MUMPS_5.8.1/0000775000175000017500000000000015042446446012447 5ustar amestoyamestoyMUMPS_5.8.1/MATLAB/0000775000175000017500000000000015042446422013401 5ustar amestoyamestoyMUMPS_5.8.1/MATLAB/mumpsmex.c0000664000175000017500000006471515042446422015435 0ustar amestoyamestoy#include "mex.h" #define MUMPS_ARITH_d 2 #define MUMPS_ARITH_z 8 #if MUMPS_ARITH == MUMPS_ARITH_z # include "zmumps_c.h" # define dmumps_c zmumps_c # define dmumps_par zmumps_par # define DMUMPS_STRUC_C ZMUMPS_STRUC_C # define DMUMPS_alloc ZMUMPS_alloc # define DMUMPS_free ZMUMPS_free # define double2 mumps_double_complex # define mxREAL2 mxCOMPLEX #elif MUMPS_ARITH == MUMPS_ARITH_d # include "dmumps_c.h" # define double2 double # define mxREAL2 mxREAL # define EXTRACT_CMPLX_FROM_C_TO_MATLAB EXTRACT_FROM_C_TO_MATLAB # define EXTRACT_CMPLX_FROM_MATLAB_TOPTR EXTRACT_FROM_MATLAB_TOPTR #else # error "Only d and z arithmetics are supported" #endif #define SYM (prhs[0]) #define JOB (prhs[1]) #define ICNTL_IN (prhs[2]) #define CNTL_IN (prhs[3]) #define PERM_IN (prhs[4]) #define COLSCA_IN (prhs[5]) #define ROWSCA_IN (prhs[6]) #define RHS_IN (prhs[7]) #define VAR_SCHUR (prhs[8]) #define INST (prhs[9]) #define REDRHS_IN (prhs[10]) #define KEEP_IN (prhs[11]) #define DKEEP_IN (prhs[12]) #define A_IN (prhs[13]) #define INFO_OUT (plhs[0]) #define RINFO_OUT (plhs[1]) #define RHS_OUT (plhs[2]) #define INST_OUT (plhs[3]) #define SCHUR_OUT (plhs[4]) #define REDRHS_OUT (plhs[5]) #define PIVNUL_LIST (plhs[6]) #define PERM_OUT (plhs[7]) #define UNS_PERM (plhs[8]) #define ICNTL_OUT (plhs[9]) #define CNTL_OUT (plhs[10]) #define COLSCA_OUT (plhs[11]) #define ROWSCA_OUT (plhs[12]) #define KEEP_OUT (plhs[13]) #define DKEEP_OUT (plhs[14]) #define MYMALLOC(ptr,l,type) \ if(!(ptr = (type *) malloc(l*sizeof(type)))){ \ mexErrMsgTxt ("Malloc failed in mumpsmex.c"); \ } #define MYFREE(ptr) \ if(ptr){ \ free(ptr); \ ptr = 0; \ } #define EXTRACT_FROM_MATLAB_TOPTR(mxcomponent,mumpspointer,type,length) \ ptr_matlab = mxGetPr(mxcomponent); \ if(ptr_matlab[0] != -9999){ \ MYFREE(mumpspointer); \ MYMALLOC(mumpspointer,length,type); \ for(i=0;iirn ); MYFREE( (*dmumps_par)->jcn ); MYFREE( (*dmumps_par)->a ); MYFREE( (*dmumps_par)->irn_loc ); MYFREE( (*dmumps_par)->jcn_loc ); MYFREE( (*dmumps_par)->a_loc ); MYFREE( (*dmumps_par)->eltptr ); MYFREE( (*dmumps_par)->eltvar ); MYFREE( (*dmumps_par)->a_elt ); MYFREE( (*dmumps_par)->perm_in ); /* colsca/rowsca might have been allocated by * MUMPS but in that case the corresponding pointer * is already equal to 0 so line below will do nothing */ MYFREE( (*dmumps_par)->colsca ); MYFREE( (*dmumps_par)->rowsca ); MYFREE( (*dmumps_par)->pivnul_list ); MYFREE( (*dmumps_par)->listvar_schur ); MYFREE( (*dmumps_par)->sym_perm ); MYFREE( (*dmumps_par)->uns_perm ); MYFREE( (*dmumps_par)->irhs_ptr); MYFREE( (*dmumps_par)->irhs_sparse); MYFREE( (*dmumps_par)->rhs_sparse); MYFREE( (*dmumps_par)->rhs); MYFREE( (*dmumps_par)->redrhs); MYFREE(*dmumps_par); } } void DMUMPS_alloc(DMUMPS_STRUC_C **dmumps_par){ MYMALLOC((*dmumps_par),1,DMUMPS_STRUC_C); (*dmumps_par)->irn = NULL; (*dmumps_par)->jcn = NULL; (*dmumps_par)->a = NULL; (*dmumps_par)->irn_loc = NULL; (*dmumps_par)->jcn_loc = NULL; (*dmumps_par)->a_loc = NULL; (*dmumps_par)->eltptr = NULL; (*dmumps_par)->eltvar = NULL; (*dmumps_par)->a_elt = NULL; (*dmumps_par)->perm_in = NULL; (*dmumps_par)->colsca = NULL; (*dmumps_par)->rowsca = NULL; (*dmumps_par)->rhs = NULL; (*dmumps_par)->redrhs = NULL; (*dmumps_par)->rhs_sparse = NULL; (*dmumps_par)->irhs_sparse = NULL; (*dmumps_par)->irhs_ptr = NULL; (*dmumps_par)->pivnul_list = NULL; (*dmumps_par)->listvar_schur = NULL; (*dmumps_par)->schur = NULL; (*dmumps_par)->sym_perm = NULL; (*dmumps_par)->uns_perm = NULL; } void mexFunction(int nlhs, mxArray *plhs[ ], int nrhs, const mxArray *prhs[ ]) { int i,j,pos; int *ptr_int; double *ptr_matlab; #if MUMPS_ARITH == MUMPS_ARITH_z double *ptri_matlab; #endif mwSize tmp_m,tmp_n; /* C pointer for input parameters */ size_t inst_address; mwSize n,m,ne, netrue ; int job; mwIndex *irn_in,*jcn_in; /* variable for multiple and sparse rhs */ int posrhs; mwSize nbrhs,ldrhs, nz_rhs; mwIndex *irhs_ptr, *irhs_sparse; double *rhs_sparse; #if MUMPS_ARITH == MUMPS_ARITH_z double *im_rhs_sparse; #endif DMUMPS_STRUC_C *dmumps_par; int dosolve = 0; int donullspace = 0; int doanalysis = 0; int dofactorize = 0; EXTRACT_FROM_MATLAB_TOVAL(JOB,job); doanalysis = (job == 1 || job == 4 || job == 6); dofactorize = (job == 2 || job == 4 || job == 5 || job == 6); dosolve = (job == 3 || job == 5 || job == 6); if(job == -1){ DMUMPS_alloc(&dmumps_par); EXTRACT_FROM_MATLAB_TOVAL(SYM,dmumps_par->sym); dmumps_par->job = -1; dmumps_par->par = 1; dmumps_c(dmumps_par); dmumps_par->nz = -1; dmumps_par->nz_alloc = -1; }else{ EXTRACT_FROM_MATLAB_TOVAL(INST,inst_address); ptr_int = (int *) inst_address; dmumps_par = (DMUMPS_STRUC_C *) ptr_int; if(job == -2){ dmumps_par->job = -2; dmumps_c(dmumps_par); /* If colsca/rowsca were freed by MUMPS, dmumps_par->colsca/rowsca are now null. Application of MYFREE in call below thus ok */ DMUMPS_free(&dmumps_par); }else{ /* check of input arguments */ n = mxGetN(A_IN); m = mxGetM(A_IN); if (!mxIsSparse(A_IN) || n != m ) mexErrMsgTxt("Input matrix must be a sparse square matrix"); jcn_in = mxGetJc(A_IN); ne = jcn_in[n]; irn_in = mxGetIr(A_IN); dmumps_par->n = (int)n; if(dmumps_par->n != n) mexErrMsgTxt("Input is too big; will not work...barfing out\n"); if(dmumps_par->sym != 0) netrue = (n+ne)/2; else netrue = ne; if(dmumps_par->nz_alloc < netrue || dmumps_par->nz_alloc >= 2*netrue){ MYFREE(dmumps_par->jcn); MYFREE(dmumps_par->irn); MYFREE(dmumps_par->a); MYMALLOC((dmumps_par->jcn),(int)netrue,int); MYMALLOC((dmumps_par->irn),(int)netrue,int); MYMALLOC((dmumps_par->a),(int)netrue,double2); dmumps_par->nz_alloc = (int)netrue; if (dmumps_par->nz_alloc != netrue) mexErrMsgTxt("Input is too big; will not work...barfing out\n"); } if(dmumps_par->sym == 0){ /* if analysis already performed then we only need to read numerical values Note that we suppose that matlab did not change the internal format of the matrix between the 2 calls */ if(doanalysis){ /* || dmumps_par->info[22] == 0 */ for(i=0;in;i++){ for(j=jcn_in[i];jjcn)[j] = i+1; (dmumps_par->irn)[j] = ((int)irn_in[j])+1; } } } dmumps_par->nz = (int)ne; if( dmumps_par->nz != ne) mexErrMsgTxt("Input is too big; will not work...barfing out\n"); #if MUMPS_ARITH == MUMPS_ARITH_z ptr_matlab = mxGetPr(A_IN); for(i=0;inz;i++){ ((dmumps_par->a)[i]).r = ptr_matlab[i]; } ptr_matlab = mxGetPi(A_IN); if(ptr_matlab){ for(i=0;inz;i++){ ((dmumps_par->a)[i]).i = ptr_matlab[i]; } }else{ for(i=0;inz;i++){ ((dmumps_par->a)[i]).i = 0.0; } } #else ptr_matlab = mxGetPr(A_IN); for(i=0;inz;i++){ (dmumps_par->a)[i] = ptr_matlab[i]; } #endif }else{ /* in the symmetric case we do not need to check doanalysis */ pos = 0; ptr_matlab = mxGetPr(A_IN); #if MUMPS_ARITH == MUMPS_ARITH_z ptri_matlab = mxGetPi(A_IN); #endif for(i=0;in;i++){ for(j=jcn_in[i];j= i){ if(pos >= netrue) mexErrMsgTxt("Input matrix must be symmetric"); (dmumps_par->jcn)[pos] = i+1; (dmumps_par->irn)[pos] = (int)irn_in[j]+1; #if MUMPS_ARITH == MUMPS_ARITH_z ((dmumps_par->a)[pos]).r = ptr_matlab[j]; if(ptri_matlab){ ((dmumps_par->a)[pos]).i = ptri_matlab[j]; }else{ ((dmumps_par->a)[pos]).i = 0.0; } #else (dmumps_par->a)[pos] = ptr_matlab[j]; #endif pos++; } } } dmumps_par->nz = pos; } EXTRACT_FROM_MATLAB_TOVAL(JOB,dmumps_par->job); EXTRACT_FROM_MATLAB_TOARR(ICNTL_IN,dmumps_par->icntl,int,60); EXTRACT_FROM_MATLAB_TOARR(CNTL_IN,dmumps_par->cntl,double,15); EXTRACT_FROM_MATLAB_TOPTR(PERM_IN,(dmumps_par->perm_in),int,((int)n)); /* colsca and rowsca are treated differently: it may happen that dmumps_par-> colsca is nonzero because it was set to a nonzero value on output (COLSCA_OUT) from MUMPS. Unfortunately if scaling was on output, one cannot currently provide scaling on input afterwards without reinitializing the instance */ EXTRACT_SCALING_FROM_MATLAB_TOPTR(COLSCA_IN,(dmumps_par->colsca),(dmumps_par->colsca_from_mumps),((int)n)); /* type always double */ EXTRACT_SCALING_FROM_MATLAB_TOPTR(ROWSCA_IN,(dmumps_par->rowsca),(dmumps_par->rowsca_from_mumps),((int)n)); /* type always double */ EXTRACT_FROM_MATLAB_TOARR(KEEP_IN,dmumps_par->keep,int,500); EXTRACT_FROM_MATLAB_TOARR(DKEEP_IN,dmumps_par->dkeep,double,230); dmumps_par->size_schur = (int)mxGetN(VAR_SCHUR); EXTRACT_FROM_MATLAB_TOPTR(VAR_SCHUR,(dmumps_par->listvar_schur),int,dmumps_par->size_schur); if(!dmumps_par->listvar_schur) dmumps_par->size_schur = 0; ptr_matlab = mxGetPr (RHS_IN); /* * To follow the "spirit" of the Matlab/Scilab interfaces, treat case of null * space separately. In that case, we initialize lrhs and nrhs, automatically * allocate the space needed, and do not rely on what is provided by the user * in component RHS, that is not touched. * * Note that, at the moment, the user should not call the solution step combined * with the factorization step when he/she sets icntl[25-1] to a non-zero value. * Hence we suppose in the following that infog[28-1] is available and that we * can use it. * * For users of scilab/matlab, it would still be nice to be able to set ICNTL(25)=-1, * and use JOB=6. If we want to make such a feature available, we should * call separately job=2 and job=3 even if job=5 or 6 and set nbrhs (and allocate * space correctly) between job=2 and job=3 calls to MUMPS. * */ if ( dmumps_par->icntl[25-1] == -1 && dmumps_par->infog[28-1] > 0 ) { dmumps_par->nrhs=dmumps_par->infog[28-1]; donullspace = dosolve; } else if ( dmumps_par->icntl[25-1] > 0 && dmumps_par->icntl[25-1] <= dmumps_par->infog[28-1] ) { dmumps_par->nrhs=1; donullspace = dosolve; } else { donullspace=0; } if (donullspace) { nbrhs=dmumps_par->nrhs; ldrhs=n; dmumps_par->lrhs=(int)n; MYMALLOC((dmumps_par->rhs),((dmumps_par->n)*(dmumps_par->nrhs)),double2); } else if((!dosolve) || ptr_matlab[0] == -9999 ) { /* rhs not already provided, or not used */ /* Case where dosolve is true and ptr_matlab[0]=-9999, this could cause problems: * 1/ RHS was not initialized while it should have been * 2/ RHS was explicitely initialized to -9999 but is not allocated of the right size */ EXTRACT_CMPLX_FROM_MATLAB_TOPTR(RHS_IN,(dmumps_par->rhs),double,1); }else{ nbrhs = mxGetN(RHS_IN); ldrhs = mxGetM(RHS_IN); dmumps_par->nrhs = (int)nbrhs; dmumps_par->lrhs = (int)ldrhs; if(ldrhs != n){ mexErrMsgTxt ("Incompatible number of rows in RHS"); } if (!mxIsSparse(RHS_IN)){ /* full rhs */ dmumps_par->icntl[20-1] = 0; EXTRACT_CMPLX_FROM_MATLAB_TOPTR(RHS_IN,(dmumps_par->rhs),double,(int)( dmumps_par->nrhs*ldrhs)); }else{ /* sparse rhs */ /* printf("sparse RHS ldrhs = %d nrhs = %d\n",ldrhs,nbrhs); */ if (dmumps_par->icntl[30-1] == 0) { /* A-1 feature was not requested => we are in the standard * sparse RHS case and thus we set ICNTL(20) accordingly. */ dmumps_par->icntl[20-1] = 1; } irhs_ptr = mxGetJc(RHS_IN); irhs_sparse = mxGetIr(RHS_IN); rhs_sparse = mxGetPr(RHS_IN); #if MUMPS_ARITH == MUMPS_ARITH_z im_rhs_sparse = mxGetPi(RHS_IN); #endif nz_rhs = irhs_ptr[nbrhs]; dmumps_par->nz_rhs = (int)nz_rhs; MYMALLOC((dmumps_par->irhs_ptr),(dmumps_par->nrhs+1),int); MYMALLOC((dmumps_par->irhs_sparse), dmumps_par->nz_rhs,int); MYMALLOC((dmumps_par->rhs_sparse), dmumps_par->nz_rhs,double2); /* dmumps_par->rhs will store the solution*/ MYMALLOC((dmumps_par->rhs),((dmumps_par->nrhs*dmumps_par->lrhs)),double2); for(i=0;i< dmumps_par->nrhs;i++){ for(j=irhs_ptr[i];jirhs_sparse)[j] = irhs_sparse[j]+1; } (dmumps_par->irhs_ptr)[i] = irhs_ptr[i]+1; } (dmumps_par->irhs_ptr)[dmumps_par->nrhs] = dmumps_par->nz_rhs+1; #if MUMPS_ARITH == MUMPS_ARITH_z if(im_rhs_sparse){ for(i=0;inz_rhs;i++){ ((dmumps_par->rhs_sparse)[i]).r = rhs_sparse[i]; ((dmumps_par->rhs_sparse)[i]).i = im_rhs_sparse[i]; } }else{ for(i=0;inz_rhs;i++){ ((dmumps_par->rhs_sparse)[i]).r = rhs_sparse[i]; ((dmumps_par->rhs_sparse)[i]).i = 0.0; } } #else for(i=0;inz_rhs;i++){ (dmumps_par->rhs_sparse)[i] = rhs_sparse[i]; } #endif } } if(dmumps_par->size_schur > 0){ if (dofactorize) { MYMALLOC((dmumps_par->schur),((dmumps_par->size_schur)*(dmumps_par->size_schur)),double2); } dmumps_par->icntl[18] = 1; }else{ dmumps_par->icntl[18] = 0; } /* Reduced RHS */ if ( dmumps_par->size_schur > 0 && dosolve ) { if ( dmumps_par->icntl[26-1] == 2 ) { /* REDRHS is on input */ tmp_m= mxGetM(REDRHS_IN); tmp_n= mxGetN(REDRHS_IN); if (tmp_m != dmumps_par->size_schur || tmp_n != dmumps_par->nrhs) { mexErrMsgTxt ("bad dimensions for REDRHS in mumpsmex.c"); } EXTRACT_CMPLX_FROM_MATLAB_TOPTR(REDRHS_IN,(dmumps_par->redrhs),double,((int)tmp_m*tmp_n)); dmumps_par->lredrhs=dmumps_par->size_schur; } if ( dmumps_par->icntl[26-1] == 1 ) { /* REDRHS on output. Must be allocated before the call */ MYFREE(dmumps_par->redrhs); if(!(dmumps_par->redrhs=(double2 *)malloc((dmumps_par->size_schur*dmumps_par->nrhs)*sizeof(double2)))){ mexErrMsgTxt("malloc redrhs failed in intmumpsc.c"); } } } dmumps_c(dmumps_par); } } if(nlhs > 0){ EXTRACT_FROM_C_TO_MATLAB( INFO_OUT ,(dmumps_par->infog),80); EXTRACT_FROM_C_TO_MATLAB( RINFO_OUT ,(dmumps_par->rinfog),40); /* A-1 on output */ if ( dmumps_par->icntl[30-1] != 0 && dosolve ) { RHS_OUT = mxCreateSparse(dmumps_par->n, dmumps_par->n,dmumps_par->nz_rhs,mxREAL2); irhs_ptr = mxGetJc(RHS_OUT); irhs_sparse = mxGetIr(RHS_OUT); for(j=0;jnrhs+1;j++){ irhs_ptr[j] = (mwIndex) ((dmumps_par->irhs_ptr)[j]-1); } ptr_matlab = mxGetPr(RHS_OUT); #if MUMPS_ARITH == MUMPS_ARITH_z ptri_matlab = mxGetPi(RHS_OUT); #endif for(i=0;inz_rhs;i++){ #if MUMPS_ARITH == MUMPS_ARITH_z /* complex arithmetic */ ptr_matlab[i] = (dmumps_par->rhs_sparse)[i].r; ptri_matlab[i] = (dmumps_par->rhs_sparse)[i].i; #else /* real arithmetic */ ptr_matlab[i] = (dmumps_par->rhs_sparse)[i]; #endif irhs_sparse[i] = (mwIndex)((dmumps_par->irhs_sparse)[i]-1); } } else if(dmumps_par->rhs && dosolve){ /* nbrhs may not have been set (case of null space) */ nbrhs=dmumps_par->nrhs; RHS_OUT = mxCreateDoubleMatrix (dmumps_par->n,dmumps_par->nrhs,mxREAL2); ptr_matlab = mxGetPr (RHS_OUT); #if MUMPS_ARITH == MUMPS_ARITH_z ptri_matlab = mxGetPi (RHS_OUT); for(j=0;jnrhs;j++){ posrhs = j*(int)n; for(i=0;in;i++){ ptr_matlab[posrhs+i]= (dmumps_par->rhs)[posrhs+i].r; ptri_matlab[posrhs+i]= (dmumps_par->rhs)[posrhs+i].i; } } #else for(j=0;jnrhs;j++){ posrhs = j*dmumps_par->n; for(i=0;in;i++){ ptr_matlab[posrhs+i]= (dmumps_par->rhs)[posrhs+i]; } } #endif }else{ EXTRACT_CMPLX_FROM_C_TO_MATLAB( RHS_OUT,(dmumps_par->rhs),1); } ptr_int = (int *)dmumps_par; inst_address = (size_t) ptr_int; EXTRACT_FROM_C_TO_MATLAB( INST_OUT ,&inst_address,1); EXTRACT_FROM_C_TO_MATLAB( PIVNUL_LIST,dmumps_par->pivnul_list,dmumps_par->infog[27]); EXTRACT_FROM_C_TO_MATLAB( PERM_OUT ,dmumps_par->sym_perm,dmumps_par->n); EXTRACT_FROM_C_TO_MATLAB( UNS_PERM ,dmumps_par->uns_perm,dmumps_par->n); EXTRACT_FROM_C_TO_MATLAB( ICNTL_OUT ,dmumps_par->icntl,60); EXTRACT_FROM_C_TO_MATLAB( CNTL_OUT ,dmumps_par->cntl,15); EXTRACT_FROM_C_TO_MATLAB( ROWSCA_OUT ,dmumps_par->rowsca,dmumps_par->n); EXTRACT_FROM_C_TO_MATLAB( COLSCA_OUT ,dmumps_par->colsca,dmumps_par->n); EXTRACT_FROM_C_TO_MATLAB( KEEP_OUT ,dmumps_par->keep,500); EXTRACT_FROM_C_TO_MATLAB( DKEEP_OUT ,dmumps_par->dkeep,230); if(dmumps_par->size_schur > 0 && dofactorize){ SCHUR_OUT = mxCreateDoubleMatrix(dmumps_par->size_schur,dmumps_par->size_schur,mxREAL2); ptr_matlab = mxGetPr (SCHUR_OUT); #if MUMPS_ARITH == MUMPS_ARITH_z ptri_matlab = mxGetPi (SCHUR_OUT); for(i=0;isize_schur;i++){ pos = i*(dmumps_par->size_schur); for(j=0;jsize_schur;j++){ ptr_matlab[j+pos] = ((dmumps_par->schur)[j+pos]).r; ptri_matlab[j+pos] = ((dmumps_par->schur)[j+pos]).i; } } #else for(i=0;isize_schur;i++){ pos = i*(dmumps_par->size_schur); for(j=0;jsize_schur;j++){ ptr_matlab[j+pos] = (dmumps_par->schur)[j+pos]; } } #endif }else{ SCHUR_OUT = mxCreateDoubleMatrix(1,1,mxREAL2); ptr_matlab = mxGetPr (SCHUR_OUT); ptr_matlab[0] = -9999; #if MUMPS_ARITH == MUMPS_ARITH_z ptr_matlab = mxGetPi (SCHUR_OUT); ptr_matlab[0] = -9999; #endif } /* REDRHS on output */ if ( dmumps_par->icntl[26-1]==1 && dmumps_par->size_schur > 0 && dosolve ) { REDRHS_OUT = mxCreateDoubleMatrix(dmumps_par->size_schur,dmumps_par->nrhs,mxREAL2); ptr_matlab = mxGetPr(REDRHS_OUT); #if MUMPS_ARITH == MUMPS_ARITH_z ptri_matlab = mxGetPi (REDRHS_OUT); #endif for(i=0;inrhs*dmumps_par->size_schur;i++){ #if MUMPS_ARITH == MUMPS_ARITH_z ptr_matlab[i] = ((dmumps_par->redrhs)[i]).r; ptri_matlab[i] = ((dmumps_par->redrhs)[i]).i; #else ptr_matlab[i] = ((dmumps_par->redrhs)[i]); #endif } }else{ REDRHS_OUT = mxCreateDoubleMatrix(1,1,mxREAL2); ptr_matlab = mxGetPr (REDRHS_OUT); ptr_matlab[0] = -9999; #if MUMPS_ARITH == MUMPS_ARITH_z ptr_matlab = mxGetPi (REDRHS_OUT); ptr_matlab[0] = -9999; #endif } MYFREE(dmumps_par->redrhs); MYFREE(dmumps_par->schur); MYFREE(dmumps_par->irhs_ptr); MYFREE(dmumps_par->irhs_sparse); MYFREE(dmumps_par->rhs_sparse); MYFREE(dmumps_par->rhs); } } MUMPS_5.8.1/MATLAB/printmumpsstat.m0000664000175000017500000000256115042446422016675 0ustar amestoyamestoyfunction printmumpsstat(id) % % printmumpsstat(id) % print mumps info % disp(['After analysis : Estimated operations ' num2str(id.RINFOG(1))]); disp(['After analysis : Estimated space for factors ' int2str(id.INFOG(3))]); disp(['After analysis : Estimated integer space ' int2str(id.INFOG(4))]); disp(['After analysis : Estimated max front size ' int2str(id.INFOG(5))]); disp(['After analysis : Number of node in the tree ' int2str(id.INFOG(6))]); disp(['After analysis : Estimated total size (Mbytes) ' int2str(id.INFOG(17))]); disp(['After factorization : Assembly operations ' num2str(id.RINFOG(2))]); disp(['After factorization : Elimination operations ' num2str(id.RINFOG(3))]); disp(['After factorization : Real/Complex space to store LU ' int2str(id.INFOG(9))]); disp(['After factorization : Integer space to store LU ' int2str(id.INFOG(10))]); disp(['After factorization : Largest front size ' int2str(id.INFOG(11))]); disp(['After factorization : Number of off-diagonal pivots ' int2str(id.INFOG(12))]); disp(['After factorization : Number of delayed pivots ' int2str(id.INFOG(13))]); disp(['After factorization : Number of memory compresses ' int2str(id.INFOG(14))]); disp(['After factorization : Total size needed (Mbytes) ' int2str(id.INFOG(19))]); MUMPS_5.8.1/MATLAB/schur_example.m0000664000175000017500000000421415042446422016417 0ustar amestoyamestoy%Example of using MUMPS in matlab with schur option % initialization of a matlab MUMPS structure id = initmumps; id = dmumps(id); load lhr01; mat = Problem.A; themax = max(max(abs(mat))); n = size(mat,1); mat = mat+sparse(1:n,1:n,3*themax*ones(n,1)); % initialization of Schur option id.VAR_SCHUR = [n-9:n]; % JOB = 6 means analysis+facto+solve id.JOB = 6; id.RHS = ones(size(mat,1),1); %call to mumps id = dmumps(id,mat); disp('*** check solution restricted to mat(1:n-10,1:n-10)'); if(norm(mat(1:n-10,1:n-10)*id.SOL(1:n-10) - ones(n-10,1),'inf') > sqrt(eps)) disp('WARNING : precision may not be OK'); else disp('SCHUR SOLUTION CHECK1 OK'); end norm(mat(1:n-10,1:n-10)*id.SOL(1:n-10) - ones(n-10,1),'inf') % we want to use Schur complement to solve % A * sol = rhs % with sol = x and rhs = rhs1 % y rhs2 % % check that the complete solution verify % y = S^(-1) * (rhs2 - A_{2,1} * A_{1,1}^(-1) * rhs1) % and % x = A_{1,1}^(-1) * rhs1) - A_{1,2} * y % sol1 = id.SOL(1:n-10); rhsy = ones(10,1)-mat(n-9:n,1:n-10)*sol1; %%%%%%%%%%%%%%%%%%% % TO CHANGE : % usually the resolution below is replaced by an iterative scheme y = id.SCHUR \ rhsy; %%%%%%%%%%%%%%%%%%%% rhsx = mat(1:n-10,n-9:n)*y; id.JOB = 3; id.RHS(1:n-10) = rhsx; id = dmumps(id,mat); rhsx = id.SOL(1:n-10); x = sol1-rhsx; sol = [x;y]; r = mat*sol - ones(n,1); disp('*** check complete solution'); if( norm(r,'inf') > sqrt(eps)) disp('WARNING : precision may not be OK'); else disp('SCHUR SOLUTION CHECK2 OK'); end norm(r,'inf') %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % NOW TRY REDUCED RHS FUNCTIONALITY % (easier to use than previous % computations) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% id.JOB=3; % Do forward solution step to obtain a reduced RHS id.ICNTL(26)=1; RHS=mat*ones(n,1); id.RHS=RHS; id = dmumps(id,mat); % Solve the problem on the interface id.REDRHS = id.SCHUR \ id.REDRHS; % Do backward solution stage to expand the solution id.ICNTL(26)=2; id = dmumps(id,mat); r = mat*id.SOL-RHS; disp('*** check solution when REDRHS is used'); if( norm(r,'inf') > sqrt(eps)) disp('WARNING : precision may not be OK'); else disp('SCHUR SOLUTION CHECK3 OK'); end norm(r,'inf') MUMPS_5.8.1/MATLAB/mumps_help.m0000664000175000017500000001172415042446422015735 0ustar amestoyamestoy%**************************************** %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. Some parameters related to distributed environments should not be modifed. For example, the solution should always be centralized and id.ICNTL(21) should thus remain to its default value, 0. Note that parameters id.ICNTL(1:4) may not work properly depending on your compiler and your environment. In case of problem, we recommand to swith printing off by setting id.ICNL(1:4)=-1. % % - id.PERM\_IN: corresponds to the given ordering option (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). Note that this permutation is only accessed if the parameter id.ICNTL(7) is set to 1. % % - id.COLSCA and id.ROWSCA: are optional scaling arrays (see Section ``Input and output parameters'' of the MUMPS user's guide for more details) % % - id.RHS: defines the right-hand side. The parameter id.ICNTL(20) related to its format (sparse or dense) is automatically set within the interface. Note that id.RHS is not modified (as in MUMPS), the solution is returned in id.SOL. % % - id.VAR\_SCHUR: corresponds to the list of variables that appear in the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). % % - id.REDRHS(input parameter only if id.VAR\_SCHUR was provided during the factorization and if ICNTL(26)=2 on entry to the solve phase): partial solution on the variables corresponding to the Schur complement. It is provided by the user and normally results from both the Schur complement and the reduced right-hand side that were returned by MUMPS in a previous call. When ICNTL(26)=2, MUMPS uses this information to build the solution id.SOL on the complete problem. See Section ``Schur complement'' of the MUMPS user's guide for more details. % %--------------- Output Parameters --------------- % % - id.SCHUR: if id.VAR\_SCHUR is provided of size SIZE\_SCHUR, then id.SCHUR corresponds to a dense array of size (SIZE\_SCHUR,SIZE\_SCHUR) that holds the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). The user does not have to initialize it. % % - id.REDRHS(output parameter only if ICNTL(26)=1 and id.VAR\_SCHUR was defined): Reduced right-hand side (or condensed right-hand side on the variables associated to the Schur complement). It is computed by MUMPS during the solve stage if ICNTL(26)=1. It can then be used outside MUMPS, together with the Schur complement, to build a solution on the interface. See Section ``Schur complement'' of the MUMPS user's guide for more details. % % - id.INFOG and id.RINFOG: information parameters (see Section ``Information parameters'' of the MUMPS user's guide ). % % - id.SYM\_PERM: corresponds to a symmetric permutation of the variables (see discussion regarding ICNTL(7) in Section ``Control parameters'' of the MUMPS user's guide ). This permutation is computed during the analysis and is followed by the numerical factorization except when numerical pivoting occurs. % % - id.UNS\_PERM: column permutation (if any) on exit from the analysis phase of MUMPS (see discussion regarding ICNTL(6) in Section ``Control parameters'' of the MUMPS user's guide ). % % - id.SOL: dense vector or matrix containing the solution after MUMPS solution phase. Also contains the nullspace in case of null space computation, or entries of the inverse, in case of computation of inverse entries. % %--------------- Internal Parameters --------------- % % - id.INST: (MUMPS reserved component) MUMPS internal parameter. % % - id.TYPE: (MUMPS reserved component) defines the arithmetic (complex or double precision). % MUMPS_5.8.1/MATLAB/dmumps.m0000664000175000017500000000467115042446422015074 0ustar amestoyamestoyfunction [id]=dmumps(id,mat) % % [id]=dmumps(id,mat) % id is a structure (see details in initmumps.m and MUMPS documentation) % mat is optional if the job is -1 or -2 % mat is a square sparse matrice % information are return in id fields % % Use help mumps_help for detailed information % errmsg = nargoutchk(1,1,nargout); if(~isempty(errmsg)) disp(errmsg); return; end arithtype = 1; if(id.JOB == -2) if(id.INST==-9999) disp('Uninitialized instance'); return; end if(id.TYPE ~= arithtype) disp('You are trying to call z/d version on a d/z instance'); return; end dmumpsmex(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS,id.KEEP,id.DKEEP); id = []; return; end if(id.JOB == -1) if(id.INST~=-9999) disp('Already initialized instance'); return; end [inform,rinform,sol,inst,schur,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl,colsca_out,rowsca_out,keep_out,dkeep_out] = dmumpsmex(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS,id.KEEP,id.DKEEP); id.INFOG = inform; id.RINFOG = rinform; id.SOL = sol; id.INST = inst; id.SCHUR = schur; id.REDRHS = redrhs; id.PIVNUL_LIST = pivnul_list; id.SYM_PERM = sym_perm; id.UNS_PERM = uns_perm; id.TYPE = arithtype; id.ICNTL = icntl; id.CNTL = cntl; id.COLSCA = colsca_out; id.ROWSCA = rowsca_out; id.KEEP = keep_out; id.DKEEP = dkeep_out; return; end if(id.INST==-9999) disp('Uninitialized instance'); return; end if(id.TYPE ~= arithtype) disp('You are trying to call z/d version on a d/z instance'); return; end [inform,rinform,sol,inst,schur,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl,colsca_out,rowsca_out,keep_out,dkeep_out] = dmumpsmex(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS,id.KEEP,id.DKEEP,mat); id.INFOG = inform; id.RINFOG = rinform; id.SOL = sol; id.INST = inst; if(id.JOB == 2 | id.JOB == 4 | id.JOB == 6) if(id.SYM == 0) id.SCHUR = schur'; else id.SCHUR = triu(schur)+tril(schur',-1); end end id.REDRHS = redrhs; id.PIVNUL_LIST = pivnul_list; id.SYM_PERM(sym_perm) = [1:size(mat,1)]; id.UNS_PERM = uns_perm; id.ICNTL=icntl; id.CNTL=cntl; id.COLSCA=colsca_out; id.ROWSCA=rowsca_out; id.KEEP=keep_out; id.DKEEP=dkeep_out; MUMPS_5.8.1/MATLAB/initmumps.m0000664000175000017500000000116015042446422015602 0ustar amestoyamestoyfunction id = initmumps() % % id = initmumps % it returns a default matlab MUMPS structure % % Use help mumps_help for detailed information % errmsg = nargoutchk(1,1,nargout); if(~isempty(errmsg)) disp(errmsg); return; end id = struct('SYM',0,'JOB',-1,'ICNTL',zeros(1,60)-9998,'CNTL',zeros(1,15)-9998,'PERM_IN',-9999,'COLSCA',-9999,'ROWSCA',-9999,'RHS',-9999,'INFOG',zeros(1,80)-9998,'RINFOG',zeros(1,40)-9998,'VAR_SCHUR',-9999,'SCHUR',-9999,'INST',-9999,'SOL',-9999,'REDRHS',-9999,'PIVNUL_LIST',-9999,'MAPPING',-9999,'SYM_PERM',-9999,'UNS_PERM',-9999,'TYPE',0,'KEEP',zeros(1,500)-9998,'DKEEP',zeros(1,230)-9998); MUMPS_5.8.1/MATLAB/lhr01.mat0000664000175000017500000074250015042446422015042 0ustar amestoyamestoyMATLAB 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/lhr01MUMPS_5.8.1/MATLAB/zmumps.m0000664000175000017500000000467115042446422015122 0ustar amestoyamestoyfunction [id]=zmumps(id,mat) % % [id]=zmumps(id,mat) % id is a structure (see details in initmumps.m and MUMPS documentation) % mat is optional if the job is -1 or -2 % mat is a square sparse matrice % information are return in id fields % % Use help mumps_help for detailed information % errmsg = nargoutchk(1,1,nargout); if(~isempty(errmsg)) disp(errmsg); return; end arithtype = 2; if(id.JOB == -2) if(id.INST==-9999) disp('Uninitialized instance'); return; end if(id.TYPE ~= arithtype) disp('You are trying to call z/d version on a d/z instance'); return; end zmumpsmex(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS,id.KEEP,id.DKEEP); id = []; return; end if(id.JOB == -1) if(id.INST~=-9999) disp('Already initialized instance'); return; end [inform,rinform,sol,inst,schur,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl,colsca_out,rowsca_out,keep_out,dkeep_out] = zmumpsmex(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS,id.KEEP,id.DKEEP); id.INFOG = inform; id.RINFOG = rinform; id.SOL = sol; id.INST = inst; id.SCHUR = schur; id.REDRHS = redrhs; id.PIVNUL_LIST = pivnul_list; id.SYM_PERM = sym_perm; id.UNS_PERM = uns_perm; id.TYPE = arithtype; id.ICNTL = icntl; id.CNTL = cntl; id.COLSCA = colsca_out; id.ROWSCA = rowsca_out; id.KEEP = keep_out; id.DKEEP = dkeep_out; return; end if(id.INST==-9999) disp('Uninitialized instance'); return; end if(id.TYPE ~= arithtype) disp('You are trying to call z/d version on a d/z instance'); return; end [inform,rinform,sol,inst,schur,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl,colsca_out,rowsca_out,keep_out,dkeep_out] = zmumpsmex(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS,id.KEEP,id.DKEEP,mat); id.INFOG = inform; id.RINFOG = rinform; id.SOL = sol; id.INST = inst; if(id.JOB == 2 | id.JOB == 4 | id.JOB == 6) if(id.SYM == 0) id.SCHUR = schur'; else id.SCHUR = triu(schur)+tril(schur',-1); end end id.REDRHS = redrhs; id.PIVNUL_LIST = pivnul_list; id.SYM_PERM(sym_perm) = [1:size(mat,1)]; id.UNS_PERM = uns_perm; id.ICNTL=icntl; id.CNTL=cntl; id.COLSCA=colsca_out; id.ROWSCA=rowsca_out; id.KEEP=keep_out; id.DKEEP=dkeep_out; MUMPS_5.8.1/MATLAB/sparserhs_example.m0000664000175000017500000000112315042446422017301 0ustar amestoyamestoy%Example of using MUMPS in matlab with sparse right hansd side % initialization of a matlab MUMPS structure id = initmumps; id = dmumps(id); load lhr01; mat = Problem.A; % JOB = 6 means analysis+facto+solve id.JOB = 6; % we set the rigth hand side id.RHS = ones(size(mat,1),2); id.RHS(:,2) = 2*id.RHS(:,2); id.RHS = sparse(id.RHS); %call to mumps id = dmumps(id,mat); if(norm(mat*id.SOL - id.RHS,'inf') > sqrt(eps)) disp('WARNING : precision may not be OK'); else disp('SOLUTION OK'); end norm(mat*id.SOL - id.RHS,'inf') % solution OK % destroy mumps instance id.JOB = -2; id = dmumps(id) MUMPS_5.8.1/MATLAB/Makefile0000664000175000017500000000135615042446422015046 0ustar amestoyamestoy# Please only change make.inc, not this Makefile include make.inc # MUMPS include files INCMUMPS = -I$(MUMPS_DIR)/include # MUMPS libraries LIBMUMPS = -L$(MUMPS_DIR)/lib -l$(ARITH)mumps -lmumps_common # Stub MPI/BLACS/ScaLAPACK INCSEQ = -I$(MUMPS_DIR)/libseq LIBSEQ = -L$(MUMPS_DIR)/libseq -lmpiseq # MUMPS includes INC = $(INCMUMPS) $(IORDERINGS) $(INCSEQ) LIB = $(LIBMUMPS) $(LORDERINGS) $(LIBSEQ) $(LIBBLAS) $(LIBFORT) all: d z d: $(MAKE) ARITH=d dmumpsmex.stamp z: $(MAKE) ARITH=z zmumpsmex.stamp clean: rm -f dmumpsmex.* zmumpsmex* $(ARITH)mumpsmex.stamp: mumpsmex.c cp -f mumpsmex.c $(ARITH)mumpsmex.c $(MEX) $(OPTC) $(ARITH)mumpsmex.c -DMUMPS_ARITH=MUMPS_ARITH_$(ARITH) $(INC) $(LIB) rm -f $(ARITH)mumpsmex.c touch $@ MUMPS_5.8.1/MATLAB/make.inc0000664000175000017500000000367115042446422015020 0ustar amestoyamestoy# It is possible to generate a MATLAB or an Octave interface thanks to # the Octave MEX file compatibility. Comment/uncomment the lines below # depending on whether you want to generate the MATLAB or the Octave # interface # To generate the MATLAB interface uncomment the following line # ( the use of -largeArrayDims is necessary to work with sparse # matrices since R2006b) MEX = /opt/matlab/matlab/bin/mex -g -largeArrayDims # To generate the Octave interface uncomment the following line # MEX = mkoctfile -g --mex # Main MUMPS_DIR MUMPS_DIR = $(HOME)/MUMPS_5.8.1 # Orderings (see main Makefile.inc file from MUMPS) LMETISDIR = ${HOME}/parmetis-4.0.3/build/Linux-x86_64/libmetis LMETIS = -L$(LMETISDIR) -lmetis LPORDDIR = $(MUMPS_DIR)/PORD/lib LPORD = -L$(LPORDDIR) -lpord LORDERINGS = $(LPORD) $(LMETIS) # Fortran runtime library # Please find out the path and name of your # Fortran runtime, examples below: # g95: # LIBFORT = /usr/lib/libf95.a /usr/lib/libgcc.a # Intel: # LIBFORT = /opt/intel80/lib/libifcore.a /opt/intel80/lib/libifport.a /opt/intel80/lib/libirc.a # PGI: # LIBFORT = -L/usr/local/pgi/linux86/5.2/lib -llapack -lblas -lpgf90 -lpgc -lpgf90rtl -lpgftnrtl -lpgf902 -lpgf90_rpm1 -lpghpf2 # SGI 32-bit # LIBFORT = -L/usr/lib32 -lblas -L/usr/lib32/mips4 -lfortran # Sun # LIBFORT = -L/opt2/SUNWspro7/lib -lsunperf -lfminvai -lfai2 -lfsu -lfmaxvai -lfmaxlai -lfai -lfsumai -lLIBFORT = /usr/local/lib/libgfortran.a # gfortran LIBFORT = /usr/lib/gcc/x86_64-linux-gnu/4.7/libgfortran.so # BLAS library: # LIBBLAS = -L/usr/lib/atlas -lblas # LIBBLAS = -lsunperf -lf77compat # LIBBLAS = -lblas LIBBLAS = /home/jylexcel/libs_courge/libgoto_opteronp-r1.26.a # LIBBLAS = /home/jylexcel/libs_courge/libblas.a # -fPIC missing # LIBBLAS = /usr/lib/libblas.so # extra options passed via mex command # Add -DINTSIZE64 if MUMPS was compiled with 64-bit integers (BLAS # library should then have 64-bit integers as well) OPTC = -g MUMPS_5.8.1/MATLAB/diagainv_example.m0000664000175000017500000000237015042446422017056 0ustar amestoyamestoy%Example of using MUMPS in matlab to compute diagonal of inverse of A % Change to true to test example complex arithmetic complex_arithmetic = false; % initialization of a matlab MUMPS structure id = initmumps; if (complex_arithmetic) id = zmumps(id); else id = dmumps(id); end load lhr01; mat = Problem.A; if (complex_arithmetic) % To test complex version mat = mat + i * speye(size(mat,1),size(mat,1)); end % JOB = 4 means analysis+factorization id.JOB = 4; if (complex_arithmetic) id = zmumps(id,mat); else id = dmumps(id,mat); end % Set the right hand side structure to requested entries of A-1 id.RHS = speye(size(mat,1),size(mat,1)); % Sparse format required %call MUMPS solution phase to compute diagonal entries of A-1 id.ICNTL(30)=1; % Ask for A-1 entries id.JOB=3; if (complex_arithmetic) id = zmumps(id,mat); else id = dmumps(id,mat); end % diagonal values have been computed in % the (sparse) matrix id.SOL, which has % the same structure as id.RHS % Compare diagonal of inverse computed by Mumps and by matlab disp(' '); disp('Computing 2-norm of error on diagonal of inverse:'); norm(diag( diag(diag(inv(mat)))-id.SOL ),2) % destroy mumps instance id.JOB = -2; if (complex_arithmetic) id = zmumps(id) else id = dmumps(id) end MUMPS_5.8.1/MATLAB/README0000664000175000017500000001107515042446422014265 0ustar amestoyamestoyREADME ************************************************************************ * This MATLAB interface to MUMPS is part of the MUMPS package * * (see ../LICENSE for the conditions of use) * * Up-to-date copies of MUMPS can be obtained from the web * * page http://mumps-solver.org * * * * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY * * EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. * * * * More information is available in the main MUMPS userguide and in: * * * * [2006] Aurelia Fevre, Jean-Yves L'Excellent and Stephane Pralet * * MATLAB and Scilab interfaces to MUMPS. LIP Report RR2006-06. * * Also available as INRIA and ENSEEIHT-IRIT Technical Reports. * * * ************************************************************************ ************************************************************************ COMPATIBILITY WITH OCTAVE: Thanks to the Octave MEX compatibility, it is pretty straightforward to generate an Octave interface for MUMPS. Please refer to the comments inside the make.inc file for instructions on how to do it. Everything said below applies for both cases where a MATLAB or an Octave interface is needed. Thanks to Carlo De Falco from "Politecnico di Milano" for support provided on the usage of Octave. ************************************************************************ CONTENT OF DIRECTORY: README Makefile make.inc initmumps.m mumps.m other *.m files: examples of usage mumpsmex.c : MATLAB CMEX-file to let you use sequential MUMPS in double precision from MATLAB. USAGE: see example below and MUMPS documentation INSTALLATION: You need 1- to have compiled/linked a sequential version of MUMPS with both double precision and double complex arithmetics ("make d" and "make z", or "make all"). The code must be position-independent (with gfortran, please add the option -fPIC in both FC, CC, and FL of the main Makefile.inc). Note that this also applies to other external libraries, such as METIS, SCOTCH, BLAS, etc. 2- to specify an adequate BLAS library. Unless you compile with the option -DINTSIZE64, MUMPS expects 32-bit integers by default (see the MUMPS_INT datatype in mumps_c_types.h). In that case, you should specify a BLAS library relying on 32-bit integers. Otherwise, an error at execution time is likely to occur (e.g., "segmentation fault in idamax"). If you use a shared library, make sure that Matlab will not override your default BLAS library (One way to do that is to issue LD_PRELOAD=my_blas_library.so matlab instead matlab) 2- to edit make.inc. Modify paths for orderings and BLAS. You should also give the path to the runtime libraries of your FORTRAN 90 compiler. Some commented examples are provided. You can use something like nm -o /opt/intel/compiler80/lib/*.a | grep to help finding which libraries should be added 3- to run the "make" command 4- We advise you to run the 4 examples simple_example.m, multiplerhs_example.m, sparserhs_example.m and schur_example.m and to check that everything runs smoothly. ****************************************************************************** LIMITATION: This interface enables you to call MUMPS from MATLAB only in sequential for double precision and double complex versions. For example it does not support: - other versions (single precision arithmetic, parallel version...) - elemental format for the input matrix ****************************************************************************** %Example of using MUMPS in matlab % initialization of a matlab MUMPS structure id = initmumps; % here JOB = -1, the call to MUMPS will initialize C and fortran MUMPS structure id = dmumps(id); % load a sparse matrix load lhr01; mat = Problem.A; % JOB = 6 means analysis+factorization+solve id.JOB = 6; id.ICNTL(6) = 0; % we set the rigth hand side id.RHS = ones(size(mat,1),1); %call to mumps id = dmumps(id,mat); % we see that there is a memory problem in INFO(1) and INFO(2) id.INFOG(1) id.INFOG(2) % we activate the numerical maximum transversal id.ICNTL(6) = 6; id = dmumps(id,mat); norm(mat*id.SOL - ones(size(mat,1),1),'inf') % solution OK % destroy mumps instance id.JOB = -2; id = dmumps(id) MUMPS_5.8.1/MATLAB/simple_example.m0000664000175000017500000000214115042446422016561 0ustar amestoyamestoy% Simple example of using MUMPS in matlab % initialization of a matlab MUMPS structure id = initmumps; id.SYM = 0; % here JOB = -1, the call to MUMPS will initialize C % and fortran MUMPS structure id = dmumps(id); % load a sparse matrix load lhr01; mat = Problem.A; % JOB = 6 means analysis+facto+solve %prob = UFget(373); %mat = prob.A; id.JOB = 6; %%%%%%% BEGIN OPTIONAL PART TO ILLUSTRATE THE USE OF MAXIMUM TRANSVERSAL id.ICNTL(7) = 5; id.ICNTL(6) = 1; id.ICNTL(8) = 7; id.ICNTL(14) = 80; % we set the rigth hand side id.RHS = ones(size(mat,1),1); %call to mumps id = dmumps(id,mat); % we see that there is a memory problem in INFOG(1) and INFOG(2) id.INFOG(1) id.INFOG(2) % we activate the numerical maximun transversal fprintf('total number of nonzeros in factors %d\n', id.INFOG(10)); %%%%%%% END OPTIONAL PART %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% if(norm(mat*id.SOL - ones(size(mat,1),1),'inf') > sqrt(eps)) disp('WARNING : precision may not be OK'); else disp('SOLUTION OK'); end norm(mat*id.SOL - ones(size(mat,1),1),'inf') % destroy mumps instance SOL = id.SOL; id.JOB = -2; id = dmumps(id) MUMPS_5.8.1/MATLAB/zsimple_example.m0000664000175000017500000000157015042446422016760 0ustar amestoyamestoy% Simple example of using MUMPS in matlab % initialization of a matlab MUMPS structure id = initmumps; % here JOB = -1, the call to MUMPS will initialize C % and fortran MUMPS structure id = zmumps(id); % load a sparse matrix load lhr01; mat = Problem.A; n = size(mat,1); mat = mat + sparse(1:n,1:n,i*ones(n,1)); % JOB = 6 means analysis+facto+solve id.JOB = 6; id.ICNTL(6) = 0; % we set the right hand side id.RHS = ones(size(mat,1),1); %call to mumps id = zmumps(id,mat); % we see that there is a memory problem in INFOG(1) and INFOG(2) id.INFOG(1) id.INFOG(2) % we activate the numerical maximun transversal id.ICNTL(6) = 6; id = zmumps(id,mat); if(norm(mat*id.SOL - ones(size(mat,1),1),'inf') > sqrt(eps)) disp('WARNING : precision may not be OK'); else disp('SOLUTION OK'); end norm(mat*id.SOL - ones(size(mat,1),1),'inf') % destroy mumps instance id.JOB = -2; id = zmumps(id) MUMPS_5.8.1/MATLAB/multiplerhs_example.m0000664000175000017500000000105215042446422017640 0ustar amestoyamestoy%Example of using MUMPS in matlab with multiple right hand side % initialization of a matlab MUMPS structure id = initmumps; id = dmumps(id); load lhr01; mat = Problem.A; % JOB = 6 means analysis+facto+solve id.JOB = 6; % we set the rigth hand side id.RHS = ones(size(mat,1),2); id.RHS(:,2) = 2*id.RHS(:,2); %call to mumps id = dmumps(id,mat); if(norm(mat*id.SOL - id.RHS,'inf') > sqrt(eps)) disp('WARNING : precision may not be OK'); else disp('SOLUTION OK'); end norm(mat*id.SOL - id.RHS,'inf') % destroy mumps instance id.JOB = -2; id = dmumps(id) MUMPS_5.8.1/ChangeLog0000664000175000017500000012610615042446416014224 0ustar amestoyamestoy------------- = ChangeLog = ------------- Changes from 5.8.0 to 5.8.1 * Fixed explicit interface expected in [sdcz]ana_driver.F for ftn compiler * Fixed error during MPI communication due to irregular blocks in block format * Fixed compiler semantic error detected by amdflang 6.2 in atomic statement * Fixed error when rank-revealing (ICNTL(56)) on at analysis and off at facto * Fixed performance of ICNTL(56) for highly reducible matrices * Fixed valgrind warning in [sdcz]mumps_arrow_treat_recv_buf_1th Changes from 5.7.3 to 5.8.0 * Memory estimations in an MPI context improved using stricter proportional mapping * Improved multithreading during scaling and reformat/distribute matrix * MPI buffer size not anymore constrained by factored panel sizes * Fixed a memory leak (COLSCA_LOC) in LDLT with save-restart * Enable different numbers of threads per MPI * Fixed a case where error -74 was raised instead of -77 * More OpenMP parallelism when compacting factors of frontal matrices * Fixed a minor issue in BLR clustering when size of halo is 0 * Provide statistics on iterative refinement settings and timings * Fixed error with binary format of WRITE_PROBLEM feature under WINDOWS * Avoid pivoting with SYM=1 even when user forces CNTL(1)>0 * More multithreading in low intensity arithmetic kernels * Fixed error with ICNTL(37)=1 * Fixed possible access to uninitialized var for SYM=0 + OOC + static pivoting * Fixed a valgrind warning in fac_front_*type1.F Changes from 5.7.2 to 5.7.3 * Fixed regression for I/O's larger than 2GB during solve (out-of-core) * Fixed size of internal workspace in case of OOC+BLR with ICNTL(37)=1 * Fix: out-of-range values of ICNTL(58) are treated as 2, as documented Changes from 5.7.1 to 5.7.2 * Fixed a bound check error with ICNTL(37)=1 in case of symmetric numerically difficult problems * Fixed compilation with -DAVOID_MPI_IN_PLACE Changes from 5.7.0 to 5.7.1 * Fixed dynamic library creation for PORD * Avoid need to link with deprecated LAPACK routine [csdz]geqpf * Fixed a numerical error with ICNTL(37)=1 in case of numerically difficult problems and very limited workspace Changes from 5.6.2 to 5.7.0 * New feature: Evolution of the distributed RHS: exploit sparsity (empty rows) * New feature: more efficient multithreading (see ICNTL(48)) * New feature: Improved null space detection with rank revealing (ICNTL(56)) * New statistics about pivots and number of swaps * Reduced time spent in BLR clustering * OOC: add support for files > 2GB to avoid opening too many files (requires -DMUMPS_WINLARGEFILES in Windows environments) * Increased various string max sizes: OOC_PREFIX(255), SAVE_PREFIX(255), WRITE_PROBLEM(1023), OOC_TMPDIR(1023), SAVE_DIR(1023), * -DMUMPS_SCOTCHIMPORTOMPTHREADS: uses MUMPS OMP threads in SCOTCH * Improved size of BLR groups with analysis by blocks * Allow for larger N (avoid need for 2*N to fit in a 32-bit integer) * Improved performance on small matrices (avoid costly string comparisons when computing RINFO(7,8) and RINFOG(17,18)) * -DNO_SAVE_RESTORE: suppress SAVE_RESTORE, RINFO(7,8), RINFOG(17,18) * Avoid calling MPI_IPROBE during solve in case of a single MPI process * MPI_ALLREDUCE workaround in case it fails for large buffers * Raise error -55 in case Nloc_RHS>0 on non-working host * Raise new error -88 in case of error during SCOTCH ordering * Fixed bound-check error in copies for 64 bit integer orderings and empty graph * Raise error -69 in case of installation with incorrect integer sizes * Compilation with -DNOSCALAPACK: suppress dependency on NUMROC * Fix for METIS > 5.1.0: METIS options indices no longer hardcoded * Fixed a bug in solve when restarting (JOB=8) with a new process * Fixed error with exploit sparsity during fwd phase on reducible matrices and when Scalapack is used * Makefiles: introduced SHARED_OPT=-shared to allow defining different option Changes from 5.6.1 to 5.6.2 * Fixed time for symbolic factorization * Fixed parallel analysis when PAR=0, 1 MPI per node, #MPI not a power of 2 * -DAVOID_MPI_IN_PLACE avoids MPI_IN_PLACE usage (in case not supported by MPI) * Fixed a bug in case of parallel analysis+analysis by blocks+scalapack off * Added missing $(PLAT) for libpord in makefile * Fixed message printing with error -17 Changes from 5.6.0 to 5.6.1 * Fixed compatibility of parallel analysis with analysis by blocks/out-of-range * Minor fix of INFO(2) value in a case of INFO(1)=-7 with parallel analysis * WRITE_PROBLEM: avoid leading space when printing "%%MatrixMarket matrix [..]" * Fix incorrect error code -74 instead of -76 (save-restore) * Avoid a remaining hard-coded Fortran unit (save-restore) * Avoid -Wundef warning in case __STDC_VERSION__ is not defined * Avoid calling MPI_IPROBE during factorization in case of a single MPI process (performance improvement on matrices with small fronts) * During analysis, write time for symbolic factorization * Update GEMMT link in INSTALL file Changes from 5.5.1 to 5.6.0 * Analysis by blocks and out-of-range entries compatible with parallel analysis * Compact workarray S before solution phase (ICNTL(49)=1,2) * JOB=-4 frees data from factorization and keeps results from analysis * NEC vector engine version: tuned block low rank and GEMMT usage * Reduced memory for symbolic datastructures (order-N arrays, arrowheads) * Use new symbolic factorization (column counts) by default (+allow forest in case of Schur) * Improved amalgamation algorithm to reduce the number tiny nodes * Discard factors option is now compatible with BLR * Discard L factors option in case of LU factorization available for in-core * Count null negative pivots (INFOG(50)) * Compilation with -DBLR_MT is no longer needed (see also -DBLR_NOOPENMP) * Improve performance of A-1 entries computation when #MPI > 1 * Fixed risk of hanging in case of OOC error (e.g. disk full) * Free internal data earlier (e.g., factors in case of failed factorization, etc.) * Avoid setenv/unsetenv on MinGW environments (Scotch versions >= 7) * Fix error during ordering when processing matrices of order 1 * Out-Of-Core, values of ICNTL(22) different from 1 are treated as zero (in-core) * BLKPTR ignored when ICNTL(15) < 0 (INFO(1:2)=-57 4 no longer occurs) * BLR OpenMP fac_lr.F fix for possible non-increasing scheduling of loop indices * Fix: id%LRGROUPS was not nullified in CMUMPS_FREE_ONENTRY_ANA_DRIVER * Fixed parameter error 1202 in PDGETRS after restoring a factorization * Workaround MPI_SSEND intel MPI 2021.6 issue * NEC: Fix MUMPS_WRAP_GINP94 offloading to host * Shared libraries: minor update in Makefiles * Fixed missing printings of preprocessing constants in mumps_print_defined.F * -DNOSCALAPACK: compilation without BLACS/ScaLAPACK (reduced performance) Changes from 5.5.0 to 5.5.1 * 64-bit default integer version: avoid MPI buffer size > 2^31 (could lead to negative counts in MPI_Recv with Intel ilp64 MPI) * Use ICNTL(3) unit instead of '*' to print parallel ordering time * Output symbolic factorization choice (ICNTL(58)) on ICNTL(3) unit * SCOTCH 7.x on Windows: use _putenv instead of setenv (unsymmetric case, #MPI >1) * Fixed parallel analysis in case of 64-bit integers in parmetis and -i8 MUMPS * Limit recursivity depth in mumps_static_mapping.F (limit stack usage on trees with small nodes at the top and large nodes below) * Limit subroutine names to 32 characters * -DWORKAROUNDILP64MPICUSTOMREDUCE introduced (platformMPI and 64-bit default integer) Changes from 5.4.1 to 5.5.0 * New feature: analysis by blocks with compressed graph (ICNTL(15)) * New feature: symbolic factorization using column counts (ICNTL(58)) * Matrix scaling compatible with Schur complement feature * Automatic setting of CNTL(3) and CNTL(5) compatible with Schur complement feature * Fixed possible error in memory (INFOG(3)) and FLOPS (RINFOG(1)) estimations with Schur feature * Memory allowed (ICNTL(23)) is per MPI process and compatible with WK_USER * More compact storage of L factors for symmetric matrices * Exploit multithreading in SCOTCH versions >= 7.0 * Support for NEC Aurora vector processors * Possibility to build shared instead of static libraries * Adjustment of BLR cluster size * Shorter time for matrix redistribution * Avoid a possible case of overflow in computation of MAXIS * Fixed memory estimate of PTRAIW/PTRARW arrays * -DDPRINT_BACKTRACE_ON_ABORT added in case of call to MUMPS_ABORT() * More usage of dynamic memory to avoid -9 errors * Fixed a possible "Internal error 3 in ZMUMPS_BLR_RETRIEVE_PANEL_LORU" * Change construction of mumps_int_def.h to allow for cross compilation * Fixed a possible error in deficiency detection on unsymmetric matrices * Duplicated few loops during solve (OMP / non-OMP) for gfortran performance * Fixed compilation issue with -DUPPER and -DMUMPS_WIN32 (5.4.1 regression) * Find free Fortan units instead of imposing a choice (WRITE_PROBLEM, save/restore) * Avoid freeing IRN/JCN when not allocated by MUMPS * Fixed a potential memory leak in dynamic memory management * -DALLOC_FROM_C introduced to fix dynamic memory management with Cray compilers Changes from 5.4.0 to 5.4.1 * Added feature to dump a matrix/rhs in binary form (see id%WRITE_PROBLEM) * Fixed error during constrained ordering (ICNTL(12)=3) leading to a segfault * Fixed type 2 assembly by pieces in case of huge blocks of delayed pivots * Avoid repeated small allocations in MUMPS_BUILD_SORT_INDEX * Fixed automatic choice for ICNTL(6) when values are not provided at analysis * Avoid an access to an uninitialized value (FLOP_FRFRONTS, MPI only, LDLT) * Fixed error printing in case of error -53 * Fixed an erroneous -9 error in case of large Schur + discard factors * -DWORKAROUNDINTELILP64OPENMPLIMITATION avoids -i8 compilation warnings * Limited repeated amalgamations of large child with small parent Changes from 5.3.5 to 5.4.0 * Modified default threshold for null pivot detection (CNTL(3)) * Improved performance of Schur complement computations * Reduced memory of centralized analysis with distributed matrix * Improved BLR clustering time during analysis * Improved BLR performance when CNTL(1)=0.0 and ICNTL(36)=0 * Improved OOC performance in case CNTL(1)=0.0 or SYM=1 * Improved multitreaded performance on matrices with many 2x2 pivots * Fixed a problem with parallel compilation (in case of: make -j all) * Fixed some timings during solve that were printed as 0 when PAR=0 * Avoid possible integer overflow on INFOG(10) * Fixed type 1 assembly by pieces in case static CB moves to dynamic storage * Use with ITAC: avoid errors (e.g. in DMUMPS_UPPER_PREDICT...) due to MPI returning nonzero error codes when traces are activated * Add a JOB=-200 call (no MPI communications, clean local OOC files) * Fixed "Start processing the root ..." printing in case of Schur * Fixed SYM_PERM in case of Schur on reducible matrices Changes from 5.3.4 to 5.3.5 * Fixed 2x2 pivots bug from 5.3.4 release in MPI LDLT factorization * Fixed ICNTL(8)=-2 option during analysis (code and documentation) * Include basic fix for make -j Changes from 5.3.3 to 5.3.4 * Fixed a rare bug (segfault) related to dynamic storage management on numerically difficult matrices * Fixed a rare deadlock in BLR for symmetric matrices * Fixed an uninitialized variable (which could lead to incorrect -19 error) * Minor fix in userguide (CNTL(1) vs. ICNTL(1) in ICNTL(36) description) * Fixed a possible runtime issue during solve, related to "TO_PROCESS" array Changes from 5.3.1 to 5.3.3 * Assume ilp64 MPI interface only applies to Fortran in c_example.c * Note on gfortran-10 compilation added * Avoid intent on pointers (F2003-only) * More robust multithreading for matrix reformatting (arrowheads) * Fixed ICNTL(31) interpretation in case of repeated analysis * Fixed multiple mpif.h inclusion (distributed rhs, ifort+openmpi) * Fixed computation of effectively used memory statistics * Minor fix in userguide * Suppressed a !$OMP CRITICAL from solve phase (introduced in 5.3.0) Changes from 5.3.0 to 5.3.1 * Improved multithreaded performance of BLR backward solve * Fixed return code in build_mumps_int_def.c + openmp compilation (pgi) * Forbid a loop vectorization in [sdcz]sol_c.F (segfault with ifort) Changes from 5.2.1 to 5.3.0 * New feature: distributed right-hand sides * Improved time for arrowheads construction (single MPI case, mainly) * C interface: ability to know if MUMPS_INT is 64-bit from include file * Improved BLR performance when CNTL(1)=0.0 and ICNTL(36)=1 * Fixed INFO(34),INFO(35),INFO(37),INFO(38) on processes with rank > 0 * More portable MPI_IS_IN_PLACE feature in libseq * Fixed determinant computation when Cholesky ScaLapack is used * Information on advancement (flops done) on each MPI process * Allow rhs_sparse and irhs_sparse to be unassociated if nz_rhs=0 * Fixed INFO(30) and INFO(31) computation on MPI processes with rank > 0 * OMP collapsed loops: avoid FIRSTPRIVATE on internal loop bound (for pgi) * Fix for compilers not freeing local allocatable arrays (64-bit metis) * Fixed RINFO(5-6) and RINFOG(15-16) metrics (#entries=>#bytes) * C interface: A_ELT/SCHUR/RHS/REDRHS/RHS_loc/SOL_loc may exceed 2^31 entries * Local Schur (ICNTL(19)=2 or 3) may now exceed 2^31 entries * Fixed internal dynamic storage of blocks with more than 2^31 entries * Fixed a bug in the parallel analysis that limited scalability Changes from 5.2.0 to 5.2.1 * Fixed a minor "Internal error in CMUMPS_DM_FREEALLDYNAMICCB" * Default value of ICNTL(14) for MPI executions independent of SYM + slightly less aggressive than for 5.2.0 * Avoided accesses to uninitialized data in symmetric (2D root, BLR) * Fixed some incorrect "out" intents for routine arguments * Avoided CHUNK=0 in OMP loops even if loop not parallelized (pgi) * Fixed COLSCA&ROWSCA declarations in [SDCZ]MUMPS_ANA_F * Avoided a possible segfault in presence of NaN's in pivot search * Minor update to userguide * Fixed MPI_IN_PLACE usage in libseq (preventing compiler optimization) Changes from 5.1.2 to 5.2.0 * Memory gains due to low-rank factorization are now effective, low-rank solve * Internal dynamic storage possible in case static workspace too small * Improved distributed memory usage and MPI granularity (some sym. matrices) * Improved granularity (and performance) for symmetric matrices; ability to use [DSCZ]GEMMT kernel (BLAS extension) if available (see INSTALL) * A-1 functionality: improved performance due to solution gathering * Memory peak for analysis reduced (distributed-entry, 64-bit orderings) * Time for analysis reduced by avoiding some preprocessing (when possible) * More exploitation of RHS sparsity during forward substitution * Ability to save/restore an instance to/from disk * INFO and INFOG dimension extended from 40 to 80 * METIS_OPTIONS introduced for METIS users to define some specific Metis options * MUMPS can be asked to call omp_set_num_threads with a value provided in ICNTL(16) * Fixed: INFO(16)/INFOG(21)/INFOG(22) did not take into account the extra memory allocated due to memory allowed (ICNTL(23)>0); INFOG(8) was not correclty set * Initialize only lower-diagonal part for workers in symmetric type 2 fronts * Workaround a segfault at beg. of facto due to a gfortran-8 bug * Fixed a bug in weighted matching algorithm when all matrix values are 0 * Portability: include stdint.h instead of int_types.h * Forced some initializations to make C interface more valgrind-friendly * Workaround intel 2017 vectorization bug in pivot search (symmetric+MPI+large matrices) * Stop trying to send messages on COMM_LOAD in case of error (risk of deadlock) * Avoided most array creation by compiler due to Fortran pointers * Avoid two cases of int. overflow (KEEP(66), A-1 with large ICNTL(27)) * Fixed a bug with compressed ordering (ICNTL(12)=2) (regression from 5.0.0) and suppress compress ordering only in case of automatic setting Changes from 5.1.1 to 5.1.2 * Corrected an overestimation of memory (regression from 5.1.0) * Corrected/extended WORKAROUNDINTELILP64MPI2INTEGER mechanism (see INSTALL) * Parallel analysis: fixed a bug, limited number of MPI processes on small problems, and reverted to sequential analysis on tiny problems. This is to avoid erroneous behavior and failures in the parallel ordering tools. * Faster BLR clustering on matrices with quasi-dense rows (which are skipped) * Improved performance of solve phase on very small matrices * Solve phase with a single MPI process is more thread-safe * Fixed compilation issue with opensolaris ([SDCZ]MUMPS_TRUNCATED_RRQR) * Fixed minor bug in BLR factorization (uninitialized timer) * Corrected minor compiler warnings * Minor correction to userguide * Add -DBLR_MT in Intel example Makefile Changes from 5.1.0 to 5.1.1 * Fix in parallel analysis * Stabilization of 5.1.0: - Improved stability of Block-Low-Rank feature - Corrected an incorrect deallocation of POSINRHSCOMP_COL - Correction of a case of uninitialized data access in type 2 pivoting - Suppressed occasional debug trace "write(6,*) " KEEP265= ", KEEP265" Changes from 5.0.2 to 5.1.0 * New feature: selective 64-bit integers (introduced only where needed) to process matrices with more than 2^{31}-1 entries. -mixed 32/64 bit integers for API: NNZ/NNZ_loc 64-bit (NZ/NZ_LOC kept temporarily for backward compatibility) - both 32 or 64 bit integer versions of external orderings (Metis/ParMetis, SCOTCH/pt-SCOTCH, PORD), can be used - Error -51 when a 32-bit external ordering is invoked on a graph larger than 2^{31}-1 * New feature: (experimental) factorization based on Block-Low-Rank format, (ICNTL(35) to activate it and CNTL(7) for low-rank precision) * Improved performance on numerically hard matrices (LU and LDLt) * "-DALLOW_NON_INIT" flag has disappeared and needs no longer be used * Fixed incorrect deallocation in case of JOB=3/ICNTL(26)=1 followed by JOB=2 * Fixed compilation problem with Intel2017 + openMPI in [sdcz]ana_aux_par.F * Minor correction of memory statistics for solve * Use 64-bit integers where needed during the solve phase to enable large number of right-hand-sides (NRHS) in one block (i.e. ICNTL(27)xN can be larger than 2^{31}-1) * Improved performance of solve phase * Allow pivoting thresholds CNTL(1) equal to 1.0 * New error -52: when default Fortran integers are 64 bit, external orderings should also have 64-bit default integers * New error -22, INFO(2)=16 when IRN_loc or JCN_loc not associated while ICNTL(18) is set to 3 * Missing O_BINARY flag was added to open binary files on MINGW systems * New error -53 that could reflect a matrix structure change between analysis and factorization Changes from 5.0.1 to 5.0.2 * Suppress error on id%SCHUR_CINTERFACE in mumps_driver.F when bound check is enabled and when using 2D block cyclic Schur complement feature (ICNTL(19)=2 or 3) from C or Matlab interfaces * Problem of failed assertion in [SDCZ]MUMPS_TREAT_DESCBAND solved (static variable INODE_WAITED_FOR was not initialized and was not detected by valgrind) * Correction of very minor memory leaks and access to uninitialized data * A setting of INFO(1)=-1-17 should have been INFO(1)=-17 * Some settings of INFO(1)=-17 should have been INFO(1)=-20 * Suppress absolute tolerance 10^-20 in pivot selection for SYM=2; skip 2x2 pivot search if only 1 pivot candidate, avoid pivots that are subnormal numbers (their inverse is equal to infinity) * Warning +2 now only occurs when solution is really close to 0 * Occasional bug in OOC and multiple instances solved * Better selection of equations for bwd errors (W1 and W2) and better forward error estimates on some machines with 80-bit registers * Improved users' guide (OOC files cleaning, permutation details, usage of multithreading, clarification of MegaByte unit) * Cleaning of asynchronous messages after facto/solve was revisited and is more robust * More robust suppression of integer overflow risk during solve for huge ICNTL(23) * Improved performance of symbolic factorization in case of matrices with relatively dense rows and/or with large number of Lagrange multipliers * Improved performance of numerical factorization phase during pivot search for symmetric indefinite matrices * Use of -xcore-avx2 requires !DEC$ NOOPTIMIZE in MUMPS_BIT_GET4PROC with current versions of Intel compilers * Suppressed some temporary array creation and implicit conversions Changes from 5.0.0 to 5.0.1 * Iterative refinement convergence check corrected (problem introduced in 5.0.0) * Used communicator provided by user instead of MPI_COMM_WORLD in two places (parallel analysis only) * Matlab interface patched to avoid memory corruption in some situations (Schur, colsca/rowsca management) * Corrected a case of error not properly processed which could cause a segfault instead of a standard "-9" error, or an abort on "ERR: ERROR: NBROWS > NBROWF" * Amalgamation without fill forced for single children * (rare) segfault related to assemblies of delayed columns in scalapack root node corrected * Automatic strategy for ordering choice improved * Further improvements to userguide (mainly iterative refinement, error analysis, discard factors and forward elimination during factorization) * Error -51 also raised in case of integer overflow during parallel analysis Changes from 4.10.0 to 5.0.0 * Userguide revisited * Compatibility with Metis 5.1.0/ParMetis 4.0.3, and with SCOTCH/pt-SCOTCH 6.0 * Matlab interface updated (scaling vectors (COLSCA, ROWSCA) and A-1 feature ICNTL(30) are now available) * Improved sequential and parallel performance for computing selected entries of A-1 (ICNTL(30)) * Workspace for solve phase, of size B x N per processor (B: block size controlled by ICNTL(27)) divided by almost #procs. Default value of B increased. * Parallel symmetric indefinite elemental matrices: improved numerical behaviour * Performance of solve phase improved * Finer control of error analysis and iterative refinement (ICNTL(11)) * Memory for analysis phase (mapping) reduced. * Better support for 64-bit integers (see INSTALL file) * Error raised instead of silent integer overflow during analysis (but not during external orderings) * Improvements and corrections to parallel analysis (ICNTL(28)), deterministic graph construction forced with -DDETERMINISTIC_PARALLEL_GRAPH * Forward elimination (ICNTL(32)) can be done during factorization * Possibility to use a workspace (WK_USER, LWK_USER) allocated by user * Very occasional numerical bug in parallel out-of-core case corrected (thanks to EDF and Samtech for the validation) * More efficient processing of sparse right-hand-sides (see ICNTL(20)) * Count for entries in factors now include parallel root node * Amalgamation of the assembly tree revisited * Scaling arrays (COLSCA, ROWSCA) also returned at C interface level * OOC_NB_FILE_TYPE is part of the MUMPS structure, for a better management of multiple OOC instances * Warning +2 set only once (could lead to incorrect +4 in case of iterative refinement + error analysis) * Warning +4 has disappeared from documentation (since it was never occurring -- JCN never modified on exit) * Error code -16 now raised for the case N=0 even on distributed matrices (thanks to P. Jolivet for noticing this) * Use BLAS3 routines for efficiency even in case of BLAS2 operations (-DMUMPS_USE_BLAS2 allows the use of BLAS2 routines for such operations) * Message "problem with NIV2_FLOPS message" should no more occur (there was still an occasional problem in 4.10.0) * Improved determinant computation (ICNTL(33)) in case of singular matrix + scaling (where zero pivots are excluded) * Trace ' PANEL: INIT and force STRAT_IO=' suppressed * Some OpenMP directives added (multithreaded BLAS still needed) * Later allocation of strips of distributed fronts with improved locality * Front factorization algorithms redesigned (two levels of panels) * Null pivot (ICNTL(24)) and null space detection ICNTL(25)) improved for unsymmetric matrices * Fortran automatic arrays (e.g. in mumps_static_mapping.F) suppressed to avoid risks of stack overflows * Routine names and filenames changed Changes from 4.9.2 to 4.10.0 * Modified variable names and variable contents in Make.inc/Makefile* for Windows (Makefile.inc from an older version needs modifications, please do a diff) * Option to discard factors during factorization when not needed (ICNTL(31)) * Option to compute the determinant (ICNTL(33)) * Experimental "A-1" functionality (ICNTL(30)) * Matlab interface updated for 64-bit machines * Improved users' guide * Suppressed a memory leak occurring when Scalapack is used and user does loops on JOB=6 without JOB=-2/JOB=-1 in-between * Avoid occasional deadlock with huge values of ICNTL(14) * Avoid problem of -17 error code during solve phase * Avoid checking association of pointer arrays ISOL_loc and SOL_loc on procs with no components of solution (small problems) * Some data structures were not free at the end of the parallel analysis. Bug fixed. * Fixed unsafe test of overflow "IF (WFLG+N .LE. WFLG)" * Large Schur complements sent by blocks if ICNTL(19)=1 (but options ICNTL(19)=2 or 3 are recommended when Schur complement is large) * Corrected problem with sparse RHS + unsymmetric permutation + transpose solve (problem appeared in 4.9) * Case where ICNTL(19)=2 or 3 and small value of SIZE_SCHUR causing problems in parallel solved. * In case an error is detected, solved occasional problem of deallocating non-allocated local array PERM. * Correction in computation of matrix norm in complex arithmetic (MPI_COMPLEX was used in place of MPI_REAL in MPI_REDUCE) * Scaling works on singular matrices * Compilation problem with -i8 solved * MUMPS_INT used in OOC layer to facilitate compilation with 64 bit integers Changes from 4.9.1 to 4.9.2 * Compressed orderings (ICNTL(12)=2) are now compatible with PORD and PT-Scotch * Mapping problem on large numbers of MPI processes, leading to INFOG(1)=-135 on "special" matrices solved (problem appeared in 4.9.1) Changes from 4.9 to 4.9.1 * Balancing on the processors of both work and memory improved. In a parallel environment memory consumption should be reduced and performance improved * Modification of the amalgamation to solve both the problem of small root nodes and the problem of tiny nodes implying too many small MPI messages * Corrected bug occurring on big-endian environments when passing a 64-bit integer argument in place of 32-bit one. This was causing problems in parallel, when ScaLAPACK is used, on IBM machines. * Internal ERROR 2 in MUMPS_271 now impossible (was already not happening in practice) * Solved compiler warnings (or even errors) related to the order of the declarations of arrays and array sizes * Parallel analysis: fixed the problem due to the invocation of the size function on non-allocated pointers, corrected a bug due to initialization of pointers in the declaration statements, and improved the Makefiles * Corrected bug in the reallocation of arrays * Corrected several accesses to uninitialized variables * Internal Error (4) in OOC (MUMPS_597) no more occurs * Suppressed possible printing of "Internal WARNING 1 in CMUMPS_274" * (Minor) numerical pivoting problem in parallel LDLt solved * Estimated flops corrected when SYM=2 and Scalapack is used (because we use LU on the root node, not LDLt, in that case) * Scaling option effectively used is now returned in INFOG(33) and ICNTL(8) is no more modified by the package * INFO(25) is now correctly documented, new statistic INFO(27) added Changes from 4.8.4 to 4.9 * Parallel analysis available * Use of 64-bit integer addressing for large internal workarrays * overflow in computation of INFO(9) in out-of-core corrected * fixed Matlab and Scilab interfaces to sparse RHS functionality * time cost of analysis reduced for "optimisation" matrices * time to gather solution on processor 0 reduced and automatic copying of some routine arguments by some compilers resolved. * extern "C" added to header file mpi.h of libseq for C++ compilers * Problem with NZ_loc=0 and scaling with ifort 10 solved * Statistics about current state of the factorization produced/printed even in case of error. * Avoid using complex arrays as real workspace (complex versions) * New error code -40 (instead of -10) when SYM=1 is used and ScaLAPACK detects a negative pivot * Solved problem of "Internal error 1" in [SDCZ]MUMPS_264 and [SDCZ]MUMPS_274 * Solved undeterministic bug occurring with asynchronous OOC + panels when uninitialized memory access had value -7777 * Fixed a remaining problem with OOC filenames having more than 150 characters * Fixed some problems related to the usage of intrinsic functions inside PARAMETER statements (HP-UX compilers) * Fixed problem of explicit interface in [SDCZ]MUMPS_521 * Out-of-core strategy from 4.7.3 can be reactivated with -DOLD_OOC_NOPANEL * Message "problem with NIV2_FLOPS message" should no more occur * Avoid compilation problem with old versions of gfortran Changes from 4.8.3 to 4.8.4 * Absolute threshold criterion for null pivot detection added to CNTL(3) * Problems related to messages "Increase small buffer size ..." solved. * New option for ICNTL(8) to scale matrices. Default scaling cheaper to compute * Problem of filename clash with unsymmetric matrices on Windows platforms solved * Allow for longer filenames for temporary OOC files * Strategy to update blocksize during factorization of frontal matrices modified to avoid too large messages during pipelined factorization (that could lead to a -17 error code) * Messages corresponding to delayed pivots can now be sent in several packets. This avoids some other cases of error -17 * One rare case of deadlock solved * Corrected values and sign of INFO(8) and INFO(20) Changes from 4.8.2 to 4.8.3 * Fix compilation issues on Windows platforms * Fix ranlib issue with libseq on MacOSX platforms * Fix a few problems of uninitialized variables Changes from 4.8.1 to 4.8.2 * Problem of wrong argument in the call to [sdcz]mumps_246 solved * Limit occurrence of error -11 in the in-core case * Problem with the use of SIZE on an unassociated pointer solved * Problem with distributed solution combined with non-working host solved * Fix generation of MM matrices * Fix of a minor bug in OOC error management * Fix portability issues on usleep Changes from 4.8.0 to 4.8.1 * New distributed scaling is now on by default for distributed matrices * Error management corrected in case of 32-bit overflow during factorization * SEPARATOR is now defined as "\\" in Windows version * Bug fix in OOC panel version Changes from 4.7.3 to 4.8.0 * Parallel scalings algorithms available * Possibility to dump a matrix in matrix-market format from both C and Fortran interfaces * Correction when dumping a distributed matrix in matrix-market format * Minor numerical stability problem in some LDL^t parallel factorizations corrected. * Memory usage significantly reduced in both parallel and sequential (limit communication buffers, in-place assembly for assembled matrices, overlapping during stack). * Better alignment properties of mumps_struc.h * Reduced time for static mapping during the analysis phase. * Correction in dynamic scheduler * "Internal error 2 in DMUMPS_26" no more occurs, even if SIZE_SCHUR=0 * Corrections in the management of ICNTL(25), some useful code was protected with -Dtry_null_space and not compiled. * Scaling arrays are now declared real even in complex versions * Out-of-core functionality storing factors on disk * Possibility to tell MUMPS how much memory the package is allowed to allocate (ICNTL(23)) * Estimated and effective number of entries in factors returned to user * API change: MAXS and MAXIS have disappeared from the interface, please use ICNTL(14) and ICNTL(23) to control the memory usage * Error code -11 raised less often, especially in out-of-core executions * Error code -14 should no more occur * Memory used at the solve phase is now returned to the user * Possibility to control the blocking size for multiple right-hand sides (strong impact on performance, in particular for out-of-core executions) * Solved problems of 32-bit integer overflows during analysis related to memory estimations. * New error code -37 related to integer overflows during factorization * Compile one single arithmetic with make s, make d, make c or make z, examples are now in examples/, test/ has disappeared. * Arithmetic-independent parts are isolated into a libmumps_common.a, that must now be linked too (see examples/Makefile). Changes from 4.7.2 to 4.7.3 * detection of null pivots for unsymmetric matrices corrected * improved pivoting in parallel symmetric solver * possible problem when Schur on and out-of-core : Schur was splitted * type of parameters of intrinsic function MAX not compatible in single precision arithmetic versions. * minor changes for Windows * correction with reduced RHS functionality in parallel case Changes from 4.7.1 to 4.7.2 * negative loads suppressed in mumps distribution Changes from 4.7 to 4.7.1 * Release number in Fortran interface corrected * "Negative load !!" message replaced by a warning Changes from 4.6.4 to 4.7 * New functionality: build reduced RHS / use partial solution * New functionality: detection of zero pivots * Memory reduced (especially communication buffers) * Problem of integer overflow "MEMORY_SENT" corrected * Error code -20 used when receive buffer too small (instead of -17 in some cases) * Erroneous memory access with singular matrices (since 4.6.3) corrected * Minor bug correction in hybrid scheduler * Parallel solution step uses less memory * Performance and memory usage of solution step improved * String containing the version number now available as a component of the MUMPS structure * Case of error "-9964" has disappeared Changes from 4.6.3 to 4.6.4 * Avoid name clashes (F_INT, ...) when C interface is used and user wants to include, say, smumps_c.h, zmumps_c.h (etc.) at the same time * Avoid large array copies (by some compilers) in distributed matrix entry functionality * Default ordering less dependent on number of processors * New garbage collector for contribution blocks * Original matrix in "arrowhead form" on candidate processors only (assembled case) * Corrected bug occurring rarely, on large number of processors, and that depended on value of uninitialized data * Parallel LDL^t factorization numerically improved * Less memory allocation in mapping phase (in some cases) Changes from 4.6.2 to 4.6.3 * Reduced memory usage for symmetric matrices (compressed CB) * Reduced memory allocation for parallel executions * Scheduler parameters for parallel executions modified * Memory estimates (that were too large) corrected with 2Dcyclic Schur complement option * Portability improved (C/Fortran interfacing for strings) * The situation leading to Warning "RHS associated in MUMPS_301" no more occurs. * Parameters INFO/RINFO from the Scilab/Matlab API are now called INFOG/RINFOG in order to match the MUMPS user's guide. Changes from 4.6.1 to 4.6.2 * Metis ordering now available with Schur option * Schur functionality correctly working with Scilab interface * Occasional SIGBUS problem on single precision versions corrected Changes from 4.6 to 4.6.1 * Problem with hybrid scheduler and elemental matrix entry corrected * Improved numerical processing of symmetric matrices with quasi-dense rows * Better use of Blacs/Scalapack on processor grids smaller than MPI_COMM_WORLD * Block sizes improved for large symmetric matrices Changes from 4.5.6 to 4.6 * Official release with Scilab and Matlab interfaces available * Correction in 2x2 pivots for symmetric indefinite complex matrices * New hybrid scheduler active by default Changes from 4.5.5 to 4.5.6 * Preliminary developments for an out-of-core code (not yet available) * Improvement in parallel symmetric indefinite solver * Preliminary distribution of a SCILAB and a MATLAB interface to MUMPS. Changes from 4.5.4 to 4.5.5 * Improved tree management * Improved weighted matching preprocessing: duplicates allowed, overflow avoided, dense rows * Improved strategy for selecting default ordering * Improved node amalgamation Changes from 4.5.3 to 4.5.4 * Double complex version no more depends on double precision version. * Simplification of some complex indirections in mumps_cv.F that were causing difficultiels to some compilers. Changes from 4.5.2 to 4.5.3 * Correction of a minor problem leading to INFO(1)=-135 in some cases. Changes from 4.5.1 to 4.5.2 * correction of two uninitialized variables in proportional mapping Changes from 4.5.0 to 4.5.1 * better management of contribution messages * minor modifications in symmetric preprocessing step Changes from 4.4.0 to 4.5.0 * improved numerical features for symmetric indefinite matrices - two-by-two pivots - symmetric scaling - ordering based on compressed graph preserving two by two pivots - constrained ordering * 2D cyclic Schur better validated * problems resulting from automatic array copies done by compiler corrected * reduced memory requirement for maximum transversal features Changes from 4.3.4 to 4.4.0 * 2D block cyclic Schur complement matrix * symmetric indefinite matrices better handled * Right-hand side vectors can be sparse * Solution can be kept distributed on the processors * Metis allowed for element-entry * Parallel performance and memory usage improved: - load is updated more often for type 2 nodes - scheduling under memory constraints - reduced message sizes in symmetric case - some linear searches avoided when sending contributions * Avoid array copies in the call to the partial mapping routine (candidates); such copies appeared with intel compiler version 8.0. * Workaround MPI_AllReduce problem with booleans if mpich and MUMPS are compiled with different compilers * Reduced message sizes for CB blocks in symmetric case * Various minor improvements Changes from 4.3.3 to 4.3.4 * Copies of some large CB blocks suppressed in local assemblies from child to parent * gathering of solution optimized in solve phase Changes from 4.3.2 to 4.3.3 * Control parameters of symbolic factorization modified. * Global distribution time and arrowheads computation slightly optimized. * Multiple Right-Hand-Side implemented. Changes from 4.3.1 to 4.3.2 * Thresholds for symbolic factorization modified. * Use merge sort for candidates (faster) * User's communicator copied when entering MUMPS * Code to free CB areas factorized in various places * One array suppressed in solve phase Changes from 4.3 to 4.3.1 * Memory leaks in PORD corrected * Minor compilation problem on T3E solved * Avoid taking into account absolute criterion CNTL(3) for partial LDLt factorization when whole column is known (relative stability is enough). * Symbol MPI_WTICK removed from mpif.h * Bug wrt inertia computation INFOG(12) corrected Changes from 4.2beta to 4.3 * C INTERFACE CHANGE: comm_fortran must be defined from the calling program, since MUMPS uses a Fortran communicator (see user guide). * LAPACK library is no more required * User guide improved * Default ordering changed * Return number of negative diagonal elements in LDLt factorization (except for root node if treated in parallel) * Rank-revealing options no more available by default * Improved parallel performance - new incremental mechanism for load information - new communicator dedicated to load information - improved candidate strategy - improved management of SMP platforms * Include files can be used in both free and fixed forms * Bug fixes: - some uninitialized values - pbs with size of data on t3e - minor problems corrected with distributed matrix entry - count of negative pivots corrected - AMD for element entries - symbolic factorization - memory leak in tree reordering and in solve step * Solve step uses less memory (and should be more efficient) Changes from 4.1.6 to 4.2beta * More precisions available (single, double, complex, double complex). * Uniprocessor version available (doesn't require MPI installed) * Interface changes (Users of MUMPS 4.1.6 will have to slightly modify their codes): - MUMPS -> ZMUMPS, CMUMPS, SMUMPS, DMUMPS depending the precision - the Schur complement matrix should now be allocated by the user before the call to MUMPS - NEW: C interface available. - ICNTL(6)=6 in 4.1.6 (automatic choice) is now ICNTL(6)=7 in 4.2 * Tighter integration of new ordering packages (for assembled matrices), see the description of ICNTL(7): - AMF, - Metis, - PORD, * Memory usage decreased and memory scalability improved. * Problem when using multiple instances solved. * Various improvments and bug fixes. Changes from 4.1.4 to 4.1.6 * Modifications/Tuning done by P.Amestoy during his visit at NERSC. * Additional memory and communication statistics. * minor pbs solved. Changes from 4.0.4 to 4.1.4 * Tuning on Cray T3e (and minor debugging) * Improved strategy for asynchronous communications (irecv during factorization) * Improved Dynamic scheduling and splitting strategies * New maximal transversal strategies * New Option (default) automatic decision for scaling and maximum transversal ------------------- = Release history = ------------------- Release 5.8.1 : July 2025 Release 5.8.0 : May 2025 Release 5.7.3 : July 2024 Release 5.7.2 : June 2024 Release 5.7.1 : May 2024 Release 5.7.0 : April 2024 Release 5.6.2 : October 2023 Release 5.6.1 : July 2023 Release 5.6.0 : April 2023 Release 5.5.1 : July 2022 Release 5.5.0 : April 2022 Release 5.4.1 : August 2021 Release 5.4.0 : April 2021 Release 5.3.5 : October 2020 Release 5.3.4 : September 2020 Release 5.3.3 : June 2020 Release 5.3.2[.x] : May 2020, internal/experimental Release 5.3.1 : April 2020 Release 5.3.0 : April 2020 Release 5.2.1 : June 2019 Release 5.2.0 : April 2019 Release 5.1.2 : October 2017 Release 5.1.1 : March 2017 Release 5.1.0 : Feb 2017, internal release (limited diffusion) Release 5.0.2 : July 2016 Release 5.0.1 : July 2015 Release 5.0.0 : February 2015 Release 4.10.0 : May 2011 Release 4.9.2 : November 2009 Release 4.9.1 : October 2009 Release 4.9 : July 2009 Release 4.8.4 : December 2008 Release 4.8.3 : September 2008 Release 4.8.2 : September 2008 Release 4.8.1 : August 2008 Release 4.8.0 : July 2008 Release 4.7.3 : May 2007 Release 4.7.2 : April 2007 Release 4.7.1 : April 2007 Release 4.7 : April 2007 Release 4.6.4 : January 2007 Release 4.6.3 : June 2006 Release 4.6.2 : April 2006 Release 4.6.1 : February 2006 Release 4.6 : January 2006 Release 4.5.6 : December 2005, internal release Release 4.5.5 : October 2005 Release 4.5.4 : September 2005 Release 4.5.3 : September 2005 Release 4.5.2 : September 2005 Release 4.5.1 : September 2005 Release 4.5.0 : July 2005 Releases 4.3.3 -- 4.4.3 : internal releases Release 4.3.2 : November 2003 Release 4.3.1 : October 2003 Release 4.3 : July 2003 Release 4.2 (beta) : December 2002 Release 4.1.6 : March 2000 Release 4.0.4 : Wed Sept 22, 1999 <-- Final version from PARASOL MUMPS_5.8.1/SCILAB/0000775000175000017500000000000015042446422013376 5ustar amestoyamestoyMUMPS_5.8.1/SCILAB/intmumpsc.c0000664000175000017500000005044615042446422015572 0ustar amestoyamestoy#include "mex.h" #include "stack-c.h" #include "sci_gateway.h" #include #include #include #define MUMPS_ARITH_d 2 #define MUMPS_ARITH_z 8 #if MUMPS_ARITH == MUMPS_ARITH_z # include "zmumps_c.h" # define dmumps_c zmumps_c # define dmumps_par zmumps_par # define DMUMPS_STRUC_C ZMUMPS_STRUC_C # define DMUMPS_alloc ZMUMPS_alloc # define DMUMPS_free ZMUMPS_free # define double2 mumps_double_complex #elif MUMPS_ARITH == MUMPS_ARITH_d # include "dmumps_c.h" # define double2 double # define EXTRACT_CMPLX_FROM_C_TO_SCILAB EXTRACT_DOUBLE_FROM_C_TO_SCILAB # define EXTRACT_CMPLX_FROM_SCILAB_TOPTR EXTRACT_FROM_SCILAB_TOPTR #else # error "Only d and z arithmetics are supported" #endif #define nb_RHS 12 #define MYFREE(ptr)\ if(ptr){ \ free(ptr); \ ptr=0;} \ #define EXTRACT_FROM_SCILAB_TOPTR(it,ptr_scilab1,ptr_scilab2,mumpspointer,type,length)\ if(ptr_scilab1[0] != -9999){ \ free(mumpspointer); \ mumpspointer = (type *) malloc(length*sizeof(type)); \ for(i=0;iirn ); MYFREE( (*dmumps_par)->jcn ); MYFREE( (*dmumps_par)->a ); MYFREE( (*dmumps_par)->irn_loc ); MYFREE( (*dmumps_par)->jcn_loc ); MYFREE( (*dmumps_par)->a_loc ); MYFREE( (*dmumps_par)->eltptr ); MYFREE( (*dmumps_par)->eltvar ); MYFREE( (*dmumps_par)->a_elt ); MYFREE( (*dmumps_par)->perm_in ); MYFREE( (*dmumps_par)->colsca ); MYFREE( (*dmumps_par)->rowsca ); MYFREE( (*dmumps_par)->pivnul_list ); MYFREE( (*dmumps_par)->listvar_schur ); MYFREE( (*dmumps_par)->sym_perm ); MYFREE( (*dmumps_par)->uns_perm ); MYFREE( (*dmumps_par)->irhs_ptr); MYFREE( (*dmumps_par)->irhs_sparse); MYFREE( (*dmumps_par)->rhs_sparse); MYFREE( (*dmumps_par)->rhs); MYFREE( (*dmumps_par)->redrhs); MYFREE(*dmumps_par); } } void DMUMPS_alloc(DMUMPS_STRUC_C **dmumps_par){ *dmumps_par = (DMUMPS_STRUC_C *) malloc(sizeof(DMUMPS_STRUC_C)); (*dmumps_par)->irn = NULL; (*dmumps_par)->jcn = NULL; (*dmumps_par)->a = NULL; (*dmumps_par)->irn_loc = NULL; (*dmumps_par)->jcn_loc = NULL; (*dmumps_par)->a_loc = NULL; (*dmumps_par)->eltptr = NULL; (*dmumps_par)->eltvar = NULL; (*dmumps_par)->a_elt = NULL; (*dmumps_par)->perm_in = NULL; (*dmumps_par)->colsca = NULL; (*dmumps_par)->rowsca = NULL; (*dmumps_par)->rhs = NULL; (*dmumps_par)->redrhs = NULL; (*dmumps_par)->irhs_ptr = NULL; (*dmumps_par)->irhs_sparse = NULL; (*dmumps_par)->rhs_sparse = NULL; (*dmumps_par)->pivnul_list = NULL; (*dmumps_par)->listvar_schur = NULL; (*dmumps_par)->schur = NULL; (*dmumps_par)->sym_perm = NULL; (*dmumps_par)->uns_perm = NULL; } static int dmumpsc(char *fname){ /* RhsVar parameters */ int njob, mjob, ljob, mint, nint, lint, nsym, msym, lsym, nA, mA, nRHS, nREDRHS, mRHS,lRHS, liRHS; int mREDRHS,lREDRHS,liREDRHS; int nicntl, micntl, licntl, ncntl, mcntl, lcntl, nperm, mperm, lperm; int ncols, mcols, lcols, licols, nrows, mrows, lrows, lirows, ns_schu , ms_schu, ls_schu; int nv_schu, mv_schu, lv_schu, nschu, mschu, lschu; int type_rhs, mtype_rhs, ntype_rhs, ltype_rhs; /* LhsVar parameters */ int linfog, lrinfog, lrhsout,lrhsouti, linstout, lschurout, lschurouti, ldef; int lpivnul_list, lmapp, lsymperm, lunsperm; int one=1, temp1=80, temp2=40, temp3, temp4; int it, itRHS, itREDRHS; /* parameter for real/complex types */ int i,j,k1,k2, nb_in_row,netrue; int *ptr_int; double *ptr_double; double *ptr_scilab; #if MUMPS_ARITH == MUMPS_ARITH_z double * ptri_scilab; #endif /* Temporary length variables */ int len1, len2; /* Temporary pointers in stack */ int stkptr, stkptri; /* C pointer for input parameters */ int inst_address; int ne,inst; int *irn_in,*jcn_in; /* Variable for multiple and sparse RHS*/ int posrhs, posschur, nz_RHS,col_ind,k; int *irhs_ptr; int *irhs_sparse; double *rhs_sparse; #if MUMPS_ARITH == MUMPS_ARITH_z double *im_rhs_sparse; char * function_name="zmumpsc"; #else char * function_name="dmumpsc"; #endif SciSparse A; SciSparse RHS_SPARSE; DMUMPS_STRUC_C *dmumps_par; int dosolve=0; int donullspace=0; int doanal = 0; /* Check number of input parameters */ CheckRhs(11,12); /* Get job value. njob/mjob are the dimensions of variable job. */ GetRhsVar(2,"i",&mjob,&njob,&ljob); dosolve = (*istk(ljob) == 3 || *istk(ljob) == 5 ||*istk(ljob) == 6); doanal = (*istk(ljob) == 1 || *istk(ljob) == 4 || *istk(ljob) == 6); if(*istk(ljob) == -1){ DMUMPS_alloc(&dmumps_par); GetRhsVar(1,"i",&msym,&nsym,&lsym); dmumps_par->sym=*istk(lsym); dmumps_par->job = -1; dmumps_par->par = 1; dmumps_c(dmumps_par); dmumps_par->nz = -1; dmumps_par->nz_alloc=-1; it=1; }else{ /* Obtain pointer on instance */ GetRhsVar(10,"i",&mint,&nint,&lint); inst_address=*istk(lint); /* EXTRACT_FROM_SCILAB_TOVAL(INST,inst_address); */ ptr_int = (int *) inst_address; dmumps_par = (DMUMPS_STRUC_C *) ptr_int; if(*istk(ljob) == -2){ dmumps_par->job = -2; dmumps_c(dmumps_par); DMUMPS_free(&dmumps_par); }else{ /* Get the sparse matrix A */ GetRhsVar(12,"s",&mA,&nA,&A); if (nA != mA || mA<1 ){ Scierror(999,"%s: Bad dimensions for mat\n",function_name); return 0; } ne=A.nel; dmumps_par->n = nA; if(dmumps_par->sym != 0){ netrue = (nA+ne)/2; }else{ netrue = ne; } if(dmumps_par->nz_alloc < netrue ||dmumps_par->nz_alloc >= 2*netrue){ MYFREE(dmumps_par->jcn); MYFREE(dmumps_par->irn); MYFREE(dmumps_par->a); dmumps_par->jcn = (int*)malloc(netrue*sizeof(int)); dmumps_par->irn = (int*)malloc(netrue*sizeof(int)); dmumps_par->a = (double2 *) malloc(netrue*sizeof(double2)); dmumps_par->nz_alloc = netrue; } /* Check for symmetry in order to initialize only * lower triangle on entry to symmetric MUMPS code */ if ((dmumps_par->sym)==0){ /* * Unsymmetric case: * build irn from mnel for MUMPS format * mA : number of rows */ if(doanal){ for(i=0;ijcn)[i]=(A.icol)[i];} k1=0; for (k2=1;k2irn[k1]=k2; /* matrix indices start at 1 */ k1=k1+1; nb_in_row=nb_in_row+1; } } } #if MUMPS_ARITH == MUMPS_ARITH_z for(i=0;ia)[i]).r = (A.R)[i];} if(A.it == 1){ for(i=0;ia)[i]).i = (A.I)[i];} }else{ for(i=0;ia)[i]).i = 0.0;} } #else for(i=0;ia)[i]) = (A.R)[i];} #endif dmumps_par->nz = ne; } else{ /* symmetric case */ k1=0; i=0; for (k2=1;k2= (A.icol)[i]){ if(k1>=netrue){ Scierror(999,"%s: The matrix must be symmetric\n",function_name); return 0; } (dmumps_par->jcn)[k1]=(A.icol)[i]; (dmumps_par->irn)[k1]=k2; #if MUMPS_ARITH == MUMPS_ARITH_z (dmumps_par->a)[k1].r=(A.R)[i]; if(A.it == 1){ ((dmumps_par->a)[k1]).i = (A.I)[i];} else{ ((dmumps_par->a)[k1]).i = 0.0;} #else ((dmumps_par->a)[k1]) = (A.R)[i]; #endif k1=k1+1;} nb_in_row=nb_in_row+1; i=i+1; } } dmumps_par->nz = k1; } GetRhsVar(2,"i",&mjob,&njob,&ljob); dmumps_par->job=*istk(ljob); GetRhsVar(3,"i",&micntl,&nicntl,&licntl); EXTRACT_FROM_SCILAB_TOARR(istk(licntl),dmumps_par->icntl,int,60); GetRhsVar(4,"d",&mcntl,&ncntl,&lcntl); EXTRACT_FROM_SCILAB_TOARR(stk(lcntl),dmumps_par->cntl,double,15); GetRhsVar(5,"i",&mperm, &nperm, &lperm); EXTRACT_FROM_SCILAB_TOPTR(IT_NOT_USED,istk(lperm),istk(lperm),(dmumps_par->perm_in),int,nA); GetRhsCVar(6,"d",&it,&mcols,&ncols,&lcols,&licols); EXTRACT_FROM_SCILAB_TOPTR(it,stk(lcols),stk(licols),(dmumps_par->colsca),double2,nA); GetRhsCVar(7,"d",&it,&mrows,&nrows,&lrows,&lirows); EXTRACT_FROM_SCILAB_TOPTR(it,stk(lrows),stk(lirows),(dmumps_par->rowsca),double2,nA); /* * To follow the "spirit" of the Matlab/Scilab interfaces, treat case of null * space separately. In that case, we initialize lrhs and nrhs automatically, * allocate the space needed, and do not rely on what is provided by the user * in component RHS, that is not touched. * At the moment the user should not call the solution step combined * with the factorization step when he/she sets icntl[25] to a non-zero value. * Hence we suppose infog[28-1] is available and we can use it. * * For users of scilab/matlab, it would still be nice to be able to set ICNTL(25)=-1, * and use JOB=6. If we want to make this functionality available, we should * call separately job=2 and job=3 even if job=5 or 6 and set nrhs (and allocate * space correctly) between job=2 and job=3 calls to MUMPS. * */ if ( dmumps_par->icntl[25-1] == -1 && dmumps_par->infog[28-1] > 0) { dmumps_par->nrhs=dmumps_par->infog[28-1]; donullspace = dosolve; } else if ( dmumps_par->icntl[25-1] > 0 && dmumps_par->icntl[25-1] <= dmumps_par->infog[28-1] ) { dmumps_par->nrhs=1; donullspace = dosolve; } else { donullspace=0; } if (donullspace) { nRHS=dmumps_par->nrhs; dmumps_par->lrhs=dmumps_par->n; dmumps_par->rhs=(double2 *)malloc((dmumps_par->n)*(dmumps_par->nrhs)*sizeof(double2)); dmumps_par->icntl[19]=0; } else if(GetType(8)!=5){ /* Dense RHS */ GetRhsCVar(8,"d",&itRHS,&mRHS,&nRHS,&lRHS,&liRHS); if((!dosolve) || (stk(lRHS)[0]) == -9999){ /* Could be dangerous ? See comment in Matlab interface */ EXTRACT_CMPLX_FROM_SCILAB_TOPTR(itRHS,stk(lRHS),stk(liRHS),(dmumps_par->rhs),double2,one); }else{ dmumps_par->nrhs = nRHS; dmumps_par->lrhs = mRHS; if(mRHS!=nA){ Scierror(999,"%s: Incompatible number of rows in RHS\n",function_name); } dmumps_par->icntl[19]=0; EXTRACT_CMPLX_FROM_SCILAB_TOPTR(itRHS,stk(lRHS),stk(liRHS),(dmumps_par->rhs),double2,(nRHS*mRHS)); } }else{ /* Sparse RHS */ GetRhsVar(8,"s",&mRHS,&nRHS,&RHS_SPARSE); dmumps_par->icntl[19]=1; dmumps_par->nrhs = nRHS; dmumps_par->lrhs = mRHS; nz_RHS=RHS_SPARSE.nel; dmumps_par->nz_rhs=nz_RHS; irhs_ptr=(int*)malloc((nRHS+1)*sizeof(int)); dmumps_par->irhs_ptr=(int*)malloc((nRHS+1)*sizeof(int)); dmumps_par->irhs_sparse=(int*)malloc(nz_RHS*sizeof(int)); dmumps_par->rhs_sparse=(double2*)malloc(nz_RHS*sizeof(double2)); dmumps_par->rhs=(double2*)malloc((nRHS*mRHS)*sizeof(double2)); /* transform row-oriented sparse multiple rhs (scilab) * into column-oriented sparse multiple rhs (mumps) */ k=0; for(i=0;iirhs_ptr[i]=0;} for(i=1;iirhs_ptr)[col_ind])++; } } (dmumps_par->irhs_ptr)[0]=1; irhs_ptr[0]=(dmumps_par->irhs_ptr)[0]; for(i=1;iirhs_ptr)[i]=(dmumps_par->irhs_ptr)[i]+(dmumps_par->irhs_ptr)[i-1]; irhs_ptr[i]= (dmumps_par->irhs_ptr)[i]; } k=RHS_SPARSE.nel-1; for(i=mRHS;i>=1;i--){ for(j=0;j<(RHS_SPARSE.mnel)[i-1];j++){ col_ind=(RHS_SPARSE.icol)[k]; (dmumps_par->irhs_sparse)[irhs_ptr[col_ind]-2]=i; #if MUMPS_ARITH == MUMPS_ARITH_z if(RHS_SPARSE.it==1){ ((dmumps_par->rhs_sparse)[irhs_ptr[col_ind]-2]).r=RHS_SPARSE.R[k]; ((dmumps_par->rhs_sparse)[irhs_ptr[col_ind]-2]).i=RHS_SPARSE.I[k]; }else{ ((dmumps_par->rhs_sparse)[irhs_ptr[col_ind]-2]).r=RHS_SPARSE.R[k]; ((dmumps_par->rhs_sparse)[irhs_ptr[col_ind]-2]).i=0.0; } #else (dmumps_par->rhs_sparse)[irhs_ptr[col_ind]-2]=RHS_SPARSE.R[k]; #endif k--; irhs_ptr[col_ind]=irhs_ptr[col_ind]-1; } } MYFREE(irhs_ptr); } GetRhsVar(9,"i",&nv_schu,&mv_schu,&lv_schu); dmumps_par-> size_schur=mv_schu; EXTRACT_FROM_SCILAB_TOPTR(IT_NOT_USED,istk(lv_schu),istk(lv_schu),(dmumps_par->listvar_schur),int,dmumps_par->size_schur); if(!dmumps_par->listvar_schur) dmumps_par->size_schur=0; if(dmumps_par->size_schur > 0){ MYFREE(dmumps_par->schur); if(!(dmumps_par->schur=(double2 *)malloc((dmumps_par->size_schur*dmumps_par->size_schur)*sizeof(double2)))){ Scierror(999,"%s: malloc Schur failed in intmumpsc.c\n",function_name); } dmumps_par->icntl[18]=1; }else{ dmumps_par->icntl[18]=0; } /* Reduced RHS */ if ( dmumps_par->size_schur > 0 && dosolve ) { if ( dmumps_par->icntl[26-1] == 2 ) { /* REDRHS is on input */ GetRhsCVar(11,"d",&itREDRHS,&mREDRHS,&nREDRHS,&lREDRHS,&liREDRHS); if (mREDRHS != dmumps_par->size_schur || nREDRHS != dmumps_par->nrhs ) { Scierror(999,"%s: bad dimensions for REDRHS\n"); } /* Fill dmumps_par->redrhs */ EXTRACT_CMPLX_FROM_SCILAB_TOPTR(itREDRHS,stk(lREDRHS),stk(liREDRHS),(dmumps_par->redrhs),double2,(nREDRHS*mREDRHS)); dmumps_par->lrhs=mREDRHS; } if ( dmumps_par->icntl[26-1] == 1 ) { /* REDRHS on output. Must be allocated before the call */ MYFREE(dmumps_par->redrhs); if(!(dmumps_par->redrhs=(double2 *)malloc((dmumps_par->size_schur*dmumps_par->nrhs)*sizeof(double2)))){ Scierror(999,"%s: malloc redrhs failed in intmumpsc.c\n",function_name); } } } /* call C interface to MUMPS */ dmumps_c(dmumps_par); } } if(*istk(ljob)==-2){ return 0; }else{ CheckLhs(11,11); EXTRACT_INT_FROM_C_TO_SCILAB(1,linfog,(dmumps_par->infog),one,temp1,one); EXTRACT_DOUBLE_FROM_C_TO_SCILAB(2,it,lrinfog,lrinfog,(dmumps_par->rinfog),one,temp2,one); if(dmumps_par->rhs && dosolve){ /* Just to know if solution step was called */ it =1; EXTRACT_CMPLX_FROM_C_TO_SCILAB(3,it,lrhsout,lrhsouti,(dmumps_par->rhs),nA,nRHS,one); }else{ it=1; EXTRACT_CMPLX_FROM_C_TO_SCILAB(3,it,lrhsout,lrhsouti,(dmumps_par->rhs),one,one,one); } ptr_int = (int *)dmumps_par; inst_address = (int) ptr_int; EXTRACT_INT_FROM_C_TO_SCILAB(4,linstout,&inst_address,one,one,one); temp4=dmumps_par->size_schur; if(temp4>0){ it=1; EXTRACT_CMPLX_FROM_C_TO_SCILAB(5,it,lschurout,lschurouti,(dmumps_par->schur),temp4,temp4,one); }else{ it=1; EXTRACT_CMPLX_FROM_C_TO_SCILAB(5,it,lschurout,lschurouti,(dmumps_par->schur),one,one,one); } /* REDRHS on output */ it=1; if ( dmumps_par->icntl[26-1]==1 && dmumps_par->size_schur > 0 && dosolve ) { len1=dmumps_par->size_schur; len2=dmumps_par->nrhs; } else { len1=1; len2=1; } it=1; EXTRACT_CMPLX_FROM_C_TO_SCILAB(6,it,stkptr,stkptri,(dmumps_par->redrhs),len1,len2,one) MYFREE(dmumps_par->redrhs); MYFREE(dmumps_par->schur); MYFREE(dmumps_par->irhs_ptr); MYFREE(dmumps_par->irhs_sparse); MYFREE(dmumps_par->rhs_sparse); MYFREE(dmumps_par->rhs); /* temp3=dmumps_par->deficiency;*/ temp3=dmumps_par->infog[27]; EXTRACT_INT_FROM_C_TO_SCILAB(7,lpivnul_list,(dmumps_par->pivnul_list),one,temp3,one); EXTRACT_INT_FROM_C_TO_SCILAB(8,lsymperm,(dmumps_par->sym_perm),one,nA,one); EXTRACT_INT_FROM_C_TO_SCILAB(9,lunsperm,(dmumps_par->uns_perm),one,nA,one); nicntl=60; EXTRACT_INT_FROM_C_TO_SCILAB(10,licntl,(dmumps_par->icntl),one,nicntl,one); ncntl=15; EXTRACT_DOUBLE_FROM_C_TO_SCILAB(11,it,lcntl,lcntl,(dmumps_par->cntl),one,ncntl,one); return 0; } } static GenericTable Tab[]={ #if MUMPS_ARITH == MUMPS_ARITH_z {(Myinterfun) sci_gateway, dmumpsc,"zmumpsc"} #else {(Myinterfun) sci_gateway, dmumpsc,"dmumpsc"} #endif }; #if MUMPS_ARITH == MUMPS_ARITH_z int C2F(scizmumps)() #else int C2F(scidmumps)() #endif {Rhs = Max(0, Rhs); (*(Tab[Fin-1].f))(Tab[Fin-1].name,Tab[Fin-1].F); return 0; } MUMPS_5.8.1/SCILAB/initmumps.sci0000664000175000017500000000071315042446422016124 0ustar amestoyamestoyfunction id = initmumps() // // id = initmumps // it returns a default Scilab MUMPS mlist (structure) // id = mlist(["StructMumps";"SYM";"JOB";"ICNTL";"CNTL";"PERM_IN";"COLSCA";"ROWSCA";"RHS";"INFOG";"RINFOG";"VAR_SCHUR";"SCHUR";"INST";"SOL";"REDRHS";"PIVNUL_LIST";"SYM_PERM";"UNS_PERM";"TYPE"],0,-1,zeros(1,60)-9998,zeros(1,15)-9998,-9999,-9999,-9999,-9999,zeros(1,80)-9998,zeros(1,40)-9998,-9999,-9999,-9999,-9999,-9999,-9999,-9999,-9999,0); endfunction MUMPS_5.8.1/SCILAB/Help/0000775000175000017500000000000015042446422014266 5ustar amestoyamestoyMUMPS_5.8.1/SCILAB/Help/help_dmumps.html0000664000175000017500000001635615042446422017504 0ustar amestoyamestoy 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. Some parameters related to distributed environments should not be modifed. For example, the solution should always be centralized and id.ICNTL(21) should thus remain to its default value, 0. Note that parameters id.ICNTL(1:4) may not work properly depending on your compiler and your environment. In case of problem, we recommand to swith printing off by setting id.ICNL(1:4)=-1.
  • id.PERM_IN : corresponds to the given ordering option (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). Note that this permutation is only accessed if the parameter id.ICNTL(7) is set to 1.
  • id.COLSCA and id.ROWSCA : are optional scaling arrays (see Section ``Input and output parameters'' of the MUMPS user's guide for more details)
  • id.RHS : defines the right-hand side. The parameter id.ICNTL(20) related to its format (sparse or dense) is automatically set within the interface. Note that id.RHS is not modified (as in MUMPS), the solution is returned in id.SOL.
  • id.VAR_SCHUR : corresponds to the list of variables that appear in the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details).
  • id.REDRHS (input parameter only if id.VAR_SCHUR was provided during the factorization and if ICNTL(26)=2 on entry to the solve phase): partial solution on the variables corresponding to the Schur complement. It is provided by the user and normally results from both the Schur complement and the reduced right-hand side that were returned by MUMPS in a previous call. When ICNTL(26)=2, MUMPS uses this information to build the solution id.SOL on the complete problem. See Section ``Schur complement'' of the MUMPS user's guide for more details.

Output Parameters

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

Internal Parameters

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

    • Description

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

         [id]=initmumps();

    Examples

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

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

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

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

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

    See Also

    initmumps,  zmumps,  

    References

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

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

    MUMPS_5.8.1/SCILAB/Help/manrev.dtd0000664000175000017500000000514215042446422016255 0ustar amestoyamestoy MUMPS_5.8.1/SCILAB/Help/help_zmumps.xml0000664000175000017500000002126615042446422017362 0ustar amestoyamestoy 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. Some parameters related to distributed environments should not be modifed. For example, the solution should always be centralized and id.ICNTL(21) should thus remain to its default value, 0. Note that parameters id.ICNTL(1:4) may not work properly depending on your compiler and your environment. In case of problem, we recommand to swith printing off by setting id.ICNL(1:4)=-1. id.PERM_IN : corresponds to the given ordering option (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). Note that this permutation is only accessed if the parameter id.ICNTL(7) is set to 1. id.COLSCA and id.ROWSCA : are optional scaling arrays (see Section ``Input and output parameters'' of the MUMPS user's guide for more details) id.RHS : defines the right-hand side. The parameter id.ICNTL(20) related to its format (sparse or dense) is automatically set within the interface. Note that id.RHS is not modified (as in MUMPS), the solution is returned in id.SOL. id.VAR_SCHUR : corresponds to the list of variables that appear in the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). id.REDRHS (input parameter only if id.VAR_SCHUR was provided during the factorization and if ICNTL(26)=2 on entry to the solve phase): partial solution on the variables corresponding to the Schur complement. It is provided by the user and normally results from both the Schur complement and the reduced right-hand side that were returned by MUMPS in a previous call. When ICNTL(26)=2, MUMPS uses this information to build the solution id.SOL on the complete problem. See Section ``Schur complement'' of the MUMPS user's guide for more details. id.SCHUR : if id.VAR_SCHUR is provided of size SIZE_SCHUR, then id.SCHUR corresponds to a dense array of size (SIZE_SCHUR,SIZE_SCHUR) that holds the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). The user does not have to initialize it. id.REDRHS (output parameter only if ICNTL(26)=1 and id.VAR_SCHUR was defined): Reduced right-hand side (or condensed right-hand side on the variables associated to the Schur complement). It is computed by MUMPS during the solve stage if ICNTL(26)=1. It can then be used outside MUMPS, together with the Schur complement, to build a solution on the interface. See Section ``Schur complement'' of the MUMPS user's guide for more details. id.INFOG and id.RINFOG : information parameters (see Section ``Information parameters'' of the MUMPS user's guide ). id.SYM_PERM : corresponds to a symmetric permutation of the variables (see discussion regarding ICNTL(7) in Section ``Control parameters'' of the MUMPS user's guide ). This permutation is computed during the analysis and is followed by the numerical factorization except when numerical pivoting occurs. id.UNS_PERM : column permutation (if any) on exit from the analysis phase of MUMPS (see discussion regarding ICNTL(6) in Section ``Control parameters'' of the MUMPS user's guide ). id.SOL : dense vector or matrix containing the solution after MUMPS solution phase. Also contains the nullspace in case of null space computation, or entries of the inverse, in case of computation of inverse entries.
    id.INST: (MUMPS reserved component) MUMPS internal parameter. id.TYPE: (MUMPS reserved component) defines the arithmetic (complex or double precision).

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

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

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

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

    MUMPS_5.8.1/SCILAB/Help/help_initmumps.html0000664000175000017500000000175215042446422020216 0ustar amestoyamestoy initmumps
    Mumps interface's function

    initmumps - Initialisation of the mumps structure

    Calling Sequence

    [id]=initmumps()

    Parameters

    • id : a structure (mlist)

    Description

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

    See Also

    dmumps,  zmumps,  

    References

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

    MUMPS_5.8.1/SCILAB/Help/help_zmumps.html0000664000175000017500000001635615042446422017532 0ustar amestoyamestoy 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. Some parameters related to distributed environments should not be modifed. For example, the solution should always be centralized and id.ICNTL(21) should thus remain to its default value, 0. Note that parameters id.ICNTL(1:4) may not work properly depending on your compiler and your environment. In case of problem, we recommand to swith printing off by setting id.ICNL(1:4)=-1.
    • id.PERM_IN : corresponds to the given ordering option (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). Note that this permutation is only accessed if the parameter id.ICNTL(7) is set to 1.
    • id.COLSCA and id.ROWSCA : are optional scaling arrays (see Section ``Input and output parameters'' of the MUMPS user's guide for more details)
    • id.RHS : defines the right-hand side. The parameter id.ICNTL(20) related to its format (sparse or dense) is automatically set within the interface. Note that id.RHS is not modified (as in MUMPS), the solution is returned in id.SOL.
    • id.VAR_SCHUR : corresponds to the list of variables that appear in the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details).
    • id.REDRHS (input parameter only if id.VAR_SCHUR was provided during the factorization and if ICNTL(26)=2 on entry to the solve phase): partial solution on the variables corresponding to the Schur complement. It is provided by the user and normally results from both the Schur complement and the reduced right-hand side that were returned by MUMPS in a previous call. When ICNTL(26)=2, MUMPS uses this information to build the solution id.SOL on the complete problem. See Section ``Schur complement'' of the MUMPS user's guide for more details.

    Output Parameters

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

    Internal Parameters

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

    • Description

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

         [id]=initmumps();

    Examples

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

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

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

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

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

    See Also

    initmumps,  dmumps,  

    References

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

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

    MUMPS_5.8.1/SCILAB/Help/help_dmumps.xml0000664000175000017500000002126615042446422017334 0ustar amestoyamestoy 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. Some parameters related to distributed environments should not be modifed. For example, the solution should always be centralized and id.ICNTL(21) should thus remain to its default value, 0. Note that parameters id.ICNTL(1:4) may not work properly depending on your compiler and your environment. In case of problem, we recommand to swith printing off by setting id.ICNL(1:4)=-1. id.PERM_IN : corresponds to the given ordering option (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). Note that this permutation is only accessed if the parameter id.ICNTL(7) is set to 1. id.COLSCA and id.ROWSCA : are optional scaling arrays (see Section ``Input and output parameters'' of the MUMPS user's guide for more details) id.RHS : defines the right-hand side. The parameter id.ICNTL(20) related to its format (sparse or dense) is automatically set within the interface. Note that id.RHS is not modified (as in MUMPS), the solution is returned in id.SOL. id.VAR_SCHUR : corresponds to the list of variables that appear in the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). id.REDRHS (input parameter only if id.VAR_SCHUR was provided during the factorization and if ICNTL(26)=2 on entry to the solve phase): partial solution on the variables corresponding to the Schur complement. It is provided by the user and normally results from both the Schur complement and the reduced right-hand side that were returned by MUMPS in a previous call. When ICNTL(26)=2, MUMPS uses this information to build the solution id.SOL on the complete problem. See Section ``Schur complement'' of the MUMPS user's guide for more details. id.SCHUR : if id.VAR_SCHUR is provided of size SIZE_SCHUR, then id.SCHUR corresponds to a dense array of size (SIZE_SCHUR,SIZE_SCHUR) that holds the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). The user does not have to initialize it. id.REDRHS (output parameter only if ICNTL(26)=1 and id.VAR_SCHUR was defined): Reduced right-hand side (or condensed right-hand side on the variables associated to the Schur complement). It is computed by MUMPS during the solve stage if ICNTL(26)=1. It can then be used outside MUMPS, together with the Schur complement, to build a solution on the interface. See Section ``Schur complement'' of the MUMPS user's guide for more details. id.INFOG and id.RINFOG : information parameters (see Section ``Information parameters'' of the MUMPS user's guide ). id.SYM_PERM : corresponds to a symmetric permutation of the variables (see discussion regarding ICNTL(7) in Section ``Control parameters'' of the MUMPS user's guide ). This permutation is computed during the analysis and is followed by the numerical factorization except when numerical pivoting occurs. id.UNS_PERM : column permutation (if any) on exit from the analysis phase of MUMPS (see discussion regarding ICNTL(6) in Section ``Control parameters'' of the MUMPS user's guide ). id.SOL : dense vector or matrix containing the solution after MUMPS solution phase. Also contains the nullspace in case of null space computation, or entries of the inverse, in case of computation of inverse entries.
    id.INST: (MUMPS reserved component) MUMPS internal parameter. id.TYPE: (MUMPS reserved component) defines the arithmetic (complex or double precision).

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

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

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

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

    MUMPS_5.8.1/SCILAB/Help/help_initmumps.xml0000664000175000017500000000230215042446422020042 0ustar amestoyamestoy eng initmumps Mumps interface's function Initialisation of the mumps structure [id]=initmumps() id : a structure (mlist)

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

    dmumps zmumps

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

    MUMPS_5.8.1/SCILAB/Help/whatis.htm0000664000175000017500000000076315042446422016305 0ustar amestoyamestoy Interface to the MUMPS package
    dmumps - sparse direct solver (MUMPS), double precision artithmetic
    zmumps - sparse direct solver (MUMPS), double complex artithmetic
    initmumps - initialisation routine for MUMPS
    MUMPS_5.8.1/SCILAB/zmumps.sci0000664000175000017500000000515115042446422015433 0ustar amestoyamestoyfunction id=zmumps(id,mat) //************************************************************************************************************** // [id] = zmumps(id,mat) // id is a structure (see details in initmumps.m and MUMPS documentation) // mat is an optional parameter if the job id.job = -1 or -2 // mat is a square sparse matrix // informations are return in id fields // // ************************************************************************************************************* if (typeof(id) ~= "StructMumps") then disp("Error. Please call initmumps first."); return; end arithtype=1; if id.JOB == -2 then if id.INST==-9999 then disp('Error. Uninitialized instance. MUMPS should be called with JOB=-1 first.'); return; end if id.TYPE ~= arithtype then disp('Error. You are trying to call z/d version on a d/z instance'); return; end // call the C routine zmumpsc zmumpsc(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS); id = []; return; end if id.JOB == -1 then if id.INST~=-9999 then disp('Error. Already initialized instance.'); return; end // call the C routine zmumpsc [inform,rinform,sol,inst,schu,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl] = zmumpsc(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS); id.INFOG = inform; id.RINFOG = rinform; id.SOL = sol; id.INST = inst; id.SCHUR = schu; id.REDRHS = redrhs; id.PIVNUL_LIST = pivnul_list; id.SYM_PERM = sym_perm; id.UNS_PERM = uns_perm; id.TYPE=arithtype; id.ICNTL=icntl; id.CNTL=cntl; clear inform rinform sol inst schu redrhs pivnul_list sym_perm uns_perm icntl cntl return; end if id.INST ==-9999 then disp('Uninitialized instance'); return; end // call the C routine zmumpsc if id.TYPE ~= arithtype then disp('You are trying to call z/d version on a d/z instance'); end [inform,rinform,sol,inst,schu,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl] = zmumpsc(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS, mat); id.INFOG = inform; id.RINFOG = rinform; id.SOL = sol; id.INST = inst; if (id.JOB == 2|id.JOB==4|id.JOB==6) then if id.SYM == 0 then id.SCHUR=schu'; else id.SCHUR=triu(schu)+tril(schu',-1); end end id.REDRHS = redrhs; id.PIVNUL_LIST = pivnul_list; id.SYM_PERM(sym_perm) = [1:size(mat,1)]; id.UNS_PERM = uns_perm; id.ICNTL=icntl; id.CNTL=cntl; clear inform rinform sol inst schu redrhs pivnul_list sym_perm uns_perm icntl cntl endfunction MUMPS_5.8.1/SCILAB/dmumps.sci0000664000175000017500000000515115042446422015405 0ustar amestoyamestoyfunction id=dmumps(id,mat) //************************************************************************************************************** // [id] = dmumps(id,mat) // id is a structure (see details in initmumps.m and MUMPS documentation) // mat is an optional parameter if the job id.job = -1 or -2 // mat is a square sparse matrix // informations are return in id fields // // ************************************************************************************************************* if (typeof(id) ~= "StructMumps") then disp("Error. Please call initmumps first."); return; end arithtype=1; if id.JOB == -2 then if id.INST==-9999 then disp('Error. Uninitialized instance. MUMPS should be called with JOB=-1 first.'); return; end if id.TYPE ~= arithtype then disp('Error. You are trying to call z/d version on a d/z instance'); return; end // call the C routine dmumpsc dmumpsc(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS); id = []; return; end if id.JOB == -1 then if id.INST~=-9999 then disp('Error. Already initialized instance.'); return; end // call the C routine dmumpsc [inform,rinform,sol,inst,schu,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl] = dmumpsc(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS); id.INFOG = inform; id.RINFOG = rinform; id.SOL = sol; id.INST = inst; id.SCHUR = schu; id.REDRHS = redrhs; id.PIVNUL_LIST = pivnul_list; id.SYM_PERM = sym_perm; id.UNS_PERM = uns_perm; id.TYPE=arithtype; id.ICNTL=icntl; id.CNTL=cntl; clear inform rinform sol inst schu redrhs pivnul_list sym_perm uns_perm icntl cntl return; end if id.INST ==-9999 then disp('Uninitialized instance'); return; end // call the C routine dmumpsc if id.TYPE ~= arithtype then disp('You are trying to call z/d version on a d/z instance'); end [inform,rinform,sol,inst,schu,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl] = dmumpsc(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS, mat); id.INFOG = inform; id.RINFOG = rinform; id.SOL = sol; id.INST = inst; if (id.JOB == 2|id.JOB==4|id.JOB==6) then if id.SYM == 0 then id.SCHUR=schu'; else id.SCHUR=triu(schu)+tril(schu',-1); end end id.REDRHS = redrhs; id.PIVNUL_LIST = pivnul_list; id.SYM_PERM(sym_perm) = [1:size(mat,1)]; id.UNS_PERM = uns_perm; id.ICNTL=icntl; id.CNTL=cntl; clear inform rinform sol inst schu redrhs pivnul_list sym_perm uns_perm icntl cntl endfunction MUMPS_5.8.1/SCILAB/examples/0000775000175000017500000000000015042446422015214 5ustar amestoyamestoyMUMPS_5.8.1/SCILAB/examples/cmplx_example.sce0000664000175000017500000000173315042446422020552 0ustar amestoyamestoy//A simple demo for the MUMPS interface //to run it, You just have to execute the instruction within Scilab // exec cmplx_example.sce; //*********************** MATRIX INITIALISATION ***********************// // This matrix has to be a SciSparse, otherwise it won't work. exec('ex.sci'); //voir pour les speyes n=size(a,1); mat=sparse(a)+%i*speye(n,n); // Right Hand side setting RHS = ones(n,1); //****************** Initialisation of the Scilab MUMPS structure ******************// timer(); [id]=initmumps(); //Here Job=-1, the next call will only initialise the C and Fortran structure [id]=zmumps(id); id.RHS=RHS; //******************** CALL TO MUMPS FOR RESOLUTION ********************// job=6; id.JOB=job; [id]=zmumps(id,mat); // verification of the solution solution=id.SOL; norm_res=norm(mat*solution-RHS,'inf'); write(%io(2),norm_res); //****************** DESTRUCTION OF THE MUMPS INSTANCE ******************// job=-2; id.JOB=job; [id]=zmumps(id); t=timer() MUMPS_5.8.1/SCILAB/examples/ex_rhs.sci0000664000175000017500000000007315042446422017204 0ustar amestoyamestoyrhs(2,1)=3; rhs(5,1)=1; rhs(1,2)=8; rhs(2,2)=2; rhs(4,2)=3;MUMPS_5.8.1/SCILAB/examples/sparseRHS_example.sce0000664000175000017500000000200215042446422021267 0ustar amestoyamestoy//A simple demo for the MUMPS interface, with the use of a sparse Right Hand Side //to run it, You just have to execute the instruction within Scilab // exec sparse_example.sce; //*********************** MATRIX INITIALISATION ***********************// // This matrix has to be a SciSparse, otherwise it won't work. exec('ex.sci'); //voir pour les speyes mat=sparse(a); // Right Hand side setting exec('ex_rhs.sci'); RHS = sparse(rhs); //****************** Initialisation of the Scilab MUMPS structure ******************// timer(); [id]=initmumps(); //Here Job=-1, the next call will only initialise the C and Fortran structure [id]=dmumps(id); id.RHS=RHS; //******************** CALL TO MUMPS FOR RESOLUTION ********************// job=6; id.JOB=job; [id]=dmumps(id,mat); // verification of the solution solution=id.SOL; norm_res=norm(mat*solution-RHS,'inf'); write(%io(2),norm_res); //****************** DESTRUCTION OF THE MUMPS INSTANCE ******************// job=-2; id.JOB=job; [id]=dmumps(id); t=timer() MUMPS_5.8.1/SCILAB/examples/ex.sci0000664000175000017500000000022215042446422016324 0ustar amestoyamestoya(1,2)=3.0; a(2,3)=-3.0; a(4,3)=2.0; a(5,5)=1.0; a(2,1)=3.0; a(1,1)=2.0; a(5,2)=4.0; a(3,4)=2.0; a(2,5)=6.0; a(3,2)=-1.0; a(1,3)=4.0; a(3,3)=1.0; MUMPS_5.8.1/SCILAB/examples/double_example.sce0000664000175000017500000000166215042446422020702 0ustar amestoyamestoy//A simple demo for the MUMPS interface //to run it, You just have to execute the instruction within Scilab // exec double_example.sce; //*********************** MATRIX INITIALISATION ***********************// // This matrix has to be a SciSparse, otherwise it won't work. exec('ex.sci'); mat=sparse(a); // Right Hand side setting RHS = ones(size(mat,1),1); //****************** Initialisation of the Scilab MUMPS structure ******************// timer(); [id]=initmumps(); //Here Job=-1, the next call will only initialise the C and Fortran structure [id]=dmumps(id); id.RHS=RHS; //******************** CALL TO MUMPS FOR RESOLUTION ********************// job=6; id.JOB=job; [id]=dmumps(id,mat); // verification of the solution solution=id.SOL; norm_res=norm(mat*solution-RHS,'inf'); write(%io(2),norm_res); //****************** DESTRUCTION OF THE MUMPS INSTANCE ******************// job=-2; id.JOB=job; [id]=dmumps(id); t=timer() MUMPS_5.8.1/SCILAB/examples/schur_example.sce0000664000175000017500000000317515042446422020555 0ustar amestoyamestoy//A simple demo for the MUMPS interface, with the return of the schur complement //to run it, You just have to execute the instruction within Scilab // exec sparse_example.sce; //*********************** MATRIX INITIALISATION ***********************// n=10; mat=sprand(n,n,.5)+speye(n,n); size_schur=3; // Right Hand side setting RHS = ones(n,1); //****************** Initialisation of the Scilab MUMPS structure ******************// timer(); [id]=initmumps(); //Here Job=-1, the next call will only initialise the C and Fortran structure [id]=dmumps(id); id.RHS=RHS; id.VAR_SCHUR = [n-size_schur+1:n]; //******************** CALL TO MUMPS FOR RESOLUTION ON INTERNAL PROBLEM ************// job=6; id.JOB=job; [id]=dmumps(id,mat); // verification of the solution solution=id.SOL; norm1=norm(mat(1:n-size_schur,1:n-size_schur)*solution(1:n-size_schur) - ones(n-size_schur,1),'inf'); if norm1> 10^(-9) then write(%io(2),'WARNING: solution on internal problem may not be OK'); else write(%io(2),'SOLUTION on internal problem ok'); end //******************* TRY REDUCED RHS FUNCTIONALITY **************// id.JOB=3; id.ICNTL(26)=1; // Forward [id]=dmumps(id,mat); // Solve the problem on the Schur complement id.REDRHS=id.SCHUR \ id.REDRHS; // and reinject it to MUMPS id.ICNTL(26)=2; [id]=dmumps(id,mat); solution=id.SOL; norm1=norm(mat*solution-RHS,'inf') if norm1> 10^(-9) then write(%io(2),'WARNING: solution on complete problem may not be OK'); else write(%io(2),'SOLUTION on complete problem ok'); end //****************** DESTRUCTION OF THE MUMPS INSTANCE ******************// job=-2; id.JOB=job; [id]=dmumps(id); t=timer() MUMPS_5.8.1/SCILAB/builder.sce0000664000175000017500000000524315042446422015524 0ustar amestoyamestoy// $Id: builder_source.sce 7142 2011-03-22 23:45:59Z jylexcel $ //******************* VARIABLE PART TO COSTUMIZE ***************************// // -- MUMPS: MUMPS_DIR = home + "/MUMPS_5.8.1"; MUMPS_INC_DIR = MUMPS_DIR+"/include"; //path until dmumps_c.h and zmumps_c.h MUMPS_LIB_DIR = MUMPS_DIR+"/lib"; //path until libdmumps.a, libzmumps.a and libpord.a MUMPS_LIB = MUMPS_LIB_DIR+"/libmumps_common.a"; DMUMPS_LIB = MUMPS_LIB_DIR+"/libdmumps.a"; ZMUMPS_LIB = MUMPS_LIB_DIR+"/libzmumps.a"; LIB_MPISEQ = MUMPS_DIR+"/libseq/libmpiseq.a"; // -- SCILAB: Path to scilab routines SCI_DIR_INC = "/usr/include/scilab/"; // -- BLAS library, if not already included in Scilab: BLAS_LIB = ""; // -- ORDERINGS (should correspond to the ones defined MUMPS's Makefile.inc): PORD_LIB = MUMPS_LIB_DIR+"libpord.a"; METIS_LIB = HOME+"/metis-4.0/libmetis.a"; ORDERINGS_LIB = PORD_LIB+" "+METIS_LIB; // -- PTHREAD lib required by MUMPS versions > 4.6 PTHREAD_LIB="-lpthread"; // -- COMPILER FOR THE INTERFACE COMPILER_= "gcc -c -O -fPIC"; // -- FORTRAN RUNTIME LIBRARIES // -- g95 //FORT_LIB = "/usr/lib/libf95.a /usr/lib/libgcc.a"; // -- gfortran compiler FORT_LIB="/usr/lib/libgfortran.a"; // -- ifort compiler //FORT_LIB_DIR = "/opt/intel/fc/9.0/lib/"; //FORT_LIB = FORT_LIB_DIR+"libifcore.a"+" "+FORT_LIB_DIR+"libimf.a"+" "+FORT_LIB_DIR+"libguide.a"+" "+FORT_LIB_DIR+"libirc.a"; //**************************************************************************// //******************* DON't EDIT BELOW (Normally) **************************// //---- Build the Makefile fd=mopen("Makefile","w"); mfprintf(fd,"SCIDIRINC = %s\n",SCI_DIR_INC); mfprintf(fd,"MUMPSINCDIR = %s\n",MUMPS_INC_DIR); mfprintf(fd,"CC = %s\n", COMPILER_); mfprintf(fd,"all: intdmumpsc.o intzmumpsc.o\n"); mfprintf(fd,"intdmumpsc.o: intmumpsc.c\n"); mfprintf(fd,"\t$(CC) -o $@ $? -DMUMPS_ARITH=MUMPS_ARITH_d -I${MUMPSINCDIR} -I${SCIDIRINC}\n"); mfprintf(fd,"intzmumpsc.o: intmumpsc.c\n"); mfprintf(fd,"\t$(CC) -o $@ $? -DMUMPS_ARITH=MUMPS_ARITH_z -I${MUMPSINCDIR} -I${SCIDIRINC}\n"); mfprintf(fd,"clean:\n"); mfprintf(fd,"\trm *.o loader_inc.sce\n"); mclose(fd); //---- Compile unix("make"); //---- Build the Loader_inc.sce fd=mopen("loader_inc.sce","w"); mfprintf(fd,"objects = [ path+\""intzmumpsc.o\"" ; \n") mfprintf(fd," path+\""intdmumpsc.o\"" ; \n") mfprintf(fd," \""%s\"" ; \n",DMUMPS_LIB) mfprintf(fd," \""%s\"" ; \n",ZMUMPS_LIB) mfprintf(fd," \""%s\"" ; \n",ORDERINGS_LIB) mfprintf(fd," \""%s\"" ; \n",LIB_MPISEQ) mfprintf(fd," \""%s\"" ; \n",PORD_LIB) mfprintf(fd," \""%s\"" ; \n",METIS_LIB) mfprintf(fd," \""%s\"" ; \n",BLAS_LIB) mfprintf(fd," \""%s\"" ; \n",FORT_LIB) mfprintf(fd," \""%s\"" ]; \n",PTHREAD_LIB) mclose(fd); MUMPS_5.8.1/SCILAB/README0000664000175000017500000001165415042446422014265 0ustar amestoyamestoyREADME ************************************************************************ * This SCILAB interface to MUMPS is provided to you free of charge * * and is part of the MUMPS package (see ../LICENSE for the * * conditions of use), http://mumps-solver.org * * * * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY * * EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. * * * * More information is available in the main MUMPS userguide and in: * * * * [2006] Aurelia Fevre, Jean-Yves L'Excellent and Stephane Pralet * * MATLAB and Scilab interfaces to MUMPS. LIP Report RR2006-06. * * Also available as an INRIA and an ENSEEIHT-IRIT Technical Report. * * * ************************************************************************ * * * IMPORTANT NOTICE: This interface does not include the most recent * * MUMPS features (e.g., entries of the inverse) and was * * only tested with Scilab 4 version. We plan to upgrade it * * in the future. * * * ************************************************************************ CONTENTS OF THE DIRECTORY: README : this file builder.sce : Scilab script to build the makefile, the loader_inc.sce and to compile intdmumpsc.c and intzmumps.c (to be executed once) intdmumpsc.c : C interface file to double precision version of MUMPS intzmumpsc.c : C interface file for double complex version of MUMPS loader.sce : installation script (to be executed each time scilab is launched) initmumps.sci : Scilab file for the initialisation of the mumps structure dmumps.sci : Scilab file for double precision version zmumps.sci : Scilab file for double complex version loader_inc.sce, Makefile, object files: Generated when executing the builder examples/ double_example.sce : file containing an example of using MUMPS in Scilab cmplx_example.sce : file containing an example of using MUMPS in Scilab, with a complex matrix schur_example.sce : file containing an example of using MUMPS in Scilab, with the schur option sparseRHS_example.sce : file containing an example of using MUMPS in Scilab, with a sparse multiple right hand side ex.sci : small sparse matrix used to run the examples ex2.sci : small sparse matrix used to run the schur_example ex_rhs.sci : small sparse right hand side used to run the examples *************************************************************************************** INSTALLATION : You need: 1- scilab version 3.x or 4.x (not tested with recent versions of scilab) 2- to have compiled/linked a sequential version of MUMPS with both double precision and double complex arithmetics ("make d" and "make z", or "make all") 3- to modify the paths in the builder.sce. In particular you will need to give the path to the runtime libraries of your FORTRAN 90 compiler. 4- to execute builder.sce and loader.sce by using the "exec" instruction within Scilab: exec('builder.sce'); exec('loader.sce'); SOME EXPLANATIONS: - Modifications of builder.sce In this file, you will find a variable part to customize. The following modifications have to be done after the installation of MUMPS, i.e., after having a working MUMPS library. o First, the paths until libmpiseq.a, libdmumpsc.a and libpord.a. If you have not installed these libraries in specific places, and assuming that you are using MUMPS version 4.5.5, the path should be: xxxx/MUMPS_4.5.5/Include/ xxxx/MUMPS_4.5.5/lib/ xxxx/MUMPS_4.5.5/libseq/ o Second, the C compiler with the flag for compilation only. For example: cc -c -O or gcc -c -O. o Finally, the harder part: you must define the libraries used by the Fortran compiler that was used to compile MUMPS. - Modifications of loader.sce The only thing to do in this file is to change the path DIR_SCIMUMPS; it has to be the path to Scilab files *************************************************************************************** LIMITATIONS: The behaviour of the interface strongly depends on the Fortran compilers and platform used. It has been tested on a limited set of these (for example, the g95 compiler with Scilab 3.0 and 3.1 under a Linux PC). This interface does not support MUMPS parallel versions, and has not been tested under Windows environments). MUMPS_5.8.1/SCILAB/loader.sce0000664000175000017500000000144415042446422015343 0ustar amestoyamestoypath= get_absolute_file_path('loader.sce'); exec(path+"/loader_inc.sce"); functions1 = ["dmumpsc"]; functions2 = ["zmumpsc"]; entrypoint1 = "scidmumps"; entrypoint2 = "scizmumps"; addinter(objects,entrypoint1,functions1) num_interface = floor(funptr("dmumpsc")/100); intppty(num_interface) addinter(objects,entrypoint2,functions2) num_interface = floor(funptr("zmumpsc")/100); intppty(num_interface) [units,typs,nams]=file(); clear units typs for k=size(nams,'*'):-1:1 l=strindex(nams(k),'loader.sce'); if l<>[] then DIR_SCIMUMPS = part(nams(k),1:l($)-1); break end end DIR_SCIMUMPS_DEM=DIR_SCIMUMPS+ "examples/"; getf(DIR_SCIMUMPS+"initmumps.sci") getf(DIR_SCIMUMPS+"dmumps.sci") getf(DIR_SCIMUMPS+"zmumps.sci") add_help_chapter("Interface to the MUMPS package",path+"Help"); MUMPS_5.8.1/CREDITS0000664000175000017500000000373015042446416013467 0ustar amestoyamestoyThis version of MUMPS has been developed by employees of CERFACS, CNRS, EDF, ENS Lyon, Toulouse INP-IRIT, Inria, Mumps Technologies, Sorbonne University and University of Bordeaux: Emmanuel Agullo, Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Philippe Combes, Marie Durand, Aurelia Fevre, Matthieu Gerest, Abdou Guermouche, Antoine Jego, Guillaume Joslin, Jacko Koster, Jean-Yves L'Excellent, Theo Mary, Stephane Pralet, Chiara Puglisi, Francois-Henry Rouet, Wissam Sid-Lakhdar, Tzvetomila Slavova, Bora Ucar and Clement Weisbecker. Since January 2019, the MUMPS solver is maintained by Mumps Technologies (http://mumps-tech.com). We are grateful to Caroline Bousquet, Indranil Chowdhury, Christophe Daniel, Iain Duff, Vincent Espirat, Gilles Moreau, Gregoire Richard, Alexis Salzman, Miroslav Tuma and Christophe Voemel who have been contributing to this project. We are also grateful to Juergen Schulze for letting us distribute PORD developed at the University of Paderborn. We thank Eddy Caron for the administration of a server that has been used during many years for MUMPS. We want to thank the French ANR programme, the European community, Airbus Group-IW, Altair, ANSYS, CINES, EDF, EMGS, ESI Group, FFT/Hexagon, LBNL, LSTC, Michelin, NEC, SAFRAN, SAMTECH, Shell, Siemens, Total and University of Southern California for their support. We also thank LBNL, LSTC, PARALLAB and the Rutherford Appleton Laboratory for research discussions that have certainly influenced this work. Finally we want to thank the institutions that have provided access to their parallel machines: Centre Informatique National de l'Enseignement Superieur (CINES), CERFACS, CALMIP ("Centre Interuniversitaire de Calcul" located in Toulouse), Centre Blaise Pascal de Simulation et de Modélisation Numérique, Institut du Developpement et des Ressources en Informatique Scientifique (IDRIS), Lawrence Berkeley National Laboratory, Laboratoire de l'Informatique du Parallelisme, Inria, and PARALLAB. MUMPS_5.8.1/Make.inc/0000775000175000017500000000000015042446416014071 5ustar amestoyamestoyMUMPS_5.8.1/Make.inc/Makefile.debian.PAR0000664000175000017500000000442115042446416017374 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # # These settings for a PC under Debian/linux with standard packages : # metis (parmetis), scotch (ptscotch), openmpi, gfortran # packages installation: # apt-get install libmetis-dev libparmetis-dev libscotch-dev libptscotch-dev libatlas-base-dev openmpi-bin libopenmpi-dev liblapack-dev libscalapack-openmpi-dev # Begin orderings LSCOTCHDIR = /usr/lib ISCOTCH = -I/usr/include/scotch #LSCOTCH = -L$(LSCOTCHDIR) -lptesmumps -lptscotch -lptscotcherr LSCOTCH = -L$(LSCOTCHDIR) -lesmumps -lscotch -lscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) LMETISDIR = /usr/lib #IMETIS = -I/usr/include/parmetis IMETIS = -I/usr/include/metis # LMETIS = -L$(LMETISDIR) -lparmetis -lmetis LMETIS = -L$(LMETISDIR) -lmetis # Corresponding variables reused later #ORDERINGSF = -Dmetis -Dpord -Dparmetis -Dscotch -Dptscotch ORDERINGSF = -Dmetis -Dpord -Dscotch ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) # End orderings ################################################################################ PLAT = LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ LIBEXT = .a OUTC = -o OUTF = -o RM = /bin/rm -f CC = mpicc FC = mpif90 FL = mpif90 AR = ar vr RANLIB = ranlib LAPACK = -llapack SCALAP = -lscalapack-openmpi # -lblacs-openmpi INCPAR = # not needed with mpif90/mpicc: -I/usr/include/openmpi LIBPAR = $(SCALAP) $(LAPACK) # not needed with mpif90/mpicc: -lmpi_mpifh -lmpi INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) LIBBLAS = -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -fopenmp -fallow-argument-mismatch # Uncomment the line below if your version of gfortran is < 10 #OPTF = -O -fopenmp OPTL = -O -fopenmp OPTC = -O -fopenmp #End Optimized options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.8.1/Make.inc/Makefile.G95.PAR0000664000175000017500000000762615042446416016530 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ################################################################################ PLAT = LIBEXT = .a LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ OUTC = -o OUTF = -o RM = /bin/rm -f CC = gcc FC = g95 FL = g95 AR = ar vr RANLIB = echo LAPACK =/usr/local/ATLAS/lib/Linux_P4SSE2/liblapack.a SCALAP = /usr/local/SCALAPACK/libscalapack.a /usr/local/BLACS/LIB/blacsCinit_MPI-LINUX-0.a /usr/local/BLACS/LIB/blacsF77init_MPI-LINUX-0.a /usr/local/BLACS/LIB/blacs_MPI-LINUX-0.a INCPAR = -I/usr/local/mpich-1.2.7p1/include LIBPAR = $(SCALAP) $(LAPACK) -L/usr/local/mpich-1.2.7p1/lib -lfmpich -lmpich INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) #LIBBLAS = /usr/local/lib/libgoto_coppermine32p-r1.00.so LIBBLAS =/usr/local/ATLAS/lib/Linux_P4SSE2/libf77blas.a /usr/local/ATLAS/lib/Linux_P4SSE2/libatlas.a -lg2c LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd__ #Begin Optimization options OPTF = -O -i4 OPTL = -O OPTC = -O #End Optimization options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.8.1/Make.inc/Makefile.FREEBSD10.SEQ0000664000175000017500000000720615042446416017377 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ################################################################################ PLAT = LIBEXT = .a LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ OUTC = -o "" OUTF = -o "" RM = /bin/rm -f CC = cc FC = gfortran48 FL = gfortran48 # keep a space at the end if options have to be separated from lib name AR = ar -vr "" RANLIB = ranlib LAPACK = -llapack INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) LIBBLAS = -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options # uncomment -fopenmp in lines below to benefit from OpenMP OPTF = -O #-fopenmp OPTL = -O #-fopenmp OPTC = -O -I. #-fopenmp #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.8.1/Make.inc/Makefile.SP64.PAR0000664000175000017500000000777515042446416016665 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -WF,-Dscotch -WF,-Dmetis -WF,-Dpord -WF,-Dptscotch -WF,-Dparmetis #ORDERINGSC = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSC = -Dpord ORDERINGSF = -WF,-Dpord LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## PLAT = LIBEXT = .a LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ OUTC = -o OUTF = -o RM = /bin/rm -f CC = mpcc_r FC = mpxlf90_r FL = mpxlf90_r AR = ar -X64 vr RANLIB = ranlib LAPACK = /usr/local/pub/LAPACK/lapack.a #LAPACK = /usr/common/usg/LAPACK/3.0a/lapack_SP.a #LAPACK = /usr/local/lib/liblapack_cci.a SCALAP = -lpesslsmp -lblacssmp INCPAR = # -I/usr/lpp/ppe.poe/include LIBPAR = $(SCALAP) $(LAPACK) # -L/usr/lpp/ppe.poe/lib -lmpi INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) LIBBLAS = -lessl LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = #Begin Optimization options OPTF = -WF,-DPESSL -WF,-DSP_ -O3 -qstrict -qmaxmem=-1 -Q -qfixed -qalign=4k -qarch=auto -qtune=auto -qcache=auto -q64 -B/usr/lib/ -tF OPTC = -O3 -qstrict -qarch=auto -qtune=auto -qcache=auto -Q=150 -s -qmaxmem=-1 -qcpluscmt -q64 OPTL = -O3 -qstrict -Q -qfixed -qalign=4k -q64 #End Optimization options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.8.1/Make.inc/Makefile.INTEL.PAR0000664000175000017500000000757215042446416017037 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ################################################################################ PLAT = LIBEXT = .a LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ OUTC = -o OUTF = -o RM = /bin/rm -f CC = mpiicc FC = mpiifort FL = mpiifort AR = ar vr #RANLIB = ranlib RANLIB = echo # Make this variable point to the path where the Intel MKL library is # installed. It is set to the default install directory for Intel MKL. MKLROOT=/opt/intel/mkl/lib/intel64 LAPACK = -L$(MKLROOT) -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core SCALAP = -L$(MKLROOT) -lmkl_scalapack_lp64 -lmkl_blacs_intelmpi_lp64 LIBPAR = $(SCALAP) $(LAPACK) INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) LIBBLAS = -L$(MKLROOT) -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -nofor_main -qopenmp -DGEMMT_AVAILABLE OPTL = -O -nofor_main -qopenmp OPTC = -O -qopenmp #End Optimized options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.8.1/Make.inc/Makefile.INTEL.SEQ0000664000175000017500000000743415042446416017042 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ################################################################################ PLAT = LIBEXT = .a LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ OUTC = -o OUTF = -o RM = /bin/rm -f CC = icc FC = ifort FL = ifort AR = ar vr #RANLIB = ranlib RANLIB = echo # Make this variable point to the path where the Intel MKL library is # installed. It is set to the default install directory for Intel MKL. MKLROOT=/opt/intel/mkl/lib/intel64 LAPACK = -L$(MKLROOT) -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) LIBBLAS = -L$(MKLROOT) -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -nofor_main -qopenmp -DGEMMT_AVAILABLE OPTL = -O -nofor_main -qopenmp OPTC = -O -qopenmp #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.8.1/Make.inc/Makefile.SGI.SEQ0000664000175000017500000000712615042446416016607 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## PLAT = LIBEXT = .a LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ OUTC = -o OUTF = -o RM = /bin/rm -f CC = cc FC = f90 FL = f90 AR = ar vr RANLIB = echo LAPACK = /usr/lib64/libcomplib.sgimath.so INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) LIBBLAS = -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimization options OPTF = -Dsgi -O -OPT:Olimit=0 -mips4 -64 -align64 OPTL = -O -OPT:Olimit=0 -mips4 -64 -align64 OPTC = -O -OPT:Olimit=0 -mips4 -64 -align64 NOOPT = -Dsgi -mips4 -64 -align64 #End Optimization options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.8.1/Make.inc/Makefile.SP64.SEQ0000664000175000017500000000760015042446416016656 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -WF,-Dscotch -WF,-Dmetis -WF,-Dpord -WF,-Dptscotch -WF,-Dparmetis #ORDERINGSC = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSC = -Dpord ORDERINGSF = -WF,-Dpord LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## PLAT = LIBEXT = .a LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ OUTC = -o OUTF = -o RM = /bin/rm -f CC = cc_r FC = xlf90_r FL = xlf90_r AR = ar -X64 vr RANLIB = ranlib LAPACK = /usr/local/pub/LAPACK/lapack.a #LAPACK = /usr/common/usg/LAPACK/3.0a/lapack_SP.a #LAPACK = /usr/local/lib/liblapack_cci.a INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) LIBBLAS = -lessl LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = #Begin Optimization options OPTF = -WF,-DPESSL -WF,-DSP_ -O3 -qstrict -qmaxmem=-1 -Q -qfixed -qalign=4k -qarch=auto -qtune=auto -qcache=auto -q64 -B/usr/lib/ -tF OPTC = -O3 -qstrict -qarch=auto -qtune=auto -qcache=auto -Q=150 -s -qmaxmem=-1 -qcpluscmt -q64 OPTL = -O3 -qstrict -Q -qfixed -qalign=4k -q64 #End Optimization options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.8.1/Make.inc/Makefile.NEC.VH0000664000175000017500000000441315042446442016452 0ustar amestoyamestoy# # ------------------------------------------------------------------------------------ # This Makefile part is dedicated to the use of VH offload of scalar routines of MUMPS # ------------------------------------------------------------------------------------ # # # Some symbols of METIS are still used on the VE. METIS on VE is thus needed. # LMETISDIR = -L/path/to/ve/metis/lib IMETIS = -I/path/to/ve/metis/include # # We need the metis on the Vector Host which will run when offloading is triggered. # Make sure VH metis is compiled with -fPIC # VHMETISLIBDIR = /path/to/vh/metis/lib # # The next section is related to the compilation of the interface of the code to be # offloaded (VE to VH) and to the generation of the Vector Host library (libvh.so). # The GNU compiler on your system will be used to generate the VH library. # Note that in order to work properly, you must add the VHOUTPUTDIR path to # the LD_LIBRARY_PATH. # VHOUTPUTDIR = $(topdir)/lib VEINCDIR = $(topdir)/src/ve/include VESRCDIR = $(topdir)/src/ve/src VHMUMPSSRCDIR = $(topdir)/src VHMUMPSOBJDIR = $(topdir)/src VHMUMPSOBJS = $(VHMUMPSOBJDIR)/ana_orderings.vh.o $(VHMUMPSOBJDIR)/ana_AMDMF.vh.o VHCC := gcc VHFC := gfortran VHCCOPT := -O2 -fPIC VHFCOPT := -O2 -fPIC VEOBJS := $(VESRCDIR)/VE_Metis_interface.o \ $(VESRCDIR)/VE_Metis_nodend.o \ $(VESRCDIR)/VE_Metis_setdefaultoptions.o \ $(VESRCDIR)/VE_Ana_orderings_interface.o \ $(VESRCDIR)/VE_Mumps_ana_h.o \ $(VESRCDIR)/VE_Mumps_symqamd.o \ $(VESRCDIR)/VE_Mumps_wrap_ginp94.o $(VHMUMPSOBJDIR)/%.vh.o : $(VHMUMPSSRCDIR)/%.F $(VHFC) $(VHFCOPT) -c $< -o $@ $(VESRCDIR)/%.o : $(VESRCDIR)/%.c $(CC) $(OPTC) $(IMETIS) -I$(VEINCDIR) $(CDEFS) -c $< -o $@ $(VESRCDIR)/%.o : $(VESRCDIR)/%.f90 $(FC) $(OPTF) -c $< -o $@ d c s z : vhlib clean : cleanvhlib vhlib: $(VEOBJS) $(VHMUMPSOBJS) @mkdir -p $(VHOUTPUTDIR) @$(VHFC) -shared -Wl,-soname,libvh.so -o $(VHOUTPUTDIR)/libvh.so $(VHMUMPSOBJS) -Wl,--whole-archive $(VHMETISLIBDIR)/libmetis.a -Wl,--no-whole-archive OBJS_COMMON_OTHER += $(VEOBJS) cleanvhlib: @$(RM) $(VEOBJS) $(VHMUMPSOBJS) ORDERINGSF += -Dmetis OPTF += -DVHOFFLOAD -I$(VEINCDIR) LMETIS = $(LMETISDIR) -lmetis MUMPS_5.8.1/Make.inc/Makefile.debian.SEQ0000664000175000017500000000414015042446416017400 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # # These settings for a PC under Debian/linux with standard packages : # metis (parmetis), scotch (ptscotch), openmpi, gfortran # packages installation: # apt-get install libmetis-dev libparmetis-dev libscotch-dev libptscotch-dev libatlas-base-dev openmpi-bin libopenmpi-dev liblapack-dev libscalapack-openmpi-dev # Begin orderings LSCOTCHDIR = /usr/lib ISCOTCH = -I/usr/include/scotch #LSCOTCH = -L$(LSCOTCHDIR) -lptesmumps -lptscotch -lptscotcherr LSCOTCH = -L$(LSCOTCHDIR) -lesmumps -lscotch -lscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) LMETISDIR = /usr/lib #IMETIS = -I/usr/include/parmetis IMETIS = -I/usr/include/metis # LMETIS = -L$(LMETISDIR) -lparmetis -lmetis LMETIS = -L$(LMETISDIR) -lmetis # Corresponding variables reused later #ORDERINGSF = -Dmetis -Dpord -Dparmetis -Dscotch -Dptscotch ORDERINGSF = -Dmetis -Dpord -Dscotch ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) # End orderings ################################################################################ PLAT = LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ LIBEXT = .a OUTC = -o OUTF = -o RM = /bin/rm -f CC = gcc FC = gfortran FL = gfortran AR = ar vr RANLIB = ranlib LAPACK = -llapack INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) LIBBLAS = -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -fopenmp -fallow-argument-mismatch # Uncomment the line below if your version of gfortran is < 10 #OPTF = -O -fopenmp OPTL = -O -fopenmp OPTC = -O -fopenmp #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.8.1/Make.inc/Makefile.SUN.SEQ0000664000175000017500000000674515042446416016640 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## PLAT = LIBEXT = .a LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ OUTC = -o OUTF = -o CPP = /lib/cpp -P -C RM = /bin/rm -f CC = cc FC = f90 FL = f90 AR = ar vr RANLIB = echo LAPACK = #included in SunPerf INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) LIBBLAS = -lsunperf -lf77compat LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -DSUN_ OPTL = -O OPTC = -O #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.8.1/Make.inc/Makefile.NEC.PAR0000664000175000017500000001037415042446416016563 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) # # The following section deals with Vector Host offloading of scalar code # like METIS or symbolic factorization. By default it is activated. If you # prefer run all code on the VE (not recommended), set WITH_VHOFFLOAD to no. # Activation is recommended for optimal performance. # # In case WITH_VHOFFLOAD is set to yes, Make.inc/Makefile.NEC.VH should # be edited (e.g. to provide the path to METIS library on the Vector Host) WITH_VHOFFLOAD := yes ifeq ($(WITH_VHOFFLOAD),yes) include $(topdir)/Make.inc/Makefile.NEC.VH else #LMETISDIR = -L/opt/metis-5.1.0/build/ve/libmetis #IMETIS = -I/opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis endif # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF += -Dpord ORDERINGSC += $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ################################################################################ PLAT = LIBEXT = .a LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ OUTC = -o OUTF = -o RM = rm -f CC = mpincc FC = mpinfort FL = mpinfort AR = nar vr RANLIB = echo LAPACK = -llapack SCALAP = -lscalapack #INCPAR = LIBPAR = $(SCALAP) $(LAPACK) LIBBLAS = -lblas_openmp LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ # # Inline basics # STRIP_TOPDIR = $(strip $(topdir)) MUMPS_INLINE_LIST = -finline-functions -finline-max-depth=5 -finline-max-function-size=250 # # Inline search on the whole directory # MUMPS_INLINE_LIST += -finline-directory=$(STRIP_TOPDIR)/src #Begin Optimization options OPTF += -O2 -fpp -fopenmp -Wobsolescent -Wextension -Wall -Woverflow $(MUMPS_INLINE_LIST) # -DGEMMT_AVAILABLE OPTL = -O2 -fopenmp OPTC = -O2 -fopenmp -Wall #End Optimization options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.8.1/Make.inc/Makefile.G95.SEQ0000664000175000017500000000716415042446416016533 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ################################################################################ PLAT = LIBEXT = .a LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ OUTC = -o OUTF = -o RM = /bin/rm -f CC = gcc FC = g95 FL = g95 AR = ar vr RANLIB = echo LAPACK =/usr/local/ATLAS/lib/Linux_P4SSE2/liblapack.a INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) #LIBBLAS = /usr/local/lib/libgoto_coppermine32p-r1.00.so LIBBLAS =/usr/local/ATLAS/lib/Linux_P4SSE2/libf77blas.a /usr/local/ATLAS/lib/Linux_P4SSE2/libatlas.a -lg2c LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd__ #Begin Optimization options OPTF = -O -i4 OPTL = -O OPTC = -O #End Optimization options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.8.1/Make.inc/Makefile.inc.generic.SEQ0000664000175000017500000001271615042446416020352 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # ################################################################################ # # Makefile.inc.generic.SEQ # # Generic Makefile.inc for sequential (MPI free, Scalapack free) version # # # This defines some parameters dependent on your platform; you should # look for the approriate file in the directory ./Make.inc/ and copy it # into a file called Makefile.inc. For example, from the MUMPS root # directory, use # "cp Make.inc/Makefile.inc.generic.SEQ ./Makefile.inc" # (see the main README file for details) # # If you do not find any suitable Makefile in Makefile.inc, use this file: # "cp Make.inc/Makefile.inc.generic ./Makefile.inc" and modify it according # to the comments given below. If you manage to build MUMPS on a new platform, # and think that this could be useful to others, you may want to send us # the corresponding Makefile.inc file. # ################################################################################ ######################################################################## #Begin orderings # # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## # DEFINE HERE SOME COMMON COMMANDS, THE COMPILER NAMES, ETC... # PLAT : use it to add a default suffix to the generated libraries PLAT = # Suffix for libraries, -soname and -fPIC options, C and Fortran "-o" option # may be adapted LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ LIBEXT = .a OUTC = -o OUTF = -o # RM : remove files RM = /bin/rm -f # CC : C compiler CC = cc # FC : Fortran 90 compiler FC = f90 # FL : Fortran linker FL = f90 # AR : Archive object in a library # keep a space at the end if options have to be separated from lib name AR = ar vr # RANLIB : generate index of an archive file # (optionnal use "RANLIB = echo" in case of problem) RANLIB = ranlib #RANLIB = echo # DEFINE HERE YOUR LAPACK LIBRARY LAPACK = -llapack # The next two lines should not be modified. They concern # the sequential library provided by MUMPS, to use instead # of ScaLAPACK and MPI. INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) # DEFINE HERE YOUR BLAS LIBRARY LIBBLAS = -lblas # DEFINE HERE YOUR PTHREAD LIBRARY LIBOTHERS = -lpthread # FORTRAN/C COMPATIBILITY: # Use: # -DAdd_ if your Fortran compiler adds an underscore at the end # of symbols, # -DAdd__ if your Fortran compiler adds 2 underscores, # # -DUPPER if your Fortran compiler uses uppercase symbols # # leave empty if your Fortran compiler does not change the symbols. # CDEFS = -DAdd_ #COMPILER OPTIONS OPTF = -O OPTC = -O -I. OPTL = -O #Sequential: INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.8.1/Make.inc/Makefile.inc.generic0000664000175000017500000001342615042446416017722 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # ################################################################################ # # Makefile.inc.generic # # This defines some parameters dependent on your platform; you should # look for the approriate file in the directory ./Make.inc/ and copy it # into a file called Makefile.inc. For example, from the MUMPS root # directory, use # "cp Make.inc/Makefile.inc.generic ./Makefile.inc" # (see the main README file for details) # # If you do not find any suitable Makefile in Makefile.inc, use this file: # "cp Make.inc/Makefile.inc.generic ./Makefile.inc" and modify it according # to the comments given below. If you manage to build MUMPS on a new platform, # and think that this could be useful to others, you may want to send us # the corresponding Makefile.inc file. # ################################################################################ ######################################################################## #Begin orderings # # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## # DEFINE HERE SOME COMMON COMMANDS, THE COMPILER NAMES, ETC... # PLAT : use it to add a default suffix to the generated libraries PLAT = # Suffix for libraries, -soname and -fPIC options, C and Fortran "-o" option # may be adapted LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ LIBEXT = .a OUTC = -o OUTF = -o # RM : remove files RM = /bin/rm -f # CC : C compiler CC = cc # FC : Fortran 90 compiler FC = f90 # FL : Fortran linker FL = f90 # AR : Archive object in a library # keep a space at the end if options have to be separated from lib name AR = ar vr # RANLIB : generate index of an archive file # (optionnal use "RANLIB = echo" in case of problem) RANLIB = ranlib #RANLIB = echo # DEFINE HERE YOUR LAPACK LIBRARY LAPACK = -llapack # SCALAP should define the SCALAPACK and BLACS libraries. SCALAP = -lscalapack -lblacs # INCLUDE DIRECTORY FOR MPI INCPAR = -I/usr/include # LIBRARIES USED BY THE PARALLEL VERSION OF MUMPS: $(SCALAP) and MPI LIBPAR = $(SCALAP) $(LAPACK) -L/usr/lib -lmpi # The parallel version is not concerned by the next two lines. # They are related to the sequential library provided by MUMPS, # to use instead of ScaLAPACK and MPI. INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) # DEFINE HERE YOUR BLAS LIBRARY LIBBLAS = -lblas # DEFINE HERE YOUR PTHREAD LIBRARY LIBOTHERS = -lpthread # FORTRAN/C COMPATIBILITY: # Use: # -DAdd_ if your Fortran compiler adds an underscore at the end # of symbols, # -DAdd__ if your Fortran compiler adds 2 underscores, # # -DUPPER if your Fortran compiler uses uppercase symbols # # leave empty if your Fortran compiler does not change the symbols. # CDEFS = -DAdd_ #COMPILER OPTIONS OPTF = -O OPTC = -O -I. OPTL = -O # CHOOSE BETWEEN USING THE SEQUENTIAL OR THE PARALLEL VERSION. #Sequential: #INCS = $(INCSEQ) #LIBS = $(LIBSEQ) #LIBSEQNEEDED = libseqneeded #Parallel: INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.8.1/Make.inc/Makefile.SGI.PAR0000664000175000017500000000730515042446416016600 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## PLAT = LIBEXT = .a LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ OUTC = -o OUTF = -o RM = /bin/rm -f CC = cc FC = f90 FL = f90 AR = ar vr RANLIB = echo LAPACK = /usr/lib64/libcomplib.sgimath.so SCALAP = -L/usr/lib64 -lscalapack64 -lmpiblacs64 INCPAR = -I/usr/include/ LIBPAR = $(SCALAP) $(LAPACK) -L/usr/lib64/ -lmpi INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) LIBBLAS = -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimization options OPTF = -Dsgi -O -OPT:Olimit=0 -mips4 -64 -align64 OPTL = -O -OPT:Olimit=0 -mips4 -64 -align64 OPTC = -O -OPT:Olimit=0 -mips4 -64 -align64 NOOPT = -Dsgi -mips4 -64 -align64 #End Optimization options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.8.1/Make.inc/Makefile.FREEBSD10.PAR0000664000175000017500000000735315042446416017374 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ################################################################################ PLAT = LIBEXT = .a LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ OUTC = -o "" OUTF = -o "" RM = /bin/rm -f CC = cc FC = gfortran48 FL = gfortran48 # keep a space at the end if options have to be separated from lib name AR = ar -vr "" RANLIB = ranlib LAPACK = -llapack SCALAP = -lscalapack -lblacs INCPAR = -I/usr/local/include LIBPAR = $(SCALAP) $(LAPACK) -L/usr/local/lib -lmpi INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) LIBBLAS = -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options # uncomment -fopenmp in lines below to benefit from OpenMP OPTF = -O #-fopenmp OPTL = -O #-fopenmp OPTC = -O -I. #-fopenmp #End Optimized options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.8.1/Make.inc/Makefile.WIN.MS-G95.SEQ0000664000175000017500000000740715042446416017504 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # # We are grateful to Evgenii Rudnyi for his help and suggestions # regarding Windows installation. #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS, PATHMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #PATHSCOTCH = -LIBPATH:$(SCOTCHDIR)/lib #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = libscotch.lib libscotcherr.lib libesmumps.lib #LSCOTCH = libptscotch.lib libptscotcherr.lib libptesmumps.lib libscotch.lib LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ PATHPORD = -LIBPATH:$(LPORDDIR) LPORD = libpord$(PLAT).lib #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #PATHMETIS = -LIBPATH:$(LMETISDIR) #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = libmetis.lib #LMETIS = libparmetis.lib libmetis.lib # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) PATHORDERINGS = $(PATHMETIS) $(PATHPORD) $(PATHSCOTCH) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) # For Windows #End orderings ######################################################################## ######################################################################## ################################################################################ PLAT = LIBEXT = .lib LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared #FPIC_OPT = -fPIC #RPATH_OPT OUTC = -Fo OUTF = -o RM = /bin/rm -f CC = cl FC = g95 FL = cl AR = lib -out: RANLIB = echo INCSEQ = -I$(topdir)/libseq LIBSEQ = $(topdir)/libseq/libmpiseq$(PLAT).lib LIBBLAS = mkl_intel_c.lib mkl_intel_thread.lib mkl_core.lib libiomp5md.lib LIBOTHERS = libf95.lib libgcc.lib -link $(PATHORDERINGS) #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd__ #Begin Optimization options OPTF = -O -i4 -fno-underscoring -fcase-upper OPTL = OPTC = -O2 -MD #End Optimization options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.8.1/Make.inc/Makefile.WIN.MS-Intel.SEQ0000664000175000017500000000754115042446416020212 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # # We are grateful to Evgenii Rudnyi for his help and suggestions # regarding Windows installation. #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS, PATHMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #PATHSCOTCH = -LIBPATH:$(SCOTCHDIR)/lib #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = libscotch.lib libscotcherr.lib libesmumps.lib #LSCOTCH = libptscotch.lib libptscotcherr.lib libptesmumps.lib libscotch.lib LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ PATHPORD = -LIBPATH:$(LPORDDIR) LPORD = libpord$(PLAT).lib #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #PATHMETIS = -LIBPATH:$(LMETISDIR) #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = libmetis.lib #LMETIS = libparmetis.lib libmetis.lib # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) PATHORDERINGS = $(PATHMETIS) $(PATHPORD) $(PATHSCOTCH) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) # For Windows #End orderings ######################################################################## ######################################################################## ################################################################################ PLAT = LIBEXT = .lib LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared #FPIC_OPT = -fPIC #RPATH_OPT 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$(PLAT).lib #LIBBLAS = -L/usr/lib/xmm/ -lf77blas -latlas #LIBBLAS = -L/local/BLAS -lblas LIBBLAS = mkl_intel_c.lib mkl_intel_thread.lib mkl_core.lib libiomp5md.lib #LIBOTHERS = -lpthread LIBOTHERS = -link $(PATHORDERINGS) #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -MD -Dintel_ -DGEMMT_AVAILABLE -fpp OPTL = OPTC = -O2 -MD #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.8.1/Make.inc/Makefile.NEC.SEQ0000664000175000017500000001050215042446416016562 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) # # The following section deals with Vector Host offloading of scalar code # like METIS or symbolic factorization. By default it is activated. If you # prefer run all code on the VE (not recommended), set WITH_VHOFFLOAD to no. # Activation is recommended for optimal performance. # # In case WITH_VHOFFLOAD is set to yes, Make.inc/Makefile.NEC.VH should # be edited (e.g. to provide the path to METIS library on the Vector Host) WITH_VHOFFLOAD := yes ifeq ($(WITH_VHOFFLOAD),yes) include $(topdir)/Make.inc/Makefile.NEC.VH else #LMETISDIR = -L/opt/metis-5.1.0/build/ve/libmetis #IMETIS = -I/opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis endif # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF += -Dpord ORDERINGSC += $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ################################################################################ PLAT = LIBEXT = .a LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ OUTC = -o OUTF = -o RM = rm -f CC = ncc FC = nfort FL = nfort AR = nar vr RANLIB = echo LAPACK = -llapack INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) LIBBLAS = -lblas_openmp LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ # # Inline basics # STRIP_TOPDIR = $(strip $(topdir)) MUMPS_INLINE_LIST = -finline-functions -finline-max-depth=5 -finline-max-function-size=250 # # Inline search on the whole directory # MUMPS_INLINE_LIST += -finline-directory=$(STRIP_TOPDIR)/src:$(STRIP_TOPDIR)/libseq #Begin Optimization options OPTF += -O2 -fpp -fopenmp -Wobsolescent -Wextension -Wall -Woverflow $(MUMPS_INLINE_LIST) # -DGEMMT_AVAILABLE OPTL = -O2 -fopenmp OPTC = -O2 -fopenmp -Wall #End Optimization options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.8.1/Make.inc/Makefile.SUN.PAR0000664000175000017500000000713515042446416016624 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord$(PLAT) #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## PLAT = LIBEXT = .a LIBEXT_SHARED = .so SONAME = -soname SHARED_OPT = -shared FPIC_OPT = -fPIC # Adapt/uncomment RPATH_OPT to avoid modifying # LD_LIBRARY_PATH in case of shared libraries # RPATH_OPT = -Wl,-rpath,/path/to/MUMPS_x.y.z/lib/ OUTC = -o OUTF = -o CPP = /lib/cpp -P -C RM = /bin/rm -f CC = cc FC = f90 FL = f90 AR = ar vr RANLIB = echo LAPACK = #included in SunPerf SCALAP = -ls3l -lhpcshm INCPAR = -I/opt/SUNWhpc/include LIBPAR = -L/opt/SUNWhpc/lib -R/opt/SUNWhpc/lib $(SCALAP) $(LAPACK) -lmpi INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq$(PLAT) LIBBLAS = -lsunperf -lf77compat LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -DSUN_ OPTL = -O OPTC = -O #End Optimized options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.8.1/LICENSE0000664000175000017500000000502315042446416013451 0ustar amestoyamestoy Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, Mumps Technologies, University of Bordeaux. This version of MUMPS is provided to you free of charge. It is released under the CeCILL-C license (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and https://cecill.info/licences/Licence_CeCILL-C_V1-en.html), except for variants of AMD ordering and [sdcz]MUMPS_TRUNCATED_RRQR derived from the LAPACK package distributed under BSD 3-clause license (see headers of ana_orderings.F and [sdcz]lr_core.F), and except for the external and optional ordering PORD provided in a separate directory PORD (see PORD/README for License information). You can acknowledge (using references [1] and [2]) the contribution of this package in any scientific publication dependent upon the use of the package. Please use reasonable endeavours to notify the authors of the package of this publication. [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, A fully asynchronous multifrontal solver using distributed dynamic scheduling, SIAM Journal on Matrix Analysis and Applications, Vol 23, No 1, pp 15-41 (2001). [2] P. R. Amestoy, A. Buttari, J.-Y. L'Excellent and T. Mary, Performance and scalability of the block low-rank multifrontal factorization on multicore architectures, ACM Transactions on Mathematical Software, Vol 45, Issue 1, pp 2:1-2:26 (2019) As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the software's author, the holder of the economic rights, and the successive licensors have only limited liability. In this respect, the user's attention is drawn to the risks associated with loading, using, modifying and/or developing or reproducing the software by the user in light of its specific status of free software, that may mean that it is complicated to manipulate, and that also therefore means that it is reserved for developers and experienced professionals having in-depth computer knowledge. Users are therefore encouraged to load and test the software's suitability as regards their requirements in conditions enabling the security of their systems and/or data to be ensured and, more generally, to use and operate it in the same conditions as regards security. The fact that you are presently reading this means that you have had knowledge of the CeCILL-C license and that you accept its terms. MUMPS_5.8.1/include/0000775000175000017500000000000015042446436014071 5ustar amestoyamestoyMUMPS_5.8.1/include/cmumps_c.h0000664000175000017500000001004515042446422016043 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Mostly written in march 2002 (JYL) */ #ifndef CMUMPS_C_H #define CMUMPS_C_H #ifdef __cplusplus extern "C" { #endif #include "mumps_compat.h" /* Next line defines MUMPS_INT, CMUMPS_COMPLEX and CMUMPS_REAL */ #include "mumps_c_types.h" #ifndef MUMPS_VERSION /* Protected in case headers of other arithmetics are included */ #define MUMPS_VERSION "5.8.1" #endif #ifndef MUMPS_VERSION_MAX_LEN #define MUMPS_VERSION_MAX_LEN 30 #endif /* * Definition of the (simplified) MUMPS C structure. * NB: CMUMPS_COMPLEX are REAL types in s and d arithmetics. */ typedef struct { MUMPS_INT sym, par, job; MUMPS_INT comm_fortran; /* Fortran communicator */ MUMPS_INT icntl[60]; MUMPS_INT keep[500]; CMUMPS_REAL cntl[15]; CMUMPS_REAL dkeep[230]; MUMPS_INT8 keep8[150]; MUMPS_INT n; MUMPS_INT nblk; MUMPS_INT nz_alloc; /* used in matlab interface to decide if we free + malloc when we have large variation */ /* Assembled entry */ MUMPS_INT nz; MUMPS_INT8 nnz; MUMPS_INT *irn; MUMPS_INT *jcn; CMUMPS_COMPLEX *a; /* Distributed entry */ MUMPS_INT nz_loc; MUMPS_INT8 nnz_loc; MUMPS_INT *irn_loc; MUMPS_INT *jcn_loc; CMUMPS_COMPLEX *a_loc; /* Element entry */ MUMPS_INT nelt; MUMPS_INT *eltptr; MUMPS_INT *eltvar; CMUMPS_COMPLEX *a_elt; /* Matrix by blocks */ MUMPS_INT *blkptr; MUMPS_INT *blkvar; /* Ordering, if given by user */ MUMPS_INT *perm_in; /* Orderings returned to user */ MUMPS_INT *sym_perm; /* symmetric permutation */ MUMPS_INT *uns_perm; /* column permutation */ /* Scaling (inout but complicated) */ CMUMPS_REAL *colsca; CMUMPS_REAL *rowsca; MUMPS_INT colsca_from_mumps; MUMPS_INT rowsca_from_mumps; /* Distributed scaling(out) */ CMUMPS_REAL *colsca_loc; CMUMPS_REAL *rowsca_loc; /* Info after facto */ MUMPS_INT *rowind; MUMPS_INT *colind; CMUMPS_COMPLEX *pivots; /* RHS, solution, ouptput data and statistics */ CMUMPS_COMPLEX *rhs, *redrhs, *rhs_sparse, *sol_loc, *rhs_loc, *rhsintr; MUMPS_INT *irhs_sparse, *irhs_ptr, *isol_loc, *irhs_loc, *glob2loc_rhs, *glob2loc_sol; MUMPS_INT nrhs, lrhs, lredrhs, nz_rhs, lsol_loc, nloc_rhs, lrhs_loc, nsol_loc; MUMPS_INT schur_mloc, schur_nloc, schur_lld; MUMPS_INT mblock, nblock, nprow, npcol; MUMPS_INT ld_rhsintr; MUMPS_INT info[80],infog[80]; CMUMPS_REAL rinfo[40], rinfog[40]; /* Null space */ MUMPS_INT deficiency; MUMPS_INT *pivnul_list; MUMPS_INT *mapping; CMUMPS_REAL *singular_values; /* Schur */ MUMPS_INT size_schur; MUMPS_INT *listvar_schur; CMUMPS_COMPLEX *schur; /* user workspace */ CMUMPS_COMPLEX *wk_user; /* Version number: length=30 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[1024]; char ooc_prefix[256]; /* To save the matrix in matrix market format */ char write_problem[1024]; MUMPS_INT lwk_user; /* For save/restore feature */ char save_dir[1024]; char save_prefix[256]; /* Metis options */ MUMPS_INT metis_options[40]; /* Internal parameters */ MUMPS_INT instance_number; } CMUMPS_STRUC_C; void MUMPS_CALL cmumps_c( CMUMPS_STRUC_C * cmumps_par ); #ifdef __cplusplus } #endif #endif /* CMUMPS_C_H */ MUMPS_5.8.1/include/zmumps_c.h0000664000175000017500000001004515042446422016072 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Mostly written in march 2002 (JYL) */ #ifndef ZMUMPS_C_H #define ZMUMPS_C_H #ifdef __cplusplus extern "C" { #endif #include "mumps_compat.h" /* Next line defines MUMPS_INT, ZMUMPS_COMPLEX and ZMUMPS_REAL */ #include "mumps_c_types.h" #ifndef MUMPS_VERSION /* Protected in case headers of other arithmetics are included */ #define MUMPS_VERSION "5.8.1" #endif #ifndef MUMPS_VERSION_MAX_LEN #define MUMPS_VERSION_MAX_LEN 30 #endif /* * Definition of the (simplified) MUMPS C structure. * NB: ZMUMPS_COMPLEX are REAL types in s and d arithmetics. */ typedef struct { MUMPS_INT sym, par, job; MUMPS_INT comm_fortran; /* Fortran communicator */ MUMPS_INT icntl[60]; MUMPS_INT keep[500]; ZMUMPS_REAL cntl[15]; ZMUMPS_REAL dkeep[230]; MUMPS_INT8 keep8[150]; MUMPS_INT n; MUMPS_INT nblk; MUMPS_INT nz_alloc; /* used in matlab interface to decide if we free + malloc when we have large variation */ /* Assembled entry */ MUMPS_INT nz; MUMPS_INT8 nnz; MUMPS_INT *irn; MUMPS_INT *jcn; ZMUMPS_COMPLEX *a; /* Distributed entry */ MUMPS_INT nz_loc; MUMPS_INT8 nnz_loc; MUMPS_INT *irn_loc; MUMPS_INT *jcn_loc; ZMUMPS_COMPLEX *a_loc; /* Element entry */ MUMPS_INT nelt; MUMPS_INT *eltptr; MUMPS_INT *eltvar; ZMUMPS_COMPLEX *a_elt; /* Matrix by blocks */ MUMPS_INT *blkptr; MUMPS_INT *blkvar; /* Ordering, if given by user */ MUMPS_INT *perm_in; /* Orderings returned to user */ MUMPS_INT *sym_perm; /* symmetric permutation */ MUMPS_INT *uns_perm; /* column permutation */ /* Scaling (inout but complicated) */ ZMUMPS_REAL *colsca; ZMUMPS_REAL *rowsca; MUMPS_INT colsca_from_mumps; MUMPS_INT rowsca_from_mumps; /* Distributed scaling(out) */ ZMUMPS_REAL *colsca_loc; ZMUMPS_REAL *rowsca_loc; /* Info after facto */ MUMPS_INT *rowind; MUMPS_INT *colind; ZMUMPS_COMPLEX *pivots; /* RHS, solution, ouptput data and statistics */ ZMUMPS_COMPLEX *rhs, *redrhs, *rhs_sparse, *sol_loc, *rhs_loc, *rhsintr; MUMPS_INT *irhs_sparse, *irhs_ptr, *isol_loc, *irhs_loc, *glob2loc_rhs, *glob2loc_sol; MUMPS_INT nrhs, lrhs, lredrhs, nz_rhs, lsol_loc, nloc_rhs, lrhs_loc, nsol_loc; MUMPS_INT schur_mloc, schur_nloc, schur_lld; MUMPS_INT mblock, nblock, nprow, npcol; MUMPS_INT ld_rhsintr; MUMPS_INT info[80],infog[80]; ZMUMPS_REAL rinfo[40], rinfog[40]; /* Null space */ MUMPS_INT deficiency; MUMPS_INT *pivnul_list; MUMPS_INT *mapping; ZMUMPS_REAL *singular_values; /* Schur */ MUMPS_INT size_schur; MUMPS_INT *listvar_schur; ZMUMPS_COMPLEX *schur; /* user workspace */ ZMUMPS_COMPLEX *wk_user; /* Version number: length=30 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[1024]; char ooc_prefix[256]; /* To save the matrix in matrix market format */ char write_problem[1024]; MUMPS_INT lwk_user; /* For save/restore feature */ char save_dir[1024]; char save_prefix[256]; /* Metis options */ MUMPS_INT metis_options[40]; /* Internal parameters */ MUMPS_INT instance_number; } ZMUMPS_STRUC_C; void MUMPS_CALL zmumps_c( ZMUMPS_STRUC_C * zmumps_par ); #ifdef __cplusplus } #endif #endif /* ZMUMPS_C_H */ MUMPS_5.8.1/include/cmumps_struc.h0000664000175000017500000002731415042446436016775 0ustar amestoyamestoy! ! This file is part of MUMPS 5.8.1, released ! on Wed Jul 30 16:49:18 UTC 2025 ! ! ! Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! Mumps Technologies, University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license ! (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and ! https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) ! TYPE CMUMPS_STRUC SEQUENCE ! ! This structure contains all parameters ! for the interface to the user, plus internal ! information from the solver ! ! ***************** ! INPUT PARAMETERS ! ***************** ! ----------------- ! MPI Communicator ! ----------------- INTEGER :: COMM ! ------------------ ! Problem definition ! ------------------ ! Solver (SYM=0 unsymmetric,SYM=1 symmetric Positive Definite, ! SYM=2 general symmetric) ! Type of parallelism (PAR=1 host working, PAR=0 host not working) INTEGER :: SYM, PAR INTEGER :: JOB ! -------------------- ! Order of Input matrix ! -------------------- INTEGER :: N ! ! ---------------------------------------- ! Assembled input matrix : User interface ! ---------------------------------------- INTEGER :: NZ ! Standard integer input + bwd. compat. INTEGER(8) :: NNZ ! 64-bit integer input COMPLEX, DIMENSION(:), POINTER :: A INTEGER, DIMENSION(:), POINTER :: IRN, JCN ! -------------- ! Scaling arrays ! -------------- REAL, DIMENSION(:), POINTER :: COLSCA, ROWSCA REAL, DIMENSION(:), POINTER :: COLSCA_loc REAL, DIMENSION(:), POINTER :: ROWSCA_loc INTEGER, DIMENSION(:), POINTER :: ROWIND, COLIND COMPLEX, DIMENSION(:), POINTER :: PIVOTS ! ! ------------------------------------ ! Case of distributed assembled matrix ! matrix on entry: ! ------------------------------------ INTEGER :: NZ_loc ! Standard integer input + bwd. compat. INTEGER :: pad1 INTEGER(8) :: NNZ_loc ! 64-bit integer input INTEGER, DIMENSION(:), POINTER :: IRN_loc, JCN_loc COMPLEX, DIMENSION(:), POINTER :: A_loc, pad2 ! ! ---------------------------------------- ! Unassembled input matrix: User interface ! ---------------------------------------- INTEGER :: NELT, pad3 INTEGER, DIMENSION(:), POINTER :: ELTPTR INTEGER, DIMENSION(:), POINTER :: ELTVAR COMPLEX, DIMENSION(:), POINTER :: A_ELT, pad4 ! ! --------------------------------------------- ! Symmetric permutation : ! PERM_IN if given by user (optional) ! --------------------------------------------- INTEGER, DIMENSION(:), POINTER :: PERM_IN ! ! ---------------- ! Format by blocks ! ---------------- INTEGER :: NBLK, pad5 INTEGER, DIMENSION(:), POINTER :: BLKPTR INTEGER, DIMENSION(:), POINTER :: BLKVAR ! ! ****************** ! INPUT/OUTPUT data ! ****************** ! -------------------------------------------------------- ! RHS / SOL_loc ! ------------- ! right-hand side and solution ! ------------------------------------------------------- COMPLEX, DIMENSION(:), POINTER :: RHS, REDRHS COMPLEX, DIMENSION(:), POINTER :: RHS_SPARSE COMPLEX, DIMENSION(:), POINTER :: SOL_loc COMPLEX, DIMENSION(:), POINTER :: RHS_loc INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE INTEGER, DIMENSION(:), POINTER :: IRHS_PTR INTEGER, DIMENSION(:), POINTER :: ISOL_loc INTEGER, DIMENSION(:), POINTER :: IRHS_loc INTEGER :: LRHS, NRHS, NZ_RHS, Nloc_RHS, LRHS_loc, LREDRHS INTEGER :: LSOL_loc, NSOL_loc INTEGER :: LD_RHSINTR, pad6 ! ---------------------------- ! Control parameters, ! statistics and output data ! --------------------------- INTEGER :: ICNTL(60) INTEGER :: INFO(80) INTEGER :: INFOG(80) REAL :: COST_SUBTREES REAL :: CNTL(15) REAL :: RINFO(40) REAL :: RINFOG(40) ! The options array for metis/parmetis INTEGER :: METIS_OPTIONS(40) ! --------------------------------------------------------- ! Permutations computed during analysis: ! SYM_PERM: Symmetric permutation ! UNS_PERM: Column permutation (optional) ! --------------------------------------------------------- INTEGER, DIMENSION(:), POINTER :: SYM_PERM, UNS_PERM ! ! ----- ! Schur ! ----- INTEGER :: NPROW, NPCOL, MBLOCK, NBLOCK INTEGER :: SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER :: SIZE_SCHUR COMPLEX, DIMENSION(:), POINTER :: SCHUR COMPLEX, DIMENSION(:), POINTER :: SCHUR_CINTERFACE INTEGER, DIMENSION(:), POINTER :: LISTVAR_SCHUR ! ------------------------------------- ! Case of distributed matrix on entry: ! CMUMPS potentially provides mapping ! ------------------------------------- INTEGER, DIMENSION(:), POINTER :: MAPPING ! -------------- ! Version number ! -------------- CHARACTER(LEN=30) :: VERSION_NUMBER ! ----------- ! Out-of-core ! ----------- CHARACTER(LEN=1023) :: OOC_TMPDIR CHARACTER(LEN=255) :: OOC_PREFIX ! ------------------------------------------ ! Name of file to dump a matrix/rhs to disk ! ------------------------------------------ CHARACTER(LEN=1023) :: WRITE_PROBLEM ! ----------- ! Save/Restore ! ----------- CHARACTER(LEN=1023) :: SAVE_DIR CHARACTER(LEN=255) :: SAVE_PREFIX CHARACTER(LEN=7) :: pad7 ! ! ! ********************** ! INTERNAL Working data ! ********************* INTEGER(8) :: KEEP8(150), MAX_SURF_MASTER INTEGER :: INST_Number ! For MPI INTEGER :: COMM_NODES, MYID_NODES, COMM_LOAD INTEGER :: MYID, NPROCS, NSLAVES INTEGER :: ASS_IRECV ! IS is used for the factors + workspace for contrib. blocks INTEGER, DIMENSION(:), POINTER :: IS INTEGER :: KEEP(500) ! The following data/arrays are computed during the analysis ! phase and used during the factorization and solve phases. INTEGER :: LNA INTEGER :: NBSA INTEGER,POINTER,DIMENSION(:) :: STEP, NE_STEPS, ND_STEPS INTEGER,POINTER,DIMENSION(:) :: FRERE_STEPS, DAD_STEPS INTEGER,POINTER,DIMENSION(:) :: FILS, FRTPTR, FRTELT INTEGER(8),POINTER,DIMENSION(:) :: PTRAR, PTR8ARR INTEGER,POINTER,DIMENSION(:) :: NINCOLARR,NINROWARR,PTRDEBARR INTEGER,POINTER,DIMENSION(:) :: NA, PROCNODE_STEPS ! Info for pruning tree INTEGER,POINTER,DIMENSION(:) :: Step2node ! PTLUST_S and PTRFAC are two pointer arrays computed during ! factorization and used by the solve INTEGER, DIMENSION(:), POINTER :: PTLUST_S INTEGER(8), DIMENSION(:), POINTER :: PTRFAC ! main real working arrays for factorization/solve phases COMPLEX, DIMENSION(:), POINTER :: S COMPLEX(kind=4), DIMENSION(:), POINTER :: LPS ! Information on mapping INTEGER, DIMENSION(:), POINTER :: PROCNODE ! Input matrix ready for numerical assembly ! -arrowhead format in case of assembled matrix ! -element format otherwise ! Element entry: internal data INTEGER :: NELT_loc, LELTVAR INTEGER, DIMENSION(:), POINTER :: ELTPROC ! Candidates and node partitionning INTEGER, DIMENSION(:,:), POINTER :: CANDIDATES INTEGER, DIMENSION(:), POINTER :: ISTEP_TO_INIV2 INTEGER, DIMENSION(:), POINTER :: FUTURE_NIV2 INTEGER, DIMENSION(:,:), POINTER :: TAB_POS_IN_PERE LOGICAL, DIMENSION(:), POINTER :: I_AM_CAND ! For heterogeneous architecture INTEGER, DIMENSION(:), POINTER :: MEM_DIST ! Compressed RHS INTEGER, DIMENSION(:), POINTER :: GLOB2LOC_RHS LOGICAL :: GLOB2LOC_SOL_ALLOC, pad11 INTEGER, DIMENSION(:), POINTER :: GLOB2LOC_SOL COMPLEX, DIMENSION(:), POINTER :: RHSINTR ! Info on the subtrees to be used during factorization DOUBLE PRECISION, DIMENSION(:), POINTER :: MEM_SUBTREE DOUBLE PRECISION, DIMENSION(:), POINTER :: COST_TRAV INTEGER, DIMENSION(:), POINTER :: MY_ROOT_SBTR INTEGER, DIMENSION(:), POINTER :: MY_FIRST_LEAF INTEGER, DIMENSION(:), POINTER :: MY_NB_LEAF INTEGER, DIMENSION(:), POINTER :: DEPTH_FIRST INTEGER, DIMENSION(:), POINTER :: DEPTH_FIRST_SEQ INTEGER, DIMENSION(:), POINTER :: SBTR_ID INTEGER, DIMENSION(:), POINTER :: SCHED_DEP INTEGER, DIMENSION(:), POINTER :: SCHED_GRP INTEGER, DIMENSION(:), POINTER :: SCHED_SBTR INTEGER, DIMENSION(:), POINTER :: CROIX_MANU COMPLEX, DIMENSION(:), POINTER :: WK_USER INTEGER :: NBSA_LOCAL INTEGER :: LWK_USER ! Internal control array REAL :: DKEEP(230) ! For simulating parallel out-of-core stack. DOUBLE PRECISION, DIMENSION(:),POINTER :: CB_SON_SIZE ! Instance number used/managed by the C/F77 interface INTEGER :: INSTANCE_NUMBER ! OOC management data that must persist from factorization to solve. INTEGER :: OOC_MAX_NB_NODES_FOR_ZONE INTEGER, DIMENSION(:,:), POINTER :: OOC_INODE_SEQUENCE INTEGER(8),DIMENSION(:,:), POINTER :: OOC_SIZE_OF_BLOCK INTEGER(8), DIMENSION(:,:), POINTER :: OOC_VADDR INTEGER,DIMENSION(:), POINTER :: OOC_TOTAL_NB_NODES INTEGER,DIMENSION(:), POINTER :: OOC_NB_FILES INTEGER :: OOC_NB_FILE_TYPE,pad12 INTEGER,DIMENSION(:), POINTER :: OOC_FILE_NAME_LENGTH CHARACTER,DIMENSION(:,:), POINTER :: OOC_FILE_NAMES ! Indices of nul pivots INTEGER,DIMENSION(:), POINTER :: PIVNUL_LIST ! Array needed to manage additionnal candidate processor INTEGER, DIMENSION(:,:), POINTER :: SUP_PROC, pad14 ! Lists of nodes where processors work. Built/used in solve phase. INTEGER, DIMENSION(:), POINTER :: IPTR_WORKING, WORKING ! Internal data structures accessor CHARACTER, DIMENSION(:), POINTER :: INTR_ENCODING ! Low-rank INTEGER, POINTER, DIMENSION(:) :: LRGROUPS INTEGER :: NBGRP,pad13 ! Pointer encoding for FDM_F data CHARACTER, DIMENSION(:), POINTER :: FDM_F_ENCODING ! Pointer array encoding BLR factors pointers CHARACTER, DIMENSION(:), POINTER :: BLRARRAY_ENCODING ! Multicore INTEGER :: LPOOL_A_L0_OMP, LPOOL_B_L0_OMP INTEGER :: L_PHYS_L0_OMP INTEGER :: L_VIRT_L0_OMP INTEGER :: LL0_OMP_MAPPING, LL0_OMP_FACTORS INTEGER(8) :: THREAD_LA ! Estimates before L0_OMP INTEGER, DIMENSION(:,:), POINTER :: I4_L0_OMP INTEGER(8), DIMENSION(:,:), POINTER :: I8_L0_OMP ! Pool before L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_B_L0_OMP ! Pool after L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_A_L0_OMP ! Subtrees INTEGER, DIMENSION(:), POINTER :: PHYS_L0_OMP ! Amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP ! Mapping of amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP_MAPPING ! From heaviest to lowest subtree INTEGER, DIMENSION(:), POINTER :: PERM_L0_OMP ! To get leafs in global pool INTEGER, DIMENSION(:), POINTER :: PTR_LEAFS_L0_OMP ! Mapping of the subtree nodes INTEGER, DIMENSION(:), POINTER :: L0_OMP_MAPPING ! Mpi to omp - mumps agile INTEGER, DIMENSION(:), POINTER :: MTKO_PROCS_MAP ! for RR on root REAL, DIMENSION(:), POINTER :: SINGULAR_VALUES INTEGER :: NB_SINGULAR_VALUES INTEGER :: Deficiency, pad16 ! To know if OOC files are associated to a saved and so if they should be removed. LOGICAL :: ASSOCIATED_OOC_FILES END TYPE CMUMPS_STRUC MUMPS_5.8.1/include/dmumps_c.h0000664000175000017500000001004515042446422016044 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Mostly written in march 2002 (JYL) */ #ifndef DMUMPS_C_H #define DMUMPS_C_H #ifdef __cplusplus extern "C" { #endif #include "mumps_compat.h" /* Next line defines MUMPS_INT, DMUMPS_COMPLEX and DMUMPS_REAL */ #include "mumps_c_types.h" #ifndef MUMPS_VERSION /* Protected in case headers of other arithmetics are included */ #define MUMPS_VERSION "5.8.1" #endif #ifndef MUMPS_VERSION_MAX_LEN #define MUMPS_VERSION_MAX_LEN 30 #endif /* * Definition of the (simplified) MUMPS C structure. * NB: DMUMPS_COMPLEX are REAL types in s and d arithmetics. */ typedef struct { MUMPS_INT sym, par, job; MUMPS_INT comm_fortran; /* Fortran communicator */ MUMPS_INT icntl[60]; MUMPS_INT keep[500]; DMUMPS_REAL cntl[15]; DMUMPS_REAL dkeep[230]; MUMPS_INT8 keep8[150]; MUMPS_INT n; MUMPS_INT nblk; MUMPS_INT nz_alloc; /* used in matlab interface to decide if we free + malloc when we have large variation */ /* Assembled entry */ MUMPS_INT nz; MUMPS_INT8 nnz; MUMPS_INT *irn; MUMPS_INT *jcn; DMUMPS_COMPLEX *a; /* Distributed entry */ MUMPS_INT nz_loc; MUMPS_INT8 nnz_loc; MUMPS_INT *irn_loc; MUMPS_INT *jcn_loc; DMUMPS_COMPLEX *a_loc; /* Element entry */ MUMPS_INT nelt; MUMPS_INT *eltptr; MUMPS_INT *eltvar; DMUMPS_COMPLEX *a_elt; /* Matrix by blocks */ MUMPS_INT *blkptr; MUMPS_INT *blkvar; /* Ordering, if given by user */ MUMPS_INT *perm_in; /* Orderings returned to user */ MUMPS_INT *sym_perm; /* symmetric permutation */ MUMPS_INT *uns_perm; /* column permutation */ /* Scaling (inout but complicated) */ DMUMPS_REAL *colsca; DMUMPS_REAL *rowsca; MUMPS_INT colsca_from_mumps; MUMPS_INT rowsca_from_mumps; /* Distributed scaling(out) */ DMUMPS_REAL *colsca_loc; DMUMPS_REAL *rowsca_loc; /* Info after facto */ MUMPS_INT *rowind; MUMPS_INT *colind; DMUMPS_COMPLEX *pivots; /* RHS, solution, ouptput data and statistics */ DMUMPS_COMPLEX *rhs, *redrhs, *rhs_sparse, *sol_loc, *rhs_loc, *rhsintr; MUMPS_INT *irhs_sparse, *irhs_ptr, *isol_loc, *irhs_loc, *glob2loc_rhs, *glob2loc_sol; MUMPS_INT nrhs, lrhs, lredrhs, nz_rhs, lsol_loc, nloc_rhs, lrhs_loc, nsol_loc; MUMPS_INT schur_mloc, schur_nloc, schur_lld; MUMPS_INT mblock, nblock, nprow, npcol; MUMPS_INT ld_rhsintr; MUMPS_INT info[80],infog[80]; DMUMPS_REAL rinfo[40], rinfog[40]; /* Null space */ MUMPS_INT deficiency; MUMPS_INT *pivnul_list; MUMPS_INT *mapping; DMUMPS_REAL *singular_values; /* Schur */ MUMPS_INT size_schur; MUMPS_INT *listvar_schur; DMUMPS_COMPLEX *schur; /* user workspace */ DMUMPS_COMPLEX *wk_user; /* Version number: length=30 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[1024]; char ooc_prefix[256]; /* To save the matrix in matrix market format */ char write_problem[1024]; MUMPS_INT lwk_user; /* For save/restore feature */ char save_dir[1024]; char save_prefix[256]; /* Metis options */ MUMPS_INT metis_options[40]; /* Internal parameters */ MUMPS_INT instance_number; } DMUMPS_STRUC_C; void MUMPS_CALL dmumps_c( DMUMPS_STRUC_C * dmumps_par ); #ifdef __cplusplus } #endif #endif /* DMUMPS_C_H */ MUMPS_5.8.1/include/mumps_compat.h0000664000175000017500000000220115042446422016734 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Compatibility issues between various Windows versions */ #ifndef MUMPS_COMPAT_H #define MUMPS_COMPAT_H #if defined(_WIN32) && ! defined(__MINGW32__) # define MUMPS_WIN32 1 #endif #ifndef MUMPS_CALL # ifdef MUMPS_WIN32 /* Choose between next lines or modify according * to your Windows calling conventions: */ /* #define MUMPS_CALL */ /* #define MUMPS_CALL __stdcall */ /* #define MUMPS_CALL __declspec(dllexport) */ # define MUMPS_CALL # else # define MUMPS_CALL # endif #endif #if defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) # define MUMPS_INLINE static inline #else # define MUMPS_INLINE #endif #endif /* MUMPS_COMPAT_H */ MUMPS_5.8.1/include/zmumps_struc.h0000664000175000017500000002764015042446436017026 0ustar amestoyamestoy! ! This file is part of MUMPS 5.8.1, released ! on Wed Jul 30 16:49:18 UTC 2025 ! ! ! Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! Mumps Technologies, University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license ! (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and ! https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) ! TYPE ZMUMPS_STRUC SEQUENCE ! ! This structure contains all parameters ! for the interface to the user, plus internal ! information from the solver ! ! ***************** ! INPUT PARAMETERS ! ***************** ! ----------------- ! MPI Communicator ! ----------------- INTEGER :: COMM ! ------------------ ! Problem definition ! ------------------ ! Solver (SYM=0 unsymmetric,SYM=1 symmetric Positive Definite, ! SYM=2 general symmetric) ! Type of parallelism (PAR=1 host working, PAR=0 host not working) INTEGER :: SYM, PAR INTEGER :: JOB ! -------------------- ! Order of Input matrix ! -------------------- INTEGER :: N ! ! ---------------------------------------- ! Assembled input matrix : User interface ! ---------------------------------------- INTEGER :: NZ ! Standard integer input + bwd. compat. INTEGER(8) :: NNZ ! 64-bit integer input COMPLEX(kind=8), DIMENSION(:), POINTER :: A INTEGER, DIMENSION(:), POINTER :: IRN, JCN ! -------------- ! Scaling arrays ! -------------- DOUBLE PRECISION, DIMENSION(:), POINTER :: COLSCA, ROWSCA DOUBLE PRECISION, DIMENSION(:), POINTER :: COLSCA_loc DOUBLE PRECISION, DIMENSION(:), POINTER :: ROWSCA_loc INTEGER, DIMENSION(:), POINTER :: ROWIND, COLIND COMPLEX(kind=8), DIMENSION(:), POINTER :: PIVOTS ! ! ------------------------------------ ! Case of distributed assembled matrix ! matrix on entry: ! ------------------------------------ INTEGER :: NZ_loc ! Standard integer input + bwd. compat. INTEGER :: pad1 INTEGER(8) :: NNZ_loc ! 64-bit integer input INTEGER, DIMENSION(:), POINTER :: IRN_loc, JCN_loc COMPLEX(kind=8), DIMENSION(:), POINTER :: A_loc, pad2 ! ! ---------------------------------------- ! Unassembled input matrix: User interface ! ---------------------------------------- INTEGER :: NELT, pad3 INTEGER, DIMENSION(:), POINTER :: ELTPTR INTEGER, DIMENSION(:), POINTER :: ELTVAR COMPLEX(kind=8), DIMENSION(:), POINTER :: A_ELT, pad4 ! ! --------------------------------------------- ! Symmetric permutation : ! PERM_IN if given by user (optional) ! --------------------------------------------- INTEGER, DIMENSION(:), POINTER :: PERM_IN ! ! ---------------- ! Format by blocks ! ---------------- INTEGER :: NBLK, pad5 INTEGER, DIMENSION(:), POINTER :: BLKPTR INTEGER, DIMENSION(:), POINTER :: BLKVAR ! ! ****************** ! INPUT/OUTPUT data ! ****************** ! -------------------------------------------------------- ! RHS / SOL_loc ! ------------- ! right-hand side and solution ! ------------------------------------------------------- COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS, REDRHS COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS_SPARSE COMPLEX(kind=8), DIMENSION(:), POINTER :: SOL_loc COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS_loc INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE INTEGER, DIMENSION(:), POINTER :: IRHS_PTR INTEGER, DIMENSION(:), POINTER :: ISOL_loc INTEGER, DIMENSION(:), POINTER :: IRHS_loc INTEGER :: LRHS, NRHS, NZ_RHS, Nloc_RHS, LRHS_loc, LREDRHS INTEGER :: LSOL_loc, NSOL_loc INTEGER :: LD_RHSINTR, pad6 ! ---------------------------- ! Control parameters, ! statistics and output data ! --------------------------- INTEGER :: ICNTL(60) INTEGER :: INFO(80) INTEGER :: INFOG(80) DOUBLE PRECISION :: COST_SUBTREES DOUBLE PRECISION :: CNTL(15) DOUBLE PRECISION :: RINFO(40) DOUBLE PRECISION :: RINFOG(40) ! The options array for metis/parmetis INTEGER :: METIS_OPTIONS(40) ! --------------------------------------------------------- ! Permutations computed during analysis: ! SYM_PERM: Symmetric permutation ! UNS_PERM: Column permutation (optional) ! --------------------------------------------------------- INTEGER, DIMENSION(:), POINTER :: SYM_PERM, UNS_PERM ! ! ----- ! Schur ! ----- INTEGER :: NPROW, NPCOL, MBLOCK, NBLOCK INTEGER :: SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER :: SIZE_SCHUR COMPLEX(kind=8), DIMENSION(:), POINTER :: SCHUR COMPLEX(kind=8), DIMENSION(:), POINTER :: SCHUR_CINTERFACE INTEGER, DIMENSION(:), POINTER :: LISTVAR_SCHUR ! ------------------------------------- ! Case of distributed matrix on entry: ! ZMUMPS potentially provides mapping ! ------------------------------------- INTEGER, DIMENSION(:), POINTER :: MAPPING ! -------------- ! Version number ! -------------- CHARACTER(LEN=30) :: VERSION_NUMBER ! ----------- ! Out-of-core ! ----------- CHARACTER(LEN=1023) :: OOC_TMPDIR CHARACTER(LEN=255) :: OOC_PREFIX ! ------------------------------------------ ! Name of file to dump a matrix/rhs to disk ! ------------------------------------------ CHARACTER(LEN=1023) :: WRITE_PROBLEM ! ----------- ! Save/Restore ! ----------- CHARACTER(LEN=1023) :: SAVE_DIR CHARACTER(LEN=255) :: SAVE_PREFIX CHARACTER(LEN=7) :: pad7 ! ! ! ********************** ! INTERNAL Working data ! ********************* INTEGER(8) :: KEEP8(150), MAX_SURF_MASTER INTEGER :: INST_Number ! For MPI INTEGER :: COMM_NODES, MYID_NODES, COMM_LOAD INTEGER :: MYID, NPROCS, NSLAVES INTEGER :: ASS_IRECV ! IS is used for the factors + workspace for contrib. blocks INTEGER, DIMENSION(:), POINTER :: IS INTEGER :: KEEP(500) ! The following data/arrays are computed during the analysis ! phase and used during the factorization and solve phases. INTEGER :: LNA INTEGER :: NBSA INTEGER,POINTER,DIMENSION(:) :: STEP, NE_STEPS, ND_STEPS INTEGER,POINTER,DIMENSION(:) :: FRERE_STEPS, DAD_STEPS INTEGER,POINTER,DIMENSION(:) :: FILS, FRTPTR, FRTELT INTEGER(8),POINTER,DIMENSION(:) :: PTRAR, PTR8ARR INTEGER,POINTER,DIMENSION(:) :: NINCOLARR,NINROWARR,PTRDEBARR INTEGER,POINTER,DIMENSION(:) :: NA, PROCNODE_STEPS ! Info for pruning tree INTEGER,POINTER,DIMENSION(:) :: Step2node ! PTLUST_S and PTRFAC are two pointer arrays computed during ! factorization and used by the solve INTEGER, DIMENSION(:), POINTER :: PTLUST_S INTEGER(8), DIMENSION(:), POINTER :: PTRFAC ! main real working arrays for factorization/solve phases COMPLEX(kind=8), DIMENSION(:), POINTER :: S COMPLEX(kind=4), DIMENSION(:), POINTER :: LPS ! Information on mapping INTEGER, DIMENSION(:), POINTER :: PROCNODE ! Input matrix ready for numerical assembly ! -arrowhead format in case of assembled matrix ! -element format otherwise ! Element entry: internal data INTEGER :: NELT_loc, LELTVAR INTEGER, DIMENSION(:), POINTER :: ELTPROC ! Candidates and node partitionning INTEGER, DIMENSION(:,:), POINTER :: CANDIDATES INTEGER, DIMENSION(:), POINTER :: ISTEP_TO_INIV2 INTEGER, DIMENSION(:), POINTER :: FUTURE_NIV2 INTEGER, DIMENSION(:,:), POINTER :: TAB_POS_IN_PERE LOGICAL, DIMENSION(:), POINTER :: I_AM_CAND ! For heterogeneous architecture INTEGER, DIMENSION(:), POINTER :: MEM_DIST ! Compressed RHS INTEGER, DIMENSION(:), POINTER :: GLOB2LOC_RHS LOGICAL :: GLOB2LOC_SOL_ALLOC, pad11 INTEGER, DIMENSION(:), POINTER :: GLOB2LOC_SOL COMPLEX(kind=8), DIMENSION(:), POINTER :: RHSINTR ! Info on the subtrees to be used during factorization DOUBLE PRECISION, DIMENSION(:), POINTER :: MEM_SUBTREE DOUBLE PRECISION, DIMENSION(:), POINTER :: COST_TRAV INTEGER, DIMENSION(:), POINTER :: MY_ROOT_SBTR INTEGER, DIMENSION(:), POINTER :: MY_FIRST_LEAF INTEGER, DIMENSION(:), POINTER :: MY_NB_LEAF INTEGER, DIMENSION(:), POINTER :: DEPTH_FIRST INTEGER, DIMENSION(:), POINTER :: DEPTH_FIRST_SEQ INTEGER, DIMENSION(:), POINTER :: SBTR_ID INTEGER, DIMENSION(:), POINTER :: SCHED_DEP INTEGER, DIMENSION(:), POINTER :: SCHED_GRP INTEGER, DIMENSION(:), POINTER :: SCHED_SBTR INTEGER, DIMENSION(:), POINTER :: CROIX_MANU COMPLEX(kind=8), DIMENSION(:), POINTER :: WK_USER INTEGER :: NBSA_LOCAL INTEGER :: LWK_USER ! Internal control array DOUBLE PRECISION :: DKEEP(230) ! For simulating parallel out-of-core stack. DOUBLE PRECISION, DIMENSION(:),POINTER :: CB_SON_SIZE ! Instance number used/managed by the C/F77 interface INTEGER :: INSTANCE_NUMBER ! OOC management data that must persist from factorization to solve. INTEGER :: OOC_MAX_NB_NODES_FOR_ZONE INTEGER, DIMENSION(:,:), POINTER :: OOC_INODE_SEQUENCE INTEGER(8),DIMENSION(:,:), POINTER :: OOC_SIZE_OF_BLOCK INTEGER(8), DIMENSION(:,:), POINTER :: OOC_VADDR INTEGER,DIMENSION(:), POINTER :: OOC_TOTAL_NB_NODES INTEGER,DIMENSION(:), POINTER :: OOC_NB_FILES INTEGER :: OOC_NB_FILE_TYPE,pad12 INTEGER,DIMENSION(:), POINTER :: OOC_FILE_NAME_LENGTH CHARACTER,DIMENSION(:,:), POINTER :: OOC_FILE_NAMES ! Indices of nul pivots INTEGER,DIMENSION(:), POINTER :: PIVNUL_LIST ! Array needed to manage additionnal candidate processor INTEGER, DIMENSION(:,:), POINTER :: SUP_PROC, pad14 ! Lists of nodes where processors work. Built/used in solve phase. INTEGER, DIMENSION(:), POINTER :: IPTR_WORKING, WORKING ! Internal data structures accessor CHARACTER, DIMENSION(:), POINTER :: INTR_ENCODING ! Low-rank INTEGER, POINTER, DIMENSION(:) :: LRGROUPS INTEGER :: NBGRP,pad13 ! Pointer encoding for FDM_F data CHARACTER, DIMENSION(:), POINTER :: FDM_F_ENCODING ! Pointer array encoding BLR factors pointers CHARACTER, DIMENSION(:), POINTER :: BLRARRAY_ENCODING ! Multicore INTEGER :: LPOOL_A_L0_OMP, LPOOL_B_L0_OMP INTEGER :: L_PHYS_L0_OMP INTEGER :: L_VIRT_L0_OMP INTEGER :: LL0_OMP_MAPPING, LL0_OMP_FACTORS INTEGER(8) :: THREAD_LA ! Estimates before L0_OMP INTEGER, DIMENSION(:,:), POINTER :: I4_L0_OMP INTEGER(8), DIMENSION(:,:), POINTER :: I8_L0_OMP ! Pool before L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_B_L0_OMP ! Pool after L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_A_L0_OMP ! Subtrees INTEGER, DIMENSION(:), POINTER :: PHYS_L0_OMP ! Amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP ! Mapping of amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP_MAPPING ! From heaviest to lowest subtree INTEGER, DIMENSION(:), POINTER :: PERM_L0_OMP ! To get leafs in global pool INTEGER, DIMENSION(:), POINTER :: PTR_LEAFS_L0_OMP ! Mapping of the subtree nodes INTEGER, DIMENSION(:), POINTER :: L0_OMP_MAPPING ! Mpi to omp - mumps agile INTEGER, DIMENSION(:), POINTER :: MTKO_PROCS_MAP ! for RR on root DOUBLE PRECISION, DIMENSION(:), POINTER :: SINGULAR_VALUES INTEGER :: NB_SINGULAR_VALUES INTEGER :: Deficiency, pad16 ! To know if OOC files are associated to a saved and so if they should be removed. LOGICAL :: ASSOCIATED_OOC_FILES END TYPE ZMUMPS_STRUC MUMPS_5.8.1/include/smumps_struc.h0000664000175000017500000002724615042446436017021 0ustar amestoyamestoy! ! This file is part of MUMPS 5.8.1, released ! on Wed Jul 30 16:49:18 UTC 2025 ! ! ! Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! Mumps Technologies, University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license ! (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and ! https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) ! TYPE SMUMPS_STRUC SEQUENCE ! ! This structure contains all parameters ! for the interface to the user, plus internal ! information from the solver ! ! ***************** ! INPUT PARAMETERS ! ***************** ! ----------------- ! MPI Communicator ! ----------------- INTEGER :: COMM ! ------------------ ! Problem definition ! ------------------ ! Solver (SYM=0 unsymmetric,SYM=1 symmetric Positive Definite, ! SYM=2 general symmetric) ! Type of parallelism (PAR=1 host working, PAR=0 host not working) INTEGER :: SYM, PAR INTEGER :: JOB ! -------------------- ! Order of Input matrix ! -------------------- INTEGER :: N ! ! ---------------------------------------- ! Assembled input matrix : User interface ! ---------------------------------------- INTEGER :: NZ ! Standard integer input + bwd. compat. INTEGER(8) :: NNZ ! 64-bit integer input REAL, DIMENSION(:), POINTER :: A INTEGER, DIMENSION(:), POINTER :: IRN, JCN ! -------------- ! Scaling arrays ! -------------- REAL, DIMENSION(:), POINTER :: COLSCA, ROWSCA REAL, DIMENSION(:), POINTER :: COLSCA_loc REAL, DIMENSION(:), POINTER :: ROWSCA_loc INTEGER, DIMENSION(:), POINTER :: ROWIND, COLIND REAL, DIMENSION(:), POINTER :: PIVOTS ! ! ------------------------------------ ! Case of distributed assembled matrix ! matrix on entry: ! ------------------------------------ INTEGER :: NZ_loc ! Standard integer input + bwd. compat. INTEGER :: pad1 INTEGER(8) :: NNZ_loc ! 64-bit integer input INTEGER, DIMENSION(:), POINTER :: IRN_loc, JCN_loc REAL, DIMENSION(:), POINTER :: A_loc, pad2 ! ! ---------------------------------------- ! Unassembled input matrix: User interface ! ---------------------------------------- INTEGER :: NELT, pad3 INTEGER, DIMENSION(:), POINTER :: ELTPTR INTEGER, DIMENSION(:), POINTER :: ELTVAR REAL, DIMENSION(:), POINTER :: A_ELT, pad4 ! ! --------------------------------------------- ! Symmetric permutation : ! PERM_IN if given by user (optional) ! --------------------------------------------- INTEGER, DIMENSION(:), POINTER :: PERM_IN ! ! ---------------- ! Format by blocks ! ---------------- INTEGER :: NBLK, pad5 INTEGER, DIMENSION(:), POINTER :: BLKPTR INTEGER, DIMENSION(:), POINTER :: BLKVAR ! ! ****************** ! INPUT/OUTPUT data ! ****************** ! -------------------------------------------------------- ! RHS / SOL_loc ! ------------- ! right-hand side and solution ! ------------------------------------------------------- REAL, DIMENSION(:), POINTER :: RHS, REDRHS REAL, DIMENSION(:), POINTER :: RHS_SPARSE REAL, DIMENSION(:), POINTER :: SOL_loc REAL, DIMENSION(:), POINTER :: RHS_loc INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE INTEGER, DIMENSION(:), POINTER :: IRHS_PTR INTEGER, DIMENSION(:), POINTER :: ISOL_loc INTEGER, DIMENSION(:), POINTER :: IRHS_loc INTEGER :: LRHS, NRHS, NZ_RHS, Nloc_RHS, LRHS_loc, LREDRHS INTEGER :: LSOL_loc, NSOL_loc INTEGER :: LD_RHSINTR, pad6 ! ---------------------------- ! Control parameters, ! statistics and output data ! --------------------------- INTEGER :: ICNTL(60) INTEGER :: INFO(80) INTEGER :: INFOG(80) REAL :: COST_SUBTREES REAL :: CNTL(15) REAL :: RINFO(40) REAL :: RINFOG(40) ! The options array for metis/parmetis INTEGER :: METIS_OPTIONS(40) ! --------------------------------------------------------- ! Permutations computed during analysis: ! SYM_PERM: Symmetric permutation ! UNS_PERM: Column permutation (optional) ! --------------------------------------------------------- INTEGER, DIMENSION(:), POINTER :: SYM_PERM, UNS_PERM ! ! ----- ! Schur ! ----- INTEGER :: NPROW, NPCOL, MBLOCK, NBLOCK INTEGER :: SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER :: SIZE_SCHUR REAL, DIMENSION(:), POINTER :: SCHUR REAL, DIMENSION(:), POINTER :: SCHUR_CINTERFACE INTEGER, DIMENSION(:), POINTER :: LISTVAR_SCHUR ! ------------------------------------- ! Case of distributed matrix on entry: ! SMUMPS potentially provides mapping ! ------------------------------------- INTEGER, DIMENSION(:), POINTER :: MAPPING ! -------------- ! Version number ! -------------- CHARACTER(LEN=30) :: VERSION_NUMBER ! ----------- ! Out-of-core ! ----------- CHARACTER(LEN=1023) :: OOC_TMPDIR CHARACTER(LEN=255) :: OOC_PREFIX ! ------------------------------------------ ! Name of file to dump a matrix/rhs to disk ! ------------------------------------------ CHARACTER(LEN=1023) :: WRITE_PROBLEM ! ----------- ! Save/Restore ! ----------- CHARACTER(LEN=1023) :: SAVE_DIR CHARACTER(LEN=255) :: SAVE_PREFIX CHARACTER(LEN=7) :: pad7 ! ! ! ********************** ! INTERNAL Working data ! ********************* INTEGER(8) :: KEEP8(150), MAX_SURF_MASTER INTEGER :: INST_Number ! For MPI INTEGER :: COMM_NODES, MYID_NODES, COMM_LOAD INTEGER :: MYID, NPROCS, NSLAVES INTEGER :: ASS_IRECV ! IS is used for the factors + workspace for contrib. blocks INTEGER, DIMENSION(:), POINTER :: IS INTEGER :: KEEP(500) ! The following data/arrays are computed during the analysis ! phase and used during the factorization and solve phases. INTEGER :: LNA INTEGER :: NBSA INTEGER,POINTER,DIMENSION(:) :: STEP, NE_STEPS, ND_STEPS INTEGER,POINTER,DIMENSION(:) :: FRERE_STEPS, DAD_STEPS INTEGER,POINTER,DIMENSION(:) :: FILS, FRTPTR, FRTELT INTEGER(8),POINTER,DIMENSION(:) :: PTRAR, PTR8ARR INTEGER,POINTER,DIMENSION(:) :: NINCOLARR,NINROWARR,PTRDEBARR INTEGER,POINTER,DIMENSION(:) :: NA, PROCNODE_STEPS ! Info for pruning tree INTEGER,POINTER,DIMENSION(:) :: Step2node ! PTLUST_S and PTRFAC are two pointer arrays computed during ! factorization and used by the solve INTEGER, DIMENSION(:), POINTER :: PTLUST_S INTEGER(8), DIMENSION(:), POINTER :: PTRFAC ! main real working arrays for factorization/solve phases REAL, DIMENSION(:), POINTER :: S REAL(kind(0.E0)), DIMENSION(:), POINTER :: LPS ! Information on mapping INTEGER, DIMENSION(:), POINTER :: PROCNODE ! Input matrix ready for numerical assembly ! -arrowhead format in case of assembled matrix ! -element format otherwise ! Element entry: internal data INTEGER :: NELT_loc, LELTVAR INTEGER, DIMENSION(:), POINTER :: ELTPROC ! Candidates and node partitionning INTEGER, DIMENSION(:,:), POINTER :: CANDIDATES INTEGER, DIMENSION(:), POINTER :: ISTEP_TO_INIV2 INTEGER, DIMENSION(:), POINTER :: FUTURE_NIV2 INTEGER, DIMENSION(:,:), POINTER :: TAB_POS_IN_PERE LOGICAL, DIMENSION(:), POINTER :: I_AM_CAND ! For heterogeneous architecture INTEGER, DIMENSION(:), POINTER :: MEM_DIST ! Compressed RHS INTEGER, DIMENSION(:), POINTER :: GLOB2LOC_RHS LOGICAL :: GLOB2LOC_SOL_ALLOC, pad11 INTEGER, DIMENSION(:), POINTER :: GLOB2LOC_SOL REAL, DIMENSION(:), POINTER :: RHSINTR ! Info on the subtrees to be used during factorization DOUBLE PRECISION, DIMENSION(:), POINTER :: MEM_SUBTREE DOUBLE PRECISION, DIMENSION(:), POINTER :: COST_TRAV INTEGER, DIMENSION(:), POINTER :: MY_ROOT_SBTR INTEGER, DIMENSION(:), POINTER :: MY_FIRST_LEAF INTEGER, DIMENSION(:), POINTER :: MY_NB_LEAF INTEGER, DIMENSION(:), POINTER :: DEPTH_FIRST INTEGER, DIMENSION(:), POINTER :: DEPTH_FIRST_SEQ INTEGER, DIMENSION(:), POINTER :: SBTR_ID INTEGER, DIMENSION(:), POINTER :: SCHED_DEP INTEGER, DIMENSION(:), POINTER :: SCHED_GRP INTEGER, DIMENSION(:), POINTER :: SCHED_SBTR INTEGER, DIMENSION(:), POINTER :: CROIX_MANU REAL, DIMENSION(:), POINTER :: WK_USER INTEGER :: NBSA_LOCAL INTEGER :: LWK_USER ! Internal control array REAL :: DKEEP(230) ! For simulating parallel out-of-core stack. DOUBLE PRECISION, DIMENSION(:),POINTER :: CB_SON_SIZE ! Instance number used/managed by the C/F77 interface INTEGER :: INSTANCE_NUMBER ! OOC management data that must persist from factorization to solve. INTEGER :: OOC_MAX_NB_NODES_FOR_ZONE INTEGER, DIMENSION(:,:), POINTER :: OOC_INODE_SEQUENCE INTEGER(8),DIMENSION(:,:), POINTER :: OOC_SIZE_OF_BLOCK INTEGER(8), DIMENSION(:,:), POINTER :: OOC_VADDR INTEGER,DIMENSION(:), POINTER :: OOC_TOTAL_NB_NODES INTEGER,DIMENSION(:), POINTER :: OOC_NB_FILES INTEGER :: OOC_NB_FILE_TYPE,pad12 INTEGER,DIMENSION(:), POINTER :: OOC_FILE_NAME_LENGTH CHARACTER,DIMENSION(:,:), POINTER :: OOC_FILE_NAMES ! Indices of nul pivots INTEGER,DIMENSION(:), POINTER :: PIVNUL_LIST ! Array needed to manage additionnal candidate processor INTEGER, DIMENSION(:,:), POINTER :: SUP_PROC, pad14 ! Lists of nodes where processors work. Built/used in solve phase. INTEGER, DIMENSION(:), POINTER :: IPTR_WORKING, WORKING ! Internal data structures accessor CHARACTER, DIMENSION(:), POINTER :: INTR_ENCODING ! Low-rank INTEGER, POINTER, DIMENSION(:) :: LRGROUPS INTEGER :: NBGRP,pad13 ! Pointer encoding for FDM_F data CHARACTER, DIMENSION(:), POINTER :: FDM_F_ENCODING ! Pointer array encoding BLR factors pointers CHARACTER, DIMENSION(:), POINTER :: BLRARRAY_ENCODING ! Multicore INTEGER :: LPOOL_A_L0_OMP, LPOOL_B_L0_OMP INTEGER :: L_PHYS_L0_OMP INTEGER :: L_VIRT_L0_OMP INTEGER :: LL0_OMP_MAPPING, LL0_OMP_FACTORS INTEGER(8) :: THREAD_LA ! Estimates before L0_OMP INTEGER, DIMENSION(:,:), POINTER :: I4_L0_OMP INTEGER(8), DIMENSION(:,:), POINTER :: I8_L0_OMP ! Pool before L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_B_L0_OMP ! Pool after L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_A_L0_OMP ! Subtrees INTEGER, DIMENSION(:), POINTER :: PHYS_L0_OMP ! Amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP ! Mapping of amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP_MAPPING ! From heaviest to lowest subtree INTEGER, DIMENSION(:), POINTER :: PERM_L0_OMP ! To get leafs in global pool INTEGER, DIMENSION(:), POINTER :: PTR_LEAFS_L0_OMP ! Mapping of the subtree nodes INTEGER, DIMENSION(:), POINTER :: L0_OMP_MAPPING ! Mpi to omp - mumps agile INTEGER, DIMENSION(:), POINTER :: MTKO_PROCS_MAP ! for RR on root REAL, DIMENSION(:), POINTER :: SINGULAR_VALUES INTEGER :: NB_SINGULAR_VALUES INTEGER :: Deficiency, pad16 ! To know if OOC files are associated to a saved and so if they should be removed. LOGICAL :: ASSOCIATED_OOC_FILES END TYPE SMUMPS_STRUC MUMPS_5.8.1/include/mumps_c_types.h0000664000175000017500000000346715042446422017136 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_C_TYPES_H #define MUMPS_C_TYPES_H #include /* mumps_int_def.h will define either MUMPS_INTSIZE32 (default) or MUMPS_INTSIZE64 (if compilation is with -DINTSIZE64 to match Fortran -i8 or equivalent option). This allows one to test from an external code whether MUMPS_INT is 64bits or not */ #include "mumps_int_def.h" #ifdef MUMPS_INTSIZE64 #define MUMPS_INT int64_t #else #define MUMPS_INT int #endif #define MUMPS_INT8 int64_t #define SMUMPS_COMPLEX float #define SMUMPS_REAL float #define DMUMPS_COMPLEX double #define DMUMPS_REAL double /* Complex datatypes */ typedef struct {float r,i;} mumps_complex; typedef struct {double r,i;} mumps_double_complex; #define CMUMPS_COMPLEX mumps_complex #define CMUMPS_REAL float #define ZMUMPS_COMPLEX mumps_double_complex #define ZMUMPS_REAL double #ifndef mumps_ftnlen /* When passing a string, what is the type of the extra argument * passed by value ? */ # define mumps_ftnlen MUMPS_INT #endif #define MUMPS_ARITH_s 1 #define MUMPS_ARITH_d 2 #define MUMPS_ARITH_c 4 #define MUMPS_ARITH_z 8 #define MUMPS_ARITH_REAL ( MUMPS_ARITH_s | MUMPS_ARITH_d ) #define MUMPS_ARITH_CMPLX ( MUMPS_ARITH_c | MUMPS_ARITH_z ) #define MUMPS_ARITH_SINGLE ( MUMPS_ARITH_s | MUMPS_ARITH_c ) #define MUMPS_ARITH_DBL ( MUMPS_ARITH_d | MUMPS_ARITH_z ) #define MUMPS_OFF_T MUMPS_INT8 #endif /* MUMPS_C_TYPES_H */ MUMPS_5.8.1/include/smumps_c.h0000664000175000017500000001004515042446422016063 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Mostly written in march 2002 (JYL) */ #ifndef SMUMPS_C_H #define SMUMPS_C_H #ifdef __cplusplus extern "C" { #endif #include "mumps_compat.h" /* Next line defines MUMPS_INT, SMUMPS_COMPLEX and SMUMPS_REAL */ #include "mumps_c_types.h" #ifndef MUMPS_VERSION /* Protected in case headers of other arithmetics are included */ #define MUMPS_VERSION "5.8.1" #endif #ifndef MUMPS_VERSION_MAX_LEN #define MUMPS_VERSION_MAX_LEN 30 #endif /* * Definition of the (simplified) MUMPS C structure. * NB: SMUMPS_COMPLEX are REAL types in s and d arithmetics. */ typedef struct { MUMPS_INT sym, par, job; MUMPS_INT comm_fortran; /* Fortran communicator */ MUMPS_INT icntl[60]; MUMPS_INT keep[500]; SMUMPS_REAL cntl[15]; SMUMPS_REAL dkeep[230]; MUMPS_INT8 keep8[150]; MUMPS_INT n; MUMPS_INT nblk; MUMPS_INT nz_alloc; /* used in matlab interface to decide if we free + malloc when we have large variation */ /* Assembled entry */ MUMPS_INT nz; MUMPS_INT8 nnz; MUMPS_INT *irn; MUMPS_INT *jcn; SMUMPS_COMPLEX *a; /* Distributed entry */ MUMPS_INT nz_loc; MUMPS_INT8 nnz_loc; MUMPS_INT *irn_loc; MUMPS_INT *jcn_loc; SMUMPS_COMPLEX *a_loc; /* Element entry */ MUMPS_INT nelt; MUMPS_INT *eltptr; MUMPS_INT *eltvar; SMUMPS_COMPLEX *a_elt; /* Matrix by blocks */ MUMPS_INT *blkptr; MUMPS_INT *blkvar; /* Ordering, if given by user */ MUMPS_INT *perm_in; /* Orderings returned to user */ MUMPS_INT *sym_perm; /* symmetric permutation */ MUMPS_INT *uns_perm; /* column permutation */ /* Scaling (inout but complicated) */ SMUMPS_REAL *colsca; SMUMPS_REAL *rowsca; MUMPS_INT colsca_from_mumps; MUMPS_INT rowsca_from_mumps; /* Distributed scaling(out) */ SMUMPS_REAL *colsca_loc; SMUMPS_REAL *rowsca_loc; /* Info after facto */ MUMPS_INT *rowind; MUMPS_INT *colind; SMUMPS_COMPLEX *pivots; /* RHS, solution, ouptput data and statistics */ SMUMPS_COMPLEX *rhs, *redrhs, *rhs_sparse, *sol_loc, *rhs_loc, *rhsintr; MUMPS_INT *irhs_sparse, *irhs_ptr, *isol_loc, *irhs_loc, *glob2loc_rhs, *glob2loc_sol; MUMPS_INT nrhs, lrhs, lredrhs, nz_rhs, lsol_loc, nloc_rhs, lrhs_loc, nsol_loc; MUMPS_INT schur_mloc, schur_nloc, schur_lld; MUMPS_INT mblock, nblock, nprow, npcol; MUMPS_INT ld_rhsintr; MUMPS_INT info[80],infog[80]; SMUMPS_REAL rinfo[40], rinfog[40]; /* Null space */ MUMPS_INT deficiency; MUMPS_INT *pivnul_list; MUMPS_INT *mapping; SMUMPS_REAL *singular_values; /* Schur */ MUMPS_INT size_schur; MUMPS_INT *listvar_schur; SMUMPS_COMPLEX *schur; /* user workspace */ SMUMPS_COMPLEX *wk_user; /* Version number: length=30 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[1024]; char ooc_prefix[256]; /* To save the matrix in matrix market format */ char write_problem[1024]; MUMPS_INT lwk_user; /* For save/restore feature */ char save_dir[1024]; char save_prefix[256]; /* Metis options */ MUMPS_INT metis_options[40]; /* Internal parameters */ MUMPS_INT instance_number; } SMUMPS_STRUC_C; void MUMPS_CALL smumps_c( SMUMPS_STRUC_C * smumps_par ); #ifdef __cplusplus } #endif #endif /* SMUMPS_C_H */ MUMPS_5.8.1/include/dmumps_struc.h0000664000175000017500000002765615042446436017007 0ustar amestoyamestoy! ! This file is part of MUMPS 5.8.1, released ! on Wed Jul 30 16:49:18 UTC 2025 ! ! ! Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! Mumps Technologies, University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license ! (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and ! https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) ! TYPE DMUMPS_STRUC SEQUENCE ! ! This structure contains all parameters ! for the interface to the user, plus internal ! information from the solver ! ! ***************** ! INPUT PARAMETERS ! ***************** ! ----------------- ! MPI Communicator ! ----------------- INTEGER :: COMM ! ------------------ ! Problem definition ! ------------------ ! Solver (SYM=0 unsymmetric,SYM=1 symmetric Positive Definite, ! SYM=2 general symmetric) ! Type of parallelism (PAR=1 host working, PAR=0 host not working) INTEGER :: SYM, PAR INTEGER :: JOB ! -------------------- ! Order of Input matrix ! -------------------- INTEGER :: N ! ! ---------------------------------------- ! Assembled input matrix : User interface ! ---------------------------------------- INTEGER :: NZ ! Standard integer input + bwd. compat. INTEGER(8) :: NNZ ! 64-bit integer input DOUBLE PRECISION, DIMENSION(:), POINTER :: A INTEGER, DIMENSION(:), POINTER :: IRN, JCN ! -------------- ! Scaling arrays ! -------------- DOUBLE PRECISION, DIMENSION(:), POINTER :: COLSCA, ROWSCA DOUBLE PRECISION, DIMENSION(:), POINTER :: COLSCA_loc DOUBLE PRECISION, DIMENSION(:), POINTER :: ROWSCA_loc INTEGER, DIMENSION(:), POINTER :: ROWIND, COLIND DOUBLE PRECISION, DIMENSION(:), POINTER :: PIVOTS ! ! ------------------------------------ ! Case of distributed assembled matrix ! matrix on entry: ! ------------------------------------ INTEGER :: NZ_loc ! Standard integer input + bwd. compat. INTEGER :: pad1 INTEGER(8) :: NNZ_loc ! 64-bit integer input INTEGER, DIMENSION(:), POINTER :: IRN_loc, JCN_loc DOUBLE PRECISION, DIMENSION(:), POINTER :: A_loc, pad2 ! ! ---------------------------------------- ! Unassembled input matrix: User interface ! ---------------------------------------- INTEGER :: NELT, pad3 INTEGER, DIMENSION(:), POINTER :: ELTPTR INTEGER, DIMENSION(:), POINTER :: ELTVAR DOUBLE PRECISION, DIMENSION(:), POINTER :: A_ELT, pad4 ! ! --------------------------------------------- ! Symmetric permutation : ! PERM_IN if given by user (optional) ! --------------------------------------------- INTEGER, DIMENSION(:), POINTER :: PERM_IN ! ! ---------------- ! Format by blocks ! ---------------- INTEGER :: NBLK, pad5 INTEGER, DIMENSION(:), POINTER :: BLKPTR INTEGER, DIMENSION(:), POINTER :: BLKVAR ! ! ****************** ! INPUT/OUTPUT data ! ****************** ! -------------------------------------------------------- ! RHS / SOL_loc ! ------------- ! right-hand side and solution ! ------------------------------------------------------- DOUBLE PRECISION, DIMENSION(:), POINTER :: RHS, REDRHS DOUBLE PRECISION, DIMENSION(:), POINTER :: RHS_SPARSE DOUBLE PRECISION, DIMENSION(:), POINTER :: SOL_loc DOUBLE PRECISION, DIMENSION(:), POINTER :: RHS_loc INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE INTEGER, DIMENSION(:), POINTER :: IRHS_PTR INTEGER, DIMENSION(:), POINTER :: ISOL_loc INTEGER, DIMENSION(:), POINTER :: IRHS_loc INTEGER :: LRHS, NRHS, NZ_RHS, Nloc_RHS, LRHS_loc, LREDRHS INTEGER :: LSOL_loc, NSOL_loc INTEGER :: LD_RHSINTR, pad6 ! ---------------------------- ! Control parameters, ! statistics and output data ! --------------------------- INTEGER :: ICNTL(60) INTEGER :: INFO(80) INTEGER :: INFOG(80) DOUBLE PRECISION :: COST_SUBTREES DOUBLE PRECISION :: CNTL(15) DOUBLE PRECISION :: RINFO(40) DOUBLE PRECISION :: RINFOG(40) ! The options array for metis/parmetis INTEGER :: METIS_OPTIONS(40) ! --------------------------------------------------------- ! Permutations computed during analysis: ! SYM_PERM: Symmetric permutation ! UNS_PERM: Column permutation (optional) ! --------------------------------------------------------- INTEGER, DIMENSION(:), POINTER :: SYM_PERM, UNS_PERM ! ! ----- ! Schur ! ----- INTEGER :: NPROW, NPCOL, MBLOCK, NBLOCK INTEGER :: SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER :: SIZE_SCHUR DOUBLE PRECISION, DIMENSION(:), POINTER :: SCHUR DOUBLE PRECISION, DIMENSION(:), POINTER :: SCHUR_CINTERFACE INTEGER, DIMENSION(:), POINTER :: LISTVAR_SCHUR ! ------------------------------------- ! Case of distributed matrix on entry: ! DMUMPS potentially provides mapping ! ------------------------------------- INTEGER, DIMENSION(:), POINTER :: MAPPING ! -------------- ! Version number ! -------------- CHARACTER(LEN=30) :: VERSION_NUMBER ! ----------- ! Out-of-core ! ----------- CHARACTER(LEN=1023) :: OOC_TMPDIR CHARACTER(LEN=255) :: OOC_PREFIX ! ------------------------------------------ ! Name of file to dump a matrix/rhs to disk ! ------------------------------------------ CHARACTER(LEN=1023) :: WRITE_PROBLEM ! ----------- ! Save/Restore ! ----------- CHARACTER(LEN=1023) :: SAVE_DIR CHARACTER(LEN=255) :: SAVE_PREFIX CHARACTER(LEN=7) :: pad7 ! ! ! ********************** ! INTERNAL Working data ! ********************* INTEGER(8) :: KEEP8(150), MAX_SURF_MASTER INTEGER :: INST_Number ! For MPI INTEGER :: COMM_NODES, MYID_NODES, COMM_LOAD INTEGER :: MYID, NPROCS, NSLAVES INTEGER :: ASS_IRECV ! IS is used for the factors + workspace for contrib. blocks INTEGER, DIMENSION(:), POINTER :: IS INTEGER :: KEEP(500) ! The following data/arrays are computed during the analysis ! phase and used during the factorization and solve phases. INTEGER :: LNA INTEGER :: NBSA INTEGER,POINTER,DIMENSION(:) :: STEP, NE_STEPS, ND_STEPS INTEGER,POINTER,DIMENSION(:) :: FRERE_STEPS, DAD_STEPS INTEGER,POINTER,DIMENSION(:) :: FILS, FRTPTR, FRTELT INTEGER(8),POINTER,DIMENSION(:) :: PTRAR, PTR8ARR INTEGER,POINTER,DIMENSION(:) :: NINCOLARR,NINROWARR,PTRDEBARR INTEGER,POINTER,DIMENSION(:) :: NA, PROCNODE_STEPS ! Info for pruning tree INTEGER,POINTER,DIMENSION(:) :: Step2node ! PTLUST_S and PTRFAC are two pointer arrays computed during ! factorization and used by the solve INTEGER, DIMENSION(:), POINTER :: PTLUST_S INTEGER(8), DIMENSION(:), POINTER :: PTRFAC ! main real working arrays for factorization/solve phases DOUBLE PRECISION, DIMENSION(:), POINTER :: S REAL(kind(0.E0)), DIMENSION(:), POINTER :: LPS ! Information on mapping INTEGER, DIMENSION(:), POINTER :: PROCNODE ! Input matrix ready for numerical assembly ! -arrowhead format in case of assembled matrix ! -element format otherwise ! Element entry: internal data INTEGER :: NELT_loc, LELTVAR INTEGER, DIMENSION(:), POINTER :: ELTPROC ! Candidates and node partitionning INTEGER, DIMENSION(:,:), POINTER :: CANDIDATES INTEGER, DIMENSION(:), POINTER :: ISTEP_TO_INIV2 INTEGER, DIMENSION(:), POINTER :: FUTURE_NIV2 INTEGER, DIMENSION(:,:), POINTER :: TAB_POS_IN_PERE LOGICAL, DIMENSION(:), POINTER :: I_AM_CAND ! For heterogeneous architecture INTEGER, DIMENSION(:), POINTER :: MEM_DIST ! Compressed RHS INTEGER, DIMENSION(:), POINTER :: GLOB2LOC_RHS LOGICAL :: GLOB2LOC_SOL_ALLOC, pad11 INTEGER, DIMENSION(:), POINTER :: GLOB2LOC_SOL DOUBLE PRECISION, DIMENSION(:), POINTER :: RHSINTR ! Info on the subtrees to be used during factorization DOUBLE PRECISION, DIMENSION(:), POINTER :: MEM_SUBTREE DOUBLE PRECISION, DIMENSION(:), POINTER :: COST_TRAV INTEGER, DIMENSION(:), POINTER :: MY_ROOT_SBTR INTEGER, DIMENSION(:), POINTER :: MY_FIRST_LEAF INTEGER, DIMENSION(:), POINTER :: MY_NB_LEAF INTEGER, DIMENSION(:), POINTER :: DEPTH_FIRST INTEGER, DIMENSION(:), POINTER :: DEPTH_FIRST_SEQ INTEGER, DIMENSION(:), POINTER :: SBTR_ID INTEGER, DIMENSION(:), POINTER :: SCHED_DEP INTEGER, DIMENSION(:), POINTER :: SCHED_GRP INTEGER, DIMENSION(:), POINTER :: SCHED_SBTR INTEGER, DIMENSION(:), POINTER :: CROIX_MANU DOUBLE PRECISION, DIMENSION(:), POINTER :: WK_USER INTEGER :: NBSA_LOCAL INTEGER :: LWK_USER ! Internal control array DOUBLE PRECISION :: DKEEP(230) ! For simulating parallel out-of-core stack. DOUBLE PRECISION, DIMENSION(:),POINTER :: CB_SON_SIZE ! Instance number used/managed by the C/F77 interface INTEGER :: INSTANCE_NUMBER ! OOC management data that must persist from factorization to solve. INTEGER :: OOC_MAX_NB_NODES_FOR_ZONE INTEGER, DIMENSION(:,:), POINTER :: OOC_INODE_SEQUENCE INTEGER(8),DIMENSION(:,:), POINTER :: OOC_SIZE_OF_BLOCK INTEGER(8), DIMENSION(:,:), POINTER :: OOC_VADDR INTEGER,DIMENSION(:), POINTER :: OOC_TOTAL_NB_NODES INTEGER,DIMENSION(:), POINTER :: OOC_NB_FILES INTEGER :: OOC_NB_FILE_TYPE,pad12 INTEGER,DIMENSION(:), POINTER :: OOC_FILE_NAME_LENGTH CHARACTER,DIMENSION(:,:), POINTER :: OOC_FILE_NAMES ! Indices of nul pivots INTEGER,DIMENSION(:), POINTER :: PIVNUL_LIST ! Array needed to manage additionnal candidate processor INTEGER, DIMENSION(:,:), POINTER :: SUP_PROC, pad14 ! Lists of nodes where processors work. Built/used in solve phase. INTEGER, DIMENSION(:), POINTER :: IPTR_WORKING, WORKING ! Internal data structures accessor CHARACTER, DIMENSION(:), POINTER :: INTR_ENCODING ! Low-rank INTEGER, POINTER, DIMENSION(:) :: LRGROUPS INTEGER :: NBGRP,pad13 ! Pointer encoding for FDM_F data CHARACTER, DIMENSION(:), POINTER :: FDM_F_ENCODING ! Pointer array encoding BLR factors pointers CHARACTER, DIMENSION(:), POINTER :: BLRARRAY_ENCODING ! Multicore INTEGER :: LPOOL_A_L0_OMP, LPOOL_B_L0_OMP INTEGER :: L_PHYS_L0_OMP INTEGER :: L_VIRT_L0_OMP INTEGER :: LL0_OMP_MAPPING, LL0_OMP_FACTORS INTEGER(8) :: THREAD_LA ! Estimates before L0_OMP INTEGER, DIMENSION(:,:), POINTER :: I4_L0_OMP INTEGER(8), DIMENSION(:,:), POINTER :: I8_L0_OMP ! Pool before L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_B_L0_OMP ! Pool after L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_A_L0_OMP ! Subtrees INTEGER, DIMENSION(:), POINTER :: PHYS_L0_OMP ! Amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP ! Mapping of amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP_MAPPING ! From heaviest to lowest subtree INTEGER, DIMENSION(:), POINTER :: PERM_L0_OMP ! To get leafs in global pool INTEGER, DIMENSION(:), POINTER :: PTR_LEAFS_L0_OMP ! Mapping of the subtree nodes INTEGER, DIMENSION(:), POINTER :: L0_OMP_MAPPING ! Mpi to omp - mumps agile INTEGER, DIMENSION(:), POINTER :: MTKO_PROCS_MAP ! for RR on root DOUBLE PRECISION, DIMENSION(:), POINTER :: SINGULAR_VALUES INTEGER :: NB_SINGULAR_VALUES INTEGER :: Deficiency, pad16 ! To know if OOC files are associated to a saved and so if they should be removed. LOGICAL :: ASSOCIATED_OOC_FILES END TYPE DMUMPS_STRUC MUMPS_5.8.1/src/0000775000175000017500000000000015042446442013232 5ustar amestoyamestoyMUMPS_5.8.1/src/sfac_sispointers_m.F0000664000175000017500000000152515042446441017235 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_S_IS_POINTERS_M C ---------------------------------- C This module defines a type used in C SMUMPS_FAC_DRIVER and SMUMPS_FAC_B C ---------------------------------- TYPE SMUMPS_S_IS_POINTERS_T REAL, POINTER, DIMENSION(:) :: A INTEGER, POINTER, DIMENSION(:) :: IW END TYPE SMUMPS_S_IS_POINTERS_T END MODULE SMUMPS_FAC_S_IS_POINTERS_M MUMPS_5.8.1/src/cfac_front_LDLT_type2.F0000664000175000017500000010652515042446440017416 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC2_LDLT_M CONTAINS SUBROUTINE CMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NNEGW, NNULLNEGW, NPVW, NB22T2W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP, PIVNUL_LIST_STRUCT & , LRGROUPS & ) USE CMUMPS_FAC_FRONT_AUX_M USE CMUMPS_FAC_FRONT_TYPE2_AUX_M USE CMUMPS_OOC USE CMUMPS_FAC_LR USE CMUMPS_LR_TYPE USE MUMPS_LR_STATS USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_DATA_M !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_TEST USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW INTEGER, intent(inout) :: NNEGW, NPVW, NNULLNEGW, NB22T2W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX, intent(inout) :: DET_MANTW INTEGER(8) :: LA INTEGER, TARGET :: IW( LIW ) COMPLEX A( LA ) REAL UU, SEUIL TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) INTEGER NBFIN, SLAVEF, & IFLAG, IERROR, LEAF, LPOOL INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER NB_BLOC_FAC INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N), & PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW COMPLEX DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL AVOID_DELAYED TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)) INTEGER(8) :: POSELT INTEGER IOLDPS, allocok, K263,J INTEGER INOPV, IFINB, NFRONT, NPIV, IEND_BLOCK INTEGER NASS, LDAFS, IBEG_BLOCK INTEGER :: NB_POSTPONED INTEGER :: IBEG_BLOCK_FOR_IPIV LOGICAL LASTPANEL, LR_ACTIVATED, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR, CURRENT_BLR INTEGER Inextpiv LOGICAL RESET_TO_ONE INTEGER K109_SAVE INTEGER XSIZE, NBKJIB_ORIG REAL UUTEMP INCLUDE 'mumps_headers.h' INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV REAL , ALLOCATABLE, DIMENSION ( : ) :: DIAG_ORIG INTEGER :: SIZEDIAG_ORIG INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY, NELIM TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PP_FIRST2SWAP_L, IFLAG_OOC INTEGER PP_LastPIVRPTRFilled INTEGER INFO_TMP(2) INTEGER :: MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_SEND COMPLEX, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP, BEGS_BLR_STATIC INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, I, IP, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG, APOSMAX COMPLEX, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL,ALLOCATABLE :: RWORK(:) COMPLEX, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM LOGICAL :: SWAP_OCCURRED INTEGER :: MY_NUM INTEGER PIVOT_OPTION INTEGER LAST_ROW EXTERNAL CMUMPS_BDC_ERROR LOGICAL STATICMODE REAL SEUIL_LOC REAL GW_FACTCUMUL INTEGER PIVSIZ,IWPOSPIV COMPLEX ONE PARAMETER (ONE=(1.0E0,0.0E0)) NULLIFY(PTDummy) NULLIFY(ACC_LUA) NULLIFY(BEGS_BLR) NULLIFY(BLR_L) NULLIFY(BLR_SEND) NULLIFY(DIAG) NULLIFY(BLR_PANEL) NULLIFY(BEGS_BLR_TMP) NULLIFY(BEGS_BLR_STATIC) IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF SWAP_OCCURRED = .FALSE. INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC=SEUIL UUTEMP=UU ENDIF RESET_TO_ONE = ((KEEP(110).GT.0).AND.(DKEEP(2).LE.0.0E0)) IF (RESET_TO_ONE) THEN K109_SAVE = KEEP(109) ENDIF IBEG_BLOCK = 1 NB_BLOC_FAC = 0 XSIZE = KEEP(IXSZ) IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) NFRONT = IW(IOLDPS+XSIZE) NASS = abs(IW(IOLDPS+2+XSIZE)) LDAFS = NASS IF ((KEEP(219).EQ.1).AND.(KEEP(207).EQ.1).AND.(KEEP(50).EQ.2) & ) THEN APOSMAX = POSELT + int(LDAFS,8)*int(LDAFS,8) NB_POSTPONED = max(NFRONT - ND(STEP(INODE)),0) CALL CMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, A(APOSMAX), NASS, NB_POSTPONED) ENDIF IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL CMUMPS_SET_INNERBLOCKSIZE( NBKJIB_ORIG, NASS, KEEP) IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF (LR_ACTIVATED) THEN K263 = 1 ELSE K263 = KEEP(263) IF (K263 .NE. 0 .AND. NASS/NBLR_ORIG < 4) THEN IF ( NBLR_ORIG .GT. NBKJIB_ORIG * 4 ) THEN NBLR_ORIG = max(NBKJIB_ORIG, (NASS+3)/4) ELSE K263 = 0 ENDIF ENDIF ENDIF PIVOT_OPTION = MIN(2,KEEP(468)) IF ((UUTEMP == 0.0E0) .AND. OOC_EFFECTIVE_ON_FRONT) THEN IF (K263.EQ.1.AND.(.NOT.LR_ACTIVATED)) THEN PIVOT_OPTION = 0 ENDIF ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID, ' : CMUMPS_FAC2_LDLT failed to allocate ', & NASS, ' integers' IFLAG = -13 IERROR=NASS GO TO 500 END IF IF (KEEP(219).GE.3) THEN SIZEDIAG_ORIG = NASS ELSE SIZEDIAG_ORIG = 1 ENDIF ALLOCATE ( DIAG_ORIG(SIZEDIAG_ORIG), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID, & ' : FAC_NIV2 failed to allocate ', & NASS, ' REAL/COMPLEX entries' IFLAG=-13 IERROR=NASS GO TO 500 END IF CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF (OOC_EFFECTIVE_ON_FRONT) THEN IDUMMY = -9876 TYPEFile = TYPEF_L NextPiv2beWritten = 1 PP_FIRST2SWAP_L = NextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 2 MonBloc%NROW = NASS MonBloc%NCOL = NASS MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -66666 MonBloc%INDICES => & IW(IOLDPS+6+NFRONT+XSIZE+IW(IOLDPS+5+XSIZE) & :IOLDPS+5+2*NFRONT+XSIZE+IW(IOLDPS+5+XSIZE)) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(475).EQ.3) THEN IF (UUTEMP == 0.0E0) THEN PIVOT_OPTION = 0 ELSE PIVOT_OPTION = 1 ENDIF ENDIF CNT_NODES = CNT_NODES + 1 ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.2) .AND. & OOC_EFFECTIVE_ON_FRONT ) IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & 0, KEEP(488), .FALSE., KEEP(472), & NFRONT, KEEP(1)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 480 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL CMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 CALL CMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .TRUE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF LASTPANEL = .FALSE. DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = BEGS_BLR(CURRENT_BLR+1)-1 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 480 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (K263.EQ.0) THEN IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK ELSE IBEG_BLOCK_FOR_IPIV = IBEG_BLR ENDIF CALL CMUMPS_FAC_I_LDLT_NIV2( & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, & NFRONT,NASS,IBEG_BLOCK_FOR_IPIV, & IBEG_BLOCK, IEND_BLOCK, & NASS, IPIV, & N,INODE,IW,LIW,A,LA, & NNEGW,NNULLNEGW, NB22T2W,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INOPV, & IFLAG,IERROR,IOLDPS,POSELT,UU, SEUIL_LOC, & KEEP,KEEP8,PIVSIZ, & DKEEP(1), PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, & PIVOT_OPTION, & Inextpiv, IEND_BLR, LR_ACTIVATED, & OOC_EFFECTIVE_ON_FRONT) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ. 1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTPANEL = .TRUE. ELSE IF (INOPV .LE. 0) THEN INOPV = 0 NPVW = NPVW + PIVSIZ CALL CMUMPS_FAC_MQ_LDLT_NIV2(IEND_BLOCK, & NASS, IW(IOLDPS+1+XSIZE), INODE,A,LA, & LDAFS, POSELT,IFINB, & PIVSIZ, & KEEP(219), & PIVOT_OPTION, IEND_BLR, LR_ACTIVATED) IF(PIVSIZ .EQ. 2) THEN IWPOSPIV = IOLDPS+XSIZE+IW(IOLDPS+1+XSIZE)+6+ & IW(IOLDPS+5+XSIZE) IW(IWPOSPIV+NFRONT) = -IW(IWPOSPIV+NFRONT) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB .EQ. -1) THEN LASTPANEL = .TRUE. ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN IF (.NOT.RESET_TO_ONE.OR.K109_SAVE.EQ.KEEP(109)) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF ENDIF IF (K263.eq.0) THEN NELIM = IEND_BLR - NPIV CALL CMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEG_BLOCK, NPIV, IPIV, NASS,LASTPANEL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, .FALSE. & , NPARTSASS, CURRENT_BLR, BLR_DUMMY, LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN CALL CMUMPS_RESET_TO_ONE( & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), & NPIV, IBEG_BLOCK, & K109_SAVE, KEEP(109), PIVNUL_LIST_STRUCT, & A, POSELT, LA, LDAFS) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF ENDIF IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL CMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & -6666, -6666, & IEND_BLR, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ENDIF CALL MUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 500 ENDIF NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) THEN WRITE(*,*) "Internal error 1 in CMUMPS_FAC2_LDLT", & IEND_BLR, IEND_BLOCK CALL MUMPS_ABORT() ENDIF IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) NULLIFY(BLR_L) ENDIF GOTO 101 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), KEEP(458), & KEEP(473), BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8 & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (PIVOT_OPTION.LT.2) THEN CALL CMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NB_BLR, 2, 1, 0, .FALSE., & IW, OFFSET_IW=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1, & NASS=NASS) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 480 IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ENDIF ENDIF 101 CONTINUE IF (.NOT. LR_ACTIVATED) THEN CALL CMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS, NASS, INODE, A, LA, & LDAFS, POSELT, & KEEP, KEEP8, & IEND_BLR, NASS, & -6666, -6666, & (PIVOT_OPTION.LE.1), .FALSE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ENDIF IF (K263.NE.0) THEN NELIM = IEND_BLR-NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_L)) THEN BLR_SEND=>BLR_L ENDIF CALL CMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEG_BLR, NPIV, IPIV, NASS,LASTPANEL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S,PTRFAC,STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR , BLR_SEND , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN CALL CMUMPS_RESET_TO_ONE( & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), & NPIV, IBEG_BLR, & K109_SAVE, KEEP(109), PIVNUL_LIST_STRUCT, & A, POSELT, LA, LDAFS) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF ENDIF IF (.NOT. LR_ACTIVATED) THEN IF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL CMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & -6666, -6666, & NASS, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ELSE NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) THEN CALL MUMPS_ABORT() ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN CALL CMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NASS, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 2, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8) ENDIF ENDIF IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 450 IF (KEEP(480).LT.2) THEN CALL CMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, & IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, & MAXI_CLUSTER, NPIV, & 2, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (PIVOT_OPTION.LT.2) THEN IF ((UU.GT.0).OR.(KEEP(486).NE.2)) THEN CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, NASS, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, & 'V', 1) ENDIF ENDIF 450 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 480 IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF ENDIF GOTO 100 ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL(BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & KEEP(34)) DEALLOCATE(BLR_L) ENDIF NULLIFY(BLR_L) ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO J=1,NB_BLR+1 BEGS_BLR_TMP(J) = BEGS_BLR_STATIC(J) ENDDO ENDIF ENDIF IF ( & (KEEP(486).EQ.2) & ) THEN MEM_TOT = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP& PRIVATE(IP, NELIM) #endif #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*DIAGSIZ_STA MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(LDAFS,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN POSELT_DIAG = POSELT_DIAG + int(LDAFS,8) ENDDO CALL CMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG, KEEP(34)) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO !$OMP SINGLE #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM_TOT,8), & .FALSE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 460 IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN DO IP=1,NPARTSASS NELIM = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8, & KEEP(34)) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, LDAFS, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(458), KEEP(473), & BLR_PANEL, IP, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 440 #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif 440 CONTINUE ENDIF 460 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 ENDIF IF ( & (KEEP(486).EQ.2) & ) THEN CALL CMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF CALL CMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 480 CONTINUE 500 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF(allocated(IPIV)) DEALLOCATE( IPIV ) IF (allocated(DIAG_ORIG)) DEALLOCATE(DIAG_ORIG) IF (LR_ACTIVATED) THEN IF (IFLAG.GE.0) THEN CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 1, NELIM) DO IP=1,NPARTSASS CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NPARTSASS-IP & ) ENDDO CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NASS-NELIM, 2, 2) ENDIF IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, KEEP(50), 2) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL CMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8, KEEP(34)) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL CMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34)) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_FAC2_LDLT SUBROUTINE CMUMPS_RESET_TO_ONE(FRONT_INDEX_LIST, NPIV, & IBEG_BLOCK, K109_SAVE, K109, PIVNUL_LIST_STRUCT, & A, POSELT, LA, LDAFS) USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T INTEGER, INTENT(IN) :: NPIV, IBEG_BLOCK INTEGER, INTENT(IN) :: FRONT_INDEX_LIST(NPIV) INTEGER, INTENT(IN) :: K109 INTEGER, INTENT(INOUT) :: K109_SAVE TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT INTEGER(8), INTENT(IN) :: POSELT, LA INTEGER, INTENT(IN) :: LDAFS COMPLEX, INTENT(INOUT) :: A(LA) LOGICAL :: TO_UPDATE INTEGER :: I, JJ, K COMPLEX ONE PARAMETER (ONE=(1.0E0,0.0E0)) DO K = K109_SAVE+1, K109 TO_UPDATE = .FALSE. I = PIVNUL_LIST_STRUCT%PIVNUL_LIST(K) DO JJ=IBEG_BLOCK, NPIV IF (FRONT_INDEX_LIST(JJ) .EQ.I) THEN TO_UPDATE=.TRUE. EXIT ENDIF ENDDO IF (TO_UPDATE) THEN A(POSELT+int(JJ,8)+int(LDAFS,8)*int(JJ-1,8))= ONE TO_UPDATE=.FALSE. ELSE write(*,*) ' Internal error related ', & 'to null pivot row detection' CALL MUMPS_ABORT() ENDIF ENDDO K109_SAVE = K109 RETURN END SUBROUTINE CMUMPS_RESET_TO_ONE END MODULE CMUMPS_FAC2_LDLT_M MUMPS_5.8.1/src/cfac_distrib_distentry.F0000664000175000017500000007444415042446440020075 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_BUILD_MAPPING & ( N, MAPPING, NNZ, IRN, JCN, PROCNODE, STEP, & SLAVEF, PERM, FILS, & RG2L, KEEP,KEEP8, MBLOCK, NBLOCK, NPROW, NPCOL ) USE CMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, SLAVEF, MBLOCK, NBLOCK, NPROW, NPCOL iNTEGER(8) :: NNZ INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN( NNZ ), JCN( NNZ ) INTEGER MAPPING( NNZ ), STEP( N ) INTEGER PROCNODE( KEEP(28) ), PERM( N ), FILS( N ), RG2L( N ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE INTEGER K4, IOLD, JOLD, INEW, JNEW, ISEND, JSEND, IARR, INODE INTEGER(8) :: K8 INTEGER TYPE_NODE, DEST INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INODE = KEEP(38) K4 = 1 DO WHILE ( INODE .GT. 0 ) RG2L( INODE ) = K4 INODE = FILS( INODE ) K4 = K4 + 1 END DO DO K8 = 1_8, NNZ IOLD = IRN( K8 ) JOLD = JCN( K8 ) IF ( IOLD .GT. N .OR. IOLD .LT. 1 .OR. & JOLD .GT. N .OR. JOLD .LT. 1 ) THEN MAPPING( K8 ) = -1 CYCLE END IF IF ( IOLD .eq. JOLD ) THEN ISEND = IOLD JSEND = JOLD ELSE INEW = PERM( IOLD ) JNEW = PERM( JOLD ) IF ( INEW .LT. JNEW ) THEN ISEND = IOLD IF ( KEEP(50) .ne. 0 ) ISEND = -IOLD JSEND = JOLD ELSE ISEND = -JOLD JSEND = IOLD END IF END IF IARR = abs( ISEND ) TYPE_NODE = MUMPS_TYPENODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) + 1 ELSE DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) END IF ELSE IF ( ISEND .LT. 0 ) THEN IPOSROOT = RG2L( JSEND ) JPOSROOT = RG2L( IARR ) ELSE IPOSROOT = RG2L( IARR ) JPOSROOT = RG2L( JSEND ) END IF IROW_GRID = mod( ( IPOSROOT - 1 )/MBLOCK, NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/NBLOCK, NPCOL ) IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = IROW_GRID * NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * NPCOL + JCOL_GRID END IF END IF MAPPING( K8 ) = DEST END DO RETURN END SUBROUTINE CMUMPS_BUILD_MAPPING SUBROUTINE CMUMPS_REDISTRIBUTION( & N, NZ_loc8, id, & DBLARR, LDBLARR, INTARR, LINTARR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & FILS, KEEP,KEEP8, MYID, COMM, NBRECORDS, & & A, LA, root, roota, PROCNODE_STEPS, SLAVEF, PERM, STEP, & ICNTL, INFO, NSEND8, NLOCAL8, & ISTEP_TO_INIV2, CANDIDATES & ) !$ USE OMP_LIB USE CMUMPS_STRUC_DEF, ONLY: CMUMPS_STRUC USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N INTEGER(8) :: NZ_loc8 TYPE (CMUMPS_STRUC) :: id INTEGER(8) :: LDBLARR, LINTARR COMPLEX DBLARR( LDBLARR ) INTEGER INTARR( LINTARR ) INTEGER KEEP(500) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER(8) KEEP8(150) INTEGER, INTENT(IN) :: FILS( N ) 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 (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER PROCNODE_STEPS(KEEP(28)), PERM( N ), STEP( N ) INTEGER INFO( 80 ), ICNTL(60) INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: IERR, MSGSOU INTEGER :: STATUS(MPI_STATUS_SIZE) COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: PTRAW INTEGER END_MSG_2_RECV INTEGER I, J INTEGER(8) :: IS8 INTEGER(8) :: K8 INTEGER :: IARR1, IORG INTEGER TYPE_NODE, DEST, DEST_SHR INTEGER IOLD, JOLD, IARR, ISEND, JSEND INTEGER ISEND_SHR, JSEND_SHR INTEGER allocok, TYPESPLIT, T4MASTER, INIV2, NCAND LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS COMPLEX VAL, VAL_SHR INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, ARROW_ROOT INTEGER IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT, & ILOCROOT, JLOCROOT INTEGER MP,LP INTEGER KPROBE, FREQPROBE INTEGER TAILLE INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFI COMPLEX, ALLOCATABLE, DIMENSION(:,:,:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI COMPLEX, ALLOCATABLE, DIMENSION(:) :: BUFRECR INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, IREQI, IREQR LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE LOGICAL :: FLAG INTEGER(8), INTENT(OUT) :: NSEND8, NLOCAL8 INTEGER MASTER_NODE, ISTEP LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P INTEGER NOMP, NOMP_P, IOMP, P2 NSEND8 = 0_8 NLOCAL8 = 0_8 LP = ICNTL(1) MP = ICNTL(2) END_MSG_2_RECV = SLAVEF ALLOCATE( IACT(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IACT in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQI(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQI in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQR(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQR in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( SEND_ACTIVE(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating SEND_ACTIVE in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = ( NBRECORDS * 2 + 1 ) * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFR( NBRECORDS, 2, SLAVEF), stat = allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating real buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFRECI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS * 2 + 1 GOTO 20 END IF ALLOCATE( BUFRECR( NBRECORDS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS GOTO 20 END IF ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8) * 2_8, INFO(2) ) GOTO 20 END IF ALLOCATE( PTRAW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8) * KEEP(10), INFO(2) ) GOTO 20 END IF 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 100 ARROW_ROOT = 0 DO J = 1, N ISTEP=STEP(J) IF (ISTEP .GT. 0) THEN IARR1 = PTRDEBARR( ISTEP ) IF ( IARR1 .GT. 0 ) THEN I = J IORG = 0 DO WHILE ( I .GT. 0 ) IORG = IORG + 1 IW4(I, 1) = NINCOLARR( IARR1 + IORG - 1 ) IW4(I, 2) = NINROWARR( IARR1 + IORG - 1 ) + & NINCOLARR( IARR1 + IORG - 1 ) IS8 = PTR8ARR( IARR1 + IORG - 1 ) PTRAW( I ) = IS8 INTARR( IS8 ) = I DBLARR( IS8 ) = ZERO I = FILS(I) ENDDO ENDIF ENDIF ENDDO EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL CMUMPS_GET_ROOT_INFO(root,LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL CMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF DO I = 1, SLAVEF BUFI( 1, 1, I ) = 0 END DO DO I = 1, SLAVEF BUFI( 1, 2, I ) = 0 END DO DO I = 1, SLAVEF SEND_ACTIVE( I ) = .FALSE. IACT( I ) = 1 END DO KPROBE = 0 FREQPROBE = max(1,NBRECORDS/10) IF (SLAVEF .EQ. 1) FREQPROBE = huge(FREQPROBE) NOMP = 1 !$ NOMP=omp_get_max_threads() OMP_FLAG = KEEP(399).EQ.1 .AND. NOMP .GE.2 .AND. SLAVEF.EQ.1 !$OMP PARALLEL PRIVATE( K8, I, DEST, TAILLE, !$OMP& T4MASTER, T4_MASTER_CONCERNED, !$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT, !$OMP& ILOCROOT, JLOCROOT, !$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE, !$OMP& IS8, VAL, !$OMP& IARR, ISTEP, ISEND, JSEND, !$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P ) !$OMP& REDUCTION(+:NSEND8, NLOCAL8, ARROW_ROOT) IF (OMP_FLAG) IOMP=0 !$ IOMP=omp_get_thread_num() NOMP_P=1 !$ NOMP_P=omp_get_num_threads() OMP_FLAG_P = .FALSE. !$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1 IF (OMP_FLAG_P) THEN IF ( NOMP_P .GE. 16 ) THEN NOMP_P=16 P2 = 4 ELSE IF (NOMP_P.GE.8) THEN NOMP_P=8 P2 = 3 ELSE IF (NOMP_P.GE.4) THEN NOMP_P=4 P2 = 2 ELSE IF (NOMP_P.GE.2) THEN NOMP_P=2 P2 = 1 ENDIF ELSE NOMP_P = 1 P2 = 0 ENDIF IF ( IOMP .LT. NOMP_P ) THEN DO K8 = 1_8, NZ_loc8 IF ( SLAVEF .GT. 1 ) THEN !$OMP MASTER KPROBE = KPROBE + 1 IF ( KPROBE .eq. FREQPROBE ) THEN KPROBE = 0 CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, & MPI_INTEGER, & MSGSOU, ARR_INT, COMM, STATUS, IERR ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, & MPI_COMPLEX, & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) CALL CMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, & root, roota, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF END IF !$OMP END MASTER ENDIF IOLD = id%IRN_loc(K8) JOLD = id%JCN_loc(K8) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE ENDIF IF (OMP_FLAG_P) THEN IF (IOLD.EQ.JOLD) THEN IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD ELSE IARR = JOLD ENDIF DOIT = ( IOMP .EQ. ibits(IARR, P2-1, P2)) ELSE DOIT = .TRUE. ENDIF IF (DOIT) THEN IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = IOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF ISTEP = abs(STEP(IARR)) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP), KEEP(199) ) T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 VAL = id%A_loc(K8) IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN VAL = VAL * id%ROWSCA(IOLD)*id%COLSCA(JOLD) ENDIF IF ( TYPE_NODE .eq. 1 ) THEN DEST = MASTER_NODE IF (DEST.EQ.MYID) THEN NLOCAL8 = NLOCAL8 + 1_8 IF (ISEND.EQ.JSEND) THEN IS8 = PTRAW(ISEND) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IF (ISEND.GE.0) THEN IS8 = PTRAW(IARR) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL ELSE IS8 = PTRAW(IARR) + IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL CMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF ENDIF CYCLE ENDIF ELSE IF ( TYPE_NODE .eq. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE DEST = MASTER_NODE END IF INIV2 = ISTEP_TO_INIV2(ISTEP) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND < 0 ) THEN IPOSROOT = root%RG2L(JSEND) JPOSROOT = root%RG2L(IARR ) ELSE IPOSROOT = root%RG2L(IARR ) JPOSROOT = root%RG2L(JSEND) END IF IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL ) DEST = IROW_GRID * root%NPCOL + JCOL_GRID ELSE DEST = -2 ENDIF IF ( OMP_FLAG_P ) THEN IF ( EARLYT3ROOTINS ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE IF (ISEND.EQ.JSEND) THEN IS8 = PTRAW(ISEND) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IF (ISEND.GE.0) THEN IS8 = PTRAW(IARR)+IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL ELSE IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL CMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF ENDIF ENDIF CYCLE ENDIF END IF IF (DEST .eq. -1) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .EQ. -2) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .eq.MYID ) THEN NLOCAL8 = NLOCAL8 + 1_8 ELSE NSEND8 = NSEND8 + 1_8 ENDIF ENDIF IF ( DEST.EQ.-1) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79) .GT. 0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) IF (DEST.LT.0) EXIT IF (I.EQ.NCAND+1) CYCLE DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL CMUMPS_DIST_FILL_BUFFER() ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL CMUMPS_DIST_FILL_BUFFER() ENDDO ENDIF DEST=MASTER_NODE DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL CMUMPS_DIST_FILL_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL CMUMPS_DIST_FILL_BUFFER() ENDIF ELSE IF (DEST .GE. 0) THEN DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL CMUMPS_DIST_FILL_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL CMUMPS_DIST_FILL_BUFFER() ENDIF ELSE IF (DEST .EQ. -2) THEN DO I = 0, SLAVEF-1 DEST=I DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL CMUMPS_DIST_FILL_BUFFER() ENDDO ENDIF ENDIF END DO ENDIF !$OMP END PARALLEL DEST_SHR = -3 CALL CMUMPS_DIST_FILL_BUFFER() DO WHILE ( END_MSG_2_RECV .NE. 0 ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, MPI_INTEGER, & MPI_ANY_SOURCE, ARR_INT, COMM, STATUS, IERR ) MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, MPI_COMPLEX, & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) CALL CMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END DO DO I = 1, SLAVEF IF ( SEND_ACTIVE( I ) ) THEN CALL MPI_WAIT( IREQI( I ), STATUS, IERR ) CALL MPI_WAIT( IREQR( I ), STATUS, IERR ) END IF END DO KEEP(49) = ARROW_ROOT 100 CONTINUE IF (ALLOCATED(IW4)) DEALLOCATE( IW4 ) IF (ALLOCATED(PTRAW)) DEALLOCATE( PTRAW ) IF (ALLOCATED(BUFI)) DEALLOCATE( BUFI ) IF (ALLOCATED(BUFR)) DEALLOCATE( BUFR ) IF (ALLOCATED(BUFRECI)) DEALLOCATE( BUFRECI ) IF (ALLOCATED(BUFRECR)) DEALLOCATE( BUFRECR ) IF (ALLOCATED(IACT)) DEALLOCATE( IACT ) IF (ALLOCATED(IREQI)) DEALLOCATE( IREQI ) IF (ALLOCATED(IREQR)) DEALLOCATE( IREQR ) IF (ALLOCATED(SEND_ACTIVE)) DEALLOCATE( SEND_ACTIVE ) RETURN CONTAINS SUBROUTINE CMUMPS_DIST_FILL_BUFFER() IMPLICIT NONE INTEGER ISLAVE, IBEG, IEND, NBREC, IREQ INTEGER TAILLE_SEND_I, TAILLE_SEND_R LOGICAL SEND_LOCAL IF ( DEST_SHR .eq. -3 ) THEN IBEG = 1 IEND = SLAVEF ELSE IBEG = DEST_SHR + 1 IEND = DEST_SHR + 1 END IF SEND_LOCAL = .FALSE. DO ISLAVE = IBEG, IEND NBREC = BUFI(1,IACT(ISLAVE),ISLAVE) IF ( DEST_SHR .eq. -3 ) THEN BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC END IF IF ( DEST_SHR .eq. -3 .or. NBREC + 1 > NBRECORDS ) THEN DO WHILE ( SEND_ACTIVE( ISLAVE ) ) CALL MPI_TEST( IREQR( ISLAVE ), FLAG, STATUS, IERR ) IF ( .NOT. FLAG ) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS(MPI_SOURCE) CALL MPI_RECV( BUFRECI(1), 2*NBRECORDS+1, & MPI_INTEGER, MSGSOU, ARR_INT, COMM, & STATUS, IERR ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, & MPI_COMPLEX, MSGSOU, & ARR_REAL, COMM, STATUS, IERR ) CALL CMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & 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_SHR .ne. -3 ) THEN IREQ = BUFI(1,IACT(ISLAVE),ISLAVE) + 1 BUFI(1,IACT(ISLAVE),ISLAVE) = IREQ BUFI(IREQ*2,IACT(ISLAVE),ISLAVE) = ISEND_SHR BUFI(IREQ*2+1,IACT(ISLAVE),ISLAVE) = JSEND_SHR BUFR(IREQ,IACT(ISLAVE),ISLAVE ) = VAL_SHR END IF END DO IF ( SEND_LOCAL ) THEN ISLAVE = MYID + 1 CALL CMUMPS_DIST_TREAT_RECV_BUF( & BUFI(1,3-IACT(ISLAVE),ISLAVE), & BUFR(1,3-IACT(ISLAVE),ISLAVE), & NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF RETURN END SUBROUTINE CMUMPS_DIST_FILL_BUFFER END SUBROUTINE CMUMPS_REDISTRIBUTION SUBROUTINE CMUMPS_DIST_TREAT_RECV_BUF & ( BUFI, BUFR, NBRECORDS, N, IW4, & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, roota, & PTR_ROOT, A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER NBRECORDS, N, MYID, SLAVEF INTEGER BUFI( NBRECORDS * 2 + 1 ) COMPLEX BUFR( NBRECORDS ) INTEGER IW4( N, 2 ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER END_MSG_2_RECV INTEGER(8), INTENT(IN) :: PTRAW( N ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER :: PERM( N ), STEP( N ) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER INTARR( LINTARR ) INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT, LA COMPLEX A( LA ), DBLARR( LDBLARR ) INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER IREC, NB_REC, NODE_TYPE, IPROC INTEGER IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER(8) :: IS8 INTEGER IARR, JARR INTEGER TAILLE LOGICAL :: EARLYT3ROOTINS COMPLEX VAL EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) NB_REC = BUFI( 1 ) IF ( NB_REC .LE. 0 ) THEN END_MSG_2_RECV = END_MSG_2_RECV - 1 NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) GOTO 100 DO IREC = 1, NB_REC IARR = BUFI( IREC * 2 ) JARR = BUFI( IREC * 2 + 1 ) VAL = BUFR( IREC ) NODE_TYPE = MUMPS_TYPENODE( & PROCNODE_STEPS(abs(STEP(abs( IARR )))), & KEEP(199) ) IF ( NODE_TYPE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JARR ) ELSE IPOSROOT = root%RG2L( JARR ) JPOSROOT = root%RG2L( -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 roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%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 IS8 = PTRAW(IARR) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IS8 = PTRAW(IARR)+IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)), & KEEP(199) ) IF ( IPROC .EQ. MYID ) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL CMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) ENDIF END IF ENDIF ENDDO 100 CONTINUE RETURN END SUBROUTINE CMUMPS_DIST_TREAT_RECV_BUF MUMPS_5.8.1/src/sfac_compact_factors_m.F0000664000175000017500000001302415042446441020017 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_COMPACT_FACTORS_M PRIVATE PUBLIC :: SMUMPS_TRY_COMPACT_FACTORS CONTAINS SUBROUTINE SMUMPS_TRY_COMPACT_FACTORS(ICNTL49_LOC, & WK_USER_PROVIDED, S, KEEP, KEEP8, INFO, MYID, ICNTL, & PROK, MP, SMUMPS_LBUFR_BYTES8, SMUMPS_LBUF8, & LIWK, LIWK8 ) USE OMP_LIB USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_FREE_S_WK C C Purpose C ======= C If no factors stored in S and .NOT.WK_USER_PROVIDED deallocate(S) C If ICNTL49_LOC = 1, 2 try to compress S C Possible values : C 0 : nothing is done. C 1 : compact S while satisfying the C memory constraint that might have been provided C with ICNTL(23) feature. C 2 : compact S. The memory constraint that might have been C provided with ICNTL(23) feature does not apply C C Parameters C ========== INTEGER :: ICNTL49_LOC, MP, MYID REAL, POINTER, DIMENSION(:) :: S INTEGER :: KEEP(500), INFO(80), ICNTL(60) LOGICAL :: PROK, WK_USER_PROVIDED INTEGER(8) :: SMUMPS_LBUFR_BYTES8, SMUMPS_LBUF8 INTEGER(8) :: KEEP8(150) INTEGER(8), INTENT(IN) :: LIWK, LIWK8 C C Local declarations C ================== C LOGICAL :: Compact_S_Authorized INTEGER :: IERR, NOMP REAL, DIMENSION(:), POINTER :: TMPS INTEGER(8) :: TMPpeak, I8 !$ INTEGER(8) :: CHUNK8 IF (.NOT.WK_USER_PROVIDED) THEN C{ IF (KEEP8(31).EQ.0) THEN C{ C No factors stored in S IF (associated(S)) THEN CALL SMUMPS_DM_FREE_S_WK(S, KEEP(430)) C Reset KEEP(430)=0 since next allocations of S C will be from Fotran KEEP(430)=0 NULLIFY(S) KEEP8(23) = 0 ENDIF C} ELSE IF (ICNTL49_LOC.NE.0) THEN C{ Factors stored in S, try to compact S TMPpeak = KEEP8(73) + KEEP8(31) & - (SMUMPS_LBUFR_BYTES8+SMUMPS_LBUF8)/int(KEEP(35),8) & - KEEP8(26) & - ((LIWK+LIWK8*KEEP(10)+KEEP8(27))*int(KEEP(34),8)) & /int(KEEP(35),8) Compact_S_Authorized = .FALSE. C Set Compact_S_Authorized IF (KEEP8(4).GT.0_8) THEN IF (TMPpeak.LT.KEEP8(75)) & Compact_S_Authorized=.TRUE. ELSE Compact_S_Authorized = .TRUE. ENDIF IF (ICNTL49_LOC.EQ.1.AND..NOT.Compact_S_Authorized) THEN C{ INFO(1) = INFO(1) + 4 C INFO(2) = C New value of ICNTL(23) (in MBytes: C ( KEEP8(4) + (TMPpeak- KEEP8(75))*KEEP(35) )/1000000 C + 1 for safety INFO(2) = int( & ( & KEEP8(4) + & (TMPpeak- KEEP8(75))*int(KEEP(35),8) & ) / 1000000_8 + 1_8 & ) C In fact increasing INFO(2) will not help C since increasing ICNTL(23) will also increase C MAXS and thus the peak of memory. C Thus setting ICNTL(23) to INFO(2) might not C enable user to Compact_S. C Simplest is to advice to set ICNTL(49)=2 C or to switch of ICNTL(23) feature. IF (PROK) THEN WRITE(MP,'(A,I4,A,I2,A,/A,/A,A)') & " ** WARNING ** on MPI proc= ", MYID, & " ICNTL(49)= ", ICNTL49_LOC, & ", but not enough memory to compact S due to ", & " memory limitation given by ICNTL(23).", & " ICNTL(23) should be reset to zero or", & " ICNTL(49) should be set to 2 " ENDIF C} ELSE IF ( & (ICNTL49_LOC.EQ.1.AND.Compact_S_Authorized) & .OR. & (ICNTL49_LOC.EQ.2) C{ & ) THEN C Try to compact S of size MAXS ALLOCATE(TMPS(KEEP8(31)), stat=IERR) IF (IERR .GT. 0 ) THEN IF (PROK) THEN WRITE(MP,'(A,I4,A,I3,A)') & " ** WARNING ** on MPI proc= ", MYID, & " ICNTL(49)= ", ICNTL49_LOC, & ", but not enough memory to compact S " ENDIF INFO(1) = INFO(1) + 4 GOTO 513 ENDIF C !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK8=int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF ( KEEP8(31) > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO I8=1_8, KEEP8(31) TMPS(I8) = S(I8) ENDDO !$OMP END PARALLEL DO CALL SMUMPS_DM_FREE_S_WK(S, KEEP(430)) C Reset KEEP(430)=0 since TMPS is allocated C in Fortran and S=>TMPS should be deallocated C in Fortran. KEEP(430)=0 S => TMPS; NULLIFY(TMPS) KEEP8(23) = KEEP8(31) C} ENDIF C} ENDIF C} ENDIF 513 CONTINUE RETURN END SUBROUTINE SMUMPS_TRY_COMPACT_FACTORS END MODULE SMUMPS_FAC_COMPACT_FACTORS_M MUMPS_5.8.1/src/mumps_pord.h0000664000175000017500000000351115042446422015566 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_PORD_H #define MUMPS_PORD_H #include "mumps_common.h" #define MUMPS_PORD_INTSIZE \ F_SYMBOL(pord_intsize,PORD_INTSIZE) void MUMPS_CALL MUMPS_PORD_INTSIZE(MUMPS_INT *pord_intsize); #if defined(pord) #include MUMPS_INT mumps_pord( PORD_INT, PORD_INT, PORD_INT *, PORD_INT *, PORD_INT * ); #define MUMPS_PORDF \ F_SYMBOL(pordf,PORDF) #if defined(INTSIZE64) || defined(PORD_INTSIZE64) void MUMPS_CALL MUMPS_PORDF( MUMPS_INT8 *nvtx, MUMPS_INT8 *nedges, MUMPS_INT8 *xadj, MUMPS_INT8 *adjncy, MUMPS_INT8 *nv, MUMPS_INT *ncmpa ); #else void MUMPS_CALL MUMPS_PORDF( MUMPS_INT *nvtx, MUMPS_INT *nedges, MUMPS_INT *xadj, MUMPS_INT *adjncy, MUMPS_INT *nv, MUMPS_INT *ncmpa ); #endif MUMPS_INT mumps_pord_wnd( PORD_INT, PORD_INT, PORD_INT *, PORD_INT *, PORD_INT *, PORD_INT * ); #define MUMPS_PORDF_WND \ F_SYMBOL(pordf_wnd,PORDF_WND) #if defined(INTSIZE64) || defined(PORD_INTSIZE64) void MUMPS_CALL MUMPS_PORDF_WND( MUMPS_INT8 *nvtx, MUMPS_INT8 *nedges, MUMPS_INT8 *xadj, MUMPS_INT8 *adjncy, MUMPS_INT8 *nv, MUMPS_INT *ncmpa, MUMPS_INT8 *totw ); #else void MUMPS_CALL MUMPS_PORDF_WND( MUMPS_INT *nvtx, MUMPS_INT *nedges, MUMPS_INT *xadj, MUMPS_INT *adjncy, MUMPS_INT *nv, MUMPS_INT *ncmpa, MUMPS_INT *totw ); #endif #endif /*PORD*/ #endif /* MUMPS_PORD_H */ MUMPS_5.8.1/src/cfac_process_blocfacto_LDLT.F0000664000175000017500000015152115042446440020631 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE CMUMPS_PROCESS_SYM_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_OOC, ONLY : IO_BLOCK USE MUMPS_OOC_COMMON, ONLY : TYPEF_L, STRAT_TRY_WRITE USE MUMPS_LOAD USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT USE CMUMPS_BUF, ONLY : CMUMPS_BUF_SEND_BLFAC_SLAVE USE CMUMPS_LR_CORE USE CMUMPS_LR_TYPE USE MUMPS_LR_STATS USE CMUMPS_FAC_LR USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR, & CMUMPS_DM_ALLOC_S_WK, CMUMPS_DM_FREE_S_WK USE CMUMPS_FAC_FRONT_AUX_M, ONLY : CMUMPS_GET_SIZE_SCHUR_IN_FRONT !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) PTRAST(KEEP(28)), PTRFAC(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PERM(N), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)), ND(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) COMPLEX DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PIVI INTEGER (8) POSPV1,POSPV2,OFFDAG,LPOS1 INTEGER J2 COMPLEX MULT1,MULT2, A11, DETPIV, A22, A12 INTEGER :: NFS4FATHER, NVSCHUR_K253, NSLAVES_L, IROW_L REAL, ALLOCATABLE, DIMENSION(:) :: M_ARRAY INTEGER NBROWSinF INTEGER :: BLFAC_NBCOLS_ALREADY_SENT, BLFAC_NBLRB_ALREADY_SENT INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NEWCOL_RECV, JBEG_BLOCK, NCOL_GEMM_FR, & SHIFT_LPOS, SHIFT_UPOS INTEGER :: IFLAG_OOC INTEGER(8) :: POSBLOCFACTO INTEGER :: LD_BLOCFACTO INTEGER(8) :: LA_BLOCFACTO INTEGER(8) :: LA_PTR INTEGER(8) :: POSELT COMPLEX, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, 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 INTEGER(8) :: LUIP21K COMPLEX, DIMENSION(:), POINTER :: UIP21K COMPLEX, DIMENSION(:), ALLOCATABLE :: DYN_BLOCFACTO INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_SLAVES_FOLLOW INTEGER, DIMENSION(:), ALLOCATABLE :: DYN_PIVINFO LOGICAL LASTPANEL LOGICAL LASTBL_INPANEL, LASTBL_INLASTPANEL LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED COMPLEX ONE,ALPHA PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER J LOGICAL COUNTER_WAS_HUGE INTEGER TO_UPDATE_CPT_RECUR INTEGER :: LR_ACTIVATED_INT LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL LOGICAL :: DYNAMIC_ALLOC LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: CURRENT_BLR, NSLAVES_PREC, INFO_TMP(2) INTEGER :: NELIM, NB_BLR_LM, NB_BLR_LS, & MAXI_CLUSTER_LM, MAXI_CLUSTER_LS, MAXI_CLUSTER, & NPARTSASS, NPARTSCB, NPARTSCB_COL, NPARTSASS_COL, & NB_BLR_COL, MAXI_CLUSTER_COL INTEGER :: NPARTSASS_MASTER, IPANEL, NB_ACCESSES_INIT, & NB_ACCESSES_LEFT_INIT TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_LM TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS, & BEGS_BLR_COL, BEGS_BLR_COL_TMP LOGICAL KEEP_BEGS_BLR_LS, KEEP_BEGS_BLR_COL, KEEP_BLR_LS COMPLEX, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR REAL,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, LWORK INTEGER :: II,JJ LOGICAL :: NOTHING_WAS_SENT INTEGER :: KEEP430_LOC INTEGER :: NB, IB, IBEG, IEND !$ INTEGER :: NOMP !$ LOGICAL :: OMP_FLAG INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE KEEP(174)=KEEP(174)+1 KEEP(175)=max(KEEP(174),KEEP(175)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 POSITION = 0 TO_UPDATE_CPT_END = -654321 NULLIFY(UIP21K) 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 ) LASTPANEL = (NPIV.LE.0) IF (LASTPANEL) THEN NPIV = -NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NB_BLOC_FAC, 1, & MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NEWCOL_RECV, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, JBEG_BLOCK, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER, 1, & MPI_INTEGER, COMM, IERR ) NPARTSASS_COL = NPARTSASS_MASTER CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT, 1, & MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) IF (JBEG_BLOCK.EQ.1) THEN NCOL_GEMM_FR = NEWCOL_RECV - NPIV SHIFT_LPOS = NPIV SHIFT_UPOS = NPIV ELSE SHIFT_LPOS = JBEG_BLOCK - 1 IF (LR_ACTIVATED) THEN NCOL_GEMM_FR = -99993 SHIFT_UPOS = -99994 ELSE NCOL_GEMM_FR = NEWCOL_RECV SHIFT_UPOS = 0 ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NSLAVES_TOT, 1, & MPI_INTEGER, COMM, IERR ) KEEP_BEGS_BLR_LS =.FALSE. NULLIFY(BEGS_BLR_LS) KEEP_BEGS_BLR_COL =.FALSE. NULLIFY(BEGS_BLR_COL) KEEP_BLR_LS =.FALSE. NULLIFY(BLR_LS) NULLIFY(BEGS_BLR_LM) IF ( LR_ACTIVATED ) THEN LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8) LD_BLOCFACTO = max(NPIV+NELIM,1) ELSE LA_BLOCFACTO = int(NPIV,8) * int(NEWCOL_RECV,8) LD_BLOCFACTO = max(NEWCOL_RECV,1) ENDIF IF (LR_ACTIVATED) THEN DYNAMIC_ALLOC = .TRUE. ELSE DYNAMIC_ALLOC = .FALSE. ENDIF IF ( .NOT. DYNAMIC_ALLOC ) THEN IF ( NPIV .EQ. 0 ) THEN IPIV = 1 POSBLOCFACTO = 1_8 ELSE CALL CMUMPS_GET_SIZE_NEEDED( & NPIV, LA_BLOCFACTO, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ),COMP,DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LA_BLOCFACTO LRLUS = LRLUS - LA_BLOCFACTO KEEP8(69) = KEEP8(69) + LA_BLOCFACTO KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LA_BLOCFACTO IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ELSE ALLOCATE(DYN_PIVINFO(max(1,NPIV)), & DYN_BLOCFACTO(max(1_8,LA_BLOCFACTO)), & stat=allocok) IF (allocok.GT.0) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR DYN_PIVINFO and DYN_BLOCFACTO IN ", & "CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 CALL MUMPS_SET_IERROR(max(1_8,LA_BLOCFACTO), IERROR) GOTO 700 ENDIF KEEP8(130)=KEEP8(130)+max(1_8,LA_BLOCFACTO) KEEP8(131)=max(KEEP8(130),KEEP8(131)) KEEP8(73) = KEEP8(73) + max(1_8,LA_BLOCFACTO) KEEP8(69) = KEEP8(69) + max(1_8,LA_BLOCFACTO) KEEP8(74) = max(KEEP8(74), KEEP8(73)) KEEP8(68) = max(KEEP8(68), KEEP8(69)) POSBLOCFACTO = 1_8 IPIV = 1 ENDIF IF (NPIV.GT.0) THEN IF (DYNAMIC_ALLOC) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & DYN_PIVINFO, NPIV, & MPI_INTEGER, COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) ENDIF IF (DYNAMIC_ALLOC) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & DYN_BLOCFACTO, int(LA_BLOCFACTO), & MPI_COMPLEX, & COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), int(LA_BLOCFACTO), & MPI_COMPLEX, & COMM, IERR ) ENDIF IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_LM, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_LM(max(NB_BLR_LM,1)), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BLR_LM IN ", & "CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = max(NB_BLR_LM,1) GOTO 700 END IF ALLOCATE(BEGS_BLR_LM(NB_BLR_LM+2), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BEGS_BLR_LM IN ", & "CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NB_BLR_LM+2 GOTO 700 END IF CALL CMUMPS_MPI_UNPACK_LR_PARTIAL( & BUFR, LBUFR, LBUFR_BYTES, POSITION, NPIV, NELIM, & 'V', BLR_LM, NB_BLR_LM, JBEG_BLOCK, & BEGS_BLR_LM(1), KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) THEN CALL CMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 550 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 + KEEP(IXSZ)) .EQ. 0 ) THEN DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 550 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) CALL CMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL CMUMPS_ASM_SLAVE_ARROWHEADS(INODE, STEP(INODE), & N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, & LRGROUPS) ELSE CALL CMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 +KEEP(IXSZ)) NCOL1 = IW( IOLDPS + 3 +KEEP(IXSZ)) + IW( IOLDPS + KEEP(IXSZ)) IF (JBEG_BLOCK.EQ.1) THEN NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) ELSE NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) - NPIV ENDIF LASTBL_INPANEL = JBEG_BLOCK+NEWCOL_RECV.GT.NASS1-NPIV1 LASTBL_INLASTPANEL = LASTPANEL .AND. LASTBL_INPANEL NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) NSLAVES_FOLLOW = NSLAV1 - XTRA_SLAVES_SYM HS = 6 + NSLAV1 + KEEP(IXSZ) IF ( LASTBL_INLASTPANEL ) THEN TO_UPDATE_CPT_END = ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & NB_BLOC_FAC END IF IF (NPIV.GT.0) THEN IF (JBEG_BLOCK.EQ.1) THEN ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1 DO I = 1, NPIV IF (DYNAMIC_ALLOC) THEN PIVI = abs(DYN_PIVINFO(I)) ELSE PIVI = abs(IW(IPIV+I-1)) ENDIF IF (PIVI.EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+PIVI) IW(ICT11+PIVI) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + PIVI - 1,8) CALL cswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO IF (LR_ACTIVATED) THEN LUIP21K = 1_8 ELSE LUIP21K=int(NPIV,8)*int(NROW1,8) ENDIF KEEP430_LOC=min(KEEP(430),1) CALL CMUMPS_DM_ALLOC_S_WK( UIP21K, LUIP21K, allocok, & KEEP430_LOC, KEEP(35) ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NPIV * NROW1 GOTO 700 END IF KEEP8(130)=KEEP8(130)+LUIP21K KEEP8(131)=max(KEEP8(130),KEEP8(131)) KEEP8(73) = KEEP8(73) + LUIP21K KEEP8(69) = KEEP8(69) + LUIP21K KEEP8(74) = max(KEEP8(74), KEEP8(73)) KEEP8(68) = max(KEEP8(68), KEEP8(69)) IF (.NOT.LR_ACTIVATED) THEN ENDIF ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 ) THEN ALLOCATE( LIST_SLAVES_FOLLOW ( NSLAVES_FOLLOW ), & stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR LIST_SLAVES_FOLLOW & IN CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NSLAVES_FOLLOW GOTO 700 END IF LIST_SLAVES_FOLLOW(1:NSLAVES_FOLLOW)= & IW(IOLDPS+6+XTRA_SLAVES_SYM+KEEP(IXSZ): & IOLDPS+5+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_FOLLOW) END IF IF ( (JBEG_BLOCK.EQ.1) .AND. & ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) & ) THEN IF (DYNAMIC_ALLOC) THEN CALL ctrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & DYN_BLOCFACTO, LD_BLOCFACTO, & A_PTR(POSELT+int(NPIV1,8)), NCOL1) ELSE CALL ctrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), LD_BLOCFACTO, & A_PTR(POSELT+int(NPIV1,8)), NCOL1) ENDIF ENDIF IF (JBEG_BLOCK.EQ.1) THEN IF (.NOT.LR_ACTIVATED.OR.KEEP(475).EQ.0) THEN NB = KEEP(360) !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = (NOMP.GT.1.AND. (int(NROW1/NB).GE.NOMP)) !$OMP PARALLEL DO !$OMP& PRIVATE (IB, II, IBEG, IEND, I, J, UPOS, LPOS, DPOS, !$OMP& PIVI, A11, A12, A22, POSPV1, POSPV2, !$OMP& OFFDAG, DETPIV, LPOS1, MULT1, MULT2 !$OMP& ) !$OMP& SCHEDULE(DYNAMIC,1) IF (OMP_FLAG) DO IB=1, NROW1, NB IBEG = IB IEND = min(IB+NB-1, NROW1) IF (.NOT.LR_ACTIVATED) THEN LPOS = POSELT + int(NPIV1,8) UPOS = 1_8 LPOS = LPOS + int((IBEG-1),8)*int(NCOL1,8) UPOS = UPOS + int((IBEG-1),8)*int(NPIV,8) DO II = IBEG, IEND DO J = 0, NPIV-1 UIP21K( UPOS+J ) = A_PTR(LPOS+J) ENDDO LPOS = LPOS + int(NCOL1,8) UPOS = UPOS + int(NPIV,8) END DO ENDIF LPOS = POSELT + int(NPIV1,8) LPOS = LPOS + int((IBEG-1),8)*int(NCOL1,8) IF (DYNAMIC_ALLOC) THEN DPOS = 1_8 ELSE DPOS = POSBLOCFACTO ENDIF I = 1 DO IF(I .GT. NPIV) EXIT IF (DYNAMIC_ALLOC) THEN PIVI = DYN_PIVINFO(I) ELSE PIVI = IW(IPIV+I-1) ENDIF IF(PIVI .GT. 0) THEN IF (DYNAMIC_ALLOC) THEN A11 = ONE/DYN_BLOCFACTO(DPOS) ELSE A11 = ONE/A(DPOS) ENDIF CALL cscal( IEND-IBEG+1, A11, A_PTR(LPOS), NCOL1 ) LPOS = LPOS + 1_8 DPOS = DPOS + int(LD_BLOCFACTO + 1,8) I = I+1 ELSE POSPV1 = DPOS POSPV2 = DPOS+ int(LD_BLOCFACTO + 1,8) OFFDAG = POSPV1+1_8 IF (DYNAMIC_ALLOC) THEN A11 = DYN_BLOCFACTO(POSPV1) A22 = DYN_BLOCFACTO(POSPV2) A12 = DYN_BLOCFACTO(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = DYN_BLOCFACTO(POSPV2)/DETPIV A12 = -A12/DETPIV ELSE A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV ENDIF LPOS1 = LPOS DO J2 = 1, IEND-IBEG+1 MULT1 = A11*A_PTR(LPOS1)+A12*A_PTR(LPOS1+1_8) MULT2 = A12*A_PTR(LPOS1)+A22*A_PTR(LPOS1+1_8) A_PTR(LPOS1) = MULT1 A_PTR(LPOS1+1_8) = MULT2 LPOS1 = LPOS1 + int(NCOL1,8) ENDDO LPOS = LPOS + 2_8 DPOS = POSPV2 + int(LD_BLOCFACTO + 1,8) I = I+2 ENDIF ENDDO ENDDO !$OMP END PARALLEL DO ENDIF ENDIF ENDIF COMPRESS_CB = .FALSE. IF ( LR_ACTIVATED ) THEN NSLAVES_PREC = NSLAVES_TOT - NSLAVES_FOLLOW -1 COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) ENDIF IF (NROW1.GT.0) THEN IF (NPIV.GT.0.AND.NROW1.LE.0) THEN CALL MUMPS_ABORT() ENDIF IF (LR_ACTIVATED) THEN IF (NPIV1.NE.0.OR.JBEG_BLOCK.NE.1) THEN CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_LS) KEEP_BEGS_BLR_LS = .TRUE. NB_BLR_LS = size(BEGS_BLR_LS) - 2 NPARTSCB = NB_BLR_LS ELSE CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) CALL REGROUPING2(BEGS_BLR_LS, NPARTSASS, NASS1, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472), & NCOL1, KEEP(1)) NB_BLR_LS = NPARTSCB ENDIF IF (NPIV.GT.0) THEN call MAX_CLUSTER(BEGS_BLR_LM(2:NB_BLR_LM+2),NB_BLR_LM, & MAXI_CLUSTER_LM) ELSE MAXI_CLUSTER_LM = 0 ENDIF call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) MAXI_CLUSTER=max(MAXI_CLUSTER_LS,MAXI_CLUSTER_LM,NPIV) IF (COMPRESS_CB) THEN IF (NPIV1.EQ.0.AND.JBEG_BLOCK.EQ.1) THEN CALL GET_CUT(IW(IOLDPS+HS+NROW1:IOLDPS+HS+NROW1+NCOL1-1), & NASS1, & NCOL1-NASS1, LRGROUPS, NPARTSCB_COL, & NPARTSASS_COL, BEGS_BLR_COL) CALL REGROUPING2(BEGS_BLR_COL, NPARTSASS_COL, NASS1, & NPARTSCB_COL, & NCOL1-NASS1, KEEP(488), .FALSE., KEEP(472), & NCOL1, KEEP(1)) NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL IF (NPARTSASS_MASTER.NE.NPARTSASS_COL) THEN ALLOCATE(BEGS_BLR_COL_TMP( & size(BEGS_BLR_COL)-NPARTSASS_COL+NPARTSASS_MASTER), & stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BEGS_BLR_COL_TMP in", & "CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = size(BEGS_BLR_COL) & -NPARTSASS_COL+NPARTSASS_MASTER GOTO 700 END IF IF ( size(BEGS_BLR_COL).GT. NPARTSASS_COL) THEN DO II=1, size(BEGS_BLR_COL) - NPARTSASS_COL BEGS_BLR_COL_TMP (II+NPARTSASS_MASTER) = & BEGS_BLR_COL(II+NPARTSASS_COL) ENDDO ENDIF DO II= 1, NPARTSASS_MASTER BEGS_BLR_COL_TMP (II) = & BEGS_BLR_COL(max(NPARTSASS_COL,1)+1) ENDDO DEALLOCATE(BEGS_BLR_COL) BEGS_BLR_COL => BEGS_BLR_COL_TMP NPARTSASS_COL = NPARTSASS_MASTER NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL ENDIF ELSE CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_COL ) KEEP_BEGS_BLR_COL = .TRUE. NB_BLR_COL = size(BEGS_BLR_COL) - 1 NPARTSCB_COL = NB_BLR_COL - NPARTSASS_COL ENDIF ELSE NULLIFY(BEGS_BLR_COL) ENDIF IF (NPIV1.EQ.0.AND.(JBEG_BLOCK.EQ.1)) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR NB_ACCESSES_INIT = 1 IF ( (KEEP(486).EQ.2) & ) THEN NB_ACCESSES_INIT = huge(NPARTSASS_MASTER) END IF INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 700 CALL CMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .TRUE., & .TRUE., & NPARTSASS_COL, & BEGS_BLR_LS, BEGS_BLR_COL, NB_ACCESSES_INIT, & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 700 ENDIF LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF CURRENT_BLR = 1 IF (JBEG_BLOCK.EQ.1.AND.NPIV.GT.0) THEN CURRENT_BLR = 1 ALLOCATE(BLR_LS(NB_BLR_LS), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_LS GOTO 700 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL CMUMPS_COMPRESS_PANEL_I_NOOPT & (A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & DKEEP(8), KEEP(466), 0, & KEEP(473), BLR_LS(1), & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP8, & OMP_NUM) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 300 IF (KEEP(475).GE.1) THEN IF (DYNAMIC_ALLOC) THEN CALL CMUMPS_BLR_PANEL_LRTRSM( & DYN_BLOCFACTO, LA_BLOCFACTO, 1_8, & LD_BLOCFACTO, -6666, & NB_BLR_LS+1, & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1, & 2, 1, 0, & .TRUE., & DYN_PIVINFO, OFFSET_IW=1) ELSE CALL CMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, & LD_BLOCFACTO, -6666, & NB_BLR_LS+1, & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1, & 2, 1, 0, & .TRUE., & IW, OFFSET_IW=IPIV) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (KEEP(486).NE.2) THEN CALL CMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A_PTR(POSELT), LA_PTR, 1_8, & NCOL1, NCOL1, & .TRUE., & NPIV1+1, & 1, & NB_BLR_LS+1, BLR_LS(1), CURRENT_BLR, 'V', 1) ENDIF ENDIF 300 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & (OOCWRITE_COMPATIBLE_WITH_BLR .OR. NPIV.EQ.0) & .AND. (JBEG_BLOCK.EQ.1) & ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTPANEL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) LAST_CALL = .FALSE. CALL CMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L, & A_PTR(POSELT), & LA_PTR, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG_OOC, LAST_CALL) IF ( IFLAG_OOC .LT. 0 )THEN IFLAG = IFLAG_OOC GOTO 700 ENDIF ENDIF IF (NPIV.GT.0) THEN IF (LR_ACTIVATED) THEN IF (JBEG_BLOCK.NE.1) THEN CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_LS) KEEP_BLR_LS = .TRUE. ENDIF IF (NELIM.GT.0.AND.JBEG_BLOCK.EQ.1) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = 1_8+int(SHIFT_UPOS,8) LPOS = LPOS2 + int(SHIFT_LPOS,8) IF (DYNAMIC_ALLOC) THEN CALL CMUMPS_BLR_UPD_NELIM_VAR_L_I( & DYN_BLOCFACTO, LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1, & CURRENT_BLR+1, NELIM, 'N') ELSE CALL CMUMPS_BLR_UPD_NELIM_VAR_L_I( & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1, & CURRENT_BLR+1, NELIM, 'N') ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif IF (DYNAMIC_ALLOC) THEN CALL CMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, NROW1, JBEG_BLOCK, & DYN_BLOCFACTO, LA_BLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1, & BLR_LM(1), NPIV1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & BLR_LS(1), 0, & CURRENT_BLR, CURRENT_BLR, & DYN_PIVINFO, & BLOCKLR, & MAXI_CLUSTER, OMP_NUM, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ELSE CALL CMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, NROW1, JBEG_BLOCK, & A(POSBLOCFACTO), LA_BLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1, & BLR_LM(1), NPIV1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & BLR_LS(1), 0, & CURRENT_BLR, CURRENT_BLR, & IW(IPIV), & BLOCKLR, & MAXI_CLUSTER, OMP_NUM, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF IF (IFLAG.LT.0) GOTO 400 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 CALL UPD_MRY_LU_LRGAIN(BLR_LS, NPARTSCB & ) CALL DEALLOC_BLR_PANEL(BLR_LM, NB_BLR_LM, KEEP8, KEEP(34)) DEALLOCATE(BLR_LM) IF ( JBEG_BLOCK.EQ.1 & ) & THEN IF ( (KEEP(486).EQ.2) & ) THEN NB_ACCESSES_LEFT_INIT = huge(NB_ACCESSES_LEFT_INIT) ELSE NB_ACCESSES_LEFT_INIT = NCOL1 - NPIV1 - NROW1 ENDIF CALL CMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_LS, NB_ACCESSES_LEFT_INIT) KEEP_BLR_LS = .TRUE. ENDIF ELSE IF (NPIV .GT. 0 .AND. NCOL_GEMM_FR.GT.0)THEN LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(SHIFT_LPOS,8) IF (DYNAMIC_ALLOC) THEN UPOS = 1_8+int(SHIFT_UPOS,8) CALL cgemm('N','N', NCOL_GEMM_FR, NROW1, NPIV, & ALPHA, DYN_BLOCFACTO(UPOS), NEWCOL_RECV, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ELSE UPOS = POSBLOCFACTO+int(SHIFT_UPOS,8) CALL cgemm('N','N', NCOL_GEMM_FR, NROW1, NPIV, & ALPHA,A(UPOS), NEWCOL_RECV, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ENDIF ENDIF IF (JBEG_BLOCK.EQ.1) THEN DPOS = POSELT + int(NCOL1 - NROW1,8) #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1 .OR. & ( KEEP(421) .GT. 0 .AND. NROW1 .GT. KEEP(421) ) ) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = 1_8 CALL cgemmt( 'U', 'T', 'N', NROW1, NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A_PTR( LPOS2 ), NCOL1, ONE, & A_PTR( DPOS ), NCOL1 ) ELSE #endif IF ( NROW1 .GT. KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NROW1 ENDIF IF ( NROW1 .GT. 0 ) THEN DO IROW = 1, NROW1, BLSIZE Block = min( BLSIZE, NROW1 - IROW + 1 ) DPOS = POSELT + int(NCOL1 - NROW1,8) & + int( IROW - 1, 8 ) * int( NCOL1 + 1, 8 ) LPOS2 = POSELT + int(NPIV1,8) & + int( IROW - 1, 8 ) * int( NCOL1, 8 ) UPOS = int( IROW - 1, 8 ) * int(NPIV, 8) + 1_8 DO I = 1, Block CALL cgemv( 'T', NPIV, Block-I+1, ALPHA, & A_PTR( LPOS2 + int(I - 1,8) * int(NCOL1,8) ), NCOL1, & UIP21K( UPOS + int(NPIV,8) * int( I - 1, 8 ) ), & 1, ONE, A_PTR(DPOS+int(NCOL1+1,8)*int(I-1,8)),NCOL1 ) END DO IF ( NROW1-IROW+1-Block .ne. 0 ) & CALL cgemm( 'T', 'N', Block, NROW1-IROW+1-Block, & NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A_PTR( LPOS2 + int(Block,8) * int(NCOL1,8) ), NCOL1, & ONE, & A_PTR( DPOS + int(Block,8) * int(NCOL1,8) ), NCOL1 ) ENDDO ENDIF #if defined(GEMMT_AVAILABLE) ENDIF #endif ENDIF ENDIF IF (LASTBL_INPANEL) THEN FLOP1 = dble(NROW1) * dble(NPIV) * & dble( 2 * (NASS1-NPIV1) - NPIV + NROW1 +1 ) FLOP1 = -FLOP1 CALL MUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF ENDIF IF (JBEG_BLOCK.EQ.1) THEN IW(IOLDPS+KEEP(IXSZ)) = IW(IOLDPS+KEEP(IXSZ)) - NPIV IW(IOLDPS+3+KEEP(IXSZ)) = IW(IOLDPS+3+KEEP(IXSZ)) + NPIV ENDIF IF (LASTBL_INLASTPANEL) THEN IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+3+KEEP(IXSZ)) ENDIF IF ( .NOT. LR_ACTIVATED ) THEN IF (DYNAMIC_ALLOC) THEN IF (allocated(DYN_PIVINFO) ) DEALLOCATE(DYN_PIVINFO) IF (allocated(DYN_BLOCFACTO)) THEN KEEP8(130) = KEEP8(130)-max(1_8,LA_BLOCFACTO) DEALLOCATE(DYN_BLOCFACTO) KEEP8(69) = KEEP8(69) - max(1_8,LA_BLOCFACTO) KEEP8(73) = KEEP8(73) - max(1_8,LA_BLOCFACTO) ENDIF ELSE LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO IWPOS = IWPOS - NPIV CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 & .AND. JBEG_BLOCK.EQ.1 ) THEN IPOSK = NPIV1 + 1 JPOSK = NCOL1 - NROW1 + 1 NPIVSENT = NPIV BLFAC_NBCOLS_ALREADY_SENT = 0 BLFAC_NBLRB_ALREADY_SENT = 0 IERR = -1 DO WHILE ( IERR .eq. -1 ) IF (DYNAMIC_ALLOC) THEN CALL CMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, LUIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & BLFAC_NBCOLS_ALREADY_SENT, BLFAC_NBLRB_ALREADY_SENT, & NOTHING_WAS_SENT, & DYN_BLOCFACTO, LA_BLOCFACTO, & 1_8, LD_BLOCFACTO, & DYN_PIVINFO, MAXI_CLUSTER, & IERR, IERROR ) ELSE CALL CMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, LUIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & BLFAC_NBCOLS_ALREADY_SENT, BLFAC_NBLRB_ALREADY_SENT, & NOTHING_WAS_SENT, & A, LA, & POSBLOCFACTO, LD_BLOCFACTO, & IW(IPIV), MAXI_CLUSTER, & IERR, IERROR ) ENDIF IF (IERR.EQ.-13) THEN IFLAG = IERR IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE within CMUMPS_BUF_SEND_BLFAC_SLAVE", & " during CMUMPS_PROCESS_SYM_BLOCFACTO", IERROR GOTO 700 ENDIF IF (IERR .EQ. -1 .AND. NOTHING_WAS_SENT) THEN IOLDPS = PTRIST(STEP(INODE)) IF ( IW(IOLDPS+6+KEEP(IXSZ)) .eq. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN COUNTER_WAS_HUGE=.TRUE. IW(IOLDPS+6+KEEP(IXSZ)) = 1 ELSE COUNTER_WAS_HUGE=.FALSE. ENDIF TO_UPDATE_CPT_RECUR = & ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & (2*NASS1/KEEP(6)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) - TO_UPDATE_CPT_RECUR - 10 BLOCKING = .FALSE. SET_IRECV= .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + TO_UPDATE_CPT_RECUR + 10 IF ( COUNTER_WAS_HUGE .AND. & IW(IOLDPS+6+KEEP(IXSZ)).EQ.1 ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = huge(IW(IOLDPS+6+KEEP(IXSZ))) ENDIF IF ( IFLAG .LT. 0 ) GOTO 550 END IF END DO IF ( IERR .eq. -2 ) THEN IF (LP > 0 ) THEN WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING & CMUMPS_PROCESS_SYM_BLOCFACTO" ENDIF IFLAG = -17 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF IF ( IERR .eq. -3 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING & CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -20 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF DEALLOCATE(LIST_SLAVES_FOLLOW) END IF IF ( LR_ACTIVATED ) THEN IF (NPIV.GT.0 & .AND. KEEP(486).EQ.3 & ) THEN IOLDPS = PTRIST(STEP(INODE)) CALL CMUMPS_BLR_DEC_AND_TRYFREE_L(IW(IOLDPS+XXF),IPANEL, & KEEP8, KEEP(34), NEWCOL_RECV) ENDIF IF (DYNAMIC_ALLOC) THEN IF (allocated(DYN_PIVINFO)) DEALLOCATE(DYN_PIVINFO) IF (allocated(DYN_BLOCFACTO)) THEN KEEP8(130) = KEEP8(130)-max(1_8,LA_BLOCFACTO) DEALLOCATE(DYN_BLOCFACTO) ENDIF ELSE IF (NPIV .GT. 0) THEN LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO IWPOS = IWPOS - NPIV CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF ( NPIV .NE. 0 ) THEN IF (associated(UIP21K)) THEN CALL CMUMPS_DM_FREE_S_WK( UIP21K, KEEP430_LOC ) NULLIFY( UIP21K ) KEEP8(130) = KEEP8(130)-LUIP21K KEEP8(69) = KEEP8(69) - LUIP21K KEEP8(73) = KEEP8(73) - LUIP21K ENDIF ENDIF IOLDPS = PTRIST(STEP(INODE)) IF (LR_ACTIVATED ) THEN COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) ENDIF CALL CMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) IF (LASTBL_INLASTPANEL) THEN IF ( KEEP(486) .NE. 0) THEN IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = IW(IOLDPS+6+KEEP(IXSZ)) & - TO_UPDATE_CPT_END & - 1 END IF IF ( IW(IOLDPS+6+KEEP(IXSZ) ) .eq. 0 & .and. KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 & .and. NSLAVES_TOT.NE.1 ) THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) CALL MUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_SYM_BLOCFACTO.' IFLAG = -99 GOTO 700 END IF ENDIF IF (IW(IOLDPS+6+KEEP(IXSZ)) .eq. 0 & ) THEN IOLDPS = PTRIST(STEP(INODE)) NELIM = IW( IOLDPS + 4 + KEEP(IXSZ)) - & IW( IOLDPS + 3 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) IF (LR_ACTIVATED) THEN IF (COMPRESS_CB) THEN allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_COL), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_COL) GOTO 700 ENDIF DO II=1,NB_BLR_LS DO JJ=1,NB_BLR_COL-NPARTSASS_COL CB_LRB(II,JJ)%M=0 CB_LRB(II,JJ)%N=0 NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL CMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL CMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) NFS4FATHER = max(NFS4FATHER,0) + NELIM ENDIF ALLOCATE(M_ARRAY(max(1,NFS4FATHER)), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR M_ARRAY ", & "CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = max(1,NFS4FATHER) ENDIF BEGS_BLR_COL(1+NPARTSASS_COL) = & BEGS_BLR_COL(1+NPARTSASS_COL) - NELIM CALL MAX_CLUSTER( & BEGS_BLR_COL(max(NPARTSASS_MASTER,1)+1:NB_BLR_COL+1), & NB_BLR_COL-max(NPARTSASS_MASTER,1),MAXI_CLUSTER_COL & ) MAXI_CLUSTER=max(MAXI_CLUSTER_LS, MAXI_CLUSTER_COL) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF NBROWSinF = 0 NVSCHUR_K253 = 0 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN CALL CMUMPS_COMPUTE_NBROWSinF ( & N, INODE, FPERE, KEEP, & IOLDPS, HS, & IW, LIW, & NROW1, NCOL1, NPIV1, & NELIM, NFS4FATHER, & NBROWSinF & ) IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) ) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL CMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR_K253 ) ELSE IF (KEEP(253).NE.0) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL CMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & 0, & IW(IROW_L), & PERM, NVSCHUR_K253 ) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 700 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL CMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_LS, NB_BLR_COL-NPARTSASS_COL, & NPARTSASS_COL, & NROW1, NCOL1-NPIV1, INODE, & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV1, NVSCHUR_K253, KEEP(1), & M_ARRAY & , NELIM, NBROWSinF & ) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 650 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL CMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF DEALLOCATE(M_ARRAY) 650 CONTINUE ENDIF IF (IFLAG.LT.0) GOTO 700 ENDIF CALL CMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, roota, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF GOTO 550 700 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 550 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (.NOT.KEEP_BEGS_BLR_LS) THEN IF (associated(BEGS_BLR_LS)) DEALLOCATE(BEGS_BLR_LS) ENDIF IF (.NOT.KEEP_BLR_LS) THEN IF (associated(BLR_LS)) THEN CALL DEALLOC_BLR_PANEL(BLR_LS, NB_BLR_LS, KEEP8, KEEP(34)) DEALLOCATE(BLR_LS) ENDIF ENDIF IF (associated(BEGS_BLR_LM)) DEALLOCATE(BEGS_BLR_LM) IF (.NOT.KEEP_BEGS_BLR_COL) THEN IF (COMPRESS_CB) THEN IF (associated(BEGS_BLR_COL)) THEN DEALLOCATE( BEGS_BLR_COL) ENDIF ENDIF ENDIF ENDIF KEEP(174)=KEEP(174)-1 RETURN END SUBROUTINE CMUMPS_PROCESS_SYM_BLOCFACTO MUMPS_5.8.1/src/cfac_asm_master_ELT_m.F0000664000175000017500000021470615042446440017500 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC_ASM_MASTER_ELT_M CONTAINS SUBROUTINE CMUMPS_FAC_ASM_NIV1_ELT( COMM_LOAD, ASS_IRECV, & UU, NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, INFO, ND, & FILS, FRERE, DAD, MAXFRW, root, roota, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, LRLUSM, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & , MUMPS_TPS_ARR, CMUMPS_TPS_ARR, L0_OMP_MAPPING & ) !$ USE OMP_LIB USE MUMPS_TPS_M USE CMUMPS_TPS_M USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_PTR, & CMUMPS_DM_FREE_BLOCK USE MUMPS_BUILD_SORT_INDEX_ELT_M USE MUMPS_BUF_COMMON, ONLY: MUMPS_BUF_SEND_MAPLIG USE MUMPS_LOAD USE CMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE, & CMUMPS_BLR_ASM_NIV1 USE CMUMPS_LR_DATA_M, ONLY : CMUMPS_BLR_INIT_FRONT, & CMUMPS_BLR_SAVE_NFS4FATHER USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N, NSTEPS INTEGER NELT INTEGER(8) LA, LRLU, LRLUS, LRLUSM, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) REAL UU INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS, LIW TYPE (MUMPS_TPS_T), TARGET, OPTIONAL :: MUMPS_TPS_ARR(:) TYPE (CMUMPS_TPS_T), TARGET, OPTIONAL :: CMUMPS_TPS_ARR(:) INTEGER, INTENT(IN), OPTIONAL :: L0_OMP_MAPPING(:) INTEGER IDUMMY(1) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER, TARGET :: IW(LIW) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ITLOC(N+KEEP(253)), & ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)), & PAMASTER(KEEP(28)) INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER ETATASS LOGICAL SON_LEVEL2 COMPLEX, TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR COMPLEX DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) LOGICAL PACKED_CB, IS_CB_LR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF LOGICAL LPOK INTEGER NBPANELS_L, NBPANELS_U INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER PARPIV_T1 INTEGER(8) NFRONT8, LAELL8, KEEP8TMPCOPY INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER LREQ_OOC INTEGER :: SON_XXS, SON_XXLR, SON_XXG INTEGER(8) LSTK8, SIZFR8 LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM, IORG, IBROT INTEGER :: J253 #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER(8) APOS, APOS2, LAPOS2 INTEGER(8) POSELT, POSEL1, ICT12, ICT21 INTEGER(8) IACHK INTEGER(8) JJ2 INTEGER(8) :: JJ8, J18, J28 INTEGER(8) :: AINPUT8, AII8 INTEGER :: K1, K2, K3, KK, KK1 INTEGER JPOS,ICT11, IJROW INTEGER Pos_First_NUMORG,NUMORG,IOLDPS, & NUMELT, ELBEG INTEGER :: J INTEGER NSLAVES, NSLSON, NPIVS, NPIV_ANA, NPIV INTEGER PTRCOL, ISLAVE, PDEST,LEVEL LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER ELTI INTEGER(8) :: SIZE_ELTI8 INTEGER(8) :: II8 INTEGER :: I LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: ITHREAD INTEGER, POINTER :: SON_IWPOS, SON_LIW INTEGER, POINTER, DIMENSION(:) :: SON_IW COMPLEX, POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTEGER PIVOT_OPTION COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) LOGICAL MUMPS_INSSARBR, SSARBR EXTERNAL MUMPS_INSSARBR DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR !$ NOMP = OMP_GET_MAX_THREADS() LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) NFS4FATHER = -1 ETATASS = 0 PACKED_CB = .FALSE. IS_CB_LR = .FALSE. IN = INODE LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (LEVEL.NE.1) THEN WRITE(*,*) 'INTERNAL ERROR 1 in CMUMPS_FAC_ASM_NIV1_ELT ' CALL MUMPS_ABORT() END IF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) NUMELT = FRT_PTR(INODE+1) - FRT_PTR(INODE) IF ( NUMELT .ne. 0 ) THEN ELBEG = FRT_PTR(INODE) ELSE ELBEG = 1 END IF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) END DO NPIV_ANA=NUMORG NSTEPS = NSTEPS + 1 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 SON_IW => IW IF (KEEP(400).GT.0) THEN IF (present(L0_OMP_MAPPING)) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .NE.0) THEN SON_IW=>MUMPS_TPS_ARR(ITHREAD)%IW ENDIF ENDIF ENDIF NASS = NASS + SON_IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG CALL IS_FRONT_BLR_CANDIDATE(INODE, 1, ND(STEP(INODE)), & NUMORG, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, KEEP(280), LRGROUPS) IF (DAD(STEP(INODE)).NE.0) THEN IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199) ) & .NE. MYID & .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199)) & .EQ.1 & ) THEN IF (LRSTATUS.EQ.1 .OR. LRSTATUS.EQ.3) THEN LRSTATUS = LRSTATUS-1 ENDIF ENDIF ENDIF COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_OOC_GET_PP_SIZES(KEEP(50), NFRONT, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL CMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, SLAVEF, & PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress CMUMPS_FAC_ASM_NIV1_ELT' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 END IF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 END IF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .TRUE. IF (.NOT. present(MUMPS_TPS_ARR).AND. & .NOT. present(L0_OMP_MAPPING) ) THEN CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & IDUMMY, LIDUMMY ) ELSE CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & IDUMMY, LIDUMMY & , MUMPS_TPS_ARR, L0_OMP_MAPPING ) ENDIF IF (INFO(1).LT.0) GOTO 300 IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL MUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1-FLOP1_EFF, & KEEP,KEEP8) ENDIF IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) & ' ERROR 1 during ass_niv1_ELT', NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF NCB = NFRONT - NASS1 MAXFRW = max(MAXFRW, NFRONT) ICT11 = IOLDPS + HF - 1 + NFRONT CALL CMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) PIVOT_OPTION = KEEP(468) IF (UU.EQ.ZERO) THEN PIVOT_OPTION=0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF(PARPIV_T1.NE.0) THEN LAELL8 = LAELL8+int(NASS1,8) ENDIF CALL CMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 LRLUSM = min( LRLUS, LRLUSM ) IF (KEEP(405).EQ.0) THEN KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + LAELL8 KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ENDIF POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8, & KEEP,KEEP8, & LRLUS) IF (KEEP(405).EQ.0) KEEP(429)= KEEP(429)+1 #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8=int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (LAPOS2 - POSELT + 1_8 > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8), KEEP(218))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & NCB, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1,TOPDIAG) ENDIF NUMROWS = NFRONT8 !$ CHUNK = max(KEEP(360)/2, !$ & ( ((int(NUMROWS)+NOMP-1) / NOMP + 2) / 3) ) #if defined(__ve__) !NEC$ IVDEP #endif !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK ) !$OMP& IF (int(NUMROWS - 1) .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = POSELT + JJ8 * NFRONT8 JJ3 = min( NFRONT8 - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS + JJ3) = ZERO ENDDO !$OMP END PARALLEL DO END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS IW(IOLDPS + KEEP(IXSZ)) = NFRONT IW(IOLDPS + KEEP(IXSZ)+ 1) = 0 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN CALL CMUMPS_BLR_INIT_FRONT (IW(IOLDPS+XXF), INFO, & MTK405=KEEP(405)) IF (INFO(1).LT.0) GOTO 500 ENDIF ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL CMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) CALL CMUMPS_BLR_SAVE_NFS4FATHER ( IW(IOLDPS+XXF), & ESTIM_NFS4FATHER_ATSON ) ENDIF ENDIF ENDIF IF (NUMSTK.NE.0) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_LIW => LIW SON_IWPOS => IWPOS SON_A => A ITHREAD = 0 IF (KEEP(400).GT.0) THEN IF (present(L0_OMP_MAPPING)) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .NE.0) THEN SON_LIW => MUMPS_TPS_ARR(ITHREAD)%LIW SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW SON_IWPOS => MUMPS_TPS_ARR(ITHREAD)%IWPOS SON_A => CMUMPS_TPS_ARR(ITHREAD)%A ENDIF ENDIF ENDIF LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + KEEP(IXSZ) + 1) NPIVS = SON_IW(ISTCHK + KEEP(IXSZ) + 3) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = SON_IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.SON_IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT = PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT = ISTCHK ENDIF SON_XXS = SON_IW(ISTCHK_CB_RIGHT+XXS) SON_XXLR = SON_IW(ISTCHK_CB_RIGHT+XXLR) SON_XXG = SON_IW(ISTCHK_CB_RIGHT+XXG) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IS_CB_LR = ( SON_XXLR.EQ.1 .OR. SON_XXLR.EQ.3 ) & .AND. (KEEP(489).EQ.1.OR.KEEP(489).EQ.3) LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = SON_IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF K1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN K2 = K1 + LSTK - 1 IF (PACKED_CB) THEN SIZFR8 = (LSTK8*(LSTK8+1_8)/2_8) ELSE SIZFR8 = LSTK8*LSTK8 ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * LSTK8 ELSE IF (PACKED_CB) THEN SIZFR8 = int(NELIM,8) * int(NELIM+1,8)/2_8 ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) ENDIF END IF K2 = K1 + NELIM - 1 ENDIF IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + LSTK8*LSTK8 ELSE OPASSW = OPASSW + LSTK8*(LSTK8+1)/2_8 ENDIF ELSE IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + int(NELIM,8)*LSTK8 ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM,8)/2_8 ENDIF ENDIF CALL MUMPS_GETI8(DYN_SIZE, SON_IW(ISTCHK_CB_RIGHT+XXD)) IS_DYNAMIC_CB = DYN_SIZE .GT. 0_8 IF ( IS_DYNAMIC_CB ) THEN CALL CMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) ENDIF IF (IS_CB_LR .AND. LEVEL1) THEN POSEL1 = PTRAST(STEP(INODE)) CALL CMUMPS_BLR_ASM_NIV1 (A, LA, & POSEL1, NFRONT, NASS1, SON_IW(ISTCHK+XXF), & SON_IW, SON_LIW, & LSTK, NELIM, K1, K1+LSTK-1, KEEP(50), & KEEP, KEEP8, OPASSW) ENDIF IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (K2.GE.K1) THEN #if defined(__ve__) !NEC$ IVDEP #endif DO 170 KK = K1, K2 APOS = POSEL1 + int(SON_IW(KK),8) * NFRONT8 #if defined(__ve__) !NEC$ IVDEP #endif DO 160 KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1 + KK1 - 1) - 1,8) A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + LSTK8 170 CONTINUE END IF ELSE IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (SIZFR8 .GT. 0) THEN CALL CMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF (SAME_PROC) THEN IF (KEEP(50).NE.0) THEN K2 = K1 + LSTK - 1 #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K1, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO ELSE K2 = K1 + LSTK - 1 K3 = K1 + NELIM #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K3, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO IF (NELIM .NE. 0) THEN K3 = K3 - 1 #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K1, K3 JPOS = SON_IW(KK) + ICT11 SON_IW(KK) = IW(JPOS) ENDDO ENDIF ENDIF ENDIF IF ( SAME_PROC ) THEN PTRIST(STEP(ISON)) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF IF (ITHREAD .EQ. 0) THEN CALL CMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & .FALSE. & ) ELSE CALL MUMPS_LOAD_DISABLE() CALL CMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & MUMPS_TPS_ARR(ITHREAD)%IW(1), & MUMPS_TPS_ARR(ITHREAD)%LIW, & MUMPS_TPS_ARR(ITHREAD)%LRLU, & MUMPS_TPS_ARR(ITHREAD)%LRLUS, & MUMPS_TPS_ARR(ITHREAD)%IPTRLU, & MUMPS_TPS_ARR(ITHREAD)%IWPOSCB, & MUMPS_TPS_ARR(ITHREAD)%LA, KEEP,KEEP8, .FALSE. & ) CALL MUMPS_LOAD_ENABLE() ENDIF IF (IS_DYNAMIC_CB) THEN CALL CMUMPS_DM_FREE_BLOCK(SON_XXG, & SON_A, SIZFR8, & KEEP(405).EQ.1, KEEP8 ) ENDIF ELSE PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP, KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL CMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, IDUMMY, & NFRONT, NASS1, NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & IZERO, IDUMMY, IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP, KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE., LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF END DO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) 220 CONTINUE END IF DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = INTARR(II8) IF (KEEP(50).EQ.0) THEN AINPUT8 = AII8 + II8 - J18 ICT12 = POSELT + int(I-1,8) * NFRONT8 DO JJ8=J18,J28 APOS2 = ICT12 + int(INTARR(JJ8) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ELSE ICT12 = POSELT + int(- NFRONT + I - 1,8) ICT21 = POSELT + int(I-1,8)*NFRONT8 - 1_8 DO JJ8=II8,J28 J = INTARR(JJ8) IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*NFRONT8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII8) AII8 = AII8 + 1_8 END DO END IF END DO END DO IF (KEEP(253).GT.0) THEN POSELT = PTRAST(STEP(INODE)) IBROT = INODE IJROW = Pos_First_NUMORG DO IORG = 1, NUMORG IF (KEEP(50).EQ.0) THEN DO J253=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ELSE DO J253=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+J253-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF IF (PARPIV_T1.NE.0.AND.(.NOT.SON_LEVEL2)) THEN IOLDPS = PTLUST(STEP(INODE)) CALL CMUMPS_PARPIVT1_SET_NVSCHUR_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1, NASS) ENDIF GOTO 500 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING CMUMPS_ASM_NIV1_ELT' ENDIF GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING CMUMPS_ASM_NIV1_ELT' ENDIF INFO(1) = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, RECV BUFFER TOO SMALL DURING CMUMPS_ASM_NIV1_ELT' ENDIF INFO(1) = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) ' FAILURE IN INTEGER', & ' DYNAMIC ALLOCATION DURING CMUMPS_ASM_NIV1_ELT' ENDIF INFO(2) = NUMSTK ENDIF 490 CONTINUE IF ( KEEP(405) .EQ. 0 ) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_ASM_NIV1_ELT SUBROUTINE CMUMPS_FAC_ASM_NIV2_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, INFO, & ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, roota, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, MEM_DISTRIB & , LRGROUPS & ) !$ USE OMP_LIB USE MUMPS_BUILD_SORT_INDEX_ELT_M USE MUMPS_BUF_COMMON, ONLY: MUMPS_BUF_SEND_MAPLIG, & MUMPS_BUF_SEND_DESC_BANDE USE MUMPS_LOAD USE CMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_PTR, & CMUMPS_DM_IS_DYNAMIC USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER NELT INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC, LA INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE, MAXFRW, LPOOL, LEAF, & IWPOS, IWPOSCB, COMP, SLAVEF COMPLEX, TARGET :: A(LA) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR COMPLEX DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER MYID, COMM INTEGER IFATH INTEGER LBUFR, LBUFR_BYTES INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INTEGER LP, HS, HF, HF_OLD, NCBSON, NSLAVES_OLD LOGICAL LPOK INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL COMPLEX, DIMENSION(:), POINTER :: SON_A INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER :: SON_XXS INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL PACKED_CB, IS_CB_LR INTEGER(8) :: LCB LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER MP INTEGER :: K1, K2, KK, KK1 INTEGER :: J253 INTEGER(8) :: AII8, AINPUT8, II8 INTEGER(8) :: J18,J28,JJ8 INTEGER(8) :: LAPOS2, JJ2, JJ3 INTEGER(8) :: NFRONT8, POSELT, POSEL1, LDAFS8, & IACHK, ICT12, ICT21 INTEGER(8) APOS, APOS2 #if ! defined(ZERO_TRIANGLE) INTEGER :: TOPDIAG #endif !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM,NPIVS,NCOLS,NROWS, & IORG INTEGER LDAFS, LDA_SON, IJROW, IBROT INTEGER Pos_First_NUMORG,NBCOL,NUMORG,IOLDPS INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, PDEST INTEGER PDEST1(1) INTEGER :: ISLAVE INTEGER ELTI INTEGER(8) :: SIZE_ELTI8 INTEGER :: I, J INTEGER :: ELBEG, NUMELT LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER IZERO INTEGER IDUMMY(1) PARAMETER( IZERO = 0 ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT COMPLEX ZERO REAL RZERO PARAMETER( RZERO = 0.0E0 ) PARAMETER( ZERO = (0.0E0,0.0E0) ) logical :: force_cand INTEGER ETATASS INTEGER(8) :: APOSMAX REAL MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT, & NUMORG_SPLIT, TYPESPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER, ALLOCATABLE, DIMENSION(:) :: SONROWS_PER_ROW INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTEGER :: NMB_OF_CAND, NMB_OF_CAND_ORIG LOGICAL :: IS_ofType5or6, SPLIT_MAP_RESTART !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IS_ofType5or6 = .FALSE. PACKED_CB = .FALSE. ETATASS = 0 IN = INODE NSTEPS = NSTEPS + 1 KEEP(429) = KEEP(429)+1 NUMELT = FRT_PTR(INODE+1) - FRT_PTR(INODE) IF ( NUMELT .NE. 0 ) THEN ELBEG = FRT_PTR(INODE) ELSE ELBEG = 1 END IF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON NCBSON_MAX = 0 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 IF ( KEEP(48)==5 .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) ENDIF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 CALL IS_FRONT_BLR_CANDIDATE(INODE, 2, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, KEEP(280), LRGROUPS) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then force_cand=.FALSE. ELSE force_cand=(mod(KEEP(24),2).eq.0) end if TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) SPLIT_MAP_RESTART = .FALSE. IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) NMB_OF_CAND = CAND( SLAVEF+1, INIV2 ) NMB_OF_CAND_ORIG = NMB_OF_CAND SIZE_TMP_SLAVES_LIST = NMB_OF_CAND IF (IS_ofType5or6) THEN DO I=NMB_OF_CAND+1,SLAVEF IF ( CAND( I, INIV2 ).LT.0) EXIT NMB_OF_CAND = NMB_OF_CAND +1 ENDDO SIZE_TMP_SLAVES_LIST = NSLSON-1 WRITE(6,*) "NMB_OF_CAND, SIZE_TMP_SLAVES_LIST ", & NMB_OF_CAND, SIZE_TMP_SLAVES_LIST IF (INODE.EQ.-999999) THEN SPLIT_MAP_RESTART = .TRUE. ENDIF ENDIF IF (IS_ofType5or6.AND.SPLIT_MAP_RESTART) THEN TYPESPLIT = 4 IS_ofType5or6 = .FALSE. SIZE_TMP_SLAVES_LIST = NMB_OF_CAND CAND (SLAVEF+1, INIV2) = SIZE_TMP_SLAVES_LIST ENDIF ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 NMB_OF_CAND = SLAVEF - 1 NMB_OF_CAND_ORIG = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IF ( (TYPESPLIT.EQ.4) & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) & ) THEN IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) IF (SPLIT_MAP_RESTART) THEN IS_ofType5or6 = .TRUE. TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) CAND( SLAVEF+1, INIV2 ) = NMB_OF_CAND_ORIG ENDIF ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) IF (KEEP(376) .EQ. 1) THEN NFRONT = IW( PIMASTER(STEP(IFSON)) + KEEP(IXSZ)) ENDIF CALL MUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND(1,INIV2), NMB_OF_CAND_ORIG, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES, & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST & ) ENDIF ELSE CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_OOC_GET_PP_SIZES(KEEP(50), NASS1, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL CMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & LRLUS,KEEP(IXSZ), & COMP, DKEEP(97), MYID, SLAVEF, & PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress CMUMPS_FAC_ASM_NIV2_ELT', & 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. ALLOCATE(SONROWS_PER_ROW(NFRONT-NASS1), stat=allocok) IF (allocok > 0) THEN GOTO 275 ENDIF CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & SONROWS_PER_ROW, NFRONT - NASS1) IF (INFO(1).LT.0) GOTO 250 IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN WRITE(6,*) ' Internal error 1 in fac_ass due to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF WRITE(6,*) ' SPLITTING NOT YET READY FOR THAT' CALL MUMPS_ABORT() ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN NCB = NFRONT_EFF - NASS1 NSLAVES_OLD = NSLAVES HF_OLD = HF IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP, KEEP8, ICNTL, & CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - & (NSLAVES_OLD - NSLAVES) IF (NSLAVES_OLD .NE. NSLAVES) THEN IF (NSLAVES_OLD > NSLAVES) THEN DO KK=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+KK)=IW(IOLDPS+HF_OLD+KK) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO KK=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+KK) = IW(IOLDPS+HF_OLD+KK) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) ' INTERNAL ERROR 2 during ass_niv2' ENDIF GOTO 270 ENDIF ENDIF NFRONT8=int(NFRONT,8) IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max(MAXFRW, NFRONT) PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+KEEP(IXSZ)) = NFRONT IW(IOLDPS + 1+KEEP(IXSZ)) = 0 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+NSLAVES+KEEP(IXSZ))= & TMP_SLAVES_LIST(1:NSLAVES) ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL CMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) ENDIF ENDIF ENDIF CALL MUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM_LOAD, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP, KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) IF(KEEP(86).EQ.1)THEN IF(mod(KEEP(24),2).eq.0)THEN CALL MUMPS_LOAD_SEND_MD_INFO(SLAVEF, & CAND(SLAVEF+1,INIV2), & CAND(1,INIV2), & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN CALL MUMPS_LOAD_SEND_MD_INFO(SLAVEF, & SLAVEF-1, & TMP_SLAVES_LIST, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ENDIF ENDIF DEALLOCATE(TMP_SLAVES_LIST) IF (KEEP(50).EQ.0) THEN LAELL8 = int(NASS1,8) * NFRONT8 LDAFS = NFRONT LDAFS8 = NFRONT8 ELSE LAELL8 = int(NASS1,8)*int(NASS1,8) IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) & LAELL8 = LAELL8+int(NASS1,8) LDAFS = NASS1 LDAFS8 = int(NASS1,8) ENDIF CALL CMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= LRSTATUS IW(IOLDPS+XXG) = MemNotPinned CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8,LRLUS) POSEL1 = POSELT - LDAFS8 #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8 = int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (LAPOS2 - POSELT > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO JJ8 = POSELT, LAPOS2 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max(KEEP(360)/2, !$ & ( (( LDAFS + NOMP -1 ) / NOMP + 2) / 3) ) APOS = POSELT #if defined(__ve__) !NEC$ IVDEP #endif !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK) !$OMP& IF (LDAFS - 1 .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(LDAFS-1,8) APOS = POSELT + JJ8 * int(LDAFS,8) JJ3 = min( int(LDAFS,8) - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) A(APOSMAX:APOSMAX+int(LDAFS-1,8))=ZERO ENDIF END IF #endif IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) IF (NELIM.EQ.0) GOTO 210 LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT=PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT=ISTCHK ENDIF SON_XXS = IW(ISTCHK_CB_RIGHT + XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF IF (KEEP(50).EQ.0) THEN LDA_SON = LSTK LCB = int(NELIM,8)*int(LSTK,8) ELSE IF (NSLSON.EQ.0) THEN IF (SAME_PROC) THEN IS_CB_LR = IW(ISTCHK_CB_RIGHT+XXLR).EQ. 1 .OR. & IW(ISTCHK_CB_RIGHT+XXLR).EQ. 3 IF (IS_CB_LR) THEN LDA_SON = NELIM ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = NELIM ENDIF IF (PACKED_CB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN OPASSW = OPASSW + dble(LCB) ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM+1,8)/2_8 ENDIF IS_DYNAMIC_CB = & CMUMPS_DM_IS_DYNAMIC(IW(ISTCHK_CB_RIGHT+XXD: & ISTCHK_CB_RIGHT+XXD+1)) IF ( IS_DYNAMIC_CB ) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_CB_RIGHT+XXD)) CALL CMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) SON_A=>A ENDIF K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IF (KEEP(50).eq.0) THEN IF (IS_ofType5or6) THEN APOS = POSELT DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + SON_A(IACHK+JJ8-1_8) ENDDO ELSE DO 170 KK = K1, K2 APOS = POSEL1 + int(IW(KK),8) * LDAFS8 DO 160 KK1 = 1, LSTK JJ2 = APOS + int(IW(K1 + KK1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (LCB .GT. 0) THEN CALL CMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) IF (KEEP(219).NE.0) THEN IF (KEEP(50).EQ.2) THEN A( APOSMAX: APOSMAX+int(NASS1-1,8))=ZERO ENDIF ENDIF DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1) - 1_8 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = INTARR(II8) IF (KEEP(50).EQ.0) THEN IF (I.LE.NASS1) THEN AINPUT8 = AII8 + II8 - J18 ICT12 = POSELT + int(I-1,8) * LDAFS8 DO JJ8=J18,J28 APOS2 = ICT12 + int(INTARR(JJ8) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ENDIF ELSE ICT12 = POSELT - LDAFS8 + int(I,8) - 1_8 ICT21 = POSELT + int(I-1,8)*LDAFS8 - 1_8 IF ( I .GT. NASS1 ) THEN IF (KEEP(219).NE.0 .AND. KEEP(50).EQ.2) THEN AINPUT8=AII8 DO JJ8=II8,J28 J=INTARR(JJ8) IF (J.LE.NASS1) THEN A(APOSMAX+int(J-1,8))=cmplx( & max(real(A(APOSMAX+int(J-1,8))), & abs(DBLARR(AINPUT8))), & kind=kind(A) & ) ENDIF AINPUT8=AINPUT8+1_8 ENDDO ENDIF AII8 = AII8 + J28 - II8 + 1_8 CYCLE ELSE IF (KEEP(219).NE.0) THEN MAXARR = RZERO ENDIF DO JJ8=II8,J28 J = INTARR(JJ8) IF ( J .LE. NASS1) THEN IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*LDAFS8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII8) ELSE IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AII8))) ENDIF AII8 = AII8 + 1_8 END DO IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(I-1,8)) = cmplx( & max( MAXARR, real(A(APOSMAX+int(I-1,8)))), & kind=kind(A) & ) ENDIF ENDIF END IF END DO END DO IF (KEEP(253).GT.0) THEN POSELT = PTRAST(STEP(INODE)) IBROT = INODE IJROW = Pos_First_NUMORG DO IORG = 1, NUMORG IF (KEEP(50).EQ.0) THEN DO J253 = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & NBLIG, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 IERR = -1 DO WHILE (IERR .EQ.-1) IF ( KEEP(50) .eq. 0 ) THEN NBCOL = NFRONT CALL MUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL MUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF ENDDO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 ENDDO DEALLOCATE(SONROWS_PER_ROW) IF (NUMSTK.EQ.0) GOTO 500 ISON = IFSON DO IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + 2 + KEEP(IXSZ) ) ELSE NROWS = NCOLS ENDIF PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN NFS4FATHER = NCBSON DO I=0,NCBSON-1 IF(IW(PTRCOL+I) .GT. NASS1) THEN NFS4FATHER = I EXIT ENDIF ENDDO NFS4FATHER = NFS4FATHER + NELIM ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) IF (PDEST1(1).EQ.MYID) THEN CALL CMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & NFRONT, NASS1, NFS4FATHER, NCBSON, IW( PTRCOL ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, roota, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, NELT+1, NELT, & FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, PDEST1, NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL CMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & NFRONT, NASS1,NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), INFO(2), & MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & CMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(2) = NUMSTK + 1 ENDIF GOTO 490 245 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING COPY_CAND', & ' DURING CMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = SLAVEF+1 GOTO 490 265 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING CMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING CMUMPS_ASM_NIV2_ELT' ENDIF GOTO 490 275 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING SONROWS_PER_ROW', & ' DURING CMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = NFRONT-NASS1 GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (1) DURING CMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (1) DURING CMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (2)', &' DURING CMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (2)', &' DURING CMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -20 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 490 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_ASM_NIV2_ELT END MODULE CMUMPS_FAC_ASM_MASTER_ELT_M MUMPS_5.8.1/src/mumps_register_thread.c0000664000175000017500000000106115042446422017766 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ void mumps_register_thread_return() { /* * Registering tools will be available in the future. */ } MUMPS_5.8.1/src/darrowheads.F0000664000175000017500000011611215042446440015644 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ANA_ARROWHEADS_WRAPPER ( id, & GATHER_MATRIX_ALLOCATED ) USE DMUMPS_STRUC_DEF USE DMUMPS_ANA_AUX_M, ONLY:DMUMPS_ANA_N_DIST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: MASTER PARAMETER( MASTER = 0 ) TYPE(DMUMPS_STRUC), TARGET :: id LOGICAL, INTENT(INOUT) :: GATHER_MATRIX_ALLOCATED INTEGER, ALLOCATABLE, DIMENSION(:) :: NBINROW_TMP, NBINCOL_TMP INTEGER, DIMENSION(:), POINTER :: KEEP, ICNTL, INFO INTEGER(8), DIMENSION(:), POINTER :: KEEP8 LOGICAL :: I_AM_SLAVE INTEGER :: allocok KEEP => id%KEEP ICNTL => id%ICNTL INFO => id%INFO KEEP8 => id%KEEP8 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (KEEP(55) .EQ. 0) THEN ALLOCATE( NBINCOL_TMP( id%N ), NBINROW_TMP( id%N ), & stat=allocok ) IF (allocok.GT.0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(int(id%N,8)+int(id%N,8), INFO(2)) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL DMUMPS_ANA_N_DIST(id, NBINCOL_TMP, NBINROW_TMP) IF ( .NOT. I_AM_SLAVE ) THEN DEALLOCATE(NBINCOL_TMP) DEALLOCATE(NBINROW_TMP) ENDIF IF(id%MYID .EQ. MASTER) THEN IF ( (KEEP(244) .EQ. 1) .AND. (KEEP(54) .EQ. 3) ) THEN IF (GATHER_MATRIX_ALLOCATED) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF GATHER_MATRIX_ALLOCATED= .FALSE. ENDIF END IF END IF ENDIF IF ( I_AM_SLAVE ) THEN IF (KEEP(55) .EQ. 0) THEN CALL DMUMPS_ANA_DIST_ARROWHEADS( id%MYID, & id%NSLAVES, id%N, id%PROCNODE_STEPS(1), & id%STEP(1), id%FILS(1), & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & KEEP(1),KEEP8(1), ICNTL(1), id, & NBINCOL_TMP, NBINROW_TMP ) DEALLOCATE(NBINCOL_TMP) DEALLOCATE(NBINROW_TMP) ELSE CALL DMUMPS_ANA_DIST_ELEMENTS( id%MYID, & id%NSLAVES, id%N, id%PROCNODE_STEPS(1), & id%STEP(1), & id%PTRAR(1), & id%PTRAR(id%NELT+2 ), & id%NELT, & id%FRTPTR(1), id%FRTELT(1), & KEEP(1), KEEP8(1), ICNTL(1), id%KEEP(50) ) id%KEEP(193)=1;id%KEEP(194)=1 id%KEEP(195)=1; id%KEEP(196)=1 ALLOCATE( id%PTR8ARR(1), & id%NINCOLARR(1), & id%NINROWARR(1), & id%PTRDEBARR(1), stat=allocok) IF (allocok .GT. 0) THEN id%INFO(1)=-7 id%INFO(2)=4 ENDIF ENDIF ELSE KEEP8(26) = 0_8 KEEP8(27) = 0_8 ALLOCATE( id%PTR8ARR(1), & id%NINCOLARR(1), & id%NINROWARR(1), & id%PTRDEBARR(1), stat=allocok) IF (allocok .GT. 0) THEN id%INFO(1)=-7 id%INFO(2)=4 ENDIF ENDIF 500 CONTINUE IF (allocated(NBINROW_TMP)) DEALLOCATE(NBINROW_TMP) IF (allocated(NBINCOL_TMP)) DEALLOCATE(NBINCOL_TMP) RETURN END SUBROUTINE DMUMPS_ANA_ARROWHEADS_WRAPPER SUBROUTINE DMUMPS_ANA_DIST_ARROWHEADS( MYID, SLAVEF, N, & PROCNODE, STEP, FILS, ISTEP_TO_INIV2, & I_AM_CAND, & KEEP, KEEP8, ICNTL, id, NINCOL_TMP, NINROW_TMP ) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE (DMUMPS_STRUC) :: id INTEGER MYID, N, SLAVEF INTEGER KEEP( 500 ), ICNTL( 60 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE( KEEP(28) ), STEP( N ), FILS( N ) INTEGER, INTENT(INOUT) :: NINCOL_TMP( N ) INTEGER, INTENT(INOUT) :: NINROW_TMP( N ) INTEGER ISTEP_TO_INIV2(KEEP(71)) LOGICAL I_AM_CAND(max(1,KEEP(56))) LOGICAL I_AM_SLAVE LOGICAL I_AM_CAND_LOC INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT INTEGER ISTEP, I, J, NINCOL, NINROW, allocok INTEGER TYPE_PARALL, ITYPE, IRANK, INIV2, TYPESPLIT LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS INTEGER :: NBARR_LOCAL INTEGER(8) :: IPTR EARLYT3ROOTINS = KEEP(200) .EQ. 0 & .OR. (KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0) TYPE_PARALL = KEEP(46) I_AM_SLAVE = (KEEP(46).EQ.1 .OR. MYID.NE.0) NBARR_LOCAL=0 DO J = 1, N ISTEP = STEP( J ) IF ( ISTEP .GT. 0 ) THEN I = J DO WHILE (I .GT. 0) ITYPE = MUMPS_TYPENODE( PROCNODE(ISTEP), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), KEEP(199) ) TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. T4_MASTER_CONCERNED = .FALSE. IF (ITYPE.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) THEN I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN IF ( TYPE_PARALL .eq. 0 ) THEN T4_MASTER_CONCERNED = & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID-1 ) ELSE T4_MASTER_CONCERNED = & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID ) ENDIF ENDIF ENDIF ENDIF IF ( TYPE_PARALL .eq. 0 ) THEN IRANK =IRANK + 1 END IF IF ( & ( ITYPE .eq. 2 .and. & IRANK .eq. MYID ) & .or. & ( ITYPE .eq. 1 .and. & IRANK .eq. MYID ) & .or. & ( T4_MASTER_CONCERNED ) & ) THEN NINCOL = NINCOL_TMP(I) NINROW = NINROW_TMP(I) ELSE IF ( ITYPE .EQ. 3 ) THEN IF ( EARLYT3ROOTINS ) THEN NINCOL = -1 NINROW = -1 ELSE NINCOL = NINCOL_TMP(I) NINROW = NINROW_TMP(I) ENDIF ELSE IF ( ITYPE .eq. 2 .AND. I_AM_CAND_LOC ) THEN NINCOL = NINCOL_TMP(I) NINROW = 0 ELSE NINCOL = -1 NINROW = -1 ENDIF IF ( NINCOL .NE. -1 ) THEN NBARR_LOCAL = NBARR_LOCAL + 1 ENDIF NINCOL_TMP(I)=NINCOL NINROW_TMP(I)=NINROW I=FILS(I) ENDDO ENDIF ENDDO KEEP(193) = max(1, NBARR_LOCAL) KEEP(194) = max(1, NBARR_LOCAL) KEEP(195) = max(1, NBARR_LOCAL) KEEP(196) = KEEP(28) ALLOCATE(id%PTR8ARR(KEEP(193)), & id%NINCOLARR(KEEP(194)), id%NINROWARR(KEEP(195)), & id%PTRDEBARR(KEEP(196)), stat=allocok) IF (allocok.GT.0) THEN id%INFO(1)=-7 CALL MUMPS_SET_IERROR( int(KEEP(194),8)+int(KEEP(195),8)+ & int(KEEP(196),8), id%INFO(2) ) RETURN ENDIF IPTR = 1_8 NBARR_LOCAL = 0 DO J = 1, N ISTEP = STEP( J ) IF ( ISTEP .GT. 0 ) THEN id%PTRDEBARR(ISTEP) = NBARR_LOCAL + 1 I = J DO WHILE (I .GT. 0) NINCOL = NINCOL_TMP(I) NINROW = NINROW_TMP(I) IF ( NINCOL .NE. -1 ) THEN NBARR_LOCAL = NBARR_LOCAL + 1 id%NINCOLARR( NBARR_LOCAL ) = NINCOL id%NINROWARR( NBARR_LOCAL ) = NINROW id%PTR8ARR ( NBARR_LOCAL ) = IPTR IPTR = IPTR + int(NINCOL + NINROW + 1,8) ENDIF I=FILS(I) ENDDO IF ( NINCOL .EQ. -1 ) THEN id%PTRDEBARR( ISTEP ) = -99999 ENDIF ENDIF ENDDO KEEP8(26) = IPTR - 1 KEEP8(27) = IPTR - 1 RETURN END SUBROUTINE DMUMPS_ANA_DIST_ARROWHEADS SUBROUTINE DMUMPS_FACTO_SEND_ARROWHEADS( N, NZ, ASPK, & IRN, ICN, PERM, & LSCAL,COLSCA,ROWSCA, & MYID, SLAVEF, PROCNODE_STEPS, NBRECORDS, & COMM, root, roota, KEEP, KEEP8, FILS, & INTARR, LINTARR, DBLARR, LDBLARR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, FRERE_STEPS, & STEP, A, LA, ISTEP_TO_INIV2, I_AM_CAND, CANDIDATES, & ICNTL, INFO ) !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER :: N, COMM, NBRECORDS INTEGER(8), INTENT(IN) :: NZ INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION ASPK(NZ) DOUBLE PRECISION COLSCA(*), ROWSCA(*) INTEGER IRN(NZ), ICN(NZ) INTEGER PERM(N), PROCNODE_STEPS(KEEP(28)) INTEGER FILS( N ) INTEGER ISTEP_TO_INIV2(KEEP(71)) LOGICAL I_AM_CAND(max(1,KEEP(56))) INTEGER SLAVEF, MYID INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56))) LOGICAL LSCAL TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER INFO( 80 ), ICNTL(60) INTEGER(8), INTENT(IN) :: LA INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER :: FRERE_STEPS( KEEP(28) ) INTEGER :: STEP(N) INTEGER(8) :: LINTARR, LDBLARR INTEGER :: INTARR( LINTARR ) DOUBLE PRECISION :: DBLARR( LDBLARR ) DOUBLE PRECISION :: A( LA ) INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT INTEGER LP LOGICAL LPOK DOUBLE PRECISION VAL, VAL_SHR INTEGER IOLD,JOLD,ISEND,JSEND,DEST,I,IARR INTEGER ISEND_SHR, JSEND_SHR, DEST_SHR INTEGER IPOSROOT, JPOSROOT INTEGER IROW_GRID, JCOL_GRID INTEGER ISTEP INTEGER NBUFS INTEGER ARROW_ROOT, TAILLE INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT INTEGER TYPE_NODE, MASTER_NODE LOGICAL I_AM_CAND_LOC, I_AM_SLAVE INTEGER JARR, ILOCROOT, JLOCROOT INTEGER allocok, INIV2, TYPESPLIT, T4MASTER INTEGER(8) :: IS8, K INTEGER NCAND LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: PTRAW INTEGER :: IARR1, IORG, J INTEGER, DIMENSION(:,:), ALLOCATABLE :: BUFI DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: BUFR LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P INTEGER NOMP, NOMP_P, IOMP, P2 LP = ICNTL(1) LPOK = ( LP .GT. 0 .AND. ICNTL(4) .GE. 1 ) ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ. 0 & .OR. (KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0) I_AM_SLAVE=(MYID.NE.0.OR.KEEP(46).EQ.1) IF ( KEEP(46) .eq. 0 ) THEN NBUFS = SLAVEF ELSE NBUFS = SLAVEF - 1 ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8)+int(N,8), INFO(2) ) IF (LPOK ) WRITE (LP,*) MYID, & ': Error allocating IW4 in DMUMPS_FACTO_SEND_ARROWHEADS' GOTO 100 END IF ALLOCATE( PTRAW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = N IF (LPOK ) WRITE (LP,*) MYID, & ': Error allocating PTRAW in DMUMPS_FACTO_SEND_ARROWHEADS' GOTO 100 END IF ENDIF IF (NBUFS.GT.0) THEN ALLOCATE( BUFI(NBRECORDS*2+1,NBUFS),stat=allocok ) IF ( allocok .GT. 0 ) THEN IF (LPOK ) WRITE (LP,*) MYID, & ': Error allocating BUFI in DMUMPS_FACTO_SEND_ARROWHEADS' INFO(1)=-13 CALL MUMPS_SET_IERROR( int(NBUFS,8) * int(NBRECORDS*2+1,8), & INFO(2)) GOTO 100 END IF ALLOCATE( BUFR( NBRECORDS, NBUFS ), stat=allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) =-13 CALL MUMPS_SET_IERROR( int(NBUFS,8) * int(NBRECORDS*2+1,8), & INFO(2)) IF (LPOK ) WRITE (LP,*) MYID, & ': Error allocating BUFR in DMUMPS_FACTO_SEND_ARROWHEADS' GOTO 100 END IF DO I = 1, NBUFS BUFI( 1, I ) = 0 ENDDO ENDIF 100 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF (KEEP(46) .NE. 0) THEN #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, N ISTEP=STEP(J) IF (ISTEP .GT. 0) THEN IARR1 = PTRDEBARR( ISTEP ) IF ( IARR1 .GT. 0 ) THEN I = J IORG = 0 DO WHILE ( I .GT. 0 ) IORG = IORG + 1 IW4(I, 1) = NINCOLARR( IARR1 + IORG - 1 ) IW4(I, 2) = NINROWARR( IARR1 + IORG - 1 ) + & NINCOLARR( IARR1 + IORG - 1 ) IS8 = PTR8ARR( IARR1 + IORG - 1 ) PTRAW( I ) = IS8 INTARR( IS8 ) = I DBLARR( IS8 ) = ZERO I = FILS(I) ENDDO ENDIF ENDIF ENDDO IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL DMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, & PTR_ROOT, LA) CALL DMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF END IF NOMP = 1 !$ NOMP=omp_get_max_threads() OMP_FLAG = KEEP(399).EQ.1 .AND. NOMP.GE.2 .AND. SLAVEF.EQ.1 & .AND. KEEP(46) .EQ. 1 !$OMP PARALLEL PRIVATE(K, I, DEST, I_AM_CAND_LOC, !$OMP& T4MASTER, T4_MASTER_CONCERNED, !$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, !$OMP& ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, !$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE, !$OMP& IS8, TAILLE, VAL, !$OMP& IARR, JARR, ISTEP, ISEND, JSEND, !$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P) !$OMP& REDUCTION(+: ARROW_ROOT) IF (OMP_FLAG) IOMP=0 !$ IOMP=omp_get_thread_num() NOMP_P=1 !$ NOMP_P=omp_get_num_threads() OMP_FLAG_P = .FALSE. !$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1 IF (OMP_FLAG_P) THEN IF ( NOMP_P .GE. 16 ) THEN NOMP_P=16 P2 = 4 ELSE IF (NOMP_P.GE.8) THEN NOMP_P=8 P2 = 3 ELSE IF (NOMP_P.GE.4) THEN NOMP_P=4 P2 = 2 ELSE IF (NOMP_P.GE.2) THEN NOMP_P=2 P2 = 1 ENDIF ELSE NOMP_P = 1 P2 = 0 ENDIF IF ( IOMP .LT. NOMP_P ) THEN DO K=1, NZ IOLD = IRN(K) JOLD = ICN(K) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE END IF IF (OMP_FLAG_P) THEN IF (IOLD.EQ.JOLD) THEN IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD ELSE IARR = JOLD ENDIF DOIT = ( IOMP .EQ. ibits(IARR, P2-1, P2)) ELSE DOIT = .TRUE. ENDIF IF (DOIT) THEN IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = JOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF ISTEP = abs( STEP(IARR) ) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 IF ( TYPE_NODE .EQ. 1 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF ELSE IF ( TYPE_NODE .EQ. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF END IF INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) IF ( KEEP(46) .eq. 0 ) THEN T4MASTER=T4MASTER+1 ENDIF ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND .LT. 0 ) THEN IPOSROOT = root%RG2L(JSEND) JPOSROOT = root%RG2L(IARR) ELSE IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JSEND ) END IF IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL ) IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * root%NPCOL + JCOL_GRID END IF ELSE DEST = -2 ENDIF END IF IF (LSCAL) THEN VAL = ASPK(K)*ROWSCA(IOLD)*COLSCA(JOLD) ELSE VAL = ASPK(K) ENDIF IF ( DEST .eq. 0 & .or. & ( DEST .eq. -1 .and. KEEP( 46 ) .eq. 1 .AND. & ( I_AM_CAND_LOC .OR. MASTER_NODE .EQ. 0 ) ) & .or. & ( T4MASTER.EQ.0 ) & .or. & ( DEST .EQ. -2 .AND. KEEP( 46 ) .EQ. 1 ) & ) THEN IARR = ISEND JARR = JSEND IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%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 IS8 = PTRAW( IARR ) DBLARR( IS8 ) = DBLARR( IS8 ) + VAL ELSE IS8 = PTRAW(IARR) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL END IF ELSE IARR = -IARR IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 .AND. & STEP( IARR) > 0 ) THEN IF ( MASTER_NODE == MYID) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL DMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF END IF END IF END IF IF ( DEST.EQ. -1 ) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79).GT.0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) IF (KEEP(46).EQ.0.AND.(DEST.GE.0)) DEST=DEST+1 IF (DEST.LT.0) EXIT IF (I.EQ.NCAND+1) CYCLE IF (DEST.NE.0) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL DMUMPS_ARROW_FILL_SEND_BUF() ENDIF ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) IF (KEEP(46).EQ.0) DEST=DEST+1 IF (DEST.NE.0) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL DMUMPS_ARROW_FILL_SEND_BUF() ENDIF ENDDO ENDIF DEST = MASTER_NODE IF (KEEP(46).EQ.0) DEST=DEST+1 IF ( DEST .NE. 0 ) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL DMUMPS_ARROW_FILL_SEND_BUF() ENDIF IF ((T4_MASTER_CONCERNED).AND.(T4MASTER.GT.0)) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=T4MASTER CALL DMUMPS_ARROW_FILL_SEND_BUF() ENDIF ELSE IF ( DEST .GT. 0 ) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL DMUMPS_ARROW_FILL_SEND_BUF() IF ( T4MASTER.GT.0 ) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=T4MASTER CALL DMUMPS_ARROW_FILL_SEND_BUF() ENDIF ELSE IF ( T4MASTER.GT.0 ) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=T4MASTER CALL DMUMPS_ARROW_FILL_SEND_BUF() ELSE IF ( DEST .EQ. -2 ) THEN DO I = 0, SLAVEF-1 DEST = I IF (KEEP(46) .EQ. 0) DEST = DEST + 1 IF (DEST .NE. 0) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL DMUMPS_ARROW_FILL_SEND_BUF() ENDIF ENDDO ENDIF ENDIF ENDDO ENDIF !$OMP END PARALLEL KEEP(49) = ARROW_ROOT IF (NBUFS.GT.0) THEN CALL DMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP( 46 ) ) ENDIF 500 CONTINUE IF ( allocated(IW4 ) ) DEALLOCATE( IW4 ) IF ( allocated(PTRAW ) ) DEALLOCATE( PTRAW ) IF ( allocated(BUFI ) ) DEALLOCATE( BUFI ) IF ( allocated(BUFR ) ) DEALLOCATE( BUFR ) RETURN CONTAINS SUBROUTINE DMUMPS_ARROW_FILL_SEND_BUF() IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ IF (BUFI(1,DEST_SHR)+1.GT.NBRECORDS) THEN TAILLE_SENDI = BUFI(1,DEST_SHR) * 2 + 1 TAILLE_SENDR = BUFI(1,DEST_SHR) CALL MPI_SEND(BUFI(1,DEST_SHR),TAILLE_SENDI, & MPI_INTEGER, & DEST_SHR, ARROWHEAD, COMM, IERR ) CALL MPI_SEND( BUFR(1,DEST_SHR), TAILLE_SENDR, & MPI_DOUBLE_PRECISION, DEST_SHR, & ARROWHEAD, COMM, IERR ) BUFI(1,DEST_SHR) = 0 ENDIF IREQ = BUFI(1,DEST_SHR) + 1 BUFI(1,DEST_SHR) = IREQ BUFI( IREQ * 2, DEST_SHR ) = ISEND_SHR BUFI( IREQ * 2 + 1, DEST_SHR ) = JSEND_SHR BUFR( IREQ, DEST_SHR ) = VAL_SHR RETURN END SUBROUTINE DMUMPS_ARROW_FILL_SEND_BUF END SUBROUTINE DMUMPS_FACTO_SEND_ARROWHEADS SUBROUTINE DMUMPS_ARROW_FILL_SEND_BUF_ELT( & ISEND_SHR, JSEND_SHR, VAL_SHR, & DEST_SHR, BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM ) IMPLICIT NONE INTEGER, INTENT(in) :: ISEND_SHR, JSEND_SHR DOUBLE PRECISION, INTENT(in) :: VAL_SHR INTEGER :: DEST_SHR, NBRECORDS, NBUFS, LP, COMM INTEGER :: BUFI( NBRECORDS*2+1, NBUFS ) DOUBLE PRECISION :: BUFR( NBRECORDS, NBUFS ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ IF (BUFI(1,DEST_SHR)+1.GT.NBRECORDS) THEN TAILLE_SENDI = BUFI(1,DEST_SHR) * 2 + 1 TAILLE_SENDR = BUFI(1,DEST_SHR) CALL MPI_SEND(BUFI(1,DEST_SHR),TAILLE_SENDI, & MPI_INTEGER, & DEST_SHR, ARROWHEAD, COMM, IERR ) CALL MPI_SEND( BUFR(1,DEST_SHR), TAILLE_SENDR, & MPI_DOUBLE_PRECISION, DEST_SHR, & ARROWHEAD, COMM, IERR ) BUFI(1,DEST_SHR) = 0 ENDIF IREQ = BUFI(1,DEST_SHR) + 1 BUFI(1,DEST_SHR) = IREQ BUFI( IREQ * 2, DEST_SHR ) = ISEND_SHR BUFI( IREQ * 2 + 1, DEST_SHR ) = JSEND_SHR BUFR( IREQ, DEST_SHR ) = VAL_SHR RETURN END SUBROUTINE DMUMPS_ARROW_FILL_SEND_BUF_ELT SUBROUTINE DMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM, & TYPE_PARALL ) IMPLICIT NONE INTEGER NBUFS, NBRECORDS, TYPE_PARALL INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS ) DOUBLE PRECISION BUFR( NBRECORDS, NBUFS ) INTEGER COMM INTEGER LP INTEGER ISLAVE, TAILLE_SENDI, TAILLE_SENDR, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' DO ISLAVE = 1,NBUFS TAILLE_SENDI = BUFI(1,ISLAVE) * 2 + 1 TAILLE_SENDR = BUFI(1,ISLAVE) BUFI(1,ISLAVE) = - BUFI(1,ISLAVE) CALL MPI_SEND(BUFI(1,ISLAVE),TAILLE_SENDI, & MPI_INTEGER, & ISLAVE, ARROWHEAD, COMM, IERR ) IF ( TAILLE_SENDR .NE. 0 ) THEN CALL MPI_SEND( BUFR(1,ISLAVE), TAILLE_SENDR, & MPI_DOUBLE_PRECISION, ISLAVE, & ARROWHEAD, COMM, IERR ) END IF ENDDO RETURN END SUBROUTINE DMUMPS_ARROW_FINISH_SEND_BUF RECURSIVE SUBROUTINE DMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTLIST, DBLLIST, TAILLE, LO, HI ) IMPLICIT NONE INTEGER N, TAILLE INTEGER PERM( N ) INTEGER INTLIST( TAILLE ) DOUBLE PRECISION DBLLIST( TAILLE ) INTEGER LO, HI INTEGER I,J INTEGER ISWAP, PIVOT DOUBLE PRECISION dswap I = LO J = HI PIVOT = PERM(INTLIST((I+J)/2)) 10 IF (PERM(INTLIST(I)) < PIVOT) THEN I=I+1 GOTO 10 ENDIF 20 IF (PERM(INTLIST(J)) > PIVOT) THEN J=J-1 GOTO 20 ENDIF IF (I < J) THEN ISWAP = INTLIST(I) INTLIST(I) = INTLIST(J) INTLIST(J)=ISWAP dswap = DBLLIST(I) DBLLIST(I) = DBLLIST(J) DBLLIST(J) = dswap ENDIF IF ( I <= J) THEN I = I+1 J = J-1 ENDIF IF ( I <= J ) GOTO 10 IF ( LO < J ) CALL DMUMPS_QUICK_SORT_ARROWHEADS(N, PERM, & INTLIST, DBLLIST, TAILLE, LO, J) IF ( I < HI ) CALL DMUMPS_QUICK_SORT_ARROWHEADS(N, PERM, & INTLIST, DBLLIST, TAILLE, I, HI) RETURN END SUBROUTINE DMUMPS_QUICK_SORT_ARROWHEADS SUBROUTINE DMUMPS_FACTO_RECV_ARROWHD2( N, & DBLARR, LDBLARR, INTARR, LINTARR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & KEEP, KEEP8, FILS, MYID, COMM, NBRECORDS, & A, LA, root, roota, & PROCNODE_STEPS, & SLAVEF, PERM, FRERE_STEPS, STEP, ICNTL, INFO ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, MYID, COMM INTEGER KEEP(500) INTEGER(8), INTENT(IN) :: LDBLARR, LINTARR INTEGER INTARR(LINTARR) INTEGER, INTENT(IN) :: FILS( N ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER(8) KEEP8(150) INTEGER(8), intent(IN) :: LA INTEGER PROCNODE_STEPS( KEEP(28) ), PERM( N ) INTEGER SLAVEF, NBRECORDS DOUBLE PRECISION A( LA ) INTEGER INFO( 80 ), ICNTL(60) DOUBLE PRECISION DBLARR(LDBLARR) INTEGER FRERE_STEPS( KEEP(28) ), STEP(N) TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER LP LOGICAL LPOK INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFI DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: PTRAW INTEGER :: IARR1, IORG, J, ISTEP LOGICAL :: EARLYT3ROOTINS LOGICAL FINI INTEGER IREC, NB_REC, IARR, JARR, I, allocok INTEGER(8) :: IS8 INTEGER LOCAL_M, LOCAL_N, ILOCROOT, JLOCROOT, & IPOSROOT, JPOSROOT, TAILLE, & IPROC INTEGER(8) :: PTR_ROOT INTEGER ARROW_ROOT, TYPE_PARALL INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE DOUBLE PRECISION VAL DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MASTER PARAMETER(MASTER=0) INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) TYPE_PARALL = KEEP(46) LP = ICNTL(1) LPOK = ( LP .GT. 0 .AND. ICNTL(4) .GE. 1 ) ARROW_ROOT=0 EARLYT3ROOTINS = KEEP(200) .EQ. 0 & .OR. (KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0) ALLOCATE( BUFI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = NBRECORDS * 2 + 1 IF (LPOK) WRITE(LP,*) MYID, & ': Error allocaing BUFI in DMUMPS_FACTO_RECV_ARROWHD2' GOTO 100 END IF ALLOCATE( BUFR( NBRECORDS ) , stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = NBRECORDS IF (LPOK) WRITE(LP,*) MYID, & ': Error allocaing BUFR in DMUMPS_FACTO_RECV_ARROWHD2' GOTO 100 END IF ALLOCATE( IW4(N,2), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR( 2_8 * int(N,8), INFO(2) ) IF (LPOK) WRITE(LP,*) MYID, & ': Error allocaing IW4 in DMUMPS_FACTO_RECV_ARROWHD2' GOTO 100 END IF ALLOCATE( PTRAW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = N IF (LPOK) WRITE(LP,*) MYID, & ': Error allocaing PTRAW in DMUMPS_FACTO_RECV_ARROWHD2' GOTO 100 END IF 100 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF ( KEEP(38).NE.0 .AND. EARLYT3ROOTINS ) THEN CALL DMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL DMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF FINI = .FALSE. #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, N ISTEP=STEP(J) IF (ISTEP .GT. 0) THEN IARR1 = PTRDEBARR( ISTEP ) IF ( IARR1 .GT. 0 ) THEN I = J IORG = 0 DO WHILE ( I .GT. 0 ) IORG = IORG + 1 IW4(I, 1) = NINCOLARR( IARR1 + IORG - 1 ) IW4(I, 2) = NINROWARR( IARR1 + IORG - 1 ) + & NINCOLARR( IARR1 + IORG - 1 ) IS8 = PTR8ARR( IARR1 + IORG - 1 ) PTRAW( I ) = IS8 INTARR( IS8 ) = I DBLARR( IS8 ) = ZERO I = FILS(I) ENDDO ENDIF ENDIF ENDDO DO WHILE (.NOT.FINI) CALL MPI_RECV( BUFI(1), 2*NBRECORDS+1, & MPI_INTEGER, MASTER, & ARROWHEAD, & COMM, STATUS, IERR ) NB_REC = BUFI(1) IF (NB_REC.LE.0) THEN FINI = .TRUE. NB_REC = -NB_REC ENDIF IF (NB_REC.EQ.0) EXIT CALL MPI_RECV( BUFR(1), NBRECORDS, MPI_DOUBLE_PRECISION, & MASTER, ARROWHEAD, & COMM, STATUS, IERR ) DO IREC=1, NB_REC IARR = BUFI( IREC * 2 ) JARR = BUFI( IREC * 2 + 1 ) VAL = BUFR( IREC ) IF ( MUMPS_TYPENODE( PROCNODE_STEPS(abs(STEP(abs(IARR)))), & KEEP(199) ) .eq. 3 & .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JARR ) ELSE IPOSROOT = root%RG2L( JARR ) JPOSROOT = root%RG2L( -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 roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%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 IS8 = PTRAW(IARR) DBLARR(IS8) = DBLARR( IS8 ) + VAL ELSE IS8 = PTRAW(IARR) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)), & KEEP(199) ) IF ( TYPE_PARALL .eq. 0 ) THEN IPROC = IPROC + 1 END IF IF (IPROC .EQ. MYID) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL DMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF END IF ENDIF ENDDO END DO 500 CONTINUE IF (allocated(BUFI ) ) DEALLOCATE( BUFI ) IF (allocated(BUFR ) ) DEALLOCATE( BUFR ) IF (allocated(IW4 ) ) DEALLOCATE( IW4 ) IF (allocated(PTRAW ) ) DEALLOCATE( PTRAW ) KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE DMUMPS_FACTO_RECV_ARROWHD2 SUBROUTINE DMUMPS_SET_TO_ZERO(A, LLD, M, N, KEEP) !$ USE OMP_LIB, ONLY : OMP_GET_MAX_THREADS IMPLICIT NONE INTEGER, INTENT(IN) :: LLD, M, N DOUBLE PRECISION :: A(int(LLD,8)*int(N-1,8)+int(M,8)) INTEGER :: KEEP(500) DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 INTEGER I, J !$ INTEGER :: NOMP INTEGER(8) :: I8, LA !$ NOMP = OMP_GET_MAX_THREADS() IF (LLD .EQ. M) THEN LA=int(LLD,8)*int(N-1,8)+int(M,8) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC,KEEP(361)) !$OMP& IF ( LA > int(KEEP(361),8) .AND. NOMP .GT. 1) DO I8=1, LA A(I8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO PRIVATE(I,J) COLLAPSE(2) !$OMP& SCHEDULE(STATIC,KEEP(361)) IF (int(M,8)*int(N,8) !$OMP& .GT. KEEP(361).AND. NOMP .GT.1) DO I = 1, N DO J = 1, M A( int(I-1,8)*int(LLD,8)+ int(J,8) ) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE DMUMPS_SET_TO_ZERO SUBROUTINE DMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER(8), INTENT(IN) :: LA DOUBLE PRECISION, INTENT(INOUT) :: A(LA) INTEGER :: KEEP(500) TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER :: LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT IF (KEEP(60)==0) THEN CALL DMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA) IF (LOCAL_N .GT. 0) THEN CALL DMUMPS_SET_TO_ZERO(A(PTR_ROOT), & LOCAL_M, LOCAL_M, LOCAL_N, KEEP) ENDIF ELSE IF (root%yes) THEN CALL DMUMPS_SET_TO_ZERO(roota%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC, & KEEP) ENDIF RETURN END SUBROUTINE DMUMPS_SET_ROOT_TO_ZERO SUBROUTINE DMUMPS_GET_ROOT_INFO(root, & LOCAL_M, LOCAL_N, PTR_ROOT, LA) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC), INTENT(IN) :: root INTEGER, INTENT(OUT) :: LOCAL_M, LOCAL_N INTEGER(8), INTENT(OUT) :: PTR_ROOT INTEGER(8), INTENT(IN) :: LA INTEGER, EXTERNAL :: MUMPS_NUMROC LOCAL_M = MUMPS_NUMROC( root%ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) LOCAL_M = max( 1, LOCAL_M ) LOCAL_N = MUMPS_NUMROC( root%ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) PTR_ROOT = LA - int(LOCAL_M,8) * int(LOCAL_N,8) + 1_8 RETURN END SUBROUTINE DMUMPS_GET_ROOT_INFO MUMPS_5.8.1/src/mumps_save_restore_C.h0000664000175000017500000000213715042446422017570 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_SAVE_RESTORE_C_H #define MUMPS_SAVE_RESTORE_C_H #include "mumps_common.h" #if ! defined(NO_SAVE_RESTORE) #define MUMPS_GET_SAVE_DIR_C \ F_SYMBOL(get_save_dir_c,GET_SAVE_DIR_C) void MUMPS_CALL MUMPS_GET_SAVE_DIR_C(MUMPS_INT *len_save_dir, char* save_dir, mumps_ftnlen l1); #define MUMPS_GET_SAVE_PREFIX_C \ F_SYMBOL(get_save_prefix_c,GET_SAVE_PREFIX_C) void MUMPS_CALL MUMPS_GET_SAVE_PREFIX_C(MUMPS_INT *len_save_prefix, char* save_prefix, mumps_ftnlen l1); #endif #define MUMPS_SAVE_RESTORE_RETURN_C \ F_SYMBOL(save_restore_return_c,SAVE_RESTORE_RETURN_C) void MUMPS_CALL MUMPS_SAVE_RESTORE_RETURN_C(); #endif /* MUMPS_SAVE_RESTORE_C_H */ MUMPS_5.8.1/src/zmumps_save_restore_files.F0000664000175000017500000002740715042446441020650 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if ! defined(NO_SAVE_RESTORE) MODULE ZMUMPS_SAVE_RESTORE_FILES USE ZMUMPS_STRUC_DEF IMPLICIT NONE INTEGER, PARAMETER :: LEN_SAVE_FILE = 1318 CONTAINS SUBROUTINE MUMPS_READ_HEADER(fileunit, ierr, size_read, SIZE_INT & ,SIZE_INT8, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE & ,READ_ARITH, READ_INT_TYPE_64 & ,READ_OOC_FILE_NAME_LENGTH, READ_OOC_FIRST_FILE_NAME & ,READ_HASH,READ_SYM,READ_PAR,READ_NPROCS & ,FORTRAN_VERSION_OK) INTEGER,intent(in) :: fileunit INTEGER,intent(out) :: ierr INTEGER(8), intent(inout) :: size_read INTEGER,intent(in) :: SIZE_INT, SIZE_INT8 INTEGER(8), intent(out) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE CHARACTER, intent(out) :: READ_ARITH LOGICAL, intent(out) :: READ_INT_TYPE_64 INTEGER, intent(out) :: READ_OOC_FILE_NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE),intent(out)::READ_OOC_FIRST_FILE_NAME CHARACTER(len=23), intent(out) :: READ_HASH INTEGER, intent(out) :: READ_SYM,READ_PAR,READ_NPROCS LOGICAL, intent(out) :: FORTRAN_VERSION_OK CHARACTER(len=5) :: READ_FORTRAN_VERSION INTEGER :: SIZE_CHARACTER, SIZE_LOGICAL INTEGER :: dummy SIZE_CHARACTER = 1 SIZE_LOGICAL = 4 FORTRAN_VERSION_OK = .true. read(fileunit,iostat=ierr) READ_FORTRAN_VERSION if(ierr.ne.0) GOTO 100 if (READ_FORTRAN_VERSION.NE."MUMPS") THEN ierr = 0 FORTRAN_VERSION_OK = .false. GOTO 100 endif size_read=size_read+int(5*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_HASH if(ierr.ne.0) GOTO 100 size_read=size_read+int(23*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(ierr.ne.0) GOTO 100 size_read=size_read+int(2*SIZE_INT8,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_ARITH if(ierr.ne.0) GOTO 100 size_read=size_read+int(1,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_SYM,READ_PAR,READ_NPROCS if(ierr.ne.0) GOTO 100 size_read=size_read+int(3*SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_INT_TYPE_64 if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_LOGICAL,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_OOC_FILE_NAME_LENGTH if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif IF(READ_OOC_FILE_NAME_LENGTH.EQ.-999) THEN read(fileunit,iostat=ierr) dummy if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif ELSE read(fileunit,iostat=ierr) & READ_OOC_FIRST_FILE_NAME(1:READ_OOC_FILE_NAME_LENGTH) if(ierr.ne.0) GOTO 100 size_read=size_read+int( & READ_OOC_FILE_NAME_LENGTH*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif ENDIF 100 continue RETURN END SUBROUTINE MUMPS_READ_HEADER SUBROUTINE ZMUMPS_CHECK_HEADER(id, BASIC_CHECK, READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) INCLUDE 'mpif.h' TYPE (ZMUMPS_STRUC),intent(inout) :: id LOGICAL, intent(in) :: BASIC_CHECK LOGICAL, intent(in) :: READ_INT_TYPE_64 CHARACTER(len=23), intent(in) :: READ_HASH INTEGER, intent(in) :: READ_NPROCS CHARACTER, intent(in) :: READ_ARITH INTEGER, intent(in) :: READ_SYM,READ_PAR LOGICAL :: INT_TYPE_64 CHARACTER(len=23) :: HASH_MASTER CHARACTER :: ARITH INTEGER :: IERR IF(id%KEEP(10).EQ.1) THEN INT_TYPE_64=.TRUE. ELSE INT_TYPE_64=.FALSE. ENDIF if(INT_TYPE_64.neqv.READ_INT_TYPE_64) THEN id%INFO(1) = -73 id%INFO(2) = 2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(id%MYID.EQ.0) THEN HASH_MASTER=READ_HASH ENDIF call MPI_BCAST(HASH_MASTER,23,MPI_CHARACTER,0,id%COMM,IERR) if(HASH_MASTER.ne.READ_HASH) THEN id%INFO(1) = -73 id%INFO(2) = 3 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(id%NPROCS.ne.READ_NPROCS) THEN id%INFO(1) = -73 id%INFO(2) = 4 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 IF (.NOT.BASIC_CHECK) THEN ARITH="ZMUMPS"(1:1) if(ARITH.ne.READ_ARITH) THEN id%INFO(1) = -73 id%INFO(2) = 5 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if((id%MYID.EQ.0).AND.(id%SYM.ne.READ_SYM)) THEN id%INFO(1) = -73 id%INFO(2) = 6 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if((id%MYID.EQ.0).AND.(id%PAR.ne.READ_PAR)) THEN write (*,*) id%MYID, 'PAR ',id%PAR, 'READ_PAR ', READ_PAR id%INFO(1) = -73 id%INFO(2) = 7 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF 100 continue RETURN END SUBROUTINE ZMUMPS_CHECK_HEADER SUBROUTINE MUMPS_CLEAN_SAVED_DATA(MYID,ierr,SUPPFILE,INFOFILE) INCLUDE 'mpif.h' INTEGER,intent(in) :: MYID INTEGER,intent(out) :: ierr CHARACTER(len=LEN_SAVE_FILE),intent(in):: SUPPFILE,INFOFILE INTEGER::supp,tmp_err ierr = 0 tmp_err = 0 CALL MUMPS_FIND_UNIT(supp) IF ( supp .EQ. -1 ) THEN ierr=-79 RETURN ENDIF open(UNIT=supp,FILE=SUPPFILE,STATUS='old', & form='unformatted',iostat=tmp_err) if (tmp_err.eq.0) THEN close(UNIT=supp,STATUS='delete',iostat=tmp_err) if(tmp_err.ne.0) then ierr = 1 tmp_err = 0 endif endif if (ierr .eq. 0) then if (tmp_err.ne.0) then ierr = 1 tmp_err = 0 endif open(UNIT=supp,FILE=INFOFILE,STATUS='old',iostat=tmp_err) if (tmp_err.eq.0) THEN close(UNIT=supp,STATUS='delete',iostat=tmp_err) endif if (tmp_err.ne.0) THEN ierr = ierr + 2 tmp_err = 0 endif endif RETURN END SUBROUTINE MUMPS_CLEAN_SAVED_DATA SUBROUTINE ZMUMPS_GET_SAVE_FILES(id,SAVE_FILE,INFO_FILE) INCLUDE 'mpif.h' TYPE (ZMUMPS_STRUC),intent(inout) :: id CHARACTER(len=LEN_SAVE_FILE),intent(out):: SAVE_FILE, INFO_FILE INTEGER::len_save_dir,len_save_prefix INTEGER, PARAMETER :: SAVE_PREFIX_MAX_LENGTH = 255 INTEGER, PARAMETER :: SAVE_DIR_MAX_LENGTH = 1023 CHARACTER(len=SAVE_DIR_MAX_LENGTH) :: tmp_save_dir CHARACTER(len=SAVE_DIR_MAX_LENGTH) :: save_dir CHARACTER(len=SAVE_PREFIX_MAX_LENGTH) :: save_prefix CHARACTER(len=SAVE_PREFIX_MAX_LENGTH) :: tmp_save_prefix CHARACTER(len=10):: STRING_MYID CHARACTER:: LAST_CHAR_DIR INFO_FILE='' SAVE_FILE='' tmp_save_dir='' tmp_save_prefix='' IF(id%SAVE_DIR.EQ."NAME_NOT_INITIALIZED") THEN call MUMPS_GET_SAVE_DIR_C(len_save_dir,tmp_save_dir) if (len_save_dir > SAVE_DIR_MAX_LENGTH) then id%INFO(1) = -77 id%INFO(2) = SAVE_DIR_MAX_LENGTH else if(tmp_save_dir(1:len_save_dir).EQ."NAME_NOT_INITIALIZED") & then id%INFO(1) = -77 id%INFO(2) = 0 else save_dir=trim(adjustl(tmp_save_dir(1:len_save_dir))) len_save_dir=len_trim(save_dir(1:len_save_dir)) endif ELSE save_dir=trim(adjustl(id%SAVE_DIR)) len_save_dir=len_trim(save_dir) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 IF(id%SAVE_PREFIX.EQ."NAME_NOT_INITIALIZED") THEN call MUMPS_GET_SAVE_PREFIX_C(len_save_prefix,tmp_save_prefix) if(len_save_prefix.GT.SAVE_PREFIX_MAX_LENGTH) then id%INFO(1)=-77 id%INFO(2)=-SAVE_PREFIX_MAX_LENGTH else if(tmp_save_prefix(1:len_save_prefix).EQ. & "NAME_NOT_INITIALIZED") then save_prefix="save" len_save_prefix=len_trim(save_prefix) else save_prefix= & trim(adjustl(tmp_save_prefix(1:len_save_prefix))) len_save_prefix=len_trim(save_prefix(1:len_save_prefix)) endif ELSE save_prefix=trim(adjustl(id%SAVE_PREFIX)) len_save_prefix=len_trim(save_prefix) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(STRING_MYID,'(I10)') id%MYID LAST_CHAR_DIR=save_dir(len_save_dir:len_save_dir) if(LAST_CHAR_DIR.NE."/") then SAVE_FILE=trim(adjustl(save_dir))//"/" else SAVE_FILE=trim(adjustl(save_dir)) endif INFO_FILE=trim(adjustl(SAVE_FILE)) SAVE_FILE=trim(adjustl(SAVE_FILE)) & //trim(adjustl(save_prefix)) & //"_" & //trim(adjustl(STRING_MYID)) & //".mumps" INFO_FILE=trim(adjustl(INFO_FILE)) & //trim(adjustl(save_prefix)) & //"_" & //trim(adjustl(STRING_MYID)) & //".info" 100 continue RETURN END SUBROUTINE ZMUMPS_GET_SAVE_FILES SUBROUTINE ZMUMPS_CHECK_FILE_NAME(id,NAME_LENGTH,FILE_NAME,CHECK) TYPE (ZMUMPS_STRUC),intent(in) :: id INTEGER,intent(in) :: NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE),intent(in) :: FILE_NAME LOGICAL,intent(out) :: CHECK INTEGER :: I CHECK = .false. IF (NAME_LENGTH.NE.-999) THEN IF (associated(id%OOC_FILE_NAME_LENGTH) .AND. & associated(id%OOC_FILE_NAMES)) THEN IF (NAME_LENGTH .EQ. id%OOC_FILE_NAME_LENGTH(1)) THEN CHECK = .true. I = 1 DO WHILE(I.LE.NAME_LENGTH) IF (FILE_NAME(I:I).NE.id%OOC_FILE_NAMES(1,I)) THEN CHECK = .false. I = NAME_LENGTH + 1 ELSE I = I + 1 ENDIF END DO ENDIF ENDIF ENDIF END SUBROUTINE ZMUMPS_CHECK_FILE_NAME END MODULE ZMUMPS_SAVE_RESTORE_FILES #else SUBROUTINE ZMUMPS_SAVE_FILES_RETURN() RETURN END SUBROUTINE ZMUMPS_SAVE_FILES_RETURN #endif MUMPS_5.8.1/src/zsol_bwd.F0000664000175000017500000001661415042446441015173 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SOL_S(N, A, LA, IW, LIW, W, LWC, & NRHS, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, & MYLEAF, MYROOT, ICNTL, INFO, & PROCNODE_STEPS, & SLAVEF, COMM,MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS & , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) USE ZMUMPS_STATIC_PTR_M, ONLY : ZMUMPS_SET_STATIC_PTR, & ZMUMPS_GET_TMP_PTR USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_L0OMPFAC_T IMPLICIT NONE INTEGER MTYPE INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: LWC INTEGER, intent(in) :: N,LIW,LIWW,LPOOL INTEGER, intent(in) :: SLAVEF,MYLEAF,MYROOT,COMM,MYID INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER NE_STEPS(KEEP(28)) INTEGER IPOOL(LPOOL) INTEGER LPANEL_POS INTEGER PANEL_POS(LPANEL_POS) INTEGER ICNTL(60), INFO(80) INTEGER PTRIST(KEEP(28)), & PTRICB(KEEP(28)) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER NRHS COMPLEX(kind=8) A(LA), W(LWC) COMPLEX(kind=8) W2(KEEP(133)) INTEGER IW(LIW),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)),DAD(KEEP(28)),FILS(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LRHSINTR, POSINRHSINTR_BWD(N) COMPLEX(kind=8) RHSINTR(LRHSINTR,NRHS) INTEGER(8), intent(in) :: LRHS_ROOT COMPLEX(kind=8) RHS_ROOT( LRHS_ROOT ) LOGICAL, INTENT(in) :: PRUN_BELOW INTEGER, intent(in) :: SIZE_TO_PROCESS LOGICAL, intent(in) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP INTEGER, INTENT( in ) :: LL0_OMP_MAPPING, LL0_OMP_FACTORS INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) TYPE (ZMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' LOGICAL FLAG COMPLEX(kind=8), DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER :: UNDERL0MAP INTEGER(8) :: POSWCB, PLEFTW INTEGER POSIWCB INTEGER NBFINF INTEGER INODE INTEGER III,IIPOOL,MYLEAF_LEFT LOGICAL BLOQ INTEGER DUMMY(1) LOGICAL :: ERROR_WAS_BROADCASTED, DO_MCAST2_TERMBWD LOGICAL :: ALLOW_OTHERS_TO_LEAVE LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: allocok DUMMY(1)=0 KEEP(266)=0 ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of DEJA_SEND in ' & //'routine ZMUMPS_SOL_S ' INFO(1)=-13 INFO(2)=SLAVEF endif CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT.0 ) GOTO 340 PLEFTW = 1_8 POSIWCB = LIWW POSWCB = LWC III = 1 IIPOOL = MYROOT + 1 MYLEAF_LEFT = MYLEAF NBFINF = SLAVEF ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) ALLOW_OTHERS_TO_LEAVE = ALLOW_OTHERS_TO_LEAVE .OR. & KEEP(31) .EQ. 1 IF (ALLOW_OTHERS_TO_LEAVE) THEN CALL ZMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERMBWD, & SLAVEF, KEEP) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0 .AND. MYLEAF_LEFT .EQ. 0) THEN GOTO 340 ENDIF ENDIF ERROR_WAS_BROADCASTED = .FALSE. DO_MCAST2_TERMBWD = .FALSE. DO WHILE ( NBFINF .NE. 0 .OR. MYLEAF_LEFT .NE. 0 ) IF ( SLAVEF.EQ.1 ) THEN FLAG = .FALSE. ELSE BLOQ = ( III .EQ. IIPOOL ) CALL ZMUMPS_BACKSLV_RECV_AND_TREAT( BLOQ, FLAG, BUFR, LBUFR, & LBUFR_BYTES, MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD & , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO(1) .LT. 0 ) GOTO 340 ENDIF IF ( .NOT. FLAG ) THEN IF (III .NE. IIPOOL) THEN INODE = IPOOL(IIPOOL-1) IIPOOL = IIPOOL - 1 IF (KEEP(400) .GT. 0 ) THEN UNDERL0MAP = L0_OMP_MAPPING(STEP(INODE)) ELSE UNDERL0MAP = 0 ENDIF IF (UNDERL0MAP .EQ. 0 .OR. KEEP(201).GT.0) THEN CALL ZMUMPS_SET_STATIC_PTR(A) CALL ZMUMPS_GET_TMP_PTR(A_PTR) LA_PTR = LA ELSE A_PTR => L0_OMP_FACTORS(UNDERL0MAP)%A LA_PTR = L0_OMP_FACTORS(UNDERL0MAP)%LA ENDIF CALL ZMUMPS_SOLVE_NODE_BWD( INODE, & N, IPOOL, LPOOL, IIPOOL, NBFINF, & A_PTR(1), LA_PTR, IW, LIW, W, LWC, NRHS, & POSWCB, PLEFTW, POSIWCB, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, & MYLEAF_LEFT, INFO, & PROCNODE_STEPS, DEJA_SEND, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & , DO_MCAST2_TERMBWD & ) IF ( INFO(1) .LT. 0 ) THEN IF (.NOT. ERROR_WAS_BROADCASTED) THEN IF (NBFINF .NE. 0 ) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ENDIF ENDIF IF (DO_MCAST2_TERMBWD) THEN CALL ZMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & TERMBWD, SLAVEF, KEEP ) ENDIF ENDIF END IF ENDDO 340 CONTINUE IF (ALLOCATED(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE ZMUMPS_SOL_S MUMPS_5.8.1/src/ssol_fwd.F0000664000175000017500000001623715042446437015176 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SOL_R(N, A, LA, IW, LIW, WCB, LWCB, & NRHS, & PTRICB, IWCB, LIWCB, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & STEP, & FRERE, DAD, FILS, & NSTK, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, MYROOT, & INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) USE SMUMPS_STATIC_PTR_M, ONLY : SMUMPS_SET_STATIC_PTR, & SMUMPS_GET_TMP_PTR USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_L0OMPFAC_T IMPLICIT NONE INTEGER MTYPE INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER, INTENT(IN) :: N, LIW, LPOOL, LIWCB INTEGER, INTENT(IN) :: SLAVEF, MYLEAF, MYROOT, COMM, MYID INTEGER INFO( 80 ), KEEP(500) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER NRHS REAL A( LA ), WCB( LWCB ) INTEGER(8), intent(in) :: LRHS_ROOT REAL RHS_ROOT( LRHS_ROOT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER STEP( N ), FRERE( KEEP(28) ), FILS( N ), & DAD( KEEP(28) ) INTEGER NSTK(KEEP(28)), IPOOL( LPOOL ) INTEGER PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTRICB( KEEP(28) ) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) INTEGER IW( LIW ), IWCB( LIWCB ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, intent(in) :: POSINRHSINTR_FWD(N), LRHSINTR REAL, intent(inout) :: RHSINTR(LRHSINTR,NRHS) LOGICAL, intent(in) :: FROM_PP INTEGER, INTENT( in ) :: LL0_OMP_MAPPING, LL0_OMP_FACTORS INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) TYPE (SMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY(1) LOGICAL FLAG REAL, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER :: UNDERL0MAP INTEGER NBFIN, MYROOT_LEFT INTEGER POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INODE, IFATH INTEGER III, LEAF LOGICAL BLOQ EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE LOGICAL ERROR_WAS_BROADCASTED DUMMY(1) = 1 KEEP(266)=0 POSIWCB = LIWCB POSWCB = LWCB PLEFTWCB= 1_8 PTRICB = 0 LEAF = MYLEAF + 1 III = 1 NBFIN = SLAVEF MYROOT_LEFT = MYROOT IF ( MYROOT_LEFT .EQ. 0 ) THEN NBFIN = NBFIN - 1 CALL SMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, & RACINE_SOLVE, SLAVEF, KEEP) IF (NBFIN.EQ.0) GOTO 260 END IF IF ( INFO(1) .LT. 0 ) THEN GOTO 260 ENDIF 50 CONTINUE IF (SLAVEF .EQ. 1) THEN CALL SMUMPS_GET_INODE_FROM_POOL & ( IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF IF (SLAVEF .EQ. 1) THEN FLAG = .FALSE. ELSE BLOQ = ( ( III .EQ. LEAF ) & ) CALL SMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) ENDIF IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 IF (.not. FLAG) THEN IF (III .NE. LEAF) THEN CALL SMUMPS_GET_INODE_FROM_POOL & (IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF ENDIF GOTO 50 60 CONTINUE IF (KEEP(400) .GT. 0 ) THEN UNDERL0MAP = L0_OMP_MAPPING(STEP(INODE)) ELSE UNDERL0MAP = 0 ENDIF IF (UNDERL0MAP .EQ. 0 .OR. KEEP(201).GT.0) THEN CALL SMUMPS_SET_STATIC_PTR(A) CALL SMUMPS_GET_TMP_PTR(A_PTR) LA_PTR = LA ELSE A_PTR => L0_OMP_FACTORS(UNDERL0MAP)%A LA_PTR = L0_OMP_FACTORS(UNDERL0MAP)%LA ENDIF CALL SMUMPS_SOLVE_NODE_FWD( INODE, & huge(INODE), huge(INODE), & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, N, & IPOOL, LPOOL, LEAF, NBFIN, NSTK, & IWCB, LIWCB, WCB, LWCB, A_PTR(1), LA_PTR, & IW, LIW, NRHS, & POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE & , FROM_PP & , ERROR_WAS_BROADCASTED & ) IF ( INFO(1) .LT. 0 ) THEN IF (.NOT. ERROR_WAS_BROADCASTED) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF GOTO 260 ENDIF IFATH = DAD(STEP(INODE)) IF ( IFATH .EQ. 0 ) THEN MYROOT_LEFT = MYROOT_LEFT - 1 IF (MYROOT_LEFT .EQ. 0) THEN NBFIN = NBFIN - 1 IF (SLAVEF .GT. 1) THEN CALL SMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, & COMM, RACINE_SOLVE, SLAVEF, KEEP) ENDIF END IF ELSE IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IFATH)), KEEP(199)) & .EQ. MYID ) THEN IF ( PTRICB(STEP(INODE)) .EQ. 1 .OR. & PTRICB(STEP(INODE)) .EQ. -1 ) THEN NSTK(STEP(IFATH)) = NSTK(STEP(IFATH)) - 1 IF (NSTK(STEP(IFATH)) .EQ. 0) THEN IPOOL(LEAF) = IFATH LEAF = LEAF + 1 IF (LEAF .GT. LPOOL) THEN WRITE(*,*) & 'Internal error SMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() ENDIF ENDIF PTRICB(STEP(INODE)) = 0 ENDIF ENDIF ENDIF IF ( NBFIN .EQ. 0 ) GOTO 260 GOTO 50 260 CONTINUE CALL MUMPS_CLEAN_PENDING(INFO(1), KEEP, BUFR, LBUFR,LBUFR_BYTES, & COMM, DUMMY(1), & SLAVEF, .TRUE., .FALSE.) RETURN END SUBROUTINE SMUMPS_SOL_R MUMPS_5.8.1/src/cfac_scalings_simScaleAbs.F0000664000175000017500000017440115042446441020374 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SIMSCALEABS(IRN_loc, JCN_loc, A_loc, NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, SYM, NB1, NB2, NB3, EPS, & ONENORMERR,INFNORMERR) C---------------------------------------------------------------------- C IF SYM=0 CALLs unsymmetric variant CMUMPS_SIMSCALEABSUNS. C IF SYM=2 CALLS symmetric variant where only one of a_ij and a_ji C is stored. CMUMPS_SIMSCALEABSSYM C--------------------------------------------------------------------- C For details, see the two subroutines below C CMUMPS_SIMSCALEABSUNS and CMUMPS_SIMSCALEABSSYM C --------------------------------------------------------------------- C !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) NZ_loc INTEGER(8) :: IWRKSZ INTEGER(8) :: ISZWRKRC, LWRKR_TH, LWRKC_TH INTEGER :: NOMP_MAX INTEGER M, N, OP INTEGER NUMPROCS, MYID, COMM INTEGER(8) :: INTSZ, RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) COMPLEX A_loc(NZ_loc) INTEGER RPARTVEC(M) INTEGER RSNDRCVSZ(2*NUMPROCS) INTEGER CPARTVEC(N) INTEGER CSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER(8) :: REGISTRE(12) REAL ROWSCA(M) REAL COLSCA(N) REAL WRKRC(ISZWRKRC) REAL WRKR_TH(LWRKR_TH,max(NOMP_MAX,1)) REAL WRKC_TH(LWRKC_TH,max(NOMP_MAX,1)) REAL ONENORMERR,INFNORMERR C LOCALS C FOR the scaling phase INTEGER SYM, NB1, NB2, NB3 REAL EPS C EXTERNALS EXTERNAL CMUMPS_SIMSCALEABSUNS,CMUMPS_SIMSCALEABSSYM, & CMUMPS_INITREAL C MUST HAVE IT INTEGER I INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER :: NOMP !$ INTEGER :: CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = omp_get_max_threads() !$ CHUNK= max(K361/2, (N+NOMP-1) / NOMP ) !$ ENDIF IF(SYM.EQ.0) THEN CALL CMUMPS_SIMSCALEABSUNS(IRN_loc, JCN_loc, A_loc, & NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, NOMP_MAX, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) ELSE CALL CMUMPS_SIMSCALEABSSYM(IRN_loc, JCN_loc, A_loc, & NZ_loc, & N, NUMPROCS, MYID, COMM, & RPARTVEC, & RSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, NOMP_MAX, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) IF (OP.EQ.2) THEN IF (NOMP_MAX.LE.0) THEN DO I=1,N COLSCA(I) = ROWSCA(I) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1,N COLSCA(I) = ROWSCA(I) ENDDO ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SIMSCALEABS SUBROUTINE CMUMPS_SIMSCALEABSUNS(IRN_loc, JCN_loc, A_loc, NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, NOMP_MAX, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) C---------------------------------------------------------------------- C Input parameters: C M, N: size of matrix (in general M=N, but the algorithm C works for rectangular matrices as well (norms other than C inf-norm are not possible mathematically in this case). C NUMPROCS, MYID, COMM: guess what are those C RPARTVEC: row partvec to be filled when OP=1 C CPARTVEC: col partvec to be filled when OP=1 C RSNDRCVSZ: send recv sizes for row operations. C to be filled when OP=1 C CSNDRCVSZ: send recv sizes for col operations. C to be filled when OP=1 C REGISTRE: to store some pointers (size etc) C IWRK: working space. when OP=1 IWRKSZ.GE.4*MAXMN C when OP=2 INTSZ portion is used. Thus, IWRKSZ>INTSZ C when OP=2 C IWRKSZ: size C INTSZ: to be computed when OP=1, necessary integer space to run C scaling algo when OP=2 C RESZ: to be computed when OP=1, necessary real space to run C scaling algo when OP=2 C OP: C =1 estimation of memory and construction of partvecs C writes into RPARTVEC,CPARTVEC,RSNDRCVSZ,CSNDRCVSZ,REGISTRE C does not access WRKRC, uses IWRK as workspace C computes INTSZ and RESZ. C =2 Compute scalings C restores pointers from REGISTRE, C stores communication structure in IWRK (from the start). C C ROWSCA: space for row scaling factor; has size M C COLSCA: space for col scaling factor; has size N C WRKRC: real working space. when OP=1, is not accessed. Thus, it C can be declared to be of size 1 at OP=1 call. C ISZWRKRC: size C SYM: is matrix symmetric C NB1, NB2, NB3: algo runs C NB1 iters of inf-norm (default 1/1), C NB2 iters of 1-norm (default 3/10), C NB3 iters of inf-norm (default 3/10). C in succession. C EPS: tolerance for concergence. C IF EPS < 0.R0 then does not test convergence. C If convergence occured during the first set of inf-norm C iterations, we start performing one-norm iterations. C If convergence occured during the one-norm iterations, C we start performing the second set of inf-norm iterations. C If convergence occured during the second set of inf-norm, C we prepare to return. C ONENORMERR : error in one norm scaling (associated with the scaling C arrays of the previous iterations), C INFNORMERR : error in inf norm scaling (associated with the scaling C arrays of the previous iterations). C--------------------------------------------------------------------- C On input: C OP=1==>Requirements C IWRKSZ.GE.4*MAXMN C RPARTVEC of size M C CPARTVEC of size N C RSNDRCVSZ of size 2*NUMPROCS C CSNDRCVSZ of size 2*NUMPROCS C REGISTRE of size 12 C C OP=2==>Requirements C INTSZ .GE. REGISTRE(11) C RESZ .GE. REGISTRE(12) C--------------------------------------------------------------------- C On output: C ROWSCA and COLSCA C at processor 0 of COMM: complete factors. C at other processors : only the ROWSCA(i) or COLSCA(j) C for which there is a nonzero a_i* or a_*j are useful. C ONENORMERR : error in one norm scaling C = -1.0 if iter2=0. C INFNORMERR : error in inf norm scaling C = inf norm error at iter3 if iter3 > 0 C = inf norm error at iter1 if iter1 > 0, iter3=0 C = -1.0 if iter1=iter3=0 C --------------------------------------------------------------------- C References: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C C The parallelization approach is discussed in C [3] P. R. Amestoy, I. S. Duff, D. Ruiz, and B. Ucar, C "A parallel matrix scaling algorithm". C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, Jan'08. C and was supported by ANR-SOLSTICE project (ANR-06-CIS6-010) C --------------------------------------------------------------------- !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER(8) :: IWRKSZ, INTSZ INTEGER(8) :: ISZWRKRC, LWRKR_TH, LWRKC_TH INTEGER :: M, N, OP INTEGER :: NUMPROCS, MYID, COMM, NOMP_MAX INTEGER(8) :: RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) COMPLEX A_loc(NZ_loc) INTEGER RPARTVEC(M) INTEGER CPARTVEC(N) INTEGER RSNDRCVSZ(2*NUMPROCS) INTEGER CSNDRCVSZ(2*NUMPROCS) INTEGER(8) :: REGISTRE(12) INTEGER IWRK(IWRKSZ) REAL ROWSCA(M) REAL COLSCA(N) REAL WRKRC(ISZWRKRC) REAL WRKR_TH(LWRKR_TH,max(NOMP_MAX,1)) REAL WRKC_TH(LWRKC_TH,max(NOMP_MAX,1)) REAL ONENORMERR,INFNORMERR C LOCALS INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER ICSNDRCVNUM, OCSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER ICSNDRCVVOL, OCSNDRCVVOL INTEGER INUMMYR, INUMMYC C IMPORTANT POINTERS INTEGER(8) :: IMYRPTR,IMYCPTR INTEGER(8) :: IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER(8) :: ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER(8) :: ICNGHBPRCS, ICSNDRCVIA,ICSNDRCVJA INTEGER(8) :: OCNGHBPRCS, OCSNDRCVIA,OCSNDRCVJA INTEGER(8) :: ISTATUS, REQUESTS, TMPWORK INTEGER(8) :: ITDRPTR, ITDCPTR, ISRRPTR INTEGER(8) :: OSRRPTR, ISRCPTR, OSRCPTR C FOR the scaling phase INTEGER NB1, NB2, NB3 REAL EPS C Iteration vars INTEGER ITER, IR, IC INTEGER(8) :: NZIND REAL ELM C COMM TAGS.... INTEGER TAG_COMM_COL PARAMETER(TAG_COMM_COL=100) INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) C FUNCTIONS EXTERNAL CMUMPS_CREATEPARTVEC, & CMUMPS_NUMVOLSNDRCV, & CMUMPS_SETUPCOMMS, & CMUMPS_FILLMYROWCOLINDICES, & CMUMPS_INITREAL, & CMUMPS_INITREALLST, & CMUMPS_DOCOMMINF, & CMUMPS_DOCOMM1N REAL CMUMPS_ERRSCALOC REAL CMUMPS_ERRSCA1 INTRINSIC abs REAL RONE, RZERO PARAMETER(RONE=1.0E0,RZERO=0.0E0) C TMP VARS INTEGER(8) :: RESZR, RESZC INTEGER(8) :: INTSZR, INTSZC INTEGER MAXMN INTEGER I, IERROR, IOMP REAL ONEERRROW, ONEERRCOL, ONEERRL, ONEERRG REAL INFERRROW, INFERRCOL, INFERRL, INFERRG LOGICAL OORANGEIND INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER :: NOMP !$ INTEGER :: CHUNK, CHUNK_NZ !$ ! Too large => pb with cache L3 ? !$ ! INTEGER(8) :: CHUNK8 !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = omp_get_max_threads() !$ CHUNK = max(K361/2, (N+NOMP-1) / NOMP ) !$ ! CHUNK8= (NZ_loc+int(NOMP-1,8) / int(NOMP,8) ) ) !$ CHUNK_NZ = max(K361/2, (N+NOMP_MAX-1) / NOMP_MAX ) !$ ENDIF C OORANGEIND = .FALSE. INFERRG = -RONE ONEERRG = -RONE MAXMN = M IF(MAXMN < N) MAXMN = N C Create row partvec and col partvec IF(OP == 1) THEN IF(NUMPROCS > 1) THEN C Check done outside C IF(IWRKSZ.LT.4*MAXMN) THEN ERROR.... CALL CMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, M, N, & IWRK, IWRKSZ, INUMMYR, NOMP_MAX) CALL CMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & JCN_loc, IRN_loc, NZ_loc, & CPARTVEC, N, M, & IWRK, IWRKSZ, INUMMYC, NOMP_MAX) C Compute sndrcv sizes, store them for later use CALL CMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, M, RPARTVEC, & NZ_loc, IRN_loc, N, JCN_loc, & IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM,ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) CALL CMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, N, CPARTVEC, & NZ_loc, JCN_loc, M, IRN_loc, & ICSNDRCVNUM,ICSNDRCVVOL, & OCSNDRCVNUM,OCSNDRCVVOL, & IWRK,IWRKSZ, & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), COMM) INTSZR = int(IRSNDRCVNUM,8) + int(ORSNDRCVNUM,8) + & int(IRSNDRCVVOL,8) + int(ORSNDRCVVOL,8) + & 2_8*int(NUMPROCS+1,8) + int(INUMMYR,8) INTSZC = int(ICSNDRCVNUM,8) + int(OCSNDRCVNUM,8) + & int(ICSNDRCVVOL,8) + int(OCSNDRCVVOL,8) + & 2_8*int(NUMPROCS+1,8) + int(INUMMYC,8) INTSZ = INTSZR + INTSZC + int(MAXMN,8) + & int(MPI_STATUS_SIZE +1,8) * int(NUMPROCS,8) ELSE C NUMPROCS IS 1 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 ICSNDRCVNUM = 0 OCSNDRCVNUM = 0 ICSNDRCVVOL = 0 OCSNDRCVVOL = 0 INUMMYC = 0 INTSZ = 0_8 ENDIF C CALCULATE NECESSARY REAL SPACE RESZR = int(M,8) + int(IRSNDRCVVOL,8) + int(ORSNDRCVVOL,8) RESZC = int(N,8) + int(ICSNDRCVVOL,8) + int(OCSNDRCVVOL,8) RESZ = RESZR + RESZC C CALCULATE NECESSARY INT SPACE C The last maxmn is tmpwork for setup comm and fillmyrowcol REGISTRE(1) = int(IRSNDRCVNUM,8) REGISTRE(2) = int(ORSNDRCVNUM,8) REGISTRE(3) = int(IRSNDRCVVOL,8) REGISTRE(4) = int(ORSNDRCVVOL,8) REGISTRE(5) = int(ICSNDRCVNUM,8) REGISTRE(6) = int(OCSNDRCVNUM,8) REGISTRE(7) = int(ICSNDRCVVOL,8) REGISTRE(8) = int(OCSNDRCVVOL,8) REGISTRE(9) = int(INUMMYR,8) REGISTRE(10) = int(INUMMYC,8) REGISTRE(11) = INTSZ REGISTRE(12) = RESZ ELSE C else of op=1. That is op=2 now. C restore the numbers IRSNDRCVNUM = int(REGISTRE(1)) ORSNDRCVNUM = int(REGISTRE(2)) IRSNDRCVVOL = int(REGISTRE(3)) ORSNDRCVVOL = int(REGISTRE(4)) ICSNDRCVNUM = int(REGISTRE(5)) OCSNDRCVNUM = int(REGISTRE(6)) ICSNDRCVVOL = int(REGISTRE(7)) OCSNDRCVVOL = int(REGISTRE(8)) INUMMYR = int(REGISTRE(9)) INUMMYC = int(REGISTRE(10)) IF(NUMPROCS > 1) THEN C Check done outsize C IF(INTSZ < REGISTRE(11)) THEN ERROR C IF(RESZ < REGISTRE(12)) THEN ERROR C Fill up myrows and my colsX CALL CMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, CPARTVEC, M, N, & IWRK(1_8), INUMMYR, & IWRK(1_8+int(INUMMYR,8)), INUMMYC, & IWRK(1_8+int(INUMMYR,8)+int(INUMMYC,8)), & IWRKSZ-int(INUMMYR,8)-int(INUMMYC,8), NOMP_MAX ) IMYRPTR = 1_8 IMYCPTR = IMYRPTR + int(INUMMYR,8) C Set up comm and run. C set pointers in iwrk (4 parts) C C ROWS [---------------------------------------------] IRNGHBPRCS = IMYCPTR + int(INUMMYC ,8) IRSNDRCVIA = IRNGHBPRCS + int(IRSNDRCVNUM,8) IRSNDRCVJA = IRSNDRCVIA + int(NUMPROCS+1 ,8) ORNGHBPRCS = IRSNDRCVJA + int(IRSNDRCVVOL,8) ORSNDRCVIA = ORNGHBPRCS + int(ORSNDRCVNUM,8) ORSNDRCVJA = ORSNDRCVIA + int(NUMPROCS+1 ,8) C COLS [---------------------------------------------] ICNGHBPRCS = ORSNDRCVJA + int(ORSNDRCVVOL,8) ICSNDRCVIA = ICNGHBPRCS + int(ICSNDRCVNUM,8) ICSNDRCVJA = ICSNDRCVIA + int(NUMPROCS+1 ,8) OCNGHBPRCS = ICSNDRCVJA + int(ICSNDRCVVOL,8) OCSNDRCVIA = OCNGHBPRCS + int(OCSNDRCVNUM,8) OCSNDRCVJA = OCSNDRCVIA + int(NUMPROCS+1 ,8) C C MPI [-----------------] REQUESTS = OCSNDRCVJA + int(OCSNDRCVVOL,8) ISTATUS = REQUESTS + int(NUMPROCS,8) C C TMPWRK [-----------------] TMPWORK = ISTATUS + int(MPI_STATUS_SIZE,8)*int(NUMPROCS,8) CALL CMUMPS_SETUPCOMMS(MYID, NUMPROCS, M, RPARTVEC, & NZ_loc, IRN_loc,N, JCN_loc, & IRSNDRCVNUM, IRSNDRCVVOL, & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_ROW, COMM) CALL CMUMPS_SETUPCOMMS(MYID, NUMPROCS, N, CPARTVEC, & NZ_loc, JCN_loc, M, IRN_loc, & ICSNDRCVNUM, ICSNDRCVVOL, & IWRK(ICNGHBPRCS), & IWRK(ICSNDRCVIA), & IWRK(ICSNDRCVJA), & OCSNDRCVNUM, OCSNDRCVVOL, & IWRK(OCNGHBPRCS),IWRK(OCSNDRCVIA),IWRK(OCSNDRCVJA), & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_COL, COMM) CALL CMUMPS_INITREAL(ROWSCA, M, RZERO, NOMP_MAX) CALL CMUMPS_INITREAL(COLSCA, N, RZERO, NOMP_MAX) CALL CMUMPS_INITREALLST(ROWSCA, M, & IWRK(IMYRPTR),INUMMYR, RONE, NOMP_MAX) CALL CMUMPS_INITREALLST(COLSCA, N, & IWRK(IMYCPTR),INUMMYC, RONE, NOMP_MAX) ELSE CALL CMUMPS_INITREAL(ROWSCA, M, RONE, NOMP_MAX) CALL CMUMPS_INITREAL(COLSCA, N, RONE, NOMP_MAX) ENDIF ITDRPTR = 1_8 ITDCPTR = ITDRPTR + int(M,8) C ISRRPTR = ITDCPTR + int(N,8) OSRRPTR = ISRRPTR + int(IRSNDRCVVOL,8) C ISRCPTR = OSRRPTR + int(ORSNDRCVVOL,8) OSRCPTR = ISRCPTR + int(ICSNDRCVVOL,8) C To avoid bound check errors... IF(NUMPROCS == 1)THEN OSRCPTR = OSRCPTR - 1_8 ISRCPTR = ISRCPTR - 1_8 OSRRPTR = OSRRPTR - 1_8 ISRRPTR = ISRRPTR - 1_8 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1_8 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1_8 IF(ICSNDRCVVOL == 0) ISRCPTR = ISRCPTR - 1_8 IF(OCSNDRCVVOL == 0) OSRCPTR = OSRCPTR - 1_8 ENDIF ITER = 1 DO WHILE (ITER.LE.NB1+NB2+NB3) C{ C ------------------------- C CLEAR temporary Dr and Dc C ------------------------- IF (NOMP_MAX.GT.1 .AND. & (ITER.GT.NB1 .AND.ITER.LE.NB1+NB2) & ) THEN C{ !$OMP PARALLEL !$OMP& PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 IF(NUMPROCS > 1) THEN CALL CMUMPS_ZEROOUT(WRKR_TH(1,IOMP),N, & IWRK(IMYRPTR),INUMMYR, 0) CALL CMUMPS_ZEROOUT(WRKC_TH(1,IOMP),N, & IWRK(IMYCPTR),INUMMYC, 0) ELSE CALL CMUMPS_INITREAL(WRKR_TH(1,IOMP),N, RZERO, & 0) CALL CMUMPS_INITREAL(WRKC_TH(1,IOMP),N, RZERO, & 0) ENDIF !$OMP END PARALLEL C} ELSE C{ IF(NUMPROCS > 1) THEN CALL CMUMPS_ZEROOUT(WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) CALL CMUMPS_ZEROOUT(WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) ELSE CALL CMUMPS_INITREAL(WRKRC(ITDRPTR),M, RZERO, & NOMP_MAX) CALL CMUMPS_INITREAL(WRKRC(ITDCPTR),N, RZERO, & NOMP_MAX) ENDIF C} ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN C ------------------ C INF-NORM ITERATION C ------------------ IF (NOMP_MAX.LE.0) THEN IF((ITER.EQ.1).OR.(OORANGEIND)) THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) IF(WRKRC(IR) int(K361,8) .AND. NOMP .GT. 1) !$OMP& REDUCTION(.OR.:OORANGEIND) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) !$OMP ATOMIC UPDATE WRKRC(IR)= max (ELM, WRKRC(IR)) !$OMP END ATOMIC C IF(WRKRC(ITDRPTR-1_8+int(IR,8)) int4 !$OMP ATOMIC UPDATE WRKRC(ITDCPTR-1_8+int(IC,8)) = & max (ELM,WRKRC(ITDCPTR-1_8+int(IC,8))) !$OMP END ATOMIC ELSE OORANGEIND = .TRUE. ENDIF ENDDO !$OMP END PARALLEL DO ELSEIF(.NOT.OORANGEIND) THEN !$OMP PARALLEL DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) DO NZIND=1,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) C IF(WRKRC(ITDRPTR-1_8+int(IR,8)) 1) THEN CALL CMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, & ICSNDRCVNUM,IWRK(ICNGHBPRCS), & ICSNDRCVVOL,IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), & WRKRC(ISRCPTR), & OCSNDRCVNUM,IWRK(OCNGHBPRCS), & OCSNDRCVVOL,IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), & WRKRC( OSRCPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) C CALL CMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, & IRSNDRCVNUM,IWRK(IRNGHBPRCS), & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM,IWRK(ORNGHBPRCS), & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = CMUMPS_ERRSCALOC(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) C find error for the cols INFERRCOL = CMUMPS_ERRSCALOC(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) C get max of those two errors INFERRL = INFERRCOL IF(INFERRROW > INFERRL ) THEN INFERRL = INFERRROW ENDIF C CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL CMUMPS_UPDATESCALE(COLSCA, & WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) CALL CMUMPS_UPDATESCALE(ROWSCA, & WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE C SINGLE PROCESSOR CASE: INF-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = CMUMPS_ERRSCA1(ROWSCA, & WRKRC(ITDRPTR), M, NOMP_MAX) C find error for the cols INFERRCOL = CMUMPS_ERRSCA1(COLSCA, & WRKRC(ITDCPTR), N, NOMP_MAX) C get max of those two errors INFERRL = INFERRCOL IF(INFERRROW > INFERRL) THEN INFERRL = INFERRROW ENDIF INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL CMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N, & NOMP_MAX) CALL CMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M, & NOMP_MAX) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE C ---------------------------------------- C WE HAVE ITER.GT.NB1 AND ITER.LE.NB1+NB2. C ONE-NORM ITERATION C ---------------------------------------- IF (NOMP_MAX.LE.1) THEN IF((ITER .EQ.1).OR.(OORANGEIND))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) C WRKRC(ITDRPTR-1_8+int(IR,8)) = C & WRKRC(ITDRPTR-1_8+int(IR,8)) + ELM WRKRC(IR) = WRKRC(IR) + ELM WRKRC(ITDCPTR-1_8+int(IC,8)) = & WRKRC(ITDCPTR-1_8+int(IC,8)) + ELM ELSE OORANGEIND = .TRUE. ENDIF ENDDO ELSEIF(.NOT.OORANGEIND) THEN DO NZIND=1,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) C WRKRC(ITDRPTR-1_8+int(IR,8)) = C & WRKRC(ITDRPTR-1_8+int(IR,8)) + ELM WRKRC(IR) = WRKRC(IR) + ELM WRKRC(ITDCPTR-1_8+int(IC,8)) = & WRKRC(ITDCPTR-1_8+int(IC,8)) + ELM ENDDO ENDIF C} ELSE ! NOMP_MAX>1 IF((ITER .EQ.1).OR.(OORANGEIND))THEN !$OMP PARALLEL PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 !$OMP DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) !$OMP& REDUCTION(.OR.:OORANGEIND) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) WRKR_TH(IR,IOMP) = WRKR_TH(IR,IOMP) + ELM IF (IR.NE.IC) & WRKC_TH(IC,IOMP) = WRKC_TH(IC,IOMP) + ELM ELSE OORANGEIND = .TRUE. ENDIF ENDDO !$OMP END DO !$OMP END PARALLEL ELSEIF(.NOT.OORANGEIND) THEN !$OMP PARALLEL PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 !$OMP DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) DO NZIND=1,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) WRKR_TH(IR,IOMP) = WRKR_TH(IR,IOMP) + ELM IF (IR.NE.IC) & WRKC_TH(IC,IOMP) = WRKC_TH(IC,IOMP) + ELM ENDDO !$OMP END DO !$OMP END PARALLEL ENDIF C C For all i on MYID: C Build WRKRC(i) = Sum (WRKR_TH(i,IOMP) C IOMP \in [1:NOMP_MAX] IF(NUMPROCS > 1) THEN CALL CMUMPS_REDUCE_WRK_MPI (WRKRC, N, WRKR_TH, & NOMP_MAX, & IWRK(IMYRPTR),INUMMYR) CALL CMUMPS_REDUCE_WRK_MPI (WRKRC(ITDCPTR), & N, WRKC_TH, NOMP_MAX, & IWRK(IMYCPTR),INUMMYC) ELSE CALL CMUMPS_REDUCE_WRK (WRKRC, N, WRKR_TH, NOMP_MAX) CALL CMUMPS_REDUCE_WRK (WRKRC(ITDCPTR), & N, WRKC_TH, NOMP_MAX) ENDIF C} ENDIF IF(NUMPROCS > 1) THEN CALL CMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, & ICSNDRCVNUM, IWRK(ICNGHBPRCS), & ICSNDRCVVOL, IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), & WRKRC(ISRCPTR), & OCSNDRCVNUM, IWRK(OCNGHBPRCS), & OCSNDRCVVOL, IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), & WRKRC( OSRCPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) C CALL CMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, & IRSNDRCVNUM, IWRK(IRNGHBPRCS), & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM, IWRK(ORNGHBPRCS), & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = CMUMPS_ERRSCALOC(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) C find error for the cols ONEERRCOL = CMUMPS_ERRSCALOC(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) C get max of those two errors ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL ) THEN ONEERRL = ONEERRROW ENDIF C CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL CMUMPS_UPDATESCALE(COLSCA, & WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) CALL CMUMPS_UPDATESCALE(ROWSCA, & WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE C SINGLE-PROCESSOR CASE: ONE-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = CMUMPS_ERRSCA1(ROWSCA, & WRKRC(ITDRPTR), M, NOMP_MAX) C find error for the cols ONEERRCOL = CMUMPS_ERRSCA1(COLSCA, & WRKRC(ITDCPTR), N, NOMP_MAX) C get max of those two errors ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL) THEN ONEERRL = ONEERRROW ENDIF ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL CMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N, & NOMP_MAX) CALL CMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M, & NOMP_MAX) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL CMUMPS_UPDATESCALE(COLSCA, WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) CALL CMUMPS_UPDATESCALE(ROWSCA, WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) C ELSE C SINGLE PROCESSOR CASE: Conv check and update of sca arrays CALL CMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N, & NOMP_MAX) CALL CMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M, & NOMP_MAX) ENDIF ITER = ITER + 1 C} ENDDO ONENORMERR = ONEERRG INFNORMERR = INFERRG IF(NUMPROCS > 1) THEN C{ CALL MPI_REDUCE(ROWSCA, WRKRC(1), M, MPI_REAL, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN DO I=1, M ROWSCA(I) = WRKRC(I) ENDDO ENDIF C Scaling factors are printed C WRITE (6,*) MYID, 'ROWSCA=',ROWSCA C WRITE (6,*) MYID, 'COLSCA=',COLSCA C CALL FLUSH(6) c REduce the whole scaling factors to processor 0 of COMM CALL MPI_REDUCE(COLSCA, WRKRC(1_8+int(M,8)), N, & MPI_REAL, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN C{ IF (NOMP_MAX.LE.0) THEN DO I=1, N COLSCA(I) = WRKRC(int(I,8)+int(M,8)) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1, N COLSCA(I) = WRKRC(int(I,8)+int(M,8)) ENDDO !$OMP END PARALLEL DO ENDIF C} ENDIF C} ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SIMSCALEABSUNS C C C SEPARATOR: Another function begins C C SUBROUTINE CMUMPS_SIMSCALEABSSYM(IRN_loc, JCN_loc, A_loc, NZ_loc, & N, NUMPROCS, MYID, COMM, & PARTVEC, & RSNDRCVSZ, & REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & SCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, NOMP_MAX, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) C---------------------------------------------------------------------- C Input parameters: C N: size of matrix (sym matrix, square). C NUMPROCS, MYID, COMM: guess what are those C PARTVEC: row/col partvec to be filled when OP=1 C RSNDRCVSZ:send recv sizes for row/col operations. C to be filled when OP=1 C REGISTRE: to store some pointers (size etc). Its size is 12, C but we do not use all in this routine. C IWRK: working space. when OP=1 IWRKSZ.GE.2*MAXMN C when OP=2 INTSZ portion is used. Donc, IWRKSZ>INTSZ C when OP=2 C IWRKSZ: size C INTSZ: to be computed when OP=1, necessary integer space to run C scaling algo when OP=2 C RESZ: to be computed when OP=1, necessary real space to run C scaling algo when OP=2 C OP: C =1 estimation of memory and construction of partvecs C writes into PARTVEC,RSNDRCVSZ,REGISTRE C does not access WRKRC, uses IWRK as workspace C computes INTSZ and RESZ. C =2 Compute scalings C restores pointers from REGISTRE, C stores communication structure in IWRK (from the start). C C SCA: space for row/col scaling factor; has size M C WRKRC: real working space. when OP=1, is not accessed. Donc, it C can be declared to be of size 1 at OP=1 call. C ISZWRKRC: size C SYM: is matrix symmetric C NB1, NB2, NB3: algo runs C NB1 iters of inf-norm (default 1/1), C NB2 iters of 1-norm (default 3/10), C NB3 iters of inf-norm (default 3/10). C in succession. C EPS: tolerance for concergence. C IF EPS < 0.R0 then does not test convergence. C See comments for the uns case above. C ONENORMERR : error in one norm scaling (see comments for the C uns case above), C INFNORMERR : error in inf norm scaling (see comments for the C uns case above). C--------------------------------------------------------------------- C On input: C OP=1==>Requirements C IWRKSZ.GE.2*MAXMN XXXX compare with uns variant. C PARTVEC of size N C SNDRCVSZ of size 2*NUMPROCS C REGISTRE of size 12 C C OP=2==>Requirements C INTSZ .GE. REGISTRE(11) C RESZ .GE. REGISTRE(12) C--------------------------------------------------------------------- C On output: C SCA C at processor 0 of COMM: complete factors. C at other processors : only the SCA(i) and SCA(j) C for which there is a nonzero a_ij. C ONENORMERR : error in one norm scaling C = -1.0 if iter2=0. C INFNORMERR : error in inf norm scaling C = inf norm error at iter3 if iter3 > 0 C = inf norm error at iter1 if iter1 > 0, iter3=0 C = -1.0 if iter1=iter3=0 C --------------------------------------------------------------------- C NOTE: some variables are named in such a way that they correspond C to the row variables in unsym case. They are used for both C row and col communications. C --------------------------------------------------------------------- C References: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C C The parallelization approach is based on discussion in C [3] P. R. Amestoy, I. S. Duff, D. Ruiz, and B. Ucar, "A parallel C matrix scaling algorithm", accepted for publication, C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, Jan'08. C and was supported by ANR-SOLSTICE project (ANR-06-CIS6-010) C --------------------------------------------------------------------- !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER N, OP INTEGER(8) :: IWRKSZ, LWRKR_TH INTEGER NUMPROCS, MYID, COMM, NOMP_MAX INTEGER(8) :: 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(8) :: REGISTRE(12) REAL SCA(N) INTEGER(8) :: ISZWRKRC REAL WRKRC(ISZWRKRC), & WRKR_TH(LWRKR_TH, max(NOMP_MAX,1)) C LOCALS INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER INUMMYR C IMPORTANT POINTERS INTEGER(8) :: IMYRPTR,IMYCPTR INTEGER(8) :: IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER(8) :: ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER(8) :: ISTATUS, REQUESTS, TMPWORK INTEGER(8) :: ITDRPTR, ISRRPTR, OSRRPTR REAL ONENORMERR,INFNORMERR C FOR the scaling phase INTEGER NB1, NB2, NB3 REAL EPS C Iteration vars INTEGER ITER, IR, IC INTEGER(8) :: NZIND REAL ELM C COMM TAGS.... INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) C FUNCTIONS EXTERNAL CMUMPS_CREATEPARTVECSYM, & CMUMPS_NUMVOLSNDRCVSYM, & CMUMPS_SETUPCOMMSSYM, & CMUMPS_FILLMYROWCOLINDICESSYM, & CMUMPS_DOCOMMINF, & CMUMPS_DOCOMM1N, & CMUMPS_INITREAL, & CMUMPS_INITREALLST REAL CMUMPS_ERRSCALOC REAL CMUMPS_ERRSCA1 INTRINSIC abs REAL RONE, RZERO PARAMETER(RONE=1.0E0,RZERO=0.0E0) C TMP VARS INTEGER(8) :: INTSZR INTEGER MAXMN INTEGER I, IERROR REAL ONEERRL, ONEERRG REAL INFERRL, INFERRG LOGICAL OORANGEIND INTEGER, PARAMETER :: K361 = 2048 INTEGER :: IOMP !$ INTEGER :: NOMP !$ INTEGER :: CHUNK, CHUNK_NZ !$ ! Too large => pb with cache L3 ? !$ ! INTEGER(8) :: CHUNK8 !$ ! CHUNK8= max(int(K361/2,8), !$ ! & (NZ_loc+int(NOMP-1,8) / int(NOMP,8) ) ) !$ ! CHUNK8 = min(CHUNK8, huge(CHUNK)-1_8) !$ NOMP = omp_get_max_threads() !$ CHUNK= max(K361/2, (N+NOMP-1) / NOMP ) !$ IF (NOMP_MAX.GT.0) THEN !$ CHUNK_NZ = max(K361/2, (N+NOMP_MAX-1) / NOMP_MAX ) !$ ENDIF C OORANGEIND = .FALSE. INFERRG = -RONE ONEERRG = -RONE MAXMN = N IF(OP == 1) THEN C{ IF(NUMPROCS > 1) THEN C Check done outside C IF(IWRKSZ.LT.2*MAXMN) THEN ERROR.... CALL CMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK, IWRKSZ, INUMMYR ) C C Check done outside CALL CMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc, JCN_loc, IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) C C INTSZR = int(IRSNDRCVNUM,8) + int(ORSNDRCVNUM,8) + & int(IRSNDRCVVOL,8) + int(ORSNDRCVVOL,8) + & 2_8*int(NUMPROCS+1,8) + int(INUMMYR,8) INTSZ = INTSZR + int(N,8) + & int(MPI_STATUS_SIZE +1,8) * int(NUMPROCS,8) ELSE C NUMPROCS IS 1 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 INTSZ = 0_8 ENDIF C CALCULATE NECESSARY REAL SPACE RESZ = int(N,8) + int(IRSNDRCVVOL,8) + int(ORSNDRCVVOL,8) REGISTRE(1) = int(IRSNDRCVNUM,8) REGISTRE(2) = int(ORSNDRCVNUM,8) REGISTRE(3) = int(IRSNDRCVVOL,8) REGISTRE(4) = int(ORSNDRCVVOL,8) REGISTRE(9) = int(INUMMYR,8) REGISTRE(11) = INTSZ REGISTRE(12) = RESZ C} ELSE C{ C else of op=1. That is op=2 now. C restore the numbers IRSNDRCVNUM = int(REGISTRE(1)) ORSNDRCVNUM = int(REGISTRE(2)) IRSNDRCVVOL = int(REGISTRE(3)) ORSNDRCVVOL = int(REGISTRE(4)) INUMMYR = int(REGISTRE(9)) IF(NUMPROCS > 1) THEN C Check done outsize C IF(INTSZ < REGISTRE(11)) THEN ERROR C IF(RESZ < REGISTRE(12)) THEN ERROR C Fill up myrows and my colsX CALL CMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK(1), INUMMYR, & IWRK(1+INUMMYR), IWRKSZ-int(INUMMYR,8), NOMP_MAX) IMYRPTR = 1_8 IMYCPTR = IMYRPTR + int(INUMMYR,8) C Set up comm and run. C set pointers in iwrk (3 parts) C C ROWS [---------------------------------------------] IRNGHBPRCS = IMYCPTR IRSNDRCVIA = IRNGHBPRCS + int(IRSNDRCVNUM,8) IRSNDRCVJA = IRSNDRCVIA + int(NUMPROCS+1,8) ORNGHBPRCS = IRSNDRCVJA + int(IRSNDRCVVOL,8) ORSNDRCVIA = ORNGHBPRCS + int(ORSNDRCVNUM,8) ORSNDRCVJA = ORSNDRCVIA + int(NUMPROCS + 1,8) C MPI [-----------------] REQUESTS = ORSNDRCVJA + int(ORSNDRCVVOL,8) ISTATUS = REQUESTS + int(NUMPROCS,8) C TMPWRK [-----------------] TMPWORK = ISTATUS + int(MPI_STATUS_SIZE,8)*int(NUMPROCS,8) CALL CMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc, JCN_loc, & IRSNDRCVNUM, IRSNDRCVVOL, & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_ROW, COMM) CALL CMUMPS_INITREAL(SCA, N, RZERO, NOMP_MAX) CALL CMUMPS_INITREALLST(SCA, N, & IWRK(IMYRPTR),INUMMYR, RONE, NOMP_MAX) ELSE CALL CMUMPS_INITREAL(SCA, N, RONE, NOMP_MAX) ENDIF ITDRPTR = 1_8 ISRRPTR = ITDRPTR + int(N,8) OSRRPTR = ISRRPTR + int(IRSNDRCVVOL,8) C C To avoid bound check errors... IF(NUMPROCS == 1)THEN OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 ENDIF C computation starts ITER = 1 DO WHILE(ITER.LE.NB1+NB2+NB3) C{ C ------------------------- C CLEAR temporary Dr and Dc C ------------------------- IF (NOMP_MAX.GT.1 .AND. & (ITER.GT.NB1 .AND.ITER.LE.NB1+NB2) & ) THEN C if one norm iteration and multithreading activated C WRKR_TH need be initialized and C WRKRC will be set by reduction of WRKR_TH !$OMP PARALLEL !$OMP& PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 IF(NUMPROCS > 1) THEN CALL CMUMPS_ZEROOUT(WRKR_TH(1,IOMP),N, & IWRK(IMYRPTR),INUMMYR, 0) ELSE CALL CMUMPS_INITREAL(WRKR_TH(1,IOMP),N, RZERO, & 0) ENDIF !$OMP END PARALLEL ELSE IF(NUMPROCS > 1) THEN CFIXME Size N should be adjusted to effective size CALL CMUMPS_ZEROOUT(WRKRC(ITDRPTR),N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) ELSE CALL CMUMPS_INITREAL(WRKRC(ITDRPTR),N, RZERO, & NOMP_MAX) ENDIF ENDIF C IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN C ------------------ C{ INF-NORM ITERATION C ------------------ IF (NOMP_MAX.LE.0) THEN IF((ITER .EQ.1).OR.(OORANGEIND))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) IF (WRKRC(IR) int(K361,8) .AND. NOMP .GT. 1) !$OMP& REDUCTION(.OR.:OORANGEIND) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) !$OMP ATOMIC UPDATE WRKRC(IR)= max (ELM, WRKRC(IR)) !$OMP END ATOMIC C IF(WRKRC(ITDRPTR-1_8+int(IR,8)) int(K361,8) .AND. NOMP .GT. 1) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) !$OMP ATOMIC UPDATE WRKRC(IR)= max (ELM, WRKRC(IR)) !$OMP END ATOMIC C IF(WRKRC(ITDRPTR-1_8+int(IR,8)) 1) THEN C{ CALL CMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, & IRSNDRCVNUM,IWRK(IRNGHBPRCS), & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM,IWRK(ORNGHBPRCS), & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) CCCC FIXME #if defined(dev_version) IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = CMUMPS_ERRSCALOC(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL CMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF CCC #endif C} ELSE C{ SINGLE PROCESSOR CASE: INF-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = CMUMPS_ERRSCA1(SCA, & WRKRC(ITDRPTR), N, NOMP_MAX) INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL CMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N, & NOMP_MAX) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF C} ENDIF C} ELSE C ---------------------------------------- C{ WE HAVE ITER.GT.NB1 AND ITER.LE.NB1+NB2. C ONE-NORM ITERATION C ---------------------------------------- IF (NOMP_MAX.LE.1) THEN IF((ITER.EQ.1).OR.(OORANGEIND))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKRC(IR) = WRKRC(IR) + ELM IF(IR.NE.IC) THEN WRKRC(IC) = WRKRC(IC) + ELM ENDIF ELSE OORANGEIND = .TRUE. ENDIF ENDDO ELSEIF(.NOT.OORANGEIND)THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKRC(IR) = WRKRC(IR) + ELM IF(IR.NE.IC) THEN WRKRC(IC) = WRKRC(IC) + ELM ENDIF ENDDO ENDIF ELSE ! NOMP_MAX>1 IF((ITER.EQ.1).OR.(OORANGEIND))THEN !$OMP PARALLEL PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 !$OMP DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) !$OMP& REDUCTION(.OR.:OORANGEIND) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKR_TH(IR,IOMP) = WRKR_TH(IR,IOMP) + ELM IF(IR.NE.IC) THEN WRKR_TH(IC,IOMP) = WRKR_TH(IC,IOMP) + ELM ENDIF ELSE OORANGEIND = .TRUE. ENDIF ENDDO !$OMP END DO !$OMP END PARALLEL ELSEIF(.NOT.OORANGEIND)THEN !$OMP PARALLEL PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 !$OMP DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKR_TH(IR,IOMP) = WRKR_TH(IR,IOMP) + ELM IF(IR.NE.IC) THEN WRKR_TH(IC,IOMP) = WRKR_TH(IC,IOMP) + ELM ENDIF ENDDO !$OMP END DO !$OMP END PARALLEL C} ENDIF C C For all i on MYID: C Build WRKRC(i) = Sum (WRKR_TH(i,IOMP) C IOMP \in [1:NOMP_MAX] IF(NUMPROCS > 1) THEN CALL CMUMPS_REDUCE_WRK_MPI (WRKRC, N, WRKR_TH, & NOMP_MAX, & IWRK(IMYRPTR),INUMMYR) ELSE CALL CMUMPS_REDUCE_WRK (WRKRC, N, WRKR_TH, NOMP_MAX) ENDIF ENDIF IF(NUMPROCS > 1) THEN C{ CALL CMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, & IRSNDRCVNUM, IWRK(IRNGHBPRCS), & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM, IWRK(ORNGHBPRCS), & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = CMUMPS_ERRSCALOC(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) C mpi allreduce. CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL CMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF C} ELSE C{ SINGLE-PROCESSOR CASE: ONE-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = CMUMPS_ERRSCA1(SCA, & WRKRC(ITDRPTR), N, NOMP_MAX) ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL CMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N, & NOMP_MAX) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF C} ENDIF IF(NUMPROCS > 1) THEN CALL CMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) ELSE CALL CMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N, & NOMP_MAX) ENDIF ITER = ITER + 1 C} ENDDO ONENORMERR = ONEERRG INFNORMERR = INFERRG IF(NUMPROCS > 1) THEN C{ CALL MPI_REDUCE(SCA, WRKRC(1), N, MPI_REAL, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN IF (NOMP_MAX.LE.0) THEN DO I=1, N SCA(I) = WRKRC(I) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1, N SCA(I) = WRKRC(I) ENDDO !$OMP END PARALLEL DO ENDIF ENDIF C} ENDIF C} ENDIF RETURN END SUBROUTINE CMUMPS_SIMSCALEABSSYM MUMPS_5.8.1/src/zsol_aux.F0000664000175000017500000016256515042446441015223 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_FREETOPSO( N, KEEP28, IWCB, LIWW, & W, LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER(8), INTENT(IN) :: LWC INTEGER(8), INTENT(INOUT) :: POSWCB INTEGER N,LIWW,IWPOSCB, KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28) INTEGER(8) :: PTRACB(KEEP28) COMPLEX(kind=8) W(LWC) INTEGER SIZFI, SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN DO WHILE ( IWCB( IWPOSCB + 2 ) .eq. 0 ) SIZFR = IWCB( IWPOSCB + 1 ) SIZFI = 2 IWPOSCB = IWPOSCB + SIZFI POSWCB = POSWCB + SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN END DO RETURN END SUBROUTINE ZMUMPS_FREETOPSO SUBROUTINE ZMUMPS_COMPSO(N,KEEP28,IWCB,LIWW,W,LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER(8), INTENT(IN) :: LWC INTEGER(8), INTENT(INOUT) :: POSWCB INTEGER N,LIWW,IWPOSCB,KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28) INTEGER(8) :: PTRACB(KEEP28) COMPLEX(kind=8) W(LWC) INTEGER IPTIW,SIZFI,LONGI INTEGER(8) :: IPTA, LONGR, SIZFR, I8 INTEGER :: I IPTIW = IWPOSCB IPTA = POSWCB LONGI = 0 LONGR = 0_8 IF ( IPTIW .EQ. LIWW ) RETURN 10 CONTINUE IF (IWCB(IPTIW+2).EQ.0) THEN SIZFR = int(IWCB(IPTIW+1),8) SIZFI = 2 IF (LONGI.NE.0) THEN DO 20 I=0,LONGI-1 IWCB(IPTIW + SIZFI - I) = IWCB (IPTIW - I) 20 CONTINUE DO 30 I8=0,LONGR-1 W(IPTA + SIZFR - I8) = W(IPTA - I8) 30 CONTINUE ENDIF DO 40 I=1,KEEP28 IF ((PTRICB(I).LE.(IPTIW+1)).AND. & (PTRICB(I).GT.IWPOSCB) ) THEN PTRICB(I) = PTRICB(I) + SIZFI PTRACB(I) = PTRACB(I) + SIZFR ENDIF 40 CONTINUE IWPOSCB = IWPOSCB + SIZFI IPTIW = IPTIW + SIZFI POSWCB = POSWCB + SIZFR IPTA = IPTA + SIZFR ELSE SIZFR = int(IWCB(IPTIW+1),8) SIZFI = 2 IPTIW = IPTIW + SIZFI LONGI = LONGI + SIZFI IPTA = IPTA + SIZFR LONGR = LONGR + SIZFR ENDIF IF (IPTIW.NE.LIWW) GOTO 10 RETURN END SUBROUTINE ZMUMPS_COMPSO SUBROUTINE ZMUMPS_SOL_X(A, NZ8, N, IRN, ICN, Z, KEEP,KEEP8, & EFF_SIZE_SCHUR, SYM_PERM ) INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) COMPLEX(kind=8), INTENT(IN) :: A(NZ8) DOUBLE PRECISION, INTENT(OUT) :: Z(N) INTEGER, INTENT(IN) :: EFF_SIZE_SCHUR, SYM_PERM(N) INTEGER :: I, J LOGICAL :: SKIP_COLinSchur DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 INTEGER(8) :: K INTRINSIC abs DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE SKIP_COLinSchur = (EFF_SIZE_SCHUR.GT.0) IF (KEEP(264).EQ.0) THEN IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE IF ( SKIP_COLinSchur.AND. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR)) CYCLE IF ( SKIP_COLinSchur.AND. & (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR)) CYCLE Z(I) = Z(I) + abs(A(K)) ENDDO ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE IF ( SKIP_COLinSchur.AND. & ( (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR) & .OR. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR) & ) & ) CYCLE Z(I) = Z(I) + abs(A(K)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)) ENDIF ENDDO ENDIF ELSE IF (KEEP(50) .EQ.0) THEN IF (SKIP_COLinSchur) THEN DO K = 1_8, NZ8 J = ICN(K) IF ( SYM_PERM(J).GT.N-EFF_SIZE_SCHUR ) CYCLE I = IRN(K) IF ( SYM_PERM(I).GT.N-EFF_SIZE_SCHUR ) CYCLE Z(I) = Z(I) + abs(A(K)) ENDDO ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) Z(I) = Z(I) + abs(A(K)) ENDDO ENDIF ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ( SKIP_COLinSchur.AND. & ( (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR) & .OR. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR) & ) & ) CYCLE Z(I) = Z(I) + abs(A(K)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SOL_X SUBROUTINE ZMUMPS_SCAL_X(A, NZ8, N, IRN, ICN, Z, & KEEP, KEEP8, COLSCA, & EFF_SIZE_SCHUR, SYM_PERM ) INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) COMPLEX(kind=8), INTENT(IN) :: A(NZ8) DOUBLE PRECISION, INTENT(IN) :: COLSCA(N) DOUBLE PRECISION, INTENT(OUT) :: Z(N) INTEGER, INTENT(IN) :: EFF_SIZE_SCHUR, SYM_PERM(N) DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 INTEGER :: I, J INTEGER(8) :: K LOGICAL :: SKIP_COLinSchur DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE SKIP_COLinSchur = (EFF_SIZE_SCHUR.GT.0) IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE IF ( SKIP_COLinSchur.AND. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR)) CYCLE IF ( SKIP_COLinSchur.AND. & (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR)) CYCLE Z(I) = Z(I) + abs(A(K)*COLSCA(J)) ENDDO ELSE DO K = 1, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE IF ( SKIP_COLinSchur.AND. & ( (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR) & .OR. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR) & ) & ) CYCLE Z(I) = Z(I) + abs(A(K)*COLSCA(J)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)*COLSCA(I)) ENDIF ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_SCAL_X SUBROUTINE ZMUMPS_SOL_Y(A, NZ8, N, IRN, ICN, RHS, X, R, W, & KEEP,KEEP8) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) COMPLEX(kind=8), INTENT(IN) :: A(NZ8), RHS(N), X(N) DOUBLE PRECISION, INTENT(OUT) :: W(N) COMPLEX(kind=8), INTENT(OUT) :: R(N) INTEGER I, J INTEGER(8) :: K8 DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 COMPLEX(kind=8) D DO I = 1, N R(I) = RHS(I) W(I) = ZERO ENDDO IF (KEEP(264).EQ.0) THEN IF (KEEP(50) .EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. & (J .LT. 1)) CYCLE D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. & (J .LT. 1)) CYCLE D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF (I.NE.J) THEN D = A(K8) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO ENDIF ELSE IF (KEEP(50) .EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF (I.NE.J) THEN D = A(K8) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SOL_Y SUBROUTINE ZMUMPS_SOL_MULR(N, R, W) INTEGER, intent(in) :: N DOUBLE PRECISION, intent(in) :: W(N) COMPLEX(kind=8), intent(inout) :: R(N) INTEGER I DO 10 I = 1, N R(I) = R(I) * W(I) 10 CONTINUE RETURN END SUBROUTINE ZMUMPS_SOL_MULR SUBROUTINE ZMUMPS_SOL_B(N, KASE, X, EST, W, IW, GRAIN) INTEGER, intent(in) :: N INTEGER, intent(inout) :: KASE INTEGER IW(N) COMPLEX(kind=8) W(N), X(N) DOUBLE PRECISION, intent(inout) :: EST INTEGER, intent(in) :: GRAIN INTRINSIC abs, nint, sign INTRINSIC dble INTEGER ZMUMPS_IXAMAX EXTERNAL ZMUMPS_IXAMAX INTEGER ITMAX PARAMETER (ITMAX = 5) INTEGER I, ITER, J, JLAST, JUMP DOUBLE PRECISION ALTSGN DOUBLE PRECISION TEMP SAVE ITER, J, JLAST, JUMP COMPLEX(kind=8) ZERO, ONE PARAMETER( ZERO = (0.0D0,0.0D0) ) PARAMETER( ONE = (1.0D0,0.0D0) ) DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: RONE = 1.0D0 IF (KASE .EQ. 0) THEN DO 10 I = 1, N X(I) = ONE / dble(N) 10 CONTINUE KASE = 1 JUMP = 1 RETURN ENDIF SELECT CASE (JUMP) CASE (1) GOTO 20 CASE(2) GOTO 40 CASE(3) GOTO 70 CASE(4) GOTO 120 CASE(5) GOTO 160 CASE DEFAULT END SELECT 20 CONTINUE IF (N .EQ. 1) THEN W(1) = X(1) EST = abs(W(1)) GOTO 190 ENDIF DO 30 I = 1, N X(I) = cmplx( sign(RONE,dble(X(I))), kind=kind(X)) IW(I) = nint(dble(X(I))) 30 CONTINUE KASE = 2 JUMP = 2 RETURN 40 CONTINUE J = ZMUMPS_IXAMAX(N, X, 1, GRAIN) ITER = 2 50 CONTINUE DO 60 I = 1, N X(I) = ZERO 60 CONTINUE X(J) = ONE KASE = 1 JUMP = 3 RETURN 70 CONTINUE DO 80 I = 1, N W(I) = X(I) 80 CONTINUE DO 90 I = 1, N IF (nint(sign(RONE, dble(X(I)))) .NE. IW(I)) GOTO 100 90 CONTINUE GOTO 130 100 CONTINUE DO 110 I = 1, N X(I) = cmplx( sign(RONE, dble(X(I))), kind=kind(X) ) IW(I) = nint(dble(X(I))) 110 CONTINUE KASE = 2 JUMP = 4 RETURN 120 CONTINUE JLAST = J J = ZMUMPS_IXAMAX(N, X, 1, GRAIN) IF ((abs(X(JLAST)) .NE. abs(X(J))) .AND. (ITER .LT. ITMAX)) THEN ITER = ITER + 1 GOTO 50 ENDIF 130 CONTINUE EST = RZERO DO 140 I = 1, N EST = EST + abs(W(I)) 140 CONTINUE ALTSGN = RONE DO 150 I = 1, N X(I) = cmplx(ALTSGN * (RONE + dble(I - 1) / dble(N - 1)), & kind=kind(X)) ALTSGN = -ALTSGN 150 CONTINUE KASE = 1 JUMP = 5 RETURN 160 CONTINUE TEMP = RZERO DO 170 I = 1, N TEMP = TEMP + abs(X(I)) 170 CONTINUE TEMP = 2.0D0/3.0D0 * TEMP / dble(N) IF (TEMP .GT. EST) THEN DO 180 I = 1, N W(I) = X(I) 180 CONTINUE EST = TEMP ENDIF 190 KASE = 0 RETURN END SUBROUTINE ZMUMPS_SOL_B SUBROUTINE ZMUMPS_QD2( MTYPE, N, NZ8, ASPK, IRN, ICN, & LHS, WRHS, W, RHS, KEEP,KEEP8) IMPLICIT NONE INTEGER MTYPE, N INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(IN) :: IRN( NZ8 ), ICN( NZ8 ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX(kind=8), INTENT(IN) :: ASPK( NZ8 ) COMPLEX(kind=8), INTENT(IN) :: LHS( N ), WRHS( N ) COMPLEX(kind=8), INTENT(OUT):: RHS( N ) DOUBLE PRECISION, INTENT(OUT):: W( N ) INTEGER I, J INTEGER(8) :: K8 DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0 DO I = 1, N W(I) = DZERO RHS(I) = WRHS(I) ENDDO IF ( KEEP(50) .EQ. 0 ) THEN IF (MTYPE .EQ. 1) THEN IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) ENDDO ENDIF ELSE IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDDO ENDIF ENDIF ELSE IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDIF ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_QD2 SUBROUTINE ZMUMPS_ELTQD2( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & LHS, WRHS, W, RHS, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX(kind=8) A_ELT(NA_ELT8) COMPLEX(kind=8) LHS( N ), WRHS( N ), RHS( N ) DOUBLE PRECISION W(N) CALL ZMUMPS_MV_ELT(N, NELT, ELTPTR, ELTVAR, A_ELT, & LHS, RHS, KEEP(50), MTYPE ) RHS = WRHS - RHS CALL ZMUMPS_SOL_X_ELT( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8 ) RETURN END SUBROUTINE ZMUMPS_ELTQD2 SUBROUTINE ZMUMPS_SOL_X_ELT( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX(kind=8) A_ELT(NA_ELT8) DOUBLE PRECISION TEMP DOUBLE PRECISION W(N) INTEGER I, J, IEL, SIZEI, IELPTR INTEGER(8) :: K8 DOUBLE PRECISION DZERO PARAMETER(DZERO = 0.0D0) W = DZERO K8 = 1_8 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( KEEP(50).EQ.0 ) THEN IF (MTYPE.EQ.1) THEN DO J = 1, SIZEI DO I = 1, SIZEI W( ELTVAR( IELPTR + I) ) = & W( ELTVAR( IELPTR + I) ) & + abs(A_ELT( K8 )) K8 = K8 + 1_8 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + abs( A_ELT(K8)) K8 = K8 + 1_8 END DO W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + TEMP END DO ENDIF ELSE DO J = 1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K8 )) K8 = K8 + 1_8 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K8 )) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + abs(A_ELT( K8 )) K8 = K8 + 1_8 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_SOL_X_ELT SUBROUTINE ZMUMPS_SOL_SCALX_ELT(MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8, COLSCA ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION COLSCA(N) COMPLEX(kind=8) A_ELT(NA_ELT8) DOUBLE PRECISION W(N) DOUBLE PRECISION TEMP, TEMP2 INTEGER I, J, IEL, SIZEI, IELPTR INTEGER(8) :: K8 DOUBLE PRECISION DZERO PARAMETER(DZERO = 0.0D0) W = DZERO K8 = 1_8 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( KEEP(50).EQ.0 ) THEN IF (MTYPE.EQ.1) THEN DO J = 1, SIZEI TEMP2 = abs(COLSCA(ELTVAR( IELPTR + J) )) DO I = 1, SIZEI W( ELTVAR( IELPTR + I) ) = & W( ELTVAR( IELPTR + I) ) & + abs(A_ELT( K8 )) * TEMP2 K8 = K8 + 1_8 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) TEMP2= abs(COLSCA(ELTVAR( IELPTR + J) )) DO I = 1, SIZEI TEMP = TEMP + abs(A_ELT( K8 )) * TEMP2 K8 = K8 + 1_8 END DO W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + TEMP END DO ENDIF ELSE DO J = 1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs( A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + J)) ) K8 = K8 + 1_8 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs(A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + J))) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + & abs(A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + I))) K8 = K8 + 1_8 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_SOL_SCALX_ELT SUBROUTINE ZMUMPS_ELTYD( MTYPE, N, NELT, ELTPTR, & LELTVAR, ELTVAR, NA_ELT8, A_ELT, & SAVERHS, X, Y, W, K50 ) IMPLICIT NONE INTEGER N, NELT, K50, MTYPE, LELTVAR INTEGER(8) :: NA_ELT8 INTEGER ELTPTR( NELT + 1 ), ELTVAR( LELTVAR ) COMPLEX(kind=8) A_ELT( NA_ELT8 ), X( N ), Y( N ), & SAVERHS(N) DOUBLE PRECISION W(N) INTEGER IEL, I , J, K, SIZEI, IELPTR DOUBLE PRECISION ZERO COMPLEX(kind=8) TEMP DOUBLE PRECISION TEMP2 PARAMETER( ZERO = 0.0D0 ) Y = SAVERHS W = ZERO K = 1 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( K50 .eq. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN DO J = 1, SIZEI TEMP = X( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) - & A_ELT( K ) * TEMP W( ELTVAR( IELPTR + I ) ) = & W( ELTVAR( IELPTR + I ) ) + & abs( A_ELT( K ) * TEMP ) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) TEMP2 = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP - & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) TEMP2 = TEMP2 + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) K = K + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP W( ELTVAR( IELPTR + J ) ) = TEMP2 END DO END IF ELSE DO J = 1, SIZEI Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) W( ELTVAR( IELPTR + J ) ) = & W( ELTVAR( IELPTR + J ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) K = K + 1 DO I = J+1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) W( ELTVAR( IELPTR + I ) ) = & W( ELTVAR( IELPTR + I ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) W( ELTVAR( IELPTR + J ) ) = & W( ELTVAR( IELPTR + J ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) K = K + 1 END DO END DO END IF END DO RETURN END SUBROUTINE ZMUMPS_ELTYD SUBROUTINE ZMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) USE ZMUMPS_OOC IMPLICIT NONE INTEGER INODE,KEEP(500),N INTEGER(8) KEEP8(150) INTEGER(8) :: LA INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER IERR COMPLEX(kind=8) A(LA) INTEGER RETURN_VALUE LOGICAL MUST_BE_PERMUTED RETURN_VALUE=ZMUMPS_SOLVE_IS_INODE_IN_MEM(INODE,PTRFAC, & KEEP(28),A,LA,IERR) IF(RETURN_VALUE.EQ.OOC_NODE_NOT_IN_MEM)THEN IF(IERR.LT.0)THEN RETURN ENDIF CALL ZMUMPS_SOLVE_ALLOC_FACTOR_SPACE(INODE,PTRFAC, & KEEP,KEEP8,A,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL ZMUMPS_READ_OOC( & A(PTRFAC(STEP(INODE))), & INODE,IERR & ) IF(IERR.LT.0)THEN RETURN ENDIF ELSE IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF(RETURN_VALUE.NE.OOC_NODE_PERMUTED)THEN MUST_BE_PERMUTED=.TRUE. CALL ZMUMPS_SOLVE_MODIFY_STATE_NODE(INODE) ELSE MUST_BE_PERMUTED=.FALSE. ENDIF RETURN END SUBROUTINE ZMUMPS_SOLVE_GET_OOC_NODE SUBROUTINE ZMUMPS_BUILD_MAPPING_INFO(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' TYPE(ZMUMPS_STRUC), TARGET :: id INTEGER, ALLOCATABLE, DIMENSION(:) :: LOCAL_LIST INTEGER :: I,IERR,TMP,NSTEPS,N_LOCAL_LIST INTEGER :: MASTER,TAG_SIZE,TAG_LIST INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: I_AM_SLAVE PARAMETER(MASTER=0, TAG_SIZE=85,TAG_LIST=86) I_AM_SLAVE = (id%MYID .NE. MASTER & .OR. ((id%MYID.EQ.MASTER).AND.(id%KEEP(46).EQ.1))) NSTEPS = id%KEEP(28) ALLOCATE(LOCAL_LIST(NSTEPS),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating LOCAL_LIST' CALL MUMPS_ABORT() END IF N_LOCAL_LIST = 0 IF(I_AM_SLAVE) THEN DO I=1,NSTEPS IF(id%PTLUST_S(I).NE.0) THEN N_LOCAL_LIST = N_LOCAL_LIST + 1 LOCAL_LIST(N_LOCAL_LIST) = I END IF END DO IF(id%MYID.NE.MASTER) THEN CALL MPI_SEND(N_LOCAL_LIST, 1, & MPI_INTEGER, MASTER, TAG_SIZE, id%COMM,IERR) CALL MPI_SEND(LOCAL_LIST, N_LOCAL_LIST, & MPI_INTEGER, MASTER, TAG_LIST, id%COMM,IERR) DEALLOCATE(LOCAL_LIST) ALLOCATE(id%IPTR_WORKING(1), & id%WORKING(1), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating ', & 'IPTR_WORKING and WORKING' CALL MUMPS_ABORT() END IF END IF END IF IF(id%MYID.EQ.MASTER) THEN ALLOCATE(id%IPTR_WORKING(id%NPROCS+1), STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating IPTR_WORKING' CALL MUMPS_ABORT() END IF id%IPTR_WORKING = 0 id%IPTR_WORKING(1) = 1 id%IPTR_WORKING(MASTER+2) = N_LOCAL_LIST DO I=1, id%NPROCS-1 CALL MPI_RECV(TMP, 1, MPI_INTEGER, MPI_ANY_SOURCE, & TAG_SIZE, id%COMM, STATUS, IERR) id%IPTR_WORKING(STATUS(MPI_SOURCE)+2) = TMP END DO DO I=2, id%NPROCS+1 id%IPTR_WORKING(I) = id%IPTR_WORKING(I) & + id%IPTR_WORKING(I-1) END DO ALLOCATE(id%WORKING(id%IPTR_WORKING(id%NPROCS+1)-1),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating LOCAL_LIST' CALL MUMPS_ABORT() END IF TMP = MASTER + 1 IF (I_AM_SLAVE) THEN id%WORKING(id%IPTR_WORKING(TMP):id%IPTR_WORKING(TMP+1)-1) & = LOCAL_LIST(1:id%IPTR_WORKING(TMP+1) & -id%IPTR_WORKING(TMP)) ENDIF DO I=1,id%NPROCS-1 CALL MPI_RECV(LOCAL_LIST, NSTEPS, MPI_INTEGER, & MPI_ANY_SOURCE, TAG_LIST, id%COMM, STATUS, IERR) TMP = STATUS(MPI_SOURCE)+1 id%WORKING(id%IPTR_WORKING(TMP):id%IPTR_WORKING(TMP+1)-1) & = LOCAL_LIST(1:id%IPTR_WORKING(TMP+1)- & id%IPTR_WORKING(TMP)) END DO DEALLOCATE(LOCAL_LIST) END IF END SUBROUTINE ZMUMPS_BUILD_MAPPING_INFO SUBROUTINE ZMUMPS_SOL_OMEGA(N, RHS, & X, Y, R_W, C_W, IW, IFLAG, & OMEGA, NOITER, TESTConv, & LP, ARRET, GRAIN, CGCE ) IMPLICIT NONE INTEGER N, IFLAG INTEGER IW(N,2) COMPLEX(kind=8) RHS(N) COMPLEX(kind=8) X(N), Y(N) DOUBLE PRECISION R_W(N,2) COMPLEX(kind=8) C_W(N) INTEGER LP, NOITER LOGICAL TESTConv DOUBLE PRECISION OMEGA(2) DOUBLE PRECISION ARRET DOUBLE PRECISION CGCE INTEGER, intent(in) :: GRAIN DOUBLE PRECISION, PARAMETER :: CTAU=1.0D3 INTEGER I, IMAX DOUBLE PRECISION OM1, OM2, DXMAX DOUBLE PRECISION TAU, DD DOUBLE PRECISION OLDOMG(2) DOUBLE PRECISION, PARAMETER :: ZERO=0.0D0 DOUBLE PRECISION, PARAMETER :: ONE=1.0D0 INTEGER ZMUMPS_IXAMAX SAVE OM1, OLDOMG IMAX = ZMUMPS_IXAMAX(N, X, 1, GRAIN) DXMAX = abs(X(IMAX)) OMEGA(1) = ZERO OMEGA(2) = ZERO DO I = 1, N TAU = (R_W(I, 2) * DXMAX + abs(RHS(I))) * dble(N) * CTAU DD = R_W(I, 1) + abs(RHS(I)) IF (DD .GT. TAU * epsilon(CTAU)) THEN OMEGA(1) = max(OMEGA(1), abs(Y(I)) / DD) IW(I, 1) = 1 ELSE IF (TAU .GT. ZERO) THEN OMEGA(2) = max(OMEGA(2), & abs(Y(I)) / (DD + R_W(I, 2) * DXMAX)) ENDIF IW(I, 1) = 2 ENDIF ENDDO IF (TESTConv) THEN OM2 = OMEGA(1) + OMEGA(2) IF (OM2 .LT. ARRET ) THEN IFLAG = 1 GOTO 70 ENDIF IF (NOITER .GE. 1) THEN IF (OM2 .GT. OM1 * CGCE) THEN IF (OM2 .GT. OM1) THEN OMEGA(1) = OLDOMG(1) OMEGA(2) = OLDOMG(2) DO I = 1, N X(I) = C_W(I) ENDDO IFLAG = 2 GOTO 70 ENDIF IFLAG = 3 GOTO 70 ENDIF ENDIF DO I = 1, N C_W(I) = X(I) ENDDO OLDOMG(1) = OMEGA(1) OLDOMG(2) = OMEGA(2) OM1 = OM2 ENDIF IFLAG = 0 RETURN 70 CONTINUE RETURN END SUBROUTINE ZMUMPS_SOL_OMEGA SUBROUTINE ZMUMPS_SOL_LCOND(N, RHS, & X, Y, D, R_W, C_W, IW, KASE, & OMEGA, ERX, COND, & LP, KEEP,KEEP8 ) IMPLICIT NONE INTEGER N, KASE, KEEP(500) INTEGER(8) KEEP8(150) INTEGER IW(N,2) COMPLEX(kind=8) RHS(N) COMPLEX(kind=8) X(N), Y(N) DOUBLE PRECISION D(N) DOUBLE PRECISION R_W(N,2) COMPLEX(kind=8) C_W(N) INTEGER LP DOUBLE PRECISION COND(2),OMEGA(2) LOGICAL LCOND1, LCOND2 INTEGER JUMP, I, IMAX DOUBLE PRECISION ERX, DXMAX DOUBLE PRECISION DXIMAX DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: ONE = 1.0D0 INTEGER ZMUMPS_IXAMAX INTRINSIC abs SAVE LCOND1, LCOND2, JUMP, DXIMAX, DXMAX IF (KASE .EQ. 0) THEN LCOND1 = .FALSE. LCOND2 = .FALSE. COND(1) = ONE COND(2) = ONE ERX = ZERO JUMP = 1 ENDIF SELECT CASE (JUMP) CASE (1) GOTO 30 CASE(2) GOTO 10 CASE(3) GOTO 110 CASE(4) GOTO 150 CASE(5) GOTO 35 CASE DEFAULT END SELECT 10 CONTINUE 30 CONTINUE 35 CONTINUE IMAX = ZMUMPS_IXAMAX(N, X, 1, KEEP(361)) DXMAX = abs(X(IMAX)) DO I = 1, N IF (IW(I, 1) .EQ. 1) THEN R_W(I, 1) = R_W(I, 1) + abs(RHS(I)) R_W(I, 2) = ZERO LCOND1 = .TRUE. ELSE R_W(I, 2) = R_W(I, 2) * DXMAX + R_W(I, 1) R_W(I, 1) = ZERO LCOND2 = .TRUE. ENDIF ENDDO DO I = 1, N C_W(I) = X(I) * D(I) ENDDO IMAX = ZMUMPS_IXAMAX(N, C_W(1), 1, KEEP(361)) DXIMAX = abs(C_W(IMAX)) IF (.NOT.LCOND1) GOTO 130 100 CONTINUE CALL ZMUMPS_SOL_B(N, KASE, Y, COND(1), C_W, IW(1, 2), KEEP(361)) IF (KASE .EQ. 0) GOTO 120 IF (KASE .EQ. 1) CALL ZMUMPS_SOL_MULR(N, Y, D) IF (KASE .EQ. 2) CALL ZMUMPS_SOL_MULR(N, Y, R_W) JUMP = 3 RETURN 110 CONTINUE IF (KASE .EQ. 1) CALL ZMUMPS_SOL_MULR(N, Y, R_W) IF (KASE .EQ. 2) CALL ZMUMPS_SOL_MULR(N, Y, D) GOTO 100 120 CONTINUE IF (DXIMAX .GT. ZERO) COND(1) = COND(1) / DXIMAX ERX = OMEGA(1) * COND(1) 130 CONTINUE IF (.NOT.LCOND2) GOTO 170 KASE = 0 140 CONTINUE CALL ZMUMPS_SOL_B(N, KASE, Y, COND(2), C_W, IW(1, 2), KEEP(361)) IF (KASE .EQ. 0) GOTO 160 IF (KASE .EQ. 1) CALL ZMUMPS_SOL_MULR(N, Y, D) IF (KASE .EQ. 2) CALL ZMUMPS_SOL_MULR(N, Y, R_W(1, 2)) JUMP = 4 RETURN 150 CONTINUE IF (KASE .EQ. 1) CALL ZMUMPS_SOL_MULR(N, Y, R_W(1, 2)) IF (KASE .EQ. 2) CALL ZMUMPS_SOL_MULR(N, Y, D) GOTO 140 160 IF (DXIMAX .GT. ZERO) THEN COND(2) = COND(2) / DXIMAX ENDIF ERX = ERX + OMEGA(2) * COND(2) 170 CONTINUE RETURN END SUBROUTINE ZMUMPS_SOL_LCOND SUBROUTINE ZMUMPS_SOL_CPY_FS2RHSINTR( JBDEB, JBFIN, NBROWS, & KEEP, RHSINTR, NRHS, LRHSINTR, FIRST_ROW_RHSINTR, W, LD_W, & FIRST_ROW_W ) INTEGER :: JBDEB, JBFIN, NBROWS INTEGER :: NRHS, LRHSINTR INTEGER :: FIRST_ROW_RHSINTR INTEGER, INTENT(IN) :: KEEP(500) COMPLEX(kind=8), INTENT(INOUT) :: RHSINTR(LRHSINTR,NRHS) INTEGER :: LD_W, FIRST_ROW_W COMPLEX(kind=8) :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER :: JJ, K, ISHIFT !$OMP PARALLEL DO PRIVATE(ISHIFT, JJ), IF !$OMP& (JBFIN-JBDEB+1 > 2*KEEP(362) .AND. !$OMP& NBROWS * (JBFIN-JBDEB+1) > 2*KEEP(363)) DO K = JBDEB, JBFIN ISHIFT = FIRST_ROW_W + LD_W * (K-JBDEB) DO JJ = 0, NBROWS-1 RHSINTR(FIRST_ROW_RHSINTR+JJ,K) = W(ISHIFT+JJ) END DO END DO !$OMP END PARALLEL DO RETURN END SUBROUTINE ZMUMPS_SOL_CPY_FS2RHSINTR SUBROUTINE ZMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSINTR, NRHS, LRHSINTR, W, LD_W, FIRST_ROW_W, & IW, LIW, KEEP, N, POSINRHSINTR_BWD ) INTEGER, INTENT(IN) :: JBDEB, JBFIN, J1, J2 INTEGER, INTENT(IN) :: NRHS, LRHSINTR INTEGER, INTENT(IN) :: FIRST_ROW_W, LD_W, LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: KEEP(500) COMPLEX(kind=8), INTENT(INOUT) :: RHSINTR(LRHSINTR,NRHS) COMPLEX(kind=8) :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: POSINRHSINTR_BWD(N) INTEGER :: ISHIFT, JJ, K, IPOSINRHSINTR !$OMP PARALLEL DO PRIVATE(JJ,ISHIFT,IPOSINRHSINTR), IF !$OMP& ((JBFIN-JBDEB+1 > 2*KEEP(362) .AND. !$OMP& (JBFIN-JBDEB+1)*(J2-KEEP(253)-J1+1)>2*KEEP(363))) DO K=JBDEB, JBFIN ISHIFT = FIRST_ROW_W+(K-JBDEB)*LD_W DO JJ = J1, J2-KEEP(253) IPOSINRHSINTR = abs(POSINRHSINTR_BWD(IW(JJ))) W(ISHIFT+JJ-J1)= RHSINTR(IPOSINRHSINTR,K) ENDDO ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE ZMUMPS_SOL_BWD_GTHR SUBROUTINE ZMUMPS_SOL_Q(MTYPE, IFLAG, N, & LHS, WRHS, W, RES, GIVNORM, ANORM, XNORM, SCLNRM, & MPRINT, ICNTL, KEEP,KEEP8) INTEGER MTYPE,N,IFLAG,ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) COMPLEX(kind=8) RES(N),LHS(N) COMPLEX(kind=8) WRHS(N) DOUBLE PRECISION W(N) DOUBLE PRECISION RESMAX,RESL2,XNORM, SCLNRM DOUBLE PRECISION ANORM,DZERO LOGICAL GIVNORM,PROK INTEGER MPRINT, MP INTEGER K INTRINSIC abs, max, sqrt MP = ICNTL(2) PROK = (MPRINT .GT. 0) DZERO = 0.0D0 IF (.NOT.GIVNORM) ANORM = DZERO RESMAX = DZERO RESL2 = DZERO DO 40 K = 1, N RESMAX = max(RESMAX, abs(RES(K))) RESL2 = RESL2 + abs(RES(K)) * abs(RES(K)) IF (.NOT.GIVNORM) ANORM = max(ANORM, W(K)) 40 CONTINUE XNORM = DZERO DO 50 K = 1, N XNORM = max(XNORM, abs(LHS(K))) 50 CONTINUE IF ( XNORM .EQ. DZERO .OR. (exponent(XNORM) .LT. & minexponent(XNORM) + KEEP(122) ) & .OR. & ( exponent(ANORM)+exponent(XNORM) .LT. & minexponent(XNORM) + KEEP(122) ) & .OR. & ( exponent(ANORM) + exponent(XNORM) -exponent(RESMAX) & .LT. minexponent(XNORM) + KEEP(122) ) & ) THEN IF (mod(IFLAG/2,2) .EQ. 0) THEN IFLAG = IFLAG + 2 ENDIF IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) & ' max-NORM of computed solut. is zero or close to zero. ' ENDIF IF (RESMAX .EQ. DZERO) THEN SCLNRM = DZERO ELSE SCLNRM = RESMAX / (ANORM * XNORM) ENDIF RESL2 = sqrt(RESL2) IF (PROK) WRITE( MPRINT, 90 ) RESMAX, RESL2, ANORM, XNORM, & SCLNRM 90 FORMAT (/' RESIDUAL IS ............ (INF-NORM) =',1PD9.2/ & ' .. (2-NORM) =',1PD9.2/ & ' RINFOG(4):NORM OF input Matrix (INF-NORM)=',1PD9.2/ & ' RINFOG(5):NORM OF Computed SOLUT (INF-NORM)=',1PD9.2/ & ' RINFOG(6):SCALED RESIDUAL ...... (INF-NORM)=',1PD9.2) RETURN END SUBROUTINE ZMUMPS_SOL_Q SUBROUTINE ZMUMPS_SOLVE_FWD_TRSOLVE (A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LDADIAG, NPIV, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT COMPLEX(kind=8), INTENT(IN) :: A(LA) COMPLEX(kind=8), INTENT(INOUT) :: WCB(LWCB) COMPLEX(kind=8) ONE PARAMETER ( ONE=(1.0D0,0.0D0) ) IF (KEEP(50).NE.0 .OR. MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ztrsv( 'U', 'T', 'U', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ztrsm( 'L','U','T','U', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ztrsv( 'L', 'N', 'N', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ztrsm( 'L','L','N','N', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF RETURN END SUBROUTINE ZMUMPS_SOLVE_FWD_TRSOLVE SUBROUTINE ZMUMPS_SOLVE_BWD_TRSOLVE (A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LDADIAG, NPIV, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT COMPLEX(kind=8), INTENT(IN) :: A(LA) COMPLEX(kind=8), INTENT(INOUT) :: WCB(LWCB) COMPLEX(kind=8) ONE PARAMETER ( ONE=(1.0D0,0.0D0) ) IF (MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ztrsv( 'L', 'T', 'N', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ztrsm( 'L','L','T','N', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ztrsv( 'U', 'N', 'U', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ztrsm( 'L','U','N','U', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF RETURN END SUBROUTINE ZMUMPS_SOLVE_BWD_TRSOLVE SUBROUTINE ZMUMPS_SOLVE_FWD_PANELS( & A, LA, APOS, NPIV, IW, & NRHS_B, WCB, LWCB, LDA_WCB, & PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, NPIV, KEEP(500) INTEGER, INTENT(IN) :: IW(NPIV) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT COMPLEX(kind=8), INTENT(IN) :: A(LA) COMPLEX(kind=8), INTENT(INOUT) :: WCB(LWCB) INTEGER :: NB_TARGET INTEGER :: NBPANELS INTEGER :: NBROWS_PANEL, NBCOLS_PANEL, ICOL_BEG, ICOL_END INTEGER(8) :: PANEL_APOS, PPIV_PANEL COMPLEX(kind=8), PARAMETER :: ONE=(1.0D0,0.0D0) IF (KEEP(459) .LE. 1) THEN WRITE(*,*) " Internal error in ZMUMPS_SOLVE_FWD_PANELS" CALL MUMPS_ABORT() ENDIF CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, NB_TARGET, KEEP ) PANEL_APOS = APOS NBPANELS = 0 ICOL_BEG = 1 NBROWS_PANEL = NPIV PPIV_PANEL = PPIV_COURANT DO WHILE ( ICOL_BEG .LE. NPIV ) NBPANELS = NBPANELS + 1 ICOL_END = min(NB_TARGET * NBPANELS, NPIV) IF ( IW(ICOL_END) .LT. 0 ) ICOL_END=ICOL_END+1 NBCOLS_PANEL = ICOL_END - ICOL_BEG + 1 CALL ZMUMPS_SOLVE_FWD_TRSOLVE (A, LA, PANEL_APOS, & NBCOLS_PANEL, NBCOLS_PANEL, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_PANEL, MTYPE, KEEP) IF ( NBROWS_PANEL .GT. NBCOLS_PANEL ) THEN CALL ZMUMPS_SOLVE_GEMM_UPDATE( A, LA, & PANEL_APOS + int(NBCOLS_PANEL,8) * int(NBCOLS_PANEL,8), & NBCOLS_PANEL, NBCOLS_PANEL, NBROWS_PANEL-NBCOLS_PANEL, & NRHS_B, WCB, LWCB, PPIV_PANEL, LDA_WCB, & PPIV_PANEL+NBCOLS_PANEL, LDA_WCB, & MTYPE, KEEP, ONE ) ENDIF ICOL_BEG = ICOL_END + 1 PANEL_APOS = PANEL_APOS + int(NBCOLS_PANEL,8) * & int(NBROWS_PANEL,8) NBROWS_PANEL = NBROWS_PANEL - NBCOLS_PANEL PPIV_PANEL = PPIV_PANEL + NBCOLS_PANEL ENDDO RETURN END SUBROUTINE ZMUMPS_SOLVE_FWD_PANELS SUBROUTINE ZMUMPS_SOLVE_BWD_PANELS( & A, LA, APOS, NPIV, IW, & NRHS_B, WCB, LWCB, LDA_WCB, & PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, NPIV, KEEP(500) INTEGER, INTENT(IN) :: IW(NPIV) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT COMPLEX(kind=8), INTENT(IN) :: A(LA) COMPLEX(kind=8), INTENT(INOUT) :: WCB(LWCB) INTEGER, PARAMETER :: PANEL_TABSIZE = 20 INTEGER(8) :: PANEL_POS(PANEL_TABSIZE) INTEGER :: PANEL_COL(PANEL_TABSIZE) INTEGER :: IPANEL, NBPANELS, NB_TARGET INTEGER :: NBROWS_PANEL, NBCOLS_PANEL INTEGER(8) :: PPIV_PANEL INTEGER :: MTYPE_TEMP COMPLEX(kind=8), PARAMETER :: ONE=(1.0D0,0.0D0) IF (KEEP(459) .LE. 1) THEN WRITE(*,*) " Internal error 1 in ZMUMPS_SOLVE_BWD_PANELS" CALL MUMPS_ABORT() ENDIF IF ( KEEP(459)+1 .GT. PANEL_TABSIZE ) THEN WRITE(*,*) " Internal error 2 in ZMUMPS_SOLVE_BWD_PANELS" CALL MUMPS_ABORT() ENDIF CALL MUMPS_LDLTPANEL_PANELINFOS( NPIV, KEEP, IW, &NB_TARGET, NBPANELS, PANEL_COL, PANEL_POS, PANEL_TABSIZE, &.FALSE. ) DO IPANEL = NBPANELS, 1, -1 NBCOLS_PANEL = PANEL_COL( IPANEL+1 ) - PANEL_COL( IPANEL ) NBROWS_PANEL = NPIV - PANEL_COL( IPANEL ) + 1 PPIV_PANEL = PPIV_COURANT + PANEL_COL( IPANEL ) - 1 IF ( NBROWS_PANEL .GT. NBCOLS_PANEL ) THEN MTYPE_TEMP = 0 CALL ZMUMPS_SOLVE_GEMM_UPDATE( A, LA, & APOS-1_8+PANEL_POS(IPANEL)+ & int(NBCOLS_PANEL,8)*int(NBCOLS_PANEL,8), & NBROWS_PANEL-NBCOLS_PANEL, NBCOLS_PANEL, & NBCOLS_PANEL, & NRHS_B, WCB, LWCB, PPIV_PANEL+NBCOLS_PANEL, LDA_WCB, & PPIV_PANEL, LDA_WCB, & MTYPE_TEMP, KEEP, ONE ) ENDIF CALL ZMUMPS_SOLVE_BWD_TRSOLVE (A, LA, & APOS+PANEL_POS(IPANEL)-1_8, & NBCOLS_PANEL, NBCOLS_PANEL, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_PANEL, MTYPE, KEEP) ENDDO RETURN END SUBROUTINE ZMUMPS_SOLVE_BWD_PANELS SUBROUTINE ZMUMPS_SOLVE_GEMM_UPDATE & (A, LA, APOS1, NX, LDA, NY, & NRHS_B, WCB, LWCB, PTRX, LDX, & PTRY, LDY, & MTYPE, KEEP, COEF_Y ) INTEGER, INTENT(IN) :: MTYPE, NY, NX, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDY, LDA, LDX INTEGER(8), INTENT(IN) :: LA, APOS1, LWCB, PTRX, & PTRY COMPLEX(kind=8), INTENT(IN) :: A(LA) COMPLEX(kind=8), INTENT(INOUT) :: WCB(LWCB) COMPLEX(kind=8), INTENT(IN) :: COEF_Y COMPLEX(kind=8) ALPHA, ZERO, ONE PARAMETER (ZERO=(0.0D0,0.0D0), ONE=(1.0D0,0.0D0), & ALPHA=(-1.0D0,0.0D0)) IF ( NX .NE. 0 .AND. NY.NE.0 ) THEN IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL zgemv('T', NX, NY, ALPHA, A(APOS1), & LDA, WCB(PTRX), 1, COEF_Y, & WCB(PTRY), 1) ELSE #endif CALL zgemm('T', 'N', NY, NRHS_B, NX, ALPHA, & A(APOS1), LDA, WCB(PTRX), LDX, COEF_Y, & WCB(PTRY), LDY) #if defined(MUMPS_USE_BLAS2) END IF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL zgemv('N',NY, NX, ALPHA, A(APOS1), & LDA, WCB(PTRX), 1, & COEF_Y, WCB(PTRY), 1 ) ELSE #endif CALL zgemm('N', 'N', NY, NRHS_B, NX, ALPHA, & A(APOS1), LDA, WCB(PTRX), LDX, & COEF_Y, WCB(PTRY), LDY) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF END IF RETURN END SUBROUTINE ZMUMPS_SOLVE_GEMM_UPDATE SUBROUTINE ZMUMPS_SOL_LD_AND_RELOAD_PANEL ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & IGNORE_K459 & ) USE ZMUMPS_OOC IMPLICIT NONE INTEGER, INTENT(IN) :: MTYPE, INODE, N, NPIV, LIELL, & NELIM, NSLAVES INTEGER, INTENT(IN) :: LRHSINTR, NRHS, LIW, JBDEB, JBFIN INTEGER, INTENT(IN) :: IW(LIW), IPOS, POSINRHSINTR_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, APOS, LA, PPIV_COURANT INTEGER, INTENT(IN) :: LD_WCBPIV INTEGER, INTENT(IN) :: KEEP(500) COMPLEX(kind=8), INTENT(IN) :: WCB( LWCB ) COMPLEX(kind=8), INTENT(IN) :: A( LA ) COMPLEX(kind=8), INTENT(INOUT) :: RHSINTR(LRHSINTR, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL, INTENT(IN) :: IGNORE_K459 INTEGER :: J1, J3 INTEGER :: IPOSINRHSINTR, JJ, K, & LDAJ, NRHS_B INTEGER(8) :: IFR8 , APOS1, APOS2, APOSOFF, IFR_ini8, & POSWCB1, POSWCB2 COMPLEX(kind=8) :: VALPIV, A11, A22, A12, DETPIV INTEGER, PARAMETER :: PANEL_TABSIZE = 20 INTEGER(8) :: PANEL_POS(PANEL_TABSIZE) INTEGER :: PANEL_COL(PANEL_TABSIZE) INTEGER :: IPANEL, ICOL, NBPANELS, NB_TARGET LOGICAL :: SKIP_IT LOGICAL :: OMP_FLAG COMPLEX(kind=8) ONE PARAMETER ( ONE=(1.0D0,0.0D0) ) IF ( NPIV.EQ. 0 ) RETURN NRHS_B = JBFIN-JBDEB+1 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J3 = IPOS + LIELL + NPIV END IF IPOSINRHSINTR = POSINRHSINTR_FWD(IW(J1)) IF ( KEEP(50) .eq. 0 ) THEN OMP_FLAG = .FALSE. !$ OMP_FLAG=(int(NRHS_B,8)*int(NPIV,8).GE.int(KEEP(363),8)) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(IFR8) COLLAPSE(2) DO K = JBDEB, JBFIN DO IFR8 = 0_8, int(NPIV-1,8) RHSINTR(IPOSINRHSINTR+IFR8, K) = & WCB(PPIV_COURANT+(K-JBDEB)*LD_WCBPIV+IFR8) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K = JBDEB, JBFIN DO IFR8 = 0_8, int(NPIV-1,8) RHSINTR(IPOSINRHSINTR+IFR8, K) = & WCB(PPIV_COURANT+(K-JBDEB)*LD_WCBPIV+IFR8) ENDDO ENDDO ENDIF ELSE CALL MUMPS_LDLTPANEL_PANELINFOS( NPIV, KEEP, IW(IPOS+LIELL+1), & NB_TARGET, NBPANELS, PANEL_COL, PANEL_POS, PANEL_TABSIZE, & IGNORE_K459 ) IFR_ini8 = PPIV_COURANT !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & ((J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363))) !$OMP PARALLEL DO PRIVATE(JJ,IFR8,APOS1,APOS2,APOSOFF,VALPIV, !$OMP& IPANEL,ICOL, !$OMP& POSWCB1,POSWCB2,A11,A22,A12,DETPIV,LDAJ,SKIP_IT) !$OMP& IF(OMP_FLAG) DO K = JBDEB, JBFIN DO JJ = J1, J3 IPANEL = (JJ-J1)/NB_TARGET + 1 IF ( JJ-J1+1 .LT. PANEL_COL(IPANEL) ) IPANEL = IPANEL -1 ICOL = JJ-J1+1 - PANEL_COL(IPANEL) + 1 LDAJ = PANEL_COL(IPANEL+1) - PANEL_COL(IPANEL) APOS1 = APOS-1_8+PANEL_POS( IPANEL ) + int(ICOL-1,8) * & int(LDAJ+1,8) IFR8 = IFR_ini8 + int(K-JBDEB,8)*int(LD_WCBPIV,8) + & int(JJ-J1,8) IF ( JJ .NE. J1 ) THEN IF ( IW(LIELL+JJ-1) .LT. 0 ) THEN SKIP_IT = .TRUE. ELSE SKIP_IT = .FALSE. ENDIF ELSE SKIP_IT = .FALSE. ENDIF IF (SKIP_IT) THEN ELSE IF ( IW(JJ+LIELL) .GT. 0 ) THEN VALPIV = ONE/A( APOS1 ) RHSINTR(IPOSINRHSINTR+JJ-J1 , K ) = & WCB( IFR8 ) * VALPIV APOS1 = APOS1 + int(LDAJ + 1,8) ELSE APOS2 = APOS1+int(LDAJ+1,8) APOSOFF=APOS1+1_8 A11 = A(APOS1) A22 = A(APOS2) A12 = A(APOSOFF) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(APOS2)/DETPIV A12 = -A12/DETPIV POSWCB1 = IFR8 POSWCB2 = POSWCB1+1_8 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSINTR(IPOSINRHSINTR+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 ENDIF ENDDO ENDDO !$OMP END PARALLEL DO END IF RETURN END SUBROUTINE ZMUMPS_SOL_LD_AND_RELOAD_PANEL SUBROUTINE ZMUMPS_SOL_LD_AND_RELOAD ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & IGNORE_K459 & ) USE ZMUMPS_OOC INTEGER, INTENT(IN) :: MTYPE, INODE, N, NPIV, LIELL, & NELIM, NSLAVES INTEGER, INTENT(IN) :: LRHSINTR, NRHS, LIW, JBDEB, JBFIN INTEGER, INTENT(IN) :: IW(LIW), IPOS, POSINRHSINTR_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, APOS, LA, PPIV_COURANT INTEGER, INTENT(IN) :: LD_WCBPIV INTEGER, INTENT(IN) :: KEEP(500) COMPLEX(kind=8), INTENT(IN) :: WCB( LWCB ) COMPLEX(kind=8), INTENT(IN) :: A( LA ) COMPLEX(kind=8), INTENT(INOUT) :: RHSINTR(LRHSINTR, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL, INTENT(IN) :: IGNORE_K459 INTEGER :: TempNROW, J1, J3, PANEL_SIZE INTEGER :: IPOSINRHSINTR, JJ, K, NBK, LDAJ, & LDAJ_ini, NBK_ini, LDAJ_FIRST_PANEL, NRHS_B INTEGER(8) :: IFR8 , APOS1, APOS2, APOSOFF, IFR_ini8, & POSWCB1, POSWCB2 COMPLEX(kind=8) :: VALPIV, A11, A22, A12, DETPIV !$ LOGICAL :: OMP_FLAG COMPLEX(kind=8) ONE PARAMETER ( ONE=(1.0D0,0.0D0) ) NRHS_B = JBFIN-JBDEB+1 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J3 = IPOS + LIELL + NPIV END IF IPOSINRHSINTR = POSINRHSINTR_FWD(IW(J1)) IF ( KEEP(50) .eq. 0 ) THEN !$ OMP_FLAG=(NRHS_B.GE.KEEP(362).AND.NRHS_B*NPIV.GE.KEEP(363)) !$OMP PARALLEL DO PRIVATE(IFR8) IF (OMP_FLAG) DO K=JBDEB,JBFIN IFR8 = PPIV_COURANT + (K-JBDEB)*LD_WCBPIV RHSINTR(IPOSINRHSINTR:IPOSINRHSINTR+NPIV-1, K) = & WCB(IFR8:IFR8+int(NPIV-1,8)) ENDDO !$OMP END PARALLEL DO ELSE IFR8 = PPIV_COURANT - 1_8 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN IF (MTYPE.EQ.1) THEN IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN TempNROW= NPIV+NELIM LDAJ_FIRST_PANEL=TempNROW ELSE TempNROW= LIELL LDAJ_FIRST_PANEL=TempNROW ENDIF ELSE TempNROW= NPIV LDAJ_FIRST_PANEL=LIELL ENDIF PANEL_SIZE = ZMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) LDAJ = TempNROW ELSE IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 & .AND. .NOT. IGNORE_K459 ) THEN CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, PANEL_SIZE, KEEP ) LDAJ = PANEL_SIZE ELSE PANEL_SIZE = -1 LDAJ = NPIV ENDIF ENDIF IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN NBK = 0 ENDIF IFR_ini8 = PPIV_COURANT - 1_8 LDAJ_ini = LDAJ IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & NBK_ini = NBK !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & ((J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363))) !$OMP PARALLEL DO PRIVATE(JJ,IFR8,NBK,APOS1,APOS2,APOSOFF,VALPIV, !$OMP& POSWCB1, POSWCB2,A11,A22,A12,DETPIV,LDAJ) IF(OMP_FLAG) DO K = JBDEB, JBFIN IFR8 = IFR_ini8 + int(K-JBDEB,8)*int(LD_WCBPIV,8) NBK = NBK_ini APOS1 = APOS LDAJ = LDAJ_ini JJ = J1 DO IF (JJ .GT. J3) EXIT IFR8 = IFR8 + 1_8 IF (IW(JJ+LIELL) .GT. 0) THEN VALPIV = ONE/A( APOS1 ) RHSINTR(IPOSINRHSINTR+JJ-J1 , K ) = & WCB( IFR8 ) * VALPIV IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 IF (NBK.EQ.PANEL_SIZE) THEN NBK = 0 LDAJ = LDAJ - PANEL_SIZE ENDIF ENDIF APOS1 = APOS1 + int(LDAJ + 1,8) JJ = JJ+1 ELSE IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 ENDIF APOS2 = APOS1+int(LDAJ+1,8) IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN APOSOFF = APOS1+int(LDAJ,8) ELSE APOSOFF=APOS1+1_8 ENDIF A11 = A(APOS1) A22 = A(APOS2) A12 = A(APOSOFF) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(APOS2)/DETPIV A12 = -A12/DETPIV POSWCB1 = IFR8 POSWCB2 = POSWCB1+1_8 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSINTR(IPOSINRHSINTR+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 IF (NBK.GE.PANEL_SIZE) THEN LDAJ = LDAJ - NBK NBK = 0 ENDIF ENDIF APOS1 = APOS2 + int(LDAJ + 1,8) JJ = JJ+2 IFR8 = IFR8+1_8 ENDIF ENDDO ENDDO !$OMP END PARALLEL DO END IF RETURN END SUBROUTINE ZMUMPS_SOL_LD_AND_RELOAD SUBROUTINE ZMUMPS_SET_SCALING_LOC( scaling_data, N, ILOC, LILOC, & COMM, MYID, I_AM_SLAVE, MASTER, NB_BYTES, NB_BYTES_MAX, & K16_8, LP, LPOK, ICNTL, INFO ) IMPLICIT NONE type scaling_data_t SEQUENCE DOUBLE PRECISION, dimension(:), pointer :: SCALING DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC INTEGER, dimension(:), pointer :: SCALING_IND end type scaling_data_t type (scaling_data_t), INTENT(INOUT) :: scaling_data INTEGER, INTENT(IN) :: N, LILOC, COMM, MYID, MASTER, LP INTEGER, INTENT(IN) :: ILOC(LILOC) INTEGER(8), INTENT(INOUT) :: NB_BYTES, NB_BYTES_MAX INTEGER(8), INTENT(IN) :: K16_8 LOGICAL, INTENT(IN) :: I_AM_SLAVE, LPOK INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(IN) :: ICNTL(60) DOUBLE PRECISION, POINTER, DIMENSION(:) :: SCALING INTEGER :: I, IERR_MPI, allocok INCLUDE 'mpif.h' NULLIFY(scaling_data%SCALING_LOC) IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data%SCALING_LOC(max(1,LILOC)), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(1,LILOC) GOTO 35 ENDIF NB_BYTES = NB_BYTES + int(max(1,LILOC),8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF IF (MYID .NE. MASTER) THEN ALLOCATE(SCALING(N), stat=allocok) IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating temporary scaling array' ENDIF INFO(1)=-13 INFO(2)=N GOTO 35 ENDIF NB_BYTES = NB_BYTES + int(N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE SCALING => scaling_data%SCALING ENDIF 35 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF (INFO(1) .LT. 0) GOTO 90 CALL MPI_BCAST( SCALING(1), N, MPI_DOUBLE_PRECISION, & MASTER, COMM, IERR_MPI) IF ( I_AM_SLAVE ) THEN DO I = 1, LILOC IF (ILOC(I) .GE. 1 .AND. ILOC(I) .LE. N) THEN scaling_data%SCALING_LOC(I) = SCALING(ILOC(I)) ENDIF ENDDO ENDIF 90 CONTINUE IF (MYID.NE. MASTER) THEN IF (associated(SCALING)) THEN DEALLOCATE(SCALING) NB_BYTES = NB_BYTES - int(N,8)*K16_8 ENDIF ENDIF NULLIFY(SCALING) IF (INFO(1) .LT. 0) THEN IF (associated(scaling_data%SCALING_LOC)) THEN DEALLOCATE(scaling_data%SCALING_LOC) NULLIFY(scaling_data%SCALING_LOC) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SET_SCALING_LOC MUMPS_5.8.1/src/dfac_process_rtnelind.F0000664000175000017500000001137215042446440017675 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_PROCESS_RTNELIND( root, roota, & INODE, NELIM, NSLAVES, ROW_LIST, & COL_LIST, SLAVE_LIST, & & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND ) USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER INODE, NELIM, NSLAVES INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER ROW_LIST(*), COL_LIST(*), & SLAVE_LIST(*) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), ITLOC( N + KEEP(253) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER IFLAG, IERROR INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF INTEGER COMM, COMM_LOAD, ND(KEEP(28)), FILS(N), DAD(KEEP(28)) INTEGER IROOT, TYPE_INODE, DEB_ROW, DEB_COL, & NOINT INTEGER(8) :: NOREAL INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE IROOT = KEEP(38) NSTK_S(STEP(IROOT))= NSTK_S(STEP(IROOT)) - 1 KEEP(42) = KEEP(42) + NELIM TYPE_INODE= MUMPS_TYPENODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IF (TYPE_INODE.EQ.1) THEN IF (NELIM.EQ.0) THEN KEEP(41) = KEEP(41) + 1 ELSE KEEP(41) = KEEP(41) + 3 ENDIF ELSE IF (NELIM.EQ.0) THEN KEEP(41) = KEEP(41) + NSLAVES ELSE KEEP(41) = KEEP(41) + 2*NSLAVES + 1 ENDIF ENDIF IF (NELIM.EQ.0) THEN PIMASTER(STEP(INODE)) = 0 ELSE NOINT = 6 + NSLAVES + NELIM + NELIM + KEEP(IXSZ) NOREAL= 0_8 CALL DMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) THEN WRITE(*,*) ' Failure in int space allocation in CB area ', & ' during assembly of root : DMUMPS_PROCESS_RTNELIND', & ' size required was :', NOINT, & 'INODE=',INODE,' NELIM=',NELIM, ' NSLAVES=', NSLAVES RETURN ENDIF PIMASTER(STEP( INODE )) = IWPOSCB + 1 PAMASTER(STEP( INODE )) = IPTRLU + 1_8 IW( IWPOSCB + 1+KEEP(IXSZ) ) = 2*NELIM IW( IWPOSCB + 2+KEEP(IXSZ) ) = NELIM IW( IWPOSCB + 3+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 5+KEEP(IXSZ) ) = 1 IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES IF (NSLAVES.GT.0) THEN IW( IWPOSCB+7+KEEP(IXSZ):IWPOSCB+7+KEEP(IXSZ)+NSLAVES-1) = & SLAVE_LIST(1:NSLAVES) ENDIF DEB_ROW = IWPOSCB+7+NSLAVES+KEEP(IXSZ) IW(DEB_ROW : DEB_ROW+NELIM -1) = ROW_LIST(1:NELIM) DEB_COL = DEB_ROW + NELIM IW(DEB_COL : DEB_COL+NELIM -1) = COL_LIST(1:NELIM) ENDIF IF (NSTK_S(STEP(IROOT)) .EQ. 0 ) THEN CALL DMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN END SUBROUTINE DMUMPS_PROCESS_RTNELIND MUMPS_5.8.1/src/dsol_omp_m.F0000664000175000017500000004755515042446437015515 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_SOL_L0OMP_M CONTAINS SUBROUTINE DMUMPS_SOL_L0OMP_R(N, MTYPE, & NRHS, LIW, IW, PTRICB, RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & STEP, FRERE, DAD, FILS, NSTK, PTRIST, PTRFAC, INFO, & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF, & COMM, MYID, & BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, & FROM_PP, & NBROOT_UNDER_L0, LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS, & DO_PRUN, TO_PROCESS ) USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_L0OMPFAC_T !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT( in ) :: N, MTYPE, NRHS, SLAVEF, LIW INTEGER, INTENT( in ) :: IW(LIW) INTEGER :: INFO( 80 ), KEEP(500) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: DKEEP(230) INTEGER, INTENT( in ) :: PROCNODE_STEPS( KEEP(28) ) INTEGER :: PTRICB( KEEP(28) ) INTEGER, INTENT( in ) :: POSINRHSINTR_FWD(N), LRHSINTR DOUBLE PRECISION, INTENT(inout):: RHSINTR(LRHSINTR,NRHS) INTEGER, INTENT( in ) :: STEP(N), FRERE( KEEP(28) ), FILS( N ), & DAD( KEEP(28) ) INTEGER, INTENT( inout ) :: NSTK(KEEP(28)) INTEGER, INTENT( in ) :: PTRIST(KEEP(28)) INTEGER(8), INTENT( in ) :: PTRFAC(KEEP(28)) INTEGER, INTENT( IN ) :: COMM, MYID INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES INTEGER :: BUFR(LBUFR) INTEGER(8), INTENT(IN) :: LRHS_ROOT DOUBLE PRECISION :: RHS_ROOT(LRHS_ROOT) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) LOGICAL, INTENT( in ) :: DO_NBSPARSE INTEGER, INTENT( in ) :: LRHS_BOUNDS INTEGER, INTENT( in ) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, INTENT( in ) :: FROM_PP INTEGER, INTENT( out ):: NBROOT_UNDER_L0 INTEGER, INTENT( in ) :: LPOOL_B_L0_OMP INTEGER, INTENT( in ) :: IPOOL_B_L0_OMP & ( LPOOL_B_L0_OMP ) INTEGER, INTENT( in ) :: L_PHYS_L0_OMP INTEGER, INTENT( in ) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT( in ) :: L_VIRT_L0_OMP INTEGER, INTENT( in ) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT( in ) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT( in ) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT( in ) :: LL0_OMP_MAPPING INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INTEGER, INTENT( in ) :: LL0_OMP_FACTORS LOGICAL, INTENT( in ) :: DO_PRUN LOGICAL, INTENT( in ) :: TO_PROCESS( KEEP(28) ) TYPE (DMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER :: LASTFSSBTRSTA_P, LASTFSSBTRDYN_P INTEGER :: THREAD_ID, IL0OMPFAC INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOOL_P INTEGER, ALLOCATABLE, DIMENSION(:) :: IWCB_P DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: WCB_P INTEGER :: LPOOL_P, LEAF_P, LIWCB_P INTEGER(8) :: LWCB_P INTEGER(8) :: POSWCB_P, PLEFTWCB_P INTEGER :: POSIWCB_P LOGICAL :: IS_INODE_PROCESSED_P LOGICAL :: ERROR_WAS_BROADCASTED_P INTEGER :: INFO_P(2), allocok INTEGER :: I, VIRTUAL_TASK, PHYSICAL_TASK INTEGER :: INODE, IFATH, IROOT_SBTR INTEGER :: NBROOT_PROCESSED INTEGER :: NEXT_TASK_DYN !$ INTEGER :: NOMP_SAVE INTEGER :: NBFIN_DUMMY !$ INTEGER :: NOMP_TOTAL !$ INTEGER :: NOMP_INNER !$ LOGICAL :: SAVE_NESTED NBFIN_DUMMY = huge(NBFIN_DUMMY) NBROOT_PROCESSED = 0 PTRICB = 0 !$ NOMP_INNER = 1 !$ IF (KEEP(369).GT.0) THEN !$ NOMP_TOTAL = omp_get_max_threads() !$ IF (NOMP_TOTAL .NE. KEEP(400)) THEN !$ IF (KEEP(439) .GT. 1) THEN !$ NOMP_INNER = KEEP(439) !$ ELSE IF ( KEEP(439) .EQ. -1 !$ & ) THEN !$ NOMP_INNER = NOMP_TOTAL / KEEP(400) !$ ENDIF !$ ENDIF !$ IF (NOMP_INNER .GT. 1) THEN !$ SAVE_NESTED = omp_get_nested() !$ CALL OMP_SET_NESTED(.TRUE.) !$ ENDIF #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(KEEP(400),4)) #else !$ CALL omp_set_num_threads(KEEP(400)) #endif !$ ENDIF NEXT_TASK_DYN = KEEP(400)+1 !$OMP PARALLEL !$OMP& SHARED ( NEXT_TASK_DYN, IPOOL_B_L0_OMP, !$OMP& LPOOL_B_L0_OMP, NBFIN_DUMMY ) !$OMP& PRIVATE ( THREAD_ID, IL0OMPFAC, VIRTUAL_TASK, PHYSICAL_TASK, !$OMP& IPOOL_P, LPOOL_P, LEAF_P, !$OMP& LIWCB_P, LWCB_P, IWCB_P, WCB_P, !$OMP& PLEFTWCB_P, POSWCB_P, POSIWCB_P, !$OMP& LASTFSSBTRSTA_P, LASTFSSBTRDYN_P, !$OMP& INODE, IROOT_SBTR, IFATH, !$OMP& IS_INODE_PROCESSED_P, !$OMP& INFO_P, ERROR_WAS_BROADCASTED_P, NOMP_SAVE, allocok ) !$OMP& REDUCTION( + : NBROOT_PROCESSED ) !$ NOMP_SAVE = omp_get_max_threads() THREAD_ID = 1 !$ THREAD_ID = OMP_GET_THREAD_NUM() + 1 !$OMP BARRIER !$ CALL omp_set_num_threads(NOMP_INNER) LPOOL_P = LPOOL_B_L0_OMP INFO_P(1:2) = 0 LWCB_P = int(KEEP(133),8)*int(NRHS,8) LIWCB_P = KEEP(133) PLEFTWCB_P = 1_8 POSWCB_P = LWCB_P POSIWCB_P = LIWCB_P ALLOCATE(IPOOL_P(LPOOL_P), IWCB_P(LIWCB_P), WCB_P( LWCB_P), & stat=allocok) IF ( allocok > 0 ) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4(LPOOL_P + LIWCB_P + LWCB_P, & INFO(2)) !$OMP CRITICAL(critical_info) INFO(1) = -13 INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ENDIF !$OMP BARRIER IF (INFO(1) .LT. 0) THEN GOTO 50 ENDIF VIRTUAL_TASK = THREAD_ID 600 CONTINUE IF (VIRTUAL_TASK .LT. L_VIRT_L0_OMP) THEN DO PHYSICAL_TASK = VIRT_L0_OMP( VIRTUAL_TASK ), & VIRT_L0_OMP ( VIRTUAL_TASK + 1 ) - 1 LEAF_P = 1 DO I = PTR_LEAFS_L0_OMP( PERM_L0_OMP( PHYSICAL_TASK )+1 )+1, & PTR_LEAFS_L0_OMP( PERM_L0_OMP( PHYSICAL_TASK ) ) IF ( IPOOL_B_L0_OMP(I) .GT. 0 ) THEN IPOOL_P(LEAF_P) = IPOOL_B_L0_OMP(I) LEAF_P = LEAF_P + 1 ENDIF ENDDO IF ( LEAF_P .EQ. 1 ) THEN WRITE(*,*) " Internal error 1 in DMUMPS_SOL_L0OMP_R", & LEAF_P ENDIF IROOT_SBTR = PHYS_L0_OMP( PERM_L0_OMP( PHYSICAL_TASK )) IF (DO_PRUN) THEN IF (.NOT. TO_PROCESS(STEP(IROOT_SBTR))) THEN CYCLE ENDIF ENDIF INODE = IROOT_SBTR DO WHILE (INODE .GT. 0) LASTFSSBTRSTA_P = INODE INODE=FILS(INODE) ENDDO CALL MUMPS_COMPUTE_LASTFS_DYN( IROOT_SBTR, LASTFSSBTRDYN_P, & MTYPE, KEEP, IW, LIW, N, STEP, PTRIST, FILS, FRERE ) DO WHILE (LEAF_P .NE.1 .AND. INFO_P(1) .GE. 0) LEAF_P = LEAF_P - 1 INODE = IPOOL_P(LEAF_P) IFATH = DAD(STEP(INODE) ) IL0OMPFAC = L0_OMP_MAPPING(STEP(INODE)) IF (IL0OMPFAC .NE. THREAD_ID) THEN ENDIF IF (DO_PRUN) THEN IS_INODE_PROCESSED_P = TO_PROCESS(STEP(INODE)) ELSE IS_INODE_PROCESSED_P = .TRUE. ENDIF IF ( IS_INODE_PROCESSED_P ) THEN CALL DMUMPS_SOLVE_NODE_FWD( INODE, & LASTFSSBTRSTA_P, LASTFSSBTRDYN_P, & BUFR, LBUFR, LBUFR_BYTES, MYID, SLAVEF, COMM, & N, IPOOL_P, LPOOL_P, LEAF_P, NBFIN_DUMMY, NSTK, & IWCB_P, LIWCB_P, WCB_P, LWCB_P, & L0_OMP_FACTORS(IL0OMPFAC)%A(1), & L0_OMP_FACTORS(IL0OMPFAC)%LA, & IW, LIW, & NRHS, POSWCB_P, PLEFTWCB_P, POSIWCB_P, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, INFO_P, KEEP, KEEP8, DKEEP, & RHS_ROOT, LRHS_ROOT, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED_P ) IF (INFO_P(1) .LT. 0) THEN !$OMP CRITICAL(critical_info) INFO(1) = INFO_P(1) INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 50 IF (ERROR_WAS_BROADCASTED_P) THEN WRITE(*,*) " Internal error 2 in DMUMPS_SOL_L0OMP_R", & ERROR_WAS_BROADCASTED_P ENDIF ENDIF IF ( IFATH .EQ. 0 ) THEN IF ( IS_INODE_PROCESSED_P ) THEN NBROOT_PROCESSED = NBROOT_PROCESSED + 1 ENDIF ELSE PTRICB(STEP(INODE)) = 0 IF (IFATH .NE. 0) THEN IF ( INODE .NE. IROOT_SBTR ) THEN IF ( IS_INODE_PROCESSED_P ) THEN NSTK(STEP(IFATH)) = NSTK(STEP(IFATH)) - 1 ENDIF IF (NSTK(STEP(IFATH)) .EQ. 0 .OR. & NSTK(STEP(IFATH)) .EQ. -1 ) THEN IPOOL_P( LEAF_P ) = IFATH LEAF_P = LEAF_P + 1 IF (DO_PRUN) THEN NSTK(STEP(IFATH)) = huge(NSTK(STEP(IFATH))) ENDIF ENDIF ELSE IF ( IS_INODE_PROCESSED_P ) THEN !$OMP ATOMIC UPDATE NSTK(STEP(IFATH)) = NSTK(STEP(IFATH)) - 1 !$OMP END ATOMIC ENDIF ENDIF ENDIF ENDIF ENDDO ENDDO !$OMP ATOMIC CAPTURE VIRTUAL_TASK = NEXT_TASK_DYN NEXT_TASK_DYN = NEXT_TASK_DYN + 1 !$OMP END ATOMIC GOTO 600 ENDIF 50 CONTINUE IF (allocated(IPOOL_P)) DEALLOCATE(IPOOL_P) IF (allocated(IWCB_P)) DEALLOCATE(IWCB_P) IF (allocated(WCB_P)) DEALLOCATE(WCB_P) #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_SAVE,4)) #else !$ CALL omp_set_num_threads(NOMP_SAVE) #endif !$OMP END PARALLEL !$ IF (KEEP(369).GT.0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_TOTAL),4)) #else !$ CALL omp_set_num_threads(NOMP_TOTAL) #endif !$ IF (NOMP_INNER .GT. 1) THEN !$ CALL OMP_SET_NESTED(SAVE_NESTED) !$ ENDIF !$ ENDIF NBROOT_UNDER_L0 = NBROOT_PROCESSED RETURN END SUBROUTINE DMUMPS_SOL_L0OMP_R SUBROUTINE DMUMPS_SOL_L0OMP_S(N, MTYPE, NRHS, LIW, IW, & PTRICB, PTRACB, RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & STEP, FRERE, FILS, NE_STEPS, PTRIST, PTRFAC, INFO, & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, RHS_ROOT, LRHS_ROOT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP, LPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS ) USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_L0OMPFAC_T USE OMP_LIB IMPLICIT NONE INTEGER, INTENT( in ) :: N, MTYPE, NRHS, SLAVEF, LIW INTEGER, INTENT( in ) :: IW(LIW) INTEGER :: INFO( 80 ), KEEP(500) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: DKEEP(230) INTEGER, INTENT( in ) :: PROCNODE_STEPS( KEEP(28) ) INTEGER :: PTRICB( KEEP(28) ) INTEGER(8) :: PTRACB( KEEP(28) ) INTEGER, INTENT( in ) :: POSINRHSINTR_BWD(N), LRHSINTR DOUBLE PRECISION, INTENT(inout):: RHSINTR(LRHSINTR,NRHS) INTEGER, INTENT( in ) :: STEP(N), FRERE( KEEP(28) ), FILS( N ) INTEGER, INTENT( inout ) :: NE_STEPS(KEEP(28)) INTEGER, INTENT( in ) :: PTRIST(KEEP(28)) INTEGER(8), INTENT( in ) :: PTRFAC(KEEP(28)) INTEGER, INTENT( IN ) :: COMM, MYID INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES INTEGER :: BUFR(LBUFR) INTEGER(8), INTENT(IN) :: LRHS_ROOT DOUBLE PRECISION :: RHS_ROOT(LRHS_ROOT) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER :: LPANEL_POS INTEGER :: PANEL_POS(LPANEL_POS) LOGICAL, INTENT( in ) :: DO_NBSPARSE INTEGER, INTENT( in ) :: LRHS_BOUNDS INTEGER, INTENT( in ) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, INTENT( in ) :: PRUN_BELOW_BWD INTEGER, INTENT( in ) :: SIZE_TO_PROCESS LOGICAL, INTENT( in ) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, INTENT( in ) :: FROM_PP INTEGER, INTENT( in ) :: LPOOL_B_L0_OMP INTEGER, INTENT( in ) :: L_PHYS_L0_OMP INTEGER, INTENT( in ) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT( in ) :: L_VIRT_L0_OMP INTEGER, INTENT( in ) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT( in ) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT( in ) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT( in ) :: LL0_OMP_MAPPING INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INTEGER, INTENT( in ) :: LL0_OMP_FACTORS TYPE (DMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER :: THREAD_ID, IL0OMPFAC INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOOL_P INTEGER, ALLOCATABLE, DIMENSION(:) :: IWCB_P DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: WCB_P DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: W2_P INTEGER, ALLOCATABLE, DIMENSION(:) :: PANEL_POS_P INTEGER :: LPOOL_P, IIPOOL_P, LIWCB_P, LPANEL_POS_P INTEGER :: MYLEAF_LEFT_HUGE_P INTEGER(8) :: LWCB_P INTEGER(8) :: POSWCB_P, PLEFTWCB_P INTEGER :: POSIWCB_P LOGICAL :: DO_MCAST2_TERMBWD_P LOGICAL :: ERROR_WAS_BROADCASTED_P INTEGER :: INFO_P(2), allocok INTEGER :: VIRTUAL_TASK, PHYSICAL_TASK INTEGER :: INODE INTEGER :: NEXT_TASK_DYN !$ INTEGER :: NOMP_SAVE INTEGER :: NBFIN_DUMMY LOGICAL, ALLOCATABLE, DIMENSION(:) :: DEJA_SEND_DUMMY !$ INTEGER :: NOMP_TOTAL NBFIN_DUMMY = huge(NBFIN_DUMMY) ALLOCATE(DEJA_SEND_DUMMY( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of DEJA_SEND_DUMMY in ' & //'routine DMUMPS_SOL_S ' INFO(1)=-13 INFO(2)=SLAVEF GOTO 100 endif !$ IF (KEEP(369).GT.0) THEN !$ NOMP_TOTAL = omp_get_max_threads() #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(KEEP(400),4)) #else !$ CALL omp_set_num_threads(KEEP(400)) #endif !$ ENDIF PTRICB = 0 NEXT_TASK_DYN = KEEP(400)+1 !$OMP PARALLEL !$OMP& SHARED ( NEXT_TASK_DYN, LPOOL_B_L0_OMP, !$OMP& NBFIN_DUMMY, DEJA_SEND_DUMMY ) !$OMP& PRIVATE ( THREAD_ID, IL0OMPFAC, VIRTUAL_TASK, PHYSICAL_TASK, !$OMP& IPOOL_P, LPOOL_P, IIPOOL_P, MYLEAF_LEFT_HUGE_P, !$OMP& LIWCB_P, LWCB_P, IWCB_P, WCB_P, W2_P, LPANEL_POS_P, !$OMP& PANEL_POS_P, !$OMP& PLEFTWCB_P, POSWCB_P, POSIWCB_P, !$OMP& INODE, !$OMP& INFO_P, DO_MCAST2_TERMBWD_P, !$OMP& ERROR_WAS_BROADCASTED_P, NOMP_SAVE, allocok ) !$ NOMP_SAVE = omp_get_max_threads() THREAD_ID = 1 !$ THREAD_ID = OMP_GET_THREAD_NUM() + 1 !$OMP BARRIER !$ CALL omp_set_num_threads(1) LPOOL_P = LPOOL_B_L0_OMP INFO_P(1:2) = 0 LWCB_P = int(KEEP(133),8)*int(NRHS,8) LIWCB_P = KEEP(133) PLEFTWCB_P = 1_8 POSWCB_P = LWCB_P POSIWCB_P = LIWCB_P IF (KEEP(201).EQ.1) THEN LPANEL_POS_P = KEEP(228)+1 CALL MUMPS_ABORT() ELSE LPANEL_POS_P = 1 ENDIF ALLOCATE(IPOOL_P(LPOOL_P), IWCB_P(LIWCB_P), WCB_P( LWCB_P), & W2_P(KEEP(133)), PANEL_POS_P(LPANEL_POS_P), stat=allocok) IF ( allocok > 0 ) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4(LPOOL_P + LIWCB_P + LWCB_P + & KEEP(133)+LPANEL_POS_P, INFO(2)) !$OMP CRITICAL(critical_info) INFO(1) = -13 INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ENDIF !$OMP BARRIER IF (INFO(1) .LT. 0) THEN GOTO 50 ENDIF VIRTUAL_TASK = THREAD_ID 600 CONTINUE IF (VIRTUAL_TASK .LT. L_VIRT_L0_OMP) THEN DO PHYSICAL_TASK = VIRT_L0_OMP( VIRTUAL_TASK ), & VIRT_L0_OMP ( VIRTUAL_TASK + 1 ) - 1 INODE = PHYS_L0_OMP( PERM_L0_OMP( PHYSICAL_TASK ) ) IPOOL_P(1) = INODE IIPOOL_P = 2 MYLEAF_LEFT_HUGE_P = huge(MYLEAF_LEFT_HUGE_P) IF ( PRUN_BELOW_BWD ) THEN IF ( .NOT. TO_PROCESS(STEP(INODE)) ) THEN CYCLE ENDIF ENDIF DO WHILE (IIPOOL_P .NE.1 .AND. INFO_P(1) .GE. 0) IIPOOL_P = IIPOOL_P - 1 INODE = IPOOL_P(IIPOOL_P) IL0OMPFAC = L0_OMP_MAPPING(STEP(INODE)) IF (IL0OMPFAC .NE. THREAD_ID) THEN ENDIF CALL DMUMPS_SOLVE_NODE_BWD( INODE, N, IPOOL_P, LPOOL_P, & IIPOOL_P, NBFIN_DUMMY, L0_OMP_FACTORS(IL0OMPFAC)%A(1), & L0_OMP_FACTORS(IL0OMPFAC)%LA, IW, LIW, & WCB_P, LWCB_P, NRHS, POSWCB_P, PLEFTWCB_P, POSIWCB_P, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PTRICB, PTRACB, IWCB_P, LIWCB_P, W2_P, NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, MYLEAF_LEFT_HUGE_P, INFO_P, & PROCNODE_STEPS, & DEJA_SEND_DUMMY, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP, KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS_P, LPANEL_POS_P, & PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED_P & , DO_MCAST2_TERMBWD_P & ) IF (INFO_P(1) .LT. 0) THEN !$OMP CRITICAL(critical_info) INFO(1) = INFO_P(1) INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 50 IF (ERROR_WAS_BROADCASTED_P) THEN WRITE(*,*) " Internal error 1 in DMUMPS_SOL_L0OMP_R", & ERROR_WAS_BROADCASTED_P ENDIF IF (DO_MCAST2_TERMBWD_P) THEN WRITE(*,*) " Internal error 2 in DMUMPS_SOL_L0OMP_R", & DO_MCAST2_TERMBWD_P ENDIF ENDDO ENDDO !$OMP ATOMIC CAPTURE VIRTUAL_TASK = NEXT_TASK_DYN NEXT_TASK_DYN = NEXT_TASK_DYN + 1 !$OMP END ATOMIC GOTO 600 ENDIF 50 CONTINUE IF (allocated(IPOOL_P)) DEALLOCATE(IPOOL_P) IF (allocated(IWCB_P)) DEALLOCATE(IWCB_P) IF (allocated(WCB_P)) DEALLOCATE(WCB_P) IF (allocated(W2_P)) DEALLOCATE(W2_P) IF (allocated(PANEL_POS_P)) DEALLOCATE(PANEL_POS_P) #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_SAVE,4)) #else !$ CALL omp_set_num_threads(NOMP_SAVE) #endif !$OMP END PARALLEL !$ IF (KEEP(369).GT.0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_TOTAL),4)) #else !$ CALL omp_set_num_threads(NOMP_TOTAL) #endif !$ ENDIF 100 CONTINUE IF (allocated(DEJA_SEND_DUMMY)) DEALLOCATE(DEJA_SEND_DUMMY) RETURN END SUBROUTINE DMUMPS_SOL_L0OMP_S END MODULE DMUMPS_SOL_L0OMP_M MUMPS_5.8.1/src/sfac_sol_pool.F0000664000175000017500000004376715042446437016210 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_INIT_POOL_LAST3(IPOOL, LPOOL, LEAF) USE MUMPS_LOAD IMPLICIT NONE INTEGER LPOOL, LEAF INTEGER IPOOL(LPOOL) IPOOL(LPOOL-2) = 0 IPOOL(LPOOL-1) = 0 IPOOL(LPOOL) = LEAF-1 RETURN END SUBROUTINE SMUMPS_INIT_POOL_LAST3 SUBROUTINE SMUMPS_INSERT_POOL_N & (N, POOL, LPOOL, PROCNODE, SLAVEF, KEEP199, & K28, K76, K80, K47, STEP, INODE) USE MUMPS_LOAD IMPLICIT NONE INTEGER N, INODE, LPOOL, K28, SLAVEF, K76, K80, K47, KEEP199 INTEGER STEP(N), POOL(LPOOL), PROCNODE(K28) EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR, ATM_CURRENT_NODE INTEGER NBINSUBTREE, NBTOP, INODE_EFF,POS_TO_INSERT INTEGER IPOS1, IPOS2, ISWAP INTEGER NODE,J,I ATM_CURRENT_NODE = ( K76 == 2 .OR. K76 ==3 .OR. & K76==4 .OR. K76==5) NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF (INODE > N ) THEN INODE_EFF = INODE - N ELSE IF (INODE < 0) THEN INODE_EFF = - INODE ELSE INODE_EFF = INODE ENDIF IF(((INODE.GT.0).AND.(INODE.LE.N)).AND.(.NOT. & MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE_EFF)), & KEEP199)) & ) THEN IF ((K80 == 1 .AND. K47 .GE. 1) .OR. & (( K80 == 2 .OR. K80==3 ) .AND. & ( K47 == 4 ))) THEN CALL MUMPS_REMOVE_NODE(INODE,1) ENDIF ENDIF IF ( MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE_EFF)), & KEEP199) ) THEN POOL(NBINSUBTREE + 1 ) = INODE NBINSUBTREE = NBINSUBTREE + 1 ELSE POS_TO_INSERT=NBTOP+1 IF((K76.EQ.4).OR.(K76.EQ.5).OR.(K76.EQ.6))THEN IF((INODE.GT.N).OR.(INODE.LE.0))THEN DO J=NBTOP,1,-1 IF((POOL(LPOOL-2-J).GT.0) & .AND.(POOL(LPOOL-2-J).LE.N))THEN GOTO 333 ENDIF IF ( POOL(LPOOL-2-J) < 0 ) THEN NODE=-POOL(LPOOL-2-J) ELSE IF ( POOL(LPOOL-2-J) > N ) THEN NODE = POOL(LPOOL-2-J) - N ELSE NODE = POOL(LPOOL-2-J) ENDIF IF((K76.EQ.4).OR.(K76.EQ.6))THEN IF(DEPTH_FIRST_LOAD(STEP(NODE)).GE. & DEPTH_FIRST_LOAD(STEP(INODE_EFF)))THEN GOTO 333 ENDIF ENDIF IF(K76.EQ.5)THEN IF(COST_TRAV(STEP(NODE)).LE. & COST_TRAV(STEP(INODE_EFF)))THEN GOTO 333 ENDIF ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO IF(J.EQ.0) J=1 333 CONTINUE DO I=NBTOP,POS_TO_INSERT,-1 POOL(LPOOL-2-I-1)=POOL(LPOOL-2-I) ENDDO POOL(LPOOL-2-POS_TO_INSERT)=INODE NBTOP = NBTOP + 1 GOTO 20 ENDIF DO J=NBTOP,1,-1 IF((POOL(LPOOL-2-J).GT.0).AND.(POOL(LPOOL-2-J).LE.N))THEN GOTO 888 ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO 888 CONTINUE DO I=J,1,-1 NODE=POOL(LPOOL-2-I) IF((K76.EQ.4).OR.(K76.EQ.6))THEN IF(DEPTH_FIRST_LOAD(STEP(NODE)).GE. & DEPTH_FIRST_LOAD(STEP(INODE_EFF)))THEN GOTO 999 ENDIF ENDIF IF(K76.EQ.5)THEN IF(COST_TRAV(STEP(NODE)).LE. & COST_TRAV(STEP(INODE_EFF)))THEN GOTO 999 ENDIF ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO IF(I.EQ.0) I=1 999 CONTINUE DO J=NBTOP,POS_TO_INSERT,-1 POOL(LPOOL-2-J-1)=POOL(LPOOL-2-J) ENDDO POOL(LPOOL-2-POS_TO_INSERT)=INODE NBTOP = NBTOP + 1 GOTO 20 ENDIF POOL( LPOOL - 2 - ( NBTOP + 1 ) ) = INODE NBTOP = NBTOP + 1 IPOS1 = LPOOL - 2 - NBTOP IPOS2 = LPOOL - 2 - NBTOP + 1 10 CONTINUE IF ( IPOS2 == LPOOL - 2 ) GOTO 20 IF ( POOL(IPOS1) < 0 ) GOTO 20 IF ( POOL(IPOS2) < 0 ) GOTO 30 IF ( ATM_CURRENT_NODE ) THEN IF ( POOL(IPOS1) > N ) GOTO 20 IF ( POOL(IPOS2) > N ) GOTO 30 END IF GOTO 20 30 CONTINUE ISWAP = POOL(IPOS1) POOL(IPOS1) = POOL(IPOS2) POOL(IPOS2) = ISWAP IPOS1 = IPOS1 + 1 IPOS2 = IPOS2 + 1 GOTO 10 20 CONTINUE ENDIF POOL(LPOOL) = NBINSUBTREE POOL(LPOOL - 1) = NBTOP RETURN END SUBROUTINE SMUMPS_INSERT_POOL_N LOGICAL FUNCTION SMUMPS_POOL_EMPTY(POOL, LPOOL) IMPLICIT NONE INTEGER LPOOL INTEGER POOL(LPOOL) INTEGER NBINSUBTREE, NBTOP NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) SMUMPS_POOL_EMPTY = (NBINSUBTREE + NBTOP == 0) RETURN END FUNCTION SMUMPS_POOL_EMPTY SUBROUTINE SMUMPS_EXTRACT_POOL( N, POOL, LPOOL, PROCNODE, SLAVEF, & STEP, INODE, KEEP,KEEP8, MYID, ND, & FORCE_EXTRACT_TOP_SBTR ) USE MUMPS_LOAD IMPLICIT NONE INTEGER INODE, LPOOL, SLAVEF, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(N), POOL(LPOOL), PROCNODE(KEEP(28)), & ND(KEEP(28)) EXTERNAL MUMPS_INSSARBR, MUMPS_ROOTSSARBR, SMUMPS_POOL_EMPTY LOGICAL MUMPS_INSSARBR, MUMPS_ROOTSSARBR, SMUMPS_POOL_EMPTY INTEGER NBINSUBTREE, NBTOP, INSUBTREE, INODE_EFF, MYID LOGICAL LEFT, ATOMIC_SUBTREE,UPPER,FLAG_MEM,SBTR_FLAG,PROC_FLAG LOGICAL FORCE_EXTRACT_TOP_SBTR INTEGER NODE_TO_EXTRACT,I,J,MIN_PROC NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF ( KEEP(76) > 6 .OR. KEEP(76) < 0 ) THEN WRITE(*,*) "Error 2 in SMUMPS_EXTRACT_POOL: unknown strategy" CALL MUMPS_ABORT() ENDIF ATOMIC_SUBTREE = ( KEEP(76) == 1 .OR. KEEP(76) == 3) IF ( SMUMPS_POOL_EMPTY(POOL, LPOOL) ) THEN WRITE(*,*) "Error 1 in SMUMPS_EXTRACT_POOL" CALL MUMPS_ABORT() ENDIF IF ( .NOT. ATOMIC_SUBTREE ) THEN LEFT = (NBTOP == 0) IF(.NOT.LEFT)THEN IF((KEEP(76).EQ.4).OR.(KEEP(76).EQ.5))THEN IF(NBINSUBTREE.EQ.0)THEN LEFT=.FALSE. ELSE IF ( POOL(NBINSUBTREE) < 0 ) THEN I = -POOL(NBINSUBTREE) ELSE IF ( POOL(NBINSUBTREE) > N ) THEN I = POOL(NBINSUBTREE) - N ELSE I = POOL(NBINSUBTREE) ENDIF IF ( POOL(LPOOL-2-NBTOP) < 0 ) THEN J = -POOL(LPOOL-2-NBTOP) ELSE IF ( POOL(LPOOL-2-NBTOP) > N ) THEN J = POOL(LPOOL-2-NBTOP) - N ELSE J = POOL(LPOOL-2-NBTOP) ENDIF IF(KEEP(76).EQ.4)THEN IF(DEPTH_FIRST_LOAD(STEP(J)).GE. & DEPTH_FIRST_LOAD(STEP(I)))THEN LEFT=.TRUE. ELSE LEFT=.FALSE. ENDIF ENDIF IF(KEEP(76).EQ.5)THEN IF(COST_TRAV(STEP(J)).LE. & COST_TRAV(STEP(I)))THEN LEFT=.TRUE. ELSE LEFT=.FALSE. ENDIF ENDIF ENDIF ENDIF ENDIF ELSE IF ( INSUBTREE == 1 ) THEN IF (NBINSUBTREE == 0) THEN WRITE(*,*) "Error 3 in SMUMPS_EXTRACT_POOL" CALL MUMPS_ABORT() ENDIF LEFT = .TRUE. ELSE LEFT = ( NBTOP == 0) ENDIF ENDIF 222 CONTINUE IF ( LEFT ) THEN INODE = POOL( NBINSUBTREE ) IF(KEEP(81).EQ.2)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN CALL SMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8,PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(.NOT.SBTR_FLAG)THEN WRITE(*,*)MYID,': ca a change pour moi' LEFT=.FALSE. GOTO 222 ENDIF ENDIF ELSEIF(KEEP(81).EQ.3)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN NODE_TO_EXTRACT=INODE FLAG_MEM=.FALSE. CALL MUMPS_LOAD_CHK_MEMCST_POOL(FLAG_MEM) IF(FLAG_MEM)THEN CALL SMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(.NOT.SBTR_FLAG)THEN LEFT=.FALSE. WRITE(*,*)MYID,': ca a change pour moi (2)' GOTO 222 ENDIF ENDIF ENDIF ENDIF NBINSUBTREE = NBINSUBTREE - 1 IF ( INODE < 0 ) THEN INODE_EFF = -INODE ELSE IF ( INODE > N ) THEN INODE_EFF = INODE - N ELSE INODE_EFF = INODE ENDIF IF ( MUMPS_INSSARBR( PROCNODE(STEP(INODE_EFF)), & KEEP(199)) ) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.0))THEN CALL MUMPS_LOAD_SET_SBTR_MEM(.TRUE.) ENDIF INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE_EFF)), & KEEP(199))) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.1))THEN CALL MUMPS_LOAD_SET_SBTR_MEM(.FALSE.) ENDIF INSUBTREE = 0 END IF ELSE IF (NBTOP < 1 ) THEN WRITE(*,*) "Error 5 in SMUMPS_EXTRACT_POOL", NBTOP CALL MUMPS_ABORT() ENDIF INODE = POOL( LPOOL - 2 - NBTOP ) IF(KEEP(81).EQ.1)THEN CALL MUMPS_LOAD_POOL_CHECK_MEM & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IF(UPPER)THEN GOTO 666 ELSE NBINSUBTREE=NBINSUBTREE-1 IF ( MUMPS_INSSARBR( PROCNODE(STEP(INODE)), & KEEP(199)) ) THEN INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE)), & KEEP(199))) THEN INSUBTREE = 0 ENDIF GOTO 777 ENDIF ENDIF IF(KEEP(81).EQ.2)THEN CALL SMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN LEFT=.TRUE. WRITE(*,*)MYID,': ca a change pour moi (3)' GOTO 222 ENDIF ELSE IF(KEEP(81).EQ.3)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN NODE_TO_EXTRACT=INODE FLAG_MEM=.FALSE. CALL MUMPS_LOAD_CHK_MEMCST_POOL(FLAG_MEM) IF(FLAG_MEM)THEN CALL SMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN LEFT=.TRUE. WRITE(*,*)MYID,': ca a change pour moi (4)' GOTO 222 ENDIF ELSE CALL MUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ENDIF ENDIF ENDIF ENDIF 666 CONTINUE NBTOP = NBTOP - 1 IF((INODE.GT.0).AND.(INODE.LE.N))THEN IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. & ( KEEP(47) == 4 ))) THEN CALL MUMPS_REMOVE_NODE(INODE,2) ENDIF ENDIF IF ( INODE < 0 ) THEN INODE_EFF = -INODE ELSE IF ( INODE > N ) THEN INODE_EFF = INODE - N ELSE INODE_EFF = INODE ENDIF END IF 777 CONTINUE POOL(LPOOL) = NBINSUBTREE POOL(LPOOL - 1) = NBTOP POOL(LPOOL - 2) = INSUBTREE RETURN END SUBROUTINE SMUMPS_EXTRACT_POOL SUBROUTINE SMUMPS_MEM_CONS_MNG(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR,FLAG_SAME_PROC,MIN_PROC) USE MUMPS_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) LOGICAL SBTR,FLAG_SAME_PROC INTEGER POS_TO_EXTRACT,NODE_TO_EXTRACT,NBTOP,I,INSUBTREE, & NBINSUBTREE DOUBLE PRECISION MIN_COST, TMP_COST NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) MIN_COST=huge(MIN_COST) TMP_COST=huge(TMP_COST) FLAG_SAME_PROC=.FALSE. SBTR=.FALSE. MIN_PROC=-9999 IF((INODE.GT.0).AND.(INODE.LE.N))THEN POS_TO_EXTRACT=-1 NODE_TO_EXTRACT=-1 DO I=NBTOP,1,-1 IF(NODE_TO_EXTRACT.LT.0)THEN POS_TO_EXTRACT=I NODE_TO_EXTRACT=POOL(LPOOL-2-I) CALL MUMPS_LOAD_COMP_MAXMEM_POOL(NODE_TO_EXTRACT, & TMP_COST,PROC) MIN_COST=TMP_COST MIN_PROC=PROC ELSE CALL MUMPS_LOAD_COMP_MAXMEM_POOL(POOL(LPOOL-2-I), & TMP_COST,PROC) IF((PROC.NE.MIN_PROC).OR.(TMP_COST.NE.MIN_COST))THEN FLAG_SAME_PROC=.TRUE. ENDIF IF(TMP_COST.GT.MIN_COST)THEN POS_TO_EXTRACT=I NODE_TO_EXTRACT=POOL(LPOOL-2-I) MIN_COST=TMP_COST MIN_PROC=PROC ENDIF ENDIF ENDDO IF((KEEP(47).EQ.4).AND.(NBINSUBTREE.NE.0))THEN CALL MUMPS_CHECK_SBTR_COST(NBINSUBTREE,INSUBTREE,NBTOP, & MIN_COST,SBTR) IF(SBTR)THEN WRITE(*,*)MYID,': selecting from subtree' RETURN ENDIF ENDIF IF((.NOT.SBTR).AND.(.NOT.FLAG_SAME_PROC))THEN WRITE(*,*)MYID,': I must search for a task & to save My friend' RETURN ENDIF INODE = NODE_TO_EXTRACT DO I=POS_TO_EXTRACT,NBTOP IF(I.NE.NBTOP)THEN POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDIF ENDDO POOL(LPOOL-2-NBTOP)=INODE CALL MUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ELSE ENDIF END SUBROUTINE SMUMPS_MEM_CONS_MNG SUBROUTINE SMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) USE MUMPS_LOAD IMPLICIT NONE INTEGER INODE,LPOOL,N,SLAVEF,MYID,MIN_PROC INTEGER POOL(LPOOL),KEEP(500),PROCNODE(KEEP(28)),STEP(N) INTEGER(8) KEEP8(150) LOGICAL SBTR_FLAG,PROC_FLAG EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR INTEGER NODE_TO_EXTRACT,I,POS_TO_EXTRACT,NBTOP,NBINSUBTREE NBTOP= POOL(LPOOL - 1) NBINSUBTREE = POOL(LPOOL) IF(NBTOP.GT.0)THEN WRITE(*,*)MYID,': NBTOP=',NBTOP ENDIF SBTR_FLAG=.FALSE. PROC_FLAG=.FALSE. CALL SMUMPS_MEM_CONS_MNG(INODE,POOL,LPOOL,N,STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN RETURN ENDIF IF(MIN_PROC.EQ.-9999)THEN IF((INODE.GT.0).AND.(INODE.LT.N))THEN SBTR_FLAG=(NBINSUBTREE.NE.0) ENDIF RETURN ENDIF IF(.NOT.PROC_FLAG)THEN NODE_TO_EXTRACT=INODE IF((INODE.GE.0).AND.(INODE.LE.N))THEN CALL MUMPS_FIND_BEST_NODE_FOR_MEM(MIN_PROC,POOL, & LPOOL,INODE) IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)), & KEEP(199)))THEN WRITE(*,*)MYID,': Extracting from a subtree & for helping',MIN_PROC SBTR_FLAG=.TRUE. RETURN ELSE IF(NODE_TO_EXTRACT.NE.INODE)THEN WRITE(*,*)MYID,': Extracting from top & inode=',INODE,'for helping',MIN_PROC ENDIF CALL MUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ENDIF ENDIF DO I=1,NBTOP IF (POOL(LPOOL-2-I).EQ.INODE)THEN GOTO 452 ENDIF ENDDO 452 CONTINUE POS_TO_EXTRACT=I DO I=POS_TO_EXTRACT,NBTOP-1 POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDDO POOL(LPOOL-2-NBTOP)=INODE ENDIF END SUBROUTINE SMUMPS_MEM_NODE_SELECT SUBROUTINE SMUMPS_GET_INODE_FROM_POOL & ( IPOOL, LPOOL, III, LEAF, & INODE, STRATEGIE ) IMPLICIT NONE INTEGER, INTENT(IN) :: STRATEGIE, LPOOL INTEGER IPOOL (LPOOL) INTEGER III,LEAF INTEGER, INTENT(OUT) :: INODE LEAF = LEAF - 1 INODE = IPOOL( LEAF ) RETURN END SUBROUTINE SMUMPS_GET_INODE_FROM_POOL MUMPS_5.8.1/src/zfac_process_contrib_type3.F0000664000175000017500000002600415042446441020667 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_PROCESS_CONTRIB_TYPE3(BUFR,LBUFR, & LBUFR_BYTES, & root, roota, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND,PROCNODE_STEPS, SLAVEF, OPASSW ) USE MUMPS_LOAD USE ZMUMPS_OOC USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC ) :: root TYPE (ZMUMPS_ROOT_STRUC ) :: roota INTEGER :: KEEP( 500 ) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: DKEEP(230) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER LBUFR, LBUFR_BYTES, N, LIW, & IWPOS, IWPOSCB, COMP, COMM, COMM_LOAD, IFLAG, & IERROR INTEGER LPOOL, LEAF INTEGER IPOOL( LEAF ) INTEGER PTRIST(KEEP(28)) INTEGER PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), ITLOC( N+KEEP(253) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER BUFR( LBUFR_BYTES ) INTEGER IW( LIW ) INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER SLAVEF COMPLEX(kind=8) A( LA ) INTEGER MYID INTEGER FILS( N ), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER INTARR(KEEP8(27)) COMPLEX(kind=8) DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW 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( STEP(IROOT)) .NE. 0 ) THEN IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NSUBSET_ROW & - NSUPROW .OR. NSUBSET_ROW - NSUPROW.EQ.0 .OR. & NSUBSET_COL_EFF .EQ. 0)THEN KEEP(121) = KEEP(121) - 1 IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL ZMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSEIF (KEEP(201).EQ.2) THEN CALL ZMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL ZMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), & KEEP(28), KEEP(76), & KEEP(80), KEEP(47), & STEP, IROOT + N) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ENDIF ENDIF ELSE IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. & NSUBSET_ROW - NSUPROW .OR. & NSUBSET_ROW - NSUPROW.EQ.0 .OR. & NSUBSET_COL_EFF .EQ. 0)THEN KEEP(121)=-1 ENDIF CALL ZMUMPS_ROOT_ALLOC_STATIC( root, roota, IROOT, N, & IW, LIW, A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) IF ( IFLAG .LT. 0 ) RETURN END IF IF (KEEP(60) .EQ.0) THEN IF ( PTRIST(STEP(IROOT)) .GE. 0 ) THEN IF ( PTRIST(STEP(IROOT)) .NE. 0 ) THEN LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) POS_ROOT = PAMASTER(STEP( IROOT )) ELSE LOCAL_N = IW( PTLUST(STEP( IROOT ) ) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST(STEP( IROOT ) ) + 2 + KEEP(IXSZ)) POS_ROOT = PTRFAC(IW(PTLUST(STEP(IROOT))+4+ & KEEP(IXSZ))) END IF ENDIF ELSE LOCAL_M = root%SCHUR_LLD LOCAL_N = root%SCHUR_NLOC ENDIF IF ( (BBPCBP.EQ.1).AND. (NBROWS_ALREADY_SENT.EQ.0).AND. & (min(NSUPROW, NSUPCOL) .GT. 0) & ) THEN LREQI = NSUPROW+NSUPCOL LREQA = int(NSUPROW,8) * int(NSUPCOL,8) IF ( (LREQA.NE.0_8) .AND. & (PTRIST(STEP(IROOT)).LT.0).AND. & KEEP(60)==0) THEN WRITE(*,*) ' Error in ZMUMPS_PROCESS_CONTRIB_TYPE3' CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 1 ), LREQI, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( IPTRLU + 1_8 ), int(LREQA), & MPI_DOUBLE_COMPLEX, COMM, IERR ) OPASSW = OPASSW + LREQA CALL ZMUMPS_ASS_ROOT( root, roota, KEEP(50), NSUPROW, NSUPCOL, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NSUPROW + 1 ), NSUPCOL, & A( IPTRLU + 1_8 ), & A( 1 ), & LOCAL_M, LOCAL_N, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & 1) IWPOSCB = IWPOSCB + LREQI IPTRLU = IPTRLU + LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) ENDIF LREQI = NBROWS_PACKET + NSUBSET_COL_EFF LREQA = int(NBROWS_PACKET,8) * int(NSUBSET_COL_EFF,8) IF ( (LREQA.NE.0_8) .AND. & (PTRIST(STEP(IROOT)).LT.0).AND. & KEEP(60)==0) THEN WRITE(*,*) ' Error in ZMUMPS_PROCESS_CONTRIB_TYPE3' CALL MUMPS_ABORT() ENDIF IF (LREQA.NE.0_8) THEN CALL ZMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 1 ), LREQI, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( IPTRLU + 1_8 ), int(LREQA), & MPI_DOUBLE_COMPLEX, COMM, IERR ) OPASSW = OPASSW + LREQA IF (KEEP(60).EQ.0) THEN CALL ZMUMPS_ASS_ROOT( root, roota, KEEP(50), & NBROWS_PACKET, NSUBSET_COL_EFF, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NBROWS_PACKET + 1 ), & NSUPCOL_EFF, & A( IPTRLU + 1_8 ), & A( POS_ROOT ), LOCAL_M, LOCAL_N, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & 0) ELSE CALL ZMUMPS_ASS_ROOT( root, roota, KEEP(50), & NBROWS_PACKET, NSUBSET_COL_EFF, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NBROWS_PACKET + 1 ), & NSUPCOL_EFF, & A( IPTRLU + 1_8 ), & roota%SCHUR_POINTER(1), & root%SCHUR_LLD , root%SCHUR_NLOC, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & 0) ENDIF IWPOSCB = IWPOSCB + LREQI IPTRLU = IPTRLU + LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) ENDIF RETURN END SUBROUTINE ZMUMPS_PROCESS_CONTRIB_TYPE3 MUMPS_5.8.1/src/dmumps_save_restore.F0000664000175000017500000127251515042446440017442 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if ! defined(NO_SAVE_RESTORE) MODULE DMUMPS_SAVE_RESTORE USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_INTR_STRUC USE DMUMPS_SAVE_RESTORE_FILES USE MUMPS_FRONT_DATA_MGT_M IMPLICIT NONE INCLUDE 'mumps_save_restore_modes.h' CONTAINS SUBROUTINE DMUMPS_REMOVE_SAVED(id) USE DMUMPS_OOC IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MASTER PARAMETER ( MASTER = 0 ) TYPE (DMUMPS_STRUC) :: id CHARACTER(len=LEN_SAVE_FILE) :: RESTOREFILE, INFOFILE INTEGER :: fileunit, ierr, SIZE_INT, SIZE_INT8 INTEGER(8) :: size_read, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE INTEGER :: READ_OOC_FILE_NAME_LENGTH,READ_SYM,READ_PAR,READ_NPROCS CHARACTER(len=LEN_SAVE_FILE) :: READ_OOC_FIRST_FILE_NAME CHARACTER :: READ_ARITH LOGICAL :: READ_INT_TYPE_64 CHARACTER(len=23) :: READ_HASH LOGICAL :: FORTRAN_VERSION_OK LOGICAL :: SAME_OOC INTEGER :: ICNTL34, MAX_LENGTH, FLAG_SAME, SUM_FLAG_SAME TYPE (DMUMPS_STRUC) :: localid ierr = 0 call DMUMPS_GET_SAVE_FILES(id,RESTOREFILE,INFOFILE) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(fileunit) IF ( fileunit .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=fileunit,FILE=RESTOREFILE #if ! defined(MUMPS_NOF2003) & ,ACCESS="stream" #endif & ,STATUS='old',FORM='unformatted',IOSTAT=ierr) IF ( ierr.ne.0 ) THEN id%INFO(1) = -76 id%INFO(2) = id%MYID endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_INT = id%KEEP(34) SIZE_INT8 = id%KEEP(34)*id%KEEP(10) size_read = 0_8 call MUMPS_READ_HEADER(fileunit,ierr,size_read,SIZE_INT, & SIZE_INT8, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE, & READ_ARITH, READ_INT_TYPE_64, & READ_OOC_FILE_NAME_LENGTH, READ_OOC_FIRST_FILE_NAME, & READ_HASH,READ_SYM,READ_PAR,READ_NPROCS, & FORTRAN_VERSION_OK) close(fileunit) if (ierr.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) elseif (.NOT.FORTRAN_VERSION_OK) THEN id%INFO(1) = -73 id%INFO(2) = 1 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL DMUMPS_CHECK_HEADER(id,.TRUE.,READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) IF ( id%INFO(1) .LT. 0 ) RETURN ICNTL34 = -99998 IF (id%MYID.EQ.MASTER) THEN ICNTL34 = id%ICNTL(34) ENDIF CALL MPI_BCAST( ICNTL34, 1, MPI_INTEGER, MASTER, id%COMM, ierr ) CALL MPI_BCAST( READ_SYM, 1, MPI_INTEGER, MASTER, id%COMM, ierr ) CALL DMUMPS_CHECK_FILE_NAME(id, READ_OOC_FILE_NAME_LENGTH, & READ_OOC_FIRST_FILE_NAME, SAME_OOC) CALL MPI_ALLREDUCE(READ_OOC_FILE_NAME_LENGTH,MAX_LENGTH,1, & MPI_INTEGER,MPI_MAX,id%COMM,ierr) IF (MAX_LENGTH.NE.-999) THEN FLAG_SAME = 0 IF (SAME_OOC) THEN FLAG_SAME = 1 ENDIF CALL MPI_ALLREDUCE(FLAG_SAME,SUM_FLAG_SAME,1, & MPI_INTEGER,MPI_SUM,id%COMM,ierr) IF (SUM_FLAG_SAME.NE.0) THEN IF (ICNTL34 .EQ. 1) THEN id%ASSOCIATED_OOC_FILES = .TRUE. ELSE id%ASSOCIATED_OOC_FILES = .FALSE. ENDIF ELSE IF (ICNTL34 .NE. 1) THEN localid%COMM = id%COMM localid%INFO(1) = 0 localid%ICNTL(1) = id%ICNTL(1) localid%MYID = id%MYID localid%NPROCS = id%NPROCS localid%KEEP(10) = id%KEEP(10) localid%SAVE_PREFIX = id%SAVE_PREFIX localid%SAVE_DIR = id%SAVE_DIR call DMUMPS_RESTORE_OOC(localid) IF ( localid%INFO(1) .EQ. 0 ) THEN localid%ASSOCIATED_OOC_FILES = .FALSE. IF (READ_OOC_FILE_NAME_LENGTH.NE.-999) THEN call DMUMPS_OOC_CLEAN_FILES(localid,ierr) IF ( ierr.ne.0 ) THEN id%INFO(1) = -90 id%INFO(2) = id%MYID ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN ENDIF ENDIF ENDIF call MUMPS_CLEAN_SAVED_DATA(id%MYID,ierr,RESTOREFILE,INFOFILE) IF (ierr.eq.-79) THEN id%INFO(1) = -79 id%INFO(2) = 2 ELSE IF (ierr.ne.0) THEN id%INFO(1) = -76 id%INFO(2) = id%MYID ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) RETURN END SUBROUTINE DMUMPS_REMOVE_SAVED SUBROUTINE DMUMPS_RESTORE_OOC(localid) IMPLICIT NONE INCLUDE 'mpif.h' TYPE (DMUMPS_STRUC) :: localid INTEGER::ierr,IN,NBVARIABLES,NBVARIABLES_ROOTC CHARACTER(len=LEN_SAVE_FILE):: restore_file_ooc,INFO_FILE INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOTC INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOTC INTEGER:: INFO1,INFO2,INFOG1,INFOG2,allocok INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE TYPE (DMUMPS_INTR_STRUC) :: localidintr NBVARIABLES=194 NBVARIABLES_ROOTC=20 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOTC(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOTC(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL DMUMPS_GET_SAVE_FILES(localid,restore_file_ooc,INFO_FILE) IF ( localid%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(IN) IF ( IN .EQ. -1 ) THEN localid%INFO(1) = -79 localid%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN open(UNIT=IN,FILE=restore_file_ooc #if ! defined(MUMPS_NOF2003) & ,ACCESS="stream" #endif & ,STATUS='old',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN localid%INFO(1) = -74 localid%INFO(2) = localid%MYID endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN CALL DMUMPS_SAVE_RESTORE_STRUCTURE(localid,localidintr,IN & ,restore_ooc_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) CLOSE(IN) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOTC) deallocate(SIZE_GEST,SIZE_GEST_ROOTC) RETURN END SUBROUTINE DMUMPS_RESTORE_OOC SUBROUTINE DMUMPS_COMPUTE_MEMORY_SAVE(id,idintr, & TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE) IMPLICIT NONE INCLUDE 'mpif.h' TYPE (DMUMPS_STRUC) :: id TYPE (DMUMPS_INTR_STRUC) :: idintr INTEGER::NBVARIABLES,NBVARIABLES_ROOTC INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOTC INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOTC INTEGER :: INFO1,INFO2,INFOG1,INFOG2,allocok INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE NBVARIABLES=194 NBVARIABLES_ROOTC=20 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOTC(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOTC(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL DMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,0,memory_save_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOTC) deallocate(SIZE_GEST,SIZE_GEST_ROOTC) RETURN END SUBROUTINE DMUMPS_COMPUTE_MEMORY_SAVE SUBROUTINE DMUMPS_SAVE(id,idintr) IMPLICIT NONE INCLUDE 'mpif.h' TYPE (DMUMPS_STRUC) :: id TYPE (DMUMPS_INTR_STRUC) :: idintr INTEGER::ierr,OUT,NBVARIABLES,NBVARIABLES_ROOTC,OUTINFO CHARACTER(len=LEN_SAVE_FILE):: SAVE_FILE,INFO_FILE LOGICAL:: SAVE_FILE_exist,INFO_FILE_exist INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOTC INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOTC INTEGER:: INFO1,INFO2,INFOG1,INFOG2,MPG INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: PROKG INTEGER :: I,J,K,H,allocok CHARACTER(len=1) :: TMP_OOC_NAMES(350) INFO1 = id%INFO(1) INFO2 = id%INFO(2) INFOG1 = id%INFO(1) INFOG2 = id%INFO(1) id%INFO(1)=0 id%INFO(2)=0 id%INFOG(1)=0 id%INFOG(2)=0 MPG= id%ICNTL(3) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. 0 ) NBVARIABLES=194 NBVARIABLES_ROOTC=20 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOTC(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOTC(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 TMP_OOC_NAMES(:)="?" CALL DMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,0,memory_save_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) CALL DMUMPS_GET_SAVE_FILES(id,SAVE_FILE,INFO_FILE) IF ( id%INFO(1) .LT. 0 ) RETURN inquire(FILE=SAVE_FILE, EXIST=SAVE_FILE_exist) IF(SAVE_FILE_exist) THEN id%INFO(1) = -70 id%INFO(2) = 0 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(OUT) IF ( OUT .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=OUT,FILE=SAVE_FILE #if ! defined(MUMPS_NOF2003) & ,ACCESS="stream" #endif & ,STATUS='new',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -71 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN inquire(FILE=INFO_FILE, EXIST=INFO_FILE_exist) IF(INFO_FILE_exist) THEN id%INFO(1) = -70 id%INFO(2) = 0 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(OUTINFO) IF ( OUTINFO .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=OUTINFO,FILE=INFO_FILE,STATUS='new',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -71 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL DMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,OUT,save_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) if (id%INFO(1).EQ.0) then id%INFO(1)=INFO1 id%INFO(2)=INFO2 id%INFOG(1)=INFOG1 id%INFOG(2)=INFOG2 CLOSE(OUT) if(id%INFOG(1).NE.0) then if (PROKG) THEN write(MPG,*) "Warning: " & ,"saved instance has negative INFO(1):" & , id%INFOG(1) endif endif IF(PROKG) THEN write(MPG,*) "Save done successfully" IF(id%KEEP(201).EQ.1) THEN K=1 write(MPG,*) "The corresponding OOC files are:" DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(MPG,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF ENDIF write(OUTINFO,*) "Save done by DMUMPS ", & trim(adjustl(id%VERSION_NUMBER)), & " after JOB=",id%KEEP(40)+456789, & " With SYM, PAR =",id%KEEP(50),id%KEEP(46) write(OUTINFO,*) "On ",id%NPROCS," processes" if((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ.0)) then write(OUTINFO,*) "with N, NNZ ", id%N, id%NNZ elseif((id%ICNTL(18).EQ.1).AND.(id%ICNTL(5).EQ. 0)) then write(OUTINFO,*) "with N, NNZ_loc=", id%N, id%NNZ_loc elseif((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ. 1)) then write(OUTINFO,*) "with N, NELT=", id%N, id%NELT endif IF(id%KEEP(10).EQ.1) THEN write(OUTINFO,*) "With a default integer size of 64 bits" ELSE write(OUTINFO,*) "With a default integer size of 32 bits" ENDIF #if defined(MUMPS_NOF2003) write(OUTINFO,*) "Using MUMPS_NOF2003" #endif write(OUTINFO,*) '' write(OUTINFO,*) "The corresponding save file is:" write(OUTINFO,*) trim(adjustl(SAVE_FILE)) write(OUTINFO,*) "of size",TOTAL_FILE_SIZE, " Bytes" IF(id%KEEP(201).EQ.1) THEN write(OUTINFO,*) '' write(OUTINFO,*) "The corresponding OOC files are:" K=1 DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(OUTINFO,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF CLOSE(OUTINFO) else CLOSE(OUT,STATUS='delete') CLOSE(OUTINFO,STATUS='delete') endif deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOTC) deallocate(SIZE_GEST,SIZE_GEST_ROOTC) if (id%KEEP(201) .GT. 0) THEN id%ASSOCIATED_OOC_FILES=.TRUE. ENDIF RETURN END SUBROUTINE DMUMPS_SAVE SUBROUTINE DMUMPS_RESTORE(id,idintr) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER::ierr,IN,NBVARIABLES,NBVARIABLES_ROOTC CHARACTER(len=LEN_SAVE_FILE):: restore_file,INFO_FILE INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOTC INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOTC INTEGER:: INFO1,INFO2,INFOG1,INFOG2,MPG,MP,JOB INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: PROKG INTEGER :: I,J,K,H,allocok CHARACTER(len=1) :: TMP_OOC_NAMES(350) TYPE (DMUMPS_STRUC) :: id TYPE (DMUMPS_INTR_STRUC) :: idintr NBVARIABLES=194 NBVARIABLES_ROOTC=20 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOTC(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOTC(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 TMP_OOC_NAMES(:)="?" INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL DMUMPS_GET_SAVE_FILES(id,restore_file,INFO_FILE) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(IN) IF ( IN .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=IN,FILE=restore_file #if ! defined(MUMPS_NOF2003) & ,ACCESS="stream" #endif & ,STATUS='old',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -74 id%INFO(2) = id%MYID endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN MP= id%ICNTL(2) MPG= id%ICNTL(3) CALL DMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,IN,restore_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. 0 ) if(id%INFO(1).EQ.0) then id%INFO(1)=INFO1 id%INFO(2)=INFO2 id%INFOG(1)=INFOG1 id%INFOG(2)=INFOG2 if(id%INFOG(1).NE.0) then write(MPG,*) "Warning: " & ,"restored instance has negative INFOG(1):" & , id%INFOG(1) endif if(MP.GT.0) then JOB=id%KEEP(40)+456789 write(MP,*) "Restore done successfully" write(MP,*) "From file ",trim(adjustl(restore_file)) if((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ.0)) then write(MP,*) "with JOB, N, NNZ ",JOB, id%N,id%NNZ elseif((id%ICNTL(18).EQ.1).AND.(id%ICNTL(5).EQ. 0)) then write(MP,*) "with JOB, N, NNZ_loc=", JOB, id%N, & id%NNZ_loc elseif((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ. 1)) then write(MP,*) "with JOB, N, NELT=", JOB, id%N, id%NELT endif endif IF(PROKG) THEN IF(id%KEEP(201).EQ.1) THEN K=1 write(MPG,*) "The corresponding OOC files are:" DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(MPG,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF ENDIF else idintr%root%gridinit_done=.FALSE. id%KEEP(140)=1 endif CLOSE(IN) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOTC) deallocate(SIZE_GEST,SIZE_GEST_ROOTC) if (id%KEEP(201) .GT. 0) THEN id%ASSOCIATED_OOC_FILES=.TRUE. ENDIF RETURN END SUBROUTINE DMUMPS_RESTORE SUBROUTINE DMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,unit,mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) USE DMUMPS_FACSOL_L0OMP_M, ONLY : DMUMPS_SAVE_RESTORE_L0FACARRAY USE DMUMPS_LR_DATA_M, ONLY: DMUMPS_SAVE_RESTORE_BLR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER, intent(in) ::unit,NBVARIABLES,NBVARIABLES_ROOTC INTEGER, intent(in) :: mode INTEGER(8),dimension(NBVARIABLES)::SIZE_VARIABLES INTEGER(8),dimension(NBVARIABLES_ROOTC)::SIZE_VARIABLES_ROOTC INTEGER,dimension(NBVARIABLES)::SIZE_GEST INTEGER,dimension(NBVARIABLES_ROOTC)::SIZE_GEST_ROOTC INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER:: INFO1,INFO2,INFOG1,INFOG2 INTEGER:: j,i1,i2,err,ierr CHARACTER :: ARITH,READ_ARITH INTEGER(8) :: size_written,gest_size,WRITTEN_STRUC_SIZE INTEGER:: SIZE_INT, SIZE_INT8, SIZE_RL_OR_DBL, SIZE_ARITH_DEP INTEGER:: SIZE_DOUBLE_PRECISION, SIZE_LOGICAL, SIZE_CHARACTER INTEGER:: READ_NPROCS, READ_PAR, READ_SYM INTEGER,dimension(NBVARIABLES)::NbRecords INTEGER,dimension(NBVARIABLES_ROOTC)::NbRecords_ROOTC INTEGER:: size_array1,size_array2,dummy,allocok INTEGER(8):: size_array_INT8_1,size_array_INT8_2 LOGICAL:: INT_TYPE_64, READ_INT_TYPE_64, CALL_SAVE_RESTORE_BLR INTEGER:: tot_NbRecords,NbSubRecords INTEGER(8):: size_read,size_allocated INTEGER(8),dimension(NBVARIABLES)::DIFF_SIZE_ALLOC_READ INTEGER(8),dimension(NBVARIABLES_ROOTC):: & DIFF_SIZE_ALLOC_READ_ROOTC INTEGER::READ_OOC_FILE_NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE):: READ_OOC_FIRST_FILE_NAME INTEGER,dimension(4)::OOC_INDICES CHARACTER(len=8) :: date CHARACTER(len=10) :: time CHARACTER(len=5) :: zone INTEGER,dimension(8):: values CHARACTER(len=23) :: hash,READ_HASH LOGICAL:: BASIC_CHECK LOGICAL :: FORTRAN_VERSION_OK CHARACTER(len=1) :: TMP_OOC_NAMES(350) INTEGER(8)::SIZE_VARIABLES_BLR,SIZE_VARIABLES_FRONT_DATA, & SIZE_VARIABLES_L0FAC INTEGER :: SIZE_GEST_ROOTA INTEGER(8) :: SIZE_VARIABLES_ROOTA INTEGER::SIZE_GEST_BLR,SIZE_GEST_FRONT_DATA,SIZE_GEST_L0FAC INTEGER :: KEEP410_SAVE, KEEP411_SAVE INTEGER(8) :: KEEP883_SAVE, KEEP884_SAVE INTEGER(4) :: I4 LOGICAL :: IS_SYMMETRIC TYPE (DMUMPS_STRUC) :: id TYPE (DMUMPS_INTR_STRUC) :: idintr INTEGER, PARAMETER :: S_ASSOCIATED_OOC_FILES=194 INTEGER, PARAMETER :: S_pad16=193 INTEGER, PARAMETER :: S_Deficiency=192 INTEGER, PARAMETER :: S_NB_SINGULAR_VALUES=191 INTEGER, PARAMETER :: S_SINGULAR_VALUES=190 INTEGER, PARAMETER :: S_MTKO_PROCS_MAP=189 INTEGER, PARAMETER :: S_L0_OMP_MAPPING=188 INTEGER, PARAMETER :: S_PTR_LEAFS_L0_OMP=187 INTEGER, PARAMETER :: S_PERM_L0_OMP=186 INTEGER, PARAMETER :: S_VIRT_L0_OMP_MAPPING=185 INTEGER, PARAMETER :: S_VIRT_L0_OMP=184 INTEGER, PARAMETER :: S_PHYS_L0_OMP=183 INTEGER, PARAMETER :: S_IPOOL_A_L0_OMP=182 INTEGER, PARAMETER :: S_IPOOL_B_L0_OMP=181 INTEGER, PARAMETER :: S_I8_L0_OMP=180 INTEGER, PARAMETER :: S_I4_L0_OMP=179 INTEGER, PARAMETER :: S_THREAD_LA=178 INTEGER, PARAMETER :: S_LL0_OMP_FACTORS=177 INTEGER, PARAMETER :: S_LL0_OMP_MAPPING=176 INTEGER, PARAMETER :: S_L_VIRT_L0_OMP=175 INTEGER, PARAMETER :: S_L_PHYS_L0_OMP=174 INTEGER, PARAMETER :: S_LPOOL_B_L0_OMP=173 INTEGER, PARAMETER :: S_LPOOL_A_L0_OMP=172 INTEGER, PARAMETER :: S_BLRARRAY_ENCODING=171 INTEGER, PARAMETER :: S_FDM_F_ENCODING=170 INTEGER, PARAMETER :: S_pad13=169 INTEGER, PARAMETER :: S_NBGRP=168 INTEGER, PARAMETER :: S_LRGROUPS=167 INTEGER, PARAMETER :: S_INTR_ENCODING=166 INTEGER, PARAMETER :: S_WORKING=165 INTEGER, PARAMETER :: S_IPTR_WORKING=164 INTEGER, PARAMETER :: S_pad14=163 INTEGER, PARAMETER :: S_SUP_PROC=162 INTEGER, PARAMETER :: S_PIVNUL_LIST=161 INTEGER, PARAMETER :: S_OOC_FILE_NAMES=160 INTEGER, PARAMETER :: S_OOC_FILE_NAME_LENGTH=159 INTEGER, PARAMETER :: S_pad12=158 INTEGER, PARAMETER :: S_OOC_NB_FILE_TYPE=157 INTEGER, PARAMETER :: S_OOC_NB_FILES=156 INTEGER, PARAMETER :: S_OOC_TOTAL_NB_NODES=155 INTEGER, PARAMETER :: S_OOC_VADDR=154 INTEGER, PARAMETER :: S_OOC_SIZE_OF_BLOCK=153 INTEGER, PARAMETER :: S_OOC_INODE_SEQUENCE=152 INTEGER, PARAMETER :: S_OOC_MAX_NB_NODES_FOR_ZONE=151 INTEGER, PARAMETER :: S_INSTANCE_NUMBER=150 INTEGER, PARAMETER :: S_CB_SON_SIZE=149 INTEGER, PARAMETER :: S_DKEEP=148 INTEGER, PARAMETER :: S_LWK_USER=147 INTEGER, PARAMETER :: S_NBSA_LOCAL=146 INTEGER, PARAMETER :: S_WK_USER=145 INTEGER, PARAMETER :: S_CROIX_MANU=144 INTEGER, PARAMETER :: S_SCHED_SBTR=143 INTEGER, PARAMETER :: S_SCHED_GRP=142 INTEGER, PARAMETER :: S_SCHED_DEP=141 INTEGER, PARAMETER :: S_SBTR_ID=140 INTEGER, PARAMETER :: S_DEPTH_FIRST_SEQ=139 INTEGER, PARAMETER :: S_DEPTH_FIRST=138 INTEGER, PARAMETER :: S_MY_NB_LEAF=137 INTEGER, PARAMETER :: S_MY_FIRST_LEAF=136 INTEGER, PARAMETER :: S_MY_ROOT_SBTR=135 INTEGER, PARAMETER :: S_COST_TRAV=134 INTEGER, PARAMETER :: S_MEM_SUBTREE=133 INTEGER, PARAMETER :: S_RHSINTR=132 INTEGER, PARAMETER :: S_GLOB2LOC_SOL=131 INTEGER, PARAMETER :: S_pad11=130 INTEGER, PARAMETER :: S_GLOB2LOC_SOL_ALLOC=129 INTEGER, PARAMETER :: S_GLOB2LOC_RHS=128 INTEGER, PARAMETER :: S_MEM_DIST=127 INTEGER, PARAMETER :: S_I_AM_CAND=126 INTEGER, PARAMETER :: S_TAB_POS_IN_PERE=125 INTEGER, PARAMETER :: S_FUTURE_NIV2=124 INTEGER, PARAMETER :: S_ISTEP_TO_INIV2=123 INTEGER, PARAMETER :: S_CANDIDATES=122 INTEGER, PARAMETER :: S_ELTPROC=121 INTEGER, PARAMETER :: S_LELTVAR=120 INTEGER, PARAMETER :: S_NELT_loc=119 INTEGER, PARAMETER :: S_PROCNODE=118 INTEGER, PARAMETER :: S_LPS=117 INTEGER, PARAMETER :: S_S=116 INTEGER, PARAMETER :: S_PTRFAC=115 INTEGER, PARAMETER :: S_PTLUST_S=114 INTEGER, PARAMETER :: S_Step2node=113 INTEGER, PARAMETER :: S_PROCNODE_STEPS=112 INTEGER, PARAMETER :: S_NA=111 INTEGER, PARAMETER :: S_PTRDEBARR=110 INTEGER, PARAMETER :: S_NINROWARR=109 INTEGER, PARAMETER :: S_NINCOLARR=108 INTEGER, PARAMETER :: S_PTR8ARR=107 INTEGER, PARAMETER :: S_PTRAR=106 INTEGER, PARAMETER :: S_FRTELT=105 INTEGER, PARAMETER :: S_FRTPTR=104 INTEGER, PARAMETER :: S_FILS=103 INTEGER, PARAMETER :: S_DAD_STEPS=102 INTEGER, PARAMETER :: S_FRERE_STEPS=101 INTEGER, PARAMETER :: S_ND_STEPS=100 INTEGER, PARAMETER :: S_NE_STEPS=99 INTEGER, PARAMETER :: S_STEP=98 INTEGER, PARAMETER :: S_NBSA=97 INTEGER, PARAMETER :: S_LNA=96 INTEGER, PARAMETER :: S_KEEP=95 INTEGER, PARAMETER :: S_IS=94 INTEGER, PARAMETER :: S_ASS_IRECV=93 INTEGER, PARAMETER :: S_NSLAVES=92 INTEGER, PARAMETER :: S_NPROCS=91 INTEGER, PARAMETER :: S_MYID=90 INTEGER, PARAMETER :: S_COMM_LOAD=89 INTEGER, PARAMETER :: S_MYID_NODES=88 INTEGER, PARAMETER :: S_COMM_NODES=87 INTEGER, PARAMETER :: S_INST_Number=86 INTEGER, PARAMETER :: S_MAX_SURF_MASTER=85 INTEGER, PARAMETER :: S_KEEP8=84 INTEGER, PARAMETER :: S_pad7=83 INTEGER, PARAMETER :: S_SAVE_PREFIX=82 INTEGER, PARAMETER :: S_SAVE_DIR=81 INTEGER, PARAMETER :: S_WRITE_PROBLEM=80 INTEGER, PARAMETER :: S_OOC_PREFIX=79 INTEGER, PARAMETER :: S_OOC_TMPDIR=78 INTEGER, PARAMETER :: S_VERSION_NUMBER=77 INTEGER, PARAMETER :: S_MAPPING=76 INTEGER, PARAMETER :: S_LISTVAR_SCHUR=75 INTEGER, PARAMETER :: S_SCHUR_CINTERFACE=74 INTEGER, PARAMETER :: S_SCHUR=73 INTEGER, PARAMETER :: S_SIZE_SCHUR=72 INTEGER, PARAMETER :: S_SCHUR_LLD=71 INTEGER, PARAMETER :: S_SCHUR_NLOC=70 INTEGER, PARAMETER :: S_SCHUR_MLOC=69 INTEGER, PARAMETER :: S_NBLOCK=68 INTEGER, PARAMETER :: S_MBLOCK=67 INTEGER, PARAMETER :: S_NPCOL=66 INTEGER, PARAMETER :: S_NPROW=65 INTEGER, PARAMETER :: S_UNS_PERM=64 INTEGER, PARAMETER :: S_SYM_PERM=63 INTEGER, PARAMETER :: S_METIS_OPTIONS=62 INTEGER, PARAMETER :: S_RINFOG=61 INTEGER, PARAMETER :: S_RINFO=60 INTEGER, PARAMETER :: S_CNTL=59 INTEGER, PARAMETER :: S_COST_SUBTREES=58 INTEGER, PARAMETER :: S_INFOG=57 INTEGER, PARAMETER :: S_INFO=56 INTEGER, PARAMETER :: S_ICNTL=55 INTEGER, PARAMETER :: S_pad6=54 INTEGER, PARAMETER :: S_LD_RHSINTR=53 INTEGER, PARAMETER :: S_NSOL_loc=52 INTEGER, PARAMETER :: S_LSOL_loc=51 INTEGER, PARAMETER :: S_LREDRHS=50 INTEGER, PARAMETER :: S_LRHS_loc=49 INTEGER, PARAMETER :: S_Nloc_RHS=48 INTEGER, PARAMETER :: S_NZ_RHS=47 INTEGER, PARAMETER :: S_NRHS=46 INTEGER, PARAMETER :: S_LRHS=45 INTEGER, PARAMETER :: S_IRHS_loc=44 INTEGER, PARAMETER :: S_ISOL_loc=43 INTEGER, PARAMETER :: S_IRHS_PTR=42 INTEGER, PARAMETER :: S_IRHS_SPARSE=41 INTEGER, PARAMETER :: S_RHS_loc=40 INTEGER, PARAMETER :: S_SOL_loc=39 INTEGER, PARAMETER :: S_RHS_SPARSE=38 INTEGER, PARAMETER :: S_REDRHS=37 INTEGER, PARAMETER :: S_RHS=36 INTEGER, PARAMETER :: S_BLKVAR=35 INTEGER, PARAMETER :: S_BLKPTR=34 INTEGER, PARAMETER :: S_pad5=33 INTEGER, PARAMETER :: S_NBLK=32 INTEGER, PARAMETER :: S_PERM_IN=31 INTEGER, PARAMETER :: S_pad4=30 INTEGER, PARAMETER :: S_A_ELT=29 INTEGER, PARAMETER :: S_ELTVAR=28 INTEGER, PARAMETER :: S_ELTPTR=27 INTEGER, PARAMETER :: S_pad3=26 INTEGER, PARAMETER :: S_NELT=25 INTEGER, PARAMETER :: S_pad2=24 INTEGER, PARAMETER :: S_A_loc=23 INTEGER, PARAMETER :: S_JCN_loc=22 INTEGER, PARAMETER :: S_IRN_loc=21 INTEGER, PARAMETER :: S_NNZ_loc=20 INTEGER, PARAMETER :: S_pad1=19 INTEGER, PARAMETER :: S_NZ_loc=18 INTEGER, PARAMETER :: S_PIVOTS=17 INTEGER, PARAMETER :: S_COLIND=16 INTEGER, PARAMETER :: S_ROWIND=15 INTEGER, PARAMETER :: S_ROWSCA_loc=14 INTEGER, PARAMETER :: S_COLSCA_loc=13 INTEGER, PARAMETER :: S_ROWSCA=12 INTEGER, PARAMETER :: S_COLSCA=11 INTEGER, PARAMETER :: S_JCN=10 INTEGER, PARAMETER :: S_IRN=9 INTEGER, PARAMETER :: S_A=8 INTEGER, PARAMETER :: S_NNZ=7 INTEGER, PARAMETER :: S_NZ=6 INTEGER, PARAMETER :: S_N=5 INTEGER, PARAMETER :: S_JOB=4 INTEGER, PARAMETER :: S_PAR=3 INTEGER, PARAMETER :: S_SYM=2 INTEGER, PARAMETER :: S_COMM=1 INTEGER, PARAMETER :: R_gridinit_done=20 INTEGER, PARAMETER :: R_yes=19 INTEGER, PARAMETER :: R_RG2L=18 INTEGER, PARAMETER :: R_IPIV=17 INTEGER, PARAMETER :: R_NB_SINGULAR_VALUES=16 INTEGER, PARAMETER :: R_LPIV=15 INTEGER, PARAMETER :: R_CNTXT_BLACS=14 INTEGER, PARAMETER :: R_DESCRIPTOR=13 INTEGER, PARAMETER :: R_TOT_ROOT_SIZE=12 INTEGER, PARAMETER :: R_ROOT_SIZE=11 INTEGER, PARAMETER :: R_RHS_NLOC=10 INTEGER, PARAMETER :: R_SCHUR_LLD=9 INTEGER, PARAMETER :: R_SCHUR_NLOC=8 INTEGER, PARAMETER :: R_SCHUR_MLOC=7 INTEGER, PARAMETER :: R_MYCOL=6 INTEGER, PARAMETER :: R_MYROW=5 INTEGER, PARAMETER :: R_NPCOL=4 INTEGER, PARAMETER :: R_NPROW=3 INTEGER, PARAMETER :: R_NBLOCK=2 INTEGER, PARAMETER :: R_MBLOCK=1 OOC_INDICES=(/156,157,159,160/) SIZE_INT = id%KEEP(34) SIZE_INT8 = id%KEEP(34)*id%KEEP(10) SIZE_RL_OR_DBL = id%KEEP(150) SIZE_ARITH_DEP = id%KEEP(149) SIZE_DOUBLE_PRECISION = 8 SIZE_LOGICAL = 4 SIZE_CHARACTER = 1 size_written=int(0,kind=8) tot_NbRecords=0 NbRecords(:)=0 NbRecords_ROOTC(:)=0 size_read=int(0,kind=8) size_allocated=int(0,kind=8) DIFF_SIZE_ALLOC_READ(:)=0 DIFF_SIZE_ALLOC_READ_ROOTC(:)=0 WRITTEN_STRUC_SIZE=int(0,kind=8) TMP_OOC_NAMES(:)="?" SIZE_VARIABLES_BLR=0_8 SIZE_GEST_BLR=0 SIZE_VARIABLES_FRONT_DATA=0_8 SIZE_GEST_FRONT_DATA=0 SIZE_VARIABLES_L0FAC=0 SIZE_GEST_L0FAC=0 if(mode.EQ.memory_save_mode) then elseif(mode.EQ.save_mode) then write(unit,iostat=err) "MUMPS" if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(5*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(id%MYID.EQ.0) THEN call date_and_time(date,time,zone,values) hash=trim(date)//trim(time)//trim(zone) ENDIF CALL MPI_BCAST( hash, 23, MPI_CHARACTER, 0, id%COMM, ierr ) write(unit,iostat=err) hash if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(23*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(2*SIZE_INT8,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ARITH="DMUMPS"(1:1) write(unit,iostat=err) ARITH if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(1,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) id%SYM,id%PAR,id%NPROCS if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(3*SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(id%KEEP(10).EQ.1) THEN INT_TYPE_64=.TRUE. ELSE INT_TYPE_64=.FALSE. ENDIF write(unit,iostat=err) INT_TYPE_64 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_LOGICAL,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(associated(id%OOC_FILE_NAME_LENGTH).AND. & associated(id%OOC_FILE_NAMES)) THEN write(unit,iostat=err) id%OOC_FILE_NAME_LENGTH(1) if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(1))= & id%OOC_FILE_NAMES(1,1:id%OOC_FILE_NAME_LENGTH(1)) write(unit,iostat=err) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(1)) if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written & +int(id%OOC_FILE_NAME_LENGTH(1)*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ELSE write(unit,iostat=err) -999 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) -999 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ENDIF elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then CALL MUMPS_READ_HEADER(unit,err,size_read,SIZE_INT,SIZE_INT8, & TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE, READ_ARITH, & READ_INT_TYPE_64, READ_OOC_FILE_NAME_LENGTH, & READ_OOC_FIRST_FILE_NAME,READ_HASH, & READ_SYM,READ_PAR,READ_NPROCS,FORTRAN_VERSION_OK) if (err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) elseif (.NOT.FORTRAN_VERSION_OK) THEN id%INFO(1) = -73 id%INFO(2) = 1 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 BASIC_CHECK = .false. IF (mode.EQ.restore_ooc_mode) THEN BASIC_CHECK = .true. ENDIF CALL DMUMPS_CHECK_HEADER(id,BASIC_CHECK,READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) IF (id%INFO(1) .LT. 0) GOTO 100 elseif(mode.EQ.fake_restore_mode) then read(unit,iostat=err) READ_HASH if(err.ne.0) GOTO 100 read(unit,iostat=err) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(err.ne.0) GOTO 100 IF ( id%INFO(1) .LT. 0 ) GOTO 100 GOTO 200 else CALL MUMPS_ABORT() endif DO j=1,size(OOC_INDICES) i1=OOC_INDICES(j) SELECT CASE(i1) CASE(S_OOC_NB_FILES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_NB_FILES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%OOC_NB_FILES,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_NB_FILES)) THEN write(unit,iostat=err) size(id%OOC_NB_FILES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_NB_FILES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then nullify(id%OOC_NB_FILES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_NB_FILES(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_NB_FILES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_NB_FILE_TYPE) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%OOC_NB_FILE_TYPE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%OOC_NB_FILE_TYPE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_FILE_NAMES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_FILE_NAMES)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_FILE_NAMES,1) & *size(id%OOC_FILE_NAMES,2)*SIZE_CHARACTER ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_FILE_NAMES)) THEN write(unit,iostat=err) size(id%OOC_FILE_NAMES,1) & ,size(id%OOC_FILE_NAMES,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_FILE_NAMES ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then nullify(id%OOC_FILE_NAMES) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2 & *SIZE_CHARACTER allocate(id%OOC_FILE_NAMES(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_FILE_NAMES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_FILE_NAME_LENGTH) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_FILE_NAME_LENGTH)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%OOC_FILE_NAME_LENGTH,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_FILE_NAME_LENGTH)) THEN write(unit,iostat=err) size(id%OOC_FILE_NAME_LENGTH,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_FILE_NAME_LENGTH ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then nullify(id%OOC_FILE_NAME_LENGTH) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_FILE_NAME_LENGTH(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_FILE_NAME_LENGTH endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE DEFAULT END SELECT ENDDO if(mode.EQ.restore_ooc_mode) then goto 200 endif DO i1=1,NBVARIABLES SELECT CASE(i1) CASE(S_COMM) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_SYM) CALL MUMPS_SAVE_INT(id%SYM) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_PAR) CALL MUMPS_SAVE_INT(id%PAR) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_JOB) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_N) CALL MUMPS_SAVE_INT(id%N) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ICNTL) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%ICNTL,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%ICNTL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%ICNTL,1) read(unit,iostat=err) id%ICNTL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_INFO) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFO,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) INFO1,INFO2 & ,id%INFO(3:size(id%INFO,1)) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFO,1) read(unit,iostat=err) INFO1,INFO2 & ,id%INFO(3:size(id%INFO,1)) if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_INFOG) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFOG,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) INFOG1,INFOG2 & ,id%INFOG(3:size(id%INFOG,1)) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFOG,1) read(unit,iostat=err) INFOG1,INFOG2 & ,id%INFOG(3:size(id%INFOG,1)) if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_COST_SUBTREES) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%COST_SUBTREES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL read(unit,iostat=err) id%COST_SUBTREES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_CNTL) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%CNTL,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%CNTL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%CNTL,1) read(unit,iostat=err) id%CNTL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_RINFO) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFO,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%RINFO if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFO,1) read(unit,iostat=err) id%RINFO if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_RINFOG) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFOG,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%RINFOG if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFOG,1) read(unit,iostat=err) id%RINFOG if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_KEEP8) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8*size(id%KEEP8,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%KEEP8 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8*size(id%KEEP8,1) KEEP883_SAVE=id%KEEP8(83) KEEP884_SAVE=id%KEEP8(84) read(unit,iostat=err) id%KEEP8 id%KEEP8(83)=KEEP883_SAVE id%KEEP8(84)=KEEP884_SAVE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_KEEP) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%KEEP,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%KEEP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%KEEP,1) KEEP410_SAVE = id%KEEP(410) KEEP411_SAVE = id%KEEP(411) read(unit,iostat=err) id%KEEP id%KEEP(410) = KEEP410_SAVE id%KEEP(411) = KEEP411_SAVE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_DKEEP) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%DKEEP,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%DKEEP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%DKEEP,1) read(unit,iostat=err) id%DKEEP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NZ) CALL MUMPS_SAVE_INT(id%NZ) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NNZ) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%NNZ if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%NNZ if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_A) CASE(S_IRN) CASE(S_JCN) CASE(S_COLSCA) IF(id%KEEP(52).NE.-1) THEN CALL MUMPS_SAVERSTR_REALARRAY(id%COLSCA) ELSE ENDIF IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ROWSCA) IF(id%KEEP(52).NE.-1) THEN CALL MUMPS_SAVERSTR_REALARRAY(id%ROWSCA) ELSE ENDIF IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_COLSCA_loc) CALL MUMPS_SAVERSTR_REALARRAY(id%COLSCA_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ROWSCA_loc) IS_SYMMETRIC = .FALSE. IF (mode.EQ.memory_save_mode .OR. & mode.EQ.save_mode) THEN IS_SYMMETRIC = id%KEEP(50).EQ.1 .OR. & id%KEEP(50).EQ.2 ELSEIF (mode.EQ.restore_mode) THEN IS_SYMMETRIC = READ_SYM.EQ.1 .OR. & READ_SYM.EQ.2 ENDIF IF ( IS_SYMMETRIC ) THEN IF ( mode.EQ.restore_mode ) THEN id%ROWSCA_loc => id%COLSCA_loc ENDIF ELSE CALL MUMPS_SAVERSTR_REALARRAY(id%ROWSCA_loc) ENDIF IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NZ_loc) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%NZ_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NZ_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NNZ_loc) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%NNZ_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%NNZ_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_IRN_loc) CASE(S_JCN_loc) CASE(S_A_loc) CASE(S_NELT) CALL MUMPS_SAVE_INT(id%NELT) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NBLK) CALL MUMPS_SAVE_INT(id%NBLK) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ELTPTR) CASE(S_ELTVAR) CASE(S_A_ELT) CASE(S_PERM_IN) CASE(S_BLKPTR) CASE(S_BLKVAR) CASE(S_COLIND) CASE(S_PIVOTS) CASE(S_RHS) CASE(S_REDRHS) CASE(S_ROWIND) CASE(S_RHS_SPARSE) CASE(S_SOL_loc) CASE(S_RHS_loc) CASE(S_IRHS_SPARSE) CASE(S_IRHS_PTR) CASE(S_ISOL_loc) CASE(S_IRHS_loc) CASE(S_LRHS) CALL MUMPS_SAVE_INT(id%LRHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NRHS) CALL MUMPS_SAVE_INT(id%NRHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NZ_RHS) CALL MUMPS_SAVE_INT(id%NZ_RHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LRHS_loc) CALL MUMPS_SAVE_INT(id%LRHS_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_Nloc_RHS) CALL MUMPS_SAVE_INT(id%Nloc_RHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LD_RHSINTR) CALL MUMPS_SAVE_INT(id%LD_RHSINTR) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NSOL_loc) CALL MUMPS_SAVE_INT(id%NSOL_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LSOL_loc) CALL MUMPS_SAVE_INT(id%LSOL_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LREDRHS) CALL MUMPS_SAVE_INT(id%LREDRHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SYM_PERM) CALL DMUMPS_SAVE_INT_SHPTR_ARRAY(id%SYM_PERM & ) IF (id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_UNS_PERM) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%UNS_PERM)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%UNS_PERM,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%UNS_PERM)) THEN write(unit,iostat=err) size(id%UNS_PERM,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%UNS_PERM ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%UNS_PERM) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%UNS_PERM(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%UNS_PERM endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NPROW) CALL MUMPS_SAVE_INT(id%NPROW) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NPCOL) CALL MUMPS_SAVE_INT(id%NPCOL) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_MBLOCK) CALL MUMPS_SAVE_INT(id%MBLOCK) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NBLOCK) CALL MUMPS_SAVE_INT(id%NBLOCK) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SCHUR_MLOC) CALL MUMPS_SAVE_INT(id%SCHUR_MLOC) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SCHUR_NLOC) CALL MUMPS_SAVE_INT(id%SCHUR_NLOC) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SCHUR_LLD) CALL MUMPS_SAVE_INT(id%SCHUR_LLD) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SIZE_SCHUR) CALL MUMPS_SAVE_INT(id%SIZE_SCHUR) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SCHUR) CASE(S_SCHUR_CINTERFACE) CASE(S_LISTVAR_SCHUR) CASE(S_MAPPING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MAPPING)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(28)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MAPPING)) THEN write(unit,iostat=err) id%KEEP8(28) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MAPPING ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MAPPING) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT+SIZE_INT8 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_INT allocate(id%MAPPING(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MAPPING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_VERSION_NUMBER) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%VERSION_NUMBER) & *SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%VERSION_NUMBER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%VERSION_NUMBER) & *SIZE_CHARACTER read(unit,iostat=err) id%VERSION_NUMBER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_TMPDIR) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%OOC_TMPDIR) & *SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%OOC_TMPDIR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%OOC_TMPDIR) & *SIZE_CHARACTER read(unit,iostat=err) id%OOC_TMPDIR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_PREFIX) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%OOC_PREFIX) & *SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%OOC_PREFIX if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=1 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%OOC_PREFIX) & *SIZE_CHARACTER read(unit,iostat=err) id%OOC_PREFIX if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_WRITE_PROBLEM) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%WRITE_PROBLEM) & *SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%WRITE_PROBLEM if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%WRITE_PROBLEM) & *SIZE_CHARACTER read(unit,iostat=err) id%WRITE_PROBLEM if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MAX_SURF_MASTER) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%MAX_SURF_MASTER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%MAX_SURF_MASTER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_INST_Number) CALL MUMPS_SAVE_INT(id%INST_Number) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_COMM_NODES) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_MYID_NODES) CALL MUMPS_SAVE_INT(id%MYID_NODES) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_COMM_LOAD) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_MYID) CALL MUMPS_SAVE_INT(id%MYID) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NPROCS) CALL MUMPS_SAVE_INT(id%NPROCS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NSLAVES) CALL MUMPS_SAVE_INT(id%NSLAVES) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ASS_IRECV) CALL MUMPS_SAVE_INT(id%ASS_IRECV) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_IS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%IS)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=id%KEEP(32)*SIZE_INT DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size(id%IS,1)-id%KEEP(32)) ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%IS)) THEN write(unit,iostat=err) size(id%IS,1),id%KEEP(32) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IS(1:id%KEEP(32)) DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size(id%IS,1)-id%KEEP(32)) ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%IS) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array2*SIZE_INT DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size_array1-size_array2) allocate(id%IS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IS(1:size_array2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_Deficiency) CALL MUMPS_SAVE_INT(id%Deficiency) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LNA) CALL MUMPS_SAVE_INT(id%LNA) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NBSA) CALL MUMPS_SAVE_INT(id%NBSA) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_STEP) CALL DMUMPS_SAVE_INT_SHPTR_ARRAY(id%STEP & ) IF (id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_NE_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%NE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%NE_STEPS)) THEN write(unit,iostat=err) size(id%NE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%NE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%NE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_ND_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%ND_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ND_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%ND_STEPS)) THEN write(unit,iostat=err) size(id%ND_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ND_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%ND_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ND_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ND_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_Step2node) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%Step2node)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%Step2node,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%Step2node)) THEN write(unit,iostat=err) size(id%Step2node,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%Step2node ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%Step2node) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%Step2node(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%Step2node endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FRERE_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%FRERE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRERE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FRERE_STEPS)) THEN write(unit,iostat=err) size(id%FRERE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FRERE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FRERE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRERE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRERE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_DAD_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%DAD_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DAD_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%DAD_STEPS)) THEN write(unit,iostat=err) size(id%DAD_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DAD_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%DAD_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DAD_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DAD_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FILS) CALL DMUMPS_SAVE_INT_SHPTR_ARRAY(id%FILS & ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_PTR8ARR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTR8ARR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTR8ARR,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTR8ARR)) THEN write(unit,iostat=err) size(id%PTR8ARR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTR8ARR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=2 elseif(mode.EQ.restore_mode) then nullify(id%PTR8ARR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTR8ARR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTR8ARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NINCOLARR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then NbRecords(i1)=2 IF(associated(id%NINCOLARR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NINCOLARR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%NINCOLARR)) THEN write(unit,iostat=err) size(id%NINCOLARR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%NINCOLARR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%NINCOLARR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NINCOLARR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NINCOLARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NINROWARR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then NbRecords(i1)=2 IF(associated(id%NINROWARR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NINROWARR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%NINROWARR)) THEN write(unit,iostat=err) size(id%NINROWARR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%NINROWARR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%NINROWARR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NINROWARR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NINROWARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTRDEBARR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then NbRecords(i1)=2 IF(associated(id%PTRDEBARR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRDEBARR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTRDEBARR)) THEN write(unit,iostat=err) size(id%PTRDEBARR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTRDEBARR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PTRDEBARR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PTRDEBARR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRDEBARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTRAR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTRAR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRAR,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTRAR)) THEN write(unit,iostat=err) size(id%PTRAR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTRAR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=2 elseif(mode.EQ.restore_mode) then nullify(id%PTRAR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTRAR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRAR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FRTPTR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%FRTPTR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRTPTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FRTPTR)) THEN write(unit,iostat=err) size(id%FRTPTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FRTPTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FRTPTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRTPTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRTPTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FRTELT) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%FRTELT)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRTELT,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FRTELT)) THEN write(unit,iostat=err) size(id%FRTELT,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%FRTELT ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FRTELT) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRTELT(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRTELT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NA) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%NA)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NA,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%NA)) THEN write(unit,iostat=err) size(id%NA,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%NA ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%NA) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NA(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NA endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PROCNODE_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then NbRecords(i1)=2 IF(associated(id%PROCNODE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PROCNODE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PROCNODE_STEPS)) THEN write(unit,iostat=err) size(id%PROCNODE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PROCNODE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PROCNODE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PROCNODE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PROCNODE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTLUST_S) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTLUST_S)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTLUST_S,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTLUST_S)) THEN write(unit,iostat=err) size(id%PTLUST_S,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTLUST_S ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PTLUST_S) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PTLUST_S(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTLUST_S endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTRFAC) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTRFAC)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRFAC,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTRFAC)) THEN write(unit,iostat=err) size(id%PTRFAC,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) id%PTRFAC ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PTRFAC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTRFAC(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRFAC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_S) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%S)) THEN SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=id%KEEP8(31)*SIZE_ARITH_DEP DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP*(id%KEEP8(23)-id%KEEP8(31)) ELSE SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%S)) THEN write(unit,iostat=err) id%KEEP8(23),id%KEEP8(31) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%S(1:id%KEEP8(31)) DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP*(id%KEEP8(23)-id%KEEP8(31)) ELSE write(unit,iostat=err) int(-999,kind=8) & ,int(-998,kind=8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%S) read(unit,iostat=err) size_array_INT8_1,size_array_INT8_2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,kind=8)) then SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=size_array_INT8_2*SIZE_ARITH_DEP DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP* & (size_array_INT8_1-size_array_INT8_2) allocate(id%S(1:size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%S(1:size_array_INT8_2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_LPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%LPS)) THEN SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=id%KEEP8(31)*SIZE_ARITH_DEP/2 DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP/2*(id%KEEP8(23)-id%KEEP8(31)) ELSE SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%LPS)) THEN write(unit,iostat=err) id%KEEP8(23),id%KEEP8(31) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%LPS(1:id%KEEP8(31)) DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP/2*(id%KEEP8(23)-id%KEEP8(31)) ELSE write(unit,iostat=err) int(-999,kind=8) & ,int(-998,kind=8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%LPS) read(unit,iostat=err) size_array_INT8_1,size_array_INT8_2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,kind=8)) then SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=size_array_INT8_2*SIZE_ARITH_DEP/2 DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP/2* & (size_array_INT8_1-size_array_INT8_2) allocate(id%LPS(1:size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%LPS(1:size_array_INT8_2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PROCNODE) CASE(S_NELT_loc) CALL MUMPS_SAVE_INT(id%NELT_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LELTVAR) CALL MUMPS_SAVE_INT(id%LELTVAR) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ELTPROC) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%ELTPROC)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ELTPROC,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%ELTPROC)) THEN write(unit,iostat=err) size(id%ELTPROC,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ELTPROC ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%ELTPROC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ELTPROC(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ELTPROC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_I4_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%I4_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%I4_L0_OMP,1) & *size(id%I4_L0_OMP,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%I4_L0_OMP)) THEN write(unit,iostat=err) size(id%I4_L0_OMP,1) & ,size(id%I4_L0_OMP,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I4_L0_OMP ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%I4_L0_OMP) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%I4_L0_OMP(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%I4_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_I8_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%I8_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%I8_L0_OMP,1) & *size(id%I8_L0_OMP,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%I8_L0_OMP)) THEN write(unit,iostat=err) size(id%I8_L0_OMP,1) & ,size(id%I8_L0_OMP,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I8_L0_OMP ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%I8_L0_OMP) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%I8_L0_OMP(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%I8_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_CANDIDATES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%CANDIDATES)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%CANDIDATES,1) & *size(id%CANDIDATES,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%CANDIDATES)) THEN write(unit,iostat=err) size(id%CANDIDATES,1) & ,size(id%CANDIDATES,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%CANDIDATES ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%CANDIDATES) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%CANDIDATES(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%CANDIDATES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_ISTEP_TO_INIV2) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%ISTEP_TO_INIV2)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ISTEP_TO_INIV2,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%ISTEP_TO_INIV2)) THEN write(unit,iostat=err) size(id%ISTEP_TO_INIV2,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ISTEP_TO_INIV2 ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%ISTEP_TO_INIV2) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ISTEP_TO_INIV2(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ISTEP_TO_INIV2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FUTURE_NIV2) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%FUTURE_NIV2)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FUTURE_NIV2,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FUTURE_NIV2)) THEN write(unit,iostat=err) size(id%FUTURE_NIV2,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FUTURE_NIV2 ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FUTURE_NIV2) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FUTURE_NIV2(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FUTURE_NIV2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_TAB_POS_IN_PERE) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%TAB_POS_IN_PERE)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%TAB_POS_IN_PERE,1) & *size(id%TAB_POS_IN_PERE,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%TAB_POS_IN_PERE)) THEN write(unit,iostat=err) size(id%TAB_POS_IN_PERE,1) & ,size(id%TAB_POS_IN_PERE,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%TAB_POS_IN_PERE ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%TAB_POS_IN_PERE) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%TAB_POS_IN_PERE(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%TAB_POS_IN_PERE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_I_AM_CAND) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%I_AM_CAND)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%I_AM_CAND,1)*SIZE_LOGICAL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%I_AM_CAND)) THEN write(unit,iostat=err) size(id%I_AM_CAND,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I_AM_CAND ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%I_AM_CAND) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_LOGICAL allocate(id%I_AM_CAND(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%I_AM_CAND endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MEM_DIST) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MEM_DIST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MEM_DIST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MEM_DIST)) THEN write(unit,iostat=err) size(id%MEM_DIST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) id%MEM_DIST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MEM_DIST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MEM_DIST(0:size_array1-1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MEM_DIST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_GLOB2LOC_RHS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%GLOB2LOC_RHS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%GLOB2LOC_RHS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%GLOB2LOC_RHS)) THEN write(unit,iostat=err) size(id%GLOB2LOC_RHS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%GLOB2LOC_RHS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%GLOB2LOC_RHS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%GLOB2LOC_RHS(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%GLOB2LOC_RHS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_GLOB2LOC_SOL_ALLOC) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%GLOB2LOC_SOL_ALLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_LOGICAL read(unit,iostat=err) id%GLOB2LOC_SOL_ALLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_GLOB2LOC_SOL) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%GLOB2LOC_SOL)) THEN IF(id%GLOB2LOC_SOL_ALLOC) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%GLOB2LOC_SOL,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%GLOB2LOC_SOL)) THEN IF(id%GLOB2LOC_SOL_ALLOC) THEN write(unit,iostat=err) size(id%GLOB2LOC_SOL,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%GLOB2LOC_SOL ELSE write(unit,iostat=err) size(id%GLOB2LOC_SOL,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%GLOB2LOC_SOL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else if(id%GLOB2LOC_SOL_ALLOC) then SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%GLOB2LOC_SOL(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%GLOB2LOC_SOL else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy id%GLOB2LOC_SOL=>id%GLOB2LOC_RHS endif endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_RHSINTR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%RHSINTR)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(25)*SIZE_ARITH_DEP ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%RHSINTR)) THEN write(unit,iostat=err) id%KEEP8(25) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%RHSINTR ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%RHSINTR) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_ARITH_DEP allocate(id%RHSINTR(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%RHSINTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MEM_SUBTREE) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MEM_SUBTREE)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%MEM_SUBTREE,1)*SIZE_DOUBLE_PRECISION ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MEM_SUBTREE)) THEN write(unit,iostat=err) size(id%MEM_SUBTREE,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MEM_SUBTREE ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MEM_SUBTREE) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_DOUBLE_PRECISION allocate(id%MEM_SUBTREE(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MEM_SUBTREE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_COST_TRAV) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%COST_TRAV)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%COST_TRAV,1)*SIZE_DOUBLE_PRECISION ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%COST_TRAV)) THEN write(unit,iostat=err) size(id%COST_TRAV,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%COST_TRAV ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%COST_TRAV) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_DOUBLE_PRECISION allocate(id%COST_TRAV(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%COST_TRAV endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MY_ROOT_SBTR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MY_ROOT_SBTR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_ROOT_SBTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MY_ROOT_SBTR)) THEN write(unit,iostat=err) size(id%MY_ROOT_SBTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_ROOT_SBTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MY_ROOT_SBTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_ROOT_SBTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_ROOT_SBTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MY_FIRST_LEAF) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MY_FIRST_LEAF)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_FIRST_LEAF,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MY_FIRST_LEAF)) THEN write(unit,iostat=err) size(id%MY_FIRST_LEAF,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_FIRST_LEAF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MY_FIRST_LEAF) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_FIRST_LEAF(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_FIRST_LEAF endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MY_NB_LEAF) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MY_NB_LEAF)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_NB_LEAF,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MY_NB_LEAF)) THEN write(unit,iostat=err) size(id%MY_NB_LEAF,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_NB_LEAF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MY_NB_LEAF) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_NB_LEAF(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_NB_LEAF endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_DEPTH_FIRST) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%DEPTH_FIRST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DEPTH_FIRST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%DEPTH_FIRST)) THEN write(unit,iostat=err) size(id%DEPTH_FIRST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DEPTH_FIRST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%DEPTH_FIRST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DEPTH_FIRST(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DEPTH_FIRST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_DEPTH_FIRST_SEQ) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%DEPTH_FIRST_SEQ)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DEPTH_FIRST_SEQ,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%DEPTH_FIRST_SEQ)) THEN write(unit,iostat=err) size(id%DEPTH_FIRST_SEQ,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DEPTH_FIRST_SEQ ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%DEPTH_FIRST_SEQ) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DEPTH_FIRST_SEQ(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DEPTH_FIRST_SEQ endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SBTR_ID) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%SBTR_ID)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%SBTR_ID,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%SBTR_ID)) THEN write(unit,iostat=err) size(id%SBTR_ID,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%SBTR_ID ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%SBTR_ID) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%SBTR_ID(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%SBTR_ID endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SCHED_DEP) CASE(S_SCHED_GRP) CASE(S_CROIX_MANU) CASE(S_WK_USER) CASE(S_NBSA_LOCAL) CALL MUMPS_SAVE_INT(id%NBSA_LOCAL) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LWK_USER) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_CB_SON_SIZE) CASE(S_INSTANCE_NUMBER) CALL MUMPS_SAVE_INT(id%INSTANCE_NUMBER) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_OOC_MAX_NB_NODES_FOR_ZONE) CALL MUMPS_SAVE_INT(id%OOC_MAX_NB_NODES_FOR_ZONE) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_OOC_INODE_SEQUENCE) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_INODE_SEQUENCE)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_INODE_SEQUENCE,1) & *size(id%OOC_INODE_SEQUENCE,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_INODE_SEQUENCE)) THEN write(unit,iostat=err) size(id%OOC_INODE_SEQUENCE,1) & ,size(id%OOC_INODE_SEQUENCE,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_INODE_SEQUENCE ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%OOC_INODE_SEQUENCE) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%OOC_INODE_SEQUENCE(size_array1 & ,size_array2), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_INODE_SEQUENCE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_SIZE_OF_BLOCK) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_SIZE_OF_BLOCK)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_SIZE_OF_BLOCK,1) & *size(id%OOC_SIZE_OF_BLOCK,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_SIZE_OF_BLOCK)) THEN write(unit,iostat=err) size(id%OOC_SIZE_OF_BLOCK,1) & ,size(id%OOC_SIZE_OF_BLOCK,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_SIZE_OF_BLOCK ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%OOC_SIZE_OF_BLOCK) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%OOC_SIZE_OF_BLOCK(size_array1 & ,size_array2), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_SIZE_OF_BLOCK endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_VADDR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_VADDR)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_VADDR,1) & *size(id%OOC_VADDR,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_VADDR)) THEN write(unit,iostat=err) size(id%OOC_VADDR,1) & ,size(id%OOC_VADDR,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_VADDR ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%OOC_VADDR) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%OOC_VADDR(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_VADDR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_TOTAL_NB_NODES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_TOTAL_NB_NODES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%OOC_TOTAL_NB_NODES,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_TOTAL_NB_NODES)) THEN write(unit,iostat=err) size(id%OOC_TOTAL_NB_NODES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_TOTAL_NB_NODES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%OOC_TOTAL_NB_NODES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_TOTAL_NB_NODES(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_TOTAL_NB_NODES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_NB_FILES) CASE(S_OOC_NB_FILE_TYPE) CASE(S_OOC_FILE_NAMES) CASE(S_OOC_FILE_NAME_LENGTH) CASE(S_PIVNUL_LIST) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PIVNUL_LIST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PIVNUL_LIST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PIVNUL_LIST)) THEN write(unit,iostat=err) size(id%PIVNUL_LIST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PIVNUL_LIST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PIVNUL_LIST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PIVNUL_LIST(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PIVNUL_LIST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SUP_PROC) CASE(S_IPTR_WORKING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%IPTR_WORKING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%IPTR_WORKING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%IPTR_WORKING)) THEN write(unit,iostat=err) size(id%IPTR_WORKING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IPTR_WORKING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%IPTR_WORKING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%IPTR_WORKING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IPTR_WORKING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_WORKING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%WORKING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%WORKING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%WORKING)) THEN write(unit,iostat=err) size(id%WORKING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%WORKING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%WORKING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%WORKING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%WORKING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_INTR_ENCODING) NbRecords(i1) =0 SIZE_GEST(i1) =0 SIZE_VARIABLES(i1)=0_8 DO i2=1,NBVARIABLES_ROOTC SELECT CASE(i2) CASE(R_MBLOCK) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%MBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%MBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_NBLOCK) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%NBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%NBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_NPROW) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%NPROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%NPROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_NPCOL) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%NPCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%NPCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_MYROW) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then NbRecords_ROOTC(i2)=1 SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%MYROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%MYROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_MYCOL) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%MYCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%MYCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_SCHUR_MLOC) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%SCHUR_MLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%SCHUR_MLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_SCHUR_NLOC) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%SCHUR_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%SCHUR_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_SCHUR_LLD) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%SCHUR_LLD if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%SCHUR_LLD if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_RHS_NLOC) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%RHS_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%RHS_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_ROOT_SIZE) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%ROOT_SIZE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%ROOT_SIZE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_TOT_ROOT_SIZE) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%TOT_ROOT_SIZE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%TOT_ROOT_SIZE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_DESCRIPTOR) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)= & size(idintr%root%DESCRIPTOR,1) * SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%DESCRIPTOR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT* & size(idintr%root%DESCRIPTOR,1) read(unit,iostat=err) idintr%root%DESCRIPTOR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_CNTXT_BLACS) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%CNTXT_BLACS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%CNTXT_BLACS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_LPIV) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%LPIV if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%LPIV if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_RG2L) CASE(R_IPIV) NbRecords_ROOTC(i2)=2 if(mode.EQ.memory_save_mode) then IF(associated(idintr%root%IPIV)) THEN SIZE_GEST_ROOTC(i2)=SIZE_INT SIZE_VARIABLES_ROOTC(i2)= & size(idintr%root%IPIV,1)*SIZE_INT ELSE SIZE_GEST_ROOTC(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOTC(i2)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(idintr%root%IPIV)) THEN write(unit,iostat=err) size(idintr%root%IPIV,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) idintr%root%IPIV ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(idintr%root%IPIV) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_ROOTC(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOTC(i2)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_ROOTC(i2)=SIZE_INT SIZE_VARIABLES_ROOTC(i2)=size_array1*SIZE_INT allocate(idintr%root%IPIV(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) idintr%root%IPIV endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_yes) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%yes if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_LOGICAL read(unit,iostat=err) idintr%root%yes if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_gridinit_done) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%gridinit_done if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_LOGICAL read(unit,iostat=err) idintr%root%gridinit_done if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_NB_SINGULAR_VALUES) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%NB_SINGULAR_VALUES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%NB_SINGULAR_VALUES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_ROOTC(i2)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_ROOTC(i2)=NbRecords_ROOTC(i2)+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_ROOTC(i2) & +int(SIZE_GEST_ROOTC(i2),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*NbRecords_ROOTC(i2),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES_ROOTC(i2)+ & DIFF_SIZE_ALLOC_READ_ROOTC(i2) size_read=size_read+SIZE_VARIABLES_ROOTC(i2) & +int(SIZE_GEST_ROOTC(i2),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*id%KEEP(34)*NbRecords_ROOTC(i2),kind=8) #endif elseif(mode.EQ.fake_restore_mode) then endif ENDDO CALL DMUMPS_SAVE_RESTORE_L0FACARRAY( & idintr%L0_OMP_FACTORS & ,unit,id%MYID,mode & ,SIZE_GEST_L0FAC,SIZE_VARIABLES_L0FAC & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) CALL DMUMPS_SAVE_RESTORE_ROOTA( & idintr%roota & ,unit,id%MYID,mode & ,SIZE_GEST_ROOTA,SIZE_VARIABLES_ROOTA & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,SIZE_RL_OR_DBL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_NBGRP) CALL MUMPS_SAVE_INT(id%NBGRP) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LRGROUPS) CALL DMUMPS_SAVE_INT_SHPTR_ARRAY(id%LRGROUPS & ) IF (id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_FDM_F_ENCODING) NbRecords(i1)=1 SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=0_8 if(mode.EQ.memory_save_mode) then IF(associated(id%FDM_F_ENCODING)) THEN CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,memory_save_mode & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FDM_F_ENCODING)) THEN write(unit,iostat=err) size(id%FDM_F_ENCODING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,save_mode & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FDM_F_ENCODING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.NE.-999) then CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,restore_mode & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_BLRARRAY_ENCODING) NbRecords(i1)=1 SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=0_8 CALL_SAVE_RESTORE_BLR = .FALSE. if(mode.EQ.memory_save_mode) then IF(associated(id%BLRARRAY_ENCODING)) THEN CALL_SAVE_RESTORE_BLR = .TRUE. ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%BLRARRAY_ENCODING)) THEN write(unit,iostat=err) size(id%BLRARRAY_ENCODING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CALL_SAVE_RESTORE_BLR = .TRUE. ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(id%BLRARRAY_ENCODING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.NE.-999) then CALL_SAVE_RESTORE_BLR = .TRUE. endif endif IF (CALL_SAVE_RESTORE_BLR) THEN CALL DMUMPS_SAVE_RESTORE_BLR(id%BLRARRAY_ENCODING & ,unit,id%MYID,mode & ,SIZE_GEST_BLR,SIZE_VARIABLES_BLR & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_SCHED_SBTR) CASE(S_LPOOL_A_L0_OMP) CALL MUMPS_SAVE_INT(id%LPOOL_A_L0_OMP) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_LPOOL_B_L0_OMP) CALL MUMPS_SAVE_INT(id%LPOOL_B_L0_OMP) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_L_PHYS_L0_OMP) CALL MUMPS_SAVE_INT(id%L_PHYS_L0_OMP) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_L_VIRT_L0_OMP) CALL MUMPS_SAVE_INT(id%L_VIRT_L0_OMP) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_LL0_OMP_MAPPING) CALL MUMPS_SAVE_INT(id%LL0_OMP_MAPPING) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_LL0_OMP_FACTORS) CALL MUMPS_SAVE_INT(id%LL0_OMP_FACTORS) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_THREAD_LA) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%THREAD_LA if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%THREAD_LA if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_IPOOL_A_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%IPOOL_A_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%IPOOL_A_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%IPOOL_A_L0_OMP)) THEN write(unit,iostat=err) size(id%IPOOL_A_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IPOOL_A_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%IPOOL_A_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%IPOOL_A_L0_OMP(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IPOOL_A_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_IPOOL_B_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%IPOOL_B_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%IPOOL_B_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%IPOOL_B_L0_OMP)) THEN write(unit,iostat=err) size(id%IPOOL_B_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IPOOL_B_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%IPOOL_B_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%IPOOL_B_L0_OMP(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IPOOL_B_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PHYS_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PHYS_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%PHYS_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PHYS_L0_OMP)) THEN write(unit,iostat=err) size(id%PHYS_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PHYS_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PHYS_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PHYS_L0_OMP(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PHYS_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_VIRT_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%VIRT_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%VIRT_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%VIRT_L0_OMP)) THEN write(unit,iostat=err) size(id%VIRT_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%VIRT_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%VIRT_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%VIRT_L0_OMP(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%VIRT_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_VIRT_L0_OMP_MAPPING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%VIRT_L0_OMP_MAPPING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%VIRT_L0_OMP_MAPPING,1) & *SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%VIRT_L0_OMP_MAPPING)) THEN write(unit,iostat=err) size(id%VIRT_L0_OMP_MAPPING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%VIRT_L0_OMP_MAPPING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%VIRT_L0_OMP_MAPPING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%VIRT_L0_OMP_MAPPING(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%VIRT_L0_OMP_MAPPING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PERM_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PERM_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PERM_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PERM_L0_OMP)) THEN write(unit,iostat=err) size(id%PERM_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PERM_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PERM_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PERM_L0_OMP(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PERM_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTR_LEAFS_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTR_LEAFS_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%PTR_LEAFS_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTR_LEAFS_L0_OMP)) THEN write(unit,iostat=err) size(id%PTR_LEAFS_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTR_LEAFS_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PTR_LEAFS_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PTR_LEAFS_L0_OMP(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTR_LEAFS_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_L0_OMP_MAPPING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%L0_OMP_MAPPING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%L0_OMP_MAPPING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%L0_OMP_MAPPING)) THEN write(unit,iostat=err) size(id%L0_OMP_MAPPING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%L0_OMP_MAPPING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%L0_OMP_MAPPING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%L0_OMP_MAPPING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%L0_OMP_MAPPING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SINGULAR_VALUES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%SINGULAR_VALUES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%SINGULAR_VALUES,1)*SIZE_RL_OR_DBL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%SINGULAR_VALUES)) THEN write(unit,iostat=err) size(id%SINGULAR_VALUES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(size_written,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%SINGULAR_VALUES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(size_written,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(size_written,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%SINGULAR_VALUES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_RL_OR_DBL allocate(id%SINGULAR_VALUES(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%SINGULAR_VALUES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NB_SINGULAR_VALUES) CALL MUMPS_SAVE_INT(id%NB_SINGULAR_VALUES) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_ASSOCIATED_OOC_FILES) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL endif CASE(S_SAVE_DIR) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%SAVE_DIR)*SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%SAVE_DIR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%SAVE_DIR)*SIZE_CHARACTER read(unit,iostat=err) id%SAVE_DIR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SAVE_PREFIX) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%SAVE_PREFIX)*SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%SAVE_PREFIX if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%SAVE_PREFIX)*SIZE_CHARACTER read(unit,iostat=err) id%SAVE_PREFIX if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MTKO_PROCS_MAP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MTKO_PROCS_MAP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%MTKO_PROCS_MAP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MTKO_PROCS_MAP)) THEN write(unit,iostat=err) size(id%MTKO_PROCS_MAP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MTKO_PROCS_MAP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MTKO_PROCS_MAP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MTKO_PROCS_MAP(0:size_array1-1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MTKO_PROCS_MAP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_METIS_OPTIONS) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%METIS_OPTIONS,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%METIS_OPTIONS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%METIS_OPTIONS,1) read(unit,iostat=err) id%METIS_OPTIONS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_pad1,S_pad2,S_pad3,S_pad4,S_pad5,S_pad6,S_pad7, & S_pad11,S_pad12,S_pad13,S_pad14,S_pad16) CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords(i1)=NbRecords(i1)+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES(i1) & +int(SIZE_GEST(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*NbRecords(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES(i1)+ & DIFF_SIZE_ALLOC_READ(i1) size_read=size_read+SIZE_VARIABLES(i1) & +int(SIZE_GEST(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*id%KEEP(34)*NbRecords(i1),kind=8) #endif elseif(mode.EQ.fake_restore_mode) then endif ENDDO 200 continue if(mode.EQ.memory_save_mode) then WRITTEN_STRUC_SIZE=sum(SIZE_VARIABLES)+ & sum(SIZE_VARIABLES_ROOTC)+ & SIZE_VARIABLES_BLR+SIZE_VARIABLES_FRONT_DATA+ & SIZE_VARIABLES_L0FAC+ & SIZE_VARIABLES_ROOTA TOTAL_STRUC_SIZE=WRITTEN_STRUC_SIZE & +sum(DIFF_SIZE_ALLOC_READ) & +sum(DIFF_SIZE_ALLOC_READ_ROOTC) gest_size=sum(SIZE_GEST)+sum(SIZE_GEST_ROOTC) & +SIZE_GEST_BLR+SIZE_GEST_FRONT_DATA & +SIZE_GEST_L0FAC & +SIZE_GEST_ROOTA & +int(5*SIZE_CHARACTER,kind=8) & +int(23*SIZE_CHARACTER,kind=8) & +int(2*SIZE_INT8,kind=8)+int(1,kind=8) & +int(3*SIZE_INT,kind=8) & +int(SIZE_LOGICAL,kind=8) IF(associated(id%OOC_FILE_NAME_LENGTH).AND. & associated(id%OOC_FILE_NAMES)) THEN gest_size=gest_size+int(SIZE_INT,kind=8) & +int(id%OOC_FILE_NAME_LENGTH(1)*SIZE_CHARACTER,kind=8) ELSE gest_size=gest_size+int(2*SIZE_INT,kind=8) ENDIF #if defined(MUMPS_NOF2003) tot_NbRecords=sum(NbRecords)+sum(NbRecords_ROOTC)+8 gest_size=gest_size+int(2*id%KEEP(34)*tot_NbRecords,kind=8) #endif TOTAL_FILE_SIZE=WRITTEN_STRUC_SIZE+gest_size elseif(mode.EQ.save_mode) then elseif(mode.EQ.restore_mode) then #if ! defined(NOSCALAPACK) if(idintr%root%gridinit_done) then idintr%root%CNTXT_BLACS = id%COMM_NODES CALL blacs_gridinit( idintr%root%CNTXT_BLACS, 'R', & idintr%root%NPROW, idintr%root%NPCOL ) idintr%root%gridinit_done = .TRUE. idintr%root%DESCRIPTOR(2) = idintr%root%CNTXT_BLACS endif #endif elseif(mode.EQ.fake_restore_mode) then elseif(mode.EQ.restore_ooc_mode) then endif 100 continue RETURN CONTAINS SUBROUTINE MUMPS_SAVERSTR_REALARRAY(idREAL) IMPLICIT NONE DOUBLE PRECISION, DIMENSION(:), POINTER :: idREAL NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(idREAL)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(idREAL,1)*SIZE_RL_OR_DBL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(idREAL)) THEN write(unit,iostat=err) size(idreal,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) idREAL ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(idREAL) read(unit,iostat=err) size_array1 if (err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if (size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_RL_OR_DBL allocate(idREAL(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) idREAL endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if (err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif 100 CONTINUE RETURN END SUBROUTINE MUMPS_SAVERSTR_REALARRAY SUBROUTINE MUMPS_SAVE_INT(idINT) IMPLICIT NONE INTEGER, INTENT(INOUT) :: idINT NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idINT if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) idINT if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif 100 CONTINUE RETURN END SUBROUTINE MUMPS_SAVE_INT SUBROUTINE DMUMPS_SAVE_INT_SHPTR_ARRAY(id_INTPTR & ) IMPLICIT NONE INTEGER, POINTER, DIMENSION(:) :: id_INTPTR NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id_INTPTR) & ) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id_INTPTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id_INTPTR) & ) THEN write(unit,iostat=err) size(id_INTPTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id_INTPTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id_INTPTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id_INTPTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) else read(unit,iostat=err) id_INTPTR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif endif endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif 100 CONTINUE RETURN END SUBROUTINE DMUMPS_SAVE_INT_SHPTR_ARRAY END SUBROUTINE DMUMPS_SAVE_RESTORE_STRUCTURE SUBROUTINE DMUMPS_SAVE_RESTORE_ROOTA( & roota & ,unit,MYID,mode & ,SIZE_GEST_ROOTA,SIZE_VARIABLES_ROOTA & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,SIZE_RL_OR_DBL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST_ROOTA INTEGER(8),intent(OUT) :: SIZE_VARIABLES_ROOTA INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER,intent(IN):: SIZE_RL_OR_DBL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: SIZE_GEST, i3 INTEGER(8) :: SIZE_VARIABLE INTEGER, PARAMETER :: NBVARIABLES_ROOTA=7 INTEGER, PARAMETER :: RA_SINGULAR_VALUES=7 INTEGER, PARAMETER :: RA_SVD_VT=6 INTEGER, PARAMETER :: RA_SVD_U=5 INTEGER, PARAMETER :: RA_RHS_ROOT=4 INTEGER, PARAMETER :: RA_QR_TAU=3 INTEGER, PARAMETER :: RA_SCHUR_POINTER=2 INTEGER, PARAMETER :: RA_RHS_CNTR_MASTER_ROOT=1 SIZE_GEST_ROOTA = 0 SIZE_VARIABLES_ROOTA = 0_8 DO i3 = 1, NBVARIABLES_ROOTA SIZE_GEST = 0 SIZE_VARIABLE = 0_8 SELECT CASE(i3) CASE(RA_QR_TAU) CALL DMUMPS_SAVE_RESTORE_ARRAY_C1D( & roota%QR_TAU ) CASE(RA_SVD_U) CALL DMUMPS_SAVE_RESTORE_ARRAY_2D(roota%SVD_U) CASE(RA_SVD_VT) CASE(RA_SINGULAR_VALUES) CALL DMUMPS_SAVE_RESTORE_ARRAY_R1D( & roota%SINGULAR_VALUES) CASE(RA_RHS_CNTR_MASTER_ROOT) CALL DMUMPS_SAVE_RESTORE_ARRAY_C1D( & roota%RHS_CNTR_MASTER_ROOT) CASE(RA_RHS_ROOT) CASE(RA_SCHUR_POINTER) CASE DEFAULT END SELECT IF ( INFO(1) .LT. 0 ) GOTO 100 IF (mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTA = SIZE_VARIABLES_ROOTA + & SIZE_VARIABLE SIZE_GEST_ROOTA = SIZE_GEST_ROOTA + SIZE_GEST ENDIF END DO 100 CONTINUE RETURN CONTAINS SUBROUTINE DMUMPS_SAVE_RESTORE_ARRAY_2D(PTRARRAY2D) IMPLICIT NONE DOUBLE PRECISION, DIMENSION(:,:), POINTER :: PTRARRAY2D INTEGER :: LocalNbRecords, err, allocok, dummy INTEGER :: size_array1, size_array2 INTEGER(8) :: sz LocalNbRecords = 2 if(mode.EQ.memory_save_mode) then IF(associated(PTRARRAY2D)) THEN SIZE_GEST = SIZE_INT*2 SIZE_VARIABLE = size(PTRARRAY2D,1) & *size(PTRARRAY2D,2)*SIZE_ARITH_DEP ELSE SIZE_GEST = SIZE_INT*3 SIZE_VARIABLE = 0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(PTRARRAY2D)) THEN write(unit,iostat=err) size(PTRARRAY2D,1) & ,size(PTRARRAY2D,2) ELSE write(unit,iostat=err) -999,-998 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+2*SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 IF(associated(PTRARRAY2D)) THEN write(unit,iostat=err) PTRARRAY2D sz= int(size(PTRARRAY2D,1),8) * & int(size(PTRARRAY2D,2),8) * & SIZE_ARITH_DEP ELSE write(unit,iostat=err) -999 sz=SIZE_INT ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(PTRARRAY2D) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) else size_read = size_read+2*SIZE_INT size_allocated = size_allocated + 2*SIZE_INT8 endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then read(unit,iostat=err) dummy sz = SIZE_INT else sz = int(size_array1,8)*int(size_array2,8) & * SIZE_ARITH_DEP allocate(PTRARRAY2D(size_array1, & size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) PTRARRAY2D endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & , INFO(2)) else size_read = size_read + sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif #if defined(MUMPS_NOF2003) IF (mode.EQ.memory_save_mode) THEN SIZE_GEST = SIZE_GEST+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.save_mode) THEN size_written = size_written+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.restore_mode) THEN size_read = size_read+2*SIZE_INT*LocalNbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_ARRAY_2D SUBROUTINE DMUMPS_SAVE_RESTORE_ARRAY_C1D(PTRARRAY1D) IMPLICIT NONE DOUBLE PRECISION, DIMENSION(:), POINTER :: PTRARRAY1D INTEGER :: LocalNbRecords, err, allocok, dummy INTEGER :: size_array1 INTEGER(8) :: sz LocalNbRecords = 2 if(mode.EQ.memory_save_mode) then IF(associated(PTRARRAY1D)) THEN SIZE_GEST = SIZE_INT SIZE_VARIABLE = size(PTRARRAY1D)*SIZE_ARITH_DEP ELSE SIZE_GEST = SIZE_INT*2 SIZE_VARIABLE = 0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(PTRARRAY1D)) THEN write(unit,iostat=err) size(PTRARRAY1D) ELSE write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 IF(associated(PTRARRAY1D)) THEN write(unit,iostat=err) PTRARRAY1D sz= int(size(PTRARRAY1D),8)* & SIZE_ARITH_DEP ELSE write(unit,iostat=err) -999 sz=SIZE_INT ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(PTRARRAY1D) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) else size_read = size_read+SIZE_INT size_allocated = size_allocated + SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then read(unit,iostat=err) dummy sz = SIZE_INT else sz = int(size_array1,8) * SIZE_ARITH_DEP allocate(PTRARRAY1D(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) PTRARRAY1D endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & , INFO(2)) else size_read = size_read + sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif #if defined(MUMPS_NOF2003) IF (mode.EQ.memory_save_mode) THEN SIZE_GEST = SIZE_GEST+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.save_mode) THEN size_written = size_written+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.restore_mode) THEN size_read = size_read+2*SIZE_INT*LocalNbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_ARRAY_C1D SUBROUTINE DMUMPS_SAVE_RESTORE_ARRAY_R1D(PTRARRAY1D) IMPLICIT NONE DOUBLE PRECISION, DIMENSION(:), POINTER :: PTRARRAY1D INTEGER :: LocalNbRecords, err, allocok, dummy INTEGER :: size_array1 INTEGER(8) :: sz LocalNbRecords = 2 if(mode.EQ.memory_save_mode) then IF(associated(PTRARRAY1D)) THEN SIZE_GEST = SIZE_INT SIZE_VARIABLE = size(PTRARRAY1D)*SIZE_RL_OR_DBL ELSE SIZE_GEST = SIZE_INT*2 SIZE_VARIABLE = 0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(PTRARRAY1D)) THEN write(unit,iostat=err) size(PTRARRAY1D) ELSE write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 IF(associated(PTRARRAY1D)) THEN write(unit,iostat=err) PTRARRAY1D sz= int(size(PTRARRAY1D),8)* & SIZE_RL_OR_DBL ELSE write(unit,iostat=err) -999 sz=SIZE_INT ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(PTRARRAY1D) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) else size_read = size_read+SIZE_INT size_allocated = size_allocated + SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then read(unit,iostat=err) dummy sz = SIZE_INT else sz = int(size_array1,8) * SIZE_RL_OR_DBL allocate(PTRARRAY1D(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) PTRARRAY1D endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & , INFO(2)) else size_read = size_read + sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif #if defined(MUMPS_NOF2003) IF (mode.EQ.memory_save_mode) THEN SIZE_GEST = SIZE_GEST+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.save_mode) THEN size_written = size_written+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.restore_mode) THEN size_read = size_read+2*SIZE_INT*LocalNbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_ARRAY_R1D END SUBROUTINE DMUMPS_SAVE_RESTORE_ROOTA END MODULE DMUMPS_SAVE_RESTORE #else SUBROUTINE DMUMPS_SAVE_RESTORE_RETURN() RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_RETURN #endif MUMPS_5.8.1/src/sol_common.F0000664000175000017500000001717315042446423015516 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_SOL_GET_NPIV_LIELL_IPOS ( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IMPLICIT NONE INTEGER, INTENT(IN) :: ISTEP, LIW, KEEP(500), N INTEGER, INTENT(IN) :: IW( LIW ) INTEGER, INTENT(IN) :: STEP( N ), PTRIST( KEEP(28) ) INTEGER, INTENT(OUT) :: NPIV, LIELL, IPOS INCLUDE 'mumps_headers.h' INTEGER :: SROOT IF (KEEP(38) .NE. 0) THEN SROOT = STEP(KEEP(38)) ELSE IF (KEEP(20) .NE. 0) THEN SROOT = STEP(KEEP(20)) ELSE SROOT = 0 ENDIF IPOS = PTRIST(ISTEP) IF (IPOS .LE. 0) THEN WRITE(*,*) "Internal error 1 in MUMPS_SOL_GET_NPIV_LIELL_IPOS", & ISTEP CALL MUMPS_ABORT() ENDIF NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SROOT ) THEN IPOS = PTRIST(ISTEP) LIELL = IW(IPOS+3+KEEP(IXSZ)) NPIV = LIELL IPOS= PTRIST(ISTEP)+5+KEEP(IXSZ) ELSE IPOS = PTRIST(ISTEP) + 2+ KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) IPOS= IPOS+1 NPIV = IW(IPOS) IPOS= IPOS+1 IPOS= IPOS+1+IW( PTRIST(ISTEP) + 5 +KEEP(IXSZ)) ENDIF RETURN END SUBROUTINE MUMPS_SOL_GET_NPIV_LIELL_IPOS SUBROUTINE MUMPS_GET_INDICES(MYID_NODES, NSLAVES, N, & PTRIST, KEEP,KEEP8, IW, LIW, STEP, PROCNODE_STEPS, & INDICES, ROW_OR_COL_INDICES) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID_NODES, NSLAVES, N, LIW INTEGER, INTENT(IN) :: PTRIST(KEEP(28)) INTEGER, INTENT(IN) :: IW(LIW), STEP(N) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT(OUT) :: INDICES(KEEP(89)) INTEGER, INTENT(IN) :: ROW_OR_COL_INDICES INTEGER :: ISTEP INTEGER :: NPIV, LIELL, IPOS INTEGER :: IINDICES INTEGER :: J1 INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_PROCNODE IINDICES = 0 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS ( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF ( ROW_OR_COL_INDICES .EQ. 0 ) THEN J1 = IPOS + 1 ELSE IF (ROW_OR_COL_INDICES .EQ. 1 ) THEN J1 = IPOS + LIELL + 1 ELSE WRITE(*,*) "Internal error 1 in MUMPS_GET_INDICES", & ROW_OR_COL_INDICES CALL MUMPS_ABORT() ENDIF IF (IINDICES+NPIV .GT. KEEP(89)) THEN WRITE(*,*) "Internal error 2 in MUMPS_GET_INDICES", & IINDICES, KEEP(89) CALL MUMPS_ABORT() ENDIF INDICES(IINDICES+1:IINDICES+NPIV)=IW(J1:J1+NPIV-1) IINDICES=IINDICES+NPIV ENDIF ENDDO IF (IINDICES .NE. KEEP(89)) THEN WRITE(*,*) "Internal error 3 in MUMPS_GET_INDICES", & IINDICES, KEEP(89) CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE MUMPS_GET_INDICES SUBROUTINE MUMPS_SOL_RHSMAPINFO( N, Nloc_RHS, INFO23, & IRHS_loc, MAP_RHS_loc, & POSINRHSINTR_FWD, & NSLAVES, MYID_NODES, COMM_NODES, & ICNTL, INFO ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, Nloc_RHS INTEGER, INTENT(IN) :: INFO23 INTEGER, INTENT(IN) :: IRHS_loc (max(1,Nloc_RHS)) INTEGER, INTENT(OUT) :: MAP_RHS_loc(max(1,Nloc_RHS)) INTEGER, INTENT(IN) :: POSINRHSINTR_FWD (N) INTEGER, INTENT(IN) :: NSLAVES, MYID_NODES, COMM_NODES INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(IN) :: ICNTL(60) INCLUDE 'mpif.h' INTEGER :: I, NFS_LOC, NFS_TOT, IERR_MPI, allocok #if defined(AVOID_MPI_IN_PLACE) INTEGER :: allocoktmp #endif INTEGER, ALLOCATABLE, DIMENSION(:) :: GLOBAL_MAPPING #if defined(AVOID_MPI_IN_PLACE) ALLOCATE(GLOBAL_MAPPING(int(N,8)+int(N,8)), stat=allocok) IF (allocok .GT. 0) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(int(N,8)+int(N,8), INFO(2)) ENDIF #else ALLOCATE(GLOBAL_MAPPING(N), stat=allocok) IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)= N ENDIF #endif #if defined(AVOID_MPI_IN_PLACE) allocoktmp = allocok CALL MPI_ALLREDUCE(allocoktmp, allocok, 1, #else CALL MPI_ALLREDUCE(MPI_IN_PLACE, allocok, 1, #endif & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI) IF (allocok .NE. 0) RETURN NFS_LOC = 0 NFS_TOT = 0 DO I = 1, N IF (POSINRHSINTR_FWD(I) .LE. 0) THEN GLOBAL_MAPPING(I) = 0 ELSE GLOBAL_MAPPING(I) = MYID_NODES NFS_LOC = NFS_LOC + 1 ENDIF ENDDO CALL MPI_ALLREDUCE(NFS_LOC, NFS_TOT, 1, MPI_INTEGER, & MPI_SUM, COMM_NODES, IERR_MPI) #if defined(AVOID_MPI_IN_PLACE) DO I = 1, N GLOBAL_MAPPING(int(N,8)+int(I,8)) = GLOBAL_MAPPING(I) ENDDO CALL MUMPS_BIGALLREDUCE( .FALSE., & GLOBAL_MAPPING(N+1), GLOBAL_MAPPING, & N, MPI_INTEGER, & MPI_SUM, COMM_NODES, IERR_MPI ) #else CALL MUMPS_BIGALLREDUCE( .TRUE., & MPI_IN_PLACE, GLOBAL_MAPPING, N, MPI_INTEGER, & MPI_SUM, COMM_NODES, IERR_MPI ) #endif DO I = 1, Nloc_RHS IF (IRHS_loc(I) .GE.1 .AND. IRHS_loc(I) .LE. N) THEN MAP_RHS_loc(I) = GLOBAL_MAPPING(IRHS_loc(I)) ELSE MAP_RHS_loc(I) = -87878787 ENDIF ENDDO DEALLOCATE(GLOBAL_MAPPING) RETURN END SUBROUTINE MUMPS_SOL_RHSMAPINFO SUBROUTINE MUMPS_COMPUTE_LASTFS_DYN( INODE, LASTFSSBTR_DYN, &MTYPE, KEEP, IW, LIW, N, STEP, PTRIST, FILS, FRERE ) IMPLICIT NONE INTEGER, INTENT(IN) :: INODE INTEGER, INTENT(OUT) :: LASTFSSBTR_DYN INTEGER, INTENT(IN) :: N, MTYPE, LIW, KEEP(500) INTEGER, INTENT(IN) :: IW(LIW), STEP( N ), PTRIST( KEEP(28) ) INTEGER, INTENT(IN) :: FILS(N), FRERE( KEEP(28) ) INTEGER :: NPIV, LIELL, IPOS, INODE_CUR, IN INODE_CUR = INODE 10 CONTINUE CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS ( STEP(INODE_CUR), KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF ( NPIV .NE. 0 ) THEN IF (MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0) THEN LASTFSSBTR_DYN = IW( IPOS + NPIV ) ELSE LASTFSSBTR_DYN = IW( IPOS+NPIV+LIELL ) ENDIF ELSE IN = INODE_CUR DO WHILE (IN.GT. 0) IN = FILS(IN) ENDDO IF (IN .LT. 0) THEN INODE_CUR = -IN GOTO 10 ELSE DO IF (INODE_CUR .EQ. INODE) THEN LASTFSSBTR_DYN = 0 EXIT ENDIF INODE_CUR = FRERE(STEP(INODE_CUR)) IF (INODE_CUR .GT. 0) THEN GOTO 10 ELSE INODE_CUR = -INODE_CUR ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE MUMPS_COMPUTE_LASTFS_DYN MUMPS_5.8.1/src/dmumps_iXamax.F0000664000175000017500000000132715042446437016164 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C INTEGER FUNCTION DMUMPS_IXAMAX(N,X,INCX,GRAIN) IMPLICIT NONE DOUBLE PRECISION, intent(in) :: X(*) INTEGER, intent(in) :: INCX,N INTEGER, intent(in) :: GRAIN INTEGER idamax DMUMPS_IXAMAX = idamax(N,X,INCX) RETURN END FUNCTION DMUMPS_IXAMAX MUMPS_5.8.1/src/dmumps_ooc.F0000664000175000017500000036322215042446437015522 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_OOC USE MUMPS_OOC_COMMON !$ USE OMP_LIB, ONLY : OMP_LOCK_KIND, OMP_SET_LOCK, OMP_UNSET_LOCK, !$ & OMP_INIT_LOCK, OMP_DESTROY_LOCK, OMP_TEST_LOCK IMPLICIT NONE !$ INTEGER(KIND=OMP_LOCK_KIND) :: LOCK_FOR_L0OMP INTEGER NOT_IN_MEM,BEING_READ,NOT_USED,PERMUTED,USED, & USED_NOT_PERMUTED,ALREADY_USED PARAMETER (NOT_IN_MEM=0,BEING_READ=-1,NOT_USED=-2, & PERMUTED=-3,USED=-4,USED_NOT_PERMUTED=-5,ALREADY_USED=-6) INTEGER OOC_NODE_NOT_IN_MEM,OOC_NODE_PERMUTED, & OOC_NODE_NOT_PERMUTED PARAMETER (OOC_NODE_NOT_IN_MEM=-20, & OOC_NODE_PERMUTED=-21,OOC_NODE_NOT_PERMUTED=-22) INTEGER(8), DIMENSION(:,:),POINTER :: SIZE_OF_BLOCK INTEGER, DIMENSION(:),POINTER :: TOTAL_NB_OOC_NODES INTEGER :: OOC_SOLVE_TYPE_FCT INTEGER, DIMENSION(:),ALLOCATABLE :: IO_REQ INTEGER(8), DIMENSION(:), ALLOCATABLE:: LRLUS_SOLVE INTEGER(8), DIMENSION(:), ALLOCATABLE:: SIZE_SOLVE_Z, & LRLU_SOLVE_T, POSFAC_SOLVE, IDEB_SOLVE_Z, LRLU_SOLVE_B INTEGER, DIMENSION(:),ALLOCATABLE :: PDEB_SOLVE_Z INTEGER (8),SAVE :: FACT_AREA_SIZE, & SIZE_ZONE_SOLVE,SIZE_SOLVE_EMM,TMP_SIZE_FACT, & MAX_SIZE_FACTOR_OOC INTEGER(8), SAVE :: MIN_SIZE_READ INTEGER, SAVE :: TMP_NB_NODES, MAX_NB_NODES_FOR_ZONE,MAX_NB_REQ, & CURRENT_SOLVE_READ_ZONE, & CUR_POS_SEQUENCE,NB_Z,SOLVE_STEP, & NB_ZONE_REQ,MTYPE_OOC,NB_ACT & ,NB_CALLED,REQ_ACT,NB_CALL INTEGER(8), SAVE :: OOC_VADDR_PTR INTEGER(8), SAVE :: SIZE_ZONE_REQ INTEGER(8), DIMENSION(:), ALLOCATABLE :: SIZE_OF_READ, READ_DEST INTEGER,DIMENSION(:),ALLOCATABLE :: FIRST_POS_IN_READ, & READ_MNG,REQ_TO_ZONE,POS_HOLE_T, & POS_HOLE_B,REQ_ID,OOC_STATE_NODE INTEGER DMUMPS_ELEMENTARY_DATA_SIZE,N_OOC INTEGER, DIMENSION(:), ALLOCATABLE :: POS_IN_MEM, INODE_TO_POS INTEGER, DIMENSION(:), ALLOCATABLE :: CURRENT_POS_T,CURRENT_POS_B LOGICAL IS_ROOT_SPECIAL INTEGER SPECIAL_ROOT_NODE PUBLIC :: DMUMPS_OOC_INIT_FACTO,DMUMPS_NEW_FACTOR, & DMUMPS_READ_OOC, & DMUMPS_SOLVE_ALLOC_FACTOR_SPACE, & DMUMPS_IS_THERE_FREE_SPACE, & DMUMPS_OOC_END_SOLVE, & DMUMPS_SOLVE_INIT_OOC_FWD,DMUMPS_SOLVE_INIT_OOC_BWD, & DMUMPS_INITIATE_READ_OPS,DMUMPS_OOC_INIT_SOLVE INTEGER, PARAMETER, PUBLIC :: TYPEF_BOTH_LU = -99976 PUBLIC DMUMPS_OOC_IO_LU_PANEL, & DMUMPS_OOC_PANEL_SIZE PRIVATE DMUMPS_OOC_STORE_LorU, & DMUMPS_OOC_WRT_IN_PANELS_LorU CONTAINS SUBROUTINE DMUMPS_SET_STRAT_IO_FLAGS( STRAT_IO_ARG, & STRAT_IO_ASYNC_ARG, WITH_BUF_ARG, LOW_LEVEL_STRAT_IO_ARG ) IMPLICIT NONE INTEGER, intent(out) :: LOW_LEVEL_STRAT_IO_ARG LOGICAL, intent(out) :: STRAT_IO_ASYNC_ARG, WITH_BUF_ARG INTEGER, intent(in) :: STRAT_IO_ARG INTEGER TMP CALL MUMPS_OOC_IS_ASYNC_AVAIL(TMP) STRAT_IO_ASYNC_ARG=.FALSE. WITH_BUF_ARG=.FALSE. IF(TMP.EQ.1)THEN IF((STRAT_IO_ARG.EQ.1).OR.(STRAT_IO_ARG.EQ.2))THEN STRAT_IO_ASYNC=.TRUE. WITH_BUF=.FALSE. ELSEIF((STRAT_IO_ARG.EQ.4).OR.(STRAT_IO_ARG.EQ.5))THEN STRAT_IO_ASYNC_ARG=.TRUE. WITH_BUF_ARG=.TRUE. ELSEIF(STRAT_IO_ARG.EQ.3)THEN STRAT_IO_ASYNC_ARG=.FALSE. WITH_BUF_ARG=.TRUE. ENDIF LOW_LEVEL_STRAT_IO_ARG=mod(STRAT_IO_ARG,3) ELSE LOW_LEVEL_STRAT_IO_ARG=0 IF(STRAT_IO_ARG.GE.3)THEN WITH_BUF_ARG=.TRUE. ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SET_STRAT_IO_FLAGS FUNCTION DMUMPS_IS_THERE_FREE_SPACE(INODE,ZONE) IMPLICIT NONE INTEGER INODE,ZONE LOGICAL DMUMPS_IS_THERE_FREE_SPACE DMUMPS_IS_THERE_FREE_SPACE=(LRLUS_SOLVE(ZONE).GE. & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) RETURN END FUNCTION DMUMPS_IS_THERE_FREE_SPACE SUBROUTINE DMUMPS_INIT_FACT_AREA_SIZE_S(LA) IMPLICIT NONE INTEGER(8) :: LA FACT_AREA_SIZE=LA END SUBROUTINE DMUMPS_INIT_FACT_AREA_SIZE_S SUBROUTINE DMUMPS_OOC_INIT_FACTO(idICNTL1, idICNTL4, & idN, idNSLAVES, & idMYID, MAXS, idOOC_NB_FILE_TYPE, & idKEEP, idKEEP8, idSTEP, idPROCNODE_STEPS, & idOOC_SIZE_OF_BLOCK, & idOOC_VADDR, idINFO, idOOC_TMPDIR, idOOC_PREFIX, & idOOC_NB_FILES, idOOC_INODE_SEQUENCE) & USE DMUMPS_STRUC_DEF USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER :: idICNTL1, idICNTL4, idN, idNSLAVES, idMYID INTEGER :: idOOC_NB_FILE_TYPE INTEGER, TARGET :: idKEEP(500) INTEGER :: idINFO(2) INTEGER(8), TARGET :: idKEEP8(150) INTEGER, POINTER, DIMENSION(:) :: idSTEP, idPROCNODE_STEPS INTEGER(8),DIMENSION(:,:), POINTER :: idOOC_SIZE_OF_BLOCK INTEGER(8), DIMENSION(:,:), POINTER :: idOOC_VADDR INTEGER(8), INTENT(IN) :: MAXS INTEGER OOC_TMPDIR_MAX_LENGTH, OOC_PREFIX_MAX_LENGTH PARAMETER (OOC_TMPDIR_MAX_LENGTH=1023, OOC_PREFIX_MAX_LENGTH=255) CHARACTER(LEN=OOC_TMPDIR_MAX_LENGTH) :: idOOC_TMPDIR CHARACTER(LEN=OOC_PREFIX_MAX_LENGTH) :: idOOC_PREFIX INTEGER, DIMENSION(:), POINTER :: idOOC_NB_FILES INTEGER, DIMENSION(:,:), POINTER :: idOOC_INODE_SEQUENCE INTEGER IERR INTEGER allocok INTEGER DIM_TMPDIR,DIM_PREFIX INTEGER, DIMENSION(:), ALLOCATABLE :: FILE_FLAG_TAB INTEGER TMP INTEGER KEEP211_LOC ICNTL1 = idICNTL1 IF (idICNTL4 .LT. 1) idICNTL1=0 MAX_SIZE_FACTOR_OOC=0_8 N_OOC=idN SOLVE=.FALSE. IERR=0 IF (idKEEP(400).GT.0) THEN !$ CALL OMP_INIT_LOCK( LOCK_FOR_L0OMP ) 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(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_VADDR))THEN NULLIFY(OOC_VADDR) ENDIF IF(allocated(I_CUR_HBUF_NEXTPOS))THEN DEALLOCATE(I_CUR_HBUF_NEXTPOS) ENDIF OOC_NB_FILE_TYPE=idOOC_NB_FILE_TYPE IF(IERR.LT.0)THEN IF (ICNTL1 > 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) idINFO(1) = IERR idINFO(2) = 0 RETURN ENDIF CALL MUMPS_OOC_INIT_FILETYPE(TYPEF_L, TYPEF_U, TYPEF_CB, & idKEEP(201), idKEEP(251), idKEEP(50), TYPEF_INVALID ) IF (idKEEP(201).EQ.2) THEN OOC_FCT_TYPE=1 ENDIF STEP_OOC=>idSTEP PROCNODE_OOC=>idPROCNODE_STEPS MYID_OOC=idMYID SLAVEF_OOC=idNSLAVES KEEP_OOC => idKEEP SIZE_OF_BLOCK=>idOOC_SIZE_OF_BLOCK OOC_VADDR=>idOOC_VADDR IF(idKEEP(107).GT.0)THEN SIZE_SOLVE_EMM=max(idKEEP8(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(idKEEP(107)),8)) IF(SIZE_ZONE_SOLVE.EQ.SIZE_SOLVE_EMM)THEN SIZE_SOLVE_EMM=idKEEP8(19) SIZE_ZONE_SOLVE=int((dble(MAXS)*0.9d0- & dble(SIZE_SOLVE_EMM))/dble(idKEEP(107)),8) ENDIF ELSE SIZE_ZONE_SOLVE=int(dble(MAXS)*0.9d0,8) SIZE_SOLVE_EMM=SIZE_ZONE_SOLVE ENDIF DMUMPS_ELEMENTARY_DATA_SIZE = idKEEP(35) SIZE_OF_BLOCK=0_8 ALLOCATE(idOOC_NB_FILES(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF idINFO(1) = -13 idINFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF idOOC_NB_FILES=0 OOC_VADDR_PTR=0_8 CALL DMUMPS_SET_STRAT_IO_FLAGS( idKEEP(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=>idOOC_INODE_SEQUENCE ALLOCATE(I_CUR_HBUF_NEXTPOS(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF idINFO(1) = -13 idINFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF I_CUR_HBUF_NEXTPOS = 1 IF(WITH_BUF)THEN CALL DMUMPS_INIT_OOC_BUF(idINFO(1),idINFO(2),IERR) IF(IERR.LT.0)THEN RETURN ENDIF 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_TMPDIR=len(trim(idOOC_TMPDIR)) DIM_PREFIX=len(trim(idOOC_PREFIX)) CALL MUMPS_LOW_LEVEL_INIT_PREFIX(DIM_PREFIX, idOOC_PREFIX) CALL MUMPS_LOW_LEVEL_INIT_TMPDIR(DIM_TMPDIR, idOOC_TMPDIR) ALLOCATE(FILE_FLAG_TAB(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1 .GT. 0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF idINFO(1) = -13 idINFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF FILE_FLAG_TAB(1:OOC_NB_FILE_TYPE)=0 IERR=0 TMP=int(idKEEP8(11)/1000000_8)+1 IF((idKEEP(201).EQ.1).AND.(idKEEP(50).EQ.0) & ) THEN TMP=max(1,TMP/2) ENDIF CALL MUMPS_LOW_LEVEL_INIT_OOC_C(MYID_OOC,TMP, & idKEEP(35),LOW_LEVEL_STRAT_IO,KEEP211_LOC,OOC_NB_FILE_TYPE, & FILE_FLAG_TAB,idKEEP(255),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 idINFO(1) = IERR idINFO(2) = 0 RETURN ENDIF DEALLOCATE(FILE_FLAG_TAB) RETURN END SUBROUTINE DMUMPS_OOC_INIT_FACTO SUBROUTINE DMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZE,IERR) USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) :: LA INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)), SIZE DOUBLE PRECISION A(LA) INTEGER IERR,REQUEST INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=FCT IERR=0 SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)=SIZE MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,SIZE) OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)=OOC_VADDR_PTR OOC_VADDR_PTR=OOC_VADDR_PTR+SIZE TMP_SIZE_FACT=TMP_SIZE_FACT+SIZE TMP_NB_NODES=TMP_NB_NODES+1 IF(TMP_SIZE_FACT.GT.SIZE_ZONE_SOLVE)THEN MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE,TMP_NB_NODES) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 ENDIF IF (.NOT. WITH_BUF) THEN CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & A(PTRFAC(STEP_OOC(INODE))),SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE).GT.KEEP_OOC(28))THEN WRITE(*,*)MYID_OOC,': Internal error (37) in OOC ' CALL MUMPS_ABORT() ENDIF OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE)=INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)= & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)+1 ELSE IF(SIZE.LE.HBUF_SIZE)THEN CALL DMUMPS_OOC_COPY_DATA_TO_BUFFER & (A(PTRFAC(STEP_OOC(INODE))),SIZE,IERR) OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE) = INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE) = & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE) + 1 PTRFAC(STEP_OOC(INODE))=-777777_8 RETURN ELSE CALL DMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL DMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & A(PTRFAC(STEP_OOC(INODE))),SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(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 (38) in OOC ' CALL MUMPS_ABORT() ENDIF OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE)=INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)= & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)+1 CALL DMUMPS_OOC_NEXT_HBUF(OOC_FCT_TYPE) ENDIF END IF PTRFAC(STEP_OOC(INODE))=-777777_8 IF(STRAT_IO_ASYNC)THEN IERR=0 CALL MUMPS_WAIT_REQUEST(REQUEST,IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_NEW_FACTOR SUBROUTINE DMUMPS_READ_OOC(DEST,INODE,IERR & ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR,INODE DOUBLE PRECISION DEST INTEGER 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 IERR=0 OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_LOW_LEVEL_DIRECT_READ(DEST, & SIZE_INT1,SIZE_INT2, & TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) WRITE(ICNTL1,*)MYID_OOC, & ': Problem in MUMPS_LOW_LEVEL_DIRECT_READ' ENDIF RETURN ENDIF 555 CONTINUE IF(.NOT.DMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE).EQ. & INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL DMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_READ_OOC SUBROUTINE DMUMPS_OOC_CLEAN_PENDING(IERR) USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out):: IERR IERR=0 IF (WITH_BUF) THEN CALL DMUMPS_OOC_BUF_CLEAN_PENDING(IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF RETURN END SUBROUTINE DMUMPS_OOC_CLEAN_PENDING SUBROUTINE DMUMPS_OOC_END_FACTO(idKEEP,idKEEP8, & idOOC_MAX_NB_NODES_FOR_ZONE, & idOOC_TOTAL_NB_NODES, & idOOC_FILE_NAMES,idINFO, & idOOC_FILE_NAME_LENGTH, & idOOC_NB_FILES, & IERR) USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER :: idKEEP(500), idINFO(2) INTEGER(8) :: idKEEP8(150) INTEGER :: idOOC_MAX_NB_NODES_FOR_ZONE INTEGER,DIMENSION(:), POINTER :: idOOC_TOTAL_NB_NODES CHARACTER,DIMENSION(:,:), POINTER :: idOOC_FILE_NAMES INTEGER,DIMENSION(:), POINTER :: idOOC_FILE_NAME_LENGTH INTEGER,DIMENSION(:), POINTER :: idOOC_NB_FILES INTEGER, intent(out) :: IERR INTEGER I,SOLVE_OR_FACTO IERR=0 IF (idKEEP(400).GT.0) THEN !$ CALL OMP_DESTROY_LOCK( LOCK_FOR_L0OMP ) ENDIF IF(WITH_BUF)THEN CALL DMUMPS_END_OOC_BUF() ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_VADDR))THEN NULLIFY(OOC_VADDR) ENDIF CALL MUMPS_OOC_END_WRITE_C(IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) GOTO 500 ENDIF idOOC_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 idOOC_TOTAL_NB_NODES(I)=I_CUR_HBUF_NEXTPOS(I)-1 ENDDO DEALLOCATE(I_CUR_HBUF_NEXTPOS) ENDIF idKEEP8(20)=MAX_SIZE_FACTOR_OOC CALL DMUMPS_STRUC_STORE_FILE_NAME( idOOC_NB_FILES, & idOOC_FILE_NAMES, idOOC_FILE_NAME_LENGTH, & idINFO, IERR) IF(IERR.LT.0)THEN GOTO 500 ENDIF 500 CONTINUE SOLVE_OR_FACTO=0 CALL MUMPS_CLEAN_IO_DATA_C(MYID_OOC,SOLVE_OR_FACTO,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF RETURN END SUBROUTINE DMUMPS_OOC_END_FACTO SUBROUTINE DMUMPS_OOC_INIT_SOLVE(idICNTL1, idICNTL4, idN, & idNSLAVES, idMYID, idOOC_NB_FILE_TYPE, idKEEP, idKEEP8, & idINFO, idSTEP, idPROCNODE_STEPS, idOOC_SIZE_OF_BLOCK, & idOOC_INODE_SEQUENCE, & idOOC_VADDR, idOOC_MAX_NB_NODES_FOR_ZONE, idOOC_TOTAL_NB_NODES, & idOOC_NB_FILES, idOOC_FILE_NAME_LENGTH, idOOC_FILE_NAMES, & idCOMM_NODES, idrootyes) IMPLICIT NONE INTEGER :: idICNTL1, idICNTL4, idN, idNSLAVES, idMYID INTEGER :: idOOC_NB_FILE_TYPE INTEGER, TARGET :: idKEEP(500) INTEGER(8) :: idKEEP8(150) INTEGER :: idINFO(2) INTEGER,POINTER,DIMENSION(:) :: idSTEP, idPROCNODE_STEPS INTEGER(8),DIMENSION(:,:), POINTER :: idOOC_SIZE_OF_BLOCK INTEGER, DIMENSION(:,:), POINTER :: idOOC_INODE_SEQUENCE INTEGER(8), DIMENSION(:,:),POINTER :: idOOC_VADDR INTEGER :: idOOC_MAX_NB_NODES_FOR_ZONE INTEGER, DIMENSION(:), POINTER :: idOOC_TOTAL_NB_NODES INTEGER :: idCOMM_NODES LOGICAL :: idrootyes INTEGER,DIMENSION(:), POINTER :: idOOC_NB_FILES INTEGER,DIMENSION(:), POINTER :: idOOC_FILE_NAME_LENGTH CHARACTER,DIMENSION(:,:), POINTER :: idOOC_FILE_NAMES INCLUDE 'mpif.h' INTEGER TMP,I,J INTEGER(8) :: TMP_SIZE8 INTEGER allocok,IERR EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER MASTER_ROOT IERR=0 ICNTL1=idICNTL1 IF (idICNTL4 > 1) ICNTL1 = 0 SOLVE=.TRUE. N_OOC=idN IF(allocated(LRLUS_SOLVE))THEN DEALLOCATE(LRLUS_SOLVE) ENDIF IF(allocated(LRLU_SOLVE_T))THEN DEALLOCATE(LRLU_SOLVE_T) ENDIF IF(allocated(LRLU_SOLVE_B))THEN DEALLOCATE(LRLU_SOLVE_B) ENDIF IF(allocated(POSFAC_SOLVE))THEN DEALLOCATE(POSFAC_SOLVE) ENDIF IF(allocated(IDEB_SOLVE_Z))THEN DEALLOCATE(IDEB_SOLVE_Z) ENDIF IF(allocated(PDEB_SOLVE_Z))THEN DEALLOCATE(PDEB_SOLVE_Z) ENDIF IF(allocated(SIZE_SOLVE_Z))THEN DEALLOCATE(SIZE_SOLVE_Z) ENDIF IF(allocated(CURRENT_POS_T))THEN DEALLOCATE(CURRENT_POS_T) ENDIF IF(allocated(CURRENT_POS_B))THEN DEALLOCATE(CURRENT_POS_B) ENDIF IF(allocated(POS_HOLE_T))THEN DEALLOCATE(POS_HOLE_T) ENDIF IF(allocated(POS_HOLE_B))THEN DEALLOCATE(POS_HOLE_B) ENDIF IF(allocated(OOC_STATE_NODE))THEN DEALLOCATE(OOC_STATE_NODE) ENDIF IF(allocated(POS_IN_MEM))THEN DEALLOCATE(POS_IN_MEM) ENDIF IF(allocated(INODE_TO_POS))THEN DEALLOCATE(INODE_TO_POS) ENDIF IF(allocated(SIZE_OF_READ))THEN DEALLOCATE(SIZE_OF_READ) ENDIF IF(allocated(FIRST_POS_IN_READ))THEN DEALLOCATE(FIRST_POS_IN_READ) ENDIF IF(allocated(READ_DEST))THEN DEALLOCATE(READ_DEST) ENDIF IF(allocated(READ_MNG))THEN DEALLOCATE(READ_MNG) ENDIF IF(allocated(REQ_TO_ZONE))THEN DEALLOCATE(REQ_TO_ZONE) ENDIF IF(allocated(REQ_ID))THEN DEALLOCATE(REQ_ID) ENDIF IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF OOC_NB_FILE_TYPE=idOOC_NB_FILE_TYPE CALL MUMPS_OOC_INIT_FILETYPE(TYPEF_L, TYPEF_U, TYPEF_CB, & idKEEP(201), idKEEP(251), idKEEP(50), TYPEF_INVALID ) DIM_ERR_STR_OOC = ERR_STR_OOC_MAX_LEN CALL MUMPS_LOW_LEVEL_INIT_ERR_STR(DIM_ERR_STR_OOC,ERR_STR_OOC) CALL DMUMPS_OOC_OPEN_FILES_FOR_SOLVE(idINFO, idOOC_NB_FILES, & idMYID, idKEEP, idOOC_FILE_NAME_LENGTH, idOOC_FILE_NAMES ) IF(idINFO(1).LT.0)THEN RETURN ENDIF STEP_OOC=>idSTEP PROCNODE_OOC=>idPROCNODE_STEPS SLAVEF_OOC=idNSLAVES MYID_OOC=idMYID KEEP_OOC => idKEEP SIZE_OF_BLOCK=>idOOC_SIZE_OF_BLOCK OOC_INODE_SEQUENCE=>idOOC_INODE_SEQUENCE OOC_VADDR=>idOOC_VADDR ALLOCATE(IO_REQ(idKEEP(28)), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = idKEEP(28) RETURN ENDIF DMUMPS_ELEMENTARY_DATA_SIZE = idKEEP(35) MAX_NB_NODES_FOR_ZONE=idOOC_MAX_NB_NODES_FOR_ZONE TOTAL_NB_OOC_NODES=>idOOC_TOTAL_NB_NODES CALL DMUMPS_SET_STRAT_IO_FLAGS( idKEEP(204), STRAT_IO_ASYNC, & WITH_BUF, LOW_LEVEL_STRAT_IO) IF(idKEEP(107).GT.0)THEN SIZE_SOLVE_EMM=max(idKEEP8(20), & FACT_AREA_SIZE / 5_8) SIZE_ZONE_SOLVE=max(SIZE_SOLVE_EMM, & int((dble(FACT_AREA_SIZE)- & dble(SIZE_SOLVE_EMM))/dble(idKEEP(107)),8)) SIZE_ZONE_SOLVE=max(SIZE_ZONE_SOLVE,0_8) IF(SIZE_ZONE_SOLVE.EQ.SIZE_SOLVE_EMM)THEN SIZE_SOLVE_EMM=idKEEP8(20) SIZE_ZONE_SOLVE=int((dble(FACT_AREA_SIZE)- & dble(SIZE_SOLVE_EMM))/dble(idKEEP(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.idKEEP8(20))THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': More space needed for & solution step in DMUMPS_OOC_INIT_SOLVE' idINFO(1) = -11 CALL MUMPS_SET_IERROR(idKEEP8(20), idINFO(2)) ENDIF TMP=MAX_NB_NODES_FOR_ZONE CALL MPI_ALLREDUCE(TMP,MAX_NB_NODES_FOR_ZONE,1, & MPI_INTEGER,MPI_MAX,idCOMM_NODES, IERR) NB_Z=KEEP_OOC(107)+1 ALLOCATE(POS_IN_MEM(MAX_NB_NODES_FOR_ZONE*NB_Z), & INODE_TO_POS(KEEP_OOC(28)), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = idKEEP(28)+(MAX_NB_NODES_FOR_ZONE*NB_Z) RETURN ENDIF ALLOCATE(OOC_STATE_NODE(KEEP_OOC(28)),stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = idKEEP(28) RETURN ENDIF OOC_STATE_NODE(1:KEEP_OOC(28))=0 INODE_TO_POS=0 POS_IN_MEM=0 ALLOCATE(LRLUS_SOLVE(NB_Z), LRLU_SOLVE_T(NB_Z),LRLU_SOLVE_B(NB_Z), & POSFAC_SOLVE(NB_Z),IDEB_SOLVE_Z(NB_Z), & PDEB_SOLVE_Z(NB_Z),SIZE_SOLVE_Z(NB_Z), & CURRENT_POS_T(NB_Z),CURRENT_POS_B(NB_Z), & POS_HOLE_T(NB_Z),POS_HOLE_B(NB_Z), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = 9*(NB_Z+1) RETURN ENDIF IERR=0 CALL MUMPS_GET_MAX_NB_REQ_C(MAX_NB_REQ,IERR) ALLOCATE(SIZE_OF_READ(MAX_NB_REQ),FIRST_POS_IN_READ(MAX_NB_REQ), & READ_DEST(MAX_NB_REQ),READ_MNG(MAX_NB_REQ), & REQ_TO_ZONE(MAX_NB_REQ),REQ_ID(MAX_NB_REQ),stat=allocok) SIZE_OF_READ=-9999_8 FIRST_POS_IN_READ=-9999 READ_DEST=-9999_8 READ_MNG=-9999 REQ_TO_ZONE=-9999 REQ_ID=-9999 IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = 6*(NB_Z+1) RETURN ENDIF MIN_SIZE_READ=min(max((1024_8*1024_8)/int(idKEEP(35),8), & SIZE_ZONE_SOLVE/3_8), & SIZE_ZONE_SOLVE) TMP_SIZE8=1_8 J=1 DO I=1,NB_Z-1 IDEB_SOLVE_Z(I)=TMP_SIZE8 POSFAC_SOLVE(I)=TMP_SIZE8 LRLUS_SOLVE(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_T(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_B(I)=0_8 SIZE_SOLVE_Z(I)=SIZE_ZONE_SOLVE CURRENT_POS_T(I)=J CURRENT_POS_B(I)=J PDEB_SOLVE_Z(I)=J POS_HOLE_T(I)=J POS_HOLE_B(I)=J J=J+MAX_NB_NODES_FOR_ZONE TMP_SIZE8=TMP_SIZE8+SIZE_ZONE_SOLVE ENDDO IDEB_SOLVE_Z(NB_Z)=TMP_SIZE8 PDEB_SOLVE_Z(NB_Z)=J POSFAC_SOLVE(NB_Z)=TMP_SIZE8 LRLUS_SOLVE(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_T(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_B(NB_Z)=0_8 SIZE_SOLVE_Z(NB_Z)=SIZE_SOLVE_EMM CURRENT_POS_T(NB_Z)=J CURRENT_POS_B(NB_Z)=J POS_HOLE_T(NB_Z)=J POS_HOLE_B(NB_Z)=J IO_REQ=-77777 REQ_ACT=0 OOC_STATE_NODE(1:KEEP_OOC(28))=NOT_IN_MEM IF(KEEP_OOC(38).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(38))), & KEEP_OOC(199) ) SPECIAL_ROOT_NODE=KEEP_OOC(38) ELSEIF(KEEP_OOC(20).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(20))), & KEEP_OOC(199) ) SPECIAL_ROOT_NODE=KEEP_OOC(20) ELSE MASTER_ROOT=-111111 SPECIAL_ROOT_NODE=-2222222 ENDIF IF ( KEEP_OOC(60).EQ.0 .AND. & ( & (KEEP_OOC(38).NE.0 .AND. idrootyes) & .OR. & (KEEP_OOC(20).NE.0 .AND. MYID_OOC.EQ.MASTER_ROOT)) & ) & THEN IS_ROOT_SPECIAL = .TRUE. ELSE IS_ROOT_SPECIAL = .FALSE. ENDIF NB_ZONE_REQ=0 SIZE_ZONE_REQ=0_8 CURRENT_SOLVE_READ_ZONE=0 NB_CALLED=0 NB_CALL=0 SOLVE_STEP=-9999 RETURN END SUBROUTINE DMUMPS_OOC_INIT_SOLVE SUBROUTINE DMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER I IERR=0 IF(NB_Z.GT.1)THEN IF(STRAT_IO_ASYNC)THEN DO I=1,NB_Z-1 CALL DMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO ELSE CALL DMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_INITIATE_READ_OPS SUBROUTINE DMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER ZONE CALL DMUMPS_SOLVE_SELECT_ZONE(ZONE) IERR=0 CALL DMUMPS_SOLVE_ZONE_READ(ZONE,A,LA,PTRFAC,NSTEPS,IERR) RETURN END SUBROUTINE DMUMPS_SUBMIT_READ_FOR_Z SUBROUTINE DMUMPS_READ_SOLVE_BLOCK(DEST,INDICE,SIZE, & ZONE,PTRFAC,NSTEPS,POS_SEQ,NB_NODES,FLAG,IERR) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER ZONE,NSTEPS,FLAG,POS_SEQ,NB_NODES DOUBLE PRECISION DEST INTEGER (8) :: INDICE, SIZE, PTRFAC(NSTEPS) INTEGER REQUEST,INODE,IERR INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=OOC_SOLVE_TYPE_FCT IERR=0 INODE=OOC_INODE_SEQUENCE(POS_SEQ,OOC_FCT_TYPE) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_READ_OOC_C(LOW_LEVEL_STRAT_IO, & DEST,SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(STRAT_IO_ASYNC)THEN CALL DMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL DMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL DMUMPS_SOLVE_UPDATE_POINTERS(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF END SUBROUTINE DMUMPS_READ_SOLVE_BLOCK SUBROUTINE DMUMPS_SOLVE_UPDATE_POINTERS(REQUEST,PTRFAC, & NSTEPS) IMPLICIT NONE INTEGER NSTEPS,REQUEST INTEGER (8) :: PTRFAC(NSTEPS) INTEGER (8) :: LAST, POS_IN_S, J INTEGER ZONE INTEGER POS_REQ,I,TMP_NODE,POS_IN_MANAGE INTEGER (8) SIZE LOGICAL DONT_USE EXTERNAL MUMPS_TYPENODE,MUMPS_PROCNODE INTEGER MUMPS_TYPENODE,MUMPS_PROCNODE POS_REQ=mod(REQUEST,MAX_NB_REQ)+1 SIZE=SIZE_OF_READ(POS_REQ) I=FIRST_POS_IN_READ(POS_REQ) POS_IN_S=READ_DEST(POS_REQ) POS_IN_MANAGE=READ_MNG(POS_REQ) ZONE=REQ_TO_ZONE(POS_REQ) DONT_USE=.FALSE. J=0_8 DO WHILE((J.LT.SIZE).AND.(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))) TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) LAST=SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN I=I+1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(TMP_NODE)).NE.0).AND. & (INODE_TO_POS(STEP_OOC(TMP_NODE)).LT. & -((N_OOC+1)*NB_Z)))THEN DONT_USE= & (((MTYPE_OOC.EQ.1).AND.(KEEP_OOC(50).EQ.0).AND. & (SOLVE_STEP.EQ.1).AND. & ((MUMPS_TYPENODE(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & KEEP_OOC(199)).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),KEEP_OOC(199)).NE. & MYID_OOC))) & .OR. & ((MTYPE_OOC.NE.1).AND.(KEEP_OOC(50).EQ.0).AND. & (SOLVE_STEP.EQ.0).AND. & ((MUMPS_TYPENODE(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & KEEP_OOC(199)).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),KEEP_OOC(199)).NE. & MYID_OOC)))).OR. & (OOC_STATE_NODE(STEP_OOC(TMP_NODE)).EQ.ALREADY_USED) IF(DONT_USE)THEN PTRFAC(STEP_OOC(TMP_NODE))=-POS_IN_S ELSE PTRFAC(STEP_OOC(TMP_NODE))=POS_IN_S ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).LT. & IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Inernal error (42) in OOC ', & PTRFAC(STEP_OOC(TMP_NODE)),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).GT. & (IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)-1_8))THEN WRITE(*,*)MYID_OOC,': Inernal error (43) in OOC ' CALL MUMPS_ABORT() ENDIF IF(DONT_USE)THEN POS_IN_MEM(POS_IN_MANAGE)=-TMP_NODE INODE_TO_POS(STEP_OOC(TMP_NODE))=-POS_IN_MANAGE IF(OOC_STATE_NODE(STEP_OOC(TMP_NODE)).NE. & ALREADY_USED)THEN OOC_STATE_NODE(STEP_OOC(TMP_NODE))=USED_NOT_PERMUTED ENDIF LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+LAST ELSE POS_IN_MEM(POS_IN_MANAGE)=TMP_NODE INODE_TO_POS(STEP_OOC(TMP_NODE))=POS_IN_MANAGE OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED ENDIF IO_REQ(STEP_OOC(TMP_NODE))=-7777 ELSE POS_IN_MEM(POS_IN_MANAGE)=0 ENDIF POS_IN_S=POS_IN_S+LAST POS_IN_MANAGE=POS_IN_MANAGE+1 J=J+LAST I=I+1 ENDDO SIZE_OF_READ(POS_REQ)=-9999_8 FIRST_POS_IN_READ(POS_REQ)=-9999 READ_DEST(POS_REQ)=-9999_8 READ_MNG(POS_REQ)=-9999 REQ_TO_ZONE(POS_REQ)=-9999 REQ_ID(POS_REQ)=-9999 RETURN END SUBROUTINE DMUMPS_SOLVE_UPDATE_POINTERS SUBROUTINE DMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,DEST,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER INODE,ZONE,REQUEST,FLAG,POS_SEQ,NB_NODES,NSTEPS INTEGER(8) :: SIZE INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: DEST, LOCAL_DEST, J8 INTEGER I,TMP_NODE,LOC_I,POS_REQ,NB INTEGER(8)::LAST INTEGER, intent(out) :: IERR IERR=0 IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN RETURN ENDIF NB=0 LOCAL_DEST=DEST I=POS_SEQ POS_REQ=mod(REQUEST,MAX_NB_REQ)+1 IF(REQ_ID(POS_REQ).NE.-9999)THEN CALL MUMPS_WAIT_REQUEST(REQ_ID(POS_REQ),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF CALL DMUMPS_SOLVE_UPDATE_POINTERS(REQUEST,PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF SIZE_OF_READ(POS_REQ)=SIZE FIRST_POS_IN_READ(POS_REQ)=I READ_DEST(POS_REQ)=DEST IF(FLAG.EQ.0)THEN READ_MNG(POS_REQ)=CURRENT_POS_B(ZONE)-NB_NODES+1 ELSEIF(FLAG.EQ.1)THEN READ_MNG(POS_REQ)=CURRENT_POS_T(ZONE) ENDIF REQ_TO_ZONE(POS_REQ)=ZONE REQ_ID(POS_REQ)=REQUEST J8=0_8 IF(FLAG.EQ.0)THEN LOC_I=CURRENT_POS_B(ZONE)-NB_NODES+1 ENDIF DO WHILE((J8.LT.SIZE).AND.(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))) TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) LAST=SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I+1 CYCLE ENDIF IF((IO_REQ(STEP_OOC(TMP_NODE)).GE.0).OR. & (INODE_TO_POS(STEP_OOC(TMP_NODE)).NE.0))THEN IF(FLAG.EQ.1)THEN POS_IN_MEM(CURRENT_POS_T(ZONE))=0 ELSEIF(FLAG.EQ.0)THEN POS_IN_MEM(CURRENT_POS_B(ZONE))=0 ENDIF ELSE IO_REQ(STEP_OOC(TMP_NODE))=REQUEST LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)-LAST IF(FLAG.EQ.1)THEN IF(POSFAC_SOLVE(ZONE).EQ.IDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)+LAST LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)-LAST POS_IN_MEM(CURRENT_POS_T(ZONE))=-TMP_NODE- & ((N_OOC+1)*NB_Z) INODE_TO_POS(STEP_OOC(TMP_NODE))=-CURRENT_POS_T(ZONE)- & ((N_OOC+1)*NB_Z) OOC_STATE_NODE(STEP_OOC(TMP_NODE))=BEING_READ PTRFAC(STEP_OOC(TMP_NODE))=-LOCAL_DEST LOCAL_DEST=LOCAL_DEST+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(FLAG.EQ.0)THEN LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)-LAST POS_IN_MEM(LOC_I)=-TMP_NODE-((N_OOC+1)*NB_Z) IF(LOC_I.EQ.POS_HOLE_T(ZONE))THEN IF(POS_HOLE_T(ZONE).LT.CURRENT_POS_T(ZONE))THEN POS_HOLE_T(ZONE)=POS_HOLE_T(ZONE)+1 ENDIF ENDIF INODE_TO_POS(STEP_OOC(TMP_NODE))=-LOC_I-((N_OOC+1)*NB_Z) OOC_STATE_NODE(STEP_OOC(TMP_NODE))=BEING_READ PTRFAC(STEP_OOC(TMP_NODE))=-LOCAL_DEST LOCAL_DEST=LOCAL_DEST+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSE WRITE(*,*)MYID_OOC,': Internal error (39) in OOC ', & ' Invalid Flag Value in ', & ' DMUMPS_UPDATE_READ_REQ_NODE',FLAG CALL MUMPS_ABORT() ENDIF ENDIF IF(POS_IN_MEM(CURRENT_POS_T(ZONE)).NE.0)THEN IF(POS_IN_MEM(CURRENT_POS_T(ZONE)).EQ. & POS_IN_MEM(PDEB_SOLVE_Z(ZONE)))THEN IF(CURRENT_POS_T(ZONE).NE.PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (40) in OOC ', & CURRENT_POS_T(ZONE), & PDEB_SOLVE_Z(ZONE), & POS_IN_MEM(CURRENT_POS_T(ZONE)), & POS_IN_MEM(PDEB_SOLVE_Z(ZONE)) CALL MUMPS_ABORT() ENDIF ENDIF ENDIF J8=J8+LAST IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (41) in OOC ', & ' LRLUS_SOLVE must be (1) > 0', & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF I=I+1 IF(FLAG.EQ.1)THEN CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)+1 IF(CURRENT_POS_T(ZONE).GT. & MAX_NB_NODES_FOR_ZONE+PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (1) in OOC ' CALL MUMPS_ABORT() ENDIF POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) ELSEIF(FLAG.EQ.0)THEN IF(POS_HOLE_B(ZONE).LT.PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (2) in OOC ', & POS_HOLE_B(ZONE),LOC_I CALL MUMPS_ABORT() ENDIF CURRENT_POS_B(ZONE)=CURRENT_POS_B(ZONE)-1 POS_HOLE_B(ZONE)=CURRENT_POS_B(ZONE) IF(POS_HOLE_B(ZONE).LT.PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF ELSE WRITE(*,*)MYID_OOC,': Internal error (3) in OOC ', & ' Invalid Flag Value in ', & ' DMUMPS_UPDATE_READ_REQ_NODE',FLAG CALL MUMPS_ABORT() ENDIF IF(FLAG.EQ.0)THEN LOC_I=LOC_I+1 ENDIF NB=NB+1 ENDDO IF(NB.NE.NB_NODES)THEN WRITE(*,*)MYID_OOC,': Internal error (4) in OOC ', & ' DMUMPS_UPDATE_READ_REQ_NODE ',NB,NB_NODES ENDIF IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=I ELSE CUR_POS_SEQUENCE=POS_SEQ-1 ENDIF RETURN END SUBROUTINE DMUMPS_UPDATE_READ_REQ_NODE SUBROUTINE DMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,NSTEPS,A, & LA,FLAG,IERR) IMPLICIT NONE INTEGER(8) :: LA INTEGER, intent(out):: IERR DOUBLE PRECISION A(LA) INTEGER INODE,NSTEPS INTEGER(8) :: PTRFAC(NSTEPS) LOGICAL FLAG INTEGER(8) FREE_SIZE INTEGER TMP,TMP_NODE,I,ZONE,J INTEGER WHICH INTEGER(8) :: DUMMY_SIZE DUMMY_SIZE=1_8 IERR = 0 WHICH=-1 IF(INODE_TO_POS(STEP_OOC(INODE)).LE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (5) in OOC ', & ' Problem in DMUMPS_FREE_FACTORS_FOR_SOLVE', & INODE, STEP_OOC(INODE), INODE_TO_POS(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE).EQ.0_8)THEN INODE_TO_POS(STEP_OOC(INODE))=0 OOC_STATE_NODE(STEP_OOC(INODE))=ALREADY_USED RETURN ENDIF CALL DMUMPS_SOLVE_FIND_ZONE(INODE,ZONE,PTRFAC,NSTEPS) TMP=INODE_TO_POS(STEP_OOC(INODE)) INODE_TO_POS(STEP_OOC(INODE))=-TMP POS_IN_MEM(TMP)=-INODE PTRFAC(STEP_OOC(INODE))=-PTRFAC(STEP_OOC(INODE)) IF (KEEP_OOC(237).eq.0) THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).NE.PERMUTED)THEN WRITE(*,*)MYID_OOC,': INTERNAL ERROR (53) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF ENDIF OOC_STATE_NODE(STEP_OOC(INODE))=USED LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (6) in OOC ', & ': LRLUS_SOLVE must be (2) > 0' CALL MUMPS_ABORT() ENDIF IF(ZONE.EQ.NB_Z)THEN IF(INODE.NE.SPECIAL_ROOT_NODE)THEN CALL DMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & DUMMY_SIZE,PTRFAC,KEEP_OOC(28),ZONE,IERR) ENDIF ELSE IF(SOLVE_STEP.EQ.0)THEN IF(TMP.GT.POS_HOLE_B(ZONE))THEN WHICH=0 ELSEIF(TMP.LT.POS_HOLE_T(ZONE))THEN WHICH=1 ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(TMP.LT.POS_HOLE_T(ZONE))THEN WHICH=1 ELSEIF(TMP.GT.POS_HOLE_B(ZONE))THEN WHICH=0 ENDIF ENDIF IF(WHICH.EQ.1)THEN J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_T(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE=0_8 DO I=J,TMP,-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN GOTO 666 ENDIF ENDDO POS_HOLE_T(ZONE)=TMP 666 CONTINUE ELSEIF(WHICH.EQ.0)THEN J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_B(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE=0_8 DO I=J,TMP IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN IF(J.EQ.PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 CURRENT_POS_B(ZONE)=-9999 ENDIF GOTO 777 ENDIF ENDDO POS_HOLE_B(ZONE)=TMP 777 CONTINUE ENDIF IERR=0 ENDIF IF((NB_Z.GT.1).AND.FLAG)THEN CALL DMUMPS_SOLVE_TRY_ZONE_FOR_READ(ZONE) IF((LRLUS_SOLVE(ZONE).GE.MIN_SIZE_READ).OR. & (LRLUS_SOLVE(ZONE).GE. & int(0.3D0*dble(SIZE_SOLVE_Z(ZONE)),8)))THEN CALL DMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL DMUMPS_SOLVE_SELECT_ZONE(ZONE) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_FREE_FACTORS_FOR_SOLVE FUNCTION DMUMPS_SOLVE_IS_INODE_IN_MEM(INODE,PTRFAC,NSTEPS,A,LA, & IERR) IMPLICIT NONE INTEGER INODE,NSTEPS INTEGER(8) :: LA INTEGER, INTENT(out)::IERR DOUBLE PRECISION A(LA) INTEGER (8) :: PTRFAC(NSTEPS) INTEGER DMUMPS_SOLVE_IS_INODE_IN_MEM IERR=0 IF(INODE_TO_POS(STEP_OOC(INODE)).GT.0)THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN DMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_PERMUTED ELSE DMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_PERMUTED ENDIF IF(.NOT.DMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE) & .EQ.INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL DMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF ELSEIF(INODE_TO_POS(STEP_OOC(INODE)).LT.0)THEN IF(INODE_TO_POS(STEP_OOC(INODE)).LT.-((N_OOC+1)*NB_Z))THEN CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(INODE)),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': Internal error (7) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF CALL DMUMPS_SOLVE_UPDATE_POINTERS(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ELSE CALL DMUMPS_SOLVE_UPD_NODE_INFO(INODE,PTRFAC,NSTEPS) IF(.NOT.DMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE).EQ. & INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL DMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF ENDIF IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN DMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_PERMUTED ELSE DMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_PERMUTED ENDIF ELSE DMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_IN_MEM ENDIF RETURN END FUNCTION DMUMPS_SOLVE_IS_INODE_IN_MEM SUBROUTINE DMUMPS_SOLVE_MODIFY_STATE_NODE(INODE) IMPLICIT NONE INTEGER INODE IF ( (KEEP_OOC(237).EQ.0) & .AND. (KEEP_OOC(235).EQ.0) & .AND. (KEEP_OOC(212).EQ.0) & ) THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).NE.NOT_USED)THEN WRITE(*,*)MYID_OOC,': INTERNAL ERROR (51) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF ENDIF OOC_STATE_NODE(STEP_OOC(INODE))=PERMUTED END SUBROUTINE DMUMPS_SOLVE_MODIFY_STATE_NODE SUBROUTINE DMUMPS_SOLVE_UPD_NODE_INFO(INODE,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER INODE,NSTEPS INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZONE INODE_TO_POS(STEP_OOC(INODE))=-INODE_TO_POS(STEP_OOC(INODE)) POS_IN_MEM(INODE_TO_POS(STEP_OOC(INODE)))= & -POS_IN_MEM(INODE_TO_POS(STEP_OOC(INODE))) PTRFAC(STEP_OOC(INODE))=-PTRFAC(STEP_OOC(INODE)) IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.USED_NOT_PERMUTED)THEN OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED ELSEIF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.USED)THEN OOC_STATE_NODE(STEP_OOC(INODE))=PERMUTED ELSE WRITE(*,*)MYID_OOC,': Internal error (52) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)), & INODE_TO_POS(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF CALL DMUMPS_SEARCH_SOLVE(PTRFAC(STEP_OOC(INODE)),ZONE) IF(INODE_TO_POS(STEP_OOC(INODE)).LE.POS_HOLE_B(ZONE))THEN IF(INODE_TO_POS(STEP_OOC(INODE)).GT. & PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)= & INODE_TO_POS(STEP_OOC(INODE))-1 ELSE CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF ENDIF IF(INODE_TO_POS(STEP_OOC(INODE)).GE.POS_HOLE_T(ZONE))THEN IF(INODE_TO_POS(STEP_OOC(INODE)).LT. & CURRENT_POS_T(ZONE)-1)THEN POS_HOLE_T(ZONE)=INODE_TO_POS(STEP_OOC(INODE))+1 ELSE POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) ENDIF ENDIF CALL DMUMPS_OOC_UPDATE_SOLVE_STAT(INODE,PTRFAC,NSTEPS,1) END SUBROUTINE DMUMPS_SOLVE_UPD_NODE_INFO SUBROUTINE DMUMPS_SOLVE_FIND_ZONE(INODE,ZONE,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER INODE,ZONE,NSTEPS INTEGER (8) :: PTRFAC(NSTEPS) ZONE=1 DO WHILE (ZONE.LE.NB_Z) IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN ZONE=ZONE-1 EXIT ENDIF ZONE=ZONE+1 ENDDO IF(ZONE.EQ.NB_Z+1)THEN ZONE=ZONE-1 ENDIF END SUBROUTINE DMUMPS_SOLVE_FIND_ZONE SUBROUTINE DMUMPS_SOLVE_TRY_ZONE_FOR_READ(ZONE) IMPLICIT NONE INTEGER ZONE ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1)+1 END SUBROUTINE DMUMPS_SOLVE_TRY_ZONE_FOR_READ SUBROUTINE DMUMPS_SOLVE_SELECT_ZONE(ZONE) IMPLICIT NONE INTEGER ZONE IF(NB_Z.GT.1)THEN CURRENT_SOLVE_READ_ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1) ZONE=CURRENT_SOLVE_READ_ZONE+1 ELSE ZONE=NB_Z ENDIF END SUBROUTINE DMUMPS_SOLVE_SELECT_ZONE SUBROUTINE DMUMPS_SOLVE_ALLOC_FACTOR_SPACE(INODE,PTRFAC, & KEEP,KEEP8, & A,IERR) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER, intent(out)::IERR INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION A(FACT_AREA_SIZE) INTEGER(8) :: REQUESTED_SIZE INTEGER ZONE,IFLAG IERR=0 IFLAG=0 IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) & .EQ.0_8)THEN INODE_TO_POS(STEP_OOC(INODE))=1 OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED PTRFAC(STEP_OOC(INODE))=1_8 RETURN ENDIF REQUESTED_SIZE=SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ZONE=NB_Z IF(CURRENT_POS_T(ZONE).GT. & (PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1))THEN CALL DMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF((LRLU_SOLVE_T(ZONE).GT.SIZE_OF_BLOCK(STEP_OOC(INODE), & OOC_FCT_TYPE)).AND. & (CURRENT_POS_T(ZONE).LE. & (PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1)))THEN CALL DMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(LRLU_SOLVE_B(ZONE).GT.SIZE_OF_BLOCK(STEP_OOC(INODE), & OOC_FCT_TYPE).AND. & (CURRENT_POS_B(ZONE).GT.0))THEN CALL DMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSE IF(DMUMPS_IS_THERE_FREE_SPACE(INODE,ZONE))THEN IF(SOLVE_STEP.EQ.0)THEN CALL DMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL DMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL DMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL DMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ELSE CALL DMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL DMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL DMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL DMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ENDIF IF(IFLAG.EQ.0)THEN CALL DMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL DMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ELSE WRITE(*,*)MYID_OOC,': Internal error (8) in OOC ', & ' Not enough space for Solve',INODE, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE), & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF ENDIF IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (9) in OOC ', & ' LRLUS_SOLVE must be (3) > 0' CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE DMUMPS_SOLVE_ALLOC_FACTOR_SPACE SUBROUTINE DMUMPS_GET_TOP_AREA_SPACE(A,LA,REQUESTED_SIZE,PTRFAC, & NSTEPS,ZONE,FLAG,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE,FLAG INTEGER(8) :: REQUESTED_SIZE, LA INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: FREE_SIZE, FREE_HOLE, FREE_HOLE_POS DOUBLE PRECISION A(LA) INTEGER I,TMP_NODE,FREE_HOLE_FLAG, J INTEGER, intent(out)::IERR IERR=0 FLAG=0 IF(LRLU_SOLVE_T(ZONE).EQ.SIZE_SOLVE_Z(ZONE).AND. & (.NOT.(CURRENT_POS_T(ZONE) & .GT.PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1)))THEN GOTO 50 ENDIF J=max(POS_HOLE_B(ZONE),PDEB_SOLVE_Z(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) DO I=POS_HOLE_T(ZONE)-1,J,-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) ELSEIF(POS_IN_MEM(I).NE.0)THEN EXIT ENDIF ENDDO POS_HOLE_T(ZONE)=I+1 IF((POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE)).OR. & (POS_HOLE_T(ZONE).LE.POS_HOLE_B(ZONE)).OR. & (POS_HOLE_T(ZONE).EQ.POS_HOLE_B(ZONE)+1))THEN CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_T(ZONE)=PDEB_SOLVE_Z(ZONE) ENDIF FREE_HOLE=0_8 FREE_SIZE=0_8 FREE_HOLE_FLAG=0 FREE_HOLE_POS=POSFAC_SOLVE(ZONE) DO I=CURRENT_POS_T(ZONE)-1,POS_HOLE_T(ZONE),-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) FREE_HOLE_FLAG=0 FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE))) PTRFAC(STEP_OOC(TMP_NODE))=-777777_8 INODE_TO_POS(STEP_OOC(TMP_NODE))=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED POS_IN_MEM(I)=0 FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).EQ.0)THEN FREE_HOLE_FLAG=1 ELSEIF(POS_IN_MEM(I).NE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (10) in OOC ', & ' DMUMPS_GET_TOP_AREA_SPACE', & CURRENT_POS_T(ZONE)-1,POS_HOLE_T(ZONE),I CALL MUMPS_ABORT() ENDIF ENDDO IF(POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE))THEN IF(FREE_HOLE_FLAG.EQ.0)THEN FREE_HOLE_FLAG=1 ENDIF ENDIF IF(FREE_HOLE_FLAG.EQ.1)THEN IF(POS_HOLE_T(ZONE)-1.GT.PDEB_SOLVE_Z(ZONE))THEN I=POS_HOLE_T(ZONE)-1 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.(N_OOC+1)*NB_Z)THEN TMP_NODE=TMP_NODE-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (11) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL DMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSEIF(TMP_NODE.EQ.0)THEN DO J=I,PDEB_SOLVE_Z(ZONE),-1 IF(POS_IN_MEM(J).NE.0) EXIT ENDDO IF(POS_IN_MEM(J).LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (12) in OOC ', & ' DMUMPS_GET_TOP_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF(J.GE.PDEB_SOLVE_Z(ZONE))THEN TMP_NODE=POS_IN_MEM(J) FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE FREE_HOLE=FREE_HOLE_POS-IDEB_SOLVE_Z(ZONE) ENDIF ELSEIF(TMP_NODE.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (13) in OOC', & ' DMUMPS_GET_TOP_AREA_SPACE' CALL MUMPS_ABORT() ELSE FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ENDIF ELSE FREE_HOLE=FREE_HOLE_POS-IDEB_SOLVE_Z(ZONE) ENDIF FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF CURRENT_POS_T(ZONE)=POS_HOLE_T(ZONE) LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)+FREE_SIZE POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)-FREE_SIZE 50 CONTINUE IF(REQUESTED_SIZE.LE.LRLU_SOLVE_T(ZONE))THEN FLAG=1 ELSE FLAG=0 ENDIF RETURN END SUBROUTINE DMUMPS_GET_TOP_AREA_SPACE SUBROUTINE DMUMPS_GET_BOTTOM_AREA_SPACE(A,LA,REQUESTED_SIZE, & PTRFAC,NSTEPS,ZONE,FLAG,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE,FLAG INTEGER (8) :: REQUESTED_SIZE INTEGER (8) :: LA INTEGER (8) :: PTRFAC(NSTEPS) DOUBLE PRECISION A(LA) INTEGER(8) :: FREE_SIZE, FREE_HOLE_POS, FREE_HOLE INTEGER I,J,TMP_NODE,FREE_HOLE_FLAG INTEGER, intent(out) :: IERR IERR=0 FLAG=0 IF(LRLU_SOLVE_B(ZONE).EQ.SIZE_SOLVE_Z(ZONE))THEN GOTO 50 ENDIF IF(POS_HOLE_B(ZONE).EQ.-9999)THEN GOTO 50 ENDIF J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_T(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE = 0_8 DO I=POS_HOLE_B(ZONE)+1,J IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN EXIT ENDIF ENDDO POS_HOLE_B(ZONE)=I-1 IF((POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE)).OR. & (POS_HOLE_T(ZONE).LE.POS_HOLE_B(ZONE)).OR. & (POS_HOLE_T(ZONE).EQ.POS_HOLE_B(ZONE)+1))THEN CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_T(ZONE)=PDEB_SOLVE_Z(ZONE) ENDIF FREE_HOLE=0_8 FREE_SIZE=0_8 FREE_HOLE_FLAG=0 FREE_HOLE_POS=IDEB_SOLVE_Z(ZONE) IF(POS_HOLE_B(ZONE).EQ.-9999)THEN GOTO 50 ENDIF DO I=PDEB_SOLVE_Z(ZONE),POS_HOLE_B(ZONE) IF((POS_IN_MEM(I).LE.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) IF(TMP_NODE.NE.0)THEN IF(I.EQ.PDEB_SOLVE_Z(ZONE))THEN IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).NE. & IDEB_SOLVE_Z(ZONE))THEN FREE_SIZE=FREE_SIZE+abs(PTRFAC(STEP_OOC(TMP_NODE))) & -IDEB_SOLVE_Z(ZONE) ENDIF ENDIF IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(TMP_NODE))=-777777_8 INODE_TO_POS(STEP_OOC(TMP_NODE))=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSE FREE_HOLE_FLAG=1 ENDIF POS_IN_MEM(I)=0 ELSEIF(POS_IN_MEM(I).NE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (14) in OOC ', & ' DMUMPS_GET_BOTTOM_AREA_SPACE', & CURRENT_POS_T(ZONE)-1,POS_HOLE_B(ZONE),I,POS_IN_MEM(I) CALL MUMPS_ABORT() ENDIF ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN IF(POS_HOLE_B(ZONE)+1.LT.CURRENT_POS_T(ZONE)-1)THEN I=POS_HOLE_B(ZONE)+1 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.(N_OOC+1)*NB_Z)THEN TMP_NODE=TMP_NODE-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (15) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL DMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))-FREE_HOLE_POS ELSEIF(TMP_NODE.EQ.0)THEN DO J=I,CURRENT_POS_T(ZONE)-1 IF(POS_IN_MEM(J).NE.0) EXIT ENDDO IF(POS_IN_MEM(J).LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (16) in OOC ', & ' DMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF(J.LE.CURRENT_POS_T(ZONE)-1)THEN TMP_NODE=POS_IN_MEM(J) FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS ELSE FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS ENDIF ELSEIF(TMP_NODE.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (17) in OOC ', & ' DMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ELSE FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS ENDIF ELSE FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS ENDIF FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF LRLU_SOLVE_B(ZONE)=FREE_SIZE IF(POS_HOLE_B(ZONE).LT.CURRENT_POS_T(ZONE)-1)THEN TMP_NODE=POS_IN_MEM(POS_HOLE_B(ZONE)+1) IF(TMP_NODE.LT.-(N_OOC+1)*NB_Z)THEN TMP_NODE=abs(TMP_NODE)-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (18) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL DMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) ENDIF LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)+ & (abs(PTRFAC(STEP_OOC(abs(TMP_NODE))))-IDEB_SOLVE_Z(ZONE)- & LRLU_SOLVE_B(ZONE)) ENDIF CURRENT_POS_B(ZONE)=POS_HOLE_B(ZONE) 50 CONTINUE IF((POS_HOLE_B(ZONE).EQ.-9999).AND. & (LRLU_SOLVE_B(ZONE).NE.0_8))THEN WRITE(*,*)MYID_OOC,': Internal error (19) in OOC ', & 'DMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF((REQUESTED_SIZE.LE.LRLU_SOLVE_B(ZONE)).AND. & (POS_HOLE_B(ZONE).NE.-9999))THEN FLAG=1 ELSE FLAG=0 ENDIF END SUBROUTINE DMUMPS_GET_BOTTOM_AREA_SPACE SUBROUTINE DMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8, A,ZONE) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION A(FACT_AREA_SIZE) INTEGER ZONE LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(INODE))=POSFAC_SOLVE(ZONE) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED IF(POSFAC_SOLVE(ZONE).EQ.IDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (20) in OOC ', & ' Problem avec debut (2)',INODE, & PTRFAC(STEP_OOC(INODE)),IDEB_SOLVE_Z(ZONE),ZONE CALL MUMPS_ABORT() ENDIF INODE_TO_POS(STEP_OOC(INODE))=CURRENT_POS_T(ZONE) POS_IN_MEM(CURRENT_POS_T(ZONE))=INODE IF(CURRENT_POS_T(ZONE).GT.(PDEB_SOLVE_Z(ZONE)+ & MAX_NB_NODES_FOR_ZONE-1))THEN WRITE(*,*)MYID_OOC,': Internal error (21) in OOC ', & ' Problem with CURRENT_POS_T', & CURRENT_POS_T(ZONE),ZONE CALL MUMPS_ABORT() ENDIF CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)+1 POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) END SUBROUTINE DMUMPS_SOLVE_ALLOC_PTR_UPD_T SUBROUTINE DMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8, & A,ZONE) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION A(FACT_AREA_SIZE) INTEGER ZONE IF(POS_HOLE_B(ZONE).EQ.-9999)THEN WRITE(*,*)MYID_OOC,': Internal error (22) in OOC ', & ' DMUMPS_SOLVE_ALLOC_PTR_UPD_B' CALL MUMPS_ABORT() ENDIF LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(INODE))=IDEB_SOLVE_Z(ZONE)+ & LRLU_SOLVE_B(ZONE) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (23) in OOC ', & PTRFAC(STEP_OOC(INODE)),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF INODE_TO_POS(STEP_OOC(INODE))=CURRENT_POS_B(ZONE) IF(CURRENT_POS_B(ZONE).EQ.0)THEN WRITE(*,*)MYID_OOC,': Internal error (23b) in OOC ' CALL MUMPS_ABORT() ENDIF POS_IN_MEM(CURRENT_POS_B(ZONE))=INODE CURRENT_POS_B(ZONE)=CURRENT_POS_B(ZONE)-1 POS_HOLE_B(ZONE)=CURRENT_POS_B(ZONE) END SUBROUTINE DMUMPS_SOLVE_ALLOC_PTR_UPD_B SUBROUTINE DMUMPS_FREE_SPACE_FOR_SOLVE(A,LA,REQUESTED_SIZE,PTRFAC, & NSTEPS,ZONE,IERR) IMPLICIT NONE INTEGER(8) :: LA, REQUESTED_SIZE INTEGER NSTEPS,ZONE INTEGER, intent(out) :: IERR INTEGER(8) :: PTRFAC(NSTEPS) DOUBLE PRECISION A(LA) INTEGER (8) :: APOS_FIRST_FREE, & SIZE_HOLE, & FREE_HOLE, & FREE_HOLE_POS INTEGER J,I,TMP_NODE, NB_FREE, IPOS_FIRST_FREE INTEGER(8) :: K8, AREA_POINTER INTEGER FREE_HOLE_FLAG IERR=0 IF(LRLU_SOLVE_T(ZONE).EQ.SIZE_SOLVE_Z(ZONE))THEN RETURN ENDIF AREA_POINTER=IDEB_SOLVE_Z(ZONE) SIZE_HOLE=0_8 DO I=PDEB_SOLVE_Z(ZONE),CURRENT_POS_T(ZONE)-1 IF((POS_IN_MEM(I).LE.0).AND. & (POS_IN_MEM(I).GT.-((N_OOC+1)*NB_Z))) GOTO 666 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.((N_OOC+1)*NB_Z))THEN TMP_NODE=TMP_NODE-((N_OOC+1)*NB_Z) ENDIF AREA_POINTER=AREA_POINTER+ & abs(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ENDDO 666 CONTINUE IF((I.EQ.CURRENT_POS_T(ZONE)-1).AND. & (PDEB_SOLVE_Z(ZONE).NE.CURRENT_POS_T(ZONE)-1))THEN IF((POS_IN_MEM(I).GT.0).OR. & (POS_IN_MEM(I).LT.-((N_OOC+1)*NB_Z)))THEN WRITE(*,*)MYID_OOC,': Internal error (25) in OOC ', & ': There are no free blocks ', & 'in DMUMPS_FREE_SPACE_FOR_SOLVE',PDEB_SOLVE_Z(ZONE), & CURRENT_POS_T(ZONE) CALL MUMPS_ABORT() ENDIF ENDIF IF(POS_IN_MEM(I).EQ.0)THEN APOS_FIRST_FREE=AREA_POINTER FREE_HOLE_POS=AREA_POINTER ELSE TMP_NODE=abs(POS_IN_MEM(I)) APOS_FIRST_FREE=abs(PTRFAC(STEP_OOC(TMP_NODE))) ENDIF IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).NE.0)THEN IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=abs(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)))- & ((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL DMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) ELSE TMP_NODE=abs(POS_IN_MEM(PDEB_SOLVE_Z(ZONE))) ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).NE.IDEB_SOLVE_Z(ZONE))THEN IF((POS_IN_MEM(I).NE.0).OR.(I.EQ.CURRENT_POS_T(ZONE)))THEN SIZE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & IDEB_SOLVE_Z(ZONE) ENDIF APOS_FIRST_FREE=IDEB_SOLVE_Z(ZONE) IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).GT.0)THEN DO J=PDEB_SOLVE_Z(ZONE),I-1 TMP_NODE=POS_IN_MEM(J) IF(TMP_NODE.LE.0)THEN IF(TMP_NODE.LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=abs(POS_IN_MEM(J))-((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST( & IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL DMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=POS_IN_MEM(J) ELSE WRITE(*,*)MYID_OOC,': Internal error (26) in OOC ', & ' DMUMPS_FREE_SPACE_FOR_SOLVE',TMP_NODE, & J,I-1,(N_OOC+1)*NB_Z CALL MUMPS_ABORT() ENDIF ENDIF DO K8=1_8, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) A(APOS_FIRST_FREE+K8-1_8)= & A(PTRFAC(STEP_OOC(TMP_NODE))+K8-1_8) ENDDO PTRFAC(STEP_OOC(TMP_NODE))=APOS_FIRST_FREE APOS_FIRST_FREE=APOS_FIRST_FREE+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) ENDDO ENDIF ENDIF ENDIF NB_FREE=0 FREE_HOLE=0_8 FREE_HOLE_FLAG=0 DO J=I,CURRENT_POS_T(ZONE)-1 TMP_NODE=abs(POS_IN_MEM(J)) IF(POS_IN_MEM(J).LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=TMP_NODE-((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL DMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=abs(POS_IN_MEM(J)) ENDIF IF(POS_IN_MEM(J).GT.0)THEN DO K8=1_8,SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) A(APOS_FIRST_FREE+K8-1_8)= & A(PTRFAC(STEP_OOC(TMP_NODE))+K8-1_8) ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(TMP_NODE))=APOS_FIRST_FREE APOS_FIRST_FREE=APOS_FIRST_FREE+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(J).EQ.0)THEN FREE_HOLE_FLAG=1 NB_FREE=NB_FREE+1 ELSE NB_FREE=NB_FREE+1 IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) SIZE_HOLE=SIZE_HOLE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) PTRFAC(STEP_OOC(abs(POS_IN_MEM(J))))=-77777_8 ENDIF ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF IPOS_FIRST_FREE=I DO J=I,CURRENT_POS_T(ZONE)-1 IF(POS_IN_MEM(J).LT.0)THEN TMP_NODE=abs(POS_IN_MEM(J)) INODE_TO_POS(STEP_OOC(TMP_NODE))=0 POS_IN_MEM(J)=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED ELSEIF(POS_IN_MEM(J).GT.0)THEN TMP_NODE=abs(POS_IN_MEM(J)) POS_IN_MEM(IPOS_FIRST_FREE)=POS_IN_MEM(J) INODE_TO_POS(STEP_OOC(TMP_NODE))=IPOS_FIRST_FREE IPOS_FIRST_FREE=IPOS_FIRST_FREE+1 ENDIF ENDDO LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)+SIZE_HOLE POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)-SIZE_HOLE CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)-NB_FREE POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 IF(LRLU_SOLVE_T(ZONE).NE.LRLUS_SOLVE(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (27) in OOC ', & LRLU_SOLVE_T(ZONE), & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF LRLU_SOLVE_T(ZONE)=LRLUS_SOLVE(ZONE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (28) in OOC ', & ' LRLUS_SOLVE must be (4) > 0' CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (29) in OOC ', & POSFAC_SOLVE(ZONE),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).NE.(IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)- & LRLUS_SOLVE(ZONE)))THEN WRITE(*,*)MYID_OOC,': Internal error (30) in OOC ', & ' Problem avec debut POSFAC_SOLVE', & POSFAC_SOLVE(ZONE),(SIZE_SOLVE_Z(ZONE)- & LRLUS_SOLVE(ZONE))+IDEB_SOLVE_Z(ZONE),LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).GT. & (IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)-1_8))THEN WRITE(*,*)MYID_OOC,': Internal error (31) in OOC ', & POSFAC_SOLVE(ZONE),IDEB_SOLVE_Z(ZONE)+ & SIZE_SOLVE_Z(ZONE)-1_8 CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE DMUMPS_FREE_SPACE_FOR_SOLVE SUBROUTINE DMUMPS_OOC_UPDATE_SOLVE_STAT(INODE,PTRFAC,NSTEPS,FLAG) IMPLICIT NONE INTEGER INODE,NSTEPS,FLAG INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZONE IF((FLAG.LT.0).OR.(FLAG.GT.1))THEN WRITE(*,*)MYID_OOC,': Internal error (32) in OOC ', & ' DMUMPS_OOC_UPDATE_SOLVE_STAT' CALL MUMPS_ABORT() ENDIF CALL DMUMPS_SEARCH_SOLVE(PTRFAC(STEP_OOC(INODE)),ZONE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (33) in OOC ', & ' LRLUS_SOLVE must be (5) ++ > 0' CALL MUMPS_ABORT() ENDIF IF(FLAG.EQ.0)THEN LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ELSE LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ENDIF IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (34) in OOC ', & ' LRLUS_SOLVE must be (5) > 0' CALL MUMPS_ABORT() ENDIF END SUBROUTINE DMUMPS_OOC_UPDATE_SOLVE_STAT SUBROUTINE DMUMPS_SEARCH_SOLVE(ADDR,ZONE) IMPLICIT NONE INTEGER (8) :: ADDR INTEGER ZONE INTEGER I I=1 DO WHILE (I.LE.NB_Z) IF(ADDR.LT.IDEB_SOLVE_Z(I))THEN EXIT ENDIF I=I+1 ENDDO ZONE=I-1 END SUBROUTINE DMUMPS_SEARCH_SOLVE FUNCTION DMUMPS_SOLVE_IS_END_REACHED() IMPLICIT NONE LOGICAL DMUMPS_SOLVE_IS_END_REACHED DMUMPS_SOLVE_IS_END_REACHED=.FALSE. IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN DMUMPS_SOLVE_IS_END_REACHED=.TRUE. ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.LT.1)THEN DMUMPS_SOLVE_IS_END_REACHED=.TRUE. ENDIF ENDIF RETURN END FUNCTION DMUMPS_SOLVE_IS_END_REACHED SUBROUTINE DMUMPS_SOLVE_ZONE_READ(ZONE,A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE INTEGER(8), INTENT(IN) :: LA INTEGER, intent(out) :: IERR DOUBLE PRECISION A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: SIZE, DEST INTEGER(8) :: NEEDED_SIZE INTEGER FLAG,TMP_FLAG,POS_SEQ,TMP_NODE, & NB_NODES IERR=0 TMP_FLAG=0 FLAG=0 IF(DMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE).GT. & SIZE_SOLVE_Z(ZONE)) CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 IF(DMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL DMUMPS_OOC_SKIP_NULL_SIZE_NODE() NEEDED_SIZE=max(MIN_SIZE_READ, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE NEEDED_SIZE=MIN_SIZE_READ ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.GE.1)THEN TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE).GT. & SIZE_SOLVE_Z(ZONE)) CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 IF(DMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL DMUMPS_OOC_SKIP_NULL_SIZE_NODE() NEEDED_SIZE=max(MIN_SIZE_READ, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE NEEDED_SIZE=MIN_SIZE_READ ENDIF ENDIF IF(LRLUS_SOLVE(ZONE).LT.NEEDED_SIZE)THEN RETURN ELSEIF((LRLU_SOLVE_T(ZONE).LT.NEEDED_SIZE).AND. & (LRLU_SOLVE_B(ZONE).LT.NEEDED_SIZE).AND. & (dble(LRLUS_SOLVE(ZONE)).LT.0.3d0* & dble(SIZE_SOLVE_Z(ZONE)))) THEN RETURN ENDIF IF((LRLU_SOLVE_T(ZONE).GT.NEEDED_SIZE).AND.(SOLVE_STEP.EQ.0).AND. & ((CURRENT_POS_T(ZONE)-PDEB_SOLVE_Z(ZONE)+1).LT. & MAX_NB_NODES_FOR_ZONE))THEN FLAG=1 ELSE IF(SOLVE_STEP.EQ.0)THEN CALL DMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 IF(TMP_FLAG.EQ.0)THEN CALL DMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=0 ENDIF ELSE CALL DMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=0 IF(TMP_FLAG.EQ.0)THEN CALL DMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF IF(TMP_FLAG.EQ.0)THEN CALL DMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF CALL DMUMPS_SOLVE_COMPUTE_READ_SIZE(ZONE,SIZE,DEST,POS_SEQ, & NB_NODES,FLAG,PTRFAC,NSTEPS) IF(SIZE.EQ.0_8)THEN RETURN ENDIF NB_ZONE_REQ=NB_ZONE_REQ+1 SIZE_ZONE_REQ=SIZE_ZONE_REQ+SIZE REQ_ACT=REQ_ACT+1 CALL DMUMPS_READ_SOLVE_BLOCK(A(DEST),DEST,SIZE,ZONE,PTRFAC,NSTEPS, & POS_SEQ,NB_NODES,FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END SUBROUTINE DMUMPS_SOLVE_ZONE_READ SUBROUTINE DMUMPS_SOLVE_COMPUTE_READ_SIZE(ZONE,SIZE,DEST,POS_SEQ, & NB_NODES,FLAG,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER(8) :: SIZE, DEST INTEGER ZONE,FLAG,POS_SEQ,NSTEPS INTEGER(8) :: PTRFAC(NSTEPS), MAX_SIZE, LAST, J8 INTEGER I,START_NODE,K,MAX_NB, & NB_NODES INTEGER NB_NODES_LOC LOGICAL ALREADY IF(DMUMPS_SOLVE_IS_END_REACHED())THEN SIZE=0_8 RETURN ENDIF IF(FLAG.EQ.0)THEN MAX_SIZE=LRLU_SOLVE_B(ZONE) MAX_NB=max(0,CURRENT_POS_B(ZONE)-PDEB_SOLVE_Z(ZONE)+1) ELSEIF(FLAG.EQ.1)THEN MAX_SIZE=LRLU_SOLVE_T(ZONE) MAX_NB=MAX_NB_NODES_FOR_ZONE ELSE WRITE(*,*)MYID_OOC,': Internal error (35) in OOC ', & ' Unknown Flag value in ', & ' DMUMPS_SOLVE_COMPUTE_READ_SIZE',FLAG CALL MUMPS_ABORT() ENDIF CALL DMUMPS_OOC_SKIP_NULL_SIZE_NODE() I=CUR_POS_SEQUENCE START_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ALREADY=.FALSE. NB_NODES=0 NB_NODES_LOC=0 IF(ZONE.EQ.NB_Z)THEN SIZE=SIZE_OF_BLOCK(STEP_OOC(START_NODE),OOC_FCT_TYPE) ELSE J8=0_8 IF(FLAG.EQ.0)THEN K=0 ELSEIF(FLAG.EQ.1)THEN K=CURRENT_POS_T(ZONE)-PDEB_SOLVE_Z(ZONE)+1 ENDIF IF(SOLVE_STEP.EQ.0)THEN I=CUR_POS_SEQUENCE DO WHILE(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) IF(SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF I=I+1 ENDDO CUR_POS_SEQUENCE=min(I,TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) I=CUR_POS_SEQUENCE DO WHILE((J8.LE.MAX_SIZE).AND. & (I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)).AND. & (K.LT.MAX_NB) ) LAST=SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ENDIF I=I+1 NB_NODES_LOC=NB_NODES_LOC+1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))) & .NE.0).OR. & (IO_REQ(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))).GE. & 0))THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 I=I+1 CYCLE ELSE EXIT ENDIF ENDIF ALREADY=.TRUE. J8=J8+LAST I=I+1 K=K+1 NB_NODES_LOC=NB_NODES_LOC+1 NB_NODES=NB_NODES+1 ENDDO IF(J8.GT.MAX_SIZE)THEN SIZE=J8-LAST NB_NODES=NB_NODES-1 NB_NODES_LOC=NB_NODES_LOC-1 ELSE SIZE=J8 ENDIF DO WHILE (CUR_POS_SEQUENCE+NB_NODES_LOC-1.GE. & CUR_POS_SEQUENCE) IF(SIZE_OF_BLOCK(STEP_OOC( & OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE+NB_NODES-1, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF NB_NODES_LOC=NB_NODES_LOC-1 ENDDO POS_SEQ=CUR_POS_SEQUENCE ELSEIF(SOLVE_STEP.EQ.1)THEN DO WHILE(I.GE.1) IF(SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF I=I-1 ENDDO CUR_POS_SEQUENCE=max(I,1) I=CUR_POS_SEQUENCE DO WHILE((J8.LE.MAX_SIZE).AND.(I.GE.1).AND. & (K.LT.MAX_NB)) LAST=SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF NB_NODES_LOC=NB_NODES_LOC+1 I=I-1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))) & .NE.0).OR. & (IO_REQ(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))).GE. & 0))THEN IF(.NOT.ALREADY)THEN I=I-1 CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 CYCLE ELSE EXIT ENDIF ENDIF ALREADY=.TRUE. J8=J8+LAST I=I-1 K=K+1 NB_NODES=NB_NODES+1 NB_NODES_LOC=NB_NODES_LOC+1 ENDDO IF(J8.GT.MAX_SIZE)THEN SIZE=J8-LAST NB_NODES=NB_NODES-1 NB_NODES_LOC=NB_NODES_LOC-1 ELSE SIZE=J8 ENDIF I=CUR_POS_SEQUENCE-NB_NODES_LOC+1 DO WHILE (I.LE.CUR_POS_SEQUENCE) IF(SIZE_OF_BLOCK(STEP_OOC( & OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE)), & OOC_FCT_TYPE).NE.0_8)THEN EXIT ENDIF I=I+1 NB_NODES_LOC=NB_NODES_LOC-1 ENDDO POS_SEQ=CUR_POS_SEQUENCE-NB_NODES_LOC+1 ENDIF ENDIF IF(FLAG.EQ.0)THEN DEST=IDEB_SOLVE_Z(ZONE)+LRLU_SOLVE_B(ZONE)-SIZE ELSE DEST=POSFAC_SOLVE(ZONE) ENDIF END SUBROUTINE DMUMPS_SOLVE_COMPUTE_READ_SIZE SUBROUTINE DMUMPS_OOC_END_SOLVE(IERR) IMPLICIT NONE INTEGER SOLVE_OR_FACTO INTEGER, intent(out) :: IERR IERR=0 IF(allocated(LRLUS_SOLVE))THEN DEALLOCATE(LRLUS_SOLVE) ENDIF IF(allocated(LRLU_SOLVE_T))THEN DEALLOCATE(LRLU_SOLVE_T) ENDIF IF(allocated(LRLU_SOLVE_B))THEN DEALLOCATE(LRLU_SOLVE_B) ENDIF IF(allocated(POSFAC_SOLVE))THEN DEALLOCATE(POSFAC_SOLVE) ENDIF IF(allocated(IDEB_SOLVE_Z))THEN DEALLOCATE(IDEB_SOLVE_Z) ENDIF IF(allocated(PDEB_SOLVE_Z))THEN DEALLOCATE(PDEB_SOLVE_Z) ENDIF IF(allocated(SIZE_SOLVE_Z))THEN DEALLOCATE(SIZE_SOLVE_Z) ENDIF IF(allocated(CURRENT_POS_T))THEN DEALLOCATE(CURRENT_POS_T) ENDIF IF(allocated(CURRENT_POS_B))THEN DEALLOCATE(CURRENT_POS_B) ENDIF IF(allocated(POS_HOLE_T))THEN DEALLOCATE(POS_HOLE_T) ENDIF IF(allocated(POS_HOLE_B))THEN DEALLOCATE(POS_HOLE_B) ENDIF IF(allocated(OOC_STATE_NODE))THEN DEALLOCATE(OOC_STATE_NODE) ENDIF IF(allocated(POS_IN_MEM))THEN DEALLOCATE(POS_IN_MEM) ENDIF IF(allocated(INODE_TO_POS))THEN DEALLOCATE(INODE_TO_POS) ENDIF IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(allocated(SIZE_OF_READ))THEN DEALLOCATE(SIZE_OF_READ) ENDIF IF(allocated(FIRST_POS_IN_READ))THEN DEALLOCATE(FIRST_POS_IN_READ) ENDIF IF(allocated(READ_DEST))THEN DEALLOCATE(READ_DEST) ENDIF IF(allocated(READ_MNG))THEN DEALLOCATE(READ_MNG) ENDIF IF(allocated(REQ_TO_ZONE))THEN DEALLOCATE(REQ_TO_ZONE) ENDIF IF(allocated(REQ_ID))THEN DEALLOCATE(REQ_ID) ENDIF SOLVE_OR_FACTO=1 CALL MUMPS_CLEAN_IO_DATA_C(MYID_OOC,SOLVE_OR_FACTO,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF END SUBROUTINE DMUMPS_OOC_END_SOLVE SUBROUTINE DMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS, & A,LA) IMPLICIT NONE INTEGER, INTENT(in) :: NSTEPS INTEGER(8), INTENT(INOUT) :: PTRFAC(NSTEPS) INTEGER(8), INTENT(IN) :: LA DOUBLE PRECISION :: A(LA) INTEGER :: I, TMP, ZONE, IPAS, IBEG, IEND INTEGER(8) :: SAVE_PTR LOGICAL :: COMPRESS_TO_BE_DONE, SET_POS_SEQUENCE INTEGER :: J, IERR INTEGER(8) :: DUMMY_SIZE COMPRESS_TO_BE_DONE = .FALSE. DUMMY_SIZE = 1_8 IERR = 0 SET_POS_SEQUENCE = .TRUE. IF(SOLVE_STEP.EQ.0)THEN IBEG = 1 IEND = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) IPAS = 1 ELSE IBEG = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) IEND = 1 IPAS = -1 ENDIF DO I=IBEG,IEND,IPAS J = OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) TMP=INODE_TO_POS(STEP_OOC(J)) IF(TMP.EQ.0)THEN IF (SET_POS_SEQUENCE) THEN SET_POS_SEQUENCE = .FALSE. CUR_POS_SEQUENCE = I ENDIF IF (KEEP_OOC(237).EQ.0 .AND. KEEP_OOC(235).EQ.0 & .AND. KEEP_OOC(212).EQ.0 ) THEN OOC_STATE_NODE(STEP_OOC(J)) = NOT_IN_MEM ENDIF CYCLE ELSE IF(TMP.LT.0)THEN IF(TMP.GT.-(N_OOC+1)*NB_Z)THEN SAVE_PTR=PTRFAC(STEP_OOC(J)) PTRFAC(STEP_OOC(J)) = abs(SAVE_PTR) CALL DMUMPS_SOLVE_FIND_ZONE(J, & ZONE,PTRFAC,NSTEPS) PTRFAC(STEP_OOC(J)) = SAVE_PTR IF(ZONE.EQ.NB_Z)THEN IF(J.NE.SPECIAL_ROOT_NODE)THEN WRITE(*,*)MYID_OOC,': Internal error 6 ', & ' Node ', J, & ' is in status USED in the & emmergency buffer ' CALL MUMPS_ABORT() ENDIF ENDIF IF (KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0 & .OR. KEEP_OOC(212).NE.0 ) & THEN IF (OOC_STATE_NODE(STEP_OOC(J)).EQ.NOT_IN_MEM) THEN OOC_STATE_NODE(STEP_OOC(J)) = USED IF((SOLVE_STEP.NE.0).AND.(J.NE.SPECIAL_ROOT_NODE) & .AND.(ZONE.NE.NB_Z))THEN CALL DMUMPS_SOLVE_UPD_NODE_INFO(J,PTRFAC,NSTEPS) ENDIF CYCLE ELSEIF(OOC_STATE_NODE(STEP_OOC(J)).EQ.USED) & THEN COMPRESS_TO_BE_DONE = .TRUE. ELSE WRITE(*,*)MYID_OOC,': Internal error Mila 4 ', & ' wrong node status :', OOC_STATE_NODE(STEP_OOC(J)), & ' on node ', J CALL MUMPS_ABORT() ENDIF ENDIF IF (KEEP_OOC(237).EQ.0 .AND. KEEP_OOC(235).EQ.0 & .AND. KEEP_OOC(212).EQ.0 ) THEN CALL DMUMPS_SOLVE_UPD_NODE_INFO(J,PTRFAC,NSTEPS) ENDIF ENDIF ENDIF ENDDO IF (KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0 .OR. & KEEP_OOC(212).NE.0 ) & THEN IF (COMPRESS_TO_BE_DONE) THEN DO ZONE=1,NB_Z-1 CALL DMUMPS_FREE_SPACE_FOR_SOLVE(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,ZONE,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error Mila 5 ', & ' IERR on return to DMUMPS_FREE_SPACE_FOR_SOLVE =', & IERR CALL MUMPS_ABORT() ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SOLVE_PREPARE_PREF SUBROUTINE DMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,NSTEPS,MTYPE, & A,LA,DOPREFETCH,IERR) IMPLICIT NONE INTEGER NSTEPS,MTYPE INTEGER, intent(out)::IERR INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER(8) :: PTRFAC(NSTEPS) LOGICAL DOPREFETCH INTEGER MUMPS_OOC_GET_FCT_TYPE EXTERNAL MUMPS_OOC_GET_FCT_TYPE IERR = 0 OOC_FCT_TYPE=MUMPS_OOC_GET_FCT_TYPE("F",MTYPE,KEEP_OOC(201), & KEEP_OOC(50)) OOC_SOLVE_TYPE_FCT = OOC_FCT_TYPE - 1 IF (KEEP_OOC(201).NE.1) THEN OOC_SOLVE_TYPE_FCT = FCT ENDIF SOLVE_STEP=0 CUR_POS_SEQUENCE=1 MTYPE_OOC=MTYPE IF ( KEEP_OOC(201).NE.1 & .OR. KEEP_OOC(50).NE.0 & ) THEN CALL DMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS,A,LA) ELSE CALL DMUMPS_SOLVE_STAT_REINIT_PANEL(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) ENDIF IF (DOPREFETCH) THEN CALL DMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC, & KEEP_OOC(28),IERR) ELSE CUR_POS_SEQUENCE = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) ENDIF RETURN END SUBROUTINE DMUMPS_SOLVE_INIT_OOC_FWD SUBROUTINE DMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,NSTEPS,MTYPE, & I_WORKED_ON_ROOT,IROOT,A,LA,IERR) IMPLICIT NONE INTEGER NSTEPS INTEGER(8) :: LA INTEGER(8) :: PTRFAC(NSTEPS) INTEGER MTYPE INTEGER IROOT LOGICAL I_WORKED_ON_ROOT INTEGER, intent(out):: IERR DOUBLE PRECISION A(LA) INTEGER(8) :: DUMMY_SIZE INTEGER ZONE INTEGER MUMPS_OOC_GET_FCT_TYPE EXTERNAL MUMPS_OOC_GET_FCT_TYPE IERR=0 OOC_FCT_TYPE=MUMPS_OOC_GET_FCT_TYPE("B",MTYPE,KEEP_OOC(201), & KEEP_OOC(50)) OOC_SOLVE_TYPE_FCT = OOC_FCT_TYPE - 1 IF (KEEP_OOC(201).NE.1) OOC_SOLVE_TYPE_FCT=FCT SOLVE_STEP=1 CUR_POS_SEQUENCE=TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) MTYPE_OOC=MTYPE IF ( KEEP_OOC(201).NE.1 & .OR. KEEP_OOC(50).NE.0 & ) THEN CALL DMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS,A,LA) IF (I_WORKED_ON_ROOT.AND. $ ((IROOT.GT.0)))THEN IF(SIZE_OF_BLOCK(STEP_OOC(IROOT),OOC_FCT_TYPE).NE.0) THEN IF (.NOT.(KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0)) & THEN CALL DMUMPS_FREE_FACTORS_FOR_SOLVE ( IROOT, & PTRFAC, KEEP_OOC(28), A, LA,.FALSE.,IERR) IF (IERR .LT. 0) RETURN ENDIF CALL DMUMPS_SOLVE_FIND_ZONE(IROOT, & ZONE,PTRFAC,NSTEPS) IF(ZONE.EQ.NB_Z)THEN DUMMY_SIZE=1_8 CALL DMUMPS_FREE_SPACE_FOR_SOLVE(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,NB_Z,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error in & DMUMPS_FREE_SPACE_FOR_SOLVE', & IERR CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ENDIF IF (NB_Z.GT.1) THEN CALL DMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC, & KEEP_OOC(28),IERR) IF (IERR .LT. 0) RETURN ENDIF ELSE CALL DMUMPS_SOLVE_STAT_REINIT_PANEL(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) CALL DMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC,KEEP_OOC(28),IERR) IF (IERR .LT. 0 ) RETURN ENDIF RETURN END SUBROUTINE DMUMPS_SOLVE_INIT_OOC_BWD SUBROUTINE DMUMPS_STRUC_STORE_FILE_NAME(idOOC_NB_FILES, & idOOC_FILE_NAMES, idOOC_FILE_NAME_LENGTH, idINFO, IERR) IMPLICIT NONE INTEGER,DIMENSION(:), POINTER :: idOOC_NB_FILES CHARACTER,DIMENSION(:,:), POINTER :: idOOC_FILE_NAMES INTEGER,DIMENSION(:), POINTER :: idOOC_FILE_NAME_LENGTH INTEGER :: idINFO(2) INTEGER, intent(out) :: IERR INTEGER I,DIM,J,TMP,SIZE,K,I1 CHARACTER(len=1):: TMP_NAME(FILENAMELENGTH) 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) idOOC_NB_FILES(J)=I SIZE=SIZE+I ENDDO IF(associated(idOOC_FILE_NAMES))THEN DEALLOCATE(idOOC_FILE_NAMES) NULLIFY(idOOC_FILE_NAMES) ENDIF ALLOCATE(idOOC_FILE_NAMES(SIZE,FILENAMELENGTH),stat=IERR) IF (IERR .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'DMUMPS_STRUC_STORE_FILE_NAME' ENDIF IERR=-1 IF(idINFO(1).GE.0)THEN idINFO(1) = -13 idINFO(2) = SIZE*FILENAMELENGTH RETURN ENDIF ENDIF IF(associated(idOOC_FILE_NAME_LENGTH))THEN DEALLOCATE(idOOC_FILE_NAME_LENGTH) NULLIFY(idOOC_FILE_NAME_LENGTH) ENDIF ALLOCATE(idOOC_FILE_NAME_LENGTH(SIZE),stat=IERR) IF (IERR .GT. 0) THEN IERR=-1 IF(idINFO(1).GE.0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) & 'PB allocation in DMUMPS_STRUC_STORE_FILE_NAME' ENDIF idINFO(1) = -13 idINFO(2) = SIZE RETURN ENDIF ENDIF K=1 DO I1=1,OOC_NB_FILE_TYPE TMP=I1-1 DO I=1,idOOC_NB_FILES(I1) CALL MUMPS_OOC_GET_FILE_NAME_C(TMP,I,DIM,TMP_NAME(1)) DO J=1,DIM+1 idOOC_FILE_NAMES(K,J)=TMP_NAME(J) ENDDO idOOC_FILE_NAME_LENGTH(K)=DIM+1 K=K+1 ENDDO ENDDO RETURN END SUBROUTINE DMUMPS_STRUC_STORE_FILE_NAME SUBROUTINE DMUMPS_OOC_OPEN_FILES_FOR_SOLVE(idINFO, idOOC_NB_FILES, & idMYID, idKEEP, idOOC_FILE_NAME_LENGTH, & idOOC_FILE_NAMES) IMPLICIT NONE INTEGER :: idINFO(2), idMYID INTEGER, DIMENSION(:), POINTER :: idOOC_NB_FILES INTEGER, DIMENSION(:), POINTER :: idOOC_FILE_NAME_LENGTH CHARACTER,DIMENSION(:,:), POINTER :: idOOC_FILE_NAMES INTEGER :: idKEEP(500) CHARACTER(len=1):: TMP_NAME(FILENAMELENGTH) INTEGER I,I1,TMP,J,K,L,DIM,IERR INTEGER, DIMENSION(:),ALLOCATABLE :: NB_FILES ALLOCATE(NB_FILES(OOC_NB_FILE_TYPE),stat=IERR) IF (IERR .GT. 0) THEN IERR=-1 IF(idINFO(1).GE.0)THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) & 'PB allocation in DMUMPS_OOC_OPEN_FILES_FOR_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF ENDIF IERR=0 NB_FILES=idOOC_NB_FILES I=idMYID K=idKEEP(35) L=mod(idKEEP(204),3) 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) idINFO(1)=IERR RETURN ENDIF CALL MUMPS_OOC_INIT_VARS_C(I,K,L,idKEEP(211),idKEEP(255),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) idINFO(1)=IERR RETURN ENDIF K=1 DO I1=1,OOC_NB_FILE_TYPE DO I=1,NB_FILES(I1) DIM=idOOC_FILE_NAME_LENGTH(K) DO J=1,DIM TMP_NAME(J)=idOOC_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) idINFO(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) idINFO(1)=IERR RETURN ENDIF DEALLOCATE(NB_FILES) RETURN END SUBROUTINE DMUMPS_OOC_OPEN_FILES_FOR_SOLVE SUBROUTINE DMUMPS_FORCE_WRITE_BUF(IERR) USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF CALL DMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF (IERR < 0) THEN RETURN ENDIF RETURN END SUBROUTINE DMUMPS_FORCE_WRITE_BUF SUBROUTINE DMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR INTEGER I IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF DO I=1,OOC_NB_FILE_TYPE CALL DMUMPS_OOC_DO_IO_AND_CHBUF(I,IERR) IF (IERR < 0) RETURN ENDDO RETURN END SUBROUTINE DMUMPS_OOC_FORCE_WRT_BUF_PANEL SUBROUTINE DMUMPS_SOLVE_STAT_REINIT_PANEL(NSTEPS, & KEEP38, KEEP20) IMPLICIT NONE INTEGER NSTEPS INTEGER I, J INTEGER(8) :: TMP_SIZE8 INTEGER KEEP38, KEEP20 INODE_TO_POS = 0 POS_IN_MEM = 0 OOC_STATE_NODE(1:NSTEPS)=0 TMP_SIZE8=1_8 J=1 DO I=1,NB_Z-1 IDEB_SOLVE_Z(I)=TMP_SIZE8 PDEB_SOLVE_Z(I)=J POSFAC_SOLVE(I)=TMP_SIZE8 LRLUS_SOLVE(I) =SIZE_ZONE_SOLVE LRLU_SOLVE_T(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_B(I)=0_8 SIZE_SOLVE_Z(I)=SIZE_ZONE_SOLVE CURRENT_POS_T(I)=J CURRENT_POS_B(I)=J POS_HOLE_T(I) =J POS_HOLE_B(I) =J J = J + MAX_NB_NODES_FOR_ZONE TMP_SIZE8 = TMP_SIZE8 + SIZE_ZONE_SOLVE ENDDO IDEB_SOLVE_Z(NB_Z)=TMP_SIZE8 PDEB_SOLVE_Z(NB_Z)=J POSFAC_SOLVE(NB_Z)=TMP_SIZE8 LRLUS_SOLVE(NB_Z) =SIZE_SOLVE_EMM LRLU_SOLVE_T(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_B(NB_Z)=0_8 SIZE_SOLVE_Z(NB_Z)=SIZE_SOLVE_EMM CURRENT_POS_T(NB_Z)=J CURRENT_POS_B(NB_Z)=J POS_HOLE_T(NB_Z) =J POS_HOLE_B(NB_Z) =J IO_REQ=-77777 SIZE_OF_READ=-9999_8 FIRST_POS_IN_READ=-9999 READ_DEST=-9999_8 READ_MNG=-9999 REQ_TO_ZONE=-9999 REQ_ID=-9999 RETURN END SUBROUTINE DMUMPS_SOLVE_STAT_REINIT_PANEL SUBROUTINE DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) IMPLICIT NONE TYPE(IO_BLOCK), INTENT(INOUT):: MonBloc INTEGER(8) :: LAFAC INTEGER, INTENT(IN) :: STRAT, LIWFAC, & MYID, TYPEFile INTEGER, INTENT(INOUT) :: IW(0:LIWFAC-1) DOUBLE PRECISION, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LNextPiv2beWritten, & UNextPiv2beWritten INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL INTEGER(8) :: TMPSIZE_OF_BLOCK INTEGER :: TempFTYPE LOGICAL WRITE_L, WRITE_U LOGICAL DO_U_FIRST INCLUDE 'mumps_headers.h' IERR = 0 IF (KEEP_OOC(50).EQ.0 & .AND.KEEP_OOC(251).EQ.2) THEN WRITE_L = .FALSE. ELSE WRITE_L = (TYPEFile.EQ.TYPEF_BOTH_LU .OR. TYPEFile.EQ.TYPEF_L) ENDIF WRITE_U = (TYPEFile.EQ.TYPEF_BOTH_LU .OR. TYPEFile.EQ.TYPEF_U) #if defined(_OPENMP) IF (KEEP_OOC(400).GT.0 .AND. KEEP_OOC(405) .GT. 0) THEN IF ( STRAT .EQ. STRAT_WRITE_MAX .OR. LAST_CALL ) THEN CALL OMP_SET_LOCK(LOCK_FOR_L0OMP) #if defined(_WIN32) ELSE #else ELSE IF ( .NOT. OMP_TEST_LOCK(LOCK_FOR_L0OMP )) THEN #endif RETURN ENDIF ENDIF #endif DO_U_FIRST = .FALSE. IF ( TYPEFile.EQ.TYPEF_BOTH_LU ) THEN IF ( LNextPiv2beWritten .GT. UNextPiv2beWritten ) THEN DO_U_FIRST = .TRUE. END IF END IF IF (DO_U_FIRST) GOTO 200 100 IF (WRITE_L .AND. TYPEF_L > 0 ) THEN TempFTYPE = TYPEF_L IF ((MonBloc%Typenode.EQ.2).AND.(.NOT.MonBloc%MASTER)) & THEN TMPSIZE_OF_BLOCK = SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE), & TempFTYPE) IF (TMPSIZE_OF_BLOCK .LT. 0_8) THEN TMPSIZE_OF_BLOCK = -TMPSIZE_OF_BLOCK - 1_8 ENDIF LNextPiv2beWritten = & int( & TMPSIZE_OF_BLOCK & / int(MonBloc%NROW,8) & ) & + 1 ENDIF CALL DMUMPS_OOC_STORE_LorU( STRAT, & TempFTYPE, AFAC, LAFAC, MonBloc, & IERR, & LNextPiv2beWritten, & OOC_VADDR(STEP_OOC(MonBloc%INODE),TempFTYPE), & SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE),TempFTYPE), & FILESIZE, LAST_CALL ) IF (IERR .LT. 0) GOTO 300 IF (DO_U_FIRST) GOTO 300 ENDIF 200 IF (WRITE_U) THEN TempFTYPE = TYPEF_U CALL DMUMPS_OOC_STORE_LorU( STRAT, & TempFTYPE, AFAC, LAFAC, MonBloc, & IERR, & UNextPiv2beWritten, & OOC_VADDR(STEP_OOC(MonBloc%INODE),TempFTYPE), & SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE),TempFTYPE), & FILESIZE, LAST_CALL) IF (IERR .LT. 0) GOTO 300 IF (DO_U_FIRST) GOTO 100 ENDIF 300 CONTINUE #if defined(_OPENMP) IF (KEEP_OOC(400).GT.0 .AND. KEEP_OOC(405) .GT. 0) THEN CALL OMP_UNSET_LOCK(LOCK_FOR_L0OMP) ENDIF #endif RETURN END SUBROUTINE DMUMPS_OOC_IO_LU_PANEL SUBROUTINE DMUMPS_OOC_STORE_LorU( STRAT, TYPEF, & AFAC, LAFAC, MonBloc, & IERR, & LorU_NextPiv2beWritten, & LorU_AddVirtNodeI8, LorUSIZE_OF_BLOCK, & FILESIZE, LAST_CALL & ) USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, INTENT(IN) :: STRAT INTEGER, INTENT(IN) :: TYPEF INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER(8), INTENT(IN) :: LAFAC DOUBLE PRECISION, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LorU_NextPiv2beWritten INTEGER(8), INTENT(INOUT) :: LorU_AddVirtNodeI8 INTEGER(8), INTENT(INOUT) :: LorUSIZE_OF_BLOCK TYPE(IO_BLOCK), INTENT(INOUT) :: MonBloc INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL INTEGER NNMAX INTEGER(8) :: TOTSIZE, EFFSIZE INTEGER(8) :: TailleEcrite INTEGER SIZE_PANEL INTEGER(8) :: AddVirtCour LOGICAL VIRT_ADD_RESERVED_BEF_CALL LOGICAL VIRTUAL_ADDRESS_JUST_RESERVED LOGICAL HOLE_PROCESSED_BEFORE_CALL LOGICAL TMP_ESTIM INTEGER ICUR, INODE_CUR INTEGER(8) :: ADDR_LAST IERR = 0 IF (TYPEF == TYPEF_L ) THEN NNMAX = MonBloc%NROW ELSE NNMAX = MonBloc%NCOL ENDIF SIZE_PANEL = DMUMPS_OOC_PANEL_SIZE(NNMAX) IF ( (.NOT.MonBloc%Last) .AND. & (MonBloc%LastPiv-LorU_NextPiv2beWritten+1.LT.SIZE_PANEL)) & THEN RETURN ENDIF TMP_ESTIM = .TRUE. TOTSIZE = DMUMPS_OOC_NBENTRIES_PANEL_123 & (MonBloc%NFS, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) IF (MonBloc%Last) THEN TMP_ESTIM=.FALSE. EFFSIZE = DMUMPS_OOC_NBENTRIES_PANEL_123 & (MonBloc%LastPiv, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) ELSE EFFSIZE = -1034039740327_8 ENDIF IF (MonBloc%Typenode.EQ.3.AND. MonBloc%NFS.NE.MonBloc%NCOL) THEN WRITE(*,*) 'Internal error in DMUMPS_OOC_STORE_LorU for type3', & MonBloc%NFS,MonBloc%NCOL CALL MUMPS_ABORT() ENDIF IF (MonBloc%Typenode.EQ.3.AND. TYPEF.NE.TYPEF_L) THEN WRITE(*,*) 'Internal error in DMUMPS_OOC_STORE_LorU,TYPEF=', & TYPEF, 'for typenode=3' CALL MUMPS_ABORT() ENDIF IF (MonBloc%Typenode.EQ.2.AND. & TYPEF.EQ.TYPEF_U.AND. & .NOT. MonBloc%MASTER ) THEN WRITE(*,*) 'Internal error in DMUMPS_OOC_STORE_LorU', & MonBloc%MASTER,MonBloc%Typenode, TYPEF CALL MUMPS_ABORT() ENDIF HOLE_PROCESSED_BEFORE_CALL = (LorUSIZE_OF_BLOCK .LT. 0_8) IF (HOLE_PROCESSED_BEFORE_CALL.AND.(.NOT.MonBloc%Last)) THEN WRITE(6,*) ' Internal error in DMUMPS_OOC_STORE_LorU ', & ' last is false after earlier calls with last=true' CALL MUMPS_ABORT() ENDIF IF (HOLE_PROCESSED_BEFORE_CALL) THEN LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 TOTSIZE = -99999999_8 ENDIF VIRTUAL_ADDRESS_JUST_RESERVED = .FALSE. VIRT_ADD_RESERVED_BEF_CALL = & ( LorUSIZE_OF_BLOCK .NE. 0_8 .OR. & HOLE_PROCESSED_BEFORE_CALL ) IF (MonBloc%Last .AND. .NOT. HOLE_PROCESSED_BEFORE_CALL) THEN KEEP_OOC(228) = max(KEEP_OOC(228), & (MonBloc%LastPiv+SIZE_PANEL-1) / SIZE_PANEL) IF (VIRT_ADD_RESERVED_BEF_CALL) THEN IF (AddVirtLibre(TYPEF).EQ. & (LorU_AddVirtNodeI8+TOTSIZE) ) THEN AddVirtLibre(TYPEF) = LorU_AddVirtNodeI8 + EFFSIZE ENDIF ELSE VIRTUAL_ADDRESS_JUST_RESERVED = .TRUE. IF (EFFSIZE .EQ. 0_8) THEN LorU_AddVirtNodeI8 = -9999_8 ELSE LorU_AddVirtNodeI8 = AddVirtLibre(TYPEF) ENDIF AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) + EFFSIZE ENDIF ELSE IF (.NOT. VIRT_ADD_RESERVED_BEF_CALL & ) THEN LorU_AddVirtNodeI8 = AddVirtLibre(TYPEF) AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) + TOTSIZE ENDIF ENDIF AddVirtCour = LorU_AddVirtNodeI8 + LorUSIZE_OF_BLOCK CALL DMUMPS_OOC_WRT_IN_PANELS_LorU( STRAT, TYPEF, MonBloc, & SIZE_PANEL, & AFAC, LAFAC, & LorU_NextPiv2beWritten, AddVirtCour, & TailleEcrite, & IERR ) IF ( IERR .LT. 0 ) RETURN LorUSIZE_OF_BLOCK = LorUSIZE_OF_BLOCK + TailleEcrite IF (LorUSIZE_OF_BLOCK.EQ.0_8 ) THEN IF ( .NOT. VIRT_ADD_RESERVED_BEF_CALL & .AND. .NOT. VIRTUAL_ADDRESS_JUST_RESERVED ) & THEN AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) - TOTSIZE LorU_AddVirtNodeI8 = 0_8 ENDIF ELSE IF (.NOT. VIRT_ADD_RESERVED_BEF_CALL ) THEN VIRTUAL_ADDRESS_JUST_RESERVED = .TRUE. ENDIF IF ( VIRTUAL_ADDRESS_JUST_RESERVED) THEN OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(TYPEF), & TYPEF) = MonBloc%INODE I_CUR_HBUF_NEXTPOS(TYPEF) = I_CUR_HBUF_NEXTPOS(TYPEF) + 1 IF (MonBloc%Last) THEN MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,EFFSIZE) TMP_SIZE_FACT=TMP_SIZE_FACT+EFFSIZE ELSE MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,TOTSIZE) TMP_SIZE_FACT=TMP_SIZE_FACT+TOTSIZE ENDIF TMP_NB_NODES=TMP_NB_NODES+1 IF(TMP_SIZE_FACT.GT.SIZE_ZONE_SOLVE)THEN MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE, & TMP_NB_NODES) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 ENDIF ENDIF IF (MonBloc%Last) THEN LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 ENDIF IF (LAST_CALL) THEN IF (.NOT.MonBloc%Last) THEN WRITE(6,*) ' Internal error in DMUMPS_OOC_STORE_LorU ', & ' LAST and LAST_CALL are incompatible ' CALL MUMPS_ABORT() ENDIF LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 ICUR = I_CUR_HBUF_NEXTPOS(TYPEF) - 1 INODE_CUR = OOC_INODE_SEQUENCE(ICUR,TYPEF) ADDR_LAST = AddVirtLibre(TYPEF) IF ( INODE_CUR .NE. MonBloc%INODE .AND. & OOC_VADDR(STEP_OOC(MonBloc%INODE),TYPEF) .NE. -9999 ) THEN 10 CONTINUE IF ( OOC_VADDR(STEP_OOC(INODE_CUR),TYPEF) .NE. -9999_8) THEN ADDR_LAST = OOC_VADDR(STEP_OOC(INODE_CUR), TYPEF) ENDIF ICUR = ICUR - 1 INODE_CUR = OOC_INODE_SEQUENCE(ICUR,TYPEF) IF (INODE_CUR .EQ. MonBloc%INODE) THEN LorUSIZE_OF_BLOCK = ADDR_LAST - & OOC_VADDR(STEP_OOC(INODE_CUR),TYPEF) ELSE IF (ICUR .LE. 1) THEN WRITE(*,*) "Internal error in DMUMPS_OOC_STORE_LorU" WRITE(*,*) "Did not find current node in sequence" CALL MUMPS_ABORT() ENDIF GOTO 10 ENDIF ENDIF FILESIZE = FILESIZE + LorUSIZE_OF_BLOCK ENDIF RETURN END SUBROUTINE DMUMPS_OOC_STORE_LorU SUBROUTINE DMUMPS_OOC_WRT_IN_PANELS_LorU( & STRAT, TYPEF, MonBloc, & SIZE_PANEL, & AFAC, LAFAC, & NextPiv2beWritten, AddVirtCour, & TailleEcrite, IERR ) USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, INTENT(IN) :: STRAT, TYPEF, SIZE_PANEL INTEGER(8) :: LAFAC INTEGER(8), INTENT(IN) :: AddVirtCour DOUBLE PRECISION, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: NextPiv2beWritten TYPE(IO_BLOCK),INTENT(INOUT) :: MonBloc INTEGER(8), INTENT(OUT) :: TailleEcrite INTEGER, INTENT(OUT) :: IERR INTEGER :: I, NBeff, LPANELeff, IEND INTEGER(8) :: AddVirtDeb IERR = 0 TailleEcrite = 0_8 AddVirtDeb = AddVirtCour I = NextPiv2beWritten IF ( NextPiv2beWritten .GT. MonBloc%LastPiv ) THEN RETURN ENDIF 10 CONTINUE NBeff = min(SIZE_PANEL,MonBloc%LastPiv-I+1 ) IF ((NBeff.NE.SIZE_PANEL) .AND. (.NOT.MonBloc%Last)) THEN GOTO 20 ENDIF IF (TYPEF.EQ.TYPEF_L.AND.MonBloc%MASTER.AND. & KEEP_OOC(50).EQ.2 .AND. MonBloc%Typenode.NE.3) THEN IF (MonBloc%INDICES(NBeff+I-1) < 0) & THEN NBeff=NBeff+1 ENDIF ENDIF IEND = I + NBeff -1 CALL DMUMPS_COPY_LU_TO_BUFFER( STRAT, TYPEF, MonBloc, & AFAC, LAFAC, & AddVirtDeb, I, IEND, LPANELeff, & IERR) IF ( IERR .LT. 0 ) THEN RETURN ENDIF IF ( IERR .EQ. 1 ) THEN IERR=0 GOTO 20 ENDIF IF (TYPEF .EQ. TYPEF_L) THEN MonBloc%LastPanelWritten_L = MonBloc%LastPanelWritten_L+1 ELSE MonBloc%LastPanelWritten_U = MonBloc%LastPanelWritten_U+1 ENDIF AddVirtDeb = AddVirtDeb + int(LPANELeff,8) TailleEcrite = TailleEcrite + int(LPANELeff,8) I=I+NBeff IF ( I .LE. MonBloc%LastPiv ) GOTO 10 20 CONTINUE NextPiv2beWritten = I RETURN END SUBROUTINE DMUMPS_OOC_WRT_IN_PANELS_LorU INTEGER(8) FUNCTION DMUMPS_OOC_NBENTRIES_PANEL_123 & (NFSorNPIV, NNMAX, SIZE_PANEL, MonBloc, ESTIM) IMPLICIT NONE TYPE(IO_BLOCK), INTENT(IN):: MonBloc INTEGER, INTENT(IN) :: NFSorNPIV, NNMAX, SIZE_PANEL LOGICAL, INTENT(IN) :: ESTIM INTEGER :: I, NBeff INTEGER(8) :: TOTSIZE TOTSIZE = 0_8 IF (NFSorNPIV.EQ.0) GOTO 100 IF (.NOT. MonBloc%MASTER .OR. MonBloc%Typenode.EQ.3) THEN TOTSIZE = int(NFSorNPIV,8) * int(NNMAX,8) ELSE I = 1 10 CONTINUE NBeff = min(SIZE_PANEL, NFSorNPIV-I+1) IF (KEEP_OOC(50).EQ.2) THEN IF (ESTIM) THEN NBeff = NBeff + 1 ELSE IF (MonBloc%INDICES(I+NBeff-1) < 0) THEN NBeff = NBeff + 1 ENDIF ENDIF ENDIF TOTSIZE = TOTSIZE + & int(NNMAX-I+1,8) * int(NBeff,8) I = I + NBeff IF ( I .LE. NFSorNPIV ) GOTO 10 ENDIF 100 CONTINUE DMUMPS_OOC_NBENTRIES_PANEL_123 = TOTSIZE RETURN END FUNCTION DMUMPS_OOC_NBENTRIES_PANEL_123 INTEGER FUNCTION DMUMPS_OOC_PANEL_SIZE( NNMAX ) IMPLICIT NONE INTEGER, INTENT(IN) :: NNMAX INTEGER DMUMPS_OOC_GET_PANEL_SIZE DMUMPS_OOC_PANEL_SIZE=DMUMPS_OOC_GET_PANEL_SIZE( & int(KEEP_OOC(223),8), NNMAX, KEEP_OOC(227),KEEP_OOC(50)) RETURN END FUNCTION DMUMPS_OOC_PANEL_SIZE SUBROUTINE DMUMPS_OOC_SKIP_NULL_SIZE_NODE() IMPLICIT NONE INTEGER I,TMP_NODE IF(.NOT.DMUMPS_SOLVE_IS_END_REACHED())THEN IF(SOLVE_STEP.EQ.0)THEN I=CUR_POS_SEQUENCE TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE ((I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)).AND. & (SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) & .EQ.0_8)) INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I+1 IF(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ENDIF ENDDO CUR_POS_SEQUENCE=min(I,TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) ELSE I=CUR_POS_SEQUENCE TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE ((I.GE.1).AND. & (SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) & .EQ.0_8)) INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I-1 IF(I.GE.1)THEN TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ENDIF ENDDO CUR_POS_SEQUENCE=max(I,1) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_OOC_SKIP_NULL_SIZE_NODE SUBROUTINE DMUMPS_OOC_SET_STATES_ES(N,KEEP201, & Pruned_List,nb_prun_nodes,STEP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP201, nb_prun_nodes INTEGER, INTENT(IN) :: STEP(N), & Pruned_List(nb_prun_nodes) INTEGER I, ISTEP IF (KEEP201 .GT. 0) THEN OOC_STATE_NODE(:) = ALREADY_USED DO I = 1, nb_prun_nodes ISTEP = STEP(Pruned_List(I)) OOC_STATE_NODE(ISTEP) = NOT_IN_MEM ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_OOC_SET_STATES_ES END MODULE DMUMPS_OOC MUMPS_5.8.1/src/cfac_distrib_ELT.F0000664000175000017500000004544515042446440016473 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ELT_DISTRIB( & N, NELT, NA_ELT8, & COMM, MYID, SLAVEF, & IELPTR_LOC8, RELPTR_LOC8, & ELTVAR_LOC, ELTVAL_LOC, & LINTARR, LDBLARR, & KEEP,KEEP8, MAXELT_SIZE, & FRTPTR, FRTELT, A, LA, FILS, & id, root, roota ) USE CMUMPS_STRUC_DEF USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, NELT INTEGER(8) :: NA_ELT8 INTEGER COMM, MYID, SLAVEF, MAXELT_SIZE, MSGLEN INTEGER(8), intent(IN) :: LA INTEGER FRTPTR( N+1 ) INTEGER FRTELT( NELT ), FILS ( N ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), INTENT(IN) :: IELPTR_LOC8( NELT + 1 ) INTEGER(8), INTENT(INOUT) :: RELPTR_LOC8( NELT + 1 ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER ELTVAR_LOC( LINTARR ) COMPLEX ELTVAL_LOC( LDBLARR ) COMPLEX A( LA ) TYPE(CMUMPS_STRUC) :: id TYPE(MUMPS_ROOT_STRUC) :: root TYPE(CMUMPS_ROOT_STRUC) :: roota INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGTAG INTEGER allocok INTEGER I, DEST, MAXELT_REAL_SIZE, MPG, IEL, SIZEI, SIZER INTEGER NBRECORDS, NBUF INTEGER(8) :: RECV_IELTPTR8 INTEGER(8) :: RECV_RELTPTR8 INTEGER(8) :: IELTPTR8, RELTPTR8 LOGICAL FINI, PROKG, I_AM_SLAVE, EARLYT3ROOTINS INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, LP, IBEG, IGLOB, JGLOB INTEGER ARROW_ROOT INTEGER IELT, J, NB_REC, IREC INTEGER(8) :: K8, IVALPTR8 INTEGER ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, IPTR INTEGER JCOL_GRID, IROW_GRID INTEGER NBELROOT INTEGER MASTER PARAMETER( MASTER = 0 ) COMPLEX VAL COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER, DIMENSION( :, : ), ALLOCATABLE :: BUFI COMPLEX, DIMENSION( :, : ), ALLOCATABLE :: BUFR COMPLEX, DIMENSION( : ), ALLOCATABLE :: TEMP_ELT_R INTEGER, DIMENSION( : ), ALLOCATABLE :: TEMP_ELT_I INTEGER(8), DIMENSION( : ), ALLOCATABLE :: ELROOTPOS8 MPG = id%ICNTL(3) LP = id%ICNTL(1) I_AM_SLAVE = ( KEEP(46) .eq. 1 .or. MYID .ne.MASTER ) PROKG = ( MPG > 0 .and. MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) KEEP(49) = 0 ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) IF ( MYID .eq. MASTER ) THEN IF ( KEEP(46) .eq. 0 ) THEN NBUF = SLAVEF ELSE NBUF = SLAVEF - 1 END IF NBRECORDS = KEEP(39) IF (NA_ELT8 < int(NBRECORDS,8)) THEN NBRECORDS = int(NA_ELT8) ENDIF IF ( KEEP(50) .eq. 0 ) THEN MAXELT_REAL_SIZE = MAXELT_SIZE * MAXELT_SIZE ELSE MAXELT_REAL_SIZE = MAXELT_SIZE * (MAXELT_SIZE+1)/2 END IF IF ( MAXELT_REAL_SIZE .GT. KEEP(39) ) THEN NBRECORDS = MAXELT_REAL_SIZE IF ( MPG .GT. 0 ) THEN WRITE(MPG,*) & ' ** Warning : For element distrib NBRECORDS set to ', & MAXELT_REAL_SIZE,' because one element is large' END IF END IF ALLOCATE( BUFI( 2*NBRECORDS+1, NBUF ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 2*NBRECORDS + 1 GOTO 100 END IF ALLOCATE( BUFR( NBRECORDS+1, NBUF ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS + 1 GOTO 100 END IF IF ( KEEP(52) .ne. 0 ) THEN ALLOCATE( TEMP_ELT_R( MAXELT_REAL_SIZE ), stat =allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXELT_REAL_SIZE GOTO 100 END IF END IF ALLOCATE( TEMP_ELT_I( MAXELT_SIZE ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXELT_SIZE GOTO 100 END IF IF ( KEEP(38) .ne. 0 ) THEN NBELROOT = FRTPTR(KEEP(38)+1)-FRTPTR(KEEP(38)) IF ( EARLYT3ROOTINS ) THEN ALLOCATE( ELROOTPOS8( max(NBELROOT,1) ), & stat = allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBELROOT GOTO 100 END IF ENDIF END IF DO I = 1, NBUF BUFI( 1, I ) = 0 BUFR( 1, I ) = ZERO END DO END IF 100 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MPI_BCAST( NBRECORDS, 1, MPI_INTEGER, MASTER, & COMM, IERR_MPI ) RECV_IELTPTR8 = 1_8 RECV_RELTPTR8 = 1_8 IF ( MYID .eq. MASTER ) THEN NBELROOT = 0 RELTPTR8 = 1_8 RELPTR_LOC8(1) = 1 DO IEL = 1, NELT IELTPTR8 = int(id%ELTPTR( IEL ),8) SIZEI = int(int(id%ELTPTR( IEL + 1 ),8) - IELTPTR8) IF ( KEEP( 50 ) .eq. 0 ) THEN SIZER = SIZEI * SIZEI ELSE SIZER = SIZEI * ( SIZEI + 1 ) / 2 END IF DEST = id%ELTPROC( IEL ) IF ( DEST .eq. -2 ) THEN NBELROOT = NBELROOT + 1 FRTELT( FRTPTR(KEEP(38)) + NBELROOT - 1 ) = IEL ELROOTPOS8( NBELROOT ) = RELTPTR8 GOTO 200 END IF IF ( DEST .ge. 0 .and. KEEP(46) .eq. 0 ) DEST = DEST + 1 IF ( KEEP(52) .ne. 0 ) THEN CALL CMUMPS_SCALE_ELEMENT( N, SIZEI, SIZER, & id%ELTVAR( IELTPTR8 ), id%A_ELT( RELTPTR8 ), & TEMP_ELT_R(1), MAXELT_REAL_SIZE, & id%ROWSCA(1), id%COLSCA(1), KEEP(50) ) END IF IF ( DEST .eq. 0 .or. ( DEST .eq. -1 .and. KEEP(46) .ne. 0 ) ) & THEN ELTVAR_LOC( RECV_IELTPTR8: RECV_IELTPTR8 + SIZEI - 1 ) & = id%ELTVAR( IELTPTR8: IELTPTR8 + SIZEI - 1 ) RECV_IELTPTR8 = RECV_IELTPTR8 + SIZEI IF ( KEEP(52) .ne. 0 & ) THEN ELTVAL_LOC( RECV_RELTPTR8: RECV_RELTPTR8 + SIZER - 1) & = TEMP_ELT_R( 1: SIZER ) RECV_RELTPTR8 = RECV_RELTPTR8 + SIZER END IF END IF IF ( DEST .NE. 0 .AND. DEST. NE. -3 ) THEN IF ( KEEP(52) .eq. 0 ) THEN CALL CMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & id%A_ELT (RELTPTR8), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) ELSE CALL CMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & TEMP_ELT_R( 1 ), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) END IF END IF 200 CONTINUE RELTPTR8 = RELTPTR8 + SIZER IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN RELPTR_LOC8( IEL + 1 ) = RELTPTR8 ELSE RELPTR_LOC8( IEL + 1 ) = RECV_RELTPTR8 ENDIF END DO IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN KEEP8(26) = RELTPTR8 - 1_8 ELSE KEEP8(26) = RECV_RELTPTR8 - 1_8 ENDIF IF ( RELTPTR8 - 1_8 .NE. NA_ELT8 ) THEN WRITE(*,*) " ** Internal error in CMUMPS_ELT_DISTRIB", & RELTPTR8 - 1_8, NA_ELT8 CALL MUMPS_ABORT() END IF DEST = -2 IELTPTR8 = 1_8 RELTPTR8 = 1_8 SIZEI = 1 SIZER = 1 CALL CMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & id%A_ELT (RELTPTR8), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) IF ( KEEP(52) .NE. 0 ) DEALLOCATE( TEMP_ELT_R ) ELSE FINI = ( RECV_IELTPTR8 .eq. IELPTR_LOC8( NELT+1 ) & .and. RECV_RELTPTR8 .eq. RELPTR_LOC8( NELT+1 ) ) DO WHILE ( .not. FINI ) CALL MPI_PROBE( MASTER, MPI_ANY_TAG, & COMM, STATUS, IERR_MPI ) MSGTAG = STATUS( MPI_TAG ) SELECT CASE ( MSGTAG ) CASE( ELT_INT ) CALL MPI_GET_COUNT( STATUS, MPI_INTEGER, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAR_LOC( RECV_IELTPTR8 ), MSGLEN, & MPI_INTEGER, MASTER, ELT_INT, & COMM, STATUS, IERR_MPI ) RECV_IELTPTR8 = RECV_IELTPTR8 + MSGLEN CASE( ELT_REAL ) CALL MPI_GET_COUNT( STATUS, MPI_COMPLEX, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAL_LOC( RECV_RELTPTR8 ), MSGLEN, & MPI_COMPLEX, MASTER, ELT_REAL, & COMM, STATUS, IERR_MPI ) RECV_RELTPTR8 = RECV_RELTPTR8 + MSGLEN END SELECT FINI = ( RECV_IELTPTR8 .eq. IELPTR_LOC8( NELT+1 ) & .and. RECV_RELTPTR8 .eq. RELPTR_LOC8( NELT+1 ) ) END DO END IF IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN IF ( I_AM_SLAVE .and. root%yes ) THEN CALL CMUMPS_GET_ROOT_INFO(root, & LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL CMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) END IF IF ( MYID .NE. MASTER ) THEN ALLOCATE( BUFI( NBRECORDS * 2 + 1, 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS * 2 + 1 GOTO 250 END IF ALLOCATE( BUFR( NBRECORDS, 1 ) , stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS END IF END IF 250 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF ( MYID .eq. MASTER ) THEN DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1 IELT = FRTELT( IPTR ) SIZEI = id%ELTPTR( IELT + 1 ) - id%ELTPTR( IELT ) DO I = 1, SIZEI TEMP_ELT_I( I ) = root%RG2L & ( id%ELTVAR( id%ELTPTR(IELT) + I - 1 ) ) END DO IVALPTR8 = ELROOTPOS8( IPTR - FRTPTR(KEEP(38)) + 1 ) - 1 K8 = 1_8 DO J = 1, SIZEI JGLOB = id%ELTVAR( id%ELTPTR( IELT ) + J - 1 ) IF ( KEEP(50).eq. 0 ) THEN IBEG = 1 ELSE IBEG = J END IF DO I = IBEG, SIZEI IGLOB = id%ELTVAR( id%ELTPTR( IELT ) + I - 1 ) IF ( KEEP(52) .eq. 0 ) THEN VAL = id%A_ELT( IVALPTR8 + K8 ) ELSE VAL = id%A_ELT( IVALPTR8 + K8 ) * & id%ROWSCA( IGLOB ) * id%COLSCA( JGLOB ) END IF IF ( KEEP(50).eq.0 ) THEN IPOSROOT = TEMP_ELT_I( I ) JPOSROOT = TEMP_ELT_I( J ) ELSE IF ( TEMP_ELT_I(I) .GT. TEMP_ELT_I(J) ) THEN IPOSROOT = TEMP_ELT_I(I) JPOSROOT = TEMP_ELT_I(J) ELSE IPOSROOT = TEMP_ELT_I(J) JPOSROOT = TEMP_ELT_I(I) END IF END IF IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, & root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, & root%NPCOL ) IF ( KEEP(46) .eq. 0 ) THEN DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * root%NPCOL + JCOL_GRID END IF IF ( DEST .eq. MASTER ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 ARROW_ROOT = ARROW_ROOT + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & + VAL ENDIF ELSE CALL CMUMPS_ARROW_FILL_SEND_BUF_ELT( & IPOSROOT, JPOSROOT, VAL, DEST, BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM ) END IF K8 = K8 + 1_8 END DO END DO END DO CALL CMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM, KEEP(46) ) ELSE FINI = .FALSE. DO WHILE ( .not. FINI ) CALL MPI_RECV( BUFI(1,1), 2*NBRECORDS+1, & MPI_INTEGER, MASTER, & ARROWHEAD, & COMM, STATUS, IERR_MPI ) NB_REC = BUFI(1,1) ARROW_ROOT = ARROW_ROOT + NB_REC IF (NB_REC.LE.0) THEN FINI = .TRUE. NB_REC = -NB_REC ENDIF IF (NB_REC.EQ.0) EXIT CALL MPI_RECV( BUFR(1,1), NBRECORDS, MPI_COMPLEX, & MASTER, ARROWHEAD, & COMM, STATUS, IERR_MPI ) DO IREC = 1, NB_REC IPOSROOT = BUFI( IREC * 2, 1 ) JPOSROOT = BUFI( IREC * 2 + 1, 1 ) VAL = BUFR( IREC, 1 ) ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60).eq.0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) & = A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) & + VAL ELSE roota%SCHUR_POINTER(int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF END DO END DO DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) END IF END IF IF ( MYID .eq. MASTER ) THEN DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) IF (allocated(ELROOTPOS8)) DEALLOCATE(ELROOTPOS8) DEALLOCATE( TEMP_ELT_I ) END IF KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE CMUMPS_ELT_DISTRIB SUBROUTINE CMUMPS_ELT_FILL_BUF( & ELNODES, ELVAL, SIZEI, SIZER, & DEST, NBUF, NBRECORDS, BUFI, BUFR, COMM ) IMPLICIT NONE INTEGER SIZEI, SIZER, DEST, NBUF, NBRECORDS, COMM INTEGER ELNODES( SIZEI ), BUFI( 2*NBRECORDS + 1, NBUF ) COMPLEX ELVAL( SIZER ), BUFR( NBRECORDS + 1, NBUF ) INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER I, IBEG, IEND, IERR_MPI, NBRECR INTEGER NBRECI COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) IF ( DEST .lt. 0 ) THEN IBEG = 1 IEND = NBUF ELSE IBEG = DEST IEND = DEST END IF DO I = IBEG, IEND NBRECI = BUFI(1,I) IF ( NBRECI .ne.0 .and. & ( DEST.eq.-2 .or. & NBRECI + SIZEI .GT. 2*NBRECORDS ) ) THEN CALL MPI_SEND( BUFI(2, I), NBRECI, MPI_INTEGER, & I, ELT_INT, COMM, IERR_MPI ) BUFI(1,I) = 0 NBRECI = 0 END IF NBRECR = int(real(BUFR(1,I))+0.5E0) IF ( NBRECR .ne.0 .and. & ( DEST.eq.-2 .or. & NBRECR + SIZER .GT. NBRECORDS ) ) THEN CALL MPI_SEND( BUFR(2, I), NBRECR, MPI_COMPLEX, & I, ELT_REAL, COMM, IERR_MPI ) BUFR(1,I) = ZERO NBRECR = 0 END IF IF ( DEST .ne. -2 ) THEN BUFI( 2 + NBRECI : 2 + NBRECI + SIZEI - 1, I ) = & ELNODES( 1: SIZEI ) BUFR( 2 + NBRECR : 2 + NBRECR + SIZER - 1, I ) = & ELVAL( 1: SIZER ) BUFI(1,I) = NBRECI + SIZEI BUFR(1,I) = cmplx( NBRECR + SIZER, kind=kind(BUFR) ) END IF END DO RETURN END SUBROUTINE CMUMPS_ELT_FILL_BUF SUBROUTINE CMUMPS_MAXELT_SIZE( ELTPTR, NELT, MAXELT_SIZE ) INTEGER NELT, MAXELT_SIZE INTEGER ELTPTR( NELT + 1 ) INTEGER I, S MAXELT_SIZE = 0 DO I = 1, NELT S = ELTPTR( I + 1 ) - ELTPTR( I ) MAXELT_SIZE = max( S, MAXELT_SIZE ) END DO RETURN END SUBROUTINE CMUMPS_MAXELT_SIZE SUBROUTINE CMUMPS_SCALE_ELEMENT( N, SIZEI, SIZER, & ELTVAR, ELTVAL, & SELTVAL, LSELTVAL, & ROWSCA, COLSCA, K50 ) INTEGER N, SIZEI, SIZER, LSELTVAL, K50 INTEGER ELTVAR( SIZEI ) COMPLEX ELTVAL( SIZER ) COMPLEX SELTVAL( LSELTVAL ) REAL ROWSCA( N ), COLSCA( N ) INTEGER I, J, K K = 1 IF ( K50 .eq. 0 ) THEN DO J = 1, SIZEI DO I = 1, SIZEI SELTVAL(K) = ELTVAL(K) * & ROWSCA(ELTVAR(I)) * & COLSCA(ELTVAR(J)) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI DO I = J, SIZEI SELTVAL(K) = ELTVAL(K) * & ROWSCA(ELTVAR(I)) * & COLSCA(ELTVAR(J)) K = K + 1 END DO END DO END IF RETURN END SUBROUTINE CMUMPS_SCALE_ELEMENT MUMPS_5.8.1/src/cmumps_ooc_buffer.F0000664000175000017500000004330415042446440017040 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_OOC_BUFFER USE MUMPS_OOC_COMMON IMPLICIT NONE PUBLIC INTEGER FIRST_HBUF,SECOND_HBUF PARAMETER (FIRST_HBUF=0, SECOND_HBUF=1) INTEGER,SAVE :: OOC_FCT_TYPE_LOC COMPLEX, DIMENSION(:),ALLOCATABLE :: BUF_IO LOGICAL,SAVE :: PANEL_FLAG INTEGER,SAVE :: EARLIEST_WRITE_MIN_SIZE INTEGER(8),SAVE,DIMENSION(:), ALLOCATABLE :: & I_SHIFT_FIRST_HBUF, I_SHIFT_SECOND_HBUF, & I_SHIFT_CUR_HBUF, I_REL_POS_CUR_HBUF INTEGER, SAVE, DIMENSION(:), ALLOCATABLE :: & LAST_IOREQUEST, CUR_HBUF INTEGER, DIMENSION(:),ALLOCATABLE :: I_CUR_HBUF_NEXTPOS INTEGER,SAVE :: I_CUR_HBUF_FSTPOS, & I_SUB_HBUF_FSTPOS INTEGER(8) :: BufferEmpty PARAMETER (BufferEmpty=-1_8) INTEGER(8), DIMENSION(:),ALLOCATABLE :: NextAddVirtBuffer INTEGER(8), DIMENSION(:),ALLOCATABLE :: FIRST_VADDR_IN_BUF CONTAINS SUBROUTINE CMUMPS_OOC_NEXT_HBUF(TYPEF_ARG) IMPLICIT NONE INTEGER TYPEF_ARG SELECT CASE(CUR_HBUF(TYPEF_ARG)) CASE (FIRST_HBUF) CUR_HBUF(TYPEF_ARG) = SECOND_HBUF I_SHIFT_CUR_HBUF(TYPEF_ARG) = & I_SHIFT_SECOND_HBUF(TYPEF_ARG) CASE (SECOND_HBUF) CUR_HBUF(TYPEF_ARG) = FIRST_HBUF I_SHIFT_CUR_HBUF(TYPEF_ARG) = & I_SHIFT_FIRST_HBUF(TYPEF_ARG) END SELECT IF(.NOT.PANEL_FLAG)THEN I_SUB_HBUF_FSTPOS =I_CUR_HBUF_FSTPOS I_CUR_HBUF_FSTPOS =I_CUR_HBUF_NEXTPOS(TYPEF_ARG) ENDIF I_REL_POS_CUR_HBUF(TYPEF_ARG) = 1_8 RETURN END SUBROUTINE CMUMPS_OOC_NEXT_HBUF SUBROUTINE CMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_ARG,IERR) IMPLICIT NONE INTEGER TYPEF_ARG INTEGER NEW_IOREQUEST INTEGER IERR IERR=0 CALL CMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF_ARG,NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL MUMPS_WAIT_REQUEST(LAST_IOREQUEST(TYPEF_ARG),IERR) IF(IERR.LT.0)THEN IF (ICNTL1>0) & WRITE(ICNTL1,*) MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF LAST_IOREQUEST(TYPEF_ARG) = NEW_IOREQUEST CALL CMUMPS_OOC_NEXT_HBUF(TYPEF_ARG) IF(PANEL_FLAG)THEN NextAddVirtBuffer(TYPEF_ARG)=BufferEmpty ENDIF RETURN END SUBROUTINE CMUMPS_OOC_DO_IO_AND_CHBUF SUBROUTINE CMUMPS_OOC_BUF_CLEAN_PENDING(IERR) IMPLICIT NONE INTEGER, intent(out) :: IERR INTEGER TYPEF_LAST INTEGER TYPEF_LOC IERR = 0 TYPEF_LAST = OOC_NB_FILE_TYPE DO TYPEF_LOC = 1, TYPEF_LAST IERR=0 CALL CMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL CMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_OOC_BUF_CLEAN_PENDING SUBROUTINE CMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF_ARG,IOREQUEST, & IERR) IMPLICIT NONE INTEGER IOREQUEST,IERR INTEGER TYPEF_ARG INTEGER FIRST_INODE INTEGER(8) :: FROM_BUFIO_POS, SIZE INTEGER TYPE INTEGER ADDR_INT1,ADDR_INT2 INTEGER(8) TMP_VADDR INTEGER SIZE_INT1,SIZE_INT2 IERR=0 IF (I_REL_POS_CUR_HBUF(TYPEF_ARG) == 1_8) THEN IOREQUEST=-1 RETURN END IF IF(PANEL_FLAG)THEN TYPE=TYPEF_ARG-1 FIRST_INODE=-9999 TMP_VADDR=FIRST_VADDR_IN_BUF(TYPEF_ARG) ELSE TYPE=FCT FIRST_INODE = & OOC_INODE_SEQUENCE(I_CUR_HBUF_FSTPOS,TYPEF_ARG) TMP_VADDR=OOC_VADDR(STEP_OOC(FIRST_INODE),TYPEF_ARG) ENDIF FROM_BUFIO_POS=I_SHIFT_CUR_HBUF(TYPEF_ARG)+1_8 SIZE = I_REL_POS_CUR_HBUF(TYPEF_ARG)-1_8 CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & TMP_VADDR) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & BUF_IO(FROM_BUFIO_POS),SIZE_INT1,SIZE_INT2, & FIRST_INODE,IOREQUEST, & TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1>0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF RETURN END SUBROUTINE CMUMPS_OOC_WRT_CUR_BUF2DISK SUBROUTINE CMUMPS_INIT_OOC_BUF(I1,I2,IERR) IMPLICIT NONE INTEGER I1,I2,IERR INTEGER allocok IERR=0 PANEL_FLAG=.FALSE. IF(allocated(I_SHIFT_FIRST_HBUF))THEN DEALLOCATE(I_SHIFT_FIRST_HBUF) ENDIF IF(allocated(I_SHIFT_SECOND_HBUF))THEN DEALLOCATE(I_SHIFT_SECOND_HBUF) ENDIF IF(allocated(I_SHIFT_CUR_HBUF))THEN DEALLOCATE(I_SHIFT_CUR_HBUF) ENDIF IF(allocated(I_REL_POS_CUR_HBUF))THEN DEALLOCATE(I_REL_POS_CUR_HBUF) ENDIF IF(allocated(LAST_IOREQUEST))THEN DEALLOCATE(LAST_IOREQUEST) ENDIF IF(allocated(CUR_HBUF))THEN DEALLOCATE(CUR_HBUF) ENDIF DIM_BUF_IO = int(KEEP_OOC(100),8) ALLOCATE(I_SHIFT_FIRST_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_SHIFT_SECOND_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_SHIFT_CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_REL_POS_CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(LAST_IOREQUEST(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF OOC_FCT_TYPE_LOC=OOC_NB_FILE_TYPE ALLOCATE(BUF_IO(DIM_BUF_IO), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF I1 = -13 CALL MUMPS_SET_IERROR(DIM_BUF_IO, I2) RETURN ENDIF PANEL_FLAG=(KEEP_OOC(201).EQ.1) IF (PANEL_FLAG) THEN IERR=0 KEEP_OOC(228)=0 IF(allocated(AddVirtLibre))THEN DEALLOCATE(AddVirtLibre) ENDIF ALLOCATE(AddVirtLibre(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'CMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF AddVirtLibre(1:OOC_NB_FILE_TYPE)=0_8 IF(allocated(NextAddVirtBuffer))THEN DEALLOCATE(NextAddVirtBuffer) ENDIF ALLOCATE(NextAddVirtBuffer(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'CMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF NextAddVirtBuffer (1:OOC_NB_FILE_TYPE) = BufferEmpty IF(allocated(FIRST_VADDR_IN_BUF))THEN DEALLOCATE(FIRST_VADDR_IN_BUF) ENDIF ALLOCATE(FIRST_VADDR_IN_BUF(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'CMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF CALL CMUMPS_OOC_INIT_DB_BUFFER_PANEL() ELSE CALL CMUMPS_OOC_INIT_DB_BUFFER() ENDIF KEEP_OOC(223)=int(HBUF_SIZE) RETURN END SUBROUTINE CMUMPS_INIT_OOC_BUF SUBROUTINE CMUMPS_END_OOC_BUF() IMPLICIT NONE IF(allocated(BUF_IO))THEN DEALLOCATE(BUF_IO) ENDIF IF(allocated(I_SHIFT_FIRST_HBUF))THEN DEALLOCATE(I_SHIFT_FIRST_HBUF) ENDIF IF(allocated(I_SHIFT_SECOND_HBUF))THEN DEALLOCATE(I_SHIFT_SECOND_HBUF) ENDIF IF(allocated(I_SHIFT_CUR_HBUF))THEN DEALLOCATE(I_SHIFT_CUR_HBUF) ENDIF IF(allocated(I_REL_POS_CUR_HBUF))THEN DEALLOCATE(I_REL_POS_CUR_HBUF) ENDIF IF(allocated(LAST_IOREQUEST))THEN DEALLOCATE(LAST_IOREQUEST) ENDIF IF(allocated(CUR_HBUF))THEN DEALLOCATE(CUR_HBUF) ENDIF IF(PANEL_FLAG)THEN IF(allocated(NextAddVirtBuffer))THEN DEALLOCATE(NextAddVirtBuffer) ENDIF IF(allocated(AddVirtLibre))THEN DEALLOCATE(AddVirtLibre) ENDIF IF(allocated(FIRST_VADDR_IN_BUF))THEN DEALLOCATE(FIRST_VADDR_IN_BUF) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_END_OOC_BUF SUBROUTINE CMUMPS_OOC_INIT_DB_BUFFER() IMPLICIT NONE OOC_FCT_TYPE_LOC=1 HBUF_SIZE = DIM_BUF_IO / int(2,kind=kind(DIM_BUF_IO)) EARLIEST_WRITE_MIN_SIZE = 0 I_SHIFT_FIRST_HBUF(OOC_FCT_TYPE_LOC) = 0_8 I_SHIFT_SECOND_HBUF(OOC_FCT_TYPE_LOC) = HBUF_SIZE LAST_IOREQUEST(OOC_FCT_TYPE_LOC) = -1 I_CUR_HBUF_NEXTPOS = 1 I_CUR_HBUF_FSTPOS = 1 I_SUB_HBUF_FSTPOS = 1 CUR_HBUF(OOC_FCT_TYPE_LOC) = SECOND_HBUF CALL CMUMPS_OOC_NEXT_HBUF(OOC_FCT_TYPE_LOC) END SUBROUTINE CMUMPS_OOC_INIT_DB_BUFFER SUBROUTINE CMUMPS_OOC_COPY_DATA_TO_BUFFER(BLOCK,SIZE_OF_BLOCK, & IERR) IMPLICIT NONE INTEGER(8) :: SIZE_OF_BLOCK COMPLEX BLOCK(SIZE_OF_BLOCK) INTEGER, intent(out) :: IERR INTEGER(8) :: I IERR=0 IF (I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + & SIZE_OF_BLOCK <= HBUF_SIZE + 1_8) THEN ELSE CALL CMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF DO I = 1_8, SIZE_OF_BLOCK BUF_IO(I_SHIFT_CUR_HBUF(OOC_FCT_TYPE_LOC) + & I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + I - 1_8) = & BLOCK(I) END DO I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) = & I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + SIZE_OF_BLOCK RETURN END SUBROUTINE CMUMPS_OOC_COPY_DATA_TO_BUFFER SUBROUTINE CMUMPS_OOC_INIT_DB_BUFFER_PANEL() IMPLICIT NONE INTEGER(8) :: DIM_BUF_IO_L_OR_U INTEGER TYPEF, TYPEF_LAST INTEGER NB_DOUBLE_BUFFERS TYPEF_LAST = OOC_NB_FILE_TYPE NB_DOUBLE_BUFFERS = OOC_NB_FILE_TYPE DIM_BUF_IO_L_OR_U = DIM_BUF_IO / & int(NB_DOUBLE_BUFFERS,kind=kind(DIM_BUF_IO_L_OR_U)) IF(.NOT.STRAT_IO_ASYNC)THEN HBUF_SIZE = DIM_BUF_IO_L_OR_U ELSE HBUF_SIZE = DIM_BUF_IO_L_OR_U / 2_8 ENDIF DO TYPEF = 1, TYPEF_LAST LAST_IOREQUEST(TYPEF) = -1 IF (TYPEF == 1 ) THEN I_SHIFT_FIRST_HBUF(TYPEF) = 0_8 ELSE I_SHIFT_FIRST_HBUF(TYPEF) = DIM_BUF_IO_L_OR_U ENDIF IF(.NOT.STRAT_IO_ASYNC)THEN I_SHIFT_SECOND_HBUF(TYPEF) = I_SHIFT_FIRST_HBUF(TYPEF) ELSE I_SHIFT_SECOND_HBUF(TYPEF) = I_SHIFT_FIRST_HBUF(TYPEF) + & HBUF_SIZE ENDIF CUR_HBUF(TYPEF) = SECOND_HBUF CALL CMUMPS_OOC_NEXT_HBUF(TYPEF) ENDDO I_CUR_HBUF_NEXTPOS = 1 RETURN END SUBROUTINE CMUMPS_OOC_INIT_DB_BUFFER_PANEL SUBROUTINE CMUMPS_OOC_TRYIO_CHBUF_PANEL(TYPEF,IERR) IMPLICIT NONE INTEGER, INTENT(in) :: TYPEF INTEGER, INTENT(out) :: IERR INTEGER IFLAG INTEGER NEW_IOREQUEST IERR=0 CALL MUMPS_TEST_REQUEST_C(LAST_IOREQUEST(TYPEF),IFLAG, & IERR) IF (IFLAG.EQ.1) THEN IERR = 0 CALL CMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF, & NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF LAST_IOREQUEST(TYPEF) = NEW_IOREQUEST CALL CMUMPS_OOC_NEXT_HBUF(TYPEF) NextAddVirtBuffer(TYPEF)=BufferEmpty RETURN ELSE IF(IFLAG.LT.0)THEN WRITE(*,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ELSE IERR = 1 RETURN ENDIF END SUBROUTINE CMUMPS_OOC_TRYIO_CHBUF_PANEL SUBROUTINE CMUMPS_OOC_UPD_VADDR_CUR_BUF (TYPEF,VADDR) IMPLICIT NONE INTEGER(8), INTENT(in) :: VADDR INTEGER, INTENT(in) :: TYPEF IF(I_REL_POS_CUR_HBUF(TYPEF).EQ.1_8)THEN FIRST_VADDR_IN_BUF(TYPEF)=VADDR ENDIF RETURN END SUBROUTINE CMUMPS_OOC_UPD_VADDR_CUR_BUF SUBROUTINE CMUMPS_COPY_LU_TO_BUFFER( STRAT, TYPEF, MonBloc, & AFAC, LAFAC, & AddVirtCour, IPIVBEG, IPIVEND, LPANELeff, & IERR) IMPLICIT NONE INTEGER, INTENT(IN) :: TYPEF, IPIVBEG, IPIVEND, STRAT INTEGER(8), INTENT(IN) :: LAFAC COMPLEX, INTENT(IN) :: AFAC(LAFAC) INTEGER(8), INTENT(IN) :: AddVirtCour TYPE(IO_BLOCK), INTENT(IN) :: MonBloc INTEGER, INTENT(OUT):: LPANELeff INTEGER, INTENT(OUT):: IERR INTEGER :: II, NBPIVeff INTEGER(8) :: IPOS, IDIAG, IDEST INTEGER(8) :: DeltaIPOS INTEGER :: StrideIPOS IERR=0 IF (STRAT.NE.STRAT_WRITE_MAX.AND.STRAT.NE.STRAT_TRY_WRITE) THEN write(6,*) ' CMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented ' CALL MUMPS_ABORT() ENDIF NBPIVeff = IPIVEND - IPIVBEG + 1 IF (MonBloc%MASTER .AND. MonBloc%Typenode .NE. 3) THEN IF (TYPEF.EQ.TYPEF_L) THEN LPANELeff = (MonBloc%NROW-IPIVBEG+1)*NBPIVeff ELSE LPANELeff = (MonBloc%NCOL-IPIVBEG+1)*NBPIVeff ENDIF ELSE LPANELeff = MonBloc%NROW*NBPIVeff ENDIF IF ( ( I_REL_POS_CUR_HBUF(TYPEF) + int(LPANELeff - 1,8) & > & HBUF_SIZE ) & .OR. & ( (AddVirtCour.NE.NextAddVirtBuffer(TYPEF)) .AND. & (NextAddVirtBuffer(TYPEF).NE.BufferEmpty) ) & ) THEN IF (STRAT.EQ.STRAT_WRITE_MAX) THEN CALL CMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF,IERR) ELSE IF (STRAT.EQ.STRAT_TRY_WRITE) THEN CALL CMUMPS_OOC_TRYIO_CHBUF_PANEL(TYPEF,IERR) IF (IERR.EQ.1) RETURN ELSE write(6,*) 'CMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented' ENDIF ENDIF IF (IERR < 0 ) THEN RETURN ENDIF IF (NextAddVirtBuffer(TYPEF).EQ. BufferEmpty) THEN CALL CMUMPS_OOC_UPD_VADDR_CUR_BUF (TYPEF,AddVirtCour) NextAddVirtBuffer(TYPEF) = AddVirtCour ENDIF IF (MonBloc%MASTER .AND. MonBloc%Typenode .NE. 3) THEN IDIAG = int(IPIVBEG-1,8)*int(MonBloc%NCOL,8) + int(IPIVBEG,8) IPOS = IDIAG IDEST = I_SHIFT_CUR_HBUF(TYPEF) + & I_REL_POS_CUR_HBUF(TYPEF) IF (TYPEF.EQ.TYPEF_L) THEN DO II = IPIVBEG, IPIVEND CALL ccopy(MonBloc%NROW-IPIVBEG+1, & AFAC(IPOS), MonBloc%NCOL, & BUF_IO(IDEST), 1) IDEST = IDEST + int(MonBloc%NROW-IPIVBEG+1,8) IPOS = IPOS + 1_8 ENDDO ELSE DO II = IPIVBEG, IPIVEND CALL ccopy(MonBloc%NCOL-IPIVBEG+1, & AFAC(IPOS), 1, & BUF_IO(IDEST), 1) IDEST = IDEST + int(MonBloc%NCOL-IPIVBEG+1,8) IPOS = IPOS + int(MonBloc%NCOL,8) ENDDO ENDIF ELSE IDEST = I_SHIFT_CUR_HBUF(TYPEF) + & I_REL_POS_CUR_HBUF(TYPEF) IF (MonBloc%Typenode.EQ.3) THEN DeltaIPOS = int(MonBloc%NROW,8) StrideIPOS = 1 ELSE DeltaIPOS = 1_8 StrideIPOS = MonBloc%NCOL ENDIF IPOS = 1_8 + int(IPIVBEG - 1,8) * DeltaIPOS DO II = IPIVBEG, IPIVEND CALL ccopy(MonBloc%NROW, & AFAC(IPOS), StrideIPOS, & BUF_IO(IDEST), 1) IDEST = IDEST+int(MonBloc%NROW,8) IPOS = IPOS + DeltaIPOS ENDDO ENDIF I_REL_POS_CUR_HBUF(TYPEF) = & I_REL_POS_CUR_HBUF(TYPEF) + int(LPANELeff,8) NextAddVirtBuffer(TYPEF) = NextAddVirtBuffer(TYPEF) & + int(LPANELeff,8) RETURN END SUBROUTINE CMUMPS_COPY_LU_TO_BUFFER END MODULE CMUMPS_OOC_BUFFER MUMPS_5.8.1/src/zend_driver.F0000664000175000017500000006131015042446442015655 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_END_DRIVER( id, idintr ) USE ZMUMPS_STRUC_DEF, ONLY: ZMUMPS_STRUC USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_INTR_STRUC IMPLICIT NONE C C Purpose: C ======= C C Terminate a MUMPS instance. Free all internal data structure and C suppress OOC files on disk, if any. C C Argument: C ======== C TYPE( ZMUMPS_STRUC ) :: id TYPE( ZMUMPS_INTR_STRUC ) :: idintr C C Local declarations C ================== INTEGER IERR INTEGER, PARAMETER :: MASTER = 0 C C Executable statements C ===================== C C First, free all MUMPS internal data except communicators created C during a call to MUMPS wit JOB=-1 CALL ZMUMPS_FREE_DATA_ANAFACSOL( id, idintr ) C C Allocated during JOB=-1: IF ( id%MYID .NE. MASTER .OR. id%KEEP(46) .ne. 0 ) THEN C Note that on some very old platforms, COMM_NODES would have been C freed inside BLACS_GRIDEXIT, which may cause problems C in the call to MPI_COMM_FREE. CALL MPI_COMM_FREE( id%COMM_NODES, IERR ) C Free communicator related to load messages. CALL MPI_COMM_FREE( id%COMM_LOAD, IERR ) END IF CALL MUMPS_DESTROY_ARCH_NODE_COMM( id%KEEP(411), id%KEEP(410), & id%KEEP(413) ) C Nullifying id%SCHUR_CINTERFACE here is not necessary, C it is freed systematically each time we exit ZMUMPS_DRIVER C and reset each time we enter MUMPS through its C interface. NULLIFY(id%SCHUR_CINTERFACE) C RETURN END SUBROUTINE ZMUMPS_END_DRIVER C SUBROUTINE ZMUMPS_END_ROOT(roota) USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE(ZMUMPS_ROOT_STRUC) :: roota IF (associated(roota%RHS_CNTR_MASTER_ROOT)) THEN DEALLOCATE(roota%RHS_CNTR_MASTER_ROOT) NULLIFY(roota%RHS_CNTR_MASTER_ROOT) ENDIF IF (associated(roota%RHS_ROOT))THEN DEALLOCATE(roota%RHS_ROOT) NULLIFY(roota%RHS_ROOT) ENDIF CALL ZMUMPS_RR_FREE_POINTERS(roota) RETURN END SUBROUTINE ZMUMPS_END_ROOT C SUBROUTINE ZMUMPS_FREE_DATA_ANAFACSOL(id, idintr) USE ZMUMPS_STRUC_DEF USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_INTR_STRUC IMPLICIT NONE C C Purpose: C ======= C Free all MUMPS internal data, except communicators built during C a JOB=-1 call. Called by ZMUMPS_END_DRIVER and ZMUMPS_ANA_DRIVER. C Calls ZMUMPS_FREE_DATA_FACTO, which frees most of the data allocated C during factorization and solve, except: C - scaling arrays, because they are sometimes allocated at analysis C - STEP2NODE, which can be reused when analysis does not change C Therefore, scaling arrays and STEP2NODE are freed here. C C Arguments C ========= TYPE( ZMUMPS_STRUC ) :: id TYPE( ZMUMPS_INTR_STRUC ) :: idintr C Local declarations C ================== LOGICAL I_AM_SLAVE INTEGER, PARAMETER :: MASTER = 0 C C Executable statements C --------------------- C I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) C C First, free data from factoriation and solve: CALL ZMUMPS_FREE_DATA_FACTO(id,idintr) C ------------------------------------- C Right-hand-side and solutions are C always user data, we do not free them C ------------------------------------- IF (associated(id%MEM_DIST)) THEN DEALLOCATE(id%MEM_DIST) NULLIFY(id%MEM_DIST) ENDIF C --------------------------------- C Allocated by ZMUMPS, Used by user. C ZMUMPS deallocates. User should C use them before ZMUMPS_END_DRIVER or C copy. C --------------------------------- IF (associated(id%MAPPING)) THEN DEALLOCATE(id%MAPPING) NULLIFY(id%MAPPING) END IF C ------------------------------------- C Always deallocate scaling arrays C if they are associated, except C when provided by the user (on master) C ------------------------------------- IF ( id%KEEP(52) .NE. -1 .or. id%MYID .ne. MASTER ) THEN IF (associated(id%COLSCA)) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ENDIF IF (associated(id%ROWSCA)) THEN DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF END IF C Begin PRUN_NODES C Info for pruning tree IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF C END PRUN_NODES c --------------------- C Allocated during analysis: IF (associated(id%NE_STEPS)) THEN DEALLOCATE(id%NE_STEPS) NULLIFY(id%NE_STEPS) ENDIF C Allocated during analysis: IF (associated(id%ND_STEPS)) THEN DEALLOCATE(id%ND_STEPS) NULLIFY(id%ND_STEPS) ENDIF C Allocated during analysis: IF (associated(id%FRERE_STEPS)) THEN DEALLOCATE(id%FRERE_STEPS) NULLIFY(id%FRERE_STEPS) ENDIF C Allocated during analysis: IF (associated(id%DAD_STEPS)) THEN DEALLOCATE(id%DAD_STEPS) NULLIFY(id%DAD_STEPS) ENDIF C Allocated during analysis: IF (associated(id%SYM_PERM)) THEN DEALLOCATE(id%SYM_PERM) NULLIFY(id%SYM_PERM) ENDIF IF (associated(id%STEP)) THEN DEALLOCATE(id%STEP) NULLIFY(id%STEP) ENDIF IF (associated(id%LRGROUPS)) THEN DEALLOCATE(id%LRGROUPS) NULLIFY(id%LRGROUPS) ENDIF IF (associated(id%FILS)) THEN DEALLOCATE(id%FILS) NULLIFY(id%FILS) ENDIF IF (associated(id%UNS_PERM)) THEN DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF CC Allocated during analysis: IF (associated(id%FRTPTR)) THEN DEALLOCATE(id%FRTPTR) NULLIFY(id%FRTPTR) ENDIF C Allocated during analysis: IF (associated(id%FRTELT)) THEN DEALLOCATE(id%FRTELT) NULLIFY(id%FRTELT) ENDIF C Allocated during analysis: IF (associated(id%NA)) THEN DEALLOCATE(id%NA) NULLIFY(id%NA) ENDIF C Allocated during analysis: IF (associated(id%PROCNODE_STEPS)) THEN DEALLOCATE(id%PROCNODE_STEPS) NULLIFY(id%PROCNODE_STEPS) ENDIF IF (associated(id%ELTPROC)) THEN DEALLOCATE(id%ELTPROC) NULLIFY(id%ELTPROC) ENDIF C Allocated at analysis: IF (associated(id%CANDIDATES)) THEN DEALLOCATE(id%CANDIDATES) NULLIFY(id%CANDIDATES) ENDIF C Allocated at analysis: IF (associated(id%I_AM_CAND)) THEN DEALLOCATE(id%I_AM_CAND) NULLIFY(id%I_AM_CAND) ENDIF C Allocated at analysis: IF (associated(id%ISTEP_TO_INIV2)) THEN DEALLOCATE(id%ISTEP_TO_INIV2) NULLIFY(id%ISTEP_TO_INIV2) ENDIF C Node partitionning (only allocated on slaves) IF (I_AM_SLAVE) THEN C Allocated at analysis: IF (associated(id%TAB_POS_IN_PERE)) THEN DEALLOCATE(id%TAB_POS_IN_PERE) NULLIFY(id%TAB_POS_IN_PERE) ENDIF ENDIF IF (I_AM_SLAVE) THEN C Allocated at analysis: IF (associated(id%FUTURE_NIV2)) THEN DEALLOCATE(id%FUTURE_NIV2) NULLIFY(id%FUTURE_NIV2) ENDIF ENDIF C Allocated at analysis: IF(associated(id%DEPTH_FIRST))THEN DEALLOCATE(id%DEPTH_FIRST) NULLIFY(id%DEPTH_FIRST) ENDIF C Allocated at analysis: IF(associated(id%DEPTH_FIRST_SEQ))THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) NULLIFY(id%DEPTH_FIRST_SEQ) ENDIF C Allocated at analysis: IF(associated(id%SBTR_ID))THEN DEALLOCATE(id%SBTR_ID) NULLIFY(id%SBTR_ID) ENDIF C Allocated and initialized at analysis: IF(associated(id%SCHED_DEP))THEN DEALLOCATE(id%SCHED_DEP) NULLIFY(id%SCHED_DEP) ENDIF C Allocated and initialized at analysis: IF(associated(id%SCHED_SBTR))THEN DEALLOCATE(id%SCHED_SBTR) NULLIFY(id%SCHED_SBTR) ENDIF C Allocated and initialized at analysis: IF(associated(id%SCHED_GRP))THEN DEALLOCATE(id%SCHED_GRP) NULLIFY(id%SCHED_GRP) ENDIF C Allocated and initialized at analysis: IF(associated(id%CROIX_MANU))THEN DEALLOCATE(id%CROIX_MANU) NULLIFY(id%CROIX_MANU) ENDIF C Allocated during analysis: IF (associated(id%PTRAR)) THEN DEALLOCATE(id%PTRAR) NULLIFY(id%PTRAR) ENDIF C Allocated at analysis: IF (associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) NULLIFY(id%MEM_SUBTREE) ENDIF C Allocated at analysis: IF (associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) NULLIFY(id%MY_ROOT_SBTR) ENDIF C Allocated at analysis: IF (associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) NULLIFY(id%MY_FIRST_LEAF) ENDIF C Allocated at analysis: IF (associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) NULLIFY(id%MY_NB_LEAF) ENDIF C Allocated at analysis: IF (associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) NULLIFY(id%COST_TRAV) ENDIF C Allocated at analysis: IF (associated(id%CB_SON_SIZE)) THEN DEALLOCATE(id%CB_SON_SIZE) NULLIFY(id%CB_SON_SIZE) ENDIF C Allocated at analysis: IF (associated(id%SUP_PROC)) THEN DEALLOCATE(id%SUP_PROC) NULLIFY(id%SUP_PROC) ENDIF ! IF(id%KEEP(486).NE.0) THEN C Allocated at analysis: IF (associated(id%LRGROUPS)) THEN DEALLOCATE(id%LRGROUPS) NULLIFY(id%LRGROUPS) ENDIF ! ENDIF C C free data concerned when redoing cheap analysis CALL ZMUMPS_FREE_DATA_REDO_ANA( id ) C C gridinit performed at analysis: #if ! defined(NOSCALAPACK) IF (idintr%root%gridinit_done) THEN IF ( id%KEEP(38).NE.0 .and. idintr%root%yes ) THEN CALL blacs_gridexit( idintr%root%CNTXT_BLACS ) idintr%root%gridinit_done = .FALSE. END IF END IF #endif RETURN END SUBROUTINE ZMUMPS_FREE_DATA_ANAFACSOL SUBROUTINE ZMUMPS_FREE_DATA_REDO_ANA ( id ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C Free all MUMPS internal data concerned C when redoing a cheap analysis : C - data related to MPI2KOMP allocated during analysis C - data related to L0OMP allocated during analysis C - data related to building arrowheads because C of EARLYT3ROOTINS that might change when of C L0-thread (KEEP(400) C Arguments C ========= TYPE( ZMUMPS_STRUC ) :: id C C Executable statements C --------------------- CCN#if defined(MPI_TO_K_OMP) C Allocated at analysis: IF (associated(id%MTKO_PROCS_MAP)) THEN DEALLOCATE(id%MTKO_PROCS_MAP) NULLIFY(id%MTKO_PROCS_MAP) ENDIF C Allocated at analysis: IF (associated(id%IPOOL_B_L0_OMP)) THEN DEALLOCATE(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_B_L0_OMP) END IF IF (associated(id%IPOOL_A_L0_OMP)) THEN DEALLOCATE(id%IPOOL_A_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) END IF IF (associated(id%PHYS_L0_OMP)) THEN DEALLOCATE(id%PHYS_L0_OMP) NULLIFY(id%PHYS_L0_OMP) END IF IF (associated(id%VIRT_L0_OMP)) THEN DEALLOCATE(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP) END IF IF (associated(id%VIRT_L0_OMP_MAPPING)) THEN DEALLOCATE(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%VIRT_L0_OMP_MAPPING) END IF IF (associated(id%PERM_L0_OMP)) THEN DEALLOCATE(id%PERM_L0_OMP) NULLIFY(id%PERM_L0_OMP) END IF IF (associated(id%PTR_LEAFS_L0_OMP)) THEN DEALLOCATE(id%PTR_LEAFS_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) END IF C Allocated at analysis: IF (associated(id%I4_L0_OMP)) THEN DEALLOCATE(id%I4_L0_OMP) NULLIFY(id%I4_L0_OMP) END IF C Allocated at analysis: IF (associated(id%I8_L0_OMP)) THEN DEALLOCATE(id%I8_L0_OMP) NULLIFY(id%I8_L0_OMP) END IF C ================================================= C BEGIN Pointers to original matrix C allocated during analysis C in format ready for assembly during factorization C (arrowheads if assembled format) C Allocated during analysis: C id%PTRAR is allocated in ana_driver and C should not be deallocated here (it does not C change in sze) IF (associated(id%PTR8ARR)) THEN DEALLOCATE(id%PTR8ARR) NULLIFY(id%PTR8ARR) ENDIF C Allocated during analysis: IF (associated(id%NINCOLARR)) THEN DEALLOCATE(id%NINCOLARR) NULLIFY(id%NINCOLARR) ENDIF C Allocated during analysis: IF (associated(id%NINROWARR)) THEN DEALLOCATE(id%NINROWARR) NULLIFY(id%NINROWARR) ENDIF C Allocated during analysis: IF (associated(id%PTRDEBARR)) THEN DEALLOCATE(id%PTRDEBARR) NULLIFY(id%PTRDEBARR) ENDIF C ================================================= RETURN END SUBROUTINE ZMUMPS_FREE_DATA_REDO_ANA SUBROUTINE ZMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8, K34) USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_END USE ZMUMPS_LR_DATA_M, only : ZMUMPS_BLR_STRUC_TO_MOD, & ZMUMPS_BLR_END_MODULE IMPLICIT NONE C C Purpose: C ======= C C Free data from modules kept from one phase to the other C and referenced through the main MUMPS structure, id. C C Both id%FDM_F_ENCODING and id%BLRARRAY_ENCODING C are concerned. C C C C Arguments: C ========= C # if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) INTEGER, intent(in) :: K34 C IF (associated(id_FDM_F_ENCODING)) THEN C Allow access to FDM_F data for BLR_END_MODULE CALL MUMPS_FDM_STRUC_TO_MOD('F', id_FDM_F_ENCODING) IF (associated(id_BLRARRAY_ENCODING)) THEN C Pass id_BLRARRAY_ENCODING control to module C and terminate BLR module of current instance CALL ZMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) CALL ZMUMPS_BLR_END_MODULE(0, KEEP8, K34, & LRSOLVE_ACT_OPT=.TRUE.) ENDIF C --------------------------------------- C FDM data structures are still allocated C in the module and should be freed C --------------------------------------- CALL MUMPS_FDM_END('F') ENDIF RETURN END SUBROUTINE ZMUMPS_FREE_ID_DATA_MODULES C C ----------------------------------------------------------------- C SUBROUTINE ZMUMPS_FREE_DATA_FACTO(id,idintr) C C Purpose: C ------- C C ZMUMPS_FREE_DATA_FACTO frees data that was allocated during C factorization and that can be useful for the solve. Afterwards, C data from analysis is kept so that a new factorization phase C is possible. C C Module depencies C ---------------- USE ZMUMPS_STRUC_DEF, ONLY: ZMUMPS_STRUC USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_INTR_STRUC USE ZMUMPS_FACSOL_L0OMP_M, ONLY : ZMUMPS_FREE_L0_OMP_FACTORS USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_FREE_S_WK USE MUMPS_BUF_COMMON, ONLY : & MUMPS_BUF_DEALL_CB, & MUMPS_BUF_DEALL_SMALL_BUF IMPLICIT NONE C C Argument: C -------- C C id is the main MUMPS structure, giving with idintr access C to all internal objects allocated by the package. C TYPE( ZMUMPS_STRUC) :: id TYPE( ZMUMPS_INTR_STRUC ) :: idintr C C Local declarations C ------------------ INTEGER :: IERR LOGICAL :: I_AM_SLAVE INTEGER, PARAMETER :: MASTER = 0 C C Interface blocks C ---------------- INTERFACE C (explicit needed because of pointer arguments) SUBROUTINE ZMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8, K34) # if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) INTEGER, intent(in) :: K34 END SUBROUTINE ZMUMPS_FREE_ID_DATA_MODULES END INTERFACE C I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) C C Free OOC-related data C --------------------- C (this includes suppression of OOC files) IF (id%KEEP(201).GT.0 .AND. I_AM_SLAVE) THEN CALL ZMUMPS_CLEAN_OOC_DATA(id,IERR) IF (IERR < 0) THEN id%INFO(1) = -90 id%INFO(2) = 0 ENDIF END IF CALL MUMPS_PROPINFO(id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID) IF (associated(id%PTLUST_S)) THEN DEALLOCATE(id%PTLUST_S) NULLIFY(id%PTLUST_S) END IF IF (associated(id%PTRFAC)) THEN DEALLOCATE(id%PTRFAC) NULLIFY(id%PTRFAC) END IF IF (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) ENDIF IF (associated(id%PIVNUL_LIST)) THEN DEALLOCATE(id%PIVNUL_LIST) NULLIFY(id%PIVNUL_LIST) ENDIF IF (associated(id%ROWSCA_loc)) THEN DEALLOCATE(id%ROWSCA_loc) NULLIFY(id%ROWSCA_loc) ENDIF IF (id%KEEP(50) .EQ. 0) THEN IF (associated(id%COLSCA_loc)) THEN DEALLOCATE(id%COLSCA_loc) ENDIF ENDIF NULLIFY(id%COLSCA_loc) C IPIV is used both for ScaLAPACK and RR C Keep it outside ZMUMPS_RR_FREE_POINTERS IF (associated(idintr%root%IPIV)) THEN DEALLOCATE(idintr%root%IPIV) NULLIFY(idintr%root%IPIV) ENDIF CALL ZMUMPS_END_ROOT(idintr%roota) IF (associated(id%SINGULAR_VALUES)) THEN DEALLOCATE(id%SINGULAR_VALUES) NULLIFY(id%SINGULAR_VALUES) ENDIF C Free module data from factorization: CALL ZMUMPS_FREE_ID_DATA_MODULES(id%FDM_F_ENCODING, ! done & id%BLRARRAY_ENCODING, id%KEEP8(1), id%KEEP(34)) C --------------------------- C Deallocate main workarray S C --------------------------- IF (id%KEEP8(24).EQ.0_8) THEN C -- deallocate only when not provided/allocated by the user IF (associated(id%S)) THEN CALL ZMUMPS_DM_FREE_S_WK(id%S, id%KEEP(430)) ENDIF C Reset KEEP(430)=0 since S is free C KEEP(430) will be redefined during facto id%KEEP(430) = 0 C Update allocated size of S: id%KEEP8(23)=0_8 ENDIF NULLIFY(id%S) IF (I_AM_SLAVE) THEN C ------------------------ C Deallocate buffer for C contrib-blocks (facto/ C solve). Note that this C will cancel all possible C pending requests. C ------------------------ CALL MUMPS_BUF_DEALL_CB( IERR ) C Deallocate buffer for integers (facto/solve) CALL MUMPS_BUF_DEALL_SMALL_BUF( IERR ) END IF C IF (associated(id%L0_OMP_MAPPING)) THEN DEALLOCATE(id%L0_OMP_MAPPING) NULLIFY(id%L0_OMP_MAPPING) END IF IF (associated(idintr%L0_OMP_FACTORS)) THEN CALL ZMUMPS_FREE_L0_OMP_FACTORS(idintr%L0_OMP_FACTORS) END IF C C Data allocated during solve C --------------------------- C C (or for some of it, factorization -- forward during factorization) IF (associated(id%RHSINTR)) THEN DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25)=0_8 ENDIF IF (associated(id%GLOB2LOC_RHS)) THEN DEALLOCATE(id%GLOB2LOC_RHS) NULLIFY(id%GLOB2LOC_RHS) ENDIF IF (id%GLOB2LOC_SOL_ALLOC) THEN DEALLOCATE(id%GLOB2LOC_SOL) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF C Allocated during solve: C (even in case of fwd in facto) IF (associated(id%IPTR_WORKING)) THEN DEALLOCATE(id%IPTR_WORKING) NULLIFY(id%IPTR_WORKING) END IF IF (associated(id%WORKING)) THEN DEALLOCATE(id%WORKING) NULLIFY(id%WORKING) END IF RETURN END SUBROUTINE ZMUMPS_FREE_DATA_FACTO SUBROUTINE ZMUMPS_FREE_DATA_RHSINTR(id) C C Purpose: C ------- C Free RHSINTR related data that might C have been generated after a forward only step (ICNTL(26)=1) C Module depencies C ---------------- USE ZMUMPS_STRUC_DEF IMPLICIT NONE C C Argument: C -------- C C id is the main MUMPS structure, giving with idintr access C to all internal objects allocated by the package. C TYPE( ZMUMPS_STRUC) :: id C IF (associated(id%RHSINTR)) THEN DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25)=0_8 id%LD_RHSINTR = 0 ENDIF IF (associated(id%GLOB2LOC_RHS)) THEN DEALLOCATE(id%GLOB2LOC_RHS) NULLIFY(id%GLOB2LOC_RHS) ENDIF IF (id%GLOB2LOC_SOL_ALLOC) THEN DEALLOCATE(id%GLOB2LOC_SOL) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF RETURN END SUBROUTINE ZMUMPS_FREE_DATA_RHSINTR SUBROUTINE ZMUMPS_CLEAN_OOC_DATA(id,IERR) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_STRUC IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id INTEGER IERR IERR=0 CALL ZMUMPS_OOC_CLEAN_FILES(id,IERR) IF(associated(id%OOC_TOTAL_NB_NODES))THEN DEALLOCATE(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_TOTAL_NB_NODES) ENDIF IF(associated(id%OOC_INODE_SEQUENCE))THEN DEALLOCATE(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_INODE_SEQUENCE) ENDIF IF(associated(id%OOC_SIZE_OF_BLOCK))THEN DEALLOCATE(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_SIZE_OF_BLOCK) ENDIF IF(associated(id%OOC_VADDR))THEN DEALLOCATE(id%OOC_VADDR) NULLIFY(id%OOC_VADDR) ENDIF RETURN END SUBROUTINE ZMUMPS_CLEAN_OOC_DATA SUBROUTINE ZMUMPS_OOC_CLEAN_FILES(id,IERR) USE ZMUMPS_STRUC_DEF USE MUMPS_OOC_COMMON, ONLY : ERR_STR_OOC, & DIM_ERR_STR_OOC, & FILENAMELENGTH IMPLICIT NONE EXTERNAL MUMPS_OOC_REMOVE_FILE_C TYPE(ZMUMPS_STRUC) :: id INTEGER IERR INTEGER I,J,I1,K CHARACTER(len=1):: TMP_NAME(FILENAMELENGTH) C Note that Fortran initializes IERR to 0. C The C layer modifies it in case of error. IERR=0 K=1 C WHEN SAVE/RESTORE IS ON, OOC FILES ASSOCIATED TO A SAVED INSTANCE C ARE NOT REMOVED IF(.NOT. id%ASSOCIATED_OOC_FILES) THEN IF(associated(id%OOC_FILE_NAMES).AND. & associated(id%OOC_FILE_NAME_LENGTH))THEN DO I1=1,id%OOC_NB_FILE_TYPE DO I=1,id%OOC_NB_FILES(I1) DO J=1,id%OOC_FILE_NAME_LENGTH(K) TMP_NAME(J)=id%OOC_FILE_NAMES(K,J) ENDDO C Note that termination character '0' is included CALL MUMPS_OOC_REMOVE_FILE_C(IERR, TMP_NAME(1)) IF(IERR.LT.0)THEN IF (id%ICNTL(1).GT.0 .AND. id%ICNTL(4).GE.1)THEN WRITE(id%ICNTL(1),*) id%MYID,': ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF ENDIF K=K+1 ENDDO ENDDO ENDIF ENDIF IF(associated(id%OOC_FILE_NAMES))THEN DEALLOCATE(id%OOC_FILE_NAMES) NULLIFY(id%OOC_FILE_NAMES) ENDIF IF(associated(id%OOC_FILE_NAME_LENGTH))THEN DEALLOCATE(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAME_LENGTH) ENDIF IF(associated(id%OOC_NB_FILES))THEN DEALLOCATE(id%OOC_NB_FILES) NULLIFY(id%OOC_NB_FILES) ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_CLEAN_FILES MUMPS_5.8.1/src/dmumps_gpu.h0000664000175000017500000000114315042446422015560 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef DMUMPS_GPU_H #define DMUMPS_GPU_H #include "mumps_compat.h" #include "mumps_common.h" void MUMPS_CALL dmumps_gpu_return(); #endif /* DMUMPS_GPU_H */ MUMPS_5.8.1/src/zsol_distrhs.F0000664000175000017500000006051615042446441016077 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SCATTER_DIST_RHS( & NSLAVES, N, & MYID_NODES, COMM_NODES, & NRHS_COL, NRHS_loc, LRHS_loc, & MAP_RHS_loc, & IRHS_loc, RHS_loc, RHS_loc_size, & RHSINTR, LD_RHSINTR, & POSINRHSINTR_FWD, NB_FS_IN_RHSINTR, & LSCAL, #if defined(USE_OLD_SCALING) & scaling_data_dr, #else & SCALING_RHSINTR_FWD, LSCALING_RHSINTR_FWD, #endif & LP, LPOK, KEEP, NB_BYTES_LOC, INFO ) USE ZMUMPS_STRUC_DEF !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN) :: NSLAVES, N, MYID_NODES INTEGER, INTENT(IN) :: NRHS_loc, LRHS_loc INTEGER, INTENT(IN) :: NRHS_COL INTEGER, INTENT(IN) :: COMM_NODES INTEGER, INTENT(IN) :: MAP_RHS_loc(max(1,NRHS_loc)) INTEGER, INTENT(IN) :: IRHS_loc(NRHS_loc) INTEGER(8), INTENT(IN) :: RHS_loc_size COMPLEX(kind=8), INTENT(IN) :: RHS_loc(RHS_loc_size) INTEGER, INTENT(IN) :: NB_FS_IN_RHSINTR, LD_RHSINTR INTEGER, INTENT(IN) :: POSINRHSINTR_FWD(N) COMPLEX(kind=8), INTENT(OUT) :: RHSINTR(LD_RHSINTR, NRHS_COL) INTEGER :: KEEP(500) LOGICAL, INTENT(IN) :: LSCAL #if defined(USE_OLD_SCALING) type scaling_data_t SEQUENCE DOUBLE PRECISION, dimension(:), pointer :: SCALING DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC INTEGER, dimension(:), pointer :: SCALING_IND end type scaling_data_t type(scaling_data_t), INTENT(IN) :: scaling_data_dr #else INTEGER :: LSCALING_RHSINTR_FWD DOUBLE PRECISION :: SCALING_RHSINTR_FWD( LSCALING_RHSINTR_FWD ) #endif LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: LP INTEGER, INTENT(INOUT) :: INFO(2) INTEGER(8), INTENT(OUT):: NB_BYTES_LOC INCLUDE 'mpif.h' INTEGER :: IERR_MPI LOGICAL :: OMP_FLAG !$ INTEGER :: CHUNK, NOMP !$ INTEGER(8) :: CHUNK8 INTEGER :: allocok INTEGER :: MAXRECORDS INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROWSTOSEND INTEGER, ALLOCATABLE, DIMENSION(:) :: NEXTROWTOSEND COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: BUFRECR LOGICAL, ALLOCATABLE, DIMENSION(:) :: IS_SEND_ACTIVE, TOUCHED INTEGER, ALLOCATABLE, DIMENSION(:) :: MPI_REQI, MPI_REQR INTEGER, ALLOCATABLE, DIMENSION(:) :: IRHS_loc_sorted INTEGER :: Iloc INTEGER :: Iloc_sorted INTEGER :: IREQ INTEGER :: IMAP, IPROC_MAX INTEGER :: IFS INTEGER :: MAX_ACTIVE_SENDS INTEGER :: NB_ACTIVE_SENDS INTEGER :: NB_FS_TOUCHED INTEGER :: NBROWSTORECV COMPLEX(kind=8), PARAMETER :: ZERO = (0.0D0, 0.0D0) #if defined(AVOID_MPI_IN_PLACE) INTEGER :: allocoktmp #endif !$ NOMP = OMP_GET_MAX_THREADS() NB_BYTES_LOC = 0_8 ALLOCATE( NBROWSTOSEND (NSLAVES), & NEXTROWTOSEND (NSLAVES), & IRHS_loc_sorted (NRHS_loc), & stat=allocok ) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = NSLAVES+NSLAVES+NRHS_loc ELSE NB_BYTES_LOC = int(2*NSLAVES+NRHS_loc,8)*KEEP(34) ENDIF #if defined(AVOID_MPI_IN_PLACE) allocoktmp=allocok CALL MPI_ALLREDUCE( allocoktmp, allocok, 1, #else CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1, #endif & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI ) IF (allocok .GT. 0) RETURN NBROWSTOSEND(1:NSLAVES) = 0 DO Iloc = 1, NRHS_loc IF (IRHS_loc(Iloc) .GE. 1 .AND. & IRHS_loc(Iloc) .LE. N) THEN IMAP = MAP_RHS_loc(Iloc) NBROWSTOSEND(IMAP+1) = NBROWSTOSEND(IMAP+1)+1 ENDIF ENDDO NEXTROWTOSEND(1)=1 DO IMAP=1, NSLAVES-1 NEXTROWTOSEND(IMAP+1)=NEXTROWTOSEND(IMAP)+NBROWSTOSEND(IMAP) ENDDO NBROWSTOSEND=0 DO Iloc = 1, NRHS_loc IF (IRHS_loc(Iloc) .GE. 1 .AND. & IRHS_loc(Iloc) .LE. N) THEN IMAP = MAP_RHS_loc(Iloc) Iloc_sorted = NEXTROWTOSEND(IMAP+1)+NBROWSTOSEND(IMAP+1) IRHS_loc_sorted(Iloc_sorted) = Iloc NBROWSTOSEND(IMAP+1)=NBROWSTOSEND(IMAP+1)+1 ENDIF ENDDO CALL ZMUMPS_DR_BUILD_NBROWSTORECV() MAX_ACTIVE_SENDS = min(10, NSLAVES) IF (KEEP(72) .EQ.1 ) THEN MAXRECORDS = 15 ELSE MAXRECORDS = min(200000,2000000/NRHS_COL) MAXRECORDS = min(MAXRECORDS, & 50000000 / MAX_ACTIVE_SENDS / NRHS_COL) MAXRECORDS = max(MAXRECORDS, 50) ENDIF ALLOCATE(BUFR(MAXRECORDS*NRHS_COL, & MAX_ACTIVE_SENDS), & MPI_REQI(MAX_ACTIVE_SENDS), & MPI_REQR(MAX_ACTIVE_SENDS), & IS_SEND_ACTIVE(MAX_ACTIVE_SENDS), & BUFRECI(MAXRECORDS), & BUFRECR(MAXRECORDS*NRHS_COL), & TOUCHED(NB_FS_IN_RHSINTR), & stat=allocok) IF (allocok .GT. 0) THEN IF (LP .GT. 0) WRITE(LP, '(A)') & 'Error: Allocation problem in ZMUMPS_SCATTER_DIST_RHS' INFO(1)=-13 INFO(2)=NRHS_COL*MAXRECORDS*MAX_ACTIVE_SENDS+ & 3*MAX_ACTIVE_SENDS+MAXRECORDS*(1+NRHS_COL) & + NB_FS_IN_RHSINTR ENDIF NB_BYTES_LOC=NB_BYTES_LOC + & KEEP(34) * ( int(2*MAX_ACTIVE_SENDS,8) + int(MAXRECORDS,8) ) + & KEEP(34) * (int(MAX_ACTIVE_SENDS,8) + int(NB_FS_IN_RHSINTR,8)) + & KEEP(35) * ( & int( MAXRECORDS,8)*int(NRHS_COL,8)*int(MAX_ACTIVE_SENDS,8) & + int(MAXRECORDS,8) * int(NRHS_COL,8) ) CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1, & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI ) IF (allocok .NE. 0) RETURN NB_ACTIVE_SENDS = 0 DO IREQ = 1, MAX_ACTIVE_SENDS IS_SEND_ACTIVE(IREQ) = .FALSE. ENDDO NB_FS_TOUCHED = 0 DO IFS = 1, NB_FS_IN_RHSINTR TOUCHED(IFS) = .FALSE. ENDDO IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1 DO WHILE (NBROWSTOSEND(IPROC_MAX+1) .NE. 0) IF (IPROC_MAX .EQ. MYID_NODES) THEN CALL ZMUMPS_DR_ASSEMBLE_LOCAL() ELSE CALL ZMUMPS_DR_TRY_SEND(IPROC_MAX) ENDIF CALL ZMUMPS_DR_TRY_RECV() CALL ZMUMPS_DR_TRY_FREE_SEND() IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1 ENDDO DO WHILE ( NBROWSTORECV .NE. 0) CALL ZMUMPS_DR_TRY_RECV() CALL ZMUMPS_DR_TRY_FREE_SEND() ENDDO DO WHILE (NB_ACTIVE_SENDS .NE. 0) CALL ZMUMPS_DR_TRY_FREE_SEND() ENDDO CALL ZMUMPS_DR_EMPTY_ROWS() RETURN CONTAINS SUBROUTINE ZMUMPS_DR_BUILD_NBROWSTORECV() INTEGER :: IPROC DO IPROC = 0, NSLAVES-1 CALL MPI_REDUCE( NBROWSTOSEND(IPROC+1), NBROWSTORECV, & 1, MPI_INTEGER, & MPI_SUM, IPROC, COMM_NODES, IERR_MPI ) ENDDO END SUBROUTINE ZMUMPS_DR_BUILD_NBROWSTORECV SUBROUTINE ZMUMPS_DR_TRY_RECV() IMPLICIT NONE INCLUDE 'mumps_tags.h' INTEGER :: MPI_STATUS(MPI_STATUS_SIZE), MSGSOU INTEGER :: NBRECORDS LOGICAL :: FLAG CALL MPI_IPROBE( MPI_ANY_SOURCE, DistRhsI, COMM_NODES, & FLAG, MPI_STATUS, IERR_MPI ) IF (FLAG) THEN MSGSOU = MPI_STATUS( MPI_SOURCE ) CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER, & NBRECORDS, IERR_MPI) CALL MPI_RECV(BUFRECI(1), NBRECORDS, MPI_INTEGER, & MSGSOU, DistRhsI, & COMM_NODES, MPI_STATUS, IERR_MPI) CALL MPI_RECV(BUFRECR(1), NBRECORDS*NRHS_COL, & MPI_DOUBLE_COMPLEX, & MSGSOU, DistRhsR, & COMM_NODES, MPI_STATUS, IERR_MPI) CALL ZMUMPS_DR_ASSEMBLE_FROM_BUFREC(NBRECORDS, & BUFRECI, BUFRECR) ENDIF RETURN END SUBROUTINE ZMUMPS_DR_TRY_RECV SUBROUTINE ZMUMPS_DR_ASSEMBLE_FROM_BUFREC & (NBRECORDS, BUFRECI_ARG, BUFRECR_ARG) IMPLICIT NONE INTEGER, INTENT(IN) :: NBRECORDS INTEGER, INTENT(INOUT) :: BUFRECI_ARG(NBRECORDS) COMPLEX(kind=8), INTENT(IN) :: BUFRECR_ARG(NBRECORDS, & NRHS_COL) INTEGER :: I, K, IRHSINTR, IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IFIRSTNOTTOUCHED = NBRECORDS+1 ILASTNOTTOUCHED = 0 DO I = 1, NBRECORDS IF (BUFRECI(I) .LE. 0) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_DR_TRY_RECV", & I, BUFRECI(I), BUFRECI(1) CALL MUMPS_ABORT() ENDIF IRHSINTR=POSINRHSINTR_FWD(BUFRECI(I)) BUFRECI_ARG(I)=IRHSINTR IF ( .NOT. TOUCHED(IRHSINTR) ) THEN IFIRSTNOTTOUCHED=min(IFIRSTNOTTOUCHED,I) ILASTNOTTOUCHED=max(ILASTNOTTOUCHED,I) ENDIF ENDDO OMP_FLAG = .FALSE. !$ OMP_FLAG = ( NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(I,IRHSINTR) DO K = 1, NRHS_COL DO I = IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IRHSINTR=BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSINTR)) THEN RHSINTR(IRHSINTR,K)=ZERO ENDIF ENDDO #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO I = 1, NBRECORDS IRHSINTR=BUFRECI_ARG(I) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & SCALING_RHSINTR_FWD(IRHSINTR) * & BUFRECR_ARG(I,K) ENDDO ELSE #endif DO I = 1, NBRECORDS IRHSINTR=BUFRECI_ARG(I) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & BUFRECR_ARG(I,K) ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif ENDDO !$OMP END PARALLEL DO ELSE DO K = 1, NRHS_COL DO I = IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IRHSINTR=BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSINTR)) THEN RHSINTR(IRHSINTR,K)=ZERO ENDIF ENDDO #if ! defined(USE_OLD_SCALING) IF ( LSCAL ) THEN DO I = 1, NBRECORDS IRHSINTR=BUFRECI_ARG(I) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & SCALING_RHSINTR_FWD(IRHSINTR) * & BUFRECR_ARG(I,K) ENDDO ELSE #endif DO I = 1, NBRECORDS IRHSINTR=BUFRECI_ARG(I) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & BUFRECR_ARG(I,K) ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif ENDDO ENDIF DO I = 1, NBRECORDS IRHSINTR = BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSINTR)) THEN NB_FS_TOUCHED = NB_FS_TOUCHED + 1 TOUCHED(IRHSINTR) = .TRUE. ENDIF ENDDO NBROWSTORECV = NBROWSTORECV - NBRECORDS RETURN END SUBROUTINE ZMUMPS_DR_ASSEMBLE_FROM_BUFREC SUBROUTINE ZMUMPS_DR_ASSEMBLE_LOCAL() INTEGER :: NBRECORDS, I, K, IFIRSTNOTTOUCHED INTEGER :: Iloc INTEGER :: Iglob INTEGER :: IRHSINTR INTEGER(8) :: ISHIFT IF ( NBROWSTOSEND(MYID_NODES+1) .EQ. 0) THEN WRITE(*,*) "Internal error in ZMUMPS_DR_ASSEMBLE_LOCAL" CALL MUMPS_ABORT() ENDIF NBRECORDS=min(MAXRECORDS, NBROWSTOSEND(MYID_NODES+1)) IFIRSTNOTTOUCHED=NBRECORDS+1 DO I = 1, NBRECORDS IRHSINTR = POSINRHSINTR_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSINTR)) THEN IFIRSTNOTTOUCHED=I EXIT ENDIF ENDDO IF (LSCAL) THEN !$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSINTR, Iloc, Iglob) !$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG) DO K = 1, NRHS_COL ISHIFT = int(K-1,8) * int(LRHS_loc,8) DO I = IFIRSTNOTTOUCHED, NBRECORDS IRHSINTR = POSINRHSINTR_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSINTR)) THEN RHSINTR(IRHSINTR,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1) Iglob = IRHS_loc(Iloc) IRHSINTR = POSINRHSINTR_FWD(Iglob) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K)+ & RHS_loc(Iloc+ISHIFT)* #if defined(USE_OLD_SCALING) & scaling_data_dr%SCALING_LOC(Iloc) #else & SCALING_RHSINTR_FWD(IRHSINTR) #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSINTR, Iloc, Iglob) !$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG) DO K = 1, NRHS_COL ISHIFT = int(K-1,8) * int(LRHS_loc,8) DO I = IFIRSTNOTTOUCHED, NBRECORDS IRHSINTR = POSINRHSINTR_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSINTR)) THEN RHSINTR(IRHSINTR,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1) Iglob = IRHS_loc(Iloc) IRHSINTR = POSINRHSINTR_FWD(Iglob) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & RHS_loc(Iloc+ISHIFT) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF DO I = 1, NBRECORDS IRHSINTR = POSINRHSINTR_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSINTR)) THEN NB_FS_TOUCHED = NB_FS_TOUCHED + 1 TOUCHED(IRHSINTR) = .TRUE. ENDIF ENDDO NEXTROWTOSEND(MYID_NODES+1)=NEXTROWTOSEND(MYID_NODES+1)+ & NBRECORDS NBROWSTOSEND(MYID_NODES+1)=NBROWSTOSEND(MYID_NODES+1)- & NBRECORDS NBROWSTORECV = NBROWSTORECV - NBRECORDS RETURN END SUBROUTINE ZMUMPS_DR_ASSEMBLE_LOCAL SUBROUTINE ZMUMPS_DR_GET_NEW_BUF( IBUF ) INTEGER, INTENT(OUT) :: IBUF INTEGER :: I IBUF = -1 IF (NB_ACTIVE_SENDS .NE. MAX_ACTIVE_SENDS) THEN DO I=1, MAX_ACTIVE_SENDS IF (.NOT. IS_SEND_ACTIVE(I)) THEN IBUF = I EXIT ENDIF ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_DR_GET_NEW_BUF SUBROUTINE ZMUMPS_DR_TRY_FREE_SEND() INTEGER :: MPI_STATUS(MPI_STATUS_SIZE) INTEGER :: I LOGICAL :: FLAG IF (NB_ACTIVE_SENDS .GT. 0) THEN DO I=1, MAX_ACTIVE_SENDS IF (IS_SEND_ACTIVE(I)) THEN CALL MPI_TEST( MPI_REQR(I), FLAG, MPI_STATUS, IERR_MPI ) IF (FLAG) THEN CALL MPI_WAIT(MPI_REQI(I), MPI_STATUS, IERR_MPI) NB_ACTIVE_SENDS = NB_ACTIVE_SENDS - 1 IS_SEND_ACTIVE(I)=.FALSE. IF (NB_ACTIVE_SENDS .EQ. 0) THEN RETURN ENDIF ENDIF ENDIF ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_DR_TRY_FREE_SEND SUBROUTINE ZMUMPS_DR_TRY_SEND(IPROC_ARG) IMPLICIT NONE INTEGER, INTENT(IN) :: IPROC_ARG INCLUDE 'mumps_tags.h' INTEGER :: NBRECORDS, IBUF, I, K INTEGER(8) :: IPOSRHS INTEGER :: IPOSBUF IF (IPROC_ARG .EQ. MYID_NODES) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_DR_TRY_SEND" CALL MUMPS_ABORT() ENDIF IF (NBROWSTOSEND(IPROC_ARG+1) .EQ. 0) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_DR_TRY_SEND" CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_DR_GET_NEW_BUF(IBUF) IF (IBUF .GT. 0) THEN NBRECORDS = min(MAXRECORDS,NBROWSTOSEND(IPROC_ARG+1)) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS_COL*NBRECORDS !$ IF (CHUNK .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((CHUNK+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF IF (LSCAL) THEN !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) !$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG) DO K=1, NRHS_COL DO I = 1, NBRECORDS IPOSBUF = (K-1)*NBRECORDS IPOSRHS = int(K-1,8)*int(LRHS_loc,8) Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) BUFR( IPOSBUF + I, IBUF ) & = RHS_loc( IPOSRHS + Iloc ) #if defined(USE_OLD_SCALING) & * scaling_data_dr%SCALING_LOC(Iloc) #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) !$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG) DO K=1, NRHS_COL DO I = 1, NBRECORDS IPOSBUF = (K-1)*NBRECORDS IPOSRHS = int(K-1,8)*int(LRHS_loc,8) Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) BUFR( IPOSBUF + I, IBUF ) & = RHS_loc( IPOSRHS + Iloc ) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) & = IRHS_loc(Iloc) ENDDO CALL MPI_ISEND( IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)), & NBRECORDS, MPI_INTEGER, IPROC_ARG, DistRhsI, & COMM_NODES, MPI_REQI(IBUF), IERR_MPI ) CALL MPI_ISEND( BUFR(1,IBUF), NBRECORDS*NRHS_COL, & MPI_DOUBLE_COMPLEX, & IPROC_ARG, DistRhsR, & COMM_NODES, MPI_REQR(IBUF), IERR_MPI ) NEXTROWTOSEND(IPROC_ARG+1)=NEXTROWTOSEND(IPROC_ARG+1)+ & NBRECORDS NBROWSTOSEND(IPROC_ARG+1)=NBROWSTOSEND(IPROC_ARG+1)-NBRECORDS NB_ACTIVE_SENDS = NB_ACTIVE_SENDS + 1 IS_SEND_ACTIVE(IBUF)=.TRUE. ENDIF RETURN END SUBROUTINE ZMUMPS_DR_TRY_SEND SUBROUTINE ZMUMPS_DR_EMPTY_ROWS() INTEGER :: K, IFS IF ( NB_FS_TOUCHED .NE. NB_FS_IN_RHSINTR ) THEN !$ OMP_FLAG = (NRHS_COL .GE. KEEP(362)) .AND. !$ & (NRHS_COL*NB_FS_IN_RHSINTR > KEEP(363)/2) !$OMP PARALLEL DO FIRSTPRIVATE(NB_FS_IN_RHSINTR) !$OMP& PRIVATE(IFS) IF (OMP_FLAG) DO K = 1, NRHS_COL DO IFS = 1, NB_FS_IN_RHSINTR IF ( .NOT. TOUCHED(IFS) ) THEN RHSINTR( IFS, K) = ZERO ENDIF ENDDO DO IFS = NB_FS_IN_RHSINTR +1, LD_RHSINTR RHSINTR (IFS, K) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$ OMP_FLAG = .FALSE. !$ CHUNK8 = int(NRHS_COL,8)*int(LD_RHSINTR-NB_FS_IN_RHSINTR,8) !$ CHUNK8 = max(CHUNK8,1_8) !$ IF (CHUNK8 .GE. int(KEEP(363),8)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK8 = max((CHUNK8+NOMP-1)/NOMP,int(KEEP(363)/2,8)) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK8) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS_COL DO IFS = NB_FS_IN_RHSINTR +1, LD_RHSINTR RHSINTR (IFS, K) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE ZMUMPS_DR_EMPTY_ROWS END SUBROUTINE ZMUMPS_SCATTER_DIST_RHS SUBROUTINE ZMUMPS_SOL_INIT_IRHS_loc(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE (ZMUMPS_STRUC) :: id INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ROW_OR_COL_INDICES INTEGER :: IERR_MPI LOGICAL :: I_AM_SLAVE INTEGER, POINTER :: idIRHS_loc(:) INTEGER, POINTER :: UNS_PERM(:) INTEGER :: UNS_PERM_TO_BE_DONE, I, allocok INTEGER, TARGET :: IDUMMY(1) INCLUDE 'mpif.h' NULLIFY(UNS_PERM) IF (id%JOB .NE. 9) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_SOL_INIT_IRHS_loc" CALL MUMPS_ABORT() ENDIF I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (id%MYID .EQ. MASTER) THEN IF (id%KEEP(50).NE.0) THEN ROW_OR_COL_INDICES = 0 ELSE IF (id%ICNTL(20).EQ.10 .OR. id%KEEP(50).EQ.0) THEN ROW_OR_COL_INDICES = 0 ELSE IF (id%ICNTL(20).EQ.11) THEN ROW_OR_COL_INDICES = 1 ELSE ROW_OR_COL_INDICES = 0 ENDIF IF (id%ICNTL(9) .NE. 1) THEN ROW_OR_COL_INDICES = 1 - ROW_OR_COL_INDICES ENDIF ENDIF IF (id%KEEP(23).NE.0 .AND. id%ICNTL(9) .NE.1) THEN UNS_PERM_TO_BE_DONE = 1 ELSE UNS_PERM_TO_BE_DONE = 0 ENDIF ENDIF CALL MPI_BCAST(ROW_OR_COL_INDICES,1,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) CALL MPI_BCAST(UNS_PERM_TO_BE_DONE,1,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) IF ( I_AM_SLAVE ) THEN IF (id%KEEP(89) .GT. 0) THEN IF (.NOT. associated(id%IRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=17 ELSE IF (size(id%IRHS_loc) < id%KEEP(89) ) THEN id%INFO(1)=-22 id%INFO(2)=17 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) goto 500 IF (I_AM_SLAVE) THEN IF (associated(id%IRHS_loc)) THEN IF (size(id%IRHS_loc) .GT. 0) THEN idIRHS_loc => id%IRHS_loc ELSE idIRHS_loc => IDUMMY ENDIF ELSE idIRHS_loc => IDUMMY ENDIF CALL MUMPS_GET_INDICES & (id%MYID_NODES, id%NSLAVES, id%N, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), id%IS(1), & max(1, id%KEEP(32)), & id%STEP(1), id%PROCNODE_STEPS(1), idIRHS_loc(1), & ROW_OR_COL_INDICES) ENDIF IF (UNS_PERM_TO_BE_DONE .EQ. 1) THEN IF (id%MYID.NE.MASTER) THEN ALLOCATE(UNS_PERM(id%N),stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=id%N GOTO 100 ENDIF ENDIF 100 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) GOTO 500 IF ( id%MYID .EQ. MASTER ) THEN UNS_PERM => id%UNS_PERM ENDIF CALL MPI_BCAST(UNS_PERM(1),id%N,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) IF (I_AM_SLAVE .AND. id%KEEP(89) .NE.0) THEN DO I=1, id%KEEP(89) id%IRHS_loc(I)=UNS_PERM(id%IRHS_loc(I)) ENDDO ENDIF ENDIF 500 CONTINUE IF (id%MYID.NE.MASTER) THEN IF (associated(UNS_PERM)) DEALLOCATE(UNS_PERM) ENDIF NULLIFY(UNS_PERM) RETURN END SUBROUTINE ZMUMPS_SOL_INIT_IRHS_loc MUMPS_5.8.1/src/cana_dist_m.F0000664000175000017500000040620415042446440015606 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ANA_COMPUTE_ESTIMATES ( id, idintr ) USE CMUMPS_STRUC_DEF, ONLY: CMUMPS_STRUC USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_INTR_STRUC USE MUMPS_ANA_OMP_M, ONLY: MUMPS_ANA_L0_OMP IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR, MASTER PARAMETER( MASTER = 0 ) TYPE(CMUMPS_STRUC), TARGET :: id TYPE(CMUMPS_INTR_STRUC) :: idintr INTEGER, DIMENSION(:), POINTER :: KEEP, INFO, INFOG INTEGER :: allocok INTEGER(8), DIMENSION(:), POINTER :: KEEP8 REAL, DIMENSION(:), POINTER :: RINFO REAL, DIMENSION(:), POINTER :: RINFOG INTEGER, DIMENSION(:), POINTER :: ICNTL INTEGER IRANK INTEGER :: LP, MP, MPG LOGICAL :: PROK, PROKG, LPOK LOGICAL :: I_AM_SLAVE, PERLU_ON, PRINT_MAXAVG LOGICAL :: SUM_OF_PEAKS, PRINT_NODEINFO INTEGER :: TOTAL_MBYTES_UNDER_L0 INTEGER(8) :: TOTAL_BYTES_UNDER_L0 INTEGER :: NBSTATS_I4, NBSTATS_I8 PARAMETER (NBSTATS_I4=4, NBSTATS_I8=24) INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: TNSTK_afterL0 INTEGER, ALLOCATABLE, DIMENSION(:) :: FLAGGED_LEAVES INTEGER(8) :: PEAK_UNDER_L0, PEAK_ABOVE_L0 INTEGER(8) :: SUM_NRLADU, MAX_NRLADU, MIN_NRLADU, & SUM_NRLADU_if_LR_LU, & SUM_NRLADULR_UD, SUM_NRLADULR_WC, & SUM_NRLNEC, SUM_NRLNEC_ACTIVE, & MIN_NRLNEC INTEGER :: SUM_NIRADU, & SUM_NIRADU_OOC, & SUM_NIRNEC, SUM_NIRNEC_OOC INTEGER :: LIPOOL_local INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: IPOOL INTEGER :: I, LIPOOL INTEGER(4) :: I4 INTEGER, POINTER, DIMENSION(:) :: NE_STEPSPTR INTEGER, POINTER, DIMENSION(:) :: IPOOLPTR LOGICAL :: BDUMMY INTEGER(8) :: K8_33relaxed, K8_34relaxed, K8_35relaxed, & K8_50relaxed INTEGER(8) :: ENTRIES_IN_FACTORS_LOC_MASTERS INTEGER :: OOC_STRAT, BLR_STRAT, IDUMMY, ISTEP, NBNODES_BLR INTEGER(8) :: TOTAL_BYTES, ITMP8 INTEGER(8) :: MAX_FRONT_SURFACE_LOCAL_L0, & MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO INTEGER :: MAXFR_UNDER_L0 DOUBLE PRECISION :: COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0 INTEGER(8):: SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB LOGICAL :: ABOVE_L0 INTEGER :: locMYID_NODES LOGICAL, POINTER :: locI_AM_CAND(:) INTEGER LOCAL_M, LOCAL_N INTEGER, EXTERNAL :: MUMPS_NUMROC INTEGER SBUF_SEND_FR, SBUF_REC_FR INTEGER SBUF_SEND_LR, SBUF_REC_LR INTEGER TOTAL_MBYTES INTEGER(8) SUM_KEEP811_THIS_NODE, MAX_SUM_KEEP811_THIS_NODE INTEGER SUM_INFO15_THIS_NODE, MAX_SUM_INFO15_THIS_NODE INTEGER SUM_INFO17_THIS_NODE, MAX_SUM_INFO17_THIS_NODE INTEGER(8) SBUF_RECOLD8, MIN_BUF_SIZE8 LOGICAL UPDATE_BUFFER INTEGER MIN_BUF_SIZE, SIZE_DESC_BANDE, & MaxBlocSize_FR, MaxBlocSize_BLR, & MIN_BUF_SIZE_FR, MIN_BUF_SIZE_BLR INTEGER(8) MAX_SIZE_FACTOR_TMP, KEEP26_I8_TMP KEEP => id%KEEP KEEP8 => id%KEEP8 INFO => id%INFO RINFO => id%RINFO INFOG => id%INFOG RINFOG => id%RINFOG ICNTL => id%ICNTL LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) PRINT_NODEINFO = PRINT_MAXAVG .AND. id%NPROCS .NE. id%KEEP(412) IDUMMY = 1 BDUMMY = .FALSE. IF ( I_AM_SLAVE ) THEN locI_AM_CAND => id%I_AM_CAND locMYID_NODES = id%MYID_NODES IF ( idintr%root%yes ) THEN LOCAL_M = MUMPS_NUMROC( & id%ND_STEPS(id%STEP(KEEP(38))), & idintr%root%MBLOCK, idintr%root%MYROW, 0, & idintr%root%NPROW ) LOCAL_M = max(1, LOCAL_M) LOCAL_N = MUMPS_NUMROC( & id%ND_STEPS(id%STEP(KEEP(38))), & idintr%root%NBLOCK, idintr%root%MYCOL, 0, & idintr%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 idintr%root%SCHUR_MLOC=LOCAL_M idintr%root%SCHUR_NLOC=LOCAL_N ENDIF IF ( .NOT. associated(id%CANDIDATES)) THEN ALLOCATE(id%CANDIDATES(id%NSLAVES+1,1), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF INFO(1)= -7 INFO(2)= id%NSLAVES+1 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF (KEEP(400) .GT. 0 ) THEN IF ( I_AM_SLAVE ) THEN CALL MUMPS_ANA_L0_OMP( & KEEP(400), id%N, KEEP(28), & KEEP(50), id%NSLAVES, id%DAD_STEPS, id%FRERE_STEPS, & id%FILS, id%NE_STEPS, id%ND_STEPS, id%STEP, & id%PROCNODE_STEPS, KEEP, KEEP8, locMYID_NODES, & id%NA, id%LNA, "CMUMPS"(1:1), & id%LPOOL_B_L0_OMP, id%IPOOL_B_L0_OMP, & id%LPOOL_A_L0_OMP, id%IPOOL_A_L0_OMP, & id%L_VIRT_L0_OMP,id%VIRT_L0_OMP, id%VIRT_L0_OMP_MAPPING, & id%L_PHYS_L0_OMP,id%PHYS_L0_OMP, id%PERM_L0_OMP, & id%PTR_LEAFS_L0_OMP, & id%INFO, id%ICNTL) IF (id%INFO(1) .GE. 0) THEN ALLOCATE( & id%I4_L0_OMP(NBSTATS_I4, KEEP(400)), & id%I8_L0_OMP(NBSTATS_I8, KEEP(400)), & TNSTK_afterL0(KEEP(28)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'L0_OMP stats' END IF INFO(1)= -7 INFO(2)= NBSTATS_I4* KEEP(400) + & NBSTATS_I8* KEEP(400)*KEEP(10) & + KEEP(28) ENDIF ENDIF ELSE ALLOCATE(id%I4_L0_OMP(1,1), id%I8_L0_OMP(1,1), stat=allocok) IF (allocok.gt.0) THEN INFO(1)= -7 INFO(2)= 2 ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN CALL CMUMPS_ANA_DISTM_UNDERL0OMP( & id%LPOOL_B_L0_OMP, id%IPOOL_B_L0_OMP(1), & id%L_VIRT_L0_OMP, & id%VIRT_L0_OMP(1), id%VIRT_L0_OMP_MAPPING(1), & id%L_PHYS_L0_OMP, id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1), & id%PTR_LEAFS_L0_OMP(1), & id%KEEP(1), id%N, id%NE_STEPS(1), id%STEP(1), & id%FRERE_STEPS(1), id%FILS(1), id%DAD_STEPS(1), & id%ND_STEPS(1), & locMYID_NODES, id%PROCNODE_STEPS(1), & id%I4_L0_OMP(1,1), NBSTATS_I4, & id%I8_L0_OMP(1,1), NBSTATS_I8, KEEP(400), & SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB, & TNSTK_afterL0, MAXFR_UNDER_L0, & MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0, NBNODES_BLR, & INFO(1), INFO(2) & ) CALL MPI_ALLREDUCE (NBNODES_BLR, KEEP(470), 1, & MPI_INTEGER, MPI_SUM, id%COMM_NODES, IERR) ENDIF ELSE IF ( I_AM_SLAVE ) THEN id%LPOOL_B_L0_OMP = 1 id%LPOOL_A_L0_OMP = 1 id%L_VIRT_L0_OMP = 1 id%L_PHYS_L0_OMP = 1 id%THREAD_LA = -1_8 ALLOCATE ( id%VIRT_L0_OMP ( id%L_VIRT_L0_OMP ), & id%VIRT_L0_OMP_MAPPING ( id%L_VIRT_L0_OMP ), & id%PERM_L0_OMP ( id%L_PHYS_L0_OMP ), & id%PTR_LEAFS_L0_OMP ( id%L_PHYS_L0_OMP + 1 ), & id%IPOOL_B_L0_OMP ( id%LPOOL_B_L0_OMP ), & id%IPOOL_A_L0_OMP ( id%LPOOL_A_L0_OMP ), & id%PHYS_L0_OMP( id%L_PHYS_L0_OMP ), & id%I4_L0_OMP(1,1), id%I8_L0_OMP(1,1), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'Allocation error in multicore' END IF INFO(1)= -7 INFO(2)= id%L_VIRT_L0_OMP & + id%L_PHYS_L0_OMP & + id%L_PHYS_L0_OMP + 1 & + id%LPOOL_B_L0_OMP & + id%LPOOL_A_L0_OMP & + id%L_PHYS_L0_OMP + 1 + KEEP(10) ENDIF ELSE ALLOCATE(id%I4_L0_OMP(1,1), id%I8_L0_OMP(1,1), stat=allocok) IF (allocok.gt.0) THEN INFO(1)= -7 INFO(2)= 2 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN IF (KEEP(400).GT.0) THEN IF (id%NSLAVES .GT.1) THEN ALLOCATE (FLAGGED_LEAVES(KEEP(28)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'L0_OMP FLAGGED LEAVES' END IF INFO(1)= -7 INFO(2)= KEEP(28) ENDIF ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN IF (KEEP(400).GT.0) THEN IF (id%NSLAVES .GT.1) THEN LIPOOL_local= & id%IPOOL_A_L0_OMP(id%LPOOL_A_L0_OMP) CALL CMUMPS_PREP_ANA_DISTM_ABOVEL0( & id%N, id%NSLAVES, id%COMM_NODES, id%MYID_NODES, & id%STEP(1), id%DAD_STEPS(1),id%ICNTL,LP,LPOK, & id%INFO, & id%PHYS_L0_OMP(1), id%L_PHYS_L0_OMP, & id%IPOOL_A_L0_OMP(1), LIPOOL_local, & id%KEEP, TNSTK_afterL0, & FLAGGED_LEAVES & ) IF ( INFO(1).LT.0 ) GOTO 75 LIPOOL= 0 DO ISTEP=1,KEEP(28) IF (FLAGGED_LEAVES(ISTEP).GT.0) LIPOOL=LIPOOL+1 ENDDO ALLOCATE( IPOOL(max(LIPOOL,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'Allocation IPOOL' END IF INFO(1)= -7 INFO(2)= LIPOOL ENDIF ELSE LIPOOL = id%IPOOL_A_L0_OMP(id%LPOOL_A_L0_OMP) ENDIF ELSE LIPOOL = id%NA(1) ENDIF ENDIF 75 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN IF (KEEP(400) .GT. 0 ) THEN IF (id%NSLAVES .GT.1) THEN IF (LIPOOL .GT.0) THEN I =LIPOOL DO ISTEP=1, KEEP(28) IF (FLAGGED_LEAVES(ISTEP).GT.0) THEN IPOOL(I) = FLAGGED_LEAVES(ISTEP) I=I-1 ENDIF IF (I.EQ.0) EXIT ENDDO ENDIF DEALLOCATE(FLAGGED_LEAVES) IPOOLPTR => IPOOL ELSE IPOOLPTR => id%IPOOL_A_L0_OMP ENDIF ABOVE_L0 =.TRUE. NE_STEPSPTR => TNSTK_afterL0(1:KEEP(28)) ELSE IPOOLPTR => id%NA(3:3+max(LIPOOL,1)-1) ABOVE_L0 =.FALSE. SIZECB_UNDER_L0 = 0_8 SIZECB_UNDER_L0_IF_LRCB = 0_8 MAX_FRONT_SURFACE_LOCAL_L0 = 0_8 MAX_SIZE_FACTOR_L0 = 0_8 ENTRIES_IN_FACTORS_UNDER_L0= 0_8 ENTRIES_IN_FACTORS_MASTERS_LO = 0_8 MAXFR_UNDER_L0 = 0 COST_SUBTREES_UNDER_L0 = 0.0D0 OPSA_UNDER_L0 = 0.0D0 NE_STEPSPTR => id%NE_STEPS ENDIF KEEP(139) = MAXFR_UNDER_L0 CALL CMUMPS_ANA_DISTM( locMYID_NODES, id%N, id%STEP(1), & id%FRERE_STEPS(1), id%FILS(1), IPOOLPTR(1), LIPOOL, NE_STEPSPTR & (1), id%DAD_STEPS(1), id%ND_STEPS(1), id%PROCNODE_STEPS(1), & id%NSLAVES, ABOVE_L0,SIZECB_UNDER_L0,SIZECB_UNDER_L0_IF_LRCB, & MAXFR_UNDER_L0, MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0, KEEP8(53), KEEP8(54), & KEEP8(11), KEEP(26), KEEP(15), KEEP8(12), KEEP8(14), & KEEP8(32), KEEP8(33), KEEP8(34), KEEP8(35), KEEP8(50), & KEEP8(36), KEEP8(47), KEEP8(37), KEEP8(38), KEEP8(39), & KEEP8(40), KEEP8(41), KEEP8(42), KEEP8(43), KEEP8(44), KEEP8(45), & KEEP8(46), KEEP8(51), KEEP8(52), KEEP(224),KEEP(225),KEEP(27), & RINFO(1),id%CNTL(1), KEEP(1), KEEP8(1), LOCAL_M, LOCAL_N, & SBUF_RECOLD8, SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR, & SBUF_REC_LR, id%COST_SUBTREES, KEEP(28), locI_AM_CAND(1), & max(KEEP(56),1), id%ISTEP_TO_INIV2(1), id%CANDIDATES(1,1), & INFO(1), INFO(2), KEEP8(15),MAX_SIZE_FACTOR_TMP, & KEEP8(9), ENTRIES_IN_FACTORS_LOC_MASTERS, & idintr%root%yes, idintr%root%NPROW, idintr%root%NPCOL & ) IF (ALLOCATED(IPOOL)) DEALLOCATE(IPOOL) NULLIFY(NE_STEPSPTR,IPOOLPTR) IF (KEEP(400) .GT. 0) THEN DEALLOCATE (TNSTK_afterL0) SUM_NIRNEC = 0 SUM_NIRADU = 0 SUM_NIRADU_OOC = 0 SUM_NIRNEC_OOC = 0 DO I=1, KEEP(400) SUM_NIRADU = SUM_NIRADU + id%I4_L0_OMP(1,I) SUM_NIRNEC = SUM_NIRNEC + id%I4_L0_OMP(2,I) SUM_NIRADU_OOC = SUM_NIRADU_OOC+ id%I4_L0_OMP(3,I) SUM_NIRNEC_OOC = SUM_NIRNEC_OOC+ id%I4_L0_OMP(4,I) ENDDO KEEP(26) = KEEP(26) + SUM_NIRADU KEEP(224) = KEEP(224) + SUM_NIRADU_OOC KEEP(15) = max(KEEP(15),KEEP(26)) KEEP(225) = max(KEEP(225),KEEP(224)) KEEP(137) = SUM_NIRNEC KEEP(138) = SUM_NIRNEC_OOC SUM_NIRNEC = int( & (REAL(SUM_NIRNEC)*REAL(KEEP(34)))/REAL(KEEP(35)) & ) SUM_NIRNEC_OOC = int( & (REAL(SUM_NIRNEC_OOC)*REAL(KEEP(34)))/REAL(KEEP(35)) & ) MAX_NRLADU = 0_8 MIN_NRLADU = id%I8_L0_OMP(1,1) SUM_NRLADU = 0_8 SUM_NRLNEC = 0_8 MIN_NRLNEC = huge(MIN_NRLNEC) SUM_NRLNEC_ACTIVE = 0_8 SUM_NRLADU_if_LR_LU = 0_8 SUM_NRLADULR_UD = 0_8 SUM_NRLADULR_WC = 0_8 DO I=1, KEEP(400) MIN_NRLADU = min(MIN_NRLADU, id%I8_L0_OMP(1,I)) MAX_NRLADU = max(MAX_NRLADU, id%I8_L0_OMP(1,I)) SUM_NRLADU = SUM_NRLADU + id%I8_L0_OMP(1,I) SUM_NRLNEC = SUM_NRLNEC + id%I8_L0_OMP(2,I) MIN_NRLNEC = min(MIN_NRLNEC, id%I8_L0_OMP(2,I)) SUM_NRLNEC_ACTIVE = SUM_NRLNEC_ACTIVE + & id%I8_L0_OMP(3,I) SUM_NRLADU_if_LR_LU = SUM_NRLADU_if_LR_LU + & id%I8_L0_OMP(4,I) SUM_NRLADULR_UD = SUM_NRLADULR_UD + & id%I8_L0_OMP(9,I) SUM_NRLADULR_WC = SUM_NRLADULR_WC + & id%I8_L0_OMP(10,I) ENDDO KEEP8(81) = KEEP8(11) KEEP8(11) = KEEP8(11) + SUM_NRLADU KEEP8(82) = KEEP8(32) KEEP8(32) = KEEP8(32) + SUM_NRLADU_if_LR_LU PEAK_UNDER_L0 = SUM_NRLNEC + MIN_NRLNEC + & int( & (real(id%N*KEEP(400))*real(KEEP(34)))/real(KEEP(35)), & 8) PEAK_ABOVE_L0 = KEEP8(53)+ SUM_NRLADU + & & max( int(SBUF_SEND_FR,8), 100000_8) + & & int( & (real(KEEP(15))*real(KEEP(34)))/real(KEEP(35)), & 8) KEEP8(53) = KEEP8(53)+ SUM_NRLADU KEEP8(40) = KEEP8(40)+ & SUM_NRLADU_if_LR_LU + SUM_NRLADULR_UD KEEP8(41) = KEEP8(41)+ SUM_NRLADULR_UD KEEP8(42) = KEEP8(42)+ SUM_NRLADULR_WC KEEP8(43) = KEEP8(43)+ & SUM_NRLADU_if_LR_LU + SUM_NRLADULR_UD KEEP8(44) = KEEP8(44)+ & SUM_NRLADU_if_LR_LU + SUM_NRLADULR_WC KEEP8(45) = KEEP8(45)+ SUM_NRLADULR_UD KEEP8(46) = KEEP8(46)+ SUM_NRLADULR_WC KEEP8(51) = KEEP8(51)+ SUM_NRLADU KEEP8(52) = KEEP8(52)+ SUM_NRLADULR_UD ELSE KEEP(137)=0 KEEP(138)=0 ENDIF id%DKEEP(15) = RINFO(1)/1000000.0E0 IF(ASSOCIATED(locI_AM_CAND)) NULLIFY(locI_AM_CAND) id%MAX_SURF_MASTER = KEEP8(15) KEEP8(19)=MAX_SIZE_FACTOR_TMP KEEP( 29 ) = KEEP(15) + 3* max(KEEP(12),10) & * ( KEEP(15) / 100 + 1) INFO( 19 ) = KEEP(225) + 3* 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) K8_33relaxed = KEEP8(33) + int(KEEP(12),8) * & ( KEEP8(33) /100_8 +1_8) K8_34relaxed = KEEP8(34) + int(KEEP(12),8) * & ( KEEP8(34) /100_8 +1_8) K8_35relaxed = KEEP8(35) + int(KEEP(12),8) * & ( KEEP8(35) /100_8 +1_8) K8_50relaxed = KEEP8(50) + int(KEEP(12),8) * & ( KEEP8(50) /100_8 +1_8) CALL MUMPS_ALLREDUCEI8 ( SBUF_RECOLD8, KEEP8(22), MPI_MAX, & id%COMM_NODES ) IF ( (id%NSLAVES.GT.1) & ) THEN SBUF_SEND_FR = max(SBUF_SEND_FR,KEEP(27)) SBUF_SEND_LR = max(SBUF_SEND_LR,KEEP(27)) SBUF_REC_FR = max(SBUF_REC_FR ,KEEP(27)) SBUF_REC_LR = max(SBUF_REC_LR ,KEEP(27)) ENDIF CALL MPI_ALLREDUCE (SBUF_REC_FR, KEEP(44), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) CALL MPI_ALLREDUCE (SBUF_REC_LR, KEEP(380), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) IF (KEEP(48)==5) THEN KEEP(43) = KEEP(44) KEEP(379) = KEEP(380) ELSE KEEP(43)=SBUF_SEND_FR KEEP(379)=SBUF_SEND_LR ENDIF UPDATE_BUFFER = .TRUE. MIN_BUF_SIZE8 = KEEP8(22) / int(KEEP(238),8) MIN_BUF_SIZE8 = min(MIN_BUF_SIZE8, & int(huge(I4),8)/int(KEEP(35),8) ) MIN_BUF_SIZE = max(int( MIN_BUF_SIZE8 ), KEEP(127)) SIZE_DESC_BANDE=(11+id%NSLAVES+KEEP(127)*2) MaxBlocSize_FR = min (KEEP(420), KEEP(127)) MaxBlocSize_FR = MaxBlocSize_FR*MaxBlocSize_FR MaxBlocSize_BLR = min (KEEP(142), KEEP(127)) MaxBlocSize_BLR = MaxBlocSize_BLR*MaxBlocSize_BLR MIN_BUF_SIZE_FR = MIN_BUF_SIZE MIN_BUF_SIZE_BLR = MIN_BUF_SIZE MIN_BUF_SIZE_FR = min ( MIN_BUF_SIZE_FR, & int ( min ( & real(KEEP(44)) * & (real(abs(KEEP(180))) / real(100)) , & real (huge(I4))/real(KEEP(35)) & ) ) & ) MIN_BUF_SIZE_BLR = min ( MIN_BUF_SIZE_BLR, & int ( min ( & real(KEEP(44)) * & (real(abs(KEEP(181))) / real(100)) , & real (huge(I4))/real(KEEP(35)) & ) ) & ) IF (KEEP(50).EQ.0) THEN KEEP(43) = max( & min(KEEP(43),MaxBlocSize_FR*max(KEEP(171),3)), & int(KEEP(43)/KEEP(172)) ) KEEP(44) = max( & min(KEEP(44), MaxBlocSize_FR*max(KEEP(171),3)), & int(KEEP(44)/KEEP(172)) ) ELSE KEEP(43) = max( & min(KEEP(43),MaxBlocSize_FR*max(KEEP(171),3)), & int((KEEP(43)*KEEP(178))/KEEP(172)) ) KEEP(44) = max( & min(KEEP(44), MaxBlocSize_FR*max(KEEP(171),3)), & int((KEEP(44)*KEEP(178))/KEEP(172)) ) ENDIF KEEP(379) = max( & min(KEEP(379), MaxBlocSize_BLR*max(KEEP(171),3)), & int(KEEP(379)/KEEP(172)) ) KEEP(380) = max( & min(KEEP(380),MaxBlocSize_BLR*max(KEEP(171),3)), & int(KEEP(380)/KEEP(172)) ) IF (UPDATE_BUFFER) THEN KEEP(43) = max(KEEP(43),MIN_BUF_SIZE_FR) + & (SIZE_DESC_BANDE * KEEP(34))/KEEP(35) KEEP(379)= max(KEEP(379),MIN_BUF_SIZE_BLR)+ & (SIZE_DESC_BANDE * KEEP(34))/KEEP(35) ENDIF IF ( (KEEP(38).NE.0) .OR. UPDATE_BUFFER) THEN KEEP(44) = max(KEEP(44),MIN_BUF_SIZE_FR) + & (SIZE_DESC_BANDE * KEEP(34))/KEEP(35) KEEP(380)= max(KEEP(380),MIN_BUF_SIZE_BLR)+ & (SIZE_DESC_BANDE * KEEP(34))/KEEP(35) ENDIF IF ( int(KEEP(43),8)*int(KEEP(35),8) .GE. & int(huge(I4)-100,8)) THEN KEEP(43) = huge(KEEP(43))-100 ENDIF IF ( int(KEEP(44),8)*int(KEEP(35),8) .GE. & int(huge(I4)-100,8)) THEN KEEP(44) = huge(KEEP(44))-100 ENDIF IF ( int(KEEP(379),8)*int(KEEP(35),8) .GE. & int(huge(I4)-100,8)) THEN KEEP(379) = huge(KEEP(379))-100 ENDIF IF ( int(KEEP(380),8)*int(KEEP(35),8) .GE. & int(huge(I4)-100,8)) THEN KEEP(380) = huge(KEEP(380))-100 ENDIF IF ( PROK ) THEN WRITE(MP,'(A,I16) ') & ' Estimated INTEGER space for factors :', & KEEP(26) WRITE(MP,'(A,I16) ') & ' INFO(3), est. complex space to store factors:', & KEEP8(11) WRITE(MP,'(A,I16) ') & ' Estimated number of entries in factors :', & KEEP8(9) WRITE(MP,'(A,I16) ') & ' Current value of space relaxation parameter :', & KEEP(12) WRITE(MP,'(A,I16) ') & ' Estimated size of IS (In Core factorization):', & KEEP(29) WRITE(MP,'(A,I16) ') & ' Estimated size of S (In Core factorization):', & KEEP8(13) WRITE(MP,'(A,I16) ') & ' Estimated size of S (OOC factorization) :', & KEEP8(17) END IF ELSE ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 KEEP8(13) = 0_8 KEEP(29) = 0 KEEP8(17)= 0_8 INFO(19) = 0 KEEP8(11) = 0_8 KEEP8(81) = 0_8 KEEP8(82) = 0_8 KEEP(26) = 0 KEEP(27) = 0 RINFO(1) = 0.0E0 K8_33relaxed = 0_8 K8_34relaxed = 0_8 K8_35relaxed = 0_8 K8_50relaxed = 0_8 IF (KEEP(400) .GT.0) THEN SUM_NIRNEC = 0 SUM_NIRADU = 0 SUM_NIRADU_OOC = 0 SUM_NIRNEC_OOC = 0 MAX_NRLADU = 0_8 MIN_NRLADU = 0_8 SUM_NRLADU = 0_8 SUM_NRLNEC = 0_8 SUM_NRLNEC_ACTIVE = 0_8 SUM_NRLADU_if_LR_LU = 0_8 SUM_NRLADULR_UD = 0_8 SUM_NRLADULR_WC = 0_8 ENDIF END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 CALL MUMPS_ALLREDUCEI8( ENTRIES_IN_FACTORS_LOC_MASTERS, & KEEP8(109), MPI_SUM, id%COMM) CALL MUMPS_ALLREDUCEI8( KEEP8(19), KEEP8(119), & MPI_MAX, id%COMM) CALL MPI_ALLREDUCE( KEEP(27), KEEP(127), 1, & MPI_INTEGER, MPI_MAX, & id%COMM, IERR) KEEP26_I8_TMP = int(KEEP(26),8) CALL MUMPS_ALLREDUCEI8( KEEP26_I8_TMP, & KEEP8(129), MPI_SUM, id%COMM) CALL MUMPS_REDUCEI8( KEEP8(11), & KEEP8(111), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4( KEEP8(111), INFOG(3) ) RINFO(5) = real(KEEP8(32) & *int(KEEP(35),8))/1E6 CALL MUMPS_REDUCEI8( KEEP8(32), & ITMP8, MPI_SUM, & MASTER, id%COMM ) IF (id%MYID.EQ.MASTER) THEN RINFOG(15) = real(ITMP8*int(KEEP(35),8))/1E6 ENDIF CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1, & MPI_REAL, MPI_SUM, & id%COMM, IERR) CALL MUMPS_SETI8TOI4( KEEP8(11), INFO(3) ) INFO ( 4 ) = KEEP( 26 ) INFO ( 5 ) = KEEP( 27 ) INFO ( 7 ) = KEEP( 29 ) CALL MUMPS_SETI8TOI4( KEEP8(13), INFO(8) ) CALL MUMPS_SETI8TOI4( KEEP8(17), INFO(20) ) CALL MUMPS_SETI8TOI4( KEEP8(9), INFO(24) ) CALL MUMPS_SETI8TOI4( K8_33relaxed, INFO(29) ) CALL MUMPS_SETI8TOI4( K8_34relaxed, INFO(32) ) CALL MUMPS_SETI8TOI4( K8_35relaxed, INFO(33) ) CALL MUMPS_SETI8TOI4( K8_50relaxed, INFO(36) ) CALL MUMPS_SETI8TOI4( KEEP8(129), INFOG(4) ) INFOG( 5 ) = KEEP( 127 ) CALL MUMPS_SETI8TOI4( KEEP8(109), INFOG(20) ) CALL CMUMPS_DIAG_ANA(id%MYID, id%COMM, KEEP(1), KEEP8(1), & INFO(1), INFOG(1), RINFO(1), RINFOG(1), ICNTL(1), & id%SIZE_SCHUR ) IF (PROK) WRITE( MP, 112 ) IF (PROKG .AND. (MPG.NE.MP)) WRITE( MPG, 112 ) SUM_KEEP811_THIS_NODE=0_8 CALL MPI_REDUCE( KEEP8(11), SUM_KEEP811_THIS_NODE, 1, & MPI_INTEGER8, & MPI_SUM, 0, id%KEEP(411), IERR ) CALL MPI_REDUCE( SUM_KEEP811_THIS_NODE, MAX_SUM_KEEP811_THIS_NODE, & 1, MPI_INTEGER8, MPI_MAX, 0, id%COMM, IERR ) IF (PROKG .AND. PRINT_NODEINFO) THEN WRITE(MPG,'(A,I16)') & ' Max. estimated space for factors per compute node :', & MAX_SUM_KEEP811_THIS_NODE ENDIF OOC_STRAT = KEEP(201) BLR_STRAT = 0 IF (KEEP(201) .NE. -1) OOC_STRAT=0 PERLU_ON = .FALSE. CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, .FALSE., & .TRUE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF KEEP8(2) = TOTAL_BYTES PERLU_ON = .TRUE. CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, & id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, .FALSE., & .TRUE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF IF ( PROK ) THEN WRITE(MP,'(A,I16) ') & ' Estimated space in MBytes for IC factorization (INFO(15)):', & TOTAL_MBYTES END IF id%INFO(15) = TOTAL_MBYTES CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(15), id%INFOG(16), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I16) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(16)):', & id%INFOG(16) ENDIF WRITE(MPG,'(A,I16) ') & ' Total space in MBytes, IC factorization (INFOG(17)):' & ,id%INFOG(17) END IF SUM_INFO15_THIS_NODE=0 CALL MPI_REDUCE( INFO(15), SUM_INFO15_THIS_NODE, 1, MPI_INTEGER, & MPI_SUM, 0, id%KEEP(411), IERR ) CALL MPI_REDUCE( SUM_INFO15_THIS_NODE, MAX_SUM_INFO15_THIS_NODE, & 1, MPI_INTEGER, MPI_MAX, 0, id%COMM, IERR ) IF ( PROKG .AND. PRINT_NODEINFO ) THEN WRITE(MPG,'(A,I16)') & ' Max. estim. space per compute node, in MBytes, IC fact :', & MAX_SUM_INFO15_THIS_NODE ENDIF OOC_STRAT = KEEP(201) BLR_STRAT = 0 #if defined(OLD_OOC_NOPANEL) IF (OOC_STRAT .NE. -1) OOC_STRAT=2 #else IF (OOC_STRAT .NE. -1) OOC_STRAT=1 #endif PERLU_ON = .FALSE. CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, .FALSE., & .TRUE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF KEEP8(3) = TOTAL_BYTES PERLU_ON = .TRUE. CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, .FALSE., & .TRUE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF id%INFO(17) = TOTAL_MBYTES CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(17), id%INFOG(26), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I16) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(26)):', & id%INFOG(26) ENDIF WRITE(MPG,'(A,I16) ') & ' Total space in MBytes, OOC factorization (INFOG(27)):' & ,id%INFOG(27) END IF SUM_INFO17_THIS_NODE=0 CALL MPI_REDUCE( INFO(17), SUM_INFO17_THIS_NODE, 1, MPI_INTEGER, & MPI_SUM, 0, id%KEEP(411), IERR ) CALL MPI_REDUCE( SUM_INFO17_THIS_NODE, MAX_SUM_INFO17_THIS_NODE, & 1, MPI_INTEGER, MPI_MAX, 0, id%COMM, IERR ) IF (PROKG .AND. PRINT_NODEINFO) THEN WRITE(MPG,'(A,I16)') & ' Max. estim. space per compute node, in MBytes, OOC fact :', & MAX_SUM_INFO17_THIS_NODE ENDIF IF (KEEP(494).NE.0) THEN SUM_OF_PEAKS = .TRUE. CALL CMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, & KEEP(1), KEEP8(1), & id%MYID, id%COMM, & id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), id%NSLAVES, & id%INFO, id%INFOG, PROK, MP, PROKG, MPG & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) END IF 500 CONTINUE IF (allocated(TNSTK_afterL0)) DEALLOCATE(TNSTK_afterL0) IF (allocated(FLAGGED_LEAVES)) DEALLOCATE(FLAGGED_LEAVES) IF (INFO(1) .LT. 0) THEN IF (associated(id%IPOOL_B_L0_OMP)) THEN DEALLOCATE(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_B_L0_OMP) ENDIF IF (associated(id%IPOOL_A_L0_OMP)) THEN DEALLOCATE(id%IPOOL_A_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) ENDIF IF (associated(id%VIRT_L0_OMP)) THEN DEALLOCATE(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP) ENDIF IF (associated(id%VIRT_L0_OMP_MAPPING)) THEN DEALLOCATE(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%VIRT_L0_OMP_MAPPING) ENDIF IF (associated(id%PERM_L0_OMP)) THEN DEALLOCATE(id%PERM_L0_OMP) NULLIFY(id%PERM_L0_OMP) ENDIF IF (associated(id%PTR_LEAFS_L0_OMP)) THEN DEALLOCATE(id%PTR_LEAFS_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) ENDIF ENDIF RETURN 112 FORMAT(/' MEMORY ESTIMATIONS ... '/ & ' Estimations with standard Full-Rank (FR) factorization:') 150 FORMAT( & /' ** FAILURE DURING CMUMPS_ANA_DRIVER, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE CMUMPS_ANA_COMPUTE_ESTIMATES SUBROUTINE CMUMPS_ANA_DISTM(MYID, N, STEP, FRERE, FILS, IPOOL, & LIPOOL, NE, DAD, ND, PROCNODE, SLAVEF, ABOVE_L0, SIZECB_UNDER_L0, & SIZECB_UNDER_L0_IF_LRCB, MAXFR_UNDER_L0, & MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_LO, OPSA_UNDER_L0, PEAK_FR, PEAK_FR_OOC, & NRLADU, NIRADU, NIRNEC, NRLNEC, NRLNEC_ACTIVE, & NRLADU_if_LR_LU, NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, NRLNEC_if_LR_CB, NRLADULR_UD, NRLADULR_WC, & NRLNECLR_CB_UD, NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC, & PEAK_LRLU_UD,PEAK_OOC_LRLU_UD,PEAK_OOC_LRLU_WC, PEAK_LRLUCB_UD, & PEAK_LRLUCB_WC,PEAK_OOC_LRLUCB_UD, PEAK_OOC_LRLUCB_WC, & PEAK_LRCB_UD, PEAK_OOC_LRCB_UD, NIRADU_OOC, NIRNEC_OOC, MAXFR, & OPSA, UU, KEEP,KEEP8, LOCAL_M, LOCAL_N, SBUF_RECOLD, & SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR, SBUF_REC_LR, & OPS_SUBTREE, NSTEPS, I_AM_CAND,NMB_PAR2, ISTEP_TO_INIV2, & CANDIDATES, IFLAG, IERROR, MAX_FRONT_SURFACE_LOCAL, & MAX_SIZE_FACTOR, ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS, ROOT_yes, ROOT_NPROW, ROOT_NPCOL & ) USE CMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE IMPLICIT NONE LOGICAL, intent(in) :: ROOT_yes INTEGER, intent(in) :: ROOT_NPROW, ROOT_NPCOL INTEGER, intent(in) :: MYID, N, LIPOOL LOGICAL, intent(in) :: ABOVE_L0 INTEGER, intent(in) :: MAXFR_UNDER_L0 INTEGER(8), intent(in) :: MAX_FRONT_SURFACE_LOCAL_L0, & MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO DOUBLE PRECISION, intent(in) :: COST_SUBTREES_UNDER_LO, & OPSA_UNDER_L0 INTEGER(8), intent(inout) :: SIZECB_UNDER_L0, & SIZECB_UNDER_L0_IF_LRCB INTEGER, intent(inout) :: IFLAG, IERROR INTEGER NIRADU, NIRNEC INTEGER(8) NRLADU, NRLNEC, NRLNEC_ACTIVE INTEGER(8), intent(out) :: NRLADU_if_LR_LU, & NRLADULR_UD, NRLADULR_WC, & NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, NRLNEC_if_LR_CB, & NRLNECOOC_if_LR_LUCB, NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC INTEGER(8), intent(out):: & PEAK_FR, PEAK_FR_OOC, & PEAK_LRLU_UD, & PEAK_OOC_LRLU_UD, PEAK_OOC_LRLU_WC, & PEAK_LRLUCB_UD, PEAK_LRLUCB_WC, & PEAK_OOC_LRLUCB_UD, PEAK_OOC_LRLUCB_WC, & PEAK_LRCB_UD, PEAK_OOC_LRCB_UD INTEGER(8) NRLADU_CURRENT, NRLADU_ROOT_3 INTEGER NIRADU_OOC, NIRNEC_OOC INTEGER MAXFR, NSTEPS INTEGER(8) MAX_FRONT_SURFACE_LOCAL INTEGER STEP(N) INTEGER FRERE(NSTEPS), FILS(N), IPOOL(max(LIPOOL,1)), NE(NSTEPS), & ND(NSTEPS), PROCNODE(NSTEPS), DAD(NSTEPS) REAL UU INTEGER SLAVEF, KEEP(500), LOCAL_M, LOCAL_N INTEGER(8) KEEP8(150) INTEGER(8) ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS INTEGER SBUF_SEND_FR, SBUF_REC_FR INTEGER SBUF_SEND_LR, SBUF_REC_LR INTEGER(8) SBUF_RECOLD INTEGER NMB_PAR2 INTEGER ISTEP_TO_INIV2( KEEP(71) ) LOGICAL I_AM_CAND(NMB_PAR2) INTEGER CANDIDATES( SLAVEF+1, NMB_PAR2 ) INTEGER PHASE PARAMETER (PHASE=0) REAL OPSA DOUBLE PRECISION OPSA_LOC INTEGER(8) MAX_SIZE_FACTOR REAL OPS_SUBTREE DOUBLE PRECISION OPS_SBTR_LOC INTEGER, ALLOCATABLE, DIMENSION(:) :: TNSTK, LSTKI INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR_if_LRCB, & LSTKRLR_CB_UD, & LSTKRLR_CB_WC LOGICAL OUTER_SENDS_FR INTEGER(8) :: SAVE_SIZECB_UNDER_L0, & SAVE_SIZECB_UNDER_L0_IF_LRCB INTEGER SBUFR_FR, SBUFS_FR INTEGER SBUFR_LR, SBUFS_LR INTEGER(8) SBUFS_CB, SBUFR_CB INTEGER ITOP,NELIM,NFR INTEGER(8) ISTKR, LSTK INTEGER(8) :: NRLADU_CURRENT_MISSING INTEGER(8) :: NRLADU_CURRENT_K60_1 LOGICAL :: I_PROCESS_SCHUR_K60_1 INTEGER(8) :: ISTKR_if_LRCB, ISTKRLR_CB_UD, ISTKRLR_CB_WC, & K464_8, K465_8 INTEGER :: LRSTATUS, IDUMMY INTEGER :: NBNODES_BLR LOGICAL :: COMPRESS_PANEL, COMPRESS_CB INTEGER ISTKI, STKI, ISTKI_OOC INTEGER K,NSTK, IFATH INTEGER INODE, LEAF, IN INTEGER LEVEL, MAXITEMPCB INTEGER(8) CURRENT_ACTIVE_MEM, MAXTEMPCB LOGICAL UPDATE, UPDATEF, MASTER, MASTERF, INSSARBR INTEGER LEVELF, NCB, SIZECBI INTEGER(8) NCB8 INTEGER(8) NFR8, NELIM8 INTEGER(8) :: SIZEFRNOCBLU INTEGER :: IDUMMY_ARRAY(1) INTEGER(8) SIZECB, SIZECBINFR, SIZECB_SLAVE INTEGER(8) SIZECB_if_LRCB, SIZECB_SLAVE_if_LRCB INTEGER(8) SIZECBLR_SLAVE_UD, SIZECBLR_SLAVE_WC INTEGER(8) SIZECBLR_UD, SIZECBLR_WC INTEGER(8) SIZECBSLR, NCBS8, & SIZECBS, SIZECBINFRS INTEGER NFRS, NELIMS, NCBS, LEVELS, LRSTATUSS LOGICAL COMPRESS_CBS INTEGER(8) :: PEAK_DYN_LRLU_UD, PEAK_DYN_LRCB_UD, & PEAK_DYN_LRLUCB_UD, PEAK_DYN_LRLU_WC, & PEAK_DYN_LRLUCB_WC INTEGER SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC INTEGER EXTRA_PERM_INFO_OOC INTEGER NBROWMAX, NSLAVES_LOC, NSLAVES_PASSED, & NELIMF, NFRF, NCBF, & NBROWMAXF, LKJIB_FR, LKJIB_LR, & NBR, NBCOLFAC INTEGER(8) LEV3MAXREC, CBMAXR, CBMAXS INTEGER ALLOCOK INTEGER PANEL_SIZE LOGICAL PACKED_CB DOUBLE PRECISION OPS_NODE, OPS_NODE_MASTER, OPS_NODE_SLAVE INTEGER(8) ENTRIES_NODE_UPPER_PART, ENTRIES_NODE_LOWER_PART INTEGER :: FLAG_L0OMP PARAMETER (FLAG_L0OMP=-2014) INCLUDE 'mumps_headers.h' LOGICAL ROOT_OWNER INTEGER(8) LWK_RR INTEGER LIWK_RR INTEGER IROOT, SIZE_ROOT INTEGER WHAT INTEGER(8) IDUMMY8 INTRINSIC min, int INTRINSIC real INTEGER CMUMPS_OOC_GET_PANEL_SIZE EXTERNAL CMUMPS_OOC_GET_PANEL_SIZE INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR EXTERNAL MUMPS_MAX_SURFCB_NBROWS EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, & MUMPS_IN_OR_ROOT_SSARBR logical :: FORCE_CAND, CONCERNED, UPDATES, STACKCB, MASTERSON integer :: IFSON, LEVELSON IDUMMY_ARRAY(1) = 0 IF (KEEP(50).eq.2) THEN EXTRA_PERM_INFO_OOC = 1 ELSE IF (KEEP(50).eq.0) THEN EXTRA_PERM_INFO_OOC = 2 ELSE EXTRA_PERM_INFO_OOC = 0 ENDIF PACKED_CB=( KEEP(215).EQ.0 .AND. KEEP(50).NE.0 ) MAX_FRONT_SURFACE_LOCAL=0_8 MAX_SIZE_FACTOR=0_8 ALLOCATE( LSTKR(NSTEPS), TNSTK(NSTEPS), & LSTKI(NSTEPS) , & LSTKR_if_LRCB(NSTEPS), LSTKRLR_CB_UD(NSTEPS), & LSTKRLR_CB_WC(NSTEPS), & stat=ALLOCOK) if (ALLOCOK .GT. 0) THEN IFLAG =-7 IERROR = 6*NSTEPS RETURN endif LKJIB_FR = max(KEEP(5),KEEP(6)) OUTER_SENDS_FR = (KEEP(263).NE.0 .OR. & KEEP(50).EQ.0. AND. (KEEP(468).LT.3 .OR. UU.EQ.0.0E0)) IF ( OUTER_SENDS_FR ) THEN LKJIB_FR = max(LKJIB_FR, KEEP(420)) ENDIF LKJIB_LR = max(LKJIB_FR,KEEP(142)) IF (KEEP(198).NE.0.AND.SLAVEF.GT.1) THEN LKJIB_FR = min(LKJIB_FR*KEEP(179), KEEP(435)) ENDIF TNSTK = NE LEAF = LIPOOL+1 #if defined(OLD_OOC_NOPANEL) XSIZE_OOC=XSIZE_OOC_NOPANEL #else IF (KEEP(50).EQ.0) THEN XSIZE_OOC=XSIZE_OOC_UNSYM ELSE XSIZE_OOC=XSIZE_OOC_SYM ENDIF #endif SIZEHEADER_OOC = XSIZE_OOC+6 SIZEHEADER = XSIZE_IC + 6 ISTKR_if_LRCB = 0_8 ISTKRLR_CB_UD = 0_8 ISTKRLR_CB_WC = 0_8 ISTKR = 0_8 ISTKI = 0 ISTKI_OOC = 0 NBNODES_BLR = 0 OPSA_LOC = 0.0D0 ENTRIES_IN_FACTORS_LOC = 0_8 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 OPS_SBTR_LOC = 0.0D0 NRLADU = 0_8 NIRADU = 0 NIRADU_OOC = 0 NRLADU_CURRENT_K60_1 = 0_8 I_PROCESS_SCHUR_K60_1 = .FALSE. NRLADU_CURRENT = 0_8 NRLADULR_UD = 0_8 NRLADULR_WC = 0_8 NRLADU_ROOT_3 = 0_8 NRLNEC_ACTIVE = 0_8 IF (ABOVE_L0) THEN SAVE_SIZECB_UNDER_L0 = SIZECB_UNDER_L0 SAVE_SIZECB_UNDER_L0_IF_LRCB = SIZECB_UNDER_L0_IF_LRCB ELSE SAVE_SIZECB_UNDER_L0 = 0_8 SAVE_SIZECB_UNDER_L0_IF_LRCB = 0_8 ENDIF PEAK_DYN_LRLU_UD = SAVE_SIZECB_UNDER_L0 PEAK_DYN_LRCB_UD = SAVE_SIZECB_UNDER_L0_IF_LRCB PEAK_DYN_LRLUCB_UD = SAVE_SIZECB_UNDER_L0_IF_LRCB PEAK_DYN_LRLU_WC = SAVE_SIZECB_UNDER_L0 PEAK_DYN_LRLUCB_WC = SAVE_SIZECB_UNDER_L0 NRLNEC = 0_8 NRLADU_if_LR_LU = 0_8 NRLNEC_if_LR_LU = 0_8 NRLNEC_if_LR_CB = 0_8 NRLNEC_if_LR_LUCB = 0_8 NRLNECOOC_if_LR_LUCB = 0_8 NRLNECLR_CB_UD = 0_8 NRLNECLR_LUCB_UD = 0_8 NRLNECLR_LUCB_WC = 0_8 NIRNEC = 0 NIRNEC_OOC = 0 MAXFR = 0 PEAK_FR = 0_8 PEAK_FR_OOC = 0_8 PEAK_LRLU_UD = 0_8 PEAK_OOC_LRLU_UD = 0_8 PEAK_OOC_LRLU_WC = 0_8 PEAK_LRLUCB_UD = 0_8 PEAK_LRLUCB_WC = 0_8 PEAK_OOC_LRLUCB_UD= 0_8 PEAK_OOC_LRLUCB_WC= 0_8 PEAK_LRCB_UD = 0_8 PEAK_OOC_LRCB_UD = 0_8 ITOP = 0 MAXTEMPCB = 0_8 MAXITEMPCB = 0 SBUFS_CB = 1_8 SBUFS_FR = 1 SBUFS_LR = 1 SBUFR_CB = 1_8 SBUFR_FR = 1 SBUFR_LR = 1 IF (KEEP(38) .NE. 0 .AND. KEEP(60).EQ.0) THEN INODE = KEEP(38) NRLADU_ROOT_3 = int(LOCAL_M,8)*int(LOCAL_N,8) NRLADU = NRLADU_ROOT_3 NRLNEC_ACTIVE = NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_ROOT_3) NRLNEC = NRLADU NRLADU_if_LR_LU = NRLADU_ROOT_3 NRLNECOOC_if_LR_LUCB = NRLNEC_ACTIVE NRLNEC_if_LR_LU = NRLADU NRLNEC_if_LR_CB = NRLADU NRLNEC_if_LR_LUCB = NRLADU PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD + SIZECB_UNDER_L0) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF IF (MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID) THEN NIRADU = SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) NIRADU_OOC = SIZEHEADER_OOC+2*(ND(STEP(INODE))+KEEP(253)) ELSE NIRADU = SIZEHEADER NIRADU_OOC = SIZEHEADER_OOC ENDIF NIRNEC = NIRADU NIRNEC_OOC = NIRADU_OOC ENDIF IF((KEEP(24).eq.0).OR.(KEEP(24).eq.1)) THEN FORCE_CAND=.FALSE. ELSE FORCE_CAND=(mod(KEEP(24),2).eq.0) END IF 90 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF - 1 INODE = IPOOL(LEAF) ELSE IF (LIPOOL.NE.0) THEN WRITE(MYID+6,*) ' ERROR 1 in CMUMPS_ANA_DISTM ' CALL MUMPS_ABORT() ELSE GOTO 115 ENDIF ENDIF 95 CONTINUE NFR = ND(STEP(INODE))+KEEP(253) NFR8 = int(NFR,8) NSTK = NE(STEP(INODE)) NELIM = 0 IN = INODE 100 NELIM = NELIM + 1 NELIM8=int(NELIM,8) IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IFSON = -IN IFATH = DAD(STEP(INODE)) MASTER = MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID LEVEL = MUMPS_TYPENODE(PROCNODE(STEP(INODE)),KEEP(199)) INSSARBR = MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) UPDATE=.FALSE. if(.NOT.FORCE_CAND) then UPDATE = ( (MASTER.AND.(LEVEL.NE.3) ).OR. LEVEL.EQ.2 ) else if(MASTER.and.(LEVEL.ne.3)) then UPDATE = .TRUE. else if(LEVEL.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(INODE)))) THEN UPDATE = .TRUE. end if end if end if NCB = NFR-NELIM NCB8 = int(NCB,8) SIZECBINFR = NCB8*NCB8 IF (KEEP(50).EQ.0) THEN SIZECB = SIZECBINFR ELSE IFATH = DAD(STEP(INODE)) IF ( IFATH.NE.KEEP(38) .AND. PACKED_CB ) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = SIZECBINFR ENDIF ENDIF IDUMMY = -99999 CALL IS_FRONT_BLR_CANDIDATE (INODE, LEVEL, NFR, NELIM, & KEEP(494), 1, KEEP(490), & KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, IDUMMY) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) IF (COMPRESS_PANEL.OR.COMPRESS_CB) NBNODES_BLR = NBNODES_BLR+1 IF (COMPRESS_PANEL) THEN K464_8 = int(KEEP(464),8) ELSE K464_8 = 1000_8 ENDIF IF (COMPRESS_CB) THEN K465_8 = int(KEEP(465),8) SIZECB_if_LRCB = 0_8 SIZECBLR_UD = SIZECB*K465_8/1000_8 SIZECBLR_WC = SIZECB ELSE K465_8 = 1000_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = SIZECB ENDIF SIZECBI = 2* NCB + SIZEHEADER IF (LEVEL.NE.2) THEN NSLAVES_LOC = -99999999 SIZECB_SLAVE = -99999997_8 SIZECB_SLAVE_if_LRCB = SIZECB_SLAVE NBROWMAX = NCB ELSE IF (KEEP(48) .EQ. 5) THEN WHAT = 5 IF (FORCE_CAND) THEN NSLAVES_LOC=CANDIDATES(SLAVEF+1, & ISTEP_TO_INIV2(STEP(INODE))) ELSE NSLAVES_LOC=SLAVEF-1 ENDIF NSLAVES_PASSED=NSLAVES_LOC ELSE WHAT = 2 NSLAVES_PASSED=SLAVEF NSLAVES_LOC =SLAVEF-1 ENDIF CALL MUMPS_MAX_SURFCB_NBROWS(WHAT, KEEP,KEEP8, & NCB, NFR, NSLAVES_PASSED, NBROWMAX, SIZECB_SLAVE & ) IF (COMPRESS_CB) THEN SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_SLAVE_UD = SIZECB_SLAVE*K465_8/1000_8 SIZECBLR_SLAVE_WC = SIZECB_SLAVE ELSE SIZECB_SLAVE_if_LRCB = SIZECB_SLAVE SIZECBLR_SLAVE_UD = 0_8 SIZECBLR_SLAVE_WC = 0_8 ENDIF ENDIF IF (KEEP(60).GT.1) THEN IF (MASTER .AND. INODE.EQ.KEEP(38)) THEN NIRADU = NIRADU+SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC+ & 2*(ND(STEP(INODE))+KEEP(253)) ENDIF ENDIF IF (LEVEL.EQ.3) THEN IF ( & KEEP(60).LE.1 & ) THEN NRLADU_CURRENT = int(LOCAL_M,8)*int(LOCAL_N,8) NRLNEC = max(NRLNEC,NRLADU+ISTKR+ & NRLADU_CURRENT) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR+ & NRLADU_CURRENT) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB , & NRLADU+ISTKR_if_LRCB+ & NRLADU_CURRENT) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU+ISTKR_if_LRCB+ & NRLADU_CURRENT) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR_if_LRCB) PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF ENDIF IF (MASTER) THEN IF (NFR.GT.MAXFR) MAXFR = NFR ENDIF ENDIF IF(KEEP(86).EQ.1)THEN IF(MASTER.AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)), KEEP(199))) & )THEN IF(LEVEL.EQ.1)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8) IF (KEEP(268).NE.0) THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8+NELIM8) ENDIF ELSEIF(LEVEL.EQ.2)THEN IF(KEEP(50).EQ.0)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NELIM8) ELSE MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NELIM8*NELIM8) IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NELIM8*(NELIM8+1_8)) ENDIF ENDIF ENDIF ENDIF ENDIF IF (LEVEL.EQ.2) THEN IF (MASTER) THEN IF (KEEP(50).EQ.0) THEN SBUFS_FR = max(SBUFS_FR, NFR*LKJIB_FR+LKJIB_FR+4) SBUFS_LR = max(SBUFS_LR, NFR*LKJIB_LR+LKJIB_LR+4) ELSE SBUFS_FR = max(SBUFS_FR, NELIM*LKJIB_FR+NELIM+6) SBUFS_LR = max(SBUFS_LR, NELIM*LKJIB_LR+NELIM+6) ENDIF ELSEIF (UPDATE) THEN if (KEEP(50).EQ.0) THEN SBUFR_FR = max(SBUFR_FR, NFR*LKJIB_FR+LKJIB_FR+4) SBUFR_LR = max(SBUFR_LR, NFR*LKJIB_LR+LKJIB_LR+4) else SBUFR_FR = max( SBUFR_FR, NELIM*LKJIB_FR+NELIM+6 ) SBUFR_LR = max( SBUFR_LR, NELIM*LKJIB_LR+NELIM+6 ) SBUFS_FR = max( SBUFS_FR, NBROWMAX*LKJIB_FR+6 ) SBUFS_LR = max( SBUFS_LR, NBROWMAX*LKJIB_LR+6 ) SBUFR_FR = max( SBUFR_FR, NBROWMAX*LKJIB_FR+6 ) SBUFR_LR = max( SBUFR_LR, NBROWMAX*LKJIB_LR+6 ) endif ENDIF ENDIF IF ( UPDATE ) THEN IF ( (MASTER) .AND. (LEVEL.EQ.1) ) THEN NIRADU = NIRADU + 2*NFR + SIZEHEADER NIRADU_OOC = NIRADU_OOC + 2*NFR + SIZEHEADER_OOC PANEL_SIZE = CMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NFR, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) IF (KEEP(50).EQ.0) THEN IF (KEEP(251) .EQ. 2) THEN NRLADU_CURRENT = int(NELIM,8) * int(NFR,8) SIZEFRNOCBLU = int(NFR-NELIM,8)*int(NELIM) ELSE NRLADU_CURRENT = int(NELIM,8)*int(2*NFR-NELIM,8) SIZEFRNOCBLU = 0_8 ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR = max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ELSE IF ( KEEP(459) .GT. 1 .AND. KEEP(50).NE.0 ) THEN CALL MUMPS_LDLTPANEL_STORAGE( NELIM, KEEP, & IDUMMY_ARRAY(1), NRLADU_CURRENT ) SIZEFRNOCBLU = int(NELIM,8)*int(NELIM,8) - & NRLADU_CURRENT NRLADU_CURRENT = NRLADU_CURRENT + & int(NELIM,8) * int(NFR-NELIM,8) ELSE SIZEFRNOCBLU = 0_8 NRLADU_CURRENT = int(NELIM,8)*int(NFR,8) ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ENDIF IF (INODE.EQ.KEEP(20).AND.(KEEP(60).EQ.1)) THEN I_PROCESS_SCHUR_K60_1 = .TRUE. NRLADU_CURRENT_K60_1 = NRLADU_CURRENT ENDIF IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_CURRENT_MISSING = 0_8 NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT ENDIF SIZECBI = 2* NCB + SIZEHEADER ELSEIF (LEVEL.EQ.2) THEN IF (MASTER) THEN NIRADU = NIRADU+SIZEHEADER +SLAVEF-1+2*NFR NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC +SLAVEF-1+2*NFR IF (KEEP(50).EQ.0) THEN NRLADU_CURRENT = int(NFR,8)*int(NELIM,8) SIZEFRNOCBLU = 0_8 NBCOLFAC = NFR ELSE NBCOLFAC = NELIM IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 ) THEN CALL MUMPS_LDLTPANEL_STORAGE( NELIM, KEEP, & IDUMMY_ARRAY(1), NRLADU_CURRENT ) SIZEFRNOCBLU = int(NELIM,8)*int(NELIM,8) - & NRLADU_CURRENT ELSE SIZEFRNOCBLU = 0_8 NRLADU_CURRENT = int(NELIM,8)*int(NELIM,8) ENDIF ENDIF PANEL_SIZE = CMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NBCOLFAC, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) NRLADU = NRLADU + NRLADU_CURRENT IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_CURRENT_MISSING = 0_8 NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT ENDIF MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) SIZECB = 0_8 SIZECBINFR = 0_8 SIZECB_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECB=SIZECB_SLAVE SIZECBINFR = SIZECB NIRADU = NIRADU+4+NELIM+NBROWMAX NIRADU_OOC = NIRADU_OOC+4+NELIM+NBROWMAX IF (KEEP(50).EQ.0) THEN IF (KEEP(251) .EQ. 2) THEN NRLADU_CURRENT = 0_8 SIZEFRNOCBLU = int(NELIM,8)*int(NBROWMAX,8) ELSE NRLADU_CURRENT = int(NELIM,8)*int(NBROWMAX,8) SIZEFRNOCBLU = 0_8 ENDIF ELSE NRLADU_CURRENT = int(NELIM,8)*int(NCB/NSLAVES_LOC,8) SIZEFRNOCBLU = 0_8 ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_CURRENT_MISSING = 0_8 NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT ENDIF IF (KEEP(50).EQ.0) THEN SIZECBI = 7 + NBROWMAX + NCB ELSE SIZECBI = 8 + NBROWMAX + NCB ENDIF IF (KEEP(50).NE.0) THEN SIZECBI=SIZECBI+NSLAVES_LOC+ & XTRA_SLAVES_SYM ELSE SIZECBI=SIZECBI+NSLAVES_LOC+ & XTRA_SLAVES_UNSYM ENDIF ENDIF ENDIF NIRNEC = max(NIRNEC, & NIRADU+ISTKI+SIZECBI+MAXITEMPCB) NIRNEC_OOC = max(NIRNEC_OOC, & NIRADU_OOC+ISTKI_OOC+SIZECBI+MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) CURRENT_ACTIVE_MEM = ISTKR+SIZECBINFR IF ( KEEP(50).NE.0 .AND. LEVEL.EQ.1 ) THEN SIZEFRNOCBLU = SIZEFRNOCBLU + int(NELIM,8)*int(NCB,8) ENDIF CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + SIZEFRNOCBLU IF (MASTER .AND. KEEP(219).NE.0.AND. & KEEP(50).EQ.2.AND.LEVEL.EQ.2) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + int(NELIM,8) ENDIF IF (SLAVEF.EQ.1) THEN NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = & max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & MAXTEMPCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING+ & MAXTEMPCB) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & MAXTEMPCB) ENDIF IF (NSTK .NE. 0 .AND. INSSARBR .AND. & KEEP(234).NE.0 .AND. KEEP(55).EQ.0) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTKR(ITOP) ENDIF IF (SLAVEF.EQ.1) THEN NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT_MISSING) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+MAXTEMPCB+ & NRLADU_CURRENT_MISSING) ENDIF NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF IF (NFR.GT.MAXFR) MAXFR = NFR IF (ABOVE_L0.AND.MASTER.AND.(LEVEL.EQ.1)) THEN DO WHILE (IFSON.GT.0) IF (TNSTK(STEP(IFSON)).EQ.FLAG_L0OMP) THEN LEVELS = MUMPS_TYPENODE(PROCNODE(STEP(IFSON)),KEEP(199)) NFRS = ND(STEP(IFSON))+KEEP(253) NELIMS= 0 IN = IFSON DO WHILE (IN.GT.0) IN = FILS(IN) NELIMS = NELIMS + 1 ENDDO NCBS = NFRS-NELIMS NCBS8 = int(NCBS,8) SIZECBINFRS = NCBS8*NCBS8 IF (KEEP(50).EQ.0) THEN SIZECBS = SIZECBINFRS ELSE IF ( PACKED_CB ) THEN SIZECBS = (NCBS8*(NCBS8+1_8))/2_8 ELSE SIZECBS = SIZECBINFRS ENDIF ENDIF IDUMMY = -99999 CALL IS_FRONT_BLR_CANDIDATE & (IFSON, LEVELS, NFRS, NELIMS, & KEEP(494), 1, KEEP(490), & KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(IFSON)), KEEP(38), & KEEP(123), LRSTATUSS, IDUMMY) COMPRESS_CBS = ((LRSTATUSS.EQ.1).OR.(LRSTATUSS.EQ.3)) IF (COMPRESS_CBS) THEN K465_8 = int(KEEP(465),8) SIZECBSLR = SIZECBS*K465_8/1000_8 ELSE SIZECBSLR = SIZECBS ENDIF SIZECB_UNDER_L0 = SIZECB_UNDER_L0 - SIZECBS SIZECB_UNDER_L0_IF_LRCB = SIZECB_UNDER_L0_IF_LRCB & - SIZECBSLR ENDIF IFSON = FRERE(STEP(IFSON)) ENDDO ENDIF IF (NSTK.GT.0) THEN DO 70 K=1,NSTK LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK IF (K==1 .AND. INSSARBR.AND.KEEP(234).NE.0 & .AND.KEEP(55).EQ.0) THEN ELSE CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTK ENDIF LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in CMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF 70 CONTINUE ENDIF ELSE IF (LEVEL.NE.3) THEN DO WHILE (IFSON.GT.0) UPDATES=.FALSE. MASTERSON = MUMPS_PROCNODE(PROCNODE(STEP(IFSON)),KEEP(199)) & .EQ.MYID LEVELSON = MUMPS_TYPENODE(PROCNODE(STEP(IFSON)),KEEP(199)) if(.NOT.FORCE_CAND) then UPDATES =((MASTERSON.AND.(LEVELSON.NE.3)).OR. & LEVELSON.EQ.2) else if(MASTERSON.and.(LEVELSON.ne.3)) then UPDATES = .TRUE. else if(LEVELSON.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFSON)))) then UPDATES = .TRUE. end if end if end if IF (UPDATES) THEN LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in CMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF ENDIF IFSON = FRERE(STEP(IFSON)) END DO ENDIF IF ( & ( (INODE.NE.KEEP(20)).OR.(KEEP(60).EQ.0) ) & .AND. & ( (INODE.NE.KEEP(38)).OR.(KEEP(60).LE.1) ) & ) & THEN ENTRIES_NODE_LOWER_PART = int(NFR-NELIM,8) * int(NELIM,8) IF ( KEEP(50).EQ.0 ) THEN ENTRIES_NODE_UPPER_PART = int(NFR,8) * int(NELIM,8) ELSE ENTRIES_NODE_UPPER_PART = & (int(NELIM,8)*int(NELIM+1,8))/2_8 ENDIF IF (KEEP(50).EQ.2 .AND. LEVEL.EQ.3) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM, 0, & 1,OPS_NODE) ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) ENDIF IF (LEVEL.EQ.2) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 2,OPS_NODE_MASTER) OPS_NODE_SLAVE=OPS_NODE-OPS_NODE_MASTER ENDIF ELSE OPS_NODE = 0.0D0 ENTRIES_NODE_UPPER_PART = 0_8 ENTRIES_NODE_LOWER_PART = 0_8 ENDIF IF ( MASTER ) THEN ENTRIES_IN_FACTORS_LOC_MASTERS = & ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ENDIF IF (UPDATE.OR.LEVEL.EQ.3) THEN IF ( LEVEL .EQ. 3 ) THEN IF (ROOT_yes) THEN OPSA_LOC = OPSA_LOC + & dble( & int(OPS_NODE,8)/ & int(ROOT_NPROW*ROOT_NPCOL,8) & ) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART / & int(ROOT_NPROW*ROOT_NPCOL,8) IF (MASTER) THEN ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & mod(ENTRIES_NODE_UPPER_PART, & int(SLAVEF,8)) ENDIF ENDIF ELSE IF (MASTER .AND. LEVEL.EQ.2) THEN OPSA_LOC = OPSA_LOC + OPS_NODE_MASTER ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART + & mod(ENTRIES_NODE_LOWER_PART, & int(NSLAVES_LOC,8)) ELSE IF (MASTER .AND. LEVEL.EQ.1) THEN OPSA_LOC = OPSA_LOC + OPS_NODE ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ELSE IF (UPDATE) THEN OPSA_LOC = OPSA_LOC + & dble(OPS_NODE_SLAVE)/dble(NSLAVES_LOC) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC & + ENTRIES_NODE_LOWER_PART / & int(NSLAVES_LOC,8) ENDIF IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) .OR. NE(STEP(INODE))==0) THEN IF (LEVEL == 1) THEN OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ENDIF ENDIF ENDIF IF (IFATH .EQ. 0) THEN IF (LEAF.GT.1) THEN GOTO 90 ELSE GOTO 115 ENDIF ELSE NFRF = ND(STEP(IFATH))+KEEP(253) IF (DAD(STEP(IFATH)).EQ.0) THEN NELIMF = NFRF-KEEP(253) IF (ABOVE_L0) IN=0 ELSE NELIMF = 0 IN = IFATH DO WHILE (IN.GT.0) IN = FILS(IN) NELIMF = NELIMF+1 ENDDO ENDIF NCBF = NFRF - NELIMF LEVELF = MUMPS_TYPENODE(PROCNODE(STEP(IFATH)),KEEP(199)) MASTERF= MUMPS_PROCNODE(PROCNODE(STEP(IFATH)), & KEEP(199)).EQ.MYID UPDATEF= .FALSE. if(.NOT.FORCE_CAND) then UPDATEF= ((MASTERF.AND.(LEVELF.NE.3)).OR.LEVELF.EQ.2) else if(MASTERF.and.(LEVELF.ne.3)) then UPDATEF = .TRUE. else if (LEVELF.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFATH)))) THEN UPDATEF = .TRUE. end if end if end if CONCERNED = UPDATEF .OR. UPDATE IF (LEVELF .NE. 2) THEN NBROWMAXF = -999999 ELSE IF (KEEP(48) .EQ. 5) THEN WHAT = 4 IF (FORCE_CAND) THEN NSLAVES_LOC=CANDIDATES(SLAVEF+1, & ISTEP_TO_INIV2(STEP(IFATH))) ELSE NSLAVES_LOC=SLAVEF-1 ENDIF ELSE WHAT = 1 NSLAVES_LOC=SLAVEF ENDIF CALL MUMPS_MAX_SURFCB_NBROWS( WHAT, KEEP, KEEP8, & NCBF, NFRF, NSLAVES_LOC, NBROWMAXF, IDUMMY8 & ) ENDIF IF(LEVEL.EQ.1.AND.UPDATE.AND. & (UPDATEF.OR.LEVELF.EQ.2) & .AND.LEVELF.NE.3) THEN IF ( INSSARBR .AND. KEEP(234).NE.0) THEN NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+SIZECB+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) ENDIF PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) 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,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) IF (.NOT.COMPRESS_PANEL) THEN NRLNEC_if_LR_LU = max( & NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT) NRLNEC_if_LR_CB = max( & NRLNEC_if_LR_CB ,NRLADU + & CURRENT_ACTIVE_MEM-ISTKR + & ISTKR_if_LRCB+NRLADU_CURRENT) NRLNEC_if_LR_LUCB = max( & NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR + & ISTKR_if_LRCB+NRLADU_CURRENT) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF ENDIF ENDIF IF (LEVELF.EQ.3) THEN IF (LEVEL.EQ.1) THEN LEV3MAXREC = int(min(NCB,LOCAL_M),8) * & int(min(NCB,LOCAL_N),8) ELSE LEV3MAXREC = min(SIZECB, & int(min(NBROWMAX,LOCAL_M),8) & *int(min(NCB,LOCAL_N),8)) ENDIF MAXTEMPCB = max(MAXTEMPCB, LEV3MAXREC) MAXITEMPCB = max(MAXITEMPCB,SIZECBI+SIZEHEADER) SBUFR_CB = max(SBUFR_CB, LEV3MAXREC+int(SIZECBI,8)) NIRNEC = max(NIRNEC,NIRADU+ISTKI+ & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) ENDIF IF (CONCERNED) THEN IF (LEVELF.EQ.2) THEN IF (UPDATE.AND.(LEVEL.NE.2.OR..NOT.MASTER)) THEN IF(MASTERF)THEN NBR = min(NBROWMAXF,NBROWMAX) ELSE NBR = min(max(NELIMF,NBROWMAXF),NBROWMAX) ENDIF IF (KEEP(50).EQ.0) THEN CBMAXS = int(NBR,8)*int(NCB,8) ELSE CBMAXS = int(NBR,8)*int(NCB,8) - & (int(NBR,8)*int(NBR-1,8))/2_8 ENDIF ELSE CBMAXS = 0_8 END IF IF (MASTERF) THEN IF (LEVEL.EQ.1) THEN IF (.NOT.UPDATE) THEN NBR = min(NELIMF, NCB) ELSE NBR = 0 ENDIF ELSE NBR = min(NELIMF, NBROWMAX) ENDIF IF (KEEP(50).EQ.0) THEN CBMAXR = int(NBR,8)*NCB8 ELSE CBMAXR = int(NBR,8)*int(min(NCB,NELIMF),8)- & (int(NBR,8)*int(NBR-1,8))/2_8 CBMAXR = min(CBMAXR, int(NELIMF,8)*int(NELIMF+1,8)/2_8) CBMAXR = min(CBMAXR, SIZECB) IF ((LEVEL.EQ.1).AND.(.NOT. PACKED_CB)) THEN CBMAXR = min(CBMAXR,(NCB8*(NCB8+1_8))/2_8) ENDIF ENDIF ELSE IF (UPDATEF) THEN NBR = min(NBROWMAXF,NBROWMAX) CBMAXR = int(NBR,8) * NCB8 IF (KEEP(50).NE.0) THEN CBMAXR = CBMAXR - (int(NBR,8)*(int(NBR-1,8)))/2_8 ENDIF ELSE CBMAXR = 0_8 ENDIF ELSEIF (LEVELF.EQ.3) THEN CBMAXR = LEV3MAXREC IF (UPDATE.AND. .NOT. (MASTER.AND.LEVEL.EQ.2)) THEN CBMAXS = LEV3MAXREC ELSE CBMAXS = 0_8 ENDIF ELSE IF (MASTERF) THEN CBMAXS = 0_8 NBR = min(NFRF,NBROWMAX) IF ((LEVEL.EQ.1).AND.UPDATE) THEN NBR = 0 ENDIF CBMAXR = int(NBR,8)*int(min(NFRF,NCB),8) IF (LEVEL.EQ.2) & CBMAXR = min(CBMAXR, SIZECB_SLAVE) IF ( KEEP(50).NE.0 ) THEN CBMAXR = min(CBMAXR,(int(NFRF,8)*int(NFRF+1,8))/2_8) ELSE CBMAXR = min(CBMAXR,int(NFRF,8)*int(NFRF,8)) ENDIF ELSE CBMAXR = 0_8 CBMAXS = SIZECB ENDIF ENDIF IF (UPDATE) THEN CBMAXS = min(CBMAXS, SIZECB) IF ( .not. ( LEVELF .eq. 1 .AND. UPDATEF ) )THEN SBUFS_CB = max(SBUFS_CB, CBMAXS+int(SIZECBI,8)) ENDIF ENDIF STACKCB = .FALSE. IF (UPDATEF) THEN STACKCB = .TRUE. SIZECBI = 2 * NCB + SIZEHEADER IF (LEVEL.EQ.1) THEN IF (KEEP(50).NE.0.AND.LEVELF.NE.3 & .AND.PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF IF (MASTER) THEN IF (MASTERF) THEN SIZECBI = 2+ XSIZE_IC ENDIF ELSE IF (LEVELF.EQ.1) THEN SIZECB = min(CBMAXR,SIZECB) IF (COMPRESS_CB) THEN SIZECBLR_UD = min(SIZECBLR_UD,SIZECB) SIZECBLR_WC = min(SIZECBLR_WC,SIZECB) SIZECB_if_LRCB = min(SIZECB_if_LRCB,SIZECB) ENDIF SIZECBI = 2 * NCB + 9 SBUFR_CB = max(SBUFR_CB, int(SIZECBI,8)+SIZECB) SIZECBI = 2 * NCB + SIZEHEADER ELSE SIZECBI = 2 * NCB + 9 SBUFR_CB = max(SBUFR_CB, & min(SIZECB,CBMAXR) + int(SIZECBI,8)) MAXTEMPCB = max(MAXTEMPCB, min(SIZECB,CBMAXR)) SIZECBI = 2 * NCB + SIZEHEADER MAXITEMPCB = max(MAXITEMPCB, SIZECBI) IF ( .NOT. MASTERF ) THEN SIZECBI = 0 ELSE SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ENDIF SIZECB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = 0_8 ENDIF ELSE SIZECB = SIZECB_SLAVE SIZECBLR_UD = SIZECBLR_SLAVE_UD SIZECBLR_WC = SIZECBLR_SLAVE_WC SIZECB_if_LRCB = SIZECB_SLAVE_if_LRCB MAXTEMPCB = max(MAXTEMPCB, min(CBMAXR,SIZECB) ) MAXITEMPCB = max(MAXITEMPCB,NBROWMAX+NCB+SIZEHEADER) IF (.NOT. & (UPDATE.AND.(.NOT.MASTER).AND.(NSLAVES_LOC.EQ.1)) & ) & SBUFR_CB = max(SBUFR_CB, & min(CBMAXR,SIZECB) + int(NBROWMAX + NCB + 6,8)) IF (MASTER) THEN SIZECB = 0_8 SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 IF (MASTERF) THEN SIZECBI = 2 + XSIZE_IC ELSE SIZECBI = 0 ENDIF ELSE IF (UPDATE) THEN IF (MASTERF) THEN SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECBI = 0 ENDIF IF (KEEP(50).EQ.0) THEN SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER ELSE SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER+ NSLAVES_LOC ENDIF ELSE SIZECB = 0_8 IF ( MASTERF ) THEN SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECBI = 0 ENDIF SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 ENDIF ENDIF ELSE IF (LEVELF.NE.3) THEN STACKCB = .TRUE. SIZECB = 0_8 SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECBI = 0 IF ( (LEVEL.EQ.1) .AND. (LEVELF.NE.1) ) THEN IF (PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF SIZECBI = 2 * NCB + SIZEHEADER ELSE IF (LEVEL.EQ.2) THEN IF (MASTER) THEN SIZECBI=0 ELSE SIZECB = SIZECB_SLAVE SIZECBLR_UD = SIZECBLR_SLAVE_UD SIZECBLR_WC = SIZECBLR_SLAVE_WC SIZECB_if_LRCB = SIZECB_SLAVE_if_LRCB SIZECBI = NBROWMAX + NFR + SIZEHEADER ENDIF ENDIF ENDIF ENDIF IF (STACKCB) THEN IF (FRERE(STEP(INODE)).EQ.0) THEN write(*,*) ' ERROR 3 in CMUMPS_ANA_DISTM' CALL MUMPS_ABORT() ENDIF ITOP = ITOP + 1 IF ( ITOP .GT. NSTEPS ) THEN WRITE(*,*) 'ERROR 4 in CMUMPS_ANA_DISTM ' ENDIF LSTKI(ITOP) = SIZECBI ISTKI=ISTKI + SIZECBI ISTKI_OOC = ISTKI_OOC + SIZECBI + (XSIZE_OOC-XSIZE_IC) LSTKR(ITOP) = SIZECB ISTKR = ISTKR + LSTKR(ITOP) NRLNEC = max(NRLNEC,NRLADU+ISTKR+MAXTEMPCB) NIRNEC = max(NIRNEC,NIRADU+ISTKI+MAXITEMPCB) NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ & MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR+MAXTEMPCB) LSTKR_if_LRCB(ITOP) = SIZECB_if_LRCB ISTKR_if_LRCB = ISTKR_if_LRCB + LSTKR_if_LRCB(ITOP) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB, & NRLADU_if_LR_LU+ISTKR_if_LRCB + & MAXTEMPCB) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU+ISTKR_if_LRCB + & MAXTEMPCB) LSTKRLR_CB_UD(ITOP) = SIZECBLR_UD ISTKRLR_CB_UD = ISTKRLR_CB_UD + LSTKRLR_CB_UD(ITOP) LSTKRLR_CB_WC(ITOP) = SIZECBLR_WC ISTKRLR_CB_WC = ISTKRLR_CB_WC + LSTKRLR_CB_WC(ITOP) NRLNECLR_CB_UD = max(NRLNECLR_CB_UD, ISTKRLR_CB_UD) NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) ENDIF ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH GOTO 95 ELSE GOTO 90 ENDIF ENDIF 115 CONTINUE IF ( KEEP(53) .NE. 0 ) THEN IF ( KEEP(38) .ne. 0 ) THEN IROOT = KEEP( 38 ) ELSE IROOT = KEEP( 20 ) END IF ROOT_OWNER = ( MYID .eq. & MUMPS_PROCNODE( PROCNODE(STEP(IROOT)), KEEP(199) ) ) SIZE_ROOT = ND(STEP(IROOT))+KEEP(253) CALL CMUMPS_SVD_QR_ESTIM_WK( PHASE, & KEEP(51), KEEP(51), SIZE_ROOT, & LOCAL_M, LOCAL_N, ROOT_OWNER, KEEP,KEEP8, & LIWK_RR, LWK_RR ) IF ( NRLNEC-NRLADU .LT. LWK_RR ) THEN NRLNEC = NRLADU + LWK_RR NRLNEC_if_LR_LU = NRLNEC_if_LR_LU + LWK_RR NRLNEC_if_LR_CB = NRLNEC_if_LR_CB + LWK_RR NRLNEC_if_LR_LUCB = NRLNEC_if_LR_LUCB + LWK_RR NRLNEC_ACTIVE = NRLNEC_ACTIVE + LWK_RR NRLNECOOC_if_LR_LUCB = NRLNECOOC_if_LR_LUCB + LWK_RR PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF END IF IF ( NIRNEC-NIRADU .LT. LIWK_RR ) THEN NIRNEC = NIRADU + LIWK_RR END IF IF ( NIRNEC_OOC-NIRADU_OOC .LT. LIWK_RR ) THEN NIRNEC_OOC = NIRADU_OOC + LIWK_RR END IF END IF NRLNEC = max(NRLNEC, NRLADU+int(KEEP(30),8)) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE, MAX_SIZE_FACTOR+ & int(KEEP(30),8)) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU + int(KEEP(30),8)) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU + int(KEEP(30),8)) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB, & NRLADU + int(KEEP(30),8)) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & MAX_SIZE_FACTOR+ int(KEEP(30),8)) PEAK_FR = SAVE_SIZECB_UNDER_L0 + NRLNEC PEAK_FR_OOC = SAVE_SIZECB_UNDER_L0 + NRLNEC_ACTIVE PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) IF (KEEP(60).EQ.1) THEN IF (I_PROCESS_SCHUR_K60_1) THEN NRLADU = NRLADU - NRLADU_CURRENT_K60_1 NRLADU_IF_LR_LU = NRLADU_IF_LR_LU - NRLADU_CURRENT_K60_1 ENDIF ENDIF IF (ABOVE_L0) THEN PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + SAVE_SIZECB_UNDER_L0_IF_LRCB) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + PEAK_DYN_LRCB_UD) PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + SAVE_SIZECB_UNDER_L0) PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + PEAK_DYN_LRLU_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + SAVE_SIZECB_UNDER_L0) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + PEAK_DYN_LRLU_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + SAVE_SIZECB_UNDER_L0) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + PEAK_DYN_LRLU_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + SAVE_SIZECB_UNDER_L0_IF_LRCB) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + PEAK_DYN_LRLUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + SAVE_SIZECB_UNDER_L0) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + PEAK_DYN_LRLUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + SAVE_SIZECB_UNDER_L0_IF_LRCB) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + PEAK_DYN_LRLUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + SAVE_SIZECB_UNDER_L0) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + PEAK_DYN_LRLUCB_WC) ENDIF SBUF_RECOLD = max(SBUFR_CB, & MAXTEMPCB+int(MAXITEMPCB,8)) + 10_8 SBUF_REC_FR = max(SBUFR_FR, int(min(100000_8,SBUFR_CB))) + 17 SBUF_REC_LR = max(SBUFR_LR, int(min(100000_8,SBUFR_CB))) + 17 SBUF_REC_FR = SBUF_REC_FR + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_REC_LR = SBUF_REC_LR + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_SEND_FR = max(SBUFS_FR, int(min(100000_8,SBUFR_CB)))+17 SBUF_SEND_LR = max(SBUFS_LR, int(min(100000_8,SBUFR_CB)))+17 IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN SBUF_RECOLD = SBUF_RECOLD+int(KEEP(108)+1,8) SBUF_REC_FR = SBUF_REC_FR+KEEP(108)+1 SBUF_REC_LR = SBUF_REC_LR+KEEP(108)+1 SBUF_SEND_FR = SBUF_SEND_FR+KEEP(108)+1 SBUF_SEND_LR = SBUF_SEND_LR+KEEP(108)+1 ENDIF IF (SLAVEF.EQ.1) THEN SBUF_RECOLD = 1_8 SBUF_REC_FR = 1 SBUF_REC_LR = 1 SBUF_SEND_FR= 1 SBUF_SEND_LR= 1 ENDIF DEALLOCATE( LSTKR, TNSTK, LSTKI, & LSTKR_if_LRCB, LSTKRLR_CB_UD, LSTKRLR_CB_WC & ) IF (ABOVE_L0) THEN KEEP(470) = KEEP(470)+ NBNODES_BLR ELSE KEEP(470) = NBNODES_BLR ENDIF IF (.NOT.ABOVE_L0) THEN PEAK_FR = NRLNEC PEAK_FR_OOC = NRLNEC_ACTIVE ENDIF MAXFR = max(MAXFR, MAXFR_UNDER_L0) MAX_FRONT_SURFACE_LOCAL = max (MAX_FRONT_SURFACE_LOCAL, & MAX_FRONT_SURFACE_LOCAL_L0) MAX_SIZE_FACTOR = max (MAX_SIZE_FACTOR, & MAX_SIZE_FACTOR_L0) ENTRIES_IN_FACTORS_LOC_MASTERS = ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_IN_FACTORS_MASTERS_LO ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_IN_FACTORS_UNDER_L0 OPS_SBTR_LOC = OPS_SBTR_LOC + COST_SUBTREES_UNDER_LO OPSA_LOC = OPSA_LOC + OPSA_UNDER_L0 OPS_SUBTREE = real(OPS_SBTR_LOC) OPSA = real(OPSA_LOC) RETURN END SUBROUTINE CMUMPS_ANA_DISTM SUBROUTINE CMUMPS_ANA_DISTM_UNDERL0OMP( & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP , VIRT_L0_OMP , VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP , PHYS_L0_OMP , PERM_L0_OMP, & PTR_LEAFS_L0_OMP, & KEEP, N, NE, STEP, FRERE, FILS, DAD, ND, & MYID, PROCNODE, & I4_L0, NBSTATS_I4, I8_L0, NBSTATS_I8, NBTHREADS, & SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB_UD, & TNSTK, MAXFR, & MAX_FRONT_SURFACE_LOCAL, MAX_SIZE_FACTOR, & ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS, & OPS_SBTR_LOC, OPSA_LOC, NBNODES_BLR, & IFLAG, IERROR ) IMPLICIT NONE INTEGER, INTENT(IN) :: LPOOL_B_L0_OMP, & L_VIRT_L0_OMP, L_PHYS_L0_OMP INTEGER, INTENT(IN) :: IPOOL_B_L0_OMP ( LPOOL_B_L0_OMP ) INTEGER, INTENT(IN) :: VIRT_L0_OMP ( L_VIRT_L0_OMP ) INTEGER, INTENT(IN) :: VIRT_L0_OMP_MAPPING ( L_VIRT_L0_OMP ) INTEGER, INTENT(IN) :: PHYS_L0_OMP ( L_PHYS_L0_OMP ) INTEGER, INTENT(IN) :: PERM_L0_OMP ( L_PHYS_L0_OMP ) INTEGER, INTENT(IN) :: PTR_LEAFS_L0_OMP ( L_PHYS_L0_OMP + 1 ) INTEGER, INTENT(IN) :: N INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER, INTENT(IN) :: NE(KEEP(28)) INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: FRERE(KEEP(28)) INTEGER, INTENT(IN) :: FILS(N) INTEGER, INTENT(IN) :: DAD(KEEP(28)), ND(KEEP(28)) INTEGER, INTENT(IN) :: MYID, PROCNODE(KEEP(28)) INTEGER, INTENT(IN) :: NBSTATS_I4, NBSTATS_I8, NBTHREADS INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(OUT) :: TNSTK(KEEP(28)) INTEGER, INTENT(OUT) :: I4_L0 (NBSTATS_I4, NBTHREADS) INTEGER(8), INTENT(OUT):: I8_L0 (NBSTATS_I8, NBTHREADS) INTEGER(8), INTENT(OUT):: ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS, & SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB_UD INTEGER, INTENT(OUT) :: MAXFR, NBNODES_BLR INTEGER(8), INTENT(OUT):: MAX_FRONT_SURFACE_LOCAL, & MAX_SIZE_FACTOR DOUBLE PRECISION, INTENT(OUT) :: OPS_SBTR_LOC, OPSA_LOC INTEGER, ALLOCATABLE, DIMENSION(:) :: LSTKI INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR_if_LRCB, & LSTKRLR_CB_UD, & LSTKRLR_CB_WC DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: OPSA_LOC_L0_OMP INTEGER :: ITH INTEGER :: NSTEPS INTEGER :: allocok INTEGER(8):: ISTKR, ISTKR_if_LRCB, ISTKRLR_CB_UD, & ISTKRLR_CB_WC INTEGER :: ISTKI, ISTKI_OOC, ITOP NSTEPS = KEEP(28) ALLOCATE( LSTKR(NSTEPS), LSTKI(NSTEPS) , & LSTKR_if_LRCB(NSTEPS), LSTKRLR_CB_UD(NSTEPS), & LSTKRLR_CB_WC(NSTEPS), & OPSA_LOC_L0_OMP(NBTHREADS), & & stat=allocok) IF ( allocok .GT. 0 ) THEN IFLAG =-7 IERROR = 4*NSTEPS+NBTHREADS RETURN ENDIF TNSTK = NE OPSA_LOC_L0_OMP(1:NBTHREADS) = 0.0D0 OPS_SBTR_LOC = 0.0D0 OPSA_LOC = 0.0D0 I4_L0(1:NBSTATS_I4, 1:NBTHREADS) = 0 I8_L0(1:NBSTATS_I8, 1:NBTHREADS) = 0_8 NBNODES_BLR = 0 SIZECB_UNDER_L0 = 0_8 SIZECB_UNDER_L0_IF_LRCB_UD = 0_8 MAXFR = 0 MAX_FRONT_SURFACE_LOCAL = 0_8 MAX_SIZE_FACTOR = 0_8 ENTRIES_IN_FACTORS_LOC = 0_8 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 DO ITH = 1, NBTHREADS ISTKI = 0 ISTKI_OOC = 0 ITOP = 0 ISTKR = 0_8 ISTKR_if_LRCB = 0_8 ISTKRLR_CB_UD = 0_8 ISTKRLR_CB_WC = 0_8 ISTKR = 0_8 CALL CMUMPS_ANA_DISTM_UNDERL0_1THR ( ITH, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP , VIRT_L0_OMP , VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP , PHYS_L0_OMP , PERM_L0_OMP, & PTR_LEAFS_L0_OMP, KEEP, N, NE, NSTEPS, & STEP, FRERE, FILS, DAD, ND, MYID, PROCNODE, & ISTKR, ISTKI, ISTKI_OOC, ISTKR_if_LRCB, ISTKRLR_CB_UD, & ISTKRLR_CB_WC, ITOP, & LSTKI, LSTKR, LSTKR_if_LRCB, LSTKRLR_CB_UD, LSTKRLR_CB_WC, & I4_L0(1,ITH), I4_L0(2,ITH), I4_L0(3,ITH), I4_L0(4,ITH), & I8_L0(1,ITH), I8_L0(2,ITH), I8_L0(3,ITH), I8_L0(4,ITH), & I8_L0(5,ITH), I8_L0(6,ITH), I8_L0(7,ITH), I8_L0(8,ITH), & I8_L0(9,ITH), I8_L0(10,ITH), I8_L0(11,ITH), I8_L0(12,ITH), & I8_L0(13,ITH), I8_L0(14,ITH), I8_L0(15,ITH), I8_L0(16,ITH), & I8_L0(17,ITH), I8_L0(18,ITH), I8_L0(19,ITH), I8_L0(20,ITH), & I8_L0(21,ITH), I8_L0(22,ITH), & NBNODES_BLR, TNSTK, MAXFR, & MAX_FRONT_SURFACE_LOCAL, MAX_SIZE_FACTOR, & ENTRIES_IN_FACTORS_LOC, ENTRIES_IN_FACTORS_LOC_MASTERS, & OPS_SBTR_LOC, OPSA_LOC_L0_OMP(ITH), IFLAG, IERROR ) OPSA_LOC = OPSA_LOC + OPSA_LOC_L0_OMP(ITH) I8_L0(23,ITH) = ISTKR SIZECB_UNDER_L0 = SIZECB_UNDER_L0 + ISTKR I8_L0(24,ITH) = ISTKR_if_LRCB + ISTKRLR_CB_UD SIZECB_UNDER_L0_IF_LRCB_UD = SIZECB_UNDER_L0_IF_LRCB_UD + & ISTKR_if_LRCB + ISTKRLR_CB_UD ENDDO DEALLOCATE( LSTKR, LSTKI , & LSTKR_if_LRCB, LSTKRLR_CB_UD, & LSTKRLR_CB_WC, & OPSA_LOC_L0_OMP) RETURN END SUBROUTINE CMUMPS_ANA_DISTM_UNDERL0OMP SUBROUTINE CMUMPS_ANA_DISTM_UNDERL0_1THR ( ITHREAD, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP , VIRT_L0_OMP , VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP , PHYS_L0_OMP , PERM_L0_OMP, & PTR_LEAFS_L0_OMP, KEEP, N, NE, NSTEPS, STEP, FRERE, FILS, DAD, & ND, MYID, PROCNODE, ISTKR, ISTKI, ISTKI_OOC, ISTKR_if_LRCB, & ISTKRLR_CB_UD, ISTKRLR_CB_WC, ITOP, & LSTKI, LSTKR, LSTKR_if_LRCB, LSTKRLR_CB_UD, LSTKRLR_CB_WC, & NIRADU, NIRNEC, NIRADU_OOC, NIRNEC_OOC, NRLADU, NRLNEC, & NRLNEC_ACTIVE, NRLADU_if_LR_LU, NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, NRLNECOOC_if_LR_LUCB, NRLNEC_if_LR_CB, & NRLADULR_UD, NRLADULR_WC, NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC, & PEAK_LRLU_UD, PEAK_OOC_LRLU_UD, PEAK_OOC_LRLU_WC, & PEAK_LRLUCB_UD, PEAK_LRLUCB_WC, PEAK_OOC_LRLUCB_UD, & PEAK_OOC_LRLUCB_WC, PEAK_LRCB_UD, PEAK_OOC_LRCB_UD, & NBNODES_BLR, TNSTK, MAXFR, & MAX_FRONT_SURFACE_LOCAL, MAX_SIZE_FACTOR, & ENTRIES_IN_FACTORS_LOC, ENTRIES_IN_FACTORS_LOC_MASTERS, & OPS_SBTR_LOC, OPSA_LOC, IFLAG, IERROR ) USE CMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE IMPLICIT NONE INTEGER, INTENT(IN) :: ITHREAD, LPOOL_B_L0_OMP, & L_VIRT_L0_OMP, L_PHYS_L0_OMP INTEGER, INTENT(IN) :: IPOOL_B_L0_OMP ( LPOOL_B_L0_OMP ) INTEGER, INTENT(IN) :: VIRT_L0_OMP ( L_VIRT_L0_OMP ) INTEGER, INTENT(IN) :: VIRT_L0_OMP_MAPPING ( L_VIRT_L0_OMP ) INTEGER, INTENT(IN) :: PHYS_L0_OMP ( L_PHYS_L0_OMP ) INTEGER, INTENT(IN) :: PERM_L0_OMP ( L_PHYS_L0_OMP ) INTEGER, INTENT(IN) :: PTR_LEAFS_L0_OMP ( L_PHYS_L0_OMP + 1 ) INTEGER, INTENT(IN) :: KEEP(500), N, NSTEPS INTEGER, INTENT(IN) :: NE(NSTEPS) INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: FRERE(NSTEPS) INTEGER, INTENT(IN) :: FILS(N) INTEGER, INTENT(IN) :: DAD(NSTEPS), ND(NSTEPS) INTEGER, INTENT(IN) :: MYID, PROCNODE(NSTEPS) DOUBLE PRECISION, INTENT(INOUT) :: OPS_SBTR_LOC DOUBLE PRECISION, INTENT(OUT) :: OPSA_LOC INTEGER, INTENT(INOUT) :: NBNODES_BLR INTEGER, INTENT(INOUT) :: TNSTK(NSTEPS) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: MAXFR INTEGER(8), INTENT(INOUT):: MAX_FRONT_SURFACE_LOCAL, & MAX_SIZE_FACTOR INTEGER(8), INTENT(INOUT):: ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS INTEGER(8), INTENT(INOUT) :: & ISTKR, ISTKR_if_LRCB, & ISTKRLR_CB_UD, ISTKRLR_CB_WC INTEGER, INTENT(INOUT) :: ISTKI, ISTKI_OOC, ITOP INTEGER, INTENT(INOUT) :: LSTKI(NSTEPS) INTEGER(8), INTENT(INOUT) :: LSTKR(NSTEPS), & LSTKR_if_LRCB(NSTEPS), & LSTKRLR_CB_UD(NSTEPS), & LSTKRLR_CB_WC(NSTEPS) INTEGER, INTENT(OUT) :: NIRADU, NIRNEC, NIRADU_OOC, NIRNEC_OOC INTEGER(8), INTENT(OUT):: NRLADU, NRLNEC, NRLNEC_ACTIVE, & NRLADU_if_LR_LU, NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, NRLNEC_if_LR_CB, & NRLADULR_UD, NRLADULR_WC, NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC, & PEAK_LRLU_UD, PEAK_OOC_LRLU_UD, PEAK_OOC_LRLU_WC, & PEAK_LRLUCB_UD, PEAK_LRLUCB_WC, PEAK_OOC_LRLUCB_UD, & PEAK_OOC_LRLUCB_WC, PEAK_LRCB_UD, PEAK_OOC_LRCB_UD LOGICAL :: INSSARBR INTEGER :: VIRTUAL_TASK, PHYSICAL_TASK INTEGER :: INODE, IFATH, I INTEGER :: SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC INTEGER :: EXTRA_PERM_INFO_OOC LOGICAL :: PACKED_CB INTEGER(8) :: NRLADU_ROOT_3 INTEGER :: FLAG_L0OMP PARAMETER (FLAG_L0OMP=-2014) INCLUDE 'mumps_headers.h' IF (KEEP(50).eq.2) THEN EXTRA_PERM_INFO_OOC = 1 ELSE IF (KEEP(50).eq.0) THEN EXTRA_PERM_INFO_OOC = 2 ELSE EXTRA_PERM_INFO_OOC = 0 ENDIF PACKED_CB=( KEEP(215).EQ.0 .AND. KEEP(50).NE.0 ) NRLADU_ROOT_3 = 0_8 #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 DO VIRTUAL_TASK = 1, L_VIRT_L0_OMP - 1 IF (VIRT_L0_OMP_MAPPING(VIRTUAL_TASK) .EQ. ITHREAD) THEN DO PHYSICAL_TASK= & VIRT_L0_OMP ( VIRTUAL_TASK ), & VIRT_L0_OMP ( VIRTUAL_TASK + 1 ) - 1 DO I = PTR_LEAFS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK ) ), & PTR_LEAFS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK )+1 ) +1, & - 1 INODE = IPOOL_B_L0_OMP(I) IF (INODE .LE. 0) THEN CYCLE ENDIF 10 CONTINUE IFATH = DAD(STEP(INODE)) CALL CMUMPS_PROCESS_NODE_UNDERL0 () IF (IFATH .NE. 0) THEN TNSTK( STEP(IFATH) ) = TNSTK( STEP(IFATH) ) - 1 ENDIF IF ( PHYS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK ) ) & .EQ. INODE ) THEN TNSTK(STEP(INODE)) = FLAG_L0OMP ELSE IF ( TNSTK( STEP(IFATH) ) .EQ. 0 ) THEN INODE = IFATH GOTO 10 ENDIF ENDDO ENDDO ENDIF ENDDO RETURN CONTAINS SUBROUTINE CMUMPS_PROCESS_NODE_UNDERL0 IMPLICIT NONE INTEGER :: LRSTATUS, IDUMMY LOGICAL :: COMPRESS_PANEL, COMPRESS_CB INTEGER :: STKI INTEGER(8) :: LSTK INTEGER :: K, NFR, NFRF, NELIM, NELIMF, NCB, NSTK, & LEVEL, LEVELF, IN, & MAXITEMPCB, PANEL_SIZE, SIZECBI INTEGER(8):: NFR8, NCB8, & K464_8, K465_8, & CURRENT_ACTIVE_MEM, & ENTRIES_NODE_LOWER_PART, ENTRIES_NODE_UPPER_PART, & NRLADU_CURRENT, NRLADU_CURRENT_MISSING INTEGER(8) :: SIZEFRNOCBLU INTEGER :: IDUMMY_ARRAY(1) INTEGER(8):: SIZECB, SIZECBINFR INTEGER(8):: SIZECB_if_LRCB INTEGER(8):: SIZECBLR_UD, SIZECBLR_WC LOGICAL :: MASTER, MASTERF, STACKCB DOUBLE PRECISION :: OPS_NODE INTRINSIC int INTEGER CMUMPS_OOC_GET_PANEL_SIZE EXTERNAL CMUMPS_OOC_GET_PANEL_SIZE INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR EXTERNAL MUMPS_MAX_SURFCB_NBROWS EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, & MUMPS_IN_OR_ROOT_SSARBR MAXITEMPCB = 0 STACKCB = .TRUE. NFR = ND(STEP(INODE))+KEEP(253) NFR8 = int(NFR,8) NSTK = NE(STEP(INODE)) NELIM = 0 IN = INODE 100 NELIM = NELIM + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IFATH = DAD(STEP(INODE)) MASTER = MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID LEVEL = MUMPS_TYPENODE(PROCNODE(STEP(INODE)),KEEP(199)) INSSARBR = MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) IDUMMY_ARRAY(1) = 0 NCB = NFR-NELIM NCB8 = int(NCB,8) SIZECBINFR = NCB8*NCB8 IF (KEEP(50).EQ.0) THEN SIZECB = SIZECBINFR ELSE IF ( PACKED_CB ) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = SIZECBINFR ENDIF ENDIF IDUMMY = -99999 CALL IS_FRONT_BLR_CANDIDATE (INODE, LEVEL, NFR, NELIM, & KEEP(494), 1, KEEP(490), & KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, IDUMMY) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) IF (COMPRESS_PANEL.OR.COMPRESS_CB) NBNODES_BLR = NBNODES_BLR+1 IF (COMPRESS_PANEL) THEN K464_8 = int(KEEP(464),8) ELSE K464_8 = 1000_8 ENDIF IF (COMPRESS_CB) THEN K465_8 = int(KEEP(465),8) SIZECB_if_LRCB = 0_8 SIZECBLR_UD = SIZECB*K465_8/1000_8 SIZECBLR_WC = SIZECB ELSE K465_8 = 1000_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = SIZECB ENDIF SIZECBI = 2* NCB + SIZEHEADER IF(KEEP(86).EQ.1)THEN IF(MASTER.AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)), KEEP(199))) & )THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8) ENDIF ENDIF NIRADU = NIRADU + 2*NFR + SIZEHEADER NIRADU_OOC = NIRADU_OOC + 2*NFR + SIZEHEADER_OOC PANEL_SIZE = CMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NFR, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) IF (KEEP(50).EQ.0) THEN IF (KEEP(251) .EQ. 2) THEN NRLADU_CURRENT = int(NELIM,8) * int(NFR,8) SIZEFRNOCBLU = int(NFR-NELIM,8)*int(NELIM) ELSE NRLADU_CURRENT = int(NELIM,8)*int(2*NFR-NELIM,8) SIZEFRNOCBLU = 0_8 ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR = max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ELSE IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 ) THEN CALL MUMPS_LDLTPANEL_STORAGE( NELIM, KEEP, & IDUMMY_ARRAY(1), NRLADU_CURRENT ) SIZEFRNOCBLU = int(NELIM,8)*int(NELIM,8) - & NRLADU_CURRENT NRLADU_CURRENT = NRLADU_CURRENT + & int(NELIM,8) * int(NFR-NELIM,8) ELSE SIZEFRNOCBLU = 0_8 NRLADU_CURRENT = int(NELIM,8)*int(NFR,8) ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ENDIF IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_CURRENT_MISSING = 0_8 NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT ENDIF SIZECBI = 2* NCB + SIZEHEADER NIRNEC = max(NIRNEC, & NIRADU+ISTKI+SIZECBI+MAXITEMPCB) NIRNEC_OOC = max(NIRNEC_OOC, & NIRADU_OOC+ISTKI_OOC+SIZECBI+MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) CURRENT_ACTIVE_MEM = ISTKR+SIZECBINFR IF ( KEEP(50).NE.0 .AND. LEVEL.EQ.1 ) THEN SIZEFRNOCBLU = SIZEFRNOCBLU + int(NELIM,8)*int(NCB,8) ENDIF CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + SIZEFRNOCBLU NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = & max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) 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 NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT_MISSING) NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (NFR.GT.MAXFR) MAXFR = NFR IF (NSTK.GT.0) THEN DO 70 K=1,NSTK LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK IF (K==1 .AND. INSSARBR.AND.KEEP(234).NE.0 & .AND.KEEP(55).EQ.0) THEN ELSE CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTK ENDIF LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in CMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF 70 CONTINUE ENDIF IF ( & ( (INODE.NE.KEEP(20)).OR.(KEEP(60).EQ.0) ) & .AND. & ( (INODE.NE.KEEP(38)).OR.(KEEP(60).LE.1) ) & ) & THEN ENTRIES_NODE_LOWER_PART = int(NFR-NELIM,8) * int(NELIM,8) IF ( KEEP(50).EQ.0 ) THEN ENTRIES_NODE_UPPER_PART = int(NFR,8) * int(NELIM,8) ELSE ENTRIES_NODE_UPPER_PART = & (int(NELIM,8)*int(NELIM+1,8))/2_8 ENDIF IF (KEEP(50).EQ.2 .AND. LEVEL.EQ.3) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM, 0, & 1,OPS_NODE) ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) ENDIF ELSE OPS_NODE = 0.0D0 ENTRIES_NODE_UPPER_PART = 0_8 ENTRIES_NODE_LOWER_PART = 0_8 ENDIF ENTRIES_IN_FACTORS_LOC_MASTERS = & ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC_MASTERS OPSA_LOC = OPSA_LOC + dble(OPS_NODE) IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) .OR. NE(STEP(INODE))==0) THEN OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ENDIF IF (IFATH .EQ. 0) THEN RETURN 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 LEVELF = MUMPS_TYPENODE(PROCNODE(STEP(IFATH)),KEEP(199)) MASTERF= MUMPS_PROCNODE(PROCNODE(STEP(IFATH)), & KEEP(199)).EQ.MYID IF ( INSSARBR .AND. KEEP(234).NE.0) THEN NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+SIZECB+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) ENDIF PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (KEEP(50).NE.0.AND.LEVELF.NE.3 & .AND.PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF SIZECBI = 2+ XSIZE_IC IF (STACKCB) THEN IF (FRERE(STEP(INODE)).EQ.0) THEN write(*,*) ' ERROR 3 in CMUMPS_ANA_DISTM' CALL MUMPS_ABORT() ENDIF ITOP = ITOP + 1 IF ( ITOP .GT. NSTEPS ) THEN WRITE(*,*) 'ERROR 4 in CMUMPS_ANA_DISTM ' CALL MUMPS_ABORT() 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) NIRNEC = max(NIRNEC,NIRADU+ISTKI) NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR) LSTKR_if_LRCB(ITOP) = SIZECB_if_LRCB ISTKR_if_LRCB = ISTKR_if_LRCB + LSTKR_if_LRCB(ITOP) LSTKRLR_CB_UD(ITOP) = SIZECBLR_UD ISTKRLR_CB_UD = ISTKRLR_CB_UD + LSTKRLR_CB_UD(ITOP) LSTKRLR_CB_WC(ITOP) = SIZECBLR_WC ISTKRLR_CB_WC = ISTKRLR_CB_WC + LSTKRLR_CB_WC(ITOP) NRLNECLR_CB_UD = max(NRLNECLR_CB_UD, ISTKRLR_CB_UD) NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) ENDIF ENDIF END SUBROUTINE CMUMPS_PROCESS_NODE_UNDERL0 END SUBROUTINE CMUMPS_ANA_DISTM_UNDERL0_1THR SUBROUTINE CMUMPS_PREP_ANA_DISTM_ABOVEL0 ( & N, SLAVEF, COMM, MYID, & STEP, DAD, ICNTL, LP, LPOK, INFO, & PHYS_L0_OMP, L_PHYS_L0_OMP, & IPOOL_A_L0_OMP, LPOOL_A_L0_OMP, & KEEP, TNSTK_afterL0, & FLAGGED_LEAVES & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, INTENT(IN) :: N, SLAVEF, COMM, MYID, ICNTL(60), & LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: L_PHYS_L0_OMP, LPOOL_A_L0_OMP INTEGER, INTENT(IN) :: PHYS_L0_OMP(max(1,L_PHYS_L0_OMP)), & IPOOL_A_L0_OMP(max(1,LPOOL_A_L0_OMP)) INTEGER, INTENT(IN) :: KEEP(500) INTEGER, INTENT(IN) :: STEP(N), DAD(KEEP(28)) INTEGER, INTENT(OUT) :: FLAGGED_LEAVES(KEEP(28)) INTEGER, INTENT(INOUT) :: TNSTK_afterL0(KEEP(28)), INFO(80) INTEGER :: ISLAVE, IERR, INODE, I, NSTEPS, allocok INTEGER :: SIZE_BUFREC, Itemp, SIZE_RECEIVED INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFREC INTEGER, ALLOCATABLE, DIMENSION(:) :: IREQ INTEGER :: MPI_STATUS(MPI_STATUS_SIZE) SIZE_BUFREC = 0 CALL MPI_ALLREDUCE(L_PHYS_L0_OMP, Itemp, 1, & MPI_INTEGER, MPI_MAX, COMM, IERR) SIZE_BUFREC = Itemp CALL MPI_ALLREDUCE(LPOOL_A_L0_OMP, Itemp, 1, & MPI_INTEGER, MPI_MAX, COMM, IERR) SIZE_BUFREC= max(SIZE_BUFREC, Itemp) ALLOCATE(IREQ(SLAVEF), BUFREC(SIZE_BUFREC), stat=allocok) IF (allocok.GT.0) THEN IF ( LPOK ) THEN WRITE(LP, '(A)') & ' Allocation failed in CMUMPS_PREP_ANA_DISTM_ABOVEL0' END IF INFO(1)= -7 INFO(2)= SLAVEF+SIZE_BUFREC ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) RETURN NSTEPS = KEEP(28) DO I=1, NSTEPS FLAGGED_LEAVES(I) = 0 ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_ISEND( IPOOL_A_L0_OMP, LPOOL_A_L0_OMP, & MPI_INTEGER, ISLAVE - 1, F_IPOOLAFTER, COMM, & IREQ( ISLAVE ), IERR ) ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_RECV( BUFREC(1), SIZE_BUFREC, & MPI_INTEGER, ISLAVE-1, & F_IPOOLAFTER, COMM, MPI_STATUS, IERR ) CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER, & SIZE_RECEIVED, IERR) DO I=1,SIZE_RECEIVED INODE = BUFREC(I) FLAGGED_LEAVES(STEP(INODE))=INODE ENDDO ENDDO IF (LPOOL_A_L0_OMP.GT.0) THEN DO I=1, LPOOL_A_L0_OMP INODE = IPOOL_A_L0_OMP(I) FLAGGED_LEAVES(STEP(INODE))=INODE ENDDO ENDIF DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_WAIT( IREQ( ISLAVE ), MPI_STATUS, IERR ) ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_ISEND(PHYS_L0_OMP, L_PHYS_L0_OMP, & MPI_INTEGER, ISLAVE - 1, F_PHYS_L0, COMM, & IREQ( ISLAVE ), IERR ) ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_RECV( BUFREC(1), SIZE_BUFREC, & MPI_INTEGER, ISLAVE-1, & F_PHYS_L0, COMM, MPI_STATUS, IERR ) CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER, & SIZE_RECEIVED, IERR) DO I=1,SIZE_RECEIVED INODE = BUFREC(I) IF (DAD(STEP(INODE)).NE.0) THEN TNSTK_afterL0(STEP(DAD(STEP(INODE)))) & = TNSTK_afterL0(STEP(DAD(STEP(INODE)))) - 1 ENDIF ENDDO ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_WAIT( IREQ( ISLAVE ), MPI_STATUS, IERR ) ENDDO IF (allocated(IREQ)) DEALLOCATE(IREQ) IF (allocated(BUFREC)) DEALLOCATE(BUFREC) RETURN END SUBROUTINE CMUMPS_PREP_ANA_DISTM_ABOVEL0 MUMPS_5.8.1/src/mumps_metis64.c0000664000175000017500000001741315042446422016116 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include /* For NULL constant (stddef.h) and debug printings */ #include "mumps_metis64.h" #if defined(parmetis) || defined(parmetis3) /*PARMETIS*/ #if defined(parmetis3) /* Provide prototype by hand. This is because we are not sure * at compilation/preprocessing time whether we use a 32-bit * or a 64-bit metis */ void ParMETIS_V3_NodeND(MUMPS_INT8 *first, MUMPS_INT8 *vertloctab, MUMPS_INT8 *edgeloctab, MUMPS_INT *numflag, MUMPS_INT *options, MUMPS_INT8 *order, MUMPS_INT8 *sizes, MPI_Comm *Ccomm); #else #include "metis.h" #include "parmetis.h" /* Prototypes from parmetis.h will be used */ #endif void MUMPS_CALL MUMPS_PARMETIS_64(MUMPS_INT8 *first, MUMPS_INT8 *vertloctab, MUMPS_INT8 *edgeloctab, #if defined(parmetis3) MUMPS_INT *numflag, MUMPS_INT *options, #else MUMPS_INT8 *numflag, MUMPS_INT8 *options, #endif MUMPS_INT8 *order, MUMPS_INT8 *sizes, MUMPS_INT *comm, MUMPS_INT *ierr) { MPI_Comm int_comm; #if defined(parmetis) # if (IDXTYPEWIDTH == 64) int iierr; #endif #endif int_comm = MPI_Comm_f2c(*comm); #if defined(parmetis3) /* Prototype may not match with 32-bit integers and Parmetis3 */ ParMETIS_V3_NodeND(first, vertloctab, edgeloctab, numflag, options, order, sizes, &int_comm); #elif defined(parmetis) # if (IDXTYPEWIDTH == 64) *ierr=0; iierr=ParMETIS_V3_NodeND(first, vertloctab, edgeloctab, numflag, options, order, sizes, &int_comm); if(iierr != METIS_OK) *ierr=1; # else /* SHOULD NEVER BE CALLED */ printf("** Error: ParMETIS version >= 4, IDXTYPE WIDTH !=64, but MUMPS_PARMETIS_64 was called\n"); *ierr=1; # endif #endif return; } void MUMPS_CALL MUMPS_PARMETIS_VWGT_64(MUMPS_INT8 *first, MUMPS_INT8 *vertloctab, MUMPS_INT8 *edgeloctab, #if defined(parmetis3) MUMPS_INT *numflag, MUMPS_INT *options, #else MUMPS_INT8 *numflag, MUMPS_INT8 *options, #endif MUMPS_INT8 *order, MUMPS_INT8 *sizes, MUMPS_INT *comm, MUMPS_INT8 *vwgt, MUMPS_INT *ierr) { MPI_Comm int_comm; #if defined(parmetis) # if (IDXTYPEWIDTH == 64) int iierr; #endif #endif int_comm = MPI_Comm_f2c(*comm); #if defined(parmetis3) /* Prototype may not match with 32-bit integers and Parmetis3 */ /* vwgt not used */ ParMETIS_V3_NodeND(first, vertloctab, edgeloctab, numflag, options, order, sizes, &int_comm); #elif defined(parmetis) # if (IDXTYPEWIDTH == 64) *ierr=0; iierr=ParMETIS_V32_NodeND(first, vertloctab, edgeloctab, vwgt, numflag, NULL, NULL, NULL, NULL, NULL, NULL, NULL, order, sizes, &int_comm); if(iierr != METIS_OK) *ierr=1; # else /* SHOULD NEVER BE CALLED */ printf("** Error: ParMETIS version >= 4, IDXTYPE WIDTH !=64, but MUMPS_PARMETIS_VWGT_64 was called\n"); *ierr=1; # endif #endif return; } #endif #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) #if defined(metis4) || defined(parmetis3) /* parmetis3 comes with metis4 */ /* Provide prototype by hand. This is because we are not sure * at compilation/preprocessing time whether we use a 32-bit * or a 64-bit metis */ void METIS_PartGraphKway(int *, MUMPS_INT8 *, MUMPS_INT8 *, MUMPS_INT8 *, MUMPS_INT8 *, int *, int *, int *, int *, int *, MUMPS_INT8 *); #else /* Prototype properly defined in metis.h * One can rely on IDXTYPEWIDTH to know at compilation/preprocessing * time whether we use a 32-bit or a 64-bit metis */ #include "metis.h" #endif /* Interface for metis k-way partitioning with 64-bit ints */ void MUMPS_CALL MUMPS_METIS_KWAY_64(MUMPS_INT8 *n, MUMPS_INT8 *iptr, MUMPS_INT8 *jcn, MUMPS_INT8 *k, MUMPS_INT8 *part) /* n -- the size of the graph to be partitioned iptr -- pointer to the beginning of each node's adjacency list jcn -- jcn[iptr[i]:iptr[i+1]-1] contains the list of neighbors of node i k -- the number of parts part -- part[i] is the part node i belongs to */ /* SELECTIVE I8 FIXME: add an argument *ierr, check it on exit */ { #if defined(metis4) || defined(parmetis3) MUMPS_INT numflag, edgecut, wgtflag, options[8]; MUMPS_INT kINT, nINT; options[0] = 0; /* unweighted partitioning */ wgtflag = 0; /* Use 1-based fortran numbering */ numflag = 1; /* n and k are MUMPS_INT */ nINT=(MUMPS_INT)(*n); kINT=(MUMPS_INT)(*k); /* void METIS_PartGraphKway(int *, idxtype *, idxtype *, idxtype *, idxtype *, int *, int *, int *, int *, int *, idxtype *); */ METIS_PartGraphKway(&nINT, iptr, jcn, NULL, NULL, &wgtflag, &numflag, &kINT, options, &edgecut, part); #else /* METIS >= 5 */ int ierr; # if (IDXTYPEWIDTH == 64) MUMPS_INT8 ncon, edgecut, options[METIS_NOPTIONS]; ierr=METIS_SetDefaultOptions(options); /* Use 1-based fortran numbering */ options[METIS_OPTION_NUMBERING] = 1; ncon = 1; ierr = METIS_PartGraphKway(n, &ncon, iptr, jcn, NULL, NULL, NULL, k, NULL, NULL, options, &edgecut, part); # else /* SHOULD NEVER BE REACHED */ printf("** Error: METIS version >= 4, IDXTYPE WIDTH !=64, but MUMPS_METIS_KWAY_64 was called\n"); ierr=1; # endif #endif return; } /* Interface for metis k-way partitioning with 64-bit ints and weights on vertices*/ void MUMPS_CALL MUMPS_METIS_KWAY_AB_64(MUMPS_INT8 *n, MUMPS_INT8 *iptr, MUMPS_INT8 *jcn, MUMPS_INT8 *k, MUMPS_INT8 *part, MUMPS_INT8 *vwgt ) /* n -- the size of the graph to be partitioned iptr -- pointer to the beginning of each node's adjacency list jcn -- jcn[iptr[i]:iptr[i+1]-1] contains the list of neighbors of node i k -- the number of parts part -- part[i] is the part node i belongs to vwgt -- weights of the vertices */ /* SELECTIVE I8 FIXME: add an argument *ierr, check it on exit */ { #if defined(metis4) || defined(parmetis3) MUMPS_INT numflag, edgecut, wgtflag, options[8]; MUMPS_INT kINT, nINT; options[0] = 0; /* unweighted partitioning */ wgtflag = 0; /* Use 1-based fortran numbering */ numflag = 1; /* n and k are MUMPS_INT */ nINT=(MUMPS_INT)(*n); kINT=(MUMPS_INT)(*k); /* void METIS_PartGraphKway(int *, idxtype *, idxtype *, idxtype *, idxtype *, int *, int *, int *, int *, int *, idxtype *); */ METIS_PartGraphKway(&nINT, iptr, jcn, vwgt, NULL, &wgtflag, &numflag, &kINT, options, &edgecut, part); #else /* METIS >= 5 */ int ierr; # if (IDXTYPEWIDTH == 64) MUMPS_INT8 ncon, edgecut, options[METIS_NOPTIONS]; ierr=METIS_SetDefaultOptions(options); /* Use 1-based fortran numbering */ options[METIS_OPTION_NUMBERING] = 1; ncon = 1; ierr = METIS_PartGraphKway(n, &ncon, iptr, jcn, vwgt, NULL, NULL, k, NULL, NULL, options, &edgecut, part); # else /* SHOULD NEVER BE REACHED */ printf("** Error: METIS version >= 4, IDXTYPE WIDTH !=64, but MUMPS_METIS_KWAY_AB_64 was called\n"); ierr=1; # endif #endif return; } #endif MUMPS_5.8.1/src/dsol_lr.F0000664000175000017500000010307715042446437015013 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_SOL_LR USE DMUMPS_LR_TYPE USE DMUMPS_LR_CORE USE MUMPS_LR_STATS USE DMUMPS_LR_DATA_M, only: BLR_ARRAY IMPLICIT NONE CONTAINS SUBROUTINE DMUMPS_SOL_FWD_LR_SU & (INODE, N, IWHDLR, NPIV_GLOBAL, NSLAVES, & IW, IPOS_INIT, LIW, & LIELL, WCB, LWCB, & LD_WCBPIV, LD_WCBCB, & PPIV_INIT, PCB_INIT, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, KEEP8, OOCWRITE_COMPATIBLE_WITH_BLR, & IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, N, IWHDLR, NPIV_GLOBAL, NSLAVES INTEGER, INTENT(IN) :: MTYPE, LIELL, KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: LIW, IPOS_INIT, LRHSINTR INTEGER, INTENT(IN) :: IW(LIW), POSINRHSINTR_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, PPIV_INIT, PCB_INIT INTEGER, INTENT(IN) :: LD_WCBPIV, LD_WCBCB, NRHS, JBDEB, JBFIN DOUBLE PRECISION, INTENT(INOUT) :: WCB(LWCB) INTEGER, INTENT(INOUT) :: IFLAG, IERROR DOUBLE PRECISION, INTENT(INOUT) :: RHSINTR(LRHSINTR, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: I, NPARTSASS, NB_BLR , NELIM, LDADIAG, & DIAGSIZ_DYN, DIAGSIZ_STA, IBEG_BLR, IEND_BLR, & LD_CB, NRHS_B, IPOS, KCB INTEGER(8) :: PPIV, PCB INTEGER :: LAST_BLR DOUBLE PRECISION, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) NRHS_B = JBFIN-JBDEB+1 IF (MTYPE.EQ.1) THEN IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ELSE WRITE(6,*) " Internal error in DMUMPS_SOL_FWD_SU_MASTER" ENDIF ELSE IF (associated(BLR_ARRAY(IWHDLR)%PANELS_U)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_U) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ENDIF ENDIF IF (NSLAVES.EQ.0 .OR. (KEEP(50).eq.0 .and. MTYPE .NE.1)) THEN LAST_BLR = NB_BLR ELSE LAST_BLR = NPARTSASS ENDIF IPOS = IPOS_INIT PPIV = PPIV_INIT DO I=1, NPARTSASS IBEG_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I) IEND_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) -1 DIAGSIZ_DYN = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) - & IBEG_BLR DIAGSIZ_STA = BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(I+1) - & IBEG_BLR IF (KEEP(50).NE.0) THEN LDADIAG = DIAGSIZ_DYN ELSE LDADIAG = DIAGSIZ_STA ENDIF IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN PCB = PCB_INIT ELSE PCB = PPIV + int(DIAGSIZ_DYN,8) ENDIF IF ( DIAGSIZ_DYN.EQ.0) CYCLE NELIM = DIAGSIZ_STA - DIAGSIZ_DYN IF ( MTYPE .EQ. 1 ) THEN BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL ELSE BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_U(I)%LRB_PANEL END IF DIAG => BLR_ARRAY(IWHDLR)%DIAG_BLOCKS(I)%DIAG_BLOCK CALL DMUMPS_SOLVE_FWD_TRSOLVE (DIAG(1), & int(size(DIAG),8), 1_8, & DIAGSIZ_DYN , LDADIAG, NRHS_B, WCB, LWCB, NPIV_GLOBAL, & PPIV, MTYPE, KEEP) IF (NELIM.GT.0) THEN KCB = int(PCB-PPIV_INIT+1) IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN LD_CB = LD_WCBCB ELSE LD_CB = LD_WCBPIV ENDIF IF (MTYPE.EQ.1) THEN IF (KCB.LE.NPIV_GLOBAL .AND. & KCB+NELIM-1.GT.NPIV_GLOBAL) THEN CALL dgemm('T', 'N', NPIV_GLOBAL-KCB+1, NRHS_B, & DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) CALL dgemm('T', 'N', KCB+NELIM-NPIV_GLOBAL-1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG + & (NPIV_GLOBAL-KCB+1)*DIAGSIZ_DYN), & DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB_INIT), LD_WCBCB) ELSE CALL dgemm('T', 'N', NELIM, NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) ENDIF ELSE IF (KCB.LE.NPIV_GLOBAL .AND. & KCB+NELIM-1.GT.NPIV_GLOBAL) THEN CALL dgemm('N', 'N', NPIV_GLOBAL-KCB+1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) CALL dgemm('N', 'N', KCB+NELIM-NPIV_GLOBAL-1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN+NPIV_GLOBAL-KCB+1), & DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB_INIT), LD_WCBCB) ELSE CALL dgemm('N', 'N', NELIM, NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) ENDIF ENDIF ENDIF CALL DMUMPS_SOL_FWD_BLR_UPDATE ( & WCB, LWCB, 1, LD_WCBPIV, PPIV_INIT, 1, & WCB, LWCB, LD_WCBCB, PCB_INIT, & PPIV, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, LAST_BLR, I, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC, & KEEP8, KEEP(34), & KEEP(448), KEEP(450), KEEP(451), & .FALSE., & IFLAG, IERROR) IF (IFLAG.LT.0) RETURN CALL DMUMPS_SOL_LD_AND_RELOAD_PANEL ( & INODE, N, DIAGSIZ_DYN, LIELL, NELIM, NSLAVES, & PPIV, & IW, IPOS, LIW, & DIAG(1), int(size(DIAG),8), 1_8, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & .TRUE. & ) PPIV = PPIV + int(DIAGSIZ_DYN,8) IPOS = IPOS + DIAGSIZ_DYN ENDDO RETURN END SUBROUTINE DMUMPS_SOL_FWD_LR_SU SUBROUTINE DMUMPS_SOL_SLAVE_LR_U & (INODE, IWHDLR, NPIV_GLOBAL, & WCB, LWCB, & LDX, LDY, & PTRX_INIT, PTRY_INIT, & JBDEB, JBFIN, & MTYPE, KEEP, KEEP8, IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, IWHDLR, NPIV_GLOBAL INTEGER, INTENT(IN) :: MTYPE, KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER(8), INTENT(IN) :: LWCB, PTRX_INIT, PTRY_INIT INTEGER, INTENT(IN) :: LDX, LDY, JBDEB, JBFIN DOUBLE PRECISION, INTENT(INOUT) :: WCB(LWCB) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, NPARTSASS, NB_BLR , NRHS_B INTEGER(8) :: PTRX, PTRY TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) NRHS_B = JBFIN-JBDEB+1 IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) NB_BLR = NB_BLR - 2 ELSE WRITE(6,*) " Internal error 1 in DMUMPS_SOL_SLAVE_LR_U" CALL MUMPS_ABORT() ENDIF PTRX = PTRX_INIT PTRY = PTRY_INIT DO I = 1, NPARTSASS BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL IF (associated(BLR_PANEL)) THEN IF (MTYPE.EQ.1) THEN CALL DMUMPS_SOL_FWD_BLR_UPDATE ( & WCB, LWCB, 1, LDX, -99999_8, 1, & WCB, LWCB, LDY, PTRY, & PTRX, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, NB_BLR, 0, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(2:NB_BLR+2), & KEEP8, KEEP(34), & KEEP(448), KEEP(450), KEEP(451), & .TRUE., IFLAG, IERROR ) ELSE CALL DMUMPS_SOL_BWD_BLR_UPDATE ( & WCB, LWCB, 1, LDY, -99999_8, 1, & WCB, LWCB, LDX, PTRX, & PTRY, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, NB_BLR, 0, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(2:NB_BLR+2), & KEEP8, KEEP(34), & KEEP(448), KEEP(450), KEEP(451), & .TRUE., & IFLAG, IERROR ) ENDIF IF (MTYPE .EQ. 1) THEN PTRX = PTRX + BLR_PANEL(1)%N ELSE PTRY = PTRY + BLR_PANEL(1)%N ENDIF IF (IFLAG.LT.0) RETURN ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_SOL_SLAVE_LR_U SUBROUTINE GEMM_Q_FWD(m, nrhs_b, k, npiv, & Q, TMP, ldT, & arraypiv, ldpiv, arraycb, lcb, ldcb, & ibeg_block, iend_block, is_t2_slave, & poscb, pospiv, pospivcol, ibeg_tmp) implicit none integer, intent(in) :: m, nrhs_b, k, npiv DOUBLE PRECISION, dimension(:,:), intent(inout) :: Q DOUBLE PRECISION, dimension(ldt, *), intent(inout) :: TMP integer(8), intent(in) :: lcb integer, intent(in) :: ldpiv DOUBLE PRECISION, intent(inout) :: arraypiv(ldpiv,*) DOUBLE PRECISION, intent(inout) :: arraycb(lcb) integer, intent(in) :: ldt, ldcb integer, intent(in) :: ibeg_block, iend_block logical, intent(in) :: is_t2_slave integer(8), intent(in) :: poscb, pospiv integer, intent(in) :: pospivcol integer, intent(in) :: ibeg_tmp integer :: posblock DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL dgemm('N', 'N', M, NRHS_B, K, MONE, & Q(1,1), M, TMP(ibeg_tmp,1), LDT, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND. & IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('N', 'N', NPIV-IBEG_BLOCK+1,NRHS_B, K, & MONE, Q(1,1), M, TMP(ibeg_tmp,1), LDT, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL dgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, & NRHS_B, K, & MONE, Q(NPIV-IBEG_BLOCK+2,1), M, & TMP(ibeg_tmp,1), LDT, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('N', 'N', M, NRHS_B, K, MONE, & Q(1,1), M, TMP(ibeg_tmp,1), LDT, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL dgemm('N', 'N', M, NRHS_B, K, MONE, & Q(1,1), M, TMP(ibeg_tmp,1), LDT, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF RETURN END SUBROUTINE GEMM_Q_FWD SUBROUTINE GEMM_Q_BWD(m, nrhs_b, k, npiv, & Q, TMP, ldT, & arraypiv, lpiv, ldpiv, arraycb, lcb, ldcb, & ibeg_block, iend_block, is_t2_slave, & poscb, pospiv, pospivcol, ibeg_tmp) implicit none integer, intent(in) :: m, nrhs_b, k, npiv DOUBLE PRECISION, dimension(:, :), intent(inout) :: Q DOUBLE PRECISION, dimension(ldt, *), intent(inout) :: TMP integer(8), intent(in) :: lcb, lpiv DOUBLE PRECISION, intent(inout) :: arraypiv(lpiv,*) DOUBLE PRECISION, intent(inout) :: arraycb(lcb) integer, intent(in) :: ldt, ldcb, ldpiv integer, intent(in) :: ibeg_block, iend_block logical, intent(in) :: is_t2_slave integer(8), intent(in) :: poscb, pospiv integer, intent(in) :: pospivcol integer, intent(in) :: ibeg_tmp integer(8) :: posblock DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB +int(IBEG_BLOCK-1,8) CALL dgemm('T', 'N', K, NRHS_B, M, ONE, & Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TMP(ibeg_tmp,1), ldt) ELSEIF (IBEG_BLOCK.LE.NPIV.AND. & IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('T', 'N', K, NRHS_B, & NPIV-IBEG_BLOCK+1, & ONE, Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TMP(ibeg_tmp, 1), ldt) CALL dgemm('T', 'N', & K, NRHS_B, IBEG_BLOCK+M-NPIV-1, & ONE, Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYCB(POSCB), LDCB, & ONE, & TMP(ibeg_tmp,1), ldt) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('T', 'N', K, NRHS_B, M, ONE, & Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TMP(ibeg_tmp, 1), ldt) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL dgemm('T', 'N', K, NRHS_B, M, ONE, & Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TMP(ibeg_tmp, 1), ldt) ENDIF RETURN END SUBROUTINE GEMM_Q_BWD SUBROUTINE DMUMPS_SOL_FWD_BLR_UPDATE ( & ARRAYPIV, LPIV, LPIVCOL, LDPIV, POSPIV, POSPIVCOL, & ARRAYCB, LCB, LDCB, POSCB, & POSDIAG, & NRHS_B, NPIV, & BLR_PANEL, LAST_BLR, & CURRENT_BLR, BEGS_BLR_STATIC, & KEEP8, K34, K448, K450, K451, IS_T2_SLAVE, IFLAG, IERROR ) !$ USE OMP_LIB INTEGER(8), INTENT(IN) :: LPIV, LCB, POSPIV, POSCB, POSDIAG INTEGER, INTENT(IN) :: LPIVCOL, POSPIVCOL DOUBLE PRECISION, INTENT(INOUT) :: ARRAYPIV(LPIV,LPIVCOL) DOUBLE PRECISION, INTENT(INOUT) :: ARRAYCB(LCB) INTEGER, INTENT(IN) :: LAST_BLR, NRHS_B, LDPIV, LDCB, & CURRENT_BLR, NPIV, K34, K448, K450, K451 TYPE(LRB_TYPE), TARGET,INTENT(IN) :: & BLR_PANEL(:) INTEGER :: BEGS_BLR_STATIC(:) LOGICAL, INTENT(IN) :: IS_T2_SLAVE INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, K, M, N, IBEG_BLOCK, IEND_BLOCK INTEGER :: KMAX INTEGER :: MMAX INTEGER(8) :: POSBLOCK INTEGER :: allocok TYPE(LRB_TYPE), POINTER :: LRB DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:) :: TEMP_BLOCK DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) KMAX = -1 MMAX = -1 DO I = CURRENT_BLR+1, LAST_BLR KMAX = max(KMAX, BLR_PANEL(I-CURRENT_BLR)%K) MMAX = max(MMAX, BLR_PANEL(I-CURRENT_BLR)%M) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(TEMP_BLOCK, allocok !$OMP& ) #endif IF (KMAX.GT.0) THEN allocate(TEMP_BLOCK(KMAX*NRHS_B), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NRHS_B * KMAX write(*,*) 'Allocation problem in BLR routine & DMUMPS_SOL_FWD_BLR_UPDATE for TEMP_BLOCK: ', & 'not enough memory? memory requested = ', IERROR ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif #if ! defined(BLR_NOOPENMP) !$OMP DO SCHEDULE(DYNAMIC,1) !$OMP& PRIVATE(IBEG_BLOCK, IEND_BLOCK, LRB, K, M, N, !$OMP& POSBLOCK) #endif DO I = CURRENT_BLR+1, LAST_BLR IF (IFLAG.LT.0) CYCLE IBEG_BLOCK = BEGS_BLR_STATIC(I) IEND_BLOCK = BEGS_BLR_STATIC(I+1)-1 IF (IBEG_BLOCK .EQ. IEND_BLOCK + 1) CYCLE LRB => BLR_PANEL(I-CURRENT_BLR) K = LRB%K M = LRB%M N = LRB%N IF (LRB%ISLR) THEN IF (K.GT.0) THEN CALL dgemm('N', 'N', K, NRHS_B, N, ONE, & LRB%R(1,1), K, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL dgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('N', 'N', NPIV-IBEG_BLOCK+1, NRHS_B, K, & MONE, LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL dgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, NRHS_B, K, & MONE, LRB%Q(NPIV-IBEG_BLOCK+2,1), M, TEMP_BLOCK(1), & K, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL dgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF ENDIF ELSE IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB + int(IBEG_BLOCK-1,8) CALL dgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('N', 'N', NPIV-IBEG_BLOCK+1, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL dgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, NRHS_B, N, MONE, & LRB%Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYPIV(POSDIAG,POSPIVCOL), & LDPIV, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB + int(IBEG_BLOCK-1-NPIV,8) CALL dgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF ENDIF ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif IF (KMAX.GT.0) THEN IF (allocated(TEMP_BLOCK)) deallocate(TEMP_BLOCK) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif RETURN END SUBROUTINE DMUMPS_SOL_FWD_BLR_UPDATE SUBROUTINE DMUMPS_SOL_BWD_LR_SU & ( INODE, IWHDLR, NPIV_GLOBAL, NSLAVES, & LIELL, WCB, LWCB, NRHS_B, PTWCB, & RHSINTR, LRHSINTR, NRHS, & IPOSINRHSINTR, JBDEB, & MTYPE, KEEP, KEEP8, & IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, IWHDLR, NPIV_GLOBAL, NSLAVES INTEGER, INTENT(IN) :: MTYPE, LIELL, KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IPOSINRHSINTR, JBDEB, LRHSINTR, NRHS INTEGER(8), INTENT(IN) :: LWCB, PTWCB INTEGER, INTENT(IN) :: NRHS_B INTEGER, INTENT(INOUT) :: IFLAG, IERROR DOUBLE PRECISION, INTENT(INOUT) :: WCB(LWCB) DOUBLE PRECISION RHSINTR(LRHSINTR,NRHS) INTEGER :: I, NPARTSASS, NB_BLR, LAST_BLR, & NELIM_PANEL, LD_WCB, & DIAGSIZ_DYN, DIAGSIZ_STA, LDADIAG, & IEND_BLR, IBEG_BLR INTEGER(8) :: PWCB INTEGER :: IPIV_PANEL DOUBLE PRECISION, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) IF ((MTYPE.EQ.1).AND.(KEEP(50).EQ.0)) THEN IF (associated(BLR_ARRAY(IWHDLR)%PANELS_U)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_U) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ENDIF ELSE IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ELSE WRITE(6,*) " Internal error in DMUMPS_SOL_FWD_SU_MASTER" ENDIF ENDIF PWCB = PTWCB + int(NPIV_GLOBAL,8) LD_WCB = LIELL IF (KEEP(50).EQ.0 .AND. NSLAVES.GT.0 .AND. MTYPE.NE.1) THEN LAST_BLR = NPARTSASS ELSE LAST_BLR = NB_BLR ENDIF DO I=NPARTSASS,1,-1 IBEG_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I) IEND_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) -1 DIAGSIZ_DYN = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) - & IBEG_BLR DIAGSIZ_STA = BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(I+1) - & IBEG_BLR IF (KEEP(50).NE.0) THEN LDADIAG = DIAGSIZ_DYN ELSE LDADIAG = DIAGSIZ_STA ENDIF IF (DIAGSIZ_DYN.EQ.0) GOTO 1000 NELIM_PANEL = DIAGSIZ_STA - DIAGSIZ_DYN IPIV_PANEL = IPOSINRHSINTR + IBEG_BLR -1 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_U(I)%LRB_PANEL ELSE BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL END IF CALL DMUMPS_SOL_BWD_BLR_UPDATE ( & RHSINTR, int(LRHSINTR,8), NRHS, LRHSINTR, & int(IPOSINRHSINTR,8), JBDEB, & WCB, LWCB, LD_WCB, PWCB, & int(IPIV_PANEL,8), & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, LAST_BLR, & I, BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC, & KEEP8, KEEP(34), & KEEP(448), KEEP(450), KEEP(451), & .FALSE., & IFLAG, IERROR) IF (IFLAG.LT.0) RETURN DIAG => BLR_ARRAY(IWHDLR)%DIAG_BLOCKS(I)%DIAG_BLOCK IF (NELIM_PANEL.GT.0) THEN IF (MTYPE.EQ.1.AND.KEEP(50).EQ.0) THEN IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN CALL dgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, WCB(PWCB), & LD_WCB, ONE , RHSINTR(IPIV_PANEL,JBDEB),LRHSINTR) ELSE IF (IEND_BLR+1.LE.NPIV_GLOBAL .AND. & IEND_BLR+NELIM_PANEL.GT.NPIV_GLOBAL) THEN CALL dgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, & NPIV_GLOBAL-IEND_BLR, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & RHSINTR(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSINTR, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) CALL dgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, & IEND_BLR+NELIM_PANEL-NPIV_GLOBAL, & MONE, DIAG(1+DIAGSIZ_DYN+NPIV_GLOBAL-IEND_BLR), & DIAGSIZ_STA, & WCB(PWCB), LD_WCB, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ELSE CALL dgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & RHSINTR(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSINTR, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ENDIF ENDIF ELSE IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN CALL dgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PWCB), LD_WCB, ONE, & RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ELSE IF (IEND_BLR+1.LE.NPIV_GLOBAL .AND. & IEND_BLR+NELIM_PANEL.GT.NPIV_GLOBAL) THEN CALL dgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, & NPIV_GLOBAL-IEND_BLR, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & RHSINTR(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSINTR, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) CALL dgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, & IEND_BLR+NELIM_PANEL-NPIV_GLOBAL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG + & (NPIV_GLOBAL-IEND_BLR)*DIAGSIZ_DYN), & DIAGSIZ_DYN, & WCB(PWCB), LD_WCB, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ELSE CALL dgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & RHSINTR(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSINTR, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ENDIF ENDIF ENDIF ENDIF IF (IFLAG.LT.0) RETURN CALL DMUMPS_SOLVE_BWD_LR_TRSOLVE ( & DIAG(1), size(DIAG), DIAGSIZ_DYN, NELIM_PANEL, LIELL, & NRHS_B, WCB, LWCB, & RHSINTR, LRHSINTR, NRHS, & IPIV_PANEL, JBDEB, & MTYPE, KEEP ) 1000 CONTINUE ENDDO RETURN END SUBROUTINE DMUMPS_SOL_BWD_LR_SU SUBROUTINE DMUMPS_SOL_BWD_BLR_UPDATE ( & ARRAYPIV, LPIV, LPIVCOL, LDPIV, POSPIV, POSPIVCOL, & ARRAYCB, LCB, LDCB, POSCB, & POSDIAG, & NRHS_B, NPIV, & BLR_PANEL, LAST_BLR, CURRENT_BLR, & BEGS_BLR_STATIC, & KEEP8, K34, K448, K450, K451, IS_T2_SLAVE, & IFLAG, IERROR) !$ USE OMP_LIB INTEGER(8), INTENT(IN) :: LPIV, LCB, POSPIV, POSCB, POSDIAG INTEGER,INTENT(IN) :: LPIVCOL, POSPIVCOL DOUBLE PRECISION, INTENT(INOUT) :: ARRAYPIV(LPIV,LPIVCOL) DOUBLE PRECISION, INTENT(INOUT) :: ARRAYCB(LCB) INTEGER, INTENT(IN) :: LAST_BLR, NRHS_B, LDPIV, LDCB, & CURRENT_BLR, NPIV, K34, K448, K450, K451 TYPE(LRB_TYPE), TARGET,INTENT(IN) :: & BLR_PANEL(:) INTEGER(8), INTENT(IN) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_T2_SLAVE INTEGER :: BEGS_BLR_STATIC(:) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, K, M, N, IBEG_BLOCK, IEND_BLOCK INTEGER :: KMAX INTEGER(8) :: POSBLOCK TYPE(LRB_TYPE), POINTER :: LRB DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: TEMP_BLOCK DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DEST_ARRAY INTEGER :: allocok DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) KMAX = -1 DO I = CURRENT_BLR+1, LAST_BLR KMAX = max(KMAX, BLR_PANEL(I-CURRENT_BLR)%K) ENDDO IF (CURRENT_BLR.LT.LAST_BLR) THEN N = BLR_PANEL(1)%N ELSE RETURN ENDIF allocate(DEST_ARRAY(N*NRHS_B),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = N * NRHS_B GOTO 100 ENDIF DEST_ARRAY = ZERO #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(TEMP_BLOCK, allocok !$OMP& ) #endif IF (KMAX.GT.0) THEN allocate(TEMP_BLOCK(KMAX*NRHS_B), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NRHS_B * KMAX write(*,*) 'Allocation problem in BLR routine & DMUMPS_SOL_BWD_BLR_UPDATE: ', & 'not enough memory? memory requested = ', IERROR ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP DO SCHEDULE(DYNAMIC,1) !$OMP& PRIVATE(IBEG_BLOCK, IEND_BLOCK, LRB, K, M, POSBLOCK) !$OMP& REDUCTION(+:DEST_ARRAY) #endif DO I = CURRENT_BLR+1, LAST_BLR IF (IFLAG.LT.0) CYCLE IBEG_BLOCK = BEGS_BLR_STATIC(I) IEND_BLOCK = BEGS_BLR_STATIC(I+1)-1 LRB => BLR_PANEL(I-CURRENT_BLR) K = LRB%K M = LRB%M IF (LRB%ISLR) THEN IF (K.GT.0) THEN IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB +int(IBEG_BLOCK-1,8) CALL dgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TEMP_BLOCK(1), K) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('T', 'N', K, NRHS_B, NPIV-IBEG_BLOCK+1, & ONE, LRB%Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) CALL dgemm('T', 'N', K, NRHS_B, IBEG_BLOCK+M-NPIV-1, & ONE, LRB%Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYCB(POSCB), LDCB, & ONE, & TEMP_BLOCK(1), K) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL dgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TEMP_BLOCK(1), K) ENDIF CALL dgemm('T', 'N', N, NRHS_B, K, MONE, & LRB%R(1,1), K, & TEMP_BLOCK(1), K, ONE, & DEST_ARRAY(1), N) ENDIF ELSE IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL dgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYCB(POSBLOCK), LDCB, & ONE, DEST_ARRAY(1), N) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('T', 'N', N, NRHS_B, NPIV-IBEG_BLOCK+1, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ONE, DEST_ARRAY(1), N) CALL dgemm('T', 'N', N, NRHS_B, IBEG_BLOCK+M-NPIV-1, MONE, & LRB%Q(NPIV-IBEG_BLOCK+2,1), M, ARRAYCB(POSCB), & LDCB, ONE, DEST_ARRAY(1), N) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ONE, DEST_ARRAY(1), N) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL dgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYCB(POSBLOCK), LDCB, & ONE, DEST_ARRAY(1), N) ENDIF ENDIF ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif IF (KMAX.GT.0) THEN IF (allocated(TEMP_BLOCK)) deallocate(TEMP_BLOCK) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IS_T2_SLAVE) THEN DO I=1,NRHS_B call daxpy(N, ONE, DEST_ARRAY((I-1)*N+1), 1, & ARRAYPIV(POSDIAG+(I-1)*LDPIV,POSPIVCOL), 1) ENDDO ELSE DO I=1,NRHS_B call daxpy(N, ONE, DEST_ARRAY((I-1)*N+1), 1, & ARRAYPIV(POSDIAG,POSPIVCOL+I-1), 1) ENDDO ENDIF 100 CONTINUE IF (allocated(DEST_ARRAY)) DEALLOCATE(DEST_ARRAY) RETURN END SUBROUTINE DMUMPS_SOL_BWD_BLR_UPDATE END MODULE DMUMPS_SOL_LR SUBROUTINE DMUMPS_SOLVE_BWD_LR_TRSOLVE ( & DIAG, LDIAG, NPIV, NELIM, LIELL, & NRHS_B, W, LWC, & RHSINTR, LRHSINTR, NRHS, & PPIVINRHSINTR, JBDEB, & MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LIELL, NPIV, NELIM, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDIAG INTEGER, INTENT(IN) :: PPIVINRHSINTR, JBDEB, LRHSINTR, NRHS INTEGER(8), INTENT(IN) :: LWC DOUBLE PRECISION, INTENT(IN) :: DIAG(LDIAG) DOUBLE PRECISION, INTENT(INOUT) :: W(LWC) DOUBLE PRECISION RHSINTR(LRHSINTR,NRHS) INTEGER :: LDAJ DOUBLE PRECISION ONE PARAMETER (ONE = 1.0D0) IF ( MTYPE .eq. 1 ) THEN LDAJ = NPIV + NELIM CALL dtrsm('L','L','T','N', NPIV, NRHS_B, ONE, DIAG(1), & LDAJ, RHSINTR(PPIVINRHSINTR,JBDEB), & LRHSINTR) ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=NPIV+NELIM ELSE LDAJ=NPIV ENDIF CALL dtrsm('L','U','N','U', NPIV, NRHS_B, ONE, DIAG(1), & LDAJ, RHSINTR(PPIVINRHSINTR,JBDEB), LRHSINTR) END IF RETURN END SUBROUTINE DMUMPS_SOLVE_BWD_LR_TRSOLVE MUMPS_5.8.1/src/dfac_mem_free_block_cb.F0000664000175000017500000000562215042446440017716 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, IPOSBLOCK, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP, KEEP8, IN_PLACE_STATS & ) !$ USE OMP_LIB USE MUMPS_LOAD IMPLICIT NONE INTEGER IPOSBLOCK, & LIW, IWPOSCB, N INTEGER(8) :: LA, LRLU, LRLUS, IPTRLU LOGICAL IN_PLACE_STATS INTEGER IW( LIW ), KEEP(500) INTEGER(8) KEEP8(150) INTEGER MYID LOGICAL SSARBR INTEGER SIZFI_BLOCK, SIZFI INTEGER(8) :: SIZFR, SIZFR_BLOCK, SIZFR_BLOCK_EFF, & SIZEHOLE, MEM_INC, DYNSIZE_BLOCK INCLUDE 'mumps_headers.h' SIZFI_BLOCK=IW(IPOSBLOCK+XXI) CALL MUMPS_GETI8( SIZFR_BLOCK, IW(IPOSBLOCK+XXR) ) CALL MUMPS_GETI8( DYNSIZE_BLOCK,IW(IPOSBLOCK+XXD) ) IF (DYNSIZE_BLOCK .GT. 0_8) THEN SIZFR_BLOCK_EFF = 0_8 ELSE IF (KEEP(216).eq.3 & ) THEN SIZFR_BLOCK_EFF = SIZFR_BLOCK ELSE CALL DMUMPS_SIZEFREEINREC( IW(IPOSBLOCK), & LIW-IPOSBLOCK+1, & SIZEHOLE, KEEP(IXSZ)) SIZFR_BLOCK_EFF = SIZFR_BLOCK - SIZEHOLE ENDIF IF (.NOT. IN_PLACE_STATS) THEN LRLUS = LRLUS + SIZFR_BLOCK_EFF IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) - SIZFR_BLOCK_EFF ELSE !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - SIZFR_BLOCK_EFF !$OMP END ATOMIC ENDIF ENDIF IF ( IPOSBLOCK .eq. IWPOSCB + 1 ) THEN IPTRLU = IPTRLU + SIZFR_BLOCK IWPOSCB = IWPOSCB + SIZFI_BLOCK LRLU = LRLU + SIZFR_BLOCK MEM_INC = -SIZFR_BLOCK_EFF IF (IN_PLACE_STATS) THEN MEM_INC= 0_8 ENDIF CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,MEM_INC,KEEP,KEEP8,LRLUS) 90 IF ( IWPOSCB .eq. LIW ) GO TO 100 SIZFI = IW( IWPOSCB+1+XXI ) CALL MUMPS_GETI8( SIZFR, IW(IWPOSCB+1+XXR) ) IF ( IW( IWPOSCB+1+XXS ) .EQ. S_FREE ) THEN IPTRLU = IPTRLU + SIZFR LRLU = LRLU + SIZFR IWPOSCB = IWPOSCB + SIZFI GO TO 90 ENDIF 100 CONTINUE IW( IWPOSCB+1+XXP)=TOP_OF_STACK ELSE IW( IPOSBLOCK +XXS)=S_FREE CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,-SIZFR_BLOCK_EFF,KEEP,KEEP8,LRLUS) END IF RETURN END SUBROUTINE DMUMPS_FREE_BLOCK_CB_STATIC MUMPS_5.8.1/src/dsol_c.F0000664000175000017500000031746315042446437014626 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SOL_C(root, roota, N, A, LA, IW, LIW, W, LWC, & IWCB, LIWW, NRHS, NA, LNA, NE_STEPS, W2, MTYPE, ICNTL, FROM_PP, & STEP, FRERE, DAD, FILS, PTRIST, PTRFAC, IW1, LIW1, PTRACB, & LIWK_PTRACB, PROCNODE_STEPS, SLAVEF, INFO, KEEP,KEEP8, DKEEP, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IBEG_ROOT_DEF, IEND_ROOT_DEF, & IROOT_DEF_RHS_COL1, RHS_ROOT, LRHS_ROOT, SIZE_ROOT, MASTER_ROOT, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, POSINRHSINTR_BWD, & Lnodes_FWD, Lnodes_BWD, & nodes_FWD, nodes_BWD, & NZ_RHS, NBCOL_INBLOC, JBEG_RHS, Step2node, LStep2node, & IRHS_SPARSE, IRHS_PTR, SIZE_PERM_RHS, PERM_RHS, & SIZE_UNS_PERM_INV, UNS_PERM_INV, NB_FS_IN_RHSINTR_F, & NB_FS_IN_RHSINTR_TOT, DO_NBSPARSE , RHS_BOUNDS, LRHS_BOUNDS #if defined(STAT_ES_SOLVE) & , IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING #endif & ,IPOOL_B_L0_OMP, LPOOL_B_L0_OMP, IPOOL_A_L0_OMP, LPOOL_A_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) USE DMUMPS_OOC USE DMUMPS_SOL_ES USE DMUMPS_SOL_L0OMP_M, ONLY : DMUMPS_SOL_L0OMP_R, & DMUMPS_SOL_L0OMP_S USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC & , DMUMPS_L0OMPFAC_T IMPLICIT NONE #if defined(V_T) INCLUDE 'VT.inc' #endif TYPE ( MUMPS_ROOT_STRUC ) :: root TYPE ( DMUMPS_ROOT_STRUC ) :: roota INTEGER(8) :: LA INTEGER(8) :: LWC INTEGER :: N,LIW,MTYPE,LIW1,LIWW,LNA INTEGER ICNTL(60),INFO(80), KEEP(500) DOUBLE PRECISION, intent(inout) :: DKEEP(230) INTEGER(8) KEEP8(150) INTEGER IW(LIW),IW1(LIW1),NA(LNA),NE_STEPS(KEEP(28)),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)), FILS(N), PTRIST(KEEP(28)), & DAD(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER :: LIWK_PTRACB INTEGER(8) :: PTRACB(LIWK_PTRACB) INTEGER NRHS, LRHSINTR, NB_FS_IN_RHSINTR_F, NB_FS_IN_RHSINTR_TOT DOUBLE PRECISION A(LA), W(LWC), & W2(KEEP(133)) DOUBLE PRECISION :: RHSINTR(LRHSINTR,NRHS) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER PROCNODE_STEPS(KEEP(28)), POSINRHSINTR_FWD(N), & POSINRHSINTR_BWD(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, IROOT_DEF_RHS_COL1 INTEGER NRHS_LOC INTEGER SIZE_ROOT, MASTER_ROOT INTEGER(8) :: LRHS_ROOT DOUBLE PRECISION RHS_ROOT(LRHS_ROOT) LOGICAL, intent(in) :: FROM_PP INTEGER, intent(in) :: Lnodes_FWD, Lnodes_BWD INTEGER, intent(in) :: nodes_FWD(max(1,Lnodes_FWD)), & nodes_BWD(max(1,Lnodes_BWD)) INTEGER, intent(in) :: NZ_RHS, NBCOL_INBLOC INTEGER, intent(in) :: SIZE_UNS_PERM_INV INTEGER, intent(in) :: SIZE_PERM_RHS INTEGER, intent(in) :: JBEG_RHS INTEGER, intent(in) :: IRHS_SPARSE(NZ_RHS) INTEGER, intent(in) :: IRHS_PTR(NBCOL_INBLOC+1) INTEGER, intent(in) :: PERM_RHS(SIZE_PERM_RHS) INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, intent(in) :: LStep2node INTEGER, intent(in) :: Step2node(LStep2node) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(inout) :: RHS_BOUNDS (LRHS_BOUNDS) #if defined(STAT_ES_SOLVE) INTEGER, INTENT(IN) :: SIZE_WORKING, SIZE_IPTR_WORKING, & IPTR_WORKING(SIZE_IPTR_WORKING), & WORKING(SIZE_WORKING) #endif INTEGER, INTENT (IN) :: LPOOL_B_L0_OMP INTEGER, INTENT (IN) :: IPOOL_B_L0_OMP( LPOOL_B_L0_OMP ) INTEGER, INTENT (IN) :: LPOOL_A_L0_OMP INTEGER, INTENT (IN) :: IPOOL_A_L0_OMP( LPOOL_A_L0_OMP ) INTEGER, INTENT (IN) :: L_PHYS_L0_OMP INTEGER, INTENT (INOUT) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT (IN) :: L_VIRT_L0_OMP INTEGER, INTENT (IN) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT (IN) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT (IN) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT (IN) :: LL0_OMP_MAPPING INTEGER, INTENT (IN) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INTEGER, INTENT (IN) :: LL0_OMP_FACTORS TYPE (DMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER MP, LP, LDIAG INTEGER K,I,II INTEGER allocok INTEGER LPOOL,MYLEAF,MYROOT,NBROOT,LPANEL_POS INTEGER MYLEAF_NOT_PRUNED INTEGER NSTK_S,IPOOL,IPANEL_POS,PTRICB INTEGER MTYPE_LOC INTEGER MODE_RHS_BOUNDS INTEGER IPT_RHS_ROOT_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 LOGICAL DOFORWARD, DOROOT, DOBACKWARD LOGICAL :: DO_L0OMP_FWD, DO_L0OMP_BWD LOGICAL I_WORKED_ON_ROOT, SPECIAL_ROOT_REACHED INTEGER IROOT LOGICAL DOROOT_FWD_OOC, DOROOT_BWD_PANEL LOGICAL DUMMY_BOOL INTEGER :: IDUMMY INTEGER :: NBROOT_UNDER_L0 DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 INCLUDE 'mumps_headers.h' INTEGER, DIMENSION(:), POINTER :: nodes_BWD_PTR INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: Pruned_Roots_FWD INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: Pruned_Roots_NS INTEGER :: Lnodes_BWD_PTR, LPruned_Roots_NS INTEGER :: Lnodes_BWD_ROOTS INTEGER nb_prun_leaves INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_Leaves INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_List INTEGER nb_prun_nodes INTEGER INODE_PRINC, nb_prun_roots INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_SONS, Pruned_Roots INTEGER :: SIZE_TO_PROCESS LOGICAL, DIMENSION(:), ALLOCATABLE :: TO_PROCESS INTEGER ISTEP INTEGER :: INODE, ICHILD LOGICAL AM1, DO_PRUN_FWD, DO_PRUN_BWD LOGICAL Exploit_Sparsity_FWD, Exploit_Sparsity_BWD LOGICAL DO_NBSPARSE_BWD, PRUN_BELOW_BWD INTEGER :: OOC_FCT_TYPE_TMP INTEGER :: MUMPS_OOC_GET_FCT_TYPE EXTERNAL :: MUMPS_OOC_GET_FCT_TYPE DOUBLE PRECISION TIME_FWD,TIME_BWD,TIME_SpecialRoot INTEGER :: nb_sparse INTEGER, EXTERNAL :: MUMPS_PROCNODE LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR MYLEAF = -1 LP = ICNTL(1) MP = ICNTL(2) LDIAG = ICNTL(4) CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, MYID ) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 #if defined(V_T) CALL VTCLASSDEF( 'Soln_c',soln_c_class,ierr) CALL VTFUNCDEF( 'forw_soln',soln_c_class,forw_soln,ierr) CALL VTFUNCDEF( 'back_soln',soln_c_class,back_soln,ierr) CALL VTFUNCDEF( 'root_soln',soln_c_class,root_soln,ierr) #endif IF (.NOT. FROM_PP) THEN CALL MUMPS_SECDEB(TIME_FWD) ENDIF NSTK_S = 1 PTRICB = NSTK_S + KEEP(28) IPOOL = PTRICB + KEEP(28) LPOOL = NA(1) + 1 IPANEL_POS = IPOOL + LPOOL IF (KEEP(201).EQ.1) THEN LPANEL_POS = KEEP(228)+1 ELSE LPANEL_POS = 1 ENDIF IF (IPANEL_POS + LPANEL_POS -1 .ne. LIW1 ) THEN WRITE(*,*) MYID, ": Internal Error 1 in DMUMPS_SOL_C", & IPANEL_POS, LPANEL_POS, LIW1 CALL MUMPS_ABORT() ENDIF KEEP(405)=0 DOFORWARD = .TRUE. DOBACKWARD= .TRUE. SPECIAL_ROOT_REACHED = .TRUE. 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_FWD = (KEEP(235) .NE. 0) .AND. (.NOT. AM1) Exploit_Sparsity_BWD = (KEEP(212) .NE. 0) .AND. (.NOT. AM1) Lnodes_BWD_ROOTS = NA(2) DO_PRUN_FWD = (Exploit_Sparsity_FWD.OR.AM1) DO_PRUN_BWD = (Exploit_Sparsity_BWD.OR.AM1) IF (FROM_PP) THEN Exploit_Sparsity_FWD = .FALSE. DO_PRUN_FWD = .FALSE. Exploit_Sparsity_BWD = .FALSE. DO_PRUN_BWD = .FALSE. IF ( AM1 ) THEN WRITE(*,*) "Internal error 2 in DMUMPS_SOL_C" CALL MUMPS_ABORT() ENDIF ENDIF DO_L0OMP_FWD= ( (KEEP(401).EQ.1).AND.(KEEP(400).GT.0) & .AND.DOFORWARD ) DO_L0OMP_FWD = DO_L0OMP_FWD .AND. KEEP(201).EQ.0 DO_L0OMP_BWD = ( (KEEP(401).EQ.1).AND.(KEEP(400).GT.0) & .AND.DOBACKWARD ) DO_L0OMP_BWD = DO_L0OMP_BWD .AND. KEEP(201).EQ.0 IF ( DO_PRUN_FWD.OR.DO_PRUN_BWD ) THEN ALLOCATE (Pruned_SONS(KEEP(28)), stat=I) IF(I.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ENDIF IF ( DO_PRUN_FWD.OR.DO_PRUN_BWD & .OR. DO_L0OMP_BWD & ) THEN SIZE_TO_PROCESS = KEEP(28) ELSE SIZE_TO_PROCESS = 1 ENDIF ALLOCATE (TO_PROCESS(SIZE_TO_PROCESS), stat=I) IF(I.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 IF ( DOFORWARD .AND. DO_PRUN_FWD ) THEN CALL DMUMPS_CHAIN_PRUN_NODES( & .FALSE., & DAD, KEEP(28), & STEP, N, & nodes_FWD, Lnodes_FWD, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, & nb_prun_leaves ) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL DMUMPS_CHAIN_PRUN_NODES( & .TRUE., & DAD, KEEP(28), & STEP, N, & nodes_FWD, Lnodes_FWD, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves ) CALL DMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF ( KEEP(201) .GT. 0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('F',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL DMUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), & KEEP8(31)+KEEP8(64), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP #if defined(STAT_ES_SOLVE) & , NRHS, COMM_NODES, IW, LIW, PTRIST,KEEP(IXSZ),0, & KEEP(50), KEEP(38) #endif & ) IF (DO_NBSPARSE) THEN nb_sparse = max(1,KEEP(497)) MODE_RHS_BOUNDS = 0 IF (Exploit_Sparsity_FWD) MODE_RHS_BOUNDS = 2 CALL DMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243), & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23), & RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & MODE_RHS_BOUNDS) CALL DMUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, KEEP(485), #if defined(STAT_ES_SOLVE) & KEEP(46), & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, #endif & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,0, & KEEP(50), KEEP(38)) END IF SPECIAL_ROOT_REACHED = .FALSE. DO I= 1, nb_prun_roots IF ( (Pruned_Roots(I).EQ.KEEP(38)).OR. & (Pruned_Roots(I).EQ.KEEP(20)) ) THEN SPECIAL_ROOT_REACHED = .TRUE. EXIT ENDIF ENDDO DEALLOCATE(Pruned_List) ENDIF IF (KEEP(201).GT.0) THEN IF (DOFORWARD .OR. DOROOT_FWD_OOC) THEN CALL DMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,KEEP(28),MTYPE, & A,LA,DOFORWARD,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (DOFORWARD) THEN IF ( KEEP( 50 ) .eq. 0 ) THEN MTYPE_LOC = MTYPE ELSE MTYPE_LOC = 1 ENDIF #if defined(V_T) CALL VTBEGIN(forw_soln,ierr) #endif IF ( .NOT. DO_PRUN_FWD ) THEN CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, MYROOT, MYID_NODES, & SLAVEF, NA, LNA, KEEP, STEP, PROCNODE_STEPS) DO ISTEP =1, KEEP(28) IW1(NSTK_S+ISTEP-1) = NE_STEPS(ISTEP) ENDDO ELSE CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & nb_prun_roots, Pruned_Roots, & MYROOT, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) IF ((Exploit_Sparsity_FWD).AND.(nb_prun_roots.NE.NA(2))) THEN Lnodes_BWD_ROOTS = nb_prun_roots ALLOCATE(Pruned_Roots_FWD(Lnodes_BWD_ROOTS), STAT=allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of nodes_FWD' INFO(1) = -13 INFO(2) = Lnodes_BWD_ROOTS CALL MUMPS_ABORT() END IF Pruned_Roots_FWD(1:Lnodes_BWD_ROOTS)= & Pruned_Roots(1:Lnodes_BWD_ROOTS) DEALLOCATE(Pruned_Roots) ELSE DEALLOCATE(Pruned_Roots) ENDIF DO ISTEP = 1, KEEP(28) IW1(NSTK_S+ISTEP-1) = Pruned_SONS(ISTEP) ENDDO ENDIF IF ( DO_L0OMP_FWD ) THEN KEEP(405)=1 CALL DMUMPS_SOL_L0OMP_R( N, MTYPE_LOC, NRHS, LIW, IW, & IW1(PTRICB), RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & STEP, FRERE, DAD, FILS, IW1(NSTK_S), & PTRIST, PTRFAC, INFO, & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, & FROM_PP, & NBROOT_UNDER_L0, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, & L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS, & DO_PRUN_FWD, TO_PROCESS & ) CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, & INFO, MYID ) IF (INFO(1).LT.0) THEN CALL DMUMPS_BDC_ERROR(MYID_NODES, SLAVEF, COMM_NODES, KEEP) ENDIF KEEP(405)=0 MYROOT = MYROOT - NBROOT_UNDER_L0 ENDIF IF ( DO_L0OMP_FWD ) THEN IF ( DO_PRUN_FWD ) THEN MYLEAF_NOT_PRUNED = IPOOL_A_L0_OMP(LPOOL_A_L0_OMP) DO I=1, MYLEAF_NOT_PRUNED IF ( TO_PROCESS( STEP( IPOOL_A_L0_OMP(I) ))) THEN IW1(IPOOL+MYLEAF-1) = IPOOL_A_L0_OMP(I) IW1(NSTK_S+STEP(IPOOL_A_L0_OMP(I))-1) = -99 ENDIF ENDDO DO I = 1, nb_prun_leaves INODE = Pruned_Leaves(I) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) & .EQ. MYID_NODES ) THEN IF (L0_OMP_MAPPING( STEP(INODE) ) .EQ. 0) THEN IW1(NSTK_S+STEP(INODE)-1) = -99 ENDIF ENDIF ENDDO DO I = 1, L_PHYS_L0_OMP INODE = DAD(STEP(PHYS_L0_OMP(I))) IF (INODE .NE. 0) THEN IF ( TO_PROCESS( STEP( INODE ))) THEN IF ( IW1(NSTK_S+STEP(INODE)-1) .EQ. 0 ) THEN IW1(NSTK_S+STEP(INODE)-1) = -99 ENDIF ENDIF ENDIF ENDDO MYLEAF = 0 DO ISTEP = KEEP(28), 1, -1 INODE=Step2Node(ISTEP) IF (IW1(NSTK_S+STEP(INODE)-1).EQ.-99) THEN MYLEAF = MYLEAF + 1 IW1(IPOOL+MYLEAF-1) = INODE IW1(NSTK_S+STEP(INODE)-1) = 0 ENDIF ENDDO DEALLOCATE(Pruned_Leaves) ELSE MYLEAF = IPOOL_A_L0_OMP(LPOOL_A_L0_OMP) DO I=1, MYLEAF IW1(IPOOL+I-1) = IPOOL_A_L0_OMP(I) ENDDO ENDIF ELSE IF ( DO_PRUN_FWD ) THEN CALL MUMPS_INIT_POOL_DIST_NONA( N, MYLEAF, MYID_NODES, & nb_prun_leaves, Pruned_Leaves, KEEP, KEEP8, & STEP, PROCNODE_STEPS, IW1(IPOOL), LPOOL ) MYLEAF = MYLEAF - 1 DEALLOCATE(Pruned_Leaves) ELSE CALL MUMPS_INIT_POOL_DIST( N, MYLEAF, MYID_NODES, & SLAVEF, NA, LNA, KEEP, KEEP8, STEP, & PROCNODE_STEPS, IW1(IPOOL), LPOOL ) MYLEAF = MYLEAF - 1 ENDIF ENDIF CALL DMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1), & LWC, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSINTR,LRHSINTR,POSINRHSINTR_FWD, & STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF, MYROOT, INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE_LOC, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) IF (DO_PRUN_FWD) THEN MYLEAF = -1 ENDIF #if defined(V_T) CALL VTEND(forw_soln,ierr) #endif ENDIF CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, MYID ) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) THEN IF ( LP .GT. 0 ) THEN WRITE(LP,*) MYID, & ': ** ERROR RETURN FROM DMUMPS_SOL_R,INFO(1:2)=', & INFO(1:2) END IF GOTO 500 END IF CALL MPI_BARRIER( COMM_NODES, IERR ) IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_FWD) DKEEP(117)=TIME_FWD + DKEEP(117) ENDIF IF ( .NOT.( & DOBACKWARD.AND. & (DO_PRUN_BWD.OR.(Lnodes_BWD_ROOTS.NE.NA(2))) & ) & ) THEN IF (.NOT. DO_L0OMP_BWD ) THEN IF ( allocated(TO_PROCESS) .AND. SIZE_TO_PROCESS.NE.1 ) THEN DEALLOCATE (TO_PROCESS) SIZE_TO_PROCESS = 1 ALLOCATE(TO_PROCESS(SIZE_TO_PROCESS),stat=I) ENDIF ENDIF ENDIF IF ( (KEEP(111).NE.0).AND.DOBACKWARD.AND. & ( & DO_PRUN_BWD & ) & ) THEN nb_prun_leaves = 0 IF ( Lnodes_BWD_ROOTS.NE.NA(2) ) THEN nodes_BWD_PTR => Pruned_Roots_FWD Lnodes_BWD_PTR = Lnodes_BWD_ROOTS ELSE IF ( (Exploit_Sparsity_BWD.AND.KEEP(111).NE.0) & ) THEN LPruned_Roots_NS = 0 Pruned_SONS(:) = -1 DO II = 1, NZ_RHS I = IRHS_SPARSE(II) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) ISTEP = abs(STEP(I)) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN LPruned_Roots_NS = LPruned_Roots_NS +1 Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ALLOCATE(Pruned_Roots_NS(LPruned_Roots_NS), STAT = allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of nodes_BWD' INFO(1) = -13 INFO(2) = LPruned_Roots_NS CALL MUMPS_ABORT() END IF LPruned_Roots_NS = 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 LPruned_Roots_NS = LPruned_Roots_NS +1 Pruned_Roots_NS(LPruned_Roots_NS) = INODE_PRINC Pruned_SONS(ISTEP) = 0 ENDIF ENDDO nodes_BWD_PTR => Pruned_Roots_NS Lnodes_BWD_PTR = LPruned_Roots_NS ENDIF IF ( & (Exploit_Sparsity_BWD.AND.KEEP(111).NE.0) .OR. & (Lnodes_BWD_ROOTS.NE.NA(2)) & ) THEN CALL DMUMPS_TREE_PRUN_NODES( & .FALSE., & DAD, NE_STEPS, FRERE, KEEP(28), & FILS, STEP, N, & nodes_BWD_PTR, Lnodes_BWD_PTR, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves & ) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL DMUMPS_TREE_PRUN_NODES( & .TRUE., & DAD, NE_STEPS, FRERE, KEEP(28), & FILS, STEP, N, & nodes_BWD_PTR, Lnodes_BWD_PTR, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IF(allocated(Pruned_Roots_NS)) DEALLOCATE(Pruned_Roots_NS) IF(allocated(Pruned_Roots_FWD)) DEALLOCATE(Pruned_Roots_FWD) CALL DMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF ENDIF ENDIF IF(KEEP(201).EQ.1.AND.DOROOT_BWD_PANEL) THEN I_WORKED_ON_ROOT = .FALSE. CALL DMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE, & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) IF (IERR .LT. 0) THEN INFO(1) = -90 INFO(2) = IERR ENDIF ENDIF IF (KEEP(201).EQ.1) THEN CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF IF (KEEP(60).NE.0 .AND. KEEP(221).EQ.0 & .AND. MYID_NODES .EQ. MASTER_ROOT) THEN RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO ENDIF IF (.NOT. FROM_PP) THEN CALL MUMPS_SECDEB(TIME_SpecialRoot) ENDIF IF ( ( KEEP( 38 ) .NE. 0 ).AND. SPECIAL_ROOT_REACHED ) THEN IF ( KEEP(60) .EQ. 0 .AND. KEEP(252) .EQ. 0 ) THEN IF ( root%yes ) THEN IF (KEEP(201).GT.0) THEN IF ( (Exploit_Sparsity_FWD.AND.(KEEP(111).NE.0)) .and. & (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) ) THEN GOTO 1010 ENDIF ENDIF IOLDPS = PTRIST(STEP(KEEP(38))) LOCAL_M = IW( IOLDPS + 2 + KEEP(IXSZ)) LOCAL_N = IW( IOLDPS + 1 + KEEP(IXSZ)) IF (KEEP(201).GT.0) THEN CALL DMUMPS_SOLVE_GET_OOC_NODE( & KEEP(38),PTRFAC,KEEP,A,LA, & STEP,KEEP8,N,DUMMY_BOOL,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) '** ERROR after DMUMPS_SOLVE_GET_OOC_NODE', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF IAPOS = PTRFAC(IW( IOLDPS + 4 + KEEP(IXSZ))) IF (LOCAL_M * LOCAL_N .EQ. 0) THEN IAPOS = min(IAPOS, LA) ENDIF #if defined(V_T) CALL VTBEGIN(root_soln,ierr) #endif CALL DMUMPS_ROOT_SOLVE( NRHS, root%DESCRIPTOR(1), & root%CNTXT_BLACS, LOCAL_M, LOCAL_N, & root%MBLOCK, root%NBLOCK, & root%IPIV(1), root%LPIV, MASTER_ROOT, MYID_NODES, & COMM_NODES, & RHS_ROOT(1), & root%TOT_ROOT_SIZE, A( IAPOS ), & INFO(1), MTYPE, KEEP(50), FROM_PP) IF(KEEP(201).GT.0)THEN CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(KEEP(38), & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) & '** ERROR after DMUMPS_FREE_FACTORS_FOR_SOLVE ', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF ENDIF ENDIF ELSE IF ( ( KEEP(20) .NE. 0) .AND. SPECIAL_ROOT_REACHED ) THEN IF ( MYID_NODES .eq. MASTER_ROOT ) THEN IF ( KEEP(60) .eq. 0 ) THEN IF (KEEP(201).GT.0) THEN CALL DMUMPS_SOLVE_GET_OOC_NODE( & KEEP(20),PTRFAC,KEEP,A,LA, & STEP,KEEP8,N,DUMMY_BOOL,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) '** ERROR after DMUMPS_SOLVE_GET_OOC_NODE', & INFO(1) call MUMPS_ABORT() ENDIF END IF NRHS_LOC = NRHS IPT_RHS_ROOT_LOC = 1 IF ( KEEP(111).NE.0 ) THEN RHS_ROOT( 1: NRHS*SIZE_ROOT) = ZERO NRHS_LOC = IEND_ROOT_DEF - IBEG_ROOT_DEF + 1 IPT_RHS_ROOT_LOC = IPT_RHS_ROOT_LOC + & (IROOT_DEF_RHS_COL1-1)*SIZE_ROOT ENDIF IF (NRHS_LOC .GT. 0) THEN CALL DMUMPS_SEQ_SOLVE_ROOT_SVD_QR(NRHS_LOC, & SIZE_ROOT,A( PTRFAC( & IW( PTRIST(STEP(KEEP(20)))+4+KEEP(IXSZ)))), & root, roota, IBEG_ROOT_DEF, IEND_ROOT_DEF, & RHS_ROOT( IPT_RHS_ROOT_LOC ), & KEEP,KEEP8, & MTYPE,INFO,LWC,W(1), LP) ENDIF IF(KEEP(201).GT.0)THEN CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(KEEP(20), & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) & '** ERROR after DMUMPS_FREE_FACTORS_FOR_SOLVE ', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF ENDIF END IF END IF IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_SpecialRoot) DKEEP(119)=TIME_SpecialRoot + DKEEP(119) ENDIF #if defined(V_T) CALL VTEND(root_soln,ierr) #endif 1010 CONTINUE CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) RETURN IF (DOBACKWARD) THEN IF ( KEEP(201).GT.0 .AND. .NOT. DOROOT_BWD_PANEL ) & THEN I_WORKED_ON_ROOT = DOROOT IF (KEEP(38).gt.0 ) THEN IF ( ( Exploit_Sparsity_FWD.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_FWD.AND.(KEEP(111).NE.0)) THEN IF (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) THEN I_WORKED_ON_ROOT = .FALSE. ENDIF ENDIF ENDIF ENDIF IF (.NOT.AM1) THEN DO_NBSPARSE_BWD = .FALSE. ELSE DO_NBSPARSE_BWD = DO_NBSPARSE ENDIF PRUN_BELOW_BWD = DO_PRUN_BWD .AND. KEEP(111).EQ.0 PRUN_BELOW_BWD = PRUN_BELOW_BWD .OR. DO_L0OMP_BWD IF ( DO_PRUN_BWD ) THEN CALL DMUMPS_CHAIN_PRUN_NODES( & .FALSE., & DAD, KEEP(28), & STEP, N, & nodes_BWD, Lnodes_BWD, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, & nb_prun_leaves) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL DMUMPS_CHAIN_PRUN_NODES( & .TRUE., & DAD, KEEP(28), & STEP, N, & nodes_BWD, Lnodes_BWD, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves ) CALL DMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL DMUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP #if defined(STAT_ES_SOLVE) & , NRHS, COMM_NODES, IW, LIW, PTRIST,KEEP(IXSZ),1, & KEEP(50), KEEP(38) #endif & ) IF (DO_NBSPARSE_BWD) THEN nb_sparse = max(1,KEEP(497)) CALL DMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243), & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23), & RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & 1) CALL DMUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, KEEP(485), #if defined(STAT_ES_SOLVE) & KEEP(46), & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, #endif & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,1, & KEEP(50), KEEP(38)) END IF ENDIF IF ( KEEP(201).GT.0 ) THEN IROOT = max(KEEP(20),KEEP(38)) CALL DMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE, & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) ENDIF IF ( KEEP( 50 ) .eq. 0 ) THEN MTYPE_LOC = MTYPE ELSE MTYPE_LOC = 0 ENDIF #if defined(V_T) CALL VTBEGIN(back_soln,ierr) #endif IF (.NOT.FROM_PP) THEN CALL MUMPS_SECDEB(TIME_BWD) ENDIF IF ( .NOT.SPECIAL_ROOT_REACHED ) THEN RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO ENDIF IF (AM1.AND.(NB_FS_IN_RHSINTR_F.NE.NB_FS_IN_RHSINTR_TOT)) THEN DO I =1, N II = POSINRHSINTR_BWD(I) IF ((II.GT.0).AND.(II.GT.NB_FS_IN_RHSINTR_F)) THEN DO K=1,NRHS RHSINTR(II, K) = ZERO ENDDO ENDIF ENDDO ENDIF IF ( .NOT. DO_PRUN_BWD ) THEN IF ( .NOT. DO_L0OMP_BWD ) THEN IF (DO_L0OMP_FWD) THEN MYLEAF = -1 ENDIF ENDIF IF ( DO_L0OMP_BWD ) THEN TO_PROCESS(:) = .TRUE. DO I=1, L_PHYS_L0_OMP TO_PROCESS( STEP(PHYS_L0_OMP( I ))) & = .FALSE. ENDDO IF (MYLEAF .EQ. -1) THEN MYLEAF = IPOOL_A_L0_OMP(LPOOL_A_L0_OMP) ENDIF CALL MUMPS_INIT_POOL_DIST_NA_BWD_L0( N, MYROOT, MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL, L0_OMP_MAPPING ) ELSE CALL MUMPS_INIT_POOL_DIST_NA_BWD( N, MYROOT, MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL ) IF (MYLEAF .EQ. -1) THEN CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & NA(1), & NA(3), & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) ENDIF ENDIF ELSE IF ( DO_L0OMP_BWD ) THEN DO I=1, L_PHYS_L0_OMP IF ( TO_PROCESS( STEP(PHYS_L0_OMP( I ))) ) THEN TO_PROCESS( STEP(PHYS_L0_OMP( I ))) = .FALSE. PHYS_L0_OMP( I ) = -PHYS_L0_OMP( I ) ENDIF ENDDO MYLEAF=0 DO ISTEP = 1, KEEP(28) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199)) & .NE. MYID_NODES ) THEN CYCLE ENDIF IF ( L0_OMP_MAPPING( ISTEP ) .NE. 0 ) THEN CYCLE ENDIF IF ( .NOT. TO_PROCESS( ISTEP ) ) THEN CYCLE ENDIF I = Step2Node( ISTEP ) ICHILD = FILS ( I ) DO WHILE ( ICHILD .GT. 0 ) ICHILD = FILS( ICHILD ) END DO IF ( ICHILD .LT. 0 ) THEN ICHILD = -ICHILD DO WHILE ( ICHILD .GT. 0 ) IF ( L0_OMP_MAPPING( STEP( ICHILD ) ) .EQ. 0 .AND. & TO_PROCESS(STEP( ICHILD )) ) THEN GOTO 10 ENDIF ICHILD = FRERE( STEP( ICHILD ) ) ENDDO ENDIF MYLEAF = MYLEAF + 1 10 CONTINUE ENDDO CALL MUMPS_INIT_POOL_DIST_NA_BWDL0ES( N, MYROOT, & MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL, L0_OMP_MAPPING, TO_PROCESS ) ELSE CALL MUMPS_INIT_POOL_DIST_BWD(N, nb_prun_roots, & Pruned_Roots, & MYROOT, MYID_NODES, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL) CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & nb_prun_leaves, Pruned_Leaves, & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) ENDIF ENDIF IF ( DO_L0OMP_BWD & ) THEN KEEP(31) = 1 ELSE KEEP(31) = 0 ENDIF IF (KEEP(31) .EQ. 1) THEN DO I = 1, KEEP(28) IF (MUMPS_PROCNODE(PROCNODE_STEPS(I),KEEP(199)) .EQ. & MYID_NODES) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(I), & KEEP(199)) ) THEN IF ( L0_OMP_MAPPING(I) .EQ. 0 ) THEN IF ( DO_PRUN_BWD & .OR. DO_L0OMP_BWD & ) THEN IF ( TO_PROCESS(I) ) THEN KEEP(31) = KEEP(31) + 1 ENDIF ELSE KEEP(31) = KEEP(31) + 1 ENDIF ENDIF ENDIF ENDIF ENDDO ENDIF CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, MYID ) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL DMUMPS_SOL_S( N, A, LA, IW, LIW, W(1), LWC, & NRHS, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & IW1(PTRICB),PTRACB,IWCB,LIWW, W2, & NE_STEPS, & STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,MYROOT,ICNTL,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP, KEEP8, DKEEP, & RHS_ROOT, LRHS_ROOT, & MTYPE_LOC, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), & LPANEL_POS, PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE_BWD & , FROM_PP & , L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) IF ( DO_L0OMP_BWD .AND. DO_PRUN_BWD ) THEN DO I = 1, L_PHYS_L0_OMP IF ( PHYS_L0_OMP( I ) .LT. 0 ) THEN PHYS_L0_OMP( I ) = -PHYS_L0_OMP( I ) TO_PROCESS(STEP(PHYS_L0_OMP( I ) )) = .TRUE. ENDIF ENDDO ENDIF CALL MUMPS_STOP_ON_USER_REQUEST(KEEP, KEEP8, ICNTL, INFO, MYID) IF (DO_L0OMP_BWD .AND. INFO(1) .GE. 0) THEN KEEP(31) = 0 PRUN_BELOW_BWD = DO_PRUN_BWD .AND. KEEP(111).EQ.0 KEEP(405)=1 CALL DMUMPS_SOL_L0OMP_S(N, MTYPE_LOC, NRHS, LIW, IW, & IW1(PTRICB), PTRACB, RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & STEP, FRERE, FILS, NE_STEPS, PTRIST, PTRFAC, INFO, & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & IW1(IPANEL_POS), LPANEL_POS, & PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE_BWD, & FROM_PP, & LPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, & L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS ) KEEP(405)=0 ENDIF CALL MUMPS_CLEAN_PENDING( INFO(1), KEEP, & BUFR, LBUFR,LBUFR_BYTES, & COMM_NODES, IDUMMY, & SLAVEF, .TRUE., .FALSE. ) CALL MUMPS_STOP_ON_USER_REQUEST(KEEP, KEEP8, ICNTL, INFO, MYID) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) #if defined(V_T) CALL VTEND(back_soln,ierr) #endif IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_BWD) DKEEP(118)=TIME_BWD+DKEEP(118) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (DOFORWARD) THEN K = min(10,size(RHSINTR,1)) IF (LDIAG.EQ.4) K = size(RHSINTR,1) IF ( .NOT. FROM_PP) THEN WRITE (MP,99992) IF (size(RHSINTR,1).GT.0) & WRITE (MP,99993) (RHSINTR(I,1),I=1,K) IF (size(RHSINTR,1).GT.0.and.NRHS>1) & WRITE (MP,99994) (RHSINTR(I,2),I=1,K) ENDIF ENDIF ENDIF 500 CONTINUE IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) IF (DO_PRUN_FWD.OR.DO_PRUN_BWD) THEN IF ( allocated(Pruned_Roots_FWD)) & DEALLOCATE (Pruned_Roots_FWD) IF ( allocated(Pruned_Roots_NS)) & DEALLOCATE (Pruned_Roots_NS) IF ( allocated(Pruned_SONS)) DEALLOCATE (Pruned_SONS) IF ( allocated(Pruned_Roots)) DEALLOCATE (Pruned_Roots) IF ( allocated(Pruned_List)) DEALLOCATE (Pruned_List) IF ( allocated(Pruned_Leaves)) DEALLOCATE (Pruned_Leaves) ENDIF RETURN 99993 FORMAT (' RHS (internal, first column)'/(1X,1P,5D14.6)) 99994 FORMAT (' RHS (internal, 2 nd column)'/(1X,1P,5D14.6)) 99992 FORMAT (//' LEAVING SOLVE (DMUMPS_SOL_C) WITH') END SUBROUTINE DMUMPS_SOL_C SUBROUTINE DMUMPS_SET_POSTPros (KEEP, ICNTL, NBRHS, MPG, PROKG, & ICNTL10, ICNTL11, POSTPros) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP(500), ICNTL(60), NBRHS, MPG LOGICAL, INTENT(IN) :: PROKG INTEGER, INTENT(OUT) :: ICNTL10, ICNTL11 LOGICAL, INTENT(OUT) :: POSTPros POSTPros = .FALSE. IF (ICNTL11.NE.0 .OR. ICNTL10.NE.0) THEN POSTPros = .TRUE. IF (KEEP(111).NE.0) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: null space basis', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(237) .NE.0 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: AM1', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(252) .NE.0 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: Fwd in facto ', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF (KEEP(221).NE.0) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: reduced RHS', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF (NBRHS.GT. 1 .OR. ICNTL(21) .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: nrhs>1 or distrib sol', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(248) .EQ. -1 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: distrib rhs', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ENDIF IF (.NOT.POSTPros) THEN ICNTL11 = 0 ICNTL10 = 0 ENDIF ENDIF IF ((ICNTL(10) .NE. 0) .AND. (ICNTL10 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 ' ENDIF IF ((ICNTL(11) .NE. 0) & .AND.(ICNTL11 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF RETURN END SUBROUTINE DMUMPS_SET_POSTPros SUBROUTINE DMUMPS_GATHER_SOLUTION( NSLAVES, N, MYID, COMM, & NRHS, & MTYPE, RHS, LRHS, NCOL_RHS, JBEG_RHS, PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, CWORK, LCWORK, #if defined(USE_OLD_SCALING) & LSCAL, SCALING, LSCALING, #else & LSCAL, SCALING_LOC_BWD, LSCALING_LOC_BWD, #endif & RHSINTR, LRHSINTR, NCOL_RHSINTR, & POSINRHSINTR, LPOS_N, PERM_RHS, SIZE_PERM_RHS ) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE, NCOL_RHS INTEGER NRHS, LRHS, LCWORK, LPOS_N, NCOL_RHSINTR DOUBLE PRECISION RHS (LRHS, NCOL_RHS) INTEGER, INTENT(in) :: JBEG_RHS INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION :: CWORK(LCWORK) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER SIZE_BUF, SIZE_BUF_BYTES INTEGER BUFFER(SIZE_BUF) INTEGER LRHSINTR, POSINRHSINTR(LPOS_N) #if defined(USE_OLD_SCALING) DOUBLE PRECISION, intent(in) :: RHSINTR(LRHSINTR, NCOL_RHSINTR) INTEGER, intent(in) :: LSCALING DOUBLE PRECISION, intent(in) :: SCALING(LSCALING) #else DOUBLE PRECISION, intent(inout) :: RHSINTR(LRHSINTR, NCOL_RHSINTR) INTEGER, intent(in) :: LSCALING_LOC_BWD DOUBLE PRECISION, intent(in) :: SCALING_LOC_BWD(LSCALING_LOC_BWD) #endif LOGICAL, intent(in) :: LSCAL INTEGER, INTENT(in) :: SIZE_PERM_RHS INTEGER, INTENT(in) :: PERM_RHS(SIZE_PERM_RHS) INTEGER I, II, J, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL, N2RECV INTEGER LIELL, IPOS, NPIV, MAXNPIV_estim, MAXSurf INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR, allocok PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND, IPOSINRHSINTR INTEGER :: JCOL_RHS INTEGER :: K242 LOGICAL :: OMP_FLAG !$ INTEGER :: CHUNK, NOMP INTEGER, PARAMETER :: FIN = -1 DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER, ALLOCATABLE, DIMENSION(:) :: IROWlist INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_PROCNODE TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 IF ( TYPE_PARAL == 1 ) THEN MYID_NODES = MYID ELSE MYID_NODES = MYID-1 ENDIF IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN IF (LSCAL) THEN OMP_FLAG = .FALSE. IF (KEEP(350).EQ.2) THEN K242 = KEEP(242) !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK = max(N/2,1) !$ IF (int(NRHS,8) * int(N,8) .GE. int(KEEP(363),8)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8)) !$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362)) !$ CHUNK = max(KEEP(363)/2,CHUNK) !$ ENDIF ENDIF IF (OMP_FLAG) THEN !$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242) !$OMP& PRIVATE(J,IPOSINRHSINTR,I,JCOL_RHS) DO J=1, NRHS IF (K242.EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF !$OMP DO SCHEDULE(DYNAMIC,CHUNK) DO I=1, N IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN RHS(I,JCOL_RHS) = RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ELSE DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO I=1, N IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN RHS(I,JCOL_RHS) = RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO ENDDO ENDIF ELSE OMP_FLAG = .FALSE. IF (KEEP(350).EQ.2) THEN K242 = KEEP(242) !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = max(N/2,1) !$ IF (NRHS * N .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8)) !$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362)) !$ CHUNK = max(KEEP(363)/2,CHUNK) !$ ENDIF ENDIF IF (OMP_FLAG) THEN !$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242) !$OMP& PRIVATE(IPOSINRHSINTR,I,JCOL_RHS) IF (OMP_FLAG) DO J=1, NRHS IF (K242.EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF !$OMP DO SCHEDULE(DYNAMIC,CHUNK) DO I=1, N IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN RHS(I,JCOL_RHS) = RHSINTR(IPOSINRHSINTR,J) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ELSE DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO I=1, N IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN RHS(I,JCOL_RHS) = RHSINTR(IPOSINRHSINTR,J) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO ENDDO ENDIF ENDIF RETURN ENDIF MAXNPIV_estim = max(KEEP(246), KEEP(247)) MAXSurf = MAXNPIV_estim*NRHS IF (LCWORK .LT. MAXNPIV_estim) THEN WRITE(*,*) MYID, & ": Internal error 2 in DMUMPS_GATHER_SOLUTION:", & TYPE_PARAL, LCWORK, KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF IF (MYID.EQ.MASTER) THEN ALLOCATE(IROWlist(KEEP(247)),stat=allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of IROWlist' CALL MUMPS_ABORT() ENDIF ENDIF IF (NSLAVES .EQ. 1 .AND. TYPE_PARAL .EQ. 1) THEN CALL MUMPS_ABORT() ENDIF SIZE1=0 CALL MPI_PACK_SIZE(MAXNPIV_estim+2,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(MAXSurf,MPI_DOUBLE_PRECISION, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in DMUMPS_GATHER_SOLUTION ' write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', & RECORD_SIZE_P_1, SIZE_BUF_BYTES CALL MUMPS_ABORT() ENDIF N2SEND =0 N2RECV =N POS_BUF =0 IF (I_AM_SLAVE) THEN POS_BUF = 0 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N) IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-NPIV IF (NPIV.GT.0) & CALL DMUMPS_NPIV_BLOCK_ADD ( .TRUE. ) ELSE IF (NPIV.GT.0) & CALL DMUMPS_NPIV_BLOCK_ADD ( .FALSE.) ENDIF ENDIF ENDDO CALL DMUMPS_NPIV_BLOCK_SEND() ENDIF IF ( MYID .EQ. MASTER ) THEN DO WHILE (N2RECV .NE. 0) CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, & MPI_ANY_SOURCE, & GatherSol, COMM, STATUS, IERR ) POS_BUF = 0 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & NPIV, 1, MPI_INTEGER, COMM, IERR) DO WHILE (NPIV.NE.FIN) CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & IROWlist, NPIV, MPI_INTEGER, COMM, IERR) DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS=J+JBEG_RHS-1 ELSE JCOL_RHS=PERM_RHS(J+JBEG_RHS-1) ENDIF CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & CWORK, NPIV, MPI_DOUBLE_PRECISION, & COMM, IERR) #if defined(USE_OLD_SCALING) IF (LSCAL) THEN DO I=1,NPIV RHS(IROWlist(I),JCOL_RHS)=CWORK(I)*SCALING(IROWlist(I)) ENDDO ELSE #else #endif DO I=1,NPIV RHS(IROWlist(I),JCOL_RHS)=CWORK(I) ENDDO #if defined(USE_OLD_SCALING) ENDIF #endif ENDDO N2RECV=N2RECV-NPIV CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, & NPIV, 1, MPI_INTEGER, COMM, IERR) ENDDO ENDDO DEALLOCATE(IROWlist) ENDIF RETURN CONTAINS SUBROUTINE DMUMPS_NPIV_BLOCK_ADD ( ON_MASTER ) LOGICAL, intent(in) :: ON_MASTER INTEGER :: JPOS, K242 LOGICAL :: PRIV_LSCAL IF (ON_MASTER) THEN IF (KEEP(350).EQ.2 & .AND. (NRHS.EQ.1.OR.((NPIV*NRHS*2*KEEP(16)).GE.KEEP(364)))) THEN PRIV_LSCAL = LSCAL K242 = KEEP(242) DO J=1, NRHS IF (K242.EQ.0) THEN JPOS = J+JBEG_RHS-1 ELSE JPOS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) IF (PRIV_LSCAL) THEN RHS(I,JPOS) = RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ELSE RHS(I,JPOS) = RHSINTR(IPOSINRHSINTR,J) ENDIF ENDDO ENDDO ELSE IF (KEEP(242).EQ.0) THEN IF (LSCAL) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ENDDO ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = RHSINTR(IPOSINRHSINTR,J) ENDDO ENDDO ENDIF ELSE IF (LSCAL) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) !DIR$ NOVECTOR DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ENDDO ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) !DIR$ NOVECTOR DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSINTR(IPOSINRHSINTR,J) ENDDO ENDDO ENDIF ENDIF ENDIF RETURN ENDIF CALL MPI_PACK(NPIV, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(IW(J1), NPIV, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) IPOSINRHSINTR= POSINRHSINTR(IW(J1)) DO J=1,NRHS #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO II=IPOSINRHSINTR, IPOSINRHSINTR+NPIV-1 RHSINTR(II,J)= & RHSINTR(II,J)*SCALING_LOC_BWD(II) ENDDO ENDIF #endif CALL MPI_PACK(RHSINTR(IPOSINRHSINTR,J), NPIV, & MPI_DOUBLE_PRECISION, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ENDDO N2SEND=N2SEND+NPIV IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL DMUMPS_NPIV_BLOCK_SEND() END IF RETURN END SUBROUTINE DMUMPS_NPIV_BLOCK_ADD SUBROUTINE DMUMPS_NPIV_BLOCK_SEND() IF (N2SEND .NE. 0) THEN CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, & GatherSol, COMM, IERR) ENDIF POS_BUF=0 N2SEND=0 RETURN END SUBROUTINE DMUMPS_NPIV_BLOCK_SEND END SUBROUTINE DMUMPS_GATHER_SOLUTION SUBROUTINE DMUMPS_GATHER_SOLUTION_AM1(NSLAVES, N, MYID, COMM, & NRHS, RHSINTR, LRHSINTR, NRHSINTR_COL, & KEEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, #if defined(USE_OLD_SCALING) & LSCAL, SCALING, LSCALING, #else & LSCAL, SCALING_LOC_BWD, LSCALING_LOC_BWD, #endif & IRHS_PTR_COPY, LIRHS_PTR_COPY, & IRHS_SPARSE_COPY, LIRHS_SPARSE_COPY, & RHS_SPARSE_COPY, LRHS_SPARSE_COPY, & UNS_PERM_INV, LUNS_PERM_INV, & POSINRHSINTR, LPOS_ROW, NB_FS_IN_RHSINTR ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM INTEGER NRHS, LRHSINTR, NRHSINTR_COL DOUBLE PRECISION, intent(in) :: RHSINTR (LRHSINTR, NRHSINTR_COL) INTEGER KEEP(500) INTEGER SIZE_BUF, SIZE_BUF_BYTES, LPOS_ROW INTEGER BUFFER(SIZE_BUF) INTEGER, intent(in) :: LIRHS_PTR_COPY, LIRHS_SPARSE_COPY, & LRHS_SPARSE_COPY, LUNS_PERM_INV, & NB_FS_IN_RHSINTR INTEGER :: IRHS_SPARSE_COPY(LIRHS_SPARSE_COPY), & IRHS_PTR_COPY(LIRHS_PTR_COPY), & UNS_PERM_INV(LUNS_PERM_INV), & POSINRHSINTR(LPOS_ROW) DOUBLE PRECISION :: RHS_SPARSE_COPY(LRHS_SPARSE_COPY) #if defined(USE_OLD_SCALING) INTEGER, intent(in) :: LSCALING DOUBLE PRECISION, intent(in) :: SCALING(LSCALING) #else INTEGER, intent(in) :: LSCALING_LOC_BWD DOUBLE PRECISION, intent(in) :: SCALING_LOC_BWD(LSCALING_LOC_BWD) #endif LOGICAL, intent(in) :: LSCAL INTEGER COLSIZE, K, IZ, IPREV, NBCOL_INBLOC INTEGER I, II, J, MASTER, & TYPE_PARAL, N2RECV, IPOSINRHSINTR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND INTEGER, PARAMETER :: FIN = -1 INCLUDE 'mumps_headers.h' TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 NBCOL_INBLOC = size(IRHS_PTR_COPY)-1 IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN K=1 DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.EQ.0) CYCLE DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)= & RHSINTR(IPOSINRHSINTR,K) #if defined(USE_OLD_SCALING) & * SCALING(I) #else & * SCALING_LOC_BWD(IPOSINRHSINTR) #endif ELSE RHS_SPARSE_COPY(IZ)=RHSINTR(IPOSINRHSINTR,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) IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)=RHSINTR(IPOSINRHSINTR,K) & * SCALING_LOC_BWD(IPOSINRHSINTR) ELSE #endif RHS_SPARSE_COPY(IZ)=RHSINTR(IPOSINRHSINTR,K) #if ! defined(USE_OLD_SCALING) ENDIF #endif ENDIF ENDDO K = K + 1 ENDDO ENDIF SIZE1=0 CALL MPI_PACK_SIZE(3,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(1,MPI_DOUBLE_PRECISION, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in DMUMPS_GATHER_SOLUTION_AM1 ' write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', & RECORD_SIZE_P_1, SIZE_BUF_BYTES CALL MUMPS_ABORT() ENDIF N2SEND =0 N2RECV =size(IRHS_SPARSE_COPY) POS_BUF =0 IF (I_AM_SLAVE) THEN DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.LE.0) CYCLE K = 0 DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) II = I IF (KEEP(23).NE.0) II = UNS_PERM_INV(I) IPOSINRHSINTR = POSINRHSINTR(II) IF (IPOSINRHSINTR.GT.0) THEN IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-1 #if defined(USE_OLD_SCALING) IF (LSCAL) & CALL DMUMPS_AM1_BLOCK_ADD ( .TRUE. ) #endif 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 #if defined(USE_OLD_SCALING) CALL DMUMPS_AM1_BLOCK_ADD ( .FALSE. ) #else CALL DMUMPS_AM1_BLOCK_ADD () #endif ENDIF ENDIF ENDDO IF (MYID.EQ.MASTER) & IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + K ENDDO CALL DMUMPS_AM1_BLOCK_SEND() ENDIF IF ( MYID .EQ. MASTER ) THEN DO WHILE (N2RECV .NE. 0) CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, & MPI_ANY_SOURCE, & GatherSol, COMM, STATUS, IERR ) POS_BUF = 0 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & J, 1, MPI_INTEGER, COMM, IERR) DO WHILE (J.NE.FIN) IZ = IRHS_PTR_COPY(J) CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & I, 1, MPI_INTEGER, COMM, IERR) IRHS_SPARSE_COPY(IZ) = I CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & RHS_SPARSE_COPY(IZ), 1, MPI_DOUBLE_PRECISION, & COMM, IERR) #if defined(USE_OLD_SCALING) IF (LSCAL) THEN IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) RHS_SPARSE_COPY(IZ) = RHS_SPARSE_COPY(IZ)*SCALING(I) ENDIF #endif N2RECV=N2RECV-1 IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + 1 CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, & J, 1, MPI_INTEGER, COMM, IERR) ENDDO ENDDO IPREV = 1 DO J=1, size(IRHS_PTR_COPY)-1 I= IRHS_PTR_COPY(J) IRHS_PTR_COPY(J) = IPREV IPREV = I ENDDO ENDIF RETURN CONTAINS SUBROUTINE DMUMPS_AM1_BLOCK_ADD ( #if defined(USE_OLD_SCALING) & SCALE_ONLY #endif & ) #if defined(USE_OLD_SCALING) LOGICAL, intent(in) :: SCALE_ONLY #endif #if defined(USE_OLD_SCALING) INTEGER III #endif #if defined(USE_OLD_SCALING) IF (SCALE_ONLY) THEN WRITE(*,*) "DMUMPS_AM1_BLOCK_ADD(true) should not be called" CALL MUMPS_ABORT() 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 #endif CALL MPI_PACK(J, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(I, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(RHS_SPARSE_COPY(IZ), 1, MPI_DOUBLE_PRECISION, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) N2SEND=N2SEND+1 IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL DMUMPS_AM1_BLOCK_SEND() END IF RETURN END SUBROUTINE DMUMPS_AM1_BLOCK_ADD SUBROUTINE DMUMPS_AM1_BLOCK_SEND() IF (N2SEND .NE. 0) THEN CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, & GatherSol, COMM, IERR) ENDIF POS_BUF=0 N2SEND=0 RETURN END SUBROUTINE DMUMPS_AM1_BLOCK_SEND END SUBROUTINE DMUMPS_GATHER_SOLUTION_AM1 SUBROUTINE DMUMPS_DISTSOL_INDICES(MTYPE, ISOL_LOC, & PTRIST, KEEP,KEEP8, & IW, LIW_PASSED, MYID_NODES, N, STEP, & PROCNODE, NSLAVES, #if defined(USE_OLD_SCALING) & scaling_data, LSCAL, #endif & IRHS_loc_MEANINGFUL, IRHS_loc, Nloc_RHS & ) IMPLICIT NONE INTEGER MTYPE, MYID_NODES, N, NSLAVES INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE(KEEP(28)) INTEGER ISOL_LOC(KEEP(89)) INTEGER LIW_PASSED INTEGER IW(LIW_PASSED) INTEGER STEP(N) #if defined(USE_OLD_SCALING) LOGICAL LSCAL #endif LOGICAL :: IRHS_loc_MEANINGFUL INTEGER :: Nloc_RHS INTEGER :: IRHS_loc(Nloc_RHS) #if defined(USE_OLD_SCALING) type scaling_data_t SEQUENCE DOUBLE PRECISION, dimension(:), pointer :: SCALING DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC INTEGER, dimension(:), pointer :: SCALING_IND end type scaling_data_t type (scaling_data_t) :: scaling_data #endif INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER ISTEP, K INTEGER J1, IPOS, LIELL, NPIV, JJ LOGICAL :: CHECK_IRHS_loc INTEGER(8) :: DIFF_ADDR INCLUDE 'mumps_headers.h' CHECK_IRHS_loc=.FALSE. IF ( IRHS_loc_MEANINGFUL ) THEN IF (Nloc_RHS .GT. 0) THEN CALL MUMPS_SIZE_C( IRHS_loc(1), ISOL_loc(1), & DIFF_ADDR ) IF (DIFF_ADDR .EQ. 0_8) THEN CHECK_IRHS_loc=.TRUE. ENDIF ENDIF ENDIF K=0 DO ISTEP=1, KEEP(28) IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW_PASSED, PTRIST, STEP, N) IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF DO JJ=J1,J1+NPIV-1 K=K+1 IF (CHECK_IRHS_loc) THEN IF (K.LE.Nloc_RHS) THEN IF ( IW(JJ) .NE.IRHS_LOC(K) ) THEN ENDIF ENDIF ENDIF ISOL_LOC(K)=IW(JJ) #if defined(USE_OLD_SCALING) IF (LSCAL) THEN scaling_data%SCALING_LOC(K)= & scaling_data%SCALING(IW(JJ)) ENDIF #endif ENDDO ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_DISTSOL_INDICES #if ! defined(USE_OLD_SCALING) SUBROUTINE DMUMPS_SCALINGRHSINTR(LSCAL, N, & SCALING_LOC, SCALING_RHSINTR, & L, POSINRHSINTR, KEEP, ROWORCOL, PTRIST, & IW, LIW_PASSED, MYID_NODES, STEP, & PROCNODE, NSLAVES) IMPLICIT NONE INTEGER :: KEEP(500) LOGICAL, INTENT(IN) :: LSCAL INTEGER, INTENT(IN) :: N, L INTEGER, INTENT(IN) :: POSINRHSINTR(N) DOUBLE PRECISION , INTENT(IN) :: SCALING_LOC(max(KEEP(89),1)) DOUBLE PRECISION , INTENT(OUT) :: SCALING_RHSINTR(L) INTEGER, INTENT(IN) :: ROWORCOL, NSLAVES, LIW_PASSED, MYID_NODES INTEGER, INTENT(IN) :: STEP(KEEP(28)), & PROCNODE(KEEP(28)), & PTRIST(KEEP(28)), & IW(LIW_PASSED) INTEGER :: IPOSINRHSINTR INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER :: ISTEP INTEGER :: KLOC, J1, JJ, LIELL, IPOS, NPIV IF (.NOT. LSCAL) THEN WRITE(*,*) "Internal error 1 in DMUMPS_DS_SCALINGRHSINTR" CALL MUMPS_ABORT() ENDIF IF (ROWORCOL .NE. 1 .AND. ROWORCOL.NE.2) THEN WRITE(*,*) "Internal error 2 in DMUMPS_DS_SCALINGRHSINTR", & ROWORCOL ENDIF IF (KEEP(89).EQ.0) RETURN KLOC = 1 DO ISTEP=1, KEEP(28) IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW_PASSED, PTRIST, STEP, N) IF (ROWORCOL .EQ. 1) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IPOSINRHSINTR = POSINRHSINTR(IW(J1)) IF ( IPOSINRHSINTR .GT. 0 ) THEN DO JJ=1, NPIV SCALING_RHSINTR(IPOSINRHSINTR+JJ-1) = & SCALING_LOC(KLOC+JJ-1) ENDDO ENDIF KLOC = KLOC + NPIV ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_SCALINGRHSINTR #endif SUBROUTINE DMUMPS_DISTRIBUTED_SOLUTION( & SLAVEF, N, MYID_NODES, & MTYPE, RHSINTR, LRHSINTR, NBRHS_EFF, & POSINRHSINTR, & ISOL_LOC, & SOL_LOC, NRHS, BEG_RHS, LSOL_LOC, & PTRIST, & PROCNODE_STEPS, KEEP,KEEP8, IW, LIW, STEP, & SCALING_LOC_BWD, LSCALING_LOC_BWD, & LSCAL, NB_RHSSKIPPED, & PERM_RHS, SIZE_PERM_RHS) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' LOGICAL, intent(in) :: LSCAL INTEGER, intent(in) :: LSCALING_LOC_BWD DOUBLE PRECISION, intent(in) :: SCALING_LOC_BWD(LSCALING_LOC_BWD) INTEGER SLAVEF, N, MYID_NODES, LIW, MTYPE, NBRHS_EFF, LRHSINTR INTEGER POSINRHSINTR(N), NB_RHSSKIPPED INTEGER LSOL_LOC, BEG_RHS INTEGER ISOL_LOC(LSOL_LOC) INTEGER, INTENT(in) :: NRHS DOUBLE PRECISION SOL_LOC( LSOL_LOC, NRHS ) DOUBLE PRECISION RHSINTR( LRHSINTR, NBRHS_EFF ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER, INTENT(in) :: SIZE_PERM_RHS INTEGER, INTENT(in) :: PERM_RHS( SIZE_PERM_RHS ) INTEGER :: JJ, J1, ISTEP, K, KLOC, IPOSINRHSINTR, JEMPTY INTEGER :: JCOL, JCOL_PERM INTEGER :: IPOS, LIELL, NPIV, JEND LOGICAL :: IS_ROOT !$ LOGICAL :: OMP_FLAG DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE K=0 JEMPTY = BEG_RHS+NB_RHSSKIPPED-1 JEND = BEG_RHS+NB_RHSSKIPPED+NBRHS_EFF-1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN IS_ROOT=.false. IF (KEEP(38).ne.0) IS_ROOT = STEP(KEEP(38))==ISTEP IF (KEEP(20).ne.0) IS_ROOT = STEP(KEEP(20))==ISTEP IF ( IS_ROOT ) THEN IPOS = PTRIST(ISTEP) + KEEP(IXSZ) LIELL = IW(IPOS+3) NPIV = LIELL IPOS= PTRIST(ISTEP)+5+KEEP(IXSZ) ELSE IPOS = PTRIST(ISTEP) + 2 +KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) IPOS= IPOS+1 NPIV = IW(IPOS) IPOS= IPOS+1 IPOS= IPOS+1+IW( PTRIST(ISTEP) + 5 +KEEP(IXSZ)) END IF IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF IF (NB_RHSSKIPPED.GT.0) THEN DO JCOL = BEG_RHS, JEMPTY IF (KEEP(242) .NE. 0) THEN JCOL_PERM = PERM_RHS(JCOL) ELSE JCOL_PERM = JCOL ENDIF KLOC=K DO JJ=J1,J1+NPIV-1 KLOC=KLOC+1 SOL_LOC(KLOC, JCOL_PERM) = ZERO ENDDO ENDDO ENDIF !$ OMP_FLAG = ( JEND-JEMPTY.GE.KEEP(362) .AND. !$ & (NPIV*(JEND-JEMPTY) .GE. KEEP(363)/2 ) ) !$OMP PARALLEL DO PRIVATE(JCOL,JCOL_PERM,KLOC,JJ,IPOSINRHSINTR) !$OMP& IF(OMP_FLAG) DO JCOL = JEMPTY+1, JEND IF (KEEP(242) .NE. 0) THEN JCOL_PERM = PERM_RHS(JCOL) ELSE JCOL_PERM = JCOL ENDIF DO JJ=J1,J1+NPIV-1 KLOC=K + JJ-J1 + 1 IF (LSCAL) THEN SOL_LOC(KLOC,JCOL_PERM) = & SCALING_LOC_BWD(KLOC)* & RHSINTR(KLOC,JCOL-JEMPTY) ELSE SOL_LOC(KLOC,JCOL_PERM) = & RHSINTR(KLOC,JCOL-JEMPTY) ENDIF ENDDO ENDDO !$OMP END PARALLEL DO K=K+NPIV ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_DISTRIBUTED_SOLUTION SUBROUTINE DMUMPS_SCATTER_RHS & (NSLAVES, N, MYID, COMM, & LSCAL, SCALING_LOC_FWD, & MTYPE, RHS, LRHS, NCOL_RHS, NRHS, & RHSINTR, LRHSINTR, NCOL_RHSINTR, & POSINRHSINTR_FWD, NB_FS_IN_RHSINTR_F, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & ICNTL, INFO) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE INTEGER NRHS, LRHS, NCOL_RHS, LRHSINTR, NCOL_RHSINTR INTEGER ICNTL(60), INFO(80) DOUBLE PRECISION, intent(in) :: RHS (LRHS, NCOL_RHS) DOUBLE PRECISION, intent(out) :: RHSINTR(LRHSINTR, NCOL_RHSINTR) INTEGER, intent(in) :: POSINRHSINTR_FWD(N), NB_FS_IN_RHSINTR_F INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) LOGICAL, intent(in) :: LSCAL DOUBLE PRECISION, intent(in) :: SCALING_LOC_FWD(max(1,KEEP(89))) INTEGER BUF_MAXSIZE, BUF_MAXREF PARAMETER (BUF_MAXREF=200000) INTEGER, ALLOCATABLE, DIMENSION(:) :: BUF_INDX DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: BUF_RHS DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: BUF_RHS_2 INTEGER ENTRIES_2_PROCESS, PROC_WHO_ASKS, BUF_EFFSIZE INTEGER INDX INTEGER allocok DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER I, J, K, JJ, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL INTEGER LIELL, IPOS, NPIV INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE !$ INTEGER :: CHUNK, NOMP !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. 0 .OR. TYPE_PARAL .eq. 1 IF ( TYPE_PARAL == 1 ) THEN MYID_NODES = MYID ELSE MYID_NODES = MYID-1 ENDIF BUF_EFFSIZE = 0 BUF_MAXSIZE = max(min(BUF_MAXREF,int(2000000/NRHS)),2000) IF ( KEEP(350).EQ.2 ) THEN !$ NOMP = OMP_GET_MAX_THREADS() ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS_2(BUF_MAXSIZE*NRHS), & stat=allocok) ELSE ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS(NRHS,BUF_MAXSIZE), & stat=allocok) END IF IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=BUF_MAXSIZE*(NRHS+1) ENDIF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM, MYID ) IF (INFO(1).LT.0) RETURN IF (MYID.EQ.MASTER) THEN ENTRIES_2_PROCESS = N - KEEP(89) IF (TYPE_PARAL.EQ.1.AND.ENTRIES_2_PROCESS.NE.0) THEN IF (NB_FS_IN_RHSINTR_F.LT.LRHSINTR) THEN DO K=1, NCOL_RHSINTR DO I = NB_FS_IN_RHSINTR_F +1, LRHSINTR RHSINTR (I, K) = ZERO ENDDO ENDDO ENDIF ENDIF IF ( KEEP(350).EQ.2 ) THEN DO WHILE ( ENTRIES_2_PROCESS .NE. 0) CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, & ScatterRhsI, COMM, STATUS, IERR ) CALL MPI_GET_COUNT(STATUS,MPI_INTEGER,BUF_EFFSIZE,IERR) PROC_WHO_ASKS = STATUS(MPI_SOURCE) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = BUF_INDX( I ) BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) = RHS( INDX, K ) ENDDO ENDDO !$OMP END PARALLEL DO CALL MPI_SEND( BUF_RHS_2, & NRHS*BUF_EFFSIZE, & MPI_DOUBLE_PRECISION, PROC_WHO_ASKS, & ScatterRhsR, COMM, IERR) ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE ENDDO BUF_EFFSIZE= 0 ELSE DO WHILE ( ENTRIES_2_PROCESS .NE. 0) CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, & ScatterRhsI, COMM, STATUS, IERR ) CALL MPI_GET_COUNT( STATUS, MPI_INTEGER,BUF_EFFSIZE,IERR) PROC_WHO_ASKS = STATUS(MPI_SOURCE) DO I = 1, BUF_EFFSIZE INDX = BUF_INDX( I ) DO K = 1, NRHS BUF_RHS( K, I ) = RHS( INDX, K ) ENDDO ENDDO CALL MPI_SEND( BUF_RHS, NRHS*BUF_EFFSIZE, & MPI_DOUBLE_PRECISION, PROC_WHO_ASKS, & ScatterRhsR, COMM, IERR) ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE ENDDO BUF_EFFSIZE= 0 ENDIF ENDIF IF (I_AM_SLAVE) THEN IF (MYID.NE.MASTER) THEN IF (NB_FS_IN_RHSINTR_F.LT.LRHSINTR) THEN DO K=1, NCOL_RHSINTR DO I = NB_FS_IN_RHSINTR_F +1, LRHSINTR RHSINTR (I, K) = ZERO ENDDO ENDDO ENDIF ENDIF DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF (MYID.EQ.MASTER) THEN INDX = POSINRHSINTR_FWD(IW(J1)) IF (KEEP(350).EQ.2 .AND. & (NRHS.EQ.1.OR.((NPIV*NRHS*2*KEEP(16)).GE.KEEP(364)))) THEN !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (NPIV*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((NPIV*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(J,JJ) !$OMP& FIRSTPRIVATE(INDX) IF (OMP_FLAG) DO K = 1, NRHS DO JJ=J1,J1+NPIV-1 J=IW(JJ) RHSINTR( INDX+JJ-J1, K ) = RHS( J, K ) * & SCALING_LOC_FWD( INDX+JJ-J1 ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE #endif !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(J,JJ) !$OMP& FIRSTPRIVATE(INDX) IF (OMP_FLAG) DO K = 1, NRHS DO JJ=J1,J1+NPIV-1 J=IW(JJ) RHSINTR( INDX+JJ-J1, K ) = RHS( J, K ) ENDDO ENDDO !$OMP END PARALLEL DO #if ! defined(USE_OLD_SCALING) ENDIF #endif ELSE #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO JJ=J1,J1+NPIV-1 J=IW(JJ) DO K = 1, NRHS RHSINTR( INDX+JJ-J1, K ) = RHS( J, K ) & * SCALING_LOC_FWD( INDX + JJ - J1 ) ENDDO ENDDO ELSE #endif DO JJ=J1,J1+NPIV-1 J=IW(JJ) DO K = 1, NRHS RHSINTR( INDX+JJ-J1, K ) = RHS( J, K ) ENDDO ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif END IF ELSE DO JJ=J1,J1+NPIV-1 BUF_EFFSIZE = BUF_EFFSIZE + 1 BUF_INDX(BUF_EFFSIZE) = IW(JJ) IF (BUF_EFFSIZE + 1 .GT. BUF_MAXSIZE) THEN CALL DMUMPS_GET_BUF_INDX_RHS() ENDIF ENDDO ENDIF ENDIF ENDDO IF ( BUF_EFFSIZE .NE. 0 .AND. MYID.NE.MASTER ) & CALL DMUMPS_GET_BUF_INDX_RHS() ENDIF IF (KEEP(350).EQ.2) THEN DEALLOCATE (BUF_INDX, BUF_RHS_2) ELSE DEALLOCATE (BUF_INDX, BUF_RHS) ENDIF RETURN CONTAINS SUBROUTINE DMUMPS_GET_BUF_INDX_RHS() CALL MPI_SEND(BUF_INDX, BUF_EFFSIZE, MPI_INTEGER, & MASTER, ScatterRhsI, COMM, IERR ) IF (KEEP(350).EQ.2) THEN CALL MPI_RECV(BUF_RHS_2, BUF_EFFSIZE*NRHS, & MPI_DOUBLE_PRECISION, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = POSINRHSINTR_FWD(BUF_INDX(I)) RHSINTR( INDX, K ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) * & SCALING_LOC_FWD( INDX ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE #endif !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = POSINRHSINTR_FWD(BUF_INDX(I)) RHSINTR( INDX, K ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) ENDDO ENDDO !$OMP END PARALLEL DO #if ! defined(USE_OLD_SCALING) ENDIF #endif ELSE CALL MPI_RECV(BUF_RHS, BUF_EFFSIZE*NRHS, & MPI_DOUBLE_PRECISION, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO I = 1, BUF_EFFSIZE INDX = POSINRHSINTR_FWD(BUF_INDX(I)) DO K = 1, NRHS RHSINTR( INDX, K ) = BUF_RHS( K, I ) & * SCALING_LOC_FWD( INDX ) ENDDO ENDDO ELSE #endif DO I = 1, BUF_EFFSIZE INDX = POSINRHSINTR_FWD(BUF_INDX(I)) DO K = 1, NRHS RHSINTR( INDX, K ) = BUF_RHS( K, I ) ENDDO ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif END IF BUF_EFFSIZE = 0 RETURN END SUBROUTINE DMUMPS_GET_BUF_INDX_RHS END SUBROUTINE DMUMPS_SCATTER_RHS SUBROUTINE DMUMPS_BUILD_GLOB2LOC & (NSLAVES, N, MYID_NODES, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & GLOB2LOC_RHS, GLOB2LOC_SOL, & GLOB2LOC_SOL_ALLOC, & MTYPE, & NBENT_RHSINTR, NB_FS_IN_RHSINTR ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER, intent(in) :: IW(LIW), STEP(N) INTEGER, intent(in) :: MTYPE LOGICAL, intent(in) :: GLOB2LOC_SOL_ALLOC INTEGER, intent(out):: GLOB2LOC_RHS(N), GLOB2LOC_SOL(N) INTEGER, intent(out):: NBENT_RHSINTR, NB_FS_IN_RHSINTR INTEGER ISTEP INTEGER NPIV INTEGER IPOS, LIELL INTEGER JJ, J1, JCOL INTEGER IPOSINRHSINTR, IPOSINRHSINTR_SOL INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE GLOB2LOC_RHS = 0 IF (GLOB2LOC_SOL_ALLOC) GLOB2LOC_SOL = 0 IPOSINRHSINTR = 1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, NPIV, LIELL, & IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = J1, J1+NPIV-1 GLOB2LOC_RHS(IW(JJ)) = IPOSINRHSINTR+JJ-J1 ENDDO IF (GLOB2LOC_SOL_ALLOC) THEN DO JJ = JCOL, JCOL+NPIV-1 GLOB2LOC_SOL(IW(JJ)) = IPOSINRHSINTR+JJ-JCOL ENDDO ENDIF IPOSINRHSINTR = IPOSINRHSINTR + NPIV ENDIF ENDDO NB_FS_IN_RHSINTR = IPOSINRHSINTR -1 IF (GLOB2LOC_SOL_ALLOC) IPOSINRHSINTR_SOL=IPOSINRHSINTR IF (IPOSINRHSINTR.GT.N) GOTO 500 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF (GLOB2LOC_SOL_ALLOC) THEN DO JJ = NPIV, LIELL-1-KEEP(253) IF (GLOB2LOC_RHS(IW(J1+JJ)).EQ.0) THEN GLOB2LOC_RHS(IW(J1+JJ)) = - IPOSINRHSINTR IPOSINRHSINTR = IPOSINRHSINTR + 1 ENDIF IF (GLOB2LOC_SOL(IW(JCOL+JJ)).EQ.0) THEN GLOB2LOC_SOL(IW(JCOL+JJ)) = - IPOSINRHSINTR_SOL IPOSINRHSINTR_SOL = IPOSINRHSINTR_SOL + 1 ENDIF ENDDO ELSE DO JJ = J1+NPIV, J1+LIELL-1-KEEP(253) IF (GLOB2LOC_RHS(IW(JJ)).EQ.0) THEN GLOB2LOC_RHS(IW(JJ)) = - IPOSINRHSINTR IPOSINRHSINTR = IPOSINRHSINTR + 1 ENDIF ENDDO ENDIF ENDIF ENDDO 500 NBENT_RHSINTR = IPOSINRHSINTR - 1 IF (GLOB2LOC_SOL_ALLOC) & NBENT_RHSINTR = max(NBENT_RHSINTR, IPOSINRHSINTR_SOL-1) RETURN END SUBROUTINE DMUMPS_BUILD_GLOB2LOC SUBROUTINE DMUMPS_NODES_FWD_BWD_SIZE_FILL ( & fill, ICNTL, & N, NSTEPS, KEEP, STEP, Step2node, & IRHS_loc, Nloc_RHS, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & PERM_RHS, SIZE_PERM_RHS, JBEG_RHS, & UNS_PERM_INV, SIZE_UNS_PERM_INV, & ICNTL21, & MYID, COMM, & INFO, & Pruned_Sons_FWD, Pruned_Sons_BWD, & Lnodes_FWD, Lnodes_BWD & , nodes_FWD, nodes_BWD & , Lnodes_FWD_in, Lnodes_BWD_in & ) USE DMUMPS_SOL_ES, ONLY : DMUMPS_ES_NODES_SIZE_AND_FILL IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: ICNTL(60),N, NSTEPS, KEEP(500) INTEGER, INTENT(IN) :: STEP(N), Step2node(NSTEPS) INTEGER, INTENT(IN) :: Nloc_RHS, & IRHS_loc(max(1,Nloc_RHS)) INTEGER, intent(in) :: NBCOL_INBLOC, IRHS_PTR(NBCOL_INBLOC+1) INTEGER, intent(in) :: NZ_RHS, IRHS_SPARSE(NZ_RHS) INTEGER, intent(in) :: SIZE_PERM_RHS, PERM_RHS(SIZE_PERM_RHS) INTEGER, intent(in) :: JBEG_RHS, SIZE_UNS_PERM_INV INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, intent(IN) :: ICNTL21 INTEGER, intent(in) :: MYID, COMM INTEGER, intent(inout) :: INFO(80) INTEGER, intent(inout) :: Pruned_Sons_FWD(NSTEPS), & Pruned_Sons_BWD(NSTEPS) INTEGER, intent(inout) :: Lnodes_FWD, Lnodes_BWD INTEGER, intent(in) :: Lnodes_FWD_in, Lnodes_BWD_in INTEGER, intent(out) :: nodes_FWD(Lnodes_FWD_in), & nodes_BWD(Lnodes_BWD_in) INCLUDE 'mpif.h' LOGICAL :: DO_PRUN_FWD, AM1, Exploit_Sparsity_FWD, & Exploit_Sparsity_BWD INTEGER :: Lnodes_FWD_loc, Lnodes_BWD_loc, ISTEP, & INODE_PRINC, I, II, JAM1 #if defined(AVOID_MPI_IN_PLACE) INTEGER, DIMENSION(:), ALLOCATABLE :: TMP_INT_ARRAY INTEGER :: allocok #endif #if defined(AVOID_MPI_IN_PLACE) ALLOCATE(TMP_INT_ARRAY(KEEP(28)), STAT = allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM, MYID ) IF(INFO(1).LT.0) GOTO 500 #endif AM1 = (KEEP(237) .NE. 0) Exploit_Sparsity_FWD = (KEEP(235) .NE. 0) .AND. (.NOT. AM1) DO_PRUN_FWD = (Exploit_Sparsity_FWD.OR.AM1) Exploit_Sparsity_BWD = (KEEP(212) .NE. 0) .AND. (.NOT. AM1) IF (.NOT.fill) Lnodes_FWD=-1 IF (.NOT.fill) Lnodes_BWD=-1 IF (.NOT.fill.AND.KEEP(252).NE.0) THEN Lnodes_FWD = 0 ENDIF IF ( KEEP(252).NE.0 ) DO_PRUN_FWD = .FALSE. IF ( DO_PRUN_FWD ) THEN IF ( Exploit_Sparsity_FWD.AND.KEEP(248).EQ.-1 ) THEN IF (.NOT.fill) THEN CALL DMUMPS_ES_NODES_SIZE_AND_FILL ( fill, & N, KEEP(28), KEEP, STEP, Step2node, & IRHS_loc, Nloc_RHS, MYID, COMM, & Pruned_Sons_FWD, Lnodes_FWD #if defined(AVOID_MPI_IN_PLACE) & , TMP_INT_ARRAY #endif & ) ELSE IF (Lnodes_FWD.GT.0) THEN CALL DMUMPS_ES_NODES_SIZE_AND_FILL ( fill, & N, KEEP(28), KEEP, STEP, Step2node, & IRHS_loc, Nloc_RHS, MYID, COMM, & Pruned_Sons_FWD, Lnodes_FWD, #if defined(AVOID_MPI_IN_PLACE) & TMP_INT_ARRAY, #endif & nodes_FWD & ) ENDIF ELSE IF ( Exploit_Sparsity_FWD.AND.KEEP(248).NE.-1 ) THEN IF (.NOT.fill) THEN Lnodes_FWD = 0 Pruned_Sons_FWD(:) = -1 DO I = 1, NZ_RHS ISTEP = abs( STEP(IRHS_SPARSE(I)) ) IF ( Pruned_Sons_FWD(ISTEP) .eq. -1) THEN Lnodes_FWD = Lnodes_FWD +1 Pruned_Sons_FWD(ISTEP) = 0 ENDIF ENDDO ELSE IF (Lnodes_FWD.GT.0) THEN Lnodes_FWD_loc = 0 Pruned_Sons_FWD(:) = -1 DO I = 1, NZ_RHS ISTEP = abs( STEP(IRHS_SPARSE(I)) ) INODE_PRINC = Step2node( ISTEP ) IF ( Pruned_Sons_FWD(ISTEP) .eq. -1) THEN Lnodes_FWD_loc = Lnodes_FWD_loc +1 nodes_FWD(Lnodes_FWD_loc) = INODE_PRINC Pruned_Sons_FWD(ISTEP) = 0 ENDIF ENDDO ENDIF ELSE IF ( AM1 ) THEN IF (.NOT.fill) THEN Lnodes_FWD = 0 Pruned_Sons_FWD(:) = -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_FWD(ISTEP) .eq. -1) THEN Lnodes_FWD = Lnodes_FWD +1 Pruned_Sons_FWD(ISTEP) = 0 ENDIF ENDDO ELSE IF (Lnodes_FWD.GT.0) THEN Lnodes_FWD_loc = 0 Pruned_Sons_FWD = -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_FWD(ISTEP) .eq. -1) THEN Lnodes_FWD_loc = Lnodes_FWD_loc +1 nodes_FWD(Lnodes_FWD_loc) = INODE_PRINC Pruned_Sons_FWD(ISTEP) = 0 ENDIF ENDDO ENDIF ENDIF ENDIF IF (AM1) THEN IF (.NOT.fill) THEN Lnodes_BWD = 0 Pruned_Sons_BWD(:) = -1 DO II = 1, NZ_RHS I = IRHS_SPARSE(II) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) ISTEP = abs(STEP(I)) IF ( Pruned_Sons_BWD(ISTEP) .eq. -1) THEN Lnodes_BWD = Lnodes_BWD +1 Pruned_Sons_BWD(ISTEP) = 0 ENDIF ENDDO ELSE IF (Lnodes_BWD.GT.0) THEN Lnodes_BWD_loc = 0 Pruned_Sons_BWD(:) = -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_BWD(ISTEP) .eq. -1) THEN Lnodes_BWD_loc = Lnodes_BWD_loc +1 nodes_BWD(Lnodes_BWD_loc) = INODE_PRINC Pruned_Sons_BWD(ISTEP) = 0 ENDIF ENDDO ENDIF ENDIF #if defined(AVOID_MPI_IN_PLACE) GOTO 600 500 CONTINUE Lnodes_FWD = -1 Lnodes_BWD = -1 600 CONTINUE #endif #if defined(AVOID_MPI_IN_PLACE) IF ( allocated(TMP_INT_ARRAY)) DEALLOCATE(TMP_INT_ARRAY) #endif RETURN END SUBROUTINE DMUMPS_NODES_FWD_BWD_SIZE_FILL SUBROUTINE DMUMPS_BUILD_GLOB2LOC_NODES_ES ( & NSLAVES, N, MYID_NODES, & PTRIST, DAD, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & Lnodes_FWD, Lnodes_BWD, & nodes_FWD, nodes_BWD, & GLOB2LOC_RHS, GLOB2LOC_SOL, & GLOB2LOC_SOL_ALLOC, & MTYPE, & NBENT_RHSINTR, & NB_FS_IN_RHSINTR_FWD, NB_FS_IN_RHSINTR_TOT & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER, intent(in) :: Lnodes_FWD, Lnodes_BWD INTEGER, intent(in) :: nodes_FWD(max(1,Lnodes_FWD)), & nodes_BWD(max(1,Lnodes_BWD)) INTEGER, intent(inout) :: DAD(KEEP(28)) INTEGER, intent(in) :: IW(LIW), STEP(N) INTEGER, intent(in) :: MTYPE LOGICAL, intent(in) :: GLOB2LOC_SOL_ALLOC INTEGER, intent(out):: GLOB2LOC_RHS(N), GLOB2LOC_SOL(N) INTEGER, intent(out):: NBENT_RHSINTR INTEGER, intent(out):: NB_FS_IN_RHSINTR_FWD, NB_FS_IN_RHSINTR_TOT INTEGER I INTEGER ISTEP, OLDISTEP INTEGER NPIV INTEGER IPOS, LIELL INTEGER JJ, J1, JCOL, ABSJCOL INTEGER IPOSINRHSINTR_RHS, IPOSINRHSINTR_SOL INTEGER NBENT_RHSINTR_ROW, NBENT_RHSINTR_COL LOGICAL GO_UP INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE GLOB2LOC_RHS = 0 IF (GLOB2LOC_SOL_ALLOC) GLOB2LOC_SOL = 0 IPOSINRHSINTR_RHS = 0 IPOSINRHSINTR_SOL = 0 DO I = 1, Lnodes_FWD ISTEP = STEP(nodes_FWD(I)) GO_UP = .TRUE. DO WHILE(GO_UP) IF (DAD(ISTEP) .GE. 0) THEN OLDISTEP=ISTEP IF (DAD(ISTEP).EQ.0) THEN GO_UP=.FALSE. ELSE GO_UP=.TRUE. ISTEP = STEP(DAD(ISTEP)) ENDIF DAD(OLDISTEP)=-DAD(OLDISTEP)-1 ELSE GO_UP = .FALSE. ENDIF END DO END DO DO ISTEP=1, KEEP(28) IF (DAD(ISTEP) .LT. 0) THEN DAD(ISTEP) = -DAD(ISTEP) - 1 IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF(NPIV.GT.0) THEN DO JJ = J1, J1+NPIV-1 GLOB2LOC_RHS(IW(JJ)) & = IPOSINRHSINTR_RHS + JJ - J1 + 1 ENDDO IPOSINRHSINTR_RHS = IPOSINRHSINTR_RHS + NPIV IF (GLOB2LOC_SOL_ALLOC) THEN DO JJ = JCOL, JCOL+NPIV-1 GLOB2LOC_SOL(IW(JJ)) & = - ( IPOSINRHSINTR_SOL + JJ - JCOL + 1 ) ENDDO IPOSINRHSINTR_SOL = IPOSINRHSINTR_SOL + NPIV ENDIF END IF END IF ENDIF END DO NB_FS_IN_RHSINTR_FWD = IPOSINRHSINTR_RHS IF(GLOB2LOC_SOL_ALLOC) THEN DO I=1, Lnodes_BWD ISTEP = STEP(nodes_BWD(I)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF ABSJCOL = abs(IW(JCOL)) IF(NPIV.GT.0) THEN IF(GLOB2LOC_SOL(ABSJCOL).EQ.0) THEN DO JJ = JCOL, JCOL+NPIV-1 GLOB2LOC_SOL(abs(IW(JJ))) = & IPOSINRHSINTR_SOL+JJ-JCOL+1 END DO IPOSINRHSINTR_SOL = IPOSINRHSINTR_SOL + NPIV ELSE IF (GLOB2LOC_SOL(ABSJCOL).LT.0) THEN DO JJ = JCOL, JCOL+NPIV-1 GLOB2LOC_SOL(abs(IW(JJ)))= & -(GLOB2LOC_SOL(abs(IW(JJ)))) END DO ELSE GO_UP = .FALSE. END IF END IF END IF IF(DAD(ISTEP).NE.0) THEN ISTEP = STEP(DAD(ISTEP)) ELSE GO_UP = .FALSE. END IF END DO END DO END IF NB_FS_IN_RHSINTR_TOT = IPOSINRHSINTR_SOL IF (NSLAVES.NE.1) THEN DO I = 1, Lnodes_FWD ISTEP = STEP(nodes_FWD(I)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = NPIV, LIELL-1-KEEP(253) IF(GLOB2LOC_RHS(IW(J1+JJ)).EQ.0) THEN IPOSINRHSINTR_RHS = IPOSINRHSINTR_RHS + 1 GLOB2LOC_RHS(IW(JJ+J1)) = -IPOSINRHSINTR_RHS END IF END DO END IF IF(DAD(ISTEP).GT.0) THEN OLDISTEP=ISTEP ISTEP = STEP(DAD(ISTEP)) DAD(OLDISTEP)=-DAD(OLDISTEP) ELSE GO_UP = .FALSE. END IF END DO END DO DAD=ABS(DAD) IF(GLOB2LOC_SOL_ALLOC) THEN DO I=1, Lnodes_BWD ISTEP = STEP(nodes_BWD(I)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = NPIV, LIELL-1-KEEP(253) IF(GLOB2LOC_SOL(IW(JCOL+JJ)).EQ.0) THEN IPOSINRHSINTR_SOL = IPOSINRHSINTR_SOL + 1 GLOB2LOC_SOL(IW(JCOL+JJ)) = -IPOSINRHSINTR_SOL END IF END DO END IF IF(DAD(ISTEP).GT.0) THEN OLDISTEP=ISTEP ISTEP = STEP(DAD(ISTEP)) DAD(OLDISTEP)=-DAD(OLDISTEP) ELSE GO_UP = .FALSE. END IF END DO END DO DAD=ABS(DAD) END IF ENDIF NBENT_RHSINTR_ROW = IPOSINRHSINTR_RHS NBENT_RHSINTR_COL = IPOSINRHSINTR_SOL NBENT_RHSINTR = max(NBENT_RHSINTR_ROW,NBENT_RHSINTR_COL) RETURN END SUBROUTINE DMUMPS_BUILD_GLOB2LOC_NODES_ES MUMPS_5.8.1/src/dfac_scalings_simScale_util.F0000664000175000017500000013345315042446441021006 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, OSZ, & IWRK, IWSZ, INUMMY, NOMP_MAX ) !$ USE OMP_LIB C IMPLICIT NONE EXTERNAL DMUMPS_BUREDUCE INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM, NOMP_MAX INTEGER(8), INTENT(IN) :: NZ_loc INTEGER(8), INTENT(IN) :: IWSZ INTEGER, INTENT(IN) :: ISZ, OSZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C OUTPUT C IPARTVEC(I) = proc number with largest number of entries C in row/col I C INUMMY = number of local rows/columns with C at least one local entry (NUMPROCS .NE. 1 only) INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) INTEGER, INTENT(OUT) :: INUMMY C C INTERNAL WORKING ARRAY C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries C on my proc and in row/col I) for I=1,ISZ C (2*ISZ+1: 4*ISZ) is then set to C the processor with largest number of entries in its row/col C and its value (that is copied back into IPARTVEC(I) #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) #else INTEGER, INTENT(OUT) :: IWRK(IWSZ) #endif INCLUDE 'mpif.h' C C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER OP, IERROR INTEGER IR, IC !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK C !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = omp_get_max_threads() !$ CHUNK= max(K361/2, (ISZ+NOMP-1) / NOMP ) !$ ENDIF C INUMMY = 0 IF(NUMPROCS.NE.1) THEN C CHECK done outsize C IF(IWSZ < 4*ISZ) THEN C CHECK ENDS CALL MPI_OP_CREATE(DMUMPS_BUREDUCE, .TRUE., OP, IERROR) C PERFORM THE REDUCTION C WE FIRST ZERO OUT IF (NOMP_MAX.LE.0) THEN DO I=1,ISZ IWRK(2_8*int(I,8)-1_8) = 0 IWRK(2_8*int(I,8)) = MYID ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND.ISZ > K361 ) DO I=1,ISZ IWRK(2_8*int(I,8)-1_8) = 0 IWRK(2_8*int(I,8)) = MYID ENDDO !$OMP END PARALLEL DO ENDIF DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.ISZ).AND. & (IC.GE.1).AND.(IC.LE.OSZ)) THEN IWRK(2_8*int(IR,8)-1_8) = IWRK(2_8*int(IR,8)-1_8) + 1 ENDIF ENDDO CALL MUMPS_BIGALLREDUCE(.FALSE., IWRK(1), & IWRK(1_8+2_8*int(ISZ,8)), ISZ, & MPI_2INTEGER, OP, COMM, IERROR) C IF (NOMP_MAX.LE.0) THEN DO I=1,ISZ IPARTVEC(I) = IWRK(2_8*int(I,8)+2_8*int(ISZ,8)) C Compute INUMMY directly IF ( IPARTVEC(I) .EQ. MYID. OR. & IWRK(2_8*int(I,8)-1_8) .GT. 0 ) THEN INUMMY=INUMMY+1 ENDIF ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) !$OMP& REDUCTION(+:INUMMY) DO I=1,ISZ IPARTVEC(I) = IWRK(2_8*int(I,8)+2_8*int(ISZ,8)) C Compute INUMMY directly IF ( IPARTVEC(I) .EQ. MYID. OR. & IWRK(2_8*int(I,8)-1_8) .GT. 0 ) THEN INUMMY=INUMMY+1 ENDIF ENDDO !$OMP END PARALLEL DO ENDIF C FREE THE OPERATOR CALL MPI_OP_FREE(OP, IERROR) ELSE IF (NOMP_MAX.LE.0) THEN DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) DO I=1,ISZ IPARTVEC(I) = 0 ENDDO !$OMP END PARALLEL DO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_CREATEPARTVEC C C SEPARATOR: Another function begins C C SUBROUTINE DMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & MYROWINDICES, INUMMYR, & MYCOLINDICES, INUMMYC, & IWRK, IWSZ, NOMP_MAX ) !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: NZ_loc, IWSZ INTEGER MYID, NUMPROCS, M, N, NOMP_MAX INTEGER INUMMYR, INUMMYC INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER ROWPARTVEC(M) INTEGER COLPARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER MYCOLINDICES(INUMMYC) INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC, ITMP INTEGER(8) :: I8 C INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP=omp_get_max_threads() C note that M=N !$ CHUNK= max(K361/2, (M+NOMP-1) / NOMP ) !$ ENDIF C C MARK MY ROWS. IF (NOMP_MAX.LE.0) THEN DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( M > K361 .AND. NOMP .GT. 1) DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO !$OMP END PARALLEL DO ENDIF CTEMP !$OMP PARALLEL DO PRIVATE(I8,IR,IC) SCHEDULE(STATIC,CHUNK) CTEMP !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) DO I8=1,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 ENDIF ENDDO CTEMP !$OMP END PARALLEL DO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,M IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C C C DO THE SMAME THING FOR COLS IF (NOMP_MAX.LE.0) THEN DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 ENDDO !$OMP END PARALLEL DO ENDIF C CTEMP !$OMP PARALLEL DO PRIVATE(I8,IR,IC) SCHEDULE(STATIC,CHUNK) CTEMP !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) DO I8=1,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IC) .EQ. 0) IWRK(IC)= 1 ENDIF ENDDO CTEMP !$OMP END PARALLEL DO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYCOLINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C RETURN END SUBROUTINE DMUMPS_FILLMYROWCOLINDICES C C SEPARATOR: Another function begins C C INTEGER FUNCTION DMUMPS_CHK1LOC(D, DSZ, INDX, INDXSZ, EPS) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) INTEGER INDX(INDXSZ) DOUBLE PRECISION EPS C LOCAL VARS INTEGER I, IID DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) DMUMPS_CHK1LOC = 1 DO I=1, INDXSZ IID = INDX(I) IF (.NOT.( (D(IID).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(IID)) )) THEN DMUMPS_CHK1LOC = 0 ENDIF ENDDO RETURN END FUNCTION DMUMPS_CHK1LOC INTEGER FUNCTION DMUMPS_CHK1CONV(D, DSZ, EPS) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION EPS C LOCAL VARS INTEGER I DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) DMUMPS_CHK1CONV = 1 DO I=1, DSZ IF (.NOT.( (D(I).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(I)) )) THEN DMUMPS_CHK1CONV = 0 ENDIF ENDDO RETURN END FUNCTION DMUMPS_CHK1CONV C C SEPARATOR: Another function begins C INTEGER FUNCTION DMUMPS_CHKCONVGLO(DR, M, INDXR, INDXRSZ, & DC, N, INDXC, INDXCSZ, EPS, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER M, N, INDXRSZ, INDXCSZ DOUBLE PRECISION DR(M), DC(N) INTEGER INDXR(INDXRSZ), INDXC(INDXCSZ) DOUBLE PRECISION EPS INTEGER COMM EXTERNAL DMUMPS_CHK1LOC INTEGER DMUMPS_CHK1LOC INTEGER GLORES, MYRESR, MYRESC, MYRES INTEGER IERR MYRESR = DMUMPS_CHK1LOC(DR, M, INDXR, INDXRSZ, EPS) MYRESC = DMUMPS_CHK1LOC(DC, N, INDXC, INDXCSZ, EPS) MYRES = MYRESR + MYRESC CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) DMUMPS_CHKCONVGLO = GLORES RETURN END FUNCTION DMUMPS_CHKCONVGLO C C SEPARATOR: Another function begins C DOUBLE PRECISION FUNCTION DMUMPS_ERRSCALOC(D, TMPD, DSZ, & INDX, INDXSZ, NOMP_MAX) !$ USE OMP_LIB C THE VAR D IS NOT USED IN COMPUTATIONS. C IT IS THERE FOR READIBLITY OF THE *simScaleAbs.F IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, INDXSZ, NOMP_MAX DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTEGER INDX(INDXSZ) C LOCAL VARS DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) INTEGER I, IIND DOUBLE PRECISION ERRMAX INTRINSIC abs !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK ERRMAX = -RONE !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,INDXSZ IIND = INDX(I) IF(abs(RONE-TMPD(IIND)).GT.ERRMAX) THEN ERRMAX = abs(RONE-TMPD(IIND)) ENDIF ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I,IIND) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1 .AND. INDXSZ > K361 ) !$OMP& REDUCTION(max:ERRMAX) DO I=1,INDXSZ IIND = INDX(I) IF(abs(RONE-TMPD(IIND)).GT.ERRMAX) THEN ERRMAX = abs(RONE-TMPD(IIND)) ENDIF ENDDO !$OMP END PARALLEL DO ENDIF DMUMPS_ERRSCALOC = ERRMAX RETURN END FUNCTION DMUMPS_ERRSCALOC DOUBLE PRECISION FUNCTION DMUMPS_ERRSCA1(D, TMPD, DSZ, NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, NOMP_MAX DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) C LOCAL VARS DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) INTEGER I DOUBLE PRECISION ERRMAX1 INTRINSIC abs !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK ERRMAX1 = -RONE !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (DSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,DSZ IF(abs(RONE-TMPD(I)).GT.ERRMAX1) THEN ERRMAX1 = abs(RONE-TMPD(I)) ENDIF ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND.DSZ > K361 ) !$OMP& REDUCTION(max:ERRMAX1) DO I=1,DSZ IF(abs(RONE-TMPD(I)).GT.ERRMAX1) THEN ERRMAX1 = abs(RONE-TMPD(I)) ENDIF ENDDO !$OMP END PARALLEL DO ENDIF DMUMPS_ERRSCA1 = ERRMAX1 RETURN END FUNCTION DMUMPS_ERRSCA1 C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_UPDATESCALE(D, TMPD, DSZ, & INDX, INDXSZ, NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(in) :: DSZ, INDXSZ, NOMP_MAX DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTEGER INDX(INDXSZ) INTRINSIC sqrt C LOCAL VARS INTEGER I, IIND DOUBLE PRECISION RZERO PARAMETER(RZERO=0.0D0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,INDXSZ IIND = INDX(I) IF (TMPD(IIND).NE.RZERO) D(IIND)=D(IIND)/sqrt(TMPD(IIND)) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I,IIND) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. INDXSZ> K361 ) DO I=1,INDXSZ IIND = INDX(I) IF (TMPD(IIND).NE.RZERO) D(IIND)=D(IIND)/sqrt(TMPD(IIND)) ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE DMUMPS_UPDATESCALE C SUBROUTINE DMUMPS_UPSCALE1(D, TMPD, DSZ, NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, NOMP_MAX DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTRINSIC sqrt C LOCAL VARS INTEGER I DOUBLE PRECISION RZERO PARAMETER(RZERO=0.0D0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (DSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,DSZ IF (TMPD(I) .NE. RZERO) D(I) = D(I)/sqrt(TMPD(I)) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. DSZ> K361 ) DO I=1,DSZ IF (TMPD(I) .NE. RZERO) D(I) = D(I)/sqrt(TMPD(I)) ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE DMUMPS_UPSCALE1 C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_INITREALLST(D, DSZ, INDX, INDXSZ, VAL, & NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, INDXSZ, NOMP_MAX DOUBLE PRECISION D(DSZ) INTEGER INDX(INDXSZ) DOUBLE PRECISION VAL C LOCAL VARS INTEGER I, IIND !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,INDXSZ IIND = INDX(I) D(IIND) = VAL ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I,IIND) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. INDXSZ > K361 ) DO I=1,INDXSZ IIND = INDX(I) D(IIND) = VAL ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE DMUMPS_INITREALLST C C SEPARATOR: Another function begins C C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_INITREAL(D, DSZ, VAL, NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, NOMP_MAX DOUBLE PRECISION D(DSZ) DOUBLE PRECISION VAL C LOCAL VARS INTEGER I !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = omp_get_max_threads() !$ CHUNK= max(K361/2, (DSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,DSZ D(I) = VAL ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND.DSZ > K361 ) DO I=1,DSZ D(I) = VAL ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE DMUMPS_INITREAL C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_REDUCE_WRK(WRK, N, WRK_TH, NOMP_MAX) C Called only when NOMP_MAX>0 !$ USE OMP_LIB IMPLICIT NONE INTEGER N,NOMP_MAX DOUBLE PRECISION WRK(N), WRK_TH(N,NOMP_MAX) C LOCAL VAR INTEGER I, IOMP DOUBLE PRECISION DZERO PARAMETER(DZERO=0.0D0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (N+NOMP-1) / NOMP ) !$OMP PARALLEL DO PRIVATE(I,IOMP) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. N > K361 ) DO I=1,N WRK(I) = DZERO DO IOMP=1,NOMP_MAX WRK(I) = WRK_TH(I,IOMP) + WRK(I) ENDDO ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE DMUMPS_REDUCE_WRK SUBROUTINE DMUMPS_REDUCE_WRK_MPI(WRK, N, WRK_TH, NOMP_MAX, & INDX, INDXSZ) C Called only when NOMP_MAX>0 !$ USE OMP_LIB IMPLICIT NONE INTEGER N,NOMP_MAX,INDXSZ DOUBLE PRECISION WRK(N), WRK_TH(N,NOMP_MAX) INTEGER INDX(INDXSZ) C LOCAL VAR INTEGER I, J, IOMP DOUBLE PRECISION DZERO PARAMETER(DZERO=0.0D0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$OMP PARALLEL DO PRIVATE(I,J,IOMP) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. INDXSZ > K361 ) DO I=1,INDXSZ J = INDX(I) WRK(J) = DZERO DO IOMP=1,NOMP_MAX WRK(J) = WRK_TH(J,IOMP) + WRK(J) ENDDO ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE DMUMPS_REDUCE_WRK_MPI SUBROUTINE DMUMPS_ZEROOUT(TMPD, TMPSZ, INDX, INDXSZ, & NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: TMPSZ,INDXSZ, NOMP_MAX DOUBLE PRECISION TMPD(TMPSZ) INTEGER INDX(INDXSZ) C LOCAL VAR INTEGER I DOUBLE PRECISION DZERO PARAMETER(DZERO=0.0D0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,INDXSZ TMPD(INDX(I)) = DZERO ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. INDXSZ > K361 ) DO I=1,INDXSZ TMPD(INDX(I)) = DZERO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE DMUMPS_ZEROOUT C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_BUREDUCE(INV, INOUTV, LEN, DTYPE) C C Like MPI_MINLOC operation (with ties broken sometimes with min C and sometimes with max) C The objective is find for each entry row/col C the processor with largest number of entries in its row/col C When 2 procs have the same number of entries in the row/col C then C if this number of entries is odd we take the proc with largest id C if this number of entries is even we take the proc with smallest id C IMPLICIT NONE #if defined(WORKAROUNDINTELILP64MPI2INTEGER) || defined(WORKAROUNDILP64MPICUSTOMREDUCE) INTEGER(4) :: LEN INTEGER(4) :: INV(2*LEN) INTEGER(4) :: INOUTV(2*LEN) INTEGER(4) :: DTYPE #else INTEGER :: LEN INTEGER :: INV(2*LEN) INTEGER :: INOUTV(2*LEN) INTEGER :: DTYPE #endif INTEGER I #if defined(WORKAROUNDINTELILP64MPI2INTEGER) || defined(WORKAROUNDILP64MPICUSTOMREDUCE) INTEGER(4) DIN, DINOUT, PIN, PINOUT #else INTEGER DIN, DINOUT, PIN, PINOUT #endif DO I=1,2*LEN-1,2 DIN = INV(I) ! nb of entries in row/col PIN = INV(I+1) ! proc number C DINOUT DINOUT = INOUTV(I) PINOUT = INOUTV(I+1) IF (DINOUT < DIN) THEN INOUTV(I) = DIN INOUTV(I+1) = PIN ELSE IF (DINOUT == DIN) THEN C --INOUTV(I) = DIN C --even number I take smallest Process number (pin) IF ((mod(DINOUT,2).EQ.0).AND.(PINPINOUT)) THEN C --odd number I take largest Process number (pin) INOUTV(I+1) = PIN ENDIF ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_BUREDUCE C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_IBUINIT(IW, IWSZ, IVAL) IMPLICIT NONE INTEGER(8) :: IWSZ #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) IW(IWSZ) INTEGER(4) IVAL #else INTEGER IW(IWSZ) INTEGER IVAL #endif INTEGER(8) :: I DO I=1_8,IWSZ IW(I)=IVAL ENDDO RETURN END SUBROUTINE DMUMPS_IBUINIT C C SEPARATOR: Another function begins C C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX,ISNDRCVNUM,ISNDRCVVOL, & OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER(8), INTENT(IN) :: IWRKSZ INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ, OSZ INTEGER, INTENT(IN) :: COMM C When INDX holds row indices O(ther)INDX holds col indices INTEGER, INTENT(IN) :: INDX(NZ_loc) INTEGER, INTENT(IN) :: OINDX(NZ_loc) C On entry IPARTVEC(I) holds proc number with largest number of entries C in row/col I INTEGER, INTENT(IN) :: IPARTVEC(ISZ) C C OUTPUT PARAMETERS C SNDSZ (IPROC+1) is set to the number of rows (or col) that C MYID will have to send to IPROC C RCVSZ(IPROC+1) is set to the nb of row/cols that C MYID will receive from IPROC INTEGER, INTENT(OUT) :: SNDSZ(NUMPROCS) INTEGER, INTENT(OUT) :: RCVSZ(NUMPROCS) C OSNDRCVNUM is set to the total number of procs C destination of messages from MYID (< NUMPROCS) C ISNDRCVNUM is set to the total number procs C that will send messages to MYID (< NUMPROCS) C ISNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C OSNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C Knowing that for each row the process with the largest C number of entries will centralize all indices then C ISNDRCVVOL and OSNDRCVVOL are bounded by N INTEGER, INTENT(OUT) :: ISNDRCVNUM, OSNDRCVNUM INTEGER, INTENT(OUT) :: ISNDRCVVOL, OSNDRCVVOL C C INTERNAL WORKING ARRAY INTEGER IWRK(IWRKSZ) INCLUDE 'mpif.h' C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER IIND, IIND2, PIND INTEGER IERROR C check done outsize C IF(ISZ>IWRKSZ) THEN ERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,max(ISZ,OSZ) IWRK(I) = 0 ENDDO C C set SNDSZ DO I8=1,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. & (IIND2.GE.1).AND.(IIND2.LE.OSZ))THEN PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN C MYID will send row/col IIND to proc PIND C (PIND has the largest nb of entries in row/col IIND IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO C C use SNDSZ to set RCVSZ CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) C C compute number of procs destinations of messages from MYID C number of row/col sent by MYID. ISNDRCVNUM = 0 ISNDRCVVOL = 0 OSNDRCVNUM = 0 OSNDRCVVOL = 0 DO I=1, NUMPROCS IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) ENDDO RETURN END SUBROUTINE DMUMPS_NUMVOLSNDRCV C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_SETUPCOMMS(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX, & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, & SNDSZ, RCVSZ, IWRK, & ISTATUS, REQUESTS, & ITAGCOMM, COMM ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER ISNDVOL, OSNDVOL INTEGER MYID, NUMPROCS, ISZ, OSZ C ISZ is either M or N INTEGER INDX(NZ_loc) INTEGER OINDX(NZ_loc) C INDX is either IRN_loc or JCN_col INTEGER IPARTVEC(ISZ) C IPARTVEC is either rowpartvec or colpartvec INTEGER :: ISNDRCVNUM INTEGER INGHBPRCS(ISNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1) INTEGER ISNDRCVJA(ISNDVOL) INTEGER OSNDRCVNUM INTEGER ONGHBPRCS(OSNDRCVNUM) INTEGER OSNDRCVIA(NUMPROCS+1) INTEGER OSNDRCVJA(OSNDVOL) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INTEGER IWRK(ISZ) INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) INTEGER REQUESTS(ISNDRCVNUM) INTEGER ITAGCOMM, COMM C LOCAL VARS INTEGER I, IIND, IIND2, IPID, OFFS INTEGER IWHERETO, POFFS, ITMP, IERROR INTEGER(8) :: I8 C COMPUATIONs START DO I=1,ISZ IWRK(I) = 0 ENDDO C INITIALIZE ONGHBPRCS using SNDSZ C INITIALIZE THE OSNDRCVIA using SNDSZ OFFS = 1 POFFS = 1 DO I=1,NUMPROCS OSNDRCVIA(I) = OFFS + SNDSZ(I) IF(SNDSZ(I) > 0) THEN ONGHBPRCS(POFFS)=I POFFS = POFFS + 1 ENDIF OFFS = OFFS + SNDSZ(I) ENDDO OSNDRCVIA(NUMPROCS+1) = OFFS C CHECK STARTS C check done outsize C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) DO I8=1,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. & (IIND2.GE.1).AND.(IIND2.LE.OSZ) ) THEN IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF ENDIF ENDDO C FILLED UP, WHAT I WILL RECEIVE (My requests from others) C FILL UP ISNDRCVJA. It will be received to fill up CALL MPI_BARRIER(COMM,IERROR) OFFS = 1 POFFS = 1 ISNDRCVIA(1) = 1 DO I=2,NUMPROCS+1 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) IF(RCVSZ(I-1) > 0) THEN INGHBPRCS(POFFS)=I-1 POFFS = POFFS + 1 ENDIF OFFS = OFFS + RCVSZ(I-1) ENDDO CALL MPI_BARRIER(COMM,IERROR) DO I=1, ISNDRCVNUM IPID = INGHBPRCS(I) OFFS = ISNDRCVIA(IPID) ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, & ITAGCOMM, COMM, REQUESTS(I),IERROR) ENDDO DO I=1,OSNDRCVNUM IPID = ONGHBPRCS(I) OFFS = OSNDRCVIA(IPID) ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, & ITAGCOMM, COMM,IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF CALL MPI_BARRIER(COMM,IERROR) RETURN END SUBROUTINE DMUMPS_SETUPCOMMS C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_DOCOMMINF(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, & ISNDRCVNUM, INGHBPRCS, & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, & OSNDRCVNUM, ONGHBPRCS, & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, & ISTATUS, REQUESTS, & COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL DOUBLE PRECISION TMPD(IDSZ) INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) DOUBLE PRECISION ISNDRCVA(ISNDRCVVOL) INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) DOUBLE PRECISION OSNDRCVA(OSNDRCVVOL) INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER COMM, IERROR C LOCAL VARS INTEGER I, PID, OFFS, SZ, J, JS, JE, IID DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, & MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS, JE IID = OSNDRCVJA(J) OSNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM, COMM, IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF C FOLD INTO MY D DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1)-1 DO J=JS,JE IID = ISNDRCVJA(J) IF(TMPD(IID) < ISNDRCVA(J)) TMPD(IID)= ISNDRCVA(J) ENDDO ENDDO C COMMUNICATE THE UPDATED ONES DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, & MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1) -1 DO J=JS, JE IID = ISNDRCVJA(J) ISNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM+1, COMM, IERROR) ENDDO IF(OSNDRCVNUM > 0) THEN CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS,JE IID = OSNDRCVJA(J) TMPD(IID)=OSNDRCVA(J) ENDDO ENDDO RETURN END SUBROUTINE DMUMPS_DOCOMMINF C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_DOCOMM1N(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, & ISNDRCVNUM, INGHBPRCS, & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, & OSNDRCVNUM, ONGHBPRCS, & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, & ISTATUS, REQUESTS, & COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL DOUBLE PRECISION TMPD(IDSZ) INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) DOUBLE PRECISION ISNDRCVA(ISNDRCVVOL) INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) DOUBLE PRECISION OSNDRCVA(OSNDRCVVOL) INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER COMM, IERROR C LOCAL VARS INTEGER I, PID, OFFS, SZ, J, JS, JE, IID DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, & MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS, JE IID = OSNDRCVJA(J) OSNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM, COMM, IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF C FOLD INTO MY D DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1)-1 DO J=JS,JE IID = ISNDRCVJA(J) TMPD(IID) = TMPD(IID)+ ISNDRCVA(J) ENDDO ENDDO C COMMUNICATE THE UPDATED ONES DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, & MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1) -1 DO J=JS, JE IID = ISNDRCVJA(J) ISNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM+1, COMM, IERROR) ENDDO IF(OSNDRCVNUM > 0) THEN CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS,JE IID = OSNDRCVJA(J) TMPD(IID)=OSNDRCVA(J) ENDDO ENDDO RETURN END SUBROUTINE DMUMPS_DOCOMM1N SUBROUTINE DMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, & IWRK, IWSZ, INUMMY) !$ USE OMP_LIB IMPLICIT NONE EXTERNAL DMUMPS_BUREDUCE INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM INTEGER(8) :: NZ_loc, IWSZ INTEGER, INTENT(IN) :: ISZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C C OUTPUT C IPARTVEC(I) = proc number with largest number of entries C in row/col I C INUMMY = number of local rows/columns with C at least one local entry (NUMPROCS .NE. 1 only) INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) INTEGER, INTENT(OUT) :: INUMMY C C INTERNAL WORKING ARRAY C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries C on my proc and in row/col I) for I=1,ISZ C (2*ISZ+1: 4*ISZ) is then set to C the processor with largest number of entries in its row/col C and its value (that is copied back into IPARTVEC(I) #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) #else INTEGER, INTENT(OUT) :: IWRK(IWSZ) #endif INCLUDE 'mpif.h' C C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER OP, IERROR INTEGER IR, IC INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK C INUMMY = 0 !$ NOMP=omp_get_max_threads() !$ CHUNK= max(K361/2, (ISZ+NOMP-1) / NOMP ) IF(NUMPROCS.NE.1) THEN C CHECK done outsize C IF(IWSZ < 2*ISZ) THEN C CHECK ENDS CALL MPI_OP_CREATE(DMUMPS_BUREDUCE, .TRUE., OP, IERROR) C PERFORM THE REDUCTION !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) DO I=1,ISZ IWRK(2_8*int(I,8)-1_8) = 0 IWRK(2_8*int(I,8)) = MYID ENDDO !$OMP END PARALLEL DO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.ISZ).AND. & (IC.GE.1).AND.(IC.LE.ISZ)) THEN IWRK(2_8*int(IR,8)-1_8) = IWRK(2_8*int(IR,8)-1_8) + 1 IWRK(2_8*int(IC,8)-1_8) = IWRK(2_8*int(IC,8)-1_8) + 1 ENDIF ENDDO CALL MUMPS_BIGALLREDUCE(.FALSE., & IWRK(1), IWRK(1_8+2_8*int(ISZ,8)), ISZ, & MPI_2INTEGER, OP, COMM, IERROR) C CHUNK computed in previous // do !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) !$OMP& REDUCTION(+:INUMMY) DO I=1,ISZ IPARTVEC(I) = IWRK(2_8*int(I,8)+2_8*int(ISZ,8)) C Compute INUMMY directly IF ( IPARTVEC(I) .EQ. MYID. OR. & IWRK(2_8*int(I,8)-1_8) .GT. 0 ) THEN INUMMY=INUMMY+1 ENDIF ENDDO !$OMP END PARALLEL DO C FREE THE OPERATOR CALL MPI_OP_FREE(OP, IERROR) ELSE !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_CREATEPARTVECSYM SUBROUTINE DMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX,OINDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER(8), INTENT(IN) :: IWRKSZ INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ INTEGER, INTENT(IN) :: INDX(NZ_loc), OINDX(NZ_loc) INTEGER, INTENT(IN) :: IPARTVEC(ISZ) INTEGER, INTENT(IN) :: COMM C C OUTPUT PARAMETERS C SNDSZ (IPROC+1) is set to the number of rows (or col) that C MYID will have to send to IPROC C RCVSZ(IPROC+1) is set to the nb of row/cols that C MYID will receive from IPROC INTEGER :: SNDSZ(NUMPROCS) INTEGER :: RCVSZ(NUMPROCS) C OSNDRCVNUM is set to the total number of procs C destination of messages from MYID (< NUMPROCS) C ISNDRCVNUM is set to the total number procs C that will send messages to MYID (< NUMPROCS) C ISNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C OSNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C Knowing that for each row the process with the largest C number of entries will centralize all indices then C ISNDRCVVOL and OSNDRCVVOL are bounded by N INTEGER, INTENT(OUT) :: ISNDRCVNUM, ISNDRCVVOL INTEGER, INTENT(OUT) :: OSNDRCVNUM, OSNDRCVVOL C C INTERNAL WORKING ARRAY INTEGER, INTENT(OUT) :: IWRK(IWRKSZ) INCLUDE 'mpif.h' C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER IIND, IIND2, PIND INTEGER IERROR C check done outsize C IF(ISZ>IWRKSZ) THEN ERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,ISZ IWRK(I) = 0 ENDDO C C set SNDSZ DO I8=1_8,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) & .AND.(IIND2.LE.ISZ)) THEN PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN C MYID will send row/col IIND to proc PIND C (PIND has the largest nb of entries in row/col IIND IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF IIND = OINDX(I8) PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO C C use SNDSZ to set RCVSZ CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) C C compute number of procs destinations of messages from MYID C number of row/col sent by MYID. ISNDRCVNUM = 0 ISNDRCVVOL = 0 OSNDRCVNUM = 0 OSNDRCVVOL = 0 DO I=1, NUMPROCS IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) ENDDO RETURN END SUBROUTINE DMUMPS_NUMVOLSNDRCVSYM INTEGER FUNCTION DMUMPS_CHKCONVGLOSYM(D, N, INDXR, INDXRSZ, & EPS, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER N, INDXRSZ DOUBLE PRECISION D(N) INTEGER INDXR(INDXRSZ) DOUBLE PRECISION EPS INTEGER COMM EXTERNAL DMUMPS_CHK1LOC INTEGER DMUMPS_CHK1LOC INTEGER GLORES, MYRESR, MYRES INTEGER IERR MYRESR = DMUMPS_CHK1LOC(D, N, INDXR, INDXRSZ, EPS) MYRES = 2*MYRESR CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) DMUMPS_CHKCONVGLOSYM = GLORES RETURN END FUNCTION DMUMPS_CHKCONVGLOSYM SUBROUTINE DMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & MYROWINDICES, INUMMYR, & IWRK, IWSZ, NOMP_MAX ) !$ USE OMP_LIB IMPLICIT NONE INTEGER MYID, NUMPROCS, N, NOMP_MAX INTEGER(8) :: NZ_loc, IWSZ INTEGER INUMMYR INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC, ITMP INTEGER(8) :: I8 INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP=omp_get_max_threads() !$ CHUNK= max(K361/2, (N+NOMP-1) / NOMP ) !$ ENDIF C C MARK MY ROWS. IF (NOMP_MAX.LE.0) THEN DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO !$OMP END PARALLEL DO ENDIF C DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 IF(IWRK(IC) .EQ.0) IWRK(IC)=1 ENDIF ENDDO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C C C THE SMAME THING APPLY TO COLS C RETURN END SUBROUTINE DMUMPS_FILLMYROWCOLINDICESSYM SUBROUTINE DMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OINDX, & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, & SNDSZ, RCVSZ, IWRK, & ISTATUS, REQUESTS, & ITAGCOMM, COMM ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, ISZ, ISNDVOL, OSNDVOL INTEGER(8) :: NZ_loc C ISZ is either M or N INTEGER INDX(NZ_loc), OINDX(NZ_loc) C INDX is either IRN_loc or JCN_col INTEGER IPARTVEC(ISZ) C IPARTVEC is either rowpartvec or colpartvec INTEGER ISNDRCVNUM, INGHBPRCS(ISNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1) INTEGER ISNDRCVJA(ISNDVOL) INTEGER OSNDRCVNUM, ONGHBPRCS(OSNDRCVNUM) INTEGER OSNDRCVIA(NUMPROCS+1) INTEGER OSNDRCVJA(OSNDVOL) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INTEGER IWRK(ISZ) INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) INTEGER REQUESTS(ISNDRCVNUM) INTEGER ITAGCOMM, COMM C LOCAL VARS INTEGER I, IIND,IIND2,IPID,OFFS,IWHERETO,POFFS, ITMP, IERROR INTEGER(8) :: I8 C COMPUATIONs START DO I=1,ISZ IWRK(I) = 0 ENDDO C INITIALIZE ONGHBPRCS using SNDSZ C INITIALIZE THE OSNDRCVIA using SNDSZ OFFS = 1 POFFS = 1 DO I=1,NUMPROCS OSNDRCVIA(I) = OFFS + SNDSZ(I) IF(SNDSZ(I) > 0) THEN ONGHBPRCS(POFFS)=I POFFS = POFFS + 1 ENDIF OFFS = OFFS + SNDSZ(I) ENDDO OSNDRCVIA(NUMPROCS+1) = OFFS C CHECK STARTS C check done outsize C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) DO I8=1_8,NZ_loc IIND=INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) & .AND.(IIND2.LE.ISZ)) THEN IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF IIND = OINDX(I8) IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF ENDIF ENDDO C FILLED UP, WHAT I WILL RECEIVE (My requests from others) C FILL UP ISNDRCVJA. It will be received to fill up CALL MPI_BARRIER(COMM,IERROR) OFFS = 1 POFFS = 1 ISNDRCVIA(1) = 1 DO I=2,NUMPROCS+1 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) IF(RCVSZ(I-1) > 0) THEN INGHBPRCS(POFFS)=I-1 POFFS = POFFS + 1 ENDIF OFFS = OFFS + RCVSZ(I-1) ENDDO CALL MPI_BARRIER(COMM,IERROR) DO I=1, ISNDRCVNUM IPID = INGHBPRCS(I) OFFS = ISNDRCVIA(IPID) ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, & ITAGCOMM, COMM, REQUESTS(I),IERROR) ENDDO DO I=1,OSNDRCVNUM IPID = ONGHBPRCS(I) OFFS = OSNDRCVIA(IPID) ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, & ITAGCOMM, COMM,IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF CALL MPI_BARRIER(COMM,IERROR) RETURN END SUBROUTINE DMUMPS_SETUPCOMMSSYM MUMPS_5.8.1/src/dfac_driver.F0000664000175000017500000056635415042446441015633 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_FAC_DRIVER(id,idintr) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_INI_MYID, MUMPS_BUF_INIT, & MUMPS_BUF_ALLOC_SMALL_BUF, MUMPS_BUF_DEALL_SMALL_BUF, & MUMPS_BUF_DIST_IRECV_SIZE USE MUMPS_LOAD USE DMUMPS_OOC, ONLY : DMUMPS_OOC_INIT_FACTO, & DMUMPS_OOC_END_FACTO USE DMUMPS_STRUC_DEF USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_INTR_STRUC USE DMUMPS_FACSOL_L0OMP_M, ONLY: DMUMPS_FREE_L0_OMP_FACTORS, & DMUMPS_INIT_L0_OMP_FACTORS USE DMUMPS_DYNAMIC_MEMORY_M, ONLY: DMUMPS_DM_ALLOC_S_WK, & DMUMPS_DM_FREE_S_WK USE MUMPS_LR_STATS USE DMUMPS_LR_DATA_M, only: DMUMPS_BLR_INIT_MODULE, & DMUMPS_BLR_END_MODULE & , DMUMPS_BLR_MOD_TO_STRUC USE DMUMPS_FAC_COMPACT_FACTORS_M, ONLY: & DMUMPS_TRY_COMPACT_FACTORS USE MUMPS_PIVNUL_MOD, only: PIVNUL_LIST_STRUCT_T USE MUMPS_FRONT_DATA_MGT_M #if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M #endif #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif !$ USE OMP_LIB C Derived datatype to pass pointers with implicit interfaces USE DMUMPS_FAC_S_IS_POINTERS_M, ONLY : DMUMPS_S_IS_POINTERS_T IMPLICIT NONE C C Purpose C ======= C C Performs scaling, sorting in arrowhead, then C distributes the matrix, and perform C factorization. C C INTERFACE SUBROUTINE DMUMPS_ANORMINF(id, ANORMINF, LSCAL, EFF_SIZE_SCHUR) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET :: id DOUBLE PRECISION, INTENT(OUT) :: ANORMINF LOGICAL, INTENT(IN) :: LSCAL INTEGER, INTENT(IN) :: EFF_SIZE_SCHUR END SUBROUTINE DMUMPS_ANORMINF END INTERFACE C C Parameters C ========== C TYPE (DMUMPS_STRUC), TARGET :: id TYPE (DMUMPS_INTR_STRUC) :: idintr C C MPI C === C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 C C Local variables C =============== C INCLUDE 'mumps_headers.h' INTEGER(8) :: NSEND8, NSEND_TOT8 INTEGER(8) :: NLOCAL8, NLOCAL_TOT8 INTEGER(4) :: I4 INTEGER :: LDPTRAR, NELT_arg, NBRECORDS INTEGER :: ITMP, JTMP INTEGER :: KEEP464COPY, KEEP465COPY INTEGER(8) :: KEEP826_SAVE INTEGER(8) :: K67, K68, K70, K74, K75 INTEGER(8) ITMP8 INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER MP, LP, MPG, allocok LOGICAL PROK, PROKG, LSCAL, LPOK, COMPUTE_ANORMINF C Reception buffer INTEGER :: DMUMPS_LBUFR, DMUMPS_LBUFR_BYTES INTEGER(8) :: DMUMPS_LBUFR_BYTES8 ! for intermediate computation INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFR C Size of send buffers (in bytes) INTEGER :: DMUMPS_LBUF, DMUMPS_LBUF_INT INTEGER(8) :: DMUMPS_LBUF8 ! for intermediate computation C INTEGER PTRIST, PTRWB, MAXELT_SIZE, & ITLOC, IPOOL, LPOOL INTEGER IRANK, ID_ROOT INTEGER KKKK INTEGER(8) :: NZ_locMAX8 INTEGER(8) MEMORY_MD_ARG INTEGER(8) MAXS_BASE8, MAXS_BASE_RELAXED8 DOUBLE PRECISION CNTL4, AVG_FLOPS INTEGER MIN_PERLU, MAXIS_ESTIM INTEGER SUM_INFO22_THIS_NODE, MAX_SUM_INFO22_THIS_NODE C TYPE (DMUMPS_S_IS_POINTERS_T) :: S_IS_POINTERS INTEGER :: MAXIS INTEGER(8) :: MAXS INTEGER :: ICNTL49_LOC, TMP_INFOG_4 C For S argument to arrowhead routines: INTEGER(8) :: MAXS_ARG DOUBLE PRECISION, TARGET :: S_DUMMY_ARG(1) DOUBLE PRECISION, POINTER, DIMENSION(:) :: S_PTR_ARG TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT C Arrowheads INTEGER, ALLOCATABLE, DIMENSION(:) :: INTARR DOUBLE PRECISION, POINTER, DIMENSION(:) :: DBLARR C (pointer to point on used-data in some cases--elt-entry) DOUBLE PRECISION TMPTIME INTEGER NOMP INTEGER NB_THREADS DOUBLE PRECISION TIMEAVG, TIMEMAX, & FLOPAVG, FLOPMAX DOUBLE PRECISION TMPFLOP INTEGER NPIV_CRITICAL_PATH, EFF_SIZE_SCHUR DOUBLE PRECISION TIME, TIMEET DOUBLE PRECISION ZERO, ONE, MONE PARAMETER( ZERO = 0.0D0, ONE = 1.0D0, MONE = -1.0D0) DOUBLE PRECISION CZERO PARAMETER( CZERO = 0.0D0 ) INTEGER PERLU, TOTAL_MBYTES, K231, K232, K233, BLR_STRAT INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. INTEGER, PARAMETER :: PANEL_TABSIZE = 20 INTEGER COLOUR, COMM_FOR_SCALING ! For Simultaneous scaling INTEGER(8) :: LIWK, LIWK8 INTEGER(8) :: LWK, LWK_REAL, LWRKR_TH, LWRKC_TH INTEGER :: NOMP_MAX C I_AM_SLAVE: used to determine if proc has the role of a slave C WK_USER_PROVIDED is set to true when WK_USER is provided by user LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED, EARLYT3ROOTINS LOGICAL PRINT_MAXAVG, PRINT_NODEINFO DOUBLE PRECISION :: ANORMINF, SEUIL, SEUIL_LDLT_NIV2, Thresh_Seuil DOUBLE PRECISION :: CNTL1, CNTL3, CNTL5, CNTL6, EPS INTEGER N, LPN_LIST,POSBUF INTEGER, DIMENSION (:), ALLOCATABLE :: ITMP2 INTEGER I,K INTEGER(8) :: ITEMP8 INTEGER :: PARPIV_T1 INTEGER FRONTWISE C temporary variables for collecting stats from all processors INTEGER, PARAMETER :: LR_DKEEPSHIFT=49, LR_TABSIZE=18 DOUBLE PRECISION :: LR_TAB(LR_TABSIZE), LR_EPSILON DOUBLE PRECISION :: TMP_MRY_LU_FR DOUBLE PRECISION :: TMP_MRY_LU_LRGAIN INTEGER :: KEEP399_SAVE, KEEP20_SAVE DOUBLE PRECISION :: TMP_MRY_CB_FR DOUBLE PRECISION :: TMP_MRY_CB_LRGAIN DOUBLE PRECISION :: TMP_FLOP_LRGAIN DOUBLE PRECISION :: TMP_FLOP_TRSM DOUBLE PRECISION :: TMP_FLOP_PANEL DOUBLE PRECISION :: TMP_FLOP_FRFRONTS DOUBLE PRECISION :: TMP_FLOP_TRSM_FR DOUBLE PRECISION :: TMP_FLOP_TRSM_LR DOUBLE PRECISION :: TMP_FLOP_UPDATE_FR DOUBLE PRECISION :: TMP_FLOP_UPDATE_LR DOUBLE PRECISION :: TMP_FLOP_UPDATE_LRLR3 DOUBLE PRECISION :: TMP_FLOP_COMPRESS DOUBLE PRECISION :: TMP_FLOP_DECOMPRESS DOUBLE PRECISION :: TMP_FLOP_MIDBLK_COMPRESS DOUBLE PRECISION :: TMP_FLOP_FRSWAP_COMPRESS DOUBLE PRECISION :: TMP_FLOP_ACCUM_COMPRESS DOUBLE PRECISION :: TMP_FLOP_CB_COMPRESS DOUBLE PRECISION :: TMP_FLOP_CB_DECOMPRESS DOUBLE PRECISION :: TMP_FLOP_FACTO_FR INTEGER :: TMP_CNT_NODES DOUBLE PRECISION :: TMP_TIME_UPDATE DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR1 DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR2 DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR3 DOUBLE PRECISION :: TMP_TIME_UPDATE_FRLR DOUBLE PRECISION :: TMP_TIME_UPDATE_FRFR DOUBLE PRECISION :: TMP_TIME_COMPRESS DOUBLE PRECISION :: TMP_TIME_MIDBLK_COMPRESS DOUBLE PRECISION :: TMP_TIME_FRSWAP_COMPRESS DOUBLE PRECISION :: TMP_TIME_CB_COMPRESS DOUBLE PRECISION :: TMP_TIME_PANEL DOUBLE PRECISION :: TMP_TIME_FAC_I DOUBLE PRECISION :: TMP_TIME_FAC_MQ DOUBLE PRECISION :: TMP_TIME_FAC_SQ DOUBLE PRECISION :: TMP_TIME_LRTRSM DOUBLE PRECISION :: TMP_TIME_FRTRSM DOUBLE PRECISION :: TMP_TIME_FRFRONTS DOUBLE PRECISION :: TMP_TIME_LR_MODULE DOUBLE PRECISION :: TMP_TIME_DIAGCOPY DOUBLE PRECISION :: TMP_TIME_DECOMP DOUBLE PRECISION :: TMP_TIME_DECOMP_UCFS DOUBLE PRECISION :: TMP_TIME_LRASM_NIV1 DOUBLE PRECISION :: TMP_TIME_LRASM_LOCASM2 DOUBLE PRECISION :: TMP_TIME_LRASM_MAPLIG1 DOUBLE PRECISION :: TMP_TIME_LRASM_CONTRIB2 DOUBLE PRECISION :: TMP_TIME_FRASM_LOCASM2 DOUBLE PRECISION :: TMP_TIME_FRASM_MAPLIG1 DOUBLE PRECISION :: TMP_TIME_FRASM_CONTRIB2 C C Workspace C INTEGER, DIMENSION(:), ALLOCATABLE :: IWK DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: WK DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: WK_REAL DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE:: WRKR_TH, & WRKC_TH INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWK8 INTEGER, DIMENSION(:), ALLOCATABLE :: BURP INTEGER, DIMENSION(:), ALLOCATABLE :: BUCP INTEGER, DIMENSION(:), ALLOCATABLE :: BURS INTEGER, DIMENSION(:), ALLOCATABLE :: BUCS INTEGER(8) :: BUREGISTRE(12) INTEGER(8) :: BUINTSZ, BURESZ, NZ_loc8 INTEGER :: BUJOB INTEGER BUMAXMN, M, SCMYID, SCNPROCS DOUBLE PRECISION SCONEERR, SCINFERR C C Parameters arising from the structure C ===================================== C * Control parameters: see description in DMUMPSID DOUBLE PRECISION,DIMENSION(:),POINTER::RINFO, RINFOG DOUBLE PRECISION,DIMENSION(:),POINTER:: CNTL INTEGER,DIMENSION(:),POINTER :: INFOG, KEEP INTEGER, DIMENSION(:), POINTER :: IRN_loc_PTR, JCN_loc_PTR DOUBLE PRECISION, DIMENSION(:), POINTER :: COLSCA_PTR, & ROWSCA_PTR DOUBLE PRECISION, DIMENSION(:), POINTER:: A_loc_PTR INTEGER, TARGET :: DUMMYIRN_loc(1), DUMMYJCN_loc(1) DOUBLE PRECISION, TARGET :: DUMMYSCA(1) DOUBLE PRECISION, TARGET :: DUMMYA_loc(1) INTEGER,DIMENSION(:),POINTER::ICNTL EXTERNAL MUMPS_GET_POOL_LENGTH INTEGER MUMPS_GET_POOL_LENGTH, SIZESCAL INTEGER(8) :: TOTAL_BYTES C C External references C =================== INTEGER, EXTERNAL :: MUMPS_NUMROC INTEGER:: NWORKING LOGICAL:: MEM_EFF_ALLOCATED INTEGER :: TOTAL_MBYTES_UNDER_L0 INTEGER(8):: TOTAL_BYTES_UNDER_L0 C Fwd in facto: DOUBLE PRECISION, DIMENSION(:), POINTER :: RHS_MUMPS LOGICAL :: RHS_MUMPS_ALLOCATED LOGICAL :: DBLARR_ALLOCATED INTEGER :: NB_ACTIVE_FRONTS_ESTIM INTEGER :: NB_FRONTS_F_ESTIM INTEGER :: KEEP_486_FOR_PRINT C C -------------------------- C Pointers used as shortcuts C -------------------------- RINFO=>id%RINFO RINFOG=>id%RINFOG CNTL=>id%CNTL INFOG=>id%INFOG KEEP=>id%KEEP ICNTL=>id%ICNTL IF (id%KEEP8(29) .NE. 0) THEN IRN_loc_PTR=>id%IRN_loc JCN_loc_PTR=>id%JCN_loc A_loc_PTR=>id%A_loc ELSE IRN_loc_PTR=>DUMMYIRN_loc JCN_loc_PTR=>DUMMYJCN_loc A_loc_PTR=>DUMMYA_loc ENDIF NOMP = 1 N = id%N C TIMINGS: reset to 0 id%DKEEP(92)=0.0D0 id%DKEEP(93)=0.0D0 id%DKEEP(94)=0.0D0 id%DKEEP(95)=0.0D0 id%DKEEP(96)=0.0D0 id%DKEEP(97)=0.0D0 id%DKEEP(98)=0.0D0 id%DKEEP(99)=0.0D0 id%DKEEP(56)=0.0D0 C Count of MPI messages: reset to 0 id%KEEP(266)=0 id%KEEP(267)=0 C ------------------------------------- C Depending on the type of parallelism, C the master can now (soon) potentially C have the role of a slave C ------------------------------------- I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) LIWK = 0_8 LIWK8 = 0_8 C RR related id%KEEP(17) = 0 id%INFOG(28) = 0 C Number of symmetric swaps id%KEEP8(80)=0_8 C Largest increase of internal panel size id%KEEP(425) =0 C Dynamic memory during process_blocfacto, in number of scalar entries id%KEEP8(130) = 0_8 ! instantaneous id%KEEP8(131) = 0_8 ! max id%KEEP8(132) = 0_8 ! max of max id%KEEP8(133) = 0_8 ! sum of max C Measure recursivity =max number of simultaneous calls to C DMUMPS_FAC_PROCESS_BLOCFACTO_LDLT id%KEEP(174) = 0 id%KEEP(175) = 0 C KEEP20_SAVE = KEEP(20) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) C Print per node informtation only in case ther are several C compute nodes (id%KEEP(412): #MPI procs on comupte node) PRINT_NODEINFO = PRINT_MAXAVG .AND. id%NPROCS .NE. id%KEEP(412) C C Related to forward in facto functionality (referred to as "Fwd in facto") NULLIFY(RHS_MUMPS) NULLIFY(DBLARR) RHS_MUMPS_ALLOCATED = .FALSE. DBLARR_ALLOCATED = .FALSE. C ----------------------------------------------------------------------- C Set WK_USER_PROVIDED to true when workspace WK_USER is provided by user C We can accept WK_USER to be provided on only one proc and C different values of WK_USER per processor C WK_USER(LWK_USER): only on working processes WK_USER_PROVIDED = (id%LWK_USER.NE.0 .AND. I_AM_SLAVE) IF (WK_USER_PROVIDED) THEN IF (id%LWK_USER.GT.0) THEN id%KEEP8(24) = int(id%LWK_USER,8) ELSE id%KEEP8(24) = -int(id%LWK_USER,8)* 1000000_8 ENDIF ELSE id%KEEP8(24) = 0_8 ENDIF C Compute sum of LWK_USER provided by user CALL MPI_REDUCE ( id%KEEP8(24), id%KEEP8(124), 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) C C KEEP8(26) might be modified C (element entry format) C but need be restore for C future factorisation C with different scaling option C KEEP826_SAVE = id%KEEP8(26) C In case of loop on factorization with C different scaling options, initialize C DKEEP(4:5) to 0. id%DKEEP(4)=-1.0D0 id%DKEEP(5)=-1.0D0 C Mapping information used during solve. In case of several facto+solve C it has to be recomputed. In case of several solves with the same C facto, it is not recomputed. IF (associated(id%IPTR_WORKING)) THEN DEALLOCATE(id%IPTR_WORKING) NULLIFY(id%IPTR_WORKING) END IF IF (associated(id%WORKING)) THEN DEALLOCATE(id%WORKING) NULLIFY(id%WORKING) END IF C C Units for printing C MP: diagnostics C LP: errors C LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) IF ( PROK ) WRITE( MP, 130 ) IF ( PROKG ) WRITE( MPG, 130 ) C C Prepare work for out-of-core C IF (id%MYID .EQ. MASTER .AND. KEEP(201) .NE. -1) THEN C Note that if KEEP(201)=-1, then we have decided C at analysis phase that factors will not be stored C (neither in memory nor on disk). In that case, C ICNTL(22) is ignored. C -- ICNTL(22) must be set before facto phase C (=1 OOC on; =0 OOC off) C and cannot be changed for subsequent solve phases. KEEP(201)=id%ICNTL(22) IF (KEEP(201) .EQ. 1) THEN # if defined(OLD_OOC_NOPANEL) KEEP(201)=2 # else KEEP(201)=1 # endif ELSE id%KEEP(201)=0 ENDIF ENDIF C C ---------------------- C Broadcast ICNTL(49) IF (id%MYID.EQ.MASTER) THEN ICNTL49_LOC=id%ICNTL(49) C out of range treated as 0 IF ( (ICNTL49_LOC.GT.2).or.(ICNTL49_LOC.LT.0) ) & ICNTL49_LOC = 0 ENDIF CALL MPI_BCAST( ICNTL49_LOC, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C ---------------------- C C Broadcast few other KEEP entries that have been decoded C and are defined for facto: C ---------------------- CALL MPI_BCAST( KEEP(12), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(19), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(21), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(459), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(460), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF ( KEEP(459) .GE. PANEL_TABSIZE ) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I4,A,I3)') " ** WARNING ** KEEP(459)=",KEEP(459), & " too large, resetting to",PANEL_TABSIZE-1 ENDIF KEEP(459) = PANEL_TABSIZE - 1 ENDIF PERLU = KEEP(12) IF (id%MYID.EQ.MASTER) THEN C { C KEEP(50) case C ============== C C KEEP(50) = 0 : matrix is unsymmetric C KEEP(50) /= 0 : matrix is symmetric C KEEP(50) = 1 : Ask L L^T on the root. Matrix is PSD. C KEEP(50) = 2 : Ask for L U on the root C KEEP(50) = 3 ... L D L^T ?? C CNTL1 = id%CNTL(1) C --------------------------------------- C For symmetric (non general) matrices C set (directly) CNTL1 = 0.0 C --------------------------------------- KEEP(17)=0 C Automatic choice if CNTL(1)<0 C For rank-revealing (KEEP(19).GT.0) then C set CNTL1=0.1 even if SYM=1 IF (CNTL1.LT.ZERO) THEN C automatic choice IF (KEEP(19).GT.0) THEN CNTL1=0.1D0 ELSE IF (KEEP(50).EQ.1) THEN CNTL1=ZERO ELSE CNTL1=0.01D0 ENDIF ENDIF IF ( KEEP(50) .eq. 1 ) THEN IF (CNTL1 .ne. ZERO ) THEN IF ( PROKG ) THEN WRITE(MPG,'(A)') & '** Warning : SPD solver called, resetting CNTL(1) to 0.0D0' END IF END IF CNTL1 = ZERO END IF C CNTL1 threshold value must be between C 0.0 and 1.0 (for SYM=0) and 0.5 (for SYM=1,2) IF (CNTL1.GT.ONE) CNTL1=ONE IF (CNTL1.LT.ZERO) CNTL1=ZERO IF (KEEP(50).NE.0.AND.CNTL1.GT.0.5D0) THEN CNTL1 = 0.5D0 ENDIF PARPIV_T1 = id%KEEP(268) IF (PARPIV_T1.EQ.77) THEN PARPIV_T1 = 0 #if defined(__ve__) PARPIV_T1 = -2 #endif ENDIF IF (PARPIV_T1.EQ.-3) THEN PARPIV_T1 = 0 ENDIF IF ((PARPIV_T1.LT.-3).OR.(PARPIV_T1.GT.1)) THEN C out of range values PARPIV_T1 =0 ENDIF C note that KEEP(50).EQ.1 => CNTL1=0.0 IF (CNTL1.EQ.0.0D0.OR.(KEEP(50).eq.1)) PARPIV_T1 = 0 C IF (PARPIV_T1.EQ.-2) THEN IF (KEEP(19).NE.0) THEN C switch off PARPIV_T1 if RR activated C but do NOT switch off PARPIV_1 with null pivot detection PARPIV_T1 = 0 ENDIF ENDIF id%KEEP(269) = PARPIV_T1 C } ENDIF CALL MPI_BCAST(CNTL1, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) CALL MPI_BCAST( KEEP(269), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (id%MYID.EQ.MASTER) THEN C{ C OMP parallelization of arrowheads C out of range are treated as zero IF (KEEP(399).LT.-1) KEEP(399)=-1 KEEP399_SAVE = KEEP(399) IF (KEEP(399).EQ.-1) THEN IF ((KEEP(54).EQ.0).AND.(id%NPROCS.GT.1)) THEN KEEP(399) = 1 ELSE KEEP(399) = 3 ENDIF ENDIF #if defined(PCPRET) C new multithreaded >=2 algo does not compile on PCPRET KEEP(399) = 1 #endif C ----------------------------------------------------- C Decoding of ICNTL(35) for factorization: same as C at analysis except that we store a copy of ICNTL(35) C in KEEP(486) instead of KEEP(494) and need to check C compatibility of KEEP(486) and KEEP(494): If LR was C not activated during analysis, it cannot be activated C at factorization. C ------------------------------------------------------ id%KEEP(486) = id%ICNTL(35) IF (id%KEEP(486).EQ.1) THEN C -- Automatic BLR option setting id%KEEP(486)= 2 ENDIF IF ( id%KEEP(486).EQ.4) id%KEEP(486)=0 IF ((id%KEEP(486).LT.0).OR.(id%KEEP(486).GT.4)) THEN C Out of range values treated as 0 id%KEEP(486) = 0 ENDIF IF ((KEEP(486).NE.0).AND.(KEEP(494).EQ.0)) THEN C To activate BLR during factorization, C ICNTL(35) must have been set at analysis. IF (LPOK) THEN WRITE(LP,'(A)') & " *** Error with BLR setting " WRITE(LP,'(A)') " *** BLR was not activated during ", & " analysis but is requested during factorization." ENDIF id%INFO(1)=-54 id%INFO(2)=0 GOTO 105 ENDIF C Save value of KEEP(486) before possibly C forcing it to 3 in case of discard factors KEEP_486_FOR_PRINT=KEEP(486) IF (KEEP(201) .EQ. -1 .AND. KEEP(486) .NE.0) THEN KEEP(486) = 3 ENDIF KEEP464COPY = id%ICNTL(38) IF (KEEP464COPY.LT.0.OR.KEEP464COPY.GT.1000) THEN C Out of range values treated as 1000 KEEP464COPY = 1000 ENDIF IF (id%KEEP(461).LT.1) THEN id%KEEP(461) = 10 ENDIF IF (id%KEEP(462).LT.1) THEN id%KEEP(462) = 10 ENDIF KEEP465COPY = id%ICNTL(39) IF (KEEP465COPY.LT.0.OR.(KEEP465COPY.GT.1000)) THEN C Out of range values treated as 1000 KEEP465COPY = 1000 ENDIF IF (id%ICNTL(36).EQ.1.OR.id%ICNTL(36).EQ.3) THEN IF (CNTL1.EQ.ZERO .OR. KEEP(468).LE.1) THEN KEEP(475) = 3 ELSE IF ( (KEEP(269).GT.0).OR. (KEEP(269).EQ.-2)) THEN KEEP(475) = 2 ELSE IF (KEEP(468).EQ.2) THEN KEEP(475) = 2 ELSE KEEP(475) = 1 ENDIF ELSE KEEP(475) = 0 ENDIF KEEP(481)=0 IF (id%ICNTL(36).LT.0 .OR. id%ICNTL(36).GE.2) THEN C Only options 1 and 2 are allowed KEEP(475) = 0 ENDIF C K489 is set according to ICNTL(37) IF (id%ICNTL(37).EQ.0.OR.id%ICNTL(37).EQ.1) THEN KEEP(489) = id%ICNTL(37) ELSE C Other values treated as zero KEEP(489) = 0 ENDIF IF (KEEP(79).GE.1) THEN C CompressCB incompatible with type4,5,6 nodes KEEP(489)=0 ENDIF C id%KEEP(476) \in [1,100] IF ((id%KEEP(476).GT.100).OR.(id%KEEP(476).LT.1)) THEN id%KEEP(476)= 50 ENDIF C id%KEEP(477) \in [1,100] IF ((id%KEEP(477).GT.100).OR.(id%KEEP(477).LT.1)) THEN id%KEEP(477)= 100 ENDIF C id%KEEP(483) \in [1,100] IF ((id%KEEP(483).GT.100).OR.(id%KEEP(483).LT.1)) THEN id%KEEP(483)= 80 ENDIF C id%KEEP(484) \in [1,100] IF ((id%KEEP(484).GT.100).OR.(id%KEEP(484).LT.1)) THEN id%KEEP(484)= 80 ENDIF C id%KEEP(480)=0,2,3,4,5,6 IF ((id%KEEP(480).GT.6).OR.(id%KEEP(480).LT.0) & .OR.(id%KEEP(480).EQ.1)) THEN id%KEEP(480)=0 ENDIF C id%KEEP(473)=0 or 1 IF ((id%KEEP(473).NE.0).AND.(id%KEEP(473).NE.1)) THEN id%KEEP(473)=0 ENDIF C id%KEEP(474)=0,1,2,3 IF ((id%KEEP(474).GT.3).OR.(id%KEEP(474).LT.0)) THEN id%KEEP(474)=0 ENDIF C id%KEEP(479)>0 IF (id%KEEP(479).LE.0) THEN id%KEEP(479)=1 ENDIF IF (id%KEEP(474).NE.0.AND.id%KEEP(480).EQ.0) THEN id%KEEP(474) = 0 ENDIF IF (id%KEEP(478).NE.0.AND.id%KEEP(480).LT.4) THEN id%KEEP(478) = 0 ENDIF IF (id%KEEP(480).GE.5 .OR. & (id%KEEP(480).NE.0.AND.id%KEEP(474).EQ.3)) THEN IF (id%KEEP(475).LT.2) THEN C Reset to 3 if 5 or to 4 if 6 id%KEEP(480) = id%KEEP(480) - 2 write(*,*) ' Resetting KEEP(480) to ', id%KEEP(480) ENDIF ENDIF 105 CONTINUE C} ENDIF ! id%MYID .EQ. MASTER CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C IF (id%INFO(1).LT.0) GOTO 530 EPS = epsilon ( ZERO ) CALL MPI_BCAST( KEEP(281), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(399), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(473), 14, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (KEEP(486).NE.0) THEN CALL MPI_BCAST( KEEP(489), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP464COPY, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP465COPY, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF IF (id%MYID.EQ.MASTER) THEN IF (KEEP(217).GT.2.OR.KEEP(217).LT.0) THEN KEEP(217)=0 ENDIF KEEP(214)=KEEP(217) IF (KEEP(214).EQ.0) THEN IF (KEEP(201).NE.0) THEN ! OOC or no factors KEEP(214)=1 ELSE KEEP(214)=2 ENDIF IF (KEEP(486).EQ.2) THEN KEEP(214)=1 ENDIF ENDIF ENDIF CALL MPI_BCAST( KEEP(214), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (KEEP(201).NE.0) THEN C -- Low Level I/O strategy CALL MPI_BCAST( KEEP(99), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(205), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(211), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(255), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF C Fwd in facto: explicitly forbid C sparse RHS and A-1 computation IF (id%KEEP(252).EQ.1 .AND. id%MYID.EQ.MASTER) THEN IF (id%ICNTL(20).EQ.1) THEN ! out-of-range => 0 C NB: in doc ICNTL(20) only accessed during solve C In practice, will have failed earlier if RHS not allocated. C Still it looks safer to keep this test. id%INFO(1)=-43 id%INFO(2)=20 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: Sparse RHS is incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE IF (id%ICNTL(30).NE.0) THEN ! out-of-range => 1 id%INFO(1)=-43 id%INFO(2)=30 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: A-1 functionality incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE IF (id%ICNTL(9) .NE. 1) THEN id%INFO(1)=-43 id%INFO(2)=9 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C IF (id%INFO(1).LT.0) GOTO 530 C C The memory allowed is given by ICNTL(23) in Mbytes C 0 means that nothing is provided. C Save memory available, ICNTL(23) in KEEP8(4) C IF ( ICNTL(23) .GT. 0 ) THEN ITMP = 1 ELSE ITMP = 0 ENDIF CALL MPI_ALLREDUCE( ITMP, JTMP, 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) IF ( id%MYID.EQ.MASTER ) THEN C Negative values considered 0 ITMP = max(ICNTL(23),0) END IF CALL MPI_BCAST( ITMP, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C JTMP: nb of procs with nonzero ICNTL(23) C ITMP: value of ICNTL(23) on master IF ( ITMP .GT. 0 .AND. JTMP .EQ. 1 ) THEN C ICNTL(23)>0 only on master ELSE C Local values of ICNTL(23) are used, note that C they could all be zeros ITMP = ICNTL(23) ENDIF C ITMP8 = int(ITMP, 8) id%KEEP8(4) = ITMP8 * 1000000_8 ! convert to nb of bytes C Compute \sum of memories allowed CALL MPI_REDUCE( id%KEEP8(4), ITMP8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) ITMP8 = ITMP8 / 1000000_8 ! Use to print \sum_{ICNTL(23)} IF ( PROKG ) THEN NWORKING = id%NSLAVES CALL MUMPS_SETI8TOI4( id%KEEP8(129), TMP_INFOG_4) WRITE( MPG, 172 ) & NWORKING, id%ICNTL(22), KEEP_486_FOR_PRINT, & KEEP(489), & id%ICNTL(49), & id%KEEP(19), & KEEP(12), & id%KEEP8(111), TMP_INFOG_4, KEEP(127), KEEP(28), & id%KEEP8(4)/1000000_8, ITMP8, id%KEEP8(124), CNTL1 IF (KEEP(252).GT.0) & WRITE(MPG,173) KEEP(253) IF (KEEP(269).NE.0) & WRITE(MPG,174) KEEP(269) ENDIF IF (KEEP(201).LE.0) THEN C In-core version or no factors KEEP(IXSZ)=XSIZE_IC ELSE IF (KEEP(201).EQ.2) THEN C OOC version, no panels KEEP(IXSZ)=XSIZE_OOC_NOPANEL ELSE IF (KEEP(201).EQ.1) THEN C Panel versions: IF (KEEP(50).EQ.0) THEN KEEP(IXSZ)=XSIZE_OOC_UNSYM ELSE KEEP(IXSZ)=XSIZE_OOC_SYM ENDIF ENDIF IF ( KEEP(486) .NE. 0 ) THEN !LR is activated C Stats initialization for LR CALL INIT_STATS_GLOBAL() END IF C Memory management: allocate id%S etc. from C or Fortran? id%KEEP(430) = 0 #if defined(MUMPS_MALLOC_FROM_C) id%KEEP(430) = 1 #endif C * ********************************** * Begin intializations regarding the * computation of the determinant * ********************************** IF (id%MYID.EQ.MASTER) KEEP(258)=ICNTL(33) CALL MPI_BCAST(KEEP(258), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF (KEEP(258) .NE. 0) THEN KEEP(259) = 0 ! Initial exponent of the local determinant KEEP(260) = 1 ! Number of permutations id%DKEEP(6) = 1.0D0 ! real part of the local determinant ENDIF * ******************************** * End intializations regarding the * computation of the determinant * ******************************** C CALL MUMPS_STOP_ON_USER_REQUEST(id%KEEP,id%KEEP8, id%ICNTL, & id%INFO, id%MYID) CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0) GOTO 530 * ********************** * Begin of Scaling phase * ********************** C C SCALING MANAGEMENT C * Options 1, 3, 4 centralized only C C * Options 7, 8 : also works for distributed matrix C C At this point, we have the scaling arrays allocated C on the master. They have been allocated on the master C inside the main MUMPS driver. C CALL MPI_BCAST(KEEP(52), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) LSCAL = ((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) IF (LSCAL) THEN C IF ( id%MYID.EQ.MASTER ) THEN CALL MUMPS_SECDEB(TIMEET) ENDIF C ----------------------- C Retrieve parameters for C simultaneous scaling C ----------------------- IF (KEEP(52) .EQ. 7) THEN C -- Cheap setting of SIMSCALING (it is the default in 4.8.4) K231= KEEP(231) K232= KEEP(232) K233= KEEP(233) ELSEIF (KEEP(52) .EQ. 8) THEN C -- More expensive setting of SIMSCALING (it was the default in 4.8.1,2,3) K231= KEEP(239) K232= KEEP(240) K233= KEEP(241) ENDIF CALL MPI_BCAST(id%DKEEP(3),1,MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) C IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. & KEEP(54).NE.0 ) THEN C{ ------------------------------ C Scaling for distributed matrix C We need to allocate scaling C arrays on all processors, not C only the master. C ------------------------------ IF ( id%MYID .NE. MASTER ) THEN IF ( associated(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=N ENDIF ALLOCATE( id%ROWSCA(N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=N ENDIF ENDIF M = N BUMAXMN=M IF(N > BUMAXMN) BUMAXMN = N LIWK = 4_8*int(BUMAXMN,8) ALLOCATE (IWK(LIWK), BURP(M), BUCP(N), & BURS(2* id%NPROCS), BUCS(2* id%NPROCS), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(LIWK+int(M,8)+int(N,8)+ & 4_8*int(id%NPROCS,8) , id%INFO(2)) ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C -- estimation of memory and construction of partvecs BUJOB = 1 C -- LWK not used LWK_REAL = 1_8 LWRKR_TH = 1_8 LWRKC_TH = 1_8 NOMP_MAX = 1 ALLOCATE(WK_REAL(LWK_REAL), & WRKR_TH(LWRKR_TH,NOMP_MAX), & WRKC_TH(LWRKC_TH,NOMP_MAX), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR( & LWK_REAL+ & LWRKR_TH*int(NOMP_MAX,8)+ & LWRKC_TH*int(NOMP_MAX,8), & id%INFO(2)) ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 CALL DMUMPS_SIMSCALEABS( & IRN_loc_PTR(1), JCN_loc_PTR(1), A_loc_PTR(1), & id%KEEP8(29), & M, N, id%NPROCS, id%MYID, id%COMM, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) IF(LIWK < BUINTSZ) THEN DEALLOCATE(IWK) LIWK = BUINTSZ ALLOCATE(IWK(LIWK), stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(LIWK,id%INFO(2)) ENDIF ENDIF DEALLOCATE(WK_REAL, WRKR_TH, WRKC_TH) LWK_REAL = BURESZ C C -- Set NOMP_MAX from KEEP(281) CALL DMUMPS_SET_NOMP_MAX(id%KEEP(281), id%KEEP(361), & N, NOMP_MAX) C IF (NOMP_MAX.LE.1) THEN C temp array per thread not used LWRKR_TH = 1 LWRKC_TH = 1 ELSE LWRKR_TH = N IF (id%KEEP(50).NE.0) THEN C WRKC_TH not used on symmetric matrices LWRKC_TH = 1 ELSE LWRKC_TH = N ENDIF ENDIF ALLOCATE(WK_REAL(LWK_REAL), & WRKR_TH(LWRKR_TH,max(NOMP_MAX,1)), & WRKC_TH(LWRKC_TH,max(NOMP_MAX,1)), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR( & LWK_REAL+ & LWRKR_TH*int(max(NOMP_MAX,1),8)+ & LWRKC_TH*int(max(NOMP_MAX,1),8), & id%INFO(2)) ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C -- estimation of memory and construction of partvecs BUJOB = 2 CALL DMUMPS_SIMSCALEABS( & IRN_loc_PTR(1), JCN_loc_PTR(1), A_loc_PTR(1), & id%KEEP8(29), & M, N, id%NPROCS, id%MYID, id%COMM, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) id%DKEEP(4) = SCONEERR id%DKEEP(5) = SCINFERR CXXXX DEALLOCATE(IWK, BURP,BUCP,BURS, BUCS) DEALLOCATE(WK_REAL, WRKR_TH, WRKC_TH) C} ELSE IF ( KEEP(54) .EQ. 0 ) THEN C{ ------------------ C Centralized matrix C ------------------ IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN C ------------------------------- C Create a communicator of size 1 C ------------------------------- IF (id%MYID.EQ.MASTER) THEN COLOUR = 0 ELSE COLOUR = MPI_UNDEFINED ENDIF CALL MPI_COMM_SPLIT( id%COMM, COLOUR, 0, & COMM_FOR_SCALING, IERR ) IF (id%MYID.EQ.MASTER) THEN M = N BUMAXMN=N IF(N > BUMAXMN) BUMAXMN = N LIWK = 1_8 ALLOCATE(IWK(LIWK), BURP(1), BUCP(1), & BURS(1), BUCS(1), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR( LIWK+4_8, id%INFO(2) ) GOTO 400 ENDIF LWK_REAL = int(M,8) + int(N,8) C C -- Set NOMP_MAX from KEEP(281) CALL DMUMPS_SET_NOMP_MAX(id%KEEP(281), id%KEEP(361), & N, NOMP_MAX) C IF (NOMP_MAX.LE.1) THEN C temp array per thread not used LWRKR_TH = 1 LWRKC_TH = 1 ELSE LWRKR_TH = N IF (id%KEEP(50).NE.0) THEN C WRKC_TH not used on symmetric matrices LWRKC_TH = 1 ELSE LWRKC_TH = N ENDIF ENDIF ALLOCATE(WK_REAL(LWK_REAL), & WRKR_TH(LWRKR_TH,max(NOMP_MAX,1)), & WRKC_TH(LWRKC_TH,max(NOMP_MAX,1)), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR( & LWK_REAL+ & LWRKR_TH*int(max(NOMP_MAX,1),8)+ & LWRKC_TH*int(max(NOMP_MAX,1),8), & id%INFO(2)) ENDIF CALL MPI_COMM_RANK(COMM_FOR_SCALING, SCMYID, IERR) CALL MPI_COMM_SIZE(COMM_FOR_SCALING, SCNPROCS, IERR) BUJOB = 1 CALL DMUMPS_SIMSCALEABS( & id%IRN(1), id%JCN(1), id%A(1), & id%KEEP8(28), & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) IF(LWK_REAL < BURESZ) THEN id%INFO(1) = -136 GOTO 400 ENDIF BUJOB = 2 CALL DMUMPS_SIMSCALEABS(id%IRN(1), & id%JCN(1), id%A(1), & id%KEEP8(28), & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) id%DKEEP(4) = SCONEERR id%DKEEP(5) = SCINFERR 400 CONTINUE IF (allocated(WK_REAL)) DEALLOCATE(WK_REAL) IF (allocated(WRKR_TH)) DEALLOCATE(WRKR_TH) IF (allocated(WRKC_TH)) DEALLOCATE(WRKC_TH) IF (allocated(IWK)) DEALLOCATE(IWK) IF (allocated(BURP)) DEALLOCATE(BURP) IF (allocated(BUCP)) DEALLOCATE(BUCP) IF (allocated(BURS)) DEALLOCATE(BURS) IF (allocated(BUCS)) DEALLOCATE(BUCS) ENDIF C Centralized matrix: make DKEEP(4:5) available to all processors CALL MPI_BCAST( id%DKEEP(4),2,MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR ) IF (id%MYID.EQ.MASTER) THEN C Communicator should only be C freed on the master process CALL MPI_COMM_FREE(COMM_FOR_SCALING, IERR) ENDIF CALL MUMPS_PROPINFO(ICNTL(1), id%INFO(1), & id%COMM, id%MYID) IF (id%INFO(1).LT.0) GOTO 517 ELSE IF (id%MYID.EQ.MASTER) THEN C ------------------- C Centralized scaling C ------------------- IF (KEEP(52).GT.0 .AND. KEEP(52).LE.6) THEN C --------------------- C Allocate temporary C workspace for scaling C --------------------- IF (KEEP(52) .eq. 1 ) THEN C No workspace indeed needed LWK = 1_8 LWK_REAL = 1_8 ELSE IF ( KEEP(52) .eq. 3 ) THEN LWK = 1_8 LWK_REAL = int(N,8) ELSE IF ( KEEP(52) .eq. 4 ) THEN C Options 3 or 4 LWK = 1_8 LWK_REAL = 2_8*int(N,8) END IF C Real workarray ALLOCATE( WK_REAL( LWK_REAL ), stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR( LWK_REAL, id%INFO(2) ) GOTO 137 END IF C Real/complex workarray ALLOCATE( WK( LWK ), stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) GOTO 137 END IF CALL DMUMPS_FAC_A(N, id%KEEP8(28), KEEP(52), id%A(1), & id%IRN(1), id%JCN(1), & id%COLSCA(1), id%ROWSCA(1), & WK, LWK, WK_REAL, LWK_REAL, ICNTL(1), id%INFO(1) ) DEALLOCATE( WK_REAL ) DEALLOCATE( WK ) ENDIF ENDIF C} ENDIF ! Scaling distributed matrices or centralized IF (KEEP(125).NE.0) THEN C ------------------------ C If we enable the scaling of the |A11 A12| block C we set to 1 the scaling corresponding to the Schur C complement matrix A22 C ------------------------ IF ((KEEP(60).GT.0) .and. (KEEP(116).GT.0)) THEN C Schur is active, reset Schur entries to ONE IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. & KEEP(54).NE.0 ) THEN C Scaling available on all procs DO I=1, N IF (id%SYM_PERM(I).GT.id%N-KEEP(116)) THEN id%COLSCA(I) = ONE id%ROWSCA(I) = ONE ENDIF ENDDO ELSE IF ( id%MYID .EQ. MASTER) THEN C Scaling available on master DO I=1, N IF (id%SYM_PERM(I).GT.id%N-KEEP(116)) THEN id%COLSCA(I) = ONE id%ROWSCA(I) = ONE ENDIF ENDDO ENDIF ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIMEET) id%DKEEP(92)=TIMEET IF (PROKG) WRITE( MPG, 140 ) TIMEET C Print inf-norm after last KEEP(233) iterations of C scaling option KEEP(52)=7 or 8 (SimScale) C IF (PROKG.AND.(KEEP(52).EQ.7.OR.KEEP(52).EQ.8)) THEN IF (K233+K231+K232.GT.0) THEN IF (K232.GT.0) WRITE(MPG, 166) id%DKEEP(4) ENDIF ENDIF ENDIF ENDIF ! LSCAL C C scaling might also be provided by the user LSCAL = (LSCAL .OR. (KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) IF (LSCAL .AND. KEEP(258).NE.0 .AND. id%MYID .EQ. MASTER) THEN DO I = 1, id%N CALL DMUMPS_UPDATEDETER_SCALING(id%ROWSCA(I), & id%DKEEP(6), ! determinant & KEEP(259)) ! exponent of the determinant ENDDO IF (KEEP(50) .EQ. 0) THEN ! unsymmetric DO I = 1, id%N CALL DMUMPS_UPDATEDETER_SCALING(id%COLSCA(I), & id%DKEEP(6), ! determinant & KEEP(259)) ! exponent of the determinant ENDDO ELSE C ----------------------------------------- C In this case COLSCA = ROWSCA C Since determinant was initialized to 1, C compute square of the current determinant C rather than going through COLSCA. C ----------------------------------------- CALL DMUMPS_DETER_SQUARE(id%DKEEP(6), KEEP(259)) ENDIF C Now we should have taken the C inverse of the scaling vectors CALL DMUMPS_DETER_SCALING_INVERSE(id%DKEEP(6), KEEP(259)) ENDIF C C ******************** C End of Scaling phase C At this point: either (matrix is distributed and KEEP(52)=7 or 8) C in which case scaling arrays are allocated on all processors, C or scaling arrays are only on the host processor. C In case of distributed matrix input, we will free the scaling C arrays on procs with MYID .NE. 0 after the all-to-all distribution C of the original matrix. C ******************** C 137 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C systematically this array now than waiting for C the root node. We rely on the fact that it is C allocated or not during the solve phase so if C it was allocated in a 1st call to facto and not C in a second, we don't want the solve to think C it was allocated in the second call. IF (associated(idintr%roota%RHS_CNTR_MASTER_ROOT)) THEN DEALLOCATE (idintr%roota%RHS_CNTR_MASTER_ROOT) NULLIFY (idintr%roota%RHS_CNTR_MASTER_ROOT) ENDIF C Fwd in facto: check that id%NRHS has not changed IF ( id%MYID.EQ.MASTER.AND. KEEP(252).EQ.1 .AND. & id%NRHS .NE. id%KEEP(253) ) THEN C Error: NRHS should not have C changed since the analysis id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) ENDIF IF (id%KEEP(252) .EQ. 1) THEN IF ( id%MYID.NE.MASTER ) THEN id%KEEP(254) = N ! Leading dimension id%KEEP8(85) = int(N,8)*int(id%KEEP(253),8) ! Tot size ALLOCATE(RHS_MUMPS(id%KEEP8(85)),stat=IERR) IF (IERR > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(85), id%INFO(2)) IF (LPOK) & WRITE(LP,*) 'ERROR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. ELSE RHS_MUMPS_ALLOCATED = .TRUE. ENDIF ELSE C Case of non working master id%KEEP(254)=id%LRHS ! Leading dimension id%KEEP8(85)=int(id%LRHS,8)*int(id%KEEP(253)-1,8)+ & int(id%N,8) ! Tot size RHS_MUMPS=>id%RHS RHS_MUMPS_ALLOCATED = .FALSE. IF (LSCAL) THEN C Scale before broadcast: apply row C scaling (remark that we assume no C transpose). DO K=1, id%KEEP(253) DO I=1, N RHS_MUMPS( id%KEEP(254) * (K-1) + I ) & = RHS_MUMPS( id%KEEP(254) * (K-1) + I ) & * id%ROWSCA(I) ENDDO ENDDO ENDIF ENDIF ELSE id%KEEP8(85)=1_8 ALLOCATE(RHS_MUMPS(1),stat=IERR) IF (IERR > 0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF (LPOK) & WRITE(LP,*) 'ERREUR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. ELSE RHS_MUMPS_ALLOCATED = .TRUE. ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 516 IF (KEEP(252) .EQ. 1) THEN C C Broadcast the columns of the right-hand side C one by one. Leading dimension is keep(254)=N C on procs with MYID > 0 but may be larger on C the master processor. DO I= 1, id%KEEP(253) CALL MPI_BCAST(RHS_MUMPS((I-1)*id%KEEP(254)+1), N, & MPI_DOUBLE_PRECISION, MASTER,id%COMM,IERR) END DO ENDIF IF (id%MYID.EQ. MASTER) THEN C Copy the value of ICNTL(24) and make it C available on all working processors. KEEP(110)=id%ICNTL(24) C KEEP(110) defaults to 0 for out of range values IF (KEEP(110).NE.1) KEEP(110)=0 ENDIF CALL MPI_BCAST(KEEP(110), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) C ----------------------------------------------- C Depending on the option used for C -detecting null pivots (ICNTL(24)/KEEP(110)) C CNTL(3) is used to set DKEEP(1) C ( A row is considered as null if ||row|| < DKEEP(1) ) C CNTL(5) is then used to define if a large C value is set on the diagonal or if a 1 is set C and other values in the row are reset to zeros. C -rank revealing on the Schur (ICNTL(56)/KEEP(19)) C SEUIL* corresponds to the minimum required C absolute value of pivot. C SEUIL_LDLT_NIV2 is used only in the C case of SYM=2 within a niv2 node for which C we have only a partial view of the fully summed rows. IF (id%MYID .EQ. MASTER) CNTL3 = id%CNTL(3) CALL MPI_BCAST(CNTL3, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) CNTL5 = id%CNTL(5) CALL MPI_BCAST(CNTL5, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) CNTL6 = id%CNTL(6) CALL MPI_BCAST(CNTL6, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) id%DKEEP(8) = id%CNTL(7) CALL MPI_BCAST(id%DKEEP(8), 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) id%DKEEP(11) = id%DKEEP(8)/id%KEEP(461) id%DKEEP(12) = id%DKEEP(8)/id%KEEP(462) IF (KEEP(486).EQ.0) id%DKEEP(8) = ZERO COMPUTE_ANORMINF = .FALSE. IF ( (KEEP(486) .NE. 0).AND. (id%DKEEP(8).LT.ZERO)) THEN COMPUTE_ANORMINF = .TRUE. ENDIF IF (KEEP(19).NE.0) THEN C Rank revealing factorisation COMPUTE_ANORMINF = .TRUE. ENDIF IF (KEEP(110).NE.0) THEN C Null pivot detection COMPUTE_ANORMINF = .TRUE. ENDIF IF (id%DKEEP(8).LT.ZERO) THEN C Experimental setting of CNTL(7) IF (COMPUTE_ANORMINF) THEN EFF_SIZE_SCHUR = 0 CALL DMUMPS_ANORMINF( id , ANORMINF, LSCAL, EFF_SIZE_SCHUR ) C If no schur ANORMINF fine for other cases id%DKEEP(8) = abs(id%DKEEP(8))*ANORMINF ELSE ANORMINF = ZERO id%DKEEP(8) = abs(id%DKEEP(8)) ENDIF C ANORMINF need be recomputed in case of schur IF ((KEEP(60).GT.0).AND.KEEP(116).GT.0) ANORMINF=ZERO ENDIF IF (PROKG) THEN IF ( (CNTL(7) < ZERO) .AND. COMPUTE_ANORMINF .AND. & (KEEP(486) .NE. 0) ) THEN C Warning : using negative values is an experimental and C non recommended setting. WRITE(MPG,'(/A,A/,A/,A,A)') & ' WARNING in BLR input setting: ', & ' CNTL(7) < 0 is experimental: ', & ' Effective BLR threshold = |CNTL(7| x ||A_pre||, ', & ' where A_pre is the preprocessed matrix as defined', & ' in the users guide ' WRITE(MPG,'(A,3D16.4/)') & ' Effective BLR threshold, CNTL(7), ||A_pre|| = ', & id%DKEEP(8), CNTL(7), ANORMINF ENDIF ENDIF C ------------------------------------------------------- C We compute ANORMINF, when needed, based on C the infinite norm of Rowsca *A*Colsca C and make it available on all working processes. IF (COMPUTE_ANORMINF) THEN EFF_SIZE_SCHUR = 0 IF (KEEP(60).GT.0) EFF_SIZE_SCHUR = KEEP(116) CALL DMUMPS_ANORMINF( id , ANORMINF, LSCAL, EFF_SIZE_SCHUR ) ELSE ANORMINF = ZERO ENDIF C IF ((KEEP(19).NE.0).OR.(KEEP(110).NE.0)) THEN IF (PROKG) THEN IF (KEEP(19).NE.0) THEN WRITE(MPG,'(A,1PD16.4)') & ' CNTL(3) for null pivot rows/singularities =',CNTL3 ELSE WRITE(MPG,'(A,1PD16.4)') & ' CNTL(3) for null pivot row detection =',CNTL3 ENDIF ENDIF ENDIF IF (KEEP(19).EQ.0) THEN C{ -- RR is off SEUIL = ZERO id%DKEEP(9) = ZERO C} ELSE C{ -- RR is on C C CNTL(3) is the threshold used in the following to compute C DKEEP(9) the threshold under which the sing val. are considered C as null and from which we start to look for a gap between two C sing val. IF (CNTL3 .LT. ZERO) THEN id%DKEEP(9) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(9) = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN CALL MUMPS_NPIV_CRITICAL_PATH( & N, KEEP(28), id%STEP(1), id%FRERE_STEPS(1), id%FILS(1), & id%NA(1), id%LNA, id%NE_STEPS(1), KEEP(127), & NPIV_CRITICAL_PATH ) id%DKEEP(9) = sqrt(dble(NPIV_CRITICAL_PATH))*EPS*ANORMINF ENDIF IF (PROKG) THEN WRITE(MPG, '(A,I16)') & ' ICNTL(56) rank revealing effective value =',KEEP(19) WRITE(MPG,'(A,1PD16.4)') & ' ...Threshold for singularities on the root =',id%DKEEP(9) ENDIF C RR postponing considers that pivot rows with norm smaller C than SEUIL should be postponed. C SEUIL should be bigger than DKEEP(9), this means that C DKEEP(13) should be bigger than 1. Thresh_Seuil = id%DKEEP(13) IF (id%DKEEP(13).LT.1) Thresh_Seuil = 10 SEUIL = id%DKEEP(9)*Thresh_Seuil IF (PROKG) WRITE(MPG,'(A,1PD16.4)') & ' ...Threshold for postponing =',SEUIL C} ENDIF !end KEEP(19).ne.0 SEUIL_LDLT_NIV2 = SEUIL C ------------------------------- C -- Null pivot row detection C ------------------------------- IF (KEEP(110).EQ.0) THEN C{ -- Null pivot is off C Initialize DKEEP(1) to a negative value C in order to avoid detection of null pivots C (test max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL C in DMUMPS_FAC_I, where PIVNUL=DKEEP(1)) id%DKEEP(1) = -1.0D0 id%DKEEP(2) = ZERO C} ELSE C{ -- Null pivot detection is on IF (KEEP(19).NE.0) THEN C{ -- RR is on C RR postponing considers that pivot rows of norm smaller that SEUIL C should be postponed, but pivot rows smaller than DKEEP(1) are C directly added to null space and thus considered as null pivot rows. IF ((id%DKEEP(10).LE.0).OR.(id%DKEEP(10).GT.1)) THEN C DKEEP(10) is out of range, set to the default value 10-1 id%DKEEP(1) = id%DKEEP(9)*1D-1 ELSE id%DKEEP(1) = id%DKEEP(9)*id%DKEEP(10) ENDIF C} ELSE C{ -- RR is off C -- only Null pivot detection C We keep strategy currently used in MUMPS 4.10.0 IF (CNTL3 .LT. ZERO) THEN id%DKEEP(1) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(1) = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN c id%DKEEP(1) = NPIV_CRITICAL_PATH*EPS*ANORMINF CALL MUMPS_NPIV_CRITICAL_PATH( & N, KEEP(28), id%STEP(1), id%FRERE_STEPS(1), id%FILS(1), & id%NA(1), id%LNA, id%NE_STEPS(1), KEEP(127), & NPIV_CRITICAL_PATH ) id%DKEEP(1) = sqrt(dble(NPIV_CRITICAL_PATH))*EPS*ANORMINF ENDIF C} ENDIF ! fin rank revealing IF ((KEEP(110).NE.0).AND.(PROKG)) THEN WRITE(MPG, '(A,I16)') & ' ICNTL(24) null pivot rows detection =',KEEP(110) WRITE(MPG,'(A,1PD16.4)') & ' ...Zero pivot detection threshold =',id%DKEEP(1) ENDIF IF (CNTL5.GT.ZERO) THEN id%DKEEP(2) = CNTL5 * ANORMINF IF (PROKG) WRITE(MPG,'(A,1PD16.4)') & ' ...Fixation for null pivots =',id%DKEEP(2) ELSE IF (PROKG) WRITE(MPG,*) '...Infinite fixation ' IF (id%KEEP(50).EQ.0) THEN C Unsym ! the user let us choose a fixation. set in NEGATIVE ! to detect during facto when to set row to zero ! id%DKEEP(2) = -max(1.0D10*ANORMINF, & sqrt(huge(ANORMINF))/1.0D8) ELSE C Sym id%DKEEP(2) = ZERO ENDIF ENDIF C} ENDIF ! fin null pivot detection. C Find id of root node if RR is on IF (KEEP(19).NE.0) THEN ID_ROOT =MUMPS_PROCNODE(id%PROCNODE_STEPS(id%STEP(KEEP(20))), & id%KEEP(199)) IF ( KEEP( 46 ) .NE. 1 ) THEN ID_ROOT = ID_ROOT + 1 END IF ENDIF IF (KEEP(19).EQ.0.AND.KEEP(53).NE.0) THEN C ICNTL(56)>0 at analysis and =0 at facto C save special root index KEEP20_SAVE = KEEP(20) C suppress special RR treatment KEEP(20) = 0 ENDIF C Second pass: set parameters for null pivot detection C Allocate PIVNUL_LIST_STRUCT in case of null pivot detection C and in case of rank revealing KEEP(109) = 0 LPN_LIST = 0 IF(KEEP(110) .EQ. 1) THEN LPN_LIST = 100 ENDIF IF (KEEP(19).NE.0 .AND. & (ID_ROOT.EQ.id%MYID .OR. id%MYID.EQ.MASTER)) THEN LPN_LIST = 100 ENDIF IF (LPN_LIST.GT.0) THEN PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST = LPN_LIST ALLOCATE( PIVNUL_LIST_STRUCT%PIVNUL_LIST(LPN_LIST),stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=LPN_LIST END IF PIVNUL_LIST_STRUCT%PIVNUL_LIST(1:LPN_LIST) = 0 ENDIF C end set parameter for null pivot detection CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 516 C -------------------------------------------------------------- C STATIC PIVOTING C -- Static pivoting only when RR and Null pivot detection OFF C -------------------------------------------------------------- KEEP(97) = 0 IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (id%MYID .EQ. MASTER) CNTL4 = id%CNTL(4) CALL MPI_BCAST( CNTL4, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR ) C IF ( CNTL4 .GE. ZERO ) THEN KEEP(97) = 1 IF ( CNTL4 .EQ. ZERO ) THEN C -- set seuil to sqrt(eps)*||A|| IF(ANORMINF .EQ. ZERO) THEN EFF_SIZE_SCHUR = 0 IF (KEEP(60).GT.0) EFF_SIZE_SCHUR = KEEP(116) CALL DMUMPS_ANORMINF( id , ANORMINF, LSCAL, & EFF_SIZE_SCHUR ) ENDIF SEUIL = sqrt(EPS) * ANORMINF ELSE SEUIL = CNTL4 ENDIF SEUIL_LDLT_NIV2 = SEUIL ELSE SEUIL = ZERO ENDIF ENDIF C set number of tiny pivots / 2x2 pivots in types 1 / C 2x2 pivots in types 2, to zero. This is because the C user can call the factorization step several times. KEEP(98) = 0 KEEP(103) = 0 KEEP(105) = 0 MAXS = 1_8 * * Start allocations * ***************** * C C The slaves can now perform the factorization C C C or point to user provided data WK_USER when LWK_USER>0 C ======================= C C Compute BLR_STRAT and a first estimation C of MAXS, the size of id%S CALL DMUMPS_SET_BLRSTRAT_AND_MAXS_K8 ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & id%KEEP(1), id%KEEP8(1)) C MAXS = MAXS_BASE_RELAXED8 IF (WK_USER_PROVIDED) THEN C -- Set MAXS to size of WK_USER_ MAXS = id%KEEP8(24) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 516 ENDIF C id%KEEP8(75) = huge(id%KEEP8(75)) id%KEEP8(76) = huge(id%KEEP8(76)) IF (I_AM_SLAVE) THEN C IF (id%KEEP8(4) .NE. 0_8) THEN C IF ( .NOT. WK_USER_PROVIDED ) THEN C Set MAXS given BLR_STRAT, KEEP(201) and MAXS_BASE_RELAXED8 CALL DMUMPS_MEM_ALLOWED_SET_MAXS ( & MAXS, & BLR_STRAT, id%KEEP(201), MAXS_BASE_RELAXED8, & id%KEEP(1), id%KEEP8(1), id%MYID, id%N, id%NELT, & id%NA(1), id%LNA, id%NSLAVES, & KEEP464COPY, KEEP465COPY, & id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) C Given MAXS and max memory allowed KEEP8(4) C compute in KEEP8(75) the number of real/complex C available for dynamic allocations CALL DMUMPS_MEM_ALLOWED_SET_K75 ( & MAXS, id%MYID, & .FALSE., ! UNDER_L0_OMP & N, id%NELT, id%NA(1), id%LNA, id%NSLAVES, & BLR_STRAT, id%KEEP(201), & id%KEEP, id%KEEP8, id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) ELSE C KEEP8(75) dow not include MAXS, since WK_USER is provided CALL DMUMPS_MEM_ALLOWED_SET_K75 ( & 0_8, id%MYID, & .FALSE., ! UNDER_L0_OMP & N, id%NELT, id%NA(1), id%LNA, id%NSLAVES, & BLR_STRAT, id%KEEP(201), & id%KEEP, id%KEEP8, id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) ENDIF IF (KEEP(400) .GT.0) THEN C ------------------------------ C compute KEEP8(75) under L0_OMP C ------------------------------ C Save KEEP8(75) above L0_OMP to reset KEEP8(75) C when starting FAC_PAR_M id%KEEP8(76) = id%KEEP8(75) CALL DMUMPS_MEM_ALLOWED_SET_K75 ( & 0_8, ! MAXS=0_8 & id%MYID, & .TRUE., ! UNDER_L0_OMP & id%N, id%NELT, id%NA(1), id%LNA, id%NSLAVES, & BLR_STRAT, id%KEEP(201), & id%KEEP, id%KEEP8, id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) C KEEP8(75) holds the number of entries that C can be allocated underL0. C It will be used during DMUMPS_FAC_L0_OMP to adjust the C the size of MUMPS_TPS_ARR(ITH)%LA ENDIF ENDIF ! MEM_ALLOWED C ENDIF ! I_AM_SLAVE THEN C IF (I_AM_SLAVE) THEN IF ( (KEEP(400).GT.0) .AND. (KEEP(406).EQ.2) ) THEN C Compute KEEP8(77) the peak authorized used by C DMUMPS_PERFORM_COPIES CALL DMUMPS_L0_COMPUTE_PEAK_ALLOWED( & id%MYID, id%N, & id%NELT, id%NA(1), id%LNA, id%NSLAVES, & BLR_STRAT, id%KEEP(201), & id%KEEP(1), id%KEEP8(1), id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) ENDIF ENDIF ! I_AM_SLAVE) C CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 516 ENDIF CALL MUMPS_SETI8TOI4(MAXS, id%INFO(39)) CALL DMUMPS_AVGMAX_STAT8(PROKG, MPG, MAXS, id%NSLAVES, & PRINT_MAXAVG, & id%COMM, " Effective size of S (based on INFO(39))= ") C IF ( I_AM_SLAVE ) THEN C ---------------------------------------- C Initialize some global variables related C to communication buffer management C ---------------------------------------- CALL MUMPS_BUF_INI_MYID(id%MYID_NODES) CALL MUMPS_BUF_INIT( id%KEEP( 34 ), id%KEEP(35) ) C ------------------ C Dynamic scheduling C ------------------ CALL MUMPS_LOAD_SET_INICOST( dble(id%COST_SUBTREES), & KEEP(64), dble(id%DKEEP(15)), KEEP(375), MAXS ) MEMORY_MD_ARG = min(int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8 ), C Restrict freedom from dynamic scheduler when C MEM_ALLOWED=ICNTL(23) is small (case where KEEP8(4)-MAXS_BASE8 C is negative after call to DMUMPS_MAX_MEM) & max(0_8, MAXS-MAXS_BASE8)) CALL MUMPS_LOAD_INIT( MEMORY_MD_ARG, MAXS, id%KEEP, & id%KEEP8, id%INFO, id%ISTEP_TO_INIV2, id%CANDIDATES, id%ND_STEPS, & id%FILS, id%FRERE_STEPS, id%DAD_STEPS, id%PROCNODE_STEPS, & id%STEP, id%NE_STEPS, id%N, id%MAX_SURF_MASTER, id%SUP_PROC, & id%COMM_LOAD, id%COMM_NODES, & id%DEPTH_FIRST, id%COST_TRAV, id%DEPTH_FIRST_SEQ, id%SBTR_ID, & id%NA, id%NSLAVES, id%FUTURE_NIV2, & id%NBSA, id%NBSA_LOCAL, id%MEM_SUBTREE, id%MY_FIRST_LEAF, & id%MY_NB_LEAF, id%MY_ROOT_SBTR ) IF (KEEP(201) .GT. 0) THEN C ------------------- C OOC initializations C ------------------- IF (KEEP(201).EQ.1 !PANEL Version & .AND.KEEP(50).EQ.0 ! Unsymmetric & .AND.KEEP(251).NE.2 ! Store L to disk & ) THEN id%OOC_NB_FILE_TYPE=2 ! declared in MUMPS_OOC_COMMON ELSE id%OOC_NB_FILE_TYPE=1 ! declared in MUMPS_OOC_COMMON ENDIF C ------------------------------ C Dimension IO buffer, KEEP(100) C ------------------------------ IF (KEEP(205) .GT. 0) THEN KEEP(100) = KEEP(205) ELSE IF (KEEP(201).EQ.1) THEN ! PANEL version ITMP8 = int(id%OOC_NB_FILE_TYPE,8) * & 2_8 * int(KEEP(226),8) ELSE ITMP8 = 2_8 * id%KEEP8(119) ENDIF ITMP8 = ITMP8 + int(max(KEEP(12),0),8) * & (ITMP8/100_8+1_8) C we want to avoid too large IO buffers. C 12M corresponds to 100Mbytes given to buffers. ITMP8 = min(ITMP8, 12000000_8) KEEP(100)=int(ITMP8) ENDIF IF (KEEP(201).EQ.1) THEN C Panel version. Force the use of a buffer. IF ( KEEP(99) < 3 ) THEN KEEP(99) = KEEP(99) + 3 ENDIF ENDIF C -------------------------- C Reset KEEP(100) to 0 if no C buffer is used for OOC. C -------------------------- IF (KEEP(99) .LT.3) KEEP(100)=0 IF((dble(KEEP(100))*dble(KEEP(35))/dble(2)).GT. & (dble(1999999999)))THEN IF (PROKG) THEN WRITE(MPG,*)id%MYID,': Warning: DIM_BUF_IO might be & too big for Filesystem' ENDIF ENDIF ALLOCATE (id%OOC_INODE_SEQUENCE(KEEP(28), & id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_INODE_SEQUENCE) GOTO 112 ENDIF ALLOCATE (id%OOC_TOTAL_NB_NODES(id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE NULLIFY(id%OOC_TOTAL_NB_NODES) GOTO 112 ENDIF ALLOCATE (id%OOC_SIZE_OF_BLOCK(KEEP(28), & id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_SIZE_OF_BLOCK) GOTO 112 ENDIF ALLOCATE (id%OOC_VADDR(KEEP(28),id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_VADDR) GOTO 112 ENDIF ENDIF ENDIF 112 CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) < 0) THEN C LOAD_END must be done but not OOC_END_FACTO GOTO 513 ENDIF IF (I_AM_SLAVE) THEN IF (KEEP(201) .GT. 0) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL DMUMPS_OOC_INIT_FACTO(id%ICNTL(1), id%ICNTL(4), id%N, & id%NSLAVES, id%MYID, MAXS, id%OOC_NB_FILE_TYPE, & id%KEEP, id%KEEP8, id%STEP, id%PROCNODE, & id%OOC_SIZE_OF_BLOCK, id%OOC_VADDR, id%INFO, & id%OOC_TMPDIR, id%OOC_PREFIX, id%OOC_NB_FILES, & id%OOC_INODE_SEQUENCE) ELSE WRITE(*,*) "Internal error in DMUMPS_FAC_DRIVER" CALL MUMPS_ABORT() ENDIF IF(id%INFO(1).LT.0)THEN GOTO 111 ENDIF ENDIF C First increment corresponds to the number of C floating-point operations for subtrees allocated C to the local processor. CALL MUMPS_LOAD_UPDATE(0,.FALSE.,dble(id%COST_SUBTREES), & id%KEEP(1),id%KEEP8(1)) IF (id%INFO(1).LT.0) GOTO 111 END IF C ----------------------- C Manage main workarray S C ----------------------- EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) #if defined (LARGEMATRICES) IF ( id%MYID .ne. MASTER ) THEN #endif IF (.NOT.WK_USER_PROVIDED) THEN IF ( EARLYT3ROOTINS ) THEN C Standard allocation strategy CALL DMUMPS_DM_ALLOC_S_WK(id%S, MAXS, IERR, & KEEP(430), KEEP(35)) id%KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(MAXS, id%INFO(2)) C On some platforms (IBM for example), an C allocation failure returns a non-null pointer. C Therefore we nullify S NULLIFY(id%S) id%KEEP8(23)=0_8 ENDIF ENDIF ELSE id%S => id%WK_USER(1:id%KEEP8(24)) id%KEEP8(23) = 0_8 ENDIF #if defined (LARGEMATRICES) END IF #endif C 111 CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 514 C -------------------------- C Initialization of modules C related to data management C -------------------------- NB_ACTIVE_FRONTS_ESTIM = 3 NB_THREADS = 1 !$ NB_THREADS = OMP_GET_MAX_THREADS() C NB_ACTIVE_FRONTS_ESTIM = 3*NB_THREADS IF (I_AM_SLAVE) THEN C CALL MUMPS_FDM_INIT('A',NB_ACTIVE_FRONTS_ESTIM, id%INFO) C IF ( (KEEP(486).EQ.2) & .OR. ((KEEP(489).NE.0).AND.(KEEP(400).GT.1)) & ) THEN C In case of LRSOLVE or CompressCB, C initialize nb of handlers to nb of BLR C nodes estimated at analysis NB_FRONTS_F_ESTIM = KEEP(470) ELSE IF (KEEP(489).NE.0) THEN C Compress CB and no L0 OMP (or 1 thread under L0): C NB_ACTIVE_FRONTS_ESTIM is too small, C to limit nb of reallocations make it twice larger NB_FRONTS_F_ESTIM = 2*NB_ACTIVE_FRONTS_ESTIM ELSE NB_FRONTS_F_ESTIM = NB_ACTIVE_FRONTS_ESTIM ENDIF ENDIF CALL MUMPS_FDM_INIT('F',NB_FRONTS_F_ESTIM, id%INFO ) IF (id%INFO(1) .LT. 0 ) GOTO 114 #if ! defined(NO_FDM_DESCBAND) C Storage of DESCBAND information CALL MUMPS_FDBD_INIT( NB_ACTIVE_FRONTS_ESTIM, id%INFO ) #endif #if ! defined(NO_FDM_MAPROW) C Storage of MAPROW and ROOT2SON information CALL MUMPS_FMRD_INIT( NB_ACTIVE_FRONTS_ESTIM, id%INFO ) #endif CALL DMUMPS_BLR_INIT_MODULE( NB_FRONTS_F_ESTIM, id%INFO & ) 114 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C GOTO 500: one of the above module initializations failed IF ( id%INFO(1).LT.0 ) GOTO 500 C C C Allocate space for matrix in arrowhead form C =========================================== C C CASE 1 : Matrix is assembled C CASE 2 : Matrix is elemental C IF ( KEEP(55) .eq. 0 ) THEN C ------------------------------------ C Space has been allocated already for C the integer part during analysis C Only slaves need the arrowheads. C ------------------------------------ IF ( I_AM_SLAVE .and. id%KEEP8(26) .ne. 0_8 ) THEN ALLOCATE( DBLARR( id%KEEP8(26) ), & INTARR( id%KEEP8(27) ), stat = IERR ) ELSE ALLOCATE( DBLARR( 1 ), & INTARR( 1 ), stat =IERR ) END IF IF ( IERR .NE. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for DBLARR(',id%KEEP8(26),')+INTARR(', & id%KEEP8(27),')' ENDIF id%INFO(1)=-13 CALL MUMPS_SET_IERROR( max(id%KEEP8(26),1_8)+ & max(id%KEEP8(27),1_8), & id%INFO(2) ) GOTO 100 END IF DBLARR_ALLOCATED = .TRUE. ELSE C -------------------------------- C Allocate element variables lists C -------------------------------- IF ( I_AM_SLAVE .and. id%KEEP8(27) .ne. 0_8 ) THEN ALLOCATE( INTARR( id%KEEP8(27) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(id%KEEP8(27), id%INFO(2)) GOTO 100 END IF ELSE C INTARR also allocated of size 1 on non-working master ALLOCATE( INTARR(1),stat=allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 GOTO 100 END IF END IF C --------------------------------------- C Allocate DBLARR to hold possibly scaled C copies of elemental matrices C On a working master (hybrid host) and C no scaling, avoid the copy and point C directly to user data instead. C --------------------------------------- IF ( I_AM_SLAVE ) THEN IF ( id%MYID_NODES .eq. MASTER & .AND. KEEP(46) .eq. 1 & .AND. KEEP(52) .eq. 0 ) THEN C ------------------- C Pointer association C ------------------- DBLARR => id%A_ELT ELSE C ---------- C Allocation C ---------- ALLOCATE( DBLARR( max(id%KEEP8(26),1_8) ), stat=allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(max(id%KEEP8(26),1_8), id%INFO(2)) NULLIFY(DBLARR) GOTO 100 END IF DBLARR_ALLOCATED = .TRUE. END IF ELSE ALLOCATE( DBLARR(1), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(DBLARR) GOTO 100 END IF DBLARR_ALLOCATED = .TRUE. END IF END IF 100 CONTINUE C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C ------------------------------------------ C Prepare stuff for the 2D block-cyclic root C ------------------------------------------ IF ( KEEP(38).NE.0 ) THEN ALLOCATE(idintr%root%RG2L(id%N), stat=allocok) IF ( allocok .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N END IF IF ( id%INFO(1) .GE.0 ) THEN CALL DMUMPS_INIT_ROOT_FAC( id%N, id%MYID, & idintr%root, id%FILS(1), id%KEEP(1) ) ENDIF ENDIF C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C C ----------------------------------- C C DISTRIBUTION OF THE ORIGINAL MATRIX C C ----------------------------------- C C TIMINGS: computed (and printed) on the host C Next line: global time for distrib(arrowheads,elts) C on the host. Synchronization has been performed. IF (id%MYID.EQ.MASTER) CALL MUMPS_SECDEB(TIME) C ------------------------------------------- C S_PTR_ARG / MAXS_ARG will be used for id%S C argument to arrowhead/element distribution C routines: if id%S is not allocated, we pass C S_DUMMY_ARG instead, which is not accessed. C ------------------------------------------- IF (EARLYT3ROOTINS) THEN S_PTR_ARG => id%S MAXS_ARG = MAXS ELSE S_PTR_ARG => S_DUMMY_ARG MAXS_ARG = 1 ENDIF C IF ( KEEP( 55 ) .eq. 0 ) THEN C { C ---------------------------- C Original matrix is assembled C Arrowhead format to be used. C ---------------------------- C KEEP8(26) and KEEP8(27) hold the number of entries for real/integer C for the matrix in arrowhead format. They have been set by the C analysis phase (DMUMPS_ANA_F and DMUMPS_ANA_G) C C ------------------------------------------------------------------ C Blocking is used for sending arrowhead records (I,J,VAL) C buffer(1) is used to store number of bytes already packed C buffer(2) number of records already packed C KEEP(39) : Number of records (blocking factor) C ------------------------------------------------------------------ C C --------------------------------------------- C In case of parallel root compute minimum C size of workspace to receive arrowheads C of root node. Will be used to check that C MAXS is large enough for arrowheads (case C of EARLYT3ROOTINS (KEEP(200)=0); if .NOT. C EARLYT3ROOTINS (KEEP(200)=1), root will C be assembled into id%S later and size of C id%S will be checked later) C --------------------------------------------- IF (EARLYT3ROOTINS .AND. KEEP(38).NE.0 .AND. & KEEP(60) .EQ.0 .AND. I_AM_SLAVE) THEN LWK = int(MUMPS_NUMROC( idintr%root%ROOT_SIZE, & idintr%root%MBLOCK, & idintr%root%MYROW, 0, idintr%root%NPROW ),8) LWK = max( 1_8, LWK ) LWK = LWK* & int(MUMPS_NUMROC( idintr%root%ROOT_SIZE, & idintr%root%NBLOCK, & idintr%root%MYCOL, 0, idintr%root%NPCOL ),8) LWK = max( 1_8, LWK ) ELSE LWK = 1_8 ENDIF C MAXS must be at least 1, and in case of C parallel root, large enough to receive C arrowheads of root. IF (MAXS .LT. int(LWK,8)) THEN id%INFO(1) = -9 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C C ===================================================== IF (KEEP(399).GE.2) THEN C{ Multihtreaded algorithm taking into account all cases C ===================================================== C C Timing on master. IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIME) END IF C NZ_loc8 = 0_8 NBRECORDS = KEEP(39) SIZESCAL = id%N C Set NZ_loc8, A_loc_PTR, IRN_loc_PTR, JCN_loc_PTR C and update NBRECORDS IF (KEEP(54).EQ.0) THEN C centralized matrix IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF IF (id%MYID.EQ.MASTER) THEN NZ_loc8 = id%KEEP8(28) A_loc_PTR => id%A IRN_loc_PTR => id%IRN JCN_loc_PTR => id%JCN IF (LSCAL) THEN COLSCA_PTR => id%COLSCA ROWSCA_PTR => id%ROWSCA ELSE COLSCA_PTR => DUMMYSCA ROWSCA_PTR => DUMMYSCA SIZESCAL = 1 ENDIF ELSE A_loc_PTR => DUMMYA_loc IRN_loc_PTR => DUMMYIRN_loc JCN_loc_PTR => DUMMYJCN_loc COLSCA_PTR => DUMMYSCA ROWSCA_PTR => DUMMYSCA SIZESCAL = 1 ENDIF ELSE C distributed matrix C --------------------------------------------------- C In order to have possibly IRN_loc/JCN_loc/A_loc C of size 0, avoid to pass them inside REDISTRIBUTION C and pass id instead C NZ_locMAX8 gives as a maximum buffer size (send/recv) used C an upper bound to limit buffers on small matrices C --------------------------------------------------- CALL MPI_ALLREDUCE(id%KEEP8(29), NZ_locMAX8, 1, & MPI_INTEGER8, MPI_MAX, id%COMM, IERR) IF (NZ_locMAX8 .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(NZ_locMAX8) ENDIF NZ_loc8 = id%KEEP8(29) LSCAL = (KEEP(52).EQ.7).OR.(KEEP(52).EQ.8) C available on all MPI IF (LSCAL) THEN COLSCA_PTR => id%COLSCA ROWSCA_PTR => id%ROWSCA ELSE COLSCA_PTR => DUMMYSCA ROWSCA_PTR => DUMMYSCA SIZESCAL = 1 ENDIF ENDIF #if ! defined(PCPRET) IF (id%KEEP(72).EQ.1) THEN NBRECORDS = max(3,NBRECORDS/10) ENDIF CALL DMUMPS_FAC_DIST_ARROWHEADS_OMP ( id%N, & NZ_loc8, C replace id by: & A_loc_PTR(1), IRN_loc_PTR(1), JCN_loc_PTR(1), & SIZESCAL, LSCAL, COLSCA_PTR(1), ROWSCA_PTR(1), & DBLARR(1), id%KEEP8(26), INTARR(1), & id%KEEP8(27), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & id%FILS(1), & KEEP(1), id%KEEP8(1), id%MYID, id%COMM, NBRECORDS, & S_PTR_ARG(1), MAXS_ARG, idintr%root, idintr%roota, & id%PROCNODE_STEPS(1), & id%NPROCS, id%NSLAVES, id%SYM_PERM(1), id%STEP(1), & id%ICNTL(1), id%INFO(1), NSEND8, NLOCAL8, & id%ISTEP_TO_INIV2(1), & id%CANDIDATES(1,1) & ) CALL MPI_BARRIER(id%COMM, IERR) #else #endif C IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN C ------------------------------ C The host is not working -> had C no data from initial matrix C ------------------------------ NSEND8 = 0_8 NLOCAL8 = 0_8 END IF C ------------------------- C Check for possible errors C ------------------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 CALL MPI_REDUCE( NSEND8, NSEND_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( NLOCAL8, NLOCAL_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN WRITE(MPG,125) NLOCAL_TOT8, NSEND_TOT8 END IF C} ELSE C{ ======================================================= IF ( KEEP(54) .eq. 0 ) THEN C { C ================================================ C FIRST CASE : MATRIX IS NOT INITIALLY DISTRIBUTED C ================================================ C A small integer workspace is needed to C send the arrowheads. IF ( id%MYID .eq. MASTER ) THEN #if defined(LARGEMATRICES) ALLOCATE (WK(LWK),stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) write(6,*) ' PB1 ALLOC LARGEMAT' ENDIF #endif ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 IF ( id%MYID .eq. MASTER ) THEN C C -------------------------------- C MASTER sends arowheads using the C global communicator with ranks C also in global communicator C IWK is used as temporary C workspace of size N. C -------------------------------- NBRECORDS = KEEP(39) IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF #if defined(LARGEMATRICES) CALL DMUMPS_FACTO_SEND_ARROWHEADS(id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), id%SYM_PERM(1), & LSCAL, id%COLSCA(1), id%ROWSCA(1), & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), & NBRECORDS, & id%COMM, idintr%root, idintr%roota, KEEP,id%KEEP8, & id%FILS(1), & & INTARR(1), id%KEEP8(27), DBLARR(1), id%KEEP8(26), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & id%FRERE_STEPS(1), id%STEP(1), WK(1), LWK, & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & id%CANDIDATES(1,1), id%ICNTL(1), id%INFO(1) ) C write(6,*) '!!! A,IRN,JCN are freed during factorization ' DEALLOCATE (id%A) NULLIFY(id%A) DEALLOCATE (id%IRN) NULLIFY (id%IRN) DEALLOCATE (id%JCN) NULLIFY (id%JCN) IF (.NOT.WK_USER_PROVIDED) THEN IF (EARLYT3ROOTINS) THEN CALL DMUMPS_ALLOC_S_WORKSPACE(id%S, MAXS, IERR, & KEEP(430), KEEP(35)) id%KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXS NULLIFY(id%S) id%KEEP8(23)=0_8 write(6,*) ' PB2 ALLOC LARGEMAT',MAXS CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ELSE id%S => id%WK_USER(1:id%KEEP8(24)) ENDIF IF (EARLYT3ROOTINS) THEN id%S(MAXS-LWK+1_8:MAXS) = WK(1_8:LWK) ENDIF DEALLOCATE (WK) #else CALL DMUMPS_FACTO_SEND_ARROWHEADS(id%N, id%KEEP8(28), & id%A(1), id%IRN(1), id%JCN(1), id%SYM_PERM(1), & LSCAL, id%COLSCA(1), id%ROWSCA(1), & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), & NBRECORDS, & id%COMM, idintr%root, idintr%roota, KEEP(1),id%KEEP8(1), & id%FILS(1), & & INTARR(1), id%KEEP8(27), DBLARR(1), id%KEEP8(26), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & id%FRERE_STEPS(1), id%STEP(1), S_PTR_ARG(1), MAXS_ARG, & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & id%CANDIDATES(1,1), id%ICNTL(1), id%INFO(1) ) #endif ELSE NBRECORDS = KEEP(39) IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF CALL DMUMPS_FACTO_RECV_ARROWHD2( id%N, & DBLARR(1), id%KEEP8(26), & INTARR(1), id%KEEP8(27), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & KEEP( 1 ), id%KEEP8(1), id%FILS(1), id%MYID, id%COMM, & NBRECORDS, & & S_PTR_ARG(1), MAXS_ARG, & idintr%root, idintr%roota, & id%PROCNODE_STEPS(1), id%NSLAVES, & id%SYM_PERM(1), id%FRERE_STEPS(1), id%STEP(1), & id%ICNTL(1), id%INFO(1) ) ENDIF C } ELSE C { C ============================================= C SECOND CASE : MATRIX IS INITIALLY DISTRIBUTED C ============================================= C Timing on master. IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIME) END IF IF ( I_AM_SLAVE ) THEN C { C --------------------------------------------------- C In order to have possibly IRN_loc/JCN_loc/A_loc C of size 0, avoid to pass them inside REDISTRIBUTION C and pass id instead C NZ_locMAX8 gives as a maximum buffer size (send/recv) used C an upper bound to limit buffers on small matrices C --------------------------------------------------- CALL MPI_ALLREDUCE(id%KEEP8(29), NZ_locMAX8, 1, MPI_INTEGER8, & MPI_MAX, id%COMM_NODES, IERR) NBRECORDS = KEEP(39) IF (NZ_locMAX8 .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(NZ_locMAX8) ENDIF CALL DMUMPS_REDISTRIBUTION( id%N, & id%KEEP8(29), & id, & DBLARR(1), id%KEEP8(26), INTARR(1), & id%KEEP8(27), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & id%FILS(1), & KEEP(1), id%KEEP8(1), id%MYID_NODES, & id%COMM_NODES, NBRECORDS, & S_PTR_ARG(1), MAXS_ARG, idintr%root, idintr%roota, & id%PROCNODE_STEPS(1), & id%NSLAVES, id%SYM_PERM(1), id%STEP(1), & id%ICNTL(1), id%INFO(1), NSEND8, NLOCAL8, & id%ISTEP_TO_INIV2(1), & id%CANDIDATES(1,1) ) IF ( ( KEEP(52).EQ.7 ).OR. (KEEP(52).EQ.8) ) THEN C ------------------------------------------------- C In that case, scaling arrays have been allocated C on all processors. They were useful for matrix C distribution. But we now really only need them C on the host. In case of distributed solution, we C will have to broadcast either ROWSCA or COLSCA C (depending on MTYPE) but this is done later. C C In other words, on exit from the factorization, C we want to have scaling arrays available only C on the host. C ------------------------------------------------- IF ( id%MYID > 0 ) THEN IF (associated(id%ROWSCA)) THEN DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF IF (associated(id%COLSCA)) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ENDIF ENDIF ENDIF #if defined(LARGEMATRICES) C deallocate id%IRN_loc, id%JCN(loc) to free extra space C Note that in this case IRN_loc cannot be used C anymore during the solve phase for IR and Error analysis. IF (associated(id%IRN_loc)) THEN DEALLOCATE(id%IRN_loc) NULLIFY(id%IRN_loc) ENDIF IF (associated(id%JCN_loc)) THEN DEALLOCATE(id%JCN_loc) NULLIFY(id%JCN_loc) ENDIF IF (associated(id%A_loc)) THEN DEALLOCATE(id%A_loc) NULLIFY(id%A_loc) ENDIF write(6,*) ' Warning :', & ' id%A_loc, IRN_loc, JCN_loc deallocated !!! ' #endif IF (PROK) THEN WRITE(MP,120) NLOCAL8, NSEND8 END IF C } END IF ! I_AM_SLAVE C ------------------------- C Check for possible errors C ------------------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN C ------------------------------ C The host is not working -> had C no data from initial matrix C ------------------------------ NSEND8 = 0_8 NLOCAL8 = 0_8 END IF C -------------------------- C Put into some info/infog ? C -------------------------- CALL MPI_REDUCE( NSEND8, NSEND_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( NLOCAL8, NLOCAL_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN WRITE(MPG,125) NLOCAL_TOT8, NSEND_TOT8 END IF C } ENDIF ! distributed matrix C } ENDIF ! "old" multithreaded algorithm C } ELSE C { C ------------------- C Matrix is elemental, C provided on the C master only C ------------------- IF ( id%MYID.eq.MASTER) & CALL DMUMPS_MAXELT_SIZE( id%ELTPTR(1), & id%NELT, & MAXELT_SIZE ) C C Perform the distribution of the elements. C A this point, C PTRAIW/PTRARW have been computed. C INTARR/DBLARR have been allocated C ELTPROC gives the mapping of elements C CALL DMUMPS_ELT_DISTRIB( id%N, id%NELT, id%KEEP8(30), & id%COMM, id%MYID, & id%NSLAVES, id%PTRAR(1), & id%PTRAR(id%NELT+2), & INTARR(1), DBLARR(1), id%KEEP8(27), id%KEEP8(26), & id%KEEP(1), id%KEEP8(1), MAXELT_SIZE, & id%FRTPTR(1), id%FRTELT(1), & S_PTR_ARG(1), MAXS_ARG, id%FILS(1), & id, idintr%root, idintr%roota ) C ---------------- C Broadcast errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C } END IF ! Element entry C ------------------------ C Time the redistribution: C ------------------------ IF ( id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIME) id%DKEEP(93) = TIME IF (PROKG) WRITE(MPG,160) id%DKEEP(93) END IF C ------------------------------------- C Small memory optimizaiton: we can now C free RG2L on the non working host, C ------------------------------------- IF (id%KEEP(38) .NE. 0 .AND. .NOT. I_AM_SLAVE) THEN IF (associated(idintr%root%RG2L)) THEN DEALLOCATE(idintr%root%RG2L) NULLIFY (idintr%root%RG2L) ENDIF ENDIF IF ( KEEP(400) .GT. 0 .AND. KEEP(369).EQ.0) THEN C{ Check if number of threads is consistent with C the one used during analysis for all procs C Note that if KEEP(369)>0 C KEEP(400) was set based on C KEEP(369) and KEEP(381) so that C omp_set_num_threads(KEEP(400)) will be called C explicitly before L0_OMP section C and KEEP(400) cannot be check here in this way NOMP=1 !$ NOMP = omp_get_max_threads() IF ( NOMP .NE. KEEP(400) ) THEN id%INFO(1)=-58 id%INFO(2)=KEEP(400) IF (LPOK) WRITE(LP,'(A,A,I5,A,I5)') &" FAILURE DETECTED IN FACTORIZATION: #threads for multithreaded", &" tree parallelism changed from",KEEP(400)," at analysis to", & NOMP ENDIF C} ENDIF C error check done outside previous if bloc C because KEEP(369) might be 0 on some and nonzero on some proc CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C C TIMINGS: C Next line: elapsed time for factorization IF (id%MYID.EQ.MASTER) CALL MUMPS_SECDEB(TIME) C C Allocate buffers on the workers C =============================== C IF ( I_AM_SLAVE ) THEN C C Some buffers are required to pack/unpack data and for C receiving MPI messages. C For packing/unpacking : the buffer must be large C enough to send several messages while receives might not C be posted yet. C It is assumed that the size of an integer is held in KEEP(34) C while the size of a complex is held in KEEP(35). C BUFR and LBUFR are declared of type integer, since byte is not C a standard datatype. C We now use KEEP(43) or KEEP(379) and KEEP(44) or KEEP(380) C as estimated at analysis to allocate appropriate buffer sizes C C Receive buffer C -------------- IF (KEEP(486).NE.0) THEN DMUMPS_LBUFR_BYTES8 = int(KEEP( 380 ),8) * int(KEEP(35),8) ELSE DMUMPS_LBUFR_BYTES8 = int(KEEP( 44 ),8) * int(KEEP(35),8) ENDIF C --------------------------------------- C Ensure a reasonable minimal buffer size C --------------------------------------- IF (KEEP(72).NE.1) THEN C ensure minimum size for small problems DMUMPS_LBUFR_BYTES8 = max( DMUMPS_LBUFR_BYTES8, & 200000_8 ) ENDIF C C If there is pivoting, size of the message might still increase. C We use a relaxation (so called PERLU) to increase the estimate. C C Note: PERLU is a global estimate for pivoting. C It may happen that one large contribution block size is increased C by more than that. C This is why we use an extra factor 2 relaxation coefficient for C the relaxation of C the reception buffer in the case where pivoting is allowed. C A more dynamic strategy could be applied: if message to C be received is larger than expected, reallocate a larger C buffer. (But this won't work with IRECV.) C Finally, one may want (as we are currently doing it for C most messages) C to cut large messages into a series of smaller ones. C IF (KEEP(48).EQ.5) THEN MIN_PERLU = 2 ELSE MIN_PERLU = 0 ENDIF C IF (KEEP(72).NE.1) THEN DMUMPS_LBUFR_BYTES8 = DMUMPS_LBUFR_BYTES8 & + int( dble(max(PERLU/2,MIN_PERLU))* & dble(DMUMPS_LBUFR_BYTES8)/100D0, 8) ELSE C on small pb we want to relax buffers C for pivoting DMUMPS_LBUFR_BYTES8 = DMUMPS_LBUFR_BYTES8 & + int( dble(max(PERLU,MIN_PERLU))* & dble(DMUMPS_LBUFR_BYTES8)/100D0, 8) ENDIF DMUMPS_LBUFR_BYTES8 = min(DMUMPS_LBUFR_BYTES8, & int(huge(I4)-100,8)) DMUMPS_LBUFR_BYTES = int( DMUMPS_LBUFR_BYTES8 ) C DMUMPS_LBUFR is the size of the buffer as a number of integers, C we round DMUMPS_LBUFR (size in #integers) above to have at least C DMUMPS_LBUFR_BYTES available in the buffer. DMUMPS_LBUFR = (DMUMPS_LBUFR_BYTES+KEEP(34)-1)/KEEP(34) C Finally, make DMUMPS_LBUFR_BYTES a multiple of KEEP(34) by setting C DMUMPS_LBUFR_BYTES to the number of bytes that will be allocated DMUMPS_LBUFR_BYTES = DMUMPS_LBUFR*KEEP(34) IF (KEEP(48)==5) THEN C Since the buffer is going to be allocated, use C it as the constraint for memory/granularity C in hybrid scheduler C id%KEEP8(21) = id%KEEP8(22) + & int( dble(max(PERLU/2,MIN_PERLU))* & dble(id%KEEP8(22))/100D0,8) ENDIF C C Now estimate the size for the buffer for asynchronous C sends of contribution blocks (so called CB). We want to be able to send at C least KEEP(213)/100 (two in general) messages at the C same time. C C Send buffer C ----------- IF (KEEP(486).NE.0) THEN DMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 * & dble(KEEP(379)) * dble(KEEP(35)), 8 ) ELSE DMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 * & dble(KEEP(43)) * dble(KEEP(35)), 8 ) ENDIF IF (KEEP(72).NE.1) THEN C ensure minimum size for small problems DMUMPS_LBUF8 = max( DMUMPS_LBUF8, 200000_8 ) DMUMPS_LBUF8 = DMUMPS_LBUF8 & + int( dble(max(PERLU/2,MIN_PERLU))* & dble(DMUMPS_LBUF8)/100D0, 8) ELSE C for very small pb force extra relaxation DMUMPS_LBUF8 = DMUMPS_LBUF8 & + int( dble(max(PERLU,MIN_PERLU))* & dble(DMUMPS_LBUF8)/100D0, 8) ENDIF C Make DMUMPS_LBUF8 small enough to be stored in a standard integer DMUMPS_LBUF8 = min(DMUMPS_LBUF8, int(huge(I4)-100,8)) C C No reason to have send buffer smaller than receive buffer. C This should never occur with the formulas above but just C in case: DMUMPS_LBUF8 = max(DMUMPS_LBUF8, DMUMPS_LBUFR_BYTES8+3*KEEP(34)) DMUMPS_LBUF = int(DMUMPS_LBUF8) IF(id%KEEP(48).EQ.4)THEN DMUMPS_LBUFR_BYTES=DMUMPS_LBUFR_BYTES*5 DMUMPS_LBUF=DMUMPS_LBUF*5 ENDIF C C Estimate size of buffer for small messages C Each node can send ( NSLAVES - 1 ) messages to (NSLAVES-1) nodes C C KEEP(56) is the number of nodes of level II. C Messages will be sent for the symmetric case C for synchronisation issues. C C We take an upperbound C DMUMPS_LBUF_INT = ( KEEP(56) + id%NSLAVES * id%NSLAVES ) * 5 & * KEEP(34) IF ( KEEP( 38 ) .NE. 0 ) THEN C C KKKK = MUMPS_PROCNODE( id%PROCNODE_STEPS(id%STEP(KEEP(38))), & id%KEEP(199) ) IF ( KKKK .EQ. id%MYID_NODES ) THEN DMUMPS_LBUF_INT = DMUMPS_LBUF_INT + 4 * KEEP(34) * & ( id%NSLAVES + id%NE_STEPS(id%STEP(KEEP(38))) & + min(KEEP(56), id%NE_STEPS(id%STEP(KEEP(38)))) * id%NSLAVES & ) END IF END IF C At this point, DMUMPS_LBUFR_BYTES, DMUMPS_LBUF C and DMUMPS_LBUF_INT have been computed (all C are in numbers of bytes). IF ( PROK ) THEN WRITE( MP, 9999 ) DMUMPS_LBUFR_BYTES, & DMUMPS_LBUF, DMUMPS_LBUF_INT ELSE IF (PROKG) THEN WRITE( MPG, 9999 ) DMUMPS_LBUFR_BYTES, & DMUMPS_LBUF, DMUMPS_LBUF_INT ENDIF END IF 9999 FORMAT( /,' Allocated buffers',/,' ------------------',/, & ' Size of reception buffer in bytes ...... = ', I12, & /, & ' Size of async. emission buffer (bytes).. = ', I12,/, & ' Small emission buffer (bytes) .......... = ', I12) C -------------------------- C Allocate small send buffer C required for DMUMPS_FAC_B C -------------------------- CALL MUMPS_BUF_ALLOC_SMALL_BUF( DMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)= -13 C convert to size in integer id%INFO(2)= DMUMPS_LBUF_INT id%INFO(2)= (DMUMPS_LBUF_INT+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Allocation error in MUMPS_BUF_ALLOC_SMALL_BUF' & ,id%INFO(2) ENDIF GO TO 110 END IF C C -------------------------------------- C Allocate reception buffer on all procs C This is done now. C -------------------------------------- ALLOCATE( BUFR( DMUMPS_LBUFR ),stat=IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = DMUMPS_LBUFR IF (LPOK) THEN WRITE(LP,*) & ': Allocation error for BUFR(', DMUMPS_LBUFR, & ') on MPI process',id%MYID ENDIF GO TO 110 END IF C ----------------------------------------- C Estimate MAXIS. IS will be allocated in C DMUMPS_FAC_B. It will contain factors and C contribution blocks integer information C ----------------------------------------- C Relax integer workspace based on PERLU PERLU = KEEP( 12 ) IF (KEEP(201).GT.0) THEN C OOC panel or non panel (note that C KEEP(15)=KEEP(225) if non panel) MAXIS_ESTIM = KEEP(225) ELSE C In-core or reals for factors not stored MAXIS_ESTIM = KEEP(15) ENDIF MAXIS = max( 1, int( min( int(huge(MAXIS),8), & int(MAXIS_ESTIM,8) + 3_8 * max(int(PERLU,8),10_8) * & ( int(MAXIS_ESTIM,8) / 100_8 + 1_8 ) & ) ! min & ) ! int & ) !max C ---------------------------- C Allocate PTLUST_S and PTRFAC C They will be used to access C factors in the solve phase. C They are also needed for C DMUMPS_FAC_L0_OMP. C ---------------------------- ALLOCATE( id%PTLUST_S( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(28) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%PTLUST_S(', id%KEEP(28),')' ENDIF NULLIFY(id%PTLUST_S) GOTO 110 END IF ALLOCATE( id%PTRFAC( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(28) NULLIFY(id%PTRFAC) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%PTRFAC(', id%KEEP(28),')' ENDIF GOTO 110 END IF C ----------------------------- C Reserve temporary workspace : C IPOOL, PTRWB, ITLOC, PTRIST C PTRWB will be subdivided again C in routine DMUMPS_FAC_B C ----------------------------- PTRIST = 1 PTRWB = PTRIST + id%KEEP(28) ITLOC = PTRWB + 2 * id%KEEP(28) C Fwd in facto: ITLOC of size id%N + id%KEEP(253) IPOOL = ITLOC + id%N + id%KEEP(253) C C -------------------------------- C NA(1) is an upperbound for LPOOL C -------------------------------- C Structure of the pool: C ____________________________________________________ C | Subtrees | | Top nodes | 1 2 3 | C ---------------------------------------------------- LPOOL = MUMPS_GET_POOL_LENGTH(id%NA(1), id%KEEP(1),id%KEEP8(1)) LIWK = IPOOL + LPOOL - 1 ALLOCATE( IWK( IPOOL + LPOOL - 1 ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=IPOOL + LPOOL - 1 IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for IWK(',IPOOL+LPOOL-1,')' ENDIF GOTO 110 END IF LIWK8 = 2 * id%KEEP(28) ALLOCATE(IWK8( 2 * id%KEEP(28)), stat = IERR) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=2 * id%KEEP(28) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for IWKB(', 2*id%KEEP(28),')' ENDIF GOTO 110 END IF C C Return to SPMD C ENDIF C 110 CONTINUE C ---------------- C Broadcast errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C IF ( I_AM_SLAVE ) THEN C Store size of receive buffers in DMUMPS_LBUF module CALL MUMPS_BUF_DIST_IRECV_SIZE( DMUMPS_LBUFR_BYTES ) IF (PROK) THEN WRITE( MP, 170 ) MAXS, MAXIS, MAXS_BASE8, KEEP(15), & id%KEEP8(26), id%KEEP8(27), id%KEEP8(11), KEEP(26), KEEP(27) ENDIF END IF C =============================================================== C Before calling the main driver, DMUMPS_FAC_B, C some statistics should be initialized to 0, C even on the host node because they will be C used in REDUCE operations afterwards. C -------------------------------------------- C Size of factors written. It will be set to POSFAC in C IC, otherwise we accumulate written factors in it. id%KEEP8(31)= 0_8 C Size of factors under L0 will be returned C in id%KEEP8(64), not included in KEEP8(31)) C Number of entries in factors id%KEEP8(10) = 0_8 C KEEP8(8) will hold the volume of extra copies due to C in-place stacking in fac_mem_stack.F id%KEEP8(8)=0_8 id%INFO(9:14)=0 RINFO(2:3)=ZERO IF ( I_AM_SLAVE ) THEN C ------------------------------------ C Call effective factorization routine C ------------------------------------ IF ( KEEP(55) .eq. 0 ) THEN LDPTRAR = 1 ! PTRAR no longer used (of size 2) ELSE LDPTRAR = id%NELT + 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN NELT_arg = id%NELT ELSE C ------------------------------ C Use size 1 to avoid complaints C when using check bound options C ------------------------------ NELT_arg = 1 END IF ENDIF IF (I_AM_SLAVE) THEN IF (associated(id%L0_OMP_MAPPING)) & DEALLOCATE(id%L0_OMP_MAPPING) IF (KEEP(400) .GT. 0) THEN id%LL0_OMP_MAPPING = KEEP(28) ELSE id%LL0_OMP_MAPPING = 1 ENDIF ALLOCATE(id%L0_OMP_MAPPING(id%LL0_OMP_MAPPING), stat=allocok) IF ( allocok > 0) THEN write(*,*) "Problem allocating L0_OMP_MAPPING", & IERR, KEEP(28) GOTO 115 ENDIF IF (KEEP(400) .GT. 0) THEN id%LL0_OMP_FACTORS = KEEP(400) ELSE id%LL0_OMP_FACTORS = 1 ENDIF ALLOCATE(idintr%L0_OMP_FACTORS(id%LL0_OMP_FACTORS), & stat = allocok) IF (allocok > 0) THEN id%INFO(1)=-7 id%INFO(2)=NB_THREADS GOTO 115 ENDIF CALL DMUMPS_INIT_L0_OMP_FACTORS(idintr%L0_OMP_FACTORS) ENDIF 115 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C Compute DKEEP(17) AVG_FLOPS = RINFOG(1)/(dble(id%NSLAVES)) id%DKEEP(17) = max ( id%DKEEP(18), AVG_FLOPS/dble(50) ) & IF (PROK.AND.id%MYID.EQ.MASTER) THEN IF (id%NSLAVES.LE.1) THEN WRITE(MP,'(/A,A,1PD10.3)') &' Start factorization with total', &' estimated flops (RINFOG(1)) = ', & RINFOG(1) ELSE WRITE(MP,'(/A,A,1PD10.3,A,1PD10.3)') &' Start factorization with total', &' estimated flops RINFOG(1) / Average per MPI proc = ', & RINFOG(1), ' / ', AVG_FLOPS ENDIF ENDIF IF (I_AM_SLAVE) THEN C IS/S pointers passed to DMUMPS_FAC_B with C implicit interface through intermediate C structure S_IS_POINTERS. IS will be allocated C during DMUMPS_FAC_B. C In case of L0OMP, id%IS and id%S are allocated during C DMUMPS_FAC_B, and only after L0OMP nodes are processed, C in order to limit the global memory peak. S_IS_POINTERS%IW => id%IS; NULLIFY(id%IS) S_IS_POINTERS%A => id%S ; NULLIFY(id%S) CALL DMUMPS_FAC_B(id%N,S_IS_POINTERS,MAXS,MAXIS,id%SYM_PERM(1), & id%NA(1),id%LNA,id%NE_STEPS(1),id%ND_STEPS(1), id%FILS(1), & id%STEP(1),id%FRERE_STEPS(1),id%DAD_STEPS(1),id%CANDIDATES(1,1), & id%ISTEP_TO_INIV2(1),id%TAB_POS_IN_PERE(1,1), id%PTRAR(1), &LDPTRAR,id%PTR8ARR(1),id%NINCOLARR(1),id%NINROWARR(1),id%PTRDEBARR & (1), IWK(PTRIST),id%PTLUST_S(1),id%PTRFAC(1),IWK(PTRWB),IWK8, & IWK(ITLOC),RHS_MUMPS(1),IWK(IPOOL),LPOOL,CNTL1,ICNTL(1), & id%INFO(1), RINFO(1),KEEP(1),id%KEEP8(1),id%PROCNODE_STEPS(1), & id%NSLAVES,id%COMM_NODES,id%MYID,id%MYID_NODES,BUFR,DMUMPS_LBUFR & , DMUMPS_LBUFR_BYTES, DMUMPS_LBUF, INTARR(1), DBLARR(1), & idintr%root, idintr%roota, NELT_arg, id%FRTPTR(1), id%FRTELT(1), & id%COMM_LOAD,id%ASS_IRECV,SEUIL,SEUIL_LDLT_NIV2,id%MEM_DIST(0), & id%DKEEP(1), PIVNUL_LIST_STRUCT, id%LRGROUPS(1) & ,id%IPOOL_B_L0_OMP(1),id%LPOOL_B_L0_OMP, & id%IPOOL_A_L0_OMP(1),id%LPOOL_A_L0_OMP,id%L_VIRT_L0_OMP, & id%VIRT_L0_OMP(1), id%VIRT_L0_OMP_MAPPING(1),id%L_PHYS_L0_OMP, & id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1), id%PTR_LEAFS_L0_OMP(1), & id%L0_OMP_MAPPING(1),id%LL0_OMP_MAPPING, id%THREAD_LA, & idintr%L0_OMP_FACTORS(1), id%LL0_OMP_FACTORS, & id%I4_L0_OMP(1,1), size(id%I4_L0_OMP,1), size(id%I4_L0_OMP,2), & id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), size(id%I8_L0_OMP,2) & ) id%IS => S_IS_POINTERS%IW; NULLIFY(S_IS_POINTERS%IW) id%S => S_IS_POINTERS%A ; NULLIFY(S_IS_POINTERS%A) C C ------------------------------ C Deallocate temporary workspace C ------------------------------ DEALLOCATE( IWK ) DEALLOCATE( IWK8 ) ENDIF C Fwd in facto: free RHS_MUMPS in case it was allocated. IF (RHS_MUMPS_ALLOCATED) THEN DEALLOCATE(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. ENDIF NULLIFY(RHS_MUMPS) C --------------------------------- C Free some workspace corresponding C to the original matrix in C arrowhead or elemental format. C ----- C Note : DBLARR may be a pointer C in case of element-entry. C --------------------------------- IF (allocated( INTARR )) DEALLOCATE( INTARR ) IF (DBLARR_ALLOCATED) THEN DEALLOCATE(DBLARR) DBLARR_ALLOCATED=.FALSE. ENDIF NULLIFY(DBLARR) C We also free RG2L now IF ( KEEP(38) .NE. 0) THEN IF (associated(idintr%root%RG2L)) THEN DEALLOCATE(idintr%root%RG2L) NULLIFY(idintr%root%RG2L) ENDIF ENDIF C C Memory statistics C ----------------------------------- C If QR (Keep(19)) is not zero, and if C the host does not have the information C (ie is not slave), send information C computed on the slaves during facto C to the host. C ----------------------------------- C Note the KEEP(17), KEEP(143) have been bcasted during fac_par_m IF ( KEEP(19) .NE. 0 ) THEN IF ( KEEP(46) .NE. 1 ) THEN C Host was not working during facto_root C Send him the information IF ( id%MYID .eq. MASTER ) THEN CALL MPI_RECV( KEEP(17), 1, MPI_INTEGER, 1, DEFIC_TAG, & id%COMM, STATUS, IERR ) CALL MPI_RECV( KEEP(143), 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 ) CALL MPI_SEND( KEEP(143), 1, MPI_INTEGER, 0, DEFIC_TAG, & id%COMM, IERR ) END IF END IF END IF C -------------------------------- C Deallocate communication buffers C They will be reallocated C in the solve. C -------------------------------- IF (allocated(BUFR)) DEALLOCATE(BUFR) CALL MUMPS_BUF_DEALL_SMALL_BUF( IERR ) C C Check for errors. C After DMUMPS_FAC_B every slave is aware of an error. C The call below informs the master, in case it is not C included in the computations. CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C CALL DMUMPS_EXTRACT_SCHUR_REDRHS(id,idintr) C return to user singular values IF (id%KEEP(19) .NE.0) THEN CALL DMUMPS_EXTRACT_SINGULAR_VALUES(id,idintr) ENDIF IF (KEEP(201) .GT. 0) THEN END IF IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIME) id%DKEEP(94)=TIME IF (KEEP(400).GT.0) THEN C Facto time above L0_OMP = total time - facto time under L0_OMP id%DKEEP(96)=id%DKEEP(94)-id%DKEEP(95) ENDIF ENDIF C Time to process root node: CALL MPI_REDUCE( id%DKEEP(99), TMPTIME, 1, & MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR ) id%DKEEP(99)=TMPTIME C ===================================================================== C COMPUTE MEMORY ALLOCATED BY MUMPS, INFO(16) C --------------------------------------------- MEM_EFF_ALLOCATED = .TRUE. CALL DMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & BLR_STRAT, .TRUE., TOTAL_BYTES, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .FALSE. ! UNDER_L0_OMP & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN ! L0 activated CALL DMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .TRUE., id%KEEP(201), & BLR_STRAT, .TRUE., TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .TRUE. ! UNDER_L0_OMP & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF IF (id%KEEP8(24).NE.0) THEN C WK_USER is not part of memory allocated by MUMPS C and is not counted, id%KEEP8(23) should be zero id%INFO(16) = TOTAL_MBYTES ELSE C Note that even for the case of ICNTL(23)>0 C we report here the memory effectively allocated C that can be smaller than ICNTL(23) ! id%INFO(16) = TOTAL_MBYTES ENDIF C ---------------------------------------------------- C Centralize memory statistics on the host C id%INFOG(18) = size of mem in Mbytes for facto, C for the processor using largest memory C id%INFOG(19) = size of mem in Mbytes for facto, C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(16), id%INFOG(18), IRANK ) CALL DMUMPS_PRINT_ALLOCATED_MEM( PROK, PROKG, PRINT_MAXAVG, & MP, MPG, id%INFO(16), id%INFOG(18), id%INFOG(19), & id%NSLAVES, IRANK, & id%KEEP(1) ) C If WK_USER is provided, this memory excludes WK_USER IF (PROK ) THEN WRITE(MP,'(A,I12) ') & ' ** Eff. min. Space MBYTES for facto (INFO(16)):', & TOTAL_MBYTES ENDIF C ========================(INFO(16) RELATED)====================== C --------------------------------------- C COMPUTE EFFECTIVE MEMORY USED INFO(22) C --------------------------------------- PERLU_ON = .TRUE. MEM_EFF_ALLOCATED = .FALSE. CALL DMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .FALSE. ! UNDER_L0_OMP & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN ! L0 activated CALL DMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .TRUE., id%KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .TRUE. ! UNDER_L0_OMP & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF C -- TOTAL_BYTES and TOTAL_MBYTES includes both static C -- (MAXS) and BLR structures computed as the SUM of the PEAKS C -- (KEEP8(67) + KEEP8(70)) id%KEEP8(7) = TOTAL_BYTES C -- INFO(22) holds the effective space (in Mbytes) used by MUMPS C -- (it includes part of WK_USER used if provided by user) id%INFO(22) = TOTAL_MBYTES C ---------------------------------------------------- C Centralize memory statistics on the host C INFOG(21) = size of effective mem (Mbytes) for facto, C for the processor using largest memory C INFOG(22) = size of effective mem (Mbytes) for facto, C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(22), id%INFOG(21), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' ** Memory effectively used, max in Mbytes (INFOG(21)):', & id%INFOG(21) ENDIF WRITE( MPG,'(A,I12) ') & ' ** Memory effectively used, total in Mbytes (INFOG(22)):', & id%INFOG(22) END IF SUM_INFO22_THIS_NODE=0 CALL MPI_REDUCE( id%INFO(22), SUM_INFO22_THIS_NODE, 1, & MPI_INTEGER, & MPI_SUM, 0, id%KEEP(411), IERR ) CALL MPI_REDUCE( SUM_INFO22_THIS_NODE, MAX_SUM_INFO22_THIS_NODE, & 1, MPI_INTEGER, MPI_MAX, 0, id%COMM, IERR ) IF (PROKG .AND. PRINT_NODEINFO) THEN WRITE(MPG,'(A,I12)') & ' ** Max. effective space per compute node, in MBytes :', & MAX_SUM_INFO22_THIS_NODE ENDIF C IF (I_AM_SLAVE) THEN K67 = id%KEEP8(67) K68 = id%KEEP8(68) K70 = id%KEEP8(70) K74 = id%KEEP8(74) K75 = id%KEEP8(75) ELSE K67 = 0_8 K68 = 0_8 K70 = 0_8 K74 = 0_8 K75 = 0_8 ENDIF C -- Save the number of entries effectively used C in main working array S CALL MUMPS_SETI8TOI4(K67,id%INFO(21)) C IF (id%NPROCS .GT. 1 .AND. id%KEEP(50) .NE. 0) THEN CALL MPI_REDUCE( id%KEEP8(131), id%KEEP8(132), 1, MPI_INTEGER8, & MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%KEEP8(131), id%KEEP8(133), 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%KEEP(175), id%KEEP(176), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR ) ENDIF C IF (KEEP(400) .GT.0 ) THEN IF (.NOT. I_AM_SLAVE) THEN id%DKEEP(95) = 0.0D0 id%DKEEP(16) = 0.0D0 ENDIF IF (id%NPROCS .GT. 1) THEN C Compute average and max (across MPI's) CALL MPI_REDUCE(id%DKEEP(95), TMPTIME, 1, & MPI_DOUBLE_PRECISION, MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) TIMEAVG = TMPTIME CALL MPI_REDUCE(id%DKEEP(16), TMPFLOP, 1, & MPI_DOUBLE_PRECISION, MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) FLOPAVG = TMPFLOP IF (id%MYID.EQ.MASTER) THEN TIMEAVG = TIMEAVG / id%NSLAVES FLOPAVG = FLOPAVG / id%NSLAVES ENDIF CALL MPI_REDUCE(id%DKEEP(95), TIMEMAX, 1, & MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR) CALL MPI_REDUCE(id%DKEEP(16), FLOPMAX, 1, & MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR) C (PROKG may only be true on master) IF ( PROKG ) THEN WRITE(MPG,190) FLOPAVG, FLOPMAX WRITE(MPG,188) TIMEAVG, TIMEMAX ENDIF ELSE C Print DKEEP(95) directly without reduction IF ( PROKG ) THEN WRITE(MPG,189) id%DKEEP(16) WRITE(MPG,187) id%DKEEP(95) ENDIF ENDIF ENDIF IF ( PROKG ) THEN IF ( ( KEEP(38).NE.0 .OR. KEEP(20).NE.0 ) .AND. & KEEP(60) .EQ. 0 ) THEN WRITE(MPG,186) id%DKEEP(99) ENDIF C Elapsed time for factorization: IF (id%INFO(1) .GE.0) THEN WRITE(MPG,180) id%DKEEP(94) ELSE WRITE(MPG,185) id%DKEEP(94) ENDIF ENDIF C C Sum RINFO(2) : total number of flops for assemblies C Sum RINFO(3) : total number of flops for eliminations C Initialize RINFO(4) in case BLR was not activated RINFO(4) = RINFO(3) C C Should work even if the master does some work C CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) C Reduce needed to dimension small working array C on all procs during DMUMPS_GATHER_SOLUTION KEEP(247) = 0 CALL MPI_REDUCE( KEEP(246), KEEP(247), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR) C C Reduce compression times: get max compression times CALL MPI_REDUCE( id%DKEEP(97), id%DKEEP(98), 1, & MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR) C CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MUMPS_REDUCEI8( id%KEEP8(31)+id%KEEP8(64),id%KEEP8(6), & MPI_SUM, MASTER, id%COMM ) C IF (id%MYID.EQ.0) THEN C In MegaBytes RINFOG(16) = dble(id%KEEP8(6)*int(KEEP(35),8))/dble(1D6) IF (KEEP(201).LE.0) THEN RINFOG(16) = ZERO ENDIF ENDIF CALL MUMPS_REDUCEI8( id%KEEP8(48),id%KEEP8(148), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(148), INFOG(9)) C CALL MPI_REDUCE( int(id%INFO(10),8), id%KEEP8(128), & 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SETI8TOI4(id%KEEP8(128), id%INFOG(10)) ENDIF C Use MPI_MAX for this one to get largest front size CALL MPI_ALLREDUCE( id%INFO(11), INFOG(11), 1, MPI_INTEGER, & MPI_MAX, id%COMM, IERR) C make maximum effective frontal size available on all procs C for solve phase C (Note that INFO(11) includes root size on root master) KEEP(133) = INFOG(11) CALL MPI_REDUCE( id%INFO(12), INFOG(12), 3, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( id%INFO(40), INFOG(50), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( KEEP(103), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(229) = INFOG(25) CALL MPI_REDUCE( KEEP(105), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(230) = INFOG(25) C id%INFO(25) = KEEP(98) CALL MPI_ALLREDUCE( id%INFO(25), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) C Extra copies due to in-place stacking CALL MUMPS_REDUCEI8( id%KEEP8(8), id%KEEP8(108), MPI_SUM, & MASTER, id%COMM ) C Entries in factors CALL MUMPS_SETI8TOI4(id%KEEP8(10), id%INFO(27)) CALL MUMPS_REDUCEI8( id%KEEP8(10),id%KEEP8(110), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(110), INFOG(29)) C Initialize INFO(28)/INFOG(35) in case BLR not activated id%INFO(28) = id%INFO(27) INFOG(35) = INFOG(29) C ============================== C LOW-RANK C ============================== IF ( KEEP(486) .NE. 0 ) THEN !LR is activated C Compute and Save local amount of flops in case of BLR RINFO(4) = dble(FLOP_FRFRONTS + FLOP_FACTO_FR - FLOP_LRGAIN & + FLOP_COMPRESS + FLOP_FRFRONTS) C C Compute and Save local number of entries in compressed factors C ITMP8 = id%KEEP8(10) - int(MRY_LU_LRGAIN,8) CALL MUMPS_SETI8TOI4( ITMP8, id%INFO(28)) C CALL MPI_REDUCE( MRY_LU_LRGAIN, TMP_MRY_LU_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_LU_FR, TMP_MRY_LU_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_CB_FR, TMP_MRY_CB_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_CB_LRGAIN, TMP_MRY_CB_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_LRGAIN, TMP_FLOP_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM_FR, TMP_FLOP_TRSM_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM_LR, TMP_FLOP_TRSM_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_FR, TMP_FLOP_UPDATE_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_LR, TMP_FLOP_UPDATE_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FRSWAP_COMPRESS, & TMP_FLOP_FRSWAP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_MIDBLK_COMPRESS, & TMP_FLOP_MIDBLK_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_LRLR3, TMP_FLOP_UPDATE_LRLR3 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(FLOP_ACCUM_COMPRESS, TMP_FLOP_ACCUM_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM, TMP_FLOP_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_PANEL, TMP_FLOP_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FRFRONTS, TMP_FLOP_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_COMPRESS, TMP_FLOP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_DECOMPRESS, TMP_FLOP_DECOMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_CB_COMPRESS, TMP_FLOP_CB_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_CB_DECOMPRESS,TMP_FLOP_CB_DECOMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FACTO_FR, TMP_FLOP_FACTO_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( CNT_NODES,TMP_CNT_NODES & , 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%NPROCS.GT.1) THEN FLOP_FACTO_LR = FLOP_FACTO_FR - FLOP_LRGAIN & + FLOP_COMPRESS + FLOP_FRFRONTS CALL MPI_REDUCE( FLOP_FACTO_LR, AVG_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN AVG_FLOP_FACTO_LR = AVG_FLOP_FACTO_LR/id%NPROCS ENDIF CALL MPI_REDUCE( FLOP_FACTO_LR, MIN_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FACTO_LR, MAX_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR) ENDIF ! NPROCS > 1 CALL MPI_REDUCE( TIME_UPDATE, TMP_TIME_UPDATE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR1, TMP_TIME_UPDATE_LRLR1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR2, TMP_TIME_UPDATE_LRLR2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR3, TMP_TIME_UPDATE_LRLR3 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_FRLR, TMP_TIME_UPDATE_FRLR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_FRFR, TMP_TIME_UPDATE_FRFR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DIAGCOPY, TMP_TIME_DIAGCOPY & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_COMPRESS,TMP_TIME_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_MIDBLK_COMPRESS, & TMP_TIME_MIDBLK_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRSWAP_COMPRESS, & TMP_TIME_FRSWAP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_CB_COMPRESS, TMP_TIME_CB_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP, TMP_TIME_DECOMP & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_UCFS, TMP_TIME_DECOMP_UCFS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LRASM_NIV1, TMP_TIME_LRASM_NIV1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_LRASM_LOCASM2, TMP_TIME_LRASM_LOCASM2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_LRASM_MAPLIG1, TMP_TIME_LRASM_MAPLIG1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_LRASM_CONTRIB2, TMP_TIME_LRASM_CONTRIB2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_FRASM_LOCASM2, TMP_TIME_FRASM_LOCASM2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_FRASM_MAPLIG1, TMP_TIME_FRASM_MAPLIG1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_FRASM_CONTRIB2, TMP_TIME_FRASM_CONTRIB2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_PANEL, TMP_TIME_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_I, TMP_TIME_FAC_I & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_MQ, TMP_TIME_FAC_MQ & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_SQ, TMP_TIME_FAC_SQ & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LRTRSM, TMP_TIME_LRTRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRTRSM, TMP_TIME_FRTRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRFRONTS, TMP_TIME_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LR_MODULE, TMP_TIME_LR_MODULE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN IF (id%NPROCS.GT.1) THEN C rename the stat variable so that COMPUTE_GLOBAL_GAINS can work for any C number of procs MRY_LU_FR = TMP_MRY_LU_FR MRY_LU_LRGAIN = TMP_MRY_LU_LRGAIN MRY_CB_FR = TMP_MRY_CB_FR MRY_CB_LRGAIN = TMP_MRY_CB_LRGAIN FLOP_LRGAIN = TMP_FLOP_LRGAIN FLOP_PANEL = TMP_FLOP_PANEL FLOP_TRSM = TMP_FLOP_TRSM FLOP_TRSM_FR = TMP_FLOP_TRSM_FR FLOP_TRSM_LR = TMP_FLOP_TRSM_LR FLOP_UPDATE_FR = TMP_FLOP_UPDATE_FR FLOP_UPDATE_LR = TMP_FLOP_UPDATE_LR FLOP_UPDATE_LRLR3 = TMP_FLOP_UPDATE_LRLR3 FLOP_COMPRESS = TMP_FLOP_COMPRESS FLOP_MIDBLK_COMPRESS = TMP_FLOP_MIDBLK_COMPRESS FLOP_FRSWAP_COMPRESS = TMP_FLOP_FRSWAP_COMPRESS FLOP_ACCUM_COMPRESS = TMP_FLOP_ACCUM_COMPRESS FLOP_CB_COMPRESS = TMP_FLOP_CB_COMPRESS FLOP_DECOMPRESS = TMP_FLOP_DECOMPRESS FLOP_CB_DECOMPRESS = TMP_FLOP_CB_DECOMPRESS FLOP_FRFRONTS = TMP_FLOP_FRFRONTS FLOP_FACTO_FR = TMP_FLOP_FACTO_FR CNT_NODES = TMP_CNT_NODES TIME_UPDATE = TMP_TIME_UPDATE /id%NPROCS TIME_UPDATE_LRLR1 = TMP_TIME_UPDATE_LRLR1 /id%NPROCS TIME_UPDATE_LRLR2 = TMP_TIME_UPDATE_LRLR2 /id%NPROCS TIME_UPDATE_LRLR3 = TMP_TIME_UPDATE_LRLR3 /id%NPROCS TIME_UPDATE_FRLR = TMP_TIME_UPDATE_FRLR /id%NPROCS TIME_UPDATE_FRFR = TMP_TIME_UPDATE_FRFR /id%NPROCS TIME_COMPRESS = TMP_TIME_COMPRESS /id%NPROCS TIME_MIDBLK_COMPRESS = TMP_TIME_MIDBLK_COMPRESS/id%NPROCS TIME_FRSWAP_COMPRESS = TMP_TIME_FRSWAP_COMPRESS/id%NPROCS TIME_DIAGCOPY = TMP_TIME_DIAGCOPY /id%NPROCS TIME_CB_COMPRESS = TMP_TIME_CB_COMPRESS /id%NPROCS TIME_PANEL = TMP_TIME_PANEL /id%NPROCS TIME_FAC_I = TMP_TIME_FAC_I /id%NPROCS TIME_FAC_MQ = TMP_TIME_FAC_MQ /id%NPROCS TIME_FAC_SQ = TMP_TIME_FAC_SQ /id%NPROCS TIME_LRTRSM = TMP_TIME_LRTRSM /id%NPROCS TIME_FRTRSM = TMP_TIME_FRTRSM /id%NPROCS TIME_FRFRONTS = TMP_TIME_FRFRONTS /id%NPROCS TIME_LR_MODULE = TMP_TIME_LR_MODULE /id%NPROCS TIME_DECOMP = TMP_TIME_DECOMP /id%NPROCS TIME_DECOMP_UCFS = TMP_TIME_DECOMP_UCFS /id%NPROCS TIME_LRASM_NIV1 = TMP_TIME_LRASM_NIV1 /id%NPROCS TIME_LRASM_LOCASM2 = TMP_TIME_LRASM_LOCASM2 /id%NPROCS TIME_LRASM_MAPLIG1 = TMP_TIME_LRASM_MAPLIG1 /id%NPROCS TIME_LRASM_CONTRIB2 = TMP_TIME_LRASM_CONTRIB2 /id%NPROCS TIME_FRASM_LOCASM2 = TMP_TIME_FRASM_LOCASM2 /id%NPROCS TIME_FRASM_MAPLIG1 = TMP_TIME_FRASM_MAPLIG1 /id%NPROCS TIME_FRASM_CONTRIB2 = TMP_TIME_FRASM_CONTRIB2 /id%NPROCS ENDIF CALL COMPUTE_GLOBAL_GAINS(id%KEEP8(110), & id%RINFOG(3), & id%KEEP8(49), PROKG, MPG) C Number of entries in factor INFOG(35) in C compressed form is updated as long as C BLR is activated, this independently of the C fact that factors are saved in LR. CALL MUMPS_SETI8TOI4(id%KEEP8(49), id%INFOG(35)) FRONTWISE = 0 C WRITE gains also compute stats stored in DKEEP array DO I=1,LR_TABSIZE LR_TAB(I) = id%DKEEP(I+LR_DKEEPSHIFT) LR_EPSILON = id%DKEEP(8) ENDDO CALL SAVEandWRITE_GAINS(FRONTWISE, KEEP(489), & LR_DKEEPSHIFT, LR_TABSIZE, LR_TAB, LR_EPSILON, & N, id%ICNTL(36), & KEEP(487), KEEP(488), KEEP(490), & KEEP(491), KEEP(50), KEEP(486), & KEEP(249)*max(KEEP(381), 1), & KEEP(472), KEEP(475), KEEP(478), & KEEP(480), KEEP(481), & KEEP(483), KEEP(484), & id%KEEP8(110), id%KEEP8(49), & KEEP(28), id%NPROCS, MPG, PROKG) C flops when BLR activated RINFOG(14) = id%DKEEP(56) DO I=1,18 id%DKEEP(I+LR_DKEEPSHIFT)=dble(LR_TAB(I)) ENDDO ELSE RINFOG(14) = 0.0D00 ENDIF IF (id%MYID .eq. MASTER) THEN KEEP(399) = KEEP399_SAVE ENDIF ENDIF C ============================== C NULL PIVOTS AND RANK-REVEALING C ============================== IF (KEEP(19).EQ.0.AND.KEEP(53).NE.0) THEN C restore KEEP(20) KEEP(20) = KEEP20_SAVE ENDIF IF(KEEP(110) .EQ. 1) THEN C -- make available to users the local number of null pivots detected C -- with ICNTL(24) = 1. id%INFO(18) = KEEP(109) CALL MPI_ALLREDUCE( KEEP(109), KEEP(112), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) ELSE id%INFO(18) = 0 KEEP(109) = 0 KEEP(112) = 0 ENDIF IF ( associated( id%PIVNUL_LIST) ) THEN DEALLOCATE(id%PIVNUL_LIST) NULLIFY(id%PIVNUL_LIST) ENDIF C set INFOG(28) even in case of error IF (id%MYID.EQ.MASTER) THEN C INFOG(28) deficiency resulting from ICNTL(24) and ICNTL(56) INFOG(28)=KEEP(112) IF (KEEP(17).GT.0) THEN INFOG(28)=KEEP(112)+KEEP(17) ENDIF ENDIF C IF (id%INFO(1).GE.0) THEN C{ PIVNUL_LIST not meaningful in case of error C (do not allocate) IF (id%MYID.EQ.MASTER) THEN IF ( INFOG(28) .GT. 0 ) THEN ALLOCATE(id%PIVNUL_LIST(INFOG(28)), stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=INFOG(28) END IF ENDIF ELSE C id%PIVNUL_LIST(1:KEEP(109)) used during sol_driver on slaves C to initialize id%RHSINTR IF (KEEP(109).GT.0) THEN ALLOCATE(id%PIVNUL_LIST(KEEP(109)), stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=INFOG(28) END IF ENDIF ENDIF C} ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 490 IF ( (KEEP(19).NE.0) .AND. (KEEP(143) .NE. KEEP(17)) ) THEN C C Raise a warning (on all MPI processes) since determinant or C inertia or null pivot list is not consistent with deficiency C computed with ICNTL(46)=1. C id%INFO(1) = id%INFO(1)+16 id%INFO(2) = KEEP(112)+KEEP(143) IF (KEEP(118) .GE. 40) THEN IF ( PROKG ) THEN WRITE(MPG,'(/A,A/,A,A,I8/,A,A,I8/)') & " WARNING: in the context of rank-revealing,", & " the inertia, determinant and pivnul list", & " are computed with RR (rank-revealing)-LU,", & " but the deficiency found by RR-LU: ", & id%INFO(2), & " is different from the deficiency computed", & " with ICNTL(56)>0: ", KEEP(112)+KEEP(17) ENDIF ELSE IF ( LP .GT. 0 ) THEN WRITE(LP,'(/A,A/,A/)') & " ERROR : in the context of rank-revealing,", & " the inertia, determinant and pivnul list", & " are not correct because RR LU not called " ENDIF ENDIF ENDIF C ======================================== C We now provide to the host the part of C PIVNUL_LIST resulting from the processing C of the root node and we update id%INFO(18) C on the processor holding the root to C include null pivots relative to the root C ======================================== IF ( KEEP(109).GT.0 ) THEN DO I=1, KEEP(109) id%PIVNUL_LIST(I)= & PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) ENDDO ENDIF IF (KEEP(17) .NE. 0) THEN IF (id%MYID .EQ. ID_ROOT) THEN C Include in id%INFO(18) null pivots resulting C from deficiency on the root. In this way, C the sum of all id%INFO(18) is equal to INFOG(28). id%INFO(18)=id%INFO(18)+KEEP(17) ENDIF IF (ID_ROOT .EQ. MASTER) THEN IF (id%MYID.EQ.MASTER) THEN C -------------------------------------------------- C Null pivots of root have been stored in C PIVNUL_LIST_STRUCT%PIVNUL_LIST( C KEEP(109)+1:KEEP(109)+KEEP(17) ) C Shift them at the end of the list because: C * this is what we need to build the null space C * we would otherwise overwrite them on the host C when gathering null pivots from other processors C -------------------------------------------------- DO I= KEEP(17), 1, -1 id%PIVNUL_LIST(KEEP(112)+I)= & PIVNUL_LIST_STRUCT%PIVNUL_LIST(KEEP(109)+I) ENDDO ENDIF ELSE C --------------------------------- C Null pivots of root must be sent C from the processor responsible of C the root to the host (or MASTER). C --------------------------------- IF (id%MYID .EQ. ID_ROOT) THEN CALL MPI_SEND( & PIVNUL_LIST_STRUCT%PIVNUL_LIST(KEEP(109)+1), & KEEP(17), MPI_INTEGER, MASTER, ZERO_PIV, & id%COMM, IERR) ELSE IF (id%MYID .EQ. MASTER) THEN CALL MPI_RECV(id%PIVNUL_LIST(KEEP(112)+1), KEEP(17), & MPI_INTEGER, ID_ROOT, ZERO_PIV, & id%COMM, STATUS, IERR ) ENDIF ENDIF ENDIF C =========================== C gather zero pivots indices C on the host node C =========================== C In case of non working host, the following code also C works considering that KEEP(109) is equal to 0 on C the non-working host IF(KEEP(110) .EQ. 1) THEN ALLOCATE(ITMP2(id%NPROCS),stat = IERR ) ! deallocated in 490 IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%NPROCS END IF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 490 CALL MPI_GATHER ( KEEP(109),1, MPI_INTEGER, & ITMP2(1), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF(id%MYID .EQ. MASTER) THEN POSBUF = ITMP2(1)+1 C First null pivot of master is in C position 1 of global list KEEP(220)=1 DO I = 1,id%NPROCS-1 IF (ITMP2(I+1).GT.0) THEN CALL MPI_RECV(id%PIVNUL_LIST(POSBUF), ITMP2(I+1), & MPI_INTEGER,I, & ZERO_PIV, id%COMM, STATUS, IERR) C Send position POSBUF of first null pivot of proc I C in global list. Will allow to quickly identify during C the solve step if one is concerned by a global position C K, 0 <= K <= INFOG(28). CALL MPI_SEND(POSBUF, 1, MPI_INTEGER, I, ZERO_PIV, & id%COMM, IERR) POSBUF = POSBUF + ITMP2(I+1) ENDIF ENDDO ELSE IF (KEEP(109).GT.0) THEN CALL MPI_SEND( & PIVNUL_LIST_STRUCT%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 ENDIF IF (associated( PIVNUL_LIST_STRUCT%PIVNUL_LIST)) THEN DEALLOCATE(PIVNUL_LIST_STRUCT%PIVNUL_LIST) NULLIFY(PIVNUL_LIST_STRUCT%PIVNUL_LIST) ENDIF C ===================================== C Statistics concerning the determinant C ===================================== C C 1/ on the host better take into account null pivots if scaling: C C Since null pivots are excluded from the computation C of the determinant, we also exclude the corresponding C scaling entries. Since those entries have already been C taken into account before the factorization, we multiply C the determinant on the host by the scaling values corresponding C to pivots in PIVNUL_LIST. IF (id%MYID.EQ.MASTER .AND. LSCAL. AND. KEEP(258).NE.0) THEN K = min(KEEP(143), KEEP(17)) K = max(K, 0) DO I = 1, KEEP(112)+ K c DO I = 1, id%INFOG(28) ! all null pivots + singular values CALL DMUMPS_UPDATEDETER_SCALING( & id%ROWSCA(id%PIVNUL_LIST(I)), & id%DKEEP(6), KEEP(259)) CALL DMUMPS_UPDATEDETER_SCALING( & id%COLSCA(id%PIVNUL_LIST(I)), & id%DKEEP(6), KEEP(259)) ENDDO ENDIF C C 2/ Swap signs depending on pivoting on each proc C IF (KEEP(258).NE.0) THEN C Return the determinant in INFOG(34) and RINFOG(12/13) C In case of real arithmetic, initialize C RINFOG(13) to 0 (no imaginary part and C not touched by DMUMPS_DETER_REDUCTION) RINFOG(13)=0.0D0 IF (KEEP(260).EQ.-1) THEN ! Local to each processor id%DKEEP(6)=-id%DKEEP(6) ENDIF C C 3/ Perform a reduction C CALL DMUMPS_DETER_REDUCTION( & id%COMM, id%DKEEP(6), KEEP(259), & RINFOG(12), INFOG(34), id%NPROCS) C C 4/ Swap sign if needed C IF (id%KEEP(50).EQ.0 .AND. id%MYID.EQ. MASTER) THEN C Modify sign of determinant according C to unsymmetric permutation (max-trans C of max-weighted matching) IF (id%KEEP(23).NE.0) THEN CALL DMUMPS_DETER_SIGN_PERM( & RINFOG(12), id%N, & id%UNS_PERM(1) ) C Remark that RINFOG(12/13) are modified only C on the host but will be broadcast on exit C from MUMPS (see DMUMPS_DRIVER) ENDIF ENDIF ENDIF 490 IF (allocated(ITMP2)) DEALLOCATE(ITMP2) C C ===================================== C Statistics relative to min/max pivots C ===================================== CALL MPI_REDUCE( id%DKEEP(19), RINFOG(19), 1, & MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(20), RINFOG(20), 1, & MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(21), RINFOG(21), 1, & MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR ) C ========================================= C Centralized number of swaps for pivoting C ========================================= CALL MPI_REDUCE( id%KEEP8(80), ITEMP8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF (id%MYID .EQ. MASTER) THEN CALL MUMPS_SETI8TOI4(ITEMP8,id%INFOG(48)) ENDIF C ========================================== C Centralized largest increase of panel size C ========================================== CALL MPI_REDUCE( id%KEEP(425), id%INFOG(49), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN C{ ----------------------------- C PRINT STATISTICS (on master) C ----------------------------- WRITE(MPG,99984) RINFOG(2),RINFOG(3),KEEP(52), & id%KEEP8(148), & id%KEEP8(128), INFOG(11), id%KEEP8(110) IF (id%KEEP(50) == 1 .OR. id%KEEP(50) == 2) THEN ! negative pivots WRITE(MPG, 99987) INFOG(12) END IF IF (id%KEEP(50) == 0) THEN ! off diag pivots WRITE(MPG, 99985) INFOG(12) END IF IF (id%KEEP(50) .NE. 1) THEN ! delayed pivots WRITE(MPG, 99982) INFOG(13) END IF IF (KEEP(97) .NE. 0) THEN ! tiny pivots WRITE(MPG, '(A,D16.4)') & ' Effective static pivoting thresh., CNTL(4) =', SEUIL WRITE(MPG, 99986) INFOG(25) ENDIF IF (id%KEEP(50) == 2) THEN !number of 2x2 pivots in type 1 nodes WRITE(MPG, 99988) KEEP(229) !number of 2x2 pivots in type 2 nodes WRITE(MPG, 99989) KEEP(230) ENDIF !number of zero pivots IF (KEEP(110) .NE.0) THEN WRITE(MPG, 99991) KEEP(112) ENDIF !Deficiency on root IF ( KEEP(19) .ne. 0 ) c IF ( KEEP(17) .ne. 0 ) & WRITE(MPG, 99983) KEEP(17) !Total deficiency IF (KEEP(110).NE.0.OR.KEEP(19).NE.0) & WRITE(MPG, 99992) KEEP(17)+KEEP(112) ! = INFOG(28) IF (id%KEEP(50) .EQ. 1 .OR. id%KEEP(50) .EQ. 2) THEN IF (KEEP(110) .NE. 0 .OR .KEEP(19).NE.0) THEN WRITE(MPG, 99997) INFOG(50) ENDIF ENDIF !Smallest pivot with also null pivots in abs value WRITE(MPG, 99995) RINFOG(19) !Smallest pivot in abs value WRITE(MPG, 99993) RINFOG(20) !Largest pivot in abs value WRITE(MPG, 99994) RINFOG(21) !value of ICNTL(12) that was effectively used. WRITE(MPG, 99996) INFOG(24) ! Memory compress WRITE(MPG, 99981) INFOG(14) ! Extra copies due to ip stack in unsym case ! in core case (or OLD_OOC_PANEL) IF (id%KEEP8(108) .GT. 0_8) THEN WRITE(MPG, 99980) id%KEEP8(108) ENDIF IF ((KEEP(60).NE.0) .AND. INFOG(25).GT.0) THEN ! Schur on and tiny pivots set in last level ! before the Schur if KEEP(114)=0 WRITE(MPG, '(A)') & " ** Warning Static pivoting was necessary" WRITE(MPG, '(A)') & " ** to factor interior variables with Schur ON" ENDIF IF (KEEP(258).NE.0) THEN WRITE(MPG,99978) RINFOG(12) WRITE(MPG,99977) INFOG(34) ENDIF C} END IF * ========================================== * * End of Factorization Phase * * ========================================== C C Goto 500 is done when C LOAD_INIT C OOC_INIT_FACTO C MUMPS_FDM_INIT #if ! defined(NO_FDM_DESCBAND) C MUMPS_FDBD_INIT #endif #if ! defined(NO_FDM_MAPROW) C MUMPS_FMRD_INIT #endif C are all called. C 500 CONTINUE C Redo free INTARR and DBLARR in case an error occurred C after allocating them and before freeing them. IF (associated(DBLARR)) THEN DEALLOCATE(DBLARR) NULLIFY(DBLARR) ENDIF IF (allocated(INTARR)) THEN DEALLOCATE(INTARR) ENDIF IF ( KEEP(38) .NE. 0) THEN IF (associated(idintr%root%RG2L)) THEN DEALLOCATE(idintr%root%RG2L) NULLIFY(idintr%root%RG2L) ENDIF ENDIF #if ! defined(NO_FDM_DESCBAND) IF (I_AM_SLAVE) THEN CALL MUMPS_FDBD_END(id%INFO(1)) ! INFO(1): input only ENDIF #endif #if ! defined(NO_FDM_MAPROW) IF (I_AM_SLAVE) THEN CALL MUMPS_FMRD_END(id%INFO(1)) ! INFO(1): input only ENDIF #endif IF (I_AM_SLAVE) THEN C Terminate BLR module except if it is still needed for solve IF ( & ( & (KEEP(486).EQ.2) & ) & .AND. id%INFO(1).GE.0 & ) THEN C Store pointer to BLR_ARRAY in MUMPS structure C (requires successful factorization otherwise module is freed) CALL DMUMPS_BLR_MOD_TO_STRUC(id%BLRARRAY_ENCODING) ELSE C INFO(1) positive or negative CALL DMUMPS_BLR_END_MODULE(id%INFO(1), id%KEEP8, id%KEEP(34)) ENDIF ENDIF IF (I_AM_SLAVE) THEN CALL MUMPS_FDM_END('A') C Terminate BLR module except if it is still needed for solve IF ( & ( & (KEEP(486).EQ.2) & ) & .AND. id%INFO(1).GE.0 & ) THEN CALL MUMPS_FDM_MOD_TO_STRUC('F', id%FDM_F_ENCODING, & id%INFO(1)) IF (.NOT. associated(id%FDM_F_ENCODING)) THEN WRITE(*,*) "Internal error 2 in DMUMPS_FAC_DRIVER" ENDIF ELSE CALL MUMPS_FDM_END('F') ENDIF ENDIF C C Goto 514 is done when an C error occurred in MUMPS_FDM_INIT C or (after FDM_INIT but before C OOC_INIT) C 514 CONTINUE IF ( I_AM_SLAVE ) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL DMUMPS_OOC_END_FACTO(id%KEEP,id%KEEP8, & id%OOC_MAX_NB_NODES_FOR_ZONE,id%OOC_TOTAL_NB_NODES, & id%OOC_FILE_NAMES, id%INFO, id%OOC_FILE_NAME_LENGTH, & id%OOC_NB_FILES, IERR) IF (id%ASSOCIATED_OOC_FILES) THEN id%ASSOCIATED_OOC_FILES = .FALSE. ENDIF IF (IERR.LT.0 .AND. id%INFO(1) .GE. 0) id%INFO(1) = IERR ENDIF IF (WK_USER_PROVIDED) THEN C at the end of a phase S is always null when WK_USER provided NULLIFY(id%S) ELSE IF (KEEP(201).NE.0) THEN C ---------------------------------------- C In OOC or if KEEP(201).EQ.-1 we always C free S at end of factorization. As id%S C may be unassociated in case of error C during or before the allocation of id%S, C we only free S when it was associated. C ---------------------------------------- IF (associated(id%S)) THEN CALL DMUMPS_DM_FREE_S_WK(id%S, KEEP(430)) C Reset KEEP(430)=0 since S will be allocated C from Fortran during solve KEEP(430) = 0 ENDIF NULLIFY(id%S) ! in all cases id%KEEP8(23)=0_8 ELSE ! in core CALL DMUMPS_TRY_COMPACT_FACTORS(ICNTL49_LOC, & WK_USER_PROVIDED, id%S, id%KEEP, id%KEEP8, & id%INFO, id%MYID, id%ICNTL, PROK, MP, & DMUMPS_LBUFR_BYTES8, DMUMPS_LBUF8, & LIWK, LIWK8 ) ENDIF ELSE ! host not working IF (WK_USER_PROVIDED) THEN C at the end of a phase S is always freed when WK_USER provided NULLIFY(id%S) ELSE IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) id%KEEP8(23)=0_8 END IF END IF C C Goto 513 is done in case of error where LOAD_INIT was C called but not the scaling nor OOC_INIT_FACTO. 513 CONTINUE IF ( I_AM_SLAVE ) THEN CALL MUMPS_LOAD_END( id%INFO(1), id%NSLAVES, IERR ) IF (IERR.LT.0 .AND. id%INFO(1) .GE. 0) id%INFO(1) = IERR ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C C Goto 516 is done in case of error when GPU initialiwqtion C has been performed and scaling was optionally computed but C not LOAD_INIT nor OOC_INIT_FACTO. We can then extract C scaling arrays in case of error. 516 CONTINUE C -------------------------------------------- C We now build id%ROWSCA_loc and id%COLSCA_loc C in case of successful factorization, in the C numbering associated to the fully summed C variables of the frontal matrices. C This requires the factorization to be C successful because otherwise we do not have C the final lists of pivots associated to C the fronts, including delayed pivots and C symmetric/unsymmetric permutations done C during the factorization process. C -------------------------------------------- IF (LSCAL .AND. id%INFO(1).GE.0) THEN CALL DMUMPS_EXTRACT_SCALING(id) C occurs during scaling extraction, keep the error. IF ( id%INFO(1) .LT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) "Facto OK but error during EXTRACT_SCALING", & id%INFO(1:2) ENDIF ENDIF ENDIF C C Goto 517 is done when an error occurs when GPU initialization C has been performed but not LOAD_INIT or OOC_INIT_FACTO, e.g. C when an error occurred during the scaling. 517 CONTINUE IF (associated( PIVNUL_LIST_STRUCT%PIVNUL_LIST)) THEN DEALLOCATE(PIVNUL_LIST_STRUCT%PIVNUL_LIST) NULLIFY(PIVNUL_LIST_STRUCT%PIVNUL_LIST) ENDIF C C Goto 530 is done when an error occurs before C the calls to GPU_INIT, LOAD_INIT and OOC_INIT_FACTO 530 CONTINUE C Fwd in facto: free RHS_MUMPS in case C it was allocated. IF (RHS_MUMPS_ALLOCATED) DEALLOCATE(RHS_MUMPS) NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. C id%KEEP8(26) = KEEP826_SAVE RETURN 120 FORMAT(/' Local redistrib: data local/sent =',I16,I16) 125 FORMAT(/' Redistrib: total data local/sent =',I16,I16) 130 FORMAT(//'****** FACTORIZATION STEP ********'/) 140 FORMAT(/' Statistics on the scaling phase' & /' Elapsed time for scaling =',F12.4) 160 FORMAT( & ' Elapsed time to reformat/distribute matrix =',F12.4/) 166 FORMAT(' Max difference from 1 after scaling the entries', & ' for ONE-NORM (option 7/8) =',D9.2/) 170 FORMAT(' STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' Size of internal working array S =',I16/ & ' Size of internal working array IS =',I16/ & ' Minimum (ICNTL(14)=0) size of S =',I16/ & ' Minimum (ICNTL(14)=0) size of IS =',I16/ & ' Real space for original matrix =',I16/ & ' Integer space for original matrix =',I16/ & ' INFO(3) Real space for factors (estimated) =',I16/ & ' INFO(4) Integer space for factors (estim.) =',I16/ & ' Maximum frontal size (estimated) =',I16) 172 FORMAT(' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' Number of working processes =',I16/ & ' ICNTL(22) Out-of-core option =',I16/ & ' ICNTL(35) BLR activation (eff. choice) =',I16/ & ' ICNTL(37) BLR CB compression (eff. choice) =',I16/ & ' ICNTL(49) Compact workarray S (end facto.) =',I16/ & ' ICNTL(56) Effective value during facto. =',I16/ & ' ICNTL(14) Memory relaxation =',I16/ & ' INFOG(3) Real space for factors (estimated)=',I16/ & ' INFOG(4) Integer space for factors (estim.)=',I16/ & ' Maximum frontal size (estimated) =',I16/ & ' Number of nodes in the tree =',I16/ & ' ICNTL(23) Memory allowed (value on host) =',I16/ & ' Sum over all procs =',I16/ & ' Memory provided by user, sum of LWK_USER =',I16/ & ' Effective threshold for pivoting, CNTL(1) =',D16.4) 173 FORMAT( ' Perform forward during facto, NRHS =',I16) 174 FORMAT( ' KEEP(268) Relaxed pivoting effective value =',I16) 180 FORMAT(/' Elapsed time for factorization =', & F12.4) 185 FORMAT(/' Elapsed time for (failed) factorization =', & F12.4) 186 FORMAT(/' Elapsed time to process root node =', & F12.4) 187 FORMAT( ' Elapsed time under L0 =',F12.4) 188 FORMAT( ' Elapsed time under L0 (avg/max across MPI) =', & F12.4,F12.4) 189 FORMAT(/' Flops under L0 layer =',1PD12.3) 190 FORMAT(/' Flops under L0 layer (avg/max across MPI) =', & 1PD12.3,1PD12.3) 99977 FORMAT( ' INFOG(34) Determinant (base 2 exponent) =', & I16) 99978 FORMAT( ' RINFOG(12) Determinant (real part) =', & F16.8) 99980 FORMAT( ' Extra copies due to In-Place stacking =', & I16) 99981 FORMAT( ' INFOG (14) Number of memory compress =', & I16) 99982 FORMAT( ' INFOG (13) Number of delayed pivots =', & I16) 99983 FORMAT( ' Nb of singularities detected by ICNTL(56) =', & I16) 99991 FORMAT( ' Nb of null pivots detected by ICNTL(24) =', & I16) 99992 FORMAT( ' INFOG (28) Estimated deficiency =', & I16) 99997 FORMAT( ' INFOG (50) Number of negative AND null pivots =', & I16) 99995 FORMAT( ' RINFOG(19) Smallest pivot WITH perturbed pivots =', & 1PD10.3) 99993 FORMAT( ' RINFOG(20) Smallest pivot WITHOUT perturbed pivots =', & 1PD10.3) 99994 FORMAT( ' RINFOG(21) Largest pivot in absolute value =', & 1PD10.3) 99996 FORMAT( ' INFOG (24) Effective value of ICNTL(12) =', & I16) 99984 FORMAT(/'Leaving factorization with ...'/ & ' RINFOG (2) Operations in node assembly =', & 1PD10.3/ & ' ------ (3) Operations in node elimination =', & 1PD10.3/ & ' ICNTL (8) Scaling effectively used =', & I16/ & ' INFOG (9) Real space for factors =', & I16/ & ' INFOG (10) Integer space for factors =', & I16/ & ' INFOG (11) Maximum front size =', & I16/ & ' INFOG (29) Number of entries in factors =', & I16) 99985 FORMAT( ' INFOG (12) Number of off diagonal pivots =', & I16) 99986 FORMAT( ' INFOG (25) Number of tiny pivots(static) =', & I16) 99987 FORMAT( ' INFOG (12) Number of negative pivots =', & I16) 99988 FORMAT( ' Number of 2x2 pivots in type 1 nodes =', & I16) 99989 FORMAT( ' Number of 2x2 pivots in type 2 nodes =', & I16) END SUBROUTINE DMUMPS_FAC_DRIVER C SUBROUTINE DMUMPS_PRINT_ALLOCATED_MEM( PROK, PROKG, PRINT_MAXAVG, & MP, MPG, INFO16, INFOG18, INFOG19, NSLAVES, IRANK, KEEP ) IMPLICIT NONE C C Purpose: C ======= C Print memory allocated during factorization C - called at beginning of factorization in full-rank C - called at end of factorization in low-rank (because C of dynamic allocations) C LOGICAL, INTENT(IN) :: PROK, PROKG, PRINT_MAXAVG INTEGER, INTENT(IN) :: MP, MPG, INFO16, INFOG18, INFOG19 INTEGER, INTENT(IN) :: IRANK, NSLAVES INTEGER, INTENT(IN) :: KEEP(500) C IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' ** Memory allocated, max in Mbytes (INFOG(18)):', & INFOG18 ENDIF WRITE( MPG,'(/A,I12) ') & ' ** Memory allocated, total in Mbytes (INFOG(19)):', & INFOG19 END IF RETURN END SUBROUTINE DMUMPS_PRINT_ALLOCATED_MEM SUBROUTINE DMUMPS_AVGMAX_STAT8(PROKG, MPG, VAL, NSLAVES, & PRINT_MAXAVG, COMM, MSG) IMPLICIT NONE INCLUDE 'mpif.h' LOGICAL, intent(in) :: PROKG INTEGER, intent(in) :: MPG INTEGER(8), intent(in) :: VAL INTEGER, intent(in) :: NSLAVES LOGICAL, intent(in) :: PRINT_MAXAVG INTEGER, intent(in) :: COMM CHARACTER*48 MSG C Local INTEGER(8) MAX_VAL INTEGER IERR, MASTER DOUBLE PRECISION LOC_VAL, AVG_VAL PARAMETER(MASTER=0) C CALL MUMPS_REDUCEI8( VAL, MAX_VAL, MPI_MAX, MASTER, COMM) LOC_VAL = dble(VAL)/dble(NSLAVES) CALL MPI_REDUCE( LOC_VAL, AVG_VAL, 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, COMM, IERR ) IF (PROKG) THEN IF (PRINT_MAXAVG) THEN WRITE(MPG,100) " Average", MSG, int(AVG_VAL,8) ELSE WRITE(MPG,110) MSG, MAX_VAL ENDIF ENDIF RETURN 100 FORMAT(A8,A48,I18) 110 FORMAT(A48,I18) END SUBROUTINE DMUMPS_AVGMAX_STAT8 C C C ================================================================== C SUBROUTINE DMUMPS_EXTRACT_SCALING(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C Extract distributed scaling arrays from DMUMPS_EXTRACT_SCALING C In case of unsymmetric permutation, ROWSCA and COLSCA correspond C to Dr and Dc, in the expression Dr A Q Dc. In other terms, Dc C is compatbile with the front column indices, it does not C correspond to the column indices of A, meaning that Q is not C needed to just extract the scaling values. C C TYPE(DMUMPS_STRUC) :: id INTEGER, EXTERNAL :: MUMPS_PROCNODE C C MPI C === C INCLUDE 'mpif.h' C C Local declarations C ================== C DOUBLE PRECISION, DIMENSION(:), POINTER :: COLSCA DOUBLE PRECISION, DIMENSION(:), POINTER :: ROWSCA INTEGER, PARAMETER :: MASTER = 0 C INTEGER :: ISTEP, NPIV, LIELL INTEGER :: IERR_MPI, allocok INTEGER :: ISCA INTEGER :: JROW, JCOL, IPOS, JJ ! access to IS INTEGER :: LIW_PASSED INTEGER(8) :: LALLOC C C Free and reallocate distributed scaling arrays : C - in symmetric, COLSCA_loc points on ROWSCA_loc. C - not allocated if KEEP(89)=0 C NULLIFY(ROWSCA) NULLIFY(COLSCA) IF (associated(id%ROWSCA_loc)) THEN DEALLOCATE(id%ROWSCA_loc) NULLIFY(id%ROWSCA_loc) ENDIF IF (associated(id%COLSCA_loc)) THEN IF (id%KEEP(50) .EQ. 0) THEN DEALLOCATE(id%COLSCA_loc) ENDIF NULLIFY(id%COLSCA_loc) ENDIF C id%ROWSCA and id%COLSCA are available on master, C allocate ROWSCA and COLSCA of order N on other procs IF ( id%MYID .EQ. MASTER ) THEN ROWSCA => id%ROWSCA COLSCA => id%COLSCA IF (.NOT. associated(ROWSCA)) THEN WRITE(*,*) "Internal error 1 in DMUMPS_EXTRACT_SCALING" CALL MUMPS_ABORT() ENDIF IF (.NOT. associated(COLSCA)) THEN WRITE(*,*) "Internal error 2 in DMUMPS_EXTRACT_SCALING" CALL MUMPS_ABORT() ENDIF ELSE IF (id%KEEP(50).EQ.0) THEN ALLOCATE(ROWSCA(id%N),COLSCA(id%N),stat=allocok) LALLOC = int(id%N+id%N,8) ELSE ALLOCATE(ROWSCA(id%N),stat=allocok) COLSCA => ROWSCA LALLOC = int(id%N,8) ENDIF IF (allocok .GT. 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(LALLOC,id%INFO(2)) ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C Jump to 110 in case of error on ROWSCA or COLSCA C on one of the MPI processes. IF (id%INFO(1) .LT. 0) GOTO 110 C IF ( id%KEEP(89) .GT. 0) THEN IF (id%KEEP(50).EQ.0) THEN ALLOCATE(id%ROWSCA_loc(id%KEEP(89)), & id%COLSCA_loc(id%KEEP(89)),stat=allocok) LALLOC = int(id%KEEP(89),8)*2_8 ELSE ALLOCATE(id%ROWSCA_loc(id%KEEP(89)),stat=allocok) id%COLSCA_loc => id%ROWSCA_loc LALLOC = int(id%KEEP(89),8) ENDIF IF (allocok .GT. 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(LALLOC,id%INFO(2)) ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C Jump to 100 in case of error (we free everything) IF (id%INFO(1) .LT. 0) GOTO 100 CALL MPI_BCAST(ROWSCA(1), id%N, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR_MPI) IF (id%KEEP(50) .EQ. 0) THEN CALL MPI_BCAST(COLSCA(1), id%N, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR_MPI) ENDIF LIW_PASSED = max(id%KEEP(32),1) ISCA = 1 IF ( id%MYID .ne. MASTER .OR. & id%KEEP(46) .eq. 1 ) THEN ! I_AM_SLAVE DO ISTEP = 1, id%KEEP(28) IF ( id%MYID_NODES.EQ. MUMPS_PROCNODE( & id%PROCNODE_STEPS(ISTEP), & id%KEEP(199) ) ) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, id%KEEP, & NPIV, LIELL, IPOS, & id%IS(1), LIW_PASSED, id%PTLUST_S(1), id%STEP(1), id%N) IF ( id%KEEP(50) .EQ. 0 ) THEN C Row indices: JROW = IPOS + 1 C Column indices: JCOL = IPOS + 1 + LIELL ELSE C Use row indices because column indices may have C been set to negative to flag 2x2 pivots JROW = IPOS + 1 ENDIF IF (id%KEEP(50).EQ.0) THEN DO JJ = 1, NPIV id%ROWSCA_loc(ISCA+JJ-1) = ROWSCA(id%IS(JROW+JJ-1)) id%COLSCA_loc(ISCA+JJ-1) = COLSCA(id%IS(JCOL+JJ-1)) ENDDO ELSE DO JJ = 1, NPIV id%ROWSCA_loc(ISCA+JJ-1) = ROWSCA(id%IS(JROW+JJ-1)) ENDDO ENDIF ISCA = ISCA + NPIV ENDIF ENDDO ENDIF C End of EXTRACT_SCALING, we keep id%ROWSCA_loc and id%COLSCA_loc C but free ROWSCA and COLSCA GOTO 110 RETURN 100 CONTINUE C Exit with error, free what was allocated IF (associated(id%ROWSCA_loc)) THEN DEALLOCATE(id%ROWSCA_loc) NULLIFY(id%ROWSCA_loc) ENDIF IF (associated(id%COLSCA_loc)) THEN IF (id%KEEP(50) .EQ. 0) THEN DEALLOCATE(id%COLSCA_loc) ENDIF NULLIFY(id%COLSCA_loc) ENDIF 110 CONTINUE C Free local ROWSCA and COLSCA arrays IF ( id%MYID .NE. 0) THEN IF (associated(ROWSCA)) DEALLOCATE(ROWSCA) IF ( id%KEEP(50) .EQ. 0 ) THEN IF (associated(COLSCA)) DEALLOCATE(COLSCA) ENDIF ENDIF NULLIFY(ROWSCA) NULLIFY(COLSCA) RETURN END SUBROUTINE DMUMPS_EXTRACT_SCALING C C ================================================================== C SUBROUTINE DMUMPS_EXTRACT_SCHUR_REDRHS(id,idintr) USE DMUMPS_STRUC_DEF USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_INTR_STRUC IMPLICIT NONE C C Purpose C ======= C C Extract the Schur and possibly also the reduced right-hand side C (if Fwd in facto) from the processor working on Schur and copy C it into the user datastructures id%SCHUR and id%REDRHS on the host. C This routine assumes that the integer list of the Schur has not C been permuted and still corresponds to LISTVAR_SCHUR. C C If the Schur is centralized, the master of the Schur holds the C Schur and possibly also the reduced right-hand side. C If the Schur is distribued (already built in user's datastructure), C then the master of the Schur may hold the reduced right-hand side, C in which case it is available in roota%RHS_CNTR_MASTER_ROOT. C TYPE (DMUMPS_STRUC) :: id TYPE (DMUMPS_INTR_STRUC) :: idintr C C Local variables C =============== C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ID_SCHUR, SIZE_SCHUR, LD_SCHUR, IB, BL4 INTEGER(4) :: I4 ! 32-bit even in 64-bit version INTEGER :: ROW_LENGTH, I INTEGER(8) :: SURFSCHUR8, BL8, SHIFT8 INTEGER(8) :: ISCHUR_SRC, ISCHUR_DEST, ISCHUR_SYM, ISCHUR_UNS C C External functions C ================== C INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE C Quick return in case factorization did not terminate correctly IF (id%INFO(1) .LT. 0) RETURN C Quick return if Schur option off IF (id%KEEP(60) .EQ. 0) RETURN C Get Schur id ID_SCHUR =MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(max(id%KEEP(20),id%KEEP(38)))), & id%KEEP(199)) IF ( id%KEEP( 46 ) .NE. 1 ) THEN ID_SCHUR = ID_SCHUR + 1 END IF C Get size of Schur IF (id%MYID.EQ.ID_SCHUR) THEN IF (id%KEEP(60).EQ.1) THEN C Sequential Schur LD_SCHUR = & id%IS(id%PTLUST_S(id%STEP(id%KEEP(20)))+2+id%KEEP(IXSZ)) SIZE_SCHUR = LD_SCHUR - id%KEEP(253) ELSE C Parallel Schur LD_SCHUR = -999999 ! not used SIZE_SCHUR = idintr%root%TOT_ROOT_SIZE ENDIF ELSE IF (id%MYID .EQ. MASTER) THEN SIZE_SCHUR = id%KEEP(116) LD_SCHUR = -44444 ! Not used ELSE C Proc is not concerned with Schur, return RETURN ENDIF SURFSCHUR8 = int(SIZE_SCHUR,8)*int(SIZE_SCHUR,8) C ===================================== C Case of parallel Schur: if REDRHS C was requested, obtain it directly C from idintr%roota%RHS_CNTR_MASTER_ROOT C ===================================== IF (id%KEEP(60) .GT. 1) THEN IF (id%KEEP(221).EQ.1 .AND. id%KEEP(252).GT.0) THEN DO I = 1, id%KEEP(253) IF (ID_SCHUR.EQ.MASTER) THEN ! Necessarily = id%MYID CALL dcopy(SIZE_SCHUR, & idintr%roota%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), 1, & id%REDRHS((I-1)*id%LREDRHS+1), 1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN C Send CALL MPI_SEND( & idintr%roota%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), & SIZE_SCHUR, & MPI_DOUBLE_PRECISION, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE ! MYID.EQ.MASTER C Receive CALL MPI_RECV( id%REDRHS((I-1)*id%LREDRHS+1), & SIZE_SCHUR, & MPI_DOUBLE_PRECISION, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF ENDDO C ------------------------------ C In case of parallel Schur, we C free roota%RHS_CNTR_MASTER_ROOT C ------------------------------ IF (id%MYID.EQ.ID_SCHUR) THEN DEALLOCATE(idintr%roota%RHS_CNTR_MASTER_ROOT) NULLIFY (idintr%roota%RHS_CNTR_MASTER_ROOT) ENDIF ENDIF C return because this is all we need to do C in case of parallel Schur complement RETURN ENDIF C ============================ C Centralized Schur complement C ============================ C PTRAST has been freed at the moment of calling this C routine. Schur is available through C PTRFAC(IW( PTLUST_S( STEP(KEEP(20)) ) + 4 +KEEP(IXSZ) )) IF (id%KEEP(252).EQ.0) THEN C CASE 1 (ORIGINAL CODE): C Schur is contiguous on ID_SCHUR IF ( ID_SCHUR .EQ. MASTER ) THEN ! Necessarily equals id%MYID C --------------------- C Copy Schur complement C --------------------- CALL DMUMPS_COPYI8SIZE( SURFSCHUR8, & id%S(id%PTRFAC(id%STEP(id%KEEP(20)))), & id%SCHUR(1) ) ELSE C ----------------------------------------- C The processor responsible of the Schur C complement sends it to the host processor C Use blocks to avoid too large messages. C ----------------------------------------- BL8=int(huge(I4)/id%KEEP(35)/10,8) DO IB=1, int((SURFSCHUR8+BL8-1_8) / BL8) SHIFT8 = int(IB-1,8) * BL8 ! Where to send BL4 = int(min(BL8,SURFSCHUR8-SHIFT8)) ! Size of block IF ( id%MYID .eq. ID_SCHUR ) THEN C Send Schur complement CALL MPI_SEND( id%S( SHIFT8 + & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ)))), & BL4, & MPI_DOUBLE_PRECISION, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE IF ( id%MYID .eq. MASTER ) THEN C Receive Schur complement CALL MPI_RECV( id%SCHUR(1_8 + SHIFT8), & BL4, & MPI_DOUBLE_PRECISION, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) END IF ENDDO END IF ELSE C CASE 2 (Fwd in facto): Schur is not contiguous on ID_SCHUR, C process it row by row. C C 2.1: We first centralize Schur complement into id%SCHUR ISCHUR_SRC = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) ISCHUR_DEST= 1_8 DO I=1, SIZE_SCHUR ROW_LENGTH = SIZE_SCHUR IF (ID_SCHUR.EQ.MASTER) THEN ! Necessarily = id%MYID CALL dcopy(ROW_LENGTH, id%S(ISCHUR_SRC), 1, & id%SCHUR(ISCHUR_DEST),1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN C Send CALL MPI_SEND( id%S(ISCHUR_SRC), ROW_LENGTH, & MPI_DOUBLE_PRECISION, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE C Recv CALL MPI_RECV( id%SCHUR(ISCHUR_DEST), & ROW_LENGTH, & MPI_DOUBLE_PRECISION, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF ISCHUR_SRC = ISCHUR_SRC+int(LD_SCHUR,8) ISCHUR_DEST= ISCHUR_DEST+int(SIZE_SCHUR,8) ENDDO C 2.2: Get REDRHS on host C 2.2.1: Symmetric => REDRHS is available in last KEEP(253) C rows of Schur structure on ID_SCHUR C 2.2.2: Unsymmetric => REDRHS corresponds to last KEEP(253) C columns. However it must be transposed. IF (id%KEEP(221).EQ.1) THEN ! Implies Fwd in facto ISCHUR_SYM = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) * & int(LD_SCHUR,8) ISCHUR_UNS = & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) ISCHUR_DEST = 1_8 DO I = 1, id%KEEP(253) IF (ID_SCHUR .EQ. MASTER) THEN ! necessarily = id%MYID IF (id%KEEP(50) .EQ. 0) THEN CALL dcopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, & id%REDRHS(ISCHUR_DEST), 1) ELSE CALL dcopy(SIZE_SCHUR, id%S(ISCHUR_SYM), 1, & id%REDRHS(ISCHUR_DEST), 1) ENDIF ELSE IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(50) .EQ. 0) THEN C Use id%S(ISCHUR_SYM) as temporary contig. workspace C of size SIZE_SCHUR. CALL dcopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, & id%S(ISCHUR_SYM), 1) ENDIF CALL MPI_SEND(id%S(ISCHUR_SYM), SIZE_SCHUR, & MPI_DOUBLE_PRECISION, MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE CALL MPI_RECV(id%REDRHS(ISCHUR_DEST), & SIZE_SCHUR, MPI_DOUBLE_PRECISION, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF IF (id%KEEP(50).EQ.0) THEN ISCHUR_UNS = ISCHUR_UNS + int(LD_SCHUR,8) ELSE ISCHUR_SYM = ISCHUR_SYM + int(LD_SCHUR,8) ENDIF ISCHUR_DEST = ISCHUR_DEST + int(id%LREDRHS,8) ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_EXTRACT_SCHUR_REDRHS SUBROUTINE DMUMPS_EXTRACT_SINGULAR_VALUES(id,idintr) USE DMUMPS_STRUC_DEF USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_INTR_STRUC IMPLICIT NONE C C Purpose C ======= C C TYPE (DMUMPS_STRUC) :: id TYPE (DMUMPS_INTR_STRUC) :: idintr C C Local variables C =============== C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ID_ROOT, ALLOCOK C C External functions C ================== C INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE C Quick return in case factorization did not terminate correctly IF (id%INFO(1) .LT. 0) RETURN C Quick return if Postponing + rank revealing option off IF (id%KEEP(19) .EQ. 0) RETURN C Get Root id ID_ROOT =MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(id%KEEP(20))), & id%KEEP(199)) IF ( id%KEEP( 46 ) .NE. 1 ) THEN ID_ROOT = ID_ROOT + 1 END IF C ================================= C Singular values are stored in C roota%SINGULAR_VALUES C We copy it to id%SINGULAR_VALUES C ================================= IF ((ID_ROOT.EQ.id%MYID).AND.(id%MYID.EQ.MASTER)) THEN C write(6,*) " singular_values already on host" IF (associated(id%SINGULAR_VALUES)) & DEALLOCATE(id%SINGULAR_VALUES) NULLIFY(id%SINGULAR_VALUES) id%NB_SINGULAR_VALUES=idintr%root%NB_SINGULAR_VALUES ALLOCATE(id%SINGULAR_VALUES(id%NB_SINGULAR_VALUES) & , stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN id%INFO(1)=-13 id%INFO(2)= id%NB_SINGULAR_VALUES RETURN END IF CALL dcopy(id%NB_SINGULAR_VALUES, & idintr%roota%SINGULAR_VALUES(1), 1, & id%SINGULAR_VALUES(1), 1) ELSE IF (id%MYID.EQ.ID_ROOT) THEN C Send C write(6,*) " id%MYID sends singular_values " CALL MPI_SEND( & idintr%root%NB_SINGULAR_VALUES, & 1, & MPI_INTEGER, & MASTER, TAG_ROOT1, & id%COMM, IERR ) CALL MPI_SEND( & idintr%roota%SINGULAR_VALUES(1), & idintr%root%NB_SINGULAR_VALUES, & MPI_DOUBLE_PRECISION, & MASTER, TAG_ROOT2, & id%COMM, IERR ) ELSEIF (id%MYID.EQ.MASTER) THEN C Receive CALL MPI_RECV( id%NB_SINGULAR_VALUES, & 1, & MPI_INTEGER, ID_ROOT, TAG_ROOT1, & id%COMM, STATUS, IERR ) IF (associated(id%SINGULAR_VALUES)) & DEALLOCATE(id%SINGULAR_VALUES) NULLIFY(id%SINGULAR_VALUES) ALLOCATE(id%SINGULAR_VALUES(id%NB_SINGULAR_VALUES) & , stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN id%INFO(1)=-13 id%INFO(2)= id%NB_SINGULAR_VALUES RETURN END IF CALL MPI_RECV( id%SINGULAR_VALUES(1), & id%NB_SINGULAR_VALUES, & MPI_DOUBLE_PRECISION, ID_ROOT, TAG_ROOT2, & id%COMM, STATUS, IERR ) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_EXTRACT_SINGULAR_VALUES SUBROUTINE DMUMPS_SET_NOMP_MAX(KEEP281, KEEP361, & N, NOMP_MAX) !$ USE OMP_LIB C C Purpose C ======= C set NOMP_MAX from KEEP(281) C on output NOMP_MAX >=0 C C Parameters C ========== C INTEGER, INTENT(IN) :: KEEP281, KEEP361, N INTEGER, INTENT(OUT) :: NOMP_MAX C C Local variables C INTEGER :: NOMP C C out-of-range entries treated as -1 NOMP_MAX= max(-1, KEEP281) NOMP = 1 !$ NOMP = omp_get_max_threads() IF (NOMP_MAX.EQ.-1) THEN C automatic setting IF (N.LE.KEEP361) THEN NOMP_MAX = 0 RETURN ENDIF IF (NOMP.GT.1) THEN C conservative because of memory allocation NOMP_MAX = min(NOMP, 10) ELSE C no multithreading and all parallel do suppressed NOMP_MAX = 0 ENDIF ELSE C NOMP_MAX >=0 C use provided value NOMP_MAX = min(NOMP_MAX, NOMP) ENDIF C RETURN END SUBROUTINE DMUMPS_SET_NOMP_MAX MUMPS_5.8.1/src/csol_fwd.F0000664000175000017500000001625315042446440015146 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SOL_R(N, A, LA, IW, LIW, WCB, LWCB, & NRHS, & PTRICB, IWCB, LIWCB, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & STEP, & FRERE, DAD, FILS, & NSTK, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, MYROOT, & INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) USE CMUMPS_STATIC_PTR_M, ONLY : CMUMPS_SET_STATIC_PTR, & CMUMPS_GET_TMP_PTR USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_L0OMPFAC_T IMPLICIT NONE INTEGER MTYPE INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER, INTENT(IN) :: N, LIW, LPOOL, LIWCB INTEGER, INTENT(IN) :: SLAVEF, MYLEAF, MYROOT, COMM, MYID INTEGER INFO( 80 ), KEEP(500) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER NRHS COMPLEX A( LA ), WCB( LWCB ) INTEGER(8), intent(in) :: LRHS_ROOT COMPLEX RHS_ROOT( LRHS_ROOT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER STEP( N ), FRERE( KEEP(28) ), FILS( N ), & DAD( KEEP(28) ) INTEGER NSTK(KEEP(28)), IPOOL( LPOOL ) INTEGER PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTRICB( KEEP(28) ) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) INTEGER IW( LIW ), IWCB( LIWCB ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, intent(in) :: POSINRHSINTR_FWD(N), LRHSINTR COMPLEX, intent(inout) :: RHSINTR(LRHSINTR,NRHS) LOGICAL, intent(in) :: FROM_PP INTEGER, INTENT( in ) :: LL0_OMP_MAPPING, LL0_OMP_FACTORS INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) TYPE (CMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY(1) LOGICAL FLAG COMPLEX, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER :: UNDERL0MAP INTEGER NBFIN, MYROOT_LEFT INTEGER POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INODE, IFATH INTEGER III, LEAF LOGICAL BLOQ EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE LOGICAL ERROR_WAS_BROADCASTED DUMMY(1) = 1 KEEP(266)=0 POSIWCB = LIWCB POSWCB = LWCB PLEFTWCB= 1_8 PTRICB = 0 LEAF = MYLEAF + 1 III = 1 NBFIN = SLAVEF MYROOT_LEFT = MYROOT IF ( MYROOT_LEFT .EQ. 0 ) THEN NBFIN = NBFIN - 1 CALL CMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, & RACINE_SOLVE, SLAVEF, KEEP) IF (NBFIN.EQ.0) GOTO 260 END IF IF ( INFO(1) .LT. 0 ) THEN GOTO 260 ENDIF 50 CONTINUE IF (SLAVEF .EQ. 1) THEN CALL CMUMPS_GET_INODE_FROM_POOL & ( IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF IF (SLAVEF .EQ. 1) THEN FLAG = .FALSE. ELSE BLOQ = ( ( III .EQ. LEAF ) & ) CALL CMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) ENDIF IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 IF (.not. FLAG) THEN IF (III .NE. LEAF) THEN CALL CMUMPS_GET_INODE_FROM_POOL & (IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF ENDIF GOTO 50 60 CONTINUE IF (KEEP(400) .GT. 0 ) THEN UNDERL0MAP = L0_OMP_MAPPING(STEP(INODE)) ELSE UNDERL0MAP = 0 ENDIF IF (UNDERL0MAP .EQ. 0 .OR. KEEP(201).GT.0) THEN CALL CMUMPS_SET_STATIC_PTR(A) CALL CMUMPS_GET_TMP_PTR(A_PTR) LA_PTR = LA ELSE A_PTR => L0_OMP_FACTORS(UNDERL0MAP)%A LA_PTR = L0_OMP_FACTORS(UNDERL0MAP)%LA ENDIF CALL CMUMPS_SOLVE_NODE_FWD( INODE, & huge(INODE), huge(INODE), & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, N, & IPOOL, LPOOL, LEAF, NBFIN, NSTK, & IWCB, LIWCB, WCB, LWCB, A_PTR(1), LA_PTR, & IW, LIW, NRHS, & POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE & , FROM_PP & , ERROR_WAS_BROADCASTED & ) IF ( INFO(1) .LT. 0 ) THEN IF (.NOT. ERROR_WAS_BROADCASTED) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF GOTO 260 ENDIF IFATH = DAD(STEP(INODE)) IF ( IFATH .EQ. 0 ) THEN MYROOT_LEFT = MYROOT_LEFT - 1 IF (MYROOT_LEFT .EQ. 0) THEN NBFIN = NBFIN - 1 IF (SLAVEF .GT. 1) THEN CALL CMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, & COMM, RACINE_SOLVE, SLAVEF, KEEP) ENDIF END IF ELSE IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IFATH)), KEEP(199)) & .EQ. MYID ) THEN IF ( PTRICB(STEP(INODE)) .EQ. 1 .OR. & PTRICB(STEP(INODE)) .EQ. -1 ) THEN NSTK(STEP(IFATH)) = NSTK(STEP(IFATH)) - 1 IF (NSTK(STEP(IFATH)) .EQ. 0) THEN IPOOL(LEAF) = IFATH LEAF = LEAF + 1 IF (LEAF .GT. LPOOL) THEN WRITE(*,*) & 'Internal error CMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() ENDIF ENDIF PTRICB(STEP(INODE)) = 0 ENDIF ENDIF ENDIF IF ( NBFIN .EQ. 0 ) GOTO 260 GOTO 50 260 CONTINUE CALL MUMPS_CLEAN_PENDING(INFO(1), KEEP, BUFR, LBUFR,LBUFR_BYTES, & COMM, DUMMY(1), & SLAVEF, .TRUE., .FALSE.) RETURN END SUBROUTINE CMUMPS_SOL_R MUMPS_5.8.1/src/cana_LDLT_preprocess.F0000664000175000017500000007133615042446440017337 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SET_CONSTRAINTS( & N,PIV,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8, ROWSCA & ) USE CMUMPS_STRUC_DEF IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(OUT) :: NCST INTEGER :: PIV(N),FRERE(N),FILS(N),NFSIZ(N),IKEEP(N) INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) REAL :: ROWSCA(N) INTEGER I,P11,P1,P2,K1,K2,NLOCKED LOGICAL V1,V2 NCST = 0 NLOCKED = 0 P11 = KEEP(93) DO I=KEEP(93)-1,1,-2 P1 = PIV(I) P2 = PIV(I+1) K1 = IKEEP(P1) IF (K1 .NE. 0) THEN V1 = (K1+2*exponent(ROWSCA(P1)) .GE. -3) ELSE V1 = .FALSE. ENDIF K2 = IKEEP(P2) IF (K2 .NE. 0) THEN V2 = (K2+exponent(ROWSCA(P2)**2) .GE. -3) ELSE V2 = .FALSE. ENDIF IF(V1 .AND. V2) THEN PIV(P11) = P1 P11 = P11 - 1 PIV(P11) = P2 P11 = P11 - 1 ELSE IF(V1) THEN NCST = NCST+1 FRERE(NCST) = P1 NCST = NCST+1 FRERE(NCST) = P2 ELSE IF(V2) THEN NCST = NCST+1 FRERE(NCST) = P2 NCST = NCST+1 FRERE(NCST) = P1 ELSE NLOCKED = NLOCKED + 1 FILS(NLOCKED) = P1 NLOCKED = NLOCKED + 1 FILS(NLOCKED) = P2 ENDIF ENDDO DO I=1,NLOCKED PIV(I) = FILS(I) ENDDO KEEP(94) = KEEP(94) + KEEP(93) - NLOCKED KEEP(93) = NLOCKED DO I=1,NCST NLOCKED = NLOCKED + 1 PIV(NLOCKED) = FRERE(I) ENDDO DO I=1,KEEP(93)/2 NFSIZ(I) = 0 ENDDO DO I=(KEEP(93)/2)+1,(KEEP(93)/2)+NCST,2 NFSIZ(I) = I+1 NFSIZ(I+1) = -1 ENDDO DO I=(KEEP(93)/2)+NCST+1,(KEEP(93)/2)+KEEP(94) NFSIZ(I) = 0 ENDDO END SUBROUTINE CMUMPS_SET_CONSTRAINTS SUBROUTINE CMUMPS_EXPAND_PERMUTATION(N,NCMP,N11,N22,PIV, & INVPERM,PERM) IMPLICIT NONE INTEGER N11,N22,N,NCMP INTEGER, intent(in) :: PIV(N),PERM(N) INTEGER, intent (out):: INVPERM(N) INTEGER CMP_POS,EXP_POS,I,J,N2,K N2 = N22/2 EXP_POS = 1 DO CMP_POS=1,NCMP J = PERM(CMP_POS) IF(J .LE. N2) THEN K = 2*J-1 I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 K = K+1 I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ELSE K = N2 + J I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ENDIF ENDDO DO K=N22+N11+1,N I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ENDDO RETURN END SUBROUTINE CMUMPS_EXPAND_PERMUTATION SUBROUTINE CMUMPS_LDLT_COMPRESS( & N,NZ, IRN, ICN, PIV, & NCMP, IW, LW, IPE, LEN, IQ, & FLAG, ICMP, IWFR, & IERROR, KEEP,KEEP8, ICNTL,INPLACE64_GRAPH_COPY) IMPLICIT NONE INTEGER, intent(in) :: N INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: IRN(NZ), ICN(NZ), PIV(N) INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(out) :: NCMP, IERROR INTEGER(8), intent(out) :: IWFR, IPE(N+1) INTEGER, intent(out) :: IW(LW) INTEGER, intent(out) :: LEN(N) INTEGER(8), intent(out) :: IQ(N) INTEGER, intent(out) :: FLAG(N), ICMP(N) LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: N11, N22 INTEGER :: I, J, N1, K INTEGER(8) :: NDUP, L, K8, K1, K2, LAST IERROR = 0 N22 = KEEP(93) N11 = KEEP(94) NCMP = N22/2 + N11 DO I=1,NCMP IPE(I) = 0 ENDDO K = 1 DO I=1,N22/2 J = PIV(K) ICMP(J) = I K = K + 1 J = PIV(K) ICMP(J) = I K = K + 1 ENDDO K = N22/2 + 1 DO I=N22+1,N22+N11 J = PIV(I) ICMP(J) = K K = K + 1 ENDDO DO I=N11+N22+1,N J = PIV(I) ICMP(J) = 0 ENDDO DO K8=1,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ICMP(I) J = ICMP(J) IF ((I.NE.0).AND.(J.NE.0).AND.(I.NE.J)) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 ENDIF ENDIF ENDDO IQ(1) = 1_8 N1 = NCMP - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(NCMP)+IQ(NCMP)-1_8,IQ(NCMP)) DO I = 1,NCMP FLAG(I) = 0 IPE(I) = IQ(I) ENDDO IW(1:LAST) = 0 IWFR = LAST + 1_8 DO K8=1,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ICMP(I) J = ICMP(J) IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1_8 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1_8 ENDIF ENDIF ENDIF ENDDO NDUP = 0_8 DO I=1,NCMP K1 = IPE(I) K2 = IQ(I) -1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) GO TO 250 L = IQ(J) IQ(J) = L + 1_8 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(L) = 0 IW(K8) = 0 ELSE IW(L) = I IW(K8) = J FLAG(J) = I ENDIF ENDDO 250 LEN(I) = int(IQ(I) - IPE(I)) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,NCMP K1 = IPE(I) IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF ENDDO LEN(I) = int(IWFR - L) ENDDO ENDIF IPE(NCMP+1) = IPE(NCMP) + int(LEN(NCMP),8) IWFR = IPE(NCMP+1) INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1_8)) RETURN END SUBROUTINE CMUMPS_LDLT_COMPRESS SUBROUTINE CMUMPS_SYM_MWM( & N, NE, IP, IRN, SCALING,LSC,CPERM, DIAG, & ICNTL, WEIGHT,MARKED,FLAG, & PIV_OUT, INFO) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NE INTEGER :: ICNTL(10), INFO(10),LSC INTEGER :: CPERM(N),PIV_OUT(N), IRN(NE), DIAG(N) INTEGER(8), INTENT(IN) :: IP(N+1) REAL :: SCALING(LSC),WEIGHT(N+2) INTEGER :: MARKED(N),FLAG(N) INTEGER :: NUM1,NUM2,NUMTOT,PATH_LENGTH,NLAST INTEGER :: I,BEST_BEG, CUR_EL,CUR_EL_PATH,CUR_EL_PATH_NEXT INTEGER :: L1,L2,TUP,T22 INTEGER(8) :: PTR_SET1,PTR_SET2 REAL :: BEST_SCORE,CUR_VAL,TMP,VAL REAL INITSCORE, CMUMPS_UPDATESCORE, & CMUMPS_UPDATE_INVERSE, CMUMPS_METRIC2x2 LOGICAL VRAI,FAUX,MAX_CARD_DIAG,USE_SCALING INTEGER SUM REAL ZERO,ONE PARAMETER (SUM = 1, VRAI = .TRUE., FAUX = .FALSE.) PARAMETER(ZERO = 0.0E0, ONE = 1.0E0) MAX_CARD_DIAG = .TRUE. NUM1 = 0 NUM2 = 0 NUMTOT = 0 NLAST = N INFO = 0 MARKED = 1 FLAG = 0 VAL = ONE IF(LSC .GT. 1) THEN USE_SCALING = .TRUE. ELSE USE_SCALING = .FALSE. ENDIF TUP = ICNTL(2) IF(TUP .EQ. SUM) THEN INITSCORE = ZERO ELSE INITSCORE = ONE ENDIF IF(ICNTL(2) .GT. 2 .OR. ICNTL(2) .LE. 0) THEN WRITE(*,*) & 'ERROR: WRONG VALUE FOR ICNTL(2) = ',ICNTL(2) INFO(1) = -1 RETURN ENDIF T22 = ICNTL(1) IF(ICNTL(1) .LT. 0 .OR. ICNTL(1) .GT. 2) THEN WRITE(*,*) & 'ERROR: WRONG VALUE FOR ICNTL(1) = ',ICNTL(1) INFO(1) = -1 RETURN ENDIF DO CUR_EL=1,N IF(MARKED(CUR_EL) .LE. 0) THEN CYCLE ENDIF IF(CPERM(CUR_EL) .LT. 0) THEN MARKED(CUR_EL) = -1 CYCLE ENDIF PATH_LENGTH = 2 CUR_EL_PATH = CPERM(CUR_EL) IF(CUR_EL_PATH .EQ. CUR_EL) THEN MARKED(CUR_EL) = -1 CYCLE ENDIF MARKED(CUR_EL) = 0 WEIGHT(1) = INITSCORE WEIGHT(2) = INITSCORE L1 = int(IP(CUR_EL+1)-IP(CUR_EL)) L2 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH)) PTR_SET1 = IP(CUR_EL) PTR_SET2 = IP(CUR_EL_PATH) IF(USE_SCALING) THEN VAL = -SCALING(CUR_EL_PATH) - SCALING(CUR_EL+N) ENDIF CUR_VAL = CMUMPS_METRIC2x2( & CUR_EL,CUR_EL_PATH, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,FAUX,T22) WEIGHT(PATH_LENGTH+1) = & CMUMPS_UPDATESCORE(WEIGHT(1),CUR_VAL,TUP) DO IF(CUR_EL_PATH .EQ. CUR_EL) EXIT PATH_LENGTH = PATH_LENGTH+1 MARKED(CUR_EL_PATH) = 0 CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH) L1 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH)) L2 = int(IP(CUR_EL_PATH_NEXT+1)-IP(CUR_EL_PATH_NEXT)) PTR_SET1 = IP(CUR_EL_PATH) PTR_SET2 = IP(CUR_EL_PATH_NEXT) IF(USE_SCALING) THEN VAL = -SCALING(CUR_EL_PATH_NEXT) & - SCALING(CUR_EL_PATH+N) ENDIF CUR_VAL = CMUMPS_METRIC2x2( & CUR_EL_PATH,CUR_EL_PATH_NEXT, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,VRAI,T22) WEIGHT(PATH_LENGTH+1) = & CMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH-1),CUR_VAL,TUP) CUR_EL_PATH = CUR_EL_PATH_NEXT ENDDO IF(mod(PATH_LENGTH,2) .EQ. 1) THEN IF(WEIGHT(PATH_LENGTH+1) .GE. WEIGHT(PATH_LENGTH)) THEN CUR_EL_PATH = CPERM(CUR_EL) ELSE CUR_EL_PATH = CUR_EL ENDIF DO I=1,(PATH_LENGTH-1)/2 NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO NUMTOT = NUMTOT + PATH_LENGTH - 1 ELSE IF(MAX_CARD_DIAG) THEN CUR_EL_PATH = CPERM(CUR_EL) IF(DIAG(CUR_EL) .NE. 0) THEN BEST_BEG = CUR_EL_PATH GOTO 1000 ENDIF DO I=1,(PATH_LENGTH/2) CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH) IF(DIAG(CUR_EL_PATH) .NE. 0) THEN BEST_BEG = CUR_EL_PATH_NEXT GOTO 1000 ENDIF ENDDO ENDIF BEST_BEG = CUR_EL BEST_SCORE = WEIGHT(PATH_LENGTH-1) CUR_EL_PATH = CPERM(CUR_EL) DO I=1,(PATH_LENGTH/2)-1 TMP = CMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH), & WEIGHT(2*I-1),TUP) TMP = CMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I),TUP) IF(TMP .GT. BEST_SCORE) THEN BEST_SCORE = TMP BEST_BEG = CUR_EL_PATH ENDIF CUR_EL_PATH = CPERM(CUR_EL_PATH) TMP = CMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH+1), & WEIGHT(2*I),TUP) TMP = CMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I+1),TUP) IF(TMP .GT. BEST_SCORE) THEN BEST_SCORE = TMP BEST_BEG = CUR_EL_PATH ENDIF CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO 1000 CUR_EL_PATH = BEST_BEG DO I=1,(PATH_LENGTH/2)-1 NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO NUMTOT = NUMTOT + PATH_LENGTH - 2 MARKED(CUR_EL_PATH) = -1 ENDIF ENDDO DO I=1,N IF(MARKED(I) .LT. 0) THEN IF(DIAG(I) .EQ. 0) THEN PIV_OUT(NLAST) = I NLAST = NLAST - 1 ELSE NUM1 = NUM1 + 1 PIV_OUT(NUM2+NUM1) = I NUMTOT = NUMTOT + 1 ENDIF ENDIF ENDDO INFO(2) = NUMTOT INFO(3) = NUM1 INFO(4) = NUM2 RETURN END SUBROUTINE CMUMPS_SYM_MWM FUNCTION CMUMPS_UPDATESCORE(A,B,T) IMPLICIT NONE REAL CMUMPS_UPDATESCORE REAL A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN CMUMPS_UPDATESCORE = A+B ELSE CMUMPS_UPDATESCORE = A*B ENDIF END FUNCTION CMUMPS_UPDATESCORE FUNCTION CMUMPS_UPDATE_INVERSE(A,B,T) IMPLICIT NONE REAL CMUMPS_UPDATE_INVERSE REAL A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN CMUMPS_UPDATE_INVERSE = A-B ELSE CMUMPS_UPDATE_INVERSE = A/B ENDIF END FUNCTION CMUMPS_UPDATE_INVERSE FUNCTION CMUMPS_METRIC2x2(CUR_EL,CUR_EL_PATH, & SET1,SET2,L1,L2,VAL,DIAG,N,FLAG,FLAGON,T) IMPLICIT NONE REAL CMUMPS_METRIC2x2 INTEGER CUR_EL,CUR_EL_PATH,L1,L2,N INTEGER SET1(L1),SET2(L2),DIAG(N),FLAG(N) REAL VAL LOGICAL FLAGON INTEGER T INTEGER I,INTER,MERGE INTEGER STRUCT,MA47 PARAMETER(STRUCT=0,MA47=1) IF(T .EQ. STRUCT) THEN IF(.NOT. FLAGON) THEN DO I=1,L1 FLAG(SET1(I)) = CUR_EL ENDDO ENDIF INTER = 0 DO I=1,L2 IF(FLAG(SET2(I)) .EQ. CUR_EL) THEN INTER = INTER + 1 FLAG(SET2(I)) = CUR_EL_PATH ENDIF ENDDO MERGE = L1 + L2 - INTER CMUMPS_METRIC2x2 = real(INTER) / real(MERGE) ELSE IF (T .EQ. MA47) THEN MERGE = 3 IF(DIAG(CUR_EL) .NE. 0) MERGE = 2 IF(DIAG(CUR_EL_PATH) .NE. 0) MERGE = MERGE - 2 IF(MERGE .EQ. 0) THEN CMUMPS_METRIC2x2 = real(L1+L2-2) CMUMPS_METRIC2x2 = -(CMUMPS_METRIC2x2**2)/2.0E0 ELSE IF(MERGE .EQ. 1) THEN CMUMPS_METRIC2x2 = - real(L1+L2-4) * real(L1-2) ELSE IF(MERGE .EQ. 2) THEN CMUMPS_METRIC2x2 = - real(L1+L2-4) * real(L2-2) ELSE CMUMPS_METRIC2x2 = - real(L1-2) * real(L2-2) ENDIF ELSE CMUMPS_METRIC2x2 = VAL ENDIF RETURN END FUNCTION SUBROUTINE CMUMPS_EXPAND_PERM_SCHUR(NA, NCMP, & INVPERM,PERM, & LISTVAR_SCHUR, SIZE_SCHUR, AOTOA) IMPLICIT NONE INTEGER, INTENT(IN):: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN):: NA, NCMP INTEGER, INTENT(IN):: AOTOA(NCMP), PERM(NCMP) INTEGER, INTENT(OUT):: INVPERM(NA) INTEGER CMP_POS, IO, I, K, IPOS DO CMP_POS=1, NCMP IO = PERM(CMP_POS) INVPERM(AOTOA(IO)) = CMP_POS ENDDO IPOS = NCMP DO K =1, SIZE_SCHUR I = LISTVAR_SCHUR(K) IPOS = IPOS+1 INVPERM(I) = IPOS ENDDO RETURN END SUBROUTINE CMUMPS_EXPAND_PERM_SCHUR SUBROUTINE CMUMPS_GNEW_SCHUR & (NA, N, NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, NBQD, AvgDens, & KEEP264, KEEP265, & LISTVAR_SCHUR, SIZE_SCHUR, ATOAO, AOTOA, & INPLACE64_GRAPH_COPY & ) IMPLICIT NONE INTEGER, intent(in) :: NA INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, intent(out) :: IERROR, symmetry INTEGER, intent(out) :: NBQD, AvgDens INTEGER, intent(out) :: LEN(N), IW(LW) INTEGER(8), intent(out):: IWFR INTEGER(8), intent(out):: NRORM, NIORM INTEGER(8), intent(out):: IPE(N+1) INTEGER, INTENT(OUT) :: AOTOA(N) INTEGER, INTENT(OUT) :: ATOAO(NA) INTEGER, intent(inout) :: IFLAG, KEEP264 INTEGER, intent(in) :: KEEP265 INTEGER(8), intent(out):: IQ(N) INTEGER, intent(out) :: FLAG(N) LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, MPG, I, J, N1 INTEGER :: NBERR, THRESH, IAO INTEGER(8) :: K8, K1, K2, LAST, NDUP INTEGER(8) :: NZOFFA, NDIAGA, L, N8 REAL :: RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) ATOAO(1:NA) = 0 DO I = 1, SIZE_SCHUR ATOAO(LISTVAR_SCHUR(I)) = -1 ENDDO IAO = 0 DO I= 1, NA IF (ATOAO(I).LT.0) CYCLE IAO = IAO +1 ATOAO(I) = IAO AOTOA(IAO) = I ENDDO NZOFFA = 0_8 NDIAGA = 0 IERROR = 0 N8 = int(N,8) DO I=1,N+1 IPE(I) = 0_8 ENDDO IF (KEEP264.EQ.0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ENDIF IF (IERROR.GE.1) THEN KEEP264 = 0 ELSE KEEP264 = 1 ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.EQ.J) THEN NDIAGA = NDIAGA + 1_8 ELSE IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDDO ENDIF ENDIF NIORM = NZOFFA + 3_8*N8 IF (IERROR.GE.1) THEN NBERR = 0 IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN WRITE (MP,99999) DO 70 K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR. & (10_8.LE.K8 .AND. K8.LE.20_8)) THEN WRITE (MP,'(I16,A,I10,A,I10,A)') & K8,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K8,10_8).EQ.1_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'st entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.2_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.3_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2_8*N8 IQ(1) = 1_8 N1 = N - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(N)+IQ(N)-1,IQ(N)) FLAG(1:N) = 0 IPE(1:N) = IQ(1:N) IW(1:LAST) = 0 IWFR = LAST + 1_8 IF (KEEP264 .EQ. 0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF (I.LT.J) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDDO ENDIF ENDIF IF (KEEP265.EQ.0) THEN NDUP = 0_8 DO I=1,N K1 = IPE(I) K2 = IQ(I) - 1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) EXIT IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE L = IQ(J) IQ(J) = L + 1 IW(L) = I IW(K8) = J FLAG(J) = I ENDIF END DO LEN(I) = int(IQ(I) - IPE(I)) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,N IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K1 = IPE(I) K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF 270 CONTINUE LEN(I) = int(IWFR - L) ENDDO ENDIF IPE(N+1) = IPE(N) + int(LEN(N),8) IWFR = IPE(N+1) ELSE IPE(1) = 1_8 DO I = 1, N LEN(I) = int(IQ(I) - IPE(I)) ENDDO DO I = 1, N IPE(I+1) = IPE(I) + int(LEN(I),8) ENDDO IWFR = IPE(N+1) ENDIF symmetry = 100 IF (SYM.EQ.0) THEN RSYM = real(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/ & real(NZOFFA+NDIAGA) IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) THEN ENDIF symmetry = nint (100.0E0*RSYM) IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) ) & write(MPG,'(A,A,I5)') & ' Case of Schur:', & ' structural symmetry (in percent) of interior block=', & symmetry IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) ) & write(MP,'(A,A,I5)') & ' Case of Schur:', & ' structural symmetry (in percent) of interior block=', & symmetry ELSE symmetry = 100 ENDIF INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1)) AvgDens = nint(real(IWFR-1_8)/real(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN DO I= 1, N J = max(LEN(I),1) IF (J.GT.THRESH) NBQD = NBQD+1 ENDDO ENDIF IF (MPG .GT. 0.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE CMUMPS_GNEW_SCHUR SUBROUTINE CMUMPS_GET_PERM_FROM_PE(N,PE,INVPERM,NFILS,WORK) IMPLICIT NONE INTEGER N INTEGER PE(N),INVPERM(N),NFILS(N),WORK(N) INTEGER I,FATHER,STKLEN,STKPOS,PERMPOS,CURVAR NFILS = 0 DO I=1,N FATHER = -PE(I) IF(FATHER .NE. 0) NFILS(FATHER) = NFILS(FATHER) + 1 ENDDO STKLEN = 0 PERMPOS = 1 DO I=1,N IF(NFILS(I) .EQ. 0) THEN STKLEN = STKLEN + 1 WORK(STKLEN) = I INVPERM(I) = PERMPOS PERMPOS = PERMPOS + 1 ENDIF ENDDO DO STKPOS = 1,STKLEN CURVAR = WORK(STKPOS) FATHER = -PE(CURVAR) DO IF(FATHER .EQ. 0) EXIT IF(NFILS(FATHER) .EQ. 1) THEN INVPERM(FATHER) = PERMPOS FATHER = -PE(FATHER) PERMPOS = PERMPOS + 1 ELSE NFILS(FATHER) = NFILS(FATHER) - 1 EXIT ENDIF ENDDO ENDDO RETURN END SUBROUTINE CMUMPS_GET_PERM_FROM_PE SUBROUTINE CMUMPS_GET_ELIM_TREE(N,PE,NV,WORK) IMPLICIT NONE INTEGER N INTEGER PE(N),NV(N),WORK(N) INTEGER I,FATHER,LEN,NEWSON,NEWFATHER DO I=1,N IF(NV(I) .GT. 0) CYCLE LEN = 1 WORK(LEN) = I FATHER = -PE(I) DO IF(NV(FATHER) .GT. 0) THEN NEWSON = FATHER EXIT ENDIF LEN = LEN + 1 WORK(LEN) = FATHER NV(FATHER) = 1 FATHER = -PE(FATHER) ENDDO NEWFATHER = -PE(FATHER) PE(WORK(LEN)) = -NEWFATHER PE(NEWSON) = -WORK(1) ENDDO END SUBROUTINE CMUMPS_GET_ELIM_TREE MUMPS_5.8.1/src/zfac_driver.F0000664000175000017500000056543315042446442015657 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_FAC_DRIVER(id,idintr) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_INI_MYID, MUMPS_BUF_INIT, & MUMPS_BUF_ALLOC_SMALL_BUF, MUMPS_BUF_DEALL_SMALL_BUF, & MUMPS_BUF_DIST_IRECV_SIZE USE MUMPS_LOAD USE ZMUMPS_OOC, ONLY : ZMUMPS_OOC_INIT_FACTO, & ZMUMPS_OOC_END_FACTO USE ZMUMPS_STRUC_DEF USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_INTR_STRUC USE ZMUMPS_FACSOL_L0OMP_M, ONLY: ZMUMPS_FREE_L0_OMP_FACTORS, & ZMUMPS_INIT_L0_OMP_FACTORS USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY: ZMUMPS_DM_ALLOC_S_WK, & ZMUMPS_DM_FREE_S_WK USE MUMPS_LR_STATS USE ZMUMPS_LR_DATA_M, only: ZMUMPS_BLR_INIT_MODULE, & ZMUMPS_BLR_END_MODULE & , ZMUMPS_BLR_MOD_TO_STRUC USE ZMUMPS_FAC_COMPACT_FACTORS_M, ONLY: & ZMUMPS_TRY_COMPACT_FACTORS USE MUMPS_PIVNUL_MOD, only: PIVNUL_LIST_STRUCT_T USE MUMPS_FRONT_DATA_MGT_M #if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M #endif #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif !$ USE OMP_LIB C Derived datatype to pass pointers with implicit interfaces USE ZMUMPS_FAC_S_IS_POINTERS_M, ONLY : ZMUMPS_S_IS_POINTERS_T IMPLICIT NONE C C Purpose C ======= C C Performs scaling, sorting in arrowhead, then C distributes the matrix, and perform C factorization. C C INTERFACE SUBROUTINE ZMUMPS_ANORMINF(id, ANORMINF, LSCAL, EFF_SIZE_SCHUR) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET :: id DOUBLE PRECISION, INTENT(OUT) :: ANORMINF LOGICAL, INTENT(IN) :: LSCAL INTEGER, INTENT(IN) :: EFF_SIZE_SCHUR END SUBROUTINE ZMUMPS_ANORMINF END INTERFACE C C Parameters C ========== C TYPE (ZMUMPS_STRUC), TARGET :: id TYPE (ZMUMPS_INTR_STRUC) :: idintr C C MPI C === C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 C C Local variables C =============== C INCLUDE 'mumps_headers.h' INTEGER(8) :: NSEND8, NSEND_TOT8 INTEGER(8) :: NLOCAL8, NLOCAL_TOT8 INTEGER(4) :: I4 INTEGER :: LDPTRAR, NELT_arg, NBRECORDS INTEGER :: ITMP, JTMP INTEGER :: KEEP464COPY, KEEP465COPY INTEGER(8) :: KEEP826_SAVE INTEGER(8) :: K67, K68, K70, K74, K75 INTEGER(8) ITMP8 INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER MP, LP, MPG, allocok LOGICAL PROK, PROKG, LSCAL, LPOK, COMPUTE_ANORMINF C Reception buffer INTEGER :: ZMUMPS_LBUFR, ZMUMPS_LBUFR_BYTES INTEGER(8) :: ZMUMPS_LBUFR_BYTES8 ! for intermediate computation INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFR C Size of send buffers (in bytes) INTEGER :: ZMUMPS_LBUF, ZMUMPS_LBUF_INT INTEGER(8) :: ZMUMPS_LBUF8 ! for intermediate computation C INTEGER PTRIST, PTRWB, MAXELT_SIZE, & ITLOC, IPOOL, LPOOL INTEGER IRANK, ID_ROOT INTEGER KKKK INTEGER(8) :: NZ_locMAX8 INTEGER(8) MEMORY_MD_ARG INTEGER(8) MAXS_BASE8, MAXS_BASE_RELAXED8 DOUBLE PRECISION CNTL4, AVG_FLOPS INTEGER MIN_PERLU, MAXIS_ESTIM INTEGER SUM_INFO22_THIS_NODE, MAX_SUM_INFO22_THIS_NODE C TYPE (ZMUMPS_S_IS_POINTERS_T) :: S_IS_POINTERS INTEGER :: MAXIS INTEGER(8) :: MAXS INTEGER :: ICNTL49_LOC, TMP_INFOG_4 C For S argument to arrowhead routines: INTEGER(8) :: MAXS_ARG COMPLEX(kind=8), TARGET :: S_DUMMY_ARG(1) COMPLEX(kind=8), POINTER, DIMENSION(:) :: S_PTR_ARG TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT C Arrowheads INTEGER, ALLOCATABLE, DIMENSION(:) :: INTARR COMPLEX(kind=8), POINTER, DIMENSION(:) :: DBLARR C (pointer to point on used-data in some cases--elt-entry) DOUBLE PRECISION TMPTIME INTEGER NOMP INTEGER NB_THREADS DOUBLE PRECISION TIMEAVG, TIMEMAX, & FLOPAVG, FLOPMAX DOUBLE PRECISION TMPFLOP INTEGER NPIV_CRITICAL_PATH, EFF_SIZE_SCHUR DOUBLE PRECISION TIME, TIMEET DOUBLE PRECISION ZERO, ONE, MONE PARAMETER( ZERO = 0.0D0, ONE = 1.0D0, MONE = -1.0D0) COMPLEX(kind=8) CZERO PARAMETER( CZERO = (0.0D0, 0.0D0) ) INTEGER PERLU, TOTAL_MBYTES, K231, K232, K233, BLR_STRAT INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. INTEGER, PARAMETER :: PANEL_TABSIZE = 20 INTEGER COLOUR, COMM_FOR_SCALING ! For Simultaneous scaling INTEGER(8) :: LIWK, LIWK8 INTEGER(8) :: LWK, LWK_REAL, LWRKR_TH, LWRKC_TH INTEGER :: NOMP_MAX C I_AM_SLAVE: used to determine if proc has the role of a slave C WK_USER_PROVIDED is set to true when WK_USER is provided by user LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED, EARLYT3ROOTINS LOGICAL PRINT_MAXAVG, PRINT_NODEINFO DOUBLE PRECISION :: ANORMINF, SEUIL, SEUIL_LDLT_NIV2, Thresh_Seuil DOUBLE PRECISION :: CNTL1, CNTL3, CNTL5, CNTL6, EPS INTEGER N, LPN_LIST,POSBUF INTEGER, DIMENSION (:), ALLOCATABLE :: ITMP2 INTEGER I,K INTEGER(8) :: ITEMP8 INTEGER :: PARPIV_T1 INTEGER FRONTWISE C temporary variables for collecting stats from all processors INTEGER, PARAMETER :: LR_DKEEPSHIFT=49, LR_TABSIZE=18 DOUBLE PRECISION :: LR_TAB(LR_TABSIZE), LR_EPSILON DOUBLE PRECISION :: TMP_MRY_LU_FR DOUBLE PRECISION :: TMP_MRY_LU_LRGAIN INTEGER :: KEEP399_SAVE, KEEP20_SAVE DOUBLE PRECISION :: TMP_MRY_CB_FR DOUBLE PRECISION :: TMP_MRY_CB_LRGAIN DOUBLE PRECISION :: TMP_FLOP_LRGAIN DOUBLE PRECISION :: TMP_FLOP_TRSM DOUBLE PRECISION :: TMP_FLOP_PANEL DOUBLE PRECISION :: TMP_FLOP_FRFRONTS DOUBLE PRECISION :: TMP_FLOP_TRSM_FR DOUBLE PRECISION :: TMP_FLOP_TRSM_LR DOUBLE PRECISION :: TMP_FLOP_UPDATE_FR DOUBLE PRECISION :: TMP_FLOP_UPDATE_LR DOUBLE PRECISION :: TMP_FLOP_UPDATE_LRLR3 DOUBLE PRECISION :: TMP_FLOP_COMPRESS DOUBLE PRECISION :: TMP_FLOP_DECOMPRESS DOUBLE PRECISION :: TMP_FLOP_MIDBLK_COMPRESS DOUBLE PRECISION :: TMP_FLOP_FRSWAP_COMPRESS DOUBLE PRECISION :: TMP_FLOP_ACCUM_COMPRESS DOUBLE PRECISION :: TMP_FLOP_CB_COMPRESS DOUBLE PRECISION :: TMP_FLOP_CB_DECOMPRESS DOUBLE PRECISION :: TMP_FLOP_FACTO_FR INTEGER :: TMP_CNT_NODES DOUBLE PRECISION :: TMP_TIME_UPDATE DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR1 DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR2 DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR3 DOUBLE PRECISION :: TMP_TIME_UPDATE_FRLR DOUBLE PRECISION :: TMP_TIME_UPDATE_FRFR DOUBLE PRECISION :: TMP_TIME_COMPRESS DOUBLE PRECISION :: TMP_TIME_MIDBLK_COMPRESS DOUBLE PRECISION :: TMP_TIME_FRSWAP_COMPRESS DOUBLE PRECISION :: TMP_TIME_CB_COMPRESS DOUBLE PRECISION :: TMP_TIME_PANEL DOUBLE PRECISION :: TMP_TIME_FAC_I DOUBLE PRECISION :: TMP_TIME_FAC_MQ DOUBLE PRECISION :: TMP_TIME_FAC_SQ DOUBLE PRECISION :: TMP_TIME_LRTRSM DOUBLE PRECISION :: TMP_TIME_FRTRSM DOUBLE PRECISION :: TMP_TIME_FRFRONTS DOUBLE PRECISION :: TMP_TIME_LR_MODULE DOUBLE PRECISION :: TMP_TIME_DIAGCOPY DOUBLE PRECISION :: TMP_TIME_DECOMP DOUBLE PRECISION :: TMP_TIME_DECOMP_UCFS DOUBLE PRECISION :: TMP_TIME_LRASM_NIV1 DOUBLE PRECISION :: TMP_TIME_LRASM_LOCASM2 DOUBLE PRECISION :: TMP_TIME_LRASM_MAPLIG1 DOUBLE PRECISION :: TMP_TIME_LRASM_CONTRIB2 DOUBLE PRECISION :: TMP_TIME_FRASM_LOCASM2 DOUBLE PRECISION :: TMP_TIME_FRASM_MAPLIG1 DOUBLE PRECISION :: TMP_TIME_FRASM_CONTRIB2 C C Workspace C INTEGER, DIMENSION(:), ALLOCATABLE :: IWK COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE :: WK DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: WK_REAL DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE:: WRKR_TH, & WRKC_TH INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWK8 INTEGER, DIMENSION(:), ALLOCATABLE :: BURP INTEGER, DIMENSION(:), ALLOCATABLE :: BUCP INTEGER, DIMENSION(:), ALLOCATABLE :: BURS INTEGER, DIMENSION(:), ALLOCATABLE :: BUCS INTEGER(8) :: BUREGISTRE(12) INTEGER(8) :: BUINTSZ, BURESZ, NZ_loc8 INTEGER :: BUJOB INTEGER BUMAXMN, M, SCMYID, SCNPROCS DOUBLE PRECISION SCONEERR, SCINFERR C C Parameters arising from the structure C ===================================== C * Control parameters: see description in ZMUMPSID DOUBLE PRECISION,DIMENSION(:),POINTER::RINFO, RINFOG DOUBLE PRECISION,DIMENSION(:),POINTER:: CNTL INTEGER,DIMENSION(:),POINTER :: INFOG, KEEP INTEGER, DIMENSION(:), POINTER :: IRN_loc_PTR, JCN_loc_PTR DOUBLE PRECISION, DIMENSION(:), POINTER :: COLSCA_PTR, & ROWSCA_PTR COMPLEX(kind=8), DIMENSION(:), POINTER:: A_loc_PTR INTEGER, TARGET :: DUMMYIRN_loc(1), DUMMYJCN_loc(1) DOUBLE PRECISION, TARGET :: DUMMYSCA(1) COMPLEX(kind=8), TARGET :: DUMMYA_loc(1) INTEGER,DIMENSION(:),POINTER::ICNTL EXTERNAL MUMPS_GET_POOL_LENGTH INTEGER MUMPS_GET_POOL_LENGTH, SIZESCAL INTEGER(8) :: TOTAL_BYTES C C External references C =================== INTEGER, EXTERNAL :: MUMPS_NUMROC INTEGER:: NWORKING LOGICAL:: MEM_EFF_ALLOCATED INTEGER :: TOTAL_MBYTES_UNDER_L0 INTEGER(8):: TOTAL_BYTES_UNDER_L0 C Fwd in facto: COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS_MUMPS LOGICAL :: RHS_MUMPS_ALLOCATED LOGICAL :: DBLARR_ALLOCATED INTEGER :: NB_ACTIVE_FRONTS_ESTIM INTEGER :: NB_FRONTS_F_ESTIM INTEGER :: KEEP_486_FOR_PRINT C C -------------------------- C Pointers used as shortcuts C -------------------------- RINFO=>id%RINFO RINFOG=>id%RINFOG CNTL=>id%CNTL INFOG=>id%INFOG KEEP=>id%KEEP ICNTL=>id%ICNTL IF (id%KEEP8(29) .NE. 0) THEN IRN_loc_PTR=>id%IRN_loc JCN_loc_PTR=>id%JCN_loc A_loc_PTR=>id%A_loc ELSE IRN_loc_PTR=>DUMMYIRN_loc JCN_loc_PTR=>DUMMYJCN_loc A_loc_PTR=>DUMMYA_loc ENDIF NOMP = 1 N = id%N C TIMINGS: reset to 0 id%DKEEP(92)=0.0D0 id%DKEEP(93)=0.0D0 id%DKEEP(94)=0.0D0 id%DKEEP(95)=0.0D0 id%DKEEP(96)=0.0D0 id%DKEEP(97)=0.0D0 id%DKEEP(98)=0.0D0 id%DKEEP(99)=0.0D0 id%DKEEP(56)=0.0D0 C Count of MPI messages: reset to 0 id%KEEP(266)=0 id%KEEP(267)=0 C ------------------------------------- C Depending on the type of parallelism, C the master can now (soon) potentially C have the role of a slave C ------------------------------------- I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) LIWK = 0_8 LIWK8 = 0_8 C RR related id%KEEP(17) = 0 id%INFOG(28) = 0 C Number of symmetric swaps id%KEEP8(80)=0_8 C Largest increase of internal panel size id%KEEP(425) =0 C Dynamic memory during process_blocfacto, in number of scalar entries id%KEEP8(130) = 0_8 ! instantaneous id%KEEP8(131) = 0_8 ! max id%KEEP8(132) = 0_8 ! max of max id%KEEP8(133) = 0_8 ! sum of max C Measure recursivity =max number of simultaneous calls to C ZMUMPS_FAC_PROCESS_BLOCFACTO_LDLT id%KEEP(174) = 0 id%KEEP(175) = 0 C KEEP20_SAVE = KEEP(20) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) C Print per node informtation only in case ther are several C compute nodes (id%KEEP(412): #MPI procs on comupte node) PRINT_NODEINFO = PRINT_MAXAVG .AND. id%NPROCS .NE. id%KEEP(412) C C Related to forward in facto functionality (referred to as "Fwd in facto") NULLIFY(RHS_MUMPS) NULLIFY(DBLARR) RHS_MUMPS_ALLOCATED = .FALSE. DBLARR_ALLOCATED = .FALSE. C ----------------------------------------------------------------------- C Set WK_USER_PROVIDED to true when workspace WK_USER is provided by user C We can accept WK_USER to be provided on only one proc and C different values of WK_USER per processor C WK_USER(LWK_USER): only on working processes WK_USER_PROVIDED = (id%LWK_USER.NE.0 .AND. I_AM_SLAVE) IF (WK_USER_PROVIDED) THEN IF (id%LWK_USER.GT.0) THEN id%KEEP8(24) = int(id%LWK_USER,8) ELSE id%KEEP8(24) = -int(id%LWK_USER,8)* 1000000_8 ENDIF ELSE id%KEEP8(24) = 0_8 ENDIF C Compute sum of LWK_USER provided by user CALL MPI_REDUCE ( id%KEEP8(24), id%KEEP8(124), 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) C C KEEP8(26) might be modified C (element entry format) C but need be restore for C future factorisation C with different scaling option C KEEP826_SAVE = id%KEEP8(26) C In case of loop on factorization with C different scaling options, initialize C DKEEP(4:5) to 0. id%DKEEP(4)=-1.0D0 id%DKEEP(5)=-1.0D0 C Mapping information used during solve. In case of several facto+solve C it has to be recomputed. In case of several solves with the same C facto, it is not recomputed. IF (associated(id%IPTR_WORKING)) THEN DEALLOCATE(id%IPTR_WORKING) NULLIFY(id%IPTR_WORKING) END IF IF (associated(id%WORKING)) THEN DEALLOCATE(id%WORKING) NULLIFY(id%WORKING) END IF C C Units for printing C MP: diagnostics C LP: errors C LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) IF ( PROK ) WRITE( MP, 130 ) IF ( PROKG ) WRITE( MPG, 130 ) C C Prepare work for out-of-core C IF (id%MYID .EQ. MASTER .AND. KEEP(201) .NE. -1) THEN C Note that if KEEP(201)=-1, then we have decided C at analysis phase that factors will not be stored C (neither in memory nor on disk). In that case, C ICNTL(22) is ignored. C -- ICNTL(22) must be set before facto phase C (=1 OOC on; =0 OOC off) C and cannot be changed for subsequent solve phases. KEEP(201)=id%ICNTL(22) IF (KEEP(201) .EQ. 1) THEN # if defined(OLD_OOC_NOPANEL) KEEP(201)=2 # else KEEP(201)=1 # endif ELSE id%KEEP(201)=0 ENDIF ENDIF C C ---------------------- C Broadcast ICNTL(49) IF (id%MYID.EQ.MASTER) THEN ICNTL49_LOC=id%ICNTL(49) C out of range treated as 0 IF ( (ICNTL49_LOC.GT.2).or.(ICNTL49_LOC.LT.0) ) & ICNTL49_LOC = 0 ENDIF CALL MPI_BCAST( ICNTL49_LOC, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C ---------------------- C C Broadcast few other KEEP entries that have been decoded C and are defined for facto: C ---------------------- CALL MPI_BCAST( KEEP(12), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(19), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(21), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(459), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(460), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF ( KEEP(459) .GE. PANEL_TABSIZE ) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I4,A,I3)') " ** WARNING ** KEEP(459)=",KEEP(459), & " too large, resetting to",PANEL_TABSIZE-1 ENDIF KEEP(459) = PANEL_TABSIZE - 1 ENDIF PERLU = KEEP(12) IF (id%MYID.EQ.MASTER) THEN C { C KEEP(50) case C ============== C C KEEP(50) = 0 : matrix is unsymmetric C KEEP(50) /= 0 : matrix is symmetric C KEEP(50) = 1 : Ask L L^T on the root. Matrix is PSD. C KEEP(50) = 2 : Ask for L U on the root C KEEP(50) = 3 ... L D L^T ?? C CNTL1 = id%CNTL(1) C --------------------------------------- C For symmetric (non general) matrices C set (directly) CNTL1 = 0.0 C --------------------------------------- KEEP(17)=0 C Automatic choice if CNTL(1)<0 C For rank-revealing (KEEP(19).GT.0) then C set CNTL1=0.1 even if SYM=1 IF (CNTL1.LT.ZERO) THEN C automatic choice IF (KEEP(19).GT.0) THEN CNTL1=0.1D0 ELSE IF (KEEP(50).EQ.1) THEN CNTL1=ZERO ELSE CNTL1=0.01D0 ENDIF ENDIF IF ( KEEP(50) .eq. 1 ) THEN IF (CNTL1 .ne. ZERO ) THEN IF ( PROKG ) THEN WRITE(MPG,'(A)') & '** Warning : SPD solver called, resetting CNTL(1) to 0.0D0' END IF END IF CNTL1 = ZERO END IF C CNTL1 threshold value must be between C 0.0 and 1.0 (for SYM=0) and 0.5 (for SYM=1,2) IF (CNTL1.GT.ONE) CNTL1=ONE IF (CNTL1.LT.ZERO) CNTL1=ZERO IF (KEEP(50).NE.0.AND.CNTL1.GT.0.5D0) THEN CNTL1 = 0.5D0 ENDIF PARPIV_T1 = id%KEEP(268) IF (PARPIV_T1.EQ.77) THEN PARPIV_T1 = 0 #if defined(__ve__) PARPIV_T1 = -2 #endif ENDIF IF (PARPIV_T1.EQ.-3) THEN PARPIV_T1 = 0 ENDIF IF ((PARPIV_T1.LT.-3).OR.(PARPIV_T1.GT.1)) THEN C out of range values PARPIV_T1 =0 ENDIF C note that KEEP(50).EQ.1 => CNTL1=0.0 IF (CNTL1.EQ.0.0D0.OR.(KEEP(50).eq.1)) PARPIV_T1 = 0 C IF (PARPIV_T1.EQ.-2) THEN IF (KEEP(19).NE.0) THEN C switch off PARPIV_T1 if RR activated C but do NOT switch off PARPIV_1 with null pivot detection PARPIV_T1 = 0 ENDIF ENDIF id%KEEP(269) = PARPIV_T1 C } ENDIF CALL MPI_BCAST(CNTL1, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) CALL MPI_BCAST( KEEP(269), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (id%MYID.EQ.MASTER) THEN C{ C OMP parallelization of arrowheads C out of range are treated as zero IF (KEEP(399).LT.-1) KEEP(399)=-1 KEEP399_SAVE = KEEP(399) IF (KEEP(399).EQ.-1) THEN IF ((KEEP(54).EQ.0).AND.(id%NPROCS.GT.1)) THEN KEEP(399) = 1 ELSE KEEP(399) = 3 ENDIF ENDIF #if defined(PCPRET) C new multithreaded >=2 algo does not compile on PCPRET KEEP(399) = 1 #endif C ----------------------------------------------------- C Decoding of ICNTL(35) for factorization: same as C at analysis except that we store a copy of ICNTL(35) C in KEEP(486) instead of KEEP(494) and need to check C compatibility of KEEP(486) and KEEP(494): If LR was C not activated during analysis, it cannot be activated C at factorization. C ------------------------------------------------------ id%KEEP(486) = id%ICNTL(35) IF (id%KEEP(486).EQ.1) THEN C -- Automatic BLR option setting id%KEEP(486)= 2 ENDIF IF ( id%KEEP(486).EQ.4) id%KEEP(486)=0 IF ((id%KEEP(486).LT.0).OR.(id%KEEP(486).GT.4)) THEN C Out of range values treated as 0 id%KEEP(486) = 0 ENDIF IF ((KEEP(486).NE.0).AND.(KEEP(494).EQ.0)) THEN C To activate BLR during factorization, C ICNTL(35) must have been set at analysis. IF (LPOK) THEN WRITE(LP,'(A)') & " *** Error with BLR setting " WRITE(LP,'(A)') " *** BLR was not activated during ", & " analysis but is requested during factorization." ENDIF id%INFO(1)=-54 id%INFO(2)=0 GOTO 105 ENDIF C Save value of KEEP(486) before possibly C forcing it to 3 in case of discard factors KEEP_486_FOR_PRINT=KEEP(486) IF (KEEP(201) .EQ. -1 .AND. KEEP(486) .NE.0) THEN KEEP(486) = 3 ENDIF KEEP464COPY = id%ICNTL(38) IF (KEEP464COPY.LT.0.OR.KEEP464COPY.GT.1000) THEN C Out of range values treated as 1000 KEEP464COPY = 1000 ENDIF IF (id%KEEP(461).LT.1) THEN id%KEEP(461) = 10 ENDIF IF (id%KEEP(462).LT.1) THEN id%KEEP(462) = 10 ENDIF KEEP465COPY = id%ICNTL(39) IF (KEEP465COPY.LT.0.OR.(KEEP465COPY.GT.1000)) THEN C Out of range values treated as 1000 KEEP465COPY = 1000 ENDIF IF (id%ICNTL(36).EQ.1.OR.id%ICNTL(36).EQ.3) THEN IF (CNTL1.EQ.ZERO .OR. KEEP(468).LE.1) THEN KEEP(475) = 3 ELSE IF ( (KEEP(269).GT.0).OR. (KEEP(269).EQ.-2)) THEN KEEP(475) = 2 ELSE IF (KEEP(468).EQ.2) THEN KEEP(475) = 2 ELSE KEEP(475) = 1 ENDIF ELSE KEEP(475) = 0 ENDIF KEEP(481)=0 IF (id%ICNTL(36).LT.0 .OR. id%ICNTL(36).GE.2) THEN C Only options 1 and 2 are allowed KEEP(475) = 0 ENDIF C K489 is set according to ICNTL(37) IF (id%ICNTL(37).EQ.0.OR.id%ICNTL(37).EQ.1) THEN KEEP(489) = id%ICNTL(37) ELSE C Other values treated as zero KEEP(489) = 0 ENDIF IF (KEEP(79).GE.1) THEN C CompressCB incompatible with type4,5,6 nodes KEEP(489)=0 ENDIF C id%KEEP(476) \in [1,100] IF ((id%KEEP(476).GT.100).OR.(id%KEEP(476).LT.1)) THEN id%KEEP(476)= 50 ENDIF C id%KEEP(477) \in [1,100] IF ((id%KEEP(477).GT.100).OR.(id%KEEP(477).LT.1)) THEN id%KEEP(477)= 100 ENDIF C id%KEEP(483) \in [1,100] IF ((id%KEEP(483).GT.100).OR.(id%KEEP(483).LT.1)) THEN id%KEEP(483)= 80 ENDIF C id%KEEP(484) \in [1,100] IF ((id%KEEP(484).GT.100).OR.(id%KEEP(484).LT.1)) THEN id%KEEP(484)= 80 ENDIF C id%KEEP(480)=0,2,3,4,5,6 IF ((id%KEEP(480).GT.6).OR.(id%KEEP(480).LT.0) & .OR.(id%KEEP(480).EQ.1)) THEN id%KEEP(480)=0 ENDIF C id%KEEP(473)=0 or 1 IF ((id%KEEP(473).NE.0).AND.(id%KEEP(473).NE.1)) THEN id%KEEP(473)=0 ENDIF C id%KEEP(474)=0,1,2,3 IF ((id%KEEP(474).GT.3).OR.(id%KEEP(474).LT.0)) THEN id%KEEP(474)=0 ENDIF C id%KEEP(479)>0 IF (id%KEEP(479).LE.0) THEN id%KEEP(479)=1 ENDIF IF (id%KEEP(474).NE.0.AND.id%KEEP(480).EQ.0) THEN id%KEEP(474) = 0 ENDIF IF (id%KEEP(478).NE.0.AND.id%KEEP(480).LT.4) THEN id%KEEP(478) = 0 ENDIF IF (id%KEEP(480).GE.5 .OR. & (id%KEEP(480).NE.0.AND.id%KEEP(474).EQ.3)) THEN IF (id%KEEP(475).LT.2) THEN C Reset to 3 if 5 or to 4 if 6 id%KEEP(480) = id%KEEP(480) - 2 write(*,*) ' Resetting KEEP(480) to ', id%KEEP(480) ENDIF ENDIF 105 CONTINUE C} ENDIF ! id%MYID .EQ. MASTER CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C IF (id%INFO(1).LT.0) GOTO 530 EPS = epsilon ( ZERO ) CALL MPI_BCAST( KEEP(281), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(399), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(473), 14, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (KEEP(486).NE.0) THEN CALL MPI_BCAST( KEEP(489), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP464COPY, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP465COPY, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF IF (id%MYID.EQ.MASTER) THEN IF (KEEP(217).GT.2.OR.KEEP(217).LT.0) THEN KEEP(217)=0 ENDIF KEEP(214)=KEEP(217) IF (KEEP(214).EQ.0) THEN IF (KEEP(201).NE.0) THEN ! OOC or no factors KEEP(214)=1 ELSE KEEP(214)=2 ENDIF IF (KEEP(486).EQ.2) THEN KEEP(214)=1 ENDIF ENDIF ENDIF CALL MPI_BCAST( KEEP(214), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (KEEP(201).NE.0) THEN C -- Low Level I/O strategy CALL MPI_BCAST( KEEP(99), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(205), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(211), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(255), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF C Fwd in facto: explicitly forbid C sparse RHS and A-1 computation IF (id%KEEP(252).EQ.1 .AND. id%MYID.EQ.MASTER) THEN IF (id%ICNTL(20).EQ.1) THEN ! out-of-range => 0 C NB: in doc ICNTL(20) only accessed during solve C In practice, will have failed earlier if RHS not allocated. C Still it looks safer to keep this test. id%INFO(1)=-43 id%INFO(2)=20 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: Sparse RHS is incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE IF (id%ICNTL(30).NE.0) THEN ! out-of-range => 1 id%INFO(1)=-43 id%INFO(2)=30 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: A-1 functionality incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE IF (id%ICNTL(9) .NE. 1) THEN id%INFO(1)=-43 id%INFO(2)=9 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C IF (id%INFO(1).LT.0) GOTO 530 C C The memory allowed is given by ICNTL(23) in Mbytes C 0 means that nothing is provided. C Save memory available, ICNTL(23) in KEEP8(4) C IF ( ICNTL(23) .GT. 0 ) THEN ITMP = 1 ELSE ITMP = 0 ENDIF CALL MPI_ALLREDUCE( ITMP, JTMP, 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) IF ( id%MYID.EQ.MASTER ) THEN C Negative values considered 0 ITMP = max(ICNTL(23),0) END IF CALL MPI_BCAST( ITMP, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C JTMP: nb of procs with nonzero ICNTL(23) C ITMP: value of ICNTL(23) on master IF ( ITMP .GT. 0 .AND. JTMP .EQ. 1 ) THEN C ICNTL(23)>0 only on master ELSE C Local values of ICNTL(23) are used, note that C they could all be zeros ITMP = ICNTL(23) ENDIF C ITMP8 = int(ITMP, 8) id%KEEP8(4) = ITMP8 * 1000000_8 ! convert to nb of bytes C Compute \sum of memories allowed CALL MPI_REDUCE( id%KEEP8(4), ITMP8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) ITMP8 = ITMP8 / 1000000_8 ! Use to print \sum_{ICNTL(23)} IF ( PROKG ) THEN NWORKING = id%NSLAVES CALL MUMPS_SETI8TOI4( id%KEEP8(129), TMP_INFOG_4) WRITE( MPG, 172 ) & NWORKING, id%ICNTL(22), KEEP_486_FOR_PRINT, & KEEP(489), & id%ICNTL(49), & id%KEEP(19), & KEEP(12), & id%KEEP8(111), TMP_INFOG_4, KEEP(127), KEEP(28), & id%KEEP8(4)/1000000_8, ITMP8, id%KEEP8(124), CNTL1 IF (KEEP(252).GT.0) & WRITE(MPG,173) KEEP(253) IF (KEEP(269).NE.0) & WRITE(MPG,174) KEEP(269) ENDIF IF (KEEP(201).LE.0) THEN C In-core version or no factors KEEP(IXSZ)=XSIZE_IC ELSE IF (KEEP(201).EQ.2) THEN C OOC version, no panels KEEP(IXSZ)=XSIZE_OOC_NOPANEL ELSE IF (KEEP(201).EQ.1) THEN C Panel versions: IF (KEEP(50).EQ.0) THEN KEEP(IXSZ)=XSIZE_OOC_UNSYM ELSE KEEP(IXSZ)=XSIZE_OOC_SYM ENDIF ENDIF IF ( KEEP(486) .NE. 0 ) THEN !LR is activated C Stats initialization for LR CALL INIT_STATS_GLOBAL() END IF C Memory management: allocate id%S etc. from C or Fortran? id%KEEP(430) = 0 #if defined(MUMPS_MALLOC_FROM_C) id%KEEP(430) = 1 #endif C * ********************************** * Begin intializations regarding the * computation of the determinant * ********************************** IF (id%MYID.EQ.MASTER) KEEP(258)=ICNTL(33) CALL MPI_BCAST(KEEP(258), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF (KEEP(258) .NE. 0) THEN KEEP(259) = 0 ! Initial exponent of the local determinant KEEP(260) = 1 ! Number of permutations id%DKEEP(6) = 1.0D0 ! real part of the local determinant id%DKEEP(7) = 0.0D0 ! imaginary part of the local determinant ENDIF * ******************************** * End intializations regarding the * computation of the determinant * ******************************** C CALL MUMPS_STOP_ON_USER_REQUEST(id%KEEP,id%KEEP8, id%ICNTL, & id%INFO, id%MYID) CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0) GOTO 530 * ********************** * Begin of Scaling phase * ********************** C C SCALING MANAGEMENT C * Options 1, 3, 4 centralized only C C * Options 7, 8 : also works for distributed matrix C C At this point, we have the scaling arrays allocated C on the master. They have been allocated on the master C inside the main MUMPS driver. C CALL MPI_BCAST(KEEP(52), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) LSCAL = ((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) IF (LSCAL) THEN C IF ( id%MYID.EQ.MASTER ) THEN CALL MUMPS_SECDEB(TIMEET) ENDIF C ----------------------- C Retrieve parameters for C simultaneous scaling C ----------------------- IF (KEEP(52) .EQ. 7) THEN C -- Cheap setting of SIMSCALING (it is the default in 4.8.4) K231= KEEP(231) K232= KEEP(232) K233= KEEP(233) ELSEIF (KEEP(52) .EQ. 8) THEN C -- More expensive setting of SIMSCALING (it was the default in 4.8.1,2,3) K231= KEEP(239) K232= KEEP(240) K233= KEEP(241) ENDIF CALL MPI_BCAST(id%DKEEP(3),1,MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) C IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. & KEEP(54).NE.0 ) THEN C{ ------------------------------ C Scaling for distributed matrix C We need to allocate scaling C arrays on all processors, not C only the master. C ------------------------------ IF ( id%MYID .NE. MASTER ) THEN IF ( associated(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=N ENDIF ALLOCATE( id%ROWSCA(N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=N ENDIF ENDIF M = N BUMAXMN=M IF(N > BUMAXMN) BUMAXMN = N LIWK = 4_8*int(BUMAXMN,8) ALLOCATE (IWK(LIWK), BURP(M), BUCP(N), & BURS(2* id%NPROCS), BUCS(2* id%NPROCS), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(LIWK+int(M,8)+int(N,8)+ & 4_8*int(id%NPROCS,8) , id%INFO(2)) ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C -- estimation of memory and construction of partvecs BUJOB = 1 C -- LWK not used LWK_REAL = 1_8 LWRKR_TH = 1_8 LWRKC_TH = 1_8 NOMP_MAX = 1 ALLOCATE(WK_REAL(LWK_REAL), & WRKR_TH(LWRKR_TH,NOMP_MAX), & WRKC_TH(LWRKC_TH,NOMP_MAX), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR( & LWK_REAL+ & LWRKR_TH*int(NOMP_MAX,8)+ & LWRKC_TH*int(NOMP_MAX,8), & id%INFO(2)) ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 CALL ZMUMPS_SIMSCALEABS( & IRN_loc_PTR(1), JCN_loc_PTR(1), A_loc_PTR(1), & id%KEEP8(29), & M, N, id%NPROCS, id%MYID, id%COMM, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) IF(LIWK < BUINTSZ) THEN DEALLOCATE(IWK) LIWK = BUINTSZ ALLOCATE(IWK(LIWK), stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(LIWK,id%INFO(2)) ENDIF ENDIF DEALLOCATE(WK_REAL, WRKR_TH, WRKC_TH) LWK_REAL = BURESZ C C -- Set NOMP_MAX from KEEP(281) CALL ZMUMPS_SET_NOMP_MAX(id%KEEP(281), id%KEEP(361), & N, NOMP_MAX) C IF (NOMP_MAX.LE.1) THEN C temp array per thread not used LWRKR_TH = 1 LWRKC_TH = 1 ELSE LWRKR_TH = N IF (id%KEEP(50).NE.0) THEN C WRKC_TH not used on symmetric matrices LWRKC_TH = 1 ELSE LWRKC_TH = N ENDIF ENDIF ALLOCATE(WK_REAL(LWK_REAL), & WRKR_TH(LWRKR_TH,max(NOMP_MAX,1)), & WRKC_TH(LWRKC_TH,max(NOMP_MAX,1)), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR( & LWK_REAL+ & LWRKR_TH*int(max(NOMP_MAX,1),8)+ & LWRKC_TH*int(max(NOMP_MAX,1),8), & id%INFO(2)) ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C -- estimation of memory and construction of partvecs BUJOB = 2 CALL ZMUMPS_SIMSCALEABS( & IRN_loc_PTR(1), JCN_loc_PTR(1), A_loc_PTR(1), & id%KEEP8(29), & M, N, id%NPROCS, id%MYID, id%COMM, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) id%DKEEP(4) = SCONEERR id%DKEEP(5) = SCINFERR CXXXX DEALLOCATE(IWK, BURP,BUCP,BURS, BUCS) DEALLOCATE(WK_REAL, WRKR_TH, WRKC_TH) C} ELSE IF ( KEEP(54) .EQ. 0 ) THEN C{ ------------------ C Centralized matrix C ------------------ IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN C ------------------------------- C Create a communicator of size 1 C ------------------------------- IF (id%MYID.EQ.MASTER) THEN COLOUR = 0 ELSE COLOUR = MPI_UNDEFINED ENDIF CALL MPI_COMM_SPLIT( id%COMM, COLOUR, 0, & COMM_FOR_SCALING, IERR ) IF (id%MYID.EQ.MASTER) THEN M = N BUMAXMN=N IF(N > BUMAXMN) BUMAXMN = N LIWK = 1_8 ALLOCATE(IWK(LIWK), BURP(1), BUCP(1), & BURS(1), BUCS(1), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR( LIWK+4_8, id%INFO(2) ) GOTO 400 ENDIF LWK_REAL = int(M,8) + int(N,8) C C -- Set NOMP_MAX from KEEP(281) CALL ZMUMPS_SET_NOMP_MAX(id%KEEP(281), id%KEEP(361), & N, NOMP_MAX) C IF (NOMP_MAX.LE.1) THEN C temp array per thread not used LWRKR_TH = 1 LWRKC_TH = 1 ELSE LWRKR_TH = N IF (id%KEEP(50).NE.0) THEN C WRKC_TH not used on symmetric matrices LWRKC_TH = 1 ELSE LWRKC_TH = N ENDIF ENDIF ALLOCATE(WK_REAL(LWK_REAL), & WRKR_TH(LWRKR_TH,max(NOMP_MAX,1)), & WRKC_TH(LWRKC_TH,max(NOMP_MAX,1)), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR( & LWK_REAL+ & LWRKR_TH*int(max(NOMP_MAX,1),8)+ & LWRKC_TH*int(max(NOMP_MAX,1),8), & id%INFO(2)) ENDIF CALL MPI_COMM_RANK(COMM_FOR_SCALING, SCMYID, IERR) CALL MPI_COMM_SIZE(COMM_FOR_SCALING, SCNPROCS, IERR) BUJOB = 1 CALL ZMUMPS_SIMSCALEABS( & id%IRN(1), id%JCN(1), id%A(1), & id%KEEP8(28), & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) IF(LWK_REAL < BURESZ) THEN id%INFO(1) = -136 GOTO 400 ENDIF BUJOB = 2 CALL ZMUMPS_SIMSCALEABS(id%IRN(1), & id%JCN(1), id%A(1), & id%KEEP8(28), & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) id%DKEEP(4) = SCONEERR id%DKEEP(5) = SCINFERR 400 CONTINUE IF (allocated(WK_REAL)) DEALLOCATE(WK_REAL) IF (allocated(WRKR_TH)) DEALLOCATE(WRKR_TH) IF (allocated(WRKC_TH)) DEALLOCATE(WRKC_TH) IF (allocated(IWK)) DEALLOCATE(IWK) IF (allocated(BURP)) DEALLOCATE(BURP) IF (allocated(BUCP)) DEALLOCATE(BUCP) IF (allocated(BURS)) DEALLOCATE(BURS) IF (allocated(BUCS)) DEALLOCATE(BUCS) ENDIF C Centralized matrix: make DKEEP(4:5) available to all processors CALL MPI_BCAST( id%DKEEP(4),2,MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR ) IF (id%MYID.EQ.MASTER) THEN C Communicator should only be C freed on the master process CALL MPI_COMM_FREE(COMM_FOR_SCALING, IERR) ENDIF CALL MUMPS_PROPINFO(ICNTL(1), id%INFO(1), & id%COMM, id%MYID) IF (id%INFO(1).LT.0) GOTO 517 ELSE IF (id%MYID.EQ.MASTER) THEN C ------------------- C Centralized scaling C ------------------- IF (KEEP(52).GT.0 .AND. KEEP(52).LE.6) THEN C --------------------- C Allocate temporary C workspace for scaling C --------------------- IF (KEEP(52) .eq. 1 ) THEN C No workspace indeed needed LWK = 1_8 LWK_REAL = 1_8 ELSE IF ( KEEP(52) .eq. 3 ) THEN LWK = 1_8 LWK_REAL = int(N,8) ELSE IF ( KEEP(52) .eq. 4 ) THEN C Options 3 or 4 LWK = 1_8 LWK_REAL = 2_8*int(N,8) END IF C Real workarray ALLOCATE( WK_REAL( LWK_REAL ), stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR( LWK_REAL, id%INFO(2) ) GOTO 137 END IF C Real/complex workarray ALLOCATE( WK( LWK ), stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) GOTO 137 END IF CALL ZMUMPS_FAC_A(N, id%KEEP8(28), KEEP(52), id%A(1), & id%IRN(1), id%JCN(1), & id%COLSCA(1), id%ROWSCA(1), & WK, LWK, WK_REAL, LWK_REAL, ICNTL(1), id%INFO(1) ) DEALLOCATE( WK_REAL ) DEALLOCATE( WK ) ENDIF ENDIF C} ENDIF ! Scaling distributed matrices or centralized IF (KEEP(125).NE.0) THEN C ------------------------ C If we enable the scaling of the |A11 A12| block C we set to 1 the scaling corresponding to the Schur C complement matrix A22 C ------------------------ IF ((KEEP(60).GT.0) .and. (KEEP(116).GT.0)) THEN C Schur is active, reset Schur entries to ONE IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. & KEEP(54).NE.0 ) THEN C Scaling available on all procs DO I=1, N IF (id%SYM_PERM(I).GT.id%N-KEEP(116)) THEN id%COLSCA(I) = ONE id%ROWSCA(I) = ONE ENDIF ENDDO ELSE IF ( id%MYID .EQ. MASTER) THEN C Scaling available on master DO I=1, N IF (id%SYM_PERM(I).GT.id%N-KEEP(116)) THEN id%COLSCA(I) = ONE id%ROWSCA(I) = ONE ENDIF ENDDO ENDIF ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIMEET) id%DKEEP(92)=TIMEET IF (PROKG) WRITE( MPG, 140 ) TIMEET C Print inf-norm after last KEEP(233) iterations of C scaling option KEEP(52)=7 or 8 (SimScale) C IF (PROKG.AND.(KEEP(52).EQ.7.OR.KEEP(52).EQ.8)) THEN IF (K233+K231+K232.GT.0) THEN IF (K232.GT.0) WRITE(MPG, 166) id%DKEEP(4) ENDIF ENDIF ENDIF ENDIF ! LSCAL C C scaling might also be provided by the user LSCAL = (LSCAL .OR. (KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) IF (LSCAL .AND. KEEP(258).NE.0 .AND. id%MYID .EQ. MASTER) THEN DO I = 1, id%N CALL ZMUMPS_UPDATEDETER_SCALING(id%ROWSCA(I), & id%DKEEP(6), ! determinant & KEEP(259)) ! exponent of the determinant ENDDO IF (KEEP(50) .EQ. 0) THEN ! unsymmetric DO I = 1, id%N CALL ZMUMPS_UPDATEDETER_SCALING(id%COLSCA(I), & id%DKEEP(6), ! determinant & KEEP(259)) ! exponent of the determinant ENDDO ELSE C ----------------------------------------- C In this case COLSCA = ROWSCA C Since determinant was initialized to 1, C compute square of the current determinant C rather than going through COLSCA. C ----------------------------------------- CALL ZMUMPS_DETER_SQUARE(id%DKEEP(6), KEEP(259)) ENDIF C Now we should have taken the C inverse of the scaling vectors CALL ZMUMPS_DETER_SCALING_INVERSE(id%DKEEP(6), KEEP(259)) ENDIF C C ******************** C End of Scaling phase C At this point: either (matrix is distributed and KEEP(52)=7 or 8) C in which case scaling arrays are allocated on all processors, C or scaling arrays are only on the host processor. C In case of distributed matrix input, we will free the scaling C arrays on procs with MYID .NE. 0 after the all-to-all distribution C of the original matrix. C ******************** C 137 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C systematically this array now than waiting for C the root node. We rely on the fact that it is C allocated or not during the solve phase so if C it was allocated in a 1st call to facto and not C in a second, we don't want the solve to think C it was allocated in the second call. IF (associated(idintr%roota%RHS_CNTR_MASTER_ROOT)) THEN DEALLOCATE (idintr%roota%RHS_CNTR_MASTER_ROOT) NULLIFY (idintr%roota%RHS_CNTR_MASTER_ROOT) ENDIF C Fwd in facto: check that id%NRHS has not changed IF ( id%MYID.EQ.MASTER.AND. KEEP(252).EQ.1 .AND. & id%NRHS .NE. id%KEEP(253) ) THEN C Error: NRHS should not have C changed since the analysis id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) ENDIF IF (id%KEEP(252) .EQ. 1) THEN IF ( id%MYID.NE.MASTER ) THEN id%KEEP(254) = N ! Leading dimension id%KEEP8(85) = int(N,8)*int(id%KEEP(253),8) ! Tot size ALLOCATE(RHS_MUMPS(id%KEEP8(85)),stat=IERR) IF (IERR > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(85), id%INFO(2)) IF (LPOK) & WRITE(LP,*) 'ERROR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. ELSE RHS_MUMPS_ALLOCATED = .TRUE. ENDIF ELSE C Case of non working master id%KEEP(254)=id%LRHS ! Leading dimension id%KEEP8(85)=int(id%LRHS,8)*int(id%KEEP(253)-1,8)+ & int(id%N,8) ! Tot size RHS_MUMPS=>id%RHS RHS_MUMPS_ALLOCATED = .FALSE. IF (LSCAL) THEN C Scale before broadcast: apply row C scaling (remark that we assume no C transpose). DO K=1, id%KEEP(253) DO I=1, N RHS_MUMPS( id%KEEP(254) * (K-1) + I ) & = RHS_MUMPS( id%KEEP(254) * (K-1) + I ) & * id%ROWSCA(I) ENDDO ENDDO ENDIF ENDIF ELSE id%KEEP8(85)=1_8 ALLOCATE(RHS_MUMPS(1),stat=IERR) IF (IERR > 0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF (LPOK) & WRITE(LP,*) 'ERREUR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. ELSE RHS_MUMPS_ALLOCATED = .TRUE. ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 516 IF (KEEP(252) .EQ. 1) THEN C C Broadcast the columns of the right-hand side C one by one. Leading dimension is keep(254)=N C on procs with MYID > 0 but may be larger on C the master processor. DO I= 1, id%KEEP(253) CALL MPI_BCAST(RHS_MUMPS((I-1)*id%KEEP(254)+1), N, & MPI_DOUBLE_COMPLEX, MASTER,id%COMM,IERR) END DO ENDIF IF (id%MYID.EQ. MASTER) THEN C Copy the value of ICNTL(24) and make it C available on all working processors. KEEP(110)=id%ICNTL(24) C KEEP(110) defaults to 0 for out of range values IF (KEEP(110).NE.1) KEEP(110)=0 ENDIF CALL MPI_BCAST(KEEP(110), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) C ----------------------------------------------- C Depending on the option used for C -detecting null pivots (ICNTL(24)/KEEP(110)) C CNTL(3) is used to set DKEEP(1) C ( A row is considered as null if ||row|| < DKEEP(1) ) C CNTL(5) is then used to define if a large C value is set on the diagonal or if a 1 is set C and other values in the row are reset to zeros. C -rank revealing on the Schur (ICNTL(56)/KEEP(19)) C SEUIL* corresponds to the minimum required C absolute value of pivot. C SEUIL_LDLT_NIV2 is used only in the C case of SYM=2 within a niv2 node for which C we have only a partial view of the fully summed rows. IF (id%MYID .EQ. MASTER) CNTL3 = id%CNTL(3) CALL MPI_BCAST(CNTL3, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) CNTL5 = id%CNTL(5) CALL MPI_BCAST(CNTL5, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) CNTL6 = id%CNTL(6) CALL MPI_BCAST(CNTL6, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) id%DKEEP(8) = id%CNTL(7) CALL MPI_BCAST(id%DKEEP(8), 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) id%DKEEP(11) = id%DKEEP(8)/id%KEEP(461) id%DKEEP(12) = id%DKEEP(8)/id%KEEP(462) IF (KEEP(486).EQ.0) id%DKEEP(8) = ZERO COMPUTE_ANORMINF = .FALSE. IF ( (KEEP(486) .NE. 0).AND. (id%DKEEP(8).LT.ZERO)) THEN COMPUTE_ANORMINF = .TRUE. ENDIF IF (KEEP(19).NE.0) THEN C Rank revealing factorisation COMPUTE_ANORMINF = .TRUE. ENDIF IF (KEEP(110).NE.0) THEN C Null pivot detection COMPUTE_ANORMINF = .TRUE. ENDIF IF (id%DKEEP(8).LT.ZERO) THEN C Experimental setting of CNTL(7) IF (COMPUTE_ANORMINF) THEN EFF_SIZE_SCHUR = 0 CALL ZMUMPS_ANORMINF( id , ANORMINF, LSCAL, EFF_SIZE_SCHUR ) C If no schur ANORMINF fine for other cases id%DKEEP(8) = abs(id%DKEEP(8))*ANORMINF ELSE ANORMINF = ZERO id%DKEEP(8) = abs(id%DKEEP(8)) ENDIF C ANORMINF need be recomputed in case of schur IF ((KEEP(60).GT.0).AND.KEEP(116).GT.0) ANORMINF=ZERO ENDIF IF (PROKG) THEN IF ( (CNTL(7) < ZERO) .AND. COMPUTE_ANORMINF .AND. & (KEEP(486) .NE. 0) ) THEN C Warning : using negative values is an experimental and C non recommended setting. WRITE(MPG,'(/A,A/,A/,A,A)') & ' WARNING in BLR input setting: ', & ' CNTL(7) < 0 is experimental: ', & ' Effective BLR threshold = |CNTL(7| x ||A_pre||, ', & ' where A_pre is the preprocessed matrix as defined', & ' in the users guide ' WRITE(MPG,'(A,3D16.4/)') & ' Effective BLR threshold, CNTL(7), ||A_pre|| = ', & id%DKEEP(8), CNTL(7), ANORMINF ENDIF ENDIF C ------------------------------------------------------- C We compute ANORMINF, when needed, based on C the infinite norm of Rowsca *A*Colsca C and make it available on all working processes. IF (COMPUTE_ANORMINF) THEN EFF_SIZE_SCHUR = 0 IF (KEEP(60).GT.0) EFF_SIZE_SCHUR = KEEP(116) CALL ZMUMPS_ANORMINF( id , ANORMINF, LSCAL, EFF_SIZE_SCHUR ) ELSE ANORMINF = ZERO ENDIF C IF ((KEEP(19).NE.0).OR.(KEEP(110).NE.0)) THEN IF (PROKG) THEN IF (KEEP(19).NE.0) THEN WRITE(MPG,'(A,1PD16.4)') & ' CNTL(3) for null pivot rows/singularities =',CNTL3 ELSE WRITE(MPG,'(A,1PD16.4)') & ' CNTL(3) for null pivot row detection =',CNTL3 ENDIF ENDIF ENDIF IF (KEEP(19).EQ.0) THEN C{ -- RR is off SEUIL = ZERO id%DKEEP(9) = ZERO C} ELSE C{ -- RR is on C C CNTL(3) is the threshold used in the following to compute C DKEEP(9) the threshold under which the sing val. are considered C as null and from which we start to look for a gap between two C sing val. IF (CNTL3 .LT. ZERO) THEN id%DKEEP(9) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(9) = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN CALL MUMPS_NPIV_CRITICAL_PATH( & N, KEEP(28), id%STEP(1), id%FRERE_STEPS(1), id%FILS(1), & id%NA(1), id%LNA, id%NE_STEPS(1), KEEP(127), & NPIV_CRITICAL_PATH ) id%DKEEP(9) = sqrt(dble(NPIV_CRITICAL_PATH))*EPS*ANORMINF ENDIF IF (PROKG) THEN WRITE(MPG, '(A,I16)') & ' ICNTL(56) rank revealing effective value =',KEEP(19) WRITE(MPG,'(A,1PD16.4)') & ' ...Threshold for singularities on the root =',id%DKEEP(9) ENDIF C RR postponing considers that pivot rows with norm smaller C than SEUIL should be postponed. C SEUIL should be bigger than DKEEP(9), this means that C DKEEP(13) should be bigger than 1. Thresh_Seuil = id%DKEEP(13) IF (id%DKEEP(13).LT.1) Thresh_Seuil = 10 SEUIL = id%DKEEP(9)*Thresh_Seuil IF (PROKG) WRITE(MPG,'(A,1PD16.4)') & ' ...Threshold for postponing =',SEUIL C} ENDIF !end KEEP(19).ne.0 SEUIL_LDLT_NIV2 = SEUIL C ------------------------------- C -- Null pivot row detection C ------------------------------- IF (KEEP(110).EQ.0) THEN C{ -- Null pivot is off C Initialize DKEEP(1) to a negative value C in order to avoid detection of null pivots C (test max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL C in ZMUMPS_FAC_I, where PIVNUL=DKEEP(1)) id%DKEEP(1) = -1.0D0 id%DKEEP(2) = ZERO C} ELSE C{ -- Null pivot detection is on IF (KEEP(19).NE.0) THEN C{ -- RR is on C RR postponing considers that pivot rows of norm smaller that SEUIL C should be postponed, but pivot rows smaller than DKEEP(1) are C directly added to null space and thus considered as null pivot rows. IF ((id%DKEEP(10).LE.0).OR.(id%DKEEP(10).GT.1)) THEN C DKEEP(10) is out of range, set to the default value 10-1 id%DKEEP(1) = id%DKEEP(9)*1D-1 ELSE id%DKEEP(1) = id%DKEEP(9)*id%DKEEP(10) ENDIF C} ELSE C{ -- RR is off C -- only Null pivot detection C We keep strategy currently used in MUMPS 4.10.0 IF (CNTL3 .LT. ZERO) THEN id%DKEEP(1) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(1) = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN c id%DKEEP(1) = NPIV_CRITICAL_PATH*EPS*ANORMINF CALL MUMPS_NPIV_CRITICAL_PATH( & N, KEEP(28), id%STEP(1), id%FRERE_STEPS(1), id%FILS(1), & id%NA(1), id%LNA, id%NE_STEPS(1), KEEP(127), & NPIV_CRITICAL_PATH ) id%DKEEP(1) = sqrt(dble(NPIV_CRITICAL_PATH))*EPS*ANORMINF ENDIF C} ENDIF ! fin rank revealing IF ((KEEP(110).NE.0).AND.(PROKG)) THEN WRITE(MPG, '(A,I16)') & ' ICNTL(24) null pivot rows detection =',KEEP(110) WRITE(MPG,'(A,1PD16.4)') & ' ...Zero pivot detection threshold =',id%DKEEP(1) ENDIF IF (CNTL5.GT.ZERO) THEN id%DKEEP(2) = CNTL5 * ANORMINF IF (PROKG) WRITE(MPG,'(A,1PD16.4)') & ' ...Fixation for null pivots =',id%DKEEP(2) ELSE IF (PROKG) WRITE(MPG,*) '...Infinite fixation ' IF (id%KEEP(50).EQ.0) THEN C Unsym ! the user let us choose a fixation. set in NEGATIVE ! to detect during facto when to set row to zero ! id%DKEEP(2) = -max(1.0D10*ANORMINF, & sqrt(huge(ANORMINF))/1.0D8) ELSE C Sym id%DKEEP(2) = ZERO ENDIF ENDIF C} ENDIF ! fin null pivot detection. C Find id of root node if RR is on IF (KEEP(19).NE.0) THEN ID_ROOT =MUMPS_PROCNODE(id%PROCNODE_STEPS(id%STEP(KEEP(20))), & id%KEEP(199)) IF ( KEEP( 46 ) .NE. 1 ) THEN ID_ROOT = ID_ROOT + 1 END IF ENDIF IF (KEEP(19).EQ.0.AND.KEEP(53).NE.0) THEN C ICNTL(56)>0 at analysis and =0 at facto C save special root index KEEP20_SAVE = KEEP(20) C suppress special RR treatment KEEP(20) = 0 ENDIF C Second pass: set parameters for null pivot detection C Allocate PIVNUL_LIST_STRUCT in case of null pivot detection C and in case of rank revealing KEEP(109) = 0 LPN_LIST = 0 IF(KEEP(110) .EQ. 1) THEN LPN_LIST = 100 ENDIF IF (KEEP(19).NE.0 .AND. & (ID_ROOT.EQ.id%MYID .OR. id%MYID.EQ.MASTER)) THEN LPN_LIST = 100 ENDIF IF (LPN_LIST.GT.0) THEN PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST = LPN_LIST ALLOCATE( PIVNUL_LIST_STRUCT%PIVNUL_LIST(LPN_LIST),stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=LPN_LIST END IF PIVNUL_LIST_STRUCT%PIVNUL_LIST(1:LPN_LIST) = 0 ENDIF C end set parameter for null pivot detection CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 516 C -------------------------------------------------------------- C STATIC PIVOTING C -- Static pivoting only when RR and Null pivot detection OFF C -------------------------------------------------------------- KEEP(97) = 0 IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (id%MYID .EQ. MASTER) CNTL4 = id%CNTL(4) CALL MPI_BCAST( CNTL4, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR ) C IF ( CNTL4 .GE. ZERO ) THEN KEEP(97) = 1 IF ( CNTL4 .EQ. ZERO ) THEN C -- set seuil to sqrt(eps)*||A|| IF(ANORMINF .EQ. ZERO) THEN EFF_SIZE_SCHUR = 0 IF (KEEP(60).GT.0) EFF_SIZE_SCHUR = KEEP(116) CALL ZMUMPS_ANORMINF( id , ANORMINF, LSCAL, & EFF_SIZE_SCHUR ) ENDIF SEUIL = sqrt(EPS) * ANORMINF ELSE SEUIL = CNTL4 ENDIF SEUIL_LDLT_NIV2 = SEUIL ELSE SEUIL = ZERO ENDIF ENDIF C set number of tiny pivots / 2x2 pivots in types 1 / C 2x2 pivots in types 2, to zero. This is because the C user can call the factorization step several times. KEEP(98) = 0 KEEP(103) = 0 KEEP(105) = 0 MAXS = 1_8 * * Start allocations * ***************** * C C The slaves can now perform the factorization C C C or point to user provided data WK_USER when LWK_USER>0 C ======================= C C Compute BLR_STRAT and a first estimation C of MAXS, the size of id%S CALL ZMUMPS_SET_BLRSTRAT_AND_MAXS_K8 ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & id%KEEP(1), id%KEEP8(1)) C MAXS = MAXS_BASE_RELAXED8 IF (WK_USER_PROVIDED) THEN C -- Set MAXS to size of WK_USER_ MAXS = id%KEEP8(24) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 516 ENDIF C id%KEEP8(75) = huge(id%KEEP8(75)) id%KEEP8(76) = huge(id%KEEP8(76)) IF (I_AM_SLAVE) THEN C IF (id%KEEP8(4) .NE. 0_8) THEN C IF ( .NOT. WK_USER_PROVIDED ) THEN C Set MAXS given BLR_STRAT, KEEP(201) and MAXS_BASE_RELAXED8 CALL ZMUMPS_MEM_ALLOWED_SET_MAXS ( & MAXS, & BLR_STRAT, id%KEEP(201), MAXS_BASE_RELAXED8, & id%KEEP(1), id%KEEP8(1), id%MYID, id%N, id%NELT, & id%NA(1), id%LNA, id%NSLAVES, & KEEP464COPY, KEEP465COPY, & id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) C Given MAXS and max memory allowed KEEP8(4) C compute in KEEP8(75) the number of real/complex C available for dynamic allocations CALL ZMUMPS_MEM_ALLOWED_SET_K75 ( & MAXS, id%MYID, & .FALSE., ! UNDER_L0_OMP & N, id%NELT, id%NA(1), id%LNA, id%NSLAVES, & BLR_STRAT, id%KEEP(201), & id%KEEP, id%KEEP8, id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) ELSE C KEEP8(75) dow not include MAXS, since WK_USER is provided CALL ZMUMPS_MEM_ALLOWED_SET_K75 ( & 0_8, id%MYID, & .FALSE., ! UNDER_L0_OMP & N, id%NELT, id%NA(1), id%LNA, id%NSLAVES, & BLR_STRAT, id%KEEP(201), & id%KEEP, id%KEEP8, id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) ENDIF IF (KEEP(400) .GT.0) THEN C ------------------------------ C compute KEEP8(75) under L0_OMP C ------------------------------ C Save KEEP8(75) above L0_OMP to reset KEEP8(75) C when starting FAC_PAR_M id%KEEP8(76) = id%KEEP8(75) CALL ZMUMPS_MEM_ALLOWED_SET_K75 ( & 0_8, ! MAXS=0_8 & id%MYID, & .TRUE., ! UNDER_L0_OMP & id%N, id%NELT, id%NA(1), id%LNA, id%NSLAVES, & BLR_STRAT, id%KEEP(201), & id%KEEP, id%KEEP8, id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) C KEEP8(75) holds the number of entries that C can be allocated underL0. C It will be used during ZMUMPS_FAC_L0_OMP to adjust the C the size of MUMPS_TPS_ARR(ITH)%LA ENDIF ENDIF ! MEM_ALLOWED C ENDIF ! I_AM_SLAVE THEN C IF (I_AM_SLAVE) THEN IF ( (KEEP(400).GT.0) .AND. (KEEP(406).EQ.2) ) THEN C Compute KEEP8(77) the peak authorized used by C ZMUMPS_PERFORM_COPIES CALL ZMUMPS_L0_COMPUTE_PEAK_ALLOWED( & id%MYID, id%N, & id%NELT, id%NA(1), id%LNA, id%NSLAVES, & BLR_STRAT, id%KEEP(201), & id%KEEP(1), id%KEEP8(1), id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) ENDIF ENDIF ! I_AM_SLAVE) C CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 516 ENDIF CALL MUMPS_SETI8TOI4(MAXS, id%INFO(39)) CALL ZMUMPS_AVGMAX_STAT8(PROKG, MPG, MAXS, id%NSLAVES, & PRINT_MAXAVG, & id%COMM, " Effective size of S (based on INFO(39))= ") C IF ( I_AM_SLAVE ) THEN C ---------------------------------------- C Initialize some global variables related C to communication buffer management C ---------------------------------------- CALL MUMPS_BUF_INI_MYID(id%MYID_NODES) CALL MUMPS_BUF_INIT( id%KEEP( 34 ), id%KEEP(35) ) C ------------------ C Dynamic scheduling C ------------------ CALL MUMPS_LOAD_SET_INICOST( dble(id%COST_SUBTREES), & KEEP(64), dble(id%DKEEP(15)), KEEP(375), MAXS ) MEMORY_MD_ARG = min(int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8 ), C Restrict freedom from dynamic scheduler when C MEM_ALLOWED=ICNTL(23) is small (case where KEEP8(4)-MAXS_BASE8 C is negative after call to ZMUMPS_MAX_MEM) & max(0_8, MAXS-MAXS_BASE8)) CALL MUMPS_LOAD_INIT( MEMORY_MD_ARG, MAXS, id%KEEP, & id%KEEP8, id%INFO, id%ISTEP_TO_INIV2, id%CANDIDATES, id%ND_STEPS, & id%FILS, id%FRERE_STEPS, id%DAD_STEPS, id%PROCNODE_STEPS, & id%STEP, id%NE_STEPS, id%N, id%MAX_SURF_MASTER, id%SUP_PROC, & id%COMM_LOAD, id%COMM_NODES, & id%DEPTH_FIRST, id%COST_TRAV, id%DEPTH_FIRST_SEQ, id%SBTR_ID, & id%NA, id%NSLAVES, id%FUTURE_NIV2, & id%NBSA, id%NBSA_LOCAL, id%MEM_SUBTREE, id%MY_FIRST_LEAF, & id%MY_NB_LEAF, id%MY_ROOT_SBTR ) IF (KEEP(201) .GT. 0) THEN C ------------------- C OOC initializations C ------------------- IF (KEEP(201).EQ.1 !PANEL Version & .AND.KEEP(50).EQ.0 ! Unsymmetric & .AND.KEEP(251).NE.2 ! Store L to disk & ) THEN id%OOC_NB_FILE_TYPE=2 ! declared in MUMPS_OOC_COMMON ELSE id%OOC_NB_FILE_TYPE=1 ! declared in MUMPS_OOC_COMMON ENDIF C ------------------------------ C Dimension IO buffer, KEEP(100) C ------------------------------ IF (KEEP(205) .GT. 0) THEN KEEP(100) = KEEP(205) ELSE IF (KEEP(201).EQ.1) THEN ! PANEL version ITMP8 = int(id%OOC_NB_FILE_TYPE,8) * & 2_8 * int(KEEP(226),8) ELSE ITMP8 = 2_8 * id%KEEP8(119) ENDIF ITMP8 = ITMP8 + int(max(KEEP(12),0),8) * & (ITMP8/100_8+1_8) C we want to avoid too large IO buffers. C 12M corresponds to 100Mbytes given to buffers. ITMP8 = min(ITMP8, 12000000_8) KEEP(100)=int(ITMP8) ENDIF IF (KEEP(201).EQ.1) THEN C Panel version. Force the use of a buffer. IF ( KEEP(99) < 3 ) THEN KEEP(99) = KEEP(99) + 3 ENDIF ENDIF C -------------------------- C Reset KEEP(100) to 0 if no C buffer is used for OOC. C -------------------------- IF (KEEP(99) .LT.3) KEEP(100)=0 IF((dble(KEEP(100))*dble(KEEP(35))/dble(2)).GT. & (dble(1999999999)))THEN IF (PROKG) THEN WRITE(MPG,*)id%MYID,': Warning: DIM_BUF_IO might be & too big for Filesystem' ENDIF ENDIF ALLOCATE (id%OOC_INODE_SEQUENCE(KEEP(28), & id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_INODE_SEQUENCE) GOTO 112 ENDIF ALLOCATE (id%OOC_TOTAL_NB_NODES(id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE NULLIFY(id%OOC_TOTAL_NB_NODES) GOTO 112 ENDIF ALLOCATE (id%OOC_SIZE_OF_BLOCK(KEEP(28), & id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_SIZE_OF_BLOCK) GOTO 112 ENDIF ALLOCATE (id%OOC_VADDR(KEEP(28),id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_VADDR) GOTO 112 ENDIF ENDIF ENDIF 112 CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) < 0) THEN C LOAD_END must be done but not OOC_END_FACTO GOTO 513 ENDIF IF (I_AM_SLAVE) THEN IF (KEEP(201) .GT. 0) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL ZMUMPS_OOC_INIT_FACTO(id%ICNTL(1), id%ICNTL(4), id%N, & id%NSLAVES, id%MYID, MAXS, id%OOC_NB_FILE_TYPE, & id%KEEP, id%KEEP8, id%STEP, id%PROCNODE, & id%OOC_SIZE_OF_BLOCK, id%OOC_VADDR, id%INFO, & id%OOC_TMPDIR, id%OOC_PREFIX, id%OOC_NB_FILES, & id%OOC_INODE_SEQUENCE) ELSE WRITE(*,*) "Internal error in ZMUMPS_FAC_DRIVER" CALL MUMPS_ABORT() ENDIF IF(id%INFO(1).LT.0)THEN GOTO 111 ENDIF ENDIF C First increment corresponds to the number of C floating-point operations for subtrees allocated C to the local processor. CALL MUMPS_LOAD_UPDATE(0,.FALSE.,dble(id%COST_SUBTREES), & id%KEEP(1),id%KEEP8(1)) IF (id%INFO(1).LT.0) GOTO 111 END IF C ----------------------- C Manage main workarray S C ----------------------- EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) #if defined (LARGEMATRICES) IF ( id%MYID .ne. MASTER ) THEN #endif IF (.NOT.WK_USER_PROVIDED) THEN IF ( EARLYT3ROOTINS ) THEN C Standard allocation strategy CALL ZMUMPS_DM_ALLOC_S_WK(id%S, MAXS, IERR, & KEEP(430), KEEP(35)) id%KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(MAXS, id%INFO(2)) C On some platforms (IBM for example), an C allocation failure returns a non-null pointer. C Therefore we nullify S NULLIFY(id%S) id%KEEP8(23)=0_8 ENDIF ENDIF ELSE id%S => id%WK_USER(1:id%KEEP8(24)) id%KEEP8(23) = 0_8 ENDIF #if defined (LARGEMATRICES) END IF #endif C 111 CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 514 C -------------------------- C Initialization of modules C related to data management C -------------------------- NB_ACTIVE_FRONTS_ESTIM = 3 NB_THREADS = 1 !$ NB_THREADS = OMP_GET_MAX_THREADS() C NB_ACTIVE_FRONTS_ESTIM = 3*NB_THREADS IF (I_AM_SLAVE) THEN C CALL MUMPS_FDM_INIT('A',NB_ACTIVE_FRONTS_ESTIM, id%INFO) C IF ( (KEEP(486).EQ.2) & .OR. ((KEEP(489).NE.0).AND.(KEEP(400).GT.1)) & ) THEN C In case of LRSOLVE or CompressCB, C initialize nb of handlers to nb of BLR C nodes estimated at analysis NB_FRONTS_F_ESTIM = KEEP(470) ELSE IF (KEEP(489).NE.0) THEN C Compress CB and no L0 OMP (or 1 thread under L0): C NB_ACTIVE_FRONTS_ESTIM is too small, C to limit nb of reallocations make it twice larger NB_FRONTS_F_ESTIM = 2*NB_ACTIVE_FRONTS_ESTIM ELSE NB_FRONTS_F_ESTIM = NB_ACTIVE_FRONTS_ESTIM ENDIF ENDIF CALL MUMPS_FDM_INIT('F',NB_FRONTS_F_ESTIM, id%INFO ) IF (id%INFO(1) .LT. 0 ) GOTO 114 #if ! defined(NO_FDM_DESCBAND) C Storage of DESCBAND information CALL MUMPS_FDBD_INIT( NB_ACTIVE_FRONTS_ESTIM, id%INFO ) #endif #if ! defined(NO_FDM_MAPROW) C Storage of MAPROW and ROOT2SON information CALL MUMPS_FMRD_INIT( NB_ACTIVE_FRONTS_ESTIM, id%INFO ) #endif CALL ZMUMPS_BLR_INIT_MODULE( NB_FRONTS_F_ESTIM, id%INFO & ) 114 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C GOTO 500: one of the above module initializations failed IF ( id%INFO(1).LT.0 ) GOTO 500 C C C Allocate space for matrix in arrowhead form C =========================================== C C CASE 1 : Matrix is assembled C CASE 2 : Matrix is elemental C IF ( KEEP(55) .eq. 0 ) THEN C ------------------------------------ C Space has been allocated already for C the integer part during analysis C Only slaves need the arrowheads. C ------------------------------------ IF ( I_AM_SLAVE .and. id%KEEP8(26) .ne. 0_8 ) THEN ALLOCATE( DBLARR( id%KEEP8(26) ), & INTARR( id%KEEP8(27) ), stat = IERR ) ELSE ALLOCATE( DBLARR( 1 ), & INTARR( 1 ), stat =IERR ) END IF IF ( IERR .NE. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for DBLARR(',id%KEEP8(26),')+INTARR(', & id%KEEP8(27),')' ENDIF id%INFO(1)=-13 CALL MUMPS_SET_IERROR( max(id%KEEP8(26),1_8)+ & max(id%KEEP8(27),1_8), & id%INFO(2) ) GOTO 100 END IF DBLARR_ALLOCATED = .TRUE. ELSE C -------------------------------- C Allocate element variables lists C -------------------------------- IF ( I_AM_SLAVE .and. id%KEEP8(27) .ne. 0_8 ) THEN ALLOCATE( INTARR( id%KEEP8(27) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(id%KEEP8(27), id%INFO(2)) GOTO 100 END IF ELSE C INTARR also allocated of size 1 on non-working master ALLOCATE( INTARR(1),stat=allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 GOTO 100 END IF END IF C --------------------------------------- C Allocate DBLARR to hold possibly scaled C copies of elemental matrices C On a working master (hybrid host) and C no scaling, avoid the copy and point C directly to user data instead. C --------------------------------------- IF ( I_AM_SLAVE ) THEN IF ( id%MYID_NODES .eq. MASTER & .AND. KEEP(46) .eq. 1 & .AND. KEEP(52) .eq. 0 ) THEN C ------------------- C Pointer association C ------------------- DBLARR => id%A_ELT ELSE C ---------- C Allocation C ---------- ALLOCATE( DBLARR( max(id%KEEP8(26),1_8) ), stat=allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(max(id%KEEP8(26),1_8), id%INFO(2)) NULLIFY(DBLARR) GOTO 100 END IF DBLARR_ALLOCATED = .TRUE. END IF ELSE ALLOCATE( DBLARR(1), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(DBLARR) GOTO 100 END IF DBLARR_ALLOCATED = .TRUE. END IF END IF 100 CONTINUE C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C ------------------------------------------ C Prepare stuff for the 2D block-cyclic root C ------------------------------------------ IF ( KEEP(38).NE.0 ) THEN ALLOCATE(idintr%root%RG2L(id%N), stat=allocok) IF ( allocok .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N END IF IF ( id%INFO(1) .GE.0 ) THEN CALL ZMUMPS_INIT_ROOT_FAC( id%N, id%MYID, & idintr%root, id%FILS(1), id%KEEP(1) ) ENDIF ENDIF C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C C ----------------------------------- C C DISTRIBUTION OF THE ORIGINAL MATRIX C C ----------------------------------- C C TIMINGS: computed (and printed) on the host C Next line: global time for distrib(arrowheads,elts) C on the host. Synchronization has been performed. IF (id%MYID.EQ.MASTER) CALL MUMPS_SECDEB(TIME) C ------------------------------------------- C S_PTR_ARG / MAXS_ARG will be used for id%S C argument to arrowhead/element distribution C routines: if id%S is not allocated, we pass C S_DUMMY_ARG instead, which is not accessed. C ------------------------------------------- IF (EARLYT3ROOTINS) THEN S_PTR_ARG => id%S MAXS_ARG = MAXS ELSE S_PTR_ARG => S_DUMMY_ARG MAXS_ARG = 1 ENDIF C IF ( KEEP( 55 ) .eq. 0 ) THEN C { C ---------------------------- C Original matrix is assembled C Arrowhead format to be used. C ---------------------------- C KEEP8(26) and KEEP8(27) hold the number of entries for real/integer C for the matrix in arrowhead format. They have been set by the C analysis phase (ZMUMPS_ANA_F and ZMUMPS_ANA_G) C C ------------------------------------------------------------------ C Blocking is used for sending arrowhead records (I,J,VAL) C buffer(1) is used to store number of bytes already packed C buffer(2) number of records already packed C KEEP(39) : Number of records (blocking factor) C ------------------------------------------------------------------ C C --------------------------------------------- C In case of parallel root compute minimum C size of workspace to receive arrowheads C of root node. Will be used to check that C MAXS is large enough for arrowheads (case C of EARLYT3ROOTINS (KEEP(200)=0); if .NOT. C EARLYT3ROOTINS (KEEP(200)=1), root will C be assembled into id%S later and size of C id%S will be checked later) C --------------------------------------------- IF (EARLYT3ROOTINS .AND. KEEP(38).NE.0 .AND. & KEEP(60) .EQ.0 .AND. I_AM_SLAVE) THEN LWK = int(MUMPS_NUMROC( idintr%root%ROOT_SIZE, & idintr%root%MBLOCK, & idintr%root%MYROW, 0, idintr%root%NPROW ),8) LWK = max( 1_8, LWK ) LWK = LWK* & int(MUMPS_NUMROC( idintr%root%ROOT_SIZE, & idintr%root%NBLOCK, & idintr%root%MYCOL, 0, idintr%root%NPCOL ),8) LWK = max( 1_8, LWK ) ELSE LWK = 1_8 ENDIF C MAXS must be at least 1, and in case of C parallel root, large enough to receive C arrowheads of root. IF (MAXS .LT. int(LWK,8)) THEN id%INFO(1) = -9 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C C ===================================================== IF (KEEP(399).GE.2) THEN C{ Multihtreaded algorithm taking into account all cases C ===================================================== C C Timing on master. IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIME) END IF C NZ_loc8 = 0_8 NBRECORDS = KEEP(39) SIZESCAL = id%N C Set NZ_loc8, A_loc_PTR, IRN_loc_PTR, JCN_loc_PTR C and update NBRECORDS IF (KEEP(54).EQ.0) THEN C centralized matrix IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF IF (id%MYID.EQ.MASTER) THEN NZ_loc8 = id%KEEP8(28) A_loc_PTR => id%A IRN_loc_PTR => id%IRN JCN_loc_PTR => id%JCN IF (LSCAL) THEN COLSCA_PTR => id%COLSCA ROWSCA_PTR => id%ROWSCA ELSE COLSCA_PTR => DUMMYSCA ROWSCA_PTR => DUMMYSCA SIZESCAL = 1 ENDIF ELSE A_loc_PTR => DUMMYA_loc IRN_loc_PTR => DUMMYIRN_loc JCN_loc_PTR => DUMMYJCN_loc COLSCA_PTR => DUMMYSCA ROWSCA_PTR => DUMMYSCA SIZESCAL = 1 ENDIF ELSE C distributed matrix C --------------------------------------------------- C In order to have possibly IRN_loc/JCN_loc/A_loc C of size 0, avoid to pass them inside REDISTRIBUTION C and pass id instead C NZ_locMAX8 gives as a maximum buffer size (send/recv) used C an upper bound to limit buffers on small matrices C --------------------------------------------------- CALL MPI_ALLREDUCE(id%KEEP8(29), NZ_locMAX8, 1, & MPI_INTEGER8, MPI_MAX, id%COMM, IERR) IF (NZ_locMAX8 .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(NZ_locMAX8) ENDIF NZ_loc8 = id%KEEP8(29) LSCAL = (KEEP(52).EQ.7).OR.(KEEP(52).EQ.8) C available on all MPI IF (LSCAL) THEN COLSCA_PTR => id%COLSCA ROWSCA_PTR => id%ROWSCA ELSE COLSCA_PTR => DUMMYSCA ROWSCA_PTR => DUMMYSCA SIZESCAL = 1 ENDIF ENDIF #if ! defined(PCPRET) IF (id%KEEP(72).EQ.1) THEN NBRECORDS = max(3,NBRECORDS/10) ENDIF CALL ZMUMPS_FAC_DIST_ARROWHEADS_OMP ( id%N, & NZ_loc8, C replace id by: & A_loc_PTR(1), IRN_loc_PTR(1), JCN_loc_PTR(1), & SIZESCAL, LSCAL, COLSCA_PTR(1), ROWSCA_PTR(1), & DBLARR(1), id%KEEP8(26), INTARR(1), & id%KEEP8(27), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & id%FILS(1), & KEEP(1), id%KEEP8(1), id%MYID, id%COMM, NBRECORDS, & S_PTR_ARG(1), MAXS_ARG, idintr%root, idintr%roota, & id%PROCNODE_STEPS(1), & id%NPROCS, id%NSLAVES, id%SYM_PERM(1), id%STEP(1), & id%ICNTL(1), id%INFO(1), NSEND8, NLOCAL8, & id%ISTEP_TO_INIV2(1), & id%CANDIDATES(1,1) & ) CALL MPI_BARRIER(id%COMM, IERR) #else #endif C IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN C ------------------------------ C The host is not working -> had C no data from initial matrix C ------------------------------ NSEND8 = 0_8 NLOCAL8 = 0_8 END IF C ------------------------- C Check for possible errors C ------------------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 CALL MPI_REDUCE( NSEND8, NSEND_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( NLOCAL8, NLOCAL_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN WRITE(MPG,125) NLOCAL_TOT8, NSEND_TOT8 END IF C} ELSE C{ ======================================================= IF ( KEEP(54) .eq. 0 ) THEN C { C ================================================ C FIRST CASE : MATRIX IS NOT INITIALLY DISTRIBUTED C ================================================ C A small integer workspace is needed to C send the arrowheads. IF ( id%MYID .eq. MASTER ) THEN #if defined(LARGEMATRICES) ALLOCATE (WK(LWK),stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) write(6,*) ' PB1 ALLOC LARGEMAT' ENDIF #endif ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 IF ( id%MYID .eq. MASTER ) THEN C C -------------------------------- C MASTER sends arowheads using the C global communicator with ranks C also in global communicator C IWK is used as temporary C workspace of size N. C -------------------------------- NBRECORDS = KEEP(39) IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF #if defined(LARGEMATRICES) CALL ZMUMPS_FACTO_SEND_ARROWHEADS(id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), id%SYM_PERM(1), & LSCAL, id%COLSCA(1), id%ROWSCA(1), & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), & NBRECORDS, & id%COMM, idintr%root, idintr%roota, KEEP,id%KEEP8, & id%FILS(1), & & INTARR(1), id%KEEP8(27), DBLARR(1), id%KEEP8(26), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & id%FRERE_STEPS(1), id%STEP(1), WK(1), LWK, & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & id%CANDIDATES(1,1), id%ICNTL(1), id%INFO(1) ) C write(6,*) '!!! A,IRN,JCN are freed during factorization ' DEALLOCATE (id%A) NULLIFY(id%A) DEALLOCATE (id%IRN) NULLIFY (id%IRN) DEALLOCATE (id%JCN) NULLIFY (id%JCN) IF (.NOT.WK_USER_PROVIDED) THEN IF (EARLYT3ROOTINS) THEN CALL ZMUMPS_ALLOC_S_WORKSPACE(id%S, MAXS, IERR, & KEEP(430), KEEP(35)) id%KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXS NULLIFY(id%S) id%KEEP8(23)=0_8 write(6,*) ' PB2 ALLOC LARGEMAT',MAXS CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ELSE id%S => id%WK_USER(1:id%KEEP8(24)) ENDIF IF (EARLYT3ROOTINS) THEN id%S(MAXS-LWK+1_8:MAXS) = WK(1_8:LWK) ENDIF DEALLOCATE (WK) #else CALL ZMUMPS_FACTO_SEND_ARROWHEADS(id%N, id%KEEP8(28), & id%A(1), id%IRN(1), id%JCN(1), id%SYM_PERM(1), & LSCAL, id%COLSCA(1), id%ROWSCA(1), & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), & NBRECORDS, & id%COMM, idintr%root, idintr%roota, KEEP(1),id%KEEP8(1), & id%FILS(1), & & INTARR(1), id%KEEP8(27), DBLARR(1), id%KEEP8(26), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & id%FRERE_STEPS(1), id%STEP(1), S_PTR_ARG(1), MAXS_ARG, & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & id%CANDIDATES(1,1), id%ICNTL(1), id%INFO(1) ) #endif ELSE NBRECORDS = KEEP(39) IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF CALL ZMUMPS_FACTO_RECV_ARROWHD2( id%N, & DBLARR(1), id%KEEP8(26), & INTARR(1), id%KEEP8(27), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & KEEP( 1 ), id%KEEP8(1), id%FILS(1), id%MYID, id%COMM, & NBRECORDS, & & S_PTR_ARG(1), MAXS_ARG, & idintr%root, idintr%roota, & id%PROCNODE_STEPS(1), id%NSLAVES, & id%SYM_PERM(1), id%FRERE_STEPS(1), id%STEP(1), & id%ICNTL(1), id%INFO(1) ) ENDIF C } ELSE C { C ============================================= C SECOND CASE : MATRIX IS INITIALLY DISTRIBUTED C ============================================= C Timing on master. IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIME) END IF IF ( I_AM_SLAVE ) THEN C { C --------------------------------------------------- C In order to have possibly IRN_loc/JCN_loc/A_loc C of size 0, avoid to pass them inside REDISTRIBUTION C and pass id instead C NZ_locMAX8 gives as a maximum buffer size (send/recv) used C an upper bound to limit buffers on small matrices C --------------------------------------------------- CALL MPI_ALLREDUCE(id%KEEP8(29), NZ_locMAX8, 1, MPI_INTEGER8, & MPI_MAX, id%COMM_NODES, IERR) NBRECORDS = KEEP(39) IF (NZ_locMAX8 .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(NZ_locMAX8) ENDIF CALL ZMUMPS_REDISTRIBUTION( id%N, & id%KEEP8(29), & id, & DBLARR(1), id%KEEP8(26), INTARR(1), & id%KEEP8(27), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & id%FILS(1), & KEEP(1), id%KEEP8(1), id%MYID_NODES, & id%COMM_NODES, NBRECORDS, & S_PTR_ARG(1), MAXS_ARG, idintr%root, idintr%roota, & id%PROCNODE_STEPS(1), & id%NSLAVES, id%SYM_PERM(1), id%STEP(1), & id%ICNTL(1), id%INFO(1), NSEND8, NLOCAL8, & id%ISTEP_TO_INIV2(1), & id%CANDIDATES(1,1) ) IF ( ( KEEP(52).EQ.7 ).OR. (KEEP(52).EQ.8) ) THEN C ------------------------------------------------- C In that case, scaling arrays have been allocated C on all processors. They were useful for matrix C distribution. But we now really only need them C on the host. In case of distributed solution, we C will have to broadcast either ROWSCA or COLSCA C (depending on MTYPE) but this is done later. C C In other words, on exit from the factorization, C we want to have scaling arrays available only C on the host. C ------------------------------------------------- IF ( id%MYID > 0 ) THEN IF (associated(id%ROWSCA)) THEN DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF IF (associated(id%COLSCA)) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ENDIF ENDIF ENDIF #if defined(LARGEMATRICES) C deallocate id%IRN_loc, id%JCN(loc) to free extra space C Note that in this case IRN_loc cannot be used C anymore during the solve phase for IR and Error analysis. IF (associated(id%IRN_loc)) THEN DEALLOCATE(id%IRN_loc) NULLIFY(id%IRN_loc) ENDIF IF (associated(id%JCN_loc)) THEN DEALLOCATE(id%JCN_loc) NULLIFY(id%JCN_loc) ENDIF IF (associated(id%A_loc)) THEN DEALLOCATE(id%A_loc) NULLIFY(id%A_loc) ENDIF write(6,*) ' Warning :', & ' id%A_loc, IRN_loc, JCN_loc deallocated !!! ' #endif IF (PROK) THEN WRITE(MP,120) NLOCAL8, NSEND8 END IF C } END IF ! I_AM_SLAVE C ------------------------- C Check for possible errors C ------------------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN C ------------------------------ C The host is not working -> had C no data from initial matrix C ------------------------------ NSEND8 = 0_8 NLOCAL8 = 0_8 END IF C -------------------------- C Put into some info/infog ? C -------------------------- CALL MPI_REDUCE( NSEND8, NSEND_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( NLOCAL8, NLOCAL_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN WRITE(MPG,125) NLOCAL_TOT8, NSEND_TOT8 END IF C } ENDIF ! distributed matrix C } ENDIF ! "old" multithreaded algorithm C } ELSE C { C ------------------- C Matrix is elemental, C provided on the C master only C ------------------- IF ( id%MYID.eq.MASTER) & CALL ZMUMPS_MAXELT_SIZE( id%ELTPTR(1), & id%NELT, & MAXELT_SIZE ) C C Perform the distribution of the elements. C A this point, C PTRAIW/PTRARW have been computed. C INTARR/DBLARR have been allocated C ELTPROC gives the mapping of elements C CALL ZMUMPS_ELT_DISTRIB( id%N, id%NELT, id%KEEP8(30), & id%COMM, id%MYID, & id%NSLAVES, id%PTRAR(1), & id%PTRAR(id%NELT+2), & INTARR(1), DBLARR(1), id%KEEP8(27), id%KEEP8(26), & id%KEEP(1), id%KEEP8(1), MAXELT_SIZE, & id%FRTPTR(1), id%FRTELT(1), & S_PTR_ARG(1), MAXS_ARG, id%FILS(1), & id, idintr%root, idintr%roota ) C ---------------- C Broadcast errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C } END IF ! Element entry C ------------------------ C Time the redistribution: C ------------------------ IF ( id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIME) id%DKEEP(93) = TIME IF (PROKG) WRITE(MPG,160) id%DKEEP(93) END IF C ------------------------------------- C Small memory optimizaiton: we can now C free RG2L on the non working host, C ------------------------------------- IF (id%KEEP(38) .NE. 0 .AND. .NOT. I_AM_SLAVE) THEN IF (associated(idintr%root%RG2L)) THEN DEALLOCATE(idintr%root%RG2L) NULLIFY (idintr%root%RG2L) ENDIF ENDIF IF ( KEEP(400) .GT. 0 .AND. KEEP(369).EQ.0) THEN C{ Check if number of threads is consistent with C the one used during analysis for all procs C Note that if KEEP(369)>0 C KEEP(400) was set based on C KEEP(369) and KEEP(381) so that C omp_set_num_threads(KEEP(400)) will be called C explicitly before L0_OMP section C and KEEP(400) cannot be check here in this way NOMP=1 !$ NOMP = omp_get_max_threads() IF ( NOMP .NE. KEEP(400) ) THEN id%INFO(1)=-58 id%INFO(2)=KEEP(400) IF (LPOK) WRITE(LP,'(A,A,I5,A,I5)') &" FAILURE DETECTED IN FACTORIZATION: #threads for multithreaded", &" tree parallelism changed from",KEEP(400)," at analysis to", & NOMP ENDIF C} ENDIF C error check done outside previous if bloc C because KEEP(369) might be 0 on some and nonzero on some proc CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C C TIMINGS: C Next line: elapsed time for factorization IF (id%MYID.EQ.MASTER) CALL MUMPS_SECDEB(TIME) C C Allocate buffers on the workers C =============================== C IF ( I_AM_SLAVE ) THEN C C Some buffers are required to pack/unpack data and for C receiving MPI messages. C For packing/unpacking : the buffer must be large C enough to send several messages while receives might not C be posted yet. C It is assumed that the size of an integer is held in KEEP(34) C while the size of a complex is held in KEEP(35). C BUFR and LBUFR are declared of type integer, since byte is not C a standard datatype. C We now use KEEP(43) or KEEP(379) and KEEP(44) or KEEP(380) C as estimated at analysis to allocate appropriate buffer sizes C C Receive buffer C -------------- IF (KEEP(486).NE.0) THEN ZMUMPS_LBUFR_BYTES8 = int(KEEP( 380 ),8) * int(KEEP(35),8) ELSE ZMUMPS_LBUFR_BYTES8 = int(KEEP( 44 ),8) * int(KEEP(35),8) ENDIF C --------------------------------------- C Ensure a reasonable minimal buffer size C --------------------------------------- IF (KEEP(72).NE.1) THEN C ensure minimum size for small problems ZMUMPS_LBUFR_BYTES8 = max( ZMUMPS_LBUFR_BYTES8, & 200000_8 ) ENDIF C C If there is pivoting, size of the message might still increase. C We use a relaxation (so called PERLU) to increase the estimate. C C Note: PERLU is a global estimate for pivoting. C It may happen that one large contribution block size is increased C by more than that. C This is why we use an extra factor 2 relaxation coefficient for C the relaxation of C the reception buffer in the case where pivoting is allowed. C A more dynamic strategy could be applied: if message to C be received is larger than expected, reallocate a larger C buffer. (But this won't work with IRECV.) C Finally, one may want (as we are currently doing it for C most messages) C to cut large messages into a series of smaller ones. C IF (KEEP(48).EQ.5) THEN MIN_PERLU = 2 ELSE MIN_PERLU = 0 ENDIF C IF (KEEP(72).NE.1) THEN ZMUMPS_LBUFR_BYTES8 = ZMUMPS_LBUFR_BYTES8 & + int( dble(max(PERLU/2,MIN_PERLU))* & dble(ZMUMPS_LBUFR_BYTES8)/100D0, 8) ELSE C on small pb we want to relax buffers C for pivoting ZMUMPS_LBUFR_BYTES8 = ZMUMPS_LBUFR_BYTES8 & + int( dble(max(PERLU,MIN_PERLU))* & dble(ZMUMPS_LBUFR_BYTES8)/100D0, 8) ENDIF ZMUMPS_LBUFR_BYTES8 = min(ZMUMPS_LBUFR_BYTES8, & int(huge(I4)-100,8)) ZMUMPS_LBUFR_BYTES = int( ZMUMPS_LBUFR_BYTES8 ) C ZMUMPS_LBUFR is the size of the buffer as a number of integers, C we round ZMUMPS_LBUFR (size in #integers) above to have at least C ZMUMPS_LBUFR_BYTES available in the buffer. ZMUMPS_LBUFR = (ZMUMPS_LBUFR_BYTES+KEEP(34)-1)/KEEP(34) C Finally, make ZMUMPS_LBUFR_BYTES a multiple of KEEP(34) by setting C ZMUMPS_LBUFR_BYTES to the number of bytes that will be allocated ZMUMPS_LBUFR_BYTES = ZMUMPS_LBUFR*KEEP(34) IF (KEEP(48)==5) THEN C Since the buffer is going to be allocated, use C it as the constraint for memory/granularity C in hybrid scheduler C id%KEEP8(21) = id%KEEP8(22) + & int( dble(max(PERLU/2,MIN_PERLU))* & dble(id%KEEP8(22))/100D0,8) ENDIF C C Now estimate the size for the buffer for asynchronous C sends of contribution blocks (so called CB). We want to be able to send at C least KEEP(213)/100 (two in general) messages at the C same time. C C Send buffer C ----------- IF (KEEP(486).NE.0) THEN ZMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 * & dble(KEEP(379)) * dble(KEEP(35)), 8 ) ELSE ZMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 * & dble(KEEP(43)) * dble(KEEP(35)), 8 ) ENDIF IF (KEEP(72).NE.1) THEN C ensure minimum size for small problems ZMUMPS_LBUF8 = max( ZMUMPS_LBUF8, 200000_8 ) ZMUMPS_LBUF8 = ZMUMPS_LBUF8 & + int( dble(max(PERLU/2,MIN_PERLU))* & dble(ZMUMPS_LBUF8)/100D0, 8) ELSE C for very small pb force extra relaxation ZMUMPS_LBUF8 = ZMUMPS_LBUF8 & + int( dble(max(PERLU,MIN_PERLU))* & dble(ZMUMPS_LBUF8)/100D0, 8) ENDIF C Make ZMUMPS_LBUF8 small enough to be stored in a standard integer ZMUMPS_LBUF8 = min(ZMUMPS_LBUF8, int(huge(I4)-100,8)) C C No reason to have send buffer smaller than receive buffer. C This should never occur with the formulas above but just C in case: ZMUMPS_LBUF8 = max(ZMUMPS_LBUF8, ZMUMPS_LBUFR_BYTES8+3*KEEP(34)) ZMUMPS_LBUF = int(ZMUMPS_LBUF8) IF(id%KEEP(48).EQ.4)THEN ZMUMPS_LBUFR_BYTES=ZMUMPS_LBUFR_BYTES*5 ZMUMPS_LBUF=ZMUMPS_LBUF*5 ENDIF C C Estimate size of buffer for small messages C Each node can send ( NSLAVES - 1 ) messages to (NSLAVES-1) nodes C C KEEP(56) is the number of nodes of level II. C Messages will be sent for the symmetric case C for synchronisation issues. C C We take an upperbound C ZMUMPS_LBUF_INT = ( KEEP(56) + id%NSLAVES * id%NSLAVES ) * 5 & * KEEP(34) IF ( KEEP( 38 ) .NE. 0 ) THEN C C KKKK = MUMPS_PROCNODE( id%PROCNODE_STEPS(id%STEP(KEEP(38))), & id%KEEP(199) ) IF ( KKKK .EQ. id%MYID_NODES ) THEN ZMUMPS_LBUF_INT = ZMUMPS_LBUF_INT + 4 * KEEP(34) * & ( id%NSLAVES + id%NE_STEPS(id%STEP(KEEP(38))) & + min(KEEP(56), id%NE_STEPS(id%STEP(KEEP(38)))) * id%NSLAVES & ) END IF END IF C At this point, ZMUMPS_LBUFR_BYTES, ZMUMPS_LBUF C and ZMUMPS_LBUF_INT have been computed (all C are in numbers of bytes). IF ( PROK ) THEN WRITE( MP, 9999 ) ZMUMPS_LBUFR_BYTES, & ZMUMPS_LBUF, ZMUMPS_LBUF_INT ELSE IF (PROKG) THEN WRITE( MPG, 9999 ) ZMUMPS_LBUFR_BYTES, & ZMUMPS_LBUF, ZMUMPS_LBUF_INT ENDIF END IF 9999 FORMAT( /,' Allocated buffers',/,' ------------------',/, & ' Size of reception buffer in bytes ...... = ', I12, & /, & ' Size of async. emission buffer (bytes).. = ', I12,/, & ' Small emission buffer (bytes) .......... = ', I12) C -------------------------- C Allocate small send buffer C required for ZMUMPS_FAC_B C -------------------------- CALL MUMPS_BUF_ALLOC_SMALL_BUF( ZMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)= -13 C convert to size in integer id%INFO(2)= ZMUMPS_LBUF_INT id%INFO(2)= (ZMUMPS_LBUF_INT+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Allocation error in MUMPS_BUF_ALLOC_SMALL_BUF' & ,id%INFO(2) ENDIF GO TO 110 END IF C C -------------------------------------- C Allocate reception buffer on all procs C This is done now. C -------------------------------------- ALLOCATE( BUFR( ZMUMPS_LBUFR ),stat=IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = ZMUMPS_LBUFR IF (LPOK) THEN WRITE(LP,*) & ': Allocation error for BUFR(', ZMUMPS_LBUFR, & ') on MPI process',id%MYID ENDIF GO TO 110 END IF C ----------------------------------------- C Estimate MAXIS. IS will be allocated in C ZMUMPS_FAC_B. It will contain factors and C contribution blocks integer information C ----------------------------------------- C Relax integer workspace based on PERLU PERLU = KEEP( 12 ) IF (KEEP(201).GT.0) THEN C OOC panel or non panel (note that C KEEP(15)=KEEP(225) if non panel) MAXIS_ESTIM = KEEP(225) ELSE C In-core or reals for factors not stored MAXIS_ESTIM = KEEP(15) ENDIF MAXIS = max( 1, int( min( int(huge(MAXIS),8), & int(MAXIS_ESTIM,8) + 3_8 * max(int(PERLU,8),10_8) * & ( int(MAXIS_ESTIM,8) / 100_8 + 1_8 ) & ) ! min & ) ! int & ) !max C ---------------------------- C Allocate PTLUST_S and PTRFAC C They will be used to access C factors in the solve phase. C They are also needed for C ZMUMPS_FAC_L0_OMP. C ---------------------------- ALLOCATE( id%PTLUST_S( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(28) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%PTLUST_S(', id%KEEP(28),')' ENDIF NULLIFY(id%PTLUST_S) GOTO 110 END IF ALLOCATE( id%PTRFAC( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(28) NULLIFY(id%PTRFAC) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%PTRFAC(', id%KEEP(28),')' ENDIF GOTO 110 END IF C ----------------------------- C Reserve temporary workspace : C IPOOL, PTRWB, ITLOC, PTRIST C PTRWB will be subdivided again C in routine ZMUMPS_FAC_B C ----------------------------- PTRIST = 1 PTRWB = PTRIST + id%KEEP(28) ITLOC = PTRWB + 2 * id%KEEP(28) C Fwd in facto: ITLOC of size id%N + id%KEEP(253) IPOOL = ITLOC + id%N + id%KEEP(253) C C -------------------------------- C NA(1) is an upperbound for LPOOL C -------------------------------- C Structure of the pool: C ____________________________________________________ C | Subtrees | | Top nodes | 1 2 3 | C ---------------------------------------------------- LPOOL = MUMPS_GET_POOL_LENGTH(id%NA(1), id%KEEP(1),id%KEEP8(1)) LIWK = IPOOL + LPOOL - 1 ALLOCATE( IWK( IPOOL + LPOOL - 1 ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=IPOOL + LPOOL - 1 IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for IWK(',IPOOL+LPOOL-1,')' ENDIF GOTO 110 END IF LIWK8 = 2 * id%KEEP(28) ALLOCATE(IWK8( 2 * id%KEEP(28)), stat = IERR) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=2 * id%KEEP(28) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for IWKB(', 2*id%KEEP(28),')' ENDIF GOTO 110 END IF C C Return to SPMD C ENDIF C 110 CONTINUE C ---------------- C Broadcast errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C IF ( I_AM_SLAVE ) THEN C Store size of receive buffers in ZMUMPS_LBUF module CALL MUMPS_BUF_DIST_IRECV_SIZE( ZMUMPS_LBUFR_BYTES ) IF (PROK) THEN WRITE( MP, 170 ) MAXS, MAXIS, MAXS_BASE8, KEEP(15), & id%KEEP8(26), id%KEEP8(27), id%KEEP8(11), KEEP(26), KEEP(27) ENDIF END IF C =============================================================== C Before calling the main driver, ZMUMPS_FAC_B, C some statistics should be initialized to 0, C even on the host node because they will be C used in REDUCE operations afterwards. C -------------------------------------------- C Size of factors written. It will be set to POSFAC in C IC, otherwise we accumulate written factors in it. id%KEEP8(31)= 0_8 C Size of factors under L0 will be returned C in id%KEEP8(64), not included in KEEP8(31)) C Number of entries in factors id%KEEP8(10) = 0_8 C KEEP8(8) will hold the volume of extra copies due to C in-place stacking in fac_mem_stack.F id%KEEP8(8)=0_8 id%INFO(9:14)=0 RINFO(2:3)=ZERO IF ( I_AM_SLAVE ) THEN C ------------------------------------ C Call effective factorization routine C ------------------------------------ IF ( KEEP(55) .eq. 0 ) THEN LDPTRAR = 1 ! PTRAR no longer used (of size 2) ELSE LDPTRAR = id%NELT + 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN NELT_arg = id%NELT ELSE C ------------------------------ C Use size 1 to avoid complaints C when using check bound options C ------------------------------ NELT_arg = 1 END IF ENDIF IF (I_AM_SLAVE) THEN IF (associated(id%L0_OMP_MAPPING)) & DEALLOCATE(id%L0_OMP_MAPPING) IF (KEEP(400) .GT. 0) THEN id%LL0_OMP_MAPPING = KEEP(28) ELSE id%LL0_OMP_MAPPING = 1 ENDIF ALLOCATE(id%L0_OMP_MAPPING(id%LL0_OMP_MAPPING), stat=allocok) IF ( allocok > 0) THEN write(*,*) "Problem allocating L0_OMP_MAPPING", & IERR, KEEP(28) GOTO 115 ENDIF IF (KEEP(400) .GT. 0) THEN id%LL0_OMP_FACTORS = KEEP(400) ELSE id%LL0_OMP_FACTORS = 1 ENDIF ALLOCATE(idintr%L0_OMP_FACTORS(id%LL0_OMP_FACTORS), & stat = allocok) IF (allocok > 0) THEN id%INFO(1)=-7 id%INFO(2)=NB_THREADS GOTO 115 ENDIF CALL ZMUMPS_INIT_L0_OMP_FACTORS(idintr%L0_OMP_FACTORS) ENDIF 115 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C Compute DKEEP(17) AVG_FLOPS = RINFOG(1)/(dble(id%NSLAVES)) id%DKEEP(17) = max ( id%DKEEP(18), AVG_FLOPS/dble(50) ) & IF (PROK.AND.id%MYID.EQ.MASTER) THEN IF (id%NSLAVES.LE.1) THEN WRITE(MP,'(/A,A,1PD10.3)') &' Start factorization with total', &' estimated flops (RINFOG(1)) = ', & RINFOG(1) ELSE WRITE(MP,'(/A,A,1PD10.3,A,1PD10.3)') &' Start factorization with total', &' estimated flops RINFOG(1) / Average per MPI proc = ', & RINFOG(1), ' / ', AVG_FLOPS ENDIF ENDIF IF (I_AM_SLAVE) THEN C IS/S pointers passed to ZMUMPS_FAC_B with C implicit interface through intermediate C structure S_IS_POINTERS. IS will be allocated C during ZMUMPS_FAC_B. C In case of L0OMP, id%IS and id%S are allocated during C ZMUMPS_FAC_B, and only after L0OMP nodes are processed, C in order to limit the global memory peak. S_IS_POINTERS%IW => id%IS; NULLIFY(id%IS) S_IS_POINTERS%A => id%S ; NULLIFY(id%S) CALL ZMUMPS_FAC_B(id%N,S_IS_POINTERS,MAXS,MAXIS,id%SYM_PERM(1), & id%NA(1),id%LNA,id%NE_STEPS(1),id%ND_STEPS(1), id%FILS(1), & id%STEP(1),id%FRERE_STEPS(1),id%DAD_STEPS(1),id%CANDIDATES(1,1), & id%ISTEP_TO_INIV2(1),id%TAB_POS_IN_PERE(1,1), id%PTRAR(1), &LDPTRAR,id%PTR8ARR(1),id%NINCOLARR(1),id%NINROWARR(1),id%PTRDEBARR & (1), IWK(PTRIST),id%PTLUST_S(1),id%PTRFAC(1),IWK(PTRWB),IWK8, & IWK(ITLOC),RHS_MUMPS(1),IWK(IPOOL),LPOOL,CNTL1,ICNTL(1), & id%INFO(1), RINFO(1),KEEP(1),id%KEEP8(1),id%PROCNODE_STEPS(1), & id%NSLAVES,id%COMM_NODES,id%MYID,id%MYID_NODES,BUFR,ZMUMPS_LBUFR & , ZMUMPS_LBUFR_BYTES, ZMUMPS_LBUF, INTARR(1), DBLARR(1), & idintr%root, idintr%roota, NELT_arg, id%FRTPTR(1), id%FRTELT(1), & id%COMM_LOAD,id%ASS_IRECV,SEUIL,SEUIL_LDLT_NIV2,id%MEM_DIST(0), & id%DKEEP(1), PIVNUL_LIST_STRUCT, id%LRGROUPS(1) & ,id%IPOOL_B_L0_OMP(1),id%LPOOL_B_L0_OMP, & id%IPOOL_A_L0_OMP(1),id%LPOOL_A_L0_OMP,id%L_VIRT_L0_OMP, & id%VIRT_L0_OMP(1), id%VIRT_L0_OMP_MAPPING(1),id%L_PHYS_L0_OMP, & id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1), id%PTR_LEAFS_L0_OMP(1), & id%L0_OMP_MAPPING(1),id%LL0_OMP_MAPPING, id%THREAD_LA, & idintr%L0_OMP_FACTORS(1), id%LL0_OMP_FACTORS, & id%I4_L0_OMP(1,1), size(id%I4_L0_OMP,1), size(id%I4_L0_OMP,2), & id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), size(id%I8_L0_OMP,2) & ) id%IS => S_IS_POINTERS%IW; NULLIFY(S_IS_POINTERS%IW) id%S => S_IS_POINTERS%A ; NULLIFY(S_IS_POINTERS%A) C C ------------------------------ C Deallocate temporary workspace C ------------------------------ DEALLOCATE( IWK ) DEALLOCATE( IWK8 ) ENDIF C Fwd in facto: free RHS_MUMPS in case it was allocated. IF (RHS_MUMPS_ALLOCATED) THEN DEALLOCATE(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. ENDIF NULLIFY(RHS_MUMPS) C --------------------------------- C Free some workspace corresponding C to the original matrix in C arrowhead or elemental format. C ----- C Note : DBLARR may be a pointer C in case of element-entry. C --------------------------------- IF (allocated( INTARR )) DEALLOCATE( INTARR ) IF (DBLARR_ALLOCATED) THEN DEALLOCATE(DBLARR) DBLARR_ALLOCATED=.FALSE. ENDIF NULLIFY(DBLARR) C We also free RG2L now IF ( KEEP(38) .NE. 0) THEN IF (associated(idintr%root%RG2L)) THEN DEALLOCATE(idintr%root%RG2L) NULLIFY(idintr%root%RG2L) ENDIF ENDIF C C Memory statistics C ----------------------------------- C If QR (Keep(19)) is not zero, and if C the host does not have the information C (ie is not slave), send information C computed on the slaves during facto C to the host. C ----------------------------------- C Note the KEEP(17), KEEP(143) have been bcasted during fac_par_m IF ( KEEP(19) .NE. 0 ) THEN IF ( KEEP(46) .NE. 1 ) THEN C Host was not working during facto_root C Send him the information IF ( id%MYID .eq. MASTER ) THEN CALL MPI_RECV( KEEP(17), 1, MPI_INTEGER, 1, DEFIC_TAG, & id%COMM, STATUS, IERR ) CALL MPI_RECV( KEEP(143), 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 ) CALL MPI_SEND( KEEP(143), 1, MPI_INTEGER, 0, DEFIC_TAG, & id%COMM, IERR ) END IF END IF END IF C -------------------------------- C Deallocate communication buffers C They will be reallocated C in the solve. C -------------------------------- IF (allocated(BUFR)) DEALLOCATE(BUFR) CALL MUMPS_BUF_DEALL_SMALL_BUF( IERR ) C C Check for errors. C After ZMUMPS_FAC_B every slave is aware of an error. C The call below informs the master, in case it is not C included in the computations. CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C CALL ZMUMPS_EXTRACT_SCHUR_REDRHS(id,idintr) C return to user singular values IF (id%KEEP(19) .NE.0) THEN CALL ZMUMPS_EXTRACT_SINGULAR_VALUES(id,idintr) ENDIF IF (KEEP(201) .GT. 0) THEN END IF IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIME) id%DKEEP(94)=TIME IF (KEEP(400).GT.0) THEN C Facto time above L0_OMP = total time - facto time under L0_OMP id%DKEEP(96)=id%DKEEP(94)-id%DKEEP(95) ENDIF ENDIF C Time to process root node: CALL MPI_REDUCE( id%DKEEP(99), TMPTIME, 1, & MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR ) id%DKEEP(99)=TMPTIME C ===================================================================== C COMPUTE MEMORY ALLOCATED BY MUMPS, INFO(16) C --------------------------------------------- MEM_EFF_ALLOCATED = .TRUE. CALL ZMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & BLR_STRAT, .TRUE., TOTAL_BYTES, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .FALSE. ! UNDER_L0_OMP & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN ! L0 activated CALL ZMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .TRUE., id%KEEP(201), & BLR_STRAT, .TRUE., TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .TRUE. ! UNDER_L0_OMP & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF IF (id%KEEP8(24).NE.0) THEN C WK_USER is not part of memory allocated by MUMPS C and is not counted, id%KEEP8(23) should be zero id%INFO(16) = TOTAL_MBYTES ELSE C Note that even for the case of ICNTL(23)>0 C we report here the memory effectively allocated C that can be smaller than ICNTL(23) ! id%INFO(16) = TOTAL_MBYTES ENDIF C ---------------------------------------------------- C Centralize memory statistics on the host C id%INFOG(18) = size of mem in Mbytes for facto, C for the processor using largest memory C id%INFOG(19) = size of mem in Mbytes for facto, C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(16), id%INFOG(18), IRANK ) CALL ZMUMPS_PRINT_ALLOCATED_MEM( PROK, PROKG, PRINT_MAXAVG, & MP, MPG, id%INFO(16), id%INFOG(18), id%INFOG(19), & id%NSLAVES, IRANK, & id%KEEP(1) ) C If WK_USER is provided, this memory excludes WK_USER IF (PROK ) THEN WRITE(MP,'(A,I12) ') & ' ** Eff. min. Space MBYTES for facto (INFO(16)):', & TOTAL_MBYTES ENDIF C ========================(INFO(16) RELATED)====================== C --------------------------------------- C COMPUTE EFFECTIVE MEMORY USED INFO(22) C --------------------------------------- PERLU_ON = .TRUE. MEM_EFF_ALLOCATED = .FALSE. CALL ZMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .FALSE. ! UNDER_L0_OMP & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN ! L0 activated CALL ZMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .TRUE., id%KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .TRUE. ! UNDER_L0_OMP & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF C -- TOTAL_BYTES and TOTAL_MBYTES includes both static C -- (MAXS) and BLR structures computed as the SUM of the PEAKS C -- (KEEP8(67) + KEEP8(70)) id%KEEP8(7) = TOTAL_BYTES C -- INFO(22) holds the effective space (in Mbytes) used by MUMPS C -- (it includes part of WK_USER used if provided by user) id%INFO(22) = TOTAL_MBYTES C ---------------------------------------------------- C Centralize memory statistics on the host C INFOG(21) = size of effective mem (Mbytes) for facto, C for the processor using largest memory C INFOG(22) = size of effective mem (Mbytes) for facto, C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(22), id%INFOG(21), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' ** Memory effectively used, max in Mbytes (INFOG(21)):', & id%INFOG(21) ENDIF WRITE( MPG,'(A,I12) ') & ' ** Memory effectively used, total in Mbytes (INFOG(22)):', & id%INFOG(22) END IF SUM_INFO22_THIS_NODE=0 CALL MPI_REDUCE( id%INFO(22), SUM_INFO22_THIS_NODE, 1, & MPI_INTEGER, & MPI_SUM, 0, id%KEEP(411), IERR ) CALL MPI_REDUCE( SUM_INFO22_THIS_NODE, MAX_SUM_INFO22_THIS_NODE, & 1, MPI_INTEGER, MPI_MAX, 0, id%COMM, IERR ) IF (PROKG .AND. PRINT_NODEINFO) THEN WRITE(MPG,'(A,I12)') & ' ** Max. effective space per compute node, in MBytes :', & MAX_SUM_INFO22_THIS_NODE ENDIF C IF (I_AM_SLAVE) THEN K67 = id%KEEP8(67) K68 = id%KEEP8(68) K70 = id%KEEP8(70) K74 = id%KEEP8(74) K75 = id%KEEP8(75) ELSE K67 = 0_8 K68 = 0_8 K70 = 0_8 K74 = 0_8 K75 = 0_8 ENDIF C -- Save the number of entries effectively used C in main working array S CALL MUMPS_SETI8TOI4(K67,id%INFO(21)) C IF (id%NPROCS .GT. 1 .AND. id%KEEP(50) .NE. 0) THEN CALL MPI_REDUCE( id%KEEP8(131), id%KEEP8(132), 1, MPI_INTEGER8, & MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%KEEP8(131), id%KEEP8(133), 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%KEEP(175), id%KEEP(176), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR ) ENDIF C IF (KEEP(400) .GT.0 ) THEN IF (.NOT. I_AM_SLAVE) THEN id%DKEEP(95) = 0.0D0 id%DKEEP(16) = 0.0D0 ENDIF IF (id%NPROCS .GT. 1) THEN C Compute average and max (across MPI's) CALL MPI_REDUCE(id%DKEEP(95), TMPTIME, 1, & MPI_DOUBLE_PRECISION, MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) TIMEAVG = TMPTIME CALL MPI_REDUCE(id%DKEEP(16), TMPFLOP, 1, & MPI_DOUBLE_PRECISION, MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) FLOPAVG = TMPFLOP IF (id%MYID.EQ.MASTER) THEN TIMEAVG = TIMEAVG / id%NSLAVES FLOPAVG = FLOPAVG / id%NSLAVES ENDIF CALL MPI_REDUCE(id%DKEEP(95), TIMEMAX, 1, & MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR) CALL MPI_REDUCE(id%DKEEP(16), FLOPMAX, 1, & MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR) C (PROKG may only be true on master) IF ( PROKG ) THEN WRITE(MPG,190) FLOPAVG, FLOPMAX WRITE(MPG,188) TIMEAVG, TIMEMAX ENDIF ELSE C Print DKEEP(95) directly without reduction IF ( PROKG ) THEN WRITE(MPG,189) id%DKEEP(16) WRITE(MPG,187) id%DKEEP(95) ENDIF ENDIF ENDIF IF ( PROKG ) THEN IF ( ( KEEP(38).NE.0 .OR. KEEP(20).NE.0 ) .AND. & KEEP(60) .EQ. 0 ) THEN WRITE(MPG,186) id%DKEEP(99) ENDIF C Elapsed time for factorization: IF (id%INFO(1) .GE.0) THEN WRITE(MPG,180) id%DKEEP(94) ELSE WRITE(MPG,185) id%DKEEP(94) ENDIF ENDIF C C Sum RINFO(2) : total number of flops for assemblies C Sum RINFO(3) : total number of flops for eliminations C Initialize RINFO(4) in case BLR was not activated RINFO(4) = RINFO(3) C C Should work even if the master does some work C CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) C Reduce needed to dimension small working array C on all procs during ZMUMPS_GATHER_SOLUTION KEEP(247) = 0 CALL MPI_REDUCE( KEEP(246), KEEP(247), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR) C C Reduce compression times: get max compression times CALL MPI_REDUCE( id%DKEEP(97), id%DKEEP(98), 1, & MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR) C CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MUMPS_REDUCEI8( id%KEEP8(31)+id%KEEP8(64),id%KEEP8(6), & MPI_SUM, MASTER, id%COMM ) C IF (id%MYID.EQ.0) THEN C In MegaBytes RINFOG(16) = dble(id%KEEP8(6)*int(KEEP(35),8))/dble(1D6) IF (KEEP(201).LE.0) THEN RINFOG(16) = ZERO ENDIF ENDIF CALL MUMPS_REDUCEI8( id%KEEP8(48),id%KEEP8(148), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(148), INFOG(9)) C CALL MPI_REDUCE( int(id%INFO(10),8), id%KEEP8(128), & 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SETI8TOI4(id%KEEP8(128), id%INFOG(10)) ENDIF C Use MPI_MAX for this one to get largest front size CALL MPI_ALLREDUCE( id%INFO(11), INFOG(11), 1, MPI_INTEGER, & MPI_MAX, id%COMM, IERR) C make maximum effective frontal size available on all procs C for solve phase C (Note that INFO(11) includes root size on root master) KEEP(133) = INFOG(11) CALL MPI_REDUCE( id%INFO(12), INFOG(12), 3, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( id%INFO(40), INFOG(50), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( KEEP(103), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(229) = INFOG(25) CALL MPI_REDUCE( KEEP(105), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(230) = INFOG(25) C id%INFO(25) = KEEP(98) CALL MPI_ALLREDUCE( id%INFO(25), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) C Extra copies due to in-place stacking CALL MUMPS_REDUCEI8( id%KEEP8(8), id%KEEP8(108), MPI_SUM, & MASTER, id%COMM ) C Entries in factors CALL MUMPS_SETI8TOI4(id%KEEP8(10), id%INFO(27)) CALL MUMPS_REDUCEI8( id%KEEP8(10),id%KEEP8(110), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(110), INFOG(29)) C Initialize INFO(28)/INFOG(35) in case BLR not activated id%INFO(28) = id%INFO(27) INFOG(35) = INFOG(29) C ============================== C LOW-RANK C ============================== IF ( KEEP(486) .NE. 0 ) THEN !LR is activated C Compute and Save local amount of flops in case of BLR RINFO(4) = dble(FLOP_FRFRONTS + FLOP_FACTO_FR - FLOP_LRGAIN & + FLOP_COMPRESS + FLOP_FRFRONTS) C C Compute and Save local number of entries in compressed factors C ITMP8 = id%KEEP8(10) - int(MRY_LU_LRGAIN,8) CALL MUMPS_SETI8TOI4( ITMP8, id%INFO(28)) C CALL MPI_REDUCE( MRY_LU_LRGAIN, TMP_MRY_LU_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_LU_FR, TMP_MRY_LU_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_CB_FR, TMP_MRY_CB_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_CB_LRGAIN, TMP_MRY_CB_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_LRGAIN, TMP_FLOP_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM_FR, TMP_FLOP_TRSM_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM_LR, TMP_FLOP_TRSM_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_FR, TMP_FLOP_UPDATE_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_LR, TMP_FLOP_UPDATE_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FRSWAP_COMPRESS, & TMP_FLOP_FRSWAP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_MIDBLK_COMPRESS, & TMP_FLOP_MIDBLK_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_LRLR3, TMP_FLOP_UPDATE_LRLR3 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(FLOP_ACCUM_COMPRESS, TMP_FLOP_ACCUM_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM, TMP_FLOP_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_PANEL, TMP_FLOP_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FRFRONTS, TMP_FLOP_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_COMPRESS, TMP_FLOP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_DECOMPRESS, TMP_FLOP_DECOMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_CB_COMPRESS, TMP_FLOP_CB_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_CB_DECOMPRESS,TMP_FLOP_CB_DECOMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FACTO_FR, TMP_FLOP_FACTO_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( CNT_NODES,TMP_CNT_NODES & , 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%NPROCS.GT.1) THEN FLOP_FACTO_LR = FLOP_FACTO_FR - FLOP_LRGAIN & + FLOP_COMPRESS + FLOP_FRFRONTS CALL MPI_REDUCE( FLOP_FACTO_LR, AVG_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN AVG_FLOP_FACTO_LR = AVG_FLOP_FACTO_LR/id%NPROCS ENDIF CALL MPI_REDUCE( FLOP_FACTO_LR, MIN_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FACTO_LR, MAX_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR) ENDIF ! NPROCS > 1 CALL MPI_REDUCE( TIME_UPDATE, TMP_TIME_UPDATE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR1, TMP_TIME_UPDATE_LRLR1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR2, TMP_TIME_UPDATE_LRLR2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR3, TMP_TIME_UPDATE_LRLR3 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_FRLR, TMP_TIME_UPDATE_FRLR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_FRFR, TMP_TIME_UPDATE_FRFR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DIAGCOPY, TMP_TIME_DIAGCOPY & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_COMPRESS,TMP_TIME_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_MIDBLK_COMPRESS, & TMP_TIME_MIDBLK_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRSWAP_COMPRESS, & TMP_TIME_FRSWAP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_CB_COMPRESS, TMP_TIME_CB_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP, TMP_TIME_DECOMP & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_UCFS, TMP_TIME_DECOMP_UCFS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LRASM_NIV1, TMP_TIME_LRASM_NIV1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_LRASM_LOCASM2, TMP_TIME_LRASM_LOCASM2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_LRASM_MAPLIG1, TMP_TIME_LRASM_MAPLIG1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_LRASM_CONTRIB2, TMP_TIME_LRASM_CONTRIB2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_FRASM_LOCASM2, TMP_TIME_FRASM_LOCASM2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_FRASM_MAPLIG1, TMP_TIME_FRASM_MAPLIG1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_FRASM_CONTRIB2, TMP_TIME_FRASM_CONTRIB2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_PANEL, TMP_TIME_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_I, TMP_TIME_FAC_I & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_MQ, TMP_TIME_FAC_MQ & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_SQ, TMP_TIME_FAC_SQ & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LRTRSM, TMP_TIME_LRTRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRTRSM, TMP_TIME_FRTRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRFRONTS, TMP_TIME_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LR_MODULE, TMP_TIME_LR_MODULE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN IF (id%NPROCS.GT.1) THEN C rename the stat variable so that COMPUTE_GLOBAL_GAINS can work for any C number of procs MRY_LU_FR = TMP_MRY_LU_FR MRY_LU_LRGAIN = TMP_MRY_LU_LRGAIN MRY_CB_FR = TMP_MRY_CB_FR MRY_CB_LRGAIN = TMP_MRY_CB_LRGAIN FLOP_LRGAIN = TMP_FLOP_LRGAIN FLOP_PANEL = TMP_FLOP_PANEL FLOP_TRSM = TMP_FLOP_TRSM FLOP_TRSM_FR = TMP_FLOP_TRSM_FR FLOP_TRSM_LR = TMP_FLOP_TRSM_LR FLOP_UPDATE_FR = TMP_FLOP_UPDATE_FR FLOP_UPDATE_LR = TMP_FLOP_UPDATE_LR FLOP_UPDATE_LRLR3 = TMP_FLOP_UPDATE_LRLR3 FLOP_COMPRESS = TMP_FLOP_COMPRESS FLOP_MIDBLK_COMPRESS = TMP_FLOP_MIDBLK_COMPRESS FLOP_FRSWAP_COMPRESS = TMP_FLOP_FRSWAP_COMPRESS FLOP_ACCUM_COMPRESS = TMP_FLOP_ACCUM_COMPRESS FLOP_CB_COMPRESS = TMP_FLOP_CB_COMPRESS FLOP_DECOMPRESS = TMP_FLOP_DECOMPRESS FLOP_CB_DECOMPRESS = TMP_FLOP_CB_DECOMPRESS FLOP_FRFRONTS = TMP_FLOP_FRFRONTS FLOP_FACTO_FR = TMP_FLOP_FACTO_FR CNT_NODES = TMP_CNT_NODES TIME_UPDATE = TMP_TIME_UPDATE /id%NPROCS TIME_UPDATE_LRLR1 = TMP_TIME_UPDATE_LRLR1 /id%NPROCS TIME_UPDATE_LRLR2 = TMP_TIME_UPDATE_LRLR2 /id%NPROCS TIME_UPDATE_LRLR3 = TMP_TIME_UPDATE_LRLR3 /id%NPROCS TIME_UPDATE_FRLR = TMP_TIME_UPDATE_FRLR /id%NPROCS TIME_UPDATE_FRFR = TMP_TIME_UPDATE_FRFR /id%NPROCS TIME_COMPRESS = TMP_TIME_COMPRESS /id%NPROCS TIME_MIDBLK_COMPRESS = TMP_TIME_MIDBLK_COMPRESS/id%NPROCS TIME_FRSWAP_COMPRESS = TMP_TIME_FRSWAP_COMPRESS/id%NPROCS TIME_DIAGCOPY = TMP_TIME_DIAGCOPY /id%NPROCS TIME_CB_COMPRESS = TMP_TIME_CB_COMPRESS /id%NPROCS TIME_PANEL = TMP_TIME_PANEL /id%NPROCS TIME_FAC_I = TMP_TIME_FAC_I /id%NPROCS TIME_FAC_MQ = TMP_TIME_FAC_MQ /id%NPROCS TIME_FAC_SQ = TMP_TIME_FAC_SQ /id%NPROCS TIME_LRTRSM = TMP_TIME_LRTRSM /id%NPROCS TIME_FRTRSM = TMP_TIME_FRTRSM /id%NPROCS TIME_FRFRONTS = TMP_TIME_FRFRONTS /id%NPROCS TIME_LR_MODULE = TMP_TIME_LR_MODULE /id%NPROCS TIME_DECOMP = TMP_TIME_DECOMP /id%NPROCS TIME_DECOMP_UCFS = TMP_TIME_DECOMP_UCFS /id%NPROCS TIME_LRASM_NIV1 = TMP_TIME_LRASM_NIV1 /id%NPROCS TIME_LRASM_LOCASM2 = TMP_TIME_LRASM_LOCASM2 /id%NPROCS TIME_LRASM_MAPLIG1 = TMP_TIME_LRASM_MAPLIG1 /id%NPROCS TIME_LRASM_CONTRIB2 = TMP_TIME_LRASM_CONTRIB2 /id%NPROCS TIME_FRASM_LOCASM2 = TMP_TIME_FRASM_LOCASM2 /id%NPROCS TIME_FRASM_MAPLIG1 = TMP_TIME_FRASM_MAPLIG1 /id%NPROCS TIME_FRASM_CONTRIB2 = TMP_TIME_FRASM_CONTRIB2 /id%NPROCS ENDIF CALL COMPUTE_GLOBAL_GAINS(id%KEEP8(110), & id%RINFOG(3), & id%KEEP8(49), PROKG, MPG) C Number of entries in factor INFOG(35) in C compressed form is updated as long as C BLR is activated, this independently of the C fact that factors are saved in LR. CALL MUMPS_SETI8TOI4(id%KEEP8(49), id%INFOG(35)) FRONTWISE = 0 C WRITE gains also compute stats stored in DKEEP array DO I=1,LR_TABSIZE LR_TAB(I) = id%DKEEP(I+LR_DKEEPSHIFT) LR_EPSILON = id%DKEEP(8) ENDDO CALL SAVEandWRITE_GAINS(FRONTWISE, KEEP(489), & LR_DKEEPSHIFT, LR_TABSIZE, LR_TAB, LR_EPSILON, & N, id%ICNTL(36), & KEEP(487), KEEP(488), KEEP(490), & KEEP(491), KEEP(50), KEEP(486), & KEEP(249)*max(KEEP(381), 1), & KEEP(472), KEEP(475), KEEP(478), & KEEP(480), KEEP(481), & KEEP(483), KEEP(484), & id%KEEP8(110), id%KEEP8(49), & KEEP(28), id%NPROCS, MPG, PROKG) C flops when BLR activated RINFOG(14) = id%DKEEP(56) DO I=1,18 id%DKEEP(I+LR_DKEEPSHIFT)=dble(LR_TAB(I)) ENDDO ELSE RINFOG(14) = 0.0D00 ENDIF IF (id%MYID .eq. MASTER) THEN KEEP(399) = KEEP399_SAVE ENDIF ENDIF C ============================== C NULL PIVOTS AND RANK-REVEALING C ============================== IF (KEEP(19).EQ.0.AND.KEEP(53).NE.0) THEN C restore KEEP(20) KEEP(20) = KEEP20_SAVE ENDIF IF(KEEP(110) .EQ. 1) THEN C -- make available to users the local number of null pivots detected C -- with ICNTL(24) = 1. id%INFO(18) = KEEP(109) CALL MPI_ALLREDUCE( KEEP(109), KEEP(112), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) ELSE id%INFO(18) = 0 KEEP(109) = 0 KEEP(112) = 0 ENDIF IF ( associated( id%PIVNUL_LIST) ) THEN DEALLOCATE(id%PIVNUL_LIST) NULLIFY(id%PIVNUL_LIST) ENDIF C set INFOG(28) even in case of error IF (id%MYID.EQ.MASTER) THEN C INFOG(28) deficiency resulting from ICNTL(24) and ICNTL(56) INFOG(28)=KEEP(112) IF (KEEP(17).GT.0) THEN INFOG(28)=KEEP(112)+KEEP(17) ENDIF ENDIF C IF (id%INFO(1).GE.0) THEN C{ PIVNUL_LIST not meaningful in case of error C (do not allocate) IF (id%MYID.EQ.MASTER) THEN IF ( INFOG(28) .GT. 0 ) THEN ALLOCATE(id%PIVNUL_LIST(INFOG(28)), stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=INFOG(28) END IF ENDIF ELSE C id%PIVNUL_LIST(1:KEEP(109)) used during sol_driver on slaves C to initialize id%RHSINTR IF (KEEP(109).GT.0) THEN ALLOCATE(id%PIVNUL_LIST(KEEP(109)), stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=INFOG(28) END IF ENDIF ENDIF C} ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 490 IF ( (KEEP(19).NE.0) .AND. (KEEP(143) .NE. KEEP(17)) ) THEN C C Raise a warning (on all MPI processes) since determinant or C inertia or null pivot list is not consistent with deficiency C computed with ICNTL(46)=1. C id%INFO(1) = id%INFO(1)+16 id%INFO(2) = KEEP(112)+KEEP(143) IF (KEEP(118) .GE. 40) THEN IF ( PROKG ) THEN WRITE(MPG,'(/A,A/,A,A,I8/,A,A,I8/)') & " WARNING: in the context of rank-revealing,", & " the inertia, determinant and pivnul list", & " are computed with RR (rank-revealing)-LU,", & " but the deficiency found by RR-LU: ", & id%INFO(2), & " is different from the deficiency computed", & " with ICNTL(56)>0: ", KEEP(112)+KEEP(17) ENDIF ELSE IF ( LP .GT. 0 ) THEN WRITE(LP,'(/A,A/,A/)') & " ERROR : in the context of rank-revealing,", & " the inertia, determinant and pivnul list", & " are not correct because RR LU not called " ENDIF ENDIF ENDIF C ======================================== C We now provide to the host the part of C PIVNUL_LIST resulting from the processing C of the root node and we update id%INFO(18) C on the processor holding the root to C include null pivots relative to the root C ======================================== IF ( KEEP(109).GT.0 ) THEN DO I=1, KEEP(109) id%PIVNUL_LIST(I)= & PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) ENDDO ENDIF IF (KEEP(17) .NE. 0) THEN IF (id%MYID .EQ. ID_ROOT) THEN C Include in id%INFO(18) null pivots resulting C from deficiency on the root. In this way, C the sum of all id%INFO(18) is equal to INFOG(28). id%INFO(18)=id%INFO(18)+KEEP(17) ENDIF IF (ID_ROOT .EQ. MASTER) THEN IF (id%MYID.EQ.MASTER) THEN C -------------------------------------------------- C Null pivots of root have been stored in C PIVNUL_LIST_STRUCT%PIVNUL_LIST( C KEEP(109)+1:KEEP(109)+KEEP(17) ) C Shift them at the end of the list because: C * this is what we need to build the null space C * we would otherwise overwrite them on the host C when gathering null pivots from other processors C -------------------------------------------------- DO I= KEEP(17), 1, -1 id%PIVNUL_LIST(KEEP(112)+I)= & PIVNUL_LIST_STRUCT%PIVNUL_LIST(KEEP(109)+I) ENDDO ENDIF ELSE C --------------------------------- C Null pivots of root must be sent C from the processor responsible of C the root to the host (or MASTER). C --------------------------------- IF (id%MYID .EQ. ID_ROOT) THEN CALL MPI_SEND( & PIVNUL_LIST_STRUCT%PIVNUL_LIST(KEEP(109)+1), & KEEP(17), MPI_INTEGER, MASTER, ZERO_PIV, & id%COMM, IERR) ELSE IF (id%MYID .EQ. MASTER) THEN CALL MPI_RECV(id%PIVNUL_LIST(KEEP(112)+1), KEEP(17), & MPI_INTEGER, ID_ROOT, ZERO_PIV, & id%COMM, STATUS, IERR ) ENDIF ENDIF ENDIF C =========================== C gather zero pivots indices C on the host node C =========================== C In case of non working host, the following code also C works considering that KEEP(109) is equal to 0 on C the non-working host IF(KEEP(110) .EQ. 1) THEN ALLOCATE(ITMP2(id%NPROCS),stat = IERR ) ! deallocated in 490 IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%NPROCS END IF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 490 CALL MPI_GATHER ( KEEP(109),1, MPI_INTEGER, & ITMP2(1), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF(id%MYID .EQ. MASTER) THEN POSBUF = ITMP2(1)+1 C First null pivot of master is in C position 1 of global list KEEP(220)=1 DO I = 1,id%NPROCS-1 IF (ITMP2(I+1).GT.0) THEN CALL MPI_RECV(id%PIVNUL_LIST(POSBUF), ITMP2(I+1), & MPI_INTEGER,I, & ZERO_PIV, id%COMM, STATUS, IERR) C Send position POSBUF of first null pivot of proc I C in global list. Will allow to quickly identify during C the solve step if one is concerned by a global position C K, 0 <= K <= INFOG(28). CALL MPI_SEND(POSBUF, 1, MPI_INTEGER, I, ZERO_PIV, & id%COMM, IERR) POSBUF = POSBUF + ITMP2(I+1) ENDIF ENDDO ELSE IF (KEEP(109).GT.0) THEN CALL MPI_SEND( & PIVNUL_LIST_STRUCT%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 ENDIF IF (associated( PIVNUL_LIST_STRUCT%PIVNUL_LIST)) THEN DEALLOCATE(PIVNUL_LIST_STRUCT%PIVNUL_LIST) NULLIFY(PIVNUL_LIST_STRUCT%PIVNUL_LIST) ENDIF C ===================================== C Statistics concerning the determinant C ===================================== C C 1/ on the host better take into account null pivots if scaling: C C Since null pivots are excluded from the computation C of the determinant, we also exclude the corresponding C scaling entries. Since those entries have already been C taken into account before the factorization, we multiply C the determinant on the host by the scaling values corresponding C to pivots in PIVNUL_LIST. IF (id%MYID.EQ.MASTER .AND. LSCAL. AND. KEEP(258).NE.0) THEN K = min(KEEP(143), KEEP(17)) K = max(K, 0) DO I = 1, KEEP(112)+ K c DO I = 1, id%INFOG(28) ! all null pivots + singular values CALL ZMUMPS_UPDATEDETER_SCALING( & id%ROWSCA(id%PIVNUL_LIST(I)), & id%DKEEP(6), KEEP(259)) CALL ZMUMPS_UPDATEDETER_SCALING( & id%COLSCA(id%PIVNUL_LIST(I)), & id%DKEEP(6), KEEP(259)) ENDDO ENDIF C C 2/ Swap signs depending on pivoting on each proc C IF (KEEP(258).NE.0) THEN C Return the determinant in INFOG(34) and RINFOG(12/13) IF (KEEP(260).EQ.-1) THEN ! Local to each processor id%DKEEP(6)=-id%DKEEP(6) id%DKEEP(7)=-id%DKEEP(7) ENDIF C C 3/ Perform a reduction C CALL ZMUMPS_DETER_REDUCTION( & id%COMM, id%DKEEP(6), KEEP(259), & RINFOG(12), INFOG(34), id%NPROCS) C C 4/ Swap sign if needed C IF (id%KEEP(50).EQ.0 .AND. id%MYID.EQ. MASTER) THEN C Modify sign of determinant according C to unsymmetric permutation (max-trans C of max-weighted matching) IF (id%KEEP(23).NE.0) THEN CALL ZMUMPS_DETER_SIGN_PERM( & RINFOG(12), id%N, & id%UNS_PERM(1) ) C Remark that RINFOG(12/13) are modified only C on the host but will be broadcast on exit C from MUMPS (see ZMUMPS_DRIVER) ENDIF ENDIF ENDIF 490 IF (allocated(ITMP2)) DEALLOCATE(ITMP2) C C ===================================== C Statistics relative to min/max pivots C ===================================== CALL MPI_REDUCE( id%DKEEP(19), RINFOG(19), 1, & MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(20), RINFOG(20), 1, & MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(21), RINFOG(21), 1, & MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR ) C ========================================= C Centralized number of swaps for pivoting C ========================================= CALL MPI_REDUCE( id%KEEP8(80), ITEMP8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF (id%MYID .EQ. MASTER) THEN CALL MUMPS_SETI8TOI4(ITEMP8,id%INFOG(48)) ENDIF C ========================================== C Centralized largest increase of panel size C ========================================== CALL MPI_REDUCE( id%KEEP(425), id%INFOG(49), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN C{ ----------------------------- C PRINT STATISTICS (on master) C ----------------------------- WRITE(MPG,99984) RINFOG(2),RINFOG(3),KEEP(52), & id%KEEP8(148), & id%KEEP8(128), INFOG(11), id%KEEP8(110) IF (id%KEEP(50) == 0) THEN ! off diag pivots WRITE(MPG, 99985) INFOG(12) END IF IF (id%KEEP(50) .NE. 1) THEN ! delayed pivots WRITE(MPG, 99982) INFOG(13) END IF IF (KEEP(97) .NE. 0) THEN ! tiny pivots WRITE(MPG, '(A,D16.4)') & ' Effective static pivoting thresh., CNTL(4) =', SEUIL WRITE(MPG, 99986) INFOG(25) ENDIF IF (id%KEEP(50) == 2) THEN !number of 2x2 pivots in type 1 nodes WRITE(MPG, 99988) KEEP(229) !number of 2x2 pivots in type 2 nodes WRITE(MPG, 99989) KEEP(230) ENDIF !number of zero pivots IF (KEEP(110) .NE.0) THEN WRITE(MPG, 99991) KEEP(112) ENDIF !Deficiency on root IF ( KEEP(19) .ne. 0 ) c IF ( KEEP(17) .ne. 0 ) & WRITE(MPG, 99983) KEEP(17) !Total deficiency IF (KEEP(110).NE.0.OR.KEEP(19).NE.0) & WRITE(MPG, 99992) KEEP(17)+KEEP(112) ! = INFOG(28) !Smallest pivot with also null pivots in abs value WRITE(MPG, 99995) RINFOG(19) !Smallest pivot in abs value WRITE(MPG, 99993) RINFOG(20) !Largest pivot in abs value WRITE(MPG, 99994) RINFOG(21) !value of ICNTL(12) that was effectively used. WRITE(MPG, 99996) INFOG(24) ! Memory compress WRITE(MPG, 99981) INFOG(14) ! Extra copies due to ip stack in unsym case ! in core case (or OLD_OOC_PANEL) IF (id%KEEP8(108) .GT. 0_8) THEN WRITE(MPG, 99980) id%KEEP8(108) ENDIF IF ((KEEP(60).NE.0) .AND. INFOG(25).GT.0) THEN ! Schur on and tiny pivots set in last level ! before the Schur if KEEP(114)=0 WRITE(MPG, '(A)') & " ** Warning Static pivoting was necessary" WRITE(MPG, '(A)') & " ** to factor interior variables with Schur ON" ENDIF IF (KEEP(258).NE.0) THEN WRITE(MPG,99978) RINFOG(12) WRITE(MPG,99979) RINFOG(13) WRITE(MPG,99977) INFOG(34) ENDIF C} END IF * ========================================== * * End of Factorization Phase * * ========================================== C C Goto 500 is done when C LOAD_INIT C OOC_INIT_FACTO C MUMPS_FDM_INIT #if ! defined(NO_FDM_DESCBAND) C MUMPS_FDBD_INIT #endif #if ! defined(NO_FDM_MAPROW) C MUMPS_FMRD_INIT #endif C are all called. C 500 CONTINUE C Redo free INTARR and DBLARR in case an error occurred C after allocating them and before freeing them. IF (associated(DBLARR)) THEN DEALLOCATE(DBLARR) NULLIFY(DBLARR) ENDIF IF (allocated(INTARR)) THEN DEALLOCATE(INTARR) ENDIF IF ( KEEP(38) .NE. 0) THEN IF (associated(idintr%root%RG2L)) THEN DEALLOCATE(idintr%root%RG2L) NULLIFY(idintr%root%RG2L) ENDIF ENDIF #if ! defined(NO_FDM_DESCBAND) IF (I_AM_SLAVE) THEN CALL MUMPS_FDBD_END(id%INFO(1)) ! INFO(1): input only ENDIF #endif #if ! defined(NO_FDM_MAPROW) IF (I_AM_SLAVE) THEN CALL MUMPS_FMRD_END(id%INFO(1)) ! INFO(1): input only ENDIF #endif IF (I_AM_SLAVE) THEN C Terminate BLR module except if it is still needed for solve IF ( & ( & (KEEP(486).EQ.2) & ) & .AND. id%INFO(1).GE.0 & ) THEN C Store pointer to BLR_ARRAY in MUMPS structure C (requires successful factorization otherwise module is freed) CALL ZMUMPS_BLR_MOD_TO_STRUC(id%BLRARRAY_ENCODING) ELSE C INFO(1) positive or negative CALL ZMUMPS_BLR_END_MODULE(id%INFO(1), id%KEEP8, id%KEEP(34)) ENDIF ENDIF IF (I_AM_SLAVE) THEN CALL MUMPS_FDM_END('A') C Terminate BLR module except if it is still needed for solve IF ( & ( & (KEEP(486).EQ.2) & ) & .AND. id%INFO(1).GE.0 & ) THEN CALL MUMPS_FDM_MOD_TO_STRUC('F', id%FDM_F_ENCODING, & id%INFO(1)) IF (.NOT. associated(id%FDM_F_ENCODING)) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_FAC_DRIVER" ENDIF ELSE CALL MUMPS_FDM_END('F') ENDIF ENDIF C C Goto 514 is done when an C error occurred in MUMPS_FDM_INIT C or (after FDM_INIT but before C OOC_INIT) C 514 CONTINUE IF ( I_AM_SLAVE ) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL ZMUMPS_OOC_END_FACTO(id%KEEP,id%KEEP8, & id%OOC_MAX_NB_NODES_FOR_ZONE,id%OOC_TOTAL_NB_NODES, & id%OOC_FILE_NAMES, id%INFO, id%OOC_FILE_NAME_LENGTH, & id%OOC_NB_FILES, IERR) IF (id%ASSOCIATED_OOC_FILES) THEN id%ASSOCIATED_OOC_FILES = .FALSE. ENDIF IF (IERR.LT.0 .AND. id%INFO(1) .GE. 0) id%INFO(1) = IERR ENDIF IF (WK_USER_PROVIDED) THEN C at the end of a phase S is always null when WK_USER provided NULLIFY(id%S) ELSE IF (KEEP(201).NE.0) THEN C ---------------------------------------- C In OOC or if KEEP(201).EQ.-1 we always C free S at end of factorization. As id%S C may be unassociated in case of error C during or before the allocation of id%S, C we only free S when it was associated. C ---------------------------------------- IF (associated(id%S)) THEN CALL ZMUMPS_DM_FREE_S_WK(id%S, KEEP(430)) C Reset KEEP(430)=0 since S will be allocated C from Fortran during solve KEEP(430) = 0 ENDIF NULLIFY(id%S) ! in all cases id%KEEP8(23)=0_8 ELSE ! in core CALL ZMUMPS_TRY_COMPACT_FACTORS(ICNTL49_LOC, & WK_USER_PROVIDED, id%S, id%KEEP, id%KEEP8, & id%INFO, id%MYID, id%ICNTL, PROK, MP, & ZMUMPS_LBUFR_BYTES8, ZMUMPS_LBUF8, & LIWK, LIWK8 ) ENDIF ELSE ! host not working IF (WK_USER_PROVIDED) THEN C at the end of a phase S is always freed when WK_USER provided NULLIFY(id%S) ELSE IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) id%KEEP8(23)=0_8 END IF END IF C C Goto 513 is done in case of error where LOAD_INIT was C called but not the scaling nor OOC_INIT_FACTO. 513 CONTINUE IF ( I_AM_SLAVE ) THEN CALL MUMPS_LOAD_END( id%INFO(1), id%NSLAVES, IERR ) IF (IERR.LT.0 .AND. id%INFO(1) .GE. 0) id%INFO(1) = IERR ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C C Goto 516 is done in case of error when GPU initialiwqtion C has been performed and scaling was optionally computed but C not LOAD_INIT nor OOC_INIT_FACTO. We can then extract C scaling arrays in case of error. 516 CONTINUE C -------------------------------------------- C We now build id%ROWSCA_loc and id%COLSCA_loc C in case of successful factorization, in the C numbering associated to the fully summed C variables of the frontal matrices. C This requires the factorization to be C successful because otherwise we do not have C the final lists of pivots associated to C the fronts, including delayed pivots and C symmetric/unsymmetric permutations done C during the factorization process. C -------------------------------------------- IF (LSCAL .AND. id%INFO(1).GE.0) THEN CALL ZMUMPS_EXTRACT_SCALING(id) C occurs during scaling extraction, keep the error. IF ( id%INFO(1) .LT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) "Facto OK but error during EXTRACT_SCALING", & id%INFO(1:2) ENDIF ENDIF ENDIF C C Goto 517 is done when an error occurs when GPU initialization C has been performed but not LOAD_INIT or OOC_INIT_FACTO, e.g. C when an error occurred during the scaling. 517 CONTINUE IF (associated( PIVNUL_LIST_STRUCT%PIVNUL_LIST)) THEN DEALLOCATE(PIVNUL_LIST_STRUCT%PIVNUL_LIST) NULLIFY(PIVNUL_LIST_STRUCT%PIVNUL_LIST) ENDIF C C Goto 530 is done when an error occurs before C the calls to GPU_INIT, LOAD_INIT and OOC_INIT_FACTO 530 CONTINUE C Fwd in facto: free RHS_MUMPS in case C it was allocated. IF (RHS_MUMPS_ALLOCATED) DEALLOCATE(RHS_MUMPS) NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. C id%KEEP8(26) = KEEP826_SAVE RETURN 120 FORMAT(/' Local redistrib: data local/sent =',I16,I16) 125 FORMAT(/' Redistrib: total data local/sent =',I16,I16) 130 FORMAT(//'****** FACTORIZATION STEP ********'/) 140 FORMAT(/' Statistics on the scaling phase' & /' Elapsed time for scaling =',F12.4) 160 FORMAT( & ' Elapsed time to reformat/distribute matrix =',F12.4/) 166 FORMAT(' Max difference from 1 after scaling the entries', & ' for ONE-NORM (option 7/8) =',D9.2/) 170 FORMAT(' STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' Size of internal working array S =',I16/ & ' Size of internal working array IS =',I16/ & ' Minimum (ICNTL(14)=0) size of S =',I16/ & ' Minimum (ICNTL(14)=0) size of IS =',I16/ & ' Real space for original matrix =',I16/ & ' Integer space for original matrix =',I16/ & ' INFO(3) Real space for factors (estimated) =',I16/ & ' INFO(4) Integer space for factors (estim.) =',I16/ & ' Maximum frontal size (estimated) =',I16) 172 FORMAT(' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' Number of working processes =',I16/ & ' ICNTL(22) Out-of-core option =',I16/ & ' ICNTL(35) BLR activation (eff. choice) =',I16/ & ' ICNTL(37) BLR CB compression (eff. choice) =',I16/ & ' ICNTL(49) Compact workarray S (end facto.) =',I16/ & ' ICNTL(56) Effective value during facto. =',I16/ & ' ICNTL(14) Memory relaxation =',I16/ & ' INFOG(3) Real space for factors (estimated)=',I16/ & ' INFOG(4) Integer space for factors (estim.)=',I16/ & ' Maximum frontal size (estimated) =',I16/ & ' Number of nodes in the tree =',I16/ & ' ICNTL(23) Memory allowed (value on host) =',I16/ & ' Sum over all procs =',I16/ & ' Memory provided by user, sum of LWK_USER =',I16/ & ' Effective threshold for pivoting, CNTL(1) =',D16.4) 173 FORMAT( ' Perform forward during facto, NRHS =',I16) 174 FORMAT( ' KEEP(268) Relaxed pivoting effective value =',I16) 180 FORMAT(/' Elapsed time for factorization =', & F12.4) 185 FORMAT(/' Elapsed time for (failed) factorization =', & F12.4) 186 FORMAT(/' Elapsed time to process root node =', & F12.4) 187 FORMAT( ' Elapsed time under L0 =',F12.4) 188 FORMAT( ' Elapsed time under L0 (avg/max across MPI) =', & F12.4,F12.4) 189 FORMAT(/' Flops under L0 layer =',1PD12.3) 190 FORMAT(/' Flops under L0 layer (avg/max across MPI) =', & 1PD12.3,1PD12.3) 99977 FORMAT( ' INFOG(34) Determinant (base 2 exponent) =', & I16) 99978 FORMAT( ' RINFOG(12) Determinant (real part) =', & F16.8) 99979 FORMAT( ' RINFOG(12) Determinant (imaginary part) =', & F16.8) 99980 FORMAT( ' Extra copies due to In-Place stacking =', & I16) 99981 FORMAT( ' INFOG (14) Number of memory compress =', & I16) 99982 FORMAT( ' INFOG (13) Number of delayed pivots =', & I16) 99983 FORMAT( ' Nb of singularities detected by ICNTL(56) =', & I16) 99991 FORMAT( ' Nb of null pivots detected by ICNTL(24) =', & I16) 99992 FORMAT( ' INFOG (28) Estimated deficiency =', & I16) 99995 FORMAT( ' RINFOG(19) Smallest pivot WITH perturbed pivots =', & 1PD10.3) 99993 FORMAT( ' RINFOG(20) Smallest pivot WITHOUT perturbed pivots =', & 1PD10.3) 99994 FORMAT( ' RINFOG(21) Largest pivot in absolute value =', & 1PD10.3) 99996 FORMAT( ' INFOG (24) Effective value of ICNTL(12) =', & I16) 99984 FORMAT(/'Leaving factorization with ...'/ & ' RINFOG (2) Operations in node assembly =', & 1PD10.3/ & ' ------ (3) Operations in node elimination =', & 1PD10.3/ & ' ICNTL (8) Scaling effectively used =', & I16/ & ' INFOG (9) Real space for factors =', & I16/ & ' INFOG (10) Integer space for factors =', & I16/ & ' INFOG (11) Maximum front size =', & I16/ & ' INFOG (29) Number of entries in factors =', & I16) 99985 FORMAT( ' INFOG (12) Number of off diagonal pivots =', & I16) 99986 FORMAT( ' INFOG (25) Number of tiny pivots(static) =', & I16) 99988 FORMAT( ' Number of 2x2 pivots in type 1 nodes =', & I16) 99989 FORMAT( ' Number of 2x2 pivots in type 2 nodes =', & I16) END SUBROUTINE ZMUMPS_FAC_DRIVER C SUBROUTINE ZMUMPS_PRINT_ALLOCATED_MEM( PROK, PROKG, PRINT_MAXAVG, & MP, MPG, INFO16, INFOG18, INFOG19, NSLAVES, IRANK, KEEP ) IMPLICIT NONE C C Purpose: C ======= C Print memory allocated during factorization C - called at beginning of factorization in full-rank C - called at end of factorization in low-rank (because C of dynamic allocations) C LOGICAL, INTENT(IN) :: PROK, PROKG, PRINT_MAXAVG INTEGER, INTENT(IN) :: MP, MPG, INFO16, INFOG18, INFOG19 INTEGER, INTENT(IN) :: IRANK, NSLAVES INTEGER, INTENT(IN) :: KEEP(500) C IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' ** Memory allocated, max in Mbytes (INFOG(18)):', & INFOG18 ENDIF WRITE( MPG,'(/A,I12) ') & ' ** Memory allocated, total in Mbytes (INFOG(19)):', & INFOG19 END IF RETURN END SUBROUTINE ZMUMPS_PRINT_ALLOCATED_MEM SUBROUTINE ZMUMPS_AVGMAX_STAT8(PROKG, MPG, VAL, NSLAVES, & PRINT_MAXAVG, COMM, MSG) IMPLICIT NONE INCLUDE 'mpif.h' LOGICAL, intent(in) :: PROKG INTEGER, intent(in) :: MPG INTEGER(8), intent(in) :: VAL INTEGER, intent(in) :: NSLAVES LOGICAL, intent(in) :: PRINT_MAXAVG INTEGER, intent(in) :: COMM CHARACTER*48 MSG C Local INTEGER(8) MAX_VAL INTEGER IERR, MASTER DOUBLE PRECISION LOC_VAL, AVG_VAL PARAMETER(MASTER=0) C CALL MUMPS_REDUCEI8( VAL, MAX_VAL, MPI_MAX, MASTER, COMM) LOC_VAL = dble(VAL)/dble(NSLAVES) CALL MPI_REDUCE( LOC_VAL, AVG_VAL, 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, COMM, IERR ) IF (PROKG) THEN IF (PRINT_MAXAVG) THEN WRITE(MPG,100) " Average", MSG, int(AVG_VAL,8) ELSE WRITE(MPG,110) MSG, MAX_VAL ENDIF ENDIF RETURN 100 FORMAT(A8,A48,I18) 110 FORMAT(A48,I18) END SUBROUTINE ZMUMPS_AVGMAX_STAT8 C C C ================================================================== C SUBROUTINE ZMUMPS_EXTRACT_SCALING(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C Extract distributed scaling arrays from ZMUMPS_EXTRACT_SCALING C In case of unsymmetric permutation, ROWSCA and COLSCA correspond C to Dr and Dc, in the expression Dr A Q Dc. In other terms, Dc C is compatbile with the front column indices, it does not C correspond to the column indices of A, meaning that Q is not C needed to just extract the scaling values. C C TYPE(ZMUMPS_STRUC) :: id INTEGER, EXTERNAL :: MUMPS_PROCNODE C C MPI C === C INCLUDE 'mpif.h' C C Local declarations C ================== C DOUBLE PRECISION, DIMENSION(:), POINTER :: COLSCA DOUBLE PRECISION, DIMENSION(:), POINTER :: ROWSCA INTEGER, PARAMETER :: MASTER = 0 C INTEGER :: ISTEP, NPIV, LIELL INTEGER :: IERR_MPI, allocok INTEGER :: ISCA INTEGER :: JROW, JCOL, IPOS, JJ ! access to IS INTEGER :: LIW_PASSED INTEGER(8) :: LALLOC C C Free and reallocate distributed scaling arrays : C - in symmetric, COLSCA_loc points on ROWSCA_loc. C - not allocated if KEEP(89)=0 C NULLIFY(ROWSCA) NULLIFY(COLSCA) IF (associated(id%ROWSCA_loc)) THEN DEALLOCATE(id%ROWSCA_loc) NULLIFY(id%ROWSCA_loc) ENDIF IF (associated(id%COLSCA_loc)) THEN IF (id%KEEP(50) .EQ. 0) THEN DEALLOCATE(id%COLSCA_loc) ENDIF NULLIFY(id%COLSCA_loc) ENDIF C id%ROWSCA and id%COLSCA are available on master, C allocate ROWSCA and COLSCA of order N on other procs IF ( id%MYID .EQ. MASTER ) THEN ROWSCA => id%ROWSCA COLSCA => id%COLSCA IF (.NOT. associated(ROWSCA)) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_EXTRACT_SCALING" CALL MUMPS_ABORT() ENDIF IF (.NOT. associated(COLSCA)) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_EXTRACT_SCALING" CALL MUMPS_ABORT() ENDIF ELSE IF (id%KEEP(50).EQ.0) THEN ALLOCATE(ROWSCA(id%N),COLSCA(id%N),stat=allocok) LALLOC = int(id%N+id%N,8) ELSE ALLOCATE(ROWSCA(id%N),stat=allocok) COLSCA => ROWSCA LALLOC = int(id%N,8) ENDIF IF (allocok .GT. 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(LALLOC,id%INFO(2)) ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C Jump to 110 in case of error on ROWSCA or COLSCA C on one of the MPI processes. IF (id%INFO(1) .LT. 0) GOTO 110 C IF ( id%KEEP(89) .GT. 0) THEN IF (id%KEEP(50).EQ.0) THEN ALLOCATE(id%ROWSCA_loc(id%KEEP(89)), & id%COLSCA_loc(id%KEEP(89)),stat=allocok) LALLOC = int(id%KEEP(89),8)*2_8 ELSE ALLOCATE(id%ROWSCA_loc(id%KEEP(89)),stat=allocok) id%COLSCA_loc => id%ROWSCA_loc LALLOC = int(id%KEEP(89),8) ENDIF IF (allocok .GT. 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(LALLOC,id%INFO(2)) ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C Jump to 100 in case of error (we free everything) IF (id%INFO(1) .LT. 0) GOTO 100 CALL MPI_BCAST(ROWSCA(1), id%N, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR_MPI) IF (id%KEEP(50) .EQ. 0) THEN CALL MPI_BCAST(COLSCA(1), id%N, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR_MPI) ENDIF LIW_PASSED = max(id%KEEP(32),1) ISCA = 1 IF ( id%MYID .ne. MASTER .OR. & id%KEEP(46) .eq. 1 ) THEN ! I_AM_SLAVE DO ISTEP = 1, id%KEEP(28) IF ( id%MYID_NODES.EQ. MUMPS_PROCNODE( & id%PROCNODE_STEPS(ISTEP), & id%KEEP(199) ) ) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, id%KEEP, & NPIV, LIELL, IPOS, & id%IS(1), LIW_PASSED, id%PTLUST_S(1), id%STEP(1), id%N) IF ( id%KEEP(50) .EQ. 0 ) THEN C Row indices: JROW = IPOS + 1 C Column indices: JCOL = IPOS + 1 + LIELL ELSE C Use row indices because column indices may have C been set to negative to flag 2x2 pivots JROW = IPOS + 1 ENDIF IF (id%KEEP(50).EQ.0) THEN DO JJ = 1, NPIV id%ROWSCA_loc(ISCA+JJ-1) = ROWSCA(id%IS(JROW+JJ-1)) id%COLSCA_loc(ISCA+JJ-1) = COLSCA(id%IS(JCOL+JJ-1)) ENDDO ELSE DO JJ = 1, NPIV id%ROWSCA_loc(ISCA+JJ-1) = ROWSCA(id%IS(JROW+JJ-1)) ENDDO ENDIF ISCA = ISCA + NPIV ENDIF ENDDO ENDIF C End of EXTRACT_SCALING, we keep id%ROWSCA_loc and id%COLSCA_loc C but free ROWSCA and COLSCA GOTO 110 RETURN 100 CONTINUE C Exit with error, free what was allocated IF (associated(id%ROWSCA_loc)) THEN DEALLOCATE(id%ROWSCA_loc) NULLIFY(id%ROWSCA_loc) ENDIF IF (associated(id%COLSCA_loc)) THEN IF (id%KEEP(50) .EQ. 0) THEN DEALLOCATE(id%COLSCA_loc) ENDIF NULLIFY(id%COLSCA_loc) ENDIF 110 CONTINUE C Free local ROWSCA and COLSCA arrays IF ( id%MYID .NE. 0) THEN IF (associated(ROWSCA)) DEALLOCATE(ROWSCA) IF ( id%KEEP(50) .EQ. 0 ) THEN IF (associated(COLSCA)) DEALLOCATE(COLSCA) ENDIF ENDIF NULLIFY(ROWSCA) NULLIFY(COLSCA) RETURN END SUBROUTINE ZMUMPS_EXTRACT_SCALING C C ================================================================== C SUBROUTINE ZMUMPS_EXTRACT_SCHUR_REDRHS(id,idintr) USE ZMUMPS_STRUC_DEF USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_INTR_STRUC IMPLICIT NONE C C Purpose C ======= C C Extract the Schur and possibly also the reduced right-hand side C (if Fwd in facto) from the processor working on Schur and copy C it into the user datastructures id%SCHUR and id%REDRHS on the host. C This routine assumes that the integer list of the Schur has not C been permuted and still corresponds to LISTVAR_SCHUR. C C If the Schur is centralized, the master of the Schur holds the C Schur and possibly also the reduced right-hand side. C If the Schur is distribued (already built in user's datastructure), C then the master of the Schur may hold the reduced right-hand side, C in which case it is available in roota%RHS_CNTR_MASTER_ROOT. C TYPE (ZMUMPS_STRUC) :: id TYPE (ZMUMPS_INTR_STRUC) :: idintr C C Local variables C =============== C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ID_SCHUR, SIZE_SCHUR, LD_SCHUR, IB, BL4 INTEGER(4) :: I4 ! 32-bit even in 64-bit version INTEGER :: ROW_LENGTH, I INTEGER(8) :: SURFSCHUR8, BL8, SHIFT8 INTEGER(8) :: ISCHUR_SRC, ISCHUR_DEST, ISCHUR_SYM, ISCHUR_UNS C C External functions C ================== C INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE C Quick return in case factorization did not terminate correctly IF (id%INFO(1) .LT. 0) RETURN C Quick return if Schur option off IF (id%KEEP(60) .EQ. 0) RETURN C Get Schur id ID_SCHUR =MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(max(id%KEEP(20),id%KEEP(38)))), & id%KEEP(199)) IF ( id%KEEP( 46 ) .NE. 1 ) THEN ID_SCHUR = ID_SCHUR + 1 END IF C Get size of Schur IF (id%MYID.EQ.ID_SCHUR) THEN IF (id%KEEP(60).EQ.1) THEN C Sequential Schur LD_SCHUR = & id%IS(id%PTLUST_S(id%STEP(id%KEEP(20)))+2+id%KEEP(IXSZ)) SIZE_SCHUR = LD_SCHUR - id%KEEP(253) ELSE C Parallel Schur LD_SCHUR = -999999 ! not used SIZE_SCHUR = idintr%root%TOT_ROOT_SIZE ENDIF ELSE IF (id%MYID .EQ. MASTER) THEN SIZE_SCHUR = id%KEEP(116) LD_SCHUR = -44444 ! Not used ELSE C Proc is not concerned with Schur, return RETURN ENDIF SURFSCHUR8 = int(SIZE_SCHUR,8)*int(SIZE_SCHUR,8) C ===================================== C Case of parallel Schur: if REDRHS C was requested, obtain it directly C from idintr%roota%RHS_CNTR_MASTER_ROOT C ===================================== IF (id%KEEP(60) .GT. 1) THEN IF (id%KEEP(221).EQ.1 .AND. id%KEEP(252).GT.0) THEN DO I = 1, id%KEEP(253) IF (ID_SCHUR.EQ.MASTER) THEN ! Necessarily = id%MYID CALL zcopy(SIZE_SCHUR, & idintr%roota%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), 1, & id%REDRHS((I-1)*id%LREDRHS+1), 1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN C Send CALL MPI_SEND( & idintr%roota%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), & SIZE_SCHUR, & MPI_DOUBLE_COMPLEX, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE ! MYID.EQ.MASTER C Receive CALL MPI_RECV( id%REDRHS((I-1)*id%LREDRHS+1), & SIZE_SCHUR, & MPI_DOUBLE_COMPLEX, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF ENDDO C ------------------------------ C In case of parallel Schur, we C free roota%RHS_CNTR_MASTER_ROOT C ------------------------------ IF (id%MYID.EQ.ID_SCHUR) THEN DEALLOCATE(idintr%roota%RHS_CNTR_MASTER_ROOT) NULLIFY (idintr%roota%RHS_CNTR_MASTER_ROOT) ENDIF ENDIF C return because this is all we need to do C in case of parallel Schur complement RETURN ENDIF C ============================ C Centralized Schur complement C ============================ C PTRAST has been freed at the moment of calling this C routine. Schur is available through C PTRFAC(IW( PTLUST_S( STEP(KEEP(20)) ) + 4 +KEEP(IXSZ) )) IF (id%KEEP(252).EQ.0) THEN C CASE 1 (ORIGINAL CODE): C Schur is contiguous on ID_SCHUR IF ( ID_SCHUR .EQ. MASTER ) THEN ! Necessarily equals id%MYID C --------------------- C Copy Schur complement C --------------------- CALL ZMUMPS_COPYI8SIZE( SURFSCHUR8, & id%S(id%PTRFAC(id%STEP(id%KEEP(20)))), & id%SCHUR(1) ) ELSE C ----------------------------------------- C The processor responsible of the Schur C complement sends it to the host processor C Use blocks to avoid too large messages. C ----------------------------------------- BL8=int(huge(I4)/id%KEEP(35)/10,8) DO IB=1, int((SURFSCHUR8+BL8-1_8) / BL8) SHIFT8 = int(IB-1,8) * BL8 ! Where to send BL4 = int(min(BL8,SURFSCHUR8-SHIFT8)) ! Size of block IF ( id%MYID .eq. ID_SCHUR ) THEN C Send Schur complement CALL MPI_SEND( id%S( SHIFT8 + & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ)))), & BL4, & MPI_DOUBLE_COMPLEX, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE IF ( id%MYID .eq. MASTER ) THEN C Receive Schur complement CALL MPI_RECV( id%SCHUR(1_8 + SHIFT8), & BL4, & MPI_DOUBLE_COMPLEX, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) END IF ENDDO END IF ELSE C CASE 2 (Fwd in facto): Schur is not contiguous on ID_SCHUR, C process it row by row. C C 2.1: We first centralize Schur complement into id%SCHUR ISCHUR_SRC = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) ISCHUR_DEST= 1_8 DO I=1, SIZE_SCHUR ROW_LENGTH = SIZE_SCHUR IF (ID_SCHUR.EQ.MASTER) THEN ! Necessarily = id%MYID CALL zcopy(ROW_LENGTH, id%S(ISCHUR_SRC), 1, & id%SCHUR(ISCHUR_DEST),1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN C Send CALL MPI_SEND( id%S(ISCHUR_SRC), ROW_LENGTH, & MPI_DOUBLE_COMPLEX, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE C Recv CALL MPI_RECV( id%SCHUR(ISCHUR_DEST), & ROW_LENGTH, & MPI_DOUBLE_COMPLEX, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF ISCHUR_SRC = ISCHUR_SRC+int(LD_SCHUR,8) ISCHUR_DEST= ISCHUR_DEST+int(SIZE_SCHUR,8) ENDDO C 2.2: Get REDRHS on host C 2.2.1: Symmetric => REDRHS is available in last KEEP(253) C rows of Schur structure on ID_SCHUR C 2.2.2: Unsymmetric => REDRHS corresponds to last KEEP(253) C columns. However it must be transposed. IF (id%KEEP(221).EQ.1) THEN ! Implies Fwd in facto ISCHUR_SYM = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) * & int(LD_SCHUR,8) ISCHUR_UNS = & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) ISCHUR_DEST = 1_8 DO I = 1, id%KEEP(253) IF (ID_SCHUR .EQ. MASTER) THEN ! necessarily = id%MYID IF (id%KEEP(50) .EQ. 0) THEN CALL zcopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, & id%REDRHS(ISCHUR_DEST), 1) ELSE CALL zcopy(SIZE_SCHUR, id%S(ISCHUR_SYM), 1, & id%REDRHS(ISCHUR_DEST), 1) ENDIF ELSE IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(50) .EQ. 0) THEN C Use id%S(ISCHUR_SYM) as temporary contig. workspace C of size SIZE_SCHUR. CALL zcopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, & id%S(ISCHUR_SYM), 1) ENDIF CALL MPI_SEND(id%S(ISCHUR_SYM), SIZE_SCHUR, & MPI_DOUBLE_COMPLEX, MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE CALL MPI_RECV(id%REDRHS(ISCHUR_DEST), & SIZE_SCHUR, MPI_DOUBLE_COMPLEX, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF IF (id%KEEP(50).EQ.0) THEN ISCHUR_UNS = ISCHUR_UNS + int(LD_SCHUR,8) ELSE ISCHUR_SYM = ISCHUR_SYM + int(LD_SCHUR,8) ENDIF ISCHUR_DEST = ISCHUR_DEST + int(id%LREDRHS,8) ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_EXTRACT_SCHUR_REDRHS SUBROUTINE ZMUMPS_EXTRACT_SINGULAR_VALUES(id,idintr) USE ZMUMPS_STRUC_DEF USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_INTR_STRUC IMPLICIT NONE C C Purpose C ======= C C TYPE (ZMUMPS_STRUC) :: id TYPE (ZMUMPS_INTR_STRUC) :: idintr C C Local variables C =============== C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ID_ROOT, ALLOCOK C C External functions C ================== C INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE C Quick return in case factorization did not terminate correctly IF (id%INFO(1) .LT. 0) RETURN C Quick return if Postponing + rank revealing option off IF (id%KEEP(19) .EQ. 0) RETURN C Get Root id ID_ROOT =MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(id%KEEP(20))), & id%KEEP(199)) IF ( id%KEEP( 46 ) .NE. 1 ) THEN ID_ROOT = ID_ROOT + 1 END IF C ================================= C Singular values are stored in C roota%SINGULAR_VALUES C We copy it to id%SINGULAR_VALUES C ================================= IF ((ID_ROOT.EQ.id%MYID).AND.(id%MYID.EQ.MASTER)) THEN C write(6,*) " singular_values already on host" IF (associated(id%SINGULAR_VALUES)) & DEALLOCATE(id%SINGULAR_VALUES) NULLIFY(id%SINGULAR_VALUES) id%NB_SINGULAR_VALUES=idintr%root%NB_SINGULAR_VALUES ALLOCATE(id%SINGULAR_VALUES(id%NB_SINGULAR_VALUES) & , stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN id%INFO(1)=-13 id%INFO(2)= id%NB_SINGULAR_VALUES RETURN END IF CALL dcopy(id%NB_SINGULAR_VALUES, & idintr%roota%SINGULAR_VALUES(1), 1, & id%SINGULAR_VALUES(1), 1) ELSE IF (id%MYID.EQ.ID_ROOT) THEN C Send C write(6,*) " id%MYID sends singular_values " CALL MPI_SEND( & idintr%root%NB_SINGULAR_VALUES, & 1, & MPI_INTEGER, & MASTER, TAG_ROOT1, & id%COMM, IERR ) CALL MPI_SEND( & idintr%roota%SINGULAR_VALUES(1), & idintr%root%NB_SINGULAR_VALUES, & MPI_DOUBLE_PRECISION, & MASTER, TAG_ROOT2, & id%COMM, IERR ) ELSEIF (id%MYID.EQ.MASTER) THEN C Receive CALL MPI_RECV( id%NB_SINGULAR_VALUES, & 1, & MPI_INTEGER, ID_ROOT, TAG_ROOT1, & id%COMM, STATUS, IERR ) IF (associated(id%SINGULAR_VALUES)) & DEALLOCATE(id%SINGULAR_VALUES) NULLIFY(id%SINGULAR_VALUES) ALLOCATE(id%SINGULAR_VALUES(id%NB_SINGULAR_VALUES) & , stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN id%INFO(1)=-13 id%INFO(2)= id%NB_SINGULAR_VALUES RETURN END IF CALL MPI_RECV( id%SINGULAR_VALUES(1), & id%NB_SINGULAR_VALUES, & MPI_DOUBLE_PRECISION, ID_ROOT, TAG_ROOT2, & id%COMM, STATUS, IERR ) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_EXTRACT_SINGULAR_VALUES SUBROUTINE ZMUMPS_SET_NOMP_MAX(KEEP281, KEEP361, & N, NOMP_MAX) !$ USE OMP_LIB C C Purpose C ======= C set NOMP_MAX from KEEP(281) C on output NOMP_MAX >=0 C C Parameters C ========== C INTEGER, INTENT(IN) :: KEEP281, KEEP361, N INTEGER, INTENT(OUT) :: NOMP_MAX C C Local variables C INTEGER :: NOMP C C out-of-range entries treated as -1 NOMP_MAX= max(-1, KEEP281) NOMP = 1 !$ NOMP = omp_get_max_threads() IF (NOMP_MAX.EQ.-1) THEN C automatic setting IF (N.LE.KEEP361) THEN NOMP_MAX = 0 RETURN ENDIF IF (NOMP.GT.1) THEN C conservative because of memory allocation NOMP_MAX = min(NOMP, 10) ELSE C no multithreading and all parallel do suppressed NOMP_MAX = 0 ENDIF ELSE C NOMP_MAX >=0 C use provided value NOMP_MAX = min(NOMP_MAX, NOMP) ENDIF C RETURN END SUBROUTINE ZMUMPS_SET_NOMP_MAX MUMPS_5.8.1/src/zfac_process_contrib_type1.F0000664000175000017500000001172015042446441020664 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_PROCESS_NODE( MYID,KEEP,KEEP8,DKEEP, & BUFR, LBUFR, LBUFR_BYTES, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER MYID INTEGER LBUFR, LBUFR_BYTES INTEGER KEEP(500), BUFR( LBUFR ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP, FPERE LOGICAL FLAG INTEGER NSTK_S( KEEP(28) ), ITLOC( N + KEEP(253) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER IFLAG, IERROR, COMM INTEGER POSITION, FINODE, FLCONT, LREQ INTEGER(8) :: LREQCB INTEGER(8) :: IPOS_NODE, ISHIFT_PACKET INTEGER SIZE_PACKET INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INCLUDE 'mumps_headers.h' LOGICAL PACKED_CB COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYN_SIZE FLAG = .FALSE. POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FLCONT, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, MPI_INTEGER, & COMM, IERR) PACKED_CB = (FLCONT.LT.0) IF (PACKED_CB) THEN FLCONT = -FLCONT LREQCB = (int(FLCONT,8) * int(FLCONT+1,8)) / 2_8 ELSE LREQCB = int(FLCONT,8) * int(FLCONT,8) ENDIF IF (NBROWS_ALREADY_SENT == 0) THEN LREQ = 2 * FLCONT + 6 + KEEP(IXSZ) CALL ZMUMPS_ALLOC_CB( .FALSE., 0_8, .FALSE.,.FALSE., & MYID,N, KEEP,KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & LREQ, LREQCB, FINODE, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PIMASTER(STEP( FINODE )) = IWPOSCB + 1 PAMASTER(STEP( FINODE )) = IPTRLU + 1_8 IF (PACKED_CB) IW(IWPOSCB + 1 + XXS ) = S_CB1COMP CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 1+KEEP(IXSZ)), LREQ-KEEP(IXSZ), & MPI_INTEGER, COMM, IERR) ENDIF IF (PACKED_CB) THEN ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * & int(NBROWS_ALREADY_SENT+1,8) / 2_8 SIZE_PACKET = (NBROWS_PACKET * (NBROWS_PACKET+1))/2 + & NBROWS_ALREADY_SENT * NBROWS_PACKET ELSE ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * int(FLCONT,8) SIZE_PACKET = NBROWS_PACKET * FLCONT ENDIF IF (NBROWS_PACKET.NE.0) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(PIMASTER(STEP(FINODE))+XXD)) IF (DYN_SIZE .GT. 0_8) THEN CALL ZMUMPS_DM_SET_PTR( PAMASTER(STEP(FINODE)), & DYN_SIZE, SON_A ) IPOS_NODE = 1_8 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & SON_A(IPOS_NODE + ISHIFT_PACKET), & SIZE_PACKET, MPI_DOUBLE_COMPLEX, COMM, IERR) ELSE IPOS_NODE = PAMASTER(STEP(FINODE)) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & A(IPOS_NODE + ISHIFT_PACKET), & SIZE_PACKET, MPI_DOUBLE_COMPLEX, COMM, IERR) ENDIF ENDIF IF (NBROWS_ALREADY_SENT+NBROWS_PACKET == FLCONT) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF ( NSTK_S(STEP(FPERE)).EQ.0 ) THEN FLAG = . TRUE. END IF ENDIF RETURN END SUBROUTINE ZMUMPS_PROCESS_NODE MUMPS_5.8.1/src/csol_c.F0000664000175000017500000031673415042446440014617 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SOL_C(root, roota, N, A, LA, IW, LIW, W, LWC, & IWCB, LIWW, NRHS, NA, LNA, NE_STEPS, W2, MTYPE, ICNTL, FROM_PP, & STEP, FRERE, DAD, FILS, PTRIST, PTRFAC, IW1, LIW1, PTRACB, & LIWK_PTRACB, PROCNODE_STEPS, SLAVEF, INFO, KEEP,KEEP8, DKEEP, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IBEG_ROOT_DEF, IEND_ROOT_DEF, & IROOT_DEF_RHS_COL1, RHS_ROOT, LRHS_ROOT, SIZE_ROOT, MASTER_ROOT, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, POSINRHSINTR_BWD, & Lnodes_FWD, Lnodes_BWD, & nodes_FWD, nodes_BWD, & NZ_RHS, NBCOL_INBLOC, JBEG_RHS, Step2node, LStep2node, & IRHS_SPARSE, IRHS_PTR, SIZE_PERM_RHS, PERM_RHS, & SIZE_UNS_PERM_INV, UNS_PERM_INV, NB_FS_IN_RHSINTR_F, & NB_FS_IN_RHSINTR_TOT, DO_NBSPARSE , RHS_BOUNDS, LRHS_BOUNDS #if defined(STAT_ES_SOLVE) & , IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING #endif & ,IPOOL_B_L0_OMP, LPOOL_B_L0_OMP, IPOOL_A_L0_OMP, LPOOL_A_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) USE CMUMPS_OOC USE CMUMPS_SOL_ES USE CMUMPS_SOL_L0OMP_M, ONLY : CMUMPS_SOL_L0OMP_R, & CMUMPS_SOL_L0OMP_S USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC & , CMUMPS_L0OMPFAC_T IMPLICIT NONE #if defined(V_T) INCLUDE 'VT.inc' #endif TYPE ( MUMPS_ROOT_STRUC ) :: root TYPE ( CMUMPS_ROOT_STRUC ) :: roota INTEGER(8) :: LA INTEGER(8) :: LWC INTEGER :: N,LIW,MTYPE,LIW1,LIWW,LNA INTEGER ICNTL(60),INFO(80), KEEP(500) REAL, intent(inout) :: DKEEP(230) INTEGER(8) KEEP8(150) INTEGER IW(LIW),IW1(LIW1),NA(LNA),NE_STEPS(KEEP(28)),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)), FILS(N), PTRIST(KEEP(28)), & DAD(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER :: LIWK_PTRACB INTEGER(8) :: PTRACB(LIWK_PTRACB) INTEGER NRHS, LRHSINTR, NB_FS_IN_RHSINTR_F, NB_FS_IN_RHSINTR_TOT COMPLEX A(LA), W(LWC), & W2(KEEP(133)) COMPLEX :: RHSINTR(LRHSINTR,NRHS) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER PROCNODE_STEPS(KEEP(28)), POSINRHSINTR_FWD(N), & POSINRHSINTR_BWD(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, IROOT_DEF_RHS_COL1 INTEGER NRHS_LOC INTEGER SIZE_ROOT, MASTER_ROOT INTEGER(8) :: LRHS_ROOT COMPLEX RHS_ROOT(LRHS_ROOT) LOGICAL, intent(in) :: FROM_PP INTEGER, intent(in) :: Lnodes_FWD, Lnodes_BWD INTEGER, intent(in) :: nodes_FWD(max(1,Lnodes_FWD)), & nodes_BWD(max(1,Lnodes_BWD)) INTEGER, intent(in) :: NZ_RHS, NBCOL_INBLOC INTEGER, intent(in) :: SIZE_UNS_PERM_INV INTEGER, intent(in) :: SIZE_PERM_RHS INTEGER, intent(in) :: JBEG_RHS INTEGER, intent(in) :: IRHS_SPARSE(NZ_RHS) INTEGER, intent(in) :: IRHS_PTR(NBCOL_INBLOC+1) INTEGER, intent(in) :: PERM_RHS(SIZE_PERM_RHS) INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, intent(in) :: LStep2node INTEGER, intent(in) :: Step2node(LStep2node) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(inout) :: RHS_BOUNDS (LRHS_BOUNDS) #if defined(STAT_ES_SOLVE) INTEGER, INTENT(IN) :: SIZE_WORKING, SIZE_IPTR_WORKING, & IPTR_WORKING(SIZE_IPTR_WORKING), & WORKING(SIZE_WORKING) #endif INTEGER, INTENT (IN) :: LPOOL_B_L0_OMP INTEGER, INTENT (IN) :: IPOOL_B_L0_OMP( LPOOL_B_L0_OMP ) INTEGER, INTENT (IN) :: LPOOL_A_L0_OMP INTEGER, INTENT (IN) :: IPOOL_A_L0_OMP( LPOOL_A_L0_OMP ) INTEGER, INTENT (IN) :: L_PHYS_L0_OMP INTEGER, INTENT (INOUT) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT (IN) :: L_VIRT_L0_OMP INTEGER, INTENT (IN) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT (IN) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT (IN) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT (IN) :: LL0_OMP_MAPPING INTEGER, INTENT (IN) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INTEGER, INTENT (IN) :: LL0_OMP_FACTORS TYPE (CMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER MP, LP, LDIAG INTEGER K,I,II INTEGER allocok INTEGER LPOOL,MYLEAF,MYROOT,NBROOT,LPANEL_POS INTEGER MYLEAF_NOT_PRUNED INTEGER NSTK_S,IPOOL,IPANEL_POS,PTRICB INTEGER MTYPE_LOC INTEGER MODE_RHS_BOUNDS INTEGER IPT_RHS_ROOT_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 LOGICAL DOFORWARD, DOROOT, DOBACKWARD LOGICAL :: DO_L0OMP_FWD, DO_L0OMP_BWD LOGICAL I_WORKED_ON_ROOT, SPECIAL_ROOT_REACHED INTEGER IROOT LOGICAL DOROOT_FWD_OOC, DOROOT_BWD_PANEL LOGICAL DUMMY_BOOL INTEGER :: IDUMMY INTEGER :: NBROOT_UNDER_L0 COMPLEX, PARAMETER :: ZERO = (0.0E0,0.0E0) INCLUDE 'mumps_headers.h' INTEGER, DIMENSION(:), POINTER :: nodes_BWD_PTR INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: Pruned_Roots_FWD INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: Pruned_Roots_NS INTEGER :: Lnodes_BWD_PTR, LPruned_Roots_NS INTEGER :: Lnodes_BWD_ROOTS INTEGER nb_prun_leaves INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_Leaves INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_List INTEGER nb_prun_nodes INTEGER INODE_PRINC, nb_prun_roots INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_SONS, Pruned_Roots INTEGER :: SIZE_TO_PROCESS LOGICAL, DIMENSION(:), ALLOCATABLE :: TO_PROCESS INTEGER ISTEP INTEGER :: INODE, ICHILD LOGICAL AM1, DO_PRUN_FWD, DO_PRUN_BWD LOGICAL Exploit_Sparsity_FWD, Exploit_Sparsity_BWD LOGICAL DO_NBSPARSE_BWD, PRUN_BELOW_BWD INTEGER :: OOC_FCT_TYPE_TMP INTEGER :: MUMPS_OOC_GET_FCT_TYPE EXTERNAL :: MUMPS_OOC_GET_FCT_TYPE DOUBLE PRECISION TIME_FWD,TIME_BWD,TIME_SpecialRoot INTEGER :: nb_sparse INTEGER, EXTERNAL :: MUMPS_PROCNODE LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR MYLEAF = -1 LP = ICNTL(1) MP = ICNTL(2) LDIAG = ICNTL(4) CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, MYID ) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 #if defined(V_T) CALL VTCLASSDEF( 'Soln_c',soln_c_class,ierr) CALL VTFUNCDEF( 'forw_soln',soln_c_class,forw_soln,ierr) CALL VTFUNCDEF( 'back_soln',soln_c_class,back_soln,ierr) CALL VTFUNCDEF( 'root_soln',soln_c_class,root_soln,ierr) #endif IF (.NOT. FROM_PP) THEN CALL MUMPS_SECDEB(TIME_FWD) ENDIF NSTK_S = 1 PTRICB = NSTK_S + KEEP(28) IPOOL = PTRICB + KEEP(28) LPOOL = NA(1) + 1 IPANEL_POS = IPOOL + LPOOL IF (KEEP(201).EQ.1) THEN LPANEL_POS = KEEP(228)+1 ELSE LPANEL_POS = 1 ENDIF IF (IPANEL_POS + LPANEL_POS -1 .ne. LIW1 ) THEN WRITE(*,*) MYID, ": Internal Error 1 in CMUMPS_SOL_C", & IPANEL_POS, LPANEL_POS, LIW1 CALL MUMPS_ABORT() ENDIF KEEP(405)=0 DOFORWARD = .TRUE. DOBACKWARD= .TRUE. SPECIAL_ROOT_REACHED = .TRUE. 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_FWD = (KEEP(235) .NE. 0) .AND. (.NOT. AM1) Exploit_Sparsity_BWD = (KEEP(212) .NE. 0) .AND. (.NOT. AM1) Lnodes_BWD_ROOTS = NA(2) DO_PRUN_FWD = (Exploit_Sparsity_FWD.OR.AM1) DO_PRUN_BWD = (Exploit_Sparsity_BWD.OR.AM1) IF (FROM_PP) THEN Exploit_Sparsity_FWD = .FALSE. DO_PRUN_FWD = .FALSE. Exploit_Sparsity_BWD = .FALSE. DO_PRUN_BWD = .FALSE. IF ( AM1 ) THEN WRITE(*,*) "Internal error 2 in CMUMPS_SOL_C" CALL MUMPS_ABORT() ENDIF ENDIF DO_L0OMP_FWD= ( (KEEP(401).EQ.1).AND.(KEEP(400).GT.0) & .AND.DOFORWARD ) DO_L0OMP_FWD = DO_L0OMP_FWD .AND. KEEP(201).EQ.0 DO_L0OMP_BWD = ( (KEEP(401).EQ.1).AND.(KEEP(400).GT.0) & .AND.DOBACKWARD ) DO_L0OMP_BWD = DO_L0OMP_BWD .AND. KEEP(201).EQ.0 IF ( DO_PRUN_FWD.OR.DO_PRUN_BWD ) THEN ALLOCATE (Pruned_SONS(KEEP(28)), stat=I) IF(I.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ENDIF IF ( DO_PRUN_FWD.OR.DO_PRUN_BWD & .OR. DO_L0OMP_BWD & ) THEN SIZE_TO_PROCESS = KEEP(28) ELSE SIZE_TO_PROCESS = 1 ENDIF ALLOCATE (TO_PROCESS(SIZE_TO_PROCESS), stat=I) IF(I.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 IF ( DOFORWARD .AND. DO_PRUN_FWD ) THEN CALL CMUMPS_CHAIN_PRUN_NODES( & .FALSE., & DAD, KEEP(28), & STEP, N, & nodes_FWD, Lnodes_FWD, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, & nb_prun_leaves ) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL CMUMPS_CHAIN_PRUN_NODES( & .TRUE., & DAD, KEEP(28), & STEP, N, & nodes_FWD, Lnodes_FWD, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves ) CALL CMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF ( KEEP(201) .GT. 0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('F',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL CMUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), & KEEP8(31)+KEEP8(64), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP #if defined(STAT_ES_SOLVE) & , NRHS, COMM_NODES, IW, LIW, PTRIST,KEEP(IXSZ),0, & KEEP(50), KEEP(38) #endif & ) IF (DO_NBSPARSE) THEN nb_sparse = max(1,KEEP(497)) MODE_RHS_BOUNDS = 0 IF (Exploit_Sparsity_FWD) MODE_RHS_BOUNDS = 2 CALL CMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243), & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23), & RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & MODE_RHS_BOUNDS) CALL CMUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, KEEP(485), #if defined(STAT_ES_SOLVE) & KEEP(46), & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, #endif & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,0, & KEEP(50), KEEP(38)) END IF SPECIAL_ROOT_REACHED = .FALSE. DO I= 1, nb_prun_roots IF ( (Pruned_Roots(I).EQ.KEEP(38)).OR. & (Pruned_Roots(I).EQ.KEEP(20)) ) THEN SPECIAL_ROOT_REACHED = .TRUE. EXIT ENDIF ENDDO DEALLOCATE(Pruned_List) ENDIF IF (KEEP(201).GT.0) THEN IF (DOFORWARD .OR. DOROOT_FWD_OOC) THEN CALL CMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,KEEP(28),MTYPE, & A,LA,DOFORWARD,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (DOFORWARD) THEN IF ( KEEP( 50 ) .eq. 0 ) THEN MTYPE_LOC = MTYPE ELSE MTYPE_LOC = 1 ENDIF #if defined(V_T) CALL VTBEGIN(forw_soln,ierr) #endif IF ( .NOT. DO_PRUN_FWD ) THEN CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, MYROOT, MYID_NODES, & SLAVEF, NA, LNA, KEEP, STEP, PROCNODE_STEPS) DO ISTEP =1, KEEP(28) IW1(NSTK_S+ISTEP-1) = NE_STEPS(ISTEP) ENDDO ELSE CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & nb_prun_roots, Pruned_Roots, & MYROOT, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) IF ((Exploit_Sparsity_FWD).AND.(nb_prun_roots.NE.NA(2))) THEN Lnodes_BWD_ROOTS = nb_prun_roots ALLOCATE(Pruned_Roots_FWD(Lnodes_BWD_ROOTS), STAT=allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of nodes_FWD' INFO(1) = -13 INFO(2) = Lnodes_BWD_ROOTS CALL MUMPS_ABORT() END IF Pruned_Roots_FWD(1:Lnodes_BWD_ROOTS)= & Pruned_Roots(1:Lnodes_BWD_ROOTS) DEALLOCATE(Pruned_Roots) ELSE DEALLOCATE(Pruned_Roots) ENDIF DO ISTEP = 1, KEEP(28) IW1(NSTK_S+ISTEP-1) = Pruned_SONS(ISTEP) ENDDO ENDIF IF ( DO_L0OMP_FWD ) THEN KEEP(405)=1 CALL CMUMPS_SOL_L0OMP_R( N, MTYPE_LOC, NRHS, LIW, IW, & IW1(PTRICB), RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & STEP, FRERE, DAD, FILS, IW1(NSTK_S), & PTRIST, PTRFAC, INFO, & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, & FROM_PP, & NBROOT_UNDER_L0, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, & L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS, & DO_PRUN_FWD, TO_PROCESS & ) CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, & INFO, MYID ) IF (INFO(1).LT.0) THEN CALL CMUMPS_BDC_ERROR(MYID_NODES, SLAVEF, COMM_NODES, KEEP) ENDIF KEEP(405)=0 MYROOT = MYROOT - NBROOT_UNDER_L0 ENDIF IF ( DO_L0OMP_FWD ) THEN IF ( DO_PRUN_FWD ) THEN MYLEAF_NOT_PRUNED = IPOOL_A_L0_OMP(LPOOL_A_L0_OMP) DO I=1, MYLEAF_NOT_PRUNED IF ( TO_PROCESS( STEP( IPOOL_A_L0_OMP(I) ))) THEN IW1(IPOOL+MYLEAF-1) = IPOOL_A_L0_OMP(I) IW1(NSTK_S+STEP(IPOOL_A_L0_OMP(I))-1) = -99 ENDIF ENDDO DO I = 1, nb_prun_leaves INODE = Pruned_Leaves(I) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) & .EQ. MYID_NODES ) THEN IF (L0_OMP_MAPPING( STEP(INODE) ) .EQ. 0) THEN IW1(NSTK_S+STEP(INODE)-1) = -99 ENDIF ENDIF ENDDO DO I = 1, L_PHYS_L0_OMP INODE = DAD(STEP(PHYS_L0_OMP(I))) IF (INODE .NE. 0) THEN IF ( TO_PROCESS( STEP( INODE ))) THEN IF ( IW1(NSTK_S+STEP(INODE)-1) .EQ. 0 ) THEN IW1(NSTK_S+STEP(INODE)-1) = -99 ENDIF ENDIF ENDIF ENDDO MYLEAF = 0 DO ISTEP = KEEP(28), 1, -1 INODE=Step2Node(ISTEP) IF (IW1(NSTK_S+STEP(INODE)-1).EQ.-99) THEN MYLEAF = MYLEAF + 1 IW1(IPOOL+MYLEAF-1) = INODE IW1(NSTK_S+STEP(INODE)-1) = 0 ENDIF ENDDO DEALLOCATE(Pruned_Leaves) ELSE MYLEAF = IPOOL_A_L0_OMP(LPOOL_A_L0_OMP) DO I=1, MYLEAF IW1(IPOOL+I-1) = IPOOL_A_L0_OMP(I) ENDDO ENDIF ELSE IF ( DO_PRUN_FWD ) THEN CALL MUMPS_INIT_POOL_DIST_NONA( N, MYLEAF, MYID_NODES, & nb_prun_leaves, Pruned_Leaves, KEEP, KEEP8, & STEP, PROCNODE_STEPS, IW1(IPOOL), LPOOL ) MYLEAF = MYLEAF - 1 DEALLOCATE(Pruned_Leaves) ELSE CALL MUMPS_INIT_POOL_DIST( N, MYLEAF, MYID_NODES, & SLAVEF, NA, LNA, KEEP, KEEP8, STEP, & PROCNODE_STEPS, IW1(IPOOL), LPOOL ) MYLEAF = MYLEAF - 1 ENDIF ENDIF CALL CMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1), & LWC, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSINTR,LRHSINTR,POSINRHSINTR_FWD, & STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF, MYROOT, INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE_LOC, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) IF (DO_PRUN_FWD) THEN MYLEAF = -1 ENDIF #if defined(V_T) CALL VTEND(forw_soln,ierr) #endif ENDIF CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, MYID ) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) THEN IF ( LP .GT. 0 ) THEN WRITE(LP,*) MYID, & ': ** ERROR RETURN FROM CMUMPS_SOL_R,INFO(1:2)=', & INFO(1:2) END IF GOTO 500 END IF CALL MPI_BARRIER( COMM_NODES, IERR ) IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_FWD) DKEEP(117)=real(TIME_FWD) + DKEEP(117) ENDIF IF ( .NOT.( & DOBACKWARD.AND. & (DO_PRUN_BWD.OR.(Lnodes_BWD_ROOTS.NE.NA(2))) & ) & ) THEN IF (.NOT. DO_L0OMP_BWD ) THEN IF ( allocated(TO_PROCESS) .AND. SIZE_TO_PROCESS.NE.1 ) THEN DEALLOCATE (TO_PROCESS) SIZE_TO_PROCESS = 1 ALLOCATE(TO_PROCESS(SIZE_TO_PROCESS),stat=I) ENDIF ENDIF ENDIF IF ( (KEEP(111).NE.0).AND.DOBACKWARD.AND. & ( & DO_PRUN_BWD & ) & ) THEN nb_prun_leaves = 0 IF ( Lnodes_BWD_ROOTS.NE.NA(2) ) THEN nodes_BWD_PTR => Pruned_Roots_FWD Lnodes_BWD_PTR = Lnodes_BWD_ROOTS ELSE IF ( (Exploit_Sparsity_BWD.AND.KEEP(111).NE.0) & ) THEN LPruned_Roots_NS = 0 Pruned_SONS(:) = -1 DO II = 1, NZ_RHS I = IRHS_SPARSE(II) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) ISTEP = abs(STEP(I)) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN LPruned_Roots_NS = LPruned_Roots_NS +1 Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ALLOCATE(Pruned_Roots_NS(LPruned_Roots_NS), STAT = allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of nodes_BWD' INFO(1) = -13 INFO(2) = LPruned_Roots_NS CALL MUMPS_ABORT() END IF LPruned_Roots_NS = 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 LPruned_Roots_NS = LPruned_Roots_NS +1 Pruned_Roots_NS(LPruned_Roots_NS) = INODE_PRINC Pruned_SONS(ISTEP) = 0 ENDIF ENDDO nodes_BWD_PTR => Pruned_Roots_NS Lnodes_BWD_PTR = LPruned_Roots_NS ENDIF IF ( & (Exploit_Sparsity_BWD.AND.KEEP(111).NE.0) .OR. & (Lnodes_BWD_ROOTS.NE.NA(2)) & ) THEN CALL CMUMPS_TREE_PRUN_NODES( & .FALSE., & DAD, NE_STEPS, FRERE, KEEP(28), & FILS, STEP, N, & nodes_BWD_PTR, Lnodes_BWD_PTR, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves & ) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL CMUMPS_TREE_PRUN_NODES( & .TRUE., & DAD, NE_STEPS, FRERE, KEEP(28), & FILS, STEP, N, & nodes_BWD_PTR, Lnodes_BWD_PTR, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IF(allocated(Pruned_Roots_NS)) DEALLOCATE(Pruned_Roots_NS) IF(allocated(Pruned_Roots_FWD)) DEALLOCATE(Pruned_Roots_FWD) CALL CMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF ENDIF ENDIF IF(KEEP(201).EQ.1.AND.DOROOT_BWD_PANEL) THEN I_WORKED_ON_ROOT = .FALSE. CALL CMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE, & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) IF (IERR .LT. 0) THEN INFO(1) = -90 INFO(2) = IERR ENDIF ENDIF IF (KEEP(201).EQ.1) THEN CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF IF (KEEP(60).NE.0 .AND. KEEP(221).EQ.0 & .AND. MYID_NODES .EQ. MASTER_ROOT) THEN RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO ENDIF IF (.NOT. FROM_PP) THEN CALL MUMPS_SECDEB(TIME_SpecialRoot) ENDIF IF ( ( KEEP( 38 ) .NE. 0 ).AND. SPECIAL_ROOT_REACHED ) THEN IF ( KEEP(60) .EQ. 0 .AND. KEEP(252) .EQ. 0 ) THEN IF ( root%yes ) THEN IF (KEEP(201).GT.0) THEN IF ( (Exploit_Sparsity_FWD.AND.(KEEP(111).NE.0)) .and. & (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) ) THEN GOTO 1010 ENDIF ENDIF IOLDPS = PTRIST(STEP(KEEP(38))) LOCAL_M = IW( IOLDPS + 2 + KEEP(IXSZ)) LOCAL_N = IW( IOLDPS + 1 + KEEP(IXSZ)) IF (KEEP(201).GT.0) THEN CALL CMUMPS_SOLVE_GET_OOC_NODE( & KEEP(38),PTRFAC,KEEP,A,LA, & STEP,KEEP8,N,DUMMY_BOOL,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) '** ERROR after CMUMPS_SOLVE_GET_OOC_NODE', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF IAPOS = PTRFAC(IW( IOLDPS + 4 + KEEP(IXSZ))) IF (LOCAL_M * LOCAL_N .EQ. 0) THEN IAPOS = min(IAPOS, LA) ENDIF #if defined(V_T) CALL VTBEGIN(root_soln,ierr) #endif CALL CMUMPS_ROOT_SOLVE( NRHS, root%DESCRIPTOR(1), & root%CNTXT_BLACS, LOCAL_M, LOCAL_N, & root%MBLOCK, root%NBLOCK, & root%IPIV(1), root%LPIV, MASTER_ROOT, MYID_NODES, & COMM_NODES, & RHS_ROOT(1), & root%TOT_ROOT_SIZE, A( IAPOS ), & INFO(1), MTYPE, KEEP(50), FROM_PP) IF(KEEP(201).GT.0)THEN CALL CMUMPS_FREE_FACTORS_FOR_SOLVE(KEEP(38), & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) & '** ERROR after CMUMPS_FREE_FACTORS_FOR_SOLVE ', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF ENDIF ENDIF ELSE IF ( ( KEEP(20) .NE. 0) .AND. SPECIAL_ROOT_REACHED ) THEN IF ( MYID_NODES .eq. MASTER_ROOT ) THEN IF ( KEEP(60) .eq. 0 ) THEN IF (KEEP(201).GT.0) THEN CALL CMUMPS_SOLVE_GET_OOC_NODE( & KEEP(20),PTRFAC,KEEP,A,LA, & STEP,KEEP8,N,DUMMY_BOOL,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) '** ERROR after CMUMPS_SOLVE_GET_OOC_NODE', & INFO(1) call MUMPS_ABORT() ENDIF END IF NRHS_LOC = NRHS IPT_RHS_ROOT_LOC = 1 IF ( KEEP(111).NE.0 ) THEN RHS_ROOT( 1: NRHS*SIZE_ROOT) = ZERO NRHS_LOC = IEND_ROOT_DEF - IBEG_ROOT_DEF + 1 IPT_RHS_ROOT_LOC = IPT_RHS_ROOT_LOC + & (IROOT_DEF_RHS_COL1-1)*SIZE_ROOT ENDIF IF (NRHS_LOC .GT. 0) THEN CALL CMUMPS_SEQ_SOLVE_ROOT_SVD_QR(NRHS_LOC, & SIZE_ROOT,A( PTRFAC( & IW( PTRIST(STEP(KEEP(20)))+4+KEEP(IXSZ)))), & root, roota, IBEG_ROOT_DEF, IEND_ROOT_DEF, & RHS_ROOT( IPT_RHS_ROOT_LOC ), & KEEP,KEEP8, & MTYPE,INFO,LWC,W(1), LP) ENDIF IF(KEEP(201).GT.0)THEN CALL CMUMPS_FREE_FACTORS_FOR_SOLVE(KEEP(20), & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) & '** ERROR after CMUMPS_FREE_FACTORS_FOR_SOLVE ', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF ENDIF END IF END IF IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_SpecialRoot) DKEEP(119)=real(TIME_SpecialRoot) + DKEEP(119) ENDIF #if defined(V_T) CALL VTEND(root_soln,ierr) #endif 1010 CONTINUE CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) RETURN IF (DOBACKWARD) THEN IF ( KEEP(201).GT.0 .AND. .NOT. DOROOT_BWD_PANEL ) & THEN I_WORKED_ON_ROOT = DOROOT IF (KEEP(38).gt.0 ) THEN IF ( ( Exploit_Sparsity_FWD.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_FWD.AND.(KEEP(111).NE.0)) THEN IF (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) THEN I_WORKED_ON_ROOT = .FALSE. ENDIF ENDIF ENDIF ENDIF IF (.NOT.AM1) THEN DO_NBSPARSE_BWD = .FALSE. ELSE DO_NBSPARSE_BWD = DO_NBSPARSE ENDIF PRUN_BELOW_BWD = DO_PRUN_BWD .AND. KEEP(111).EQ.0 PRUN_BELOW_BWD = PRUN_BELOW_BWD .OR. DO_L0OMP_BWD IF ( DO_PRUN_BWD ) THEN CALL CMUMPS_CHAIN_PRUN_NODES( & .FALSE., & DAD, KEEP(28), & STEP, N, & nodes_BWD, Lnodes_BWD, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, & nb_prun_leaves) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL CMUMPS_CHAIN_PRUN_NODES( & .TRUE., & DAD, KEEP(28), & STEP, N, & nodes_BWD, Lnodes_BWD, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves ) CALL CMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL CMUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP #if defined(STAT_ES_SOLVE) & , NRHS, COMM_NODES, IW, LIW, PTRIST,KEEP(IXSZ),1, & KEEP(50), KEEP(38) #endif & ) IF (DO_NBSPARSE_BWD) THEN nb_sparse = max(1,KEEP(497)) CALL CMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243), & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23), & RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & 1) CALL CMUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, KEEP(485), #if defined(STAT_ES_SOLVE) & KEEP(46), & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, #endif & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,1, & KEEP(50), KEEP(38)) END IF ENDIF IF ( KEEP(201).GT.0 ) THEN IROOT = max(KEEP(20),KEEP(38)) CALL CMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE, & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) ENDIF IF ( KEEP( 50 ) .eq. 0 ) THEN MTYPE_LOC = MTYPE ELSE MTYPE_LOC = 0 ENDIF #if defined(V_T) CALL VTBEGIN(back_soln,ierr) #endif IF (.NOT.FROM_PP) THEN CALL MUMPS_SECDEB(TIME_BWD) ENDIF IF ( .NOT.SPECIAL_ROOT_REACHED ) THEN RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO ENDIF IF (AM1.AND.(NB_FS_IN_RHSINTR_F.NE.NB_FS_IN_RHSINTR_TOT)) THEN DO I =1, N II = POSINRHSINTR_BWD(I) IF ((II.GT.0).AND.(II.GT.NB_FS_IN_RHSINTR_F)) THEN DO K=1,NRHS RHSINTR(II, K) = ZERO ENDDO ENDIF ENDDO ENDIF IF ( .NOT. DO_PRUN_BWD ) THEN IF ( .NOT. DO_L0OMP_BWD ) THEN IF (DO_L0OMP_FWD) THEN MYLEAF = -1 ENDIF ENDIF IF ( DO_L0OMP_BWD ) THEN TO_PROCESS(:) = .TRUE. DO I=1, L_PHYS_L0_OMP TO_PROCESS( STEP(PHYS_L0_OMP( I ))) & = .FALSE. ENDDO IF (MYLEAF .EQ. -1) THEN MYLEAF = IPOOL_A_L0_OMP(LPOOL_A_L0_OMP) ENDIF CALL MUMPS_INIT_POOL_DIST_NA_BWD_L0( N, MYROOT, MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL, L0_OMP_MAPPING ) ELSE CALL MUMPS_INIT_POOL_DIST_NA_BWD( N, MYROOT, MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL ) IF (MYLEAF .EQ. -1) THEN CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & NA(1), & NA(3), & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) ENDIF ENDIF ELSE IF ( DO_L0OMP_BWD ) THEN DO I=1, L_PHYS_L0_OMP IF ( TO_PROCESS( STEP(PHYS_L0_OMP( I ))) ) THEN TO_PROCESS( STEP(PHYS_L0_OMP( I ))) = .FALSE. PHYS_L0_OMP( I ) = -PHYS_L0_OMP( I ) ENDIF ENDDO MYLEAF=0 DO ISTEP = 1, KEEP(28) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199)) & .NE. MYID_NODES ) THEN CYCLE ENDIF IF ( L0_OMP_MAPPING( ISTEP ) .NE. 0 ) THEN CYCLE ENDIF IF ( .NOT. TO_PROCESS( ISTEP ) ) THEN CYCLE ENDIF I = Step2Node( ISTEP ) ICHILD = FILS ( I ) DO WHILE ( ICHILD .GT. 0 ) ICHILD = FILS( ICHILD ) END DO IF ( ICHILD .LT. 0 ) THEN ICHILD = -ICHILD DO WHILE ( ICHILD .GT. 0 ) IF ( L0_OMP_MAPPING( STEP( ICHILD ) ) .EQ. 0 .AND. & TO_PROCESS(STEP( ICHILD )) ) THEN GOTO 10 ENDIF ICHILD = FRERE( STEP( ICHILD ) ) ENDDO ENDIF MYLEAF = MYLEAF + 1 10 CONTINUE ENDDO CALL MUMPS_INIT_POOL_DIST_NA_BWDL0ES( N, MYROOT, & MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL, L0_OMP_MAPPING, TO_PROCESS ) ELSE CALL MUMPS_INIT_POOL_DIST_BWD(N, nb_prun_roots, & Pruned_Roots, & MYROOT, MYID_NODES, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL) CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & nb_prun_leaves, Pruned_Leaves, & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) ENDIF ENDIF IF ( DO_L0OMP_BWD & ) THEN KEEP(31) = 1 ELSE KEEP(31) = 0 ENDIF IF (KEEP(31) .EQ. 1) THEN DO I = 1, KEEP(28) IF (MUMPS_PROCNODE(PROCNODE_STEPS(I),KEEP(199)) .EQ. & MYID_NODES) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(I), & KEEP(199)) ) THEN IF ( L0_OMP_MAPPING(I) .EQ. 0 ) THEN IF ( DO_PRUN_BWD & .OR. DO_L0OMP_BWD & ) THEN IF ( TO_PROCESS(I) ) THEN KEEP(31) = KEEP(31) + 1 ENDIF ELSE KEEP(31) = KEEP(31) + 1 ENDIF ENDIF ENDIF ENDIF ENDDO ENDIF CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, MYID ) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL CMUMPS_SOL_S( N, A, LA, IW, LIW, W(1), LWC, & NRHS, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & IW1(PTRICB),PTRACB,IWCB,LIWW, W2, & NE_STEPS, & STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,MYROOT,ICNTL,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP, KEEP8, DKEEP, & RHS_ROOT, LRHS_ROOT, & MTYPE_LOC, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), & LPANEL_POS, PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE_BWD & , FROM_PP & , L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) IF ( DO_L0OMP_BWD .AND. DO_PRUN_BWD ) THEN DO I = 1, L_PHYS_L0_OMP IF ( PHYS_L0_OMP( I ) .LT. 0 ) THEN PHYS_L0_OMP( I ) = -PHYS_L0_OMP( I ) TO_PROCESS(STEP(PHYS_L0_OMP( I ) )) = .TRUE. ENDIF ENDDO ENDIF CALL MUMPS_STOP_ON_USER_REQUEST(KEEP, KEEP8, ICNTL, INFO, MYID) IF (DO_L0OMP_BWD .AND. INFO(1) .GE. 0) THEN KEEP(31) = 0 PRUN_BELOW_BWD = DO_PRUN_BWD .AND. KEEP(111).EQ.0 KEEP(405)=1 CALL CMUMPS_SOL_L0OMP_S(N, MTYPE_LOC, NRHS, LIW, IW, & IW1(PTRICB), PTRACB, RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & STEP, FRERE, FILS, NE_STEPS, PTRIST, PTRFAC, INFO, & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & IW1(IPANEL_POS), LPANEL_POS, & PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE_BWD, & FROM_PP, & LPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, & L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS ) KEEP(405)=0 ENDIF CALL MUMPS_CLEAN_PENDING( INFO(1), KEEP, & BUFR, LBUFR,LBUFR_BYTES, & COMM_NODES, IDUMMY, & SLAVEF, .TRUE., .FALSE. ) CALL MUMPS_STOP_ON_USER_REQUEST(KEEP, KEEP8, ICNTL, INFO, MYID) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) #if defined(V_T) CALL VTEND(back_soln,ierr) #endif IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_BWD) DKEEP(118)=real(TIME_BWD)+DKEEP(118) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (DOFORWARD) THEN K = min(10,size(RHSINTR,1)) IF (LDIAG.EQ.4) K = size(RHSINTR,1) IF ( .NOT. FROM_PP) THEN WRITE (MP,99992) IF (size(RHSINTR,1).GT.0) & WRITE (MP,99993) (RHSINTR(I,1),I=1,K) IF (size(RHSINTR,1).GT.0.and.NRHS>1) & WRITE (MP,99994) (RHSINTR(I,2),I=1,K) ENDIF ENDIF ENDIF 500 CONTINUE IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) IF (DO_PRUN_FWD.OR.DO_PRUN_BWD) THEN IF ( allocated(Pruned_Roots_FWD)) & DEALLOCATE (Pruned_Roots_FWD) IF ( allocated(Pruned_Roots_NS)) & DEALLOCATE (Pruned_Roots_NS) IF ( allocated(Pruned_SONS)) DEALLOCATE (Pruned_SONS) IF ( allocated(Pruned_Roots)) DEALLOCATE (Pruned_Roots) IF ( allocated(Pruned_List)) DEALLOCATE (Pruned_List) IF ( allocated(Pruned_Leaves)) DEALLOCATE (Pruned_Leaves) ENDIF RETURN 99993 FORMAT (' RHS (internal, first column)'/(1X,1P,5E14.6)) 99994 FORMAT (' RHS (internal, 2 nd column)'/(1X,1P,5E14.6)) 99992 FORMAT (//' LEAVING SOLVE (CMUMPS_SOL_C) WITH') END SUBROUTINE CMUMPS_SOL_C SUBROUTINE CMUMPS_SET_POSTPros (KEEP, ICNTL, NBRHS, MPG, PROKG, & ICNTL10, ICNTL11, POSTPros) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP(500), ICNTL(60), NBRHS, MPG LOGICAL, INTENT(IN) :: PROKG INTEGER, INTENT(OUT) :: ICNTL10, ICNTL11 LOGICAL, INTENT(OUT) :: POSTPros POSTPros = .FALSE. IF (ICNTL11.NE.0 .OR. ICNTL10.NE.0) THEN POSTPros = .TRUE. IF (KEEP(111).NE.0) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: null space basis', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(237) .NE.0 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: AM1', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(252) .NE.0 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: Fwd in facto ', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF (KEEP(221).NE.0) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: reduced RHS', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF (NBRHS.GT. 1 .OR. ICNTL(21) .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: nrhs>1 or distrib sol', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(248) .EQ. -1 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: distrib rhs', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ENDIF IF (.NOT.POSTPros) THEN ICNTL11 = 0 ICNTL10 = 0 ENDIF ENDIF IF ((ICNTL(10) .NE. 0) .AND. (ICNTL10 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 ' ENDIF IF ((ICNTL(11) .NE. 0) & .AND.(ICNTL11 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF RETURN END SUBROUTINE CMUMPS_SET_POSTPros SUBROUTINE CMUMPS_GATHER_SOLUTION( NSLAVES, N, MYID, COMM, & NRHS, & MTYPE, RHS, LRHS, NCOL_RHS, JBEG_RHS, PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, CWORK, LCWORK, #if defined(USE_OLD_SCALING) & LSCAL, SCALING, LSCALING, #else & LSCAL, SCALING_LOC_BWD, LSCALING_LOC_BWD, #endif & RHSINTR, LRHSINTR, NCOL_RHSINTR, & POSINRHSINTR, LPOS_N, PERM_RHS, SIZE_PERM_RHS ) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE, NCOL_RHS INTEGER NRHS, LRHS, LCWORK, LPOS_N, NCOL_RHSINTR COMPLEX RHS (LRHS, NCOL_RHS) INTEGER, INTENT(in) :: JBEG_RHS INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX :: CWORK(LCWORK) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER SIZE_BUF, SIZE_BUF_BYTES INTEGER BUFFER(SIZE_BUF) INTEGER LRHSINTR, POSINRHSINTR(LPOS_N) #if defined(USE_OLD_SCALING) COMPLEX, intent(in) :: RHSINTR(LRHSINTR, NCOL_RHSINTR) INTEGER, intent(in) :: LSCALING REAL, intent(in) :: SCALING(LSCALING) #else COMPLEX, intent(inout) :: RHSINTR(LRHSINTR, NCOL_RHSINTR) INTEGER, intent(in) :: LSCALING_LOC_BWD REAL, intent(in) :: SCALING_LOC_BWD(LSCALING_LOC_BWD) #endif LOGICAL, intent(in) :: LSCAL INTEGER, INTENT(in) :: SIZE_PERM_RHS INTEGER, INTENT(in) :: PERM_RHS(SIZE_PERM_RHS) INTEGER I, II, J, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL, N2RECV INTEGER LIELL, IPOS, NPIV, MAXNPIV_estim, MAXSurf INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR, allocok PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND, IPOSINRHSINTR INTEGER :: JCOL_RHS INTEGER :: K242 LOGICAL :: OMP_FLAG !$ INTEGER :: CHUNK, NOMP INTEGER, PARAMETER :: FIN = -1 COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER, ALLOCATABLE, DIMENSION(:) :: IROWlist INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_PROCNODE TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 IF ( TYPE_PARAL == 1 ) THEN MYID_NODES = MYID ELSE MYID_NODES = MYID-1 ENDIF IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN IF (LSCAL) THEN OMP_FLAG = .FALSE. IF (KEEP(350).EQ.2) THEN K242 = KEEP(242) !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK = max(N/2,1) !$ IF (int(NRHS,8) * int(N,8) .GE. int(KEEP(363),8)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8)) !$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362)) !$ CHUNK = max(KEEP(363)/2,CHUNK) !$ ENDIF ENDIF IF (OMP_FLAG) THEN !$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242) !$OMP& PRIVATE(J,IPOSINRHSINTR,I,JCOL_RHS) DO J=1, NRHS IF (K242.EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF !$OMP DO SCHEDULE(DYNAMIC,CHUNK) DO I=1, N IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN RHS(I,JCOL_RHS) = RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ELSE DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO I=1, N IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN RHS(I,JCOL_RHS) = RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO ENDDO ENDIF ELSE OMP_FLAG = .FALSE. IF (KEEP(350).EQ.2) THEN K242 = KEEP(242) !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = max(N/2,1) !$ IF (NRHS * N .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8)) !$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362)) !$ CHUNK = max(KEEP(363)/2,CHUNK) !$ ENDIF ENDIF IF (OMP_FLAG) THEN !$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242) !$OMP& PRIVATE(IPOSINRHSINTR,I,JCOL_RHS) IF (OMP_FLAG) DO J=1, NRHS IF (K242.EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF !$OMP DO SCHEDULE(DYNAMIC,CHUNK) DO I=1, N IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN RHS(I,JCOL_RHS) = RHSINTR(IPOSINRHSINTR,J) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ELSE DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO I=1, N IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN RHS(I,JCOL_RHS) = RHSINTR(IPOSINRHSINTR,J) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO ENDDO ENDIF ENDIF RETURN ENDIF MAXNPIV_estim = max(KEEP(246), KEEP(247)) MAXSurf = MAXNPIV_estim*NRHS IF (LCWORK .LT. MAXNPIV_estim) THEN WRITE(*,*) MYID, & ": Internal error 2 in CMUMPS_GATHER_SOLUTION:", & TYPE_PARAL, LCWORK, KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF IF (MYID.EQ.MASTER) THEN ALLOCATE(IROWlist(KEEP(247)),stat=allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of IROWlist' CALL MUMPS_ABORT() ENDIF ENDIF IF (NSLAVES .EQ. 1 .AND. TYPE_PARAL .EQ. 1) THEN CALL MUMPS_ABORT() ENDIF SIZE1=0 CALL MPI_PACK_SIZE(MAXNPIV_estim+2,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(MAXSurf,MPI_COMPLEX, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in CMUMPS_GATHER_SOLUTION ' write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', & RECORD_SIZE_P_1, SIZE_BUF_BYTES CALL MUMPS_ABORT() ENDIF N2SEND =0 N2RECV =N POS_BUF =0 IF (I_AM_SLAVE) THEN POS_BUF = 0 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N) IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-NPIV IF (NPIV.GT.0) & CALL CMUMPS_NPIV_BLOCK_ADD ( .TRUE. ) ELSE IF (NPIV.GT.0) & CALL CMUMPS_NPIV_BLOCK_ADD ( .FALSE.) ENDIF ENDIF ENDDO CALL CMUMPS_NPIV_BLOCK_SEND() ENDIF IF ( MYID .EQ. MASTER ) THEN DO WHILE (N2RECV .NE. 0) CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, & MPI_ANY_SOURCE, & GatherSol, COMM, STATUS, IERR ) POS_BUF = 0 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & NPIV, 1, MPI_INTEGER, COMM, IERR) DO WHILE (NPIV.NE.FIN) CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & IROWlist, NPIV, MPI_INTEGER, COMM, IERR) DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS=J+JBEG_RHS-1 ELSE JCOL_RHS=PERM_RHS(J+JBEG_RHS-1) ENDIF CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & CWORK, NPIV, MPI_COMPLEX, & COMM, IERR) #if defined(USE_OLD_SCALING) IF (LSCAL) THEN DO I=1,NPIV RHS(IROWlist(I),JCOL_RHS)=CWORK(I)*SCALING(IROWlist(I)) ENDDO ELSE #else #endif DO I=1,NPIV RHS(IROWlist(I),JCOL_RHS)=CWORK(I) ENDDO #if defined(USE_OLD_SCALING) ENDIF #endif ENDDO N2RECV=N2RECV-NPIV CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, & NPIV, 1, MPI_INTEGER, COMM, IERR) ENDDO ENDDO DEALLOCATE(IROWlist) ENDIF RETURN CONTAINS SUBROUTINE CMUMPS_NPIV_BLOCK_ADD ( ON_MASTER ) LOGICAL, intent(in) :: ON_MASTER INTEGER :: JPOS, K242 LOGICAL :: PRIV_LSCAL IF (ON_MASTER) THEN IF (KEEP(350).EQ.2 & .AND. (NRHS.EQ.1.OR.((NPIV*NRHS*2*KEEP(16)).GE.KEEP(364)))) THEN PRIV_LSCAL = LSCAL K242 = KEEP(242) DO J=1, NRHS IF (K242.EQ.0) THEN JPOS = J+JBEG_RHS-1 ELSE JPOS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) IF (PRIV_LSCAL) THEN RHS(I,JPOS) = RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ELSE RHS(I,JPOS) = RHSINTR(IPOSINRHSINTR,J) ENDIF ENDDO ENDDO ELSE IF (KEEP(242).EQ.0) THEN IF (LSCAL) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ENDDO ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = RHSINTR(IPOSINRHSINTR,J) ENDDO ENDDO ENDIF ELSE IF (LSCAL) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) !DIR$ NOVECTOR DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ENDDO ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) !DIR$ NOVECTOR DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSINTR(IPOSINRHSINTR,J) ENDDO ENDDO ENDIF ENDIF ENDIF RETURN ENDIF CALL MPI_PACK(NPIV, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(IW(J1), NPIV, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) IPOSINRHSINTR= POSINRHSINTR(IW(J1)) DO J=1,NRHS #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO II=IPOSINRHSINTR, IPOSINRHSINTR+NPIV-1 RHSINTR(II,J)= & RHSINTR(II,J)*SCALING_LOC_BWD(II) ENDDO ENDIF #endif CALL MPI_PACK(RHSINTR(IPOSINRHSINTR,J), NPIV, & MPI_COMPLEX, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ENDDO N2SEND=N2SEND+NPIV IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL CMUMPS_NPIV_BLOCK_SEND() END IF RETURN END SUBROUTINE CMUMPS_NPIV_BLOCK_ADD SUBROUTINE CMUMPS_NPIV_BLOCK_SEND() IF (N2SEND .NE. 0) THEN CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, & GatherSol, COMM, IERR) ENDIF POS_BUF=0 N2SEND=0 RETURN END SUBROUTINE CMUMPS_NPIV_BLOCK_SEND END SUBROUTINE CMUMPS_GATHER_SOLUTION SUBROUTINE CMUMPS_GATHER_SOLUTION_AM1(NSLAVES, N, MYID, COMM, & NRHS, RHSINTR, LRHSINTR, NRHSINTR_COL, & KEEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, #if defined(USE_OLD_SCALING) & LSCAL, SCALING, LSCALING, #else & LSCAL, SCALING_LOC_BWD, LSCALING_LOC_BWD, #endif & IRHS_PTR_COPY, LIRHS_PTR_COPY, & IRHS_SPARSE_COPY, LIRHS_SPARSE_COPY, & RHS_SPARSE_COPY, LRHS_SPARSE_COPY, & UNS_PERM_INV, LUNS_PERM_INV, & POSINRHSINTR, LPOS_ROW, NB_FS_IN_RHSINTR ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM INTEGER NRHS, LRHSINTR, NRHSINTR_COL COMPLEX, intent(in) :: RHSINTR (LRHSINTR, NRHSINTR_COL) INTEGER KEEP(500) INTEGER SIZE_BUF, SIZE_BUF_BYTES, LPOS_ROW INTEGER BUFFER(SIZE_BUF) INTEGER, intent(in) :: LIRHS_PTR_COPY, LIRHS_SPARSE_COPY, & LRHS_SPARSE_COPY, LUNS_PERM_INV, & NB_FS_IN_RHSINTR INTEGER :: IRHS_SPARSE_COPY(LIRHS_SPARSE_COPY), & IRHS_PTR_COPY(LIRHS_PTR_COPY), & UNS_PERM_INV(LUNS_PERM_INV), & POSINRHSINTR(LPOS_ROW) COMPLEX :: RHS_SPARSE_COPY(LRHS_SPARSE_COPY) #if defined(USE_OLD_SCALING) INTEGER, intent(in) :: LSCALING REAL, intent(in) :: SCALING(LSCALING) #else INTEGER, intent(in) :: LSCALING_LOC_BWD REAL, intent(in) :: SCALING_LOC_BWD(LSCALING_LOC_BWD) #endif LOGICAL, intent(in) :: LSCAL INTEGER COLSIZE, K, IZ, IPREV, NBCOL_INBLOC INTEGER I, II, J, MASTER, & TYPE_PARAL, N2RECV, IPOSINRHSINTR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND INTEGER, PARAMETER :: FIN = -1 INCLUDE 'mumps_headers.h' TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 NBCOL_INBLOC = size(IRHS_PTR_COPY)-1 IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN K=1 DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.EQ.0) CYCLE DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)= & RHSINTR(IPOSINRHSINTR,K) #if defined(USE_OLD_SCALING) & * SCALING(I) #else & * SCALING_LOC_BWD(IPOSINRHSINTR) #endif ELSE RHS_SPARSE_COPY(IZ)=RHSINTR(IPOSINRHSINTR,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) IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)=RHSINTR(IPOSINRHSINTR,K) & * SCALING_LOC_BWD(IPOSINRHSINTR) ELSE #endif RHS_SPARSE_COPY(IZ)=RHSINTR(IPOSINRHSINTR,K) #if ! defined(USE_OLD_SCALING) ENDIF #endif ENDIF ENDDO K = K + 1 ENDDO ENDIF SIZE1=0 CALL MPI_PACK_SIZE(3,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(1,MPI_COMPLEX, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in CMUMPS_GATHER_SOLUTION_AM1 ' write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', & RECORD_SIZE_P_1, SIZE_BUF_BYTES CALL MUMPS_ABORT() ENDIF N2SEND =0 N2RECV =size(IRHS_SPARSE_COPY) POS_BUF =0 IF (I_AM_SLAVE) THEN DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.LE.0) CYCLE K = 0 DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) II = I IF (KEEP(23).NE.0) II = UNS_PERM_INV(I) IPOSINRHSINTR = POSINRHSINTR(II) IF (IPOSINRHSINTR.GT.0) THEN IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-1 #if defined(USE_OLD_SCALING) IF (LSCAL) & CALL CMUMPS_AM1_BLOCK_ADD ( .TRUE. ) #endif 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 #if defined(USE_OLD_SCALING) CALL CMUMPS_AM1_BLOCK_ADD ( .FALSE. ) #else CALL CMUMPS_AM1_BLOCK_ADD () #endif ENDIF ENDIF ENDDO IF (MYID.EQ.MASTER) & IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + K ENDDO CALL CMUMPS_AM1_BLOCK_SEND() ENDIF IF ( MYID .EQ. MASTER ) THEN DO WHILE (N2RECV .NE. 0) CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, & MPI_ANY_SOURCE, & GatherSol, COMM, STATUS, IERR ) POS_BUF = 0 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & J, 1, MPI_INTEGER, COMM, IERR) DO WHILE (J.NE.FIN) IZ = IRHS_PTR_COPY(J) CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & I, 1, MPI_INTEGER, COMM, IERR) IRHS_SPARSE_COPY(IZ) = I CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & RHS_SPARSE_COPY(IZ), 1, MPI_COMPLEX, & COMM, IERR) #if defined(USE_OLD_SCALING) IF (LSCAL) THEN IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) RHS_SPARSE_COPY(IZ) = RHS_SPARSE_COPY(IZ)*SCALING(I) ENDIF #endif N2RECV=N2RECV-1 IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + 1 CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, & J, 1, MPI_INTEGER, COMM, IERR) ENDDO ENDDO IPREV = 1 DO J=1, size(IRHS_PTR_COPY)-1 I= IRHS_PTR_COPY(J) IRHS_PTR_COPY(J) = IPREV IPREV = I ENDDO ENDIF RETURN CONTAINS SUBROUTINE CMUMPS_AM1_BLOCK_ADD ( #if defined(USE_OLD_SCALING) & SCALE_ONLY #endif & ) #if defined(USE_OLD_SCALING) LOGICAL, intent(in) :: SCALE_ONLY #endif #if defined(USE_OLD_SCALING) INTEGER III #endif #if defined(USE_OLD_SCALING) IF (SCALE_ONLY) THEN WRITE(*,*) "CMUMPS_AM1_BLOCK_ADD(true) should not be called" CALL MUMPS_ABORT() 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 #endif CALL MPI_PACK(J, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(I, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(RHS_SPARSE_COPY(IZ), 1, MPI_COMPLEX, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) N2SEND=N2SEND+1 IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL CMUMPS_AM1_BLOCK_SEND() END IF RETURN END SUBROUTINE CMUMPS_AM1_BLOCK_ADD SUBROUTINE CMUMPS_AM1_BLOCK_SEND() IF (N2SEND .NE. 0) THEN CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, & GatherSol, COMM, IERR) ENDIF POS_BUF=0 N2SEND=0 RETURN END SUBROUTINE CMUMPS_AM1_BLOCK_SEND END SUBROUTINE CMUMPS_GATHER_SOLUTION_AM1 SUBROUTINE CMUMPS_DISTSOL_INDICES(MTYPE, ISOL_LOC, & PTRIST, KEEP,KEEP8, & IW, LIW_PASSED, MYID_NODES, N, STEP, & PROCNODE, NSLAVES, #if defined(USE_OLD_SCALING) & scaling_data, LSCAL, #endif & IRHS_loc_MEANINGFUL, IRHS_loc, Nloc_RHS & ) IMPLICIT NONE INTEGER MTYPE, MYID_NODES, N, NSLAVES INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE(KEEP(28)) INTEGER ISOL_LOC(KEEP(89)) INTEGER LIW_PASSED INTEGER IW(LIW_PASSED) INTEGER STEP(N) #if defined(USE_OLD_SCALING) LOGICAL LSCAL #endif LOGICAL :: IRHS_loc_MEANINGFUL INTEGER :: Nloc_RHS INTEGER :: IRHS_loc(Nloc_RHS) #if defined(USE_OLD_SCALING) type scaling_data_t SEQUENCE REAL, dimension(:), pointer :: SCALING REAL, dimension(:), pointer :: SCALING_LOC INTEGER, dimension(:), pointer :: SCALING_IND end type scaling_data_t type (scaling_data_t) :: scaling_data #endif INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER ISTEP, K INTEGER J1, IPOS, LIELL, NPIV, JJ LOGICAL :: CHECK_IRHS_loc INTEGER(8) :: DIFF_ADDR INCLUDE 'mumps_headers.h' CHECK_IRHS_loc=.FALSE. IF ( IRHS_loc_MEANINGFUL ) THEN IF (Nloc_RHS .GT. 0) THEN CALL MUMPS_SIZE_C( IRHS_loc(1), ISOL_loc(1), & DIFF_ADDR ) IF (DIFF_ADDR .EQ. 0_8) THEN CHECK_IRHS_loc=.TRUE. ENDIF ENDIF ENDIF K=0 DO ISTEP=1, KEEP(28) IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW_PASSED, PTRIST, STEP, N) IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF DO JJ=J1,J1+NPIV-1 K=K+1 IF (CHECK_IRHS_loc) THEN IF (K.LE.Nloc_RHS) THEN IF ( IW(JJ) .NE.IRHS_LOC(K) ) THEN ENDIF ENDIF ENDIF ISOL_LOC(K)=IW(JJ) #if defined(USE_OLD_SCALING) IF (LSCAL) THEN scaling_data%SCALING_LOC(K)= & scaling_data%SCALING(IW(JJ)) ENDIF #endif ENDDO ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_DISTSOL_INDICES #if ! defined(USE_OLD_SCALING) SUBROUTINE CMUMPS_SCALINGRHSINTR(LSCAL, N, & SCALING_LOC, SCALING_RHSINTR, & L, POSINRHSINTR, KEEP, ROWORCOL, PTRIST, & IW, LIW_PASSED, MYID_NODES, STEP, & PROCNODE, NSLAVES) IMPLICIT NONE INTEGER :: KEEP(500) LOGICAL, INTENT(IN) :: LSCAL INTEGER, INTENT(IN) :: N, L INTEGER, INTENT(IN) :: POSINRHSINTR(N) REAL , INTENT(IN) :: SCALING_LOC(max(KEEP(89),1)) REAL , INTENT(OUT) :: SCALING_RHSINTR(L) INTEGER, INTENT(IN) :: ROWORCOL, NSLAVES, LIW_PASSED, MYID_NODES INTEGER, INTENT(IN) :: STEP(KEEP(28)), & PROCNODE(KEEP(28)), & PTRIST(KEEP(28)), & IW(LIW_PASSED) INTEGER :: IPOSINRHSINTR INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER :: ISTEP INTEGER :: KLOC, J1, JJ, LIELL, IPOS, NPIV IF (.NOT. LSCAL) THEN WRITE(*,*) "Internal error 1 in CMUMPS_DS_SCALINGRHSINTR" CALL MUMPS_ABORT() ENDIF IF (ROWORCOL .NE. 1 .AND. ROWORCOL.NE.2) THEN WRITE(*,*) "Internal error 2 in CMUMPS_DS_SCALINGRHSINTR", & ROWORCOL ENDIF IF (KEEP(89).EQ.0) RETURN KLOC = 1 DO ISTEP=1, KEEP(28) IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW_PASSED, PTRIST, STEP, N) IF (ROWORCOL .EQ. 1) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IPOSINRHSINTR = POSINRHSINTR(IW(J1)) IF ( IPOSINRHSINTR .GT. 0 ) THEN DO JJ=1, NPIV SCALING_RHSINTR(IPOSINRHSINTR+JJ-1) = & SCALING_LOC(KLOC+JJ-1) ENDDO ENDIF KLOC = KLOC + NPIV ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_SCALINGRHSINTR #endif SUBROUTINE CMUMPS_DISTRIBUTED_SOLUTION( & SLAVEF, N, MYID_NODES, & MTYPE, RHSINTR, LRHSINTR, NBRHS_EFF, & POSINRHSINTR, & ISOL_LOC, & SOL_LOC, NRHS, BEG_RHS, LSOL_LOC, & PTRIST, & PROCNODE_STEPS, KEEP,KEEP8, IW, LIW, STEP, & SCALING_LOC_BWD, LSCALING_LOC_BWD, & LSCAL, NB_RHSSKIPPED, & PERM_RHS, SIZE_PERM_RHS) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' LOGICAL, intent(in) :: LSCAL INTEGER, intent(in) :: LSCALING_LOC_BWD REAL, intent(in) :: SCALING_LOC_BWD(LSCALING_LOC_BWD) INTEGER SLAVEF, N, MYID_NODES, LIW, MTYPE, NBRHS_EFF, LRHSINTR INTEGER POSINRHSINTR(N), NB_RHSSKIPPED INTEGER LSOL_LOC, BEG_RHS INTEGER ISOL_LOC(LSOL_LOC) INTEGER, INTENT(in) :: NRHS COMPLEX SOL_LOC( LSOL_LOC, NRHS ) COMPLEX RHSINTR( LRHSINTR, NBRHS_EFF ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER, INTENT(in) :: SIZE_PERM_RHS INTEGER, INTENT(in) :: PERM_RHS( SIZE_PERM_RHS ) INTEGER :: JJ, J1, ISTEP, K, KLOC, IPOSINRHSINTR, JEMPTY INTEGER :: JCOL, JCOL_PERM INTEGER :: IPOS, LIELL, NPIV, JEND LOGICAL :: IS_ROOT !$ LOGICAL :: OMP_FLAG COMPLEX, PARAMETER :: ZERO = (0.0E0,0.0E0) INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE K=0 JEMPTY = BEG_RHS+NB_RHSSKIPPED-1 JEND = BEG_RHS+NB_RHSSKIPPED+NBRHS_EFF-1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN IS_ROOT=.false. IF (KEEP(38).ne.0) IS_ROOT = STEP(KEEP(38))==ISTEP IF (KEEP(20).ne.0) IS_ROOT = STEP(KEEP(20))==ISTEP IF ( IS_ROOT ) THEN IPOS = PTRIST(ISTEP) + KEEP(IXSZ) LIELL = IW(IPOS+3) NPIV = LIELL IPOS= PTRIST(ISTEP)+5+KEEP(IXSZ) ELSE IPOS = PTRIST(ISTEP) + 2 +KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) IPOS= IPOS+1 NPIV = IW(IPOS) IPOS= IPOS+1 IPOS= IPOS+1+IW( PTRIST(ISTEP) + 5 +KEEP(IXSZ)) END IF IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF IF (NB_RHSSKIPPED.GT.0) THEN DO JCOL = BEG_RHS, JEMPTY IF (KEEP(242) .NE. 0) THEN JCOL_PERM = PERM_RHS(JCOL) ELSE JCOL_PERM = JCOL ENDIF KLOC=K DO JJ=J1,J1+NPIV-1 KLOC=KLOC+1 SOL_LOC(KLOC, JCOL_PERM) = ZERO ENDDO ENDDO ENDIF !$ OMP_FLAG = ( JEND-JEMPTY.GE.KEEP(362) .AND. !$ & (NPIV*(JEND-JEMPTY) .GE. KEEP(363)/2 ) ) !$OMP PARALLEL DO PRIVATE(JCOL,JCOL_PERM,KLOC,JJ,IPOSINRHSINTR) !$OMP& IF(OMP_FLAG) DO JCOL = JEMPTY+1, JEND IF (KEEP(242) .NE. 0) THEN JCOL_PERM = PERM_RHS(JCOL) ELSE JCOL_PERM = JCOL ENDIF DO JJ=J1,J1+NPIV-1 KLOC=K + JJ-J1 + 1 IF (LSCAL) THEN SOL_LOC(KLOC,JCOL_PERM) = & SCALING_LOC_BWD(KLOC)* & RHSINTR(KLOC,JCOL-JEMPTY) ELSE SOL_LOC(KLOC,JCOL_PERM) = & RHSINTR(KLOC,JCOL-JEMPTY) ENDIF ENDDO ENDDO !$OMP END PARALLEL DO K=K+NPIV ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_DISTRIBUTED_SOLUTION SUBROUTINE CMUMPS_SCATTER_RHS & (NSLAVES, N, MYID, COMM, & LSCAL, SCALING_LOC_FWD, & MTYPE, RHS, LRHS, NCOL_RHS, NRHS, & RHSINTR, LRHSINTR, NCOL_RHSINTR, & POSINRHSINTR_FWD, NB_FS_IN_RHSINTR_F, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & ICNTL, INFO) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE INTEGER NRHS, LRHS, NCOL_RHS, LRHSINTR, NCOL_RHSINTR INTEGER ICNTL(60), INFO(80) COMPLEX, intent(in) :: RHS (LRHS, NCOL_RHS) COMPLEX, intent(out) :: RHSINTR(LRHSINTR, NCOL_RHSINTR) INTEGER, intent(in) :: POSINRHSINTR_FWD(N), NB_FS_IN_RHSINTR_F INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) LOGICAL, intent(in) :: LSCAL REAL, intent(in) :: SCALING_LOC_FWD(max(1,KEEP(89))) INTEGER BUF_MAXSIZE, BUF_MAXREF PARAMETER (BUF_MAXREF=200000) INTEGER, ALLOCATABLE, DIMENSION(:) :: BUF_INDX COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: BUF_RHS COMPLEX, ALLOCATABLE, DIMENSION(:) :: BUF_RHS_2 INTEGER ENTRIES_2_PROCESS, PROC_WHO_ASKS, BUF_EFFSIZE INTEGER INDX INTEGER allocok COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER I, J, K, JJ, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL INTEGER LIELL, IPOS, NPIV INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE !$ INTEGER :: CHUNK, NOMP !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. 0 .OR. TYPE_PARAL .eq. 1 IF ( TYPE_PARAL == 1 ) THEN MYID_NODES = MYID ELSE MYID_NODES = MYID-1 ENDIF BUF_EFFSIZE = 0 BUF_MAXSIZE = max(min(BUF_MAXREF,int(2000000/NRHS)),2000) IF ( KEEP(350).EQ.2 ) THEN !$ NOMP = OMP_GET_MAX_THREADS() ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS_2(BUF_MAXSIZE*NRHS), & stat=allocok) ELSE ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS(NRHS,BUF_MAXSIZE), & stat=allocok) END IF IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=BUF_MAXSIZE*(NRHS+1) ENDIF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM, MYID ) IF (INFO(1).LT.0) RETURN IF (MYID.EQ.MASTER) THEN ENTRIES_2_PROCESS = N - KEEP(89) IF (TYPE_PARAL.EQ.1.AND.ENTRIES_2_PROCESS.NE.0) THEN IF (NB_FS_IN_RHSINTR_F.LT.LRHSINTR) THEN DO K=1, NCOL_RHSINTR DO I = NB_FS_IN_RHSINTR_F +1, LRHSINTR RHSINTR (I, K) = ZERO ENDDO ENDDO ENDIF ENDIF IF ( KEEP(350).EQ.2 ) THEN DO WHILE ( ENTRIES_2_PROCESS .NE. 0) CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, & ScatterRhsI, COMM, STATUS, IERR ) CALL MPI_GET_COUNT(STATUS,MPI_INTEGER,BUF_EFFSIZE,IERR) PROC_WHO_ASKS = STATUS(MPI_SOURCE) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = BUF_INDX( I ) BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) = RHS( INDX, K ) ENDDO ENDDO !$OMP END PARALLEL DO CALL MPI_SEND( BUF_RHS_2, & NRHS*BUF_EFFSIZE, & MPI_COMPLEX, PROC_WHO_ASKS, & ScatterRhsR, COMM, IERR) ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE ENDDO BUF_EFFSIZE= 0 ELSE DO WHILE ( ENTRIES_2_PROCESS .NE. 0) CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, & ScatterRhsI, COMM, STATUS, IERR ) CALL MPI_GET_COUNT( STATUS, MPI_INTEGER,BUF_EFFSIZE,IERR) PROC_WHO_ASKS = STATUS(MPI_SOURCE) DO I = 1, BUF_EFFSIZE INDX = BUF_INDX( I ) DO K = 1, NRHS BUF_RHS( K, I ) = RHS( INDX, K ) ENDDO ENDDO CALL MPI_SEND( BUF_RHS, NRHS*BUF_EFFSIZE, & MPI_COMPLEX, PROC_WHO_ASKS, & ScatterRhsR, COMM, IERR) ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE ENDDO BUF_EFFSIZE= 0 ENDIF ENDIF IF (I_AM_SLAVE) THEN IF (MYID.NE.MASTER) THEN IF (NB_FS_IN_RHSINTR_F.LT.LRHSINTR) THEN DO K=1, NCOL_RHSINTR DO I = NB_FS_IN_RHSINTR_F +1, LRHSINTR RHSINTR (I, K) = ZERO ENDDO ENDDO ENDIF ENDIF DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF (MYID.EQ.MASTER) THEN INDX = POSINRHSINTR_FWD(IW(J1)) IF (KEEP(350).EQ.2 .AND. & (NRHS.EQ.1.OR.((NPIV*NRHS*2*KEEP(16)).GE.KEEP(364)))) THEN !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (NPIV*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((NPIV*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(J,JJ) !$OMP& FIRSTPRIVATE(INDX) IF (OMP_FLAG) DO K = 1, NRHS DO JJ=J1,J1+NPIV-1 J=IW(JJ) RHSINTR( INDX+JJ-J1, K ) = RHS( J, K ) * & SCALING_LOC_FWD( INDX+JJ-J1 ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE #endif !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(J,JJ) !$OMP& FIRSTPRIVATE(INDX) IF (OMP_FLAG) DO K = 1, NRHS DO JJ=J1,J1+NPIV-1 J=IW(JJ) RHSINTR( INDX+JJ-J1, K ) = RHS( J, K ) ENDDO ENDDO !$OMP END PARALLEL DO #if ! defined(USE_OLD_SCALING) ENDIF #endif ELSE #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO JJ=J1,J1+NPIV-1 J=IW(JJ) DO K = 1, NRHS RHSINTR( INDX+JJ-J1, K ) = RHS( J, K ) & * SCALING_LOC_FWD( INDX + JJ - J1 ) ENDDO ENDDO ELSE #endif DO JJ=J1,J1+NPIV-1 J=IW(JJ) DO K = 1, NRHS RHSINTR( INDX+JJ-J1, K ) = RHS( J, K ) ENDDO ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif END IF ELSE DO JJ=J1,J1+NPIV-1 BUF_EFFSIZE = BUF_EFFSIZE + 1 BUF_INDX(BUF_EFFSIZE) = IW(JJ) IF (BUF_EFFSIZE + 1 .GT. BUF_MAXSIZE) THEN CALL CMUMPS_GET_BUF_INDX_RHS() ENDIF ENDDO ENDIF ENDIF ENDDO IF ( BUF_EFFSIZE .NE. 0 .AND. MYID.NE.MASTER ) & CALL CMUMPS_GET_BUF_INDX_RHS() ENDIF IF (KEEP(350).EQ.2) THEN DEALLOCATE (BUF_INDX, BUF_RHS_2) ELSE DEALLOCATE (BUF_INDX, BUF_RHS) ENDIF RETURN CONTAINS SUBROUTINE CMUMPS_GET_BUF_INDX_RHS() CALL MPI_SEND(BUF_INDX, BUF_EFFSIZE, MPI_INTEGER, & MASTER, ScatterRhsI, COMM, IERR ) IF (KEEP(350).EQ.2) THEN CALL MPI_RECV(BUF_RHS_2, BUF_EFFSIZE*NRHS, & MPI_COMPLEX, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = POSINRHSINTR_FWD(BUF_INDX(I)) RHSINTR( INDX, K ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) * & SCALING_LOC_FWD( INDX ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE #endif !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = POSINRHSINTR_FWD(BUF_INDX(I)) RHSINTR( INDX, K ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) ENDDO ENDDO !$OMP END PARALLEL DO #if ! defined(USE_OLD_SCALING) ENDIF #endif ELSE CALL MPI_RECV(BUF_RHS, BUF_EFFSIZE*NRHS, & MPI_COMPLEX, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO I = 1, BUF_EFFSIZE INDX = POSINRHSINTR_FWD(BUF_INDX(I)) DO K = 1, NRHS RHSINTR( INDX, K ) = BUF_RHS( K, I ) & * SCALING_LOC_FWD( INDX ) ENDDO ENDDO ELSE #endif DO I = 1, BUF_EFFSIZE INDX = POSINRHSINTR_FWD(BUF_INDX(I)) DO K = 1, NRHS RHSINTR( INDX, K ) = BUF_RHS( K, I ) ENDDO ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif END IF BUF_EFFSIZE = 0 RETURN END SUBROUTINE CMUMPS_GET_BUF_INDX_RHS END SUBROUTINE CMUMPS_SCATTER_RHS SUBROUTINE CMUMPS_BUILD_GLOB2LOC & (NSLAVES, N, MYID_NODES, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & GLOB2LOC_RHS, GLOB2LOC_SOL, & GLOB2LOC_SOL_ALLOC, & MTYPE, & NBENT_RHSINTR, NB_FS_IN_RHSINTR ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER, intent(in) :: IW(LIW), STEP(N) INTEGER, intent(in) :: MTYPE LOGICAL, intent(in) :: GLOB2LOC_SOL_ALLOC INTEGER, intent(out):: GLOB2LOC_RHS(N), GLOB2LOC_SOL(N) INTEGER, intent(out):: NBENT_RHSINTR, NB_FS_IN_RHSINTR INTEGER ISTEP INTEGER NPIV INTEGER IPOS, LIELL INTEGER JJ, J1, JCOL INTEGER IPOSINRHSINTR, IPOSINRHSINTR_SOL INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE GLOB2LOC_RHS = 0 IF (GLOB2LOC_SOL_ALLOC) GLOB2LOC_SOL = 0 IPOSINRHSINTR = 1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, NPIV, LIELL, & IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = J1, J1+NPIV-1 GLOB2LOC_RHS(IW(JJ)) = IPOSINRHSINTR+JJ-J1 ENDDO IF (GLOB2LOC_SOL_ALLOC) THEN DO JJ = JCOL, JCOL+NPIV-1 GLOB2LOC_SOL(IW(JJ)) = IPOSINRHSINTR+JJ-JCOL ENDDO ENDIF IPOSINRHSINTR = IPOSINRHSINTR + NPIV ENDIF ENDDO NB_FS_IN_RHSINTR = IPOSINRHSINTR -1 IF (GLOB2LOC_SOL_ALLOC) IPOSINRHSINTR_SOL=IPOSINRHSINTR IF (IPOSINRHSINTR.GT.N) GOTO 500 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF (GLOB2LOC_SOL_ALLOC) THEN DO JJ = NPIV, LIELL-1-KEEP(253) IF (GLOB2LOC_RHS(IW(J1+JJ)).EQ.0) THEN GLOB2LOC_RHS(IW(J1+JJ)) = - IPOSINRHSINTR IPOSINRHSINTR = IPOSINRHSINTR + 1 ENDIF IF (GLOB2LOC_SOL(IW(JCOL+JJ)).EQ.0) THEN GLOB2LOC_SOL(IW(JCOL+JJ)) = - IPOSINRHSINTR_SOL IPOSINRHSINTR_SOL = IPOSINRHSINTR_SOL + 1 ENDIF ENDDO ELSE DO JJ = J1+NPIV, J1+LIELL-1-KEEP(253) IF (GLOB2LOC_RHS(IW(JJ)).EQ.0) THEN GLOB2LOC_RHS(IW(JJ)) = - IPOSINRHSINTR IPOSINRHSINTR = IPOSINRHSINTR + 1 ENDIF ENDDO ENDIF ENDIF ENDDO 500 NBENT_RHSINTR = IPOSINRHSINTR - 1 IF (GLOB2LOC_SOL_ALLOC) & NBENT_RHSINTR = max(NBENT_RHSINTR, IPOSINRHSINTR_SOL-1) RETURN END SUBROUTINE CMUMPS_BUILD_GLOB2LOC SUBROUTINE CMUMPS_NODES_FWD_BWD_SIZE_FILL ( & fill, ICNTL, & N, NSTEPS, KEEP, STEP, Step2node, & IRHS_loc, Nloc_RHS, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & PERM_RHS, SIZE_PERM_RHS, JBEG_RHS, & UNS_PERM_INV, SIZE_UNS_PERM_INV, & ICNTL21, & MYID, COMM, & INFO, & Pruned_Sons_FWD, Pruned_Sons_BWD, & Lnodes_FWD, Lnodes_BWD & , nodes_FWD, nodes_BWD & , Lnodes_FWD_in, Lnodes_BWD_in & ) USE CMUMPS_SOL_ES, ONLY : CMUMPS_ES_NODES_SIZE_AND_FILL IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: ICNTL(60),N, NSTEPS, KEEP(500) INTEGER, INTENT(IN) :: STEP(N), Step2node(NSTEPS) INTEGER, INTENT(IN) :: Nloc_RHS, & IRHS_loc(max(1,Nloc_RHS)) INTEGER, intent(in) :: NBCOL_INBLOC, IRHS_PTR(NBCOL_INBLOC+1) INTEGER, intent(in) :: NZ_RHS, IRHS_SPARSE(NZ_RHS) INTEGER, intent(in) :: SIZE_PERM_RHS, PERM_RHS(SIZE_PERM_RHS) INTEGER, intent(in) :: JBEG_RHS, SIZE_UNS_PERM_INV INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, intent(IN) :: ICNTL21 INTEGER, intent(in) :: MYID, COMM INTEGER, intent(inout) :: INFO(80) INTEGER, intent(inout) :: Pruned_Sons_FWD(NSTEPS), & Pruned_Sons_BWD(NSTEPS) INTEGER, intent(inout) :: Lnodes_FWD, Lnodes_BWD INTEGER, intent(in) :: Lnodes_FWD_in, Lnodes_BWD_in INTEGER, intent(out) :: nodes_FWD(Lnodes_FWD_in), & nodes_BWD(Lnodes_BWD_in) INCLUDE 'mpif.h' LOGICAL :: DO_PRUN_FWD, AM1, Exploit_Sparsity_FWD, & Exploit_Sparsity_BWD INTEGER :: Lnodes_FWD_loc, Lnodes_BWD_loc, ISTEP, & INODE_PRINC, I, II, JAM1 #if defined(AVOID_MPI_IN_PLACE) INTEGER, DIMENSION(:), ALLOCATABLE :: TMP_INT_ARRAY INTEGER :: allocok #endif #if defined(AVOID_MPI_IN_PLACE) ALLOCATE(TMP_INT_ARRAY(KEEP(28)), STAT = allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM, MYID ) IF(INFO(1).LT.0) GOTO 500 #endif AM1 = (KEEP(237) .NE. 0) Exploit_Sparsity_FWD = (KEEP(235) .NE. 0) .AND. (.NOT. AM1) DO_PRUN_FWD = (Exploit_Sparsity_FWD.OR.AM1) Exploit_Sparsity_BWD = (KEEP(212) .NE. 0) .AND. (.NOT. AM1) IF (.NOT.fill) Lnodes_FWD=-1 IF (.NOT.fill) Lnodes_BWD=-1 IF (.NOT.fill.AND.KEEP(252).NE.0) THEN Lnodes_FWD = 0 ENDIF IF ( KEEP(252).NE.0 ) DO_PRUN_FWD = .FALSE. IF ( DO_PRUN_FWD ) THEN IF ( Exploit_Sparsity_FWD.AND.KEEP(248).EQ.-1 ) THEN IF (.NOT.fill) THEN CALL CMUMPS_ES_NODES_SIZE_AND_FILL ( fill, & N, KEEP(28), KEEP, STEP, Step2node, & IRHS_loc, Nloc_RHS, MYID, COMM, & Pruned_Sons_FWD, Lnodes_FWD #if defined(AVOID_MPI_IN_PLACE) & , TMP_INT_ARRAY #endif & ) ELSE IF (Lnodes_FWD.GT.0) THEN CALL CMUMPS_ES_NODES_SIZE_AND_FILL ( fill, & N, KEEP(28), KEEP, STEP, Step2node, & IRHS_loc, Nloc_RHS, MYID, COMM, & Pruned_Sons_FWD, Lnodes_FWD, #if defined(AVOID_MPI_IN_PLACE) & TMP_INT_ARRAY, #endif & nodes_FWD & ) ENDIF ELSE IF ( Exploit_Sparsity_FWD.AND.KEEP(248).NE.-1 ) THEN IF (.NOT.fill) THEN Lnodes_FWD = 0 Pruned_Sons_FWD(:) = -1 DO I = 1, NZ_RHS ISTEP = abs( STEP(IRHS_SPARSE(I)) ) IF ( Pruned_Sons_FWD(ISTEP) .eq. -1) THEN Lnodes_FWD = Lnodes_FWD +1 Pruned_Sons_FWD(ISTEP) = 0 ENDIF ENDDO ELSE IF (Lnodes_FWD.GT.0) THEN Lnodes_FWD_loc = 0 Pruned_Sons_FWD(:) = -1 DO I = 1, NZ_RHS ISTEP = abs( STEP(IRHS_SPARSE(I)) ) INODE_PRINC = Step2node( ISTEP ) IF ( Pruned_Sons_FWD(ISTEP) .eq. -1) THEN Lnodes_FWD_loc = Lnodes_FWD_loc +1 nodes_FWD(Lnodes_FWD_loc) = INODE_PRINC Pruned_Sons_FWD(ISTEP) = 0 ENDIF ENDDO ENDIF ELSE IF ( AM1 ) THEN IF (.NOT.fill) THEN Lnodes_FWD = 0 Pruned_Sons_FWD(:) = -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_FWD(ISTEP) .eq. -1) THEN Lnodes_FWD = Lnodes_FWD +1 Pruned_Sons_FWD(ISTEP) = 0 ENDIF ENDDO ELSE IF (Lnodes_FWD.GT.0) THEN Lnodes_FWD_loc = 0 Pruned_Sons_FWD = -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_FWD(ISTEP) .eq. -1) THEN Lnodes_FWD_loc = Lnodes_FWD_loc +1 nodes_FWD(Lnodes_FWD_loc) = INODE_PRINC Pruned_Sons_FWD(ISTEP) = 0 ENDIF ENDDO ENDIF ENDIF ENDIF IF (AM1) THEN IF (.NOT.fill) THEN Lnodes_BWD = 0 Pruned_Sons_BWD(:) = -1 DO II = 1, NZ_RHS I = IRHS_SPARSE(II) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) ISTEP = abs(STEP(I)) IF ( Pruned_Sons_BWD(ISTEP) .eq. -1) THEN Lnodes_BWD = Lnodes_BWD +1 Pruned_Sons_BWD(ISTEP) = 0 ENDIF ENDDO ELSE IF (Lnodes_BWD.GT.0) THEN Lnodes_BWD_loc = 0 Pruned_Sons_BWD(:) = -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_BWD(ISTEP) .eq. -1) THEN Lnodes_BWD_loc = Lnodes_BWD_loc +1 nodes_BWD(Lnodes_BWD_loc) = INODE_PRINC Pruned_Sons_BWD(ISTEP) = 0 ENDIF ENDDO ENDIF ENDIF #if defined(AVOID_MPI_IN_PLACE) GOTO 600 500 CONTINUE Lnodes_FWD = -1 Lnodes_BWD = -1 600 CONTINUE #endif #if defined(AVOID_MPI_IN_PLACE) IF ( allocated(TMP_INT_ARRAY)) DEALLOCATE(TMP_INT_ARRAY) #endif RETURN END SUBROUTINE CMUMPS_NODES_FWD_BWD_SIZE_FILL SUBROUTINE CMUMPS_BUILD_GLOB2LOC_NODES_ES ( & NSLAVES, N, MYID_NODES, & PTRIST, DAD, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & Lnodes_FWD, Lnodes_BWD, & nodes_FWD, nodes_BWD, & GLOB2LOC_RHS, GLOB2LOC_SOL, & GLOB2LOC_SOL_ALLOC, & MTYPE, & NBENT_RHSINTR, & NB_FS_IN_RHSINTR_FWD, NB_FS_IN_RHSINTR_TOT & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER, intent(in) :: Lnodes_FWD, Lnodes_BWD INTEGER, intent(in) :: nodes_FWD(max(1,Lnodes_FWD)), & nodes_BWD(max(1,Lnodes_BWD)) INTEGER, intent(inout) :: DAD(KEEP(28)) INTEGER, intent(in) :: IW(LIW), STEP(N) INTEGER, intent(in) :: MTYPE LOGICAL, intent(in) :: GLOB2LOC_SOL_ALLOC INTEGER, intent(out):: GLOB2LOC_RHS(N), GLOB2LOC_SOL(N) INTEGER, intent(out):: NBENT_RHSINTR INTEGER, intent(out):: NB_FS_IN_RHSINTR_FWD, NB_FS_IN_RHSINTR_TOT INTEGER I INTEGER ISTEP, OLDISTEP INTEGER NPIV INTEGER IPOS, LIELL INTEGER JJ, J1, JCOL, ABSJCOL INTEGER IPOSINRHSINTR_RHS, IPOSINRHSINTR_SOL INTEGER NBENT_RHSINTR_ROW, NBENT_RHSINTR_COL LOGICAL GO_UP INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE GLOB2LOC_RHS = 0 IF (GLOB2LOC_SOL_ALLOC) GLOB2LOC_SOL = 0 IPOSINRHSINTR_RHS = 0 IPOSINRHSINTR_SOL = 0 DO I = 1, Lnodes_FWD ISTEP = STEP(nodes_FWD(I)) GO_UP = .TRUE. DO WHILE(GO_UP) IF (DAD(ISTEP) .GE. 0) THEN OLDISTEP=ISTEP IF (DAD(ISTEP).EQ.0) THEN GO_UP=.FALSE. ELSE GO_UP=.TRUE. ISTEP = STEP(DAD(ISTEP)) ENDIF DAD(OLDISTEP)=-DAD(OLDISTEP)-1 ELSE GO_UP = .FALSE. ENDIF END DO END DO DO ISTEP=1, KEEP(28) IF (DAD(ISTEP) .LT. 0) THEN DAD(ISTEP) = -DAD(ISTEP) - 1 IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF(NPIV.GT.0) THEN DO JJ = J1, J1+NPIV-1 GLOB2LOC_RHS(IW(JJ)) & = IPOSINRHSINTR_RHS + JJ - J1 + 1 ENDDO IPOSINRHSINTR_RHS = IPOSINRHSINTR_RHS + NPIV IF (GLOB2LOC_SOL_ALLOC) THEN DO JJ = JCOL, JCOL+NPIV-1 GLOB2LOC_SOL(IW(JJ)) & = - ( IPOSINRHSINTR_SOL + JJ - JCOL + 1 ) ENDDO IPOSINRHSINTR_SOL = IPOSINRHSINTR_SOL + NPIV ENDIF END IF END IF ENDIF END DO NB_FS_IN_RHSINTR_FWD = IPOSINRHSINTR_RHS IF(GLOB2LOC_SOL_ALLOC) THEN DO I=1, Lnodes_BWD ISTEP = STEP(nodes_BWD(I)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF ABSJCOL = abs(IW(JCOL)) IF(NPIV.GT.0) THEN IF(GLOB2LOC_SOL(ABSJCOL).EQ.0) THEN DO JJ = JCOL, JCOL+NPIV-1 GLOB2LOC_SOL(abs(IW(JJ))) = & IPOSINRHSINTR_SOL+JJ-JCOL+1 END DO IPOSINRHSINTR_SOL = IPOSINRHSINTR_SOL + NPIV ELSE IF (GLOB2LOC_SOL(ABSJCOL).LT.0) THEN DO JJ = JCOL, JCOL+NPIV-1 GLOB2LOC_SOL(abs(IW(JJ)))= & -(GLOB2LOC_SOL(abs(IW(JJ)))) END DO ELSE GO_UP = .FALSE. END IF END IF END IF IF(DAD(ISTEP).NE.0) THEN ISTEP = STEP(DAD(ISTEP)) ELSE GO_UP = .FALSE. END IF END DO END DO END IF NB_FS_IN_RHSINTR_TOT = IPOSINRHSINTR_SOL IF (NSLAVES.NE.1) THEN DO I = 1, Lnodes_FWD ISTEP = STEP(nodes_FWD(I)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = NPIV, LIELL-1-KEEP(253) IF(GLOB2LOC_RHS(IW(J1+JJ)).EQ.0) THEN IPOSINRHSINTR_RHS = IPOSINRHSINTR_RHS + 1 GLOB2LOC_RHS(IW(JJ+J1)) = -IPOSINRHSINTR_RHS END IF END DO END IF IF(DAD(ISTEP).GT.0) THEN OLDISTEP=ISTEP ISTEP = STEP(DAD(ISTEP)) DAD(OLDISTEP)=-DAD(OLDISTEP) ELSE GO_UP = .FALSE. END IF END DO END DO DAD=ABS(DAD) IF(GLOB2LOC_SOL_ALLOC) THEN DO I=1, Lnodes_BWD ISTEP = STEP(nodes_BWD(I)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = NPIV, LIELL-1-KEEP(253) IF(GLOB2LOC_SOL(IW(JCOL+JJ)).EQ.0) THEN IPOSINRHSINTR_SOL = IPOSINRHSINTR_SOL + 1 GLOB2LOC_SOL(IW(JCOL+JJ)) = -IPOSINRHSINTR_SOL END IF END DO END IF IF(DAD(ISTEP).GT.0) THEN OLDISTEP=ISTEP ISTEP = STEP(DAD(ISTEP)) DAD(OLDISTEP)=-DAD(OLDISTEP) ELSE GO_UP = .FALSE. END IF END DO END DO DAD=ABS(DAD) END IF ENDIF NBENT_RHSINTR_ROW = IPOSINRHSINTR_RHS NBENT_RHSINTR_COL = IPOSINRHSINTR_SOL NBENT_RHSINTR = max(NBENT_RHSINTR_ROW,NBENT_RHSINTR_COL) RETURN END SUBROUTINE CMUMPS_BUILD_GLOB2LOC_NODES_ES MUMPS_5.8.1/src/cfac_determinant.F0000664000175000017500000002003715042446440016627 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_UPDATEDETER(PIV, DETER, NEXP) IMPLICIT NONE COMPLEX, intent(in) :: PIV COMPLEX, intent(inout) :: DETER INTEGER, intent(inout) :: NEXP REAL R_PART, C_PART INTEGER NEXP_LOC DETER=DETER*PIV R_PART=real(DETER) C_PART=aimag(DETER) NEXP_LOC = exponent(abs(R_PART)+abs(C_PART)) NEXP = NEXP + NEXP_LOC R_PART=scale(R_PART, -NEXP_LOC) C_PART=scale(C_PART, -NEXP_LOC) DETER=cmplx(R_PART,C_PART,kind=kind(DETER)) RETURN END SUBROUTINE CMUMPS_UPDATEDETER SUBROUTINE CMUMPS_UPDATEDETER_SCALING(PIV, DETER, NEXP) IMPLICIT NONE REAL, intent(in) :: PIV REAL, intent(inout) :: DETER INTEGER, intent(inout) :: NEXP DETER=DETER*fraction(PIV) NEXP=NEXP+exponent(PIV)+exponent(DETER) DETER=fraction(DETER) RETURN END SUBROUTINE CMUMPS_UPDATEDETER_SCALING SUBROUTINE CMUMPS_GETDETER2D(BLOCK_SIZE,IPIV, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, & DETER,NEXP,SYM) IMPLICIT NONE INTEGER, intent (in) :: SYM INTEGER, intent (inout) :: NEXP COMPLEX, intent (inout) :: DETER INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, & LOCAL_M, LOCAL_N, N INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) COMPLEX, intent(in) :: A(*) INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, & ROW_PROC,COL_PROC, K DI = LOCAL_M + 1 NBLOCK = ( N - 1 ) / BLOCK_SIZE DO IBLOCK = 0, NBLOCK ROW_PROC = mod( IBLOCK, NPROW ) IF ( MYROW.EQ.ROW_PROC ) THEN COL_PROC = mod( IBLOCK, NPCOL ) IF ( MYCOL.EQ.COL_PROC ) THEN ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE I = ILOC + JLOC * LOCAL_M + 1 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M & + 1 K=1 DO WHILE ( I .LT. IMX ) CALL CMUMPS_UPDATEDETER(A(I),DETER,NEXP) IF (SYM.EQ.1) THEN CALL CMUMPS_UPDATEDETER(A(I),DETER,NEXP) ENDIF IF (SYM.NE.1) THEN IF (IPIV(ILOC+K) .NE. IBLOCK*BLOCK_SIZE+K) THEN DETER = -DETER ENDIF ENDIF K = K + 1 I = I + DI END DO END IF END IF END DO RETURN END SUBROUTINE CMUMPS_GETDETER2D SUBROUTINE CMUMPS_DETER_REDUCTION( & COMM, DETER_IN, NEXP_IN, & DETER_OUT, NEXP_OUT, NPROCS) IMPLICIT NONE INTEGER, intent(in) :: COMM, NPROCS COMPLEX, intent(in) :: DETER_IN INTEGER,intent(in) :: NEXP_IN COMPLEX,intent(out):: DETER_OUT INTEGER,intent(out):: NEXP_OUT INTEGER :: IERR_MPI EXTERNAL CMUMPS_DETERREDUCE_FUNC INTEGER TWO_SCALARS_TYPE, DETERREDUCE_OP COMPLEX :: INV(2) COMPLEX :: OUTV(2) INCLUDE 'mpif.h' IF (NPROCS .EQ. 1) THEN DETER_OUT = DETER_IN NEXP_OUT = NEXP_IN RETURN ENDIF CALL MPI_TYPE_CONTIGUOUS(2, MPI_COMPLEX, & TWO_SCALARS_TYPE, & IERR_MPI) CALL MPI_TYPE_COMMIT(TWO_SCALARS_TYPE, IERR_MPI) CALL MPI_OP_CREATE(CMUMPS_DETERREDUCE_FUNC, & .TRUE., & DETERREDUCE_OP, & IERR_MPI) INV(1)=DETER_IN INV(2)=cmplx(NEXP_IN,kind=kind(INV)) CALL MPI_ALLREDUCE( INV, OUTV, 1, TWO_SCALARS_TYPE, & DETERREDUCE_OP, COMM, IERR_MPI) CALL MPI_OP_FREE(DETERREDUCE_OP, IERR_MPI) CALL MPI_TYPE_FREE(TWO_SCALARS_TYPE, IERR_MPI) DETER_OUT = OUTV(1) NEXP_OUT = int(OUTV(2)) RETURN END SUBROUTINE CMUMPS_DETER_REDUCTION SUBROUTINE CMUMPS_DETERREDUCE_FUNC(INV, INOUTV, NEL, DATATYPE) IMPLICIT NONE #if defined(WORKAROUNDINTELILP64MPI2INTEGER) || defined(WORKAROUNDILP64MPICUSTOMREDUCE) INTEGER(4), INTENT(IN) :: NEL, DATATYPE #else INTEGER, INTENT(IN) :: NEL, DATATYPE #endif COMPLEX, INTENT(IN) :: INV ( 2 * NEL ) COMPLEX, INTENT(INOUT) :: INOUTV ( 2 * NEL ) INTEGER I, TMPEXPIN, TMPEXPINOUT DO I = 1, NEL TMPEXPIN = int(INV (I*2)) TMPEXPINOUT = int(INOUTV(I*2)) CALL CMUMPS_UPDATEDETER(INV(I*2-1), & INOUTV(I*2-1), & TMPEXPINOUT) TMPEXPINOUT = TMPEXPINOUT + TMPEXPIN INOUTV(I*2) = cmplx(TMPEXPINOUT,kind=kind(INOUTV)) ENDDO RETURN END SUBROUTINE CMUMPS_DETERREDUCE_FUNC SUBROUTINE CMUMPS_DETER_SQUARE(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP COMPLEX, intent (inout) :: DETER DETER=DETER*DETER NEXP=NEXP+NEXP RETURN END SUBROUTINE CMUMPS_DETER_SQUARE SUBROUTINE CMUMPS_DETER_SCALING_INVERSE(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP REAL, intent (inout) :: DETER DETER=1.0E0/DETER NEXP=-NEXP RETURN END SUBROUTINE CMUMPS_DETER_SCALING_INVERSE SUBROUTINE CMUMPS_DETER_SIGN_PERM(DETER, N, PERM) IMPLICIT NONE COMPLEX, intent(inout) :: DETER INTEGER, intent(in) :: N INTEGER, intent(inout) :: PERM(N) INTEGER I, J, K K = 0 DO I = 1, N IF (PERM(I) .LT. 0) THEN PERM(I)=-PERM(I) ELSE J = PERM(I) DO WHILE (J.NE.I) PERM(J)=-PERM(J) K = K + 1 J = -PERM(J) ENDDO ENDIF ENDDO IF (mod(K,2).EQ.1) THEN DETER = -DETER ENDIF RETURN END SUBROUTINE CMUMPS_DETER_SIGN_PERM SUBROUTINE CMUMPS_PAR_ROOT_MINMAX_PIV_UPD ( & BLOCK_SIZE,IPIV, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, & DKEEP, KEEP, SYM) USE CMUMPS_FAC_FRONT_AUX_M, & ONLY : CMUMPS_UPDATE_MINMAX_PIVOT IMPLICIT NONE INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, & LOCAL_M, LOCAL_N, N, SYM INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) COMPLEX, intent(in) :: A(*) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER, INTENT(IN) :: KEEP(500) INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, & ROW_PROC,COL_PROC, K REAL :: ABSPIVOT DI = LOCAL_M + 1 NBLOCK = ( N - 1 ) / BLOCK_SIZE DO IBLOCK = 0, NBLOCK ROW_PROC = mod( IBLOCK, NPROW ) IF ( MYROW.EQ.ROW_PROC ) THEN COL_PROC = mod( IBLOCK, NPCOL ) IF ( MYCOL.EQ.COL_PROC ) THEN ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE I = ILOC + JLOC * LOCAL_M + 1 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M & + 1 K=1 DO WHILE ( I .LT. IMX ) IF (SYM.NE.1) THEN ABSPIVOT = abs(A(I)) ELSE ABSPIVOT = abs(A(I)*A(I)) ENDIF CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( ABSPIVOT, & DKEEP, KEEP, .FALSE.) K = K + 1 I = I + DI END DO END IF END IF END DO RETURN END SUBROUTINE CMUMPS_PAR_ROOT_MINMAX_PIV_UPD MUMPS_5.8.1/src/cfac_front_LU_type1.F0000664000175000017500000012356715042446440017203 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC1_LU_M CONTAINS SUBROUTINE CMUMPS_FAC1_LU( & N, INODE, IW, LIW, A, & LA, & IOLDPS, POSELT, IFLAG, IERROR, UU, & NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, & IWPOS & , LRGROUPS & , PERM & ) USE CMUMPS_FAC_FRONT_AUX_M USE CMUMPS_OOC USE CMUMPS_FAC_LR USE CMUMPS_LR_TYPE USE MUMPS_LR_STATS USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_DATA_M USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T #if ! defined(BLR_NOOPENMP) #endif !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, INTENT(INOUT) :: NOFFW, NPVW, NBTINYW INTEGER, INTENT(INOUT) :: DET_EXPW, DET_SIGNW COMPLEX, INTENT(INOUT) :: DET_MANTW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER MYID, SLAVEF, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ), STEP(N) REAL UU, SEUIL LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)), PERM(N) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER LAST_ROW, LAST_COL, FIRST_COL LOGICAL CALL_LTRSM, CALL_UTRSM REAL UUTEMP LOGICAL STATICMODE REAL SEUIL_LOC INTEGER PIVOT_OPTION INTEGER LRTRSM_OPTION INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U INTEGER TYPEF_LOC TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PARPIV_T1 INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER :: K473_LOC INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER INFO_TMP(2), MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM, NELIM_LOC INTEGER :: IROW_L, NVSCHUR INTEGER, POINTER, DIMENSION(:) :: PTDummy INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_U, BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL COMPLEX, POINTER, DIMENSION(:) :: DIAG INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, LorU, I, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG CHARACTER(len=1) :: DIR COMPLEX, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) COMPLEX, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok,J INTEGER :: OMP_NUM INTEGER :: IP INTEGER(8) :: UPOS, LPOS INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_U, NEXT_BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC COMPLEX :: ZERO PARAMETER (ZERO=(0.0E0,0.0E0)) LOGICAL :: SWAP_OCCURRED INCLUDE 'mumps_headers.h' FIRST_BLOCK = -99999 LAST_BLOCK = -99999 IP=0 IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF SWAP_OCCURRED = .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 PIVOT_OPTION = KEEP(468) LRTRSM_OPTION = KEEP(475) LAFAC = -9999_8 XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) NASS = abs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED = .FALSE. COMPRESS_PANEL = .FALSE. COMPRESS_CB = .FALSE. NULLIFY(PTDummy) NULLIFY(BEGS_BLR) NULLIFY(CB_LRB) NULLIFY(ACC_LUA) NULLIFY(BLR_U) NULLIFY(BLR_L) NULLIFY(BEGS_BLR_TMP) NULLIFY(BLR_PANEL) NULLIFY(DIAG) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN K473_LOC = 1 ELSE K473_LOC = KEEP(473) ENDIF K473_LOC = KEEP(473) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL CMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS, KEEP, & LR_ACTIVATED, PARPIV_T1) IF (UUTEMP.EQ.ZERO) THEN PIVOT_OPTION=0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF IF (LR_ACTIVATED) THEN IF (LRTRSM_OPTION.EQ.3) THEN PIVOT_OPTION = MIN(PIVOT_OPTION,1) ELSEIF (LRTRSM_OPTION.EQ.2) THEN PIVOT_OPTION = MIN(PIVOT_OPTION, 2) ENDIF ENDIF IF (PIVOT_OPTION.LE.1) THEN PARPIV_T1 = 0 ENDIF CALL CMUMPS_SET_INNERBLOCKSIZE( NBKJIB_ORIG, NASS, KEEP) IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = IOLDPS+6+XSIZE+NASS CALL CMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF ( OOC_EFFECTIVE_ON_FRONT ) THEN LNextPiv2beWritten = 1 UNextPiv2beWritten = 1 PP_FIRST2SWAP_L = LNextPiv2beWritten PP_FIRST2SWAP_U = UNextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%LastPanelWritten_U = 0 PP_LastPIVRPTRFilled_L = 0 PP_LastPIVRPTRFilled_U = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 1 MonBloc%NROW = NFRONT MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -88877 NULLIFY(MonBloc%INDICES) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(405) .EQ. 1) THEN !$OMP ATOMIC UPDATE CNT_NODES = CNT_NODES + 1 !$OMP END ATOMIC ELSE CNT_NODES = CNT_NODES + 1 ENDIF ELSE IF (KEEP(486).NE.0) THEN ENDIF OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472), & NFRONT, KEEP(1)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 490 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL CMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .FALSE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF IF (COMPRESS_CB) THEN IF (NPARTSCB.GT.0) THEN allocate(CB_LRB(NPARTSCB,NPARTSCB),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSCB*NPARTSCB GOTO 490 ENDIF CALL CMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF ENDIF DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = BEGS_BLR(CURRENT_BLR+1)-1 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(480).GE.5) THEN IF (CURRENT_BLR.EQ.1) THEN ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR) THEN BLR_U(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) BLR_L(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ELSE IF (NB_BLR.GT.CURRENT_BLR) THEN CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF IF (CURRENT_BLR.LT.NPARTSASS) THEN ALLOCATE(NEXT_BLR_U(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF ALLOCATE(NEXT_BLR_L(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR+1) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR+1, NEXT_BLR_U, 0) CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR+1, NEXT_BLR_L, 0) ENDIF ENDIF ELSE ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE CALL CMUMPS_FAC_I(NFRONT,NASS,NFRONT, & IBEG_BLOCK,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, & DKEEP(1), PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1 & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF ELSE IF ( INOPV.LE.0 ) THEN INOPV = 0 IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL CMUMPS_FAC_MQ(IBEG_BLOCK, IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED & ) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) THEN GOTO 50 ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_U, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL CMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, & NPIV, NFRONT, IEND_BLR, LAST_COL, & A, LA, POSELT, & -66666, & .TRUE., .FALSE., .TRUE., & .FALSE., & LR_ACTIVATED & ) ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN IF (PIVOT_OPTION.EQ.4) THEN LAST_ROW = NFRONT ELSE LAST_ROW = NASS ENDIF IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSE LAST_COL = NASS ENDIF IF (IEND_BLR.LT.LAST_ROW) THEN CALL CMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, LAST_ROW, LAST_COL, & A, LA, POSELT, IEND_BLR, .TRUE., (PIVOT_OPTION.LT.2), & .TRUE., .FALSE., & LR_ACTIVATED) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_U(J)%M=0 BLR_U(J)%N=0 BLR_U(J)%K=0 BLR_U(J)%ISLR=.FALSE. NULLIFY(BLR_U(J)%Q) NULLIFY(BLR_U(J)%R) ENDDO CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) NULLIFY(BLR_L) NULLIFY(BLR_U) IF (KEEP(480).GE.2 .AND. IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = 1 ELSE FIRST_BLOCK = NPARTSASS-CURRENT_BLR ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL CMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) IF (IFLAG.LT.0) GOTO 900 CALL CMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) 900 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF ENDIF GOTO 100 ENDIF IF (PIVOT_OPTION.GE.3) THEN FIRST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN FIRST_COL = NASS ELSE FIRST_COL = IEND_BLR ENDIF IF (LRTRSM_OPTION.EQ.3) THEN LAST_COL = IEND_BLR ELSEIF (LRTRSM_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = NFRONT ENDIF CALL_LTRSM = (LRTRSM_OPTION.EQ.0) CALL_UTRSM = (LAST_COL-FIRST_COL.GT.0) IF ((IEND_BLR.LT.NFRONT) .AND. & (CALL_LTRSM.OR.CALL_UTRSM)) THEN CALL CMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NFRONT, & LAST_COL, & A, LA, POSELT, & FIRST_COL, CALL_LTRSM, & CALL_UTRSM, .FALSE., & .FALSE., & LR_ACTIVATED) ENDIF #if ! defined(BLR_NOOPENMP) #endif #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(UPOS,LPOS) FIRSTPRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), & KEEP(458), K473_LOC, & BLR_U, CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), & KEEP(458), K473_LOC, BLR_L, & CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER !$OMP MASTER #endif IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (LRTRSM_OPTION.GT.0) THEN CALL CMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NB_BLR, 1, 0, 0, .FALSE.) IF (PIVOT_OPTION.LT.3.AND.LRTRSM_OPTION.GE.2) THEN IF (PIVOT_OPTION.LE.1.AND.LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF CALL CMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, NB_BLR, BLR_U, & CURRENT_BLR, FIRST_BLOCK, NB_BLR, & 1, 0, 1, .FALSE.) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif CALL CMUMPS_BLR_UPD_NELIM_VAR_U( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_U, NB_BLR, & FIRST_BLOCK, IBEG_BLR, NPIV, NELIM) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(480).GE.2) THEN UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) LPOS = POSELT+int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) CALL CMUMPS_BLR_UPD_NELIM_VAR_L(A, LA, UPOS, A, LA, & LPOS, IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & CURRENT_BLR+1, NELIM, 'N') IF (IFLAG.LT.0) GOTO 444 IF (IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = 1 ELSE FIRST_BLOCK = NPARTSASS-CURRENT_BLR ENDIF CALL CMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) IF (IFLAG.LT.0) GOTO 442 CALL CMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) 442 CONTINUE ENDIF 444 CONTINUE ELSE CALL CMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & BLR_U, NB_BLR, & NELIM,.FALSE., 0, & 1, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(486).NE.2) THEN LAST_BLOCK = NB_BLR ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF IF (LRTRSM_OPTION.GT.0) THEN FIRST_BLOCK = CURRENT_BLR+1 CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_L, CURRENT_BLR, 'V', 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) #if ! defined(BLR_NOOPENMP) #endif ENDIF IF (LRTRSM_OPTION.GE.2) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_U, CURRENT_BLR, 'H', 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL(BLR_U, NB_BLR-CURRENT_BLR, KEEP8, & KEEP(34)) CALL DEALLOC_BLR_PANEL(BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & KEEP(34)) DEALLOCATE(BLR_U,BLR_L) ENDIF ENDIF NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN IF (PIVOT_OPTION.LT.4) THEN TYPEF_LOC = TYPEF_U ELSE TYPEF_LOC = TYPEF_BOTH_LU ENDIF MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_LOC, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO IP=1,NB_BLR+1 BEGS_BLR_TMP(IP) = BEGS_BLR_STATIC(IP) ENDDO ENDIF ENDIF MEM_TOT = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP& PRIVATE(IP, LorU, DIR, NELIM_LOC, BLR_PANEL) #endif IF ( & (KEEP(486).EQ.2) & ) THEN #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*(2*DIAGSIZ_STA-DIAGSIZ_DYN) MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA IF (I.LE.DIAGSIZ_DYN) THEN DIAG(DPOS:DPOS+DIAGSIZ_STA-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_STA-1,8)) DPOS = DPOS + DIAGSIZ_STA ELSE DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN ENDIF POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL CMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG, KEEP(34)) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO !$OMP SINGLE #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM_TOT,8), & (KEEP(405).NE.0), KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 447 IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN DO IP=1,NPARTSASS NELIM_LOC = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) DO LorU=0,1 CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8, & KEEP(34)) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (LorU.EQ.0) THEN DIR = 'V' ELSE DIR = 'H' ENDIF CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(458), K473_LOC, & BLR_PANEL, IP, & DIR, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM_LOC, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif 445 CONTINUE ENDIF 447 CONTINUE ENDIF IF (IFLAG .LT. 0) GOTO 450 IF (KEEP(480) .GE. 2) THEN #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif CALL CMUMPS_BLR_UPD_CB_LEFT(A, LA, POSELT, NFRONT, & BEGS_BLR_STATIC, BEGS_BLR_STATIC, & NPARTSCB, NPARTSCB, NPARTSASS, NASS, & IW(IOLDPS+XXF), & 1, .FALSE., IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & ACC_LUA, KEEP(480),KEEP(479),KEEP(478),KEEP(476), & KEEP(484), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & .FALSE., & CB_LRB, KEEP8) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF IF (IFLAG.LT.0) GOTO 450 #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF (COMPRESS_CB & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL CMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (COMPRESS_CB) THEN IEND_BLR = BEGS_BLR(CURRENT_BLR+2) IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) ENDIF ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (COMPRESS_CB) THEN CALL CMUMPS_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR, NPARTSCB, NPARTSCB, NPARTSASS, & NFRONT-NASS, NFRONT-NASS, INODE, & IW(IOLDPS+XXF), 0, 1, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & -9999, -9999, -9999, KEEP(1), & NELIM=NELIM) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF 450 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF ( & ( & (KEEP(486).EQ.2) & ) & .AND.UU.GT.0 .AND. SWAP_OCCURRED & ) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 0, NASS-NPIV) DO IP=1,NPARTSASS DO LorU=0,1 CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NB_BLR-IP & ) ENDDO ENDDO CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NPIV, 0, 1) ENDIF IF ( (PIVOT_OPTION.LT.4) .AND. (.NOT.LR_ACTIVATED) ) THEN CALL CMUMPS_FAC_FR_UPDATE_CBROWS( INODE, & NFRONT, NASS, (PIVOT_OPTION.LT.3), A, LA, LAFAC, POSELT, & IW, LIW, IOLDPS, MonBloc, MYID, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR ) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 0, 1) ENDIF ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF CALL CMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 490 CONTINUE 500 CONTINUE 600 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(WORK)) deallocate(WORK) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) deallocate(TAU) IF (allocated(JPVT)) deallocate(JPVT) IF (allocated(BLOCK)) deallocate(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) ENDDO ENDIF DEALLOCATE(ACC_LUA) NULLIFY(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL CMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 2, & KEEP8, KEEP(34)) ENDIF ENDIF IF ( LR_ACTIVATED .AND. KEEP(486).EQ. 2 .AND. & KEEP(251) .EQ. 2) THEN CALL CMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8, KEEP(34)) ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND. .NOT.COMPRESS_CB) THEN CALL CMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34), MTK405=KEEP(405)) ENDIF ENDIF NPVW = NPVW + IW(IOLDPS+1+XSIZE) RETURN END SUBROUTINE CMUMPS_FAC1_LU END MODULE CMUMPS_FAC1_LU_M SUBROUTINE CMUMPS_FAC1_LU_I( N, INODE, IW, LIW, A, & LA, & IOLDPS, POSELT, IFLAG, IERROR, UU, & NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, & IWPOS & , LRGROUPS & , PERM & ) USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T USE CMUMPS_FAC1_LU_M, ONLY: CMUMPS_FAC1_LU IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, INTENT(INOUT) :: NOFFW, NPVW, NBTINYW INTEGER, INTENT(INOUT) :: DET_EXPW, DET_SIGNW COMPLEX, INTENT(INOUT) :: DET_MANTW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER MYID, SLAVEF, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ), STEP(N) REAL UU, SEUIL LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)), PERM(N) CALL CMUMPS_FAC1_LU( N, INODE, IW, LIW, A, & LA, & IOLDPS, POSELT, IFLAG, IERROR, UU, & NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, & IWPOS & , LRGROUPS & , PERM & ) RETURN END SUBROUTINE CMUMPS_FAC1_LU_I MUMPS_5.8.1/src/zstatic_ptr_m.F0000664000175000017500000000211715042446441016223 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_STATIC_PTR_M PUBLIC :: ZMUMPS_TMP_PTR, ZMUMPS_GET_TMP_PTR COMPLEX(kind=8), DIMENSION(:), POINTER, SAVE :: ZMUMPS_TMP_PTR CONTAINS SUBROUTINE ZMUMPS_SET_STATIC_PTR(ARRAY) COMPLEX(kind=8), DIMENSION(:), TARGET :: ARRAY ZMUMPS_TMP_PTR => ARRAY RETURN END SUBROUTINE ZMUMPS_SET_STATIC_PTR SUBROUTINE ZMUMPS_GET_TMP_PTR(PTR) #if defined(MUMPS_NOF2003) COMPLEX(kind=8), DIMENSION(:), POINTER :: PTR #else COMPLEX(kind=8), DIMENSION(:), POINTER, INTENT(OUT) :: PTR #endif PTR => ZMUMPS_TMP_PTR RETURN END SUBROUTINE ZMUMPS_GET_TMP_PTR END MODULE ZMUMPS_STATIC_PTR_M MUMPS_5.8.1/src/zmumps_ooc_buffer.F0000664000175000017500000004333415042446441017073 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_OOC_BUFFER USE MUMPS_OOC_COMMON IMPLICIT NONE PUBLIC INTEGER FIRST_HBUF,SECOND_HBUF PARAMETER (FIRST_HBUF=0, SECOND_HBUF=1) INTEGER,SAVE :: OOC_FCT_TYPE_LOC COMPLEX(kind=8), DIMENSION(:),ALLOCATABLE :: BUF_IO LOGICAL,SAVE :: PANEL_FLAG INTEGER,SAVE :: EARLIEST_WRITE_MIN_SIZE INTEGER(8),SAVE,DIMENSION(:), ALLOCATABLE :: & I_SHIFT_FIRST_HBUF, I_SHIFT_SECOND_HBUF, & I_SHIFT_CUR_HBUF, I_REL_POS_CUR_HBUF INTEGER, SAVE, DIMENSION(:), ALLOCATABLE :: & LAST_IOREQUEST, CUR_HBUF INTEGER, DIMENSION(:),ALLOCATABLE :: I_CUR_HBUF_NEXTPOS INTEGER,SAVE :: I_CUR_HBUF_FSTPOS, & I_SUB_HBUF_FSTPOS INTEGER(8) :: BufferEmpty PARAMETER (BufferEmpty=-1_8) INTEGER(8), DIMENSION(:),ALLOCATABLE :: NextAddVirtBuffer INTEGER(8), DIMENSION(:),ALLOCATABLE :: FIRST_VADDR_IN_BUF CONTAINS SUBROUTINE ZMUMPS_OOC_NEXT_HBUF(TYPEF_ARG) IMPLICIT NONE INTEGER TYPEF_ARG SELECT CASE(CUR_HBUF(TYPEF_ARG)) CASE (FIRST_HBUF) CUR_HBUF(TYPEF_ARG) = SECOND_HBUF I_SHIFT_CUR_HBUF(TYPEF_ARG) = & I_SHIFT_SECOND_HBUF(TYPEF_ARG) CASE (SECOND_HBUF) CUR_HBUF(TYPEF_ARG) = FIRST_HBUF I_SHIFT_CUR_HBUF(TYPEF_ARG) = & I_SHIFT_FIRST_HBUF(TYPEF_ARG) END SELECT IF(.NOT.PANEL_FLAG)THEN I_SUB_HBUF_FSTPOS =I_CUR_HBUF_FSTPOS I_CUR_HBUF_FSTPOS =I_CUR_HBUF_NEXTPOS(TYPEF_ARG) ENDIF I_REL_POS_CUR_HBUF(TYPEF_ARG) = 1_8 RETURN END SUBROUTINE ZMUMPS_OOC_NEXT_HBUF SUBROUTINE ZMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_ARG,IERR) IMPLICIT NONE INTEGER TYPEF_ARG INTEGER NEW_IOREQUEST INTEGER IERR IERR=0 CALL ZMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF_ARG,NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL MUMPS_WAIT_REQUEST(LAST_IOREQUEST(TYPEF_ARG),IERR) IF(IERR.LT.0)THEN IF (ICNTL1>0) & WRITE(ICNTL1,*) MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF LAST_IOREQUEST(TYPEF_ARG) = NEW_IOREQUEST CALL ZMUMPS_OOC_NEXT_HBUF(TYPEF_ARG) IF(PANEL_FLAG)THEN NextAddVirtBuffer(TYPEF_ARG)=BufferEmpty ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_DO_IO_AND_CHBUF SUBROUTINE ZMUMPS_OOC_BUF_CLEAN_PENDING(IERR) IMPLICIT NONE INTEGER, intent(out) :: IERR INTEGER TYPEF_LAST INTEGER TYPEF_LOC IERR = 0 TYPEF_LAST = OOC_NB_FILE_TYPE DO TYPEF_LOC = 1, TYPEF_LAST IERR=0 CALL ZMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL ZMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_OOC_BUF_CLEAN_PENDING SUBROUTINE ZMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF_ARG,IOREQUEST, & IERR) IMPLICIT NONE INTEGER IOREQUEST,IERR INTEGER TYPEF_ARG INTEGER FIRST_INODE INTEGER(8) :: FROM_BUFIO_POS, SIZE INTEGER TYPE INTEGER ADDR_INT1,ADDR_INT2 INTEGER(8) TMP_VADDR INTEGER SIZE_INT1,SIZE_INT2 IERR=0 IF (I_REL_POS_CUR_HBUF(TYPEF_ARG) == 1_8) THEN IOREQUEST=-1 RETURN END IF IF(PANEL_FLAG)THEN TYPE=TYPEF_ARG-1 FIRST_INODE=-9999 TMP_VADDR=FIRST_VADDR_IN_BUF(TYPEF_ARG) ELSE TYPE=FCT FIRST_INODE = & OOC_INODE_SEQUENCE(I_CUR_HBUF_FSTPOS,TYPEF_ARG) TMP_VADDR=OOC_VADDR(STEP_OOC(FIRST_INODE),TYPEF_ARG) ENDIF FROM_BUFIO_POS=I_SHIFT_CUR_HBUF(TYPEF_ARG)+1_8 SIZE = I_REL_POS_CUR_HBUF(TYPEF_ARG)-1_8 CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & TMP_VADDR) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & BUF_IO(FROM_BUFIO_POS),SIZE_INT1,SIZE_INT2, & FIRST_INODE,IOREQUEST, & TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1>0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_WRT_CUR_BUF2DISK SUBROUTINE ZMUMPS_INIT_OOC_BUF(I1,I2,IERR) IMPLICIT NONE INTEGER I1,I2,IERR INTEGER allocok IERR=0 PANEL_FLAG=.FALSE. IF(allocated(I_SHIFT_FIRST_HBUF))THEN DEALLOCATE(I_SHIFT_FIRST_HBUF) ENDIF IF(allocated(I_SHIFT_SECOND_HBUF))THEN DEALLOCATE(I_SHIFT_SECOND_HBUF) ENDIF IF(allocated(I_SHIFT_CUR_HBUF))THEN DEALLOCATE(I_SHIFT_CUR_HBUF) ENDIF IF(allocated(I_REL_POS_CUR_HBUF))THEN DEALLOCATE(I_REL_POS_CUR_HBUF) ENDIF IF(allocated(LAST_IOREQUEST))THEN DEALLOCATE(LAST_IOREQUEST) ENDIF IF(allocated(CUR_HBUF))THEN DEALLOCATE(CUR_HBUF) ENDIF DIM_BUF_IO = int(KEEP_OOC(100),8) ALLOCATE(I_SHIFT_FIRST_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_SHIFT_SECOND_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_SHIFT_CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_REL_POS_CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(LAST_IOREQUEST(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF OOC_FCT_TYPE_LOC=OOC_NB_FILE_TYPE ALLOCATE(BUF_IO(DIM_BUF_IO), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF I1 = -13 CALL MUMPS_SET_IERROR(DIM_BUF_IO, I2) RETURN ENDIF PANEL_FLAG=(KEEP_OOC(201).EQ.1) IF (PANEL_FLAG) THEN IERR=0 KEEP_OOC(228)=0 IF(allocated(AddVirtLibre))THEN DEALLOCATE(AddVirtLibre) ENDIF ALLOCATE(AddVirtLibre(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'ZMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF AddVirtLibre(1:OOC_NB_FILE_TYPE)=0_8 IF(allocated(NextAddVirtBuffer))THEN DEALLOCATE(NextAddVirtBuffer) ENDIF ALLOCATE(NextAddVirtBuffer(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'ZMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF NextAddVirtBuffer (1:OOC_NB_FILE_TYPE) = BufferEmpty IF(allocated(FIRST_VADDR_IN_BUF))THEN DEALLOCATE(FIRST_VADDR_IN_BUF) ENDIF ALLOCATE(FIRST_VADDR_IN_BUF(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'ZMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF CALL ZMUMPS_OOC_INIT_DB_BUFFER_PANEL() ELSE CALL ZMUMPS_OOC_INIT_DB_BUFFER() ENDIF KEEP_OOC(223)=int(HBUF_SIZE) RETURN END SUBROUTINE ZMUMPS_INIT_OOC_BUF SUBROUTINE ZMUMPS_END_OOC_BUF() IMPLICIT NONE IF(allocated(BUF_IO))THEN DEALLOCATE(BUF_IO) ENDIF IF(allocated(I_SHIFT_FIRST_HBUF))THEN DEALLOCATE(I_SHIFT_FIRST_HBUF) ENDIF IF(allocated(I_SHIFT_SECOND_HBUF))THEN DEALLOCATE(I_SHIFT_SECOND_HBUF) ENDIF IF(allocated(I_SHIFT_CUR_HBUF))THEN DEALLOCATE(I_SHIFT_CUR_HBUF) ENDIF IF(allocated(I_REL_POS_CUR_HBUF))THEN DEALLOCATE(I_REL_POS_CUR_HBUF) ENDIF IF(allocated(LAST_IOREQUEST))THEN DEALLOCATE(LAST_IOREQUEST) ENDIF IF(allocated(CUR_HBUF))THEN DEALLOCATE(CUR_HBUF) ENDIF IF(PANEL_FLAG)THEN IF(allocated(NextAddVirtBuffer))THEN DEALLOCATE(NextAddVirtBuffer) ENDIF IF(allocated(AddVirtLibre))THEN DEALLOCATE(AddVirtLibre) ENDIF IF(allocated(FIRST_VADDR_IN_BUF))THEN DEALLOCATE(FIRST_VADDR_IN_BUF) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_END_OOC_BUF SUBROUTINE ZMUMPS_OOC_INIT_DB_BUFFER() IMPLICIT NONE OOC_FCT_TYPE_LOC=1 HBUF_SIZE = DIM_BUF_IO / int(2,kind=kind(DIM_BUF_IO)) EARLIEST_WRITE_MIN_SIZE = 0 I_SHIFT_FIRST_HBUF(OOC_FCT_TYPE_LOC) = 0_8 I_SHIFT_SECOND_HBUF(OOC_FCT_TYPE_LOC) = HBUF_SIZE LAST_IOREQUEST(OOC_FCT_TYPE_LOC) = -1 I_CUR_HBUF_NEXTPOS = 1 I_CUR_HBUF_FSTPOS = 1 I_SUB_HBUF_FSTPOS = 1 CUR_HBUF(OOC_FCT_TYPE_LOC) = SECOND_HBUF CALL ZMUMPS_OOC_NEXT_HBUF(OOC_FCT_TYPE_LOC) END SUBROUTINE ZMUMPS_OOC_INIT_DB_BUFFER SUBROUTINE ZMUMPS_OOC_COPY_DATA_TO_BUFFER(BLOCK,SIZE_OF_BLOCK, & IERR) IMPLICIT NONE INTEGER(8) :: SIZE_OF_BLOCK COMPLEX(kind=8) BLOCK(SIZE_OF_BLOCK) INTEGER, intent(out) :: IERR INTEGER(8) :: I IERR=0 IF (I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + & SIZE_OF_BLOCK <= HBUF_SIZE + 1_8) THEN ELSE CALL ZMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF DO I = 1_8, SIZE_OF_BLOCK BUF_IO(I_SHIFT_CUR_HBUF(OOC_FCT_TYPE_LOC) + & I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + I - 1_8) = & BLOCK(I) END DO I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) = & I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + SIZE_OF_BLOCK RETURN END SUBROUTINE ZMUMPS_OOC_COPY_DATA_TO_BUFFER SUBROUTINE ZMUMPS_OOC_INIT_DB_BUFFER_PANEL() IMPLICIT NONE INTEGER(8) :: DIM_BUF_IO_L_OR_U INTEGER TYPEF, TYPEF_LAST INTEGER NB_DOUBLE_BUFFERS TYPEF_LAST = OOC_NB_FILE_TYPE NB_DOUBLE_BUFFERS = OOC_NB_FILE_TYPE DIM_BUF_IO_L_OR_U = DIM_BUF_IO / & int(NB_DOUBLE_BUFFERS,kind=kind(DIM_BUF_IO_L_OR_U)) IF(.NOT.STRAT_IO_ASYNC)THEN HBUF_SIZE = DIM_BUF_IO_L_OR_U ELSE HBUF_SIZE = DIM_BUF_IO_L_OR_U / 2_8 ENDIF DO TYPEF = 1, TYPEF_LAST LAST_IOREQUEST(TYPEF) = -1 IF (TYPEF == 1 ) THEN I_SHIFT_FIRST_HBUF(TYPEF) = 0_8 ELSE I_SHIFT_FIRST_HBUF(TYPEF) = DIM_BUF_IO_L_OR_U ENDIF IF(.NOT.STRAT_IO_ASYNC)THEN I_SHIFT_SECOND_HBUF(TYPEF) = I_SHIFT_FIRST_HBUF(TYPEF) ELSE I_SHIFT_SECOND_HBUF(TYPEF) = I_SHIFT_FIRST_HBUF(TYPEF) + & HBUF_SIZE ENDIF CUR_HBUF(TYPEF) = SECOND_HBUF CALL ZMUMPS_OOC_NEXT_HBUF(TYPEF) ENDDO I_CUR_HBUF_NEXTPOS = 1 RETURN END SUBROUTINE ZMUMPS_OOC_INIT_DB_BUFFER_PANEL SUBROUTINE ZMUMPS_OOC_TRYIO_CHBUF_PANEL(TYPEF,IERR) IMPLICIT NONE INTEGER, INTENT(in) :: TYPEF INTEGER, INTENT(out) :: IERR INTEGER IFLAG INTEGER NEW_IOREQUEST IERR=0 CALL MUMPS_TEST_REQUEST_C(LAST_IOREQUEST(TYPEF),IFLAG, & IERR) IF (IFLAG.EQ.1) THEN IERR = 0 CALL ZMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF, & NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF LAST_IOREQUEST(TYPEF) = NEW_IOREQUEST CALL ZMUMPS_OOC_NEXT_HBUF(TYPEF) NextAddVirtBuffer(TYPEF)=BufferEmpty RETURN ELSE IF(IFLAG.LT.0)THEN WRITE(*,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ELSE IERR = 1 RETURN ENDIF END SUBROUTINE ZMUMPS_OOC_TRYIO_CHBUF_PANEL SUBROUTINE ZMUMPS_OOC_UPD_VADDR_CUR_BUF (TYPEF,VADDR) IMPLICIT NONE INTEGER(8), INTENT(in) :: VADDR INTEGER, INTENT(in) :: TYPEF IF(I_REL_POS_CUR_HBUF(TYPEF).EQ.1_8)THEN FIRST_VADDR_IN_BUF(TYPEF)=VADDR ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_UPD_VADDR_CUR_BUF SUBROUTINE ZMUMPS_COPY_LU_TO_BUFFER( STRAT, TYPEF, MonBloc, & AFAC, LAFAC, & AddVirtCour, IPIVBEG, IPIVEND, LPANELeff, & IERR) IMPLICIT NONE INTEGER, INTENT(IN) :: TYPEF, IPIVBEG, IPIVEND, STRAT INTEGER(8), INTENT(IN) :: LAFAC COMPLEX(kind=8), INTENT(IN) :: AFAC(LAFAC) INTEGER(8), INTENT(IN) :: AddVirtCour TYPE(IO_BLOCK), INTENT(IN) :: MonBloc INTEGER, INTENT(OUT):: LPANELeff INTEGER, INTENT(OUT):: IERR INTEGER :: II, NBPIVeff INTEGER(8) :: IPOS, IDIAG, IDEST INTEGER(8) :: DeltaIPOS INTEGER :: StrideIPOS IERR=0 IF (STRAT.NE.STRAT_WRITE_MAX.AND.STRAT.NE.STRAT_TRY_WRITE) THEN write(6,*) ' ZMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented ' CALL MUMPS_ABORT() ENDIF NBPIVeff = IPIVEND - IPIVBEG + 1 IF (MonBloc%MASTER .AND. MonBloc%Typenode .NE. 3) THEN IF (TYPEF.EQ.TYPEF_L) THEN LPANELeff = (MonBloc%NROW-IPIVBEG+1)*NBPIVeff ELSE LPANELeff = (MonBloc%NCOL-IPIVBEG+1)*NBPIVeff ENDIF ELSE LPANELeff = MonBloc%NROW*NBPIVeff ENDIF IF ( ( I_REL_POS_CUR_HBUF(TYPEF) + int(LPANELeff - 1,8) & > & HBUF_SIZE ) & .OR. & ( (AddVirtCour.NE.NextAddVirtBuffer(TYPEF)) .AND. & (NextAddVirtBuffer(TYPEF).NE.BufferEmpty) ) & ) THEN IF (STRAT.EQ.STRAT_WRITE_MAX) THEN CALL ZMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF,IERR) ELSE IF (STRAT.EQ.STRAT_TRY_WRITE) THEN CALL ZMUMPS_OOC_TRYIO_CHBUF_PANEL(TYPEF,IERR) IF (IERR.EQ.1) RETURN ELSE write(6,*) 'ZMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented' ENDIF ENDIF IF (IERR < 0 ) THEN RETURN ENDIF IF (NextAddVirtBuffer(TYPEF).EQ. BufferEmpty) THEN CALL ZMUMPS_OOC_UPD_VADDR_CUR_BUF (TYPEF,AddVirtCour) NextAddVirtBuffer(TYPEF) = AddVirtCour ENDIF IF (MonBloc%MASTER .AND. MonBloc%Typenode .NE. 3) THEN IDIAG = int(IPIVBEG-1,8)*int(MonBloc%NCOL,8) + int(IPIVBEG,8) IPOS = IDIAG IDEST = I_SHIFT_CUR_HBUF(TYPEF) + & I_REL_POS_CUR_HBUF(TYPEF) IF (TYPEF.EQ.TYPEF_L) THEN DO II = IPIVBEG, IPIVEND CALL zcopy(MonBloc%NROW-IPIVBEG+1, & AFAC(IPOS), MonBloc%NCOL, & BUF_IO(IDEST), 1) IDEST = IDEST + int(MonBloc%NROW-IPIVBEG+1,8) IPOS = IPOS + 1_8 ENDDO ELSE DO II = IPIVBEG, IPIVEND CALL zcopy(MonBloc%NCOL-IPIVBEG+1, & AFAC(IPOS), 1, & BUF_IO(IDEST), 1) IDEST = IDEST + int(MonBloc%NCOL-IPIVBEG+1,8) IPOS = IPOS + int(MonBloc%NCOL,8) ENDDO ENDIF ELSE IDEST = I_SHIFT_CUR_HBUF(TYPEF) + & I_REL_POS_CUR_HBUF(TYPEF) IF (MonBloc%Typenode.EQ.3) THEN DeltaIPOS = int(MonBloc%NROW,8) StrideIPOS = 1 ELSE DeltaIPOS = 1_8 StrideIPOS = MonBloc%NCOL ENDIF IPOS = 1_8 + int(IPIVBEG - 1,8) * DeltaIPOS DO II = IPIVBEG, IPIVEND CALL zcopy(MonBloc%NROW, & AFAC(IPOS), StrideIPOS, & BUF_IO(IDEST), 1) IDEST = IDEST+int(MonBloc%NROW,8) IPOS = IPOS + DeltaIPOS ENDDO ENDIF I_REL_POS_CUR_HBUF(TYPEF) = & I_REL_POS_CUR_HBUF(TYPEF) + int(LPANELeff,8) NextAddVirtBuffer(TYPEF) = NextAddVirtBuffer(TYPEF) & + int(LPANELeff,8) RETURN END SUBROUTINE ZMUMPS_COPY_LU_TO_BUFFER END MODULE ZMUMPS_OOC_BUFFER MUMPS_5.8.1/src/dmumps_gpu.c0000664000175000017500000000117315042446422015556 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include #include #include #include "dmumps_gpu.h" void MUMPS_CALL dmumps_gpu_return() { /* GPU feature will be available in the future */ } MUMPS_5.8.1/src/ssol_distrhs.F0000664000175000017500000006031315042446437016070 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SCATTER_DIST_RHS( & NSLAVES, N, & MYID_NODES, COMM_NODES, & NRHS_COL, NRHS_loc, LRHS_loc, & MAP_RHS_loc, & IRHS_loc, RHS_loc, RHS_loc_size, & RHSINTR, LD_RHSINTR, & POSINRHSINTR_FWD, NB_FS_IN_RHSINTR, & LSCAL, #if defined(USE_OLD_SCALING) & scaling_data_dr, #else & SCALING_RHSINTR_FWD, LSCALING_RHSINTR_FWD, #endif & LP, LPOK, KEEP, NB_BYTES_LOC, INFO ) USE SMUMPS_STRUC_DEF !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN) :: NSLAVES, N, MYID_NODES INTEGER, INTENT(IN) :: NRHS_loc, LRHS_loc INTEGER, INTENT(IN) :: NRHS_COL INTEGER, INTENT(IN) :: COMM_NODES INTEGER, INTENT(IN) :: MAP_RHS_loc(max(1,NRHS_loc)) INTEGER, INTENT(IN) :: IRHS_loc(NRHS_loc) INTEGER(8), INTENT(IN) :: RHS_loc_size REAL, INTENT(IN) :: RHS_loc(RHS_loc_size) INTEGER, INTENT(IN) :: NB_FS_IN_RHSINTR, LD_RHSINTR INTEGER, INTENT(IN) :: POSINRHSINTR_FWD(N) REAL, INTENT(OUT) :: RHSINTR(LD_RHSINTR, NRHS_COL) INTEGER :: KEEP(500) LOGICAL, INTENT(IN) :: LSCAL #if defined(USE_OLD_SCALING) type scaling_data_t SEQUENCE REAL, dimension(:), pointer :: SCALING REAL, dimension(:), pointer :: SCALING_LOC INTEGER, dimension(:), pointer :: SCALING_IND end type scaling_data_t type(scaling_data_t), INTENT(IN) :: scaling_data_dr #else INTEGER :: LSCALING_RHSINTR_FWD REAL :: SCALING_RHSINTR_FWD( LSCALING_RHSINTR_FWD ) #endif LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: LP INTEGER, INTENT(INOUT) :: INFO(2) INTEGER(8), INTENT(OUT):: NB_BYTES_LOC INCLUDE 'mpif.h' INTEGER :: IERR_MPI LOGICAL :: OMP_FLAG !$ INTEGER :: CHUNK, NOMP !$ INTEGER(8) :: CHUNK8 INTEGER :: allocok INTEGER :: MAXRECORDS INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROWSTOSEND INTEGER, ALLOCATABLE, DIMENSION(:) :: NEXTROWTOSEND REAL, ALLOCATABLE, DIMENSION(:,:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI REAL, ALLOCATABLE, DIMENSION(:) :: BUFRECR LOGICAL, ALLOCATABLE, DIMENSION(:) :: IS_SEND_ACTIVE, TOUCHED INTEGER, ALLOCATABLE, DIMENSION(:) :: MPI_REQI, MPI_REQR INTEGER, ALLOCATABLE, DIMENSION(:) :: IRHS_loc_sorted INTEGER :: Iloc INTEGER :: Iloc_sorted INTEGER :: IREQ INTEGER :: IMAP, IPROC_MAX INTEGER :: IFS INTEGER :: MAX_ACTIVE_SENDS INTEGER :: NB_ACTIVE_SENDS INTEGER :: NB_FS_TOUCHED INTEGER :: NBROWSTORECV REAL, PARAMETER :: ZERO = 0.0E0 #if defined(AVOID_MPI_IN_PLACE) INTEGER :: allocoktmp #endif !$ NOMP = OMP_GET_MAX_THREADS() NB_BYTES_LOC = 0_8 ALLOCATE( NBROWSTOSEND (NSLAVES), & NEXTROWTOSEND (NSLAVES), & IRHS_loc_sorted (NRHS_loc), & stat=allocok ) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = NSLAVES+NSLAVES+NRHS_loc ELSE NB_BYTES_LOC = int(2*NSLAVES+NRHS_loc,8)*KEEP(34) ENDIF #if defined(AVOID_MPI_IN_PLACE) allocoktmp=allocok CALL MPI_ALLREDUCE( allocoktmp, allocok, 1, #else CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1, #endif & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI ) IF (allocok .GT. 0) RETURN NBROWSTOSEND(1:NSLAVES) = 0 DO Iloc = 1, NRHS_loc IF (IRHS_loc(Iloc) .GE. 1 .AND. & IRHS_loc(Iloc) .LE. N) THEN IMAP = MAP_RHS_loc(Iloc) NBROWSTOSEND(IMAP+1) = NBROWSTOSEND(IMAP+1)+1 ENDIF ENDDO NEXTROWTOSEND(1)=1 DO IMAP=1, NSLAVES-1 NEXTROWTOSEND(IMAP+1)=NEXTROWTOSEND(IMAP)+NBROWSTOSEND(IMAP) ENDDO NBROWSTOSEND=0 DO Iloc = 1, NRHS_loc IF (IRHS_loc(Iloc) .GE. 1 .AND. & IRHS_loc(Iloc) .LE. N) THEN IMAP = MAP_RHS_loc(Iloc) Iloc_sorted = NEXTROWTOSEND(IMAP+1)+NBROWSTOSEND(IMAP+1) IRHS_loc_sorted(Iloc_sorted) = Iloc NBROWSTOSEND(IMAP+1)=NBROWSTOSEND(IMAP+1)+1 ENDIF ENDDO CALL SMUMPS_DR_BUILD_NBROWSTORECV() MAX_ACTIVE_SENDS = min(10, NSLAVES) IF (KEEP(72) .EQ.1 ) THEN MAXRECORDS = 15 ELSE MAXRECORDS = min(200000,2000000/NRHS_COL) MAXRECORDS = min(MAXRECORDS, & 50000000 / MAX_ACTIVE_SENDS / NRHS_COL) MAXRECORDS = max(MAXRECORDS, 50) ENDIF ALLOCATE(BUFR(MAXRECORDS*NRHS_COL, & MAX_ACTIVE_SENDS), & MPI_REQI(MAX_ACTIVE_SENDS), & MPI_REQR(MAX_ACTIVE_SENDS), & IS_SEND_ACTIVE(MAX_ACTIVE_SENDS), & BUFRECI(MAXRECORDS), & BUFRECR(MAXRECORDS*NRHS_COL), & TOUCHED(NB_FS_IN_RHSINTR), & stat=allocok) IF (allocok .GT. 0) THEN IF (LP .GT. 0) WRITE(LP, '(A)') & 'Error: Allocation problem in SMUMPS_SCATTER_DIST_RHS' INFO(1)=-13 INFO(2)=NRHS_COL*MAXRECORDS*MAX_ACTIVE_SENDS+ & 3*MAX_ACTIVE_SENDS+MAXRECORDS*(1+NRHS_COL) & + NB_FS_IN_RHSINTR ENDIF NB_BYTES_LOC=NB_BYTES_LOC + & KEEP(34) * ( int(2*MAX_ACTIVE_SENDS,8) + int(MAXRECORDS,8) ) + & KEEP(34) * (int(MAX_ACTIVE_SENDS,8) + int(NB_FS_IN_RHSINTR,8)) + & KEEP(35) * ( & int( MAXRECORDS,8)*int(NRHS_COL,8)*int(MAX_ACTIVE_SENDS,8) & + int(MAXRECORDS,8) * int(NRHS_COL,8) ) CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1, & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI ) IF (allocok .NE. 0) RETURN NB_ACTIVE_SENDS = 0 DO IREQ = 1, MAX_ACTIVE_SENDS IS_SEND_ACTIVE(IREQ) = .FALSE. ENDDO NB_FS_TOUCHED = 0 DO IFS = 1, NB_FS_IN_RHSINTR TOUCHED(IFS) = .FALSE. ENDDO IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1 DO WHILE (NBROWSTOSEND(IPROC_MAX+1) .NE. 0) IF (IPROC_MAX .EQ. MYID_NODES) THEN CALL SMUMPS_DR_ASSEMBLE_LOCAL() ELSE CALL SMUMPS_DR_TRY_SEND(IPROC_MAX) ENDIF CALL SMUMPS_DR_TRY_RECV() CALL SMUMPS_DR_TRY_FREE_SEND() IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1 ENDDO DO WHILE ( NBROWSTORECV .NE. 0) CALL SMUMPS_DR_TRY_RECV() CALL SMUMPS_DR_TRY_FREE_SEND() ENDDO DO WHILE (NB_ACTIVE_SENDS .NE. 0) CALL SMUMPS_DR_TRY_FREE_SEND() ENDDO CALL SMUMPS_DR_EMPTY_ROWS() RETURN CONTAINS SUBROUTINE SMUMPS_DR_BUILD_NBROWSTORECV() INTEGER :: IPROC DO IPROC = 0, NSLAVES-1 CALL MPI_REDUCE( NBROWSTOSEND(IPROC+1), NBROWSTORECV, & 1, MPI_INTEGER, & MPI_SUM, IPROC, COMM_NODES, IERR_MPI ) ENDDO END SUBROUTINE SMUMPS_DR_BUILD_NBROWSTORECV SUBROUTINE SMUMPS_DR_TRY_RECV() IMPLICIT NONE INCLUDE 'mumps_tags.h' INTEGER :: MPI_STATUS(MPI_STATUS_SIZE), MSGSOU INTEGER :: NBRECORDS LOGICAL :: FLAG CALL MPI_IPROBE( MPI_ANY_SOURCE, DistRhsI, COMM_NODES, & FLAG, MPI_STATUS, IERR_MPI ) IF (FLAG) THEN MSGSOU = MPI_STATUS( MPI_SOURCE ) CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER, & NBRECORDS, IERR_MPI) CALL MPI_RECV(BUFRECI(1), NBRECORDS, MPI_INTEGER, & MSGSOU, DistRhsI, & COMM_NODES, MPI_STATUS, IERR_MPI) CALL MPI_RECV(BUFRECR(1), NBRECORDS*NRHS_COL, & MPI_REAL, & MSGSOU, DistRhsR, & COMM_NODES, MPI_STATUS, IERR_MPI) CALL SMUMPS_DR_ASSEMBLE_FROM_BUFREC(NBRECORDS, & BUFRECI, BUFRECR) ENDIF RETURN END SUBROUTINE SMUMPS_DR_TRY_RECV SUBROUTINE SMUMPS_DR_ASSEMBLE_FROM_BUFREC & (NBRECORDS, BUFRECI_ARG, BUFRECR_ARG) IMPLICIT NONE INTEGER, INTENT(IN) :: NBRECORDS INTEGER, INTENT(INOUT) :: BUFRECI_ARG(NBRECORDS) REAL, INTENT(IN) :: BUFRECR_ARG(NBRECORDS, & NRHS_COL) INTEGER :: I, K, IRHSINTR, IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IFIRSTNOTTOUCHED = NBRECORDS+1 ILASTNOTTOUCHED = 0 DO I = 1, NBRECORDS IF (BUFRECI(I) .LE. 0) THEN WRITE(*,*) "Internal error 1 in SMUMPS_DR_TRY_RECV", & I, BUFRECI(I), BUFRECI(1) CALL MUMPS_ABORT() ENDIF IRHSINTR=POSINRHSINTR_FWD(BUFRECI(I)) BUFRECI_ARG(I)=IRHSINTR IF ( .NOT. TOUCHED(IRHSINTR) ) THEN IFIRSTNOTTOUCHED=min(IFIRSTNOTTOUCHED,I) ILASTNOTTOUCHED=max(ILASTNOTTOUCHED,I) ENDIF ENDDO OMP_FLAG = .FALSE. !$ OMP_FLAG = ( NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(I,IRHSINTR) DO K = 1, NRHS_COL DO I = IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IRHSINTR=BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSINTR)) THEN RHSINTR(IRHSINTR,K)=ZERO ENDIF ENDDO #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO I = 1, NBRECORDS IRHSINTR=BUFRECI_ARG(I) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & SCALING_RHSINTR_FWD(IRHSINTR) * & BUFRECR_ARG(I,K) ENDDO ELSE #endif DO I = 1, NBRECORDS IRHSINTR=BUFRECI_ARG(I) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & BUFRECR_ARG(I,K) ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif ENDDO !$OMP END PARALLEL DO ELSE DO K = 1, NRHS_COL DO I = IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IRHSINTR=BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSINTR)) THEN RHSINTR(IRHSINTR,K)=ZERO ENDIF ENDDO #if ! defined(USE_OLD_SCALING) IF ( LSCAL ) THEN DO I = 1, NBRECORDS IRHSINTR=BUFRECI_ARG(I) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & SCALING_RHSINTR_FWD(IRHSINTR) * & BUFRECR_ARG(I,K) ENDDO ELSE #endif DO I = 1, NBRECORDS IRHSINTR=BUFRECI_ARG(I) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & BUFRECR_ARG(I,K) ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif ENDDO ENDIF DO I = 1, NBRECORDS IRHSINTR = BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSINTR)) THEN NB_FS_TOUCHED = NB_FS_TOUCHED + 1 TOUCHED(IRHSINTR) = .TRUE. ENDIF ENDDO NBROWSTORECV = NBROWSTORECV - NBRECORDS RETURN END SUBROUTINE SMUMPS_DR_ASSEMBLE_FROM_BUFREC SUBROUTINE SMUMPS_DR_ASSEMBLE_LOCAL() INTEGER :: NBRECORDS, I, K, IFIRSTNOTTOUCHED INTEGER :: Iloc INTEGER :: Iglob INTEGER :: IRHSINTR INTEGER(8) :: ISHIFT IF ( NBROWSTOSEND(MYID_NODES+1) .EQ. 0) THEN WRITE(*,*) "Internal error in SMUMPS_DR_ASSEMBLE_LOCAL" CALL MUMPS_ABORT() ENDIF NBRECORDS=min(MAXRECORDS, NBROWSTOSEND(MYID_NODES+1)) IFIRSTNOTTOUCHED=NBRECORDS+1 DO I = 1, NBRECORDS IRHSINTR = POSINRHSINTR_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSINTR)) THEN IFIRSTNOTTOUCHED=I EXIT ENDIF ENDDO IF (LSCAL) THEN !$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSINTR, Iloc, Iglob) !$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG) DO K = 1, NRHS_COL ISHIFT = int(K-1,8) * int(LRHS_loc,8) DO I = IFIRSTNOTTOUCHED, NBRECORDS IRHSINTR = POSINRHSINTR_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSINTR)) THEN RHSINTR(IRHSINTR,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1) Iglob = IRHS_loc(Iloc) IRHSINTR = POSINRHSINTR_FWD(Iglob) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K)+ & RHS_loc(Iloc+ISHIFT)* #if defined(USE_OLD_SCALING) & scaling_data_dr%SCALING_LOC(Iloc) #else & SCALING_RHSINTR_FWD(IRHSINTR) #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSINTR, Iloc, Iglob) !$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG) DO K = 1, NRHS_COL ISHIFT = int(K-1,8) * int(LRHS_loc,8) DO I = IFIRSTNOTTOUCHED, NBRECORDS IRHSINTR = POSINRHSINTR_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSINTR)) THEN RHSINTR(IRHSINTR,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1) Iglob = IRHS_loc(Iloc) IRHSINTR = POSINRHSINTR_FWD(Iglob) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & RHS_loc(Iloc+ISHIFT) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF DO I = 1, NBRECORDS IRHSINTR = POSINRHSINTR_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSINTR)) THEN NB_FS_TOUCHED = NB_FS_TOUCHED + 1 TOUCHED(IRHSINTR) = .TRUE. ENDIF ENDDO NEXTROWTOSEND(MYID_NODES+1)=NEXTROWTOSEND(MYID_NODES+1)+ & NBRECORDS NBROWSTOSEND(MYID_NODES+1)=NBROWSTOSEND(MYID_NODES+1)- & NBRECORDS NBROWSTORECV = NBROWSTORECV - NBRECORDS RETURN END SUBROUTINE SMUMPS_DR_ASSEMBLE_LOCAL SUBROUTINE SMUMPS_DR_GET_NEW_BUF( IBUF ) INTEGER, INTENT(OUT) :: IBUF INTEGER :: I IBUF = -1 IF (NB_ACTIVE_SENDS .NE. MAX_ACTIVE_SENDS) THEN DO I=1, MAX_ACTIVE_SENDS IF (.NOT. IS_SEND_ACTIVE(I)) THEN IBUF = I EXIT ENDIF ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_DR_GET_NEW_BUF SUBROUTINE SMUMPS_DR_TRY_FREE_SEND() INTEGER :: MPI_STATUS(MPI_STATUS_SIZE) INTEGER :: I LOGICAL :: FLAG IF (NB_ACTIVE_SENDS .GT. 0) THEN DO I=1, MAX_ACTIVE_SENDS IF (IS_SEND_ACTIVE(I)) THEN CALL MPI_TEST( MPI_REQR(I), FLAG, MPI_STATUS, IERR_MPI ) IF (FLAG) THEN CALL MPI_WAIT(MPI_REQI(I), MPI_STATUS, IERR_MPI) NB_ACTIVE_SENDS = NB_ACTIVE_SENDS - 1 IS_SEND_ACTIVE(I)=.FALSE. IF (NB_ACTIVE_SENDS .EQ. 0) THEN RETURN ENDIF ENDIF ENDIF ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_DR_TRY_FREE_SEND SUBROUTINE SMUMPS_DR_TRY_SEND(IPROC_ARG) IMPLICIT NONE INTEGER, INTENT(IN) :: IPROC_ARG INCLUDE 'mumps_tags.h' INTEGER :: NBRECORDS, IBUF, I, K INTEGER(8) :: IPOSRHS INTEGER :: IPOSBUF IF (IPROC_ARG .EQ. MYID_NODES) THEN WRITE(*,*) "Internal error 1 in SMUMPS_DR_TRY_SEND" CALL MUMPS_ABORT() ENDIF IF (NBROWSTOSEND(IPROC_ARG+1) .EQ. 0) THEN WRITE(*,*) "Internal error 2 in SMUMPS_DR_TRY_SEND" CALL MUMPS_ABORT() ENDIF CALL SMUMPS_DR_GET_NEW_BUF(IBUF) IF (IBUF .GT. 0) THEN NBRECORDS = min(MAXRECORDS,NBROWSTOSEND(IPROC_ARG+1)) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS_COL*NBRECORDS !$ IF (CHUNK .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((CHUNK+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF IF (LSCAL) THEN !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) !$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG) DO K=1, NRHS_COL DO I = 1, NBRECORDS IPOSBUF = (K-1)*NBRECORDS IPOSRHS = int(K-1,8)*int(LRHS_loc,8) Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) BUFR( IPOSBUF + I, IBUF ) & = RHS_loc( IPOSRHS + Iloc ) #if defined(USE_OLD_SCALING) & * scaling_data_dr%SCALING_LOC(Iloc) #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) !$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG) DO K=1, NRHS_COL DO I = 1, NBRECORDS IPOSBUF = (K-1)*NBRECORDS IPOSRHS = int(K-1,8)*int(LRHS_loc,8) Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) BUFR( IPOSBUF + I, IBUF ) & = RHS_loc( IPOSRHS + Iloc ) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) & = IRHS_loc(Iloc) ENDDO CALL MPI_ISEND( IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)), & NBRECORDS, MPI_INTEGER, IPROC_ARG, DistRhsI, & COMM_NODES, MPI_REQI(IBUF), IERR_MPI ) CALL MPI_ISEND( BUFR(1,IBUF), NBRECORDS*NRHS_COL, & MPI_REAL, & IPROC_ARG, DistRhsR, & COMM_NODES, MPI_REQR(IBUF), IERR_MPI ) NEXTROWTOSEND(IPROC_ARG+1)=NEXTROWTOSEND(IPROC_ARG+1)+ & NBRECORDS NBROWSTOSEND(IPROC_ARG+1)=NBROWSTOSEND(IPROC_ARG+1)-NBRECORDS NB_ACTIVE_SENDS = NB_ACTIVE_SENDS + 1 IS_SEND_ACTIVE(IBUF)=.TRUE. ENDIF RETURN END SUBROUTINE SMUMPS_DR_TRY_SEND SUBROUTINE SMUMPS_DR_EMPTY_ROWS() INTEGER :: K, IFS IF ( NB_FS_TOUCHED .NE. NB_FS_IN_RHSINTR ) THEN !$ OMP_FLAG = (NRHS_COL .GE. KEEP(362)) .AND. !$ & (NRHS_COL*NB_FS_IN_RHSINTR > KEEP(363)/2) !$OMP PARALLEL DO FIRSTPRIVATE(NB_FS_IN_RHSINTR) !$OMP& PRIVATE(IFS) IF (OMP_FLAG) DO K = 1, NRHS_COL DO IFS = 1, NB_FS_IN_RHSINTR IF ( .NOT. TOUCHED(IFS) ) THEN RHSINTR( IFS, K) = ZERO ENDIF ENDDO DO IFS = NB_FS_IN_RHSINTR +1, LD_RHSINTR RHSINTR (IFS, K) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$ OMP_FLAG = .FALSE. !$ CHUNK8 = int(NRHS_COL,8)*int(LD_RHSINTR-NB_FS_IN_RHSINTR,8) !$ CHUNK8 = max(CHUNK8,1_8) !$ IF (CHUNK8 .GE. int(KEEP(363),8)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK8 = max((CHUNK8+NOMP-1)/NOMP,int(KEEP(363)/2,8)) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK8) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS_COL DO IFS = NB_FS_IN_RHSINTR +1, LD_RHSINTR RHSINTR (IFS, K) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE SMUMPS_DR_EMPTY_ROWS END SUBROUTINE SMUMPS_SCATTER_DIST_RHS SUBROUTINE SMUMPS_SOL_INIT_IRHS_loc(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE (SMUMPS_STRUC) :: id INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ROW_OR_COL_INDICES INTEGER :: IERR_MPI LOGICAL :: I_AM_SLAVE INTEGER, POINTER :: idIRHS_loc(:) INTEGER, POINTER :: UNS_PERM(:) INTEGER :: UNS_PERM_TO_BE_DONE, I, allocok INTEGER, TARGET :: IDUMMY(1) INCLUDE 'mpif.h' NULLIFY(UNS_PERM) IF (id%JOB .NE. 9) THEN WRITE(*,*) "Internal error 1 in SMUMPS_SOL_INIT_IRHS_loc" CALL MUMPS_ABORT() ENDIF I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (id%MYID .EQ. MASTER) THEN IF (id%KEEP(50).NE.0) THEN ROW_OR_COL_INDICES = 0 ELSE IF (id%ICNTL(20).EQ.10 .OR. id%KEEP(50).EQ.0) THEN ROW_OR_COL_INDICES = 0 ELSE IF (id%ICNTL(20).EQ.11) THEN ROW_OR_COL_INDICES = 1 ELSE ROW_OR_COL_INDICES = 0 ENDIF IF (id%ICNTL(9) .NE. 1) THEN ROW_OR_COL_INDICES = 1 - ROW_OR_COL_INDICES ENDIF ENDIF IF (id%KEEP(23).NE.0 .AND. id%ICNTL(9) .NE.1) THEN UNS_PERM_TO_BE_DONE = 1 ELSE UNS_PERM_TO_BE_DONE = 0 ENDIF ENDIF CALL MPI_BCAST(ROW_OR_COL_INDICES,1,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) CALL MPI_BCAST(UNS_PERM_TO_BE_DONE,1,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) IF ( I_AM_SLAVE ) THEN IF (id%KEEP(89) .GT. 0) THEN IF (.NOT. associated(id%IRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=17 ELSE IF (size(id%IRHS_loc) < id%KEEP(89) ) THEN id%INFO(1)=-22 id%INFO(2)=17 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) goto 500 IF (I_AM_SLAVE) THEN IF (associated(id%IRHS_loc)) THEN IF (size(id%IRHS_loc) .GT. 0) THEN idIRHS_loc => id%IRHS_loc ELSE idIRHS_loc => IDUMMY ENDIF ELSE idIRHS_loc => IDUMMY ENDIF CALL MUMPS_GET_INDICES & (id%MYID_NODES, id%NSLAVES, id%N, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), id%IS(1), & max(1, id%KEEP(32)), & id%STEP(1), id%PROCNODE_STEPS(1), idIRHS_loc(1), & ROW_OR_COL_INDICES) ENDIF IF (UNS_PERM_TO_BE_DONE .EQ. 1) THEN IF (id%MYID.NE.MASTER) THEN ALLOCATE(UNS_PERM(id%N),stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=id%N GOTO 100 ENDIF ENDIF 100 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) GOTO 500 IF ( id%MYID .EQ. MASTER ) THEN UNS_PERM => id%UNS_PERM ENDIF CALL MPI_BCAST(UNS_PERM(1),id%N,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) IF (I_AM_SLAVE .AND. id%KEEP(89) .NE.0) THEN DO I=1, id%KEEP(89) id%IRHS_loc(I)=UNS_PERM(id%IRHS_loc(I)) ENDDO ENDIF ENDIF 500 CONTINUE IF (id%MYID.NE.MASTER) THEN IF (associated(UNS_PERM)) DEALLOCATE(UNS_PERM) ENDIF NULLIFY(UNS_PERM) RETURN END SUBROUTINE SMUMPS_SOL_INIT_IRHS_loc MUMPS_5.8.1/src/fac_maprow_data_m.F0000664000175000017500000002445315042446423016773 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_FAC_MAPROW_DATA_M IMPLICIT NONE #if ! defined(NO_FDM_MAPROW) C ========================================= C The MUMPS_FAC_MAPROW_DATA_M module stores C the MAPROW messages that arrive too early. C It is based on the MUMPS_FRONT_DATA_MGT_M C module. C C An array of structures that contain MAPROW C information is used as a global variable in C this module. It is indexed by an "IWHANDLER" C (stored in the main IW array) that is C managed by the MUMPS_FRONT_DATA_MGT_M module. C C The same handler can be used for other data C stored for active type 2 fronts (DESCBAND C information, typically) C ======================================== C PRIVATE PUBLIC :: MAPROW_STRUC_T, MUMPS_FMRD_INIT, MUMPS_FMRD_END, & MUMPS_FMRD_SAVE_MAPROW, MUMPS_FMRD_IS_MAPROW_STORED, & MUMPS_FMRD_RETRIEVE_MAPROW, & MUMPS_FMRD_FREE_MAPROW_STRUC TYPE MAPROW_STRUC_T INTEGER :: INODE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER INTEGER,POINTER, DIMENSION(:) :: SLAVES_PERE !size NSLAVES_PERE INTEGER,POINTER, DIMENSION(:) :: TROW !size LMAP END TYPE MAPROW_STRUC_T TYPE (MAPROW_STRUC_T), POINTER, DIMENSION(:), SAVE :: FMRD_ARRAY CONTAINS FUNCTION MUMPS_FMRD_IS_MAPROW_STORED( IWHANDLER ) LOGICAL :: MUMPS_FMRD_IS_MAPROW_STORED INTEGER, INTENT(IN) :: IWHANDLER IF (IWHANDLER .LT. 0 .OR. IWHANDLER .GT. size(FMRD_ARRAY)) THEN MUMPS_FMRD_IS_MAPROW_STORED = .FALSE. ELSE MUMPS_FMRD_IS_MAPROW_STORED = & (FMRD_ARRAY(IWHANDLER)%INODE .GE. 0 ) IF (FMRD_ARRAY(IWHANDLER)%INODE .EQ.0) THEN WRITE(*,*) " Internal error 1 in MUMPS_FMRD_IS_MAPROW_STORED" CALL MUMPS_ABORT() ENDIF ENDIF RETURN END FUNCTION MUMPS_FMRD_IS_MAPROW_STORED C SUBROUTINE MUMPS_FMRD_INIT( INITIAL_SIZE, INFO ) C C Purpose: C ======= C C Module initialization C C Arguments C ========= C INTEGER, INTENT(IN) :: INITIAL_SIZE INTEGER, INTENT(INOUT) :: INFO(2) C C Local variables C =============== C INTEGER :: I, IERR C ALLOCATE(FMRD_ARRAY( INITIAL_SIZE ), stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=INITIAL_SIZE RETURN ENDIF DO I=1, INITIAL_SIZE FMRD_ARRAY(I)%INODE=-9999 NULLIFY(FMRD_ARRAY(I)%SLAVES_PERE) NULLIFY(FMRD_ARRAY(I)%TROW) ENDDO RETURN END SUBROUTINE MUMPS_FMRD_INIT C SUBROUTINE MUMPS_FMRD_SAVE_MAPROW( & IWHANDLER, & INODE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER, & SLAVES_PERE, !size NSLAVES_PERE & TROW, !size LMAP & INFO) C C Arguments: C ========= C INTEGER, INTENT(IN) :: INODE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER INTEGER, INTENT(IN) :: SLAVES_PERE (max(1,NSLAVES_PERE)) INTEGER, INTENT(IN) :: TROW( LMAP) INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) C C Local variables: C =============== C TYPE(MAPROW_STRUC_T) :: MAPROW_STRUC C CALL MUMPS_FMRD_FILL_MAPROW( MAPROW_STRUC, & INODE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER, & SLAVES_PERE, !size NSLAVES_PERE & TROW, !size LMAP & INFO) IF (INFO(1) .LT. 0) RETURN CALL MUMPS_FMRD_STORE_MAPROW(IWHANDLER, MAPROW_STRUC, INFO) RETURN END SUBROUTINE MUMPS_FMRD_SAVE_MAPROW C SUBROUTINE MUMPS_FMRD_STORE_MAPROW(IWHANDLER, MAPROW_STRUC, INFO) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX C C Purpose: C ======= C C Given an IWHANDLER and a MAPROW structure, store the MAPROW C structure into the main array of the module. C C If IWHANDLER is larger than the current array size, the C array is reallocated. C C Arguments: C ========= C INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) TYPE(MAPROW_STRUC_T), INTENT(IN) :: MAPROW_STRUC C C Local variables: C =============== C TYPE(MAPROW_STRUC_T), POINTER, DIMENSION(:) :: FMRD_ARRAY_TMP INTEGER :: OLD_SIZE, NEW_SIZE INTEGER :: I INTEGER :: IERR C CALL MUMPS_FDM_START_IDX('A', 'MAPROW', IWHANDLER, INFO) IF (INFO(1) .LT. 0) RETURN IF (IWHANDLER > size(FMRD_ARRAY)) THEN C Reallocate in a bigger array OLD_SIZE = size(FMRD_ARRAY) NEW_SIZE = max( (OLD_SIZE * 3) / 2 + 1, IWHANDLER) C ALLOCATE(FMRD_ARRAY_TMP(NEW_SIZE),stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=NEW_SIZE RETURN ENDIF DO I=1, OLD_SIZE FMRD_ARRAY_TMP(I)=FMRD_ARRAY(I) ENDDO C Similar to code in MUMPS_FMRD_INIT: DO I=OLD_SIZE+1, NEW_SIZE FMRD_ARRAY_TMP(I)%INODE = -9999 NULLIFY(FMRD_ARRAY_TMP(I)%SLAVES_PERE) NULLIFY(FMRD_ARRAY_TMP(I)%TROW) ENDDO DEALLOCATE(FMRD_ARRAY) FMRD_ARRAY=>FMRD_ARRAY_TMP NULLIFY(FMRD_ARRAY_TMP) ENDIF FMRD_ARRAY(IWHANDLER) = MAPROW_STRUC RETURN END SUBROUTINE MUMPS_FMRD_STORE_MAPROW SUBROUTINE MUMPS_FMRD_FILL_MAPROW(MAPROW_STRUC, & INODE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER, & SLAVES_PERE, !size NSLAVES_PERE & TROW, !size LMAP & INFO) C C Purpose: C ======= C Fill the MAPROW_STRUC into C C Arguments: C ========= C INTEGER, INTENT(IN) :: INODE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER INTEGER, INTENT(IN) :: SLAVES_PERE(max(1,NSLAVES_PERE)) INTEGER, INTENT(IN) :: TROW( LMAP) TYPE (MAPROW_STRUC_T), INTENT(OUT) :: MAPROW_STRUC INTEGER, INTENT(INOUT) :: INFO(2) C C Local variables: C =============== C INTEGER :: IERR, I C MAPROW_STRUC%INODE = INODE MAPROW_STRUC%ISON = ISON MAPROW_STRUC%NSLAVES_PERE = NSLAVES_PERE MAPROW_STRUC%NFRONT_PERE = NFRONT_PERE MAPROW_STRUC%NASS_PERE = NASS_PERE MAPROW_STRUC%LMAP = LMAP MAPROW_STRUC%NFS4FATHER = NFS4FATHER ALLOCATE(MAPROW_STRUC%SLAVES_PERE(max(1,NSLAVES_PERE)), & MAPROW_STRUC%TROW(LMAP), stat=IERR) IF (IERR .GT.0) THEN INFO(1) = -13 INFO(2) = NSLAVES_PERE + LMAP RETURN ENDIF DO I=1, NSLAVES_PERE MAPROW_STRUC%SLAVES_PERE(I) = SLAVES_PERE(I) ENDDO DO I=1, LMAP MAPROW_STRUC%TROW(I) = TROW(I) ENDDO RETURN END SUBROUTINE MUMPS_FMRD_FILL_MAPROW C SUBROUTINE MUMPS_FMRD_FREE_MAPROW_STRUC(IWHANDLER) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX C C Purpose: C ======= C C Free internal arrays of MAPROW_STRUC. C Typically used after a MAPROW_STRUC has been retrieved C from the module and late-received message has finally C been processed. C C MAPROW_STRUC normally corresponds to a local variable C of the calling routine and will not be reused. C C Arguments: C ========= C INTEGER, INTENT(INOUT) :: IWHANDLER C C Local variables: C =============== C TYPE (MAPROW_STRUC_T), POINTER :: MAPROW_STRUC C MAPROW_STRUC => FMRD_ARRAY(IWHANDLER) MAPROW_STRUC%INODE = -7777 ! Special value: negative means unused DEALLOCATE(MAPROW_STRUC%SLAVES_PERE, MAPROW_STRUC%TROW) NULLIFY (MAPROW_STRUC%SLAVES_PERE, MAPROW_STRUC%TROW) C Release handler IWHANDLER and store it C in a new free position for future reuse CALL MUMPS_FDM_END_IDX('A', 'MAPROW', IWHANDLER) RETURN END SUBROUTINE MUMPS_FMRD_FREE_MAPROW_STRUC C SUBROUTINE MUMPS_FMRD_RETRIEVE_MAPROW(IWHANDLER, MAPROW_STRUC) C C Purpose: C ======= C C Given an IWHANDLER, return a pointer to a MAPROW structure, C containing information on a previously received MAPROW message. C C Arguments: C ========= C INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) TYPE (MAPROW_STRUC_T), POINTER :: MAPROW_STRUC #else TYPE (MAPROW_STRUC_T), POINTER, INTENT(OUT) :: MAPROW_STRUC #endif MAPROW_STRUC => FMRD_ARRAY(IWHANDLER) RETURN END SUBROUTINE MUMPS_FMRD_RETRIEVE_MAPROW C SUBROUTINE MUMPS_FMRD_END(INFO1) C C Purpose: C ======= C Module final termination. C C Arguments: C ========= C INTEGER, INTENT(IN) :: INFO1 C Local variables: C =============== INTEGER :: I, IWHANDLER C IF (.NOT. associated(FMRD_ARRAY)) THEN WRITE(*,*) "Internal error 1 in MUMPS_FAC_FMRD_END" CALL MUMPS_ABORT() ENDIF DO I=1, size(FMRD_ARRAY) IF (FMRD_ARRAY(I)%INODE .GE. 0) THEN C Node is not free: possible only in C case of fatal error (INFO1 < 0) IF (INFO1 .GE.0) THEN C Should have been freed earlier while consuming MAPLIG WRITE(*,*) "Internal error 2 in MUMPS_FAC_FMRD_END",I CALL MUMPS_ABORT() ELSE C May happen in case an error has forced finishing C factorization before all MAPROW msgs were processed. C We copy the loop index I in the local variable IWHANDLER C because there would otherwise be a risk for the loop index C I to be modified by MUMPS_FMRD_FREE_MAPROW_STRUC IWHANDLER=I CALL MUMPS_FMRD_FREE_MAPROW_STRUC(IWHANDLER) ENDIF ENDIF ENDDO DEALLOCATE(FMRD_ARRAY) RETURN END SUBROUTINE MUMPS_FMRD_END #endif END MODULE MUMPS_FAC_MAPROW_DATA_M MUMPS_5.8.1/src/dmumps_mpi3_mod.F0000664000175000017500000000137615042446437016450 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_MPI3_MOD IMPLICIT NONE INTEGER, PARAMETER :: WIN_SYM_PERM272 = 272 INTEGER, PARAMETER :: WIN_FILS273 = 273 INTEGER, PARAMETER :: WIN_STEP274 = 274 INTEGER, PARAMETER :: WIN_LRGROUPS275 = 275 INTEGER, PARAMETER :: WIN_RG2L276 = 276 END MODULE DMUMPS_MPI3_MOD MUMPS_5.8.1/src/sfac_process_blocfacto_LDLT.F0000664000175000017500000015143715042446437020665 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE SMUMPS_PROCESS_SYM_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_OOC, ONLY : IO_BLOCK USE MUMPS_OOC_COMMON, ONLY : TYPEF_L, STRAT_TRY_WRITE USE MUMPS_LOAD USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT USE SMUMPS_BUF, ONLY : SMUMPS_BUF_SEND_BLFAC_SLAVE USE SMUMPS_LR_CORE USE SMUMPS_LR_TYPE USE MUMPS_LR_STATS USE SMUMPS_FAC_LR USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR, & SMUMPS_DM_ALLOC_S_WK, SMUMPS_DM_FREE_S_WK USE SMUMPS_FAC_FRONT_AUX_M, ONLY : SMUMPS_GET_SIZE_SCHUR_IN_FRONT !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) PTRAST(KEEP(28)), PTRFAC(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PERM(N), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)), ND(KEEP(28)) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) REAL DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PIVI INTEGER (8) POSPV1,POSPV2,OFFDAG,LPOS1 INTEGER J2 REAL MULT1,MULT2, A11, DETPIV, A22, A12 INTEGER :: NFS4FATHER, NVSCHUR_K253, NSLAVES_L, IROW_L REAL, ALLOCATABLE, DIMENSION(:) :: M_ARRAY INTEGER NBROWSinF INTEGER :: BLFAC_NBCOLS_ALREADY_SENT, BLFAC_NBLRB_ALREADY_SENT INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NEWCOL_RECV, JBEG_BLOCK, NCOL_GEMM_FR, & SHIFT_LPOS, SHIFT_UPOS INTEGER :: IFLAG_OOC INTEGER(8) :: POSBLOCFACTO INTEGER :: LD_BLOCFACTO INTEGER(8) :: LA_BLOCFACTO INTEGER(8) :: LA_PTR INTEGER(8) :: POSELT REAL, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, 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 INTEGER(8) :: LUIP21K REAL, DIMENSION(:), POINTER :: UIP21K REAL, DIMENSION(:), ALLOCATABLE :: DYN_BLOCFACTO INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_SLAVES_FOLLOW INTEGER, DIMENSION(:), ALLOCATABLE :: DYN_PIVINFO LOGICAL LASTPANEL LOGICAL LASTBL_INPANEL, LASTBL_INLASTPANEL LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED REAL ONE,ALPHA PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER J LOGICAL COUNTER_WAS_HUGE INTEGER TO_UPDATE_CPT_RECUR INTEGER :: LR_ACTIVATED_INT LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL LOGICAL :: DYNAMIC_ALLOC LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: CURRENT_BLR, NSLAVES_PREC, INFO_TMP(2) INTEGER :: NELIM, NB_BLR_LM, NB_BLR_LS, & MAXI_CLUSTER_LM, MAXI_CLUSTER_LS, MAXI_CLUSTER, & NPARTSASS, NPARTSCB, NPARTSCB_COL, NPARTSASS_COL, & NB_BLR_COL, MAXI_CLUSTER_COL INTEGER :: NPARTSASS_MASTER, IPANEL, NB_ACCESSES_INIT, & NB_ACCESSES_LEFT_INIT TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_LM TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS, & BEGS_BLR_COL, BEGS_BLR_COL_TMP LOGICAL KEEP_BEGS_BLR_LS, KEEP_BEGS_BLR_COL, KEEP_BLR_LS REAL, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT REAL, ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR REAL,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, LWORK INTEGER :: II,JJ LOGICAL :: NOTHING_WAS_SENT INTEGER :: KEEP430_LOC INTEGER :: NB, IB, IBEG, IEND !$ INTEGER :: NOMP !$ LOGICAL :: OMP_FLAG INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE KEEP(174)=KEEP(174)+1 KEEP(175)=max(KEEP(174),KEEP(175)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 POSITION = 0 TO_UPDATE_CPT_END = -654321 NULLIFY(UIP21K) 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 ) LASTPANEL = (NPIV.LE.0) IF (LASTPANEL) THEN NPIV = -NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NB_BLOC_FAC, 1, & MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NEWCOL_RECV, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, JBEG_BLOCK, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER, 1, & MPI_INTEGER, COMM, IERR ) NPARTSASS_COL = NPARTSASS_MASTER CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT, 1, & MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) IF (JBEG_BLOCK.EQ.1) THEN NCOL_GEMM_FR = NEWCOL_RECV - NPIV SHIFT_LPOS = NPIV SHIFT_UPOS = NPIV ELSE SHIFT_LPOS = JBEG_BLOCK - 1 IF (LR_ACTIVATED) THEN NCOL_GEMM_FR = -99993 SHIFT_UPOS = -99994 ELSE NCOL_GEMM_FR = NEWCOL_RECV SHIFT_UPOS = 0 ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NSLAVES_TOT, 1, & MPI_INTEGER, COMM, IERR ) KEEP_BEGS_BLR_LS =.FALSE. NULLIFY(BEGS_BLR_LS) KEEP_BEGS_BLR_COL =.FALSE. NULLIFY(BEGS_BLR_COL) KEEP_BLR_LS =.FALSE. NULLIFY(BLR_LS) NULLIFY(BEGS_BLR_LM) IF ( LR_ACTIVATED ) THEN LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8) LD_BLOCFACTO = max(NPIV+NELIM,1) ELSE LA_BLOCFACTO = int(NPIV,8) * int(NEWCOL_RECV,8) LD_BLOCFACTO = max(NEWCOL_RECV,1) ENDIF IF (LR_ACTIVATED) THEN DYNAMIC_ALLOC = .TRUE. ELSE DYNAMIC_ALLOC = .FALSE. ENDIF IF ( .NOT. DYNAMIC_ALLOC ) THEN IF ( NPIV .EQ. 0 ) THEN IPIV = 1 POSBLOCFACTO = 1_8 ELSE CALL SMUMPS_GET_SIZE_NEEDED( & NPIV, LA_BLOCFACTO, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ),COMP,DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LA_BLOCFACTO LRLUS = LRLUS - LA_BLOCFACTO KEEP8(69) = KEEP8(69) + LA_BLOCFACTO KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LA_BLOCFACTO IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ELSE ALLOCATE(DYN_PIVINFO(max(1,NPIV)), & DYN_BLOCFACTO(max(1_8,LA_BLOCFACTO)), & stat=allocok) IF (allocok.GT.0) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR DYN_PIVINFO and DYN_BLOCFACTO IN ", & "SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 CALL MUMPS_SET_IERROR(max(1_8,LA_BLOCFACTO), IERROR) GOTO 700 ENDIF KEEP8(130)=KEEP8(130)+max(1_8,LA_BLOCFACTO) KEEP8(131)=max(KEEP8(130),KEEP8(131)) KEEP8(73) = KEEP8(73) + max(1_8,LA_BLOCFACTO) KEEP8(69) = KEEP8(69) + max(1_8,LA_BLOCFACTO) KEEP8(74) = max(KEEP8(74), KEEP8(73)) KEEP8(68) = max(KEEP8(68), KEEP8(69)) POSBLOCFACTO = 1_8 IPIV = 1 ENDIF IF (NPIV.GT.0) THEN IF (DYNAMIC_ALLOC) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & DYN_PIVINFO, NPIV, & MPI_INTEGER, COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) ENDIF IF (DYNAMIC_ALLOC) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & DYN_BLOCFACTO, int(LA_BLOCFACTO), & MPI_REAL, & COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), int(LA_BLOCFACTO), & MPI_REAL, & COMM, IERR ) ENDIF IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_LM, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_LM(max(NB_BLR_LM,1)), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BLR_LM IN ", & "SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = max(NB_BLR_LM,1) GOTO 700 END IF ALLOCATE(BEGS_BLR_LM(NB_BLR_LM+2), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BEGS_BLR_LM IN ", & "SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NB_BLR_LM+2 GOTO 700 END IF CALL SMUMPS_MPI_UNPACK_LR_PARTIAL( & BUFR, LBUFR, LBUFR_BYTES, POSITION, NPIV, NELIM, & 'V', BLR_LM, NB_BLR_LM, JBEG_BLOCK, & BEGS_BLR_LM(1), KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) THEN CALL SMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 550 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 + KEEP(IXSZ)) .EQ. 0 ) THEN DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 550 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) CALL SMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL SMUMPS_ASM_SLAVE_ARROWHEADS(INODE, STEP(INODE), & N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, & LRGROUPS) ELSE CALL SMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 +KEEP(IXSZ)) NCOL1 = IW( IOLDPS + 3 +KEEP(IXSZ)) + IW( IOLDPS + KEEP(IXSZ)) IF (JBEG_BLOCK.EQ.1) THEN NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) ELSE NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) - NPIV ENDIF LASTBL_INPANEL = JBEG_BLOCK+NEWCOL_RECV.GT.NASS1-NPIV1 LASTBL_INLASTPANEL = LASTPANEL .AND. LASTBL_INPANEL NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) NSLAVES_FOLLOW = NSLAV1 - XTRA_SLAVES_SYM HS = 6 + NSLAV1 + KEEP(IXSZ) IF ( LASTBL_INLASTPANEL ) THEN TO_UPDATE_CPT_END = ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & NB_BLOC_FAC END IF IF (NPIV.GT.0) THEN IF (JBEG_BLOCK.EQ.1) THEN ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1 DO I = 1, NPIV IF (DYNAMIC_ALLOC) THEN PIVI = abs(DYN_PIVINFO(I)) ELSE PIVI = abs(IW(IPIV+I-1)) ENDIF IF (PIVI.EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+PIVI) IW(ICT11+PIVI) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + PIVI - 1,8) CALL sswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO IF (LR_ACTIVATED) THEN LUIP21K = 1_8 ELSE LUIP21K=int(NPIV,8)*int(NROW1,8) ENDIF KEEP430_LOC=min(KEEP(430),1) CALL SMUMPS_DM_ALLOC_S_WK( UIP21K, LUIP21K, allocok, & KEEP430_LOC, KEEP(35) ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NPIV * NROW1 GOTO 700 END IF KEEP8(130)=KEEP8(130)+LUIP21K KEEP8(131)=max(KEEP8(130),KEEP8(131)) KEEP8(73) = KEEP8(73) + LUIP21K KEEP8(69) = KEEP8(69) + LUIP21K KEEP8(74) = max(KEEP8(74), KEEP8(73)) KEEP8(68) = max(KEEP8(68), KEEP8(69)) IF (.NOT.LR_ACTIVATED) THEN ENDIF ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 ) THEN ALLOCATE( LIST_SLAVES_FOLLOW ( NSLAVES_FOLLOW ), & stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR LIST_SLAVES_FOLLOW & IN SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NSLAVES_FOLLOW GOTO 700 END IF LIST_SLAVES_FOLLOW(1:NSLAVES_FOLLOW)= & IW(IOLDPS+6+XTRA_SLAVES_SYM+KEEP(IXSZ): & IOLDPS+5+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_FOLLOW) END IF IF ( (JBEG_BLOCK.EQ.1) .AND. & ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) & ) THEN IF (DYNAMIC_ALLOC) THEN CALL strsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & DYN_BLOCFACTO, LD_BLOCFACTO, & A_PTR(POSELT+int(NPIV1,8)), NCOL1) ELSE CALL strsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), LD_BLOCFACTO, & A_PTR(POSELT+int(NPIV1,8)), NCOL1) ENDIF ENDIF IF (JBEG_BLOCK.EQ.1) THEN IF (.NOT.LR_ACTIVATED.OR.KEEP(475).EQ.0) THEN NB = KEEP(360) !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = (NOMP.GT.1.AND. (int(NROW1/NB).GE.NOMP)) !$OMP PARALLEL DO !$OMP& PRIVATE (IB, II, IBEG, IEND, I, J, UPOS, LPOS, DPOS, !$OMP& PIVI, A11, A12, A22, POSPV1, POSPV2, !$OMP& OFFDAG, DETPIV, LPOS1, MULT1, MULT2 !$OMP& ) !$OMP& SCHEDULE(DYNAMIC,1) IF (OMP_FLAG) DO IB=1, NROW1, NB IBEG = IB IEND = min(IB+NB-1, NROW1) IF (.NOT.LR_ACTIVATED) THEN LPOS = POSELT + int(NPIV1,8) UPOS = 1_8 LPOS = LPOS + int((IBEG-1),8)*int(NCOL1,8) UPOS = UPOS + int((IBEG-1),8)*int(NPIV,8) DO II = IBEG, IEND DO J = 0, NPIV-1 UIP21K( UPOS+J ) = A_PTR(LPOS+J) ENDDO LPOS = LPOS + int(NCOL1,8) UPOS = UPOS + int(NPIV,8) END DO ENDIF LPOS = POSELT + int(NPIV1,8) LPOS = LPOS + int((IBEG-1),8)*int(NCOL1,8) IF (DYNAMIC_ALLOC) THEN DPOS = 1_8 ELSE DPOS = POSBLOCFACTO ENDIF I = 1 DO IF(I .GT. NPIV) EXIT IF (DYNAMIC_ALLOC) THEN PIVI = DYN_PIVINFO(I) ELSE PIVI = IW(IPIV+I-1) ENDIF IF(PIVI .GT. 0) THEN IF (DYNAMIC_ALLOC) THEN A11 = ONE/DYN_BLOCFACTO(DPOS) ELSE A11 = ONE/A(DPOS) ENDIF CALL sscal( IEND-IBEG+1, A11, A_PTR(LPOS), NCOL1 ) LPOS = LPOS + 1_8 DPOS = DPOS + int(LD_BLOCFACTO + 1,8) I = I+1 ELSE POSPV1 = DPOS POSPV2 = DPOS+ int(LD_BLOCFACTO + 1,8) OFFDAG = POSPV1+1_8 IF (DYNAMIC_ALLOC) THEN A11 = DYN_BLOCFACTO(POSPV1) A22 = DYN_BLOCFACTO(POSPV2) A12 = DYN_BLOCFACTO(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = DYN_BLOCFACTO(POSPV2)/DETPIV A12 = -A12/DETPIV ELSE A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV ENDIF LPOS1 = LPOS DO J2 = 1, IEND-IBEG+1 MULT1 = A11*A_PTR(LPOS1)+A12*A_PTR(LPOS1+1_8) MULT2 = A12*A_PTR(LPOS1)+A22*A_PTR(LPOS1+1_8) A_PTR(LPOS1) = MULT1 A_PTR(LPOS1+1_8) = MULT2 LPOS1 = LPOS1 + int(NCOL1,8) ENDDO LPOS = LPOS + 2_8 DPOS = POSPV2 + int(LD_BLOCFACTO + 1,8) I = I+2 ENDIF ENDDO ENDDO !$OMP END PARALLEL DO ENDIF ENDIF ENDIF COMPRESS_CB = .FALSE. IF ( LR_ACTIVATED ) THEN NSLAVES_PREC = NSLAVES_TOT - NSLAVES_FOLLOW -1 COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) ENDIF IF (NROW1.GT.0) THEN IF (NPIV.GT.0.AND.NROW1.LE.0) THEN CALL MUMPS_ABORT() ENDIF IF (LR_ACTIVATED) THEN IF (NPIV1.NE.0.OR.JBEG_BLOCK.NE.1) THEN CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_LS) KEEP_BEGS_BLR_LS = .TRUE. NB_BLR_LS = size(BEGS_BLR_LS) - 2 NPARTSCB = NB_BLR_LS ELSE CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) CALL REGROUPING2(BEGS_BLR_LS, NPARTSASS, NASS1, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472), & NCOL1, KEEP(1)) NB_BLR_LS = NPARTSCB ENDIF IF (NPIV.GT.0) THEN call MAX_CLUSTER(BEGS_BLR_LM(2:NB_BLR_LM+2),NB_BLR_LM, & MAXI_CLUSTER_LM) ELSE MAXI_CLUSTER_LM = 0 ENDIF call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) MAXI_CLUSTER=max(MAXI_CLUSTER_LS,MAXI_CLUSTER_LM,NPIV) IF (COMPRESS_CB) THEN IF (NPIV1.EQ.0.AND.JBEG_BLOCK.EQ.1) THEN CALL GET_CUT(IW(IOLDPS+HS+NROW1:IOLDPS+HS+NROW1+NCOL1-1), & NASS1, & NCOL1-NASS1, LRGROUPS, NPARTSCB_COL, & NPARTSASS_COL, BEGS_BLR_COL) CALL REGROUPING2(BEGS_BLR_COL, NPARTSASS_COL, NASS1, & NPARTSCB_COL, & NCOL1-NASS1, KEEP(488), .FALSE., KEEP(472), & NCOL1, KEEP(1)) NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL IF (NPARTSASS_MASTER.NE.NPARTSASS_COL) THEN ALLOCATE(BEGS_BLR_COL_TMP( & size(BEGS_BLR_COL)-NPARTSASS_COL+NPARTSASS_MASTER), & stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BEGS_BLR_COL_TMP in", & "SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = size(BEGS_BLR_COL) & -NPARTSASS_COL+NPARTSASS_MASTER GOTO 700 END IF IF ( size(BEGS_BLR_COL).GT. NPARTSASS_COL) THEN DO II=1, size(BEGS_BLR_COL) - NPARTSASS_COL BEGS_BLR_COL_TMP (II+NPARTSASS_MASTER) = & BEGS_BLR_COL(II+NPARTSASS_COL) ENDDO ENDIF DO II= 1, NPARTSASS_MASTER BEGS_BLR_COL_TMP (II) = & BEGS_BLR_COL(max(NPARTSASS_COL,1)+1) ENDDO DEALLOCATE(BEGS_BLR_COL) BEGS_BLR_COL => BEGS_BLR_COL_TMP NPARTSASS_COL = NPARTSASS_MASTER NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL ENDIF ELSE CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_COL ) KEEP_BEGS_BLR_COL = .TRUE. NB_BLR_COL = size(BEGS_BLR_COL) - 1 NPARTSCB_COL = NB_BLR_COL - NPARTSASS_COL ENDIF ELSE NULLIFY(BEGS_BLR_COL) ENDIF IF (NPIV1.EQ.0.AND.(JBEG_BLOCK.EQ.1)) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR NB_ACCESSES_INIT = 1 IF ( (KEEP(486).EQ.2) & ) THEN NB_ACCESSES_INIT = huge(NPARTSASS_MASTER) END IF INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 700 CALL SMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .TRUE., & .TRUE., & NPARTSASS_COL, & BEGS_BLR_LS, BEGS_BLR_COL, NB_ACCESSES_INIT, & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 700 ENDIF LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF CURRENT_BLR = 1 IF (JBEG_BLOCK.EQ.1.AND.NPIV.GT.0) THEN CURRENT_BLR = 1 ALLOCATE(BLR_LS(NB_BLR_LS), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_LS GOTO 700 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL SMUMPS_COMPRESS_PANEL_I_NOOPT & (A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & DKEEP(8), KEEP(466), 0, & KEEP(473), BLR_LS(1), & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP8, & OMP_NUM) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 300 IF (KEEP(475).GE.1) THEN IF (DYNAMIC_ALLOC) THEN CALL SMUMPS_BLR_PANEL_LRTRSM( & DYN_BLOCFACTO, LA_BLOCFACTO, 1_8, & LD_BLOCFACTO, -6666, & NB_BLR_LS+1, & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1, & 2, 1, 0, & .TRUE., & DYN_PIVINFO, OFFSET_IW=1) ELSE CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, & LD_BLOCFACTO, -6666, & NB_BLR_LS+1, & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1, & 2, 1, 0, & .TRUE., & IW, OFFSET_IW=IPIV) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (KEEP(486).NE.2) THEN CALL SMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A_PTR(POSELT), LA_PTR, 1_8, & NCOL1, NCOL1, & .TRUE., & NPIV1+1, & 1, & NB_BLR_LS+1, BLR_LS(1), CURRENT_BLR, 'V', 1) ENDIF ENDIF 300 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & (OOCWRITE_COMPATIBLE_WITH_BLR .OR. NPIV.EQ.0) & .AND. (JBEG_BLOCK.EQ.1) & ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTPANEL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) LAST_CALL = .FALSE. CALL SMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L, & A_PTR(POSELT), & LA_PTR, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG_OOC, LAST_CALL) IF ( IFLAG_OOC .LT. 0 )THEN IFLAG = IFLAG_OOC GOTO 700 ENDIF ENDIF IF (NPIV.GT.0) THEN IF (LR_ACTIVATED) THEN IF (JBEG_BLOCK.NE.1) THEN CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_LS) KEEP_BLR_LS = .TRUE. ENDIF IF (NELIM.GT.0.AND.JBEG_BLOCK.EQ.1) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = 1_8+int(SHIFT_UPOS,8) LPOS = LPOS2 + int(SHIFT_LPOS,8) IF (DYNAMIC_ALLOC) THEN CALL SMUMPS_BLR_UPD_NELIM_VAR_L_I( & DYN_BLOCFACTO, LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1, & CURRENT_BLR+1, NELIM, 'N') ELSE CALL SMUMPS_BLR_UPD_NELIM_VAR_L_I( & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1, & CURRENT_BLR+1, NELIM, 'N') ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif IF (DYNAMIC_ALLOC) THEN CALL SMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, NROW1, JBEG_BLOCK, & DYN_BLOCFACTO, LA_BLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1, & BLR_LM(1), NPIV1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & BLR_LS(1), 0, & CURRENT_BLR, CURRENT_BLR, & DYN_PIVINFO, & BLOCKLR, & MAXI_CLUSTER, OMP_NUM, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ELSE CALL SMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, NROW1, JBEG_BLOCK, & A(POSBLOCFACTO), LA_BLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1, & BLR_LM(1), NPIV1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & BLR_LS(1), 0, & CURRENT_BLR, CURRENT_BLR, & IW(IPIV), & BLOCKLR, & MAXI_CLUSTER, OMP_NUM, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF IF (IFLAG.LT.0) GOTO 400 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 CALL UPD_MRY_LU_LRGAIN(BLR_LS, NPARTSCB & ) CALL DEALLOC_BLR_PANEL(BLR_LM, NB_BLR_LM, KEEP8, KEEP(34)) DEALLOCATE(BLR_LM) IF ( JBEG_BLOCK.EQ.1 & ) & THEN IF ( (KEEP(486).EQ.2) & ) THEN NB_ACCESSES_LEFT_INIT = huge(NB_ACCESSES_LEFT_INIT) ELSE NB_ACCESSES_LEFT_INIT = NCOL1 - NPIV1 - NROW1 ENDIF CALL SMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_LS, NB_ACCESSES_LEFT_INIT) KEEP_BLR_LS = .TRUE. ENDIF ELSE IF (NPIV .GT. 0 .AND. NCOL_GEMM_FR.GT.0)THEN LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(SHIFT_LPOS,8) IF (DYNAMIC_ALLOC) THEN UPOS = 1_8+int(SHIFT_UPOS,8) CALL sgemm('N','N', NCOL_GEMM_FR, NROW1, NPIV, & ALPHA, DYN_BLOCFACTO(UPOS), NEWCOL_RECV, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ELSE UPOS = POSBLOCFACTO+int(SHIFT_UPOS,8) CALL sgemm('N','N', NCOL_GEMM_FR, NROW1, NPIV, & ALPHA,A(UPOS), NEWCOL_RECV, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ENDIF ENDIF IF (JBEG_BLOCK.EQ.1) THEN DPOS = POSELT + int(NCOL1 - NROW1,8) #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1 .OR. & ( KEEP(421) .GT. 0 .AND. NROW1 .GT. KEEP(421) ) ) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = 1_8 CALL sgemmt( 'U', 'T', 'N', NROW1, NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A_PTR( LPOS2 ), NCOL1, ONE, & A_PTR( DPOS ), NCOL1 ) ELSE #endif IF ( NROW1 .GT. KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NROW1 ENDIF IF ( NROW1 .GT. 0 ) THEN DO IROW = 1, NROW1, BLSIZE Block = min( BLSIZE, NROW1 - IROW + 1 ) DPOS = POSELT + int(NCOL1 - NROW1,8) & + int( IROW - 1, 8 ) * int( NCOL1 + 1, 8 ) LPOS2 = POSELT + int(NPIV1,8) & + int( IROW - 1, 8 ) * int( NCOL1, 8 ) UPOS = int( IROW - 1, 8 ) * int(NPIV, 8) + 1_8 DO I = 1, Block CALL sgemv( 'T', NPIV, Block-I+1, ALPHA, & A_PTR( LPOS2 + int(I - 1,8) * int(NCOL1,8) ), NCOL1, & UIP21K( UPOS + int(NPIV,8) * int( I - 1, 8 ) ), & 1, ONE, A_PTR(DPOS+int(NCOL1+1,8)*int(I-1,8)),NCOL1 ) END DO IF ( NROW1-IROW+1-Block .ne. 0 ) & CALL sgemm( 'T', 'N', Block, NROW1-IROW+1-Block, & NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A_PTR( LPOS2 + int(Block,8) * int(NCOL1,8) ), NCOL1, & ONE, & A_PTR( DPOS + int(Block,8) * int(NCOL1,8) ), NCOL1 ) ENDDO ENDIF #if defined(GEMMT_AVAILABLE) ENDIF #endif ENDIF ENDIF IF (LASTBL_INPANEL) THEN FLOP1 = dble(NROW1) * dble(NPIV) * & dble( 2 * (NASS1-NPIV1) - NPIV + NROW1 +1 ) FLOP1 = -FLOP1 CALL MUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF ENDIF IF (JBEG_BLOCK.EQ.1) THEN IW(IOLDPS+KEEP(IXSZ)) = IW(IOLDPS+KEEP(IXSZ)) - NPIV IW(IOLDPS+3+KEEP(IXSZ)) = IW(IOLDPS+3+KEEP(IXSZ)) + NPIV ENDIF IF (LASTBL_INLASTPANEL) THEN IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+3+KEEP(IXSZ)) ENDIF IF ( .NOT. LR_ACTIVATED ) THEN IF (DYNAMIC_ALLOC) THEN IF (allocated(DYN_PIVINFO) ) DEALLOCATE(DYN_PIVINFO) IF (allocated(DYN_BLOCFACTO)) THEN KEEP8(130) = KEEP8(130)-max(1_8,LA_BLOCFACTO) DEALLOCATE(DYN_BLOCFACTO) KEEP8(69) = KEEP8(69) - max(1_8,LA_BLOCFACTO) KEEP8(73) = KEEP8(73) - max(1_8,LA_BLOCFACTO) ENDIF ELSE LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO IWPOS = IWPOS - NPIV CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 & .AND. JBEG_BLOCK.EQ.1 ) THEN IPOSK = NPIV1 + 1 JPOSK = NCOL1 - NROW1 + 1 NPIVSENT = NPIV BLFAC_NBCOLS_ALREADY_SENT = 0 BLFAC_NBLRB_ALREADY_SENT = 0 IERR = -1 DO WHILE ( IERR .eq. -1 ) IF (DYNAMIC_ALLOC) THEN CALL SMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, LUIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & BLFAC_NBCOLS_ALREADY_SENT, BLFAC_NBLRB_ALREADY_SENT, & NOTHING_WAS_SENT, & DYN_BLOCFACTO, LA_BLOCFACTO, & 1_8, LD_BLOCFACTO, & DYN_PIVINFO, MAXI_CLUSTER, & IERR, IERROR ) ELSE CALL SMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, LUIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & BLFAC_NBCOLS_ALREADY_SENT, BLFAC_NBLRB_ALREADY_SENT, & NOTHING_WAS_SENT, & A, LA, & POSBLOCFACTO, LD_BLOCFACTO, & IW(IPIV), MAXI_CLUSTER, & IERR, IERROR ) ENDIF IF (IERR.EQ.-13) THEN IFLAG = IERR IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE within SMUMPS_BUF_SEND_BLFAC_SLAVE", & " during SMUMPS_PROCESS_SYM_BLOCFACTO", IERROR GOTO 700 ENDIF IF (IERR .EQ. -1 .AND. NOTHING_WAS_SENT) THEN IOLDPS = PTRIST(STEP(INODE)) IF ( IW(IOLDPS+6+KEEP(IXSZ)) .eq. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN COUNTER_WAS_HUGE=.TRUE. IW(IOLDPS+6+KEEP(IXSZ)) = 1 ELSE COUNTER_WAS_HUGE=.FALSE. ENDIF TO_UPDATE_CPT_RECUR = & ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & (2*NASS1/KEEP(6)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) - TO_UPDATE_CPT_RECUR - 10 BLOCKING = .FALSE. SET_IRECV= .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + TO_UPDATE_CPT_RECUR + 10 IF ( COUNTER_WAS_HUGE .AND. & IW(IOLDPS+6+KEEP(IXSZ)).EQ.1 ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = huge(IW(IOLDPS+6+KEEP(IXSZ))) ENDIF IF ( IFLAG .LT. 0 ) GOTO 550 END IF END DO IF ( IERR .eq. -2 ) THEN IF (LP > 0 ) THEN WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING & SMUMPS_PROCESS_SYM_BLOCFACTO" ENDIF IFLAG = -17 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF IF ( IERR .eq. -3 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING & SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -20 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF DEALLOCATE(LIST_SLAVES_FOLLOW) END IF IF ( LR_ACTIVATED ) THEN IF (NPIV.GT.0 & .AND. KEEP(486).EQ.3 & ) THEN IOLDPS = PTRIST(STEP(INODE)) CALL SMUMPS_BLR_DEC_AND_TRYFREE_L(IW(IOLDPS+XXF),IPANEL, & KEEP8, KEEP(34), NEWCOL_RECV) ENDIF IF (DYNAMIC_ALLOC) THEN IF (allocated(DYN_PIVINFO)) DEALLOCATE(DYN_PIVINFO) IF (allocated(DYN_BLOCFACTO)) THEN KEEP8(130) = KEEP8(130)-max(1_8,LA_BLOCFACTO) DEALLOCATE(DYN_BLOCFACTO) ENDIF ELSE IF (NPIV .GT. 0) THEN LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO IWPOS = IWPOS - NPIV CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF ( NPIV .NE. 0 ) THEN IF (associated(UIP21K)) THEN CALL SMUMPS_DM_FREE_S_WK( UIP21K, KEEP430_LOC ) NULLIFY( UIP21K ) KEEP8(130) = KEEP8(130)-LUIP21K KEEP8(69) = KEEP8(69) - LUIP21K KEEP8(73) = KEEP8(73) - LUIP21K ENDIF ENDIF IOLDPS = PTRIST(STEP(INODE)) IF (LR_ACTIVATED ) THEN COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) ENDIF CALL SMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) IF (LASTBL_INLASTPANEL) THEN IF ( KEEP(486) .NE. 0) THEN IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = IW(IOLDPS+6+KEEP(IXSZ)) & - TO_UPDATE_CPT_END & - 1 END IF IF ( IW(IOLDPS+6+KEEP(IXSZ) ) .eq. 0 & .and. KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 & .and. NSLAVES_TOT.NE.1 ) THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) CALL MUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_SYM_BLOCFACTO.' IFLAG = -99 GOTO 700 END IF ENDIF IF (IW(IOLDPS+6+KEEP(IXSZ)) .eq. 0 & ) THEN IOLDPS = PTRIST(STEP(INODE)) NELIM = IW( IOLDPS + 4 + KEEP(IXSZ)) - & IW( IOLDPS + 3 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) IF (LR_ACTIVATED) THEN IF (COMPRESS_CB) THEN allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_COL), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_COL) GOTO 700 ENDIF DO II=1,NB_BLR_LS DO JJ=1,NB_BLR_COL-NPARTSASS_COL CB_LRB(II,JJ)%M=0 CB_LRB(II,JJ)%N=0 NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL SMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL SMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) NFS4FATHER = max(NFS4FATHER,0) + NELIM ENDIF ALLOCATE(M_ARRAY(max(1,NFS4FATHER)), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR M_ARRAY ", & "SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = max(1,NFS4FATHER) ENDIF BEGS_BLR_COL(1+NPARTSASS_COL) = & BEGS_BLR_COL(1+NPARTSASS_COL) - NELIM CALL MAX_CLUSTER( & BEGS_BLR_COL(max(NPARTSASS_MASTER,1)+1:NB_BLR_COL+1), & NB_BLR_COL-max(NPARTSASS_MASTER,1),MAXI_CLUSTER_COL & ) MAXI_CLUSTER=max(MAXI_CLUSTER_LS, MAXI_CLUSTER_COL) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF NBROWSinF = 0 NVSCHUR_K253 = 0 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN CALL SMUMPS_COMPUTE_NBROWSinF ( & N, INODE, FPERE, KEEP, & IOLDPS, HS, & IW, LIW, & NROW1, NCOL1, NPIV1, & NELIM, NFS4FATHER, & NBROWSinF & ) IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) ) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL SMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR_K253 ) ELSE IF (KEEP(253).NE.0) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL SMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & 0, & IW(IROW_L), & PERM, NVSCHUR_K253 ) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 700 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL SMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_LS, NB_BLR_COL-NPARTSASS_COL, & NPARTSASS_COL, & NROW1, NCOL1-NPIV1, INODE, & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV1, NVSCHUR_K253, KEEP(1), & M_ARRAY & , NELIM, NBROWSinF & ) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 650 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL SMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF DEALLOCATE(M_ARRAY) 650 CONTINUE ENDIF IF (IFLAG.LT.0) GOTO 700 ENDIF CALL SMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, roota, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF GOTO 550 700 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 550 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (.NOT.KEEP_BEGS_BLR_LS) THEN IF (associated(BEGS_BLR_LS)) DEALLOCATE(BEGS_BLR_LS) ENDIF IF (.NOT.KEEP_BLR_LS) THEN IF (associated(BLR_LS)) THEN CALL DEALLOC_BLR_PANEL(BLR_LS, NB_BLR_LS, KEEP8, KEEP(34)) DEALLOCATE(BLR_LS) ENDIF ENDIF IF (associated(BEGS_BLR_LM)) DEALLOCATE(BEGS_BLR_LM) IF (.NOT.KEEP_BEGS_BLR_COL) THEN IF (COMPRESS_CB) THEN IF (associated(BEGS_BLR_COL)) THEN DEALLOCATE( BEGS_BLR_COL) ENDIF ENDIF ENDIF ENDIF KEEP(174)=KEEP(174)-1 RETURN END SUBROUTINE SMUMPS_PROCESS_SYM_BLOCFACTO MUMPS_5.8.1/src/sfac_process_end_facto_slave.F0000664000175000017500000002735515042446437021227 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE SMUMPS_END_FACTO_SLAVE( & COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, roota, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_LOAD #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif USE SMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER INODE, FPERE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER COMM, MYID INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER N INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP, IFLAG, IERROR INTEGER PERM(N) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER ND( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER FRERE(KEEP(28)) INTEGER INTARR( KEEP8(27) ) REAL DBLARR( KEEP8(26) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER MRS_INODE INTEGER MRS_ISON INTEGER MRS_NSLAVES_PERE INTEGER MRS_NASS_PERE INTEGER MRS_NFRONT_PERE INTEGER MRS_LMAP INTEGER MRS_NFS4FATHER INTEGER, POINTER, DIMENSION(:) :: MRS_SLAVES_PERE, MRS_TROW INTEGER ITYPE2 INTEGER IHDR_REC PARAMETER (ITYPE2=2) INTEGER IOLDPS, NROW, LDA INTEGER NPIV, LCONT, NELIM, NASS, NCOL_TO_SEND, & SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER(8) :: SHIFT_VAL_SON INTEGER(8) :: MEM_GAIN INTEGER(8) :: DYN_SIZE #if ! defined(NO_FDM_MAPROW) TYPE(MAPROW_STRUC_T), POINTER :: MRS #endif INTEGER :: IWHANDLER_SAVE INTEGER :: LRSTATUS LOGICAL :: CB_STORED_IN_BLRSTRUC, COMPRESS_CB IF (KEEP(50).EQ.0) THEN IHDR_REC=6 ELSE IHDR_REC=8 ENDIF IOLDPS = PTRIST(STEP(INODE)) IWHANDLER_SAVE = IW(IOLDPS+XXA) LRSTATUS = IW(IOLDPS+XXLR) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND..NOT.COMPRESS_CB) THEN CALL SMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34)) ENDIF IW(IOLDPS+XXS)=S_ALL IOLDPS = PTRIST(STEP(INODE)) LRSTATUS = IW(IOLDPS+XXLR) IF ( (KEEP(214).EQ.1) & ) THEN CALL SMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP,KEEP8, DKEEP, ITYPE2 & ) IOLDPS = PTRIST(STEP(INODE)) IF (KEEP(38).NE.FPERE) THEN CB_STORED_IN_BLRSTRUC = .FALSE. LRSTATUS = IW(IOLDPS+XXLR) IF ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) THEN CB_STORED_IN_BLRSTRUC = .TRUE. IW(IOLDPS+XXS) = S_NOLNOCB CALL MUMPS_GETI8(MEM_GAIN, IW(IOLDPS+XXR)) LRLUS = LRLUS + MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ELSE IW(IOLDPS+XXS)=S_NOLCBNOCONTIG CALL MUMPS_GETI8( DYN_SIZE, IW(IOLDPS+XXD)) IF (DYN_SIZE .GT.0) THEN ELSE IF (KEEP(216).NE.3) THEN MEM_GAIN=int(IW( IOLDPS + 2 + KEEP(IXSZ) ),8)* & int(IW( IOLDPS + 3 + KEEP(IXSZ) ),8) LRLUS = LRLUS+MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ENDIF ENDIF ENDIF CALL MUMPS_GETI8( DYN_SIZE, IW(IOLDPS+XXD)) IF (DYN_SIZE > 0_8) THEN ELSE IF (KEEP(216).EQ.2) THEN IF (FPERE.NE.KEEP(38)) THEN IF (.NOT. CB_STORED_IN_BLRSTRUC) THEN CALL SMUMPS_MAKECBCONTIG(A,LA,PTRAST(STEP(INODE)), & IW( IOLDPS + 2 + KEEP(IXSZ) ), & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 3 + KEEP(IXSZ) )+ & IW( IOLDPS + KEEP(IXSZ) ), 0, & IW( IOLDPS + XXS ), 0_8 ) IW(IOLDPS+XXS)=S_NOLCBCONTIG ENDIF ENDIF ENDIF ENDIF IF ( KEEP(38).EQ.FPERE) THEN LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV NCOL_TO_SEND = LCONT-NELIM SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NASS SHIFT_VAL_SON = int(NASS,8) LDA = LCONT + NPIV IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOTBAND_INIT) THEN IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_REC_CONTSTATIC ELSE ENDIF CALL SMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTRIST, PTRAST, & root, roota, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, & ROOT_CONT_STATIC, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE.,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS, 0, 0, 0 & ) IF ( IFLAG < 0 ) GOTO 600 IF (NELIM.EQ.0) THEN IF (KEEP(214).EQ.2) THEN CALL SMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, & COMM, KEEP,KEEP8,DKEEP, ITYPE2 & ) ENDIF CALL SMUMPS_FREE_BAND( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP, KEEP8, ITYPE2 & ) ELSE IOLDPS = PTRIST(STEP(INODE)) IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOT2SON_CALLED) THEN CALL SMUMPS_FREE_BAND( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP, KEEP8, ITYPE2 & ) ELSE IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_ROOTBAND_INIT IF (KEEP(214).EQ.1.AND.KEEP(216).NE.3) THEN IW(IOLDPS+XXS)=S_NOLCBNOCONTIG38 CALL SMUMPS_SIZEFREEINREC( IW(IOLDPS), & LIW-IOLDPS+1, & MEM_GAIN, KEEP(IXSZ) ) LRLUS = LRLUS + MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) IF (KEEP(216).EQ.2) THEN CALL SMUMPS_MAKECBCONTIG(A,LA,PTRAST(STEP(INODE)), & IW( IOLDPS + 2 + KEEP(IXSZ) ), & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 3 + KEEP(IXSZ) )+ & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 4 + KEEP(IXSZ) ) - & IW( IOLDPS + 3 + KEEP(IXSZ) ), & IW( IOLDPS + XXS ),0_8) IW(IOLDPS+XXS)=S_NOLCBCONTIG38 ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE #if ! defined(NO_FDM_MAPROW) IOLDPS = PTRIST(STEP(INODE)) IF (FPERE .NE. KEEP(38)) THEN IF (MUMPS_FMRD_IS_MAPROW_STORED( IW(IOLDPS+XXA) )) THEN CALL MUMPS_FMRD_RETRIEVE_MAPROW( IW(IOLDPS+XXA), MRS ) IF (FPERE .NE. MRS%INODE) THEN WRITE(*,*) " Internal error 1 in SMUMPS_END_FACTO_SLAVE", & INODE, MRS%INODE, FPERE CALL MUMPS_ABORT() ENDIF MRS_INODE = MRS%INODE MRS_ISON = MRS%ISON MRS_NSLAVES_PERE = MRS%NSLAVES_PERE MRS_NASS_PERE = MRS%NASS_PERE MRS_NFRONT_PERE = MRS%NFRONT_PERE MRS_LMAP = MRS%LMAP MRS_NFS4FATHER = MRS%NFS4FATHER MRS_SLAVES_PERE => MRS%SLAVES_PERE MRS_TROW => MRS%TROW CALL SMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & MRS_INODE, MRS_ISON, & MRS_NSLAVES_PERE, MRS_SLAVES_PERE(1), & MRS_NFRONT_PERE, MRS_NASS_PERE, MRS_NFS4FATHER, & MRS_LMAP, MRS_TROW(1), & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) CALL MUMPS_FMRD_FREE_MAPROW_STRUC( IWHANDLER_SAVE ) ENDIF ENDIF #endif RETURN END SUBROUTINE SMUMPS_END_FACTO_SLAVE MUMPS_5.8.1/src/mumps_ooc_common.F0000664000175000017500000001112015042446423016704 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER, PARAMETER :: FCT = 0 INTEGER, PARAMETER, PUBLIC :: TYPEF_INVALID = -999999 INTEGER, PUBLIC :: TYPEF_L, TYPEF_U, TYPEF_CB INTEGER OOC_NB_FILE_TYPE, OOC_FCT_TYPE INTEGER, PARAMETER :: FILENAMELENGTH=1300 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 :: PROCNODE_OOC => null() INTEGER, DIMENSION(:),POINTER :: STEP_OOC => null() INTEGER, SAVE :: MYID_OOC,SLAVEF_OOC,LOW_LEVEL_STRAT_IO INTEGER(8), SAVE :: HBUF_SIZE, DIM_BUF_IO INTEGER ERR_STR_OOC_MAX_LEN PARAMETER(ERR_STR_OOC_MAX_LEN = 512) CHARACTER(len=1):: ERR_STR_OOC(ERR_STR_OOC_MAX_LEN) INTEGER DIM_ERR_STR_OOC TYPE IO_BLOCK INTEGER :: INODE LOGICAL :: MASTER INTEGER :: Typenode INTEGER :: NROW, NCOL, NFS LOGICAL :: Last INTEGER :: LastPiv INTEGER :: LastPanelWritten_L INTEGER :: LastPanelWritten_U INTEGER,POINTER,DIMENSION(:) :: INDICES END TYPE PUBLIC IO_BLOCK INTEGER, PUBLIC :: STRAT_WRITE_MAX, STRAT_TRY_WRITE PARAMETER (STRAT_WRITE_MAX=1, STRAT_TRY_WRITE=2) END MODULE MUMPS_OOC_COMMON SUBROUTINE MUMPS_OOC_CONVERT_2INTTOBIGINT(INT1,INT2,BIGINT) IMPLICIT NONE INTEGER INT1,INT2 INTEGER(8) BIGINT INTEGER(8) TMP1,TMP2,CONV PARAMETER (CONV=1073741824_8) TMP1=int(INT1,kind=kind(TMP1)) TMP2=int(INT2,kind=kind(TMP2)) BIGINT=(TMP1*CONV)+TMP2 RETURN END SUBROUTINE MUMPS_OOC_CONVERT_2INTTOBIGINT SUBROUTINE MUMPS_OOC_CONVERT_BIGINTTO2INT(INT1,INT2,BIGINT) IMPLICIT NONE INTEGER INT1,INT2 INTEGER(8) BIGINT INTEGER(8) TMP1,TMP2,CONV PARAMETER (CONV=1073741824_8) TMP1=BIGINT/CONV TMP2=mod(BIGINT,CONV) INT1=int(TMP1) INT2=int(TMP2) RETURN END SUBROUTINE MUMPS_OOC_CONVERT_BIGINTTO2INT SUBROUTINE MUMPS_OOC_INIT_FILETYPE & (TYPEF_L,TYPEF_U,TYPEF_CB,K201, K251, K50, & TYPEF_INVALID) IMPLICIT NONE INTEGER, intent(out):: TYPEF_L, TYPEF_U, TYPEF_CB INTEGER, intent(in) :: K201, K251, K50 INTEGER, intent(in) :: TYPEF_INVALID IF (K201 .EQ. 1 .AND. K50.EQ.0) THEN IF ( K251.NE.2 ) THEN TYPEF_L = 1 TYPEF_U = 2 TYPEF_CB = 3 ELSE TYPEF_U = 1 TYPEF_L = TYPEF_INVALID TYPEF_CB = 2 ENDIF ELSE TYPEF_L = 1 TYPEF_U = TYPEF_INVALID TYPEF_CB=2 ENDIF RETURN END SUBROUTINE MUMPS_OOC_INIT_FILETYPE INTEGER FUNCTION MUMPS_OOC_GET_FCT_TYPE & (FWDORBWD, MTYPE, K201, K50) USE MUMPS_OOC_COMMON INTEGER, intent(in) :: MTYPE, K201, K50 CHARACTER(len=1), intent(in) :: FWDORBWD IF ( (TYPEF_L .NE. 1 .AND. TYPEF_L .NE. TYPEF_INVALID) & .OR. (TYPEF_U .NE. 1 .AND. TYPEF_U .NE. 2 .AND. & TYPEF_U .NE. TYPEF_INVALID) ) THEN WRITE(*,*) "Internal error 1 in MUMPS_OOC_GET_FCT_TYPE", & TYPEF_L, TYPEF_U CALL MUMPS_ABORT() ENDIF IF (FWDORBWD .NE. 'F' .AND. FWDORBWD .NE. 'B') THEN WRITE(*,*) "Internal error in MUMPS_OOC_GET_FCT_TYPE,",FWDORBWD CALL MUMPS_ABORT() ENDIF IF (K201 .EQ. 1) THEN IF (FWDORBWD .EQ. 'F') THEN IF((MTYPE.NE.1).AND.(K50.EQ.0))THEN MUMPS_OOC_GET_FCT_TYPE=TYPEF_U ELSE MUMPS_OOC_GET_FCT_TYPE=TYPEF_L ENDIF ELSE IF(K50.EQ.0)THEN IF(MTYPE.NE.1)THEN MUMPS_OOC_GET_FCT_TYPE=TYPEF_L ELSE MUMPS_OOC_GET_FCT_TYPE=TYPEF_U ENDIF ELSE MUMPS_OOC_GET_FCT_TYPE=TYPEF_L ENDIF ENDIF ELSE MUMPS_OOC_GET_FCT_TYPE = 1 ENDIF RETURN END FUNCTION MUMPS_OOC_GET_FCT_TYPE MUMPS_5.8.1/src/mumps_type2_blocking.F0000664000175000017500000005045615042446423017506 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C INTEGER FUNCTION MUMPS_BLOC2_GET_NSLAVESMIN & ( SLAVEF, K48, K821, K50, & NFRONT, NCB, K375, K119) IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, K48, K50, NFRONT, NCB INTEGER, INTENT (IN) :: K375 INTEGER, INTENT (IN) :: K119 INTEGER(8), INTENT (IN) :: K821 INTEGER NSLAVESMIN, NASS, KMAX REAL Wmaster, Wtotal, Wmax INTEGER ACC,X REAL MUMPS_BLOC2_COUT INTEGER MUMPS_REG_GETKMAX EXTERNAL MUMPS_BLOC2_COUT, MUMPS_REG_GETKMAX KMAX = MUMPS_REG_GETKMAX( K821, NCB ) NASS = NFRONT - NCB NSLAVESMIN = 1 IF ( K48 .EQ.0 .OR. & (K48.EQ.5 .AND. (K119.EQ.1. OR.K50.EQ.0))) THEN NSLAVESMIN = max(NCB/max(1,KMAX),1) ELSE IF (K48 .EQ. 3 .OR.(K48.EQ.5 .AND.K50.NE.0) ) THEN Wmax = MUMPS_BLOC2_COUT(KMAX,NFRONT,NASS) Wtotal = MUMPS_BLOC2_COUT(NCB,NFRONT,NASS) Wmaster = real(NASS)*real(NASS)*real(NASS)/(3.0E0) IF ( Wmaster .GT. Wmax ) THEN NSLAVESMIN = max ( nint ( Wtotal / Wmaster ), 1 ) ELSE NSLAVESMIN = max ( nint ( Wtotal / Wmax ), 1 ) ENDIF IF (K48 .EQ. 5) THEN IF (K119.EQ.2) THEN NSLAVESMIN = max ( NSLAVESMIN/2, 1 ) ENDIF END IF ELSE IF (K48 .EQ. 4 ) THEN IF ( K821 > 0_8 ) THEN WRITE(*,*) 'Internal Error 1 in MUMPS_BLOC2_GET_NSLAVESMIN' CALL MUMPS_ABORT() ENDIF CALL MUMPS_ABORT_ON_OVERFLOW(K821, & "K821 too large in MUMPS_BLOC2_GET_NSLAVESMIN" ) KMAX=int(abs(K821)) IF(K50.EQ.0)THEN NSLAVESMIN = max(int( & (int(NCB,8)*int(NCB,8))/int(KMAX,8) & ),1) ELSE ACC=0 NSLAVESMIN=0 DO WHILE (ACC.NE.NCB) X=int((-real(NFRONT-NCB+ACC) & +sqrt(((real(NFRONT-NCB+ACC)* & real(NFRONT-NCB+ACC))+real(4)* & real(KMAX))))/ & real(2)) ACC=ACC+X NSLAVESMIN=NSLAVESMIN+1 IF (((NCB-ACC)*NCB).LT.KMAX)THEN ACC=NCB NSLAVESMIN=NSLAVESMIN+1 ENDIF ENDDO ENDIF ENDIF NSLAVESMIN = min ( NSLAVESMIN,(SLAVEF-1) ) MUMPS_BLOC2_GET_NSLAVESMIN = & min ( NSLAVESMIN, NCB ) IF (K375 .EQ. 1) THEN MUMPS_BLOC2_GET_NSLAVESMIN=1 ENDIF RETURN END FUNCTION MUMPS_BLOC2_GET_NSLAVESMIN INTEGER FUNCTION MUMPS_BLOC2_GET_NSLAVESMAX & ( SLAVEF, K48, K821, K50, & NFRONT, NCB, K375, K119 ) IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, K48, K50,NFRONT, NCB, K375, K119 INTEGER(8), INTENT(IN) :: K821 INTEGER NSLAVESMAX, KMAX, KMIN INTEGER NSLAVESMIN INTEGER MUMPS_REG_GETKMAX,MUMPS_GETKMIN, & MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NS_BLSIZE EXTERNAL MUMPS_REG_GETKMAX,MUMPS_GETKMIN, & MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NS_BLSIZE IF (K48 .eq. 0 .OR. K48.eq.3.OR.K48.EQ.5) THEN KMAX = MUMPS_REG_GETKMAX( K821, NCB ) KMIN = MUMPS_GETKMIN( K821, K50, KMAX, NCB) NSLAVESMAX = MUMPS_BLOC2_GET_NS_BLSIZE( & SLAVEF, K48, K50, KMIN, NFRONT, NCB ) ELSE NSLAVESMAX = SLAVEF-1 ENDIF NSLAVESMIN = MUMPS_BLOC2_GET_NSLAVESMIN( & SLAVEF, K48, K821, K50, NFRONT, NCB, K375, K119 ) NSLAVESMAX = max ( NSLAVESMAX, NSLAVESMIN ) MUMPS_BLOC2_GET_NSLAVESMAX = & min ( NSLAVESMAX, NCB ) IF (K375 .EQ. 1) THEN MUMPS_BLOC2_GET_NSLAVESMAX = SLAVEF-1 ENDIF RETURN END FUNCTION MUMPS_BLOC2_GET_NSLAVESMAX SUBROUTINE MUMPS_MAX_SURFCB_NBROWS( WHAT, KEEP,KEEP8, & NCB, NFR, SLAVEF, NBROWMAX, MAXSURFCB8 & ) IMPLICIT NONE INTEGER, intent(in) :: WHAT, NCB, NFR, SLAVEF INTEGER, intent(in) :: KEEP(500) INTEGER(8) KEEP8(150) INTEGER, intent(out) :: NBROWMAX INTEGER(8), intent(out) :: MAXSURFCB8 INTEGER KMAX, KMIN, NSLAVES, SIZEDUMMY, TABDUMMY(1) EXTERNAL MUMPS_REG_GETKMAX, MUMPS_GETKMIN, & MUMPS_BLOC2_GET_NSLAVESMIN INTEGER MUMPS_REG_GETKMAX, MUMPS_GETKMIN, & MUMPS_BLOC2_GET_NSLAVESMIN IF ( WHAT .NE. 1 .and. WHAT .NE. 2 ) THEN IF (WHAT .NE. 4 .and. WHAT .NE. 5 .AND. & KEEP(48).NE.5 ) THEN WRITE(*,*) "Internal error 1 in MUMPS_MAX_SURFCB_NBROWS" CALL MUMPS_ABORT() END IF ENDIF KMAX = MUMPS_REG_GETKMAX( KEEP8(21), NCB ) IF (WHAT .EQ.1.OR.WHAT.EQ.2) THEN NSLAVES = MUMPS_BLOC2_GET_NSLAVESMIN( SLAVEF, KEEP(48), & KEEP8(21), KEEP(50), & NFR, NCB, KEEP(375), KEEP(119) ) ELSE NSLAVES=SLAVEF ENDIF IF ( KEEP(48) == 0 .OR. (KEEP(48).EQ.5.AND.KEEP(50).EQ.0)) THEN NBROWMAX = NCB / NSLAVES + mod( NCB, NSLAVES ) IF ( WHAT == 2 .OR. WHAT == 5 ) & MAXSURFCB8 = int(NBROWMAX,8) * int(NCB,8) ELSE IF (KEEP(48) == 3.OR.(KEEP(48).EQ.5.AND.KEEP(50).NE.0))THEN KMIN = MUMPS_GETKMIN( KEEP8(21), KEEP(50), KMAX, NCB ) SIZEDUMMY = 1 IF (WHAT.GT.3) THEN CALL MUMPS_BLOC2_SET_POSK483( & WHAT-3, NSLAVES, NFR, NCB, & KMIN, KMAX, SLAVEF, & NBROWMAX, MAXSURFCB8, TABDUMMY, SIZEDUMMY) ELSE CALL MUMPS_BLOC2_SET_POSK483( & WHAT, NSLAVES, NFR, NCB, & KMIN, KMAX, SLAVEF, & NBROWMAX, MAXSURFCB8, TABDUMMY, SIZEDUMMY) ENDIF ELSE IF ( KEEP(48) == 4 ) THEN IF (KEEP8(21) > 0_8) THEN WRITE(*,*) "Internal error 2 in MUMPS_MAX_SURFCB_NBROWS" CALL MUMPS_ABORT() END IF IF(KEEP(50).EQ.0)THEN IF ( abs(KEEP8(21)) * int( SLAVEF - 1,8 ) > & int( NCB,8) * int(NFR,8) ) THEN NBROWMAX = (NCB + SLAVEF -2 ) / ( SLAVEF - 1 ) IF ( WHAT == 2 ) MAXSURFCB8 = int(NBROWMAX,8) *int(NCB,8) ELSE NBROWMAX=int( & (abs(KEEP8(21)) + int(NFR - 1,8)) & / int(NFR,8) & ) IF ( WHAT == 2 ) MAXSURFCB8 = abs(KEEP8(21)) ENDIF ELSE NBROWMAX=int((-real(NFR-NCB) & +sqrt((real(NFR-NCB)* & real(NFR-NCB))+real(4)* & real(abs(KEEP8(21)))))/ & real(2)) IF ( WHAT == 2 ) MAXSURFCB8 = abs(KEEP8(21)) ENDIF ELSE NBROWMAX = NCB IF (WHAT == 2) MAXSURFCB8 = int(NCB,8) * int(NCB,8) ENDIF NBROWMAX = min ( max(NBROWMAX, 1), NCB) RETURN END SUBROUTINE MUMPS_MAX_SURFCB_NBROWS INTEGER FUNCTION MUMPS_BLOC2_GET_NS_BLSIZE( SLAVEF, K48, K50, & BLSIZE, NFRONT, NCB) IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, K48, K50, BLSIZE, NFRONT, NCB INTEGER NSLAVES, NASS REAL Wtotal, Wblsize REAL MUMPS_BLOC2_COUT EXTERNAL MUMPS_BLOC2_COUT NASS = NFRONT - NCB NSLAVES = SLAVEF-1 IF ( K48 .EQ.0 .OR. (K48.EQ.5 .AND. K50.EQ.0)) THEN NSLAVES = max(NCB/max(1,BLSIZE),1) ELSE IF (K48.EQ.3 .OR. (K48.EQ.5 .AND. K50.NE.0))THEN Wblsize = MUMPS_BLOC2_COUT(BLSIZE,NFRONT,NASS) Wtotal = MUMPS_BLOC2_COUT(NCB,NFRONT,NASS) NSLAVES = max(nint ( Wtotal / Wblsize ), 1) ENDIF MUMPS_BLOC2_GET_NS_BLSIZE = & min ( NSLAVES,(SLAVEF-1) ) RETURN END FUNCTION MUMPS_BLOC2_GET_NS_BLSIZE SUBROUTINE MUMPS_BLOC2_SET_POSK483( & GETPOSITIONS, NSLAVES, NFRONT, NCB, & KMIN, KMAX, SLAVEF, & NBROWMAX, MAXSURFCB, TABPOS, SIZETABPOS) IMPLICIT NONE INTEGER, INTENT (IN) :: GETPOSITIONS, & NSLAVES, NFRONT, NCB, & KMIN, KMAX, SLAVEF, SIZETABPOS INTEGER, INTENT (OUT) :: NBROWMAX INTEGER(8), INTENT(OUT) :: MAXSURFCB INTEGER, INTENT (OUT) :: TABPOS(SIZETABPOS) REAL W, COSTni REAL delta INTEGER SumNi, NCOLim1, I, BLSIZE, NASS LOGICAL GETROW, GETSURF, GETPOS, GET_AVGROW, GET_AVGSURF REAL MUMPS_BLOC2_COUT EXTERNAL MUMPS_BLOC2_COUT GETROW = (GETPOSITIONS.EQ.1) GETSURF= (GETPOSITIONS.EQ.2) GETPOS = (GETPOSITIONS.EQ.3) GET_AVGROW = (GETPOSITIONS.EQ.4) GET_AVGSURF = (GETPOSITIONS.EQ.5) NBROWMAX = 0 MAXSURFCB = 0_8 IF (GETPOS) THEN TABPOS (1) = 1 TABPOS (NSLAVES+1)= NCB+1 TABPOS (SLAVEF+2) = NSLAVES ENDIF IF (NSLAVES.EQ.1) THEN IF ( GETSURF ) THEN NBROWMAX = NCB MAXSURFCB = int(NCB,8)*int(NCB,8) ELSEIF ( GETROW ) THEN NBROWMAX = NCB ENDIF ELSE NASS = NFRONT - NCB W = MUMPS_BLOC2_COUT(NCB,NFRONT,NASS) SumNi = 0 NCOLim1 = NASS DO I = 1, NSLAVES-1 delta = real(2*NCOLim1-NASS+1)**2 + & (real(4)*W)/real(NASS*(NSLAVES-I+1)) delta = sqrt(delta) delta = (real(-2*NCOLim1+NASS-1) + delta )/real(2) BLSIZE = max(int(delta), 1) IF ( (NFRONT-NCOLim1-BLSIZE) .LE. NSLAVES-I ) THEN BLSIZE = 1 ENDIF NCOLim1 = NCOLim1+BLSIZE COSTni = MUMPS_BLOC2_COUT(BLSIZE,NCOLim1,NASS) W = W - COSTni IF (GETPOS) TABPOS(I) = SumNi + 1 IF (GETSURF) THEN NBROWMAX = max ( NBROWMAX, & BLSIZE ) MAXSURFCB = max ( MAXSURFCB, & int(BLSIZE,8)* int(SumNi+BLSIZE,8) ) ELSEIF ( GETROW ) THEN NBROWMAX = max ( NBROWMAX, & BLSIZE ) RETURN ELSEIF (GET_AVGSURF) THEN NBROWMAX = NBROWMAX + BLSIZE MAXSURFCB = MAXSURFCB + int(BLSIZE,8)*int(SumNi+BLSIZE,8) ELSEIF (GET_AVGROW) THEN NBROWMAX = NBROWMAX + BLSIZE ENDIF SumNi = SumNi + BLSIZE ENDDO BLSIZE = NCB - SumNi IF (BLSIZE.LE.0) THEN write(*,*) ' Error in MUMPS_BLOC2_SET_POSK483: ', & ' size lastbloc ', BLSIZE CALL MUMPS_ABORT() ENDIF if (NCOLim1+BLSIZE.NE.NFRONT) then write(*,*) ' Error in MUMPS_BLOC2_SET_POSK483: ', & ' NCOLim1, BLSIZE, NFRONT=', & NCOLim1, BLSIZE, NFRONT CALL MUMPS_ABORT() endif IF (GETPOS) TABPOS(NSLAVES) = SumNi + 1 IF (GETSURF) THEN NBROWMAX = max ( NBROWMAX, & BLSIZE ) MAXSURFCB = max ( MAXSURFCB, & int(BLSIZE,8)* int(SumNi+BLSIZE,8 )) ELSEIF ( GETROW ) THEN NBROWMAX = max ( NBROWMAX, & BLSIZE ) ELSEIF (GET_AVGSURF) THEN NBROWMAX = NBROWMAX + BLSIZE MAXSURFCB = MAXSURFCB + int(BLSIZE,8)*int(SumNi+BLSIZE,8) NBROWMAX=(NBROWMAX+NSLAVES-1)/NSLAVES MAXSURFCB=(MAXSURFCB+int(NSLAVES-1,8))/int(NSLAVES,8) ELSEIF (GET_AVGROW) THEN NBROWMAX = NBROWMAX + BLSIZE NBROWMAX=(NBROWMAX+NSLAVES-1)/NSLAVES ENDIF ENDIF RETURN END SUBROUTINE MUMPS_BLOC2_SET_POSK483 SUBROUTINE MUMPS_BLOC2_SETPARTITION( & KEEP,KEEP8, SLAVEF, & TAB_POS_IN_PERE, & NSLAVES, NFRONT, NCB & ) IMPLICIT NONE INTEGER, INTENT( IN ) :: NCB, NSLAVES, SLAVEF, NFRONT, & KEEP(500) INTEGER(8) KEEP8(150) INTEGER TAB_POS_IN_PERE(SLAVEF+2) INTEGER :: I, BLSIZE INTEGER KMIN, KMAX, NBROWDUMMY, & GETPOSITIONS, SIZECOLTAB INTEGER(8) MAXSURFDUMMY8 INTEGER MUMPS_GETKMIN, MUMPS_REG_GETKMAX EXTERNAL MUMPS_GETKMIN, MUMPS_REG_GETKMAX, & MUMPS_BLOC2_SET_POSK483 IF (KEEP(48).EQ.0) THEN BLSIZE = NCB / NSLAVES TAB_POS_IN_PERE( 1 ) = 1 DO I = 1, NSLAVES-1 TAB_POS_IN_PERE( I+1 ) = TAB_POS_IN_PERE(I) + & BLSIZE ENDDO TAB_POS_IN_PERE(NSLAVES+1) = NCB+1 TAB_POS_IN_PERE(SLAVEF+2) = NSLAVES RETURN ELSE IF (KEEP(48).EQ.3 ) THEN KMAX = MUMPS_REG_GETKMAX(KEEP8(21), NCB) KMIN = MUMPS_GETKMIN(KEEP8(21), KEEP(50), KMAX, NCB) GETPOSITIONS = 3 SIZECOLTAB = SLAVEF+2 CALL MUMPS_BLOC2_SET_POSK483( & GETPOSITIONS, NSLAVES, NFRONT, NCB, & KMIN, KMAX, SLAVEF, & NBROWDUMMY, MAXSURFDUMMY8, & TAB_POS_IN_PERE(1), SIZECOLTAB) ENDIF RETURN END SUBROUTINE MUMPS_BLOC2_SETPARTITION SUBROUTINE MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & ISLAVE, NCB, NSLAVES, SIZE, FIRST_INDEX ) IMPLICIT NONE INTEGER, INTENT( IN ) :: ISLAVE, NCB, NSLAVES, SLAVEF, & KEEP(500), INODE, N INTEGER(8) KEEP8(150) INTEGER, INTENT( IN ) :: STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, INTENT( OUT ):: SIZE, FIRST_INDEX INTEGER BLSIZE, J IF (KEEP(48).EQ.0) THEN BLSIZE = NCB / NSLAVES IF ( ISLAVE .NE. NSLAVES ) THEN SIZE = BLSIZE ELSE SIZE = BLSIZE + mod( NCB, NSLAVES ) END IF FIRST_INDEX = ( ISLAVE - 1 ) * BLSIZE + 1 ELSEIF (KEEP(48).EQ.3) THEN J = ISTEP_TO_INIV2 ( STEP(INODE) ) FIRST_INDEX = TAB_POS_IN_PERE (ISLAVE,J) SIZE = TAB_POS_IN_PERE (ISLAVE+1,J) - FIRST_INDEX ELSEIF (KEEP(48).EQ.4) THEN J = ISTEP_TO_INIV2 ( STEP(INODE) ) FIRST_INDEX = TAB_POS_IN_PERE (ISLAVE,J) SIZE = TAB_POS_IN_PERE (ISLAVE+1,J) - FIRST_INDEX ELSEIF (KEEP(48).EQ.5) THEN J = ISTEP_TO_INIV2 ( STEP(INODE) ) FIRST_INDEX = TAB_POS_IN_PERE (ISLAVE,J) SIZE = TAB_POS_IN_PERE (ISLAVE+1,J) - FIRST_INDEX ELSE WRITE(*,*) 'Error in MUMPS_BLOC2 undef strat' CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE MUMPS_BLOC2_GET_SLAVE_INFO REAL FUNCTION MUMPS_BLOC2_COUT(NROW,NCOL,NASS) IMPLICIT NONE INTEGER, INTENT (IN) :: NROW,NCOL,NASS MUMPS_BLOC2_COUT = real(NASS)*real(NROW)* & real(2*NCOL - NASS - NROW + 1) RETURN END FUNCTION MUMPS_BLOC2_COUT INTEGER FUNCTION MUMPS_REG_GET_NSLAVES & (K821, K48, K50, SLAVEF, & NCB, NFRONT, NSLAVES_less, NMB_OF_CAND, K375, K119) IMPLICIT NONE INTEGER, INTENT( IN ) :: NCB, NFRONT, NSLAVES_less, & K48, K50, SLAVEF, NMB_OF_CAND, K375, K119 INTEGER(8), INTENT(IN) :: K821 INTEGER NSLAVES INTEGER NPIV, & NSLAVES_ref, NSLAVES_max REAL WK_MASTER, WK_SLAVE INTEGER MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX REAL MUMPS_BLOC2_COUT EXTERNAL MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX EXTERNAL MUMPS_BLOC2_COUT IF (NMB_OF_CAND.LE.0) THEN ENDIF IF ( (K48.EQ.0).OR. (K48.EQ.3) ) THEN NSLAVES_ref = MUMPS_BLOC2_GET_NSLAVESMIN( & SLAVEF, K48, K821, K50, NFRONT, NCB, K375, K119 ) NSLAVES = NSLAVES_ref IF ( NSLAVES_ref.LT.SLAVEF ) THEN NSLAVES_max = MUMPS_BLOC2_GET_NSLAVESMAX( & SLAVEF, K48, K821, K50, NFRONT, NCB, K375, K119 ) IF ( NSLAVES_max .LT. NSLAVES_less ) THEN NSLAVES = NSLAVES_max ELSE NSLAVES = NSLAVES_less ENDIF NSLAVES = max(NSLAVES_ref,NSLAVES) ENDIF NSLAVES = min (NSLAVES, NMB_OF_CAND) IF ( NSLAVES.GT.NSLAVES_ref) THEN NPIV = NFRONT - NCB IF ( K50.EQ.0 ) THEN WK_SLAVE = real( NPIV ) * real( NCB ) * & ( 2.0E0 * real(NFRONT) - real(NPIV) ) & / real(NSLAVES) WK_MASTER = 0.66667E0 * & real(NPIV)*real(NPIV)*real(NPIV)+ & real(NPIV)*real(NPIV)*real(NCB) ELSE WK_SLAVE = MUMPS_BLOC2_COUT(NCB,NFRONT,NPIV) & / real(NSLAVES) WK_MASTER = real(NPIV)*real(NPIV)*real(NPIV)/3.0E0 ENDIF IF ( (WK_MASTER.GT.WK_SLAVE).AND. & (WK_SLAVE.GT.1.0E0) ) THEN NSLAVES = & int( real(NSLAVES) * (WK_SLAVE/WK_MASTER)) NSLAVES = max(NSLAVES_ref, NSLAVES) ENDIF ENDIF ELSE NSLAVES = NSLAVES_less ENDIF NSLAVES = min (NSLAVES, NCB) NSLAVES = min (NSLAVES, NMB_OF_CAND) MUMPS_REG_GET_NSLAVES = NSLAVES RETURN END FUNCTION MUMPS_REG_GET_NSLAVES SUBROUTINE MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS, NCB, & NSLAVES, POSITION, ISLAVE, IPOSSLAVE ) IMPLICIT NONE INTEGER, INTENT( IN ) :: KEEP(500),INODE,N,SLAVEF INTEGER(8) KEEP8(150) INTEGER, INTENT( IN ) :: STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, INTENT( IN ) :: NASS, NCB, & NSLAVES, POSITION INTEGER, INTENT( OUT ) :: ISLAVE, IPOSSLAVE INTEGER BLSIZE, J, ISHIFT IF ((NSLAVES.LE.0).OR.(POSITION.LE.NASS)) THEN ISLAVE = 0 IPOSSLAVE = POSITION RETURN ENDIF IF (KEEP(48).NE.0.and.KEEP(48).NE.3.and.KEEP(48).NE.4 & .and.KEEP(48).NE.5) THEN WRITE(*,*) 'Error in MUMPS_BLOC2_GET_ISLAVE: undef strat' CALL MUMPS_ABORT() ENDIF IF (KEEP(48).ne.0) THEN J = ISTEP_TO_INIV2 ( STEP(INODE) ) ISHIFT = POSITION - NASS DO ISLAVE = NSLAVES,1,-1 IF ( ISHIFT .GE. TAB_POS_IN_PERE(ISLAVE,J)) THEN IPOSSLAVE = ISHIFT - TAB_POS_IN_PERE(ISLAVE,J) + 1 EXIT END IF END DO ELSE BLSIZE = NCB / NSLAVES ISLAVE = min( NSLAVES, & ( POSITION - NASS - 1 ) / BLSIZE + 1 ) IPOSSLAVE = POSITION - NASS - ( ISLAVE - 1 ) * BLSIZE ENDIF RETURN END SUBROUTINE MUMPS_BLOC2_GET_ISLAVE INTEGER FUNCTION MUMPS_GETKMIN( K821, K50, KMAX, NCB ) IMPLICIT NONE INTEGER, INTENT( IN ) :: KMAX, NCB, K50 INTEGER(8), INTENT(IN) :: K821 INTEGER KMIN, MINGRAN INTEGER(8) :: KMINSURF IF ( ( NCB .LE.0 ).OR. (KMAX.LE.0) ) THEN MUMPS_GETKMIN = 1 RETURN ENDIF IF (K50.EQ.0) THEN KMINSURF = 60000_8 #if defined(t3e) || defined(sgi) MINGRAN = 40 #else MINGRAN = 50 #endif ELSE KMINSURF = 30000_8 #if defined(t3e) || defined(sgi) MINGRAN = 10 #else MINGRAN = 20 #endif ENDIF IF (K821.GT.0_8) THEN #if defined(t3e) || defined(sgi) KMIN = max(MINGRAN,KMAX/10) #else KMIN = max(MINGRAN,KMAX/20) #endif ELSE KMINSURF = max( abs(K821)/500_8, KMINSURF ) KMIN = max( & int( KMINSURF / int(max(NCB,1),8) ), & 1 & ) ENDIF KMIN = min(KMIN,KMAX) KMIN = max(KMIN,1) MUMPS_GETKMIN = KMIN RETURN END FUNCTION MUMPS_GETKMIN INTEGER FUNCTION MUMPS_REG_GETKMAX( KEEP821, NCB ) IMPLICIT NONE INTEGER, intent( in ) :: NCB INTEGER(8), intent( in ) :: KEEP821 INTEGER KMAX IF ( NCB .LE.0 ) THEN MUMPS_REG_GETKMAX = 1 RETURN ENDIF IF ( KEEP821.GT.0_8 ) THEN KMAX = int(KEEP821) ELSE KMAX = -int(KEEP821/int(NCB,8)) ENDIF KMAX = min (NCB, KMAX) MUMPS_REG_GETKMAX = max ( KMAX, 1 ) RETURN END FUNCTION MUMPS_REG_GETKMAX MUMPS_5.8.1/src/srank_revealing.F0000664000175000017500000005444615042446437016534 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_GET_NS_OPTIONS_FACTO(N,KEEP,ICNTL,MPG) IMPLICIT NONE INTEGER N, KEEP(500), ICNTL(60), MPG KEEP(19)=0 KEEP(19)=ICNTL(56) IF ((KEEP(19).LT.1).OR.(KEEP(19).GE.2)) KEEP(19)=0 IF ( KEEP(53) .LE. 0 .and. & KEEP(19) .NE. 0 ) THEN KEEP(19) = 0 IF ( MPG .GT. 0 ) THEN WRITE( MPG,'(A)') '** Warning: ICNTL(56) null space option' WRITE( MPG,'(A)') '** disabled (incompatibility with analysis)' END IF END IF KEEP(21) = min(ICNTL(57),N) KEEP(22) = max(ICNTL(55),0) IF ( KEEP(19) .ne. 0 .and. KEEP(60) .ne. 0 ) THEN IF ( MPG .GT. 0 ) THEN WRITE( MPG,'(A)') '** Warning: ICNTL(56) null space option' WRITE( MPG,'(A)') '** disabled (incompatibility with Schur)' END IF KEEP(19) = 0 END IF RETURN END SUBROUTINE SMUMPS_GET_NS_OPTIONS_FACTO SUBROUTINE SMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL, KEEP, & NRHS, MPG, INFO) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500), NRHS, MPG, ICNTL(60) INTEGER, intent(inout):: INFO(80) IF (KEEP(19).EQ.0.AND.KEEP(110).EQ.0) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 56 IF (KEEP(110).EQ.0) INFO(2) = 24 IF(MPG.GT.0) THEN WRITE( MPG,'(A)') &'** ERROR : Null space computation requirement' WRITE( MPG,'(A)') &'** not consistent with factorization options' ENDIF GOTO 333 ENDIF ENDIF IF (ICNTL(9).NE.1) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 9 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') &'** ERROR ICNTL(25) incompatible with ' WRITE( MPG,'(A)') &'** option transposed system (ICNTL(9).ne.1) ' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(19).EQ.2) THEN IF ((KEEP(111).NE.0).AND.(KEEP(50).EQ.0)) THEN INFO(1) = -37 INFO(2) = 0 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') &'** ERROR ICNTL(25) incompatible with ' WRITE( MPG,'(A)') &'** option RRQR (ICNLT(56)=2) and unsym. matrices ' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(111).eq.-1.AND.NRHS.NE.KEEP(112)+KEEP(17))THEN INFO(1)=-32 INFO(2)=NRHS GOTO 333 ENDIF IF (KEEP(111).gt.0 .AND. NRHS .NE. 1) THEN INFO(1)=-32 INFO(2)=NRHS GOTO 333 ENDIF IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) and ICNTL(30) functionalities ', & ' incompatible with null space' ENDIF INFO(1) = -37 IF (KEEP(237).NE.0) THEN INFO(2) = 30 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(30) functionality ', & ' incompatible with null space' ENDIF ELSE IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) functionality ', & ' incompatible with null space' ENDIF INFO(2) = 20 ENDIF GOTO 333 ENDIF IF (( KEEP(111) .LT. -1 ) .OR. & (KEEP(111).GT.KEEP(112)+KEEP(17)) .OR. & (KEEP(111) .EQ.-1 .AND. KEEP(112)+KEEP(17).EQ.0)) & THEN INFO(1)=-36 INFO(2)=KEEP(111) GOTO 333 ENDIF IF (KEEP(221).NE.0.AND.KEEP(111).NE.0) THEN INFO(1)=-37 INFO(2)=26 GOTO 333 ENDIF 333 CONTINUE RETURN END SUBROUTINE SMUMPS_GET_NS_OPTIONS_SOLVE SUBROUTINE SMUMPS_RR_INIT_POINTERS(roota) USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: roota NULLIFY(roota%QR_TAU) NULLIFY(roota%SVD_U) NULLIFY(roota%SVD_VT) NULLIFY(roota%SINGULAR_VALUES) RETURN END SUBROUTINE SMUMPS_RR_INIT_POINTERS SUBROUTINE SMUMPS_RR_FREE_POINTERS(roota) USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: roota IF (associated(roota%QR_TAU)) THEN DEALLOCATE(roota%QR_TAU) NULLIFY(roota%QR_TAU) ENDIF IF (associated(roota%SVD_U)) THEN DEALLOCATE(roota%SVD_U) NULLIFY(roota%SVD_U) ENDIF IF (associated(roota%SVD_VT)) THEN DEALLOCATE(roota%SVD_VT) NULLIFY(roota%SVD_VT) ENDIF IF (associated(roota%SINGULAR_VALUES)) THEN DEALLOCATE(roota%SINGULAR_VALUES) NULLIFY(roota%SINGULAR_VALUES) ENDIF RETURN END SUBROUTINE SMUMPS_RR_FREE_POINTERS SUBROUTINE SMUMPS_SEQ_SYMMETRIZE(N,A) INTEGER N REAL A( N, N ) INTEGER I,J DO I = 2, N DO J = 1, I - 1 A( I, J ) = A( J, I ) END DO END DO RETURN END SUBROUTINE SMUMPS_SEQ_SYMMETRIZE SUBROUTINE SMUMPS_UXVSBP(N,PERM,X,RN01) INTEGER N,PERM(N),I REAL RN01(N),X(N) DO I=1,N RN01(PERM(I))=X(I) ENDDO DO I=1,N X(I)=RN01(I) ENDDO RETURN END SUBROUTINE SMUMPS_UXVSBP SUBROUTINE SMUMPS_UXVSFP(N,PERM,X,RN01) INTEGER N,PERM(N),I REAL RN01(N),X(N) DO I=1,N RN01(I)=X(PERM(I)) ENDDO DO I=1,N X(I)=RN01(I) ENDDO RETURN END SUBROUTINE SMUMPS_UXVSFP SUBROUTINE SMUMPS_SVD_QR_ESTIM_WK( PHASE, MBLOCK, NBLOCK, & SIZE_ROOT_ARG, & LOCAL_M, LOCAL_N, ROOT_OWNER, KEEP,KEEP8, & LIWK_RR, LWK_RR ) IMPLICIT NONE INTEGER, INTENT(IN) :: PHASE, SIZE_ROOT_ARG INTEGER, INTENT(IN) :: MBLOCK, NBLOCK, LOCAL_M, LOCAL_N LOGICAL, INTENT(IN) :: ROOT_OWNER INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(OUT):: LIWK_RR INTEGER(8), INTENT(OUT):: LWK_RR INTEGER SIZE_ROOT INTEGER NBPOSPONED_ESTIM PARAMETER (NBPOSPONED_ESTIM=2000) INTEGER SVD_QR,PAR_ROOT SVD_QR = KEEP(19) PAR_ROOT = KEEP(38) LIWK_RR = 0 LWK_RR = 0_8 IF (PAR_ROOT.EQ.0) THEN IF(ROOT_OWNER) THEN IF (PHASE.EQ.0) THEN SIZE_ROOT=SIZE_ROOT_ARG+NBPOSPONED_ESTIM ELSE SIZE_ROOT=SIZE_ROOT_ARG ENDIF IF(SVD_QR.EQ.1) THEN LWK_RR=int(5*SIZE_ROOT+1,8) ELSEIF(SVD_QR.EQ.2) THEN LWK_RR=int(3*SIZE_ROOT+1,8) END IF END IF ENDIF RETURN END SUBROUTINE SMUMPS_SVD_QR_ESTIM_WK SUBROUTINE SMUMPS_SEQ_FACTO_ROOT_SVD_QR &(NN,A,root,roota,WR03,LWR03,KEEP,KEEP8,INFO,LP,DKEEP, & GLOBK109,OPELIW,PIVNUL_LIST,LPIVNUL_LIST, & ROW_INDICES) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE ( MUMPS_ROOT_STRUC ) :: root TYPE ( SMUMPS_ROOT_STRUC ) :: roota INTEGER :: NN,LP,LWR03,LWR03_MINSIZE REAL :: A(NN*NN) INTEGER :: INFO(2),KEEP(500) INTEGER(8) :: KEEP8(150) REAL :: DKEEP(230) DOUBLE PRECISION :: OPELIW INTEGER :: GLOBK109 INTEGER :: LPIVNUL_LIST INTEGER :: PIVNUL_LIST(LPIVNUL_LIST) INTEGER :: ROW_INDICES(NN) REAL :: WR03(LWR03) INTEGER LDLT,DEFICIENCY REAL, DIMENSION(:), ALLOCATABLE :: RWORK INTEGER :: I,LDA,LDU,LDVT,J INTEGER :: IERR, LAST_BEFORE_GAP_IND INTEGER :: LAST_BEFORE_GAPLIMIT_IND, FIRST_AFTER_MinPiv, & FIRST_AFTER_GAPLIMIT, START_POINT, END_POINT INTEGER :: ALLOCOK,MAXDEF,MINDEF REAL :: EPS, ZERO, GAPLIMIT, MaxGap, MaxGap1, & MinPiv, Tol_MaxGap PARAMETER(ZERO=0.0E0) EPS = epsilon(ZERO) LDLT=KEEP(50) IF ((KEEP(19) .NE. 1).AND.(KEEP(19) .NE. 2)) THEN INFO(1)=-107 INFO(2)= KEEP(19) IF ( LP .GT. 0 ) THEN WRITE(LP,*) " *** Option ",KEEP(19), & " for null space no more available." ENDIF GOTO 100 ENDIF IF(KEEP(19).EQ.1) THEN LWR03_MINSIZE=5*NN+1 ELSEIF(KEEP(19).EQ.2) THEN LWR03_MINSIZE=3*NN+1 END IF MAXDEF=KEEP(21) IF ( MAXDEF .LE. 0 ) THEN MAXDEF = NN ELSE MAXDEF = max(MAXDEF - GLOBK109,0) ENDIF MINDEF = max(KEEP(22) - GLOBK109,0) MINDEF = min(MINDEF,NN) MAXDEF = min(MAXDEF,NN) IF(KEEP(19).EQ.1) THEN OPELIW = OPELIW + dble(26)*dble(NN)*dble(NN)*dble(NN) ELSEIF(KEEP(19).EQ.2) THEN OPELIW = OPELIW + dble(4)*dble(NN)*dble(NN)*dble(NN)/dble(3) ENDIF IF (associated(roota%SINGULAR_VALUES)) & DEALLOCATE(roota%SINGULAR_VALUES) NULLIFY(roota%SINGULAR_VALUES) root%NB_SINGULAR_VALUES=NN ALLOCATE(roota%SINGULAR_VALUES(NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN IF ( LP .GT. 0 ) & WRITE(LP,*) 'SMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating SINGULAR_VALUES' GOTO 100 END IF IF(KEEP(19).EQ.1) THEN IF(associated(roota%SVD_U)) DEALLOCATE(roota%SVD_U) NULLIFY(roota%SVD_U) ALLOCATE(roota%SVD_U(NN,NN),stat=ALLOCOK ) IF(ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NN IF ( LP .GT. 0 ) & WRITE(LP,*) 'SMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating SVD_U' GOTO 100 END IF IF (associated(roota%SVD_VT)) DEALLOCATE(roota%SVD_VT) NULLIFY(roota%SVD_VT) ALLOCATE(roota%SVD_VT(NN,NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NN IF ( LP .GT. 0 ) & WRITE(LP,*) 'SMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating SVD_VT' GOTO 100 END IF IF (allocated(RWORK)) DEALLOCATE(RWORK) ALLOCATE(RWORK(1), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=1 IF ( LP .GT. 0 ) & WRITE(LP,*) & 'SMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating RWORK' GOTO 100 END IF ELSEIF(KEEP(19).EQ.2) THEN IF (associated(roota%QR_TAU)) DEALLOCATE(roota%QR_TAU) NULLIFY(roota%QR_TAU) ALLOCATE(roota%QR_TAU(NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN IF ( LP .GT. 0 ) & WRITE(LP,*) & 'SMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating QR_TAU' GOTO 100 END IF IF (associated(ROOT%IPIV)) DEALLOCATE(ROOT%IPIV) NULLIFY(ROOT%IPIV) ALLOCATE(ROOT%IPIV(NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN IF ( LP .GT. 0 ) & WRITE(LP,*) & 'SMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating IPIV' GOTO 100 END IF IF (allocated(RWORK)) DEALLOCATE(RWORK) ALLOCATE(RWORK(1), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=1 IF ( LP .GT. 0 ) & WRITE(LP,*) & 'SMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating RWORK' GOTO 100 END IF ENDIF IF (LDLT.NE.0) THEN CALL SMUMPS_SEQ_SYMMETRIZE(NN,A) END IF LDA=NN LDU=NN LDVT=NN IERR = 0 IF(KEEP(19).EQ.1) THEN CALL sgesvd('A','A',NN,NN,A,LDA,roota%SINGULAR_VALUES(1) & ,roota%SVD_U(1,1) & ,LDU,roota%SVD_VT(1,1),LDVT,WR03,LWR03,IERR) ENDIF IF(IERR.NE.0) THEN INFO(1)=-107 INFO(2)=IERR IF (LP.GT.0) THEN IF(KEEP(19).EQ.1) THEN WRITE(LP,*) ' Problem in sgesvd : IERR = ', IERR ELSEIF(KEEP(19).EQ.2) THEN WRITE(LP,*) ' Problem in sgeqpf : IERR = ', IERR ENDIF GOTO 100 END IF ENDIF IF(KEEP(19).EQ.2) THEN DO I=1,NN roota%SINGULAR_VALUES(I)=abs(A(I+NN*(I-1))) ENDDO ENDIF DEFICIENCY=0 MinPiv = DKEEP(20) GAPLIMIT = DKEEP(9) IF (roota%SINGULAR_VALUES(NN).GT.MinPiv) THEN DEFICIENCY = 0 GOTO 170 ENDIF IF (roota%SINGULAR_VALUES(1).LE.GAPLIMIT) THEN DEFICIENCY = NN GOTO 170 ENDIF LAST_BEFORE_GAPLIMIT_IND = 0 LAST_BEFORE_GAP_IND = 0 FIRST_AFTER_MinPiv = 0 FIRST_AFTER_GAPLIMIT = 0 MaxGap = 0 MaxGap1 = 0 Tol_MaxGap = DKEEP(24) DO I=NN,1,-1 IF (FIRST_AFTER_MinPiv.GT.0) exit IF(roota%SINGULAR_VALUES(I).LE.GAPLIMIT) THEN LAST_BEFORE_GAPLIMIT_IND = I ELSE IF ((FIRST_AFTER_GAPLIMIT.EQ.0).AND. & (roota%SINGULAR_VALUES(I).LE.MinPiv)) THEN FIRST_AFTER_GAPLIMIT = I ELSE IF (roota%SINGULAR_VALUES(I).GT.MinPiv) THEN FIRST_AFTER_MinPiv = I IF (FIRST_AFTER_GAPLIMIT.EQ.0) FIRST_AFTER_GAPLIMIT = I ENDIF ENDDO START_POINT = LAST_BEFORE_GAPLIMIT_IND IF ((LAST_BEFORE_GAPLIMIT_IND.EQ.0).AND. & (FIRST_AFTER_GAPLIMIT.GT. FIRST_AFTER_MinPiv)) & START_POINT = FIRST_AFTER_GAPLIMIT END_POINT = FIRST_AFTER_MinPiv IF (FIRST_AFTER_MinPiv.EQ.0) END_POINT = 1 DO I=START_POINT,END_POINT+1,-1 IF (roota%SINGULAR_VALUES(I).EQ.0) THEN LAST_BEFORE_GAP_IND = I ELSE MaxGap1 = roota%SINGULAR_VALUES(I-1)* & (1/roota%SINGULAR_VALUES(I)) IF (MaxGap1.GE. Tol_MaxGap) THEN IF (MaxGap1.GE. DKEEP(25)*MaxGap ) THEN LAST_BEFORE_GAP_IND = I MaxGap = MaxGap1 ENDIF ENDIF ENDIF ENDDO IF (MaxGap.EQ.ZERO) THEN IF (LAST_BEFORE_GAPLIMIT_IND.EQ.0) THEN DEFICIENCY = 0 ELSE DEFICIENCY = NN - LAST_BEFORE_GAPLIMIT_IND +1 ENDIF ELSE DEFICIENCY = NN - LAST_BEFORE_GAP_IND +1 ENDIF 170 CONTINUE DEFICIENCY=min(DEFICIENCY,MAXDEF) DEFICIENCY=max(DEFICIENCY,MINDEF) KEEP(17)=DEFICIENCY IF(KEEP(19).EQ.2) THEN IF(DEFICIENCY.GT.0) THEN CALL strtrs('U','N','N',NN-DEFICIENCY,DEFICIENCY, & A,LDA,A(LDA*(NN-DEFICIENCY)+1),LDA,IERR) IF ( IERR .NE. 0 ) THEN IF (LP.GT.0) & WRITE(LP,*) ' Internal error in strtrs: IERR = ',IERR CALL MUMPS_ABORT() END IF END IF ENDIF DO J=NN-DEFICIENCY+1, NN IF(KEEP(19).EQ.1) THEN PIVNUL_LIST(J-NN+DEFICIENCY) = ROW_INDICES(J) ELSEIF(KEEP(19).EQ.2) THEN PIVNUL_LIST(J-NN+DEFICIENCY) = ROW_INDICES(root%IPIV(J)) ENDIF ENDDO 100 CONTINUE IF (allocated(RWORK)) DEALLOCATE(RWORK) RETURN END SUBROUTINE SMUMPS_SEQ_FACTO_ROOT_SVD_QR SUBROUTINE SMUMPS_SEQ_SOLVE_ROOT_SVD_QR & (NRHS,NN,A,root, roota, & IBEG_ROOT_DEF, IEND_ROOT_DEF, & RHS,KEEP,KEEP8,MTYPE,INFO,LWK8,WK, LP) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER NN, NRHS INTEGER(8), INTENT(IN) :: LWK8 TYPE ( MUMPS_ROOT_STRUC ) :: root TYPE ( SMUMPS_ROOT_STRUC ) :: roota REAL A(NN*NN) INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, MTYPE INTEGER INFO(2),KEEP(500) INTEGER(8) KEEP8(150) REAL RHS(NN,NRHS), WK(LWK8) INTEGER LP INTEGER :: LWK REAL,DIMENSION(:,:), allocatable :: TEMP_RHS INTEGER :: I,IERR,K INTEGER :: LDLT,RRSTRAT,DEFICIENCY,LDA,LDRHS INTEGER :: ALLOCOK REAL, PARAMETER :: RONE=1.0E+0 REAL ZERO, ONE, MINUSONE PARAMETER( ZERO = 0.0E0, ONE = 1.0E0, MINUSONE=-1.0E0 ) LDLT = KEEP(50) RRSTRAT = KEEP(19) DEFICIENCY = KEEP(17) LDA = NN LDRHS = NN LWK = int(min(int(huge(LWK),8),LWK8)) IERR = 0 IF ((RRSTRAT .NE. 1).AND.(RRSTRAT .NE. 2)) THEN WRITE(*,*) " *** Internal error ption ",RRSTRAT, & " for null space no more available." CALL MUMPS_ABORT() ENDIF IF (KEEP(111).EQ.0) THEN IF(KEEP(19).EQ.1) THEN IF ((MTYPE.EQ.0).OR.(LDLT.GT.0)) THEN allocate(TEMP_RHS(NN,NRHS), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NRHS IF ( LP .GT. 0 ) & WRITE(LP,*) & 'SMUMPS_SEQ_SOLVE_ROOT_SVD_QR: Problem ' & //'allocating TEMP_RHS' RETURN END IF CALL sgemm('Transpose','N',NN,NRHS,NN,ONE, & roota%SVD_U(1,1),NN,RHS, & NN,ZERO,TEMP_RHS,NN) DO I=1,NN-DEFICIENCY TEMP_RHS( I, 1:NRHS ) = (ONE/roota%SINGULAR_VALUES(I))* & TEMP_RHS( I, 1:NRHS ) ENDDO DO I=NN-DEFICIENCY +1, NN TEMP_RHS(I, 1:NRHS) = ZERO ENDDO CALL sgemm('Transpose','N',NN,NRHS,NN,ONE, & roota%SVD_VT(1,1),NN, & TEMP_RHS, NN,ZERO,RHS,NN) DEALLOCATE(TEMP_RHS) ELSEIF(MTYPE.EQ.1) THEN allocate(TEMP_RHS(NN,NRHS), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NRHS IF ( LP .GT. 0 ) & WRITE(LP,*) & 'SMUMPS_SEQ_SOLVE_ROOT_SVD_QR: Problem ' & //'allocating TEMP_RHS' RETURN END IF CALL sgemm('N','N',NN,NRHS,NN,ONE,roota%SVD_VT(1,1),NN, & RHS, NN,ZERO,TEMP_RHS,NN) DO I=1,NN-DEFICIENCY TEMP_RHS( I, 1:NRHS ) = (ONE/roota%SINGULAR_VALUES(I))* & TEMP_RHS( I, 1:NRHS ) ENDDO DO I=NN-DEFICIENCY +1, NN TEMP_RHS(I, 1:NRHS) = ZERO ENDDO CALL sgemm('N','N',NN,NRHS,NN,ONE,roota%SVD_U(1,1),NN, & TEMP_RHS,NN,ZERO,RHS,NN) DEALLOCATE(TEMP_RHS) ENDIF ELSEIF(KEEP(19).EQ.2) THEN IF ((MTYPE.EQ.0).OR.(LDLT.GT.0)) THEN CALL sormqr('L','Transpose',NN,NRHS,NN, & A,LDA,roota%QR_TAU(1), & RHS,LDRHS,WK(1),LWK,IERR) IF(IERR.LT.0) THEN WRITE(*,*) & 'Error return from sormqr in root solve: IERR=', IERR RETURN END IF CALL strtrs('U','N','N',NN-DEFICIENCY,NRHS,A,LDA, & RHS,LDRHS,IERR) IF ( IERR .LT. 0 ) THEN WRITE(*,*) & 'Error return from strtrs in roor solve: IERR =',IERR RETURN END IF DO I=1,NRHS RHS( NN - DEFICIENCY + 1: NN, I ) = ZERO ENDDO DO I=1,NRHS CALL SMUMPS_UXVSBP(NN,root%IPIV(1),RHS(1,I),WK) ENDDO ELSEIF(MTYPE.EQ.1) THEN DO I=1,NRHS CALL SMUMPS_UXVSFP(NN,root%IPIV(1),RHS(1,I),WK) ENDDO CALL strtrs('U','T','N',NN-DEFICIENCY,NRHS, & A,LDA,RHS,LDRHS,IERR) IF(IERR.NE.0) THEN WRITE(*,*) 'Error return from trtrs: IERR=', IERR STOP END IF DO I=1,NRHS RHS( NN - DEFICIENCY + 1: NN, I ) = ZERO ENDDO CALL sormqr( 'L','N',NN,NRHS,NN,A,LDA,roota%QR_TAU(1), & RHS,LDRHS,WK,LWK,IERR) IF(IERR.LT.0) THEN WRITE(*,*) 'Error return from sormqr: IERR=', IERR RETURN END IF ENDIF ENDIF ELSE IF(KEEP(19).EQ.1) THEN IF ((MTYPE.EQ.0).OR.(LDLT.GT.0)) THEN DO I=IBEG_ROOT_DEF,IEND_ROOT_DEF RHS(:,I+1-IBEG_ROOT_DEF) = & roota%SVD_VT(NN-DEFICIENCY+I,:) ENDDO ELSEIF(MTYPE.EQ.1) THEN DO I=IBEG_ROOT_DEF,IEND_ROOT_DEF RHS(:,I+1-IBEG_ROOT_DEF) = & roota%SVD_U(:,NN-DEFICIENCY+I) ENDDO ENDIF ELSEIF(KEEP(19).EQ.2) THEN IF((MTYPE.EQ.0).OR.(LDLT.GT.0)) THEN DO I=IBEG_ROOT_DEF,IEND_ROOT_DEF RHS(NN-DEFICIENCY+I,I-IBEG_ROOT_DEF+1) = MINUSONE DO K=1,NN-DEFICIENCY RHS(K,I-IBEG_ROOT_DEF+1)= & A(K + LDA*(NN-DEFICIENCY+I-1)) ENDDO ENDDO DO I=1,IEND_ROOT_DEF-IBEG_ROOT_DEF+1 CALL SMUMPS_UXVSBP(NN,root%IPIV(1),RHS(1,I),WK) ENDDO ELSEIF(MTYPE.EQ.1) THEN WRITE(*,*) 'Computation of a null space basis' & // ' of A is unavailable for unsymetric matrices' DO I=IBEG_ROOT_DEF,IEND_ROOT_DEF RHS(NN-DEFICIENCY+I,I-IBEG_ROOT_DEF+1) = ONE ENDDO CALL sormqr('L','N',NN,NRHS,NN, A,LDA,roota%QR_TAU(1), & RHS,LDRHS,WK(1),LWK,IERR) ENDIF ENDIf ENDIF RETURN END SUBROUTINE SMUMPS_SEQ_SOLVE_ROOT_SVD_QR MUMPS_5.8.1/src/dsol_bwd_aux.F0000664000175000017500000021036115042446437016022 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SOLVE_NODE_BWD( INODE, & N, IPOOL, LPOOL, IIPOOL, NBFINF, & A, LA, IW, LIW, W, LWC, NRHS, & POSWCB, PLEFTW, POSIWCB, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, & MYLEAF_LEFT, INFO, & PROCNODE_STEPS, DEJA_SEND, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & , DO_MCAST2_TERMBWD & ) USE DMUMPS_OOC USE DMUMPS_BUF USE DMUMPS_SOL_LR, only : DMUMPS_SOL_BWD_LR_SU IMPLICIT NONE INTEGER :: KEEP( 500 ) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER :: INFO(80) INTEGER, INTENT( IN ) :: INODE, N, NRHS, MTYPE, LIW, LIWW INTEGER, INTENT( IN ) :: SLAVEF, COMM, MYID INTEGER, INTENT (IN ) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT( IN ) :: NE_STEPS(KEEP(28)) INTEGER(8), INTENT( IN ) :: LA, LWC INTEGER(8), INTENT( INOUT ) :: POSWCB, PLEFTW INTEGER, INTENT( INOUT ) :: POSIWCB INTEGER, INTENT( IN ) :: LPANEL_POS INTEGER :: PANEL_POS(LPANEL_POS) LOGICAL, INTENT(INOUT) :: DEJA_SEND(0:SLAVEF-1) INTEGER, INTENT(IN) :: LPOOL INTEGER, INTENT(INOUT) :: IPOOL(LPOOL), IIPOOL INTEGER, INTENT(INOUT) :: NBFINF, MYLEAF_LEFT INTEGER :: PTRIST(KEEP(28)), PTRICB(KEEP(28)) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION :: A( LA ) DOUBLE PRECISION :: W(LWC) DOUBLE PRECISION :: W2(KEEP(133)) INTEGER :: IW(LIW),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)),FILS(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LRHSINTR, POSINRHSINTR_BWD(N) DOUBLE PRECISION RHSINTR(LRHSINTR,NRHS) INTEGER(8), intent(in) :: LRHS_ROOT DOUBLE PRECISION RHS_ROOT( LRHS_ROOT ) LOGICAL, INTENT( IN ) :: PRUN_BELOW INTEGER, INTENT(IN) :: SIZE_TO_PROCESS LOGICAL, INTENT(IN) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, INTENT(IN) :: DO_NBSPARSE INTEGER, INTENT(IN) :: LRHS_BOUNDS INTEGER, INTENT(IN) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, INTENT(IN) :: FROM_PP LOGICAL, INTENT( OUT ) :: ERROR_WAS_BROADCASTED LOGICAL, INTENT( OUT ) :: DO_MCAST2_TERMBWD INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR LOGICAL FLAG INCLUDE 'mumps_headers.h' LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL LTLEVEL2, IN_SUBTREE INTEGER TYPENODE INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL NO_CHILDREN LOGICAL :: ALLOW_OTHERS_TO_LEAVE INTEGER :: K, JBDEB, JBFIN, NRHS_B INTEGER IWHDLR INTEGER NPIV INTEGER IPOS,LIELL,NELIM,JJ,I INTEGER J1,J2,J,NCB INTEGER NSLAVES INTEGER IN,IF,LONG,POOL_FIRST_POS,TMP INTEGER :: NBFILS INTEGER :: PROCDEST, DEST INTEGER(8) :: PTWCB, PPIV_COURANT INTEGER :: Offset, EffectiveSize, ISLAVE, FirstIndex INTEGER :: POSINDICES, IPOSINRHSINTR, IPOSINRHSINTR_PANEL INTEGER(8) :: APOS, IST INTEGER(8) :: IFR8 INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER LDAJ, NBJ, & NBJLAST, NPIV_LAST, PANEL_SIZE, & NCB_PANEL, TYPEF INTEGER BEG_PANEL LOGICAL TWOBYTWO INTEGER NPANELS, IPANEL DOUBLE PRECISION ALPHA,ONE,ZERO PARAMETER (ZERO=0.0D0, ONE = 1.0D0, ALPHA=-1.0D0) LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE ERROR_WAS_BROADCASTED = .FALSE. DO_MCAST2_TERMBWD = .FALSE. NO_CHILDREN = .FALSE. IF (DO_NBSPARSE) THEN JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) JBFIN= RHS_BOUNDS(2*STEP(INODE)) NRHS_B = JBFIN-JBDEB+1 ELSE JBDEB = 1 JBFIN = NRHS NRHS_B = NRHS ENDIF IF ( INODE .EQ. KEEP( 38 ) .OR. INODE .EQ. KEEP( 20 ) ) THEN IPOS = PTRIST(STEP(INODE))+KEEP(IXSZ) NPIV = IW(IPOS+3) LIELL = IW(IPOS) + NPIV IPOS = PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) IF ( MTYPE .EQ. 1 .AND. KEEP(50) .EQ. 0) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + LIELL + NPIV ELSE J1 = IPOS + 1 J2 = IPOS + NPIV END IF IFR8 = 0_8 IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) CALL DMUMPS_SOL_CPY_FS2RHSINTR(JBDEB, JBFIN, J2-J1+1, & KEEP, RHSINTR, NRHS, LRHSINTR, IPOSINRHSINTR, & RHS_ROOT(1+NPIV*(JBDEB-1)), NPIV, 1) IN = INODE 270 IN = FILS(IN) IF (IN .GT. 0) GOTO 270 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF (KEEP(31) .NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF RETURN ENDIF IF = -IN LONG = NPIV NBFILS = NE_STEPS(STEP(INODE)) IF ( PRUN_BELOW ) THEN I = NBFILS NBFILS = 0 DO WHILE (I.GT.0) IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 IF = FRERE(STEP(IF)) I = I -1 ENDDO IF (NBFILS.EQ.0) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF IF = -IN ENDIF DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1030 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1030 ENDIF NO_CHILDREN = .FALSE. ENDIF IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)),KEEP(199)) & .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) IF (.NOT. DEJA_SEND( PROCDEST )) THEN 600 CONTINUE CALL DMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, & LONG, LONG, IW( J1 ), & RHS_ROOT( 1+NPIV*(JBDEB-1) ), & JBDEB, JBFIN, & RHSINTR(1, 1), NRHS, LRHSINTR, & IPOSINRHSINTR, NPIV, & KEEP, PROCDEST, & NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, & MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 600 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal error 2 DMUMPS_SOLVE_NODE_BWD", & IERR CALL MUMPS_ABORT() END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF ENDIF IF = FRERE(STEP(IF)) ENDDO ALLOW_OTHERS_TO_LEAVE = .FALSE. IF ( PRUN_BELOW .AND. NO_CHILDREN ) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) ENDIF IF ( KEEP(31). NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF IF (IIPOOL.NE.POOL_FIRST_POS) THEN DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP = IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1) = IPOOL(IIPOOL-I) IPOOL(IIPOOL-I) = TMP ENDDO ENDIF RETURN END IF IN_SUBTREE = MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) TYPENODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) LTLEVEL2= ( & (TYPENODE .eq.2 ) .AND. & (MTYPE.NE.1) ) NPIV = IW(PTRIST(STEP(INODE))+2+KEEP(IXSZ)+1) IF ((NPIV.NE.0).AND.(LTLEVEL2)) THEN IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) NCB = LIELL - NPIV - NELIM IPOS = IPOS + 2 NSLAVES = IW( IPOS ) Offset = 0 IPOS = IPOS + NSLAVES IW(PTRIST(STEP(INODE))+XXS)= C_FINI+NSLAVES IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL DMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR(NCB * NRHS_B - POSWCB-PLEFTW+1_8, & INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - int(NCB,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = NCB*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF IF ( NCB.EQ.0 ) THEN write(6,*) ' Internal Error type 2 node with no CB ' CALL MUMPS_ABORT() ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + NELIM +1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + NELIM +1 J2 = IPOS + LIELL END IF IFR8 = PTRACB(STEP( INODE )) - 1_8 CALL DMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSINTR, NRHS, LRHSINTR, & W(PTRACB(STEP(INODE))), NCB, 1, & IW, LIW, KEEP, N, POSINRHSINTR_BWD ) IFR8 = IFR8 + int(J2-KEEP(253)-J1+1,8) IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR8 = IFR8 + 1_8 DO K=JBDEB, JBFIN IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR8+int(K-JBDEB,8)*int(NCB,8)) = ALPHA ELSE W(IFR8+int(K-JBDEB,8)*int(NCB,8)) = ZERO ENDIF ENDDO ENDDO ENDIF DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & EffectiveSize, & FirstIndex ) 500 CONTINUE DEST = IW( PTRIST(STEP(INODE))+5+ISLAVE+KEEP(IXSZ)) CALL DMUMPS_BUF_SEND_BACKVEC(NRHS_B, INODE, & W(Offset+PTRACB(STEP(INODE))), & EffectiveSize, & NCB, DEST, & BACKSLV_MASTER2SLAVE, JBDEB, JBFIN, & KEEP, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, & PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 500 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF Offset = Offset + EffectiveSize END DO IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL DMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) RETURN ENDIF LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) NCB = LIELL - NPIV IPOS = IPOS + 1 IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ENDIF APOS = PTRFAC( STEP(INODE)) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 + NSLAVES IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN IF (MTYPE.NE.1) THEN TYPEF = TYPEF_L ELSE TYPEF = TYPEF_U ENDIF PANEL_SIZE = DMUMPS_OOC_PANEL_SIZE( LIELL ) IF (KEEP(50).NE.1) THEN CALL DMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF LONG = 0 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL ELSE J1 = IPOS + 1 J2 = IPOS + NPIV ENDIF IF (IN_SUBTREE) THEN PTWCB = PLEFTW IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN CALL DMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(int(LIELL,8)*int(NRHS_B,8)-POSWCB, & INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF ELSE IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL DMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB ) IF ( POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR( int(LIELL,8)*int(NRHS_B,8)- & POSWCB-PLEFTW+1_8, & INFO(2) ) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - int(LIELL,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF PTWCB = PTRACB(STEP( INODE )) ENDIF IF (J2.GE.J1) THEN IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) ELSE IPOSINRHSINTR = -99999 ENDIF IF (J2.GE.J1) THEN DO K=JBDEB, JBFIN IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = ZERO ENDDO ENDIF END DO ENDIF IFR8 = PTWCB + int(NPIV - 1,8) IF ( LIELL .GT. NPIV ) THEN IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + 1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + 1 J2 = IPOS + LIELL END IF CALL DMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSINTR, NRHS, LRHSINTR, & W(PTWCB), LIELL, NPIV+1, & IW, LIW, KEEP, N, POSINRHSINTR_BWD ) IFR8 = IFR8 + int(J2-KEEP(253)-J1+1,8) IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR8 = IFR8 + 1_8 DO K=JBDEB, JBFIN IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR8+int(K-JBDEB,8)*int(LIELL,8)) = ALPHA ELSE W(IFR8+int(K-JBDEB,8)*int(LIELL,8)) = ZERO ENDIF ENDDO ENDDO ENDIF NCB = LIELL - NPIV IF (NPIV .EQ. 0) GOTO 160 ENDIF IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN J = NPIV / PANEL_SIZE TWOBYTWO = KEEP(50).EQ.2 .AND. & ((TYPENODE.EQ.1.AND.KEEP(103).GT.0) .OR. & (TYPENODE.EQ.2.AND.KEEP(105).GT.0)) IF (TWOBYTWO) THEN CALL DMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, LPANEL_POS, & IW(IPOS+1+LIELL), NPIV, NPANELS, LIELL, & NBENTRIES_ALLPANELS) ELSE IF (NPIV.EQ.J*PANEL_SIZE) THEN NPIV_LAST = NPIV NBJLAST = PANEL_SIZE NPANELS = J ELSE NPIV_LAST = (J+1)* PANEL_SIZE NBJLAST = NPIV-J*PANEL_SIZE NPANELS = J+1 ENDIF NBENTRIES_ALLPANELS = & int(LIELL,8) * int(NPIV,8) & - int( ( J * ( J - 1 ) ) /2,8 ) & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) & - int(J,8) & * int(mod(NPIV, PANEL_SIZE),8) & * int(PANEL_SIZE,8) JJ=NPIV_LAST ENDIF APOSDEB = APOS + NBENTRIES_ALLPANELS DO IPANEL = NPANELS, 1, -1 IF (TWOBYTWO) THEN NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) BEG_PANEL = PANEL_POS(IPANEL) ELSE IF (JJ.EQ.NPIV_LAST) THEN NBJ = NBJLAST ELSE NBJ = PANEL_SIZE ENDIF BEG_PANEL = JJ- PANEL_SIZE+1 ENDIF LDAJ = LIELL-BEG_PANEL+1 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) IPOSINRHSINTR_PANEL = IPOSINRHSINTR + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ IF (KEEP(50).NE.1.AND.MUST_BE_PERMUTED) THEN CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) IF (NPIV.EQ.(IW(I_PIVRPTR)-1)) THEN MUST_BE_PERMUTED=.FALSE. ELSE CALL DMUMPS_PERMUTE_PANEL( & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, BEG_PANEL-1) ENDIF ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB.NE. 0) THEN CALL dgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL+NBJ,JBDEB), & 1, ONE, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1 ) ENDIF IF (NCB .NE. 0) THEN CALL dgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1 ) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL dtrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1) ELSE CALL dtrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1) ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB .NE. 0) THEN CALL dgemm( 'T', 'N', NBJ, NRHS_B, & NCB_PANEL-NCB, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL+NBJ,JBDEB), LRHSINTR, & ONE, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ENDIF IF (NCB .NE. 0) THEN CALL dgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, & W( PTWCB+int(NPIV,8) ), LIELL, & ONE, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB),LRHSINTR) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL dtrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ELSE CALL dtrsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO ELSE IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 & .AND. KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL DMUMPS_SOL_BWD_LR_SU ( & INODE, IWHDLR, NPIV, NSLAVES, & LIELL, W, LWC, NRHS_B, PTWCB, & RHSINTR, LRHSINTR, NRHS, & IPOSINRHSINTR, JBDEB, & MTYPE, KEEP, KEEP8, & INFO(1), INFO(2) ) IF (INFO(1).LT.0) THEN ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ELSE IF ( LIELL .GT. NPIV ) THEN IF ( MTYPE .eq. 1 ) THEN IST = APOS + int(NPIV,8) #if defined(MUMPS_USE_BLAS2) IF (NRHS_B == 1) THEN CALL dgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(PTWCB+int(NPIV,8)), 1, & ONE, & RHSINTR(IPOSINRHSINTR,JBDEB), 1 ) ELSE #endif CALL dgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), & LIELL, W(PTWCB+int(NPIV,8)), LIELL, ONE, & RHSINTR(IPOSINRHSINTR,JBDEB), LRHSINTR) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE IF ( KEEP(50) .eq. 0 ) THEN IST = APOS + int(NPIV,8) * int(LIELL,8) ELSE IF( KEEP(459) .GT. 1) THEN CALL MUMPS_GETI8(IST, IW(PTRIST(STEP(INODE))+XXR)) IST = APOS + IST - int(NPIV,8) * int(LIELL-NPIV,8) ELSE IST = APOS + int(NPIV,8) * int(NPIV,8) ENDIF END IF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSINTR(IPOSINRHSINTR,JBDEB), 1 ) ELSE #endif CALL dgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), & NPIV, W(PTWCB+int(NPIV,8)), LIELL, & ONE, RHSINTR(IPOSINRHSINTR,JBDEB), LRHSINTR) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF ENDIF IF ( MTYPE .eq. 1 ) THEN LDAJ = LIELL ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=LIELL ELSE IF (KEEP(459).GT.1) THEN LDAJ=-999799 ELSE LDAJ=NPIV ENDIF ENDIF END IF PPIV_COURANT = int(JBDEB-1,8)*int(LRHSINTR,8) & + int(IPOSINRHSINTR,8) IF (KEEP(459).GT.1 .AND. KEEP(50).NE.0) THEN CALL DMUMPS_SOLVE_BWD_PANELS( A, LA, APOS, & NPIV, IW(IPOS+1+LIELL), & NRHS_B, RHSINTR(1,1), KEEP8(25), LRHSINTR, PPIV_COURANT, & MTYPE, KEEP ) ELSE CALL DMUMPS_SOLVE_BWD_TRSOLVE( A, LA, APOS, & NPIV, LDAJ, & NRHS_B, RHSINTR(1,1), KEEP8(25), LRHSINTR, PPIV_COURANT, & MTYPE, KEEP ) ENDIF ENDIF ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN J1 = IPOS + LIELL + 1 ELSE J1 = IPOS + 1 END IF IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) 160 CONTINUE IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ENDIF IN = INODE 170 IN = FILS(IN) IF (IN .GT. 0) GOTO 170 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 IF (.NOT. IN_SUBTREE ) THEN IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 CALL DMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF ( KEEP(31) .NE. 0 .AND. & .NOT. IN_SUBTREE ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31).EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF RETURN ENDIF IF = -IN NBFILS = NE_STEPS(STEP(INODE)) IF ( PRUN_BELOW ) THEN I = NBFILS NBFILS = 0 DO WHILE (I.GT.0) IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 IF = FRERE(STEP(IF)) I = I -1 ENDDO IF (NBFILS.EQ.0) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF IF = -IN ENDIF IF (IN_SUBTREE) THEN DO I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1010 CONTINUE IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1010 ENDIF NO_CHILDREN = .FALSE. ENDIF IPOOL((IIPOOL-I+1)+NBFILS-I) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ENDDO IF (PRUN_BELOW .AND. NO_CHILDREN) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF (ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 RETURN ENDIF ENDIF ELSE DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO 190 I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1020 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1020 ENDIF NO_CHILDREN = .FALSE. ENDIF IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) IF (.not. DEJA_SEND( PROCDEST )) THEN 400 CONTINUE CALL DMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, & LIELL, LIELL - KEEP(253), & IW( POSINDICES ), & W( PTRACB(STEP(INODE)) ), JBDEB, JBFIN, & RHSINTR(1, 1), NRHS, LRHSINTR, & IPOSINRHSINTR, NPIV, & KEEP, PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF IF = FRERE(STEP(IF)) ENDIF 190 CONTINUE IF ( PRUN_BELOW .AND. NO_CHILDREN ) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF ( ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 RETURN ENDIF ENDIF DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO IF ( KEEP(31) .NE. 0 ) & THEN KEEP(31) = KEEP(31) - 1 ALLOW_OTHERS_TO_LEAVE = (KEEP(31) .EQ. 1) IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF ENDIF IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 CALL DMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF RETURN END SUBROUTINE DMUMPS_SOLVE_NODE_BWD RECURSIVE SUBROUTINE DMUMPS_BACKSLV_RECV_AND_TREAT( & BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IMPLICIT NONE LOGICAL BLOQ, FLAG INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER(8), intent(in) :: LWC DOUBLE PRECISION W( LWC ) INTEGER POSIWCB INTEGER IIPOOL, LPOOL INTEGER IPOOL( LPOOL ) INTEGER LPANEL_POS INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(80), KEEP(500) INTEGER(8) :: POSWCB, PLEFTW INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER LIW INTEGER(8) :: LA INTEGER PTRIST(KEEP(28)), IW( LIW ) INTEGER (8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION A( LA ), W2( KEEP(133) ) INTEGER NRHS INTEGER MYLEAF_LEFT, MTYPE INTEGER LRHSINTR, POSINRHSINTR_BWD(N) DOUBLE PRECISION RHSINTR(LRHSINTR,NRHS) LOGICAL, INTENT(IN) :: PRUN_BELOW INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR FLAG = .FALSE. IF ( BLOQ ) THEN CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF (FLAG) THEN KEEP(266)=KEEP(266)-1 MSGSOU=STATUS(MPI_SOURCE) MSGTAG=STATUS(MPI_TAG) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN INFO(1) = -20 INFO(2) = MSGLEN IF (NBFINF .NE. 0) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ELSE CALL MPI_RECV(BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, COMM, STATUS, IERR) CALL DMUMPS_BACKSLV_TRAITER_MESSAGE( MSGTAG, MSGSOU, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) END IF END IF RETURN END SUBROUTINE DMUMPS_BACKSLV_RECV_AND_TREAT RECURSIVE SUBROUTINE DMUMPS_BACKSLV_TRAITER_MESSAGE( & MSGTAG, MSGSOU, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) USE DMUMPS_OOC USE DMUMPS_SOL_LR, ONLY: DMUMPS_SOL_SLAVE_LR_U, & DMUMPS_SOL_BWD_LR_SU USE DMUMPS_BUF IMPLICIT NONE INTEGER MSGTAG, MSGSOU INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER(8), intent(in) :: LWC DOUBLE PRECISION W( LWC ) INTEGER POSIWCB INTEGER IIPOOL, LPOOL, LPANEL_POS INTEGER IPOOL( LPOOL ) INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(80), KEEP(500) INTEGER(8) :: POSWCB, PLEFTW INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER FRERE(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER LIW INTEGER(8) :: LA INTEGER IW( LIW ), PTRIST( KEEP(28) ) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION A( LA ), W2( KEEP(133) ) INTEGER NRHS INTEGER MYLEAF_LEFT, MTYPE INTEGER LRHSINTR, POSINRHSINTR_BWD(N) DOUBLE PRECISION RHSINTR(LRHSINTR,NRHS) LOGICAL, INTENT(IN) :: PRUN_BELOW INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS), NO_CHILDREN LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IF, INODE, IERR, LONG, DUMMY(1) INTEGER :: LIELL, K INTEGER(8) :: APOS, IST INTEGER NPIV, NROW_L, IPOS, NROW_RECU INTEGER(8) :: IFR8 INTEGER I, JJ, IN, PROCDEST, J1, J2, LDA INTEGER NSLAVES, NELIM, J, POSINDICES, INODEPOS, & IPOSINRHSINTR, IPOSINRHSINTR_PANEL INTEGER JBDEB, JBFIN, NRHS_B, allocok INTEGER(8) :: P_UPDATE, P_SOL_MAS INTEGER :: IWHDLR, MTYPE_SLAVE, LDA_SLAVE LOGICAL FLAG DOUBLE PRECISION ZERO, ALPHA, ONE PARAMETER (ZERO=0.0D0, ONE = 1.0D0, ALPHA=-1.0D0) INCLUDE 'mumps_headers.h' INTEGER POOL_FIRST_POS, TMP LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: NCB INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER(8) :: PTWCB, PPIV_COURANT INTEGER LDAJ, NBJ, & NBJLAST, NPIV_LAST, PANEL_SIZE, & NCB_PANEL, TYPEF LOGICAL TWOBYTWO INTEGER BEG_PANEL INTEGER IPANEL, NPANELS INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL :: ALLOW_OTHERS_TO_LEAVE LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_PROCNODE ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then INFO(1)=-13 INFO(2)=SLAVEF WRITE(6,*) MYID,' Allocation error of DEJA_SEND ' & //'in bwd solve COMPSO' GOTO 260 END IF DUMMY(1)=0 IF (MSGTAG .EQ. TERMBWD) THEN NBFINF = NBFINF - 1 ELSE IF (MSGTAG .EQ. NOEUD) THEN POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & LONG, 1, MPI_INTEGER, & COMM, IERR) NRHS_B = JBFIN-JBDEB+1 IF ( POSIWCB - LONG .LT. 0 & .OR. POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN CALL DMUMPS_COMPSO(N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF (POSIWCB - LONG .LT. 0) THEN INFO(1)=-14 INFO(2)=-POSIWCB + LONG WRITE(6,*) MYID,' Internal error 1 in bwd solve COMPSO' GOTO 260 END IF IF ( POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(LONG + PLEFTW - POSWCB - 1_8, & INFO(2)) WRITE(6,*) MYID,' Internal error 2 in bwd solve COMPSO' GOTO 260 END IF ENDIF POSIWCB = POSIWCB - LONG POSWCB = POSWCB - LONG IF (LONG .GT. 0) THEN CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IWCB(POSIWCB + 1), & LONG, MPI_INTEGER, COMM, IERR) DO K=JBDEB,JBFIN CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & W(POSWCB + 1), LONG, & MPI_DOUBLE_PRECISION, COMM, IERR) DO JJ=0, LONG-1 IPOSINRHSINTR = abs( POSINRHSINTR_BWD( IWCB( & POSIWCB+1+JJ ) ) ) IF (IPOSINRHSINTR.EQ.0) CYCLE RHSINTR(IPOSINRHSINTR,K) = W(POSWCB+1+JJ) ENDDO ENDDO POSIWCB = POSIWCB + LONG POSWCB = POSWCB + LONG ENDIF POOL_FIRST_POS = IIPOOL IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(INODE))) & GOTO 1010 ENDIF IPOOL( IIPOOL ) = INODE IIPOOL = IIPOOL + 1 1010 CONTINUE IF = FRERE( STEP(INODE) ) DO WHILE ( IF .GT. 0 ) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) .eq. MYID ) THEN IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(IF))) THEN IF = FRERE(STEP(IF)) CYCLE ENDIF ENDIF IPOOL( IIPOOL ) = IF IIPOOL = IIPOOL + 1 END IF IF = FRERE( STEP( IF ) ) END DO DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO ELSE IF ( MSGTAG .EQ. BACKSLV_MASTER2SLAVE ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NROW_RECU, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) NPIV = - IW( IPOS ) NROW_L = IW( IPOS + 1 ) IF ( NROW_L .NE. NROW_RECU ) THEN WRITE(*,*) 'Error1 : NROW L/RECU=',NROW_L, NROW_RECU CALL MUMPS_ABORT() END IF LONG = NROW_L + NPIV IF ( POSWCB - int(LONG,8)*int(NRHS_B,8) .LT. PLEFTW - 1_8 ) THEN CALL DMUMPS_COMPSO( N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LONG*NRHS_B .LT. PLEFTW - 1_8 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(LONG * NRHS_B- POSWCB,INFO(2)) WRITE(6,*) MYID,' Internal error 3 in bwd solve COMPSO' GOTO 260 END IF END IF P_UPDATE = PLEFTW P_SOL_MAS = PLEFTW + int(NPIV,8) * int(NRHS_B,8) PLEFTW = P_SOL_MAS + int(NROW_L,8) * int(NRHS_B,8) DO K=JBDEB, JBFIN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W( P_SOL_MAS+(K-JBDEB)*NROW_L),NROW_L, & MPI_DOUBLE_PRECISION, & COMM, IERR ) ENDDO IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF APOS = PTRFAC( STEP(INODE)) IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) MTYPE_SLAVE = 0 W(P_UPDATE:P_UPDATE+NPIV*NRHS_B-1)=ZERO CALL DMUMPS_SOL_SLAVE_LR_U(INODE, IWHDLR, -9999, & W, LWC, & NROW_L, NPIV, & P_SOL_MAS, P_UPDATE, & JBDEB, JBFIN, & MTYPE_SLAVE, KEEP, KEEP8, & INFO(1), INFO(2) ) ELSE IF (KEEP(201) .EQ. 1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN MTYPE_SLAVE = 1 LDA_SLAVE = NROW_L ELSE MTYPE_SLAVE = 0 LDA_SLAVE = NPIV ENDIF CALL DMUMPS_SOLVE_GEMM_UPDATE( & A, LA, APOS, NROW_L, & LDA_SLAVE, & NPIV, & NRHS_B, W, LWC, & P_SOL_MAS, NROW_L, & P_UPDATE, NPIV, & MTYPE_SLAVE, KEEP, ZERO) ENDIF IF (KEEP(201) .EQ. 1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF PLEFTW = PLEFTW - int(NROW_L,8) * int(NRHS_B,8) 100 CONTINUE CALL DMUMPS_BUF_SEND_BACKVEC( NRHS_B, INODE, & W(P_UPDATE), & NPIV, NPIV, & MSGSOU, & BACKSLV_UPDATERHS, & JBDEB, JBFIN, & KEEP, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 100 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) GOTO 260 END IF PLEFTW = PLEFTW - NPIV * NRHS_B ELSE IF ( MSGTAG .EQ. BACKSLV_UPDATERHS ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPIV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) IPOS = IPOS + 1 NSLAVES = IW( IPOS + 1 ) IPOS = IPOS + 1 + NSLAVES INODEPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 4 IF ( KEEP(50) .eq. 0 ) THEN LDA = LIELL ELSE LDA = NPIV ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL ELSE J1 = IPOS + 1 J2 = IPOS + NPIV ENDIF IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) DO K=JBDEB, JBFIN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W2, NPIV, MPI_DOUBLE_PRECISION, & COMM, IERR ) I = 1 IF ( (KEEP(253).NE.0) .AND. & (IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI+NSLAVES) & ) THEN DO JJ = J1,J2 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = W2(I) I = I+1 ENDDO ELSE DO JJ = J1,J2 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = & RHSINTR(IPOSINRHSINTR+JJ-J1,K) + W2(I) I = I+1 ENDDO ENDIF ENDDO IW(PTRIST(STEP(INODE))+XXS) = & IW(PTRIST(STEP(INODE))+XXS) - 1 IF ( IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI ) THEN IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN CALL DMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL DMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF APOS = PTRFAC(IW(INODEPOS)) IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN TYPEF = TYPEF_L NROW_L = NPIV+NELIM PANEL_SIZE = DMUMPS_OOC_PANEL_SIZE(NROW_L) IF (PANEL_SIZE.LT.0) THEN WRITE(6,*) ' Internal error in bwd solve PANEL_SIZE=', & PANEL_SIZE CALL MUMPS_ABORT() ENDIF ENDIF IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL DMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB ) IF ( POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR( int(LIELL,8)*int(NRHS_B,8)- & POSWCB-PLEFTW+1_8, & INFO(2) ) GOTO 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 - int(LIELL,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 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 PTWCB = PTRACB(STEP( INODE )) IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) IFR8 = PTRACB(STEP( INODE )) IFR8 = PTWCB + int(NPIV - 1,8) IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + 1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + 1 J2 = IPOS + LIELL END IF CALL DMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSINTR, NRHS, LRHSINTR, & W(PTWCB), LIELL, NPIV+1, & IW, LIW, KEEP, N, POSINRHSINTR_BWD ) IFR8 = IFR8 + int(J2-KEEP(253)-J1+1,8) IF ( KEEP(201).EQ.1 .AND. OOCWRITE_COMPATIBLE_WITH_BLR .AND. & (( NELIM .GT. 0 ).OR. (MTYPE.NE.1 ))) THEN J = NPIV / PANEL_SIZE TWOBYTWO = KEEP(50).EQ.2 .AND. KEEP(105).GT.0 IF (TWOBYTWO) THEN CALL DMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, LPANEL_POS, & IW(IPOS+1+LIELL), NPIV, NPANELS, NROW_L, & NBENTRIES_ALLPANELS) ELSE IF (NPIV.EQ.J*PANEL_SIZE) THEN NPIV_LAST = NPIV NBJLAST = PANEL_SIZE NPANELS = J ELSE NPIV_LAST = (J+1)* PANEL_SIZE NBJLAST = NPIV-J*PANEL_SIZE NPANELS = J+1 ENDIF NBENTRIES_ALLPANELS = & int(NROW_L,8) * int(NPIV,8) & - int( ( J * ( J - 1 ) ) /2,8 ) & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) & - int(J,8) & * int(mod(NPIV, PANEL_SIZE),8) & * int(PANEL_SIZE,8) JJ=NPIV_LAST ENDIF APOSDEB = APOS + NBENTRIES_ALLPANELS DO IPANEL = NPANELS, 1, -1 IF (TWOBYTWO) THEN NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) BEG_PANEL = PANEL_POS(IPANEL) ELSE IF (JJ.EQ.NPIV_LAST) THEN NBJ = NBJLAST ELSE NBJ = PANEL_SIZE ENDIF BEG_PANEL = JJ- PANEL_SIZE+1 ENDIF LDAJ = NROW_L-BEG_PANEL+1 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) PTWCB = PTRACB(STEP(INODE)) IPOSINRHSINTR_PANEL = IPOSINRHSINTR + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ NCB = NROW_L - NPIV IF (KEEP(50).NE.1 .AND.MUST_BE_PERMUTED) THEN CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) CALL DMUMPS_PERMUTE_PANEL( & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, BEG_PANEL-1) ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB.NE. 0) THEN CALL dgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL+NBJ,JBDEB), & 1, ONE, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1 ) ENDIF IF (NCB .NE. 0) THEN CALL dgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1 ) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL dtrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1) ELSE CALL dtrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1) ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB .NE. 0) THEN CALL dgemm( 'T', 'N', NBJ, NRHS_B, & NCB_PANEL-NCB, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL+NBJ,JBDEB), LRHSINTR, & ONE, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ENDIF IF (NCB .NE. 0) THEN CALL dgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, & W( PTWCB+int(NPIV,8) ), LIELL, & ONE, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB),LRHSINTR) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL dtrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ELSE CALL dtrsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO GOTO 1234 ENDIF IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 & .AND. KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL DMUMPS_SOL_BWD_LR_SU ( & INODE, IWHDLR, NPIV, NSLAVES, & LIELL, W, LWC, NRHS_B, PTRACB(STEP(INODE)), & RHSINTR, LRHSINTR, NRHS, & IPOSINRHSINTR, JBDEB, & MTYPE, KEEP, KEEP8, & INFO(1), INFO(2) ) ELSE IF (NELIM .GT.0) THEN IF ( KEEP(50) .eq. 0 ) THEN IST = APOS + int(NPIV,8) * int(LIELL,8) ELSE IF( KEEP(459) .GT. 1) THEN CALL MUMPS_GETI8(IST, IW(PTRIST(STEP(INODE))+XXR)) IST = APOS + IST - int(NPIV,8) * int(NELIM,8) ELSE IST = APOS + int(NPIV,8) * int(NPIV,8) ENDIF END IF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dgemv( 'N', NPIV, NELIM, ALPHA, A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, & RHSINTR(IPOSINRHSINTR,JBDEB), 1 ) ELSE #endif CALL dgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))), LIELL, & ONE, RHSINTR(IPOSINRHSINTR,JBDEB), LRHSINTR) #if defined(MUMPS_USE_BLAS2) END IF #endif ENDIF PPIV_COURANT = int(JBDEB-1,8)*int(LRHSINTR,8) & + int(IPOSINRHSINTR,8) IF (KEEP(459).GT.1 .AND. KEEP(50).NE.0) THEN CALL DMUMPS_SOLVE_BWD_PANELS( A, LA, APOS, & NPIV, IW(IPOS+1+LIELL), & NRHS_B, RHSINTR(1,1), KEEP8(25), LRHSINTR, PPIV_COURANT, & MTYPE, KEEP ) ELSE CALL DMUMPS_SOLVE_BWD_TRSOLVE( A, LA, APOS, & NPIV, LDA, & NRHS_B, RHSINTR(1,1), KEEP8(25), LRHSINTR, PPIV_COURANT, & MTYPE, KEEP ) ENDIF ENDIF 1234 CONTINUE IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 6 + NSLAVES IPOSINRHSINTR = POSINRHSINTR_BWD(IW(IPOS)) IN = INODE 170 IN = FILS(IN) IF (IN .GT. 0) GOTO 170 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) IF (KEEP(31) .NE. 0) THEN IF (.NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & TERMBWD, SLAVEF, KEEP ) NBFINF = NBFINF - 1 ENDIF IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 CALL DMUMPS_FREETOPSO(N, KEEP(28), & IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) GOTO 270 ENDIF DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO IN = -IN IF ( PRUN_BELOW ) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF DO WHILE (IN.GT.0) IF ( PRUN_BELOW ) THEN IF ( .NOT.TO_PROCESS(STEP(IN)) ) THEN IN = FRERE(STEP(IN)) CYCLE ELSE NO_CHILDREN = .FALSE. ENDIF ENDIF POOL_FIRST_POS = IIPOOL IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)), & KEEP(199)) .EQ. MYID) THEN IPOOL(IIPOOL ) = IN IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IN)), & KEEP(199) ) IF ( .NOT. DEJA_SEND( PROCDEST ) ) THEN 400 CONTINUE CALL DMUMPS_BUF_SEND_VCB( NRHS_B, IN, 0, 0, & LIELL, LIELL - KEEP(253), & IW( POSINDICES ), & W( PTRACB(STEP(INODE)) ), JBDEB, JBFIN, & RHSINTR(1, 1), NRHS, LRHSINTR, & IPOSINRHSINTR, NPIV, & KEEP, PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN GOTO 270 ENDIF GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) GOTO 260 END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF END IF IN = FRERE( STEP( IN ) ) END DO ALLOW_OTHERS_TO_LEAVE = .FALSE. IF (NO_CHILDREN) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) ENDIF IF (KEEP(31) .NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERMBWD, SLAVEF, KEEP ) NBFINF = NBFINF - 1 ENDIF IF ( .NOT. NO_CHILDREN ) THEN DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO ENDIF IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL DMUMPS_FREETOPSO( N, KEEP(28), & IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) END IF ELSE IF (MSGTAG.EQ.TERREUR) THEN INFO(1) = -001 INFO(2) = MSGSOU GO TO 270 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. & (MSGTAG.EQ.TAG_DUMMY) ) THEN GO TO 270 ELSE INFO(1) = -100 INFO(2) = MSGTAG GOTO 260 ENDIF GO TO 270 260 CONTINUE IF (NBFINF .NE. 0) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 270 CONTINUE IF (allocated(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE DMUMPS_BACKSLV_TRAITER_MESSAGE SUBROUTINE DMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, & LEN_PANEL_POS, INDICES, NPIV, & NPANELS, NFRONT_OR_NASS, & NBENTRIES_ALLPANELS) IMPLICIT NONE INTEGER, intent (in) :: PANEL_SIZE, NPIV INTEGER, intent (in) :: INDICES(NPIV) INTEGER, intent (in) :: LEN_PANEL_POS INTEGER, intent (out) :: NPANELS INTEGER, intent (out) :: PANEL_POS(LEN_PANEL_POS) INTEGER, intent (in) :: NFRONT_OR_NASS INTEGER(8), intent(out):: NBENTRIES_ALLPANELS INTEGER NPANELS_MAX, I, NBeff INTEGER(8) :: NBENTRIES_THISPANEL NBENTRIES_ALLPANELS = 0_8 NPANELS_MAX = (NPIV+PANEL_SIZE-1)/PANEL_SIZE IF (LEN_PANEL_POS .LT. NPANELS_MAX + 1) THEN WRITE(*,*) "Error 1 in DMUMPS_BUILD_PANEL_POS", & LEN_PANEL_POS,NPANELS_MAX CALL MUMPS_ABORT() ENDIF I = 1 NPANELS = 0 IF (I .GT. NPIV) RETURN 10 CONTINUE NPANELS = NPANELS + 1 PANEL_POS(NPANELS) = I NBeff = min(PANEL_SIZE, NPIV-I+1) IF ( INDICES(I+NBeff-1) < 0) THEN NBeff=NBeff+1 ENDIF NBENTRIES_THISPANEL = int(NFRONT_OR_NASS-I+1,8) * int(NBeff,8) NBENTRIES_ALLPANELS = NBENTRIES_ALLPANELS + NBENTRIES_THISPANEL I=I+NBeff IF ( I .LE. NPIV ) GOTO 10 PANEL_POS(NPANELS+1)=NPIV+1 RETURN END SUBROUTINE DMUMPS_BUILD_PANEL_POS MUMPS_5.8.1/src/dana_driver.F0000664000175000017500000057077715042446441015645 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C SUBROUTINE DMUMPS_ANA_DRIVER(id,idintr) USE MUMPS_STATIC_MAPPING USE DMUMPS_STRUC_DEF USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_INTR_STRUC USE MUMPS_MEMORY_MOD USE DMUMPS_PARALLEL_ANALYSIS USE DMUMPS_ANA_LR USE DMUMPS_LR_CORE USE MUMPS_LR_STATS USE MUMPS_LR_COMMON USE DMUMPS_ANA_AUX_M USE MUMPS_ANA_BLK_M, ONLY: COMPACT_GRAPH_T, LMATRIX_T IMPLICIT NONE INTERFACE C Explicit interfaces when id has the TARGET attribute SUBROUTINE DMUMPS_ANA_ARROWHEADS_WRAPPER & (id, GATHER_MATRIX_ALLOCATED) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET :: id LOGICAL, INTENT(INOUT) :: GATHER_MATRIX_ALLOCATED END SUBROUTINE DMUMPS_ANA_ARROWHEADS_WRAPPER SUBROUTINE DMUMPS_ANA_COMPUTE_ESTIMATES (id, idintr) USE DMUMPS_STRUC_DEF USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_INTR_STRUC TYPE (DMUMPS_STRUC), TARGET :: id TYPE (DMUMPS_INTR_STRUC) :: idintr END SUBROUTINE DMUMPS_ANA_COMPUTE_ESTIMATES END INTERFACE C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) C C Purpose C ======= C C Performs analysis and (if required) Max-trans on the master, then C broadcasts information to the slaves. Also includes mapping. C C C Parameters C ========== C TYPE(DMUMPS_STRUC), TARGET :: id TYPE(DMUMPS_INTR_STRUC) :: idintr C C Local variables C =============== C C C Pointers inside integer array IKEEPALLOC, various data INTEGER(8) IKEEP, NE, NA INTEGER I, allocok C Other locals INTEGER NB_NIV2, IDEST INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MP, LP, MPG LOGICAL PROK, PROKG, LISTVAR_SCHUR_2BE_FREED, LPOK INTEGER SIZE_SCHUR_PASSED INTEGER LEAF, INODE, ISTEP, INN, LPTRAR INTEGER NBLEAF, NBROOT, MYROW_CHECK, INIV2 DOUBLE PRECISION TIMEG DOUBLE PRECISION :: PEAK C C Related to commuicators for parallel analysis: C COMM_PARAORD: communicator on which Parmetis/PTscotch C is performed C COMM_PARASYMB: communicator on which parallel symbolic C facto is performed C PARAORD_to_idCOMM (1:NPROCS_PARAORD) is such that C PARAORD_to_idCOMM(idPARAORD+1)=idCOMM, C where idPARAORD \in [0:NPROCS_PARAORD] C RKinSYMB_PROC0ORD: Rank in COMM_PARASYMB of proc 0 in C COMM_PARAORD C RKinidCOMM_PROC0SYMB: Rank in id%COMM of proc 0 in C COMM_PARASYMB C INTEGER :: COMM_PARAORD, NPROCS_PARAORD, RKinSYMB_PROC0ORD, & OPTION_COMM_PARAORD INTEGER :: COMM_PARASYMB, NPROCS_PARASYMB, & RKinidCOMM_PROC0SYMB LOGICAL :: COMM_PARAORD_ALLOCATED, COMM_PARASYMB_ALLOCATED INTEGER, ALLOCATABLE, DIMENSION(:) :: PARAORD_to_idCOMM #if defined(AVOID_MPI_IN_PLACE) INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP #endif C C INTEGER WORKSPACE C INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: PAR2_NODES INTEGER, DIMENSION(:), POINTER :: PAR2_NODESPTR INTEGER, ALLOCATABLE, DIMENSION(:) :: PROCNODE INTEGER, DIMENSION(:), ALLOCATABLE :: IWtemp INTEGER, DIMENSION(:), ALLOCATABLE :: XNODEL, NODEL INTEGER, DIMENSION(:), POINTER :: SSARBR C Element matrix entry INTEGER, POINTER :: NELT, LELTVAR INTEGER, DIMENSION(:), POINTER :: KEEP, INFO, INFOG INTEGER(8), DIMENSION(:), POINTER :: KEEP8 DOUBLE PRECISION, DIMENSION(:), POINTER :: RINFO DOUBLE PRECISION, DIMENSION(:), POINTER :: RINFOG INTEGER, DIMENSION(:), POINTER :: ICNTL LOGICAL :: I_AM_SLAVE, COND INTEGER, TARGET :: IDUMMY_ARRAY(1) INTEGER(8) :: NNZ_loc, NNZ_TMP INTEGER, POINTER, DIMENSION(:) :: IRN_loc_PTR INTEGER, POINTER, DIMENSION(:) :: JCN_loc_PTR INTEGER, POINTER, DIMENSION(:) :: IRN_PTR INTEGER, POINTER, DIMENSION(:) :: JCN_PTR INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR INTEGER, POINTER, DIMENSION(:) :: UNS_PERM_PTR !$ INTEGER :: NOMPMAX INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER, EXTERNAL :: MUMPS_ENCODE_TPN_IPROC INTEGER :: PROCNODE_VALUE INTEGER K,J, IFS INTEGER SIZE_TEMP_MEM,SIZE_DEPTH_FIRST,SIZE_COST_TRAV LOGICAL IS_BUILD_LOAD_MEM_CALLED LOGICAL PRINT_MAXAVG LOGICAL :: PRINT_NODEINFO 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 :: SIZE_PAR2_NODESPTR INTEGER :: LSIZEOFBLOCKS_PTR LOGICAL :: READY_FOR_ANA_F INTEGER, ALLOCATABLE, DIMENSION(:) :: MAPCOL LOGICAL :: BLKPTR_ALLOCATED, BLKVAR_ALLOCATED INTEGER, POINTER, DIMENSION(:) :: BLKPTR_PTRLOC, BLKVAR_PTRLOC INTEGER :: IB, BLKSIZE INTEGER :: IBcurrent, IPOS, IPOSB, II C Internal work arrays: C DOF2BLOCK(idof)=inode, idof in [1,N], inode in [1,NBLK] C SIZEBLOCK(1:NBLK) (for node valuation) INTEGER, TARGET, DIMENSION(:), allocatable:: SIZEOFBLOCKS INTEGER, DIMENSION(:), allocatable:: DOF2BLOCK INTEGER :: NBRECORDS INTEGER(8) :: NSEND8, NLOCAL8, IDUMMY8 C LMAT_BLOCK: in case of centralized matrix, C to store on MASTER the cleaned Lmatrix C used to compute GCOMP C LMAT_BLOCK might also be saved to C be used during grouping C LUMAT : in case of distributed matrix C to store distributed the cleaned LU matrix C LUMAT might also be saved to C be used for MPI based grouping C LUMAT_REMAP : in case of distributed matrix C it is used to remap LUMAT C C GCOMP : Graph "ready" to be called by orderings C INTEGER(8) :: MEMCNT TYPE(LMATRIX_T) :: LMAT_BLOCK, LUMAT, LUMAT_REMAP INTEGER :: LMAT_BLOCK_AVAIL_I LOGICAL :: GCOMP_PROVIDED, & LUMAT_AVAIL, LMAT_BLOCK_AVAIL LOGICAL :: LUMAT_REMAP_DIST_AVAIL, & LUMAT_REMAP_CENT_AVAIL TYPE(COMPACT_GRAPH_T) :: GCOMP TYPE(COMPACT_GRAPH_T) :: GCOMP_DIST INTEGER(4) :: I4 INTEGER, POINTER, DIMENSION(:) :: & NFSIZPTR, & FREREPTR, & IKEEP1, IKEEP2, IKEEP3 #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: FILS_TMPPTR #endif INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: FILS_TMP INTEGER, ALLOCATABLE, DIMENSION(:) :: STEP_TMP, & LRGROUPS_TMP INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: IKEEPALLOC INTEGER, ALLOCATABLE, DIMENSION(:) :: WORK2ALLOC INTEGER :: SIZELRGROUPS_TMP INTEGER(8) :: SIZEIKEEPALLOC, SIZEWORK2ALLOC INTEGER(kind=8) :: NZ8, LIW8 C NBLK : id%N or order of blocked matrix INTEGER :: NBLK, idNBLKSAVE INTEGER(8) :: LIW8_ELT C GATHER_MATRIX_ALLOCATED: C To be sure that id%IRN and id%JCN are C deallocated only when DMUMPS_GATHER_MATRIX was called LOGICAL :: GATHER_MATRIX_ALLOCATED C C Beginning of executable statements C C DMUMPS_FREE_DATA_ANAFACSOL was called in DMUMPS_DRIVER C to reduce the memory peak during analysis, especially C when computing the graph associated to the input matrix. IS_BUILD_LOAD_MEM_CALLED=.FALSE. KEEP => id%KEEP KEEP8 => id%KEEP8 INFO => id%INFO RINFO => id%RINFO INFOG => id%INFOG RINFOG => id%RINFOG ICNTL => id%ICNTL NELT => id%NELT LELTVAR => id%LELTVAR KEEP(264) = 0 ! reinitialise out-of-range status (0=yes) KEEP(265) = 0 ! reinitialise dupplicates (0=yes) KEEP(280) = 0 ! size of id%LRGROUPS PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) C FIXME: count memory used during analysis MEMCNT = 0_8 C Print per node information only in case there are several C compute nodes (id%KEEP(412): #MPI procs on compute node) PRINT_NODEINFO = PRINT_MAXAVG .AND. id%NPROCS .NE. id%KEEP(412) GATHER_MATRIX_ALLOCATED = .FALSE. COMM_PARAORD = MPI_COMM_NULL COMM_PARASYMB = id%COMM COMM_PARAORD_ALLOCATED = .FALSE. COMM_PARASYMB_ALLOCATED = .FALSE. RKinidCOMM_PROC0SYMB = MASTER NULLIFY ( NFSIZPTR, FREREPTR, & IKEEP1, IKEEP2, IKEEP3, & SSARBR, SIZEOFBLOCKS_PTR, IRN_loc_PTR, JCN_loc_PTR, & IRN_PTR, JCN_PTR, & PAR2_NODESPTR, BLKPTR_PTRLOC, BLKVAR_PTRLOC) IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM) nullify(id%UNS_PERM) C Set default value that witl be reset in C case of blocked format matrices NBLK = id%N GCOMP_PROVIDED = .FALSE. BLKPTR_ALLOCATED = .FALSE. BLKVAR_ALLOCATED = .FALSE. LUMAT_AVAIL = .FALSE. LMAT_BLOCK_AVAIL = .FALSE. C ------------------------------------- C Depending on the type of parallelism, C the master can now (soon) potentially C have the role of a slave C ------------------------------------- I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(ICNTL(4).GE.2)) IF ( PROK ) THEN IF ( KEEP(50) .eq. 0 ) THEN WRITE(MP, '(A)') 'L U Solver for unsymmetric matrices' ELSE IF ( KEEP(50) .eq. 1 ) THEN WRITE(MP, '(A)') & 'L D L^T Solver for symmetric positive definite matrices' ELSE WRITE(MP, '(A)') & 'L D L^T Solver for general symmetric matrices' END IF IF ( KEEP(46) .eq. 1 ) THEN WRITE(MP, '(A)') 'Type of parallelism: Working host' ELSE WRITE(MP, '(A)') 'Type of parallelism: Host not working' END IF END IF IF ( PROKG .AND. (MP.NE.MPG)) THEN IF ( KEEP(50) .eq. 0 ) THEN WRITE(MPG, '(A)') 'L U Solver for unsymmetric matrices' ELSE IF ( KEEP(50) .eq. 1 ) THEN WRITE(MPG, '(A)') & 'L D L^T Solver for symmetric positive definite matrices' ELSE WRITE(MPG, '(A)') & 'L D L^T Solver for general symmetric matrices' END IF IF ( KEEP(46) .eq. 1 ) THEN WRITE(MPG, '(A)') 'Type of parallelism: Working host' ELSE WRITE(MPG, '(A)') 'Type of parallelism: Host not working' END IF END IF IF (PROK) WRITE( MP, 110 ) IF (PROKG .AND. (MPG.NE.MP)) WRITE( MPG, 110 ) C Reinitialize last used size of WK_USER C --------------------------------------- KEEP8(24) = 0_8 C C C C Decode API (ICNTL parameters, mainly) C and check consistency of the KEEP array. C Note: DMUMPS_ANA_CHECK_KEEP also sets C some INFOG parameters CALL DMUMPS_ANA_CHECK_KEEP(id, I_AM_SLAVE) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C ------------------------------------------- C Broadcast KEEP(60) since we need to broadcast C related information C ------------------------------------------ CALL MPI_BCAST( KEEP(60), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C broadcast also size of schur IF (id%KEEP(60) .NE. 0 ) THEN CALL MPI_BCAST( KEEP(116), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF IF (id%KEEP(60) .EQ. 2 .or. id%KEEP(60). EQ. 3) THEN CALL MPI_BCAST( id%NPROW, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NPCOL, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%MBLOCK, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NBLOCK, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) C Note that DMUMPS_INIT_ROOT_ANA will C then use that information. ENDIF C ---------------------------------------------- C Broadcast KEEP(54) now to know if the C structure of the graph is intially distributed C and should be assembled on the master C Broadcast KEEP(55) now to know if the C matrix is in assembled or elemental format C ---------------------------------------------- CALL MPI_BCAST( KEEP(54), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast KEEP(69) now to know if C we will need to communicate during analysis C ---------------------------------------------- CALL MPI_BCAST( KEEP(69), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast Out of core strategy (used only on master so far) C Boradcast KEEP(201), KEEP(202) and KEEP(203) C ---------------------------------------------- CALL MPI_BCAST( KEEP(201), 3, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast analysis strategy (used only on master so far) C ---------------------------------------------- CALL MPI_BCAST( KEEP(244), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) IF (KEEP(244).NE.1) THEN C broadcast parallel ordering strategy used CALL MPI_BCAST( KEEP(245), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF C --------------------------- C Fwd in facto C Broadcast KEEP(251,252,253) defined on master so far CALL MPI_BCAST( KEEP(251), 3, MPI_INTEGER,MASTER,id%COMM,IERR) C CALL MPI_BCAST( KEEP(401), 1, MPI_INTEGER,MASTER,id%COMM,IERR) id%KEEP(400) = 0 id%KEEP(369) = id%KEEP(368) !$ IF (id%KEEP(401).GT.0) THEN !$ id%KEEP(400) = omp_get_max_threads() C => id%KEEP(400)>=1 C C IF KEEP(400)<=1 on all procs switch off L0 thread: !$ CALL MPI_ALLREDUCE(id%KEEP(400),NOMPMAX,1,MPI_INTEGER, !$ & MPI_MAX,id%COMM,IERR) !$ IF (NOMPMAX.LE.1) THEN !$ id%KEEP(400) = 0 !$ id%KEEP(401) = 0 !$ ENDIF !$ ENDIF !$ IF (id%KEEP(400).GT.0 .AND. id%KEEP(401).GT.0 !$ & .AND. id%KEEP(369).GT.0) THEN C reset id%KEEP(400) to value provided by user !$ id%KEEP(400) = min(id%KEEP(400),id%KEEP(369)) !$ ENDIF CALL MPI_BCAST( id%KEEP(490), 5, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( KEEP(123),1,MPI_INTEGER,MASTER,id%COMM,IERR) C ---------------------------------------------- C Broadcast N C ---------------------------------------------- CALL MPI_BCAST( id%N, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast NZ for assembled entry C ---------------------------------------------- IF ( KEEP(55) .EQ. 0) THEN IF ( KEEP(54) .eq. 3 ) THEN C Reset to 0 id%KEEP8(29) for host not working, since C value provided by user might be undefined IF (.NOT.I_AM_SLAVE) id%KEEP8(29)= 0_8 C Compute total number of non-zeros CALL MPI_ALLREDUCE( id%KEEP8(29), id%KEEP8(28), 1, & MPI_INTEGER8, & MPI_SUM, id%COMM, IERR ) C Local number of non-zeros cannot be negative IF (id%KEEP8(29) .LT. 0_8) THEN id%INFO(1) = -2 CALL MUMPS_SET_IERROR(id%KEEP8(29), id%INFO(2)) ENDIF ELSE C Broadcast NZ from the master node CALL MPI_BCAST( id%KEEP8(28), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) END IF C Total number of non zeros must be positive strictly IF (id%KEEP8(28) .LE. 0_8) THEN id%INFO(1) = -2 CALL MUMPS_SET_IERROR(id%KEEP8(28), id%INFO(2)) ENDIF ELSE C Broadcast NA_ELT <=> KEEP8(30) for elemental entry CALL MPI_BCAST( id%KEEP8(30), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) ENDIF IF( id%KEEP(54).EQ.3) THEN C test IRN_loc and JCN_loc allocated on working procs IF (I_AM_SLAVE .AND. id%KEEP8(29).GT.0 .AND. & ( (.NOT. associated(id%IRN_loc)) .OR. & (.NOT. associated(id%JCN_loc)) ) & ) THEN id%INFO(1) = -22 id%INFO(2) = 16 ENDIF ENDIF IF ( associated(id%MEM_DIST) ) THEN DEALLOCATE( id%MEM_DIST ) ENDIF allocate( id%MEM_DIST( 0:id%NSLAVES-1 ), STAT=IERR ) IF ( IERR .GT. 0 ) THEN INFO(1) = -7 INFO(2) = id%NSLAVES IF ( LPOK ) THEN WRITE(LP, 150) 'MEM_DIST' END IF END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 id%MEM_DIST(0:id%NSLAVES-1) = 0 CALL MUMPS_INIT_ARCH_PARAMETERS( & id%COMM,id%COMM_NODES,KEEP(69),KEEP(46), & id%NSLAVES,id%MEM_DIST,INFO ) C ======================== C Write problem to a file, C if requested by the user C ======================== CALL DMUMPS_DUMP_PROBLEM(id) IF ( id%INFO(1) .LT. 0 ) GOTO 500 C ================= C ANALYSIS BY BLOCK C ================= IF ( id%MYID .EQ. MASTER ) THEN IF (KEEP(13).EQ.1) THEN NBLK=id%NBLK ELSE IF (KEEP(13).LT.0) THEN C regular blocks in BLKVAR of size -KEEP(13) C mod(id%N,-KEEP(13)) has already been checked NBLK = id%N/(-KEEP(13)) ENDIF C end of id%MYID .EQ. MASTER ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 500 C C Broadcast KEEP(13-14), NBLK CALL MPI_BCAST( KEEP(13), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( NBLK, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C C =========================== IF (KEEP(13).NE.0) THEN C { BEGIN preparation ANA_BLK C =========================== IF ( & ( KEEP(244).NE.1) & .OR. ( (KEEP(54).NE.3).AND.(id%MYID.EQ.MASTER) ) & .OR. (KEEP(54).EQ.3) ) THEN C{ C ---------------------------------------- C Allocate SIZEOFBLOCKS, DOF2BLOCK C ---------------------------------------- IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) allocate(SIZEOFBLOCKS(NBLK), DOF2BLOCK(id%N), & STAT=allocok) C IF (allocok.NE.0) THEN id%INFO( 1 ) = -7 id%INFO( 2 ) = id%N+NBLK IF ( LPOK ) WRITE(LP, 150) ' SIZEOFBLOCKS, DOF2BLOCK' ENDIF C IF ( (allocok.EQ.0) .AND. (id%MYID.EQ.MASTER)) THEN C{ BLKPTR and BLKVAR needed for DMUMPS_EXPAND_TREE C allocate then if not associated IF (.NOT.associated(id%BLKPTR).OR.KEEP(13).LT.0) THEN BLKPTR_ALLOCATED = .TRUE. C allocate(id%BLKPTR(NBLK+1), STAT=allocok) allocate(BLKPTR_PTRLOC(NBLK+1), STAT=allocok) IF (allocok.NE.0) THEN BLKPTR_ALLOCATED = .FALSE. id%INFO( 1 ) = -7 id%INFO( 2 ) = NBLK+1 IF ( LPOK ) WRITE(LP, 150) ' id%BLKPTR ' ENDIF ELSE BLKPTR_PTRLOC=>id%BLKPTR ENDIF IF (allocok.EQ.0) THEN IF (.NOT.associated(id%BLKVAR).OR.KEEP(13).LT.0) THEN allocate(BLKVAR_PTRLOC(id%N), STAT=allocok) BLKVAR_ALLOCATED = .TRUE. IF (allocok.NE.0) THEN BLKVAR_ALLOCATED = .FALSE. id%INFO( 1 ) = -7 id%INFO( 2 ) = id%N IF ( LPOK ) WRITE(LP, 150) ' id%BLKVAR ' ENDIF ELSE BLKVAR_PTRLOC => id%BLKVAR ENDIF ENDIF C} ENDIF C} ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 500 IF ( id%MYID .EQ. MASTER ) THEN C{ ----------------------------------------- C Compute SIZEOFBLOCKS, DOF2BLOCK on MASTER C based on id%BLKPTR and id%BLKVAR C and compute id%BLKPTR and id%BLKVAR if not C provided by user C ----------------------------------------- IF (BLKVAR_ALLOCATED) THEN C implicitly id%BLKVAR(I)=I DO I=1, id%N BLKVAR_PTRLOC(I)=I ENDDO ENDIF IF (BLKPTR_ALLOCATED) THEN IB=0 BLKSIZE=-KEEP(13) DO I=1, id%N, BLKSIZE IB=IB+1 BLKPTR_PTRLOC(IB) = I ENDDO BLKPTR_PTRLOC(NBLK+1) = id%N+1 ENDIF C CALL MUMPS_AB_COMPUTE_SIZEOFBLOCK ( & NBLK, id%N, BLKPTR_PTRLOC(1), BLKVAR_PTRLOC(1), & SIZEOFBLOCKS, DOF2BLOCK) C} ENDIF C ======================== IF (KEEP(244).NE.1) THEN C{ Parallel analysis C ======================== C KEEP(13).ne.0 only if KEEP(339).NE.0 : IF (KEEP(339).EQ.0) THEN INFO(1) = -901 INFO(2) = KEEP(13) IF ( LPOK ) WRITE(LP, 150) ' Internal error K339' ENDIF NNZ_loc = 0_8 C ----------------------------------------- C Build distributed clean LUMAT matrix C even when matrix is provided centralised C ----------------------------------------- IF (KEEP(54).EQ.3) THEN IF (.NOT. I_AM_SLAVE .OR. ! non-working master & KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc NNZ_loc = KEEP8(29) ENDIF ELSE C Matrix on host IF (id%MYID.EQ.MASTER) THEN C Store input matrix (IRN/JCN) as a cleaned blocked Lmatrix C of nodes (indices \in [1,NBLK]) IF (id%KEEP8(28) .EQ. 0_8) THEN IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ELSE IRN_loc_PTR => id%IRN JCN_loc_PTR => id%JCN NNZ_loc = id%KEEP8(28) ENDIF ELSE IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ENDIF ENDIF C build communicator for parallel ordering C used to distribute LUMAT OPTION_COMM_PARAORD = 0 CALL MUMPS_BUILD_COMM_PARA_ANA ( & OPTION_COMM_PARAORD, id%N, & id%COMM, id%MYID, id%COMM_NODES, id%MYID_NODES, & id%NPROCS, id%NSLAVES, & id%KEEP(1), & COMM_PARAORD, NPROCS_PARAORD, & COMM_PARAORD_ALLOCATED, & COMM_PARASYMB, NPROCS_PARASYMB, & COMM_PARASYMB_ALLOCATED, & id%ICNTL(1), id%INFO(1)) C allocate and initialize PARAORD_to_idCOMM if (allocated(PARAORD_to_idCOMM)) & DEALLOCATE(PARAORD_to_idCOMM) allocate(PARAORD_to_idCOMM(NPROCS_PARAORD), #if defined(AVOID_MPI_IN_PLACE) & TMP(NPROCS_PARAORD), #endif & STAT=allocok) IF (allocok.NE.0) THEN id%INFO( 1 ) = -7 id%INFO( 2 ) = NPROCS_PARAORD #if defined(AVOID_MPI_IN_PLACE) & + NPROCS_PARAORD #endif IF ( LPOK ) WRITE(LP, 150) ' PARAORD_to_idCOMM' ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 500 CALL MUMPS_BUILD_PARAORD_to_idCOMM ( & id%COMM, id%MYID, id%KEEP(1), & COMM_PARASYMB, NPROCS_PARASYMB, & COMM_PARAORD, NPROCS_PARAORD, & PARAORD_to_idCOMM, #if defined(AVOID_MPI_IN_PLACE) & TMP, #endif & RKinSYMB_PROC0ORD, & RKinidCOMM_PROC0SYMB, id%NPROCS ) #if defined(AVOID_MPI_IN_PLACE) DEALLOCATE(TMP) #endif C C C build LUMAT such that col of LUMAT are distributed C only procs in COMM_PARAORD C CALL MUMPS_AB_DCOORD_TO_DLUMAT ( & id%MYID, id%NPROCS, id%COMM, & NPROCS_PARAORD, PARAORD_to_idCOMM, & NBLK, id%N, & NNZ_loc, & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), id%KEEP8(1), & LUMAT) IF (allocated(PARAORD_to_idCOMM)) THEN DEALLOCATE(PARAORD_to_idCOMM) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 LUMAT_AVAIL = .TRUE. C SIZEOFBLOCKS needed on all procs during // analysis CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, & id%COMM, IERR ) C C} End of Parallel analysis ELSE C =================== C{ Sequential analysis C =================== C ======================= IF (KEEP(54).NE.3.OR.id%NPROCS.EQ.1) THEN C ======================= C{ Matrix structure available on host C also case of distributed input matrix format C with one mpi proc C --------------------- KEEP(14) = 0 IF (id%MYID.EQ.MASTER) THEN C Store input matrix (IRN/JCN) as a cleaned blocked Lmatrix C of nodes (indices \in [1,NBLK]) IF (KEEP(54).NE.3) THEN IF (id%KEEP8(28) .EQ. 0_8) THEN IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY ELSE IRN_PTR => id%IRN JCN_PTR => id%JCN ENDIF NNZ_TMP = id%KEEP8(28) ELSE IF (id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY id%KEEP8(29) = 0_8 ELSE IRN_PTR => id%IRN_loc JCN_PTR => id%JCN_loc ENDIF NNZ_TMP = id%KEEP8(29) ENDIF CALL MUMPS_AB_COORD_TO_LMAT ( id%MYID, & NBLK, id%N, NNZ_TMP, IRN_PTR(1), JCN_PTR(1), & DOF2BLOCK, & INFO(1), INFO(2), LP, LPOK, & LMAT_BLOCK, IDUMMY8, KEEP(1) ) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C IF (id%MYID.EQ.MASTER) THEN C From LMAT_BLOCK build GCOMP format wich requires C symmetrizing the Lmatrix CALL MUMPS_AB_LMAT_TO_CLEAN_G ( id%MYID, .TRUE., & .TRUE., ! not relevant because unfold is true & LMAT_BLOCK, GCOMP, & INFO(1), ICNTL(1), MEMCNT) GCOMP_PROVIDED = .TRUE. IF (KEEP(494).EQ.0.OR.KEEP(487).NE.1) THEN CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK, KEEP(147)) LMAT_BLOCK_AVAIL_I = 0 ELSE LMAT_BLOCK_AVAIL_I = 1 ENDIF ENDIF CALL MPI_BCAST( LMAT_BLOCK_AVAIL_I, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) LMAT_BLOCK_AVAIL = (LMAT_BLOCK_AVAIL_I.EQ.1) C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C} C ==== ELSE C ==== C ---------------------- C{ matrix is distributed C ---------------------- IF (.NOT. I_AM_SLAVE .OR. ! non-working master & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY id%KEEP8(29) = 0_8 ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc ENDIF C C Given distributed matrix IRN_loc_PTR, JCN_loc_PTR C build distributed cleaned graph GCOMP and C save distributed LUMAT in case of grouping C IF (id%NPROCS.EQ.1) THEN C Build GCOMP, the centralized final cleaned graph READY_FOR_ANA_F = .TRUE. CALL MUMPS_AB_DCOORD_TO_DCOMPG ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & LUMAT, LUMAT_AVAIL, GCOMP, READY_FOR_ANA_F) GCOMP_PROVIDED = .TRUE. ELSE READY_FOR_ANA_F = .FALSE. CALL MUMPS_AB_DCOORD_TO_DCOMPG ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & LUMAT, LUMAT_AVAIL, GCOMP_DIST, READY_FOR_ANA_F) ENDIF IF (LUMAT_AVAIL.AND.KEEP(487).NE.1) THEN CALL MUMPS_AB_FREE_LMAT(LUMAT, KEEP(147)) LUMAT_AVAIL = .FALSE. ENDIF C C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C C} end matrix structure is distributed C ===== ENDIF C ===== C} end of sequential analysis C ===== ENDIF C ===== IF (allocated(DOF2BLOCK)) THEN C DOF2BLOCK reused on master if pivot order given by user IF ( (id%MYID.NE.MASTER) .OR. & (id%MYID.EQ.MASTER).AND. (KEEP(256) .NE. 1)) THEN DEALLOCATE(DOF2BLOCK) ENDIF ENDIF C ======================== ENDIF C } END preparation ANA_BLK C ========================= C ==================================================== C TEST FOR SEQUENTIAL OR PARALLEL ANALYSIS (KEEP(244)) C ==================================================== IF ( (KEEP(244).EQ.1) .AND. (KEEP(54) .eq. 3) ) THEN C ----------------------------------------------- C Sequential analysis: C Collect on the host -- if matrix is distributed C at analysis -- all integer information needed C to perform ordering C ----------------------------------------------- C FIXME: one should test instead if GCOMP_DIST available C instead of retestinf KEEP(13) and NPROCS.NE.1 IF (KEEP(13).NE.0) THEN IF (id%NPROCS.NE.1) THEN CALL MUMPS_AB_GATHER_GRAPH( & id%ICNTL(1), KEEP(1), id%COMM, id%MYID, id%NPROCS, & id%INFO(1), & GCOMP_DIST, GCOMP) GCOMP_PROVIDED = .TRUE. C CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST, MEMCNT) ENDIF ELSE CALL DMUMPS_GATHER_MATRIX(id) GATHER_MATRIX_ALLOCATED = .TRUE. CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF 1234 CONTINUE IF (KEEP(244) .EQ. 1) THEN C Sequential analysis : Schur IF ( id%MYID .eq. MASTER ) THEN C Prepare arguments for call to DMUMPS_ANA_F and C DMUMPS_ANA_F_ELT in case id%SCHUR was not allocated C by user. The objective is to avoid passing a null C pointer. C FIXME Block fomat for Schur IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN SIZE_SCHUR_PASSED = 1 LISTVAR_SCHUR_2BE_FREED=.TRUE. allocate( id%LISTVAR_SCHUR( 1 ), STAT=allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) & 'PB allocating an array of size 1 for Schur!! ' INFO(1)=-7 INFO(2)=1 END IF ELSE SIZE_SCHUR_PASSED=id%SIZE_SCHUR LISTVAR_SCHUR_2BE_FREED = .FALSE. END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF C IF ((id%MYID.EQ.MASTER).AND.(KEEP(244) .EQ. 1) & .AND. (id%N.EQ.NBLK) & ) THEN C Sequential analysis : maximum transversal on master IF ((KEEP(50).NE.1).AND. & .NOT.((KEEP(23).EQ.7).AND.KEEP(50).EQ.0) & ) THEN C (KEEP(23).EQ.7).AND.KEEP(50).EQ.0) : C For unsymmetric matrix, if automatic setting is requested C default setting of Maximum Transversal is decided during C DMUMPS_ANA_F and is based on matrix unsymmetry. C Thus in this case we skip DMUMPS_ANA_O IF ( ( KEEP(23) .NE. 0 ) .OR. C Automatic choice for scaling does not force Maxtrans C Only when scaling is explicitly asked during analysis C (KEEP(52)=-2) DMUMPS_ANA_O is called & KEEP(52) .EQ. -2 ) THEN C C Maximum Trans. algorithm called on original matrix. C We compute a permutation of the original matrix to C have a zero free diagonal C KEEP(23)=7 means that automatic choice C of max trans value will be done during analysis C Permutation is held in UNS_PERM(1, ...,N). C Maximum transversal is not available for element C entry format C UNS_PERM that might be set to C to permutation computed during Max transversal ALLOCATE(id%UNS_PERM(id%N),IKEEPALLOC(3_8*int(id%N,8)), & WORK2ALLOC(id%N), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( 5_8 * int(id%N,8), INFO(2) ) ELSE CALL DMUMPS_ANA_O(id%N, id%KEEP8(28), KEEP(23), & id%UNS_PERM, IKEEPALLOC, 3_8*int(id%N,8), & id%IRN, id%JCN, id%A, & id%ROWSCA, id%COLSCA, & WORK2ALLOC, id%KEEP, id%ICNTL, id%INFO, id%INFOG) IF (allocated(WORK2ALLOC)) DEALLOCATE(WORK2ALLOC) IF (KEEP(23).EQ.0) THEN C Maximum tranversal did not produce a permutation IF (associated( id%UNS_PERM )) & DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF C Check if IKEEPALLOC needed for ANA_F IF (KEEP(23).EQ.0.AND.(KEEP(95).EQ.1)) THEN IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) ENDIF ENDIF IF (INFO(1) .LT. 0) THEN C Fatal error C Permutation was not computed; reset keep(23) KEEP(23) = 0 ELSE ENDIF ELSE KEEP(23) = 0 C Switch off C compressed/contrained ordering id%KEEP(95) = 1 END IF ENDIF C END OF MAX-TRANS ON THE MASTER ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C IF ( KEEP(244) .EQ. 1) THEN C Sequential analysis: allocate data for ordering on MASTER IF (id%MYID.EQ.MASTER) THEN C allocate IKEEPALLOC and TREE related pointers C IKEEPALLOC might have been allocated in DMUMPS_ANA_O C and IKEEPALLOC(1:N) might hold information to C be given to ANA_F. IF (allocated(IKEEPALLOC)) THEN ALLOCATE( FILS_TMP(NBLK), FREREPTR(NBLK), & NFSIZPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(int(NBLK,8)*3_8, INFO(2)) ENDIF ELSE ALLOCATE(IKEEPALLOC(int(NBLK,8)+2_8*int(id%N,8)), & FILS_TMP(NBLK), FREREPTR(NBLK), & NFSIZPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(int(NBLK,8)*4_8+2_8*int(id%N,8), & INFO(2)) ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF C IF (KEEP(244) .EQ. 1) THEN C Sequential analysis IF ( id%MYID .eq. MASTER ) THEN C BEGINNING OF ANALYSIS ON THE MASTER C ------------------------------------------------------ C For element entry (KEEP(55).ne.0), we do not know NZ, C and so the whole allocation of IW cannot be done at this C point and more workspace is declared/allocated/used C inside DMUMPS_ANA_F_ELT. C ------------------------------------------------------ C IF (KEEP(55) .EQ. 0) THEN C ---------------- C Assembled format C ---------------- NZ8=id%KEEP8(28) C Compute LIW8: C For local orderings a contiguous space IW C of size LIW8 must be provided. C IW must hold the graph (with double adjacency C list) and and extra space of size the number of C nodes in the graph: C ==> LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8 C In case of analysis by block and C However, when GCOMP is provided directly then C IW is not allocated C ==> LIW8 = 0 C In this case C size(LCOMP%ADJ)>= 2_8*NZ8+int(NBLK,8)+1_8 C should hold IF (KEEP(13).NE.0) THEN C Compact graph is provided on entry to DMUMPS_ANA_F NZ8=0_8 ! GCOMP is provided on entry ENDIF IF (NZ8.EQ.0_8) THEN LIW8 = 0_8 ELSE LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8 ENDIF C ELSE C ---------------- C Elemental format C ---------------- C Only available for AMD, METIS, and given ordering #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) COND = (KEEP(60) .NE. 0) .OR. (KEEP(256) .EQ. 5) #else COND = (KEEP(60) .NE. 0) #endif IF( COND ) THEN C C C we suppress supervariable detection when Schur C is active or when METIS is applied C Workspaces for FLAG(N), and either LEN(N) or some pointers(N+1) LIW8_ELT = int(id%N,8) + int(id%N,8) + 1_8 ELSE C Spaces FLAG(N), LEN(N), N+3, SVAR(0:N), LIW8_ELT = int(id%N,8) + int(id%N,8) + & int(id%N,8)+3_8 + int(id%N,8)+1_8 ENDIF C ENDIF C We must ensure that an array of order C 3*N is available for DMUMPS_ANA_LNEW IF (KEEP(55) .EQ. 0) THEN IF (LIW8.LT.3_8*int(NBLK,8)) LIW8=3_8*int(NBLK,8) ELSE IF (LIW8_ELT.LT.3_8*int(id%N,8)) LIW8_ELT=3_8*int(id%N,8) ENDIF C IF ( KEEP(256) .EQ. 1 ) THEN C It has been checked that id%PERM_IN is associated but C values of pivot order will be checked later and C should be checked here too C PERM_IN( I ) = position of I in the pivot order IKEEP2 => IKEEPALLOC(int(NBLK+1,8):int(NBLK,8)+int(id%N,8)) C Build inverse permutation and check PERM_IN DO I = 1, id%N IKEEP2(I) = 0 ENDDO DO I = 1, id%N IF ( id%PERM_IN(I) .LT.1 .OR. & id%PERM_IN(I) .GT. id%N ) THEN C PERM_IN entry is out-of-range INFO(1) = -4 INFO(2) = I GOTO 10 ELSE IF ( IKEEP2(id%PERM_IN(I)) .NE. 0 ) THEN C Duplicate entry in PERM_IN was found INFO(1) = -4 INFO(2) = I GOTO 10 ELSE C Store entry in inverse permutation IKEEP2(id%PERM_IN( I )) = I ENDIF ENDDO IF ((KEEP(55) .EQ. 0).AND.(KEEP(13).NE.0) & .AND.(KEEP(13).NE.-1) & ) THEN C Build blocked permutation: C IKEEPALLOC(IB)= IBPos where IB, IBPos \in [1:NBLK] C IKEEP2 holds inverse permutation IPOSB = 0 IPOS = 1 DO WHILE (IPOS.LE.id%N) IPOSB = IPOSB+1 I = IKEEP2(IPOS) IBcurrent = DOF2BLOCK(I) BLKSIZE = SIZEOFBLOCKS(IBcurrent) IKEEPALLOC(IBcurrent) = IPOSB IF (BLKSIZE.GT.1) THEN DO II = 1, BLKSIZE-1 IPOS = IPOS+1 I = IKEEP2(IPOS) IB = DOF2BLOCK(I) IF (IB.NE.IBcurrent) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & " ERROR: given permutation (ICNTL(7)=1)", & " incompatible with block format" ENDIF INFO(1)= -4 INFO(2)= I GOTO 10 ENDIF ENDDO ENDIF IPOS = IPOS+1 ENDDO C IF PERM_IN is correct then C on exit last position should be NBLK IF (IPOSB.NE.NBLK) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & " ERROR: given permutation (ICNTL(7)=1)", & " incompatible with block format" ENDIF INFO(1)= -4 C N+1 to indicate "global" error INFO(2)= id%N+1 GOTO 10 ENDIF ELSE DO I = 1, id%N IKEEPALLOC( I ) = id%PERM_IN( I ) END DO ENDIF IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) END IF INFOG(1) = 0 INFOG(2) = 0 C Initialize structural symmetry value to not yet computed. INFOG(8) = -1 IF (KEEP(55) .EQ. 0) THEN IKEEP1 => IKEEPALLOC(1:NBLK) IKEEP2 => IKEEPALLOC(int(NBLK+1,8): & int(NBLK,8)+int(id%N,8)) IKEEP3 => IKEEPALLOC(int(NBLK,8)+int(id%N+1,8): & int(NBLK,8)+2_8*int(id%N,8)) C id%UNS_PERM corresponds to argument PIV C in DMUMPS_ANA_F, it should be an assumed-shape C array rather than a possibly null pointer: IF (associated(id%UNS_PERM)) THEN UNS_PERM_PTR => id%UNS_PERM ELSE UNS_PERM_PTR => IDUMMY_ARRAY ENDIF IF (KEEP(13).EQ.0) THEN CALL DMUMPS_ANA_F(id%N, NZ8, & id%IRN, id%JCN, & LIW8, IKEEP1, IKEEP2, IKEEP3, & KEEP(256), NFSIZPTR, & FILS_TMP, & FREREPTR, & id%LISTVAR_SCHUR, SIZE_SCHUR_PASSED, & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, & UNS_PERM_PTR, & id%CNTL(4), id%COLSCA, id%ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & ) ELSE IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY CALL DMUMPS_ANA_F(NBLK, NZ8, & IRN_loc_PTR, JCN_loc_PTR, & LIW8, IKEEP1, IKEEP2, IKEEP3, & KEEP(256), NFSIZPTR, & FILS_TMP, FREREPTR, & id%LISTVAR_SCHUR, SIZE_SCHUR_PASSED, & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, & UNS_PERM_PTR, & id%CNTL(4), id%COLSCA, id%ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & , id%N, SIZEOFBLOCKS, GCOMP_PROVIDED, GCOMP & ) IF (GCOMP_PROVIDED) & CALL MUMPS_AB_FREE_GCOMP(GCOMP, MEMCNT) C ENDIF INFOG(7) = KEEP(256) C UNS_PERM_PTR was only used locally C for the call to DMUMPS_ANA_F NULLIFY(UNS_PERM_PTR) ELSE allocate( XNODEL ( id%N+1 ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = id%N + 1 IF ( LPOK ) THEN WRITE(LP, 150) 'XNODEL' END IF GOTO 10 ENDIF IF (LELTVAR.ne.id%ELTPTR(NELT+1)-1) THEN C -- internal error INFO(1) = -2002 INFO(2) = id%ELTPTR(NELT+1)-1 GOTO 10 ENDIF allocate( NODEL ( LELTVAR ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LELTVAR IF ( LPOK ) THEN WRITE(LP, 150) 'NODEL' END IF GOTO 10 ENDIF CALL DMUMPS_ANA_F_ELT(id%N, NELT, & id%ELTPTR(1), id%ELTVAR(1), LIW8_ELT, & IKEEPALLOC(1), & KEEP(256), NFSIZPTR(1), FILS_TMP(1), & FREREPTR(1), id%LISTVAR_SCHUR(1), & SIZE_SCHUR_PASSED, & ICNTL(1), INFOG(1), KEEP(1),KEEP8(1), & id%NSLAVES, & XNODEL(1), NODEL(1) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & ) INFOG(7)=KEEP(256) C C XNODEL and NODEL as output to DMUMPS_ANA_F_ELT C be used in DMUMPS_FRTELT and thus C cannot be deallocated at this point C ENDIF IF ( LISTVAR_SCHUR_2BE_FREED ) THEN C We do not want to have LISTVAR_SCHUR C allocated of size 1 if Schur is off. DEALLOCATE( id%LISTVAR_SCHUR ) NULLIFY ( id%LISTVAR_SCHUR ) LISTVAR_SCHUR_2BE_FREED = .TRUE. ENDIF C ------------------------------ C Significant error codes should C always be in INFO(1/2) C ------------------------------ INFO(1)=INFOG(1) INFO(2)=INFOG(2) C save statistics in KEEP array. KEEP(28) = INFOG(6) IKEEP = 1_8 NA = IKEEP + int(id%N,8) NE = IKEEP + 2_8 * int(id%N,8) C -- if (id%myid.eq.master) ENDIF C -- if sequential analysis ENDIF C 10 CONTINUE IF (KEEP(244).EQ.1) THEN CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF IF ((KEEP(244).EQ.1).AND.(KEEP(55).EQ.0)) THEN C Sequential analysis on assembled matrix C check if max transversal should be called CALL MPI_BCAST(KEEP(23),1,MPI_INTEGER,MASTER,id%COMM,IERR) IF ( (KEEP(23).LE.-1).AND.(KEEP(23).GE.-6) ) THEN C -- Perform max transversal KEEP(23) = -KEEP(23) IF (id%MYID.EQ.MASTER) THEN IF (.NOT. associated(id%A)) KEEP(23) = 1 IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (allocated(FILS_TMP) ) THEN DEALLOCATE(FILS_TMP) ENDIF IF (associated(FREREPTR) ) THEN DEALLOCATE(FREREPTR) NULLIFY(FREREPTR) ENDIF IF (associated(NFSIZPTR) ) THEN DEALLOCATE(NFSIZPTR) NULLIFY(NFSIZPTR) ENDIF ENDIF GOTO 1234 ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(244).EQ.1).AND. (KEEP(55).EQ.0)) THEN C Sequential ordering on assembled matrix IF ((KEEP(54).EQ.3).AND.KEEP(494).EQ.0) THEN IF (GATHER_MATRIX_ALLOCATED) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF GATHER_MATRIX_ALLOCATED= .FALSE. ENDIF ENDIF ENDIF ENDIF IF (KEEP(244).NE.1) THEN C{ Parallel analysis IF (id%MYID .EQ. MASTER) THEN C KEEPALLOC reuse later C FIXME allocate of size 2*NBLK and C allocate of size 3*id%N after call ana_aux_par SIZEIKEEPALLOC = 3_8*int(id%N,8) SIZEWORK2ALLOC = max(4_8*int(NBLK,8), int(id%NPROCS+1,8)) ALLOCATE( IKEEPALLOC(SIZEIKEEPALLOC), & WORK2ALLOC(SIZEWORK2ALLOC), & FILS_TMP(NBLK), FREREPTR(NBLK), NFSIZPTR(NBLK), & stat=IERR) ELSE IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN C Allocate only on procs concerned by parallel analysis SIZEIKEEPALLOC = 3_8*int(NBLK,8) SIZEWORK2ALLOC = 4_8*int(NBLK,8) ALLOCATE(IKEEPALLOC(SIZEIKEEPALLOC), & WORK2ALLOC(SIZEWORK2ALLOC), stat=IERR ) ELSE C Not concerned by DMUMPS_ANA_F_PAR IERR = 0 SIZEIKEEPALLOC = 0_8 SIZEWORK2ALLOC = 0_8 ENDIF IF (IERR.GT.0) THEN INFO(1) = -7 IF (id%MYID .EQ. MASTER) THEN CALL MUMPS_SET_IERROR( & SIZEIKEEPALLOC+SIZEWORK2ALLOC+3_8*int(NBLK,8), & INFO(2) ) ELSE CALL MUMPS_SET_IERROR( & SIZEIKEEPALLOC+SIZEWORK2ALLOC, & INFO(2) ) ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C save value provided by user idNBLKSAVE= id%NBLK C #if defined(MUMPS_NOF2003) C Allocatable not allowed in DMUMPS_ANA_F_PAR, C use a pointer instead. FILS_TMP is typically C allocated only on MPI rank 0. IF (allocated(FILS_TMP)) THEN FILS_TMPPTR => FILS_TMP ELSE FILS_TMPPTR => IDUMMY_ARRAY ENDIF #endif IF (LUMAT_AVAIL) THEN C{ C id%NBLK = NBLK IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN IF (RKinidCOMM_PROC0SYMB.NE.MASTER) CALL MUMPS_ABORT() CALL DMUMPS_ANA_F_PAR(id, & IKEEPALLOC, & WORK2ALLOC, & SIZEIKEEPALLOC, & SIZEWORK2ALLOC, & NFSIZPTR, #if defined(MUMPS_NOF2003) & FILS_TMPPTR, #else & FILS_TMP, #endif & FREREPTR, & COMM_PARASYMB ! optional: & , LUMAT, SIZEOFBLOCKS & , COMM_PARAORD, NPROCS_PARAORD & , RKinSYMB_PROC0ORD & ) ENDIF IF (KEEP(494).EQ.0.OR.KEEP(487).NE.1) THEN CALL MUMPS_AB_FREE_LMAT(LUMAT,KEEP(147)) LUMAT_AVAIL = .FALSE. ELSE LUMAT_AVAIL = .TRUE. ENDIF C C} ELSE C{ LUMAT not available and COMM_PARASYMB=id%COMM id%NBLK = id%N CALL DMUMPS_ANA_F_PAR(id, & IKEEPALLOC, & WORK2ALLOC, & SIZEIKEEPALLOC, & SIZEWORK2ALLOC, & NFSIZPTR, #if defined(MUMPS_NOF2003) & FILS_TMPPTR, #else & FILS_TMP, #endif & FREREPTR, & id%COMM & ) C} ENDIF id%NBLK = idNBLKSAVE IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN DEALLOCATE(WORK2ALLOC) IF(id%MYID .NE. MASTER) THEN DEALLOCATE(IKEEPALLOC) ENDIF ENDIF KEEP(28) = INFOG(6) IF (COMM_PARAORD_ALLOCATED) THEN IF (COMM_PARAORD.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_FREE( COMM_PARAORD, IERR ) COMM_PARAORD_ALLOCATED = .FALSE. ENDIF ENDIF IF (COMM_PARASYMB_ALLOCATED) THEN IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_FREE( COMM_PARASYMB, IERR ) COMM_PARASYMB_ALLOCATED = .FALSE. ENDIF ENDIF C Check error after freeing communicators CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C IF (id%MYID.EQ.MASTER) THEN IKEEP = 1_8 NA = IKEEP + int(id%N,8) NE = IKEEP + 2_8 * int(id%N,8) ENDIF C --------------------------------------------------------- C Check whether FILS_TMP, FREREPTR, NFSIZPTR C computed on master of COMM_PARSYMB (RKinidCOMM_PROC0SYMB) C should be send on MASTER C --------------------------------------------------------- IF (RKinidCOMM_PROC0SYMB.NE.MASTER) THEN C allocate data on MASTER of id%COMM IF (id%MYID.EQ.MASTER) THEN C FILS_TMP allocate to size NBLK since it will be C allways copied back in structure ALLOCATE( FILS_TMP(NBLK), FREREPTR(id%N), NFSIZPTR(id%N), & stat=IERR) ENDIF ENDIF IF (IERR.GT.0) THEN INFO(1) = -7 IF (id%MYID .EQ. MASTER) THEN CALL MUMPS_SET_IERROR(3_8*int(id%N,8), INFO(2)) ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF (RKinidCOMM_PROC0SYMB.NE.MASTER) THEN C data computed on master of COMM_PARASYMB to be C sent on MASTER of id%COMM C FIXME to be authorized INFOG data should also C be sent to MASTER of id%COMM CALL MUMPS_ABORT() IF (id%MYID.EQ.RKinidCOMM_PROC0SYMB) THEN CALL MPI_SEND (FILS_TMP(1), NBLK, MPI_INTEGER, & MASTER, CENT_AFTER_PARAORD, id%COMM, IERR) CALL MPI_SEND (FREREPTR(1), NBLK, MPI_INTEGER, & MASTER, CENT_AFTER_PARAORD, id%COMM, IERR) CALL MPI_SEND (NFSIZPTR(1), NBLK, MPI_INTEGER, & MASTER, CENT_AFTER_PARAORD, id%COMM, IERR) C C deallocate data sent to MASTER DEALLOCATE(FILS_TMP, FREREPTR, NFSIZPTR) C FILS_TMP is an allocatable array nullify(FREREPTR, NFSIZPTR) C ENDIF IF (id%MYID.EQ.MASTER) THEN CALL MPI_RECV (FILS_TMP(1), NBLK, MPI_INTEGER, & RKinidCOMM_PROC0SYMB, CENT_AFTER_PARAORD, & id%COMM, STATUS, IERR) CALL MPI_RECV (FREREPTR(1), NBLK, MPI_INTEGER, & RKinidCOMM_PROC0SYMB, CENT_AFTER_PARAORD, & id%COMM, STATUS, IERR) CALL MPI_RECV (NFSIZPTR(1), NBLK, MPI_INTEGER, & RKinidCOMM_PROC0SYMB, CENT_AFTER_PARAORD, & id%COMM, STATUS, IERR) ENDIF C ENDIF C} END IF C Allocated PROCNODE on MASTER IF (id%MYID.EQ.MASTER) THEN allocok = 0 allocate(PROCNODE(NBLK), STAT=allocok) IF (allocok .ne. 0) THEN INFO(1) = -7 INFO(2) = NBLK ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF ( I_AM_SLAVE) THEN KEEP(144)=1 ! MPI process is working ELSE KEEP(144)=0 ENDIF IF(id%MYID .EQ. MASTER) THEN C Save ICNTL(14) value into KEEP(12) CALL MUMPS_GET_PERLU(KEEP(12),ICNTL(14), & KEEP(50),KEEP(54),ICNTL(6),KEEP(52)) CALL DMUMPS_ANA_R(NBLK, FILS_TMP(1), FREREPTR(1), & IKEEPALLOC(NE), IKEEPALLOC(NA)) C ********************************************************** C Continue with CALL to MAPPING routine C ********************* C BEGIN SEQUENTIAL CODE C No mapping computed C ********************* C C In sequential, if no special root C reset KEEP(20) and KEEP(38) to 0 C IF (id%NSLAVES .EQ. 1 & ) THEN id%NBSA = 0 IF ( (id%KEEP(60).EQ.0). & AND.(id%KEEP(53).EQ.0)) THEN C If Schur is on (keep(60).ne.0) C or if RR is on (keep (53) > 0 C then we keep root numbers C root node number in seq id%KEEP(20)=0 C root node number in paral id%KEEP(38)=0 ENDIF C No type 2 nodes: id%KEEP(56)=0 C All mapped on MPI process 0, and of type TPN=0 C (treated as if they were all root of subtree) PROCNODE_VALUE = MUMPS_ENCODE_TPN_IPROC(0, 0, KEEP(199)) DO I = 1, NBLK PROCNODE(I) = PROCNODE_VALUE END DO C It may also happen that KEEP(38) has already been set, C in the case of a distributed Schur complement (KEEP(60)=2 or 3). C In that case, PROCNODE should be set accordingly and KEEP(38) is C not modified. IF (id%KEEP(60) .EQ. 2 .OR. id%KEEP(60).EQ.3) THEN PROCNODE_VALUE = MUMPS_ENCODE_TPN_IPROC(3, 0, KEEP(199)) CALL DMUMPS_SET_PROCNODE(id%KEEP(38), PROCNODE(1), & PROCNODE_VALUE, FILS_TMP(1), NBLK) ENDIF C ******************* C END SEQUENTIAL CODE C ******************* ELSE C ***************************** C BEGIN MAPPING WITH CANDIDATES C (NSLAVES > 1) C ***************************** C C C peak is set by default to 1 largest front + One largest CB PEAK = dble(id%INFOG(5))*dble(id%INFOG(5)) + ! front matrix & dble(id%KEEP(2))*dble(id%KEEP(2)) ! cb bloc C IKEEP(1:N,1) can be used as a work space since it is set C to its final state by the SORT_PERM subroutine below. SSARBR => IKEEPALLOC(IKEEP:IKEEP+int(NBLK-1,8)) C ====================================================== C Map nodes and assign candidates for dynamic scheduling C ====================================================== IF ((KEEP(13).NE.0).AND.(NBLK.NE.id%N)) THEN SIZEOFBLOCKS_PTR => SIZEOFBLOCKS(1:NBLK) LSIZEOFBLOCKS_PTR = NBLK ELSE SIZEOFBLOCKS_PTR => IDUMMY_ARRAY LSIZEOFBLOCKS_PTR = 1 IDUMMY_ARRAY(1) = -1 ENDIF CALL DMUMPS_DIST_AVOID_COPIES( & NBLK,id%NSLAVES,ICNTL(1), & INFOG(1), & IKEEPALLOC(NE), & NFSIZPTR(1), & FREREPTR(1), & FILS_TMP(1), & KEEP(1),KEEP8(1),PROCNODE(1), & SSARBR(1),id%NBSA,PEAK,IERR & , SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR & ) NULLIFY(SSARBR) if(IERR.eq.-999) then write(6,*) ' Internal error during static mapping ' INFO(1) = IERR GOTO 11 ENDIF IF(IERR.NE.0) THEN INFO(1) = -135 INFO(2) = IERR GOTO 11 ENDIF CALL DMUMPS_ANA_R(NBLK, FILS_TMP(1), & FREREPTR(1), IKEEPALLOC(NE), & IKEEPALLOC(NA)) ENDIF 11 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C The following part is done in parallel CALL MPI_BCAST( id%NELT, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KEEP(55) .EQ. 0) THEN C Assembled matrix format. Fill up the id%PTRAR array C Broadcast id%SYM_PERM needed to fill up id%PTRAR C postpone to after computation of id%SYM_PERM C computed after id%DAD_STEPS if (associated(id%FRTPTR)) DEALLOCATE(id%FRTPTR) if (associated(id%FRTELT)) DEALLOCATE(id%FRTELT) allocate( id%FRTPTR(1), id%FRTELT(1) ,STAT=allocok) IF (allocok .GT. 0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'FRTPTR,FRTELT' END IF INFO(1)= -7 INFO(2)= 2 END IF ELSE C Element Entry: C ------------------------------- C COMPUTE THE LIST OF ELEMENTS THAT WILL BE ASSEMBLED C AT EACH NODE OF THE ELIMINATION TREE. ALSO COMPUTE C FOR EACH ELEMENT THE TREE NODE TO WHICH IT IS ASSIGNED. C C FRTPTR is an INTEGER array of length N+1 which need not be set by C the user. On output, FRTPTR(I) points in FRTELT to first element C in the list of elements assigned to node I in the elimination tree. C C FRTELT is an INTEGER array of length NELT which need not be set by C the user. On output, positions FRTELT(FRTPTR(I)) to C FRTELT(FRTPTR(I+1)-1) contain the list of elements assigned to C node I in the elimination tree. C LPTRAR = id%NELT+id%NELT+2 CALL MUMPS_I8REALLOC(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%FRTPTR, id%N+1, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTPTR (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%ELTPROC, id%NELT, id%INFO, LP, & FORCE=.TRUE., STRING='id%ELTPROC (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%FRTELT, id%NELT, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTELT (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF(id%MYID .EQ. MASTER) THEN C In the elemental format case, PTRAR&friends are still C computed sequentially and then broadcasted CALL DMUMPS_FRTELT( & id%N, NELT, id%ELTPTR(NELT+1)-1, FREREPTR(1), & FILS_TMP(1), & IKEEPALLOC(NA), IKEEPALLOC(NE), XNODEL, & NODEL, id%FRTPTR(1), id%FRTELT(1), id%ELTPROC(1)) DO I=1, id%NELT+1 C PTRAR declared 64-bit id%PTRAR(id%NELT+I+1)=int(id%ELTPTR(I),8) ENDDO DEALLOCATE(XNODEL) DEALLOCATE(NODEL) END IF CALL MPI_BCAST( id%PTRAR(id%NELT+2), id%NELT+1, MPI_INTEGER8, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRTPTR(1), id%N+1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRTELT(1), id%NELT, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C We switch again to sequential computations on the master node IF(id%MYID .EQ. MASTER) THEN IF ( INFO( 1 ) .LT. 0 ) GOTO 12 IF ( KEEP(55) .ne. 0 ) THEN C --------------------------------------- C Build ELTPROC: correspondance between elements and slave ranks C in COMM_NODES with special values -1 (all procs) and -2 and -3 C (no procs). This is used later to distribute the elements on C the processes at the beginning of the factorisation phase C --------------------------------------- CALL DMUMPS_ELTPROC(NBLK, NELT, id%ELTPROC(1),id%NSLAVES, & PROCNODE(1), id%KEEP(1)) END IF NB_NIV2 = KEEP(56) IF ( NB_NIV2.GT.0 ) THEN C allocate(PAR2_NODES(NB_NIV2), & STAT=allocok) IF (allocok .GT.0) then INFO(1)= -7 INFO(2)= NB_NIV2 IF ( LPOK ) THEN WRITE(LP, 150) 'PAR2_NODES' END IF GOTO 12 END IF ENDIF IF ((NB_NIV2.GT.0) .AND. (KEEP(24).EQ.0)) THEN INIV2 = 0 DO 777 INODE = 1, NBLK IF ( ( FREREPTR(INODE) .NE. NBLK ) .AND. & ( MUMPS_TYPENODE(PROCNODE(INODE),id%KEEP(199)) & .eq. 2) ) THEN INIV2 = INIV2 + 1 PAR2_NODES(INIV2) = INODE END IF 777 CONTINUE IF ( INIV2 .NE. NB_NIV2 ) THEN WRITE(*,*) "Internal Error 2 in DMUMPS_ANA_DRIVER", & INIV2, NB_NIV2 CALL MUMPS_ABORT() ENDIF ENDIF IF ( (KEEP(24) .NE. 0) .AND. (NB_NIV2.GT.0) ) THEN C allocate array to store cadidates stategy C for each level two nodes IF ( associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES) allocate( id%CANDIDATES(id%NSLAVES+1,NB_NIV2), & stat=allocok) if (allocok .gt.0) then INFO(1)= -7 INFO(2)= NB_NIV2*(id%NSLAVES+1) IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 END IF CALL MUMPS_RETURN_CANDIDATES & (PAR2_NODES,id%CANDIDATES, & IERR) IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF C deallocation of variables of module mumps_static_mapping CALL MUMPS_END_ARCH_CV() IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF ELSE IF (associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES) allocate(id%CANDIDATES(1,1), stat=allocok) IF (allocok .NE. 0) THEN INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 ENDIF ENDIF C******************************************************************* C --------------- 12 CONTINUE C --------------- * * =============================== * End of analysis phase on master * =============================== * END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C C We now allocate and compute arrays in NSTEPS C on the master, as this makes more sense. C C Broadcast KEEP8(101) to be used in MUMPS_ANA_L0_OMP CALL MPI_BCAST( id%KEEP8(101), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) C C ============================== C PREPARE DATA FOR FACTORIZATION C ============================== C ------------------ CALL MPI_BCAST( id%KEEP(1), 110, MPI_INTEGER, MASTER, & id%COMM, IERR ) C We also need to broadcast KEEP8(21) CALL MPI_BCAST( id%KEEP8(21), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) C -------------------------------------------------- C Broadcast KEEP(205) which is outside the first 110 C KEEP entries but is needed for factorization. C -------------------------------------------------- CALL MPI_BCAST( id%KEEP(205), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C -------------- C Broadcast NBSA CALL MPI_BCAST( id%NBSA, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- C Global MAXFRT (computed in DMUMPS_ANA_M) C is needed on all the procs during DMUMPS_ANA_DISTM C to evaluate workspace for solve. C We could also recompute it in DMUMPS_ANA_DISTM IF (id%MYID==MASTER) KEEP(127)=INFOG(5) CALL MPI_BCAST( id%KEEP(127), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- C Global max panel size KEEP(226) CALL MPI_BCAST( id%KEEP(226), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- CALL MPI_BCAST( id%KEEP(464), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(471), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(475), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(482), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(487), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) C Number of leaves not belonging to L0 KEEP(262) C and KEEP(263) : inner or outer sends for blocked facto CALL MPI_BCAST( id%KEEP(262), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ---------------------------------------- C Allocate new workspace on all processors C ---------------------------------------- C STEP_TMP is of size NBLK because it C is computed on compressed graph and C broadcasted when needed. C It is then extended in id%STEP on master C and broadcasted on all procs ALLOCATE(STEP_TMP(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NBLK ENDIF IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%PROCNODE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%PROCNODE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%NE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%NE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%ND_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%ND_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%FRERE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%FRERE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%DAD_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%DAD_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 IF (KEEP(55) .EQ. 0) THEN LPTRAR = 2 CALL MUMPS_I8REALLOC(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 ENDIF IF (id%KEEP(494).NE.0) THEN C of size NBLK that will be extended and copies later C on master SIZELRGROUPS_TMP = NBLK ELSE C needed as argument for DMUMPS_EXPAND_TREE_STEPS SIZELRGROUPS_TMP = 1 ENDIF ALLOCATE(LRGROUPS_TMP(SIZELRGROUPS_TMP), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NBLK ENDIF C IF(INFO(1).LT.0) GOTO 94 C Copy data for factorization and/or solve. C ================================ C COMPUTE ON THE MASTER, BROADCAST C TO OTHER PROCESSES C ================================ IF ( id%MYID .NE. MASTER .OR. id%KEEP(23) .EQ. 0 ) THEN IF ( associated( id%UNS_PERM ) ) THEN DEALLOCATE(id%UNS_PERM) ENDIF ENDIF 94 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( id%MYID .EQ. MASTER ) THEN C NA -> compressed NA containing only list C of leaves of the elimination tree and list of roots C (the two useful informations for factorization/solve). IF (NBLK.eq.1) THEN NBROOT = 1 NBLEAF = 1 ELSE IF (IKEEPALLOC(NA+int(NBLK-1,8)) .LT.0) THEN NBLEAF= NBLK NBROOT= NBLK ELSE IF (IKEEPALLOC(NA+int(NBLK-2,8)) .LT.0) THEN NBLEAF = NBLK-1 NBROOT = IKEEPALLOC(NA+int(NBLK-1,8)) ELSE NBLEAF = IKEEPALLOC(NA+int(NBLK-2,8)) NBROOT = IKEEPALLOC(NA+int(NBLK-1,8)) ENDIF id%LNA = 2+NBLEAF+NBROOT ENDIF CALL MPI_BCAST( id%LNA, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MUMPS_REALLOC(id%NA, id%LNA, id%INFO, LP, FORCE=.TRUE., & STRING='id%NA (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF (id%MYID .EQ.MASTER ) THEN C{ The structure of NA is the following: C NA(1) is the number of leaves. C NA(2) is the number of roots. C NA(3:2+NA(1)) are the leaves. C NA(3+NA(1):2+NA(1)+NA(2)) are the roots. id%NA(1) = NBLEAF id%NA(2) = NBROOT C C Initialize NA with the leaves and roots LEAF = 3 IF ( NBLK == 1 ) THEN id%NA(LEAF) = 1 LEAF = LEAF + 1 ELSE IF (IKEEPALLOC(NA+int(NBLK-1,8)) < 0) THEN id%NA(LEAF) = - IKEEPALLOC(NA+int(NBLK-1,8))-1 LEAF = LEAF + 1 DO I = 1, NBLEAF - 1 id%NA(LEAF) = IKEEPALLOC(NA+int(I-1,8)) LEAF = LEAF + 1 ENDDO ELSE IF (IKEEPALLOC(NA+int(NBLK-2,8)) < 0 ) THEN INODE = - IKEEPALLOC(NA+int(NBLK-2,8)) - 1 id%NA(LEAF) = INODE LEAF =LEAF + 1 IF ( NBLEAF > 1 ) THEN DO I = 1, NBLEAF - 1 id%NA(LEAF) = IKEEPALLOC(NA+int(I-1,8)) LEAF = LEAF + 1 ENDDO ENDIF ELSE DO I = 1, NBLEAF id%NA(LEAF) = IKEEPALLOC(NA+int(I-1,8)) LEAF = LEAF + 1 ENDDO END IF C C Build array STEP_TMP(1:NBLK) to hold step numbers in C range 1..id%KEEP(28), allowing compression of C other arrays from id%N to id%KEEP(28) C (the number of nodes/steps in the assembly tree) ISTEP = 0 DO I = 1, NBLK IF ( FREREPTR(I) .ne. NBLK + 1 ) THEN C New node in the tree. c (Set step( inode_n ) = inode_nsteps for principal C variables and -inode_nsteps for internal variables C of the node) ISTEP = ISTEP + 1 STEP_TMP(I)=ISTEP INN = FILS_TMP(I) DO WHILE ( INN .GT. 0 ) STEP_TMP(INN) = - ISTEP INN = FILS_TMP(INN) END DO IF (FREREPTR(I) .eq. 0) THEN C Keep root nodes list in NA id%NA(LEAF) = I LEAF = LEAF + 1 ENDIF ENDIF END DO IF ( LEAF - 1 .NE. 2+NBROOT + NBLEAF ) THEN WRITE(*,*) 'Internal error 2 in DMUMPS_ANA_DRIVER' CALL MUMPS_ABORT() ENDIF IF ( ISTEP .NE. id%KEEP(28) ) THEN write(*,*) 'Internal error 3 in DMUMPS_ANA_DRIVER', & ISTEP, id%KEEP(28) CALL MUMPS_ABORT() ENDIF C ============ C SET PROCNODE, FRERE, NE C ============ C copies to NSTEP array should be ok DO I = 1, NBLK IF (FREREPTR(I) .NE. NBLK+1) THEN id%PROCNODE_STEPS(STEP_TMP(I)) = PROCNODE( I ) id%FRERE_STEPS(STEP_TMP(I)) = FREREPTR(I) id%NE_STEPS(STEP_TMP(I)) = IKEEPALLOC(NE+int(I-1,8)) id%ND_STEPS(STEP_TMP(I)) = NFSIZPTR(I) ENDIF ENDDO C =============================== C Algorithm to compute array DAD_STEPS: C ---- C For each node set dad for all of its sons C plus, for root nodes set dad to zero. C C =============================== DO I = 1, NBLK C -- skip non principal nodes IF ( STEP_TMP(I) .LE. 0) CYCLE C -- (I) is a principal node IF (FREREPTR(I) .eq. 0) THEN C -- I is a root node and has no father id%DAD_STEPS(STEP_TMP(I)) = 0 ENDIF C -- Find first son node (IFS) IFS = FILS_TMP(I) DO WHILE ( IFS .GT. 0 ) IFS= FILS_TMP(IFS) END DO C -- IFS > 0 if I is not a leave node C -- Go through list of brothers of IFS if any IFS = -IFS DO WHILE (IFS.GT.0) C -- I is not a leave node and has a son node IFS id%DAD_STEPS(STEP_TMP(IFS)) = I IFS = FREREPTR(IFS) ENDDO END DO C C C Following arrays (PROCNODE and IKEEPALLOC) not used anymore C during analysis IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (associated(FREREPTR)) DEALLOCATE(FREREPTR) NULLIFY(FREREPTR) IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR) NULLIFY(NFSIZPTR) ENDIF IF (KEEP(494).NE.0) THEN C{ IF (id%MYID.EQ.MASTER) THEN IF (PROKG) THEN CALL MUMPS_SECDEB(TIMEG) END IF ENDIF C ======================================================= C Compute a grouping of variables for LR approximations. C Grouping may be performed on a distributed matrix C ======================================================= C C ======================================= C I/ Prepare data before call to grouping C ======================================= LUMAT_REMAP_DIST_AVAIL = .FALSE. LUMAT_REMAP_CENT_AVAIL = .FALSE. C IF (LUMAT_AVAIL) THEN C Use clean symmetrized LUMAT matrix available ALLOCATE(MAPCOL(id%KEEP(28)), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C CALL MUMPS_INIALIZE_REDIST_LUMAT ( & id%INFO, id%ICNTL, id%KEEP, id%COMM, id%MYID, NBLK, & id%NPROCS, & LUMAT, id%PROCNODE_STEPS(1), id%KEEP(28), MAPCOL, & LUMAT_REMAP, NBRECORDS, STEP_TMP(1)) C INFO(1) has been broadcasted already in routine IF ( id%INFO(1).LT.0 ) GOTO 500 C C -- Redistribute LUMAT into LU_REMAP relying on procnode CALL MUMPS_AB_DIST_LMAT_TO_LUMAT ( & .FALSE., ! do not UNFOLD & .TRUE., ! MAPCOL in NSTEPS=> STEP array needed & id%INFO, id%ICNTL, id%COMM, id%MYID, NBLK, id%NPROCS, & LUMAT, MAPCOL, id%KEEP(28), STEP_TMP(1), NBLK, & LUMAT_REMAP, NBRECORDS, NSEND8, NLOCAL8 & ) LUMAT_REMAP_DIST_AVAIL = .TRUE. CALL MUMPS_AB_FREE_LMAT(LUMAT,KEEP(147)) C Distribute SIZEOFBLOCKS that was defined only on master CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, & id%COMM, IERR ) C} ELSE IF ( LMAT_BLOCK_AVAIL ) THEN C{ Centralized matrix and clean LMAT_BLOCK available C IF (id%MYID.EQ.MASTER) THEN C CALL MUMPS_AB_CLEANLMAT_TO_LUMAT ( & LMAT_BLOCK, LUMAT_REMAP, KEEP(147), & INFO(1), ICNTL(1)) LUMAT_REMAP_CENT_AVAIL=.TRUE. C --- LMAT_BLOCK not needed anymore CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK,KEEP(147)) C ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C} ELSE IF ((KEEP(54).EQ.3).AND.(KEEP(13).EQ.0) & .AND. KEEP(487).EQ.1) THEN C{ C Matrix is distributed on entry and compression not requested C (this will be the case when ICNTL(15).EQ.0 and C // analysis, or Schur, etc...) C note that with distributed matrix and centralized ordering C compression is forced to limit memory peak) C Free centralized matrix before grouping to C limit memory peak IF (GATHER_MATRIX_ALLOCATED) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF GATHER_MATRIX_ALLOCATED= .FALSE. ENDIF IF (.NOT. I_AM_SLAVE .OR. ! non-working master & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc ENDIF ALLOCATE(MAPCOL(id%KEEP(28)), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C C Build MAPCOL and LUMAT_REMAP mapped according C to MAPCOL (outputs available on all MPI procs). CALL MUMPS_AB_DCOORD_TO_DTREE_LUMAT ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & id%PROCNODE_STEPS(1), id%KEEP(28), STEP_TMP(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & MAPCOL, LUMAT_REMAP ) LUMAT_REMAP_DIST_AVAIL = .TRUE. IF (INFO(1).GE.0) THEN C SIZEOFBLOCKS needed on all procs during MPI grouping ALLOCATE(SIZEOFBLOCKS(NBLK), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= NBLK ENDIF DO I=1, NBLK SIZEOFBLOCKS(I) = 1 ENDDO ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C} ELSE IF ((KEEP(54).EQ.3) .AND. (KEEP(487).NE.1) & ) THEN C{ C Grouping preparation on slaves: C If the input matrix is distributed C the graph is centralized to compute the C clustering. C CALL DMUMPS_GATHER_MATRIX(id) GATHER_MATRIX_ALLOCATED = .TRUE. C} ENDIF C ============ C ============ C II/ GROUPING C ============ IF (LUMAT_REMAP_DIST_AVAIL) THEN C{ Distributed memory based grouping is used IF (id%MYID.NE.MASTER) THEN ALLOCATE(FILS_TMP(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NBLK ENDIF ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL MPI_BCAST( id%ND_STEPS(1), KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL DMUMPS_AB_LR_MPI_GROUPING(NBLK, & MAPCOL, id%KEEP(28), & id%KEEP(28), LUMAT_REMAP, FILS_TMP(1), & id%FRERE_STEPS, & id%DAD_STEPS, STEP_TMP(1), id%NA, & id%LNA, LRGROUPS_TMP(1), SIZEOFBLOCKS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), id%KEEP(142), & LPOK, LP, id%COMM, id%MYID, id%NPROCS, & id%KEEP(1), id%ND_STEPS) IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) IF (id%MYID.NE.MASTER) DEALLOCATE(FILS_TMP) C} ELSE IF (id%MYID.EQ.MASTER) THEN C{ IF (LUMAT_REMAP_CENT_AVAIL) THEN C{ C IDUMMY_ARRAY(1) = -1 CALL DMUMPS_AB_LR_MPI_GROUPING(NBLK, & IDUMMY_ARRAY, 1, & id%KEEP(28), LUMAT_REMAP, FILS_TMP, & id%FRERE_STEPS, & id%DAD_STEPS, STEP_TMP, id%NA, & id%LNA, LRGROUPS_TMP, SIZEOFBLOCKS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), id%KEEP(142), & LPOK, LP, id%COMM, id%MYID, id%NPROCS, & id%KEEP(1), id%ND_STEPS) C} ELSE C{ grouping based on centralized matrix IF (KEEP(469).EQ.0) THEN CALL DMUMPS_LR_GROUPING(id%N, id%KEEP8(28), id%KEEP(28), & id%IRN, & id%JCN, FILS_TMP, id%FRERE_STEPS, & id%DAD_STEPS, id%NE_STEPS, STEP_TMP, id%NA, & id%LNA, LRGROUPS_TMP, & id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(10), & id%KEEP(54), id%KEEP(142), & LPOK, LP, GATHER_MATRIX_ALLOCATED, & id%KEEP(1), id%ND_STEPS) ELSE CALL DMUMPS_LR_GROUPING_NEW(id%N, id%KEEP8(28), & id%KEEP(28), id%IRN, & id%JCN, FILS_TMP, id%FRERE_STEPS, & id%DAD_STEPS, STEP_TMP, id%NA, & id%LNA, LRGROUPS_TMP, id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), id%KEEP(142), & LPOK, LP, GATHER_MATRIX_ALLOCATED, & id%KEEP(1), id%ND_STEPS) ENDIF C} ENDIF C} ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C update KEEP(142): maximum group size CALL MPI_BCAST( KEEP(142), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ============ C III/ CLEANUP C ============ C Free LUMAT_REMAP if allocated IF (LUMAT_REMAP_DIST_AVAIL.OR.LUMAT_REMAP_CENT_AVAIL) & CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP,KEEP(147)) IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF ( (KEEP(54).EQ.3) .AND. (KEEP(244).EQ.2).AND. & (KEEP(487).NE.1) ) THEN C Cleanup the irn and jcn arrays filled up by the C cmumps_gather_matrix above. It might have been done C during grouping IF (GATHER_MATRIX_ALLOCATED) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF GATHER_MATRIX_ALLOCATED= .FALSE. ENDIF END IF IF (PROKG) THEN CALL MUMPS_SECFIN(TIMEG) WRITE(MPG,145) TIMEG END IF C} Grouping: KEEP(494) .NE. 0 ENDIF C ALLOCATE id%FILS(id%N)on all procs possibly using mpi3 CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 C C ALLOCATE id%STEP(id%N)on all procs possibly using mpi3 CALL MUMPS_REALLOC(id%STEP, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 C C ALLOCATE id%LRGROUPS on all procs possibly using mpi3 C compute size of id%LRGROUPS in KEEP(280) IF (id%KEEP(494).EQ.0) THEN C not used id%KEEP(280) = 1 ELSE id%KEEP(280) = id%N ENDIF CALL MUMPS_REALLOC(id%LRGROUPS, id%KEEP(280), id%INFO, LP, & FORCE=.TRUE., & STRING='id%LRGROUPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 IF (id%MYID.EQ.MASTER) THEN C{ IF (KEEP(13).NE.0) THEN C{ =========== C Expand tree C =========== C Current tree is relative to the analysis by block. C Expand the tree on the master if compression is effective C (in all cases, grouping done or not) IF (NBLK.LT.id%N.OR.(.NOT.BLKVAR_ALLOCATED)) THEN C { C even if NBLK.EQ.N BLKVAR provided by user might hold C a permutation of the variables and this expand_tree_steps C should also be called C Expand FILS_TMP, STEP_TMP into id%FILS, id%STEP C and update arrays of size NSTEPS IF (NB_NIV2.EQ.0) THEN IDUMMY_ARRAY(1) = -9999 PAR2_NODESPTR => IDUMMY_ARRAY(1:1) SIZE_PAR2_NODESPTR=1 ELSE PAR2_NODESPTR => PAR2_NODES(1:NB_NIV2) SIZE_PAR2_NODESPTR=NB_NIV2 ENDIF CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 CALL DMUMPS_EXPAND_TREE_STEPS (id%ICNTL, & id%N, NBLK, BLKPTR_PTRLOC(1), BLKVAR_PTRLOC(1), & FILS_TMP(1), id%FILS(1), id%KEEP(28), & STEP_TMP(1), id%STEP(1), & PAR2_NODESPTR(1), SIZE_PAR2_NODESPTR, & id%DAD_STEPS(1), id%FRERE_STEPS(1), & id%NA(1), id%LNA, & LRGROUPS_TMP(1), SIZELRGROUPS_TMP, & id%LRGROUPS(1), KEEP(280), & id%KEEP(20), id%KEEP(38), KEEP(494) & ) NULLIFY(PAR2_NODESPTR) C C } ELSE C{ NBLK=N C perform local copies DO I=1, NBLK id%STEP(I) = STEP_TMP(I) id%FILS(I) = FILS_TMP(I) ENDDO IF (id%KEEP(494).NE.0) THEN DO I=1, id%KEEP(280) id%LRGROUPS(I) = LRGROUPS_TMP(I) ENDDO ENDIF C} ENDIF C} ELSE C{ NBLK=N C perform local copies DO I=1, NBLK id%STEP(I) = STEP_TMP(I) id%FILS(I) = FILS_TMP(I) ENDDO IF (id%KEEP(494).NE.0) THEN C we copy only in case of BLR since C LRGROUPS_TMP is otherwise allocated C and not used/initialized DO I=1, id%KEEP(280) id%LRGROUPS(I) = LRGROUPS_TMP(I) ENDDO ENDIF C} ENDIF C C ------------------------------------------- C Adjust LR_GROUPING to bound size of groups C and update KEEP(142): maximum group size C that should then be broadcasted again C ------------------------------------------- IF (id%N.GT.NBLK.AND.KEEP(494).NE.0) THEN CALL MUMPS_ADJUST_SIZE_LRGROUPS ( & id%STEP(1), id%FILS(1), id%N, & id%ND_STEPS(1), id%KEEP(28), id%KEEP(1), & id%LRGROUPS(1), INFO(1), INFO(2)) ENDIF C} ENDIF C update KEEP(142): maximum group size that might have been C updated in MUMPS_ADJUST_SIZE_LRGROUPS CALL MPI_BCAST( KEEP(142), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C 97 CONTINUE C IF (allocated(STEP_TMP)) DEALLOCATE(STEP_TMP) IF (allocated(LRGROUPS_TMP)) DEALLOCATE(LRGROUPS_TMP) IF (allocated(FILS_TMP)) DEALLOCATE(FILS_TMP) C C CALL MUMPS_REALLOC(id%SYM_PERM, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF (id%MYID.EQ.MASTER) THEN C ================================================================= C Reorder the tree using a variant of Liu's algorithm. Note that C REORDER_TREE MUST always be called since it sorts NA (the list of C leaves) in a valid order in the sense of a depth-first traversal. C ================================================================= CALL DMUMPS_REORDER_TREE(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%KEEP(70), & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(215), & id%KEEP(234), id%KEEP(55), id%KEEP(199), & id%PROCNODE_STEPS(1),id%NSLAVES,PEAK,id%KEEP(90) & ) IF(id%KEEP(261).EQ.1)THEN CALL MUMPS_SORT_STEP(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%INFO(1), & id%ICNTL(1),id%PROCNODE_STEPS(1),id%NSLAVES & ) ENDIF C Compute and export some global information on the tree needed by C dynamic schedulers during the factorization. The type of C information depends on the selected strategy. IF ((id%KEEP(76).GE.4).OR.(id%KEEP(76).GE.6).OR. & (id%KEEP(47).EQ.4).OR.((id%KEEP(81).GT.0) & .AND.(id%KEEP(47).GE.2)))THEN IS_BUILD_LOAD_MEM_CALLED=.TRUE. IF ((id%KEEP(47) .EQ. 4).OR. & (( id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN IF(id%NSLAVES.GT.1) THEN C NBSA is the total number of subtrees and C is an upperbound of the local number of C subtrees SIZE_TEMP_MEM = id%NBSA ELSE C Only one processor, NA(2) is the number of leaves SIZE_TEMP_MEM = id%NA(2) ENDIF ELSE SIZE_TEMP_MEM = 1 ENDIF IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN SIZE_DEPTH_FIRST=id%KEEP(28) ELSE SIZE_DEPTH_FIRST=1 ENDIF allocate(TEMP_MEM(SIZE_TEMP_MEM,id%NSLAVES),STAT=allocok) IF (allocok .NE.0) THEN INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_MEM' END IF GOTO 80 !! FIXME propagate error END IF allocate(TEMP_LEAF(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_LEAF' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 !! FIXME propagate error end if allocate(TEMP_SIZE(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_SIZE' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 end if allocate(TEMP_ROOT(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_ROOT' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 end if allocate(DEPTH_FIRST(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'DEPTH_FIRST' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if ALLOCATE(DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'DEPTH_FIRST_SEQ' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if ALLOCATE(SBTR_ID(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'SBTR_ID' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if IF(id%KEEP(76).EQ.5)THEN C We reuse the same variable as before SIZE_COST_TRAV=id%KEEP(28) ELSE SIZE_COST_TRAV=1 ENDIF allocate(COST_TRAV_TMP(SIZE_COST_TRAV),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'COST_TRAV_TMP' END IF INFO(1)= -7 INFO(2)= SIZE_COST_TRAV GOTO 80 END IF IF(id%KEEP(76).EQ.5)THEN IF(id%KEEP(70).EQ.0)THEN id%KEEP(70)=5 ENDIF IF(id%KEEP(70).EQ.1)THEN id%KEEP(70)=6 ENDIF ENDIF IF(id%KEEP(76).EQ.4)THEN IF(id%KEEP(70).EQ.0)THEN id%KEEP(70)=3 ENDIF IF(id%KEEP(70).EQ.1)THEN id%KEEP(70)=4 ENDIF ENDIF CALL DMUMPS_BUILD_LOAD_MEM_INFO(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%KEEP(70), & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(47), & id%KEEP(81),id%KEEP(76),id%KEEP(215), & id%KEEP(234), id%KEEP(55), id%KEEP(199), & id%PROCNODE_STEPS(1),TEMP_MEM,id%NSLAVES, & SIZE_TEMP_MEM, PEAK,id%KEEP(90),SIZE_DEPTH_FIRST, & SIZE_COST_TRAV,DEPTH_FIRST(1),DEPTH_FIRST_SEQ(1), & COST_TRAV_TMP(1), & TEMP_LEAF,TEMP_SIZE,TEMP_ROOT,SBTR_ID(1) & ) END IF ENDIF IF (id%MYID.EQ.MASTER) THEN CALL DMUMPS_SORT_PERM(id%N, id%NA(1), id%LNA, & id%NE_STEPS(1), id%SYM_PERM(1), & id%FILS(1), id%DAD_STEPS(1), & id%STEP(1), id%KEEP(28), & id%KEEP(60), id%KEEP(20), id%KEEP(38), & id%INFO(1) ) ENDIF C Root principal variable C for scalapack (KEEP(38)) or special serial root (KEEP(20)) C might have been updated C since root variables might have been permuted C and/or expanded (MUMPS_EXPAND_TREE) in case of compressed graph C It should thus be redistributed to all procs IF ( KEEP(494).NE.0 .OR. KEEP(13).NE.0 ) THEN C Value of KEEP(20) and KEEP(38) on master is always correct C + non-zero status is identical on all procs since 110 first C KEEP entries have been broadcasted IF (KEEP(38) .NE. 0) THEN CALL MPI_BCAST( id%KEEP(38), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF IF (KEEP(20) .NE. 0) THEN CALL MPI_BCAST( id%KEEP(20), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF ENDIF 80 CONTINUE C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C --------------------------------------------------- C Broadcast information computed on the master to C the slaves. C The matrix itself with numerical values and C integer data for the arrowhead/element description C will be received at the beginning of FACTO. C --------------------------------------------------- CALL MPI_BCAST( id%NA(1), id%LNA, 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%FILS(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%SYM_PERM(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%STEP(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF(KEEP(494).NE.0) THEN CALL MPI_BCAST( id%LRGROUPS(1), id%KEEP(280), MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF C C Store size of the stack memory for each C of the sequential subtree. IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN IF(associated(id%DEPTH_FIRST)) THEN DEALLOCATE(id%DEPTH_FIRST) ENDIF allocate(id%DEPTH_FIRST(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST' END IF GOTO 87 END IF IF(associated(id%DEPTH_FIRST_SEQ)) THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) ENDIF ALLOCATE(id%DEPTH_FIRST_SEQ(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(associated(id%SBTR_ID)) THEN DEALLOCATE(id%SBTR_ID) ENDIF ALLOCATE(id%SBTR_ID(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(id%MYID.EQ.MASTER)THEN id%DEPTH_FIRST(1:id%KEEP(28))=DEPTH_FIRST(1:id%KEEP(28)) id%DEPTH_FIRST_SEQ(1:id%KEEP(28))= & DEPTH_FIRST_SEQ(1:id%KEEP(28)) id%SBTR_ID(1:KEEP(28))=SBTR_ID(1:KEEP(28)) ENDIF CALL MPI_BCAST( id%DEPTH_FIRST(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%DEPTH_FIRST_SEQ(1), id%KEEP(28), & MPI_INTEGER,MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%SBTR_ID(1), id%KEEP(28), & MPI_INTEGER,MASTER, id%COMM, IERR ) ELSE IF(associated(id%DEPTH_FIRST)) THEN DEALLOCATE(id%DEPTH_FIRST) ENDIF allocate(id%DEPTH_FIRST(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST' END IF GOTO 87 END IF IF(associated(id%DEPTH_FIRST_SEQ)) THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) ENDIF ALLOCATE(id%DEPTH_FIRST_SEQ(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(associated(id%SBTR_ID)) THEN DEALLOCATE(id%SBTR_ID) ENDIF ALLOCATE(id%SBTR_ID(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF id%SBTR_ID(1)=0 id%DEPTH_FIRST(1)=0 id%DEPTH_FIRST_SEQ(1)=0 ENDIF IF(id%KEEP(76).EQ.5)THEN IF(associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) ENDIF allocate(id%COST_TRAV(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%COST_TRAV' END IF INFO(1)= -7 INFO(2)= id%KEEP(28) GOTO 87 END IF IF(id%MYID.EQ.MASTER)THEN id%COST_TRAV(1:id%KEEP(28))= & dble(COST_TRAV_TMP(1:id%KEEP(28))) ENDIF CALL MPI_BCAST( id%COST_TRAV(1), id%KEEP(28), & MPI_DOUBLE_PRECISION,MASTER, id%COMM, IERR ) ELSE IF(associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) ENDIF allocate(id%COST_TRAV(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%COST_TRAV(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF id%COST_TRAV(1)=0.0d0 ENDIF IF (id%KEEP(47) .EQ. 4 .OR. & ((id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN IF(id%MYID .EQ. MASTER)THEN DO K=1,id%NSLAVES DO J=1,SIZE_TEMP_MEM IF(TEMP_MEM(J,K) < 0.0D0) GOTO 666 ENDDO 666 CONTINUE J=J-1 IF (id%KEEP(46) == 1) THEN IDEST = K - 1 ELSE IDEST = K ENDIF IF (IDEST .NE. MASTER) THEN CALL MPI_SEND(J,1,MPI_INTEGER,IDEST,0, & id%COMM,IERR) CALL MPI_SEND(TEMP_MEM(1,K),J,MPI_DOUBLE_PRECISION, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_LEAF(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_SIZE(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_ROOT(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) ELSE IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%NBSA_LOCAL = J id%MEM_SUBTREE(1:J)=TEMP_MEM(1:J,1) IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_ROOT_SBTR(1:J)=TEMP_ROOT(1:J,1) IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_FIRST_LEAF' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_FIRST_LEAF(1:J)=TEMP_LEAF(1:J,1) IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_NB_LEAF' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_NB_LEAF(1:J)=TEMP_SIZE(1:J,1) ENDIF ENDDO ELSE CALL MPI_RECV(id%NBSA_LOCAL,1,MPI_INTEGER, & MASTER,0,id%COMM,STATUS, IERR) IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'MY_FIRST_LEAF' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'MY_NB_LEAF' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF CALL MPI_RECV(id%MEM_SUBTREE(1),id%NBSA_LOCAL, & MPI_DOUBLE_PRECISION,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_FIRST_LEAF(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_NB_LEAF(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_ROOT_SBTR(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) ENDIF ELSE id%NBSA_LOCAL = -999999 IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_FIRST_LEAF(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_NB_LEAF(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF ENDIF IF(id%MYID.EQ.MASTER)THEN IF(IS_BUILD_LOAD_MEM_CALLED)THEN DEALLOCATE(TEMP_MEM) DEALLOCATE(TEMP_SIZE) DEALLOCATE(TEMP_ROOT) DEALLOCATE(TEMP_LEAF) DEALLOCATE(COST_TRAV_TMP) DEALLOCATE(DEPTH_FIRST) DEALLOCATE(DEPTH_FIRST_SEQ) DEALLOCATE(SBTR_ID) ENDIF ENDIF 87 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C NB_NIV2 = KEEP(56) ! KEEP(1:110) was broadcast earlier C NB_NIV2 is now available on all processors. IF ( NB_NIV2.GT.0 ) THEN C Allocate arrays on slaves if (id%MYID.ne.MASTER) then IF (associated(id%CANDIDATES)) THEN DEALLOCATE(id%CANDIDATES) ENDIF allocate(PAR2_NODES(NB_NIV2), & id%CANDIDATES(id%NSLAVES+1,NB_NIV2), & STAT=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= NB_NIV2*(id%NSLAVES+1) IF ( LPOK ) THEN WRITE(LP, 150) 'PAR2_NODES/id%CANDIDATES' END IF end if end if CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL MPI_BCAST(PAR2_NODES(1),NB_NIV2, & MPI_INTEGER, MASTER, id%COMM, IERR ) IF (KEEP(24) .NE.0 ) THEN CALL MPI_BCAST(id%CANDIDATES(1,1), & (NB_NIV2*(id%NSLAVES+1)), & MPI_INTEGER, MASTER, id%COMM, IERR ) ENDIF ENDIF IF ( associated(id%ISTEP_TO_INIV2)) THEN DEALLOCATE(id%ISTEP_TO_INIV2) NULLIFY(id%ISTEP_TO_INIV2) ENDIF IF ( associated(id%I_AM_CAND)) THEN DEALLOCATE(id%I_AM_CAND) NULLIFY(id%I_AM_CAND) ENDIF IF (NB_NIV2.EQ.0) THEN C allocate dummy arrays C ISTEP_TO_INIV2 will never be used C Add a parameter SIZE_ISTEP_TO_INIV2 and make C it always available in a keep(71) id%KEEP(71) = 1 ELSE id%KEEP(71) = id%KEEP(28) ENDIF allocate(id%ISTEP_TO_INIV2(id%KEEP(71)), & id%I_AM_CAND(max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'id%ISTEP_TO_INIV2' WRITE(LP, 150) 'id%TAB_POS_IN_PERE' END IF INFO(1)= -7 IF (NB_NIV2.EQ.0) THEN INFO(2)= 2 ELSE INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2) END IF GOTO 321 ENDIF IF ( NB_NIV2 .GT.0 ) THEN C If BLR grouping was performed then PAR2_NODES(INIV2) C might then point to a non principal variable C for which STEP might be negative C id%ISTEP_TO_INIV2 = -9999 DO INIV2 = 1, NB_NIV2 INN = PAR2_NODES(INIV2) id%ISTEP_TO_INIV2(abs(id%STEP(INN))) = INIV2 END DO CALL DMUMPS_BUILD_I_AM_CAND( id%NSLAVES, KEEP(79), & NB_NIV2, id%MYID_NODES, & id%CANDIDATES(1,1), id%I_AM_CAND(1) ) ENDIF IF ( I_AM_SLAVE ) THEN IF (associated(id%FUTURE_NIV2)) THEN DEALLOCATE(id%FUTURE_NIV2) NULLIFY(id%FUTURE_NIV2) ENDIF allocate(id%FUTURE_NIV2(id%NSLAVES), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'FUTURE_NIV2' END IF INFO(1)= -7 INFO(2)= id%NSLAVES GOTO 321 ENDIF id%FUTURE_NIV2=0 DO INIV2 = 1, NB_NIV2 IDEST = MUMPS_PROCNODE( & id%PROCNODE_STEPS(abs(id%STEP(PAR2_NODES(INIV2)))), & id%KEEP(199)) id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1 ENDDO C Allocate id%TAB_POS_IN_PERE, C TAB_POS_IN_PERE is an array of size (id%NSLAVES+2,NB_NIV2) C where NB_NIV2 is the number of type 2 nodes in the tree. IF ( associated(id%TAB_POS_IN_PERE)) THEN DEALLOCATE(id%TAB_POS_IN_PERE) NULLIFY(id%TAB_POS_IN_PERE) ENDIF allocate(id%TAB_POS_IN_PERE(id%NSLAVES+2,max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'id%ISTEP_TO_INIV2' WRITE(LP, 150) 'id%TAB_POS_IN_PERE' END IF INFO(1)= -7 IF (NB_NIV2.EQ.0) THEN INFO(2)= 2 ELSE INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2) END IF GOTO 321 ENDIF END IF C deallocate PAR2_NODES that was computed C on master and broadcasted on all slaves IF (NB_NIV2.GT.0) DEALLOCATE (PAR2_NODES) 321 CONTINUE C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C IF ( KEEP(38) .NE. 0 ) THEN C ------------------------- C Initialize root structure C ------------------------- CALL DMUMPS_INIT_ROOT_ANA( id%MYID, & id%NSLAVES, id%N, idintr%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 idintr%root%yes = .FALSE. END IF IF ( KEEP(38) .NE. 0 .and. I_AM_SLAVE ) THEN C ----------------------------------------------- C Check if at least one processor belongs to the C root. In the case where all of them have MYROW C equal to -1, this could be a problem due to the C BLACS. (mpxlf90_r and IBM BLACS). C ----------------------------------------------- CALL MPI_ALLREDUCE(idintr%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 ( idintr%root%MYROW .LT. -1 .OR. & idintr%root%MYCOL .LT. -1 ) THEN INFO(1) = -25 INFO(2) = 0 END IF IF ( LPOK .AND. INFO(1) == -25 ) THEN WRITE(LP, '(A)') & 'Problem with your version of the BLACS.' WRITE(LP, '(A)') 'Try using a BLACS version from netlib.' ENDIF END IF C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C C C CALL DMUMPS_ANA_ARROWHEADS_WRAPPER ( id, & GATHER_MATRIX_ALLOCATED ) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL DMUMPS_ANA_COMPUTE_ESTIMATES (id,idintr) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C ------------------------- C Define a specific mapping C for the user C ------------------------- IF ( id%MYID. eq. MASTER .AND. KEEP(54) .eq. 1 ) THEN IF (associated( id%MAPPING)) THEN DEALLOCATE( id%MAPPING) ENDIF allocate( id%MAPPING(id%KEEP8(28)), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28), INFO(2)) IF ( LPOK ) THEN WRITE(LP, 150) 'id%MAPPING' END IF GOTO 92 END IF allocate(IWtemp( id%N ), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-7 INFO(2)=id%N IF ( LPOK ) THEN WRITE(LP, 150) 'IWtemp(N)' END IF GOTO 92 END IF IF ( id%KEEP8(28) .EQ. 0_8 ) THEN IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY ELSE IRN_PTR => id%IRN JCN_PTR => id%JCN ENDIF CALL DMUMPS_BUILD_MAPPING( & id%N, id%MAPPING(1), id%KEEP8(28), & IRN_PTR(1),JCN_PTR(1), id%PROCNODE_STEPS(1), & id%STEP(1), & id%NSLAVES, id%SYM_PERM(1), & id%FILS(1), IWtemp, id%KEEP(1),id%KEEP8(1), & idintr%root%MBLOCK, idintr%root%NBLOCK, & idintr%root%NPROW, idintr%root%NPCOL ) DEALLOCATE( IWtemp ) 92 CONTINUE END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C 500 CONTINUE C Deallocate allocated working space IF (allocated(FILS_TMP)) DEALLOCATE(FILS_TMP) IF (allocated(STEP_TMP)) DEALLOCATE(STEP_TMP) IF (allocated(LRGROUPS_TMP)) DEALLOCATE(LRGROUPS_TMP) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (allocated(WORK2ALLOC)) DEALLOCATE(WORK2ALLOC) IF (KEEP(244).NE.1) THEN IF (allocated(PARAORD_to_idCOMM)) & DEALLOCATE(PARAORD_to_idCOMM) IF (COMM_PARAORD_ALLOCATED) THEN IF (COMM_PARAORD.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_FREE( COMM_PARAORD, IERR ) COMM_PARAORD_ALLOCATED = .FALSE. ENDIF ENDIF IF (COMM_PARASYMB_ALLOCATED) THEN IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_FREE( COMM_PARASYMB, IERR ) COMM_PARASYMB_ALLOCATED = .FALSE. ENDIF ENDIF ENDIF IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE) IF (allocated(XNODEL)) DEALLOCATE(XNODEL) IF (allocated(NODEL)) DEALLOCATE(NODEL) IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK,KEEP(147)) CALL MUMPS_AB_FREE_LMAT(LUMAT,KEEP(147)) CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP,KEEP(147)) CALL MUMPS_AB_FREE_GCOMP(GCOMP, MEMCNT) CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST, MEMCNT) C Standard deallocations (error or not) IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR) IF (associated(FREREPTR)) DEALLOCATE(FREREPTR) nullify(FREREPTR, NFSIZPTR) IF (associated(BLKPTR_PTRLOC).AND.BLKPTR_ALLOCATED) THEN DEALLOCATE(BLKPTR_PTRLOC) nullify(BLKPTR_PTRLOC) ENDIF IF (associated(BLKVAR_PTRLOC).AND.BLKVAR_ALLOCATED) THEN DEALLOCATE(BLKVAR_PTRLOC) nullify(BLKVAR_PTRLOC) ENDIF KEEP8(26)=max(1_8,KEEP8(26)) KEEP8(27)=max(1_8,KEEP8(27)) RETURN 110 FORMAT(/' ****** ANALYSIS STEP ********'/) 145 FORMAT(' ELAPSED TIME SPENT IN BLR CLUSTERING =',F12.4) 150 FORMAT( & /' ** FAILURE DURING DMUMPS_ANA_DRIVER, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE DMUMPS_ANA_DRIVER SUBROUTINE DMUMPS_ANA_CHECK_KEEP(id, I_AM_SLAVE) !$ USE OMP_LIB, ONLY : omp_get_max_threads C C Purpose C ======= C This subroutine decodes the control parameters, C stores them in the KEEP array, and performs a C consistency check on the KEEP array. USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id LOGICAL :: I_AM_SLAVE C internal variables INTEGER :: LP, MP, MPG, I INTEGER :: MASTER LOGICAL :: PROK, PROKG, LPOK PARAMETER( MASTER = 0 ) C LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) C Re-intialize few KEEPs entries corresponding C to stat that are incremented such C the number of split nodes: id%KEEP(61)=0 IF (id%MYID.eq.MASTER) THEN id%KEEP(38) = 0 id%KEEP(20) = 0 CALL DMUMPS_ANA_CHECK_ICNTL48 ( id ) id%KEEP(256) = id%ICNTL(7) ! copy ordering option id%KEEP(252) = id%ICNTL(32) IF (id%KEEP(252) < 0 .OR. id%KEEP(252) > 1 ) THEN id%KEEP(252) = 0 ENDIF C Which factors to store id%KEEP(251) = id%ICNTL(31) IF (id%KEEP(251) < 0 .OR. id%KEEP(251) > 2 ) THEN id%KEEP(251)=0 ENDIF C For unsymmetric matrices, if forward solve C performed during facto, C no reason to store L factors at all. Reset C KEEP(251) accordingly... except if the user C tells that no solve is needed. IF (id%KEEP(50) .EQ. 0 .AND. id%KEEP(252).EQ.1) THEN IF (id%KEEP(251) .NE. 1) id%KEEP(251) = 2 ENDIF C Symmetric case, even if no backward needed, C store all factors IF (id%KEEP(50) .NE.0 .AND. id%KEEP(251) .EQ. 2) THEN id%KEEP(251) = 0 ENDIF C Case of solve not needed: IF (id%KEEP(251) .EQ. 1) THEN id%KEEP(201) = -1 C In that case, id%ICNTL(22) will C be ignored in future phases ELSE C Reset id%KEEP(201) -- typically for the case C of a previous analysis with KEEP(201)=-1 id%KEEP(201) = 0 ENDIF IF (id%KEEP(252).EQ.1) THEN id%KEEP(253) = id%NRHS IF (id%KEEP(253) .LE. 0) THEN id%INFO(1)=-42 id%INFO(2)=id%NRHS RETURN ENDIF ELSE id%KEEP(253) = 0 ENDIF ENDIF IF ( (id%KEEP(24).NE.0) .AND. & id%NSLAVES.eq.1 ) THEN id%KEEP(24) = 0 END IF IF ( (id%KEEP(24).EQ.0) .AND. & id%NSLAVES.GT.1 ) THEN id%KEEP(24) = 8 ENDIF IF ( (id%KEEP(24).NE.0) .AND. (id%KEEP(24).NE.1) .AND. & (id%KEEP(24).NE.8) .AND. (id%KEEP(24).NE.10) .AND. & (id%KEEP(24).NE.12) .AND. (id%KEEP(24).NE.14) .AND. & (id%KEEP(24).NE.16) .AND. (id%KEEP(24).NE.18)) THEN id%KEEP(24) = 8 END IF C**************************************************** C C The master is doing most of the work C C NOTE: Treatment of the errors on the master= C Go to the next SPMD part of the code in which C the first statement must be a call to PROPINFO C C**************************************************** C ========================================= C Check (raise error or modify) some input C parameters or KEEP values on the master. C ========================================= id%KEEP8(21) = int(id%KEEP(85),8) IF ( id%MYID .EQ. MASTER ) THEN C ---------------------------- C Save id%ICNTL(18) (distributed C matrix on entry) in id%KEEP(54) C ---------------------------- id%KEEP(54) = id%ICNTL(18) IF ( id%KEEP(54) .LT. 0 .or. id%KEEP(54).GT.3 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Out-of-range value for id%ICNTL(18).' WRITE(MPG, *) ' Used 0 ie matrix not distributed' END IF id%KEEP(54) = 0 END IF IF ( id%KEEP(54) .EQ. 1 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Option id%ICNTL(18)=1 is obsolete.' WRITE(MPG, *) ' We recommend not to use it.' WRITE(MPG, *) ' It will disappear in a future release' END IF END IF C ----------------------------------------- C Save id%ICNTL(5) (matrix format) in id%KEEP(55) C ----------------------------------------- id%KEEP(55) = id%ICNTL(5) IF ( id%KEEP(55) .LT. 0 .OR. id%KEEP(55) .GT. 1 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Out-of-range value for id%ICNTL(5).' WRITE(MPG, *) ' Used 0 ie matrix is assembled' END IF id%KEEP(55) = 0 END IF id%KEEP(60) = id%ICNTL(19) IF ( id%KEEP( 60 ) .LE. 0 ) id%KEEP( 60 ) = 0 IF ( id%KEEP( 60 ) .GT. 3 ) id%KEEP( 60 ) = 0 IF (id%KEEP(60) .NE. 0 .AND. id%SIZE_SCHUR == 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Schur option ignored because SIZE_SCHUR=0' ENDIF id%KEEP(60)=0 END IF C --------------------------------------- C Save SIZE_SCHUR in a KEEP, for possible C check at factorization and solve phases C --------------------------------------- IF ( id%KEEP(60) .NE.0 ) THEN id%KEEP(116) = id%SIZE_SCHUR IF (id%SIZE_SCHUR .LT. 0 .OR. id%SIZE_SCHUR .GE. id%N) THEN id%INFO(1)=-49 id%INFO(2)=id%SIZE_SCHUR RETURN ENDIF C List of Schur variables provided by user. IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 8 RETURN ELSE IF (size(id%LISTVAR_SCHUR) 0 .AND. id%NBLOCK > 0 .AND. & id%NPROW > 0 .AND. id%NPCOL > 0 ) THEN IF (id%NPROW *id%NPCOL .LE. id%NSLAVES) THEN C We will eventually have to "symmetrize the C Schur complement. For that NBLOCK and MBLOCK C must be equal. IF (id%MBLOCK .NE. id%NBLOCK ) THEN id%INFO(1)=-31 id%INFO(2)=id%MBLOCK - id%NBLOCK RETURN ENDIF ENDIF ENDIF ENDIF C Check the ordering strategy and compatibility with C other control parameters id%KEEP(244) = id%ICNTL(28) IF ((id%KEEP(244) .LT. 0) .OR. (id%KEEP(244) .GT. 2)) THEN id%KEEP(244) = 0 ENDIF IF(id%KEEP(244) .EQ. 0) THEN ! Automatic C One could check for availability of parallel ordering C tools, or for possible options incompatible with // C analysis to decide (e.g. avoid returning an error if C // analysis not compatible with some option but user C lets MUMPS decide to choose sequential or paralllel C analysis) C Current strategy for automatic is sequential analysis id%KEEP(244) = 1 ENDIF #if ! defined (ptscotch) && ! defined(parmetis) && ! defined(parmetis3) IF (id%KEEP(244) .EQ. 2) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("ParMETIS and PT-SCOTCH not available.")') END IF RETURN END IF #endif id%KEEP(245) = id%ICNTL(29) IF ((id%KEEP(245) .LT. 0) .OR. (id%KEEP(245) .GT. 2)) THEN id%KEEP(245) = 0 END IF IF (id%KEEP(244) .EQ. 2) THEN IF ( id%KEEP(245).EQ.0 ) THEN #if defined(parmetis) || defined(parmetis3) id%KEEP(245) = 2 #elif defined(ptscotch) id%KEEP(245) = 1 #endif ENDIF ENDIF C #if ! defined(parmetis) && ! defined(parmetis3) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 2)) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("ParMETIS not available.")') END IF RETURN END IF #endif #if ! defined(ptscotch) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 1)) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("PT-SCOTCH not available.")') END IF RETURN END IF #endif IF (id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(55) .NE. 0) THEN id%INFO(1) = -39 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(5), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if the")') WRITE(LP, & '("matrix is not assembled")') ENDIF RETURN ELSE IF(id%KEEP(60) .NE. 0) THEN id%INFO(1) = -39 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(19), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if SCHUR")') WRITE(LP, & '("complement must be returned")') ENDIF RETURN END IF C In the case where there are too few processes to do C the parallel analysis we simply revert to sequential version IF(id%NSLAVES .LT. 2) THEN id%KEEP(244) = 1 IF(PROKG) WRITE(MPG, & '("Too few processes. & Reverting to sequential analysis")',advance='no') IF(id%KEEP(245) .EQ. 1) THEN C Scotch necessarily available because pt-scotch C is, otherwise an error would have occurred IF(PROKG) WRITE(MPG, '(" with SCOTCH.")') id%KEEP(256) = 3 ELSE IF(id%KEEP(245) .EQ. 2) THEN C Metis necessarily available because parmetis C is, otherwise an error would have occurred IF(PROKG) WRITE(MPG, '(" with Metis.")') id%KEEP(256) = 5 ELSE IF(PROKG) WRITE(MPG, '(".")') id%KEEP(256) = 7 END IF END IF C In the case where there the input matrix is too small to do C the parallel analysis we simply revert to sequential version IF(id%N .LE. 50) THEN id%KEEP(244) = 1 IF(PROKG) WRITE(MPG, & '("Input matrix is too small for the parallel & analysis. Reverting to sequential analysis")',advance='no') IF(id%KEEP(245) .EQ. 1) THEN IF(PROKG) WRITE(MPG, '(" with SCOTCH.")') id%KEEP(256) = 3 ELSE IF(id%KEEP(245) .EQ. 2) THEN IF(PROKG) WRITE(MPG, '(" with Metis.")') id%KEEP(256) = 5 ELSE IF(PROKG) WRITE(MPG, '(".")') id%KEEP(256) = 7 END IF END IF END IF id%INFOG(32) = id%KEEP(244) IF ( (id%KEEP(244) .EQ. 1) .AND. & (id%KEEP(256) .EQ. 1) ) THEN C ordering given, PERM_IN must be of size N IF ( .NOT. associated( id%PERM_IN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 3 RETURN ELSE IF ( size( id%PERM_IN ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 3 RETURN END IF ENDIF C Check KEEP(9-10) for level 2 IF (id%KEEP(9) .LE. 1 ) id%KEEP(9) = 500 IF ( id%KEEP8(21) .GT. 0_8 ) THEN IF ((id%KEEP8(21).LE.1_8) .OR. & (id%KEEP8(21).GT.int(id%KEEP(9),8))) & id%KEEP8(21) = int(min(id%KEEP(9),100),8) ENDIF C IF (id%KEEP(48). EQ. 1 ) id%KEEP(48) = -12345 C IF ( (id%KEEP(48).LT.0) .OR. (id%KEEP(48).GT.5) ) THEN id%KEEP(48)=5 ENDIF C Schur C Given ordering must be compatible with Schur variables. IF ( (id%KEEP(60) .NE. 0) .AND. (id%KEEP(256) .EQ. 1) ) THEN DO I = 1, id%SIZE_SCHUR IF (id%PERM_IN(id%LISTVAR_SCHUR(I)) & .EQ. id%N-id%SIZE_SCHUR+I) & CYCLE C ------------------------------- C Problem with PERM_IN: -22/3 C Above constrained explained in C doc of PERM_IN in user guide. C ------------------------------- id%INFO(1) = -4 id%INFO(2) = id%LISTVAR_SCHUR(I) RETURN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Ignoring user-ordering, because incompatible with Schur.' WRITE(MPG,'(A)') ' ** id%ICNTL(7) treated as 0.' END IF EXIT ENDDO END IF C C Note that schur is not compatible with C C 1/Max-trans DONE C 2/Null space C 3/Ordering given DONE C 4/Scaling C 5/Iterative Refinement C 6/Error analysis C 7/Parallel Analysis C C Graph modification prior to ordering (id%ICNTL(12) option) C id%KEEP (95) will hold the eventually modified value of id%ICNTL(12) C id%KEEP(95) = id%ICNTL(12) C reset to usual ordering (KEEP(95)=1) C - when matrix is not general symmetric C - for out-of-range values IF (id%KEEP(50).NE.2) id%KEEP(95) = 1 IF ((id%KEEP(95).GT.3).OR.(id%KEEP(95).LT.0)) id%KEEP(95) = 1 C MAX-TRANS C C id%KEEP (23) will hold the eventually modified value of id%ICNTL(6) C (maximum transversal if >= 1) C id%KEEP(23) = id%ICNTL(6) C C C -------------------------------------------- C Avoid max-trans unsymmetric permutation in case of C matrix is symmetric with SYM=1 or C ordering is given, C or matrix is in element form, or Schur is asked C or initial matrix is distributed C -------------------------------------------- IF (id%KEEP(23).LT.0.OR.id%KEEP(23).GT.7) id%KEEP(23) = 0 C still forbid max trans for SYM=1 case IF ( id%KEEP(50) .EQ. 1 ) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not needed with SYM=1 factorization' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(95) .GT. 1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) ignored: not needed with SYM=1 factorization' END IF ENDIF id%KEEP(95) = 1 END IF C IF (id%KEEP(60) .GT. 0) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not allowed because of Schur' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Scaling during analysis not allowed because of Schur' ENDIF id%KEEP(52) = 0 ENDIF C also forbid compressed/constrained ordering... IF (id%KEEP(95) .GT. 1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) option not allowed because of Schur' END IF ENDIF id%KEEP(95) = 1 END IF IF ( (id%KEEP(23) .NE. 0) .AND. (id%KEEP(256).EQ.1)) THEN id%KEEP(23) = 0 IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'because ordering is given' END IF END IF IF ( id%KEEP(256) .EQ. 1 ) THEN IF (id%KEEP(95) > 1 .AND. PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) option incompatible with given ordering' END IF id%KEEP(95) = 1 END IF IF (id%KEEP(54) .NE. 0) THEN IF( id%KEEP(23) .NE. 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'because matrix is distributed' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Scaling (ICNTL(8)) during analysis not ', & 'allowed because matrix is distributed)' ENDIF ENDIF id%KEEP(52) = 0 IF (id%KEEP(95) .GT. 1 .AND. MPG.GT.0) THEN WRITE(MPG,'(A,A)') & ' ** ICNTL(12) option not allowed because matrix is ', & 'distributed' ENDIF id%KEEP(95) = 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN IF( id%KEEP(23) .NE. 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'for matrices in elemental format' END IF id%KEEP(23) = 0 ENDIF IF (PROKG .AND. id%KEEP(52).EQ.-2) THEN WRITE(MPG,'(A)') & ' ** Scaling (ICNTL(8)) not allowed ', & 'for matrices in elemental format' ENDIF id%KEEP(52) = 0 id%KEEP(95) = 1 ENDIF C In the case where parallel analysis is done, column permutation C is not allowed IF(id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(23) .EQ. 7) THEN C Automatic hoice: set it to 0 id%KEEP(23) = 0 ELSE IF (id%KEEP(23) .GT. 0) THEN id%INFO(1) = -39 id%KEEP(23) = 0 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(6), ICNTL(28)")') WRITE(LP, & '("Maximum transversal not allowed & in parallel analysis")') ENDIF RETURN END IF END IF C -------------------------------------------- C Avoid distributed entry for element matrix. C -------------------------------------------- IF ( id%KEEP(54) .NE. 0 .AND. id%KEEP(55) .NE. 0 ) THEN id%KEEP(54) = 0 IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Distributed entry not available for element matrix' END IF ENDIF C ---------------------------------- C Choice of symbolic analysis option C ---------------------------------- IF (id%ICNTL(58).NE.1 .and. id%ICNTL(58).NE.2 & .and. id%ICNTL(58).NE.3 .and. id%ICNTL(58).NE.4 ) THEN C out of range values leads to default id%KEEP(106)=2 ELSE id%KEEP(106)=id%ICNTL(58) C Options 3 and 4 not available, reset to default IF (id%KEEP(106).EQ.4) id%KEEP(106)=2 IF (id%KEEP(106).EQ.3) id%KEEP(106)=2 ENDIF C modify input parameters to avoid incompatible C input data between ordering, scaling and maxtrans C note that if id%ICNTL(12)/id%KEEP(95) = 0 then C the automatic choice will be done in ANA_O IF(id%KEEP(50) .EQ. 2) THEN C LDLT case IF( .NOT. associated(id%A) ) THEN C constraint ordering can be computed only if values are C given to analysis IF(id%KEEP(95) .EQ. 3) THEN id%KEEP(95) = 2 ENDIF ENDIF IF(id%KEEP(95) .EQ. 3 .AND. id%KEEP(256) .NE. 2) THEN C if constraint and ordering is not AMF then use compress IF (PROK) WRITE(MP,*) & 'WARNING: DMUMPS_ANA_O constrained ordering not ', & 'available with selected ordering' id%KEEP(95) = 2 ENDIF IF(id%KEEP(95) .EQ. 3) THEN C if constraint ordering required then we need to compute scaling C and max trans C NOTE that if we enter this condition then C id%A is associated because of the test above: C (IF( .NOT. associated(id%A) ) THEN) id%KEEP(23) = 5 id%KEEP(52) = -2 ELSE IF(id%KEEP(95) .EQ. 2 .AND. & (id%KEEP(23) .EQ. 0 .OR. id%KEEP(23) .EQ. 7) ) THEN C compressed ordering requires max trans but not necessary scaling IF( associated(id%A) ) THEN id%KEEP(23) = 5 ELSE C we can do compressed ordering without C information on the numerical values: C a maximum transversal already provides C information on the location of off-diagonal C nonzeros which can be candidates for 2x2 C pivots id%KEEP(23) = 1 ENDIF ELSE IF(id%KEEP(95) .EQ. 1) THEN id%KEEP(23) = 0 ELSE IF(id%KEEP(95) .EQ. 0 .AND. id%KEEP(23) .EQ. 0) THEN C if max trans desactivated then the automatic choice for type of ord C is set to 1, which means that we will use usual ordering C (no constraints or compression) id%KEEP(95) = 1 ENDIF ELSE id%KEEP(95) = 1 ENDIF C -------------------------------- C Save ICNTL(56) (QR) in KEEP(53) C Will be broadcasted to all other C nodes in routine DMUMPS_BDCAST C -------------------------------- id%KEEP(53) = id%ICNTL(56) C --------------------------- C Possible values are 0..2 C Other values are treated as 0 C ------------------------------ IF ( id%KEEP(53) .LT. 0 .OR. & id%KEEP(53) .GE. 2 & ) THEN id%KEEP(53) = 0 IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(56) treated as if set to 0 ' END IF IF(id%KEEP(86).EQ.1)THEN C Force the exchange of both the memory and flops information during C the factorization IF(id%KEEP(47).LT.2) id%KEEP(47)=2 ENDIF IF(id%KEEP(48).EQ.5)THEN IF(id%KEEP(50).EQ.0)THEN id%KEEP(87)=50 id%KEEP(88)=50 ELSE id%KEEP(87)=70 id%KEEP(88)=70 ENDIF ENDIF IF((id%NSLAVES.EQ.1).AND.(id%KEEP(76).GT.3))THEN id%KEEP(76)=2 ENDIF IF(id%KEEP(81).GT.0)THEN IF(id%KEEP(47).LT.2) id%KEEP(47)=2 ENDIF C C -- Save Block Low Rank input parameter id%KEEP(494) = id%ICNTL(35) IF (id%KEEP(494).EQ.1) THEN C -- Automatic BLR option setting id%KEEP(494)= 2 ENDIF IF ( id%KEEP(494).EQ.4) id%KEEP(494)=0 IF ((id%KEEP(494).LT.0).OR.(id%KEEP(494).GT.4)) THEN C Out of range values treated as 0 id%KEEP(494) = 0 ENDIF IF(id%KEEP(494).NE.0) THEN C test BLR incompatibilities C id%KEEP(464) = id%ICNTL(38) IF (id%KEEP(464).LT.0.OR.(id%KEEP(464).GT.1000)) THEN C Out of range values treated as 0 id%KEEP(464) = 0 ENDIF id%KEEP(465) = id%ICNTL(39) IF (id%KEEP(465).LT.0.OR.(id%KEEP(465).GT.1000)) THEN C Out of range values treated as 0 id%KEEP(465) = 0 ENDIF C LR is incompatible with elemental matrices, forbid it at analysis IF (id%KEEP(55).NE.0) THEN IF (LPOK) WRITE(LP,*) & " *** BLR feature currently incompatible " & ,"with elemental matrices" C BLR for elt entry might be developed in the future id%INFO(1)=-800 id%INFO(2)=5 RETURN ENDIF C C LR incompatible with forward in facto IF (id%KEEP(252).NE.0) THEN IF (LPOK) WRITE(LP,*) & " *** BLR feature currently incompatible" & ," with forward during factorization" id%INFO(1) = -43 id%INFO(2) = 35 RETURN ENDIF C ENDIF C IF(id%KEEP(494).NE.0) THEN C id%KEEP(469)=0,1,2,3,4 IF ((id%KEEP(469).GT.4).OR.(id%KEEP(469).LT.0)) THEN id%KEEP(469)=0 ENDIF C Not implemented yet IF (id%KEEP(469).EQ.4) id%KEEP(469)=0 C id%KEEP(471)=-1,0,1 IF ((id%KEEP(471).LT.-1).AND.(id%KEEP(471).GT.1)) THEN id%KEEP(471)=-1 ENDIF C id%KEEP(472)=0 or 1 IF ((id%KEEP(472).NE.0).AND.(id%KEEP(472).NE.1)) THEN id%KEEP(472)=1 ENDIF C id%KEEP(475)=0,1,2,3 IF ((id%KEEP(475).GT.3).OR.(id%KEEP(475).LT.0)) THEN id%KEEP(475)=0 ENDIF C id%KEEP(482)=0,1,2,3 IF ((id%KEEP(482).GT.3).OR.(id%KEEP(482).LT.0)) THEN id%KEEP(482)=0 ENDIF IF((id%KEEP(487).LT.0)) THEN id%KEEP(487)= 2 ! default value ENDIF C id%KEEP(488)>0 IF((id%KEEP(488).LE.0)) THEN id%KEEP(488)= 8*id%KEEP(6) ENDIF C id%KEEP(490)>0 IF((id%KEEP(490).LE.0)) THEN id%KEEP(490) = 128 ENDIF C KEEP(491)>0 IF((id%KEEP(491).LE.0)) THEN id%KEEP(491) = 1000 ENDIF ENDIF C id%KEEP(13) = 0 id%KEEP(14) = 0 C Analysis by Blocks id%KEEP(13) = id%ICNTL(15) IF (id%KEEP(13).GT.1) THEN CV0 out-of range values id%KEEP(13) = 0 ENDIF IF (id%KEEP(13).EQ.1) THEN C{ Analysis by block with block data provided by user C check input data IF ( .NOT.associated(id%BLKPTR)) THEN C BLKPTR provided by user IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " id%BLKPTR should be provided by user on host " ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ELSE IF ( (id%NBLK.LE.0).OR.(id%NBLK.GT.id%N) & .OR. (id%NBLK+1.NE.size(id%BLKPTR)) & ) THEN C id%NBLK out of range IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ERROR incorrect value of id%NBLK:", id%NBLK ENDIF id%INFO(1) = -57 id%INFO(2) = 1 ELSE IF (id%BLKPTR(id%NBLK+1)-1.NE.id%N) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR id%BLKPTR(id%NBLK+1)-1 ", & "should be equal to id%N instead of ", & id%BLKPTR(id%NBLK+1)-1 ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ELSE IF (id%BLKPTR(1).NE.1) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR id%BLKPTR(1)", & "should be equal to 1 instead of ", & id%BLKPTR(1) ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ELSE IF (associated(id%BLKVAR)) THEN C id%BLKVAR IF (size(id%BLKVAR).NE.id%N) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR with centralized matrix. Size of id%BLKVAR ", & "should be equal to id%N instead of ", & size(id%BLKVAR) ENDIF id%INFO(1) = -57 id%INFO(2) = 3 ENDIF ENDIF C} ENDIF IF (id%KEEP(13).LT.0) THEN C note that id%BLKPTR might still be associated C but will not be used IF (mod(id%N,-id%KEEP(13)) .NE.0) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ICNTL(15)=", id%ICNTL(15), & " is incompatible with N=", id%N ENDIF id%INFO(1) = -57 id%INFO(2) = 1 ENDIF ENDIF IF (id%KEEP(13).EQ.0) THEN IF ( & ((id%KEEP(54).EQ.3).AND.(id%KEEP(244).EQ.1)) & .OR. & ((id%KEEP(244).EQ.2).AND.(id%KEEP(339).NE.0)) & ) THEN id%KEEP(13)=-1 ENDIF C unsymmetric assembled matrices with or without BLR, C also in case of centralized matrix (if C matrix is distributed, then KEEP(13) has C been set to -1 in the block above) IF (id%KEEP(50).EQ.0.AND. id%KEEP(55).EQ.0) THEN C Respect decision taken for Maxtrans C since it will be switch off C if one activates the analysis by block IF ( (id%KEEP(23).LE.0) .OR. (id%KEEP(23).GT.7) & ) THEN id%KEEP(13)=-1 ENDIF ENDIF ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(55).NE.0) & ) THEN IF (PROKG.AND.(id%KEEP(13).NE.-1)) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with elemental matrices" C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(106).NE.1).AND. (id%KEEP(106).NE.2) & ) THEN IF (PROKG.AND.(id%KEEP(13).NE.-1)) WRITE(MPG,'(A,A,I4)') & " ** Analysis by block not compatible ", & "with symbolic factorization option ", & id%KEEP(106) C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. (id%KEEP(244) .EQ. 2) .AND. & (id%KEEP(339).EQ.0) & ) THEN IF (PROKG.AND.(id%KEEP(13).NE.-1)) WRITE(MPG,'(A)') & " ** Analysis by block switched off " C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(60).NE.0) & ) THEN IF (PROKG.AND.(id%KEEP(13).NE.-1)) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with Schur " C switch off analysis by block id%KEEP(13)= 0 ENDIF IF (id%KEEP(13).NE.0) THEN C Maximum transversal not compatible with analysis by block IF (id%KEEP(23).NE.0) THEN C in case of automatic choice (id%KEEP(27).EQ.7) C do not print message IF (PROKG.AND.id%KEEP(23).NE.7) WRITE(MPG,'(A,A)') & " ** Maximum transversal (ICNTL(6)) ", & "not compatible with analysis by block" C switch off max transversal id%KEEP(23)= 0 ENDIF C - compression for LDLT IF (id%KEEP(95).NE.1) THEN C in case of automatic choice (id%KEEP(95).EQ.0) C do not print message IF (PROKG.AND.id%KEEP(95).NE.0) WRITE(MPG,'(A,A)') & " ** ICNTL(12) not compatible with ", & " analysis by block" C switch off 2x2 preprocessing for symmetric matrices id%KEEP(95) = 1 ENDIF ENDIF C C end id%MYID.EQ.MASTER END IF RETURN END SUBROUTINE DMUMPS_ANA_CHECK_KEEP C ======================================== SUBROUTINE DMUMPS_ANA_CHECK_ICNTL48 (id ) !$ USE OMP_LIB, ONLY : omp_get_max_threads USE DMUMPS_STRUC_DEF C IMPLICIT NONE C C Purpose C ======= C This subroutine performed part of DMUMPS_ANA_CHECK_KEEP concerned by ICNTL(48) C and is called by DMUMPS_ANA_CHECK_KEEP and DMUMPS_ANA_REDO_STAT C C Parameters C TYPE(DMUMPS_STRUC) :: id C C Local variables C INTEGER :: LP, MP, MPG, NOMP INTEGER :: MASTER LOGICAL :: PROK, PROKG, LPOK LOGICAL :: I_AM_SLAVE PARAMETER( MASTER = 0 ) C LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (id%MYID.eq.MASTER) THEN C C L0-OMP settings of KEEP(400) C id%KEEP(401) = 0 NOMP = 0 IF (id%ICNTL(48).EQ.1) id%KEEP(401)=1 IF (id%KEEP(401) .GT. 0) THEN !$ NOMP=omp_get_max_threads() IF ( NOMP .EQ. 0 ) THEN C Compilation without OMP! id%KEEP(400) = 0 id%INFO(1)=-58 id%INFO(2)=0 IF (LPOK) WRITE(LP,'(A)') & " FAILURE DETECTED IN ANALYSIS: ICNTL(48) requires OpenMP" RETURN ENDIF ENDIF C ENDIF RETURN END SUBROUTINE DMUMPS_ANA_CHECK_ICNTL48 C SUBROUTINE DMUMPS_GATHER_MATRIX(id) C This subroutine gathers a distributed matrix C on the host node USE DMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) TYPE(DMUMPS_STRUC) :: id C local variables INTEGER, ALLOCATABLE :: REQPTR(:,:) INTEGER(8), ALLOCATABLE :: MATPTR(:) INTEGER(8), ALLOCATABLE :: MATPTR_cp(:) INTEGER(8) :: IBEG8, IEND8 INTEGER :: INDX INTEGER :: LP, MP, MPG, I, K INTEGER(8) :: I8 LOGICAL :: PROKG C C messages are split into blocks of size BLOCKSIZE C (smaller than IOVFLO (=2^31-1)) C on all processors INTEGER(4) :: IOVFLO INTEGER :: BLOCKSIZE INTEGER :: MAX_NBBLOCK_loc, NBBLOCK_loc INTEGER :: SIZE_SENT, NRECV LOGICAL :: OMP_FLAG INTEGER(8) :: NZ_loc8 C for validation only: INTEGER :: NB_BLOCKS, NB_BLOCK_SENT LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) C iovflo = huge(INTEGER, kind=4) IOVFLO = huge(IOVFLO) C we do not want too large messages BLOCKSIZE = int(max(100000_8,int(IOVFLO,8)/200_8)) IF ( id%KEEP(46) .EQ. 0 .AND. id%MYID .EQ. MASTER ) THEN C host-node mode: master has no entries. id%KEEP8(29) = 0_8 END IF IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------- C Allocate small arrays for pointers C into arrays IRN/JCN C ----------------------------------- ALLOCATE( MATPTR( id%NPROCS ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) ' array MATPTR' END IF GOTO 13 END IF ALLOCATE( MATPTR_cp( id%NPROCS ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) ' array MATPTR' END IF GOTO 13 END IF C ----------------------------------- C Allocate a small array for requests C ----------------------------------- ALLOCATE( REQPTR( id%NPROCS-1, 2 ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = 2 * (id%NPROCS-1) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array REQPTR' END IF GOTO 13 END IF C -------------------- C Allocate now IRN/JCN C -------------------- ALLOCATE( id%IRN( id%KEEP8(28) ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2)) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array IRN' END IF GOTO 13 END IF ALLOCATE( id%JCN( id%KEEP8(28) ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2)) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array JCN' END IF GOTO 13 END IF END IF 13 CONTINUE C Propagate errors CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) < 0 ) RETURN C ------------------------------------- C Get numbers of non-zeros for everyone C and count total and maximum C nb of blocks of size BLOCKSIZE C that slaves will sent C ------------------------------------- IF ( id%MYID .EQ. MASTER ) THEN C each block will correspond to 2 messages (IRN_LOC,JCN_LOC) NB_BLOCK_SENT = 0 MAX_NBBLOCK_loc = 0 DO I = 1, id%NPROCS - 1 CALL MPI_RECV( MATPTR( I+1 ), 1, & MPI_INTEGER8, I, & COLLECT_NZ, id%COMM, STATUS, IERR ) NBBLOCK_loc = ceiling(dble(MATPTR(I+1))/dble(BLOCKSIZE)) MAX_NBBLOCK_loc = max(MAX_NBBLOCK_loc, NBBLOCK_loc) NB_BLOCK_SENT = NB_BLOCK_SENT + NBBLOCK_loc END DO IF ( id%KEEP(46) .eq. 0 ) THEN MATPTR( 1 ) = 1_8 ELSE NZ_loc8=id%KEEP8(29) MATPTR( 1 ) = NZ_loc8 + 1_8 END IF C -------------- C Build pointers C -------------- DO I = 2, id%NPROCS MATPTR( I ) = MATPTR( I ) + MATPTR( I-1 ) END DO ELSE NZ_loc8=id%KEEP8(29) CALL MPI_SEND( NZ_loc8, 1, MPI_INTEGER8, MASTER, & COLLECT_NZ, id%COMM, IERR ) END IF IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------------------- C Bottleneck is here master; use synchronous send C for slaves, but asynchronous receives on master C Then while master receives indices do the local C copies for better overlap. C (If master has other things to do, he could try C to do them here.) C ------------------------------------ C copy pointers to position in IRN/JCN MATPTR_cp = MATPTR IF ( id%KEEP8(29) .NE. 0_8 ) THEN OMP_FLAG = ( id%KEEP8(29).GE.50000_8 ) !$OMP PARALLEL DO PRIVATE(I8) !$OMP& IF(OMP_FLAG) DO I8=1,id%KEEP8(29) id%IRN(I8) = id%IRN_loc(I8) id%JCN(I8) = id%JCN_loc(I8) ENDDO !$OMP END PARALLEL DO ENDIF C C Compute position for each block to be received C and store it. NB_BLOCKS = 0 C at least one slave will send MAX_NBBLOCK_loc C couple of messages (IRN_loc/JCN_loc) DO K = 1, MAX_NBBLOCK_loc C Post irecv for all messages from proc I C that have been sent NRECV = 0 DO I = 1, id%NPROCS - 1 C Check if message was sent IBEG8 = MATPTR_cp( I ) IF ( IBEG8 .LT. MATPTR(I+1)) THEN C Count number of request in NRECV NRECV = NRECV + 2 IEND8 = min(IBEG8+int(BLOCKSIZE,8)-1_8, & MATPTR(I+1)-1_8) C update pointer for receiving messages C from proc I in MATPTR_cp: MATPTR_cp( I ) = IEND8 + 1_8 SIZE_SENT = int(IEND8 - IBEG8 + 1_8) NB_BLOCKS = NB_BLOCKS + 1 C CALL MPI_IRECV( id%IRN(IBEG8), SIZE_SENT, MPI_INTEGER, & I, COLLECT_IRN, id%COMM, REQPTR(I,1), IERR ) C CALL MPI_IRECV( id%JCN(IBEG8), SIZE_SENT, MPI_INTEGER, & I, COLLECT_JCN, id%COMM, REQPTR(I,2), IERR ) ELSE REQPTR( I,1 ) = MPI_REQUEST_NULL REQPTR( I,2 ) = MPI_REQUEST_NULL ENDIF END DO C Wait set of messages corresponding to current block C ( we dont exploit the fact that C messages are not overtaking C (if sent by one source to the same destination) ) C C Loop on only non MPI_REQUEST_NULL requests DO I = 1, NRECV CALL MPI_WAITANY & ( 2 * (id%NPROCS-1), REQPTR( 1, 1 ), INDX, & STATUS, IERR ) ENDDO C C process next block END DO DEALLOCATE( REQPTR ) DEALLOCATE( MATPTR ) DEALLOCATE( MATPTR_cp ) C end of reception by master ELSE C ----------------------------- C Send only if size is not zero C ----------------------------- IF ( id%KEEP8(29) .NE. 0_8 ) THEN NZ_loc8=id%KEEP8(29) C send by blocks of size BLOCKSIZE DO I8=1_8, NZ_loc8, int(BLOCKSIZE,8) SIZE_SENT = BLOCKSIZE IF (NZ_loc8-I8+1_8.LT.int(BLOCKSIZE,8)) THEN SIZE_SENT = int(NZ_loc8-I8+1_8) ENDIF CALL MPI_SEND( id%IRN_loc(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & COLLECT_IRN, id%COMM, IERR ) CALL MPI_SEND( id%JCN_loc(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & COLLECT_JCN, id%COMM, IERR ) END DO END IF END IF RETURN 150 FORMAT( &/' ** FAILURE DURING DMUMPS_GATHER_MATRIX, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE DMUMPS_GATHER_MATRIX SUBROUTINE DMUMPS_DUMP_PROBLEM(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C If id%WRITE_PROBLEM has been set by the user, C possibly on all processors in case of distributed C matrix, open a file and dumps the matrix and/or C the right hand side. In case the last characters C of id.WRITE_PROBLEM are "bin" (uppercase letters C are also accepted), then the matrix is written C in binary stream format (a C routine is called to C avoid depending on the access='stream' mode that C is only available since Fortran 2003). In that case, C a small header file is also written. C Otherwise, this subroutine calls C DMUMPS_DUMP_MATRIX (to write the matrix in C matrix-market format) and DMUMPS_DUMP_RHS. C The routine should be called on all MPI processes. C C Examples: C 1/ WRITE_PROBLEM='mymatrix.txt', centralized matrix C mymatrix.txt contains the matrix in matrix-market format C 2/ WRITE_PROBLEM='mymatrix.txt', distributed matrix C mymatrix.txt contains the portion of the matrix C on process , in matrix-market format C 3/ WRITE_PROBLEM='mymatrix.bin', centralized matrix C mymatrix.bin contains the matrix in binary format C mymatrix.header contains a short description in text format, C with the first line identical to the one of C a matrix-market format C 4/ WRITE_PROBLEM='mymatrix.bin', distributed matrix C mymatrix.bin contains the portion of the matrix C on process , in binary format C C mymatrix.header contains a short description in text format, C with the first line identical to matrix-market format C C If a centralized, dense, RHS is available, it is also written, C either in matrix-market or binary format (if WRITE_PROBLEM C has a .bin extension). In that case the filename for the RHS C is WRITE_PROBLEM//".rhs". If written in binary form, information C on the RHS is also provided in the header file. C INCLUDE 'mpif.h' C C Arguments C ========= C TYPE(DMUMPS_STRUC) :: id C C Local variables C =============== C INTEGER :: MASTER, IERR, I INTEGER :: IUNIT LOGICAL :: IS_ELEMENTAL LOGICAL :: IS_DISTRIBUTED LOGICAL :: NAME_INITIALIZED INTEGER :: DO_WRITE, DO_WRITE_CHECK CHARACTER(LEN=20) :: IDSTR LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: L LOGICAL :: BINARY_FORMAT, DUMP_RHS, & DUMP_BLKPTR, DUMP_BLKVAR INTEGER :: IS_A_PROVIDED, IS_A_PROVIDED_GLOB DOUBLE PRECISION, TARGET :: A_DUMMY(1) INTEGER, TARGET :: IRN_DUMMY(1), JCN_DUMMY(1) INTEGER, POINTER, DIMENSION(:) :: IRN_PASSED, JCN_PASSED DOUBLE PRECISION, POINTER, DIMENSION(:) :: A_PASSED INTEGER :: MPG LOGICAL :: PROKG PARAMETER( MASTER = 0 ) 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) MPG = id%ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) NAME_INITIALIZED = id%WRITE_PROBLEM(1:20) & .NE. "NAME_NOT_INITIALIZED" BINARY_FORMAT = .FALSE. L=len_trim(id%WRITE_PROBLEM) IF (L.GT.4) THEN IF ( id%WRITE_PROBLEM(L-3:L-3) .EQ. '.' .AND. & ( id%WRITE_PROBLEM(L-2:L-2) .EQ. 'b' .OR. & id%WRITE_PROBLEM(L-2:L-2) .EQ. 'B' ) .AND. & ( id%WRITE_PROBLEM(L-1:L-1) .EQ. 'i' .OR. & id%WRITE_PROBLEM(L-1:L-1) .EQ. 'I' ) .AND. & ( id%WRITE_PROBLEM(L:L) .EQ. 'n' .OR. & id%WRITE_PROBLEM(L:L) .EQ. 'N' ) ) THEN BINARY_FORMAT = .TRUE. ENDIF ENDIF IF (NAME_INITIALIZED.AND.PROKG) THEN WRITE(MPG,'(/A,A/)') & " Write input matrix to file, WRITE_PROBLEM= ", & id%WRITE_PROBLEM(1:L) ENDIF C Check if RHS should also be dumped DUMP_RHS = id%MYID.EQ.MASTER .AND. & associated(id%RHS) .AND. NAME_INITIALIZED DUMP_RHS = DUMP_RHS .AND. id%NRHS .GE. 1 DUMP_RHS = DUMP_RHS .AND. id%N .GE. 1 DUMP_RHS = DUMP_RHS .AND. id%ICNTL(20) .EQ. 0 C Check if BLKPTR and/or BLKVAR should also be dumped DUMP_BLKPTR = .FALSE. DUMP_BLKVAR = .FALSE. IF ( id%MYID.EQ.MASTER .AND. NAME_INITIALIZED ) THEN IF ( id%ICNTL(15) .EQ. 1 & .AND. id%NBLK .GT. 0 ) THEN IF (associated(id%BLKPTR)) THEN DUMP_BLKPTR = .TRUE. IF (associated(id%BLKVAR)) THEN C Dump also BLKVAR, except if allocated by MUMPS DUMP_BLKVAR = .TRUE. ENDIF ENDIF ELSE IF ( id%ICNTL(15) .LT. 0 ) THEN IF (associated(id%BLKVAR)) THEN C Dump also BLKVAR, except if allocated by MUMPS DUMP_BLKVAR = .TRUE. ENDIF ENDIF ENDIF C Remark: if id%KEEP(54) = 1 or 2, the structure C is centralized at analysis. Since DMUMPS_DUMP_PROBLEM C is called at analysis phase, we define IS_DISTRIBUTED C as below, which implies that the structure of the problem C is distributed in IRN_loc/JCN_loc at analysis. IS_DISTRIBUTED = (id%KEEP(54) .EQ. 3) IS_ELEMENTAL = (id%KEEP(55) .NE. 0) IF (NAME_INITIALIZED) THEN IF (I_AM_MASTER .OR. IS_DISTRIBUTED) THEN C Try to find a free Fortran unit CALL MUMPS_FIND_UNIT(IUNIT) IF ( IUNIT .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 1 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) GOTO 500 IF (I_AM_MASTER .AND. .NOT. IS_DISTRIBUTED) THEN C ==================== C Matrix is assembled C and centralized C ==================== IF (NAME_INITIALIZED) THEN IF ( BINARY_FORMAT ) THEN IF (id%KEEP8(28) .EQ. 0_8) THEN C Special case of empty matrix A_PASSED => A_DUMMY IRN_PASSED => IRN_DUMMY JCN_PASSED => JCN_DUMMY IS_A_PROVIDED = 1 ELSE IF (associated(id%A)) THEN A_PASSED=>id%A IRN_PASSED => id%IRN JCN_PASSED => id%JCN IS_A_PROVIDED = 1 ELSE A_PASSED => A_DUMMY IRN_PASSED => id%IRN JCN_PASSED => id%JCN IS_A_PROVIDED = 0 ENDIF OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' ) CALL DMUMPS_DUMP_HEADER( IUNIT, id%N, & IS_A_PROVIDED, id%KEEP(50), IS_DISTRIBUTED, & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) ) CLOSE( IUNIT ) CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(28), & id%KEEP(35), & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1), & IS_A_PROVIDED, & trim(id%WRITE_PROBLEM)//char(0) ) ELSE OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)) CALL DMUMPS_DUMP_MATRIX( id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! = .FALSE., centralized & IS_ELEMENTAL, ! Elemental or not & .FALSE.) CLOSE(IUNIT) ENDIF ENDIF ELSE IF ( IS_DISTRIBUTED ) THEN C ===================== C Matrix is distributed C ===================== IF ( .NOT.NAME_INITIALIZED & .OR. .NOT. I_AM_SLAVE )THEN DO_WRITE = 0 ELSE DO_WRITE = 1 ENDIF CALL MPI_ALLREDUCE(DO_WRITE, DO_WRITE_CHECK, 1, & MPI_INTEGER, MPI_SUM, id%COMM, IERR) C ----------------------------------------- C If yes, each processor writes its share C of the matrix in a file in matrix market C format (otherwise nothing written). We C append the process id to the filename. C Safer in case all filenames are the C same if all processors share the same C file system. C ----------------------------------------- IF (DO_WRITE_CHECK.EQ.id%NSLAVES .AND. I_AM_SLAVE) THEN WRITE(IDSTR,'(I9)') id%MYID_NODES IF (BINARY_FORMAT) THEN IF (id%KEEP8(29) .EQ. 0_8) THEN C Special case of empty matrix A_PASSED => A_DUMMY IRN_PASSED => IRN_DUMMY JCN_PASSED => JCN_DUMMY C (consider that A is provided when NNZ_loc=0) IS_A_PROVIDED = 1 ELSE IF (associated(id%A_loc)) THEN A_PASSED=>id%A_loc IRN_PASSED => id%IRN_loc JCN_PASSED => id%JCN_loc IS_A_PROVIDED = 1 ELSE A_PASSED => A_DUMMY IRN_PASSED => id%IRN_loc JCN_PASSED => id%JCN_loc IS_A_PROVIDED = 0 ENDIF CALL MPI_ALLREDUCE( IS_A_PROVIDED, & IS_A_PROVIDED_GLOB, 1, & MPI_INTEGER, MPI_PROD, id%COMM_NODES, IERR ) C IS_A_PROVIDED_GLOB = 1 => dump numerical values C IS_A_PROVIDED_GLOB = 0 => some processes did not provide C numerical values, dump only pattern, C and indicate this in the header IF ( id%MYID_NODES.EQ.0) THEN C Print header on first MPI worker (only one global header C file in case of distributed matrix), replacing the .bin C extension by a .header extension OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' ) CALL DMUMPS_DUMP_HEADER( IUNIT, id%N, & IS_A_PROVIDED_GLOB, id%KEEP(50), IS_DISTRIBUTED, & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) ) CLOSE( IUNIT ) ENDIF CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(29), & id%KEEP(35), & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1), & IS_A_PROVIDED_GLOB, & trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))//char(0) ) ELSE OPEN(IUNIT, & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))) CALL DMUMPS_DUMP_MATRIX(id, & IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! =.TRUE., distributed & IS_ELEMENTAL, ! Elemental or not & .FALSE.) CLOSE(IUNIT) ENDIF ENDIF C ELSE ... C Nothing written in other cases. ENDIF C =============== C Right-hand side C =============== IF ( DUMP_RHS ) THEN IF (BINARY_FORMAT) THEN C dump RHS in binary format CALL MUMPS_DUMPRHSBINARY_C( id%N, id%NRHS, id%LRHS, id%RHS(1), & id%KEEP(35), & trim(id%WRITE_PROBLEM)//'.rhs'//char(0) ) ELSE C dump RHS in matrix-market format OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM) //".rhs") CALL DMUMPS_DUMP_RHS(IUNIT, id) CLOSE(IUNIT) ENDIF ENDIF IF ( DUMP_BLKPTR ) THEN IF (BINARY_FORMAT) THEN ! suppress trailing '.bin' and use '.blkptr' OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkptr' ) ELSE ! just append '.blkptr' OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkptr") ENDIF WRITE(IUNIT,'(I9)') id%NBLK DO I=1,id%NBLK+1 WRITE(IUNIT,'(I9)') id%BLKPTR(I) ENDDO CLOSE(IUNIT) ENDIF IF ( DUMP_BLKVAR ) THEN IF (BINARY_FORMAT) THEN ! suppress trailing '.bin' and use '.blkvar' OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkvar' ) ELSE ! just append '.blkvar' OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkvar") ENDIF DO I=1,id%N WRITE(IUNIT,'(I9)') id%BLKVAR(I) ENDDO CLOSE(IUNIT) ENDIF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_DUMP_PROBLEM SUBROUTINE DMUMPS_DUMP_HEADER( IUNIT, N, IS_A_PROVIDED_GLOB, & SYM, IS_DISTRIBUTED, NSLAVES, NNZTOT, DUMP_RHS, NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, NBLK, ICNTL15 ) C C Purpose: C ======= C C Write a small header file, similar to matrix-market headers, C to accompany a matrix written in binary format. C INTEGER, INTENT(IN) :: IUNIT, N, IS_A_PROVIDED_GLOB , SYM, NSLAVES INTEGER(8), INTENT(IN) :: NNZTOT LOGICAL, INTENT(IN) :: IS_DISTRIBUTED, DUMP_RHS INTEGER, INTENT(IN) :: NRHS LOGICAL, INTENT(IN) :: DUMP_BLKPTR, DUMP_BLKVAR INTEGER, INTENT(IN) :: NBLK INTEGER, INTENT(IN) :: ICNTL15 C C Local declarations: C ================== C CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH C 1/ write a line identical to first line of matrix-market header IF ( IS_A_PROVIDED_GLOB .EQ. 1 ) THEN ARITH='real' ELSE ARITH='pattern' ENDIF IF (SYM .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) C 2/ indicate if matrix is distributed or centralized, C then describe binary file content and format IF ( IS_DISTRIBUTED ) THEN WRITE(IUNIT,FMT='(A,I5,A)') & '% Matrix is distributed (MPI ranks=',NSLAVES,')' ELSE WRITE(IUNIT,FMT='(A)') & '% Matrix is centralized' ENDIF WRITE(IUNIT,FMT='(A)') & '% Unformatted stream IO (no record boundaries):' IF (ARITH(1:7).EQ.'pattern') THEN IF (IS_DISTRIBUTED) THEN WRITE(IUNIT,'(A)') & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc)' ELSE WRITE(IUNIT,'(A)') & '% N,NNZ,IRN(1:NNZ),JCN(1:NNZ)' ENDIF WRITE(IUNIT,'(A)') '% (numerical values not provided)' ELSE IF (IS_DISTRIBUTED) THEN WRITE(IUNIT,'(A)') & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc),'// & 'A_loc(1:NNZ_loc)' ELSE WRITE(IUNIT,'(A)') '% N/NNZ/IRN(1:NNZ),JCN(1:NNZ),A(1:NNZ)' ENDIF WRITE(IUNIT,'(A)') '% Double precision storage' ENDIF IF ( IS_DISTRIBUTED ) THEN WRITE(IUNIT,'(A,/,A)') & '% N,IRN_loc(i),JCN_loc(i): 32 bits', & '% NNZ_loc: 64 bits' ELSE WRITE(IUNIT,'(A,/,A)') & '% N,IRN(i),JCN(i): 32 bits', & '% NNZ: 64 bits' ENDIF WRITE(IUNIT,FMT='(A,I16)') '% Matrix order: N=',N WRITE(IUNIT,FMT='(A,I16)') '% Matrix nonzeros: NNZ=',NNZTOT IF (DUMP_RHS) THEN WRITE(IUNIT,FMT='(A)') '%' WRITE(IUNIT,FMT='(A,/,A,I10,A,I5)') & '% A RHS was also written to disk by columns in binary form.', & '% Size: N rows x NRHS columns with N=',N,' NRHS=',NRHS WRITE(IUNIT,FMT='(A,I16,A)') & '% Total:',int(N,8)*int(NRHS,8),' scalar values.' WRITE(IUNIT,'(A)') '% Double precision storage' ENDIF IF (DUMP_BLKPTR) THEN WRITE(IUNIT,FMT='(A)') '%' WRITE(IUNIT,'(A,I9,A)') '% Matrix has a block format with', & NBLK,' blocks' WRITE(IUNIT,'(A)') & '% File .blkptr contains NBLK and BLKPTR(1:NBLK+1)' ELSE IF (ICNTL15 .LT. 0) THEN WRITE(IUNIT,FMT='(A)') '%' WRITE(IUNIT,'(A,I9,A)') & '% Matrix has a block format with ICNTL15=',ICNTL15 ENDIF IF (DUMP_BLKVAR) THEN WRITE(IUNIT,'(A)') & '% File .blkvar contains BLKVAR (N integers)' ELSE IF (ICNTL15 .NE. 0) THEN WRITE(IUNIT,'(A)') & '% (BLKVAR considered to be identity is not written)' ENDIF RETURN END SUBROUTINE DMUMPS_DUMP_HEADER SUBROUTINE DMUMPS_DUMP_MATRIX & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, IS_ELEMENTAL, PATTERN_ONLY ) USE DMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C This subroutine dumps a routine in matrix-market format C if the matrix is assembled, and in "MUMPS" format (see C example in the MUMPS users'guide, if the matrix is C centralized and elemental). C The routine can be called on all processors. In case of C distributed assembled matrix, each processor writes its C share as a matrix market file on IUNIT (IUNIT may have C different values on different processors). C C C C Arguments (input parameters) C ============================ C C IUNIT: should be set to the Fortran unit where C data should be written. C I_AM_SLAVE: .TRUE. except on a non working master C IS_DISTRIBUTED: .TRUE. if matrix is distributed, C i.e., if IRN_loc/JCN_loc are provided. C IS_ELEMENTAL : .TRUE. if matrix is elemental C id : main MUMPS structure C LOGICAL, intent(in) :: I_AM_SLAVE, & I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL, & PATTERN_ONLY INTEGER, intent(in) :: IUNIT TYPE(DMUMPS_STRUC), intent(in) :: id C C Local variables: C =============== C CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH INTEGER(8) :: I8, NNZ_i C C Executable statements: C ===================== IF (I_AM_MASTER .AND. .NOT. IS_DISTRIBUTED .AND. & .NOT. IS_ELEMENTAL) THEN C ================== C CENTRALIZED MATRIX C ================== IF (id%KEEP8(28) .EQ. 0_8) THEN CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ, id%NZ, NNZ_i) ELSE NNZ_i=id%KEEP8(28) ENDIF IF ((associated(id%A)).AND.(.NOT.PATTERN_ONLY)) THEN C Write header line: ARITH='real' ELSE ARITH='pattern ' ENDIF IF (id%KEEP(50) .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) WRITE(IUNIT,*) id%N, id%N, NNZ_i IF ((associated(id%A)).AND.(.NOT.PATTERN_ONLY)) THEN DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. id%IRN(I8).LT.id%JCN(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8), id%A(I8) ELSE WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8), id%A(I8) ENDIF ENDDO ELSE C pattern only DO I8=1_8,id%KEEP8(28) IF (id%KEEP(50).NE.0 .AND. id%IRN(I8).LT.id%JCN(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8) ELSE WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8) ENDIF ENDDO ENDIF ELSE IF ( IS_DISTRIBUTED .AND. I_AM_SLAVE ) THEN C ================== C DISTRIBUTED MATRIX C ================== IF (id%KEEP8(29) .EQ. 0_8) THEN CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ_loc, id%NZ_loc, NNZ_i) ELSE NNZ_i=id%KEEP8(29) ENDIF IF ((associated(id%A_loc)).AND.(.NOT.PATTERN_ONLY)) THEN ARITH='real' ELSE ARITH='pattern ' ENDIF IF (id%KEEP(50) .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) WRITE(IUNIT,*) id%N, id%N, NNZ_i IF ((associated(id%A_loc)).AND.(.NOT.PATTERN_ONLY)) THEN DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I8).LT.id%JCN_loc(I8)) THEN WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8), & id%A_loc(I8) ELSE WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8), & id%A_loc(I8) ENDIF ENDDO ELSE DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I8).LT.id%JCN_loc(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8) ELSE WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8) ENDIF ENDDO ENDIF ELSE IF (IS_ELEMENTAL .AND. I_AM_MASTER) THEN C ================== C ELEMENTAL MATRIX C ================== WRITE(IUNIT,*) id%N," :: N" WRITE(IUNIT,*) id%NELT," :: NELT" WRITE(IUNIT,*) size(id%ELTVAR)," :: NELTVAR" WRITE(IUNIT,*) size(id%A_ELT)," :: NELTVL" WRITE(IUNIT,*) id%ELTPTR(:)," ::ELTPTR" WRITE(IUNIT,*) id%ELTVAR(:)," ::ELTVAR" IF(.NOT.PATTERN_ONLY) THEN WRITE(IUNIT,*) id%A_ELT(:) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_DUMP_MATRIX SUBROUTINE DMUMPS_DUMP_RHS(IUNIT, id) C C Purpose: C ======= C Dumps a dense, centralized, C right-hand side in matrix market format on unit C IUNIT. Should be called on the host only. C USE DMUMPS_STRUC_DEF IMPLICIT NONE C Arguments C ========= TYPE(DMUMPS_STRUC), intent(in) :: id INTEGER, intent(in) :: IUNIT C C Local variables C =============== C CHARACTER (LEN=8) :: ARITH INTEGER :: I, J INTEGER(8) :: LD_RHS8, K8 C C Executable statements C ===================== C IF (associated(id%RHS)) THEN ARITH='real' WRITE(IUNIT,'(A,A,A)') '%%MatrixMarket matrix array ', & trim(ARITH), & ' general' WRITE(IUNIT,*) id%N, id%NRHS IF ( id%NRHS .EQ. 1 ) THEN LD_RHS8 = int(id%N,8) ELSE LD_RHS8 = int(id%LRHS,8) ENDIF DO J = 1, id%NRHS DO I = 1, id%N K8=int(J-1,8)*LD_RHS8+int(I,8) WRITE(IUNIT,*) id%RHS(K8) ENDDO ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_DUMP_RHS SUBROUTINE DMUMPS_BUILD_I_AM_CAND( NSLAVES, K79, & NB_NIV2, MYID_NODES, & CANDIDATES, I_AM_CAND ) IMPLICIT NONE C C Purpose: C ======= C Given a list of candidate processors per node, C returns an array of booleans telling whether the C processor is candidate or not for a given node. C C K79 holds splitting strategy (KEEP(79)). If K79>1 then C TPYE4,5,6 nodes might have been introduced and C in this case "hidden" slaves should be taken C into account to enable dynamic redistribution C of the hidden slaves while climbing the chain of C split nodes. The master of the first node in the C chain requires a special treatment and is thus here C not considered as a slave. C INTEGER, intent(in) :: NSLAVES, NB_NIV2, MYID_NODES, K79 INTEGER, intent(in) :: CANDIDATES( NSLAVES+1, NB_NIV2 ) LOGICAL, intent(out):: I_AM_CAND( NB_NIV2 ) INTEGER I, INIV2, NCAND IF (K79.GT.0) THEN C Because of potential restarting the number of C candidates that will be used to distribute C arrowheads have to include all possible candidates. DO INIV2=1, NB_NIV2 I_AM_CAND(INIV2)=.FALSE. NCAND = CANDIDATES(NSLAVES+1,INIV2) C check if some hidden slaves are there C Note that if hidden candidates exists (type 5 or 6 nodes) then C in position CANDIDATES (NCAND+1,INIV2) must be the master C of the first node in the chain (type 4) that we skip here because C a special treatment (it has to be "considered as a master" for all C nodes in the list) is needed. DO I=1, NSLAVES IF (CANDIDATES(I,INIV2).LT.0) EXIT ! end of extra slaves IF (I.EQ.NCAND+1) CYCLE ! skip master of associated TYPE 4 node IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN I_AM_CAND(INIV2)=.TRUE. EXIT ENDIF ENDDO END DO ELSE DO INIV2=1, NB_NIV2 I_AM_CAND(INIV2)=.FALSE. NCAND = CANDIDATES(NSLAVES+1,INIV2) DO I=1, NCAND IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN I_AM_CAND(INIV2)=.TRUE. EXIT ENDIF ENDDO END DO ENDIF RETURN END SUBROUTINE DMUMPS_BUILD_I_AM_CAND MUMPS_5.8.1/src/dfac_type3_symmetrize.F0000664000175000017500000001375215042446440017660 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SYMMETRIZE( BUF, BLOCK_SIZE, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, COMM ) IMPLICIT NONE INTEGER BLOCK_SIZE, NPROW, NPCOL, LOCAL_M, LOCAL_N, N, COMM INTEGER MYROW, MYCOL, MYID DOUBLE PRECISION BUF( BLOCK_SIZE * BLOCK_SIZE ) DOUBLE PRECISION A( LOCAL_M, LOCAL_N ) INTEGER NBLOCK, IBLOCK, JBLOCK, IBLOCK_SIZE, JBLOCK_SIZE INTEGER ROW_SOURCE, ROW_DEST, COL_SOURCE, COL_DEST INTEGER IGLOB, JGLOB INTEGER IROW_LOC_SOURCE, JCOL_LOC_SOURCE INTEGER IROW_LOC_DEST, JCOL_LOC_DEST INTEGER PROC_SOURCE, PROC_DEST NBLOCK = ( N - 1 ) / BLOCK_SIZE + 1 DO IBLOCK = 1, NBLOCK IF ( IBLOCK .NE. NBLOCK & ) THEN IBLOCK_SIZE = BLOCK_SIZE ELSE IBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE END IF ROW_SOURCE = mod( IBLOCK - 1, NPROW ) COL_DEST = mod( IBLOCK - 1, NPCOL ) IGLOB = ( IBLOCK - 1 ) * BLOCK_SIZE + 1 IROW_LOC_SOURCE = BLOCK_SIZE * & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 JCOL_LOC_DEST = BLOCK_SIZE * & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 DO JBLOCK = 1, IBLOCK IF ( JBLOCK .NE. NBLOCK & ) THEN JBLOCK_SIZE = BLOCK_SIZE ELSE JBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE END IF COL_SOURCE = mod( JBLOCK - 1, NPCOL ) ROW_DEST = mod( JBLOCK - 1, NPROW ) PROC_SOURCE = ROW_SOURCE * NPCOL + COL_SOURCE PROC_DEST = ROW_DEST * NPCOL + COL_DEST IF ( PROC_SOURCE .eq. PROC_DEST ) THEN IF ( MYID .eq. PROC_DEST ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 JCOL_LOC_SOURCE = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 IROW_LOC_DEST = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 IF ( IBLOCK .eq. JBLOCK ) THEN IF ( IBLOCK_SIZE .ne. JBLOCK_SIZE ) THEN WRITE(*,*) MYID,': Error in calling transdiag:unsym' CALL MUMPS_ABORT() END IF CALL DMUMPS_TRANS_DIAG( A( IROW_LOC_SOURCE, & JCOL_LOC_SOURCE), & IBLOCK_SIZE, LOCAL_M ) ELSE CALL DMUMPS_TRANSPO( & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), & A( IROW_LOC_DEST, JCOL_LOC_DEST ), & IBLOCK_SIZE, JBLOCK_SIZE, LOCAL_M ) END IF END IF ELSE IF ( MYROW .eq. ROW_SOURCE & .AND. MYCOL .eq. COL_SOURCE ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 JCOL_LOC_SOURCE = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 CALL DMUMPS_SEND_BLOCK( BUF, & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), LOCAL_M, & IBLOCK_SIZE, JBLOCK_SIZE, COMM, PROC_DEST ) ELSE IF ( MYROW .eq. ROW_DEST & .AND. MYCOL .eq. COL_DEST ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 IROW_LOC_DEST = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 CALL DMUMPS_RECV_BLOCK( BUF, & A( IROW_LOC_DEST, JCOL_LOC_DEST ), LOCAL_M, & JBLOCK_SIZE, IBLOCK_SIZE, COMM, PROC_SOURCE ) END IF END DO END DO RETURN END SUBROUTINE DMUMPS_SYMMETRIZE SUBROUTINE DMUMPS_SEND_BLOCK( BUF, A, LDA, M, N, COMM, DEST ) IMPLICIT NONE INTEGER M, N, LDA, DEST, COMM DOUBLE PRECISION BUF(*), A(LDA,*) INTEGER I, IBUF, IERR INTEGER J INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IBUF = 1 DO J = 1, N BUF( IBUF: IBUF + M - 1 ) = A( 1 : M, J ) DO I = 1, M END DO IBUF = IBUF + M END DO CALL MPI_SEND( BUF, M * N, MPI_DOUBLE_PRECISION, & DEST, SYMMETRIZE, COMM, IERR ) RETURN END SUBROUTINE DMUMPS_SEND_BLOCK SUBROUTINE DMUMPS_RECV_BLOCK( BUF, A, LDA, M, N, COMM, SOURCE ) IMPLICIT NONE INTEGER LDA, M, N, COMM, SOURCE DOUBLE PRECISION BUF(*), A( LDA, *) INTEGER I, IBUF, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) CALL MPI_RECV( BUF(1), M * N, MPI_DOUBLE_PRECISION, SOURCE, & SYMMETRIZE, COMM, STATUS, IERR ) IBUF = 1 DO I = 1, M CALL dcopy( N, BUF(IBUF), 1, A(I,1), LDA ) IBUF = IBUF + N END DO RETURN END SUBROUTINE DMUMPS_RECV_BLOCK SUBROUTINE DMUMPS_TRANS_DIAG( A, N, LDA ) IMPLICIT NONE INTEGER N,LDA DOUBLE PRECISION A( LDA, * ) INTEGER I, J DO I = 2, N DO J = 1, I - 1 A( J, I ) = A( I, J ) END DO END DO RETURN END SUBROUTINE DMUMPS_TRANS_DIAG SUBROUTINE DMUMPS_TRANSPO( A1, A2, M, N, LD ) IMPLICIT NONE INTEGER M,N,LD DOUBLE PRECISION A1( LD,* ), A2( LD, * ) INTEGER I, J DO J = 1, N DO I = 1, M A2( J, I ) = A1( I, J ) END DO END DO RETURN END SUBROUTINE DMUMPS_TRANSPO MUMPS_5.8.1/src/dsol_fwd_aux.F0000664000175000017500000012701015042446437016024 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE DMUMPS_TRAITER_MESSAGE_SOLVE & ( BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, & PTRFAC, IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, & INFO, KEEP, KEEP8, DKEEP, STEP, PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) USE DMUMPS_OOC USE DMUMPS_SOL_LR, ONLY: DMUMPS_SOL_SLAVE_LR_U USE DMUMPS_BUF IMPLICIT NONE INTEGER LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER N, NRHS, LPOOL, LEAF, NBFIN, LRHSINTR INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S( N ) INTEGER IWCB( LIWCB ) INTEGER IW( LIW ) INTEGER PTRICB(KEEP(28)),PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)) DOUBLE PRECISION WCB( LWCB ), A( LA ) DOUBLE PRECISION RHSINTR( LRHSINTR, NRHS ) INTEGER, intent(in) :: POSINRHSINTR_FWD(N) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER(8) :: PTRX, PTRY, IFR8 INTEGER IERR, K, JJ, JBDEB, JBFIN, NRHS_B INTEGER :: IWHDLR, LDA_SLAVE INTEGER :: MTYPE_SLAVE INTEGER FINODE, FPERE, LONG, NCB, POSITION, NCV, NPIV INTEGER PDEST, I, IPOSINRHSINTR INTEGER J1 INTEGER(8) :: APOS LOGICAL DUMMY LOGICAL FLAG LOGICAL :: OMP_FLAG EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR DOUBLE PRECISION ALPHA, ONE PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) INCLUDE 'mumps_headers.h' IF ( MSGTAG .EQ. RACINE_SOLVE ) THEN NBFIN = NBFIN - 1 IF ( NBFIN .eq. 0 ) GOTO 270 ELSE IF (MSGTAG .EQ. ContVec ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LONG, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 IF ( NCB .eq. 0 ) THEN PTRICB(STEP(FINODE)) = -1 ELSE IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN PTRICB(STEP(FINODE)) = NCB + 1 END IF IF ( ( POSIWCB - LONG ) .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = LONG GOTO 260 END IF IF ( POSWCB - PLEFTWCB + 1_8 .LT. & int(LONG,8) * int(NRHS_B,8)) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8+ & int(LONG,8) * int(NRHS_B,8), & INFO(2)) GOTO 260 END IF IF (LONG .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IWCB( 1 ), & LONG, MPI_INTEGER, COMM, IERR ) DO K = 1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PLEFTWCB ), & LONG, MPI_DOUBLE_PRECISION, COMM, IERR ) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1, LONG IPOSINRHSINTR= abs(POSINRHSINTR_FWD(IWCB(I))) RHSINTR(IPOSINRHSINTR,JBDEB+K-1) = & RHSINTR(IPOSINRHSINTR,JBDEB+K-1) + & WCB(PLEFTWCB+I-1) ENDDO END DO PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - LONG ENDIF END IF IF ( PTRICB(STEP(FINODE)) == 1 .OR. & PTRICB(STEP(FINODE)) == -1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 PTRICB(STEP(FINODE)) = 0 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) & 'Internal error 1 DMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() END IF ENDIF ELSEIF ( MSGTAG .EQ. Master2Slave ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPIV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 PTRY = PLEFTWCB PTRX = PLEFTWCB + int(NCV,8) * int(NRHS_B,8) PLEFTWCB = PLEFTWCB + int(NPIV + NCV,8) * int(NRHS_B,8) IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(-POSWCB+PLEFTWCB-1_8,INFO(2)) GO TO 260 END IF DO K=1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PTRY + (K-1) * NCV ), NCV, & MPI_DOUBLE_PRECISION, COMM, IERR ) ENDDO IF ( NPIV .GT. 0 ) THEN DO K=1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PTRX + (K-1)*NPIV ), NPIV, & MPI_DOUBLE_PRECISION, COMM, IERR ) END DO END IF LR_ACTIVATED = (IW(PTRIST(STEP(FINODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(FINODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_SOLVE_GET_OOC_NODE( & FINODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,DUMMY,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF IF ( IW(PTRIST(STEP(FINODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(FINODE))+XXF) MTYPE_SLAVE = 1 CALL DMUMPS_SOL_SLAVE_LR_U( FINODE, IWHDLR, & -9999, & WCB, LWCB, & NPIV, NCV, & PTRX, PTRY, & JBDEB, JBFIN, & MTYPE_SLAVE, KEEP, KEEP8, & INFO(1), INFO(2) ) ELSE APOS = PTRFAC(STEP(FINODE)) IF (KEEP(201) .EQ. 1) THEN MTYPE_SLAVE = 0 LDA_SLAVE = NCV ELSE MTYPE_SLAVE = 1 LDA_SLAVE = NPIV ENDIF CALL DMUMPS_SOLVE_GEMM_UPDATE & ( A, LA, APOS, NPIV, & LDA_SLAVE, & NCV, & NRHS_B, WCB, LWCB, & PTRX, NPIV, & PTRY, NCV, & MTYPE_SLAVE, KEEP, ONE ) ENDIF IF ((KEEP(201).GT.0).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(FINODE,PTRFAC, & KEEP(28),A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF PLEFTWCB = PLEFTWCB - int(NPIV,8) * int(NRHS_B,8) PDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & KEEP(199) ) IF ( PDEST .EQ. MYID ) THEN IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN NCB = IW( PTRIST(STEP(FINODE)) + 2 + KEEP(IXSZ) ) PTRICB(STEP(FINODE)) = NCB + 1 END IF J1 = PTRIST(STEP(FINODE))+3+KEEP(IXSZ) OMP_FLAG = .FALSE. !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (NCV*(JBFIN-JBDEB+1) .GE. KEEP(363) ) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(I,JJ,IFR8,IPOSINRHSINTR) DO K=1, NRHS_B IFR8 = PTRY+int(K-1,8)*int(NCV,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1,NCV JJ = IW(J1+I) IPOSINRHSINTR= abs(POSINRHSINTR_FWD(JJ)) RHSINTR(IPOSINRHSINTR,JBDEB+K-1)= & RHSINTR(IPOSINRHSINTR,JBDEB+K-1) & + WCB(IFR8+int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K=1, NRHS_B IFR8 = PTRY+int(K-1,8)*int(NCV,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1,NCV JJ = IW(J1+I) IPOSINRHSINTR= abs(POSINRHSINTR_FWD(JJ)) RHSINTR(IPOSINRHSINTR,JBDEB+K-1)= & RHSINTR(IPOSINRHSINTR,JBDEB+K-1) & + WCB(IFR8+int(I-1,8)) ENDDO ENDDO ENDIF PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - NCV IF ( PTRICB( STEP( FINODE ) ) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 PTRICB(STEP(FINODE)) = 0 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) & 'INTERNAL Error in DMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() END IF ENDIF ELSE 210 CONTINUE CALL DMUMPS_BUF_SEND_VCB( NRHS_B, FINODE, FPERE, & IW(PTRIST(STEP( FINODE )) + 2 + KEEP(IXSZ) ), NCV,NCV, & IW(PTRIST(STEP(FINODE))+4+ KEEP(IXSZ) ), & WCB( PTRY ), JBDEB, JBFIN, & RHSINTR, 1, 1, -9999, -9999, & KEEP, PDEST, ContVec, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 210 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + & NCV * KEEP( 35 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + & NCV * KEEP( 35 ) END IF END IF PLEFTWCB = PLEFTWCB - int(NCV,8) * int(NRHS_B,8) ELSEIF ( MSGTAG .EQ. TERREUR ) THEN INFO(1) = -001 INFO(2) = MSGSOU GOTO 270 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. & (MSGTAG.EQ.TAG_DUMMY) ) THEN GO TO 270 ELSE INFO(1)=-100 INFO(2)=MSGTAG GO TO 260 ENDIF GO TO 270 260 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 270 CONTINUE RETURN END SUBROUTINE DMUMPS_TRAITER_MESSAGE_SOLVE SUBROUTINE DMUMPS_SOLVE_NODE_FWD( INODE, & LASTFSL0STA, LASTFSL0DYN, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, & IWCB, LIWCB, & WCB, LWCB, A, LA, IW, LIW, & NRHS, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & ) USE DMUMPS_SOL_LR !$ USE MUMPS_SOL_L0OMP_M, ONLY: LOCK_FOR_SCATTER USE MUMPS_SOL_L0OMP_M, ONLY: NB_LOCK_MAX USE DMUMPS_OOC USE DMUMPS_BUF IMPLICIT NONE INTEGER MTYPE INTEGER, INTENT( IN ) :: INODE, LASTFSL0STA, LASTFSL0DYN INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER LIWCB, LIW, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB, LWCB INTEGER(8) :: LA INTEGER N, LPOOL, LEAF, NBFIN INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S(KEEP(28)) INTEGER IWCB( LIWCB ), IW( LIW ) INTEGER NRHS DOUBLE PRECISION WCB( LWCB ) DOUBLE PRECISION :: A( LA ) INTEGER(8) :: LRHS_ROOT DOUBLE PRECISION RHS_ROOT( LRHS_ROOT ) INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER FILS( N ), STEP( N ), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSINRHSINTR_FWD(N), LRHSINTR DOUBLE PRECISION RHSINTR(LRHSINTR, NRHS) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP LOGICAL, intent(out) :: ERROR_WAS_BROADCASTED EXTERNAL dgemv, dtrsv, dgemm, dtrsm, MUMPS_PROCNODE INTEGER MUMPS_PROCNODE DOUBLE PRECISION ALPHA,ONE,ZERO PARAMETER (ZERO=0.0D0, ONE = 1.0D0, ALPHA=-1.0D0) INTEGER :: IWHDLR INTEGER JBDEB, JBFIN, NRHS_B INTEGER LDADIAG INTEGER(8) :: APOS, APOS1, IFR8, IFR_ini8 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, FPERE_MAPPING, & NPIV, NCB, LIELL, JJ, NELIM, IERR INTEGER(8) :: PCB_COURANT, PPIV_COURANT, PPIV_PANEL, PCB_PANEL INTEGER IPOSINRHSINTR_TMP INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex LOGICAL FLAG INTEGER :: NUPDATE_NONCRITICAL, IPOSINRHSINTRLASTFSDYN LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSDEB INTEGER TempNROW, TempNCOL, PANEL_SIZE, & JFIN, NBJ, NUPDATE_PANEL, & TYPEF INTEGER LD_WCBPIV INTEGER LD_WCBCB LOGICAL :: LDEQLIELLPANEL LOGICAL :: CBINITZERO INTEGER LDAJ, LDAJ_FIRST_PANEL INTEGER LDAtemp LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPANEL LOGICAL MUST_BE_PERMUTED INTEGER :: SIZEBLOCK, NB, JCourant, NB_LOCK INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' ERROR_WAS_BROADCASTED = .FALSE. LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IF (DO_NBSPARSE) THEN JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) JBFIN= RHS_BOUNDS(2*STEP(INODE)) ELSE JBDEB = 1 JBFIN = NRHS ENDIF NRHS_B = JBFIN-JBDEB+1 IF (DO_NBSPARSE) THEN if (JBDEB.GT.JBFIN) then write(6,*) " Internal error 1 in nbsparse :", & JBDEB, JBFIN CALL MUMPS_ABORT() endif IF (JBDEB.LT.1 .OR. JBDEB.GT.NRHS .or. & JBFIN.LT.1 .OR. JBFIN.GT.NRHS ) THEN write(6,*) " Internal error 2 in nbsparse :", & JBDEB, JBFIN CALL MUMPS_ABORT() endif ENDIF IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq.KEEP( 20 ) ) THEN LIELL = IW( PTRIST( STEP(INODE)) + 3 + KEEP(IXSZ)) NPIV = LIELL NELIM = 0 NSLAVES = 0 IPOS = PTRIST( STEP(INODE)) + 5 + KEEP(IXSZ) ELSE IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 NPIV = IW(IPOS) IPOS = IPOS + 1 IF ((KEEP(201).GT.0).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL DMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL+1+NSLAVES), & MUST_BE_PERMUTED ) ENDIF ENDIF NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IPOS = IPOS + 1 + NSLAVES END IF IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J2 = IPOS + LIELL J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J2 = IPOS + 2 * LIELL J3 = IPOS + LIELL + NPIV END IF NCB = LIELL-NPIV IF (KEEP(50).NE.0) THEN IF ( KEEP(459) .GT. 1 ) THEN LDADIAG = -99999 ELSE LDADIAG = NPIV ENDIF ELSE LDADIAG = LIELL ENDIF IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq. KEEP(20) ) THEN IFR8 = 0_8 IPOSINRHSINTR_TMP = POSINRHSINTR_FWD(IW(J1)) IFR_ini8 = IFR8 OMP_FLAG = .FALSE. !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(IFR8,JJ) DO K=1,NRHS IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 RHS_ROOT(IFR8+int(JJ-J1+1,8)) = & RHSINTR(IPOSINRHSINTR_TMP+JJ-J1,K) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K=1,NRHS IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 RHS_ROOT(IFR8+int(JJ-J1+1,8)) = & RHSINTR(IPOSINRHSINTR_TMP+JJ-J1,K) ENDDO ENDDO ENDIF IF ( NPIV .LT. LIELL ) THEN WRITE(*,*) ' Internal error 1 in DMUMPS_SOLVE_NODE_FWD', & NPIV, LIELL CALL MUMPS_ABORT() END IF GO TO 270 END IF APOS = PTRFAC(STEP(INODE)) IF ( (KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR ) THEN IF (MTYPE.EQ.1) THEN IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN TempNROW= NPIV+NELIM TempNCOL= NPIV LDAJ_FIRST_PANEL=TempNROW ELSE TempNROW= LIELL TempNCOL= NPIV LDAJ_FIRST_PANEL=TempNROW ENDIF TYPEF=TYPEF_L ELSE TempNCOL= LIELL TempNROW= NPIV LDAJ_FIRST_PANEL=TempNCOL TYPEF= TYPEF_U ENDIF PANEL_SIZE = DMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) ENDIF PPIV_COURANT = PLEFTWCB PLEFTWCB = PLEFTWCB + int(LIELL,8) * int(NRHS_B,8) IF ( POSWCB - PLEFTWCB + 1_8 .LT. 0 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8, INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF IF (KEEP(201) .EQ. 1 .AND. OOCWRITE_COMPATIBLE_WITH_BLR) THEN LDEQLIELLPANEL = .TRUE. LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV ELSE LDEQLIELLPANEL = .FALSE. LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + int(NPIV,8)*int(NRHS_B,8) ENDIF FPERE = DAD(STEP(INODE)) IF ( FPERE .NE. 0 ) THEN FPERE_MAPPING = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & KEEP(199) ) ELSE FPERE_MAPPING = -1 ENDIF IF ( LASTFSL0DYN .LE. N ) THEN CBINITZERO = .TRUE. ELSE IF ( FPERE_MAPPING .EQ. MYID ) THEN CBINITZERO = .TRUE. ELSE CBINITZERO = .FALSE. ENDIF CALL DMUMPS_RHSINTR_TO_WCB( & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL, & RHSINTR(1, JBDEB), LRHSINTR, NRHS_B, & POSINRHSINTR_FWD, N, & WCB(PPIV_COURANT), & IW, LIW, J1, J3, J2, KEEP, DKEEP) IF ( NPIV .NE. 0 ) THEN IF ((KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN APOSDEB = APOS J = 1 IPANEL = 0 10 CONTINUE IPANEL = IPANEL + 1 JFIN = min(J+PANEL_SIZE-1, NPIV) IF (IW(IPOS+ LIELL + JFIN) < 0) THEN JFIN=JFIN+1 ENDIF NBJ = JFIN-J+1 LDAJ = LDAJ_FIRST_PANEL-J+1 IF ( (KEEP(50).NE.1).AND. MUST_BE_PERMUTED ) THEN CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS+1+2*LIELL, IW, LIW) IF (NPIV.EQ.(IW(I_PIVRPTR+IPANEL-1)-1)) THEN MUST_BE_PERMUTED=.FALSE. ELSE CALL DMUMPS_PERMUTE_PANEL( & IW( I_PIVR+ IW(I_PIVRPTR+IPANEL-1)- & IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, J-1 ) ENDIF ENDIF NUPDATE_PANEL = LDAJ - NBJ PPIV_PANEL = PPIV_COURANT+int(J-1,8) PCB_PANEL = PPIV_PANEL+int(NBJ,8) APOS1 = APOSDEB+int(NBJ,8) IF (MTYPE.EQ.1) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dtrsv( 'L', 'N', 'U', NBJ, A(APOSDEB), LDAJ, & WCB(PPIV_PANEL), 1 ) IF (NUPDATE_PANEL.GT.0) THEN CALL dgemv('N', NUPDATE_PANEL,NBJ,ALPHA, A(APOS1), & LDAJ, WCB(PPIV_PANEL), 1, ONE, & WCB(PCB_PANEL), 1) ENDIF ELSE #endif CALL dtrsm( 'L','L','N','U', NBJ, NRHS_B, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL ) IF (NUPDATE_PANEL.GT.0) THEN CALL dgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF (NRHS_B == 1) THEN CALL dtrsv( 'L', 'N', 'N', NBJ, A(APOSDEB), LDAJ, & WCB(PPIV_PANEL), 1 ) IF (NUPDATE_PANEL.GT.0) THEN CALL dgemv('N',NUPDATE_PANEL, NBJ, ALPHA, A(APOS1), & LDAJ, WCB(PPIV_PANEL), 1, & ONE, WCB(PCB_PANEL), 1 ) ENDIF ELSE #endif CALL dtrsm('L','L','N','N',NBJ, NRHS_B, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL) IF (NUPDATE_PANEL.GT.0) THEN CALL dgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF APOSDEB = APOSDEB+int(LDAJ,8)*int(NBJ,8) J=JFIN+1 IF ( J .LE. NPIV ) GOTO 10 ELSE IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL DMUMPS_SOL_FWD_LR_SU ( & INODE, N, IWHDLR, NPIV, NSLAVES, & IW, IPOS, LIW, & LIELL, WCB, LWCB, & LD_WCBPIV, LD_WCBCB, & PPIV_COURANT, PCB_COURANT, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, KEEP8, OOCWRITE_COMPATIBLE_WITH_BLR, & INFO(1), INFO(2) ) IF (INFO(1).LT.0) THEN ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF ELSE IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 ) THEN CALL DMUMPS_SOLVE_FWD_PANELS( & A, LA, APOS, & NPIV, IW(IPOS+LIELL+1), & NRHS_B, WCB, LWCB, LD_WCBPIV, & PPIV_COURANT, MTYPE, KEEP) ELSE CALL DMUMPS_SOLVE_FWD_TRSOLVE ( & A, LA, APOS, & NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LD_WCBPIV, & PPIV_COURANT, MTYPE, KEEP) ENDIF END IF END IF NCB = LIELL - NPIV IF ( MTYPE .EQ. 1 ) THEN IF ( NSLAVES .EQ. 0 .OR. NPIV .eq. 0 ) THEN NUPDATE = NCB ELSE NUPDATE = NELIM END IF IF (KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0) THEN CALL MUMPS_GETI8(APOS1, IW(PTRIST(STEP(INODE))+XXR)) APOS1 = APOS + APOS1 - int(NPIV,8)*int(NUPDATE,8) ELSE APOS1 = APOS + int(NPIV,8) * int(LDADIAG,8) ENDIF ELSE APOS1 = APOS + int(NPIV,8) NUPDATE = NCB END IF IF (KEEP(201).NE.1) THEN IF ( IW(PTRIST(STEP(INODE))+XXLR) .LT. 2 .OR. & KEEP(485).EQ.0) THEN IF (MTYPE .EQ. 1) THEN LDAtemp = NPIV ELSE LDAtemp = LIELL ENDIF CALL DMUMPS_SOLVE_GEMM_UPDATE & (A, LA, APOS1, & NPIV, LDAtemp, NUPDATE, & NRHS_B, WCB, LWCB, PPIV_COURANT, LD_WCBPIV, & PCB_COURANT, LD_WCBCB, & MTYPE, KEEP, ONE) ENDIF END IF IF ( IW(PTRIST(STEP(INODE))+XXLR) .LT. 2 .OR. & KEEP(485).EQ.0) THEN IF (KEEP(201) .GT. 0 .AND. OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_SOL_LD_AND_RELOAD( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & .FALSE. & ) ELSE CALL DMUMPS_SOL_LD_AND_RELOAD_PANEL ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & .FALSE. & ) ENDIF ENDIF IF ((KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR) &THEN CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF END IF IF ( FPERE .EQ. 0 ) THEN PLEFTWCB = PLEFTWCB - int(LIELL,8) *int(NRHS_B,8) GOTO 270 ENDIF IF ( NUPDATE .NE. 0 .OR. NCB.EQ.0 ) THEN IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID) THEN IF ( NCB .ne. 0 ) THEN PTRICB(STEP(INODE)) = NCB + 1 NUPDATE_NONCRITICAL = NUPDATE IF (LASTFSL0DYN .LE. N) THEN IF ( LASTFSL0DYN .EQ. 0 ) THEN IPOSINRHSINTRLASTFSDYN = 0 ELSE IPOSINRHSINTRLASTFSDYN = & abs(POSINRHSINTR_FWD(LASTFSL0DYN)) ENDIF DO I = 1, NUPDATE IF ( abs(POSINRHSINTR_FWD( IW(J3+I) )) .GT. & IPOSINRHSINTRLASTFSDYN ) THEN IF (abs(STEP(IW(J3+I))) .GT. & abs(STEP( LASTFSL0STA)) & .OR. KEEP(261) .NE. 1) THEN NUPDATE_NONCRITICAL = I - 1 EXIT ENDIF ENDIF ENDDO ENDIF OMP_FLAG = .FALSE. !$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND. !$ & (NUPDATE*NRHS_B .GE. KEEP(363)) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(I,IFR8,IPOSINRHSINTR_TMP) DO K = JBDEB, JBFIN IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1, NUPDATE_NONCRITICAL IPOSINRHSINTR_TMP = & abs(POSINRHSINTR_FWD(IW(J3 + I))) RHSINTR( IPOSINRHSINTR_TMP, K ) = & RHSINTR( IPOSINRHSINTR_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K = JBDEB, JBFIN IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1, NUPDATE_NONCRITICAL IPOSINRHSINTR_TMP = & abs(POSINRHSINTR_FWD(IW(J3 + I))) RHSINTR( IPOSINRHSINTR_TMP, K ) = & RHSINTR( IPOSINRHSINTR_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO ENDIF IF ( CBINITZERO ) THEN IF ( NUPDATE .NE. NUPDATE_NONCRITICAL) THEN NB_LOCK = 1 IF ( KEEP(400) .GT. 1 ) THEN NB_LOCK = min(KEEP(400),NB_LOCK_MAX) ENDIF SIZEBLOCK = (NRHS+NB_LOCK-1) / NB_LOCK DO NB = 1 + (JBDEB-1)/SIZEBLOCK, NB_LOCK JCourant = 1+SIZEBLOCK*(NB-1) IF ( JCourant .GT. JBFIN ) EXIT !$ CALL OMP_SET_LOCK(LOCK_FOR_SCATTER(NB)) DO K = max(Jcourant,JBDEB), & min(JBFIN,Jcourant+SIZEBLOCK-1) IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = NUPDATE_NONCRITICAL+1, NUPDATE IPOSINRHSINTR_TMP = & abs(POSINRHSINTR_FWD(IW(J3 + I))) RHSINTR( IPOSINRHSINTR_TMP, K ) = & RHSINTR( IPOSINRHSINTR_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO !$ CALL OMP_UNSET_LOCK(LOCK_FOR_SCATTER(NB)) ENDDO ENDIF ENDIF PTRICB(STEP( INODE )) = PTRICB(STEP( INODE )) - NUPDATE ELSE PTRICB(STEP( INODE )) = -1 ENDIF ELSE 210 CONTINUE CALL DMUMPS_BUF_SEND_VCB( NRHS_B, INODE, FPERE, & NCB, LD_WCBCB, & NUPDATE, & IW( J3 + 1 ), WCB( PCB_COURANT ), JBDEB, JBFIN, & RHSINTR, 1, 1, -9999, -9999, & KEEP, & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), KEEP(199)), & ContVec, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. GOTO 270 ENDIF GOTO 210 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF ENDIF END IF IF ( NSLAVES .NE. 0 .AND. MTYPE .eq. 1 & .and. NPIV .NE. 0 ) THEN DO ISLAVE = 1, NSLAVES PDEST = IW( PTRIST(STEP(INODE)) + 5 + ISLAVE +KEEP(IXSZ)) CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB - NELIM, & NSLAVES, & Effective_CB_Size, FirstIndex ) 222 CONTINUE CALL DMUMPS_BUF_SEND_MASTER2SLAVE( NRHS_B, & INODE, FPERE, & Effective_CB_Size, LD_WCBCB, LD_WCBPIV, NPIV, & JBDEB, JBFIN, & WCB( PCB_COURANT + NELIM + FirstIndex - 1 ), & WCB( PPIV_COURANT ), & PDEST, COMM, KEEP, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. GOTO 270 ENDIF GOTO 222 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF END DO END IF PLEFTWCB = PLEFTWCB - int(LIELL,8)*int(NRHS_B,8) 270 CONTINUE RETURN END SUBROUTINE DMUMPS_SOLVE_NODE_FWD RECURSIVE SUBROUTINE DMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) IMPLICIT NONE LOGICAL BLOQ INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER N, NRHS, LPOOL, LEAF, NBFIN INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ), IPOOL(LPOOL) INTEGER NSTK_S( KEEP(28) ) INTEGER IWCB( LIWCB ) INTEGER IW( LIW ) DOUBLE PRECISION WCB( LWCB ), A( LA ) INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)) LOGICAL FLAG INTEGER LRHSINTR, POSINRHSINTR_FWD(N) DOUBLE PRECISION RHSINTR(LRHSINTR,NRHS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGSOU, MSGTAG, MSGLEN FLAG = .FALSE. IF ( BLOQ ) THEN FLAG = .FALSE. CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF ( FLAG ) THEN KEEP(266) = KEEP(266) -1 MSGSOU = STATUS( MPI_SOURCE ) MSGTAG = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN INFO(1) = -20 INFO(2) = MSGLEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ELSE CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, & MSGSOU, MSGTAG, COMM, STATUS, IERR ) CALL DMUMPS_TRAITER_MESSAGE_SOLVE( BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) END IF END IF RETURN END SUBROUTINE DMUMPS_SOLVE_RECV_AND_TREAT SUBROUTINE DMUMPS_RHSINTR_TO_WCB( & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL, & RHSINTR, LRHSINTR, NRHS_B, & POSINRHSINTR_FWD, N, & WCB, & IW, LIW, J1, J3, J2, KEEP, DKEEP) IMPLICIT NONE INTEGER, INTENT( IN ) :: NPIV, NCB, LIELL, N, & LRHSINTR, NRHS_B, & LIW, J1, J2, J3 LOGICAL, INTENT( IN ) :: LDEQLIELLPANEL LOGICAL, INTENT( IN ) :: CBINITZERO INTEGER, INTENT( IN ) :: POSINRHSINTR_FWD( N ), IW( LIW ) DOUBLE PRECISION, INTENT( INOUT ) :: RHSINTR( LRHSINTR, NRHS_B ) DOUBLE PRECISION, INTENT( OUT ) :: WCB( int(LIELL,8)* & int(NRHS_B,8) ) INTEGER :: KEEP(500) DOUBLE PRECISION :: DKEEP(150) INTEGER, PARAMETER :: ZERO = 0.0D0 INTEGER(8), PARAMETER :: PPIV_COURANT = 1_8 INTEGER(8) :: PCB_COURANT INTEGER :: LD_WCBCB, LD_WCBPIV, J, JJ, K, IPOSINRHSINTR INTEGER(8) :: IFR8, IFR_ini8 INCLUDE 'mpif.h' LOGICAL :: OMP_FLAG IF ( LDEQLIELLPANEL ) THEN LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV ELSE LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + NPIV * NRHS_B ENDIF IF ( LDEQLIELLPANEL ) THEN DO K=1, NRHS_B IFR8 = PPIV_COURANT+int(K-1,8)*int(LD_WCBPIV,8)-1_8 IPOSINRHSINTR = POSINRHSINTR_FWD(IW(J1)) DO JJ = J1, J3 IFR8 = IFR8 + 1_8 WCB(IFR8) = RHSINTR(IPOSINRHSINTR,K) IPOSINRHSINTR = IPOSINRHSINTR + 1 ENDDO IF (NCB.GT.0 .AND. .NOT. CBINITZERO) THEN #if defined(__ve__) !NEC$ IVDEP #endif DO JJ = J3+1, J2 J = IW(JJ) IFR8 = IFR8 + 1_8 IPOSINRHSINTR = abs(POSINRHSINTR_FWD(J)) WCB(IFR8) = RHSINTR(IPOSINRHSINTR,K) RHSINTR (IPOSINRHSINTR,K) = ZERO ENDDO ENDIF ENDDO ELSE PCB_COURANT = PPIV_COURANT + LD_WCBPIV*NRHS_B IFR8 = PPIV_COURANT - 1_8 IFR_ini8 = IFR8 IPOSINRHSINTR = POSINRHSINTR_FWD(IW(J1)) OMP_FLAG = .FALSE. !$ OMP_FLAG = ( NRHS_B .GE. KEEP(362) .AND. !$ & int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(JJ,IFR8) DO K=1, NRHS_B IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 WCB(IFR8+int(JJ-J1+1,8)) = & RHSINTR(IPOSINRHSINTR+JJ-J1,K) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K=1, NRHS_B IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 WCB(IFR8+int(JJ-J1+1,8)) = & RHSINTR(IPOSINRHSINTR+JJ-J1,K) ENDDO ENDDO ENDIF IFR8 = PCB_COURANT - 1_8 IF (NCB.GT.0 .AND. .NOT. CBINITZERO) THEN IFR_ini8 = IFR8 OMP_FLAG = .FALSE. !$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND. !$ & NCB*NRHS_B .GE. KEEP(363) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE (IFR8, JJ, J, IPOSINRHSINTR) DO K=1, NRHS_B IFR8 = IFR_ini8+(K-1)*NCB #if defined(__ve__) !NEC$ IVDEP #endif DO JJ = J3 + 1, J2 J = IW(JJ) IPOSINRHSINTR = abs(POSINRHSINTR_FWD(J)) WCB(IFR8+int(JJ-J3,8)) = RHSINTR(IPOSINRHSINTR,K) RHSINTR(IPOSINRHSINTR,K)=ZERO ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K=1, NRHS_B IFR8 = IFR_ini8+(K-1)*NCB #if defined(__ve__) !NEC$ IVDEP #endif DO JJ = J3 + 1, J2 J = IW(JJ) IPOSINRHSINTR = abs(POSINRHSINTR_FWD(J)) WCB(IFR8+int(JJ-J3,8)) = RHSINTR(IPOSINRHSINTR,K) RHSINTR(IPOSINRHSINTR,K)=ZERO ENDDO ENDDO ENDIF ENDIF ENDIF IF ( CBINITZERO ) THEN OMP_FLAG = .FALSE. !$ OMP_FLAG = int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) IF (OMP_FLAG) THEN !$OMP PARALLEL DO COLLAPSE(2) DO K = 1, NRHS_B DO JJ = 1, NCB WCB(PCB_COURANT+int(K-1,8)*int(LD_WCBCB,8)+JJ-1_8) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K = 1, NRHS_B DO JJ = 1, NCB WCB(PCB_COURANT+int(K-1,8)*int(LD_WCBCB,8)+JJ-1_8) = ZERO ENDDO ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_RHSINTR_TO_WCB MUMPS_5.8.1/src/mumps_scotch_int.c0000664000175000017500000000142515042446422016754 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mumps_scotch_int.h" #if defined(scotch) || defined(ptscotch) # include # include "scotch.h" #endif void MUMPS_CALL MUMPS_SCOTCH_INTSIZE(MUMPS_INT *scotch_intsize) { # if defined(scotch) || defined(ptscotch) *scotch_intsize=8*sizeof(SCOTCH_Num); # else *scotch_intsize=-99999; # endif } MUMPS_5.8.1/src/mumps_int_def32_h.in0000664000175000017500000000140615042446422017066 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #if ! defined(MUMPS_INT_H) # define MUMPS_INT_H /* MUMPS has been configured without -DINTSIZE64: * both 32-bit and 64-bit integers are used, depending on usage * (e.g., the order of a matrix, N, is a 32-bit integer, and the * number of nonzeros, NNZ, is a 64-bit integers) */ # define MUMPS_INTSIZE32 #endif MUMPS_5.8.1/src/zana_aux_ELT.F0000664000175000017500000011300215042446441015647 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ANA_F_ELT(N, NELT, ELTPTR, ELTVAR, LIW, & IKEEP, & IORD, NFSIZ, FILS, FRERE, & LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, & NSLAVES, & XNODEL, NODEL #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , METIS_OPTIONS #endif & ) USE MUMPS_ANA_ORD_WRAPPERS IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, SIZE_SCHUR, NSLAVES INTEGER(8), INTENT(IN) :: LIW INTEGER, INTENT(IN) :: ELTPTR(NELT+1) INTEGER, INTENT(IN) :: ELTVAR(ELTPTR(NELT+1)-1) INTEGER, INTENT(IN) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: IKEEP(N,3) INTEGER, INTENT(INOUT) :: INFO(80), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(OUT) :: NFSIZ(N), FILS(N), FRERE(N) INTEGER, INTENT(OUT) :: XNODEL(N+1), NODEL(ELTPTR(NELT+1)-1) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER, INTENT(IN) :: METIS_OPTIONS(40) #endif INTEGER K,I,NCMPA,IFSON,IN INTEGER(8) :: L1, L2 INTEGER NEMIN, MPRINT, LP, MP, LDIAG INTEGER(8) :: NZ8, LLIW8, IWFR8 INTEGER allocok, ITEMP LOGICAL PROK, NOSUPERVAR, LPOK INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) LOGICAL SPLITROOT INTEGER HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & NBSONS_Scalapack_CAND INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER :: IDUMMY(1) INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER, DIMENSION(:), ALLOCATABLE :: IW2 INTEGER, DIMENSION(:), ALLOCATABLE :: PARENT INTEGER, DIMENSION(:,:), ALLOCATABLE :: IWtemp INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE8 #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) INTEGER :: NUMFLAG #else INTEGER, DIMENSION(:), ALLOCATABLE :: NUMFLAG #endif INTEGER :: OPT_METIS_SIZE, METIS_IDX_SIZE INTEGER :: IERR #endif INTEGER IDUM EXTERNAL ZMUMPS_ANA_G11_ELT, ZMUMPS_ANA_G12_ELT, & ZMUMPS_ANA_G1_ELT, ZMUMPS_ANA_G2_ELT, & ZMUMPS_ANA_G2_ELTNEW, & ZMUMPS_ANA_J1_ELT, ZMUMPS_ANA_J2_ELT, & ZMUMPS_ANA_K, & ZMUMPS_ANA_LNEW, ZMUMPS_ANA_M, & MUMPS_AMD_ELT ALLOCATE( IW ( LIW ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(LIW, INFO( 2 )) GOTO 90 ENDIF ALLOCATE( IPE8 ( N + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (N+1)*KEEP(10) GOTO 90 ENDIF ALLOCATE( PARENT(N), IWtemp ( N, 3 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(4_8*int(N,8), INFO( 2 )) GOTO 90 ENDIF MPRINT= ICNTL(3) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MP = ICNTL(3) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) LDIAG = ICNTL(4) IF (KEEP(60).NE.0) THEN NOSUPERVAR=.TRUE. IF (IORD.GT.1) IORD = 0 ELSE NOSUPERVAR=.FALSE. ENDIF IF (IORD == 7) THEN IF ( N < 10000 ) THEN IORD = 0 ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IORD = 5 #else IORD = 0 #endif ENDIF END IF #if ! defined(metis) && ! defined(parmetis) && ! defined(metis4) && ! defined(parmetis3) IF (IORD == 5) IORD = 0 #endif IF (KEEP(1).LT.1) KEEP(1) = 1 NEMIN = KEEP(1) IF (LDIAG.LE.2 .OR. MP.LE.0) GO TO 10 WRITE (MP,99999) N, NELT, LIW, INFO(1) K = min(10,NELT+1) IF (LDIAG.EQ.4) K = NELT+1 IF (K.GT.0) WRITE (MP,99998) (ELTPTR(I),I=1,K) K = min(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 = min(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_8 L2 = L1 + int(N,8) IF (LIW .LT. 3_8*int(N,8)) THEN INFO(1) = -2002 CALL MUMPS_SET_IERROR( LIW, INFO(2) ) ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF ( IORD == 5 ) THEN IF (LIW .LT. int(N,8)+int(N,8)+1_8) THEN INFO(1)= -2002 CALL MUMPS_SET_IERROR( LIW, INFO(2) ) GOTO 90 ENDIF ELSE #endif IF (NOSUPERVAR) THEN IF ( LIW .LT. 2_8*int(N,8) ) THEN INFO(1)= -2002 CALL MUMPS_SET_IERROR( LIW, INFO(2) ) GOTO 90 END IF ELSE IF ( LIW .LT. 4_8*int(N,8)+4_8 ) THEN INFO(1)= -2002 CALL MUMPS_SET_IERROR( LIW, INFO(2) ) GOTO 90 END IF ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif IDUM=0 CALL ZMUMPS_NODEL(NELT, N, ELTPTR(NELT+1)-1, ELTPTR, ELTVAR, & XNODEL, NODEL, IW(L1), IDUM, ICNTL) IF (IORD.NE.1 .AND. IORD .NE. 5) THEN IORD = 0 IF (NOSUPERVAR) THEN CALL ZMUMPS_ANA_G1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), IW(L1)) ELSE CALL ZMUMPS_ANA_G11_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), 4_8*int(N,8)+4_8, IW(L1)) ENDIF LLIW8 = max(NZ8,int(N,8)) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8, INFO(2)) GOTO 90 ENDIF IF (NOSUPERVAR) THEN CALL ZMUMPS_ANA_G2_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) ELSE CALL ZMUMPS_ANA_G12_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) ENDIF IF (NOSUPERVAR) THEN CALL MUMPS_HAMD(N, LLIW8, IPE8, IWFR8, IWtemp(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), IWtemp(1,3), & IWtemp, & LISTVAR_SCHUR, SIZE_SCHUR) IF (KEEP(60) == 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSEIF (KEEP(60) == 2 .OR. KEEP(60) == 3 ) THEN KEEP(38) = LISTVAR_SCHUR(1) ELSE WRITE(*,*) "Internal error in ZMUMPS_ANA_F_ELT",KEEP(60) CALL MUMPS_ABORT() ENDIF ELSE CALL MUMPS_AMD_ELT(N, LLIW8, IPE8, IWFR8, IWtemp(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), IWtemp(1,3), & IWtemp) ENDIF ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MPRINT,'(A)') ' Ordering based on METIS' ENDIF CALL ZMUMPS_ANA_G1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), IW(L1)) LLIW8 = max(NZ8,int(N,8)) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8, INFO(2)) GOTO 90 ENDIF CALL ZMUMPS_ANA_G2_ELTNEW(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) #if defined(metis4) || defined(parmetis3) NUMFLAG = 1 OPT_METIS_SIZE = 8 #else ALLOCATE( NUMFLAG ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF DO I=1,N NUMFLAG(I) = 1 ENDDO OPT_METIS_SIZE = 40 #endif CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN INFO(1) = -52 INFO(2) = 1 GOTO 90 ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32(N, IPE8, IW2, #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG, #endif & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP(1:N,2), IKEEP(1:N,1), INFO(1), LP, LPOK) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64(N, IPE8, IW2, #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG, #endif & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP(1:N,2), IKEEP(1:N,1), INFO(1), & LP, LPOK, KEEP(10), & LLIW8, .FALSE., .TRUE. ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF IF (INFO(1) .LT. 0) GOTO 90 DEALLOCATE(IW2) ELSE IF (IORD.NE.1) THEN WRITE(*,*) IORD WRITE(*,*) 'bad option for ordering' CALL MUMPS_ABORT() ENDIF #endif DO K=1,N IW(L1+int(K,8)) = 0 ENDDO DO K=1,N IF ((IKEEP(K,1).LE.0).OR.(IKEEP(K,1).GT.N)) & GO TO 40 IF (IW(L1+int(IKEEP(K,1),8)).EQ.1) THEN GOTO 40 ELSE IW(L1+int(IKEEP(K,1),8)) = 1 ENDIF ENDDO CALL ZMUMPS_ANA_J1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IWtemp(1,2), IW(L1)) LLIW8 = NZ8+int(N,8) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8,INFO(2)) GOTO 90 ENDIF CALL ZMUMPS_ANA_J2_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) IF (KEEP(60) == 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR IF (KEEP(60) == 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSEIF (KEEP(60) == 2 .OR. KEEP(60) == 3 ) THEN KEEP(38) = LISTVAR_SCHUR(1) ELSE WRITE(*,*) "Internal error in ZMUMPS_ANA_F_ELT",KEEP(60) CALL MUMPS_ABORT() ENDIF ENDIF CALL ZMUMPS_ANA_K(N, IPE8, IW2, LLIW8, IWFR8, IKEEP, & IKEEP(1,2), IW(L1), & IW(L2), NCMPA, ITEMP, IWtemp) ENDIF CALL ZMUMPS_ANA_LNEW(N, IWtemp, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, IWtemp(1,2), & INFO(6), FILS, FRERE, IWtemp(1,3), NEMIN, & IW(L2), KEEP(60), KEEP(20), KEEP(38), & IW2,KEEP(104),IW(L2+int(N,8)),KEEP(50), & ICNTL(13), KEEP(37), KEEP(197), NSLAVES, KEEP(250).EQ.1, & .FALSE., IDUMMY, LIDUMMY, & INODE_Scalapack_CAND, NBSONS_Scalapack_CAND, & KEEP(11), KEEP(191), KEEP(192), KEEP(193) ) DEALLOCATE(IW2) IF (KEEP(60).NE.0) THEN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO WHILE (IN.GT.0) IN = FILS (IN) END DO IFSON = -IN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO I=2,SIZE_SCHUR FILS(IN) = LISTVAR_SCHUR (I) IN = FILS(IN) FRERE (IN) = N+1 ENDDO FILS(IN) = -IFSON ENDIF CALL ZMUMPS_ANA_M(IKEEP(1,2), & IWtemp(1,3), INFO(6), & INFO(5), KEEP(2),KEEP(50), & KEEP8(101), KEEP(108),KEEP(5), & KEEP(6), KEEP(226), KEEP(253)) IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, KEEP(20) ) INODE_Scalapack_CAND = KEEP(20) NBSONS_Scalapack_CAND = 1 END IF IF ( KEEP(48) == 4 .OR. & ( (KEEP(24).NE.0).AND.(KEEP8(21).GT.0_8) ) ) THEN CALL ZMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2), & KEEP(48), KEEP(50), NSLAVES) END IF IF (KEEP(210).LT.1.OR.KEEP(210).GT.2) KEEP(210)=2 IF (KEEP(210).EQ.2) KEEP8(79)=huge(KEEP8(79)) IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF IF (KEEP(11).EQ.0) THEN IF (KEEP(79).EQ.0) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN IDUMMY(1)= -1 CALL ZMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ, & IDUMMY, LIDUMMY, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF (PROK) THEN WRITE(MP,*) " Number of split nodes in pre-splitting=", & KEEP(61) ENDIF ENDIF ENDIF ENDIF ENDIF HOW_TO_SPLIT_ROOT = 0 SPLITROOT = ICNTL(13) .EQ. -1 #if defined(NOSCALAPACK) SPLITROOT = SPLITROOT .OR. NSLAVES.GT.0 #else SPLITROOT = SPLITROOT .OR. & (ICNTL(13).GT.0 .AND. NSLAVES .GT. ICNTL(13)) #endif HOW_TO_SPLIT_ROOT = 0 IF (SPLITROOT.AND.KEEP(11).GT.0) HOW_TO_SPLIT_ROOT =1 IF (KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. IF (KEEP(11).GT.0) HOW_TO_SPLIT_ROOT = 2 ENDIF SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) )) #if defined(NOSCALAPACK) #else IF ( KEEP(11).GT.0) THEN IF (.NOT.SPLITROOT .AND. & (KEEP(60).EQ.0).AND. & ( (NFSIZ(INODE_Scalapack_CAND).GT.KEEP(37)) & .AND.(ICNTL(13).LE.0) ) & .AND. & (NBSONS_Scalapack_CAND.GT.KEEP(11)) & ) THEN HOW_TO_SPLIT_ROOT = 3 SPLITROOT=.TRUE. ENDIF ENDIF #endif IF (SPLITROOT) THEN IDUMMY(1) = -1 IF (KEEP(11).EQ.0) THEN CALL ZMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & IDUMMY, LIDUMMY, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) ENDIF ELSE CALL ZMUMPS_SPLIT_ROOT( NSLAVES, & HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & N, FRERE(1), FILS(1), NFSIZ(1), & KEEP, KEEP8, & IDUMMY, LIDUMMY, INFO(6)) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN K = min(10,N) IF (LDIAG.EQ.4) K = N IF (K.GT.0) WRITE (MP,99997) (IKEEP(I,1),I=1,K) IF (K.GT.0) WRITE (MP,99991) (IKEEP(I,2),I=1,K) IF (K.GT.0) WRITE (MP,99990) (IKEEP(I,3),I=1,K) IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) ENDIF GO TO 90 40 INFO(1) = -4 INFO(2) = K 90 CONTINUE IF (INFO(1) .LT.0) THEN IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99996) INFO(1) IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99982) INFO(2) ENDIF IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(IPE8)) DEALLOCATE(IPE8) IF (allocated(IW2)) DEALLOCATE(IW2) IF (allocated(IWtemp)) DEALLOCATE(IWtemp) RETURN 99999 FORMAT (/'Entering analysis phase with ...'/ & ' N NELT LIW INFO(1)'/, & 9X, I10, I11, I12, I14) 99998 FORMAT ('Element pointers: ELTPTR() '/(9X, 7I10)) 99995 FORMAT ('Element variables: ELTVAR() '/(9X, 7I10)) 99997 FORMAT ('IKEEP(.,1)=', 10I6/(12X, 10I6)) 99996 FORMAT (/'** Error return ** from Analysis * INFO(1)=', I3) 99991 FORMAT ('IKEEP(.,2)=', 10I6/(12X, 10I6)) 99990 FORMAT ('IKEEP(.,3)=', 10I6/(12X, 10I6)) 99989 FORMAT ('FILS (.) =', 10I6/(12X, 10I6)) 99988 FORMAT ('FRERE(.) =', 10I6/(12X, 10I6)) 99987 FORMAT ('NFSIZ(.) =', 10I6/(12X, 10I6)) 99982 FORMAT ('Error in permutation array KEEP INFO(2)=', I3) END SUBROUTINE ZMUMPS_ANA_F_ELT SUBROUTINE ZMUMPS_NODEL( NELT, N, NELNOD, XELNOD, ELNOD, & XNODEL, NODEL, FLAG, IERROR, ICNTL ) IMPLICIT NONE INTEGER NELT, N, NELNOD, IERROR, ICNTL(60) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & FLAG(N) INTEGER I, J, K, MP, NBERR MP = ICNTL(2) FLAG(1:N) = 0 XNODEL(1:N) = 0 IERROR = 0 DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF ( J.LT.1 .OR. J.GT.N ) THEN IERROR = IERROR + 1 ELSE IF ( FLAG(J).NE.I ) THEN XNODEL(J) = XNODEL(J) + 1 FLAG(J) = I ENDIF ENDIF ENDDO ENDDO IF ( IERROR.GT.0 .AND. MP.GT.0 .AND. ICNTL(4).GE.2 ) THEN NBERR = 0 WRITE(MP,99999) DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF ( J.LT.1 .OR. J.GT.N ) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN WRITE(MP,'(A,I8,A,I8,A)') & 'Element ',I,' variable ',J,' ignored.' ELSE GO TO 100 ENDIF ENDIF ENDDO ENDDO ENDIF 100 CONTINUE K = 1 DO I = 1, N K = K + XNODEL(I) XNODEL(I) = K ENDDO XNODEL(N+1) = XNODEL(N) FLAG(1:N) = 0 DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF (FLAG(J).NE.I) THEN XNODEL(J) = XNODEL(J) - 1 NODEL(XNODEL(J)) = I FLAG(J) = I ENDIF ENDDO ENDDO RETURN 99999 FORMAT (/'*** Warning message from subroutine ZMUMPS_NODEL ***') END SUBROUTINE ZMUMPS_NODEL SUBROUTINE ZMUMPS_ANA_G1_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, FLAG) IMPLICIT NONE INTEGER N, NELT, NELNOD INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & FLAG(N) INTEGER I,J,K1,K2,K3 FLAG(1:N) = 0 LEN(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN LEN(I) = LEN(I) + 1 LEN(J) = LEN(J) + 1 FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO NZ = 0_8 DO I = 1,N NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_G1_ELT SUBROUTINE ZMUMPS_ANA_G2_ELTNEW(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N+1) INTEGER LEN(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IWFR = IWFR + int(LEN(I),8) IPE(I) = IWFR ENDDO IPE(N+1)=IPE(N) FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1 IW(IPE(I)) = J IPE(J) = IPE(J) - 1 IW(IPE(J)) = I FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_G2_ELTNEW SUBROUTINE ZMUMPS_ANA_G2_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER LEN(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IWFR = IWFR + int(LEN(I),8) IF (LEN(I).GT.0) THEN IPE(I) = IWFR ELSE IPE(I) = 0_8 ENDIF ENDDO FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1_8 IW(IPE(I)) = J IPE(J) = IPE(J) - 1_8 IW(IPE(J)) = I FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_G2_ELT SUBROUTINE ZMUMPS_ANA_J1_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, LEN, FLAG) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), FLAG(N) INTEGER I,J,K1,K2,K3 FLAG(1:N) = 0 LEN(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IF (PERM(J).GT.PERM(I)) THEN LEN(I) = LEN(I) + 1 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO NZ = 0_8 DO I = 1,N NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_J1_ELT SUBROUTINE ZMUMPS_ANA_J2_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), IW(LW), & FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 0_8 DO I = 1,N IWFR = IWFR + int(LEN(I) + 1,8) IPE(I) = IWFR ENDDO IWFR = IWFR + 1_8 FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IF (PERM(J).GT.PERM(I)) THEN IW(IPE(I)) = J IPE(I) = IPE(I) - 1_8 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO DO I = 1,N J = int(IPE(I)) IW(J) = LEN(I) IF (LEN(I).EQ.0) IPE(I) = 0_8 ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_J2_ELT SUBROUTINE ZMUMPS_ANA_DIST_ELEMENTS( MYID, SLAVEF, N, & PROCNODE, STEP, PTRAIW, PTRARW, & NELT, FRTPTR, FRTELT, & KEEP,KEEP8, ICNTL, SYM ) IMPLICIT NONE INTEGER MYID, SLAVEF, N, NELT, SYM INTEGER KEEP( 500 ), ICNTL( 60 ) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAIW( NELT+1 ), PTRARW( NELT+1 ) INTEGER STEP( N ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PROCNODE( KEEP(28) ) INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER(8) :: IPTRI8, IPTRR8, NVAR8 INTEGER ELT, I, K INTEGER TYPE_PARALL, ITYPE, IRANK LOGICAL :: EARLYT3ROOTINS TYPE_PARALL = KEEP(46) PTRAIW( 1:NELT ) = 0_8 EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) DO I = 1, N IF (STEP(I).LT.0) CYCLE ITYPE = MUMPS_TYPENODE( PROCNODE(abs(STEP(I))), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(abs(STEP(I))), KEEP(199) ) IF ( TYPE_PARALL .eq. 0 ) THEN IRANK = IRANK + 1 END IF IF ( (ITYPE .EQ. 2) .OR. & (ITYPE .EQ. 3 .AND. .NOT. EARLYT3ROOTINS ) .OR. & (ITYPE .EQ. 1 .AND. IRANK .EQ. MYID) ) THEN DO K = FRTPTR(I),FRTPTR(I+1)-1 ELT = FRTELT(K) PTRAIW( ELT ) = PTRARW(ELT+1) - PTRARW(ELT) ENDDO ELSE END IF END DO IPTRI8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT ) PTRAIW( ELT ) = IPTRI8 IPTRI8 = IPTRI8 + NVAR8 ENDDO PTRAIW( NELT+1 ) = IPTRI8 KEEP8(27) = IPTRI8 - 1 IF ( .TRUE. ) THEN IF (SYM .EQ. 0) THEN IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + NVAR8*NVAR8 ENDDO PTRARW( NELT+1 ) = IPTRR8 ELSE IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + (NVAR8*(NVAR8+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR8 ENDIF ELSE IF (SYM .EQ. 0) THEN IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + NVAR8*NVAR8 ENDDO PTRARW( NELT+1 ) = IPTRR8 ELSE IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + (NVAR8*(NVAR8+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR8 ENDIF ENDIF KEEP8(26) = IPTRR8 - 1_8 RETURN END SUBROUTINE ZMUMPS_ANA_DIST_ELEMENTS SUBROUTINE ZMUMPS_ELTPROC( N, NELT, ELTPROC, SLAVEF, PROCNODE, & KEEP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, SLAVEF INTEGER, INTENT(IN) :: PROCNODE( N ) INTEGER, INTENT(INOUT) :: ELTPROC( NELT ) INTEGER :: KEEP(500) INTEGER ELT, I, ITYPE LOGICAL :: EARLYT3ROOTINS INTEGER, EXTERNAL :: MUMPS_TYPENODE, MUMPS_PROCNODE EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) DO ELT = 1, NELT I = ELTPROC(ELT) IF ( I .NE. 0) THEN ITYPE = MUMPS_TYPENODE(PROCNODE(I),KEEP(199)) IF (ITYPE.EQ.1) THEN ELTPROC(ELT) = MUMPS_PROCNODE(PROCNODE(I),KEEP(199)) ELSE IF ( ITYPE.EQ.2 .OR. .NOT. EARLYT3ROOTINS ) THEN ELTPROC(ELT) = -1 ELSE ELTPROC(ELT) = -2 ENDIF ELSE ELTPROC(ELT) = -3 ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_ELTPROC SUBROUTINE ZMUMPS_FRTELT(N, NELT, NELNOD, FRERE, FILS, NA, NE, & XNODEL, NODEL, FRTPTR, FRTELT, ELTNOD) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, NELNOD INTEGER, INTENT(IN) :: FRERE(N), FILS(N), NA(N), NE(N) INTEGER, INTENT(OUT):: FRTPTR(N+1), FRTELT(NELT), ELTNOD(NELT) INTEGER, INTENT(IN) :: XNODEL(N+1), NODEL(NELNOD) INTEGER, DIMENSION(:), ALLOCATABLE :: TNSTK, IPOOL INTEGER I, K, IFATH, allocok INTEGER INODE, LEAF, NBLEAF, NBROOT, III, IN ALLOCATE(TNSTK( N ), stat=allocok) IF (allocok.ne.0) THEN WRITE(6,*) ' Allocation error of TNSTK in ' & // 'routine ZMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF ALLOCATE(IPOOL( N ), stat=allocok) IF (allocok.ne.0) THEN WRITE(6,*) ' Allocation error of IPOOL in ' & // 'routine ZMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF TNSTK = NE LEAF = 1 IF (N.EQ.1) THEN NBROOT = 1 NBLEAF = 1 IPOOL(1) = 1 LEAF = LEAF + 1 ELSEIF (NA(N).LT.0) THEN NBLEAF = N NBROOT = N DO 20 I=1,NBLEAF-1 INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 20 CONTINUE INODE = -NA(N)-1 IPOOL(LEAF) = INODE LEAF = LEAF + 1 ELSEIF (NA(N-1).LT.0) THEN NBLEAF = N-1 NBROOT = NA(N) IF (NBLEAF-1.GT.0) THEN DO 30 I=1,NBLEAF-1 INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 30 CONTINUE ENDIF INODE = -NA(N-1)-1 IPOOL(LEAF) = INODE LEAF = LEAF + 1 ELSE NBLEAF = NA(N-1) NBROOT = NA(N) DO 40 I = 1,NBLEAF INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 40 CONTINUE ENDIF ELTNOD(1:NELT) = 0 III = 1 90 CONTINUE IF (III.NE.LEAF) THEN INODE=IPOOL(III) III = III + 1 ELSE WRITE(6,*) ' ERROR 1 in subroutine ZMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF 95 CONTINUE IN = INODE 100 CONTINUE DO K = XNODEL(IN),XNODEL(IN+1)-1 I = NODEL(K) IF (ELTNOD(I).EQ.0) ELTNOD(I) = INODE ENDDO IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IN = INODE 110 IN = FRERE(IN) IF (IN.GT.0) GO TO 110 IF (IN.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 115 GOTO 90 ELSE IFATH = -IN ENDIF TNSTK(IFATH) = TNSTK(IFATH) - 1 IF ( TNSTK(IFATH) .EQ. 0 ) THEN INODE = IFATH GOTO 95 ELSE GOTO 90 ENDIF 115 CONTINUE FRTPTR(1:N) = 0 DO I = 1,NELT IF (ELTNOD(I) .NE. 0) THEN FRTPTR(ELTNOD(I)) = FRTPTR(ELTNOD(I)) + 1 ENDIF ENDDO K = 1 DO I = 1,N K = K + FRTPTR(I) FRTPTR(I) = K ENDDO FRTPTR(N+1) = FRTPTR(N) DO K = 1,NELT INODE = ELTNOD(K) IF (INODE .NE. 0) THEN FRTPTR(INODE) = FRTPTR(INODE) - 1 FRTELT(FRTPTR(INODE)) = K ENDIF ENDDO DEALLOCATE(TNSTK, IPOOL) RETURN END SUBROUTINE ZMUMPS_FRTELT SUBROUTINE ZMUMPS_ANA_G11_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, LW, IW) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8) :: LW INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW) INTEGER I,J,K1,K2,K3,LP,NSUP,SUPVAR INTEGER INFO44(6) EXTERNAL ZMUMPS_SUPVAR LP = 6 CALL ZMUMPS_SUPVAR(N,NELT,XELNOD(NELT+1)-1,ELNOD,XELNOD, & NSUP,IW(3_8*int(N,8)+3_8+1_8), & 3_8*int(N,8)+3_8,IW,LP,INFO44) IF (INFO44(1) .LT. 0) THEN IF (LP.GE.0) WRITE(LP,*) & 'Error return from ZMUMPS_SUPVAR. INFO(1) = ',INFO44(1) ENDIF IW(1:NSUP) = 0 LEN(1:N) = 0 DO I = 1,N SUPVAR = IW(3_8*int(N,8)+3_8+1_8+int(I,8)) IF (SUPVAR .EQ. 0) CYCLE IF (IW(SUPVAR).NE.0) THEN LEN(I) = -IW(SUPVAR) ELSE IW(SUPVAR) = I ENDIF ENDDO IW(int(N+1,8):2_8*int(N,8)) = 0 NZ = 0_8 DO SUPVAR = 1,NSUP I = IW(SUPVAR) DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF (LEN(J).GE.0) THEN IF ((I.NE.J) .AND. (IW(int(N,8)+int(J,8)).NE.I)) THEN IW(int(N,8)+int(J,8)) = I LEN(I) = LEN(I) + 1 ENDIF ENDIF ENDIF ENDDO ENDDO NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_G11_ELT SUBROUTINE ZMUMPS_ANA_G12_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IF (LEN(I).GT.0) THEN IWFR = IWFR + int(LEN(I),8) IPE(I) = IWFR ELSE IPE(I) = 0_8 ENDIF ENDDO FLAG(1:N) = 0 DO I = 1,N IF (LEN(I).LE.0) CYCLE DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF (LEN(J) .GT. 0) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1 IW(IPE(I)) = J FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_G12_ELT SUBROUTINE ZMUMPS_SUPVAR(N,NELT,NZ,ELTVAR,ELTPTR,NSUP,SVAR, & LIW,IW,LP,INFO) INTEGER LP,N,NELT,NSUP,NZ INTEGER(8)::LIW INTEGER INFO(6) INTEGER ELTPTR(NELT+1),ELTVAR(NZ) INTEGER IW(LIW),SVAR(0:N) INTEGER(8) :: FLAG,NEW,VARS 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) = N + 1 GO TO 40 END IF NEW = 1_8 VARS = NEW + LIW/3_8 FLAG = VARS + LIW/3_8 CALL ZMUMPS_SUPVARB(N,NELT,ELTPTR,NZ,ELTVAR,SVAR,NSUP, & int(min(int(huge(NSUP)-1,8),LIW/3_8-1_8)), & IW(NEW),IW(VARS),IW(FLAG),INFO) IF (INFO(1).EQ.-4) THEN INFO(4) = N + 1 GO TO 40 ELSE INFO(4) = NSUP + 1 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) 3_8*int(INFO(4),8) END IF 50 RETURN 9000 FORMAT (/3X,'Error message from ZMUMPS_SUPVAR: INFO(1) = ',I2) 9010 FORMAT (3X,'LIW is insufficient. Upper bound on required work', & 'space is ',I12) END SUBROUTINE ZMUMPS_SUPVAR SUBROUTINE ZMUMPS_SUPVARB( N, NELT, ELTPTR, NZ, ELTVAR, & SVAR, NSUP, MAXSUP, NEW, VARS, FLAG, INFO ) INTEGER MAXSUP,N,NELT,NSUP,NZ INTEGER ELTPTR(NELT+1),ELTVAR(NZ) INTEGER INFO(6) INTEGER FLAG(0:MAXSUP), NEW(0:MAXSUP),SVAR(0:N), & VARS(0:MAXSUP) INTEGER I,IS,J,JS,K,K1,K2 DO 10 I = 0,N SVAR(I) = 0 10 CONTINUE VARS(0) = N + 1 NEW(0) = -1 FLAG(0) = 0 NSUP = 0 DO 40 J = 1,NELT K1 = ELTPTR(J) K2 = ELTPTR(J+1) - 1 DO 20 K = K1,K2 I = ELTVAR(K) IF (I.LT.1 .OR. I.GT.N) THEN INFO(2) = INFO(2) + 1 GO TO 20 END IF IS = SVAR(I) IF (IS.LT.0) THEN ELTVAR(K) = 0 INFO(3) = INFO(3) + 1 GO TO 20 END IF SVAR(I) = SVAR(I) - N - 2 VARS(IS) = VARS(IS) - 1 20 CONTINUE DO 30 K = K1,K2 I = ELTVAR(K) IF (I.LT.1 .OR. I.GT.N) GO TO 30 IS = SVAR(I) + N + 2 IF (FLAG(IS).LT.J) THEN FLAG(IS) = J IF (VARS(IS).GT.0) THEN NSUP = NSUP + 1 IF (NSUP.GT.MAXSUP) THEN INFO(1) = -4 RETURN END IF VARS(NSUP) = 1 FLAG(NSUP) = J NEW(IS) = NSUP SVAR(I) = NSUP ELSE VARS(IS) = 1 NEW(IS) = IS SVAR(I) = IS END IF ELSE JS = NEW(IS) VARS(JS) = VARS(JS) + 1 SVAR(I) = JS END IF 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE ZMUMPS_SUPVARB MUMPS_5.8.1/src/cmumps_lr_data_m.F0000664000175000017500000036713015042446440016657 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_LR_DATA_M USE CMUMPS_LR_TYPE IMPLICIT NONE PRIVATE PUBLIC :: CMUMPS_BLR_END_FRONT, CMUMPS_BLR_INIT_MODULE, & CMUMPS_BLR_END_MODULE, CMUMPS_BLR_INIT_FRONT, & CMUMPS_BLR_SAVE_INIT, & CMUMPS_BLR_SAVE_PANEL_LORU, CMUMPS_BLR_RETRIEVE_BEGS_BLR_L, & CMUMPS_BLR_SAVE_BEGS_BLR_C, CMUMPS_BLR_RETRIEVE_BEGS_BLR_C, & CMUMPS_BLR_DEC_AND_RETRIEVE_L, CMUMPS_BLR_RETRIEVE_PANEL_LORU, & CMUMPS_BLR_DEC_AND_TRYFREE_L, CMUMPS_BLR_TRY_FREE_PANEL, & CMUMPS_BLR_FORCE_FREE_PANEL_L, & CMUMPS_BLR_FREE_CB_LRB, CMUMPS_BLR_FREE_ALL_PANELS, & CMUMPS_BLR_SAVE_CB_LRB, & CMUMPS_BLR_RETRIEVE_CB_LRB, CMUMPS_BLR_RETRIEVE_BEGSBLR_STA, & CMUMPS_BLR_SAVE_BEGS_BLR_DYN, CMUMPS_BLR_RETRIEVE_BEGSBLR_DYN, & CMUMPS_BLR_RETRIEVE_NB_PANELS, CMUMPS_BLR_EMPTY_PANEL_LORU, & CMUMPS_BLR_SAVE_NFS4FATHER, CMUMPS_BLR_RETRIEVE_NFS4FATHER, & CMUMPS_BLR_SAVE_M_ARRAY, CMUMPS_BLR_RETRIEVE_M_ARRAY, & CMUMPS_BLR_FREE_M_ARRAY & , CMUMPS_BLR_STRUC_TO_MOD, CMUMPS_BLR_MOD_TO_STRUC, BLR_ARRAY #if defined(MUMPS_NOF2003) & , BLR_STRUC_T, blr_panel_type, diag_block_type #endif & , CMUMPS_BLR_SAVE_DIAG_BLOCK, CMUMPS_BLR_RETRIEVE_DIAG_BLOCK #if ! defined(NO_SAVE_RESTORE) & , CMUMPS_SAVE_RESTORE_BLR #endif TYPE blr_panel_type integer :: NB_ACCESSES_LEFT type(LRB_TYPE), pointer :: LRB_PANEL(:) END TYPE blr_panel_type TYPE diag_block_type COMPLEX, POINTER :: DIAG_BLOCK(:) END TYPE diag_block_type TYPE BLR_STRUC_T LOGICAL :: IsSYM, IsT2, IsSLAVE TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_L TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_U TYPE(LRB_TYPE), pointer :: CB_LRB(:,:) TYPE(diag_block_type), DIMENSION (:), POINTER :: DIAG_BLOCKS INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_STATIC INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_DYNAMIC INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: NB_ACCESSES_INIT INTEGER :: NB_PANELS INTEGER :: NFS4FATHER REAL, DIMENSION(:), POINTER :: M_ARRAY END TYPE BLR_STRUC_T type(BLR_STRUC_T), POINTER, DIMENSION(:), SAVE :: BLR_ARRAY TYPE BLR_ARRAY_T type(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY END TYPE BLR_ARRAY_T INTEGER BLR_ARRAY_FREE, PANELS_NOTUSED, PANELS_FREED, & NB_PANELS_NOTINIT, NFS4FATHER_NOTINIT PARAMETER (BLR_ARRAY_FREE=-9999, & PANELS_NOTUSED=-1111, PANELS_FREED=-2222, & NB_PANELS_NOTINIT=-3333, & NFS4FATHER_NOTINIT=-4444 ) #if ! defined(NO_SAVE_RESTORE) INCLUDE 'mumps_save_restore_modes.h' #endif CONTAINS SUBROUTINE CMUMPS_BLR_INIT_MODULE(INITIAL_SIZE, INFO & ) INTEGER, INTENT(IN) :: INITIAL_SIZE INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR ALLOCATE(BLR_ARRAY( INITIAL_SIZE ), stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=INITIAL_SIZE RETURN ENDIF DO I=1, INITIAL_SIZE NULLIFY(BLR_ARRAY(I)%PANELS_L) NULLIFY(BLR_ARRAY(I)%PANELS_U) NULLIFY(BLR_ARRAY(I)%CB_LRB) NULLIFY(BLR_ARRAY(I)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_DYNAMIC) BLR_ARRAY(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY(I)%NB_PANELS = NB_PANELS_NOTINIT NULLIFY(BLR_ARRAY(I)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_COL) BLR_ARRAY(I)%NFS4FATHER = NFS4FATHER_NOTINIT NULLIFY(BLR_ARRAY(I)%M_ARRAY) ENDDO RETURN END SUBROUTINE CMUMPS_BLR_INIT_MODULE SUBROUTINE CMUMPS_BLR_END_MODULE(INFO1, KEEP8, K34 & , LRSOLVE_ACT_OPT & ) INTEGER, INTENT(IN) :: INFO1, K34 LOGICAL, OPTIONAL, INTENT(IN) :: LRSOLVE_ACT_OPT INTEGER(8) :: KEEP8(150) INTEGER :: I, ILOOP IF (.NOT. associated(BLR_ARRAY)) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_END_MODULE" CALL MUMPS_ABORT() ENDIF DO I=1, size(BLR_ARRAY) ILOOP= I IF (associated(BLR_ARRAY(I)%PANELS_L).OR. & associated(BLR_ARRAY(I)%PANELS_U).OR. & associated(BLR_ARRAY(I)%CB_LRB).OR. & associated(BLR_ARRAY(I)%DIAG_BLOCKS) & ) THEN IF (present(LRSOLVE_ACT_OPT)) THEN CALL CMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8, K34 & , LRSOLVE_ACT_OPT & ) ELSE CALL CMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8, K34 ) ENDIF ENDIF ENDDO DEALLOCATE(BLR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE CMUMPS_BLR_END_MODULE SUBROUTINE CMUMPS_BLR_MOD_TO_STRUC(id_BLRARRAY_ENCODING) # if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING # else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING # endif CHARACTER :: CHAR_ARRAY(1) INTEGER :: CHAR_LENGTH, IERR TYPE(BLR_ARRAY_T) :: BLR_ARRAY_VAR IF (associated(id_BLRARRAY_ENCODING)) THEN WRITE(*,*) "Internal error 1 in MUMPS_BLR_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF BLR_ARRAY_VAR%BLR_ARRAY => BLR_ARRAY CHAR_LENGTH=size(transfer(BLR_ARRAY_VAR,CHAR_ARRAY)) ALLOCATE(id_BLRARRAY_ENCODING(CHAR_LENGTH), stat=IERR) IF (IERR > 0 ) THEN WRITE(*,*) "Allocation error in MUMPS_BLR_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF id_BLRARRAY_ENCODING=transfer(BLR_ARRAY_VAR,CHAR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE CMUMPS_BLR_MOD_TO_STRUC SUBROUTINE CMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) # if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING # else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING # endif TYPE (BLR_ARRAY_T) :: BLR_ARRAY_VAR IF (.NOT.associated(id_BLRARRAY_ENCODING)) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_STRUC_TO_MOD" ENDIF BLR_ARRAY_VAR = transfer(id_BLRARRAY_ENCODING,BLR_ARRAY_VAR) BLR_ARRAY => BLR_ARRAY_VAR%BLR_ARRAY DEALLOCATE(id_BLRARRAY_ENCODING) NULLIFY(id_BLRARRAY_ENCODING) RETURN END SUBROUTINE CMUMPS_BLR_STRUC_TO_MOD SUBROUTINE CMUMPS_BLR_INIT_FRONT(IWHANDLER, & INFO, MTK405) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX !$ USE OMP_LIB INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) INTEGER, INTENT(IN), OPTIONAL :: MTK405 TYPE(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY_TMP INTEGER :: OLD_SIZE, NEW_SIZE INTEGER :: I INTEGER :: IERR LOGICAL :: NEEDS_THREAD_SAFETY NEEDS_THREAD_SAFETY = .FALSE. IF (present(MTK405)) THEN IF (MTK405 .EQ. 1 ) THEN NEEDS_THREAD_SAFETY = .TRUE. ENDIF ENDIF IF ( NEEDS_THREAD_SAFETY ) THEN !$OMP CRITICAL(critical_blr_idx) CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) !$OMP END CRITICAL(critical_blr_idx) ELSE CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) ENDIF IF (IWHANDLER > size(BLR_ARRAY)) THEN OLD_SIZE = size(BLR_ARRAY) NEW_SIZE = max( (OLD_SIZE * 3) / 2 + 1, IWHANDLER) ALLOCATE(BLR_ARRAY_TMP(NEW_SIZE),stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=NEW_SIZE GOTO 500 ENDIF DO I=1, OLD_SIZE BLR_ARRAY_TMP(I)=BLR_ARRAY(I) ENDDO DO I=OLD_SIZE+1, NEW_SIZE NULLIFY(BLR_ARRAY_TMP(I)%PANELS_L) NULLIFY(BLR_ARRAY_TMP(I)%PANELS_U) NULLIFY(BLR_ARRAY_TMP(I)%CB_LRB) NULLIFY(BLR_ARRAY_TMP(I)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_DYNAMIC) BLR_ARRAY_TMP(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY_TMP(I)%NB_PANELS = NB_PANELS_NOTINIT NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_L) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_COL) BLR_ARRAY_TMP(I)%NFS4FATHER = NFS4FATHER_NOTINIT NULLIFY(BLR_ARRAY_TMP(I)%M_ARRAY) ENDDO DEALLOCATE(BLR_ARRAY) BLR_ARRAY => BLR_ARRAY_TMP NULLIFY(BLR_ARRAY_TMP) 500 CONTINUE ENDIF RETURN END SUBROUTINE CMUMPS_BLR_INIT_FRONT SUBROUTINE CMUMPS_BLR_SAVE_INIT(IWHANDLER, & IsSYM, IsT2, IsSLAVE, & NB_PANELS, & BEGS_BLR_L, BEGS_BLR_COL, & NB_ACCESSES_INIT, INFO) LOGICAL, INTENT(IN) :: IsSYM, IsT2, IsSLAVE INTEGER, INTENT(IN) :: NB_PANELS, IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: NB_ACCESSES_INIT INTEGER, INTENT(IN), DIMENSION(:) :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: I INTEGER :: IERR IF (NB_PANELS.EQ.0) THEN WRITE(6,*) " Internal error 1 in CMUMPS_BLR_SAVE_INIT ", & NB_PANELS ENDIF IF (IWHANDLER .LE.0 ) THEN WRITE(6,*) " Internal error 2 in CMUMPS_BLR_SAVE_INIT ", & IWHANDLER ENDIF IF (associated(BEGS_BLR_COL)) THEN ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=size(BEGS_BLR_COL) RETURN ENDIF ENDIF IF (NB_ACCESSES_INIT.EQ.0) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=3*size(BEGS_BLR_L) RETURN ENDIF ELSE IF (IsSYM) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & stat=IERR) ELSE ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%PANELS_U(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & stat=IERR) ENDIF IF (IERR .GT. 0) THEN INFO(1)=-13 IF (IsSYM) THEN INFO(2)=NB_PANELS+3*size(BEGS_BLR_L) ELSE INFO(2)=NB_PANELS+NB_PANELS+3*size(BEGS_BLR_L) ENDIF RETURN ENDIF IF (.NOT.IsSLAVE) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(NB_PANELS), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=NB_PANELS RETURN ENDIF ENDIF DO I=1,NB_PANELS NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L(I)%LRB_PANEL) IF (.NOT.IsSYM) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U(I)%LRB_PANEL) ENDIF IF (.NOT.IsSLAVE) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(I)%DIAG_BLOCK) ENDIF ENDDO ENDIF BLR_ARRAY(IWHANDLER)%IsSYM = IsSYM BLR_ARRAY(IWHANDLER)%IsT2 = IsT2 BLR_ARRAY(IWHANDLER)%IsSLAVE = IsSLAVE BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS BLR_ARRAY(IWHANDLER)%BEGS_BLR_L = BEGS_BLR_L BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC = BEGS_BLR_L BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC = -999991 IF (NB_ACCESSES_INIT.EQ.0) THEN BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = PANELS_NOTUSED ELSE BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = NB_ACCESSES_INIT ENDIF IF (associated(BEGS_BLR_COL)) THEN DO I=1,size(BEGS_BLR_COL) BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) ENDDO ELSE NULLIFY( BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL ) ENDIF RETURN END SUBROUTINE CMUMPS_BLR_SAVE_INIT SUBROUTINE CMUMPS_BLR_END_FRONT(IWHANDLER, INFO1, KEEP8, K34 & , LRSOLVE_ACT_OPT, MTK405 ) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX INTEGER, INTENT(INOUT) :: IWHANDLER INTEGER, INTENT(IN) :: INFO1 INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: K34 LOGICAL, OPTIONAL, INTENT(IN) :: LRSOLVE_ACT_OPT INTEGER, OPTIONAL, INTENT(IN) :: MTK405 INTEGER :: IPANEL, JPANEL INTEGER(8) :: MEM_FREED INTEGER :: IDUMMY, JDUMMY TYPE(blr_panel_type), POINTER :: THEPANEL LOGICAL :: LRSOLVE_ACT, NEEDS_THREAD_SAFETY TYPE(diag_block_type), POINTER :: THEBLOCK LRSOLVE_ACT = .FALSE. IF (present(LRSOLVE_ACT_OPT)) LRSOLVE_ACT = LRSOLVE_ACT_OPT IF (IWHANDLER.LE.0) THEN RETURN ENDIF NEEDS_THREAD_SAFETY = .FALSE. IF (present(MTK405)) THEN IF (MTK405 .EQ. 1 ) THEN NEEDS_THREAD_SAFETY = .TRUE. ENDIF ENDIF IF (IWHANDLER .GT. size(BLR_ARRAY)) THEN RETURN END IF IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ.BLR_ARRAY_FREE) & RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.NE. & PANELS_NOTUSED) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 2a in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated", & " NB_ACCESSES_LEFT= ",THEPANEL%NB_ACCESSES_LEFT CALL MUMPS_ABORT() ELSE CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDDO IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 2b in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated" CALL MUMPS_ABORT() ELSE CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDDO IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN MEM_FREED = 0_8 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) THEBLOCK => BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL) IF (associated(THEBLOCK%DIAG_BLOCK)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 3 in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated" CALL MUMPS_ABORT() ENDIF MEM_FREED = MEM_FREED + int(size(THEBLOCK%DIAG_BLOCK),8) DEALLOCATE (THEBLOCK%DIAG_BLOCK) NULLIFY (THEBLOCK%DIAG_BLOCK) ENDIF ENDDO IF ( MEM_FREED .GT. 0_8 ) THEN CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-MEM_FREED, & NEEDS_THREAD_SAFETY, KEEP8, & IDUMMY, JDUMMY, & .TRUE., .TRUE.) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsT2.OR. & BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN IF (associated(BLR_ARRAY(IWHANDLER)%CB_LRB)) THEN IF (INFO1 .GE. 0) THEN WRITE(*,*) & " Internal Error 4 in MUMPS_BLR_END_FRONT ", & IWHANDLER, "CB block still associated", & BLR_ARRAY(IWHANDLER)%IsT2, & BLR_ARRAY(IWHANDLER)%IsSLAVE CALL MUMPS_ABORT() ELSE DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%CB_LRB,1) DO JPANEL = 1, size(BLR_ARRAY(IWHANDLER)%CB_LRB,2) CALL DEALLOC_LRB( & BLR_ARRAY(IWHANDLER)%CB_LRB(IPANEL,JPANEL), & KEEP8, K34) ENDDO ENDDO DEALLOCATE(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) ENDIF ENDIF ENDIF ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) ENDIF BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS_NOTINIT BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER_NOTINIT IF (associated(BLR_ARRAY(IWHANDLER)%M_ARRAY)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY) NULLIFY(BLR_ARRAY(IWHANDLER)%M_ARRAY) ENDIF IF (NEEDS_THREAD_SAFETY) THEN !$OMP CRITICAL(critical_blr_idx) CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) !$OMP END CRITICAL(critical_blr_idx) ELSE CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) ENDIF RETURN END SUBROUTINE CMUMPS_BLR_END_FRONT SUBROUTINE CMUMPS_BLR_SAVE_PANEL_LORU ( & IWHANDLER, LORU, IPANEL, LRB_PANEL, NB_ACCESSES_INIT_IN ) type(LRB_TYPE), DIMENSION(:), pointer :: LRB_PANEL INTEGER, INTENT(IN) :: IWHANDLER, IPANEL, NB_ACCESSES_INIT_IN INTEGER, INTENT(IN) :: LORU TYPE(blr_panel_type), POINTER :: THEPANEL IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_SAVE_PANEL_LORU" CALL MUMPS_ABORT() ENDIF IF (LORU.EQ.0) THEN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) ELSE THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) ENDIF IF (NB_ACCESSES_INIT_IN.GT.0) THEN THEPANEL%NB_ACCESSES_LEFT = NB_ACCESSES_INIT_IN ELSE THEPANEL%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT ENDIF THEPANEL%LRB_PANEL => LRB_PANEL RETURN END SUBROUTINE CMUMPS_BLR_SAVE_PANEL_LORU SUBROUTINE CMUMPS_BLR_SAVE_CB_LRB ( & IWHANDLER, CB_LRB ) #if defined(MUMPS_NOF2003) TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) #else TYPE(LRB_TYPE), POINTER, INTENT(IN) :: CB_LRB(:,:) #endif INTEGER, INTENT(IN) :: IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_SAVE_CB_LRB" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%CB_LRB => CB_LRB RETURN END SUBROUTINE CMUMPS_BLR_SAVE_CB_LRB SUBROUTINE CMUMPS_BLR_SAVE_DIAG_BLOCK ( & IWHANDLER, IPANEL, D, KEEP34 ) use iso_c_binding COMPLEX,POINTER :: D(:) INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER, INTENT(IN) :: KEEP34 IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_SAVE_DIAG_BLOCK" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in CMUMPS_BLR_SAVE_DIAG_BLOCK" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK => D RETURN END SUBROUTINE CMUMPS_BLR_SAVE_DIAG_BLOCK SUBROUTINE CMUMPS_BLR_SAVE_BEGS_BLR_C ( & IWHANDLER, BEGS_BLR_COL, INFO) INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_SAVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in CMUMPS_BLR_SAVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF ALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=size(BEGS_BLR_COL) RETURN ENDIF DO I=1,size(BEGS_BLR_COL) BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) ENDDO RETURN END SUBROUTINE CMUMPS_BLR_SAVE_BEGS_BLR_C SUBROUTINE CMUMPS_BLR_SAVE_BEGS_BLR_DYN ( & IWHANDLER, BEGS_BLR_DYNAMIC ) INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_DYNAMIC INTEGER, INTENT(IN) :: IWHANDLER INTEGER :: I IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_SAVE_BEGS_BLR_DYN" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in CMUMPS_BLR_SAVE_BEGS_BLR_DYN" CALL MUMPS_ABORT() ENDIF DO I=1,size(BEGS_BLR_DYNAMIC) BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(I) = BEGS_BLR_DYNAMIC(I) ENDDO RETURN END SUBROUTINE CMUMPS_BLR_SAVE_BEGS_BLR_DYN SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGS_BLR_L & ( IWHANDLER, BEGS_BLR_L ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_BEGS_BLR_L" CALL MUMPS_ABORT() ENDIF BEGS_BLR_L => BLR_ARRAY(IWHANDLER)%BEGS_BLR_L RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGS_BLR_L SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGSBLR_STA & ( IWHANDLER, BEGS_BLR_STATIC ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_STATIC #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_BEGSBLR_STA" CALL MUMPS_ABORT() ENDIF BEGS_BLR_STATIC => BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGSBLR_STA SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGSBLR_DYN & ( IWHANDLER, BEGS_BLR_DYNAMIC ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_DYNAMIC #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_DYNAMIC #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_BEGSBLR_DYN" CALL MUMPS_ABORT() ENDIF BEGS_BLR_DYNAMIC => BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGSBLR_DYN SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGS_BLR_C & ( IWHANDLER, BEGS_BLR_COL, NB_PANELS ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NB_PANELS #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_COL #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_COL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF BEGS_BLR_COL => BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGS_BLR_C SUBROUTINE CMUMPS_BLR_RETRIEVE_NB_PANELS & ( IWHANDLER, NB_PANELS ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NB_PANELS IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_NB_PANELS" CALL MUMPS_ABORT() ENDIF NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_NB_PANELS SUBROUTINE CMUMPS_BLR_DEC_AND_RETRIEVE_L(IWHANDLER, IPANEL, & BEGS_BLR_L, THELRBPANEL, & NBDEC ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: IPANEL, NBDEC #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) "Internal error 2 in CMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) "Internal error 3 in CMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_L( IWHANDLER, BEGS_BLR_L ) THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - NBDEC RETURN END SUBROUTINE CMUMPS_BLR_DEC_AND_RETRIEVE_L LOGICAL FUNCTION CMUMPS_BLR_EMPTY_PANEL_LORU & (IWHANDLER, LorU, IPANEL) INTEGER, INTENT(IN) :: LorU, IPANEL, IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF (LorU.EQ.0) THEN IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) & "Internal error 2 in CMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF CMUMPS_BLR_EMPTY_PANEL_LORU = .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 3 in CMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF CMUMPS_BLR_EMPTY_PANEL_LORU = .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ENDIF RETURN END FUNCTION CMUMPS_BLR_EMPTY_PANEL_LORU SUBROUTINE CMUMPS_BLR_RETRIEVE_PANEL_LORU & (IWHANDLER, LORU, IPANEL, & THELRBPANEL) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: LORU INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_NOF2003) TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL #else TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF (LORU.EQ.0) THEN IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) & "Internal error 2 in CMUMPS_BLR_RETRIEVE_PANEL_LORU", & " IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) & "Internal error 3 in CMUMPS_BLR_RETRIEVE_PANEL_LORU", & " IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 4 in CMUMPS_BLR_RETRIEVE_PANEL_LORU", & " IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) & "Internal error 5 in CMUMPS_BLR_RETRIEVE_PANEL_LORU", & " IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL ENDIF RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_PANEL_LORU SUBROUTINE CMUMPS_BLR_RETRIEVE_DIAG_BLOCK & (IWHANDLER, IPANEL, & THEBLOCK) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_NOF2003) COMPLEX, POINTER :: THEBLOCK(:) #else COMPLEX, POINTER, INTENT(OUT) :: THEBLOCK(:) #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN WRITE(*,*) & "Internal error 2 in CMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK)) & THEN WRITE(*,*) & "Internal error 3 in CMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THEBLOCK => & BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_DIAG_BLOCK SUBROUTINE CMUMPS_BLR_RETRIEVE_CB_LRB & (IWHANDLER, THECB) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) TYPE(LRB_TYPE), POINTER :: THECB(:,:) #else TYPE(LRB_TYPE), POINTER, INTENT(OUT) :: THECB(:,:) #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_RETRIEVE_CB_LRB" CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%CB_LRB)) THEN WRITE(*,*) "Internal error 2 in CMUMPS_BLR_RETRIEVE_CB_LRB" CALL MUMPS_ABORT() ENDIF THECB => BLR_ARRAY(IWHANDLER)%CB_LRB RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_CB_LRB SUBROUTINE CMUMPS_BLR_SAVE_NFS4FATHER & ( IWHANDLER, NFS4FATHER ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: NFS4FATHER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_NFS4FATHER" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER RETURN END SUBROUTINE CMUMPS_BLR_SAVE_NFS4FATHER SUBROUTINE CMUMPS_BLR_RETRIEVE_NFS4FATHER & ( IWHANDLER, NFS4FATHER ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NFS4FATHER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_NFS4FATHER" CALL MUMPS_ABORT() ENDIF NFS4FATHER = BLR_ARRAY(IWHANDLER)%NFS4FATHER RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_NFS4FATHER SUBROUTINE CMUMPS_BLR_SAVE_M_ARRAY ( & IWHANDLER, M_ARRAY, INFO) REAL, DIMENSION(:), INTENT(IN) :: M_ARRAY INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_SAVE_M_ARRAY" CALL MUMPS_ABORT() ENDIF ALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY(size(M_ARRAY)), & stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=size(M_ARRAY) RETURN ENDIF DO I=1,size(M_ARRAY) BLR_ARRAY(IWHANDLER)%M_ARRAY(I) = M_ARRAY(I) ENDDO BLR_ARRAY(IWHANDLER)%NFS4FATHER = size(M_ARRAY) RETURN END SUBROUTINE CMUMPS_BLR_SAVE_M_ARRAY SUBROUTINE CMUMPS_BLR_RETRIEVE_M_ARRAY ( IWHANDLER, M_ARRAY) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) REAL, DIMENSION(:), POINTER :: M_ARRAY #else REAL, DIMENSION(:), POINTER, INTENT(OUT) :: M_ARRAY #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_RETRIEVE_M_ARRAY" CALL MUMPS_ABORT() ENDIF M_ARRAY => BLR_ARRAY(IWHANDLER)%M_ARRAY RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_M_ARRAY SUBROUTINE CMUMPS_BLR_FREE_M_ARRAY ( IWHANDLER ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_FREE_M_ARRAY" CALL MUMPS_ABORT() ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%M_ARRAY)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY) NULLIFY(BLR_ARRAY(IWHANDLER)%M_ARRAY) ENDIF BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER_NOTINIT RETURN END SUBROUTINE CMUMPS_BLR_FREE_M_ARRAY SUBROUTINE CMUMPS_BLR_DEC_AND_TRYFREE_L( IWHANDLER, IPANEL, & KEEP8, K34, NBDEC) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL, K34, NBDEC INTEGER(8) :: KEEP8(150) IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) & RETURN BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - NBDEC CALL CMUMPS_BLR_TRY_FREE_PANEL (IWHANDLER, IPANEL, & KEEP8, K34) RETURN END SUBROUTINE CMUMPS_BLR_DEC_AND_TRYFREE_L SUBROUTINE CMUMPS_BLR_FORCE_FREE_PANEL_L( IWHANDLER, IPANEL, & KEEP8, K34 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: K34 TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) & RETURN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED RETURN END SUBROUTINE CMUMPS_BLR_FORCE_FREE_PANEL_L SUBROUTINE CMUMPS_BLR_TRY_FREE_PANEL( IWHANDLER, IPANEL, & KEEP8, K34 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: K34 TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0.OR. & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.eq.huge(IPANEL) ) & RETURN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF ( THEPANEL%NB_ACCESSES_LEFT .EQ. 0 ) THEN IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF RETURN END SUBROUTINE CMUMPS_BLR_TRY_FREE_PANEL SUBROUTINE CMUMPS_BLR_FREE_CB_LRB ( IWHANDLER, FREE_ONLY_STRUCT, & KEEP8, K34 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, K34 LOGICAL, INTENT(IN) :: FREE_ONLY_STRUCT INTEGER(8) :: KEEP8(150) TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER :: IPANEL, JPANEL TYPE(LRB_TYPE), POINTER :: THELRB IF (BLR_ARRAY(IWHANDLER)%IsT2.AND. & .NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN write(*,*) 'Internal error 1 in CMUMPS_BLR_FREE_CB_LRB' CALL MUMPS_ABORT() ENDIF CB_LRB => BLR_ARRAY(IWHANDLER)%CB_LRB IF (.NOT.associated(CB_LRB)) THEN write(*,*) 'Internal error 2 in CMUMPS_BLR_FREE_CB_LRB' CALL MUMPS_ABORT() ENDIF IF (.NOT.FREE_ONLY_STRUCT) THEN DO IPANEL = 1,size(CB_LRB,1) DO JPANEL = 1,size(CB_LRB,2) THELRB => CB_LRB(IPANEL,JPANEL) IF (associated(THELRB)) THEN CALL DEALLOC_LRB(THELRB, KEEP8, K34) ENDIF ENDDO ENDDO ENDIF DEALLOCATE(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) RETURN END SUBROUTINE CMUMPS_BLR_FREE_CB_LRB SUBROUTINE CMUMPS_BLR_FREE_ALL_PANELS ( IWHANDLER, & LorU, KEEP8, K34) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, LorU, K34 INTEGER(8) :: KEEP8(150) INTEGER :: IPANEL INTEGER :: IDUMMY, JDUMMY TYPE(blr_panel_type), POINTER :: THEPANEL TYPE(diag_block_type), POINTER :: THEBLOCK INTEGER(8) :: MEM_FREED IF (IWHANDLER.LE.0) RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ. & PANELS_NOTUSED) RETURN IF (LorU.EQ.0.OR.LorU.EQ.2) THEN IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF ENDIF IF (LorU.GE.1.AND..NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF ENDIF IF (LorU.GE.1.AND..NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN IF (associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN MEM_FREED = 0_8 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) THEBLOCK => BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL) IF (associated(THEBLOCK%DIAG_BLOCK)) THEN MEM_FREED = MEM_FREED + int(size(THEBLOCK%DIAG_BLOCK),8) DEALLOCATE(THEBLOCK%DIAG_BLOCK) NULLIFY (THEBLOCK%DIAG_BLOCK) ENDIF ENDDO IF (MEM_FREED .GT. 0 ) THEN CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-MEM_FREED, & .TRUE., KEEP8, & IDUMMY, JDUMMY, & .TRUE., .TRUE.) ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_BLR_FREE_ALL_PANELS #if ! defined(NO_SAVE_RESTORE) SUBROUTINE CMUMPS_SAVE_RESTORE_BLR(id_BLRARRAY_ENCODING & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: j1,NbRecords,NbSubRecords,size_array1,dummy,allocok,err INTEGER:: SIZE_GEST_BLR_ARRAY,SIZE_GEST_BLR_ARRAY_j1 INTEGER(8):: SIZE_VARIABLES_BLR_ARRAY,SIZE_VARIABLES_BLR_ARRAY_j1 INTEGER(4) :: I4 NbRecords=0 SIZE_GEST_BLR_ARRAY=0 SIZE_GEST_BLR_ARRAY_j1=0 SIZE_VARIABLES_BLR_ARRAY=0_8 SIZE_VARIABLES_BLR_ARRAY_j1=0_8 SIZE_GEST=0 SIZE_VARIABLES=0_8 if(mode.EQ.memory_save_mode.OR.mode.EQ.save_mode) then call CMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) endif if(mode.EQ.memory_save_mode) then IF(associated(BLR_ARRAY)) THEN NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 DO j1=1,size(BLR_ARRAY,1) CALL CMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_BLR_ARRAY=SIZE_GEST_BLR_ARRAY+ & SIZE_GEST_BLR_ARRAY_j1 SIZE_VARIABLES_BLR_ARRAY=SIZE_VARIABLES_BLR_ARRAY+ & SIZE_VARIABLES_BLR_ARRAY_j1 ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_ARRAY)) THEN NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 write(unit,iostat=err) size(BLR_ARRAY,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 DO j1=1,size(BLR_ARRAY,1) CALL CMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_ARRAY) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 allocate(BLR_ARRAY(size_array1), stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL CMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_BLR_ARRAY=SIZE_GEST_BLR_ARRAY+ & SIZE_GEST_BLR_ARRAY_j1 SIZE_VARIABLES_BLR_ARRAY=SIZE_VARIABLES_BLR_ARRAY+ & SIZE_VARIABLES_BLR_ARRAY_j1 ENDDO endif endif if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(mode.EQ.memory_save_mode) then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_BLR_ARRAY SIZE_GEST=SIZE_GEST+SIZE_GEST_BLR_ARRAY #if defined(MUMPS_NOF2003) SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif call CMUMPS_BLR_MOD_TO_STRUC(id_BLRARRAY_ENCODING) 100 continue RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_BLR SUBROUTINE CMUMPS_SAVE_RESTORE_BLR_STRUC(BLR_STRUC & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(BLR_STRUC_T) :: BLR_STRUC INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER, PARAMETER :: NBVARIABLES_BLR_STRUC_T = 15 INTEGER, PARAMETER :: B_IsSYM=1 INTEGER, PARAMETER :: B_IsT2=2 INTEGER, PARAMETER :: B_IsSLAVE=3 INTEGER, PARAMETER :: B_PANELS_L=4 INTEGER, PARAMETER :: B_PANELS_U=5 INTEGER, PARAMETER :: B_CB_LRB=6 INTEGER, PARAMETER :: B_DIAG_BLOCKS=7 INTEGER, PARAMETER :: B_BEGS_BLR_STATIC=8 INTEGER, PARAMETER :: B_BEGS_BLR_DYNAMIC=9 INTEGER, PARAMETER :: B_BEGS_BLR_L=10 INTEGER, PARAMETER :: B_BEGS_BLR_COL=11 INTEGER, PARAMETER :: B_NB_ACCESSES_INIT=12 INTEGER, PARAMETER :: B_NB_PANELS=13 INTEGER, PARAMETER :: B_NFS4FATHER=14 INTEGER, PARAMETER :: B_M_ARRAY=15 INTEGER(8),dimension(NBVARIABLES_BLR_STRUC_T):: & SIZE_VARIABLES_BLR_STRUC_T INTEGER,dimension(NBVARIABLES_BLR_STRUC_T)::SIZE_GEST_BLR_STRUC_T INTEGER,dimension(NBVARIABLES_BLR_STRUC_T)::NbRecords_BLR_STRUC_T INTEGER:: size_array1,size_array2,dummy,allocok INTEGER:: err,i1,j1,j2,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER::SIZE_GEST_PANELS_L,SIZE_GEST_PANELS_L_j1 INTEGER(8)::SIZE_VARIABLES_PANELS_L,SIZE_VARIABLES_PANELS_L_j1 INTEGER::SIZE_GEST_PANELS_U,SIZE_GEST_PANELS_U_j1 INTEGER(8)::SIZE_VARIABLES_PANELS_U,SIZE_VARIABLES_PANELS_U_j1 INTEGER::SIZE_GEST_CB_LRB,SIZE_GEST_CB_LRB_j1j2 INTEGER(8)::SIZE_VARIABLES_CB_LRB,SIZE_VARIABLES_CB_LRB_j1j2 INTEGER::SIZE_GEST_DIAG_BLOCKS,SIZE_GEST_DIAG_BLOCKS_j1 INTEGER(8)::SIZE_VARIABLES_DIAG_BLOCKS INTEGER(8)::SIZE_VARIABLES_DIAG_BLOCKS_j1 INTEGER(4)::I4 SIZE_VARIABLES_BLR_STRUC_T(:)=0_8 SIZE_GEST_BLR_STRUC_T(:)=0 NbRecords_BLR_STRUC_T(:)=0 SIZE_GEST_PANELS_L=0 SIZE_GEST_PANELS_L_j1=0 SIZE_VARIABLES_PANELS_L=0_8 SIZE_VARIABLES_PANELS_L_j1=0_8 SIZE_GEST_PANELS_U=0 SIZE_GEST_PANELS_U_j1=0 SIZE_VARIABLES_PANELS_U=0_8 SIZE_VARIABLES_PANELS_U_j1=0_8 SIZE_GEST_CB_LRB=0 SIZE_GEST_CB_LRB_j1j2=0 SIZE_VARIABLES_CB_LRB=0_8 SIZE_VARIABLES_CB_LRB_j1j2=0_8 SIZE_GEST_DIAG_BLOCKS=0 SIZE_GEST_DIAG_BLOCKS_j1=0 SIZE_VARIABLES_DIAG_BLOCKS=0_8 SIZE_VARIABLES_DIAG_BLOCKS_j1=0_8 DO i1=1,NBVARIABLES_BLR_STRUC_T SELECT CASE(i1) CASE(B_IsSYM) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsSYM if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsSYM if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_IsT2) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsT2 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsT2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_IsSLAVE) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsSLAVE if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsSLAVE if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_BEGS_BLR_STATIC) NbRecords_BLR_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_STATIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_STATIC,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_STATIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_STATIC,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_STATIC,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_STATIC ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%BEGS_BLR_STATIC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_STATIC(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_STATIC endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_BEGS_BLR_DYNAMIC) NbRecords_BLR_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_DYNAMIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_DYNAMIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_DYNAMIC ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%BEGS_BLR_DYNAMIC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_DYNAMIC(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_DYNAMIC endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_BEGS_BLR_L) NbRecords_BLR_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_L)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_L,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_L)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_L,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_L,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_L ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%BEGS_BLR_L) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_L(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_L endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_BEGS_BLR_COL) NbRecords_BLR_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_COL)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_COL,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_COL)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_COL,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_COL,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_COL ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%BEGS_BLR_COL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_COL(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_COL endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_NB_ACCESSES_INIT) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NB_ACCESSES_INIT if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NB_ACCESSES_INIT if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_NB_PANELS) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NB_PANELS if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NB_PANELS if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_PANELS_L) if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%PANELS_L)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%PANELS_L,1) CALL CMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_L=SIZE_GEST_PANELS_L+ & SIZE_GEST_PANELS_L_j1 SIZE_VARIABLES_PANELS_L=SIZE_VARIABLES_PANELS_L+ & SIZE_VARIABLES_PANELS_L_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%PANELS_L)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%PANELS_L,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%PANELS_L,1) CALL CMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%PANELS_L) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%PANELS_L(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL CMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_L=SIZE_GEST_PANELS_L+ & SIZE_GEST_PANELS_L_j1 SIZE_VARIABLES_PANELS_L=SIZE_VARIABLES_PANELS_L+ & SIZE_VARIABLES_PANELS_L_j1 ENDDO endif endif CASE(B_PANELS_U) if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%PANELS_U)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%PANELS_U,1) CALL CMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_U=SIZE_GEST_PANELS_U+ & SIZE_GEST_PANELS_U_j1 SIZE_VARIABLES_PANELS_U=SIZE_VARIABLES_PANELS_U+ & SIZE_VARIABLES_PANELS_U_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%PANELS_U)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%PANELS_U,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%PANELS_U,1) CALL CMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%PANELS_U) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%PANELS_U(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL CMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_U=SIZE_GEST_PANELS_U+ & SIZE_GEST_PANELS_U_j1 SIZE_VARIABLES_PANELS_U=SIZE_VARIABLES_PANELS_U+ & SIZE_VARIABLES_PANELS_U_j1 ENDDO endif endif CASE(B_CB_LRB) if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%CB_LRB)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%CB_LRB,1) DO j2=1,size(BLR_STRUC%CB_LRB,2) CALL CMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_CB_LRB=SIZE_GEST_CB_LRB+ & SIZE_GEST_CB_LRB_j1j2 SIZE_VARIABLES_CB_LRB=SIZE_VARIABLES_CB_LRB+ & SIZE_VARIABLES_CB_LRB_j1j2 ENDDO ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%CB_LRB)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%CB_LRB,1),size(BLR_STRUC%CB_LRB,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%CB_LRB,1) DO j2=1,size(BLR_STRUC%CB_LRB,2) CALL CMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,save_mode & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%CB_LRB) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%CB_LRB(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 DO j2=1,size_array2 CALL CMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,restore_mode & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_CB_LRB=SIZE_GEST_CB_LRB+ & SIZE_GEST_CB_LRB_j1j2 SIZE_VARIABLES_CB_LRB=SIZE_VARIABLES_CB_LRB+ & SIZE_VARIABLES_CB_LRB_j1j2 ENDDO ENDDO endif endif CASE(B_DIAG_BLOCKS) if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%DIAG_BLOCKS)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%DIAG_BLOCKS,1) CALL CMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_DIAG_BLOCKS=SIZE_GEST_DIAG_BLOCKS+ & SIZE_GEST_DIAG_BLOCKS_j1 SIZE_VARIABLES_DIAG_BLOCKS= & SIZE_VARIABLES_DIAG_BLOCKS+ & SIZE_VARIABLES_DIAG_BLOCKS_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%DIAG_BLOCKS)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%DIAG_BLOCKS,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%DIAG_BLOCKS,1) CALL CMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%DIAG_BLOCKS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%DIAG_BLOCKS(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL CMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_DIAG_BLOCKS=SIZE_GEST_DIAG_BLOCKS+ & SIZE_GEST_DIAG_BLOCKS_j1 SIZE_VARIABLES_DIAG_BLOCKS= & SIZE_VARIABLES_DIAG_BLOCKS+ & SIZE_VARIABLES_DIAG_BLOCKS_j1 ENDDO endif endif CASE(B_NFS4FATHER) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NFS4FATHER if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NFS4FATHER if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_M_ARRAY) if(mode.EQ.restore_mode) then nullify(BLR_STRUC%M_ARRAY) endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_BLR_STRUC_T(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_BLR_STRUC_T(i1)=NbRecords_BLR_STRUC_T(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_BLR_STRUC_T(i1) & +int(SIZE_GEST_BLR_STRUC_T(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_BLR_STRUC_T(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_BLR_STRUC_T(i1) size_read=size_read+SIZE_VARIABLES_BLR_STRUC_T(i1) & +int(SIZE_GEST_BLR_STRUC_T(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_BLR_STRUC_T(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_BLR_STRUC_T) & +SIZE_VARIABLES_PANELS_L & +SIZE_VARIABLES_PANELS_U & +SIZE_VARIABLES_CB_LRB & +SIZE_VARIABLES_DIAG_BLOCKS Local_SIZE_GEST=sum(SIZE_GEST_BLR_STRUC_T) & +SIZE_GEST_PANELS_L & +SIZE_GEST_PANELS_U & +SIZE_GEST_CB_LRB & +SIZE_GEST_DIAG_BLOCKS #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_BLR_STRUC_T) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 100 continue RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_BLR_STRUC SUBROUTINE CMUMPS_SAVE_RESTORE_LRB(LRB_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(LRB_TYPE) :: LRB_T INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER, PARAMETER :: LRB_Q=1 INTEGER, PARAMETER :: LRB_R=2 INTEGER, PARAMETER :: LRB_K=3 INTEGER, PARAMETER :: LRB_M=4 INTEGER, PARAMETER :: LRB_N=5 INTEGER, PARAMETER :: LRB_ISLR=6 INTEGER, PARAMETER :: NBVARIABLES_LRB_TYPE=6 INTEGER(8),dimension(NBVARIABLES_LRB_TYPE):: & SIZE_VARIABLES_LRB_TYPE INTEGER,dimension(NBVARIABLES_LRB_TYPE):: & SIZE_GEST_LRB_TYPE INTEGER,dimension(NBVARIABLES_LRB_TYPE):: & NbRecords_LRB_TYPE INTEGER:: size_array1,size_array2,dummy,allocok INTEGER:: err,i1,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER(4) ::I4 SIZE_VARIABLES_LRB_TYPE(:)=0_8 SIZE_GEST_LRB_TYPE(:)=0 NbRecords_LRB_TYPE(:)=0 DO i1=1,NBVARIABLES_LRB_TYPE SELECT CASE(i1) CASE(LRB_Q) NbRecords_LRB_TYPE(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(LRB_T%Q)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%Q,1)*size(LRB_T%Q,2) & * SIZE_ARITH_DEP ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(LRB_T%Q)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%Q,1)*size(LRB_T%Q,2) & * SIZE_ARITH_DEP write(unit,iostat=err) size(LRB_T%Q,1),size(LRB_T%Q,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) LRB_T%Q ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then nullify(LRB_T%Q) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(size_array1.EQ.-999) then SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size_array1*size_array2*SIZE_ARITH_DEP allocate(LRB_T%Q(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) LRB_T%Q endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_R) NbRecords_LRB_TYPE(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(LRB_T%R)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%R,1)*size(LRB_T%R,2) & * SIZE_ARITH_DEP ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(LRB_T%R)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%R,1)*size(LRB_T%R,2) & * SIZE_ARITH_DEP write(unit,iostat=err) size(LRB_T%R,1),size(LRB_T%R,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) LRB_T%R ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then nullify(LRB_T%R) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(size_array1.EQ.-999) then SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size_array1*size_array2*SIZE_ARITH_DEP allocate(LRB_T%R(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) LRB_T%R endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_K) NbRecords_LRB_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%K if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%K if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_M) NbRecords_LRB_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%M if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%M if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_N) NbRecords_LRB_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%N if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%N if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_ISLR) NbRecords_LRB_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL write(unit,iostat=err) LRB_T%ISLR if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL read(unit,iostat=err) LRB_T%ISLR if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_LRB_TYPE(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_LRB_TYPE(i1)= & NbRecords_LRB_TYPE(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_LRB_TYPE(i1) & +int(SIZE_GEST_LRB_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_LRB_TYPE(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_LRB_TYPE(i1) size_read=size_read+SIZE_VARIABLES_LRB_TYPE(i1) & +int(SIZE_GEST_LRB_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_LRB_TYPE(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_LRB_TYPE) Local_SIZE_GEST=sum(SIZE_GEST_LRB_TYPE) #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_LRB_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 300 continue RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_LRB SUBROUTINE CMUMPS_SAVE_RESTORE_BLR_PANEL(BLR_PANEL_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(blr_panel_type) :: BLR_PANEL_T INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER, PARAMETER :: P_NB_ACCESSES_LEFT=1 INTEGER, PARAMETER :: P_LRB_PANEL=2 INTEGER, PARAMETER :: NBVARIABLES_BLR_PANEL_TYPE = 2 INTEGER(8),dimension(NBVARIABLES_BLR_PANEL_TYPE):: & SIZE_VARIABLES_BLR_PANEL_TYPE INTEGER,dimension(NBVARIABLES_BLR_PANEL_TYPE):: & SIZE_GEST_BLR_PANEL_TYPE INTEGER,dimension(NBVARIABLES_BLR_PANEL_TYPE):: & NbRecords_BLR_PANEL_TYPE INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,j1,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER:: SIZE_GEST_LRB_PANEL_j1,SIZE_GEST_LRB_PANEL INTEGER(8)::SIZE_VARIABLES_LRB_PANEL_j1,SIZE_VARIABLES_LRB_PANEL INTEGER(4)::I4 SIZE_VARIABLES_BLR_PANEL_TYPE(:)=0_8 SIZE_GEST_BLR_PANEL_TYPE(:)=0 NbRecords_BLR_PANEL_TYPE(:)=0 SIZE_GEST_LRB_PANEL_j1=0 SIZE_GEST_LRB_PANEL=0 SIZE_VARIABLES_LRB_PANEL_j1=0_8 SIZE_VARIABLES_LRB_PANEL=0_8 DO i1=1,NBVARIABLES_BLR_PANEL_TYPE SELECT CASE(i1) CASE(P_NB_ACCESSES_LEFT) NbRecords_BLR_PANEL_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT write(unit,iostat=err) BLR_PANEL_T%NB_ACCESSES_LEFT if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT read(unit,iostat=err) BLR_PANEL_T%NB_ACCESSES_LEFT if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 endif CASE(P_LRB_PANEL) if(mode.EQ.memory_save_mode) then IF(associated(BLR_PANEL_T%LRB_PANEL)) THEN NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 DO j1=1,size(BLR_PANEL_T%LRB_PANEL,1) CALL CMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_LRB_PANEL=SIZE_GEST_LRB_PANEL+ & SIZE_GEST_LRB_PANEL_j1 SIZE_VARIABLES_LRB_PANEL=SIZE_VARIABLES_LRB_PANEL+ & SIZE_VARIABLES_LRB_PANEL_j1 ENDDO ELSE NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_PANEL_T%LRB_PANEL)) THEN NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 write(unit,iostat=err) size(BLR_PANEL_T%LRB_PANEL,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 DO j1=1,size(BLR_PANEL_T%LRB_PANEL,1) CALL CMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 400 ENDDO ELSE NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_PANEL_T%LRB_PANEL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 if(size_array1.EQ.-999) then NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 else NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 allocate(BLR_PANEL_T%LRB_PANEL(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL CMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_LRB_PANEL=SIZE_GEST_LRB_PANEL+ & SIZE_GEST_LRB_PANEL_j1 SIZE_VARIABLES_LRB_PANEL=SIZE_VARIABLES_LRB_PANEL+ & SIZE_VARIABLES_LRB_PANEL_j1 ENDDO endif endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_BLR_PANEL_TYPE(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_BLR_PANEL_TYPE(i1)= & NbRecords_BLR_PANEL_TYPE(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_BLR_PANEL_TYPE(i1) & +int(SIZE_GEST_BLR_PANEL_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_BLR_PANEL_TYPE(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_BLR_PANEL_TYPE(i1) size_read=size_read+SIZE_VARIABLES_BLR_PANEL_TYPE(i1) & +int(SIZE_GEST_BLR_PANEL_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_BLR_PANEL_TYPE(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_BLR_PANEL_TYPE)+ & SIZE_VARIABLES_LRB_PANEL Local_SIZE_GEST=sum(SIZE_GEST_BLR_PANEL_TYPE)+ & SIZE_GEST_LRB_PANEL #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_BLR_PANEL_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 400 continue RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_BLR_PANEL SUBROUTINE CMUMPS_SAVE_RESTORE_DIAG_BLOCK(DIAG_BLOCK_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(diag_block_type) :: DIAG_BLOCK_T INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER, PARAMETER :: D_DIAG_BLOCK=1 INTEGER, PARAMETER :: NBVARIABLES_DIAG_BLOCK_TYPE = 1 INTEGER(8),dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & SIZE_VARIABLES_DIAG_BLOCK_TYPE INTEGER,dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & SIZE_GEST_DIAG_BLOCK_TYPE INTEGER,dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & NbRecords_DIAG_BLOCK_TYPE INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER(4) :: I4 SIZE_VARIABLES_DIAG_BLOCK_TYPE(:)=0_8 SIZE_GEST_DIAG_BLOCK_TYPE(:)=0 NbRecords_DIAG_BLOCK_TYPE(:)=0 DO i1=1,NBVARIABLES_DIAG_BLOCK_TYPE SELECT CASE(i1) CASE(D_DIAG_BLOCK) NbRecords_DIAG_BLOCK_TYPE(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(DIAG_BLOCK_T%DIAG_BLOCK)) THEN SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size(DIAG_BLOCK_T%DIAG_BLOCK,1) & * SIZE_ARITH_DEP ELSE SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(DIAG_BLOCK_T%DIAG_BLOCK)) THEN SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size(DIAG_BLOCK_T%DIAG_BLOCK,1) & * SIZE_ARITH_DEP write(unit,iostat=err) size(DIAG_BLOCK_T%DIAG_BLOCK,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 write(unit,iostat=err) DIAG_BLOCK_T%DIAG_BLOCK ELSE SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 elseif(mode.EQ.restore_mode) then nullify(DIAG_BLOCK_T%DIAG_BLOCK) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 if(size_array1.EQ.-999) then SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size_array1*SIZE_ARITH_DEP allocate(DIAG_BLOCK_T%DIAG_BLOCK(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) GOTO 200 endif read(unit,iostat=err) DIAG_BLOCK_T%DIAG_BLOCK endif if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 200 endif endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)/ & huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_DIAG_BLOCK_TYPE(i1)= & NbRecords_DIAG_BLOCK_TYPE(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) & +int(SIZE_GEST_DIAG_BLOCK_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_DIAG_BLOCK_TYPE(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) size_read=size_read+SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) & +int(SIZE_GEST_DIAG_BLOCK_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_DIAG_BLOCK_TYPE(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_DIAG_BLOCK_TYPE) Local_SIZE_GEST=sum(SIZE_GEST_DIAG_BLOCK_TYPE) #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_DIAG_BLOCK_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 200 continue RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_DIAG_BLOCK #endif END MODULE CMUMPS_LR_DATA_M MUMPS_5.8.1/src/zfac_mem_free_block_cb.F0000664000175000017500000000562215042446441017745 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, IPOSBLOCK, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP, KEEP8, IN_PLACE_STATS & ) !$ USE OMP_LIB USE MUMPS_LOAD IMPLICIT NONE INTEGER IPOSBLOCK, & LIW, IWPOSCB, N INTEGER(8) :: LA, LRLU, LRLUS, IPTRLU LOGICAL IN_PLACE_STATS INTEGER IW( LIW ), KEEP(500) INTEGER(8) KEEP8(150) INTEGER MYID LOGICAL SSARBR INTEGER SIZFI_BLOCK, SIZFI INTEGER(8) :: SIZFR, SIZFR_BLOCK, SIZFR_BLOCK_EFF, & SIZEHOLE, MEM_INC, DYNSIZE_BLOCK INCLUDE 'mumps_headers.h' SIZFI_BLOCK=IW(IPOSBLOCK+XXI) CALL MUMPS_GETI8( SIZFR_BLOCK, IW(IPOSBLOCK+XXR) ) CALL MUMPS_GETI8( DYNSIZE_BLOCK,IW(IPOSBLOCK+XXD) ) IF (DYNSIZE_BLOCK .GT. 0_8) THEN SIZFR_BLOCK_EFF = 0_8 ELSE IF (KEEP(216).eq.3 & ) THEN SIZFR_BLOCK_EFF = SIZFR_BLOCK ELSE CALL ZMUMPS_SIZEFREEINREC( IW(IPOSBLOCK), & LIW-IPOSBLOCK+1, & SIZEHOLE, KEEP(IXSZ)) SIZFR_BLOCK_EFF = SIZFR_BLOCK - SIZEHOLE ENDIF IF (.NOT. IN_PLACE_STATS) THEN LRLUS = LRLUS + SIZFR_BLOCK_EFF IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) - SIZFR_BLOCK_EFF ELSE !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - SIZFR_BLOCK_EFF !$OMP END ATOMIC ENDIF ENDIF IF ( IPOSBLOCK .eq. IWPOSCB + 1 ) THEN IPTRLU = IPTRLU + SIZFR_BLOCK IWPOSCB = IWPOSCB + SIZFI_BLOCK LRLU = LRLU + SIZFR_BLOCK MEM_INC = -SIZFR_BLOCK_EFF IF (IN_PLACE_STATS) THEN MEM_INC= 0_8 ENDIF CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,MEM_INC,KEEP,KEEP8,LRLUS) 90 IF ( IWPOSCB .eq. LIW ) GO TO 100 SIZFI = IW( IWPOSCB+1+XXI ) CALL MUMPS_GETI8( SIZFR, IW(IWPOSCB+1+XXR) ) IF ( IW( IWPOSCB+1+XXS ) .EQ. S_FREE ) THEN IPTRLU = IPTRLU + SIZFR LRLU = LRLU + SIZFR IWPOSCB = IWPOSCB + SIZFI GO TO 90 ENDIF 100 CONTINUE IW( IWPOSCB+1+XXP)=TOP_OF_STACK ELSE IW( IPOSBLOCK +XXS)=S_FREE CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,-SIZFR_BLOCK_EFF,KEEP,KEEP8,LRLUS) END IF RETURN END SUBROUTINE ZMUMPS_FREE_BLOCK_CB_STATIC MUMPS_5.8.1/src/sfac_scalings_simScaleAbs.F0000664000175000017500000017437015042446441020421 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SIMSCALEABS(IRN_loc, JCN_loc, A_loc, NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, SYM, NB1, NB2, NB3, EPS, & ONENORMERR,INFNORMERR) C---------------------------------------------------------------------- C IF SYM=0 CALLs unsymmetric variant SMUMPS_SIMSCALEABSUNS. C IF SYM=2 CALLS symmetric variant where only one of a_ij and a_ji C is stored. SMUMPS_SIMSCALEABSSYM C--------------------------------------------------------------------- C For details, see the two subroutines below C SMUMPS_SIMSCALEABSUNS and SMUMPS_SIMSCALEABSSYM C --------------------------------------------------------------------- C !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) NZ_loc INTEGER(8) :: IWRKSZ INTEGER(8) :: ISZWRKRC, LWRKR_TH, LWRKC_TH INTEGER :: NOMP_MAX INTEGER M, N, OP INTEGER NUMPROCS, MYID, COMM INTEGER(8) :: INTSZ, RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) REAL A_loc(NZ_loc) INTEGER RPARTVEC(M) INTEGER RSNDRCVSZ(2*NUMPROCS) INTEGER CPARTVEC(N) INTEGER CSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER(8) :: REGISTRE(12) REAL ROWSCA(M) REAL COLSCA(N) REAL WRKRC(ISZWRKRC) REAL WRKR_TH(LWRKR_TH,max(NOMP_MAX,1)) REAL WRKC_TH(LWRKC_TH,max(NOMP_MAX,1)) REAL ONENORMERR,INFNORMERR C LOCALS C FOR the scaling phase INTEGER SYM, NB1, NB2, NB3 REAL EPS C EXTERNALS EXTERNAL SMUMPS_SIMSCALEABSUNS,SMUMPS_SIMSCALEABSSYM, & SMUMPS_INITREAL C MUST HAVE IT INTEGER I INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER :: NOMP !$ INTEGER :: CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = omp_get_max_threads() !$ CHUNK= max(K361/2, (N+NOMP-1) / NOMP ) !$ ENDIF IF(SYM.EQ.0) THEN CALL SMUMPS_SIMSCALEABSUNS(IRN_loc, JCN_loc, A_loc, & NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, NOMP_MAX, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) ELSE CALL SMUMPS_SIMSCALEABSSYM(IRN_loc, JCN_loc, A_loc, & NZ_loc, & N, NUMPROCS, MYID, COMM, & RPARTVEC, & RSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, NOMP_MAX, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) IF (OP.EQ.2) THEN IF (NOMP_MAX.LE.0) THEN DO I=1,N COLSCA(I) = ROWSCA(I) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1,N COLSCA(I) = ROWSCA(I) ENDDO ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SIMSCALEABS SUBROUTINE SMUMPS_SIMSCALEABSUNS(IRN_loc, JCN_loc, A_loc, NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, NOMP_MAX, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) C---------------------------------------------------------------------- C Input parameters: C M, N: size of matrix (in general M=N, but the algorithm C works for rectangular matrices as well (norms other than C inf-norm are not possible mathematically in this case). C NUMPROCS, MYID, COMM: guess what are those C RPARTVEC: row partvec to be filled when OP=1 C CPARTVEC: col partvec to be filled when OP=1 C RSNDRCVSZ: send recv sizes for row operations. C to be filled when OP=1 C CSNDRCVSZ: send recv sizes for col operations. C to be filled when OP=1 C REGISTRE: to store some pointers (size etc) C IWRK: working space. when OP=1 IWRKSZ.GE.4*MAXMN C when OP=2 INTSZ portion is used. Thus, IWRKSZ>INTSZ C when OP=2 C IWRKSZ: size C INTSZ: to be computed when OP=1, necessary integer space to run C scaling algo when OP=2 C RESZ: to be computed when OP=1, necessary real space to run C scaling algo when OP=2 C OP: C =1 estimation of memory and construction of partvecs C writes into RPARTVEC,CPARTVEC,RSNDRCVSZ,CSNDRCVSZ,REGISTRE C does not access WRKRC, uses IWRK as workspace C computes INTSZ and RESZ. C =2 Compute scalings C restores pointers from REGISTRE, C stores communication structure in IWRK (from the start). C C ROWSCA: space for row scaling factor; has size M C COLSCA: space for col scaling factor; has size N C WRKRC: real working space. when OP=1, is not accessed. Thus, it C can be declared to be of size 1 at OP=1 call. C ISZWRKRC: size C SYM: is matrix symmetric C NB1, NB2, NB3: algo runs C NB1 iters of inf-norm (default 1/1), C NB2 iters of 1-norm (default 3/10), C NB3 iters of inf-norm (default 3/10). C in succession. C EPS: tolerance for concergence. C IF EPS < 0.R0 then does not test convergence. C If convergence occured during the first set of inf-norm C iterations, we start performing one-norm iterations. C If convergence occured during the one-norm iterations, C we start performing the second set of inf-norm iterations. C If convergence occured during the second set of inf-norm, C we prepare to return. C ONENORMERR : error in one norm scaling (associated with the scaling C arrays of the previous iterations), C INFNORMERR : error in inf norm scaling (associated with the scaling C arrays of the previous iterations). C--------------------------------------------------------------------- C On input: C OP=1==>Requirements C IWRKSZ.GE.4*MAXMN C RPARTVEC of size M C CPARTVEC of size N C RSNDRCVSZ of size 2*NUMPROCS C CSNDRCVSZ of size 2*NUMPROCS C REGISTRE of size 12 C C OP=2==>Requirements C INTSZ .GE. REGISTRE(11) C RESZ .GE. REGISTRE(12) C--------------------------------------------------------------------- C On output: C ROWSCA and COLSCA C at processor 0 of COMM: complete factors. C at other processors : only the ROWSCA(i) or COLSCA(j) C for which there is a nonzero a_i* or a_*j are useful. C ONENORMERR : error in one norm scaling C = -1.0 if iter2=0. C INFNORMERR : error in inf norm scaling C = inf norm error at iter3 if iter3 > 0 C = inf norm error at iter1 if iter1 > 0, iter3=0 C = -1.0 if iter1=iter3=0 C --------------------------------------------------------------------- C References: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C C The parallelization approach is discussed in C [3] P. R. Amestoy, I. S. Duff, D. Ruiz, and B. Ucar, C "A parallel matrix scaling algorithm". C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, Jan'08. C and was supported by ANR-SOLSTICE project (ANR-06-CIS6-010) C --------------------------------------------------------------------- !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER(8) :: IWRKSZ, INTSZ INTEGER(8) :: ISZWRKRC, LWRKR_TH, LWRKC_TH INTEGER :: M, N, OP INTEGER :: NUMPROCS, MYID, COMM, NOMP_MAX INTEGER(8) :: RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) REAL A_loc(NZ_loc) INTEGER RPARTVEC(M) INTEGER CPARTVEC(N) INTEGER RSNDRCVSZ(2*NUMPROCS) INTEGER CSNDRCVSZ(2*NUMPROCS) INTEGER(8) :: REGISTRE(12) INTEGER IWRK(IWRKSZ) REAL ROWSCA(M) REAL COLSCA(N) REAL WRKRC(ISZWRKRC) REAL WRKR_TH(LWRKR_TH,max(NOMP_MAX,1)) REAL WRKC_TH(LWRKC_TH,max(NOMP_MAX,1)) REAL ONENORMERR,INFNORMERR C LOCALS INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER ICSNDRCVNUM, OCSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER ICSNDRCVVOL, OCSNDRCVVOL INTEGER INUMMYR, INUMMYC C IMPORTANT POINTERS INTEGER(8) :: IMYRPTR,IMYCPTR INTEGER(8) :: IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER(8) :: ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER(8) :: ICNGHBPRCS, ICSNDRCVIA,ICSNDRCVJA INTEGER(8) :: OCNGHBPRCS, OCSNDRCVIA,OCSNDRCVJA INTEGER(8) :: ISTATUS, REQUESTS, TMPWORK INTEGER(8) :: ITDRPTR, ITDCPTR, ISRRPTR INTEGER(8) :: OSRRPTR, ISRCPTR, OSRCPTR C FOR the scaling phase INTEGER NB1, NB2, NB3 REAL EPS C Iteration vars INTEGER ITER, IR, IC INTEGER(8) :: NZIND REAL ELM C COMM TAGS.... INTEGER TAG_COMM_COL PARAMETER(TAG_COMM_COL=100) INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) C FUNCTIONS EXTERNAL SMUMPS_CREATEPARTVEC, & SMUMPS_NUMVOLSNDRCV, & SMUMPS_SETUPCOMMS, & SMUMPS_FILLMYROWCOLINDICES, & SMUMPS_INITREAL, & SMUMPS_INITREALLST, & SMUMPS_DOCOMMINF, & SMUMPS_DOCOMM1N REAL SMUMPS_ERRSCALOC REAL SMUMPS_ERRSCA1 INTRINSIC abs REAL RONE, RZERO PARAMETER(RONE=1.0E0,RZERO=0.0E0) C TMP VARS INTEGER(8) :: RESZR, RESZC INTEGER(8) :: INTSZR, INTSZC INTEGER MAXMN INTEGER I, IERROR, IOMP REAL ONEERRROW, ONEERRCOL, ONEERRL, ONEERRG REAL INFERRROW, INFERRCOL, INFERRL, INFERRG LOGICAL OORANGEIND INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER :: NOMP !$ INTEGER :: CHUNK, CHUNK_NZ !$ ! Too large => pb with cache L3 ? !$ ! INTEGER(8) :: CHUNK8 !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = omp_get_max_threads() !$ CHUNK = max(K361/2, (N+NOMP-1) / NOMP ) !$ ! CHUNK8= (NZ_loc+int(NOMP-1,8) / int(NOMP,8) ) ) !$ CHUNK_NZ = max(K361/2, (N+NOMP_MAX-1) / NOMP_MAX ) !$ ENDIF C OORANGEIND = .FALSE. INFERRG = -RONE ONEERRG = -RONE MAXMN = M IF(MAXMN < N) MAXMN = N C Create row partvec and col partvec IF(OP == 1) THEN IF(NUMPROCS > 1) THEN C Check done outside C IF(IWRKSZ.LT.4*MAXMN) THEN ERROR.... CALL SMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, M, N, & IWRK, IWRKSZ, INUMMYR, NOMP_MAX) CALL SMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & JCN_loc, IRN_loc, NZ_loc, & CPARTVEC, N, M, & IWRK, IWRKSZ, INUMMYC, NOMP_MAX) C Compute sndrcv sizes, store them for later use CALL SMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, M, RPARTVEC, & NZ_loc, IRN_loc, N, JCN_loc, & IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM,ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) CALL SMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, N, CPARTVEC, & NZ_loc, JCN_loc, M, IRN_loc, & ICSNDRCVNUM,ICSNDRCVVOL, & OCSNDRCVNUM,OCSNDRCVVOL, & IWRK,IWRKSZ, & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), COMM) INTSZR = int(IRSNDRCVNUM,8) + int(ORSNDRCVNUM,8) + & int(IRSNDRCVVOL,8) + int(ORSNDRCVVOL,8) + & 2_8*int(NUMPROCS+1,8) + int(INUMMYR,8) INTSZC = int(ICSNDRCVNUM,8) + int(OCSNDRCVNUM,8) + & int(ICSNDRCVVOL,8) + int(OCSNDRCVVOL,8) + & 2_8*int(NUMPROCS+1,8) + int(INUMMYC,8) INTSZ = INTSZR + INTSZC + int(MAXMN,8) + & int(MPI_STATUS_SIZE +1,8) * int(NUMPROCS,8) ELSE C NUMPROCS IS 1 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 ICSNDRCVNUM = 0 OCSNDRCVNUM = 0 ICSNDRCVVOL = 0 OCSNDRCVVOL = 0 INUMMYC = 0 INTSZ = 0_8 ENDIF C CALCULATE NECESSARY REAL SPACE RESZR = int(M,8) + int(IRSNDRCVVOL,8) + int(ORSNDRCVVOL,8) RESZC = int(N,8) + int(ICSNDRCVVOL,8) + int(OCSNDRCVVOL,8) RESZ = RESZR + RESZC C CALCULATE NECESSARY INT SPACE C The last maxmn is tmpwork for setup comm and fillmyrowcol REGISTRE(1) = int(IRSNDRCVNUM,8) REGISTRE(2) = int(ORSNDRCVNUM,8) REGISTRE(3) = int(IRSNDRCVVOL,8) REGISTRE(4) = int(ORSNDRCVVOL,8) REGISTRE(5) = int(ICSNDRCVNUM,8) REGISTRE(6) = int(OCSNDRCVNUM,8) REGISTRE(7) = int(ICSNDRCVVOL,8) REGISTRE(8) = int(OCSNDRCVVOL,8) REGISTRE(9) = int(INUMMYR,8) REGISTRE(10) = int(INUMMYC,8) REGISTRE(11) = INTSZ REGISTRE(12) = RESZ ELSE C else of op=1. That is op=2 now. C restore the numbers IRSNDRCVNUM = int(REGISTRE(1)) ORSNDRCVNUM = int(REGISTRE(2)) IRSNDRCVVOL = int(REGISTRE(3)) ORSNDRCVVOL = int(REGISTRE(4)) ICSNDRCVNUM = int(REGISTRE(5)) OCSNDRCVNUM = int(REGISTRE(6)) ICSNDRCVVOL = int(REGISTRE(7)) OCSNDRCVVOL = int(REGISTRE(8)) INUMMYR = int(REGISTRE(9)) INUMMYC = int(REGISTRE(10)) IF(NUMPROCS > 1) THEN C Check done outsize C IF(INTSZ < REGISTRE(11)) THEN ERROR C IF(RESZ < REGISTRE(12)) THEN ERROR C Fill up myrows and my colsX CALL SMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, CPARTVEC, M, N, & IWRK(1_8), INUMMYR, & IWRK(1_8+int(INUMMYR,8)), INUMMYC, & IWRK(1_8+int(INUMMYR,8)+int(INUMMYC,8)), & IWRKSZ-int(INUMMYR,8)-int(INUMMYC,8), NOMP_MAX ) IMYRPTR = 1_8 IMYCPTR = IMYRPTR + int(INUMMYR,8) C Set up comm and run. C set pointers in iwrk (4 parts) C C ROWS [---------------------------------------------] IRNGHBPRCS = IMYCPTR + int(INUMMYC ,8) IRSNDRCVIA = IRNGHBPRCS + int(IRSNDRCVNUM,8) IRSNDRCVJA = IRSNDRCVIA + int(NUMPROCS+1 ,8) ORNGHBPRCS = IRSNDRCVJA + int(IRSNDRCVVOL,8) ORSNDRCVIA = ORNGHBPRCS + int(ORSNDRCVNUM,8) ORSNDRCVJA = ORSNDRCVIA + int(NUMPROCS+1 ,8) C COLS [---------------------------------------------] ICNGHBPRCS = ORSNDRCVJA + int(ORSNDRCVVOL,8) ICSNDRCVIA = ICNGHBPRCS + int(ICSNDRCVNUM,8) ICSNDRCVJA = ICSNDRCVIA + int(NUMPROCS+1 ,8) OCNGHBPRCS = ICSNDRCVJA + int(ICSNDRCVVOL,8) OCSNDRCVIA = OCNGHBPRCS + int(OCSNDRCVNUM,8) OCSNDRCVJA = OCSNDRCVIA + int(NUMPROCS+1 ,8) C C MPI [-----------------] REQUESTS = OCSNDRCVJA + int(OCSNDRCVVOL,8) ISTATUS = REQUESTS + int(NUMPROCS,8) C C TMPWRK [-----------------] TMPWORK = ISTATUS + int(MPI_STATUS_SIZE,8)*int(NUMPROCS,8) CALL SMUMPS_SETUPCOMMS(MYID, NUMPROCS, M, RPARTVEC, & NZ_loc, IRN_loc,N, JCN_loc, & IRSNDRCVNUM, IRSNDRCVVOL, & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_ROW, COMM) CALL SMUMPS_SETUPCOMMS(MYID, NUMPROCS, N, CPARTVEC, & NZ_loc, JCN_loc, M, IRN_loc, & ICSNDRCVNUM, ICSNDRCVVOL, & IWRK(ICNGHBPRCS), & IWRK(ICSNDRCVIA), & IWRK(ICSNDRCVJA), & OCSNDRCVNUM, OCSNDRCVVOL, & IWRK(OCNGHBPRCS),IWRK(OCSNDRCVIA),IWRK(OCSNDRCVJA), & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_COL, COMM) CALL SMUMPS_INITREAL(ROWSCA, M, RZERO, NOMP_MAX) CALL SMUMPS_INITREAL(COLSCA, N, RZERO, NOMP_MAX) CALL SMUMPS_INITREALLST(ROWSCA, M, & IWRK(IMYRPTR),INUMMYR, RONE, NOMP_MAX) CALL SMUMPS_INITREALLST(COLSCA, N, & IWRK(IMYCPTR),INUMMYC, RONE, NOMP_MAX) ELSE CALL SMUMPS_INITREAL(ROWSCA, M, RONE, NOMP_MAX) CALL SMUMPS_INITREAL(COLSCA, N, RONE, NOMP_MAX) ENDIF ITDRPTR = 1_8 ITDCPTR = ITDRPTR + int(M,8) C ISRRPTR = ITDCPTR + int(N,8) OSRRPTR = ISRRPTR + int(IRSNDRCVVOL,8) C ISRCPTR = OSRRPTR + int(ORSNDRCVVOL,8) OSRCPTR = ISRCPTR + int(ICSNDRCVVOL,8) C To avoid bound check errors... IF(NUMPROCS == 1)THEN OSRCPTR = OSRCPTR - 1_8 ISRCPTR = ISRCPTR - 1_8 OSRRPTR = OSRRPTR - 1_8 ISRRPTR = ISRRPTR - 1_8 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1_8 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1_8 IF(ICSNDRCVVOL == 0) ISRCPTR = ISRCPTR - 1_8 IF(OCSNDRCVVOL == 0) OSRCPTR = OSRCPTR - 1_8 ENDIF ITER = 1 DO WHILE (ITER.LE.NB1+NB2+NB3) C{ C ------------------------- C CLEAR temporary Dr and Dc C ------------------------- IF (NOMP_MAX.GT.1 .AND. & (ITER.GT.NB1 .AND.ITER.LE.NB1+NB2) & ) THEN C{ !$OMP PARALLEL !$OMP& PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 IF(NUMPROCS > 1) THEN CALL SMUMPS_ZEROOUT(WRKR_TH(1,IOMP),N, & IWRK(IMYRPTR),INUMMYR, 0) CALL SMUMPS_ZEROOUT(WRKC_TH(1,IOMP),N, & IWRK(IMYCPTR),INUMMYC, 0) ELSE CALL SMUMPS_INITREAL(WRKR_TH(1,IOMP),N, RZERO, & 0) CALL SMUMPS_INITREAL(WRKC_TH(1,IOMP),N, RZERO, & 0) ENDIF !$OMP END PARALLEL C} ELSE C{ IF(NUMPROCS > 1) THEN CALL SMUMPS_ZEROOUT(WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) CALL SMUMPS_ZEROOUT(WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) ELSE CALL SMUMPS_INITREAL(WRKRC(ITDRPTR),M, RZERO, & NOMP_MAX) CALL SMUMPS_INITREAL(WRKRC(ITDCPTR),N, RZERO, & NOMP_MAX) ENDIF C} ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN C ------------------ C INF-NORM ITERATION C ------------------ IF (NOMP_MAX.LE.0) THEN IF((ITER.EQ.1).OR.(OORANGEIND)) THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) IF(WRKRC(IR) int(K361,8) .AND. NOMP .GT. 1) !$OMP& REDUCTION(.OR.:OORANGEIND) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) !$OMP ATOMIC UPDATE WRKRC(IR)= max (ELM, WRKRC(IR)) !$OMP END ATOMIC C IF(WRKRC(ITDRPTR-1_8+int(IR,8)) int4 !$OMP ATOMIC UPDATE WRKRC(ITDCPTR-1_8+int(IC,8)) = & max (ELM,WRKRC(ITDCPTR-1_8+int(IC,8))) !$OMP END ATOMIC ELSE OORANGEIND = .TRUE. ENDIF ENDDO !$OMP END PARALLEL DO ELSEIF(.NOT.OORANGEIND) THEN !$OMP PARALLEL DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) DO NZIND=1,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) C IF(WRKRC(ITDRPTR-1_8+int(IR,8)) 1) THEN CALL SMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, & ICSNDRCVNUM,IWRK(ICNGHBPRCS), & ICSNDRCVVOL,IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), & WRKRC(ISRCPTR), & OCSNDRCVNUM,IWRK(OCNGHBPRCS), & OCSNDRCVVOL,IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), & WRKRC( OSRCPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) C CALL SMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, & IRSNDRCVNUM,IWRK(IRNGHBPRCS), & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM,IWRK(ORNGHBPRCS), & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = SMUMPS_ERRSCALOC(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) C find error for the cols INFERRCOL = SMUMPS_ERRSCALOC(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) C get max of those two errors INFERRL = INFERRCOL IF(INFERRROW > INFERRL ) THEN INFERRL = INFERRROW ENDIF C CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL SMUMPS_UPDATESCALE(COLSCA, & WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) CALL SMUMPS_UPDATESCALE(ROWSCA, & WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE C SINGLE PROCESSOR CASE: INF-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = SMUMPS_ERRSCA1(ROWSCA, & WRKRC(ITDRPTR), M, NOMP_MAX) C find error for the cols INFERRCOL = SMUMPS_ERRSCA1(COLSCA, & WRKRC(ITDCPTR), N, NOMP_MAX) C get max of those two errors INFERRL = INFERRCOL IF(INFERRROW > INFERRL) THEN INFERRL = INFERRROW ENDIF INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL SMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N, & NOMP_MAX) CALL SMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M, & NOMP_MAX) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE C ---------------------------------------- C WE HAVE ITER.GT.NB1 AND ITER.LE.NB1+NB2. C ONE-NORM ITERATION C ---------------------------------------- IF (NOMP_MAX.LE.1) THEN IF((ITER .EQ.1).OR.(OORANGEIND))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) C WRKRC(ITDRPTR-1_8+int(IR,8)) = C & WRKRC(ITDRPTR-1_8+int(IR,8)) + ELM WRKRC(IR) = WRKRC(IR) + ELM WRKRC(ITDCPTR-1_8+int(IC,8)) = & WRKRC(ITDCPTR-1_8+int(IC,8)) + ELM ELSE OORANGEIND = .TRUE. ENDIF ENDDO ELSEIF(.NOT.OORANGEIND) THEN DO NZIND=1,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) C WRKRC(ITDRPTR-1_8+int(IR,8)) = C & WRKRC(ITDRPTR-1_8+int(IR,8)) + ELM WRKRC(IR) = WRKRC(IR) + ELM WRKRC(ITDCPTR-1_8+int(IC,8)) = & WRKRC(ITDCPTR-1_8+int(IC,8)) + ELM ENDDO ENDIF C} ELSE ! NOMP_MAX>1 IF((ITER .EQ.1).OR.(OORANGEIND))THEN !$OMP PARALLEL PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 !$OMP DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) !$OMP& REDUCTION(.OR.:OORANGEIND) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) WRKR_TH(IR,IOMP) = WRKR_TH(IR,IOMP) + ELM IF (IR.NE.IC) & WRKC_TH(IC,IOMP) = WRKC_TH(IC,IOMP) + ELM ELSE OORANGEIND = .TRUE. ENDIF ENDDO !$OMP END DO !$OMP END PARALLEL ELSEIF(.NOT.OORANGEIND) THEN !$OMP PARALLEL PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 !$OMP DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) DO NZIND=1,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) WRKR_TH(IR,IOMP) = WRKR_TH(IR,IOMP) + ELM IF (IR.NE.IC) & WRKC_TH(IC,IOMP) = WRKC_TH(IC,IOMP) + ELM ENDDO !$OMP END DO !$OMP END PARALLEL ENDIF C C For all i on MYID: C Build WRKRC(i) = Sum (WRKR_TH(i,IOMP) C IOMP \in [1:NOMP_MAX] IF(NUMPROCS > 1) THEN CALL SMUMPS_REDUCE_WRK_MPI (WRKRC, N, WRKR_TH, & NOMP_MAX, & IWRK(IMYRPTR),INUMMYR) CALL SMUMPS_REDUCE_WRK_MPI (WRKRC(ITDCPTR), & N, WRKC_TH, NOMP_MAX, & IWRK(IMYCPTR),INUMMYC) ELSE CALL SMUMPS_REDUCE_WRK (WRKRC, N, WRKR_TH, NOMP_MAX) CALL SMUMPS_REDUCE_WRK (WRKRC(ITDCPTR), & N, WRKC_TH, NOMP_MAX) ENDIF C} ENDIF IF(NUMPROCS > 1) THEN CALL SMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, & ICSNDRCVNUM, IWRK(ICNGHBPRCS), & ICSNDRCVVOL, IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), & WRKRC(ISRCPTR), & OCSNDRCVNUM, IWRK(OCNGHBPRCS), & OCSNDRCVVOL, IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), & WRKRC( OSRCPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) C CALL SMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, & IRSNDRCVNUM, IWRK(IRNGHBPRCS), & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM, IWRK(ORNGHBPRCS), & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = SMUMPS_ERRSCALOC(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) C find error for the cols ONEERRCOL = SMUMPS_ERRSCALOC(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) C get max of those two errors ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL ) THEN ONEERRL = ONEERRROW ENDIF C CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL SMUMPS_UPDATESCALE(COLSCA, & WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) CALL SMUMPS_UPDATESCALE(ROWSCA, & WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE C SINGLE-PROCESSOR CASE: ONE-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = SMUMPS_ERRSCA1(ROWSCA, & WRKRC(ITDRPTR), M, NOMP_MAX) C find error for the cols ONEERRCOL = SMUMPS_ERRSCA1(COLSCA, & WRKRC(ITDCPTR), N, NOMP_MAX) C get max of those two errors ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL) THEN ONEERRL = ONEERRROW ENDIF ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL SMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N, & NOMP_MAX) CALL SMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M, & NOMP_MAX) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL SMUMPS_UPDATESCALE(COLSCA, WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) CALL SMUMPS_UPDATESCALE(ROWSCA, WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) C ELSE C SINGLE PROCESSOR CASE: Conv check and update of sca arrays CALL SMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N, & NOMP_MAX) CALL SMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M, & NOMP_MAX) ENDIF ITER = ITER + 1 C} ENDDO ONENORMERR = ONEERRG INFNORMERR = INFERRG IF(NUMPROCS > 1) THEN C{ CALL MPI_REDUCE(ROWSCA, WRKRC(1), M, MPI_REAL, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN DO I=1, M ROWSCA(I) = WRKRC(I) ENDDO ENDIF C Scaling factors are printed C WRITE (6,*) MYID, 'ROWSCA=',ROWSCA C WRITE (6,*) MYID, 'COLSCA=',COLSCA C CALL FLUSH(6) c REduce the whole scaling factors to processor 0 of COMM CALL MPI_REDUCE(COLSCA, WRKRC(1_8+int(M,8)), N, & MPI_REAL, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN C{ IF (NOMP_MAX.LE.0) THEN DO I=1, N COLSCA(I) = WRKRC(int(I,8)+int(M,8)) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1, N COLSCA(I) = WRKRC(int(I,8)+int(M,8)) ENDDO !$OMP END PARALLEL DO ENDIF C} ENDIF C} ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SIMSCALEABSUNS C C C SEPARATOR: Another function begins C C SUBROUTINE SMUMPS_SIMSCALEABSSYM(IRN_loc, JCN_loc, A_loc, NZ_loc, & N, NUMPROCS, MYID, COMM, & PARTVEC, & RSNDRCVSZ, & REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & SCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, NOMP_MAX, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) C---------------------------------------------------------------------- C Input parameters: C N: size of matrix (sym matrix, square). C NUMPROCS, MYID, COMM: guess what are those C PARTVEC: row/col partvec to be filled when OP=1 C RSNDRCVSZ:send recv sizes for row/col operations. C to be filled when OP=1 C REGISTRE: to store some pointers (size etc). Its size is 12, C but we do not use all in this routine. C IWRK: working space. when OP=1 IWRKSZ.GE.2*MAXMN C when OP=2 INTSZ portion is used. Donc, IWRKSZ>INTSZ C when OP=2 C IWRKSZ: size C INTSZ: to be computed when OP=1, necessary integer space to run C scaling algo when OP=2 C RESZ: to be computed when OP=1, necessary real space to run C scaling algo when OP=2 C OP: C =1 estimation of memory and construction of partvecs C writes into PARTVEC,RSNDRCVSZ,REGISTRE C does not access WRKRC, uses IWRK as workspace C computes INTSZ and RESZ. C =2 Compute scalings C restores pointers from REGISTRE, C stores communication structure in IWRK (from the start). C C SCA: space for row/col scaling factor; has size M C WRKRC: real working space. when OP=1, is not accessed. Donc, it C can be declared to be of size 1 at OP=1 call. C ISZWRKRC: size C SYM: is matrix symmetric C NB1, NB2, NB3: algo runs C NB1 iters of inf-norm (default 1/1), C NB2 iters of 1-norm (default 3/10), C NB3 iters of inf-norm (default 3/10). C in succession. C EPS: tolerance for concergence. C IF EPS < 0.R0 then does not test convergence. C See comments for the uns case above. C ONENORMERR : error in one norm scaling (see comments for the C uns case above), C INFNORMERR : error in inf norm scaling (see comments for the C uns case above). C--------------------------------------------------------------------- C On input: C OP=1==>Requirements C IWRKSZ.GE.2*MAXMN XXXX compare with uns variant. C PARTVEC of size N C SNDRCVSZ of size 2*NUMPROCS C REGISTRE of size 12 C C OP=2==>Requirements C INTSZ .GE. REGISTRE(11) C RESZ .GE. REGISTRE(12) C--------------------------------------------------------------------- C On output: C SCA C at processor 0 of COMM: complete factors. C at other processors : only the SCA(i) and SCA(j) C for which there is a nonzero a_ij. C ONENORMERR : error in one norm scaling C = -1.0 if iter2=0. C INFNORMERR : error in inf norm scaling C = inf norm error at iter3 if iter3 > 0 C = inf norm error at iter1 if iter1 > 0, iter3=0 C = -1.0 if iter1=iter3=0 C --------------------------------------------------------------------- C NOTE: some variables are named in such a way that they correspond C to the row variables in unsym case. They are used for both C row and col communications. C --------------------------------------------------------------------- C References: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C C The parallelization approach is based on discussion in C [3] P. R. Amestoy, I. S. Duff, D. Ruiz, and B. Ucar, "A parallel C matrix scaling algorithm", accepted for publication, C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, Jan'08. C and was supported by ANR-SOLSTICE project (ANR-06-CIS6-010) C --------------------------------------------------------------------- !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER N, OP INTEGER(8) :: IWRKSZ, LWRKR_TH INTEGER NUMPROCS, MYID, COMM, NOMP_MAX INTEGER(8) :: 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(8) :: REGISTRE(12) REAL SCA(N) INTEGER(8) :: ISZWRKRC REAL WRKRC(ISZWRKRC), & WRKR_TH(LWRKR_TH, max(NOMP_MAX,1)) C LOCALS INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER INUMMYR C IMPORTANT POINTERS INTEGER(8) :: IMYRPTR,IMYCPTR INTEGER(8) :: IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER(8) :: ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER(8) :: ISTATUS, REQUESTS, TMPWORK INTEGER(8) :: ITDRPTR, ISRRPTR, OSRRPTR REAL ONENORMERR,INFNORMERR C FOR the scaling phase INTEGER NB1, NB2, NB3 REAL EPS C Iteration vars INTEGER ITER, IR, IC INTEGER(8) :: NZIND REAL ELM C COMM TAGS.... INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) C FUNCTIONS EXTERNAL SMUMPS_CREATEPARTVECSYM, & SMUMPS_NUMVOLSNDRCVSYM, & SMUMPS_SETUPCOMMSSYM, & SMUMPS_FILLMYROWCOLINDICESSYM, & SMUMPS_DOCOMMINF, & SMUMPS_DOCOMM1N, & SMUMPS_INITREAL, & SMUMPS_INITREALLST REAL SMUMPS_ERRSCALOC REAL SMUMPS_ERRSCA1 INTRINSIC abs REAL RONE, RZERO PARAMETER(RONE=1.0E0,RZERO=0.0E0) C TMP VARS INTEGER(8) :: INTSZR INTEGER MAXMN INTEGER I, IERROR REAL ONEERRL, ONEERRG REAL INFERRL, INFERRG LOGICAL OORANGEIND INTEGER, PARAMETER :: K361 = 2048 INTEGER :: IOMP !$ INTEGER :: NOMP !$ INTEGER :: CHUNK, CHUNK_NZ !$ ! Too large => pb with cache L3 ? !$ ! INTEGER(8) :: CHUNK8 !$ ! CHUNK8= max(int(K361/2,8), !$ ! & (NZ_loc+int(NOMP-1,8) / int(NOMP,8) ) ) !$ ! CHUNK8 = min(CHUNK8, huge(CHUNK)-1_8) !$ NOMP = omp_get_max_threads() !$ CHUNK= max(K361/2, (N+NOMP-1) / NOMP ) !$ IF (NOMP_MAX.GT.0) THEN !$ CHUNK_NZ = max(K361/2, (N+NOMP_MAX-1) / NOMP_MAX ) !$ ENDIF C OORANGEIND = .FALSE. INFERRG = -RONE ONEERRG = -RONE MAXMN = N IF(OP == 1) THEN C{ IF(NUMPROCS > 1) THEN C Check done outside C IF(IWRKSZ.LT.2*MAXMN) THEN ERROR.... CALL SMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK, IWRKSZ, INUMMYR ) C C Check done outside CALL SMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc, JCN_loc, IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) C C INTSZR = int(IRSNDRCVNUM,8) + int(ORSNDRCVNUM,8) + & int(IRSNDRCVVOL,8) + int(ORSNDRCVVOL,8) + & 2_8*int(NUMPROCS+1,8) + int(INUMMYR,8) INTSZ = INTSZR + int(N,8) + & int(MPI_STATUS_SIZE +1,8) * int(NUMPROCS,8) ELSE C NUMPROCS IS 1 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 INTSZ = 0_8 ENDIF C CALCULATE NECESSARY REAL SPACE RESZ = int(N,8) + int(IRSNDRCVVOL,8) + int(ORSNDRCVVOL,8) REGISTRE(1) = int(IRSNDRCVNUM,8) REGISTRE(2) = int(ORSNDRCVNUM,8) REGISTRE(3) = int(IRSNDRCVVOL,8) REGISTRE(4) = int(ORSNDRCVVOL,8) REGISTRE(9) = int(INUMMYR,8) REGISTRE(11) = INTSZ REGISTRE(12) = RESZ C} ELSE C{ C else of op=1. That is op=2 now. C restore the numbers IRSNDRCVNUM = int(REGISTRE(1)) ORSNDRCVNUM = int(REGISTRE(2)) IRSNDRCVVOL = int(REGISTRE(3)) ORSNDRCVVOL = int(REGISTRE(4)) INUMMYR = int(REGISTRE(9)) IF(NUMPROCS > 1) THEN C Check done outsize C IF(INTSZ < REGISTRE(11)) THEN ERROR C IF(RESZ < REGISTRE(12)) THEN ERROR C Fill up myrows and my colsX CALL SMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK(1), INUMMYR, & IWRK(1+INUMMYR), IWRKSZ-int(INUMMYR,8), NOMP_MAX) IMYRPTR = 1_8 IMYCPTR = IMYRPTR + int(INUMMYR,8) C Set up comm and run. C set pointers in iwrk (3 parts) C C ROWS [---------------------------------------------] IRNGHBPRCS = IMYCPTR IRSNDRCVIA = IRNGHBPRCS + int(IRSNDRCVNUM,8) IRSNDRCVJA = IRSNDRCVIA + int(NUMPROCS+1,8) ORNGHBPRCS = IRSNDRCVJA + int(IRSNDRCVVOL,8) ORSNDRCVIA = ORNGHBPRCS + int(ORSNDRCVNUM,8) ORSNDRCVJA = ORSNDRCVIA + int(NUMPROCS + 1,8) C MPI [-----------------] REQUESTS = ORSNDRCVJA + int(ORSNDRCVVOL,8) ISTATUS = REQUESTS + int(NUMPROCS,8) C TMPWRK [-----------------] TMPWORK = ISTATUS + int(MPI_STATUS_SIZE,8)*int(NUMPROCS,8) CALL SMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc, JCN_loc, & IRSNDRCVNUM, IRSNDRCVVOL, & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_ROW, COMM) CALL SMUMPS_INITREAL(SCA, N, RZERO, NOMP_MAX) CALL SMUMPS_INITREALLST(SCA, N, & IWRK(IMYRPTR),INUMMYR, RONE, NOMP_MAX) ELSE CALL SMUMPS_INITREAL(SCA, N, RONE, NOMP_MAX) ENDIF ITDRPTR = 1_8 ISRRPTR = ITDRPTR + int(N,8) OSRRPTR = ISRRPTR + int(IRSNDRCVVOL,8) C C To avoid bound check errors... IF(NUMPROCS == 1)THEN OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 ENDIF C computation starts ITER = 1 DO WHILE(ITER.LE.NB1+NB2+NB3) C{ C ------------------------- C CLEAR temporary Dr and Dc C ------------------------- IF (NOMP_MAX.GT.1 .AND. & (ITER.GT.NB1 .AND.ITER.LE.NB1+NB2) & ) THEN C if one norm iteration and multithreading activated C WRKR_TH need be initialized and C WRKRC will be set by reduction of WRKR_TH !$OMP PARALLEL !$OMP& PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 IF(NUMPROCS > 1) THEN CALL SMUMPS_ZEROOUT(WRKR_TH(1,IOMP),N, & IWRK(IMYRPTR),INUMMYR, 0) ELSE CALL SMUMPS_INITREAL(WRKR_TH(1,IOMP),N, RZERO, & 0) ENDIF !$OMP END PARALLEL ELSE IF(NUMPROCS > 1) THEN CFIXME Size N should be adjusted to effective size CALL SMUMPS_ZEROOUT(WRKRC(ITDRPTR),N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) ELSE CALL SMUMPS_INITREAL(WRKRC(ITDRPTR),N, RZERO, & NOMP_MAX) ENDIF ENDIF C IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN C ------------------ C{ INF-NORM ITERATION C ------------------ IF (NOMP_MAX.LE.0) THEN IF((ITER .EQ.1).OR.(OORANGEIND))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) IF (WRKRC(IR) int(K361,8) .AND. NOMP .GT. 1) !$OMP& REDUCTION(.OR.:OORANGEIND) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) !$OMP ATOMIC UPDATE WRKRC(IR)= max (ELM, WRKRC(IR)) !$OMP END ATOMIC C IF(WRKRC(ITDRPTR-1_8+int(IR,8)) int(K361,8) .AND. NOMP .GT. 1) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) !$OMP ATOMIC UPDATE WRKRC(IR)= max (ELM, WRKRC(IR)) !$OMP END ATOMIC C IF(WRKRC(ITDRPTR-1_8+int(IR,8)) 1) THEN C{ CALL SMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, & IRSNDRCVNUM,IWRK(IRNGHBPRCS), & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM,IWRK(ORNGHBPRCS), & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) CCCC FIXME #if defined(dev_version) IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = SMUMPS_ERRSCALOC(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL SMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF CCC #endif C} ELSE C{ SINGLE PROCESSOR CASE: INF-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = SMUMPS_ERRSCA1(SCA, & WRKRC(ITDRPTR), N, NOMP_MAX) INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL SMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N, & NOMP_MAX) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF C} ENDIF C} ELSE C ---------------------------------------- C{ WE HAVE ITER.GT.NB1 AND ITER.LE.NB1+NB2. C ONE-NORM ITERATION C ---------------------------------------- IF (NOMP_MAX.LE.1) THEN IF((ITER.EQ.1).OR.(OORANGEIND))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKRC(IR) = WRKRC(IR) + ELM IF(IR.NE.IC) THEN WRKRC(IC) = WRKRC(IC) + ELM ENDIF ELSE OORANGEIND = .TRUE. ENDIF ENDDO ELSEIF(.NOT.OORANGEIND)THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKRC(IR) = WRKRC(IR) + ELM IF(IR.NE.IC) THEN WRKRC(IC) = WRKRC(IC) + ELM ENDIF ENDDO ENDIF ELSE ! NOMP_MAX>1 IF((ITER.EQ.1).OR.(OORANGEIND))THEN !$OMP PARALLEL PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 !$OMP DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) !$OMP& REDUCTION(.OR.:OORANGEIND) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKR_TH(IR,IOMP) = WRKR_TH(IR,IOMP) + ELM IF(IR.NE.IC) THEN WRKR_TH(IC,IOMP) = WRKR_TH(IC,IOMP) + ELM ENDIF ELSE OORANGEIND = .TRUE. ENDIF ENDDO !$OMP END DO !$OMP END PARALLEL ELSEIF(.NOT.OORANGEIND)THEN !$OMP PARALLEL PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 !$OMP DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKR_TH(IR,IOMP) = WRKR_TH(IR,IOMP) + ELM IF(IR.NE.IC) THEN WRKR_TH(IC,IOMP) = WRKR_TH(IC,IOMP) + ELM ENDIF ENDDO !$OMP END DO !$OMP END PARALLEL C} ENDIF C C For all i on MYID: C Build WRKRC(i) = Sum (WRKR_TH(i,IOMP) C IOMP \in [1:NOMP_MAX] IF(NUMPROCS > 1) THEN CALL SMUMPS_REDUCE_WRK_MPI (WRKRC, N, WRKR_TH, & NOMP_MAX, & IWRK(IMYRPTR),INUMMYR) ELSE CALL SMUMPS_REDUCE_WRK (WRKRC, N, WRKR_TH, NOMP_MAX) ENDIF ENDIF IF(NUMPROCS > 1) THEN C{ CALL SMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, & IRSNDRCVNUM, IWRK(IRNGHBPRCS), & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM, IWRK(ORNGHBPRCS), & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = SMUMPS_ERRSCALOC(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) C mpi allreduce. CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL SMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF C} ELSE C{ SINGLE-PROCESSOR CASE: ONE-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = SMUMPS_ERRSCA1(SCA, & WRKRC(ITDRPTR), N, NOMP_MAX) ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL SMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N, & NOMP_MAX) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF C} ENDIF IF(NUMPROCS > 1) THEN CALL SMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) ELSE CALL SMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N, & NOMP_MAX) ENDIF ITER = ITER + 1 C} ENDDO ONENORMERR = ONEERRG INFNORMERR = INFERRG IF(NUMPROCS > 1) THEN C{ CALL MPI_REDUCE(SCA, WRKRC(1), N, MPI_REAL, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN IF (NOMP_MAX.LE.0) THEN DO I=1, N SCA(I) = WRKRC(I) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1, N SCA(I) = WRKRC(I) ENDDO !$OMP END PARALLEL DO ENDIF ENDIF C} ENDIF C} ENDIF RETURN END SUBROUTINE SMUMPS_SIMSCALEABSSYM MUMPS_5.8.1/src/dfac_front_type2_aux.F0000664000175000017500000007633415042446437017467 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_FRONT_TYPE2_AUX_M CONTAINS SUBROUTINE DMUMPS_FAC_I_LDLT_NIV2( & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, & NFRONT, NASS, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK, & NASS2, TIPIV, & N, INODE, IW, LIW, A, LA, NNEGW, NNULLNEGW, & NB22T2W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INOPV, IFLAG,IERROR, & IOLDPS, POSELT, UU, & SEUIL,KEEP,KEEP8,PIVSIZ, & DKEEP, PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & PP_FIRST2SWAP_L, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled, & PIVOT_OPTION, & Inextpiv, IEND_BLR, LR_ACTIVATED, & OOC_EFFECTIVE_ON_FRONT) USE MUMPS_OOC_COMMON, ONLY : TYPEF_L USE DMUMPS_FAC_FRONT_AUX_M USE MUMPS_PIVNUL_MOD IMPLICIT NONE INTEGER SIZEDIAG_ORIG DOUBLE PRECISION DIAG_ORIG(SIZEDIAG_ORIG) DOUBLE PRECISION GW_FACTCUMUL INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,IERROR,INOPV INTEGER NASS2, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK INTEGER, intent(inout) :: NNEGW, NNULLNEGW, NB22T2W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW INTEGER TIPIV( NASS2 ) INTEGER PIVSIZ,LPIV INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER(8) :: LA DOUBLE PRECISION A(LA) DOUBLE PRECISION UU, UULOC, SEUIL DOUBLE PRECISION CSEUIL INTEGER IW(LIW) INTEGER IOLDPS INTEGER(8) :: POSELT INTEGER KEEP(500) INTEGER(8) KEEP8(150) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT LOGICAL :: SWAP_OCCURRED DOUBLE PRECISION DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled include 'mpif.h' INTEGER(8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX INTEGER :: IPIVNUL, HF DOUBLE PRECISION RMAX,AMAX,TMAX,RMAX_NORELAX,MAX_PREV_in_PARPIV DOUBLE PRECISION MAXPIV, ABS_PIVOT DOUBLE PRECISION RMAX_NOSLAVE, TMAX_NOSLAVE DOUBLE PRECISION PIVOT,DETPIV DOUBLE PRECISION ABSDETPIV INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX, APOSROW INTEGER(8) :: APOS INTEGER(8) :: J1, J2, JJ, KK DOUBLE PRECISION :: GROWTH, RSWOP DOUBLE PRECISION :: UULOCM1 INTEGER :: LDAFS INTEGER(8) :: LDAFS8 DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: RONE = 1.0D0 DOUBLE PRECISION ZERO, ONE PARAMETER( ZERO = 0.0D0 ) PARAMETER( ONE = 1.0D0 ) DOUBLE PRECISION PIVNUL, VALTMP DOUBLE PRECISION FIXA INTEGER NPIV,IPIV,K219 INTEGER NPIVP1,ILOC,K,J INTEGER ISHIFT, K206, IPIV_END, IPIV_SHIFT INTRINSIC max INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L DOUBLE PRECISION GW_FACT GW_FACT = RONE AMAX = RZERO RMAX = RZERO TMAX = RZERO RMAX_NOSLAVE = RZERO PIVOT = ONE HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) K206 = KEEP(206) PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL LDAFS = NASS LDAFS8 = int(LDAFS,8) IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+KEEP(IXSZ)) & +KEEP(IXSZ), & IW, LIW) ENDIF UULOC = UU K219 = KEEP(219) IF (UULOC.GT.RZERO) THEN UULOCM1 = RONE/UULOC ELSE K219=0 UULOCM1 = RONE ENDIF IF (K219.LT.2) GW_FACTCUMUL = RONE PIVSIZ = 1 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NPIVP1 = NPIV + 1 ILOC = NPIVP1 - IBEG_BLOCK_TO_SEND + 1 TIPIV( ILOC ) = ILOC APOSMAX = POSELT+LDAFS8*LDAFS8-1_8 IF(INOPV .EQ. -1) THEN APOS = POSELT + LDAFS8*int(NPIVP1-1,8) + int(NPIV,8) POSPV1 = APOS ABS_PIVOT = abs(PIVOT) CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, & DKEEP, KEEP, .TRUE.) IF(ABS_PIVOT.LT.SEUIL) THEN IF(dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL NNEGW = NNEGW+1 ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE.0 ) THEN CALL DMUMPS_UPDATEDETER( A(APOS), DET_MANTW, DET_EXPW ) ENDIF IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 IF ((K219.GE.2).AND.(NPIVP1.EQ.1)) THEN GW_FACTCUMUL = RONE IF (K219.EQ.3) THEN DO IPIV=1,NASS DIAG_ORIG (IPIV) = abs(A(POSELT + & (LDAFS8+1_8)*int(IPIV-1,8))) ENDDO ELSE IF (K219.GE.4) THEN DIAG_ORIG = RZERO DO IPIV=1,NASS APOS = POSELT + LDAFS8*int(IPIV-1,8) POSPV1 = APOS + int(IPIV - 1,8) DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) DO J=IPIV+1,NASS DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) DIAG_ORIG(IPIV+J-IPIV) = max( abs(A(POSPV1)), & DIAG_ORIG(IPIV+J-IPIV) ) POSPV1 = POSPV1 + LDAFS8 ENDDO ENDDO ENDIF ENDIF ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + LDAFS8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN IF(ABS_PIVOT.LT.SEUIL) THEN CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, & DKEEP, KEEP, .TRUE.) IF(dble(PIVOT) .GE. RZERO) THEN A(POSPV1) = CSEUIL ELSE A(POSPV1) = -CSEUIL NNEGW = NNEGW+1 ENDIF NBTINYW = NBTINYW + 1 ELSE IF (ABS_PIVOT.EQ.RZERO) THEN GO TO 630 ELSE IF (PIVOT.LT.RZERO) NNEGW = NNEGW+1 CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF ENDIF GO TO 420 ENDIF AMAX = -RONE JMAX = 0 J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDAFS8 DO J=1, IEND_BLOCK - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDAFS8 ENDDO RMAX_NOSLAVE = RZERO IF (PIVOT_OPTION.EQ.2) THEN DO J=1,NASS - IEND_BLOCK RMAX_NOSLAVE = max(abs(A(J1+LDAFS8*int(J-1,8))), & RMAX_NOSLAVE) ENDDO ENDIF IF (K219.NE.0) THEN RMAX_NORELAX = dble(A(APOSMAX+int(IPIV,8))) RMAX = RMAX_NORELAX IF (K219.GE.2) THEN IF (ABS_PIVOT.NE.RZERO.AND. & ABS_PIVOT.GE.UULOC*max(RMAX,RMAX_NOSLAVE,AMAX)) & THEN GROWTH = RONE IF (K219.EQ.3) THEN IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN DIAG_ORIG(IPIV) = ABS_PIVOT ELSE GROWTH = ABS_PIVOT / DIAG_ORIG(IPIV) ENDIF ELSE IF (K219.GE.4) THEN IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN DIAG_ORIG(IPIV) = max(AMAX,RMAX_NOSLAVE) ELSE GROWTH = max(ABS_PIVOT,AMAX,RMAX_NOSLAVE)/ & DIAG_ORIG(IPIV) ENDIF ENDIF RMAX = RMAX*max(GROWTH,GW_FACTCUMUL) ENDIF ENDIF ELSE RMAX = RZERO RMAX_NORELAX = RZERO ENDIF RMAX_NOSLAVE = max(RMAX_NORELAX,RMAX_NOSLAVE) RMAX = max(RMAX,RMAX_NOSLAVE) IF (max(AMAX,RMAX,ABS_PIVOT).LE.PIVNUL) THEN IF ((K219.NE.0) & .AND.(K219.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & dble(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + LDAFS8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) THEN GOTO 460 ENDIF ENDDO ENDIF ENDIF CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(POSPV1)), DKEEP, KEEP, .TRUE.) IF ( A(POSPV1) .LT. RZERO ) NNULLNEGW=NNULLNEGW+1 KEEP(109) = KEEP(109) + 1 IPIVNUL = KEEP(109) IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST.LT.KEEP(109)) & THEN CALL MUMPS_RESIZE_PIVNUL(KEEP, N, PIVNUL_LIST_STRUCT, & IPIVNUL, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 430 ENDIF PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) IF (dble(FIXA).GT.RZERO) THEN IF(dble(PIVOT) .GE. RZERO) THEN A(POSPV1) = FIXA ELSE A(POSPV1) = -FIXA ENDIF ELSE J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 A(JJ) = ZERO ENDDO DO J=1, NASS-IPIV A(POSPV1+int(J,8)*LDAFS8) = ZERO ENDDO VALTMP = max(1.0D10*RMAX, sqrt(huge(RMAX))/1.0D8) A(POSPV1) = VALTMP ENDIF PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) GO TO 415 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF (ABS_PIVOT.GE.UULOC*max(RMAX,AMAX) & .AND. ABS_PIVOT .GT. max(SEUIL, tiny(RMAX))) THEN IF (A(POSPV1).LT.RZERO) NNEGW = NNEGW+1 CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL DMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) THEN GOTO 460 ELSE IF (JMAX .EQ.0) THEN GOTO 460 ENDIF IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN GOTO 460 ENDIF IF (RMAX_NOSLAVE.LT.AMAX) THEN J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN RMAX_NOSLAVE = max(RMAX_NOSLAVE,abs(A(JJ))) ENDIF ENDDO DO J=1,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX_NOSLAVE = max(abs(A(POSPV1+LDAFS8*int(J,8))), & RMAX_NOSLAVE) ENDIF ENDDO RMAX = max(RMAX, RMAX_NOSLAVE) ENDIF APOSJ = POSELT + int(JMAX-1,8)*LDAFS8 + int(NPIV,8) POSPV2 = APOSJ + int(JMAX - NPIVP1,8) IF (IPIV.LT.JMAX) THEN OFFDAG = APOSJ + int(IPIV - NPIVP1,8) ELSE OFFDAG = APOS + int(JMAX - NPIVP1,8) END IF TMAX_NOSLAVE = RZERO IF(JMAX .LT. IPIV) THEN JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+LDAFS8 IF (JMAX+K.NE.IPIV) THEN TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) ENDIF ENDDO DO KK = APOSJ, POSPV2-1_8 TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) ENDDO ELSE JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+LDAFS8 TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) ENDDO DO KK = APOSJ, POSPV2 - 1_8 IF (KK.NE.OFFDAG) THEN TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) ENDIF ENDDO ENDIF IF (K219.NE.0) THEN TMAX = max(SEUIL*UULOCM1, & abs(dble(A(APOSMAX+int(JMAX,8)))) & ) ELSE TMAX = SEUIL*UULOCM1 ENDIF IF (K219.GE.2) THEN GROWTH = RONE IF (K219.EQ.3) THEN IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN DIAG_ORIG(JMAX) = abs(A(POSPV2)) ELSE GROWTH = abs(A(POSPV2))/DIAG_ORIG(JMAX) ENDIF ELSE IF (K219.EQ.4) THEN IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN DIAG_ORIG(JMAX)=max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) ELSE GROWTH = max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) & / DIAG_ORIG(JMAX) ENDIF ENDIF TMAX = TMAX*max(GROWTH,GW_FACTCUMUL) ENDIF TMAX = max (TMAX,TMAX_NOSLAVE) DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)*A(OFFDAG) ABSDETPIV = abs(DETPIV) IF (SEUIL.GT.RZERO) THEN IF (sqrt(ABSDETPIV) .LE. SEUIL ) THEN GOTO 460 ENDIF ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN GO TO 460 ENDIF IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN GO TO 460 ENDIF CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( sqrt(abs(DETPIV)), & DKEEP, KEEP, .FALSE.) IF (KEEP(258).NE.0) THEN CALL DMUMPS_UPDATEDETER(DETPIV, DET_MANTW, DET_EXPW ) ENDIF PIVSIZ = 2 NB22T2W = NB22T2W+1 IF(DETPIV .LT. RZERO) THEN NNEGW = NNEGW+1 ELSE IF(A(POSPV2) .LT. RZERO) THEN NNEGW = NNEGW+2 ENDIF 415 CONTINUE IF (K206.GE.1) THEN Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) ENDIF DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2 ) THEN IF (K==1) THEN LPIV = min(IPIV, JMAX) TIPIV(ILOC) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) ELSE LPIV = max(IPIV, JMAX) TIPIV(ILOC+1) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) ENDIF ELSE LPIV = IPIV TIPIV(ILOC) = IPIV - IBEG_BLOCK_TO_SEND + 1 ENDIF IF (LPIV.EQ.NPIVP1) THEN GOTO 416 ENDIF KEEP8(80) = KEEP8(80)+1 CALL DMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDAFS, NFRONT, 2, K219, KEEP(50), & KEEP(IXSZ), IBEG_BLOCK_TO_SEND ) SWAP_OCCURRED = .TRUE. IF (K219.GE.3) THEN RSWOP = DIAG_ORIG(LPIV) DIAG_ORIG(LPIV) = DIAG_ORIG(NPIVP1) DIAG_ORIG(NPIVP1) = RSWOP ENDIF 416 CONTINUE IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL DMUMPS_STORE_PERMINFO( & IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF NPIVP1 = NPIVP1+1 ENDDO IF(PIVSIZ .EQ. 2) THEN A(POSELT+LDAFS8*int(NPIV,8)+int(NPIV+1,8)) = DETPIV ENDIF GOTO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE IFLAG = -10 420 CONTINUE IF (K219.GE.2) THEN IF(INOPV .EQ. 0) THEN IF(PIVSIZ .EQ. 1) THEN GW_FACT = max(AMAX,RMAX_NOSLAVE)/ABS_PIVOT ELSE IF(PIVSIZ .EQ. 2) THEN GW_FACT = max( & (abs(A(POSPV2))*RMAX_NOSLAVE+AMAX*TMAX_NOSLAVE) & / ABSDETPIV , & (abs(A(POSPV1))*TMAX_NOSLAVE+AMAX*RMAX_NOSLAVE) & / ABSDETPIV & ) ENDIF GW_FACT = min(GW_FACT, UULOCM1) GW_FACTCUMUL = max(GW_FACT,GW_FACTCUMUL) ENDIF ENDIF 430 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_I_LDLT_NIV2 SUBROUTINE DMUMPS_FAC_MQ_LDLT_NIV2 & (IEND_BLOCK, & NASS, NPIV, INODE, A, LA, LDAFS, & POSELT,IFINB,PIVSIZ, & K219, PIVOT_OPTION, IEND_BLR, LR_ACTIVATED) IMPLICIT NONE INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: K219 DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER, intent(in) :: IEND_BLOCK INTEGER, intent(in) :: NPIV, PIVSIZ INTEGER, intent(in) :: NASS,INODE,LDAFS INTEGER, intent(out) :: IFINB INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED DOUBLE PRECISION VALPIV INTEGER NCB1 INTEGER(8) :: APOS, APOSMAX INTEGER(8) :: LPOS, LPOS1, LPOS2, K1POS INTEGER(8) :: JJ, K1, K2 INTEGER(8) :: POSPV1, POSPV2, OFFDAG, OFFDAG_OLD INTEGER(8) :: LDAFS8 INTEGER NEL2 DOUBLE PRECISION ONE, ALPHA DOUBLE PRECISION ZERO INTEGER NPIV_NEW, I INTEGER(8) :: IBEG, IEND, IROW, J8 INTEGER :: J2 DOUBLE PRECISION SWOP,DETPIV,MULT1,MULT2, A11, A22, A12 PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) PARAMETER (ZERO=0.0D0) INCLUDE 'mumps_headers.h' LDAFS8 = int(LDAFS,8) NPIV_NEW = NPIV + PIVSIZ IFINB = 0 NEL2 = IEND_BLOCK - NPIV_NEW IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ENDIF IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDAFS8 DO I = 1, NEL2 K1POS = LPOS + int(I-1,8)*LDAFS8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ=1_8, int(I,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO IF (PIVOT_OPTION.EQ.2) THEN NCB1 = NASS - IEND_BLOCK ELSE NCB1 = IEND_BLR - IEND_BLOCK ENDIF !$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) DO I=NEL2+1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDAFS8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO !$OMP END PARALLEL DO IF (K219.eq. -1) THEN APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) A(APOSMAX) = A(APOSMAX) * abs(VALPIV) DO J8 = 1_8, int(NEL2+NCB1,8) A(APOSMAX+J8) = A(APOSMAX+J8) + & A(APOSMAX) * abs(A(APOS+J8)) ENDDO ENDIF ELSE POSPV1 = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) POSPV2 = POSPV1+LDAFS8+1_8 OFFDAG_OLD = POSPV2 - 1_8 OFFDAG = POSPV1+1_8 SWOP = A(POSPV2) DETPIV = A(OFFDAG) A22 = A(POSPV1)/DETPIV A11 = SWOP/DETPIV A12 = -A(OFFDAG_OLD)/DETPIV A(OFFDAG) = A(OFFDAG_OLD) A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDAFS8 - 1_8 LPOS2 = LPOS1 + 1_8 CALL dcopy(NASS-NPIV_NEW, A(LPOS1), LDAFS, A(POSPV1+2_8), 1) CALL dcopy(NASS-NPIV_NEW, A(LPOS2), LDAFS, A(POSPV2+1_8), 1) JJ = POSPV2 + int(NASS-1,8) IBEG = JJ + 2_8 IEND = IBEG DO J2 = 1,NEL2 K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1+2_8 K2 = POSPV2+1_8 DO IROW = IBEG,IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = -MULT1 A(JJ+1_8) = -MULT2 IBEG = IBEG + int(NASS,8) IEND = IEND + int(NASS + 1,8) JJ = JJ+int(NASS,8) ENDDO IEND = IEND-1_8 DO J2 = IEND_BLOCK+1,NASS K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1+2_8 K2 = POSPV2+1_8 DO IROW = IBEG,IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = -MULT1 A(JJ+1_8) = -MULT2 IBEG = IBEG + int(NASS,8) IEND = IEND + int(NASS,8) JJ = JJ+int(NASS,8) ENDDO IF (K219.eq. -1) THEN APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) JJ = APOSMAX K1 = JJ K2 = JJ + 1_8 MULT1 = abs(A11)*A(K1)+abs(A12)*A(K2) MULT2 = abs(A12)*A(K1)+abs(A22)*A(K2) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 IBEG = APOSMAX + 2_8 IEND = APOSMAX + 1_8 + NASS - NPIV_NEW DO IROW = IBEG, IEND A(IROW) = A(IROW) + MULT1*abs(A(K1)) + MULT2*abs(A(K2)) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = MULT1 A(JJ+1_8) = MULT2 ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_FAC_MQ_LDLT_NIV2 SUBROUTINE DMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, N, & INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, LDA_FS, & IBEG_PANEL, IEND, TIPIV, LPIV, LASTPANEL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED, NPARTSASS, CURRENT_BLR_PANEL & , BLR_LorU & , LRGROUPS & ) USE DMUMPS_BUF USE MUMPS_LOAD USE DMUMPS_LR_TYPE USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, IBEG_PANEL, IEND, LPIV, & IOLDPS, LDA_FS, NB_BLOC_FAC INTEGER(8) :: POSELT, LA INTEGER IW(LIW), TIPIV(LPIV) LOGICAL LASTPANEL DOUBLE PRECISION A(LA) INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL, & SLAVEF, ICNTL(60) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), & PERM(N), PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL, intent(in) :: LR_ACTIVATED TYPE (LRB_TYPE), DIMENSION(:) :: BLR_LorU INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER :: NELIM INTEGER, intent(in) :: NPARTSASS, CURRENT_BLR_PANEL INCLUDE 'mumps_headers.h' INTEGER(8) :: APOS, LREQA INTEGER NPIV, NCOL, PDEST, NSLAVES, WIDTH INTEGER IERR, LREQI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED DOUBLE PRECISION FLOP1,FLOP2 LOGICAL COMPRESS_CB INTEGER NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 IF (NSLAVES.EQ.0) THEN WRITE(6,*) ' ERROR 1 in DMUMPS_SEND_FACTORED_PANEL ' CALL MUMPS_ABORT() ENDIF NPIV = IEND - IBEG_PANEL + 1 NCOL = LDA_FS - IBEG_PANEL + 1 APOS = POSELT + int(LDA_FS,8)*int(IBEG_PANEL-1,8) + & int(IBEG_PANEL - 1,8) IF (IBEG_PANEL > 0) THEN CALL MUMPS_GET_FLOPS_COST( LDA_FS, IBEG_PANEL-1, LPIV, & KEEP(50),2,FLOP1) ELSE FLOP1=0.0D0 ENDIF CALL MUMPS_GET_FLOPS_COST( LDA_FS, IEND, LPIV, & KEEP(50),2,FLOP2) FLOP2 = FLOP1 - FLOP2 CALL MUMPS_LOAD_UPDATE(1, .FALSE., FLOP2, KEEP,KEEP8) IF ((NPIV.GT.0) .OR. & ((NPIV.EQ.0).AND.(LASTPANEL)) & ) THEN IF ((NPIV.EQ.0).AND.(LASTPANEL)) THEN IF (COMPRESS_CB) THEN IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 COMPRESS_CB = .FALSE. ENDIF ENDIF PDEST = IOLDPS + 6 + KEEP(IXSZ) IF (( NPIV .NE. 0 ).AND.(KEEP(50).NE.0)) THEN NB_BLOC_FAC = NB_BLOC_FAC + 1 END IF IERR = -1 DO WHILE (IERR .EQ.-1) WIDTH = NSLAVES CALL DMUMPS_BUF_SEND_BLOCFACTO( INODE, LDA_FS, NCOL, & NPIV, FPERE, LASTPANEL, TIPIV, A(APOS), & IW(PDEST), NSLAVES, KEEP, NB_BLOC_FAC, & NSLAVES, WIDTH, COMM, & NELIM, NPARTSASS, CURRENT_BLR_PANEL, & LR_ACTIVATED, BLR_LorU, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & IBEG_PANEL, COMPRESS_CB, & ICNTL, IERR ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (MESSAGE_RECEIVED) THEN POSELT = PTRAST(STEP(INODE)) APOS = POSELT + int(LDA_FS,8)*int(IBEG_PANEL-1,8) + & int(IBEG_PANEL - 1,8) ENDIF IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2 .OR. IERR.EQ.-3 ) THEN IF (IERR.EQ.-2) IFLAG = -17 IF (IERR.EQ.-3) IFLAG = -20 LREQA = int(NCOL,8)*int(NPIV,8) LREQI = NPIV + 6 + 2*NSLAVES + 2 CALL MUMPS_SET_IERROR( & int(LREQI,8) * int(KEEP(34),8) + LREQA * int(KEEP(35),8), & IERROR) GOTO 300 ENDIF ENDIF GOTO 500 300 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE DMUMPS_SEND_FACTORED_PANEL END MODULE DMUMPS_FAC_FRONT_TYPE2_AUX_M MUMPS_5.8.1/src/mumps_numa.c0000664000175000017500000000075415042446422015563 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ int mumps_numa_return() { return 0; } MUMPS_5.8.1/src/carrowheads.F0000664000175000017500000011560415042446440015650 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ANA_ARROWHEADS_WRAPPER ( id, & GATHER_MATRIX_ALLOCATED ) USE CMUMPS_STRUC_DEF USE CMUMPS_ANA_AUX_M, ONLY:CMUMPS_ANA_N_DIST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: MASTER PARAMETER( MASTER = 0 ) TYPE(CMUMPS_STRUC), TARGET :: id LOGICAL, INTENT(INOUT) :: GATHER_MATRIX_ALLOCATED INTEGER, ALLOCATABLE, DIMENSION(:) :: NBINROW_TMP, NBINCOL_TMP INTEGER, DIMENSION(:), POINTER :: KEEP, ICNTL, INFO INTEGER(8), DIMENSION(:), POINTER :: KEEP8 LOGICAL :: I_AM_SLAVE INTEGER :: allocok KEEP => id%KEEP ICNTL => id%ICNTL INFO => id%INFO KEEP8 => id%KEEP8 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (KEEP(55) .EQ. 0) THEN ALLOCATE( NBINCOL_TMP( id%N ), NBINROW_TMP( id%N ), & stat=allocok ) IF (allocok.GT.0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(int(id%N,8)+int(id%N,8), INFO(2)) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL CMUMPS_ANA_N_DIST(id, NBINCOL_TMP, NBINROW_TMP) IF ( .NOT. I_AM_SLAVE ) THEN DEALLOCATE(NBINCOL_TMP) DEALLOCATE(NBINROW_TMP) ENDIF IF(id%MYID .EQ. MASTER) THEN IF ( (KEEP(244) .EQ. 1) .AND. (KEEP(54) .EQ. 3) ) THEN IF (GATHER_MATRIX_ALLOCATED) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF GATHER_MATRIX_ALLOCATED= .FALSE. ENDIF END IF END IF ENDIF IF ( I_AM_SLAVE ) THEN IF (KEEP(55) .EQ. 0) THEN CALL CMUMPS_ANA_DIST_ARROWHEADS( id%MYID, & id%NSLAVES, id%N, id%PROCNODE_STEPS(1), & id%STEP(1), id%FILS(1), & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & KEEP(1),KEEP8(1), ICNTL(1), id, & NBINCOL_TMP, NBINROW_TMP ) DEALLOCATE(NBINCOL_TMP) DEALLOCATE(NBINROW_TMP) ELSE CALL CMUMPS_ANA_DIST_ELEMENTS( id%MYID, & id%NSLAVES, id%N, id%PROCNODE_STEPS(1), & id%STEP(1), & id%PTRAR(1), & id%PTRAR(id%NELT+2 ), & id%NELT, & id%FRTPTR(1), id%FRTELT(1), & KEEP(1), KEEP8(1), ICNTL(1), id%KEEP(50) ) id%KEEP(193)=1;id%KEEP(194)=1 id%KEEP(195)=1; id%KEEP(196)=1 ALLOCATE( id%PTR8ARR(1), & id%NINCOLARR(1), & id%NINROWARR(1), & id%PTRDEBARR(1), stat=allocok) IF (allocok .GT. 0) THEN id%INFO(1)=-7 id%INFO(2)=4 ENDIF ENDIF ELSE KEEP8(26) = 0_8 KEEP8(27) = 0_8 ALLOCATE( id%PTR8ARR(1), & id%NINCOLARR(1), & id%NINROWARR(1), & id%PTRDEBARR(1), stat=allocok) IF (allocok .GT. 0) THEN id%INFO(1)=-7 id%INFO(2)=4 ENDIF ENDIF 500 CONTINUE IF (allocated(NBINROW_TMP)) DEALLOCATE(NBINROW_TMP) IF (allocated(NBINCOL_TMP)) DEALLOCATE(NBINCOL_TMP) RETURN END SUBROUTINE CMUMPS_ANA_ARROWHEADS_WRAPPER SUBROUTINE CMUMPS_ANA_DIST_ARROWHEADS( MYID, SLAVEF, N, & PROCNODE, STEP, FILS, ISTEP_TO_INIV2, & I_AM_CAND, & KEEP, KEEP8, ICNTL, id, NINCOL_TMP, NINROW_TMP ) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE (CMUMPS_STRUC) :: id INTEGER MYID, N, SLAVEF INTEGER KEEP( 500 ), ICNTL( 60 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE( KEEP(28) ), STEP( N ), FILS( N ) INTEGER, INTENT(INOUT) :: NINCOL_TMP( N ) INTEGER, INTENT(INOUT) :: NINROW_TMP( N ) INTEGER ISTEP_TO_INIV2(KEEP(71)) LOGICAL I_AM_CAND(max(1,KEEP(56))) LOGICAL I_AM_SLAVE LOGICAL I_AM_CAND_LOC INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT INTEGER ISTEP, I, J, NINCOL, NINROW, allocok INTEGER TYPE_PARALL, ITYPE, IRANK, INIV2, TYPESPLIT LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS INTEGER :: NBARR_LOCAL INTEGER(8) :: IPTR EARLYT3ROOTINS = KEEP(200) .EQ. 0 & .OR. (KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0) TYPE_PARALL = KEEP(46) I_AM_SLAVE = (KEEP(46).EQ.1 .OR. MYID.NE.0) NBARR_LOCAL=0 DO J = 1, N ISTEP = STEP( J ) IF ( ISTEP .GT. 0 ) THEN I = J DO WHILE (I .GT. 0) ITYPE = MUMPS_TYPENODE( PROCNODE(ISTEP), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), KEEP(199) ) TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. T4_MASTER_CONCERNED = .FALSE. IF (ITYPE.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) THEN I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN IF ( TYPE_PARALL .eq. 0 ) THEN T4_MASTER_CONCERNED = & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID-1 ) ELSE T4_MASTER_CONCERNED = & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID ) ENDIF ENDIF ENDIF ENDIF IF ( TYPE_PARALL .eq. 0 ) THEN IRANK =IRANK + 1 END IF IF ( & ( ITYPE .eq. 2 .and. & IRANK .eq. MYID ) & .or. & ( ITYPE .eq. 1 .and. & IRANK .eq. MYID ) & .or. & ( T4_MASTER_CONCERNED ) & ) THEN NINCOL = NINCOL_TMP(I) NINROW = NINROW_TMP(I) ELSE IF ( ITYPE .EQ. 3 ) THEN IF ( EARLYT3ROOTINS ) THEN NINCOL = -1 NINROW = -1 ELSE NINCOL = NINCOL_TMP(I) NINROW = NINROW_TMP(I) ENDIF ELSE IF ( ITYPE .eq. 2 .AND. I_AM_CAND_LOC ) THEN NINCOL = NINCOL_TMP(I) NINROW = 0 ELSE NINCOL = -1 NINROW = -1 ENDIF IF ( NINCOL .NE. -1 ) THEN NBARR_LOCAL = NBARR_LOCAL + 1 ENDIF NINCOL_TMP(I)=NINCOL NINROW_TMP(I)=NINROW I=FILS(I) ENDDO ENDIF ENDDO KEEP(193) = max(1, NBARR_LOCAL) KEEP(194) = max(1, NBARR_LOCAL) KEEP(195) = max(1, NBARR_LOCAL) KEEP(196) = KEEP(28) ALLOCATE(id%PTR8ARR(KEEP(193)), & id%NINCOLARR(KEEP(194)), id%NINROWARR(KEEP(195)), & id%PTRDEBARR(KEEP(196)), stat=allocok) IF (allocok.GT.0) THEN id%INFO(1)=-7 CALL MUMPS_SET_IERROR( int(KEEP(194),8)+int(KEEP(195),8)+ & int(KEEP(196),8), id%INFO(2) ) RETURN ENDIF IPTR = 1_8 NBARR_LOCAL = 0 DO J = 1, N ISTEP = STEP( J ) IF ( ISTEP .GT. 0 ) THEN id%PTRDEBARR(ISTEP) = NBARR_LOCAL + 1 I = J DO WHILE (I .GT. 0) NINCOL = NINCOL_TMP(I) NINROW = NINROW_TMP(I) IF ( NINCOL .NE. -1 ) THEN NBARR_LOCAL = NBARR_LOCAL + 1 id%NINCOLARR( NBARR_LOCAL ) = NINCOL id%NINROWARR( NBARR_LOCAL ) = NINROW id%PTR8ARR ( NBARR_LOCAL ) = IPTR IPTR = IPTR + int(NINCOL + NINROW + 1,8) ENDIF I=FILS(I) ENDDO IF ( NINCOL .EQ. -1 ) THEN id%PTRDEBARR( ISTEP ) = -99999 ENDIF ENDIF ENDDO KEEP8(26) = IPTR - 1 KEEP8(27) = IPTR - 1 RETURN END SUBROUTINE CMUMPS_ANA_DIST_ARROWHEADS SUBROUTINE CMUMPS_FACTO_SEND_ARROWHEADS( N, NZ, ASPK, & IRN, ICN, PERM, & LSCAL,COLSCA,ROWSCA, & MYID, SLAVEF, PROCNODE_STEPS, NBRECORDS, & COMM, root, roota, KEEP, KEEP8, FILS, & INTARR, LINTARR, DBLARR, LDBLARR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, FRERE_STEPS, & STEP, A, LA, ISTEP_TO_INIV2, I_AM_CAND, CANDIDATES, & ICNTL, INFO ) !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER :: N, COMM, NBRECORDS INTEGER(8), INTENT(IN) :: NZ INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) COMPLEX ASPK(NZ) REAL COLSCA(*), ROWSCA(*) INTEGER IRN(NZ), ICN(NZ) INTEGER PERM(N), PROCNODE_STEPS(KEEP(28)) INTEGER FILS( N ) INTEGER ISTEP_TO_INIV2(KEEP(71)) LOGICAL I_AM_CAND(max(1,KEEP(56))) INTEGER SLAVEF, MYID INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56))) LOGICAL LSCAL TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER INFO( 80 ), ICNTL(60) INTEGER(8), INTENT(IN) :: LA INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER :: FRERE_STEPS( KEEP(28) ) INTEGER :: STEP(N) INTEGER(8) :: LINTARR, LDBLARR INTEGER :: INTARR( LINTARR ) COMPLEX :: DBLARR( LDBLARR ) COMPLEX :: A( LA ) INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT INTEGER LP LOGICAL LPOK COMPLEX VAL, VAL_SHR INTEGER IOLD,JOLD,ISEND,JSEND,DEST,I,IARR INTEGER ISEND_SHR, JSEND_SHR, DEST_SHR INTEGER IPOSROOT, JPOSROOT INTEGER IROW_GRID, JCOL_GRID INTEGER ISTEP INTEGER NBUFS INTEGER ARROW_ROOT, TAILLE INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT INTEGER TYPE_NODE, MASTER_NODE LOGICAL I_AM_CAND_LOC, I_AM_SLAVE INTEGER JARR, ILOCROOT, JLOCROOT INTEGER allocok, INIV2, TYPESPLIT, T4MASTER INTEGER(8) :: IS8, K INTEGER NCAND LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: PTRAW INTEGER :: IARR1, IORG, J INTEGER, DIMENSION(:,:), ALLOCATABLE :: BUFI COMPLEX, DIMENSION(:,:), ALLOCATABLE :: BUFR LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P INTEGER NOMP, NOMP_P, IOMP, P2 LP = ICNTL(1) LPOK = ( LP .GT. 0 .AND. ICNTL(4) .GE. 1 ) ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ. 0 & .OR. (KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0) I_AM_SLAVE=(MYID.NE.0.OR.KEEP(46).EQ.1) IF ( KEEP(46) .eq. 0 ) THEN NBUFS = SLAVEF ELSE NBUFS = SLAVEF - 1 ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8)+int(N,8), INFO(2) ) IF (LPOK ) WRITE (LP,*) MYID, & ': Error allocating IW4 in CMUMPS_FACTO_SEND_ARROWHEADS' GOTO 100 END IF ALLOCATE( PTRAW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = N IF (LPOK ) WRITE (LP,*) MYID, & ': Error allocating PTRAW in CMUMPS_FACTO_SEND_ARROWHEADS' GOTO 100 END IF ENDIF IF (NBUFS.GT.0) THEN ALLOCATE( BUFI(NBRECORDS*2+1,NBUFS),stat=allocok ) IF ( allocok .GT. 0 ) THEN IF (LPOK ) WRITE (LP,*) MYID, & ': Error allocating BUFI in CMUMPS_FACTO_SEND_ARROWHEADS' INFO(1)=-13 CALL MUMPS_SET_IERROR( int(NBUFS,8) * int(NBRECORDS*2+1,8), & INFO(2)) GOTO 100 END IF ALLOCATE( BUFR( NBRECORDS, NBUFS ), stat=allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) =-13 CALL MUMPS_SET_IERROR( int(NBUFS,8) * int(NBRECORDS*2+1,8), & INFO(2)) IF (LPOK ) WRITE (LP,*) MYID, & ': Error allocating BUFR in CMUMPS_FACTO_SEND_ARROWHEADS' GOTO 100 END IF DO I = 1, NBUFS BUFI( 1, I ) = 0 ENDDO ENDIF 100 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF (KEEP(46) .NE. 0) THEN #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, N ISTEP=STEP(J) IF (ISTEP .GT. 0) THEN IARR1 = PTRDEBARR( ISTEP ) IF ( IARR1 .GT. 0 ) THEN I = J IORG = 0 DO WHILE ( I .GT. 0 ) IORG = IORG + 1 IW4(I, 1) = NINCOLARR( IARR1 + IORG - 1 ) IW4(I, 2) = NINROWARR( IARR1 + IORG - 1 ) + & NINCOLARR( IARR1 + IORG - 1 ) IS8 = PTR8ARR( IARR1 + IORG - 1 ) PTRAW( I ) = IS8 INTARR( IS8 ) = I DBLARR( IS8 ) = ZERO I = FILS(I) ENDDO ENDIF ENDIF ENDDO IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL CMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, & PTR_ROOT, LA) CALL CMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF END IF NOMP = 1 !$ NOMP=omp_get_max_threads() OMP_FLAG = KEEP(399).EQ.1 .AND. NOMP.GE.2 .AND. SLAVEF.EQ.1 & .AND. KEEP(46) .EQ. 1 !$OMP PARALLEL PRIVATE(K, I, DEST, I_AM_CAND_LOC, !$OMP& T4MASTER, T4_MASTER_CONCERNED, !$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, !$OMP& ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, !$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE, !$OMP& IS8, TAILLE, VAL, !$OMP& IARR, JARR, ISTEP, ISEND, JSEND, !$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P) !$OMP& REDUCTION(+: ARROW_ROOT) IF (OMP_FLAG) IOMP=0 !$ IOMP=omp_get_thread_num() NOMP_P=1 !$ NOMP_P=omp_get_num_threads() OMP_FLAG_P = .FALSE. !$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1 IF (OMP_FLAG_P) THEN IF ( NOMP_P .GE. 16 ) THEN NOMP_P=16 P2 = 4 ELSE IF (NOMP_P.GE.8) THEN NOMP_P=8 P2 = 3 ELSE IF (NOMP_P.GE.4) THEN NOMP_P=4 P2 = 2 ELSE IF (NOMP_P.GE.2) THEN NOMP_P=2 P2 = 1 ENDIF ELSE NOMP_P = 1 P2 = 0 ENDIF IF ( IOMP .LT. NOMP_P ) THEN DO K=1, NZ IOLD = IRN(K) JOLD = ICN(K) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE END IF IF (OMP_FLAG_P) THEN IF (IOLD.EQ.JOLD) THEN IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD ELSE IARR = JOLD ENDIF DOIT = ( IOMP .EQ. ibits(IARR, P2-1, P2)) ELSE DOIT = .TRUE. ENDIF IF (DOIT) THEN IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = JOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF ISTEP = abs( STEP(IARR) ) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 IF ( TYPE_NODE .EQ. 1 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF ELSE IF ( TYPE_NODE .EQ. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF END IF INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) IF ( KEEP(46) .eq. 0 ) THEN T4MASTER=T4MASTER+1 ENDIF ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND .LT. 0 ) THEN IPOSROOT = root%RG2L(JSEND) JPOSROOT = root%RG2L(IARR) ELSE IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JSEND ) END IF IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL ) IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * root%NPCOL + JCOL_GRID END IF ELSE DEST = -2 ENDIF END IF IF (LSCAL) THEN VAL = ASPK(K)*ROWSCA(IOLD)*COLSCA(JOLD) ELSE VAL = ASPK(K) ENDIF IF ( DEST .eq. 0 & .or. & ( DEST .eq. -1 .and. KEEP( 46 ) .eq. 1 .AND. & ( I_AM_CAND_LOC .OR. MASTER_NODE .EQ. 0 ) ) & .or. & ( T4MASTER.EQ.0 ) & .or. & ( DEST .EQ. -2 .AND. KEEP( 46 ) .EQ. 1 ) & ) THEN IARR = ISEND JARR = JSEND IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%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 IS8 = PTRAW( IARR ) DBLARR( IS8 ) = DBLARR( IS8 ) + VAL ELSE IS8 = PTRAW(IARR) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL END IF ELSE IARR = -IARR IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 .AND. & STEP( IARR) > 0 ) THEN IF ( MASTER_NODE == MYID) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL CMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF END IF END IF END IF IF ( DEST.EQ. -1 ) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79).GT.0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) IF (KEEP(46).EQ.0.AND.(DEST.GE.0)) DEST=DEST+1 IF (DEST.LT.0) EXIT IF (I.EQ.NCAND+1) CYCLE IF (DEST.NE.0) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL CMUMPS_ARROW_FILL_SEND_BUF() ENDIF ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) IF (KEEP(46).EQ.0) DEST=DEST+1 IF (DEST.NE.0) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL CMUMPS_ARROW_FILL_SEND_BUF() ENDIF ENDDO ENDIF DEST = MASTER_NODE IF (KEEP(46).EQ.0) DEST=DEST+1 IF ( DEST .NE. 0 ) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL CMUMPS_ARROW_FILL_SEND_BUF() ENDIF IF ((T4_MASTER_CONCERNED).AND.(T4MASTER.GT.0)) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=T4MASTER CALL CMUMPS_ARROW_FILL_SEND_BUF() ENDIF ELSE IF ( DEST .GT. 0 ) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL CMUMPS_ARROW_FILL_SEND_BUF() IF ( T4MASTER.GT.0 ) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=T4MASTER CALL CMUMPS_ARROW_FILL_SEND_BUF() ENDIF ELSE IF ( T4MASTER.GT.0 ) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=T4MASTER CALL CMUMPS_ARROW_FILL_SEND_BUF() ELSE IF ( DEST .EQ. -2 ) THEN DO I = 0, SLAVEF-1 DEST = I IF (KEEP(46) .EQ. 0) DEST = DEST + 1 IF (DEST .NE. 0) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL CMUMPS_ARROW_FILL_SEND_BUF() ENDIF ENDDO ENDIF ENDIF ENDDO ENDIF !$OMP END PARALLEL KEEP(49) = ARROW_ROOT IF (NBUFS.GT.0) THEN CALL CMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP( 46 ) ) ENDIF 500 CONTINUE IF ( allocated(IW4 ) ) DEALLOCATE( IW4 ) IF ( allocated(PTRAW ) ) DEALLOCATE( PTRAW ) IF ( allocated(BUFI ) ) DEALLOCATE( BUFI ) IF ( allocated(BUFR ) ) DEALLOCATE( BUFR ) RETURN CONTAINS SUBROUTINE CMUMPS_ARROW_FILL_SEND_BUF() IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ IF (BUFI(1,DEST_SHR)+1.GT.NBRECORDS) THEN TAILLE_SENDI = BUFI(1,DEST_SHR) * 2 + 1 TAILLE_SENDR = BUFI(1,DEST_SHR) CALL MPI_SEND(BUFI(1,DEST_SHR),TAILLE_SENDI, & MPI_INTEGER, & DEST_SHR, ARROWHEAD, COMM, IERR ) CALL MPI_SEND( BUFR(1,DEST_SHR), TAILLE_SENDR, & MPI_COMPLEX, DEST_SHR, & ARROWHEAD, COMM, IERR ) BUFI(1,DEST_SHR) = 0 ENDIF IREQ = BUFI(1,DEST_SHR) + 1 BUFI(1,DEST_SHR) = IREQ BUFI( IREQ * 2, DEST_SHR ) = ISEND_SHR BUFI( IREQ * 2 + 1, DEST_SHR ) = JSEND_SHR BUFR( IREQ, DEST_SHR ) = VAL_SHR RETURN END SUBROUTINE CMUMPS_ARROW_FILL_SEND_BUF END SUBROUTINE CMUMPS_FACTO_SEND_ARROWHEADS SUBROUTINE CMUMPS_ARROW_FILL_SEND_BUF_ELT( & ISEND_SHR, JSEND_SHR, VAL_SHR, & DEST_SHR, BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM ) IMPLICIT NONE INTEGER, INTENT(in) :: ISEND_SHR, JSEND_SHR COMPLEX, INTENT(in) :: VAL_SHR INTEGER :: DEST_SHR, NBRECORDS, NBUFS, LP, COMM INTEGER :: BUFI( NBRECORDS*2+1, NBUFS ) COMPLEX :: BUFR( NBRECORDS, NBUFS ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ IF (BUFI(1,DEST_SHR)+1.GT.NBRECORDS) THEN TAILLE_SENDI = BUFI(1,DEST_SHR) * 2 + 1 TAILLE_SENDR = BUFI(1,DEST_SHR) CALL MPI_SEND(BUFI(1,DEST_SHR),TAILLE_SENDI, & MPI_INTEGER, & DEST_SHR, ARROWHEAD, COMM, IERR ) CALL MPI_SEND( BUFR(1,DEST_SHR), TAILLE_SENDR, & MPI_COMPLEX, DEST_SHR, & ARROWHEAD, COMM, IERR ) BUFI(1,DEST_SHR) = 0 ENDIF IREQ = BUFI(1,DEST_SHR) + 1 BUFI(1,DEST_SHR) = IREQ BUFI( IREQ * 2, DEST_SHR ) = ISEND_SHR BUFI( IREQ * 2 + 1, DEST_SHR ) = JSEND_SHR BUFR( IREQ, DEST_SHR ) = VAL_SHR RETURN END SUBROUTINE CMUMPS_ARROW_FILL_SEND_BUF_ELT SUBROUTINE CMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM, & TYPE_PARALL ) IMPLICIT NONE INTEGER NBUFS, NBRECORDS, TYPE_PARALL INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS ) COMPLEX BUFR( NBRECORDS, NBUFS ) INTEGER COMM INTEGER LP INTEGER ISLAVE, TAILLE_SENDI, TAILLE_SENDR, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' DO ISLAVE = 1,NBUFS TAILLE_SENDI = BUFI(1,ISLAVE) * 2 + 1 TAILLE_SENDR = BUFI(1,ISLAVE) BUFI(1,ISLAVE) = - BUFI(1,ISLAVE) CALL MPI_SEND(BUFI(1,ISLAVE),TAILLE_SENDI, & MPI_INTEGER, & ISLAVE, ARROWHEAD, COMM, IERR ) IF ( TAILLE_SENDR .NE. 0 ) THEN CALL MPI_SEND( BUFR(1,ISLAVE), TAILLE_SENDR, & MPI_COMPLEX, ISLAVE, & ARROWHEAD, COMM, IERR ) END IF ENDDO RETURN END SUBROUTINE CMUMPS_ARROW_FINISH_SEND_BUF RECURSIVE SUBROUTINE CMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTLIST, DBLLIST, TAILLE, LO, HI ) IMPLICIT NONE INTEGER N, TAILLE INTEGER PERM( N ) INTEGER INTLIST( TAILLE ) COMPLEX DBLLIST( TAILLE ) INTEGER LO, HI INTEGER I,J INTEGER ISWAP, PIVOT COMPLEX cswap I = LO J = HI PIVOT = PERM(INTLIST((I+J)/2)) 10 IF (PERM(INTLIST(I)) < PIVOT) THEN I=I+1 GOTO 10 ENDIF 20 IF (PERM(INTLIST(J)) > PIVOT) THEN J=J-1 GOTO 20 ENDIF IF (I < J) THEN ISWAP = INTLIST(I) INTLIST(I) = INTLIST(J) INTLIST(J)=ISWAP cswap = DBLLIST(I) DBLLIST(I) = DBLLIST(J) DBLLIST(J) = cswap ENDIF IF ( I <= J) THEN I = I+1 J = J-1 ENDIF IF ( I <= J ) GOTO 10 IF ( LO < J ) CALL CMUMPS_QUICK_SORT_ARROWHEADS(N, PERM, & INTLIST, DBLLIST, TAILLE, LO, J) IF ( I < HI ) CALL CMUMPS_QUICK_SORT_ARROWHEADS(N, PERM, & INTLIST, DBLLIST, TAILLE, I, HI) RETURN END SUBROUTINE CMUMPS_QUICK_SORT_ARROWHEADS SUBROUTINE CMUMPS_FACTO_RECV_ARROWHD2( N, & DBLARR, LDBLARR, INTARR, LINTARR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & KEEP, KEEP8, FILS, MYID, COMM, NBRECORDS, & A, LA, root, roota, & PROCNODE_STEPS, & SLAVEF, PERM, FRERE_STEPS, STEP, ICNTL, INFO ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, MYID, COMM INTEGER KEEP(500) INTEGER(8), INTENT(IN) :: LDBLARR, LINTARR INTEGER INTARR(LINTARR) INTEGER, INTENT(IN) :: FILS( N ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER(8) KEEP8(150) INTEGER(8), intent(IN) :: LA INTEGER PROCNODE_STEPS( KEEP(28) ), PERM( N ) INTEGER SLAVEF, NBRECORDS COMPLEX A( LA ) INTEGER INFO( 80 ), ICNTL(60) COMPLEX DBLARR(LDBLARR) INTEGER FRERE_STEPS( KEEP(28) ), STEP(N) TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER LP LOGICAL LPOK INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFI COMPLEX, ALLOCATABLE, DIMENSION(:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: PTRAW INTEGER :: IARR1, IORG, J, ISTEP LOGICAL :: EARLYT3ROOTINS LOGICAL FINI INTEGER IREC, NB_REC, IARR, JARR, I, allocok INTEGER(8) :: IS8 INTEGER LOCAL_M, LOCAL_N, ILOCROOT, JLOCROOT, & IPOSROOT, JPOSROOT, TAILLE, & IPROC INTEGER(8) :: PTR_ROOT INTEGER ARROW_ROOT, TYPE_PARALL INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE COMPLEX VAL COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MASTER PARAMETER(MASTER=0) INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) TYPE_PARALL = KEEP(46) LP = ICNTL(1) LPOK = ( LP .GT. 0 .AND. ICNTL(4) .GE. 1 ) ARROW_ROOT=0 EARLYT3ROOTINS = KEEP(200) .EQ. 0 & .OR. (KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0) ALLOCATE( BUFI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = NBRECORDS * 2 + 1 IF (LPOK) WRITE(LP,*) MYID, & ': Error allocaing BUFI in CMUMPS_FACTO_RECV_ARROWHD2' GOTO 100 END IF ALLOCATE( BUFR( NBRECORDS ) , stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = NBRECORDS IF (LPOK) WRITE(LP,*) MYID, & ': Error allocaing BUFR in CMUMPS_FACTO_RECV_ARROWHD2' GOTO 100 END IF ALLOCATE( IW4(N,2), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR( 2_8 * int(N,8), INFO(2) ) IF (LPOK) WRITE(LP,*) MYID, & ': Error allocaing IW4 in CMUMPS_FACTO_RECV_ARROWHD2' GOTO 100 END IF ALLOCATE( PTRAW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = N IF (LPOK) WRITE(LP,*) MYID, & ': Error allocaing PTRAW in CMUMPS_FACTO_RECV_ARROWHD2' GOTO 100 END IF 100 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF ( KEEP(38).NE.0 .AND. EARLYT3ROOTINS ) THEN CALL CMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL CMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF FINI = .FALSE. #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, N ISTEP=STEP(J) IF (ISTEP .GT. 0) THEN IARR1 = PTRDEBARR( ISTEP ) IF ( IARR1 .GT. 0 ) THEN I = J IORG = 0 DO WHILE ( I .GT. 0 ) IORG = IORG + 1 IW4(I, 1) = NINCOLARR( IARR1 + IORG - 1 ) IW4(I, 2) = NINROWARR( IARR1 + IORG - 1 ) + & NINCOLARR( IARR1 + IORG - 1 ) IS8 = PTR8ARR( IARR1 + IORG - 1 ) PTRAW( I ) = IS8 INTARR( IS8 ) = I DBLARR( IS8 ) = ZERO I = FILS(I) ENDDO ENDIF ENDIF ENDDO DO WHILE (.NOT.FINI) CALL MPI_RECV( BUFI(1), 2*NBRECORDS+1, & MPI_INTEGER, MASTER, & ARROWHEAD, & COMM, STATUS, IERR ) NB_REC = BUFI(1) IF (NB_REC.LE.0) THEN FINI = .TRUE. NB_REC = -NB_REC ENDIF IF (NB_REC.EQ.0) EXIT CALL MPI_RECV( BUFR(1), NBRECORDS, MPI_COMPLEX, & MASTER, ARROWHEAD, & COMM, STATUS, IERR ) DO IREC=1, NB_REC IARR = BUFI( IREC * 2 ) JARR = BUFI( IREC * 2 + 1 ) VAL = BUFR( IREC ) IF ( MUMPS_TYPENODE( PROCNODE_STEPS(abs(STEP(abs(IARR)))), & KEEP(199) ) .eq. 3 & .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JARR ) ELSE IPOSROOT = root%RG2L( JARR ) JPOSROOT = root%RG2L( -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 roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%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 IS8 = PTRAW(IARR) DBLARR(IS8) = DBLARR( IS8 ) + VAL ELSE IS8 = PTRAW(IARR) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)), & KEEP(199) ) IF ( TYPE_PARALL .eq. 0 ) THEN IPROC = IPROC + 1 END IF IF (IPROC .EQ. MYID) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL CMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF END IF ENDIF ENDDO END DO 500 CONTINUE IF (allocated(BUFI ) ) DEALLOCATE( BUFI ) IF (allocated(BUFR ) ) DEALLOCATE( BUFR ) IF (allocated(IW4 ) ) DEALLOCATE( IW4 ) IF (allocated(PTRAW ) ) DEALLOCATE( PTRAW ) KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE CMUMPS_FACTO_RECV_ARROWHD2 SUBROUTINE CMUMPS_SET_TO_ZERO(A, LLD, M, N, KEEP) !$ USE OMP_LIB, ONLY : OMP_GET_MAX_THREADS IMPLICIT NONE INTEGER, INTENT(IN) :: LLD, M, N COMPLEX :: A(int(LLD,8)*int(N-1,8)+int(M,8)) INTEGER :: KEEP(500) COMPLEX, PARAMETER :: ZERO = (0.0E0,0.0E0) INTEGER I, J !$ INTEGER :: NOMP INTEGER(8) :: I8, LA !$ NOMP = OMP_GET_MAX_THREADS() IF (LLD .EQ. M) THEN LA=int(LLD,8)*int(N-1,8)+int(M,8) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC,KEEP(361)) !$OMP& IF ( LA > int(KEEP(361),8) .AND. NOMP .GT. 1) DO I8=1, LA A(I8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO PRIVATE(I,J) COLLAPSE(2) !$OMP& SCHEDULE(STATIC,KEEP(361)) IF (int(M,8)*int(N,8) !$OMP& .GT. KEEP(361).AND. NOMP .GT.1) DO I = 1, N DO J = 1, M A( int(I-1,8)*int(LLD,8)+ int(J,8) ) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE CMUMPS_SET_TO_ZERO SUBROUTINE CMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER(8), INTENT(IN) :: LA COMPLEX, INTENT(INOUT) :: A(LA) INTEGER :: KEEP(500) TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER :: LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT IF (KEEP(60)==0) THEN CALL CMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA) IF (LOCAL_N .GT. 0) THEN CALL CMUMPS_SET_TO_ZERO(A(PTR_ROOT), & LOCAL_M, LOCAL_M, LOCAL_N, KEEP) ENDIF ELSE IF (root%yes) THEN CALL CMUMPS_SET_TO_ZERO(roota%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC, & KEEP) ENDIF RETURN END SUBROUTINE CMUMPS_SET_ROOT_TO_ZERO SUBROUTINE CMUMPS_GET_ROOT_INFO(root, & LOCAL_M, LOCAL_N, PTR_ROOT, LA) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC), INTENT(IN) :: root INTEGER, INTENT(OUT) :: LOCAL_M, LOCAL_N INTEGER(8), INTENT(OUT) :: PTR_ROOT INTEGER(8), INTENT(IN) :: LA INTEGER, EXTERNAL :: MUMPS_NUMROC LOCAL_M = MUMPS_NUMROC( root%ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) LOCAL_M = max( 1, LOCAL_M ) LOCAL_N = MUMPS_NUMROC( root%ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) PTR_ROOT = LA - int(LOCAL_M,8) * int(LOCAL_N,8) + 1_8 RETURN END SUBROUTINE CMUMPS_GET_ROOT_INFO MUMPS_5.8.1/src/mumps_io_thread.c0000664000175000017500000004410215042446422016554 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mumps_io_basic.h" #include "mumps_io_err.h" #include "mumps_io_thread.h" #include "mumps_c_types.h" #if ! defined(MUMPS_WIN32) && ! defined(WITHOUT_PTHREAD) /* Exported global variables */ MUMPS_INT io_flag_stop,current_req_num; pthread_t io_thread,main_thread; pthread_mutex_t io_mutex; pthread_cond_t cond_io,cond_nb_free_finished_requests,cond_nb_free_active_requests,cond_stop; pthread_mutex_t io_mutex_cond; MUMPS_INT int_sem_io,int_sem_nb_free_finished_requests,int_sem_nb_free_active_requests,int_sem_stop; MUMPS_INT with_sem; struct request_io *io_queue; MUMPS_INT first_active,last_active,nb_active; MUMPS_INT *finished_requests_inode,*finished_requests_id,first_finished_requests, last_finished_requests,nb_finished_requests,smallest_request_id; MUMPS_INT mumps_owns_mutex; MUMPS_INT test_request_called_from_mumps; /* Other global variables */ double inactive_time_io_thread; MUMPS_INT time_flag_io_thread; struct timeval origin_time_io_thread; /** * Main function of the io thread when semaphores are used. */ void* mumps_async_thread_function_with_sem (void* arg){ struct request_io *current_io_request; MUMPS_INT ierr,_sem_stop; struct timeval start_time,end_time; MUMPS_INT ret_code; for (;;){ gettimeofday(&start_time,NULL); if(with_sem==2){ mumps_wait_sem(&int_sem_io,&cond_io); } /* sem_wait(&sem_io); */ gettimeofday(&end_time,NULL); if(time_flag_io_thread){ inactive_time_io_thread=inactive_time_io_thread+((double)end_time.tv_sec+((double)end_time.tv_usec/1000000))-((double)start_time.tv_sec+((double)start_time.tv_usec/1000000)); }else{ inactive_time_io_thread=((double)end_time.tv_sec+((double)end_time.tv_usec/1000000))-((double)origin_time_io_thread.tv_sec+((double)origin_time_io_thread.tv_usec/1000000)); } if(!time_flag_io_thread){ time_flag_io_thread=1; } /* Check if the main thread ordered to stop this slave thread */ /* sem_getvalue(&sem_stop,&_sem_stop); */ if(with_sem==2){ mumps_get_sem(&int_sem_stop,&_sem_stop); } if(_sem_stop==IO_FLAG_STOP){ /* The thread must stop */ break; /* Breaks the while loop. */ } current_io_request=&io_queue[first_active]; switch(current_io_request->io_type) { case IO_WRITE: ret_code=mumps_io_do_write_block(current_io_request->addr, current_io_request->size, &(current_io_request->file_type), current_io_request->vaddr, &ierr); if(ret_code<0){ goto end; } break; case IO_READ: ret_code=mumps_io_do_read_block(current_io_request->addr, current_io_request->size, &(current_io_request->file_type), current_io_request->vaddr, &ierr); if(ret_code<0){ goto end; } break; default: printf("Error : Mumps_IO : Operation %d is neither READ nor WRITE\n",current_io_request->io_type); exit (-3); } /* Notify that the IO was performed */ /* Wait that finished_requests queue could register the notification */ if(with_sem==2){ mumps_wait_sem(&int_sem_nb_free_finished_requests,&cond_nb_free_finished_requests); } pthread_mutex_lock(&io_mutex); /* Updates active queue bounds */ /* Register the notification in finished_requests queue and updates its bounds. */ finished_requests_id[last_finished_requests]=current_io_request->req_num; finished_requests_inode[last_finished_requests]=current_io_request->inode; last_finished_requests=(last_finished_requests+1)%(MAX_FINISH_REQ); /* ??? */ nb_finished_requests++; /* Realeases the lock : ***UNLOCK*** */ nb_active--; if(first_activeint_local_cond),&(current_io_request->local_cond)); } pthread_mutex_unlock(&io_mutex); /* Finally increases the number of free active requests.*/ /* sem_post(&sem_nb_free_active_requests); */ mumps_post_sem(&int_sem_nb_free_active_requests,&cond_nb_free_active_requests); } end: /* The main thread ordered the end of the IO thread (it changed sem_stop). We exit. */ pthread_exit(NULL); /* FIXME Not reached */ /* return NULL; */ } MUMPS_INT mumps_test_request_th(MUMPS_INT* request_id,MUMPS_INT *flag){ /* Tests if the request "request_id" has finished. It sets the flag */ /* argument to 1 if the request has finished (0 otherwise) */ MUMPS_INT request_pos; MUMPS_INT i; i=mumps_check_error_th(); if(i!=0){ return i; } pthread_mutex_lock(&io_mutex); /* printf("entering test !!! \n"); */ if(*request_id < smallest_request_id){ *flag=1; /* exit (-2); */ }else{ if(nb_finished_requests==0){ *flag=0; }else{ request_pos=(first_finished_requests+nb_finished_requests-1)%(MAX_IO*2); if(*request_id > finished_requests_id[request_pos]){ /*the request has not been treated yet since it is not in the list of treated requests*/ i=0; /*this loop is only for checking (no special treatment is done*/ while(i we just have to increase smallest_request_id*/ smallest_request_id++; if(!mumps_owns_mutex) pthread_mutex_unlock(&io_mutex); if(with_sem) { if(with_sem==2){ mumps_post_sem(&int_sem_nb_free_finished_requests,&cond_nb_free_finished_requests); } } return 0; } MUMPS_INT mumps_low_level_init_ooc_c_th(MUMPS_INT* async, MUMPS_INT* ierr){ MUMPS_INT i, ret_code; char buf[128]; /* Computes the number of files needed. Uses ceil value. */ *ierr=0; current_req_num=0; with_sem=2; first_active=0; last_active=0; nb_active=0; first_finished_requests=0; last_finished_requests=0; nb_finished_requests=0; smallest_request_id=0; mumps_owns_mutex=0; inactive_time_io_thread=0; time_flag_io_thread=0; gettimeofday(&origin_time_io_thread,NULL); /* mumps_io_flag_async=*async; */ if(*async!=IO_ASYNC_TH){ *ierr = -91; sprintf(buf,"Internal error: mumps_low_level_init_ooc_c_th should not to be called with strat_IO=%d\n",*async); return mumps_io_error(*ierr,buf); } if(*async){ pthread_mutex_init(&io_mutex,NULL); mumps_io_init_err_lock(); #ifdef WITH_PFUNC mumps_io_init_pointers_lock(); #endif io_queue=(struct request_io *)malloc(MAX_IO*sizeof(struct request_io)); if(with_sem==2){ for(i=0;i #include #include #include "zmumps_gpu.h" void MUMPS_CALL zmumps_gpu_return() { /* GPU feature will be available in the future */ } MUMPS_5.8.1/src/cstatic_ptr_m.F0000664000175000017500000000205715042446440016176 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_STATIC_PTR_M PUBLIC :: CMUMPS_TMP_PTR, CMUMPS_GET_TMP_PTR COMPLEX, DIMENSION(:), POINTER, SAVE :: CMUMPS_TMP_PTR CONTAINS SUBROUTINE CMUMPS_SET_STATIC_PTR(ARRAY) COMPLEX, DIMENSION(:), TARGET :: ARRAY CMUMPS_TMP_PTR => ARRAY RETURN END SUBROUTINE CMUMPS_SET_STATIC_PTR SUBROUTINE CMUMPS_GET_TMP_PTR(PTR) #if defined(MUMPS_NOF2003) COMPLEX, DIMENSION(:), POINTER :: PTR #else COMPLEX, DIMENSION(:), POINTER, INTENT(OUT) :: PTR #endif PTR => CMUMPS_TMP_PTR RETURN END SUBROUTINE CMUMPS_GET_TMP_PTR END MODULE CMUMPS_STATIC_PTR_M MUMPS_5.8.1/src/dfac_mem_dynamic.F0000664000175000017500000005200415042446440016577 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_DYNAMIC_MEMORY_M CONTAINS SUBROUTINE DMUMPS_DM_ALLOC_S_WK(S, MAXS, allocok, & KEEP430, KEEP35 ) IMPLICIT NONE DOUBLE PRECISION, DIMENSION(:), POINTER :: S INTEGER(8) :: MAXS INTEGER, INTENT(IN) :: KEEP35 INTEGER, INTENT(IN) :: KEEP430 INTEGER, INTENT(OUT) :: allocok INTEGER(8) :: TMP_ADDRESS8 IF (KEEP430.EQ.0) THEN ALLOCATE(S(MAXS), stat=allocok) ELSE IF (KEEP430.EQ.1) THEN CALL MUMPS_MALLOC_C( TMP_ADDRESS8, max(MAXS,1_8) * KEEP35 ) ELSE WRITE(*,*) "KEEP430: wrong value", KEEP430 CALL MUMPS_ABORT() ENDIF IF (TMP_ADDRESS8 .EQ. 0_8) THEN allocok = 1 ELSE allocok = 0 CALL DMUMPS_DM_SET_PTR( TMP_ADDRESS8, max(MAXS,1_8), S ) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_DM_ALLOC_S_WK SUBROUTINE DMUMPS_DM_FREE_S_WK( S, KEEP430 ) IMPLICIT NONE DOUBLE PRECISION, DIMENSION(:), POINTER :: S INTEGER, INTENT(IN) :: KEEP430 IF ( KEEP430 .EQ. 0 ) THEN DEALLOCATE(S) ELSE IF ( KEEP430 .EQ. 1 ) THEN CALL MUMPS_FREE_C(S(1)) #if defined(USE_XKBLAS) #endif ELSE WRITE(*,*) "KEEP430: wrong value", KEEP430 CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE DMUMPS_DM_FREE_S_WK SUBROUTINE DMUMPS_DM_SET_DYNPTR( CB_STATE, A, LA, & PAMASTER_OR_PTRAST, IXXD, & IXXR, SON_A, IACHK, RECSIZE ) IMPLICIT NONE INTEGER, INTENT(IN) :: CB_STATE INTEGER, INTENT(IN) :: IXXR(2), IXXD(2) INTEGER(8), INTENT(IN) :: LA, PAMASTER_OR_PTRAST DOUBLE PRECISION, INTENT(IN), TARGET :: A( LA ) #if defined(MUMPS_NOF2003) DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A #else DOUBLE PRECISION, POINTER, DIMENSION(:), INTENT(OUT) :: SON_A #endif INTEGER(8), INTENT(OUT) :: IACHK, RECSIZE IF ( DMUMPS_DM_IS_DYNAMIC( IXXD ) ) THEN CALL MUMPS_GETI8(RECSIZE, IXXD) CALL DMUMPS_DM_SET_PTR( PAMASTER_OR_PTRAST, RECSIZE, SON_A ) IACHK = 1_8 ELSE CALL MUMPS_GETI8(RECSIZE, IXXR) IACHK = PAMASTER_OR_PTRAST SON_A => A ENDIF RETURN END SUBROUTINE DMUMPS_DM_SET_DYNPTR SUBROUTINE DMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP28, & KEEP199, INODE, CB_STATE, IXXD, & STEP, DAD, PROCNODE_STEPS, & RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IMPLICIT NONE INTEGER, INTENT(in) :: KEEP28, N, SLAVEF, MYID, INODE, CB_STATE INTEGER, INTENT(in) :: KEEP199 INTEGER, INTENT(in) :: IXXD(2) INTEGER, INTENT(in) :: DAD(KEEP28) INTEGER, INTENT(in) :: STEP(N) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP28) LOGICAL, INTENT(out) :: IS_PAMASTER, IS_PTRAST INTEGER(8), INTENT(in) :: PAMASTER(KEEP28), PTRAST(KEEP28) INTEGER(8), INTENT(in) :: RCURRENT LOGICAL :: DAD_TYPE2_NOT_ON_MYID INTEGER :: NODETYPE, DADTYPE INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE IS_PAMASTER = .FALSE. IS_PTRAST = .FALSE. IF (CB_STATE .EQ. S_FREE) THEN RETURN ENDIF NODETYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), KEEP199) DADTYPE=-99999 DAD_TYPE2_NOT_ON_MYID = .FALSE. IF (DAD(STEP(INODE)) .NE. 0) THEN DADTYPE= MUMPS_TYPENODE( & PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP199) IF (DADTYPE .EQ. 2 .AND. & MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP199).NE.MYID & ) THEN DAD_TYPE2_NOT_ON_MYID = .TRUE. ENDIF ENDIF IF (DMUMPS_DM_ISBAND(CB_STATE)) THEN IS_PTRAST=.TRUE. ELSE IF (NODETYPE.EQ.1 & .AND. MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP199).EQ.MYID & .AND. DAD_TYPE2_NOT_ON_MYID) & THEN IS_PTRAST=.TRUE. ELSE IS_PAMASTER=.TRUE. ENDIF RETURN END SUBROUTINE DMUMPS_DM_PAMASTERORPTRAST LOGICAL FUNCTION DMUMPS_DM_ISBAND(XXSTATE) INTEGER, INTENT(IN) :: XXSTATE INCLUDE 'mumps_headers.h' SELECT CASE (XXSTATE) CASE(S_NOTFREE, S_CB1COMP); DMUMPS_DM_ISBAND = .FALSE. CASE(S_ACTIVE, S_ALL, & S_NOLCBCONTIG, S_NOLCBNOCONTIG, S_NOLCLEANED, & S_NOLCBNOCONTIG38, S_NOLCBCONTIG38, S_NOLCLEANED38, & S_NOLNOCB, S_NOLNOCBCLEANED); DMUMPS_DM_ISBAND = .TRUE. CASE(S_FREE); DMUMPS_DM_ISBAND = .FALSE. CASE DEFAULT; WRITE(*,*) "Wrong state during DMUMPS_DM_ISBAND", XXSTATE CALL MUMPS_ABORT() END SELECT RETURN END FUNCTION DMUMPS_DM_ISBAND LOGICAL FUNCTION DMUMPS_DM_IS_DYNAMIC(IXXD) INTEGER :: IXXD(2) INTEGER(8) :: DYN_SIZE CALL MUMPS_GETI8( DYN_SIZE, IXXD ) DMUMPS_DM_IS_DYNAMIC = DYN_SIZE > 0_8 RETURN END FUNCTION DMUMPS_DM_IS_DYNAMIC SUBROUTINE DMUMPS_DM_FAC_ALLOC_ALLOWED & (MEM_COUNT_TO_ALLOCATE, KEEP8, & IFLAG, IERROR) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_COUNT_TO_ALLOCATE INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR IF ( KEEP8(73) + MEM_COUNT_TO_ALLOCATE & .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & KEEP8(73) + MEM_COUNT_TO_ALLOCATE -KEEP8(75), & IERROR ) ENDIF RETURN END SUBROUTINE DMUMPS_DM_FAC_ALLOC_ALLOWED SUBROUTINE DMUMPS_DM_CBSTATIC2DYNAMIC( STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) !$ USE OMP_LIB USE MUMPS_LOAD, ONLY : MUMPS_LOAD_MEM_UPDATE IMPLICIT NONE INTEGER, INTENT(in) :: STRATEGY INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS DOUBLE PRECISION, INTENT(in) :: A( LA ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER, INTENT(inout) :: IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER :: ICURRENT, INODE, TYPEINODE, CB_STATE INTEGER(8) :: RCURRENT, RCURRENT_SIZE, SIZEHOLE INTEGER(8) :: KEEP8TMPCOPY LOGICAL :: MOVE2DYNAMIC LOGICAL :: SSARBRDAD INTEGER(8) :: TMP_ADDRESS, ITMP8 INTEGER(8) :: I8 DOUBLE PRECISION, DIMENSION(:), POINTER :: DYNAMIC_CB LOGICAL :: IS_PAMASTER, IS_PTRAST INTEGER :: allocok !$ INTEGER(8) :: CHUNK8 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP LOGICAL :: IFLAG_M13_OCCURED, IFLAG_M19_OCCURED INTEGER(8) :: MIN_SIZE_M13, MIN_SIZE_M19 INTEGER, EXTERNAL :: MUMPS_TYPENODE IF ( STRATEGY .EQ. 0 ) THEN IF (LRLUS.LT.SIZER_NEEDED) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) ENDIF RETURN ENDIF IFLAG_M13_OCCURED = .FALSE. MIN_SIZE_M13 = huge(MIN_SIZE_M13) IFLAG_M19_OCCURED = .FALSE. MIN_SIZE_M19 = huge(MIN_SIZE_M19) !$ NOMP = OMP_GET_MAX_THREADS() ICURRENT = IWPOSCB + 1 RCURRENT = IPTRLU + 1 IF (STRATEGY.EQ.1 .AND. SIZER_NEEDED.LE.LRLUS) GOTO 500 IF (( KEEP8(73) + SIZER_NEEDED-LRLUS).GT. & KEEP8(75)) THEN IFLAG = -19 CALL MUMPS_SET_IERROR & (KEEP8(73) + SIZER_NEEDED-LRLUS-KEEP8(75), IERROR) GOTO 500 ENDIF DO WHILE (ICURRENT .NE. LIW-KEEP(IXSZ)+1) INODE = IW(ICURRENT+XXN) CB_STATE = IW(ICURRENT+XXS) CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT+XXR)) CALL DMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP(28), & KEEP(199), INODE, CB_STATE, & IW(ICURRENT+XXD:ICURRENT+XXD+1), & STEP, DAD, PROCNODE_STEPS, & RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF ( CB_STATE .NE. S_FREE .AND. & .NOT. DMUMPS_DM_IS_DYNAMIC(IW(ICURRENT+XXD)) ) THEN TYPEINODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IF (STRATEGY .EQ. -1) THEN MOVE2DYNAMIC = .FALSE. MOVE2DYNAMIC = MOVE2DYNAMIC .OR. & CB_STATE .EQ. S_NOLCBCONTIG .OR. & CB_STATE .EQ. S_NOLCBNOCONTIG .OR. & CB_STATE .EQ. S_NOLCLEANED .OR. & CB_STATE .EQ. S_ALL .OR. & CB_STATE .EQ. S_ACTIVE ELSE IF (STRATEGY .EQ. 2 .OR. STRATEGY .EQ. 3) THEN MOVE2DYNAMIC = .TRUE. MOVE2DYNAMIC = MOVE2DYNAMIC .AND. (TYPEINODE.NE.3) ELSE IF (STRATEGY .EQ. 1) THEN MOVE2DYNAMIC = .FALSE. IF (LRLUS.GT.SIZER_NEEDED) GOTO 500 IF (TYPEINODE.EQ.3) GOTO 100 MOVE2DYNAMIC = MOVE2DYNAMIC.OR..TRUE. ELSE WRITE(*,*) "Internal error in DMUMPS_DM_CBSTATIC2DYNAMIC", & MOVE2DYNAMIC CALL MUMPS_ABORT() ENDIF MOVE2DYNAMIC = MOVE2DYNAMIC .AND. (RCURRENT_SIZE .NE. 0_8) MOVE2DYNAMIC = MOVE2DYNAMIC .AND. & .NOT. ((ICURRENT.EQ.IWPOSCB + 1).AND.(SKIP_TOP_STACK)) IF (STRATEGY .NE. 3) THEN IF ( KEEP(405) .EQ. 1 ) THEN !$OMP ATOMIC READ KEEP8TMPCOPY = KEEP8(73) !$OMP END ATOMIC ELSE KEEP8TMPCOPY = KEEP8(73) ENDIF IF ( RCURRENT_SIZE + KEEP8TMPCOPY .GT. KEEP8(75) ) THEN IFLAG_M19_OCCURED= .TRUE. MIN_SIZE_M19 = min( MIN_SIZE_M19, & RCURRENT_SIZE+KEEP8(73)-KEEP8(75) ) MOVE2DYNAMIC = .FALSE. ENDIF ENDIF IF ( MOVE2DYNAMIC ) THEN #if defined(MUMPS_ALLOC_FROM_C) || defined(_CRAYFTN) CALL MUMPS_MALLOC_C( TMP_ADDRESS, & RCURRENT_SIZE * KEEP(35) ) IF (TMP_ADDRESS .EQ. 0_8) THEN allocok=1 ELSE allocok=0 ENDIF #else ALLOCATE(DYNAMIC_CB(RCURRENT_SIZE), stat=allocok) #endif IF (allocok .GT. 0) THEN IF ( (STRATEGY .NE. 1).OR. & (SIZER_NEEDED-LRLUS).GE.RCURRENT_SIZE) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) GOTO 500 ENDIF IFLAG_M13_OCCURED = .TRUE. MIN_SIZE_M13 = min(MIN_SIZE_M13, RCURRENT_SIZE) GOTO 100 ENDIF SIZEHOLE=0_8 IF (KEEP(216).NE.3) THEN CALL DMUMPS_SIZEFREEINREC( IW(ICURRENT), & LIW-ICURRENT+1, SIZEHOLE, KEEP(IXSZ)) ENDIF CALL MUMPS_STOREI8(RCURRENT_SIZE,IW(ICURRENT+XXD)) #if defined(MUMPS_ALLOC_FROM_C) || defined(_CRAYFTN) CALL DMUMPS_DM_SET_PTR( TMP_ADDRESS, RCURRENT_SIZE, & DYNAMIC_CB ) #else CALL MUMPS_ADDR_C(DYNAMIC_CB(1), TMP_ADDRESS) #endif IF (IS_PTRAST) THEN PTRAST(STEP(INODE)) = TMP_ADDRESS ELSE IF (IS_PAMASTER) THEN PAMASTER(STEP(INODE)) = TMP_ADDRESS ELSE WRITE(*,*) & "Internal error 3 in DMUMPS_DM_CBSTATIC2DYNAMIC", & RCURRENT, PTRAST(STEP(INODE)), PAMASTER(STEP(INODE)) CALL MUMPS_ABORT() ENDIF ITMP8 = (RCURRENT_SIZE-SIZEHOLE) LRLUS = LRLUS + ITMP8 IF (KEEP(405).EQ.1) THEN IF (SIZEHOLE .NE. 0_8) THEN !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + SIZEHOLE KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max( KEEP8(68), KEEP8TMPCOPY ) !$OMP END ATOMIC ENDIF ELSE KEEP8(69) = KEEP8(69) + SIZEHOLE KEEP8(68) = max( KEEP8(68), KEEP8(69) ) ENDIF CALL MUMPS_SET_SSARBR_DAD(SSARBRDAD, INODE, & DAD, N, KEEP(28), & STEP, PROCNODE_STEPS, KEEP(199)) CALL MUMPS_LOAD_MEM_UPDATE( SSARBRDAD, .FALSE., & LA - LRLUS, 0_8, -(RCURRENT_SIZE-SIZEHOLE), & KEEP, KEEP8, LRLUS) IF (ICURRENT .EQ. IWPOSCB+1) THEN IPTRLU = IPTRLU + RCURRENT_SIZE LRLU = LRLU + RCURRENT_SIZE CALL MUMPS_STOREI8(0_8, IW(ICURRENT+XXR)) ENDIF IF (STRATEGY .NE. 3) THEN CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS ( & RCURRENT_SIZE, KEEP(405).EQ.1, KEEP8, & IFLAG, IERROR, .FALSE., .FALSE.) IF (IFLAG.LT.0) GOTO 500 ENDIF !$ CHUNK8 = max( int(KEEP(361),8), !$ & (RCURRENT_SIZE+NOMP-1) / NOMP) !$ OMP_FLAG = ( (RCURRENT_SIZE > int(KEEP(361),8)) !$ & .AND.(NOMP.GT.1) !$ & ) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (OMP_FLAG) DO I8=1_8, RCURRENT_SIZE DYNAMIC_CB(I8) = A(RCURRENT+I8-1_8) ENDDO !$OMP END PARALLEL DO ENDIF ENDIF 100 CONTINUE RCURRENT = RCURRENT + RCURRENT_SIZE ICURRENT = ICURRENT + IW(ICURRENT+XXI) END DO IF (LRLUS.LT.SIZER_NEEDED) THEN IF (IFLAG_M19_OCCURED) THEN IFLAG = -19 CALL MUMPS_SET_IERROR(MIN_SIZE_M19, IERROR) ELSE IF (IFLAG_M13_OCCURED) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(MIN_SIZE_M13, IERROR) ELSE IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_DM_CBSTATIC2DYNAMIC SUBROUTINE DMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(in) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) LOGICAL, INTENT(in) :: ATOMIC_UPDATES INCLUDE 'mumps_headers.h' INTEGER :: ICURRENT, INODE INTEGER :: CB_STATE INTEGER(8) :: DYN_SIZE, TMP_ADDRESS INTEGER(8), PARAMETER :: RDUMMY = -987654 LOGICAL :: IS_PAMASTER, IS_PTRAST DOUBLE PRECISION, DIMENSION(:), POINTER :: TMP_PTR ICURRENT = IWPOSCB + 1 IF (KEEP8(73) .NE. 0_8) THEN DO WHILE (ICURRENT .LT. LIW-KEEP(IXSZ)+1) INODE = IW(ICURRENT+XXN) CB_STATE = IW(ICURRENT+XXS) IF (CB_STATE.NE.S_FREE) THEN CALL MUMPS_GETI8( DYN_SIZE, IW(ICURRENT+XXD) ) IF (DYN_SIZE .GT. 0_8) THEN CALL DMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP(28), & KEEP(199), INODE, CB_STATE, IW(ICURRENT+XXD), & STEP, DAD, PROCNODE_STEPS, & RDUMMY, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF (IS_PAMASTER) THEN TMP_ADDRESS = PAMASTER(STEP(INODE)) ELSE IF (IS_PTRAST) THEN TMP_ADDRESS = PTRAST(STEP(INODE)) ELSE WRITE(*,*) "Internal error 1 in DMUMPS_DM_FREEALLDYNAMICCB" & , IS_PTRAST, IS_PAMASTER ENDIF CALL DMUMPS_DM_SET_PTR(TMP_ADDRESS, DYN_SIZE, TMP_PTR) CALL DMUMPS_DM_FREE_BLOCK( IW(ICURRENT+XXG), & TMP_PTR, DYN_SIZE, & ATOMIC_UPDATES, KEEP8 ) CALL MUMPS_STOREI8(0_8, IW(ICURRENT+XXD)) ENDIF ENDIF ICURRENT = ICURRENT + IW(ICURRENT+XXI) ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_DM_FREEALLDYNAMICCB SUBROUTINE DMUMPS_DM_SET_PTR(ADDRESS, SIZFR8, CBPTR) USE DMUMPS_STATIC_PTR_M, ONLY : DMUMPS_GET_TMP_PTR IMPLICIT NONE INTEGER(8), INTENT(IN) :: ADDRESS, SIZFR8 #if defined(MUMPS_NOF2003) DOUBLE PRECISION, DIMENSION(:), POINTER :: CBPTR #else DOUBLE PRECISION, DIMENSION(:), POINTER, INTENT(out) :: CBPTR #endif !$OMP CRITICAL(STATIC_PTR_ACCESS) CALL DMUMPS_SET_TMP_PTR_C( ADDRESS, SIZFR8 ) CALL DMUMPS_GET_TMP_PTR( CBPTR ) !$OMP END CRITICAL(STATIC_PTR_ACCESS) RETURN END SUBROUTINE DMUMPS_DM_SET_PTR SUBROUTINE DMUMPS_DM_FREE_BLOCK( XXG_STATUS, DYNPTR, SIZFR8, & ATOMIC_UPDATES, KEEP8 ) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER :: XXG_STATUS DOUBLE PRECISION, POINTER, DIMENSION(:) :: DYNPTR INTEGER(8) :: SIZFR8 LOGICAL, INTENT(IN) :: ATOMIC_UPDATES INTEGER(8) :: KEEP8(150) INTEGER IDUMMY #if defined(MUMPS_ALLOC_FROM_C) || defined(_CRAYFTN) CALL MUMPS_FREE_C(DYNPTR(1)) #else DEALLOCATE(DYNPTR) #endif NULLIFY(DYNPTR) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS ( & -SIZFR8, ATOMIC_UPDATES, KEEP8, IDUMMY, IDUMMY, & .TRUE., .FALSE.) RETURN END SUBROUTINE DMUMPS_DM_FREE_BLOCK END MODULE DMUMPS_DYNAMIC_MEMORY_M SUBROUTINE DMUMPS_DM_FREEALLDYNAMICCB_I( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_FREEALLDYNAMICCB IMPLICIT NONE INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(in) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) LOGICAL, INTENT(in) :: ATOMIC_UPDATES CALL DMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) RETURN END SUBROUTINE DMUMPS_DM_FREEALLDYNAMICCB_I SUBROUTINE DMUMPS_DM_CBSTATIC2DYNAMIC_I( & STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_CBSTATIC2DYNAMIC IMPLICIT NONE INTEGER, INTENT(in) :: STRATEGY INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS DOUBLE PRECISION, INTENT(in) :: A( LA ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER, INTENT(inout) :: IFLAG, IERROR CALL DMUMPS_DM_CBSTATIC2DYNAMIC( STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) RETURN END SUBROUTINE DMUMPS_DM_CBSTATIC2DYNAMIC_I MUMPS_5.8.1/src/cfac_b.F0000664000175000017500000006112615042446440014542 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_FAC_B( N, S_IS_POINTERS, LA, LIW, SYM_PERM, & NA, LNA, NE_STEPS, NFSIZ, FILS, STEP, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PTRAR, LDPTRAR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, PTRIST, & PTLUST_S, PTRFAC, IW1, IW2, ITLOC, RHS_MUMPS, POOL, LPOOL, & CNTL1, ICNTL, INFO, RINFO, KEEP, KEEP8, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & CMUMPS_LBUF, INTARR, DBLARR, root, roota, NELT, FRTPTR, FRTELT, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, & DKEEP, PIVNUL_LIST_STRUCT, LRGROUPS & ,IPOOL_B_L0_OMP, LPOOL_B_L0_OMP, IPOOL_A_L0_OMP, & LPOOL_A_L0_OMP, L_VIRT_L0_OMP, VIRT_L0_OMP, & VIRT_L0_OMP_MAPPING, L_PHYS_L0_OMP, PHYS_L0_OMP, PERM_L0_OMP, & PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, THREAD_LA, & L0_OMP_FACTORS, LL0_OMP_FACTORS, I4_L0_OMP, NBSTATS_I4, & NBCOLS_I4, I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) USE MUMPS_LOAD USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_ALLOC_CB, & MUMPS_BUF_DEALL_CB USE CMUMPS_BUF, ONLY : CMUMPS_BUF_MAX_ARRAY_MINSIZE & , CMUMPS_BUF_DEALL_MAX_ARRAY USE CMUMPS_FAC_S_IS_POINTERS_M, ONLY : CMUMPS_S_IS_POINTERS_T USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T USE OMP_LIB USE MUMPS_TPS_M USE CMUMPS_TPS_M USE CMUMPS_FAC_OMP_M USE CMUMPS_DYNAMIC_MEMORY_M, ONLY: CMUMPS_DM_ALLOC_S_WK, & CMUMPS_DM_FREE_S_WK USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC & , CMUMPS_L0OMPFAC_T IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER(8) :: LA INTEGER N,LIW,LPOOL,SLAVEF,COMM_NODES INTEGER MYID, MYID_NODES,LNA TYPE (CMUMPS_S_IS_POINTERS_T) :: S_IS_POINTERS REAL RINFO(40) INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES INTEGER :: BUFR( LBUFR ) INTEGER, INTENT( IN ) :: CMUMPS_LBUF INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER NELT, LDPTRAR INTEGER FRTPTR(*), FRTELT(*) REAL CNTL1 INTEGER ICNTL(60) INTEGER INFO(80), KEEP(500) INTEGER(8) KEEP8(150) INTEGER LRGROUPS(KEEP(280)) INTEGER SYM_PERM(N), NA(LNA), & NE_STEPS(KEEP(28)), FILS(N), & FRERE(KEEP(28)), NFSIZ(KEEP(28)), & DAD(KEEP(28)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER STEP(N) INTEGER(8), INTENT(IN) :: PTRAR(LDPTRAR,2) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IW1(2*KEEP(28)), ITLOC(N+KEEP(253)), POOL(LPOOL) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: IW2(2*KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER COMM_LOAD, ASS_IRECV INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) COMPLEX DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) REAL SEUIL, SEUIL_LDLT_NIV2 TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER, INTENT (IN) :: LPOOL_B_L0_OMP INTEGER, INTENT (IN) :: IPOOL_B_L0_OMP( LPOOL_B_L0_OMP ) INTEGER, INTENT (IN) :: LPOOL_A_L0_OMP INTEGER, INTENT (IN) :: IPOOL_A_L0_OMP( LPOOL_A_L0_OMP ) INTEGER, INTENT (IN) :: L_PHYS_L0_OMP INTEGER, INTENT (IN) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT (IN) :: L_VIRT_L0_OMP INTEGER, INTENT (IN) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT (IN) :: VIRT_L0_OMP_MAPPING( L_VIRT_L0_OMP ) INTEGER, INTENT (IN) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT (IN) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT (IN) :: LL0_OMP_MAPPING INTEGER, INTENT (OUT):: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INTEGER, INTENT (IN) :: LL0_OMP_FACTORS TYPE(CMUMPS_L0OMPFAC_T), INTENT (INOUT) :: L0_OMP_FACTORS( & LL0_OMP_FACTORS ) INTEGER, INTENT (IN) :: NBSTATS_I4, NBSTATS_I8 INTEGER, INTENT (IN) :: NBCOLS_I4, NBCOLS_I8 INTEGER, INTENT (IN) :: I4_L0_OMP(NBSTATS_I4, NBCOLS_I4) INTEGER(8), INTENT (IN) :: I8_L0_OMP(NBSTATS_I8, NBCOLS_I8) INTEGER(8), INTENT ( IN ) :: THREAD_LA INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER allocok REAL UULOC INTEGER IERR INTEGER LP, MPRINT LOGICAL LPOK INTEGER NSTK,PTRAST INTEGER PIMASTER, PAMASTER LOGICAL PROK REAL,PARAMETER :: ZERO = 0.0E0 INTEGER I INTEGER LTPS_ARR TYPE (MUMPS_TPS_T), DIMENSION(:), ALLOCATABLE :: MUMPS_TPS_ARR TYPE (CMUMPS_TPS_T), DIMENSION(:), ALLOCATABLE :: CMUMPS_TPS_ARR INTEGER NBROOT_UNDER_L0 INTEGER :: NSTEPSDONE DOUBLE PRECISION :: OPASS, OPELI INTEGER :: NELVA, COMP INTEGER :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV, NULLNEGPV INTEGER :: NB22T1, NB22T2, NBTINY, DET_EXP, DET_SIGN COMPLEX :: DET_MANT INTEGER :: NTOTPVTOT INTEGER(8) :: POSFAC, LRLU, IPTRLU, LRLUS INTEGER IWPOS, LEAF, NBROOT, NROOT INTEGER :: LIW_ARG_FAC_PAR INTEGER(8) :: LA_ARG_FAC_PAR COMPLEX, TARGET:: CDUMMY(1) INTEGER, TARGET :: IDUMMY(1) LOGICAL :: IW_DUMMY, A_DUMMY, & IW_ALLOCATED_HERE, A_ALLOCATED_HERE KEEP(41)=0 KEEP(42)=0 LP = ICNTL(1) LPOK = (LP.GT.0) .AND. (ICNTL(4).GE.1) MPRINT = ICNTL(2) PROK = (MPRINT.GT.0) .AND. (ICNTL(4).GE.2) UULOC = CNTL1 PIMASTER = 1 NSTK = PIMASTER + KEEP(28) PTRAST = 1 PAMASTER = 1 + KEEP(28) IF (KEEP(4).LE.0) KEEP(4)=32 IF (KEEP(5).LE.0) KEEP(5)=16 IF (KEEP(5).GT.KEEP(4)) KEEP(5) = KEEP(4) IF (KEEP(6).LE.0) KEEP(6)=24 IF (KEEP(3).LE.KEEP(4)) KEEP(3)=KEEP(4)*2 IF (KEEP(6).GT.KEEP(3)) KEEP(6) = KEEP(3) POSFAC = 1_8 IWPOS = 1 LRLU = LA LRLUS = LRLU KEEP8(62) = 0_8 KEEP8(63) = 0_8 KEEP8(64) = 0_8 KEEP8(65) = 0_8 KEEP8(66) = 0_8 KEEP8(68) = 0_8 KEEP8(69) = 0_8 KEEP8(70) = 0_8 KEEP8(71) = 0_8 KEEP8(73) = 0_8 KEEP8(74) = 0_8 IPTRLU = LRLU DKEEP(19)=huge(0.0E0) DKEEP(20)=huge(0.0E0) DKEEP(21)=0.0E0 NSTEPSDONE = 0 OPASS = 0.0D0 OPELI = 0.0D0 NELVA = 0 COMP = 0 MAXFRT = 0 NMAXNPIV = 0 NTOTPV = 0 NOFFNEGPV = 0 NULLNEGPV = 0 NB22T1 = 0 NB22T2 = 0 NBTINY = 0 DET_EXP = 0 DET_SIGN = 1 DET_MANT = cmplx(1.0E0,0.0E0, kind=kind(1.0E0)) IW1(NSTK:NSTK+KEEP(28)-1) = NE_STEPS(1:KEEP(28)) CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, NROOT, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP, STEP, & PROCNODE_STEPS) IF (KEEP(400) .GT. 0 & ) THEN IF (LPOOL .NE. LPOOL_A_L0_OMP) THEN WRITE(*,*) "Check LPOOL vs. LPOOL_A_L0_OMP", & LPOOL, LPOOL_A_L0_OMP, KEEP(28) CALL MUMPS_ABORT() ENDIF DO I = 1, LPOOL POOL(I) = IPOOL_A_L0_OMP(I) ENDDO ELSE CALL MUMPS_INIT_POOL_DIST(N, LEAF, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, & POOL, LPOOL) CALL CMUMPS_INIT_POOL_LAST3(POOL, LPOOL, LEAF) ENDIF CALL MUMPS_LOAD_INIT_SBTR_STRUCT(POOL, LPOOL,KEEP,KEEP8) IF ( KEEP( 38 ) .NE. 0 ) THEN NBROOT = NBROOT + root%NPROW * root%NPCOL - 1 END IF IF ( root%yes ) THEN IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(KEEP(38))), & KEEP(199) ) & .NE. MYID_NODES ) THEN NROOT = NROOT + 1 END IF END IF PTRIST(1:KEEP(28))=0 PTLUST_S(1:KEEP(28))=0 PTRFAC(1:KEEP(28))=-99999_8 IW2(PTRAST:PTRAST+KEEP(28)-1)=0_8 IW1(PIMASTER:PIMASTER+KEEP(28)-1)=-99999_8 KEEP(405) = 0 NBROOT_UNDER_L0 = 0 IF (KEEP(400).GT.0 & ) THEN KEEP(405)=1 ALLOCATE( MUMPS_TPS_ARR( KEEP(400) ), stat=allocok ) IF (allocok .GT. 0) THEN IF (LPOK) THEN WRITE(LP,*) "Problem allocating MUMPS_TPS_ARR", & KEEP(400) ENDIF CALL MUMPS_ABORT() ENDIF ALLOCATE( CMUMPS_TPS_ARR( KEEP(400) ), stat=allocok ) IF (allocok .GT. 0) THEN WRITE(*,*) "Problem allocating CMUMPS_TPS_ARR", KEEP(400) CALL MUMPS_ABORT() ENDIF CALL CMUMPS_FAC_L0_OMP(N,LIW, IW1(NSTK), NFSIZ, FILS,STEP,FRERE, & DAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, PTRIST, IW2(PTRAST), & IW1(PIMASTER), IW2(PAMASTER), PTRAR(1,2), PTRAR(1,1), & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, RINFO, NROOT, NBROOT, NBROOT_UNDER_L0, & UULOC, ICNTL, PTLUST_S, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS,SLAVEF, COMM_NODES, MYID, MYID_NODES, BUFR, & LBUFR,LBUFR_BYTES,INTARR,DBLARR,root,roota,SYM_PERM,NELT,FRTPTR, & FRTELT, LDPTRAR, COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB, NE_STEPS, DKEEP, PIVNUL_LIST_STRUCT, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, L_VIRT_L0_OMP, & VIRT_L0_OMP, VIRT_L0_OMP_MAPPING, L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, & THREAD_LA, MUMPS_TPS_ARR, CMUMPS_TPS_ARR, NSTEPSDONE, & OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, NOFFNEGPV, & NULLNEGPV, NB22T1, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & LRGROUPS(1), L0_OMP_FACTORS, LL0_OMP_FACTORS, & I4_L0_OMP, NBSTATS_I4, NBCOLS_I4, & I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 ) KEEP(405)=0 DKEEP(16) = OPELI KEEP8(75)=KEEP8(76) KEEP8(63)=KEEP8(74) KEEP8(62) = KEEP8(74)-KEEP8(62) IF (INFO(1) .LT. 0) THEN KEEP8(69) = KEEP8(73) ENDIF KEEP8(74) = KEEP8(73) IF ((INFO(1).GE.0).AND.(KEEP8(74).GT.KEEP8(75))) THEN INFO(1) = -19 CALL MUMPS_SET_IERROR ( & KEEP8(74)-KEEP8(75), INFO(2)) IF (LPOK) THEN WRITE(LP,'(/A/,A,I8,A,I10/,A/,A/)') & '** ERROR: memory allowed (ICNTL(23)) is not large enough:', & ' INFO(1)=', INFO(1), ' INFO(2)=', INFO(2), & ' memory used at the end of the treatment of L0 thread ', & ' does not enable processing nodes above L0 thread ' ENDIF ENDIF KEEP8(66) = KEEP8(68) KEEP8(65) = KEEP8(64) + KEEP8(71) ENDIF KEEP8(67) = LRLUS IW_ALLOCATED_HERE = .FALSE. A_ALLOCATED_HERE = .FALSE. IF (associated(S_IS_POINTERS%IW)) THEN WRITE(*,*) " Internal error CMUMPS_FAC_B IW" CALL MUMPS_ABORT() ENDIF IF (INFO(1) .GE. 0 ) THEN ALLOCATE(S_IS_POINTERS%IW(LIW), stat=allocok) IF (allocok .GT.0) THEN INFO(1) = -13 INFO(2) = LIW IF (LPOK) THEN WRITE(LP,*) & 'Allocation error for id%IS(',LIW,') on worker', & MYID_NODES ENDIF ELSE IW_ALLOCATED_HERE = .TRUE. ENDIF ENDIF IF (INFO(1) .GE. 0) THEN IF (.NOT. associated(S_IS_POINTERS%A)) THEN CALL CMUMPS_DM_ALLOC_S_WK(S_IS_POINTERS%A, & LA, allocok, KEEP(430), KEEP(35) ) IF (allocok .GT. 0) THEN INFO(1) = -13 CALL MUMPS_SETI8TOI4(LA, INFO(2)) DEALLOCATE(S_IS_POINTERS%IW); NULLIFY(S_IS_POINTERS%IW) IW_ALLOCATED_HERE = .FALSE. KEEP8(23)=0_8 ELSE A_ALLOCATED_HERE = .TRUE. KEEP8(23)=LA ENDIF ENDIF ENDIF IF (INFO(1) .GE. 0) THEN CALL MUMPS_BUF_ALLOC_CB( CMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1)= -13 INFO(2)= (CMUMPS_LBUF+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) & 'Allocation error in CMUMPS_BUF_ALLOC_CB' & ,INFO(2), ' on worker', MYID_NODES ENDIF ELSE IF ((KEEP(50).EQ.2).AND.(KEEP(219).NE.0)) THEN CALL CMUMPS_BUF_MAX_ARRAY_MINSIZE(max(KEEP(108),1),IERR) IF (IERR .NE. 0) THEN INFO(1) = -13 INFO(2) = max(KEEP(108),1) END IF ENDIF ENDIF ENDIF IF ( KEEP(400) .EQ. 0 & ) THEN LTPS_ARR = 1 ALLOCATE( MUMPS_TPS_ARR(1)) ALLOCATE(CMUMPS_TPS_ARR(1)) ELSE LTPS_ARR = KEEP(400) ENDIF IW_DUMMY = .FALSE.; A_DUMMY = .FALSE.; IF (INFO(1) .GE. 0) THEN LIW_ARG_FAC_PAR = LIW LA_ARG_FAC_PAR = LA ELSE IF (IW_ALLOCATED_HERE) THEN DEALLOCATE(S_IS_POINTERS%IW) NULLIFY(S_IS_POINTERS%IW) IW_ALLOCATED_HERE = .FALSE. ENDIF IF (A_ALLOCATED_HERE) THEN CALL CMUMPS_DM_FREE_S_WK(S_IS_POINTERS%A, KEEP(430)) NULLIFY(S_IS_POINTERS%A) A_ALLOCATED_HERE = .FALSE. ENDIF LIW_ARG_FAC_PAR = 1 LA_ARG_FAC_PAR = 1_8 IF (.NOT. associated(S_IS_POINTERS%IW)) THEN S_IS_POINTERS%IW => IDUMMY IW_DUMMY = .TRUE. ENDIF IF (.NOT. associated(S_IS_POINTERS%A)) THEN S_IS_POINTERS%A => CDUMMY A_DUMMY = .TRUE. ENDIF ENDIF IF ( INFO(1) .LT. 0 ) THEN CALL CMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP ) ENDIF KEEP(398)=NSTEPSDONE CALL CMUMPS_FAC_PAR_I(N,S_IS_POINTERS%IW(1),LIW_ARG_FAC_PAR, & S_IS_POINTERS%A(1),LA_ARG_FAC_PAR,IW1(NSTK), NFSIZ,FILS,STEP, & FRERE,DAD,CAND,ISTEP_TO_INIV2, TAB_POS_IN_PERE, NSTEPSDONE, & OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, NOFFNEGPV, & NULLNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & PTRIST, IW2(PTRAST), IW1(PIMASTER), IW2(PAMASTER), & PTRAR(1,2), PTRAR(1,1), PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, POOL, LPOOL, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & MUMPS_TPS_ARR, CMUMPS_TPS_ARR, LTPS_ARR, & RINFO, POSFAC, IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NROOT, NBROOT, & NBROOT_UNDER_L0, & UULOC, ICNTL, PTLUST_S, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS,SLAVEF,MYID,COMM_NODES, MYID_NODES, BUFR, LBUFR, & LBUFR_BYTES, INTARR, DBLARR, root, roota, SYM_PERM, NELT, FRTPTR, & FRTELT, LDPTRAR, COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB,NE_STEPS, DKEEP(1),PIVNUL_LIST_STRUCT, & LRGROUPS(1) ) IF (IW_DUMMY) THEN NULLIFY( S_IS_POINTERS%IW ) ENDIF IF (A_DUMMY) THEN NULLIFY( S_IS_POINTERS%A ) ENDIF IF ((KEEP(50).EQ.2).AND.(KEEP(219).NE.0)) THEN CALL CMUMPS_BUF_DEALL_MAX_ARRAY() ENDIF CALL MUMPS_BUF_DEALL_CB( IERR ) RINFO(2) = real(OPASS) RINFO(3) = real(OPELI) INFO(13) = NELVA INFO(14) = COMP KEEP(33) = MAXFRT; INFO(11) = MAXFRT KEEP(246) = NMAXNPIV KEEP(89) = NTOTPV; INFO(23) = NTOTPV INFO(12) = NOFFNEGPV INFO(40) = NULLNEGPV KEEP(103) = NB22T1 KEEP(105) = NB22T2 KEEP(98) = NBTINY IF (KEEP(258) .NE. 0) THEN KEEP(260) = KEEP(260) * DET_SIGN KEEP(259) = KEEP(259) + DET_EXP CALL CMUMPS_UPDATEDETER( DET_MANT, DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(400) .GT. 0 & ) THEN IF (LL0_OMP_FACTORS.NE.KEEP(400)) THEN WRITE(*,*) "Internal error in CMUMPS_FAC_B, KEEP(400), L..=", & KEEP(400), LL0_OMP_FACTORS CALL MUMPS_ABORT() ENDIF IF ( INFO(1) .GE. 0 ) THEN CALL CMUMPS_L0OMP_COPY_IW(S_IS_POINTERS%IW, & LIW, IWPOS, MUMPS_TPS_ARR, KEEP, PTLUST_S, & ICNTL, INFO) ENDIF !$OMP PARALLEL DO DO I=1, KEEP(400) IF (INFO(1) .LT. 0) THEN IF ( associated( L0_OMP_FACTORS(I)%A ) ) THEN DEALLOCATE( L0_OMP_FACTORS(I)%A ) NULLIFY ( L0_OMP_FACTORS(I)%A ) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -L0_OMP_FACTORS(I)%LA, .TRUE., & KEEP8, INFO(1), INFO(2), .TRUE., .FALSE. ) ENDIF L0_OMP_FACTORS(I)%LA = -99999_8 ENDIF IF (associated(MUMPS_TPS_ARR(I)%IW)) THEN DEALLOCATE(MUMPS_TPS_ARR(I)%IW) NULLIFY(MUMPS_TPS_ARR(I)%IW) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -((int(MUMPS_TPS_ARR(I)%LIW,8) * int(KEEP(34),8)) & / int(KEEP(35),8)), & .TRUE., & KEEP8, INFO(1), INFO(2), .TRUE., .FALSE. ) ENDIF ENDDO !$OMP END PARALLEL DO ENDIF IF (allocated(MUMPS_TPS_ARR)) THEN DEALLOCATE(MUMPS_TPS_ARR) ENDIF IF (allocated(CMUMPS_TPS_ARR)) THEN DEALLOCATE(CMUMPS_TPS_ARR) ENDIF POSFAC = POSFAC -1_8 IWPOS = IWPOS -1 IF (KEEP(201).LE.0) THEN IF (KEEP(201) .EQ. -1 .AND. INFO(1) .LT. 0) THEN POSFAC = 0_8 ENDIF KEEP8(31) = POSFAC RINFO(6) = ZERO ELSE RINFO(6) = real(KEEP8(31)*int(KEEP(35),8))/1E6 ENDIF KEEP8(48) = KEEP8(31)+KEEP8(71)+KEEP8(64) KEEP(32) = IWPOS CALL MUMPS_SETI8TOI4(KEEP8(48), INFO(9)) INFO(10) = KEEP(32) KEEP8(67) = LA - KEEP8(67) CALL MPI_ALLREDUCE(NTOTPV, NTOTPVTOT, 1, MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR) IF ( ( (INFO(1).EQ.-10 .OR. INFO(1).EQ.-40) & .AND. (NTOTPVTOT.EQ.N) ) & .OR. ( NTOTPVTOT.GT.N ) ) THEN write(*,*) ' Error 1 NTOTPVTOT=', NTOTPVTOT,N CALL MUMPS_ABORT() ENDIF IF ( (KEEP(19).NE.0 ) .AND. (NTOTPVTOT.NE.N) .AND. & (INFO(1).GE.0) ) THEN write(*,*) ' Error 2 NTOTPVTOT=', NTOTPVTOT CALL MUMPS_ABORT() ENDIF IF ( (INFO(1) .GE. 0 ) & .AND. (NTOTPVTOT.NE.N) ) THEN INFO(1) = -10 ENDIF IF (INFO(1).EQ.-10) THEN INFO(2) = NTOTPVTOT ENDIF IF (PROK) THEN WRITE (MPRINT,99980) INFO(1), INFO(2), & KEEP(28), KEEP8(48), INFO(10), INFO(11) IF(KEEP(50) .EQ. 0) THEN WRITE(MPRINT,99982) INFO(12) ENDIF WRITE (MPRINT, 99986) & INFO(13), INFO(14), RINFO(2), RINFO(3) IF (KEEP(97) .NE. 0) THEN WRITE (MPRINT, 99987) INFO(25) ENDIF ENDIF RETURN 99980 FORMAT (/' LEAVING FACTORIZATION PHASE WITH ...'/ & ' INFO (1) =',I15/ & ' --- (2) =',I15/ & ' Number of nodes in the tree =',I15/ & ' INFO (9) Real space for factors =',I15/ & ' --- (10) Integer space for factors =',I15/ & ' --- (11) Maximum size of frontal matrices =',I15) 99982 FORMAT (' --- (12) Number of off diagonal pivots =',I15) 99986 FORMAT (' --- (13) Number of delayed pivots =',I15/ & ' --- (14) Number of memory compresses =',I15/ & ' RINFO(2) Operations during node assembly =',1PD10.3/ & ' -----(3) Operations during node elimination =',1PD10.3) 99987 FORMAT (' INFO (25) Number of tiny pivots(static) =',I15) END SUBROUTINE CMUMPS_FAC_B SUBROUTINE CMUMPS_FAC_PAR_I(N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NULLNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, & DET_SIGN,PTRIST,PTRAST,PIMASTER,PAMASTER,PTRARW,PTRAIW,PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & MUMPS_TPS_ARR, CMUMPS_TPS_ARR, LTPS_ARR, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & NBROOT_UNDER_L0, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS, SLAVEF, MYID, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, INTARR, DBLARR, root, roota, & PERM, NELT, FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV, & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP, & PIVNUL_LIST_STRUCT, LRGROUPS ) USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T USE CMUMPS_TPS_M, ONLY: CMUMPS_TPS_T USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_FAC_PAR_M, ONLY : CMUMPS_FAC_PAR USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80) DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI INTEGER, INTENT(INOUT) :: NELVA, COMP INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV INTEGER, INTENT(INOUT) :: NULLNEGPV INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP COMPLEX, INTENT(INOUT) :: DET_MANT INTEGER(8) :: LA COMPLEX :: A(LA) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER LPOOL INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER IW(LIW), NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST(KEEP(28)), PERM(N) INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IPOOL(LPOOL) INTEGER NE(KEEP(28)) REAL RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU INTEGER IWPOS, LEAF, NBROOT, NBRTOT INTEGER, INTENT(in) :: NBROOT_UNDER_L0 INTEGER COMM_LOAD, ASS_IRECV REAL UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) COMPLEX DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER LRGROUPS(KEEP(280)) INTEGER, INTENT( IN ) :: LTPS_ARR, LL0_OMP_MAPPING TYPE (MUMPS_TPS_T) :: MUMPS_TPS_ARR(LTPS_ARR) TYPE (CMUMPS_TPS_T) :: CMUMPS_TPS_ARR(LTPS_ARR) INTEGER, INTENT( IN ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) CALL CMUMPS_FAC_PAR( N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NULLNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, & DET_SIGN,PTRIST,PTRAST,PIMASTER,PAMASTER,PTRARW,PTRAIW,PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & MUMPS_TPS_ARR, CMUMPS_TPS_ARR, LTPS_ARR, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & NBROOT_UNDER_L0, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8, & PROCNODE_STEPS,SLAVEF,MYID, COMM_NODES, MYID_NODES, & BUFR,LBUFR,LBUFR_BYTES,INTARR,DBLARR,root,roota,PERM, NELT, & FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV, & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP, & PIVNUL_LIST_STRUCT, LRGROUPS ) RETURN END SUBROUTINE CMUMPS_FAC_PAR_I MUMPS_5.8.1/src/mumps_save_restore_C.c0000664000175000017500000000257015042446422017564 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include #include #include #include "mumps_save_restore_C.h" #include "mumps_common.h" #if ! defined(NO_SAVE_RESTORE) /* Functions */ void MUMPS_CALL MUMPS_GET_SAVE_DIR_C(MUMPS_INT *len_save_dir, char* save_dir, mumps_ftnlen l1) { char *tmp_save_dir; tmp_save_dir = getenv ("MUMPS_SAVE_DIR"); if (tmp_save_dir==NULL) { tmp_save_dir = "NAME_NOT_INITIALIZED"; } *len_save_dir = strlen(tmp_save_dir); save_dir = strncpy(save_dir, tmp_save_dir, l1); } void MUMPS_CALL MUMPS_GET_SAVE_PREFIX_C(MUMPS_INT *len_save_prefix, char* save_prefix, mumps_ftnlen l1) { char *tmp_save_prefix; tmp_save_prefix = getenv ("MUMPS_SAVE_PREFIX"); if (tmp_save_prefix==NULL) { tmp_save_prefix = "NAME_NOT_INITIALIZED"; } *len_save_prefix = strlen(tmp_save_prefix); save_prefix = strncpy(save_prefix, tmp_save_prefix, l1); } #else void MUMPS_CALL MUMPS_SAVE_RESTORE_RETURN_C() { } #endif MUMPS_5.8.1/src/zfac_par_m.F0000664000175000017500000015276615042446441015462 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_PAR_M CONTAINS SUBROUTINE ZMUMPS_FAC_PAR(N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NULLNEGPV, NB22T1, NB22T2, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & PTRIST, PTRAST, PIMASTER, PAMASTER, PTRARW, PTRAIW, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & MUMPS_TPS_ARR, ZMUMPS_TPS_ARR, LTPS_ARR, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & NBROOT_UNDER_L0, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8, PROCNODE_STEPS, & SLAVEF,MYID, COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & INTARR, DBLARR, root, roota, PERM, NELT, FRTPTR, FRTELT, LPTRAR, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, & DKEEP, PIVNUL_LIST_STRUCT, LRGROUPS ) !$ USE OMP_LIB USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : & ZMUMPS_DM_FREEALLDYNAMICCB USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_TEST USE MUMPS_LOAD USE ZMUMPS_OOC, ONLY: ZMUMPS_OOC_CLEAN_PENDING, & IO_BLOCK, & ZMUMPS_OOC_FORCE_WRT_BUF_PANEL, & ZMUMPS_NEW_FACTOR, & ZMUMPS_OOC_IO_LU_PANEL, & ZMUMPS_FORCE_WRITE_BUF USE MUMPS_OOC_COMMON, ONLY: TYPEF_L, STRAT_WRITE_MAX USE ZMUMPS_FAC_ASM_MASTER_M USE ZMUMPS_FAC_ASM_MASTER_ELT_M USE ZMUMPS_FAC1_LDLT_M USE ZMUMPS_FAC2_LDLT_M USE ZMUMPS_FAC1_LU_M USE ZMUMPS_FAC2_LU_M USE OMP_LIB USE MUMPS_TPS_M USE ZMUMPS_TPS_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC USE MUMPS_PIVNUL_MOD IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80) DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI INTEGER, INTENT(INOUT) :: NELVA, COMP INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV, & NULLNEGPV INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP COMPLEX(kind=8), INTENT(INOUT) :: DET_MANT INTEGER(8) :: LA COMPLEX(kind=8), TARGET :: A(LA) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER LPOOL INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER IW(LIW), NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST(KEEP(28)), PERM(N) INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IPOOL(LPOOL) INTEGER NE(KEEP(28)) DOUBLE PRECISION RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU INTEGER IWPOS, LEAF, NBROOT, NBRTOT INTEGER, INTENT(in) :: NBROOT_UNDER_L0 INTEGER COMM_LOAD, ASS_IRECV DOUBLE PRECISION UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) LOGICAL IS_ISOLATED_NODE TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER LRGROUPS(KEEP(280)) INTEGER, INTENT( IN ) :: LTPS_ARR TYPE (MUMPS_TPS_T), TARGET :: MUMPS_TPS_ARR( LTPS_ARR ) TYPE (ZMUMPS_TPS_T), TARGET :: ZMUMPS_TPS_ARR( LTPS_ARR ) INTEGER, INTENT( IN ) :: LL0_OMP_MAPPING INTEGER, INTENT( IN ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 INTEGER INODE INTEGER IWPOSCB INTEGER FPERE, TYPEF INTEGER MP, LP, DUMMY(1) INTEGER NBFIN, NBROOT_TRAITEES INTEGER NFRONT, IOLDPS 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 !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 INTEGER LIWK_RR, PHASE, MBLOCK, NBLOCK INTEGER(8) :: LWK_RR INTEGER(8) :: I8 INTEGER I, K, KEEP17_LU INTEGER NOFFNEGPV_ROOT, NTOTPV_ROOT, NB22T1_ROOT, NBTINY_ROOT, & NULLNEGPV_ROOT, & DET_EXP_ROOT, DET_SIGN_ROOT, & LRecord, Header_ROOT(5) COMPLEX(kind=8) DET_MANT_ROOT DOUBLE PRECISION DKEEP_SAVE(230) COMPLEX(kind=8), DIMENSION(:), POINTER :: A_ROOT_SAVE LOGICAL :: IS_A_ROOT_SAVE_ALLOCATED INTEGER, DIMENSION(:), ALLOCATABLE :: RECORD_ROOT INTEGER KEEP_SAVE(500) INTEGER(8) KEEP8_SAVE(150) EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE LOGICAL MUMPS_INSSARBR EXTERNAL MUMPS_INSSARBR LOGICAL ZMUMPS_POOL_EMPTY EXTERNAL ZMUMPS_POOL_EMPTY, ZMUMPS_EXTRACT_POOL LOGICAL STACK_RIGHT_AUTHORIZED INTEGER, EXTERNAL :: MUMPS_NUMROC INTEGER JOBASS, ETATASS INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY INTEGER(8) :: ITMP8 TYPE(IO_BLOCK) :: MonBloc INCLUDE 'mumps_headers.h' INTEGER MPA DOUBLE PRECISION OPLAST_PRINTED DOUBLE PRECISION :: ROOTTIME INTEGER:: ITH DOUBLE PRECISION :: DUMMY_FLOP_ESTIM_ACC DUMMY_FLOP_ESTIM_ACC = 0.0d0 ITLOC(1:N+KEEP(253)) =0 ASS_IRECV = MPI_REQUEST_NULL MP = ICNTL(2) LP = ICNTL(1) IWPOSCB = LIW NULLIFY(BUFRX) IS_BUFRX_ALLOCATED = .FALSE. KEEP(143) = -1 KEEP17_LU = -1 NULLIFY(A_ROOT_SAVE) IS_A_ROOT_SAVE_ALLOCATED = .FALSE. IF ( INFO(1) .LT. 0 ) THEN GOTO 640 ENDIF OPLAST_PRINTED = DONE MPA = ICNTL(2) IF (ICNTL(4).LT.2) MPA=0 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) CALL ZMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) STACK_RIGHT_AUTHORIZED = .TRUE. CALL ZMUMPS_ALLOC_CB( .FALSE., 0_8, & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, DKEEP, & IW, LIW, A, LA, LRLU, IPTRLU, IWPOS, IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, LRLUS, KEEP8(67), & INFO(1), INFO(2) & ) JOBASS = 0 ETATASS = 0 NBFIN = NBRTOT NBROOT_TRAITEES = 0 KEEP(121)=0 IF ( KEEP(38).NE.0 ) THEN IF (root%yes) THEN CALL ZMUMPS_ROOT_ALLOC_STATIC( & root, roota, KEEP(38), N, IW, LIW, & A, LA, & FILS, DAD, MYID_NODES, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, INFO(1), KEEP,KEEP8, DKEEP, INFO(2) ) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 635 END IF IF (KEEP(400).GT.0) THEN NBROOT_TRAITEES = NBROOT_UNDER_L0 IF (NBROOT_TRAITEES .GT.0) THEN IF (NBROOT_TRAITEES.EQ.NBROOT) THEN NBFIN = NBFIN - NBROOT IF (SLAVEF .GT. 1) THEN CALL ZMUMPS_MCAST2( NBROOT, 1, MPI_INTEGER, & MYID_NODES, COMM_NODES, RACINE, SLAVEF, KEEP ) ENDIF ENDIF ENDIF IF (NBFIN .EQ. 0) GOTO 640 ENDIF KEEP(429)=0 20 CONTINUE CALL ZMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 635 NIV1_FLAG=0 SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .FALSE. IF ( SLAVEF .GT. 1 ) THEN CALL ZMUMPS_TRY_RECVTREAT( & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, & MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, & COMP, INFO(1), INFO(2), COMM_NODES, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, & root, roota, OPASS, OPELI, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED & , LRGROUPS & ) CALL MUMPS_LOAD_RECV_MSGS(COMM_LOAD) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (MESSAGE_RECEIVED) THEN IF ( INFO(1) .LT. 0 ) GO TO 640 IF ( NBFIN .eq. 0 ) GOTO 640 ELSE IF ( .NOT. ZMUMPS_POOL_EMPTY( IPOOL, LPOOL) )THEN CALL ZMUMPS_EXTRACT_POOL( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, STEP, INODE, KEEP,KEEP8, MYID_NODES, ND, & (.NOT. STACK_RIGHT_AUTHORIZED) ) STACK_RIGHT_AUTHORIZED = .TRUE. IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF IF (KEEP(47).EQ.4) THEN IF(INODE.GT.0.AND.INODE.LE.N)THEN IF((NE(STEP(INODE)).EQ.0).AND. & (FRERE(STEP(INODE)).EQ.0))THEN IS_ISOLATED_NODE=.TRUE. ELSE IS_ISOLATED_NODE=.FALSE. ENDIF ENDIF CALL MUMPS_LOAD_SBTR_UPD_NEW_POOL( & IS_ISOLATED_NODE,INODE,IPOOL,LPOOL, & MYID_NODES,SLAVEF,COMM_LOAD,KEEP,KEEP8) ENDIF IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. & ( KEEP(47) == 4 )).OR. & (KEEP(80) == 1 .AND. KEEP(47) .GE. 1)) THEN CALL MUMPS_UPPER_PREDICT(INODE,STEP,KEEP(28), & PROCNODE_STEPS,FRERE,ND,COMM_LOAD,SLAVEF, & MYID_NODES,KEEP,KEEP8,N) END IF GOTO 30 ELSE CALL MUMPS_BUF_TEST() ENDIF ENDIF GO TO 20 30 CONTINUE IF ( INODE .LT. 0 ) THEN INODE = -INODE FPERE = DAD(STEP(INODE)) GOTO 130 ELSE IF (INODE.GT.N) THEN INODE = INODE - N IF (INODE.EQ.KEEP(38)) THEN NBROOT_TRAITEES = NBROOT_TRAITEES + 1 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN NBFIN = NBFIN - NBROOT IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL ZMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID_NODES, & COMM_NODES, RACINE, SLAVEF, KEEP ) END IF ENDIF IF (NBFIN.EQ.0) GOTO 640 GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (TYPE.EQ.1) GOTO 100 FPERE = DAD(STEP(INODE)) AVOID_DELAYED = ( (FPERE .eq. KEEP(20) .OR. FPERE .eq. KEEP(38)) & .AND. KEEP(60).ne.0 ) IF ( KEEP(50) .eq. 0 ) THEN CALL ZMUMPS_FAC2_LU( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, & NOFFNEGPV, NTOTPV, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, & NBFIN,LEAF, INFO(1), INFO(2), IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_STEPS,PERM,PROCNODE_STEPS, & root, roota, OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & 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_STRUCT & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) ELSE CALL ZMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, & NOFFNEGPV, NULLNEGPV, NTOTPV, & NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, & NBFIN,LEAF, INFO(1), INFO(2), IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_STEPS,PERM,PROCNODE_STEPS, & root, roota, OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & 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_STRUCT & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF ( IW( PTLUST(STEP(INODE)) + KEEP(IXSZ) + 5 ) .GT. 1 ) THEN GOTO 20 END IF END IF GOTO 130 ENDIF IF (INODE.EQ.KEEP(38)) THEN CALL ZMUMPS_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, & root, roota, FRERE, & INODE, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, COMP, & INFO(1), INFO(2), COMM_NODES, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID_NODES, SLAVEF, & & OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP, ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (TYPE.EQ.1) THEN IF (KEEP(55).NE.0) THEN CALL ZMUMPS_FAC_ASM_NIV1_ELT( COMM_LOAD, ASS_IRECV, & UU, NELT, FRTPTR, FRTELT, & N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,roota,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP, & INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS,PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & , MUMPS_TPS_ARR, ZMUMPS_TPS_ARR, & L0_OMP_MAPPING & ) ELSE JOBASS = 0 CALL ZMUMPS_FAC_ASM_NIV1(COMM_LOAD, ASS_IRECV, & UU, N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,roota,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP, INTARR,KEEP8(27), & DBLARR,KEEP8(26), & NSTK_STEPS,PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, JOBASS,ETATASS & , LRGROUPS & , MUMPS_TPS_ARR, ZMUMPS_TPS_ARR, & L0_OMP_MAPPING & ) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF ( INFO(1) .LT. 0 ) GOTO 640 IF ((IW(PTLUST(STEP(INODE))+XXNBPR).GT.0).OR.(SON_LEVEL2)) THEN GOTO 20 ENDIF ELSE IF ( KEEP(55) .eq. 0 ) THEN CALL ZMUMPS_FAC_ASM_NIV2(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, & INFO(1), & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, & root, roota, OPASS, OPELI, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) ELSE CALL ZMUMPS_FAC_ASM_NIV2_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, INFO(1), & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, & root, roota, OPASS, OPELI, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) END IF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 640 GOTO 20 ENDIF 100 CONTINUE FPERE = DAD(STEP(INODE)) IF ( INODE .eq. KEEP(20) ) THEN POSELT = PTRAST(STEP(INODE)) IF (PTRFAC(STEP(INODE)).NE.POSELT) THEN WRITE(*,*) "ERROR 2 in ZMUMPS_FAC_PAR", POSELT GOTO 635 ENDIF IF (KEEP(118).GE.40) THEN IOLDPS = PTLUST(STEP(INODE)) LRecord = IW(IOLDPS+XXI) IF (allocated(RECORD_ROOT)) DEALLOCATE(RECORD_ROOT) ALLOCATE(RECORD_ROOT(LRecord), stat=IERR) IF (IERR.GT.0) THEN INFO(1)= -13 INFO(2)= LRecord IF (LP > 0) & write(LP,*) "ERROR allocate RECORD_ROOT" GOTO 635 ENDIF RECORD_ROOT(1:LRecord) = IW(IOLDPS:IOLDPS+LRecord-1) ENDIF CALL ZMUMPS_CHANGE_HEADER & ( IW(PTLUST(STEP(INODE))+KEEP(IXSZ)), KEEP(253) ) IF (KEEP(118).GE.40) THEN Header_ROOT(1:5) = IW(PTLUST(STEP(INODE))+KEEP(IXSZ): & PTLUST(STEP(INODE))+KEEP(IXSZ)+4) ENDIF GOTO 200 END IF POSELT = PTRAST(STEP(INODE)) IOLDPS = PTLUST(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_FAC1_LU ( & N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFNEGPV, NTOTPV, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & KEEP,KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) GOTO 635 ELSE IW( IOLDPS+4+KEEP(IXSZ) ) = 1 CALL ZMUMPS_FAC1_LDLT( N, INODE, & IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFNEGPV, NULLNEGPV, NTOTPV, & NB22T1, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, & ETATASS, & DKEEP(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) GOTO 635 IW( IOLDPS+4+KEEP(IXSZ) ) = STEP(INODE) ENDIF JOBASS = ETATASS IF (JOBASS.EQ.1) THEN CALL ZMUMPS_FAC_ASM_NIV1(COMM_LOAD, ASS_IRECV, & UU, N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,roota,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, & PTRARW,PTRAIW,PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & JOBASS,ETATASS & , LRGROUPS & ) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 635 130 CONTINUE TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF ( FPERE .NE. 0 ) THEN TYPEF = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(FPERE)),KEEP(199)) ELSE TYPEF = -9999 END IF CALL ZMUMPS_FAC_STACK( COMM_LOAD, ASS_IRECV, & N,INODE,TYPE,TYPEF,LA,IW,LIW,A, & INFO(1),INFO(2),OPELI,NELVA,NMAXNPIV, & PTRIST,PTLUST,PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NE, POSFAC,LRLU, LRLUS,KEEP8(67), & IPTRLU,ICNTL,KEEP,KEEP8,DKEEP,COMP,IWPOS,IWPOSCB, & PROCNODE_STEPS,SLAVEF,FPERE,COMM_NODES,MYID_NODES, & IPOOL, LPOOL, LEAF, & NSTK_STEPS, PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, & root, roota, & OPASS, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ,DUMMY_FLOP_ESTIM_ACC & ) IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 640 200 CONTINUE IF ( INODE .eq. KEEP(38) ) THEN WRITE(*,*) 'Error .. in ZMUMPS_FAC_PAR: ', & ' INODE == KEEP(38)' CALL MUMPS_ABORT() END IF IF ( FPERE.EQ.0 ) THEN NBROOT_TRAITEES = NBROOT_TRAITEES + 1 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN IF (KEEP(201).EQ.1) THEN CALL ZMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF ( KEEP(201).EQ.2) THEN CALL ZMUMPS_FORCE_WRITE_BUF(IERR) ENDIF NBFIN = NBFIN - NBROOT IF ( NBFIN .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in ZMUMPS_FAC_PAR: ', & ' NBFIN=', NBFIN CALL MUMPS_ABORT() END IF IF ( NBROOT .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in ZMUMPS_FAC_PAR: ', & ' NBROOT=', NBROOT CALL MUMPS_ABORT() END IF IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL ZMUMPS_MCAST2( DUMMY(1), 1, MPI_INTEGER, & MYID_NODES, COMM_NODES, RACINE, SLAVEF, KEEP ) END IF ENDIF IF (NBFIN.EQ.0)THEN GOTO 640 ENDIF ELSEIF ( FPERE.NE.KEEP(38) .AND. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID_NODES ) THEN NSTK_STEPS(STEP(FPERE)) = NSTK_STEPS(STEP(FPERE))-1 IF ( NSTK_STEPS( STEP( FPERE )).EQ.0) THEN IF (KEEP(234).NE.0 .AND. & MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199))) & THEN STACK_RIGHT_AUTHORIZED = .FALSE. ENDIF CALL ZMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( FPERE, N, PROCNODE_STEPS,KEEP(199), & ND, FILS, FRERE, STEP, PIMASTER, KEEP(28), & KEEP(50), KEEP(253), FLOP1, & IW, LIW, KEEP(IXSZ) ) IF (FPERE.NE.KEEP(20)) & CALL MUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ENDIF GO TO 20 635 CONTINUE IF (allocated(RECORD_ROOT)) DEALLOCATE(RECORD_ROOT) CALL ZMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP ) 640 CONTINUE CALL ZMUMPS_CANCEL_IRECV( INFO(1), & KEEP, & ASS_IRECV, BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, & MYID_NODES, SLAVEF) CALL MUMPS_CLEAN_PENDING( INFO(1), KEEP, & BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, & .TRUE., & .TRUE.) CALL MPI_BARRIER( COMM_NODES, IERR ) IF (INFO(1) .LT. 0) THEN CALL ZMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & .FALSE. ) IF ( KEEP(400) .GT. 0 & ) THEN !$OMP PARALLEL DO SCHEDULE(STATIC,1) DO ITH = 1, KEEP(400) IF (associated(MUMPS_TPS_ARR(ITH)%IW)) THEN CALL ZMUMPS_DM_FREEALLDYNAMICCB_I( MYID, N, SLAVEF, & KEEP, KEEP8, & MUMPS_TPS_ARR(ITH)%IW(1), MUMPS_TPS_ARR(ITH)%LIW, & MUMPS_TPS_ARR(ITH)%IWPOSCB, MUMPS_TPS_ARR(ITH)%IWPOS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & .TRUE. ) ENDIF ENDDO !$OMP END PARALLEL DO ENDIF ENDIF IF ( INFO(1) .GE. 0 ) THEN IF( KEEP(38) .NE. 0 .OR. KEEP(20).NE.0) THEN CALL MUMPS_SECDEB(ROOTTIME) MASTER_ROOT = MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(max(KEEP(38),KEEP(20)))), & KEEP(199)) ROOT_OWNER = (MASTER_ROOT .EQ. MYID_NODES) IF ( KEEP(38) .NE. 0 ) THEN IF (KEEP(60).EQ.0) THEN IOLDPS = PTLUST(STEP(KEEP(38))) LOCAL_M = IW(IOLDPS+2+KEEP(IXSZ)) LOCAL_N = IW(IOLDPS+1+KEEP(IXSZ)) ELSE IOLDPS = -999 LOCAL_M = root%SCHUR_MLOC LOCAL_N = root%SCHUR_NLOC ENDIF ITMP8 = int(LOCAL_M,8)*int(LOCAL_N,8) LBUFRX = min(int(root%MBLOCK,8)*int(root%NBLOCK,8), & int(root%TOT_ROOT_SIZE,8)*int(root%TOT_ROOT_SIZE,8) ) IS_BUFRX_ALLOCATED = .FALSE. IF ( LRLU .GT. LBUFRX ) THEN BUFRX => A(POSFAC:POSFAC+LRLU-1_8) LBUFRX=LRLU ELSE ALLOCATE( BUFRX( LBUFRX ), stat = IERR ) IF (IERR.gt.0) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR(LBUFRX, INFO(2) ) IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before ZMUMPS_FACTO_ROOT', LBUFRX ELSE IS_BUFRX_ALLOCATED = .TRUE. ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL, INFO, & COMM_NODES, MYID_NODES ) IF (INFO(1).GE.0) THEN CALL ZMUMPS_FACTO_ROOT( & MPA, MYID_NODES, MASTER_ROOT, & root, roota, N, KEEP(38), & COMM_NODES, IW, LIW, IWPOS + 1, & A, LA, PTRAST, PTLUST, PTRFAC, STEP, & INFO(1), KEEP(50), KEEP(19), & BUFRX(1), LBUFRX, KEEP,KEEP8, DKEEP, & OPELI, DET_EXP, DET_MANT, DET_SIGN ) CALL ZMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IS_BUFRX_ALLOCATED = .FALSE. CALL MUMPS_PROPINFO( ICNTL, INFO, & COMM_NODES, MYID_NODES ) ENDIF IF ( MYID_NODES .eq. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))), & KEEP(199)) & ) THEN IF ( INFO(1) .EQ. -10 .OR. INFO(1) .EQ. -40 ) THEN NTOTPV = NTOTPV + INFO(2) ELSE IF ( INFO(1) .GE. 0 ) THEN NTOTPV = NTOTPV + root%TOT_ROOT_SIZE NMAXNPIV = max(NMAXNPIV,root%TOT_ROOT_SIZE) END IF END IF IF (INFO(1).GE.0.AND.KEEP(60).EQ.0) THEN IF (root%yes) THEN IF (KEEP(252).EQ.0) THEN IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_L NextPiv2beWritten = 1 MonBloc%INODE = KEEP(38) MonBloc%MASTER = .TRUE. MonBloc%Typenode = 3 MonBloc%NROW = LOCAL_M MonBloc%NCOL = LOCAL_N MonBloc%NFS = MonBloc%NCOL MonBloc%Last = .TRUE. MonBloc%LastPiv = MonBloc%NCOL MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. LAST_CALL = .TRUE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(PTRFAC(STEP(KEEP(38)))), & LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IERR,LAST_CALL) IF (IERR .LT.0) THEN INFO(1) = IERR IF (LP > 0 ) THEN WRITE(LP,*)MYID, & ': Error in ZMUMPS_OOC_IO_LU_PANEL',IERR ENDIF ENDIF ELSE IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+ ITMP8 CALL ZMUMPS_NEW_FACTOR(KEEP(38),PTRFAC, & KEEP,KEEP8,A,LA, ITMP8, IERR) IF(IERR.LT.0)THEN INFO(1)=IERR IF (LP > 0 ) THEN WRITE(LP,*)MYID, & ': Error in ZMUMPS_NEW_FACTOR',IERR ENDIF ENDIF ENDIF ENDIF IF (KEEP(201).NE.0 .OR. KEEP(252).NE.0) THEN LRLUS = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 IF (KEEP(252).NE.0) THEN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,0_8,-ITMP8, & KEEP,KEEP8,LRLUS) ELSE CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLUS) ENDIF IF (PTRFAC(STEP(KEEP(38))).EQ.POSFAC-ITMP8) THEN POSFAC = POSFAC - ITMP8 LRLU = LRLU + ITMP8 ENDIF ELSE CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLUS) ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL, INFO, & COMM_NODES, MYID_NODES ) ENDIF IF ( INFO(1).GE.0 .AND. KEEP(252) .NE. 0 .AND. & (KEEP(60).EQ.0 .OR. KEEP(221).EQ.1)) THEN IF (root%yes) 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(roota%RHS_CNTR_MASTER_ROOT( & LRHS_CNTR_MASTER_ROOT), stat=IERR ) IF (IERR.gt.0) THEN INFO(1) = -13 INFO(2) = LRHS_CNTR_MASTER_ROOT IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'CNTR_MASTER_ROOT of size', & LRHS_CNTR_MASTER_ROOT ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL, INFO, COMM_NODES, & MYID_NODES) IF (root%yes .AND. INFO(1).GE.0) THEN FWD_LOCAL_N_RHS = MUMPS_NUMROC(KEEP(253), & root%NBLOCK, root%MYCOL, 0, root%NPCOL) FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) CALL ZMUMPS_GATHER_ROOT( MYID_NODES, & root%TOT_ROOT_SIZE, KEEP(253), & roota%RHS_CNTR_MASTER_ROOT(1), LOCAL_M, & FWD_LOCAL_N_RHS, root%MBLOCK, root%NBLOCK, & roota%RHS_ROOT(1,1), MASTER_ROOT, & root%NPROW, root%NPCOL, COMM_NODES ) ENDIF ENDIF ELSE IF (KEEP(19).NE.0) THEN CALL MPI_REDUCE(KEEP(109), GLOBK109, 1, & MPI_INTEGER, MPI_SUM, & MASTER_ROOT, & COMM_NODES, IERR) ENDIF IF (ROOT_OWNER) THEN IPOSROOT = PTLUST(STEP(KEEP(20))) NFRONT = IW(IPOSROOT+KEEP(IXSZ)+3) NFRONT8 = int(NFRONT,8) IPOSROOTROWINDICES=IPOSROOT+6+KEEP(IXSZ)+ & IW(IPOSROOT+5+KEEP(IXSZ)) NTOTPV = NTOTPV + NFRONT NMAXNPIV = max(NMAXNPIV,NFRONT) END IF IF ( KEEP(60) .EQ. 0 ) THEN IF ( ROOT_OWNER ) THEN IF (KEEP(118).GE.40) THEN NOFFNEGPV_ROOT = 0 NULLNEGPV_ROOT = 0 NTOTPV_ROOT = 0 NB22T1_ROOT = 0 NBTINY_ROOT = 0 DET_SIGN_ROOT = 1 DET_EXP_ROOT = 0 DET_MANT_ROOT = cmplx(1.0D0,0.0D0, & kind=kind(1.0D0)) DKEEP_SAVE(:) = DKEEP(:) KEEP_SAVE(:) = KEEP(:) KEEP8_SAVE(:) = KEEP8(:) KEEP_SAVE(201) = 0 IF (KEEP(110).EQ.0) THEN KEEP_SAVE(110)= 1 IF (KEEP(118).EQ.40) THEN IF ((DKEEP(10).LE.0).OR.(DKEEP(10).GT.1)) THEN DKEEP_SAVE(1) = DKEEP(9)*1D-1 ELSE DKEEP_SAVE(1) = DKEEP(9)*DKEEP(10) ENDIF ELSE IF (KEEP(118).EQ.41) THEN DKEEP_SAVE(1) = DKEEP(9) ELSE IF (KEEP(118).EQ.42) THEN IF (DKEEP(13).LT.1) THEN DKEEP_SAVE(1) = DKEEP(9)*10 ELSE DKEEP_SAVE(1) = DKEEP(9)*DKEEP(13) ENDIF ENDIF ELSE DKEEP_SAVE(1) = DKEEP(9) ENDIF IS_A_ROOT_SAVE_ALLOCATED = .FALSE. IF (LRLU.GT.NFRONT8*NFRONT8) THEN A_ROOT_SAVE => A(POSFAC:POSFAC+LRLU-1_8) ELSE IF (associated(A_ROOT_SAVE)) & DEALLOCATE(A_ROOT_SAVE) ALLOCATE(A_ROOT_SAVE(NFRONT8*NFRONT8),stat=IERR) IF (IERR.GT.0) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR(NFRONT8*NFRONT8, INFO(2) ) IF (LP > 0 ) & write(LP,*) "ERROR allocating A_ROOT_SAVE ", & " of size ", NFRONT*NFRONT GOTO 735 ENDIF IS_A_ROOT_SAVE_ALLOCATED = .TRUE. ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK8=int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF ( NFRONT8*NFRONT8 > int(KEEP(361),8) .AND. NOMP .GT. 1) DO I8 =1_8, NFRONT8*NFRONT8 A_ROOT_SAVE(I8) = & A(PTRAST(STEP(KEEP(20)))+I8-1_8) ENDDO IW(PTLUST(STEP(INODE))+KEEP(IXSZ): & PTLUST(STEP(INODE))+KEEP(IXSZ)+4) & = RECORD_ROOT(KEEP(IXSZ)+1:KEEP(IXSZ)+5) IW(PTLUST(STEP(INODE))+XXLR) = 0 AVOID_DELAYED = .TRUE. IF (KEEP(50).EQ.0) THEN CALL ZMUMPS_FAC1_LU_I ( & N, INODE, IW, LIW, A_ROOT_SAVE(1), & NFRONT8*NFRONT8, IPOSROOT, 1_8, & INFO(1), INFO(2), UU, NOFFNEGPV_ROOT, NTOTPV_ROOT, & NBTINY_ROOT, & DET_EXP_ROOT, DET_MANT_ROOT, DET_SIGN_ROOT, & KEEP_SAVE,KEEP8_SAVE, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP_SAVE(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) THEN IF (LP.GT.0) & write(LP,*) "ERROR after ZMUMPS_FAC1_LU ", & "on the root INFO(1)= ", INFO(1) GOTO 735 ENDIF ELSE CALL ZMUMPS_FAC1_LDLT_I (N,KEEP_SAVE(20), & IW, LIW, A_ROOT_SAVE(1), NFRONT8*NFRONT8, & IPOSROOT, 1_8, & INFO(1), INFO(2), UU, & NOFFNEGPV_ROOT, NULLNEGPV_ROOT, NTOTPV_ROOT, & NB22T1_ROOT, NBTINY_ROOT, & DET_EXP_ROOT, DET_MANT_ROOT, DET_SIGN_ROOT, & KEEP_SAVE,KEEP8_SAVE, MYID_NODES, SEUIL, & AVOID_DELAYED, ETATASS, DKEEP_SAVE(1), & PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) THEN IF (LP.GT.0) & write(LP,*) "ERROR after ZMUMPS_FAC1_LDLT ", & "on the root INFO(1)= ", INFO(1) GOTO 735 ENDIF ENDIF LRecord = IW(IOLDPS+XXI) IW(PTLUST(STEP(INODE)): & PTLUST(STEP(INODE))+LRecord-1) = & RECORD_ROOT(1:LRecord) IW(PTLUST(STEP(INODE))+KEEP(IXSZ): & PTLUST(STEP(INODE))+KEEP(IXSZ)+4) = & Header_ROOT(1:5) KEEP17_LU = KEEP_SAVE(109)-KEEP(109) IF (KEEP_SAVE(109).GT.KEEP(109)) THEN K = 1 DO I = KEEP(109)+1, KEEP(109)+KEEP17_LU RECORD_ROOT(K) = & PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) K = K+1 ENDDO ENDIF IF (IS_A_ROOT_SAVE_ALLOCATED) DEALLOCATE(A_ROOT_SAVE) NULLIFY(A_ROOT_SAVE) IS_A_ROOT_SAVE_ALLOCATED = .FALSE. DET_SIGN = DET_SIGN * DET_SIGN_ROOT DET_EXP = DET_EXP + DET_EXP_ROOT CALL ZMUMPS_UPDATEDETER ( DET_MANT_ROOT, & DET_MANT, DET_EXP) NOFFNEGPV = NOFFNEGPV + NOFFNEGPV_ROOT NULLNEGPV = NULLNEGPV + NULLNEGPV_ROOT ENDIF LOCAL_M = 0 LOCAL_N = 0 MBLOCK = 0 NBLOCK = 0 PHASE = 1 CALL ZMUMPS_SVD_QR_ESTIM_WK( PHASE, & MBLOCK, NBLOCK, NFRONT, LOCAL_M, LOCAL_N, & ROOT_OWNER, KEEP,KEEP8, & LIWK_RR, LWK_RR ) LBUFRX = LWK_RR IS_BUFRX_ALLOCATED = .FALSE. IF ( LRLU .GT. LBUFRX ) THEN BUFRX => A(POSFAC:POSFAC+LBUFRX-1_8) ELSE ALLOCATE( BUFRX( LBUFRX ), stat = IERR ) IF (IERR.gt.0) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR(LBUFRX, INFO(2)) IF (LP.GT.0) & write(LP,*) ' Error allocating, real & array ','of size ', LBUFRX, & ' before ZMUMPS_SEQ_FACTO_ROOT_SVD_QR' GOTO 735 ENDIF IS_BUFRX_ALLOCATED = .TRUE. ENDIF IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST .LT. & KEEP(109)+NFRONT) THEN CALL MUMPS_RESIZE_PIVNUL(KEEP, N, PIVNUL_LIST_STRUCT, & KEEP(109)+NFRONT, INFO(1), INFO(2) ) IF (INFO(1).LT.0) GOTO 735 ENDIF CALL ZMUMPS_SEQ_FACTO_ROOT_SVD_QR( & NFRONT,A(PTRAST(STEP(KEEP(20)))), & root, roota, & BUFRX(1), int(LBUFRX), & KEEP,KEEP8, INFO, LP, DKEEP, & GLOBK109, OPELI, & PIVNUL_LIST_STRUCT%PIVNUL_LIST(KEEP(109)+1), & PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST- KEEP(109), & IW(IPOSROOTROWINDICES)) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IS_BUFRX_ALLOCATED = .FALSE. IF (INFO(1).LT.0) GOTO 735 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) CALL ZMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) KEEP(143) = KEEP17_LU IF (KEEP(118).GE.40) THEN K = 1 IF (KEEP(17).GT.0) THEN DO I = KEEP(109)+1, KEEP(109)+KEEP(17) IF ( K .GT. KEEP17_LU ) THEN PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) = -1 ELSE PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) = & RECORD_ROOT(K) ENDIF K = K+1 ENDDO ENDIF ENDIF IF (allocated(RECORD_ROOT)) DEALLOCATE(RECORD_ROOT) IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC, IW(IPOSROOT+XXR)) LIWFAC = IW(IPOSROOT+XXI) TYPEFile = TYPEF_L NextPiv2beWritten = 1 MonBloc%INODE = KEEP(20) MonBloc%MASTER = .TRUE. MonBloc%Typenode = 3 MonBloc%NCOL = NFRONT MonBloc%NROW = NFRONT MonBloc%NFS = NFRONT MonBloc%Last = .TRUE. MonBloc%LastPiv = MonBloc%NCOL MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. LAST_CALL = .TRUE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(PTRAST(STEP(KEEP(20)))), & LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IPOSROOT), LIWFAC, & MYID, KEEP8(31), IERR, LAST_CALL) IF(IERR.LT.0)THEN IF (LP > 0) & WRITE(LP,*)MYID, & ': Error raised in ZMUMPS_OOC_IO_LU_PANEL', & IERR INFO(1)=IERR ENDIF ELSE IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+NFRONT8*NFRONT8 CALL ZMUMPS_NEW_FACTOR(KEEP(20),PTRFAC, & KEEP,KEEP8,A,LA, NFRONT8*NFRONT8, IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID, & ': Internal error in ZMUMPS_NEW_FACTOR', & IERR GOTO 735 ENDIF ENDIF ITMP8 = NFRONT8*NFRONT8 IF(KEEP(201).NE.0)THEN IF (PTRFAC(STEP(KEEP(20))).EQ. & POSFAC-ITMP8) THEN POSFAC = POSFAC - ITMP8 LRLU = LRLU + ITMP8 LRLUS = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 ELSE IF (LP.GT.0) & WRITE(LP,*) "Internal error", & POSFAC,NFRONT8, & "root KEEP(20) not on top in OOC" GOTO 735 ENDIF ENDIF CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,ITMP8,0_8,KEEP,KEEP8,LRLUS) ENDIF 735 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM_NODES, MYID_NODES ) IF (INFO(1).LT.0) GOTO 745 CALL MPI_BCAST( KEEP(17), 1, MPI_INTEGER, & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(20))), & KEEP(199)), & COMM_NODES, IERR ) CALL MPI_BCAST( KEEP(143), 1, MPI_INTEGER, & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(20))), & KEEP(199)), & COMM_NODES, IERR ) END IF IF (ROOT_OWNER.AND.KEEP(60).NE.0) THEN ITMP8 = NFRONT8*NFRONT8 IF ( PTRFAC(STEP(KEEP(20))) .EQ. POSFAC - & ITMP8 ) THEN POSFAC = POSFAC - ITMP8 LRLUS = LRLUS + ITMP8 LRLU = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-ITMP8,KEEP,KEEP8,LRLUS) ENDIF ENDIF END IF GOTO 750 745 CONTINUE IF (allocated(RECORD_ROOT)) DEALLOCATE(RECORD_ROOT) IF (IS_A_ROOT_SAVE_ALLOCATED) DEALLOCATE(A_ROOT_SAVE) NULLIFY(A_ROOT_SAVE) 750 CONTINUE IF (INFO(1).LT.0) GOTO 500 CALL MUMPS_SECFIN(ROOTTIME) DKEEP(99)=ROOTTIME END IF END IF 500 CONTINUE IF ( KEEP(38) .NE. 0 ) THEN IF (MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))),KEEP(199)) & ) THEN MAXFRT = max ( MAXFRT, root%TOT_ROOT_SIZE) END IF END IF IF ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.2)) THEN CALL ZMUMPS_OOC_CLEAN_PENDING(IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ENDIF CALL MUMPS_PROPINFO( ICNTL, INFO, COMM_NODES, MYID_NODES ) ENDIF IF (associated(roota%RHS_ROOT)) THEN DEALLOCATE(roota%RHS_ROOT) NULLIFY(roota%RHS_ROOT) ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_PAR SUBROUTINE ZMUMPS_CHANGE_HEADER( HEADER, KEEP253 ) INTEGER HEADER( 6 ), KEEP253 INTEGER NFRONT, NASS NFRONT = HEADER(1) IF ( HEADER(2) .ne. 0 ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 1 :',HEADER(2) CALL MUMPS_ABORT() END IF NASS = abs( HEADER( 3 ) ) IF ( NASS .NE. abs( HEADER( 4 ) ) ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 2 :',HEADER(3:4) CALL MUMPS_ABORT() END IF IF ( NASS+KEEP253 .NE. NFRONT ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 3 : not root', & NASS, KEEP253, NFRONT CALL MUMPS_ABORT() END IF HEADER( 1 ) = KEEP253 HEADER( 2 ) = 0 HEADER( 3 ) = NFRONT HEADER( 4 ) = NFRONT-KEEP253 RETURN END SUBROUTINE ZMUMPS_CHANGE_HEADER END MODULE ZMUMPS_FAC_PAR_M MUMPS_5.8.1/src/ana_orderings_wrappers_m.F0000664000175000017500000013067515042446423020426 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if defined(__ve__) #if defined(VHOFFLOAD) #include 've.h' #endif #endif MODULE MUMPS_ANA_ORD_WRAPPERS IMPLICIT NONE CONTAINS #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) SUBROUTINE MUMPS_METIS_NODEWND_MIXEDto32( NCMP, IPE8, IW, FRERE, & NUMFLAG, & OPTIONS_METIS, LOPTIONS_METIS, IKEEP2, IKEEP1, INFO, & LP, LPOK ) IMPLICIT NONE INTEGER :: INFO(2), LOPTIONS_METIS INTEGER :: NCMP, NUMFLAG, IKEEP1(:), IKEEP2(:), FRERE(:) INTEGER :: OPTIONS_METIS(LOPTIONS_METIS), IW(:) INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER(8) :: IPE8(:) INTEGER,ALLOCATABLE, DIMENSION(:) :: IPE INTEGER :: allocok IF (IPE8(NCMP+1) .GE. int(huge(IW),8)) THEN INFO(1) = -51 CALL MUMPS_SET_IERROR( & IPE8(NCMP+1), INFO(2)) RETURN ENDIF ALLOCATE(IPE(NCMP+1), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 INFO(2)=NCMP+1 IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in METIS_NODEWND_MIXEDto32" RETURN ENDIF CALL MUMPS_ICOPY_64TO32(IPE8(1), NCMP+1, IPE) CALL METIS_NODEWND(NCMP, IPE, IW(1),FRERE(1), & NUMFLAG, OPTIONS_METIS, & IKEEP2(1), IKEEP1(1) ) RETURN END SUBROUTINE MUMPS_METIS_NODEWND_MIXEDto32 SUBROUTINE MUMPS_METIS_NODEND_MIXEDto32( NCMP, IPE8, IW, NUMFLAG, & OPTIONS_METIS, LOPTIONS_METIS, IKEEP2, IKEEP1, INFO, & LP, LPOK) IMPLICIT NONE INTEGER :: INFO(2), LOPTIONS_METIS INTEGER :: NCMP, NUMFLAG, IKEEP1(:), IKEEP2(:), IW(:) INTEGER :: OPTIONS_METIS(LOPTIONS_METIS) INTEGER(8) :: IPE8(:) INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER,ALLOCATABLE, DIMENSION(:) :: IPE INTEGER :: allocok IF (IPE8(NCMP+1) .GE. int(huge(IW),8)) THEN INFO(1) = -51 CALL MUMPS_SET_IERROR( & IPE8(NCMP+1), INFO(2)) RETURN ENDIF ALLOCATE(IPE(NCMP+1), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 INFO(2)=NCMP+1 IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in METIS_NODEND_MIXEDto32" RETURN ENDIF CALL MUMPS_ICOPY_64TO32(IPE8(1), NCMP+1, IPE) CALL METIS_NODEND(NCMP, IPE, IW(1), & NUMFLAG, OPTIONS_METIS, & IKEEP2(1), IKEEP1(1) ) DEALLOCATE(IPE) RETURN END SUBROUTINE MUMPS_METIS_NODEND_MIXEDto32 #else SUBROUTINE MUMPS_METIS_NODEND_MIXEDto32( NCMP, IPE8, IW, FRERE, & OPTIONS_METIS, LOPTIONS_METIS, IKEEP2, IKEEP1, INFO, & LP, LPOK ) IMPLICIT NONE INTEGER :: INFO(2), LOPTIONS_METIS INTEGER :: NCMP, IKEEP1(:), IKEEP2(:), FRERE(:), IW(:) INTEGER :: OPTIONS_METIS(LOPTIONS_METIS) INTEGER(8) :: IPE8(:) INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER,ALLOCATABLE, DIMENSION(:) :: IPE INTEGER :: allocok IF (IPE8(NCMP+1) .GE. int(huge(IW),8)) THEN INFO(1) = -51 CALL MUMPS_SET_IERROR( & IPE8(NCMP+1), INFO(2)) RETURN ENDIF ALLOCATE(IPE(NCMP+1), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 INFO(2)=NCMP+1 IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in METIS_NODEND_MIXEDto32" RETURN ENDIF CALL MUMPS_ICOPY_64TO32(IPE8(1), NCMP+1, IPE) CALL METIS_NODEND( NCMP, IPE, IW(1), FRERE(1), & OPTIONS_METIS, IKEEP2(1), IKEEP1(1)) DEALLOCATE(IPE) RETURN END SUBROUTINE MUMPS_METIS_NODEND_MIXEDto32 #endif #endif #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) SUBROUTINE MUMPS_METIS_NODEWND_MIXEDto64( NCMP, IPE8, IW, FRERE, & NUMFLAG, & OPTIONS_METIS, LOPTIONS_METIS, IKEEP2, IKEEP1, INFO, & LP, LPOK, KEEP10, INPLACE64_GRAPH_COPY ) IMPLICIT NONE INTEGER :: INFO(2), LOPTIONS_METIS INTEGER :: NCMP, NUMFLAG, IKEEP1(:), IKEEP2(:), FRERE(:) INTEGER :: OPTIONS_METIS(LOPTIONS_METIS), IW(:) INTEGER(8) :: IPE8(:) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK LOGICAL, INTENT(IN) :: INPLACE64_GRAPH_COPY INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IW8, FRERE8, & IKEEP18, IKEEP28 INTEGER :: allocok IF (KEEP10.EQ.1) THEN CALL METIS_NODEWND(NCMP, IPE8(1), IW(1),FRERE, & NUMFLAG, OPTIONS_METIS, & IKEEP2(1), IKEEP1(1) ) ELSE IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_ICOPY_32TO64_64C_IP(IW(1), IPE8(NCMP+1)-1_8, & 2_8*IPE8(NCMP+1)-2_8) ELSE ALLOCATE(IW8(IPE8(NCMP+1)-1_8), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( & int(KEEP10,8)* ( IPE8(NCMP+1)-1_8 ) & , INFO(2) & ) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in METIS_NODEWND_MIXEDto64" RETURN ENDIF CALL MUMPS_ICOPY_32TO64_64C(IW(1), IPE8(NCMP+1)-1_8, IW8 ) ENDIF ALLOCATE(FRERE8(NCMP), & IKEEP18(NCMP), IKEEP28(NCMP), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( & int(KEEP10,8)* ( 3_8*int(NCMP,8) ) & , INFO(2) & ) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in METIS_NODEWND_MIXEDto64" RETURN ENDIF CALL MUMPS_ICOPY_32TO64 (FRERE, NCMP , FRERE8) IF (INPLACE64_GRAPH_COPY) THEN CALL METIS_NODEWND(NCMP, IPE8(1), IW(1),FRERE8, & NUMFLAG, OPTIONS_METIS, & IKEEP28(1), IKEEP18(1) ) ELSE CALL METIS_NODEWND(NCMP, IPE8(1), IW8,FRERE8, & NUMFLAG, OPTIONS_METIS, & IKEEP28(1), IKEEP18(1) ) ENDIF CALL MUMPS_ICOPY_64TO32(IKEEP18, NCMP, IKEEP1(1)) CALL MUMPS_ICOPY_64TO32(IKEEP28, NCMP, IKEEP2(1)) IF (INPLACE64_GRAPH_COPY) THEN DEALLOCATE(FRERE8, IKEEP18, IKEEP28) ELSE DEALLOCATE(IW8, FRERE8, IKEEP18, IKEEP28) ENDIF ENDIF RETURN END SUBROUTINE MUMPS_METIS_NODEWND_MIXEDto64 SUBROUTINE MUMPS_METIS_NODEND_MIXEDto64( NCMP, IPE8, IW, NUMFLAG, & OPTIONS_METIS, LOPTIONS_METIS, IKEEP2, IKEEP1, INFO, & LP, LPOK, KEEP10, & LIW8, INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH & ) IMPLICIT NONE INTEGER :: INFO(2), LOPTIONS_METIS INTEGER :: NCMP, NUMFLAG, IKEEP1(:), IKEEP2(:), IW(:) INTEGER :: OPTIONS_METIS(LOPTIONS_METIS) INTEGER(8) :: IPE8(:) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK INTEGER(8) :: LIW8 LOGICAL, INTENT(IN) :: INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IW8, & IKEEP18, IKEEP28 INTEGER :: allocok IF (KEEP10.EQ.1) THEN CALL METIS_NODEND(NCMP, IPE8(1), IW(1), & NUMFLAG, OPTIONS_METIS, & IKEEP2(1), IKEEP1(1) ) ELSE IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_ICOPY_32TO64_64C_IP(IW(1), IPE8(NCMP+1)-1_8, & 2_8*IPE8(NCMP+1)-2_8) ELSE ALLOCATE(IW8(IPE8(NCMP+1)-1_8), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( int(KEEP10,8)* & ( IPE8(NCMP+1)-1_8+2_8*int(NCMP,8) ) & , INFO(2) ) IF (LPOK) WRITE(LP,'(A)') & "ERROR 1 memory allocation in METIS_METIS_NODEND_MIXEDto64" RETURN ENDIF CALL MUMPS_ICOPY_32TO64_64C(IW(1), IPE8(NCMP+1)-1_8, IW8 ) ENDIF ALLOCATE(IKEEP18(NCMP), IKEEP28(NCMP), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( int(KEEP10,8)* & 2_8*int(NCMP,8), INFO(2) ) IF (LPOK) WRITE(LP,'(A)') & "ERROR 2 memory allocation in METIS_METIS_NODEND_MIXEDto64" RETURN ENDIF IF (INPLACE64_GRAPH_COPY) THEN CALL METIS_NODEND(NCMP, IPE8(1), IW(1), & NUMFLAG, OPTIONS_METIS, & IKEEP28, IKEEP18 ) ELSE CALL METIS_NODEND(NCMP, IPE8(1), IW8, & NUMFLAG, OPTIONS_METIS, & IKEEP28, IKEEP18 ) ENDIF CALL MUMPS_ICOPY_64TO32(IKEEP18, NCMP, IKEEP1(1)) CALL MUMPS_ICOPY_64TO32(IKEEP28, NCMP, IKEEP2(1)) IF (INPLACE64_GRAPH_COPY) THEN IF (INPLACE64_RESTORE_GRAPH) THEN CALL MUMPS_ICOPY_64TO32_64C_IP(IW(1), IPE8(NCMP+1)-1_8, & 2_8*IPE8(NCMP+1)-2_8) ENDIF DEALLOCATE(IKEEP18, IKEEP28) ELSE DEALLOCATE(IW8, IKEEP18, IKEEP28) ENDIF ENDIF RETURN END SUBROUTINE MUMPS_METIS_NODEND_MIXEDto64 #else SUBROUTINE MUMPS_METIS_NODEND_MIXEDto64( NCMP, IPE8, IW, FRERE, & OPTIONS_METIS, LOPTIONS_METIS, IKEEP2, IKEEP1, INFO, & LP, LPOK, KEEP10, & LIW8, INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH & ) IMPLICIT NONE INTEGER :: INFO(2) INTEGER :: LOPTIONS_METIS INTEGER :: NCMP, IKEEP1(:), IKEEP2(:), FRERE(:), IW(:) INTEGER :: OPTIONS_METIS(LOPTIONS_METIS) INTEGER(8) :: IPE8(:) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK INTEGER(8) :: LIW8 LOGICAL, INTENT(IN) :: INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IW8, FRERE8, & IKEEP18, IKEEP28, & OPTIONS_METIS8 INTEGER :: allocok IF (KEEP10.EQ.1) THEN CALL METIS_NODEND( NCMP, IPE8(1), IW(1), FRERE(1), & OPTIONS_METIS, IKEEP2(1), IKEEP1(1) ) ELSE IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_ICOPY_32TO64_64C_IP(IW(1), IPE8(NCMP+1)-1_8, & 2_8*IPE8(NCMP+1)-2_8) ELSE ALLOCATE(IW8(IPE8(NCMP+1)-1_8), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( int(KEEP10,8) * (IPE8(NCMP+1)-1_8) & , INFO(2) ) IF (LPOK) WRITE(LP,'(A)') & "ERROR 1 memory allocation in METIS_METIS_NODEND_MIXEDto64" RETURN ENDIF CALL MUMPS_ICOPY_32TO64_64C(IW(1), IPE8(NCMP+1)-1_8, IW8 ) ENDIF ALLOCATE(FRERE8(NCMP), & IKEEP18(NCMP), IKEEP28(NCMP), & OPTIONS_METIS8(LOPTIONS_METIS), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( & int(KEEP10,8)* & (3_8*int(NCMP,8)+int(LOPTIONS_METIS,8)) & , INFO(2)) IF (LPOK) WRITE(LP,'(A)') & "ERROR 2 memory allocation in METIS_NODEND_MIXEDto64" RETURN ENDIF CALL MUMPS_ICOPY_32TO64 (FRERE(1), NCMP, FRERE8) CALL MUMPS_ICOPY_32TO64 (OPTIONS_METIS, LOPTIONS_METIS, & OPTIONS_METIS8) IF (INPLACE64_GRAPH_COPY) THEN CALL METIS_NODEND( int(NCMP,8), IPE8(1), IW(1), FRERE8, & OPTIONS_METIS8, IKEEP28, IKEEP18 ) ELSE CALL METIS_NODEND( int(NCMP,8), IPE8(1), IW8, FRERE8, & OPTIONS_METIS8, IKEEP28, IKEEP18 ) ENDIF CALL MUMPS_ICOPY_64TO32(IKEEP18, NCMP, IKEEP1(1)) CALL MUMPS_ICOPY_64TO32(IKEEP28, NCMP, IKEEP2(1)) IF (INPLACE64_GRAPH_COPY) THEN IF (INPLACE64_RESTORE_GRAPH) THEN CALL MUMPS_ICOPY_64TO32_64C_IP(IW(1), IPE8(NCMP+1)-1_8, & 2_8*IPE8(NCMP+1)-2_8) ENDIF DEALLOCATE(FRERE8, IKEEP18, IKEEP28, OPTIONS_METIS8) ELSE DEALLOCATE(IW8, FRERE8, IKEEP18, IKEEP28, OPTIONS_METIS8) ENDIF ENDIF RETURN END SUBROUTINE MUMPS_METIS_NODEND_MIXEDto64 #endif #endif #if defined(scotch) || defined(ptscotch) SUBROUTINE MUMPS_SCOTCH_MIXEDto32(NCMP, LIW8, IPE8, PARENT, IWFR8, & PTRAR, IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, & WEIGHTUSED, WEIGHTREQUESTED, SCOTCH_SYMBOLIC) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN) :: NCMP INTEGER(8), INTENT(IN) :: LIW8 INTEGER, INTENT(OUT) :: NCMPA INTEGER(8), INTENT(INOUT) :: IPE8(:) INTEGER, INTENT(OUT) :: PARENT(NCMP) INTEGER(8), INTENT(IN) :: IWFR8 INTEGER :: PTRAR(NCMP) INTEGER :: IW(:) INTEGER :: IWL1(NCMP) INTEGER, INTENT(OUT) :: IKEEP1(:) INTEGER, INTENT(OUT) :: IKEEP2(:) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(OUT) :: WEIGHTUSED INTEGER, INTENT(IN) :: WEIGHTREQUESTED LOGICAL, INTENT(IN) :: SCOTCH_SYMBOLIC INTEGER, DIMENSION(:), ALLOCATABLE :: IPE INTEGER :: allocok #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) INCLUDE 'scotchf.h' INTEGER :: IOMP, NOMP DOUBLE PRECISION :: CONTDAT(SCOTCH_CONTEXTDIM) INTEGER(4) :: IERR_SCOTCH #else INTEGER :: PTHREAD_NUMBER, NOMP #endif IF (IWFR8 .GE. int(huge(IW),8)) THEN INFO(1) = -51 CALL MUMPS_SET_IERROR(IPE8(NCMP+1), INFO(2)) RETURN ENDIF ALLOCATE(IPE(NCMP+1), stat=allocok) IF (allocok > 0) THEN IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_SCOTCH_MIXEDto32" INFO(1) = -7 INFO(2) = NCMP+1 RETURN ENDIF CALL MUMPS_ICOPY_64TO32(IPE8(1),NCMP+1,IPE) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) !$OMP PARALLEL PRIVATE(IOMP, IERR_SCOTCH) !$OMP SINGLE NOMP=omp_get_num_threads() !$OMP END SINGLE IOMP=omp_get_thread_num() IF (IOMP.EQ.0) THEN CALL SCOTCHFCONTEXTINIT(CONTDAT, IERR_SCOTCH) CALL SCOTCHFCONTEXTRANDOMCLONE(CONTDAT, IERR_SCOTCH) CALL SCOTCHFCONTEXTTHREADIMPORT1(CONTDAT, NOMP,IERR_SCOTCH) ENDIF !$OMP BARRIER CALL SCOTCHFCONTEXTTHREADIMPORT2(CONTDAT, IOMP, IERR_SCOTCH) #else NOMP=0 !$ NOMP=omp_get_max_threads() IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (PTHREAD_NUMBER) CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (NOMP) ENDIF #endif #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) IF (IOMP.EQ.0) THEN #endif IF (SCOTCH_SYMBOLIC) THEN CALL MUMPS_SCOTCH( NCMP, int(LIW8), IPE, int(IWFR8), & PTRAR, IW(1), IWL1, IKEEP1(1), & IKEEP2(1), NCMPA, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, #endif & WEIGHTUSED, WEIGHTREQUESTED ) ELSE CALL MUMPS_SCOTCH_ORD ( NCMP, int(LIW8), IPE, int(IWFR8), & PTRAR, IW(1), IWL1, IKEEP1(1), & IKEEP2(1), NCMPA, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, #endif & WEIGHTUSED, WEIGHTREQUESTED ) ENDIF #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL SCOTCHFCONTEXTEXIT(CONTDAT) ENDIF !$OMP END PARALLEL #else IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (PTHREAD_NUMBER) ENDIF #endif IF (NCMPA .NE.0) THEN IF (LPOK) WRITE(LP,*) & ' Error on output from SCOTCH, NCMPA=', NCMPA INFO(1) = -88 INFO(2) = NCMPA GOTO 500 ENDIF IF (SCOTCH_SYMBOLIC) THEN PARENT(1:NCMP)=IPE(1:NCMP) ENDIF 500 CONTINUE DEALLOCATE(IPE) RETURN END SUBROUTINE MUMPS_SCOTCH_MIXEDto32 SUBROUTINE MUMPS_SCOTCH_MIXEDto64( & NCMP, LIW8, IPE8, PARENT, IWFR8, & PTRAR, IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, KEEP10, & INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH, & WEIGHTUSED, WEIGHTREQUESTED, SCOTCH_SYMBOLIC) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN) :: NCMP INTEGER(8), INTENT(IN) :: LIW8 INTEGER, INTENT(OUT) :: NCMPA INTEGER(8), INTENT(INOUT), target :: IPE8(:) INTEGER, INTENT(OUT) :: PARENT(NCMP) INTEGER(8), INTENT(IN) :: IWFR8 INTEGER :: PTRAR(NCMP) INTEGER :: IW(:) INTEGER :: IWL1(NCMP) INTEGER, INTENT(OUT) :: IKEEP1(:) INTEGER, INTENT(OUT) :: IKEEP2(:) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: KEEP10 LOGICAL, INTENT(IN) :: INPLACE64_GRAPH_COPY LOGICAL, INTENT(IN) :: INPLACE64_RESTORE_GRAPH INTEGER, INTENT(OUT) :: WEIGHTUSED INTEGER, INTENT(IN) :: WEIGHTREQUESTED LOGICAL, INTENT(IN) :: SCOTCH_SYMBOLIC INTEGER(8), DIMENSION(:), ALLOCATABLE :: & PTRAR8, IW8, IWL18, IKEEP18, & IKEEP28 INTEGER(8), DIMENSION(:), POINTER :: IPE8_TEMP INTEGER :: allocok, I #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) INCLUDE 'scotchf.h' INTEGER :: IOMP, NOMP DOUBLE PRECISION :: CONTDAT(SCOTCH_CONTEXTDIM) INTEGER(4) :: IERR_SCOTCH #else INTEGER :: PTHREAD_NUMBER, NOMP #endif LOGICAL :: IPE8_TEMP_ALLOCATED IPE8_TEMP_ALLOCATED =.FALSE. NULLIFY(IPE8_TEMP) CALL MUMPS_SCOTCH_WEIGHTUSED (WEIGHTUSED) IF ( (.NOT.SCOTCH_SYMBOLIC) .OR. & ( (WEIGHTREQUESTED.EQ.1).AND.(WEIGHTUSED.EQ.0)) & ) THEN ALLOCATE( IPE8_TEMP(NCMP+1), stat=allocok ) IF (allocok > 0) THEN IF (LPOK) WRITE(LP,*) & "ERROR memory allocation in MUMPS_SCOTCH_MIXEDto64" INFO(1) = -7 INFO(2) = NCMP+1 RETURN ENDIF IPE8_TEMP_ALLOCATED = .TRUE. DO I=1, NCMP+1 IPE8_TEMP(I) = IPE8(I) ENDDO ELSE IPE8_TEMP => IPE8(1:NCMP+1) ENDIF IF (KEEP10.EQ.1) THEN #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) !$OMP PARALLEL PRIVATE(IOMP, IERR_SCOTCH) !$OMP SINGLE NOMP=omp_get_num_threads() !$OMP END SINGLE IOMP=omp_get_thread_num() IF (IOMP.EQ.0) THEN CALL SCOTCHFCONTEXTINIT(CONTDAT, IERR_SCOTCH) CALL SCOTCHFCONTEXTRANDOMCLONE(CONTDAT, IERR_SCOTCH) CALL SCOTCHFCONTEXTTHREADIMPORT1(CONTDAT, NOMP,IERR_SCOTCH) ENDIF !$OMP BARRIER CALL SCOTCHFCONTEXTTHREADIMPORT2(CONTDAT, IOMP, IERR_SCOTCH) #else NOMP=0 !$ NOMP=omp_get_max_threads() IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (PTHREAD_NUMBER) CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (NOMP) ENDIF #endif #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) IF (IOMP.EQ.0) THEN #endif IF (SCOTCH_SYMBOLIC) THEN CALL MUMPS_SCOTCH_64( NCMP, LIW8, & IPE8_TEMP(1), & IWFR8, & PTRAR, IW(1), IWL1, IKEEP1(1), & IKEEP2(1), NCMPA, & WEIGHTUSED, WEIGHTREQUESTED) PARENT(1:NCMP) = int(IPE8_TEMP(1:NCMP)) ELSE CALL MUMPS_SCOTCH_ORD_64( NCMP, LIW8, & IPE8_TEMP(1), & IWFR8, & PTRAR, IW(1), IWL1, IKEEP1(1), & IKEEP2(1), NCMPA, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, #endif & WEIGHTUSED, WEIGHTREQUESTED) ENDIF #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL SCOTCHFCONTEXTEXIT(CONTDAT) ENDIF !$OMP END PARALLEL #else IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (PTHREAD_NUMBER) ENDIF #endif IF (NCMPA .NE. 0) THEN IF (LPOK) WRITE(LP,*) & ' Error on output from SCOTCH, NCMPA=', NCMPA INFO( 1 ) = -88 INFO( 2 ) = NCMPA GOTO 600 ENDIF ELSE IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_ICOPY_32TO64_64C_IP(IW(1), IPE8_TEMP(NCMP+1)-1_8, & 2_8*IPE8(NCMP+1)-2_8) ELSE ALLOCATE( IW8(LIW8), stat=allocok ) IF (allocok > 0) THEN IF (LPOK) WRITE(LP,*) & "ERROR memory allocation in MUMPS_SCOTCH_MIXEDto64" INFO(1) = -7 CALL MUMPS_SET_IERROR( int(KEEP10,8) * LIW8 & , INFO(2) ) GOTO 500 ENDIF CALL MUMPS_ICOPY_32TO64_64C(IW(1),LIW8,IW8) ENDIF ALLOCATE( & PTRAR8(NCMP), IWL18(NCMP), IKEEP18(NCMP), IKEEP28(NCMP), & stat=allocok ) IF (allocok > 0) THEN IF (LPOK) WRITE(LP,*) & "ERROR memory allocation in MUMPS_SCOTCH_MIXEDto64" INFO(1) = -7 CALL MUMPS_SET_IERROR( int(KEEP10,8) * & ( int(NCMP,8)*4_8 ) & , INFO(2) ) GOTO 500 ENDIF CALL MUMPS_ICOPY_32TO64(PTRAR,NCMP,PTRAR8) IF (WEIGHTREQUESTED.EQ.1) THEN CALL MUMPS_ICOPY_32TO64(IWL1,NCMP,IWL18) ENDIF #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) !$OMP PARALLEL PRIVATE(IOMP, IERR_SCOTCH) !$OMP SINGLE NOMP=omp_get_num_threads() !$OMP END SINGLE IOMP=omp_get_thread_num() IF (IOMP.EQ.0) THEN CALL SCOTCHFCONTEXTINIT(CONTDAT, IERR_SCOTCH) CALL SCOTCHFCONTEXTRANDOMCLONE(CONTDAT, IERR_SCOTCH) CALL SCOTCHFCONTEXTTHREADIMPORT1(CONTDAT, NOMP,IERR_SCOTCH) ENDIF !$OMP BARRIER CALL SCOTCHFCONTEXTTHREADIMPORT2(CONTDAT, IOMP, IERR_SCOTCH) #else NOMP=0 !$ NOMP=omp_get_max_threads() IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (PTHREAD_NUMBER) CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (NOMP) ENDIF #endif #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) IF (IOMP.EQ.0) THEN #endif IF (INPLACE64_GRAPH_COPY) THEN IF (SCOTCH_SYMBOLIC) THEN CALL MUMPS_SCOTCH_64( & int(NCMP,8), LIW8, & IPE8_TEMP(1), & IWFR8, & PTRAR8, IW(1), IWL18, & IKEEP18(1), IKEEP28(1), NCMPA, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, #endif & WEIGHTUSED, & WEIGHTREQUESTED ) ELSE CALL MUMPS_SCOTCH_ORD_64 ( & int(NCMP,8), LIW8, & IPE8_TEMP(1), & IWFR8, & PTRAR8, IW(1), IWL18, & IKEEP18(1), & IKEEP28(1), NCMPA, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, #endif & WEIGHTUSED, & WEIGHTREQUESTED ) ENDIF ELSE IF (SCOTCH_SYMBOLIC) THEN CALL MUMPS_SCOTCH_64( & int(NCMP,8), LIW8, & IPE8_TEMP(1), & IWFR8, & PTRAR8, IW8, IWL18, & IKEEP18(1), IKEEP28(1), NCMPA, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, #endif & WEIGHTUSED, & WEIGHTREQUESTED ) ELSE CALL MUMPS_SCOTCH_ORD_64( & int(NCMP,8), LIW8, & IPE8_TEMP(1), & IWFR8, & PTRAR8, IW8, IWL18, & IKEEP18(1), & IKEEP28(1), NCMPA, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, #endif & WEIGHTUSED, & WEIGHTREQUESTED ) ENDIF ENDIF #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL SCOTCHFCONTEXTEXIT(CONTDAT) ENDIF !$OMP END PARALLEL #else IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (PTHREAD_NUMBER) ENDIF #endif IF (NCMPA .NE. 0) THEN IF (LPOK) WRITE(LP,*) & ' Error on output from SCOTCH, NCMPA=', NCMPA INFO( 1 ) = -88 INFO( 2 ) = NCMPA GOTO 500 ENDIF CALL MUMPS_ICOPY_64TO32(IWL18,NCMP,IWL1) CALL MUMPS_ICOPY_64TO32(IKEEP18,NCMP,IKEEP1(1)) CALL MUMPS_ICOPY_64TO32(IKEEP28,NCMP,IKEEP2(1)) IF (SCOTCH_SYMBOLIC) THEN CALL MUMPS_ICOPY_64TO32(IPE8_TEMP(1),NCMP,PARENT) ELSE IF (INPLACE64_GRAPH_COPY) THEN IF (INPLACE64_RESTORE_GRAPH) THEN CALL MUMPS_ICOPY_64TO32_64C_IP(IW(1), IPE8(NCMP+1)-1_8, & 2_8*IPE8(NCMP+1)-2_8) ENDIF ENDIF 500 CONTINUE IF (.NOT.INPLACE64_GRAPH_COPY) THEN IF (ALLOCATED(IW8)) DEALLOCATE(IW8) ENDIF IF (ALLOCATED(PTRAR8)) DEALLOCATE(PTRAR8) IF (ALLOCATED(IWL18)) DEALLOCATE(IWL18) IF (ALLOCATED(IKEEP18)) DEALLOCATE(IKEEP18) IF (ALLOCATED(IKEEP28)) DEALLOCATE(IKEEP28) ENDIF 600 CONTINUE IF (IPE8_TEMP_ALLOCATED ) DEALLOCATE(IPE8_TEMP) RETURN END SUBROUTINE MUMPS_SCOTCH_MIXEDto64 #endif #if defined (scotch) || defined (ptscotch) SUBROUTINE MUMPS_SCOTCH_KWAY_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, JCNHALO, & NBGROUPS, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) IMPLICIT NONE include 'scotchf.h' INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBGROUPS INTEGER :: JCNHALO(max(HALOEDGENBR,1)), PARTS(NHALO) INTEGER(8) :: IPTRHALO(NHALO+1) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: IFLAG, IERROR DOUBLE PRECISION :: GRAFDAT(SCOTCH_GRAPHDIM) DOUBLE PRECISION :: STRADAT(SCOTCH_STRATDIM) INTEGER :: BASEVAL, IERR, EDGENBR INTEGER, ALLOCATABLE :: IPTRHALO_I4(:) INTEGER :: allocok IF (IPTRHALO(size(IPTRHALO)) .GE. int(huge(LP),8)) THEN IFLAG = -51 CALL MUMPS_SET_IERROR( IPTRHALO (size(IPTRHALO)), & IERROR ) RETURN ENDIF ALLOCATE(IPTRHALO_I4(size(IPTRHALO)), stat=allocok) IF (allocok > 0) THEN IFLAG = -7 IERROR = size(IPTRHALO) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_SCOTCH_KWAY_MIXEDto32" RETURN END IF CALL MUMPS_ICOPY_64TO32(IPTRHALO, & size(IPTRHALO), IPTRHALO_I4) BASEVAL = 1 EDGENBR = IPTRHALO_I4(NHALO+1) - 1 CALL SCOTCHFGRAPHINIT(GRAFDAT(1), IERR) IF (IERR.EQ.0) THEN CALL SCOTCHFGRAPHBUILD(GRAFDAT(1), BASEVAL, NHALO, & IPTRHALO_I4(1), IPTRHALO_I4(2), IPTRHALO_I4(1), & IPTRHALO_I4(1), EDGENBR, JCNHALO(1), JCNHALO(1), IERR) CALL SCOTCHFSTRATINIT(STRADAT(1), IERR) IF (IERR.EQ.0) THEN CALL SCOTCHFGRAPHPART(GRAFDAT(1), NBGROUPS, STRADAT(1), & PARTS(1), IERR) IF (IERR.EQ.0) THEN PARTS(1:NHALO) = PARTS(1:NHALO)+1 ELSE PARTS(1:NHALO) = -9999 ENDIF CALL SCOTCHFSTRATEXIT(STRADAT(1)) ENDIF CALL SCOTCHFGRAPHEXIT(GRAFDAT(1)) ENDIF IF (IERR.NE.0) THEN IFLAG = -89 IERROR = IERR ENDIF DEALLOCATE(IPTRHALO_I4) RETURN END SUBROUTINE MUMPS_SCOTCH_KWAY_MIXEDto32 SUBROUTINE MUMPS_SCOTCH_KWAY_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, JCNHALO, & NBGROUPS, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) IMPLICIT NONE include 'scotchf.h' INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBGROUPS INTEGER :: JCNHALO(max(HALOEDGENBR,1)), PARTS(NHALO) INTEGER(8) :: IPTRHALO(NHALO+1) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: IFLAG, IERROR DOUBLE PRECISION :: GRAFDAT(SCOTCH_GRAPHDIM) DOUBLE PRECISION :: STRADAT(SCOTCH_STRATDIM) INTEGER :: IERR INTEGER(8), ALLOCATABLE :: JCNHALO_I8(:), PARTS_I8(:) INTEGER(8) :: NHALO_I8, NBGROUPS_I8, EDGENBR_I8, & BASEVAL_I8 INTEGER :: allocok ALLOCATE(JCNHALO_I8(max(IPTRHALO(NHALO+1)-1_8,1_8)), & PARTS_I8(size(PARTS)), stat=allocok) IF (allocok > 0) THEN IFLAG =-7 CALL MUMPS_SET_IERROR( & int(KEEP10,8)* (IPTRHALO(NHALO+1)-1_8 & +int(size(PARTS),8)), & IERROR) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_SCOTCH_KWAY_MIXEDto64 " RETURN ENDIF CALL MUMPS_ICOPY_32TO64_64C(JCNHALO, & IPTRHALO(NHALO+1)-1, JCNHALO_I8) NHALO_I8 = int(NHALO,8) NBGROUPS_I8 = int(NBGROUPS,8) BASEVAL_I8 = 1_8 EDGENBR_I8 = IPTRHALO(NHALO+1) - 1_8 CALL SCOTCHFGRAPHINIT(GRAFDAT(1), IERR) IF (IERR.EQ.0) THEN CALL SCOTCHFGRAPHBUILD(GRAFDAT(1), BASEVAL_I8, NHALO_I8, & IPTRHALO(1), IPTRHALO(2), IPTRHALO(1), & IPTRHALO(1), EDGENBR_I8, JCNHALO_I8(1), JCNHALO_I8(1), IERR) CALL SCOTCHFSTRATINIT(STRADAT(1), IERR) CALL SCOTCHFGRAPHPART(GRAFDAT(1), NBGROUPS_I8, STRADAT(1), & PARTS_I8(1), IERR) IF (IERR.EQ.0) THEN CALL MUMPS_ICOPY_64TO32(PARTS_I8, & size(PARTS), PARTS) PARTS(1:NHALO) = PARTS(1:NHALO)+1 ELSE PARTS(1:NHALO) = -9999 ENDIF CALL SCOTCHFSTRATEXIT(STRADAT(1)) CALL SCOTCHFGRAPHEXIT(GRAFDAT(1)) ENDIF IF (IERR.NE.0) THEN IFLAG = -89 IERROR = IERR ENDIF DEALLOCATE(JCNHALO_I8, PARTS_I8) RETURN END SUBROUTINE MUMPS_SCOTCH_KWAY_MIXEDto64 #endif #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) SUBROUTINE MUMPS_METIS_KWAY_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, NBGROUPS, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) IMPLICIT NONE INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBGROUPS INTEGER :: JCNHALO(max(HALOEDGENBR,1)), PARTS(NHALO) INTEGER(8) :: IPTRHALO(NHALO+1) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, ALLOCATABLE :: IPTRHALO_I4(:) INTEGER :: allocok IF (IPTRHALO(size(IPTRHALO)) .GE. int(huge(LP),8)) THEN IFLAG = -51 CALL MUMPS_SET_IERROR( IPTRHALO (size(IPTRHALO)), & IERROR) RETURN ENDIF ALLOCATE(IPTRHALO_I4(size(IPTRHALO)), stat=allocok) IF (allocok > 0) THEN IFLAG = -7 IERROR = size(IPTRHALO) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_METIS_KWAY_MIXEDto32" RETURN END IF CALL MUMPS_ICOPY_64TO32(IPTRHALO, & size(IPTRHALO), IPTRHALO_I4) CALL MUMPS_METIS_KWAY(NHALO, IPTRHALO_I4(1), & JCNHALO(1), NBGROUPS, PARTS(1)) DEALLOCATE(IPTRHALO_I4) RETURN END SUBROUTINE MUMPS_METIS_KWAY_MIXEDto32 SUBROUTINE MUMPS_METIS_KWAY_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, NBGROUPS, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) IMPLICIT NONE INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBGROUPS INTEGER :: JCNHALO(max(HALOEDGENBR,1)), PARTS(NHALO) INTEGER(8) :: IPTRHALO(NHALO+1) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: JCNHALO_I8, PARTS_I8 INTEGER(8) :: NHALO_I8, NBGROUPS_I8 INTEGER :: allocok ALLOCATE(JCNHALO_I8(max(IPTRHALO(NHALO+1)-1_8,1_8)), & PARTS_I8(size(PARTS)), stat=allocok) IF (allocok > 0) THEN IFLAG = -7 CALL MUMPS_SET_IERROR( & int(KEEP10,8)* (IPTRHALO(NHALO+1)-1_8+int(size(PARTS),8)), & IERROR) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_METIS_KWAY_MIXEDto64 " ENDIF NHALO_I8 = int(NHALO,8) NBGROUPS_I8 = int(NBGROUPS,8) CALL MUMPS_ICOPY_32TO64_64C(JCNHALO, & IPTRHALO(NHALO+1)-1, JCNHALO_I8) CALL MUMPS_METIS_KWAY_64(NHALO_I8, IPTRHALO(1), & JCNHALO_I8(1), NBGROUPS_I8, PARTS_I8(1)) CALL MUMPS_ICOPY_64TO32(PARTS_I8, & size(PARTS), PARTS) DEALLOCATE(JCNHALO_I8, PARTS_I8) RETURN END SUBROUTINE MUMPS_METIS_KWAY_MIXEDto64 SUBROUTINE MUMPS_METIS_KWAY_AB_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, NBGROUPS, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) IMPLICIT NONE INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBGROUPS INTEGER :: JCNHALO(max(HALOEDGENBR,1)), PARTS(NHALO), & VWGT(NHALO) INTEGER(8) :: IPTRHALO(NHALO+1) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, ALLOCATABLE :: IPTRHALO_I4(:) INTEGER :: allocok IF (IPTRHALO(size(IPTRHALO)) .GE. int(huge(LP),8)) THEN IFLAG = -51 CALL MUMPS_SET_IERROR( IPTRHALO (size(IPTRHALO)), & IERROR) RETURN ENDIF ALLOCATE(IPTRHALO_I4(size(IPTRHALO)), stat=allocok) IF (allocok > 0) THEN IFLAG = -7 IERROR = size(IPTRHALO) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_METIS_KWAY_AB_MIXEDto32" RETURN END IF CALL MUMPS_ICOPY_64TO32(IPTRHALO, & size(IPTRHALO), IPTRHALO_I4) CALL MUMPS_METIS_KWAY_AB(NHALO, IPTRHALO_I4(1), & JCNHALO(1), NBGROUPS, PARTS(1), VWGT(1)) DEALLOCATE(IPTRHALO_I4) RETURN END SUBROUTINE MUMPS_METIS_KWAY_AB_MIXEDto32 SUBROUTINE MUMPS_METIS_KWAY_AB_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, NBGROUPS, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) IMPLICIT NONE INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBGROUPS INTEGER :: JCNHALO(max(HALOEDGENBR,1)), PARTS(NHALO), & VWGT(NHALO) INTEGER(8) :: IPTRHALO(NHALO+1) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: JCNHALO_I8, PARTS_I8 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: VWGT_I8 INTEGER(8) :: NHALO_I8, NBGROUPS_I8 INTEGER :: allocok ALLOCATE(JCNHALO_I8(max(IPTRHALO(NHALO+1)-1_8,1_8)), & PARTS_I8(size(PARTS)), VWGT_I8(NHALO), stat=allocok) IF (allocok > 0) THEN IFLAG = -7 CALL MUMPS_SET_IERROR( & int(KEEP10,8)* (IPTRHALO(NHALO+1)-1_8+int(size(PARTS),8)) & +int(NHALO,8), IERROR) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_METIS_KWAY_AB_MIXEDto64 " ENDIF NHALO_I8 = int(NHALO,8) NBGROUPS_I8 = int(NBGROUPS,8) CALL MUMPS_ICOPY_32TO64_64C(JCNHALO, & IPTRHALO(NHALO+1)-1, JCNHALO_I8) CALL MUMPS_ICOPY_32TO64_64C(VWGT, & NHALO_I8, VWGT_I8) CALL MUMPS_METIS_KWAY_AB_64(NHALO_I8, IPTRHALO(1), & JCNHALO_I8(1), NBGROUPS_I8, PARTS_I8(1), & VWGT_I8(1)) CALL MUMPS_ICOPY_64TO32(PARTS_I8, & size(PARTS), PARTS) DEALLOCATE(JCNHALO_I8, PARTS_I8, VWGT_I8) RETURN END SUBROUTINE MUMPS_METIS_KWAY_AB_MIXEDto64 #endif #if defined(pord) SUBROUTINE MUMPS_PORDF_MIXEDto32( NVTX, NEDGES8, XADJ8, IW, & NV, NCMPA, PARENT, & INFO, LP, LPOK, KEEP10 ) IMPLICIT NONE INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: NVTX INTEGER, INTENT(OUT) :: NCMPA INTEGER(8), INTENT(IN) :: NEDGES8 INTEGER(8) :: XADJ8(:) INTEGER, INTENT(OUT) :: NV(NVTX) INTEGER :: IW(:) INTEGER, INTENT(OUT) :: PARENT(NVTX) INTEGER, INTENT(IN) :: KEEP10 INTEGER, DIMENSION(:), ALLOCATABLE :: XADJ INTEGER :: I, allocok IF (NEDGES8.GT. int(huge(IW),8)) THEN INFO(1) = -51 CALL MUMPS_SET_IERROR(NEDGES8,INFO(2)) RETURN ENDIF ALLOCATE(XADJ(NVTX+1), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 INFO(2)=NVTX+1 IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_PORD_MIXEDto32" RETURN ENDIF CALL MUMPS_ICOPY_64TO32(XADJ8(1), NVTX+1, XADJ) CALL MUMPS_PORDF( NVTX, int(NEDGES8), XADJ, IW(1), & NV, NCMPA ) DO I= 1, NVTX PARENT(I) = XADJ(I) ENDDO DEALLOCATE(XADJ) RETURN END SUBROUTINE MUMPS_PORDF_MIXEDto32 SUBROUTINE MUMPS_PORDF_MIXEDto64( NVTX, NEDGES8, XADJ8, IW, & NV, NCMPA, PARENT, & INFO, LP, LPOK, KEEP10, & INPLACE64_GRAPH_COPY ) IMPLICIT NONE INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: NVTX INTEGER, INTENT(OUT) :: NCMPA INTEGER(8), INTENT(IN) :: NEDGES8 INTEGER(8) :: XADJ8(:) INTEGER, INTENT(OUT) :: NV(NVTX) INTEGER, INTENT(IN) :: IW(:) INTEGER, INTENT(OUT) :: PARENT(NVTX) INTEGER, INTENT(IN) :: KEEP10 LOGICAL, INTENT(IN) :: INPLACE64_GRAPH_COPY INTEGER(8), DIMENSION(:), ALLOCATABLE :: IW8, NV8 INTEGER :: I, allocok IF (KEEP10.EQ.1) THEN CALL MUMPS_PORDF( int(NVTX,8), NEDGES8, XADJ8(1), IW(1), & NV, NCMPA ) DO I=1, NVTX PARENT(I)=int(XADJ8(I)) ENDDO ELSE IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_ICOPY_32TO64_64C_IP(IW(1), NEDGES8, & 2_8*NEDGES8 ) ELSE ALLOCATE(IW8(NEDGES8), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(NEDGES8,INFO(2)) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_PORD_MIXEDto64" RETURN ENDIF CALL MUMPS_ICOPY_32TO64_64C(IW(1), NEDGES8, IW8) ENDIF ALLOCATE(NV8(NVTX), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(int(NVTX,8),INFO(2)) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_PORD_MIXEDto64" RETURN ENDIF IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_PORDF( int(NVTX,8), NEDGES8, XADJ8(1), IW(1), & NV8, NCMPA ) ELSE CALL MUMPS_PORDF( int(NVTX,8), NEDGES8, XADJ8(1), IW8, & NV8, NCMPA ) DEALLOCATE(IW8) ENDIF CALL MUMPS_ICOPY_64TO32(XADJ8(1), NVTX, PARENT) CALL MUMPS_ICOPY_64TO32(NV8, NVTX, NV) DEALLOCATE(NV8) ENDIF RETURN END SUBROUTINE MUMPS_PORDF_MIXEDto64 SUBROUTINE MUMPS_PORDF_WND_MIXEDto32( NVTX, NEDGES8, & XADJ8, IW, & NV, NCMPA, N, PARENT, & INFO, LP, LPOK, KEEP10 ) IMPLICIT NONE INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: NVTX, N INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(INOUT) :: NV(NVTX) INTEGER(8) :: XADJ8(:) INTEGER(8), INTENT(IN) :: NEDGES8 INTEGER :: IW(:) INTEGER, INTENT(OUT) :: PARENT(NVTX) INTEGER, INTENT(IN) :: KEEP10 INTEGER, DIMENSION(:), ALLOCATABLE :: XADJ INTEGER :: I, allocok IF (NEDGES8.GT. int(huge(IW),8)) THEN INFO(1) = -51 CALL MUMPS_SET_IERROR(NEDGES8,INFO(2)) RETURN ENDIF ALLOCATE(XADJ(NVTX+1), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 INFO(2)=NVTX+1 IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_PORDF_WND_MIXEDto32" RETURN ENDIF CALL MUMPS_ICOPY_64TO32(XADJ8(1),NVTX+1,XADJ) CALL MUMPS_PORDF_WND( NVTX, int(NEDGES8), & XADJ, IW(1), & NV, NCMPA, N ) DO I= 1, NVTX PARENT(I) = XADJ(I) ENDDO DEALLOCATE(XADJ) RETURN END SUBROUTINE MUMPS_PORDF_WND_MIXEDto32 SUBROUTINE MUMPS_PORDF_WND_MIXEDto64( NVTX, NEDGES8, & XADJ8, IW, & NV, NCMPA, N, PARENT, & INFO, LP, LPOK, KEEP10, & INPLACE64_GRAPH_COPY ) IMPLICIT NONE INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: NVTX, N INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(INOUT) :: NV(NVTX) INTEGER(8) :: XADJ8(:) INTEGER(8), INTENT(IN) :: NEDGES8 INTEGER :: IW(:) INTEGER, INTENT(OUT) :: PARENT(NVTX) INTEGER, INTENT(IN) :: KEEP10 LOGICAL, INTENT(IN) :: INPLACE64_GRAPH_COPY INTEGER(8), DIMENSION(:), ALLOCATABLE :: IW8, NV8 INTEGER :: allocok IF (KEEP10.EQ.1) THEN CALL MUMPS_PORDF_WND( int(NVTX,8), NEDGES8, & XADJ8(1), IW(1), & NV, NCMPA, int(N,8) ) CALL MUMPS_ICOPY_64TO32(XADJ8(1), NVTX, PARENT) ELSE IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_ICOPY_32TO64_64C_IP(IW(1), NEDGES8, & 2_8*NEDGES8 ) ELSE ALLOCATE(IW8(NEDGES8), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(NEDGES8,INFO(2)) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_PORDF_WND_MIXEDto64" RETURN ENDIF CALL MUMPS_ICOPY_32TO64_64C(IW(1), NEDGES8, IW8) ENDIF ALLOCATE(NV8(NVTX), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(int(NVTX,8),INFO(2)) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_PORDF_WND_MIXEDto64" RETURN ENDIF CALL MUMPS_ICOPY_32TO64(NV, NVTX, NV8) IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_PORDF_WND( int(NVTX,8), NEDGES8, & XADJ8(1), IW(1), & NV8, NCMPA, int(N,8) ) ELSE CALL MUMPS_PORDF_WND( int(NVTX,8), NEDGES8, & XADJ8(1), IW8, & NV8, NCMPA, int(N,8) ) DEALLOCATE(IW8) ENDIF CALL MUMPS_ICOPY_64TO32(XADJ8(1), NVTX, PARENT) CALL MUMPS_ICOPY_64TO32(NV8, NVTX, NV) DEALLOCATE(NV8) ENDIF RETURN END SUBROUTINE MUMPS_PORDF_WND_MIXEDto64 #endif SUBROUTINE MUMPS_ANA_WRAP_RETURN() RETURN END SUBROUTINE MUMPS_ANA_WRAP_RETURN END MODULE MUMPS_ANA_ORD_WRAPPERS MUMPS_5.8.1/src/sfac_asm_ELT.F0000664000175000017500000002403715042446437015633 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ELT_ASM_S_2_S_INIT( & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP, KEEP8, MYID, LRGROUPS) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER NELT, N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID INTEGER NBROWS, NBCOLS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER INTARR(KEEP8(27)) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) REAL :: A(LA) REAL :: DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) INTEGER(8) :: POSELT REAL, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS REAL ZERO PARAMETER( ZERO = 0.0E0 ) INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL SMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) IF (NASS.LT.0) THEN NASS = -NASS IW(IOLDPS+1+KEEP(IXSZ)) = NASS CALL SMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, FILS, & PTRAIW, PTRARW, & INTARR, DBLARR, KEEP8(27), KEEP8(26), FRT_PTR, FRT_ELT, & RHS_MUMPS, LRGROUPS) ENDIF IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_ELT_ASM_S_2_S_INIT SUBROUTINE SMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW, &IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, PTRARW, &INTARR, DBLARR, LINTARR, LDBLARR, FRT_PTR, FRT_ELT, RHS_MUMPS, &LRGROUPS) !$ USE OMP_LIB USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, intent(in) :: N, NELT, LIW, IOLDPS, INODE INTEGER(8), intent(in) :: LA, POSELT, LINTARR, LDBLARR INTEGER, intent(in) :: IW(LIW) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(inout) :: ITLOC(N+KEEP(253)) REAL, intent(inout) :: A(LA) REAL, intent(in) :: RHS_MUMPS(KEEP8(85)) INTEGER, intent(in) :: INTARR(LINTARR) REAL, intent(in) :: DBLARR(LDBLARR) INTEGER, intent(in) :: FRT_PTR(N+1), FRT_ELT(NELT) INTEGER, intent(in) :: FILS(N) INTEGER(8), intent(in) :: PTRAIW(NELT+1), PTRARW(NELT+1) INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 !$ INTEGER :: CHUNK INCLUDE 'mumps_headers.h' INTEGER :: HF, NBROWF, NBCOLF, NASS, NSLAVES INTEGER :: ILOC, IELL, ELTI, ELBEG, NUMELT INTEGER(8) :: SIZE_ELTI8 INTEGER :: I, J, K, K1, K2 INTEGER :: IPOS, IPOS1, IPOS2, JPOS, IJROW INTEGER :: IN INTEGER(8) :: II8, JJ8, J18, J28 INTEGER(8) :: AINPUT8 INTEGER(8) :: AII8 INTEGER(8) :: APOS, APOS2, ICT12 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE, TOPDIAG INTEGER(8) :: JJ3 INTEGER :: K1RHS, K2RHS, JFirstRHS REAL ZERO PARAMETER( ZERO = 0.0E0 ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) !$ NOMP = OMP_GET_MAX_THREADS() IF (KEEP(50) .EQ. 0 .OR. NBROWF .LT. KEEP(63)) THEN !$ CHUNK8 = int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8) !$OMP& .AND. NOMP .GT. 1) DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = 0 IF (IW(IOLDPS+XXLR).GE.1) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0, & NBROWF, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) NB_BLR_LS = NPARTSCB call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR_LS) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS, & NBCOLF, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max( KEEP(360)/2, !$ & ((NBROWF+NOMP-1)/NOMP +2) / 3 ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK) !$OMP& IF (NBROWF .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(NBROWF-1,8) APOS = POSELT+ JJ8*int(NBCOLF,8) JJ3 = min( int(NBCOLF,8) - 1_8, & JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG ) A(APOS: APOS+JJ3) = ZERO ENDDO !$OMP END PARALLEL DO ENDIF K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = -JPOS JPOS = JPOS + 1 END DO K1 = IOLDPS + HF K2 = K1 + NBROWF - 1 JPOS = 1 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN K1RHS = 0 K2RHS = -1 DO K = K1, K2 J = IW(K) ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN K1RHS = K JFirstRHS=J-N ENDIF JPOS = JPOS + 1 ENDDO IF (K1RHS.GT.0) K2RHS=K2 IF ( K2RHS.GE.K1RHS ) THEN IN = INODE DO WHILE (IN.GT.0) IJROW = -ITLOC(IN) DO K = K1RHS, K2RHS J = IW(K) I = ITLOC(J) ILOC = mod(I,NBCOLF) APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+ IN) ENDDO IN = FILS(IN) ENDDO ENDIF ELSE DO K = K1, K2 J = IW(K) ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS JPOS = JPOS + 1 END DO ENDIF ELBEG = FRT_PTR(INODE) NUMELT = FRT_PTR(INODE+1) - ELBEG DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1_8 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = ITLOC(INTARR(II8)) IF (KEEP(50).EQ.0) THEN IF (I.LE.0) CYCLE AINPUT8 = AII8 + II8 - J18 IPOS = mod(I,NBCOLF) ICT12 = POSELT + int(IPOS-1,8) * int(NBCOLF,8) DO JJ8 = J18, J28 JPOS = ITLOC(INTARR(JJ8)) IF (JPOS.LE.0) THEN JPOS = -JPOS ELSE JPOS = JPOS/NBCOLF END IF APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ELSE IF ( I .EQ. 0 ) THEN AII8 = AII8 + J28 - II8 + 1_8 CYCLE ENDIF IF ( I .LE. 0 ) THEN IPOS1 = -I IPOS2 = 0 ELSE IPOS1 = I/NBCOLF IPOS2 = mod(I,NBCOLF) END IF ICT12 = POSELT + int(IPOS2-1,8)*int(NBCOLF,8) DO JJ8=II8,J28 AII8 = AII8 + 1_8 J = ITLOC(INTARR(JJ8)) IF ( J .EQ. 0 ) CYCLE IF ( IPOS2.EQ.0 .AND. J.LE.0) CYCLE IF ( J .LE. 0 ) THEN JPOS = -J ELSE JPOS = J/NBCOLF END IF IF ( (IPOS1.GE.JPOS) .AND. (IPOS2.GT.0) ) THEN APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AII8-1_8) END IF IF ( (IPOS1.LT.JPOS) .AND. (J.GT.0) ) THEN IPOS = mod(J,NBCOLF) JPOS = IPOS1 APOS2 = POSELT + int(IPOS-1,8)*int(NBCOLF,8) & + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AII8-1_8) END IF END DO END IF END DO END DO K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 END DO END SUBROUTINE SMUMPS_ASM_SLAVE_ELEMENTS MUMPS_5.8.1/src/cmumps_config_file.F0000664000175000017500000000103315042446440017164 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_CONFIG_FILE_RETURN() RETURN END SUBROUTINE CMUMPS_CONFIG_FILE_RETURN MUMPS_5.8.1/src/sfac_front_LU_type1.F0000664000175000017500000012352715042446437017225 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC1_LU_M CONTAINS SUBROUTINE SMUMPS_FAC1_LU( & N, INODE, IW, LIW, A, & LA, & IOLDPS, POSELT, IFLAG, IERROR, UU, & NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, & IWPOS & , LRGROUPS & , PERM & ) USE SMUMPS_FAC_FRONT_AUX_M USE SMUMPS_OOC USE SMUMPS_FAC_LR USE SMUMPS_LR_TYPE USE MUMPS_LR_STATS USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_DATA_M USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T #if ! defined(BLR_NOOPENMP) #endif !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, INTENT(INOUT) :: NOFFW, NPVW, NBTINYW INTEGER, INTENT(INOUT) :: DET_EXPW, DET_SIGNW REAL, INTENT(INOUT) :: DET_MANTW INTEGER IW( LIW ) REAL A( LA ) INTEGER MYID, SLAVEF, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ), STEP(N) REAL UU, SEUIL LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)), PERM(N) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER LAST_ROW, LAST_COL, FIRST_COL LOGICAL CALL_LTRSM, CALL_UTRSM REAL UUTEMP LOGICAL STATICMODE REAL SEUIL_LOC INTEGER PIVOT_OPTION INTEGER LRTRSM_OPTION INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U INTEGER TYPEF_LOC TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PARPIV_T1 INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER :: K473_LOC INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER INFO_TMP(2), MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM, NELIM_LOC INTEGER :: IROW_L, NVSCHUR INTEGER, POINTER, DIMENSION(:) :: PTDummy INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_U, BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL REAL, POINTER, DIMENSION(:) :: DIAG INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, LorU, I, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG CHARACTER(len=1) :: DIR REAL, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) REAL, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok,J INTEGER :: OMP_NUM INTEGER :: IP INTEGER(8) :: UPOS, LPOS INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_U, NEXT_BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC REAL :: ZERO PARAMETER (ZERO=0.0E0) LOGICAL :: SWAP_OCCURRED INCLUDE 'mumps_headers.h' FIRST_BLOCK = -99999 LAST_BLOCK = -99999 IP=0 IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF SWAP_OCCURRED = .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 PIVOT_OPTION = KEEP(468) LRTRSM_OPTION = KEEP(475) LAFAC = -9999_8 XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) NASS = abs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED = .FALSE. COMPRESS_PANEL = .FALSE. COMPRESS_CB = .FALSE. NULLIFY(PTDummy) NULLIFY(BEGS_BLR) NULLIFY(CB_LRB) NULLIFY(ACC_LUA) NULLIFY(BLR_U) NULLIFY(BLR_L) NULLIFY(BEGS_BLR_TMP) NULLIFY(BLR_PANEL) NULLIFY(DIAG) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN K473_LOC = 1 ELSE K473_LOC = KEEP(473) ENDIF K473_LOC = KEEP(473) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL SMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS, KEEP, & LR_ACTIVATED, PARPIV_T1) IF (UUTEMP.EQ.ZERO) THEN PIVOT_OPTION=0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF IF (LR_ACTIVATED) THEN IF (LRTRSM_OPTION.EQ.3) THEN PIVOT_OPTION = MIN(PIVOT_OPTION,1) ELSEIF (LRTRSM_OPTION.EQ.2) THEN PIVOT_OPTION = MIN(PIVOT_OPTION, 2) ENDIF ENDIF IF (PIVOT_OPTION.LE.1) THEN PARPIV_T1 = 0 ENDIF CALL SMUMPS_SET_INNERBLOCKSIZE( NBKJIB_ORIG, NASS, KEEP) IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = IOLDPS+6+XSIZE+NASS CALL SMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF ( OOC_EFFECTIVE_ON_FRONT ) THEN LNextPiv2beWritten = 1 UNextPiv2beWritten = 1 PP_FIRST2SWAP_L = LNextPiv2beWritten PP_FIRST2SWAP_U = UNextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%LastPanelWritten_U = 0 PP_LastPIVRPTRFilled_L = 0 PP_LastPIVRPTRFilled_U = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 1 MonBloc%NROW = NFRONT MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -88877 NULLIFY(MonBloc%INDICES) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(405) .EQ. 1) THEN !$OMP ATOMIC UPDATE CNT_NODES = CNT_NODES + 1 !$OMP END ATOMIC ELSE CNT_NODES = CNT_NODES + 1 ENDIF ELSE IF (KEEP(486).NE.0) THEN ENDIF OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472), & NFRONT, KEEP(1)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 490 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL SMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .FALSE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF IF (COMPRESS_CB) THEN IF (NPARTSCB.GT.0) THEN allocate(CB_LRB(NPARTSCB,NPARTSCB),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSCB*NPARTSCB GOTO 490 ENDIF CALL SMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF ENDIF DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = BEGS_BLR(CURRENT_BLR+1)-1 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(480).GE.5) THEN IF (CURRENT_BLR.EQ.1) THEN ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR) THEN BLR_U(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) BLR_L(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ELSE IF (NB_BLR.GT.CURRENT_BLR) THEN CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF IF (CURRENT_BLR.LT.NPARTSASS) THEN ALLOCATE(NEXT_BLR_U(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF ALLOCATE(NEXT_BLR_L(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR+1) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR+1, NEXT_BLR_U, 0) CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR+1, NEXT_BLR_L, 0) ENDIF ENDIF ELSE ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE CALL SMUMPS_FAC_I(NFRONT,NASS,NFRONT, & IBEG_BLOCK,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, & DKEEP(1), PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1 & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF ELSE IF ( INOPV.LE.0 ) THEN INOPV = 0 IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL SMUMPS_FAC_MQ(IBEG_BLOCK, IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED & ) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) THEN GOTO 50 ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_U, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL SMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, & NPIV, NFRONT, IEND_BLR, LAST_COL, & A, LA, POSELT, & -66666, & .TRUE., .FALSE., .TRUE., & .FALSE., & LR_ACTIVATED & ) ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN IF (PIVOT_OPTION.EQ.4) THEN LAST_ROW = NFRONT ELSE LAST_ROW = NASS ENDIF IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSE LAST_COL = NASS ENDIF IF (IEND_BLR.LT.LAST_ROW) THEN CALL SMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, LAST_ROW, LAST_COL, & A, LA, POSELT, IEND_BLR, .TRUE., (PIVOT_OPTION.LT.2), & .TRUE., .FALSE., & LR_ACTIVATED) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_U(J)%M=0 BLR_U(J)%N=0 BLR_U(J)%K=0 BLR_U(J)%ISLR=.FALSE. NULLIFY(BLR_U(J)%Q) NULLIFY(BLR_U(J)%R) ENDDO CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) NULLIFY(BLR_L) NULLIFY(BLR_U) IF (KEEP(480).GE.2 .AND. IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = 1 ELSE FIRST_BLOCK = NPARTSASS-CURRENT_BLR ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL SMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) IF (IFLAG.LT.0) GOTO 900 CALL SMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) 900 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF ENDIF GOTO 100 ENDIF IF (PIVOT_OPTION.GE.3) THEN FIRST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN FIRST_COL = NASS ELSE FIRST_COL = IEND_BLR ENDIF IF (LRTRSM_OPTION.EQ.3) THEN LAST_COL = IEND_BLR ELSEIF (LRTRSM_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = NFRONT ENDIF CALL_LTRSM = (LRTRSM_OPTION.EQ.0) CALL_UTRSM = (LAST_COL-FIRST_COL.GT.0) IF ((IEND_BLR.LT.NFRONT) .AND. & (CALL_LTRSM.OR.CALL_UTRSM)) THEN CALL SMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NFRONT, & LAST_COL, & A, LA, POSELT, & FIRST_COL, CALL_LTRSM, & CALL_UTRSM, .FALSE., & .FALSE., & LR_ACTIVATED) ENDIF #if ! defined(BLR_NOOPENMP) #endif #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(UPOS,LPOS) FIRSTPRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), & KEEP(458), K473_LOC, & BLR_U, CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), & KEEP(458), K473_LOC, BLR_L, & CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER !$OMP MASTER #endif IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (LRTRSM_OPTION.GT.0) THEN CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NB_BLR, 1, 0, 0, .FALSE.) IF (PIVOT_OPTION.LT.3.AND.LRTRSM_OPTION.GE.2) THEN IF (PIVOT_OPTION.LE.1.AND.LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, NB_BLR, BLR_U, & CURRENT_BLR, FIRST_BLOCK, NB_BLR, & 1, 0, 1, .FALSE.) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif CALL SMUMPS_BLR_UPD_NELIM_VAR_U( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_U, NB_BLR, & FIRST_BLOCK, IBEG_BLR, NPIV, NELIM) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(480).GE.2) THEN UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) LPOS = POSELT+int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) CALL SMUMPS_BLR_UPD_NELIM_VAR_L(A, LA, UPOS, A, LA, & LPOS, IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & CURRENT_BLR+1, NELIM, 'N') IF (IFLAG.LT.0) GOTO 444 IF (IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = 1 ELSE FIRST_BLOCK = NPARTSASS-CURRENT_BLR ENDIF CALL SMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) IF (IFLAG.LT.0) GOTO 442 CALL SMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) 442 CONTINUE ENDIF 444 CONTINUE ELSE CALL SMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & BLR_U, NB_BLR, & NELIM,.FALSE., 0, & 1, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(486).NE.2) THEN LAST_BLOCK = NB_BLR ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF IF (LRTRSM_OPTION.GT.0) THEN FIRST_BLOCK = CURRENT_BLR+1 CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_L, CURRENT_BLR, 'V', 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) #if ! defined(BLR_NOOPENMP) #endif ENDIF IF (LRTRSM_OPTION.GE.2) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_U, CURRENT_BLR, 'H', 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL(BLR_U, NB_BLR-CURRENT_BLR, KEEP8, & KEEP(34)) CALL DEALLOC_BLR_PANEL(BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & KEEP(34)) DEALLOCATE(BLR_U,BLR_L) ENDIF ENDIF NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN IF (PIVOT_OPTION.LT.4) THEN TYPEF_LOC = TYPEF_U ELSE TYPEF_LOC = TYPEF_BOTH_LU ENDIF MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_LOC, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO IP=1,NB_BLR+1 BEGS_BLR_TMP(IP) = BEGS_BLR_STATIC(IP) ENDDO ENDIF ENDIF MEM_TOT = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP& PRIVATE(IP, LorU, DIR, NELIM_LOC, BLR_PANEL) #endif IF ( & (KEEP(486).EQ.2) & ) THEN #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*(2*DIAGSIZ_STA-DIAGSIZ_DYN) MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA IF (I.LE.DIAGSIZ_DYN) THEN DIAG(DPOS:DPOS+DIAGSIZ_STA-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_STA-1,8)) DPOS = DPOS + DIAGSIZ_STA ELSE DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN ENDIF POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL SMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG, KEEP(34)) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO !$OMP SINGLE #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM_TOT,8), & (KEEP(405).NE.0), KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 447 IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN DO IP=1,NPARTSASS NELIM_LOC = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) DO LorU=0,1 CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8, & KEEP(34)) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (LorU.EQ.0) THEN DIR = 'V' ELSE DIR = 'H' ENDIF CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(458), K473_LOC, & BLR_PANEL, IP, & DIR, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM_LOC, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif 445 CONTINUE ENDIF 447 CONTINUE ENDIF IF (IFLAG .LT. 0) GOTO 450 IF (KEEP(480) .GE. 2) THEN #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif CALL SMUMPS_BLR_UPD_CB_LEFT(A, LA, POSELT, NFRONT, & BEGS_BLR_STATIC, BEGS_BLR_STATIC, & NPARTSCB, NPARTSCB, NPARTSASS, NASS, & IW(IOLDPS+XXF), & 1, .FALSE., IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & ACC_LUA, KEEP(480),KEEP(479),KEEP(478),KEEP(476), & KEEP(484), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & .FALSE., & CB_LRB, KEEP8) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF IF (IFLAG.LT.0) GOTO 450 #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF (COMPRESS_CB & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL SMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (COMPRESS_CB) THEN IEND_BLR = BEGS_BLR(CURRENT_BLR+2) IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) ENDIF ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (COMPRESS_CB) THEN CALL SMUMPS_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR, NPARTSCB, NPARTSCB, NPARTSASS, & NFRONT-NASS, NFRONT-NASS, INODE, & IW(IOLDPS+XXF), 0, 1, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & -9999, -9999, -9999, KEEP(1), & NELIM=NELIM) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF 450 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF ( & ( & (KEEP(486).EQ.2) & ) & .AND.UU.GT.0 .AND. SWAP_OCCURRED & ) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 0, NASS-NPIV) DO IP=1,NPARTSASS DO LorU=0,1 CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NB_BLR-IP & ) ENDDO ENDDO CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NPIV, 0, 1) ENDIF IF ( (PIVOT_OPTION.LT.4) .AND. (.NOT.LR_ACTIVATED) ) THEN CALL SMUMPS_FAC_FR_UPDATE_CBROWS( INODE, & NFRONT, NASS, (PIVOT_OPTION.LT.3), A, LA, LAFAC, POSELT, & IW, LIW, IOLDPS, MonBloc, MYID, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR ) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 0, 1) ENDIF ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF CALL SMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 490 CONTINUE 500 CONTINUE 600 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(WORK)) deallocate(WORK) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) deallocate(TAU) IF (allocated(JPVT)) deallocate(JPVT) IF (allocated(BLOCK)) deallocate(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) ENDDO ENDIF DEALLOCATE(ACC_LUA) NULLIFY(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL SMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 2, & KEEP8, KEEP(34)) ENDIF ENDIF IF ( LR_ACTIVATED .AND. KEEP(486).EQ. 2 .AND. & KEEP(251) .EQ. 2) THEN CALL SMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8, KEEP(34)) ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND. .NOT.COMPRESS_CB) THEN CALL SMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34), MTK405=KEEP(405)) ENDIF ENDIF NPVW = NPVW + IW(IOLDPS+1+XSIZE) RETURN END SUBROUTINE SMUMPS_FAC1_LU END MODULE SMUMPS_FAC1_LU_M SUBROUTINE SMUMPS_FAC1_LU_I( N, INODE, IW, LIW, A, & LA, & IOLDPS, POSELT, IFLAG, IERROR, UU, & NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, & IWPOS & , LRGROUPS & , PERM & ) USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T USE SMUMPS_FAC1_LU_M, ONLY: SMUMPS_FAC1_LU IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, INTENT(INOUT) :: NOFFW, NPVW, NBTINYW INTEGER, INTENT(INOUT) :: DET_EXPW, DET_SIGNW REAL, INTENT(INOUT) :: DET_MANTW INTEGER IW( LIW ) REAL A( LA ) INTEGER MYID, SLAVEF, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ), STEP(N) REAL UU, SEUIL LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)), PERM(N) CALL SMUMPS_FAC1_LU( N, INODE, IW, LIW, A, & LA, & IOLDPS, POSELT, IFLAG, IERROR, UU, & NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, & IWPOS & , LRGROUPS & , PERM & ) RETURN END SUBROUTINE SMUMPS_FAC1_LU_I MUMPS_5.8.1/src/dmumps_intr_types.F0000664000175000017500000001077615042446441017140 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_INTR_TYPES USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC PRIVATE PUBLIC :: DMUMPS_ROOT_STRUC, & DMUMPS_L0OMPFAC_T, & DMUMPS_INTR_STRUC, & DMUMPS_INIT_INTR_ENCODING, & DMUMPS_FREE_INTR_ENCODING, & DMUMPS_ENCODE_INTR, & DMUMPS_DECODE_INTR C DMUMPS_ROOT_STRUC no longer contains INTEGERS TYPE DMUMPS_ROOT_STRUC ! 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 ! 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 ! for SVD on root (#define try_null_space) DOUBLE PRECISION, DIMENSION(:,:), POINTER :: SVD_U, SVD_VT ! for RR on root (#define try_null_space) DOUBLE PRECISION, DIMENSION(:), POINTER :: SINGULAR_VALUES ! END TYPE DMUMPS_ROOT_STRUC ! multicore TYPE DMUMPS_L0OMPFAC_T DOUBLE PRECISION, POINTER, DIMENSION(:) :: A INTEGER(8) :: LA END TYPE DMUMPS_L0OMPFAC_T C C All MUMPS internal datatypes are in an internal structure: TYPE DMUMPS_INTR_STRUC TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota TYPE (DMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & L0_OMP_FACTORS END TYPE DMUMPS_INTR_STRUC C ================================================================= CONTAINS C ================================================================= SUBROUTINE DMUMPS_INIT_INTR_ENCODING(id_intr_ENCODING) IMPLICIT NONE CHARACTER, DIMENSION(:), POINTER :: id_intr_ENCODING C To be called only before JOB=-1 NULLIFY(id_intr_ENCODING) END SUBROUTINE DMUMPS_INIT_INTR_ENCODING C ================================================================= SUBROUTINE DMUMPS_FREE_INTR_ENCODING(id_intr_ENCODING) IMPLICIT NONE CHARACTER, DIMENSION(:), POINTER :: id_intr_ENCODING C To be called only after JOB=-2 DEALLOCATE(id_intr_ENCODING) NULLIFY(id_intr_ENCODING) RETURN END SUBROUTINE DMUMPS_FREE_INTR_ENCODING C ================================================================= SUBROUTINE DMUMPS_ENCODE_INTR(id_intr_ENCODING, id_intr) IMPLICIT NONE C C Arguments: C ========= CHARACTER, DIMENSION(:), POINTER :: id_intr_ENCODING TYPE (DMUMPS_INTR_STRUC) :: id_intr C C Local variables: C =============== CHARACTER :: CHAR_ARRAY(1) INTEGER :: CHAR_LENGTH, IERR C IF (associated(id_intr_ENCODING)) THEN C Should be unassociated on entry WRITE(*,*) "Internal error in DMUMPS_ENCODE_INTR:", & " id_intr_ENCODING already allocated" CALL MUMPS_ABORT() ENDIF CHAR_LENGTH=size(transfer(id_intr,CHAR_ARRAY)) ALLOCATE(id_intr_ENCODING(CHAR_LENGTH), stat=IERR) IF (IERR > 0 ) THEN WRITE(*,*) "Allocation error in MUMPS_ENCODE_INTR" CALL MUMPS_ABORT() ENDIF C Fill with derived datatype id_intr_ENCODING=transfer(id_intr,CHAR_ARRAY) RETURN END SUBROUTINE DMUMPS_ENCODE_INTR C ================================================================= SUBROUTINE DMUMPS_DECODE_INTR(id_intr_ENCODING, id_intr) IMPLICIT NONE CHARACTER(len=1), DIMENSION(:), POINTER :: id_intr_ENCODING TYPE (DMUMPS_INTR_STRUC) :: id_intr IF (.NOT.associated(id_intr_ENCODING)) THEN WRITE(*,*) "Internal error 1 in DMUMPS_DECODE_INTR" CALL MUMPS_ABORT() ENDIf id_intr=transfer(id_intr_ENCODING,id_intr) DEALLOCATE(id_intr_ENCODING) NULLIFY(id_intr_ENCODING) RETURN END SUBROUTINE DMUMPS_DECODE_INTR END MODULE DMUMPS_INTR_TYPES MUMPS_5.8.1/src/cbcast_int.F0000664000175000017500000000314015042446440015446 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_MCAST2(DATA, LDATA, MPITYPE, ROOT, COMMW, TAG, &SLAVEF, KEEP) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER LDATA, ROOT, COMMW, TAG, MPITYPE, SLAVEF INTEGER DEST INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER DATA(LDATA) DO 10 DEST = 0, SLAVEF - 1 IF (DEST .NE. ROOT) THEN IF ( LDATA .EQ. 1 .and. MPITYPE .EQ. MPI_INTEGER ) THEN CALL MUMPS_BUF_SEND_1INT( DATA(1), DEST, TAG, & COMMW, KEEP, IERR ) ELSE WRITE(*,*) 'Error : bad argument to CMUMPS_MCAST2' CALL MUMPS_ABORT() END IF ENDIF 10 CONTINUE RETURN END SUBROUTINE CMUMPS_MCAST2 SUBROUTINE CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) INTEGER MYID, SLAVEF, COMM INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY (1) DUMMY(1) = -98765 CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERREUR, SLAVEF, KEEP ) RETURN END SUBROUTINE CMUMPS_BDC_ERROR MUMPS_5.8.1/src/ctype3_root.F0000664000175000017500000016066715042446440015631 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ASS_ROOT( root, roota, KEEP50, & NROW_SON, NCOL_SON, INDROW_SON, & INDCOL_SON, NSUPCOL, VAL_SON, VAL_ROOT, & LOCAL_M, LOCAL_N, & RHS_ROOT, NLOC_ROOT, CBP ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER, INTENT(IN) :: KEEP50 INTEGER NCOL_SON, NROW_SON, NSUPCOL INTEGER, intent(in) :: CBP INTEGER INDROW_SON( NROW_SON ), INDCOL_SON( NCOL_SON ) INTEGER LOCAL_M, LOCAL_N COMPLEX VAL_SON( NCOL_SON, NROW_SON ) COMPLEX VAL_ROOT( LOCAL_M, LOCAL_N ) INTEGER NLOC_ROOT COMPLEX RHS_ROOT( LOCAL_M, NLOC_ROOT ) INTEGER I, J, INDROW, INDCOL, IPOSROOT, JPOSROOT IF (CBP .EQ. 0) THEN DO I = 1, NROW_SON INDROW = INDROW_SON(I) IPOSROOT = (root%NPROW*((INDROW-1)/root%MBLOCK)+root%MYROW) & * root%MBLOCK + mod(INDROW-1,root%MBLOCK) + 1 DO J = 1, NCOL_SON-NSUPCOL INDCOL = INDCOL_SON(J) IF (KEEP50.NE.0) THEN JPOSROOT = (root%NPCOL*((INDCOL-1)/root%NBLOCK)+root%MYCOL) & * root%NBLOCK + mod(INDCOL-1,root%NBLOCK) + 1 IF (IPOSROOT < JPOSROOT) THEN CYCLE ENDIF ENDIF VAL_ROOT( INDROW, INDCOL ) = & VAL_ROOT( INDROW, INDCOL ) + VAL_SON(J,I) END DO DO J = NCOL_SON-NSUPCOL+1, NCOL_SON INDCOL = INDCOL_SON(J) RHS_ROOT( INDROW, INDCOL ) = & RHS_ROOT( INDROW, INDCOL ) + VAL_SON(J,I) ENDDO END DO ELSE DO I=1, NROW_SON DO J = 1, NCOL_SON RHS_ROOT( INDROW_SON( I ), INDCOL_SON(J)) = & RHS_ROOT(INDROW_SON(I),INDCOL_SON(J)) + VAL_SON(J,I) ENDDO ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_ASS_ROOT RECURSIVE SUBROUTINE CMUMPS_BUILD_AND_SEND_CB_ROOT & ( COMM_LOAD, ASS_IRECV, N, ISON, IROOT, & PTRI, PTRR, & root, roota, NBROW, NBCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, SHIFT_VAL_SON_ARG, LDA_ARG, TAG, & MYID, COMM, BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,TRANSPOSE_ASM, & ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS, NELIM_ROOT, NELIM_ROW, NELIM_COL & ) USE CMUMPS_OOC USE CMUMPS_BUF USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER N, ISON, IROOT, TAG INTEGER PTRI( KEEP(28) ) INTEGER(8) :: PTRR( KEEP(28) ) INTEGER NBROW, NBCOL INTEGER, INTENT(IN):: LDA_ARG INTEGER(8), INTENT(IN) :: SHIFT_VAL_SON_ARG INTEGER SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER MYID, COMM LOGICAL TRANSPOSE_ASM INTEGER :: NELIM_ROOT, NELIM_ROW, NELIM_COL INCLUDE 'mpif.h' INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NSTK( N ) INTEGER COMP, IFLAG, IERROR INTEGER PERM(N) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER INTARR( KEEP8(27) ) COMPLEX DBLARR( KEEP8(26) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) COMPLEX, DIMENSION(:), POINTER :: SONA_PTR INTEGER(8) :: LSONA_PTR, POSSONA_PTR INTEGER allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: PTRROW, PTRCOL INTEGER, ALLOCATABLE, DIMENSION(:) :: NSUPROW, NSUPCOL INTEGER, ALLOCATABLE, DIMENSION(:) :: ROW_INDEX_LIST INTEGER, ALLOCATABLE, DIMENSION(:) :: COL_INDEX_LIST INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER I, POS_IN_ROOT, IROW, JCOL, IGLOB, JGLOB INTEGER PDEST, IERR INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: POSROOT INTEGER NSUBSET_ROW, NSUBSET_COL INTEGER NRLOCAL, NCLOCAL INTEGER :: LDA INTEGER(8) :: SHIFT_VAL_SON LOGICAL SET_IRECV, BLOCKING, MESSAGE_RECEIVED INTEGER NBROWS_ALREADY_SENT INTEGER SIZE_MSG INTEGER LP INCLUDE 'mumps_headers.h' LOGICAL SKIPLAST_RHS_ROWS, BCP_SYM_NONEMPTY INTEGER BBPCBP BBPCBP = 0 LP = ICNTL(1) IF ( ICNTL(4) .LE. 0 ) LP = -1 IF (LDA_ARG < 0) THEN CALL CMUMPS_SET_LDA_SHIFT_VAL_SON(IW, LIW, PTRI(STEP(ISON)), & LDA, SHIFT_VAL_SON) ELSE LDA = LDA_ARG SHIFT_VAL_SON = SHIFT_VAL_SON_ARG ENDIF ALLOCATE(PTRROW(root%NPROW + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPROW + 1 endif ALLOCATE(PTRCOL(root%NPCOL + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPCOL + 1 endif ALLOCATE(NSUPROW(root%NPROW + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPROW + 1 endif ALLOCATE(NSUPCOL(root%NPCOL + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPCOL + 1 endif IF (IFLAG.LT.0) THEN IF (LP > 0) write(6,*) MYID, ' : MEMORY ALLOCATION ', & 'FAILURE in CMUMPS_BUILD_AND_SEND_CB_ROOT' CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF SKIPLAST_RHS_ROWS = ((KEEP(253).GT.0).AND.(KEEP(50).EQ.0)) BCP_SYM_NONEMPTY = .FALSE. PTRROW = 0 PTRCOL = 0 NSUPROW = 0 NSUPCOL = 0 DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (IGLOB.GT.N) THEN BCP_SYM_NONEMPTY = .TRUE. POS_IN_ROOT = IGLOB - N JCOL = mod((POS_IN_ROOT-1)/root%NBLOCK,root%NPCOL) NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 ELSE IF ( I .LE. NELIM_ROW ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( IGLOB ) ENDIF 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 IF ( I .LE. NELIM_ROW ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( IGLOB ) ENDIF ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, root%NPCOL ) IF (IGLOB.GT.N) & NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 END IF END DO IF (KEEP(50).NE.0 .AND.(.NOT.TRANSPOSE_ASM).AND.BCP_SYM_NONEMPTY) & BBPCBP = 1 DO I = 1, NBCOL JGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_COL_SON + I - 1 ) IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (KEEP(50).EQ.0) THEN IF (JGLOB.LE.N) THEN IF ( I.LE.NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L(JGLOB) ENDIF 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 IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( JGLOB ) ENDIF JCOL = mod((POS_IN_ROOT-1) / root%NBLOCK, root%NPCOL ) PTRCOL ( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 IF (BCP_SYM_NONEMPTY) THEN 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 IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( JGLOB ) ENDIF ELSE POS_IN_ROOT = JGLOB-N ENDIF IROW = mod( ( POS_IN_ROOT - 1 ) / & root%MBLOCK, root%NPROW ) PTRROW ( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 END IF END DO PTRROW( 1 ) = 1 DO IROW = 2, root%NPROW + 1 PTRROW( IROW ) = PTRROW( IROW ) + PTRROW( IROW - 1 ) END DO PTRCOL( 1 ) = 1 DO JCOL = 2, root%NPCOL + 1 PTRCOL( JCOL ) = PTRCOL( JCOL ) + PTRCOL( JCOL - 1 ) END DO ALLOCATE(ROW_INDEX_LIST(PTRROW(root%NPROW+1)-1+1), & stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = PTRROW(root%NPROW+1)-1+1 endif ALLOCATE(COL_INDEX_LIST(PTRCOL(root%NPCOL+1)-1+1), & stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = PTRCOL(root%NPCOL+1)-1+1 endif DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (IGLOB.GT.N) CYCLE IF ( I .LE. NELIM_ROW ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( IGLOB ) 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 ELSE IF (IGLOB.LE.N) THEN IF ( I .LE. NELIM_ROW ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( IGLOB ) ENDIF ELSE POS_IN_ROOT = IGLOB - N ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, & root%NPCOL ) COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 END IF END DO DO I = 1, NBCOL JGLOB = IW( PTRI(STEP(ISON))+SHIFT_LIST_COL_SON+I - 1 ) IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF ( JGLOB.LE.N ) THEN IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( JGLOB ) ENDIF 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 IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( JGLOB ) ENDIF 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 IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L(JGLOB) ENDIF ENDIF IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I PTRROW( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 ENDDO ENDIF DO IROW = root%NPROW, 2, -1 PTRROW( IROW ) = PTRROW( IROW - 1 ) END DO PTRROW( 1 ) = 1 DO JCOL = root%NPCOL, 2, -1 PTRCOL( JCOL ) = PTRCOL( JCOL - 1 ) END DO PTRCOL( 1 ) = 1 JCOL = root%MYCOL IROW = root%MYROW IF ( root%yes ) THEN if (IROW .ne. root%MYROW .or. JCOL.ne.root%MYCOL) then write(*,*) ' error in grid position buildandsendcbroot' CALL MUMPS_ABORT() end if IF ( PTRIST(STEP(IROOT)).EQ.0.AND. & PTLUST_S(STEP(IROOT)).EQ.0) THEN CALL CMUMPS_ROOT_ALLOC_STATIC(root, roota, IROOT, N, IW, LIW, & A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP, IERROR ) KEEP(121) = -1 IF (IFLAG.LT.0) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF ELSE KEEP(121) = KEEP(121) - 1 IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL CMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL CMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL CMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT+N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF END IF CALL CMUMPS_DM_SET_DYNPTR( IW(PTRI(STEP(ISON))+XXS), A, LA, & PTRR(STEP(ISON)), IW(PTRI(STEP(ISON))+XXD), & IW(PTRI(STEP(ISON))+XXR), & SONA_PTR, POSSONA_PTR, LSONA_PTR ) IF (KEEP(60) .NE. 0 ) THEN LOCAL_M = root%SCHUR_LLD LOCAL_N = root%SCHUR_NLOC NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) CALL CMUMPS_ROOT_LOCAL_ASSEMBLY( N, & roota%SCHUR_POINTER(1), & LOCAL_M, LOCAL_N, & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NRLOCAL, & NCLOCAL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%RG2L(1), TRANSPOSE_ASM, & KEEP, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) ELSE IF ( PTRIST(STEP( IROOT )) .GE. 0 ) THEN IF ( PTRIST(STEP( IROOT )) .EQ. 0 ) THEN LOCAL_N = IW( PTLUST_S(STEP(IROOT)) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST_S(STEP(IROOT)) + 2 + KEEP(IXSZ)) POSROOT = PTRFAC(IW( PTLUST_S(STEP(IROOT)) +4+KEEP(IXSZ) )) ELSE LOCAL_N = - IW( PTRIST(STEP(IROOT)) +KEEP(IXSZ)) LOCAL_M = IW( PTRIST(STEP(IROOT)) + 1 +KEEP(IXSZ)) POSROOT = PAMASTER(STEP( IROOT )) ENDIF NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) CALL CMUMPS_ROOT_LOCAL_ASSEMBLY( N, A( POSROOT ), & LOCAL_M, LOCAL_N, & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NRLOCAL, & NCLOCAL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%RG2L(1), TRANSPOSE_ASM, & KEEP, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) END IF ENDIF END IF DO IROW = 0, root%NPROW - 1 DO JCOL = 0, root%NPCOL - 1 PDEST = IROW * root%NPCOL + JCOL IF ( (root%MYROW.eq.IROW.and.root%MYCOL.eq.JCOL) .and. & MYID.ne.PDEST) THEN write(*,*) 'error: myrow,mycol=',root%MYROW,root%MYCOL write(*,*) ' MYID,PDEST=',MYID,PDEST CALL MUMPS_ABORT() END IF IF ( root%MYROW .NE. IROW .OR. root%MYCOL .NE. JCOL) THEN NBROWS_ALREADY_SENT = 0 IERR = -1 DO WHILE ( IERR .EQ. -1 ) NSUBSET_ROW = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) NSUBSET_COL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) IF ( LRLU .LT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) & .AND. LRLUS .GT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) ) & THEN CALL CMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) MYID,": pb compress in", & "CMUMPS_BUILD_AND_SEND_CB_ROOT" WRITE(*,*) MYID,': LRLU, LRLUS=',LRLU,LRLUS CALL MUMPS_ABORT() END IF END IF CALL CMUMPS_DM_SET_DYNPTR( & IW(PTRI(STEP(ISON))+XXS), A, LA, & PTRR(STEP(ISON)), IW(PTRI(STEP(ISON))+XXD), & IW(PTRI(STEP(ISON))+XXR), & SONA_PTR, POSSONA_PTR, LSONA_PTR ) CALL CMUMPS_BUF_SEND_CONTRIB_TYPE3_I( N, ISON, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & TAG, & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NSUBSET_ROW, NSUBSET_COL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%NPROW, root%NPCOL, root%MBLOCK, & root%RG2L(1), & root%NBLOCK, PDEST, & COMM, IERR, A( POSFAC ), LRLU, TRANSPOSE_ASM, & SIZE_MSG, NBROWS_ALREADY_SENT, KEEP, BBPCBP, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK, & COMP, IFLAG, IERROR, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, MYID, SLAVEF, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW,PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (LDA_ARG < 0) THEN CALL CMUMPS_SET_LDA_SHIFT_VAL_SON( & IW, LIW, PTRI(STEP(ISON)), & LDA, SHIFT_VAL_SON) ENDIF END IF END DO IF ( IERR == -2 ) THEN IFLAG = -17 IERROR = SIZE_MSG IF (LP > 0) WRITE(LP, *) "FAILURE, SEND BUFFER TOO & SMALL DURING CMUMPS_BUILD_AND_SEND_CB_ROOT" CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 500 ENDIF IF ( IERR == -3 ) THEN IF (LP > 0) WRITE(LP, *) "FAILURE, RECV BUFFER TOO & SMALL DURING CMUMPS_BUILD_AND_SEND_CB_ROOT" IFLAG = -20 IERROR = SIZE_MSG CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 500 ENDIF END IF END DO END DO 500 CONTINUE DEALLOCATE(PTRROW) DEALLOCATE(PTRCOL) DEALLOCATE(ROW_INDEX_LIST) DEALLOCATE(COL_INDEX_LIST) RETURN CONTAINS SUBROUTINE CMUMPS_SET_LDA_SHIFT_VAL_SON(IW, LIW, IOLDPS, & LDA, SHIFT_VAL_SON) INTEGER, INTENT(IN) :: LIW, IOLDPS INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT) :: LDA INTEGER(8), INTENT(OUT) :: SHIFT_VAL_SON INCLUDE 'mumps_headers.h' INTEGER :: LCONT, NROW, NPIV, NASS, NELIM LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV IF (IW(IOLDPS+XXS).EQ.S_NOLCBNOCONTIG38.OR. & IW(IOLDPS+XXS).EQ.S_ALL) THEN SHIFT_VAL_SON = int(NPIV,8) LDA = LCONT + NPIV ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCBCONTIG38) THEN SHIFT_VAL_SON = int(NROW,8)*int(LCONT+NPIV-NELIM,8) LDA = NELIM ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCLEANED38) THEN SHIFT_VAL_SON=0_8 LDA = NELIM ELSE WRITE(*,*) MYID, & ": internal error in CMUMPS_SET_LDA_SHIFT_VAL_SON", & IW(IOLDPS+XXS), "ISON=",ISON CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE CMUMPS_SET_LDA_SHIFT_VAL_SON END SUBROUTINE CMUMPS_BUILD_AND_SEND_CB_ROOT SUBROUTINE CMUMPS_ROOT_LOCAL_ASSEMBLY( N, VAL_ROOT, & LOCAL_M, LOCAL_N, & NPCOL, NPROW, MBLOCK, NBLOCK, NBCOL_SON, NBROW_SON, INDCOL_SON, & INDROW_SON, LD_SON, VAL_SON, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, NSUPROW, NSUPCOL, & RG2L, TRANSPOSE_ASM, & KEEP, RHS_ROOT, NLOC, NELIM_ROOT, NELIM_ROW, NELIM_COL ) IMPLICIT NONE INTEGER N, LOCAL_M, LOCAL_N COMPLEX VAL_ROOT( LOCAL_M, LOCAL_N ) INTEGER NPCOL, NPROW, MBLOCK, NBLOCK INTEGER NBCOL_SON, NBROW_SON INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER LD_SON INTEGER NSUPROW, NSUPCOL COMPLEX VAL_SON( LD_SON, NBROW_SON ) INTEGER KEEP(500) INTEGER NSUBSET_ROW, NSUBSET_COL INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER RG2L( N ) LOGICAL TRANSPOSE_ASM INTEGER NLOC COMPLEX RHS_ROOT( LOCAL_M, NLOC) INTEGER :: NELIM_ROOT, NELIM_ROW, NELIM_COL 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 ) IF ( I .LE. NELIM_ROW ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L( IGLOB ) ENDIF 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 ) IF ( J .LE. NELIM_COL ) THEN JPOS_ROOT = NELIM_ROOT + J - 1 ELSE JPOS_ROOT = RG2L( JGLOB ) ENDIF JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO DO JSUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( JSUB ) JGLOB = INDCOL_SON( J ) JPOS_ROOT = JGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 RHS_ROOT(ILOC_ROOT, JLOC_ROOT) = & RHS_ROOT(ILOC_ROOT, JLOC_ROOT) + VAL_SON( J, I ) ENDDO END DO ELSE IF ( .NOT. TRANSPOSE_ASM ) THEN DO ISUB = 1, NSUBSET_ROW - NSUPROW I = SUBSET_ROW( ISUB ) IGLOB = INDROW_SON( I ) IF ( I .LE. NELIM_ROW ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L( IGLOB ) ENDIF 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 ) IF ( J .LE. NELIM_COL ) THEN JPOS_ROOT = NELIM_ROOT + J - 1 ELSE JPOS_ROOT = RG2L( JGLOB ) ENDIF IF (KEEP(50).NE.0. AND. JPOS_ROOT .GT. IPOS_ROOT) CYCLE JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO END DO DO JSUB = NSUBSET_COL -NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( JSUB ) JGLOB = INDROW_SON( J ) JPOS_ROOT = JGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 DO ISUB = NSUBSET_ROW - NSUPROW +1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IGLOB = INDCOL_SON( I ) IF ( I .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L(IGLOB) ENDIF 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 ) IF ( I .LE. NELIM_ROW ) THEN JPOS_ROOT = NELIM_ROOT + I - 1 ELSE JPOS_ROOT = RG2L( IGLOB ) ENDIF 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 ) IF ( J .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + J - 1 ELSE IPOS_ROOT = RG2L( JGLOB ) ENDIF 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 ) IF ( J .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + J - 1 ELSE IPOS_ROOT = RG2L( JGLOB ) ENDIF ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) = & RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO ENDDO END IF END IF RETURN END SUBROUTINE CMUMPS_ROOT_LOCAL_ASSEMBLY SUBROUTINE CMUMPS_INIT_ROOT_ANA &( MYID, NPROCS, N, root, COMM_ROOT, IROOT, FILS, & K50, K46, K51 & , K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK & ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC IMPLICIT NONE INTEGER MYID, MYID_ROOT TYPE (MUMPS_ROOT_STRUC)::root INTEGER COMM_ROOT INTEGER N, IROOT, NPROCS, K50, K46, K51 INTEGER FILS( N ) INTEGER K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK INTEGER INODE #if ! defined(NOSCALAPACK) INTEGER NPROWtemp, NPCOLtemp #endif LOGICAL SLAVE root%ROOT_SIZE = 0 root%TOT_ROOT_SIZE = 0 SLAVE = ( MYID .ne. 0 .or. & ( MYID .eq. 0 .and. K46 .eq. 1 ) ) INODE = IROOT DO WHILE ( INODE .GT. 0 ) INODE = FILS( INODE ) root%ROOT_SIZE = root%ROOT_SIZE + 1 END DO IF ( ( K60 .NE. 2 .AND. K60 .NE. 3 ) .OR. & IDNPROW .LE. 0 .OR. IDNPCOL .LE. 0 & .OR. IDMBLOCK .LE.0 .OR. IDNBLOCK.LE.0 & .OR. IDNPROW * IDNPCOL .GT. NPROCS ) THEN root%MBLOCK = K51 root%NBLOCK = K51 CALL CMUMPS_DEF_GRID( NPROCS, root%NPROW, root%NPCOL, & root%ROOT_SIZE, K50 ) IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN IDNPROW = root%NPROW IDNPCOL = root%NPCOL IDMBLOCK = root%MBLOCK IDNBLOCK = root%NBLOCK ENDIF ELSE IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN root%NPROW = IDNPROW root%NPCOL = IDNPCOL root%MBLOCK = IDMBLOCK root%NBLOCK = IDNBLOCK ENDIF IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN IF (SLAVE) THEN root%LPIV = 0 IF (K46.EQ.0) THEN MYID_ROOT=MYID-1 ELSE MYID_ROOT=MYID ENDIF IF (MYID_ROOT < root%NPROW*root%NPCOL) THEN root%MYROW = MYID_ROOT / root%NPCOL root%MYCOL = mod(MYID_ROOT, root%NPCOL) root%yes = .true. ELSE root%MYROW = -1 root%MYCOL = -1 root%yes = .FALSE. ENDIF ELSE root%yes = .FALSE. ENDIF #if ! defined(NOSCALAPACK) ELSE IF ( SLAVE ) THEN IF ( root%gridinit_done) THEN IF (root%yes) THEN CALL blacs_gridexit( root%CNTXT_BLACS ) root%gridinit_done = .FALSE. ENDIF END IF root%CNTXT_BLACS = COMM_ROOT CALL blacs_gridinit( root%CNTXT_BLACS, 'R', & root%NPROW, root%NPCOL ) root%gridinit_done = .TRUE. CALL blacs_gridinfo( root%CNTXT_BLACS, & NPROWtemp, NPCOLtemp, & root%MYROW, root%MYCOL ) IF ( root%MYROW .NE. -1 ) THEN root%yes = .true. ELSE root%yes = .false. END IF root%LPIV = 0 #endif ELSE root%yes = .FALSE. ENDIF RETURN END SUBROUTINE CMUMPS_INIT_ROOT_ANA SUBROUTINE CMUMPS_INIT_ROOT_FAC( N, MYID, root, & FILS, KEEP ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC IMPLICIT NONE TYPE ( MUMPS_ROOT_STRUC ):: root INTEGER, INTENT(IN) :: N, MYID, KEEP(500) INTEGER FILS( N ) INTEGER INODE, I LOGICAL INITIALIZE_RG2L INITIALIZE_RG2L = ( KEEP(38) .NE. 0 ) INITIALIZE_RG2L = .TRUE. IF ( INITIALIZE_RG2L ) THEN INODE = KEEP(38) I = 1 DO WHILE ( INODE .GT. 0 ) root%RG2L( INODE ) = I I = I + 1 INODE = FILS( INODE ) END DO ENDIF root%TOT_ROOT_SIZE=0 RETURN END SUBROUTINE CMUMPS_INIT_ROOT_FAC SUBROUTINE CMUMPS_DEF_GRID( NPROCS, NPROW, NPCOL, SIZE, K50 ) IMPLICIT NONE INTEGER NPROCS, NPROW, NPCOL, SIZE, K50 INTEGER NPROWtemp, NPCOLtemp, NPROCSused, FLATNESS LOGICAL KEEPIT IF ( K50 .EQ. 1 ) THEN FLATNESS = 2 ELSE FLATNESS = 3 ENDIF NPROW = int(sqrt(real(NPROCS))) NPROWtemp = NPROW NPCOL = int(NPROCS / NPROW) NPCOLtemp = NPCOL NPROCSused = NPROWtemp * NPCOLtemp 10 CONTINUE IF ( NPROWtemp >= NPCOLtemp/FLATNESS .AND. NPROWtemp > 1) THEN NPROWtemp = NPROWtemp - 1 NPCOLtemp = int(NPROCS / NPROWtemp) KEEPIT=.FALSE. IF ( NPROWtemp * NPCOLtemp .GE. NPROCSused ) THEN IF ( ( K50 .NE. 1 .AND. NPROWtemp >= NPCOLtemp/FLATNESS) & .OR. NPROWtemp * NPCOLtemp .GT. NPROCSused ) & KEEPIT=.TRUE. END IF IF ( KEEPIT ) THEN NPROW = NPROWtemp NPCOL = NPCOLtemp NPROCSused = NPROW * NPCOL END IF GO TO 10 END IF RETURN END SUBROUTINE CMUMPS_DEF_GRID SUBROUTINE CMUMPS_SCATTER_ROOT(MYID, M, N, ASEQ, & LOCAL_M, LOCAL_N, & MBLOCK, NBLOCK, & APAR, & MASTER_ROOT, & NPROW, NPCOL, & COMM) IMPLICIT NONE INTEGER MYID, MASTER_ROOT, COMM INTEGER M, N INTEGER NPROW, NPCOL INTEGER LOCAL_M, LOCAL_N INTEGER MBLOCK, NBLOCK COMPLEX APAR( LOCAL_M, LOCAL_N ) COMPLEX ASEQ( M, N ) INCLUDE 'mpif.h' INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, IDEST, IROW, ICOL INTEGER IBLOCK, JBLOCK, II, JJ, KK INTEGER IAPAR, JAPAR, IERR, allocok INTEGER :: STATUS(MPI_STATUS_SIZE) COMPLEX, DIMENSION(:), ALLOCATABLE :: WK LOGICAL JUPDATE ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of WK in ' & // 'routine CMUMPS_SCATTER_ROOT ' CALL MUMPS_ABORT() endif IAPAR = 1 JAPAR = 1 DO J = 1, N, NBLOCK SIZE_JBLOCK = NBLOCK IF ( J + NBLOCK > N ) THEN SIZE_JBLOCK = N - J + 1 END IF JUPDATE = .FALSE. DO I = 1, M, MBLOCK SIZE_IBLOCK = MBLOCK IF ( I + MBLOCK > M ) THEN SIZE_IBLOCK = M - I + 1 END IF IBLOCK = I / MBLOCK JBLOCK = J / NBLOCK IROW = mod ( IBLOCK, NPROW ) ICOL = mod ( JBLOCK, NPCOL ) IDEST = IROW * NPCOL + ICOL IF ( IDEST .NE. MASTER_ROOT ) THEN IF ( MYID .EQ. MASTER_ROOT ) THEN KK=1 DO JJ=J,J+SIZE_JBLOCK-1 DO II=I,I+SIZE_IBLOCK-1 WK(KK)=ASEQ(II,JJ) KK=KK+1 END DO END DO CALL MPI_SEND( WK, SIZE_IBLOCK*SIZE_JBLOCK, & MPI_COMPLEX, & IDEST, 128, COMM, IERR ) ELSE IF ( MYID .EQ. IDEST ) THEN CALL MPI_RECV( WK(1), & SIZE_IBLOCK*SIZE_JBLOCK, & MPI_COMPLEX, & MASTER_ROOT,128,COMM,STATUS,IERR) KK=1 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 APAR(II,JJ)=WK(KK) KK=KK+1 END DO END DO JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, & JAPAR:JAPAR+SIZE_JBLOCK-1 ) & = ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF END DO IF ( JUPDATE ) THEN IAPAR = 1 JAPAR = JAPAR + SIZE_JBLOCK END IF END DO DEALLOCATE(WK) RETURN END SUBROUTINE CMUMPS_SCATTER_ROOT SUBROUTINE CMUMPS_GATHER_ROOT(MYID, M, N, ASEQ, & LOCAL_M, LOCAL_N, & MBLOCK, NBLOCK, & APAR, & MASTER_ROOT, & NPROW, NPCOL, & COMM) IMPLICIT NONE INTEGER MYID, MASTER_ROOT, COMM INTEGER M, N INTEGER NPROW, NPCOL INTEGER LOCAL_M, LOCAL_N INTEGER MBLOCK, NBLOCK COMPLEX APAR( LOCAL_M, LOCAL_N ) COMPLEX ASEQ( M, N ) INCLUDE 'mpif.h' INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, ISOUR, IROW, ICOL INTEGER IBLOCK, JBLOCK, II, JJ, KK INTEGER IAPAR, JAPAR, IERR, allocok INTEGER :: STATUS(MPI_STATUS_SIZE) COMPLEX,DIMENSION(:), ALLOCATABLE :: WK LOGICAL JUPDATE ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of WK in ' & // 'routine CMUMPS_GATHER_ROOT ' CALL MUMPS_ABORT() endif IAPAR = 1 JAPAR = 1 DO J = 1, N, NBLOCK SIZE_JBLOCK = NBLOCK IF ( J + NBLOCK > N ) THEN SIZE_JBLOCK = N - J + 1 END IF JUPDATE = .FALSE. DO I = 1, M, MBLOCK SIZE_IBLOCK = MBLOCK IF ( I + MBLOCK > M ) THEN SIZE_IBLOCK = M - I + 1 END IF IBLOCK = I / MBLOCK JBLOCK = J / NBLOCK IROW = mod ( IBLOCK, NPROW ) ICOL = mod ( JBLOCK, NPCOL ) ISOUR = IROW * NPCOL + ICOL IF ( ISOUR .NE. MASTER_ROOT ) THEN IF ( MYID .EQ. MASTER_ROOT ) THEN CALL MPI_RECV( WK(1), SIZE_IBLOCK*SIZE_JBLOCK, & MPI_COMPLEX, & ISOUR, 128, COMM, STATUS, IERR ) KK=1 DO JJ=J,J+SIZE_JBLOCK-1 DO II=I,I+SIZE_IBLOCK-1 ASEQ(II,JJ)=WK(KK) KK=KK+1 END DO END DO ELSE IF ( MYID .EQ. ISOUR ) THEN KK=1 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 WK(KK)=APAR(II,JJ) KK=KK+1 END DO END DO CALL MPI_SEND( WK( 1 ), & SIZE_IBLOCK*SIZE_JBLOCK, & MPI_COMPLEX, & MASTER_ROOT,128,COMM,IERR) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) & = APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, & JAPAR:JAPAR+SIZE_JBLOCK-1 ) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF END DO IF ( JUPDATE ) THEN IAPAR = 1 JAPAR = JAPAR + SIZE_JBLOCK END IF END DO DEALLOCATE(WK) RETURN END SUBROUTINE CMUMPS_GATHER_ROOT SUBROUTINE CMUMPS_ROOT_ALLOC_STATIC(root, roota, IROOT, N, & IW, LIW, A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) TYPE (MUMPS_ROOT_STRUC ) :: root TYPE (CMUMPS_ROOT_STRUC ) :: roota INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER IROOT, LIW, N, IWPOS, IWPOSCB INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER ITLOC( N + KEEP(253) ) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER COMP, IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER FILS( N ), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER INTARR(KEEP8(27)) COMPLEX DBLARR(KEEP8(26)) INTEGER, EXTERNAL :: MUMPS_NUMROC COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER(8) :: LREQA_ROOT INTEGER LREQI_ROOT, LOCAL_M, LOCAL_N, allocok LOGICAL :: EARLYT3ROOTINS LOCAL_M = MUMPS_NUMROC( root%ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) LOCAL_M = max( 1, LOCAL_M ) LOCAL_N = MUMPS_NUMROC( root%ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) IF (KEEP(253).GT.0) THEN root%RHS_NLOC = MUMPS_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( roota%RHS_ROOT) ) & DEALLOCATE (roota%RHS_ROOT) ALLOCATE(roota%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 roota%RHS_ROOT = ZERO CALL CMUMPS_ASM_RHS_ROOT ( N, FILS, & root, roota, KEEP, KEEP8, RHS_MUMPS, & IFLAG, IERROR ) IF ( IFLAG .LT. 0 ) RETURN ENDIF IF (KEEP(60) .NE. 0) THEN PTRIST(STEP(IROOT)) = -6666666 ELSE LREQI_ROOT = 2 + KEEP(IXSZ) LREQA_ROOT = int(LOCAL_M,8) * int(LOCAL_N,8) IF (LREQA_ROOT.EQ.0_8) THEN PTRIST(STEP(IROOT)) = -9999999 RETURN ENDIF CALL CMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LREQI_ROOT, & LREQA_ROOT, IROOT, S_NOTFREE, .TRUE., COMP, & LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PTRIST ( STEP(IROOT) ) = IWPOSCB + 1 PAMASTER( STEP(IROOT) ) = IPTRLU + 1_8 IW( IWPOSCB + 1 + KEEP(IXSZ)) = - LOCAL_N IW( IWPOSCB + 2 + KEEP(IXSZ)) = LOCAL_M ENDIF EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) IF (LOCAL_N > 0 .AND. .NOT. EARLYT3ROOTINS ) THEN IF (KEEP(60) .EQ. 0) THEN CALL CMUMPS_SET_TO_ZERO(A(IPTRLU+1_8), LOCAL_M, & LOCAL_M, LOCAL_N, KEEP) ELSE CALL CMUMPS_SET_TO_ZERO(roota%SCHUR_POINTER(1), & root%SCHUR_LLD, LOCAL_M, LOCAL_N, KEEP) ENDIF IF (KEEP(55) .eq. 0) THEN IF (KEEP(60) .EQ. 0) THEN CALL CMUMPS_ASM_ARR_ROOT( N, root, roota, & IROOT, STEP(IROOT), & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N, & FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL CMUMPS_ASM_ARR_ROOT( N, root, roota, & IROOT, STEP(IROOT), & roota%SCHUR_POINTER(1), root%SCHUR_LLD, & LOCAL_M, LOCAL_N, & FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ENDIF ELSE IF (KEEP(60) .EQ. 0) THEN CALL CMUMPS_ASM_ELT_ROOT( N, root, roota, & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ELSE CALL CMUMPS_ASM_ELT_ROOT( N, root, roota, & roota%SCHUR_POINTER(1), root%SCHUR_LLD, & root%SCHUR_MLOC, root%SCHUR_NLOC, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_ROOT_ALLOC_STATIC SUBROUTINE CMUMPS_ASM_ELT_ROOT( N, root, roota, & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & INTARR, DBLARR, LINTARR, LDBLARR, & KEEP, KEEP8, & MYID) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER :: N, MYID, LOCAL_M, LOCAL_N, KEEP(500) INTEGER :: LOCAL_M_LLD INTEGER(8) KEEP8(150) COMPLEX VALROOT(LOCAL_M_LLD,LOCAL_N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER, INTENT(INOUT) :: INTARR(LINTARR) COMPLEX DBLARR(LDBLARR) INTEGER(8) :: J1, J2, K8, IPTR INTEGER :: IELT, I, J, IGLOB, SIZEI, IBEG INTEGER :: ARROW_ROOT INTEGER :: IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INTEGER :: ILOCROOT, JLOCROOT ARROW_ROOT = 0 DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1 IELT = FRTELT( IPTR ) J1 = PTRAIW(IELT) J2 = PTRAIW(IELT+1)-1 K8 = PTRARW(IELT) SIZEI=int(J2-J1)+1 DO J=1, SIZEI IGLOB = INTARR(J1+J-1) INTARR(J1+J-1) = root%RG2L(IGLOB) ENDDO DO J = 1, SIZEI IGLOB = INTARR(J1+J-1) IF ( KEEP(50).eq. 0 ) THEN IBEG = 1 ELSE IBEG = J END IF DO I = IBEG, SIZEI IF ( KEEP(50).eq.0 ) THEN IPOSROOT = INTARR(J1+I-1) JPOSROOT = INTARR(J1+J-1) ELSE IF ( INTARR(J1+I-1).GT. INTARR(J1+J-1) ) THEN IPOSROOT = INTARR(J1+I-1) JPOSROOT = INTARR(J1+J-1) ELSE IPOSROOT = INTARR(J1+J-1) JPOSROOT = INTARR(J1+I-1) END IF END IF IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, & root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, & root%NPCOL ) IF ( IROW_GRID.EQ.root%MYROW .AND. & JCOL_GRID.EQ.root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + DBLARR(K8) ENDIF K8 = K8 + 1_8 END DO END DO ARROW_ROOT = ARROW_ROOT + int(PTRARW(IELT+1_8)-PTRARW(IELT)) END DO KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE CMUMPS_ASM_ELT_ROOT SUBROUTINE CMUMPS_ASM_RHS_ROOT & ( N, FILS, root, roota, KEEP, KEEP8, RHS_MUMPS, & IFLAG, IERROR ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, KEEP(500), IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER FILS(N) TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota COMPLEX :: RHS_MUMPS(KEEP8(85)) 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( 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 roota%RHS_ROOT(ILOCRHS, JLOCRHS) = & RHS_MUMPS(INODE+(JCOL-1)*KEEP(254)) ENDDO 100 CONTINUE INODE=FILS(INODE) ENDDO RETURN END SUBROUTINE CMUMPS_ASM_RHS_ROOT SUBROUTINE CMUMPS_ASM_ARR_ROOT( N, root, roota, IROOT, STEP_IROOT, & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, LINTARR, LDBLARR, & MYID) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER :: N, MYID, IROOT, STEP_IROOT, LOCAL_M, LOCAL_N INTEGER :: LOCAL_M_LLD INTEGER FILS( N ) INTEGER :: KEEP(500) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) COMPLEX VALROOT(LOCAL_M_LLD,LOCAL_N) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER INTARR(LINTARR) COMPLEX DBLARR(LDBLARR) COMPLEX VAL INTEGER(8) :: JJ, J1,J2,J3, J4, AINPUT INTEGER IORG, NUMORG, & IROW, JCOL, IARR1 INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INTEGER ILOCROOT, JLOCROOT NUMORG = root%ROOT_SIZE IARR1=PTRDEBARR(STEP_IROOT) DO IORG = 1, NUMORG AINPUT = PTR8ARR(IARR1+IORG-1) J1 = AINPUT J2 = J1 + NINCOLARR(IARR1+IORG-1) J3 = J2 + 1 J4 = J2 + NINROWARR(IARR1+IORG-1) JCOL = INTARR(J1) DO JJ = J1, J2 IROW = INTARR(JJ) VAL = DBLARR(AINPUT) AINPUT = AINPUT + 1 IPOSROOT = root%RG2L( IROW ) JPOSROOT = root%RG2L( JCOL ) IROW_GRID = mod( ( IPOSROOT - 1 ) / root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 ) / root%NBLOCK, root%NPCOL ) IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + VAL END IF END DO IF (J3 .LE. J4) THEN IROW = INTARR(J1) DO JJ= J3,J4 JCOL = INTARR(JJ) VAL = DBLARR(AINPUT) AINPUT = AINPUT + 1 IPOSROOT = root%RG2L( IROW ) JPOSROOT = root%RG2L( JCOL ) IROW_GRID= mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW) JCOL_GRID= mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL) IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + VAL END IF END DO ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_ASM_ARR_ROOT MUMPS_5.8.1/src/sfac_scalings_simScale_util.F0000664000175000017500000013232315042446441021020 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, OSZ, & IWRK, IWSZ, INUMMY, NOMP_MAX ) !$ USE OMP_LIB C IMPLICIT NONE EXTERNAL SMUMPS_BUREDUCE INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM, NOMP_MAX INTEGER(8), INTENT(IN) :: NZ_loc INTEGER(8), INTENT(IN) :: IWSZ INTEGER, INTENT(IN) :: ISZ, OSZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C OUTPUT C IPARTVEC(I) = proc number with largest number of entries C in row/col I C INUMMY = number of local rows/columns with C at least one local entry (NUMPROCS .NE. 1 only) INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) INTEGER, INTENT(OUT) :: INUMMY C C INTERNAL WORKING ARRAY C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries C on my proc and in row/col I) for I=1,ISZ C (2*ISZ+1: 4*ISZ) is then set to C the processor with largest number of entries in its row/col C and its value (that is copied back into IPARTVEC(I) #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) #else INTEGER, INTENT(OUT) :: IWRK(IWSZ) #endif INCLUDE 'mpif.h' C C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER OP, IERROR INTEGER IR, IC !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK C !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = omp_get_max_threads() !$ CHUNK= max(K361/2, (ISZ+NOMP-1) / NOMP ) !$ ENDIF C INUMMY = 0 IF(NUMPROCS.NE.1) THEN C CHECK done outsize C IF(IWSZ < 4*ISZ) THEN C CHECK ENDS CALL MPI_OP_CREATE(SMUMPS_BUREDUCE, .TRUE., OP, IERROR) C PERFORM THE REDUCTION C WE FIRST ZERO OUT IF (NOMP_MAX.LE.0) THEN DO I=1,ISZ IWRK(2_8*int(I,8)-1_8) = 0 IWRK(2_8*int(I,8)) = MYID ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND.ISZ > K361 ) DO I=1,ISZ IWRK(2_8*int(I,8)-1_8) = 0 IWRK(2_8*int(I,8)) = MYID ENDDO !$OMP END PARALLEL DO ENDIF DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.ISZ).AND. & (IC.GE.1).AND.(IC.LE.OSZ)) THEN IWRK(2_8*int(IR,8)-1_8) = IWRK(2_8*int(IR,8)-1_8) + 1 ENDIF ENDDO CALL MUMPS_BIGALLREDUCE(.FALSE., IWRK(1), & IWRK(1_8+2_8*int(ISZ,8)), ISZ, & MPI_2INTEGER, OP, COMM, IERROR) C IF (NOMP_MAX.LE.0) THEN DO I=1,ISZ IPARTVEC(I) = IWRK(2_8*int(I,8)+2_8*int(ISZ,8)) C Compute INUMMY directly IF ( IPARTVEC(I) .EQ. MYID. OR. & IWRK(2_8*int(I,8)-1_8) .GT. 0 ) THEN INUMMY=INUMMY+1 ENDIF ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) !$OMP& REDUCTION(+:INUMMY) DO I=1,ISZ IPARTVEC(I) = IWRK(2_8*int(I,8)+2_8*int(ISZ,8)) C Compute INUMMY directly IF ( IPARTVEC(I) .EQ. MYID. OR. & IWRK(2_8*int(I,8)-1_8) .GT. 0 ) THEN INUMMY=INUMMY+1 ENDIF ENDDO !$OMP END PARALLEL DO ENDIF C FREE THE OPERATOR CALL MPI_OP_FREE(OP, IERROR) ELSE IF (NOMP_MAX.LE.0) THEN DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) DO I=1,ISZ IPARTVEC(I) = 0 ENDDO !$OMP END PARALLEL DO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_CREATEPARTVEC C C SEPARATOR: Another function begins C C SUBROUTINE SMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & MYROWINDICES, INUMMYR, & MYCOLINDICES, INUMMYC, & IWRK, IWSZ, NOMP_MAX ) !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: NZ_loc, IWSZ INTEGER MYID, NUMPROCS, M, N, NOMP_MAX INTEGER INUMMYR, INUMMYC INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER ROWPARTVEC(M) INTEGER COLPARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER MYCOLINDICES(INUMMYC) INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC, ITMP INTEGER(8) :: I8 C INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP=omp_get_max_threads() C note that M=N !$ CHUNK= max(K361/2, (M+NOMP-1) / NOMP ) !$ ENDIF C C MARK MY ROWS. IF (NOMP_MAX.LE.0) THEN DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( M > K361 .AND. NOMP .GT. 1) DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO !$OMP END PARALLEL DO ENDIF CTEMP !$OMP PARALLEL DO PRIVATE(I8,IR,IC) SCHEDULE(STATIC,CHUNK) CTEMP !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) DO I8=1,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 ENDIF ENDDO CTEMP !$OMP END PARALLEL DO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,M IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C C C DO THE SMAME THING FOR COLS IF (NOMP_MAX.LE.0) THEN DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 ENDDO !$OMP END PARALLEL DO ENDIF C CTEMP !$OMP PARALLEL DO PRIVATE(I8,IR,IC) SCHEDULE(STATIC,CHUNK) CTEMP !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) DO I8=1,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IC) .EQ. 0) IWRK(IC)= 1 ENDIF ENDDO CTEMP !$OMP END PARALLEL DO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYCOLINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C RETURN END SUBROUTINE SMUMPS_FILLMYROWCOLINDICES C C SEPARATOR: Another function begins C C INTEGER FUNCTION SMUMPS_CHK1LOC(D, DSZ, INDX, INDXSZ, EPS) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) INTEGER INDX(INDXSZ) REAL EPS C LOCAL VARS INTEGER I, IID REAL RONE PARAMETER(RONE=1.0E0) SMUMPS_CHK1LOC = 1 DO I=1, INDXSZ IID = INDX(I) IF (.NOT.( (D(IID).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(IID)) )) THEN SMUMPS_CHK1LOC = 0 ENDIF ENDDO RETURN END FUNCTION SMUMPS_CHK1LOC INTEGER FUNCTION SMUMPS_CHK1CONV(D, DSZ, EPS) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL EPS C LOCAL VARS INTEGER I REAL RONE PARAMETER(RONE=1.0E0) SMUMPS_CHK1CONV = 1 DO I=1, DSZ IF (.NOT.( (D(I).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(I)) )) THEN SMUMPS_CHK1CONV = 0 ENDIF ENDDO RETURN END FUNCTION SMUMPS_CHK1CONV C C SEPARATOR: Another function begins C INTEGER FUNCTION SMUMPS_CHKCONVGLO(DR, M, INDXR, INDXRSZ, & DC, N, INDXC, INDXCSZ, EPS, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER M, N, INDXRSZ, INDXCSZ REAL DR(M), DC(N) INTEGER INDXR(INDXRSZ), INDXC(INDXCSZ) REAL EPS INTEGER COMM EXTERNAL SMUMPS_CHK1LOC INTEGER SMUMPS_CHK1LOC INTEGER GLORES, MYRESR, MYRESC, MYRES INTEGER IERR MYRESR = SMUMPS_CHK1LOC(DR, M, INDXR, INDXRSZ, EPS) MYRESC = SMUMPS_CHK1LOC(DC, N, INDXC, INDXCSZ, EPS) MYRES = MYRESR + MYRESC CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) SMUMPS_CHKCONVGLO = GLORES RETURN END FUNCTION SMUMPS_CHKCONVGLO C C SEPARATOR: Another function begins C REAL FUNCTION SMUMPS_ERRSCALOC(D, TMPD, DSZ, & INDX, INDXSZ, NOMP_MAX) !$ USE OMP_LIB C THE VAR D IS NOT USED IN COMPUTATIONS. C IT IS THERE FOR READIBLITY OF THE *simScaleAbs.F IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, INDXSZ, NOMP_MAX REAL D(DSZ) REAL TMPD(DSZ) INTEGER INDX(INDXSZ) C LOCAL VARS REAL RONE PARAMETER(RONE=1.0E0) INTEGER I, IIND REAL ERRMAX INTRINSIC abs !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK ERRMAX = -RONE !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,INDXSZ IIND = INDX(I) IF(abs(RONE-TMPD(IIND)).GT.ERRMAX) THEN ERRMAX = abs(RONE-TMPD(IIND)) ENDIF ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I,IIND) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1 .AND. INDXSZ > K361 ) !$OMP& REDUCTION(max:ERRMAX) DO I=1,INDXSZ IIND = INDX(I) IF(abs(RONE-TMPD(IIND)).GT.ERRMAX) THEN ERRMAX = abs(RONE-TMPD(IIND)) ENDIF ENDDO !$OMP END PARALLEL DO ENDIF SMUMPS_ERRSCALOC = ERRMAX RETURN END FUNCTION SMUMPS_ERRSCALOC REAL FUNCTION SMUMPS_ERRSCA1(D, TMPD, DSZ, NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, NOMP_MAX REAL D(DSZ) REAL TMPD(DSZ) C LOCAL VARS REAL RONE PARAMETER(RONE=1.0E0) INTEGER I REAL ERRMAX1 INTRINSIC abs !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK ERRMAX1 = -RONE !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (DSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,DSZ IF(abs(RONE-TMPD(I)).GT.ERRMAX1) THEN ERRMAX1 = abs(RONE-TMPD(I)) ENDIF ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND.DSZ > K361 ) !$OMP& REDUCTION(max:ERRMAX1) DO I=1,DSZ IF(abs(RONE-TMPD(I)).GT.ERRMAX1) THEN ERRMAX1 = abs(RONE-TMPD(I)) ENDIF ENDDO !$OMP END PARALLEL DO ENDIF SMUMPS_ERRSCA1 = ERRMAX1 RETURN END FUNCTION SMUMPS_ERRSCA1 C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_UPDATESCALE(D, TMPD, DSZ, & INDX, INDXSZ, NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(in) :: DSZ, INDXSZ, NOMP_MAX REAL D(DSZ) REAL TMPD(DSZ) INTEGER INDX(INDXSZ) INTRINSIC sqrt C LOCAL VARS INTEGER I, IIND REAL RZERO PARAMETER(RZERO=0.0E0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,INDXSZ IIND = INDX(I) IF (TMPD(IIND).NE.RZERO) D(IIND)=D(IIND)/sqrt(TMPD(IIND)) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I,IIND) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. INDXSZ> K361 ) DO I=1,INDXSZ IIND = INDX(I) IF (TMPD(IIND).NE.RZERO) D(IIND)=D(IIND)/sqrt(TMPD(IIND)) ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE SMUMPS_UPDATESCALE C SUBROUTINE SMUMPS_UPSCALE1(D, TMPD, DSZ, NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, NOMP_MAX REAL D(DSZ) REAL TMPD(DSZ) INTRINSIC sqrt C LOCAL VARS INTEGER I REAL RZERO PARAMETER(RZERO=0.0E0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (DSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,DSZ IF (TMPD(I) .NE. RZERO) D(I) = D(I)/sqrt(TMPD(I)) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. DSZ> K361 ) DO I=1,DSZ IF (TMPD(I) .NE. RZERO) D(I) = D(I)/sqrt(TMPD(I)) ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE SMUMPS_UPSCALE1 C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_INITREALLST(D, DSZ, INDX, INDXSZ, VAL, & NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, INDXSZ, NOMP_MAX REAL D(DSZ) INTEGER INDX(INDXSZ) REAL VAL C LOCAL VARS INTEGER I, IIND !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,INDXSZ IIND = INDX(I) D(IIND) = VAL ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I,IIND) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. INDXSZ > K361 ) DO I=1,INDXSZ IIND = INDX(I) D(IIND) = VAL ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE SMUMPS_INITREALLST C C SEPARATOR: Another function begins C C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_INITREAL(D, DSZ, VAL, NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, NOMP_MAX REAL D(DSZ) REAL VAL C LOCAL VARS INTEGER I !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = omp_get_max_threads() !$ CHUNK= max(K361/2, (DSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,DSZ D(I) = VAL ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND.DSZ > K361 ) DO I=1,DSZ D(I) = VAL ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE SMUMPS_INITREAL C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_REDUCE_WRK(WRK, N, WRK_TH, NOMP_MAX) C Called only when NOMP_MAX>0 !$ USE OMP_LIB IMPLICIT NONE INTEGER N,NOMP_MAX REAL WRK(N), WRK_TH(N,NOMP_MAX) C LOCAL VAR INTEGER I, IOMP REAL DZERO PARAMETER(DZERO=0.0E0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (N+NOMP-1) / NOMP ) !$OMP PARALLEL DO PRIVATE(I,IOMP) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. N > K361 ) DO I=1,N WRK(I) = DZERO DO IOMP=1,NOMP_MAX WRK(I) = WRK_TH(I,IOMP) + WRK(I) ENDDO ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE SMUMPS_REDUCE_WRK SUBROUTINE SMUMPS_REDUCE_WRK_MPI(WRK, N, WRK_TH, NOMP_MAX, & INDX, INDXSZ) C Called only when NOMP_MAX>0 !$ USE OMP_LIB IMPLICIT NONE INTEGER N,NOMP_MAX,INDXSZ REAL WRK(N), WRK_TH(N,NOMP_MAX) INTEGER INDX(INDXSZ) C LOCAL VAR INTEGER I, J, IOMP REAL DZERO PARAMETER(DZERO=0.0E0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$OMP PARALLEL DO PRIVATE(I,J,IOMP) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. INDXSZ > K361 ) DO I=1,INDXSZ J = INDX(I) WRK(J) = DZERO DO IOMP=1,NOMP_MAX WRK(J) = WRK_TH(J,IOMP) + WRK(J) ENDDO ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE SMUMPS_REDUCE_WRK_MPI SUBROUTINE SMUMPS_ZEROOUT(TMPD, TMPSZ, INDX, INDXSZ, & NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: TMPSZ,INDXSZ, NOMP_MAX REAL TMPD(TMPSZ) INTEGER INDX(INDXSZ) C LOCAL VAR INTEGER I REAL DZERO PARAMETER(DZERO=0.0E0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,INDXSZ TMPD(INDX(I)) = DZERO ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. INDXSZ > K361 ) DO I=1,INDXSZ TMPD(INDX(I)) = DZERO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE SMUMPS_ZEROOUT C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_BUREDUCE(INV, INOUTV, LEN, DTYPE) C C Like MPI_MINLOC operation (with ties broken sometimes with min C and sometimes with max) C The objective is find for each entry row/col C the processor with largest number of entries in its row/col C When 2 procs have the same number of entries in the row/col C then C if this number of entries is odd we take the proc with largest id C if this number of entries is even we take the proc with smallest id C IMPLICIT NONE #if defined(WORKAROUNDINTELILP64MPI2INTEGER) || defined(WORKAROUNDILP64MPICUSTOMREDUCE) INTEGER(4) :: LEN INTEGER(4) :: INV(2*LEN) INTEGER(4) :: INOUTV(2*LEN) INTEGER(4) :: DTYPE #else INTEGER :: LEN INTEGER :: INV(2*LEN) INTEGER :: INOUTV(2*LEN) INTEGER :: DTYPE #endif INTEGER I #if defined(WORKAROUNDINTELILP64MPI2INTEGER) || defined(WORKAROUNDILP64MPICUSTOMREDUCE) INTEGER(4) DIN, DINOUT, PIN, PINOUT #else INTEGER DIN, DINOUT, PIN, PINOUT #endif DO I=1,2*LEN-1,2 DIN = INV(I) ! nb of entries in row/col PIN = INV(I+1) ! proc number C DINOUT DINOUT = INOUTV(I) PINOUT = INOUTV(I+1) IF (DINOUT < DIN) THEN INOUTV(I) = DIN INOUTV(I+1) = PIN ELSE IF (DINOUT == DIN) THEN C --INOUTV(I) = DIN C --even number I take smallest Process number (pin) IF ((mod(DINOUT,2).EQ.0).AND.(PINPINOUT)) THEN C --odd number I take largest Process number (pin) INOUTV(I+1) = PIN ENDIF ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_BUREDUCE C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_IBUINIT(IW, IWSZ, IVAL) IMPLICIT NONE INTEGER(8) :: IWSZ #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) IW(IWSZ) INTEGER(4) IVAL #else INTEGER IW(IWSZ) INTEGER IVAL #endif INTEGER(8) :: I DO I=1_8,IWSZ IW(I)=IVAL ENDDO RETURN END SUBROUTINE SMUMPS_IBUINIT C C SEPARATOR: Another function begins C C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX,ISNDRCVNUM,ISNDRCVVOL, & OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER(8), INTENT(IN) :: IWRKSZ INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ, OSZ INTEGER, INTENT(IN) :: COMM C When INDX holds row indices O(ther)INDX holds col indices INTEGER, INTENT(IN) :: INDX(NZ_loc) INTEGER, INTENT(IN) :: OINDX(NZ_loc) C On entry IPARTVEC(I) holds proc number with largest number of entries C in row/col I INTEGER, INTENT(IN) :: IPARTVEC(ISZ) C C OUTPUT PARAMETERS C SNDSZ (IPROC+1) is set to the number of rows (or col) that C MYID will have to send to IPROC C RCVSZ(IPROC+1) is set to the nb of row/cols that C MYID will receive from IPROC INTEGER, INTENT(OUT) :: SNDSZ(NUMPROCS) INTEGER, INTENT(OUT) :: RCVSZ(NUMPROCS) C OSNDRCVNUM is set to the total number of procs C destination of messages from MYID (< NUMPROCS) C ISNDRCVNUM is set to the total number procs C that will send messages to MYID (< NUMPROCS) C ISNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C OSNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C Knowing that for each row the process with the largest C number of entries will centralize all indices then C ISNDRCVVOL and OSNDRCVVOL are bounded by N INTEGER, INTENT(OUT) :: ISNDRCVNUM, OSNDRCVNUM INTEGER, INTENT(OUT) :: ISNDRCVVOL, OSNDRCVVOL C C INTERNAL WORKING ARRAY INTEGER IWRK(IWRKSZ) INCLUDE 'mpif.h' C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER IIND, IIND2, PIND INTEGER IERROR C check done outsize C IF(ISZ>IWRKSZ) THEN ERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,max(ISZ,OSZ) IWRK(I) = 0 ENDDO C C set SNDSZ DO I8=1,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. & (IIND2.GE.1).AND.(IIND2.LE.OSZ))THEN PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN C MYID will send row/col IIND to proc PIND C (PIND has the largest nb of entries in row/col IIND IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO C C use SNDSZ to set RCVSZ CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) C C compute number of procs destinations of messages from MYID C number of row/col sent by MYID. ISNDRCVNUM = 0 ISNDRCVVOL = 0 OSNDRCVNUM = 0 OSNDRCVVOL = 0 DO I=1, NUMPROCS IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) ENDDO RETURN END SUBROUTINE SMUMPS_NUMVOLSNDRCV C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_SETUPCOMMS(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX, & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, & SNDSZ, RCVSZ, IWRK, & ISTATUS, REQUESTS, & ITAGCOMM, COMM ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER ISNDVOL, OSNDVOL INTEGER MYID, NUMPROCS, ISZ, OSZ C ISZ is either M or N INTEGER INDX(NZ_loc) INTEGER OINDX(NZ_loc) C INDX is either IRN_loc or JCN_col INTEGER IPARTVEC(ISZ) C IPARTVEC is either rowpartvec or colpartvec INTEGER :: ISNDRCVNUM INTEGER INGHBPRCS(ISNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1) INTEGER ISNDRCVJA(ISNDVOL) INTEGER OSNDRCVNUM INTEGER ONGHBPRCS(OSNDRCVNUM) INTEGER OSNDRCVIA(NUMPROCS+1) INTEGER OSNDRCVJA(OSNDVOL) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INTEGER IWRK(ISZ) INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) INTEGER REQUESTS(ISNDRCVNUM) INTEGER ITAGCOMM, COMM C LOCAL VARS INTEGER I, IIND, IIND2, IPID, OFFS INTEGER IWHERETO, POFFS, ITMP, IERROR INTEGER(8) :: I8 C COMPUATIONs START DO I=1,ISZ IWRK(I) = 0 ENDDO C INITIALIZE ONGHBPRCS using SNDSZ C INITIALIZE THE OSNDRCVIA using SNDSZ OFFS = 1 POFFS = 1 DO I=1,NUMPROCS OSNDRCVIA(I) = OFFS + SNDSZ(I) IF(SNDSZ(I) > 0) THEN ONGHBPRCS(POFFS)=I POFFS = POFFS + 1 ENDIF OFFS = OFFS + SNDSZ(I) ENDDO OSNDRCVIA(NUMPROCS+1) = OFFS C CHECK STARTS C check done outsize C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) DO I8=1,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. & (IIND2.GE.1).AND.(IIND2.LE.OSZ) ) THEN IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF ENDIF ENDDO C FILLED UP, WHAT I WILL RECEIVE (My requests from others) C FILL UP ISNDRCVJA. It will be received to fill up CALL MPI_BARRIER(COMM,IERROR) OFFS = 1 POFFS = 1 ISNDRCVIA(1) = 1 DO I=2,NUMPROCS+1 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) IF(RCVSZ(I-1) > 0) THEN INGHBPRCS(POFFS)=I-1 POFFS = POFFS + 1 ENDIF OFFS = OFFS + RCVSZ(I-1) ENDDO CALL MPI_BARRIER(COMM,IERROR) DO I=1, ISNDRCVNUM IPID = INGHBPRCS(I) OFFS = ISNDRCVIA(IPID) ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, & ITAGCOMM, COMM, REQUESTS(I),IERROR) ENDDO DO I=1,OSNDRCVNUM IPID = ONGHBPRCS(I) OFFS = OSNDRCVIA(IPID) ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, & ITAGCOMM, COMM,IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF CALL MPI_BARRIER(COMM,IERROR) RETURN END SUBROUTINE SMUMPS_SETUPCOMMS C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_DOCOMMINF(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, & ISNDRCVNUM, INGHBPRCS, & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, & OSNDRCVNUM, ONGHBPRCS, & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, & ISTATUS, REQUESTS, & COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL REAL TMPD(IDSZ) INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) REAL ISNDRCVA(ISNDRCVVOL) INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) REAL OSNDRCVA(OSNDRCVVOL) INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER COMM, IERROR C LOCAL VARS INTEGER I, PID, OFFS, SZ, J, JS, JE, IID DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, & MPI_REAL, PID-1, & ITAGCOMM,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS, JE IID = OSNDRCVJA(J) OSNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_REAL, PID-1, & ITAGCOMM, COMM, IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF C FOLD INTO MY D DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1)-1 DO J=JS,JE IID = ISNDRCVJA(J) IF(TMPD(IID) < ISNDRCVA(J)) TMPD(IID)= ISNDRCVA(J) ENDDO ENDDO C COMMUNICATE THE UPDATED ONES DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, & MPI_REAL, PID-1, & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1) -1 DO J=JS, JE IID = ISNDRCVJA(J) ISNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_REAL, PID-1, & ITAGCOMM+1, COMM, IERROR) ENDDO IF(OSNDRCVNUM > 0) THEN CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS,JE IID = OSNDRCVJA(J) TMPD(IID)=OSNDRCVA(J) ENDDO ENDDO RETURN END SUBROUTINE SMUMPS_DOCOMMINF C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_DOCOMM1N(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, & ISNDRCVNUM, INGHBPRCS, & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, & OSNDRCVNUM, ONGHBPRCS, & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, & ISTATUS, REQUESTS, & COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL REAL TMPD(IDSZ) INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) REAL ISNDRCVA(ISNDRCVVOL) INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) REAL OSNDRCVA(OSNDRCVVOL) INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER COMM, IERROR C LOCAL VARS INTEGER I, PID, OFFS, SZ, J, JS, JE, IID DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, & MPI_REAL, PID-1, & ITAGCOMM,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS, JE IID = OSNDRCVJA(J) OSNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_REAL, PID-1, & ITAGCOMM, COMM, IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF C FOLD INTO MY D DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1)-1 DO J=JS,JE IID = ISNDRCVJA(J) TMPD(IID) = TMPD(IID)+ ISNDRCVA(J) ENDDO ENDDO C COMMUNICATE THE UPDATED ONES DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, & MPI_REAL, PID-1, & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1) -1 DO J=JS, JE IID = ISNDRCVJA(J) ISNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_REAL, PID-1, & ITAGCOMM+1, COMM, IERROR) ENDDO IF(OSNDRCVNUM > 0) THEN CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS,JE IID = OSNDRCVJA(J) TMPD(IID)=OSNDRCVA(J) ENDDO ENDDO RETURN END SUBROUTINE SMUMPS_DOCOMM1N SUBROUTINE SMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, & IWRK, IWSZ, INUMMY) !$ USE OMP_LIB IMPLICIT NONE EXTERNAL SMUMPS_BUREDUCE INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM INTEGER(8) :: NZ_loc, IWSZ INTEGER, INTENT(IN) :: ISZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C C OUTPUT C IPARTVEC(I) = proc number with largest number of entries C in row/col I C INUMMY = number of local rows/columns with C at least one local entry (NUMPROCS .NE. 1 only) INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) INTEGER, INTENT(OUT) :: INUMMY C C INTERNAL WORKING ARRAY C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries C on my proc and in row/col I) for I=1,ISZ C (2*ISZ+1: 4*ISZ) is then set to C the processor with largest number of entries in its row/col C and its value (that is copied back into IPARTVEC(I) #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) #else INTEGER, INTENT(OUT) :: IWRK(IWSZ) #endif INCLUDE 'mpif.h' C C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER OP, IERROR INTEGER IR, IC INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK C INUMMY = 0 !$ NOMP=omp_get_max_threads() !$ CHUNK= max(K361/2, (ISZ+NOMP-1) / NOMP ) IF(NUMPROCS.NE.1) THEN C CHECK done outsize C IF(IWSZ < 2*ISZ) THEN C CHECK ENDS CALL MPI_OP_CREATE(SMUMPS_BUREDUCE, .TRUE., OP, IERROR) C PERFORM THE REDUCTION !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) DO I=1,ISZ IWRK(2_8*int(I,8)-1_8) = 0 IWRK(2_8*int(I,8)) = MYID ENDDO !$OMP END PARALLEL DO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.ISZ).AND. & (IC.GE.1).AND.(IC.LE.ISZ)) THEN IWRK(2_8*int(IR,8)-1_8) = IWRK(2_8*int(IR,8)-1_8) + 1 IWRK(2_8*int(IC,8)-1_8) = IWRK(2_8*int(IC,8)-1_8) + 1 ENDIF ENDDO CALL MUMPS_BIGALLREDUCE(.FALSE., & IWRK(1), IWRK(1_8+2_8*int(ISZ,8)), ISZ, & MPI_2INTEGER, OP, COMM, IERROR) C CHUNK computed in previous // do !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) !$OMP& REDUCTION(+:INUMMY) DO I=1,ISZ IPARTVEC(I) = IWRK(2_8*int(I,8)+2_8*int(ISZ,8)) C Compute INUMMY directly IF ( IPARTVEC(I) .EQ. MYID. OR. & IWRK(2_8*int(I,8)-1_8) .GT. 0 ) THEN INUMMY=INUMMY+1 ENDIF ENDDO !$OMP END PARALLEL DO C FREE THE OPERATOR CALL MPI_OP_FREE(OP, IERROR) ELSE !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_CREATEPARTVECSYM SUBROUTINE SMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX,OINDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER(8), INTENT(IN) :: IWRKSZ INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ INTEGER, INTENT(IN) :: INDX(NZ_loc), OINDX(NZ_loc) INTEGER, INTENT(IN) :: IPARTVEC(ISZ) INTEGER, INTENT(IN) :: COMM C C OUTPUT PARAMETERS C SNDSZ (IPROC+1) is set to the number of rows (or col) that C MYID will have to send to IPROC C RCVSZ(IPROC+1) is set to the nb of row/cols that C MYID will receive from IPROC INTEGER :: SNDSZ(NUMPROCS) INTEGER :: RCVSZ(NUMPROCS) C OSNDRCVNUM is set to the total number of procs C destination of messages from MYID (< NUMPROCS) C ISNDRCVNUM is set to the total number procs C that will send messages to MYID (< NUMPROCS) C ISNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C OSNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C Knowing that for each row the process with the largest C number of entries will centralize all indices then C ISNDRCVVOL and OSNDRCVVOL are bounded by N INTEGER, INTENT(OUT) :: ISNDRCVNUM, ISNDRCVVOL INTEGER, INTENT(OUT) :: OSNDRCVNUM, OSNDRCVVOL C C INTERNAL WORKING ARRAY INTEGER, INTENT(OUT) :: IWRK(IWRKSZ) INCLUDE 'mpif.h' C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER IIND, IIND2, PIND INTEGER IERROR C check done outsize C IF(ISZ>IWRKSZ) THEN ERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,ISZ IWRK(I) = 0 ENDDO C C set SNDSZ DO I8=1_8,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) & .AND.(IIND2.LE.ISZ)) THEN PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN C MYID will send row/col IIND to proc PIND C (PIND has the largest nb of entries in row/col IIND IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF IIND = OINDX(I8) PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO C C use SNDSZ to set RCVSZ CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) C C compute number of procs destinations of messages from MYID C number of row/col sent by MYID. ISNDRCVNUM = 0 ISNDRCVVOL = 0 OSNDRCVNUM = 0 OSNDRCVVOL = 0 DO I=1, NUMPROCS IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) ENDDO RETURN END SUBROUTINE SMUMPS_NUMVOLSNDRCVSYM INTEGER FUNCTION SMUMPS_CHKCONVGLOSYM(D, N, INDXR, INDXRSZ, & EPS, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER N, INDXRSZ REAL D(N) INTEGER INDXR(INDXRSZ) REAL EPS INTEGER COMM EXTERNAL SMUMPS_CHK1LOC INTEGER SMUMPS_CHK1LOC INTEGER GLORES, MYRESR, MYRES INTEGER IERR MYRESR = SMUMPS_CHK1LOC(D, N, INDXR, INDXRSZ, EPS) MYRES = 2*MYRESR CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) SMUMPS_CHKCONVGLOSYM = GLORES RETURN END FUNCTION SMUMPS_CHKCONVGLOSYM SUBROUTINE SMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & MYROWINDICES, INUMMYR, & IWRK, IWSZ, NOMP_MAX ) !$ USE OMP_LIB IMPLICIT NONE INTEGER MYID, NUMPROCS, N, NOMP_MAX INTEGER(8) :: NZ_loc, IWSZ INTEGER INUMMYR INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC, ITMP INTEGER(8) :: I8 INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP=omp_get_max_threads() !$ CHUNK= max(K361/2, (N+NOMP-1) / NOMP ) !$ ENDIF C C MARK MY ROWS. IF (NOMP_MAX.LE.0) THEN DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO !$OMP END PARALLEL DO ENDIF C DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 IF(IWRK(IC) .EQ.0) IWRK(IC)=1 ENDIF ENDDO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C C C THE SMAME THING APPLY TO COLS C RETURN END SUBROUTINE SMUMPS_FILLMYROWCOLINDICESSYM SUBROUTINE SMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OINDX, & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, & SNDSZ, RCVSZ, IWRK, & ISTATUS, REQUESTS, & ITAGCOMM, COMM ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, ISZ, ISNDVOL, OSNDVOL INTEGER(8) :: NZ_loc C ISZ is either M or N INTEGER INDX(NZ_loc), OINDX(NZ_loc) C INDX is either IRN_loc or JCN_col INTEGER IPARTVEC(ISZ) C IPARTVEC is either rowpartvec or colpartvec INTEGER ISNDRCVNUM, INGHBPRCS(ISNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1) INTEGER ISNDRCVJA(ISNDVOL) INTEGER OSNDRCVNUM, ONGHBPRCS(OSNDRCVNUM) INTEGER OSNDRCVIA(NUMPROCS+1) INTEGER OSNDRCVJA(OSNDVOL) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INTEGER IWRK(ISZ) INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) INTEGER REQUESTS(ISNDRCVNUM) INTEGER ITAGCOMM, COMM C LOCAL VARS INTEGER I, IIND,IIND2,IPID,OFFS,IWHERETO,POFFS, ITMP, IERROR INTEGER(8) :: I8 C COMPUATIONs START DO I=1,ISZ IWRK(I) = 0 ENDDO C INITIALIZE ONGHBPRCS using SNDSZ C INITIALIZE THE OSNDRCVIA using SNDSZ OFFS = 1 POFFS = 1 DO I=1,NUMPROCS OSNDRCVIA(I) = OFFS + SNDSZ(I) IF(SNDSZ(I) > 0) THEN ONGHBPRCS(POFFS)=I POFFS = POFFS + 1 ENDIF OFFS = OFFS + SNDSZ(I) ENDDO OSNDRCVIA(NUMPROCS+1) = OFFS C CHECK STARTS C check done outsize C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) DO I8=1_8,NZ_loc IIND=INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) & .AND.(IIND2.LE.ISZ)) THEN IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF IIND = OINDX(I8) IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF ENDIF ENDDO C FILLED UP, WHAT I WILL RECEIVE (My requests from others) C FILL UP ISNDRCVJA. It will be received to fill up CALL MPI_BARRIER(COMM,IERROR) OFFS = 1 POFFS = 1 ISNDRCVIA(1) = 1 DO I=2,NUMPROCS+1 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) IF(RCVSZ(I-1) > 0) THEN INGHBPRCS(POFFS)=I-1 POFFS = POFFS + 1 ENDIF OFFS = OFFS + RCVSZ(I-1) ENDDO CALL MPI_BARRIER(COMM,IERROR) DO I=1, ISNDRCVNUM IPID = INGHBPRCS(I) OFFS = ISNDRCVIA(IPID) ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, & ITAGCOMM, COMM, REQUESTS(I),IERROR) ENDDO DO I=1,OSNDRCVNUM IPID = ONGHBPRCS(I) OFFS = OSNDRCVIA(IPID) ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, & ITAGCOMM, COMM,IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF CALL MPI_BARRIER(COMM,IERROR) RETURN END SUBROUTINE SMUMPS_SETUPCOMMSSYM MUMPS_5.8.1/src/zfac_scalings_simScale_util.F0000664000175000017500000013345315042446442021035 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, OSZ, & IWRK, IWSZ, INUMMY, NOMP_MAX ) !$ USE OMP_LIB C IMPLICIT NONE EXTERNAL ZMUMPS_BUREDUCE INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM, NOMP_MAX INTEGER(8), INTENT(IN) :: NZ_loc INTEGER(8), INTENT(IN) :: IWSZ INTEGER, INTENT(IN) :: ISZ, OSZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C OUTPUT C IPARTVEC(I) = proc number with largest number of entries C in row/col I C INUMMY = number of local rows/columns with C at least one local entry (NUMPROCS .NE. 1 only) INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) INTEGER, INTENT(OUT) :: INUMMY C C INTERNAL WORKING ARRAY C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries C on my proc and in row/col I) for I=1,ISZ C (2*ISZ+1: 4*ISZ) is then set to C the processor with largest number of entries in its row/col C and its value (that is copied back into IPARTVEC(I) #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) #else INTEGER, INTENT(OUT) :: IWRK(IWSZ) #endif INCLUDE 'mpif.h' C C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER OP, IERROR INTEGER IR, IC !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK C !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = omp_get_max_threads() !$ CHUNK= max(K361/2, (ISZ+NOMP-1) / NOMP ) !$ ENDIF C INUMMY = 0 IF(NUMPROCS.NE.1) THEN C CHECK done outsize C IF(IWSZ < 4*ISZ) THEN C CHECK ENDS CALL MPI_OP_CREATE(ZMUMPS_BUREDUCE, .TRUE., OP, IERROR) C PERFORM THE REDUCTION C WE FIRST ZERO OUT IF (NOMP_MAX.LE.0) THEN DO I=1,ISZ IWRK(2_8*int(I,8)-1_8) = 0 IWRK(2_8*int(I,8)) = MYID ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND.ISZ > K361 ) DO I=1,ISZ IWRK(2_8*int(I,8)-1_8) = 0 IWRK(2_8*int(I,8)) = MYID ENDDO !$OMP END PARALLEL DO ENDIF DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.ISZ).AND. & (IC.GE.1).AND.(IC.LE.OSZ)) THEN IWRK(2_8*int(IR,8)-1_8) = IWRK(2_8*int(IR,8)-1_8) + 1 ENDIF ENDDO CALL MUMPS_BIGALLREDUCE(.FALSE., IWRK(1), & IWRK(1_8+2_8*int(ISZ,8)), ISZ, & MPI_2INTEGER, OP, COMM, IERROR) C IF (NOMP_MAX.LE.0) THEN DO I=1,ISZ IPARTVEC(I) = IWRK(2_8*int(I,8)+2_8*int(ISZ,8)) C Compute INUMMY directly IF ( IPARTVEC(I) .EQ. MYID. OR. & IWRK(2_8*int(I,8)-1_8) .GT. 0 ) THEN INUMMY=INUMMY+1 ENDIF ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) !$OMP& REDUCTION(+:INUMMY) DO I=1,ISZ IPARTVEC(I) = IWRK(2_8*int(I,8)+2_8*int(ISZ,8)) C Compute INUMMY directly IF ( IPARTVEC(I) .EQ. MYID. OR. & IWRK(2_8*int(I,8)-1_8) .GT. 0 ) THEN INUMMY=INUMMY+1 ENDIF ENDDO !$OMP END PARALLEL DO ENDIF C FREE THE OPERATOR CALL MPI_OP_FREE(OP, IERROR) ELSE IF (NOMP_MAX.LE.0) THEN DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) DO I=1,ISZ IPARTVEC(I) = 0 ENDDO !$OMP END PARALLEL DO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_CREATEPARTVEC C C SEPARATOR: Another function begins C C SUBROUTINE ZMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & MYROWINDICES, INUMMYR, & MYCOLINDICES, INUMMYC, & IWRK, IWSZ, NOMP_MAX ) !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: NZ_loc, IWSZ INTEGER MYID, NUMPROCS, M, N, NOMP_MAX INTEGER INUMMYR, INUMMYC INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER ROWPARTVEC(M) INTEGER COLPARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER MYCOLINDICES(INUMMYC) INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC, ITMP INTEGER(8) :: I8 C INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP=omp_get_max_threads() C note that M=N !$ CHUNK= max(K361/2, (M+NOMP-1) / NOMP ) !$ ENDIF C C MARK MY ROWS. IF (NOMP_MAX.LE.0) THEN DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( M > K361 .AND. NOMP .GT. 1) DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO !$OMP END PARALLEL DO ENDIF CTEMP !$OMP PARALLEL DO PRIVATE(I8,IR,IC) SCHEDULE(STATIC,CHUNK) CTEMP !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) DO I8=1,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 ENDIF ENDDO CTEMP !$OMP END PARALLEL DO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,M IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C C C DO THE SMAME THING FOR COLS IF (NOMP_MAX.LE.0) THEN DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 ENDDO !$OMP END PARALLEL DO ENDIF C CTEMP !$OMP PARALLEL DO PRIVATE(I8,IR,IC) SCHEDULE(STATIC,CHUNK) CTEMP !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) DO I8=1,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IC) .EQ. 0) IWRK(IC)= 1 ENDIF ENDDO CTEMP !$OMP END PARALLEL DO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYCOLINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C RETURN END SUBROUTINE ZMUMPS_FILLMYROWCOLINDICES C C SEPARATOR: Another function begins C C INTEGER FUNCTION ZMUMPS_CHK1LOC(D, DSZ, INDX, INDXSZ, EPS) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) INTEGER INDX(INDXSZ) DOUBLE PRECISION EPS C LOCAL VARS INTEGER I, IID DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) ZMUMPS_CHK1LOC = 1 DO I=1, INDXSZ IID = INDX(I) IF (.NOT.( (D(IID).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(IID)) )) THEN ZMUMPS_CHK1LOC = 0 ENDIF ENDDO RETURN END FUNCTION ZMUMPS_CHK1LOC INTEGER FUNCTION ZMUMPS_CHK1CONV(D, DSZ, EPS) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION EPS C LOCAL VARS INTEGER I DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) ZMUMPS_CHK1CONV = 1 DO I=1, DSZ IF (.NOT.( (D(I).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(I)) )) THEN ZMUMPS_CHK1CONV = 0 ENDIF ENDDO RETURN END FUNCTION ZMUMPS_CHK1CONV C C SEPARATOR: Another function begins C INTEGER FUNCTION ZMUMPS_CHKCONVGLO(DR, M, INDXR, INDXRSZ, & DC, N, INDXC, INDXCSZ, EPS, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER M, N, INDXRSZ, INDXCSZ DOUBLE PRECISION DR(M), DC(N) INTEGER INDXR(INDXRSZ), INDXC(INDXCSZ) DOUBLE PRECISION EPS INTEGER COMM EXTERNAL ZMUMPS_CHK1LOC INTEGER ZMUMPS_CHK1LOC INTEGER GLORES, MYRESR, MYRESC, MYRES INTEGER IERR MYRESR = ZMUMPS_CHK1LOC(DR, M, INDXR, INDXRSZ, EPS) MYRESC = ZMUMPS_CHK1LOC(DC, N, INDXC, INDXCSZ, EPS) MYRES = MYRESR + MYRESC CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) ZMUMPS_CHKCONVGLO = GLORES RETURN END FUNCTION ZMUMPS_CHKCONVGLO C C SEPARATOR: Another function begins C DOUBLE PRECISION FUNCTION ZMUMPS_ERRSCALOC(D, TMPD, DSZ, & INDX, INDXSZ, NOMP_MAX) !$ USE OMP_LIB C THE VAR D IS NOT USED IN COMPUTATIONS. C IT IS THERE FOR READIBLITY OF THE *simScaleAbs.F IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, INDXSZ, NOMP_MAX DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTEGER INDX(INDXSZ) C LOCAL VARS DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) INTEGER I, IIND DOUBLE PRECISION ERRMAX INTRINSIC abs !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK ERRMAX = -RONE !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,INDXSZ IIND = INDX(I) IF(abs(RONE-TMPD(IIND)).GT.ERRMAX) THEN ERRMAX = abs(RONE-TMPD(IIND)) ENDIF ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I,IIND) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1 .AND. INDXSZ > K361 ) !$OMP& REDUCTION(max:ERRMAX) DO I=1,INDXSZ IIND = INDX(I) IF(abs(RONE-TMPD(IIND)).GT.ERRMAX) THEN ERRMAX = abs(RONE-TMPD(IIND)) ENDIF ENDDO !$OMP END PARALLEL DO ENDIF ZMUMPS_ERRSCALOC = ERRMAX RETURN END FUNCTION ZMUMPS_ERRSCALOC DOUBLE PRECISION FUNCTION ZMUMPS_ERRSCA1(D, TMPD, DSZ, NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, NOMP_MAX DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) C LOCAL VARS DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) INTEGER I DOUBLE PRECISION ERRMAX1 INTRINSIC abs !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK ERRMAX1 = -RONE !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (DSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,DSZ IF(abs(RONE-TMPD(I)).GT.ERRMAX1) THEN ERRMAX1 = abs(RONE-TMPD(I)) ENDIF ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND.DSZ > K361 ) !$OMP& REDUCTION(max:ERRMAX1) DO I=1,DSZ IF(abs(RONE-TMPD(I)).GT.ERRMAX1) THEN ERRMAX1 = abs(RONE-TMPD(I)) ENDIF ENDDO !$OMP END PARALLEL DO ENDIF ZMUMPS_ERRSCA1 = ERRMAX1 RETURN END FUNCTION ZMUMPS_ERRSCA1 C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_UPDATESCALE(D, TMPD, DSZ, & INDX, INDXSZ, NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(in) :: DSZ, INDXSZ, NOMP_MAX DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTEGER INDX(INDXSZ) INTRINSIC sqrt C LOCAL VARS INTEGER I, IIND DOUBLE PRECISION RZERO PARAMETER(RZERO=0.0D0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,INDXSZ IIND = INDX(I) IF (TMPD(IIND).NE.RZERO) D(IIND)=D(IIND)/sqrt(TMPD(IIND)) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I,IIND) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. INDXSZ> K361 ) DO I=1,INDXSZ IIND = INDX(I) IF (TMPD(IIND).NE.RZERO) D(IIND)=D(IIND)/sqrt(TMPD(IIND)) ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE ZMUMPS_UPDATESCALE C SUBROUTINE ZMUMPS_UPSCALE1(D, TMPD, DSZ, NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, NOMP_MAX DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTRINSIC sqrt C LOCAL VARS INTEGER I DOUBLE PRECISION RZERO PARAMETER(RZERO=0.0D0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (DSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,DSZ IF (TMPD(I) .NE. RZERO) D(I) = D(I)/sqrt(TMPD(I)) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. DSZ> K361 ) DO I=1,DSZ IF (TMPD(I) .NE. RZERO) D(I) = D(I)/sqrt(TMPD(I)) ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE ZMUMPS_UPSCALE1 C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_INITREALLST(D, DSZ, INDX, INDXSZ, VAL, & NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, INDXSZ, NOMP_MAX DOUBLE PRECISION D(DSZ) INTEGER INDX(INDXSZ) DOUBLE PRECISION VAL C LOCAL VARS INTEGER I, IIND !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,INDXSZ IIND = INDX(I) D(IIND) = VAL ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I,IIND) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. INDXSZ > K361 ) DO I=1,INDXSZ IIND = INDX(I) D(IIND) = VAL ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE ZMUMPS_INITREALLST C C SEPARATOR: Another function begins C C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_INITREAL(D, DSZ, VAL, NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, NOMP_MAX DOUBLE PRECISION D(DSZ) DOUBLE PRECISION VAL C LOCAL VARS INTEGER I !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = omp_get_max_threads() !$ CHUNK= max(K361/2, (DSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,DSZ D(I) = VAL ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND.DSZ > K361 ) DO I=1,DSZ D(I) = VAL ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE ZMUMPS_INITREAL C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_REDUCE_WRK(WRK, N, WRK_TH, NOMP_MAX) C Called only when NOMP_MAX>0 !$ USE OMP_LIB IMPLICIT NONE INTEGER N,NOMP_MAX DOUBLE PRECISION WRK(N), WRK_TH(N,NOMP_MAX) C LOCAL VAR INTEGER I, IOMP DOUBLE PRECISION DZERO PARAMETER(DZERO=0.0D0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (N+NOMP-1) / NOMP ) !$OMP PARALLEL DO PRIVATE(I,IOMP) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. N > K361 ) DO I=1,N WRK(I) = DZERO DO IOMP=1,NOMP_MAX WRK(I) = WRK_TH(I,IOMP) + WRK(I) ENDDO ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE ZMUMPS_REDUCE_WRK SUBROUTINE ZMUMPS_REDUCE_WRK_MPI(WRK, N, WRK_TH, NOMP_MAX, & INDX, INDXSZ) C Called only when NOMP_MAX>0 !$ USE OMP_LIB IMPLICIT NONE INTEGER N,NOMP_MAX,INDXSZ DOUBLE PRECISION WRK(N), WRK_TH(N,NOMP_MAX) INTEGER INDX(INDXSZ) C LOCAL VAR INTEGER I, J, IOMP DOUBLE PRECISION DZERO PARAMETER(DZERO=0.0D0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$OMP PARALLEL DO PRIVATE(I,J,IOMP) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. INDXSZ > K361 ) DO I=1,INDXSZ J = INDX(I) WRK(J) = DZERO DO IOMP=1,NOMP_MAX WRK(J) = WRK_TH(J,IOMP) + WRK(J) ENDDO ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE ZMUMPS_REDUCE_WRK_MPI SUBROUTINE ZMUMPS_ZEROOUT(TMPD, TMPSZ, INDX, INDXSZ, & NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: TMPSZ,INDXSZ, NOMP_MAX DOUBLE PRECISION TMPD(TMPSZ) INTEGER INDX(INDXSZ) C LOCAL VAR INTEGER I DOUBLE PRECISION DZERO PARAMETER(DZERO=0.0D0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,INDXSZ TMPD(INDX(I)) = DZERO ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. INDXSZ > K361 ) DO I=1,INDXSZ TMPD(INDX(I)) = DZERO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE ZMUMPS_ZEROOUT C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_BUREDUCE(INV, INOUTV, LEN, DTYPE) C C Like MPI_MINLOC operation (with ties broken sometimes with min C and sometimes with max) C The objective is find for each entry row/col C the processor with largest number of entries in its row/col C When 2 procs have the same number of entries in the row/col C then C if this number of entries is odd we take the proc with largest id C if this number of entries is even we take the proc with smallest id C IMPLICIT NONE #if defined(WORKAROUNDINTELILP64MPI2INTEGER) || defined(WORKAROUNDILP64MPICUSTOMREDUCE) INTEGER(4) :: LEN INTEGER(4) :: INV(2*LEN) INTEGER(4) :: INOUTV(2*LEN) INTEGER(4) :: DTYPE #else INTEGER :: LEN INTEGER :: INV(2*LEN) INTEGER :: INOUTV(2*LEN) INTEGER :: DTYPE #endif INTEGER I #if defined(WORKAROUNDINTELILP64MPI2INTEGER) || defined(WORKAROUNDILP64MPICUSTOMREDUCE) INTEGER(4) DIN, DINOUT, PIN, PINOUT #else INTEGER DIN, DINOUT, PIN, PINOUT #endif DO I=1,2*LEN-1,2 DIN = INV(I) ! nb of entries in row/col PIN = INV(I+1) ! proc number C DINOUT DINOUT = INOUTV(I) PINOUT = INOUTV(I+1) IF (DINOUT < DIN) THEN INOUTV(I) = DIN INOUTV(I+1) = PIN ELSE IF (DINOUT == DIN) THEN C --INOUTV(I) = DIN C --even number I take smallest Process number (pin) IF ((mod(DINOUT,2).EQ.0).AND.(PINPINOUT)) THEN C --odd number I take largest Process number (pin) INOUTV(I+1) = PIN ENDIF ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_BUREDUCE C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_IBUINIT(IW, IWSZ, IVAL) IMPLICIT NONE INTEGER(8) :: IWSZ #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) IW(IWSZ) INTEGER(4) IVAL #else INTEGER IW(IWSZ) INTEGER IVAL #endif INTEGER(8) :: I DO I=1_8,IWSZ IW(I)=IVAL ENDDO RETURN END SUBROUTINE ZMUMPS_IBUINIT C C SEPARATOR: Another function begins C C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX,ISNDRCVNUM,ISNDRCVVOL, & OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER(8), INTENT(IN) :: IWRKSZ INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ, OSZ INTEGER, INTENT(IN) :: COMM C When INDX holds row indices O(ther)INDX holds col indices INTEGER, INTENT(IN) :: INDX(NZ_loc) INTEGER, INTENT(IN) :: OINDX(NZ_loc) C On entry IPARTVEC(I) holds proc number with largest number of entries C in row/col I INTEGER, INTENT(IN) :: IPARTVEC(ISZ) C C OUTPUT PARAMETERS C SNDSZ (IPROC+1) is set to the number of rows (or col) that C MYID will have to send to IPROC C RCVSZ(IPROC+1) is set to the nb of row/cols that C MYID will receive from IPROC INTEGER, INTENT(OUT) :: SNDSZ(NUMPROCS) INTEGER, INTENT(OUT) :: RCVSZ(NUMPROCS) C OSNDRCVNUM is set to the total number of procs C destination of messages from MYID (< NUMPROCS) C ISNDRCVNUM is set to the total number procs C that will send messages to MYID (< NUMPROCS) C ISNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C OSNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C Knowing that for each row the process with the largest C number of entries will centralize all indices then C ISNDRCVVOL and OSNDRCVVOL are bounded by N INTEGER, INTENT(OUT) :: ISNDRCVNUM, OSNDRCVNUM INTEGER, INTENT(OUT) :: ISNDRCVVOL, OSNDRCVVOL C C INTERNAL WORKING ARRAY INTEGER IWRK(IWRKSZ) INCLUDE 'mpif.h' C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER IIND, IIND2, PIND INTEGER IERROR C check done outsize C IF(ISZ>IWRKSZ) THEN ERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,max(ISZ,OSZ) IWRK(I) = 0 ENDDO C C set SNDSZ DO I8=1,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. & (IIND2.GE.1).AND.(IIND2.LE.OSZ))THEN PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN C MYID will send row/col IIND to proc PIND C (PIND has the largest nb of entries in row/col IIND IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO C C use SNDSZ to set RCVSZ CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) C C compute number of procs destinations of messages from MYID C number of row/col sent by MYID. ISNDRCVNUM = 0 ISNDRCVVOL = 0 OSNDRCVNUM = 0 OSNDRCVVOL = 0 DO I=1, NUMPROCS IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) ENDDO RETURN END SUBROUTINE ZMUMPS_NUMVOLSNDRCV C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_SETUPCOMMS(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX, & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, & SNDSZ, RCVSZ, IWRK, & ISTATUS, REQUESTS, & ITAGCOMM, COMM ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER ISNDVOL, OSNDVOL INTEGER MYID, NUMPROCS, ISZ, OSZ C ISZ is either M or N INTEGER INDX(NZ_loc) INTEGER OINDX(NZ_loc) C INDX is either IRN_loc or JCN_col INTEGER IPARTVEC(ISZ) C IPARTVEC is either rowpartvec or colpartvec INTEGER :: ISNDRCVNUM INTEGER INGHBPRCS(ISNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1) INTEGER ISNDRCVJA(ISNDVOL) INTEGER OSNDRCVNUM INTEGER ONGHBPRCS(OSNDRCVNUM) INTEGER OSNDRCVIA(NUMPROCS+1) INTEGER OSNDRCVJA(OSNDVOL) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INTEGER IWRK(ISZ) INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) INTEGER REQUESTS(ISNDRCVNUM) INTEGER ITAGCOMM, COMM C LOCAL VARS INTEGER I, IIND, IIND2, IPID, OFFS INTEGER IWHERETO, POFFS, ITMP, IERROR INTEGER(8) :: I8 C COMPUATIONs START DO I=1,ISZ IWRK(I) = 0 ENDDO C INITIALIZE ONGHBPRCS using SNDSZ C INITIALIZE THE OSNDRCVIA using SNDSZ OFFS = 1 POFFS = 1 DO I=1,NUMPROCS OSNDRCVIA(I) = OFFS + SNDSZ(I) IF(SNDSZ(I) > 0) THEN ONGHBPRCS(POFFS)=I POFFS = POFFS + 1 ENDIF OFFS = OFFS + SNDSZ(I) ENDDO OSNDRCVIA(NUMPROCS+1) = OFFS C CHECK STARTS C check done outsize C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) DO I8=1,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. & (IIND2.GE.1).AND.(IIND2.LE.OSZ) ) THEN IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF ENDIF ENDDO C FILLED UP, WHAT I WILL RECEIVE (My requests from others) C FILL UP ISNDRCVJA. It will be received to fill up CALL MPI_BARRIER(COMM,IERROR) OFFS = 1 POFFS = 1 ISNDRCVIA(1) = 1 DO I=2,NUMPROCS+1 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) IF(RCVSZ(I-1) > 0) THEN INGHBPRCS(POFFS)=I-1 POFFS = POFFS + 1 ENDIF OFFS = OFFS + RCVSZ(I-1) ENDDO CALL MPI_BARRIER(COMM,IERROR) DO I=1, ISNDRCVNUM IPID = INGHBPRCS(I) OFFS = ISNDRCVIA(IPID) ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, & ITAGCOMM, COMM, REQUESTS(I),IERROR) ENDDO DO I=1,OSNDRCVNUM IPID = ONGHBPRCS(I) OFFS = OSNDRCVIA(IPID) ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, & ITAGCOMM, COMM,IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF CALL MPI_BARRIER(COMM,IERROR) RETURN END SUBROUTINE ZMUMPS_SETUPCOMMS C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_DOCOMMINF(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, & ISNDRCVNUM, INGHBPRCS, & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, & OSNDRCVNUM, ONGHBPRCS, & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, & ISTATUS, REQUESTS, & COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL DOUBLE PRECISION TMPD(IDSZ) INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) DOUBLE PRECISION ISNDRCVA(ISNDRCVVOL) INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) DOUBLE PRECISION OSNDRCVA(OSNDRCVVOL) INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER COMM, IERROR C LOCAL VARS INTEGER I, PID, OFFS, SZ, J, JS, JE, IID DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, & MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS, JE IID = OSNDRCVJA(J) OSNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM, COMM, IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF C FOLD INTO MY D DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1)-1 DO J=JS,JE IID = ISNDRCVJA(J) IF(TMPD(IID) < ISNDRCVA(J)) TMPD(IID)= ISNDRCVA(J) ENDDO ENDDO C COMMUNICATE THE UPDATED ONES DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, & MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1) -1 DO J=JS, JE IID = ISNDRCVJA(J) ISNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM+1, COMM, IERROR) ENDDO IF(OSNDRCVNUM > 0) THEN CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS,JE IID = OSNDRCVJA(J) TMPD(IID)=OSNDRCVA(J) ENDDO ENDDO RETURN END SUBROUTINE ZMUMPS_DOCOMMINF C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_DOCOMM1N(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, & ISNDRCVNUM, INGHBPRCS, & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, & OSNDRCVNUM, ONGHBPRCS, & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, & ISTATUS, REQUESTS, & COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL DOUBLE PRECISION TMPD(IDSZ) INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) DOUBLE PRECISION ISNDRCVA(ISNDRCVVOL) INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) DOUBLE PRECISION OSNDRCVA(OSNDRCVVOL) INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER COMM, IERROR C LOCAL VARS INTEGER I, PID, OFFS, SZ, J, JS, JE, IID DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, & MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS, JE IID = OSNDRCVJA(J) OSNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM, COMM, IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF C FOLD INTO MY D DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1)-1 DO J=JS,JE IID = ISNDRCVJA(J) TMPD(IID) = TMPD(IID)+ ISNDRCVA(J) ENDDO ENDDO C COMMUNICATE THE UPDATED ONES DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, & MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1) -1 DO J=JS, JE IID = ISNDRCVJA(J) ISNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM+1, COMM, IERROR) ENDDO IF(OSNDRCVNUM > 0) THEN CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS,JE IID = OSNDRCVJA(J) TMPD(IID)=OSNDRCVA(J) ENDDO ENDDO RETURN END SUBROUTINE ZMUMPS_DOCOMM1N SUBROUTINE ZMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, & IWRK, IWSZ, INUMMY) !$ USE OMP_LIB IMPLICIT NONE EXTERNAL ZMUMPS_BUREDUCE INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM INTEGER(8) :: NZ_loc, IWSZ INTEGER, INTENT(IN) :: ISZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C C OUTPUT C IPARTVEC(I) = proc number with largest number of entries C in row/col I C INUMMY = number of local rows/columns with C at least one local entry (NUMPROCS .NE. 1 only) INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) INTEGER, INTENT(OUT) :: INUMMY C C INTERNAL WORKING ARRAY C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries C on my proc and in row/col I) for I=1,ISZ C (2*ISZ+1: 4*ISZ) is then set to C the processor with largest number of entries in its row/col C and its value (that is copied back into IPARTVEC(I) #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) #else INTEGER, INTENT(OUT) :: IWRK(IWSZ) #endif INCLUDE 'mpif.h' C C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER OP, IERROR INTEGER IR, IC INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK C INUMMY = 0 !$ NOMP=omp_get_max_threads() !$ CHUNK= max(K361/2, (ISZ+NOMP-1) / NOMP ) IF(NUMPROCS.NE.1) THEN C CHECK done outsize C IF(IWSZ < 2*ISZ) THEN C CHECK ENDS CALL MPI_OP_CREATE(ZMUMPS_BUREDUCE, .TRUE., OP, IERROR) C PERFORM THE REDUCTION !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) DO I=1,ISZ IWRK(2_8*int(I,8)-1_8) = 0 IWRK(2_8*int(I,8)) = MYID ENDDO !$OMP END PARALLEL DO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.ISZ).AND. & (IC.GE.1).AND.(IC.LE.ISZ)) THEN IWRK(2_8*int(IR,8)-1_8) = IWRK(2_8*int(IR,8)-1_8) + 1 IWRK(2_8*int(IC,8)-1_8) = IWRK(2_8*int(IC,8)-1_8) + 1 ENDIF ENDDO CALL MUMPS_BIGALLREDUCE(.FALSE., & IWRK(1), IWRK(1_8+2_8*int(ISZ,8)), ISZ, & MPI_2INTEGER, OP, COMM, IERROR) C CHUNK computed in previous // do !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) !$OMP& REDUCTION(+:INUMMY) DO I=1,ISZ IPARTVEC(I) = IWRK(2_8*int(I,8)+2_8*int(ISZ,8)) C Compute INUMMY directly IF ( IPARTVEC(I) .EQ. MYID. OR. & IWRK(2_8*int(I,8)-1_8) .GT. 0 ) THEN INUMMY=INUMMY+1 ENDIF ENDDO !$OMP END PARALLEL DO C FREE THE OPERATOR CALL MPI_OP_FREE(OP, IERROR) ELSE !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_CREATEPARTVECSYM SUBROUTINE ZMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX,OINDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER(8), INTENT(IN) :: IWRKSZ INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ INTEGER, INTENT(IN) :: INDX(NZ_loc), OINDX(NZ_loc) INTEGER, INTENT(IN) :: IPARTVEC(ISZ) INTEGER, INTENT(IN) :: COMM C C OUTPUT PARAMETERS C SNDSZ (IPROC+1) is set to the number of rows (or col) that C MYID will have to send to IPROC C RCVSZ(IPROC+1) is set to the nb of row/cols that C MYID will receive from IPROC INTEGER :: SNDSZ(NUMPROCS) INTEGER :: RCVSZ(NUMPROCS) C OSNDRCVNUM is set to the total number of procs C destination of messages from MYID (< NUMPROCS) C ISNDRCVNUM is set to the total number procs C that will send messages to MYID (< NUMPROCS) C ISNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C OSNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C Knowing that for each row the process with the largest C number of entries will centralize all indices then C ISNDRCVVOL and OSNDRCVVOL are bounded by N INTEGER, INTENT(OUT) :: ISNDRCVNUM, ISNDRCVVOL INTEGER, INTENT(OUT) :: OSNDRCVNUM, OSNDRCVVOL C C INTERNAL WORKING ARRAY INTEGER, INTENT(OUT) :: IWRK(IWRKSZ) INCLUDE 'mpif.h' C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER IIND, IIND2, PIND INTEGER IERROR C check done outsize C IF(ISZ>IWRKSZ) THEN ERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,ISZ IWRK(I) = 0 ENDDO C C set SNDSZ DO I8=1_8,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) & .AND.(IIND2.LE.ISZ)) THEN PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN C MYID will send row/col IIND to proc PIND C (PIND has the largest nb of entries in row/col IIND IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF IIND = OINDX(I8) PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO C C use SNDSZ to set RCVSZ CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) C C compute number of procs destinations of messages from MYID C number of row/col sent by MYID. ISNDRCVNUM = 0 ISNDRCVVOL = 0 OSNDRCVNUM = 0 OSNDRCVVOL = 0 DO I=1, NUMPROCS IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) ENDDO RETURN END SUBROUTINE ZMUMPS_NUMVOLSNDRCVSYM INTEGER FUNCTION ZMUMPS_CHKCONVGLOSYM(D, N, INDXR, INDXRSZ, & EPS, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER N, INDXRSZ DOUBLE PRECISION D(N) INTEGER INDXR(INDXRSZ) DOUBLE PRECISION EPS INTEGER COMM EXTERNAL ZMUMPS_CHK1LOC INTEGER ZMUMPS_CHK1LOC INTEGER GLORES, MYRESR, MYRES INTEGER IERR MYRESR = ZMUMPS_CHK1LOC(D, N, INDXR, INDXRSZ, EPS) MYRES = 2*MYRESR CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) ZMUMPS_CHKCONVGLOSYM = GLORES RETURN END FUNCTION ZMUMPS_CHKCONVGLOSYM SUBROUTINE ZMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & MYROWINDICES, INUMMYR, & IWRK, IWSZ, NOMP_MAX ) !$ USE OMP_LIB IMPLICIT NONE INTEGER MYID, NUMPROCS, N, NOMP_MAX INTEGER(8) :: NZ_loc, IWSZ INTEGER INUMMYR INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC, ITMP INTEGER(8) :: I8 INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP=omp_get_max_threads() !$ CHUNK= max(K361/2, (N+NOMP-1) / NOMP ) !$ ENDIF C C MARK MY ROWS. IF (NOMP_MAX.LE.0) THEN DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO !$OMP END PARALLEL DO ENDIF C DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 IF(IWRK(IC) .EQ.0) IWRK(IC)=1 ENDIF ENDDO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C C C THE SMAME THING APPLY TO COLS C RETURN END SUBROUTINE ZMUMPS_FILLMYROWCOLINDICESSYM SUBROUTINE ZMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OINDX, & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, & SNDSZ, RCVSZ, IWRK, & ISTATUS, REQUESTS, & ITAGCOMM, COMM ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, ISZ, ISNDVOL, OSNDVOL INTEGER(8) :: NZ_loc C ISZ is either M or N INTEGER INDX(NZ_loc), OINDX(NZ_loc) C INDX is either IRN_loc or JCN_col INTEGER IPARTVEC(ISZ) C IPARTVEC is either rowpartvec or colpartvec INTEGER ISNDRCVNUM, INGHBPRCS(ISNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1) INTEGER ISNDRCVJA(ISNDVOL) INTEGER OSNDRCVNUM, ONGHBPRCS(OSNDRCVNUM) INTEGER OSNDRCVIA(NUMPROCS+1) INTEGER OSNDRCVJA(OSNDVOL) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INTEGER IWRK(ISZ) INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) INTEGER REQUESTS(ISNDRCVNUM) INTEGER ITAGCOMM, COMM C LOCAL VARS INTEGER I, IIND,IIND2,IPID,OFFS,IWHERETO,POFFS, ITMP, IERROR INTEGER(8) :: I8 C COMPUATIONs START DO I=1,ISZ IWRK(I) = 0 ENDDO C INITIALIZE ONGHBPRCS using SNDSZ C INITIALIZE THE OSNDRCVIA using SNDSZ OFFS = 1 POFFS = 1 DO I=1,NUMPROCS OSNDRCVIA(I) = OFFS + SNDSZ(I) IF(SNDSZ(I) > 0) THEN ONGHBPRCS(POFFS)=I POFFS = POFFS + 1 ENDIF OFFS = OFFS + SNDSZ(I) ENDDO OSNDRCVIA(NUMPROCS+1) = OFFS C CHECK STARTS C check done outsize C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) DO I8=1_8,NZ_loc IIND=INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) & .AND.(IIND2.LE.ISZ)) THEN IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF IIND = OINDX(I8) IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF ENDIF ENDDO C FILLED UP, WHAT I WILL RECEIVE (My requests from others) C FILL UP ISNDRCVJA. It will be received to fill up CALL MPI_BARRIER(COMM,IERROR) OFFS = 1 POFFS = 1 ISNDRCVIA(1) = 1 DO I=2,NUMPROCS+1 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) IF(RCVSZ(I-1) > 0) THEN INGHBPRCS(POFFS)=I-1 POFFS = POFFS + 1 ENDIF OFFS = OFFS + RCVSZ(I-1) ENDDO CALL MPI_BARRIER(COMM,IERROR) DO I=1, ISNDRCVNUM IPID = INGHBPRCS(I) OFFS = ISNDRCVIA(IPID) ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, & ITAGCOMM, COMM, REQUESTS(I),IERROR) ENDDO DO I=1,OSNDRCVNUM IPID = ONGHBPRCS(I) OFFS = OSNDRCVIA(IPID) ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, & ITAGCOMM, COMM,IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF CALL MPI_BARRIER(COMM,IERROR) RETURN END SUBROUTINE ZMUMPS_SETUPCOMMSSYM MUMPS_5.8.1/src/csol_distsol.F0000664000175000017500000000101115042446440016031 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_DS_RETURN() RETURN END SUBROUTINE CMUMPS_DS_RETURN MUMPS_5.8.1/src/cfac_process_contrib_type2.F0000664000175000017500000004720215042446440020641 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, & MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, & N, IW, LIW, A, LA, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, PERM, & COMP, root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, NBFIN, & MYID, COMM, ICNTL, KEEP,KEEP8,DKEEP, IFLAG, IERROR, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_LOAD USE CMUMPS_BUF USE CMUMPS_LR_TYPE USE MUMPS_LR_STATS USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR, & CMUMPS_DM_FREE_BLOCK IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV, MSGLEN INTEGER BUFR( LBUFR ) INTEGER(8) :: LRLU, IPTRLU, LRLUS, LA, POSFAC INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER NBFIN INTEGER COMP INTEGER NELT, LPTRAR INTEGER PROCNODE_STEPS( KEEP(28) ), PTRIST(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER PTLUST( KEEP(28) ) INTEGER PERM(N) INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER ITLOC( N + KEEP(253)), NSTK_S( KEEP(28) ) INTEGER :: FILS( N ), DAD(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER ND(KEEP(28)), FRERE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER INTARR( KEEP8(27) ) COMPLEX DBLARR( KEEP8(26) ) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, MYID, IFLAG, IERROR INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER FRTPTR(N+1), FRTELT( NELT ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NFS4FATHER INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPESPLIT INTEGER IERR INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER I, INODE, ISON, POSITION, NBROW, LROW, IROW, INDCOL INTEGER LREQI INTEGER(8) :: LREQA, POSCONTRIB INTEGER ROW_LENGTH INTEGER MASTER INTEGER ISTCHK LOGICAL SAME_PROC LOGICAL SLAVE_NODE LOGICAL IS_ofType5or6 INTEGER ISHIFT_BUFR, LBUFR_LOC, LBUFR_BYTES_LOC INTEGER TYPESPLIT INTEGER DECR INTEGER :: INBPROCFILS_SON LOGICAL :: CB_IS_LR INTEGER :: CB_IS_LR_INT, NBLRB_PACKET, allocok INTEGER :: MAXI_CLUSTER INTEGER :: ICOL_BEG, ICOL_END, ICOL_SHARED INTEGER :: IROW_BEG, IROW_END INTEGER :: NB_BLOCKS_UNPACKED LOGICAL :: BLOCKS_LEFT_2_UNPACK DOUBLE PRECISION :: PROMOTE_COST INTEGER(8) :: LA_TEMP COMPLEX, DIMENSION(:), POINTER :: A_TEMP TYPE (LRB_TYPE) :: LRB INTEGER(8) :: IACHK, SIZFR8, DYN_SIZE COMPLEX, DIMENSION(:), POINTER :: DYNPTR INTEGER :: NSLAVES, NFRONT, NASS1, IOLDPS, PARPIV_T1 INTEGER :: NB_POSTPONED LOGICAL :: LR_ACTIVATED INTEGER(8) :: POSELT INTEGER :: XXG_STATUS INCLUDE 'mumps_headers.h' COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) INTEGER :: NBCOLS_ALREADY_SENT LOGICAL :: IS_PANEL_FINISHED, IS_LROW_NEGATIVE 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 ) IS_LROW_NEGATIVE = (LROW.LT.0) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & CB_IS_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) CB_IS_LR = (CB_IS_LR_INT.EQ.1) IF (CB_IS_LR.AND.LROW.LT.0) THEN LROW = -LROW ENDIF NBCOLS_ALREADY_SENT=0 ICOL_SHARED = -9999 MASTER = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) SLAVE_NODE = MASTER .NE. MYID TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) IF (SLAVE_NODE .AND. PTRIST(STEP(INODE)) ==0) THEN ISHIFT_BUFR = ( MSGLEN + KEEP(34) ) / KEEP(34) LBUFR_LOC = LBUFR - ISHIFT_BUFR + 1 LBUFR_BYTES_LOC = LBUFR_LOC * KEEP(34) CALL CMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR(ISHIFT_BUFR), LBUFR_LOC, LBUFR_BYTES_LOC, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (IFLAG.LT.0) RETURN ENDIF IF ( SLAVE_NODE ) THEN LREQI = LROW + NBROWS_PACKET ELSE LREQI = NBROWS_PACKET END IF LREQA = int(LROW,8) CALL CMUMPS_GET_SIZE_NEEDED( & LREQI, LREQA, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR ) IF (IFLAG.LT.0) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA POSCONTRIB = POSFAC POSFAC = POSFAC + LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) IF ( SLAVE_NODE ) THEN IROW = IWPOS INDCOL = IWPOS + NBROWS_PACKET ELSE IROW = IWPOS INDCOL = -1 END IF IWPOS = IWPOS + LREQI IF ( SLAVE_NODE ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( INDCOL ), LROW, MPI_INTEGER, & COMM, IERR ) END IF DO I = 1, NBROWS_PACKET CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IROW + I - 1 ), 1, MPI_INTEGER, & COMM, IERR ) END DO IF (CB_IS_LR.AND.(NBROWS_PACKET.GT.0)) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBLRB_PACKET, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBCOLS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR ) ICOL_SHARED = 1+NBCOLS_ALREADY_SENT ENDIF IF ( SLAVE_NODE ) THEN IF ( KEEP(55) .eq. 0 ) THEN CALL CMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, INODE, IW, LIW, A, LA, & NBROW, LROW, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ELSE CALL CMUMPS_ELT_ASM_S_2_S_INIT( & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, & NBROW, LROW, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ENDIF ENDIF IF (CB_IS_LR.AND.(NBROWS_PACKET.GT.0)) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & MAXI_CLUSTER, 1, & MPI_INTEGER, COMM, IERR ) IROW_BEG = 1 IROW_END = NBROWS_PACKET LA_TEMP = NBROWS_PACKET*MAXI_CLUSTER NB_BLOCKS_UNPACKED = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(A_TEMP, LRB, I, ICOL_BEG, !$OMP& ICOL_END, ROW_LENGTH, allocok, BLOCKS_LEFT_2_UNPACK, !$OMP& PROMOTE_COST) #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) nullify(A_TEMP) IF (LA_TEMP.GT.0) THEN allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 550 ENDIF ENDIF BLOCKS_LEFT_2_UNPACK = .TRUE. DO WHILE (BLOCKS_LEFT_2_UNPACK) #if ! defined(BLR_NOOPENMP) !$OMP CRITICAL(contrib_type2_lrcb) #endif IF (NB_BLOCKS_UNPACKED.LT.NBLRB_PACKET) THEN CALL CMUMPS_MPI_UNPACK_LRB(BUFR, LBUFR, & LBUFR_BYTES, POSITION, LRB, KEEP8, & COMM, IFLAG, IERROR & ) NB_BLOCKS_UNPACKED = NB_BLOCKS_UNPACKED + 1 ICOL_BEG = ICOL_SHARED ICOL_SHARED = ICOL_SHARED + LRB%N ELSE BLOCKS_LEFT_2_UNPACK = .FALSE. ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END CRITICAL(contrib_type2_lrcb) #endif IF (.NOT.BLOCKS_LEFT_2_UNPACK) CYCLE IF (LRB%ISLR .AND. LRB%K.EQ.0) CYCLE IF (LRB%ISLR) THEN CALL cgemm('T','T', LRB%N, NBROWS_PACKET, LRB%K, ONE, & LRB%R(1,1), LRB%K, LRB%Q(IROW_BEG,1), LRB%M, & ZERO, A_TEMP(1), LRB%N) PROMOTE_COST = 2.0D0*LRB%N*NBROWS_PACKET*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE DO I = IROW_BEG, IROW_END A_TEMP( 1+(I-IROW_BEG)*LRB%N : (I-IROW_BEG+1)*LRB%N ) & = LRB%Q(I,1:LRB%N) ENDDO ENDIF CALL DEALLOC_LRB(LRB, KEEP8, KEEP(34)) DO I=1,NBROWS_PACKET IF (KEEP(50).EQ.0) THEN ROW_LENGTH = LROW ELSE ROW_LENGTH = LROW - NBROWS_PACKET + I ENDIF ICOL_END = min(ICOL_BEG+LRB%N-1, ROW_LENGTH) IF (SLAVE_NODE) THEN CALL CMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & 1, ICOL_END-ICOL_BEG+1, IW( IROW+I-1 ), & IW(INDCOL+ICOL_BEG-1), & A_TEMP(1+(I-1)*LRB%N), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, & LROW) ELSE CALL CMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, 1, ICOL_END-ICOL_BEG+1, IW( IROW+I-1 ), & A_TEMP(1+(I-1)*LRB%N), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LROW, ICOL_BEG & ) ENDIF ENDDO ENDDO IF (associated(A_TEMP)) deallocate(A_TEMP) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) 550 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) RETURN ELSE DO I=1,NBROWS_PACKET IF (KEEP(50).NE.0) THEN ROW_LENGTH = LROW - NBROWS_PACKET + I ELSE ROW_LENGTH = LROW ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSCONTRIB), & ROW_LENGTH, & MPI_COMPLEX, & COMM, IERR ) IF (SLAVE_NODE) THEN CALL CMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & 1, ROW_LENGTH, IW( IROW+I-1 ),IW(INDCOL), & A(POSCONTRIB), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, & ROW_LENGTH ) ELSE CALL CMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, 1, ROW_LENGTH, IW( IROW +I-1 ), & A(POSCONTRIB), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, ROW_LENGTH, 1 ) ENDIF ENDDO ENDIF IF (SLAVE_NODE) THEN IF (CB_IS_LR) THEN IF (NBROWS_PACKET.EQ.0) THEN IS_PANEL_FINISHED = .TRUE. ELSE IS_PANEL_FINISHED = ICOL_SHARED .GT. LROW ENDIF ELSE IS_PANEL_FINISHED = .TRUE. ENDIF IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW & .AND. IS_PANEL_FINISHED ) THEN IW(PTRIST(STEP(INODE))+XXNBPR) = & IW(PTRIST(STEP(INODE))+XXNBPR) - NBROW ENDIF CALL CMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, & NBROWS_PACKET, STEP, PTRIST, & ITLOC, RHS_MUMPS,KEEP,KEEP8) ENDIF IF ( .NOT. SLAVE_NODE ) THEN IF ( (NBROWS_ALREADY_SENT .EQ. 0) & .AND. (NBCOLS_ALREADY_SENT .EQ. 0) & ) THEN IF (KEEP(219).NE.0) THEN IF(KEEP(50) .EQ. 2) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NFS4FATHER, & 1, & MPI_INTEGER, & COMM, IERR ) IF(NFS4FATHER .GT. 0) THEN CALL CMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERROR = BUF_LMAX_ARRAY IFLAG = -13 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BUF_MAX_ARRAY, & NFS4FATHER, & MPI_REAL, & COMM, IERR ) CALL CMUMPS_ASM_MAX(N, INODE, IW, LIW, A, LA, & ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8) ENDIF ENDIF ENDIF ENDIF IF (CB_IS_LR) THEN IF (NBROWS_PACKET.EQ.0) THEN IS_PANEL_FINISHED = .TRUE. ELSE IS_PANEL_FINISHED = ICOL_SHARED .GT. LROW ENDIF ELSE IS_PANEL_FINISHED = .TRUE. ENDIF IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW & .AND. IS_PANEL_FINISHED ) THEN DECR = 1 ISTCHK = PIMASTER(STEP(ISON)) SAME_PROC = ISTCHK .LT. IWPOSCB IW(PTLUST(STEP(INODE))+XXNBPR) = & IW(PTLUST(STEP(INODE))+XXNBPR) - DECR IF (SAME_PROC) THEN INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR ELSE INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ENDIF IW(INBPROCFILS_SON) = IW(INBPROCFILS_SON) - DECR IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN IF (SAME_PROC) THEN CALL CMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST, IW, LIW, STEP, KEEP,KEEP8) ENDIF IF (SAME_PROC) THEN ISTCHK = PTRIST(STEP(ISON)) PTRIST(STEP( ISON) ) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL CMUMPS_DM_SET_DYNPTR( IW(ISTCHK+XXS), A, LA, & PAMASTER(STEP(ISON)), IW(ISTCHK+XXD), & IW(ISTCHK+XXR), DYNPTR, IACHK, SIZFR8) CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK+XXD)) XXG_STATUS = IW(ISTCHK+XXG) CALL CMUMPS_FREE_BLOCK_CB_STATIC( & .FALSE., MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) IF ( DYN_SIZE .GT. 0_8 ) THEN CALL CMUMPS_DM_FREE_BLOCK( XXG_STATUS, & DYNPTR, DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF IF (IW(PTLUST(STEP(INODE))+XXNBPR) .EQ. 0) THEN IOLDPS = PTLUST(STEP(INODE)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) IF (NSLAVES.EQ.0) THEN NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS1 = abs(IW(IOLDPS + 2+KEEP(IXSZ))) POSELT = PTRAST(STEP(INODE)) PARPIV_T1 = -999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) NB_POSTPONED = max(NFRONT - ND(STEP(INODE)),0) CALL CMUMPS_PARPIVT1_SET_NVSCHUR_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1, & NB_POSTPONED) ENDIF CALL CMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, INODE+N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ENDIF ENDIF END IF IWPOS = IWPOS - LREQI LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA POSFAC = POSFAC - LREQA CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) RETURN END SUBROUTINE CMUMPS_PROCESS_CONTRIB_TYPE2 MUMPS_5.8.1/src/sfac_process_contrib_type1.F0000664000175000017500000001161715042446437020667 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_PROCESS_NODE( MYID,KEEP,KEEP8,DKEEP, & BUFR, LBUFR, LBUFR_BYTES, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER MYID INTEGER LBUFR, LBUFR_BYTES INTEGER KEEP(500), BUFR( LBUFR ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP, FPERE LOGICAL FLAG INTEGER NSTK_S( KEEP(28) ), ITLOC( N + KEEP(253) ) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER IFLAG, IERROR, COMM INTEGER POSITION, FINODE, FLCONT, LREQ INTEGER(8) :: LREQCB INTEGER(8) :: IPOS_NODE, ISHIFT_PACKET INTEGER SIZE_PACKET INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INCLUDE 'mumps_headers.h' LOGICAL PACKED_CB REAL, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYN_SIZE FLAG = .FALSE. POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FLCONT, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, MPI_INTEGER, & COMM, IERR) PACKED_CB = (FLCONT.LT.0) IF (PACKED_CB) THEN FLCONT = -FLCONT LREQCB = (int(FLCONT,8) * int(FLCONT+1,8)) / 2_8 ELSE LREQCB = int(FLCONT,8) * int(FLCONT,8) ENDIF IF (NBROWS_ALREADY_SENT == 0) THEN LREQ = 2 * FLCONT + 6 + KEEP(IXSZ) CALL SMUMPS_ALLOC_CB( .FALSE., 0_8, .FALSE.,.FALSE., & MYID,N, KEEP,KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & LREQ, LREQCB, FINODE, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PIMASTER(STEP( FINODE )) = IWPOSCB + 1 PAMASTER(STEP( FINODE )) = IPTRLU + 1_8 IF (PACKED_CB) IW(IWPOSCB + 1 + XXS ) = S_CB1COMP CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 1+KEEP(IXSZ)), LREQ-KEEP(IXSZ), & MPI_INTEGER, COMM, IERR) ENDIF IF (PACKED_CB) THEN ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * & int(NBROWS_ALREADY_SENT+1,8) / 2_8 SIZE_PACKET = (NBROWS_PACKET * (NBROWS_PACKET+1))/2 + & NBROWS_ALREADY_SENT * NBROWS_PACKET ELSE ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * int(FLCONT,8) SIZE_PACKET = NBROWS_PACKET * FLCONT ENDIF IF (NBROWS_PACKET.NE.0) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(PIMASTER(STEP(FINODE))+XXD)) IF (DYN_SIZE .GT. 0_8) THEN CALL SMUMPS_DM_SET_PTR( PAMASTER(STEP(FINODE)), & DYN_SIZE, SON_A ) IPOS_NODE = 1_8 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & SON_A(IPOS_NODE + ISHIFT_PACKET), & SIZE_PACKET, MPI_REAL, COMM, IERR) ELSE IPOS_NODE = PAMASTER(STEP(FINODE)) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & A(IPOS_NODE + ISHIFT_PACKET), & SIZE_PACKET, MPI_REAL, COMM, IERR) ENDIF ENDIF IF (NBROWS_ALREADY_SENT+NBROWS_PACKET == FLCONT) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF ( NSTK_S(STEP(FPERE)).EQ.0 ) THEN FLAG = . TRUE. END IF ENDIF RETURN END SUBROUTINE SMUMPS_PROCESS_NODE MUMPS_5.8.1/src/cmumps_gpu.h0000664000175000017500000000114315042446422015557 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef CMUMPS_GPU_H #define CMUMPS_GPU_H #include "mumps_compat.h" #include "mumps_common.h" void MUMPS_CALL cmumps_gpu_return(); #endif /* CMUMPS_GPU_H */ MUMPS_5.8.1/src/mumps_io_err.h0000664000175000017500000000317615042446422016110 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include #include "mumps_common.h" #include "mumps_c_types.h" #if ! ( defined(MUMPS_WIN32) || defined(WITHOUT_PTHREAD) ) # include #endif /* ! ( MUMPS_WIN32 || WITHOUT_PTHREAD ) */ #if ! ( defined(MUMPS_WIN32) || defined(WITHOUT_PTHREAD) ) extern pthread_mutex_t err_mutex; #endif /* ! ( MUMPS_WIN32 || WITHOUT_PTHREAD ) */ /* Exported functions */ #define MUMPS_LOW_LEVEL_INIT_ERR_STR \ F_SYMBOL(low_level_init_err_str,LOW_LEVEL_INIT_ERR_STR) void MUMPS_CALL MUMPS_LOW_LEVEL_INIT_ERR_STR( MUMPS_INT *dim, char *err_str, mumps_ftnlen l1 ); /* Export an error to the Fortran layer Returns mumps_errno for convenience */ MUMPS_INT mumps_io_error(MUMPS_INT mumps_errno, const char* desc); /* Export a system error to the Fortran layer (errno must be set) Returns mumps_errno for convenience */ MUMPS_INT mumps_io_sys_error(MUMPS_INT mumps_errno, const char* desc); #if ! ( defined(MUMPS_WIN32) || defined(WITHOUT_PTHREAD) ) MUMPS_INT mumps_io_init_err_lock(); MUMPS_INT mumps_io_destroy_err_lock(); MUMPS_INT mumps_check_error_th(); MUMPS_INLINE MUMPS_INT mumps_io_protect_err(); MUMPS_INLINE MUMPS_INT mumps_io_unprotect_err(); #endif /* ! ( MUMPS_WIN32 || WITHOUT_PTHREAD ) */ MUMPS_5.8.1/src/sooc_panel_piv.F0000664000175000017500000002770015042446441016346 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C This file contains routines related to OOC, C panels, and pivoting. They are used to store C permutation information of what is already on C disk to be able to permute things back at the C solve stage. C They do not need to be in the MUMPS_OOC C module (most of them do not use any variable C from the module, or are called from routines C where we do not necessarily want to do a C USE SMUMPS_OOC). INTEGER FUNCTION SMUMPS_OOC_GET_PANEL_SIZE & ( HBUF_SIZE, NNMAX, K227, K50 ) IMPLICIT NONE C C Arguments: C ========= C INTEGER, INTENT(IN) :: NNMAX, K227, K50 INTEGER(8), INTENT(IN) :: HBUF_SIZE C C Purpose: C ======= C C - Compute the effective size (maximum number of pivots in a panel) C for a front with NNMAX entries in its row (for U) / C column (for L). C - Be able to adapt the fixed number of columns in panel C depending on NNMAX, and size of IO buffer HBUF_SIZE C C Local variables C =============== C INTEGER K227_LOC INTEGER NBCOL_MAX INTEGER EFFECTIVE_SIZE NBCOL_MAX=int(HBUF_SIZE / int(NNMAX,8)) C KEEP(227): Maximum size (nb of col/row) of a panel K227_LOC = abs(K227) IF (K50.EQ.2) THEN C for 2x2 pivots we may end-up having the first part C of a 2x2 pivot in the last col of the panel; the C adopted solution consists in adding the next column C to the panel; therefore we need be able to C dynamically increase the panel size by one. C note that we also maintain property: C KEEP(227): Maximum size (nb of col/row) of a panel K227_LOC=max(K227_LOC,2) EFFECTIVE_SIZE = min(NBCOL_MAX-1, K227_LOC-1) cN - during bwd the effective size is useless ELSE C complete buffer space can be used for a panel EFFECTIVE_SIZE = min(NBCOL_MAX, K227_LOC) ENDIF IF (EFFECTIVE_SIZE.LE.0) THEN write(6,*) 'Internal buffers too small to store ', & ' ONE col/row of size', NNMAX CALL MUMPS_ABORT() ENDIF SMUMPS_OOC_GET_PANEL_SIZE = EFFECTIVE_SIZE RETURN END FUNCTION SMUMPS_OOC_GET_PANEL_SIZE C SUBROUTINE SMUMPS_PERMUTE_PANEL( IPIV, LPIV, ISHIFT, & THE_PANEL, NBROW, NBCOL, KbeforePanel ) IMPLICIT NONE C C Purpose: C ======= C C Permute rows of a panel, stored by columns, according C to permutation array IPIV. C IPIV is such that, for I = 1 to LPIV, row ISHIFT + I C in the front must be permuted with row IPIV( I ) C C Since the panel is not necessary at the beginning of C the front, let KbeforePanel be the number of pivots in the C front before the first pivot of the panel. C C In the panel, row ISHIFT+I-KbeforePanel is permuted with C row IPIV(I)-KbeforePanel C C Note: C ==== C C This routine can also be used to permute the columns of C a matrix (U) stored by rows. In that case, the argument C NBROW represents the number of columns, and NBCOL represents C the number of rows. C C C Arguments: C ========= C INTEGER LPIV, ISHIFT, NBROW, NBCOL, KbeforePanel INTEGER IPIV(LPIV) REAL THE_PANEL(NBROW, NBCOL) C C Local variables: C =============== C INTEGER I, IPERM C C Executable statements C ===================== C DO I = 1, LPIV C Swap rows ISHIFT + I and PIV(I) IPERM=IPIV(I) IF ( I+ISHIFT.NE.IPERM) THEN CALL sswap(NBCOL, & THE_PANEL(I+ISHIFT-KbeforePanel,1), NBROW, & THE_PANEL(IPERM-KbeforePanel,1), NBROW) ENDIF END DO RETURN END SUBROUTINE SMUMPS_PERMUTE_PANEL SUBROUTINE SMUMPS_GET_OOC_PERM_PTR(TYPEF, & NBPANELS, & I_PIVPTR, I_PIV, IPOS, IW, LIW) USE MUMPS_OOC_COMMON ! To access TYPEF_L and TYPEF_U IMPLICIT NONE INCLUDE 'mumps_headers.h' C C Purpose: C ======= C C Get the pointers in IW on pivoting information to be stored C during factorization and used during the solve phase. This C routine is both for the symmetric (TYPEF=TYPEF_L) and unsymmetric C cases (TYPEF=TYPEF_L or TYPEF_U). C The total size of this space is estimated during C fac_ass.F / fac_ass_ELT.F and must be: C * Symmetric case: 1 for NASS + 1 for NBPANELS_L + NBPANELS_L + NASS C * Unsymmetric case: 1 + (1+NBPANELS_L+NASS) + (1+NBPANELS_U+NASS) C Size computation is in routine SMUMPS_OOC_GET_PP_SIZES. C C At the end of the standard description of the structure of a node C (header, nb slaves, , row indices, col indices), we C add, when panel version with pivoting is used: C C NASS (nb of fully summed variables) C NBPANELS_L C PIVRPTR(1:NBPANELS_L) C PIV_L (1:NASS) NASS (=IW(IPOS)(or NASS-PIVRPTR(1) in C the future, after compression) C NBPANELS_U C PIVRPTR(1:NBPANELS_U) C PIV_U (1:NASS) NASS (=IW(IPOS)(or NASS-PIVRPTR(1) in C the future, after compression) C C C Output parameters: C ================= C NBPANELS : nb of panels as estimated during assembly C I_PIVPTR : position in IW of the starting of the pointer list C (of size NBPANELS) of the pointers to the list of pivots C I_PIV : position in IW of the starting of the pivot permutation list C INTEGER, intent(out) :: NBPANELS, I_PIVPTR, I_PIV INTEGER, intent(in) :: TYPEF ! TYPEF_L or TYPEF_U INTEGER, intent(in) :: LIW, IPOS INTEGER IW(LIW) C Locals INTEGER I_NBPANELS, I_NASS C I_NASS = IPOS I_NBPANELS = I_NASS + 1 ! L NBPANELS = IW(I_NBPANELS) ! L I_PIVPTR = I_NBPANELS + 1 ! L I_PIV = I_PIVPTR + NBPANELS ! L C ... of size NASS = IW(I_NASS) IF (TYPEF==TYPEF_U) THEN I_NBPANELS = I_PIV+IW(I_NASS) ! U NBPANELS = IW(I_NBPANELS) ! U I_PIVPTR = I_NBPANELS + 1 ! U I_PIV = I_PIVPTR + NBPANELS ! U ENDIF RETURN END SUBROUTINE SMUMPS_GET_OOC_PERM_PTR SUBROUTINE SMUMPS_OOC_PP_SET_PTR(K50,NBPANELS_L,NBPANELS_U, & NASS, IPOS, IW, LIW ) IMPLICIT NONE C C Purpose: C ======= C C Initialize the contents of PIV/PIVPTR/etc. that will store C pivoting information during the factorization. C NASS and NBPANELS are recorded. PIVPTR(1:NBPANELS) C is initialized to NASS+1. This will be modified during C the factorization in cases where permutations have to C be performed during the solve phase. C C Arguments: C ========= C INTEGER K50 INTEGER IPOS, NASS, NBPANELS_L, NBPANELS_U, LIW INTEGER IW(LIW) C C Local variables: C =============== C INTEGER IPOS_U C Executable statements IF (K50.EQ.1) THEN WRITE(*,*) "Internal error: SMUMPS_OOC_PP_SET_PTR called" ENDIF IW(IPOS)=NASS IW(IPOS+1)=NBPANELS_L IW(IPOS+2:IPOS+1+NBPANELS_L)=NASS+1 IF (K50 == 0) THEN IPOS_U=IPOS+2+NASS+NBPANELS_L IW(IPOS_U)=NBPANELS_U IW(IPOS_U+1:IPOS_U+NBPANELS_U)=NASS+1 ENDIF RETURN END SUBROUTINE SMUMPS_OOC_PP_SET_PTR SUBROUTINE SMUMPS_OOC_PP_TRYRELEASE_SPACE ( & IWPOS, IOLDPS, IW, LIW, MonBloc, NFRONT, KEEP & ) USE SMUMPS_OOC IMPLICIT NONE INCLUDE 'mumps_headers.h' C C Purpose: C ======= C If space used was at the top of the stack then C try to free space by detecting that C no permutation needs to be applied during C solve on panels. C One position is left (I_NASS) and set to -1 C to indicate that permutation not needed at solve. C C Arguments: C ========= C INTEGER, INTENT(IN) :: IOLDPS, LIW, NFRONT, & KEEP(500) INTEGER, INTENT(INOUT) :: IWPOS, IW(LIW) TYPE(IO_BLOCK), INTENT(IN):: MonBloc C C Local variables: C =============== C INTEGER :: NBPANELS_L,I_PIVRPTR_L, I_PIVR_L, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, XSIZE, IBEGOOC LOGICAL FREESPACE ! set to true when permutation not needed C Executable statements IF (KEEP(50).EQ.1) RETURN ! no pivoting C -------------------------------- C quick return if record is not at C the top of stack of L factors IF ((IOLDPS+IW(IOLDPS+XXI)).NE.IWPOS) RETURN C --------------------------------------------- C Panel+pivoting: get pointers on each subarray C --------------------------------------------- XSIZE = KEEP(IXSZ) IBEGOOC = IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE C -- get L related data CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IBEGOOC, IW, LIW) FREESPACE = & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_L)-1)) IF (KEEP(50).EQ.0) THEN C -- get U related dataA CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IBEGOOC, IW, LIW) FREESPACE = FREESPACE .AND. & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_U)-1)) ENDIF C --------------------------------- C Check if permutations eed be C performed on panels during solve C -------------------------------- IF (FREESPACE) THEN C -- compress memory for that node: keep one entry set to -7777 IW(IBEGOOC) = -7777 ! will be tested during solve IW(IOLDPS+XXI) = IBEGOOC & - IOLDPS + 1 ! new size of inode's record IWPOS = IBEGOOC+1 ! move back to top of stack ENDIF RETURN END SUBROUTINE SMUMPS_OOC_PP_TRYRELEASE_SPACE C SUBROUTINE SMUMPS_OOC_GET_PP_SIZES(K50, NBROW_L, NBCOL_U, NASS, & NBPANELS_L, NBPANELS_U, LREQ) USE SMUMPS_OOC ! To call SMUMPS_OOC_PANEL_SIZE IMPLICIT NONE C C Purpose C ======= C C Compute the size of the workspace required to store the permutation C information during factorization, so that solve can permute back C what has to be permuted (this could not be done during factorization C because it was already on disk). C C Arguments C ========= C INTEGER, intent(IN) :: K50, NBROW_L, NBCOL_U, NASS INTEGER, intent(OUT) :: NBPANELS_L, NBPANELS_U, LREQ NBPANELS_L=-99999 NBPANELS_U=-99999 C C Quick return in SPD case (no pivoting) C IF (K50.EQ.1) THEN LREQ = 0 RETURN ENDIF C C L information is always computed C NBPANELS_L = (NASS / SMUMPS_OOC_PANEL_SIZE(NBROW_L))+1 LREQ = 1 ! Store NASS & + 1 ! Store NBPANELS_L & + NASS ! Store permutations & + NBPANELS_L ! Store pointers on permutations IF (K50.eq.0) THEN C C Also take U information into account C NBPANELS_U = (NASS / SMUMPS_OOC_PANEL_SIZE(NBCOL_U) ) +1 LREQ = LREQ + 1 ! Store NBPANELS_U & + NASS ! Store permutations & + NBPANELS_U ! Store pointers on permutations ENDIF RETURN END SUBROUTINE SMUMPS_OOC_GET_PP_SIZES SUBROUTINE SMUMPS_OOC_PP_CHECK_PERM_FREED & (IW_LOCATION, MUST_BE_PERMUTED) IMPLICIT NONE INTEGER, INTENT(IN) :: IW_LOCATION LOGICAL, INTENT(INOUT) :: MUST_BE_PERMUTED C C Purpose C ======= C C Reset MUST_BE_PERMUTED to .FALSE. when we detect C that the SMUMPS_OOC_PP_TRY_RELEASE_SPACE has freed C the permutation information (see that routine). C IF (IW_LOCATION .EQ. -7777) THEN MUST_BE_PERMUTED = .FALSE. ENDIF RETURN END SUBROUTINE SMUMPS_OOC_PP_CHECK_PERM_FREED MUMPS_5.8.1/src/cend_driver.F0000664000175000017500000006131015042446441015625 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_END_DRIVER( id, idintr ) USE CMUMPS_STRUC_DEF, ONLY: CMUMPS_STRUC USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_INTR_STRUC IMPLICIT NONE C C Purpose: C ======= C C Terminate a MUMPS instance. Free all internal data structure and C suppress OOC files on disk, if any. C C Argument: C ======== C TYPE( CMUMPS_STRUC ) :: id TYPE( CMUMPS_INTR_STRUC ) :: idintr C C Local declarations C ================== INTEGER IERR INTEGER, PARAMETER :: MASTER = 0 C C Executable statements C ===================== C C First, free all MUMPS internal data except communicators created C during a call to MUMPS wit JOB=-1 CALL CMUMPS_FREE_DATA_ANAFACSOL( id, idintr ) C C Allocated during JOB=-1: IF ( id%MYID .NE. MASTER .OR. id%KEEP(46) .ne. 0 ) THEN C Note that on some very old platforms, COMM_NODES would have been C freed inside BLACS_GRIDEXIT, which may cause problems C in the call to MPI_COMM_FREE. CALL MPI_COMM_FREE( id%COMM_NODES, IERR ) C Free communicator related to load messages. CALL MPI_COMM_FREE( id%COMM_LOAD, IERR ) END IF CALL MUMPS_DESTROY_ARCH_NODE_COMM( id%KEEP(411), id%KEEP(410), & id%KEEP(413) ) C Nullifying id%SCHUR_CINTERFACE here is not necessary, C it is freed systematically each time we exit CMUMPS_DRIVER C and reset each time we enter MUMPS through its C interface. NULLIFY(id%SCHUR_CINTERFACE) C RETURN END SUBROUTINE CMUMPS_END_DRIVER C SUBROUTINE CMUMPS_END_ROOT(roota) USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE(CMUMPS_ROOT_STRUC) :: roota IF (associated(roota%RHS_CNTR_MASTER_ROOT)) THEN DEALLOCATE(roota%RHS_CNTR_MASTER_ROOT) NULLIFY(roota%RHS_CNTR_MASTER_ROOT) ENDIF IF (associated(roota%RHS_ROOT))THEN DEALLOCATE(roota%RHS_ROOT) NULLIFY(roota%RHS_ROOT) ENDIF CALL CMUMPS_RR_FREE_POINTERS(roota) RETURN END SUBROUTINE CMUMPS_END_ROOT C SUBROUTINE CMUMPS_FREE_DATA_ANAFACSOL(id, idintr) USE CMUMPS_STRUC_DEF USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_INTR_STRUC IMPLICIT NONE C C Purpose: C ======= C Free all MUMPS internal data, except communicators built during C a JOB=-1 call. Called by CMUMPS_END_DRIVER and CMUMPS_ANA_DRIVER. C Calls CMUMPS_FREE_DATA_FACTO, which frees most of the data allocated C during factorization and solve, except: C - scaling arrays, because they are sometimes allocated at analysis C - STEP2NODE, which can be reused when analysis does not change C Therefore, scaling arrays and STEP2NODE are freed here. C C Arguments C ========= TYPE( CMUMPS_STRUC ) :: id TYPE( CMUMPS_INTR_STRUC ) :: idintr C Local declarations C ================== LOGICAL I_AM_SLAVE INTEGER, PARAMETER :: MASTER = 0 C C Executable statements C --------------------- C I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) C C First, free data from factoriation and solve: CALL CMUMPS_FREE_DATA_FACTO(id,idintr) C ------------------------------------- C Right-hand-side and solutions are C always user data, we do not free them C ------------------------------------- IF (associated(id%MEM_DIST)) THEN DEALLOCATE(id%MEM_DIST) NULLIFY(id%MEM_DIST) ENDIF C --------------------------------- C Allocated by CMUMPS, Used by user. C CMUMPS deallocates. User should C use them before CMUMPS_END_DRIVER or C copy. C --------------------------------- IF (associated(id%MAPPING)) THEN DEALLOCATE(id%MAPPING) NULLIFY(id%MAPPING) END IF C ------------------------------------- C Always deallocate scaling arrays C if they are associated, except C when provided by the user (on master) C ------------------------------------- IF ( id%KEEP(52) .NE. -1 .or. id%MYID .ne. MASTER ) THEN IF (associated(id%COLSCA)) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ENDIF IF (associated(id%ROWSCA)) THEN DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF END IF C Begin PRUN_NODES C Info for pruning tree IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF C END PRUN_NODES c --------------------- C Allocated during analysis: IF (associated(id%NE_STEPS)) THEN DEALLOCATE(id%NE_STEPS) NULLIFY(id%NE_STEPS) ENDIF C Allocated during analysis: IF (associated(id%ND_STEPS)) THEN DEALLOCATE(id%ND_STEPS) NULLIFY(id%ND_STEPS) ENDIF C Allocated during analysis: IF (associated(id%FRERE_STEPS)) THEN DEALLOCATE(id%FRERE_STEPS) NULLIFY(id%FRERE_STEPS) ENDIF C Allocated during analysis: IF (associated(id%DAD_STEPS)) THEN DEALLOCATE(id%DAD_STEPS) NULLIFY(id%DAD_STEPS) ENDIF C Allocated during analysis: IF (associated(id%SYM_PERM)) THEN DEALLOCATE(id%SYM_PERM) NULLIFY(id%SYM_PERM) ENDIF IF (associated(id%STEP)) THEN DEALLOCATE(id%STEP) NULLIFY(id%STEP) ENDIF IF (associated(id%LRGROUPS)) THEN DEALLOCATE(id%LRGROUPS) NULLIFY(id%LRGROUPS) ENDIF IF (associated(id%FILS)) THEN DEALLOCATE(id%FILS) NULLIFY(id%FILS) ENDIF IF (associated(id%UNS_PERM)) THEN DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF CC Allocated during analysis: IF (associated(id%FRTPTR)) THEN DEALLOCATE(id%FRTPTR) NULLIFY(id%FRTPTR) ENDIF C Allocated during analysis: IF (associated(id%FRTELT)) THEN DEALLOCATE(id%FRTELT) NULLIFY(id%FRTELT) ENDIF C Allocated during analysis: IF (associated(id%NA)) THEN DEALLOCATE(id%NA) NULLIFY(id%NA) ENDIF C Allocated during analysis: IF (associated(id%PROCNODE_STEPS)) THEN DEALLOCATE(id%PROCNODE_STEPS) NULLIFY(id%PROCNODE_STEPS) ENDIF IF (associated(id%ELTPROC)) THEN DEALLOCATE(id%ELTPROC) NULLIFY(id%ELTPROC) ENDIF C Allocated at analysis: IF (associated(id%CANDIDATES)) THEN DEALLOCATE(id%CANDIDATES) NULLIFY(id%CANDIDATES) ENDIF C Allocated at analysis: IF (associated(id%I_AM_CAND)) THEN DEALLOCATE(id%I_AM_CAND) NULLIFY(id%I_AM_CAND) ENDIF C Allocated at analysis: IF (associated(id%ISTEP_TO_INIV2)) THEN DEALLOCATE(id%ISTEP_TO_INIV2) NULLIFY(id%ISTEP_TO_INIV2) ENDIF C Node partitionning (only allocated on slaves) IF (I_AM_SLAVE) THEN C Allocated at analysis: IF (associated(id%TAB_POS_IN_PERE)) THEN DEALLOCATE(id%TAB_POS_IN_PERE) NULLIFY(id%TAB_POS_IN_PERE) ENDIF ENDIF IF (I_AM_SLAVE) THEN C Allocated at analysis: IF (associated(id%FUTURE_NIV2)) THEN DEALLOCATE(id%FUTURE_NIV2) NULLIFY(id%FUTURE_NIV2) ENDIF ENDIF C Allocated at analysis: IF(associated(id%DEPTH_FIRST))THEN DEALLOCATE(id%DEPTH_FIRST) NULLIFY(id%DEPTH_FIRST) ENDIF C Allocated at analysis: IF(associated(id%DEPTH_FIRST_SEQ))THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) NULLIFY(id%DEPTH_FIRST_SEQ) ENDIF C Allocated at analysis: IF(associated(id%SBTR_ID))THEN DEALLOCATE(id%SBTR_ID) NULLIFY(id%SBTR_ID) ENDIF C Allocated and initialized at analysis: IF(associated(id%SCHED_DEP))THEN DEALLOCATE(id%SCHED_DEP) NULLIFY(id%SCHED_DEP) ENDIF C Allocated and initialized at analysis: IF(associated(id%SCHED_SBTR))THEN DEALLOCATE(id%SCHED_SBTR) NULLIFY(id%SCHED_SBTR) ENDIF C Allocated and initialized at analysis: IF(associated(id%SCHED_GRP))THEN DEALLOCATE(id%SCHED_GRP) NULLIFY(id%SCHED_GRP) ENDIF C Allocated and initialized at analysis: IF(associated(id%CROIX_MANU))THEN DEALLOCATE(id%CROIX_MANU) NULLIFY(id%CROIX_MANU) ENDIF C Allocated during analysis: IF (associated(id%PTRAR)) THEN DEALLOCATE(id%PTRAR) NULLIFY(id%PTRAR) ENDIF C Allocated at analysis: IF (associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) NULLIFY(id%MEM_SUBTREE) ENDIF C Allocated at analysis: IF (associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) NULLIFY(id%MY_ROOT_SBTR) ENDIF C Allocated at analysis: IF (associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) NULLIFY(id%MY_FIRST_LEAF) ENDIF C Allocated at analysis: IF (associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) NULLIFY(id%MY_NB_LEAF) ENDIF C Allocated at analysis: IF (associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) NULLIFY(id%COST_TRAV) ENDIF C Allocated at analysis: IF (associated(id%CB_SON_SIZE)) THEN DEALLOCATE(id%CB_SON_SIZE) NULLIFY(id%CB_SON_SIZE) ENDIF C Allocated at analysis: IF (associated(id%SUP_PROC)) THEN DEALLOCATE(id%SUP_PROC) NULLIFY(id%SUP_PROC) ENDIF ! IF(id%KEEP(486).NE.0) THEN C Allocated at analysis: IF (associated(id%LRGROUPS)) THEN DEALLOCATE(id%LRGROUPS) NULLIFY(id%LRGROUPS) ENDIF ! ENDIF C C free data concerned when redoing cheap analysis CALL CMUMPS_FREE_DATA_REDO_ANA( id ) C C gridinit performed at analysis: #if ! defined(NOSCALAPACK) IF (idintr%root%gridinit_done) THEN IF ( id%KEEP(38).NE.0 .and. idintr%root%yes ) THEN CALL blacs_gridexit( idintr%root%CNTXT_BLACS ) idintr%root%gridinit_done = .FALSE. END IF END IF #endif RETURN END SUBROUTINE CMUMPS_FREE_DATA_ANAFACSOL SUBROUTINE CMUMPS_FREE_DATA_REDO_ANA ( id ) USE CMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C Free all MUMPS internal data concerned C when redoing a cheap analysis : C - data related to MPI2KOMP allocated during analysis C - data related to L0OMP allocated during analysis C - data related to building arrowheads because C of EARLYT3ROOTINS that might change when of C L0-thread (KEEP(400) C Arguments C ========= TYPE( CMUMPS_STRUC ) :: id C C Executable statements C --------------------- CCN#if defined(MPI_TO_K_OMP) C Allocated at analysis: IF (associated(id%MTKO_PROCS_MAP)) THEN DEALLOCATE(id%MTKO_PROCS_MAP) NULLIFY(id%MTKO_PROCS_MAP) ENDIF C Allocated at analysis: IF (associated(id%IPOOL_B_L0_OMP)) THEN DEALLOCATE(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_B_L0_OMP) END IF IF (associated(id%IPOOL_A_L0_OMP)) THEN DEALLOCATE(id%IPOOL_A_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) END IF IF (associated(id%PHYS_L0_OMP)) THEN DEALLOCATE(id%PHYS_L0_OMP) NULLIFY(id%PHYS_L0_OMP) END IF IF (associated(id%VIRT_L0_OMP)) THEN DEALLOCATE(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP) END IF IF (associated(id%VIRT_L0_OMP_MAPPING)) THEN DEALLOCATE(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%VIRT_L0_OMP_MAPPING) END IF IF (associated(id%PERM_L0_OMP)) THEN DEALLOCATE(id%PERM_L0_OMP) NULLIFY(id%PERM_L0_OMP) END IF IF (associated(id%PTR_LEAFS_L0_OMP)) THEN DEALLOCATE(id%PTR_LEAFS_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) END IF C Allocated at analysis: IF (associated(id%I4_L0_OMP)) THEN DEALLOCATE(id%I4_L0_OMP) NULLIFY(id%I4_L0_OMP) END IF C Allocated at analysis: IF (associated(id%I8_L0_OMP)) THEN DEALLOCATE(id%I8_L0_OMP) NULLIFY(id%I8_L0_OMP) END IF C ================================================= C BEGIN Pointers to original matrix C allocated during analysis C in format ready for assembly during factorization C (arrowheads if assembled format) C Allocated during analysis: C id%PTRAR is allocated in ana_driver and C should not be deallocated here (it does not C change in sze) IF (associated(id%PTR8ARR)) THEN DEALLOCATE(id%PTR8ARR) NULLIFY(id%PTR8ARR) ENDIF C Allocated during analysis: IF (associated(id%NINCOLARR)) THEN DEALLOCATE(id%NINCOLARR) NULLIFY(id%NINCOLARR) ENDIF C Allocated during analysis: IF (associated(id%NINROWARR)) THEN DEALLOCATE(id%NINROWARR) NULLIFY(id%NINROWARR) ENDIF C Allocated during analysis: IF (associated(id%PTRDEBARR)) THEN DEALLOCATE(id%PTRDEBARR) NULLIFY(id%PTRDEBARR) ENDIF C ================================================= RETURN END SUBROUTINE CMUMPS_FREE_DATA_REDO_ANA SUBROUTINE CMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8, K34) USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_END USE CMUMPS_LR_DATA_M, only : CMUMPS_BLR_STRUC_TO_MOD, & CMUMPS_BLR_END_MODULE IMPLICIT NONE C C Purpose: C ======= C C Free data from modules kept from one phase to the other C and referenced through the main MUMPS structure, id. C C Both id%FDM_F_ENCODING and id%BLRARRAY_ENCODING C are concerned. C C C C Arguments: C ========= C # if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) INTEGER, intent(in) :: K34 C IF (associated(id_FDM_F_ENCODING)) THEN C Allow access to FDM_F data for BLR_END_MODULE CALL MUMPS_FDM_STRUC_TO_MOD('F', id_FDM_F_ENCODING) IF (associated(id_BLRARRAY_ENCODING)) THEN C Pass id_BLRARRAY_ENCODING control to module C and terminate BLR module of current instance CALL CMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) CALL CMUMPS_BLR_END_MODULE(0, KEEP8, K34, & LRSOLVE_ACT_OPT=.TRUE.) ENDIF C --------------------------------------- C FDM data structures are still allocated C in the module and should be freed C --------------------------------------- CALL MUMPS_FDM_END('F') ENDIF RETURN END SUBROUTINE CMUMPS_FREE_ID_DATA_MODULES C C ----------------------------------------------------------------- C SUBROUTINE CMUMPS_FREE_DATA_FACTO(id,idintr) C C Purpose: C ------- C C CMUMPS_FREE_DATA_FACTO frees data that was allocated during C factorization and that can be useful for the solve. Afterwards, C data from analysis is kept so that a new factorization phase C is possible. C C Module depencies C ---------------- USE CMUMPS_STRUC_DEF, ONLY: CMUMPS_STRUC USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_INTR_STRUC USE CMUMPS_FACSOL_L0OMP_M, ONLY : CMUMPS_FREE_L0_OMP_FACTORS USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_FREE_S_WK USE MUMPS_BUF_COMMON, ONLY : & MUMPS_BUF_DEALL_CB, & MUMPS_BUF_DEALL_SMALL_BUF IMPLICIT NONE C C Argument: C -------- C C id is the main MUMPS structure, giving with idintr access C to all internal objects allocated by the package. C TYPE( CMUMPS_STRUC) :: id TYPE( CMUMPS_INTR_STRUC ) :: idintr C C Local declarations C ------------------ INTEGER :: IERR LOGICAL :: I_AM_SLAVE INTEGER, PARAMETER :: MASTER = 0 C C Interface blocks C ---------------- INTERFACE C (explicit needed because of pointer arguments) SUBROUTINE CMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8, K34) # if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) INTEGER, intent(in) :: K34 END SUBROUTINE CMUMPS_FREE_ID_DATA_MODULES END INTERFACE C I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) C C Free OOC-related data C --------------------- C (this includes suppression of OOC files) IF (id%KEEP(201).GT.0 .AND. I_AM_SLAVE) THEN CALL CMUMPS_CLEAN_OOC_DATA(id,IERR) IF (IERR < 0) THEN id%INFO(1) = -90 id%INFO(2) = 0 ENDIF END IF CALL MUMPS_PROPINFO(id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID) IF (associated(id%PTLUST_S)) THEN DEALLOCATE(id%PTLUST_S) NULLIFY(id%PTLUST_S) END IF IF (associated(id%PTRFAC)) THEN DEALLOCATE(id%PTRFAC) NULLIFY(id%PTRFAC) END IF IF (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) ENDIF IF (associated(id%PIVNUL_LIST)) THEN DEALLOCATE(id%PIVNUL_LIST) NULLIFY(id%PIVNUL_LIST) ENDIF IF (associated(id%ROWSCA_loc)) THEN DEALLOCATE(id%ROWSCA_loc) NULLIFY(id%ROWSCA_loc) ENDIF IF (id%KEEP(50) .EQ. 0) THEN IF (associated(id%COLSCA_loc)) THEN DEALLOCATE(id%COLSCA_loc) ENDIF ENDIF NULLIFY(id%COLSCA_loc) C IPIV is used both for ScaLAPACK and RR C Keep it outside CMUMPS_RR_FREE_POINTERS IF (associated(idintr%root%IPIV)) THEN DEALLOCATE(idintr%root%IPIV) NULLIFY(idintr%root%IPIV) ENDIF CALL CMUMPS_END_ROOT(idintr%roota) IF (associated(id%SINGULAR_VALUES)) THEN DEALLOCATE(id%SINGULAR_VALUES) NULLIFY(id%SINGULAR_VALUES) ENDIF C Free module data from factorization: CALL CMUMPS_FREE_ID_DATA_MODULES(id%FDM_F_ENCODING, ! done & id%BLRARRAY_ENCODING, id%KEEP8(1), id%KEEP(34)) C --------------------------- C Deallocate main workarray S C --------------------------- IF (id%KEEP8(24).EQ.0_8) THEN C -- deallocate only when not provided/allocated by the user IF (associated(id%S)) THEN CALL CMUMPS_DM_FREE_S_WK(id%S, id%KEEP(430)) ENDIF C Reset KEEP(430)=0 since S is free C KEEP(430) will be redefined during facto id%KEEP(430) = 0 C Update allocated size of S: id%KEEP8(23)=0_8 ENDIF NULLIFY(id%S) IF (I_AM_SLAVE) THEN C ------------------------ C Deallocate buffer for C contrib-blocks (facto/ C solve). Note that this C will cancel all possible C pending requests. C ------------------------ CALL MUMPS_BUF_DEALL_CB( IERR ) C Deallocate buffer for integers (facto/solve) CALL MUMPS_BUF_DEALL_SMALL_BUF( IERR ) END IF C IF (associated(id%L0_OMP_MAPPING)) THEN DEALLOCATE(id%L0_OMP_MAPPING) NULLIFY(id%L0_OMP_MAPPING) END IF IF (associated(idintr%L0_OMP_FACTORS)) THEN CALL CMUMPS_FREE_L0_OMP_FACTORS(idintr%L0_OMP_FACTORS) END IF C C Data allocated during solve C --------------------------- C C (or for some of it, factorization -- forward during factorization) IF (associated(id%RHSINTR)) THEN DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25)=0_8 ENDIF IF (associated(id%GLOB2LOC_RHS)) THEN DEALLOCATE(id%GLOB2LOC_RHS) NULLIFY(id%GLOB2LOC_RHS) ENDIF IF (id%GLOB2LOC_SOL_ALLOC) THEN DEALLOCATE(id%GLOB2LOC_SOL) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF C Allocated during solve: C (even in case of fwd in facto) IF (associated(id%IPTR_WORKING)) THEN DEALLOCATE(id%IPTR_WORKING) NULLIFY(id%IPTR_WORKING) END IF IF (associated(id%WORKING)) THEN DEALLOCATE(id%WORKING) NULLIFY(id%WORKING) END IF RETURN END SUBROUTINE CMUMPS_FREE_DATA_FACTO SUBROUTINE CMUMPS_FREE_DATA_RHSINTR(id) C C Purpose: C ------- C Free RHSINTR related data that might C have been generated after a forward only step (ICNTL(26)=1) C Module depencies C ---------------- USE CMUMPS_STRUC_DEF IMPLICIT NONE C C Argument: C -------- C C id is the main MUMPS structure, giving with idintr access C to all internal objects allocated by the package. C TYPE( CMUMPS_STRUC) :: id C IF (associated(id%RHSINTR)) THEN DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25)=0_8 id%LD_RHSINTR = 0 ENDIF IF (associated(id%GLOB2LOC_RHS)) THEN DEALLOCATE(id%GLOB2LOC_RHS) NULLIFY(id%GLOB2LOC_RHS) ENDIF IF (id%GLOB2LOC_SOL_ALLOC) THEN DEALLOCATE(id%GLOB2LOC_SOL) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF RETURN END SUBROUTINE CMUMPS_FREE_DATA_RHSINTR SUBROUTINE CMUMPS_CLEAN_OOC_DATA(id,IERR) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_STRUC IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id INTEGER IERR IERR=0 CALL CMUMPS_OOC_CLEAN_FILES(id,IERR) IF(associated(id%OOC_TOTAL_NB_NODES))THEN DEALLOCATE(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_TOTAL_NB_NODES) ENDIF IF(associated(id%OOC_INODE_SEQUENCE))THEN DEALLOCATE(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_INODE_SEQUENCE) ENDIF IF(associated(id%OOC_SIZE_OF_BLOCK))THEN DEALLOCATE(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_SIZE_OF_BLOCK) ENDIF IF(associated(id%OOC_VADDR))THEN DEALLOCATE(id%OOC_VADDR) NULLIFY(id%OOC_VADDR) ENDIF RETURN END SUBROUTINE CMUMPS_CLEAN_OOC_DATA SUBROUTINE CMUMPS_OOC_CLEAN_FILES(id,IERR) USE CMUMPS_STRUC_DEF USE MUMPS_OOC_COMMON, ONLY : ERR_STR_OOC, & DIM_ERR_STR_OOC, & FILENAMELENGTH IMPLICIT NONE EXTERNAL MUMPS_OOC_REMOVE_FILE_C TYPE(CMUMPS_STRUC) :: id INTEGER IERR INTEGER I,J,I1,K CHARACTER(len=1):: TMP_NAME(FILENAMELENGTH) C Note that Fortran initializes IERR to 0. C The C layer modifies it in case of error. IERR=0 K=1 C WHEN SAVE/RESTORE IS ON, OOC FILES ASSOCIATED TO A SAVED INSTANCE C ARE NOT REMOVED IF(.NOT. id%ASSOCIATED_OOC_FILES) THEN IF(associated(id%OOC_FILE_NAMES).AND. & associated(id%OOC_FILE_NAME_LENGTH))THEN DO I1=1,id%OOC_NB_FILE_TYPE DO I=1,id%OOC_NB_FILES(I1) DO J=1,id%OOC_FILE_NAME_LENGTH(K) TMP_NAME(J)=id%OOC_FILE_NAMES(K,J) ENDDO C Note that termination character '0' is included CALL MUMPS_OOC_REMOVE_FILE_C(IERR, TMP_NAME(1)) IF(IERR.LT.0)THEN IF (id%ICNTL(1).GT.0 .AND. id%ICNTL(4).GE.1)THEN WRITE(id%ICNTL(1),*) id%MYID,': ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF ENDIF K=K+1 ENDDO ENDDO ENDIF ENDIF IF(associated(id%OOC_FILE_NAMES))THEN DEALLOCATE(id%OOC_FILE_NAMES) NULLIFY(id%OOC_FILE_NAMES) ENDIF IF(associated(id%OOC_FILE_NAME_LENGTH))THEN DEALLOCATE(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAME_LENGTH) ENDIF IF(associated(id%OOC_NB_FILES))THEN DEALLOCATE(id%OOC_NB_FILES) NULLIFY(id%OOC_NB_FILES) ENDIF RETURN END SUBROUTINE CMUMPS_OOC_CLEAN_FILES MUMPS_5.8.1/src/zini_defaults.F0000664000175000017500000017017515042446442016214 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C********************************************************************** C SUBROUTINE ZMUMPS_SET_TYPE_SIZES( K34, K149, K150, K10 ) IMPLICIT NONE C C Purpose: C ======= C C Set the size in bytes of an "INTEGER" in K34 C Set the size of the default arithmetic (DOUBLE PRECISION, DOUBLE PRECISION, C COMPLEX(kind=8) or DOUBLE COMPLEX(kind=8)) in K149 C Set the size of floating-point types that are real or double C precision even for complex versions of MUMPS (DOUBLE PRECISION for S and C C versions, DOUBLE PRECISION for D and Z versions) C Assuming that the size of an INTEGER(8) is 8, store the ratio C nb_bytes(INTEGER(8)) / nb_bytes(INTEGER) = 8 / K34 into K10. C C In practice, we have: C C K149: Arithmetic Value Value for T3E C S 4 8 C D 8 16 C C 8 16 C Z 16 32 C C K150 = K149 for S and D arithmetics C K150 = K149 / 2 for C and Z arithmetics C C K34= 4 and K10 = 2, except on CRAY machines or when compilation C flag -i8 is used, in which case, K34 = 8 and K10 = 1 C INTEGER, INTENT(OUT) :: K34, K149, K10, K150 INTEGER(8) :: SIZE_INT, SIZE_REAL_OR_DOUBLE ! matches MUMPS_INT8 INTEGER I(2) DOUBLE PRECISION R(2) ! Will be DOUBLE PRECISION if 1 CALL MUMPS_SIZE_C(I(1),I(2),SIZE_INT) CALL MUMPS_SIZE_C(R(1),R(2),SIZE_REAL_OR_DOUBLE) K34 = int(SIZE_INT) K10 = 8 / K34 K150 = int(SIZE_REAL_OR_DOUBLE) K149 = K150 K149 = K149 * 2 RETURN END SUBROUTINE ZMUMPS_SET_TYPE_SIZES C C********************************************************************** C SUBROUTINE ZMUMPSID( NSLAVES, LWK_USER, CNTL, ICNTL, & KEEP,KEEP8, & INFO, INFOG, RINFO, RINFOG, SYM, PAR, & DKEEP, MYID ) !$ USE OMP_LIB IMPLICIT NONE C C Purpose C ======= C C The elements of the arrays CNTL and ICNTL control the action of C ZMUMPS, ZMUMPS_ANA_DRIVER, ZMUMPS_FAC_DRIVER, ZMUMPS_SOLVE_DRIVER C Default values for the elements are set in this routine. C DOUBLE PRECISION DKEEP(230) DOUBLE PRECISION CNTL(15), RINFO(40), RINFOG(40) INTEGER ICNTL(60), KEEP(500), SYM, PAR, NSLAVES, MYID INTEGER INFO(80), INFOG(80) INTEGER(8) KEEP8(150) INTEGER LWK_USER C C Parameters C ========== C=========================================== C Arrays for control and information C=========================================== C C N Matrix order C C NELT Number of elements for matrix in ELt format C C C SYM = 0 ... initializes the defaults for unsymmetric code C = 1,2 ... initializes the defaults for symmetric code C C C C PAR = 0 ... instance where host is not working C = 1 ... instance where host is working as a normal node. C (host uses more memory than other processors in C the latter case) C C CNTL and the elements of the array ICNTL control the action of C ZMUMPS Default values C are set by ZMUMPSID. The elements of the arrays RINFO C and INFO provide information on the action of ZMUMPS. C C CNTL(1) threshold for partial pivoting C has default -1.0 (automatic choice): C 0.1 in case of rank-revealing (ICNTL(56)=1,2) C otherwise 0.0 when SYM=1 and 0.01 otherwise. C Values greater than 1.0 are treated as 1.0 for C SYM=1 and as 0.5 for SYM=2 C In general, a larger value of CNTL(1) leads to C greater fill-in but a more accurate factorization. C If CNTL(1) is nonzero, numerical pivoting will be performed. C If CNTL(1) is zero, no pivoting will be performed and C the subroutine will fail if a zero pivot is encountered. C If the matrix A is diagonally dominant, then C setting CNTL(1) to zero will decrease the factorization C time while still providing a stable decomposition. C C CNTL(2) must be set to the tolerance for convergence of iterative C refinement. C Default value is sqrt(macheps). C Values less than zero are treated as sqrt(macheps). C C CNTL(3) is used with null pivot row detection (ICNTL(24) .eq. 1) C and/or with Rank-Revealing (RR) option (ICNTL(56)). C Default value is 0.0. C Let A_{preproc} be the preprocessed matrix to be factored (see C equation in the user's guide). C A pivot is considered to be null if the infinite norm of its C row/column is smaller than a threshold. Let MACHEPS be the C machine precision and ||.|| be the infinite norm. C The absolute value to detect a null pivot row (when ICNTL(24) .EQ.1) C is stored in DKEEP(1). C In case of RR, CNTL(3) will define the thresholds for : C C - Postponing pseudo singularities (SEUIL): C The computed threshold value for postponing pivots C is stored in "SEUIL" and then "SEUIL_LDLT_NIV2" C which are identical in current version. C C - Defining singularities on root (DKEEP(9)) C C - Defining null pivot rows if ICNTL(24).EQ.1 (DKEEP(1)) C in this case DKEEP(1) must be smaller than DKEEP(9) C C IF (ICNTL(56).NE.0) THEN C RR on root is active C IF (CNTL3 .LT. ZERO) THEN C DKEEP(9) = abs(CNTL(3)) C ELSE IF (CNTL3 .GT. ZERO) THEN C DKEEP(9) = CNTL3*||A_{preproc}|| C ELSE ! (CNTL(3) .EQ. ZERO) THEN C DKEEP(9) = sqrt(N_h)*MACHEPS*||A_{preproc}|| C where Nh is the number of pivots on the deepest branch C of the elimination tree. C ENDIF C IF (ICNTL(24).EQ.1) THEN C null pivot detection C DKEEP(1) = DKEEP(9)*DKEEP(10) C ENDIF C C ELSE (ONLY NULL PIVOT detection is active) C IF CNTL(3) > 0 THEN C DKEEP(1) = CNTL(3) ||A_{preproc}|| C ELSE IF CNTL(3) = 0.0 THEN C DKEEP(1) = MACHEPS sqrt(N_h)||A_{preproc}|| C ELSE IF CNTL(3) < 0 THEN C DKEEP(1) = abs(CNTL(3))! this was added for EDF C ! in the context of SOLSTICE project C ENDIF C ENDIF C C CNTL(4) must be set to value for static pivoting. C Default value is -1.0 C Note that static pivoting is enabled only when C Rank-Revealing and null pivot detection C are off (KEEP(19).EQ.0).AND.(KEEP(110).EQ.0). C If negative, static pivoting will be set OFF (KEEP(97)=0) C If positive, static pivoting is ON (KEEP(97=1) with C threshold CNTL(4) C If = 0, static pivoting is ON with threshold MACHEPS^1/2 || A || C C CNTL(5) fixation for null pivots C Default value is 0.0 C Only active if ICNTL(24) = 1 C If > 0 after finding a null pivot, it is set to CNTL(5) x ||A|| C (This value is stored in DKEEP(2)) C If <= 0 then C SYM=2: C the row/column (except the pivot) is set to zero C and the pivot is set to 1 C SYM=0: C the fixation is automatically C set to a large potitive value and the pivot row of the C U factors is set to zero. C Default is 0. C C CNTL(6) not used yet C C CNTL(7) tolerance for Low Rank approximation of the Blocks (BLR). C Dropping parameter expressed with a double precision, C real value, controlling C compression and used to truncate the RRQR algorithm C default value is 0.0. (i.e. no approximation). C The truncated RRQR operation is implemented as C as variant of the LAPACK GEQP3 and LAQPS routines. C 0.0 : full precision approximation. C > 0.0 : the dropping parameter is DKEEP(8). C C Warning: using negative values is an experimental and C non recommended setting. C < 0.0 : the dropping parameter is |DKEEP(8)|*|Apre|, Apre C as defined in user's guide C C C ----------------------------------------- C C ICNTL(1) has default value 6. C It is the output stream for error messages. C If it is set to zero, these C messages will be suppressed. C C ICNTL(2) has default value 0. C It is the output stream for diagnostic printing and C for warning messages that are local to each MPI process. C If it is set to zero, these messages are suppressed. C C ICNTL(3) -- Host only C It is the output stream for diagnostic printing C and for warning messages. Default value is 6. C If it is set to zero, these messages are suppressed. C C ICNTL(4) is used by ZMUMPS to control printing of error, C warning, and diagnostic messages. It has default value 2. C Possible values are: C C <1 __No messages output. C 1 __Only error messages printed. C 2 __Errors and warnings printed. C 3 __Errors and warnings and terse diagnostics C (only first ten entries C of arrays printed). C 4 __Errors and warnings and all information C on input and output parameters printed. C C C ICNTL(5) is the format of the input matrix and rhs C 0: assembled matrix, assembled rhs C 1: elemental matrix, assembled rhs C Default value is 0. C C ICNTL(6) has default value 7 for unsymmetric and C general symmetric matrices, and 0 for SPD matrices. C It is only accessed and operational C on a call that includes an analysis phase C (JOB = 1, 4, or 6). C In these cases, if ICNTL(6)=1, 2, 3, 4, 5, 6 or 7, C a column permutation based on algorithms described in C Duff and Koster, 1997, *SIMAX <20>, 4, 889-901, C is applied to the original matrix. Column permutations are C then applied to the original matrix to get a zero-free diagonal. C Except for ICNTL(6)=1, the numerical values of the C original matrix, id%A(NE), need be provided by the user C during the analysis phase. C If ICNTL(6)=7, based on the structural symmetry of the C input matrix the value of ICNTL(6) is automatically chosen. C If the ordering is provided by the user C (ICNTL(7)=1) then the value of ICNTL(6) is ignored. C C ICNTL(7) has default value 7 and must be set by the user to C 1 if the pivot order in IS is to be used. C Effective value of ordering stored in KEEP(256). C Possible values are (depending on the softwares installed) C 0 AMD: Approximate minimum degree (included in ZMUMPS package) C 1 Ordering provided by the user C 2 Approximate minimum fill (included in ZMUMPS package) C 3 SCOTCH (see http://gforge.inria.fr/projects/scotch/) C should be downloaded/installed separately. C 4 PORD from Juergen Schulze (js@juergenschulze.de) C PORD package is extracted from the SPACE-1.0 package developed at the C University of Paderborn by Juergen Schulze C and is provided as a separate package. C 5 Metis ordering should be downloaded/installed separately. C 6 Approximate minimum degree with automatic quasi C dense row detection (included in ZMUMPS package). C (to be used when ordering time with AMD is abnormally large) C 7 Automatic choice done during analysis phase C For any other C value of ICNTL(7), a suitable pivot order will be C chosen automatically. C C ICNTL(8) is used to describe the scaling strategy. C Default value is 77. C Note that scaling is performed only when the numerical C factorization step is performed (JOB = 2, 4>, 5>, or 6>). C If ICNTL(8) is not equal to C any of the values listed below then ICNTL(8) is treated C as if it had its default value of 0 (no scaling). C If the matrix is known to be very badly scaled, C our experience has been that option 6 is the most robust but C the best scaling is very problem dependent. C If ICNTL(8)=0, COLSCA and ROWSCA are dummy arguments C of the subroutine that are not accessed. C Possible values of ICNTL(8) are: C C -2 scaling computed during analysis (and applied during the C factorization) C C -1 the user must provide the scaling in arrays C COLSCA and ROWSCA C C 0 no scaling C C 1 Diagonal scaling C C 2 not defined C C 3 Column scaling C C 4 Row and column scaling C C 5,6 not defined C 7, 8 Scaling based on Daniel Ruiz and Bora Ucar's work done C during the ANR-SOLSTICE project. C Reference for this work are: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C This scaling can work on both centralized and distributed C assembled input matrix format. (it works for both symmetric C and unsymmetric matrices) C Option 8 is similar to 7 but more rigourous and expensive to compute. C 77 Automatic choice of scaling value done. Proposed algo: C if (sym=1) then C option = 0 C else C if distributed matrix entry then C option = 7 C else C if (maximum transversal is called C and makes use of numerical values) then C option=-2 and ordering is computed during analysis C else C option = 7 C endif C endif C endif C C ICNTL(9) has default value 1. If ICNTL(9)=1 C the system of equations A * x = b is solved. For other C values the system A^T * x = b is solved. C When ICNTL(30) (compute selected entries in A-1) is activated C ICNTL(9) is ignored. C C ICNTL(10) has default value 0. C If ICNTL(10)=0 : iterative refinement is not performed. C Values of ICNTL(10) < 0 : a fix number of steps equal C to ICNTL(10) of IR is done. C Values of ICNTL(10) > 0 : mean a maximum of ICNTL(10) number C of steps of IR is done, and a test of C convergence is used C C ICNTL(11) has default value 0. C A value equal to 1 will return a backward error estimate in C RINFO(4-11). C A value equal to 2 will return a backward error estimate in C RINFO(4-8). No LCOND 1, 2 and forward error are computed. C If ICNTL(11) is negative, zero or greater than 2 no estimate C is returned. C C C ICNTL(12) has default value 0 and defines the strategy for C LDLT orderings C 0 : automatic choice C 1 : usual ordering (nothing done) C 2 : ordering on the compressed graph, available with all orderings C except with AMD C 3 : constraint ordering, only available with AMF, C -> reset to 2 with other orderings C Other values are treated as 1 (nothing done). C On output KEEP(95) holds the internal value used and INFOG(24) gives C access to KEEP(95) to the user. C in LU facto it is always reset to 1 C C - ICNTL(12) = 3 has a lower priority than ICNTL(7) C thus if ICNTL(12) = 3 and the ordering required is not AMF C then ICNTL(12) is set to 2 C C - ICNTL(12) = 2 has a higher priority than ICNTL(7) C thus if ICNTL(12) = 2 and the ordering required is AMD C then the ordering used is QAMD C C - ICNTL(12) has a higher priority than ICNTL(6) and ICNTL(8) C thus if ICNTL(12) = 2 then ICNTL(6) is automatically C considered as if it was set to a value between 1-6 C if ICNTL(12) = 3 then ICNTL(6) is considered as if C set to 5 and ICNTL(8) as if set to -2 (we need the scaling C factors to define free and constrained variables) C C ICNTL(13) has default value 0 and allows for selecting Type 3 node. C IF ICNTL(13).GT. 0 scalapack is forbidden. Otherwise, C scalapack will be activated if the root is large enough. C Furthermore C IF ((ICNTL(13).GT.0) .AND. (NSLAVES.GT.ICNTL(13), C or ICNTL(13)=-1 THEN C extra splitting of the root will be activated C and is controlled by abs(KEEP(82)). C The order of the root node is divided by KEEP(82) C ENDIF C If ICNTL(13) .EQ. -1 then splitting of the root C is done whatever the nb of procs is. C Authorizing extra root spliting during analysis might be C interesting to further split the root node (combined for C example with null pivot detection option ICNTL(24)=1 OR ICNTL(56)) C C To summarize: C -1 : root splitting and scalapack on C 0 or < -1 : root splitting off and sclalapack on C > 0 : scalapack off C C ICNTL(14) has default value 20 (5 if NSLAVES=1 and SYM=1) C and is the value for memory relaxation C so called "PERLU" in the following. C C C ICNTL(15) : Describes the compression of the graph of the input matrix C The analysis step is then performed on the compressed C graph C Must be set during analysis on the master C 0 : OFF C 1 : Compression provided by the user: C BLKPTR(1:id%NBLK+1) and C BLKVAR(1:N or N_LOC if distributed format) C (BLKVAR(BLKPTR(iblk):BLKPTR(iblk+1)-1): C dof list for iblk) C - If BLKVAR is not provided then BLKVAR is C treated as the identity C (contiguous variables in blocks) C - Distributed format if on MASTER N_LOC#N C C ICNTL(16) : number of OpenMP threads asked by the user. C C ICNTL(17) not used in this version C C ICNTL(18) has default value 0 and is only accessed by the host during C the analysis phase if the matrix is assembled (ICNTL(5))= 0). C ICNTL(18) defines the strategy for the distributed input matrix. C Possible values are: C 0: input matrix is centralized on the host. This is the default C 1: user provides the structure of the matrix on the host at analysis, C ZMUMPS returns C a mapping and user should provide the matrix distributed according C to the mapping C 2: user provides the structure of the matrix on the host at analysis, C and the C distributed matrix on all slave processors at factorization. C Any distribution is allowed C 3: user directly provides the distributed matrix input both C for analysis and factorization C C For flexibility and performance issues, option 3 is recommended. C C ICNTL(19) has default value 0 and is only accessed by the host C during the analysis phase. If ICNTL(19) \neq 0 then Schur matrix will C be returned to the user. C The user must set on entry on the host node (before analysis): C the integer variable SIZE\_SCHUR to the size fo the Schur matrix, C the integer array pointer LISTVAR\_SCHUR to the list of indices C of the schur matrix. C if = 0 : Schur is off and the root node gets factorized C if = 1 : Schur is on and the Schur complement is returned entirely C on a memory area provided by the user ONLY on the host node C if = 2 or 3 : Schur is on and the Schur complement is returned in a C distributed fashion according to a 2D block-cyclic C distribution. In the case where the matrix is symmetric C the lower part is returned if =2 or the complete C matrix if =3. C C ICNTL(20) has default value 0 and is only accessed by the host C during the solve phase. If ICNTL(20)=0, the right-hand side must given C in dense form in the structure component RHS. C If ICNTL(20)=1,2,3, then the right-hand side must be given in sparse form C using the structure components IRHS\_SPARSE, RHS\_SPARSE, IRHS\_PTR and C NZ\_RHS. C When the right-hand side is provided in sparse form then duplicate entries C are summed. C C 0 : dense RHS C 1,2,3 : Sparse RHS C 1 The decision of exploiting sparsity of the right-hand side to C accelerate the solution phase is done automatically. C 2 Sparsity of the right-hand sides is NOT exploited C to improve solution phase. C 3 Sparsity of the right-hand sides is exploited C to improve solution phase. C Values different from 0,1, 2,3 are treated as 0. C For sparse RHS recommended value is 1. C C ICNTL(21) has default value 0 and is only accessed by the host C during the solve phase. If ICNTL(21)=0, the solution vector will be assembled C and stored in the structure component RHS, that must have been allocated by C the user. If ICNTL(21)=1, the solution vector is kept distributed at the C end of the solve phase, and will be available on each slave processor C in the structure components ISOL_loc and SOL_loc. ISOL_loc and SOL_loc C must then have been allocated by the user and must be of size at least C INFO(23), where INFO(23) has been returned by ZMUMPS at the end of the C factorization phase. C Values of ICNTL(21) different from 0 and 1 are currently treated as 0. C C ICNTL(22) (saved in KEEP(201) controls the OOC setting (0=incore, 1 =OOC) C It has default value 0 (incore).Out-of-range values are treated as 0. C If set before analysis then special setting and massage of the tree C might be done (so far only extra splitting CUTNODES) is performed. C It is then accessed by the host C during the factorization phase. If ICNTL(22)=0, then no attempt C to use the disks is made. If ICNTL(22)=1, then ZMUMPS will store C the computed factors on disk for later use during the solution C phase. C C ICNTL(23) has default value 0 and is accessed by ALL processors C at the beginning of the factorization phase. If positive C it corresponds to the maximum size of the working memory C in MegaBytes that MUMPS can allocate per working processor. C If only the host C value is non zero, then other processors also use the value on C the host. Otherwise, each processor uses the local value C provided. C C ICNTL(24) default value is 0 C if = 0 no null pivot detection (CNTL(5) and CNTL(3) are inactive), C = 1 null pivot row detection; CNTL(3) and CNTL(5) are C then used to describe the action taken. C C C ICNTL(25) has default value 0 and is only accessed by the C host during the solution stage. It is only significant if C a null space basis was requested during the factorization C phase (INFOG(28) .GT. 0); otherwise a normal solution step C is performed. C If ICNTL(25)=0, then a normal solution step is performed, C on the internal problem (excluding the null space). C No special property on the solution (discussion with Serge) C If ICNTL(25)=i, 1 <= i <= INFOG(28), then the i-th vector C of the null space basis is computed. In that case, note C that NRHS should be set to 1. C If ICNTL(25)=-1, then all null space is computed. The C user should set NRHS=INFOG(28) in that case. C Note that centralized or distributed solutions are C applicable in that case, but that iterative refinement, C error analysis, etc... are excluded. Note also that the C option to solve the transpose system (ICNTL(9)) is ignored. C C C ICNTL(26) has default value 0 and is accessed on the host only C at the beginning of the solution step. C It is only effective if the Schur option is ON. C (copy in KEEP(221)) C C C During the solution step, a value of 0 will perform a normal C solution step on the reduced problem not involving the Schur C variables. C During the solution step, if ICNTL(26)=1 or 2, then REDRHS C should be allocated of size at least LREDRHS*(NRHS-1)+ C SIZE_SCHUR, where LREDRHS is the leading dimension of C LREDRHS (LREDRHS >= SIZE_SCHUR). C C If ICNTL(26)=1, then only a forward substitution is performed, C and a reduced RHS will be computed and made available in C REDRHS(i+(k-1)*LREDRHS), i=1, ..., SIZE_SCHUR, k=1, ..., NRHS. C If ICNTL(26)=2, then REDRHS(i+(k-1)*LREDRHS),i=1, SIZE_SCHUR, C k=1,NRHS is considered to be the solution corresponding to the C Schur variables. It is injected in ZMUMPS, that computes the C solution on the "internal" problem during the backward C substitution. C C ICNTL(27) controls the blocking factor for multiple right-hand-sides C during the solution phase. C It influences both the memory used (see INFOG(30-31)) and C the solution time C (Larger values of ICNTL(27) leads to larger memory requirements). C Its tuning can be critical when C the factors are written on disk (out-of core, ICNTL(22)=1). C A negative value indicates that automatic setting is C performed by the solver. C C C ICNTL(28) decides whether parallel or sequential analysis should be used. Three C values are possible at the moment: C 0: automatic. This defaults to sequential analysis C 1: sequential. In this case the ordering strategy is defined by ICNTL(7) C 2: parallel. In this case the ordering strategy is defined by ICNTL(29) C C ICNTL(29) defines the ordering too to be used during the parallel analysis. Three C values are possible at the moment: C 0: automatic. This defaults to PT-SCOTCH C 1: PT-SCOTCH. C 2: ParMetis. C C C ICNTL(30) controls the activation of functionality A-1. C It has default value 0 and is only accessed by the master C during the solution phase. It enables the solver to C compute entries in the inverse of the original matrix. C Possible values are: C 0 normal solution C other values: compute entries in A-1 C When ICNTL(30).NE.0 then the user C must describe on entry to the solution phase, C in the sparse right-hand-side C (NZ_RHS, NRHS, RHS_SPARSE, IRHS_SPARSE, IRHS_PTR) C the target entries of A-1 that need be computed. C Note that RHS_SPARSE must be allocated but need not be C initialized. C On output RHS_SPARSE then holds the requested C computed values of A-1. C Note that when ICNTL(30).NE.0 then C - sparse right hand side interface is implicitly used C functionality (ICNTL(20)= 1) but RHS need not be C allocated since computed A-1 entries will be stored C in place. C - ICNTL(9) option (solve Ax=b or Atx=b) is ignored C In case of duplicate entries in the sparse rhs then C on output duplicate entries in the solution are provided C in the same place. C This need not be mentioned in the spec since it is a C "natural" extension. C C ----------- C Fwd in facto C ----------- C ICNTL(31) Must be set before analysis to control storage C of LU factors. Default value is 0. Out of range C values considered as 0. C (copied in KEEP(251) and broadcast, C when setting of ICNTL(31) C results in not factors to be stored then C KEEP(201) = -1, OOC is "suppressed") C 0 Keep factors needed for solution phase C (when option forward during facto is used then C on unsymmetric matrices L factors are not stored) C 1 Solve not needed (solve phase will never be called). C When the user is only interested in the inertia or the C determinant then C all factor matrices need not be stored. C This can also be useful for testing : C to experiment facto OOC without C effective storage of factors on disk. C 2 L factors not stored: meaningful when both C - matrix is unsymmetric and fwd performed during facto C - the user is only interested in the null-space basis C and thus only need the U factors to be stored. C Currently, L factors are always stored in IC. C C ----------- C Fwd in facto C ----------- C ICNTL(32) Must be set before analysis to indicate whether C forward is performed during factorization. C Default value is 0 (normal factorization without fwd) C (copied in KEEP(252) and broadcast) C 0 Normal factorization (default value) C 1 Forward performed during factorization C C C ICNTL(33) Must be set before the factorization phase to compute C the determinant. See also KEEP(258), KEEP(259), C DKEEP(6), DKEEP(7), INFOG(34), RINFOG(12) C C If ICNTL(33)=0 the determinant is not computed C For all other values, the determinant is computed. Note that C null pivots and static pivots are excluded from the C computation of the determinant. C #if ! defined(NO_SAVE_RESTORE) C ICNTL(34) Must be set before a call to MUMPS with JOB=-3 in case C the save/restore feature was used and user wants to clean C save/restore files (and possibly OOC files). C ICTNL(34)=0 => user wants to be able to restore instance later C ICTNL(34)=1 => user will not restore the instance again (clean C to be done) #endif C C ICNTL(35) : Block Low-Rank (BLR) functionality, C need be set before analysis C Default value is 0 C 0: FR factorization and FR solve C 1: Automatic BLR option setting (=> 2) C 2: BLR factorization + BLR Solve C => keep BLR factors only C 3: BLR factorization + FR Solve C Other values are treated as zero C Note that this functionality is currently incompatible C with elemental matrices (ICNTL(5) = 1) and with C forward elimination during factorization (ICNTL(32) = 1) C C ICNTL(36) : Block Low-Rank variant choice C Default value is 0 C 0: UFSC variant, no recompression: Compress step is C performed after the Solve; the low-rank updates are not C recompressed C 1: UFCS variant, no recompression: Factor (with pivoting) on full-rank blocks, C then Compress and finally Solve on low-rank blocks (those where pivoting is not needed, C which depends on the context) C C ICNTL(37) : Compress CB strategy need be set before factorization C 0 = DONT compress CB (default) C 1 = SYSTEMATIC compress CB: compress CB for all candidate fronts C C ICNTL(38): Compression rate of LU factors, can be set before C analysis/factorization C Between 0 and 1000; other values ares treated as 0; C ICNTL(38)/10 is a percentage representing the typical C compressed factors compression of the factor matrices C in BLR fronts: C ICNTL(38)/10= compressed/uncompressed factors × 100. C Default value: 600 C (when factors of BLR fronts are compressed, C their size is 60% of their full- rank size). C ICNTL(39) : Compression rate of Contribution Blocks (CBs) C can be set before analysis/factorization C Between 0 and 1000; other values ares treated as 0; C corresponds to an estimated compression rate of C ICNTL(39)/1000%. C Default value: 500 (50.0% compression rate). C ICNTL(48) : Controls L0_OMP feature. It must be set on the host C before the analysis phase to prepare datastructures C for factorization. C If ICNTL(48) was nonzero during analysis, C L0-OMP will be activated during factorization. C OMP_NUM_THREADS should not change between analysis C and factorization, as long as L0 task scheduling during C factorization is static. C ICNTL(48) can however change between factorization C and solve phases. If activated during analysis, the C number of threads for L0OMP (for both analysis and C factorization) is saved in KEEP(400) (see above). C For LO_OMP feature to be effective during solve C both KEEP(400)>0 and ICNTL(48)>0 are needed C Possible values at analysis: C 0 : off -- L0-OMP is not activated for analysis C and factorization C >0 : on -- L0-OMP is activated for analysis C and factorization C out-of-range values (<0) : off C Possible values at solve: C 0 : off --L0-OMP is not activated for solve. C Possible even if L0-OMP was activated during C analysis/factorization C >0 : on --L0-OMP activated for solve. C Possible only if L0-OMP was activated during C analysis/factorization C if (defined(_OPENMP)) then C default value is 1 (L0-thread ON) C else C default value is 0 (L0thread OFF) C endif C out of range values are treated as 0 C C C ICNTL(49): compact workarray id%S before solution phase C must be set before factorization C 0 : nothing is done. C 1 : compact workarray id%S(MAXS) at the end of the C factorization phase while satisfying the C memory contraint that might have been provided C with ICNTL(23) feature. C 2 : compact workarray id%S(MAXS) at the end of the C factorization phase. The memory C constraint that might have been provided with C ICNTL(23) feature does not apply to this process C Other values are treated as 0. C Default value: 0 C C C ICNTL(56) has default value 0 and is only accessed by the host. C During the analysis phase, a positive value prepares the data for C later use of null space functionalities (saved in KEEP(53)). C (the tree is modified to have only one root in analysis) C If ICNTL(56) is negative or zero, null space feature will C be forbidden during the factorization phase. C During the factorization phase, if ICNTL(56) was positive C (KEEP(53)>0) for analysis, then the values of ICNTL(56) (saved C in KEEP(19)) have the following meaning. C 0: No null space analysis, C 1: Null space analysis on last root node using SVD, C 2: Null space analysis on last root node using QR, C C The singular values (ICNTL(56)=1) or the diagonal entries of R C (ICNTL(56)=2) are available in root%SINGULAR_VALUES C C C C ICNTL(58): strategy for symbolic factorization used C with centralized ordering based on METIS (ICNTL(7)=5) C or with given given ordering (ICNTL(7)=1) C C Default value 2 C 1 => SYMBQAMD based symbolic factorization C 2 => Column count based symbolic factorization C Symbolic factorization based on C [GIMP94] "An efficient algorithm to compute row and column C counts for sparse cholesky factorization" C John R. Gilbert, Esmond G. Ng, and Barry W. Peyton C SIMAX 1994 C implementation of the algorithm described in figure 3 C of the [GINP94] article C C Other values are treated as 1 C C========================= C ARRAYS FOR INFORMATION C======================== C C----- C INFO is an INTEGER array of length 80 that need not be C set by the user. C----- C C INFO(1) is zero if the routine is successful, is negative if an C error occurred, and is positive for a warning (see ZMUMPS for C a partial documentation and the userguide for a full documentation C of INFO(1)). C C INFO(2) holds additional information concerning the C error (see ZMUMPS). C C ------------------------------------------ C Statistics produced after analysis phase C ------------------------------------------ C C INFO(3) Estimated real space needed for factors. C C INFO(4) Estimated integer space needed for factors. C C INFO(5) Estimated maximum frontal size. C C INFO(6) Number of nodes in the tree. C C INFO(7) Minimum value of integer working array IS (old MAXIS) C estimated by the analysis phase C to run the numerical factorization. C C INFO(8) Minimum value of real/complex array S (old MAXS) C estimated by the analysis phase C to run the numerical factorization. C C INFO(15) Estimated size in MBytes of all ZMUMPS internal data C structures to run factorization C C INFO(17) provides an estimation (minimum in Megabytes) C of the total memory required to run C the numerical phases out-of-core. C This memory estimation corresponds to C the least memory consuming out-of-core strategy and it can be C used as a lower bound if the user wishes to provide ICNTL(23). C --------------------------------------- C Statistics produced after factorization C --------------------------------------- C INFO(9) Size of the real space used to store the LU factors possibly C including BLR compressed factors C C INFO(10) Size of the integer space used to store the LU factors C C INFO(11) Order of largest frontal matrix. C C INFO(12) Number of off-diagonal pivots in unsymmetric case / C number of negative pivots in symmetric case C C INFO(13) Number of uneliminated variables sent to the father. C C INFO(14) Number of memory compresses. C C INFO(18) On exit to factorization: C Local number of null pivots (ICNTL(24)=1) C on the local processor even on master. C (local size of array PIVNUL_LIST). C Note that it also includes null pivots C that might have been further detected on C the root if ICNTL(56).NE.0. and root C processed by MYID C C INFO(19) - after analysis: C Estimated size of the main internal integer workarray IS C (old MAXIS) to run the numerical factorization out-of-core. C C INFO(21) - after factorization: Effective space used in the main C real/complex workarray S -- or in the workarray WK_USER, C in the case where WK_USER is provided. C C INFO(22) - after factorization: C Size in millions of bytes of memory effectively used during C factorization. C This includes the memory effectively used in the workarray C WK_USER, in the case where WK_user is provided. C C INFO(23) - after factorization: total number of pivots eliminated C on the processor. In the case of a distributed solution (see C ICNTL(21)), this should be used by the user to allocate solution C vectors ISOL_loc and SOL_loc of appropriate dimensions C (ISOL_LOC of size INFO(23), SOL_LOC of size LSOL_LOC * NRHS C where LSOL_LOC >= INFO(23)) on that processor, between the C factorization and solve steps. C C INFO(24) - after analysis: estimated number of entries in factors on C the processor. If negative, then C the absolute value corresponds to {\it millions} of entries C in the factors. C Note that in the unsymmetric case, INFO(24)=INFO(3). C In the symmetric case, however, INFO(24) < INFO(3). C INFO(25) - after factorization: number of tiny pivots (number of C pivots modified by static pivoting) detected on the processor. C INFO(26) - after solution: C effective size in Megabytes of all working space C to run the solution phase. C (The maximum and sum over all processors are returned C respectively in INFOG(30) and INFOG(31)). C INFO(27) - after factorization: effective number of entries in factors C on the processor. If negative, then C the absolute value corresponds to {\it millions} of entries C in the factors. C Note that in the unsymmetric case, INFO(27)=INFO(9). C In the symmetric case, however, INFO(27) < INFO(9). C The total number of entries over all processors is C available in INFOG(29). C C C ------------------------------------------------------------- C ------------------------------------------------------------- C RINFO is a DOUBLE PRECISION/DOUBLE PRECISION array of length 40 that C need not be set by the user. This array supplies C local information on the execution of ZMUMPS. C C C RINFOG is a DOUBLE PRECISION/DOUBLE PRECISION array of length 40 that C need not be set by the user. This array supplies C global information on the execution of ZMUMPS. C RINFOG is only significant on processor 0 C C C RINFO(1) hold the estimated number of floating-point operations C for the elimination process on the local processor C C RINFOG(1) hold the estimated number of floating-point operations C for the elimination process on all processors C C RINFO(2) Number of floating-point operations C for the assembly process on local processor. C C RINFOG(2) Number of floating-point operations C for the assembly process. C C RINFO(3) Number of floating-point operations C for the elimination process on the local processor. C C RINFOG(3) Number of floating-point operations C for the elimination process on all processors. C C---------------------------------------------------- C Statistics produced after solve with error analysis C---------------------------------------------------- C C RINFOG(4) Infinite norm of the input matrix. C C RINFOG(5) Infinite norm of the computed solution, where C C RINFOG(6) Norm of scaled residuals C C RINFOG(7), `RINFOG(8) and `RINFOG(9) are used to hold information C on the backward error. C We calculate an estimate of the sparse backward error using the C theory and measure developed C by Arioli, Demmel, and Duff (1989). The scaled residual w1 C is calculated for all equations except those C for which numerator is nonzero and the denominator is small. C For the exceptional equations, w2, is used instead. C The largest scaled residual (w1) is returned in C RINFOG(7) and the largest scaled C residual (w2) is returned in `RINFOG(8)>. If all equations are C non exceptional then zero is returned in `RINFOG(8). C The upper bound error is returned in `RINFOG(9). C C RINFOG(14) Number of floating-point operations C for the elimination process (on all fronts, BLR or not) C performed when BLR option is activated on all processors. C (equal to zero if BLR option not used, ICNTL(35).EQ.1) C C RINFOG(15) - after analysis: if the user decides to perform an C out-of-core factorization (ICNTL(22)=1), then a rough C estimation of the total size of the disk space in MegaBytes of C the files written by all processors is provided in RINFOG(15). C C RINFOG(16) - after factorization: in the case of an out-of-core C execution (ICNTL(22)=1), the total C size in MegaBytes of the disk space used by the files written C by all processors is provided. C C RINFOG(17) - after each job: sum over all processors of the sizes C (in MegaBytes) of the files used to save the instance C C RINFOG(18) - after each job: sum over all processors of the sizes C (in MegaBytes) of the MUMPS structures. C C RINFOG(19) - after factorization: smallest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre and considering also C small pivots selected as null-pivots (see ICNTL(24)) C and pivots on which static pivoting was applied C C RINFOG(20) - after factorization: smallest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre and NOT considering C small pivots selected as null-pivots (see ICNTL(24)) C and pivots on which static pivoting was applied C C RINFOG(21) - after factorization: largest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre. C C RINFOG(22) - after factorization: C total number of floating-point operations offloaded to C the accelerator(s) by all MPI processes (see RINFO(9)) C C RINFOG(23) - after factorization: average (over all MPI processes) C time spent in operations offloaded to the accelerators C including communication (see RINFO(10)). C C Computed when solve involves exploit sparsity (fwd and/or bwd) C here we only report off diagonal flops) C #if defined(STAT_ES_SOLVE) C RINFOG(24) - FR FLOPS (off diagonal flops) C RINFOG(25) - FR FLOPS (off diag) with Exploit sparsity C (possibly with nb_sparse algo used) #endif C C C=========================== C DESCRIPTION OF KEEP8 ARRAY C=========================== C C KEEP8 is a 64-bit integer array of length 150 that need not C be set by the user C #if ! defined(NO_SAVE_RESTORE) #endif C=========================== C DESCRIPTION OF KEEP ARRAY C=========================== C C KEEP is an INTEGER array of length 500 that need not C be set by the user. C C C============================= C Description of DKEEP array C============================= C C DKEEP internal control array for DOUBLE PRECISION parameters C of size 30 C=================================== C Default values for control arrays C================================== C uninitialized values should be 0 LWK_USER = 0 KEEP(1:500) = 0 KEEP8(1:150)= 0_8 INFO(1:80) = 0 INFOG(1:80) = 0 ICNTL(1:60) = 0 RINFO(1:40) = 0.0D0 RINFOG(1:40)= 0.0D0 CNTL(1:15) = 0.0D0 DKEEP(1:230) = 0.0D0 C ---------------- C Symmetric code ? C ---------------- KEEP( 50 ) = SYM C Check value of SYM IF (SYM.EQ.1) THEN C C this option is not available with the complex C code on symmetric matrices. C We set KEEP(50) to 2 and will exploit symmetry C up to the root. KEEP(50) = 2 ENDIF C ------------------------------------- C Only options 0, 1, or 2 are available C ------------------------------------- IF ( KEEP(50).NE.1 .and. KEEP(50).NE.2 ) KEEP( 50 ) = 0 C threshold value for pivoting C Automatic choice depending on (SYM and ICNTL(56)) CNTL(1) = -1.0D0 CNTL(2) = sqrt(epsilon(0.0D0)) CNTL(3) = 0.0D0 CNTL(4) = -1.0D0 CNTL(5) = 0.0D0 C Working host ? KEEP(46) = PAR IF ( KEEP(46) .NE. 0 .AND. & KEEP(46) .NE. 1 ) THEN C ---------------------- C If out-of-range value, C use a working host C ---------------------- KEEP(46) = 1 END IF C control printing ICNTL(1) = 6 ICNTL(2) = 0 ICNTL(3) = 6 ICNTL(4) = 2 C format of input matrix ICNTL(5) = 0 C maximum transversal (0=NO, 7=automatic) IF (SYM.NE.1) THEN ICNTL(6) = 7 ELSE ICNTL(6) = 0 ENDIF C Ordering option (icntl(7)) C Default is automatic choice done during analysis ICNTL(7) = 7 C ask for scaling (0=NO, 4=Row and Column) C Default value is 77: automatic choice for analysis ICNTL(8) = 77 C solve Ax=b (1) or Atx=b (other values) ICNTL(9) = 1 C Naximum number of IR (0=NO) ICNTL(10) = 0 C Error analysis (0=NO) ICNTL(11) = 0 C Control ordering strategy C automatic choice IF(SYM .EQ. 2) THEN ICNTL(12) = 0 ELSE ICNTL(12) = 1 ENDIF C Control of the use of ScaLAPACK for root node C If null space options asked, ScaLAPACK is always ignored C and ICNTL(13) is not significant C ICNTL(13) = 0 : Root parallelism on (if size large enough) C ICNTL(13) = 1 : Root parallelism off #if defined(NOSCALAPACK) ICNTL(13) = 1 #else ICNTL(13) = 0 #endif C Default value for the memory relaxation IF (SYM.eq.1.AND.NSLAVES.EQ.1) THEN ICNTL(14) = 5 ! it should work with 0 ELSE ICNTL(14) = 20 END IF IF (NSLAVES.GT.4) ICNTL(14) = ICNTL(14) + 5 IF (NSLAVES.GT.8) ICNTL(14) = ICNTL(14) + 5 IF (NSLAVES.GT.16) ICNTL(14)= ICNTL(14) + 5 C Distributed matrix entry ICNTL(18) = 0 C Schur (default is not active) ICNTL(19) = 0 C dense RHS by default ICNTL(20) = 0 C solution vector centralized on host ICNTL(21) = 0 C out-of-core flag ICNTL(22) = 0 C MEM_ALLOWED (0: not provided) ICNTL(23) = 0 C null pivots ICNTL(24) = 0 C blocking factor for multiple RHS during solution phase ICNTL(27) = -32 C analysis strategy: 0=auto, 1=sequential, 2=parallel ICNTL(28) = 1 C tool used for parallel ordering computation : C 0 = auto, 1 = PT-SCOTCH, 2 = ParMETIS ICNTL(29) = 0 C Default BLR compression rate of factors (60%) ICNTL(38) = 600 C Default BLR compression rate of factors (50%) ICNTL(39) = 500 C L0-thread feature #if defined(_OPENMP) C Activate L0OMP ICNTL(48) = 1 #else C Do not activate L0OMP ICNTL(48) = 0 #endif ICNTL(55) = 0 ICNTL(56) = 0 ICNTL(57) = 0 ICNTL(58) = 2 C=================================== C Default values for some components C of KEEP array C=================================== KEEP(12) = 0 KEEP(24) = 18 KEEP(68) = 0 KEEP(30) = 2000 KEEP(36) = 1 KEEP(1) = 5 KEEP(7) = 150 KEEP(8) = 120 KEEP(57) = 2000 KEEP(58) = 1000 IF ( SYM .eq. 0 ) THEN KEEP(4) = 32 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 32 KEEP(9) = 700 KEEP(85) = 300 KEEP(62) = 10 ELSE KEEP(4) = 24 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 32 KEEP(9) = 400 KEEP(85) = 100 KEEP(62) = 10 END IF KEEP(11)=200 KEEP(63) = 60 KEEP(48) = 5 CALL ZMUMPS_SET_TYPE_SIZES( KEEP(34), KEEP(149), & KEEP(150), KEEP(10) ) KEEP(35)=KEEP(149) KEEP(16)=KEEP(150) KEEP(151)=KEEP(35) KEEP(51) = 70 KEEP(37) = max(800, int(sqrt(dble(NSLAVES+1))*dble(KEEP(51)))) IF ( NSLAVES > 256 ) THEN KEEP(39) = 10000 ELSEIF ( NSLAVES > 128 ) THEN KEEP(39) = 20000 ELSEIF ( NSLAVES > 64 ) THEN KEEP(39) = 40000 ELSEIF ( NSLAVES > 16 ) THEN KEEP(39) = 80000 ELSE KEEP(39) = 160000 END IF KEEP(40) = -1 - 456789 KEEP(45) = 0 KEEP(47) = 2 KEEP(64) = 20 KEEP(69) = 4 C To disable SMP management when using new mapping strategy C KEEP(69) = 1 C Forcing proportional is ok with strategy 5 KEEP(75) = 1 KEEP(76) = 2 KEEP(77) = 0 KEEP(78)= 0 KEEP(79) = 0 ! old splitting KEEP(210) = 2 KEEP8(79) = -10_8 KEEP(80) = 1 KEEP(81) = 0 IF (SYM.EQ.0) THEN KEEP(82)= 15 ELSE KEEP(82) = 10 ENDIF KEEP(83) = -1 KEEP(86)=1 KEEP(87)=0 KEEP(88)=0 KEEP(90)=1 KEEP(91)= -1 KEEP(102)= -1 #if defined(OLD_OOC_NOPANEL) KEEP(99)=0 ! no panel -> synchronous / no buffer #else KEEP(99)=4 ! new OOC -> asynchronous + buffer #endif KEEP(100)=0 KEEP(114) = 1 C Threshold value for null pîvot detection during C LU factorization on root in case of RR KEEP(118)=41 C strategy for MUMPS_BLOC2_GET_NSLAVESMIN KEEP(119)=0 C Scaling is enabled by default with the Schur complement option KEEP(125)=1 C Columns of LMAT handled by block of size KEEP(147) KEEP(147)=20000 C Control buffer size estimation and minimum granularities: C Try to avoid messages smaller than KEEP(170)/1000 of recv buf C ... minimum number of blocks KEEP(171)=10 C ... buffer size reduction factor with respect to worst case IF (SYM.EQ.0) THEN KEEP(172)= 5 ELSE KEEP(172)= 3 ENDIF KEEP(173)= 0 ! 0 = normal IF (SYM.EQ.0) THEN KEEP(178)= 2 ELSE KEEP(178)= 3 ENDIF KEEP(179)= 10 ! default outer block size increase by factor K179 IF (SYM.EQ.0) THEN KEEP(180) = 80 ! % of KEEP(44) to bound MIN_BUF_SIZE_FR KEEP(181) = 50 ! % of KEEP(44) to bound MIN_BUF_SIZE_BLR ELSE KEEP(180) = 200 ! % of KEEP(44) to bound MIN_BUF_SIZE_FR KEEP(181) = 200 ! % of KEEP(44) to bound MIN_BUF_SIZE_BLR ENDIF C amalgamation: to define sons KEEP(191) larger than fathers KEEP(191)= 50 C amalgamation: to define tiny son nodes C (KEEP(192 smaller than father) KEEP(192)= 900 C to limit the amalgamation of tiny nodes KEEP(193)= 50 C More amalgamation of tiny fronts KEEP(197)=1 C KEEP(199) for MUMPS_PROCNODE, MUMPS_TYPENODE, etc C KEEP(199)=NSLAVES + 7 KEEP(199)=-1 KEEP(200)=0 ! root pre-assembled in id%S C Pre-assemble type 3 root in id%S if no L0-OMP, C allocate id%S later otherwise. KEEP(200) = -1 KEEP(204)=0 KEEP(205)=0 KEEP(209)=-1 KEEP(104) = 16 KEEP(107)=0 KEEP(121)=-999999 KEEP(122)=150 C Size of CB for which we want to force BLR compressCB C even if NASS is small. KEEP(123)=10000 KEEP(141)=1 ! min needed KEEP(206)=1 KEEP(207) = 1 KEEP(211)=2 IF (SYM.EQ.0) THEN KEEP(213) = 301 ELSE KEEP(213) = 401 ENDIF KEEP(217)=0 KEEP(215)=0 KEEP(216)=1 KEEP(218)=250 IF (SYM.EQ.2) THEN KEEP(219)=1 ELSE KEEP(219)=0 ENDIF IF (KEEP(50).EQ.2) THEN KEEP(227)= max(2,32) ELSE KEEP(227)= max(1,32) ENDIF KEEP(231) = 1 KEEP(232) = 3 KEEP(233) = 0 KEEP(239) = 1 KEEP(240) = 10 DKEEP(4) = -1.0D0 DKEEP(5) = -1.0D0 DKEEP(10) = -9D0 ! default value is 10D-1 set in fac_driver.F DKEEP(13) = -9D0 ! to define SEUIL for postponing with RR ! (default value is 10 set in fac_driver.F) DKEEP(24) = 1000.0D0 ! gap should be larger than dkeep(14) DKEEP(25) = 10.0D0 ! gap precision DKEEP(22) = 0.5D0 ! to check for slow convergence KEEP(238)=24 KEEP(234)= 1 KEEP(235)=-1 DKEEP(3) =-5.0D0 DKEEP(18)= 1.0D12 KEEP(242) = -9 KEEP(243) = -1 KEEP(255)=100 C Multithreading of norm1 loop during scaling KEEP(281)=8 KEEP(337) = 1 C Parallel analysis compatible with analysis by blocks C and detection out-of-range KEEP(339)= 1 KEEP(249)=1 !$ KEEP(249) = OMP_GET_MAX_THREADS() KEEP(250) = 1 KEEP(261) = 1 KEEP(262) = 0 KEEP(263) = 1 KEEP(266) = 0 KEEP(267) = 0 KEEP(268)=77 KEEP(350) = 2 KEEP(351) = 1 KEEP(360) = 256 KEEP(361) = 2048 KEEP(362) = 4 KEEP(363) = 512 KEEP(364) = 32768 ! 32KiB KEEP(365) = 1024*1024 ! 1MiB KEEP(366) = 450 KEEP(370) = 1 KEEP(375) = 1 KEEP(378) = 1 C OMP parallelization of arrowheads KEEP(399) = -1 KEEP(397) = -1 KEEP(402) = 1 KEEP(405) = 0 ! 1 under L0OMP KEEP(406) = 2 #if defined(__PGLLVM__) C With aocc version of Classic flang, we want to C avoid an OpenMP bug during L0thread copies by C switching to simpler copy algorithm. C Since we cannot test __aocc__ in Fortran, we rely on the C slower algorithm as soon as __PGLLVM__ is detected, even C if this is "too careful". KEEP(406)=0 #endif C 0.9 equilibration KEEP(408) = 90 KEEP(420) = 4*KEEP(6) ! if KEEP(6)=32 then 128 #if defined(GEMMT_AVAILABLE) KEEP(421) = -1 #if defined(__ve__) KEEP(421) = 500 #endif #endif #if defined(ANA_BLKAUTO) C automatic graph compression effective C only if reduction of the number of nodes C in graph smaller than 75% KEEP(440) = 75 #endif C Default size of KEEP(424) is defined below. C It does not depend on arithmetic, C it is related to L1 cache size: 250 * 64 bytes C is about half of the cache size (32768 bytes). C This leaves space in cache for the destination, C of size 250*sizeof(arith). (4k bytes for z) C At each new block of size KEEP(424), there is C probably a cache miss on the pivot. KEEP(424) = 250 KEEP(448) = 0 KEEP(458)=0 #if defined(__ve__) KEEP(458)=1 #endif KEEP(459) = 10 ! max number of panels KEEP(460) = 63 ! min panel size KEEP(461) = 10 KEEP(462) = 100 KEEP(466) = 1 KEEP(468) = 3 KEEP(469) = 3 KEEP(471) = -1 KEEP(479) = 1 KEEP(480) = 3 KEEP(472) = 1 KEEP(476) = 50 KEEP(477) = 100 KEEP(483) = 80 KEEP(484) = 80 KEEP(487) = 1 IF (KEEP(472).EQ.1) THEN KEEP(488) = 768 ELSE KEEP(488) = 8*KEEP(6) ! if KEEP(6)=32 then 256 ENDIF KEEP(490) = 128 KEEP(491) = 1000 #if defined(__ve__) KEEP(490)=512 KEEP(491)=8000 #endif KEEP(492) = 1 KEEP(493) = 0 KEEP(496) = 1 KEEP(495) = -1 KEEP(497) = -1 C RETURN END SUBROUTINE ZMUMPSID SUBROUTINE ZMUMPS_SET_KEEP72(id, LP) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE (ZMUMPS_STRUC) :: id INTEGER LP IF (id%KEEP(72)==1) THEN id%KEEP(37) = 2*id%NSLAVES id%KEEP(3)=3 id%KEEP(4)=2 id%KEEP(5)=1 id%KEEP(6)=2 id%KEEP(9)=3 C KEEP(11) not too small either id%KEEP(11)=3 id%KEEP(39)=300 id%KEEP(7) = 3 id%KEEP(8) = 2 id%KEEP(57)= 3 id%KEEP(58)= 2 id%KEEP(63)=3 id%CNTL(1)=0.1D0 id%KEEP(213) = 101 id%KEEP(85)=2 id%KEEP(85)=-4 id%KEEP(62) = 2 id%KEEP(1) = 1 id%KEEP(123) = 6 id%KEEP(147) = 3 id%KEEP(197) = 0 id%KEEP(51) = 2 !$ id%KEEP(360) = 2 !$ id%KEEP(361) = 2 !$ id%KEEP(362) = 1 !$ id%KEEP(363) = 2 id%KEEP(364) = 10 id%KEEP(366) = 2 id%KEEP(420) = 4 id%KEEP(488) = 4 id%KEEP(490) = 5 id%KEEP(491) = 5 id%ICNTL(27)=-3 id%KEEP(227)=3 id%KEEP(30) = 1000 C ... Try to avoid messages smaller than KEEP(170)/1000 of recv buf C large value to test deadlock C (no effect with KEEP(173)=1) id%KEEP(170) = 500 ! default is 100 C reduce buffer size estimated during analysis C with respect to message size without SMB mechanism C ... minimum nb of blocks is reduced to stress more buffers id%KEEP(171) = 3 ! default is 10 blocs C ... buffer size factor of reduction is increased C to stress more buffers id%KEEP(172) = 10 ! default is 3 C both values of KEEP(173) should be tested id%KEEP(173) = 1 ! 0=normal 1=force blocking id%KEEP(178) = 1 ! reduce it to one panel for FR LDLT CB buf C ... factor of reduction of CB messages is increased id%KEEP(238) = 36 ! default is 24 ELSE IF (id%KEEP(72)==2) THEN C{ id%KEEP(85)=2 ! default is id%KEEP(85)=-10000 ! default is 160 id%KEEP(210) = 1 ! defaults is 0 (automatic) id%KEEP8(79) = 160000_8 id%KEEP(1) = 2 ! default is 8 id%KEEP(102) = 110 ! defaults is 150 up to 48 procs C reduce buffer size estimated during analysis C with respect to message size without SMB mechanism C ... minimum nb of blocks is reduced to stress more buffers id%KEEP(171) = 3 ! default is 10 blocs C ... buffer size factor of reduction is increased C to stress more buffers id%KEEP(172) = 10 ! default is 3 id%KEEP(213) = 121 ! default is 201 C} END IF RETURN END SUBROUTINE ZMUMPS_SET_KEEP72 MUMPS_5.8.1/src/dlr_core.F0000664000175000017500000022471415042446441015143 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C Note: the last routine of this file, xMUMPS_TRUNCATED_RRQR is derived from C the LAPACK package, for which BSD 3-clause license applies C (see header of the routine). MODULE DMUMPS_LR_CORE USE MUMPS_LR_COMMON USE DMUMPS_LR_TYPE USE MUMPS_LR_STATS USE DMUMPS_LR_DATA_M !$ USE OMP_LIB IMPLICIT NONE CONTAINS SUBROUTINE INIT_LRB(LRB_OUT,K,M,N,ISLR) C This routine simply initializes a LR block but does NOT allocate it C (allocation occurs somewhere else) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,M,N LOGICAL,INTENT(IN) :: ISLR LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%ISLR = ISLR NULLIFY(LRB_OUT%Q) NULLIFY(LRB_OUT%R) END SUBROUTINE INIT_LRB C C SUBROUTINE IS_FRONT_BLR_CANDIDATE(INODE, NIV, NFRONT, NASS, & BLRON, K489, & K490, K491, K492, K20, K60, IDAD, K38, & K123, LRSTATUS, K280, LRGROUPS) INTEGER,INTENT(IN) :: INODE, NFRONT, NASS, BLRON, K123, & K489, K490, & K491, K492, NIV, K20, K60, IDAD, K38 INTEGER,INTENT(OUT):: LRSTATUS INTEGER, INTENT(IN):: K280 INTEGER, INTENT(IN), OPTIONAL :: LRGROUPS(K280) C C Local variables LOGICAL :: COMPRESS_PANEL, COMPRESS_CB LRSTATUS = 0 C Type 3 node is not BLR IF (NIV.EQ.3) RETURN COMPRESS_PANEL = .FALSE. IF ((BLRON.NE.0).and.( & ((K492.LT.0).and.INODE.EQ.abs(K492)) & .or. & ( (K492.GT.0).and.(K491.LE.NFRONT) & .and.(K490.LE.NASS)))) THEN COMPRESS_PANEL = .TRUE. C Compression for NASS =1 is useless IF (NASS.LE.1) THEN COMPRESS_PANEL =.FALSE. ENDIF IF (present(LRGROUPS)) THEN IF (LRGROUPS (INODE) .LT. 0) COMPRESS_PANEL = .FALSE. ENDIF ENDIF COMPRESS_CB = .FALSE. IF ((BLRON.NE.0).and. & (K489.GT.0.AND.(K489.NE.2.OR.NIV.EQ.2)) & .and.( & ((K492.LT.0).and.INODE.EQ.abs(K492)) & .or. & ((K492.GT.0).AND.(NFRONT-NASS.GT.K491)))) & THEN COMPRESS_CB = .TRUE. ENDIF IF (.NOT.COMPRESS_PANEL) COMPRESS_CB=.FALSE. IF (COMPRESS_PANEL.OR.COMPRESS_CB) THEN IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN LRSTATUS = 1 ELSE IF (COMPRESS_PANEL.AND.(.NOT.COMPRESS_CB)) THEN LRSTATUS = 2 ELSE LRSTATUS = 3 ENDIF ELSE LRSTATUS = 0 ENDIF C C Schur complement cannot be BLR for now C IF ( INODE .EQ. K20 .AND. K60 .NE. 0 ) THEN LRSTATUS = 0 ENDIF C C Do not compress CB of children of root C IF ( IDAD .EQ. K38 .AND. K38 .NE.0 ) THEN COMPRESS_CB = .FALSE. IF (LRSTATUS.GE.2) THEN LRSTATUS = 2 ELSE LRSTATUS = 0 ENDIF ENDIF RETURN END SUBROUTINE IS_FRONT_BLR_CANDIDATE SUBROUTINE ALLOC_LRB(LRB_OUT,K,M,N,ISLR,IFLAG,IERROR,KEEP8) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,M,N INTEGER,INTENT(INOUT) :: IFLAG, IERROR LOGICAL,INTENT(IN) :: ISLR INTEGER(8) :: KEEP8(150) INTEGER :: MEM, allocok DOUBLE PRECISION :: ZERO PARAMETER (ZERO = 0.0D0) LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%ISLR = ISLR IF ((M.EQ.0).OR.(N.EQ.0)) THEN nullify(LRB_OUT%Q) nullify(LRB_OUT%R) RETURN ENDIF IF (ISLR) THEN IF (K.EQ.0) THEN nullify(LRB_OUT%Q) nullify(LRB_OUT%R) ELSE allocate(LRB_OUT%Q(M,K),LRB_OUT%R(K,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = K*(M+N) RETURN ENDIF ENDIF ELSE nullify(LRB_OUT%R) allocate(LRB_OUT%Q(M,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = M*N RETURN ENDIF ENDIF IF (ISLR) THEN MEM = M*K + N*K ELSE MEM = M*N ENDIF CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM,8), & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) RETURN END SUBROUTINE ALLOC_LRB SUBROUTINE ALLOC_LRB_FROM_ACC(ACC_LRB, LRB_OUT, K, M, N, LorU, & IFLAG, IERROR, KEEP8) TYPE(LRB_TYPE), INTENT(IN) :: ACC_LRB TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K, M, N, LorU INTEGER,INTENT(INOUT) :: IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER :: I IF (LorU.EQ.1) THEN CALL ALLOC_LRB(LRB_OUT,K,M,N,.TRUE.,IFLAG,IERROR,KEEP8) IF (IFLAG.LT.0) RETURN DO I=1,K LRB_OUT%Q(1:M,I) = ACC_LRB%Q(1:M,I) LRB_OUT%R(I,1:N) = -ACC_LRB%R(I,1:N) ENDDO ELSE CALL ALLOC_LRB(LRB_OUT,K,N,M,.TRUE.,IFLAG,IERROR,KEEP8) IF (IFLAG.LT.0) RETURN DO I=1,K LRB_OUT%Q(1:N,I) = ACC_LRB%R(I,1:N) LRB_OUT%R(I,1:M) = -ACC_LRB%Q(1:M,I) ENDDO ENDIF END SUBROUTINE ALLOC_LRB_FROM_ACC SUBROUTINE REGROUPING2(CUT, NPARTSASS, NASS, & NPARTSCB, NCB, IBCKSZ, ONLYCB, K472, & NFRONT, KEEP) INTEGER, INTENT(IN) :: IBCKSZ, NASS, NCB, NFRONT, KEEP(500) INTEGER, INTENT(INOUT) :: NPARTSCB, NPARTSASS INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER, POINTER, DIMENSION(:) :: NEW_CUT INTEGER :: I, INEW, MINSIZE, NEW_NPARTSASS, allocok LOGICAL :: ONLYCB, TRACE INTEGER, INTENT(IN) :: K472 INTEGER :: IBCKSZ2,IFLAG,IERROR ALLOCATE(NEW_CUT(max(NPARTSASS,1)+NPARTSCB+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = max(NPARTSASS,1)+NPARTSCB+1 write(*,*) 'Allocation problem in BLR routine REGROUPING2:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF CALL COMPUTE_BLR_VCS(K472, IBCKSZ2, IBCKSZ, NASS, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) NEW_NPARTSASS = max(NPARTSASS,1) IF (.NOT. ONLYCB) THEN NEW_CUT(1) = 1 INEW = 2 I = 2 DO WHILE (I .LE. NPARTSASS + 1) NEW_CUT(INEW) = CUT(I) TRACE = .FALSE. IF (NEW_CUT(INEW) - NEW_CUT(INEW-1) .GT. MINSIZE) THEN INEW = INEW + 1 TRACE = .TRUE. ENDIF I = I + 1 END DO IF (TRACE) THEN INEW = INEW - 1 ELSE IF (INEW .NE. 2) THEN NEW_CUT(INEW-1) = NEW_CUT(INEW) INEW = INEW - 1 ENDIF ENDIF NEW_NPARTSASS = INEW - 1 ENDIF IF (ONLYCB) THEN DO I=1,max(NPARTSASS,1)+1 NEW_CUT(I) = CUT(I) ENDDO ENDIF IF (NCB .EQ. 0) GO TO 50 INEW = NEW_NPARTSASS+2 I = max(NPARTSASS,1) + 2 DO WHILE (I .LE. max(NPARTSASS,1) + NPARTSCB + 1) NEW_CUT(INEW) = CUT(I) TRACE = .FALSE. IF (NEW_CUT(INEW) - NEW_CUT(INEW-1) .GT. MINSIZE) THEN INEW = INEW + 1 TRACE = .TRUE. ENDIF I = I + 1 END DO IF (TRACE) THEN INEW = INEW - 1 ELSE IF (INEW .NE. NEW_NPARTSASS+2) THEN NEW_CUT(INEW-1) = NEW_CUT(INEW) INEW = INEW - 1 ENDIF ENDIF NPARTSCB = INEW - 1 - NEW_NPARTSASS 50 CONTINUE NPARTSASS = NEW_NPARTSASS DEALLOCATE(CUT) ALLOCATE(CUT(NPARTSASS+NPARTSCB+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSASS+NPARTSCB+1 write(*,*) 'Allocation problem in BLR routine REGROUPING2:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF DO I=1,NPARTSASS+NPARTSCB+1 CUT(I) = NEW_CUT(I) ENDDO DEALLOCATE(NEW_CUT) END SUBROUTINE REGROUPING2 SUBROUTINE UPD_MRY_LU_LRGAIN( BLR_PANEL, NBBLOCKS & ) C Updates the memory gain associated with a given BLR panel INTEGER,INTENT(IN) :: NBBLOCKS TYPE(LRB_TYPE), INTENT(IN) :: BLR_PANEL(:) DOUBLE PRECISION :: MRY INTEGER :: I C MRY = 0.0D0 DO I = 1, NBBLOCKS IF (BLR_PANEL(I)%ISLR) THEN MRY = MRY + dble(BLR_PANEL(I)%M*BLR_PANEL(I)%N & - BLR_PANEL(I)%K*(BLR_PANEL(I)%M + BLR_PANEL(I)%N)) ELSE ! islr MRY = MRY + 0.0d0 ENDIF ! islr ENDDO !$OMP ATOMIC UPDATE MRY_LU_LRGAIN = MRY_LU_LRGAIN + MRY !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_LU_LRGAIN SUBROUTINE DMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA, LRB, & NIV, SYM, LorU, IW, OFFSET_IW) C ----------- C Parameters C ----------- INTEGER(8), intent(in) :: LA INTEGER, intent(in) :: NFRONT, NIV, SYM, LorU, LDA INTEGER(8), intent(in) :: POSELT_LOCAL DOUBLE PRECISION, intent(inout) :: A(LA) TYPE(LRB_TYPE), intent(inout) :: LRB INTEGER, OPTIONAL:: OFFSET_IW INTEGER, OPTIONAL :: IW(*) C ----------- C Local variables C ----------- INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER :: M, N, I, J DOUBLE PRECISION, POINTER :: LR_BLOCK_PTR(:,:) DOUBLE PRECISION :: ONE, MONE, ZERO DOUBLE PRECISION :: MULT1, MULT2, A11, DETPIV, A22, A12 PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) N = LRB%N IF (LRB%ISLR) THEN M = LRB%K LR_BLOCK_PTR => LRB%R ELSE M = LRB%M LR_BLOCK_PTR => LRB%Q END IF IF (M.NE.0) THEN C Why is it Right, Lower, Tranpose? C Because A is stored by rows C but BLR_L is stored by columns IF (SYM.EQ.0.AND.LorU.EQ.0) THEN CALL dtrsm('R', 'L', 'T', 'N', M, N, ONE, & A(POSELT_LOCAL), NFRONT, & LR_BLOCK_PTR(1,1), M) ELSE CALL dtrsm('R', 'U', 'N', 'U', M, N, ONE, & A(POSELT_LOCAL), LDA, & LR_BLOCK_PTR(1,1), M) IF (LorU.EQ.0) THEN C Now apply D scaling IF (.NOT.present(OFFSET_IW)) THEN write(*,*) 'Internal error in ', & 'DMUMPS_LRTRSM' CALL MUMPS_ABORT() ENDIF DPOS = POSELT_LOCAL I = 1 DO IF(I .GT. N) EXIT IF(IW(OFFSET_IW+I-1) .GT. 0) THEN C 1x1 pivot A11 = ONE/A(DPOS) CALL dscal(M, A11, LR_BLOCK_PTR(1,I), 1) DPOS = DPOS + int(LDA + 1,8) I = I+1 ELSE C 2x2 pivot POSPV1 = DPOS POSPV2 = DPOS+ int(LDA + 1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV DO J = 1,M MULT1 = A11*LR_BLOCK_PTR(J,I)+A12*LR_BLOCK_PTR(J,I+1) MULT2 = A12*LR_BLOCK_PTR(J,I)+A22*LR_BLOCK_PTR(J,I+1) LR_BLOCK_PTR(J,I) = MULT1 LR_BLOCK_PTR(J,I+1) = MULT2 ENDDO DPOS = POSPV2 + int(LDA + 1,8) I = I+2 ENDIF ENDDO ENDIF ENDIF ENDIF CALL UPD_FLOP_TRSM(LRB%M, LRB%N, LRB%K, LRB%ISLR, LorU) END SUBROUTINE DMUMPS_LRTRSM SUBROUTINE DMUMPS_LRGEMM_SCALING(LRB, SCALED, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, MAXI_CLUSTER) C This routine does the scaling (for the symmetric case) before C computing the LR product (done in DMUMPS_LRGEMM4) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) DOUBLE PRECISION, intent(inout), DIMENSION(:,:) :: SCALED INTEGER,INTENT(IN) :: LD_DIAG, NFRONT, IW2(*) INTEGER(8), INTENT(IN) :: POSELTT DOUBLE PRECISION, INTENT(IN), OPTIONAL :: DIAG(*) INTEGER, INTENT(IN) :: MAXI_CLUSTER DOUBLE PRECISION, intent(inout) :: BLOCK(MAXI_CLUSTER) INTEGER :: J, NROWS DOUBLE PRECISION :: PIV1, PIV2, OFFDIAG IF (LRB%ISLR) THEN NROWS = LRB%K ELSE NROWS = LRB%M ENDIF J = 1 DO WHILE (J <= LRB%N) IF (IW2(J) > 0) THEN SCALED(1:NROWS,J) = DIAG(1+LD_DIAG*(J-1)+J-1) & * SCALED(1:NROWS,J) J = J+1 ELSE !2x2 pivot PIV1 = DIAG(1+LD_DIAG*(J-1)+J-1) PIV2 = DIAG(1+LD_DIAG*J+J) OFFDIAG = DIAG(1+LD_DIAG*(J-1)+J) BLOCK(1:NROWS) = SCALED(1:NROWS,J) SCALED(1:NROWS,J) = PIV1 * SCALED(1:NROWS,J) & + OFFDIAG * SCALED(1:NROWS,J+1) SCALED(1:NROWS,J+1) = OFFDIAG * BLOCK(1:NROWS) & + PIV2 * SCALED(1:NROWS,J+1) J=J+2 ENDIF END DO END SUBROUTINE DMUMPS_LRGEMM_SCALING SUBROUTINE DMUMPS_LRGEMM4(ALPHA, & LRB1, LRB2, BETA, & A, LA, POSELTT, NFRONT, SYM, & IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & RANK, BUILDQ, & LUA_ACTIVATED, C Start of OPTIONAL arguments & LorU, & LRB3, MAXI_RANK, & MAXI_CLUSTER, & DIAG, LD_DIAG, IW2, BLOCK & ) C CC TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, SYM, TOL_OPT INTEGER,INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), INTENT(IN) :: POSELTT DOUBLE PRECISION, INTENT(IN), OPTIONAL :: DIAG(*) INTEGER,INTENT(IN), OPTIONAL :: LD_DIAG, IW2(*) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION, intent(in) :: TOLEPS DOUBLE PRECISION :: ALPHA,BETA LOGICAL, INTENT(OUT) :: BUILDQ DOUBLE PRECISION, intent(inout), OPTIONAL :: BLOCK(*) INTEGER, INTENT(IN), OPTIONAL :: LorU LOGICAL, INTENT(IN) :: LUA_ACTIVATED INTEGER, INTENT(IN), OPTIONAL :: MAXI_CLUSTER INTEGER, INTENT(IN), OPTIONAL :: MAXI_RANK TYPE(LRB_TYPE), INTENT(INOUT), OPTIONAL :: LRB3 DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: XY_YZ DOUBLE PRECISION, ALLOCATABLE, TARGET, DIMENSION(:,:) :: XQ, R_Y DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: X, Y, Y1, Y2, Z CHARACTER(len=1) :: SIDE, TRANSY INTEGER :: K_XY, K_YZ, LDY, LDY1, LDY2, K_Y INTEGER :: LDXY_YZ, SAVE_K INTEGER :: I, J, RANK, MAXRANK, INFO, LWORK DOUBLE PRECISION, ALLOCATABLE :: RWORK_RRQR(:) DOUBLE PRECISION, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:), & Y_RRQR(:,:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: allocok, MREQ DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) IF (LRB1%M.EQ.0) THEN RETURN ENDIF IF (LRB2%M.EQ.0) THEN ENDIF RANK = 0 BUILDQ = .FALSE. IF (LRB1%ISLR.AND.LRB2%ISLR) THEN IF ((LRB1%K.EQ.0).OR.(LRB2%K.EQ.0)) THEN GOTO 1200 ENDIF allocate(Y(LRB1%K,LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K GOTO 1570 ENDIF X => LRB1%Q K_Y = LRB1%N IF (SYM .EQ. 0) THEN Y1 => LRB1%R ELSE allocate(Y1(LRB1%K,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%K Y1(I,J) = LRB1%R(I,J) ENDDO ENDDO CALL DMUMPS_LRGEMM_SCALING(LRB1, Y1, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY1 = LRB1%K Z => LRB2%Q Y2 => LRB2%R LDY2 = LRB2%K CALL dgemm('N', 'T', LRB1%K, LRB2%K, K_Y, ONE, & Y1(1,1), LDY1, Y2(1,1), LDY2, ZERO, Y(1,1), LRB1%K ) IF (MIDBLK_COMPRESS.GE.1) THEN LWORK = LRB2%K*(LRB2%K+1) allocate(Y_RRQR(LRB1%K,LRB2%K), & WORK_RRQR(LWORK), RWORK_RRQR(2*LRB2%K), & TAU_RRQR(MIN(LRB1%K,LRB2%K)), & JPVT_RRQR(LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K + LWORK + 2*LRB2%K + & MIN(LRB1%K,LRB2%K) + LRB2%K GOTO 1570 ENDIF DO J=1,LRB2%K DO I=1,LRB1%K Y_RRQR(I,J) = Y(I,J) ENDDO ENDDO MAXRANK = MIN(LRB1%K, LRB2%K)-1 MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) JPVT_RRQR = 0 CALL DMUMPS_TRUNCATED_RRQR(LRB1%K, LRB2%K, Y_RRQR(1,1), & LRB1%K, JPVT_RRQR, TAU_RRQR, WORK_RRQR, & LRB2%K, RWORK_RRQR, TOLEPS, TOL_OPT, RANK, & MAXRANK, INFO, & BUILDQ) IF (RANK.GT.MAXRANK) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) BUILDQ = .FALSE. ELSE BUILDQ = .TRUE. ENDIF IF (BUILDQ) THEN IF (RANK.EQ.0) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) deallocate(Y) nullify(Y) C GOTO 1580 not ok because BUILDQ .EQV. true C would try to free XQ and R_Y that are not allocated C in that case. So we free Y1 now if it was allocated. IF (SYM .NE. 0) deallocate(Y1) GOTO 1200 ELSE allocate(XQ(LRB1%M,RANK), R_Y(RANK,LRB2%K), & stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*RANK + RANK*LRB2%K GOTO 1570 ENDIF DO J=1, LRB2%K R_Y(1:MIN(RANK,J),JPVT_RRQR(J)) = & Y_RRQR(1:MIN(RANK,J),J) IF(J.LT.RANK) R_Y(MIN(RANK,J)+1: & RANK,JPVT_RRQR(J))= ZERO END DO C LWORK=LRB2%K*(LRB2%K+1), with LRB2%K>RANK C large enough for dorgqr CALL dorgqr & (LRB1%K, RANK, RANK, Y_RRQR(1,1), & LRB1%K, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) CALL dgemm('N', 'N', LRB1%M, RANK, LRB1%K, ONE, & X(1,1), LRB1%M, Y_RRQR(1,1), LRB1%K, ZERO, & XQ(1,1), LRB1%M) deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) nullify(X) X => XQ K_XY = RANK deallocate(Y) nullify(Y) Y => R_Y LDY = RANK K_YZ = LRB2%K TRANSY = 'N' SIDE = 'R' ENDIF ENDIF ENDIF IF (.NOT.BUILDQ) THEN LDY = LRB1%K K_XY = LRB1%K K_YZ = LRB2%K TRANSY = 'N' IF (LRB1%K .GE. LRB2%K) THEN SIDE = 'L' ELSE SIDE = 'R' ENDIF ENDIF ENDIF IF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN IF (LRB1%K.EQ.0) THEN GOTO 1200 ENDIF SIDE = 'R' K_XY = LRB1%K TRANSY = 'N' Z => LRB2%Q X => LRB1%Q LDY = LRB1%K IF (SYM .EQ. 0) THEN Y => LRB1%R ELSE allocate(Y(LRB1%K,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%K Y(I,J) = LRB1%R(I,J) ENDDO ENDDO CALL DMUMPS_LRGEMM_SCALING(LRB1, Y, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF K_YZ = LRB2%N ENDIF IF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN IF (LRB2%K.EQ.0) THEN GOTO 1200 ENDIF SIDE = 'L' K_YZ = LRB2%K X => LRB1%Q TRANSY = 'T' K_XY = LRB1%N IF (SYM .EQ. 0) THEN Y => LRB2%R ELSE allocate(Y(LRB2%K,LRB2%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB2%K*LRB2%N GOTO 1570 ENDIF DO J=1,LRB2%N DO I=1,LRB2%K Y(I,J) = LRB2%R(I,J) ENDDO ENDDO CALL DMUMPS_LRGEMM_SCALING(LRB2, Y, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY = LRB2%K Z => LRB2%Q ENDIF IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .EQ. 0) THEN X => LRB1%Q ELSE allocate(X(LRB1%M,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%M X(I,J) = LRB1%Q(I,J) ENDDO ENDDO CALL DMUMPS_LRGEMM_SCALING(LRB1, X, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF SIDE = 'N' Z => LRB2%Q K_XY = LRB1%N ENDIF IF (LUA_ACTIVATED) THEN SAVE_K = LRB3%K IF (SIDE == 'L') THEN LRB3%K = LRB3%K+K_YZ ELSEIF (SIDE == 'R') THEN LRB3%K = LRB3%K+K_XY ENDIF ENDIF IF (SIDE == 'L') THEN ! LEFT: XY_YZ = X*Y; A = XY_YZ*Z IF (.NOT.LUA_ACTIVATED) THEN allocate(XY_YZ(LRB1%M,K_YZ),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*K_YZ GOTO 1570 ENDIF LDXY_YZ = LRB1%M ELSE IF (SAVE_K+K_YZ.GT.MAXI_RANK) THEN write(*,*) 'Internal error in DMUMPS_LRGEMM4 1a', & 'K_ACC+K_CUR>K_MAX:',SAVE_K,K_YZ,MAXI_RANK CALL MUMPS_ABORT() ENDIF IF (LRB3%M.NE.LRB1%M) THEN write(*,*) 'Internal error in DMUMPS_LRGEMM4 1b', & 'LRB1%M =/= LRB3%M',LRB1%M,LRB3%M CALL MUMPS_ABORT() ENDIF XY_YZ => LRB3%Q(1:LRB1%M,SAVE_K+1:SAVE_K+K_YZ) LDXY_YZ = MAXI_CLUSTER DO I=1,K_YZ LRB3%R(SAVE_K+I,1:LRB2%M) = Z(1:LRB2%M,I) ENDDO ENDIF CALL dgemm('N', TRANSY, LRB1%M, K_YZ, K_XY, ONE, & X(1,1), LRB1%M, Y(1,1), LDY, ZERO, XY_YZ(1,1), & LDXY_YZ) IF (.NOT.LUA_ACTIVATED) THEN CALL dgemm('N', 'T', LRB1%M, LRB2%M, K_YZ, ALPHA, & XY_YZ(1,1), LRB1%M, Z(1,1), LRB2%M, BETA, & A(POSELTT), NFRONT) deallocate(XY_YZ) ENDIF ELSEIF (SIDE == 'R') THEN ! RIGHT: XY_YZ = Y*Z; A = X*XY_YZ IF (.NOT.LUA_ACTIVATED) THEN allocate(XY_YZ(K_XY,LRB2%M),stat=allocok) IF (allocok > 0) THEN MREQ = K_XY*LRB2%M GOTO 1570 ENDIF LDXY_YZ = K_XY ELSE IF (SAVE_K+K_XY.GT.MAXI_RANK) THEN write(*,*) 'Internal error in DMUMPS_LRGEMM4 2a', & 'K_ACC+K_CUR>K_MAX:',SAVE_K,K_XY,MAXI_RANK CALL MUMPS_ABORT() ENDIF IF (LRB3%N.NE.LRB2%M) THEN write(*,*) 'Internal error in DMUMPS_LRGEMM4 2b', & 'LRB2%M =/= LRB3%N',LRB2%M,LRB3%N CALL MUMPS_ABORT() ENDIF XY_YZ => LRB3%R(SAVE_K+1:SAVE_K+K_XY,1:LRB2%M) LDXY_YZ = MAXI_RANK DO I=1,K_XY LRB3%Q(1:LRB1%M,SAVE_K+I) = X(1:LRB1%M,I) ENDDO ENDIF CALL dgemm(TRANSY, 'T', K_XY, LRB2%M, K_YZ, ONE, & Y(1,1), LDY, Z(1,1), LRB2%M, ZERO, XY_YZ(1,1), & LDXY_YZ) IF (.NOT.LUA_ACTIVATED) THEN CALL dgemm('N', 'N', LRB1%M, LRB2%M, K_XY, ALPHA, & X(1,1), LRB1%M, XY_YZ(1,1), K_XY, BETA, A(POSELTT), & NFRONT) deallocate(XY_YZ) ENDIF ELSE ! SIDE == 'N' : NONE; A = X*Z CALL dgemm('N', 'T', LRB1%M, LRB2%M, K_XY, ALPHA, & X(1,1), LRB1%M, Z(1,1), LRB2%M, BETA, A(POSELTT), & NFRONT) ENDIF GOTO 1580 1570 CONTINUE C Alloc NOT ok!! IFLAG = -13 IERROR = MREQ RETURN 1580 CONTINUE C Alloc ok!! IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .NE. 0) deallocate(X) ELSEIF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN IF (SYM .NE. 0) deallocate(Y) ELSEIF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .NE. 0) deallocate(Y) ELSE IF (SYM .NE. 0) deallocate(Y1) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN deallocate(XQ) deallocate(R_Y) ELSE deallocate(Y) ENDIF ENDIF 1200 CONTINUE END SUBROUTINE DMUMPS_LRGEMM4 SUBROUTINE DMUMPS_DECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, LorU, & COUNT_FLOPS) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK INTEGER(8), INTENT(IN) :: POSELTT LOGICAL, OPTIONAL :: COUNT_FLOPS LOGICAL :: COUNT_FLOPS_LOC INTEGER :: LorU DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) IF (present(COUNT_FLOPS)) THEN COUNT_FLOPS_LOC=COUNT_FLOPS ELSE COUNT_FLOPS_LOC=.TRUE. ENDIF CALL dgemm('N', 'N', ACC_LRB%M, ACC_LRB%N, ACC_LRB%K, & MONE, ACC_LRB%Q(1,1), MAXI_CLUSTER, ACC_LRB%R(1,1), & MAXI_RANK, ONE, A(POSELTT), NFRONT) ACC_LRB%K = 0 END SUBROUTINE DMUMPS_DECOMPRESS_ACC SUBROUTINE DMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & TOLEPS, TOL_OPT, KPERCENT, BUILDQ, LorU, CB_COMPRESS) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, LorU, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT INTEGER(8), INTENT(IN) :: POSELTT DOUBLE PRECISION, intent(in) :: TOLEPS LOGICAL, INTENT(OUT) :: BUILDQ LOGICAL, INTENT(IN) :: CB_COMPRESS DOUBLE PRECISION, ALLOCATABLE :: RWORK_RRQR(:) DOUBLE PRECISION, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: INFO, RANK, MAXRANK, LWORK INTEGER :: I, J, M, N INTEGER :: allocok, MREQ DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) M = ACC_LRB%M N = ACC_LRB%N MAXRANK = floor(dble(M*N)/dble(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) LWORK = N*(N+1) allocate(WORK_RRQR(LWORK), RWORK_RRQR(2*N), & TAU_RRQR(N), & JPVT_RRQR(N), stat=allocok) IF (allocok > 0) THEN MREQ = LWORK +4 *N GOTO 100 ENDIF DO I=1,N ACC_LRB%Q(1:M,I)= & - A(POSELTT+int(I-1,8)*int(NFRONT,8) : & POSELTT+int(I-1,8)*int(NFRONT,8) + int(M-1,8) ) END DO JPVT_RRQR = 0 CALL DMUMPS_TRUNCATED_RRQR(M, N, ACC_LRB%Q(1,1), & MAXI_CLUSTER, JPVT_RRQR(1), TAU_RRQR(1), & WORK_RRQR(1), & N, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK, MAXRANK, INFO, & BUILDQ) IF (BUILDQ) THEN DO J=1, N ACC_LRB%R(1:MIN(RANK,J),JPVT_RRQR(J)) = & ACC_LRB%Q(1:MIN(RANK,J),J) IF(J.LT.RANK) ACC_LRB%R(MIN(RANK,J)+1: & RANK,JPVT_RRQR(J))= ZERO END DO CALL dorgqr & (M, RANK, RANK, ACC_LRB%Q(1,1), & MAXI_CLUSTER, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) DO I=1,N A( POSELTT+int(I-1,8)*int(NFRONT,8) : & POSELTT+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) = ZERO END DO ACC_LRB%K = RANK CALL UPD_FLOP_COMPRESS(ACC_LRB%M, ACC_LRB%N, ACC_LRB%K, & ACC_LRB%ISLR, CB_COMPRESS=CB_COMPRESS) ELSE ACC_LRB%K = RANK ACC_LRB%ISLR = .FALSE. CALL UPD_FLOP_COMPRESS(ACC_LRB%M, ACC_LRB%N, ACC_LRB%K, & ACC_LRB%ISLR, CB_COMPRESS=CB_COMPRESS) ACC_LRB%ISLR = .TRUE. ACC_LRB%K = 0 ENDIF deallocate(JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & DMUMPS_COMPRESS_FR_UPDATES: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE DMUMPS_COMPRESS_FR_UPDATES SUBROUTINE DMUMPS_RECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER :: IFLAG, IERROR INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER,INTENT(INOUT) :: NEW_ACC_RANK INTEGER(8), INTENT(IN) :: POSELTT INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB DOUBLE PRECISION, intent(in) :: TOLEPS DOUBLE PRECISION, ALLOCATABLE:: RWORK_RRQR(:) DOUBLE PRECISION, ALLOCATABLE:: WORK_RRQR(:), TAU_RRQR(:) DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:),TARGET:: Q1, R1, & Q2, R2 INTEGER, ALLOCATABLE :: JPVT_RRQR(:) TYPE(LRB_TYPE) :: LRB1, LRB2 INTEGER :: INFO, RANK1, RANK2, RANK, MAXRANK, LWORK LOGICAL :: BUILDQ, BUILDQ1, BUILDQ2, SKIP1, SKIP2 INTEGER :: I, J, M, N, K INTEGER :: allocok, MREQ DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) SKIP1 = .FALSE. SKIP2 = .FALSE. SKIP1 = .TRUE. 1500 CONTINUE M = ACC_LRB%M N = ACC_LRB%N K = ACC_LRB%K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) IF (.FALSE.) THEN CALL DMUMPS_RECOMPRESS_ACC_V2(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, & NEW_ACC_RANK) K = ACC_LRB%K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) SKIP1 = .TRUE. SKIP2 = K.EQ.0 ENDIF IF (SKIP1.AND.SKIP2) GOTO 1600 allocate(Q1(M,K), Q2(N,K), & WORK_RRQR(LWORK), & RWORK_RRQR(2*K), & TAU_RRQR(K), & JPVT_RRQR(K), stat=allocok) IF (allocok > 0) THEN MREQ = LWORK + M*N + N*K+ 4 * K GOTO 100 ENDIF IF (SKIP1) THEN BUILDQ1 = .FALSE. ELSE DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J) ENDDO ENDDO JPVT_RRQR = 0 CALL DMUMPS_TRUNCATED_RRQR(M, K, Q1(1,1), & M, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, RANK1, & MAXRANK, INFO, & BUILDQ1) ENDIF IF (BUILDQ1) THEN allocate(R1(RANK1,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK1*K GOTO 100 ENDIF DO J=1, K R1(1:MIN(RANK1,J),JPVT_RRQR(J)) = & Q1(1:MIN(RANK1,J),J) IF(J.LT.RANK1) R1(MIN(RANK1,J)+1: & RANK1,JPVT_RRQR(J))= ZERO END DO CALL dorgqr & (M, RANK1, RANK1, Q1(1,1), & M, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) ENDIF IF (SKIP2) THEN BUILDQ2 = .FALSE. ELSE DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J,I) ENDDO ENDDO JPVT_RRQR = 0 CALL DMUMPS_TRUNCATED_RRQR(N, K, Q2(1,1), & N, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK2, MAXRANK, INFO, & BUILDQ2) ENDIF IF (BUILDQ2) THEN allocate(R2(RANK2,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK2*K GOTO 100 ENDIF DO J=1, K R2(1:MIN(RANK2,J),JPVT_RRQR(J)) = & Q2(1:MIN(RANK2,J),J) IF(J.LT.RANK2) R2(MIN(RANK2,J)+1: & RANK2,JPVT_RRQR(J))= ZERO END DO CALL dorgqr & (N, RANK2, RANK2, Q2(1,1), & N, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) ENDIF CALL INIT_LRB(LRB1,RANK1,M,K,BUILDQ1) CALL INIT_LRB(LRB2,RANK2,N,K,BUILDQ2) IF (BUILDQ1.OR.BUILDQ2) THEN IF (BUILDQ1) THEN LRB1%R => R1 ELSE DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J) ENDDO ENDDO ENDIF LRB1%Q => Q1 IF (BUILDQ2) THEN LRB2%R => R2 ELSE DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J,I) ENDDO ENDDO ENDIF LRB2%Q => Q2 ACC_LRB%K = 0 CALL DMUMPS_LRGEMM4(MONE, LRB1, LRB2, ONE, & A, LA, POSELTT, NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS-1, TOLEPS, TOL_OPT, & KPERCENT_RMB, & RANK, BUILDQ, .TRUE., LRB3=ACC_LRB, & MAXI_RANK=MAXI_RANK, MAXI_CLUSTER=MAXI_CLUSTER) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(LRB1%M, LRB1%N, LRB1%K, LRB1%ISLR, & LRB2%M, LRB2%N, LRB2%K, LRB2%ISLR, & MIDBLK_COMPRESS-1, RANK, BUILDQ, & .TRUE., .FALSE., REC_ACC=.TRUE.) ENDIF IF (.NOT. SKIP1) & CALL UPD_FLOP_COMPRESS(LRB1%M, LRB1%N, LRB1%K, & LRB1%ISLR, REC_ACC=.TRUE.) IF (.NOT. SKIP2) & CALL UPD_FLOP_COMPRESS(LRB2%M, LRB2%N, LRB2%K, & LRB2%ISLR, REC_ACC=.TRUE.) deallocate(Q1,Q2) IF (BUILDQ1) deallocate(R1) IF (BUILDQ2) deallocate(R2) deallocate(JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) IF (SKIP1.AND.(RANK2.GT.0)) THEN SKIP1 = .FALSE. SKIP2 = .TRUE. GOTO 1500 ENDIF 1600 CONTINUE NEW_ACC_RANK = 0 RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & DMUMPS_RECOMPRESS_ACC: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE DMUMPS_RECOMPRESS_ACC RECURSIVE SUBROUTINE DMUMPS_RECOMPRESS_ACC_NARYTREE( & ACC_LRB, MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, & KPERCENT_LUA, K478, RANK_LIST, POS_LIST, NB_NODES, & LEVEL, ACC_TMP) TYPE(LRB_TYPE),TARGET,INTENT(INOUT) :: ACC_LRB TYPE(LRB_TYPE),TARGET,INTENT(INOUT),OPTIONAL :: ACC_TMP INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER(8), INTENT(IN) :: POSELTT INTEGER(8) :: KEEP8(150) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB DOUBLE PRECISION, intent(in) :: TOLEPS INTEGER,INTENT(IN) :: K478, NB_NODES, LEVEL INTEGER,INTENT(INOUT) :: RANK_LIST(NB_NODES), POS_LIST(NB_NODES) TYPE(LRB_TYPE) :: LRB, ACC_NEW TYPE(LRB_TYPE), POINTER :: LRB_PTR LOGICAL :: RESORT INTEGER :: I, J, M, N, L, NODE_RANK, NARY, IOFF, IMAX, CURPOS INTEGER :: NB_NODES_NEW, KTOT, NEW_ACC_RANK INTEGER, ALLOCATABLE :: RANK_LIST_NEW(:), POS_LIST_NEW(:) DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) INTEGER :: allocok RESORT = .FALSE. M = ACC_LRB%M N = ACC_LRB%N NARY = -K478 IOFF = 0 NB_NODES_NEW = NB_NODES/NARY IF (NB_NODES_NEW*NARY.NE.NB_NODES) THEN NB_NODES_NEW = NB_NODES_NEW + 1 ENDIF ALLOCATE(RANK_LIST_NEW(NB_NODES_NEW),POS_LIST_NEW(NB_NODES_NEW), & stat=allocok) IF (allocok > 0) THEN write(*,*) 'Allocation error of RANK_LIST_NEW/POS_LIST_NEW ', & 'in DMUMPS_RECOMPRESS_ACC_NARYTREE' call MUMPS_ABORT() ENDIF DO J=1,NB_NODES_NEW NODE_RANK = RANK_LIST(IOFF+1) CURPOS = POS_LIST(IOFF+1) IMAX = MIN(NARY,NB_NODES-IOFF) IF (IMAX.GE.2) THEN DO I=2,IMAX IF (POS_LIST(IOFF+I).NE.CURPOS+NODE_RANK) THEN DO L=0,RANK_LIST(IOFF+I)-1 ACC_LRB%Q(1:M,CURPOS+NODE_RANK+L) = & ACC_LRB%Q(1:M,POS_LIST(IOFF+I)+L) ACC_LRB%R(CURPOS+NODE_RANK+L,1:N) = & ACC_LRB%R(POS_LIST(IOFF+I)+L,1:N) ENDDO POS_LIST(IOFF+I) = CURPOS+NODE_RANK ENDIF NODE_RANK = NODE_RANK+RANK_LIST(IOFF+I) ENDDO CALL INIT_LRB(LRB,NODE_RANK,M,N,.TRUE.) IF (.NOT.RESORT.OR.LEVEL.EQ.0) THEN LRB%Q => ACC_LRB%Q(1:M,CURPOS:CURPOS+NODE_RANK) LRB%R => ACC_LRB%R(CURPOS:CURPOS+NODE_RANK,1:N) ELSE LRB%Q => ACC_TMP%Q(1:M,CURPOS:CURPOS+NODE_RANK) LRB%R => ACC_TMP%R(CURPOS:CURPOS+NODE_RANK,1:N) ENDIF NEW_ACC_RANK = NODE_RANK-RANK_LIST(IOFF+1) IF (NEW_ACC_RANK.GT.0) THEN CALL DMUMPS_RECOMPRESS_ACC(LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF RANK_LIST_NEW(J) = LRB%K POS_LIST_NEW(J) = CURPOS ELSE RANK_LIST_NEW(J) = NODE_RANK POS_LIST_NEW(J) = CURPOS ENDIF IOFF = IOFF+IMAX ENDDO IF (NB_NODES_NEW.GT.1) THEN IF (RESORT) THEN KTOT = SUM(RANK_LIST_NEW) CALL INIT_LRB(ACC_NEW,KTOT,M,N,.TRUE.) ALLOCATE(ACC_NEW%Q(MAXI_CLUSTER,MAXI_RANK), & ACC_NEW%R(MAXI_RANK,MAXI_CLUSTER), stat=allocok) IF (allocok > 0) THEN write(*,*) 'Allocation error of ACC_NEW%Q/ACC_NEW%R ', & 'in DMUMPS_RECOMPRESS_ACC_NARYTREE' call MUMPS_ABORT() ENDIF CALL MUMPS_SORT_INT(NB_NODES_NEW, RANK_LIST_NEW, & POS_LIST_NEW) CURPOS = 1 IF (LEVEL.EQ.0) THEN LRB_PTR => ACC_LRB ELSE LRB_PTR => ACC_TMP ENDIF DO J=1,NB_NODES_NEW DO L=0,RANK_LIST_NEW(J)-1 ACC_NEW%Q(1:M,CURPOS+L) = & LRB_PTR%Q(1:M,POS_LIST_NEW(J)+L) ACC_NEW%R(CURPOS+L,1:N) = & LRB_PTR%R(POS_LIST_NEW(J)+L,1:N) ENDDO POS_LIST_NEW(J) = CURPOS CURPOS = CURPOS + RANK_LIST_NEW(J) ENDDO IF (LEVEL.GT.0) THEN CALL DEALLOC_LRB(ACC_TMP, KEEP8, 4) ENDIF CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST_NEW, POS_LIST_NEW, NB_NODES_NEW, & LEVEL+1, ACC_NEW) ELSE CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST_NEW, POS_LIST_NEW, NB_NODES_NEW, LEVEL+1) ENDIF ELSE IF (POS_LIST_NEW(1).NE.1) THEN write(*,*) 'Internal error in ', & 'DMUMPS_RECOMPRESS_ACC_NARYTREE', POS_LIST_NEW(1) ENDIF ACC_LRB%K = RANK_LIST_NEW(1) IF (RESORT.AND.LEVEL.GT.0) THEN DO L=1,ACC_LRB%K DO I=1,M ACC_LRB%Q(I,L) = ACC_TMP%Q(I,L) ENDDO DO I=1,N ACC_LRB%R(L,I) = ACC_TMP%R(L,I) ENDDO ENDDO CALL DEALLOC_LRB(ACC_TMP, KEEP8, 4) ENDIF ENDIF DEALLOCATE(RANK_LIST_NEW, POS_LIST_NEW) END SUBROUTINE DMUMPS_RECOMPRESS_ACC_NARYTREE SUBROUTINE DMUMPS_RECOMPRESS_ACC_V2(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER,INTENT(INOUT) :: NEW_ACC_RANK INTEGER(8), INTENT(IN) :: POSELTT INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB DOUBLE PRECISION, intent(in) :: TOLEPS DOUBLE PRECISION, ALLOCATABLE :: RWORK_RRQR(:) DOUBLE PRECISION, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:), TARGET :: & Q1, R1, Q2, PROJ INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: INFO, RANK1, MAXRANK, LWORK LOGICAL :: BUILDQ1 INTEGER :: I, J, M, N, K, K1 INTEGER :: allocok, MREQ DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) M = ACC_LRB%M N = ACC_LRB%N K = NEW_ACC_RANK K1 = ACC_LRB%K - K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) allocate(Q1(M,K), PROJ(K1, K), & WORK_RRQR(LWORK), RWORK_RRQR(2*K), & TAU_RRQR(K), & JPVT_RRQR(K), stat=allocok) IF (allocok > 0) THEN MREQ = M * K + K1 * K + LWORK + 4 * K GOTO 100 ENDIF DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J+K1) ENDDO ENDDO CALL dgemm('T', 'N', K1, K, M, ONE, ACC_LRB%Q(1,1), & MAXI_CLUSTER, Q1(1,1), M, ZERO, PROJ(1,1), K1) CALL dgemm('N', 'N', M, K, K1, MONE, ACC_LRB%Q(1,1), & MAXI_CLUSTER, PROJ(1,1), K1, ONE, Q1(1,1), M) JPVT_RRQR = 0 CALL DMUMPS_TRUNCATED_RRQR(M, K, Q1(1,1), & M, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK1, MAXRANK, INFO, & BUILDQ1) IF (BUILDQ1) THEN allocate(Q2(N,K), stat=allocok) IF (allocok > 0) THEN MREQ = N*K GOTO 100 ENDIF DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J+K1,I) ENDDO ENDDO CALL dgemm('N', 'T', K1, N, K, ONE, PROJ(1,1), K1, & Q2(1,1), N, ONE, ACC_LRB%R(1,1), MAXI_RANK) IF (RANK1.GT.0) THEN allocate(R1(RANK1,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK1*K GOTO 100 ENDIF DO J=1, K R1(1:MIN(RANK1,J),JPVT_RRQR(J)) = & Q1(1:MIN(RANK1,J),J) IF(J.LT.RANK1) R1(MIN(RANK1,J)+1: & RANK1,JPVT_RRQR(J))= ZERO END DO CALL dorgqr & (M, RANK1, RANK1, Q1(1,1), & M, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) DO J=1,K DO I=1,M ACC_LRB%Q(I,J+K1) = Q1(I,J) ENDDO ENDDO CALL dgemm('N', 'T', RANK1, N, K, ONE, R1(1,1), RANK1, & Q2(1,1), N, ZERO, ACC_LRB%R(K1+1,1), MAXI_RANK) deallocate(R1) ENDIF deallocate(Q2) ACC_LRB%K = K1 + RANK1 ENDIF deallocate(PROJ) deallocate(Q1, JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & DMUMPS_RECOMPRESS_ACC_V2: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE DMUMPS_RECOMPRESS_ACC_V2 SUBROUTINE MAX_CLUSTER(CUT,CUT_SIZE,MAXI_CLUSTER) INTEGER, intent(in) :: CUT_SIZE INTEGER, intent(out) :: MAXI_CLUSTER INTEGER, DIMENSION(:), intent(in) :: CUT INTEGER :: I MAXI_CLUSTER = 0 DO I = 1, CUT_SIZE IF (CUT(I+1) - CUT(I) .GE. MAXI_CLUSTER) THEN MAXI_CLUSTER = CUT(I+1) - CUT(I) END IF END DO END SUBROUTINE MAX_CLUSTER SUBROUTINE DMUMPS_GET_LUA_ORDER(NB_BLOCKS, ORDER, RANK, IWHANDLER, & SYM, FS_OR_CB, I, J, FRFR_UPDATES, & LBANDSLAVE_IN, K474, BLR_U_COL) C ----------- C Parameters C ----------- INTEGER, INTENT(IN) :: NB_BLOCKS, IWHANDLER, SYM, FS_OR_CB, I, J INTEGER, INTENT(OUT) :: ORDER(NB_BLOCKS), RANK(NB_BLOCKS), & FRFR_UPDATES LOGICAL, OPTIONAL, INTENT(IN) :: LBANDSLAVE_IN INTEGER, OPTIONAL, INTENT(IN) :: K474 TYPE(LRB_TYPE), POINTER, OPTIONAL :: BLR_U_COL(:) C ----------- C Local variables C ----------- INTEGER :: K, IND_L, IND_U LOGICAL :: LBANDSLAVE TYPE(LRB_TYPE), POINTER :: BLR_L(:), BLR_U(:) IF (PRESENT(LBANDSLAVE_IN)) THEN LBANDSLAVE = LBANDSLAVE_IN ELSE LBANDSLAVE = .FALSE. ENDIF IF ((SYM.NE.0).AND.(FS_OR_CB.EQ.0).AND.(J.NE.0)) THEN write(6,*) 'Internal error in DMUMPS_GET_LUA_ORDER', & 'SYM, FS_OR_CB, J = ',SYM,FS_OR_CB,J CALL MUMPS_ABORT() ENDIF FRFR_UPDATES = 0 DO K = 1, NB_BLOCKS ORDER(K) = K IF (FS_OR_CB.EQ.0) THEN ! FS IF (J.EQ.0) THEN ! L panel IND_L = NB_BLOCKS+I-K IND_U = NB_BLOCKS+1-K ELSE ! U panel IND_L = NB_BLOCKS+1-K IND_U = NB_BLOCKS+I-K ENDIF ELSE ! CB IND_L = I-K IND_U = J-K ENDIF IF (LBANDSLAVE) THEN IND_L = I IF (K474.GE.2) THEN IND_U = K ENDIF ENDIF CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, ! L Panel & K, BLR_L) IF (SYM.EQ.0) THEN IF (LBANDSLAVE.AND.K474.GE.2) THEN BLR_U => BLR_U_COL ELSE CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, ! L Panel & K, BLR_U) ENDIF ELSE BLR_U => BLR_L ENDIF IF (BLR_L(IND_L)%ISLR) THEN IF (BLR_U(IND_U)%ISLR) THEN RANK(K) = min(BLR_L(IND_L)%K, BLR_U(IND_U)%K) ELSE RANK(K) = BLR_L(IND_L)%K ENDIF ELSE IF (BLR_U(IND_U)%ISLR) THEN RANK(K) = BLR_U(IND_U)%K ELSE RANK(K) = -1 FRFR_UPDATES = FRFR_UPDATES + 1 ENDIF ENDIF ENDDO CALL MUMPS_SORT_INT(NB_BLOCKS, RANK, ORDER) END SUBROUTINE DMUMPS_GET_LUA_ORDER SUBROUTINE DMUMPS_BLR_ASM_NIV1 (A, LA, POSEL1, NFRONT, NASS1, & IWHANDLER, SON_IW, LIW, LSTK, NELIM, K1, K2, SYM, & KEEP, KEEP8, OPASSW) C C Purpose C ======= C C Called by a level 1 master assembling the contribution C block of a level 1 son that has been BLR-compressed C C C Parameters C ========== C INTEGER(8) :: LA, POSEL1 INTEGER :: LIW, NFRONT, NASS1, LSTK, NELIM, K1, K2, IWHANDLER DOUBLE PRECISION :: A(LA) C INTEGER :: SON_IW(LIW) INTEGER :: SON_IW(:) ! contiguity information lost but no copy INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER :: SYM DOUBLE PRECISION, INTENT(INOUT) :: OPASSW C C Local variables C =============== C DOUBLE PRECISION, ALLOCATABLE :: SON_A(:) INTEGER(8) :: APOS, SON_APOS, IACHK, JJ2, NFRONT8 INTEGER :: KK, KK1, allocok, SON_LA TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:), LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_DYNAMIC INTEGER :: NB_INCB, NB_INASM, NB_BLR, I, J, M, N, II, NPIV, & IBIS, IBIS_END, FIRST_ROW, LAST_ROW, FIRST_COL, LAST_COL, & SON_LDA DOUBLE PRECISION :: PROMOTE_COST DOUBLE PRECISION :: ONE, ZERO PARAMETER (ONE = 1.0D0) PARAMETER (ZERO = 0.0D0) CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_DYN(IWHANDLER, & BEGS_BLR_DYNAMIC) CALL DMUMPS_BLR_RETRIEVE_CB_LRB(IWHANDLER, CB_LRB) NB_BLR = size(BEGS_BLR_DYNAMIC)-1 NB_INCB = size(CB_LRB,1) NB_INASM = NB_BLR - NB_INCB NPIV = BEGS_BLR_DYNAMIC(NB_INASM+1)-1 NFRONT8 = int(NFRONT,8) IF (SYM.EQ.0) THEN IBIS_END = NB_INCB*NB_INCB ELSE IBIS_END = NB_INCB*(NB_INCB+1)/2 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP DO PRIVATE(IBIS, I, J, M, N, SON_LA, SON_LDA, FIRST_ROW, !$OMP& LAST_ROW, FIRST_COL, LAST_COL, LRB, SON_A, II, KK, !$OMP& APOS, IACHK, KK1, JJ2, PROMOTE_COST, allocok, SON_APOS) #endif DO IBIS = 1,IBIS_END C Determining I,J from IBIS IF (SYM.EQ.0) THEN I = (IBIS-1)/NB_INCB+1 J = IBIS - (I-1)*NB_INCB ELSE I = ceiling((1.0D0+sqrt(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 ENDIF I = I+NB_INASM J = J+NB_INASM IF (I.EQ.NB_INASM+1) THEN C first CB block, add NELIM because FIRST_ROW starts at NELIM+1 FIRST_ROW = BEGS_BLR_DYNAMIC(I)-NPIV+NELIM ELSE FIRST_ROW = BEGS_BLR_DYNAMIC(I)-NPIV ENDIF LAST_ROW = BEGS_BLR_DYNAMIC(I+1)-1-NPIV M=LAST_ROW-FIRST_ROW+1 FIRST_COL = BEGS_BLR_DYNAMIC(J)-NPIV LAST_COL = BEGS_BLR_DYNAMIC(J+1)-1-NPIV N = BEGS_BLR_DYNAMIC(J+1)-BEGS_BLR_DYNAMIC(J) SON_APOS = 1_8 SON_LA = M*N SON_LDA = N LRB => CB_LRB(I-NB_INASM,J-NB_INASM) IF (LRB%ISLR.AND.LRB%K.EQ.0) THEN C No need to perform extend-add CALL DEALLOC_LRB(LRB, KEEP8, KEEP(34)) NULLIFY(LRB) CYCLE ENDIF allocate(SON_A(SON_LA),stat=allocok) IF (allocok.GT.0) THEN write(*,*) 'Not enough memory in DMUMPS_BLR_ASM_NIV1', & ", Memory requested = ", SON_LA CALL MUMPS_ABORT() ENDIF C decompress block IF (LRB%ISLR) THEN CALL dgemm('T', 'T', N, M, LRB%K, ONE, LRB%R(1,1), LRB%K, & LRB%Q(1,1), M, ZERO, SON_A(SON_APOS), SON_LDA) PROMOTE_COST = 2.0D0*M*N*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE IF (I.EQ.J.AND.SYM.NE.0) THEN C Diag block and LDLT, copy only lower half IF (J-NB_INASM.EQ.1.AND.NELIM.GT.0) THEN C The first diagonal block is rectangular !! C with NELIM more cols than rows DO II=1,M DO KK=1,II+NELIM SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ELSE DO II=1,M DO KK=1,II SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ENDIF ELSE DO II=1,M DO KK=1,N SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ENDIF ENDIF C Deallocate block CALL DEALLOC_LRB(LRB, KEEP8, KEEP(34)) NULLIFY(LRB) C extend add in father IF (SYM.NE.0.AND.J-NB_INASM.EQ.1.AND.NELIM.GT.0) THEN C Case of LDLT with NELIM: first-block column is treated C differently as the NELIM are assembled at the end of the C father DO KK = FIRST_ROW, LAST_ROW IACHK = 1_8 + int(KK-FIRST_ROW,8)*int(SON_LDA,8) IF (SON_IW(KK+K1-1).LE.NASS1) THEN C Fully summed row of the father => permute destination in C father, symmetric swap to be done C First NELIM columns APOS = POSEL1 + int(SON_IW(KK+K1-1),8) - 1_8 DO KK1 = FIRST_COL, FIRST_COL+NELIM-1 JJ2 = APOS + int(SON_IW(K1+KK1-1)-1,8)*NFRONT8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO C Remaining columns APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 C DO KK1 = FIRST_COL+NELIM, LAST_COL C In case I=J and first block, one may have C LAST_COL > KK, but only lower triangular part C should be assembled. We use min(LAST_COL,KK) C below index to cover this case. DO KK1 = FIRST_COL+NELIM, min(LAST_COL,KK) JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ELSE APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 DO KK1 = FIRST_COL, min(LAST_COL,KK) JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ENDIF ENDDO ELSE C Case of LDLT without NELIM or LU: everything is simpler DO KK = FIRST_ROW, LAST_ROW APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 IACHK = 1_8 + int(KK-FIRST_ROW,8)*int(SON_LDA,8) IF (I.EQ.J.AND.SYM.NE.0) THEN C LDLT diag block: assemble only lower half DO KK1 = FIRST_COL, KK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ELSE DO KK1 = FIRST_COL, LAST_COL JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ENDIF ENDDO ENDIF C Deallocate SON_A DEALLOCATE(SON_A) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO !$OMP END PARALLEL #endif CALL DMUMPS_BLR_FREE_CB_LRB(IWHANDLER, C Only CB_LRB structure is left to deallocate & .TRUE., KEEP8, KEEP(34)) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN C Case of FR solve: the BLR structure could not be freed C in DMUMPS_END_FACTO_SLAVE and should be freed here C Not reachable in case of error: set INFO1 to 0 CALL DMUMPS_BLR_END_FRONT(IWHANDLER, 0, KEEP8, KEEP(34), & MTK405=KEEP(405)) ENDIF END SUBROUTINE DMUMPS_BLR_ASM_NIV1 END MODULE DMUMPS_LR_CORE C -------------------------------------------------------------------- SUBROUTINE DMUMPS_TRUNCATED_RRQR( M, N, A, LDA, JPVT, TAU, WORK, & LDW, RWORK, TOLEPS, TOL_OPT, RANK, MAXRANK, INFO, & ISLR) C This routine computes a Rank-Revealing QR factorization of a dense C matrix A. The factorization is truncated when the absolute value of C a diagonal coefficient of the R factor becomes smaller than a C prescribed threshold TOLEPS. The resulting partial Q and R factors C provide a rank-k approximation of the input matrix A with accuracy C TOLEPS. C C This routine is obtained by merging the LAPACK C (http://www.netlib.org/lapack/) CGEQP3 and CLAQPS routines and by C applying a minor modification to the outer factorization loop in C order to stop computations as soon as possible when the required C accuracy is reached. C C Copyright (c) 1992-2017 The University of Tennessee and The C University of Tennessee Research Foundation. All rights reserved. C Copyright (c) 2000-2017 The University of California Berkeley. C All rights reserved. C Copyright (c) 2006-2017 The University of Colorado Denver. C All rights reserved. C C Redistribution and use in source and binary forms, with or without C modification, are permitted provided that the following conditions C are met: C C - Redistributions of source code must retain the above copyright C notice, this list of conditions and the following disclaimer. C C - Redistributions in binary form must reproduce the above C copyright notice, this list of conditions and the following C disclaimer listed in this license in the documentation and/or C other materials provided with the distribution. C C - Neither the name of the copyright holders nor the names of its C contributors may be used to endorse or promote products derived from C this software without specific prior written permission. C C The copyright holders provide no reassurances that the source code C provided does not infringe any patent, copyright, or any other C intellectual property rights of third parties. The copyright holders C disclaim any liability to any recipient for claims brought against C recipient by any third party for infringement of that parties C intellectual property rights. C C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. C IMPLICIT NONE C INTEGER :: INFO, LDA, LDW, M, N, RANK, MAXRANK C TOL_OPT controls the tolerance option used C >0 => use 2-norm (||.||_X = ||.||_2) C <0 => use Frobenius-norm (||.||_X = ||.||_F) C Furthermore, depending on abs(TOL_OPT): C 1 => absolute: ||B_{I(k+1:end),J(k+1:end)}||_X <= TOLEPS C 2 => relative to 2-norm of the compressed block: C ||B_{I(k+1:end),J(k+1:end)}||_X <= TOLEPS*||B_{I,J}||_2 C 3 => relative to the max of the 2-norms of the row and column diagonal blocks C ||B_{I(k+1:end),J{k+1:end}}||_X <= TOLEPS*max(||B_{I,I}||_2,||B_{J,J}||_2) C 4 => relative to the sqrt of product of the 2-norms of the row and column diagonal blocks C ||B_{I(k+1:end),J{k+1:end}}||_X <= TOLEPS*sqrt(||B_{I,I}||_2*||B_{J,J}||_2) INTEGER :: TOL_OPT DOUBLE PRECISION :: TOLEPS INTEGER :: JPVT(*) DOUBLE PRECISION :: RWORK(*) DOUBLE PRECISION :: A(LDA,*), TAU(*) DOUBLE PRECISION :: WORK(LDW,*) LOGICAL :: ISLR DOUBLE PRECISION :: TOLEPS_EFF, TRUNC_ERR INTEGER, PARAMETER :: INB=1, INBMIN=2 INTEGER :: J, JB, MINMN, NB INTEGER :: OFFSET, ITEMP INTEGER :: LSTICC, PVT, K, RK DOUBLE PRECISION :: TEMP, TEMP2, TOL3Z DOUBLE PRECISION :: AKK LOGICAL INADMISSIBLE DOUBLE PRECISION, PARAMETER :: RZERO=0.0D+0, RONE=1.0D+0 DOUBLE PRECISION :: ZERO DOUBLE PRECISION :: ONE PARAMETER ( ONE = 1.0D+0 ) PARAMETER ( ZERO = 0.0D+0 ) DOUBLE PRECISION :: dlamch INTEGER :: ilaenv, idamax EXTERNAL :: idamax, dlamch EXTERNAL dgeqrf, dormqr, xerbla EXTERNAL ilaenv EXTERNAL dgemm, dgemv, dlarfg, dswap DOUBLE PRECISION, EXTERNAL :: dnrm2 INFO = 0 ISLR = .FALSE. IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.EQ.0 ) THEN IF( LDW.LT.N ) THEN INFO = -8 END IF END IF IF( INFO.NE.0 ) THEN WRITE(*,999) -INFO RETURN END IF MINMN = MIN(M,N) IF( MINMN.EQ.0 ) THEN RANK = 0 RETURN END IF NB = ilaenv( INB, 'CGEQRF', ' ', M, N, -1, -1 ) SELECT CASE(abs(TOL_OPT)) CASE(1) TOLEPS_EFF = TOLEPS CASE(2) C TOLEPS_EFF will be computed at step K=1 below CASE DEFAULT write(*,*) 'Internal error in DMUMPS_TRUNCATED_RRQR: TOL_OPT =', & TOL_OPT CALL MUMPS_ABORT() END SELECT TOLEPS_EFF = TOLEPS C C Avoid pointers (and TARGET attribute on RWORK/WORK) C because of implicit interface. An implicit interface C is needed to avoid intermediate array copies C VN1 => RWORK(1:N) C VN2 => RWORK(N+1:2*N) C AUXV => WORK(1:LDW,1:1) C F => WORK(1:LDW,2:NB+1) C LDF = LDW * Initialize partial column norms. The first N elements of work * store the exact column norms. DO J = 1, N C VN1( J ) = dnrm2( M, A( 1, J ), 1 ) RWORK( J ) = dnrm2( M, A( 1, J ), 1 ) C VN2( J ) = VN1( J ) RWORK( N + J ) = RWORK( J ) JPVT(J) = J END DO IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for first step C TRUNC_ERR = dnrm2( N, VN1( 1 ), 1 ) TRUNC_ERR = dnrm2( N, RWORK( 1 ), 1 ) ENDIF OFFSET = 0 TOL3Z = SQRT(dlamch('Epsilon')) DO JB = MIN(NB,MINMN-OFFSET) LSTICC = 0 K = 0 DO IF(K.EQ.JB) EXIT K = K+1 RK = OFFSET+K C PVT = ( RK-1 ) + IDAMAX( N-RK+1, VN1( RK ), 1 ) PVT = ( RK-1 ) + idamax( N-RK+1, RWORK( RK ), 1 ) IF (RK.EQ.1) THEN C IF (abs(TOL_OPT).EQ.2) TOLEPS_EFF = VN1(PVT)*TOLEPS IF (abs(TOL_OPT).EQ.2) TOLEPS_EFF = RWORK(PVT)*TOLEPS ENDIF IF (TOL_OPT.GT.0) THEN C TRUNC_ERR = VN1(PVT) TRUNC_ERR = RWORK(PVT) C ELSE C TRUNC_ERR has been already computed at previous step ENDIF IF(TRUNC_ERR.LT.TOLEPS_EFF) THEN RANK = RK-1 ISLR = .TRUE. RETURN ENDIF INADMISSIBLE = (RK.GT.MAXRANK) IF (INADMISSIBLE) THEN RANK = RK INFO = RK ISLR = .FALSE. RETURN END IF IF( PVT.NE.RK ) THEN CALL dswap( M, A( 1, PVT ), 1, A( 1, RK ), 1 ) c CALL dswap( K-1, F( PVT-OFFSET, 1 ), LDF, c & F( K, 1 ), LDF ) CALL dswap( K-1, WORK( PVT-OFFSET, 2 ), LDW, & WORK( K, 2 ), LDW ) ITEMP = JPVT(PVT) JPVT(PVT) = JPVT(RK) JPVT(RK) = ITEMP C VN1(PVT) = VN1(RK) C VN2(PVT) = VN2(RK) RWORK(PVT) = RWORK(RK) RWORK(N+PVT) = RWORK(N+RK) END IF * Apply previous Householder reflectors to column K: * A(RK:M,RK) := A(RK:M,RK) - A(RK:M,OFFSET+1:RK-1)*F(K,1:K-1)**H. IF( K.GT.1 ) THEN CALL dgemv( 'No transpose', M-RK+1, K-1, -ONE, C & A(RK,OFFSET+1), LDA, F(K,1), LDF, & A(RK,OFFSET+1), LDA, WORK(K,2), LDW, & ONE, A(RK,RK), 1 ) END IF * Generate elementary reflector H(k). IF( RK.LT.M ) THEN CALL dlarfg( M-RK+1, A(RK,RK), A(RK+1,RK), 1, TAU(RK) ) ELSE CALL dlarfg( 1, A(RK,RK), A(RK,RK), 1, TAU(RK) ) END IF AKK = A(RK,RK) A(RK,RK) = ONE * Compute Kth column of F: * F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**H*A(RK:M,K). IF( RK.LT.N ) THEN CALL dgemv( 'Transpose', M-RK+1, N-RK, TAU(RK), & A(RK,RK+1), LDA, A(RK,RK), 1, ZERO, C & F( K+1, K ), 1 ) & WORK( K+1, K+1 ), 1 ) END IF * Padding F(1:K,K) with zeros. DO J = 1, K C F( J, K ) = ZERO WORK( J, K+1 ) = ZERO END DO * Incremental updating of F: * F(1:N,K) := F(1:N-OFFSET,K) - * tau(RK)*F(1:N,1:K-1)*A(RK:M,OFFSET+1:RK-1)**H*A(RK:M,RK). IF( K.GT.1 ) THEN CALL dgemv( 'Transpose', M-RK+1, K-1, -TAU(RK), & A(RK,OFFSET+1), LDA, A(RK,RK), 1, ZERO, & WORK(1,1), 1 ) C & AUXV(1,1), 1 ) CALL dgemv( 'No transpose', N-OFFSET, K-1, ONE, & WORK(1,2), LDW, WORK(1,1), 1, ONE, WORK(1,K+1), 1 ) C & F(1,1), LDF, AUXV(1,1), 1, ONE, F(1,K), 1 ) END IF * Update the current row of A: * A(RK,RK+1:N) := A(RK,RK+1:N) - A(RK,OFFSET+1:RK)*F(K+1:N,1:K)**H. IF( RK.LT.N ) THEN C CALL dgemv( 'No Transpose', N-RK, K, -ONE, F( K+1, 1 ), CALL dgemv( 'No Transpose', N-RK, K, -ONE, WORK( K+1,2 ), & LDW, & A( RK, OFFSET+1 ), LDA, ONE, A( RK, RK+1 ), LDA ) END IF * Update partial column norms. * IF( RK.LT.MINMN ) THEN DO J = RK + 1, N C IF( VN1( J ).NE.RZERO ) THEN IF( RWORK( J ).NE.RZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * C TEMP = ABS( A( RK, J ) ) / VN1( J ) TEMP = ABS( A( RK, J ) ) / RWORK( J ) TEMP = MAX( RZERO, ( RONE+TEMP )*( RONE-TEMP ) ) C TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 TEMP2 = TEMP*( RWORK( J ) / RWORK( N+J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN C VN2( J ) = dble( LSTICC ) RWORK( N+J ) = dble( LSTICC ) LSTICC = J ELSE C VN1( J ) = VN1( J )*SQRT( TEMP ) RWORK( J ) = RWORK( J )*SQRT( TEMP ) END IF END IF END DO END IF A( RK, RK ) = AKK IF (LSTICC.NE.0) EXIT IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for next step C TRUNC_ERR = dnrm2( N-RK, VN1( RK+1 ), 1 ) TRUNC_ERR = dnrm2( N-RK, RWORK( RK+1 ), 1 ) ENDIF END DO * Apply the block reflector to the rest of the matrix: * A(RK+1:M,RK+1:N) := A(RK+1:M,RK+1:N) - * A(RK+1:M,OFFSET+1:RK)*F(K+1:N-OFFSET,1:K)**H. IF( RK.LT.MIN(N,M) ) THEN CALL dgemm( 'No transpose', 'Transpose', M-RK, & N-RK, K, -ONE, A(RK+1,OFFSET+1), LDA, C & F(K+1,1), LDF, ONE, A(RK+1,RK+1), LDA ) & WORK(K+1,2), LDW, ONE, A(RK+1,RK+1), LDA ) END IF * Recomputation of difficult columns. DO WHILE( LSTICC.GT.0 ) C ITEMP = NINT( VN2( LSTICC ) ) ITEMP = NINT( RWORK( N + LSTICC ) ) C VN1( LSTICC ) = dnrm2( M-RK, A( RK+1, LSTICC ), 1 ) RWORK( LSTICC ) = dnrm2( M-RK, A( RK+1, LSTICC ), 1 ) * * NOTE: The computation of RWORK( LSTICC ) relies on the fact that * SNRM2 does not fail on vectors with norm below the value of * SQRT(DLAMCH('S')) * C VN2( LSTICC ) = VN1( LSTICC ) RWORK( N + LSTICC ) = RWORK( LSTICC ) LSTICC = ITEMP END DO IF(RK.GE.MINMN) EXIT OFFSET = RK IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for next step C TRUNC_ERR = dnrm2( N-RK, VN1( RK+1 ), 1 ) TRUNC_ERR = dnrm2( N-RK, RWORK( RK+1 ), 1 ) ENDIF END DO RANK = RK ISLR = .NOT.(RK.GT.MAXRANK) RETURN 999 FORMAT ('On entry to DMUMPS_TRUNCATED_RRQR, parameter number', & I2,' had an illegal value') END SUBROUTINE DMUMPS_TRUNCATED_RRQR MUMPS_5.8.1/src/zana_driver.F0000664000175000017500000057126715042446442015667 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C SUBROUTINE ZMUMPS_ANA_DRIVER(id,idintr) USE MUMPS_STATIC_MAPPING USE ZMUMPS_STRUC_DEF USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_INTR_STRUC USE MUMPS_MEMORY_MOD USE ZMUMPS_PARALLEL_ANALYSIS USE ZMUMPS_ANA_LR USE ZMUMPS_LR_CORE USE MUMPS_LR_STATS USE MUMPS_LR_COMMON USE ZMUMPS_ANA_AUX_M USE MUMPS_ANA_BLK_M, ONLY: COMPACT_GRAPH_T, LMATRIX_T IMPLICIT NONE INTERFACE C Explicit interfaces when id has the TARGET attribute SUBROUTINE ZMUMPS_ANA_ARROWHEADS_WRAPPER & (id, GATHER_MATRIX_ALLOCATED) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET :: id LOGICAL, INTENT(INOUT) :: GATHER_MATRIX_ALLOCATED END SUBROUTINE ZMUMPS_ANA_ARROWHEADS_WRAPPER SUBROUTINE ZMUMPS_ANA_COMPUTE_ESTIMATES (id, idintr) USE ZMUMPS_STRUC_DEF USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_INTR_STRUC TYPE (ZMUMPS_STRUC), TARGET :: id TYPE (ZMUMPS_INTR_STRUC) :: idintr END SUBROUTINE ZMUMPS_ANA_COMPUTE_ESTIMATES END INTERFACE C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) C C Purpose C ======= C C Performs analysis and (if required) Max-trans on the master, then C broadcasts information to the slaves. Also includes mapping. C C C Parameters C ========== C TYPE(ZMUMPS_STRUC), TARGET :: id TYPE(ZMUMPS_INTR_STRUC) :: idintr C C Local variables C =============== C C C Pointers inside integer array IKEEPALLOC, various data INTEGER(8) IKEEP, NE, NA INTEGER I, allocok C Other locals INTEGER NB_NIV2, IDEST INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MP, LP, MPG LOGICAL PROK, PROKG, LISTVAR_SCHUR_2BE_FREED, LPOK INTEGER SIZE_SCHUR_PASSED INTEGER LEAF, INODE, ISTEP, INN, LPTRAR INTEGER NBLEAF, NBROOT, MYROW_CHECK, INIV2 DOUBLE PRECISION TIMEG DOUBLE PRECISION :: PEAK C C Related to commuicators for parallel analysis: C COMM_PARAORD: communicator on which Parmetis/PTscotch C is performed C COMM_PARASYMB: communicator on which parallel symbolic C facto is performed C PARAORD_to_idCOMM (1:NPROCS_PARAORD) is such that C PARAORD_to_idCOMM(idPARAORD+1)=idCOMM, C where idPARAORD \in [0:NPROCS_PARAORD] C RKinSYMB_PROC0ORD: Rank in COMM_PARASYMB of proc 0 in C COMM_PARAORD C RKinidCOMM_PROC0SYMB: Rank in id%COMM of proc 0 in C COMM_PARASYMB C INTEGER :: COMM_PARAORD, NPROCS_PARAORD, RKinSYMB_PROC0ORD, & OPTION_COMM_PARAORD INTEGER :: COMM_PARASYMB, NPROCS_PARASYMB, & RKinidCOMM_PROC0SYMB LOGICAL :: COMM_PARAORD_ALLOCATED, COMM_PARASYMB_ALLOCATED INTEGER, ALLOCATABLE, DIMENSION(:) :: PARAORD_to_idCOMM #if defined(AVOID_MPI_IN_PLACE) INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP #endif C C INTEGER WORKSPACE C INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: PAR2_NODES INTEGER, DIMENSION(:), POINTER :: PAR2_NODESPTR INTEGER, ALLOCATABLE, DIMENSION(:) :: PROCNODE INTEGER, DIMENSION(:), ALLOCATABLE :: IWtemp INTEGER, DIMENSION(:), ALLOCATABLE :: XNODEL, NODEL INTEGER, DIMENSION(:), POINTER :: SSARBR C Element matrix entry INTEGER, POINTER :: NELT, LELTVAR INTEGER, DIMENSION(:), POINTER :: KEEP, INFO, INFOG INTEGER(8), DIMENSION(:), POINTER :: KEEP8 DOUBLE PRECISION, DIMENSION(:), POINTER :: RINFO DOUBLE PRECISION, DIMENSION(:), POINTER :: RINFOG INTEGER, DIMENSION(:), POINTER :: ICNTL LOGICAL :: I_AM_SLAVE, COND INTEGER, TARGET :: IDUMMY_ARRAY(1) INTEGER(8) :: NNZ_loc, NNZ_TMP INTEGER, POINTER, DIMENSION(:) :: IRN_loc_PTR INTEGER, POINTER, DIMENSION(:) :: JCN_loc_PTR INTEGER, POINTER, DIMENSION(:) :: IRN_PTR INTEGER, POINTER, DIMENSION(:) :: JCN_PTR INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR INTEGER, POINTER, DIMENSION(:) :: UNS_PERM_PTR !$ INTEGER :: NOMPMAX INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER, EXTERNAL :: MUMPS_ENCODE_TPN_IPROC INTEGER :: PROCNODE_VALUE INTEGER K,J, IFS INTEGER SIZE_TEMP_MEM,SIZE_DEPTH_FIRST,SIZE_COST_TRAV LOGICAL IS_BUILD_LOAD_MEM_CALLED LOGICAL PRINT_MAXAVG LOGICAL :: PRINT_NODEINFO 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 :: SIZE_PAR2_NODESPTR INTEGER :: LSIZEOFBLOCKS_PTR LOGICAL :: READY_FOR_ANA_F INTEGER, ALLOCATABLE, DIMENSION(:) :: MAPCOL LOGICAL :: BLKPTR_ALLOCATED, BLKVAR_ALLOCATED INTEGER, POINTER, DIMENSION(:) :: BLKPTR_PTRLOC, BLKVAR_PTRLOC INTEGER :: IB, BLKSIZE INTEGER :: IBcurrent, IPOS, IPOSB, II C Internal work arrays: C DOF2BLOCK(idof)=inode, idof in [1,N], inode in [1,NBLK] C SIZEBLOCK(1:NBLK) (for node valuation) INTEGER, TARGET, DIMENSION(:), allocatable:: SIZEOFBLOCKS INTEGER, DIMENSION(:), allocatable:: DOF2BLOCK INTEGER :: NBRECORDS INTEGER(8) :: NSEND8, NLOCAL8, IDUMMY8 C LMAT_BLOCK: in case of centralized matrix, C to store on MASTER the cleaned Lmatrix C used to compute GCOMP C LMAT_BLOCK might also be saved to C be used during grouping C LUMAT : in case of distributed matrix C to store distributed the cleaned LU matrix C LUMAT might also be saved to C be used for MPI based grouping C LUMAT_REMAP : in case of distributed matrix C it is used to remap LUMAT C C GCOMP : Graph "ready" to be called by orderings C INTEGER(8) :: MEMCNT TYPE(LMATRIX_T) :: LMAT_BLOCK, LUMAT, LUMAT_REMAP INTEGER :: LMAT_BLOCK_AVAIL_I LOGICAL :: GCOMP_PROVIDED, & LUMAT_AVAIL, LMAT_BLOCK_AVAIL LOGICAL :: LUMAT_REMAP_DIST_AVAIL, & LUMAT_REMAP_CENT_AVAIL TYPE(COMPACT_GRAPH_T) :: GCOMP TYPE(COMPACT_GRAPH_T) :: GCOMP_DIST INTEGER(4) :: I4 INTEGER, POINTER, DIMENSION(:) :: & NFSIZPTR, & FREREPTR, & IKEEP1, IKEEP2, IKEEP3 #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: FILS_TMPPTR #endif INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: FILS_TMP INTEGER, ALLOCATABLE, DIMENSION(:) :: STEP_TMP, & LRGROUPS_TMP INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: IKEEPALLOC INTEGER, ALLOCATABLE, DIMENSION(:) :: WORK2ALLOC INTEGER :: SIZELRGROUPS_TMP INTEGER(8) :: SIZEIKEEPALLOC, SIZEWORK2ALLOC INTEGER(kind=8) :: NZ8, LIW8 C NBLK : id%N or order of blocked matrix INTEGER :: NBLK, idNBLKSAVE INTEGER(8) :: LIW8_ELT C GATHER_MATRIX_ALLOCATED: C To be sure that id%IRN and id%JCN are C deallocated only when ZMUMPS_GATHER_MATRIX was called LOGICAL :: GATHER_MATRIX_ALLOCATED C C Beginning of executable statements C C ZMUMPS_FREE_DATA_ANAFACSOL was called in ZMUMPS_DRIVER C to reduce the memory peak during analysis, especially C when computing the graph associated to the input matrix. IS_BUILD_LOAD_MEM_CALLED=.FALSE. KEEP => id%KEEP KEEP8 => id%KEEP8 INFO => id%INFO RINFO => id%RINFO INFOG => id%INFOG RINFOG => id%RINFOG ICNTL => id%ICNTL NELT => id%NELT LELTVAR => id%LELTVAR KEEP(264) = 0 ! reinitialise out-of-range status (0=yes) KEEP(265) = 0 ! reinitialise dupplicates (0=yes) KEEP(280) = 0 ! size of id%LRGROUPS PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) C FIXME: count memory used during analysis MEMCNT = 0_8 C Print per node information only in case there are several C compute nodes (id%KEEP(412): #MPI procs on compute node) PRINT_NODEINFO = PRINT_MAXAVG .AND. id%NPROCS .NE. id%KEEP(412) GATHER_MATRIX_ALLOCATED = .FALSE. COMM_PARAORD = MPI_COMM_NULL COMM_PARASYMB = id%COMM COMM_PARAORD_ALLOCATED = .FALSE. COMM_PARASYMB_ALLOCATED = .FALSE. RKinidCOMM_PROC0SYMB = MASTER NULLIFY ( NFSIZPTR, FREREPTR, & IKEEP1, IKEEP2, IKEEP3, & SSARBR, SIZEOFBLOCKS_PTR, IRN_loc_PTR, JCN_loc_PTR, & IRN_PTR, JCN_PTR, & PAR2_NODESPTR, BLKPTR_PTRLOC, BLKVAR_PTRLOC) IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM) nullify(id%UNS_PERM) C Set default value that witl be reset in C case of blocked format matrices NBLK = id%N GCOMP_PROVIDED = .FALSE. BLKPTR_ALLOCATED = .FALSE. BLKVAR_ALLOCATED = .FALSE. LUMAT_AVAIL = .FALSE. LMAT_BLOCK_AVAIL = .FALSE. C ------------------------------------- C Depending on the type of parallelism, C the master can now (soon) potentially C have the role of a slave C ------------------------------------- I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(ICNTL(4).GE.2)) IF ( PROK ) THEN IF ( KEEP(50) .eq. 0 ) THEN WRITE(MP, '(A)') 'L U Solver for unsymmetric matrices' ELSE IF ( KEEP(50) .eq. 1 ) THEN WRITE(MP, '(A)') & 'L D L^T Solver for symmetric positive definite matrices' ELSE WRITE(MP, '(A)') & 'L D L^T Solver for general symmetric matrices' END IF IF ( KEEP(46) .eq. 1 ) THEN WRITE(MP, '(A)') 'Type of parallelism: Working host' ELSE WRITE(MP, '(A)') 'Type of parallelism: Host not working' END IF END IF IF ( PROKG .AND. (MP.NE.MPG)) THEN IF ( KEEP(50) .eq. 0 ) THEN WRITE(MPG, '(A)') 'L U Solver for unsymmetric matrices' ELSE IF ( KEEP(50) .eq. 1 ) THEN WRITE(MPG, '(A)') & 'L D L^T Solver for symmetric positive definite matrices' ELSE WRITE(MPG, '(A)') & 'L D L^T Solver for general symmetric matrices' END IF IF ( KEEP(46) .eq. 1 ) THEN WRITE(MPG, '(A)') 'Type of parallelism: Working host' ELSE WRITE(MPG, '(A)') 'Type of parallelism: Host not working' END IF END IF IF (PROK) WRITE( MP, 110 ) IF (PROKG .AND. (MPG.NE.MP)) WRITE( MPG, 110 ) C Reinitialize last used size of WK_USER C --------------------------------------- KEEP8(24) = 0_8 C C C C Decode API (ICNTL parameters, mainly) C and check consistency of the KEEP array. C Note: ZMUMPS_ANA_CHECK_KEEP also sets C some INFOG parameters CALL ZMUMPS_ANA_CHECK_KEEP(id, I_AM_SLAVE) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C ------------------------------------------- C Broadcast KEEP(60) since we need to broadcast C related information C ------------------------------------------ CALL MPI_BCAST( KEEP(60), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C broadcast also size of schur IF (id%KEEP(60) .NE. 0 ) THEN CALL MPI_BCAST( KEEP(116), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF IF (id%KEEP(60) .EQ. 2 .or. id%KEEP(60). EQ. 3) THEN CALL MPI_BCAST( id%NPROW, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NPCOL, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%MBLOCK, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NBLOCK, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) C Note that ZMUMPS_INIT_ROOT_ANA will C then use that information. ENDIF C ---------------------------------------------- C Broadcast KEEP(54) now to know if the C structure of the graph is intially distributed C and should be assembled on the master C Broadcast KEEP(55) now to know if the C matrix is in assembled or elemental format C ---------------------------------------------- CALL MPI_BCAST( KEEP(54), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast KEEP(69) now to know if C we will need to communicate during analysis C ---------------------------------------------- CALL MPI_BCAST( KEEP(69), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast Out of core strategy (used only on master so far) C Boradcast KEEP(201), KEEP(202) and KEEP(203) C ---------------------------------------------- CALL MPI_BCAST( KEEP(201), 3, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast analysis strategy (used only on master so far) C ---------------------------------------------- CALL MPI_BCAST( KEEP(244), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) IF (KEEP(244).NE.1) THEN C broadcast parallel ordering strategy used CALL MPI_BCAST( KEEP(245), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF C --------------------------- C Fwd in facto C Broadcast KEEP(251,252,253) defined on master so far CALL MPI_BCAST( KEEP(251), 3, MPI_INTEGER,MASTER,id%COMM,IERR) C CALL MPI_BCAST( KEEP(401), 1, MPI_INTEGER,MASTER,id%COMM,IERR) id%KEEP(400) = 0 id%KEEP(369) = id%KEEP(368) !$ IF (id%KEEP(401).GT.0) THEN !$ id%KEEP(400) = omp_get_max_threads() C => id%KEEP(400)>=1 C C IF KEEP(400)<=1 on all procs switch off L0 thread: !$ CALL MPI_ALLREDUCE(id%KEEP(400),NOMPMAX,1,MPI_INTEGER, !$ & MPI_MAX,id%COMM,IERR) !$ IF (NOMPMAX.LE.1) THEN !$ id%KEEP(400) = 0 !$ id%KEEP(401) = 0 !$ ENDIF !$ ENDIF !$ IF (id%KEEP(400).GT.0 .AND. id%KEEP(401).GT.0 !$ & .AND. id%KEEP(369).GT.0) THEN C reset id%KEEP(400) to value provided by user !$ id%KEEP(400) = min(id%KEEP(400),id%KEEP(369)) !$ ENDIF CALL MPI_BCAST( id%KEEP(490), 5, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( KEEP(123),1,MPI_INTEGER,MASTER,id%COMM,IERR) C ---------------------------------------------- C Broadcast N C ---------------------------------------------- CALL MPI_BCAST( id%N, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast NZ for assembled entry C ---------------------------------------------- IF ( KEEP(55) .EQ. 0) THEN IF ( KEEP(54) .eq. 3 ) THEN C Reset to 0 id%KEEP8(29) for host not working, since C value provided by user might be undefined IF (.NOT.I_AM_SLAVE) id%KEEP8(29)= 0_8 C Compute total number of non-zeros CALL MPI_ALLREDUCE( id%KEEP8(29), id%KEEP8(28), 1, & MPI_INTEGER8, & MPI_SUM, id%COMM, IERR ) C Local number of non-zeros cannot be negative IF (id%KEEP8(29) .LT. 0_8) THEN id%INFO(1) = -2 CALL MUMPS_SET_IERROR(id%KEEP8(29), id%INFO(2)) ENDIF ELSE C Broadcast NZ from the master node CALL MPI_BCAST( id%KEEP8(28), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) END IF C Total number of non zeros must be positive strictly IF (id%KEEP8(28) .LE. 0_8) THEN id%INFO(1) = -2 CALL MUMPS_SET_IERROR(id%KEEP8(28), id%INFO(2)) ENDIF ELSE C Broadcast NA_ELT <=> KEEP8(30) for elemental entry CALL MPI_BCAST( id%KEEP8(30), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) ENDIF IF( id%KEEP(54).EQ.3) THEN C test IRN_loc and JCN_loc allocated on working procs IF (I_AM_SLAVE .AND. id%KEEP8(29).GT.0 .AND. & ( (.NOT. associated(id%IRN_loc)) .OR. & (.NOT. associated(id%JCN_loc)) ) & ) THEN id%INFO(1) = -22 id%INFO(2) = 16 ENDIF ENDIF IF ( associated(id%MEM_DIST) ) THEN DEALLOCATE( id%MEM_DIST ) ENDIF allocate( id%MEM_DIST( 0:id%NSLAVES-1 ), STAT=IERR ) IF ( IERR .GT. 0 ) THEN INFO(1) = -7 INFO(2) = id%NSLAVES IF ( LPOK ) THEN WRITE(LP, 150) 'MEM_DIST' END IF END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 id%MEM_DIST(0:id%NSLAVES-1) = 0 CALL MUMPS_INIT_ARCH_PARAMETERS( & id%COMM,id%COMM_NODES,KEEP(69),KEEP(46), & id%NSLAVES,id%MEM_DIST,INFO ) C ======================== C Write problem to a file, C if requested by the user C ======================== CALL ZMUMPS_DUMP_PROBLEM(id) IF ( id%INFO(1) .LT. 0 ) GOTO 500 C ================= C ANALYSIS BY BLOCK C ================= IF ( id%MYID .EQ. MASTER ) THEN IF (KEEP(13).EQ.1) THEN NBLK=id%NBLK ELSE IF (KEEP(13).LT.0) THEN C regular blocks in BLKVAR of size -KEEP(13) C mod(id%N,-KEEP(13)) has already been checked NBLK = id%N/(-KEEP(13)) ENDIF C end of id%MYID .EQ. MASTER ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 500 C C Broadcast KEEP(13-14), NBLK CALL MPI_BCAST( KEEP(13), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( NBLK, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C C =========================== IF (KEEP(13).NE.0) THEN C { BEGIN preparation ANA_BLK C =========================== IF ( & ( KEEP(244).NE.1) & .OR. ( (KEEP(54).NE.3).AND.(id%MYID.EQ.MASTER) ) & .OR. (KEEP(54).EQ.3) ) THEN C{ C ---------------------------------------- C Allocate SIZEOFBLOCKS, DOF2BLOCK C ---------------------------------------- IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) allocate(SIZEOFBLOCKS(NBLK), DOF2BLOCK(id%N), & STAT=allocok) C IF (allocok.NE.0) THEN id%INFO( 1 ) = -7 id%INFO( 2 ) = id%N+NBLK IF ( LPOK ) WRITE(LP, 150) ' SIZEOFBLOCKS, DOF2BLOCK' ENDIF C IF ( (allocok.EQ.0) .AND. (id%MYID.EQ.MASTER)) THEN C{ BLKPTR and BLKVAR needed for ZMUMPS_EXPAND_TREE C allocate then if not associated IF (.NOT.associated(id%BLKPTR).OR.KEEP(13).LT.0) THEN BLKPTR_ALLOCATED = .TRUE. C allocate(id%BLKPTR(NBLK+1), STAT=allocok) allocate(BLKPTR_PTRLOC(NBLK+1), STAT=allocok) IF (allocok.NE.0) THEN BLKPTR_ALLOCATED = .FALSE. id%INFO( 1 ) = -7 id%INFO( 2 ) = NBLK+1 IF ( LPOK ) WRITE(LP, 150) ' id%BLKPTR ' ENDIF ELSE BLKPTR_PTRLOC=>id%BLKPTR ENDIF IF (allocok.EQ.0) THEN IF (.NOT.associated(id%BLKVAR).OR.KEEP(13).LT.0) THEN allocate(BLKVAR_PTRLOC(id%N), STAT=allocok) BLKVAR_ALLOCATED = .TRUE. IF (allocok.NE.0) THEN BLKVAR_ALLOCATED = .FALSE. id%INFO( 1 ) = -7 id%INFO( 2 ) = id%N IF ( LPOK ) WRITE(LP, 150) ' id%BLKVAR ' ENDIF ELSE BLKVAR_PTRLOC => id%BLKVAR ENDIF ENDIF C} ENDIF C} ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 500 IF ( id%MYID .EQ. MASTER ) THEN C{ ----------------------------------------- C Compute SIZEOFBLOCKS, DOF2BLOCK on MASTER C based on id%BLKPTR and id%BLKVAR C and compute id%BLKPTR and id%BLKVAR if not C provided by user C ----------------------------------------- IF (BLKVAR_ALLOCATED) THEN C implicitly id%BLKVAR(I)=I DO I=1, id%N BLKVAR_PTRLOC(I)=I ENDDO ENDIF IF (BLKPTR_ALLOCATED) THEN IB=0 BLKSIZE=-KEEP(13) DO I=1, id%N, BLKSIZE IB=IB+1 BLKPTR_PTRLOC(IB) = I ENDDO BLKPTR_PTRLOC(NBLK+1) = id%N+1 ENDIF C CALL MUMPS_AB_COMPUTE_SIZEOFBLOCK ( & NBLK, id%N, BLKPTR_PTRLOC(1), BLKVAR_PTRLOC(1), & SIZEOFBLOCKS, DOF2BLOCK) C} ENDIF C ======================== IF (KEEP(244).NE.1) THEN C{ Parallel analysis C ======================== C KEEP(13).ne.0 only if KEEP(339).NE.0 : IF (KEEP(339).EQ.0) THEN INFO(1) = -901 INFO(2) = KEEP(13) IF ( LPOK ) WRITE(LP, 150) ' Internal error K339' ENDIF NNZ_loc = 0_8 C ----------------------------------------- C Build distributed clean LUMAT matrix C even when matrix is provided centralised C ----------------------------------------- IF (KEEP(54).EQ.3) THEN IF (.NOT. I_AM_SLAVE .OR. ! non-working master & KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc NNZ_loc = KEEP8(29) ENDIF ELSE C Matrix on host IF (id%MYID.EQ.MASTER) THEN C Store input matrix (IRN/JCN) as a cleaned blocked Lmatrix C of nodes (indices \in [1,NBLK]) IF (id%KEEP8(28) .EQ. 0_8) THEN IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ELSE IRN_loc_PTR => id%IRN JCN_loc_PTR => id%JCN NNZ_loc = id%KEEP8(28) ENDIF ELSE IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ENDIF ENDIF C build communicator for parallel ordering C used to distribute LUMAT OPTION_COMM_PARAORD = 0 CALL MUMPS_BUILD_COMM_PARA_ANA ( & OPTION_COMM_PARAORD, id%N, & id%COMM, id%MYID, id%COMM_NODES, id%MYID_NODES, & id%NPROCS, id%NSLAVES, & id%KEEP(1), & COMM_PARAORD, NPROCS_PARAORD, & COMM_PARAORD_ALLOCATED, & COMM_PARASYMB, NPROCS_PARASYMB, & COMM_PARASYMB_ALLOCATED, & id%ICNTL(1), id%INFO(1)) C allocate and initialize PARAORD_to_idCOMM if (allocated(PARAORD_to_idCOMM)) & DEALLOCATE(PARAORD_to_idCOMM) allocate(PARAORD_to_idCOMM(NPROCS_PARAORD), #if defined(AVOID_MPI_IN_PLACE) & TMP(NPROCS_PARAORD), #endif & STAT=allocok) IF (allocok.NE.0) THEN id%INFO( 1 ) = -7 id%INFO( 2 ) = NPROCS_PARAORD #if defined(AVOID_MPI_IN_PLACE) & + NPROCS_PARAORD #endif IF ( LPOK ) WRITE(LP, 150) ' PARAORD_to_idCOMM' ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 500 CALL MUMPS_BUILD_PARAORD_to_idCOMM ( & id%COMM, id%MYID, id%KEEP(1), & COMM_PARASYMB, NPROCS_PARASYMB, & COMM_PARAORD, NPROCS_PARAORD, & PARAORD_to_idCOMM, #if defined(AVOID_MPI_IN_PLACE) & TMP, #endif & RKinSYMB_PROC0ORD, & RKinidCOMM_PROC0SYMB, id%NPROCS ) #if defined(AVOID_MPI_IN_PLACE) DEALLOCATE(TMP) #endif C C C build LUMAT such that col of LUMAT are distributed C only procs in COMM_PARAORD C CALL MUMPS_AB_DCOORD_TO_DLUMAT ( & id%MYID, id%NPROCS, id%COMM, & NPROCS_PARAORD, PARAORD_to_idCOMM, & NBLK, id%N, & NNZ_loc, & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), id%KEEP8(1), & LUMAT) IF (allocated(PARAORD_to_idCOMM)) THEN DEALLOCATE(PARAORD_to_idCOMM) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 LUMAT_AVAIL = .TRUE. C SIZEOFBLOCKS needed on all procs during // analysis CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, & id%COMM, IERR ) C C} End of Parallel analysis ELSE C =================== C{ Sequential analysis C =================== C ======================= IF (KEEP(54).NE.3.OR.id%NPROCS.EQ.1) THEN C ======================= C{ Matrix structure available on host C also case of distributed input matrix format C with one mpi proc C --------------------- KEEP(14) = 0 IF (id%MYID.EQ.MASTER) THEN C Store input matrix (IRN/JCN) as a cleaned blocked Lmatrix C of nodes (indices \in [1,NBLK]) IF (KEEP(54).NE.3) THEN IF (id%KEEP8(28) .EQ. 0_8) THEN IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY ELSE IRN_PTR => id%IRN JCN_PTR => id%JCN ENDIF NNZ_TMP = id%KEEP8(28) ELSE IF (id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY id%KEEP8(29) = 0_8 ELSE IRN_PTR => id%IRN_loc JCN_PTR => id%JCN_loc ENDIF NNZ_TMP = id%KEEP8(29) ENDIF CALL MUMPS_AB_COORD_TO_LMAT ( id%MYID, & NBLK, id%N, NNZ_TMP, IRN_PTR(1), JCN_PTR(1), & DOF2BLOCK, & INFO(1), INFO(2), LP, LPOK, & LMAT_BLOCK, IDUMMY8, KEEP(1) ) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C IF (id%MYID.EQ.MASTER) THEN C From LMAT_BLOCK build GCOMP format wich requires C symmetrizing the Lmatrix CALL MUMPS_AB_LMAT_TO_CLEAN_G ( id%MYID, .TRUE., & .TRUE., ! not relevant because unfold is true & LMAT_BLOCK, GCOMP, & INFO(1), ICNTL(1), MEMCNT) GCOMP_PROVIDED = .TRUE. IF (KEEP(494).EQ.0.OR.KEEP(487).NE.1) THEN CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK, KEEP(147)) LMAT_BLOCK_AVAIL_I = 0 ELSE LMAT_BLOCK_AVAIL_I = 1 ENDIF ENDIF CALL MPI_BCAST( LMAT_BLOCK_AVAIL_I, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) LMAT_BLOCK_AVAIL = (LMAT_BLOCK_AVAIL_I.EQ.1) C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C} C ==== ELSE C ==== C ---------------------- C{ matrix is distributed C ---------------------- IF (.NOT. I_AM_SLAVE .OR. ! non-working master & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY id%KEEP8(29) = 0_8 ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc ENDIF C C Given distributed matrix IRN_loc_PTR, JCN_loc_PTR C build distributed cleaned graph GCOMP and C save distributed LUMAT in case of grouping C IF (id%NPROCS.EQ.1) THEN C Build GCOMP, the centralized final cleaned graph READY_FOR_ANA_F = .TRUE. CALL MUMPS_AB_DCOORD_TO_DCOMPG ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & LUMAT, LUMAT_AVAIL, GCOMP, READY_FOR_ANA_F) GCOMP_PROVIDED = .TRUE. ELSE READY_FOR_ANA_F = .FALSE. CALL MUMPS_AB_DCOORD_TO_DCOMPG ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & LUMAT, LUMAT_AVAIL, GCOMP_DIST, READY_FOR_ANA_F) ENDIF IF (LUMAT_AVAIL.AND.KEEP(487).NE.1) THEN CALL MUMPS_AB_FREE_LMAT(LUMAT, KEEP(147)) LUMAT_AVAIL = .FALSE. ENDIF C C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C C} end matrix structure is distributed C ===== ENDIF C ===== C} end of sequential analysis C ===== ENDIF C ===== IF (allocated(DOF2BLOCK)) THEN C DOF2BLOCK reused on master if pivot order given by user IF ( (id%MYID.NE.MASTER) .OR. & (id%MYID.EQ.MASTER).AND. (KEEP(256) .NE. 1)) THEN DEALLOCATE(DOF2BLOCK) ENDIF ENDIF C ======================== ENDIF C } END preparation ANA_BLK C ========================= C ==================================================== C TEST FOR SEQUENTIAL OR PARALLEL ANALYSIS (KEEP(244)) C ==================================================== IF ( (KEEP(244).EQ.1) .AND. (KEEP(54) .eq. 3) ) THEN C ----------------------------------------------- C Sequential analysis: C Collect on the host -- if matrix is distributed C at analysis -- all integer information needed C to perform ordering C ----------------------------------------------- C FIXME: one should test instead if GCOMP_DIST available C instead of retestinf KEEP(13) and NPROCS.NE.1 IF (KEEP(13).NE.0) THEN IF (id%NPROCS.NE.1) THEN CALL MUMPS_AB_GATHER_GRAPH( & id%ICNTL(1), KEEP(1), id%COMM, id%MYID, id%NPROCS, & id%INFO(1), & GCOMP_DIST, GCOMP) GCOMP_PROVIDED = .TRUE. C CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST, MEMCNT) ENDIF ELSE CALL ZMUMPS_GATHER_MATRIX(id) GATHER_MATRIX_ALLOCATED = .TRUE. CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF 1234 CONTINUE IF (KEEP(244) .EQ. 1) THEN C Sequential analysis : Schur IF ( id%MYID .eq. MASTER ) THEN C Prepare arguments for call to ZMUMPS_ANA_F and C ZMUMPS_ANA_F_ELT in case id%SCHUR was not allocated C by user. The objective is to avoid passing a null C pointer. C FIXME Block fomat for Schur IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN SIZE_SCHUR_PASSED = 1 LISTVAR_SCHUR_2BE_FREED=.TRUE. allocate( id%LISTVAR_SCHUR( 1 ), STAT=allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) & 'PB allocating an array of size 1 for Schur!! ' INFO(1)=-7 INFO(2)=1 END IF ELSE SIZE_SCHUR_PASSED=id%SIZE_SCHUR LISTVAR_SCHUR_2BE_FREED = .FALSE. END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF C IF ((id%MYID.EQ.MASTER).AND.(KEEP(244) .EQ. 1) & .AND. (id%N.EQ.NBLK) & ) THEN C Sequential analysis : maximum transversal on master IF ((KEEP(50).NE.1).AND. & .NOT.((KEEP(23).EQ.7).AND.KEEP(50).EQ.0) & ) THEN C (KEEP(23).EQ.7).AND.KEEP(50).EQ.0) : C For unsymmetric matrix, if automatic setting is requested C default setting of Maximum Transversal is decided during C ZMUMPS_ANA_F and is based on matrix unsymmetry. C Thus in this case we skip ZMUMPS_ANA_O IF ( ( KEEP(23) .NE. 0 ) .OR. C Automatic choice for scaling does not force Maxtrans C Only when scaling is explicitly asked during analysis C (KEEP(52)=-2) ZMUMPS_ANA_O is called & KEEP(52) .EQ. -2 ) THEN C C Maximum Trans. algorithm called on original matrix. C We compute a permutation of the original matrix to C have a zero free diagonal C KEEP(23)=7 means that automatic choice C of max trans value will be done during analysis C Permutation is held in UNS_PERM(1, ...,N). C Maximum transversal is not available for element C entry format C UNS_PERM that might be set to C to permutation computed during Max transversal ALLOCATE(id%UNS_PERM(id%N),IKEEPALLOC(3_8*int(id%N,8)), & WORK2ALLOC(id%N), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( 5_8 * int(id%N,8), INFO(2) ) ELSE CALL ZMUMPS_ANA_O(id%N, id%KEEP8(28), KEEP(23), & id%UNS_PERM, IKEEPALLOC, 3_8*int(id%N,8), & id%IRN, id%JCN, id%A, & id%ROWSCA, id%COLSCA, & WORK2ALLOC, id%KEEP, id%ICNTL, id%INFO, id%INFOG) IF (allocated(WORK2ALLOC)) DEALLOCATE(WORK2ALLOC) IF (KEEP(23).EQ.0) THEN C Maximum tranversal did not produce a permutation IF (associated( id%UNS_PERM )) & DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF C Check if IKEEPALLOC needed for ANA_F IF (KEEP(23).EQ.0.AND.(KEEP(95).EQ.1)) THEN IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) ENDIF ENDIF IF (INFO(1) .LT. 0) THEN C Fatal error C Permutation was not computed; reset keep(23) KEEP(23) = 0 ELSE ENDIF ELSE KEEP(23) = 0 C Switch off C compressed/contrained ordering id%KEEP(95) = 1 END IF ENDIF C END OF MAX-TRANS ON THE MASTER ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C IF ( KEEP(244) .EQ. 1) THEN C Sequential analysis: allocate data for ordering on MASTER IF (id%MYID.EQ.MASTER) THEN C allocate IKEEPALLOC and TREE related pointers C IKEEPALLOC might have been allocated in ZMUMPS_ANA_O C and IKEEPALLOC(1:N) might hold information to C be given to ANA_F. IF (allocated(IKEEPALLOC)) THEN ALLOCATE( FILS_TMP(NBLK), FREREPTR(NBLK), & NFSIZPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(int(NBLK,8)*3_8, INFO(2)) ENDIF ELSE ALLOCATE(IKEEPALLOC(int(NBLK,8)+2_8*int(id%N,8)), & FILS_TMP(NBLK), FREREPTR(NBLK), & NFSIZPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(int(NBLK,8)*4_8+2_8*int(id%N,8), & INFO(2)) ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF C IF (KEEP(244) .EQ. 1) THEN C Sequential analysis IF ( id%MYID .eq. MASTER ) THEN C BEGINNING OF ANALYSIS ON THE MASTER C ------------------------------------------------------ C For element entry (KEEP(55).ne.0), we do not know NZ, C and so the whole allocation of IW cannot be done at this C point and more workspace is declared/allocated/used C inside ZMUMPS_ANA_F_ELT. C ------------------------------------------------------ C IF (KEEP(55) .EQ. 0) THEN C ---------------- C Assembled format C ---------------- NZ8=id%KEEP8(28) C Compute LIW8: C For local orderings a contiguous space IW C of size LIW8 must be provided. C IW must hold the graph (with double adjacency C list) and and extra space of size the number of C nodes in the graph: C ==> LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8 C In case of analysis by block and C However, when GCOMP is provided directly then C IW is not allocated C ==> LIW8 = 0 C In this case C size(LCOMP%ADJ)>= 2_8*NZ8+int(NBLK,8)+1_8 C should hold IF (KEEP(13).NE.0) THEN C Compact graph is provided on entry to ZMUMPS_ANA_F NZ8=0_8 ! GCOMP is provided on entry ENDIF IF (NZ8.EQ.0_8) THEN LIW8 = 0_8 ELSE LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8 ENDIF C ELSE C ---------------- C Elemental format C ---------------- C Only available for AMD, METIS, and given ordering #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) COND = (KEEP(60) .NE. 0) .OR. (KEEP(256) .EQ. 5) #else COND = (KEEP(60) .NE. 0) #endif IF( COND ) THEN C C C we suppress supervariable detection when Schur C is active or when METIS is applied C Workspaces for FLAG(N), and either LEN(N) or some pointers(N+1) LIW8_ELT = int(id%N,8) + int(id%N,8) + 1_8 ELSE C Spaces FLAG(N), LEN(N), N+3, SVAR(0:N), LIW8_ELT = int(id%N,8) + int(id%N,8) + & int(id%N,8)+3_8 + int(id%N,8)+1_8 ENDIF C ENDIF C We must ensure that an array of order C 3*N is available for ZMUMPS_ANA_LNEW IF (KEEP(55) .EQ. 0) THEN IF (LIW8.LT.3_8*int(NBLK,8)) LIW8=3_8*int(NBLK,8) ELSE IF (LIW8_ELT.LT.3_8*int(id%N,8)) LIW8_ELT=3_8*int(id%N,8) ENDIF C IF ( KEEP(256) .EQ. 1 ) THEN C It has been checked that id%PERM_IN is associated but C values of pivot order will be checked later and C should be checked here too C PERM_IN( I ) = position of I in the pivot order IKEEP2 => IKEEPALLOC(int(NBLK+1,8):int(NBLK,8)+int(id%N,8)) C Build inverse permutation and check PERM_IN DO I = 1, id%N IKEEP2(I) = 0 ENDDO DO I = 1, id%N IF ( id%PERM_IN(I) .LT.1 .OR. & id%PERM_IN(I) .GT. id%N ) THEN C PERM_IN entry is out-of-range INFO(1) = -4 INFO(2) = I GOTO 10 ELSE IF ( IKEEP2(id%PERM_IN(I)) .NE. 0 ) THEN C Duplicate entry in PERM_IN was found INFO(1) = -4 INFO(2) = I GOTO 10 ELSE C Store entry in inverse permutation IKEEP2(id%PERM_IN( I )) = I ENDIF ENDDO IF ((KEEP(55) .EQ. 0).AND.(KEEP(13).NE.0) & .AND.(KEEP(13).NE.-1) & ) THEN C Build blocked permutation: C IKEEPALLOC(IB)= IBPos where IB, IBPos \in [1:NBLK] C IKEEP2 holds inverse permutation IPOSB = 0 IPOS = 1 DO WHILE (IPOS.LE.id%N) IPOSB = IPOSB+1 I = IKEEP2(IPOS) IBcurrent = DOF2BLOCK(I) BLKSIZE = SIZEOFBLOCKS(IBcurrent) IKEEPALLOC(IBcurrent) = IPOSB IF (BLKSIZE.GT.1) THEN DO II = 1, BLKSIZE-1 IPOS = IPOS+1 I = IKEEP2(IPOS) IB = DOF2BLOCK(I) IF (IB.NE.IBcurrent) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & " ERROR: given permutation (ICNTL(7)=1)", & " incompatible with block format" ENDIF INFO(1)= -4 INFO(2)= I GOTO 10 ENDIF ENDDO ENDIF IPOS = IPOS+1 ENDDO C IF PERM_IN is correct then C on exit last position should be NBLK IF (IPOSB.NE.NBLK) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & " ERROR: given permutation (ICNTL(7)=1)", & " incompatible with block format" ENDIF INFO(1)= -4 C N+1 to indicate "global" error INFO(2)= id%N+1 GOTO 10 ENDIF ELSE DO I = 1, id%N IKEEPALLOC( I ) = id%PERM_IN( I ) END DO ENDIF IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) END IF INFOG(1) = 0 INFOG(2) = 0 C Initialize structural symmetry value to not yet computed. INFOG(8) = -1 IF (KEEP(55) .EQ. 0) THEN IKEEP1 => IKEEPALLOC(1:NBLK) IKEEP2 => IKEEPALLOC(int(NBLK+1,8): & int(NBLK,8)+int(id%N,8)) IKEEP3 => IKEEPALLOC(int(NBLK,8)+int(id%N+1,8): & int(NBLK,8)+2_8*int(id%N,8)) C id%UNS_PERM corresponds to argument PIV C in ZMUMPS_ANA_F, it should be an assumed-shape C array rather than a possibly null pointer: IF (associated(id%UNS_PERM)) THEN UNS_PERM_PTR => id%UNS_PERM ELSE UNS_PERM_PTR => IDUMMY_ARRAY ENDIF IF (KEEP(13).EQ.0) THEN CALL ZMUMPS_ANA_F(id%N, NZ8, & id%IRN, id%JCN, & LIW8, IKEEP1, IKEEP2, IKEEP3, & KEEP(256), NFSIZPTR, & FILS_TMP, & FREREPTR, & id%LISTVAR_SCHUR, SIZE_SCHUR_PASSED, & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, & UNS_PERM_PTR, & id%CNTL(4), id%COLSCA, id%ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & ) ELSE IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY CALL ZMUMPS_ANA_F(NBLK, NZ8, & IRN_loc_PTR, JCN_loc_PTR, & LIW8, IKEEP1, IKEEP2, IKEEP3, & KEEP(256), NFSIZPTR, & FILS_TMP, FREREPTR, & id%LISTVAR_SCHUR, SIZE_SCHUR_PASSED, & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, & UNS_PERM_PTR, & id%CNTL(4), id%COLSCA, id%ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & , id%N, SIZEOFBLOCKS, GCOMP_PROVIDED, GCOMP & ) IF (GCOMP_PROVIDED) & CALL MUMPS_AB_FREE_GCOMP(GCOMP, MEMCNT) C ENDIF INFOG(7) = KEEP(256) C UNS_PERM_PTR was only used locally C for the call to ZMUMPS_ANA_F NULLIFY(UNS_PERM_PTR) ELSE allocate( XNODEL ( id%N+1 ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = id%N + 1 IF ( LPOK ) THEN WRITE(LP, 150) 'XNODEL' END IF GOTO 10 ENDIF IF (LELTVAR.ne.id%ELTPTR(NELT+1)-1) THEN C -- internal error INFO(1) = -2002 INFO(2) = id%ELTPTR(NELT+1)-1 GOTO 10 ENDIF allocate( NODEL ( LELTVAR ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LELTVAR IF ( LPOK ) THEN WRITE(LP, 150) 'NODEL' END IF GOTO 10 ENDIF CALL ZMUMPS_ANA_F_ELT(id%N, NELT, & id%ELTPTR(1), id%ELTVAR(1), LIW8_ELT, & IKEEPALLOC(1), & KEEP(256), NFSIZPTR(1), FILS_TMP(1), & FREREPTR(1), id%LISTVAR_SCHUR(1), & SIZE_SCHUR_PASSED, & ICNTL(1), INFOG(1), KEEP(1),KEEP8(1), & id%NSLAVES, & XNODEL(1), NODEL(1) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & ) INFOG(7)=KEEP(256) C C XNODEL and NODEL as output to ZMUMPS_ANA_F_ELT C be used in ZMUMPS_FRTELT and thus C cannot be deallocated at this point C ENDIF IF ( LISTVAR_SCHUR_2BE_FREED ) THEN C We do not want to have LISTVAR_SCHUR C allocated of size 1 if Schur is off. DEALLOCATE( id%LISTVAR_SCHUR ) NULLIFY ( id%LISTVAR_SCHUR ) LISTVAR_SCHUR_2BE_FREED = .TRUE. ENDIF C ------------------------------ C Significant error codes should C always be in INFO(1/2) C ------------------------------ INFO(1)=INFOG(1) INFO(2)=INFOG(2) C save statistics in KEEP array. KEEP(28) = INFOG(6) IKEEP = 1_8 NA = IKEEP + int(id%N,8) NE = IKEEP + 2_8 * int(id%N,8) C -- if (id%myid.eq.master) ENDIF C -- if sequential analysis ENDIF C 10 CONTINUE IF (KEEP(244).EQ.1) THEN CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF IF ((KEEP(244).EQ.1).AND.(KEEP(55).EQ.0)) THEN C Sequential analysis on assembled matrix C check if max transversal should be called CALL MPI_BCAST(KEEP(23),1,MPI_INTEGER,MASTER,id%COMM,IERR) IF ( (KEEP(23).LE.-1).AND.(KEEP(23).GE.-6) ) THEN C -- Perform max transversal KEEP(23) = -KEEP(23) IF (id%MYID.EQ.MASTER) THEN IF (.NOT. associated(id%A)) KEEP(23) = 1 IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (allocated(FILS_TMP) ) THEN DEALLOCATE(FILS_TMP) ENDIF IF (associated(FREREPTR) ) THEN DEALLOCATE(FREREPTR) NULLIFY(FREREPTR) ENDIF IF (associated(NFSIZPTR) ) THEN DEALLOCATE(NFSIZPTR) NULLIFY(NFSIZPTR) ENDIF ENDIF GOTO 1234 ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(244).EQ.1).AND. (KEEP(55).EQ.0)) THEN C Sequential ordering on assembled matrix IF ((KEEP(54).EQ.3).AND.KEEP(494).EQ.0) THEN IF (GATHER_MATRIX_ALLOCATED) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF GATHER_MATRIX_ALLOCATED= .FALSE. ENDIF ENDIF ENDIF ENDIF IF (KEEP(244).NE.1) THEN C{ Parallel analysis IF (id%MYID .EQ. MASTER) THEN C KEEPALLOC reuse later C FIXME allocate of size 2*NBLK and C allocate of size 3*id%N after call ana_aux_par SIZEIKEEPALLOC = 3_8*int(id%N,8) SIZEWORK2ALLOC = max(4_8*int(NBLK,8), int(id%NPROCS+1,8)) ALLOCATE( IKEEPALLOC(SIZEIKEEPALLOC), & WORK2ALLOC(SIZEWORK2ALLOC), & FILS_TMP(NBLK), FREREPTR(NBLK), NFSIZPTR(NBLK), & stat=IERR) ELSE IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN C Allocate only on procs concerned by parallel analysis SIZEIKEEPALLOC = 3_8*int(NBLK,8) SIZEWORK2ALLOC = 4_8*int(NBLK,8) ALLOCATE(IKEEPALLOC(SIZEIKEEPALLOC), & WORK2ALLOC(SIZEWORK2ALLOC), stat=IERR ) ELSE C Not concerned by ZMUMPS_ANA_F_PAR IERR = 0 SIZEIKEEPALLOC = 0_8 SIZEWORK2ALLOC = 0_8 ENDIF IF (IERR.GT.0) THEN INFO(1) = -7 IF (id%MYID .EQ. MASTER) THEN CALL MUMPS_SET_IERROR( & SIZEIKEEPALLOC+SIZEWORK2ALLOC+3_8*int(NBLK,8), & INFO(2) ) ELSE CALL MUMPS_SET_IERROR( & SIZEIKEEPALLOC+SIZEWORK2ALLOC, & INFO(2) ) ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C save value provided by user idNBLKSAVE= id%NBLK C #if defined(MUMPS_NOF2003) C Allocatable not allowed in ZMUMPS_ANA_F_PAR, C use a pointer instead. FILS_TMP is typically C allocated only on MPI rank 0. IF (allocated(FILS_TMP)) THEN FILS_TMPPTR => FILS_TMP ELSE FILS_TMPPTR => IDUMMY_ARRAY ENDIF #endif IF (LUMAT_AVAIL) THEN C{ C id%NBLK = NBLK IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN IF (RKinidCOMM_PROC0SYMB.NE.MASTER) CALL MUMPS_ABORT() CALL ZMUMPS_ANA_F_PAR(id, & IKEEPALLOC, & WORK2ALLOC, & SIZEIKEEPALLOC, & SIZEWORK2ALLOC, & NFSIZPTR, #if defined(MUMPS_NOF2003) & FILS_TMPPTR, #else & FILS_TMP, #endif & FREREPTR, & COMM_PARASYMB ! optional: & , LUMAT, SIZEOFBLOCKS & , COMM_PARAORD, NPROCS_PARAORD & , RKinSYMB_PROC0ORD & ) ENDIF IF (KEEP(494).EQ.0.OR.KEEP(487).NE.1) THEN CALL MUMPS_AB_FREE_LMAT(LUMAT,KEEP(147)) LUMAT_AVAIL = .FALSE. ELSE LUMAT_AVAIL = .TRUE. ENDIF C C} ELSE C{ LUMAT not available and COMM_PARASYMB=id%COMM id%NBLK = id%N CALL ZMUMPS_ANA_F_PAR(id, & IKEEPALLOC, & WORK2ALLOC, & SIZEIKEEPALLOC, & SIZEWORK2ALLOC, & NFSIZPTR, #if defined(MUMPS_NOF2003) & FILS_TMPPTR, #else & FILS_TMP, #endif & FREREPTR, & id%COMM & ) C} ENDIF id%NBLK = idNBLKSAVE IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN DEALLOCATE(WORK2ALLOC) IF(id%MYID .NE. MASTER) THEN DEALLOCATE(IKEEPALLOC) ENDIF ENDIF KEEP(28) = INFOG(6) IF (COMM_PARAORD_ALLOCATED) THEN IF (COMM_PARAORD.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_FREE( COMM_PARAORD, IERR ) COMM_PARAORD_ALLOCATED = .FALSE. ENDIF ENDIF IF (COMM_PARASYMB_ALLOCATED) THEN IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_FREE( COMM_PARASYMB, IERR ) COMM_PARASYMB_ALLOCATED = .FALSE. ENDIF ENDIF C Check error after freeing communicators CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C IF (id%MYID.EQ.MASTER) THEN IKEEP = 1_8 NA = IKEEP + int(id%N,8) NE = IKEEP + 2_8 * int(id%N,8) ENDIF C --------------------------------------------------------- C Check whether FILS_TMP, FREREPTR, NFSIZPTR C computed on master of COMM_PARSYMB (RKinidCOMM_PROC0SYMB) C should be send on MASTER C --------------------------------------------------------- IF (RKinidCOMM_PROC0SYMB.NE.MASTER) THEN C allocate data on MASTER of id%COMM IF (id%MYID.EQ.MASTER) THEN C FILS_TMP allocate to size NBLK since it will be C allways copied back in structure ALLOCATE( FILS_TMP(NBLK), FREREPTR(id%N), NFSIZPTR(id%N), & stat=IERR) ENDIF ENDIF IF (IERR.GT.0) THEN INFO(1) = -7 IF (id%MYID .EQ. MASTER) THEN CALL MUMPS_SET_IERROR(3_8*int(id%N,8), INFO(2)) ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF (RKinidCOMM_PROC0SYMB.NE.MASTER) THEN C data computed on master of COMM_PARASYMB to be C sent on MASTER of id%COMM C FIXME to be authorized INFOG data should also C be sent to MASTER of id%COMM CALL MUMPS_ABORT() IF (id%MYID.EQ.RKinidCOMM_PROC0SYMB) THEN CALL MPI_SEND (FILS_TMP(1), NBLK, MPI_INTEGER, & MASTER, CENT_AFTER_PARAORD, id%COMM, IERR) CALL MPI_SEND (FREREPTR(1), NBLK, MPI_INTEGER, & MASTER, CENT_AFTER_PARAORD, id%COMM, IERR) CALL MPI_SEND (NFSIZPTR(1), NBLK, MPI_INTEGER, & MASTER, CENT_AFTER_PARAORD, id%COMM, IERR) C C deallocate data sent to MASTER DEALLOCATE(FILS_TMP, FREREPTR, NFSIZPTR) C FILS_TMP is an allocatable array nullify(FREREPTR, NFSIZPTR) C ENDIF IF (id%MYID.EQ.MASTER) THEN CALL MPI_RECV (FILS_TMP(1), NBLK, MPI_INTEGER, & RKinidCOMM_PROC0SYMB, CENT_AFTER_PARAORD, & id%COMM, STATUS, IERR) CALL MPI_RECV (FREREPTR(1), NBLK, MPI_INTEGER, & RKinidCOMM_PROC0SYMB, CENT_AFTER_PARAORD, & id%COMM, STATUS, IERR) CALL MPI_RECV (NFSIZPTR(1), NBLK, MPI_INTEGER, & RKinidCOMM_PROC0SYMB, CENT_AFTER_PARAORD, & id%COMM, STATUS, IERR) ENDIF C ENDIF C} END IF C Allocated PROCNODE on MASTER IF (id%MYID.EQ.MASTER) THEN allocok = 0 allocate(PROCNODE(NBLK), STAT=allocok) IF (allocok .ne. 0) THEN INFO(1) = -7 INFO(2) = NBLK ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF ( I_AM_SLAVE) THEN KEEP(144)=1 ! MPI process is working ELSE KEEP(144)=0 ENDIF IF(id%MYID .EQ. MASTER) THEN C Save ICNTL(14) value into KEEP(12) CALL MUMPS_GET_PERLU(KEEP(12),ICNTL(14), & KEEP(50),KEEP(54),ICNTL(6),KEEP(52)) CALL ZMUMPS_ANA_R(NBLK, FILS_TMP(1), FREREPTR(1), & IKEEPALLOC(NE), IKEEPALLOC(NA)) C ********************************************************** C Continue with CALL to MAPPING routine C ********************* C BEGIN SEQUENTIAL CODE C No mapping computed C ********************* C C In sequential, if no special root C reset KEEP(20) and KEEP(38) to 0 C IF (id%NSLAVES .EQ. 1 & ) THEN id%NBSA = 0 IF ( (id%KEEP(60).EQ.0). & AND.(id%KEEP(53).EQ.0)) THEN C If Schur is on (keep(60).ne.0) C or if RR is on (keep (53) > 0 C then we keep root numbers C root node number in seq id%KEEP(20)=0 C root node number in paral id%KEEP(38)=0 ENDIF C No type 2 nodes: id%KEEP(56)=0 C All mapped on MPI process 0, and of type TPN=0 C (treated as if they were all root of subtree) PROCNODE_VALUE = MUMPS_ENCODE_TPN_IPROC(0, 0, KEEP(199)) DO I = 1, NBLK PROCNODE(I) = PROCNODE_VALUE END DO C It may also happen that KEEP(38) has already been set, C in the case of a distributed Schur complement (KEEP(60)=2 or 3). C In that case, PROCNODE should be set accordingly and KEEP(38) is C not modified. IF (id%KEEP(60) .EQ. 2 .OR. id%KEEP(60).EQ.3) THEN PROCNODE_VALUE = MUMPS_ENCODE_TPN_IPROC(3, 0, KEEP(199)) CALL ZMUMPS_SET_PROCNODE(id%KEEP(38), PROCNODE(1), & PROCNODE_VALUE, FILS_TMP(1), NBLK) ENDIF C ******************* C END SEQUENTIAL CODE C ******************* ELSE C ***************************** C BEGIN MAPPING WITH CANDIDATES C (NSLAVES > 1) C ***************************** C C C peak is set by default to 1 largest front + One largest CB PEAK = dble(id%INFOG(5))*dble(id%INFOG(5)) + ! front matrix & dble(id%KEEP(2))*dble(id%KEEP(2)) ! cb bloc C IKEEP(1:N,1) can be used as a work space since it is set C to its final state by the SORT_PERM subroutine below. SSARBR => IKEEPALLOC(IKEEP:IKEEP+int(NBLK-1,8)) C ====================================================== C Map nodes and assign candidates for dynamic scheduling C ====================================================== IF ((KEEP(13).NE.0).AND.(NBLK.NE.id%N)) THEN SIZEOFBLOCKS_PTR => SIZEOFBLOCKS(1:NBLK) LSIZEOFBLOCKS_PTR = NBLK ELSE SIZEOFBLOCKS_PTR => IDUMMY_ARRAY LSIZEOFBLOCKS_PTR = 1 IDUMMY_ARRAY(1) = -1 ENDIF CALL ZMUMPS_DIST_AVOID_COPIES( & NBLK,id%NSLAVES,ICNTL(1), & INFOG(1), & IKEEPALLOC(NE), & NFSIZPTR(1), & FREREPTR(1), & FILS_TMP(1), & KEEP(1),KEEP8(1),PROCNODE(1), & SSARBR(1),id%NBSA,PEAK,IERR & , SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR & ) NULLIFY(SSARBR) if(IERR.eq.-999) then write(6,*) ' Internal error during static mapping ' INFO(1) = IERR GOTO 11 ENDIF IF(IERR.NE.0) THEN INFO(1) = -135 INFO(2) = IERR GOTO 11 ENDIF CALL ZMUMPS_ANA_R(NBLK, FILS_TMP(1), & FREREPTR(1), IKEEPALLOC(NE), & IKEEPALLOC(NA)) ENDIF 11 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C The following part is done in parallel CALL MPI_BCAST( id%NELT, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KEEP(55) .EQ. 0) THEN C Assembled matrix format. Fill up the id%PTRAR array C Broadcast id%SYM_PERM needed to fill up id%PTRAR C postpone to after computation of id%SYM_PERM C computed after id%DAD_STEPS if (associated(id%FRTPTR)) DEALLOCATE(id%FRTPTR) if (associated(id%FRTELT)) DEALLOCATE(id%FRTELT) allocate( id%FRTPTR(1), id%FRTELT(1) ,STAT=allocok) IF (allocok .GT. 0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'FRTPTR,FRTELT' END IF INFO(1)= -7 INFO(2)= 2 END IF ELSE C Element Entry: C ------------------------------- C COMPUTE THE LIST OF ELEMENTS THAT WILL BE ASSEMBLED C AT EACH NODE OF THE ELIMINATION TREE. ALSO COMPUTE C FOR EACH ELEMENT THE TREE NODE TO WHICH IT IS ASSIGNED. C C FRTPTR is an INTEGER array of length N+1 which need not be set by C the user. On output, FRTPTR(I) points in FRTELT to first element C in the list of elements assigned to node I in the elimination tree. C C FRTELT is an INTEGER array of length NELT which need not be set by C the user. On output, positions FRTELT(FRTPTR(I)) to C FRTELT(FRTPTR(I+1)-1) contain the list of elements assigned to C node I in the elimination tree. C LPTRAR = id%NELT+id%NELT+2 CALL MUMPS_I8REALLOC(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%FRTPTR, id%N+1, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTPTR (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%ELTPROC, id%NELT, id%INFO, LP, & FORCE=.TRUE., STRING='id%ELTPROC (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%FRTELT, id%NELT, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTELT (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF(id%MYID .EQ. MASTER) THEN C In the elemental format case, PTRAR&friends are still C computed sequentially and then broadcasted CALL ZMUMPS_FRTELT( & id%N, NELT, id%ELTPTR(NELT+1)-1, FREREPTR(1), & FILS_TMP(1), & IKEEPALLOC(NA), IKEEPALLOC(NE), XNODEL, & NODEL, id%FRTPTR(1), id%FRTELT(1), id%ELTPROC(1)) DO I=1, id%NELT+1 C PTRAR declared 64-bit id%PTRAR(id%NELT+I+1)=int(id%ELTPTR(I),8) ENDDO DEALLOCATE(XNODEL) DEALLOCATE(NODEL) END IF CALL MPI_BCAST( id%PTRAR(id%NELT+2), id%NELT+1, MPI_INTEGER8, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRTPTR(1), id%N+1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRTELT(1), id%NELT, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C We switch again to sequential computations on the master node IF(id%MYID .EQ. MASTER) THEN IF ( INFO( 1 ) .LT. 0 ) GOTO 12 IF ( KEEP(55) .ne. 0 ) THEN C --------------------------------------- C Build ELTPROC: correspondance between elements and slave ranks C in COMM_NODES with special values -1 (all procs) and -2 and -3 C (no procs). This is used later to distribute the elements on C the processes at the beginning of the factorisation phase C --------------------------------------- CALL ZMUMPS_ELTPROC(NBLK, NELT, id%ELTPROC(1),id%NSLAVES, & PROCNODE(1), id%KEEP(1)) END IF NB_NIV2 = KEEP(56) IF ( NB_NIV2.GT.0 ) THEN C allocate(PAR2_NODES(NB_NIV2), & STAT=allocok) IF (allocok .GT.0) then INFO(1)= -7 INFO(2)= NB_NIV2 IF ( LPOK ) THEN WRITE(LP, 150) 'PAR2_NODES' END IF GOTO 12 END IF ENDIF IF ((NB_NIV2.GT.0) .AND. (KEEP(24).EQ.0)) THEN INIV2 = 0 DO 777 INODE = 1, NBLK IF ( ( FREREPTR(INODE) .NE. NBLK ) .AND. & ( MUMPS_TYPENODE(PROCNODE(INODE),id%KEEP(199)) & .eq. 2) ) THEN INIV2 = INIV2 + 1 PAR2_NODES(INIV2) = INODE END IF 777 CONTINUE IF ( INIV2 .NE. NB_NIV2 ) THEN WRITE(*,*) "Internal Error 2 in ZMUMPS_ANA_DRIVER", & INIV2, NB_NIV2 CALL MUMPS_ABORT() ENDIF ENDIF IF ( (KEEP(24) .NE. 0) .AND. (NB_NIV2.GT.0) ) THEN C allocate array to store cadidates stategy C for each level two nodes IF ( associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES) allocate( id%CANDIDATES(id%NSLAVES+1,NB_NIV2), & stat=allocok) if (allocok .gt.0) then INFO(1)= -7 INFO(2)= NB_NIV2*(id%NSLAVES+1) IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 END IF CALL MUMPS_RETURN_CANDIDATES & (PAR2_NODES,id%CANDIDATES, & IERR) IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF C deallocation of variables of module mumps_static_mapping CALL MUMPS_END_ARCH_CV() IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF ELSE IF (associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES) allocate(id%CANDIDATES(1,1), stat=allocok) IF (allocok .NE. 0) THEN INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 ENDIF ENDIF C******************************************************************* C --------------- 12 CONTINUE C --------------- * * =============================== * End of analysis phase on master * =============================== * END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C C We now allocate and compute arrays in NSTEPS C on the master, as this makes more sense. C C Broadcast KEEP8(101) to be used in MUMPS_ANA_L0_OMP CALL MPI_BCAST( id%KEEP8(101), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) C C ============================== C PREPARE DATA FOR FACTORIZATION C ============================== C ------------------ CALL MPI_BCAST( id%KEEP(1), 110, MPI_INTEGER, MASTER, & id%COMM, IERR ) C We also need to broadcast KEEP8(21) CALL MPI_BCAST( id%KEEP8(21), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) C -------------------------------------------------- C Broadcast KEEP(205) which is outside the first 110 C KEEP entries but is needed for factorization. C -------------------------------------------------- CALL MPI_BCAST( id%KEEP(205), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C -------------- C Broadcast NBSA CALL MPI_BCAST( id%NBSA, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- C Global MAXFRT (computed in ZMUMPS_ANA_M) C is needed on all the procs during ZMUMPS_ANA_DISTM C to evaluate workspace for solve. C We could also recompute it in ZMUMPS_ANA_DISTM IF (id%MYID==MASTER) KEEP(127)=INFOG(5) CALL MPI_BCAST( id%KEEP(127), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- C Global max panel size KEEP(226) CALL MPI_BCAST( id%KEEP(226), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- CALL MPI_BCAST( id%KEEP(464), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(471), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(475), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(482), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(487), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) C Number of leaves not belonging to L0 KEEP(262) C and KEEP(263) : inner or outer sends for blocked facto CALL MPI_BCAST( id%KEEP(262), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ---------------------------------------- C Allocate new workspace on all processors C ---------------------------------------- C STEP_TMP is of size NBLK because it C is computed on compressed graph and C broadcasted when needed. C It is then extended in id%STEP on master C and broadcasted on all procs ALLOCATE(STEP_TMP(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NBLK ENDIF IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%PROCNODE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%PROCNODE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%NE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%NE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%ND_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%ND_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%FRERE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%FRERE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%DAD_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%DAD_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 IF (KEEP(55) .EQ. 0) THEN LPTRAR = 2 CALL MUMPS_I8REALLOC(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 ENDIF IF (id%KEEP(494).NE.0) THEN C of size NBLK that will be extended and copies later C on master SIZELRGROUPS_TMP = NBLK ELSE C needed as argument for ZMUMPS_EXPAND_TREE_STEPS SIZELRGROUPS_TMP = 1 ENDIF ALLOCATE(LRGROUPS_TMP(SIZELRGROUPS_TMP), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NBLK ENDIF C IF(INFO(1).LT.0) GOTO 94 C Copy data for factorization and/or solve. C ================================ C COMPUTE ON THE MASTER, BROADCAST C TO OTHER PROCESSES C ================================ IF ( id%MYID .NE. MASTER .OR. id%KEEP(23) .EQ. 0 ) THEN IF ( associated( id%UNS_PERM ) ) THEN DEALLOCATE(id%UNS_PERM) ENDIF ENDIF 94 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( id%MYID .EQ. MASTER ) THEN C NA -> compressed NA containing only list C of leaves of the elimination tree and list of roots C (the two useful informations for factorization/solve). IF (NBLK.eq.1) THEN NBROOT = 1 NBLEAF = 1 ELSE IF (IKEEPALLOC(NA+int(NBLK-1,8)) .LT.0) THEN NBLEAF= NBLK NBROOT= NBLK ELSE IF (IKEEPALLOC(NA+int(NBLK-2,8)) .LT.0) THEN NBLEAF = NBLK-1 NBROOT = IKEEPALLOC(NA+int(NBLK-1,8)) ELSE NBLEAF = IKEEPALLOC(NA+int(NBLK-2,8)) NBROOT = IKEEPALLOC(NA+int(NBLK-1,8)) ENDIF id%LNA = 2+NBLEAF+NBROOT ENDIF CALL MPI_BCAST( id%LNA, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MUMPS_REALLOC(id%NA, id%LNA, id%INFO, LP, FORCE=.TRUE., & STRING='id%NA (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF (id%MYID .EQ.MASTER ) THEN C{ The structure of NA is the following: C NA(1) is the number of leaves. C NA(2) is the number of roots. C NA(3:2+NA(1)) are the leaves. C NA(3+NA(1):2+NA(1)+NA(2)) are the roots. id%NA(1) = NBLEAF id%NA(2) = NBROOT C C Initialize NA with the leaves and roots LEAF = 3 IF ( NBLK == 1 ) THEN id%NA(LEAF) = 1 LEAF = LEAF + 1 ELSE IF (IKEEPALLOC(NA+int(NBLK-1,8)) < 0) THEN id%NA(LEAF) = - IKEEPALLOC(NA+int(NBLK-1,8))-1 LEAF = LEAF + 1 DO I = 1, NBLEAF - 1 id%NA(LEAF) = IKEEPALLOC(NA+int(I-1,8)) LEAF = LEAF + 1 ENDDO ELSE IF (IKEEPALLOC(NA+int(NBLK-2,8)) < 0 ) THEN INODE = - IKEEPALLOC(NA+int(NBLK-2,8)) - 1 id%NA(LEAF) = INODE LEAF =LEAF + 1 IF ( NBLEAF > 1 ) THEN DO I = 1, NBLEAF - 1 id%NA(LEAF) = IKEEPALLOC(NA+int(I-1,8)) LEAF = LEAF + 1 ENDDO ENDIF ELSE DO I = 1, NBLEAF id%NA(LEAF) = IKEEPALLOC(NA+int(I-1,8)) LEAF = LEAF + 1 ENDDO END IF C C Build array STEP_TMP(1:NBLK) to hold step numbers in C range 1..id%KEEP(28), allowing compression of C other arrays from id%N to id%KEEP(28) C (the number of nodes/steps in the assembly tree) ISTEP = 0 DO I = 1, NBLK IF ( FREREPTR(I) .ne. NBLK + 1 ) THEN C New node in the tree. c (Set step( inode_n ) = inode_nsteps for principal C variables and -inode_nsteps for internal variables C of the node) ISTEP = ISTEP + 1 STEP_TMP(I)=ISTEP INN = FILS_TMP(I) DO WHILE ( INN .GT. 0 ) STEP_TMP(INN) = - ISTEP INN = FILS_TMP(INN) END DO IF (FREREPTR(I) .eq. 0) THEN C Keep root nodes list in NA id%NA(LEAF) = I LEAF = LEAF + 1 ENDIF ENDIF END DO IF ( LEAF - 1 .NE. 2+NBROOT + NBLEAF ) THEN WRITE(*,*) 'Internal error 2 in ZMUMPS_ANA_DRIVER' CALL MUMPS_ABORT() ENDIF IF ( ISTEP .NE. id%KEEP(28) ) THEN write(*,*) 'Internal error 3 in ZMUMPS_ANA_DRIVER', & ISTEP, id%KEEP(28) CALL MUMPS_ABORT() ENDIF C ============ C SET PROCNODE, FRERE, NE C ============ C copies to NSTEP array should be ok DO I = 1, NBLK IF (FREREPTR(I) .NE. NBLK+1) THEN id%PROCNODE_STEPS(STEP_TMP(I)) = PROCNODE( I ) id%FRERE_STEPS(STEP_TMP(I)) = FREREPTR(I) id%NE_STEPS(STEP_TMP(I)) = IKEEPALLOC(NE+int(I-1,8)) id%ND_STEPS(STEP_TMP(I)) = NFSIZPTR(I) ENDIF ENDDO C =============================== C Algorithm to compute array DAD_STEPS: C ---- C For each node set dad for all of its sons C plus, for root nodes set dad to zero. C C =============================== DO I = 1, NBLK C -- skip non principal nodes IF ( STEP_TMP(I) .LE. 0) CYCLE C -- (I) is a principal node IF (FREREPTR(I) .eq. 0) THEN C -- I is a root node and has no father id%DAD_STEPS(STEP_TMP(I)) = 0 ENDIF C -- Find first son node (IFS) IFS = FILS_TMP(I) DO WHILE ( IFS .GT. 0 ) IFS= FILS_TMP(IFS) END DO C -- IFS > 0 if I is not a leave node C -- Go through list of brothers of IFS if any IFS = -IFS DO WHILE (IFS.GT.0) C -- I is not a leave node and has a son node IFS id%DAD_STEPS(STEP_TMP(IFS)) = I IFS = FREREPTR(IFS) ENDDO END DO C C C Following arrays (PROCNODE and IKEEPALLOC) not used anymore C during analysis IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (associated(FREREPTR)) DEALLOCATE(FREREPTR) NULLIFY(FREREPTR) IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR) NULLIFY(NFSIZPTR) ENDIF IF (KEEP(494).NE.0) THEN C{ IF (id%MYID.EQ.MASTER) THEN IF (PROKG) THEN CALL MUMPS_SECDEB(TIMEG) END IF ENDIF C ======================================================= C Compute a grouping of variables for LR approximations. C Grouping may be performed on a distributed matrix C ======================================================= C C ======================================= C I/ Prepare data before call to grouping C ======================================= LUMAT_REMAP_DIST_AVAIL = .FALSE. LUMAT_REMAP_CENT_AVAIL = .FALSE. C IF (LUMAT_AVAIL) THEN C Use clean symmetrized LUMAT matrix available ALLOCATE(MAPCOL(id%KEEP(28)), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C CALL MUMPS_INIALIZE_REDIST_LUMAT ( & id%INFO, id%ICNTL, id%KEEP, id%COMM, id%MYID, NBLK, & id%NPROCS, & LUMAT, id%PROCNODE_STEPS(1), id%KEEP(28), MAPCOL, & LUMAT_REMAP, NBRECORDS, STEP_TMP(1)) C INFO(1) has been broadcasted already in routine IF ( id%INFO(1).LT.0 ) GOTO 500 C C -- Redistribute LUMAT into LU_REMAP relying on procnode CALL MUMPS_AB_DIST_LMAT_TO_LUMAT ( & .FALSE., ! do not UNFOLD & .TRUE., ! MAPCOL in NSTEPS=> STEP array needed & id%INFO, id%ICNTL, id%COMM, id%MYID, NBLK, id%NPROCS, & LUMAT, MAPCOL, id%KEEP(28), STEP_TMP(1), NBLK, & LUMAT_REMAP, NBRECORDS, NSEND8, NLOCAL8 & ) LUMAT_REMAP_DIST_AVAIL = .TRUE. CALL MUMPS_AB_FREE_LMAT(LUMAT,KEEP(147)) C Distribute SIZEOFBLOCKS that was defined only on master CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, & id%COMM, IERR ) C} ELSE IF ( LMAT_BLOCK_AVAIL ) THEN C{ Centralized matrix and clean LMAT_BLOCK available C IF (id%MYID.EQ.MASTER) THEN C CALL MUMPS_AB_CLEANLMAT_TO_LUMAT ( & LMAT_BLOCK, LUMAT_REMAP, KEEP(147), & INFO(1), ICNTL(1)) LUMAT_REMAP_CENT_AVAIL=.TRUE. C --- LMAT_BLOCK not needed anymore CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK,KEEP(147)) C ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C} ELSE IF ((KEEP(54).EQ.3).AND.(KEEP(13).EQ.0) & .AND. KEEP(487).EQ.1) THEN C{ C Matrix is distributed on entry and compression not requested C (this will be the case when ICNTL(15).EQ.0 and C // analysis, or Schur, etc...) C note that with distributed matrix and centralized ordering C compression is forced to limit memory peak) C Free centralized matrix before grouping to C limit memory peak IF (GATHER_MATRIX_ALLOCATED) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF GATHER_MATRIX_ALLOCATED= .FALSE. ENDIF IF (.NOT. I_AM_SLAVE .OR. ! non-working master & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc ENDIF ALLOCATE(MAPCOL(id%KEEP(28)), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C C Build MAPCOL and LUMAT_REMAP mapped according C to MAPCOL (outputs available on all MPI procs). CALL MUMPS_AB_DCOORD_TO_DTREE_LUMAT ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & id%PROCNODE_STEPS(1), id%KEEP(28), STEP_TMP(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & MAPCOL, LUMAT_REMAP ) LUMAT_REMAP_DIST_AVAIL = .TRUE. IF (INFO(1).GE.0) THEN C SIZEOFBLOCKS needed on all procs during MPI grouping ALLOCATE(SIZEOFBLOCKS(NBLK), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= NBLK ENDIF DO I=1, NBLK SIZEOFBLOCKS(I) = 1 ENDDO ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C} ELSE IF ((KEEP(54).EQ.3) .AND. (KEEP(487).NE.1) & ) THEN C{ C Grouping preparation on slaves: C If the input matrix is distributed C the graph is centralized to compute the C clustering. C CALL ZMUMPS_GATHER_MATRIX(id) GATHER_MATRIX_ALLOCATED = .TRUE. C} ENDIF C ============ C ============ C II/ GROUPING C ============ IF (LUMAT_REMAP_DIST_AVAIL) THEN C{ Distributed memory based grouping is used IF (id%MYID.NE.MASTER) THEN ALLOCATE(FILS_TMP(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NBLK ENDIF ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL MPI_BCAST( id%ND_STEPS(1), KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL ZMUMPS_AB_LR_MPI_GROUPING(NBLK, & MAPCOL, id%KEEP(28), & id%KEEP(28), LUMAT_REMAP, FILS_TMP(1), & id%FRERE_STEPS, & id%DAD_STEPS, STEP_TMP(1), id%NA, & id%LNA, LRGROUPS_TMP(1), SIZEOFBLOCKS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), id%KEEP(142), & LPOK, LP, id%COMM, id%MYID, id%NPROCS, & id%KEEP(1), id%ND_STEPS) IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) IF (id%MYID.NE.MASTER) DEALLOCATE(FILS_TMP) C} ELSE IF (id%MYID.EQ.MASTER) THEN C{ IF (LUMAT_REMAP_CENT_AVAIL) THEN C{ C IDUMMY_ARRAY(1) = -1 CALL ZMUMPS_AB_LR_MPI_GROUPING(NBLK, & IDUMMY_ARRAY, 1, & id%KEEP(28), LUMAT_REMAP, FILS_TMP, & id%FRERE_STEPS, & id%DAD_STEPS, STEP_TMP, id%NA, & id%LNA, LRGROUPS_TMP, SIZEOFBLOCKS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), id%KEEP(142), & LPOK, LP, id%COMM, id%MYID, id%NPROCS, & id%KEEP(1), id%ND_STEPS) C} ELSE C{ grouping based on centralized matrix IF (KEEP(469).EQ.0) THEN CALL ZMUMPS_LR_GROUPING(id%N, id%KEEP8(28), id%KEEP(28), & id%IRN, & id%JCN, FILS_TMP, id%FRERE_STEPS, & id%DAD_STEPS, id%NE_STEPS, STEP_TMP, id%NA, & id%LNA, LRGROUPS_TMP, & id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(10), & id%KEEP(54), id%KEEP(142), & LPOK, LP, GATHER_MATRIX_ALLOCATED, & id%KEEP(1), id%ND_STEPS) ELSE CALL ZMUMPS_LR_GROUPING_NEW(id%N, id%KEEP8(28), & id%KEEP(28), id%IRN, & id%JCN, FILS_TMP, id%FRERE_STEPS, & id%DAD_STEPS, STEP_TMP, id%NA, & id%LNA, LRGROUPS_TMP, id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), id%KEEP(142), & LPOK, LP, GATHER_MATRIX_ALLOCATED, & id%KEEP(1), id%ND_STEPS) ENDIF C} ENDIF C} ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C update KEEP(142): maximum group size CALL MPI_BCAST( KEEP(142), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ============ C III/ CLEANUP C ============ C Free LUMAT_REMAP if allocated IF (LUMAT_REMAP_DIST_AVAIL.OR.LUMAT_REMAP_CENT_AVAIL) & CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP,KEEP(147)) IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF ( (KEEP(54).EQ.3) .AND. (KEEP(244).EQ.2).AND. & (KEEP(487).NE.1) ) THEN C Cleanup the irn and jcn arrays filled up by the C cmumps_gather_matrix above. It might have been done C during grouping IF (GATHER_MATRIX_ALLOCATED) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF GATHER_MATRIX_ALLOCATED= .FALSE. ENDIF END IF IF (PROKG) THEN CALL MUMPS_SECFIN(TIMEG) WRITE(MPG,145) TIMEG END IF C} Grouping: KEEP(494) .NE. 0 ENDIF C ALLOCATE id%FILS(id%N)on all procs possibly using mpi3 CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 C C ALLOCATE id%STEP(id%N)on all procs possibly using mpi3 CALL MUMPS_REALLOC(id%STEP, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 C C ALLOCATE id%LRGROUPS on all procs possibly using mpi3 C compute size of id%LRGROUPS in KEEP(280) IF (id%KEEP(494).EQ.0) THEN C not used id%KEEP(280) = 1 ELSE id%KEEP(280) = id%N ENDIF CALL MUMPS_REALLOC(id%LRGROUPS, id%KEEP(280), id%INFO, LP, & FORCE=.TRUE., & STRING='id%LRGROUPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 IF (id%MYID.EQ.MASTER) THEN C{ IF (KEEP(13).NE.0) THEN C{ =========== C Expand tree C =========== C Current tree is relative to the analysis by block. C Expand the tree on the master if compression is effective C (in all cases, grouping done or not) IF (NBLK.LT.id%N.OR.(.NOT.BLKVAR_ALLOCATED)) THEN C { C even if NBLK.EQ.N BLKVAR provided by user might hold C a permutation of the variables and this expand_tree_steps C should also be called C Expand FILS_TMP, STEP_TMP into id%FILS, id%STEP C and update arrays of size NSTEPS IF (NB_NIV2.EQ.0) THEN IDUMMY_ARRAY(1) = -9999 PAR2_NODESPTR => IDUMMY_ARRAY(1:1) SIZE_PAR2_NODESPTR=1 ELSE PAR2_NODESPTR => PAR2_NODES(1:NB_NIV2) SIZE_PAR2_NODESPTR=NB_NIV2 ENDIF CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 CALL ZMUMPS_EXPAND_TREE_STEPS (id%ICNTL, & id%N, NBLK, BLKPTR_PTRLOC(1), BLKVAR_PTRLOC(1), & FILS_TMP(1), id%FILS(1), id%KEEP(28), & STEP_TMP(1), id%STEP(1), & PAR2_NODESPTR(1), SIZE_PAR2_NODESPTR, & id%DAD_STEPS(1), id%FRERE_STEPS(1), & id%NA(1), id%LNA, & LRGROUPS_TMP(1), SIZELRGROUPS_TMP, & id%LRGROUPS(1), KEEP(280), & id%KEEP(20), id%KEEP(38), KEEP(494) & ) NULLIFY(PAR2_NODESPTR) C C } ELSE C{ NBLK=N C perform local copies DO I=1, NBLK id%STEP(I) = STEP_TMP(I) id%FILS(I) = FILS_TMP(I) ENDDO IF (id%KEEP(494).NE.0) THEN DO I=1, id%KEEP(280) id%LRGROUPS(I) = LRGROUPS_TMP(I) ENDDO ENDIF C} ENDIF C} ELSE C{ NBLK=N C perform local copies DO I=1, NBLK id%STEP(I) = STEP_TMP(I) id%FILS(I) = FILS_TMP(I) ENDDO IF (id%KEEP(494).NE.0) THEN C we copy only in case of BLR since C LRGROUPS_TMP is otherwise allocated C and not used/initialized DO I=1, id%KEEP(280) id%LRGROUPS(I) = LRGROUPS_TMP(I) ENDDO ENDIF C} ENDIF C C ------------------------------------------- C Adjust LR_GROUPING to bound size of groups C and update KEEP(142): maximum group size C that should then be broadcasted again C ------------------------------------------- IF (id%N.GT.NBLK.AND.KEEP(494).NE.0) THEN CALL MUMPS_ADJUST_SIZE_LRGROUPS ( & id%STEP(1), id%FILS(1), id%N, & id%ND_STEPS(1), id%KEEP(28), id%KEEP(1), & id%LRGROUPS(1), INFO(1), INFO(2)) ENDIF C} ENDIF C update KEEP(142): maximum group size that might have been C updated in MUMPS_ADJUST_SIZE_LRGROUPS CALL MPI_BCAST( KEEP(142), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C 97 CONTINUE C IF (allocated(STEP_TMP)) DEALLOCATE(STEP_TMP) IF (allocated(LRGROUPS_TMP)) DEALLOCATE(LRGROUPS_TMP) IF (allocated(FILS_TMP)) DEALLOCATE(FILS_TMP) C C CALL MUMPS_REALLOC(id%SYM_PERM, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF (id%MYID.EQ.MASTER) THEN C ================================================================= C Reorder the tree using a variant of Liu's algorithm. Note that C REORDER_TREE MUST always be called since it sorts NA (the list of C leaves) in a valid order in the sense of a depth-first traversal. C ================================================================= CALL ZMUMPS_REORDER_TREE(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%KEEP(70), & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(215), & id%KEEP(234), id%KEEP(55), id%KEEP(199), & id%PROCNODE_STEPS(1),id%NSLAVES,PEAK,id%KEEP(90) & ) IF(id%KEEP(261).EQ.1)THEN CALL MUMPS_SORT_STEP(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%INFO(1), & id%ICNTL(1),id%PROCNODE_STEPS(1),id%NSLAVES & ) ENDIF C Compute and export some global information on the tree needed by C dynamic schedulers during the factorization. The type of C information depends on the selected strategy. IF ((id%KEEP(76).GE.4).OR.(id%KEEP(76).GE.6).OR. & (id%KEEP(47).EQ.4).OR.((id%KEEP(81).GT.0) & .AND.(id%KEEP(47).GE.2)))THEN IS_BUILD_LOAD_MEM_CALLED=.TRUE. IF ((id%KEEP(47) .EQ. 4).OR. & (( id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN IF(id%NSLAVES.GT.1) THEN C NBSA is the total number of subtrees and C is an upperbound of the local number of C subtrees SIZE_TEMP_MEM = id%NBSA ELSE C Only one processor, NA(2) is the number of leaves SIZE_TEMP_MEM = id%NA(2) ENDIF ELSE SIZE_TEMP_MEM = 1 ENDIF IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN SIZE_DEPTH_FIRST=id%KEEP(28) ELSE SIZE_DEPTH_FIRST=1 ENDIF allocate(TEMP_MEM(SIZE_TEMP_MEM,id%NSLAVES),STAT=allocok) IF (allocok .NE.0) THEN INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_MEM' END IF GOTO 80 !! FIXME propagate error END IF allocate(TEMP_LEAF(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_LEAF' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 !! FIXME propagate error end if allocate(TEMP_SIZE(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_SIZE' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 end if allocate(TEMP_ROOT(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_ROOT' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 end if allocate(DEPTH_FIRST(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'DEPTH_FIRST' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if ALLOCATE(DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'DEPTH_FIRST_SEQ' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if ALLOCATE(SBTR_ID(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'SBTR_ID' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if IF(id%KEEP(76).EQ.5)THEN C We reuse the same variable as before SIZE_COST_TRAV=id%KEEP(28) ELSE SIZE_COST_TRAV=1 ENDIF allocate(COST_TRAV_TMP(SIZE_COST_TRAV),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'COST_TRAV_TMP' END IF INFO(1)= -7 INFO(2)= SIZE_COST_TRAV GOTO 80 END IF IF(id%KEEP(76).EQ.5)THEN IF(id%KEEP(70).EQ.0)THEN id%KEEP(70)=5 ENDIF IF(id%KEEP(70).EQ.1)THEN id%KEEP(70)=6 ENDIF ENDIF IF(id%KEEP(76).EQ.4)THEN IF(id%KEEP(70).EQ.0)THEN id%KEEP(70)=3 ENDIF IF(id%KEEP(70).EQ.1)THEN id%KEEP(70)=4 ENDIF ENDIF CALL ZMUMPS_BUILD_LOAD_MEM_INFO(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%KEEP(70), & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(47), & id%KEEP(81),id%KEEP(76),id%KEEP(215), & id%KEEP(234), id%KEEP(55), id%KEEP(199), & id%PROCNODE_STEPS(1),TEMP_MEM,id%NSLAVES, & SIZE_TEMP_MEM, PEAK,id%KEEP(90),SIZE_DEPTH_FIRST, & SIZE_COST_TRAV,DEPTH_FIRST(1),DEPTH_FIRST_SEQ(1), & COST_TRAV_TMP(1), & TEMP_LEAF,TEMP_SIZE,TEMP_ROOT,SBTR_ID(1) & ) END IF ENDIF IF (id%MYID.EQ.MASTER) THEN CALL ZMUMPS_SORT_PERM(id%N, id%NA(1), id%LNA, & id%NE_STEPS(1), id%SYM_PERM(1), & id%FILS(1), id%DAD_STEPS(1), & id%STEP(1), id%KEEP(28), & id%KEEP(60), id%KEEP(20), id%KEEP(38), & id%INFO(1) ) ENDIF C Root principal variable C for scalapack (KEEP(38)) or special serial root (KEEP(20)) C might have been updated C since root variables might have been permuted C and/or expanded (MUMPS_EXPAND_TREE) in case of compressed graph C It should thus be redistributed to all procs IF ( KEEP(494).NE.0 .OR. KEEP(13).NE.0 ) THEN C Value of KEEP(20) and KEEP(38) on master is always correct C + non-zero status is identical on all procs since 110 first C KEEP entries have been broadcasted IF (KEEP(38) .NE. 0) THEN CALL MPI_BCAST( id%KEEP(38), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF IF (KEEP(20) .NE. 0) THEN CALL MPI_BCAST( id%KEEP(20), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF ENDIF 80 CONTINUE C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C --------------------------------------------------- C Broadcast information computed on the master to C the slaves. C The matrix itself with numerical values and C integer data for the arrowhead/element description C will be received at the beginning of FACTO. C --------------------------------------------------- CALL MPI_BCAST( id%NA(1), id%LNA, 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%FILS(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%SYM_PERM(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%STEP(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF(KEEP(494).NE.0) THEN CALL MPI_BCAST( id%LRGROUPS(1), id%KEEP(280), MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF C C Store size of the stack memory for each C of the sequential subtree. IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN IF(associated(id%DEPTH_FIRST)) THEN DEALLOCATE(id%DEPTH_FIRST) ENDIF allocate(id%DEPTH_FIRST(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST' END IF GOTO 87 END IF IF(associated(id%DEPTH_FIRST_SEQ)) THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) ENDIF ALLOCATE(id%DEPTH_FIRST_SEQ(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(associated(id%SBTR_ID)) THEN DEALLOCATE(id%SBTR_ID) ENDIF ALLOCATE(id%SBTR_ID(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(id%MYID.EQ.MASTER)THEN id%DEPTH_FIRST(1:id%KEEP(28))=DEPTH_FIRST(1:id%KEEP(28)) id%DEPTH_FIRST_SEQ(1:id%KEEP(28))= & DEPTH_FIRST_SEQ(1:id%KEEP(28)) id%SBTR_ID(1:KEEP(28))=SBTR_ID(1:KEEP(28)) ENDIF CALL MPI_BCAST( id%DEPTH_FIRST(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%DEPTH_FIRST_SEQ(1), id%KEEP(28), & MPI_INTEGER,MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%SBTR_ID(1), id%KEEP(28), & MPI_INTEGER,MASTER, id%COMM, IERR ) ELSE IF(associated(id%DEPTH_FIRST)) THEN DEALLOCATE(id%DEPTH_FIRST) ENDIF allocate(id%DEPTH_FIRST(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST' END IF GOTO 87 END IF IF(associated(id%DEPTH_FIRST_SEQ)) THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) ENDIF ALLOCATE(id%DEPTH_FIRST_SEQ(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(associated(id%SBTR_ID)) THEN DEALLOCATE(id%SBTR_ID) ENDIF ALLOCATE(id%SBTR_ID(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF id%SBTR_ID(1)=0 id%DEPTH_FIRST(1)=0 id%DEPTH_FIRST_SEQ(1)=0 ENDIF IF(id%KEEP(76).EQ.5)THEN IF(associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) ENDIF allocate(id%COST_TRAV(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%COST_TRAV' END IF INFO(1)= -7 INFO(2)= id%KEEP(28) GOTO 87 END IF IF(id%MYID.EQ.MASTER)THEN id%COST_TRAV(1:id%KEEP(28))= & dble(COST_TRAV_TMP(1:id%KEEP(28))) ENDIF CALL MPI_BCAST( id%COST_TRAV(1), id%KEEP(28), & MPI_DOUBLE_PRECISION,MASTER, id%COMM, IERR ) ELSE IF(associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) ENDIF allocate(id%COST_TRAV(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%COST_TRAV(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF id%COST_TRAV(1)=0.0d0 ENDIF IF (id%KEEP(47) .EQ. 4 .OR. & ((id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN IF(id%MYID .EQ. MASTER)THEN DO K=1,id%NSLAVES DO J=1,SIZE_TEMP_MEM IF(TEMP_MEM(J,K) < 0.0D0) GOTO 666 ENDDO 666 CONTINUE J=J-1 IF (id%KEEP(46) == 1) THEN IDEST = K - 1 ELSE IDEST = K ENDIF IF (IDEST .NE. MASTER) THEN CALL MPI_SEND(J,1,MPI_INTEGER,IDEST,0, & id%COMM,IERR) CALL MPI_SEND(TEMP_MEM(1,K),J,MPI_DOUBLE_PRECISION, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_LEAF(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_SIZE(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_ROOT(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) ELSE IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%NBSA_LOCAL = J id%MEM_SUBTREE(1:J)=TEMP_MEM(1:J,1) IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_ROOT_SBTR(1:J)=TEMP_ROOT(1:J,1) IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_FIRST_LEAF' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_FIRST_LEAF(1:J)=TEMP_LEAF(1:J,1) IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_NB_LEAF' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_NB_LEAF(1:J)=TEMP_SIZE(1:J,1) ENDIF ENDDO ELSE CALL MPI_RECV(id%NBSA_LOCAL,1,MPI_INTEGER, & MASTER,0,id%COMM,STATUS, IERR) IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'MY_FIRST_LEAF' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'MY_NB_LEAF' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF CALL MPI_RECV(id%MEM_SUBTREE(1),id%NBSA_LOCAL, & MPI_DOUBLE_PRECISION,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_FIRST_LEAF(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_NB_LEAF(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_ROOT_SBTR(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) ENDIF ELSE id%NBSA_LOCAL = -999999 IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_FIRST_LEAF(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_NB_LEAF(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF ENDIF IF(id%MYID.EQ.MASTER)THEN IF(IS_BUILD_LOAD_MEM_CALLED)THEN DEALLOCATE(TEMP_MEM) DEALLOCATE(TEMP_SIZE) DEALLOCATE(TEMP_ROOT) DEALLOCATE(TEMP_LEAF) DEALLOCATE(COST_TRAV_TMP) DEALLOCATE(DEPTH_FIRST) DEALLOCATE(DEPTH_FIRST_SEQ) DEALLOCATE(SBTR_ID) ENDIF ENDIF 87 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C NB_NIV2 = KEEP(56) ! KEEP(1:110) was broadcast earlier C NB_NIV2 is now available on all processors. IF ( NB_NIV2.GT.0 ) THEN C Allocate arrays on slaves if (id%MYID.ne.MASTER) then IF (associated(id%CANDIDATES)) THEN DEALLOCATE(id%CANDIDATES) ENDIF allocate(PAR2_NODES(NB_NIV2), & id%CANDIDATES(id%NSLAVES+1,NB_NIV2), & STAT=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= NB_NIV2*(id%NSLAVES+1) IF ( LPOK ) THEN WRITE(LP, 150) 'PAR2_NODES/id%CANDIDATES' END IF end if end if CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL MPI_BCAST(PAR2_NODES(1),NB_NIV2, & MPI_INTEGER, MASTER, id%COMM, IERR ) IF (KEEP(24) .NE.0 ) THEN CALL MPI_BCAST(id%CANDIDATES(1,1), & (NB_NIV2*(id%NSLAVES+1)), & MPI_INTEGER, MASTER, id%COMM, IERR ) ENDIF ENDIF IF ( associated(id%ISTEP_TO_INIV2)) THEN DEALLOCATE(id%ISTEP_TO_INIV2) NULLIFY(id%ISTEP_TO_INIV2) ENDIF IF ( associated(id%I_AM_CAND)) THEN DEALLOCATE(id%I_AM_CAND) NULLIFY(id%I_AM_CAND) ENDIF IF (NB_NIV2.EQ.0) THEN C allocate dummy arrays C ISTEP_TO_INIV2 will never be used C Add a parameter SIZE_ISTEP_TO_INIV2 and make C it always available in a keep(71) id%KEEP(71) = 1 ELSE id%KEEP(71) = id%KEEP(28) ENDIF allocate(id%ISTEP_TO_INIV2(id%KEEP(71)), & id%I_AM_CAND(max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'id%ISTEP_TO_INIV2' WRITE(LP, 150) 'id%TAB_POS_IN_PERE' END IF INFO(1)= -7 IF (NB_NIV2.EQ.0) THEN INFO(2)= 2 ELSE INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2) END IF GOTO 321 ENDIF IF ( NB_NIV2 .GT.0 ) THEN C If BLR grouping was performed then PAR2_NODES(INIV2) C might then point to a non principal variable C for which STEP might be negative C id%ISTEP_TO_INIV2 = -9999 DO INIV2 = 1, NB_NIV2 INN = PAR2_NODES(INIV2) id%ISTEP_TO_INIV2(abs(id%STEP(INN))) = INIV2 END DO CALL ZMUMPS_BUILD_I_AM_CAND( id%NSLAVES, KEEP(79), & NB_NIV2, id%MYID_NODES, & id%CANDIDATES(1,1), id%I_AM_CAND(1) ) ENDIF IF ( I_AM_SLAVE ) THEN IF (associated(id%FUTURE_NIV2)) THEN DEALLOCATE(id%FUTURE_NIV2) NULLIFY(id%FUTURE_NIV2) ENDIF allocate(id%FUTURE_NIV2(id%NSLAVES), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'FUTURE_NIV2' END IF INFO(1)= -7 INFO(2)= id%NSLAVES GOTO 321 ENDIF id%FUTURE_NIV2=0 DO INIV2 = 1, NB_NIV2 IDEST = MUMPS_PROCNODE( & id%PROCNODE_STEPS(abs(id%STEP(PAR2_NODES(INIV2)))), & id%KEEP(199)) id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1 ENDDO C Allocate id%TAB_POS_IN_PERE, C TAB_POS_IN_PERE is an array of size (id%NSLAVES+2,NB_NIV2) C where NB_NIV2 is the number of type 2 nodes in the tree. IF ( associated(id%TAB_POS_IN_PERE)) THEN DEALLOCATE(id%TAB_POS_IN_PERE) NULLIFY(id%TAB_POS_IN_PERE) ENDIF allocate(id%TAB_POS_IN_PERE(id%NSLAVES+2,max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'id%ISTEP_TO_INIV2' WRITE(LP, 150) 'id%TAB_POS_IN_PERE' END IF INFO(1)= -7 IF (NB_NIV2.EQ.0) THEN INFO(2)= 2 ELSE INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2) END IF GOTO 321 ENDIF END IF C deallocate PAR2_NODES that was computed C on master and broadcasted on all slaves IF (NB_NIV2.GT.0) DEALLOCATE (PAR2_NODES) 321 CONTINUE C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C IF ( KEEP(38) .NE. 0 ) THEN C ------------------------- C Initialize root structure C ------------------------- CALL ZMUMPS_INIT_ROOT_ANA( id%MYID, & id%NSLAVES, id%N, idintr%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 idintr%root%yes = .FALSE. END IF IF ( KEEP(38) .NE. 0 .and. I_AM_SLAVE ) THEN C ----------------------------------------------- C Check if at least one processor belongs to the C root. In the case where all of them have MYROW C equal to -1, this could be a problem due to the C BLACS. (mpxlf90_r and IBM BLACS). C ----------------------------------------------- CALL MPI_ALLREDUCE(idintr%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 ( idintr%root%MYROW .LT. -1 .OR. & idintr%root%MYCOL .LT. -1 ) THEN INFO(1) = -25 INFO(2) = 0 END IF IF ( LPOK .AND. INFO(1) == -25 ) THEN WRITE(LP, '(A)') & 'Problem with your version of the BLACS.' WRITE(LP, '(A)') 'Try using a BLACS version from netlib.' ENDIF END IF C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C C C CALL ZMUMPS_ANA_ARROWHEADS_WRAPPER ( id, & GATHER_MATRIX_ALLOCATED ) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL ZMUMPS_ANA_COMPUTE_ESTIMATES (id,idintr) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C ------------------------- C Define a specific mapping C for the user C ------------------------- IF ( id%MYID. eq. MASTER .AND. KEEP(54) .eq. 1 ) THEN IF (associated( id%MAPPING)) THEN DEALLOCATE( id%MAPPING) ENDIF allocate( id%MAPPING(id%KEEP8(28)), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28), INFO(2)) IF ( LPOK ) THEN WRITE(LP, 150) 'id%MAPPING' END IF GOTO 92 END IF allocate(IWtemp( id%N ), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-7 INFO(2)=id%N IF ( LPOK ) THEN WRITE(LP, 150) 'IWtemp(N)' END IF GOTO 92 END IF IF ( id%KEEP8(28) .EQ. 0_8 ) THEN IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY ELSE IRN_PTR => id%IRN JCN_PTR => id%JCN ENDIF CALL ZMUMPS_BUILD_MAPPING( & id%N, id%MAPPING(1), id%KEEP8(28), & IRN_PTR(1),JCN_PTR(1), id%PROCNODE_STEPS(1), & id%STEP(1), & id%NSLAVES, id%SYM_PERM(1), & id%FILS(1), IWtemp, id%KEEP(1),id%KEEP8(1), & idintr%root%MBLOCK, idintr%root%NBLOCK, & idintr%root%NPROW, idintr%root%NPCOL ) DEALLOCATE( IWtemp ) 92 CONTINUE END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C 500 CONTINUE C Deallocate allocated working space IF (allocated(FILS_TMP)) DEALLOCATE(FILS_TMP) IF (allocated(STEP_TMP)) DEALLOCATE(STEP_TMP) IF (allocated(LRGROUPS_TMP)) DEALLOCATE(LRGROUPS_TMP) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (allocated(WORK2ALLOC)) DEALLOCATE(WORK2ALLOC) IF (KEEP(244).NE.1) THEN IF (allocated(PARAORD_to_idCOMM)) & DEALLOCATE(PARAORD_to_idCOMM) IF (COMM_PARAORD_ALLOCATED) THEN IF (COMM_PARAORD.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_FREE( COMM_PARAORD, IERR ) COMM_PARAORD_ALLOCATED = .FALSE. ENDIF ENDIF IF (COMM_PARASYMB_ALLOCATED) THEN IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_FREE( COMM_PARASYMB, IERR ) COMM_PARASYMB_ALLOCATED = .FALSE. ENDIF ENDIF ENDIF IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE) IF (allocated(XNODEL)) DEALLOCATE(XNODEL) IF (allocated(NODEL)) DEALLOCATE(NODEL) IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK,KEEP(147)) CALL MUMPS_AB_FREE_LMAT(LUMAT,KEEP(147)) CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP,KEEP(147)) CALL MUMPS_AB_FREE_GCOMP(GCOMP, MEMCNT) CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST, MEMCNT) C Standard deallocations (error or not) IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR) IF (associated(FREREPTR)) DEALLOCATE(FREREPTR) nullify(FREREPTR, NFSIZPTR) IF (associated(BLKPTR_PTRLOC).AND.BLKPTR_ALLOCATED) THEN DEALLOCATE(BLKPTR_PTRLOC) nullify(BLKPTR_PTRLOC) ENDIF IF (associated(BLKVAR_PTRLOC).AND.BLKVAR_ALLOCATED) THEN DEALLOCATE(BLKVAR_PTRLOC) nullify(BLKVAR_PTRLOC) ENDIF KEEP8(26)=max(1_8,KEEP8(26)) KEEP8(27)=max(1_8,KEEP8(27)) RETURN 110 FORMAT(/' ****** ANALYSIS STEP ********'/) 145 FORMAT(' ELAPSED TIME SPENT IN BLR CLUSTERING =',F12.4) 150 FORMAT( & /' ** FAILURE DURING ZMUMPS_ANA_DRIVER, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE ZMUMPS_ANA_DRIVER SUBROUTINE ZMUMPS_ANA_CHECK_KEEP(id, I_AM_SLAVE) !$ USE OMP_LIB, ONLY : omp_get_max_threads C C Purpose C ======= C This subroutine decodes the control parameters, C stores them in the KEEP array, and performs a C consistency check on the KEEP array. USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id LOGICAL :: I_AM_SLAVE C internal variables INTEGER :: LP, MP, MPG, I INTEGER :: MASTER LOGICAL :: PROK, PROKG, LPOK PARAMETER( MASTER = 0 ) C LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) C Re-intialize few KEEPs entries corresponding C to stat that are incremented such C the number of split nodes: id%KEEP(61)=0 IF (id%MYID.eq.MASTER) THEN id%KEEP(38) = 0 id%KEEP(20) = 0 CALL ZMUMPS_ANA_CHECK_ICNTL48 ( id ) id%KEEP(256) = id%ICNTL(7) ! copy ordering option id%KEEP(252) = id%ICNTL(32) IF (id%KEEP(252) < 0 .OR. id%KEEP(252) > 1 ) THEN id%KEEP(252) = 0 ENDIF C Which factors to store id%KEEP(251) = id%ICNTL(31) IF (id%KEEP(251) < 0 .OR. id%KEEP(251) > 2 ) THEN id%KEEP(251)=0 ENDIF C For unsymmetric matrices, if forward solve C performed during facto, C no reason to store L factors at all. Reset C KEEP(251) accordingly... except if the user C tells that no solve is needed. IF (id%KEEP(50) .EQ. 0 .AND. id%KEEP(252).EQ.1) THEN IF (id%KEEP(251) .NE. 1) id%KEEP(251) = 2 ENDIF C Symmetric case, even if no backward needed, C store all factors IF (id%KEEP(50) .NE.0 .AND. id%KEEP(251) .EQ. 2) THEN id%KEEP(251) = 0 ENDIF C Case of solve not needed: IF (id%KEEP(251) .EQ. 1) THEN id%KEEP(201) = -1 C In that case, id%ICNTL(22) will C be ignored in future phases ELSE C Reset id%KEEP(201) -- typically for the case C of a previous analysis with KEEP(201)=-1 id%KEEP(201) = 0 ENDIF IF (id%KEEP(252).EQ.1) THEN id%KEEP(253) = id%NRHS IF (id%KEEP(253) .LE. 0) THEN id%INFO(1)=-42 id%INFO(2)=id%NRHS RETURN ENDIF ELSE id%KEEP(253) = 0 ENDIF ENDIF IF ( (id%KEEP(24).NE.0) .AND. & id%NSLAVES.eq.1 ) THEN id%KEEP(24) = 0 END IF IF ( (id%KEEP(24).EQ.0) .AND. & id%NSLAVES.GT.1 ) THEN id%KEEP(24) = 8 ENDIF IF ( (id%KEEP(24).NE.0) .AND. (id%KEEP(24).NE.1) .AND. & (id%KEEP(24).NE.8) .AND. (id%KEEP(24).NE.10) .AND. & (id%KEEP(24).NE.12) .AND. (id%KEEP(24).NE.14) .AND. & (id%KEEP(24).NE.16) .AND. (id%KEEP(24).NE.18)) THEN id%KEEP(24) = 8 END IF C**************************************************** C C The master is doing most of the work C C NOTE: Treatment of the errors on the master= C Go to the next SPMD part of the code in which C the first statement must be a call to PROPINFO C C**************************************************** C ========================================= C Check (raise error or modify) some input C parameters or KEEP values on the master. C ========================================= id%KEEP8(21) = int(id%KEEP(85),8) IF ( id%MYID .EQ. MASTER ) THEN C ---------------------------- C Save id%ICNTL(18) (distributed C matrix on entry) in id%KEEP(54) C ---------------------------- id%KEEP(54) = id%ICNTL(18) IF ( id%KEEP(54) .LT. 0 .or. id%KEEP(54).GT.3 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Out-of-range value for id%ICNTL(18).' WRITE(MPG, *) ' Used 0 ie matrix not distributed' END IF id%KEEP(54) = 0 END IF IF ( id%KEEP(54) .EQ. 1 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Option id%ICNTL(18)=1 is obsolete.' WRITE(MPG, *) ' We recommend not to use it.' WRITE(MPG, *) ' It will disappear in a future release' END IF END IF C ----------------------------------------- C Save id%ICNTL(5) (matrix format) in id%KEEP(55) C ----------------------------------------- id%KEEP(55) = id%ICNTL(5) IF ( id%KEEP(55) .LT. 0 .OR. id%KEEP(55) .GT. 1 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Out-of-range value for id%ICNTL(5).' WRITE(MPG, *) ' Used 0 ie matrix is assembled' END IF id%KEEP(55) = 0 END IF id%KEEP(60) = id%ICNTL(19) IF ( id%KEEP( 60 ) .LE. 0 ) id%KEEP( 60 ) = 0 IF ( id%KEEP( 60 ) .GT. 3 ) id%KEEP( 60 ) = 0 IF (id%KEEP(60) .NE. 0 .AND. id%SIZE_SCHUR == 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Schur option ignored because SIZE_SCHUR=0' ENDIF id%KEEP(60)=0 END IF C --------------------------------------- C Save SIZE_SCHUR in a KEEP, for possible C check at factorization and solve phases C --------------------------------------- IF ( id%KEEP(60) .NE.0 ) THEN id%KEEP(116) = id%SIZE_SCHUR IF (id%SIZE_SCHUR .LT. 0 .OR. id%SIZE_SCHUR .GE. id%N) THEN id%INFO(1)=-49 id%INFO(2)=id%SIZE_SCHUR RETURN ENDIF C List of Schur variables provided by user. IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 8 RETURN ELSE IF (size(id%LISTVAR_SCHUR) 0 .AND. id%NBLOCK > 0 .AND. & id%NPROW > 0 .AND. id%NPCOL > 0 ) THEN IF (id%NPROW *id%NPCOL .LE. id%NSLAVES) THEN C We will eventually have to "symmetrize the C Schur complement. For that NBLOCK and MBLOCK C must be equal. IF (id%MBLOCK .NE. id%NBLOCK ) THEN id%INFO(1)=-31 id%INFO(2)=id%MBLOCK - id%NBLOCK RETURN ENDIF ENDIF ENDIF ENDIF C Check the ordering strategy and compatibility with C other control parameters id%KEEP(244) = id%ICNTL(28) IF ((id%KEEP(244) .LT. 0) .OR. (id%KEEP(244) .GT. 2)) THEN id%KEEP(244) = 0 ENDIF IF(id%KEEP(244) .EQ. 0) THEN ! Automatic C One could check for availability of parallel ordering C tools, or for possible options incompatible with // C analysis to decide (e.g. avoid returning an error if C // analysis not compatible with some option but user C lets MUMPS decide to choose sequential or paralllel C analysis) C Current strategy for automatic is sequential analysis id%KEEP(244) = 1 ENDIF #if ! defined (ptscotch) && ! defined(parmetis) && ! defined(parmetis3) IF (id%KEEP(244) .EQ. 2) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("ParMETIS and PT-SCOTCH not available.")') END IF RETURN END IF #endif id%KEEP(245) = id%ICNTL(29) IF ((id%KEEP(245) .LT. 0) .OR. (id%KEEP(245) .GT. 2)) THEN id%KEEP(245) = 0 END IF IF (id%KEEP(244) .EQ. 2) THEN IF ( id%KEEP(245).EQ.0 ) THEN #if defined(parmetis) || defined(parmetis3) id%KEEP(245) = 2 #elif defined(ptscotch) id%KEEP(245) = 1 #endif ENDIF ENDIF C #if ! defined(parmetis) && ! defined(parmetis3) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 2)) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("ParMETIS not available.")') END IF RETURN END IF #endif #if ! defined(ptscotch) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 1)) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("PT-SCOTCH not available.")') END IF RETURN END IF #endif IF (id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(55) .NE. 0) THEN id%INFO(1) = -39 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(5), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if the")') WRITE(LP, & '("matrix is not assembled")') ENDIF RETURN ELSE IF(id%KEEP(60) .NE. 0) THEN id%INFO(1) = -39 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(19), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if SCHUR")') WRITE(LP, & '("complement must be returned")') ENDIF RETURN END IF C In the case where there are too few processes to do C the parallel analysis we simply revert to sequential version IF(id%NSLAVES .LT. 2) THEN id%KEEP(244) = 1 IF(PROKG) WRITE(MPG, & '("Too few processes. & Reverting to sequential analysis")',advance='no') IF(id%KEEP(245) .EQ. 1) THEN C Scotch necessarily available because pt-scotch C is, otherwise an error would have occurred IF(PROKG) WRITE(MPG, '(" with SCOTCH.")') id%KEEP(256) = 3 ELSE IF(id%KEEP(245) .EQ. 2) THEN C Metis necessarily available because parmetis C is, otherwise an error would have occurred IF(PROKG) WRITE(MPG, '(" with Metis.")') id%KEEP(256) = 5 ELSE IF(PROKG) WRITE(MPG, '(".")') id%KEEP(256) = 7 END IF END IF C In the case where there the input matrix is too small to do C the parallel analysis we simply revert to sequential version IF(id%N .LE. 50) THEN id%KEEP(244) = 1 IF(PROKG) WRITE(MPG, & '("Input matrix is too small for the parallel & analysis. Reverting to sequential analysis")',advance='no') IF(id%KEEP(245) .EQ. 1) THEN IF(PROKG) WRITE(MPG, '(" with SCOTCH.")') id%KEEP(256) = 3 ELSE IF(id%KEEP(245) .EQ. 2) THEN IF(PROKG) WRITE(MPG, '(" with Metis.")') id%KEEP(256) = 5 ELSE IF(PROKG) WRITE(MPG, '(".")') id%KEEP(256) = 7 END IF END IF END IF id%INFOG(32) = id%KEEP(244) IF ( (id%KEEP(244) .EQ. 1) .AND. & (id%KEEP(256) .EQ. 1) ) THEN C ordering given, PERM_IN must be of size N IF ( .NOT. associated( id%PERM_IN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 3 RETURN ELSE IF ( size( id%PERM_IN ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 3 RETURN END IF ENDIF C Check KEEP(9-10) for level 2 IF (id%KEEP(9) .LE. 1 ) id%KEEP(9) = 500 IF ( id%KEEP8(21) .GT. 0_8 ) THEN IF ((id%KEEP8(21).LE.1_8) .OR. & (id%KEEP8(21).GT.int(id%KEEP(9),8))) & id%KEEP8(21) = int(min(id%KEEP(9),100),8) ENDIF C IF (id%KEEP(48). EQ. 1 ) id%KEEP(48) = -12345 C IF ( (id%KEEP(48).LT.0) .OR. (id%KEEP(48).GT.5) ) THEN id%KEEP(48)=5 ENDIF C Schur C Given ordering must be compatible with Schur variables. IF ( (id%KEEP(60) .NE. 0) .AND. (id%KEEP(256) .EQ. 1) ) THEN DO I = 1, id%SIZE_SCHUR IF (id%PERM_IN(id%LISTVAR_SCHUR(I)) & .EQ. id%N-id%SIZE_SCHUR+I) & CYCLE C ------------------------------- C Problem with PERM_IN: -22/3 C Above constrained explained in C doc of PERM_IN in user guide. C ------------------------------- id%INFO(1) = -4 id%INFO(2) = id%LISTVAR_SCHUR(I) RETURN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Ignoring user-ordering, because incompatible with Schur.' WRITE(MPG,'(A)') ' ** id%ICNTL(7) treated as 0.' END IF EXIT ENDDO END IF C C Note that schur is not compatible with C C 1/Max-trans DONE C 2/Null space C 3/Ordering given DONE C 4/Scaling C 5/Iterative Refinement C 6/Error analysis C 7/Parallel Analysis C C Graph modification prior to ordering (id%ICNTL(12) option) C id%KEEP (95) will hold the eventually modified value of id%ICNTL(12) C id%KEEP(95) = id%ICNTL(12) C reset to usual ordering (KEEP(95)=1) C - when matrix is not general symmetric C - for out-of-range values IF (id%KEEP(50).NE.2) id%KEEP(95) = 1 IF ((id%KEEP(95).GT.3).OR.(id%KEEP(95).LT.0)) id%KEEP(95) = 1 C MAX-TRANS C C id%KEEP (23) will hold the eventually modified value of id%ICNTL(6) C (maximum transversal if >= 1) C id%KEEP(23) = id%ICNTL(6) C C C -------------------------------------------- C Avoid max-trans unsymmetric permutation in case of C matrix is symmetric with SYM=1 or C ordering is given, C or matrix is in element form, or Schur is asked C or initial matrix is distributed C -------------------------------------------- IF (id%KEEP(23).LT.0.OR.id%KEEP(23).GT.7) id%KEEP(23) = 0 C still forbid max trans for SYM=1 case IF ( id%KEEP(50) .EQ. 1 ) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not needed with SYM=1 factorization' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(95) .GT. 1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) ignored: not needed with SYM=1 factorization' END IF ENDIF id%KEEP(95) = 1 END IF C IF (id%KEEP(60) .GT. 0) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not allowed because of Schur' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Scaling during analysis not allowed because of Schur' ENDIF id%KEEP(52) = 0 ENDIF C also forbid compressed/constrained ordering... IF (id%KEEP(95) .GT. 1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) option not allowed because of Schur' END IF ENDIF id%KEEP(95) = 1 END IF IF ( (id%KEEP(23) .NE. 0) .AND. (id%KEEP(256).EQ.1)) THEN id%KEEP(23) = 0 IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'because ordering is given' END IF END IF IF ( id%KEEP(256) .EQ. 1 ) THEN IF (id%KEEP(95) > 1 .AND. PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) option incompatible with given ordering' END IF id%KEEP(95) = 1 END IF IF (id%KEEP(54) .NE. 0) THEN IF( id%KEEP(23) .NE. 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'because matrix is distributed' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Scaling (ICNTL(8)) during analysis not ', & 'allowed because matrix is distributed)' ENDIF ENDIF id%KEEP(52) = 0 IF (id%KEEP(95) .GT. 1 .AND. MPG.GT.0) THEN WRITE(MPG,'(A,A)') & ' ** ICNTL(12) option not allowed because matrix is ', & 'distributed' ENDIF id%KEEP(95) = 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN IF( id%KEEP(23) .NE. 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'for matrices in elemental format' END IF id%KEEP(23) = 0 ENDIF IF (PROKG .AND. id%KEEP(52).EQ.-2) THEN WRITE(MPG,'(A)') & ' ** Scaling (ICNTL(8)) not allowed ', & 'for matrices in elemental format' ENDIF id%KEEP(52) = 0 id%KEEP(95) = 1 ENDIF C In the case where parallel analysis is done, column permutation C is not allowed IF(id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(23) .EQ. 7) THEN C Automatic hoice: set it to 0 id%KEEP(23) = 0 ELSE IF (id%KEEP(23) .GT. 0) THEN id%INFO(1) = -39 id%KEEP(23) = 0 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(6), ICNTL(28)")') WRITE(LP, & '("Maximum transversal not allowed & in parallel analysis")') ENDIF RETURN END IF END IF C -------------------------------------------- C Avoid distributed entry for element matrix. C -------------------------------------------- IF ( id%KEEP(54) .NE. 0 .AND. id%KEEP(55) .NE. 0 ) THEN id%KEEP(54) = 0 IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Distributed entry not available for element matrix' END IF ENDIF C ---------------------------------- C Choice of symbolic analysis option C ---------------------------------- IF (id%ICNTL(58).NE.1 .and. id%ICNTL(58).NE.2 & .and. id%ICNTL(58).NE.3 .and. id%ICNTL(58).NE.4 ) THEN C out of range values leads to default id%KEEP(106)=2 ELSE id%KEEP(106)=id%ICNTL(58) C Options 3 and 4 not available, reset to default IF (id%KEEP(106).EQ.4) id%KEEP(106)=2 IF (id%KEEP(106).EQ.3) id%KEEP(106)=2 ENDIF C modify input parameters to avoid incompatible C input data between ordering, scaling and maxtrans C note that if id%ICNTL(12)/id%KEEP(95) = 0 then C the automatic choice will be done in ANA_O IF(id%KEEP(50) .EQ. 2) THEN C LDLT case IF( .NOT. associated(id%A) ) THEN C constraint ordering can be computed only if values are C given to analysis IF(id%KEEP(95) .EQ. 3) THEN id%KEEP(95) = 2 ENDIF ENDIF IF(id%KEEP(95) .EQ. 3 .AND. id%KEEP(256) .NE. 2) THEN C if constraint and ordering is not AMF then use compress IF (PROK) WRITE(MP,*) & 'WARNING: ZMUMPS_ANA_O constrained ordering not ', & 'available with selected ordering' id%KEEP(95) = 2 ENDIF IF(id%KEEP(95) .EQ. 3) THEN C if constraint ordering required then we need to compute scaling C and max trans C NOTE that if we enter this condition then C id%A is associated because of the test above: C (IF( .NOT. associated(id%A) ) THEN) id%KEEP(23) = 5 id%KEEP(52) = -2 ELSE IF(id%KEEP(95) .EQ. 2 .AND. & (id%KEEP(23) .EQ. 0 .OR. id%KEEP(23) .EQ. 7) ) THEN C compressed ordering requires max trans but not necessary scaling IF( associated(id%A) ) THEN id%KEEP(23) = 5 ELSE C we can do compressed ordering without C information on the numerical values: C a maximum transversal already provides C information on the location of off-diagonal C nonzeros which can be candidates for 2x2 C pivots id%KEEP(23) = 1 ENDIF ELSE IF(id%KEEP(95) .EQ. 1) THEN id%KEEP(23) = 0 ELSE IF(id%KEEP(95) .EQ. 0 .AND. id%KEEP(23) .EQ. 0) THEN C if max trans desactivated then the automatic choice for type of ord C is set to 1, which means that we will use usual ordering C (no constraints or compression) id%KEEP(95) = 1 ENDIF ELSE id%KEEP(95) = 1 ENDIF C -------------------------------- C Save ICNTL(56) (QR) in KEEP(53) C Will be broadcasted to all other C nodes in routine ZMUMPS_BDCAST C -------------------------------- id%KEEP(53) = id%ICNTL(56) C --------------------------- C Possible values are 0..2 C Other values are treated as 0 C ------------------------------ IF ( id%KEEP(53) .LT. 0 .OR. & id%KEEP(53) .GE. 2 & ) THEN id%KEEP(53) = 0 IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(56) treated as if set to 0 ' END IF IF(id%KEEP(86).EQ.1)THEN C Force the exchange of both the memory and flops information during C the factorization IF(id%KEEP(47).LT.2) id%KEEP(47)=2 ENDIF IF(id%KEEP(48).EQ.5)THEN IF(id%KEEP(50).EQ.0)THEN id%KEEP(87)=50 id%KEEP(88)=50 ELSE id%KEEP(87)=70 id%KEEP(88)=70 ENDIF ENDIF IF((id%NSLAVES.EQ.1).AND.(id%KEEP(76).GT.3))THEN id%KEEP(76)=2 ENDIF IF(id%KEEP(81).GT.0)THEN IF(id%KEEP(47).LT.2) id%KEEP(47)=2 ENDIF C C -- Save Block Low Rank input parameter id%KEEP(494) = id%ICNTL(35) IF (id%KEEP(494).EQ.1) THEN C -- Automatic BLR option setting id%KEEP(494)= 2 ENDIF IF ( id%KEEP(494).EQ.4) id%KEEP(494)=0 IF ((id%KEEP(494).LT.0).OR.(id%KEEP(494).GT.4)) THEN C Out of range values treated as 0 id%KEEP(494) = 0 ENDIF IF(id%KEEP(494).NE.0) THEN C test BLR incompatibilities C id%KEEP(464) = id%ICNTL(38) IF (id%KEEP(464).LT.0.OR.(id%KEEP(464).GT.1000)) THEN C Out of range values treated as 0 id%KEEP(464) = 0 ENDIF id%KEEP(465) = id%ICNTL(39) IF (id%KEEP(465).LT.0.OR.(id%KEEP(465).GT.1000)) THEN C Out of range values treated as 0 id%KEEP(465) = 0 ENDIF C LR is incompatible with elemental matrices, forbid it at analysis IF (id%KEEP(55).NE.0) THEN IF (LPOK) WRITE(LP,*) & " *** BLR feature currently incompatible " & ,"with elemental matrices" C BLR for elt entry might be developed in the future id%INFO(1)=-800 id%INFO(2)=5 RETURN ENDIF C C LR incompatible with forward in facto IF (id%KEEP(252).NE.0) THEN IF (LPOK) WRITE(LP,*) & " *** BLR feature currently incompatible" & ," with forward during factorization" id%INFO(1) = -43 id%INFO(2) = 35 RETURN ENDIF C ENDIF C IF(id%KEEP(494).NE.0) THEN C id%KEEP(469)=0,1,2,3,4 IF ((id%KEEP(469).GT.4).OR.(id%KEEP(469).LT.0)) THEN id%KEEP(469)=0 ENDIF C Not implemented yet IF (id%KEEP(469).EQ.4) id%KEEP(469)=0 C id%KEEP(471)=-1,0,1 IF ((id%KEEP(471).LT.-1).AND.(id%KEEP(471).GT.1)) THEN id%KEEP(471)=-1 ENDIF C id%KEEP(472)=0 or 1 IF ((id%KEEP(472).NE.0).AND.(id%KEEP(472).NE.1)) THEN id%KEEP(472)=1 ENDIF C id%KEEP(475)=0,1,2,3 IF ((id%KEEP(475).GT.3).OR.(id%KEEP(475).LT.0)) THEN id%KEEP(475)=0 ENDIF C id%KEEP(482)=0,1,2,3 IF ((id%KEEP(482).GT.3).OR.(id%KEEP(482).LT.0)) THEN id%KEEP(482)=0 ENDIF IF((id%KEEP(487).LT.0)) THEN id%KEEP(487)= 2 ! default value ENDIF C id%KEEP(488)>0 IF((id%KEEP(488).LE.0)) THEN id%KEEP(488)= 8*id%KEEP(6) ENDIF C id%KEEP(490)>0 IF((id%KEEP(490).LE.0)) THEN id%KEEP(490) = 128 ENDIF C KEEP(491)>0 IF((id%KEEP(491).LE.0)) THEN id%KEEP(491) = 1000 ENDIF ENDIF C id%KEEP(13) = 0 id%KEEP(14) = 0 C Analysis by Blocks id%KEEP(13) = id%ICNTL(15) IF (id%KEEP(13).GT.1) THEN CV0 out-of range values id%KEEP(13) = 0 ENDIF IF (id%KEEP(13).EQ.1) THEN C{ Analysis by block with block data provided by user C check input data IF ( .NOT.associated(id%BLKPTR)) THEN C BLKPTR provided by user IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " id%BLKPTR should be provided by user on host " ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ELSE IF ( (id%NBLK.LE.0).OR.(id%NBLK.GT.id%N) & .OR. (id%NBLK+1.NE.size(id%BLKPTR)) & ) THEN C id%NBLK out of range IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ERROR incorrect value of id%NBLK:", id%NBLK ENDIF id%INFO(1) = -57 id%INFO(2) = 1 ELSE IF (id%BLKPTR(id%NBLK+1)-1.NE.id%N) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR id%BLKPTR(id%NBLK+1)-1 ", & "should be equal to id%N instead of ", & id%BLKPTR(id%NBLK+1)-1 ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ELSE IF (id%BLKPTR(1).NE.1) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR id%BLKPTR(1)", & "should be equal to 1 instead of ", & id%BLKPTR(1) ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ELSE IF (associated(id%BLKVAR)) THEN C id%BLKVAR IF (size(id%BLKVAR).NE.id%N) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR with centralized matrix. Size of id%BLKVAR ", & "should be equal to id%N instead of ", & size(id%BLKVAR) ENDIF id%INFO(1) = -57 id%INFO(2) = 3 ENDIF ENDIF C} ENDIF IF (id%KEEP(13).LT.0) THEN C note that id%BLKPTR might still be associated C but will not be used IF (mod(id%N,-id%KEEP(13)) .NE.0) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ICNTL(15)=", id%ICNTL(15), & " is incompatible with N=", id%N ENDIF id%INFO(1) = -57 id%INFO(2) = 1 ENDIF ENDIF IF (id%KEEP(13).EQ.0) THEN IF ( & ((id%KEEP(54).EQ.3).AND.(id%KEEP(244).EQ.1)) & .OR. & ((id%KEEP(244).EQ.2).AND.(id%KEEP(339).NE.0)) & ) THEN id%KEEP(13)=-1 ENDIF C unsymmetric assembled matrices with or without BLR, C also in case of centralized matrix (if C matrix is distributed, then KEEP(13) has C been set to -1 in the block above) IF (id%KEEP(50).EQ.0.AND. id%KEEP(55).EQ.0) THEN C Respect decision taken for Maxtrans C since it will be switch off C if one activates the analysis by block IF ( (id%KEEP(23).LE.0) .OR. (id%KEEP(23).GT.7) & ) THEN id%KEEP(13)=-1 ENDIF ENDIF ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(55).NE.0) & ) THEN IF (PROKG.AND.(id%KEEP(13).NE.-1)) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with elemental matrices" C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(106).NE.1).AND. (id%KEEP(106).NE.2) & ) THEN IF (PROKG.AND.(id%KEEP(13).NE.-1)) WRITE(MPG,'(A,A,I4)') & " ** Analysis by block not compatible ", & "with symbolic factorization option ", & id%KEEP(106) C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. (id%KEEP(244) .EQ. 2) .AND. & (id%KEEP(339).EQ.0) & ) THEN IF (PROKG.AND.(id%KEEP(13).NE.-1)) WRITE(MPG,'(A)') & " ** Analysis by block switched off " C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(60).NE.0) & ) THEN IF (PROKG.AND.(id%KEEP(13).NE.-1)) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with Schur " C switch off analysis by block id%KEEP(13)= 0 ENDIF IF (id%KEEP(13).NE.0) THEN C Maximum transversal not compatible with analysis by block IF (id%KEEP(23).NE.0) THEN C in case of automatic choice (id%KEEP(27).EQ.7) C do not print message IF (PROKG.AND.id%KEEP(23).NE.7) WRITE(MPG,'(A,A)') & " ** Maximum transversal (ICNTL(6)) ", & "not compatible with analysis by block" C switch off max transversal id%KEEP(23)= 0 ENDIF C - compression for LDLT IF (id%KEEP(95).NE.1) THEN C in case of automatic choice (id%KEEP(95).EQ.0) C do not print message IF (PROKG.AND.id%KEEP(95).NE.0) WRITE(MPG,'(A,A)') & " ** ICNTL(12) not compatible with ", & " analysis by block" C switch off 2x2 preprocessing for symmetric matrices id%KEEP(95) = 1 ENDIF ENDIF C C end id%MYID.EQ.MASTER END IF RETURN END SUBROUTINE ZMUMPS_ANA_CHECK_KEEP C ======================================== SUBROUTINE ZMUMPS_ANA_CHECK_ICNTL48 (id ) !$ USE OMP_LIB, ONLY : omp_get_max_threads USE ZMUMPS_STRUC_DEF C IMPLICIT NONE C C Purpose C ======= C This subroutine performed part of ZMUMPS_ANA_CHECK_KEEP concerned by ICNTL(48) C and is called by ZMUMPS_ANA_CHECK_KEEP and ZMUMPS_ANA_REDO_STAT C C Parameters C TYPE(ZMUMPS_STRUC) :: id C C Local variables C INTEGER :: LP, MP, MPG, NOMP INTEGER :: MASTER LOGICAL :: PROK, PROKG, LPOK LOGICAL :: I_AM_SLAVE PARAMETER( MASTER = 0 ) C LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (id%MYID.eq.MASTER) THEN C C L0-OMP settings of KEEP(400) C id%KEEP(401) = 0 NOMP = 0 IF (id%ICNTL(48).EQ.1) id%KEEP(401)=1 IF (id%KEEP(401) .GT. 0) THEN !$ NOMP=omp_get_max_threads() IF ( NOMP .EQ. 0 ) THEN C Compilation without OMP! id%KEEP(400) = 0 id%INFO(1)=-58 id%INFO(2)=0 IF (LPOK) WRITE(LP,'(A)') & " FAILURE DETECTED IN ANALYSIS: ICNTL(48) requires OpenMP" RETURN ENDIF ENDIF C ENDIF RETURN END SUBROUTINE ZMUMPS_ANA_CHECK_ICNTL48 C SUBROUTINE ZMUMPS_GATHER_MATRIX(id) C This subroutine gathers a distributed matrix C on the host node USE ZMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) TYPE(ZMUMPS_STRUC) :: id C local variables INTEGER, ALLOCATABLE :: REQPTR(:,:) INTEGER(8), ALLOCATABLE :: MATPTR(:) INTEGER(8), ALLOCATABLE :: MATPTR_cp(:) INTEGER(8) :: IBEG8, IEND8 INTEGER :: INDX INTEGER :: LP, MP, MPG, I, K INTEGER(8) :: I8 LOGICAL :: PROKG C C messages are split into blocks of size BLOCKSIZE C (smaller than IOVFLO (=2^31-1)) C on all processors INTEGER(4) :: IOVFLO INTEGER :: BLOCKSIZE INTEGER :: MAX_NBBLOCK_loc, NBBLOCK_loc INTEGER :: SIZE_SENT, NRECV LOGICAL :: OMP_FLAG INTEGER(8) :: NZ_loc8 C for validation only: INTEGER :: NB_BLOCKS, NB_BLOCK_SENT LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) C iovflo = huge(INTEGER, kind=4) IOVFLO = huge(IOVFLO) C we do not want too large messages BLOCKSIZE = int(max(100000_8,int(IOVFLO,8)/200_8)) IF ( id%KEEP(46) .EQ. 0 .AND. id%MYID .EQ. MASTER ) THEN C host-node mode: master has no entries. id%KEEP8(29) = 0_8 END IF IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------- C Allocate small arrays for pointers C into arrays IRN/JCN C ----------------------------------- ALLOCATE( MATPTR( id%NPROCS ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) ' array MATPTR' END IF GOTO 13 END IF ALLOCATE( MATPTR_cp( id%NPROCS ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) ' array MATPTR' END IF GOTO 13 END IF C ----------------------------------- C Allocate a small array for requests C ----------------------------------- ALLOCATE( REQPTR( id%NPROCS-1, 2 ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = 2 * (id%NPROCS-1) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array REQPTR' END IF GOTO 13 END IF C -------------------- C Allocate now IRN/JCN C -------------------- ALLOCATE( id%IRN( id%KEEP8(28) ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2)) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array IRN' END IF GOTO 13 END IF ALLOCATE( id%JCN( id%KEEP8(28) ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2)) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array JCN' END IF GOTO 13 END IF END IF 13 CONTINUE C Propagate errors CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) < 0 ) RETURN C ------------------------------------- C Get numbers of non-zeros for everyone C and count total and maximum C nb of blocks of size BLOCKSIZE C that slaves will sent C ------------------------------------- IF ( id%MYID .EQ. MASTER ) THEN C each block will correspond to 2 messages (IRN_LOC,JCN_LOC) NB_BLOCK_SENT = 0 MAX_NBBLOCK_loc = 0 DO I = 1, id%NPROCS - 1 CALL MPI_RECV( MATPTR( I+1 ), 1, & MPI_INTEGER8, I, & COLLECT_NZ, id%COMM, STATUS, IERR ) NBBLOCK_loc = ceiling(dble(MATPTR(I+1))/dble(BLOCKSIZE)) MAX_NBBLOCK_loc = max(MAX_NBBLOCK_loc, NBBLOCK_loc) NB_BLOCK_SENT = NB_BLOCK_SENT + NBBLOCK_loc END DO IF ( id%KEEP(46) .eq. 0 ) THEN MATPTR( 1 ) = 1_8 ELSE NZ_loc8=id%KEEP8(29) MATPTR( 1 ) = NZ_loc8 + 1_8 END IF C -------------- C Build pointers C -------------- DO I = 2, id%NPROCS MATPTR( I ) = MATPTR( I ) + MATPTR( I-1 ) END DO ELSE NZ_loc8=id%KEEP8(29) CALL MPI_SEND( NZ_loc8, 1, MPI_INTEGER8, MASTER, & COLLECT_NZ, id%COMM, IERR ) END IF IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------------------- C Bottleneck is here master; use synchronous send C for slaves, but asynchronous receives on master C Then while master receives indices do the local C copies for better overlap. C (If master has other things to do, he could try C to do them here.) C ------------------------------------ C copy pointers to position in IRN/JCN MATPTR_cp = MATPTR IF ( id%KEEP8(29) .NE. 0_8 ) THEN OMP_FLAG = ( id%KEEP8(29).GE.50000_8 ) !$OMP PARALLEL DO PRIVATE(I8) !$OMP& IF(OMP_FLAG) DO I8=1,id%KEEP8(29) id%IRN(I8) = id%IRN_loc(I8) id%JCN(I8) = id%JCN_loc(I8) ENDDO !$OMP END PARALLEL DO ENDIF C C Compute position for each block to be received C and store it. NB_BLOCKS = 0 C at least one slave will send MAX_NBBLOCK_loc C couple of messages (IRN_loc/JCN_loc) DO K = 1, MAX_NBBLOCK_loc C Post irecv for all messages from proc I C that have been sent NRECV = 0 DO I = 1, id%NPROCS - 1 C Check if message was sent IBEG8 = MATPTR_cp( I ) IF ( IBEG8 .LT. MATPTR(I+1)) THEN C Count number of request in NRECV NRECV = NRECV + 2 IEND8 = min(IBEG8+int(BLOCKSIZE,8)-1_8, & MATPTR(I+1)-1_8) C update pointer for receiving messages C from proc I in MATPTR_cp: MATPTR_cp( I ) = IEND8 + 1_8 SIZE_SENT = int(IEND8 - IBEG8 + 1_8) NB_BLOCKS = NB_BLOCKS + 1 C CALL MPI_IRECV( id%IRN(IBEG8), SIZE_SENT, MPI_INTEGER, & I, COLLECT_IRN, id%COMM, REQPTR(I,1), IERR ) C CALL MPI_IRECV( id%JCN(IBEG8), SIZE_SENT, MPI_INTEGER, & I, COLLECT_JCN, id%COMM, REQPTR(I,2), IERR ) ELSE REQPTR( I,1 ) = MPI_REQUEST_NULL REQPTR( I,2 ) = MPI_REQUEST_NULL ENDIF END DO C Wait set of messages corresponding to current block C ( we dont exploit the fact that C messages are not overtaking C (if sent by one source to the same destination) ) C C Loop on only non MPI_REQUEST_NULL requests DO I = 1, NRECV CALL MPI_WAITANY & ( 2 * (id%NPROCS-1), REQPTR( 1, 1 ), INDX, & STATUS, IERR ) ENDDO C C process next block END DO DEALLOCATE( REQPTR ) DEALLOCATE( MATPTR ) DEALLOCATE( MATPTR_cp ) C end of reception by master ELSE C ----------------------------- C Send only if size is not zero C ----------------------------- IF ( id%KEEP8(29) .NE. 0_8 ) THEN NZ_loc8=id%KEEP8(29) C send by blocks of size BLOCKSIZE DO I8=1_8, NZ_loc8, int(BLOCKSIZE,8) SIZE_SENT = BLOCKSIZE IF (NZ_loc8-I8+1_8.LT.int(BLOCKSIZE,8)) THEN SIZE_SENT = int(NZ_loc8-I8+1_8) ENDIF CALL MPI_SEND( id%IRN_loc(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & COLLECT_IRN, id%COMM, IERR ) CALL MPI_SEND( id%JCN_loc(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & COLLECT_JCN, id%COMM, IERR ) END DO END IF END IF RETURN 150 FORMAT( &/' ** FAILURE DURING ZMUMPS_GATHER_MATRIX, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE ZMUMPS_GATHER_MATRIX SUBROUTINE ZMUMPS_DUMP_PROBLEM(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C If id%WRITE_PROBLEM has been set by the user, C possibly on all processors in case of distributed C matrix, open a file and dumps the matrix and/or C the right hand side. In case the last characters C of id.WRITE_PROBLEM are "bin" (uppercase letters C are also accepted), then the matrix is written C in binary stream format (a C routine is called to C avoid depending on the access='stream' mode that C is only available since Fortran 2003). In that case, C a small header file is also written. C Otherwise, this subroutine calls C ZMUMPS_DUMP_MATRIX (to write the matrix in C matrix-market format) and ZMUMPS_DUMP_RHS. C The routine should be called on all MPI processes. C C Examples: C 1/ WRITE_PROBLEM='mymatrix.txt', centralized matrix C mymatrix.txt contains the matrix in matrix-market format C 2/ WRITE_PROBLEM='mymatrix.txt', distributed matrix C mymatrix.txt contains the portion of the matrix C on process , in matrix-market format C 3/ WRITE_PROBLEM='mymatrix.bin', centralized matrix C mymatrix.bin contains the matrix in binary format C mymatrix.header contains a short description in text format, C with the first line identical to the one of C a matrix-market format C 4/ WRITE_PROBLEM='mymatrix.bin', distributed matrix C mymatrix.bin contains the portion of the matrix C on process , in binary format C C mymatrix.header contains a short description in text format, C with the first line identical to matrix-market format C C If a centralized, dense, RHS is available, it is also written, C either in matrix-market or binary format (if WRITE_PROBLEM C has a .bin extension). In that case the filename for the RHS C is WRITE_PROBLEM//".rhs". If written in binary form, information C on the RHS is also provided in the header file. C INCLUDE 'mpif.h' C C Arguments C ========= C TYPE(ZMUMPS_STRUC) :: id C C Local variables C =============== C INTEGER :: MASTER, IERR, I INTEGER :: IUNIT LOGICAL :: IS_ELEMENTAL LOGICAL :: IS_DISTRIBUTED LOGICAL :: NAME_INITIALIZED INTEGER :: DO_WRITE, DO_WRITE_CHECK CHARACTER(LEN=20) :: IDSTR LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: L LOGICAL :: BINARY_FORMAT, DUMP_RHS, & DUMP_BLKPTR, DUMP_BLKVAR INTEGER :: IS_A_PROVIDED, IS_A_PROVIDED_GLOB COMPLEX(kind=8), TARGET :: A_DUMMY(1) INTEGER, TARGET :: IRN_DUMMY(1), JCN_DUMMY(1) INTEGER, POINTER, DIMENSION(:) :: IRN_PASSED, JCN_PASSED COMPLEX(kind=8), POINTER, DIMENSION(:) :: A_PASSED INTEGER :: MPG LOGICAL :: PROKG PARAMETER( MASTER = 0 ) 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) MPG = id%ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) NAME_INITIALIZED = id%WRITE_PROBLEM(1:20) & .NE. "NAME_NOT_INITIALIZED" BINARY_FORMAT = .FALSE. L=len_trim(id%WRITE_PROBLEM) IF (L.GT.4) THEN IF ( id%WRITE_PROBLEM(L-3:L-3) .EQ. '.' .AND. & ( id%WRITE_PROBLEM(L-2:L-2) .EQ. 'b' .OR. & id%WRITE_PROBLEM(L-2:L-2) .EQ. 'B' ) .AND. & ( id%WRITE_PROBLEM(L-1:L-1) .EQ. 'i' .OR. & id%WRITE_PROBLEM(L-1:L-1) .EQ. 'I' ) .AND. & ( id%WRITE_PROBLEM(L:L) .EQ. 'n' .OR. & id%WRITE_PROBLEM(L:L) .EQ. 'N' ) ) THEN BINARY_FORMAT = .TRUE. ENDIF ENDIF IF (NAME_INITIALIZED.AND.PROKG) THEN WRITE(MPG,'(/A,A/)') & " Write input matrix to file, WRITE_PROBLEM= ", & id%WRITE_PROBLEM(1:L) ENDIF C Check if RHS should also be dumped DUMP_RHS = id%MYID.EQ.MASTER .AND. & associated(id%RHS) .AND. NAME_INITIALIZED DUMP_RHS = DUMP_RHS .AND. id%NRHS .GE. 1 DUMP_RHS = DUMP_RHS .AND. id%N .GE. 1 DUMP_RHS = DUMP_RHS .AND. id%ICNTL(20) .EQ. 0 C Check if BLKPTR and/or BLKVAR should also be dumped DUMP_BLKPTR = .FALSE. DUMP_BLKVAR = .FALSE. IF ( id%MYID.EQ.MASTER .AND. NAME_INITIALIZED ) THEN IF ( id%ICNTL(15) .EQ. 1 & .AND. id%NBLK .GT. 0 ) THEN IF (associated(id%BLKPTR)) THEN DUMP_BLKPTR = .TRUE. IF (associated(id%BLKVAR)) THEN C Dump also BLKVAR, except if allocated by MUMPS DUMP_BLKVAR = .TRUE. ENDIF ENDIF ELSE IF ( id%ICNTL(15) .LT. 0 ) THEN IF (associated(id%BLKVAR)) THEN C Dump also BLKVAR, except if allocated by MUMPS DUMP_BLKVAR = .TRUE. ENDIF ENDIF ENDIF C Remark: if id%KEEP(54) = 1 or 2, the structure C is centralized at analysis. Since ZMUMPS_DUMP_PROBLEM C is called at analysis phase, we define IS_DISTRIBUTED C as below, which implies that the structure of the problem C is distributed in IRN_loc/JCN_loc at analysis. IS_DISTRIBUTED = (id%KEEP(54) .EQ. 3) IS_ELEMENTAL = (id%KEEP(55) .NE. 0) IF (NAME_INITIALIZED) THEN IF (I_AM_MASTER .OR. IS_DISTRIBUTED) THEN C Try to find a free Fortran unit CALL MUMPS_FIND_UNIT(IUNIT) IF ( IUNIT .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 1 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) GOTO 500 IF (I_AM_MASTER .AND. .NOT. IS_DISTRIBUTED) THEN C ==================== C Matrix is assembled C and centralized C ==================== IF (NAME_INITIALIZED) THEN IF ( BINARY_FORMAT ) THEN IF (id%KEEP8(28) .EQ. 0_8) THEN C Special case of empty matrix A_PASSED => A_DUMMY IRN_PASSED => IRN_DUMMY JCN_PASSED => JCN_DUMMY IS_A_PROVIDED = 1 ELSE IF (associated(id%A)) THEN A_PASSED=>id%A IRN_PASSED => id%IRN JCN_PASSED => id%JCN IS_A_PROVIDED = 1 ELSE A_PASSED => A_DUMMY IRN_PASSED => id%IRN JCN_PASSED => id%JCN IS_A_PROVIDED = 0 ENDIF OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' ) CALL ZMUMPS_DUMP_HEADER( IUNIT, id%N, & IS_A_PROVIDED, id%KEEP(50), IS_DISTRIBUTED, & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) ) CLOSE( IUNIT ) CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(28), & id%KEEP(35), & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1), & IS_A_PROVIDED, & trim(id%WRITE_PROBLEM)//char(0) ) ELSE OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)) CALL ZMUMPS_DUMP_MATRIX( id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! = .FALSE., centralized & IS_ELEMENTAL, ! Elemental or not & .FALSE.) CLOSE(IUNIT) ENDIF ENDIF ELSE IF ( IS_DISTRIBUTED ) THEN C ===================== C Matrix is distributed C ===================== IF ( .NOT.NAME_INITIALIZED & .OR. .NOT. I_AM_SLAVE )THEN DO_WRITE = 0 ELSE DO_WRITE = 1 ENDIF CALL MPI_ALLREDUCE(DO_WRITE, DO_WRITE_CHECK, 1, & MPI_INTEGER, MPI_SUM, id%COMM, IERR) C ----------------------------------------- C If yes, each processor writes its share C of the matrix in a file in matrix market C format (otherwise nothing written). We C append the process id to the filename. C Safer in case all filenames are the C same if all processors share the same C file system. C ----------------------------------------- IF (DO_WRITE_CHECK.EQ.id%NSLAVES .AND. I_AM_SLAVE) THEN WRITE(IDSTR,'(I9)') id%MYID_NODES IF (BINARY_FORMAT) THEN IF (id%KEEP8(29) .EQ. 0_8) THEN C Special case of empty matrix A_PASSED => A_DUMMY IRN_PASSED => IRN_DUMMY JCN_PASSED => JCN_DUMMY C (consider that A is provided when NNZ_loc=0) IS_A_PROVIDED = 1 ELSE IF (associated(id%A_loc)) THEN A_PASSED=>id%A_loc IRN_PASSED => id%IRN_loc JCN_PASSED => id%JCN_loc IS_A_PROVIDED = 1 ELSE A_PASSED => A_DUMMY IRN_PASSED => id%IRN_loc JCN_PASSED => id%JCN_loc IS_A_PROVIDED = 0 ENDIF CALL MPI_ALLREDUCE( IS_A_PROVIDED, & IS_A_PROVIDED_GLOB, 1, & MPI_INTEGER, MPI_PROD, id%COMM_NODES, IERR ) C IS_A_PROVIDED_GLOB = 1 => dump numerical values C IS_A_PROVIDED_GLOB = 0 => some processes did not provide C numerical values, dump only pattern, C and indicate this in the header IF ( id%MYID_NODES.EQ.0) THEN C Print header on first MPI worker (only one global header C file in case of distributed matrix), replacing the .bin C extension by a .header extension OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' ) CALL ZMUMPS_DUMP_HEADER( IUNIT, id%N, & IS_A_PROVIDED_GLOB, id%KEEP(50), IS_DISTRIBUTED, & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) ) CLOSE( IUNIT ) ENDIF CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(29), & id%KEEP(35), & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1), & IS_A_PROVIDED_GLOB, & trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))//char(0) ) ELSE OPEN(IUNIT, & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))) CALL ZMUMPS_DUMP_MATRIX(id, & IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! =.TRUE., distributed & IS_ELEMENTAL, ! Elemental or not & .FALSE.) CLOSE(IUNIT) ENDIF ENDIF C ELSE ... C Nothing written in other cases. ENDIF C =============== C Right-hand side C =============== IF ( DUMP_RHS ) THEN IF (BINARY_FORMAT) THEN C dump RHS in binary format CALL MUMPS_DUMPRHSBINARY_C( id%N, id%NRHS, id%LRHS, id%RHS(1), & id%KEEP(35), & trim(id%WRITE_PROBLEM)//'.rhs'//char(0) ) ELSE C dump RHS in matrix-market format OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM) //".rhs") CALL ZMUMPS_DUMP_RHS(IUNIT, id) CLOSE(IUNIT) ENDIF ENDIF IF ( DUMP_BLKPTR ) THEN IF (BINARY_FORMAT) THEN ! suppress trailing '.bin' and use '.blkptr' OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkptr' ) ELSE ! just append '.blkptr' OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkptr") ENDIF WRITE(IUNIT,'(I9)') id%NBLK DO I=1,id%NBLK+1 WRITE(IUNIT,'(I9)') id%BLKPTR(I) ENDDO CLOSE(IUNIT) ENDIF IF ( DUMP_BLKVAR ) THEN IF (BINARY_FORMAT) THEN ! suppress trailing '.bin' and use '.blkvar' OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkvar' ) ELSE ! just append '.blkvar' OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkvar") ENDIF DO I=1,id%N WRITE(IUNIT,'(I9)') id%BLKVAR(I) ENDDO CLOSE(IUNIT) ENDIF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_DUMP_PROBLEM SUBROUTINE ZMUMPS_DUMP_HEADER( IUNIT, N, IS_A_PROVIDED_GLOB, & SYM, IS_DISTRIBUTED, NSLAVES, NNZTOT, DUMP_RHS, NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, NBLK, ICNTL15 ) C C Purpose: C ======= C C Write a small header file, similar to matrix-market headers, C to accompany a matrix written in binary format. C INTEGER, INTENT(IN) :: IUNIT, N, IS_A_PROVIDED_GLOB , SYM, NSLAVES INTEGER(8), INTENT(IN) :: NNZTOT LOGICAL, INTENT(IN) :: IS_DISTRIBUTED, DUMP_RHS INTEGER, INTENT(IN) :: NRHS LOGICAL, INTENT(IN) :: DUMP_BLKPTR, DUMP_BLKVAR INTEGER, INTENT(IN) :: NBLK INTEGER, INTENT(IN) :: ICNTL15 C C Local declarations: C ================== C CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH C 1/ write a line identical to first line of matrix-market header IF ( IS_A_PROVIDED_GLOB .EQ. 1 ) THEN ARITH='complex' ELSE ARITH='pattern' ENDIF IF (SYM .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) C 2/ indicate if matrix is distributed or centralized, C then describe binary file content and format IF ( IS_DISTRIBUTED ) THEN WRITE(IUNIT,FMT='(A,I5,A)') & '% Matrix is distributed (MPI ranks=',NSLAVES,')' ELSE WRITE(IUNIT,FMT='(A)') & '% Matrix is centralized' ENDIF WRITE(IUNIT,FMT='(A)') & '% Unformatted stream IO (no record boundaries):' IF (ARITH(1:7).EQ.'pattern') THEN IF (IS_DISTRIBUTED) THEN WRITE(IUNIT,'(A)') & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc)' ELSE WRITE(IUNIT,'(A)') & '% N,NNZ,IRN(1:NNZ),JCN(1:NNZ)' ENDIF WRITE(IUNIT,'(A)') '% (numerical values not provided)' ELSE IF (IS_DISTRIBUTED) THEN WRITE(IUNIT,'(A)') & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc),'// & 'A_loc(1:NNZ_loc)' ELSE WRITE(IUNIT,'(A)') '% N/NNZ/IRN(1:NNZ),JCN(1:NNZ),A(1:NNZ)' ENDIF WRITE(IUNIT,'(A)') '% Double complex storage' ENDIF IF ( IS_DISTRIBUTED ) THEN WRITE(IUNIT,'(A,/,A)') & '% N,IRN_loc(i),JCN_loc(i): 32 bits', & '% NNZ_loc: 64 bits' ELSE WRITE(IUNIT,'(A,/,A)') & '% N,IRN(i),JCN(i): 32 bits', & '% NNZ: 64 bits' ENDIF WRITE(IUNIT,FMT='(A,I16)') '% Matrix order: N=',N WRITE(IUNIT,FMT='(A,I16)') '% Matrix nonzeros: NNZ=',NNZTOT IF (DUMP_RHS) THEN WRITE(IUNIT,FMT='(A)') '%' WRITE(IUNIT,FMT='(A,/,A,I10,A,I5)') & '% A RHS was also written to disk by columns in binary form.', & '% Size: N rows x NRHS columns with N=',N,' NRHS=',NRHS WRITE(IUNIT,FMT='(A,I16,A)') & '% Total:',int(N,8)*int(NRHS,8),' scalar values.' WRITE(IUNIT,'(A)') '% Double complex storage' ENDIF IF (DUMP_BLKPTR) THEN WRITE(IUNIT,FMT='(A)') '%' WRITE(IUNIT,'(A,I9,A)') '% Matrix has a block format with', & NBLK,' blocks' WRITE(IUNIT,'(A)') & '% File .blkptr contains NBLK and BLKPTR(1:NBLK+1)' ELSE IF (ICNTL15 .LT. 0) THEN WRITE(IUNIT,FMT='(A)') '%' WRITE(IUNIT,'(A,I9,A)') & '% Matrix has a block format with ICNTL15=',ICNTL15 ENDIF IF (DUMP_BLKVAR) THEN WRITE(IUNIT,'(A)') & '% File .blkvar contains BLKVAR (N integers)' ELSE IF (ICNTL15 .NE. 0) THEN WRITE(IUNIT,'(A)') & '% (BLKVAR considered to be identity is not written)' ENDIF RETURN END SUBROUTINE ZMUMPS_DUMP_HEADER SUBROUTINE ZMUMPS_DUMP_MATRIX & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, IS_ELEMENTAL, PATTERN_ONLY ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C This subroutine dumps a routine in matrix-market format C if the matrix is assembled, and in "MUMPS" format (see C example in the MUMPS users'guide, if the matrix is C centralized and elemental). C The routine can be called on all processors. In case of C distributed assembled matrix, each processor writes its C share as a matrix market file on IUNIT (IUNIT may have C different values on different processors). C C C C Arguments (input parameters) C ============================ C C IUNIT: should be set to the Fortran unit where C data should be written. C I_AM_SLAVE: .TRUE. except on a non working master C IS_DISTRIBUTED: .TRUE. if matrix is distributed, C i.e., if IRN_loc/JCN_loc are provided. C IS_ELEMENTAL : .TRUE. if matrix is elemental C id : main MUMPS structure C LOGICAL, intent(in) :: I_AM_SLAVE, & I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL, & PATTERN_ONLY INTEGER, intent(in) :: IUNIT TYPE(ZMUMPS_STRUC), intent(in) :: id C C Local variables: C =============== C CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH INTEGER(8) :: I8, NNZ_i C C Executable statements: C ===================== IF (I_AM_MASTER .AND. .NOT. IS_DISTRIBUTED .AND. & .NOT. IS_ELEMENTAL) THEN C ================== C CENTRALIZED MATRIX C ================== IF (id%KEEP8(28) .EQ. 0_8) THEN CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ, id%NZ, NNZ_i) ELSE NNZ_i=id%KEEP8(28) ENDIF IF ((associated(id%A)).AND.(.NOT.PATTERN_ONLY)) THEN C Write header line: ARITH='complex' ELSE ARITH='pattern ' ENDIF IF (id%KEEP(50) .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) WRITE(IUNIT,*) id%N, id%N, NNZ_i IF ((associated(id%A)).AND.(.NOT.PATTERN_ONLY)) THEN DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. id%IRN(I8).LT.id%JCN(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8), & dble(id%A(I8)), aimag(id%A(I8)) ELSE WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8), & dble(id%A(I8)), aimag(id%A(I8)) ENDIF ENDDO ELSE C pattern only DO I8=1_8,id%KEEP8(28) IF (id%KEEP(50).NE.0 .AND. id%IRN(I8).LT.id%JCN(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8) ELSE WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8) ENDIF ENDDO ENDIF ELSE IF ( IS_DISTRIBUTED .AND. I_AM_SLAVE ) THEN C ================== C DISTRIBUTED MATRIX C ================== IF (id%KEEP8(29) .EQ. 0_8) THEN CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ_loc, id%NZ_loc, NNZ_i) ELSE NNZ_i=id%KEEP8(29) ENDIF IF ((associated(id%A_loc)).AND.(.NOT.PATTERN_ONLY)) THEN ARITH='complex' ELSE ARITH='pattern ' ENDIF IF (id%KEEP(50) .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) WRITE(IUNIT,*) id%N, id%N, NNZ_i IF ((associated(id%A_loc)).AND.(.NOT.PATTERN_ONLY)) THEN DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I8).LT.id%JCN_loc(I8)) THEN WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8), & dble(id%A_loc(I8)), aimag(id%A_loc(I8)) ELSE WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8), & dble(id%A_loc(I8)), aimag(id%A_loc(I8)) ENDIF ENDDO ELSE DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I8).LT.id%JCN_loc(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8) ELSE WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8) ENDIF ENDDO ENDIF ELSE IF (IS_ELEMENTAL .AND. I_AM_MASTER) THEN C ================== C ELEMENTAL MATRIX C ================== WRITE(IUNIT,*) id%N," :: N" WRITE(IUNIT,*) id%NELT," :: NELT" WRITE(IUNIT,*) size(id%ELTVAR)," :: NELTVAR" WRITE(IUNIT,*) size(id%A_ELT)," :: NELTVL" WRITE(IUNIT,*) id%ELTPTR(:)," ::ELTPTR" WRITE(IUNIT,*) id%ELTVAR(:)," ::ELTVAR" IF(.NOT.PATTERN_ONLY) THEN WRITE(IUNIT,*) id%A_ELT(:) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_DUMP_MATRIX SUBROUTINE ZMUMPS_DUMP_RHS(IUNIT, id) C C Purpose: C ======= C Dumps a dense, centralized, C right-hand side in matrix market format on unit C IUNIT. Should be called on the host only. C USE ZMUMPS_STRUC_DEF IMPLICIT NONE C Arguments C ========= TYPE(ZMUMPS_STRUC), intent(in) :: id INTEGER, intent(in) :: IUNIT C C Local variables C =============== C CHARACTER (LEN=8) :: ARITH INTEGER :: I, J INTEGER(8) :: LD_RHS8, K8 C C Executable statements C ===================== C IF (associated(id%RHS)) THEN ARITH='complex' WRITE(IUNIT,'(A,A,A)') '%%MatrixMarket matrix array ', & trim(ARITH), & ' general' WRITE(IUNIT,*) id%N, id%NRHS IF ( id%NRHS .EQ. 1 ) THEN LD_RHS8 = int(id%N,8) ELSE LD_RHS8 = int(id%LRHS,8) ENDIF DO J = 1, id%NRHS DO I = 1, id%N K8=int(J-1,8)*LD_RHS8+int(I,8) WRITE(IUNIT,*) dble(id%RHS(K8)), aimag(id%RHS(K8)) ENDDO ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_DUMP_RHS SUBROUTINE ZMUMPS_BUILD_I_AM_CAND( NSLAVES, K79, & NB_NIV2, MYID_NODES, & CANDIDATES, I_AM_CAND ) IMPLICIT NONE C C Purpose: C ======= C Given a list of candidate processors per node, C returns an array of booleans telling whether the C processor is candidate or not for a given node. C C K79 holds splitting strategy (KEEP(79)). If K79>1 then C TPYE4,5,6 nodes might have been introduced and C in this case "hidden" slaves should be taken C into account to enable dynamic redistribution C of the hidden slaves while climbing the chain of C split nodes. The master of the first node in the C chain requires a special treatment and is thus here C not considered as a slave. C INTEGER, intent(in) :: NSLAVES, NB_NIV2, MYID_NODES, K79 INTEGER, intent(in) :: CANDIDATES( NSLAVES+1, NB_NIV2 ) LOGICAL, intent(out):: I_AM_CAND( NB_NIV2 ) INTEGER I, INIV2, NCAND IF (K79.GT.0) THEN C Because of potential restarting the number of C candidates that will be used to distribute C arrowheads have to include all possible candidates. DO INIV2=1, NB_NIV2 I_AM_CAND(INIV2)=.FALSE. NCAND = CANDIDATES(NSLAVES+1,INIV2) C check if some hidden slaves are there C Note that if hidden candidates exists (type 5 or 6 nodes) then C in position CANDIDATES (NCAND+1,INIV2) must be the master C of the first node in the chain (type 4) that we skip here because C a special treatment (it has to be "considered as a master" for all C nodes in the list) is needed. DO I=1, NSLAVES IF (CANDIDATES(I,INIV2).LT.0) EXIT ! end of extra slaves IF (I.EQ.NCAND+1) CYCLE ! skip master of associated TYPE 4 node IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN I_AM_CAND(INIV2)=.TRUE. EXIT ENDIF ENDDO END DO ELSE DO INIV2=1, NB_NIV2 I_AM_CAND(INIV2)=.FALSE. NCAND = CANDIDATES(NSLAVES+1,INIV2) DO I=1, NCAND IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN I_AM_CAND(INIV2)=.TRUE. EXIT ENDIF ENDDO END DO ENDIF RETURN END SUBROUTINE ZMUMPS_BUILD_I_AM_CAND MUMPS_5.8.1/src/cfac_diag.F0000664000175000017500000000120215042446441015213 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_GETSETDIAGRETURN() C C This file contain code to access/return the C diagonal of a factorized matrix in the future. C RETURN END SUBROUTINE CMUMPS_GETSETDIAGRETURN MUMPS_5.8.1/src/sfac_process_band.F0000664000175000017500000003217415042446437017012 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_PROCESS_DESC_BANDE( MYID, BUFR, LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP,KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, #if ! defined(NO_FDM_DESCBAND) & IWHANDLER_IN, #endif & IFLAG, IERROR ) USE MUMPS_LOAD USE SMUMPS_LR_DATA_M, ONLY: SMUMPS_BLR_INIT_FRONT, & SMUMPS_BLR_SAVE_NFS4FATHER #if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M #endif IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB, N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), & ITLOC( N + KEEP(253) ) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER :: ISTEP_TO_INIV2(KEEP(71)) #if ! defined(NO_FDM_DESCBAND) INTEGER IWHANDLER_IN #endif INTEGER COMP, IFLAG, IERROR INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES INTEGER NSLAVES_HDR, NFRONT INTEGER LREQ INTEGER :: IBUFR INTEGER(8) :: LREQCB #if ! defined(NO_FDM_DESCBAND) INTEGER :: IWHANDLER_LOC #endif DOUBLE PRECISION FLOP1 INCLUDE 'mumps_headers.h' #if ! defined(NO_FDM_DESCBAND) INTEGER :: INFO_TMP(2) #else #endif INTEGER :: LRSTATUS INTEGER :: ESTIM_NFS4FATHER_ATSON LOGICAL :: LR_ACTIVATED, COMPRESS_CB REAL, POINTER, DIMENSION(:) :: DYNAMIC_CB INTEGER(8) :: TMP_ADDRESS INTEGER :: allocok INODE = BUFR( 2 ) NBPROCFILS = BUFR( 3 ) NROW = BUFR( 4 ) NCOL = BUFR( 5 ) NASS = BUFR( 6 ) NFRONT = BUFR( 7 ) NSLAVES_HDR = BUFR( 8 ) NSLAVES = BUFR( 9 ) LRSTATUS = BUFR(10 ) ESTIM_NFS4FATHER_ATSON = BUFR(11) IBUFR = 12 #if ! defined(NO_FDM_DESCBAND) IWHANDLER_LOC = IWHANDLER_IN IF ((IWHANDLER_IN .LE. 0) .AND. & (INODE .NE. INODE_WAITED_FOR)) THEN INFO_TMP=0 CALL MUMPS_FDBD_SAVE_DESCBAND(INODE, BUFR(1), BUFR, & IWHANDLER_LOC, INFO_TMP) IF (INFO_TMP(1) < 0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) RETURN ENDIF GOTO 555 ENDIF #endif IF ( KEEP(50) .eq. 0 ) THEN FLOP1 = dble( NASS * NROW ) + & dble(NROW*NASS)*dble(2*NCOL-NASS-1) ELSE FLOP1 = dble( NASS ) * dble( NROW ) & * dble( 2 * NCOL - NROW - NASS + 1) END IF CALL MUMPS_LOAD_UPDATE(1,.TRUE.,FLOP1, KEEP,KEEP8) IF ( KEEP(50) .eq. 0 ) THEN NSLAVES = NSLAVES_HDR + XTRA_SLAVES_UNSYM ELSE NSLAVES = NSLAVES_HDR + XTRA_SLAVES_SYM END IF LREQ = NROW + NCOL + 6 + NSLAVES + KEEP(IXSZ) LREQCB = int(NCOL,8) * int(NROW,8) IF ( LREQCB .GT. LRLUS .AND. KEEP(101) .EQ. 0 .AND. & KEEP8(73) + LREQCB .LE. KEEP8(75) ) THEN CALL SMUMPS_ALLOC_CB(.FALSE., 0_8, .FALSE.,.TRUE., & MYID,N, KEEP, KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, & LREQ, 0_8, & INODE, S_ACTIVE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN #if defined(MUMPS_ALLOC_FROM_C) || defined(_CRAYFTN) CALL MUMPS_MALLOC_C( TMP_ADDRESS, & LREQCB * int(KEEP(35),8) ) IF (TMP_ADDRESS .EQ. 0_8) THEN allocok=1 ELSE allocok=0 ENDIF #else ALLOCATE(DYNAMIC_CB(LREQCB), stat=allocok) #endif IF (allocok .GT. 0) THEN CALL SMUMPS_FREE_BLOCK_CB_STATIC( .FALSE., MYID, N, & IWPOSCB + 1, IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP, KEEP8, .FALSE. ) ELSE CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( LREQCB, & KEEP(405).EQ.1, & KEEP8, IFLAG, IERROR, & .TRUE., & .FALSE. ) #if ! defined(MUMPS_ALLOC_FROM_C) && ! defined(_CRAYFTN) CALL MUMPS_ADDR_C( DYNAMIC_CB(1), TMP_ADDRESS ) #endif CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXD)) PTRIST(STEP(INODE)) = IWPOSCB + 1 PTRAST(STEP(INODE)) = TMP_ADDRESS ENDIF ENDIF IF ( PTRIST(STEP(INODE)) .EQ. 0 ) THEN CALL SMUMPS_ALLOC_CB(.FALSE., 0_8, .FALSE.,.TRUE., & MYID,N, KEEP, KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, & LREQ, LREQCB, INODE, S_ACTIVE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PTRIST(STEP(INODE)) = IWPOSCB + 1 PTRAST(STEP(INODE)) = IPTRLU + 1_8 ENDIF # if ! defined(NO_FDM_DESCBAND) 555 CONTINUE # endif # if ! defined(NO_FDM_DESCBAND) IF ((IWHANDLER_IN .LE. 0) .AND. & (INODE .NE. INODE_WAITED_FOR)) THEN RETURN ENDIF IW(IWPOSCB+1+XXA) = IWHANDLER_LOC # endif IW(IWPOSCB+1+XXF) = -9999 IW( IWPOSCB + 1+KEEP(IXSZ) ) = NCOL IW( IWPOSCB + 2+KEEP(IXSZ) ) = - NASS IW( IWPOSCB + 3+KEEP(IXSZ) ) = NROW IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 5+KEEP(IXSZ) ) = NASS IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES IW( IWPOSCB + 7+KEEP(IXSZ)+NSLAVES : & IWPOSCB + 6+KEEP(IXSZ)+NSLAVES + NROW + NCOL ) &= BUFR( IBUFR + NSLAVES_HDR : & IBUFR + NSLAVES_HDR + NROW + NCOL - 1 ) IF ( KEEP(50) .eq. 0 ) THEN IW( IWPOSCB + 7+KEEP(IXSZ) ) = S_ROOTBAND_INIT IF (NSLAVES_HDR.GT.0) THEN write(6,*) " Internal error in SMUMPS_PROCESS_DESC_BANDE " CALL MUMPS_ABORT() ENDIF ELSE IW( IWPOSCB+7+KEEP(IXSZ) ) = huge(IW(IWPOSCB+7+KEEP(IXSZ))) IW( IWPOSCB + 8+KEEP(IXSZ) ) = NFRONT IW( IWPOSCB + 9+KEEP(IXSZ) ) = S_ROOTBAND_INIT IW( IWPOSCB + 7+XTRA_SLAVES_SYM+KEEP(IXSZ): & IWPOSCB + 6+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_HDR ) = & BUFR( IBUFR: IBUFR - 1 + NSLAVES_HDR ) END IF IW(IWPOSCB+1+XXNBPR)=NBPROCFILS IW(IWPOSCB+1+XXLR)=LRSTATUS COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP=0 CALL SMUMPS_BLR_INIT_FRONT (IW(IWPOSCB+1+XXF), INFO_TMP) IF (INFO_TMP(1).LT.0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) RETURN ENDIF IF (COMPRESS_CB.AND. & (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & (ESTIM_NFS4FATHER_ATSON.GE.0) & ) THEN CALL SMUMPS_BLR_SAVE_NFS4FATHER ( IW(IWPOSCB+1+XXF), & ESTIM_NFS4FATHER_ATSON ) ENDIF ENDIF IF (NBPROCFILS .EQ. 0) THEN ENDIF RETURN END SUBROUTINE SMUMPS_PROCESS_DESC_BANDE RECURSIVE SUBROUTINE SMUMPS_TREAT_DESCBAND( INODE, & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED & , LRGROUPS & ) # if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M # endif USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER, INTENT(IN) :: INODE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST(KEEP(28)) INTEGER STEP(N), & PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) REAL DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' LOGICAL :: BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: SRC_DESCBAND #if ! defined(NO_FDM_DESCBAND) INTEGER :: IWHANDLER TYPE(DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC #endif INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE SRC_DESCBAND = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) # if ! defined(NO_FDM_DESCBAND) IF (MUMPS_FDBD_IS_DESCBAND_STORED( INODE, IWHANDLER )) THEN CALL MUMPS_FDBD_RETRIEVE_DESCBAND(IWHANDLER, DESCBAND_STRUC) CALL SMUMPS_PROCESS_DESC_BANDE( MYID, DESCBAND_STRUC%BUFR(1), & DESCBAND_STRUC%LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, & IWHANDLER, & IFLAG, IERROR ) IF (IFLAG .LT. 0) GOTO 500 CALL MUMPS_FDBD_FREE_DESCBAND_STRUC(IW(PTRIST(STEP(INODE))+XXA)) ELSE IF (INODE_WAITED_FOR.GT.0) THEN WRITE(*,*) " Internal error 1 in SMUMPS_TREAT_DESCBAND", & INODE, INODE_WAITED_FOR CALL MUMPS_ABORT() ENDIF INODE_WAITED_FOR = INODE # endif DO WHILE (PTRIST(STEP(INODE)) .EQ. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT(COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & SRC_DESCBAND, MAITRE_DESC_BANDE, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (IFLAG .LT. 0) THEN RETURN ENDIF ENDDO # if ! defined(NO_FDM_DESCBAND) INODE_WAITED_FOR = -1 ENDIF # endif RETURN 500 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE SMUMPS_TREAT_DESCBAND MUMPS_5.8.1/src/zfac_front_LU_type2.F0000664000175000017500000011632115042446441017222 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC2_LU_M CONTAINS SUBROUTINE ZMUMPS_FAC2_LU( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP,PIVNUL_LIST_STRUCT & , LRGROUPS & ) !$ USE OMP_LIB USE ZMUMPS_FAC_FRONT_AUX_M USE ZMUMPS_FAC_FRONT_TYPE2_AUX_M USE ZMUMPS_OOC USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_TEST USE ZMUMPS_FAC_LR USE ZMUMPS_LR_CORE USE ZMUMPS_LR_TYPE USE MUMPS_LR_STATS USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_DATA_M !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW INTEGER, intent(inout) :: NOFFW, NPVW, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW INTEGER(8) :: LA INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) DOUBLE PRECISION UU, SEUIL TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) INTEGER NBFIN, SLAVEF, & IFLAG, IERROR, LEAF, LPOOL INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N), & PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL AVOID_DELAYED TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER :: IBEG_BLOCK_FOR_IPIV INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv LOGICAL LASTPANEL INTEGER(8) :: POSELT INTEGER IOLDPS, allocok, K263,J INTEGER idummy DOUBLE PRECISION UUTEMP LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER CURRENT_BLR, NELIM LOGICAL LR_ACTIVATED, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER :: IROW_L, NVSCHUR, NSLAVES INTEGER :: PIVOT_OPTION, LAST_COL, FIRST_COL INTEGER :: PARPIV_T1 INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER :: INFO_TMP(2) INTEGER :: MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR, END_I INTEGER MAXI_CLUSTER, LWORK TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_U, BLR_SEND COMPLEX(kind=8), POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP, BEGS_BLR_STATIC INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, LorU, I, IP, MEM, & MEM_TOT INTEGER(8) :: POSELT_DIAG CHARACTER(len=1) :: DIR COMPLEX(kind=8), ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) COMPLEX(kind=8), ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER(8) :: UPOS, LPOS INTEGER :: MY_NUM LOGICAL :: SWAP_OCCURRED INCLUDE 'mumps_headers.h' NULLIFY(BLR_L,BLR_U) NULLIFY(PTDummy) NULLIFY(ACC_LUA) NULLIFY(BEGS_BLR) NULLIFY(BLR_L, BLR_U, BLR_SEND) NULLIFY(DIAG) NULLIFY(BLR_PANEL) NULLIFY( BEGS_BLR_TMP, BEGS_BLR_STATIC) IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF SWAP_OCCURRED = .FALSE. idummy = 0 IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) NASS = abs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) PARPIV_T1 = 0 INOPV = 0 SEUIL_LOC = SEUIL IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE UUTEMP=UU ENDIF CALL ZMUMPS_SET_INNERBLOCKSIZE( NBKJIB_ORIG, NASS, KEEP) IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN NSLAVES = IW(IOLDPS+5+XSIZE) IROW_L = IOLDPS+6+XSIZE+NSLAVES+NASS CALL ZMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IF (LR_ACTIVATED) THEN K263 = 1 ELSE K263 = KEEP(263) IF (K263 .NE. 0 .AND. NASS/NBLR_ORIG < 4) THEN IF ( NBLR_ORIG .GT. NBKJIB_ORIG * 4 ) THEN NBLR_ORIG = max(NBKJIB_ORIG, (NASS+3)/4) ELSE K263 = 0 ENDIF ENDIF ENDIF PIVOT_OPTION = KEEP(468) IF ( UUTEMP == 0.0D0 .AND. & .NOT.( & OOC_EFFECTIVE_ON_FRONT & ) & ) THEN IF (K263.EQ.1.AND.(.NOT.LR_ACTIVATED)) THEN PIVOT_OPTION = 0 ENDIF ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID,' : ZMUMPS_FAC2_LU :failed to allocate ', & NASS, ' integers' IFLAG = -13 IERROR =NASS GO TO 500 END IF CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF ( OOC_EFFECTIVE_ON_FRONT ) THEN LNextPiv2beWritten = 1 UNextPiv2beWritten = 1 PP_FIRST2SWAP_L = LNextPiv2beWritten PP_FIRST2SWAP_U = UNextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%LastPanelWritten_U = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 2 MonBloc%NROW = NASS MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -68877 NULLIFY(MonBloc%INDICES) ENDIF IF (LR_ACTIVATED) THEN PIVOT_OPTION = 4 IF (KEEP(475).EQ.1) THEN PIVOT_OPTION = 3 ELSEIF (KEEP(475).EQ.2) THEN PIVOT_OPTION = 3 ELSEIF (KEEP(475).EQ.3) THEN IF (UUTEMP == 0.0D0) THEN PIVOT_OPTION = 0 ELSE PIVOT_OPTION = 1 ENDIF ENDIF CNT_NODES = CNT_NODES + 1 ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472), & NFRONT, KEEP(1)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) & ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL ZMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 CALL ZMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .TRUE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF LASTPANEL = .FALSE. DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = BEGS_BLR(CURRENT_BLR+1)-1 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 500 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (K263.EQ.0) THEN IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK ELSE IBEG_BLOCK_FOR_IPIV = IBEG_BLR ENDIF CALL ZMUMPS_FAC_I(NFRONT,NASS,NASS, & IBEG_BLOCK_FOR_IPIV,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, & DKEEP(1), PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, & TIPIV=IPIV & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTPANEL = .TRUE. ELSE IF (INOPV .LE. 0) THEN INOPV = 0 IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL ZMUMPS_FAC_MQ(IBEG_BLOCK, IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 NPVW = NPVW + 1 IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB .EQ. -1) THEN LASTPANEL = .TRUE. ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF (K263.EQ.0) THEN NELIM = IEND_BLR - NPIV CALL ZMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, & NFRONT, IBEG_BLOCK, NPIV, IPIV,NASS,LASTPANEL,idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR, ICNTL,KEEP,KEEP8, & DKEEP,ND,FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, .FALSE. & , NPARTSASS, CURRENT_BLR & , BLR_DUMMY, LRGROUPS & ) END IF IF ( IFLAG .LT. 0 ) GOTO 500 IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_U, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN CALL MUMPS_BUF_TEST() IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL ZMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, & NPIV, NFRONT, IEND_BLR, LAST_COL, & A, LA, POSELT, & -77777, & .TRUE., .FALSE., .TRUE., & .FALSE., & LR_ACTIVATED) ENDIF CALL MUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 500 ENDIF ALLOCATE(BLR_L(NPARTSASS-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSASS-CURRENT_BLR GOTO 500 ENDIF NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_U(J)%M=0 BLR_U(J)%N=0 BLR_U(J)%K=0 BLR_U(J)%ISLR=.FALSE. NULLIFY(BLR_U(J)%Q) NULLIFY(BLR_U(J)%R) ENDDO CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) DO J=1,NPARTSASS-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF GOTO 101 ENDIF END_I=NB_BLR #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), & KEEP(458), KEEP(473), BLR_U, & CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, 2, KEEP(483), KEEP8, & END_I_IN=END_I & ) IF (IFLAG.LT.0) GOTO 300 IF ((KEEP(480).NE.0.AND.NB_BLR.GT.CURRENT_BLR) & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (PIVOT_OPTION.LT.3) THEN IF (PIVOT_OPTION.LT.2) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF LAST_BLOCK=NB_BLR CALL ZMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_U, CURRENT_BLR, & FIRST_BLOCK, LAST_BLOCK, 2, 0, 1, & .FALSE.) ENDIF 300 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif ENDIF 101 CONTINUE IF (LR_ACTIVATED .OR. (K263.NE.0.AND.PIVOT_OPTION.GE.3)) THEN NELIM = IEND_BLR - NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_U)) THEN BLR_SEND=>BLR_U ENDIF CALL ZMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, NFRONT, & IBEG_BLR, NPIV, IPIV, NASS,LASTPANEL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR & , BLR_SEND, LRGROUPS & ) ENDIF IF (.NOT. LR_ACTIVATED) THEN LAST_COL = NFRONT IF (PIVOT_OPTION.EQ.2) THEN FIRST_COL = NASS ELSE FIRST_COL = NPIV ENDIF IF (IEND_BLR.LT.NASS .OR. PIVOT_OPTION.LT.3) THEN CALL ZMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, LAST_COL, & A, LA, POSELT, FIRST_COL, .TRUE., (PIVOT_OPTION.LT.3), & .TRUE., (KEEP(377).EQ.1), & LR_ACTIVATED) ENDIF IF (K263.NE.0 .AND. PIVOT_OPTION.LT.3) THEN NELIM = IEND_BLR - NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_U)) THEN BLR_SEND=>BLR_U ENDIF CALL ZMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, & NFRONT, IBEG_BLR, NPIV, IPIV, NASS,LASTPANEL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR & , BLR_SEND, LRGROUPS & ) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL ZMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8 & ) IF (IFLAG.LT.0) GOTO 600 CALL ZMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8, & END_I_IN=END_I & ) 600 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF ENDIF GOTO 100 ENDIF IF (KEEP(475).EQ.0) THEN IF (IEND_BLR.LT.NFRONT) THEN CALL ZMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & -77777, & A, LA, POSELT, & -77777, & .TRUE., .FALSE., .FALSE., & .FALSE., & LR_ACTIVATED) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(UPOS,LPOS,FIRST_BLOCK,LAST_BLOCK) #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NPARTSASS, DKEEP(8), KEEP(466), & KEEP(458), KEEP(473), & BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8 & ) #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF ((KEEP(480).NE.0.AND.NB_BLR.GT.CURRENT_BLR) & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(475).GT.0) THEN CALL ZMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NPARTSASS, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NPARTSASS, 2, 0, 0, .FALSE.) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF IF (KEEP(480).GE.2) THEN UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) LPOS = POSELT+int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) CALL ZMUMPS_BLR_UPD_NELIM_VAR_L(A, LA, UPOS, A, LA, LPOS, & IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NPARTSASS, & CURRENT_BLR+1, NELIM, 'N') IF (IFLAG.LT.0) GOTO 444 IF (IEND_BLR.LT.NASS) THEN CALL ZMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8 & ) IF (IFLAG.LT.0) GOTO 442 CALL ZMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8, & END_I_IN=END_I & ) 442 CONTINUE ENDIF 444 CONTINUE ELSE CALL ZMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, BLR_L, NPARTSASS, & BLR_U, NB_BLR, NELIM, .FALSE., 0, & 2, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(475).GT.0) THEN FIRST_BLOCK = CURRENT_BLR+1 IF (KEEP(486).EQ.2.AND.UU.EQ.0) THEN LAST_BLOCK = CURRENT_BLR ELSE LAST_BLOCK = NPARTSASS ENDIF CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NPARTSASS, BLR_L, CURRENT_BLR, 'V', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) #if ! defined(BLR_NOOPENMP) #endif ENDIF IF (KEEP(475).GE.2) THEN IF (KEEP(475).EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF IF (KEEP(486).NE.2) THEN LAST_BLOCK = END_I ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_U, CURRENT_BLR, 'H', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0.OR.NB_BLR.EQ.CURRENT_BLR) THEN CALL DEALLOC_BLR_PANEL(BLR_U, NB_BLR-CURRENT_BLR, & KEEP8, KEEP(34)) CALL DEALLOC_BLR_PANEL(BLR_L, NPARTSASS-CURRENT_BLR, & KEEP8, KEEP(34)) DEALLOCATE(BLR_U,BLR_L) ENDIF ENDIF NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_TRY_WRITE MonBloc%LastPiv = NPIV LAST_CALL= .FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO IP=1,NB_BLR+1 BEGS_BLR_TMP(IP) = BEGS_BLR_STATIC(IP) ENDDO ENDIF ENDIF IF ( & (KEEP(486).EQ.2) & ) THEN MEM_TOT = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP& PRIVATE(IP, LorU, DIR, NELIM) #endif #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*(2*DIAGSIZ_STA-DIAGSIZ_DYN) MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA IF (I.LE.DIAGSIZ_DYN) THEN DIAG(DPOS:DPOS+DIAGSIZ_STA-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_STA-1,8)) DPOS = DPOS + DIAGSIZ_STA ELSE DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN ENDIF POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL ZMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG, KEEP(34)) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO !$OMP SINGLE #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM_TOT,8), & .FALSE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 460 IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN DO IP=1,NPARTSASS NELIM = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) DO LorU=0,1 #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8, & KEEP(34)) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (LorU.EQ.0) THEN DIR = 'V' ELSE DIR = 'H' ENDIF CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(458), KEEP(473), & BLR_PANEL, IP, & DIR, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 440 ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif 440 CONTINUE ENDIF 460 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN deallocate(BEGS_BLR_TMP) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 500 IF ( & (KEEP(486).EQ.2) & ) THEN CALL ZMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (IFLAG.GE.0) THEN CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 0, NELIM) DO IP=1,NPARTSASS CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NPARTSASS-IP & ) CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 1, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NB_BLR-IP & ) ENDDO CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NASS-NELIM, 0, 2) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 0, 2) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 500 IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF CALL ZMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 700 480 CONTINUE 500 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 700 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL ZMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 2, & KEEP8, KEEP(34)) ENDIF ENDIF IF ( LR_ACTIVATED .AND. KEEP(486).EQ. 2 .AND. & KEEP(251) .EQ. 2) THEN CALL ZMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8, KEEP(34)) ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL ZMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34)) ENDIF ENDIF DEALLOCATE( IPIV ) RETURN END SUBROUTINE ZMUMPS_FAC2_LU END MODULE ZMUMPS_FAC2_LU_M MUMPS_5.8.1/src/cfac_dist_arrowheads_omp.F0000664000175000017500000015102415042446440020353 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if ! defined(PCPRET) SUBROUTINE CMUMPS_FAC_DIST_ARROWHEADS_OMP ( & N, NZ_loc8, & A_loc, IRN_loc, JCN_loc, & SIZESCAL, LSCAL, COLSCA, ROWSCA, & DBLARR, LDBLARR, INTARR, LINTARR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & FILS, KEEP,KEEP8, MYID, COMM, NBRECORDS, & & S, LA, root, roota, PROCNODE_STEPS, NPROCS, SLAVEF, PERM, STEP, & ICNTL, INFO, NSEND8, NLOCAL8, & ISTEP_TO_INIV2, CANDIDATES & ) !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZESCAL LOGICAL, INTENT(IN) :: LSCAL INTEGER(8), INTENT(IN) :: NZ_loc8 INTEGER, INTENT(IN) :: IRN_LOC(max(1_8,NZ_loc8)), & JCN_LOC(max(1_8,NZ_loc8)) COMPLEX, INTENT(IN) :: A_loc(max(1_8,NZ_loc8)) REAL, INTENT(IN) :: ROWSCA(SIZESCAL), & COLSCA(SIZESCAL) INTEGER(8), INTENT(IN) :: LDBLARR, LINTARR COMPLEX, INTENT(OUT) :: DBLARR( LDBLARR ) INTEGER, INTENT(OUT) :: INTARR( LINTARR ) INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER(8), INTENT(INOUT):: KEEP8(150) INTEGER, INTENT(IN) :: FILS( N ) INTEGER, INTENT(IN) :: MYID, COMM, NBRECORDS INTEGER(8), INTENT(IN) :: LA INTEGER, INTENT(IN) :: NPROCS, SLAVEF INTEGER(8), INTENT(OUT):: NSEND8, NLOCAL8 INTEGER, INTENT(IN) :: ISTEP_TO_INIV2(KEEP(71)) INTEGER, INTENT(IN) :: CANDIDATES(SLAVEF+1, max(1,KEEP(56))) COMPLEX, INTENT(INOUT) :: S( LA ) TYPE (MUMPS_ROOT_STRUC), INTENT(INOUT) :: root TYPE (CMUMPS_ROOT_STRUC), INTENT(INOUT) :: roota INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), & PERM( N ), STEP( N ) INTEGER, INTENT(INOUT) :: INFO( 80 ) INTEGER, INTENT(IN) :: ICNTL(60) INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: PTRAW INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFSENDI COMPLEX, ALLOCATABLE, DIMENSION(:,:,:) :: BUFSENDR INTEGER, ALLOCATABLE, DIMENSION(:,:) :: BUFSEND_POSRESERVED INTEGER, ALLOCATABLE, DIMENSION(:,:) :: BUFRECVI COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: BUFRECVR INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, ISENDREQI, ISENDREQR LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE INTEGER, ALLOCATABLE, DIMENSION(:) :: IRECVREQI, IRECVREQR INTEGER, ALLOCATABLE, DIMENSION(:):: RECV_BUF_STATUS INTEGER, PARAMETER :: Processed_IrecNeeded = 1 INTEGER, PARAMETER :: IrecPosted = 2 INTEGER, PARAMETER :: Received_NotProcessed = 3 INTEGER, PARAMETER :: Processed_IrecNotneeded = 4 INTEGER, PARAMETER :: Treating = 5 INTEGER, PARAMETER :: BeingTreatednotbyme = 6 INTEGER(8) :: ILOC8 INTEGER :: EndNZloc, NB_END_MSG_2_RECV LOGICAL :: MPI_End_Send, End_TreatRecvBuf, MPI_InvolvedinSend, & MPI_InvolvedinRecv, TH_InvolvedinComm, & NO_ATOMIC_Wsendbuf, NO_ATOMIC_Warrow, FINISHED, & TH_InvolvedinArrange, TH_InvolvedinTreatRecv INTEGER(8) :: PTR_ROOT INTEGER :: LOCAL_M, LOCAL_N, ARROW_ROOT LOGICAL :: EARLYT3ROOTINS LOGICAL :: I_AM_SLAVE, OneMPI INTEGER :: IARR1, IORG, NOMP, NOMP_MAX INTEGER :: ISTEP, ISLAVE_MAIN, IMAIN, JMAIN INTEGER :: allocok LOGICAL :: OMP_FLAG INTEGER(8) :: IS8MAIN INTEGER :: TYPE_NODE_P, MASTER_NODE_P, NBJ_P INTEGER(8) :: IS8_P INTEGER :: LP, MP LOGICAL :: LPOK, PROK INTEGER(8) :: NB_RANGE_8 INTEGER :: SHIFT_PID INTEGER :: NOMP_SHARED LOGICAL :: NOTHINGTOARRANGE_P INTEGER :: IOMP, NB_RANGE_P, EndNZloc_P LOGICAL :: ThWorking INTEGER(8) :: ILOC8_P INTEGER :: NBRECORDS_LOC INTEGER, PARAMETER :: MPI_MASTER = 0 NSEND8 = 0_8 NLOCAL8 = 0_8 LP = ICNTL(1) MP = ICNTL(2) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) NB_RANGE_8 = int(max(NBRECORDS/10, 1), 8) IF (KEEP(46).EQ.0) THEN SHIFT_PID = 1 ELSE SHIFT_PID = 0 ENDIF I_AM_SLAVE = (MYID.NE.0.OR.KEEP(46).EQ.1) OneMPI = NPROCS.EQ.1 IF (OneMPI) THEN NBRECORDS_LOC = 1 ELSE NBRECORDS_LOC = NBRECORDS ENDIF IF ( OneMPI.OR. & (KEEP(54).EQ.0.AND.(MYID.NE.MPI_MASTER)) & ) THEN MPI_InvolvedinSend = .FALSE. MPI_End_Send = .TRUE. ELSE MPI_InvolvedinSend = .TRUE. MPI_End_Send = .FALSE. ENDIF ALLOCATE( & BUFSENDI(NBRECORDS_LOC * 2 + 1, 2, NPROCS), & BUFSENDR(NBRECORDS_LOC, 2, NPROCS), & IACT(NPROCS), SEND_ACTIVE(NPROCS), & ISENDREQI(NPROCS), ISENDREQR(NPROCS), & BUFSEND_POSRESERVED(2, NPROCS), & stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LPOK ) THEN WRITE(LP,*) & '** Error allocating SEND buffers for matrix distribution' END IF INFO(1) = -13 INFO(2) = ( NBRECORDS_LOC * 2 + 1 ) * NPROCS * 2 + & NBRECORDS_LOC * NPROCS * 2 + & NPROCS*6 GOTO 20 END IF IF (.NOT.OneMPI) THEN DO ISLAVE_MAIN=1, NPROCS IACT (ISLAVE_MAIN) = 1 ISENDREQI(ISLAVE_MAIN) = MPI_REQUEST_NULL ISENDREQR(ISLAVE_MAIN) = MPI_REQUEST_NULL BUFSENDI(1, 1, ISLAVE_MAIN) = 0 BUFSEND_POSRESERVED(1,ISLAVE_MAIN)= 0 BUFSENDI(1, 2, ISLAVE_MAIN) = NBRECORDS_LOC BUFSEND_POSRESERVED(2,ISLAVE_MAIN)= NBRECORDS_LOC SEND_ACTIVE(ISLAVE_MAIN) = .FALSE. ENDDO ENDIF IF (OneMPI.OR. & (KEEP(54).EQ.0.AND.(MYID.EQ.MPI_MASTER)) & ) THEN NB_END_MSG_2_RECV = 0 MPI_InvolvedinRecv = .FALSE. End_TreatRecvBuf = .TRUE. ELSE IF (KEEP(54).EQ.0.AND.MYID.NE.MPI_MASTER) THEN NB_END_MSG_2_RECV = 1 MPI_InvolvedinRecv = .TRUE. End_TreatRecvBuf = .FALSE. ELSE NB_END_MSG_2_RECV = NPROCS-1 MPI_InvolvedinRecv = .TRUE. End_TreatRecvBuf = .FALSE. ENDIF ALLOCATE( & BUFRECVI(NBRECORDS_LOC * 2 + 1, NPROCS), & BUFRECVR(NBRECORDS_LOC, NPROCS), & IRECVREQI(NPROCS), IRECVREQR(NPROCS), & RECV_BUF_STATUS(NPROCS), & stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LPOK ) THEN WRITE(LP,*) & '** Error allocating RECV buffers for matrix distribution' END IF INFO(1) = -13 INFO(2) = ( NBRECORDS_LOC * 2 + 1 ) * NPROCS + & NBRECORDS_LOC * NPROCS + & NPROCS*3 GOTO 20 ENDIF IF (.NOT.OneMPI) THEN BUFRECVI(1, 1:NPROCS) = 0 IRECVREQI(1:NPROCS) = MPI_REQUEST_NULL IRECVREQR(1:NPROCS) = MPI_REQUEST_NULL RECV_BUF_STATUS (1:NPROCS)= Processed_IrecNeeded RECV_BUF_STATUS (MYID+1) = Processed_IrecNotneeded IF (KEEP(54).EQ.0) THEN DO ISLAVE_MAIN=1, NPROCS RECV_BUF_STATUS (ISLAVE_MAIN)= Processed_IrecNotneeded ENDDO IF (MYID.NE.MPI_MASTER) THEN RECV_BUF_STATUS(MPI_MASTER+1) = Processed_IrecNeeded ENDIF ENDIF ENDIF ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8) * 2_8, INFO(2) ) GOTO 20 END IF ALLOCATE( PTRAW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8) * KEEP(10), INFO(2) ) GOTO 20 END IF 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 100 ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) IF (I_AM_SLAVE) THEN DO JMAIN = 1, N ISTEP=STEP(JMAIN) IF (ISTEP .GT. 0) THEN IARR1 = PTRDEBARR( ISTEP ) IF ( IARR1 .GT. 0 ) THEN IMAIN = JMAIN IORG = 0 DO WHILE ( IMAIN .GT. 0 ) IORG = IORG + 1 IW4(IMAIN, 1) = NINCOLARR( IARR1 + IORG - 1 ) IW4(IMAIN, 2) = NINROWARR( IARR1 + IORG - 1 ) + & NINCOLARR( IARR1 + IORG - 1 ) IS8MAIN = PTR8ARR( IARR1 + IORG - 1 ) PTRAW( IMAIN ) = IS8MAIN INTARR( IS8MAIN ) = IMAIN DBLARR( IS8MAIN ) = ZERO IMAIN = FILS(IMAIN) ENDDO ENDIF ENDIF ENDDO IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL CMUMPS_GET_ROOT_INFO(root, LOCAL_M, & LOCAL_N, PTR_ROOT, LA) CALL CMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, S, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 ENDIF NOMP=1 !$ NOMP=omp_get_max_threads() NOMP_MAX = NOMP IF (NOMP_MAX.GT.2.AND.KEEP(399).EQ.2) THEN IF (.NOT.OneMPI) THEN NOMP_MAX = 2 ENDIF ENDIF IF (NOMP_MAX.GT.3.AND.KEEP(399).EQ.3) THEN IF (.NOT.OneMPI) THEN NOMP_MAX = 3 ENDIF ENDIF ILOC8 = 1_8 OMP_FLAG = ((NOMP .GE.2).AND.(KEEP(399).NE.99)) FINISHED = .FALSE. NOMP_SHARED = 1 !$OMP PARALLEL !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& PRIVATE( !$OMP& IOMP, ThWorking, ILOC8_P, NB_RANGE_P, !$OMP& NOTHINGTOARRANGE_P, EndNZloc_P, TH_InvolvedinComm, !$OMP& TH_InvolvedinTreatRecv, TH_InvolvedinArrange ) !$OMP& REDUCTION(+:NSEND8, NLOCAL8, ARROW_ROOT) !$OMP& IF (OMP_FLAG) IOMP = 0 !$ IOMP=omp_get_thread_num() !$OMP SINGLE !$ NOMP_SHARED= omp_get_num_threads() IF (OneMPI) THEN EndNZloc = NOMP_SHARED ELSE EndNZloc = max(1,NOMP_SHARED -1) IF ( KEEP(399).EQ.2.OR.KEEP(399).EQ.3 ) THEN EndNZloc = min(EndNZloc,1) ENDIF ENDIF IF (NZ_loc8.EQ.0_8) EndNZloc = 0 IF (.NOT.MPI_InvolvedinSend.AND.(EndNZloc.EQ.0)) EndNZloc=-1 NO_ATOMIC_Wsendbuf = ( NOMP_SHARED.EQ.1 ) NO_ATOMIC_Warrow = ( NOMP_SHARED.EQ.1 ) IF (NPROCS.GT.1) THEN NO_ATOMIC_Warrow = (NOMP_SHARED.LE.2) IF ( KEEP(399).EQ.2 .OR. KEEP(399).EQ.3) THEN NO_ATOMIC_Wsendbuf = .TRUE. IF (.NOT.MPI_InvolvedinSend) NO_ATOMIC_Warrow=.TRUE. IF (.NOT.MPI_InvolvedinRecv) NO_ATOMIC_Warrow=.TRUE. ENDIF ENDIF !$OMP END SINGLE ThWorking = OneMPI.OR. & (NOMP_SHARED.EQ.1) .OR. (IOMP.NE.0) TH_InvolvedinTreatRecv = (MPI_InvolvedinRecv.AND.ThWorking) IF ( TH_InvolvedinTreatRecv.AND. & (NOMP_SHARED.EQ.3).AND.(KEEP(399).EQ.3) ) THEN IF (IOMP.NE.2) TH_InvolvedinTreatRecv = .FALSE. ENDIF TH_InvolvedinArrange = ThWorking IF (.NOT.OneMPI.AND.ThWorking) THEN IF (KEEP(399).EQ.2.OR.KEEP(399).EQ.3) & THEN IF ((NOMP_SHARED.NE.1).AND.(IOMP.NE.1)) & TH_InvolvedinArrange = .FALSE. ENDIF ENDIF TH_InvolvedinComm = ((.NOT.OneMPI).AND.(IOMP.EQ.0)) NOTHINGTOARRANGE_P = (NZ_loc8.EQ.0_8) ILOC8_P = 0_8 DO WHILE ( .NOT.FINISHED ) IF (TH_InvolvedinComm) THEN CALL CMUMPS_ARROW_TRY_PROGRESS_COMM ( IOMP, MYID, & NPROCS, NBRECORDS_LOC, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ENDIF IF (.NOT.ThWorking) THEN CALL MUMPS_USLEEP(20) GOTO 50 ENDIF IF (TH_InvolvedinTreatRecv) THEN CALL CMUMPS_ARROW_TRY_TREAT_RECV_BUF ( IOMP, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, & NPROCS, NBRECORDS_LOC, N, IW4, & KEEP, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, S, LA, & NB_END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR, & NOMP_SHARED, EARLYT3ROOTINS, NO_ATOMIC_Warrow ) IF (NOMP_SHARED.EQ.1) THEN CALL CMUMPS_ARROW_TRY_PROGRESS_COMM ( IOMP, MYID, & NPROCS, NBRECORDS_LOC, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ENDIF ENDIF IF (.NOT. NOTHINGTOARRANGE_P.AND.TH_InvolvedinArrange) THEN !$OMP ATOMIC CAPTURE ILOC8_P = ILOC8 ILOC8 = ILOC8 + NB_RANGE_8 !$OMP END ATOMIC IF (ILOC8_P.LE.NZ_loc8) THEN NB_RANGE_P = int(min(NB_RANGE_8, NZ_loc8-ILOC8_P+1)) CALL CMUMPS_FAC_ARROW_ARRANGE ( MYID, IOMP, N, SHIFT_PID, & SLAVEF, LSCAL, NSEND8, NLOCAL8, ILOC8_P, NB_RANGE_P, & NZ_loc8, IRN_LOC, JCN_LOC, A_loc, SIZESCAL, ROWSCA, COLSCA, & ISTEP_TO_INIV2, CANDIDATES, KEEP, MPI_MASTER, NO_ATOMIC_Warrow, & NO_ATOMIC_Wsendbuf, TH_InvolvedinTreatRecv, & NPROCS, NBRECORDS_LOC, MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, IACT, & SEND_ACTIVE, BUFSEND_POSRESERVED, IRECVREQI, IRECVREQR, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, EndNZloc, MPI_End_Send, & End_TreatRecvBuf, & root, roota, PTR_ROOT, ARROW_ROOT, EARLYT3ROOTINS, & LOCAL_M, LOCAL_N, & S, LA, NB_END_MSG_2_RECV, PROCNODE_STEPS, IW4, PTRAW, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, PERM, STEP, INTARR, LINTARR, & DBLARR, LDBLARR, NOMP_SHARED ) ENDIF IF (ILOC8_P+NB_RANGE_8.GT.NZ_loc8) THEN IF (.NOT. NOTHINGTOARRANGE_P) THEN NOTHINGTOARRANGE_P=.TRUE. !$OMP ATOMIC CAPTURE EndNZloc = EndNZloc-1 EndNZloc_P = EndNZloc !$OMP END ATOMIC IF (MPI_End_Send.AND.EndNZloc_P.EQ.0) THEN !$OMP ATOMIC WRITE EndNZloc=-1 !$OMP END ATOMIC ENDIF ENDIF ENDIF ENDIF 50 CONTINUE !$OMP MASTER !$OMP ATOMIC WRITE FINISHED = ( (EndNZloc.EQ.-1) & .AND.(MPI_End_Send.OR.(.not.MPI_InvolvedinSend)) & .AND. End_TreatRecvBuf & ) !$OMP END ATOMIC !$OMP END MASTER ENDDO !$OMP END PARALLEL !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) !$OMP& PRIVATE(ISTEP, TYPE_NODE_P, MASTER_NODE_P, NBJ_P, !$OMP& IARR1, IS8_P ) !$OMP& IF (OMP_FLAG) DO ISTEP=1, KEEP(28) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE_P, MASTER_NODE_P, & PROCNODE_STEPS(ISTEP), KEEP(199) ) MASTER_NODE_P = MASTER_NODE_P + SHIFT_PID IF ( MASTER_NODE_P.NE.MYID.OR. & ( (TYPE_NODE_P.NE.1) .AND. (TYPE_NODE_P.NE.2) ) & ) CYCLE IARR1 = PTRDEBARR( ISTEP ) NBJ_P = NINCOLARR( IARR1) IF (NBJ_P.LE.0) CYCLE IS8_P = PTR8ARR( IARR1) + 1_8 CALL CMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( IS8_P ), & DBLARR( IS8_P ), & NBJ_P, 1, NBJ_P ) ENDDO !$OMP END PARALLEL DO 100 CONTINUE IF (ALLOCATED(IW4)) DEALLOCATE( IW4 ) IF (ALLOCATED(PTRAW)) DEALLOCATE( PTRAW ) IF (ALLOCATED(BUFSENDI)) DEALLOCATE( BUFSENDI ) IF (ALLOCATED(BUFSENDR)) DEALLOCATE( BUFSENDR ) IF (ALLOCATED(BUFRECVI)) DEALLOCATE( BUFRECVI ) IF (ALLOCATED(BUFRECVR)) DEALLOCATE( BUFRECVR ) IF (ALLOCATED(IACT)) DEALLOCATE( IACT ) IF (ALLOCATED(ISENDREQI)) DEALLOCATE( ISENDREQI ) IF (ALLOCATED(ISENDREQR)) DEALLOCATE( ISENDREQR ) IF (ALLOCATED(IRECVREQI)) DEALLOCATE( IRECVREQI ) IF (ALLOCATED(IRECVREQR)) DEALLOCATE( IRECVREQR ) IF (ALLOCATED(SEND_ACTIVE)) DEALLOCATE( SEND_ACTIVE ) IF (ALLOCATED(BUFSEND_POSRESERVED)) & DEALLOCATE( BUFSEND_POSRESERVED ) IF (ALLOCATED(RECV_BUF_STATUS)) DEALLOCATE( RECV_BUF_STATUS ) RETURN END SUBROUTINE CMUMPS_FAC_DIST_ARROWHEADS_OMP SUBROUTINE CMUMPS_ARROW_TRY_PROGRESS_COMM ( IOMP, MYID, & NPROCS, NBRECORDS, MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) IMPLICIT NONE INTEGER, INTENT(IN) :: IOMP, MYID, NPROCS, NBRECORDS, COMM LOGICAL, INTENT(IN) :: MPI_InvolvedinSend, MPI_InvolvedinRecv INTEGER, INTENT(IN) :: NB_END_MSG_2_RECV INTEGER, INTENT(INOUT) :: EndNZloc LOGICAL, INTENT(INOUT) :: MPI_End_Send, End_TreatRecvBuf INTEGER, INTENT(INOUT) :: & ISENDREQI(NPROCS), ISENDREQR(NPROCS), & BUFSENDI(NBRECORDS * 2 + 1, 2, NPROCS), & IACT(NPROCS), BUFSEND_POSRESERVED(2,NPROCS) COMPLEX, INTENT(INOUT) :: BUFSENDR(NBRECORDS, 2, NPROCS) LOGICAL, INTENT(INOUT) :: SEND_ACTIVE(NPROCS) INTEGER, INTENT(INOUT) :: & IRECVREQI(NPROCS), IRECVREQR(NPROCS), & BUFRECVI(NBRECORDS * 2 + 1, NPROCS), & RECV_BUF_STATUS(NPROCS) COMPLEX, INTENT(INOUT) :: BUFRECVR(NBRECORDS, NPROCS) INTEGER, PARAMETER :: Processed_IrecNeeded = 1 INTEGER, PARAMETER :: IrecPosted = 2 INTEGER, PARAMETER :: Received_NotProcessed = 3 INTEGER, PARAMETER :: Processed_IrecNotneeded = 4 INTEGER, PARAMETER :: Treating = 5 INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: EndNZloc_copy, ISLAVE, NBREC, STATE, & NB_END_MSG_2_RECV_COPY, ISLAVE_RECV INTEGER :: IERR, IACT_P, NEXT_IACT INTEGER :: TAILLE_SEND_I, TAILLE_SEND_R LOGICAL :: FLAG, FLAGRECV, ALL_LAST_MESS_SENT INTEGER :: STATUS(MPI_STATUS_SIZE) IF (MPI_InvolvedinSend.and.(.NOT.MPI_End_Send)) THEN DO ISLAVE = 1, NPROCS IF (ISLAVE-1.EQ.MYID) CYCLE IF (SEND_ACTIVE( ISLAVE )) THEN CALL MPI_TEST( ISENDREQR( ISLAVE ), FLAG, STATUS, IERR ) IF (FLAG) THEN CALL MPI_WAIT( ISENDREQI( ISLAVE ), STATUS, IERR ) SEND_ACTIVE( ISLAVE ) = .FALSE. ENDIF ENDIF ENDDO !$OMP ATOMIC READ EndNZloc_copy = EndNZloc !$OMP END ATOMIC ALL_LAST_MESS_SENT = (EndNZloc_copy.EQ.0) IF (EndNZloc_copy.NE.-1) THEN DO ISLAVE=1, NPROCS IF (ISLAVE-1.EQ.MYID) CYCLE IF (EndNZloc_copy .EQ. 0) THEN NBREC = & min(BUFSEND_POSRESERVED(IACT(ISLAVE),ISLAVE),NBRECORDS) IF (NBREC.EQ.-99) CYCLE BUFSENDI(1,IACT(ISLAVE),ISLAVE) = - NBREC ELSE !$OMP ATOMIC READ NBREC = BUFSENDI(1,IACT(ISLAVE),ISLAVE) !$OMP END ATOMIC ENDIF IF ((EndNZloc_copy.EQ.0).OR.(NBREC.EQ.NBRECORDS)) THEN IF (.NOT.SEND_ACTIVE(ISLAVE)) THEN TAILLE_SEND_I = NBREC * 2 + 1 TAILLE_SEND_R = NBREC IACT_P = IACT(ISLAVE) CALL MPI_ISEND( BUFSENDI(1, IACT_P, ISLAVE ), & TAILLE_SEND_I, & MPI_INTEGER, ISLAVE - 1, & ARR_INT, COMM, & ISENDREQI( ISLAVE ), IERR ) CALL MPI_ISEND( BUFSENDR(1, IACT_P, ISLAVE ), & TAILLE_SEND_R, & MPI_COMPLEX, ISLAVE - 1, & ARR_REAL, COMM, & ISENDREQR( ISLAVE ), IERR ) SEND_ACTIVE( ISLAVE ) = .TRUE. IF (EndNZloc_copy.NE.0) THEN NEXT_IACT = 3-IACT_P !$OMP ATOMIC WRITE BUFSEND_POSRESERVED(NEXT_IACT,ISLAVE) = 0 !$OMP END ATOMIC !$OMP ATOMIC WRITE BUFSENDI(1,NEXT_IACT,ISLAVE) = 0 !$OMP END ATOMIC !$OMP ATOMIC WRITE IACT( ISLAVE ) = NEXT_IACT !$OMP END ATOMIC ELSE BUFSEND_POSRESERVED(IACT_P,ISLAVE) = -99 ENDIF ELSE ALL_LAST_MESS_SENT=.FALSE. ENDIF ENDIF ENDDO ENDIF IF (EndNZloc_copy.EQ.0.AND.ALL_LAST_MESS_SENT) THEN EndNZloc = -1 EndNZloc_copy = -1 ENDIF IF (.NOT.MPI_End_Send) THEN IF ( (EndNZloc_copy.EQ.-1) ) THEN MPI_End_Send = .TRUE. DO ISLAVE = 1, NPROCS IF (ISLAVE-1.EQ.MYID) CYCLE IF (SEND_ACTIVE( ISLAVE )) THEN MPI_End_Send=.FALSE. EXIT ENDIF ENDDO ENDIF ENDIF ENDIF IF (MPI_InvolvedinRecv.AND.(.NOT.End_TreatRecvBuf)) THEN CALL MPI_TESTANY(NPROCS, IRECVREQR, ISLAVE_RECV, & FLAGRECV, STATUS,IERR) IF (FLAGRECV.AND.(ISLAVE_RECV.NE.MPI_UNDEFINED)) & THEN CALL MPI_WAIT(IRECVREQI(ISLAVE_RECV),STATUS,IERR) !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE_RECV)=Received_NotProcessed !$OMP END ATOMIC ENDIF DO ISLAVE = 1, NPROCS IF (ISLAVE - 1 .EQ. MYID) CYCLE !$OMP ATOMIC READ STATE = RECV_BUF_STATUS(ISLAVE) !$OMP END ATOMIC IF (STATE.EQ.Processed_IrecNeeded) THEN CALL MPI_IRECV ( BUFRECVI(1,ISLAVE), NBRECORDS * 2 + 1, & MPI_INTEGER, ISLAVE-1, ARR_INT, COMM, & IRECVREQI(ISLAVE), IERR) CALL MPI_IRECV ( BUFRECVR(1,ISLAVE), NBRECORDS, & MPI_COMPLEX, ISLAVE-1, & ARR_REAL, COMM, & IRECVREQR(ISLAVE), IERR) !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = IrecPosted !$OMP END ATOMIC ENDIF ENDDO !$OMP ATOMIC READ NB_END_MSG_2_RECV_COPY = NB_END_MSG_2_RECV !$OMP END ATOMIC IF (NB_END_MSG_2_RECV_COPY.EQ.0) THEN End_TreatRecvBuf = .TRUE. DO ISLAVE = 1, NPROCS IF (ISLAVE - 1 .EQ. MYID) CYCLE IF (RECV_BUF_STATUS(ISLAVE).NE.Processed_IrecNotneeded) THEN End_TreatRecvBuf = .FALSE. EXIT ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_ARROW_TRY_PROGRESS_COMM SUBROUTINE CMUMPS_ARROW_TRY_TREAT_RECV_BUF (IOMP, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, & NPROCS, NBRECORDS, N, IW4, & KEEP, LOCAL_M, LOCAL_N, root, roota, & PTR_ROOT, S, LA, & NB_END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR, & NOMP_SHARED, EARLYT3ROOTINS, NO_ATOMIC_Warrow ) USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER, INTENT(IN):: IOMP, NPROCS, NBRECORDS, N, MYID, SLAVEF, & NOMP_SHARED LOGICAL, INTENT(IN):: EARLYT3ROOTINS INTEGER, INTENT(IN):: BUFRECVI( NBRECORDS * 2 + 1, NPROCS ) COMPLEX, INTENT(IN):: BUFRECVR( NBRECORDS, NPROCS ) INTEGER, INTENT(INOUT) :: RECV_BUF_STATUS(NPROCS) INTEGER, INTENT(INOUT):: IW4( N, 2 ) INTEGER, INTENT(IN):: KEEP(500) INTEGER, INTENT(INOUT):: NB_END_MSG_2_RECV INTEGER(8), INTENT(IN) :: PTRAW( N ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER, INTENT(IN) :: PERM( N ), STEP( N ) INTEGER, INTENT(IN) :: PROCNODE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER, INTENT(INOUT) :: INTARR( LINTARR ) INTEGER, INTENT(IN):: LOCAL_M, LOCAL_N INTEGER(8), INTENT(IN) :: PTR_ROOT, LA COMPLEX, INTENT(INOUT) :: S( LA ), DBLARR( LDBLARR ) LOGICAL, INTENT(IN) :: NO_ATOMIC_Warrow INTEGER, PARAMETER :: Processed_IrecNeeded = 1 INTEGER, PARAMETER :: IrecPosted = 2 INTEGER, PARAMETER :: Received_NotProcessed = 3 INTEGER, PARAMETER :: Processed_IrecNotneeded = 4 INTEGER, PARAMETER :: Treating = 5 INTEGER, PARAMETER :: BeingTreatednotbyme = 6 INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE INTEGER STATE, ISLAVE DO ISLAVE =1, NPROCS IF (MYID.EQ.ISLAVE-1) CYCLE !$OMP ATOMIC READ STATE = RECV_BUF_STATUS(ISLAVE) !$OMP END ATOMIC IF (STATE.EQ.Treating) CYCLE IF (STATE.EQ.Received_NotProcessed) THEN IF (NOMP_SHARED.EQ.1) THEN RECV_BUF_STATUS(ISLAVE) = Treating STATE = Treating ELSE IF (KEEP(399).LE.3) THEN !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Treating !$OMP END ATOMIC STATE = Treating ELSE !$OMP CRITICAL(ARROW_RECV_BUF_STATUS) !$OMP ATOMIC READ STATE = RECV_BUF_STATUS(ISLAVE) !$OMP END ATOMIC IF (STATE.EQ.Received_NotProcessed) THEN !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Treating !$OMP END ATOMIC STATE = Treating ELSE STATE = BeingTreatednotbyme ENDIF !$OMP END CRITICAL(ARROW_RECV_BUF_STATUS) ENDIF ENDIF IF (STATE.NE.Treating) CYCLE IF (NO_ATOMIC_Warrow) THEN CALL CMUMPS_ARROW_TREAT_RECV_BUF_1TH() ELSE CALL CMUMPS_ARROW_TREAT_RECV_BUF() ENDIF ENDDO RETURN CONTAINS SUBROUTINE CMUMPS_ARROW_TREAT_RECV_BUF() INTEGER :: IREC, NB_REC, TYPE_NODE INTEGER :: IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER(8) :: IS8 INTEGER :: IARR, JARR, IW4_CAPTURED INTEGER :: NB_END_MSG_2_RECV_COPY COMPLEX :: VAL LOGICAL :: LAST_MESSAGE LAST_MESSAGE = .FALSE. NB_REC = BUFRECVI( 1, ISLAVE ) TYPE_NODE = -998 IF ( NB_REC .LE. 0 ) THEN LAST_MESSAGE = .TRUE. !$OMP ATOMIC CAPTURE NB_END_MSG_2_RECV_COPY = NB_END_MSG_2_RECV NB_END_MSG_2_RECV = NB_END_MSG_2_RECV - 1 !$OMP END ATOMIC NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) GOTO 100 DO IREC = 1, NB_REC IARR = BUFRECVI( IREC * 2, ISLAVE ) JARR = BUFRECVI( IREC * 2 + 1, ISLAVE ) VAL = BUFRECVR( IREC, ISLAVE ) IF (EARLYT3ROOTINS) THEN TYPE_NODE = MUMPS_TYPENODE( & PROCNODE_STEPS(abs(STEP(abs( IARR )))), & KEEP(199) ) ENDIF IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JARR ) ELSE IPOSROOT = root%RG2L( JARR ) JPOSROOT = root%RG2L( -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 !$OMP ATOMIC UPDATE S( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = S( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL !$OMP END ATOMIC ELSE !$OMP ATOMIC UPDATE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL !$OMP END ATOMIC ENDIF ELSE IF (IARR.GE.0) THEN IF (IARR.EQ.JARR) THEN IS8 = PTRAW(IARR) !$OMP ATOMIC UPDATE DBLARR(IS8) = DBLARR(IS8) + VAL !$OMP END ATOMIC ELSE !$OMP ATOMIC CAPTURE IW4_CAPTURED= IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 !$OMP END ATOMIC IS8 = PTRAW(IARR)+int(IW4_CAPTURED,8) INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ELSE IARR = -IARR !$OMP ATOMIC CAPTURE IW4_CAPTURED = IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 !$OMP END ATOMIC IS8 = PTRAW(IARR) + int(IW4_CAPTURED,8) INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ENDDO 100 CONTINUE IF (LAST_MESSAGE) THEN !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Processed_IrecNotneeded !$OMP END ATOMIC ELSE !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Processed_IrecNeeded !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE CMUMPS_ARROW_TREAT_RECV_BUF SUBROUTINE CMUMPS_ARROW_TREAT_RECV_BUF_1TH() INTEGER :: IREC, NB_REC, TYPE_NODE INTEGER :: IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER(8) :: IS8 INTEGER :: IARR, JARR INTEGER :: NB_END_MSG_2_RECV_COPY COMPLEX :: VAL LOGICAL :: LAST_MESSAGE TYPE_NODE = -997 LAST_MESSAGE = .FALSE. NB_REC = BUFRECVI( 1, ISLAVE ) IF ( NB_REC .LE. 0 ) THEN LAST_MESSAGE = .TRUE. !$OMP ATOMIC CAPTURE NB_END_MSG_2_RECV_COPY = NB_END_MSG_2_RECV NB_END_MSG_2_RECV = NB_END_MSG_2_RECV - 1 !$OMP END ATOMIC NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) GOTO 100 DO IREC = 1, NB_REC IARR = BUFRECVI( IREC * 2, ISLAVE ) JARR = BUFRECVI( IREC * 2 + 1, ISLAVE ) VAL = BUFRECVR( IREC, ISLAVE ) IF (EARLYT3ROOTINS) THEN TYPE_NODE = MUMPS_TYPENODE( & PROCNODE_STEPS(abs(STEP(abs( IARR )))), & KEEP(199) ) ENDIF IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JARR ) ELSE IPOSROOT = root%RG2L( JARR ) JPOSROOT = root%RG2L( -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 S( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = S( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%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 IS8 = PTRAW(IARR) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IS8 = PTRAW(IARR)+IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ENDDO 100 CONTINUE IF (LAST_MESSAGE) THEN !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Processed_IrecNotneeded !$OMP END ATOMIC ELSE !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Processed_IrecNeeded !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE CMUMPS_ARROW_TREAT_RECV_BUF_1TH END SUBROUTINE CMUMPS_ARROW_TRY_TREAT_RECV_BUF SUBROUTINE CMUMPS_FAC_ARROW_ARRANGE ( & MYID, IOMP, N, SHIFT_PID, SLAVEF, LSCAL, NSEND8, NLOCAL8, & ILOC8_P, NB_RANGE_P, NZ_loc8, IRN_LOC, JCN_LOC, A_loc, SIZESCAL, & ROWSCA, COLSCA, ISTEP_TO_INIV2, CANDIDATES, KEEP, MPI_MASTER, & NO_ATOMIC_Warrow, NO_ATOMIC_Wsendbuf, TH_InvolvedinTreatRecv, & NPROCS, NBRECORDS, MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, IACT, & SEND_ACTIVE, BUFSEND_POSRESERVED, IRECVREQI, IRECVREQR, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, EndNZloc, MPI_End_Send, & End_TreatRecvBuf, & root, roota, & PTR_ROOT, ARROW_ROOT, EARLYT3ROOTINS, LOCAL_M, LOCAL_N, & S, LA, NB_END_MSG_2_RECV, PROCNODE_STEPS, IW4, PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, INTARR, LINTARR, DBLARR, LDBLARR, NOMP_SHARED ) !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, IOMP, N, SHIFT_PID, & SLAVEF, SIZESCAL, MPI_MASTER INTEGER, INTENT(IN) :: NB_RANGE_P, KEEP(500) INTEGER(8), INTENT(IN) :: NZ_loc8, ILOC8_P INTEGER(8), INTENT(INOUT):: NSEND8, NLOCAL8 INTEGER, INTENT(IN) :: IRN_LOC(max(1_8,NZ_loc8)), & JCN_LOC(max(1_8,NZ_loc8)) INTEGER, INTENT(IN):: ISTEP_TO_INIV2(KEEP(71)) INTEGER, INTENT(IN):: CANDIDATES(SLAVEF+1, max(1,KEEP(56))) COMPLEX, INTENT(IN):: A_loc(max(1_8,NZ_loc8)) REAL, INTENT(IN) :: ROWSCA(SIZESCAL), & COLSCA(SIZESCAL) LOGICAL, INTENT(IN):: NO_ATOMIC_Warrow, NO_ATOMIC_Wsendbuf, & TH_InvolvedinTreatRecv INTEGER, INTENT(IN) :: NPROCS, NBRECORDS, COMM, NOMP_SHARED LOGICAL, INTENT(IN) :: MPI_InvolvedinSend, MPI_InvolvedinRecv, & LSCAL INTEGER, INTENT(INOUT) :: EndNZloc LOGICAL, INTENT(INOUT) :: MPI_End_Send, End_TreatRecvBuf INTEGER, INTENT(INOUT) :: ISENDREQI(NPROCS), ISENDREQR(NPROCS), & BUFSENDI(NBRECORDS * 2 + 1, 2, NPROCS), & IACT(NPROCS), BUFSEND_POSRESERVED(2,NPROCS) COMPLEX, INTENT(INOUT) :: BUFSENDR(NBRECORDS, 2, NPROCS) LOGICAL, INTENT(INOUT) :: SEND_ACTIVE(NPROCS) INTEGER, INTENT(INOUT) :: IRECVREQI(NPROCS), IRECVREQR(NPROCS), & BUFRECVI(NBRECORDS * 2 + 1, NPROCS), & RECV_BUF_STATUS(NPROCS) COMPLEX, INTENT(INOUT) :: BUFRECVR(NBRECORDS, NPROCS) INTEGER, PARAMETER :: Processed_IrecNeeded = 1 INTEGER, PARAMETER :: IrecPosted = 2 INTEGER, PARAMETER :: Received_NotProcessed = 3 INTEGER, PARAMETER :: Processed_IrecNotneeded = 4 INTEGER, PARAMETER :: Treating = 5 TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER, INTENT(IN) :: LOCAL_M, LOCAL_N LOGICAL, INTENT(IN) :: EARLYT3ROOTINS INTEGER, INTENT(INOUT) :: ARROW_ROOT INTEGER, INTENT(INOUT):: IW4( N, 2 ) INTEGER, INTENT(INOUT):: NB_END_MSG_2_RECV INTEGER(8), INTENT(IN) :: PTRAW( N ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER, INTENT(IN) :: PERM( N ), STEP( N ) INTEGER, INTENT(IN) :: PROCNODE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER, INTENT(INOUT) :: INTARR( LINTARR ) INTEGER(8), INTENT(IN) :: PTR_ROOT, LA COMPLEX, INTENT(INOUT) :: S( LA ), DBLARR( LDBLARR ) INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT INTEGER :: DEST, JSEND, ISEND , DEST_SAVE INTEGER :: I, INIV2, NCAND, T4MASTER INTEGER :: IOLD, JOLD, IARR, TYPESPLIT INTEGER(8) :: IS8, IZ8, LAST8 LOGICAL :: T4_MASTER_CONCERNED INTEGER :: MASTER_NODE, TYPE_NODE, ISTEP_P INTEGER :: IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER :: IROW_GRID, JCOL_GRID, IW4_CAPTURED LOGICAL :: LOCAL_ASSEMBLY, LOCAL COMPLEX :: VAL INTEGER :: ISTEP_T3_1PROC LAST8 = ILOC8_P + int(NB_RANGE_P-1,8) LOCAL_ASSEMBLY = (NPROCS.EQ.1) IF (NPROCS.EQ.1 .AND. KEEP(38).EQ.0) THEN TYPE_NODE = 1 ISTEP_T3_1PROC = -9999 ELSE IF (NPROCS.EQ.1 .AND. KEEP(38).NE.0) THEN ISTEP_T3_1PROC = STEP(KEEP(38)) ELSE ISTEP_T3_1PROC = -99999 ENDIF DO IZ8=ILOC8_P, LAST8 IOLD = IRN_loc(IZ8) JOLD = JCN_loc(IZ8) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE ENDIF IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = IOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF VAL = A_loc(IZ8) IF (LSCAL) THEN VAL = VAL * ROWSCA(IOLD)*COLSCA(JOLD) ENDIF IF (NPROCS.GT.1 .OR. KEEP(38).NE.0) THEN ISTEP_P = abs(STEP(IARR)) IF ( NPROCS.EQ.1 .AND. ISTEP_P.NE.ISTEP_T3_1PROC ) THEN TYPE_NODE=1 ELSE IF (NPROCS.EQ.1) THEN TYPE_NODE=3 IF (EARLYT3ROOTINS) THEN IF ( ISEND < 0 ) THEN IPOSROOT = root%RG2L(JSEND) JPOSROOT = root%RG2L(IARR ) ELSE IPOSROOT = root%RG2L(IARR ) JPOSROOT = root%RG2L(JSEND) END IF END IF ELSE ISTEP_P = abs(STEP(IARR)) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP_P), KEEP(199) ) MASTER_NODE = MASTER_NODE + SHIFT_PID T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 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 INIV2 = ISTEP_TO_INIV2(ISTEP_P) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP_P), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER= & CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & + SHIFT_PID ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND < 0 ) THEN IPOSROOT = root%RG2L(JSEND) JPOSROOT = root%RG2L(IARR ) ELSE IPOSROOT = root%RG2L(IARR ) JPOSROOT = root%RG2L(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 + SHIFT_PID ELSE DEST = -2 ENDIF ENDIF IF (DEST .eq. -1) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .EQ. -2) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .eq.MYID ) THEN NLOCAL8 = NLOCAL8 + 1_8 ELSE NSEND8 = NSEND8 + 1_8 ENDIF ENDIF LOCAL_ASSEMBLY = .FALSE. IF ( DEST.EQ.-1) THEN INIV2 = ISTEP_TO_INIV2(ISTEP_P) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79) .GT. 0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) + SHIFT_PID IF (DEST.LT.0) EXIT LOCAL = (DEST.EQ.MYID) IF (LOCAL) LOCAL_ASSEMBLY = .TRUE. IF (LOCAL) CYCLE IF (I.EQ.NCAND+1) CYCLE CALL CMUMPS_DIST_FILL_SEND_BUFFER() ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) + SHIFT_PID LOCAL = (DEST.EQ.MYID) IF (LOCAL) LOCAL_ASSEMBLY = .TRUE. IF (LOCAL) CYCLE CALL CMUMPS_DIST_FILL_SEND_BUFFER() ENDDO ENDIF IF ( LOCAL_ASSEMBLY ) THEN DEST_SAVE = DEST DEST = MASTER_NODE IF (DEST.NE.MYID) & CALL CMUMPS_DIST_FILL_SEND_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER IF (DEST.NE.MYID) & CALL CMUMPS_DIST_FILL_SEND_BUFFER() ENDIF DEST = DEST_SAVE ELSE DEST=MASTER_NODE LOCAL_ASSEMBLY = (DEST.EQ.MYID) IF (.NOT.LOCAL_ASSEMBLY) & CALL CMUMPS_DIST_FILL_SEND_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER LOCAL_ASSEMBLY = (DEST.EQ.MYID) IF (.NOT.LOCAL_ASSEMBLY) & CALL CMUMPS_DIST_FILL_SEND_BUFFER() ENDIF ENDIF ELSE IF (DEST .GE. 0) THEN LOCAL_ASSEMBLY = (DEST.EQ.MYID) IF (.NOT.LOCAL_ASSEMBLY) & CALL CMUMPS_DIST_FILL_SEND_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER LOCAL_ASSEMBLY = (DEST.EQ.MYID) IF (.NOT.LOCAL_ASSEMBLY) & CALL CMUMPS_DIST_FILL_SEND_BUFFER() ENDIF ELSE IF (DEST .EQ. -2) THEN DO I = 0, SLAVEF-1 DEST=I + SHIFT_PID IF (DEST.NE.MYID) & CALL CMUMPS_DIST_FILL_SEND_BUFFER() ENDDO IF (SHIFT_PID.EQ.1.AND.MYID.EQ.MPI_MASTER) THEN LOCAL_ASSEMBLY=.FALSE. ELSE LOCAL_ASSEMBLY=.TRUE. ENDIF ENDIF ENDIF ENDIF IF (LOCAL_ASSEMBLY) THEN IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN !$OMP ATOMIC UPDATE S( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = S( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL !$OMP END ATOMIC ELSE !$OMP ATOMIC UPDATE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL !$OMP END ATOMIC ENDIF ELSE IF (NO_ATOMIC_Warrow) THEN IF (ISEND.EQ.JSEND) THEN IS8 = PTRAW(ISEND) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IF (ISEND.GE.0) THEN IS8 = PTRAW(IARR)+IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL ELSE IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL ENDIF ELSE IF (ISEND.EQ.JSEND) THEN IS8 = PTRAW(ISEND) !$OMP ATOMIC UPDATE DBLARR(IS8) = DBLARR(IS8) + VAL !$OMP END ATOMIC ELSE IF (ISEND.GE.0) THEN !$OMP ATOMIC CAPTURE IW4_CAPTURED = IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 !$OMP END ATOMIC IS8 = PTRAW(IARR) + int(IW4_CAPTURED,8) INTARR(IS8) = JSEND DBLARR(IS8) = VAL ELSE !$OMP ATOMIC CAPTURE IW4_CAPTURED = IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 !$OMP END ATOMIC IS8 = PTRAW(IARR) + int(IW4_CAPTURED,8) INTARR(IS8) = JSEND DBLARR(IS8) = VAL ENDIF ENDIF ENDIF ENDIF ENDDO RETURN CONTAINS SUBROUTINE CMUMPS_DIST_FILL_SEND_BUFFER( ) INTEGER IREQ, IACT_P, ISLAVE ISLAVE = DEST+1 100 CONTINUE !$OMP ATOMIC READ IACT_P = IACT(ISLAVE) !$OMP END ATOMIC IF (NO_ATOMIC_Wsendbuf) THEN BUFSEND_POSRESERVED(IACT_P,ISLAVE) = & BUFSEND_POSRESERVED(IACT_P, ISLAVE) + 1 IREQ = BUFSEND_POSRESERVED(IACT_P, ISLAVE) IF (IREQ > NBRECORDS ) THEN IF (IREQ > huge(NBRECORDS)-1000 - NOMP_SHARED-2) THEN BUFSEND_POSRESERVED(IACT_P, ISLAVE) = min(NBRECORDS+1, & BUFSEND_POSRESERVED(IACT_P, ISLAVE) ) ENDIF IF (NOMP_SHARED.EQ.1) & CALL CMUMPS_ARROW_TRY_PROGRESS_COMM (IOMP, & MYID, NPROCS, NBRECORDS, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) IF (TH_InvolvedinTreatRecv) & CALL CMUMPS_ARROW_TRY_TREAT_RECV_BUF (IOMP, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, & NPROCS, NBRECORDS, N, IW4, & KEEP, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, S, LA, & NB_END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR, & NOMP_SHARED, EARLYT3ROOTINS, NO_ATOMIC_Warrow) IF (NOMP_SHARED.EQ.1) THEN CALL CMUMPS_ARROW_TRY_PROGRESS_COMM (IOMP, & MYID, NPROCS, NBRECORDS, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ELSE IF (.NOT.TH_InvolvedinTreatRecv) THEN CALL MUMPS_USLEEP(200) ELSE CALL MUMPS_USLEEP(20) ENDIF ENDIF GOTO 100 ENDIF BUFSENDI(IREQ*2,IACT_P,ISLAVE) = ISEND BUFSENDI(IREQ*2+1,IACT_P,ISLAVE) = JSEND BUFSENDR(IREQ,IACT_P,ISLAVE ) = VAL IF (IREQ.EQ.NBRECORDS) THEN !$OMP ATOMIC WRITE BUFSENDI(1,IACT_P,ISLAVE) = NBRECORDS !$OMP END ATOMIC ENDIF ELSE !$OMP ATOMIC CAPTURE BUFSEND_POSRESERVED(IACT_P,ISLAVE) = & BUFSEND_POSRESERVED(IACT_P, ISLAVE) + 1 IREQ = BUFSEND_POSRESERVED(IACT_P, ISLAVE) !$OMP END ATOMIC IF (IREQ > huge(NBRECORDS)-NOMP_SHARED-2) THEN !$OMP ATOMIC UPDATE BUFSEND_POSRESERVED(IACT_P, ISLAVE) = min(NBRECORDS+1, & BUFSEND_POSRESERVED(IACT_P, ISLAVE) ) !$OMP END ATOMIC ENDIF IF (IREQ > NBRECORDS ) THEN IF (NOMP_SHARED.EQ.1) THEN CALL CMUMPS_ARROW_TRY_PROGRESS_COMM (IOMP, & MYID, NPROCS, NBRECORDS, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ENDIF IF (TH_InvolvedinTreatRecv) & CALL CMUMPS_ARROW_TRY_TREAT_RECV_BUF (IOMP, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, & NPROCS, NBRECORDS, N, IW4, & KEEP, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, S, LA, & NB_END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR, & NOMP_SHARED, EARLYT3ROOTINS, NO_ATOMIC_Warrow) IF (NOMP_SHARED.EQ.1) THEN CALL CMUMPS_ARROW_TRY_PROGRESS_COMM (IOMP, & MYID, NPROCS, NBRECORDS, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ELSE IF (.NOT.TH_InvolvedinTreatRecv) THEN CALL MUMPS_USLEEP(200) ELSE CALL MUMPS_USLEEP(20) ENDIF ENDIF GOTO 100 ENDIF BUFSENDI(IREQ*2,IACT_P,ISLAVE) = ISEND BUFSENDI(IREQ*2+1,IACT_P,ISLAVE) = JSEND BUFSENDR(IREQ,IACT_P,ISLAVE ) = VAL !$OMP ATOMIC UPDATE BUFSENDI(1,IACT_P,ISLAVE) = BUFSENDI(1,IACT_P,ISLAVE) + 1 !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE CMUMPS_DIST_FILL_SEND_BUFFER END SUBROUTINE CMUMPS_FAC_ARROW_ARRANGE #endif MUMPS_5.8.1/src/cfac_process_blocfacto.F0000664000175000017500000011075215042446440020013 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE CMUMPS_PROCESS_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL, KEEP,KEEP8, DKEEP, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_OOC, ONLY : IO_BLOCK USE MUMPS_OOC_COMMON, ONLY : TYPEF_L, STRAT_TRY_WRITE USE MUMPS_LOAD USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT USE CMUMPS_LR_CORE USE CMUMPS_LR_TYPE USE MUMPS_LR_STATS USE CMUMPS_FAC_LR USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER(8) :: POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PERM(N), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER COMM, MYID INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)), ND(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) COMPLEX DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER INODE, POSITION, NPIV, IERR, LP INTEGER NCOL_RECV, JBEG_BLOCK, NCOL_GEMM, SHIFT_LPOS, SHIFT_UPOS INTEGER SHIFT_BEGS_BLR_U INTEGER :: IFLAG_OOC INTEGER(8) :: POSBLOCFACTO INTEGER :: LD_BLOCFACTO INTEGER(8) :: LA_BLOCFACTO INTEGER(8) :: LA_PTR INTEGER(8) :: POSELT COMPLEX, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW INTEGER (8) :: LPOS, UPOS, LPOS2, IPOS, KPOS INTEGER ICT11 INTEGER I, IPIV, FPERE LOGICAL LASTPANEL, KEEP_BEGS_BLR_L, KEEP_BEGS_BLR_COL LOGICAL LASTBL_INPANEL, LASTBL_INLASTPANEL LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED COMPLEX ONE,ALPHA PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER :: INFO_TMP(2) INTEGER :: IDUMMY(1) INTEGER :: NELIM, NPARTSASS_MASTER, NPARTSASS_MASTER_AUX, & IPANEL, & CURRENT_BLR, & NB_BLR_L, NB_BLR_U, NB_BLR_COL INTEGER :: NBCOL_in_LRB, SIZE_BEGS_BLR_COL TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_U, BLR_L LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: LR_ACTIVATED_INT INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U, & BEGS_BLR_COL COMPLEX, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT REAL,ALLOCATABLE,DIMENSION(:) :: RWORK COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: BLOCK INTEGER :: OMP_NUM INTEGER NPARTSASS, NPARTSCB, MAXI_CLUSTER, LWORK, & MAXI_CLUSTER_L, MAXI_CLUSTER_U, MAXI_CLUSTER_COL INTEGER :: allocok KEEP_BEGS_BLR_COL = .FALSE. KEEP_BEGS_BLR_L = .FALSE. nullify(BEGS_BLR_L) NB_BLR_U = -7654321 SHIFT_BEGS_BLR_U = 0 NULLIFY(BEGS_BLR_U) NULLIFY(BEGS_BLR_COL) MAXI_CLUSTER = 0 CURRENT_BLR = 1 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 ) LASTPANEL = (NPIV.LE.0) IF (LASTPANEL) 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_RECV, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, JBEG_BLOCK, 1, & MPI_INTEGER, COMM, IERR ) IF (JBEG_BLOCK.EQ.1) THEN NCOL_GEMM = NCOL_RECV - NPIV SHIFT_LPOS = NPIV SHIFT_UPOS = NPIV ELSE NCOL_GEMM = NCOL_RECV SHIFT_LPOS = JBEG_BLOCK-1 SHIFT_UPOS = 0 ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER , 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT, & 1, MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) IF ( LR_ACTIVATED ) THEN IF (JBEG_BLOCK.NE.1) THEN LA_BLOCFACTO = 0_8 ELSE LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8) ENDIF ELSE LA_BLOCFACTO = int(NPIV,8) * int(NCOL_RECV,8) ENDIF CALL CMUMPS_GET_SIZE_NEEDED( & NPIV, LA_BLOCFACTO, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID,SLAVEF, PROCNODE_STEPS, & DAD, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LA_BLOCFACTO LRLUS = LRLUS - LA_BLOCFACTO KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LA_BLOCFACTO KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LA_BLOCFACTO CALL MUMPS_LOAD_MEM_UPDATE(.FALSE., .FALSE., & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS) IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SIZE_BEGS_BLR_COL, 1, & MPI_INTEGER, COMM, IERR ) IF (SIZE_BEGS_BLR_COL.GT.0) THEN ALLOCATE(BEGS_BLR_COL(SIZE_BEGS_BLR_COL+2+IPANEL-1), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = SIZE_BEGS_BLR_COL+2 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF IF (IPANEL.GT.1) THEN BEGS_BLR_COL(1:IPANEL-1) = 1 ENDIF BEGS_BLR_COL(IPANEL) = 1 BEGS_BLR_COL(IPANEL+1) = NPIV+NELIM+1 DO I = 1, SIZE_BEGS_BLR_COL CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBCOL_in_LRB, 1, & MPI_INTEGER, COMM, IERR ) BEGS_BLR_COL(I+IPANEL+1) = & BEGS_BLR_COL(I+IPANEL) + NBCOL_in_LRB ENDDO ENDIF ENDIF IF ((NPIV .EQ. 0) & ) THEN IPIV=1 ELSE IPIV = IWPOS IWPOS = IWPOS + NPIV IF (NPIV .GT. 0.AND.JBEG_BLOCK.EQ.1) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) ENDIF IF ( LR_ACTIVATED .AND. JBEG_BLOCK.EQ.1) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*(NPIV+NELIM), & MPI_COMPLEX, & COMM, IERR ) LD_BLOCFACTO = NPIV+NELIM ENDIF IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_U, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_U(max(NB_BLR_U,1)), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = max(NB_BLR_U,1) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF ALLOCATE(BEGS_BLR_U(NB_BLR_U+2), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_U+2 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF CALL CMUMPS_MPI_UNPACK_LR_PARTIAL & (BUFR, LBUFR, LBUFR_BYTES, & POSITION, NPIV, NELIM, 'H', & BLR_U(1), NB_BLR_U, & JBEG_BLOCK, & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (JBEG_BLOCK.NE.1) SHIFT_BEGS_BLR_U = 1 IF (IFLAG.LT.0) GOTO 700 ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL_RECV, & MPI_COMPLEX, & COMM, IERR ) LD_BLOCFACTO = NCOL_RECV ENDIF ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) THEN CALL CMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 550 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 +KEEP(IXSZ)) .EQ. 0 ) THEN DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 550 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) CALL CMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LASTBL_INPANEL = JBEG_BLOCK+NCOL_RECV.GT.LCONT1 LASTBL_INLASTPANEL = LASTPANEL .AND. LASTBL_INPANEL IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL CMUMPS_ASM_SLAVE_ARROWHEADS(INODE, STEP(INODE), & N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, & LRGROUPS) ELSE CALL CMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 +KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) COMPRESS_CB = .FALSE. IF (LR_ACTIVATED) THEN COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) IF (COMPRESS_CB.AND.NPIV.EQ.0) THEN COMPRESS_CB = .FALSE. IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 ENDIF ENDIF NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF (NPIV.GT.0) THEN IF (JBEG_BLOCK.EQ.1) 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_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO ENDIF LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(SHIFT_LPOS,8) IF ( (JBEG_BLOCK.EQ.1) .AND. & ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) & ) THEN CALL ctrsm('L','L','N','N', NPIV, NROW1, ONE, & A(POSBLOCFACTO), LD_BLOCFACTO, & A_PTR(LPOS2), NCOL1) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (NPIV.NE.0) THEN IF ( (NPIV1.EQ.0).AND.(JBEG_BLOCK.EQ.1) & ) THEN IOLDPS = PTRIST(STEP(INODE)) CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_L) CALL REGROUPING2(BEGS_BLR_L, NPARTSASS, NASS1, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472), & NCOL1, KEEP(1)) NB_BLR_L = NPARTSCB IF (IFLAG.LT.0) GOTO 700 CALL CMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .TRUE., & .TRUE., & NPARTSASS_MASTER, & BEGS_BLR_L, & BEGS_BLR_COL, & huge(NPARTSASS_MASTER), & INFO_TMP) IF (associated(BEGS_BLR_COL)) DEALLOCATE(BEGS_BLR_COL) IF (IFLAG.LT.0) GOTO 700 ELSE CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_L) KEEP_BEGS_BLR_L = .TRUE. NB_BLR_L = size(BEGS_BLR_L) - 2 NPARTSASS = 1 NPARTSCB = NB_BLR_L ENDIF ENDIF ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (LR_ACTIVATED) THEN IF ( (JBEG_BLOCK.EQ.1) & ) THEN call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) call MAX_CLUSTER(BEGS_BLR_U(1+SHIFT_BEGS_BLR_U:NB_BLR_U+2), & NB_BLR_U+1-SHIFT_BEGS_BLR_U, & MAXI_CLUSTER_U) IF (SHIFT_BEGS_BLR_U.EQ.1) & MAXI_CLUSTER_U = max(MAXI_CLUSTER_U,NPIV+NELIM) IF (LASTBL_INLASTPANEL.AND.COMPRESS_CB) THEN MAXI_CLUSTER=max(MAXI_CLUSTER_U+NELIM,MAXI_CLUSTER_L) ELSE MAXI_CLUSTER=max(MAXI_CLUSTER_U,MAXI_CLUSTER_L) ENDIF LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER & + 2*MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + LWORK*OMP_NUM LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF CURRENT_BLR=1 ALLOCATE(BLR_L(NB_BLR_L), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_L LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL CMUMPS_COMPRESS_PANEL_I_NOOPT & (A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), NB_BLR_L+1, & DKEEP(8), KEEP(466), 0, & KEEP(473), BLR_L(1), & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP8, & OMP_NUM ) #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_L, 0) #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 300 IF ((KEEP(475).GE.1).AND.(JBEG_BLOCK.EQ.1)) THEN CALL CMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, & LD_BLOCFACTO, -6666, & NB_BLR_L+1, & BLR_L, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_L+1, & 2, 0, 0, & .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (KEEP(486).NE.2) THEN CALL CMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A_PTR(POSELT), LA_PTR, 1_8, & NCOL1, NCOL1, & .TRUE., & NPIV1+1, & 1, & NB_BLR_L+1, BLR_L(1), CURRENT_BLR, 'V', 1) ENDIF ENDIF 300 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ELSE CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_L) CURRENT_BLR=1 ENDIF ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & (OOCWRITE_COMPATIBLE_WITH_BLR .OR. NPIV.EQ.0) & .AND. (JBEG_BLOCK.EQ.1) & ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTPANEL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) LAST_CALL = .FALSE. CALL CMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L, & A_PTR(POSELT), & LA_PTR, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG_OOC, LAST_CALL) IF ( IFLAG_OOC .LT. 0 )THEN IFLAG = IFLAG_OOC GOTO 700 ENDIF ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (LR_ACTIVATED) THEN IF (NELIM.GT.0.AND.JBEG_BLOCK.EQ.1) THEN UPOS = 1_8+int(SHIFT_UPOS,8) CALL CMUMPS_BLR_UPD_NELIM_VAR_L_I( & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & CURRENT_BLR, BLR_L(1), NB_BLR_L+1, & CURRENT_BLR+1, NELIM, 'N') ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL CMUMPS_BLR_UPDATE_TRAILING_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & BEGS_BLR_U(1), size(BEGS_BLR_U), CURRENT_BLR, & BLR_L(1), NB_BLR_L+1, & BLR_U(1), NB_BLR_U+1, & 0, & .TRUE., & NPIV1, & 2, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ELSE UPOS = POSBLOCFACTO+int(SHIFT_UPOS,8) CALL cgemm('N','N', NCOL_GEMM, NROW1, NPIV, & ALPHA,A(UPOS), NCOL_RECV, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ENDIF ENDIF IF (LASTBL_INPANEL) THEN IW(IOLDPS + KEEP(IXSZ)) = IW(IOLDPS + KEEP(IXSZ)) - NPIV IW(IOLDPS + 3 + KEEP(IXSZ))= IW(IOLDPS + 3 + KEEP(IXSZ)) + NPIV IF (LASTPANEL) THEN IW(IOLDPS+1+KEEP(IXSZ) ) = IW(IOLDPS+3+KEEP(IXSZ) ) ENDIF ENDIF IF ( .not. LASTBL_INLASTPANEL .AND. & (IW(IOLDPS+1+KEEP(IXSZ)) .EQ. IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN write(*,*) 'Internal ERROR 1 **** IN BLACFACTO ' CALL MUMPS_ABORT() ENDIF IF (LR_ACTIVATED) THEN IF ((NPIV.GT.0) & ) THEN CALL DEALLOC_BLR_PANEL( BLR_U, NB_BLR_U, KEEP8, KEEP(34)) DEALLOCATE(BLR_U) IF (KEEP(486).NE.3) THEN CALL UPD_MRY_LU_LRGAIN(BLR_L, NPARTSCB & ) ENDIF ENDIF ENDIF LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) IWPOS = IWPOS - NPIV IF (LASTBL_INPANEL) THEN 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 MUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IF (LR_ACTIVATED.AND.LASTBL_INPANEL.AND. & (KEEP(486).EQ.3) & ) THEN IF (NPIV.NE.0) THEN CALL CMUMPS_BLR_FORCE_FREE_PANEL_L(IW(IOLDPS+XXF), IPANEL, & KEEP8, KEEP(34)) nullify(BLR_L) ENDIF ENDIF IF (LASTBL_INLASTPANEL) THEN IF (KEEP(486).NE.0) THEN IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (COMPRESS_CB) THEN CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER_AUX) KEEP_BEGS_BLR_COL = .TRUE. BEGS_BLR_COL(1+NPARTSASS_MASTER) = & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM NB_BLR_COL = size(BEGS_BLR_COL) - 1 call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) call MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER_COL=MAXI_CLUSTER_COL+NELIM IF ( (MAXI_CLUSTER.LT.MAXI_CLUSTER_COL).OR. & (MAXI_CLUSTER.LT.MAXI_CLUSTER_L) ) THEN MAXI_CLUSTER = max(MAXI_CLUSTER_COL,MAXI_CLUSTER_L) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER & + 2*MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + LWORK*OMP_NUM LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF ENDIF allocate(CB_LRB(NB_BLR_L,NB_BLR_COL-NPARTSASS_MASTER), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_L*(NB_BLR_COL-NPARTSASS_MASTER) GOTO 700 ENDIF CALL CMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif IF (COMPRESS_CB) THEN CALL CMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_L, NB_BLR_COL-NPARTSASS_MASTER, & NPARTSASS_MASTER, & NROW1, NCOL1-NPIV1-NPIV, INODE, & IW(IOLDPS+XXF), 0, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, OMP_NUM, & -9999, -9999, -9999, KEEP(1), & IDUMMY, 0, -9999 ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 IF ( KEEP(251).EQ.2 .AND. KEEP(486).EQ.2 ) THEN CALL CMUMPS_BLR_FREE_ALL_PANELS( IW(IOLDPS+XXF), & 0, & KEEP8, KEEP(34) ) ENDIF ENDIF CALL CMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, roota, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF GOTO 550 700 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 550 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(BEGS_BLR_COL)) THEN IF (.NOT. KEEP_BEGS_BLR_COL) DEALLOCATE(BEGS_BLR_COL) ENDIF IF (associated(BEGS_BLR_L)) THEN IF (.NOT. KEEP_BEGS_BLR_L) DEALLOCATE(BEGS_BLR_L) ENDIF IF ((NPIV.GT.0) & ) THEN IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_PROCESS_BLOCFACTO SUBROUTINE CMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, & NPIV, NELIM, DIR, & BLR_U, NB_BLOCK_U, & BEGS_BLR_U, KEEP8, & COMM, IERR, IFLAG, IERROR) USE CMUMPS_LR_CORE, ONLY : LRB_TYPE, ALLOC_LRB USE CMUMPS_LR_TYPE IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR INTEGER, INTENT(IN) :: LBUFR_BYTES INTEGER, INTENT(IN) :: BUFR(LBUFR) INTEGER, INTENT(INOUT) :: POSITION INTEGER, INTENT(IN) :: NB_BLOCK_U, NELIM, NPIV CHARACTER(len=1) :: DIR INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(OUT) :: IERR TYPE (LRB_TYPE), INTENT(OUT), & DIMENSION(max(NB_BLOCK_U,1)):: BLR_U INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2) :: BEGS_BLR_U INTEGER(8) :: KEEP8(150) LOGICAL :: ISLR INTEGER :: ISLR_INT, I INTEGER :: K, M, N INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IERR = 0 IF (size(BLR_U) .NE. & MAX(NB_BLOCK_U,1) ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_MPI_UNPACK", & NB_BLOCK_U,size(BLR_U) CALL MUMPS_ABORT() ENDIF BEGS_BLR_U(1) = 1 BEGS_BLR_U(2) = NPIV+NELIM+1 DO I = 1, NB_BLOCK_U CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ISLR_INT, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & K, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & M, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & N, 1, & MPI_INTEGER, COMM, IERR ) BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M IF (ISLR_INT .eq. 1) THEN ISLR = .TRUE. ELSE ISLR = .FALSE. ENDIF CALL ALLOC_LRB( BLR_U(I), K, M, N, ISLR, & IFLAG, IERROR, KEEP8 ) IF (IFLAG.LT.0) RETURN IF (ISLR) THEN IF (K .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*K, MPI_COMPLEX, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%R(1,1), N*K, MPI_COMPLEX, & COMM, IERR) ENDIF ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*N, MPI_COMPLEX, & COMM, IERR) ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_MPI_UNPACK_LR SUBROUTINE CMUMPS_MPI_UNPACK_LR_PARTIAL( & BUFR, LBUFR, LBUFR_BYTES, POSITION, & NPIV, NELIM, DIR, & BLR_U, NB_BLOCK_U, & JBEG_BLOCK, & BEGS_BLR_U, KEEP8, & COMM, IERR, IFLAG, IERROR) USE CMUMPS_LR_CORE, ONLY : LRB_TYPE, ALLOC_LRB USE CMUMPS_LR_TYPE IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR INTEGER, INTENT(IN) :: LBUFR_BYTES INTEGER, INTENT(IN) :: BUFR(LBUFR) INTEGER, INTENT(INOUT) :: POSITION INTEGER, INTENT(IN) :: NB_BLOCK_U, NELIM, NPIV, JBEG_BLOCK CHARACTER(len=1) :: DIR INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(OUT) :: IERR TYPE (LRB_TYPE), INTENT(OUT), & DIMENSION(max(NB_BLOCK_U,1)):: BLR_U INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2) :: BEGS_BLR_U INTEGER(8) :: KEEP8(150) LOGICAL :: ISLR INTEGER :: ISLR_INT, I INTEGER :: K, M, N INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IERR = 0 IF (size(BLR_U) .NE. & MAX(NB_BLOCK_U,1) ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_MPI_UNPACK", & NB_BLOCK_U,size(BLR_U) CALL MUMPS_ABORT() ENDIF BEGS_BLR_U(1) = 1 BEGS_BLR_U(2) = NPIV+NELIM+1 IF (JBEG_BLOCK.NE.1) THEN BEGS_BLR_U(2) = JBEG_BLOCK ENDIF DO I = 1, NB_BLOCK_U CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ISLR_INT, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & K, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & M, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & N, 1, & MPI_INTEGER, COMM, IERR ) BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M IF (ISLR_INT .eq. 1) THEN ISLR = .TRUE. ELSE ISLR = .FALSE. ENDIF CALL ALLOC_LRB( BLR_U(I), K, M, N, ISLR, & IFLAG, IERROR, KEEP8 ) IF (IFLAG.LT.0) RETURN IF (ISLR) THEN IF (K .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*K, MPI_COMPLEX, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%R(1,1), N*K, MPI_COMPLEX, & COMM, IERR) ENDIF ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*N, MPI_COMPLEX, & COMM, IERR) ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_MPI_UNPACK_LR_PARTIAL MUMPS_5.8.1/src/dfac_process_contrib_type2.F0000664000175000017500000004730315042446440020644 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, & MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, & N, IW, LIW, A, LA, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, PERM, & COMP, root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, NBFIN, & MYID, COMM, ICNTL, KEEP,KEEP8,DKEEP, IFLAG, IERROR, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_LOAD USE DMUMPS_BUF USE DMUMPS_LR_TYPE USE MUMPS_LR_STATS USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR, & DMUMPS_DM_FREE_BLOCK IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV, MSGLEN INTEGER BUFR( LBUFR ) INTEGER(8) :: LRLU, IPTRLU, LRLUS, LA, POSFAC INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER NBFIN INTEGER COMP INTEGER NELT, LPTRAR INTEGER PROCNODE_STEPS( KEEP(28) ), PTRIST(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER PTLUST( KEEP(28) ) INTEGER PERM(N) INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER ITLOC( N + KEEP(253)), NSTK_S( KEEP(28) ) INTEGER :: FILS( N ), DAD(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER ND(KEEP(28)), FRERE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER INTARR( KEEP8(27) ) DOUBLE PRECISION DBLARR( KEEP8(26) ) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, MYID, IFLAG, IERROR INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER FRTPTR(N+1), FRTELT( NELT ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NFS4FATHER INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPESPLIT INTEGER IERR INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER I, INODE, ISON, POSITION, NBROW, LROW, IROW, INDCOL INTEGER LREQI INTEGER(8) :: LREQA, POSCONTRIB INTEGER ROW_LENGTH INTEGER MASTER INTEGER ISTCHK LOGICAL SAME_PROC LOGICAL SLAVE_NODE LOGICAL IS_ofType5or6 INTEGER ISHIFT_BUFR, LBUFR_LOC, LBUFR_BYTES_LOC INTEGER TYPESPLIT INTEGER DECR INTEGER :: INBPROCFILS_SON LOGICAL :: CB_IS_LR INTEGER :: CB_IS_LR_INT, NBLRB_PACKET, allocok INTEGER :: MAXI_CLUSTER INTEGER :: ICOL_BEG, ICOL_END, ICOL_SHARED INTEGER :: IROW_BEG, IROW_END INTEGER :: NB_BLOCKS_UNPACKED LOGICAL :: BLOCKS_LEFT_2_UNPACK DOUBLE PRECISION :: PROMOTE_COST INTEGER(8) :: LA_TEMP DOUBLE PRECISION, DIMENSION(:), POINTER :: A_TEMP TYPE (LRB_TYPE) :: LRB INTEGER(8) :: IACHK, SIZFR8, DYN_SIZE DOUBLE PRECISION, DIMENSION(:), POINTER :: DYNPTR INTEGER :: NSLAVES, NFRONT, NASS1, IOLDPS, PARPIV_T1 INTEGER :: NB_POSTPONED LOGICAL :: LR_ACTIVATED INTEGER(8) :: POSELT INTEGER :: XXG_STATUS INCLUDE 'mumps_headers.h' DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) INTEGER :: NBCOLS_ALREADY_SENT LOGICAL :: IS_PANEL_FINISHED, IS_LROW_NEGATIVE 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 ) IS_LROW_NEGATIVE = (LROW.LT.0) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & CB_IS_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) CB_IS_LR = (CB_IS_LR_INT.EQ.1) IF (CB_IS_LR.AND.LROW.LT.0) THEN LROW = -LROW ENDIF NBCOLS_ALREADY_SENT=0 ICOL_SHARED = -9999 MASTER = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) SLAVE_NODE = MASTER .NE. MYID TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) IF (SLAVE_NODE .AND. PTRIST(STEP(INODE)) ==0) THEN ISHIFT_BUFR = ( MSGLEN + KEEP(34) ) / KEEP(34) LBUFR_LOC = LBUFR - ISHIFT_BUFR + 1 LBUFR_BYTES_LOC = LBUFR_LOC * KEEP(34) CALL DMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR(ISHIFT_BUFR), LBUFR_LOC, LBUFR_BYTES_LOC, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (IFLAG.LT.0) RETURN ENDIF IF ( SLAVE_NODE ) THEN LREQI = LROW + NBROWS_PACKET ELSE LREQI = NBROWS_PACKET END IF LREQA = int(LROW,8) CALL DMUMPS_GET_SIZE_NEEDED( & LREQI, LREQA, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR ) IF (IFLAG.LT.0) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA POSCONTRIB = POSFAC POSFAC = POSFAC + LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) IF ( SLAVE_NODE ) THEN IROW = IWPOS INDCOL = IWPOS + NBROWS_PACKET ELSE IROW = IWPOS INDCOL = -1 END IF IWPOS = IWPOS + LREQI IF ( SLAVE_NODE ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( INDCOL ), LROW, MPI_INTEGER, & COMM, IERR ) END IF DO I = 1, NBROWS_PACKET CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IROW + I - 1 ), 1, MPI_INTEGER, & COMM, IERR ) END DO IF (CB_IS_LR.AND.(NBROWS_PACKET.GT.0)) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBLRB_PACKET, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBCOLS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR ) ICOL_SHARED = 1+NBCOLS_ALREADY_SENT ENDIF IF ( SLAVE_NODE ) THEN IF ( KEEP(55) .eq. 0 ) THEN CALL DMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, INODE, IW, LIW, A, LA, & NBROW, LROW, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ELSE CALL DMUMPS_ELT_ASM_S_2_S_INIT( & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, & NBROW, LROW, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ENDIF ENDIF IF (CB_IS_LR.AND.(NBROWS_PACKET.GT.0)) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & MAXI_CLUSTER, 1, & MPI_INTEGER, COMM, IERR ) IROW_BEG = 1 IROW_END = NBROWS_PACKET LA_TEMP = NBROWS_PACKET*MAXI_CLUSTER NB_BLOCKS_UNPACKED = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(A_TEMP, LRB, I, ICOL_BEG, !$OMP& ICOL_END, ROW_LENGTH, allocok, BLOCKS_LEFT_2_UNPACK, !$OMP& PROMOTE_COST) #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) nullify(A_TEMP) IF (LA_TEMP.GT.0) THEN allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 550 ENDIF ENDIF BLOCKS_LEFT_2_UNPACK = .TRUE. DO WHILE (BLOCKS_LEFT_2_UNPACK) #if ! defined(BLR_NOOPENMP) !$OMP CRITICAL(contrib_type2_lrcb) #endif IF (NB_BLOCKS_UNPACKED.LT.NBLRB_PACKET) THEN CALL DMUMPS_MPI_UNPACK_LRB(BUFR, LBUFR, & LBUFR_BYTES, POSITION, LRB, KEEP8, & COMM, IFLAG, IERROR & ) NB_BLOCKS_UNPACKED = NB_BLOCKS_UNPACKED + 1 ICOL_BEG = ICOL_SHARED ICOL_SHARED = ICOL_SHARED + LRB%N ELSE BLOCKS_LEFT_2_UNPACK = .FALSE. ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END CRITICAL(contrib_type2_lrcb) #endif IF (.NOT.BLOCKS_LEFT_2_UNPACK) CYCLE IF (LRB%ISLR .AND. LRB%K.EQ.0) CYCLE IF (LRB%ISLR) THEN CALL dgemm('T','T', LRB%N, NBROWS_PACKET, LRB%K, ONE, & LRB%R(1,1), LRB%K, LRB%Q(IROW_BEG,1), LRB%M, & ZERO, A_TEMP(1), LRB%N) PROMOTE_COST = 2.0D0*LRB%N*NBROWS_PACKET*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE DO I = IROW_BEG, IROW_END A_TEMP( 1+(I-IROW_BEG)*LRB%N : (I-IROW_BEG+1)*LRB%N ) & = LRB%Q(I,1:LRB%N) ENDDO ENDIF CALL DEALLOC_LRB(LRB, KEEP8, KEEP(34)) DO I=1,NBROWS_PACKET IF (KEEP(50).EQ.0) THEN ROW_LENGTH = LROW ELSE ROW_LENGTH = LROW - NBROWS_PACKET + I ENDIF ICOL_END = min(ICOL_BEG+LRB%N-1, ROW_LENGTH) IF (SLAVE_NODE) THEN CALL DMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & 1, ICOL_END-ICOL_BEG+1, IW( IROW+I-1 ), & IW(INDCOL+ICOL_BEG-1), & A_TEMP(1+(I-1)*LRB%N), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, & LROW) ELSE CALL DMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, 1, ICOL_END-ICOL_BEG+1, IW( IROW+I-1 ), & A_TEMP(1+(I-1)*LRB%N), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LROW, ICOL_BEG & ) ENDIF ENDDO ENDDO IF (associated(A_TEMP)) deallocate(A_TEMP) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) 550 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) RETURN ELSE DO I=1,NBROWS_PACKET IF (KEEP(50).NE.0) THEN ROW_LENGTH = LROW - NBROWS_PACKET + I ELSE ROW_LENGTH = LROW ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSCONTRIB), & ROW_LENGTH, & MPI_DOUBLE_PRECISION, & COMM, IERR ) IF (SLAVE_NODE) THEN CALL DMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & 1, ROW_LENGTH, IW( IROW+I-1 ),IW(INDCOL), & A(POSCONTRIB), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, & ROW_LENGTH ) ELSE CALL DMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, 1, ROW_LENGTH, IW( IROW +I-1 ), & A(POSCONTRIB), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, ROW_LENGTH, 1 ) ENDIF ENDDO ENDIF IF (SLAVE_NODE) THEN IF (CB_IS_LR) THEN IF (NBROWS_PACKET.EQ.0) THEN IS_PANEL_FINISHED = .TRUE. ELSE IS_PANEL_FINISHED = ICOL_SHARED .GT. LROW ENDIF ELSE IS_PANEL_FINISHED = .TRUE. ENDIF IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW & .AND. IS_PANEL_FINISHED ) THEN IW(PTRIST(STEP(INODE))+XXNBPR) = & IW(PTRIST(STEP(INODE))+XXNBPR) - NBROW ENDIF CALL DMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, & NBROWS_PACKET, STEP, PTRIST, & ITLOC, RHS_MUMPS,KEEP,KEEP8) ENDIF IF ( .NOT. SLAVE_NODE ) THEN IF ( (NBROWS_ALREADY_SENT .EQ. 0) & .AND. (NBCOLS_ALREADY_SENT .EQ. 0) & ) THEN IF (KEEP(219).NE.0) THEN IF(KEEP(50) .EQ. 2) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NFS4FATHER, & 1, & MPI_INTEGER, & COMM, IERR ) IF(NFS4FATHER .GT. 0) THEN CALL DMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERROR = BUF_LMAX_ARRAY IFLAG = -13 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BUF_MAX_ARRAY, & NFS4FATHER, & MPI_DOUBLE_PRECISION, & COMM, IERR ) CALL DMUMPS_ASM_MAX(N, INODE, IW, LIW, A, LA, & ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8) ENDIF ENDIF ENDIF ENDIF IF (CB_IS_LR) THEN IF (NBROWS_PACKET.EQ.0) THEN IS_PANEL_FINISHED = .TRUE. ELSE IS_PANEL_FINISHED = ICOL_SHARED .GT. LROW ENDIF ELSE IS_PANEL_FINISHED = .TRUE. ENDIF IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW & .AND. IS_PANEL_FINISHED ) THEN DECR = 1 ISTCHK = PIMASTER(STEP(ISON)) SAME_PROC = ISTCHK .LT. IWPOSCB IW(PTLUST(STEP(INODE))+XXNBPR) = & IW(PTLUST(STEP(INODE))+XXNBPR) - DECR IF (SAME_PROC) THEN INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR ELSE INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ENDIF IW(INBPROCFILS_SON) = IW(INBPROCFILS_SON) - DECR IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN IF (SAME_PROC) THEN CALL DMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST, IW, LIW, STEP, KEEP,KEEP8) ENDIF IF (SAME_PROC) THEN ISTCHK = PTRIST(STEP(ISON)) PTRIST(STEP( ISON) ) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL DMUMPS_DM_SET_DYNPTR( IW(ISTCHK+XXS), A, LA, & PAMASTER(STEP(ISON)), IW(ISTCHK+XXD), & IW(ISTCHK+XXR), DYNPTR, IACHK, SIZFR8) CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK+XXD)) XXG_STATUS = IW(ISTCHK+XXG) CALL DMUMPS_FREE_BLOCK_CB_STATIC( & .FALSE., MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) IF ( DYN_SIZE .GT. 0_8 ) THEN CALL DMUMPS_DM_FREE_BLOCK( XXG_STATUS, & DYNPTR, DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF IF (IW(PTLUST(STEP(INODE))+XXNBPR) .EQ. 0) THEN IOLDPS = PTLUST(STEP(INODE)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) IF (NSLAVES.EQ.0) THEN NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS1 = abs(IW(IOLDPS + 2+KEEP(IXSZ))) POSELT = PTRAST(STEP(INODE)) PARPIV_T1 = -999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) NB_POSTPONED = max(NFRONT - ND(STEP(INODE)),0) CALL DMUMPS_PARPIVT1_SET_NVSCHUR_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1, & NB_POSTPONED) ENDIF CALL DMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, INODE+N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ENDIF ENDIF END IF IWPOS = IWPOS - LREQI LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA POSFAC = POSFAC - LREQA CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) RETURN END SUBROUTINE DMUMPS_PROCESS_CONTRIB_TYPE2 MUMPS_5.8.1/src/zfac_dist_arrowheads_omp.F0000664000175000017500000015130215042446441020402 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if ! defined(PCPRET) SUBROUTINE ZMUMPS_FAC_DIST_ARROWHEADS_OMP ( & N, NZ_loc8, & A_loc, IRN_loc, JCN_loc, & SIZESCAL, LSCAL, COLSCA, ROWSCA, & DBLARR, LDBLARR, INTARR, LINTARR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & FILS, KEEP,KEEP8, MYID, COMM, NBRECORDS, & & S, LA, root, roota, PROCNODE_STEPS, NPROCS, SLAVEF, PERM, STEP, & ICNTL, INFO, NSEND8, NLOCAL8, & ISTEP_TO_INIV2, CANDIDATES & ) !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZESCAL LOGICAL, INTENT(IN) :: LSCAL INTEGER(8), INTENT(IN) :: NZ_loc8 INTEGER, INTENT(IN) :: IRN_LOC(max(1_8,NZ_loc8)), & JCN_LOC(max(1_8,NZ_loc8)) COMPLEX(kind=8), INTENT(IN) :: A_loc(max(1_8,NZ_loc8)) DOUBLE PRECISION, INTENT(IN) :: ROWSCA(SIZESCAL), & COLSCA(SIZESCAL) INTEGER(8), INTENT(IN) :: LDBLARR, LINTARR COMPLEX(kind=8), INTENT(OUT) :: DBLARR( LDBLARR ) INTEGER, INTENT(OUT) :: INTARR( LINTARR ) INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER(8), INTENT(INOUT):: KEEP8(150) INTEGER, INTENT(IN) :: FILS( N ) INTEGER, INTENT(IN) :: MYID, COMM, NBRECORDS INTEGER(8), INTENT(IN) :: LA INTEGER, INTENT(IN) :: NPROCS, SLAVEF INTEGER(8), INTENT(OUT):: NSEND8, NLOCAL8 INTEGER, INTENT(IN) :: ISTEP_TO_INIV2(KEEP(71)) INTEGER, INTENT(IN) :: CANDIDATES(SLAVEF+1, max(1,KEEP(56))) COMPLEX(kind=8), INTENT(INOUT) :: S( LA ) TYPE (MUMPS_ROOT_STRUC), INTENT(INOUT) :: root TYPE (ZMUMPS_ROOT_STRUC), INTENT(INOUT) :: roota INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), & PERM( N ), STEP( N ) INTEGER, INTENT(INOUT) :: INFO( 80 ) INTEGER, INTENT(IN) :: ICNTL(60) INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: PTRAW INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFSENDI COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:,:) :: BUFSENDR INTEGER, ALLOCATABLE, DIMENSION(:,:) :: BUFSEND_POSRESERVED INTEGER, ALLOCATABLE, DIMENSION(:,:) :: BUFRECVI COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: BUFRECVR INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, ISENDREQI, ISENDREQR LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE INTEGER, ALLOCATABLE, DIMENSION(:) :: IRECVREQI, IRECVREQR INTEGER, ALLOCATABLE, DIMENSION(:):: RECV_BUF_STATUS INTEGER, PARAMETER :: Processed_IrecNeeded = 1 INTEGER, PARAMETER :: IrecPosted = 2 INTEGER, PARAMETER :: Received_NotProcessed = 3 INTEGER, PARAMETER :: Processed_IrecNotneeded = 4 INTEGER, PARAMETER :: Treating = 5 INTEGER, PARAMETER :: BeingTreatednotbyme = 6 INTEGER(8) :: ILOC8 INTEGER :: EndNZloc, NB_END_MSG_2_RECV LOGICAL :: MPI_End_Send, End_TreatRecvBuf, MPI_InvolvedinSend, & MPI_InvolvedinRecv, TH_InvolvedinComm, & NO_ATOMIC_Wsendbuf, NO_ATOMIC_Warrow, FINISHED, & TH_InvolvedinArrange, TH_InvolvedinTreatRecv INTEGER(8) :: PTR_ROOT INTEGER :: LOCAL_M, LOCAL_N, ARROW_ROOT LOGICAL :: EARLYT3ROOTINS LOGICAL :: I_AM_SLAVE, OneMPI INTEGER :: IARR1, IORG, NOMP, NOMP_MAX INTEGER :: ISTEP, ISLAVE_MAIN, IMAIN, JMAIN INTEGER :: allocok LOGICAL :: OMP_FLAG INTEGER(8) :: IS8MAIN INTEGER :: TYPE_NODE_P, MASTER_NODE_P, NBJ_P INTEGER(8) :: IS8_P INTEGER :: LP, MP LOGICAL :: LPOK, PROK INTEGER(8) :: NB_RANGE_8 INTEGER :: SHIFT_PID INTEGER :: NOMP_SHARED LOGICAL :: NOTHINGTOARRANGE_P INTEGER :: IOMP, NB_RANGE_P, EndNZloc_P LOGICAL :: ThWorking INTEGER(8) :: ILOC8_P INTEGER :: NBRECORDS_LOC INTEGER, PARAMETER :: MPI_MASTER = 0 NSEND8 = 0_8 NLOCAL8 = 0_8 LP = ICNTL(1) MP = ICNTL(2) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) NB_RANGE_8 = int(max(NBRECORDS/10, 1), 8) IF (KEEP(46).EQ.0) THEN SHIFT_PID = 1 ELSE SHIFT_PID = 0 ENDIF I_AM_SLAVE = (MYID.NE.0.OR.KEEP(46).EQ.1) OneMPI = NPROCS.EQ.1 IF (OneMPI) THEN NBRECORDS_LOC = 1 ELSE NBRECORDS_LOC = NBRECORDS ENDIF IF ( OneMPI.OR. & (KEEP(54).EQ.0.AND.(MYID.NE.MPI_MASTER)) & ) THEN MPI_InvolvedinSend = .FALSE. MPI_End_Send = .TRUE. ELSE MPI_InvolvedinSend = .TRUE. MPI_End_Send = .FALSE. ENDIF ALLOCATE( & BUFSENDI(NBRECORDS_LOC * 2 + 1, 2, NPROCS), & BUFSENDR(NBRECORDS_LOC, 2, NPROCS), & IACT(NPROCS), SEND_ACTIVE(NPROCS), & ISENDREQI(NPROCS), ISENDREQR(NPROCS), & BUFSEND_POSRESERVED(2, NPROCS), & stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LPOK ) THEN WRITE(LP,*) & '** Error allocating SEND buffers for matrix distribution' END IF INFO(1) = -13 INFO(2) = ( NBRECORDS_LOC * 2 + 1 ) * NPROCS * 2 + & NBRECORDS_LOC * NPROCS * 2 + & NPROCS*6 GOTO 20 END IF IF (.NOT.OneMPI) THEN DO ISLAVE_MAIN=1, NPROCS IACT (ISLAVE_MAIN) = 1 ISENDREQI(ISLAVE_MAIN) = MPI_REQUEST_NULL ISENDREQR(ISLAVE_MAIN) = MPI_REQUEST_NULL BUFSENDI(1, 1, ISLAVE_MAIN) = 0 BUFSEND_POSRESERVED(1,ISLAVE_MAIN)= 0 BUFSENDI(1, 2, ISLAVE_MAIN) = NBRECORDS_LOC BUFSEND_POSRESERVED(2,ISLAVE_MAIN)= NBRECORDS_LOC SEND_ACTIVE(ISLAVE_MAIN) = .FALSE. ENDDO ENDIF IF (OneMPI.OR. & (KEEP(54).EQ.0.AND.(MYID.EQ.MPI_MASTER)) & ) THEN NB_END_MSG_2_RECV = 0 MPI_InvolvedinRecv = .FALSE. End_TreatRecvBuf = .TRUE. ELSE IF (KEEP(54).EQ.0.AND.MYID.NE.MPI_MASTER) THEN NB_END_MSG_2_RECV = 1 MPI_InvolvedinRecv = .TRUE. End_TreatRecvBuf = .FALSE. ELSE NB_END_MSG_2_RECV = NPROCS-1 MPI_InvolvedinRecv = .TRUE. End_TreatRecvBuf = .FALSE. ENDIF ALLOCATE( & BUFRECVI(NBRECORDS_LOC * 2 + 1, NPROCS), & BUFRECVR(NBRECORDS_LOC, NPROCS), & IRECVREQI(NPROCS), IRECVREQR(NPROCS), & RECV_BUF_STATUS(NPROCS), & stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LPOK ) THEN WRITE(LP,*) & '** Error allocating RECV buffers for matrix distribution' END IF INFO(1) = -13 INFO(2) = ( NBRECORDS_LOC * 2 + 1 ) * NPROCS + & NBRECORDS_LOC * NPROCS + & NPROCS*3 GOTO 20 ENDIF IF (.NOT.OneMPI) THEN BUFRECVI(1, 1:NPROCS) = 0 IRECVREQI(1:NPROCS) = MPI_REQUEST_NULL IRECVREQR(1:NPROCS) = MPI_REQUEST_NULL RECV_BUF_STATUS (1:NPROCS)= Processed_IrecNeeded RECV_BUF_STATUS (MYID+1) = Processed_IrecNotneeded IF (KEEP(54).EQ.0) THEN DO ISLAVE_MAIN=1, NPROCS RECV_BUF_STATUS (ISLAVE_MAIN)= Processed_IrecNotneeded ENDDO IF (MYID.NE.MPI_MASTER) THEN RECV_BUF_STATUS(MPI_MASTER+1) = Processed_IrecNeeded ENDIF ENDIF ENDIF ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8) * 2_8, INFO(2) ) GOTO 20 END IF ALLOCATE( PTRAW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8) * KEEP(10), INFO(2) ) GOTO 20 END IF 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 100 ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) IF (I_AM_SLAVE) THEN DO JMAIN = 1, N ISTEP=STEP(JMAIN) IF (ISTEP .GT. 0) THEN IARR1 = PTRDEBARR( ISTEP ) IF ( IARR1 .GT. 0 ) THEN IMAIN = JMAIN IORG = 0 DO WHILE ( IMAIN .GT. 0 ) IORG = IORG + 1 IW4(IMAIN, 1) = NINCOLARR( IARR1 + IORG - 1 ) IW4(IMAIN, 2) = NINROWARR( IARR1 + IORG - 1 ) + & NINCOLARR( IARR1 + IORG - 1 ) IS8MAIN = PTR8ARR( IARR1 + IORG - 1 ) PTRAW( IMAIN ) = IS8MAIN INTARR( IS8MAIN ) = IMAIN DBLARR( IS8MAIN ) = ZERO IMAIN = FILS(IMAIN) ENDDO ENDIF ENDIF ENDDO IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL ZMUMPS_GET_ROOT_INFO(root, LOCAL_M, & LOCAL_N, PTR_ROOT, LA) CALL ZMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, S, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 ENDIF NOMP=1 !$ NOMP=omp_get_max_threads() NOMP_MAX = NOMP IF (NOMP_MAX.GT.2.AND.KEEP(399).EQ.2) THEN IF (.NOT.OneMPI) THEN NOMP_MAX = 2 ENDIF ENDIF IF (NOMP_MAX.GT.3.AND.KEEP(399).EQ.3) THEN IF (.NOT.OneMPI) THEN NOMP_MAX = 3 ENDIF ENDIF ILOC8 = 1_8 OMP_FLAG = ((NOMP .GE.2).AND.(KEEP(399).NE.99)) FINISHED = .FALSE. NOMP_SHARED = 1 !$OMP PARALLEL !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& PRIVATE( !$OMP& IOMP, ThWorking, ILOC8_P, NB_RANGE_P, !$OMP& NOTHINGTOARRANGE_P, EndNZloc_P, TH_InvolvedinComm, !$OMP& TH_InvolvedinTreatRecv, TH_InvolvedinArrange ) !$OMP& REDUCTION(+:NSEND8, NLOCAL8, ARROW_ROOT) !$OMP& IF (OMP_FLAG) IOMP = 0 !$ IOMP=omp_get_thread_num() !$OMP SINGLE !$ NOMP_SHARED= omp_get_num_threads() IF (OneMPI) THEN EndNZloc = NOMP_SHARED ELSE EndNZloc = max(1,NOMP_SHARED -1) IF ( KEEP(399).EQ.2.OR.KEEP(399).EQ.3 ) THEN EndNZloc = min(EndNZloc,1) ENDIF ENDIF IF (NZ_loc8.EQ.0_8) EndNZloc = 0 IF (.NOT.MPI_InvolvedinSend.AND.(EndNZloc.EQ.0)) EndNZloc=-1 NO_ATOMIC_Wsendbuf = ( NOMP_SHARED.EQ.1 ) NO_ATOMIC_Warrow = ( NOMP_SHARED.EQ.1 ) IF (NPROCS.GT.1) THEN NO_ATOMIC_Warrow = (NOMP_SHARED.LE.2) IF ( KEEP(399).EQ.2 .OR. KEEP(399).EQ.3) THEN NO_ATOMIC_Wsendbuf = .TRUE. IF (.NOT.MPI_InvolvedinSend) NO_ATOMIC_Warrow=.TRUE. IF (.NOT.MPI_InvolvedinRecv) NO_ATOMIC_Warrow=.TRUE. ENDIF ENDIF !$OMP END SINGLE ThWorking = OneMPI.OR. & (NOMP_SHARED.EQ.1) .OR. (IOMP.NE.0) TH_InvolvedinTreatRecv = (MPI_InvolvedinRecv.AND.ThWorking) IF ( TH_InvolvedinTreatRecv.AND. & (NOMP_SHARED.EQ.3).AND.(KEEP(399).EQ.3) ) THEN IF (IOMP.NE.2) TH_InvolvedinTreatRecv = .FALSE. ENDIF TH_InvolvedinArrange = ThWorking IF (.NOT.OneMPI.AND.ThWorking) THEN IF (KEEP(399).EQ.2.OR.KEEP(399).EQ.3) & THEN IF ((NOMP_SHARED.NE.1).AND.(IOMP.NE.1)) & TH_InvolvedinArrange = .FALSE. ENDIF ENDIF TH_InvolvedinComm = ((.NOT.OneMPI).AND.(IOMP.EQ.0)) NOTHINGTOARRANGE_P = (NZ_loc8.EQ.0_8) ILOC8_P = 0_8 DO WHILE ( .NOT.FINISHED ) IF (TH_InvolvedinComm) THEN CALL ZMUMPS_ARROW_TRY_PROGRESS_COMM ( IOMP, MYID, & NPROCS, NBRECORDS_LOC, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ENDIF IF (.NOT.ThWorking) THEN CALL MUMPS_USLEEP(20) GOTO 50 ENDIF IF (TH_InvolvedinTreatRecv) THEN CALL ZMUMPS_ARROW_TRY_TREAT_RECV_BUF ( IOMP, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, & NPROCS, NBRECORDS_LOC, N, IW4, & KEEP, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, S, LA, & NB_END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR, & NOMP_SHARED, EARLYT3ROOTINS, NO_ATOMIC_Warrow ) IF (NOMP_SHARED.EQ.1) THEN CALL ZMUMPS_ARROW_TRY_PROGRESS_COMM ( IOMP, MYID, & NPROCS, NBRECORDS_LOC, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ENDIF ENDIF IF (.NOT. NOTHINGTOARRANGE_P.AND.TH_InvolvedinArrange) THEN !$OMP ATOMIC CAPTURE ILOC8_P = ILOC8 ILOC8 = ILOC8 + NB_RANGE_8 !$OMP END ATOMIC IF (ILOC8_P.LE.NZ_loc8) THEN NB_RANGE_P = int(min(NB_RANGE_8, NZ_loc8-ILOC8_P+1)) CALL ZMUMPS_FAC_ARROW_ARRANGE ( MYID, IOMP, N, SHIFT_PID, & SLAVEF, LSCAL, NSEND8, NLOCAL8, ILOC8_P, NB_RANGE_P, & NZ_loc8, IRN_LOC, JCN_LOC, A_loc, SIZESCAL, ROWSCA, COLSCA, & ISTEP_TO_INIV2, CANDIDATES, KEEP, MPI_MASTER, NO_ATOMIC_Warrow, & NO_ATOMIC_Wsendbuf, TH_InvolvedinTreatRecv, & NPROCS, NBRECORDS_LOC, MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, IACT, & SEND_ACTIVE, BUFSEND_POSRESERVED, IRECVREQI, IRECVREQR, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, EndNZloc, MPI_End_Send, & End_TreatRecvBuf, & root, roota, PTR_ROOT, ARROW_ROOT, EARLYT3ROOTINS, & LOCAL_M, LOCAL_N, & S, LA, NB_END_MSG_2_RECV, PROCNODE_STEPS, IW4, PTRAW, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, PERM, STEP, INTARR, LINTARR, & DBLARR, LDBLARR, NOMP_SHARED ) ENDIF IF (ILOC8_P+NB_RANGE_8.GT.NZ_loc8) THEN IF (.NOT. NOTHINGTOARRANGE_P) THEN NOTHINGTOARRANGE_P=.TRUE. !$OMP ATOMIC CAPTURE EndNZloc = EndNZloc-1 EndNZloc_P = EndNZloc !$OMP END ATOMIC IF (MPI_End_Send.AND.EndNZloc_P.EQ.0) THEN !$OMP ATOMIC WRITE EndNZloc=-1 !$OMP END ATOMIC ENDIF ENDIF ENDIF ENDIF 50 CONTINUE !$OMP MASTER !$OMP ATOMIC WRITE FINISHED = ( (EndNZloc.EQ.-1) & .AND.(MPI_End_Send.OR.(.not.MPI_InvolvedinSend)) & .AND. End_TreatRecvBuf & ) !$OMP END ATOMIC !$OMP END MASTER ENDDO !$OMP END PARALLEL !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) !$OMP& PRIVATE(ISTEP, TYPE_NODE_P, MASTER_NODE_P, NBJ_P, !$OMP& IARR1, IS8_P ) !$OMP& IF (OMP_FLAG) DO ISTEP=1, KEEP(28) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE_P, MASTER_NODE_P, & PROCNODE_STEPS(ISTEP), KEEP(199) ) MASTER_NODE_P = MASTER_NODE_P + SHIFT_PID IF ( MASTER_NODE_P.NE.MYID.OR. & ( (TYPE_NODE_P.NE.1) .AND. (TYPE_NODE_P.NE.2) ) & ) CYCLE IARR1 = PTRDEBARR( ISTEP ) NBJ_P = NINCOLARR( IARR1) IF (NBJ_P.LE.0) CYCLE IS8_P = PTR8ARR( IARR1) + 1_8 CALL ZMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( IS8_P ), & DBLARR( IS8_P ), & NBJ_P, 1, NBJ_P ) ENDDO !$OMP END PARALLEL DO 100 CONTINUE IF (ALLOCATED(IW4)) DEALLOCATE( IW4 ) IF (ALLOCATED(PTRAW)) DEALLOCATE( PTRAW ) IF (ALLOCATED(BUFSENDI)) DEALLOCATE( BUFSENDI ) IF (ALLOCATED(BUFSENDR)) DEALLOCATE( BUFSENDR ) IF (ALLOCATED(BUFRECVI)) DEALLOCATE( BUFRECVI ) IF (ALLOCATED(BUFRECVR)) DEALLOCATE( BUFRECVR ) IF (ALLOCATED(IACT)) DEALLOCATE( IACT ) IF (ALLOCATED(ISENDREQI)) DEALLOCATE( ISENDREQI ) IF (ALLOCATED(ISENDREQR)) DEALLOCATE( ISENDREQR ) IF (ALLOCATED(IRECVREQI)) DEALLOCATE( IRECVREQI ) IF (ALLOCATED(IRECVREQR)) DEALLOCATE( IRECVREQR ) IF (ALLOCATED(SEND_ACTIVE)) DEALLOCATE( SEND_ACTIVE ) IF (ALLOCATED(BUFSEND_POSRESERVED)) & DEALLOCATE( BUFSEND_POSRESERVED ) IF (ALLOCATED(RECV_BUF_STATUS)) DEALLOCATE( RECV_BUF_STATUS ) RETURN END SUBROUTINE ZMUMPS_FAC_DIST_ARROWHEADS_OMP SUBROUTINE ZMUMPS_ARROW_TRY_PROGRESS_COMM ( IOMP, MYID, & NPROCS, NBRECORDS, MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) IMPLICIT NONE INTEGER, INTENT(IN) :: IOMP, MYID, NPROCS, NBRECORDS, COMM LOGICAL, INTENT(IN) :: MPI_InvolvedinSend, MPI_InvolvedinRecv INTEGER, INTENT(IN) :: NB_END_MSG_2_RECV INTEGER, INTENT(INOUT) :: EndNZloc LOGICAL, INTENT(INOUT) :: MPI_End_Send, End_TreatRecvBuf INTEGER, INTENT(INOUT) :: & ISENDREQI(NPROCS), ISENDREQR(NPROCS), & BUFSENDI(NBRECORDS * 2 + 1, 2, NPROCS), & IACT(NPROCS), BUFSEND_POSRESERVED(2,NPROCS) COMPLEX(kind=8), INTENT(INOUT) :: BUFSENDR(NBRECORDS, 2, NPROCS) LOGICAL, INTENT(INOUT) :: SEND_ACTIVE(NPROCS) INTEGER, INTENT(INOUT) :: & IRECVREQI(NPROCS), IRECVREQR(NPROCS), & BUFRECVI(NBRECORDS * 2 + 1, NPROCS), & RECV_BUF_STATUS(NPROCS) COMPLEX(kind=8), INTENT(INOUT) :: BUFRECVR(NBRECORDS, NPROCS) INTEGER, PARAMETER :: Processed_IrecNeeded = 1 INTEGER, PARAMETER :: IrecPosted = 2 INTEGER, PARAMETER :: Received_NotProcessed = 3 INTEGER, PARAMETER :: Processed_IrecNotneeded = 4 INTEGER, PARAMETER :: Treating = 5 INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: EndNZloc_copy, ISLAVE, NBREC, STATE, & NB_END_MSG_2_RECV_COPY, ISLAVE_RECV INTEGER :: IERR, IACT_P, NEXT_IACT INTEGER :: TAILLE_SEND_I, TAILLE_SEND_R LOGICAL :: FLAG, FLAGRECV, ALL_LAST_MESS_SENT INTEGER :: STATUS(MPI_STATUS_SIZE) IF (MPI_InvolvedinSend.and.(.NOT.MPI_End_Send)) THEN DO ISLAVE = 1, NPROCS IF (ISLAVE-1.EQ.MYID) CYCLE IF (SEND_ACTIVE( ISLAVE )) THEN CALL MPI_TEST( ISENDREQR( ISLAVE ), FLAG, STATUS, IERR ) IF (FLAG) THEN CALL MPI_WAIT( ISENDREQI( ISLAVE ), STATUS, IERR ) SEND_ACTIVE( ISLAVE ) = .FALSE. ENDIF ENDIF ENDDO !$OMP ATOMIC READ EndNZloc_copy = EndNZloc !$OMP END ATOMIC ALL_LAST_MESS_SENT = (EndNZloc_copy.EQ.0) IF (EndNZloc_copy.NE.-1) THEN DO ISLAVE=1, NPROCS IF (ISLAVE-1.EQ.MYID) CYCLE IF (EndNZloc_copy .EQ. 0) THEN NBREC = & min(BUFSEND_POSRESERVED(IACT(ISLAVE),ISLAVE),NBRECORDS) IF (NBREC.EQ.-99) CYCLE BUFSENDI(1,IACT(ISLAVE),ISLAVE) = - NBREC ELSE !$OMP ATOMIC READ NBREC = BUFSENDI(1,IACT(ISLAVE),ISLAVE) !$OMP END ATOMIC ENDIF IF ((EndNZloc_copy.EQ.0).OR.(NBREC.EQ.NBRECORDS)) THEN IF (.NOT.SEND_ACTIVE(ISLAVE)) THEN TAILLE_SEND_I = NBREC * 2 + 1 TAILLE_SEND_R = NBREC IACT_P = IACT(ISLAVE) CALL MPI_ISEND( BUFSENDI(1, IACT_P, ISLAVE ), & TAILLE_SEND_I, & MPI_INTEGER, ISLAVE - 1, & ARR_INT, COMM, & ISENDREQI( ISLAVE ), IERR ) CALL MPI_ISEND( BUFSENDR(1, IACT_P, ISLAVE ), & TAILLE_SEND_R, & MPI_DOUBLE_COMPLEX, ISLAVE - 1, & ARR_REAL, COMM, & ISENDREQR( ISLAVE ), IERR ) SEND_ACTIVE( ISLAVE ) = .TRUE. IF (EndNZloc_copy.NE.0) THEN NEXT_IACT = 3-IACT_P !$OMP ATOMIC WRITE BUFSEND_POSRESERVED(NEXT_IACT,ISLAVE) = 0 !$OMP END ATOMIC !$OMP ATOMIC WRITE BUFSENDI(1,NEXT_IACT,ISLAVE) = 0 !$OMP END ATOMIC !$OMP ATOMIC WRITE IACT( ISLAVE ) = NEXT_IACT !$OMP END ATOMIC ELSE BUFSEND_POSRESERVED(IACT_P,ISLAVE) = -99 ENDIF ELSE ALL_LAST_MESS_SENT=.FALSE. ENDIF ENDIF ENDDO ENDIF IF (EndNZloc_copy.EQ.0.AND.ALL_LAST_MESS_SENT) THEN EndNZloc = -1 EndNZloc_copy = -1 ENDIF IF (.NOT.MPI_End_Send) THEN IF ( (EndNZloc_copy.EQ.-1) ) THEN MPI_End_Send = .TRUE. DO ISLAVE = 1, NPROCS IF (ISLAVE-1.EQ.MYID) CYCLE IF (SEND_ACTIVE( ISLAVE )) THEN MPI_End_Send=.FALSE. EXIT ENDIF ENDDO ENDIF ENDIF ENDIF IF (MPI_InvolvedinRecv.AND.(.NOT.End_TreatRecvBuf)) THEN CALL MPI_TESTANY(NPROCS, IRECVREQR, ISLAVE_RECV, & FLAGRECV, STATUS,IERR) IF (FLAGRECV.AND.(ISLAVE_RECV.NE.MPI_UNDEFINED)) & THEN CALL MPI_WAIT(IRECVREQI(ISLAVE_RECV),STATUS,IERR) !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE_RECV)=Received_NotProcessed !$OMP END ATOMIC ENDIF DO ISLAVE = 1, NPROCS IF (ISLAVE - 1 .EQ. MYID) CYCLE !$OMP ATOMIC READ STATE = RECV_BUF_STATUS(ISLAVE) !$OMP END ATOMIC IF (STATE.EQ.Processed_IrecNeeded) THEN CALL MPI_IRECV ( BUFRECVI(1,ISLAVE), NBRECORDS * 2 + 1, & MPI_INTEGER, ISLAVE-1, ARR_INT, COMM, & IRECVREQI(ISLAVE), IERR) CALL MPI_IRECV ( BUFRECVR(1,ISLAVE), NBRECORDS, & MPI_DOUBLE_COMPLEX, ISLAVE-1, & ARR_REAL, COMM, & IRECVREQR(ISLAVE), IERR) !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = IrecPosted !$OMP END ATOMIC ENDIF ENDDO !$OMP ATOMIC READ NB_END_MSG_2_RECV_COPY = NB_END_MSG_2_RECV !$OMP END ATOMIC IF (NB_END_MSG_2_RECV_COPY.EQ.0) THEN End_TreatRecvBuf = .TRUE. DO ISLAVE = 1, NPROCS IF (ISLAVE - 1 .EQ. MYID) CYCLE IF (RECV_BUF_STATUS(ISLAVE).NE.Processed_IrecNotneeded) THEN End_TreatRecvBuf = .FALSE. EXIT ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_ARROW_TRY_PROGRESS_COMM SUBROUTINE ZMUMPS_ARROW_TRY_TREAT_RECV_BUF (IOMP, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, & NPROCS, NBRECORDS, N, IW4, & KEEP, LOCAL_M, LOCAL_N, root, roota, & PTR_ROOT, S, LA, & NB_END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR, & NOMP_SHARED, EARLYT3ROOTINS, NO_ATOMIC_Warrow ) USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER, INTENT(IN):: IOMP, NPROCS, NBRECORDS, N, MYID, SLAVEF, & NOMP_SHARED LOGICAL, INTENT(IN):: EARLYT3ROOTINS INTEGER, INTENT(IN):: BUFRECVI( NBRECORDS * 2 + 1, NPROCS ) COMPLEX(kind=8), INTENT(IN):: BUFRECVR( NBRECORDS, NPROCS ) INTEGER, INTENT(INOUT) :: RECV_BUF_STATUS(NPROCS) INTEGER, INTENT(INOUT):: IW4( N, 2 ) INTEGER, INTENT(IN):: KEEP(500) INTEGER, INTENT(INOUT):: NB_END_MSG_2_RECV INTEGER(8), INTENT(IN) :: PTRAW( N ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER, INTENT(IN) :: PERM( N ), STEP( N ) INTEGER, INTENT(IN) :: PROCNODE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER, INTENT(INOUT) :: INTARR( LINTARR ) INTEGER, INTENT(IN):: LOCAL_M, LOCAL_N INTEGER(8), INTENT(IN) :: PTR_ROOT, LA COMPLEX(kind=8), INTENT(INOUT) :: S( LA ), DBLARR( LDBLARR ) LOGICAL, INTENT(IN) :: NO_ATOMIC_Warrow INTEGER, PARAMETER :: Processed_IrecNeeded = 1 INTEGER, PARAMETER :: IrecPosted = 2 INTEGER, PARAMETER :: Received_NotProcessed = 3 INTEGER, PARAMETER :: Processed_IrecNotneeded = 4 INTEGER, PARAMETER :: Treating = 5 INTEGER, PARAMETER :: BeingTreatednotbyme = 6 INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE INTEGER STATE, ISLAVE DO ISLAVE =1, NPROCS IF (MYID.EQ.ISLAVE-1) CYCLE !$OMP ATOMIC READ STATE = RECV_BUF_STATUS(ISLAVE) !$OMP END ATOMIC IF (STATE.EQ.Treating) CYCLE IF (STATE.EQ.Received_NotProcessed) THEN IF (NOMP_SHARED.EQ.1) THEN RECV_BUF_STATUS(ISLAVE) = Treating STATE = Treating ELSE IF (KEEP(399).LE.3) THEN !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Treating !$OMP END ATOMIC STATE = Treating ELSE !$OMP CRITICAL(ARROW_RECV_BUF_STATUS) !$OMP ATOMIC READ STATE = RECV_BUF_STATUS(ISLAVE) !$OMP END ATOMIC IF (STATE.EQ.Received_NotProcessed) THEN !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Treating !$OMP END ATOMIC STATE = Treating ELSE STATE = BeingTreatednotbyme ENDIF !$OMP END CRITICAL(ARROW_RECV_BUF_STATUS) ENDIF ENDIF IF (STATE.NE.Treating) CYCLE IF (NO_ATOMIC_Warrow) THEN CALL ZMUMPS_ARROW_TREAT_RECV_BUF_1TH() ELSE CALL ZMUMPS_ARROW_TREAT_RECV_BUF() ENDIF ENDDO RETURN CONTAINS SUBROUTINE ZMUMPS_ARROW_TREAT_RECV_BUF() INTEGER :: IREC, NB_REC, TYPE_NODE INTEGER :: IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER(8) :: IS8 INTEGER :: IARR, JARR, IW4_CAPTURED INTEGER :: NB_END_MSG_2_RECV_COPY COMPLEX(kind=8) :: VAL LOGICAL :: LAST_MESSAGE LAST_MESSAGE = .FALSE. NB_REC = BUFRECVI( 1, ISLAVE ) TYPE_NODE = -998 IF ( NB_REC .LE. 0 ) THEN LAST_MESSAGE = .TRUE. !$OMP ATOMIC CAPTURE NB_END_MSG_2_RECV_COPY = NB_END_MSG_2_RECV NB_END_MSG_2_RECV = NB_END_MSG_2_RECV - 1 !$OMP END ATOMIC NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) GOTO 100 DO IREC = 1, NB_REC IARR = BUFRECVI( IREC * 2, ISLAVE ) JARR = BUFRECVI( IREC * 2 + 1, ISLAVE ) VAL = BUFRECVR( IREC, ISLAVE ) IF (EARLYT3ROOTINS) THEN TYPE_NODE = MUMPS_TYPENODE( & PROCNODE_STEPS(abs(STEP(abs( IARR )))), & KEEP(199) ) ENDIF IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JARR ) ELSE IPOSROOT = root%RG2L( JARR ) JPOSROOT = root%RG2L( -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 !$OMP ATOMIC UPDATE S( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = S( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL !$OMP END ATOMIC ELSE !$OMP ATOMIC UPDATE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL !$OMP END ATOMIC ENDIF ELSE IF (IARR.GE.0) THEN IF (IARR.EQ.JARR) THEN IS8 = PTRAW(IARR) !$OMP ATOMIC UPDATE DBLARR(IS8) = DBLARR(IS8) + VAL !$OMP END ATOMIC ELSE !$OMP ATOMIC CAPTURE IW4_CAPTURED= IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 !$OMP END ATOMIC IS8 = PTRAW(IARR)+int(IW4_CAPTURED,8) INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ELSE IARR = -IARR !$OMP ATOMIC CAPTURE IW4_CAPTURED = IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 !$OMP END ATOMIC IS8 = PTRAW(IARR) + int(IW4_CAPTURED,8) INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ENDDO 100 CONTINUE IF (LAST_MESSAGE) THEN !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Processed_IrecNotneeded !$OMP END ATOMIC ELSE !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Processed_IrecNeeded !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE ZMUMPS_ARROW_TREAT_RECV_BUF SUBROUTINE ZMUMPS_ARROW_TREAT_RECV_BUF_1TH() INTEGER :: IREC, NB_REC, TYPE_NODE INTEGER :: IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER(8) :: IS8 INTEGER :: IARR, JARR INTEGER :: NB_END_MSG_2_RECV_COPY COMPLEX(kind=8) :: VAL LOGICAL :: LAST_MESSAGE TYPE_NODE = -997 LAST_MESSAGE = .FALSE. NB_REC = BUFRECVI( 1, ISLAVE ) IF ( NB_REC .LE. 0 ) THEN LAST_MESSAGE = .TRUE. !$OMP ATOMIC CAPTURE NB_END_MSG_2_RECV_COPY = NB_END_MSG_2_RECV NB_END_MSG_2_RECV = NB_END_MSG_2_RECV - 1 !$OMP END ATOMIC NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) GOTO 100 DO IREC = 1, NB_REC IARR = BUFRECVI( IREC * 2, ISLAVE ) JARR = BUFRECVI( IREC * 2 + 1, ISLAVE ) VAL = BUFRECVR( IREC, ISLAVE ) IF (EARLYT3ROOTINS) THEN TYPE_NODE = MUMPS_TYPENODE( & PROCNODE_STEPS(abs(STEP(abs( IARR )))), & KEEP(199) ) ENDIF IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JARR ) ELSE IPOSROOT = root%RG2L( JARR ) JPOSROOT = root%RG2L( -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 S( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = S( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%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 IS8 = PTRAW(IARR) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IS8 = PTRAW(IARR)+IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ENDDO 100 CONTINUE IF (LAST_MESSAGE) THEN !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Processed_IrecNotneeded !$OMP END ATOMIC ELSE !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Processed_IrecNeeded !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE ZMUMPS_ARROW_TREAT_RECV_BUF_1TH END SUBROUTINE ZMUMPS_ARROW_TRY_TREAT_RECV_BUF SUBROUTINE ZMUMPS_FAC_ARROW_ARRANGE ( & MYID, IOMP, N, SHIFT_PID, SLAVEF, LSCAL, NSEND8, NLOCAL8, & ILOC8_P, NB_RANGE_P, NZ_loc8, IRN_LOC, JCN_LOC, A_loc, SIZESCAL, & ROWSCA, COLSCA, ISTEP_TO_INIV2, CANDIDATES, KEEP, MPI_MASTER, & NO_ATOMIC_Warrow, NO_ATOMIC_Wsendbuf, TH_InvolvedinTreatRecv, & NPROCS, NBRECORDS, MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, IACT, & SEND_ACTIVE, BUFSEND_POSRESERVED, IRECVREQI, IRECVREQR, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, EndNZloc, MPI_End_Send, & End_TreatRecvBuf, & root, roota, & PTR_ROOT, ARROW_ROOT, EARLYT3ROOTINS, LOCAL_M, LOCAL_N, & S, LA, NB_END_MSG_2_RECV, PROCNODE_STEPS, IW4, PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, INTARR, LINTARR, DBLARR, LDBLARR, NOMP_SHARED ) !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, IOMP, N, SHIFT_PID, & SLAVEF, SIZESCAL, MPI_MASTER INTEGER, INTENT(IN) :: NB_RANGE_P, KEEP(500) INTEGER(8), INTENT(IN) :: NZ_loc8, ILOC8_P INTEGER(8), INTENT(INOUT):: NSEND8, NLOCAL8 INTEGER, INTENT(IN) :: IRN_LOC(max(1_8,NZ_loc8)), & JCN_LOC(max(1_8,NZ_loc8)) INTEGER, INTENT(IN):: ISTEP_TO_INIV2(KEEP(71)) INTEGER, INTENT(IN):: CANDIDATES(SLAVEF+1, max(1,KEEP(56))) COMPLEX(kind=8), INTENT(IN):: A_loc(max(1_8,NZ_loc8)) DOUBLE PRECISION, INTENT(IN) :: ROWSCA(SIZESCAL), & COLSCA(SIZESCAL) LOGICAL, INTENT(IN):: NO_ATOMIC_Warrow, NO_ATOMIC_Wsendbuf, & TH_InvolvedinTreatRecv INTEGER, INTENT(IN) :: NPROCS, NBRECORDS, COMM, NOMP_SHARED LOGICAL, INTENT(IN) :: MPI_InvolvedinSend, MPI_InvolvedinRecv, & LSCAL INTEGER, INTENT(INOUT) :: EndNZloc LOGICAL, INTENT(INOUT) :: MPI_End_Send, End_TreatRecvBuf INTEGER, INTENT(INOUT) :: ISENDREQI(NPROCS), ISENDREQR(NPROCS), & BUFSENDI(NBRECORDS * 2 + 1, 2, NPROCS), & IACT(NPROCS), BUFSEND_POSRESERVED(2,NPROCS) COMPLEX(kind=8), INTENT(INOUT) :: BUFSENDR(NBRECORDS, 2, NPROCS) LOGICAL, INTENT(INOUT) :: SEND_ACTIVE(NPROCS) INTEGER, INTENT(INOUT) :: IRECVREQI(NPROCS), IRECVREQR(NPROCS), & BUFRECVI(NBRECORDS * 2 + 1, NPROCS), & RECV_BUF_STATUS(NPROCS) COMPLEX(kind=8), INTENT(INOUT) :: BUFRECVR(NBRECORDS, NPROCS) INTEGER, PARAMETER :: Processed_IrecNeeded = 1 INTEGER, PARAMETER :: IrecPosted = 2 INTEGER, PARAMETER :: Received_NotProcessed = 3 INTEGER, PARAMETER :: Processed_IrecNotneeded = 4 INTEGER, PARAMETER :: Treating = 5 TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER, INTENT(IN) :: LOCAL_M, LOCAL_N LOGICAL, INTENT(IN) :: EARLYT3ROOTINS INTEGER, INTENT(INOUT) :: ARROW_ROOT INTEGER, INTENT(INOUT):: IW4( N, 2 ) INTEGER, INTENT(INOUT):: NB_END_MSG_2_RECV INTEGER(8), INTENT(IN) :: PTRAW( N ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER, INTENT(IN) :: PERM( N ), STEP( N ) INTEGER, INTENT(IN) :: PROCNODE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER, INTENT(INOUT) :: INTARR( LINTARR ) INTEGER(8), INTENT(IN) :: PTR_ROOT, LA COMPLEX(kind=8), INTENT(INOUT) :: S( LA ), DBLARR( LDBLARR ) INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT INTEGER :: DEST, JSEND, ISEND , DEST_SAVE INTEGER :: I, INIV2, NCAND, T4MASTER INTEGER :: IOLD, JOLD, IARR, TYPESPLIT INTEGER(8) :: IS8, IZ8, LAST8 LOGICAL :: T4_MASTER_CONCERNED INTEGER :: MASTER_NODE, TYPE_NODE, ISTEP_P INTEGER :: IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER :: IROW_GRID, JCOL_GRID, IW4_CAPTURED LOGICAL :: LOCAL_ASSEMBLY, LOCAL COMPLEX(kind=8) :: VAL INTEGER :: ISTEP_T3_1PROC LAST8 = ILOC8_P + int(NB_RANGE_P-1,8) LOCAL_ASSEMBLY = (NPROCS.EQ.1) IF (NPROCS.EQ.1 .AND. KEEP(38).EQ.0) THEN TYPE_NODE = 1 ISTEP_T3_1PROC = -9999 ELSE IF (NPROCS.EQ.1 .AND. KEEP(38).NE.0) THEN ISTEP_T3_1PROC = STEP(KEEP(38)) ELSE ISTEP_T3_1PROC = -99999 ENDIF DO IZ8=ILOC8_P, LAST8 IOLD = IRN_loc(IZ8) JOLD = JCN_loc(IZ8) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE ENDIF IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = IOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF VAL = A_loc(IZ8) IF (LSCAL) THEN VAL = VAL * ROWSCA(IOLD)*COLSCA(JOLD) ENDIF IF (NPROCS.GT.1 .OR. KEEP(38).NE.0) THEN ISTEP_P = abs(STEP(IARR)) IF ( NPROCS.EQ.1 .AND. ISTEP_P.NE.ISTEP_T3_1PROC ) THEN TYPE_NODE=1 ELSE IF (NPROCS.EQ.1) THEN TYPE_NODE=3 IF (EARLYT3ROOTINS) THEN IF ( ISEND < 0 ) THEN IPOSROOT = root%RG2L(JSEND) JPOSROOT = root%RG2L(IARR ) ELSE IPOSROOT = root%RG2L(IARR ) JPOSROOT = root%RG2L(JSEND) END IF END IF ELSE ISTEP_P = abs(STEP(IARR)) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP_P), KEEP(199) ) MASTER_NODE = MASTER_NODE + SHIFT_PID T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 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 INIV2 = ISTEP_TO_INIV2(ISTEP_P) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP_P), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER= & CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & + SHIFT_PID ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND < 0 ) THEN IPOSROOT = root%RG2L(JSEND) JPOSROOT = root%RG2L(IARR ) ELSE IPOSROOT = root%RG2L(IARR ) JPOSROOT = root%RG2L(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 + SHIFT_PID ELSE DEST = -2 ENDIF ENDIF IF (DEST .eq. -1) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .EQ. -2) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .eq.MYID ) THEN NLOCAL8 = NLOCAL8 + 1_8 ELSE NSEND8 = NSEND8 + 1_8 ENDIF ENDIF LOCAL_ASSEMBLY = .FALSE. IF ( DEST.EQ.-1) THEN INIV2 = ISTEP_TO_INIV2(ISTEP_P) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79) .GT. 0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) + SHIFT_PID IF (DEST.LT.0) EXIT LOCAL = (DEST.EQ.MYID) IF (LOCAL) LOCAL_ASSEMBLY = .TRUE. IF (LOCAL) CYCLE IF (I.EQ.NCAND+1) CYCLE CALL ZMUMPS_DIST_FILL_SEND_BUFFER() ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) + SHIFT_PID LOCAL = (DEST.EQ.MYID) IF (LOCAL) LOCAL_ASSEMBLY = .TRUE. IF (LOCAL) CYCLE CALL ZMUMPS_DIST_FILL_SEND_BUFFER() ENDDO ENDIF IF ( LOCAL_ASSEMBLY ) THEN DEST_SAVE = DEST DEST = MASTER_NODE IF (DEST.NE.MYID) & CALL ZMUMPS_DIST_FILL_SEND_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER IF (DEST.NE.MYID) & CALL ZMUMPS_DIST_FILL_SEND_BUFFER() ENDIF DEST = DEST_SAVE ELSE DEST=MASTER_NODE LOCAL_ASSEMBLY = (DEST.EQ.MYID) IF (.NOT.LOCAL_ASSEMBLY) & CALL ZMUMPS_DIST_FILL_SEND_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER LOCAL_ASSEMBLY = (DEST.EQ.MYID) IF (.NOT.LOCAL_ASSEMBLY) & CALL ZMUMPS_DIST_FILL_SEND_BUFFER() ENDIF ENDIF ELSE IF (DEST .GE. 0) THEN LOCAL_ASSEMBLY = (DEST.EQ.MYID) IF (.NOT.LOCAL_ASSEMBLY) & CALL ZMUMPS_DIST_FILL_SEND_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER LOCAL_ASSEMBLY = (DEST.EQ.MYID) IF (.NOT.LOCAL_ASSEMBLY) & CALL ZMUMPS_DIST_FILL_SEND_BUFFER() ENDIF ELSE IF (DEST .EQ. -2) THEN DO I = 0, SLAVEF-1 DEST=I + SHIFT_PID IF (DEST.NE.MYID) & CALL ZMUMPS_DIST_FILL_SEND_BUFFER() ENDDO IF (SHIFT_PID.EQ.1.AND.MYID.EQ.MPI_MASTER) THEN LOCAL_ASSEMBLY=.FALSE. ELSE LOCAL_ASSEMBLY=.TRUE. ENDIF ENDIF ENDIF ENDIF IF (LOCAL_ASSEMBLY) THEN IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN !$OMP ATOMIC UPDATE S( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = S( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL !$OMP END ATOMIC ELSE !$OMP ATOMIC UPDATE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL !$OMP END ATOMIC ENDIF ELSE IF (NO_ATOMIC_Warrow) THEN IF (ISEND.EQ.JSEND) THEN IS8 = PTRAW(ISEND) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IF (ISEND.GE.0) THEN IS8 = PTRAW(IARR)+IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL ELSE IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL ENDIF ELSE IF (ISEND.EQ.JSEND) THEN IS8 = PTRAW(ISEND) !$OMP ATOMIC UPDATE DBLARR(IS8) = DBLARR(IS8) + VAL !$OMP END ATOMIC ELSE IF (ISEND.GE.0) THEN !$OMP ATOMIC CAPTURE IW4_CAPTURED = IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 !$OMP END ATOMIC IS8 = PTRAW(IARR) + int(IW4_CAPTURED,8) INTARR(IS8) = JSEND DBLARR(IS8) = VAL ELSE !$OMP ATOMIC CAPTURE IW4_CAPTURED = IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 !$OMP END ATOMIC IS8 = PTRAW(IARR) + int(IW4_CAPTURED,8) INTARR(IS8) = JSEND DBLARR(IS8) = VAL ENDIF ENDIF ENDIF ENDIF ENDDO RETURN CONTAINS SUBROUTINE ZMUMPS_DIST_FILL_SEND_BUFFER( ) INTEGER IREQ, IACT_P, ISLAVE ISLAVE = DEST+1 100 CONTINUE !$OMP ATOMIC READ IACT_P = IACT(ISLAVE) !$OMP END ATOMIC IF (NO_ATOMIC_Wsendbuf) THEN BUFSEND_POSRESERVED(IACT_P,ISLAVE) = & BUFSEND_POSRESERVED(IACT_P, ISLAVE) + 1 IREQ = BUFSEND_POSRESERVED(IACT_P, ISLAVE) IF (IREQ > NBRECORDS ) THEN IF (IREQ > huge(NBRECORDS)-1000 - NOMP_SHARED-2) THEN BUFSEND_POSRESERVED(IACT_P, ISLAVE) = min(NBRECORDS+1, & BUFSEND_POSRESERVED(IACT_P, ISLAVE) ) ENDIF IF (NOMP_SHARED.EQ.1) & CALL ZMUMPS_ARROW_TRY_PROGRESS_COMM (IOMP, & MYID, NPROCS, NBRECORDS, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) IF (TH_InvolvedinTreatRecv) & CALL ZMUMPS_ARROW_TRY_TREAT_RECV_BUF (IOMP, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, & NPROCS, NBRECORDS, N, IW4, & KEEP, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, S, LA, & NB_END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR, & NOMP_SHARED, EARLYT3ROOTINS, NO_ATOMIC_Warrow) IF (NOMP_SHARED.EQ.1) THEN CALL ZMUMPS_ARROW_TRY_PROGRESS_COMM (IOMP, & MYID, NPROCS, NBRECORDS, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ELSE IF (.NOT.TH_InvolvedinTreatRecv) THEN CALL MUMPS_USLEEP(200) ELSE CALL MUMPS_USLEEP(20) ENDIF ENDIF GOTO 100 ENDIF BUFSENDI(IREQ*2,IACT_P,ISLAVE) = ISEND BUFSENDI(IREQ*2+1,IACT_P,ISLAVE) = JSEND BUFSENDR(IREQ,IACT_P,ISLAVE ) = VAL IF (IREQ.EQ.NBRECORDS) THEN !$OMP ATOMIC WRITE BUFSENDI(1,IACT_P,ISLAVE) = NBRECORDS !$OMP END ATOMIC ENDIF ELSE !$OMP ATOMIC CAPTURE BUFSEND_POSRESERVED(IACT_P,ISLAVE) = & BUFSEND_POSRESERVED(IACT_P, ISLAVE) + 1 IREQ = BUFSEND_POSRESERVED(IACT_P, ISLAVE) !$OMP END ATOMIC IF (IREQ > huge(NBRECORDS)-NOMP_SHARED-2) THEN !$OMP ATOMIC UPDATE BUFSEND_POSRESERVED(IACT_P, ISLAVE) = min(NBRECORDS+1, & BUFSEND_POSRESERVED(IACT_P, ISLAVE) ) !$OMP END ATOMIC ENDIF IF (IREQ > NBRECORDS ) THEN IF (NOMP_SHARED.EQ.1) THEN CALL ZMUMPS_ARROW_TRY_PROGRESS_COMM (IOMP, & MYID, NPROCS, NBRECORDS, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ENDIF IF (TH_InvolvedinTreatRecv) & CALL ZMUMPS_ARROW_TRY_TREAT_RECV_BUF (IOMP, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, & NPROCS, NBRECORDS, N, IW4, & KEEP, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, S, LA, & NB_END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR, & NOMP_SHARED, EARLYT3ROOTINS, NO_ATOMIC_Warrow) IF (NOMP_SHARED.EQ.1) THEN CALL ZMUMPS_ARROW_TRY_PROGRESS_COMM (IOMP, & MYID, NPROCS, NBRECORDS, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ELSE IF (.NOT.TH_InvolvedinTreatRecv) THEN CALL MUMPS_USLEEP(200) ELSE CALL MUMPS_USLEEP(20) ENDIF ENDIF GOTO 100 ENDIF BUFSENDI(IREQ*2,IACT_P,ISLAVE) = ISEND BUFSENDI(IREQ*2+1,IACT_P,ISLAVE) = JSEND BUFSENDR(IREQ,IACT_P,ISLAVE ) = VAL !$OMP ATOMIC UPDATE BUFSENDI(1,IACT_P,ISLAVE) = BUFSENDI(1,IACT_P,ISLAVE) + 1 !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE ZMUMPS_DIST_FILL_SEND_BUFFER END SUBROUTINE ZMUMPS_FAC_ARROW_ARRANGE #endif MUMPS_5.8.1/src/zfac_determinant.F0000664000175000017500000002032615042446441016660 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_UPDATEDETER(PIV, DETER, NEXP) IMPLICIT NONE COMPLEX(kind=8), intent(in) :: PIV COMPLEX(kind=8), intent(inout) :: DETER INTEGER, intent(inout) :: NEXP DOUBLE PRECISION R_PART, C_PART INTEGER NEXP_LOC DETER=DETER*PIV R_PART=dble(DETER) C_PART=aimag(DETER) NEXP_LOC = exponent(abs(R_PART)+abs(C_PART)) NEXP = NEXP + NEXP_LOC R_PART=scale(R_PART, -NEXP_LOC) C_PART=scale(C_PART, -NEXP_LOC) DETER=cmplx(R_PART,C_PART,kind=kind(DETER)) RETURN END SUBROUTINE ZMUMPS_UPDATEDETER SUBROUTINE ZMUMPS_UPDATEDETER_SCALING(PIV, DETER, NEXP) IMPLICIT NONE DOUBLE PRECISION, intent(in) :: PIV DOUBLE PRECISION, intent(inout) :: DETER INTEGER, intent(inout) :: NEXP DETER=DETER*fraction(PIV) NEXP=NEXP+exponent(PIV)+exponent(DETER) DETER=fraction(DETER) RETURN END SUBROUTINE ZMUMPS_UPDATEDETER_SCALING SUBROUTINE ZMUMPS_GETDETER2D(BLOCK_SIZE,IPIV, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, & DETER,NEXP,SYM) IMPLICIT NONE INTEGER, intent (in) :: SYM INTEGER, intent (inout) :: NEXP COMPLEX(kind=8), intent (inout) :: DETER INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, & LOCAL_M, LOCAL_N, N INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) COMPLEX(kind=8), intent(in) :: A(*) INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, & ROW_PROC,COL_PROC, K DI = LOCAL_M + 1 NBLOCK = ( N - 1 ) / BLOCK_SIZE DO IBLOCK = 0, NBLOCK ROW_PROC = mod( IBLOCK, NPROW ) IF ( MYROW.EQ.ROW_PROC ) THEN COL_PROC = mod( IBLOCK, NPCOL ) IF ( MYCOL.EQ.COL_PROC ) THEN ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE I = ILOC + JLOC * LOCAL_M + 1 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M & + 1 K=1 DO WHILE ( I .LT. IMX ) CALL ZMUMPS_UPDATEDETER(A(I),DETER,NEXP) IF (SYM.EQ.1) THEN CALL ZMUMPS_UPDATEDETER(A(I),DETER,NEXP) ENDIF IF (SYM.NE.1) THEN IF (IPIV(ILOC+K) .NE. IBLOCK*BLOCK_SIZE+K) THEN DETER = -DETER ENDIF ENDIF K = K + 1 I = I + DI END DO END IF END IF END DO RETURN END SUBROUTINE ZMUMPS_GETDETER2D SUBROUTINE ZMUMPS_DETER_REDUCTION( & COMM, DETER_IN, NEXP_IN, & DETER_OUT, NEXP_OUT, NPROCS) IMPLICIT NONE INTEGER, intent(in) :: COMM, NPROCS COMPLEX(kind=8), intent(in) :: DETER_IN INTEGER,intent(in) :: NEXP_IN COMPLEX(kind=8),intent(out):: DETER_OUT INTEGER,intent(out):: NEXP_OUT INTEGER :: IERR_MPI EXTERNAL ZMUMPS_DETERREDUCE_FUNC INTEGER TWO_SCALARS_TYPE, DETERREDUCE_OP COMPLEX(kind=8) :: INV(2) COMPLEX(kind=8) :: OUTV(2) INCLUDE 'mpif.h' IF (NPROCS .EQ. 1) THEN DETER_OUT = DETER_IN NEXP_OUT = NEXP_IN RETURN ENDIF CALL MPI_TYPE_CONTIGUOUS(2, MPI_DOUBLE_COMPLEX, & TWO_SCALARS_TYPE, & IERR_MPI) CALL MPI_TYPE_COMMIT(TWO_SCALARS_TYPE, IERR_MPI) CALL MPI_OP_CREATE(ZMUMPS_DETERREDUCE_FUNC, & .TRUE., & DETERREDUCE_OP, & IERR_MPI) INV(1)=DETER_IN INV(2)=cmplx(NEXP_IN,kind=kind(INV)) CALL MPI_ALLREDUCE( INV, OUTV, 1, TWO_SCALARS_TYPE, & DETERREDUCE_OP, COMM, IERR_MPI) CALL MPI_OP_FREE(DETERREDUCE_OP, IERR_MPI) CALL MPI_TYPE_FREE(TWO_SCALARS_TYPE, IERR_MPI) DETER_OUT = OUTV(1) NEXP_OUT = int(OUTV(2)) RETURN END SUBROUTINE ZMUMPS_DETER_REDUCTION SUBROUTINE ZMUMPS_DETERREDUCE_FUNC(INV, INOUTV, NEL, DATATYPE) IMPLICIT NONE #if defined(WORKAROUNDINTELILP64MPI2INTEGER) || defined(WORKAROUNDILP64MPICUSTOMREDUCE) INTEGER(4), INTENT(IN) :: NEL, DATATYPE #else INTEGER, INTENT(IN) :: NEL, DATATYPE #endif COMPLEX(kind=8), INTENT(IN) :: INV ( 2 * NEL ) COMPLEX(kind=8), INTENT(INOUT) :: INOUTV ( 2 * NEL ) INTEGER I, TMPEXPIN, TMPEXPINOUT DO I = 1, NEL TMPEXPIN = int(INV (I*2)) TMPEXPINOUT = int(INOUTV(I*2)) CALL ZMUMPS_UPDATEDETER(INV(I*2-1), & INOUTV(I*2-1), & TMPEXPINOUT) TMPEXPINOUT = TMPEXPINOUT + TMPEXPIN INOUTV(I*2) = cmplx(TMPEXPINOUT,kind=kind(INOUTV)) ENDDO RETURN END SUBROUTINE ZMUMPS_DETERREDUCE_FUNC SUBROUTINE ZMUMPS_DETER_SQUARE(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP COMPLEX(kind=8), intent (inout) :: DETER DETER=DETER*DETER NEXP=NEXP+NEXP RETURN END SUBROUTINE ZMUMPS_DETER_SQUARE SUBROUTINE ZMUMPS_DETER_SCALING_INVERSE(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP DOUBLE PRECISION, intent (inout) :: DETER DETER=1.0D0/DETER NEXP=-NEXP RETURN END SUBROUTINE ZMUMPS_DETER_SCALING_INVERSE SUBROUTINE ZMUMPS_DETER_SIGN_PERM(DETER, N, PERM) IMPLICIT NONE COMPLEX(kind=8), intent(inout) :: DETER INTEGER, intent(in) :: N INTEGER, intent(inout) :: PERM(N) INTEGER I, J, K K = 0 DO I = 1, N IF (PERM(I) .LT. 0) THEN PERM(I)=-PERM(I) ELSE J = PERM(I) DO WHILE (J.NE.I) PERM(J)=-PERM(J) K = K + 1 J = -PERM(J) ENDDO ENDIF ENDDO IF (mod(K,2).EQ.1) THEN DETER = -DETER ENDIF RETURN END SUBROUTINE ZMUMPS_DETER_SIGN_PERM SUBROUTINE ZMUMPS_PAR_ROOT_MINMAX_PIV_UPD ( & BLOCK_SIZE,IPIV, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, & DKEEP, KEEP, SYM) USE ZMUMPS_FAC_FRONT_AUX_M, & ONLY : ZMUMPS_UPDATE_MINMAX_PIVOT IMPLICIT NONE INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, & LOCAL_M, LOCAL_N, N, SYM INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) COMPLEX(kind=8), intent(in) :: A(*) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER, INTENT(IN) :: KEEP(500) INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, & ROW_PROC,COL_PROC, K DOUBLE PRECISION :: ABSPIVOT DI = LOCAL_M + 1 NBLOCK = ( N - 1 ) / BLOCK_SIZE DO IBLOCK = 0, NBLOCK ROW_PROC = mod( IBLOCK, NPROW ) IF ( MYROW.EQ.ROW_PROC ) THEN COL_PROC = mod( IBLOCK, NPCOL ) IF ( MYCOL.EQ.COL_PROC ) THEN ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE I = ILOC + JLOC * LOCAL_M + 1 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M & + 1 K=1 DO WHILE ( I .LT. IMX ) IF (SYM.NE.1) THEN ABSPIVOT = abs(A(I)) ELSE ABSPIVOT = abs(A(I)*A(I)) ENDIF CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( ABSPIVOT, & DKEEP, KEEP, .FALSE.) K = K + 1 I = I + DI END DO END IF END IF END DO RETURN END SUBROUTINE ZMUMPS_PAR_ROOT_MINMAX_PIV_UPD MUMPS_5.8.1/src/cfac_sol_l0omp_m.F0000664000175000017500000003360015042446440016535 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FACSOL_L0OMP_M PRIVATE PUBLIC :: CMUMPS_INIT_L0_OMP_FACTORS & , CMUMPS_FREE_L0_OMP_FACTORS #if ! defined(NO_SAVE_RESTORE) & , CMUMPS_SAVE_RESTORE_L0FACARRAY #endif #if ! defined(NO_SAVE_RESTORE) #endif #if ! defined(NO_SAVE_RESTORE) INCLUDE 'mumps_save_restore_modes.h' #endif CONTAINS SUBROUTINE CMUMPS_INIT_L0_OMP_FACTORS(id_L0_OMP_FACTORS) USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (CMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & id_L0_OMP_FACTORS INTEGER I IF (associated(id_L0_OMP_FACTORS)) THEN DO I=1, size(id_L0_OMP_FACTORS) NULLIFY(id_L0_OMP_FACTORS(I)%A) ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_INIT_L0_OMP_FACTORS SUBROUTINE CMUMPS_FREE_L0_OMP_FACTORS(id_L0_OMP_FACTORS) USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (CMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & id_L0_OMP_FACTORS INTEGER I IF (associated(id_L0_OMP_FACTORS)) THEN DO I=1, size(id_L0_OMP_FACTORS) IF (associated(id_L0_OMP_FACTORS(I)%A)) THEN DEALLOCATE(id_L0_OMP_FACTORS(I)%A) NULLIFY(id_L0_OMP_FACTORS(I)%A) ENDIF ENDDO DEALLOCATE(id_L0_OMP_FACTORS) NULLIFY(id_L0_OMP_FACTORS) ENDIF RETURN END SUBROUTINE CMUMPS_FREE_L0_OMP_FACTORS #if ! defined(NO_SAVE_RESTORE) SUBROUTINE CMUMPS_SAVE_RESTORE_L0FACARRAY(L0_OMP_FACTORS & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (CMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: L0_OMP_FACTORS INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: j1,NbRecords,NbSubRecords,size_array1,dummy,allocok,err INTEGER:: SIZE_GEST_L0FAC_ARRAY, & SIZE_GEST_L0FAC_ARRAY_j1 INTEGER(4) :: I4 INTEGER(8):: SIZE_VARIABLES_L0FAC_ARRAY, & SIZE_VARIABLES_L0FAC_ARRAY_j1 SIZE_GEST = 0 SIZE_VARIABLES = 0_8 SIZE_GEST_L0FAC_ARRAY=0 SIZE_VARIABLES_L0FAC_ARRAY=0 SIZE_GEST_L0FAC_ARRAY_j1=0 SIZE_VARIABLES_L0FAC_ARRAY_j1=0 NbRecords = 0 IF (mode.EQ.memory_save_mode) THEN IF (associated(L0_OMP_FACTORS)) THEN NbRecords = 1 SIZE_GEST = SIZE_INT SIZE_VARIABLES = 0 DO j1=1,size(L0_OMP_FACTORS) CALL CMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_L0FAC_ARRAY_j1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_L0FAC_ARRAY=SIZE_GEST_L0FAC_ARRAY+ & SIZE_GEST_L0FAC_ARRAY_j1 SIZE_VARIABLES_L0FAC_ARRAY=SIZE_VARIABLES_L0FAC_ARRAY+ & SIZE_VARIABLES_L0FAC_ARRAY_j1 IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords = 2 SIZE_GEST = 2*SIZE_INT SIZE_VARIABLES = 0 ENDIF ELSEIF (mode.EQ.save_mode) THEN IF (associated(L0_OMP_FACTORS)) THEN NbRecords = 1 SIZE_GEST = SIZE_INT SIZE_VARIABLES = 0 write(unit,iostat=err) size(L0_OMP_FACTORS) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 DO j1=1,size(L0_OMP_FACTORS) CALL CMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_L0FAC_ARRAY_J1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF ELSE IF (mode.EQ.restore_mode) THEN NULLIFY(L0_OMP_FACTORS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 allocate(L0_OMP_FACTORS(size_array1), stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size(L0_OMP_FACTORS) CALL CMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_L0FAC_ARRAY_J1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_L0FAC_ARRAY=SIZE_GEST_L0FAC_ARRAY+ & SIZE_GEST_L0FAC_ARRAY_j1 SIZE_VARIABLES_L0FAC_ARRAY=SIZE_VARIABLES_L0FAC_ARRAY+ & SIZE_VARIABLES_L0FAC_ARRAY_j1 IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO endif ENDIF if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(mode.EQ.memory_save_mode) then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_L0FAC_ARRAY SIZE_GEST=SIZE_GEST+SIZE_GEST_L0FAC_ARRAY #if defined(MUMPS_NOF2003) SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif 100 continue RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_L0FACARRAY SUBROUTINE CMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS_1THREAD & ,unit,MYID,mode & ,Local_SIZE_GEST, Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (CMUMPS_L0OMPFAC_T) :: L0_OMP_FACTORS_1THREAD INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: Local_NbRecords, allocok, err INTEGER(8) :: itmp Local_NbRecords = 0 Local_SIZE_GEST = 0 Local_SIZE_VARIABLES = 0_8 Local_NbRecords = Local_NbRecords+1 IF (mode .EQ. memory_save_mode) THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 ELSE IF (mode .EQ. save_mode) THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 WRITE(unit,iostat=err) L0_OMP_FACTORS_1THREAD%LA IF (err .NE. 0) THEN INFO(1)=-72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 ENDIF size_written=size_written+SIZE_INT8 ELSE IF (mode .EQ. restore_mode) THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 READ(unit,iostat=err) L0_OMP_FACTORS_1THREAD%LA IF (err .NE. 0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & INFO(2)) GOTO 100 ENDIF size_read=size_read+SIZE_INT8 ENDIF IF (mode.EQ.memory_save_mode) THEN IF (associated(L0_OMP_FACTORS_1THREAD%A)) THEN Local_NbRecords = Local_NbRecords + 2 Local_SIZE_GEST = Local_SIZE_GEST + SIZE_INT8 Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP ELSE Local_NbRecords = Local_NbRecords + 1 Local_SIZE_GEST = Local_SIZE_GEST + SIZE_INT8 Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + 0 ENDIF ELSEIF (mode.EQ.save_mode) THEN IF (associated(L0_OMP_FACTORS_1THREAD%A)) THEN Local_NbRecords = Local_NbRecords + 2 write(unit,iostat=err) int(0,8) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written=size_written+SIZE_INT8 write(unit,iostat=err) L0_OMP_FACTORS_1THREAD%A if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written = size_written + & max(L0_OMP_FACTORS_1THREAD%LA,1_8)*SIZE_ARITH_DEP ELSE Local_NbRecords = Local_NbRecords + 1 write(unit,iostat=err) int(-999,8) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written=size_written+SIZE_INT8 ENDIF ELSEIF (mode.EQ.restore_mode) THEN NULLIFY(L0_OMP_FACTORS_1THREAD%A) READ(unit,iostat=err) itmp if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 100 endif size_read = size_read + SIZE_INT8 size_allocated = size_allocated + SIZE_INT8 IF (itmp .eq. -999) THEN Local_NbRecords = Local_NbRecords + 1 ELSE Local_NbRecords = Local_NbRecords + 2 ALLOCATE(L0_OMP_FACTORS_1THREAD%A( & max(L0_OMP_FACTORS_1THREAD%LA,1_8)), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) GOTO 100 ENDIF READ(unit,iostat=err) L0_OMP_FACTORS_1THREAD%A if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 100 endif size_read = size_read + & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP size_allocated = size_allocated+ & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP ENDIF ENDIF #if defined(MUMPS_NOF2003) IF (mode.EQ.memory_save_mode) THEN Local_SIZE_GEST = Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords ELSE IF (mode.EQ.save_mode) THEN size_written = size_written+2*SIZE_INT*Local_NbRecords ELSE IF (mode.EQ.restore_mode) THEN size_read = size_read+2*SIZE_INT*Local_NbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_L0FAC #endif END MODULE CMUMPS_FACSOL_L0OMP_M MUMPS_5.8.1/src/dfac_process_master2.F0000664000175000017500000001636715042446440017444 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, SLAVEF, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, KEEP, KEEP8, DKEEP, & ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE MUMPS_LOAD USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER SLAVEF INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ), ITLOC( N +KEEP(253) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ) INTEGER IFLAG, IERROR, COMM, COMM_LOAD INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER ND(KEEP(28)), FILS( N ), DAD(KEEP(28)), FRERE(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSITION, IFATH, ISON, NROW, NCOL, NELIM, & NSLAVES INTEGER(8) :: NOREAL INTEGER NOINT, INIV2, NCOL_EFF DOUBLE PRECISION FLOP1 INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER NOREAL_PACKET LOGICAL PERETYPE2 INCLUDE 'mumps_headers.h' DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYN_SIZE INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IFATH, 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & ISON , 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NROW , 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NCOL , 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, & MPI_INTEGER, COMM, IERR) IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN NCOL_EFF = NROW ELSE NCOL_EFF = NCOL ENDIF NOREAL_PACKET = NBROWS_PACKET * NCOL_EFF IF (NBROWS_ALREADY_SENT .EQ. 0) THEN NOINT = 6 + NROW + NCOL + NSLAVES + KEEP(IXSZ) NOREAL= int(NROW,8) * int(NCOL_EFF,8) CALL DMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, ISON, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) THEN RETURN ENDIF PIMASTER(STEP( ISON )) = IWPOSCB + 1 PAMASTER(STEP( ISON )) = IPTRLU + 1_8 IW( IWPOSCB + 1 + XXNBPR ) = 0 IW( IWPOSCB + 1 + KEEP(IXSZ) ) = NCOL NELIM = NROW IW( IWPOSCB + 2 + KEEP(IXSZ) ) = NELIM IW( IWPOSCB + 3 + KEEP(IXSZ) ) = NROW IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN IW( IWPOSCB + 4 + KEEP(IXSZ) ) = NROW - NCOL IF ( NROW - NCOL .GE. 0 ) THEN WRITE(*,*) 'Error in PROCESS_MAITRE2:',NROW,NCOL CALL MUMPS_ABORT() END IF ELSE IW( IWPOSCB + 4 + KEEP(IXSZ) ) = 0 END IF IW( IWPOSCB + 5 + KEEP(IXSZ) ) = 1 IW( IWPOSCB + 6 + KEEP(IXSZ) ) = NSLAVES IF (NSLAVES.GT.0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 7 + KEEP(IXSZ) ), & NSLAVES, MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 7 + KEEP(IXSZ) + NSLAVES), & NROW, MPI_INTEGER, COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 7 + KEEP(IXSZ) + NROW + NSLAVES), & NCOL, MPI_INTEGER, COMM, IERR) IF ( NSLAVES .GT. 0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(ISON) ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES+1, MPI_INTEGER, COMM, IERR) TAB_POS_IN_PERE(SLAVEF+2,INIV2) = NSLAVES ENDIF ENDIF IF (NOREAL_PACKET.GT.0) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(PIMASTER(STEP(ISON))+XXD)) IF ( DYN_SIZE .GT. 0_8 ) THEN CALL DMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), & DYN_SIZE, SON_A ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SON_A( 1_8 + & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8) ), & NOREAL_PACKET, MPI_DOUBLE_PRECISION, COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( PAMASTER(STEP(ISON)) + & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8) ), & NOREAL_PACKET, MPI_DOUBLE_PRECISION, COMM, IERR ) ENDIF ENDIF IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NROW ) THEN PERETYPE2 = ( MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)), & KEEP(199)) .EQ. 2 ) NSTK_S( STEP(IFATH )) = NSTK_S( STEP(IFATH) ) - 1 IF ( NSTK_S( STEP(IFATH)) .EQ. 0 ) THEN CALL DMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IFATH ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( IFATH, N, PROCNODE_STEPS, & KEEP(199), ND, & FILS,FRERE, STEP, PIMASTER, & KEEP(28), KEEP(50), KEEP(253), & FLOP1,IW, LIW, KEEP(IXSZ) ) IF (IFATH.NE.KEEP(20)) & CALL MUMPS_LOAD_UPDATE(1, .FALSE., FLOP1, KEEP,KEEP8) END IF ENDIF RETURN END SUBROUTINE DMUMPS_PROCESS_MASTER2 MUMPS_5.8.1/src/zfac_process_contrib_type2.F0000664000175000017500000004732115042446441020673 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, & MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, & N, IW, LIW, A, LA, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, PERM, & COMP, root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, NBFIN, & MYID, COMM, ICNTL, KEEP,KEEP8,DKEEP, IFLAG, IERROR, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_LOAD USE ZMUMPS_BUF USE ZMUMPS_LR_TYPE USE MUMPS_LR_STATS USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR, & ZMUMPS_DM_FREE_BLOCK IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV, MSGLEN INTEGER BUFR( LBUFR ) INTEGER(8) :: LRLU, IPTRLU, LRLUS, LA, POSFAC INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER NBFIN INTEGER COMP INTEGER NELT, LPTRAR INTEGER PROCNODE_STEPS( KEEP(28) ), PTRIST(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER PTLUST( KEEP(28) ) INTEGER PERM(N) INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER ITLOC( N + KEEP(253)), NSTK_S( KEEP(28) ) INTEGER :: FILS( N ), DAD(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER ND(KEEP(28)), FRERE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, MYID, IFLAG, IERROR INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER FRTPTR(N+1), FRTELT( NELT ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NFS4FATHER INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPESPLIT INTEGER IERR INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER I, INODE, ISON, POSITION, NBROW, LROW, IROW, INDCOL INTEGER LREQI INTEGER(8) :: LREQA, POSCONTRIB INTEGER ROW_LENGTH INTEGER MASTER INTEGER ISTCHK LOGICAL SAME_PROC LOGICAL SLAVE_NODE LOGICAL IS_ofType5or6 INTEGER ISHIFT_BUFR, LBUFR_LOC, LBUFR_BYTES_LOC INTEGER TYPESPLIT INTEGER DECR INTEGER :: INBPROCFILS_SON LOGICAL :: CB_IS_LR INTEGER :: CB_IS_LR_INT, NBLRB_PACKET, allocok INTEGER :: MAXI_CLUSTER INTEGER :: ICOL_BEG, ICOL_END, ICOL_SHARED INTEGER :: IROW_BEG, IROW_END INTEGER :: NB_BLOCKS_UNPACKED LOGICAL :: BLOCKS_LEFT_2_UNPACK DOUBLE PRECISION :: PROMOTE_COST INTEGER(8) :: LA_TEMP COMPLEX(kind=8), DIMENSION(:), POINTER :: A_TEMP TYPE (LRB_TYPE) :: LRB INTEGER(8) :: IACHK, SIZFR8, DYN_SIZE COMPLEX(kind=8), DIMENSION(:), POINTER :: DYNPTR INTEGER :: NSLAVES, NFRONT, NASS1, IOLDPS, PARPIV_T1 INTEGER :: NB_POSTPONED LOGICAL :: LR_ACTIVATED INTEGER(8) :: POSELT INTEGER :: XXG_STATUS INCLUDE 'mumps_headers.h' COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) INTEGER :: NBCOLS_ALREADY_SENT LOGICAL :: IS_PANEL_FINISHED, IS_LROW_NEGATIVE 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 ) IS_LROW_NEGATIVE = (LROW.LT.0) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & CB_IS_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) CB_IS_LR = (CB_IS_LR_INT.EQ.1) IF (CB_IS_LR.AND.LROW.LT.0) THEN LROW = -LROW ENDIF NBCOLS_ALREADY_SENT=0 ICOL_SHARED = -9999 MASTER = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) SLAVE_NODE = MASTER .NE. MYID TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) IF (SLAVE_NODE .AND. PTRIST(STEP(INODE)) ==0) THEN ISHIFT_BUFR = ( MSGLEN + KEEP(34) ) / KEEP(34) LBUFR_LOC = LBUFR - ISHIFT_BUFR + 1 LBUFR_BYTES_LOC = LBUFR_LOC * KEEP(34) CALL ZMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR(ISHIFT_BUFR), LBUFR_LOC, LBUFR_BYTES_LOC, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (IFLAG.LT.0) RETURN ENDIF IF ( SLAVE_NODE ) THEN LREQI = LROW + NBROWS_PACKET ELSE LREQI = NBROWS_PACKET END IF LREQA = int(LROW,8) CALL ZMUMPS_GET_SIZE_NEEDED( & LREQI, LREQA, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR ) IF (IFLAG.LT.0) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA POSCONTRIB = POSFAC POSFAC = POSFAC + LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) IF ( SLAVE_NODE ) THEN IROW = IWPOS INDCOL = IWPOS + NBROWS_PACKET ELSE IROW = IWPOS INDCOL = -1 END IF IWPOS = IWPOS + LREQI IF ( SLAVE_NODE ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( INDCOL ), LROW, MPI_INTEGER, & COMM, IERR ) END IF DO I = 1, NBROWS_PACKET CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IROW + I - 1 ), 1, MPI_INTEGER, & COMM, IERR ) END DO IF (CB_IS_LR.AND.(NBROWS_PACKET.GT.0)) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBLRB_PACKET, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBCOLS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR ) ICOL_SHARED = 1+NBCOLS_ALREADY_SENT ENDIF IF ( SLAVE_NODE ) THEN IF ( KEEP(55) .eq. 0 ) THEN CALL ZMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, INODE, IW, LIW, A, LA, & NBROW, LROW, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ELSE CALL ZMUMPS_ELT_ASM_S_2_S_INIT( & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, & NBROW, LROW, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ENDIF ENDIF IF (CB_IS_LR.AND.(NBROWS_PACKET.GT.0)) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & MAXI_CLUSTER, 1, & MPI_INTEGER, COMM, IERR ) IROW_BEG = 1 IROW_END = NBROWS_PACKET LA_TEMP = NBROWS_PACKET*MAXI_CLUSTER NB_BLOCKS_UNPACKED = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(A_TEMP, LRB, I, ICOL_BEG, !$OMP& ICOL_END, ROW_LENGTH, allocok, BLOCKS_LEFT_2_UNPACK, !$OMP& PROMOTE_COST) #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) nullify(A_TEMP) IF (LA_TEMP.GT.0) THEN allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 550 ENDIF ENDIF BLOCKS_LEFT_2_UNPACK = .TRUE. DO WHILE (BLOCKS_LEFT_2_UNPACK) #if ! defined(BLR_NOOPENMP) !$OMP CRITICAL(contrib_type2_lrcb) #endif IF (NB_BLOCKS_UNPACKED.LT.NBLRB_PACKET) THEN CALL ZMUMPS_MPI_UNPACK_LRB(BUFR, LBUFR, & LBUFR_BYTES, POSITION, LRB, KEEP8, & COMM, IFLAG, IERROR & ) NB_BLOCKS_UNPACKED = NB_BLOCKS_UNPACKED + 1 ICOL_BEG = ICOL_SHARED ICOL_SHARED = ICOL_SHARED + LRB%N ELSE BLOCKS_LEFT_2_UNPACK = .FALSE. ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END CRITICAL(contrib_type2_lrcb) #endif IF (.NOT.BLOCKS_LEFT_2_UNPACK) CYCLE IF (LRB%ISLR .AND. LRB%K.EQ.0) CYCLE IF (LRB%ISLR) THEN CALL zgemm('T','T', LRB%N, NBROWS_PACKET, LRB%K, ONE, & LRB%R(1,1), LRB%K, LRB%Q(IROW_BEG,1), LRB%M, & ZERO, A_TEMP(1), LRB%N) PROMOTE_COST = 2.0D0*LRB%N*NBROWS_PACKET*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE DO I = IROW_BEG, IROW_END A_TEMP( 1+(I-IROW_BEG)*LRB%N : (I-IROW_BEG+1)*LRB%N ) & = LRB%Q(I,1:LRB%N) ENDDO ENDIF CALL DEALLOC_LRB(LRB, KEEP8, KEEP(34)) DO I=1,NBROWS_PACKET IF (KEEP(50).EQ.0) THEN ROW_LENGTH = LROW ELSE ROW_LENGTH = LROW - NBROWS_PACKET + I ENDIF ICOL_END = min(ICOL_BEG+LRB%N-1, ROW_LENGTH) IF (SLAVE_NODE) THEN CALL ZMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & 1, ICOL_END-ICOL_BEG+1, IW( IROW+I-1 ), & IW(INDCOL+ICOL_BEG-1), & A_TEMP(1+(I-1)*LRB%N), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, & LROW) ELSE CALL ZMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, 1, ICOL_END-ICOL_BEG+1, IW( IROW+I-1 ), & A_TEMP(1+(I-1)*LRB%N), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LROW, ICOL_BEG & ) ENDIF ENDDO ENDDO IF (associated(A_TEMP)) deallocate(A_TEMP) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) 550 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) RETURN ELSE DO I=1,NBROWS_PACKET IF (KEEP(50).NE.0) THEN ROW_LENGTH = LROW - NBROWS_PACKET + I ELSE ROW_LENGTH = LROW ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSCONTRIB), & ROW_LENGTH, & MPI_DOUBLE_COMPLEX, & COMM, IERR ) IF (SLAVE_NODE) THEN CALL ZMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & 1, ROW_LENGTH, IW( IROW+I-1 ),IW(INDCOL), & A(POSCONTRIB), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, & ROW_LENGTH ) ELSE CALL ZMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, 1, ROW_LENGTH, IW( IROW +I-1 ), & A(POSCONTRIB), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, ROW_LENGTH, 1 ) ENDIF ENDDO ENDIF IF (SLAVE_NODE) THEN IF (CB_IS_LR) THEN IF (NBROWS_PACKET.EQ.0) THEN IS_PANEL_FINISHED = .TRUE. ELSE IS_PANEL_FINISHED = ICOL_SHARED .GT. LROW ENDIF ELSE IS_PANEL_FINISHED = .TRUE. ENDIF IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW & .AND. IS_PANEL_FINISHED ) THEN IW(PTRIST(STEP(INODE))+XXNBPR) = & IW(PTRIST(STEP(INODE))+XXNBPR) - NBROW ENDIF CALL ZMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, & NBROWS_PACKET, STEP, PTRIST, & ITLOC, RHS_MUMPS,KEEP,KEEP8) ENDIF IF ( .NOT. SLAVE_NODE ) THEN IF ( (NBROWS_ALREADY_SENT .EQ. 0) & .AND. (NBCOLS_ALREADY_SENT .EQ. 0) & ) THEN IF (KEEP(219).NE.0) THEN IF(KEEP(50) .EQ. 2) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NFS4FATHER, & 1, & MPI_INTEGER, & COMM, IERR ) IF(NFS4FATHER .GT. 0) THEN CALL ZMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERROR = BUF_LMAX_ARRAY IFLAG = -13 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BUF_MAX_ARRAY, & NFS4FATHER, & MPI_DOUBLE_PRECISION, & COMM, IERR ) CALL ZMUMPS_ASM_MAX(N, INODE, IW, LIW, A, LA, & ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8) ENDIF ENDIF ENDIF ENDIF IF (CB_IS_LR) THEN IF (NBROWS_PACKET.EQ.0) THEN IS_PANEL_FINISHED = .TRUE. ELSE IS_PANEL_FINISHED = ICOL_SHARED .GT. LROW ENDIF ELSE IS_PANEL_FINISHED = .TRUE. ENDIF IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW & .AND. IS_PANEL_FINISHED ) THEN DECR = 1 ISTCHK = PIMASTER(STEP(ISON)) SAME_PROC = ISTCHK .LT. IWPOSCB IW(PTLUST(STEP(INODE))+XXNBPR) = & IW(PTLUST(STEP(INODE))+XXNBPR) - DECR IF (SAME_PROC) THEN INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR ELSE INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ENDIF IW(INBPROCFILS_SON) = IW(INBPROCFILS_SON) - DECR IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN IF (SAME_PROC) THEN CALL ZMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST, IW, LIW, STEP, KEEP,KEEP8) ENDIF IF (SAME_PROC) THEN ISTCHK = PTRIST(STEP(ISON)) PTRIST(STEP( ISON) ) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL ZMUMPS_DM_SET_DYNPTR( IW(ISTCHK+XXS), A, LA, & PAMASTER(STEP(ISON)), IW(ISTCHK+XXD), & IW(ISTCHK+XXR), DYNPTR, IACHK, SIZFR8) CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK+XXD)) XXG_STATUS = IW(ISTCHK+XXG) CALL ZMUMPS_FREE_BLOCK_CB_STATIC( & .FALSE., MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) IF ( DYN_SIZE .GT. 0_8 ) THEN CALL ZMUMPS_DM_FREE_BLOCK( XXG_STATUS, & DYNPTR, DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF IF (IW(PTLUST(STEP(INODE))+XXNBPR) .EQ. 0) THEN IOLDPS = PTLUST(STEP(INODE)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) IF (NSLAVES.EQ.0) THEN NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS1 = abs(IW(IOLDPS + 2+KEEP(IXSZ))) POSELT = PTRAST(STEP(INODE)) PARPIV_T1 = -999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) NB_POSTPONED = max(NFRONT - ND(STEP(INODE)),0) CALL ZMUMPS_PARPIVT1_SET_NVSCHUR_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1, & NB_POSTPONED) ENDIF CALL ZMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, INODE+N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ENDIF ENDIF END IF IWPOS = IWPOS - LREQI LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA POSFAC = POSFAC - LREQA CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) RETURN END SUBROUTINE ZMUMPS_PROCESS_CONTRIB_TYPE2 MUMPS_5.8.1/src/zfac_process_blocfacto_LDLT.F0000664000175000017500000015172315042446441020665 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE ZMUMPS_PROCESS_SYM_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_OOC, ONLY : IO_BLOCK USE MUMPS_OOC_COMMON, ONLY : TYPEF_L, STRAT_TRY_WRITE USE MUMPS_LOAD USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT USE ZMUMPS_BUF, ONLY : ZMUMPS_BUF_SEND_BLFAC_SLAVE USE ZMUMPS_LR_CORE USE ZMUMPS_LR_TYPE USE MUMPS_LR_STATS USE ZMUMPS_FAC_LR USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR, & ZMUMPS_DM_ALLOC_S_WK, ZMUMPS_DM_FREE_S_WK USE ZMUMPS_FAC_FRONT_AUX_M, ONLY : ZMUMPS_GET_SIZE_SCHUR_IN_FRONT !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) PTRAST(KEEP(28)), PTRFAC(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PERM(N), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)), ND(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PIVI INTEGER (8) POSPV1,POSPV2,OFFDAG,LPOS1 INTEGER J2 COMPLEX(kind=8) MULT1,MULT2, A11, DETPIV, A22, A12 INTEGER :: NFS4FATHER, NVSCHUR_K253, NSLAVES_L, IROW_L DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: M_ARRAY INTEGER NBROWSinF INTEGER :: BLFAC_NBCOLS_ALREADY_SENT, BLFAC_NBLRB_ALREADY_SENT INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NEWCOL_RECV, JBEG_BLOCK, NCOL_GEMM_FR, & SHIFT_LPOS, SHIFT_UPOS INTEGER :: IFLAG_OOC INTEGER(8) :: POSBLOCFACTO INTEGER :: LD_BLOCFACTO INTEGER(8) :: LA_BLOCFACTO INTEGER(8) :: LA_PTR INTEGER(8) :: POSELT COMPLEX(kind=8), DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, 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 INTEGER(8) :: LUIP21K COMPLEX(kind=8), DIMENSION(:), POINTER :: UIP21K COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE :: DYN_BLOCFACTO INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_SLAVES_FOLLOW INTEGER, DIMENSION(:), ALLOCATABLE :: DYN_PIVINFO LOGICAL LASTPANEL LOGICAL LASTBL_INPANEL, LASTBL_INLASTPANEL LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED COMPLEX(kind=8) ONE,ALPHA PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER J LOGICAL COUNTER_WAS_HUGE INTEGER TO_UPDATE_CPT_RECUR INTEGER :: LR_ACTIVATED_INT LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL LOGICAL :: DYNAMIC_ALLOC LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: CURRENT_BLR, NSLAVES_PREC, INFO_TMP(2) INTEGER :: NELIM, NB_BLR_LM, NB_BLR_LS, & MAXI_CLUSTER_LM, MAXI_CLUSTER_LS, MAXI_CLUSTER, & NPARTSASS, NPARTSCB, NPARTSCB_COL, NPARTSASS_COL, & NB_BLR_COL, MAXI_CLUSTER_COL INTEGER :: NPARTSASS_MASTER, IPANEL, NB_ACCESSES_INIT, & NB_ACCESSES_LEFT_INIT TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_LM TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS, & BEGS_BLR_COL, BEGS_BLR_COL_TMP LOGICAL KEEP_BEGS_BLR_LS, KEEP_BEGS_BLR_COL, KEEP_BLR_LS COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, LWORK INTEGER :: II,JJ LOGICAL :: NOTHING_WAS_SENT INTEGER :: KEEP430_LOC INTEGER :: NB, IB, IBEG, IEND !$ INTEGER :: NOMP !$ LOGICAL :: OMP_FLAG INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE KEEP(174)=KEEP(174)+1 KEEP(175)=max(KEEP(174),KEEP(175)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 POSITION = 0 TO_UPDATE_CPT_END = -654321 NULLIFY(UIP21K) 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 ) LASTPANEL = (NPIV.LE.0) IF (LASTPANEL) THEN NPIV = -NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NB_BLOC_FAC, 1, & MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NEWCOL_RECV, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, JBEG_BLOCK, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER, 1, & MPI_INTEGER, COMM, IERR ) NPARTSASS_COL = NPARTSASS_MASTER CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT, 1, & MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) IF (JBEG_BLOCK.EQ.1) THEN NCOL_GEMM_FR = NEWCOL_RECV - NPIV SHIFT_LPOS = NPIV SHIFT_UPOS = NPIV ELSE SHIFT_LPOS = JBEG_BLOCK - 1 IF (LR_ACTIVATED) THEN NCOL_GEMM_FR = -99993 SHIFT_UPOS = -99994 ELSE NCOL_GEMM_FR = NEWCOL_RECV SHIFT_UPOS = 0 ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NSLAVES_TOT, 1, & MPI_INTEGER, COMM, IERR ) KEEP_BEGS_BLR_LS =.FALSE. NULLIFY(BEGS_BLR_LS) KEEP_BEGS_BLR_COL =.FALSE. NULLIFY(BEGS_BLR_COL) KEEP_BLR_LS =.FALSE. NULLIFY(BLR_LS) NULLIFY(BEGS_BLR_LM) IF ( LR_ACTIVATED ) THEN LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8) LD_BLOCFACTO = max(NPIV+NELIM,1) ELSE LA_BLOCFACTO = int(NPIV,8) * int(NEWCOL_RECV,8) LD_BLOCFACTO = max(NEWCOL_RECV,1) ENDIF IF (LR_ACTIVATED) THEN DYNAMIC_ALLOC = .TRUE. ELSE DYNAMIC_ALLOC = .FALSE. ENDIF IF ( .NOT. DYNAMIC_ALLOC ) THEN IF ( NPIV .EQ. 0 ) THEN IPIV = 1 POSBLOCFACTO = 1_8 ELSE CALL ZMUMPS_GET_SIZE_NEEDED( & NPIV, LA_BLOCFACTO, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ),COMP,DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LA_BLOCFACTO LRLUS = LRLUS - LA_BLOCFACTO KEEP8(69) = KEEP8(69) + LA_BLOCFACTO KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LA_BLOCFACTO IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ELSE ALLOCATE(DYN_PIVINFO(max(1,NPIV)), & DYN_BLOCFACTO(max(1_8,LA_BLOCFACTO)), & stat=allocok) IF (allocok.GT.0) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR DYN_PIVINFO and DYN_BLOCFACTO IN ", & "ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 CALL MUMPS_SET_IERROR(max(1_8,LA_BLOCFACTO), IERROR) GOTO 700 ENDIF KEEP8(130)=KEEP8(130)+max(1_8,LA_BLOCFACTO) KEEP8(131)=max(KEEP8(130),KEEP8(131)) KEEP8(73) = KEEP8(73) + max(1_8,LA_BLOCFACTO) KEEP8(69) = KEEP8(69) + max(1_8,LA_BLOCFACTO) KEEP8(74) = max(KEEP8(74), KEEP8(73)) KEEP8(68) = max(KEEP8(68), KEEP8(69)) POSBLOCFACTO = 1_8 IPIV = 1 ENDIF IF (NPIV.GT.0) THEN IF (DYNAMIC_ALLOC) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & DYN_PIVINFO, NPIV, & MPI_INTEGER, COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) ENDIF IF (DYNAMIC_ALLOC) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & DYN_BLOCFACTO, int(LA_BLOCFACTO), & MPI_DOUBLE_COMPLEX, & COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), int(LA_BLOCFACTO), & MPI_DOUBLE_COMPLEX, & COMM, IERR ) ENDIF IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_LM, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_LM(max(NB_BLR_LM,1)), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BLR_LM IN ", & "ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = max(NB_BLR_LM,1) GOTO 700 END IF ALLOCATE(BEGS_BLR_LM(NB_BLR_LM+2), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BEGS_BLR_LM IN ", & "ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NB_BLR_LM+2 GOTO 700 END IF CALL ZMUMPS_MPI_UNPACK_LR_PARTIAL( & BUFR, LBUFR, LBUFR_BYTES, POSITION, NPIV, NELIM, & 'V', BLR_LM, NB_BLR_LM, JBEG_BLOCK, & BEGS_BLR_LM(1), KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) THEN CALL ZMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 550 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 + KEEP(IXSZ)) .EQ. 0 ) THEN DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 550 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) CALL ZMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL ZMUMPS_ASM_SLAVE_ARROWHEADS(INODE, STEP(INODE), & N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, & LRGROUPS) ELSE CALL ZMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 +KEEP(IXSZ)) NCOL1 = IW( IOLDPS + 3 +KEEP(IXSZ)) + IW( IOLDPS + KEEP(IXSZ)) IF (JBEG_BLOCK.EQ.1) THEN NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) ELSE NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) - NPIV ENDIF LASTBL_INPANEL = JBEG_BLOCK+NEWCOL_RECV.GT.NASS1-NPIV1 LASTBL_INLASTPANEL = LASTPANEL .AND. LASTBL_INPANEL NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) NSLAVES_FOLLOW = NSLAV1 - XTRA_SLAVES_SYM HS = 6 + NSLAV1 + KEEP(IXSZ) IF ( LASTBL_INLASTPANEL ) THEN TO_UPDATE_CPT_END = ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & NB_BLOC_FAC END IF IF (NPIV.GT.0) THEN IF (JBEG_BLOCK.EQ.1) THEN ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1 DO I = 1, NPIV IF (DYNAMIC_ALLOC) THEN PIVI = abs(DYN_PIVINFO(I)) ELSE PIVI = abs(IW(IPIV+I-1)) ENDIF IF (PIVI.EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+PIVI) IW(ICT11+PIVI) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + PIVI - 1,8) CALL zswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO IF (LR_ACTIVATED) THEN LUIP21K = 1_8 ELSE LUIP21K=int(NPIV,8)*int(NROW1,8) ENDIF KEEP430_LOC=min(KEEP(430),1) CALL ZMUMPS_DM_ALLOC_S_WK( UIP21K, LUIP21K, allocok, & KEEP430_LOC, KEEP(35) ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NPIV * NROW1 GOTO 700 END IF KEEP8(130)=KEEP8(130)+LUIP21K KEEP8(131)=max(KEEP8(130),KEEP8(131)) KEEP8(73) = KEEP8(73) + LUIP21K KEEP8(69) = KEEP8(69) + LUIP21K KEEP8(74) = max(KEEP8(74), KEEP8(73)) KEEP8(68) = max(KEEP8(68), KEEP8(69)) IF (.NOT.LR_ACTIVATED) THEN ENDIF ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 ) THEN ALLOCATE( LIST_SLAVES_FOLLOW ( NSLAVES_FOLLOW ), & stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR LIST_SLAVES_FOLLOW & IN ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NSLAVES_FOLLOW GOTO 700 END IF LIST_SLAVES_FOLLOW(1:NSLAVES_FOLLOW)= & IW(IOLDPS+6+XTRA_SLAVES_SYM+KEEP(IXSZ): & IOLDPS+5+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_FOLLOW) END IF IF ( (JBEG_BLOCK.EQ.1) .AND. & ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) & ) THEN IF (DYNAMIC_ALLOC) THEN CALL ztrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & DYN_BLOCFACTO, LD_BLOCFACTO, & A_PTR(POSELT+int(NPIV1,8)), NCOL1) ELSE CALL ztrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), LD_BLOCFACTO, & A_PTR(POSELT+int(NPIV1,8)), NCOL1) ENDIF ENDIF IF (JBEG_BLOCK.EQ.1) THEN IF (.NOT.LR_ACTIVATED.OR.KEEP(475).EQ.0) THEN NB = KEEP(360) !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = (NOMP.GT.1.AND. (int(NROW1/NB).GE.NOMP)) !$OMP PARALLEL DO !$OMP& PRIVATE (IB, II, IBEG, IEND, I, J, UPOS, LPOS, DPOS, !$OMP& PIVI, A11, A12, A22, POSPV1, POSPV2, !$OMP& OFFDAG, DETPIV, LPOS1, MULT1, MULT2 !$OMP& ) !$OMP& SCHEDULE(DYNAMIC,1) IF (OMP_FLAG) DO IB=1, NROW1, NB IBEG = IB IEND = min(IB+NB-1, NROW1) IF (.NOT.LR_ACTIVATED) THEN LPOS = POSELT + int(NPIV1,8) UPOS = 1_8 LPOS = LPOS + int((IBEG-1),8)*int(NCOL1,8) UPOS = UPOS + int((IBEG-1),8)*int(NPIV,8) DO II = IBEG, IEND DO J = 0, NPIV-1 UIP21K( UPOS+J ) = A_PTR(LPOS+J) ENDDO LPOS = LPOS + int(NCOL1,8) UPOS = UPOS + int(NPIV,8) END DO ENDIF LPOS = POSELT + int(NPIV1,8) LPOS = LPOS + int((IBEG-1),8)*int(NCOL1,8) IF (DYNAMIC_ALLOC) THEN DPOS = 1_8 ELSE DPOS = POSBLOCFACTO ENDIF I = 1 DO IF(I .GT. NPIV) EXIT IF (DYNAMIC_ALLOC) THEN PIVI = DYN_PIVINFO(I) ELSE PIVI = IW(IPIV+I-1) ENDIF IF(PIVI .GT. 0) THEN IF (DYNAMIC_ALLOC) THEN A11 = ONE/DYN_BLOCFACTO(DPOS) ELSE A11 = ONE/A(DPOS) ENDIF CALL zscal( IEND-IBEG+1, A11, A_PTR(LPOS), NCOL1 ) LPOS = LPOS + 1_8 DPOS = DPOS + int(LD_BLOCFACTO + 1,8) I = I+1 ELSE POSPV1 = DPOS POSPV2 = DPOS+ int(LD_BLOCFACTO + 1,8) OFFDAG = POSPV1+1_8 IF (DYNAMIC_ALLOC) THEN A11 = DYN_BLOCFACTO(POSPV1) A22 = DYN_BLOCFACTO(POSPV2) A12 = DYN_BLOCFACTO(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = DYN_BLOCFACTO(POSPV2)/DETPIV A12 = -A12/DETPIV ELSE A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV ENDIF LPOS1 = LPOS DO J2 = 1, IEND-IBEG+1 MULT1 = A11*A_PTR(LPOS1)+A12*A_PTR(LPOS1+1_8) MULT2 = A12*A_PTR(LPOS1)+A22*A_PTR(LPOS1+1_8) A_PTR(LPOS1) = MULT1 A_PTR(LPOS1+1_8) = MULT2 LPOS1 = LPOS1 + int(NCOL1,8) ENDDO LPOS = LPOS + 2_8 DPOS = POSPV2 + int(LD_BLOCFACTO + 1,8) I = I+2 ENDIF ENDDO ENDDO !$OMP END PARALLEL DO ENDIF ENDIF ENDIF COMPRESS_CB = .FALSE. IF ( LR_ACTIVATED ) THEN NSLAVES_PREC = NSLAVES_TOT - NSLAVES_FOLLOW -1 COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) ENDIF IF (NROW1.GT.0) THEN IF (NPIV.GT.0.AND.NROW1.LE.0) THEN CALL MUMPS_ABORT() ENDIF IF (LR_ACTIVATED) THEN IF (NPIV1.NE.0.OR.JBEG_BLOCK.NE.1) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_LS) KEEP_BEGS_BLR_LS = .TRUE. NB_BLR_LS = size(BEGS_BLR_LS) - 2 NPARTSCB = NB_BLR_LS ELSE CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) CALL REGROUPING2(BEGS_BLR_LS, NPARTSASS, NASS1, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472), & NCOL1, KEEP(1)) NB_BLR_LS = NPARTSCB ENDIF IF (NPIV.GT.0) THEN call MAX_CLUSTER(BEGS_BLR_LM(2:NB_BLR_LM+2),NB_BLR_LM, & MAXI_CLUSTER_LM) ELSE MAXI_CLUSTER_LM = 0 ENDIF call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) MAXI_CLUSTER=max(MAXI_CLUSTER_LS,MAXI_CLUSTER_LM,NPIV) IF (COMPRESS_CB) THEN IF (NPIV1.EQ.0.AND.JBEG_BLOCK.EQ.1) THEN CALL GET_CUT(IW(IOLDPS+HS+NROW1:IOLDPS+HS+NROW1+NCOL1-1), & NASS1, & NCOL1-NASS1, LRGROUPS, NPARTSCB_COL, & NPARTSASS_COL, BEGS_BLR_COL) CALL REGROUPING2(BEGS_BLR_COL, NPARTSASS_COL, NASS1, & NPARTSCB_COL, & NCOL1-NASS1, KEEP(488), .FALSE., KEEP(472), & NCOL1, KEEP(1)) NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL IF (NPARTSASS_MASTER.NE.NPARTSASS_COL) THEN ALLOCATE(BEGS_BLR_COL_TMP( & size(BEGS_BLR_COL)-NPARTSASS_COL+NPARTSASS_MASTER), & stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BEGS_BLR_COL_TMP in", & "ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = size(BEGS_BLR_COL) & -NPARTSASS_COL+NPARTSASS_MASTER GOTO 700 END IF IF ( size(BEGS_BLR_COL).GT. NPARTSASS_COL) THEN DO II=1, size(BEGS_BLR_COL) - NPARTSASS_COL BEGS_BLR_COL_TMP (II+NPARTSASS_MASTER) = & BEGS_BLR_COL(II+NPARTSASS_COL) ENDDO ENDIF DO II= 1, NPARTSASS_MASTER BEGS_BLR_COL_TMP (II) = & BEGS_BLR_COL(max(NPARTSASS_COL,1)+1) ENDDO DEALLOCATE(BEGS_BLR_COL) BEGS_BLR_COL => BEGS_BLR_COL_TMP NPARTSASS_COL = NPARTSASS_MASTER NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL ENDIF ELSE CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_COL ) KEEP_BEGS_BLR_COL = .TRUE. NB_BLR_COL = size(BEGS_BLR_COL) - 1 NPARTSCB_COL = NB_BLR_COL - NPARTSASS_COL ENDIF ELSE NULLIFY(BEGS_BLR_COL) ENDIF IF (NPIV1.EQ.0.AND.(JBEG_BLOCK.EQ.1)) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR NB_ACCESSES_INIT = 1 IF ( (KEEP(486).EQ.2) & ) THEN NB_ACCESSES_INIT = huge(NPARTSASS_MASTER) END IF INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 700 CALL ZMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .TRUE., & .TRUE., & NPARTSASS_COL, & BEGS_BLR_LS, BEGS_BLR_COL, NB_ACCESSES_INIT, & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 700 ENDIF LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF CURRENT_BLR = 1 IF (JBEG_BLOCK.EQ.1.AND.NPIV.GT.0) THEN CURRENT_BLR = 1 ALLOCATE(BLR_LS(NB_BLR_LS), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_LS GOTO 700 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL ZMUMPS_COMPRESS_PANEL_I_NOOPT & (A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & DKEEP(8), KEEP(466), 0, & KEEP(473), BLR_LS(1), & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP8, & OMP_NUM) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 300 IF (KEEP(475).GE.1) THEN IF (DYNAMIC_ALLOC) THEN CALL ZMUMPS_BLR_PANEL_LRTRSM( & DYN_BLOCFACTO, LA_BLOCFACTO, 1_8, & LD_BLOCFACTO, -6666, & NB_BLR_LS+1, & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1, & 2, 1, 0, & .TRUE., & DYN_PIVINFO, OFFSET_IW=1) ELSE CALL ZMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, & LD_BLOCFACTO, -6666, & NB_BLR_LS+1, & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1, & 2, 1, 0, & .TRUE., & IW, OFFSET_IW=IPIV) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (KEEP(486).NE.2) THEN CALL ZMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A_PTR(POSELT), LA_PTR, 1_8, & NCOL1, NCOL1, & .TRUE., & NPIV1+1, & 1, & NB_BLR_LS+1, BLR_LS(1), CURRENT_BLR, 'V', 1) ENDIF ENDIF 300 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & (OOCWRITE_COMPATIBLE_WITH_BLR .OR. NPIV.EQ.0) & .AND. (JBEG_BLOCK.EQ.1) & ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTPANEL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) LAST_CALL = .FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L, & A_PTR(POSELT), & LA_PTR, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG_OOC, LAST_CALL) IF ( IFLAG_OOC .LT. 0 )THEN IFLAG = IFLAG_OOC GOTO 700 ENDIF ENDIF IF (NPIV.GT.0) THEN IF (LR_ACTIVATED) THEN IF (JBEG_BLOCK.NE.1) THEN CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_LS) KEEP_BLR_LS = .TRUE. ENDIF IF (NELIM.GT.0.AND.JBEG_BLOCK.EQ.1) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = 1_8+int(SHIFT_UPOS,8) LPOS = LPOS2 + int(SHIFT_LPOS,8) IF (DYNAMIC_ALLOC) THEN CALL ZMUMPS_BLR_UPD_NELIM_VAR_L_I( & DYN_BLOCFACTO, LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1, & CURRENT_BLR+1, NELIM, 'N') ELSE CALL ZMUMPS_BLR_UPD_NELIM_VAR_L_I( & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1, & CURRENT_BLR+1, NELIM, 'N') ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif IF (DYNAMIC_ALLOC) THEN CALL ZMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, NROW1, JBEG_BLOCK, & DYN_BLOCFACTO, LA_BLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1, & BLR_LM(1), NPIV1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & BLR_LS(1), 0, & CURRENT_BLR, CURRENT_BLR, & DYN_PIVINFO, & BLOCKLR, & MAXI_CLUSTER, OMP_NUM, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ELSE CALL ZMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, NROW1, JBEG_BLOCK, & A(POSBLOCFACTO), LA_BLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1, & BLR_LM(1), NPIV1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & BLR_LS(1), 0, & CURRENT_BLR, CURRENT_BLR, & IW(IPIV), & BLOCKLR, & MAXI_CLUSTER, OMP_NUM, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF IF (IFLAG.LT.0) GOTO 400 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 CALL UPD_MRY_LU_LRGAIN(BLR_LS, NPARTSCB & ) CALL DEALLOC_BLR_PANEL(BLR_LM, NB_BLR_LM, KEEP8, KEEP(34)) DEALLOCATE(BLR_LM) IF ( JBEG_BLOCK.EQ.1 & ) & THEN IF ( (KEEP(486).EQ.2) & ) THEN NB_ACCESSES_LEFT_INIT = huge(NB_ACCESSES_LEFT_INIT) ELSE NB_ACCESSES_LEFT_INIT = NCOL1 - NPIV1 - NROW1 ENDIF CALL ZMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_LS, NB_ACCESSES_LEFT_INIT) KEEP_BLR_LS = .TRUE. ENDIF ELSE IF (NPIV .GT. 0 .AND. NCOL_GEMM_FR.GT.0)THEN LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(SHIFT_LPOS,8) IF (DYNAMIC_ALLOC) THEN UPOS = 1_8+int(SHIFT_UPOS,8) CALL zgemm('N','N', NCOL_GEMM_FR, NROW1, NPIV, & ALPHA, DYN_BLOCFACTO(UPOS), NEWCOL_RECV, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ELSE UPOS = POSBLOCFACTO+int(SHIFT_UPOS,8) CALL zgemm('N','N', NCOL_GEMM_FR, NROW1, NPIV, & ALPHA,A(UPOS), NEWCOL_RECV, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ENDIF ENDIF IF (JBEG_BLOCK.EQ.1) THEN DPOS = POSELT + int(NCOL1 - NROW1,8) #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1 .OR. & ( KEEP(421) .GT. 0 .AND. NROW1 .GT. KEEP(421) ) ) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = 1_8 CALL zgemmt( 'U', 'T', 'N', NROW1, NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A_PTR( LPOS2 ), NCOL1, ONE, & A_PTR( DPOS ), NCOL1 ) ELSE #endif IF ( NROW1 .GT. KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NROW1 ENDIF IF ( NROW1 .GT. 0 ) THEN DO IROW = 1, NROW1, BLSIZE Block = min( BLSIZE, NROW1 - IROW + 1 ) DPOS = POSELT + int(NCOL1 - NROW1,8) & + int( IROW - 1, 8 ) * int( NCOL1 + 1, 8 ) LPOS2 = POSELT + int(NPIV1,8) & + int( IROW - 1, 8 ) * int( NCOL1, 8 ) UPOS = int( IROW - 1, 8 ) * int(NPIV, 8) + 1_8 DO I = 1, Block CALL zgemv( 'T', NPIV, Block-I+1, ALPHA, & A_PTR( LPOS2 + int(I - 1,8) * int(NCOL1,8) ), NCOL1, & UIP21K( UPOS + int(NPIV,8) * int( I - 1, 8 ) ), & 1, ONE, A_PTR(DPOS+int(NCOL1+1,8)*int(I-1,8)),NCOL1 ) END DO IF ( NROW1-IROW+1-Block .ne. 0 ) & CALL zgemm( 'T', 'N', Block, NROW1-IROW+1-Block, & NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A_PTR( LPOS2 + int(Block,8) * int(NCOL1,8) ), NCOL1, & ONE, & A_PTR( DPOS + int(Block,8) * int(NCOL1,8) ), NCOL1 ) ENDDO ENDIF #if defined(GEMMT_AVAILABLE) ENDIF #endif ENDIF ENDIF IF (LASTBL_INPANEL) THEN FLOP1 = dble(NROW1) * dble(NPIV) * & dble( 2 * (NASS1-NPIV1) - NPIV + NROW1 +1 ) FLOP1 = -FLOP1 CALL MUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF ENDIF IF (JBEG_BLOCK.EQ.1) THEN IW(IOLDPS+KEEP(IXSZ)) = IW(IOLDPS+KEEP(IXSZ)) - NPIV IW(IOLDPS+3+KEEP(IXSZ)) = IW(IOLDPS+3+KEEP(IXSZ)) + NPIV ENDIF IF (LASTBL_INLASTPANEL) THEN IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+3+KEEP(IXSZ)) ENDIF IF ( .NOT. LR_ACTIVATED ) THEN IF (DYNAMIC_ALLOC) THEN IF (allocated(DYN_PIVINFO) ) DEALLOCATE(DYN_PIVINFO) IF (allocated(DYN_BLOCFACTO)) THEN KEEP8(130) = KEEP8(130)-max(1_8,LA_BLOCFACTO) DEALLOCATE(DYN_BLOCFACTO) KEEP8(69) = KEEP8(69) - max(1_8,LA_BLOCFACTO) KEEP8(73) = KEEP8(73) - max(1_8,LA_BLOCFACTO) ENDIF ELSE LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO IWPOS = IWPOS - NPIV CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 & .AND. JBEG_BLOCK.EQ.1 ) THEN IPOSK = NPIV1 + 1 JPOSK = NCOL1 - NROW1 + 1 NPIVSENT = NPIV BLFAC_NBCOLS_ALREADY_SENT = 0 BLFAC_NBLRB_ALREADY_SENT = 0 IERR = -1 DO WHILE ( IERR .eq. -1 ) IF (DYNAMIC_ALLOC) THEN CALL ZMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, LUIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & BLFAC_NBCOLS_ALREADY_SENT, BLFAC_NBLRB_ALREADY_SENT, & NOTHING_WAS_SENT, & DYN_BLOCFACTO, LA_BLOCFACTO, & 1_8, LD_BLOCFACTO, & DYN_PIVINFO, MAXI_CLUSTER, & IERR, IERROR ) ELSE CALL ZMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, LUIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & BLFAC_NBCOLS_ALREADY_SENT, BLFAC_NBLRB_ALREADY_SENT, & NOTHING_WAS_SENT, & A, LA, & POSBLOCFACTO, LD_BLOCFACTO, & IW(IPIV), MAXI_CLUSTER, & IERR, IERROR ) ENDIF IF (IERR.EQ.-13) THEN IFLAG = IERR IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE within ZMUMPS_BUF_SEND_BLFAC_SLAVE", & " during ZMUMPS_PROCESS_SYM_BLOCFACTO", IERROR GOTO 700 ENDIF IF (IERR .EQ. -1 .AND. NOTHING_WAS_SENT) THEN IOLDPS = PTRIST(STEP(INODE)) IF ( IW(IOLDPS+6+KEEP(IXSZ)) .eq. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN COUNTER_WAS_HUGE=.TRUE. IW(IOLDPS+6+KEEP(IXSZ)) = 1 ELSE COUNTER_WAS_HUGE=.FALSE. ENDIF TO_UPDATE_CPT_RECUR = & ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & (2*NASS1/KEEP(6)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) - TO_UPDATE_CPT_RECUR - 10 BLOCKING = .FALSE. SET_IRECV= .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + TO_UPDATE_CPT_RECUR + 10 IF ( COUNTER_WAS_HUGE .AND. & IW(IOLDPS+6+KEEP(IXSZ)).EQ.1 ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = huge(IW(IOLDPS+6+KEEP(IXSZ))) ENDIF IF ( IFLAG .LT. 0 ) GOTO 550 END IF END DO IF ( IERR .eq. -2 ) THEN IF (LP > 0 ) THEN WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING & ZMUMPS_PROCESS_SYM_BLOCFACTO" ENDIF IFLAG = -17 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF IF ( IERR .eq. -3 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING & ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -20 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF DEALLOCATE(LIST_SLAVES_FOLLOW) END IF IF ( LR_ACTIVATED ) THEN IF (NPIV.GT.0 & .AND. KEEP(486).EQ.3 & ) THEN IOLDPS = PTRIST(STEP(INODE)) CALL ZMUMPS_BLR_DEC_AND_TRYFREE_L(IW(IOLDPS+XXF),IPANEL, & KEEP8, KEEP(34), NEWCOL_RECV) ENDIF IF (DYNAMIC_ALLOC) THEN IF (allocated(DYN_PIVINFO)) DEALLOCATE(DYN_PIVINFO) IF (allocated(DYN_BLOCFACTO)) THEN KEEP8(130) = KEEP8(130)-max(1_8,LA_BLOCFACTO) DEALLOCATE(DYN_BLOCFACTO) ENDIF ELSE IF (NPIV .GT. 0) THEN LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO IWPOS = IWPOS - NPIV CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF ( NPIV .NE. 0 ) THEN IF (associated(UIP21K)) THEN CALL ZMUMPS_DM_FREE_S_WK( UIP21K, KEEP430_LOC ) NULLIFY( UIP21K ) KEEP8(130) = KEEP8(130)-LUIP21K KEEP8(69) = KEEP8(69) - LUIP21K KEEP8(73) = KEEP8(73) - LUIP21K ENDIF ENDIF IOLDPS = PTRIST(STEP(INODE)) IF (LR_ACTIVATED ) THEN COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) ENDIF CALL ZMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) IF (LASTBL_INLASTPANEL) THEN IF ( KEEP(486) .NE. 0) THEN IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = IW(IOLDPS+6+KEEP(IXSZ)) & - TO_UPDATE_CPT_END & - 1 END IF IF ( IW(IOLDPS+6+KEEP(IXSZ) ) .eq. 0 & .and. KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 & .and. NSLAVES_TOT.NE.1 ) THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) CALL MUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_SYM_BLOCFACTO.' IFLAG = -99 GOTO 700 END IF ENDIF IF (IW(IOLDPS+6+KEEP(IXSZ)) .eq. 0 & ) THEN IOLDPS = PTRIST(STEP(INODE)) NELIM = IW( IOLDPS + 4 + KEEP(IXSZ)) - & IW( IOLDPS + 3 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) IF (LR_ACTIVATED) THEN IF (COMPRESS_CB) THEN allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_COL), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_COL) GOTO 700 ENDIF DO II=1,NB_BLR_LS DO JJ=1,NB_BLR_COL-NPARTSASS_COL CB_LRB(II,JJ)%M=0 CB_LRB(II,JJ)%N=0 NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL ZMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL ZMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) NFS4FATHER = max(NFS4FATHER,0) + NELIM ENDIF ALLOCATE(M_ARRAY(max(1,NFS4FATHER)), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR M_ARRAY ", & "ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = max(1,NFS4FATHER) ENDIF BEGS_BLR_COL(1+NPARTSASS_COL) = & BEGS_BLR_COL(1+NPARTSASS_COL) - NELIM CALL MAX_CLUSTER( & BEGS_BLR_COL(max(NPARTSASS_MASTER,1)+1:NB_BLR_COL+1), & NB_BLR_COL-max(NPARTSASS_MASTER,1),MAXI_CLUSTER_COL & ) MAXI_CLUSTER=max(MAXI_CLUSTER_LS, MAXI_CLUSTER_COL) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF NBROWSinF = 0 NVSCHUR_K253 = 0 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN CALL ZMUMPS_COMPUTE_NBROWSinF ( & N, INODE, FPERE, KEEP, & IOLDPS, HS, & IW, LIW, & NROW1, NCOL1, NPIV1, & NELIM, NFS4FATHER, & NBROWSinF & ) IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) ) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL ZMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR_K253 ) ELSE IF (KEEP(253).NE.0) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL ZMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & 0, & IW(IROW_L), & PERM, NVSCHUR_K253 ) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 700 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL ZMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_LS, NB_BLR_COL-NPARTSASS_COL, & NPARTSASS_COL, & NROW1, NCOL1-NPIV1, INODE, & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV1, NVSCHUR_K253, KEEP(1), & M_ARRAY & , NELIM, NBROWSinF & ) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 650 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL ZMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF DEALLOCATE(M_ARRAY) 650 CONTINUE ENDIF IF (IFLAG.LT.0) GOTO 700 ENDIF CALL ZMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, roota, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF GOTO 550 700 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 550 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (.NOT.KEEP_BEGS_BLR_LS) THEN IF (associated(BEGS_BLR_LS)) DEALLOCATE(BEGS_BLR_LS) ENDIF IF (.NOT.KEEP_BLR_LS) THEN IF (associated(BLR_LS)) THEN CALL DEALLOC_BLR_PANEL(BLR_LS, NB_BLR_LS, KEEP8, KEEP(34)) DEALLOCATE(BLR_LS) ENDIF ENDIF IF (associated(BEGS_BLR_LM)) DEALLOCATE(BEGS_BLR_LM) IF (.NOT.KEEP_BEGS_BLR_COL) THEN IF (COMPRESS_CB) THEN IF (associated(BEGS_BLR_COL)) THEN DEALLOCATE( BEGS_BLR_COL) ENDIF ENDIF ENDIF ENDIF KEEP(174)=KEEP(174)-1 RETURN END SUBROUTINE ZMUMPS_PROCESS_SYM_BLOCFACTO MUMPS_5.8.1/src/mumps_headers.h0000664000175000017500000000721315042446423016241 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C Common header positions: C C XXI -> size of integer record C XXR -> size of real record C XXS -> status of the node C XXN -> node number C XXP -> pointer to previous record C XXA -> active fronts data management C XXF -> blr data passed from factorization to solve C XXLR -> Low rank status of a node (0=FR, C 1=LowRank CB only C 2=LowRank factors/panels only C 3=LowRank CB+factor/panel) C XXEBF -> End of Blocfacto (0=not yet, 1=finished) C XXD -> dynamic data size C XXG -> GPU information (currently number of pinned rows NFRONT-NBROWS_CPU C for type 1 nodes, pinning status for type 2 strips) C REMARK: .h file could be replaced by a module with functions to get node status C added in the module. C INTEGER, PARAMETER :: XXI = 0, XXR = 1, XXS = 3, XXN = 4, XXP = 5 INTEGER, PARAMETER :: XXA = 6, XXF = 7 INTEGER, PARAMETER :: XXLR = 8 INTEGER, PARAMETER :: XXNBPR = 9 INTEGER, PARAMETER :: XXEBF = 10 INTEGER, PARAMETER :: XXD = 11 INTEGER, PARAMETER :: XXG = 13 C C Size of header in incore and out-of-core C INTEGER XSIZE_IC, XSIZE_OOC_SYM, XSIZE_OOC_UNSYM INTEGER XSIZE_OOC_NOPANEL ! To store virtual addresses C At the moment, all headers are of the same size because C no OOC specific information are stored in header. CM other OOC specific information directly in the headers. PARAMETER (XSIZE_IC=14,XSIZE_OOC_SYM=14,XSIZE_OOC_UNSYM=14, & XSIZE_OOC_NOPANEL=14) C C ------------------------------------------------------- C Position of header size (formerly XSIZE) in KEEP array. C KEEP(IXSZ) is set at the beginning of the factorization C to either XSIZE_IC, XSIZE_OOC_SYM or XSIZE_OOC_UNSYM. C ------------------------------------------------------- INTEGER IXSZ PARAMETER(IXSZ= 222) ! KEEP(222) used INTEGER, PARAMETER :: S_CB1COMP = 314 INTEGER S_ACTIVE, S_ALL, S_NOLCBCONTIG, & S_NOLCBNOCONTIG, S_NOLCLEANED, & S_NOLCBNOCONTIG38, S_NOLCBCONTIG38, & S_NOLCLEANED38, & S_NOLNOCB, S_NOLNOCBCLEANED, & C_FINI PARAMETER(S_ACTIVE=400, S_ALL=401, S_NOLCBCONTIG=402, & S_NOLCBNOCONTIG=403, S_NOLCLEANED=404, & S_NOLCBNOCONTIG38=405, S_NOLCBCONTIG38=406, & S_NOLCLEANED38=407, & S_NOLNOCB=408, S_NOLNOCBCLEANED=409, & C_FINI=1) INTEGER, PARAMETER :: S_FREE = 54321 INTEGER, PARAMETER :: S_NOTFREE = -123 INTEGER, PARAMETER :: TOP_OF_STACK = -999999 INTEGER XTRA_SLAVES_SYM, XTRA_SLAVES_UNSYM PARAMETER(XTRA_SLAVES_SYM=4, XTRA_SLAVES_UNSYM=2) INTEGER S_ROOT2SON_CALLED, S_REC_CONTSTATIC, & S_ROOTBAND_INIT PARAMETER(S_ROOT2SON_CALLED=-341,S_REC_CONTSTATIC=1, & S_ROOTBAND_INIT=0) INTEGER, PARAMETER :: MemNotPinned = -1 INTEGER, PARAMETER :: MemPinned = -2 INTEGER, PARAMETER :: PinningOnTheWay = -3 INTEGER, PARAMETER :: UnpinningOnTheWay = -4 MUMPS_5.8.1/src/smumps_sol_es.F0000664000175000017500000010727015042446437016244 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_SOL_ES PRIVATE PUBLIC:: SMUMPS_CHAIN_PRUN_NODES PUBLIC:: SMUMPS_CHAIN_PRUN_NODES_STATS PUBLIC:: SMUMPS_INITIALIZE_RHS_BOUNDS PUBLIC:: SMUMPS_PROPAGATE_RHS_BOUNDS PUBLIC:: SMUMPS_TREE_PRUN_NODES PUBLIC:: SMUMPS_SOL_ES_INIT # if defined(STAT_ES_SOLVE) PUBLIC:: SMUMPS_SOL_ES_PRINT_STATS # endif PUBLIC:: SMUMPS_ES_GET_SUM_Nloc PUBLIC:: SMUMPS_ES_NODES_SIZE_AND_FILL INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK # if defined(STAT_ES_SOLVE) DOUBLE PRECISION :: nb_flops, & nb_sparse_flops, & total_efficiency INTEGER :: total_procs, total_blocks #endif INCLUDE 'mumps_headers.h' CONTAINS SUBROUTINE SMUMPS_SOL_ES_INIT(SIZE_OF_BLOCK_ARG, KEEP201) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP201 INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK_ARG IF (KEEP201 > 0) THEN SIZE_OF_BLOCK => SIZE_OF_BLOCK_ARG ELSE NULLIFY(SIZE_OF_BLOCK) ENDIF #if defined(STAT_ES_SOLVE) nb_flops=0.0d0 nb_sparse_flops=0.0d0 total_efficiency=0.0d0 total_procs=0 total_blocks=0 #endif RETURN END SUBROUTINE SMUMPS_SOL_ES_INIT SUBROUTINE SMUMPS_TREE_PRUN_NODES( & fill, & DAD, NE_STEPS, FRERE, KEEP28, & FILS, STEP, N, & nodes_RHS, nb_nodes_RHS, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N, KEEP28 INTEGER, INTENT(IN) :: DAD(KEEP28),NE_STEPS(KEEP28),FRERE(KEEP28) INTEGER, INTENT(IN) :: FILS(N), STEP(N) INTEGER, INTENT(IN) :: nodes_RHS(:), nb_nodes_RHS INTEGER :: nb_prun_nodes INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_List(nb_prun_nodes) INTEGER :: nb_prun_roots INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Roots(nb_prun_roots) INTEGER :: nb_prun_leaves INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Leaves(nb_prun_leaves) LOGICAL :: TO_PROCESS(KEEP28) INTEGER :: IN, I, ISTEP, TMP, TMPsave LOGICAL :: FILS_VISITED nb_prun_nodes = 0 nb_prun_leaves = 0 TO_PROCESS(:) = .FALSE. DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) TMPsave = TMP ISTEP = STEP(TMP) DO WHILE(.NOT.TO_PROCESS(ISTEP)) TO_PROCESS(ISTEP) = .TRUE. nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = TMP END IF IN = FILS(TMP) DO WHILE(IN.GT.0) IN = FILS(IN) END DO FILS_VISITED = .FALSE. IF (IN.LT.0) THEN FILS_VISITED = TO_PROCESS(STEP(-IN)) ENDIF IF ( IN.LT.0.and..NOT.FILS_VISITED) & THEN TMP = -IN ISTEP = STEP(TMP) ELSE IF (IN.EQ.0) THEN nb_prun_leaves = nb_prun_leaves + 1 IF (fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF ELSE TMP = -IN ISTEP = STEP(TMP) ENDIF DO WHILE (TMP.NE.TMPsave) TMP = abs(FRERE(ISTEP)) IF(TMP.NE.0) THEN ISTEP = STEP(TMP) ELSE exit END IF IF (.NOT.TO_PROCESS(ISTEP)) exit END DO END IF END DO END DO nb_prun_roots = 0 DO I=1,nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) IF(DAD(ISTEP).NE.0) THEN IF(.NOT.TO_PROCESS(STEP(DAD(ISTEP)))) THEN nb_prun_roots = nb_prun_roots + 1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF END IF ELSE nb_prun_roots = nb_prun_roots + 1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF END IF END DO RETURN END SUBROUTINE SMUMPS_TREE_PRUN_NODES SUBROUTINE SMUMPS_CHAIN_PRUN_NODES( & fill, & DAD, KEEP28, & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes,nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: KEEP28 INTEGER, INTENT(IN) :: DAD(KEEP28) INTEGER, INTENT(IN) :: nb_nodes_RHS INTEGER, INTENT(IN) :: nodes_RHS(max(nb_nodes_RHS,1)) INTEGER, INTENT(INOUT) :: nb_prun_nodes INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_List(nb_prun_nodes) INTEGER, INTENT(INOUT) :: nb_prun_roots INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Roots(nb_prun_roots) INTEGER, INTENT(INOUT) :: nb_prun_leaves INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Leaves(nb_prun_leaves) INTEGER, INTENT(OUT) :: Pruned_SONS(KEEP28) LOGICAL, INTENT(OUT) :: TO_PROCESS(KEEP28) INTEGER :: IN, I, ISTEP, TMP nb_prun_nodes = 0 nb_prun_roots = 0 TO_PROCESS(:) = .FALSE. Pruned_SONS(:) = -1 DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) TO_PROCESS(ISTEP) = .TRUE. IF (Pruned_SONS(ISTEP) .eq. -1) THEN Pruned_SONS(ISTEP) = 0 nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = nodes_RHS(I) END IF IN = nodes_RHS(I) IN = DAD(STEP(IN)) DO WHILE (IN.NE.0) TO_PROCESS(STEP(IN)) = .TRUE. IF (Pruned_SONS(STEP(IN)).eq.-1) THEN nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = IN END IF Pruned_SONS(STEP(IN)) = 1 TMP = IN IN = DAD(STEP(IN)) ELSE Pruned_SONS(STEP(IN)) = Pruned_SONS(STEP(IN)) + 1 GOTO 201 ENDIF ENDDO nb_prun_roots = nb_prun_roots +1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF ENDIF 201 CONTINUE ENDDO nb_prun_leaves = 0 DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) IF (Pruned_SONS(ISTEP).EQ.0) THEN nb_prun_leaves = nb_prun_leaves +1 IF(fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF END IF ENDDO RETURN END SUBROUTINE SMUMPS_CHAIN_PRUN_NODES SUBROUTINE SMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, K242, K243, & UNS_PERM_INV, SIZE_UNS_PERM_INV, K23, & RHS_BOUNDS, NSTEPS, & nb_sparse, MYID, & mode) IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, N, NSTEPS, K242, K243, K23 INTEGER, INTENT(IN) :: JBEG_RHS, SIZE_PERM_RHS, nb_sparse INTEGER, INTENT(IN) :: NBCOL, NZ_RHS, SIZE_UNS_PERM_INV INTEGER, INTENT(IN) :: STEP(N), PERM_RHS(SIZE_PERM_RHS) INTEGER, INTENT(IN) :: IRHS_PTR(NBCOL+1),IRHS_SPARSE(NZ_RHS) INTEGER, INTENT(IN) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, INTENT(INOUT):: RHS_BOUNDS(2*NSTEPS) INTEGER, INTENT(IN) :: mode INTEGER :: I, ICOL, JPTR, J, JAM1, node, bound RHS_BOUNDS = 0 ICOL = 0 DO I = 1, NBCOL IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE ICOL = ICOL + 1 bound = ICOL - mod(ICOL, nb_sparse) + 1 IF(mod(ICOL, nb_sparse).EQ.0) bound = bound - nb_sparse IF(mode.EQ.0) THEN IF ((K242.NE.0).OR.(K243.NE.0)) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 ENDIF node = abs(STEP(JAM1)) IF(RHS_BOUNDS(2*node - 1).EQ.0) THEN RHS_BOUNDS(2*node - 1) = bound RHS_BOUNDS(2*node) = bound + nb_sparse - 1 ELSE RHS_BOUNDS(2*node) = bound + nb_sparse - 1 END IF ELSE DO JPTR = IRHS_PTR(I), IRHS_PTR(I+1)-1 J = IRHS_SPARSE(JPTR) IF ( mode .EQ. 1 ) THEN IF (K23.NE.0) J = UNS_PERM_INV(J) ENDIF node = abs(STEP(J)) IF(RHS_BOUNDS(2*node - 1).EQ.0) THEN RHS_BOUNDS(2*node - 1) = bound RHS_BOUNDS(2*node) = bound + nb_sparse - 1 ELSE RHS_BOUNDS(2*node) = bound + nb_sparse - 1 END IF END DO END IF END DO RETURN END SUBROUTINE SMUMPS_INITIALIZE_RHS_BOUNDS SUBROUTINE SMUMPS_PROPAGATE_RHS_BOUNDS( & pruned_leaves, nb_pruned_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, NSTEPS, & MYID, COMM, KEEP485, #if defined(STAT_ES_SOLVE) & KEEP46, & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, #endif & IW, LIW, PTRIST, KIXSZ,OOC_FCT_LOC, PHASE, LDLT, K38) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' INTEGER, INTENT(IN) :: nb_pruned_leaves, N, NSTEPS INTEGER, INTENT(IN) :: STEP(N), DAD(NSTEPS), Pruned_SONS(NSTEPS) INTEGER, INTENT(IN) :: MYID, COMM, KEEP485 INTEGER, INTENT(IN) :: pruned_leaves(nb_pruned_leaves) INTEGER, INTENT(IN) :: LIW, IW(LIW), PTRIST(NSTEPS) INTEGER, INTENT(IN) :: KIXSZ, OOC_FCT_LOC, PHASE, LDLT, K38 # if defined(STAT_ES_SOLVE) INTEGER, INTENT(IN) :: KEEP46 INTEGER, INTENT(IN) :: SIZE_IPTR_WORKING, SIZE_WORKING, & IPTR_WORKING(SIZE_IPTR_WORKING), & WORKING(SIZE_WORKING) #endif INTEGER, INTENT(INOUT):: RHS_BOUNDS(2*NSTEPS) INTEGER :: I, node, father, size_pool, next_size_pool INTEGER :: IERR INTEGER, ALLOCATABLE, DIMENSION(:) :: POOL, NBSONS #if defined(STAT_ES_SOLVE) LOGICAL, ALLOCATABLE, DIMENSION(:) :: isleaf INTEGER :: J, NPROCS, proc, allocok LOGICAL :: found DOUBLE PRECISION :: avg_load, efficiency, max_load, effmax DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: proc_flops_buf DOUBLE PRECISION :: proc_block_flops, block_flops INTEGER :: SK38 INTEGER, PARAMETER :: MASTER = 0 #endif ALLOCATE(POOL(nb_pruned_leaves), & NBSONS(NSTEPS), & STAT=IERR) IF (IERR.NE.0) THEN WRITE(6,*)'Allocation problem in SMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() END IF size_pool = nb_pruned_leaves POOL = pruned_leaves NBSONS = Pruned_SONS # if defined(STAT_ES_SOLVE) NPROCS = SIZE_IPTR_WORKING-1 IF((MYID.EQ.MASTER).AND.(KEEP46.EQ.1)) THEN ALLOCATE(isleaf(NSTEPS), STAT=IERR) IF (IERR.NE.0) THEN WRITE(6,*)'Allocation problem in SMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() END IF isleaf = .FALSE. DO I=1,nb_pruned_leaves isleaf(abs(STEP(pruned_leaves(I)))) = .true. END DO proc = 0 DO I=1,NPROCS found = .FALSE. J = IPTR_WORKING(I) DO WHILE((J.LE.IPTR_WORKING(I+1)-1).AND.(.NOT.found)) IF (isleaf(WORKING(J)))THEN found = .TRUE. END IF J = J + 1 END DO IF(found) THEN proc = proc + 1 END IF END DO total_procs = total_procs + proc total_blocks = total_blocks + 1 DEALLOCATE(isleaf) END IF # endif DO WHILE (size_pool.ne.0) next_size_pool =0 DO I=1, size_pool node = STEP(POOL(I)) IF (DAD(node).NE.0) THEN father = STEP(DAD(node)) NBSONS(father) = NBSONS(father)-1 IF (RHS_BOUNDS(2*father-1).EQ.0) THEN RHS_BOUNDS(2*father-1) = RHS_BOUNDS(2*node-1) RHS_BOUNDS(2*father) = RHS_BOUNDS(2*node) ELSE RHS_BOUNDS(2*father-1) = min(RHS_BOUNDS(2*father-1), & RHS_BOUNDS(2*node-1)) RHS_BOUNDS(2*father) = max(RHS_BOUNDS(2*father), & RHS_BOUNDS(2*node)) END IF IF(NBSONS(father).EQ.0) THEN next_size_pool = next_size_pool+1 POOL(next_size_pool) = DAD(node) END IF END IF END DO size_pool = next_size_pool END DO DEALLOCATE(POOL, NBSONS) # if defined(STAT_ES_SOLVE) IF (KEEP46.EQ.1) THEN IF(MYID.EQ.MASTER) THEN block_flops = 0D0 END IF proc_block_flops = 0D0 IF (K38 .GT. 0) THEN SK38 = STEP(K38) ELSE SK38 = 0 END IF DO I=1,NSTEPS IF (RHS_BOUNDS(2*I).NE.0) THEN IF(PTRIST(I).GT.0) THEN proc_block_flops = proc_block_flops & + dble(2*(RHS_BOUNDS(2*I) - RHS_BOUNDS(2*I-1) +1)) & * dble(SMUMPS_LOCAL_FACTOR_SIZE(IW, LIW, & PTRIST(I)+KIXSZ, & PHASE,LDLT,I.EQ.SK38)) END IF END IF END DO IF(MYID.EQ.MASTER) THEN ALLOCATE(proc_flops_buf(SIZE_IPTR_WORKING-1),stat=allocok) IF(allocok.GT.0) THEN WRITE(6,*)'Allocation problem of proc_flops_buf' & ,' in SMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() ENDIF proc_flops_buf=0.0d0 ELSE ALLOCATE(proc_flops_buf(1),stat=allocok) IF(allocok.GT.0) THEN WRITE(6,*)'Allocation problem of proc_flops_buf' & ,' in SMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() ENDIF proc_flops_buf=0.0d0 END IF CALL MPI_GATHER(proc_block_flops, 1, MPI_DOUBLE_PRECISION, & proc_flops_buf, 1, MPI_DOUBLE_PRECISION, & 0, COMM, IERR) CALL MPI_REDUCE(proc_block_flops, block_flops, 1, & MPI_DOUBLE_PRECISION, MPI_SUM, 0, COMM, IERR) IF(MYID.EQ.MASTER) THEN nb_sparse_flops = nb_sparse_flops+block_flops avg_load = sum(proc_flops_buf)/dble(NPROCS) max_load = maxval(proc_flops_buf) efficiency = 0D0 effmax = 0D0 DO I=1,NPROCS efficiency= efficiency + (proc_flops_buf(I)-avg_load)**2 IF (proc_flops_buf(I)-avg_load.GT.0.0D0) THEN effmax = effmax + (max_load-avg_load)**2 ELSE IF (proc_flops_buf(I)-avg_load.LT.0.0D0) THEN effmax = effmax + avg_load**2 END IF END DO efficiency = sqrt(efficiency/dble(NPROCS)) effmax = sqrt(effmax/dble(NPROCS)) IF(effmax.ne.0.0d0) efficiency = efficiency / effmax efficiency = 1.0d0 - efficiency efficiency = efficiency * block_flops total_efficiency = total_efficiency + efficiency DEALLOCATE(proc_flops_buf) ELSE DEALLOCATE(proc_flops_buf) END IF END IF #endif RETURN END SUBROUTINE SMUMPS_PROPAGATE_RHS_BOUNDS INTEGER(8) FUNCTION SMUMPS_LOCAL_FACTOR_SIZE(IW,LIW,PTR, & PHASE, LDLT, IS_ROOT) INTEGER, INTENT(IN) :: LIW, PTR, PHASE, LDLT INTEGER, INTENT(IN) :: IW(LIW) LOGICAL, INTENT(IN) :: IS_ROOT INTEGER(8) :: NCB, NELIM, LIELL, NPIV, NROW NCB = int(IW(PTR),8) NELIM = int(IW(PTR+1),8) NROW = int(IW(PTR+2),8) NPIV = int(IW(PTR+3),8) LIELL = NPIV + NCB IF (IS_ROOT) THEN SMUMPS_LOCAL_FACTOR_SIZE = int(IW(PTR+1),8) * & int(IW(PTR+2),8) / 2_8 RETURN ENDIF IF (NCB.GE.0_8) THEN IF (PHASE.EQ.0 & .OR. (PHASE.EQ.1.AND.LDLT.NE.0) & ) THEN SMUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV-1_8)/2_8 + (NROW-NPIV)*NPIV ELSE SMUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV-1_8)/2_8 + (LIELL-NPIV)*NPIV ENDIF ELSE SMUMPS_LOCAL_FACTOR_SIZE = & -NCB*NELIM END IF RETURN END FUNCTION SMUMPS_LOCAL_FACTOR_SIZE SUBROUTINE SMUMPS_CHAIN_PRUN_NODES_STATS & (MYID, N, KEEP28, KEEP201, KEEP485, FR_FACT, & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_LOC # if defined(STAT_ES_SOLVE) & , NRHS, COMM, IW, LIW, PTRIST, KIXSZ, PHASE, & LDLT, K38 #endif & ) IMPLICIT NONE INTEGER, intent(in) :: KEEP28, KEEP201, OOC_FCT_TYPE_LOC, N, & KEEP485 INTEGER(8), intent(in) :: FR_FACT INTEGER, intent(in) :: nb_prun_nodes, MYID INTEGER, intent(in) :: Pruned_List(nb_prun_nodes) INTEGER, intent(in) :: STEP(N) #if defined(STAT_ES_SOLVE) INTEGER, INTENT(IN):: LIW, COMM, NRHS, LDLT, K38 INTEGER, INTENT(IN):: IW(LIW), PTRIST(KEEP28), KIXSZ, PHASE DOUBLE PRECISION :: proc_block_flops, block_flops INTEGER(8) :: Pruned_Size_ic INTEGER :: IERR INTEGER :: SK38 #endif INCLUDE 'mpif.h' INTEGER I, ISTEP INTEGER(8) :: Pruned_Size #if defined(STAT_ES_SOLVE) Pruned_Size_ic = 0_8 #endif Pruned_Size = 0_8 #if defined(STAT_ES_SOLVE) IF (K38 .GT. 0) THEN SK38 = STEP(K38) ELSE SK38 = 0 END IF #endif 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 #if defined(STAT_ES_SOLVE) IF (PTRIST(ISTEP) .GT. 0) THEN Pruned_Size_ic = Pruned_Size_ic + & SMUMPS_LOCAL_FACTOR_SIZE(IW, LIW, & PTRIST(ISTEP)+KIXSZ, & PHASE, LDLT, & ISTEP.EQ.SK38) ENDIF # endif ENDDO #if defined(STAT_ES_SOLVE) proc_block_flops = dble(2_8*Pruned_Size_ic)*dble(NRHS) CALL MPI_REDUCE(proc_block_flops, block_flops, 1, & MPI_DOUBLE_PRECISION, MPI_SUM, 0, COMM, IERR) IF(MYID.EQ.0) nb_flops = nb_flops + block_flops #endif RETURN END SUBROUTINE SMUMPS_CHAIN_PRUN_NODES_STATS #if defined(STAT_ES_SOLVE) SUBROUTINE SMUMPS_SOL_ES_PRINT_STATS( & K212, K235, K237, K485, K497, NZLU8, & NRHS, ICNTL27, N, K50, DKEEPS, RINFOGS, MPG) IMPLICIT NONE INTEGER, intent(in) :: K212, K235, K237, K485, K497, & NRHS, MPG, ICNTL27, N, K50 INTEGER(8), intent(in) :: NZLU8 REAL, intent(out) :: DKEEPS(5), RINFOGS(5) LOGICAL :: AM1, ES_FWD, ES_BWD, DO_NBSPARSE IF (MPG.LE.0) RETURN AM1 = (K237 .NE. 0) ES_FWD = (K235 .NE. 0) .AND. (.NOT. AM1) ES_BWD = (K212 .NE. 0) .AND. (.NOT. AM1) DO_NBSPARSE = (K497.NE.0).AND.(NRHS.GT.1).AND.(ICNTL27.GT.1) IF (AM1) & WRITE(MPG,'(/A)') ' ** FLOPS SUMMARY during SOLVE AM1 ** ' IF ((ES_FWD).AND. (.NOT.ES_BWD)) & WRITE(MPG,'(/A,A)') ' ** FLOPS SUMMARY during fwd step', & ' (exploit RHS sparsity) ** ' IF ((.NOT.ES_FWD).AND. (ES_BWD)) & WRITE(MPG,'(/A,A)') ' ** FLOPS SUMMARY during bwd step', & ' (selected entries in solution) ** ' IF ((ES_FWD).AND. (ES_BWD)) & WRITE(MPG,'(/A,/A)') & ' ** FLOPS SUMMARY during SOLVE (fwd+bwd steps)', & ' (sparse RHS and selected entries in solution) **' IF ( & (ES_FWD) .AND. (.NOT.ES_BWD) & .OR. & (.NOT.ES_FWD) .AND. (ES_BWD) & ) THEN IF (K50.NE.0) THEN DKEEPS(1)=(real(NZLU8)-real(N))*real(2*NRHS) ELSE DKEEPS(1)=(real(NZLU8)-real(N))*real(NRHS) ENDIF ELSE IF ((ES_FWD).AND.(ES_BWD)) THEN IF (K50.NE.0) THEN DKEEPS(1) = (real(NZLU8)-real(N))*real(4*NRHS) ELSE DKEEPS(1)=(real(NZLU8)-real(N))*real(2*NRHS) ENDIF ENDIF RINFOGS(1) = DKEEPS(1) IF (.NOT.AM1) THEN WRITE(MPG,'(A,F25.1)') & ' RINFOG(24) FLOPS with dense full rank format =', DKEEPS(1) ENDIF DKEEPS(2)=real(nb_flops) IF (DO_NBSPARSE) DKEEPS(4)=real(nb_sparse_flops) IF (DO_NBSPARSE) THEN RINFOGS(2)= DKEEPS(4) ELSE RINFOGS(2)= DKEEPS(2) ENDIF WRITE(MPG,'(A,F25.1)') & ' RINFOG(25) FLOPS with exploit sparsity (ES) =', RINFOGS(2) RETURN END SUBROUTINE SMUMPS_SOL_ES_PRINT_STATS #endif SUBROUTINE SMUMPS_ES_GET_SUM_Nloc ( & N, Nloc_ITAB, ITAB_loc, COMM, & SUM_idNloc_8 ) IMPLICIT NONE INTEGER, INTENT(IN) :: N #if defined(MUMPS_NOF2003) INTEGER, POINTER :: ITAB_loc (:) #else INTEGER, INTENT( IN ), POINTER :: ITAB_loc (:) #endif INTEGER, INTENT(IN) :: Nloc_ITAB INTEGER, INTENT(IN) :: COMM INTEGER(8) :: SUM_idNloc_8 INCLUDE 'mpif.h' INTEGER I, II, IERR_MPI INTEGER(8) :: idNloc_8 idNloc_8 = 0_8 DO I= 1, Nloc_ITAB II = ITAB_loc(I) IF (II.GE.1 .and. II.LE.N) & idNloc_8 = idNloc_8 + 1_8 ENDDO CALL MPI_ALLREDUCE (idNloc_8, SUM_idNloc_8, 1, & MPI_INTEGER8, & MPI_SUM, COMM, IERR_MPI ) RETURN END SUBROUTINE SMUMPS_ES_GET_SUM_Nloc SUBROUTINE SMUMPS_ES_NODES_SIZE_AND_FILL ( & fill, & N, NSTEPS, KEEP, STEP, Step2node, & ITAB_loc, Nloc_ITAB, & MYID, COMM, & Pruned_Sons, Lnodes_ITAB #if defined(AVOID_MPI_IN_PLACE) & , TMP_INT_ARRAY #endif & , nodes_ITAB & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N, NSTEPS, KEEP(500) INTEGER, INTENT(IN) :: Nloc_ITAB INTEGER, INTENT(IN) :: STEP(N), Step2node(NSTEPS), & ITAB_loc(max(1,Nloc_ITAB)) INTEGER, INTENT(IN) :: MYID, COMM #if defined(AVOID_MPI_IN_PLACE) INTEGER :: TMP_INT_ARRAY(NSTEPS) #endif INTEGER, INTENT(INOUT) :: Pruned_Sons(NSTEPS), Lnodes_ITAB INTEGER, OPTIONAL, INTENT(OUT) :: nodes_ITAB(max(1,Lnodes_ITAB)) INCLUDE 'mpif.h' INTEGER I, II, ISTEP, IERR_MPI, Lnodes_ITAB_loc, INODE_PRINC IF (.NOT.fill) THEN Pruned_SONS = 0 DO I= 1, Nloc_ITAB II = ITAB_loc(I) IF (II.GE.1 .and. II.LE.N) THEN ISTEP = abs(STEP(II)) IF ( Pruned_SONS(ISTEP) .eq. 0 ) THEN Pruned_SONS(ISTEP) = 1 ENDIF ENDIF ENDDO #if defined(AVOID_MPI_IN_PLACE) TMP_INT_ARRAY = Pruned_Sons #endif CALL MPI_ALLREDUCE( #if defined(AVOID_MPI_IN_PLACE) & TMP_INT_ARRAY, #else & MPI_IN_PLACE, #endif & Pruned_Sons, NSTEPS, & MPI_INTEGER, MPI_SUM, COMM, IERR_MPI) Lnodes_ITAB = 0 DO ISTEP=1,NSTEPS if (Pruned_SONS(ISTEP) .NE.0) Lnodes_ITAB=Lnodes_ITAB+1 ENDDO ELSE IF (Lnodes_ITAB.GT.0) THEN Lnodes_ITAB_loc = 0 DO ISTEP=1,NSTEPS if (Pruned_SONS(ISTEP) .GT. 0) then Lnodes_ITAB_loc=Lnodes_ITAB_loc+1 INODE_PRINC = Step2node( ISTEP ) nodes_ITAB(Lnodes_ITAB_loc) = INODE_PRINC endif ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_ES_NODES_SIZE_AND_FILL END MODULE SMUMPS_SOL_ES SUBROUTINE SMUMPS_PERMUTE_RHS_GS & (LP, LPOK, PROKG, MPG, PERM_STRAT, & SYM_PERM, N, NRHS, & IRHS_PTR, SIZE_IRHS_PTR, & IRHS_SPARSE, NZRHS, & PERM_RHS, IERR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: LP, MPG, PERM_STRAT, N, NRHS, & SIZE_IRHS_PTR, & NZRHS LOGICAL, INTENT(IN) :: LPOK, PROKG INTEGER, INTENT(IN) :: SYM_PERM(N) INTEGER, INTENT(IN) :: IRHS_PTR(SIZE_IRHS_PTR) INTEGER, INTENT(IN) :: IRHS_SPARSE(NZRHS) INTEGER, INTENT(OUT) :: PERM_RHS(NRHS) INTEGER, INTENT(OUT) :: IERR INTEGER :: I,J,K, POSINPERMRHS, JJ, & KPOS INTEGER, ALLOCATABLE :: ROW_REFINDEX(:) IERR = 0 IF ((PERM_STRAT.NE.-1).AND.(PERM_STRAT.NE.1)) THEN IERR=-1 IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -1 in ", & " SMUMPS_PERMUTE_RHS_GS, PERM_STRAT =", PERM_STRAT, & " is out of range " RETURN ENDIF IF (PERM_STRAT.EQ.-1) THEN DO I=1,NRHS PERM_RHS(I) = I END DO GOTO 490 ENDIF ALLOCATE(ROW_REFINDEX(NRHS), STAT=IERR) IF (IERR.GT.0) THEN IERR=-1 IF (LPOK) THEN WRITE(LP,*) " ERROR -2 : ", & " ALLOCATE IN SMUMPS_PERMUTE_RHS_GS OF SIZE :", & NRHS ENDIF RETURN ENDIF DO I=1,NRHS IF (IRHS_PTR(I+1)-IRHS_PTR(I).LE.0) THEN IERR = 1 IF (I.EQ.1) THEN ROW_REFINDEX(I) = IRHS_SPARSE(IRHS_PTR(I)) ELSE ROW_REFINDEX(I) = ROW_REFINDEX(I-1) ENDIF ELSE ROW_REFINDEX(I) = IRHS_SPARSE(IRHS_PTR(I)) ENDIF END DO POSINPERMRHS = 0 DO I=1,NRHS KPOS = N+1 JJ = 0 DO J=1,NRHS K = ROW_REFINDEX(J) IF (K.LE.0) CYCLE IF (SYM_PERM(K).LT.KPOS) THEN KPOS = SYM_PERM(K) JJ = J ENDIF END DO IF (JJ.EQ.0) THEN IERR = -3 IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -3 in ", & " SMUMPS_PERMUTE_RHS_GS " GOTO 500 ENDIF POSINPERMRHS = POSINPERMRHS + 1 PERM_RHS(POSINPERMRHS) = JJ ROW_REFINDEX(JJ) = -ROW_REFINDEX(JJ) END DO IF (POSINPERMRHS.NE.NRHS) THEN IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -4 in ", & " SMUMPS_PERMUTE_RHS_GS ", maxval(ROW_REFINDEX) IERR = -4 GOTO 500 ENDIF 490 CONTINUE 500 CONTINUE IF (allocated(ROW_REFINDEX)) DEALLOCATE(ROW_REFINDEX) END SUBROUTINE SMUMPS_PERMUTE_RHS_GS SUBROUTINE SMUMPS_PERMUTE_RHS_AM1 & (PERM_STRAT, SYM_PERM, & IRHS_PTR, NHRS, & PERM_RHS, SIZEPERM, IERR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: PERM_STRAT, NHRS, SIZEPERM INTEGER, INTENT(IN) :: SYM_PERM(SIZEPERM) INTEGER, INTENT(IN) :: IRHS_PTR(NHRS) INTEGER, INTENT(OUT):: IERR INTEGER, INTENT(OUT):: PERM_RHS(SIZEPERM) DOUBLE PRECISION :: RAND_NUM INTEGER I, J, STRAT IERR = 0 STRAT = PERM_STRAT IF( (STRAT.NE.-3).AND. & (STRAT.NE.-2).AND. & (STRAT.NE.-1).AND. & (STRAT.NE. 1).AND. & (STRAT.NE. 2).AND. & (STRAT.NE. 6) ) THEN WRITE(*,*)"Warning: incorrect value for the RHS permutation; ", & "defaulting to post-order" STRAT = 1 END IF IF (STRAT .EQ. -3) THEN PERM_RHS(1:SIZEPERM)=0 DO I=1, SIZEPERM CALL random_number(RAND_NUM) RAND_NUM = RAND_NUM*dble(SIZEPERM) J = ceiling(RAND_NUM) DO WHILE (PERM_RHS(J).NE.0) CALL random_number(RAND_NUM) RAND_NUM = RAND_NUM*dble(SIZEPERM) J = ceiling(RAND_NUM) ENDDO PERM_RHS(J)=I ENDDO ELSEIF (STRAT .EQ. -2) THEN DO I=1, SIZEPERM PERM_RHS(SIZEPERM -I +1) = I ENDDO ELSEIF (STRAT .EQ. -1) THEN DO I=1, SIZEPERM PERM_RHS(I) = I ENDDO ELSEIF (STRAT .EQ. 1) THEN DO I=1, SIZEPERM PERM_RHS(SYM_PERM(I)) = I ENDDO ELSEIF (STRAT .EQ. 2) THEN DO I=1, SIZEPERM PERM_RHS(SIZEPERM-SYM_PERM(I)+1) = I ENDDO ENDIF END SUBROUTINE SMUMPS_PERMUTE_RHS_AM1 SUBROUTINE SMUMPS_INTERLEAVE_RHS_AM1( & PERM_RHS, SIZE_PERM, & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, & IRHS_PTR, & STEP, SYM_PERM, N, NBRHS, & PROCNODE, NSTEPS, SLAVEF, KEEP199, & behaviour_L0, reorder, n_select, PROKG, MPG & ) IMPLICIT NONE INTEGER, INTENT(IN) :: SIZE_PERM, & SIZE_IPTR_WORKING, & IPTR_WORKING(SIZE_IPTR_WORKING), & SIZE_WORKING, & WORKING(SIZE_WORKING), & N, & IRHS_PTR(N+1), & STEP(N), & SYM_PERM(N), & NBRHS, & NSTEPS, & PROCNODE(NSTEPS), & SLAVEF, KEEP199, & n_select, MPG LOGICAL, INTENT(IN) :: behaviour_L0, & reorder, PROKG INTEGER, INTENT(INOUT) :: PERM_RHS(SIZE_PERM) INTEGER :: I, J, K, IVAR, IBLOCK, & entry, & node, & SIZE_PERM_WORKING, & NB_NON_EMPTY, & to_be_found, & posintmprhs, & selected, & local_selected, & current_proc, & NPROCS, & n_pass, & pass, & nblocks, & n_select_loc, & IERR INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_RHS, & PTR_PROCS, & IPTR_PERM_WORKING, & PERM_WORKING, & MYTYPENODE INTEGER, ALLOCATABLE, DIMENSION(:) :: & PERM_PO, & ISTEP2BLOCK, & NEXTINBLOCK LOGICAL, ALLOCATABLE, DIMENSION(:) :: USED LOGICAL :: allow_above_L0 INTEGER, EXTERNAL :: MUMPS_TYPENODE_ROUGH NPROCS = SIZE_IPTR_WORKING - 1 ALLOCATE(TMP_RHS(SIZE_PERM), & PTR_PROCS(NPROCS), & USED(SIZE_PERM), & IPTR_PERM_WORKING(NPROCS+1), & MYTYPENODE(NSTEPS), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in SMUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF DO I=1, NSTEPS MYTYPENODE(I) = MUMPS_TYPENODE_ROUGH( PROCNODE(I), KEEP199 ) ENDDO NB_NON_EMPTY = 0 DO I=1,SIZE_PERM IF(IRHS_PTR(I+1)-IRHS_PTR(I).NE.0) THEN NB_NON_EMPTY = NB_NON_EMPTY + 1 END IF END DO K = 0 IPTR_PERM_WORKING(1)=1 DO I=1,NPROCS USED = .FALSE. DO J=IPTR_WORKING(I),IPTR_WORKING(I+1)-1 USED(WORKING(J)) = .TRUE. END DO DO J=1,N IF (USED(abs(STEP(PERM_RHS(J)))).AND. & ((IRHS_PTR(PERM_RHS(J)+1)-IRHS_PTR(PERM_RHS(J))).NE.0)) & THEN K = K + 1 END IF END DO IPTR_PERM_WORKING(I+1) = K+1 END DO SIZE_PERM_WORKING = K ALLOCATE(PERM_WORKING(SIZE_PERM_WORKING), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in SMUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF K = 0 DO I=1,NPROCS USED = .FALSE. DO J=IPTR_WORKING(I),IPTR_WORKING(I+1)-1 USED(WORKING(J)) = .TRUE. END DO DO J=1,N IF (USED(abs(STEP(PERM_RHS(J)))).AND. & ((IRHS_PTR(PERM_RHS(J)+1)-IRHS_PTR(PERM_RHS(J))).NE.0)) & THEN K = K + 1 PERM_WORKING(K) = PERM_RHS(J) END IF END DO END DO IF(behaviour_L0) THEN n_pass = 2 allow_above_L0 = .false. to_be_found = 0 DO I=1,SIZE_PERM IF((MYTYPENODE(abs(STEP(I))).LE.1).AND. & (IRHS_PTR(I+1)-IRHS_PTR(I).NE.0)) & THEN to_be_found = to_be_found + 1 END IF END DO ELSE n_pass = 1 allow_above_L0 = .true. to_be_found = NB_NON_EMPTY END IF PTR_PROCS(1:NPROCS) = IPTR_PERM_WORKING(1:NPROCS) USED = .FALSE. current_proc = 1 n_select_loc = n_select IF (n_select_loc.LE.0) THEN n_select_loc = 1 ENDIF posintmprhs = 0 DO pass=1,n_pass selected = 0 DO WHILE(selected.LT.to_be_found) local_selected = 0 DO WHILE(local_selected.LT.n_select_loc) IF(PTR_PROCS(current_proc).EQ. & IPTR_PERM_WORKING(current_proc+1)) & THEN EXIT ELSE entry = PERM_WORKING(PTR_PROCS(current_proc)) node = abs(STEP(entry)) IF(.NOT.USED(entry)) THEN IF(allow_above_L0.OR.(MYTYPENODE(node).LE.1)) THEN USED(entry) = .TRUE. selected = selected + 1 local_selected = local_selected + 1 posintmprhs = posintmprhs + 1 TMP_RHS(posintmprhs) = entry IF(selected.EQ.to_be_found) EXIT END IF END IF PTR_PROCS(current_proc) = PTR_PROCS(current_proc) + 1 END IF END DO current_proc = mod(current_proc,NPROCS)+1 END DO to_be_found = NB_NON_EMPTY - to_be_found allow_above_L0 = .true. PTR_PROCS(1:NPROCS) = IPTR_PERM_WORKING(1:NPROCS) END DO DO I=1,SIZE_PERM IF(IRHS_PTR(PERM_RHS(I)+1)-IRHS_PTR(PERM_RHS(I)).EQ.0) THEN posintmprhs = posintmprhs+1 TMP_RHS(posintmprhs) = PERM_RHS(I) IF(posintmprhs.EQ.SIZE_PERM) EXIT END IF END DO DEALLOCATE(PTR_PROCS, USED, & IPTR_PERM_WORKING, & PERM_WORKING, MYTYPENODE) IF(reorder) THEN nblocks = (N+NBRHS-1)/NBRHS ALLOCATE(PERM_PO(N), ISTEP2BLOCK(N), NEXTINBLOCK(nblocks), & stat=IERR) IF(IERR.GT.0) THEN IF (PROKG ) WRITE(MPG,*) & 'Warning: reorder not done in SMUMPS_INTERLEAVE_RHS_AM1' PERM_RHS = TMP_RHS GOTO 500 ENDIF DO IVAR = 1, N K = SYM_PERM( IVAR ) PERM_PO( K ) = IVAR END DO DO I = 1, N IBLOCK = 1 + ( I - 1 ) / NBRHS IVAR = TMP_RHS( I ) K = SYM_PERM( IVAR ) ISTEP2BLOCK( K ) = IBLOCK END DO DO IBLOCK = 1, NBLOCKS NEXTINBLOCK(IBLOCK) = 1 + (IBLOCK-1)*NBRHS ENDDO DO K = 1, N IBLOCK = ISTEP2BLOCK(K) IVAR = PERM_PO(K) PERM_RHS(NEXTINBLOCK(IBLOCK)) = IVAR NEXTINBLOCK(IBLOCK) = NEXTINBLOCK(IBLOCK) + 1 ENDDO ELSE PERM_RHS = TMP_RHS END IF 500 CONTINUE DEALLOCATE(TMP_RHS) IF (allocated(PERM_PO )) DEALLOCATE(PERM_PO ) IF (allocated(ISTEP2BLOCK)) DEALLOCATE(ISTEP2BLOCK) IF (allocated(NEXTINBLOCK)) DEALLOCATE(NEXTINBLOCK) RETURN END SUBROUTINE SMUMPS_INTERLEAVE_RHS_AM1 MUMPS_5.8.1/src/cfac_asm_master_m.F0000664000175000017500000022536715042446440017001 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC_ASM_MASTER_M CONTAINS SUBROUTINE CMUMPS_FAC_ASM_NIV1( COMM_LOAD, ASS_IRECV, & UU, N, INODE, IW, LIW, A, LA, INFO, ND, & FILS, FRERE, DAD, MAXFRW, root, roota, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, LRLUSM, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, JOBASS, ETATASS & , LRGROUPS & , MUMPS_TPS_ARR, CMUMPS_TPS_ARR, L0_OMP_MAPPING & ) !$ USE OMP_LIB USE MUMPS_TPS_M USE CMUMPS_TPS_M USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_PTR, & CMUMPS_DM_FREE_BLOCK USE MUMPS_BUILD_SORT_INDEX_M USE MUMPS_BUF_COMMON, ONLY: MUMPS_BUF_SEND_MAPLIG USE MUMPS_LOAD USE CMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE, & CMUMPS_BLR_ASM_NIV1 USE CMUMPS_LR_DATA_M, ONLY : CMUMPS_BLR_INIT_FRONT, & CMUMPS_BLR_SAVE_NFS4FATHER USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N, NSTEPS INTEGER(8) LA, LRLU, LRLUS, LRLUSM, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) REAL UU INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS, LIW TYPE (MUMPS_TPS_T), TARGET, OPTIONAL :: MUMPS_TPS_ARR(:) TYPE (CMUMPS_TPS_T), TARGET, OPTIONAL :: CMUMPS_TPS_ARR(:) INTEGER, INTENT(IN), OPTIONAL :: L0_OMP_MAPPING(:) INTEGER IDUMMY(1) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER, TARGET :: IW(LIW) INTEGER(8), INTENT(IN) :: PTRARW(1), PTRAIW(1) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ITLOC(N+KEEP(253)), & ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)), & PAMASTER(KEEP(28)) INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER JOBASS,ETATASS LOGICAL SON_LEVEL2 COMPLEX, TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR COMPLEX DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) LOGICAL PACKED_CB, IS_CB_LR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF LOGICAL LPOK INTEGER NBPANELS_L, NBPANELS_U INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER(8) NFRONT8, LAELL8, LAELL_REQ8, ITMP8, KEEP8TMPCOPY INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER LREQ_OOC INTEGER :: SON_XXS, SON_XXLR, SON_XXG INTEGER(8) LSTK8, SIZFR8 LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM, IORG, IBROT INTEGER IARR1 #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER JPOS,ICT11 INTEGER IJROW,NBCOL,NUMORG,IOLDPS INTEGER(8) IACHK, POSELT, LAPOS2, IACHK_ini INTEGER(8) APOS, APOS2, APOS3, POSEL1, ICT12 INTEGER(8) :: JJ2, ICT13 INTEGER(8) :: J18, J28, J38, J48, JJ8 INTEGER(8) :: AINPUT8 INTEGER :: K1, K2, K3, KK, KK1 INTEGER :: J253 INTEGER NSLAVES, NSLSON, NPIVS,NPIV_ANA,NPIV INTEGER PTRCOL, ISLAVE, PDEST,LEVEL INTEGER ISON_IN_PLACE LOGICAL SKIP_TOP_STACK INTEGER ISON_TOP INTEGER(8) SIZE_ISON_TOP8, DYN_SIZE_ISON_TOP8 LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE !$ LOGICAL OMP_PARALLEL_FLAG LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE INTEGER INDX, FIRST_INDEX, SHIFT_INDEX INTEGER PARPIV_T1 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: ITHREAD INTEGER, POINTER :: SON_IWPOS, SON_LIW INTEGER, POINTER, DIMENSION(:) :: SON_IW COMPLEX, POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTEGER PIVOT_OPTION COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER NELT, LPTRAR EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR LOGICAL SSARBR DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR !$ NOMP = OMP_GET_MAX_THREADS() LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) NELT = 1 LPTRAR = 1 NFS4FATHER = -1 PACKED_CB = .FALSE. IS_CB_LR = .FALSE. IN = INODE LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (LEVEL.NE.1) THEN WRITE(*,*) 'INTERNAL ERROR 1 in CMUMPS_FAC_ASM_NIV1 ' CALL MUMPS_ABORT() END IF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) IF (JOBASS.EQ.0) THEN ETATASS= 0 ELSE ETATASS= 2 IOLDPS = PTLUST(STEP(INODE)) NFRONT = IW(IOLDPS + KEEP(IXSZ)) NASS1 = abs(IW(IOLDPS + 2 + KEEP(IXSZ))) ICT11 = IOLDPS + HF - 1 + NFRONT SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 ISON = FRERE(STEP(ISON)) ENDDO ENDIF GOTO 123 ENDIF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) END DO NPIV_ANA=NUMORG NSTEPS = NSTEPS + 1 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 SON_IW => IW IF (KEEP(400).GT.0) THEN IF (present(L0_OMP_MAPPING)) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .NE.0) THEN SON_IW=>MUMPS_TPS_ARR(ITHREAD)%IW ENDIF ENDIF ENDIF NASS = NASS + SON_IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG CALL IS_FRONT_BLR_CANDIDATE(INODE, 1, ND(STEP(INODE)), & NUMORG, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, KEEP(280), LRGROUPS) IF (DAD(STEP(INODE)).NE.0) THEN IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199) ) & .NE. MYID & .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199)) & .EQ.1 & ) THEN IF (LRSTATUS.EQ.1 .OR. LRSTATUS.EQ.3) THEN LRSTATUS = LRSTATUS-1 ENDIF ENDIF ENDIF COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_OOC_GET_PP_SIZES(KEEP(50), NFRONT, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL CMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, SLAVEF, & PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'INTERNAL ERROR 2 after compress ' WRITE(LP, * ) 'IN CMUMPS_FAC_ASM_NIV1 ' WRITE(LP, * ) 'LRLU,LRLUS=', LRLU,LRLUS ENDIF GOTO 270 END IF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 END IF IOLDPS = IWPOS IWPOS = IWPOS + LREQ ISON_TOP = -9999 ISON_IN_PLACE = -9999 SIZE_ISON_TOP8 = 0_8 IF (KEEP(234).NE.0) THEN IF ( IWPOSCB .NE. LIW ) THEN IF ( IWPOSCB+IW(IWPOSCB+1+XXI).NE.LIW) THEN ISON = IW( IWPOSCB + 1 + XXN ) IF ( DAD( STEP( ISON ) ) .EQ. INODE .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)),KEEP(199)) & .EQ. 1 ) & THEN ISON_TOP = ISON CALL MUMPS_GETI8(SIZE_ISON_TOP8,IW(IWPOSCB + 1 + XXR)) CALL MUMPS_GETI8(DYN_SIZE_ISON_TOP8, IW(IWPOSCB + 1 + XXD)) IF (DYN_SIZE_ISON_TOP8 .EQ. 0_8) THEN IF (LRLU .LT. int(NFRONT,8) * int(NFRONT,8)) THEN ISON_IN_PLACE = ISON ENDIF ENDIF END IF END IF END IF END IF NIV1 = .TRUE. IF (.NOT. present(MUMPS_TPS_ARR).AND. & .NOT. present(L0_OMP_MAPPING) ) THEN CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP, KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, IDUMMY, LIDUMMY ) ELSE CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP, KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, IDUMMY, LIDUMMY & , MUMPS_TPS_ARR, L0_OMP_MAPPING ) ENDIF IF (INFO(1).LT.0) GOTO 300 IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL MUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1-FLOP1_EFF, & KEEP,KEEP8) ENDIF IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) ' INTERNAL ERROR 3 ', & ' IN CMUMPS_FAC_ASM_NIV1 ', & ' NFRONT, NFRONT_EFF = ', & NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF NCB = NFRONT - NASS1 MAXFRW = max(MAXFRW, NFRONT) ICT11 = IOLDPS + HF - 1 + NFRONT CALL CMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) PIVOT_OPTION = KEEP(468) IF (UU.EQ.ZERO) THEN PIVOT_OPTION=0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF(PARPIV_T1.NE.0) THEN LAELL8 = LAELL8+int(NASS1,8) ENDIF LAELL_REQ8 = LAELL8 IF ( ISON_IN_PLACE > 0 ) THEN LAELL_REQ8 = LAELL8 - SIZE_ISON_TOP8 ENDIF SKIP_TOP_STACK = (ISON_IN_PLACE.GT.0) CALL CMUMPS_GET_SIZE_NEEDED & (0, LAELL_REQ8, SKIP_TOP_STACK, & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 LRLUSM = min( LRLUS, LRLUSM ) ITMP8 = LAELL8 - SIZE_ISON_TOP8 IF (KEEP(405).EQ.0) THEN KEEP8(69) = KEEP8(69) + ITMP8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + ITMP8 KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ENDIF POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8-SIZE_ISON_TOP8, & KEEP,KEEP8, & LRLUS) IF (KEEP(405).EQ.0) KEEP(429)= KEEP(429)+1 #if defined(ZERO_TRIANGLE) LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) !$ CHUNK8=int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (LAPOS2 - POSELT + 1_8 > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8), KEEP(218))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & NCB, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1,TOPDIAG) ENDIF IF (ETATASS.EQ.1) THEN IF (KEEP(234).NE.0) THEN WRITE(*,*) & "Internal error: ETATASS.EQ.1 and IN-PLACE ACTIVATED" CALL MUMPS_ABORT() ENDIF #if defined(__ve__) !NEC$ IVDEP #endif !$ CHUNK = max( KEEP(360)/2, (NFRONT+NOMP-1) / NOMP ) !$OMP PARALLEL DO PRIVATE(APOS, JJ3) SCHEDULE( STATIC, CHUNK ) !$OMP& IF (NFRONT8 - 1_8 > KEEP(360)) DO JJ8 = 0_8, NFRONT8 - 1_8 JJ3 = min(JJ8+TOPDIAG,int(NASS1-1,8)) APOS = POSELT + JJ8 * NFRONT8 A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO ELSE NUMROWS = min(NFRONT8, (IPTRLU-POSELT) / NFRONT8 ) !$ CHUNK = max(KEEP(360)/2, !$ & ( ((int(NUMROWS)+NOMP-1) / NOMP + 2) / 3) ) #if defined(__ve__) !NEC$ IVDEP #endif !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK ) !$OMP& IF (int(NUMROWS - 1) .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = POSELT + JJ8 * NFRONT8 JJ3 = min( NFRONT8 - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS + JJ3) = ZERO ENDDO !$OMP END PARALLEL DO IF( NUMROWS .LT. NFRONT8 ) THEN APOS = POSELT + NFRONT8*NUMROWS A(APOS : min(IPTRLU,APOS+NUMROWS)) = ZERO ENDIF ENDIF END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS IW(IOLDPS + KEEP(IXSZ)) = NFRONT IW(IOLDPS + KEEP(IXSZ)+ 1) = 0 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN CALL CMUMPS_BLR_INIT_FRONT (IW(IOLDPS+XXF), INFO, & MTK405=KEEP(405)) IF (INFO(1).LT.0) GOTO 500 ENDIF ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL CMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) CALL CMUMPS_BLR_SAVE_NFS4FATHER ( IW(IOLDPS+XXF), & ESTIM_NFS4FATHER_ATSON ) IF (INFO(1).LT.0) GOTO 500 ENDIF ENDIF ENDIF 123 CONTINUE IF (NUMSTK.NE.0) THEN IF (ISON_TOP > 0) THEN ISON = ISON_TOP ELSE ISON = IFSON ENDIF DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_LIW => LIW SON_IWPOS => IWPOS SON_A => A ITHREAD = 0 IF (KEEP(400).GT.0) THEN IF (present(L0_OMP_MAPPING)) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .NE.0) THEN SON_LIW => MUMPS_TPS_ARR(ITHREAD)%LIW SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW SON_IWPOS => MUMPS_TPS_ARR(ITHREAD)%IWPOS SON_A => CMUMPS_TPS_ARR(ITHREAD)%A ENDIF ENDIF ENDIF LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + KEEP(IXSZ) + 1) NPIVS = SON_IW(ISTCHK + KEEP(IXSZ) + 3) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = SON_IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.SON_IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT = PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT = ISTCHK ENDIF SON_XXS = SON_IW(ISTCHK_CB_RIGHT+XXS) SON_XXLR = SON_IW(ISTCHK_CB_RIGHT+XXLR) SON_XXG = SON_IW(ISTCHK_CB_RIGHT+XXG) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IS_CB_LR = ( SON_XXLR.EQ.1 .OR. SON_XXLR.EQ.3 ) & .AND. (KEEP(489).EQ.1.OR.KEEP(489).EQ.3) LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = SON_IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF K1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN K2 = K1 + LSTK - 1 IF (PACKED_CB) THEN SIZFR8 = (LSTK8*(LSTK8+1_8)/2_8) ELSE SIZFR8 = LSTK8*LSTK8 ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * LSTK8 ELSE IF (PACKED_CB) THEN SIZFR8 = int(NELIM,8) * int(NELIM+1,8)/2_8 ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) ENDIF END IF K2 = K1 + NELIM - 1 ENDIF IF (JOBASS.EQ.0) THEN IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + LSTK8*LSTK8 ELSE OPASSW = OPASSW + LSTK8*(LSTK8+1)/2_8 ENDIF ELSE IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + int(NELIM,8)*LSTK8 ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM,8)/2_8 ENDIF ENDIF ENDIF CALL MUMPS_GETI8(DYN_SIZE, SON_IW(ISTCHK_CB_RIGHT+XXD)) IS_DYNAMIC_CB = DYN_SIZE .GT. 0_8 IF ( IS_DYNAMIC_CB ) THEN CALL CMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) ENDIF IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (NFRONT .EQ. LSTK.AND. ISON.EQ.ISON_IN_PLACE & .AND.IACHK + SIZFR8 - 1_8 .EQ. POSFAC - 1_8 ) THEN GOTO 205 ENDIF IF (K2.GE.K1) THEN RESET_TO_ZERO = (IACHK .LT. POSFAC .AND. & ISON.EQ.ISON_IN_PLACE) RISK_OF_SAME_POS = IACHK + SIZFR8 - 1_8 .EQ. POSFAC - 1_8 & .AND. ISON.EQ.ISON_IN_PLACE RISK_OF_SAME_POS_THIS_LINE = .FALSE. IACHK_ini = IACHK !$ OMP_PARALLEL_FLAG = (RESET_TO_ZERO.EQV..FALSE.).AND. !$ & ((K2-K1).GT.KEEP(360)) !$OMP PARALLEL IF(OMP_PARALLEL_FLAG) PRIVATE(APOS, KK1, JJ2,IACHK) !$OMP& FIRSTPRIVATE(RISK_OF_SAME_POS_THIS_LINE,RESET_TO_ZERO) !$OMP DO DO 170 KK = K1, K2 APOS = POSEL1 + int(SON_IW(KK),8) * int(NFRONT,8) IACHK = IACHK_ini + int(KK-K1,8)*int(LSTK,8) IF (RESET_TO_ZERO) THEN IF (RISK_OF_SAME_POS) THEN IF (KK.EQ.K2) THEN RISK_OF_SAME_POS_THIS_LINE = & (ISON .EQ. ISON_IN_PLACE) & .AND. ( APOS + int(SON_IW(K1+LSTK-1)-1,8).EQ. & IACHK+int(LSTK-1,8) ) ENDIF ENDIF IF ((IACHK .GE. POSFAC).AND.(KK>K1))THEN RESET_TO_ZERO =.FALSE. ENDIF IF (RISK_OF_SAME_POS_THIS_LINE) THEN DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1 + KK1 - 1) - 1,8) IF ( IACHK+int(KK1-1,8) .NE. JJ2 ) THEN A(JJ2) = A(IACHK + int(KK1 - 1,8)) A(IACHK + int(KK1 -1,8)) = ZERO ENDIF ENDDO ELSE #if defined(__ve__) !NEC$ IVDEP #endif DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(IACHK + int(KK1 - 1,8)) A(IACHK + int(KK1 -1,8)) = ZERO ENDDO ENDIF ELSE #if defined(__ve__) !NEC$ IVDEP #endif DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) ENDDO ENDIF 170 CONTINUE !$OMP END DO !$OMP END PARALLEL END IF ELSE IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (ISON .EQ. ISON_IN_PLACE) THEN CALL CMUMPS_LDLT_ASM_NIV12_IP(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB) ELSE IF (SIZFR8 .GT. 0) THEN CALL CMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF ENDIF IF (IS_CB_LR .AND. LEVEL1) THEN POSEL1 = PTRAST(STEP(INODE)) CALL CMUMPS_BLR_ASM_NIV1 (A, LA, & POSEL1, NFRONT, NASS1, SON_IW(ISTCHK+XXF), & SON_IW, SON_LIW, & LSTK, NELIM, K1, K1+LSTK-1, KEEP(50), & KEEP, KEEP8, OPASSW) ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF ((SAME_PROC).AND.ETATASS.NE.1) THEN IF (KEEP(50).NE.0) THEN K2 = K1 + LSTK - 1 #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K1, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO ELSE K2 = K1 + LSTK - 1 K3 = K1 + NELIM #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K3, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO IF (NELIM .NE. 0) THEN K3 = K3 - 1 #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K1, K3 JPOS = SON_IW(KK) + ICT11 SON_IW(KK) = IW(JPOS) ENDDO ENDIF ENDIF ENDIF IF (ETATASS.NE.1) THEN IF ( SAME_PROC ) THEN PTRIST(STEP(ISON)) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF IF (ITHREAD .EQ. 0) THEN CALL CMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & (ISON .EQ. ISON_TOP) & ) ELSE CALL MUMPS_LOAD_DISABLE() CALL CMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & MUMPS_TPS_ARR(ITHREAD)%IW(1), & MUMPS_TPS_ARR(ITHREAD)%LIW, & MUMPS_TPS_ARR(ITHREAD)%LRLU, & MUMPS_TPS_ARR(ITHREAD)%LRLUS, & MUMPS_TPS_ARR(ITHREAD)%IPTRLU, & MUMPS_TPS_ARR(ITHREAD)%IWPOSCB, & MUMPS_TPS_ARR(ITHREAD)%LA, KEEP,KEEP8, .FALSE. & ) CALL MUMPS_LOAD_ENABLE() ENDIF IF (IS_DYNAMIC_CB) THEN CALL CMUMPS_DM_FREE_BLOCK(SON_XXG, & SON_A, SIZFR8, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF ELSE PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP, KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL CMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, IDUMMY, & NFRONT, NASS1, NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & IZERO, IDUMMY, IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP, KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE., LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) IF (ISON .LE. 0) THEN ISON = IFSON ENDIF 220 CONTINUE END IF IF (ETATASS.EQ.2) GOTO 500 POSELT = PTRAST(STEP(INODE)) IBROT = INODE IARR1 = PTRDEBARR(STEP(INODE)) DO 260 IORG = 1, NUMORG AINPUT8 = PTR8ARR(IARR1+IORG-1) J18 = AINPUT8 J28 = J18 + NINCOLARR(IARR1+IORG-1) J38 = J28 + 1 J48 = J28 + NINROWARR(IARR1+IORG-1) IJROW = INTARR(J18) ICT12 = POSELT + int(IJROW - NFRONT - 1,8) #if defined(__ve__) IF ( KEEP(265).NE. 0 ) THEN !NEC$ IVDEP #endif DO JJ8 = J18, J28 APOS2 = ICT12 + int(INTARR(JJ8),8) * NFRONT8 A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + 1_8 ENDDO #if defined(__ve__) ELSE DO JJ8 = J18, J28 APOS2 = ICT12 + int(INTARR(JJ8),8) * NFRONT8 A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + 1_8 ENDDO ENDIF #endif IF (J38 .LE. J48) THEN ICT13 = POSELT + int(IJROW - 1,8) * NFRONT8 NBCOL = int(J48 - J38 + 1_8) #if defined(__ve__) IF ( KEEP(265) .NE. 0 ) THEN !NEC$ IVDEP #endif DO JJ8 = 1_8, int(NBCOL,8) APOS3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8) - 1_8,8) A(APOS3) = A(APOS3) + DBLARR(AINPUT8 + JJ8 - 1_8) ENDDO #if defined(__ve__) ELSE DO JJ8 = 1_8, int(NBCOL,8) APOS3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8) - 1_8,8) A(APOS3) = A(APOS3) + DBLARR(AINPUT8 + JJ8 - 1_8) ENDDO ENDIF #endif ENDIF IF (KEEP(50).EQ.0) THEN DO J253=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ELSE DO J253=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+J253-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE IF (PARPIV_T1.NE.0.AND.(.NOT.SON_LEVEL2)) THEN IOLDPS = PTLUST(STEP(INODE)) CALL CMUMPS_PARPIVT1_SET_NVSCHUR_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1, NASS) ENDIF GOTO 500 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING CMUMPS_FAC_ASM' ENDIF GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING CMUMPS_FAC_ASM' ENDIF INFO(1) = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, RECV BUFFER TOO SMALL DURING CMUMPS_FAC_ASM' ENDIF INFO(1) = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF( INFO(1).EQ.-13 ) THEN IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING CMUMPS_FAC_ASM' ENDIF INFO(2) = NUMSTK + 1 ENDIF 490 CONTINUE IF ( KEEP(405) .EQ. 0 ) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_ASM_NIV1 SUBROUTINE CMUMPS_FAC_ASM_NIV2(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, INFO, & ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, roota, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, MEM_DISTRIB & , LRGROUPS & ) !$ USE OMP_LIB USE MUMPS_BUILD_SORT_INDEX_M USE MUMPS_BUF_COMMON, ONLY: MUMPS_BUF_SEND_MAPLIG, & MUMPS_BUF_SEND_DESC_BANDE USE MUMPS_LOAD USE CMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_PTR, & CMUMPS_DM_IS_DYNAMIC USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC, LA INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE, MAXFRW, LPOOL, LEAF, & IWPOS, IWPOSCB, COMP, SLAVEF COMPLEX, TARGET :: A(LA) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(1), PTRAIW(1) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PROCNODE_STEPS(KEEP(28)), BUFR(LBUFR) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR COMPLEX DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INTEGER LP, HS, HF, HF_OLD, NCBSON, NSLAVES_OLD LOGICAL LPOK INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL COMPLEX, DIMENSION(:), POINTER :: SON_A INTEGER :: MAXWASTEDPROCS PARAMETER (MAXWASTEDPROCS=1) INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER I INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER :: SON_XXS INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL PACKED_CB, IS_CB_LR INTEGER(8) :: LCB LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER MP INTEGER :: K1, K2, KK, KK1 INTEGER :: J253 INTEGER(8) :: AINPUT8, J18, J28, J38, J48, JJ8 INTEGER(8) :: LAPOS2, JJ2, JJ3 INTEGER(8) :: ICT13 INTEGER(8) :: IACHK, APOS, APOS2, POSELT, ICT12, POSEL1 #if ! defined(ZERO_TRIANGLE) INTEGER :: TOPDIAG #endif !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM,NPIVS,NCOLS,NROWS, & IORG INTEGER LDAFS, LDA_SON, IJROW, IBROT INTEGER IARR1 INTEGER NBCOL,NUMORG,IOLDPS, NUMORG_SPLIT INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, PDEST INTEGER PDEST1(1) INTEGER :: ISLAVE INTEGER TYPESPLIT INTEGER ISON_IN_PLACE LOGICAL IS_ofType5or6, SPLIT_MAP_RESTART INTEGER NMB_OF_CAND, NMB_OF_CAND_ORIG LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER IZERO INTEGER IDUMMY(1) PARAMETER( IZERO = 0 ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT COMPLEX ZERO REAL RZERO PARAMETER( RZERO = 0.0E0 ) PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER NELT, LPTRAR logical :: force_cand INTEGER ETATASS INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX REAL MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER, ALLOCATABLE, DIMENSION(:) :: SONROWS_PER_ROW INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IS_ofType5or6 = .FALSE. PACKED_CB = .FALSE. ETATASS = 0 IN = INODE NSTEPS = NSTEPS + 1 KEEP(429) = KEEP(429)+1 NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON NCBSON_MAX = 0 NELT = 1 LPTRAR = 1 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 IF ( KEEP(48)==5 .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) ENDIF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 CALL IS_FRONT_BLR_CANDIDATE(INODE, 2, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, KEEP(280), LRGROUPS) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then force_cand=.FALSE. ELSE force_cand=(mod(KEEP(24),2).eq.0) end if TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) SPLIT_MAP_RESTART = .FALSE. IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) NMB_OF_CAND = CAND( SLAVEF+1, INIV2 ) NMB_OF_CAND_ORIG = NMB_OF_CAND SIZE_TMP_SLAVES_LIST = NMB_OF_CAND IF (IS_ofType5or6) THEN DO I=NMB_OF_CAND+1,SLAVEF IF ( CAND( I, INIV2 ).LT.0) EXIT NMB_OF_CAND = NMB_OF_CAND +1 ENDDO SIZE_TMP_SLAVES_LIST = NSLSON-1 IF (INODE.EQ.-999999) THEN SPLIT_MAP_RESTART = .TRUE. ENDIF ENDIF IF (IS_ofType5or6.AND.SPLIT_MAP_RESTART) THEN TYPESPLIT = 4 IS_ofType5or6 = .FALSE. SIZE_TMP_SLAVES_LIST = NMB_OF_CAND CAND (SLAVEF+1, INIV2) = SIZE_TMP_SLAVES_LIST ENDIF ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 NMB_OF_CAND = SLAVEF - 1 NMB_OF_CAND_ORIG = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF IF ( (TYPESPLIT.EQ.4) & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) & ) THEN IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) IF (SPLIT_MAP_RESTART) THEN IS_ofType5or6 = .TRUE. TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) CAND( SLAVEF+1, INIV2 ) = NMB_OF_CAND_ORIG ENDIF ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) IF (KEEP(376) .EQ. 1) THEN NFRONT = IW( PIMASTER(STEP(IFSON)) + KEEP(IXSZ)) ENDIF CALL MUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND(1,INIV2), NMB_OF_CAND_ORIG, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES, & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST & ) ENDIF ELSE CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_OOC_GET_PP_SIZES(KEEP(50), NASS1, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL CMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & LRLUS,KEEP(IXSZ), & COMP, DKEEP(97), MYID, SLAVEF, & PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress CMUMPS_FAC_ASM_NIV2 ', & 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. ALLOCATE(SONROWS_PER_ROW(NFRONT-NASS1), stat=allocok) IF (allocok > 0) THEN GOTO 275 ENDIF ISON_IN_PLACE = -9999 CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP,KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, SONROWS_PER_ROW, & NFRONT-NASS1 ) IF (INFO(1).LT.0) GOTO 250 IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN WRITE(*,*) ' Internal error 1 in fac_ass due to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF WRITE(*,*) ' SPLITTING NOT YET READY FOR THAT' CALL MUMPS_ABORT() ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN NCB = NFRONT_EFF - NASS1 NSLAVES_OLD = NSLAVES HF_OLD = HF IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP, KEEP8, ICNTL, & CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - & (NSLAVES_OLD - NSLAVES) IF (NSLAVES_OLD .NE. NSLAVES) THEN IF (NSLAVES_OLD > NSLAVES) THEN DO KK=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+KK)=IW(IOLDPS+HF_OLD+KK) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO KK=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+KK) = IW(IOLDPS+HF_OLD+KK) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) MYID,': INTERNAL ERROR 2 ', & ' IN CMUMPS_FAC_ASM_NIV2 , INODE=', & INODE, ' NFRONT, NFRONT_EFF=', NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max(MAXFRW, NFRONT) PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+KEEP(IXSZ)) = NFRONT IW(IOLDPS + 1+KEEP(IXSZ)) = 0 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+NSLAVES+KEEP(IXSZ))= & TMP_SLAVES_LIST(1:NSLAVES) ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL CMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) ENDIF ENDIF ENDIF CALL MUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM_LOAD, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP, KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) IF(KEEP(86).EQ.1)THEN IF(mod(KEEP(24),2).eq.0)THEN CALL MUMPS_LOAD_SEND_MD_INFO(SLAVEF, & CAND(SLAVEF+1,INIV2), & CAND(1,INIV2), & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN CALL MUMPS_LOAD_SEND_MD_INFO(SLAVEF, & SLAVEF-1, & TMP_SLAVES_LIST, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ENDIF ENDIF DEALLOCATE(TMP_SLAVES_LIST) IF (KEEP(50).EQ.0) THEN LAELL8 = int(NASS1,8) * int(NFRONT,8) LDAFS = NFRONT ELSE LAELL8 = int(NASS1,8)*int(NASS1,8) IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) & LAELL8 = LAELL8+int(NASS1,8) LDAFS = NASS1 ENDIF CALL CMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= LRSTATUS IW(IOLDPS+XXG) = MemNotPinned CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8,LRLUS) POSEL1 = POSELT - int(LDAFS,8) #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8 = int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (LAPOS2 - POSELT > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO JJ8 = POSELT, LAPOS2 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max(KEEP(360)/2, !$ & ( (( LDAFS + NOMP -1 ) / NOMP + 2) / 3) ) APOS = POSELT #if defined(__ve__) !NEC$ IVDEP #endif !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK) !$OMP& IF (LDAFS - 1 .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(LDAFS-1,8) APOS = POSELT + JJ8 * int(LDAFS,8) JJ3 = min( int(LDAFS,8) - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) A(APOSMAX:APOSMAX+int(LDAFS-1,8))=ZERO ENDIF END IF #endif IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) IF (NELIM.EQ.0) GOTO 210 LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT=PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT=ISTCHK ENDIF SON_XXS = IW(ISTCHK_CB_RIGHT + XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF IF (KEEP(50).EQ.0) THEN LDA_SON = LSTK LCB = int(NELIM,8)*int(LSTK,8) ELSE IF (NSLSON.EQ.0) THEN IF (SAME_PROC) THEN IS_CB_LR = IW(ISTCHK_CB_RIGHT+XXLR).EQ. 1 .OR. & IW(ISTCHK_CB_RIGHT+XXLR).EQ. 3 IF (IS_CB_LR) THEN LDA_SON = NELIM ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = NELIM ENDIF IF (PACKED_CB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN OPASSW = OPASSW + dble(LCB) ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM+1,8)/2_8 ENDIF IS_DYNAMIC_CB = & CMUMPS_DM_IS_DYNAMIC(IW(ISTCHK_CB_RIGHT+XXD: & ISTCHK_CB_RIGHT+XXD+1)) IF ( IS_DYNAMIC_CB ) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_CB_RIGHT+XXD)) CALL CMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) SON_A=>A ENDIF K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IF (KEEP(50).eq.0) THEN IF (IS_ofType5or6) THEN APOS = POSELT DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + SON_A(IACHK+JJ8-1_8) ENDDO ELSE DO 170 KK = K1, K2 APOS = POSEL1 + int(IW(KK),8) * int(LDAFS,8) DO 160 KK1 = 1, LSTK JJ2 = APOS + int(IW(K1 + KK1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (LCB .GT. 0) THEN CALL CMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF IBROT = INODE APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) IARR1 = PTRDEBARR(STEP(INODE)) DO 260 IORG = 1, NUMORG AINPUT8 = PTR8ARR(IARR1+IORG-1) J18 = AINPUT8 J28 = J18 + NINCOLARR(IARR1+IORG-1) J38 = J28 + 1_8 J48 = J28 + NINROWARR(IARR1+IORG-1) IJROW = INTARR(J18) ICT12 = POSELT + int(IJROW - 1 - LDAFS, 8) MAXARR = RZERO DO JJ8 = J18, J28 IF (KEEP(219).NE.0) THEN IF (INTARR(JJ8).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ8),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) ELSEIF (KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AINPUT8))) ENDIF ELSE IF (INTARR(JJ8).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ8),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) ENDIF ENDIF AINPUT8 = AINPUT8 + 1_8 ENDDO IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(IJROW-1,8)) = cmplx(MAXARR,kind=kind(A)) ENDIF IF (J38 .GT. J48) GOTO 255 ICT13 = POSELT + int(IJROW - 1,8) * int(LDAFS,8) NBCOL = int(J48 - J38 + 1_8) DO JJ8 = 1_8, int(NBCOL,8) JJ3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8),8) - 1_8 A(JJ3) = A(JJ3) + DBLARR(AINPUT8 + JJ8 - 1_8) ENDDO 255 CONTINUE IF (KEEP(50).EQ.0) THEN DO J253 = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & NBLIG, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 IERR = -1 DO WHILE (IERR .EQ.-1) IF ( KEEP(50) .eq. 0 ) THEN NBCOL = NFRONT CALL MUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL MUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF ENDDO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 ENDDO DEALLOCATE(SONROWS_PER_ROW) IF (NUMSTK.EQ.0) GOTO 500 ISON = IFSON DO IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + 2 + KEEP(IXSZ) ) ELSE NROWS = NCOLS ENDIF PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN NFS4FATHER = NCBSON DO I=0,NCBSON-1 IF(IW(PTRCOL+I) .GT. NASS1) THEN NFS4FATHER = I EXIT ENDIF ENDDO NFS4FATHER = NFS4FATHER + NELIM ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) IF (PDEST1(1).EQ.MYID) THEN CALL CMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & NFRONT, NASS1, NFS4FATHER, NCBSON, IW( PTRCOL ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, roota, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, PDEST1, NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, & NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL CMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & NFRONT, NASS1,NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), INFO(2), & MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, LPTRAR, NELT, IW, & IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & CMUMPS_FAC_ASM_NIV2' ENDIF INFO(2) = NUMSTK + 1 ENDIF GOTO 490 245 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING COPY_CAND', & ' DURING CMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = SLAVEF+1 GOTO 490 265 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING CMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING CMUMPS_FAC_ASM_NIV2' ENDIF GOTO 490 275 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING SONROWS_PER_ROW', & ' DURING CMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = NFRONT-NASS1 GOTO 490 290 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (1) DURING CMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (1) DURING CMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (2)', &' DURING CMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (2)', &' DURING CMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -20 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 490 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_ASM_NIV2 END MODULE CMUMPS_FAC_ASM_MASTER_M MUMPS_5.8.1/src/dtype3_root.F0000664000175000017500000016132515042446437015630 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ASS_ROOT( root, roota, KEEP50, & NROW_SON, NCOL_SON, INDROW_SON, & INDCOL_SON, NSUPCOL, VAL_SON, VAL_ROOT, & LOCAL_M, LOCAL_N, & RHS_ROOT, NLOC_ROOT, CBP ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER, INTENT(IN) :: KEEP50 INTEGER NCOL_SON, NROW_SON, NSUPCOL INTEGER, intent(in) :: CBP INTEGER INDROW_SON( NROW_SON ), INDCOL_SON( NCOL_SON ) INTEGER LOCAL_M, LOCAL_N DOUBLE PRECISION VAL_SON( NCOL_SON, NROW_SON ) DOUBLE PRECISION VAL_ROOT( LOCAL_M, LOCAL_N ) INTEGER NLOC_ROOT DOUBLE PRECISION RHS_ROOT( LOCAL_M, NLOC_ROOT ) INTEGER I, J, INDROW, INDCOL, IPOSROOT, JPOSROOT IF (CBP .EQ. 0) THEN DO I = 1, NROW_SON INDROW = INDROW_SON(I) IPOSROOT = (root%NPROW*((INDROW-1)/root%MBLOCK)+root%MYROW) & * root%MBLOCK + mod(INDROW-1,root%MBLOCK) + 1 DO J = 1, NCOL_SON-NSUPCOL INDCOL = INDCOL_SON(J) IF (KEEP50.NE.0) THEN JPOSROOT = (root%NPCOL*((INDCOL-1)/root%NBLOCK)+root%MYCOL) & * root%NBLOCK + mod(INDCOL-1,root%NBLOCK) + 1 IF (IPOSROOT < JPOSROOT) THEN CYCLE ENDIF ENDIF VAL_ROOT( INDROW, INDCOL ) = & VAL_ROOT( INDROW, INDCOL ) + VAL_SON(J,I) END DO DO J = NCOL_SON-NSUPCOL+1, NCOL_SON INDCOL = INDCOL_SON(J) RHS_ROOT( INDROW, INDCOL ) = & RHS_ROOT( INDROW, INDCOL ) + VAL_SON(J,I) ENDDO END DO ELSE DO I=1, NROW_SON DO J = 1, NCOL_SON RHS_ROOT( INDROW_SON( I ), INDCOL_SON(J)) = & RHS_ROOT(INDROW_SON(I),INDCOL_SON(J)) + VAL_SON(J,I) ENDDO ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_ASS_ROOT RECURSIVE SUBROUTINE DMUMPS_BUILD_AND_SEND_CB_ROOT & ( COMM_LOAD, ASS_IRECV, N, ISON, IROOT, & PTRI, PTRR, & root, roota, NBROW, NBCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, SHIFT_VAL_SON_ARG, LDA_ARG, TAG, & MYID, COMM, BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,TRANSPOSE_ASM, & ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS, NELIM_ROOT, NELIM_ROW, NELIM_COL & ) USE DMUMPS_OOC USE DMUMPS_BUF USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER N, ISON, IROOT, TAG INTEGER PTRI( KEEP(28) ) INTEGER(8) :: PTRR( KEEP(28) ) INTEGER NBROW, NBCOL INTEGER, INTENT(IN):: LDA_ARG INTEGER(8), INTENT(IN) :: SHIFT_VAL_SON_ARG INTEGER SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER MYID, COMM LOGICAL TRANSPOSE_ASM INTEGER :: NELIM_ROOT, NELIM_ROW, NELIM_COL INCLUDE 'mpif.h' INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NSTK( N ) INTEGER COMP, IFLAG, IERROR INTEGER PERM(N) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER INTARR( KEEP8(27) ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION, DIMENSION(:), POINTER :: SONA_PTR INTEGER(8) :: LSONA_PTR, POSSONA_PTR INTEGER allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: PTRROW, PTRCOL INTEGER, ALLOCATABLE, DIMENSION(:) :: NSUPROW, NSUPCOL INTEGER, ALLOCATABLE, DIMENSION(:) :: ROW_INDEX_LIST INTEGER, ALLOCATABLE, DIMENSION(:) :: COL_INDEX_LIST INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER I, POS_IN_ROOT, IROW, JCOL, IGLOB, JGLOB INTEGER PDEST, IERR INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: POSROOT INTEGER NSUBSET_ROW, NSUBSET_COL INTEGER NRLOCAL, NCLOCAL INTEGER :: LDA INTEGER(8) :: SHIFT_VAL_SON LOGICAL SET_IRECV, BLOCKING, MESSAGE_RECEIVED INTEGER NBROWS_ALREADY_SENT INTEGER SIZE_MSG INTEGER LP INCLUDE 'mumps_headers.h' LOGICAL SKIPLAST_RHS_ROWS, BCP_SYM_NONEMPTY INTEGER BBPCBP BBPCBP = 0 LP = ICNTL(1) IF ( ICNTL(4) .LE. 0 ) LP = -1 IF (LDA_ARG < 0) THEN CALL DMUMPS_SET_LDA_SHIFT_VAL_SON(IW, LIW, PTRI(STEP(ISON)), & LDA, SHIFT_VAL_SON) ELSE LDA = LDA_ARG SHIFT_VAL_SON = SHIFT_VAL_SON_ARG ENDIF ALLOCATE(PTRROW(root%NPROW + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPROW + 1 endif ALLOCATE(PTRCOL(root%NPCOL + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPCOL + 1 endif ALLOCATE(NSUPROW(root%NPROW + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPROW + 1 endif ALLOCATE(NSUPCOL(root%NPCOL + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPCOL + 1 endif IF (IFLAG.LT.0) THEN IF (LP > 0) write(6,*) MYID, ' : MEMORY ALLOCATION ', & 'FAILURE in DMUMPS_BUILD_AND_SEND_CB_ROOT' CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF SKIPLAST_RHS_ROWS = ((KEEP(253).GT.0).AND.(KEEP(50).EQ.0)) BCP_SYM_NONEMPTY = .FALSE. PTRROW = 0 PTRCOL = 0 NSUPROW = 0 NSUPCOL = 0 DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (IGLOB.GT.N) THEN BCP_SYM_NONEMPTY = .TRUE. POS_IN_ROOT = IGLOB - N JCOL = mod((POS_IN_ROOT-1)/root%NBLOCK,root%NPCOL) NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 ELSE IF ( I .LE. NELIM_ROW ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( IGLOB ) ENDIF 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 IF ( I .LE. NELIM_ROW ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( IGLOB ) ENDIF ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, root%NPCOL ) IF (IGLOB.GT.N) & NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 END IF END DO IF (KEEP(50).NE.0 .AND.(.NOT.TRANSPOSE_ASM).AND.BCP_SYM_NONEMPTY) & BBPCBP = 1 DO I = 1, NBCOL JGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_COL_SON + I - 1 ) IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (KEEP(50).EQ.0) THEN IF (JGLOB.LE.N) THEN IF ( I.LE.NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L(JGLOB) ENDIF 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 IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( JGLOB ) ENDIF JCOL = mod((POS_IN_ROOT-1) / root%NBLOCK, root%NPCOL ) PTRCOL ( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 IF (BCP_SYM_NONEMPTY) THEN 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 IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( JGLOB ) ENDIF ELSE POS_IN_ROOT = JGLOB-N ENDIF IROW = mod( ( POS_IN_ROOT - 1 ) / & root%MBLOCK, root%NPROW ) PTRROW ( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 END IF END DO PTRROW( 1 ) = 1 DO IROW = 2, root%NPROW + 1 PTRROW( IROW ) = PTRROW( IROW ) + PTRROW( IROW - 1 ) END DO PTRCOL( 1 ) = 1 DO JCOL = 2, root%NPCOL + 1 PTRCOL( JCOL ) = PTRCOL( JCOL ) + PTRCOL( JCOL - 1 ) END DO ALLOCATE(ROW_INDEX_LIST(PTRROW(root%NPROW+1)-1+1), & stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = PTRROW(root%NPROW+1)-1+1 endif ALLOCATE(COL_INDEX_LIST(PTRCOL(root%NPCOL+1)-1+1), & stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = PTRCOL(root%NPCOL+1)-1+1 endif DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (IGLOB.GT.N) CYCLE IF ( I .LE. NELIM_ROW ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( IGLOB ) 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 ELSE IF (IGLOB.LE.N) THEN IF ( I .LE. NELIM_ROW ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( IGLOB ) ENDIF ELSE POS_IN_ROOT = IGLOB - N ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, & root%NPCOL ) COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 END IF END DO DO I = 1, NBCOL JGLOB = IW( PTRI(STEP(ISON))+SHIFT_LIST_COL_SON+I - 1 ) IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF ( JGLOB.LE.N ) THEN IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( JGLOB ) ENDIF 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 IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( JGLOB ) ENDIF 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 IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L(JGLOB) ENDIF ENDIF IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I PTRROW( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 ENDDO ENDIF DO IROW = root%NPROW, 2, -1 PTRROW( IROW ) = PTRROW( IROW - 1 ) END DO PTRROW( 1 ) = 1 DO JCOL = root%NPCOL, 2, -1 PTRCOL( JCOL ) = PTRCOL( JCOL - 1 ) END DO PTRCOL( 1 ) = 1 JCOL = root%MYCOL IROW = root%MYROW IF ( root%yes ) THEN if (IROW .ne. root%MYROW .or. JCOL.ne.root%MYCOL) then write(*,*) ' error in grid position buildandsendcbroot' CALL MUMPS_ABORT() end if IF ( PTRIST(STEP(IROOT)).EQ.0.AND. & PTLUST_S(STEP(IROOT)).EQ.0) THEN CALL DMUMPS_ROOT_ALLOC_STATIC(root, roota, IROOT, N, IW, LIW, & A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP, IERROR ) KEEP(121) = -1 IF (IFLAG.LT.0) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF ELSE KEEP(121) = KEEP(121) - 1 IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL DMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL DMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL DMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT+N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF END IF CALL DMUMPS_DM_SET_DYNPTR( IW(PTRI(STEP(ISON))+XXS), A, LA, & PTRR(STEP(ISON)), IW(PTRI(STEP(ISON))+XXD), & IW(PTRI(STEP(ISON))+XXR), & SONA_PTR, POSSONA_PTR, LSONA_PTR ) IF (KEEP(60) .NE. 0 ) THEN LOCAL_M = root%SCHUR_LLD LOCAL_N = root%SCHUR_NLOC NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) CALL DMUMPS_ROOT_LOCAL_ASSEMBLY( N, & roota%SCHUR_POINTER(1), & LOCAL_M, LOCAL_N, & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NRLOCAL, & NCLOCAL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%RG2L(1), TRANSPOSE_ASM, & KEEP, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) ELSE IF ( PTRIST(STEP( IROOT )) .GE. 0 ) THEN IF ( PTRIST(STEP( IROOT )) .EQ. 0 ) THEN LOCAL_N = IW( PTLUST_S(STEP(IROOT)) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST_S(STEP(IROOT)) + 2 + KEEP(IXSZ)) POSROOT = PTRFAC(IW( PTLUST_S(STEP(IROOT)) +4+KEEP(IXSZ) )) ELSE LOCAL_N = - IW( PTRIST(STEP(IROOT)) +KEEP(IXSZ)) LOCAL_M = IW( PTRIST(STEP(IROOT)) + 1 +KEEP(IXSZ)) POSROOT = PAMASTER(STEP( IROOT )) ENDIF NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) CALL DMUMPS_ROOT_LOCAL_ASSEMBLY( N, A( POSROOT ), & LOCAL_M, LOCAL_N, & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NRLOCAL, & NCLOCAL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%RG2L(1), TRANSPOSE_ASM, & KEEP, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) END IF ENDIF END IF DO IROW = 0, root%NPROW - 1 DO JCOL = 0, root%NPCOL - 1 PDEST = IROW * root%NPCOL + JCOL IF ( (root%MYROW.eq.IROW.and.root%MYCOL.eq.JCOL) .and. & MYID.ne.PDEST) THEN write(*,*) 'error: myrow,mycol=',root%MYROW,root%MYCOL write(*,*) ' MYID,PDEST=',MYID,PDEST CALL MUMPS_ABORT() END IF IF ( root%MYROW .NE. IROW .OR. root%MYCOL .NE. JCOL) THEN NBROWS_ALREADY_SENT = 0 IERR = -1 DO WHILE ( IERR .EQ. -1 ) NSUBSET_ROW = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) NSUBSET_COL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) IF ( LRLU .LT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) & .AND. LRLUS .GT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) ) & THEN CALL DMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) MYID,": pb compress in", & "DMUMPS_BUILD_AND_SEND_CB_ROOT" WRITE(*,*) MYID,': LRLU, LRLUS=',LRLU,LRLUS CALL MUMPS_ABORT() END IF END IF CALL DMUMPS_DM_SET_DYNPTR( & IW(PTRI(STEP(ISON))+XXS), A, LA, & PTRR(STEP(ISON)), IW(PTRI(STEP(ISON))+XXD), & IW(PTRI(STEP(ISON))+XXR), & SONA_PTR, POSSONA_PTR, LSONA_PTR ) CALL DMUMPS_BUF_SEND_CONTRIB_TYPE3_I( N, ISON, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & TAG, & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NSUBSET_ROW, NSUBSET_COL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%NPROW, root%NPCOL, root%MBLOCK, & root%RG2L(1), & root%NBLOCK, PDEST, & COMM, IERR, A( POSFAC ), LRLU, TRANSPOSE_ASM, & SIZE_MSG, NBROWS_ALREADY_SENT, KEEP, BBPCBP, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK, & COMP, IFLAG, IERROR, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, MYID, SLAVEF, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW,PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (LDA_ARG < 0) THEN CALL DMUMPS_SET_LDA_SHIFT_VAL_SON( & IW, LIW, PTRI(STEP(ISON)), & LDA, SHIFT_VAL_SON) ENDIF END IF END DO IF ( IERR == -2 ) THEN IFLAG = -17 IERROR = SIZE_MSG IF (LP > 0) WRITE(LP, *) "FAILURE, SEND BUFFER TOO & SMALL DURING DMUMPS_BUILD_AND_SEND_CB_ROOT" CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 500 ENDIF IF ( IERR == -3 ) THEN IF (LP > 0) WRITE(LP, *) "FAILURE, RECV BUFFER TOO & SMALL DURING DMUMPS_BUILD_AND_SEND_CB_ROOT" IFLAG = -20 IERROR = SIZE_MSG CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 500 ENDIF END IF END DO END DO 500 CONTINUE DEALLOCATE(PTRROW) DEALLOCATE(PTRCOL) DEALLOCATE(ROW_INDEX_LIST) DEALLOCATE(COL_INDEX_LIST) RETURN CONTAINS SUBROUTINE DMUMPS_SET_LDA_SHIFT_VAL_SON(IW, LIW, IOLDPS, & LDA, SHIFT_VAL_SON) INTEGER, INTENT(IN) :: LIW, IOLDPS INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT) :: LDA INTEGER(8), INTENT(OUT) :: SHIFT_VAL_SON INCLUDE 'mumps_headers.h' INTEGER :: LCONT, NROW, NPIV, NASS, NELIM LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV IF (IW(IOLDPS+XXS).EQ.S_NOLCBNOCONTIG38.OR. & IW(IOLDPS+XXS).EQ.S_ALL) THEN SHIFT_VAL_SON = int(NPIV,8) LDA = LCONT + NPIV ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCBCONTIG38) THEN SHIFT_VAL_SON = int(NROW,8)*int(LCONT+NPIV-NELIM,8) LDA = NELIM ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCLEANED38) THEN SHIFT_VAL_SON=0_8 LDA = NELIM ELSE WRITE(*,*) MYID, & ": internal error in DMUMPS_SET_LDA_SHIFT_VAL_SON", & IW(IOLDPS+XXS), "ISON=",ISON CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE DMUMPS_SET_LDA_SHIFT_VAL_SON END SUBROUTINE DMUMPS_BUILD_AND_SEND_CB_ROOT SUBROUTINE DMUMPS_ROOT_LOCAL_ASSEMBLY( N, VAL_ROOT, & LOCAL_M, LOCAL_N, & NPCOL, NPROW, MBLOCK, NBLOCK, NBCOL_SON, NBROW_SON, INDCOL_SON, & INDROW_SON, LD_SON, VAL_SON, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, NSUPROW, NSUPCOL, & RG2L, TRANSPOSE_ASM, & KEEP, RHS_ROOT, NLOC, NELIM_ROOT, NELIM_ROW, NELIM_COL ) IMPLICIT NONE INTEGER N, LOCAL_M, LOCAL_N DOUBLE PRECISION VAL_ROOT( LOCAL_M, LOCAL_N ) INTEGER NPCOL, NPROW, MBLOCK, NBLOCK INTEGER NBCOL_SON, NBROW_SON INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER LD_SON INTEGER NSUPROW, NSUPCOL DOUBLE PRECISION VAL_SON( LD_SON, NBROW_SON ) INTEGER KEEP(500) INTEGER NSUBSET_ROW, NSUBSET_COL INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER RG2L( N ) LOGICAL TRANSPOSE_ASM INTEGER NLOC DOUBLE PRECISION RHS_ROOT( LOCAL_M, NLOC) INTEGER :: NELIM_ROOT, NELIM_ROW, NELIM_COL 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 ) IF ( I .LE. NELIM_ROW ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L( IGLOB ) ENDIF 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 ) IF ( J .LE. NELIM_COL ) THEN JPOS_ROOT = NELIM_ROOT + J - 1 ELSE JPOS_ROOT = RG2L( JGLOB ) ENDIF JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO DO JSUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( JSUB ) JGLOB = INDCOL_SON( J ) JPOS_ROOT = JGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 RHS_ROOT(ILOC_ROOT, JLOC_ROOT) = & RHS_ROOT(ILOC_ROOT, JLOC_ROOT) + VAL_SON( J, I ) ENDDO END DO ELSE IF ( .NOT. TRANSPOSE_ASM ) THEN DO ISUB = 1, NSUBSET_ROW - NSUPROW I = SUBSET_ROW( ISUB ) IGLOB = INDROW_SON( I ) IF ( I .LE. NELIM_ROW ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L( IGLOB ) ENDIF 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 ) IF ( J .LE. NELIM_COL ) THEN JPOS_ROOT = NELIM_ROOT + J - 1 ELSE JPOS_ROOT = RG2L( JGLOB ) ENDIF IF (KEEP(50).NE.0. AND. JPOS_ROOT .GT. IPOS_ROOT) CYCLE JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO END DO DO JSUB = NSUBSET_COL -NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( JSUB ) JGLOB = INDROW_SON( J ) JPOS_ROOT = JGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 DO ISUB = NSUBSET_ROW - NSUPROW +1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IGLOB = INDCOL_SON( I ) IF ( I .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L(IGLOB) ENDIF 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 ) IF ( I .LE. NELIM_ROW ) THEN JPOS_ROOT = NELIM_ROOT + I - 1 ELSE JPOS_ROOT = RG2L( IGLOB ) ENDIF 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 ) IF ( J .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + J - 1 ELSE IPOS_ROOT = RG2L( JGLOB ) ENDIF 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 ) IF ( J .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + J - 1 ELSE IPOS_ROOT = RG2L( JGLOB ) ENDIF ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) = & RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO ENDDO END IF END IF RETURN END SUBROUTINE DMUMPS_ROOT_LOCAL_ASSEMBLY SUBROUTINE DMUMPS_INIT_ROOT_ANA &( MYID, NPROCS, N, root, COMM_ROOT, IROOT, FILS, & K50, K46, K51 & , K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK & ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC IMPLICIT NONE INTEGER MYID, MYID_ROOT TYPE (MUMPS_ROOT_STRUC)::root INTEGER COMM_ROOT INTEGER N, IROOT, NPROCS, K50, K46, K51 INTEGER FILS( N ) INTEGER K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK INTEGER INODE #if ! defined(NOSCALAPACK) INTEGER NPROWtemp, NPCOLtemp #endif LOGICAL SLAVE root%ROOT_SIZE = 0 root%TOT_ROOT_SIZE = 0 SLAVE = ( MYID .ne. 0 .or. & ( MYID .eq. 0 .and. K46 .eq. 1 ) ) INODE = IROOT DO WHILE ( INODE .GT. 0 ) INODE = FILS( INODE ) root%ROOT_SIZE = root%ROOT_SIZE + 1 END DO IF ( ( K60 .NE. 2 .AND. K60 .NE. 3 ) .OR. & IDNPROW .LE. 0 .OR. IDNPCOL .LE. 0 & .OR. IDMBLOCK .LE.0 .OR. IDNBLOCK.LE.0 & .OR. IDNPROW * IDNPCOL .GT. NPROCS ) THEN root%MBLOCK = K51 root%NBLOCK = K51 CALL DMUMPS_DEF_GRID( NPROCS, root%NPROW, root%NPCOL, & root%ROOT_SIZE, K50 ) IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN IDNPROW = root%NPROW IDNPCOL = root%NPCOL IDMBLOCK = root%MBLOCK IDNBLOCK = root%NBLOCK ENDIF ELSE IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN root%NPROW = IDNPROW root%NPCOL = IDNPCOL root%MBLOCK = IDMBLOCK root%NBLOCK = IDNBLOCK ENDIF IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN IF (SLAVE) THEN root%LPIV = 0 IF (K46.EQ.0) THEN MYID_ROOT=MYID-1 ELSE MYID_ROOT=MYID ENDIF IF (MYID_ROOT < root%NPROW*root%NPCOL) THEN root%MYROW = MYID_ROOT / root%NPCOL root%MYCOL = mod(MYID_ROOT, root%NPCOL) root%yes = .true. ELSE root%MYROW = -1 root%MYCOL = -1 root%yes = .FALSE. ENDIF ELSE root%yes = .FALSE. ENDIF #if ! defined(NOSCALAPACK) ELSE IF ( SLAVE ) THEN IF ( root%gridinit_done) THEN IF (root%yes) THEN CALL blacs_gridexit( root%CNTXT_BLACS ) root%gridinit_done = .FALSE. ENDIF END IF root%CNTXT_BLACS = COMM_ROOT CALL blacs_gridinit( root%CNTXT_BLACS, 'R', & root%NPROW, root%NPCOL ) root%gridinit_done = .TRUE. CALL blacs_gridinfo( root%CNTXT_BLACS, & NPROWtemp, NPCOLtemp, & root%MYROW, root%MYCOL ) IF ( root%MYROW .NE. -1 ) THEN root%yes = .true. ELSE root%yes = .false. END IF root%LPIV = 0 #endif ELSE root%yes = .FALSE. ENDIF RETURN END SUBROUTINE DMUMPS_INIT_ROOT_ANA SUBROUTINE DMUMPS_INIT_ROOT_FAC( N, MYID, root, & FILS, KEEP ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC IMPLICIT NONE TYPE ( MUMPS_ROOT_STRUC ):: root INTEGER, INTENT(IN) :: N, MYID, KEEP(500) INTEGER FILS( N ) INTEGER INODE, I LOGICAL INITIALIZE_RG2L INITIALIZE_RG2L = ( KEEP(38) .NE. 0 ) INITIALIZE_RG2L = .TRUE. IF ( INITIALIZE_RG2L ) THEN INODE = KEEP(38) I = 1 DO WHILE ( INODE .GT. 0 ) root%RG2L( INODE ) = I I = I + 1 INODE = FILS( INODE ) END DO ENDIF root%TOT_ROOT_SIZE=0 RETURN END SUBROUTINE DMUMPS_INIT_ROOT_FAC SUBROUTINE DMUMPS_DEF_GRID( NPROCS, NPROW, NPCOL, SIZE, K50 ) IMPLICIT NONE INTEGER NPROCS, NPROW, NPCOL, SIZE, K50 INTEGER NPROWtemp, NPCOLtemp, NPROCSused, FLATNESS LOGICAL KEEPIT IF ( K50 .EQ. 1 ) THEN FLATNESS = 2 ELSE FLATNESS = 3 ENDIF NPROW = int(sqrt(dble(NPROCS))) NPROWtemp = NPROW NPCOL = int(NPROCS / NPROW) NPCOLtemp = NPCOL NPROCSused = NPROWtemp * NPCOLtemp 10 CONTINUE IF ( NPROWtemp >= NPCOLtemp/FLATNESS .AND. NPROWtemp > 1) THEN NPROWtemp = NPROWtemp - 1 NPCOLtemp = int(NPROCS / NPROWtemp) KEEPIT=.FALSE. IF ( NPROWtemp * NPCOLtemp .GE. NPROCSused ) THEN IF ( ( K50 .NE. 1 .AND. NPROWtemp >= NPCOLtemp/FLATNESS) & .OR. NPROWtemp * NPCOLtemp .GT. NPROCSused ) & KEEPIT=.TRUE. END IF IF ( KEEPIT ) THEN NPROW = NPROWtemp NPCOL = NPCOLtemp NPROCSused = NPROW * NPCOL END IF GO TO 10 END IF RETURN END SUBROUTINE DMUMPS_DEF_GRID SUBROUTINE DMUMPS_SCATTER_ROOT(MYID, M, N, ASEQ, & LOCAL_M, LOCAL_N, & MBLOCK, NBLOCK, & APAR, & MASTER_ROOT, & NPROW, NPCOL, & COMM) IMPLICIT NONE INTEGER MYID, MASTER_ROOT, COMM INTEGER M, N INTEGER NPROW, NPCOL INTEGER LOCAL_M, LOCAL_N INTEGER MBLOCK, NBLOCK DOUBLE PRECISION APAR( LOCAL_M, LOCAL_N ) DOUBLE PRECISION ASEQ( M, N ) INCLUDE 'mpif.h' INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, IDEST, IROW, ICOL INTEGER IBLOCK, JBLOCK, II, JJ, KK INTEGER IAPAR, JAPAR, IERR, allocok INTEGER :: STATUS(MPI_STATUS_SIZE) DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: WK LOGICAL JUPDATE ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of WK in ' & // 'routine DMUMPS_SCATTER_ROOT ' CALL MUMPS_ABORT() endif IAPAR = 1 JAPAR = 1 DO J = 1, N, NBLOCK SIZE_JBLOCK = NBLOCK IF ( J + NBLOCK > N ) THEN SIZE_JBLOCK = N - J + 1 END IF JUPDATE = .FALSE. DO I = 1, M, MBLOCK SIZE_IBLOCK = MBLOCK IF ( I + MBLOCK > M ) THEN SIZE_IBLOCK = M - I + 1 END IF IBLOCK = I / MBLOCK JBLOCK = J / NBLOCK IROW = mod ( IBLOCK, NPROW ) ICOL = mod ( JBLOCK, NPCOL ) IDEST = IROW * NPCOL + ICOL IF ( IDEST .NE. MASTER_ROOT ) THEN IF ( MYID .EQ. MASTER_ROOT ) THEN KK=1 DO JJ=J,J+SIZE_JBLOCK-1 DO II=I,I+SIZE_IBLOCK-1 WK(KK)=ASEQ(II,JJ) KK=KK+1 END DO END DO CALL MPI_SEND( WK, SIZE_IBLOCK*SIZE_JBLOCK, & MPI_DOUBLE_PRECISION, & IDEST, 128, COMM, IERR ) ELSE IF ( MYID .EQ. IDEST ) THEN CALL MPI_RECV( WK(1), & SIZE_IBLOCK*SIZE_JBLOCK, & MPI_DOUBLE_PRECISION, & MASTER_ROOT,128,COMM,STATUS,IERR) KK=1 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 APAR(II,JJ)=WK(KK) KK=KK+1 END DO END DO JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, & JAPAR:JAPAR+SIZE_JBLOCK-1 ) & = ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF END DO IF ( JUPDATE ) THEN IAPAR = 1 JAPAR = JAPAR + SIZE_JBLOCK END IF END DO DEALLOCATE(WK) RETURN END SUBROUTINE DMUMPS_SCATTER_ROOT SUBROUTINE DMUMPS_GATHER_ROOT(MYID, M, N, ASEQ, & LOCAL_M, LOCAL_N, & MBLOCK, NBLOCK, & APAR, & MASTER_ROOT, & NPROW, NPCOL, & COMM) IMPLICIT NONE INTEGER MYID, MASTER_ROOT, COMM INTEGER M, N INTEGER NPROW, NPCOL INTEGER LOCAL_M, LOCAL_N INTEGER MBLOCK, NBLOCK DOUBLE PRECISION APAR( LOCAL_M, LOCAL_N ) DOUBLE PRECISION ASEQ( M, N ) INCLUDE 'mpif.h' INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, ISOUR, IROW, ICOL INTEGER IBLOCK, JBLOCK, II, JJ, KK INTEGER IAPAR, JAPAR, IERR, allocok INTEGER :: STATUS(MPI_STATUS_SIZE) DOUBLE PRECISION,DIMENSION(:), ALLOCATABLE :: WK LOGICAL JUPDATE ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of WK in ' & // 'routine DMUMPS_GATHER_ROOT ' CALL MUMPS_ABORT() endif IAPAR = 1 JAPAR = 1 DO J = 1, N, NBLOCK SIZE_JBLOCK = NBLOCK IF ( J + NBLOCK > N ) THEN SIZE_JBLOCK = N - J + 1 END IF JUPDATE = .FALSE. DO I = 1, M, MBLOCK SIZE_IBLOCK = MBLOCK IF ( I + MBLOCK > M ) THEN SIZE_IBLOCK = M - I + 1 END IF IBLOCK = I / MBLOCK JBLOCK = J / NBLOCK IROW = mod ( IBLOCK, NPROW ) ICOL = mod ( JBLOCK, NPCOL ) ISOUR = IROW * NPCOL + ICOL IF ( ISOUR .NE. MASTER_ROOT ) THEN IF ( MYID .EQ. MASTER_ROOT ) THEN CALL MPI_RECV( WK(1), SIZE_IBLOCK*SIZE_JBLOCK, & MPI_DOUBLE_PRECISION, & ISOUR, 128, COMM, STATUS, IERR ) KK=1 DO JJ=J,J+SIZE_JBLOCK-1 DO II=I,I+SIZE_IBLOCK-1 ASEQ(II,JJ)=WK(KK) KK=KK+1 END DO END DO ELSE IF ( MYID .EQ. ISOUR ) THEN KK=1 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 WK(KK)=APAR(II,JJ) KK=KK+1 END DO END DO CALL MPI_SEND( WK( 1 ), & SIZE_IBLOCK*SIZE_JBLOCK, & MPI_DOUBLE_PRECISION, & MASTER_ROOT,128,COMM,IERR) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) & = APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, & JAPAR:JAPAR+SIZE_JBLOCK-1 ) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF END DO IF ( JUPDATE ) THEN IAPAR = 1 JAPAR = JAPAR + SIZE_JBLOCK END IF END DO DEALLOCATE(WK) RETURN END SUBROUTINE DMUMPS_GATHER_ROOT SUBROUTINE DMUMPS_ROOT_ALLOC_STATIC(root, roota, IROOT, N, & IW, LIW, A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) TYPE (MUMPS_ROOT_STRUC ) :: root TYPE (DMUMPS_ROOT_STRUC ) :: roota INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER IROOT, LIW, N, IWPOS, IWPOSCB INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER ITLOC( N + KEEP(253) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER COMP, IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER FILS( N ), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER INTARR(KEEP8(27)) DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER, EXTERNAL :: MUMPS_NUMROC DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER(8) :: LREQA_ROOT INTEGER LREQI_ROOT, LOCAL_M, LOCAL_N, allocok LOGICAL :: EARLYT3ROOTINS LOCAL_M = MUMPS_NUMROC( root%ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) LOCAL_M = max( 1, LOCAL_M ) LOCAL_N = MUMPS_NUMROC( root%ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) IF (KEEP(253).GT.0) THEN root%RHS_NLOC = MUMPS_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( roota%RHS_ROOT) ) & DEALLOCATE (roota%RHS_ROOT) ALLOCATE(roota%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 roota%RHS_ROOT = ZERO CALL DMUMPS_ASM_RHS_ROOT ( N, FILS, & root, roota, KEEP, KEEP8, RHS_MUMPS, & IFLAG, IERROR ) IF ( IFLAG .LT. 0 ) RETURN ENDIF IF (KEEP(60) .NE. 0) THEN PTRIST(STEP(IROOT)) = -6666666 ELSE LREQI_ROOT = 2 + KEEP(IXSZ) LREQA_ROOT = int(LOCAL_M,8) * int(LOCAL_N,8) IF (LREQA_ROOT.EQ.0_8) THEN PTRIST(STEP(IROOT)) = -9999999 RETURN ENDIF CALL DMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LREQI_ROOT, & LREQA_ROOT, IROOT, S_NOTFREE, .TRUE., COMP, & LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PTRIST ( STEP(IROOT) ) = IWPOSCB + 1 PAMASTER( STEP(IROOT) ) = IPTRLU + 1_8 IW( IWPOSCB + 1 + KEEP(IXSZ)) = - LOCAL_N IW( IWPOSCB + 2 + KEEP(IXSZ)) = LOCAL_M ENDIF EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) IF (LOCAL_N > 0 .AND. .NOT. EARLYT3ROOTINS ) THEN IF (KEEP(60) .EQ. 0) THEN CALL DMUMPS_SET_TO_ZERO(A(IPTRLU+1_8), LOCAL_M, & LOCAL_M, LOCAL_N, KEEP) ELSE CALL DMUMPS_SET_TO_ZERO(roota%SCHUR_POINTER(1), & root%SCHUR_LLD, LOCAL_M, LOCAL_N, KEEP) ENDIF IF (KEEP(55) .eq. 0) THEN IF (KEEP(60) .EQ. 0) THEN CALL DMUMPS_ASM_ARR_ROOT( N, root, roota, & IROOT, STEP(IROOT), & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N, & FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL DMUMPS_ASM_ARR_ROOT( N, root, roota, & IROOT, STEP(IROOT), & roota%SCHUR_POINTER(1), root%SCHUR_LLD, & LOCAL_M, LOCAL_N, & FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ENDIF ELSE IF (KEEP(60) .EQ. 0) THEN CALL DMUMPS_ASM_ELT_ROOT( N, root, roota, & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ELSE CALL DMUMPS_ASM_ELT_ROOT( N, root, roota, & roota%SCHUR_POINTER(1), root%SCHUR_LLD, & root%SCHUR_MLOC, root%SCHUR_NLOC, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_ROOT_ALLOC_STATIC SUBROUTINE DMUMPS_ASM_ELT_ROOT( N, root, roota, & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & INTARR, DBLARR, LINTARR, LDBLARR, & KEEP, KEEP8, & MYID) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER :: N, MYID, LOCAL_M, LOCAL_N, KEEP(500) INTEGER :: LOCAL_M_LLD INTEGER(8) KEEP8(150) DOUBLE PRECISION VALROOT(LOCAL_M_LLD,LOCAL_N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER, INTENT(INOUT) :: INTARR(LINTARR) DOUBLE PRECISION DBLARR(LDBLARR) INTEGER(8) :: J1, J2, K8, IPTR INTEGER :: IELT, I, J, IGLOB, SIZEI, IBEG INTEGER :: ARROW_ROOT INTEGER :: IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INTEGER :: ILOCROOT, JLOCROOT ARROW_ROOT = 0 DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1 IELT = FRTELT( IPTR ) J1 = PTRAIW(IELT) J2 = PTRAIW(IELT+1)-1 K8 = PTRARW(IELT) SIZEI=int(J2-J1)+1 DO J=1, SIZEI IGLOB = INTARR(J1+J-1) INTARR(J1+J-1) = root%RG2L(IGLOB) ENDDO DO J = 1, SIZEI IGLOB = INTARR(J1+J-1) IF ( KEEP(50).eq. 0 ) THEN IBEG = 1 ELSE IBEG = J END IF DO I = IBEG, SIZEI IF ( KEEP(50).eq.0 ) THEN IPOSROOT = INTARR(J1+I-1) JPOSROOT = INTARR(J1+J-1) ELSE IF ( INTARR(J1+I-1).GT. INTARR(J1+J-1) ) THEN IPOSROOT = INTARR(J1+I-1) JPOSROOT = INTARR(J1+J-1) ELSE IPOSROOT = INTARR(J1+J-1) JPOSROOT = INTARR(J1+I-1) END IF END IF IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, & root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, & root%NPCOL ) IF ( IROW_GRID.EQ.root%MYROW .AND. & JCOL_GRID.EQ.root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + DBLARR(K8) ENDIF K8 = K8 + 1_8 END DO END DO ARROW_ROOT = ARROW_ROOT + int(PTRARW(IELT+1_8)-PTRARW(IELT)) END DO KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE DMUMPS_ASM_ELT_ROOT SUBROUTINE DMUMPS_ASM_RHS_ROOT & ( N, FILS, root, roota, KEEP, KEEP8, RHS_MUMPS, & IFLAG, IERROR ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, KEEP(500), IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER FILS(N) TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) 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( 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 roota%RHS_ROOT(ILOCRHS, JLOCRHS) = & RHS_MUMPS(INODE+(JCOL-1)*KEEP(254)) ENDDO 100 CONTINUE INODE=FILS(INODE) ENDDO RETURN END SUBROUTINE DMUMPS_ASM_RHS_ROOT SUBROUTINE DMUMPS_ASM_ARR_ROOT( N, root, roota, IROOT, STEP_IROOT, & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, LINTARR, LDBLARR, & MYID) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER :: N, MYID, IROOT, STEP_IROOT, LOCAL_M, LOCAL_N INTEGER :: LOCAL_M_LLD INTEGER FILS( N ) INTEGER :: KEEP(500) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) DOUBLE PRECISION VALROOT(LOCAL_M_LLD,LOCAL_N) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER INTARR(LINTARR) DOUBLE PRECISION DBLARR(LDBLARR) DOUBLE PRECISION VAL INTEGER(8) :: JJ, J1,J2,J3, J4, AINPUT INTEGER IORG, NUMORG, & IROW, JCOL, IARR1 INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INTEGER ILOCROOT, JLOCROOT NUMORG = root%ROOT_SIZE IARR1=PTRDEBARR(STEP_IROOT) DO IORG = 1, NUMORG AINPUT = PTR8ARR(IARR1+IORG-1) J1 = AINPUT J2 = J1 + NINCOLARR(IARR1+IORG-1) J3 = J2 + 1 J4 = J2 + NINROWARR(IARR1+IORG-1) JCOL = INTARR(J1) DO JJ = J1, J2 IROW = INTARR(JJ) VAL = DBLARR(AINPUT) AINPUT = AINPUT + 1 IPOSROOT = root%RG2L( IROW ) JPOSROOT = root%RG2L( JCOL ) IROW_GRID = mod( ( IPOSROOT - 1 ) / root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 ) / root%NBLOCK, root%NPCOL ) IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + VAL END IF END DO IF (J3 .LE. J4) THEN IROW = INTARR(J1) DO JJ= J3,J4 JCOL = INTARR(JJ) VAL = DBLARR(AINPUT) AINPUT = AINPUT + 1 IPOSROOT = root%RG2L( IROW ) JPOSROOT = root%RG2L( JCOL ) IROW_GRID= mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW) JCOL_GRID= mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL) IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + VAL END IF END DO ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_ASM_ARR_ROOT MUMPS_5.8.1/src/cfac_process_master2.F0000664000175000017500000001627615042446440017442 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, SLAVEF, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, KEEP, KEEP8, DKEEP, & ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE MUMPS_LOAD USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER SLAVEF INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ), ITLOC( N +KEEP(253) ) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ) INTEGER IFLAG, IERROR, COMM, COMM_LOAD INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER ND(KEEP(28)), FILS( N ), DAD(KEEP(28)), FRERE(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSITION, IFATH, ISON, NROW, NCOL, NELIM, & NSLAVES INTEGER(8) :: NOREAL INTEGER NOINT, INIV2, NCOL_EFF DOUBLE PRECISION FLOP1 INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER NOREAL_PACKET LOGICAL PERETYPE2 INCLUDE 'mumps_headers.h' COMPLEX, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYN_SIZE INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IFATH, 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & ISON , 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NROW , 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NCOL , 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, & MPI_INTEGER, COMM, IERR) IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN NCOL_EFF = NROW ELSE NCOL_EFF = NCOL ENDIF NOREAL_PACKET = NBROWS_PACKET * NCOL_EFF IF (NBROWS_ALREADY_SENT .EQ. 0) THEN NOINT = 6 + NROW + NCOL + NSLAVES + KEEP(IXSZ) NOREAL= int(NROW,8) * int(NCOL_EFF,8) CALL CMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, ISON, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) THEN RETURN ENDIF PIMASTER(STEP( ISON )) = IWPOSCB + 1 PAMASTER(STEP( ISON )) = IPTRLU + 1_8 IW( IWPOSCB + 1 + XXNBPR ) = 0 IW( IWPOSCB + 1 + KEEP(IXSZ) ) = NCOL NELIM = NROW IW( IWPOSCB + 2 + KEEP(IXSZ) ) = NELIM IW( IWPOSCB + 3 + KEEP(IXSZ) ) = NROW IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN IW( IWPOSCB + 4 + KEEP(IXSZ) ) = NROW - NCOL IF ( NROW - NCOL .GE. 0 ) THEN WRITE(*,*) 'Error in PROCESS_MAITRE2:',NROW,NCOL CALL MUMPS_ABORT() END IF ELSE IW( IWPOSCB + 4 + KEEP(IXSZ) ) = 0 END IF IW( IWPOSCB + 5 + KEEP(IXSZ) ) = 1 IW( IWPOSCB + 6 + KEEP(IXSZ) ) = NSLAVES IF (NSLAVES.GT.0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 7 + KEEP(IXSZ) ), & NSLAVES, MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 7 + KEEP(IXSZ) + NSLAVES), & NROW, MPI_INTEGER, COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 7 + KEEP(IXSZ) + NROW + NSLAVES), & NCOL, MPI_INTEGER, COMM, IERR) IF ( NSLAVES .GT. 0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(ISON) ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES+1, MPI_INTEGER, COMM, IERR) TAB_POS_IN_PERE(SLAVEF+2,INIV2) = NSLAVES ENDIF ENDIF IF (NOREAL_PACKET.GT.0) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(PIMASTER(STEP(ISON))+XXD)) IF ( DYN_SIZE .GT. 0_8 ) THEN CALL CMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), & DYN_SIZE, SON_A ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SON_A( 1_8 + & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8) ), & NOREAL_PACKET, MPI_COMPLEX, COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( PAMASTER(STEP(ISON)) + & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8) ), & NOREAL_PACKET, MPI_COMPLEX, COMM, IERR ) ENDIF ENDIF IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NROW ) THEN PERETYPE2 = ( MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)), & KEEP(199)) .EQ. 2 ) NSTK_S( STEP(IFATH )) = NSTK_S( STEP(IFATH) ) - 1 IF ( NSTK_S( STEP(IFATH)) .EQ. 0 ) THEN CALL CMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IFATH ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( IFATH, N, PROCNODE_STEPS, & KEEP(199), ND, & FILS,FRERE, STEP, PIMASTER, & KEEP(28), KEEP(50), KEEP(253), & FLOP1,IW, LIW, KEEP(IXSZ) ) IF (IFATH.NE.KEEP(20)) & CALL MUMPS_LOAD_UPDATE(1, .FALSE., FLOP1, KEEP,KEEP8) END IF ENDIF RETURN END SUBROUTINE CMUMPS_PROCESS_MASTER2 MUMPS_5.8.1/src/sfac_mem_free_block_cb.F0000664000175000017500000000562215042446437017743 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, IPOSBLOCK, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP, KEEP8, IN_PLACE_STATS & ) !$ USE OMP_LIB USE MUMPS_LOAD IMPLICIT NONE INTEGER IPOSBLOCK, & LIW, IWPOSCB, N INTEGER(8) :: LA, LRLU, LRLUS, IPTRLU LOGICAL IN_PLACE_STATS INTEGER IW( LIW ), KEEP(500) INTEGER(8) KEEP8(150) INTEGER MYID LOGICAL SSARBR INTEGER SIZFI_BLOCK, SIZFI INTEGER(8) :: SIZFR, SIZFR_BLOCK, SIZFR_BLOCK_EFF, & SIZEHOLE, MEM_INC, DYNSIZE_BLOCK INCLUDE 'mumps_headers.h' SIZFI_BLOCK=IW(IPOSBLOCK+XXI) CALL MUMPS_GETI8( SIZFR_BLOCK, IW(IPOSBLOCK+XXR) ) CALL MUMPS_GETI8( DYNSIZE_BLOCK,IW(IPOSBLOCK+XXD) ) IF (DYNSIZE_BLOCK .GT. 0_8) THEN SIZFR_BLOCK_EFF = 0_8 ELSE IF (KEEP(216).eq.3 & ) THEN SIZFR_BLOCK_EFF = SIZFR_BLOCK ELSE CALL SMUMPS_SIZEFREEINREC( IW(IPOSBLOCK), & LIW-IPOSBLOCK+1, & SIZEHOLE, KEEP(IXSZ)) SIZFR_BLOCK_EFF = SIZFR_BLOCK - SIZEHOLE ENDIF IF (.NOT. IN_PLACE_STATS) THEN LRLUS = LRLUS + SIZFR_BLOCK_EFF IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) - SIZFR_BLOCK_EFF ELSE !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - SIZFR_BLOCK_EFF !$OMP END ATOMIC ENDIF ENDIF IF ( IPOSBLOCK .eq. IWPOSCB + 1 ) THEN IPTRLU = IPTRLU + SIZFR_BLOCK IWPOSCB = IWPOSCB + SIZFI_BLOCK LRLU = LRLU + SIZFR_BLOCK MEM_INC = -SIZFR_BLOCK_EFF IF (IN_PLACE_STATS) THEN MEM_INC= 0_8 ENDIF CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,MEM_INC,KEEP,KEEP8,LRLUS) 90 IF ( IWPOSCB .eq. LIW ) GO TO 100 SIZFI = IW( IWPOSCB+1+XXI ) CALL MUMPS_GETI8( SIZFR, IW(IWPOSCB+1+XXR) ) IF ( IW( IWPOSCB+1+XXS ) .EQ. S_FREE ) THEN IPTRLU = IPTRLU + SIZFR LRLU = LRLU + SIZFR IWPOSCB = IWPOSCB + SIZFI GO TO 90 ENDIF 100 CONTINUE IW( IWPOSCB+1+XXP)=TOP_OF_STACK ELSE IW( IPOSBLOCK +XXS)=S_FREE CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,-SIZFR_BLOCK_EFF,KEEP,KEEP8,LRLUS) END IF RETURN END SUBROUTINE SMUMPS_FREE_BLOCK_CB_STATIC MUMPS_5.8.1/src/cmumps_gpu.c0000664000175000017500000000117315042446422015555 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include #include #include #include "cmumps_gpu.h" void MUMPS_CALL cmumps_gpu_return() { /* GPU feature will be available in the future */ } MUMPS_5.8.1/src/smumps_ooc.F0000664000175000017500000036264215042446437015546 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_OOC USE MUMPS_OOC_COMMON !$ USE OMP_LIB, ONLY : OMP_LOCK_KIND, OMP_SET_LOCK, OMP_UNSET_LOCK, !$ & OMP_INIT_LOCK, OMP_DESTROY_LOCK, OMP_TEST_LOCK IMPLICIT NONE !$ INTEGER(KIND=OMP_LOCK_KIND) :: LOCK_FOR_L0OMP INTEGER NOT_IN_MEM,BEING_READ,NOT_USED,PERMUTED,USED, & USED_NOT_PERMUTED,ALREADY_USED PARAMETER (NOT_IN_MEM=0,BEING_READ=-1,NOT_USED=-2, & PERMUTED=-3,USED=-4,USED_NOT_PERMUTED=-5,ALREADY_USED=-6) INTEGER OOC_NODE_NOT_IN_MEM,OOC_NODE_PERMUTED, & OOC_NODE_NOT_PERMUTED PARAMETER (OOC_NODE_NOT_IN_MEM=-20, & OOC_NODE_PERMUTED=-21,OOC_NODE_NOT_PERMUTED=-22) INTEGER(8), DIMENSION(:,:),POINTER :: SIZE_OF_BLOCK INTEGER, DIMENSION(:),POINTER :: TOTAL_NB_OOC_NODES INTEGER :: OOC_SOLVE_TYPE_FCT INTEGER, DIMENSION(:),ALLOCATABLE :: IO_REQ INTEGER(8), DIMENSION(:), ALLOCATABLE:: LRLUS_SOLVE INTEGER(8), DIMENSION(:), ALLOCATABLE:: SIZE_SOLVE_Z, & LRLU_SOLVE_T, POSFAC_SOLVE, IDEB_SOLVE_Z, LRLU_SOLVE_B INTEGER, DIMENSION(:),ALLOCATABLE :: PDEB_SOLVE_Z INTEGER (8),SAVE :: FACT_AREA_SIZE, & SIZE_ZONE_SOLVE,SIZE_SOLVE_EMM,TMP_SIZE_FACT, & MAX_SIZE_FACTOR_OOC INTEGER(8), SAVE :: MIN_SIZE_READ INTEGER, SAVE :: TMP_NB_NODES, MAX_NB_NODES_FOR_ZONE,MAX_NB_REQ, & CURRENT_SOLVE_READ_ZONE, & CUR_POS_SEQUENCE,NB_Z,SOLVE_STEP, & NB_ZONE_REQ,MTYPE_OOC,NB_ACT & ,NB_CALLED,REQ_ACT,NB_CALL INTEGER(8), SAVE :: OOC_VADDR_PTR INTEGER(8), SAVE :: SIZE_ZONE_REQ INTEGER(8), DIMENSION(:), ALLOCATABLE :: SIZE_OF_READ, READ_DEST INTEGER,DIMENSION(:),ALLOCATABLE :: FIRST_POS_IN_READ, & READ_MNG,REQ_TO_ZONE,POS_HOLE_T, & POS_HOLE_B,REQ_ID,OOC_STATE_NODE INTEGER SMUMPS_ELEMENTARY_DATA_SIZE,N_OOC INTEGER, DIMENSION(:), ALLOCATABLE :: POS_IN_MEM, INODE_TO_POS INTEGER, DIMENSION(:), ALLOCATABLE :: CURRENT_POS_T,CURRENT_POS_B LOGICAL IS_ROOT_SPECIAL INTEGER SPECIAL_ROOT_NODE PUBLIC :: SMUMPS_OOC_INIT_FACTO,SMUMPS_NEW_FACTOR, & SMUMPS_READ_OOC, & SMUMPS_SOLVE_ALLOC_FACTOR_SPACE, & SMUMPS_IS_THERE_FREE_SPACE, & SMUMPS_OOC_END_SOLVE, & SMUMPS_SOLVE_INIT_OOC_FWD,SMUMPS_SOLVE_INIT_OOC_BWD, & SMUMPS_INITIATE_READ_OPS,SMUMPS_OOC_INIT_SOLVE INTEGER, PARAMETER, PUBLIC :: TYPEF_BOTH_LU = -99976 PUBLIC SMUMPS_OOC_IO_LU_PANEL, & SMUMPS_OOC_PANEL_SIZE PRIVATE SMUMPS_OOC_STORE_LorU, & SMUMPS_OOC_WRT_IN_PANELS_LorU CONTAINS SUBROUTINE SMUMPS_SET_STRAT_IO_FLAGS( STRAT_IO_ARG, & STRAT_IO_ASYNC_ARG, WITH_BUF_ARG, LOW_LEVEL_STRAT_IO_ARG ) IMPLICIT NONE INTEGER, intent(out) :: LOW_LEVEL_STRAT_IO_ARG LOGICAL, intent(out) :: STRAT_IO_ASYNC_ARG, WITH_BUF_ARG INTEGER, intent(in) :: STRAT_IO_ARG INTEGER TMP CALL MUMPS_OOC_IS_ASYNC_AVAIL(TMP) STRAT_IO_ASYNC_ARG=.FALSE. WITH_BUF_ARG=.FALSE. IF(TMP.EQ.1)THEN IF((STRAT_IO_ARG.EQ.1).OR.(STRAT_IO_ARG.EQ.2))THEN STRAT_IO_ASYNC=.TRUE. WITH_BUF=.FALSE. ELSEIF((STRAT_IO_ARG.EQ.4).OR.(STRAT_IO_ARG.EQ.5))THEN STRAT_IO_ASYNC_ARG=.TRUE. WITH_BUF_ARG=.TRUE. ELSEIF(STRAT_IO_ARG.EQ.3)THEN STRAT_IO_ASYNC_ARG=.FALSE. WITH_BUF_ARG=.TRUE. ENDIF LOW_LEVEL_STRAT_IO_ARG=mod(STRAT_IO_ARG,3) ELSE LOW_LEVEL_STRAT_IO_ARG=0 IF(STRAT_IO_ARG.GE.3)THEN WITH_BUF_ARG=.TRUE. ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SET_STRAT_IO_FLAGS FUNCTION SMUMPS_IS_THERE_FREE_SPACE(INODE,ZONE) IMPLICIT NONE INTEGER INODE,ZONE LOGICAL SMUMPS_IS_THERE_FREE_SPACE SMUMPS_IS_THERE_FREE_SPACE=(LRLUS_SOLVE(ZONE).GE. & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) RETURN END FUNCTION SMUMPS_IS_THERE_FREE_SPACE SUBROUTINE SMUMPS_INIT_FACT_AREA_SIZE_S(LA) IMPLICIT NONE INTEGER(8) :: LA FACT_AREA_SIZE=LA END SUBROUTINE SMUMPS_INIT_FACT_AREA_SIZE_S SUBROUTINE SMUMPS_OOC_INIT_FACTO(idICNTL1, idICNTL4, & idN, idNSLAVES, & idMYID, MAXS, idOOC_NB_FILE_TYPE, & idKEEP, idKEEP8, idSTEP, idPROCNODE_STEPS, & idOOC_SIZE_OF_BLOCK, & idOOC_VADDR, idINFO, idOOC_TMPDIR, idOOC_PREFIX, & idOOC_NB_FILES, idOOC_INODE_SEQUENCE) & USE SMUMPS_STRUC_DEF USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER :: idICNTL1, idICNTL4, idN, idNSLAVES, idMYID INTEGER :: idOOC_NB_FILE_TYPE INTEGER, TARGET :: idKEEP(500) INTEGER :: idINFO(2) INTEGER(8), TARGET :: idKEEP8(150) INTEGER, POINTER, DIMENSION(:) :: idSTEP, idPROCNODE_STEPS INTEGER(8),DIMENSION(:,:), POINTER :: idOOC_SIZE_OF_BLOCK INTEGER(8), DIMENSION(:,:), POINTER :: idOOC_VADDR INTEGER(8), INTENT(IN) :: MAXS INTEGER OOC_TMPDIR_MAX_LENGTH, OOC_PREFIX_MAX_LENGTH PARAMETER (OOC_TMPDIR_MAX_LENGTH=1023, OOC_PREFIX_MAX_LENGTH=255) CHARACTER(LEN=OOC_TMPDIR_MAX_LENGTH) :: idOOC_TMPDIR CHARACTER(LEN=OOC_PREFIX_MAX_LENGTH) :: idOOC_PREFIX INTEGER, DIMENSION(:), POINTER :: idOOC_NB_FILES INTEGER, DIMENSION(:,:), POINTER :: idOOC_INODE_SEQUENCE INTEGER IERR INTEGER allocok INTEGER DIM_TMPDIR,DIM_PREFIX INTEGER, DIMENSION(:), ALLOCATABLE :: FILE_FLAG_TAB INTEGER TMP INTEGER KEEP211_LOC ICNTL1 = idICNTL1 IF (idICNTL4 .LT. 1) idICNTL1=0 MAX_SIZE_FACTOR_OOC=0_8 N_OOC=idN SOLVE=.FALSE. IERR=0 IF (idKEEP(400).GT.0) THEN !$ CALL OMP_INIT_LOCK( LOCK_FOR_L0OMP ) 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(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_VADDR))THEN NULLIFY(OOC_VADDR) ENDIF IF(allocated(I_CUR_HBUF_NEXTPOS))THEN DEALLOCATE(I_CUR_HBUF_NEXTPOS) ENDIF OOC_NB_FILE_TYPE=idOOC_NB_FILE_TYPE IF(IERR.LT.0)THEN IF (ICNTL1 > 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) idINFO(1) = IERR idINFO(2) = 0 RETURN ENDIF CALL MUMPS_OOC_INIT_FILETYPE(TYPEF_L, TYPEF_U, TYPEF_CB, & idKEEP(201), idKEEP(251), idKEEP(50), TYPEF_INVALID ) IF (idKEEP(201).EQ.2) THEN OOC_FCT_TYPE=1 ENDIF STEP_OOC=>idSTEP PROCNODE_OOC=>idPROCNODE_STEPS MYID_OOC=idMYID SLAVEF_OOC=idNSLAVES KEEP_OOC => idKEEP SIZE_OF_BLOCK=>idOOC_SIZE_OF_BLOCK OOC_VADDR=>idOOC_VADDR IF(idKEEP(107).GT.0)THEN SIZE_SOLVE_EMM=max(idKEEP8(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(idKEEP(107)),8)) IF(SIZE_ZONE_SOLVE.EQ.SIZE_SOLVE_EMM)THEN SIZE_SOLVE_EMM=idKEEP8(19) SIZE_ZONE_SOLVE=int((dble(MAXS)*0.9d0- & dble(SIZE_SOLVE_EMM))/dble(idKEEP(107)),8) ENDIF ELSE SIZE_ZONE_SOLVE=int(dble(MAXS)*0.9d0,8) SIZE_SOLVE_EMM=SIZE_ZONE_SOLVE ENDIF SMUMPS_ELEMENTARY_DATA_SIZE = idKEEP(35) SIZE_OF_BLOCK=0_8 ALLOCATE(idOOC_NB_FILES(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF idINFO(1) = -13 idINFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF idOOC_NB_FILES=0 OOC_VADDR_PTR=0_8 CALL SMUMPS_SET_STRAT_IO_FLAGS( idKEEP(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=>idOOC_INODE_SEQUENCE ALLOCATE(I_CUR_HBUF_NEXTPOS(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF idINFO(1) = -13 idINFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF I_CUR_HBUF_NEXTPOS = 1 IF(WITH_BUF)THEN CALL SMUMPS_INIT_OOC_BUF(idINFO(1),idINFO(2),IERR) IF(IERR.LT.0)THEN RETURN ENDIF 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_TMPDIR=len(trim(idOOC_TMPDIR)) DIM_PREFIX=len(trim(idOOC_PREFIX)) CALL MUMPS_LOW_LEVEL_INIT_PREFIX(DIM_PREFIX, idOOC_PREFIX) CALL MUMPS_LOW_LEVEL_INIT_TMPDIR(DIM_TMPDIR, idOOC_TMPDIR) ALLOCATE(FILE_FLAG_TAB(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1 .GT. 0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF idINFO(1) = -13 idINFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF FILE_FLAG_TAB(1:OOC_NB_FILE_TYPE)=0 IERR=0 TMP=int(idKEEP8(11)/1000000_8)+1 IF((idKEEP(201).EQ.1).AND.(idKEEP(50).EQ.0) & ) THEN TMP=max(1,TMP/2) ENDIF CALL MUMPS_LOW_LEVEL_INIT_OOC_C(MYID_OOC,TMP, & idKEEP(35),LOW_LEVEL_STRAT_IO,KEEP211_LOC,OOC_NB_FILE_TYPE, & FILE_FLAG_TAB,idKEEP(255),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 idINFO(1) = IERR idINFO(2) = 0 RETURN ENDIF DEALLOCATE(FILE_FLAG_TAB) RETURN END SUBROUTINE SMUMPS_OOC_INIT_FACTO SUBROUTINE SMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZE,IERR) USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) :: LA INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)), SIZE REAL A(LA) INTEGER IERR,REQUEST INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=FCT IERR=0 SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)=SIZE MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,SIZE) OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)=OOC_VADDR_PTR OOC_VADDR_PTR=OOC_VADDR_PTR+SIZE TMP_SIZE_FACT=TMP_SIZE_FACT+SIZE TMP_NB_NODES=TMP_NB_NODES+1 IF(TMP_SIZE_FACT.GT.SIZE_ZONE_SOLVE)THEN MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE,TMP_NB_NODES) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 ENDIF IF (.NOT. WITH_BUF) THEN CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & A(PTRFAC(STEP_OOC(INODE))),SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE).GT.KEEP_OOC(28))THEN WRITE(*,*)MYID_OOC,': Internal error (37) in OOC ' CALL MUMPS_ABORT() ENDIF OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE)=INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)= & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)+1 ELSE IF(SIZE.LE.HBUF_SIZE)THEN CALL SMUMPS_OOC_COPY_DATA_TO_BUFFER & (A(PTRFAC(STEP_OOC(INODE))),SIZE,IERR) OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE) = INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE) = & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE) + 1 PTRFAC(STEP_OOC(INODE))=-777777_8 RETURN ELSE CALL SMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL SMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & A(PTRFAC(STEP_OOC(INODE))),SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(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 (38) in OOC ' CALL MUMPS_ABORT() ENDIF OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE)=INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)= & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)+1 CALL SMUMPS_OOC_NEXT_HBUF(OOC_FCT_TYPE) ENDIF END IF PTRFAC(STEP_OOC(INODE))=-777777_8 IF(STRAT_IO_ASYNC)THEN IERR=0 CALL MUMPS_WAIT_REQUEST(REQUEST,IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_NEW_FACTOR SUBROUTINE SMUMPS_READ_OOC(DEST,INODE,IERR & ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR,INODE REAL DEST INTEGER 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 IERR=0 OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_LOW_LEVEL_DIRECT_READ(DEST, & SIZE_INT1,SIZE_INT2, & TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) WRITE(ICNTL1,*)MYID_OOC, & ': Problem in MUMPS_LOW_LEVEL_DIRECT_READ' ENDIF RETURN ENDIF 555 CONTINUE IF(.NOT.SMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE).EQ. & INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL SMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_READ_OOC SUBROUTINE SMUMPS_OOC_CLEAN_PENDING(IERR) USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out):: IERR IERR=0 IF (WITH_BUF) THEN CALL SMUMPS_OOC_BUF_CLEAN_PENDING(IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF RETURN END SUBROUTINE SMUMPS_OOC_CLEAN_PENDING SUBROUTINE SMUMPS_OOC_END_FACTO(idKEEP,idKEEP8, & idOOC_MAX_NB_NODES_FOR_ZONE, & idOOC_TOTAL_NB_NODES, & idOOC_FILE_NAMES,idINFO, & idOOC_FILE_NAME_LENGTH, & idOOC_NB_FILES, & IERR) USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER :: idKEEP(500), idINFO(2) INTEGER(8) :: idKEEP8(150) INTEGER :: idOOC_MAX_NB_NODES_FOR_ZONE INTEGER,DIMENSION(:), POINTER :: idOOC_TOTAL_NB_NODES CHARACTER,DIMENSION(:,:), POINTER :: idOOC_FILE_NAMES INTEGER,DIMENSION(:), POINTER :: idOOC_FILE_NAME_LENGTH INTEGER,DIMENSION(:), POINTER :: idOOC_NB_FILES INTEGER, intent(out) :: IERR INTEGER I,SOLVE_OR_FACTO IERR=0 IF (idKEEP(400).GT.0) THEN !$ CALL OMP_DESTROY_LOCK( LOCK_FOR_L0OMP ) ENDIF IF(WITH_BUF)THEN CALL SMUMPS_END_OOC_BUF() ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_VADDR))THEN NULLIFY(OOC_VADDR) ENDIF CALL MUMPS_OOC_END_WRITE_C(IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) GOTO 500 ENDIF idOOC_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 idOOC_TOTAL_NB_NODES(I)=I_CUR_HBUF_NEXTPOS(I)-1 ENDDO DEALLOCATE(I_CUR_HBUF_NEXTPOS) ENDIF idKEEP8(20)=MAX_SIZE_FACTOR_OOC CALL SMUMPS_STRUC_STORE_FILE_NAME( idOOC_NB_FILES, & idOOC_FILE_NAMES, idOOC_FILE_NAME_LENGTH, & idINFO, IERR) IF(IERR.LT.0)THEN GOTO 500 ENDIF 500 CONTINUE SOLVE_OR_FACTO=0 CALL MUMPS_CLEAN_IO_DATA_C(MYID_OOC,SOLVE_OR_FACTO,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF RETURN END SUBROUTINE SMUMPS_OOC_END_FACTO SUBROUTINE SMUMPS_OOC_INIT_SOLVE(idICNTL1, idICNTL4, idN, & idNSLAVES, idMYID, idOOC_NB_FILE_TYPE, idKEEP, idKEEP8, & idINFO, idSTEP, idPROCNODE_STEPS, idOOC_SIZE_OF_BLOCK, & idOOC_INODE_SEQUENCE, & idOOC_VADDR, idOOC_MAX_NB_NODES_FOR_ZONE, idOOC_TOTAL_NB_NODES, & idOOC_NB_FILES, idOOC_FILE_NAME_LENGTH, idOOC_FILE_NAMES, & idCOMM_NODES, idrootyes) IMPLICIT NONE INTEGER :: idICNTL1, idICNTL4, idN, idNSLAVES, idMYID INTEGER :: idOOC_NB_FILE_TYPE INTEGER, TARGET :: idKEEP(500) INTEGER(8) :: idKEEP8(150) INTEGER :: idINFO(2) INTEGER,POINTER,DIMENSION(:) :: idSTEP, idPROCNODE_STEPS INTEGER(8),DIMENSION(:,:), POINTER :: idOOC_SIZE_OF_BLOCK INTEGER, DIMENSION(:,:), POINTER :: idOOC_INODE_SEQUENCE INTEGER(8), DIMENSION(:,:),POINTER :: idOOC_VADDR INTEGER :: idOOC_MAX_NB_NODES_FOR_ZONE INTEGER, DIMENSION(:), POINTER :: idOOC_TOTAL_NB_NODES INTEGER :: idCOMM_NODES LOGICAL :: idrootyes INTEGER,DIMENSION(:), POINTER :: idOOC_NB_FILES INTEGER,DIMENSION(:), POINTER :: idOOC_FILE_NAME_LENGTH CHARACTER,DIMENSION(:,:), POINTER :: idOOC_FILE_NAMES INCLUDE 'mpif.h' INTEGER TMP,I,J INTEGER(8) :: TMP_SIZE8 INTEGER allocok,IERR EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER MASTER_ROOT IERR=0 ICNTL1=idICNTL1 IF (idICNTL4 > 1) ICNTL1 = 0 SOLVE=.TRUE. N_OOC=idN IF(allocated(LRLUS_SOLVE))THEN DEALLOCATE(LRLUS_SOLVE) ENDIF IF(allocated(LRLU_SOLVE_T))THEN DEALLOCATE(LRLU_SOLVE_T) ENDIF IF(allocated(LRLU_SOLVE_B))THEN DEALLOCATE(LRLU_SOLVE_B) ENDIF IF(allocated(POSFAC_SOLVE))THEN DEALLOCATE(POSFAC_SOLVE) ENDIF IF(allocated(IDEB_SOLVE_Z))THEN DEALLOCATE(IDEB_SOLVE_Z) ENDIF IF(allocated(PDEB_SOLVE_Z))THEN DEALLOCATE(PDEB_SOLVE_Z) ENDIF IF(allocated(SIZE_SOLVE_Z))THEN DEALLOCATE(SIZE_SOLVE_Z) ENDIF IF(allocated(CURRENT_POS_T))THEN DEALLOCATE(CURRENT_POS_T) ENDIF IF(allocated(CURRENT_POS_B))THEN DEALLOCATE(CURRENT_POS_B) ENDIF IF(allocated(POS_HOLE_T))THEN DEALLOCATE(POS_HOLE_T) ENDIF IF(allocated(POS_HOLE_B))THEN DEALLOCATE(POS_HOLE_B) ENDIF IF(allocated(OOC_STATE_NODE))THEN DEALLOCATE(OOC_STATE_NODE) ENDIF IF(allocated(POS_IN_MEM))THEN DEALLOCATE(POS_IN_MEM) ENDIF IF(allocated(INODE_TO_POS))THEN DEALLOCATE(INODE_TO_POS) ENDIF IF(allocated(SIZE_OF_READ))THEN DEALLOCATE(SIZE_OF_READ) ENDIF IF(allocated(FIRST_POS_IN_READ))THEN DEALLOCATE(FIRST_POS_IN_READ) ENDIF IF(allocated(READ_DEST))THEN DEALLOCATE(READ_DEST) ENDIF IF(allocated(READ_MNG))THEN DEALLOCATE(READ_MNG) ENDIF IF(allocated(REQ_TO_ZONE))THEN DEALLOCATE(REQ_TO_ZONE) ENDIF IF(allocated(REQ_ID))THEN DEALLOCATE(REQ_ID) ENDIF IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF OOC_NB_FILE_TYPE=idOOC_NB_FILE_TYPE CALL MUMPS_OOC_INIT_FILETYPE(TYPEF_L, TYPEF_U, TYPEF_CB, & idKEEP(201), idKEEP(251), idKEEP(50), TYPEF_INVALID ) DIM_ERR_STR_OOC = ERR_STR_OOC_MAX_LEN CALL MUMPS_LOW_LEVEL_INIT_ERR_STR(DIM_ERR_STR_OOC,ERR_STR_OOC) CALL SMUMPS_OOC_OPEN_FILES_FOR_SOLVE(idINFO, idOOC_NB_FILES, & idMYID, idKEEP, idOOC_FILE_NAME_LENGTH, idOOC_FILE_NAMES ) IF(idINFO(1).LT.0)THEN RETURN ENDIF STEP_OOC=>idSTEP PROCNODE_OOC=>idPROCNODE_STEPS SLAVEF_OOC=idNSLAVES MYID_OOC=idMYID KEEP_OOC => idKEEP SIZE_OF_BLOCK=>idOOC_SIZE_OF_BLOCK OOC_INODE_SEQUENCE=>idOOC_INODE_SEQUENCE OOC_VADDR=>idOOC_VADDR ALLOCATE(IO_REQ(idKEEP(28)), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = idKEEP(28) RETURN ENDIF SMUMPS_ELEMENTARY_DATA_SIZE = idKEEP(35) MAX_NB_NODES_FOR_ZONE=idOOC_MAX_NB_NODES_FOR_ZONE TOTAL_NB_OOC_NODES=>idOOC_TOTAL_NB_NODES CALL SMUMPS_SET_STRAT_IO_FLAGS( idKEEP(204), STRAT_IO_ASYNC, & WITH_BUF, LOW_LEVEL_STRAT_IO) IF(idKEEP(107).GT.0)THEN SIZE_SOLVE_EMM=max(idKEEP8(20), & FACT_AREA_SIZE / 5_8) SIZE_ZONE_SOLVE=max(SIZE_SOLVE_EMM, & int((dble(FACT_AREA_SIZE)- & dble(SIZE_SOLVE_EMM))/dble(idKEEP(107)),8)) SIZE_ZONE_SOLVE=max(SIZE_ZONE_SOLVE,0_8) IF(SIZE_ZONE_SOLVE.EQ.SIZE_SOLVE_EMM)THEN SIZE_SOLVE_EMM=idKEEP8(20) SIZE_ZONE_SOLVE=int((real(FACT_AREA_SIZE)- & real(SIZE_SOLVE_EMM))/real(idKEEP(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.idKEEP8(20))THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': More space needed for & solution step in SMUMPS_OOC_INIT_SOLVE' idINFO(1) = -11 CALL MUMPS_SET_IERROR(idKEEP8(20), idINFO(2)) ENDIF TMP=MAX_NB_NODES_FOR_ZONE CALL MPI_ALLREDUCE(TMP,MAX_NB_NODES_FOR_ZONE,1, & MPI_INTEGER,MPI_MAX,idCOMM_NODES, IERR) NB_Z=KEEP_OOC(107)+1 ALLOCATE(POS_IN_MEM(MAX_NB_NODES_FOR_ZONE*NB_Z), & INODE_TO_POS(KEEP_OOC(28)), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = idKEEP(28)+(MAX_NB_NODES_FOR_ZONE*NB_Z) RETURN ENDIF ALLOCATE(OOC_STATE_NODE(KEEP_OOC(28)),stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = idKEEP(28) RETURN ENDIF OOC_STATE_NODE(1:KEEP_OOC(28))=0 INODE_TO_POS=0 POS_IN_MEM=0 ALLOCATE(LRLUS_SOLVE(NB_Z), LRLU_SOLVE_T(NB_Z),LRLU_SOLVE_B(NB_Z), & POSFAC_SOLVE(NB_Z),IDEB_SOLVE_Z(NB_Z), & PDEB_SOLVE_Z(NB_Z),SIZE_SOLVE_Z(NB_Z), & CURRENT_POS_T(NB_Z),CURRENT_POS_B(NB_Z), & POS_HOLE_T(NB_Z),POS_HOLE_B(NB_Z), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = 9*(NB_Z+1) RETURN ENDIF IERR=0 CALL MUMPS_GET_MAX_NB_REQ_C(MAX_NB_REQ,IERR) ALLOCATE(SIZE_OF_READ(MAX_NB_REQ),FIRST_POS_IN_READ(MAX_NB_REQ), & READ_DEST(MAX_NB_REQ),READ_MNG(MAX_NB_REQ), & REQ_TO_ZONE(MAX_NB_REQ),REQ_ID(MAX_NB_REQ),stat=allocok) SIZE_OF_READ=-9999_8 FIRST_POS_IN_READ=-9999 READ_DEST=-9999_8 READ_MNG=-9999 REQ_TO_ZONE=-9999 REQ_ID=-9999 IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = 6*(NB_Z+1) RETURN ENDIF MIN_SIZE_READ=min(max((1024_8*1024_8)/int(idKEEP(35),8), & SIZE_ZONE_SOLVE/3_8), & SIZE_ZONE_SOLVE) TMP_SIZE8=1_8 J=1 DO I=1,NB_Z-1 IDEB_SOLVE_Z(I)=TMP_SIZE8 POSFAC_SOLVE(I)=TMP_SIZE8 LRLUS_SOLVE(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_T(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_B(I)=0_8 SIZE_SOLVE_Z(I)=SIZE_ZONE_SOLVE CURRENT_POS_T(I)=J CURRENT_POS_B(I)=J PDEB_SOLVE_Z(I)=J POS_HOLE_T(I)=J POS_HOLE_B(I)=J J=J+MAX_NB_NODES_FOR_ZONE TMP_SIZE8=TMP_SIZE8+SIZE_ZONE_SOLVE ENDDO IDEB_SOLVE_Z(NB_Z)=TMP_SIZE8 PDEB_SOLVE_Z(NB_Z)=J POSFAC_SOLVE(NB_Z)=TMP_SIZE8 LRLUS_SOLVE(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_T(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_B(NB_Z)=0_8 SIZE_SOLVE_Z(NB_Z)=SIZE_SOLVE_EMM CURRENT_POS_T(NB_Z)=J CURRENT_POS_B(NB_Z)=J POS_HOLE_T(NB_Z)=J POS_HOLE_B(NB_Z)=J IO_REQ=-77777 REQ_ACT=0 OOC_STATE_NODE(1:KEEP_OOC(28))=NOT_IN_MEM IF(KEEP_OOC(38).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(38))), & KEEP_OOC(199) ) SPECIAL_ROOT_NODE=KEEP_OOC(38) ELSEIF(KEEP_OOC(20).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(20))), & KEEP_OOC(199) ) SPECIAL_ROOT_NODE=KEEP_OOC(20) ELSE MASTER_ROOT=-111111 SPECIAL_ROOT_NODE=-2222222 ENDIF IF ( KEEP_OOC(60).EQ.0 .AND. & ( & (KEEP_OOC(38).NE.0 .AND. idrootyes) & .OR. & (KEEP_OOC(20).NE.0 .AND. MYID_OOC.EQ.MASTER_ROOT)) & ) & THEN IS_ROOT_SPECIAL = .TRUE. ELSE IS_ROOT_SPECIAL = .FALSE. ENDIF NB_ZONE_REQ=0 SIZE_ZONE_REQ=0_8 CURRENT_SOLVE_READ_ZONE=0 NB_CALLED=0 NB_CALL=0 SOLVE_STEP=-9999 RETURN END SUBROUTINE SMUMPS_OOC_INIT_SOLVE SUBROUTINE SMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA REAL A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER I IERR=0 IF(NB_Z.GT.1)THEN IF(STRAT_IO_ASYNC)THEN DO I=1,NB_Z-1 CALL SMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO ELSE CALL SMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_INITIATE_READ_OPS SUBROUTINE SMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA REAL A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER ZONE CALL SMUMPS_SOLVE_SELECT_ZONE(ZONE) IERR=0 CALL SMUMPS_SOLVE_ZONE_READ(ZONE,A,LA,PTRFAC,NSTEPS,IERR) RETURN END SUBROUTINE SMUMPS_SUBMIT_READ_FOR_Z SUBROUTINE SMUMPS_READ_SOLVE_BLOCK(DEST,INDICE,SIZE, & ZONE,PTRFAC,NSTEPS,POS_SEQ,NB_NODES,FLAG,IERR) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER ZONE,NSTEPS,FLAG,POS_SEQ,NB_NODES REAL DEST INTEGER (8) :: INDICE, SIZE, PTRFAC(NSTEPS) INTEGER REQUEST,INODE,IERR INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=OOC_SOLVE_TYPE_FCT IERR=0 INODE=OOC_INODE_SEQUENCE(POS_SEQ,OOC_FCT_TYPE) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_READ_OOC_C(LOW_LEVEL_STRAT_IO, & DEST,SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(STRAT_IO_ASYNC)THEN CALL SMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL SMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL SMUMPS_SOLVE_UPDATE_POINTERS(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF END SUBROUTINE SMUMPS_READ_SOLVE_BLOCK SUBROUTINE SMUMPS_SOLVE_UPDATE_POINTERS(REQUEST,PTRFAC, & NSTEPS) IMPLICIT NONE INTEGER NSTEPS,REQUEST INTEGER (8) :: PTRFAC(NSTEPS) INTEGER (8) :: LAST, POS_IN_S, J INTEGER ZONE INTEGER POS_REQ,I,TMP_NODE,POS_IN_MANAGE INTEGER (8) SIZE LOGICAL DONT_USE EXTERNAL MUMPS_TYPENODE,MUMPS_PROCNODE INTEGER MUMPS_TYPENODE,MUMPS_PROCNODE POS_REQ=mod(REQUEST,MAX_NB_REQ)+1 SIZE=SIZE_OF_READ(POS_REQ) I=FIRST_POS_IN_READ(POS_REQ) POS_IN_S=READ_DEST(POS_REQ) POS_IN_MANAGE=READ_MNG(POS_REQ) ZONE=REQ_TO_ZONE(POS_REQ) DONT_USE=.FALSE. J=0_8 DO WHILE((J.LT.SIZE).AND.(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))) TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) LAST=SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN I=I+1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(TMP_NODE)).NE.0).AND. & (INODE_TO_POS(STEP_OOC(TMP_NODE)).LT. & -((N_OOC+1)*NB_Z)))THEN DONT_USE= & (((MTYPE_OOC.EQ.1).AND.(KEEP_OOC(50).EQ.0).AND. & (SOLVE_STEP.EQ.1).AND. & ((MUMPS_TYPENODE(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & KEEP_OOC(199)).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),KEEP_OOC(199)).NE. & MYID_OOC))) & .OR. & ((MTYPE_OOC.NE.1).AND.(KEEP_OOC(50).EQ.0).AND. & (SOLVE_STEP.EQ.0).AND. & ((MUMPS_TYPENODE(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & KEEP_OOC(199)).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),KEEP_OOC(199)).NE. & MYID_OOC)))).OR. & (OOC_STATE_NODE(STEP_OOC(TMP_NODE)).EQ.ALREADY_USED) IF(DONT_USE)THEN PTRFAC(STEP_OOC(TMP_NODE))=-POS_IN_S ELSE PTRFAC(STEP_OOC(TMP_NODE))=POS_IN_S ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).LT. & IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Inernal error (42) in OOC ', & PTRFAC(STEP_OOC(TMP_NODE)),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).GT. & (IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)-1_8))THEN WRITE(*,*)MYID_OOC,': Inernal error (43) in OOC ' CALL MUMPS_ABORT() ENDIF IF(DONT_USE)THEN POS_IN_MEM(POS_IN_MANAGE)=-TMP_NODE INODE_TO_POS(STEP_OOC(TMP_NODE))=-POS_IN_MANAGE IF(OOC_STATE_NODE(STEP_OOC(TMP_NODE)).NE. & ALREADY_USED)THEN OOC_STATE_NODE(STEP_OOC(TMP_NODE))=USED_NOT_PERMUTED ENDIF LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+LAST ELSE POS_IN_MEM(POS_IN_MANAGE)=TMP_NODE INODE_TO_POS(STEP_OOC(TMP_NODE))=POS_IN_MANAGE OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED ENDIF IO_REQ(STEP_OOC(TMP_NODE))=-7777 ELSE POS_IN_MEM(POS_IN_MANAGE)=0 ENDIF POS_IN_S=POS_IN_S+LAST POS_IN_MANAGE=POS_IN_MANAGE+1 J=J+LAST I=I+1 ENDDO SIZE_OF_READ(POS_REQ)=-9999_8 FIRST_POS_IN_READ(POS_REQ)=-9999 READ_DEST(POS_REQ)=-9999_8 READ_MNG(POS_REQ)=-9999 REQ_TO_ZONE(POS_REQ)=-9999 REQ_ID(POS_REQ)=-9999 RETURN END SUBROUTINE SMUMPS_SOLVE_UPDATE_POINTERS SUBROUTINE SMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,DEST,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER INODE,ZONE,REQUEST,FLAG,POS_SEQ,NB_NODES,NSTEPS INTEGER(8) :: SIZE INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: DEST, LOCAL_DEST, J8 INTEGER I,TMP_NODE,LOC_I,POS_REQ,NB INTEGER(8)::LAST INTEGER, intent(out) :: IERR IERR=0 IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN RETURN ENDIF NB=0 LOCAL_DEST=DEST I=POS_SEQ POS_REQ=mod(REQUEST,MAX_NB_REQ)+1 IF(REQ_ID(POS_REQ).NE.-9999)THEN CALL MUMPS_WAIT_REQUEST(REQ_ID(POS_REQ),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF CALL SMUMPS_SOLVE_UPDATE_POINTERS(REQUEST,PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF SIZE_OF_READ(POS_REQ)=SIZE FIRST_POS_IN_READ(POS_REQ)=I READ_DEST(POS_REQ)=DEST IF(FLAG.EQ.0)THEN READ_MNG(POS_REQ)=CURRENT_POS_B(ZONE)-NB_NODES+1 ELSEIF(FLAG.EQ.1)THEN READ_MNG(POS_REQ)=CURRENT_POS_T(ZONE) ENDIF REQ_TO_ZONE(POS_REQ)=ZONE REQ_ID(POS_REQ)=REQUEST J8=0_8 IF(FLAG.EQ.0)THEN LOC_I=CURRENT_POS_B(ZONE)-NB_NODES+1 ENDIF DO WHILE((J8.LT.SIZE).AND.(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))) TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) LAST=SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I+1 CYCLE ENDIF IF((IO_REQ(STEP_OOC(TMP_NODE)).GE.0).OR. & (INODE_TO_POS(STEP_OOC(TMP_NODE)).NE.0))THEN IF(FLAG.EQ.1)THEN POS_IN_MEM(CURRENT_POS_T(ZONE))=0 ELSEIF(FLAG.EQ.0)THEN POS_IN_MEM(CURRENT_POS_B(ZONE))=0 ENDIF ELSE IO_REQ(STEP_OOC(TMP_NODE))=REQUEST LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)-LAST IF(FLAG.EQ.1)THEN IF(POSFAC_SOLVE(ZONE).EQ.IDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)+LAST LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)-LAST POS_IN_MEM(CURRENT_POS_T(ZONE))=-TMP_NODE- & ((N_OOC+1)*NB_Z) INODE_TO_POS(STEP_OOC(TMP_NODE))=-CURRENT_POS_T(ZONE)- & ((N_OOC+1)*NB_Z) OOC_STATE_NODE(STEP_OOC(TMP_NODE))=BEING_READ PTRFAC(STEP_OOC(TMP_NODE))=-LOCAL_DEST LOCAL_DEST=LOCAL_DEST+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(FLAG.EQ.0)THEN LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)-LAST POS_IN_MEM(LOC_I)=-TMP_NODE-((N_OOC+1)*NB_Z) IF(LOC_I.EQ.POS_HOLE_T(ZONE))THEN IF(POS_HOLE_T(ZONE).LT.CURRENT_POS_T(ZONE))THEN POS_HOLE_T(ZONE)=POS_HOLE_T(ZONE)+1 ENDIF ENDIF INODE_TO_POS(STEP_OOC(TMP_NODE))=-LOC_I-((N_OOC+1)*NB_Z) OOC_STATE_NODE(STEP_OOC(TMP_NODE))=BEING_READ PTRFAC(STEP_OOC(TMP_NODE))=-LOCAL_DEST LOCAL_DEST=LOCAL_DEST+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSE WRITE(*,*)MYID_OOC,': Internal error (39) in OOC ', & ' Invalid Flag Value in ', & ' SMUMPS_UPDATE_READ_REQ_NODE',FLAG CALL MUMPS_ABORT() ENDIF ENDIF IF(POS_IN_MEM(CURRENT_POS_T(ZONE)).NE.0)THEN IF(POS_IN_MEM(CURRENT_POS_T(ZONE)).EQ. & POS_IN_MEM(PDEB_SOLVE_Z(ZONE)))THEN IF(CURRENT_POS_T(ZONE).NE.PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (40) in OOC ', & CURRENT_POS_T(ZONE), & PDEB_SOLVE_Z(ZONE), & POS_IN_MEM(CURRENT_POS_T(ZONE)), & POS_IN_MEM(PDEB_SOLVE_Z(ZONE)) CALL MUMPS_ABORT() ENDIF ENDIF ENDIF J8=J8+LAST IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (41) in OOC ', & ' LRLUS_SOLVE must be (1) > 0', & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF I=I+1 IF(FLAG.EQ.1)THEN CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)+1 IF(CURRENT_POS_T(ZONE).GT. & MAX_NB_NODES_FOR_ZONE+PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (1) in OOC ' CALL MUMPS_ABORT() ENDIF POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) ELSEIF(FLAG.EQ.0)THEN IF(POS_HOLE_B(ZONE).LT.PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (2) in OOC ', & POS_HOLE_B(ZONE),LOC_I CALL MUMPS_ABORT() ENDIF CURRENT_POS_B(ZONE)=CURRENT_POS_B(ZONE)-1 POS_HOLE_B(ZONE)=CURRENT_POS_B(ZONE) IF(POS_HOLE_B(ZONE).LT.PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF ELSE WRITE(*,*)MYID_OOC,': Internal error (3) in OOC ', & ' Invalid Flag Value in ', & ' SMUMPS_UPDATE_READ_REQ_NODE',FLAG CALL MUMPS_ABORT() ENDIF IF(FLAG.EQ.0)THEN LOC_I=LOC_I+1 ENDIF NB=NB+1 ENDDO IF(NB.NE.NB_NODES)THEN WRITE(*,*)MYID_OOC,': Internal error (4) in OOC ', & ' SMUMPS_UPDATE_READ_REQ_NODE ',NB,NB_NODES ENDIF IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=I ELSE CUR_POS_SEQUENCE=POS_SEQ-1 ENDIF RETURN END SUBROUTINE SMUMPS_UPDATE_READ_REQ_NODE SUBROUTINE SMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,NSTEPS,A, & LA,FLAG,IERR) IMPLICIT NONE INTEGER(8) :: LA INTEGER, intent(out):: IERR REAL A(LA) INTEGER INODE,NSTEPS INTEGER(8) :: PTRFAC(NSTEPS) LOGICAL FLAG INTEGER(8) FREE_SIZE INTEGER TMP,TMP_NODE,I,ZONE,J INTEGER WHICH INTEGER(8) :: DUMMY_SIZE DUMMY_SIZE=1_8 IERR = 0 WHICH=-1 IF(INODE_TO_POS(STEP_OOC(INODE)).LE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (5) in OOC ', & ' Problem in SMUMPS_FREE_FACTORS_FOR_SOLVE', & INODE, STEP_OOC(INODE), INODE_TO_POS(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE).EQ.0_8)THEN INODE_TO_POS(STEP_OOC(INODE))=0 OOC_STATE_NODE(STEP_OOC(INODE))=ALREADY_USED RETURN ENDIF CALL SMUMPS_SOLVE_FIND_ZONE(INODE,ZONE,PTRFAC,NSTEPS) TMP=INODE_TO_POS(STEP_OOC(INODE)) INODE_TO_POS(STEP_OOC(INODE))=-TMP POS_IN_MEM(TMP)=-INODE PTRFAC(STEP_OOC(INODE))=-PTRFAC(STEP_OOC(INODE)) IF (KEEP_OOC(237).eq.0) THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).NE.PERMUTED)THEN WRITE(*,*)MYID_OOC,': INTERNAL ERROR (53) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF ENDIF OOC_STATE_NODE(STEP_OOC(INODE))=USED LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (6) in OOC ', & ': LRLUS_SOLVE must be (2) > 0' CALL MUMPS_ABORT() ENDIF IF(ZONE.EQ.NB_Z)THEN IF(INODE.NE.SPECIAL_ROOT_NODE)THEN CALL SMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & DUMMY_SIZE,PTRFAC,KEEP_OOC(28),ZONE,IERR) ENDIF ELSE IF(SOLVE_STEP.EQ.0)THEN IF(TMP.GT.POS_HOLE_B(ZONE))THEN WHICH=0 ELSEIF(TMP.LT.POS_HOLE_T(ZONE))THEN WHICH=1 ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(TMP.LT.POS_HOLE_T(ZONE))THEN WHICH=1 ELSEIF(TMP.GT.POS_HOLE_B(ZONE))THEN WHICH=0 ENDIF ENDIF IF(WHICH.EQ.1)THEN J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_T(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE=0_8 DO I=J,TMP,-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN GOTO 666 ENDIF ENDDO POS_HOLE_T(ZONE)=TMP 666 CONTINUE ELSEIF(WHICH.EQ.0)THEN J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_B(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE=0_8 DO I=J,TMP IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN IF(J.EQ.PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 CURRENT_POS_B(ZONE)=-9999 ENDIF GOTO 777 ENDIF ENDDO POS_HOLE_B(ZONE)=TMP 777 CONTINUE ENDIF IERR=0 ENDIF IF((NB_Z.GT.1).AND.FLAG)THEN CALL SMUMPS_SOLVE_TRY_ZONE_FOR_READ(ZONE) IF((LRLUS_SOLVE(ZONE).GE.MIN_SIZE_READ).OR. & (LRLUS_SOLVE(ZONE).GE. & int(0.3E0*real(SIZE_SOLVE_Z(ZONE)),8)))THEN CALL SMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL SMUMPS_SOLVE_SELECT_ZONE(ZONE) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_FREE_FACTORS_FOR_SOLVE FUNCTION SMUMPS_SOLVE_IS_INODE_IN_MEM(INODE,PTRFAC,NSTEPS,A,LA, & IERR) IMPLICIT NONE INTEGER INODE,NSTEPS INTEGER(8) :: LA INTEGER, INTENT(out)::IERR REAL A(LA) INTEGER (8) :: PTRFAC(NSTEPS) INTEGER SMUMPS_SOLVE_IS_INODE_IN_MEM IERR=0 IF(INODE_TO_POS(STEP_OOC(INODE)).GT.0)THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN SMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_PERMUTED ELSE SMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_PERMUTED ENDIF IF(.NOT.SMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE) & .EQ.INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL SMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF ELSEIF(INODE_TO_POS(STEP_OOC(INODE)).LT.0)THEN IF(INODE_TO_POS(STEP_OOC(INODE)).LT.-((N_OOC+1)*NB_Z))THEN CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(INODE)),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': Internal error (7) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF CALL SMUMPS_SOLVE_UPDATE_POINTERS(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ELSE CALL SMUMPS_SOLVE_UPD_NODE_INFO(INODE,PTRFAC,NSTEPS) IF(.NOT.SMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE).EQ. & INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL SMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF ENDIF IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN SMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_PERMUTED ELSE SMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_PERMUTED ENDIF ELSE SMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_IN_MEM ENDIF RETURN END FUNCTION SMUMPS_SOLVE_IS_INODE_IN_MEM SUBROUTINE SMUMPS_SOLVE_MODIFY_STATE_NODE(INODE) IMPLICIT NONE INTEGER INODE IF ( (KEEP_OOC(237).EQ.0) & .AND. (KEEP_OOC(235).EQ.0) & .AND. (KEEP_OOC(212).EQ.0) & ) THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).NE.NOT_USED)THEN WRITE(*,*)MYID_OOC,': INTERNAL ERROR (51) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF ENDIF OOC_STATE_NODE(STEP_OOC(INODE))=PERMUTED END SUBROUTINE SMUMPS_SOLVE_MODIFY_STATE_NODE SUBROUTINE SMUMPS_SOLVE_UPD_NODE_INFO(INODE,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER INODE,NSTEPS INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZONE INODE_TO_POS(STEP_OOC(INODE))=-INODE_TO_POS(STEP_OOC(INODE)) POS_IN_MEM(INODE_TO_POS(STEP_OOC(INODE)))= & -POS_IN_MEM(INODE_TO_POS(STEP_OOC(INODE))) PTRFAC(STEP_OOC(INODE))=-PTRFAC(STEP_OOC(INODE)) IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.USED_NOT_PERMUTED)THEN OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED ELSEIF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.USED)THEN OOC_STATE_NODE(STEP_OOC(INODE))=PERMUTED ELSE WRITE(*,*)MYID_OOC,': Internal error (52) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)), & INODE_TO_POS(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF CALL SMUMPS_SEARCH_SOLVE(PTRFAC(STEP_OOC(INODE)),ZONE) IF(INODE_TO_POS(STEP_OOC(INODE)).LE.POS_HOLE_B(ZONE))THEN IF(INODE_TO_POS(STEP_OOC(INODE)).GT. & PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)= & INODE_TO_POS(STEP_OOC(INODE))-1 ELSE CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF ENDIF IF(INODE_TO_POS(STEP_OOC(INODE)).GE.POS_HOLE_T(ZONE))THEN IF(INODE_TO_POS(STEP_OOC(INODE)).LT. & CURRENT_POS_T(ZONE)-1)THEN POS_HOLE_T(ZONE)=INODE_TO_POS(STEP_OOC(INODE))+1 ELSE POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) ENDIF ENDIF CALL SMUMPS_OOC_UPDATE_SOLVE_STAT(INODE,PTRFAC,NSTEPS,1) END SUBROUTINE SMUMPS_SOLVE_UPD_NODE_INFO SUBROUTINE SMUMPS_SOLVE_FIND_ZONE(INODE,ZONE,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER INODE,ZONE,NSTEPS INTEGER (8) :: PTRFAC(NSTEPS) ZONE=1 DO WHILE (ZONE.LE.NB_Z) IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN ZONE=ZONE-1 EXIT ENDIF ZONE=ZONE+1 ENDDO IF(ZONE.EQ.NB_Z+1)THEN ZONE=ZONE-1 ENDIF END SUBROUTINE SMUMPS_SOLVE_FIND_ZONE SUBROUTINE SMUMPS_SOLVE_TRY_ZONE_FOR_READ(ZONE) IMPLICIT NONE INTEGER ZONE ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1)+1 END SUBROUTINE SMUMPS_SOLVE_TRY_ZONE_FOR_READ SUBROUTINE SMUMPS_SOLVE_SELECT_ZONE(ZONE) IMPLICIT NONE INTEGER ZONE IF(NB_Z.GT.1)THEN CURRENT_SOLVE_READ_ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1) ZONE=CURRENT_SOLVE_READ_ZONE+1 ELSE ZONE=NB_Z ENDIF END SUBROUTINE SMUMPS_SOLVE_SELECT_ZONE SUBROUTINE SMUMPS_SOLVE_ALLOC_FACTOR_SPACE(INODE,PTRFAC, & KEEP,KEEP8, & A,IERR) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER, intent(out)::IERR INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) REAL A(FACT_AREA_SIZE) INTEGER(8) :: REQUESTED_SIZE INTEGER ZONE,IFLAG IERR=0 IFLAG=0 IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) & .EQ.0_8)THEN INODE_TO_POS(STEP_OOC(INODE))=1 OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED PTRFAC(STEP_OOC(INODE))=1_8 RETURN ENDIF REQUESTED_SIZE=SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ZONE=NB_Z IF(CURRENT_POS_T(ZONE).GT. & (PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1))THEN CALL SMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF((LRLU_SOLVE_T(ZONE).GT.SIZE_OF_BLOCK(STEP_OOC(INODE), & OOC_FCT_TYPE)).AND. & (CURRENT_POS_T(ZONE).LE. & (PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1)))THEN CALL SMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(LRLU_SOLVE_B(ZONE).GT.SIZE_OF_BLOCK(STEP_OOC(INODE), & OOC_FCT_TYPE).AND. & (CURRENT_POS_B(ZONE).GT.0))THEN CALL SMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSE IF(SMUMPS_IS_THERE_FREE_SPACE(INODE,ZONE))THEN IF(SOLVE_STEP.EQ.0)THEN CALL SMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL SMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL SMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL SMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ELSE CALL SMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL SMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL SMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL SMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ENDIF IF(IFLAG.EQ.0)THEN CALL SMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL SMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ELSE WRITE(*,*)MYID_OOC,': Internal error (8) in OOC ', & ' Not enough space for Solve',INODE, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE), & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF ENDIF IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (9) in OOC ', & ' LRLUS_SOLVE must be (3) > 0' CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE SMUMPS_SOLVE_ALLOC_FACTOR_SPACE SUBROUTINE SMUMPS_GET_TOP_AREA_SPACE(A,LA,REQUESTED_SIZE,PTRFAC, & NSTEPS,ZONE,FLAG,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE,FLAG INTEGER(8) :: REQUESTED_SIZE, LA INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: FREE_SIZE, FREE_HOLE, FREE_HOLE_POS REAL A(LA) INTEGER I,TMP_NODE,FREE_HOLE_FLAG, J INTEGER, intent(out)::IERR IERR=0 FLAG=0 IF(LRLU_SOLVE_T(ZONE).EQ.SIZE_SOLVE_Z(ZONE).AND. & (.NOT.(CURRENT_POS_T(ZONE) & .GT.PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1)))THEN GOTO 50 ENDIF J=max(POS_HOLE_B(ZONE),PDEB_SOLVE_Z(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) DO I=POS_HOLE_T(ZONE)-1,J,-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) ELSEIF(POS_IN_MEM(I).NE.0)THEN EXIT ENDIF ENDDO POS_HOLE_T(ZONE)=I+1 IF((POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE)).OR. & (POS_HOLE_T(ZONE).LE.POS_HOLE_B(ZONE)).OR. & (POS_HOLE_T(ZONE).EQ.POS_HOLE_B(ZONE)+1))THEN CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_T(ZONE)=PDEB_SOLVE_Z(ZONE) ENDIF FREE_HOLE=0_8 FREE_SIZE=0_8 FREE_HOLE_FLAG=0 FREE_HOLE_POS=POSFAC_SOLVE(ZONE) DO I=CURRENT_POS_T(ZONE)-1,POS_HOLE_T(ZONE),-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) FREE_HOLE_FLAG=0 FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE))) PTRFAC(STEP_OOC(TMP_NODE))=-777777_8 INODE_TO_POS(STEP_OOC(TMP_NODE))=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED POS_IN_MEM(I)=0 FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).EQ.0)THEN FREE_HOLE_FLAG=1 ELSEIF(POS_IN_MEM(I).NE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (10) in OOC ', & ' SMUMPS_GET_TOP_AREA_SPACE', & CURRENT_POS_T(ZONE)-1,POS_HOLE_T(ZONE),I CALL MUMPS_ABORT() ENDIF ENDDO IF(POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE))THEN IF(FREE_HOLE_FLAG.EQ.0)THEN FREE_HOLE_FLAG=1 ENDIF ENDIF IF(FREE_HOLE_FLAG.EQ.1)THEN IF(POS_HOLE_T(ZONE)-1.GT.PDEB_SOLVE_Z(ZONE))THEN I=POS_HOLE_T(ZONE)-1 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.(N_OOC+1)*NB_Z)THEN TMP_NODE=TMP_NODE-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (11) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL SMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSEIF(TMP_NODE.EQ.0)THEN DO J=I,PDEB_SOLVE_Z(ZONE),-1 IF(POS_IN_MEM(J).NE.0) EXIT ENDDO IF(POS_IN_MEM(J).LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (12) in OOC ', & ' SMUMPS_GET_TOP_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF(J.GE.PDEB_SOLVE_Z(ZONE))THEN TMP_NODE=POS_IN_MEM(J) FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE FREE_HOLE=FREE_HOLE_POS-IDEB_SOLVE_Z(ZONE) ENDIF ELSEIF(TMP_NODE.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (13) in OOC', & ' SMUMPS_GET_TOP_AREA_SPACE' CALL MUMPS_ABORT() ELSE FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ENDIF ELSE FREE_HOLE=FREE_HOLE_POS-IDEB_SOLVE_Z(ZONE) ENDIF FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF CURRENT_POS_T(ZONE)=POS_HOLE_T(ZONE) LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)+FREE_SIZE POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)-FREE_SIZE 50 CONTINUE IF(REQUESTED_SIZE.LE.LRLU_SOLVE_T(ZONE))THEN FLAG=1 ELSE FLAG=0 ENDIF RETURN END SUBROUTINE SMUMPS_GET_TOP_AREA_SPACE SUBROUTINE SMUMPS_GET_BOTTOM_AREA_SPACE(A,LA,REQUESTED_SIZE, & PTRFAC,NSTEPS,ZONE,FLAG,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE,FLAG INTEGER (8) :: REQUESTED_SIZE INTEGER (8) :: LA INTEGER (8) :: PTRFAC(NSTEPS) REAL A(LA) INTEGER(8) :: FREE_SIZE, FREE_HOLE_POS, FREE_HOLE INTEGER I,J,TMP_NODE,FREE_HOLE_FLAG INTEGER, intent(out) :: IERR IERR=0 FLAG=0 IF(LRLU_SOLVE_B(ZONE).EQ.SIZE_SOLVE_Z(ZONE))THEN GOTO 50 ENDIF IF(POS_HOLE_B(ZONE).EQ.-9999)THEN GOTO 50 ENDIF J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_T(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE = 0_8 DO I=POS_HOLE_B(ZONE)+1,J IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN EXIT ENDIF ENDDO POS_HOLE_B(ZONE)=I-1 IF((POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE)).OR. & (POS_HOLE_T(ZONE).LE.POS_HOLE_B(ZONE)).OR. & (POS_HOLE_T(ZONE).EQ.POS_HOLE_B(ZONE)+1))THEN CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_T(ZONE)=PDEB_SOLVE_Z(ZONE) ENDIF FREE_HOLE=0_8 FREE_SIZE=0_8 FREE_HOLE_FLAG=0 FREE_HOLE_POS=IDEB_SOLVE_Z(ZONE) IF(POS_HOLE_B(ZONE).EQ.-9999)THEN GOTO 50 ENDIF DO I=PDEB_SOLVE_Z(ZONE),POS_HOLE_B(ZONE) IF((POS_IN_MEM(I).LE.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) IF(TMP_NODE.NE.0)THEN IF(I.EQ.PDEB_SOLVE_Z(ZONE))THEN IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).NE. & IDEB_SOLVE_Z(ZONE))THEN FREE_SIZE=FREE_SIZE+abs(PTRFAC(STEP_OOC(TMP_NODE))) & -IDEB_SOLVE_Z(ZONE) ENDIF ENDIF IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(TMP_NODE))=-777777_8 INODE_TO_POS(STEP_OOC(TMP_NODE))=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSE FREE_HOLE_FLAG=1 ENDIF POS_IN_MEM(I)=0 ELSEIF(POS_IN_MEM(I).NE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (14) in OOC ', & ' SMUMPS_GET_BOTTOM_AREA_SPACE', & CURRENT_POS_T(ZONE)-1,POS_HOLE_B(ZONE),I,POS_IN_MEM(I) CALL MUMPS_ABORT() ENDIF ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN IF(POS_HOLE_B(ZONE)+1.LT.CURRENT_POS_T(ZONE)-1)THEN I=POS_HOLE_B(ZONE)+1 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.(N_OOC+1)*NB_Z)THEN TMP_NODE=TMP_NODE-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (15) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL SMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))-FREE_HOLE_POS ELSEIF(TMP_NODE.EQ.0)THEN DO J=I,CURRENT_POS_T(ZONE)-1 IF(POS_IN_MEM(J).NE.0) EXIT ENDDO IF(POS_IN_MEM(J).LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (16) in OOC ', & ' SMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF(J.LE.CURRENT_POS_T(ZONE)-1)THEN TMP_NODE=POS_IN_MEM(J) FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS ELSE FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS ENDIF ELSEIF(TMP_NODE.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (17) in OOC ', & ' SMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ELSE FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS ENDIF ELSE FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS ENDIF FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF LRLU_SOLVE_B(ZONE)=FREE_SIZE IF(POS_HOLE_B(ZONE).LT.CURRENT_POS_T(ZONE)-1)THEN TMP_NODE=POS_IN_MEM(POS_HOLE_B(ZONE)+1) IF(TMP_NODE.LT.-(N_OOC+1)*NB_Z)THEN TMP_NODE=abs(TMP_NODE)-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (18) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL SMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) ENDIF LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)+ & (abs(PTRFAC(STEP_OOC(abs(TMP_NODE))))-IDEB_SOLVE_Z(ZONE)- & LRLU_SOLVE_B(ZONE)) ENDIF CURRENT_POS_B(ZONE)=POS_HOLE_B(ZONE) 50 CONTINUE IF((POS_HOLE_B(ZONE).EQ.-9999).AND. & (LRLU_SOLVE_B(ZONE).NE.0_8))THEN WRITE(*,*)MYID_OOC,': Internal error (19) in OOC ', & 'SMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF((REQUESTED_SIZE.LE.LRLU_SOLVE_B(ZONE)).AND. & (POS_HOLE_B(ZONE).NE.-9999))THEN FLAG=1 ELSE FLAG=0 ENDIF END SUBROUTINE SMUMPS_GET_BOTTOM_AREA_SPACE SUBROUTINE SMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8, A,ZONE) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) REAL A(FACT_AREA_SIZE) INTEGER ZONE LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(INODE))=POSFAC_SOLVE(ZONE) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED IF(POSFAC_SOLVE(ZONE).EQ.IDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (20) in OOC ', & ' Problem avec debut (2)',INODE, & PTRFAC(STEP_OOC(INODE)),IDEB_SOLVE_Z(ZONE),ZONE CALL MUMPS_ABORT() ENDIF INODE_TO_POS(STEP_OOC(INODE))=CURRENT_POS_T(ZONE) POS_IN_MEM(CURRENT_POS_T(ZONE))=INODE IF(CURRENT_POS_T(ZONE).GT.(PDEB_SOLVE_Z(ZONE)+ & MAX_NB_NODES_FOR_ZONE-1))THEN WRITE(*,*)MYID_OOC,': Internal error (21) in OOC ', & ' Problem with CURRENT_POS_T', & CURRENT_POS_T(ZONE),ZONE CALL MUMPS_ABORT() ENDIF CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)+1 POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) END SUBROUTINE SMUMPS_SOLVE_ALLOC_PTR_UPD_T SUBROUTINE SMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8, & A,ZONE) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) REAL A(FACT_AREA_SIZE) INTEGER ZONE IF(POS_HOLE_B(ZONE).EQ.-9999)THEN WRITE(*,*)MYID_OOC,': Internal error (22) in OOC ', & ' SMUMPS_SOLVE_ALLOC_PTR_UPD_B' CALL MUMPS_ABORT() ENDIF LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(INODE))=IDEB_SOLVE_Z(ZONE)+ & LRLU_SOLVE_B(ZONE) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (23) in OOC ', & PTRFAC(STEP_OOC(INODE)),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF INODE_TO_POS(STEP_OOC(INODE))=CURRENT_POS_B(ZONE) IF(CURRENT_POS_B(ZONE).EQ.0)THEN WRITE(*,*)MYID_OOC,': Internal error (23b) in OOC ' CALL MUMPS_ABORT() ENDIF POS_IN_MEM(CURRENT_POS_B(ZONE))=INODE CURRENT_POS_B(ZONE)=CURRENT_POS_B(ZONE)-1 POS_HOLE_B(ZONE)=CURRENT_POS_B(ZONE) END SUBROUTINE SMUMPS_SOLVE_ALLOC_PTR_UPD_B SUBROUTINE SMUMPS_FREE_SPACE_FOR_SOLVE(A,LA,REQUESTED_SIZE,PTRFAC, & NSTEPS,ZONE,IERR) IMPLICIT NONE INTEGER(8) :: LA, REQUESTED_SIZE INTEGER NSTEPS,ZONE INTEGER, intent(out) :: IERR INTEGER(8) :: PTRFAC(NSTEPS) REAL A(LA) INTEGER (8) :: APOS_FIRST_FREE, & SIZE_HOLE, & FREE_HOLE, & FREE_HOLE_POS INTEGER J,I,TMP_NODE, NB_FREE, IPOS_FIRST_FREE INTEGER(8) :: K8, AREA_POINTER INTEGER FREE_HOLE_FLAG IERR=0 IF(LRLU_SOLVE_T(ZONE).EQ.SIZE_SOLVE_Z(ZONE))THEN RETURN ENDIF AREA_POINTER=IDEB_SOLVE_Z(ZONE) SIZE_HOLE=0_8 DO I=PDEB_SOLVE_Z(ZONE),CURRENT_POS_T(ZONE)-1 IF((POS_IN_MEM(I).LE.0).AND. & (POS_IN_MEM(I).GT.-((N_OOC+1)*NB_Z))) GOTO 666 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.((N_OOC+1)*NB_Z))THEN TMP_NODE=TMP_NODE-((N_OOC+1)*NB_Z) ENDIF AREA_POINTER=AREA_POINTER+ & abs(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ENDDO 666 CONTINUE IF((I.EQ.CURRENT_POS_T(ZONE)-1).AND. & (PDEB_SOLVE_Z(ZONE).NE.CURRENT_POS_T(ZONE)-1))THEN IF((POS_IN_MEM(I).GT.0).OR. & (POS_IN_MEM(I).LT.-((N_OOC+1)*NB_Z)))THEN WRITE(*,*)MYID_OOC,': Internal error (25) in OOC ', & ': There are no free blocks ', & 'in SMUMPS_FREE_SPACE_FOR_SOLVE',PDEB_SOLVE_Z(ZONE), & CURRENT_POS_T(ZONE) CALL MUMPS_ABORT() ENDIF ENDIF IF(POS_IN_MEM(I).EQ.0)THEN APOS_FIRST_FREE=AREA_POINTER FREE_HOLE_POS=AREA_POINTER ELSE TMP_NODE=abs(POS_IN_MEM(I)) APOS_FIRST_FREE=abs(PTRFAC(STEP_OOC(TMP_NODE))) ENDIF IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).NE.0)THEN IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=abs(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)))- & ((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL SMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) ELSE TMP_NODE=abs(POS_IN_MEM(PDEB_SOLVE_Z(ZONE))) ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).NE.IDEB_SOLVE_Z(ZONE))THEN IF((POS_IN_MEM(I).NE.0).OR.(I.EQ.CURRENT_POS_T(ZONE)))THEN SIZE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & IDEB_SOLVE_Z(ZONE) ENDIF APOS_FIRST_FREE=IDEB_SOLVE_Z(ZONE) IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).GT.0)THEN DO J=PDEB_SOLVE_Z(ZONE),I-1 TMP_NODE=POS_IN_MEM(J) IF(TMP_NODE.LE.0)THEN IF(TMP_NODE.LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=abs(POS_IN_MEM(J))-((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST( & IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL SMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=POS_IN_MEM(J) ELSE WRITE(*,*)MYID_OOC,': Internal error (26) in OOC ', & ' SMUMPS_FREE_SPACE_FOR_SOLVE',TMP_NODE, & J,I-1,(N_OOC+1)*NB_Z CALL MUMPS_ABORT() ENDIF ENDIF DO K8=1_8, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) A(APOS_FIRST_FREE+K8-1_8)= & A(PTRFAC(STEP_OOC(TMP_NODE))+K8-1_8) ENDDO PTRFAC(STEP_OOC(TMP_NODE))=APOS_FIRST_FREE APOS_FIRST_FREE=APOS_FIRST_FREE+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) ENDDO ENDIF ENDIF ENDIF NB_FREE=0 FREE_HOLE=0_8 FREE_HOLE_FLAG=0 DO J=I,CURRENT_POS_T(ZONE)-1 TMP_NODE=abs(POS_IN_MEM(J)) IF(POS_IN_MEM(J).LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=TMP_NODE-((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL SMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=abs(POS_IN_MEM(J)) ENDIF IF(POS_IN_MEM(J).GT.0)THEN DO K8=1_8,SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) A(APOS_FIRST_FREE+K8-1_8)= & A(PTRFAC(STEP_OOC(TMP_NODE))+K8-1_8) ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(TMP_NODE))=APOS_FIRST_FREE APOS_FIRST_FREE=APOS_FIRST_FREE+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(J).EQ.0)THEN FREE_HOLE_FLAG=1 NB_FREE=NB_FREE+1 ELSE NB_FREE=NB_FREE+1 IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) SIZE_HOLE=SIZE_HOLE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) PTRFAC(STEP_OOC(abs(POS_IN_MEM(J))))=-77777_8 ENDIF ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF IPOS_FIRST_FREE=I DO J=I,CURRENT_POS_T(ZONE)-1 IF(POS_IN_MEM(J).LT.0)THEN TMP_NODE=abs(POS_IN_MEM(J)) INODE_TO_POS(STEP_OOC(TMP_NODE))=0 POS_IN_MEM(J)=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED ELSEIF(POS_IN_MEM(J).GT.0)THEN TMP_NODE=abs(POS_IN_MEM(J)) POS_IN_MEM(IPOS_FIRST_FREE)=POS_IN_MEM(J) INODE_TO_POS(STEP_OOC(TMP_NODE))=IPOS_FIRST_FREE IPOS_FIRST_FREE=IPOS_FIRST_FREE+1 ENDIF ENDDO LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)+SIZE_HOLE POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)-SIZE_HOLE CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)-NB_FREE POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 IF(LRLU_SOLVE_T(ZONE).NE.LRLUS_SOLVE(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (27) in OOC ', & LRLU_SOLVE_T(ZONE), & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF LRLU_SOLVE_T(ZONE)=LRLUS_SOLVE(ZONE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (28) in OOC ', & ' LRLUS_SOLVE must be (4) > 0' CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (29) in OOC ', & POSFAC_SOLVE(ZONE),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).NE.(IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)- & LRLUS_SOLVE(ZONE)))THEN WRITE(*,*)MYID_OOC,': Internal error (30) in OOC ', & ' Problem avec debut POSFAC_SOLVE', & POSFAC_SOLVE(ZONE),(SIZE_SOLVE_Z(ZONE)- & LRLUS_SOLVE(ZONE))+IDEB_SOLVE_Z(ZONE),LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).GT. & (IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)-1_8))THEN WRITE(*,*)MYID_OOC,': Internal error (31) in OOC ', & POSFAC_SOLVE(ZONE),IDEB_SOLVE_Z(ZONE)+ & SIZE_SOLVE_Z(ZONE)-1_8 CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE SMUMPS_FREE_SPACE_FOR_SOLVE SUBROUTINE SMUMPS_OOC_UPDATE_SOLVE_STAT(INODE,PTRFAC,NSTEPS,FLAG) IMPLICIT NONE INTEGER INODE,NSTEPS,FLAG INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZONE IF((FLAG.LT.0).OR.(FLAG.GT.1))THEN WRITE(*,*)MYID_OOC,': Internal error (32) in OOC ', & ' SMUMPS_OOC_UPDATE_SOLVE_STAT' CALL MUMPS_ABORT() ENDIF CALL SMUMPS_SEARCH_SOLVE(PTRFAC(STEP_OOC(INODE)),ZONE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (33) in OOC ', & ' LRLUS_SOLVE must be (5) ++ > 0' CALL MUMPS_ABORT() ENDIF IF(FLAG.EQ.0)THEN LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ELSE LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ENDIF IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (34) in OOC ', & ' LRLUS_SOLVE must be (5) > 0' CALL MUMPS_ABORT() ENDIF END SUBROUTINE SMUMPS_OOC_UPDATE_SOLVE_STAT SUBROUTINE SMUMPS_SEARCH_SOLVE(ADDR,ZONE) IMPLICIT NONE INTEGER (8) :: ADDR INTEGER ZONE INTEGER I I=1 DO WHILE (I.LE.NB_Z) IF(ADDR.LT.IDEB_SOLVE_Z(I))THEN EXIT ENDIF I=I+1 ENDDO ZONE=I-1 END SUBROUTINE SMUMPS_SEARCH_SOLVE FUNCTION SMUMPS_SOLVE_IS_END_REACHED() IMPLICIT NONE LOGICAL SMUMPS_SOLVE_IS_END_REACHED SMUMPS_SOLVE_IS_END_REACHED=.FALSE. IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN SMUMPS_SOLVE_IS_END_REACHED=.TRUE. ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.LT.1)THEN SMUMPS_SOLVE_IS_END_REACHED=.TRUE. ENDIF ENDIF RETURN END FUNCTION SMUMPS_SOLVE_IS_END_REACHED SUBROUTINE SMUMPS_SOLVE_ZONE_READ(ZONE,A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE INTEGER(8), INTENT(IN) :: LA INTEGER, intent(out) :: IERR REAL A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: SIZE, DEST INTEGER(8) :: NEEDED_SIZE INTEGER FLAG,TMP_FLAG,POS_SEQ,TMP_NODE, & NB_NODES IERR=0 TMP_FLAG=0 FLAG=0 IF(SMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE).GT. & SIZE_SOLVE_Z(ZONE)) CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 IF(SMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL SMUMPS_OOC_SKIP_NULL_SIZE_NODE() NEEDED_SIZE=max(MIN_SIZE_READ, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE NEEDED_SIZE=MIN_SIZE_READ ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.GE.1)THEN TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE).GT. & SIZE_SOLVE_Z(ZONE)) CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 IF(SMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL SMUMPS_OOC_SKIP_NULL_SIZE_NODE() NEEDED_SIZE=max(MIN_SIZE_READ, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE NEEDED_SIZE=MIN_SIZE_READ ENDIF ENDIF IF(LRLUS_SOLVE(ZONE).LT.NEEDED_SIZE)THEN RETURN ELSEIF((LRLU_SOLVE_T(ZONE).LT.NEEDED_SIZE).AND. & (LRLU_SOLVE_B(ZONE).LT.NEEDED_SIZE).AND. & (dble(LRLUS_SOLVE(ZONE)).LT.0.3d0* & dble(SIZE_SOLVE_Z(ZONE)))) THEN RETURN ENDIF IF((LRLU_SOLVE_T(ZONE).GT.NEEDED_SIZE).AND.(SOLVE_STEP.EQ.0).AND. & ((CURRENT_POS_T(ZONE)-PDEB_SOLVE_Z(ZONE)+1).LT. & MAX_NB_NODES_FOR_ZONE))THEN FLAG=1 ELSE IF(SOLVE_STEP.EQ.0)THEN CALL SMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 IF(TMP_FLAG.EQ.0)THEN CALL SMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=0 ENDIF ELSE CALL SMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=0 IF(TMP_FLAG.EQ.0)THEN CALL SMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF IF(TMP_FLAG.EQ.0)THEN CALL SMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF CALL SMUMPS_SOLVE_COMPUTE_READ_SIZE(ZONE,SIZE,DEST,POS_SEQ, & NB_NODES,FLAG,PTRFAC,NSTEPS) IF(SIZE.EQ.0_8)THEN RETURN ENDIF NB_ZONE_REQ=NB_ZONE_REQ+1 SIZE_ZONE_REQ=SIZE_ZONE_REQ+SIZE REQ_ACT=REQ_ACT+1 CALL SMUMPS_READ_SOLVE_BLOCK(A(DEST),DEST,SIZE,ZONE,PTRFAC,NSTEPS, & POS_SEQ,NB_NODES,FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END SUBROUTINE SMUMPS_SOLVE_ZONE_READ SUBROUTINE SMUMPS_SOLVE_COMPUTE_READ_SIZE(ZONE,SIZE,DEST,POS_SEQ, & NB_NODES,FLAG,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER(8) :: SIZE, DEST INTEGER ZONE,FLAG,POS_SEQ,NSTEPS INTEGER(8) :: PTRFAC(NSTEPS), MAX_SIZE, LAST, J8 INTEGER I,START_NODE,K,MAX_NB, & NB_NODES INTEGER NB_NODES_LOC LOGICAL ALREADY IF(SMUMPS_SOLVE_IS_END_REACHED())THEN SIZE=0_8 RETURN ENDIF IF(FLAG.EQ.0)THEN MAX_SIZE=LRLU_SOLVE_B(ZONE) MAX_NB=max(0,CURRENT_POS_B(ZONE)-PDEB_SOLVE_Z(ZONE)+1) ELSEIF(FLAG.EQ.1)THEN MAX_SIZE=LRLU_SOLVE_T(ZONE) MAX_NB=MAX_NB_NODES_FOR_ZONE ELSE WRITE(*,*)MYID_OOC,': Internal error (35) in OOC ', & ' Unknown Flag value in ', & ' SMUMPS_SOLVE_COMPUTE_READ_SIZE',FLAG CALL MUMPS_ABORT() ENDIF CALL SMUMPS_OOC_SKIP_NULL_SIZE_NODE() I=CUR_POS_SEQUENCE START_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ALREADY=.FALSE. NB_NODES=0 NB_NODES_LOC=0 IF(ZONE.EQ.NB_Z)THEN SIZE=SIZE_OF_BLOCK(STEP_OOC(START_NODE),OOC_FCT_TYPE) ELSE J8=0_8 IF(FLAG.EQ.0)THEN K=0 ELSEIF(FLAG.EQ.1)THEN K=CURRENT_POS_T(ZONE)-PDEB_SOLVE_Z(ZONE)+1 ENDIF IF(SOLVE_STEP.EQ.0)THEN I=CUR_POS_SEQUENCE DO WHILE(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) IF(SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF I=I+1 ENDDO CUR_POS_SEQUENCE=min(I,TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) I=CUR_POS_SEQUENCE DO WHILE((J8.LE.MAX_SIZE).AND. & (I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)).AND. & (K.LT.MAX_NB) ) LAST=SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ENDIF I=I+1 NB_NODES_LOC=NB_NODES_LOC+1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))) & .NE.0).OR. & (IO_REQ(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))).GE. & 0))THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 I=I+1 CYCLE ELSE EXIT ENDIF ENDIF ALREADY=.TRUE. J8=J8+LAST I=I+1 K=K+1 NB_NODES_LOC=NB_NODES_LOC+1 NB_NODES=NB_NODES+1 ENDDO IF(J8.GT.MAX_SIZE)THEN SIZE=J8-LAST NB_NODES=NB_NODES-1 NB_NODES_LOC=NB_NODES_LOC-1 ELSE SIZE=J8 ENDIF DO WHILE (CUR_POS_SEQUENCE+NB_NODES_LOC-1.GE. & CUR_POS_SEQUENCE) IF(SIZE_OF_BLOCK(STEP_OOC( & OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE+NB_NODES-1, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF NB_NODES_LOC=NB_NODES_LOC-1 ENDDO POS_SEQ=CUR_POS_SEQUENCE ELSEIF(SOLVE_STEP.EQ.1)THEN DO WHILE(I.GE.1) IF(SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF I=I-1 ENDDO CUR_POS_SEQUENCE=max(I,1) I=CUR_POS_SEQUENCE DO WHILE((J8.LE.MAX_SIZE).AND.(I.GE.1).AND. & (K.LT.MAX_NB)) LAST=SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF NB_NODES_LOC=NB_NODES_LOC+1 I=I-1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))) & .NE.0).OR. & (IO_REQ(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))).GE. & 0))THEN IF(.NOT.ALREADY)THEN I=I-1 CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 CYCLE ELSE EXIT ENDIF ENDIF ALREADY=.TRUE. J8=J8+LAST I=I-1 K=K+1 NB_NODES=NB_NODES+1 NB_NODES_LOC=NB_NODES_LOC+1 ENDDO IF(J8.GT.MAX_SIZE)THEN SIZE=J8-LAST NB_NODES=NB_NODES-1 NB_NODES_LOC=NB_NODES_LOC-1 ELSE SIZE=J8 ENDIF I=CUR_POS_SEQUENCE-NB_NODES_LOC+1 DO WHILE (I.LE.CUR_POS_SEQUENCE) IF(SIZE_OF_BLOCK(STEP_OOC( & OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE)), & OOC_FCT_TYPE).NE.0_8)THEN EXIT ENDIF I=I+1 NB_NODES_LOC=NB_NODES_LOC-1 ENDDO POS_SEQ=CUR_POS_SEQUENCE-NB_NODES_LOC+1 ENDIF ENDIF IF(FLAG.EQ.0)THEN DEST=IDEB_SOLVE_Z(ZONE)+LRLU_SOLVE_B(ZONE)-SIZE ELSE DEST=POSFAC_SOLVE(ZONE) ENDIF END SUBROUTINE SMUMPS_SOLVE_COMPUTE_READ_SIZE SUBROUTINE SMUMPS_OOC_END_SOLVE(IERR) IMPLICIT NONE INTEGER SOLVE_OR_FACTO INTEGER, intent(out) :: IERR IERR=0 IF(allocated(LRLUS_SOLVE))THEN DEALLOCATE(LRLUS_SOLVE) ENDIF IF(allocated(LRLU_SOLVE_T))THEN DEALLOCATE(LRLU_SOLVE_T) ENDIF IF(allocated(LRLU_SOLVE_B))THEN DEALLOCATE(LRLU_SOLVE_B) ENDIF IF(allocated(POSFAC_SOLVE))THEN DEALLOCATE(POSFAC_SOLVE) ENDIF IF(allocated(IDEB_SOLVE_Z))THEN DEALLOCATE(IDEB_SOLVE_Z) ENDIF IF(allocated(PDEB_SOLVE_Z))THEN DEALLOCATE(PDEB_SOLVE_Z) ENDIF IF(allocated(SIZE_SOLVE_Z))THEN DEALLOCATE(SIZE_SOLVE_Z) ENDIF IF(allocated(CURRENT_POS_T))THEN DEALLOCATE(CURRENT_POS_T) ENDIF IF(allocated(CURRENT_POS_B))THEN DEALLOCATE(CURRENT_POS_B) ENDIF IF(allocated(POS_HOLE_T))THEN DEALLOCATE(POS_HOLE_T) ENDIF IF(allocated(POS_HOLE_B))THEN DEALLOCATE(POS_HOLE_B) ENDIF IF(allocated(OOC_STATE_NODE))THEN DEALLOCATE(OOC_STATE_NODE) ENDIF IF(allocated(POS_IN_MEM))THEN DEALLOCATE(POS_IN_MEM) ENDIF IF(allocated(INODE_TO_POS))THEN DEALLOCATE(INODE_TO_POS) ENDIF IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(allocated(SIZE_OF_READ))THEN DEALLOCATE(SIZE_OF_READ) ENDIF IF(allocated(FIRST_POS_IN_READ))THEN DEALLOCATE(FIRST_POS_IN_READ) ENDIF IF(allocated(READ_DEST))THEN DEALLOCATE(READ_DEST) ENDIF IF(allocated(READ_MNG))THEN DEALLOCATE(READ_MNG) ENDIF IF(allocated(REQ_TO_ZONE))THEN DEALLOCATE(REQ_TO_ZONE) ENDIF IF(allocated(REQ_ID))THEN DEALLOCATE(REQ_ID) ENDIF SOLVE_OR_FACTO=1 CALL MUMPS_CLEAN_IO_DATA_C(MYID_OOC,SOLVE_OR_FACTO,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF END SUBROUTINE SMUMPS_OOC_END_SOLVE SUBROUTINE SMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS, & A,LA) IMPLICIT NONE INTEGER, INTENT(in) :: NSTEPS INTEGER(8), INTENT(INOUT) :: PTRFAC(NSTEPS) INTEGER(8), INTENT(IN) :: LA REAL :: A(LA) INTEGER :: I, TMP, ZONE, IPAS, IBEG, IEND INTEGER(8) :: SAVE_PTR LOGICAL :: COMPRESS_TO_BE_DONE, SET_POS_SEQUENCE INTEGER :: J, IERR INTEGER(8) :: DUMMY_SIZE COMPRESS_TO_BE_DONE = .FALSE. DUMMY_SIZE = 1_8 IERR = 0 SET_POS_SEQUENCE = .TRUE. IF(SOLVE_STEP.EQ.0)THEN IBEG = 1 IEND = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) IPAS = 1 ELSE IBEG = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) IEND = 1 IPAS = -1 ENDIF DO I=IBEG,IEND,IPAS J = OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) TMP=INODE_TO_POS(STEP_OOC(J)) IF(TMP.EQ.0)THEN IF (SET_POS_SEQUENCE) THEN SET_POS_SEQUENCE = .FALSE. CUR_POS_SEQUENCE = I ENDIF IF (KEEP_OOC(237).EQ.0 .AND. KEEP_OOC(235).EQ.0 & .AND. KEEP_OOC(212).EQ.0 ) THEN OOC_STATE_NODE(STEP_OOC(J)) = NOT_IN_MEM ENDIF CYCLE ELSE IF(TMP.LT.0)THEN IF(TMP.GT.-(N_OOC+1)*NB_Z)THEN SAVE_PTR=PTRFAC(STEP_OOC(J)) PTRFAC(STEP_OOC(J)) = abs(SAVE_PTR) CALL SMUMPS_SOLVE_FIND_ZONE(J, & ZONE,PTRFAC,NSTEPS) PTRFAC(STEP_OOC(J)) = SAVE_PTR IF(ZONE.EQ.NB_Z)THEN IF(J.NE.SPECIAL_ROOT_NODE)THEN WRITE(*,*)MYID_OOC,': Internal error 6 ', & ' Node ', J, & ' is in status USED in the & emmergency buffer ' CALL MUMPS_ABORT() ENDIF ENDIF IF (KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0 & .OR. KEEP_OOC(212).NE.0 ) & THEN IF (OOC_STATE_NODE(STEP_OOC(J)).EQ.NOT_IN_MEM) THEN OOC_STATE_NODE(STEP_OOC(J)) = USED IF((SOLVE_STEP.NE.0).AND.(J.NE.SPECIAL_ROOT_NODE) & .AND.(ZONE.NE.NB_Z))THEN CALL SMUMPS_SOLVE_UPD_NODE_INFO(J,PTRFAC,NSTEPS) ENDIF CYCLE ELSEIF(OOC_STATE_NODE(STEP_OOC(J)).EQ.USED) & THEN COMPRESS_TO_BE_DONE = .TRUE. ELSE WRITE(*,*)MYID_OOC,': Internal error Mila 4 ', & ' wrong node status :', OOC_STATE_NODE(STEP_OOC(J)), & ' on node ', J CALL MUMPS_ABORT() ENDIF ENDIF IF (KEEP_OOC(237).EQ.0 .AND. KEEP_OOC(235).EQ.0 & .AND. KEEP_OOC(212).EQ.0 ) THEN CALL SMUMPS_SOLVE_UPD_NODE_INFO(J,PTRFAC,NSTEPS) ENDIF ENDIF ENDIF ENDDO IF (KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0 .OR. & KEEP_OOC(212).NE.0 ) & THEN IF (COMPRESS_TO_BE_DONE) THEN DO ZONE=1,NB_Z-1 CALL SMUMPS_FREE_SPACE_FOR_SOLVE(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,ZONE,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error Mila 5 ', & ' IERR on return to SMUMPS_FREE_SPACE_FOR_SOLVE =', & IERR CALL MUMPS_ABORT() ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SOLVE_PREPARE_PREF SUBROUTINE SMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,NSTEPS,MTYPE, & A,LA,DOPREFETCH,IERR) IMPLICIT NONE INTEGER NSTEPS,MTYPE INTEGER, intent(out)::IERR INTEGER(8) :: LA REAL A(LA) INTEGER(8) :: PTRFAC(NSTEPS) LOGICAL DOPREFETCH INTEGER MUMPS_OOC_GET_FCT_TYPE EXTERNAL MUMPS_OOC_GET_FCT_TYPE IERR = 0 OOC_FCT_TYPE=MUMPS_OOC_GET_FCT_TYPE("F",MTYPE,KEEP_OOC(201), & KEEP_OOC(50)) OOC_SOLVE_TYPE_FCT = OOC_FCT_TYPE - 1 IF (KEEP_OOC(201).NE.1) THEN OOC_SOLVE_TYPE_FCT = FCT ENDIF SOLVE_STEP=0 CUR_POS_SEQUENCE=1 MTYPE_OOC=MTYPE IF ( KEEP_OOC(201).NE.1 & .OR. KEEP_OOC(50).NE.0 & ) THEN CALL SMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS,A,LA) ELSE CALL SMUMPS_SOLVE_STAT_REINIT_PANEL(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) ENDIF IF (DOPREFETCH) THEN CALL SMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC, & KEEP_OOC(28),IERR) ELSE CUR_POS_SEQUENCE = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) ENDIF RETURN END SUBROUTINE SMUMPS_SOLVE_INIT_OOC_FWD SUBROUTINE SMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,NSTEPS,MTYPE, & I_WORKED_ON_ROOT,IROOT,A,LA,IERR) IMPLICIT NONE INTEGER NSTEPS INTEGER(8) :: LA INTEGER(8) :: PTRFAC(NSTEPS) INTEGER MTYPE INTEGER IROOT LOGICAL I_WORKED_ON_ROOT INTEGER, intent(out):: IERR REAL A(LA) INTEGER(8) :: DUMMY_SIZE INTEGER ZONE INTEGER MUMPS_OOC_GET_FCT_TYPE EXTERNAL MUMPS_OOC_GET_FCT_TYPE IERR=0 OOC_FCT_TYPE=MUMPS_OOC_GET_FCT_TYPE("B",MTYPE,KEEP_OOC(201), & KEEP_OOC(50)) OOC_SOLVE_TYPE_FCT = OOC_FCT_TYPE - 1 IF (KEEP_OOC(201).NE.1) OOC_SOLVE_TYPE_FCT=FCT SOLVE_STEP=1 CUR_POS_SEQUENCE=TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) MTYPE_OOC=MTYPE IF ( KEEP_OOC(201).NE.1 & .OR. KEEP_OOC(50).NE.0 & ) THEN CALL SMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS,A,LA) IF (I_WORKED_ON_ROOT.AND. $ ((IROOT.GT.0)))THEN IF(SIZE_OF_BLOCK(STEP_OOC(IROOT),OOC_FCT_TYPE).NE.0) THEN IF (.NOT.(KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0)) & THEN CALL SMUMPS_FREE_FACTORS_FOR_SOLVE ( IROOT, & PTRFAC, KEEP_OOC(28), A, LA,.FALSE.,IERR) IF (IERR .LT. 0) RETURN ENDIF CALL SMUMPS_SOLVE_FIND_ZONE(IROOT, & ZONE,PTRFAC,NSTEPS) IF(ZONE.EQ.NB_Z)THEN DUMMY_SIZE=1_8 CALL SMUMPS_FREE_SPACE_FOR_SOLVE(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,NB_Z,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error in & SMUMPS_FREE_SPACE_FOR_SOLVE', & IERR CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ENDIF IF (NB_Z.GT.1) THEN CALL SMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC, & KEEP_OOC(28),IERR) IF (IERR .LT. 0) RETURN ENDIF ELSE CALL SMUMPS_SOLVE_STAT_REINIT_PANEL(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) CALL SMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC,KEEP_OOC(28),IERR) IF (IERR .LT. 0 ) RETURN ENDIF RETURN END SUBROUTINE SMUMPS_SOLVE_INIT_OOC_BWD SUBROUTINE SMUMPS_STRUC_STORE_FILE_NAME(idOOC_NB_FILES, & idOOC_FILE_NAMES, idOOC_FILE_NAME_LENGTH, idINFO, IERR) IMPLICIT NONE INTEGER,DIMENSION(:), POINTER :: idOOC_NB_FILES CHARACTER,DIMENSION(:,:), POINTER :: idOOC_FILE_NAMES INTEGER,DIMENSION(:), POINTER :: idOOC_FILE_NAME_LENGTH INTEGER :: idINFO(2) INTEGER, intent(out) :: IERR INTEGER I,DIM,J,TMP,SIZE,K,I1 CHARACTER(len=1):: TMP_NAME(FILENAMELENGTH) 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) idOOC_NB_FILES(J)=I SIZE=SIZE+I ENDDO IF(associated(idOOC_FILE_NAMES))THEN DEALLOCATE(idOOC_FILE_NAMES) NULLIFY(idOOC_FILE_NAMES) ENDIF ALLOCATE(idOOC_FILE_NAMES(SIZE,FILENAMELENGTH),stat=IERR) IF (IERR .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'SMUMPS_STRUC_STORE_FILE_NAME' ENDIF IERR=-1 IF(idINFO(1).GE.0)THEN idINFO(1) = -13 idINFO(2) = SIZE*FILENAMELENGTH RETURN ENDIF ENDIF IF(associated(idOOC_FILE_NAME_LENGTH))THEN DEALLOCATE(idOOC_FILE_NAME_LENGTH) NULLIFY(idOOC_FILE_NAME_LENGTH) ENDIF ALLOCATE(idOOC_FILE_NAME_LENGTH(SIZE),stat=IERR) IF (IERR .GT. 0) THEN IERR=-1 IF(idINFO(1).GE.0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) & 'PB allocation in SMUMPS_STRUC_STORE_FILE_NAME' ENDIF idINFO(1) = -13 idINFO(2) = SIZE RETURN ENDIF ENDIF K=1 DO I1=1,OOC_NB_FILE_TYPE TMP=I1-1 DO I=1,idOOC_NB_FILES(I1) CALL MUMPS_OOC_GET_FILE_NAME_C(TMP,I,DIM,TMP_NAME(1)) DO J=1,DIM+1 idOOC_FILE_NAMES(K,J)=TMP_NAME(J) ENDDO idOOC_FILE_NAME_LENGTH(K)=DIM+1 K=K+1 ENDDO ENDDO RETURN END SUBROUTINE SMUMPS_STRUC_STORE_FILE_NAME SUBROUTINE SMUMPS_OOC_OPEN_FILES_FOR_SOLVE(idINFO, idOOC_NB_FILES, & idMYID, idKEEP, idOOC_FILE_NAME_LENGTH, & idOOC_FILE_NAMES) IMPLICIT NONE INTEGER :: idINFO(2), idMYID INTEGER, DIMENSION(:), POINTER :: idOOC_NB_FILES INTEGER, DIMENSION(:), POINTER :: idOOC_FILE_NAME_LENGTH CHARACTER,DIMENSION(:,:), POINTER :: idOOC_FILE_NAMES INTEGER :: idKEEP(500) CHARACTER(len=1):: TMP_NAME(FILENAMELENGTH) INTEGER I,I1,TMP,J,K,L,DIM,IERR INTEGER, DIMENSION(:),ALLOCATABLE :: NB_FILES ALLOCATE(NB_FILES(OOC_NB_FILE_TYPE),stat=IERR) IF (IERR .GT. 0) THEN IERR=-1 IF(idINFO(1).GE.0)THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) & 'PB allocation in SMUMPS_OOC_OPEN_FILES_FOR_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF ENDIF IERR=0 NB_FILES=idOOC_NB_FILES I=idMYID K=idKEEP(35) L=mod(idKEEP(204),3) 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) idINFO(1)=IERR RETURN ENDIF CALL MUMPS_OOC_INIT_VARS_C(I,K,L,idKEEP(211),idKEEP(255),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) idINFO(1)=IERR RETURN ENDIF K=1 DO I1=1,OOC_NB_FILE_TYPE DO I=1,NB_FILES(I1) DIM=idOOC_FILE_NAME_LENGTH(K) DO J=1,DIM TMP_NAME(J)=idOOC_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) idINFO(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) idINFO(1)=IERR RETURN ENDIF DEALLOCATE(NB_FILES) RETURN END SUBROUTINE SMUMPS_OOC_OPEN_FILES_FOR_SOLVE SUBROUTINE SMUMPS_FORCE_WRITE_BUF(IERR) USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF CALL SMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF (IERR < 0) THEN RETURN ENDIF RETURN END SUBROUTINE SMUMPS_FORCE_WRITE_BUF SUBROUTINE SMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR INTEGER I IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF DO I=1,OOC_NB_FILE_TYPE CALL SMUMPS_OOC_DO_IO_AND_CHBUF(I,IERR) IF (IERR < 0) RETURN ENDDO RETURN END SUBROUTINE SMUMPS_OOC_FORCE_WRT_BUF_PANEL SUBROUTINE SMUMPS_SOLVE_STAT_REINIT_PANEL(NSTEPS, & KEEP38, KEEP20) IMPLICIT NONE INTEGER NSTEPS INTEGER I, J INTEGER(8) :: TMP_SIZE8 INTEGER KEEP38, KEEP20 INODE_TO_POS = 0 POS_IN_MEM = 0 OOC_STATE_NODE(1:NSTEPS)=0 TMP_SIZE8=1_8 J=1 DO I=1,NB_Z-1 IDEB_SOLVE_Z(I)=TMP_SIZE8 PDEB_SOLVE_Z(I)=J POSFAC_SOLVE(I)=TMP_SIZE8 LRLUS_SOLVE(I) =SIZE_ZONE_SOLVE LRLU_SOLVE_T(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_B(I)=0_8 SIZE_SOLVE_Z(I)=SIZE_ZONE_SOLVE CURRENT_POS_T(I)=J CURRENT_POS_B(I)=J POS_HOLE_T(I) =J POS_HOLE_B(I) =J J = J + MAX_NB_NODES_FOR_ZONE TMP_SIZE8 = TMP_SIZE8 + SIZE_ZONE_SOLVE ENDDO IDEB_SOLVE_Z(NB_Z)=TMP_SIZE8 PDEB_SOLVE_Z(NB_Z)=J POSFAC_SOLVE(NB_Z)=TMP_SIZE8 LRLUS_SOLVE(NB_Z) =SIZE_SOLVE_EMM LRLU_SOLVE_T(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_B(NB_Z)=0_8 SIZE_SOLVE_Z(NB_Z)=SIZE_SOLVE_EMM CURRENT_POS_T(NB_Z)=J CURRENT_POS_B(NB_Z)=J POS_HOLE_T(NB_Z) =J POS_HOLE_B(NB_Z) =J IO_REQ=-77777 SIZE_OF_READ=-9999_8 FIRST_POS_IN_READ=-9999 READ_DEST=-9999_8 READ_MNG=-9999 REQ_TO_ZONE=-9999 REQ_ID=-9999 RETURN END SUBROUTINE SMUMPS_SOLVE_STAT_REINIT_PANEL SUBROUTINE SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) IMPLICIT NONE TYPE(IO_BLOCK), INTENT(INOUT):: MonBloc INTEGER(8) :: LAFAC INTEGER, INTENT(IN) :: STRAT, LIWFAC, & MYID, TYPEFile INTEGER, INTENT(INOUT) :: IW(0:LIWFAC-1) REAL, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LNextPiv2beWritten, & UNextPiv2beWritten INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL INTEGER(8) :: TMPSIZE_OF_BLOCK INTEGER :: TempFTYPE LOGICAL WRITE_L, WRITE_U LOGICAL DO_U_FIRST INCLUDE 'mumps_headers.h' IERR = 0 IF (KEEP_OOC(50).EQ.0 & .AND.KEEP_OOC(251).EQ.2) THEN WRITE_L = .FALSE. ELSE WRITE_L = (TYPEFile.EQ.TYPEF_BOTH_LU .OR. TYPEFile.EQ.TYPEF_L) ENDIF WRITE_U = (TYPEFile.EQ.TYPEF_BOTH_LU .OR. TYPEFile.EQ.TYPEF_U) #if defined(_OPENMP) IF (KEEP_OOC(400).GT.0 .AND. KEEP_OOC(405) .GT. 0) THEN IF ( STRAT .EQ. STRAT_WRITE_MAX .OR. LAST_CALL ) THEN CALL OMP_SET_LOCK(LOCK_FOR_L0OMP) #if defined(_WIN32) ELSE #else ELSE IF ( .NOT. OMP_TEST_LOCK(LOCK_FOR_L0OMP )) THEN #endif RETURN ENDIF ENDIF #endif DO_U_FIRST = .FALSE. IF ( TYPEFile.EQ.TYPEF_BOTH_LU ) THEN IF ( LNextPiv2beWritten .GT. UNextPiv2beWritten ) THEN DO_U_FIRST = .TRUE. END IF END IF IF (DO_U_FIRST) GOTO 200 100 IF (WRITE_L .AND. TYPEF_L > 0 ) THEN TempFTYPE = TYPEF_L IF ((MonBloc%Typenode.EQ.2).AND.(.NOT.MonBloc%MASTER)) & THEN TMPSIZE_OF_BLOCK = SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE), & TempFTYPE) IF (TMPSIZE_OF_BLOCK .LT. 0_8) THEN TMPSIZE_OF_BLOCK = -TMPSIZE_OF_BLOCK - 1_8 ENDIF LNextPiv2beWritten = & int( & TMPSIZE_OF_BLOCK & / int(MonBloc%NROW,8) & ) & + 1 ENDIF CALL SMUMPS_OOC_STORE_LorU( STRAT, & TempFTYPE, AFAC, LAFAC, MonBloc, & IERR, & LNextPiv2beWritten, & OOC_VADDR(STEP_OOC(MonBloc%INODE),TempFTYPE), & SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE),TempFTYPE), & FILESIZE, LAST_CALL ) IF (IERR .LT. 0) GOTO 300 IF (DO_U_FIRST) GOTO 300 ENDIF 200 IF (WRITE_U) THEN TempFTYPE = TYPEF_U CALL SMUMPS_OOC_STORE_LorU( STRAT, & TempFTYPE, AFAC, LAFAC, MonBloc, & IERR, & UNextPiv2beWritten, & OOC_VADDR(STEP_OOC(MonBloc%INODE),TempFTYPE), & SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE),TempFTYPE), & FILESIZE, LAST_CALL) IF (IERR .LT. 0) GOTO 300 IF (DO_U_FIRST) GOTO 100 ENDIF 300 CONTINUE #if defined(_OPENMP) IF (KEEP_OOC(400).GT.0 .AND. KEEP_OOC(405) .GT. 0) THEN CALL OMP_UNSET_LOCK(LOCK_FOR_L0OMP) ENDIF #endif RETURN END SUBROUTINE SMUMPS_OOC_IO_LU_PANEL SUBROUTINE SMUMPS_OOC_STORE_LorU( STRAT, TYPEF, & AFAC, LAFAC, MonBloc, & IERR, & LorU_NextPiv2beWritten, & LorU_AddVirtNodeI8, LorUSIZE_OF_BLOCK, & FILESIZE, LAST_CALL & ) USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, INTENT(IN) :: STRAT INTEGER, INTENT(IN) :: TYPEF INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER(8), INTENT(IN) :: LAFAC REAL, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LorU_NextPiv2beWritten INTEGER(8), INTENT(INOUT) :: LorU_AddVirtNodeI8 INTEGER(8), INTENT(INOUT) :: LorUSIZE_OF_BLOCK TYPE(IO_BLOCK), INTENT(INOUT) :: MonBloc INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL INTEGER NNMAX INTEGER(8) :: TOTSIZE, EFFSIZE INTEGER(8) :: TailleEcrite INTEGER SIZE_PANEL INTEGER(8) :: AddVirtCour LOGICAL VIRT_ADD_RESERVED_BEF_CALL LOGICAL VIRTUAL_ADDRESS_JUST_RESERVED LOGICAL HOLE_PROCESSED_BEFORE_CALL LOGICAL TMP_ESTIM INTEGER ICUR, INODE_CUR INTEGER(8) :: ADDR_LAST IERR = 0 IF (TYPEF == TYPEF_L ) THEN NNMAX = MonBloc%NROW ELSE NNMAX = MonBloc%NCOL ENDIF SIZE_PANEL = SMUMPS_OOC_PANEL_SIZE(NNMAX) IF ( (.NOT.MonBloc%Last) .AND. & (MonBloc%LastPiv-LorU_NextPiv2beWritten+1.LT.SIZE_PANEL)) & THEN RETURN ENDIF TMP_ESTIM = .TRUE. TOTSIZE = SMUMPS_OOC_NBENTRIES_PANEL_123 & (MonBloc%NFS, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) IF (MonBloc%Last) THEN TMP_ESTIM=.FALSE. EFFSIZE = SMUMPS_OOC_NBENTRIES_PANEL_123 & (MonBloc%LastPiv, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) ELSE EFFSIZE = -1034039740327_8 ENDIF IF (MonBloc%Typenode.EQ.3.AND. MonBloc%NFS.NE.MonBloc%NCOL) THEN WRITE(*,*) 'Internal error in SMUMPS_OOC_STORE_LorU for type3', & MonBloc%NFS,MonBloc%NCOL CALL MUMPS_ABORT() ENDIF IF (MonBloc%Typenode.EQ.3.AND. TYPEF.NE.TYPEF_L) THEN WRITE(*,*) 'Internal error in SMUMPS_OOC_STORE_LorU,TYPEF=', & TYPEF, 'for typenode=3' CALL MUMPS_ABORT() ENDIF IF (MonBloc%Typenode.EQ.2.AND. & TYPEF.EQ.TYPEF_U.AND. & .NOT. MonBloc%MASTER ) THEN WRITE(*,*) 'Internal error in SMUMPS_OOC_STORE_LorU', & MonBloc%MASTER,MonBloc%Typenode, TYPEF CALL MUMPS_ABORT() ENDIF HOLE_PROCESSED_BEFORE_CALL = (LorUSIZE_OF_BLOCK .LT. 0_8) IF (HOLE_PROCESSED_BEFORE_CALL.AND.(.NOT.MonBloc%Last)) THEN WRITE(6,*) ' Internal error in SMUMPS_OOC_STORE_LorU ', & ' last is false after earlier calls with last=true' CALL MUMPS_ABORT() ENDIF IF (HOLE_PROCESSED_BEFORE_CALL) THEN LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 TOTSIZE = -99999999_8 ENDIF VIRTUAL_ADDRESS_JUST_RESERVED = .FALSE. VIRT_ADD_RESERVED_BEF_CALL = & ( LorUSIZE_OF_BLOCK .NE. 0_8 .OR. & HOLE_PROCESSED_BEFORE_CALL ) IF (MonBloc%Last .AND. .NOT. HOLE_PROCESSED_BEFORE_CALL) THEN KEEP_OOC(228) = max(KEEP_OOC(228), & (MonBloc%LastPiv+SIZE_PANEL-1) / SIZE_PANEL) IF (VIRT_ADD_RESERVED_BEF_CALL) THEN IF (AddVirtLibre(TYPEF).EQ. & (LorU_AddVirtNodeI8+TOTSIZE) ) THEN AddVirtLibre(TYPEF) = LorU_AddVirtNodeI8 + EFFSIZE ENDIF ELSE VIRTUAL_ADDRESS_JUST_RESERVED = .TRUE. IF (EFFSIZE .EQ. 0_8) THEN LorU_AddVirtNodeI8 = -9999_8 ELSE LorU_AddVirtNodeI8 = AddVirtLibre(TYPEF) ENDIF AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) + EFFSIZE ENDIF ELSE IF (.NOT. VIRT_ADD_RESERVED_BEF_CALL & ) THEN LorU_AddVirtNodeI8 = AddVirtLibre(TYPEF) AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) + TOTSIZE ENDIF ENDIF AddVirtCour = LorU_AddVirtNodeI8 + LorUSIZE_OF_BLOCK CALL SMUMPS_OOC_WRT_IN_PANELS_LorU( STRAT, TYPEF, MonBloc, & SIZE_PANEL, & AFAC, LAFAC, & LorU_NextPiv2beWritten, AddVirtCour, & TailleEcrite, & IERR ) IF ( IERR .LT. 0 ) RETURN LorUSIZE_OF_BLOCK = LorUSIZE_OF_BLOCK + TailleEcrite IF (LorUSIZE_OF_BLOCK.EQ.0_8 ) THEN IF ( .NOT. VIRT_ADD_RESERVED_BEF_CALL & .AND. .NOT. VIRTUAL_ADDRESS_JUST_RESERVED ) & THEN AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) - TOTSIZE LorU_AddVirtNodeI8 = 0_8 ENDIF ELSE IF (.NOT. VIRT_ADD_RESERVED_BEF_CALL ) THEN VIRTUAL_ADDRESS_JUST_RESERVED = .TRUE. ENDIF IF ( VIRTUAL_ADDRESS_JUST_RESERVED) THEN OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(TYPEF), & TYPEF) = MonBloc%INODE I_CUR_HBUF_NEXTPOS(TYPEF) = I_CUR_HBUF_NEXTPOS(TYPEF) + 1 IF (MonBloc%Last) THEN MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,EFFSIZE) TMP_SIZE_FACT=TMP_SIZE_FACT+EFFSIZE ELSE MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,TOTSIZE) TMP_SIZE_FACT=TMP_SIZE_FACT+TOTSIZE ENDIF TMP_NB_NODES=TMP_NB_NODES+1 IF(TMP_SIZE_FACT.GT.SIZE_ZONE_SOLVE)THEN MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE, & TMP_NB_NODES) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 ENDIF ENDIF IF (MonBloc%Last) THEN LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 ENDIF IF (LAST_CALL) THEN IF (.NOT.MonBloc%Last) THEN WRITE(6,*) ' Internal error in SMUMPS_OOC_STORE_LorU ', & ' LAST and LAST_CALL are incompatible ' CALL MUMPS_ABORT() ENDIF LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 ICUR = I_CUR_HBUF_NEXTPOS(TYPEF) - 1 INODE_CUR = OOC_INODE_SEQUENCE(ICUR,TYPEF) ADDR_LAST = AddVirtLibre(TYPEF) IF ( INODE_CUR .NE. MonBloc%INODE .AND. & OOC_VADDR(STEP_OOC(MonBloc%INODE),TYPEF) .NE. -9999 ) THEN 10 CONTINUE IF ( OOC_VADDR(STEP_OOC(INODE_CUR),TYPEF) .NE. -9999_8) THEN ADDR_LAST = OOC_VADDR(STEP_OOC(INODE_CUR), TYPEF) ENDIF ICUR = ICUR - 1 INODE_CUR = OOC_INODE_SEQUENCE(ICUR,TYPEF) IF (INODE_CUR .EQ. MonBloc%INODE) THEN LorUSIZE_OF_BLOCK = ADDR_LAST - & OOC_VADDR(STEP_OOC(INODE_CUR),TYPEF) ELSE IF (ICUR .LE. 1) THEN WRITE(*,*) "Internal error in SMUMPS_OOC_STORE_LorU" WRITE(*,*) "Did not find current node in sequence" CALL MUMPS_ABORT() ENDIF GOTO 10 ENDIF ENDIF FILESIZE = FILESIZE + LorUSIZE_OF_BLOCK ENDIF RETURN END SUBROUTINE SMUMPS_OOC_STORE_LorU SUBROUTINE SMUMPS_OOC_WRT_IN_PANELS_LorU( & STRAT, TYPEF, MonBloc, & SIZE_PANEL, & AFAC, LAFAC, & NextPiv2beWritten, AddVirtCour, & TailleEcrite, IERR ) USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, INTENT(IN) :: STRAT, TYPEF, SIZE_PANEL INTEGER(8) :: LAFAC INTEGER(8), INTENT(IN) :: AddVirtCour REAL, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: NextPiv2beWritten TYPE(IO_BLOCK),INTENT(INOUT) :: MonBloc INTEGER(8), INTENT(OUT) :: TailleEcrite INTEGER, INTENT(OUT) :: IERR INTEGER :: I, NBeff, LPANELeff, IEND INTEGER(8) :: AddVirtDeb IERR = 0 TailleEcrite = 0_8 AddVirtDeb = AddVirtCour I = NextPiv2beWritten IF ( NextPiv2beWritten .GT. MonBloc%LastPiv ) THEN RETURN ENDIF 10 CONTINUE NBeff = min(SIZE_PANEL,MonBloc%LastPiv-I+1 ) IF ((NBeff.NE.SIZE_PANEL) .AND. (.NOT.MonBloc%Last)) THEN GOTO 20 ENDIF IF (TYPEF.EQ.TYPEF_L.AND.MonBloc%MASTER.AND. & KEEP_OOC(50).EQ.2 .AND. MonBloc%Typenode.NE.3) THEN IF (MonBloc%INDICES(NBeff+I-1) < 0) & THEN NBeff=NBeff+1 ENDIF ENDIF IEND = I + NBeff -1 CALL SMUMPS_COPY_LU_TO_BUFFER( STRAT, TYPEF, MonBloc, & AFAC, LAFAC, & AddVirtDeb, I, IEND, LPANELeff, & IERR) IF ( IERR .LT. 0 ) THEN RETURN ENDIF IF ( IERR .EQ. 1 ) THEN IERR=0 GOTO 20 ENDIF IF (TYPEF .EQ. TYPEF_L) THEN MonBloc%LastPanelWritten_L = MonBloc%LastPanelWritten_L+1 ELSE MonBloc%LastPanelWritten_U = MonBloc%LastPanelWritten_U+1 ENDIF AddVirtDeb = AddVirtDeb + int(LPANELeff,8) TailleEcrite = TailleEcrite + int(LPANELeff,8) I=I+NBeff IF ( I .LE. MonBloc%LastPiv ) GOTO 10 20 CONTINUE NextPiv2beWritten = I RETURN END SUBROUTINE SMUMPS_OOC_WRT_IN_PANELS_LorU INTEGER(8) FUNCTION SMUMPS_OOC_NBENTRIES_PANEL_123 & (NFSorNPIV, NNMAX, SIZE_PANEL, MonBloc, ESTIM) IMPLICIT NONE TYPE(IO_BLOCK), INTENT(IN):: MonBloc INTEGER, INTENT(IN) :: NFSorNPIV, NNMAX, SIZE_PANEL LOGICAL, INTENT(IN) :: ESTIM INTEGER :: I, NBeff INTEGER(8) :: TOTSIZE TOTSIZE = 0_8 IF (NFSorNPIV.EQ.0) GOTO 100 IF (.NOT. MonBloc%MASTER .OR. MonBloc%Typenode.EQ.3) THEN TOTSIZE = int(NFSorNPIV,8) * int(NNMAX,8) ELSE I = 1 10 CONTINUE NBeff = min(SIZE_PANEL, NFSorNPIV-I+1) IF (KEEP_OOC(50).EQ.2) THEN IF (ESTIM) THEN NBeff = NBeff + 1 ELSE IF (MonBloc%INDICES(I+NBeff-1) < 0) THEN NBeff = NBeff + 1 ENDIF ENDIF ENDIF TOTSIZE = TOTSIZE + & int(NNMAX-I+1,8) * int(NBeff,8) I = I + NBeff IF ( I .LE. NFSorNPIV ) GOTO 10 ENDIF 100 CONTINUE SMUMPS_OOC_NBENTRIES_PANEL_123 = TOTSIZE RETURN END FUNCTION SMUMPS_OOC_NBENTRIES_PANEL_123 INTEGER FUNCTION SMUMPS_OOC_PANEL_SIZE( NNMAX ) IMPLICIT NONE INTEGER, INTENT(IN) :: NNMAX INTEGER SMUMPS_OOC_GET_PANEL_SIZE SMUMPS_OOC_PANEL_SIZE=SMUMPS_OOC_GET_PANEL_SIZE( & int(KEEP_OOC(223),8), NNMAX, KEEP_OOC(227),KEEP_OOC(50)) RETURN END FUNCTION SMUMPS_OOC_PANEL_SIZE SUBROUTINE SMUMPS_OOC_SKIP_NULL_SIZE_NODE() IMPLICIT NONE INTEGER I,TMP_NODE IF(.NOT.SMUMPS_SOLVE_IS_END_REACHED())THEN IF(SOLVE_STEP.EQ.0)THEN I=CUR_POS_SEQUENCE TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE ((I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)).AND. & (SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) & .EQ.0_8)) INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I+1 IF(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ENDIF ENDDO CUR_POS_SEQUENCE=min(I,TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) ELSE I=CUR_POS_SEQUENCE TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE ((I.GE.1).AND. & (SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) & .EQ.0_8)) INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I-1 IF(I.GE.1)THEN TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ENDIF ENDDO CUR_POS_SEQUENCE=max(I,1) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_OOC_SKIP_NULL_SIZE_NODE SUBROUTINE SMUMPS_OOC_SET_STATES_ES(N,KEEP201, & Pruned_List,nb_prun_nodes,STEP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP201, nb_prun_nodes INTEGER, INTENT(IN) :: STEP(N), & Pruned_List(nb_prun_nodes) INTEGER I, ISTEP IF (KEEP201 .GT. 0) THEN OOC_STATE_NODE(:) = ALREADY_USED DO I = 1, nb_prun_nodes ISTEP = STEP(Pruned_List(I)) OOC_STATE_NODE(ISTEP) = NOT_IN_MEM ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_OOC_SET_STATES_ES END MODULE SMUMPS_OOC MUMPS_5.8.1/src/zfac_lastrtnelind.F0000664000175000017500000002075715042446441017061 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, & root, roota, FRERE, IROOT, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_ROOT2SLAVE, & MUMPS_BUF_SEND_ROOT2SON USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER IROOT INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC,IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER(8) :: LA INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND(KEEP(28)), FRERE(KEEP(28)) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER I, NELIM, NB_CONTRI_GLOBAL, NUMORG, & NFRONT, IROW, JCOL, PDEST, HF, IOLDPS, & IN, DEB_ROW, ILOC_ROW, IFSON, ILOC_COL, & IPOS_SON, NELIM_SON, NSLAVES_SON, HS, & IROW_SON, ICOL_SON, ISLAVE, IERR, & NELIM_SENT, IPOS_STATREC, TYPE_SON INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' NB_CONTRI_GLOBAL = KEEP(41) NUMORG = root%ROOT_SIZE NELIM = KEEP(42) NFRONT = NUMORG + KEEP(42) DO IROW = 0, root%NPROW - 1 DO JCOL = 0, root%NPCOL - 1 PDEST = IROW * root%NPCOL + JCOL IF ( PDEST .NE. MYID ) THEN CALL MUMPS_BUF_SEND_ROOT2SLAVE(NFRONT, & NB_CONTRI_GLOBAL, PDEST, COMM, KEEP, IERR) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'MUMPS_BUF_SEND_ROOT2SLAVE' CALL MUMPS_ABORT() endif ENDIF END DO END DO CALL ZMUMPS_PROCESS_ROOT2SLAVE( NFRONT, & NB_CONTRI_GLOBAL, root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND ) IF (IFLAG < 0 ) RETURN HF = 6 + KEEP(IXSZ) IOLDPS = PTLUST_S(STEP(IROOT)) IN = IROOT DEB_ROW = IOLDPS + HF ILOC_ROW = DEB_ROW DO WHILE (IN.GT.0) IW(ILOC_ROW) = IN IW(ILOC_ROW+NFRONT) = IN ILOC_ROW = ILOC_ROW + 1 IN = FILS(IN) END DO IFSON = -IN ILOC_ROW = IOLDPS + HF + NUMORG ILOC_COL = ILOC_ROW + NFRONT IF ( NELIM.GT.0 ) THEN IN = IFSON DO WHILE (IN.GT.0) IPOS_SON = PIMASTER(STEP(IN)) IF (IPOS_SON .EQ. 0) GOTO 100 NELIM_SON = IW(IPOS_SON+1+KEEP(IXSZ)) if (NELIM_SON.eq.0) then write(6,*) ' error 1 in process_last_rtnelind' CALL MUMPS_ABORT() endif NSLAVES_SON = IW(IPOS_SON+5+KEEP(IXSZ)) HS = 6 + NSLAVES_SON + KEEP(IXSZ) IROW_SON = IPOS_SON + HS ICOL_SON = IROW_SON + NELIM_SON DO I = 1, NELIM_SON IW( ILOC_ROW+I-1 ) = IW( IROW_SON+I-1 ) ENDDO DO I = 1, NELIM_SON IW( ILOC_COL+I-1 ) = IW( ICOL_SON+I-1 ) ENDDO NELIM_SENT = ILOC_ROW - IOLDPS - HF + 1 DO ISLAVE = 0,NSLAVES_SON IF (ISLAVE.EQ.0) THEN PDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)),KEEP(199)) ELSE PDEST = IW(IPOS_SON + 5 + ISLAVE+KEEP(IXSZ)) ENDIF IF (PDEST.NE.MYID) THEN CALL MUMPS_BUF_SEND_ROOT2SON(IN, NELIM_SENT, & PDEST, COMM, KEEP, IERR ) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'MUMPS_BUF_SEND_ROOT2SON' CALL MUMPS_ABORT() endif ELSE CALL ZMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & IN, NELIM_SENT, root, roota, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( ISLAVE .NE. 0 ) THEN IF (KEEP(50) .EQ. 0) THEN IPOS_STATREC = PTRIST(STEP(IN))+6+KEEP(IXSZ) ELSE IPOS_STATREC = PTRIST(STEP(IN))+8+KEEP(IXSZ) ENDIF IF (IW(IPOS_STATREC).EQ. S_REC_CONTSTATIC) THEN IW(IPOS_STATREC) = S_ROOT2SON_CALLED ELSE IF (NSLAVES_SON .EQ. 0) THEN TYPE_SON = 1 ELSE TYPE_SON = 2 ENDIF CALL ZMUMPS_FREE_BAND( N, IN, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON & ) ENDIF ENDIF IPOS_SON = PIMASTER(STEP(IN)) ENDIF END DO CALL ZMUMPS_FREE_BLOCK_CB_STATIC( & .FALSE., MYID, N, IPOS_SON, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) ILOC_ROW = ILOC_ROW + NELIM_SON ILOC_COL = ILOC_COL + NELIM_SON 100 CONTINUE IN = FRERE(STEP(IN)) ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_LAST_RTNELIND MUMPS_5.8.1/src/dana_aux_ELT.F0000664000175000017500000011300215042446437015626 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ANA_F_ELT(N, NELT, ELTPTR, ELTVAR, LIW, & IKEEP, & IORD, NFSIZ, FILS, FRERE, & LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, & NSLAVES, & XNODEL, NODEL #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , METIS_OPTIONS #endif & ) USE MUMPS_ANA_ORD_WRAPPERS IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, SIZE_SCHUR, NSLAVES INTEGER(8), INTENT(IN) :: LIW INTEGER, INTENT(IN) :: ELTPTR(NELT+1) INTEGER, INTENT(IN) :: ELTVAR(ELTPTR(NELT+1)-1) INTEGER, INTENT(IN) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: IKEEP(N,3) INTEGER, INTENT(INOUT) :: INFO(80), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(OUT) :: NFSIZ(N), FILS(N), FRERE(N) INTEGER, INTENT(OUT) :: XNODEL(N+1), NODEL(ELTPTR(NELT+1)-1) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER, INTENT(IN) :: METIS_OPTIONS(40) #endif INTEGER K,I,NCMPA,IFSON,IN INTEGER(8) :: L1, L2 INTEGER NEMIN, MPRINT, LP, MP, LDIAG INTEGER(8) :: NZ8, LLIW8, IWFR8 INTEGER allocok, ITEMP LOGICAL PROK, NOSUPERVAR, LPOK INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) LOGICAL SPLITROOT INTEGER HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & NBSONS_Scalapack_CAND INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER :: IDUMMY(1) INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER, DIMENSION(:), ALLOCATABLE :: IW2 INTEGER, DIMENSION(:), ALLOCATABLE :: PARENT INTEGER, DIMENSION(:,:), ALLOCATABLE :: IWtemp INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE8 #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) INTEGER :: NUMFLAG #else INTEGER, DIMENSION(:), ALLOCATABLE :: NUMFLAG #endif INTEGER :: OPT_METIS_SIZE, METIS_IDX_SIZE INTEGER :: IERR #endif INTEGER IDUM EXTERNAL DMUMPS_ANA_G11_ELT, DMUMPS_ANA_G12_ELT, & DMUMPS_ANA_G1_ELT, DMUMPS_ANA_G2_ELT, & DMUMPS_ANA_G2_ELTNEW, & DMUMPS_ANA_J1_ELT, DMUMPS_ANA_J2_ELT, & DMUMPS_ANA_K, & DMUMPS_ANA_LNEW, DMUMPS_ANA_M, & MUMPS_AMD_ELT ALLOCATE( IW ( LIW ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(LIW, INFO( 2 )) GOTO 90 ENDIF ALLOCATE( IPE8 ( N + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (N+1)*KEEP(10) GOTO 90 ENDIF ALLOCATE( PARENT(N), IWtemp ( N, 3 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(4_8*int(N,8), INFO( 2 )) GOTO 90 ENDIF MPRINT= ICNTL(3) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MP = ICNTL(3) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) LDIAG = ICNTL(4) IF (KEEP(60).NE.0) THEN NOSUPERVAR=.TRUE. IF (IORD.GT.1) IORD = 0 ELSE NOSUPERVAR=.FALSE. ENDIF IF (IORD == 7) THEN IF ( N < 10000 ) THEN IORD = 0 ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IORD = 5 #else IORD = 0 #endif ENDIF END IF #if ! defined(metis) && ! defined(parmetis) && ! defined(metis4) && ! defined(parmetis3) IF (IORD == 5) IORD = 0 #endif IF (KEEP(1).LT.1) KEEP(1) = 1 NEMIN = KEEP(1) IF (LDIAG.LE.2 .OR. MP.LE.0) GO TO 10 WRITE (MP,99999) N, NELT, LIW, INFO(1) K = min(10,NELT+1) IF (LDIAG.EQ.4) K = NELT+1 IF (K.GT.0) WRITE (MP,99998) (ELTPTR(I),I=1,K) K = min(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 = min(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_8 L2 = L1 + int(N,8) IF (LIW .LT. 3_8*int(N,8)) THEN INFO(1) = -2002 CALL MUMPS_SET_IERROR( LIW, INFO(2) ) ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF ( IORD == 5 ) THEN IF (LIW .LT. int(N,8)+int(N,8)+1_8) THEN INFO(1)= -2002 CALL MUMPS_SET_IERROR( LIW, INFO(2) ) GOTO 90 ENDIF ELSE #endif IF (NOSUPERVAR) THEN IF ( LIW .LT. 2_8*int(N,8) ) THEN INFO(1)= -2002 CALL MUMPS_SET_IERROR( LIW, INFO(2) ) GOTO 90 END IF ELSE IF ( LIW .LT. 4_8*int(N,8)+4_8 ) THEN INFO(1)= -2002 CALL MUMPS_SET_IERROR( LIW, INFO(2) ) GOTO 90 END IF ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif IDUM=0 CALL DMUMPS_NODEL(NELT, N, ELTPTR(NELT+1)-1, ELTPTR, ELTVAR, & XNODEL, NODEL, IW(L1), IDUM, ICNTL) IF (IORD.NE.1 .AND. IORD .NE. 5) THEN IORD = 0 IF (NOSUPERVAR) THEN CALL DMUMPS_ANA_G1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), IW(L1)) ELSE CALL DMUMPS_ANA_G11_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), 4_8*int(N,8)+4_8, IW(L1)) ENDIF LLIW8 = max(NZ8,int(N,8)) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8, INFO(2)) GOTO 90 ENDIF IF (NOSUPERVAR) THEN CALL DMUMPS_ANA_G2_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) ELSE CALL DMUMPS_ANA_G12_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) ENDIF IF (NOSUPERVAR) THEN CALL MUMPS_HAMD(N, LLIW8, IPE8, IWFR8, IWtemp(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), IWtemp(1,3), & IWtemp, & LISTVAR_SCHUR, SIZE_SCHUR) IF (KEEP(60) == 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSEIF (KEEP(60) == 2 .OR. KEEP(60) == 3 ) THEN KEEP(38) = LISTVAR_SCHUR(1) ELSE WRITE(*,*) "Internal error in DMUMPS_ANA_F_ELT",KEEP(60) CALL MUMPS_ABORT() ENDIF ELSE CALL MUMPS_AMD_ELT(N, LLIW8, IPE8, IWFR8, IWtemp(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), IWtemp(1,3), & IWtemp) ENDIF ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MPRINT,'(A)') ' Ordering based on METIS' ENDIF CALL DMUMPS_ANA_G1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), IW(L1)) LLIW8 = max(NZ8,int(N,8)) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8, INFO(2)) GOTO 90 ENDIF CALL DMUMPS_ANA_G2_ELTNEW(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) #if defined(metis4) || defined(parmetis3) NUMFLAG = 1 OPT_METIS_SIZE = 8 #else ALLOCATE( NUMFLAG ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF DO I=1,N NUMFLAG(I) = 1 ENDDO OPT_METIS_SIZE = 40 #endif CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN INFO(1) = -52 INFO(2) = 1 GOTO 90 ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32(N, IPE8, IW2, #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG, #endif & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP(1:N,2), IKEEP(1:N,1), INFO(1), LP, LPOK) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64(N, IPE8, IW2, #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG, #endif & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP(1:N,2), IKEEP(1:N,1), INFO(1), & LP, LPOK, KEEP(10), & LLIW8, .FALSE., .TRUE. ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF IF (INFO(1) .LT. 0) GOTO 90 DEALLOCATE(IW2) ELSE IF (IORD.NE.1) THEN WRITE(*,*) IORD WRITE(*,*) 'bad option for ordering' CALL MUMPS_ABORT() ENDIF #endif DO K=1,N IW(L1+int(K,8)) = 0 ENDDO DO K=1,N IF ((IKEEP(K,1).LE.0).OR.(IKEEP(K,1).GT.N)) & GO TO 40 IF (IW(L1+int(IKEEP(K,1),8)).EQ.1) THEN GOTO 40 ELSE IW(L1+int(IKEEP(K,1),8)) = 1 ENDIF ENDDO CALL DMUMPS_ANA_J1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IWtemp(1,2), IW(L1)) LLIW8 = NZ8+int(N,8) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8,INFO(2)) GOTO 90 ENDIF CALL DMUMPS_ANA_J2_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) IF (KEEP(60) == 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR IF (KEEP(60) == 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSEIF (KEEP(60) == 2 .OR. KEEP(60) == 3 ) THEN KEEP(38) = LISTVAR_SCHUR(1) ELSE WRITE(*,*) "Internal error in DMUMPS_ANA_F_ELT",KEEP(60) CALL MUMPS_ABORT() ENDIF ENDIF CALL DMUMPS_ANA_K(N, IPE8, IW2, LLIW8, IWFR8, IKEEP, & IKEEP(1,2), IW(L1), & IW(L2), NCMPA, ITEMP, IWtemp) ENDIF CALL DMUMPS_ANA_LNEW(N, IWtemp, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, IWtemp(1,2), & INFO(6), FILS, FRERE, IWtemp(1,3), NEMIN, & IW(L2), KEEP(60), KEEP(20), KEEP(38), & IW2,KEEP(104),IW(L2+int(N,8)),KEEP(50), & ICNTL(13), KEEP(37), KEEP(197), NSLAVES, KEEP(250).EQ.1, & .FALSE., IDUMMY, LIDUMMY, & INODE_Scalapack_CAND, NBSONS_Scalapack_CAND, & KEEP(11), KEEP(191), KEEP(192), KEEP(193) ) DEALLOCATE(IW2) IF (KEEP(60).NE.0) THEN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO WHILE (IN.GT.0) IN = FILS (IN) END DO IFSON = -IN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO I=2,SIZE_SCHUR FILS(IN) = LISTVAR_SCHUR (I) IN = FILS(IN) FRERE (IN) = N+1 ENDDO FILS(IN) = -IFSON ENDIF CALL DMUMPS_ANA_M(IKEEP(1,2), & IWtemp(1,3), INFO(6), & INFO(5), KEEP(2),KEEP(50), & KEEP8(101), KEEP(108),KEEP(5), & KEEP(6), KEEP(226), KEEP(253)) IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, KEEP(20) ) INODE_Scalapack_CAND = KEEP(20) NBSONS_Scalapack_CAND = 1 END IF IF ( KEEP(48) == 4 .OR. & ( (KEEP(24).NE.0).AND.(KEEP8(21).GT.0_8) ) ) THEN CALL DMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2), & KEEP(48), KEEP(50), NSLAVES) END IF IF (KEEP(210).LT.1.OR.KEEP(210).GT.2) KEEP(210)=2 IF (KEEP(210).EQ.2) KEEP8(79)=huge(KEEP8(79)) IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF IF (KEEP(11).EQ.0) THEN IF (KEEP(79).EQ.0) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN IDUMMY(1)= -1 CALL DMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ, & IDUMMY, LIDUMMY, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF (PROK) THEN WRITE(MP,*) " Number of split nodes in pre-splitting=", & KEEP(61) ENDIF ENDIF ENDIF ENDIF ENDIF HOW_TO_SPLIT_ROOT = 0 SPLITROOT = ICNTL(13) .EQ. -1 #if defined(NOSCALAPACK) SPLITROOT = SPLITROOT .OR. NSLAVES.GT.0 #else SPLITROOT = SPLITROOT .OR. & (ICNTL(13).GT.0 .AND. NSLAVES .GT. ICNTL(13)) #endif HOW_TO_SPLIT_ROOT = 0 IF (SPLITROOT.AND.KEEP(11).GT.0) HOW_TO_SPLIT_ROOT =1 IF (KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. IF (KEEP(11).GT.0) HOW_TO_SPLIT_ROOT = 2 ENDIF SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) )) #if defined(NOSCALAPACK) #else IF ( KEEP(11).GT.0) THEN IF (.NOT.SPLITROOT .AND. & (KEEP(60).EQ.0).AND. & ( (NFSIZ(INODE_Scalapack_CAND).GT.KEEP(37)) & .AND.(ICNTL(13).LE.0) ) & .AND. & (NBSONS_Scalapack_CAND.GT.KEEP(11)) & ) THEN HOW_TO_SPLIT_ROOT = 3 SPLITROOT=.TRUE. ENDIF ENDIF #endif IF (SPLITROOT) THEN IDUMMY(1) = -1 IF (KEEP(11).EQ.0) THEN CALL DMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & IDUMMY, LIDUMMY, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) ENDIF ELSE CALL DMUMPS_SPLIT_ROOT( NSLAVES, & HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & N, FRERE(1), FILS(1), NFSIZ(1), & KEEP, KEEP8, & IDUMMY, LIDUMMY, INFO(6)) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN K = min(10,N) IF (LDIAG.EQ.4) K = N IF (K.GT.0) WRITE (MP,99997) (IKEEP(I,1),I=1,K) IF (K.GT.0) WRITE (MP,99991) (IKEEP(I,2),I=1,K) IF (K.GT.0) WRITE (MP,99990) (IKEEP(I,3),I=1,K) IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) ENDIF GO TO 90 40 INFO(1) = -4 INFO(2) = K 90 CONTINUE IF (INFO(1) .LT.0) THEN IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99996) INFO(1) IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99982) INFO(2) ENDIF IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(IPE8)) DEALLOCATE(IPE8) IF (allocated(IW2)) DEALLOCATE(IW2) IF (allocated(IWtemp)) DEALLOCATE(IWtemp) RETURN 99999 FORMAT (/'Entering analysis phase with ...'/ & ' N NELT LIW INFO(1)'/, & 9X, I10, I11, I12, I14) 99998 FORMAT ('Element pointers: ELTPTR() '/(9X, 7I10)) 99995 FORMAT ('Element variables: ELTVAR() '/(9X, 7I10)) 99997 FORMAT ('IKEEP(.,1)=', 10I6/(12X, 10I6)) 99996 FORMAT (/'** Error return ** from Analysis * INFO(1)=', I3) 99991 FORMAT ('IKEEP(.,2)=', 10I6/(12X, 10I6)) 99990 FORMAT ('IKEEP(.,3)=', 10I6/(12X, 10I6)) 99989 FORMAT ('FILS (.) =', 10I6/(12X, 10I6)) 99988 FORMAT ('FRERE(.) =', 10I6/(12X, 10I6)) 99987 FORMAT ('NFSIZ(.) =', 10I6/(12X, 10I6)) 99982 FORMAT ('Error in permutation array KEEP INFO(2)=', I3) END SUBROUTINE DMUMPS_ANA_F_ELT SUBROUTINE DMUMPS_NODEL( NELT, N, NELNOD, XELNOD, ELNOD, & XNODEL, NODEL, FLAG, IERROR, ICNTL ) IMPLICIT NONE INTEGER NELT, N, NELNOD, IERROR, ICNTL(60) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & FLAG(N) INTEGER I, J, K, MP, NBERR MP = ICNTL(2) FLAG(1:N) = 0 XNODEL(1:N) = 0 IERROR = 0 DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF ( J.LT.1 .OR. J.GT.N ) THEN IERROR = IERROR + 1 ELSE IF ( FLAG(J).NE.I ) THEN XNODEL(J) = XNODEL(J) + 1 FLAG(J) = I ENDIF ENDIF ENDDO ENDDO IF ( IERROR.GT.0 .AND. MP.GT.0 .AND. ICNTL(4).GE.2 ) THEN NBERR = 0 WRITE(MP,99999) DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF ( J.LT.1 .OR. J.GT.N ) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN WRITE(MP,'(A,I8,A,I8,A)') & 'Element ',I,' variable ',J,' ignored.' ELSE GO TO 100 ENDIF ENDIF ENDDO ENDDO ENDIF 100 CONTINUE K = 1 DO I = 1, N K = K + XNODEL(I) XNODEL(I) = K ENDDO XNODEL(N+1) = XNODEL(N) FLAG(1:N) = 0 DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF (FLAG(J).NE.I) THEN XNODEL(J) = XNODEL(J) - 1 NODEL(XNODEL(J)) = I FLAG(J) = I ENDIF ENDDO ENDDO RETURN 99999 FORMAT (/'*** Warning message from subroutine DMUMPS_NODEL ***') END SUBROUTINE DMUMPS_NODEL SUBROUTINE DMUMPS_ANA_G1_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, FLAG) IMPLICIT NONE INTEGER N, NELT, NELNOD INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & FLAG(N) INTEGER I,J,K1,K2,K3 FLAG(1:N) = 0 LEN(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN LEN(I) = LEN(I) + 1 LEN(J) = LEN(J) + 1 FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO NZ = 0_8 DO I = 1,N NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE DMUMPS_ANA_G1_ELT SUBROUTINE DMUMPS_ANA_G2_ELTNEW(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N+1) INTEGER LEN(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IWFR = IWFR + int(LEN(I),8) IPE(I) = IWFR ENDDO IPE(N+1)=IPE(N) FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1 IW(IPE(I)) = J IPE(J) = IPE(J) - 1 IW(IPE(J)) = I FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE DMUMPS_ANA_G2_ELTNEW SUBROUTINE DMUMPS_ANA_G2_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER LEN(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IWFR = IWFR + int(LEN(I),8) IF (LEN(I).GT.0) THEN IPE(I) = IWFR ELSE IPE(I) = 0_8 ENDIF ENDDO FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1_8 IW(IPE(I)) = J IPE(J) = IPE(J) - 1_8 IW(IPE(J)) = I FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE DMUMPS_ANA_G2_ELT SUBROUTINE DMUMPS_ANA_J1_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, LEN, FLAG) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), FLAG(N) INTEGER I,J,K1,K2,K3 FLAG(1:N) = 0 LEN(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IF (PERM(J).GT.PERM(I)) THEN LEN(I) = LEN(I) + 1 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO NZ = 0_8 DO I = 1,N NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE DMUMPS_ANA_J1_ELT SUBROUTINE DMUMPS_ANA_J2_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), IW(LW), & FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 0_8 DO I = 1,N IWFR = IWFR + int(LEN(I) + 1,8) IPE(I) = IWFR ENDDO IWFR = IWFR + 1_8 FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IF (PERM(J).GT.PERM(I)) THEN IW(IPE(I)) = J IPE(I) = IPE(I) - 1_8 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO DO I = 1,N J = int(IPE(I)) IW(J) = LEN(I) IF (LEN(I).EQ.0) IPE(I) = 0_8 ENDDO RETURN END SUBROUTINE DMUMPS_ANA_J2_ELT SUBROUTINE DMUMPS_ANA_DIST_ELEMENTS( MYID, SLAVEF, N, & PROCNODE, STEP, PTRAIW, PTRARW, & NELT, FRTPTR, FRTELT, & KEEP,KEEP8, ICNTL, SYM ) IMPLICIT NONE INTEGER MYID, SLAVEF, N, NELT, SYM INTEGER KEEP( 500 ), ICNTL( 60 ) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAIW( NELT+1 ), PTRARW( NELT+1 ) INTEGER STEP( N ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PROCNODE( KEEP(28) ) INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER(8) :: IPTRI8, IPTRR8, NVAR8 INTEGER ELT, I, K INTEGER TYPE_PARALL, ITYPE, IRANK LOGICAL :: EARLYT3ROOTINS TYPE_PARALL = KEEP(46) PTRAIW( 1:NELT ) = 0_8 EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) DO I = 1, N IF (STEP(I).LT.0) CYCLE ITYPE = MUMPS_TYPENODE( PROCNODE(abs(STEP(I))), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(abs(STEP(I))), KEEP(199) ) IF ( TYPE_PARALL .eq. 0 ) THEN IRANK = IRANK + 1 END IF IF ( (ITYPE .EQ. 2) .OR. & (ITYPE .EQ. 3 .AND. .NOT. EARLYT3ROOTINS ) .OR. & (ITYPE .EQ. 1 .AND. IRANK .EQ. MYID) ) THEN DO K = FRTPTR(I),FRTPTR(I+1)-1 ELT = FRTELT(K) PTRAIW( ELT ) = PTRARW(ELT+1) - PTRARW(ELT) ENDDO ELSE END IF END DO IPTRI8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT ) PTRAIW( ELT ) = IPTRI8 IPTRI8 = IPTRI8 + NVAR8 ENDDO PTRAIW( NELT+1 ) = IPTRI8 KEEP8(27) = IPTRI8 - 1 IF ( .TRUE. ) THEN IF (SYM .EQ. 0) THEN IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + NVAR8*NVAR8 ENDDO PTRARW( NELT+1 ) = IPTRR8 ELSE IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + (NVAR8*(NVAR8+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR8 ENDIF ELSE IF (SYM .EQ. 0) THEN IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + NVAR8*NVAR8 ENDDO PTRARW( NELT+1 ) = IPTRR8 ELSE IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + (NVAR8*(NVAR8+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR8 ENDIF ENDIF KEEP8(26) = IPTRR8 - 1_8 RETURN END SUBROUTINE DMUMPS_ANA_DIST_ELEMENTS SUBROUTINE DMUMPS_ELTPROC( N, NELT, ELTPROC, SLAVEF, PROCNODE, & KEEP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, SLAVEF INTEGER, INTENT(IN) :: PROCNODE( N ) INTEGER, INTENT(INOUT) :: ELTPROC( NELT ) INTEGER :: KEEP(500) INTEGER ELT, I, ITYPE LOGICAL :: EARLYT3ROOTINS INTEGER, EXTERNAL :: MUMPS_TYPENODE, MUMPS_PROCNODE EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) DO ELT = 1, NELT I = ELTPROC(ELT) IF ( I .NE. 0) THEN ITYPE = MUMPS_TYPENODE(PROCNODE(I),KEEP(199)) IF (ITYPE.EQ.1) THEN ELTPROC(ELT) = MUMPS_PROCNODE(PROCNODE(I),KEEP(199)) ELSE IF ( ITYPE.EQ.2 .OR. .NOT. EARLYT3ROOTINS ) THEN ELTPROC(ELT) = -1 ELSE ELTPROC(ELT) = -2 ENDIF ELSE ELTPROC(ELT) = -3 ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_ELTPROC SUBROUTINE DMUMPS_FRTELT(N, NELT, NELNOD, FRERE, FILS, NA, NE, & XNODEL, NODEL, FRTPTR, FRTELT, ELTNOD) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, NELNOD INTEGER, INTENT(IN) :: FRERE(N), FILS(N), NA(N), NE(N) INTEGER, INTENT(OUT):: FRTPTR(N+1), FRTELT(NELT), ELTNOD(NELT) INTEGER, INTENT(IN) :: XNODEL(N+1), NODEL(NELNOD) INTEGER, DIMENSION(:), ALLOCATABLE :: TNSTK, IPOOL INTEGER I, K, IFATH, allocok INTEGER INODE, LEAF, NBLEAF, NBROOT, III, IN ALLOCATE(TNSTK( N ), stat=allocok) IF (allocok.ne.0) THEN WRITE(6,*) ' Allocation error of TNSTK in ' & // 'routine DMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF ALLOCATE(IPOOL( N ), stat=allocok) IF (allocok.ne.0) THEN WRITE(6,*) ' Allocation error of IPOOL in ' & // 'routine DMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF TNSTK = NE LEAF = 1 IF (N.EQ.1) THEN NBROOT = 1 NBLEAF = 1 IPOOL(1) = 1 LEAF = LEAF + 1 ELSEIF (NA(N).LT.0) THEN NBLEAF = N NBROOT = N DO 20 I=1,NBLEAF-1 INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 20 CONTINUE INODE = -NA(N)-1 IPOOL(LEAF) = INODE LEAF = LEAF + 1 ELSEIF (NA(N-1).LT.0) THEN NBLEAF = N-1 NBROOT = NA(N) IF (NBLEAF-1.GT.0) THEN DO 30 I=1,NBLEAF-1 INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 30 CONTINUE ENDIF INODE = -NA(N-1)-1 IPOOL(LEAF) = INODE LEAF = LEAF + 1 ELSE NBLEAF = NA(N-1) NBROOT = NA(N) DO 40 I = 1,NBLEAF INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 40 CONTINUE ENDIF ELTNOD(1:NELT) = 0 III = 1 90 CONTINUE IF (III.NE.LEAF) THEN INODE=IPOOL(III) III = III + 1 ELSE WRITE(6,*) ' ERROR 1 in subroutine DMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF 95 CONTINUE IN = INODE 100 CONTINUE DO K = XNODEL(IN),XNODEL(IN+1)-1 I = NODEL(K) IF (ELTNOD(I).EQ.0) ELTNOD(I) = INODE ENDDO IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IN = INODE 110 IN = FRERE(IN) IF (IN.GT.0) GO TO 110 IF (IN.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 115 GOTO 90 ELSE IFATH = -IN ENDIF TNSTK(IFATH) = TNSTK(IFATH) - 1 IF ( TNSTK(IFATH) .EQ. 0 ) THEN INODE = IFATH GOTO 95 ELSE GOTO 90 ENDIF 115 CONTINUE FRTPTR(1:N) = 0 DO I = 1,NELT IF (ELTNOD(I) .NE. 0) THEN FRTPTR(ELTNOD(I)) = FRTPTR(ELTNOD(I)) + 1 ENDIF ENDDO K = 1 DO I = 1,N K = K + FRTPTR(I) FRTPTR(I) = K ENDDO FRTPTR(N+1) = FRTPTR(N) DO K = 1,NELT INODE = ELTNOD(K) IF (INODE .NE. 0) THEN FRTPTR(INODE) = FRTPTR(INODE) - 1 FRTELT(FRTPTR(INODE)) = K ENDIF ENDDO DEALLOCATE(TNSTK, IPOOL) RETURN END SUBROUTINE DMUMPS_FRTELT SUBROUTINE DMUMPS_ANA_G11_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, LW, IW) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8) :: LW INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW) INTEGER I,J,K1,K2,K3,LP,NSUP,SUPVAR INTEGER INFO44(6) EXTERNAL DMUMPS_SUPVAR LP = 6 CALL DMUMPS_SUPVAR(N,NELT,XELNOD(NELT+1)-1,ELNOD,XELNOD, & NSUP,IW(3_8*int(N,8)+3_8+1_8), & 3_8*int(N,8)+3_8,IW,LP,INFO44) IF (INFO44(1) .LT. 0) THEN IF (LP.GE.0) WRITE(LP,*) & 'Error return from DMUMPS_SUPVAR. INFO(1) = ',INFO44(1) ENDIF IW(1:NSUP) = 0 LEN(1:N) = 0 DO I = 1,N SUPVAR = IW(3_8*int(N,8)+3_8+1_8+int(I,8)) IF (SUPVAR .EQ. 0) CYCLE IF (IW(SUPVAR).NE.0) THEN LEN(I) = -IW(SUPVAR) ELSE IW(SUPVAR) = I ENDIF ENDDO IW(int(N+1,8):2_8*int(N,8)) = 0 NZ = 0_8 DO SUPVAR = 1,NSUP I = IW(SUPVAR) DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF (LEN(J).GE.0) THEN IF ((I.NE.J) .AND. (IW(int(N,8)+int(J,8)).NE.I)) THEN IW(int(N,8)+int(J,8)) = I LEN(I) = LEN(I) + 1 ENDIF ENDIF ENDIF ENDDO ENDDO NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE DMUMPS_ANA_G11_ELT SUBROUTINE DMUMPS_ANA_G12_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IF (LEN(I).GT.0) THEN IWFR = IWFR + int(LEN(I),8) IPE(I) = IWFR ELSE IPE(I) = 0_8 ENDIF ENDDO FLAG(1:N) = 0 DO I = 1,N IF (LEN(I).LE.0) CYCLE DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF (LEN(J) .GT. 0) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1 IW(IPE(I)) = J FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE DMUMPS_ANA_G12_ELT SUBROUTINE DMUMPS_SUPVAR(N,NELT,NZ,ELTVAR,ELTPTR,NSUP,SVAR, & LIW,IW,LP,INFO) INTEGER LP,N,NELT,NSUP,NZ INTEGER(8)::LIW INTEGER INFO(6) INTEGER ELTPTR(NELT+1),ELTVAR(NZ) INTEGER IW(LIW),SVAR(0:N) INTEGER(8) :: FLAG,NEW,VARS 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) = N + 1 GO TO 40 END IF NEW = 1_8 VARS = NEW + LIW/3_8 FLAG = VARS + LIW/3_8 CALL DMUMPS_SUPVARB(N,NELT,ELTPTR,NZ,ELTVAR,SVAR,NSUP, & int(min(int(huge(NSUP)-1,8),LIW/3_8-1_8)), & IW(NEW),IW(VARS),IW(FLAG),INFO) IF (INFO(1).EQ.-4) THEN INFO(4) = N + 1 GO TO 40 ELSE INFO(4) = NSUP + 1 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) 3_8*int(INFO(4),8) END IF 50 RETURN 9000 FORMAT (/3X,'Error message from DMUMPS_SUPVAR: INFO(1) = ',I2) 9010 FORMAT (3X,'LIW is insufficient. Upper bound on required work', & 'space is ',I12) END SUBROUTINE DMUMPS_SUPVAR SUBROUTINE DMUMPS_SUPVARB( N, NELT, ELTPTR, NZ, ELTVAR, & SVAR, NSUP, MAXSUP, NEW, VARS, FLAG, INFO ) INTEGER MAXSUP,N,NELT,NSUP,NZ INTEGER ELTPTR(NELT+1),ELTVAR(NZ) INTEGER INFO(6) INTEGER FLAG(0:MAXSUP), NEW(0:MAXSUP),SVAR(0:N), & VARS(0:MAXSUP) INTEGER I,IS,J,JS,K,K1,K2 DO 10 I = 0,N SVAR(I) = 0 10 CONTINUE VARS(0) = N + 1 NEW(0) = -1 FLAG(0) = 0 NSUP = 0 DO 40 J = 1,NELT K1 = ELTPTR(J) K2 = ELTPTR(J+1) - 1 DO 20 K = K1,K2 I = ELTVAR(K) IF (I.LT.1 .OR. I.GT.N) THEN INFO(2) = INFO(2) + 1 GO TO 20 END IF IS = SVAR(I) IF (IS.LT.0) THEN ELTVAR(K) = 0 INFO(3) = INFO(3) + 1 GO TO 20 END IF SVAR(I) = SVAR(I) - N - 2 VARS(IS) = VARS(IS) - 1 20 CONTINUE DO 30 K = K1,K2 I = ELTVAR(K) IF (I.LT.1 .OR. I.GT.N) GO TO 30 IS = SVAR(I) + N + 2 IF (FLAG(IS).LT.J) THEN FLAG(IS) = J IF (VARS(IS).GT.0) THEN NSUP = NSUP + 1 IF (NSUP.GT.MAXSUP) THEN INFO(1) = -4 RETURN END IF VARS(NSUP) = 1 FLAG(NSUP) = J NEW(IS) = NSUP SVAR(I) = NSUP ELSE VARS(IS) = 1 NEW(IS) = IS SVAR(I) = IS END IF ELSE JS = NEW(IS) VARS(JS) = VARS(JS) + 1 SVAR(I) = JS END IF 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE DMUMPS_SUPVARB MUMPS_5.8.1/src/cfac_compact_factors_m.F0000664000175000017500000001303215042446441017776 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC_COMPACT_FACTORS_M PRIVATE PUBLIC :: CMUMPS_TRY_COMPACT_FACTORS CONTAINS SUBROUTINE CMUMPS_TRY_COMPACT_FACTORS(ICNTL49_LOC, & WK_USER_PROVIDED, S, KEEP, KEEP8, INFO, MYID, ICNTL, & PROK, MP, CMUMPS_LBUFR_BYTES8, CMUMPS_LBUF8, & LIWK, LIWK8 ) USE OMP_LIB USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_FREE_S_WK C C Purpose C ======= C If no factors stored in S and .NOT.WK_USER_PROVIDED deallocate(S) C If ICNTL49_LOC = 1, 2 try to compress S C Possible values : C 0 : nothing is done. C 1 : compact S while satisfying the C memory constraint that might have been provided C with ICNTL(23) feature. C 2 : compact S. The memory constraint that might have been C provided with ICNTL(23) feature does not apply C C Parameters C ========== INTEGER :: ICNTL49_LOC, MP, MYID COMPLEX, POINTER, DIMENSION(:) :: S INTEGER :: KEEP(500), INFO(80), ICNTL(60) LOGICAL :: PROK, WK_USER_PROVIDED INTEGER(8) :: CMUMPS_LBUFR_BYTES8, CMUMPS_LBUF8 INTEGER(8) :: KEEP8(150) INTEGER(8), INTENT(IN) :: LIWK, LIWK8 C C Local declarations C ================== C LOGICAL :: Compact_S_Authorized INTEGER :: IERR, NOMP COMPLEX, DIMENSION(:), POINTER :: TMPS INTEGER(8) :: TMPpeak, I8 !$ INTEGER(8) :: CHUNK8 IF (.NOT.WK_USER_PROVIDED) THEN C{ IF (KEEP8(31).EQ.0) THEN C{ C No factors stored in S IF (associated(S)) THEN CALL CMUMPS_DM_FREE_S_WK(S, KEEP(430)) C Reset KEEP(430)=0 since next allocations of S C will be from Fotran KEEP(430)=0 NULLIFY(S) KEEP8(23) = 0 ENDIF C} ELSE IF (ICNTL49_LOC.NE.0) THEN C{ Factors stored in S, try to compact S TMPpeak = KEEP8(73) + KEEP8(31) & - (CMUMPS_LBUFR_BYTES8+CMUMPS_LBUF8)/int(KEEP(35),8) & - KEEP8(26) & - ((LIWK+LIWK8*KEEP(10)+KEEP8(27))*int(KEEP(34),8)) & /int(KEEP(35),8) Compact_S_Authorized = .FALSE. C Set Compact_S_Authorized IF (KEEP8(4).GT.0_8) THEN IF (TMPpeak.LT.KEEP8(75)) & Compact_S_Authorized=.TRUE. ELSE Compact_S_Authorized = .TRUE. ENDIF IF (ICNTL49_LOC.EQ.1.AND..NOT.Compact_S_Authorized) THEN C{ INFO(1) = INFO(1) + 4 C INFO(2) = C New value of ICNTL(23) (in MBytes: C ( KEEP8(4) + (TMPpeak- KEEP8(75))*KEEP(35) )/1000000 C + 1 for safety INFO(2) = int( & ( & KEEP8(4) + & (TMPpeak- KEEP8(75))*int(KEEP(35),8) & ) / 1000000_8 + 1_8 & ) C In fact increasing INFO(2) will not help C since increasing ICNTL(23) will also increase C MAXS and thus the peak of memory. C Thus setting ICNTL(23) to INFO(2) might not C enable user to Compact_S. C Simplest is to advice to set ICNTL(49)=2 C or to switch of ICNTL(23) feature. IF (PROK) THEN WRITE(MP,'(A,I4,A,I2,A,/A,/A,A)') & " ** WARNING ** on MPI proc= ", MYID, & " ICNTL(49)= ", ICNTL49_LOC, & ", but not enough memory to compact S due to ", & " memory limitation given by ICNTL(23).", & " ICNTL(23) should be reset to zero or", & " ICNTL(49) should be set to 2 " ENDIF C} ELSE IF ( & (ICNTL49_LOC.EQ.1.AND.Compact_S_Authorized) & .OR. & (ICNTL49_LOC.EQ.2) C{ & ) THEN C Try to compact S of size MAXS ALLOCATE(TMPS(KEEP8(31)), stat=IERR) IF (IERR .GT. 0 ) THEN IF (PROK) THEN WRITE(MP,'(A,I4,A,I3,A)') & " ** WARNING ** on MPI proc= ", MYID, & " ICNTL(49)= ", ICNTL49_LOC, & ", but not enough memory to compact S " ENDIF INFO(1) = INFO(1) + 4 GOTO 513 ENDIF C !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK8=int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF ( KEEP8(31) > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO I8=1_8, KEEP8(31) TMPS(I8) = S(I8) ENDDO !$OMP END PARALLEL DO CALL CMUMPS_DM_FREE_S_WK(S, KEEP(430)) C Reset KEEP(430)=0 since TMPS is allocated C in Fortran and S=>TMPS should be deallocated C in Fortran. KEEP(430)=0 S => TMPS; NULLIFY(TMPS) KEEP8(23) = KEEP8(31) C} ENDIF C} ENDIF C} ENDIF 513 CONTINUE RETURN END SUBROUTINE CMUMPS_TRY_COMPACT_FACTORS END MODULE CMUMPS_FAC_COMPACT_FACTORS_M MUMPS_5.8.1/src/sana_aux.F0000664000175000017500000043041615042446436015153 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if defined(__ve__) #if defined(VHOFFLOAD) #include 've.h' #endif #endif MODULE SMUMPS_ANA_AUX_M IMPLICIT NONE CONTAINS SUBROUTINE SMUMPS_ANA_F(N, NZ8, IRN, ICN, LIWALLOC, & IKEEP1, IKEEP2, IKEEP3, & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, & CNTL4, COLSCA, ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , METIS_OPTIONS #endif & , NORIG_ARG, SIZEOFBLOCKS, GCOMP_PROVIDED_IN, GCOMP & ) USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY : COMPACT_GRAPH_T IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR, NSLAVES INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: LIWALLOC INTEGER, INTENT(in) :: LISTVAR_SCHUR(:) INTEGER, POINTER :: IRN(:), ICN(:) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: INFO(80), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(OUT) :: NFSIZ(:), FILS(:), FRERE(:) INTEGER, INTENT(INOUT) :: PIV(:) INTEGER, INTENT(INOUT) :: IKEEP1(:), IKEEP2(:), IKEEP3(:) REAL :: CNTL4 REAL, POINTER :: COLSCA(:), ROWSCA(:) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER, INTENT(IN) :: METIS_OPTIONS(40) #endif INTEGER, INTENT(IN), OPTIONAL :: NORIG_ARG INTEGER, INTENT(IN), TARGET, OPTIONAL :: SIZEOFBLOCKS(N) LOGICAL, INTENT(IN), OPTIONAL :: GCOMP_PROVIDED_IN TYPE(COMPACT_GRAPH_T), OPTIONAL :: GCOMP INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: IWALLOC INTEGER, DIMENSION(:), POINTER :: IW INTEGER(8), DIMENSION(:), ALLOCATABLE, TARGET :: IPEALLOC INTEGER(8), DIMENSION(:), POINTER :: IPE INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8 INTEGER, DIMENSION(:,:), ALLOCATABLE :: PTRAR INTEGER, DIMENSION(:), ALLOCATABLE :: PARENT INTEGER, DIMENSION(:), ALLOCATABLE :: IWL1 INTEGER NBBUCK INTEGER, DIMENSION(:), ALLOCATABLE :: WTEMP INTEGER IERR INTEGER I, K, NCMPA, IN, IFSON INTEGER(8) :: J8, I8 INTEGER :: NORIG INTEGER(8) :: IFIRST, ILAST INTEGER(8) IWFR8 INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry INTEGER NBQD, AvgDens LOGICAL PROK, COMPRESS_SCHUR, LPOK, COMPUTE_PERM #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) INTEGER NUMFLAG #endif INTEGER METIS_IDX_SIZE INTEGER OPT_METIS_SIZE #endif #if defined(scotch) || defined(ptscotch) INTEGER :: SCOTCH_INT_SIZE #endif #if defined(pord) INTEGER :: PORD_INT_SIZE #endif REAL, DIMENSION(:), ALLOCATABLE :: COLSCA_TEMP INTEGER THRESH, IVersion LOGICAL AGG6 INTEGER MINSYM PARAMETER (MINSYM=50) INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) INTEGER MTRANS, COMPRESS,NCMP,IERROR,J,JPERM,NCST INTEGER TOTEL INTEGER NFR #if defined(pord) INTEGER TOTW #endif INTEGER WEIGHTUSED #if defined(scotch) || defined(ptscotch) INTEGER WEIGHTREQUESTED #endif INTEGER HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & NBSONS_Scalapack_CAND LOGICAL SCOTCH_SYMBOLIC LOGICAL IDENT,SPLITROOT LOGICAL FREE_CENTRALIZED_MATRIX LOGICAL GCOMP_PROVIDED LOGICAL INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH INTEGER(8) :: LIW8, NZG8 DOUBLE PRECISION TIMEB INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR INTEGER, TARGET :: IDUMMY_ARRAY(1) INTEGER :: LSIZEOFBLOCKS_PTR LOGICAL :: SIZEOFBLOCKS_AVAIL #if defined (MUMPS_SCOTCHIMPORTOMPTHREADS) INTEGER :: ESMUMPSCONTEXT #endif EXTERNAL MUMPS_ANA_H, SMUMPS_ANA_J, & SMUMPS_ANA_K, SMUMPS_ANA_GNEW, & SMUMPS_ANA_LNEW, SMUMPS_ANA_M EXTERNAL SMUMPS_GNEW_SCHUR EXTERNAL SMUMPS_LDLT_COMPRESS, SMUMPS_EXPAND_PERMUTATION, & SMUMPS_SET_CONSTRAINTS ALLOCATE( IWL1 (N), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF ALLOCATE( PTRAR (N,3), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 3*N GOTO 90 ENDIF SCOTCH_SYMBOLIC=(KEEP(270).EQ.0) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL MUMPS_SCOTCH_ESMUMPSCONTEXT( ESMUMPSCONTEXT ) SCOTCH_SYMBOLIC=SCOTCH_SYMBOLIC .AND. (ESMUMPSCONTEXT.EQ.1) #endif symmetry = INFO(8) NBQD = 0 GCOMP_PROVIDED=.FALSE. WEIGHTUSED = 0 NORIG = N IF (present(NORIG_ARG)) THEN NORIG=NORIG_ARG ENDIF IF (present(GCOMP_PROVIDED_IN)) & GCOMP_PROVIDED = GCOMP_PROVIDED_IN IF (GCOMP_PROVIDED.AND.(.NOT. present(GCOMP))) THEN INFO(1) = -900 WRITE(6,*) " INTERNAL ERROR in MUMPS(ANA_F) ", & GCOMP_PROVIDED_IN, present(GCOMP) INFO(2) = 1 RETURN ENDIF IF (GCOMP_PROVIDED) THEN NZG8 = GCOMP%NZG LIW8 = NZG8 + int(GCOMP%NG,8)+1_8 IW => GCOMP%ADJ(1:LIW8) IPE => GCOMP%IPE(1:GCOMP%NG+1) DO I=1,GCOMP%NG PTRAR(I,2) = int(IPE(I+1)-IPE(I)) ENDDO ELSE IF (LIWALLOC.GT.0_8) THEN ALLOCATE( IWALLOC (LIWALLOC), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(LIWALLOC,INFO(2)) GOTO 90 ENDIF ENDIF IF ( LIWALLOC.EQ.0_8 ) THEN INFO(1) = -900 WRITE(6,*) " INTERNAL ERROR in MUMPS(ANA_F) ", & "LIWALLOC, GCOMP_PROVIDED=", LIWALLOC, GCOMP_PROVIDED INFO(2) = 2 RETURN ENDIF LIW8 = LIWALLOC NZG8 = NZ8 IW => IWALLOC(1:LIW8) ALLOCATE( IPEALLOC(N+1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (N+1)*KEEP(10) GOTO 90 ENDIF IPE => IPEALLOC(1:N+1) ENDIF LP = ICNTL(1) MP = ICNTL(3) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) LDIAG = ICNTL(4) COMPRESS_SCHUR = .FALSE. IF (present(SIZEOFBLOCKS)) THEN SIZEOFBLOCKS_PTR => SIZEOFBLOCKS(1:N) LSIZEOFBLOCKS_PTR = N SIZEOFBLOCKS_AVAIL = .TRUE. ELSE SIZEOFBLOCKS_PTR => IDUMMY_ARRAY SIZEOFBLOCKS_AVAIL = .FALSE. LSIZEOFBLOCKS_PTR = 1 IDUMMY_ARRAY(1) = -1 ENDIF IF (PROK) THEN IF (present(GCOMP)) THEN WRITE(MP,'(A,I10,A,I13,A)') " Processing a graph of size:", N & ," with ", GCOMP%NZG, " edges" ELSE WRITE(MP,'(A,I10)') " Processing a graph of size:", N ENDIF ENDIF IF (GCOMP_PROVIDED) THEN FREE_CENTRALIZED_MATRIX = .FALSE. ELSE FREE_CENTRALIZED_MATRIX = ( & (KEEP(54).EQ.3).AND. & (KEEP(494).EQ.0).AND. & (KEEP(106).NE.3) & ) ENDIF INPLACE64_GRAPH_COPY = .FALSE. INPLACE64_RESTORE_GRAPH = .TRUE. IF (KEEP(1).LT.0) KEEP(1) = 0 NEMIN = KEEP(1) IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (present(SIZEOFBLOCKS)) THEN K = min(10,GCOMP%NG) IF (LDIAG.EQ.4) K = GCOMP%NG WRITE (MP,99909) N, NZG8, INFO(1) I8= 0_8 WRITE(MP,'(A)') " Graph adjacency " DO J=1, K IFIRST = GCOMP%IPE(J) ILAST= min(GCOMP%IPE(J+1)-1,GCOMP%IPE(J)+K-1) write(MP,'(A,I10)') " .... node/column:", J write(MP,'(8X,10I9)') & (GCOMP%ADJ(I8),I8=IFIRST,ILAST) ENDDO ELSE J8 = min(NZG8, 10_8) IF (LDIAG .EQ.4) J8 = NZG8 WRITE (MP,99999) N, NZG8, LIW8, INFO(1) IF (J8.GT.0_8) WRITE (MP,99998) (IRN(I8),ICN(I8),I8=1_8,J8) ENDIF K = min(10,N) IF (LDIAG.EQ.4) K = N IF (IORD.EQ.1 .AND. K.GT.0) THEN WRITE (MP,99997) (IKEEP1(I),I=1,K) ENDIF ENDIF NCMP = N IF (KEEP(60).NE.0) THEN IF ((SIZE_SCHUR.LE.0 ).OR. & (SIZE_SCHUR.GE.N) ) GOTO 90 ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF ( ( KEEP(60).NE.0).AND.(SIZE_SCHUR.GT.0) & .AND. & ((IORD.EQ.7).OR.(IORD.EQ.5)) & )THEN COMPRESS_SCHUR=.TRUE. NCMP = N-SIZE_SCHUR ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL SMUMPS_GNEW_SCHUR(N,NCMP,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, & KEEP(264), KEEP(265), & LISTVAR_SCHUR(1), SIZE_SCHUR, FRERE(1), FILS(1), & INPLACE64_GRAPH_COPY) INFO(8) = symmetry INPLACE64_GRAPH_COPY = INPLACE64_GRAPH_COPY.AND. & (.NOT.FREE_CENTRALIZED_MATRIX) DEALLOCATE(IPQ8) IORD = 5 KEEP(95) = 1 NBQD = 0 ELSE #endif IF (GCOMP_PROVIDED) THEN IWFR8 = GCOMP%NZG+1_8 ELSE ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF CALL SMUMPS_ANA_GNEW(N,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, KEEP(264), KEEP(265), & .TRUE., INPLACE64_GRAPH_COPY) INFO(8) = symmetry INPLACE64_GRAPH_COPY = INPLACE64_GRAPH_COPY.AND. & (.NOT.FREE_CENTRALIZED_MATRIX) DEALLOCATE(IPQ8) ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif IF(NBQD .GT. 0) THEN IF( KEEP(50) .EQ. 2 .AND. ICNTL(12) .EQ. 0 ) THEN IF(KEEP(95) .NE. 1) THEN IF ( PROK ) & WRITE( MP,*) & 'Compressed/constrained ordering set OFF' KEEP(95) = 1 ENDIF ENDIF ENDIF IF ( (KEEP(60).NE.0) .AND. (IORD.GT.1) .AND. & .NOT. COMPRESS_SCHUR ) THEN IORD = 0 ENDIF IF ( (KEEP(50).EQ.2) & .AND. (KEEP(95) .EQ. 3) & .AND. (IORD .EQ. 7) ) THEN IORD = 2 ENDIF CALL MUMPS_SET_ORDERING( NORIG, KEEP, & KEEP(50), NSLAVES, IORD, & NBQD, AvgDens, & PROK, MP ) IF(KEEP(50) .EQ. 2) THEN IF(KEEP(95) .EQ. 3 .AND. IORD .NE. 2) THEN IF (PROK) WRITE(MP,*) & 'WARNING: SMUMPS_ANA_F constrained ordering not '// & ' available with selected ordering. Move to' // & ' compressed ordering.' KEEP(95) = 2 ENDIF ELSE KEEP(95) = 1 ENDIF MTRANS = KEEP(23) COMPRESS = KEEP(95) - 1 IF(COMPRESS .GT. 0 .AND. KEEP(52) .EQ. -2) THEN IF(CNTL4 .GE. 0.0E0) THEN IF (KEEP(1).LE.8) THEN NEMIN = 16 ELSE NEMIN = 2*KEEP(1) ENDIF ENDIF ENDIF IF(MTRANS .GT. 0 .AND. KEEP(50) .EQ. 2) THEN KEEP(23) = 0 ENDIF IF (COMPRESS .EQ. 2) THEN IF (IORD.NE.2) THEN WRITE(*,*) "IORD not compatible with COMPRESS:", & IORD, COMPRESS CALL MUMPS_ABORT() ENDIF CALL SMUMPS_SET_CONSTRAINTS( & N,PIV(1),FRERE(1),FILS(1),NFSIZ(1),IKEEP1(1), & NCST,KEEP,KEEP8, ROWSCA(1) & ) ENDIF IF ( IORD .NE. 1 ) THEN IF (COMPRESS .GE. 1) THEN ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL SMUMPS_LDLT_COMPRESS( & N, NZ8, IRN(1), ICN(1), PIV(1), & NCMP, IW(1), LIW8, IPE(1), PTRAR(1,2), IPQ8, & IWL1, FILS(1), IWFR8, & IERROR, KEEP, KEEP8, ICNTL, INPLACE64_GRAPH_COPY) DEALLOCATE(IPQ8) symmetry = 100 ENDIF IF ( (symmetry.LT.MINSYM).AND.(KEEP(50).EQ.0) ) THEN IF(KEEP(23) .EQ. 7 ) THEN KEEP(23) = -5 GOTO 90 ELSE IF(KEEP(23) .EQ. -9876543) THEN IDENT = .TRUE. KEEP(23) = 5 IF (PROK) WRITE(MP,'(A)') & ' ... Apply column permutation (already computed)' DO J=1,N JPERM = PIV(J) FILS(JPERM) = J IF (JPERM.NE.J) IDENT = .FALSE. ENDDO IF (.NOT.IDENT) THEN DO J8=1_8,NZ8 J = ICN(J8) IF ((J.LE.0).OR.(J.GT.N)) CYCLE ICN(J8) = FILS(J) ENDDO ALLOCATE(COLSCA_TEMP(N), stat=IERR) IF ( IERR > 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF DO J = 1, N COLSCA_TEMP(J)=COLSCA(J) ENDDO DO J=1, N COLSCA(FILS(J))=COLSCA_TEMP(J) ENDDO DEALLOCATE(COLSCA_TEMP) IF (PROK) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL SMUMPS_ANA_GNEW & (N,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264), KEEP(265), & .TRUE.,INPLACE64_GRAPH_COPY) INFO(8) = symmetry DEALLOCATE(IPQ8) NCMP = N ELSE KEEP(23) = 0 ENDIF ENDIF ELSE IF (KEEP(23) .EQ. 7 .OR. KEEP(23) .EQ. -9876543 ) THEN IF (PROK) WRITE(MP,'(A)') & ' ... No column permutation' KEEP(23) = 0 ENDIF ENDIF IF (FREE_CENTRALIZED_MATRIX & .AND.COMPRESS.EQ.0.AND.(.NOT.COMPRESS_SCHUR)) THEN deallocate(IRN) NULLIFY(IRN) deallocate(ICN) NULLIFY(ICN) ENDIF INPLACE64_RESTORE_GRAPH = & INPLACE64_RESTORE_GRAPH.AND.(COMPRESS.NE.1) ALLOCATE( PARENT ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF IF (IORD.NE.1 .AND. IORD.NE.5) THEN IF ( KEEP(60) .NE. 0 ) THEN IORD = 0 ENDIF IF (PROK) THEN IF (IORD.EQ.2) THEN WRITE(MP,'(A)') ' Ordering based on AMF ' #if defined(scotch) || defined(ptscotch) ELSE IF (IORD.EQ.3) THEN WRITE(MP,'(A)') ' Ordering based on SCOTCH ' #endif #if defined(pord) ELSE IF (IORD.EQ.4) THEN WRITE(MP,'(A)') ' Ordering based on PORD ' #endif ELSE IF (IORD.EQ.6) THEN WRITE(MP,'(A)') ' Ordering based on QAMD ' ELSE WRITE(MP,'(A)') ' Ordering based on AMD ' ENDIF ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF IF ( KEEP(60) .NE. 0 ) THEN CALL MUMPS_HAMD(N, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP1(1), & IKEEP2(1), NCMPA, FILS(1), IKEEP3(1), & PTRAR, PTRAR(1,3), & PARENT, & LISTVAR_SCHUR(1), SIZE_SCHUR) IF (KEEP(60)==1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ELSE IF ( .FALSE. ) THEN #if defined(pord) ELSEIF (IORD .EQ. 4) THEN CALL MUMPS_PORD_INTSIZE(PORD_INT_SIZE) TOTW = N IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) & ) THEN IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IF & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) THEN TOTW = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF IF (PORD_INT_SIZE .EQ. 64) THEN CALL MUMPS_PORDF_WND_MIXEDto64(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, TOTW, PARENT, & INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY & ) ELSE IF (PORD_INT_SIZE .EQ. 32) THEN CALL MUMPS_PORDF_WND_MIXEDto32(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, TOTW, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE WRITE(*,*) & "Internal error in PORD wrappers, PORD_INT_SIZE=", & PORD_INT_SIZE CALL MUMPS_ABORT() ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 GOTO 90 ENDIF IF (INFO(1) .LT.0) GOTO 90 IF (COMPRESS.EQ.1) THEN CALL SMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS(1)) CALL SMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP1(1), & FRERE(1),PTRAR(1,1)) DO I=1,NCMP IKEEP2(IKEEP1(I))=I ENDDO ENDIF ELSE IF (PORD_INT_SIZE.EQ.64) THEN CALL MUMPS_PORDF_MIXEDto64(NCMP, IWFR8-1_8, IPE, & IW, & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY & ) ELSE IF (PORD_INT_SIZE.EQ.32) THEN CALL MUMPS_PORDF_MIXEDto32(NCMP, IWFR8-1_8, IPE, & IW, & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE WRITE(*,*) & "Internal error in PORD wrappers, PORD_INT_SIZE=", & PORD_INT_SIZE CALL MUMPS_ABORT() ENDIF ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 GOTO 90 ENDIF IF (INFO(1) .LT. 0) GOTO 90 #endif #if defined(scotch) || defined(ptscotch) ELSEIF (IORD .EQ. 3) THEN CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE) IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) & ) THEN WEIGHTREQUESTED=1 IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IF & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) THEN DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF ELSE WEIGHTREQUESTED = 0 DO I= 1, N IWL1(I) = 1 ENDDO ENDIF IF (SCOTCH_INT_SIZE.EQ.32) THEN IF (KEEP(10).EQ.1) THEN INFO(1) = -52 INFO(2) = 2 ELSE CALL MUMPS_SCOTCH_MIXEDto32(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, & WEIGHTUSED, WEIGHTREQUESTED, SCOTCH_SYMBOLIC) ENDIF ELSE IF (SCOTCH_INT_SIZE.EQ.64) THEN CALL MUMPS_SCOTCH_MIXEDto64(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH, & WEIGHTUSED, WEIGHTREQUESTED, SCOTCH_SYMBOLIC) ELSE WRITE(*,*) & "Internal error in SCOTCH wrappers, SCOTCH_INT_SIZE=", & SCOTCH_INT_SIZE CALL MUMPS_ABORT() ENDIF IF (INFO(1) .LT. 0) GOTO 90 IF (.NOT. SCOTCH_SYMBOLIC) THEN IF ( COMPRESS .EQ. 1 ) THEN CALL SMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94), & KEEP(93),PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF ELSE IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS).AND. & (WEIGHTUSED.EQ.0) ) & ) THEN CALL SMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS(1)) CALL SMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP1(1), & FRERE(1),PTRAR(1,1)) DO I=1,NCMP IKEEP2(IKEEP1(I))=I ENDDO ENDIF #endif ELSEIF (IORD .EQ. 2) THEN NBBUCK = 2*N COMPUTE_PERM=.FALSE. IF(COMPRESS .GE. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.GE.1) THEN CALL MUMPS_ABORT() ENDIF NBBUCK = max(NBBUCK, NORIG-N) NBBUCK = max(NBBUCK, 2*NORIG) NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF ALLOCATE( WTEMP ( 0: NBBUCK + 1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = NBBUCK+2 GOTO 90 ENDIF IF(COMPRESS .LE. 1) THEN CALL MUMPS_HAMF4 & (TOTEL, NCMP, COMPUTE_PERM, NBBUCK, LIW8, IPE(1), & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), WTEMP, PARENT(1)) ELSE IF(PROK) WRITE(MP,'(A)') & ' Constrained Ordering based on AMF' CALL MUMPS_CST_AMF(NCMP, NBBUCK, LIW8, IPE(1), & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), WTEMP, & NFSIZ(1), FRERE(1), PARENT(1)) ENDIF DEALLOCATE(WTEMP) ELSEIF (IORD .EQ. 6) THEN ALLOCATE( WTEMP ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF THRESH = 1 IVersion = 2 COMPUTE_PERM=.FALSE. IF(COMPRESS .EQ. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.EQ.1) THEN CALL MUMPS_ABORT() ENDIF NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL MUMPS_QAMD & (TOTEL,COMPUTE_PERM,IVersion, THRESH, WTEMP, & NCMP, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), PARENT(1)) DEALLOCATE(WTEMP) ELSE COMPUTE_PERM=.FALSE. IF(COMPRESS .EQ. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.EQ.1) THEN CALL MUMPS_ABORT() ENDIF NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL MUMPS_ANA_H(TOTEL, COMPUTE_PERM, & NCMP, LIW8, IPE(1), IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), PARENT(1)) ENDIF ENDIF IF(COMPRESS .GE. 1) THEN CALL SMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94),KEEP(93), & PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) #if defined(scotch) || defined(ptscotch) IF (IORD.EQ.3) THEN WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME SPENT IN SCOTCH reordering =', TIMEB ENDIF #endif ENDIF ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MP,'(A)') ' Ordering based on METIS' ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN INFO(1) = -52 INFO(2) = 1 GOTO 90 ENDIF #if defined(metis4) || defined(parmetis3) NUMFLAG = 1 OPT_METIS_SIZE = 8 #else OPT_METIS_SIZE = 40 #endif IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 FRERE(I) = 2 ENDDO DO I=KEEP(93)/2+1,NCMP FRERE(I) = 1 ENDDO #if defined(metis4) || defined(parmetis3) IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEWND_MIXEDto32( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ELSE IF ((NORIG.NE.N).AND.present(SIZEOFBLOCKS)) THEN DO I=1, N FRERE(I) = SIZEOFBLOCKS(I) ENDDO IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEWND_MIXEDto32( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ELSE IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW, NUMFLAG, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW, NUMFLAG, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP,LPOK,KEEP(10), & LIW8, INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ENDIF ENDIF #else ELSE IF (present(SIZEOFBLOCKS)) THEN DO I=1,N FRERE(I) = SIZEOFBLOCKS(I) ENDDO ELSE DO I=1,NCMP FRERE(I) = 1 ENDDO ENDIF ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW, FRERE, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW, FRERE, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP,LPOK,KEEP(10), & LIW8, INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH) ELSE IF (LPOK) WRITE(LP,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF #endif IF (INFO(1) .LT.0) GOTO 90 IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME SPENT IN METIS reordering =', TIMEB ENDIF IF ( COMPRESS_SCHUR ) THEN CALL SMUMPS_EXPAND_PERM_SCHUR( & N, NCMP, IKEEP1(1),IKEEP2(1), & LISTVAR_SCHUR(1), SIZE_SCHUR, FILS(1)) COMPRESS = -1 ENDIF IF (COMPRESS .EQ. 1) THEN CALL SMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94), & KEEP(93),PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF ENDIF #endif IF (PROK) THEN IF (IORD.EQ.1) THEN WRITE(MP,'(A)') ' Ordering given is used' ENDIF ENDIF IF (IORD.EQ.1 .OR. IORD.EQ.5 .OR. COMPRESS.EQ.-1 & .OR. ( (IORD.EQ.3).AND.(.NOT.SCOTCH_SYMBOLIC) ) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) .AND.(IORD.EQ.3) & .AND. (WEIGHTUSED.EQ.0) & ) & ) THEN IF ((KEEP(106).EQ.1).OR.(KEEP(106).EQ.2).OR.(KEEP(106).EQ.4) & .OR.(KEEP(60).NE.0)) THEN IF ( COMPRESS .EQ. -1 ) THEN ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL SMUMPS_ANA_GNEW(N,NZ8,IRN(1),ICN(1),IW(1),LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264),KEEP(265), .TRUE., & INPLACE64_GRAPH_COPY) DEALLOCATE(IPQ8) ENDIF COMPRESS = 0 IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF IF (KEEP(106).EQ.2) THEN IF (PROK) THEN WRITE(MP,'(A)') " SYMBOLIC based on column counts " ENDIF IF (present(SIZEOFBLOCKS)) THEN DO I=1, N FRERE(I) = SIZEOFBLOCKS(I) ENDDO ELSE FRERE(1) = -1 ENDIF CALL MUMPS_WRAP_GINP94 ( & N, IPE(1), IW(1), IWFR8, & IKEEP1(1), & FRERE(1), & KEEP(60), LISTVAR_SCHUR(1), SIZE_SCHUR, & KEEP(378), & IWL1, PARENT, & IKEEP2(1), IKEEP3(1), NFSIZ(1), & PTRAR(1,1), PTRAR(1,2), PTRAR(1,3), & INFO ) IF (INFO(1).LT.0) GOTO 90 ELSE IF ((KEEP(106).EQ.4).AND.(KEEP(60).EQ.0).AND. & (.NOT.present(SIZEOFBLOCKS) .OR. (NORIG.EQ.N)) & ) THEN WRITE(MP,*) " Undefined option for ICNTL(58) " INFO(1)= -99998 GOTO 90 ELSE ALLOCATE( WTEMP ( 2_8*int(N,8) ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(2_8*int(N,8), INFO(2) ) GOTO 90 ENDIF THRESH = -1 IF (KEEP(60) == 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR ENDIF AGG6 =.FALSE. IF (present(SIZEOFBLOCKS)) THEN DO I=1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO TOTEL = NORIG ELSE IWL1(1) = -1 TOTEL = N ENDIF CALL MUMPS_SYMQAMD(THRESH, WTEMP, & N, TOTEL, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1(1), WTEMP(N+1), & IKEEP2(1), NCMPA, FILS(1), IKEEP3(1), PTRAR, & PTRAR(1,3),IKEEP1(1), LISTVAR_SCHUR(1), ITEMP, & AGG6, PARENT) DEALLOCATE(WTEMP) ENDIF IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME IN symbolic factorization =', TIMEB ENDIF ELSE CALL SMUMPS_ANA_J(N, NZ8, IRN(1), ICN(1), IKEEP1(1), IW(1), & LIW8, IPE(1), & PTRAR(1,2), IWL1, IWFR8, & INFO(1),INFO(2), MP) IF (KEEP(60) .EQ. 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR ENDIF CALL SMUMPS_ANA_K(N, IPE(1), IW(1), LIW8, IWFR8, IKEEP1(1), & IKEEP2(1), IWL1, & PTRAR, NCMPA, ITEMP, PARENT) ENDIF ENDIF IF (KEEP(60) .NE. 0) THEN IF (KEEP(60)==1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ENDIF IF (allocated(IPEALLOC)) DEALLOCATE(IPEALLOC) ALLOCATE(WTEMP(N), stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF CALL SMUMPS_ANA_LNEW & (N, PARENT, IWL1, IKEEP1(1), IKEEP2(1), IKEEP3(1), & NFSIZ(1), PTRAR, INFO(6), FILS(1), FRERE(1), & PTRAR(1,3), NEMIN, WTEMP, KEEP(60), & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), & ICNTL(13), KEEP(37), KEEP(197), NSLAVES, KEEP(250).EQ.1, & SIZEOFBLOCKS_AVAIL, SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR & , INODE_Scalapack_CAND, NBSONS_Scalapack_CAND, & KEEP(11), KEEP(191), KEEP(192), KEEP(193) & ) DEALLOCATE(WTEMP) IF (KEEP(60).NE.0) THEN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO WHILE (IN.GT.0) IN = FILS (IN) END DO IFSON = -IN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO I=2,SIZE_SCHUR FILS(IN) = LISTVAR_SCHUR (I) IN = FILS(IN) FRERE (IN) = N+1 ENDDO FILS(IN) = -IFSON ENDIF CALL SMUMPS_ANA_M(IKEEP2(1), & PTRAR(1,3), INFO(6), & INFO(5), KEEP(2), KEEP(50), & KEEP8(101), KEEP(108), KEEP(5), & KEEP(6), KEEP(226), KEEP(253)) KEEP(59) = INFO(5) IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) INODE_Scalapack_CAND = KEEP(20) NBSONS_Scalapack_CAND = 1 END IF IF ( (KEEP(48) == 4 .AND. KEEP8(21).GT.0_8) & .OR. & (KEEP (48)==5 .AND. KEEP8(21) .GT. 0_8 ) & .OR. & (KEEP(24).NE.0.AND.KEEP8(21).GT.0_8) ) THEN CALL SMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2), & KEEP(48), KEEP(50), NSLAVES) END IF IF (KEEP(210).LT.1.OR.KEEP(210).GT.2) KEEP(210)=2 IF (KEEP(210).EQ.2) KEEP8(79)=huge(KEEP8(79)) IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF IF (KEEP(11).EQ.0) THEN IF ( (KEEP(79).EQ.0).OR.(KEEP(79).EQ.2).OR. & (KEEP(79).EQ.3).OR.(KEEP(79).EQ.5).OR. & (KEEP(79).EQ.6) & ) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN CALL SMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF (PROK) THEN WRITE(MP,*) " Number of split nodes in pre-splitting=", & KEEP(61) ENDIF ENDIF ENDIF ENDIF ENDIF HOW_TO_SPLIT_ROOT = 0 SPLITROOT = ICNTL(13) .EQ. -1 IF (KEEP(11).GT.1) THEN NFR = NFSIZ(INODE_Scalapack_CAND) #if defined(NOSCALAPACK) SPLITROOT = SPLITROOT .OR. & ( NSLAVES.GT.0.AND. & ( REAL(NFR) - REAL(NFR)/REAL(max(2,NSLAVES)) & .GT. REAL(KEEP(9)) ) & ) #else SPLITROOT = SPLITROOT .OR. & ( ICNTL(13).GT.0 .AND. NSLAVES .GT. ICNTL(13). AND. & ( REAL(NFR) - REAL(NFR)/REAL(max(2,NSLAVES)) & .GT. REAL(KEEP(9)) ) & ) #endif ELSE #if defined(NOSCALAPACK) SPLITROOT = SPLITROOT .OR. NSLAVES.GT.0 #else SPLITROOT = SPLITROOT .OR. & (ICNTL(13).GT.0 .AND. NSLAVES .GT. ICNTL(13) & ) #endif ENDIF IF (SPLITROOT.AND.KEEP(11).GT.0) HOW_TO_SPLIT_ROOT =1 IF (KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. IF (KEEP(11).GT.0) HOW_TO_SPLIT_ROOT = 2 ENDIF #if defined(NOSCALAPACK) #else IF ( KEEP(11).GT.0) THEN IF (.NOT.SPLITROOT .AND. & (KEEP(60).EQ.0).AND. & ( (NFSIZ(INODE_Scalapack_CAND).GT.KEEP(37)) & .AND.(ICNTL(13).LE.0) ) & .AND. & (NBSONS_Scalapack_CAND.GT.KEEP(11)) & ) THEN HOW_TO_SPLIT_ROOT = 3 SPLITROOT=.TRUE. ENDIF ENDIF #endif SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) )) IF (SPLITROOT) THEN IF (KEEP(11).EQ.0) THEN CALL SMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) ENDIF ELSE CALL SMUMPS_SPLIT_ROOT( NSLAVES, & HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(1), KEEP8(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, INFO(6)) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN K = min(10,N) IF (LDIAG.EQ.4) K = N IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) ENDIF GO TO 90 90 CONTINUE IF (INFO(1) .NE. 0) THEN IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE (LP,99996) INFO(1), INFO(2) ENDIF IF (allocated(IWALLOC)) DEALLOCATE(IWALLOC) IF (allocated(IWL1)) DEALLOCATE(IWL1) IF (allocated(IPEALLOC)) DEALLOCATE(IPEALLOC) IF (allocated(PTRAR)) DEALLOCATE(PTRAR) IF (allocated(PARENT)) DEALLOCATE(PARENT) RETURN 99999 FORMAT (/'Entering ordering phase with ...'/ & ' N NNZ LIW INFO(1)'/, & 6X, I10, I11, I12, I10) 99998 FORMAT ('Matrix entries: IRN() ICN()'/ & (I12, I9, I12, I9, I12, I9)) 99909 FORMAT (/'Entering ordering phase with graph dimensions ...'/ & ' |V| |E| INFO(1)'/, & 10X, I10, I13, I10) 99997 FORMAT ('IKEEP1(.)=', 10I8/(12X, 10I8)) 99996 FORMAT & (/'** Error/warning return ** from Analysis * INFO(1:2)= ', & (I3, I16)) 99989 FORMAT ('FILS (.) =', 10I9/(11X, 10I9)) 99988 FORMAT ('FRERE(.) =', 10I9/(11X, 10I9)) 99987 FORMAT ('NFSIZ(.) =', 10I9/(11X, 10I9)) END SUBROUTINE SMUMPS_ANA_F SUBROUTINE SMUMPS_ANA_N_DIST( id, NBINCOL, NBINROW ) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_STRUC IMPLICIT NONE include 'mpif.h' TYPE(SMUMPS_STRUC), INTENT(INOUT), TARGET :: id INTEGER, INTENT(OUT), TARGET :: NBINCOL(:) INTEGER, INTENT(OUT), TARGET :: NBINROW(:) INTEGER :: IERR, allocok INTEGER :: IOLD, JOLD, INEW, JNEW INTEGER(8) :: K, INZ INTEGER, POINTER :: IIRN(:), IJCN(:) INTEGER, POINTER :: IWORK1(:), IWORK2(:) LOGICAL :: IDO IF(id%KEEP(54) .EQ. 3) THEN IIRN => id%IRN_loc IJCN => id%JCN_loc INZ = id%KEEP8(29) IWORK1 => NBINROW(1:id%N) allocate(IWORK2(id%N),stat=allocok) IF (allocok > 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%N RETURN ENDIF IDO = .TRUE. ELSE IIRN => id%IRN IJCN => id%JCN INZ = id%KEEP8(28) IWORK1 => NBINCOL(1:id%N) IWORK2 => NBINROW(1:id%N) IDO = id%MYID .EQ. 0 END IF DO 50 IOLD=1,id%N IWORK1(IOLD) = 0_8 IWORK2(IOLD) = 0_8 50 CONTINUE IF(IDO) THEN DO 70 K=1_8,INZ IOLD = IIRN(K) JOLD = IJCN(K) IF ( (IOLD.GT.id%N).OR.(JOLD.GT.id%N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) GOTO 70 IF (IOLD.NE.JOLD) THEN INEW = id%SYM_PERM(IOLD) JNEW = id%SYM_PERM(JOLD) IF ( id%KEEP( 50 ) .EQ. 0 ) THEN IF (INEW.LT.JNEW) THEN IWORK2(IOLD) = IWORK2(IOLD) + 1 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 (id%KEEP(54) .EQ. 3) THEN CALL MUMPS_BIGALLREDUCE(.FALSE., IWORK1(1), NBINCOL(1), id%N, & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) CALL MUMPS_BIGALLREDUCE(.FALSE., IWORK2(1), NBINROW(1), id%N, & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) deallocate(IWORK2) ELSE CALL MPI_BCAST( NBINCOL(1), id%N, MPI_INTEGER, & 0, id%COMM, IERR ) CALL MPI_BCAST( NBINROW(1), id%N, MPI_INTEGER, & 0, id%COMM, IERR ) END IF RETURN END SUBROUTINE SMUMPS_ANA_N_DIST SUBROUTINE SMUMPS_ANA_O( N, NZ, MTRANS, PERM, & IKEEPALLOC, LIKEEPALLOC, & idIRN, idJCN, idA, idROWSCA, idCOLSCA, WORK2, KEEP, & ICNTL, INFO, INFOG ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ INTEGER, INTENT(OUT) :: PERM(:) INTEGER, POINTER, DIMENSION(:) :: idIRN, idJCN REAL, POINTER, DIMENSION(:) :: idA REAL, POINTER, DIMENSION(:) :: idROWSCA, idCOLSCA INTEGER(8), INTENT(IN) :: LIKEEPALLOC INTEGER, TARGET :: IKEEPALLOC(LIKEEPALLOC) INTEGER, INTENT(INOUT) :: MTRANS INTEGER :: KEEP(500) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(INOUT) :: INFOG(80) INTEGER, TARGET :: WORK2(N) INTEGER :: allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: IW REAL, ALLOCATABLE, DIMENSION(:) :: S2 TARGET :: S2 INTEGER ICNTL64(10), INFO64(10) INTEGER ICNTL_SYM_MWM(10),INFO_SYM_MWM(10) REAL CNTL64(10) INTEGER MPRINT,LP, MP INTEGER JPERM INTEGER NUMNZ, I, J, JPOS LOGICAL PROK, IDENT, DUPPLI INTEGER K50, KER_SIZE, NZER_DIAG, MTRANSLOC,RZ_DIAG INTEGER(8) :: LIWG INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8 INTEGER :: LSC INTEGER(8) :: NZTOT, NZREAL, IPIW, LIW, LIWMIN, NZsave, & K, KPOS, LDW, LDWMIN, IRNW, RSPOS, CSPOS, & LS2,J8, N8 LOGICAL SCALINGLOC INTEGER,POINTER,DIMENSION(:) :: ZERODIAG INTEGER,POINTER,DIMENSION(:) :: STR_KER INTEGER,POINTER,DIMENSION(:) :: MARKED INTEGER,POINTER,DIMENSION(:) :: FLAG INTEGER,POINTER,DIMENSION(:) :: PIV_OUT REAL THEMIN, THEMAX, COLNORM,MAXDBL, ABSAK REAL ZERO,TWO,ONE PARAMETER(ZERO = 0.0E0,TWO = 2.0E0,ONE = 1.0E0) N8 = int(N,8) MPRINT = ICNTL(3) LP = ICNTL(1) MP = ICNTL(2) PROK = ((MPRINT.GT.0).AND.(ICNTL(4).GE.2)) K50 = KEEP(50) SCALINGLOC = .FALSE. IF(KEEP(52) .EQ. -2) THEN IF(.not.associated(idA)) THEN ELSE SCALINGLOC = .TRUE. ENDIF ELSE IF(KEEP(52) .EQ. 77) THEN SCALINGLOC = .TRUE. IF( MTRANS .NE. 5 .AND. MTRANS .NE. 6 & .AND. MTRANS .NE. 7) THEN SCALINGLOC = .FALSE. ENDIF IF(.not.associated(idA)) THEN SCALINGLOC = .FALSE. IF (PROK) & WRITE(MPRINT,*) 'Analysis: auto scaling OFF because ', & 'A not provided at analysis ' ENDIF ENDIF IF ( (KEEP(50).EQ.2).AND.(ICNTL(8).NE.-2).AND. & (MTRANS .EQ. 7 .OR. KEEP(95) .EQ. 0) ) THEN ZERODIAG => IKEEPALLOC(1:N) ZERODIAG = 0 NZER_DIAG = N RZ_DIAG = 0 DO K=1,NZ I = idIRN(K) J = idJCN(K) IF (I.NE.J) CYCLE IF ( (J.LE.N).AND.(J.GE.1) ) THEN IF(ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = 1 IF(associated(idA)) THEN ABSAK= abs(idA(K)) IF(ABSAK .EQ. real(0.0E0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ENDIF NZER_DIAG = NZER_DIAG - 1 ENDIF ENDIF ENDDO IF( (NZER_DIAG+RZ_DIAG) .LT. max(1,(N/10)) ) THEN MTRANS = 0 KEEP(95) = 1 GOTO 500 ENDIF ENDIF IF(SCALINGLOC) THEN IF (PROK) WRITE(MPRINT,*) & 'Scaling will be computed during analysis' ENDIF IF( MTRANS.NE.0 .AND. (.NOT.associated(idA)) ) MTRANS=1 MTRANSLOC = MTRANS IF (MTRANS.LT.0 .OR. MTRANS.GT.7) GO TO 500 IF (K50 .EQ. 0) THEN IF(.NOT. SCALINGLOC .AND. MTRANS .EQ. 7) THEN GO TO 500 ENDIF IF(SCALINGLOC) THEN IF (MTRANSLOC.NE.6) THEN MTRANSLOC = 5 ENDIF ENDIF ELSE IF (MTRANS .EQ. 7) MTRANSLOC = 5 ENDIF IF(SCALINGLOC .AND. MTRANSLOC .NE. 5 .AND. & MTRANSLOC .NE. 6 ) THEN IF (PROK) WRITE(MPRINT,*) & 'WARNING scaling required: set MTRANS option to 5' MTRANSLOC = 5 ENDIF IF (N.EQ.1) THEN MTRANS = 0 KEEP(95) = 1 GO TO 500 ENDIF IF(K50 .NE. 0) THEN NZTOT = 2_8*NZ+N8 ELSE NZTOT = NZ ENDIF ZERODIAG => IKEEPALLOC(1:N) STR_KER => IKEEPALLOC(int(N+1,8):2_8*int(N,8)) CALL SMUMPS_MTRANSI(ICNTL64,CNTL64) ICNTL64(1) = ICNTL(1) ICNTL64(2) = ICNTL(2) ICNTL64(3) = ICNTL(3) ICNTL64(4) = -1 IF (ICNTL(4).EQ.3) ICNTL64(4) = 0 IF (ICNTL(4).EQ.4) ICNTL64(4) = 1 ICNTL64(5) = -1 IF (PROK) THEN WRITE(MPRINT,'(A,I3)') & 'Compute maximum matching (Maximum Transversal):', & MTRANSLOC IF (MTRANSLOC.EQ.1) & WRITE(MPRINT,'(A,I3)')' ... JOB =',MTRANSLOC IF (MTRANSLOC.EQ.2) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': BOTTLENECK THESIS' IF (MTRANSLOC.EQ.3) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': BOTTLENECK SIMAX' IF (MTRANSLOC.EQ.4) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': MAXIMIZE SUM DIAGONAL' IF (MTRANSLOC.EQ.5 .OR. MTRANSLOC.EQ.6) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC, & ': MAXIMIZE PRODUCT DIAGONAL AND SCALE' ENDIF INFOG(23) = MTRANSLOC CNTL64(2) = huge(CNTL64(2)) IRNW = 1 IPIW = IRNW + NZTOT IF (MTRANSLOC.EQ.1) LIWMIN = 5_8*N8 IF (MTRANSLOC.EQ.2) LIWMIN = 3_8*N8 IF (MTRANSLOC.EQ.3) LIWMIN = 10_8*N8 + NZTOT IF (MTRANSLOC.EQ.4) LIWMIN = 2_8*N8 IF (MTRANSLOC.EQ.5) LIWMIN = 5_8*N8 IF (MTRANSLOC.EQ.6) LIWMIN = 5_8*N8 + NZTOT LIW = LIWMIN LIWG = LIW + NZTOT ALLOCATE(IW(LIWG), stat=allocok) IF (allocok .GT. 0 ) THEN GOTO 410 ENDIF ALLOCATE( IPQ8(N), IPE(N+1), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR( (2_8*int(N,8)+1_8) * int(KEEP(10),8), & INFO(2) ) GOTO 500 ENDIF IF (MTRANSLOC.EQ.1) THEN LDWMIN = N8+3_8 ENDIF IF (MTRANSLOC.EQ.2) LDWMIN = max( N8+NZTOT , N8+3_8 ) IF (MTRANSLOC.EQ.3) LDWMIN = max( NZTOT+1_8 , N8+3_8 ) IF (MTRANSLOC.EQ.4) LDWMIN = 2_8 * N8 + & max( NZTOT , N8+3_8 ) IF (MTRANSLOC.EQ.5) LDWMIN = 3_8 * N8 + NZTOT IF (MTRANSLOC.EQ.6) LDWMIN = 4_8 * N8 + NZTOT LDW = LDWMIN ALLOCATE(S2(LDW), stat=allocok) IF (allocok .GT. 0 ) THEN GOTO 430 ENDIF IF(MTRANSLOC .NE. 1) LDW = LDW-NZTOT RSPOS = NZTOT CSPOS = RSPOS+N8 NZREAL = 0_8 DO 5 J=1,N IPQ8(J) = 0_8 5 CONTINUE IF(K50 .EQ. 0) THEN DO 10 K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1).AND. & (I.LE.N).AND.(I.GE.1) ) THEN IPQ8(J) = IPQ8(J) + 1_8 NZREAL = NZREAL + 1_8 ENDIF 10 CONTINUE ELSE ZERODIAG = 0 NZER_DIAG = N RZ_DIAG = 0 DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1).AND. & (I.LE.N).AND.(I.GE.1) ) THEN IPQ8(J) = IPQ8(J) + 1_8 NZREAL = NZREAL + 1_8 IF(I .NE. J) THEN IPQ8(I) = IPQ8(I) + 1_8 NZREAL = NZREAL + 1_8 ELSE IF (ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = 1 IF(associated(idA)) THEN ABSAK= abs(idA(K)) IF(ABSAK .EQ. real(0.0E0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ZERODIAG(I) = exponent(ABSAK) if ( ZERODIAG(I).EQ.0) ZERODIAG(I)=1 ENDIF NZER_DIAG = NZER_DIAG - 1 ELSE IF(associated(idA)) THEN ABSAK= abs(idA(K)) ZERODIAG(I) = ZERODIAG(I)+ exponent(ABSAK) if ( ZERODIAG(I).EQ.0) ZERODIAG(I)=1 ENDIF ENDIF ENDIF ENDIF ENDDO IF(MTRANSLOC .GE. 4) THEN DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN IPQ8(I) = IPQ8(I) + 1_8 NZREAL = NZREAL + 1_8 ENDIF ENDDO ENDIF ENDIF IPE(1) = 1 DO 20 J=1,N IPE(J+1) = IPE(J)+IPQ8(J) 20 CONTINUE DO 25 J=1, N IPQ8(J ) = IPE(J) 25 CONTINUE IF(K50 .EQ. 0) THEN IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1_8) = I IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ELSE IF ( .not.associated(idA)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1) = I S2(KPOS) = abs(idA(K)) IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ENDIF ELSE IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1) = I IPQ8(J) = IPQ8(J) + 1_8 IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDIF ENDDO ELSE IF ( .not.associated(idA) ) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF THEMAX = ZERO THEMIN = huge(THEMIN) DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1_8) = I S2(KPOS) = abs(idA(K)) IPQ8(J) = IPQ8(J) + 1_8 IF(abs(idA(K)) .GT. THEMAX) THEN THEMAX = abs(idA(K)) ELSE IF(abs(idA(K)) .LT. THEMIN & .AND. abs(idA(K)).GT. ZERO) THEN THEMIN = abs(idA(K)) ENDIF IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J S2(KPOS) = abs(idA(K)) IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDIF ENDDO DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = I S2(KPOS) = ZERO IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDDO IF ( THEMAX .NE. ZERO ) THEN CNTL64(2) = (log(THEMAX/THEMIN))*(real(N)) & - log(THEMIN) + ONE ENDIF ENDIF ENDIF DUPPLI = .FALSE. NZsave = NZREAL FLAG => IKEEPALLOC(2_8*int(N,8)+1:3_8*int(N,8)) IF(MTRANSLOC.NE.1) THEN CALL SMUMPS_SUPPRESS_DUPPLI_VAL(N,NZREAL,IPE(1),IW(IRNW),S2, & PERM(1),IPQ8(1)) ELSE CALL SMUMPS_SUPPRESS_DUPPLI_STR(N,NZREAL,IPE(1),IW(IRNW), & PERM(1)) ENDIF IF(NZREAL .NE. NZsave) DUPPLI = .TRUE. LS2 = NZTOT IF ( MTRANSLOC .EQ. 1 ) THEN LS2 = 1_8 LDW = 1_8 ENDIF CALL SMUMPS_MTRANS_DRIVER(MTRANSLOC ,N, N, NZREAL, & IPE, IW(IRNW), S2(1), LS2, & NUMNZ, PERM(1), LIW, IW(IPIW), LDW, S2(LS2+1), & IPQ8, & ICNTL64, CNTL64, INFO64, INFO) IF (INFO(1).LT.0) THEN IF (LP.GT.0 .AND. ICNTL(4).GE.1) & WRITE(LP,'(A,I5)') & ' Not enough memory in MAXTRANS INFO(1)=',INFO(1) GOTO 500 ENDIF IF (INFO64(1).LT.0) THEN IF (LP.GT.0 .AND. ICNTL(4).GE.1) & WRITE(LP,'(A,I5)') & ' INTERNAL ERROR in MAXTRANS INFO(1)=',INFO64(1) INFO(1) = -9964 INFO(2) = INFO64(1) GO TO 500 ENDIF IF (INFO64(1).GT.0) THEN IF (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(A,I5)') & ' WARNING in MAXTRANS INFO(1)=',INFO64(1) ENDIF KER_SIZE = 0 IF(K50 .EQ. 2) THEN DO I=1,N IF(ZERODIAG(I) .EQ. 0) THEN IF(PERM(I) .EQ. I) THEN KER_SIZE = KER_SIZE + 1 PERM(I) = -I STR_KER(KER_SIZE) = I ENDIF ENDIF ENDDO ENDIF IF (NUMNZ.LT.N) then IF (MTRANSLOC.EQ.1) THEN IF (MINVAL(PERM(1:N)) .LE. 0) THEN GOTO 400 ENDIF ELSE GO TO 400 ENDIF ENDIF IF(K50 .EQ. 0) THEN IDENT = .TRUE. IF (MTRANS .EQ. 0 ) GOTO 102 DO 80 J=1,N JPERM = PERM(J) IW(IRNW+int(JPERM-1,8)) = J IF (JPERM.NE.J) IDENT = .FALSE. 80 CONTINUE IF(IDENT) THEN MTRANS = 0 ELSE IF(MTRANS .EQ. 7) THEN MTRANS = -9876543 GOTO 102 ENDIF IF (PROK) WRITE(MPRINT,'(A)') & ' ... Apply column permutation' DO 100 K=1,NZ J = idJCN(K) IF ((J.LE.0).OR.(J.GT.N)) GO TO 100 idJCN(K) = IW(IRNW+int(J-1,8)) 100 CONTINUE IF (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' ENDIF 102 CONTINUE IF (SCALINGLOC) THEN IF ( associated(idCOLSCA)) & DEALLOCATE( idCOLSCA ) IF ( associated(idROWSCA)) & DEALLOCATE( idROWSCA ) ALLOCATE( idCOLSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in SMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of COLSCA' GOTO 500 ENDIF ENDIF ALLOCATE( idROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in SMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of ROWSCA' GOTO 500 ENDIF ENDIF KEEP(52) = -2 KEEP(74) = 1 MAXDBL = log(huge(MAXDBL)) DO J=1,N IF(S2(RSPOS+J) .GT. MAXDBL) THEN S2(RSPOS+J) = ZERO ENDIF IF(S2(CSPOS+J) .GT. MAXDBL) THEN S2(CSPOS+J)= ZERO ENDIF ENDDO DO 105 J=1,N J8 = int(J,8) idROWSCA(J) = exp(S2(RSPOS+J8)) IF(idROWSCA(J) .EQ. ZERO) THEN idROWSCA(J) = ONE ENDIF IF ( MTRANS .EQ. -9876543 .OR. MTRANS.EQ. 0 ) THEN idCOLSCA(J)= exp(S2(CSPOS+J8)) IF(idCOLSCA(J) .EQ. ZERO) THEN idCOLSCA(J) = ONE ENDIF ELSE idCOLSCA(IW(IRNW+J8-1_8))= exp(S2(CSPOS+J8)) IF(idCOLSCA(IW(IRNW+J8-1_8)) .EQ. ZERO) THEN idCOLSCA(IW(IRNW+J8-1_8)) = ONE ENDIF ENDIF 105 CONTINUE ENDIF ELSE IDENT = .FALSE. IF(SCALINGLOC) THEN IF ( associated(idCOLSCA)) DEALLOCATE( idCOLSCA ) IF ( associated(idROWSCA)) DEALLOCATE( idROWSCA ) ALLOCATE( idCOLSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in SMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of COLSCA' GOTO 500 ENDIF ENDIF ALLOCATE( idROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in SMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of ROWSCA' GOTO 500 ENDIF ENDIF KEEP(52) = -2 KEEP(74) = 1 MAXDBL = log(huge(MAXDBL)) DO J=1,N J8 = int(J,8) IF(S2(RSPOS+J8)+S2(CSPOS+J8) .GT. MAXDBL) THEN S2(RSPOS+J8) = ZERO S2(CSPOS+J8)= ZERO ENDIF ENDDO DO J=1,N J8 = int(J,8) IF(PERM(J) .GT. 0) THEN idROWSCA(J) = & exp((S2(RSPOS+J8)+S2(CSPOS+J8))/TWO) IF(idROWSCA(J) .EQ. ZERO) THEN idROWSCA(J) = ONE ENDIF idCOLSCA(J)= idROWSCA(J) ENDIF ENDDO DO JPOS=1,KER_SIZE I = STR_KER(JPOS) COLNORM = ZERO DO K = IPE(I),IPE(I+1) - 1 IF ( PERM( IW( IRNW+K-1_8) ) > 0 ) THEN COLNORM = max(COLNORM,S2(J)) ENDIF ENDDO COLNORM = exp(COLNORM) idROWSCA(I) = ONE / COLNORM idCOLSCA(I) = idROWSCA(I) ENDDO ENDIF IF(MTRANS .EQ. 7 .OR. KEEP(95) .EQ. 0) THEN IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) & .AND. KEEP(95) .EQ. 0) THEN MTRANS = 0 KEEP(95) = 1 GOTO 390 ELSE IF(KEEP(95) .EQ. 0) THEN IF(SCALINGLOC) THEN KEEP(95) = 3 ELSE KEEP(95) = 2 ENDIF ENDIF IF(MTRANS .EQ. 7) MTRANS = 5 ENDIF ENDIF IF(MTRANS .EQ. 0) GOTO 390 ICNTL_SYM_MWM = 0 INFO_SYM_MWM = 0 IF(MTRANS .EQ. 5 .OR. MTRANS .EQ. 6 .OR. & MTRANS .EQ. 7) THEN ICNTL_SYM_MWM(1) = 0 ICNTL_SYM_MWM(2) = 1 ELSE IF(MTRANS .EQ. 4) THEN ICNTL_SYM_MWM(1) = 2 ICNTL_SYM_MWM(2) = 1 ELSE ICNTL_SYM_MWM(1) = 0 ICNTL_SYM_MWM(2) = 1 ENDIF MARKED => IKEEPALLOC( int(N,8)+1_8 : 2_8*int(N,8)) FLAG => IKEEPALLOC(2_8*int(N,8)+1_8 : 3_8*int(N,8)) PIV_OUT => WORK2(1:N) IF(MTRANSLOC .LT. 4) THEN LSC = 1 ELSE LSC = 2*N ENDIF CALL SMUMPS_SYM_MWM( & N, NZREAL, IPE, IW(IRNW), S2(1),LSC, PERM(1), & ZERODIAG(1), & ICNTL_SYM_MWM, S2(LSC+1),MARKED(1),FLAG(1), & PIV_OUT(1), INFO_SYM_MWM) IF(INFO_SYM_MWM(1) .NE. 0) THEN WRITE(*,*) '** Error in SMUMPS_ANA_O' RETURN ENDIF IF(INFO_SYM_MWM(3) .EQ. N) THEN IDENT = .TRUE. ELSEIF ( (ICNTL(12).EQ.0).AND. & ( (N-INFO_SYM_MWM(4)-INFO_SYM_MWM(3)) .GT. N/10 ) & ) THEN IDENT = .TRUE. KEEP(95) = 1 ELSE DO I=1,N PERM(I) = PIV_OUT(I) ENDDO ENDIF KEEP(93) = INFO_SYM_MWM(4) KEEP(94) = INFO_SYM_MWM(3) IF (IDENT) MTRANS=0 ENDIF 390 IF(MTRANS .EQ. 0) THEN KEEP(95) = 1 IF (PROK) THEN WRITE (MPRINT,'(A)') & ' ... Column permutation not used' ENDIF ENDIF GO TO 500 400 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) & WRITE (LP,'(/A)') '** Error: Matrix is structurally singular' INFO(1) = -6 INFO(2) = NUMNZ GOTO 500 410 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in SMUMPS_ANA_O' WRITE (LP,'(A,I14)') & '** Failure during allocation of INTEGER array of size ', & LIWG ENDIF INFO(1) = -7 CALL MUMPS_SET_IERROR(LIWG,INFO(2)) GOTO 500 430 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in SMUMPS_ANA_O' WRITE (LP,'(A)') '** Failure during allocation of S2' ENDIF INFO(1) = -5 CALL MUMPS_SET_IERROR(LDW,INFO(2)) 500 CONTINUE IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(S2)) DEALLOCATE(S2) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(IPQ8)) DEALLOCATE(IPQ8) RETURN END SUBROUTINE SMUMPS_ANA_O END MODULE SMUMPS_ANA_AUX_M SUBROUTINE SMUMPS_ANA_K(N,IPE, IW, LW, IWFR, IPS, IPV, & NV, FLAG, & NCMPA, SIZE_SCHUR, PARENT) IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR INTEGER, INTENT(IN) :: IPS(N) INTEGER(8), INTENT(IN) :: LW INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: IPV(N), NV(N), PARENT(N) INTEGER(8), INTENT(INOUT) :: IWFR INTEGER(8), INTENT(INOUT) :: IPE(N) INTEGER, INTENT(INOUT) :: IW(LW) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER I,J,ML,MS,ME,MINJS,IE,KDUMMY INTEGER LN,JS,JE INTEGER(8) :: JP, JP1, JP2, LWFR, IP DO 10 I=1,N FLAG(I) = 0 NV(I) = 0 J = IPS(I) IPV(J) = I 10 CONTINUE NCMPA = 0 DO 100 ML=1,N-SIZE_SCHUR MS = IPV(ML) ME = MS FLAG(MS) = ME IP = IWFR MINJS = N IE = ME DO 70 KDUMMY=1,N JP = IPE(IE) LN = 0 IF (JP.LE.0_8) GO TO 60 LN = IW(JP) DO 50 JP1=1_8,int(LN,8) JP = JP + 1_8 JS = IW(JP) IF (FLAG(JS).EQ.ME) GO TO 50 FLAG(JS) = ME IF (IWFR.LT.LW) GO TO 40 IPE(IE) = JP IW(JP) = LN - int(JP1) CALL SMUMPS_ANA_D(N, IPE, IW, IP-1_8, LWFR, NCMPA) JP2 = IWFR - 1 IWFR = LWFR IF (IP.GT.JP2) GO TO 30 DO 20 JP=IP,JP2 IW(IWFR) = IW(JP) IWFR = IWFR + 1_8 20 CONTINUE 30 IP = LWFR JP = IPE(IE) 40 IW(IWFR) = JS MINJS = min(MINJS,IPS(JS)+0) IWFR = IWFR + 1_8 50 CONTINUE 60 IPE(IE) = int(-ME,8) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 80 70 CONTINUE 80 IF (IWFR.GT.IP) GO TO 90 IPE(ME) = 0_8 NV(ME) = 1 GO TO 100 90 MINJS = IPV(MINJS) NV(ME) = NV(MINJS) NV(MINJS) = ME IW(IWFR) = IW(IP) IW(IP) = int(IWFR - IP) IPE(ME) = IP IWFR = IWFR + 1_8 100 CONTINUE IF (SIZE_SCHUR == 0) GOTO 500 DO ML = N-SIZE_SCHUR+1,N ME = IPV(ML) IE = ME DO KDUMMY=1,N JP = IPE(IE) LN = 0 IF (JP.LE.0_8) GO TO 160 LN = IW(JP) 160 IPE(IE) = int(-IPV(N-SIZE_SCHUR+1),8) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 190 ENDDO 190 NV(ME) = 0 IPE(ME) = int(-IPV(N-SIZE_SCHUR+1),8) ENDDO ME = IPV(N-SIZE_SCHUR+1) IPE(ME) = 0_8 NV(ME) = SIZE_SCHUR 500 DO I=1,N PARENT(I) = int(IPE(I)) ENDDO RETURN END SUBROUTINE SMUMPS_ANA_K SUBROUTINE SMUMPS_ANA_J(N, NZ, IRN, ICN, PERM, & IW, LW, IPE, IQ, FLAG, & IWFR, IFLAG, IERROR, MP) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ, LW INTEGER, INTENT(IN) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: PERM(N) INTEGER, INTENT(IN) :: MP INTEGER(8), INTENT(OUT):: IWFR INTEGER, INTENT(OUT) :: IERROR INTEGER, INTENT(OUT) :: IQ(N) INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER, INTENT(OUT) :: IW(LW) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER, INTENT(INOUT) :: IFLAG INTEGER :: I,J,LBIG,IN,LEN,JDUMMY,L1 INTEGER(8) :: K, K1, K2, KL, KID IERROR = 0 DO 10 I=1,N IQ(I) = 0 10 CONTINUE DO 80 K=1_8,NZ I = IRN(K) J = ICN(K) IW(K) = -I IF (I.EQ.J) GOTO 40 IF (I.GT.J) GOTO 30 IF (I.GE.1 .AND. J.LE.N) GO TO 60 GO TO 50 30 IF (J.GE.1 .AND. I.LE.N) GO TO 60 GO TO 50 40 IW(K) = 0 IF (I.GE.1 .AND. I.LE.N) GO TO 80 50 IERROR = IERROR + 1 IW(K) = 0 IF (IERROR.LE.1 .AND. MP.GT.0) WRITE (MP,99999) IF (IERROR.LE.10 .AND. MP.GT.0) WRITE (MP,99998) K, I, J GO TO 80 60 IF (PERM(J).GT.PERM(I)) GO TO 70 IQ(J) = IQ(J) + 1 GO TO 80 70 IQ(I) = IQ(I) + 1 80 CONTINUE IF (IERROR.GE.1) THEN IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 ENDIF IWFR = 1_8 LBIG = 0 DO 100 I=1,N L1 = IQ(I) LBIG = max(L1,LBIG) IWFR = IWFR + int(L1,8) IPE(I) = IWFR - 1_8 100 CONTINUE DO 140 K=1_8,NZ I = -IW(K) IF (I.LE.0) GO TO 140 KL = K IW(K) = 0 DO 130 KID=1,NZ J = ICN(KL) IF (PERM(I).LT.PERM(J)) GO TO 110 KL = IPE(J) IPE(J) = KL - 1_8 IN = IW(KL) IW(KL) = I GO TO 120 110 KL = IPE(I) IPE(I) = KL - 1_8 IN = IW(KL) IW(KL) = J 120 I = -IN IF (I.LE.0) GO TO 140 130 CONTINUE 140 CONTINUE K = IWFR - 1_8 KL = K + int(N,8) IWFR = KL + 1_8 DO 170 I=1,N FLAG(I) = 0 J = N + 1 - I LEN = IQ(J) IF (LEN.LE.0) GO TO 160 DO 150 JDUMMY=1,LEN IW(KL) = IW(K) K = K - 1_8 KL = KL - 1_8 150 CONTINUE 160 IPE(J) = KL KL = KL - 1_8 170 CONTINUE IF (LBIG.GE.huge(N)) GO TO 190 DO 180 I=1,N K = IPE(I) IW(K) = IQ(I) IF (IQ(I).EQ.0) IPE(I) = 0_8 180 CONTINUE GO TO 230 190 IWFR = 1_8 DO 220 I=1,N K1 = IPE(I) + 1_8 K2 = IPE(I) + int(IQ(I),8) IF (K1.LE.K2) GO TO 200 IPE(I) = 0_8 GO TO 220 200 IPE(I) = IWFR IWFR = IWFR + 1_8 DO 210 K=K1,K2 J = IW(K) IF (FLAG(J).EQ.I) GO TO 210 IW(IWFR) = J IWFR = IWFR + 1_8 FLAG(J) = I 210 CONTINUE K = IPE(I) IW(K) = int(IWFR - K - 1_8) 220 CONTINUE 230 RETURN 99999 FORMAT (' *** WARNING MESSAGE FROM SMUMPS_ANA_J ***' ) 99998 FORMAT (I6, ' NON-ZERO (IN ROW, I6, 11H AND COLUMN ', I6, & ') IGNORED') END SUBROUTINE SMUMPS_ANA_J SUBROUTINE SMUMPS_ANA_D(N, IPE, IW, LW, IWFR,NCMPA) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(INOUT):: IPE(N) INTEGER, INTENT(INOUT) :: NCMPA INTEGER, INTENT(INOUT) :: IW(LW) INTEGER :: I, IR INTEGER(8) :: K1, K, K2, LWFR NCMPA = NCMPA + 1 DO 10 I=1,N K1 = IPE(I) IF (K1.LE.0_8) GO TO 10 IPE(I) = int(IW(K1), 8) IW(K1) = -I 10 CONTINUE IWFR = 1_8 LWFR = IWFR DO 60 IR=1,N IF (LWFR.GT.LW) GO TO 70 DO 20 K=LWFR,LW IF (IW(K).LT.0) GO TO 30 20 CONTINUE GO TO 70 30 I = -IW(K) IW(IWFR) = int(IPE(I)) IPE(I) = int(IWFR,8) K1 = K + 1_8 K2 = K + int(IW(IWFR),8) IWFR = IWFR + 1_8 IF (K1.GT.K2) GO TO 50 DO 40 K=K1,K2 IW(IWFR) = IW(K) IWFR = IWFR + 1_8 40 CONTINUE 50 LWFR = K2 + 1_8 60 CONTINUE 70 RETURN END SUBROUTINE SMUMPS_ANA_D SUBROUTINE SMUMPS_ANA_LNEW(N, IPE, NV, IPS, NE, NA, NFSIZ, & NODE, NSTEPS, & FILS, FRERE, ND, NEMIN, SUBORD, KEEP60, & KEEP20, KEEP38, NAMALG,NAMALGMAX, & CUMUL,KEEP50, ICNTL13, KEEP37, KEEP197, NSLAVES, & ALLOW_AMALG_TINY_NODES & , BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS & , INODE_Scalapack_CAND, NBSONS_Scalapack_CAND & , KEEP11, KEEP191, KEEP192, KEEP193 & ) IMPLICIT NONE INTEGER N, NSTEPS, KEEP60, KEEP20, KEEP38, KEEP50 INTEGER ND(N), NFSIZ(N) INTEGER IPE(N), FILS(N), FRERE(N), SUBORD(N) INTEGER NV(N), IPS(N), NE(N), NA(N), NODE(N) INTEGER NEMIN,AMALG_COUNT INTEGER NAMALG(N),NAMALGMAX, CUMUL(N) DOUBLE PRECISION SIZE_DADI_AMALGAMATED, PERCENT_FILL DOUBLE PRECISION ACCU, FLOPS_FATHER, FLOPS_SON, & FLOPS_AVANT, FLOPS_APRES INTEGER ICNTL13, KEEP37, NSLAVES LOGICAL ALLOW_AMALG_TINY_NODES INTEGER KEEP197 LOGICAL, INTENT(IN) :: BLKON INTEGER, INTENT(IN) :: LSIZEOFBLOCKS INTEGER, INTENT(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) INTEGER, INTENT(OUT):: INODE_Scalapack_CAND, & NBSONS_Scalapack_CAND INTEGER, INTENT(IN) :: KEEP11, KEEP191, KEEP192, KEEP193 #if defined(NOAMALGTOFATHER) #else #endif INTEGER I,IF,IS,NR,INS INTEGER K,L,ISON,IN,IFSON,INO INTEGER INOS,IB,IL INTEGER IPERM INTEGER MAXNODE INTEGER SIZE_Scalapack_CAND, NBSONS_current_root LOGICAL ROOT_WITH_FEW_SONS #if defined(NOAMALGTOFATHER) INTEGER INB,INF,INFS,INL,INSW,INT1,NR1 #else INTEGER DADI #endif LOGICAL AMALG_TO_father_OK AMALG_COUNT = 0 INODE_Scalapack_CAND = -1 NBSONS_Scalapack_CAND = -1 SIZE_Scalapack_CAND = -1 NBSONS_current_root = 0 DO 10 I=1,N CUMUL(I)= 0 IPS(I) = 0 NE(I) = 0 SUBORD(I) = 0 NAMALG(I) = 0 10 CONTINUE DO I=1,N IF (BLKON) THEN NODE(I) = SIZEOFBLOCKS(I) ELSE NODE(I) = 1 ENDIF ENDDO FRERE(1:N) = IPE(1:N) NR = N + 1 MAXNODE = 1 DO 50 I=1,N IF = -FRERE(I) IF (NV(I).EQ.0) THEN IF (SUBORD(IF).NE.0) SUBORD(I) = SUBORD(IF) SUBORD(IF) = I IF (BLKON) THEN NODE(IF) = NODE(IF)+SIZEOFBLOCKS(I) ELSE NODE(IF) = NODE(IF)+1 ENDIF MAXNODE = max(NODE(IF),MAXNODE) ELSE IF (IF.NE.0) THEN IS = -IPS(IF) IF (IS.GT.0) FRERE(I) = IS IPS(IF) = -I ELSE NR = NR - 1 NE(NR) = I ENDIF ENDIF 50 CONTINUE MAXNODE = int(dble(MAXNODE)*dble(NEMIN) / dble(100)) MAXNODE = max(MAXNODE,2000) #if defined(NOAMALGTOFATHER) DO 999 I=1,N FILS(I) = IPS(I) 999 CONTINUE NR1 = NR INS = 0 1000 IF (NR1.GT.N) GO TO 1151 INS = NE(NR1) NR1 = NR1 + 1 1070 INL = FILS(INS) IF (INL.LT.0) THEN INS = -INL GO TO 1070 ENDIF 1080 IF (FRERE(INS).LT.0) THEN INS = -FRERE(INS) FILS(INS) = 0 GO TO 1080 ENDIF IF (FRERE(INS).EQ.0) THEN INS = 0 GO TO 1000 ENDIF INB = FRERE(INS) IF (NV(INB).GE.NV(INS)) THEN INS = INB GO TO 1070 ENDIF INF = INB 1090 INF = FRERE(INF) IF (INF.GT.0) GO TO 1090 INF = -INF INFS = -FILS(INF) IF (INFS.EQ.INS) THEN FILS(INF) = -INB IPS(INF) = -INB FRERE(INS) = FRERE(INB) FRERE(INB) = INS ELSE INSW = INFS 1100 INFS = FRERE(INSW) IF (INFS.NE.INS) THEN INSW = INFS GO TO 1100 ENDIF FRERE(INS) = FRERE(INB) FRERE(INB) = INS FRERE(INSW)= INB ENDIF INS = INB GO TO 1070 1151 CONTINUE #endif DO 51 I=1,N FILS(I) = IPS(I) 51 CONTINUE IS = 1 I = 0 IPERM = 1 DO 160 K=1,N AMALG_TO_father_OK=.FALSE. IF (I.LE.0) THEN IF (NR.GT.N) EXIT I = NE(NR) NE(NR) = 0 NR = NR + 1 IL = N NA(N) = 0 NBSONS_current_root =0 IF (IPS(I).LT.0) THEN IB = -IPS(I) NBSONS_current_root = NBSONS_current_root + 1 69 IB =FRERE(IB) IF (IB.GT.0) THEN NBSONS_current_root = NBSONS_current_root + 1 GOTO 69 ENDIF ENDIF 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 DADI = -IPE(I) IF (DADI.EQ.0) THEN IF (NV(I) .GT. SIZE_Scalapack_CAND) THEN INODE_Scalapack_CAND = I SIZE_Scalapack_CAND = NV(I) ENDIF ENDIF #if ! defined(NOAMALGTOFATHER) IF ( (DADI.NE.0) .AND. & ( & (KEEP60.EQ.0).OR. & ( (KEEP20.NE.DADI).AND.(KEEP38.NE.DADI) ) & ) & ) THEN ACCU = dble(2)*dble(NODE(I))*dble(NV(DADI)-NV(I)+NODE(I)) SIZE_DADI_AMALGAMATED = & dble(NV(DADI)+NODE(I)) * & dble(NV(DADI)+NODE(I)) PERCENT_FILL = dble(100) * ACCU / SIZE_DADI_AMALGAMATED ACCU = ACCU + dble(CUMUL(I)) AMALG_TO_father_OK = ( & ( (NODE(I).LE.MAXNODE).AND.(NODE(DADI).LE.MAXNODE) ) & .OR. & ( (NODE(I).LE.NEMIN.and. NODE(DADI).GT. MAXNODE) & .OR.(NODE(DADI).LE.NEMIN .and. NODE(I).GT.MAXNODE))) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( PERCENT_FILL < dble(NEMIN) ) ) IF (KEEP197 .EQ. 1 ) THEN AMALG_TO_father_OK = AMALG_TO_father_OK.OR. & ( NODE(I).LE.2*NEMIN .AND. NODE(DADI).LT.4*NEMIN) ENDIF AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( ACCU / SIZE_DADI_AMALGAMATED .LE. dble(NEMIN)) ) IF (AMALG_TO_father_OK) THEN CALL MUMPS_GET_FLOPS_COST(NV(I),NODE(I),NODE(I), & KEEP50,1,FLOPS_SON) CALL MUMPS_GET_FLOPS_COST(NV(DADI),NODE(DADI), & NODE(DADI), & KEEP50,1,FLOPS_FATHER) FLOPS_AVANT = FLOPS_FATHER+FLOPS_SON & + max(dble(200.0) * dble(NV(I)-NODE(I)) & * dble(NV(I)-NODE(I)), & dble(10000.0)) CALL MUMPS_GET_FLOPS_COST(NV(DADI)+NODE(I), & NODE(DADI)+NODE(I), & NODE(DADI)+NODE(I), & KEEP50,1,FLOPS_APRES) IF (FLOPS_APRES.GT.FLOPS_AVANT* & (dble(1)+dble(max(8,NEMIN)-8)/dble(100))) THEN AMALG_TO_father_OK = .FALSE. ENDIF ENDIF ROOT_WITH_FEW_SONS =.TRUE. IF (KEEP11.GT.0) THEN IF (IPE(DADI).EQ.0) THEN IF & (NA(IL)+max(NA(IL+1),NBSONS_current_root) & .GT.KEEP11) & ROOT_WITH_FEW_SONS= .FALSE. ELSE IF & (NA(IL)+NA(IL+1)+max(NA(N),NBSONS_current_root) & .GT.KEEP11) & ROOT_WITH_FEW_SONS= .FALSE. ENDIF ENDIF IF ( (NV(I).GT. max(KEEP191,1)*NV(DADI)) & .AND. (NSLAVES.GT.1) & .AND. (ICNTL13.LE.0) & .AND. (NV(I).GT. KEEP37) & .AND. ROOT_WITH_FEW_SONS & ) THEN IF ( ( ACCU / SIZE_DADI_AMALGAMATED ) .LT. & 10.0D0/dble(max(KEEP191,1)) ) THEN AMALG_TO_father_OK = .TRUE. ENDIF ENDIF IF ( ALLOW_AMALG_TINY_NODES .AND. & (NODE(I)*max(KEEP192,1)) .LE. (NV(DADI)-NAMALG(DADI)) ) & THEN IF ( NAMALG(DADI) < & (NV(DADI)-NAMALG(DADI))/max(KEEP193,1) ) THEN AMALG_TO_father_OK = .TRUE. NAMALG(DADI) = NAMALG(DADI) + NODE(I) ENDIF ENDIF IF ( DADI .EQ. -FRERE(I) & .AND. -FILS(DADI).EQ.I & ) THEN AMALG_TO_father_OK = ( AMALG_TO_father_OK .OR. & ( NV(I)-NODE(I).EQ.NV(DADI)) ) ENDIF IF (AMALG_TO_father_OK) THEN CUMUL(DADI)=CUMUL(DADI)+nint(ACCU) NAMALG(DADI) = NAMALG(DADI) + NAMALG(I) AMALG_COUNT = AMALG_COUNT+1 IN = DADI 75 IF (SUBORD(IN).EQ.0) GOTO 76 IN = SUBORD(IN) GOTO 75 76 CONTINUE SUBORD(IN) = I NV(I) = 0 IFSON = -FILS(DADI) IF (IFSON.EQ.I) THEN IF (FILS(I).LT.0) THEN FILS(DADI) = FILS(I) GOTO 78 ELSE IF (FRERE(I).GT.0) THEN FILS(DADI) = -FRERE(I) ELSE FILS(DADI) = 0 ENDIF GOTO 90 ENDIF ENDIF IN = IFSON 77 INS = IN IN = FRERE(IN) IF (IN.NE.I) GOTO 77 IF (FILS(I) .LT.0) THEN FRERE(INS) = -FILS(I) ELSE FRERE(INS) = FRERE(I) GOTO 90 ENDIF 78 CONTINUE IN = -FILS(I) 79 INO = IN IN = FRERE(IN) IF (IN.GT.0) GOTO 79 FRERE(INO) = FRERE(I) 90 CONTINUE NODE(DADI) = NODE(DADI)+ NODE(I) NV(DADI) = NV(DADI) + NODE(I) NA(IL+1) = NA(IL+1) + NA(IL) GOTO 120 ENDIF ENDIF #endif NE(IS) = NE(IS) + NODE(I) IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1 NA(IS) = NA(IL) ND(IS) = NV(I) NODE(I) = IS IPS(I) = IPERM IPERM = IPERM + 1 IN = I 777 IF (SUBORD(IN).EQ.0) GO TO 778 IN = SUBORD(IN) NODE(IN) = IS IPS(IN) = IPERM IPERM = IPERM + 1 GO TO 777 778 IF (NA(IS).LE.0) GO TO 110 #if defined(NOAMALGTOFATHER) IF ( (KEEP60.NE.0).AND. & (NE(IS).EQ.ND(IS)) ) GOTO 110 IF (ND(IS-1)-NE(IS-1).EQ.ND(IS)) THEN GO TO 100 ENDIF IF(NAMALG(IS-1) .GE. NAMALGMAX) THEN GOTO 110 ENDIF IF ((NE(IS-1).GE.NEMIN).AND. & (NE(IS).GE.NEMIN) ) GO TO 110 IF (2*NE(IS-1)*(ND(IS)-ND(IS-1)+NE(IS-1)).GE. & ((ND(IS)+NE(IS-1))* & (ND(IS)+NE(IS-1))*NEMIN/100)) GO TO 110 NAMALG(IS-1) = NAMALG(IS-1)+1 100 NA(IS-1) = NA(IS-1) + NA(IS) - 1 ND(IS-1) = ND(IS) + NE(IS-1) NE(IS-1) = NE(IS) + NE(IS-1) NE(IS) = 0 NODE(I) = IS-1 IFSON = -FILS(I) IN = IFSON 102 INO = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 102 NV(INO) = 0 IN = I 888 IF (SUBORD(IN).EQ.0) GO TO 889 IN = SUBORD(IN) GO TO 888 889 SUBORD(IN) = INO INOS = -FILS(INO) IF (IFSON.EQ.INO) THEN FILS(I) = -INOS GO TO 107 ENDIF IN = IFSON 105 INS = IN IN = FRERE(IN) IF (IN.NE.INO) GO TO 105 IF (INOS.EQ.0) THEN FRERE(INS) = -I GO TO 120 ELSE FRERE(INS) = INOS ENDIF 107 IN = INOS IF (IN.EQ.0) GO TO 120 108 INT1 = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 108 FRERE(INT1) = -I GO TO 120 #endif 110 IS = IS + 1 120 IB = FRERE(I) IF (IB.GE.0) THEN IF (IB.GT.0) NA(IL) = 0 I = IB ELSE I = -IB IL = IL + 1 ENDIF 160 CONTINUE NSTEPS = IS - 1 I = INODE_Scalapack_CAND INOS = -FILS(I) NBSONS_Scalapack_CAND = 0 IF (INOS.GT.0) THEN NBSONS_Scalapack_CAND = NBSONS_Scalapack_CAND+1 INO = FRERE(INOS) DO WHILE (INO.GT.0 .AND. INO.LE.N) NBSONS_Scalapack_CAND = NBSONS_Scalapack_CAND+1 INO = FRERE(INO) ENDDO ENDIF DO I=1, N IF (NV(I).EQ.0) THEN FRERE(I) = N+1 NFSIZ(I) = 0 ELSE NFSIZ(I) = ND(NODE(I)) IF (SUBORD(I) .NE.0) THEN INOS = -FILS(I) INO = I DO WHILE (SUBORD(INO).NE.0) IS = SUBORD(INO) FILS(INO) = IS INO = IS END DO FILS(INO) = -INOS ENDIF ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_ANA_LNEW SUBROUTINE SMUMPS_ANA_M(NE, ND, NSTEPS, & MAXFR, MAXELIM, K50, SIZEFAC_TOT, MAXNPIV, & K5,K6,PANEL_SIZE,K253) IMPLICIT NONE INTEGER, INTENT(in) :: NSTEPS, K50, K253, K5, K6 INTEGER, INTENT(in) :: NE(NSTEPS), ND(NSTEPS) INTEGER, INTENT(out) :: MAXNPIV, PANEL_SIZE INTEGER, INTENT(out) :: MAXFR, MAXELIM INTEGER(8), INTENT(out):: SIZEFAC_TOT INTEGER ITREE, NFR, NELIM INTEGER LKJIB INTEGER(8) :: SIZEFAC LKJIB = max(K5,K6) MAXFR = 0 MAXELIM = 0 MAXNPIV = 0 PANEL_SIZE = 0 SIZEFAC_TOT = 0_8 DO ITREE=1,NSTEPS NELIM = NE(ITREE) NFR = ND(ITREE) + K253 IF (NFR.GT.MAXFR) MAXFR = NFR IF (NFR-NELIM.GT.MAXELIM) MAXELIM = NFR - NELIM IF (NELIM .GT. MAXNPIV) THEN MAXNPIV = NELIM ENDIF IF (K50.EQ.0) THEN SIZEFAC = (2_8*int(NFR,8) - int(NELIM,8))*int(NELIM,8) PANEL_SIZE = max(PANEL_SIZE, NFR*(LKJIB+1)) ELSE SIZEFAC = int(NFR,8) * int(NELIM,8) PANEL_SIZE = max(PANEL_SIZE, NELIM*(LKJIB+1)) PANEL_SIZE = max(PANEL_SIZE, (NFR-NELIM)*(LKJIB+1)) ENDIF SIZEFAC_TOT = SIZEFAC_TOT + SIZEFAC END DO RETURN END SUBROUTINE SMUMPS_ANA_M SUBROUTINE SMUMPS_ANA_R( N, FILS, FRERE, & NSTK, NA ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: FILS(N), FRERE(N) INTEGER, INTENT(OUT) :: NSTK(N), NA(N) INTEGER NBROOT, NBLEAF, ILEAF, I, IN, ISON NA = 0 NSTK = 0 NBROOT = 0 ILEAF = 1 DO 11 I=1,N IF (FRERE(I).EQ. N+1) CYCLE IF (FRERE(I).EQ.0) NBROOT = NBROOT + 1 IN = I 12 IN = FILS(IN) IF (IN.GT.0) GO TO 12 IF (IN.EQ.0) THEN NA(ILEAF) = I ILEAF = ILEAF + 1 CYCLE ENDIF ISON = -IN 13 NSTK(I) = NSTK(I) + 1 ISON = FRERE(ISON) IF (ISON.GT.0) GO TO 13 11 CONTINUE NBLEAF = ILEAF-1 IF (N.GT.1) THEN IF (NBLEAF.GT.N-2) THEN IF (NBLEAF.EQ.N-1) THEN NA(N-1) = -NA(N-1)-1 NA(N) = NBROOT ELSE NA(N) = -NA(N)-1 ENDIF ELSE NA(N-1) = NBLEAF NA(N) = NBROOT ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_ANA_R SUBROUTINE SMUMPS_DIAG_ANA &( MYID, COMM, KEEP,KEEP8, INFO, INFOG, RINFO, RINFOG, ICNTL, & SIZE_SCHUR ) IMPLICIT NONE INTEGER, INTENT(IN) :: COMM, MYID, KEEP(500), INFO(80), & ICNTL(60), INFOG(80), SIZE_SCHUR INTEGER(8), INTENT(IN) :: KEEP8(150) REAL, INTENT(IN) :: RINFO(40), RINFOG(40) INCLUDE 'mpif.h' INTEGER MASTER, MPG INTEGER ITMP, ICNTL48_EFF PARAMETER( MASTER = 0 ) MPG = ICNTL(3) IF ( MYID.eq.MASTER.and.MPG.GT.0.AND.ICNTL(4).GE.2) THEN ITMP = KEEP(13) IF (ICNTL(15).EQ.0) THEN ITMP = 0 ENDIF IF (KEEP(400).GT.0) THEN ICNTL48_EFF=1 ELSE ICNTL48_EFF=0 ENDIF 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(95), ICNTL(13), KEEP(12), & ITMP, & ICNTL(18), KEEP(252), KEEP(494), & ICNTL48_EFF, & KEEP(106), & 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), SIZE_SCHUR IF (KEEP(251).GT.0) WRITE(MPG, 99997) KEEP(251) IF (KEEP(253).GT.0) WRITE(MPG, 99996) KEEP(253) ENDIF RETURN 99992 FORMAT(/'Leaving analysis phase with ...'/ & ' INFOG(1) =',I16/ & ' INFOG(2) =',I16/ & ' -- (20) Number of entries in factors (estim.) =',I16/ & ' -- (3) Real space for factors (estimated) =',I16/ & ' -- (4) Integer space for factors (estimated) =',I16/ & ' -- (5) Maximum frontal size (estimated) =',I16/ & ' -- (6) Number of nodes in the tree =',I16/ & ' -- (32) Type of analysis effectively used =',I16/ & ' -- (7) Ordering option effectively used =',I16/ & ' ICNTL (6) Maximum transversal option =',I16/ & ' ICNTL (7) Pivot order option =',I16/ & ' ICNTL(12) Ordering symmetric indef. matrices =',I16/ & ' ICNTL(13) Parallelism/splitting of root node =',I16/ & ' ICNTL(14) Percentage of memory relaxation =',I16/ & ' ICNTL(15) Analysis by block effectively used =',I16/ & ' ICNTL(18) Distributed input matrix (on if >0) =',I16/ & ' ICNTL(32) Forward elimination during facto. =',I16/ & ' ICNTL(35) BLR activation =',I16/ & ' ICNTL(48) Tree based multithreading (effective)=',I16/ & ' ICNTL(58) Symbolic factorization option =',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/ & ' Size of Schur (SIZE_SCHUR) =',I16) 99996 FORMAT(' Forward solution during factorization, NRHS =',I16) 99997 FORMAT(' ICNTL(31) Discard factors (eff. value) =',I16) END SUBROUTINE SMUMPS_DIAG_ANA SUBROUTINE SMUMPS_CUTNODES & ( N, FRERE, FILS, NFSIZ, SIZEOFBLOCKS, LSIZEOFBLOCKS, & NSTEPS, NSLAVES, & KEEP, KEEP8, SPLITROOT, MP, LDIAG, INFO1, INFO2 ) IMPLICIT NONE INTEGER N, NSTEPS, NSLAVES, KEEP(500) INTEGER(8) KEEP8(150) INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) INTEGER LSIZEOFBLOCKS INTEGER SIZEOFBLOCKS(LSIZEOFBLOCKS) LOGICAL SPLITROOT INTEGER MP, LDIAG INTEGER INFO1, INFO2 INTEGER, DIMENSION(:), ALLOCATABLE :: IPOOL INTEGER INODE, DEPTH, I, IBEG, IEND, IIPOOL, NROOT INTEGER MAX_DEPTH, ISON, TOT_CUT, MAX_CUT, STRAT INTEGER(8) :: K79 INTEGER K82, allocok LOGICAL BLKON BLKON = .NOT.(SIZEOFBLOCKS(1).EQ.-1) K79 = KEEP8(79) K82 = abs(KEEP(82)) STRAT= KEEP(62) IF (KEEP(210).EQ.1) THEN MAX_DEPTH = 2*NSLAVES*K82 STRAT = STRAT/4 ELSE IF (( NSLAVES .eq. 1 ).AND. (.NOT. SPLITROOT) ) RETURN IF (NSLAVES.EQ.1) THEN MAX_DEPTH=1 ELSE MAX_DEPTH = int( log( real( NSLAVES - 1 ) ) & / log(2.0E0) ) ENDIF ENDIF ALLOCATE(IPOOL(NSTEPS+1), stat=allocok) IF (allocok.GT.0) THEN INFO1= -7 INFO2= NSTEPS+1 RETURN ENDIF NROOT = 0 DO INODE = 1, N IF ( FRERE(INODE) .eq. 0 ) THEN NROOT = NROOT + 1 IPOOL( NROOT ) = INODE END IF END DO IBEG = 1 IEND = NROOT IIPOOL = NROOT + 1 IF (SPLITROOT) THEN MAX_DEPTH=0 ENDIF DO DEPTH = 1, MAX_DEPTH DO I = IBEG, IEND INODE = IPOOL( I ) ISON = INODE DO WHILE ( ISON .GT. 0 ) ISON = FILS( ISON ) END DO ISON = - ISON DO WHILE ( ISON .GT. 0 ) IPOOL( IIPOOL ) = ISON IIPOOL = IIPOOL + 1 ISON = FRERE( ISON ) END DO END DO IPOOL( IBEG ) = -IPOOL( IBEG ) IBEG = IEND + 1 IEND = IIPOOL - 1 END DO IPOOL( IBEG ) = -IPOOL( IBEG ) TOT_CUT = 0 IF (SPLITROOT) THEN MAX_CUT = NROOT*max(K82,2) IF (KEEP(72).EQ.1) THEN K79 = min(3_8*3_8,K79) ELSE K79 = min(2000_8*2000_8,K79) IF (KEEP(376) .EQ. 1) THEN K79 = min(int(KEEP(9)+1,8)*int(KEEP(9)+1,8),K79) ENDIF ENDIF IF (KEEP(53).NE.0) THEN K79 = 121_8*121_8 ENDIF ELSE MAX_CUT = 2 * NSLAVES IF (KEEP(210).EQ.1) THEN MAX_CUT = 4 * (MAX_CUT + 4) ENDIF ENDIF DEPTH = -1 DO I = 1, IIPOOL - 1 INODE = IPOOL( I ) IF ( INODE .LT. 0 ) THEN INODE = -INODE DEPTH = DEPTH + 1 END IF CALL SMUMPS_SPLIT_1NODE & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, & KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IF ( TOT_CUT > MAX_CUT ) EXIT END DO KEEP(61) = TOT_CUT DEALLOCATE(IPOOL) RETURN END SUBROUTINE SMUMPS_CUTNODES RECURSIVE SUBROUTINE SMUMPS_SPLIT_1NODE & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, KEEP,KEEP8, & TOT_CUT, STRAT, DEPTH, K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IMPLICIT NONE INTEGER(8) :: K79 INTEGER INODE, N, NSTEPS, NSLAVES, KEEP(500), STRAT, & DEPTH, TOT_CUT, MP, LDIAG INTEGER(8) KEEP8(150) INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) LOGICAL SPLITROOT LOGICAL BLKON INTEGER LSIZEOFBLOCKS INTEGER SIZEOFBLOCKS(LSIZEOFBLOCKS) INTEGER I, IN, NPIV, NFRONT, NSLAVES_ESTIM REAL WK_SLAVE, WK_MASTER INTEGER INODE_SON, INODE_FATH, IN_SON, IN_FATH, IN_GRANDFATH INTEGER NPIV_COMPG, NPIV_SON_COMPG, NPIV_FATH_COMPG INTEGER NPIV_SON, NPIV_FATH, NPIV_TEMP INTEGER NCB, NSLAVESMIN, NSLAVESMAX INTEGER MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX EXTERNAL MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX IF ( (KEEP(210).EQ.1.AND.KEEP(60).EQ.0) .OR. & (SPLITROOT) ) THEN IF ( FRERE ( INODE ) .eq. 0 ) THEN NFRONT = NFSIZ( INODE ) NPIV = NFRONT IF (BLKON) THEN IN = INODE NPIV_COMPG = 0 DO WHILE( IN > 0 ) NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) ENDDO ELSE NPIV_COMPG = NPIV ENDIF NCB = 0 IF ( int(NFRONT,8)*int(NFRONT,8).GT.K79 & ) THEN GOTO 333 ENDIF ENDIF ENDIF IF ( FRERE ( INODE ) .eq. 0 ) RETURN NFRONT = NFSIZ( INODE ) IN = INODE NPIV = 0 NPIV_COMPG = 0 DO WHILE( IN > 0 ) IF (BLKON) THEN NPIV = NPIV + SIZEOFBLOCKS(IN) ENDIF NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) END DO IF (.NOT.BLKON) NPIV = NPIV_COMPG NCB = NFRONT - NPIV IF ( (NFRONT - (NPIV/2)) .LE. KEEP(9)) RETURN IF ((KEEP(50) == 0.and.int(NFRONT,8) * int(NPIV,8) > K79 ) .OR. &(KEEP(50) .NE.0.and.int(NPIV,8) * int(NPIV,8) > K79 )) GOTO 333 IF (KEEP(210).EQ.1) THEN NSLAVESMIN = 1 NSLAVESMAX = 64 NSLAVES_ESTIM = 32+NSLAVES ELSE NSLAVESMIN = MUMPS_BLOC2_GET_NSLAVESMIN & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375), KEEP(119)) NSLAVESMAX = MUMPS_BLOC2_GET_NSLAVESMAX & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375), KEEP(119)) NSLAVES_ESTIM = max (1, & nint( real(NSLAVESMAX-NSLAVESMIN)/real(3) ) & ) NSLAVES_ESTIM = min (NSLAVES_ESTIM, NSLAVES-1) ENDIF IF ( KEEP(50) .eq. 0 ) THEN WK_MASTER = 0.6667E0 * & real(NPIV)*real(NPIV)*real(NPIV) + & real(NPIV)*real(NPIV)*real(NCB) WK_SLAVE = real( NPIV ) * real( NCB ) * & ( 2.0E0 * real(NFRONT) - real(NPIV) ) & / real(NSLAVES_ESTIM) ELSE WK_MASTER = real(NPIV)*real(NPIV)*real(NPIV) / real(3) WK_SLAVE = & (real(NPIV)*real(NCB)*real(NFRONT)) & / real(NSLAVES_ESTIM) ENDIF IF (KEEP(210).EQ.1) THEN IF ( real( 100 + STRAT ) & * WK_SLAVE / real(100) .GE. WK_MASTER ) RETURN ELSE IF ( real( 100 + STRAT * max( DEPTH-1, 1 ) ) & * WK_SLAVE / real(100) .GE. WK_MASTER ) RETURN ENDIF 333 CONTINUE IF (NPIV .LE. 1 ) RETURN NPIV_SON = max(NPIV/2,1) NPIV_FATH = NPIV - NPIV_SON IF (SPLITROOT) THEN IF (NCB .NE .0) THEN WRITE(*,*) "Error splitting" CALL MUMPS_ABORT() ENDIF NPIV_FATH = min(int(sqrt(real(K79))), int(NPIV/2)) NPIV_SON = NPIV - NPIV_FATH ENDIF INODE_SON = INODE IF (BLKON) THEN NPIV_TEMP = 0 NPIV_SON_COMPG = 0 IN_SON = INODE DO WHILE (IN_SON > 0) NPIV_TEMP = NPIV_TEMP + SIZEOFBLOCKS(IN_SON) NPIV_SON_COMPG = NPIV_SON_COMPG +1 IF (NPIV_TEMP.GE.NPIV_SON) EXIT IN_SON = FILS( IN_SON ) END DO NPIV_FATH_COMPG = NPIV_COMPG - NPIV_SON_COMPG NPIV_SON = NPIV_TEMP NPIV_FATH = NPIV - NPIV_SON ELSE NPIV_SON_COMPG = NPIV_SON NPIV_FATH_COMPG = NPIV_FATH IN_SON = INODE DO I = 1, NPIV_SON_COMPG - 1 IN_SON = FILS( IN_SON ) END DO ENDIF IF (NPIV_FATH_COMPG.EQ.0) RETURN NSTEPS = NSTEPS + 1 TOT_CUT = TOT_CUT + 1 INODE_FATH = FILS( IN_SON ) IF ( INODE_FATH .LT. 0 ) THEN write(*,*) 'Error: INODE_FATH < 0 ', INODE_FATH END IF IN_FATH = INODE_FATH DO WHILE ( FILS( IN_FATH ) > 0 ) IN_FATH = FILS( IN_FATH ) END DO FRERE( INODE_FATH ) = FRERE( INODE_SON ) FRERE( INODE_SON ) = - INODE_FATH FILS ( IN_SON ) = FILS( IN_FATH ) FILS ( IN_FATH ) = - INODE_SON IN = FRERE( INODE_FATH ) DO WHILE ( IN > 0 ) IN = FRERE( IN ) END DO IF ( IN .eq. 0 ) GO TO 10 IN = -IN DO WHILE ( FILS( IN ) > 0 ) IN = FILS( IN ) END DO IN_GRANDFATH = IN IF ( FILS( IN_GRANDFATH ) .eq. - INODE_SON ) THEN FILS( IN_GRANDFATH ) = -INODE_FATH ELSE IN = IN_GRANDFATH IN = - FILS ( IN ) DO WHILE ( FRERE( IN ) > 0 ) IF ( FRERE( IN ) .eq. INODE_SON ) THEN FRERE( IN ) = INODE_FATH GOTO 10 END IF IN = FRERE( IN ) END DO WRITE(*,*) 'ERROR 2 in SPLIT NODE', & IN_GRANDFATH, IN, FRERE(IN) END IF 10 CONTINUE NFSIZ(INODE_SON) = NFRONT NFSIZ(INODE_FATH) = NFRONT - NPIV_SON KEEP(2) = max( KEEP(2), NFRONT - NPIV_SON ) IF (SPLITROOT) THEN RETURN ENDIF CALL SMUMPS_SPLIT_1NODE & ( INODE_FATH, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IF (.NOT. SPLITROOT) THEN CALL SMUMPS_SPLIT_1NODE & ( INODE_SON, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) ENDIF RETURN END SUBROUTINE SMUMPS_SPLIT_1NODE SUBROUTINE SMUMPS_SPLIT_ROOT & ( NSLAVES, HOW, INODE, N, FRERE, FILS, NFSIZ, KEEP, KEEP8, & SIZEOFBLOCKS, LSIZEOFBLOCKS, NSTEPS) IMPLICIT NONE INTEGER, INTENT(in) :: NSLAVES, HOW INTEGER, INTENT(in) :: INODE, N INTEGER(8), INTENT(in) :: KEEP8(150) INTEGER, INTENT(inout) :: NSTEPS INTEGER, INTENT(inout) :: KEEP(500) INTEGER, INTENT(inout) :: FRERE( N ), FILS( N ), NFSIZ( N ) INTEGER, INTENT(IN) :: LSIZEOFBLOCKS INTEGER, INTENT(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) LOGICAL :: BLKON INTEGER(8) :: K79 INTEGER I, IN, NPIV, NFRONT INTEGER INODE_SON, INODE_FATH, IN_SON, IN_FATH, IN_GRANDFATH INTEGER NPIV_COMPG, NPIV_SON_COMPG, NPIV_FATH_COMPG INTEGER NPIV_SON, NPIV_FATH, NPIV_TEMP INTEGER, PARAMETER :: K_HOW1 = 4000 IF (FRERE(INODE).NE.0) RETURN BLKON = .NOT.(SIZEOFBLOCKS(1).EQ.-1) K79 = max(KEEP8(79), 4_8) K79 = min(20000_8*20000_8,K79) IF (KEEP(72).EQ.1) THEN K79 = min(3_8*3_8,K79) ENDIF IF ((HOW.LT.1) .OR. (HOW.GT.3)) THEN RETURN ENDIF IF (HOW.EQ.2) THEN K79 = min(K79, 121_8*121_8) ENDIF NFRONT = NFSIZ (INODE) NPIV = NFRONT IF (NPIV .LE. 1 ) RETURN IF (BLKON) THEN IN = INODE NPIV_COMPG = 0 DO WHILE( IN > 0 ) NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) ENDDO ELSE NPIV_COMPG = NPIV ENDIF IF (HOW.EQ.1) THEN IF ( (NFRONT/2) .LT. K_HOW1 ) RETURN NPIV_FATH = max(NFRONT/max(NSLAVES,2), 1) NPIV_FATH = max(NPIV_FATH, K_HOW1/2) NPIV_FATH = min(NPIV_FATH, max(NFRONT/2,1)) NPIV_FATH = min(int(sqrt(real(K79))), NPIV_FATH) NPIV_SON = NPIV - NPIV_FATH ELSE IF (HOW.EQ.2) THEN NPIV_FATH = min(int(sqrt(real(K79))), int(NPIV/2)) NPIV_SON = NPIV - NPIV_FATH ELSE NPIV_FATH = max(NFRONT - 3*KEEP(6),1) NPIV_SON = NPIV - NPIV_FATH ENDIF INODE_SON = INODE IF (BLKON) THEN NPIV_TEMP = 0 NPIV_SON_COMPG = 0 IN_SON = INODE DO WHILE (IN_SON > 0) NPIV_TEMP = NPIV_TEMP + SIZEOFBLOCKS(IN_SON) NPIV_SON_COMPG = NPIV_SON_COMPG +1 IF (NPIV_TEMP.GE.NPIV_SON) EXIT IN_SON = FILS( IN_SON ) END DO NPIV_FATH_COMPG = NPIV_COMPG - NPIV_SON_COMPG NPIV_SON = NPIV_TEMP NPIV_FATH = NPIV - NPIV_SON ELSE NPIV_SON_COMPG = NPIV_SON NPIV_FATH_COMPG = NPIV_FATH IN_SON = INODE DO I = 1, NPIV_SON_COMPG - 1 IN_SON = FILS( IN_SON ) END DO ENDIF IF (NPIV_FATH_COMPG.EQ.0) RETURN 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 ) NSTEPS = NSTEPS + 1 IF ( (KEEP(53).EQ.0) .AND. NSLAVES.GT.1) THEN KEEP(38) = INODE_FATH ENDIF IF ( KEEP(53).NE.0 ) THEN KEEP(20) = INODE_FATH ENDIF RETURN END SUBROUTINE SMUMPS_SPLIT_ROOT SUBROUTINE SMUMPS_ANA_GNEW & (N, NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, NBQD, AvgDens, & KEEP264, KEEP265, PRINTSTAT, & INPLACE64_GRAPH_COPY & ) IMPLICIT NONE INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) INTEGER, intent(inout) :: IERROR INTEGER, intent(out) :: symmetry INTEGER, intent(out) :: NBQD, AvgDens INTEGER, intent(out) :: LEN(N), IW(LW) INTEGER(8), intent(out):: IWFR INTEGER(8), intent(out):: NRORM, NIORM INTEGER(8), intent(out):: IPE(N+1) INTEGER, intent(inout) :: IFLAG, KEEP264, KEEP265 INTEGER(8), intent(out):: IQ(N) INTEGER, intent(out) :: FLAG(N) LOGICAL, intent(in) :: PRINTSTAT LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, MPG, I, J, N1 INTEGER :: NBERR, THRESH, IERROR_LOC INTEGER(8) :: K8, K1, K2, LAST, NDUP INTEGER(8) :: NZOFFA, NDIAGA, L, N8 REAL :: RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) NZOFFA = 0_8 NDIAGA = 0 IERROR_LOC = 0 N8 = int(N,8) DO I=1,N+1 IPE(I) = 0_8 ENDDO IF (KEEP264.EQ.0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR_LOC = IERROR_LOC + 1 ELSE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR_LOC = IERROR_LOC + 1 ELSE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.EQ.J) THEN NDIAGA = NDIAGA + 1_8 ELSE IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDDO ENDIF ENDIF NIORM = NZOFFA + 3_8*N8 IF ((IERROR_LOC.GE.1).AND.(mod(IFLAG,2) .EQ. 0)) THEN IFLAG = IFLAG+1 IERROR = IERROR_LOC IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN NBERR = 0 WRITE (MP,99999) DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR. & (10_8.LE.K8 .AND. K8.LE.20_8)) THEN WRITE (MP,'(I16,A,I10,A,I10,A)') & K8,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K8,10_8).EQ.1_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'st entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.2_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.3_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE EXIT ENDIF ENDIF ENDDO ENDIF ENDIF NRORM = NIORM - 2_8*N8 IQ(1) = 1_8 N1 = N - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(N)+IQ(N)-1,IQ(N)) FLAG(1:N) = 0 IPE(1:N) = IQ(1:N) IW(1:LAST) = 0 IWFR = LAST + 1_8 IF (KEEP264 .EQ. 0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF (I.LT.J) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDDO ENDIF ENDIF IF (KEEP265.EQ.0) THEN NDUP = 0_8 DO I=1,N K1 = IPE(I) K2 = IQ(I) - 1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) EXIT IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE L = IQ(J) IW(L) = I IQ(J) = L + 1 IW(K8) = J FLAG(J) = I ENDIF END DO LEN(I) = int((IQ(I) - IPE(I))) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,N IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K1 = IPE(I) K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF 270 CONTINUE LEN(I) = int(IWFR - L) ENDDO ELSE KEEP265 = 1 ENDIF IPE(N+1) = IPE(N) + int(LEN(N),8) IWFR = IPE(N+1) ELSE IPE(1) = 1_8 DO I = 1, N LEN(I) = int(IQ(I) - IPE(I)) ENDDO DO I = 1, N IPE(I+1) = IPE(I) + int(LEN(I),8) ENDDO IWFR = IPE(N+1) ENDIF symmetry = 100 IF (SYM.EQ.0) THEN RSYM = real(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/ & real(NZOFFA+NDIAGA) IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) & THEN KEEP265 = -1 ENDIF symmetry = min(nint (100.0E0*RSYM), 100) IF (PRINTSTAT) THEN IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) ) & write(MPG,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) ) & write(MP,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry ENDIF ELSE ENDIF AvgDens = nint(real(IWFR-1_8)/real(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN DO I= 1, N J = max(LEN(I),1) IF (J.GT.THRESH) NBQD = NBQD+1 ENDDO ENDIF INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1_8)) IF (PRINTSTAT) THEN IF (MPG .GT. 0.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2)) & write(MP,'(A,1I5)') & ' Average density of rows/columns =', AvgDens ENDIF RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE SMUMPS_ANA_GNEW SUBROUTINE SMUMPS_SET_K821_SURFACE & (KEEP821, KEEP2, KEEP48 ,KEEP50, NSLAVES) IMPLICIT NONE INTEGER NSLAVES, KEEP2, KEEP48, KEEP50 INTEGER (8) :: KEEP821 INTEGER(8) KEEP2_SQUARE, NSLAVES8 NSLAVES8= int(NSLAVES,8) KEEP2_SQUARE = int(KEEP2,8) * int(KEEP2,8) KEEP821 = max(KEEP821*int(KEEP2,8),1_8) #if defined(t3e) KEEP821 = min(1500000_8, KEEP821) #elif defined(SP_) KEEP821 = min(3000000_8, KEEP821) #else KEEP821 = min(2000000_8, KEEP821) #endif #if defined(t3e) IF (NSLAVES .GT. 64) THEN KEEP821 = & min(8_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ELSE KEEP821 = & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ENDIF #else IF (NSLAVES.GT.64) THEN KEEP821 = & min(6_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ELSE KEEP821 = & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ENDIF #endif IF (KEEP50 .EQ. 0 ) THEN KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) ELSE KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) ENDIF IF (KEEP50 .EQ. 0 ) THEN #if defined(t3e) KEEP821 = max(KEEP821,200000_8) #else KEEP821 = max(KEEP821,300000_8) #endif ELSE #if defined(t3e) KEEP821 = max(KEEP821,40000_8) #else KEEP821 = max(KEEP821,80000_8) #endif ENDIF KEEP821 = -KEEP821 RETURN END SUBROUTINE SMUMPS_SET_K821_SURFACE SUBROUTINE SMUMPS_MTRANS_DRIVER(JOB,M,N,NE, & IP,IRN,A,LA,NUM,PERM,LIW,IW,LDW,DW, & IPQ8, & ICNTL,CNTL,INFO, INFOMUMPS) IMPLICIT NONE INTEGER :: NICNTL, NCNTL, NINFO, INFOMUMPS(80) PARAMETER (NICNTL=10, NCNTL=10, NINFO=10) INTEGER :: JOB,M,N,NUM INTEGER(8), INTENT(IN) :: NE, LIW,LDW, LA INTEGER(8) :: IP(N+1), IPQ8(N) INTEGER :: IRN(NE),PERM(M),IW(LIW) INTEGER :: ICNTL(NICNTL),INFO(NINFO) REAL :: A(LA) REAL :: DW(LDW),CNTL(NCNTL) INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWtemp8 INTEGER :: allocok INTEGER :: I,J,WARN1,WARN2,WARN4 INTEGER(8) :: K REAL :: FACT,ZERO,ONE,RINF,RINF2,RINF3 PARAMETER (ZERO=0.0E+00,ONE=1.0E+0) EXTERNAL SMUMPS_MTRANSZ,SMUMPS_MTRANSB,SMUMPS_MTRANSR, & SMUMPS_MTRANSS,SMUMPS_MTRANSW INTRINSIC abs,log RINF = CNTL(2) RINF2 = huge(RINF2)/real(int(2,8)*int(N,8)) RINF3 = 0.0E0 WARN1 = 0 WARN2 = 0 WARN4 = 0 IF (JOB.LT.1 .OR. JOB.GT.6) THEN INFO(1) = -1 INFO(2) = JOB IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'JOB',JOB GO TO 99 ENDIF IF (M.LT.1 .OR. M.LT.N) THEN INFO(1) = -2 INFO(2) = M IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'M',M GO TO 99 ENDIF IF (N.LT.1) THEN INFO(1) = -2 INFO(2) = N IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'N',N GO TO 99 ENDIF IF (NE.LT.1) THEN INFO(1) = -3 CALL MUMPS_SET_IERROR(NE,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'NE',NE GO TO 99 ENDIF IF (JOB.EQ.1) K = 4_8*int(N,8)+int(M,8) IF (JOB.EQ.2) K = int(N,8) + 2_8*int(M,8) IF (JOB.EQ.3) K = 8_8*int(N,8) + 2*int(M,8) + NE IF (JOB.EQ.4) K = int(N,8) + int(M,8) IF (JOB.EQ.5) K = 3_8*int(N,8) + 2_8*int(M,8) IF (JOB.EQ.6) K = 3_8*int(N,8) + 2_8*int(M,8) + NE IF (LIW.LT.K) THEN INFO(1) = -4 CALL MUMPS_SET_IERROR(K,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9004) INFO(1),K GO TO 99 ENDIF IF (JOB.GT.1) THEN IF (JOB.EQ.2) K = int(M,8) IF (JOB.EQ.3) K = int(1,8) IF (JOB.EQ.4) K = 2_8*int(M,8) IF (JOB.EQ.5) K = int(N,8) + 2_8*int(M,8) IF (JOB.EQ.6) K = int(N,8) + 3_8*int(M,8) IF (LDW .LT. K) THEN INFO(1) = -5 CALL MUMPS_SET_IERROR(K,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9005) INFO(1),K GO TO 99 ENDIF ENDIF IF (ICNTL(5).EQ.0) THEN DO 3 I = 1,M IW(I) = 0 3 CONTINUE DO 6 J = 1,N DO 4 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (I.LT.1 .OR. I.GT.M) THEN INFO(1) = -6 INFO(2) = J IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9006) INFO(1),J,I GO TO 99 ENDIF IF (IW(I).EQ.J) THEN INFO(1) = -7 INFO(2) = J IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9007) INFO(1),J,I GO TO 99 ELSE IW(I) = J ENDIF 4 CONTINUE 6 CONTINUE ENDIF IF (ICNTL(3).GT.0) THEN IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9020) JOB,M,N,NE IF (ICNTL(4).EQ.0) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,min(10,N+1)) WRITE(ICNTL(3),9022) (IRN(K),K=1_8,min(10_8,NE)) IF (JOB.GT.1) WRITE(ICNTL(3),9023) & (A(K),K=1_8,min(10_8,NE)) ELSEIF (ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,N+1) WRITE(ICNTL(3),9022) (IRN(K),K=1_8,NE) IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(K),K=1_8,NE) ENDIF WRITE(ICNTL(3),9024) (ICNTL(J),J=1,NICNTL) WRITE(ICNTL(3),9025) (CNTL(J),J=1,NCNTL) ENDIF ENDIF DO 8 I=1,NINFO INFO(I) = 0 8 CONTINUE IF (JOB.EQ.1) THEN DO 10 J = 1,N IW(J) = int(IP(J+1) - IP(J)) 10 CONTINUE CALL SMUMPS_MTRANSZ(M,N,IRN,NE,IP,IW(1),PERM,NUM, & IW( int(N,8)+1_8), & IW(2_8*int(N,8)+1_8), & IW(3_8*int(N,8)+1_8), & IW(3_8*int(N,8)+int(M,8)+1_8)) GO TO 90 ENDIF IF (JOB.EQ.2) THEN DW(1) = max(ZERO,CNTL(1)) CALL SMUMPS_MTRANSB(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IPQ8,IW(int(N,8)+1_8), & IW(int(N,8)+int(M,8)+1_8), & DW,RINF2) GO TO 90 ENDIF IF (JOB.EQ.3) THEN DO 20 K = 1,NE IW(K) = IRN(K) 20 CONTINUE CALL SMUMPS_MTRANSR(N,NE,IP,IW,A) FACT = max(ZERO,CNTL(1)) CALL SMUMPS_MTRANSS(M,N,NE,IP,IW(1),A,PERM,NUM,IW(NE+1_8), & IW(NE+int(N,8)+1_8),IW(NE+2_8*int(N,8)+1_8), & IW(NE+3_8*int(N,8)+1_8), & IW(NE+4_8*int(N,8)+1_8), & IW(NE+5_8*int(N,8)+1_8), & IW(NE+5_8*int(N,8)+int(M,8)+1_8), & FACT,RINF2) GO TO 90 ENDIF IF ((JOB.EQ.4).OR.(JOB.EQ.5).or.(JOB.EQ.6)) THEN ALLOCATE(IWtemp8(int(M,8)+int(N,8)+int(N,8)), stat=allocok) IF (allocok.GT.0) THEN INFOMUMPS(1) = -7 CALL MUMPS_SET_IERROR( int(M,8)+int(N,8)+int(N,8), & INFOMUMPS(2) ) GOTO 90 ENDIF ENDIF IF (JOB.EQ.4) THEN DO 50 J = 1,N FACT = ZERO DO 30 K = IP(J),IP(J+1)-1_8 IF (abs(A(K)).GT.FACT) FACT = abs(A(K)) 30 CONTINUE IF(FACT .GT. RINF3) RINF3 = FACT DO 40 K = IP(J),IP(J+1)-1_8 A(K) = FACT - abs(A(K)) 40 CONTINUE 50 CONTINUE DW(1) = max(ZERO,CNTL(1)) DW(2) = RINF3 IWtemp8(1) = int(JOB,8) CALL SMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(int(N,8)+1_8),IPQ8, & IW(int(N,8)+1_8), & IWtemp8(2_8*int(N,8)+1_8), & DW(1),DW(int(M,8)+1_8),RINF2) DEALLOCATE(IWtemp8) GO TO 90 ENDIF IF (JOB.EQ.5 .or. JOB.EQ.6) THEN RINF3=ONE IF (JOB.EQ.5) THEN DO 75 J = 1,N FACT = ZERO DO 60 K = IP(J),IP(J+1)-1_8 IF (A(K).GT.FACT) FACT = A(K) 60 CONTINUE DW(2_8*int(M,8)+int(J,8)) = FACT IF (FACT.NE.ZERO) THEN FACT = log(FACT) IF(FACT .GT. RINF3) RINF3=FACT DO 70 K = IP(J),IP(J+1)-1_8 IF (A(K).NE.ZERO) THEN A(K) = FACT - log(A(K)) IF(A(K) .GT. RINF3) RINF3=A(K) ELSE A(K) = FACT + RINF ENDIF 70 CONTINUE ELSE DO 71 K = IP(J),IP(J+1)-1_8 A(K) = ONE 71 CONTINUE ENDIF 75 CONTINUE ENDIF IF (JOB.EQ.6) THEN DO 175 K = 1,NE IW(3_8*int(N,8)+2_8*int(M,8)+int(K,8)) = IRN(K) 175 CONTINUE DO 61 I = 1,M DW(2_8*int(M,8)+int(N,8)+int(I,8)) = ZERO 61 CONTINUE DO 63 J = 1,N DO 62 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (A(K).GT.DW(2_8*int(M,8)+int(N,8)+int(I,8))) THEN DW(2_8*int(M,8)+int(N,8)+int(I,8)) = A(K) ENDIF 62 CONTINUE 63 CONTINUE DO 64 I = 1,M IF (DW(2_8*int(M,8)+int(N,8)+int(I,8)).NE.ZERO) THEN DW(2_8*int(M,8)+int(N,8)+int(I,8)) = & 1.0E0/DW(2_8*int(M,8)+int(N,8)+int(I,8)) ENDIF 64 CONTINUE DO 66 J = 1,N DO 65 K = IP(J),IP(J+1)-1 I = IRN(K) A(K) = DW(2_8*int(M,8)+int(N,8)+int(I,8)) * A(K) 65 CONTINUE 66 CONTINUE CALL SMUMPS_MTRANSR(N,NE,IP, & IW(3_8*int(N,8)+2_8*int(M,8)+1_8),A) DO 176 J = 1,N IF (IP(J).NE.IP(J+1)) THEN FACT = A(IP(J)) ELSE FACT = ZERO ENDIF DW(2_8*int(M,8)+int(J,8)) = FACT IF (FACT.NE.ZERO) THEN FACT = log(FACT) DO 170 K = IP(J),IP(J+1)-1_8 IF (A(K).NE.ZERO) THEN A(K) = FACT - log(A(K)) IF(A(K) .GT. RINF3) RINF3=A(K) ELSE A(K) = FACT + RINF ENDIF 170 CONTINUE ELSE DO 171 K = IP(J),IP(J+1)-1_8 A(K) = ONE 171 CONTINUE ENDIF 176 CONTINUE ENDIF DW(1) = max(ZERO,CNTL(1)) RINF3 = RINF3+ONE DW(2) = RINF3 IWtemp8(1) = int(JOB,8) IF (JOB.EQ.5) THEN CALL SMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(int(N,8)+1_8),IPQ8, & IW(int(N,8)+1_8), & IWtemp8(2_8*int(N,8)+1_8), & DW(1),DW(int(M,8)+1_8),RINF2) ENDIF IF (JOB.EQ.6) THEN CALL SMUMPS_MTRANSW(M,N,NE,IP, & IW(3_8*int(N,8)+2_8*int(M,8)+1_8),A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(int(N,8)+1_8),IPQ8, & IW(int(N,8)+1_8), & IWtemp8(2_8*int(N,8)+1_8), & DW(1),DW(int(M,8)+1_8),RINF2) ENDIF IF ((JOB.EQ.5).or.(JOB.EQ.6)) THEN DEALLOCATE(IWtemp8) ENDIF IF (JOB.EQ.6) THEN DO 79 I = 1,M IF (DW(2_8*int(M,8)+int(N,8)+int(I,8)).NE.0.0E0) THEN DW(I) = DW(I) + log(DW(2_8*int(M,8)+int(N,8)+int(I,8))) ENDIF 79 CONTINUE ENDIF IF (NUM.EQ.N) THEN DO 80 J = 1,N IF (DW(2_8*int(M,8)+int(J,8)).NE.ZERO) THEN DW(int(M,8)+int(J,8)) = DW(int(M,8)+int(J,8)) - & log(DW(2_8*int(M,8)+int(J,8))) ELSE DW(int(M,8)+int(J,8)) = ZERO ENDIF 80 CONTINUE ENDIF FACT = 0.5E0*log(RINF2) DO 86 I = 1,M IF (DW(I).LT.FACT) GO TO 86 WARN2 = 2 GO TO 90 86 CONTINUE DO 87 J = 1,N IF (DW(M+J).LT.FACT) GO TO 87 WARN2 = 2 GO TO 90 87 CONTINUE ENDIF 90 IF (INFOMUMPS(1).LT.0) RETURN IF (NUM.LT.N) WARN1 = 1 IF (JOB.EQ.4 .OR. JOB.EQ.5 .OR. JOB.EQ.6) THEN IF (CNTL(1).LT.ZERO) WARN4 = 4 ENDIF IF (INFO(1).EQ.0) THEN INFO(1) = WARN1 + WARN2 + WARN4 IF (INFO(1).GT.0 .AND. ICNTL(2).GT.0) THEN WRITE(ICNTL(2),9010) INFO(1) IF (WARN1.EQ.1) WRITE(ICNTL(2),9011) IF (WARN2.EQ.2) WRITE(ICNTL(2),9012) IF (WARN4.EQ.4) WRITE(ICNTL(2),9014) ENDIF ENDIF IF (ICNTL(3).GE.0) THEN IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9030) (INFO(J),J=1,2) WRITE(ICNTL(3),9031) NUM IF (ICNTL(4).EQ.0) THEN WRITE(ICNTL(3),9032) (PERM(J),J=1,min(10,M)) IF (JOB.EQ.5 .OR. JOB.EQ.6) THEN WRITE(ICNTL(3),9033) (DW(J),J=1,min(10,M)) WRITE(ICNTL(3),9034) (DW(int(M,8)+int(J,8)), & 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(int(M,8)+int(J,8)), & J=1,N) ENDIF ENDIF ENDIF ENDIF 99 RETURN 9001 FORMAT (' ****** Error in SMUMPS_MTRANSA. INFO(1) = ',I2, & ' because ',(A),' = ',I14) 9004 FORMAT (' ****** Error in SMUMPS_MTRANSA. INFO(1) = ',I2/ & ' LIW too small, must be at least ',I14) 9005 FORMAT (' ****** Error in SMUMPS_MTRANSA. INFO(1) = ',I2/ & ' LDW too small, must be at least ',I14) 9006 FORMAT (' ****** Error in SMUMPS_MTRANSA. INFO(1) = ',I2/ & ' Column ',I8, & ' contains an entry with invalid row index ',I8) 9007 FORMAT (' ****** Error in SMUMPS_MTRANSA. INFO(1) = ',I2/ & ' Column ',I8, & ' contains two or more entries with row index ',I8) 9010 FORMAT (' ****** Warning from SMUMPS_MTRANSA. INFO(1) = ',I2) 9011 FORMAT (' - The matrix is structurally singular.') 9012 FORMAT (' - Some scaling factors may be too large.') 9014 FORMAT (' - CNTL(1) is negative and was treated as zero.') 9020 FORMAT (' ****** Input parameters for SMUMPS_MTRANSA:'/ & ' JOB =',I10/' M =',I10/' N =',I10/' NE =',I14) 9021 FORMAT (' IP(1:N+1) = ',8I8/(15X,8I8)) 9022 FORMAT (' IRN(1:NE) = ',8I8/(15X,8I8)) 9023 FORMAT (' A(1:NE) = ',4(1PD14.4)/(15X,4(1PD14.4))) 9024 FORMAT (' ICNTL(1:10) = ',8I8/(15X,2I8)) 9025 FORMAT (' CNTL(1:10) = ',4(1PD14.4)/(15X,4(1PD14.4))) 9030 FORMAT (' ****** Output parameters for SMUMPS_MTRANSA:'/ & ' INFO(1:2) = ',2I8) 9031 FORMAT (' NUM = ',I8) 9032 FORMAT (' PERM(1:M) = ',8I8/(15X,8I8)) 9033 FORMAT (' DW(1:M) = ',5(F11.3)/(15X,5(F11.3))) 9034 FORMAT (' DW(M+1:M+N) = ',5(F11.3)/(15X,5(F11.3))) END SUBROUTINE SMUMPS_MTRANS_DRIVER SUBROUTINE SMUMPS_SUPPRESS_DUPPLI_VAL(N,NZ,IP,IRN,A,FLAG,POSI) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(INOUT) :: NZ INTEGER(8), INTENT(INOUT) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NZ) REAL, INTENT(INOUT) :: A(NZ) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER(8), INTENT(OUT) :: POSI(N) INTEGER :: ROW, COL INTEGER(8) :: K, WR_POS, BEG_COL, SV_POS FLAG = 0 WR_POS = 1_8 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1_8 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW A(WR_POS) = A(K) FLAG(ROW) = COL POSI(ROW) = WR_POS WR_POS = WR_POS+1 ELSE SV_POS = POSI(ROW) A(SV_POS) = A(SV_POS) + A(K) ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1_8 RETURN END SUBROUTINE SMUMPS_SUPPRESS_DUPPLI_VAL SUBROUTINE SMUMPS_SUPPRESS_DUPPLI_STR(N,NZ,IP,IRN,FLAG) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(INOUT) :: NZ INTEGER(8), INTENT(INOUT) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NZ) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER :: ROW, COL INTEGER(8) :: K, WR_POS, BEG_COL FLAG = 0 WR_POS = 1_8 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1_8 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW FLAG(ROW) = COL WR_POS = WR_POS+1_8 ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1_8 RETURN END SUBROUTINE SMUMPS_SUPPRESS_DUPPLI_STR SUBROUTINE SMUMPS_SORT_PERM( N, NA, LNA, NE_STEPS, & PERM, FILS, & DAD_STEPS, STEP, NSTEPS, & KEEP60, KEEP20, KEEP38, & INFO) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA INTEGER, INTENT(IN) :: FILS( N ), STEP(N), NA(LNA) INTEGER, INTENT(IN) :: DAD_STEPS ( NSTEPS ), NE_STEPS (NSTEPS) INTEGER, INTENT(IN) :: KEEP60, KEEP20, KEEP38 INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(OUT) :: PERM( N ) INTEGER :: IPERM, INODE, IN, ISCHUR INTEGER :: INBLEAF, INBROOT, allocok INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, NSTK INBLEAF = NA(1) INBROOT = NA(2) ALLOCATE(POOL(INBLEAF), NSTK(NSTEPS), stat=allocok) IF (allocok > 0 ) THEN INFO(1) = -7 INFO(2) = INBLEAF + NSTEPS RETURN ENDIF POOL(1:INBLEAF) = NA(3:2+INBLEAF) NSTK(1:NSTEPS) = NE_STEPS(1:NSTEPS) ISCHUR = 0 IF ( KEEP60.GT.0 ) THEN ISCHUR = max (KEEP20, KEEP38) ENDIF IPERM = 1 DO WHILE ( INBLEAF .NE. 0 ) INODE = POOL( INBLEAF ) INBLEAF = INBLEAF - 1 IN = INODE IF (INODE.NE.ISCHUR) THEN DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO ENDIF IN = DAD_STEPS(STEP( INODE )) IF ( IN .eq. 0 ) THEN INBROOT = INBROOT - 1 ELSE NSTK( STEP(IN) ) = NSTK( STEP(IN) ) - 1 IF ( NSTK( STEP(IN) ) .eq. 0 ) THEN INBLEAF = INBLEAF + 1 POOL( INBLEAF ) = IN END IF END IF END DO IF (IPERM.LE.N) THEN IF (ISCHUR.GT.0) THEN IN = ISCHUR DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO ENDIF ENDIF DEALLOCATE(POOL, NSTK) RETURN END SUBROUTINE SMUMPS_SORT_PERM SUBROUTINE SMUMPS_EXPAND_TREE_STEPS( ICNTL, & N, NBLK, BLKPTR, BLKVAR, & FILS_OLD, FILS_NEW, NSTEPS, & STEP_OLD, STEP_NEW, PAR2_NODES, NB_NIV2, & DAD_STEPS, FRERE_STEPS, & NA, LNA, & LRGROUPS_OLD, SIZELRGROUPS_OLD, & LRGROUPS_NEW, SIZELRGROUPS_NEW, & K20, K38, K494 & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NBLK, ICNTL(60), NSTEPS, LNA, & NB_NIV2, K494 INTEGER, INTENT(IN) :: BLKPTR(NBLK+1), BLKVAR(N) INTEGER, INTENT(IN) :: SIZELRGROUPS_OLD, SIZELRGROUPS_NEW INTEGER, INTENT(IN) :: FILS_OLD(NBLK), STEP_OLD(NBLK), & LRGROUPS_OLD(SIZELRGROUPS_OLD) INTEGER, INTENT(INOUT) :: DAD_STEPS(NSTEPS), FRERE_STEPS(NSTEPS) INTEGER, INTENT(INOUT) :: NA(LNA), PAR2_NODES(NB_NIV2), K20,K38 INTEGER, INTENT(OUT) :: FILS_NEW(N), STEP_NEW(N), & LRGROUPS_NEW(SIZELRGROUPS_NEW) INTEGER :: IB, I, IBFS, IBNB, IFS, INB INTEGER NBLEAF, NBROOT, ISTEP, IGROUP INTEGER :: II IF (K20.GT.0) K20 = BLKVAR(BLKPTR(K20)) IF (K38.GT.0) K38 = BLKVAR(BLKPTR(K38)) NBLEAF = NA(1) NBROOT = NA(2) IF (NBLK.GT.1) THEN DO I= 3, 3+NBLEAF+NBROOT-1 IBNB = NA(I) INB = BLKVAR(BLKPTR(IBNB)) NA(I) = INB ENDDO ENDIF IF (PAR2_NODES(1).GT.0) THEN DO I=1, NB_NIV2 IBNB = PAR2_NODES(I) INB = BLKVAR(BLKPTR(IBNB)) PAR2_NODES(I) = INB ENDDO ENDIF DO I= 1, NSTEPS IBNB = DAD_STEPS(I) IF (IBNB.EQ.0) THEN INB = 0 ELSE INB = BLKVAR(BLKPTR(IBNB)) ENDIF DAD_STEPS(I) = INB ENDDO DO I= 1, NSTEPS IBNB = FRERE_STEPS(I) IF (IBNB.EQ.0) THEN INB = 0 ELSE INB = BLKVAR(BLKPTR(abs(IBNB))) IF (IBNB.LT.0) INB=-INB ENDIF FRERE_STEPS(I) = INB ENDDO DO IB=1, NBLK IBFS = FILS_OLD(IB) IF (IBFS.EQ.0) THEN IFS = 0 ELSE IFS = BLKVAR(BLKPTR(abs(IBFS))) IF (IBFS.LT.0) IFS=-IFS ENDIF IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE DO II=BLKPTR(IB), BLKPTR(IB+1)-1 IF (II.LT. BLKPTR(IB+1)-1) THEN FILS_NEW(BLKVAR(II))= BLKVAR(II+1) ELSE FILS_NEW(BLKVAR(II))= IFS ENDIF ENDDO ENDDO DO IB=1, NBLK ISTEP = STEP_OLD(IB) IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE IF (ISTEP.LT.0) THEN DO II=BLKPTR(IB), BLKPTR(IB+1)-1 STEP_NEW(BLKVAR(II)) = ISTEP ENDDO ELSE I = BLKVAR(BLKPTR(IB)) STEP_NEW(I) = ISTEP DO II=BLKPTR(IB)+1, BLKPTR(IB+1)-1 STEP_NEW(BLKVAR(II)) = -ISTEP ENDDO ENDIF ENDDO IF (K494.NE.0) THEN DO IB=1, NBLK IGROUP = LRGROUPS_OLD(IB) IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE DO II=BLKPTR(IB), BLKPTR(IB+1)-1 LRGROUPS_NEW(BLKVAR(II)) = IGROUP ENDDO ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_EXPAND_TREE_STEPS SUBROUTINE SMUMPS_DIST_AVOID_COPIES(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,PEAK,IERR & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) USE MUMPS_STATIC_MAPPING IMPLICIT NONE INTEGER N, NSLAVES, NBSA, IERR INTEGER ICNTL(60),INFOG(80),KEEP(500) INTEGER(8) KEEP8(150) INTEGER NE(N),NFSIZ(N),FRERE(N),FILS(N),PROCNODE(N) INTEGER SSARBR(N) REAL PEAK INTEGER, intent(IN) :: LSIZEOFBLOCKS INTEGER, intent(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) CALL MUMPS_SET_K78_83_91 (NSLAVES,KEEP(78),KEEP(83),KEEP(91)) CALL MUMPS_DISTRIBUTE(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,dble(PEAK),IERR & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) RETURN END SUBROUTINE SMUMPS_DIST_AVOID_COPIES SUBROUTINE SMUMPS_SET_PROCNODE(INODE, PROCNODE, VALUE, FILS, N) INTEGER, intent(in) :: INODE, N, VALUE INTEGER, intent(in) :: FILS(N) INTEGER, intent(inout) :: PROCNODE(N) INTEGER IN IN=INODE DO WHILE ( IN > 0 ) PROCNODE( IN ) = VALUE IN=FILS( IN ) ENDDO RETURN END SUBROUTINE SMUMPS_SET_PROCNODE MUMPS_5.8.1/src/zsol_matvec.F0000664000175000017500000002413515042446442015674 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_MV_ELT( N, NELT, ELTPTR, ELTVAR, A_ELT, & X, Y, K50, MTYPE ) IMPLICIT NONE C C Purpose C ======= C C To perform the matrix vector product C A_ELT X = Y if MTYPE = 1 C A_ELT^T X = Y if MTYPE = 0 C C If K50 is different from 0, then the elements are C supposed to be in symmetric packed storage; the C lower part is stored by columns. C Otherwise, the element is square, stored by columns. C C Note C ==== C C A_ELT is processed entry by entry and this code is not C optimized. In particular, one could gather/scatter C X / Y for each element to improve performance. C C Arguments C ========= C INTEGER N, NELT, K50, MTYPE INTEGER ELTPTR( NELT + 1 ), ELTVAR( * ) COMPLEX(kind=8) A_ELT( * ), X( N ), Y( N ) C C Local variables C =============== C INTEGER IEL, I , J, SIZEI, IELPTR INTEGER(8) :: K8 COMPLEX(kind=8) TEMP COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) C C C Executable statements C ===================== C Y = ZERO K8 = 1_8 C -------------------- C Process the elements C -------------------- DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( K50 .eq. 0 ) THEN C ------------------- C Unsymmetric element C stored by columns C ------------------- IF ( MTYPE .eq. 1 ) THEN C ----------------- C Compute A_ELT x X C ----------------- DO J = 1, SIZEI TEMP = X( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) + & A_ELT( K8 ) * TEMP K8 = K8 + 1 END DO END DO ELSE C ------------------- C Compute A_ELT^T x X C ------------------- DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + & A_ELT( K8 ) * X( ELTVAR( IELPTR + I ) ) K8 = K8 + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP END DO END IF ELSE C ----------------- C Symmetric element C L stored by cols C ----------------- DO J = 1, SIZEI C Diagonal counted once Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + J ) ) K8 = K8 + 1 DO I = J+1, SIZEI C Off diagonal + transpose Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + J ) ) Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + I ) ) K8 = K8 + 1 END DO END DO END IF END DO RETURN END SUBROUTINE ZMUMPS_MV_ELT SUBROUTINE ZMUMPS_LOC_MV8 &( N, NZ_loc8, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE C C Purpose: C ======= C C Perform a distributed matrix vector product. C Y_loc <- A X if MTYPE = 1 C Y_loc <- A^T X if MTYPE = 0 C C Notes: C ===== C C 1) assembly of all Y_loc still has to be done on exit. C 2) X should be available on all processors. C C Arguments: C ========= C INTEGER N INTEGER(8) :: NZ_loc8 INTEGER IRN_loc( NZ_loc8 ), JCN_loc( NZ_loc8 ) COMPLEX(kind=8) A_loc( NZ_loc8 ), X( N ), Y_loc( N ) INTEGER LDLT, MTYPE C C Locals variables: C ================ C INTEGER I, J INTEGER(8) :: K8 COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) Y_loc = ZERO IF ( LDLT .eq. 0 ) THEN C Unsymmetric IF ( MTYPE .eq. 1 ) THEN C No transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + A_loc(K8) * X(J) ENDDO ELSE C Transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) & .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(J) = Y_loc(J) + A_loc(K8) * X(I) ENDDO END IF ELSE C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + A_loc(K8) * X(J) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + A_loc(K8) * X(I) ENDIF ENDDO END IF RETURN END SUBROUTINE ZMUMPS_LOC_MV8 SUBROUTINE ZMUMPS_MV8( N, NZ8, IRN, ICN, ASPK, X, Y, & LDLT, MTYPE, MAXTRANS, PERM, & IFLAG, IERROR ) C C Purpose: C ======= C C Perform matrix-vector product C Y <- A X if MTYPE = 1 C Y <- A^T X if MTYPE = 0 C C C Note: C ==== C C MAXTRANS should be set to 1 if a column permutation C was applied on A and we still want the matrix vector C product wrt the original matrix. C C Arguments: C ========= C INTEGER N, LDLT, MTYPE, MAXTRANS INTEGER(8) :: NZ8 INTEGER IRN( NZ8 ), ICN( NZ8 ) INTEGER PERM( N ) COMPLEX(kind=8) ASPK( NZ8 ), X( N ), Y( N ) INTEGER, intent(inout) :: IFLAG, IERROR C C Local variables C =============== C INTEGER I, J INTEGER(8) :: K8 COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE :: PX COMPLEX(kind=8) ZERO INTEGER :: allocok PARAMETER( ZERO = (0.0D0,0.0D0) ) Y = ZERO ALLOCATE(PX(N), stat=allocok) IF (allocok < 0) THEN IFLAG = -13 IERROR = N RETURN ENDIF C C -------------------------------------- C Permute X if A has been permuted C with some max-trans column permutation C -------------------------------------- IF ( MAXTRANS .eq. 1 .and. MTYPE .eq. 1) THEN DO I = 1, N PX(I) = X( PERM( I ) ) END DO ELSE PX = X END IF IF ( LDLT .eq. 0 ) THEN C C Complete unsymmetric matrix was provided (LU facto) IF (MTYPE .EQ. 1) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K8) * PX(J) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(J) = Y(J) + ASPK(K8) * PX(I) ENDDO ENDIF C ELSE C C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K8) * PX(J) IF (J.NE.I) THEN Y(J) = Y(J) + ASPK(K8) * PX(I) ENDIF ENDDO END IF IF ( MAXTRANS .EQ. 1 .AND. MTYPE .eq. 0 ) THEN PX = Y DO I = 1, N Y( PERM( I ) ) = PX( I ) END DO END IF DEALLOCATE(PX) RETURN END SUBROUTINE ZMUMPS_MV8 C C SUBROUTINE ZMUMPS_LOC_OMEGA1 &( N, NZ_loc8, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE C C Purpose: C ======= C Compute C * If MTYPE = 1 C Y_loc(i) = Sum | Aij | | Xj | C j C * If MTYPE = 0 C Y_loc(j) = Sum | Aij | | Xi | C C C Notes: C ===== C C 1) assembly of all Y_loc still has to be done. C 2) X should be available on all processors. C C Arguments: C ========= C INTEGER N INTEGER(8) :: NZ_loc8 INTEGER IRN_loc( NZ_loc8 ), JCN_loc( NZ_loc8 ) COMPLEX(kind=8) A_loc( NZ_loc8 ), X( N ) DOUBLE PRECISION Y_loc( N ) INTEGER LDLT, MTYPE C C Local variables: C =============== C INTEGER I, J INTEGER(8) :: K8 DOUBLE PRECISION, PARAMETER :: RZERO=0.0D0 C Y_loc = RZERO IF ( LDLT .eq. 0 ) THEN C Unsymmetric IF ( MTYPE .eq. 1 ) THEN C No transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + abs( A_loc(K8) * X(J) ) ENDDO ELSE C Transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) & .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(J) = Y_loc(J) + abs( A_loc(K8) * X(I) ) ENDDO END IF ELSE C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + abs( A_loc(K8) * X(J) ) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + abs( A_loc(K8) * X(I) ) ENDIF ENDDO END IF RETURN END SUBROUTINE ZMUMPS_LOC_OMEGA1 MUMPS_5.8.1/src/somp_tps_m.F0000664000175000017500000000124615042446437015530 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_TPS_M TYPE SMUMPS_TPS_T REAL, DIMENSION(:), POINTER :: A END TYPE SMUMPS_TPS_T END MODULE SMUMPS_TPS_M SUBROUTINE SMUMPS_TPS_M_RETURN() RETURN END SUBROUTINE SMUMPS_TPS_M_RETURN MUMPS_5.8.1/src/sfac_process_master2.F0000664000175000017500000001625715042446437017467 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, SLAVEF, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, KEEP, KEEP8, DKEEP, & ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE MUMPS_LOAD USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER SLAVEF INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ), ITLOC( N +KEEP(253) ) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ) INTEGER IFLAG, IERROR, COMM, COMM_LOAD INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER ND(KEEP(28)), FILS( N ), DAD(KEEP(28)), FRERE(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSITION, IFATH, ISON, NROW, NCOL, NELIM, & NSLAVES INTEGER(8) :: NOREAL INTEGER NOINT, INIV2, NCOL_EFF DOUBLE PRECISION FLOP1 INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER NOREAL_PACKET LOGICAL PERETYPE2 INCLUDE 'mumps_headers.h' REAL, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYN_SIZE INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IFATH, 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & ISON , 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NROW , 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NCOL , 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, & MPI_INTEGER, COMM, IERR) IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN NCOL_EFF = NROW ELSE NCOL_EFF = NCOL ENDIF NOREAL_PACKET = NBROWS_PACKET * NCOL_EFF IF (NBROWS_ALREADY_SENT .EQ. 0) THEN NOINT = 6 + NROW + NCOL + NSLAVES + KEEP(IXSZ) NOREAL= int(NROW,8) * int(NCOL_EFF,8) CALL SMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, ISON, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) THEN RETURN ENDIF PIMASTER(STEP( ISON )) = IWPOSCB + 1 PAMASTER(STEP( ISON )) = IPTRLU + 1_8 IW( IWPOSCB + 1 + XXNBPR ) = 0 IW( IWPOSCB + 1 + KEEP(IXSZ) ) = NCOL NELIM = NROW IW( IWPOSCB + 2 + KEEP(IXSZ) ) = NELIM IW( IWPOSCB + 3 + KEEP(IXSZ) ) = NROW IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN IW( IWPOSCB + 4 + KEEP(IXSZ) ) = NROW - NCOL IF ( NROW - NCOL .GE. 0 ) THEN WRITE(*,*) 'Error in PROCESS_MAITRE2:',NROW,NCOL CALL MUMPS_ABORT() END IF ELSE IW( IWPOSCB + 4 + KEEP(IXSZ) ) = 0 END IF IW( IWPOSCB + 5 + KEEP(IXSZ) ) = 1 IW( IWPOSCB + 6 + KEEP(IXSZ) ) = NSLAVES IF (NSLAVES.GT.0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 7 + KEEP(IXSZ) ), & NSLAVES, MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 7 + KEEP(IXSZ) + NSLAVES), & NROW, MPI_INTEGER, COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 7 + KEEP(IXSZ) + NROW + NSLAVES), & NCOL, MPI_INTEGER, COMM, IERR) IF ( NSLAVES .GT. 0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(ISON) ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES+1, MPI_INTEGER, COMM, IERR) TAB_POS_IN_PERE(SLAVEF+2,INIV2) = NSLAVES ENDIF ENDIF IF (NOREAL_PACKET.GT.0) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(PIMASTER(STEP(ISON))+XXD)) IF ( DYN_SIZE .GT. 0_8 ) THEN CALL SMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), & DYN_SIZE, SON_A ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SON_A( 1_8 + & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8) ), & NOREAL_PACKET, MPI_REAL, COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( PAMASTER(STEP(ISON)) + & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8) ), & NOREAL_PACKET, MPI_REAL, COMM, IERR ) ENDIF ENDIF IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NROW ) THEN PERETYPE2 = ( MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)), & KEEP(199)) .EQ. 2 ) NSTK_S( STEP(IFATH )) = NSTK_S( STEP(IFATH) ) - 1 IF ( NSTK_S( STEP(IFATH)) .EQ. 0 ) THEN CALL SMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IFATH ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( IFATH, N, PROCNODE_STEPS, & KEEP(199), ND, & FILS,FRERE, STEP, PIMASTER, & KEEP(28), KEEP(50), KEEP(253), & FLOP1,IW, LIW, KEEP(IXSZ) ) IF (IFATH.NE.KEEP(20)) & CALL MUMPS_LOAD_UPDATE(1, .FALSE., FLOP1, KEEP,KEEP8) END IF ENDIF RETURN END SUBROUTINE SMUMPS_PROCESS_MASTER2 MUMPS_5.8.1/src/dfac_process_blocfacto_LDLT.F0000664000175000017500000015172315042446440020636 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE DMUMPS_PROCESS_SYM_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_OOC, ONLY : IO_BLOCK USE MUMPS_OOC_COMMON, ONLY : TYPEF_L, STRAT_TRY_WRITE USE MUMPS_LOAD USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT USE DMUMPS_BUF, ONLY : DMUMPS_BUF_SEND_BLFAC_SLAVE USE DMUMPS_LR_CORE USE DMUMPS_LR_TYPE USE MUMPS_LR_STATS USE DMUMPS_FAC_LR USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR, & DMUMPS_DM_ALLOC_S_WK, DMUMPS_DM_FREE_S_WK USE DMUMPS_FAC_FRONT_AUX_M, ONLY : DMUMPS_GET_SIZE_SCHUR_IN_FRONT !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) PTRAST(KEEP(28)), PTRFAC(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PERM(N), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)), ND(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PIVI INTEGER (8) POSPV1,POSPV2,OFFDAG,LPOS1 INTEGER J2 DOUBLE PRECISION MULT1,MULT2, A11, DETPIV, A22, A12 INTEGER :: NFS4FATHER, NVSCHUR_K253, NSLAVES_L, IROW_L DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: M_ARRAY INTEGER NBROWSinF INTEGER :: BLFAC_NBCOLS_ALREADY_SENT, BLFAC_NBLRB_ALREADY_SENT INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NEWCOL_RECV, JBEG_BLOCK, NCOL_GEMM_FR, & SHIFT_LPOS, SHIFT_UPOS INTEGER :: IFLAG_OOC INTEGER(8) :: POSBLOCFACTO INTEGER :: LD_BLOCFACTO INTEGER(8) :: LA_BLOCFACTO INTEGER(8) :: LA_PTR INTEGER(8) :: POSELT DOUBLE PRECISION, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, 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 INTEGER(8) :: LUIP21K DOUBLE PRECISION, DIMENSION(:), POINTER :: UIP21K DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: DYN_BLOCFACTO INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_SLAVES_FOLLOW INTEGER, DIMENSION(:), ALLOCATABLE :: DYN_PIVINFO LOGICAL LASTPANEL LOGICAL LASTBL_INPANEL, LASTBL_INLASTPANEL LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED DOUBLE PRECISION ONE,ALPHA PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER J LOGICAL COUNTER_WAS_HUGE INTEGER TO_UPDATE_CPT_RECUR INTEGER :: LR_ACTIVATED_INT LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL LOGICAL :: DYNAMIC_ALLOC LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: CURRENT_BLR, NSLAVES_PREC, INFO_TMP(2) INTEGER :: NELIM, NB_BLR_LM, NB_BLR_LS, & MAXI_CLUSTER_LM, MAXI_CLUSTER_LS, MAXI_CLUSTER, & NPARTSASS, NPARTSCB, NPARTSCB_COL, NPARTSASS_COL, & NB_BLR_COL, MAXI_CLUSTER_COL INTEGER :: NPARTSASS_MASTER, IPANEL, NB_ACCESSES_INIT, & NB_ACCESSES_LEFT_INIT TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_LM TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS, & BEGS_BLR_COL, BEGS_BLR_COL_TMP LOGICAL KEEP_BEGS_BLR_LS, KEEP_BEGS_BLR_COL, KEEP_BLR_LS DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, LWORK INTEGER :: II,JJ LOGICAL :: NOTHING_WAS_SENT INTEGER :: KEEP430_LOC INTEGER :: NB, IB, IBEG, IEND !$ INTEGER :: NOMP !$ LOGICAL :: OMP_FLAG INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE KEEP(174)=KEEP(174)+1 KEEP(175)=max(KEEP(174),KEEP(175)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 POSITION = 0 TO_UPDATE_CPT_END = -654321 NULLIFY(UIP21K) 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 ) LASTPANEL = (NPIV.LE.0) IF (LASTPANEL) THEN NPIV = -NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NB_BLOC_FAC, 1, & MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NEWCOL_RECV, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, JBEG_BLOCK, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER, 1, & MPI_INTEGER, COMM, IERR ) NPARTSASS_COL = NPARTSASS_MASTER CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT, 1, & MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) IF (JBEG_BLOCK.EQ.1) THEN NCOL_GEMM_FR = NEWCOL_RECV - NPIV SHIFT_LPOS = NPIV SHIFT_UPOS = NPIV ELSE SHIFT_LPOS = JBEG_BLOCK - 1 IF (LR_ACTIVATED) THEN NCOL_GEMM_FR = -99993 SHIFT_UPOS = -99994 ELSE NCOL_GEMM_FR = NEWCOL_RECV SHIFT_UPOS = 0 ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NSLAVES_TOT, 1, & MPI_INTEGER, COMM, IERR ) KEEP_BEGS_BLR_LS =.FALSE. NULLIFY(BEGS_BLR_LS) KEEP_BEGS_BLR_COL =.FALSE. NULLIFY(BEGS_BLR_COL) KEEP_BLR_LS =.FALSE. NULLIFY(BLR_LS) NULLIFY(BEGS_BLR_LM) IF ( LR_ACTIVATED ) THEN LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8) LD_BLOCFACTO = max(NPIV+NELIM,1) ELSE LA_BLOCFACTO = int(NPIV,8) * int(NEWCOL_RECV,8) LD_BLOCFACTO = max(NEWCOL_RECV,1) ENDIF IF (LR_ACTIVATED) THEN DYNAMIC_ALLOC = .TRUE. ELSE DYNAMIC_ALLOC = .FALSE. ENDIF IF ( .NOT. DYNAMIC_ALLOC ) THEN IF ( NPIV .EQ. 0 ) THEN IPIV = 1 POSBLOCFACTO = 1_8 ELSE CALL DMUMPS_GET_SIZE_NEEDED( & NPIV, LA_BLOCFACTO, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ),COMP,DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LA_BLOCFACTO LRLUS = LRLUS - LA_BLOCFACTO KEEP8(69) = KEEP8(69) + LA_BLOCFACTO KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LA_BLOCFACTO IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ELSE ALLOCATE(DYN_PIVINFO(max(1,NPIV)), & DYN_BLOCFACTO(max(1_8,LA_BLOCFACTO)), & stat=allocok) IF (allocok.GT.0) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR DYN_PIVINFO and DYN_BLOCFACTO IN ", & "DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 CALL MUMPS_SET_IERROR(max(1_8,LA_BLOCFACTO), IERROR) GOTO 700 ENDIF KEEP8(130)=KEEP8(130)+max(1_8,LA_BLOCFACTO) KEEP8(131)=max(KEEP8(130),KEEP8(131)) KEEP8(73) = KEEP8(73) + max(1_8,LA_BLOCFACTO) KEEP8(69) = KEEP8(69) + max(1_8,LA_BLOCFACTO) KEEP8(74) = max(KEEP8(74), KEEP8(73)) KEEP8(68) = max(KEEP8(68), KEEP8(69)) POSBLOCFACTO = 1_8 IPIV = 1 ENDIF IF (NPIV.GT.0) THEN IF (DYNAMIC_ALLOC) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & DYN_PIVINFO, NPIV, & MPI_INTEGER, COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) ENDIF IF (DYNAMIC_ALLOC) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & DYN_BLOCFACTO, int(LA_BLOCFACTO), & MPI_DOUBLE_PRECISION, & COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), int(LA_BLOCFACTO), & MPI_DOUBLE_PRECISION, & COMM, IERR ) ENDIF IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_LM, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_LM(max(NB_BLR_LM,1)), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BLR_LM IN ", & "DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = max(NB_BLR_LM,1) GOTO 700 END IF ALLOCATE(BEGS_BLR_LM(NB_BLR_LM+2), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BEGS_BLR_LM IN ", & "DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NB_BLR_LM+2 GOTO 700 END IF CALL DMUMPS_MPI_UNPACK_LR_PARTIAL( & BUFR, LBUFR, LBUFR_BYTES, POSITION, NPIV, NELIM, & 'V', BLR_LM, NB_BLR_LM, JBEG_BLOCK, & BEGS_BLR_LM(1), KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) THEN CALL DMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 550 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 + KEEP(IXSZ)) .EQ. 0 ) THEN DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 550 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) CALL DMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL DMUMPS_ASM_SLAVE_ARROWHEADS(INODE, STEP(INODE), & N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, & LRGROUPS) ELSE CALL DMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 +KEEP(IXSZ)) NCOL1 = IW( IOLDPS + 3 +KEEP(IXSZ)) + IW( IOLDPS + KEEP(IXSZ)) IF (JBEG_BLOCK.EQ.1) THEN NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) ELSE NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) - NPIV ENDIF LASTBL_INPANEL = JBEG_BLOCK+NEWCOL_RECV.GT.NASS1-NPIV1 LASTBL_INLASTPANEL = LASTPANEL .AND. LASTBL_INPANEL NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) NSLAVES_FOLLOW = NSLAV1 - XTRA_SLAVES_SYM HS = 6 + NSLAV1 + KEEP(IXSZ) IF ( LASTBL_INLASTPANEL ) THEN TO_UPDATE_CPT_END = ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & NB_BLOC_FAC END IF IF (NPIV.GT.0) THEN IF (JBEG_BLOCK.EQ.1) THEN ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1 DO I = 1, NPIV IF (DYNAMIC_ALLOC) THEN PIVI = abs(DYN_PIVINFO(I)) ELSE PIVI = abs(IW(IPIV+I-1)) ENDIF IF (PIVI.EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+PIVI) IW(ICT11+PIVI) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + PIVI - 1,8) CALL dswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO IF (LR_ACTIVATED) THEN LUIP21K = 1_8 ELSE LUIP21K=int(NPIV,8)*int(NROW1,8) ENDIF KEEP430_LOC=min(KEEP(430),1) CALL DMUMPS_DM_ALLOC_S_WK( UIP21K, LUIP21K, allocok, & KEEP430_LOC, KEEP(35) ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NPIV * NROW1 GOTO 700 END IF KEEP8(130)=KEEP8(130)+LUIP21K KEEP8(131)=max(KEEP8(130),KEEP8(131)) KEEP8(73) = KEEP8(73) + LUIP21K KEEP8(69) = KEEP8(69) + LUIP21K KEEP8(74) = max(KEEP8(74), KEEP8(73)) KEEP8(68) = max(KEEP8(68), KEEP8(69)) IF (.NOT.LR_ACTIVATED) THEN ENDIF ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 ) THEN ALLOCATE( LIST_SLAVES_FOLLOW ( NSLAVES_FOLLOW ), & stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR LIST_SLAVES_FOLLOW & IN DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NSLAVES_FOLLOW GOTO 700 END IF LIST_SLAVES_FOLLOW(1:NSLAVES_FOLLOW)= & IW(IOLDPS+6+XTRA_SLAVES_SYM+KEEP(IXSZ): & IOLDPS+5+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_FOLLOW) END IF IF ( (JBEG_BLOCK.EQ.1) .AND. & ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) & ) THEN IF (DYNAMIC_ALLOC) THEN CALL dtrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & DYN_BLOCFACTO, LD_BLOCFACTO, & A_PTR(POSELT+int(NPIV1,8)), NCOL1) ELSE CALL dtrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), LD_BLOCFACTO, & A_PTR(POSELT+int(NPIV1,8)), NCOL1) ENDIF ENDIF IF (JBEG_BLOCK.EQ.1) THEN IF (.NOT.LR_ACTIVATED.OR.KEEP(475).EQ.0) THEN NB = KEEP(360) !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = (NOMP.GT.1.AND. (int(NROW1/NB).GE.NOMP)) !$OMP PARALLEL DO !$OMP& PRIVATE (IB, II, IBEG, IEND, I, J, UPOS, LPOS, DPOS, !$OMP& PIVI, A11, A12, A22, POSPV1, POSPV2, !$OMP& OFFDAG, DETPIV, LPOS1, MULT1, MULT2 !$OMP& ) !$OMP& SCHEDULE(DYNAMIC,1) IF (OMP_FLAG) DO IB=1, NROW1, NB IBEG = IB IEND = min(IB+NB-1, NROW1) IF (.NOT.LR_ACTIVATED) THEN LPOS = POSELT + int(NPIV1,8) UPOS = 1_8 LPOS = LPOS + int((IBEG-1),8)*int(NCOL1,8) UPOS = UPOS + int((IBEG-1),8)*int(NPIV,8) DO II = IBEG, IEND DO J = 0, NPIV-1 UIP21K( UPOS+J ) = A_PTR(LPOS+J) ENDDO LPOS = LPOS + int(NCOL1,8) UPOS = UPOS + int(NPIV,8) END DO ENDIF LPOS = POSELT + int(NPIV1,8) LPOS = LPOS + int((IBEG-1),8)*int(NCOL1,8) IF (DYNAMIC_ALLOC) THEN DPOS = 1_8 ELSE DPOS = POSBLOCFACTO ENDIF I = 1 DO IF(I .GT. NPIV) EXIT IF (DYNAMIC_ALLOC) THEN PIVI = DYN_PIVINFO(I) ELSE PIVI = IW(IPIV+I-1) ENDIF IF(PIVI .GT. 0) THEN IF (DYNAMIC_ALLOC) THEN A11 = ONE/DYN_BLOCFACTO(DPOS) ELSE A11 = ONE/A(DPOS) ENDIF CALL dscal( IEND-IBEG+1, A11, A_PTR(LPOS), NCOL1 ) LPOS = LPOS + 1_8 DPOS = DPOS + int(LD_BLOCFACTO + 1,8) I = I+1 ELSE POSPV1 = DPOS POSPV2 = DPOS+ int(LD_BLOCFACTO + 1,8) OFFDAG = POSPV1+1_8 IF (DYNAMIC_ALLOC) THEN A11 = DYN_BLOCFACTO(POSPV1) A22 = DYN_BLOCFACTO(POSPV2) A12 = DYN_BLOCFACTO(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = DYN_BLOCFACTO(POSPV2)/DETPIV A12 = -A12/DETPIV ELSE A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV ENDIF LPOS1 = LPOS DO J2 = 1, IEND-IBEG+1 MULT1 = A11*A_PTR(LPOS1)+A12*A_PTR(LPOS1+1_8) MULT2 = A12*A_PTR(LPOS1)+A22*A_PTR(LPOS1+1_8) A_PTR(LPOS1) = MULT1 A_PTR(LPOS1+1_8) = MULT2 LPOS1 = LPOS1 + int(NCOL1,8) ENDDO LPOS = LPOS + 2_8 DPOS = POSPV2 + int(LD_BLOCFACTO + 1,8) I = I+2 ENDIF ENDDO ENDDO !$OMP END PARALLEL DO ENDIF ENDIF ENDIF COMPRESS_CB = .FALSE. IF ( LR_ACTIVATED ) THEN NSLAVES_PREC = NSLAVES_TOT - NSLAVES_FOLLOW -1 COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) ENDIF IF (NROW1.GT.0) THEN IF (NPIV.GT.0.AND.NROW1.LE.0) THEN CALL MUMPS_ABORT() ENDIF IF (LR_ACTIVATED) THEN IF (NPIV1.NE.0.OR.JBEG_BLOCK.NE.1) THEN CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_LS) KEEP_BEGS_BLR_LS = .TRUE. NB_BLR_LS = size(BEGS_BLR_LS) - 2 NPARTSCB = NB_BLR_LS ELSE CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) CALL REGROUPING2(BEGS_BLR_LS, NPARTSASS, NASS1, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472), & NCOL1, KEEP(1)) NB_BLR_LS = NPARTSCB ENDIF IF (NPIV.GT.0) THEN call MAX_CLUSTER(BEGS_BLR_LM(2:NB_BLR_LM+2),NB_BLR_LM, & MAXI_CLUSTER_LM) ELSE MAXI_CLUSTER_LM = 0 ENDIF call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) MAXI_CLUSTER=max(MAXI_CLUSTER_LS,MAXI_CLUSTER_LM,NPIV) IF (COMPRESS_CB) THEN IF (NPIV1.EQ.0.AND.JBEG_BLOCK.EQ.1) THEN CALL GET_CUT(IW(IOLDPS+HS+NROW1:IOLDPS+HS+NROW1+NCOL1-1), & NASS1, & NCOL1-NASS1, LRGROUPS, NPARTSCB_COL, & NPARTSASS_COL, BEGS_BLR_COL) CALL REGROUPING2(BEGS_BLR_COL, NPARTSASS_COL, NASS1, & NPARTSCB_COL, & NCOL1-NASS1, KEEP(488), .FALSE., KEEP(472), & NCOL1, KEEP(1)) NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL IF (NPARTSASS_MASTER.NE.NPARTSASS_COL) THEN ALLOCATE(BEGS_BLR_COL_TMP( & size(BEGS_BLR_COL)-NPARTSASS_COL+NPARTSASS_MASTER), & stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BEGS_BLR_COL_TMP in", & "DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = size(BEGS_BLR_COL) & -NPARTSASS_COL+NPARTSASS_MASTER GOTO 700 END IF IF ( size(BEGS_BLR_COL).GT. NPARTSASS_COL) THEN DO II=1, size(BEGS_BLR_COL) - NPARTSASS_COL BEGS_BLR_COL_TMP (II+NPARTSASS_MASTER) = & BEGS_BLR_COL(II+NPARTSASS_COL) ENDDO ENDIF DO II= 1, NPARTSASS_MASTER BEGS_BLR_COL_TMP (II) = & BEGS_BLR_COL(max(NPARTSASS_COL,1)+1) ENDDO DEALLOCATE(BEGS_BLR_COL) BEGS_BLR_COL => BEGS_BLR_COL_TMP NPARTSASS_COL = NPARTSASS_MASTER NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL ENDIF ELSE CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_COL ) KEEP_BEGS_BLR_COL = .TRUE. NB_BLR_COL = size(BEGS_BLR_COL) - 1 NPARTSCB_COL = NB_BLR_COL - NPARTSASS_COL ENDIF ELSE NULLIFY(BEGS_BLR_COL) ENDIF IF (NPIV1.EQ.0.AND.(JBEG_BLOCK.EQ.1)) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR NB_ACCESSES_INIT = 1 IF ( (KEEP(486).EQ.2) & ) THEN NB_ACCESSES_INIT = huge(NPARTSASS_MASTER) END IF INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 700 CALL DMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .TRUE., & .TRUE., & NPARTSASS_COL, & BEGS_BLR_LS, BEGS_BLR_COL, NB_ACCESSES_INIT, & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 700 ENDIF LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF CURRENT_BLR = 1 IF (JBEG_BLOCK.EQ.1.AND.NPIV.GT.0) THEN CURRENT_BLR = 1 ALLOCATE(BLR_LS(NB_BLR_LS), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_LS GOTO 700 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL DMUMPS_COMPRESS_PANEL_I_NOOPT & (A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & DKEEP(8), KEEP(466), 0, & KEEP(473), BLR_LS(1), & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP8, & OMP_NUM) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 300 IF (KEEP(475).GE.1) THEN IF (DYNAMIC_ALLOC) THEN CALL DMUMPS_BLR_PANEL_LRTRSM( & DYN_BLOCFACTO, LA_BLOCFACTO, 1_8, & LD_BLOCFACTO, -6666, & NB_BLR_LS+1, & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1, & 2, 1, 0, & .TRUE., & DYN_PIVINFO, OFFSET_IW=1) ELSE CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, & LD_BLOCFACTO, -6666, & NB_BLR_LS+1, & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1, & 2, 1, 0, & .TRUE., & IW, OFFSET_IW=IPIV) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (KEEP(486).NE.2) THEN CALL DMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A_PTR(POSELT), LA_PTR, 1_8, & NCOL1, NCOL1, & .TRUE., & NPIV1+1, & 1, & NB_BLR_LS+1, BLR_LS(1), CURRENT_BLR, 'V', 1) ENDIF ENDIF 300 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & (OOCWRITE_COMPATIBLE_WITH_BLR .OR. NPIV.EQ.0) & .AND. (JBEG_BLOCK.EQ.1) & ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTPANEL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) LAST_CALL = .FALSE. CALL DMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L, & A_PTR(POSELT), & LA_PTR, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG_OOC, LAST_CALL) IF ( IFLAG_OOC .LT. 0 )THEN IFLAG = IFLAG_OOC GOTO 700 ENDIF ENDIF IF (NPIV.GT.0) THEN IF (LR_ACTIVATED) THEN IF (JBEG_BLOCK.NE.1) THEN CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_LS) KEEP_BLR_LS = .TRUE. ENDIF IF (NELIM.GT.0.AND.JBEG_BLOCK.EQ.1) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = 1_8+int(SHIFT_UPOS,8) LPOS = LPOS2 + int(SHIFT_LPOS,8) IF (DYNAMIC_ALLOC) THEN CALL DMUMPS_BLR_UPD_NELIM_VAR_L_I( & DYN_BLOCFACTO, LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1, & CURRENT_BLR+1, NELIM, 'N') ELSE CALL DMUMPS_BLR_UPD_NELIM_VAR_L_I( & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1, & CURRENT_BLR+1, NELIM, 'N') ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif IF (DYNAMIC_ALLOC) THEN CALL DMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, NROW1, JBEG_BLOCK, & DYN_BLOCFACTO, LA_BLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1, & BLR_LM(1), NPIV1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & BLR_LS(1), 0, & CURRENT_BLR, CURRENT_BLR, & DYN_PIVINFO, & BLOCKLR, & MAXI_CLUSTER, OMP_NUM, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ELSE CALL DMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, NROW1, JBEG_BLOCK, & A(POSBLOCFACTO), LA_BLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1, & BLR_LM(1), NPIV1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & BLR_LS(1), 0, & CURRENT_BLR, CURRENT_BLR, & IW(IPIV), & BLOCKLR, & MAXI_CLUSTER, OMP_NUM, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF IF (IFLAG.LT.0) GOTO 400 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 CALL UPD_MRY_LU_LRGAIN(BLR_LS, NPARTSCB & ) CALL DEALLOC_BLR_PANEL(BLR_LM, NB_BLR_LM, KEEP8, KEEP(34)) DEALLOCATE(BLR_LM) IF ( JBEG_BLOCK.EQ.1 & ) & THEN IF ( (KEEP(486).EQ.2) & ) THEN NB_ACCESSES_LEFT_INIT = huge(NB_ACCESSES_LEFT_INIT) ELSE NB_ACCESSES_LEFT_INIT = NCOL1 - NPIV1 - NROW1 ENDIF CALL DMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_LS, NB_ACCESSES_LEFT_INIT) KEEP_BLR_LS = .TRUE. ENDIF ELSE IF (NPIV .GT. 0 .AND. NCOL_GEMM_FR.GT.0)THEN LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(SHIFT_LPOS,8) IF (DYNAMIC_ALLOC) THEN UPOS = 1_8+int(SHIFT_UPOS,8) CALL dgemm('N','N', NCOL_GEMM_FR, NROW1, NPIV, & ALPHA, DYN_BLOCFACTO(UPOS), NEWCOL_RECV, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ELSE UPOS = POSBLOCFACTO+int(SHIFT_UPOS,8) CALL dgemm('N','N', NCOL_GEMM_FR, NROW1, NPIV, & ALPHA,A(UPOS), NEWCOL_RECV, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ENDIF ENDIF IF (JBEG_BLOCK.EQ.1) THEN DPOS = POSELT + int(NCOL1 - NROW1,8) #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1 .OR. & ( KEEP(421) .GT. 0 .AND. NROW1 .GT. KEEP(421) ) ) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = 1_8 CALL dgemmt( 'U', 'T', 'N', NROW1, NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A_PTR( LPOS2 ), NCOL1, ONE, & A_PTR( DPOS ), NCOL1 ) ELSE #endif IF ( NROW1 .GT. KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NROW1 ENDIF IF ( NROW1 .GT. 0 ) THEN DO IROW = 1, NROW1, BLSIZE Block = min( BLSIZE, NROW1 - IROW + 1 ) DPOS = POSELT + int(NCOL1 - NROW1,8) & + int( IROW - 1, 8 ) * int( NCOL1 + 1, 8 ) LPOS2 = POSELT + int(NPIV1,8) & + int( IROW - 1, 8 ) * int( NCOL1, 8 ) UPOS = int( IROW - 1, 8 ) * int(NPIV, 8) + 1_8 DO I = 1, Block CALL dgemv( 'T', NPIV, Block-I+1, ALPHA, & A_PTR( LPOS2 + int(I - 1,8) * int(NCOL1,8) ), NCOL1, & UIP21K( UPOS + int(NPIV,8) * int( I - 1, 8 ) ), & 1, ONE, A_PTR(DPOS+int(NCOL1+1,8)*int(I-1,8)),NCOL1 ) END DO IF ( NROW1-IROW+1-Block .ne. 0 ) & CALL dgemm( 'T', 'N', Block, NROW1-IROW+1-Block, & NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A_PTR( LPOS2 + int(Block,8) * int(NCOL1,8) ), NCOL1, & ONE, & A_PTR( DPOS + int(Block,8) * int(NCOL1,8) ), NCOL1 ) ENDDO ENDIF #if defined(GEMMT_AVAILABLE) ENDIF #endif ENDIF ENDIF IF (LASTBL_INPANEL) THEN FLOP1 = dble(NROW1) * dble(NPIV) * & dble( 2 * (NASS1-NPIV1) - NPIV + NROW1 +1 ) FLOP1 = -FLOP1 CALL MUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF ENDIF IF (JBEG_BLOCK.EQ.1) THEN IW(IOLDPS+KEEP(IXSZ)) = IW(IOLDPS+KEEP(IXSZ)) - NPIV IW(IOLDPS+3+KEEP(IXSZ)) = IW(IOLDPS+3+KEEP(IXSZ)) + NPIV ENDIF IF (LASTBL_INLASTPANEL) THEN IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+3+KEEP(IXSZ)) ENDIF IF ( .NOT. LR_ACTIVATED ) THEN IF (DYNAMIC_ALLOC) THEN IF (allocated(DYN_PIVINFO) ) DEALLOCATE(DYN_PIVINFO) IF (allocated(DYN_BLOCFACTO)) THEN KEEP8(130) = KEEP8(130)-max(1_8,LA_BLOCFACTO) DEALLOCATE(DYN_BLOCFACTO) KEEP8(69) = KEEP8(69) - max(1_8,LA_BLOCFACTO) KEEP8(73) = KEEP8(73) - max(1_8,LA_BLOCFACTO) ENDIF ELSE LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO IWPOS = IWPOS - NPIV CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 & .AND. JBEG_BLOCK.EQ.1 ) THEN IPOSK = NPIV1 + 1 JPOSK = NCOL1 - NROW1 + 1 NPIVSENT = NPIV BLFAC_NBCOLS_ALREADY_SENT = 0 BLFAC_NBLRB_ALREADY_SENT = 0 IERR = -1 DO WHILE ( IERR .eq. -1 ) IF (DYNAMIC_ALLOC) THEN CALL DMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, LUIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & BLFAC_NBCOLS_ALREADY_SENT, BLFAC_NBLRB_ALREADY_SENT, & NOTHING_WAS_SENT, & DYN_BLOCFACTO, LA_BLOCFACTO, & 1_8, LD_BLOCFACTO, & DYN_PIVINFO, MAXI_CLUSTER, & IERR, IERROR ) ELSE CALL DMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, LUIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & BLFAC_NBCOLS_ALREADY_SENT, BLFAC_NBLRB_ALREADY_SENT, & NOTHING_WAS_SENT, & A, LA, & POSBLOCFACTO, LD_BLOCFACTO, & IW(IPIV), MAXI_CLUSTER, & IERR, IERROR ) ENDIF IF (IERR.EQ.-13) THEN IFLAG = IERR IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE within DMUMPS_BUF_SEND_BLFAC_SLAVE", & " during DMUMPS_PROCESS_SYM_BLOCFACTO", IERROR GOTO 700 ENDIF IF (IERR .EQ. -1 .AND. NOTHING_WAS_SENT) THEN IOLDPS = PTRIST(STEP(INODE)) IF ( IW(IOLDPS+6+KEEP(IXSZ)) .eq. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN COUNTER_WAS_HUGE=.TRUE. IW(IOLDPS+6+KEEP(IXSZ)) = 1 ELSE COUNTER_WAS_HUGE=.FALSE. ENDIF TO_UPDATE_CPT_RECUR = & ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & (2*NASS1/KEEP(6)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) - TO_UPDATE_CPT_RECUR - 10 BLOCKING = .FALSE. SET_IRECV= .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + TO_UPDATE_CPT_RECUR + 10 IF ( COUNTER_WAS_HUGE .AND. & IW(IOLDPS+6+KEEP(IXSZ)).EQ.1 ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = huge(IW(IOLDPS+6+KEEP(IXSZ))) ENDIF IF ( IFLAG .LT. 0 ) GOTO 550 END IF END DO IF ( IERR .eq. -2 ) THEN IF (LP > 0 ) THEN WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING & DMUMPS_PROCESS_SYM_BLOCFACTO" ENDIF IFLAG = -17 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF IF ( IERR .eq. -3 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING & DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -20 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF DEALLOCATE(LIST_SLAVES_FOLLOW) END IF IF ( LR_ACTIVATED ) THEN IF (NPIV.GT.0 & .AND. KEEP(486).EQ.3 & ) THEN IOLDPS = PTRIST(STEP(INODE)) CALL DMUMPS_BLR_DEC_AND_TRYFREE_L(IW(IOLDPS+XXF),IPANEL, & KEEP8, KEEP(34), NEWCOL_RECV) ENDIF IF (DYNAMIC_ALLOC) THEN IF (allocated(DYN_PIVINFO)) DEALLOCATE(DYN_PIVINFO) IF (allocated(DYN_BLOCFACTO)) THEN KEEP8(130) = KEEP8(130)-max(1_8,LA_BLOCFACTO) DEALLOCATE(DYN_BLOCFACTO) ENDIF ELSE IF (NPIV .GT. 0) THEN LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO IWPOS = IWPOS - NPIV CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF ( NPIV .NE. 0 ) THEN IF (associated(UIP21K)) THEN CALL DMUMPS_DM_FREE_S_WK( UIP21K, KEEP430_LOC ) NULLIFY( UIP21K ) KEEP8(130) = KEEP8(130)-LUIP21K KEEP8(69) = KEEP8(69) - LUIP21K KEEP8(73) = KEEP8(73) - LUIP21K ENDIF ENDIF IOLDPS = PTRIST(STEP(INODE)) IF (LR_ACTIVATED ) THEN COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) ENDIF CALL DMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) IF (LASTBL_INLASTPANEL) THEN IF ( KEEP(486) .NE. 0) THEN IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = IW(IOLDPS+6+KEEP(IXSZ)) & - TO_UPDATE_CPT_END & - 1 END IF IF ( IW(IOLDPS+6+KEEP(IXSZ) ) .eq. 0 & .and. KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 & .and. NSLAVES_TOT.NE.1 ) THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) CALL MUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_SYM_BLOCFACTO.' IFLAG = -99 GOTO 700 END IF ENDIF IF (IW(IOLDPS+6+KEEP(IXSZ)) .eq. 0 & ) THEN IOLDPS = PTRIST(STEP(INODE)) NELIM = IW( IOLDPS + 4 + KEEP(IXSZ)) - & IW( IOLDPS + 3 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) IF (LR_ACTIVATED) THEN IF (COMPRESS_CB) THEN allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_COL), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_COL) GOTO 700 ENDIF DO II=1,NB_BLR_LS DO JJ=1,NB_BLR_COL-NPARTSASS_COL CB_LRB(II,JJ)%M=0 CB_LRB(II,JJ)%N=0 NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL DMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL DMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) NFS4FATHER = max(NFS4FATHER,0) + NELIM ENDIF ALLOCATE(M_ARRAY(max(1,NFS4FATHER)), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR M_ARRAY ", & "DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = max(1,NFS4FATHER) ENDIF BEGS_BLR_COL(1+NPARTSASS_COL) = & BEGS_BLR_COL(1+NPARTSASS_COL) - NELIM CALL MAX_CLUSTER( & BEGS_BLR_COL(max(NPARTSASS_MASTER,1)+1:NB_BLR_COL+1), & NB_BLR_COL-max(NPARTSASS_MASTER,1),MAXI_CLUSTER_COL & ) MAXI_CLUSTER=max(MAXI_CLUSTER_LS, MAXI_CLUSTER_COL) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF NBROWSinF = 0 NVSCHUR_K253 = 0 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN CALL DMUMPS_COMPUTE_NBROWSinF ( & N, INODE, FPERE, KEEP, & IOLDPS, HS, & IW, LIW, & NROW1, NCOL1, NPIV1, & NELIM, NFS4FATHER, & NBROWSinF & ) IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) ) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL DMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR_K253 ) ELSE IF (KEEP(253).NE.0) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL DMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & 0, & IW(IROW_L), & PERM, NVSCHUR_K253 ) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 700 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL DMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_LS, NB_BLR_COL-NPARTSASS_COL, & NPARTSASS_COL, & NROW1, NCOL1-NPIV1, INODE, & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV1, NVSCHUR_K253, KEEP(1), & M_ARRAY & , NELIM, NBROWSinF & ) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 650 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL DMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF DEALLOCATE(M_ARRAY) 650 CONTINUE ENDIF IF (IFLAG.LT.0) GOTO 700 ENDIF CALL DMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, roota, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF GOTO 550 700 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 550 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (.NOT.KEEP_BEGS_BLR_LS) THEN IF (associated(BEGS_BLR_LS)) DEALLOCATE(BEGS_BLR_LS) ENDIF IF (.NOT.KEEP_BLR_LS) THEN IF (associated(BLR_LS)) THEN CALL DEALLOC_BLR_PANEL(BLR_LS, NB_BLR_LS, KEEP8, KEEP(34)) DEALLOCATE(BLR_LS) ENDIF ENDIF IF (associated(BEGS_BLR_LM)) DEALLOCATE(BEGS_BLR_LM) IF (.NOT.KEEP_BEGS_BLR_COL) THEN IF (COMPRESS_CB) THEN IF (associated(BEGS_BLR_COL)) THEN DEALLOCATE( BEGS_BLR_COL) ENDIF ENDIF ENDIF ENDIF KEEP(174)=KEEP(174)-1 RETURN END SUBROUTINE DMUMPS_PROCESS_SYM_BLOCFACTO MUMPS_5.8.1/src/zfac_asm_master_ELT_m.F0000664000175000017500000021512215042446441017521 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_ASM_MASTER_ELT_M CONTAINS SUBROUTINE ZMUMPS_FAC_ASM_NIV1_ELT( COMM_LOAD, ASS_IRECV, & UU, NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, INFO, ND, & FILS, FRERE, DAD, MAXFRW, root, roota, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, LRLUSM, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & , MUMPS_TPS_ARR, ZMUMPS_TPS_ARR, L0_OMP_MAPPING & ) !$ USE OMP_LIB USE MUMPS_TPS_M USE ZMUMPS_TPS_M USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_PTR, & ZMUMPS_DM_FREE_BLOCK USE MUMPS_BUILD_SORT_INDEX_ELT_M USE MUMPS_BUF_COMMON, ONLY: MUMPS_BUF_SEND_MAPLIG USE MUMPS_LOAD USE ZMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE, & ZMUMPS_BLR_ASM_NIV1 USE ZMUMPS_LR_DATA_M, ONLY : ZMUMPS_BLR_INIT_FRONT, & ZMUMPS_BLR_SAVE_NFS4FATHER USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N, NSTEPS INTEGER NELT INTEGER(8) LA, LRLU, LRLUS, LRLUSM, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) DOUBLE PRECISION UU INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS, LIW TYPE (MUMPS_TPS_T), TARGET, OPTIONAL :: MUMPS_TPS_ARR(:) TYPE (ZMUMPS_TPS_T), TARGET, OPTIONAL :: ZMUMPS_TPS_ARR(:) INTEGER, INTENT(IN), OPTIONAL :: L0_OMP_MAPPING(:) INTEGER IDUMMY(1) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER, TARGET :: IW(LIW) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ITLOC(N+KEEP(253)), & ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)), & PAMASTER(KEEP(28)) INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER ETATASS LOGICAL SON_LEVEL2 COMPLEX(kind=8), TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR COMPLEX(kind=8) DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) LOGICAL PACKED_CB, IS_CB_LR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF LOGICAL LPOK INTEGER NBPANELS_L, NBPANELS_U INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER PARPIV_T1 INTEGER(8) NFRONT8, LAELL8, KEEP8TMPCOPY INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER LREQ_OOC INTEGER :: SON_XXS, SON_XXLR, SON_XXG INTEGER(8) LSTK8, SIZFR8 LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM, IORG, IBROT INTEGER :: J253 #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER(8) APOS, APOS2, LAPOS2 INTEGER(8) POSELT, POSEL1, ICT12, ICT21 INTEGER(8) IACHK INTEGER(8) JJ2 INTEGER(8) :: JJ8, J18, J28 INTEGER(8) :: AINPUT8, AII8 INTEGER :: K1, K2, K3, KK, KK1 INTEGER JPOS,ICT11, IJROW INTEGER Pos_First_NUMORG,NUMORG,IOLDPS, & NUMELT, ELBEG INTEGER :: J INTEGER NSLAVES, NSLSON, NPIVS, NPIV_ANA, NPIV INTEGER PTRCOL, ISLAVE, PDEST,LEVEL LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER ELTI INTEGER(8) :: SIZE_ELTI8 INTEGER(8) :: II8 INTEGER :: I LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: ITHREAD INTEGER, POINTER :: SON_IWPOS, SON_LIW INTEGER, POINTER, DIMENSION(:) :: SON_IW COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTEGER PIVOT_OPTION COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) LOGICAL MUMPS_INSSARBR, SSARBR EXTERNAL MUMPS_INSSARBR DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR !$ NOMP = OMP_GET_MAX_THREADS() LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) NFS4FATHER = -1 ETATASS = 0 PACKED_CB = .FALSE. IS_CB_LR = .FALSE. IN = INODE LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (LEVEL.NE.1) THEN WRITE(*,*) 'INTERNAL ERROR 1 in ZMUMPS_FAC_ASM_NIV1_ELT ' CALL MUMPS_ABORT() END IF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) NUMELT = FRT_PTR(INODE+1) - FRT_PTR(INODE) IF ( NUMELT .ne. 0 ) THEN ELBEG = FRT_PTR(INODE) ELSE ELBEG = 1 END IF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) END DO NPIV_ANA=NUMORG NSTEPS = NSTEPS + 1 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 SON_IW => IW IF (KEEP(400).GT.0) THEN IF (present(L0_OMP_MAPPING)) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .NE.0) THEN SON_IW=>MUMPS_TPS_ARR(ITHREAD)%IW ENDIF ENDIF ENDIF NASS = NASS + SON_IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG CALL IS_FRONT_BLR_CANDIDATE(INODE, 1, ND(STEP(INODE)), & NUMORG, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, KEEP(280), LRGROUPS) IF (DAD(STEP(INODE)).NE.0) THEN IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199) ) & .NE. MYID & .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199)) & .EQ.1 & ) THEN IF (LRSTATUS.EQ.1 .OR. LRSTATUS.EQ.3) THEN LRSTATUS = LRSTATUS-1 ENDIF ENDIF ENDIF COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_OOC_GET_PP_SIZES(KEEP(50), NFRONT, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL ZMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, SLAVEF, & PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ZMUMPS_FAC_ASM_NIV1_ELT' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 END IF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 END IF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .TRUE. IF (.NOT. present(MUMPS_TPS_ARR).AND. & .NOT. present(L0_OMP_MAPPING) ) THEN CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & IDUMMY, LIDUMMY ) ELSE CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & IDUMMY, LIDUMMY & , MUMPS_TPS_ARR, L0_OMP_MAPPING ) ENDIF IF (INFO(1).LT.0) GOTO 300 IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL MUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1-FLOP1_EFF, & KEEP,KEEP8) ENDIF IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) & ' ERROR 1 during ass_niv1_ELT', NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF NCB = NFRONT - NASS1 MAXFRW = max(MAXFRW, NFRONT) ICT11 = IOLDPS + HF - 1 + NFRONT CALL ZMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) PIVOT_OPTION = KEEP(468) IF (UU.EQ.ZERO) THEN PIVOT_OPTION=0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF(PARPIV_T1.NE.0) THEN LAELL8 = LAELL8+int(NASS1,8) ENDIF CALL ZMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 LRLUSM = min( LRLUS, LRLUSM ) IF (KEEP(405).EQ.0) THEN KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + LAELL8 KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ENDIF POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8, & KEEP,KEEP8, & LRLUS) IF (KEEP(405).EQ.0) KEEP(429)= KEEP(429)+1 #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8=int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (LAPOS2 - POSELT + 1_8 > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8), KEEP(218))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & NCB, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1,TOPDIAG) ENDIF NUMROWS = NFRONT8 !$ CHUNK = max(KEEP(360)/2, !$ & ( ((int(NUMROWS)+NOMP-1) / NOMP + 2) / 3) ) #if defined(__ve__) !NEC$ IVDEP #endif !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK ) !$OMP& IF (int(NUMROWS - 1) .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = POSELT + JJ8 * NFRONT8 JJ3 = min( NFRONT8 - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS + JJ3) = ZERO ENDDO !$OMP END PARALLEL DO END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS IW(IOLDPS + KEEP(IXSZ)) = NFRONT IW(IOLDPS + KEEP(IXSZ)+ 1) = 0 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN CALL ZMUMPS_BLR_INIT_FRONT (IW(IOLDPS+XXF), INFO, & MTK405=KEEP(405)) IF (INFO(1).LT.0) GOTO 500 ENDIF ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL ZMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) CALL ZMUMPS_BLR_SAVE_NFS4FATHER ( IW(IOLDPS+XXF), & ESTIM_NFS4FATHER_ATSON ) ENDIF ENDIF ENDIF IF (NUMSTK.NE.0) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_LIW => LIW SON_IWPOS => IWPOS SON_A => A ITHREAD = 0 IF (KEEP(400).GT.0) THEN IF (present(L0_OMP_MAPPING)) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .NE.0) THEN SON_LIW => MUMPS_TPS_ARR(ITHREAD)%LIW SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW SON_IWPOS => MUMPS_TPS_ARR(ITHREAD)%IWPOS SON_A => ZMUMPS_TPS_ARR(ITHREAD)%A ENDIF ENDIF ENDIF LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + KEEP(IXSZ) + 1) NPIVS = SON_IW(ISTCHK + KEEP(IXSZ) + 3) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = SON_IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.SON_IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT = PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT = ISTCHK ENDIF SON_XXS = SON_IW(ISTCHK_CB_RIGHT+XXS) SON_XXLR = SON_IW(ISTCHK_CB_RIGHT+XXLR) SON_XXG = SON_IW(ISTCHK_CB_RIGHT+XXG) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IS_CB_LR = ( SON_XXLR.EQ.1 .OR. SON_XXLR.EQ.3 ) & .AND. (KEEP(489).EQ.1.OR.KEEP(489).EQ.3) LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = SON_IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF K1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN K2 = K1 + LSTK - 1 IF (PACKED_CB) THEN SIZFR8 = (LSTK8*(LSTK8+1_8)/2_8) ELSE SIZFR8 = LSTK8*LSTK8 ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * LSTK8 ELSE IF (PACKED_CB) THEN SIZFR8 = int(NELIM,8) * int(NELIM+1,8)/2_8 ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) ENDIF END IF K2 = K1 + NELIM - 1 ENDIF IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + LSTK8*LSTK8 ELSE OPASSW = OPASSW + LSTK8*(LSTK8+1)/2_8 ENDIF ELSE IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + int(NELIM,8)*LSTK8 ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM,8)/2_8 ENDIF ENDIF CALL MUMPS_GETI8(DYN_SIZE, SON_IW(ISTCHK_CB_RIGHT+XXD)) IS_DYNAMIC_CB = DYN_SIZE .GT. 0_8 IF ( IS_DYNAMIC_CB ) THEN CALL ZMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) ENDIF IF (IS_CB_LR .AND. LEVEL1) THEN POSEL1 = PTRAST(STEP(INODE)) CALL ZMUMPS_BLR_ASM_NIV1 (A, LA, & POSEL1, NFRONT, NASS1, SON_IW(ISTCHK+XXF), & SON_IW, SON_LIW, & LSTK, NELIM, K1, K1+LSTK-1, KEEP(50), & KEEP, KEEP8, OPASSW) ENDIF IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (K2.GE.K1) THEN #if defined(__ve__) !NEC$ IVDEP #endif DO 170 KK = K1, K2 APOS = POSEL1 + int(SON_IW(KK),8) * NFRONT8 #if defined(__ve__) !NEC$ IVDEP #endif DO 160 KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1 + KK1 - 1) - 1,8) A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + LSTK8 170 CONTINUE END IF ELSE IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (SIZFR8 .GT. 0) THEN CALL ZMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF (SAME_PROC) THEN IF (KEEP(50).NE.0) THEN K2 = K1 + LSTK - 1 #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K1, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO ELSE K2 = K1 + LSTK - 1 K3 = K1 + NELIM #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K3, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO IF (NELIM .NE. 0) THEN K3 = K3 - 1 #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K1, K3 JPOS = SON_IW(KK) + ICT11 SON_IW(KK) = IW(JPOS) ENDDO ENDIF ENDIF ENDIF IF ( SAME_PROC ) THEN PTRIST(STEP(ISON)) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF IF (ITHREAD .EQ. 0) THEN CALL ZMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & .FALSE. & ) ELSE CALL MUMPS_LOAD_DISABLE() CALL ZMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & MUMPS_TPS_ARR(ITHREAD)%IW(1), & MUMPS_TPS_ARR(ITHREAD)%LIW, & MUMPS_TPS_ARR(ITHREAD)%LRLU, & MUMPS_TPS_ARR(ITHREAD)%LRLUS, & MUMPS_TPS_ARR(ITHREAD)%IPTRLU, & MUMPS_TPS_ARR(ITHREAD)%IWPOSCB, & MUMPS_TPS_ARR(ITHREAD)%LA, KEEP,KEEP8, .FALSE. & ) CALL MUMPS_LOAD_ENABLE() ENDIF IF (IS_DYNAMIC_CB) THEN CALL ZMUMPS_DM_FREE_BLOCK(SON_XXG, & SON_A, SIZFR8, & KEEP(405).EQ.1, KEEP8 ) ENDIF ELSE PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP, KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL ZMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, IDUMMY, & NFRONT, NASS1, NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & IZERO, IDUMMY, IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP, KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE., LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF END DO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) 220 CONTINUE END IF DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = INTARR(II8) IF (KEEP(50).EQ.0) THEN AINPUT8 = AII8 + II8 - J18 ICT12 = POSELT + int(I-1,8) * NFRONT8 DO JJ8=J18,J28 APOS2 = ICT12 + int(INTARR(JJ8) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ELSE ICT12 = POSELT + int(- NFRONT + I - 1,8) ICT21 = POSELT + int(I-1,8)*NFRONT8 - 1_8 DO JJ8=II8,J28 J = INTARR(JJ8) IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*NFRONT8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII8) AII8 = AII8 + 1_8 END DO END IF END DO END DO IF (KEEP(253).GT.0) THEN POSELT = PTRAST(STEP(INODE)) IBROT = INODE IJROW = Pos_First_NUMORG DO IORG = 1, NUMORG IF (KEEP(50).EQ.0) THEN DO J253=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ELSE DO J253=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+J253-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF IF (PARPIV_T1.NE.0.AND.(.NOT.SON_LEVEL2)) THEN IOLDPS = PTLUST(STEP(INODE)) CALL ZMUMPS_PARPIVT1_SET_NVSCHUR_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1, NASS) ENDIF GOTO 500 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING ZMUMPS_ASM_NIV1_ELT' ENDIF GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING ZMUMPS_ASM_NIV1_ELT' ENDIF INFO(1) = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, RECV BUFFER TOO SMALL DURING ZMUMPS_ASM_NIV1_ELT' ENDIF INFO(1) = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) ' FAILURE IN INTEGER', & ' DYNAMIC ALLOCATION DURING ZMUMPS_ASM_NIV1_ELT' ENDIF INFO(2) = NUMSTK ENDIF 490 CONTINUE IF ( KEEP(405) .EQ. 0 ) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_ASM_NIV1_ELT SUBROUTINE ZMUMPS_FAC_ASM_NIV2_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, INFO, & ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, roota, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, MEM_DISTRIB & , LRGROUPS & ) !$ USE OMP_LIB USE MUMPS_BUILD_SORT_INDEX_ELT_M USE MUMPS_BUF_COMMON, ONLY: MUMPS_BUF_SEND_MAPLIG, & MUMPS_BUF_SEND_DESC_BANDE USE MUMPS_LOAD USE ZMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_PTR, & ZMUMPS_DM_IS_DYNAMIC USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER NELT INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC, LA INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE, MAXFRW, LPOOL, LEAF, & IWPOS, IWPOSCB, COMP, SLAVEF COMPLEX(kind=8), TARGET :: A(LA) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR COMPLEX(kind=8) DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER MYID, COMM INTEGER IFATH INTEGER LBUFR, LBUFR_BYTES INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INTEGER LP, HS, HF, HF_OLD, NCBSON, NSLAVES_OLD LOGICAL LPOK INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL COMPLEX(kind=8), DIMENSION(:), POINTER :: SON_A INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER :: SON_XXS INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL PACKED_CB, IS_CB_LR INTEGER(8) :: LCB LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER MP INTEGER :: K1, K2, KK, KK1 INTEGER :: J253 INTEGER(8) :: AII8, AINPUT8, II8 INTEGER(8) :: J18,J28,JJ8 INTEGER(8) :: LAPOS2, JJ2, JJ3 INTEGER(8) :: NFRONT8, POSELT, POSEL1, LDAFS8, & IACHK, ICT12, ICT21 INTEGER(8) APOS, APOS2 #if ! defined(ZERO_TRIANGLE) INTEGER :: TOPDIAG #endif !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM,NPIVS,NCOLS,NROWS, & IORG INTEGER LDAFS, LDA_SON, IJROW, IBROT INTEGER Pos_First_NUMORG,NBCOL,NUMORG,IOLDPS INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, PDEST INTEGER PDEST1(1) INTEGER :: ISLAVE INTEGER ELTI INTEGER(8) :: SIZE_ELTI8 INTEGER :: I, J INTEGER :: ELBEG, NUMELT LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER IZERO INTEGER IDUMMY(1) PARAMETER( IZERO = 0 ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT COMPLEX(kind=8) ZERO DOUBLE PRECISION RZERO PARAMETER( RZERO = 0.0D0 ) PARAMETER( ZERO = (0.0D0,0.0D0) ) logical :: force_cand INTEGER ETATASS INTEGER(8) :: APOSMAX DOUBLE PRECISION MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT, & NUMORG_SPLIT, TYPESPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER, ALLOCATABLE, DIMENSION(:) :: SONROWS_PER_ROW INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTEGER :: NMB_OF_CAND, NMB_OF_CAND_ORIG LOGICAL :: IS_ofType5or6, SPLIT_MAP_RESTART !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IS_ofType5or6 = .FALSE. PACKED_CB = .FALSE. ETATASS = 0 IN = INODE NSTEPS = NSTEPS + 1 KEEP(429) = KEEP(429)+1 NUMELT = FRT_PTR(INODE+1) - FRT_PTR(INODE) IF ( NUMELT .NE. 0 ) THEN ELBEG = FRT_PTR(INODE) ELSE ELBEG = 1 END IF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON NCBSON_MAX = 0 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 IF ( KEEP(48)==5 .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) ENDIF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 CALL IS_FRONT_BLR_CANDIDATE(INODE, 2, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, KEEP(280), LRGROUPS) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then force_cand=.FALSE. ELSE force_cand=(mod(KEEP(24),2).eq.0) end if TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) SPLIT_MAP_RESTART = .FALSE. IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) NMB_OF_CAND = CAND( SLAVEF+1, INIV2 ) NMB_OF_CAND_ORIG = NMB_OF_CAND SIZE_TMP_SLAVES_LIST = NMB_OF_CAND IF (IS_ofType5or6) THEN DO I=NMB_OF_CAND+1,SLAVEF IF ( CAND( I, INIV2 ).LT.0) EXIT NMB_OF_CAND = NMB_OF_CAND +1 ENDDO SIZE_TMP_SLAVES_LIST = NSLSON-1 WRITE(6,*) "NMB_OF_CAND, SIZE_TMP_SLAVES_LIST ", & NMB_OF_CAND, SIZE_TMP_SLAVES_LIST IF (INODE.EQ.-999999) THEN SPLIT_MAP_RESTART = .TRUE. ENDIF ENDIF IF (IS_ofType5or6.AND.SPLIT_MAP_RESTART) THEN TYPESPLIT = 4 IS_ofType5or6 = .FALSE. SIZE_TMP_SLAVES_LIST = NMB_OF_CAND CAND (SLAVEF+1, INIV2) = SIZE_TMP_SLAVES_LIST ENDIF ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 NMB_OF_CAND = SLAVEF - 1 NMB_OF_CAND_ORIG = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IF ( (TYPESPLIT.EQ.4) & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) & ) THEN IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) IF (SPLIT_MAP_RESTART) THEN IS_ofType5or6 = .TRUE. TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) CAND( SLAVEF+1, INIV2 ) = NMB_OF_CAND_ORIG ENDIF ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) IF (KEEP(376) .EQ. 1) THEN NFRONT = IW( PIMASTER(STEP(IFSON)) + KEEP(IXSZ)) ENDIF CALL MUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND(1,INIV2), NMB_OF_CAND_ORIG, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES, & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST & ) ENDIF ELSE CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_OOC_GET_PP_SIZES(KEEP(50), NASS1, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL ZMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & LRLUS,KEEP(IXSZ), & COMP, DKEEP(97), MYID, SLAVEF, & PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress ZMUMPS_FAC_ASM_NIV2_ELT', & 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. ALLOCATE(SONROWS_PER_ROW(NFRONT-NASS1), stat=allocok) IF (allocok > 0) THEN GOTO 275 ENDIF CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & SONROWS_PER_ROW, NFRONT - NASS1) IF (INFO(1).LT.0) GOTO 250 IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN WRITE(6,*) ' Internal error 1 in fac_ass due to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF WRITE(6,*) ' SPLITTING NOT YET READY FOR THAT' CALL MUMPS_ABORT() ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN NCB = NFRONT_EFF - NASS1 NSLAVES_OLD = NSLAVES HF_OLD = HF IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP, KEEP8, ICNTL, & CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - & (NSLAVES_OLD - NSLAVES) IF (NSLAVES_OLD .NE. NSLAVES) THEN IF (NSLAVES_OLD > NSLAVES) THEN DO KK=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+KK)=IW(IOLDPS+HF_OLD+KK) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO KK=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+KK) = IW(IOLDPS+HF_OLD+KK) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) ' INTERNAL ERROR 2 during ass_niv2' ENDIF GOTO 270 ENDIF ENDIF NFRONT8=int(NFRONT,8) IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max(MAXFRW, NFRONT) PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+KEEP(IXSZ)) = NFRONT IW(IOLDPS + 1+KEEP(IXSZ)) = 0 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+NSLAVES+KEEP(IXSZ))= & TMP_SLAVES_LIST(1:NSLAVES) ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL ZMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) ENDIF ENDIF ENDIF CALL MUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM_LOAD, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP, KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) IF(KEEP(86).EQ.1)THEN IF(mod(KEEP(24),2).eq.0)THEN CALL MUMPS_LOAD_SEND_MD_INFO(SLAVEF, & CAND(SLAVEF+1,INIV2), & CAND(1,INIV2), & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN CALL MUMPS_LOAD_SEND_MD_INFO(SLAVEF, & SLAVEF-1, & TMP_SLAVES_LIST, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ENDIF ENDIF DEALLOCATE(TMP_SLAVES_LIST) IF (KEEP(50).EQ.0) THEN LAELL8 = int(NASS1,8) * NFRONT8 LDAFS = NFRONT LDAFS8 = NFRONT8 ELSE LAELL8 = int(NASS1,8)*int(NASS1,8) IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) & LAELL8 = LAELL8+int(NASS1,8) LDAFS = NASS1 LDAFS8 = int(NASS1,8) ENDIF CALL ZMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= LRSTATUS IW(IOLDPS+XXG) = MemNotPinned CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8,LRLUS) POSEL1 = POSELT - LDAFS8 #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8 = int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (LAPOS2 - POSELT > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO JJ8 = POSELT, LAPOS2 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max(KEEP(360)/2, !$ & ( (( LDAFS + NOMP -1 ) / NOMP + 2) / 3) ) APOS = POSELT #if defined(__ve__) !NEC$ IVDEP #endif !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK) !$OMP& IF (LDAFS - 1 .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(LDAFS-1,8) APOS = POSELT + JJ8 * int(LDAFS,8) JJ3 = min( int(LDAFS,8) - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) A(APOSMAX:APOSMAX+int(LDAFS-1,8))=ZERO ENDIF END IF #endif IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) IF (NELIM.EQ.0) GOTO 210 LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT=PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT=ISTCHK ENDIF SON_XXS = IW(ISTCHK_CB_RIGHT + XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF IF (KEEP(50).EQ.0) THEN LDA_SON = LSTK LCB = int(NELIM,8)*int(LSTK,8) ELSE IF (NSLSON.EQ.0) THEN IF (SAME_PROC) THEN IS_CB_LR = IW(ISTCHK_CB_RIGHT+XXLR).EQ. 1 .OR. & IW(ISTCHK_CB_RIGHT+XXLR).EQ. 3 IF (IS_CB_LR) THEN LDA_SON = NELIM ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = NELIM ENDIF IF (PACKED_CB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN OPASSW = OPASSW + dble(LCB) ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM+1,8)/2_8 ENDIF IS_DYNAMIC_CB = & ZMUMPS_DM_IS_DYNAMIC(IW(ISTCHK_CB_RIGHT+XXD: & ISTCHK_CB_RIGHT+XXD+1)) IF ( IS_DYNAMIC_CB ) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_CB_RIGHT+XXD)) CALL ZMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) SON_A=>A ENDIF K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IF (KEEP(50).eq.0) THEN IF (IS_ofType5or6) THEN APOS = POSELT DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + SON_A(IACHK+JJ8-1_8) ENDDO ELSE DO 170 KK = K1, K2 APOS = POSEL1 + int(IW(KK),8) * LDAFS8 DO 160 KK1 = 1, LSTK JJ2 = APOS + int(IW(K1 + KK1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (LCB .GT. 0) THEN CALL ZMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) IF (KEEP(219).NE.0) THEN IF (KEEP(50).EQ.2) THEN A( APOSMAX: APOSMAX+int(NASS1-1,8))=ZERO ENDIF ENDIF DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1) - 1_8 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = INTARR(II8) IF (KEEP(50).EQ.0) THEN IF (I.LE.NASS1) THEN AINPUT8 = AII8 + II8 - J18 ICT12 = POSELT + int(I-1,8) * LDAFS8 DO JJ8=J18,J28 APOS2 = ICT12 + int(INTARR(JJ8) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ENDIF ELSE ICT12 = POSELT - LDAFS8 + int(I,8) - 1_8 ICT21 = POSELT + int(I-1,8)*LDAFS8 - 1_8 IF ( I .GT. NASS1 ) THEN IF (KEEP(219).NE.0 .AND. KEEP(50).EQ.2) THEN AINPUT8=AII8 DO JJ8=II8,J28 J=INTARR(JJ8) IF (J.LE.NASS1) THEN A(APOSMAX+int(J-1,8))=cmplx( & max(dble(A(APOSMAX+int(J-1,8))), & abs(DBLARR(AINPUT8))), & kind=kind(A) & ) ENDIF AINPUT8=AINPUT8+1_8 ENDDO ENDIF AII8 = AII8 + J28 - II8 + 1_8 CYCLE ELSE IF (KEEP(219).NE.0) THEN MAXARR = RZERO ENDIF DO JJ8=II8,J28 J = INTARR(JJ8) IF ( J .LE. NASS1) THEN IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*LDAFS8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII8) ELSE IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AII8))) ENDIF AII8 = AII8 + 1_8 END DO IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(I-1,8)) = cmplx( & max( MAXARR, dble(A(APOSMAX+int(I-1,8)))), & kind=kind(A) & ) ENDIF ENDIF END IF END DO END DO IF (KEEP(253).GT.0) THEN POSELT = PTRAST(STEP(INODE)) IBROT = INODE IJROW = Pos_First_NUMORG DO IORG = 1, NUMORG IF (KEEP(50).EQ.0) THEN DO J253 = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & NBLIG, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 IERR = -1 DO WHILE (IERR .EQ.-1) IF ( KEEP(50) .eq. 0 ) THEN NBCOL = NFRONT CALL MUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL MUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF ENDDO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 ENDDO DEALLOCATE(SONROWS_PER_ROW) IF (NUMSTK.EQ.0) GOTO 500 ISON = IFSON DO IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + 2 + KEEP(IXSZ) ) ELSE NROWS = NCOLS ENDIF PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN NFS4FATHER = NCBSON DO I=0,NCBSON-1 IF(IW(PTRCOL+I) .GT. NASS1) THEN NFS4FATHER = I EXIT ENDIF ENDDO NFS4FATHER = NFS4FATHER + NELIM ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) IF (PDEST1(1).EQ.MYID) THEN CALL ZMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & NFRONT, NASS1, NFS4FATHER, NCBSON, IW( PTRCOL ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, roota, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, NELT+1, NELT, & FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, PDEST1, NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL ZMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & NFRONT, NASS1,NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), INFO(2), & MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & ZMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(2) = NUMSTK + 1 ENDIF GOTO 490 245 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING COPY_CAND', & ' DURING ZMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = SLAVEF+1 GOTO 490 265 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING ZMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING ZMUMPS_ASM_NIV2_ELT' ENDIF GOTO 490 275 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING SONROWS_PER_ROW', & ' DURING ZMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = NFRONT-NASS1 GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (1) DURING ZMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (1) DURING ZMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (2)', &' DURING ZMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (2)', &' DURING ZMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -20 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 490 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_ASM_NIV2_ELT END MODULE ZMUMPS_FAC_ASM_MASTER_ELT_M MUMPS_5.8.1/src/cmumps_f77.F0000664000175000017500000004377515042446440015346 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, NBLK, ICNTL, & CNTL, KEEP, DKEEP, KEEP8, NZ, NNZ, IRN, IRNhere, JCN, & JCNhere, A, Ahere, NZ_loc, NNZ_loc, IRN_loc, IRN_lochere, & JCN_loc, JCN_lochere, A_loc, A_lochere, NELT, ELTPTR, & ELTPTRhere, ELTVAR, ELTVARhere, A_ELT, A_ELThere, & BLKPTR, BLKPTRhere, BLKVAR, BLKVARhere, PERM_IN, PERM_INhere, & ROWIND, ROWINDhere, COLIND, COLINDhere, PIVOTS, PIVOTShere, & RHS, RHShere, REDRHS, REDRHShere, & INFO, RINFO, INFOG, RINFOG, DEFICIENCY, LWK_USER, & SIZE_SCHUR, LISTVAR_SCHUR, LISTVAR_SCHURhere, SCHUR, & SCHURhere, WK_USER, WK_USERhere, COLSCA, COLSCAhere, & ROWSCA, ROWSCAhere, INSTANCE_NUMBER, NRHS, LRHS, LREDRHS, & RHS_SPARSE, RHS_SPARSEhere, SOL_loc, SOL_lochere, & RHS_loc, RHS_lochere, & IRHS_SPARSE, IRHS_SPARSEhere, IRHS_PTR, IRHS_PTRhere, & ISOL_loc, ISOL_lochere, IRHS_loc, IRHS_lochere, NZ_RHS, & LSOL_loc, LRHS_loc, NSOL_loc, Nloc_RHS, & SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD, & MBLOCK, NBLOCK, NPROW, NPCOL, LD_RHSINTR, & OOC_TMPDIR, OOC_PREFIX, WRITE_PROBLEM, #if ! defined(NO_SAVE_RESTORE) & SAVE_DIR, SAVE_PREFIX, #endif & TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN, #if ! defined(NO_SAVE_RESTORE) & SAVE_DIRLEN, SAVE_PREFIXLEN, #endif & METIS_OPTIONS & ) USE CMUMPS_STRUC_DEF IMPLICIT NONE INTEGER OOC_PREFIX_MAX_LENGTH, OOC_TMPDIR_MAX_LENGTH INTEGER PB_MAX_LENGTH PARAMETER(OOC_PREFIX_MAX_LENGTH=255, OOC_TMPDIR_MAX_LENGTH=1023) PARAMETER(PB_MAX_LENGTH=1023) #if ! defined(NO_SAVE_RESTORE) INTEGER, PARAMETER :: SAVE_DIR_MAX_LENGTH = 1023 INTEGER, PARAMETER :: SAVE_PREFIX_MAX_LENGTH = 255 #endif INTEGER JOB, SYM, PAR, COMM_F77, N, NBLK, NZ, NZ_loc, NELT, & DEFICIENCY, LWK_USER, SIZE_SCHUR, INSTANCE_NUMBER, & NRHS, LRHS, & NZ_RHS, LSOL_loc,Nloc_RHS, LRHS_loc, NSOL_loc, LREDRHS INTEGER(8) :: NNZ, NNZ_loc INTEGER ICNTL(60), INFO(80), INFOG(80), KEEP(500) INTEGER SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER MBLOCK, NBLOCK, NPROW, NPCOL INTEGER LD_RHSINTR INTEGER TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN REAL CNTL(15), RINFO(40), RINFOG(40), DKEEP(230) INTEGER(8) KEEP8(150) INTEGER, TARGET :: IRN(*), JCN(*), ELTPTR(*), ELTVAR(*) INTEGER, TARGET :: PERM_IN(*), IRN_loc(*), JCN_loc(*) INTEGER, TARGET :: LISTVAR_SCHUR(*) INTEGER, TARGET :: IRHS_PTR(*), IRHS_SPARSE(*) INTEGER, TARGET :: ISOL_loc(*), IRHS_loc(*) INTEGER, TARGET :: BLKPTR(*), BLKVAR(*) COMPLEX, TARGET :: A(*), A_ELT(*), A_loc(*), RHS(*) INTEGER, TARGET :: ROWIND(*), COLIND(*) COMPLEX, TARGET :: PIVOTS(*) COMPLEX, TARGET :: WK_USER(*) COMPLEX, TARGET :: REDRHS(*) REAL, TARGET :: ROWSCA(*), COLSCA(*) COMPLEX, TARGET :: SCHUR(*) COMPLEX, TARGET :: RHS_SPARSE(*), SOL_loc(*), RHS_loc(*) INTEGER, INTENT(inout) :: OOC_TMPDIR(OOC_TMPDIR_MAX_LENGTH) INTEGER, INTENT(inout) :: OOC_PREFIX(OOC_PREFIX_MAX_LENGTH) INTEGER, INTENT(in) :: WRITE_PROBLEM(PB_MAX_LENGTH) #if ! defined(NO_SAVE_RESTORE) INTEGER SAVE_DIRLEN, SAVE_PREFIXLEN INTEGER, INTENT(in) :: SAVE_DIR(SAVE_DIR_MAX_LENGTH) INTEGER, INTENT(in) :: SAVE_PREFIX(SAVE_PREFIX_MAX_LENGTH) #endif INTEGER METIS_OPTIONS(40) INTEGER IRNhere, JCNhere, Ahere, ELTPTRhere, ELTVARhere, & A_ELThere, BLKPTRhere, BLKVARhere, PERM_INhere, & WK_USERhere, ROWINDhere, COLINDhere, PIVOTShere, & RHShere, REDRHShere, IRN_lochere, & JCN_lochere, A_lochere, LISTVAR_SCHURhere, & SCHURhere, COLSCAhere, ROWSCAhere, RHS_SPARSEhere, & SOL_lochere, RHS_lochere, IRHS_PTRhere, IRHS_SPARSEhere, & ISOL_lochere, IRHS_lochere INCLUDE 'mpif.h' TYPE CMUMPS_STRUC_PTR TYPE (CMUMPS_STRUC), POINTER :: PTR END TYPE CMUMPS_STRUC_PTR TYPE (CMUMPS_STRUC), POINTER :: mumps_par TYPE (CMUMPS_STRUC_PTR), DIMENSION (:), POINTER, SAVE :: & mumps_par_array TYPE (CMUMPS_STRUC_PTR), DIMENSION (:), POINTER :: & mumps_par_array_bis INTEGER, SAVE :: CMUMPS_STRUC_ARRAY_SIZE = 0 INTEGER, SAVE :: N_INSTANCES = 0 INTEGER I, Np, IERR INTEGER(8) :: A_ELT_SIZE, NNZ_i INTEGER CMUMPS_STRUC_ARRAY_SIZE_INIT PARAMETER (CMUMPS_STRUC_ARRAY_SIZE_INIT=10) EXTERNAL MUMPS_ASSIGN_MAPPING, & MUMPS_ASSIGN_PIVNUL_LIST, & MUMPS_ASSIGN_SYM_PERM, & MUMPS_ASSIGN_UNS_PERM, & MUMPS_ASSIGN_GLOB2LOC_RHS, & MUMPS_ASSIGN_GLOB2LOC_SOL EXTERNAL MUMPS_NULLIFY_C_MAPPING, & MUMPS_NULLIFY_C_PIVNUL_LIST, & MUMPS_NULLIFY_C_SYM_PERM, & MUMPS_NULLIFY_C_UNS_PERM, & MUMPS_NULLIFY_C_GLOB2LOC_RHS, & MUMPS_NULLIFY_C_GLOB2LOC_SOL EXTERNAL CMUMPS_ASSIGN_COLSCA, & CMUMPS_ASSIGN_ROWSCA, & CMUMPS_ASSIGN_ROWSCA_LOC, & CMUMPS_ASSIGN_COLSCA_LOC, & CMUMPS_ASSIGN_RHSINTR, & CMUMPS_ASSIGN_SINGULAR_VALUES EXTERNAL CMUMPS_NULLIFY_C_COLSCA, & CMUMPS_NULLIFY_C_ROWSCA, & CMUMPS_NULLIFY_C_ROWSCA_LOC, & CMUMPS_NULLIFY_C_COLSCA_LOC, & CMUMPS_NULLIFY_C_RHSINTR, & CMUMPS_NULLIFY_C_SING_VALUES IF (JOB == -1) THEN DO I = 1, CMUMPS_STRUC_ARRAY_SIZE IF ( .NOT. associated(mumps_par_array(I)%PTR) ) GOTO 10 END DO ALLOCATE( mumps_par_array_bis(CMUMPS_STRUC_ARRAY_SIZE + & CMUMPS_STRUC_ARRAY_SIZE_INIT), stat=IERR) IF (IERR /= 0) THEN WRITE(*,*) ' ** Allocation Error 1 in CMUMPS_F77.' CALL MUMPS_ABORT() END IF DO I = 1, CMUMPS_STRUC_ARRAY_SIZE mumps_par_array_bis(I)%PTR=>mumps_par_array(I)%PTR ENDDO IF (associated(mumps_par_array)) DEALLOCATE(mumps_par_array) mumps_par_array=>mumps_par_array_bis NULLIFY(mumps_par_array_bis) DO I = CMUMPS_STRUC_ARRAY_SIZE+1, CMUMPS_STRUC_ARRAY_SIZE + & CMUMPS_STRUC_ARRAY_SIZE_INIT NULLIFY(mumps_par_array(I)%PTR) ENDDO I = CMUMPS_STRUC_ARRAY_SIZE+1 CMUMPS_STRUC_ARRAY_SIZE = CMUMPS_STRUC_ARRAY_SIZE + & CMUMPS_STRUC_ARRAY_SIZE_INIT 10 CONTINUE INSTANCE_NUMBER = I N_INSTANCES = N_INSTANCES+1 ALLOCATE( mumps_par_array(INSTANCE_NUMBER)%PTR,stat=IERR ) IF (IERR /= 0) THEN WRITE(*,*) '** Allocation Error 2 in CMUMPS_F77.' CALL MUMPS_ABORT() ENDIF ICNTL(1:60) = 0 CNTL(1:15) = 0.0E0 KEEP(1:500) = 0 DKEEP(1:230) = 0.0E0 KEEP8(1:150) = 0_8 METIS_OPTIONS(1:40) = 0 mumps_par_array(INSTANCE_NUMBER)%PTR%INSTANCE_NUMBER = & INSTANCE_NUMBER END IF IF ( INSTANCE_NUMBER .LE. 0 .OR. INSTANCE_NUMBER .GT. & CMUMPS_STRUC_ARRAY_SIZE ) THEN WRITE(*,*) ' ** Instance Error 1 in CMUMPS_F77', & INSTANCE_NUMBER CALL MUMPS_ABORT() END IF IF ( .NOT. associated ( mumps_par_array(INSTANCE_NUMBER)%PTR ) ) & THEN WRITE(*,*) ' Instance Error 2 in CMUMPS_F77', & INSTANCE_NUMBER CALL MUMPS_ABORT() END IF mumps_par => mumps_par_array(INSTANCE_NUMBER)%PTR mumps_par%SYM = SYM mumps_par%PAR = PAR mumps_par%JOB = JOB mumps_par%N = N mumps_par%NBLK = NBLK mumps_par%NZ = NZ mumps_par%NNZ = NNZ mumps_par%NZ_loc = NZ_loc mumps_par%NNZ_loc = NNZ_loc mumps_par%LWK_USER = LWK_USER mumps_par%SIZE_SCHUR = SIZE_SCHUR mumps_par%NELT= NELT mumps_par%ICNTL(1:60)=ICNTL(1:60) mumps_par%CNTL(1:15)=CNTL(1:15) mumps_par%KEEP(1:500)=KEEP(1:500) mumps_par%DKEEP(1:230)=DKEEP(1:230) mumps_par%KEEP8(1:150)=KEEP8(1:150) CALL MUMPS_ADDR_C( ICNTL(50), mumps_par%KEEP8(83) ) CALL MUMPS_ADDR_C( RINFO(3), mumps_par%KEEP8(84) ) mumps_par%METIS_OPTIONS(1:40)=METIS_OPTIONS(1:40) mumps_par%NRHS = NRHS mumps_par%LRHS = LRHS mumps_par%LREDRHS = LREDRHS mumps_par%NZ_RHS = NZ_RHS mumps_par%LSOL_loc = LSOL_loc mumps_par%Nloc_RHS = Nloc_RHS mumps_par%LRHS_loc = LRHS_loc mumps_par%NSOL_loc = NSOL_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 mumps_par%LD_RHSINTR = LD_RHSINTR IF ( COMM_F77 .NE. -987654 ) THEN mumps_par%COMM = COMM_F77 ELSE mumps_par%COMM = MPI_COMM_WORLD ENDIF CALL MPI_BCAST(NRHS,1,MPI_INTEGER,0,mumps_par%COMM,IERR) CALL MUMPS_GET_NNZ_INTERNAL(NNZ,NZ,NNZ_i) IF ( IRNhere /= 0 ) mumps_par%IRN => IRN(1:NNZ_i) IF ( JCNhere /= 0 ) mumps_par%JCN => JCN(1:NNZ_i) IF ( Ahere /= 0 ) mumps_par%A => A(1:NNZ_i) CALL MUMPS_GET_NNZ_INTERNAL(NNZ_loc,NZ_loc,NNZ_i) IF ( IRN_lochere /= 0 ) mumps_par%IRN_loc => IRN_loc(1:NNZ_i) IF ( JCN_lochere /= 0 ) mumps_par%JCN_loc => JCN_loc(1:NNZ_i) IF ( A_lochere /= 0 ) mumps_par%A_loc => A_loc(1:NNZ_i) IF ( ELTPTRhere /= 0 ) mumps_par%ELTPTR => ELTPTR(1:NELT+1) IF ( ELTVARhere /= 0 ) mumps_par%ELTVAR => & ELTVAR(1:ELTPTR(NELT+1)-1) IF ( A_ELThere /= 0 ) THEN A_ELT_SIZE = 0_8 DO I = 1, NELT Np = ELTPTR(I+1) -ELTPTR(I) IF (SYM == 0) THEN A_ELT_SIZE = A_ELT_SIZE + Np * Np ELSE A_ELT_SIZE = A_ELT_SIZE + Np * ( Np + 1 ) / 2 END IF END DO mumps_par%A_ELT => A_ELT(1_8:A_ELT_SIZE) END IF IF ( BLKPTRhere /= 0 ) mumps_par%BLKPTR => BLKPTR(1:NBLK+1) IF ( BLKVARhere /= 0 ) mumps_par%BLKVAR => BLKVAR(1:N) IF ( PERM_INhere /= 0) mumps_par%PERM_IN => PERM_IN(1:N) IF ( LISTVAR_SCHURhere /= 0) & mumps_par%LISTVAR_SCHUR =>LISTVAR_SCHUR(1:SIZE_SCHUR) IF ( SCHURhere /= 0 ) THEN mumps_par%SCHUR_CINTERFACE=>SCHUR(1:1) ENDIF IF (ROWINDhere /= 0) THEN mumps_par%ROWIND => ROWIND(1:KEEP(89)) ENDIF IF (COLINDhere /= 0) THEN mumps_par%COLIND => COLIND(1:KEEP(89)) ENDIF IF (PIVOTShere /= 0) THEN IF (KEEP(50) .EQ.0 .OR.KEEP(50).EQ.1) THEN mumps_par%PIVOTS => PIVOTS(1:KEEP(89)) ELSE mumps_par%PIVOTS => PIVOTS(1_8: & int(KEEP(89),8)+int(KEEP(89),8)) ENDIF ENDIF IF (NRHS .NE. 1) THEN IF ( RHShere /= 0 ) mumps_par%RHS => & RHS(1_8:int(NRHS,8)*int(LRHS,8)) IF (REDRHShere /= 0)mumps_par%REDRHS=> & REDRHS(1_8:int(NRHS,8)*int(LREDRHS,8)) ELSE IF ( RHShere /= 0 ) mumps_par%RHS => RHS(1:N) IF (REDRHShere /= 0)mumps_par%REDRHS=>REDRHS(1:SIZE_SCHUR) ENDIF IF ( WK_USERhere /=0 ) THEN IF (LWK_USER > 0 ) THEN mumps_par%WK_USER => WK_USER(1:LWK_USER) ELSE mumps_par%WK_USER => WK_USER(1_8:-int(LWK_USER,8)*1000000_8) ENDIF ENDIF IF ( COLSCAhere /= 0) mumps_par%COLSCA => COLSCA(1:N) IF ( ROWSCAhere /= 0) mumps_par%ROWSCA => ROWSCA(1:N) IF ( RHS_SPARSEhere /=0 ) mumps_par%RHS_SPARSE=> & RHS_SPARSE(1:NZ_RHS) IF ( IRHS_SPARSEhere /=0 ) mumps_par%IRHS_SPARSE=> & IRHS_SPARSE(1:NZ_RHS) IF ( SOL_lochere /=0 ) mumps_par%SOL_loc=> & SOL_loc(1_8:int(LSOL_loc,8)*int(NRHS,8)) IF ( RHS_lochere /=0 ) mumps_par%RHS_loc=> & RHS_loc(1_8:int(LRHS_loc,8)*int(NRHS,8)) IF ( ISOL_lochere /=0 ) mumps_par%ISOL_loc=> & ISOL_loc(1:LSOL_loc) IF ( IRHS_lochere /=0 ) mumps_par%IRHS_loc=> & IRHS_loc(1:LRHS_loc) IF ( IRHS_PTRhere /=0 ) mumps_par%IRHS_PTR=> & IRHS_PTR(1:NRHS+1) DO I=1,TMPDIRLEN mumps_par%OOC_TMPDIR(I:I)=char(OOC_TMPDIR(I)) ENDDO DO I=TMPDIRLEN+1,OOC_TMPDIR_MAX_LENGTH mumps_par%OOC_TMPDIR(I:I)=' ' ENDDO DO I=1,PREFIXLEN mumps_par%OOC_PREFIX(I:I)=char(OOC_PREFIX(I)) ENDDO DO I=PREFIXLEN+1,OOC_PREFIX_MAX_LENGTH mumps_par%OOC_PREFIX(I:I)=' ' ENDDO DO I=1,WRITE_PROBLEMLEN mumps_par%WRITE_PROBLEM(I:I)=char(WRITE_PROBLEM(I)) ENDDO DO I=WRITE_PROBLEMLEN+1,PB_MAX_LENGTH mumps_par%WRITE_PROBLEM(I:I)=' ' ENDDO #if ! defined(NO_SAVE_RESTORE) DO I=1,SAVE_DIRLEN mumps_par%SAVE_DIR(I:I)=char(SAVE_DIR(I)) ENDDO DO I=SAVE_DIRLEN+1,SAVE_DIR_MAX_LENGTH mumps_par%SAVE_DIR(I:I)=' ' ENDDO DO I=1,SAVE_PREFIXLEN mumps_par%SAVE_PREFIX(I:I)=char(SAVE_PREFIX(I)) ENDDO DO I=SAVE_PREFIXLEN+1,SAVE_PREFIX_MAX_LENGTH mumps_par%SAVE_PREFIX(I:I)=' ' ENDDO #endif CALL CMUMPS( mumps_par ) INFO(1:80)=mumps_par%INFO(1:80) INFOG(1:80)=mumps_par%INFOG(1:80) RINFO(1:40)=mumps_par%RINFO(1:40) RINFOG(1:40)=mumps_par%RINFOG(1:40) ICNTL(1:60) = mumps_par%ICNTL(1:60) CNTL(1:15) = mumps_par%CNTL(1:15) KEEP(1:500) = mumps_par%KEEP(1:500) DKEEP(1:230) = mumps_par%DKEEP(1:230) KEEP8(1:150) = mumps_par%KEEP8(1:150) METIS_OPTIONS(1:40) = mumps_par%METIS_OPTIONS(1:40) SYM = mumps_par%SYM PAR = mumps_par%PAR JOB = mumps_par%JOB N = mumps_par%N NBLK = mumps_par%NBLK NZ = mumps_par%NZ NNZ = mumps_par%NNZ NRHS = mumps_par%NRHS LRHS = mumps_par%LRHS LREDRHS = mumps_par%LREDRHS NZ_loc = mumps_par%NZ_loc NNZ_loc = mumps_par%NNZ_loc NZ_RHS = mumps_par%NZ_RHS LSOL_loc = mumps_par%LSOL_loc Nloc_RHS = mumps_par%Nloc_RHS LRHS_loc = mumps_par%LRHS_loc NSOL_loc = mumps_par%NSOL_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 LD_RHSINTR = mumps_par%LD_RHSINTR IF ( associated (mumps_par%MAPPING) ) THEN CALL MUMPS_ASSIGN_MAPPING(mumps_par%MAPPING(1)) ELSE CALL MUMPS_NULLIFY_C_MAPPING() ENDIF IF ( associated (mumps_par%PIVNUL_LIST) ) THEN CALL MUMPS_ASSIGN_PIVNUL_LIST(mumps_par%PIVNUL_LIST(1)) ELSE CALL MUMPS_NULLIFY_C_PIVNUL_LIST() ENDIF IF ( associated (mumps_par%SINGULAR_VALUES) ) THEN CALL CMUMPS_ASSIGN_SINGULAR_VALUES( & mumps_par%SINGULAR_VALUES(1)) ELSE CALL CMUMPS_NULLIFY_C_SING_VALUES() ENDIF IF ( associated (mumps_par%SYM_PERM) ) THEN CALL MUMPS_ASSIGN_SYM_PERM(mumps_par%SYM_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_SYM_PERM() ENDIF IF ( associated (mumps_par%UNS_PERM) ) THEN CALL MUMPS_ASSIGN_UNS_PERM(mumps_par%UNS_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_UNS_PERM() ENDIF IF ( associated (mumps_par%COLSCA_loc) ) THEN CALL CMUMPS_ASSIGN_COLSCA_LOC(1) ELSE CALL CMUMPS_NULLIFY_C_COLSCA_LOC() ENDIF IF ( associated (mumps_par%ROWSCA_loc) ) THEN CALL CMUMPS_ASSIGN_ROWSCA_LOC(1) ELSE CALL CMUMPS_NULLIFY_C_ROWSCA_LOC() ENDIF IF (associated( mumps_par%COLSCA )) THEN CALL CMUMPS_ASSIGN_COLSCA(mumps_par%COLSCA(1)) ELSE CALL CMUMPS_NULLIFY_C_COLSCA() ENDIF IF (associated( mumps_par%ROWSCA )) THEN CALL CMUMPS_ASSIGN_ROWSCA(mumps_par%ROWSCA(1)) ELSE CALL CMUMPS_NULLIFY_C_ROWSCA() ENDIF IF (associated( mumps_par%RHSINTR )) THEN CALL CMUMPS_ASSIGN_RHSINTR(mumps_par%RHSINTR(1)) ELSE CALL CMUMPS_NULLIFY_C_RHSINTR() ENDIF IF (associated(mumps_par%GLOB2LOC_RHS)) THEN CALL MUMPS_ASSIGN_GLOB2LOC_RHS(mumps_par%GLOB2LOC_RHS(1)) ELSE CALL MUMPS_NULLIFY_C_GLOB2LOC_RHS() ENDIF IF (associated(mumps_par%GLOB2LOC_SOL)) THEN CALL MUMPS_ASSIGN_GLOB2LOC_SOL(mumps_par%GLOB2LOC_SOL(1)) ELSE CALL MUMPS_NULLIFY_C_GLOB2LOC_SOL() ENDIF TMPDIRLEN=len_trim(mumps_par%OOC_TMPDIR) DO I=1,TMPDIRLEN OOC_TMPDIR(I)=ichar(mumps_par%OOC_TMPDIR(I:I)) ENDDO PREFIXLEN=len_trim(mumps_par%OOC_PREFIX) DO I=1,PREFIXLEN OOC_PREFIX(I)=ichar(mumps_par%OOC_PREFIX(I:I)) ENDDO IF ( JOB == -2 ) THEN IF (associated(mumps_par_array(INSTANCE_NUMBER)%PTR))THEN DEALLOCATE(mumps_par_array(INSTANCE_NUMBER)%PTR) NULLIFY (mumps_par_array(INSTANCE_NUMBER)%PTR) N_INSTANCES = N_INSTANCES - 1 IF ( N_INSTANCES == 0 ) THEN DEALLOCATE(mumps_par_array) CMUMPS_STRUC_ARRAY_SIZE = 0 END IF ELSE WRITE(*,*) "** Warning: instance already freed" WRITE(*,*) " this should normally not happen." ENDIF END IF RETURN END SUBROUTINE CMUMPS_F77 MUMPS_5.8.1/src/sfac_front_LDLT_type2.F0000664000175000017500000010645315042446437017444 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC2_LDLT_M CONTAINS SUBROUTINE SMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NNEGW, NNULLNEGW, NPVW, NB22T2W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP, PIVNUL_LIST_STRUCT & , LRGROUPS & ) USE SMUMPS_FAC_FRONT_AUX_M USE SMUMPS_FAC_FRONT_TYPE2_AUX_M USE SMUMPS_OOC USE SMUMPS_FAC_LR USE SMUMPS_LR_TYPE USE MUMPS_LR_STATS USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_DATA_M !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_TEST USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW INTEGER, intent(inout) :: NNEGW, NPVW, NNULLNEGW, NB22T2W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW INTEGER(8) :: LA INTEGER, TARGET :: IW( LIW ) REAL A( LA ) REAL UU, SEUIL TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) INTEGER NBFIN, SLAVEF, & IFLAG, IERROR, LEAF, LPOOL INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER NB_BLOC_FAC INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N), & PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL AVOID_DELAYED TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)) INTEGER(8) :: POSELT INTEGER IOLDPS, allocok, K263,J INTEGER INOPV, IFINB, NFRONT, NPIV, IEND_BLOCK INTEGER NASS, LDAFS, IBEG_BLOCK INTEGER :: NB_POSTPONED INTEGER :: IBEG_BLOCK_FOR_IPIV LOGICAL LASTPANEL, LR_ACTIVATED, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR, CURRENT_BLR INTEGER Inextpiv LOGICAL RESET_TO_ONE INTEGER K109_SAVE INTEGER XSIZE, NBKJIB_ORIG REAL UUTEMP INCLUDE 'mumps_headers.h' INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV REAL , ALLOCATABLE, DIMENSION ( : ) :: DIAG_ORIG INTEGER :: SIZEDIAG_ORIG INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY, NELIM TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PP_FIRST2SWAP_L, IFLAG_OOC INTEGER PP_LastPIVRPTRFilled INTEGER INFO_TMP(2) INTEGER :: MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_SEND REAL, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP, BEGS_BLR_STATIC INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, I, IP, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG, APOSMAX REAL, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL,ALLOCATABLE :: RWORK(:) REAL, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM LOGICAL :: SWAP_OCCURRED INTEGER :: MY_NUM INTEGER PIVOT_OPTION INTEGER LAST_ROW EXTERNAL SMUMPS_BDC_ERROR LOGICAL STATICMODE REAL SEUIL_LOC REAL GW_FACTCUMUL INTEGER PIVSIZ,IWPOSPIV REAL ONE PARAMETER (ONE = 1.0E0) NULLIFY(PTDummy) NULLIFY(ACC_LUA) NULLIFY(BEGS_BLR) NULLIFY(BLR_L) NULLIFY(BLR_SEND) NULLIFY(DIAG) NULLIFY(BLR_PANEL) NULLIFY(BEGS_BLR_TMP) NULLIFY(BEGS_BLR_STATIC) IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF SWAP_OCCURRED = .FALSE. INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC=SEUIL UUTEMP=UU ENDIF RESET_TO_ONE = ((KEEP(110).GT.0).AND.(DKEEP(2).LE.0.0E0)) IF (RESET_TO_ONE) THEN K109_SAVE = KEEP(109) ENDIF IBEG_BLOCK = 1 NB_BLOC_FAC = 0 XSIZE = KEEP(IXSZ) IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) NFRONT = IW(IOLDPS+XSIZE) NASS = abs(IW(IOLDPS+2+XSIZE)) LDAFS = NASS IF ((KEEP(219).EQ.1).AND.(KEEP(207).EQ.1).AND.(KEEP(50).EQ.2) & ) THEN APOSMAX = POSELT + int(LDAFS,8)*int(LDAFS,8) NB_POSTPONED = max(NFRONT - ND(STEP(INODE)),0) CALL SMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, A(APOSMAX), NASS, NB_POSTPONED) ENDIF IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL SMUMPS_SET_INNERBLOCKSIZE( NBKJIB_ORIG, NASS, KEEP) IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF (LR_ACTIVATED) THEN K263 = 1 ELSE K263 = KEEP(263) IF (K263 .NE. 0 .AND. NASS/NBLR_ORIG < 4) THEN IF ( NBLR_ORIG .GT. NBKJIB_ORIG * 4 ) THEN NBLR_ORIG = max(NBKJIB_ORIG, (NASS+3)/4) ELSE K263 = 0 ENDIF ENDIF ENDIF PIVOT_OPTION = MIN(2,KEEP(468)) IF ((UUTEMP == 0.0E0) .AND. OOC_EFFECTIVE_ON_FRONT) THEN IF (K263.EQ.1.AND.(.NOT.LR_ACTIVATED)) THEN PIVOT_OPTION = 0 ENDIF ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID, ' : SMUMPS_FAC2_LDLT failed to allocate ', & NASS, ' integers' IFLAG = -13 IERROR=NASS GO TO 500 END IF IF (KEEP(219).GE.3) THEN SIZEDIAG_ORIG = NASS ELSE SIZEDIAG_ORIG = 1 ENDIF ALLOCATE ( DIAG_ORIG(SIZEDIAG_ORIG), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID, & ' : FAC_NIV2 failed to allocate ', & NASS, ' REAL/COMPLEX entries' IFLAG=-13 IERROR=NASS GO TO 500 END IF CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF (OOC_EFFECTIVE_ON_FRONT) THEN IDUMMY = -9876 TYPEFile = TYPEF_L NextPiv2beWritten = 1 PP_FIRST2SWAP_L = NextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 2 MonBloc%NROW = NASS MonBloc%NCOL = NASS MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -66666 MonBloc%INDICES => & IW(IOLDPS+6+NFRONT+XSIZE+IW(IOLDPS+5+XSIZE) & :IOLDPS+5+2*NFRONT+XSIZE+IW(IOLDPS+5+XSIZE)) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(475).EQ.3) THEN IF (UUTEMP == 0.0E0) THEN PIVOT_OPTION = 0 ELSE PIVOT_OPTION = 1 ENDIF ENDIF CNT_NODES = CNT_NODES + 1 ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.2) .AND. & OOC_EFFECTIVE_ON_FRONT ) IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & 0, KEEP(488), .FALSE., KEEP(472), & NFRONT, KEEP(1)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 480 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL SMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 CALL SMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .TRUE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF LASTPANEL = .FALSE. DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = BEGS_BLR(CURRENT_BLR+1)-1 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 480 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (K263.EQ.0) THEN IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK ELSE IBEG_BLOCK_FOR_IPIV = IBEG_BLR ENDIF CALL SMUMPS_FAC_I_LDLT_NIV2( & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, & NFRONT,NASS,IBEG_BLOCK_FOR_IPIV, & IBEG_BLOCK, IEND_BLOCK, & NASS, IPIV, & N,INODE,IW,LIW,A,LA, & NNEGW,NNULLNEGW, NB22T2W,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INOPV, & IFLAG,IERROR,IOLDPS,POSELT,UU, SEUIL_LOC, & KEEP,KEEP8,PIVSIZ, & DKEEP(1), PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, & PIVOT_OPTION, & Inextpiv, IEND_BLR, LR_ACTIVATED, & OOC_EFFECTIVE_ON_FRONT) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ. 1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTPANEL = .TRUE. ELSE IF (INOPV .LE. 0) THEN INOPV = 0 NPVW = NPVW + PIVSIZ CALL SMUMPS_FAC_MQ_LDLT_NIV2(IEND_BLOCK, & NASS, IW(IOLDPS+1+XSIZE), INODE,A,LA, & LDAFS, POSELT,IFINB, & PIVSIZ, & KEEP(219), & PIVOT_OPTION, IEND_BLR, LR_ACTIVATED) IF(PIVSIZ .EQ. 2) THEN IWPOSPIV = IOLDPS+XSIZE+IW(IOLDPS+1+XSIZE)+6+ & IW(IOLDPS+5+XSIZE) IW(IWPOSPIV+NFRONT) = -IW(IWPOSPIV+NFRONT) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB .EQ. -1) THEN LASTPANEL = .TRUE. ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN IF (.NOT.RESET_TO_ONE.OR.K109_SAVE.EQ.KEEP(109)) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF ENDIF IF (K263.eq.0) THEN NELIM = IEND_BLR - NPIV CALL SMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEG_BLOCK, NPIV, IPIV, NASS,LASTPANEL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, .FALSE. & , NPARTSASS, CURRENT_BLR, BLR_DUMMY, LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN CALL SMUMPS_RESET_TO_ONE( & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), & NPIV, IBEG_BLOCK, & K109_SAVE, KEEP(109), PIVNUL_LIST_STRUCT, & A, POSELT, LA, LDAFS) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF ENDIF IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL SMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & -6666, -6666, & IEND_BLR, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ENDIF CALL MUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 500 ENDIF NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) THEN WRITE(*,*) "Internal error 1 in SMUMPS_FAC2_LDLT", & IEND_BLR, IEND_BLOCK CALL MUMPS_ABORT() ENDIF IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) NULLIFY(BLR_L) ENDIF GOTO 101 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), KEEP(458), & KEEP(473), BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8 & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (PIVOT_OPTION.LT.2) THEN CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NB_BLR, 2, 1, 0, .FALSE., & IW, OFFSET_IW=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1, & NASS=NASS) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 480 IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ENDIF ENDIF 101 CONTINUE IF (.NOT. LR_ACTIVATED) THEN CALL SMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS, NASS, INODE, A, LA, & LDAFS, POSELT, & KEEP, KEEP8, & IEND_BLR, NASS, & -6666, -6666, & (PIVOT_OPTION.LE.1), .FALSE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ENDIF IF (K263.NE.0) THEN NELIM = IEND_BLR-NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_L)) THEN BLR_SEND=>BLR_L ENDIF CALL SMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEG_BLR, NPIV, IPIV, NASS,LASTPANEL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S,PTRFAC,STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR , BLR_SEND , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN CALL SMUMPS_RESET_TO_ONE( & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), & NPIV, IBEG_BLR, & K109_SAVE, KEEP(109), PIVNUL_LIST_STRUCT, & A, POSELT, LA, LDAFS) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF ENDIF IF (.NOT. LR_ACTIVATED) THEN IF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL SMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & -6666, -6666, & NASS, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ELSE NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) THEN CALL MUMPS_ABORT() ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN CALL SMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NASS, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 2, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8) ENDIF ENDIF IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 450 IF (KEEP(480).LT.2) THEN CALL SMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, & IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, & MAXI_CLUSTER, NPIV, & 2, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (PIVOT_OPTION.LT.2) THEN IF ((UU.GT.0).OR.(KEEP(486).NE.2)) THEN CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, NASS, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, & 'V', 1) ENDIF ENDIF 450 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 480 IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF ENDIF GOTO 100 ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL(BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & KEEP(34)) DEALLOCATE(BLR_L) ENDIF NULLIFY(BLR_L) ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO J=1,NB_BLR+1 BEGS_BLR_TMP(J) = BEGS_BLR_STATIC(J) ENDDO ENDIF ENDIF IF ( & (KEEP(486).EQ.2) & ) THEN MEM_TOT = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP& PRIVATE(IP, NELIM) #endif #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*DIAGSIZ_STA MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(LDAFS,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN POSELT_DIAG = POSELT_DIAG + int(LDAFS,8) ENDDO CALL SMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG, KEEP(34)) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO !$OMP SINGLE #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM_TOT,8), & .FALSE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 460 IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN DO IP=1,NPARTSASS NELIM = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8, & KEEP(34)) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, LDAFS, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(458), KEEP(473), & BLR_PANEL, IP, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 440 #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif 440 CONTINUE ENDIF 460 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 ENDIF IF ( & (KEEP(486).EQ.2) & ) THEN CALL SMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF CALL SMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 480 CONTINUE 500 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF(allocated(IPIV)) DEALLOCATE( IPIV ) IF (allocated(DIAG_ORIG)) DEALLOCATE(DIAG_ORIG) IF (LR_ACTIVATED) THEN IF (IFLAG.GE.0) THEN CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 1, NELIM) DO IP=1,NPARTSASS CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NPARTSASS-IP & ) ENDDO CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NASS-NELIM, 2, 2) ENDIF IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, KEEP(50), 2) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL SMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8, KEEP(34)) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL SMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34)) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_FAC2_LDLT SUBROUTINE SMUMPS_RESET_TO_ONE(FRONT_INDEX_LIST, NPIV, & IBEG_BLOCK, K109_SAVE, K109, PIVNUL_LIST_STRUCT, & A, POSELT, LA, LDAFS) USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T INTEGER, INTENT(IN) :: NPIV, IBEG_BLOCK INTEGER, INTENT(IN) :: FRONT_INDEX_LIST(NPIV) INTEGER, INTENT(IN) :: K109 INTEGER, INTENT(INOUT) :: K109_SAVE TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT INTEGER(8), INTENT(IN) :: POSELT, LA INTEGER, INTENT(IN) :: LDAFS REAL, INTENT(INOUT) :: A(LA) LOGICAL :: TO_UPDATE INTEGER :: I, JJ, K REAL ONE PARAMETER (ONE = 1.0E0) DO K = K109_SAVE+1, K109 TO_UPDATE = .FALSE. I = PIVNUL_LIST_STRUCT%PIVNUL_LIST(K) DO JJ=IBEG_BLOCK, NPIV IF (FRONT_INDEX_LIST(JJ) .EQ.I) THEN TO_UPDATE=.TRUE. EXIT ENDIF ENDDO IF (TO_UPDATE) THEN A(POSELT+int(JJ,8)+int(LDAFS,8)*int(JJ-1,8))= ONE TO_UPDATE=.FALSE. ELSE write(*,*) ' Internal error related ', & 'to null pivot row detection' CALL MUMPS_ABORT() ENDIF ENDDO K109_SAVE = K109 RETURN END SUBROUTINE SMUMPS_RESET_TO_ONE END MODULE SMUMPS_FAC2_LDLT_M MUMPS_5.8.1/src/ssol_driver.F0000664000175000017500000100655615042446441015710 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SOLVE_DRIVER(id,idintr) USE SMUMPS_STRUC_DEF USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_INTR_STRUC USE SMUMPS_SOL_ES C Lock Initialization (_LI) and Desruction (_LD) USE MUMPS_SOL_L0OMP_M, ONLY: MUMPS_SOL_L0OMP_LI, & MUMPS_SOL_L0OMP_LD C C Purpose C ======= C C Performs solution phase (solve), Iterative Refinements C and Error analysis. C C c C USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_ALLOC_SMALL_BUF, & MUMPS_BUF_ALLOC_CB, MUMPS_BUF_INIT, & MUMPS_BUF_DEALL_CB, & MUMPS_BUF_DEALL_SMALL_BUF USE SMUMPS_OOC USE MUMPS_MEMORY_MOD USE SMUMPS_LR_DATA_M, only : SMUMPS_BLR_STRUC_TO_MOD & , SMUMPS_BLR_MOD_TO_STRUC USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_MOD_TO_STRUC #if ! defined(NO_SAVE_RESTORE) USE SMUMPS_SAVE_RESTORE #endif !$ USE OMP_LIB IMPLICIT NONE C ------------------- C Explicit interfaces C ------------------- INTERFACE SUBROUTINE SMUMPS_SIZE_IN_STRUCT( id, idintr, & NB_INT,NB_CMPLX,NB_CHAR ) USE SMUMPS_STRUC_DEF, ONLY: SMUMPS_STRUC USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_INTR_STRUC TYPE (SMUMPS_STRUC) :: id TYPE (SMUMPS_INTR_STRUC) :: idintr INTEGER(8) :: NB_INT,NB_CMPLX,NB_CHAR END SUBROUTINE SMUMPS_SIZE_IN_STRUCT SUBROUTINE SMUMPS_CHECK_DENSE_RHS &(idRHS, idINFO, idN, idNRHS, idLRHS) REAL, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE SMUMPS_CHECK_DENSE_RHS END INTERFACE C INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' #if defined(V_T) INCLUDE 'VT.inc' #endif INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 C C Parameters C ========== C TYPE (SMUMPS_STRUC), TARGET :: id TYPE (SMUMPS_INTR_STRUC) :: idintr C C Local variables C =============== C INTEGER MP,LP, MPG LOGICAL PROK, PROKG, LPOK INTEGER MTYPE, ICNTL21 LOGICAL LSCAL, POSTPros, GIVSOL INTEGER ICNTL10, ICNTL11, ICNTL48_EFF INTEGER I,K,JPERM, J, II, IZ2 #if defined(USE_OLD_SCALING) INTEGER IPERM #endif INTEGER IZ, NZ_THIS_BLOCK, PJ C pointers in IS INTEGER LIW C pointers in id%S INTEGER(8) :: LA, LA_PASSED INTEGER LIW_PASSED INTEGER(8) :: LWCB8_MIN, LWCB8 C buffer sizes INTEGER SMUMPS_LBUF, SMUMPS_LBUF_INT INTEGER(8) :: SMUMPS_LBUF_8 INTEGER :: LBUFR, LBUFR_BYTES INTEGER :: MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL INTEGER(8) :: MSG_MAX_BYTES_SOLVE8 C reception buffer INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFR C null space INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, & IBEG_GLOB_DEF, IEND_GLOB_DEF, & IROOT_DEF_RHS_COL1 C INTEGER NITREF, NOITER, SOLVET, KASE C Meaningful only with tree pruning and sparse RHS LOGICAL INTERLEAVE_PAR, DO_PERMUTE_RHS LOGICAL CALL_NODES_FWD_BWD, FIRST_CALL_NODES_FWD_BWD C true if SMUMPS_SOL_C called during postprocessing LOGICAL FROM_PP LOGICAL ALLOCATE_S C C TIMINGS DOUBLE PRECISION TIMEIT, TIMEEA, TIMEEA1, TIMELCOND DOUBLE PRECISION TIME3 DOUBLE PRECISION TIMEC1,TIMEC2 DOUBLE PRECISION TIMEGATHER1,TIMEGATHER2 DOUBLE PRECISION TIMESCATTER1,TIMESCATTER2 DOUBLE PRECISION TIMECOPYSCALE1,TIMECOPYSCALE2 C ------------------------------------------ C Declarations related to exploit sparsity C ------------------------------------------ INTEGER :: NRHS_NONEMPTY INTEGER :: STRAT_PERMAM1 LOGICAL :: DO_NULL_PIV INTEGER, DIMENSION(:), POINTER :: IRHS_PTR_COPY INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE_COPY REAL, DIMENSION(:), POINTER :: RHS_SPARSE_COPY LOGICAL IRHS_SPARSE_COPY_ALLOCATED, IRHS_PTR_COPY_ALLOCATED, & RHS_SPARSE_COPY_ALLOCATED C INTEGER, DIMENSION(:), ALLOCATABLE :: MAP_RHS_loc INTEGER, DIMENSION(:), POINTER :: IRHS_loc_PTR LOGICAL :: IRHS_loc_PTR_ALLOCATED INTEGER(8) :: SUM_idNloc_RHS_8 REAL, DIMENSION(:), POINTER :: idRHS_loc INTEGER(8) :: DIFF_SOL_loc_RHS_loc INTEGER(8) :: RHS_loc_size, RHS_loc_shift INTEGER(8) :: NBT INTEGER :: NBCOL, COLSIZE, JBEG_RHS, JEND_RHS, JBEG_NEW, & NBCOL_INBLOC, IPOS, IPOSRHSINTR C Nb of pruned NE_STEPS, useful for FWD step; and list of root nodes LOGICAL :: fill INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_Sons_FWD, & Pruned_Sons_BWD INTEGER, DIMENSION(:), ALLOCATABLE :: PERM_RHS INTEGER, DIMENSION(:), POINTER :: PTR_POSINRHSINTR_FWD, & PTR_POSINRHSINTR_BWD REAL, DIMENSION(:), POINTER :: PTR_RHS INTEGER, DIMENSION(:), POINTER :: idIPTR_WORKING, idWORKING INTEGER :: SIZE_IPTR_WORKING, SIZE_WORKING C NRHS_NONEMPTY: holds C either the original number of RHS (id%NRHS defined on host) C or, when the RHS is sparse, it holds the C number of non empty columns. C it is computed on master and is C then broadcasted on all processes. C IRHS_PTR_COPY holds a compressed local copy of IRHS_PTR (or points C on the master to id%IRHS_PTR if no permutation requested) C IRHS_SPARSE_COPY might be allocated or might also point to C id%IRHS_SPARSE. To test if we can deallocate it we trace C with IRHS_SPARSE_COPY_ALLOCATED when it was effectively C allocated. C NBCOL_INBLOC total nb columns to process in this block C JBEG_RHS global ptr for starting column requested for this block C JEND_RHS global ptr for end column_number requested for this block C PERM_RHS -- Permutation of RHS computed on master and broadcasted C on all procs (of size id%NRHS orginal) C PERM_RHS(k) = i means that i is the kth column to be processed C Note that PERM_RHS will be used also in case of interleaving C ------------------------------------ INTEGER :: NOMP REAL ONE REAL ZERO PARAMETER( ONE = 1.0E0 ) PARAMETER( ZERO = 0.0E0 ) REAL RZERO, RONE PARAMETER( RZERO = 0.0E0, RONE = 1.0E0 ) C C RHS_IR is internal to SMUMPS and used for iterative refinement C or the error analysis section. It either points to the user's C RHS (on the host when the solution is centralized or the RHS C is dense), or is a workarray allocated inside this routine C of size N. REAL, DIMENSION(:), POINTER :: RHS_IR REAL, DIMENSION(:), POINTER :: WORK_WCB REAL, DIMENSION(:), POINTER :: PTR_RHS_ROOT INTEGER(8) :: LPTR_RHS_ROOT C C Local workarrays that will be dynamically allocated C REAL, ALLOCATABLE :: SAVERHS(:), C_RW1(:), & C_RW2(:), & SRW3(:), C_Y(:), & C_W(:) INTEGER :: LCWORK REAL, ALLOCATABLE :: CWORK(:) INTEGER, ALLOCATABLE :: MAP_RHS(:) REAL, ALLOCATABLE :: R_Y(:), D(:) REAL, ALLOCATABLE :: R_W(:) C The 2 following workarrays are temporary local C arrays only used for distributed matrix input C (KEEP(54) .NE. 0). REAL, ALLOCATABLE, DIMENSION(:) :: R_LOCWK54 REAL, ALLOCATABLE, DIMENSION(:) :: C_LOCWK54 INTEGER :: NBENT_RHSINTR, NB_FS_RHSINTR_F, & NB_FS_RHSINTR_TOT INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV LOGICAL :: UNS_PERM_INV_NEEDED_INMAINLOOP, & UNS_PERM_INV_NEEDED_BEFMAINLOOP, & UNS_PERM_INV_NEEDED_ONSLAVES INTEGER LIWK_SOLVE, LIWCB INTEGER, ALLOCATABLE :: IW1(:), IWK_SOLVE(:), IWCB(:) INTEGER :: LIWK_PTRACB INTEGER(8), ALLOCATABLE :: PTRACB(:) C C Parameters arising from the structure C INTEGER(8) :: MAXS REAL, DIMENSION(:), POINTER :: CNTL INTEGER, DIMENSION (:), POINTER :: KEEP,ICNTL,INFO INTEGER(8), DIMENSION (:), POINTER :: KEEP8 INTEGER, DIMENSION (:), POINTER :: IS REAL, DIMENSION(:),POINTER:: RINFOG C =============================================================== C SCALING issues: C When scaling was performed C RHS holds the solution of the scaled system C The unscaled second member (b0) was given C then we have to scale both rhs and solution: C A(sca) = LU = D1*A*D2 , with D2 = COLSCA C D1 = ROWSCA C -------------- C CASE OF A X =B C -------------- C (ICNTL(9)=1 or MTYPE=1) C A*x0 = b0 C b(sca) = D1 * b0 = ROWSCA*b0 C A(sca) [(D2) **(-1)] x0 = b(sca) C so the computed solution of LU * x(sca) = b(sca) C is : x(sca) =[(D2) **(-1)] x0 and so x0= D2*x(sca) C -------------- C CASE OF AT X =B C -------------- C (ICNTL(9).NE.1 or MTYPE=0) C A(sca) = LU = D1*A*D2 C AT*x0 = b0 => D2*AT*D1 * D1-1 x0 = D2 * b0 C b(sca) = D2 * b0 = COLSCA*b0 C A(sca)T [(D1) **(-1)] x0 = b(sca) C so the computed solution of (LU)^T * x(sca) = b(sca) C is : x(sca) =[(D1) **(-1)] x0 and so x0= D1*y0 is modified C C In case of distributed RHS or distributed solution we need C scaling information on each processor and this information has C been stored in ROWSCA_loc(1:INFO(23)) and COLSCA_loc(1:INFO(23)) C such that: C C ---------------- C CASE OF A X = B C ---------------- C C - the scaling factor of row i of A is stored on the C processor for which GLOB2LOC_RHS(i) > 0 at position C ROWSCA_loc(GLOB2LOC_RHS(i)) C C - the scaling factor of column j of A is stored on the C processor for which GLOB2LOC_SOL(j) > 0 at position C COLSCA_loc(GLOB2LOC_SOL(j)) C C ------------------ C CASE OF A^T X = B C ------------------ C C - the scaling factor of row i of A^T is stored on the C processor for which GLOB2LOC_RHS(i) > 0 at position C COLSCA_loc(GLOB2LOC_RHS(i)) C C - the scaling factor of column j of A^T is stored on the C processor for which GLOB2LOC_SOL(j) > 0 at position C ROWSCA_loc(GLOB2LOC_SOL(j)) C #if defined(USE_OLD_SCALING) type scaling_data_t SEQUENCE REAL , dimension(:), pointer :: SCALING REAL , dimension(:), pointer :: SCALING_LOC INTEGER, dimension(:), pointer :: SCALING_IND end type scaling_data_t type (scaling_data_t) :: scaling_data_dr type (scaling_data_t) :: scaling_data_sol C To scale on the fly during GATHER SOLUTION: REAL, DIMENSION(:), POINTER :: PT_SCALING REAL, TARGET :: Dummy_SCAL(1) #else INTEGER :: ROWORCOL #endif C C ==================== END OF SCALING related data ================ C C Local variables C C Interval associated to the subblocks of RHS a node has to process INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: RHS_BOUNDS INTEGER :: LPTR_RHS_BOUNDS INTEGER, DIMENSION(:), POINTER :: PTR_RHS_BOUNDS LOGICAL :: DO_NBSPARSE, NBSPARSE_LOC LOGICAL :: PRINT_MAXAVG REAL ARRET REAL C_DUMMY(1) REAL R_DUMMY(1) INTEGER IDUMMY(1), JDUMMY(1), KDUMMY(1), LDUMMY(1), MDUMMY(1) INTEGER, TARGET :: IDUMMY_TARGET(1) REAL, TARGET :: CDUMMY_TARGET(1) INTEGER JJ INTEGER allocok INTEGER NBRHS, NBRHS_EFF, BEG_RHS, NB_RHSSKIPPED, & LD_RHS, & MASTER_ROOT, MASTER_ROOT_IN_COMM C NRHS_COLS_SOL_C is used to estimate NRHS_EFF C before the loop on RHS column blocks INTEGER NRHS_COLS_SOL_C INTEGER SIZE_ROOT, LD_REDRHS INTEGER(8) :: IBEG, IBEG_RHSINTR, KDEC, IBEG_loc, IBEG_REDRHS INTEGER NCOL_RHS_loc INTEGER LD_RHS_loc, JBEG_RHS_loc INTEGER NB_K133, IRANK, TSIZE INTEGER KMAX_246_247 INTEGER IFLAG_IR, IRStep LOGICAL TESTConv LOGICAL WORKSPACE_MINIMAL_PREFERRED, WK_USER_PROVIDED INTEGER(8) NB_BYTES !size of data allocated during solve INTEGER(8) NB_BYTES_MAX !MAX size of data allocated during solve INTEGER(8) NB_BYTES_EXTRA !For Step2Node, which may be freed later INTEGER(8) NB_BYTES_LOC !For temp. computations INTEGER(8) NB_INT, NB_CMPLX, NB_CHAR, K34_8, K35_8, K149_8, K151_8 INTEGER(8) K16_8, ITMP8, SUM_ITMP8, NB_BYTES_ON_ENTRY #if defined(V_T) C Vampir INTEGER soln_drive_class, glob_comm_ini, perm_scal_ini, soln_dist, & soln_assem, perm_scal_post #endif LOGICAL I_AM_SLAVE, BUILD_POSINRHSINTR LOGICAL :: BUILD_RHSMAPINFO REAL, TARGET :: RDUMMY_TARGET(1) LOGICAL :: ES_RHSINTR INTEGER, DIMENSION(:), POINTER :: nodes_FWD, nodes_BWD C to manage sparsity: compute target nodes for starting chains C Lnodes_FWD/Lnodes_BWD = -1 => all nodes to be processed INTEGER, DIMENSION(:), POINTER :: nodes_FWD_PTR, nodes_BWD_PTR INTEGER :: Lnodes_FWD, Lnodes_BWD, Lnodes_FWD_PTR, Lnodes_BWD_PTR REAL, POINTER, DIMENSION(:) :: SCALING_loc_FWD REAL, POINTER, DIMENSION(:) :: SCALING_loc_BWD REAL, POINTER, DIMENSION(:) :: SCALING_RHSINTR_BWD REAL, POINTER, DIMENSION(:) :: SCALING_RHSINTR_FWD INTEGER :: LSCALING_RHSINTR_BWD, LSCALING_RHSINTR_FWD LOGICAL :: SCALING_RHSINTR_BWD_ALLOCATED, & SCALING_RHSINTR_FWD_ALLOCATED, & BUILD_SCALING_RHSINTR C NSOL_loc will be equal to KEEP(89) in case ICNTL(21)=1 INTEGER :: NSOL_loc LOGICAL WORK_WCB_ALLOCATED, IS_INIT_OOC_DONE LOGICAL PTR_RHS_ROOT_ALLOCATED LOGICAL :: IS_LR_MOD_TO_STRUC_DONE INTEGER :: KEEP350_SAVE, KEEP20_SAVE LOGICAL STOP_AT_NEXT_EMPTY_COL INTEGER MTYPE_LOC INTEGER(4) :: I4 INTEGER MAT_ALLOC_LOC, MAT_ALLOC INTEGER :: NZ_THIS_BLOCK_ARG, NBCOL_INBLOC_ARG, LStep2node_ARG INTEGER, POINTER :: Step2node_ARG(:), IRHS_PTR_COPY_ARG(:), & IRHS_SPARSE_COPY_ARG(:) INTEGER :: NB_FS_RHSINTR_F_ARG, NB_FS_RHSINTR_TOT_ARG INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE C C First executable statement C #if defined(V_T) CALL VTCLASSDEF( 'Soln driver',soln_drive_class,IERR) CALL VTFUNCDEF( 'glob_comm_ini',soln_drive_class, & glob_comm_ini,IERR) CALL VTFUNCDEF( 'perm_scal_ini',soln_drive_class, & perm_scal_ini,IERR) CALL VTFUNCDEF( 'soln_dist',soln_drive_class,soln_dist,IERR) CALL VTFUNCDEF( 'soln_assem',soln_drive_class,soln_assem,IERR) CALL VTFUNCDEF( 'perm_scal_post',soln_drive_class, & perm_scal_post,IERR) #endif C Depending on the type of parallelism, C the master can have the role of a slave I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) C -- The following pointers xxCOPY might be allocated but then C -- the associated xxCOPY_ALLOCATED will be set to C -- enable deallocation SCALING_RHSINTR_FWD_ALLOCATED = .FALSE. SCALING_RHSINTR_BWD_ALLOCATED = .FALSE. C Initialize scalings to possilby pass them as arguments C (e.g. to SMUMPS_DS_ALL2ALL) even on non working host C and/or when LSCAL is false SCALING_RHSINTR_FWD => RDUMMY_TARGET SCALING_RHSINTR_BWD => RDUMMY_TARGET LSCALING_RHSINTR_FWD = 1 LSCALING_RHSINTR_BWD = 1 SCALING_LOC_FWD => RDUMMY_TARGET SCALING_LOC_BWD => RDUMMY_TARGET 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. C ALLOCATE_S will be set to true if S needs be allocated. C It is then tested to free S befgore returning ALLOCATE_S = .FALSE. NULLIFY(RHS_IR) NULLIFY(WORK_WCB) #if defined(USE_OLD_SCALING) NULLIFY(scaling_data_dr%SCALING) NULLIFY(scaling_data_dr%SCALING_LOC) NULLIFY(scaling_data_dr%SCALING_IND) NULLIFY(scaling_data_sol%SCALING) NULLIFY(scaling_data_sol%SCALING_LOC) NULLIFY(scaling_data_sol%SCALING_IND) #endif NULLIFY(nodes_FWD) NULLIFY(nodes_BWD) IRHS_loc_PTR_allocated = .FALSE. IS_INIT_OOC_DONE = .FALSE. IS_LR_MOD_TO_STRUC_DONE = .FALSE. WK_USER_PROVIDED = .FALSE. WORK_WCB_ALLOCATED = .FALSE. PTR_RHS_ROOT_ALLOCATED = .FALSE. CNTL =>id%CNTL KEEP =>id%KEEP KEEP8=>id%KEEP8 IS =>id%IS ICNTL=>id%ICNTL INFO =>id%INFO RINFOG =>id%RINFOG LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) IF (.not.PROK) MP =0 IF (.not.PROKG) MPG=0 IF ( PROK ) WRITE(MP,100) IF ( PROKG ) WRITE(MPG,100) NB_BYTES = 0_8 NB_BYTES_MAX = 0_8 NB_BYTES_EXTRA = 0_8 K34_8 = int(KEEP(34), 8) K35_8 = int(KEEP(35), 8) ! complex factor K16_8 = int(KEEP(16), 8) K149_8 = int(KEEP(149),8) ! complex in instance K151_8 = int(KEEP(151),8) ! complex in instance C RR KEEP20_SAVE = KEEP(20) IF (KEEP(19).EQ.0.AND.KEEP(53).NE.0) THEN C ICNTL(56)>0 at analysis and =0 at facto C save special root index KEEP20_SAVE = KEEP(20) C suppress special RR treatment KEEP(20) = 0 ENDIF NBENT_RHSINTR = 0 C Used by DISTRIBUTED_SOLUTION to skip empty columns C that are skipped (case of sparse RHS) NB_RHSSKIPPED = 0 C next 4 initialisations needed in case of error C to free space allocated LSCAL = .FALSE. C ICNTL21 = -99998 ! will be bcasted later to slaves IBEG_RHSINTR =-152525_8 ! Should not be used BUILD_POSINRHSINTR = .TRUE. C NSOL_loc, KEEP(212) will be set if ICNTL(21).EQ.2 NSOL_loc = 0 KEEP(212)= 0 C SCALING_RHSINTR was initialized to a dummy array of size 1 C on the non working host, no need to reset it at each block BUILD_SCALING_RHSINTR = I_AM_SLAVE IBEG_GLOB_DEF = -9888 ! unitialized state IEND_GLOB_DEF = -9888 ! unitialized state IBEG_ROOT_DEF = -9777 ! unitialized state IEND_ROOT_DEF = -9777 ! unitialized state IROOT_DEF_RHS_COL1 = -9666 ! unitialized state C ------------------------------ C id%LD_RHSINTR will be set each C time RHSINTR is allocated C ------------------------------ NB_FS_RHSINTR_TOT = KEEP(89) ! number of FS var of the pruned tree ! mapped on this proc NB_FS_RHSINTR_F = NB_FS_RHSINTR_TOT C Save value of KEEP(350), in case of LR solve C KEEP(350) may be overwritten and restored C Old unoptimized version before 5.0.2 not available anymore IF (KEEP(350).LE.0) KEEP(350)=1 IF (KEEP(350).GT.2) KEEP(350)=1 KEEP350_SAVE = KEEP(350) C C Compute the number of integers and nb of reals in the structure CALL SMUMPS_SIZE_IN_STRUCT (id, idintr, NB_INT, NB_CMPLX, NB_CHAR) NB_BYTES = NB_BYTES + NB_INT * K34_8 + NB_CMPLX * K149_8 + NB_CHAR ! KE15: size of a cmplx in current MUMPS instance NB_BYTES_ON_ENTRY = NB_BYTES !used to check alloc/dealloc count ok NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ====================================== C BEGIN CHECK KEEP ENTRIES AND INTERFACE C ====================================== IF (id%MYID .EQ. MASTER) THEN C { C Set ICNTL(26) -> KEEP(221) (called at facto and solve) C (might be called at facto in case of fwd in facto C with Schur+reduced RHS requested) CALL SMUMPS_SET_K221(id, .TRUE.) id%KEEP(111) = id%ICNTL(25) C For the case of ICNTL(20)=1 one could C switch off exploit sparsity when RHS is too dense. IF (id%ICNTL(20) .EQ. 1) id%KEEP(235) = -1 !automatic IF (id%ICNTL(20) .EQ. 2) id%KEEP(235) = 0 !off IF (id%ICNTL(20) .EQ. 3) id%KEEP(235) = 1 !on IF (id%ICNTL(20).EQ.1 .or. id%ICNTL(20).EQ.2 .or. & id%ICNTL(20).EQ.3) THEN id%KEEP(248) = 1 !sparse RHS ELSE IF (id%ICNTL(20).EQ.10 .OR. id%ICNTL(20).EQ.11) THEN id%KEEP(248) = -1 ! dist. RHS ELSE id%KEEP(248) = 0 !dense RHS ENDIF C C set ICNTL21 and test for out-of range entries ICNTL21 = id%ICNTL(21) IF ( ICNTL21.NE.0 .AND. ICNTL21.NE.1 & ) ICNTL21 = 0 C IF ( id%ICNTL(30) .NE.0 ) THEN C A-1 is on id%KEEP(237) = 1 ELSE C A-1 is off id%KEEP(237) = 0 ENDIF IF (id%KEEP(248) .eq.0.and. id%KEEP(237).ne.0) THEN C For A-1 we have a sparse RHS in the API. C Force KEEP(248) accordingly. id%KEEP(248)=1 ENDIF IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(248).NE.0) ) THEN IF (KEEP(60).NE.0) THEN C -- input RHS is stored in REDRHS and RHSINTR id%KEEP(248) = 0 ENDIF ENDIF C} ENDIF C ============================================================= C KEEP(248) and KEEP(221): need be broadcasted C before continuing other checking/settings CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(248), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) IF (KEEP(248).EQ.-1 & ) THEN C{ CALL SMUMPS_CHECK_DISTRHS( & id%Nloc_RHS, & id%LRHS_loc, & id%NRHS, & id%IRHS_loc, & id%RHS_loc, & I_AM_SLAVE, & id%INFO) CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 C Compute sum of id%Nloc_RHS (without out-of-range) C and store it in SUM_idNloc_RHS_8 C (to be used to decide whether exploit sparsity C is exploited) CALL SMUMPS_ES_GET_SUM_Nloc ( & id%N, id%Nloc_RHS, id%IRHS_loc, id%COMM, & SUM_idNloc_RHS_8 ) C} ENDIF C =========================================================== IF (id%MYID .EQ. MASTER) THEN C { IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(235).NE.0) ) THEN C -- input RHS is in fact effectively C -- stored in REDRHS and/or RHSINTR C (for both Schur and bwd only) id%KEEP(235) = 0 ENDIF IF ( (id%KEEP(248).EQ.0).AND.(id%KEEP(111).EQ.0) ) THEN C RHS is not sparse and thus exploit sparsity is reset to 0 id%KEEP(235) = 0 ENDIF IF (id%KEEP(248) .EQ. -1 & ) THEN IF (id%KEEP(126).EQ.0) THEN id%KEEP(235) = 0 ELSE IF (id%KEEP(126).EQ.-1) THEN id%KEEP(235) = 1 ELSE IF (id%KEEP(126).GT.0) THEN IF ( SUM_idNloc_RHS_8 .LE. & int( & (real(id%KEEP(126))/real(1000))*real(id%N) & , 8) & ) THEN id%KEEP(235) = 1 ELSE id%KEEP(235) = 0 ENDIF ELSE id%KEEP(235) = 0 ENDIF ENDIF C Case of Automatic setting of exploit sparsity (KEEP(235)=-1) C (in MUMPS_DRIVER original value of KEEP(235) is reset) IF(id%KEEP(111).NE.0) id%KEEP(235)=0 IF(id%KEEP(111).NE.0) id%KEEP(212)=0 C IF (id%KEEP(235).EQ.-1) THEN IF (id%KEEP(237).NE.0) THEN C for A-1 id%KEEP(235)=1 ELSE id%KEEP(235)=1 ENDIF ELSE IF (id%KEEP(235).NE.0) THEN id%KEEP(235)=1 ENDIF C Setting of KEEP(242) (permute RHS) IF ((KEEP(111).NE.0).OR.(KEEP(248) .EQ. -1)) THEN C In the context of C - distributed RHS, all columns share the same structure C - null space, the null pivots C are by default permuted to post-order C However for null space there is in this case no need to C permute null pivots since they are already in correct order. C Setting KEEP(242)=1 would just force to go through C part of the code permuting to identity. C Apart for validation purposes this is not interesting C costly (and more risky). KEEP(242) = 0 ENDIF IF (KEEP(248).EQ.0.AND.KEEP(111).EQ.0) THEN C Permutation possible if sparse RHS C (KEEP(248).NE.0: A-1 or General Sparse) C or null space (even if in current version C it is deactived) KEEP(242) = 0 ENDIF IF ((KEEP(242).NE.0).AND.KEEP(237).EQ.0) THEN IF ((KEEP(242).NE.-9).AND.KEEP(242).NE.1.AND. & KEEP(242).NE.-1) THEN C Reset it to 0 KEEP(242) = 0 ENDIF ENDIF IF (KEEP(242).EQ.-9) THEN C { C Automatic setting of permute RHS IF (id%KEEP(237).NE.0) THEN KEEP(242) = 1 ! postorder for A-1 ELSE ! dense or general sparse or distributed RHS KEEP(242) = 0 ! no permutation in most general case IF (KEEP(248) .EQ. 1) THEN ! sparse RHS IF (id%KEEP(235) .EQ. 1) THEN ! Tree pruning IF (id%NRHS .GT. 1) THEN IF (KEEP(497).EQ.-1 .OR. KEEP(497).GE.1) THEN KEEP(242)=1 ENDIF ENDIF ENDIF ENDIF ENDIF C } ENDIF IF ( id%KEEP(221).NE.0 ) THEN C -- Do not permute RHS with REDRHS/RHSINTR id%KEEP(242) = 0 ENDIF IF (KEEP(242).EQ.0) KEEP(243)=0 ! interleave off IF ((KEEP(237).EQ.0).OR.(KEEP(242).EQ.0)) THEN C Interleave (243) possible only C when permute RHS (242) is on and with A-1 KEEP(243) = 0 ENDIF IF (id%KEEP(237).EQ.1) THEN ! A-1 entries C Case of automatic setting of KEEP(243), KEEP(493-498) C (exploit sparsity parameters) IF (id%NSLAVES.EQ.1) THEN IF (id%KEEP(243).EQ.-1) id%KEEP(243)=0 IF (id%KEEP(495).EQ.-1) id%KEEP(495)=1 IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ELSE IF (id%KEEP(243).EQ.-1) id%KEEP(243)=1 IF (id%KEEP(495).EQ.-1) id%KEEP(495)=1 IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ENDIF ELSE ! dense or general sparse or distributed RHS id%KEEP(243)=0 id%KEEP(495)=0 IF (KEEP(248) .EQ. 1) THEN ! sparse RHS IF (id%KEEP(235) .EQ. 1) THEN ! Tree pruning IF (id%NRHS .GT. 1) THEN IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ENDIF ENDIF ELSE C nbsparse meaningless for distributed or dense RHS C Force it to 0 whatever was the initial value id%KEEP(497)=0 ENDIF ENDIF MTYPE = id%ICNTL( 9 ) IF (MTYPE.NE.1) MTYPE=0 ! see interface IF ((MTYPE.EQ.0).AND.KEEP(50).NE.0) MTYPE =1 ! suppress option Atx=b for A-1 IF (id%KEEP(237).NE.0) MTYPE = 1 C C ICNTL(35) was defined at analysis and C consistently reset at factorization C It was stored in KEEP(486) after factorization C Set KEEP(485) accordingly. C IF (KEEP(486) .EQ. 2) THEN KEEP(485) = 1 ! BLR solve ELSE KEEP(485) = 0 ! FR solve ENDIF C } ENDIF id%KEEP(401) = 0 IF (id%ICNTL(48).EQ.1) id%KEEP(401)=1 C Bcast id%KEEP(401) strategy (which C may be switched off or on during solve) CALL MPI_BCAST( id%KEEP(401), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) C define ICNTL48_EFF on master IF (id%MYID.EQ.MASTER) THEN IF ( (id%KEEP(401).EQ.1). AND. (id%KEEP(400).GT.0) ) THEN ICNTL48_EFF = 1 ELSE ICNTL48_EFF = 0 ENDIF ENDIF CALL MPI_BCAST(MTYPE,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST( id%KEEP(111), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(235), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(237), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(242), 2, MPI_INTEGER, MASTER, id%COMM, & IERR ) C Allready done CALL MPI_BCAST( id%KEEP(248), ...) CALL MPI_BCAST( id%KEEP(350), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(485), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(495), 3, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( ICNTL21, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C Broadcast original id%NRHS (used at least for checks on SOL_loc C and to allocate PERM_RHS in case of exploit sparsity) CALL MPI_BCAST( id%NRHS,1, MPI_INTEGER, MASTER, id%COMM,IERR) C C TIMINGS: reset to 0 TIMEC2=0.0D0 TIMECOPYSCALE2=0.0D0 TIMEGATHER2=0.0D0 TIMESCATTER2=0.0D0 id%DKEEP(112)=0.0E0 id%DKEEP(113)=0.0E0 C id%DKEEP(114) time for the iterative refinement C id%DKEEP(120) time for the error analysis C id%DKEEP(121) time for condition number C id%DKEEP(122) time for matrix redistribution (copy+scale solution) id%DKEEP(114)=0.0E0 id%DKEEP(120)=0.0E0 id%DKEEP(121)=0.0E0 id%DKEEP(115)=0.0E0 id%DKEEP(116)=0.0E0 id%DKEEP(122)=0.0E0 C Time for fwd, bwd and scalapack is C accumulated in DKEEP(117-119) within SOL_C C If requested time for each call to FWD/BWD C might be print but on output to solve C phase DKEEP will hold on each proc the accumulated time id%DKEEP(117)=0.0E0 id%DKEEP(118)=0.0E0 id%DKEEP(119)=0.0E0 id%DKEEP(123)=0.0E0 id%DKEEP(124)=0.0E0 id%DKEEP(125)=0.0E0 id%DKEEP(126)=0.0E0 id%DKEEP(127)=0.0E0 id%DKEEP(128:134)=0.0E0 id%DKEEP(140:153)=0.0E0 C CALL MUMPS_SECDEB(TIME3) C ------------------------------ C Check parameters on the master C ------------------------------ IF ( id%MYID .EQ. MASTER ) THEN IF ((KEEP(23).NE.0).AND.KEEP(50).NE.0) THEN C Maximum transversal permutation C has not been saved (KEEP(23)>0 and UNS_PERM allocated) C when matrix is symmetric. IF (PROKG) WRITE(MPG,'(A)') & ' Internal Error 1 in solution driver ' id%INFO(1)=-444 id%INFO(2)=KEEP(23) ENDIF C ------------------------------------ C Check that factors are available C either in-core or on disk, case C where factors were discarded during C factorization (e.g. useful to simulate C an OOC factorization or just get nb of C negative pivots or determinant) C ------------------------------------ IF (KEEP(201) .EQ. -1) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: Solve impossible because factors not kept' ENDIF id%INFO(1)=-44 id%INFO(2)=KEEP(251) GOTO 333 ELSE IF (KEEP(221).EQ.0 .AND. KEEP(251) .EQ. 2 & .AND. KEEP(252).EQ.0) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: Solve impossible because factors not kept' ENDIF id%INFO(1)=-44 id%INFO(2)=KEEP(251) GOTO 333 ENDIF C ------------------ IF (KEEP(252).NE.0 .AND. id%NRHS .NE. id%KEEP(253)) THEN C Fwd in facto C KEEP(252-253) available on all procs since analysis phase C Error: id%NRHS is not allowed to change since analysis C because fwd has been performed during facto with C KEEP(253) RHS IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: id%NRHS not allowed to change when', & ' ICNTL(32)=1' ENDIF id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) GOTO 333 ENDIF C Testing MTYPE instead of ICNTL(9) IF (KEEP(252).NE.0 .AND. MTYPE.NE.1) THEN C Fwd in facto is not compatible with transpose system INFO(1) = -43 INFO(2) = 9 IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.1) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' ENDIF GOTO 333 ENDIF IF (KEEP(248) .NE. 0.AND.KEEP(252).NE.0) THEN C Fwd during facto incompatible with sparse RHS C Forbid sparse RHS when Fwd performed during facto C Sparse RHS may be due to A-1 (ICNTL(30) INFO(1) = -43 IF (KEEP(237).NE.0) THEN INFO(2) = 30 ! ICNTL(30) IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: A-1 functionality incompatible with', & ' forward performed during factorization', & ' (ICNTL(32)=1)' ENDIF ELSE INFO(2) = 20 ! ICNTL(20) IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: sparse or dist. RHS incompatible with forward', & ' elimination during factorization (ICNTL(32)=1)' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. ICNTL21.NE.0) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with distributed solution.' ENDIF INFO(1)=-48 INFO(2)=21 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(60) .NE.0) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with Schur.' ENDIF INFO(1)=-48 INFO(2)=19 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(111) .NE.0) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with null space.' ENDIF INFO(1)=-48 INFO(2)=25 GOTO 333 ENDIF IF (id%NRHS .LE. 0) THEN id%INFO(1)=-45 id%INFO(2)=id%NRHS IF ((id%KEEP(111).NE.0).AND.(id%INFOG(28).EQ.0)) THEN IF (LPOK) THEN WRITE(LP,'(A)') & 'ICNTL(25) NE 0 but INFOG(28)=0', & ' the matrix is not deficient' ENDIF ENDIF GOTO 333 ENDIF C Entries of A-1 are stored in place of the input sparse RHS C thus no need for RHS to be allocated. IF (id%KEEP(237).EQ.0) THEN IF ((id%KEEP(248) == 0 .AND.KEEP(221).NE.2) & .OR. & (ICNTL21==0.AND.(KEEP(221).NE.1)) & )THEN C RHS must be of size N*NRHS on the master either to C store the dense centralized RHS, either to store C the dense centralized solution. CALL SMUMPS_CHECK_DENSE_RHS & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) IF (id%INFO(1) .LT. 0) GOTO 333 ENDIF ELSE C AM1: check that the constraint NRHS=N is respected C Check for valid sparse RHS structure done IF (id%NRHS .NE. id%N) THEN id%INFO(1)= -47 id%INFO(2)=id%NRHS GOTO 333 ENDIF ENDIF IF (id%KEEP(248) == 1 & ) THEN C{ ------------------------------------ C RHS_SPARSE, IRHS_SPARSE and IRHS_PTR C must be allocated of adequate size C ------------------------------------ IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(237).NE.0)) THEN C At least one entry of A-1 must be requested id%INFO(1)=-46 id%INFO(2)=id%NZ_RHS GOTO 333 ENDIF IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(221).EQ.1)) THEN C At least one entry of RHS must be nonzero with c Schur reduced RHS option id%INFO(1)=-46 id%INFO(2)=id%NZ_RHS GOTO 333 ENDIF IF ( id%NZ_RHS .GT. 0 ) THEN IF ( .not. associated(id%RHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 ENDIF ENDIF IF (id%NZ_RHS .GT. 0) THEN IF ( .not. associated(id%IRHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 ENDIF ENDIF IF ( .not. associated(id%IRHS_PTR) )THEN id%INFO(1)=-22 id%INFO(2)=12 GOTO 333 ENDIF C IF (size(id%IRHS_PTR) < id%NRHS + 1) THEN id%INFO(1)=-22 id%INFO(2)=12 GOTO 333 END IF IF (id%IRHS_PTR(id%NRHS + 1).ne.id%NZ_RHS+1) THEN id%INFO(1)=-27 id%INFO(2)=id%IRHS_PTR(id%NRHS+1) GOTO 333 END IF C compare with dble to prevent overflow IF (dble(id%N)*dble(id%NRHS).LT.dble(id%NZ_RHS)) THEN C Possible in case of dupplicate entries in Sparse RHS IF (PROKG) THEN write(MPG,*) & " WARNING: many dupplicate entries in ", & " sparse RHS provided by the user ", & " id%NZ_RHS,id%N,id%NRHS =", & id%NZ_RHS,id%N,id%NRHS ENDIF END IF IF (id%IRHS_PTR(1).ne.1) THEN id%INFO(1)=-28 id%INFO(2)=id%IRHS_PTR(1) GOTO 333 END IF IF (size(id%IRHS_SPARSE) < id%NZ_RHS) THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 END IF IF (size(id%RHS_SPARSE) < id%NZ_RHS) THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 END IF C} ENDIF C -------------------------------- C Set null space options for solve C -------------------------------- CALL SMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL(1),KEEP(1), & id%NRHS, & MPG,INFO(1)) IF (INFO(1) .LT. 0) GOTO 333 C END IF ! MASTER C -------------------------------------- C Check distributed solution vectors C -------------------------------------- IF (ICNTL21 .NE. 0 ) THEN IF (I_AM_SLAVE) THEN NSOL_loc = id%KEEP(89) ELSE NSOL_loc = 0 ENDIF C (I)SOL_loc should be allocated to hold the C distributed solution on exit IF ( id%LSOL_loc .LT. NSOL_loc ) THEN id%INFO(1)= -29 id%INFO(2)= id%LSOL_loc GOTO 333 ENDIF IF ( NSOL_loc .GT. 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) < NSOL_loc ) THEN id%INFO(1)=-22 id%INFO(2)=13 GOTO 333 END IF # if defined(MUMPS_NOF2003) C Warning: size returns a standard INTEGER and could C overflow if id%SOL_loc was allocated of size > 2^31-1; C still we prefer to perform this test since only (1) very C large problems with large NRHS and small numbers of MPI C can result in such a situation; (2) the test could be C suppressed if needed but might be still be ok in case C the right-hand side overflows too. IF (size(id%SOL_loc) < & (id%NRHS-1)*id%LSOL_loc+NSOL_loc) THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 END IF # else IF (size(id%SOL_loc,kind=8) < & int(id%NRHS-1,8)*int(id%LSOL_loc,8)+ & int(NSOL_loc,8)) THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 END IF # endif ENDIF ! NSOL_loc > 0 ENDIF ! ICNTL21 .NE. 0 IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(248) == 1 & ) THEN C RHS should NOT be associated C if I am not master since it is C not even used to store the solution IF ( associated( id%RHS ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 7 GOTO 333 END IF IF ( associated( id%RHS_SPARSE ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 10 GOTO 333 END IF IF ( associated( id%IRHS_SPARSE ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 11 GOTO 333 END IF IF ( associated( id%IRHS_PTR ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 12 GOTO 333 END IF END IF ENDIF C Prepare pointers to pass POINTERS(1) to C routines with implicit interfaces which C will then assume contiguous information C without needing to copy pointer arrays C in and out. Do this even if KEEP(248) C is different from -1 because of the C call to SMUMPS_DISTSOL_INDICES IF (associated(id%IRHS_loc)) THEN IF (size(id%IRHS_loc) .NE. 0) THEN IRHS_loc_PTR=>id%IRHS_loc ELSE C so that IRHS_loc_PTR(1) is ok IRHS_loc_PTR=>IDUMMY_TARGET ENDIF ELSE IRHS_loc_PTR=>IDUMMY_TARGET ENDIF IF (associated(id%RHS_loc)) THEN IF (size(id%RHS_loc) .NE. 0) THEN idRHS_loc=>id%RHS_loc ELSE idRHS_loc=>CDUMMY_TARGET ENDIF ELSE idRHS_loc=>CDUMMY_TARGET ENDIF C C C Check as soon as solution is distributed IF (I_AM_SLAVE .AND. ICNTL21.NE.0 .AND. & KEEP(248) .EQ. -1 & ) THEN ! Dist RHS and dist solution C IF (associated(id%RHS_loc) .AND. & associated(id%SOL_loc)) THEN C NSOL_loc was defined earlier IF (NSOL_loc.GT.0) THEN C ---------------------------------------------------- C Check if RHS_loc and SOL_loc point to same object... C id%SOL_loc(1) ok otherwise an error -22/14 C would have been raised earlier. C idRHS_loc(1) may point to CDUMMY but is ok C ---------------------------------------------------- CALL MUMPS_SIZE_C(idRHS_loc(1),id%SOL_loc(1), & DIFF_SOL_loc_RHS_loc) C ---------------------------------------- C Check for compatible dimensions in case C SOL_loc and RHS_loc point to same memory C ---------------------------------------- IF (DIFF_SOL_loc_RHS_loc .EQ. 0_8 .AND. & id%LSOL_loc .GT. id%LRHS_loc) THEN C Note that, depending on the block size, C if all columns are processed in one C shot, this could still work. However, C and since this was forbidden in the UG, C we raise the error systematically id%INFO(1)=-56 id%INFO(2)=id%LRHS_loc IF (LPOK) THEN WRITE(LP,'(A,I9,A,I9)') &" ** Error RHS_loc and SOL_loc pointers match but LRHS_loc=" &,id%LRHS_loc, " and LSOL_loc=", id%LSOL_loc ENDIF GOTO 333 ENDIF ENDIF ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN C Do some checks on KEEP(221) and REDRHS (in case of Schur) CALL SMUMPS_CHECK_K221andREDRHS(id) END IF ! MYID.EQ.MASTER IF (id%INFO(1) .LT. 0) GOTO 333 C ------------------------- C Propagate possible errors C ------------------------- 333 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 C ==================================== C END CHECK INTERFACE AND KEEP ENTRIES C ==================================== C ----------------------------------- 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) ENDIF C C ======================================================= C BEGIN Test for empty RHS : C sparse RHS and General Sparse (NOT A-1) and NZ_RHS = 0 C OR C Distributed RHS and sum of id%Nloc_RHS C (without off out-of-range) equal to 0 C ======================================================= IF & ( & ( (id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0) & .AND. (id%NZ_RHS.EQ.0) ) & .OR. & ( (id%KEEP(248).EQ.-1).AND. (SUM_idNloc_RHS_8.EQ.0_8) & ) & ) THEN C{ C We reset solution to zero and we return C (first freeing working space at label 90) IF ((ICNTL21.EQ.1).AND.(I_AM_SLAVE)) THEN C ---------------------- C SOL_loc reset to zero C ---------------------- C ---------------------- C Prepare ISOL_loc array C ---------------------- LIW_PASSED=max(1,KEEP(32)) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF (KEEP(89) .GT. 0) THEN CALL SMUMPS_DISTSOL_INDICES( MTYPE, id%ISOL_loc(1), & id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%IS(1), LIW_PASSED,id%MYID_NODES, & id%N, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES, #if defined(USE_OLD_SCALING) & scaling_data_sol, .FALSE., ! empty RHS, no scaling #endif C For checking only & .FALSE., IDUMMY(1), 1 & ) ENDIF ENDIF C Solution is null IF (ICNTL21.NE.0) THEN ! distributed solution DO J=1, id%NRHS C (NSOL_loc=KEEP(89) or id%NSOL_loc, and in case C ICNTL21=1, NSOL_loc is 0 on non-working host) DO I=1, NSOL_loc id%SOL_loc(int(J-1,8)*id%LSOL_loc + I) =ZERO ENDDO ENDDO ENDIF IF (ICNTL21.EQ.0) THEN ! centralized solution C ---------------------------- C RHS reset to zero on master C ---------------------------- IF (id%MYID.EQ.MASTER) THEN DO J=1, id%NRHS DO I=1, id%N id%RHS(int(J-1,8)*int(id%LRHS,8) + int(I,8)) =ZERO ENDDO ENDDO ENDIF ENDIF C C print solve phase stats if requested IF ( PROKG ) THEN WRITE( MPG, 150 ) C ICNTL(35) should not been accessed during SOLVE thus C print KEEP(486) value set during factorization & id%NRHS, ICNTL(27), ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30), KEEP(486), & ICNTL48_EFF IF (KEEP(221).NE.0) THEN WRITE (MPG, 152) KEEP(221) ENDIF IF (KEEP(252).GT.0) THEN ! Fwd during facto WRITE (MPG, 153) KEEP(252) ENDIF ENDIF C C -------- GOTO 90 ! end of solve deallocate what is needed C} ENDIF ! test empty RHS (general sparse or Distributed) C ======================================================= C END of Test for empty RHS : C ======================================================= C ==================================== C END CHECK INTERFACE AND KEEP ENTRIES C ==================================== INTERLEAVE_PAR =.FALSE. DO_PERMUTE_RHS =.FALSE. CALL_NODES_FWD_BWD = .FALSE. FIRST_CALL_NODES_FWD_BWD = .FALSE. C Default is no sparsity exploited nodes_FWD_PTR => IDUMMY_TARGET nodes_BWD_PTR => IDUMMY_TARGET Lnodes_FWD = -1 Lnodes_BWD = -1 C IF ((id%KEEP(235).NE.0).or.(id%KEEP(237).NE.0) & ) THEN CALL_NODES_FWD_BWD = .TRUE. FIRST_CALL_NODES_FWD_BWD = .TRUE. C Case of pruned elimination tree or selected entries in A-1 IF (id%KEEP(237).NE.0.AND. & id%KEEP(248).EQ.0) THEN C When A-1 is requested (keep(237).ne.0) C sparse RHS has been forced to be on. IF (LPOK) THEN WRITE(LP,'(A,I4,I4)') & ' Internal Error 2 in solution driver (A-1) ', & id%KEEP(237), id%KEEP(248) ENDIF CALL MUMPS_ABORT() ENDIF C NBT (in Bytes) is inout in MUMPS_REALLOC and C should be initialized. NBT = 0 C -- Allocate Step2node on each proc CALL MUMPS_REALLOC(id%Step2node, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%Step2node (Solve)', MEMCNT=NBT, ERRCODE=-13) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C -- build Step2node on each proc; C -- this is usefull to have at each step a unique C -- representative node (associated with principal variable of C -- that node. IF (NBT.NE.0) THEN ! Step2node was reallocated and needs be recomputed DO I=1, id%N IF (id%STEP(I).LE.0) CYCLE ! nonprincipal variables id%Step2node(id%STEP(I)) = I ENDDO C ELSE C we reuse Step2node computed in a previous solve phase C Step2node is deallocated each time a new analysis is C performed or when job=-2 is called ENDIF C --- NBT is the nb of extra bytes allocated NB_BYTES = NB_BYTES + NBT NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) NB_BYTES_EXTRA = NB_BYTES_EXTRA + NBT C Mapping information used during solve. In case of several C facto+solve it has to be recomputed. C In case of several solves with the same C facto, it is not recomputed. C It is used to compute the interleaving C for A-1, and, in dev_version, passed to sol_c to compute C some stats IF((KEEP(235).NE.0).OR.(KEEP(237).NE.0)) THEN IF(.NOT.associated(id%IPTR_WORKING)) THEN C Not computed at a previous solve: C recompute id%IPTR_WORKING and id%WORKING CALL SMUMPS_BUILD_MAPPING_INFO(id) END IF idIPTR_WORKING => id%IPTR_WORKING idWORKING => id%WORKING ELSE C case of selected entries in solution C with no ES during fwd SIZE_WORKING = 1 SIZE_IPTR_WORKING = 1 idIPTR_WORKING => IDUMMY_TARGET idWORKING => IDUMMY_TARGET END IF ENDIF C C Initialize SIZE_OF_BLOCK from MUMPS_SOL_ES module IF ( I_AM_SLAVE ) THEN CALL SMUMPS_SOL_ES_INIT(id%OOC_SIZE_OF_BLOCK, id%KEEP(201)) ENDIF DO_NULL_PIV = .TRUE. NBCOL_INBLOC = -9998 NZ_THIS_BLOCK= -9998 JBEG_RHS = -9998 c IF (id%MYID.EQ.MASTER) THEN ! Compute NRHS_NONEMPTY C C -- Sparse RHS (general, centralized) IF ( KEEP(111)==0 .AND. KEEP(248)==1 & ) THEN C -- Note that KEEP(111).NE.0 (null space on) C -- and KEEP(248).NE.0 will be made incompatible C -- When computing entries of A-1 (or SparseRHS only) NRHS_NONEMPTY = 0 DO I=1, id%NRHS IF (id%IRHS_PTR(I).LT.id%IRHS_PTR(I+1)) THEN NRHS_NONEMPTY = NRHS_NONEMPTY+1 !ith col in non empty ENDIF ENDDO IF (NRHS_NONEMPTY.LE.0) THEN C Internal error: tested before in mumps_driver IF (LPOK) & WRITE(LP,*) " Internal Error 3 in solution driver ", & " NRHS_NONEMPTY= ", & NRHS_NONEMPTY CALL MUMPS_ABORT() ENDIF ELSE NRHS_NONEMPTY = id%NRHS ENDIF ENDIF C ------------------------------------ C If there is a special root node, C precompute mapping of root's master C ------------------------------------ SIZE_ROOT = -33333 IF ( KEEP( 38 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP( KEEP(38))), & KEEP(199) ) IF (id%MYID_NODES .eq. MASTER_ROOT) THEN SIZE_ROOT = idintr%root%TOT_ROOT_SIZE ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN C SIZE_ROOT also used for KEEP(221).NE.0 SIZE_ROOT=id%KEEP(116) ENDIF ELSE IF (KEEP( 20 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(KEEP(20))), & KEEP(199) ) IF (id%MYID_NODES .eq. MASTER_ROOT) THEN SIZE_ROOT = id%IS( & id%PTLUST_S(id%STEP(KEEP(20)))+KEEP(IXSZ) + 3) ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN C SIZE_ROOT also used for KEEP(221).NE.0 SIZE_ROOT=id%KEEP(116) ENDIF ELSE MASTER_ROOT = -44444 END IF C -------------- C Get block size C -------------- C We work on a maximum of NBRHS at a time. C The leading dimension of RHS is id%LRHS on the host process C and it is set to N on slave processes. IF (id%MYID .eq. MASTER) THEN C{ KEEP(84) = ICNTL(27) C Treating ICNTL(27)=0 as if ICNTL(27)=1 IF(ICNTL(27).EQ.0) KEEP(84)=1 IF (KEEP(252).NE.0) THEN ! Fwd in facto: all rhs (KEEP(253) need be processed in one pass NBRHS = KEEP(253) ELSE IF (KEEP(201) .EQ. 0 .OR. KEEP(84) .GT. 0) THEN NBRHS = abs(KEEP(84)) ELSE NBRHS = -2*KEEP(84) END IF IF (NBRHS .GT. NRHS_NONEMPTY ) NBRHS = NRHS_NONEMPTY C ENDIF C} ENDIF #if defined(V_T) CALL VTBEGIN(glob_comm_ini,IERR) #endif C NRHS_NONEMPTY needed on all procs to allocate RHSINTR on slaves CALL MPI_BCAST(NRHS_NONEMPTY,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(NBRHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) C IF (KEEP(201).GT.0) THEN C --- id%KEEP(201) indicates if OOC is on (=1) of not (=0) C -- 107: number of buffers C Define number of types of files (L, possibly U) WORKSPACE_MINIMAL_PREFERRED = .FALSE. IF (id%MYID .eq. MASTER) THEN KEEP(107) = max(0,KEEP(107)) IF ((KEEP(107).EQ.0).AND. & (KEEP(204).EQ.0).AND.(KEEP(211).NE.1) ) THEN C -- default setting for release 4.8 ! Case of ! -Emmergency buffer only and ! -Synchronous mode ! -NO_O_DIRECT (because of synchronous choice) ! THEN ! "Basic system-based version" ! We can force to allocate S to a minimal ! value. WORKSPACE_MINIMAL_PREFERRED=.TRUE. ENDIF ENDIF CALL MPI_BCAST( KEEP(107), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(204), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(208), 2, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( WORKSPACE_MINIMAL_PREFERRED, 1, & MPI_LOGICAL, & MASTER, id%COMM, IERR ) C --- end of OOC case ENDIF IF ( I_AM_SLAVE ) THEN C C NB_K133: Max number of simultaneously processed C active fronts. C Why more than one active node ? C 1/ In parallel when we start a level 2 node C then we do not know exactly when we will C have received all contributions from the C slaves. C This is very critical in OOC since the C size provided to the solve phase is C much smaller and since we need C to determine the size fo the buffers for IO. C We pospone the allocation of the block NFRONT*NB_NRHS C and solve the problem. C C C 2/ While processing a node and sending information C if we have not enough memory in send buffer C then we must receive. C We feel that this is not so critical. C NB_K133 = 3 C To this we must add one time KEEP(133) to store C the RHS of the root node if the root is local. C Furthermore this quantity has to be multiplied by the C blocking size in case of multiple RHS. IF ( KEEP( 38 ) .NE. 0 .OR. KEEP( 20 ) .NE. 0 ) THEN IF ( MASTER_ROOT .eq. id%MYID_NODES ) THEN IF ( & .NOT. associated(idintr%roota%RHS_CNTR_MASTER_ROOT) & ) THEN NB_K133 = NB_K133 + 1 ENDIF END IF ENDIF C -------------------------------------- C NRHS_COLS_SOL_C is the maximum number C of colums for the call to SMUMPS_SOL_C C -------------------------------------- NRHS_COLS_SOL_C = min(NRHS_NONEMPTY,NBRHS) C C LWCB8_MIN = int(NB_K133,8)*int(KEEP(133),8)* & int(NRHS_COLS_SOL_C,8) C ENDIF C --------------------------------------------------------------- C Set WK_USER_PROVIDED to true when workspace WK_USER is provided C We can accept WK_USER to be provided on only some process and C different values of WK_USER per process. WK_USER_PROVIDED = (id%LWK_USER.NE.0 .AND.I_AM_SLAVE) IF (WK_USER_PROVIDED) THEN IF (id%LWK_USER.GT.0) THEN ITMP8= int(id%LWK_USER,8) ELSE ITMP8 = -int(id%LWK_USER,8)* 1000000_8 ENDIF ELSE ITMP8 = 0_8 ENDIF CALL MPI_REDUCE ( ITMP8, SUM_ITMP8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) C Incore: Check if the provided size is equal to that used during C facto (case of ITMP8/=0 and KEEP8(24)/=ITMP8) C But also check case of space not provided during solve C but was provided during facto C (case of ITMP8=0 and KEEP8(24)/=0) IF (KEEP(201).EQ.0) THEN ! incore C Compare provided size with previous size IF (ITMP8.NE.KEEP8(24)) THEN C -- error when reusing space allocated INFO(1) = -41 INFO(2) = id%LWK_USER ENDIF ELSE KEEP8(24)=ITMP8 ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 IF (.NOT. I_AM_SLAVE) KEEP8(124)=SUM_ITMP8 C all procs: KEEP8(24) holds the size of WK_USER provided by user. C master only: KEEP8(124) indicates if WK_USER provided on some proc MAXS = 0_8 IF (I_AM_SLAVE) THEN IF (WK_USER_PROVIDED) THEN MAXS = KEEP8(24) IF (MAXS.LT. KEEP8(20)) THEN INFO(1)= -11 ! MAXS should be increased by at least ITMP8 ITMP8 = KEEP8(20)+1_8-MAXS CALL MUMPS_SET_IERROR(ITMP8, INFO(2)) ENDIF IF (INFO(1) .GE. 0 ) id%S => id%WK_USER(1:KEEP8(24)) ALLOCATE_S = .FALSE. ELSE IF (KEEP8(23) .GT. 0) THEN MAXS = KEEP8(23) C S is already allocated, of size KEEP8(23) ALLOCATE_S = .FALSE. ELSE IF (KEEP(201).EQ.0) THEN ! incore C id%S might have been freed during factorization and C reallocated of size KEEP8(31) ( if KEEP8(31)>0 ) IF (KEEP8(31).EQ.0) THEN MAXS = 1 ALLOCATE_S = .TRUE. ENDIF ELSE C -- OOC and WK_USER not provided: C define size (S) and allocate it C ---- modify size of MAXS: in a simple C ---- system-based version, we want to C ---- use a small size for MAXS, to C ---- avoid the system pagecache to be C ---- polluted by 'our memory' ALLOCATE_S = .TRUE. IF ( KEEP(209).EQ.-1 .AND. WORKSPACE_MINIMAL_PREFERRED) & THEN C We need space to load at least the largest factor MAXS = KEEP8(20) + 1_8 ELSE IF ( KEEP(209) .GE.0 ) THEN C Use suggested value of MAXS provided in KEEP(209) MAXS = max(int(KEEP(209),8), KEEP8(20) + 1_8) ELSE MAXS = id%KEEP8(14) ! initial value: do not use more than ! minimum (non relaxed) size of OOC facto ENDIF C MAXS = max(MAXS, id%KEEP8(20)+1_8) C --- end of OOC case ENDIF IF ( ALLOCATE_S ) THEN ALLOCATE (id%S(MAXS), stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID,': problem allocation of S ', & 'at solve' ENDIF INFO(1) = -13 CALL MUMPS_SET_IERROR(MAXS, INFO(2)) KEEP8(23)=0_8 ALLOCATE_S = .FALSE. ELSE KEEP8(23)=MAXS ENDIF NB_BYTES = NB_BYTES + KEEP8(23) * K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C IF (KEEP(201).EQ.0) THEN C On the slaves, S is divided as follows: C S(1..LA) holds the factors, C S(LA+1..MAXS) is free workspace LA = KEEP8(31) ELSE C MAXS has normally been dimensionned to store only factors. LA = MAXS IF(MAXS.GT.KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8))THEN C If we have a very large MAXS, the size reserved for C loading the factors into memory does not need to exceed the C total size of factors. The (KEEP8(20)*(KEEP(107)+1)) term C is here in order to ensure that even with round-off C problems (linked to the number of solve zones) factors can C all be stored in-core LA=KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8) ENDIF ENDIF C C We need to allocate a workspace of size LWCB8 for the solve phase. C Either it is available at the end of MAXS, or we perform a C dynamic allocation. IF ( MAXS-LA .GT. LWCB8_MIN & ) THEN LWCB8 = MAXS - LA WORK_WCB => id%S(LA+1_8:LA+LWCB8) WORK_WCB_ALLOCATED=.FALSE. ELSE LWCB8 = LWCB8_MIN ALLOCATE(WORK_WCB(LWCB8), stat=allocok) IF (allocok < 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(LWCB8,INFO(2)) ELSE WORK_WCB_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + LWCB8*K151_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C --------------------------------- C Space for the RHS of special root C --------------------------------- IF ( id%MYID_NODES .EQ. MASTER_ROOT ) THEN C This is a special root (otherwise MASTER_ROOT < 0) IF ( associated(idintr%roota%RHS_CNTR_MASTER_ROOT) ) THEN C RHS_CNTR_MASTER_ROOT may have been allocated C during the factorization phase. PTR_RHS_ROOT => idintr%roota%RHS_CNTR_MASTER_ROOT # if defined(MUMPS_NOF2003) LPTR_RHS_ROOT = & int(size(idintr%roota%RHS_CNTR_MASTER_ROOT),8) # else LPTR_RHS_ROOT = & size(idintr%roota%RHS_CNTR_MASTER_ROOT,kind=8) # endif ELSE C In this case, the space for RHS_CNTR_MASTER_ROOT C is always part of WORKWCB, which can itself be C part of id%S or not. LPTR_RHS_ROOT = NRHS_COLS_SOL_C * int(SIZE_ROOT,8) PTR_RHS_ROOT => WORK_WCB(LWCB8-LPTR_RHS_ROOT+1_8:LWCB8) C Reduce size of WORK_WCB LWCB8=LWCB8-LPTR_RHS_ROOT ENDIF ELSE LPTR_RHS_ROOT = 1_8 PTR_RHS_ROOT => CDUMMY_TARGET ENDIF ENDIF ! I_AM_SLAVE C ----------------------------------- 99 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 C ----------------------------------- IF ( I_AM_SLAVE ) THEN IF (KEEP(201).GT.0) THEN CALL SMUMPS_INIT_FACT_AREA_SIZE_S(LA) C -- This includes thread creation C -- for asynchronous strategies CALL SMUMPS_OOC_INIT_SOLVE(id%ICNTL(1), id%ICNTL(4), id%N, & id%NSLAVES, id%MYID, id%OOC_NB_FILE_TYPE, id%KEEP, id%KEEP8, & id%INFO, id%STEP, id%PROCNODE_STEPS, id%OOC_SIZE_OF_BLOCK, & id%OOC_INODE_SEQUENCE, id%OOC_VADDR, & id%OOC_MAX_NB_NODES_FOR_ZONE, id%OOC_TOTAL_NB_NODES, & id%OOC_NB_FILES, id%OOC_FILE_NAME_LENGTH, id%OOC_FILE_NAMES, & id%COMM_NODES, idintr%root%yes) IS_INIT_OOC_DONE = .TRUE. ENDIF ! KEEP(201).GT.0 ENDIF C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 C IF (I_AM_SLAVE) THEN IF (KEEP(485).EQ.1) THEN IF (.NOT. (associated(id%FDM_F_ENCODING))) THEN WRITE(*,*) "Internal error 18 in SMUMPS_SOL_DRIVER" CALL MUMPS_ABORT() ENDIF IF (.NOT. (associated(id%BLRARRAY_ENCODING))) THEN WRITE(*,*) "Internal error 19 in SMUMPS_SOL_DRIVER" CALL MUMPS_ABORT() ENDIF C Access to OOC data in module during solve CALL MUMPS_FDM_STRUC_TO_MOD('F',id%FDM_F_ENCODING) CALL SMUMPS_BLR_STRUC_TO_MOD(id%BLRARRAY_ENCODING) IS_LR_MOD_TO_STRUC_DONE = .TRUE. ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN C{ IF ( PROKG ) THEN WRITE( MPG, 150 ) C ICNTL(35) should not been accessed during SOLVE thus C print KEEP(486) value set during factorization & id%NRHS, NBRHS, ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30), KEEP(486), & ICNTL48_EFF IF (KEEP(111).NE.0) THEN WRITE (MPG, 151) KEEP(111) ENDIF IF (KEEP(221).NE.0) THEN WRITE (MPG, 152) KEEP(221) ENDIF IF (KEEP(252).GT.0) THEN ! Fwd during facto WRITE (MPG, 153) KEEP(252) ENDIF ENDIF C ==================================== C Define LSCAL, ICNTL10 and ICNTL11 C ==================================== LSCAL = (((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) .OR. ( & KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) ICNTL10 = ICNTL(10) ICNTL11 = ICNTL(11) C Values of ICNTL(11) out of range IF ((ICNTL11 .LT. 0).OR.(ICNTL11 .GE. 3)) THEN ICNTL11 = 0 IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) out of range' ENDIF CALL SMUMPS_SET_POSTPros ( & KEEP(1), ICNTL(1), NBRHS, MPG, PROKG, & ICNTL10, ICNTL11, POSTPros) C} -- end of test master END IF CALL MPI_BCAST(POSTPros,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) C We need the original matrix only in the case of C we want to perform IR or Error Analysis, i.e. if C POSTPros = TRUE MAT_ALLOC_LOC = 0 IF ( POSTPros ) THEN MAT_ALLOC_LOC = 1 C Check if the original matrix has been allocated. IF ( KEEP(54) .EQ. 0 ) THEN C The original matrix is centralized IF ( id%MYID .eq. MASTER ) THEN IF (KEEP(55).eq.0) THEN C Case of matrix assembled centralized IF (.NOT.associated(id%A) .OR. & (.NOT.associated(id%IRN)) .OR. & ( .NOT.associated(id%JCN))) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original centralized assembled', & ' matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ELSE C Case of matrix in elemental format IF (.NOT.associated(id%A_ELT).OR. & .NOT.associated(id%ELTPTR).OR. & .NOT.associated(id%ELTVAR)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original elemental matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ENDIF ENDIF !end master, centralized matrix ELSE C The original matrix is assembled distributed IF ( I_AM_SLAVE .AND. (id%KEEP8(29) .GT. 0_8) ) THEN C If MAT_ALLOC_LOC = 1 the local distributed matrix is C allocated, otherwise MAT_ALLOC_LOC = 0 IF ((.NOT.associated(id%A_loc)) .OR. & (.NOT.associated(id%IRN_loc)) .OR. & (.NOT.associated(id%JCN_loc))) THEN IF (PROK) WRITE(MP,'(A/,A,I5,I12)') & ' WARNING: original distributed matrix not allocated', & ' MPI rank, local nonzeros=', & id%MYID, id%KEEP8(29) MAT_ALLOC_LOC = 0 ENDIF ENDIF ENDIF ! end test allocation matrix (keep(54)) ENDIF ! POSTPros CALL MPI_REDUCE( MAT_ALLOC_LOC, MAT_ALLOC, 1, & MPI_INTEGER, & MPI_MIN, MASTER, id%COMM, IERR) IF ( POSTPros.and.(id%MYID .eq. MASTER) ) THEN C if postprocessing requested matrix must be allocated IF (MAT_ALLOC.EQ.0) THEN IF (KEEP(54).NE.0) THEN C Write on MPG this time (we wrote on MP before in C case of distributed matrix and wrote on MPG already C in case of centralized matrix) IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original distributed matrix is not allocated' ENDIF POSTPros = .FALSE. ICNTL11 = 0 ICNTL10 = 0 C Write a warning. IF ((ICNTL(10) .NE. 0) .AND. (ICNTL10 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0' ENDIF IF ((ICNTL(11) .EQ. 1).OR.(ICNTL(11) .EQ. 2) & .AND.(ICNTL11 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF ENDIF IF (POSTPros) THEN ALLOCATE(SAVERHS(id%N*NBRHS),stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Problem in solve: error allocating SAVERHS' ENDIF INFO(1) = -13 INFO(2) = id%N*NBRHS END IF NB_BYTES = NB_BYTES + int(size(SAVERHS),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C C Forbid entries in a-1, in case of null space computations c IF (KEEP(237).NE.0 .AND.KEEP(111).NE.0) THEN C Ignore ENTRIES IN A-1 in case we compute C vectors of the null space (KEEP(111)).NE.0.) C We should still allocate IRHS_SPARSE IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: KEEP(237) treated as if set to 0 (null space)' KEEP(237)=0 ENDIF C -- end of test master END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C -------------------------------------------------- C Broadcast information to have all processes do the C same thing (error analysis/iterative refinements/ C scaling/distribution of solution) C -------------------------------------------------- CALL MPI_BCAST(ICNTL10,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(ICNTL11,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(POSTPros,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) CALL MPI_BCAST(LSCAL,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) CALL MPI_BCAST(KEEP(237),1,MPI_INTEGER,MASTER, & id%COMM,IERR) #if ! defined(USE_OLD_SCALING) C ---------------------------------------------- C Initialize SCALING_LOC_FWD and SCALING_LOC_BWD C They corespond to all pivots factorized on a C given MPI process and point to a dummy array C of size 1 on the host of if no pivot was C factorized (KEEP(89))=0 C ---------------------------------------------- IF (LSCAL .AND. id%KEEP(89) .GT. 0) THEN IF (MTYPE .EQ. 1) THEN SCALING_LOC_FWD => id%ROWSCA_loc SCALING_LOC_BWD => id%COLSCA_loc ELSE SCALING_LOC_FWD => id%COLSCA_loc SCALING_LOC_BWD => id%ROWSCA_loc ENDIF ELSE ! includes non working master on which KEEP(89)=0 SCALING_LOC_FWD => RDUMMY_TARGET SCALING_LOC_BWD => RDUMMY_TARGET ENDIF C Remarks related to scalings: C * During postprocessing, one performs solves C with alternatively A and A^T, meaning that C SCALING_LOC_FWD and SCALING_LOC_BWD will C be redefined. C * In case of exploit sparsity, RHSINTR may C have less rows than ROWSCA_loc/COLSCA_loc. C SCALING_RHSINTR_FWD and SCALING_RHSINTR_BWD C will then be extracted from C SCALING_LOC_FWD and SCALING_LOC_BWD thanks C to the subroutine SMUMPS_SCALINGRHSINTR #endif C KEEP(248)==1 if not_NullSpace (KEEP(111)=0) C and sparse RHS on input (id%ICNTL(20)/KEEP(248)==1) C (KEEP(248)==1 implies KEEP(111) = 0, otherwise error was raised) C We cant thus isolate the case of C sparse RHS associated to Null space computation because C in this case preparation is different since C -we skip the forward step and C -the pattern of the RHS C of the bwd is related to null pivot indices found and not C to information contained in the sparse rhs input format. DO_PERMUTE_RHS = (KEEP(242).NE.0) C apply interleaving in parallel (FOR A-1 or Null space only) IF ( (id%NSLAVES.GT.1) .AND. (KEEP(243).NE.0) & ) THEN C -- Option to interleave RHS only makes sense when C -- A-1 option is on or Null space compution are on C (note also that KEEP(243).NE.0 only when PERMUTE_RHS is on) IF ((KEEP(237).NE.0).or.(KEEP(111).GT.0)) THEN INTERLEAVE_PAR= .TRUE. IF (KEEP(237).EQ.1) THEN IF (NRHS_NONEMPTY.LT.2*NBRHS) THEN INTERLEAVE_PAR= .FALSE. ENDIF ENDIF ELSE IF (PROKG) THEN write(MPG,*) ' Warning incompatible options ', & ' interleave RHS reset to false ' ENDIF ENDIF ENDIF CALL MUMPS_BUF_INIT( id%KEEP( 34 ), id%KEEP(151) ) C -------------------------------------- C Compute an upperbound of message size C for forward and backward solutions: C -------------------------------------- MSG_MAX_BYTES_SOLVE8 = int(( 4 + KEEP(133) ) * KEEP(34),8) + & int(KEEP(133)*KEEP(151),8) * int(NBRHS,8) & + int(16*KEEP(34),8) ! for request id, pointer to next + safety IF ( MSG_MAX_BYTES_SOLVE8 .GT. & int(huge(I4),8)) THEN INFO(1) = -18 C Max NBRHS to avoid overflow: INFO(2) = ( huge(I4) - & ( 16 + 4 + KEEP(133) ) * KEEP(34) ) / & ( KEEP(133) * KEEP(151) ) ENDIF IF (INFO(1) .LT.0 ) GOTO 111 MSG_MAX_BYTES_SOLVE = int(MSG_MAX_BYTES_SOLVE8) C ------------------------------------------ C Compute an upperbound of message size C for SMUMPS_GATHER_SOLUTION. Except C possibly on the non working host, it C should be smaller than MSG_MAX_BYTES_SOLVE C ------------------------------------------ IF (KEEP(237).EQ.0) THEN C Note that for SMUMPS_GATHER_SOLUTION LBUFR buffer should C be larger that MAX_inode(NPIV))*NBRHS + NPIV C which is covered by next formula since KMAX_246_247 is larger C than MAX_inode(NPIV)) C 2 integers packed (npiv and termination) C Note that MSG_MAX_BYTES_GTHRSOL < MSG_MAX_BYTES_SOLVE C so that it should not overflow KMAX_246_247 = max(KEEP(246),KEEP(247)) MSG_MAX_BYTES_GTHRSOL = ( 2 + KMAX_246_247 ) * KEEP(34) + & KMAX_246_247 * NBRHS * KEEP(149) ELSE IF (ICNTL21.EQ.0) THEN C Each message from a slave is of size max 4: C 2 integers : I,J C 1 complex : (Aij)-1 C 1 terminaison MSG_MAX_BYTES_GTHRSOL = ( 3 * KEEP(34) + KEEP(149) ) ELSE C Not needed in case of distributed solution and A-1 C because the entries of A −1 are C returned in RHS SPARSE on the host. MSG_MAX_BYTES_GTHRSOL = 0 ENDIF C The buffer is used both for solve and for SMUMPS_GATHER_SOLUTION LBUFR_BYTES = max(MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL) TSIZE = int(min(100_8*int(MSG_MAX_BYTES_GTHRSOL,8), & 10000000_8)) LBUFR_BYTES = max(LBUFR_BYTES,TSIZE) LBUFR = ( LBUFR_BYTES + KEEP(34) - 1 ) / KEEP(34) ALLOCATE (BUFR(LBUFR),stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ' Problem in solve: error allocating BUFR' ENDIF INFO(1) = -13 INFO(2) = LBUFR GOTO 111 ENDIF NB_BYTES = NB_BYTES + int(size(BUFR),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( I_AM_SLAVE .AND. id%NSLAVES .GT. 1 ) THEN C ------------------------------------------------------ C Dimension send buffer for small integers, e.g. TRACINE C ------------------------------------------------------ SMUMPS_LBUF_INT = ( 20 + id%NSLAVES * id%NSLAVES * 4 ) & * KEEP(34) CALL MUMPS_BUF_ALLOC_SMALL_BUF( SMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = SMUMPS_LBUF_INT IF ( LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating small Send buffer:IERR=',IERR END IF GOTO 111 END IF C C --------------------------------------- C Dimension cyclic send buffer for normal C messages, based on largest message C size during forward and backward solves C --------------------------------------- C Compute buffer size in BYTES (SMUMPS_LBUF) C using integer8 in SMUMPS_LBUF_8 C then convert it in integer4 and bound it to largest integer value C SMUMPS_LBUF_8 = & (int(MSG_MAX_BYTES_SOLVE,8)+2_8*int(KEEP(34),8))* & int(id%NSLAVES,8) C Avoid buffers larger than 100 Mbytes ... SMUMPS_LBUF_8 = min(SMUMPS_LBUF_8, 100000000_8) C ... as long as we can send messages to at least 3 C destinations simultaneously SMUMPS_LBUF_8 = max(SMUMPS_LBUF_8, & int((MSG_MAX_BYTES_SOLVE+2*KEEP(34)),8) * & int(min(id%NSLAVES,3),8) ) SMUMPS_LBUF_8 = SMUMPS_LBUF_8 + 2_8*int(KEEP(34),8) C Convert to integer and bound it to largest 32-bit integer C and suppress 10 integers (one should be enough!) C to enable computation of integer size. SMUMPS_LBUF_8 = min(SMUMPS_LBUF_8, & int(huge(I4),8) & - 10_8*int(KEEP(34),8) & ) SMUMPS_LBUF = int(SMUMPS_LBUF_8, kind(SMUMPS_LBUF)) CALL MUMPS_BUF_ALLOC_CB( SMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = SMUMPS_LBUF/KEEP(34) + 1 IF ( LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating Send buffer:IERR=', IERR END IF GOTO 111 END IF C C C -- end of I am slave ENDIF C IF ( POSTPros ) THEN C When Iterative refinement of error analysis requested C Allocate RHS_IR on slave processors C (note that on MASTER RHS_IR points to RHS) IF ( id%MYID .NE. MASTER ) THEN C ALLOCATE(RHS_IR(id%N),stat=IERR) NB_BYTES = NB_BYTES + int(size(RHS_IR),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( IERR .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) THEN WRITE(LP,*) 'ERROR while allocating RHS on a slave' ENDIF GOTO 111 END IF ELSE RHS_IR=>id%RHS ENDIF ENDIF C C Parallel A-1 or General sparse and C exploit sparsity between columns DO_NBSPARSE = ( ( (KEEP(237).NE.0).OR.(KEEP(235).NE.0) ) & .AND. & ( KEEP(497).NE.0 ) & ) IF ( I_AM_SLAVE ) THEN IF(DO_NBSPARSE) THEN c --- ALLOCATE outside loop RHS_BOUNDS is needed LPTR_RHS_BOUNDS = 2*KEEP(28) ALLOCATE(RHS_BOUNDS(LPTR_RHS_BOUNDS), STAT=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=LPTR_RHS_BOUNDS IF (LPOK) THEN WRITE(LP,*) 'ERROR while allocating RHS_BOUNDS on', & ' a slave' ENDIF GOTO 111 END IF NB_BYTES = NB_BYTES + & int(size(RHS_BOUNDS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) PTR_RHS_BOUNDS => RHS_BOUNDS ELSE LPTR_RHS_BOUNDS = 1 PTR_RHS_BOUNDS => IDUMMY_TARGET ENDIF ENDIF C -------------------------------------------------- IF ( I_AM_SLAVE ) THEN IF ((KEEP(221).EQ.2 .AND. KEEP(252).EQ.0)) THEN C -- RHSINTR must have been allocated in C -- previous solve step (with option KEEP(221)=1) IF (.NOT.associated(id%RHSINTR)) THEN INFO(1) = -35 INFO(2) = 1 GOTO 111 ENDIF C IF ((KEEP(248).EQ.0) .OR. (id%NRHS.EQ.1)) THEN C GLOB2LOC_RHS/SOL are meaningful and could even be reused IF (.NOT.associated(id%GLOB2LOC_RHS) ) ! .OR. ! & .NOT.(id%GLOB2LOC_SOL_ALLOC)) & THEN INFO(1) = -35 INFO(2) = 2 GOTO 111 ENDIF IF (.not.id%GLOB2LOC_SOL_ALLOC) THEN C GLOB2LOC_SOL that is kept from C previous call to solve must then (already) C point to id%GLOB2LOC_RHS id%GLOB2LOC_SOL => id%GLOB2LOC_RHS ENDIF ELSE C ---------------------- C Allocate GLOB2LOC_RHS/SOL C ---------------------- C The size of POSINRHSINTR arrays C does not depend on the block of RHS C GLOB2LOC_RHS/SOL are initialized in the loop of RHS IF (associated(id%GLOB2LOC_RHS)) THEN NB_BYTES = NB_BYTES - & int(size(id%GLOB2LOC_RHS),8)*K34_8 DEALLOCATE(id%GLOB2LOC_RHS) ENDIF ALLOCATE (id%GLOB2LOC_RHS(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 END IF NB_BYTES = NB_BYTES + & int(size(id%GLOB2LOC_RHS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%GLOB2LOC_SOL_ALLOC) THEN NB_BYTES = NB_BYTES - & int(size(id%GLOB2LOC_SOL),8)*K34_8 DEALLOCATE(id%GLOB2LOC_SOL) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF C IF ( (KEEP(50).EQ.0).OR.(KEEP(237).NE.0).OR. & (KEEP(212).NE.0) & ) THEN ALLOCATE (id%GLOB2LOC_SOL(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 END IF id%GLOB2LOC_SOL_ALLOC = .TRUE. NB_BYTES = NB_BYTES + & int(size(id%GLOB2LOC_SOL),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE C Do no allocate GLOB2LOC_SOL id%GLOB2LOC_SOL => id%GLOB2LOC_RHS id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF IF (KEEP(221).NE.2) THEN C -- only in the case of bwd after C -- fwd only (with or without Schur) C -- we have to keep "old" RHSINTR IF (associated(id%RHSINTR)) THEN NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25) = 0_8 id%LD_RHSINTR = 0 ENDIF ENDIF ENDIF C --------------------------- C Allocate local workspace C for the solve (SMUMPS_SOL_C) C --------------------------- LIWK_SOLVE = 2 * KEEP(28) + id%NA(1)+1 LIWK_PTRACB= KEEP(28) C KEEP(228)+1 temporary integer positions C will be needed in SMUMPS_SOL_S IF (KEEP(201).EQ.1) THEN LIWK_SOLVE = LIWK_SOLVE + KEEP(228) + 1 ELSE C Reserve 1 position to pass array of size 1 in routines LIWK_SOLVE = LIWK_SOLVE + 1 ENDIF ALLOCATE ( IWK_SOLVE(LIWK_SOLVE), & PTRACB(LIWK_PTRACB), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWK_SOLVE + LIWK_PTRACB*KEEP(10) GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWK_SOLVE,8)*K34_8 + & int(LIWK_PTRACB,8)*K34_8 *int(KEEP(10),8) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C array IWCB used temporarily to hold C indices of a front unpacked from a message C and to stack (potentially in a recursive call) C headers of size 2 positions of CB blocks. LIWCB = 20*NB_K133*2 + KEEP(133) ALLOCATE ( IWCB( LIWCB), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWCB GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWCB,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C C -- Code for a slave C ----------- C Subdivision C of array IS C ----------- LIW = KEEP(32) C Define a work array of size maximum global frontal C size (KEEP(133)) for the call to SMUMPS_SOL_C C This used to be of size id%N. ALLOCATE(SRW3(KEEP(133)), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=KEEP(133) GOTO 111 END IF NB_BYTES = NB_BYTES + int(KEEP(133),8)*K151_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ----------------- C End of slave code C ----------------- ELSE C I am the master with host not working C C LIW is used on master when calling C the routine SMUMPS_GATHER_SOLUTION. LIW=0 END IF C C Precompute inverse of UNS_PERM outside loop IF (allocated(UNS_PERM_INV)) DEALLOCATE(UNS_PERM_INV) UNS_PERM_INV_NEEDED_INMAINLOOP = .FALSE. IF ( ( id%MYID .eq. MASTER.AND.(KEEP(23).GT.0) .AND. & (MTYPE .NE. 1).AND.(KEEP(248).NE.0) & ) C Permute UNS_PERM on master only with C sparse RHS (KEEP(248).NE.0 ) when AT x = b is solved & .OR. ( KEEP(237).NE.0 .AND. KEEP(23).NE.0 ) C When A-1 is active and when the matrix is unsymmetric C and a column permutation has been applied (Max transversal) C then we have performed a C factorization of a column permuted matrix AQ = LU. C In this case, C the permuted entry must be used to select the target C entries for the BWD (note that a diagonal entry of A-1 C is not anymore a diagonal of AQ. Thus a diagonal C of A-1 does not correspond to the same path C in the tree during FWD and BWD steps when MAXTRANS is on C and permutation is not identity.) C Note that the inverse permutation C UNS_PERM_INV needs to be allocated on each proc C since it is used in SMUMPS_SOL_C routine for pruning. C It is allocated only once and its allocation has been C migrated outside the blocking on the right hand sides. & ) THEN UNS_PERM_INV_NEEDED_INMAINLOOP = .TRUE. ENDIF UNS_PERM_INV_NEEDED_BEFMAINLOOP = .FALSE. IF (KEEP(23) .GT. 0 .AND. MTYPE.EQ.1 .AND. ICNTL21.EQ.2) THEN UNS_PERM_INV_NEEDED_INMAINLOOP = .TRUE. ENDIF IF ( KEEP(23) .GT.0 .AND. & MTYPE .NE. 1 .AND. KEEP(248).EQ.-1 ) THEN C Similar to sparse RHS case, we need to modify IRHS_loc C indices in the distributed RHS case. However, we need C UNS_PERM_INV on all processors. But only before the C main loop on the RHS blocks. UNS_PERM_INV_NEEDED_BEFMAINLOOP = .TRUE. ENDIF C UNS_PERM_INV_NEEDED_ONSLAVES = .FALSE. IF ( UNS_PERM_INV_NEEDED_INMAINLOOP .OR. & UNS_PERM_INV_NEEDED_BEFMAINLOOP ) THEN C We need UNS_PERM_INV ALLOCATE(UNS_PERM_INV(id%N),stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 endif NB_BYTES = NB_BYTES + int(id%N,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.EQ.MASTER) THEN C Build inverse permutation DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I ENDDO ENDIF C ELSE ALLOCATE(UNS_PERM_INV(1), stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=1 GOTO 111 endif NB_BYTES = NB_BYTES + 1_8*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C 111 CONTINUE #if defined(V_T) CALL VTEND(glob_comm_ini,IERR) #endif C C Synchro point + Broadcast of errors C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C C UNS_PERM_INV needed on slaves: IF ( KEEP(23).NE.0 .AND. & ( KEEP(237).NE.0 .OR. & ( MTYPE.NE.1 .AND. KEEP(248).EQ.-1 ) .OR. & ( MTYPE.EQ.1 .AND. ICNTL21.EQ.2) & ) & ) THEN UNS_PERM_INV_NEEDED_ONSLAVES = .TRUE. ENDIF IF (UNS_PERM_INV_NEEDED_ONSLAVES) THEN C Broadcast UNS_PERM_INV CALL MPI_BCAST( UNS_PERM_INV,id%N,MPI_INTEGER,MASTER, & id%COMM,IERR ) ENDIF C ------------------------------- C BEGIN C Preparation for distributed RHS C ------------------------------- IF (I_AM_SLAVE .AND. KEEP(248).EQ.-1 & ) THEN C Distributed RHS case ALLOCATE(MAP_RHS_loc(max(id%Nloc_RHS,1)), stat=allocok) IF (allocok .GT. 0) THEN id%INFO(1)=-13 id%INFO(2)=max(id%Nloc_RHS,1) GOTO 20 ENDIF NB_BYTES = NB_BYTES + max(int(id%Nloc_RHS,8),1_8)*K34_8 ENDIF C MAP_RHS_loc will be built in the main C loop, when processing the first block. C It requires POSINRHSINTR to be built. BUILD_RHSMAPINFO = .TRUE. 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT.0 ) GOTO 90 C In case of Unsymmetric column permutation and C transpose system, use MUMPS internal indices C for IRHS_loc_PTR. Done before scaling since C scaling is on permuted matrix IF ( I_AM_SLAVE .AND. KEEP(23).GT.0 .AND. KEEP(248).EQ.-1 & .AND. MTYPE.NE.1 & ) THEN IF (id%Nloc_RHS .GT. 0) THEN ALLOCATE(IRHS_loc_PTR(id%Nloc_RHS),stat=allocok) IF (allocok.GT.0) THEN INFO(1)=-13 INFO(2)=id%Nloc_RHS GOTO 25 ENDIF IRHS_loc_PTR_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + max(int(id%Nloc_RHS,8),1_8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) DO I=1, id%Nloc_RHS IF (id%IRHS_loc(I).GE.1 .AND. id%IRHS_loc(I).LE.id%N) & THEN IRHS_loc_PTR(I)=UNS_PERM_INV(id%IRHS_loc(I)) ELSE C Keep track of out-of range entries IRHS_loc_PTR(I)=id%IRHS_loc(I) ENDIF ENDDO ENDIF ENDIF C Check if UNS_PERM_INV still needed C to free memory IF (UNS_PERM_INV_NEEDED_BEFMAINLOOP .AND. & .NOT. UNS_PERM_INV_NEEDED_INMAINLOOP) THEN NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 DEALLOCATE(UNS_PERM_INV) ALLOCATE(UNS_PERM_INV(1)) ! to posibly pass it as an argument NB_BYTES = NB_BYTES + K34_8 ENDIF #if defined(USE_OLD_SCALING) IF (LSCAL .AND. id%KEEP(248).EQ.-1 & ) THEN C Scaling done based on original indices C provided by user IF (MTYPE == 1) THEN C No transpose scaling_data_dr%SCALING=>id%ROWSCA ELSE C Transpose scaling_data_dr%SCALING=>id%COLSCA ENDIF CALL SMUMPS_SET_SCALING_LOC( scaling_data_dr, id%N, & IRHS_loc_PTR(1), id%Nloc_RHS, & id%COMM, id%MYID, I_AM_SLAVE, MASTER, & NB_BYTES, NB_BYTES_MAX, K16_8, LP, LPOK, & ICNTL(1), INFO(1) ) ENDIF #endif C ------------------------------- C END C Preparation for distributed RHS C ------------------------------- 25 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT.0 ) GOTO 90 C ------------------------------------- C BEGIN C Preparation for distributed solution C ------------------------------------- IF ( ICNTL21 .NE. 0 ) THEN C{ #if defined(USE_OLD_SCALING) IF (LSCAL) THEN C{ In case of scaling we will need to scale C back the sol. Put the values of the scaling C arrays needed to do that on each processor. IF (id%MYID.NE.MASTER) THEN IF (MTYPE == 1) THEN ALLOCATE(id%COLSCA(id%N),stat=allocok) ELSE ALLOCATE(id%ROWSCA(id%N),stat=allocok) ENDIF IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating temporary scaling array' ENDIF INFO(1)=-13 INFO(2)=id%N GOTO 37 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ! MYID .NE. MASTER 37 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data_sol%SCALING_LOC(max(1,id%KEEP(89))), & stat=allocok) IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating local scaling array' ENDIF INFO(1)=-13 INFO(2)=max(1,id%KEEP(89)) GOTO 38 ENDIF IF (ICNTL21.NE.0) THEN C Real entries for scaling NB_BYTES = NB_BYTES + int(max(1,id%KEEP(89)),8)*K16_8 ENDIF NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ! I_AM_SLAVE 38 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) THEN GOTO 90 ENDIF IF (MTYPE == 1) THEN CALL MPI_BCAST(id%COLSCA(1),id%N, & MPI_REAL,MASTER, & id%COMM,IERR) scaling_data_sol%SCALING=>id%COLSCA ELSE CALL MPI_BCAST(id%ROWSCA(1),id%N, & MPI_REAL,MASTER, & id%COMM,IERR) scaling_data_sol%SCALING=>id%ROWSCA ENDIF C} ENDIF ! LSCAL #endif IF ( ICNTL21.EQ.1 .AND. I_AM_SLAVE & ) THEN C -------------------------------- C Prepare ISOL_loc array #if defined(USE_OLD_SCALING) C and on the fly, scaling_data_sol #endif C -------------------------------- LIW_PASSED=max(1,LIW) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF (KEEP(89) .GT. 0) THEN CALL SMUMPS_DISTSOL_INDICES( MTYPE, id%ISOL_loc(1), & id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%IS(1), LIW_PASSED,id%MYID_NODES, & id%N, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES, #if defined(USE_OLD_SCALING) & scaling_data_sol, LSCAL, #endif C For checking only & (KEEP(248).EQ.-1), IRHS_loc_PTR(1), id%Nloc_RHS & ) ENDIF ENDIF ! I_AM_SLAVE #if defined(USE_OLD_SCALING) #endif #if defined(USE_OLD_SCALING) IF (id%MYID.NE.MASTER .AND. LSCAL) THEN C --------------------------------- C Local (small) scaling arrays have C been built, free temporary copies C --------------------------------- IF (MTYPE == 1) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ELSE DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF NB_BYTES = NB_BYTES - int(id%N,8)*K16_8 ENDIF #endif C} ENDIF ! ICNTL21 .NE. 0 IF (ICNTL21 .EQ.1) THEN C --------------------------------------------------- C Take into account unsymmetric permutation to modify C ISOL_loc, in case ISOL_loc is provided by MUMPS C --------------------------------------------------- IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN C Broadcast the unsymmetric permutation and C permute the indices in ISOL_loc IF (id%MYID.NE.MASTER) THEN ALLOCATE(id%UNS_PERM(id%N),stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=id%N GOTO 40 ENDIF ENDIF ENDIF C C ===================== ERROR handling and propagation ================ 40 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN CALL MPI_BCAST(id%UNS_PERM(1),id%N,MPI_INTEGER,MASTER, & id%COMM,IERR) IF (I_AM_SLAVE) THEN DO I=1, KEEP(89) id%ISOL_loc(I) = id%UNS_PERM(id%ISOL_loc(I)) ENDDO ENDIF IF (id%MYID.NE.MASTER) THEN DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF ENDIF ENDIF ! ICNTL(21)=1 C -------------------------------------- C Preparation for distributed solution C END C -------------------------------------- C --------------------------------------------- C In case of Schur, preparation for reduced RHS C --------------------------------------------- IF ( (KEEP(60).NE.0) .AND. & ( & ( KEEP(221) .EQ. 1 ) .OR. & ( KEEP(221) .EQ. 2 ) & ) & ) THEN C -- First compute MASTER_ROOT_IN_COMM proc number in C COMM_NODES on which is mapped the master of the root. IF (KEEP(46).EQ.1) THEN MASTER_ROOT_IN_COMM=MASTER_ROOT ELSE MASTER_ROOT_IN_COMM =MASTER_ROOT+1 ENDIF IF ( id%MYID .EQ. MASTER ) THEN C -------------------------------- C Avoid using LREDRHS when id%NRHS is C equal to 1, as was done for RHS C -------------------------------- IF (id%NRHS.EQ.1) THEN LD_REDRHS = id%KEEP(116) ELSE LD_REDRHS = id%LREDRHS ENDIF ENDIF IF (MASTER.NE.MASTER_ROOT_IN_COMM) THEN C -- Make available LD_REDRHS on MASTER_ROOT_IN_COMM C This will then be used to test if a single C message can be sent C (this is possible if LD_REDRHS=SIZE_SCHUR) IF ( id%MYID .EQ. MASTER ) THEN C -- send LD_REDRHS to MASTER_ROOT_IN_COMM C using COMM communicator CALL MPI_SEND(LD_REDRHS,1,MPI_INTEGER, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSEIF ( id%MYID.EQ.MASTER_ROOT_IN_COMM) THEN C -- recv LD_REDRHS CALL MPI_RECV(LD_REDRHS,1,MPI_INTEGER, & MASTER, 0, id%COMM,STATUS,IERR) ENDIF C -- other procs not concerned ENDIF ENDIF C IF ( KEEP(248)==1 & ) THEN ! Sparse RHS (A-1 or general sparse) ! JBEG_RHS - current starting column within A-1 or sparse rhs ! set in the loop below and used to obtain the ! global index of the column of the sparse RHS ! Also used to get index in global permutation. ! It also allows to skip empty columns; JEND_RHS = 0 ! last column in current blockin A-1 C C Compute and apply permutations IF (DO_PERMUTE_RHS) THEN C Allocate PERM_RHS ALLOCATE(PERM_RHS(id%NRHS),stat=allocok) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = id%NRHS GOTO 109 ENDIF NB_BYTES = NB_BYTES + int(id%NRHS,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.EQ.MASTER) THEN C PERM_RHS is computed on MASTER, it might be modified C in case of interleaving and will thus be distributed C (BCAST) to all slaves only later. C Compute PERM_RHS C on output: PERM_RHS(k) = i means that i is the kth column C to be processed IF (KEEP(237).EQ.0) THEN C Permute RHS : case of GS (General Sparse) RHS C IRHS_SPARSE is of size at least NZ_RHS > 0 C since all this is skipped when NZ_RHS=0. So C accessing IRHS_SPARSE(1) is ok. CALL SMUMPS_PERMUTE_RHS_GS( & LP, LPOK, PROKG, MPG, KEEP(242), & id%SYM_PERM(1), id%N, id%NRHS, & id%IRHS_PTR(1), id%NRHS+1, & id%IRHS_SPARSE(1), id%NZ_RHS, & PERM_RHS, IERR) IF (IERR.LT.0) THEN INFO(1) = -9999 INFO(2) = IERR GOTO 109 ! propagate error ENDIF ELSE C Case of A-1 : C We compute the permutation of the RHS (sparse matrix) C (to compute all inverse entries) C We apply permutation to IRHS_SPARSE ONLY. C Note NRHS_NONEMPTY holds the nb of non empty columns C in A-1. STRAT_PERMAM1 = KEEP(242) CALL SMUMPS_PERMUTE_RHS_AM1 & (STRAT_PERMAM1, id%SYM_PERM(1), & id%IRHS_PTR(1), id%NRHS+1, & PERM_RHS, id%NRHS, & IERR & ) ENDIF ENDIF ENDIF ENDIF C C Note that within SMUMPS_SOL_C, PERM_RHS could be used C for A-1 case (with DO_PERMUTE_RHS OR INTERLEAVE_RHS C being tested) to get the column index for the C original matrix of RHS (column index in A-1) C of the permuted columns that have been selected. C PERM_RHS is also used in SMUMPS_GATHER_SOLUTION C in case of sparse RHS awith DO_PERMUTE_RHS. C C Allocate PERM_RHS of size 1 if not allocated IF (.NOT. allocated(PERM_RHS)) THEN ALLOCATE(PERM_RHS(1),stat=allocok) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = 1 GOTO 109 ENDIF NB_BYTES = NB_BYTES + int(size(PERM_RHS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C Propagate errors 109 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 c -------------------------- c -------------------------- IF (id%NSLAVES .EQ. 1) THEN C{ - In case of NS/A-1 we may want to permute RHS C - for NS thus is to apply permutation to PIVNUL_LIST C - before starting loop of NBRHS IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN C NOTE: C when host not working both master and slaves have C in this case the complete list WRITE(*,*) id%MYID, ':INTERNAL ERROR 1 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF ! End Permute_RHS C} ELSE IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 2 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() C ENDIF ! End DO_PERMUTE_RHS IF (INTERLEAVE_PAR.AND. (KEEP(111).NE.0)) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 3 : ', & ' INTERLEAVE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF IF (INTERLEAVE_PAR.AND.KEEP(111).EQ.0 & ) THEN C - A-1 + Interleave: C permute RHS on master IF (id%MYID.EQ.MASTER) THEN C -- PERM_RHS must have been already set or initialized C -- it is then modified in next routine SIZE_WORKING = id%IPTR_WORKING(id%NPROCS+1)-1 SIZE_IPTR_WORKING = id%NPROCS+1 CALL SMUMPS_INTERLEAVE_RHS_AM1( & PERM_RHS, id%NRHS, & id%IPTR_WORKING(1), SIZE_IPTR_WORKING, & id%WORKING(1), SIZE_WORKING, & id%IRHS_PTR(1), & id%STEP(1), id%SYM_PERM(1), id%N, NBRHS, & id%PROCNODE_STEPS(1), KEEP(28), id%NSLAVES, & KEEP(199), & KEEP(493).NE.0, & KEEP(495).NE.0, KEEP(496), PROKG, MPG & ) ENDIF ! End Master ENDIF ! End A-1 and INTERLEAVE_PAR C ------------- ENDIF ! End Parallel Case c -------------------------- c IF (DO_PERMUTE_RHS.AND.(KEEP(111).EQ.0)) THEN C --- Distribute PERM_RHS before loop of RHS C --- (with null space option PERM_RHS is not allocated / needed C to permute the null column pivot list) CALL MPI_BCAST(PERM_RHS(1), & id%NRHS, & MPI_INTEGER, & MASTER, id%COMM,IERR) ENDIF C L0-threads to be activated iff KEEP(401)=1 and KEEP(400)>0 IF (KEEP(401) .EQ. 1) THEN C L0-threads was requested for solve phase C and will be effective only if KEEP(400) >0 C which indicates that L0-threads was C performed during analysis+factorization IF ( KEEP(400) .GT. 0 .AND. KEEP(369).EQ.0 ) THEN C{ Check if number of threads is consistent with C the one used during factorization for all procs C Note that if KEEP(369)>0 C KEEP(400) was set based on C KEEP(369) and KEEP(381) so that C omp_set_num_threads(KEEP(400)) will be called C explicitly before L0_OMP section C and KEEP(400) cannot be check here in this way C NOMP = 1 !$ NOMP=omp_get_max_threads() IF (KEEP(400).NE.NOMP) THEN C NOMP should be the one from analysis id%INFO(1) = -58 id%INFO(2) = KEEP(400) IF (LPOK) WRITE(LP,'(A,A,I5,A,I5)') &" FAILURE DETECTED IN SOLVE: #threads for multithreaded", &" tree parallelism changed from",KEEP(400)," at analysis to", & NOMP ENDIF C} ENDIF C error check CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 C} ENDIF IF (KEEP(400) .GT. 0) THEN CALL MUMPS_SOL_L0OMP_LI(KEEP(400)) ENDIF C ============================== C MAIN LOOP: C BLOCKING ON the number of RHS C We work on a maximum of NBRHS at a time. C the leading dimension of RHS is id%LRHS on master C and is set to N on slaves C ============================== C We may want to allow to have NBRHS that varies C this is typically the case when a partitionning of C the right hand side is performed and leads to C irregular partitions. C We only have to be sure that the size of each partition C is smaller than NBRHS. BEG_RHS=1 DO WHILE (BEG_RHS.LE.NRHS_NONEMPTY) C { CALL MUMPS_STOP_ON_USER_REQUEST( id%KEEP, id%KEEP8, id%ICNTL, & id%INFO, id%MYID ) CALL MUMPS_PROPINFO( id%ICNTL, id%INFO, id%COMM, id%MYID ) IF (id%INFO(1). LT. 0) GOTO 90 C ========================== C -- NBRHS : Original block size C -- BEG_RHS : Column index of the first RHS in the list of C non empty RHS (RHS_loc) to C be processed during this iteration C -- NBRHS_EFF : Effective block size at current iteration C that will be set to nb of contiguous non empty C columns C In case of sparse RHS (KEEP(248)==1) NBRHS_EFF only refers to C non-empty columns and is used to compute NBCOL_INBLOC C -- NBCOL_INBLOC : the number of columns of sparse RHS needed C to get NBRHS_EFF non empty columns columns of C sparse RHS processed at each step C NBRHS_EFF = min(NRHS_NONEMPTY-BEG_RHS+1, NBRHS) C C Sparse RHS C Free space and reset pointers if needed IF (IRHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_SPARSE_COPY),8)*K34_8 DEALLOCATE(IRHS_SPARSE_COPY) IRHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_SPARSE_COPY) ENDIF IF (IRHS_PTR_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_PTR_COPY),8)*K34_8 DEALLOCATE(IRHS_PTR_COPY) IRHS_PTR_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_PTR_COPY) ENDIF IF (RHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(RHS_SPARSE_COPY),8)*K35_8 DEALLOCATE(RHS_SPARSE_COPY) RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_SPARSE_COPY) ENDIF C C =========================================================== C Set LD_RHS and IBEG for the accesses to id%RHS (in cases C id%RHS is accessed). Remark that IBEG might still be C overwritten later, in case of general sparse right-hand side C and centralized solution to skip empty columns C =========================================================== IF ( C slave procs & ( id%MYID .NE. MASTER ) C even on master when RHS not allocated & .or. C Case of Master working but with distributed sol and C ( sparse RHS or null space ) C -- Allocate not needed on host not working & ( I_AM_SLAVE .AND. id%MYID .EQ. MASTER .AND. & ICNTL21 .NE.0 .AND. & ( KEEP(248).ne.0 .OR. KEEP(221).EQ.2 & .OR. KEEP(111).NE.0 ) & ) & .or. C Case of Master and C (compute entries of INV(A)) C Even when I am a master with host not working I C am in charge of gathering solution to scale it C and to copy it back in the sparse RHS format & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) C & ) THEN LD_RHS = id%N IBEG = 1 ELSE ! (id%MYID .eq. MASTER) IF ( associated(id%RHS) ) THEN C Leading dimension of RHS on master is id%LRHS LD_RHS = max(id%LRHS, id%N) ELSE C --- LRHS might not be defined (dont use it) LD_RHS = id%N ENDIF IBEG = int(BEG_RHS-1,8) * int(LD_RHS,8) + 1_8 ENDIF C JBEG_RHS might also be used in DISTRIBUTED_SOLUTION C even when RHS is not sparse on input. In this case, C there are no empty columns. (If RHS is sparse JBEG_RHS C is overwritten). JBEG_RHS = BEG_RHS C ========================================== C Shift empty columns in case of sparse RHS C ========================================== IF ( (id%MYID.EQ.MASTER) .AND. & KEEP(248)==1 & ) THEN C update position of JBEG_RHS on first non-empty C column of this block JBEG_RHS = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( id%IRHS_PTR(PERM_RHS(JBEG_RHS)) .EQ. & id%IRHS_PTR(PERM_RHS(JBEG_RHS)+1) ) C Empty column IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) & ) THEN C General sparse RHS (NOT A-1) and centralized solution C Set to zero part of the C solution corresponding to empty columns DO I=1, id%N id%RHS(int(PERM_RHS(JBEG_RHS) -1,8)*int(LD_RHS,8)+ & int(I,8)) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ELSE DO WHILE( id%IRHS_PTR(JBEG_RHS) .EQ. & id%IRHS_PTR(JBEG_RHS+1) ) IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) & ) THEN C Case of general sparse RHS (NOT A-1) and C centralized solution: set to zero part of C the solution corresponding to empty columns DO I=1, id%N id%RHS(int(JBEG_RHS -1,8)*int(LD_RHS,8) + & int(I,8)) = ZERO ENDDO ENDIF IF (KEEP(221).EQ.1) THEN IF (KEEP(60).NE.0) THEN C Fwd with Schur: reduced RHS set to ZERO DO I = 1, id%SIZE_SCHUR id%REDRHS(int(JBEG_RHS-1,8)*int(LD_REDRHS,8) + & int(I,8)) = ZERO ENDDO ENDIF ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR C Count nb of RHS columns skipped: useful for C * SMUMPS_DISTRIBUTED_SOLUTION to reset those C columns to zero. C * in case of reduced right-hand side, to set C corresponding entries of RHSINTR to 0 after C forward phase. NB_RHSSKIPPED = JBEG_RHS - (JEND_RHS + 1) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0) & .AND. (ICNTL21.EQ.0)) & THEN ! case of general sparse rhs with centralized solution, !set IBEG to shifted columns ! (after empty columns have been skipped) IBEG = int(JBEG_RHS-1,8) * int(LD_RHS,8) + 1_8 ENDIF ENDIF ! of if (id%MYID.EQ.MASTER) .AND. KEEP(248)==1 CALL MPI_BCAST( JBEG_RHS, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C C Shift on REDRHS in reduced RHS functionality C IF (id%MYID.EQ.MASTER .AND. KEEP(221).NE.0 & .AND. KEEP(60).NE.0 ) THEN C Initialize IBEG_REDRHS C Note that REDRHS always has id%NRHS Colmuns IBEG_REDRHS= int(JBEG_RHS-1,8)*int(LD_REDRHS,8) + 1_8 ELSE IBEG_REDRHS=-142424_8 ! Should not be used ENDIF C C ===================== C BEGIN C Prepare RHS on master C #if defined(V_T) CALL VTBEGIN(perm_scal_ini,IERR) #endif IF (id%MYID .eq. MASTER) THEN C{ ====================== IF (KEEP(248)==1 & ) THEN C{ ====================== C C Sparse RHS format ( A-1 or sparse centralized input format) C is provided as input by the user (IRHS_SPARSE ...) C -------------------------------------------------- C Compute NZ_THIS_BLOCK and NBCOL_INBLOC C where C NZ_THIS_BLOCK is defined C as the number of entries in the next NBRHS_EFF C non empty columns (note that since they might be permuted C then the following formula is not always valid: C NZ_THIS_BLOCK=id%IRHS_PTR(BEG_RHS+NBRHS_EFF)- C & id%IRHS_PTR(BEG_RHS) C anyway NBCOL_INBLOC also need be computed so going through C columns one at a time is needed. C NBCOL = 0 NBCOL_INBLOC = 0 NZ_THIS_BLOCK = 0 C With exploit sparsity we skip empty columns up to reaching C the first non empty column; then we process a block of C maximum size NBRHS_EFF except if we reach another empty C column. (We are not sure to have a copy allocated C and thus cannot compress on the fly, as done naturally C for A-1) C For A-1 we process NBRHS_EFF non empty columns C in the bloc that contains NBCOL_INBLOC columns C (empty+non empty) STOP_AT_NEXT_EMPTY_COL = .FALSE. DO I=JBEG_RHS, id%NRHS NBCOL_INBLOC = NBCOL_INBLOC +1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN C PERM_RHS(k) = i means that i is the kth C column to be processed C PERM_RHS should also be defined for C empty columns i in A-1 (PERM_RHS(K) = i) COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) ELSE COLSIZE = id%IRHS_PTR(I+1) - id%IRHS_PTR(I) ENDIF IF ((.NOT.STOP_AT_NEXT_EMPTY_COL).AND.(COLSIZE.GT.0).AND. & (KEEP(237).EQ.0)) THEN C -- set STOP_NEXT_EMPTY_COL only for general C -- sparse case (not AM-1) STOP_AT_NEXT_EMPTY_COL =.TRUE. ENDIF IF (COLSIZE.GT.0 C{ & ) THEN NBCOL = NBCOL+1 NZ_THIS_BLOCK = NZ_THIS_BLOCK + COLSIZE C} ELSE IF (STOP_AT_NEXT_EMPTY_COL) THEN C{ We have reached an empty column with already selected non empty C columns: reduce block size to non empty columns reached so far. NBCOL_INBLOC = NBCOL_INBLOC -1 C Note that NBRHS_EFF is udated only on master NBRHS_EFF = NBCOL EXIT C} ENDIF IF (NBCOL.EQ.NBRHS_EFF) EXIT ENDDO IF (NZ_THIS_BLOCK.EQ.0) THEN WRITE(*,*) " Internal Error 16 in sol driver NZ_THIS_BLOCK=", & NZ_THIS_BLOCK CALL MUMPS_ABORT() ENDIF C IF (NBCOL.NE.NBRHS_EFF.AND. (KEEP(237).NE.0) & .AND.KEEP(221).NE.1) THEN C With exploit sparsity for general sparse RHS (Not A-1) C we skip empty rows up to reaching C the first non empty column; then we process a block of C maximum size NBRHS_EFF except if we reach another empty C column. (We are not sure to have a copy allocated C and thus cannot compress on the fly, as done naturally C for A-1). Thus NBCOL might be smaller than NBRHS_EFF WRITE(6,*) ' Internal Error 8 in solution driver ', & NBCOL, NBRHS_EFF call MUMPS_ABORT() ENDIF C ------------------------------------------------------------- C IF (NZ_THIS_BLOCK .NE. 0) THEN C ----------------------------------------------------------- C We recall that C NBCOL_INBLOC is the number of columns of sparse RHS needed C to get NBRHS_EFF non empty columns: ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NBCOL_INBLOC+1 GOTO 30 endif IRHS_PTR_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 C ----------------------------------------------------------- C Initialize IRHS_PTR_COPY C compute local copy (compressed) of id%IRHS_PTR on Master IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 IRHS_PTR_COPY(J) = IPOS COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) IPOS = IPOS + COLSIZE ENDDO ELSE IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 IRHS_PTR_COPY(J) = IPOS COLSIZE = id%IRHS_PTR(I+1) & - id%IRHS_PTR(I) IPOS = IPOS + COLSIZE ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR IRHS_PTR_COPY(NBCOL_INBLOC+1)= IPOS IF ( IPOS-1 .NE. NZ_THIS_BLOCK ) THEN WRITE(*,*) "Error in compressed copy of IRHS_PTR" IERR = 99 call MUMPS_ABORT() ENDIF C ----------------------------------------------------------- C IRHS_SPARSE : do a copy or point to the original indices C C Check whether IRHS_SPARSE_COPY need be allocated IF (KEEP(23) .NE. 0 .and. MTYPE .NE. 1) THEN C AP = LU and At x = b ==> b need be permuted ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK) & ,stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 30 endif IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN C Columns are not contiguous and need be copied one by one C IRHS_SPARSE_COPY will hold a copy of contiguous permuted C columns so an explicit copy is needed. C IRHS_SPARSE_COPY is also allways allocated with A-1, C to enable receiving during mumps_gather_solution C . on the master in any order. ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) IF (allocok .GT.0 ) THEN IERR = 99 GOTO 30 ENDIF IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ENDIF C C Initialize IRHS_SPARSE_COPY IF (IRHS_SPARSE_COPY_ALLOCATED) THEN IF ( DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ) THEN IPOS = 1 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) DO K=0,COLSIZE-1 IRHS_SPARSE_COPY(IPOS+K) = & id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K) ENDDO IPOS = IPOS + COLSIZE ENDDO ELSE DO K=1,NZ_THIS_BLOCK IRHS_SPARSE_COPY(K) = id%IRHS_SPARSE( & id%IRHS_PTR(JBEG_RHS)+K-1) ENDDO ENDIF ELSE IRHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => & id%IRHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ENDIF #if defined(USE_OLD_SCALING) C Centralized scaling: perform scaling on master C in RHS_SPARSE_COPY IF (LSCAL.OR.DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN #else IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN #endif C if columns of the RHS are C permuted then a copy of RHS_SPARSE is needed. C Also always allocated with A-1, c to enable receiving during mumps_gather_solution C on the master in any order. C ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 30 ENDIF RHS_SPARSE_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE IF ( KEEP(248)==1 ) THEN RHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => id%RHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ELSE RHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => id%RHS_SPARSE(id%IRHS_PTR(BEG_RHS): & id%IRHS_PTR(BEG_RHS)+NZ_THIS_BLOCK-1) ENDIF ENDIF IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) THEN IF (id%KEEP(237).NE.0) THEN C --initialized to one #if defined(USE_OLD_SCALING) C it might be modified if scaling is on (one first entry C in each col is scaled) RHS_SPARSE_COPY = ONE #else C Local scalings are used: RHSINTR is initialized C directly on the workers and RHS_SPARSE_COPY will C only be used during SMUMPS_GATHER_SOLUTION_AM1. #endif ELSE C -- Columns are not contiguous and need be copied one by one #if defined(USE_OLD_SCALING) C -- This need not be done if scaling is on because it C -- will done and scaled later. IF (.NOT. LSCAL) THEN #endif 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 DO K=0, COLSIZE-1 RHS_SPARSE_COPY(IPOS+K) = & id%RHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K) ENDDO IPOS = IPOS + COLSIZE ENDDO #if defined(USE_OLD_SCALING) ENDIF #endif ENDIF ENDIF C ========================= IF (KEEP(23) .NE. 0) THEN C ========================= * maximum transversal was performed IF (MTYPE .NE. 1) THEN * At x = b is asked while * we have AP = LU where P is the column permutation * due to max trans. * Therefore we need to modify rhs: * b' = P-1 b (P-1=Pt) * Apply column permutation to the right hand side RHS * Column J of the permuted matrix corresponds to * column PERMW(J) of the original matrix. * C ========== C SPARSE RHS : permute indices rather than values C ========== C Solve with At X = B should never occur for A-1 IPOS = 1 DO I=1, NBCOL_INBLOC C Note that: (i) IRHS_PTR_COPY is compressed; C (ii) columns might have been permuted COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) DO K = 1, COLSIZE JPERM = UNS_PERM_INV(IRHS_SPARSE_COPY(IPOS+K-1)) IRHS_SPARSE_COPY(IPOS+K-1) = JPERM ENDDO IPOS = IPOS + COLSIZE ENDDO ENDIF ! MTYPE.NE.1 ENDIF ! KEEP(23).NE.0 ENDIF ! NZ_THIS_BLOCK .NE. 0 C} ----- ENDIF ! ============ KEEP(248)==1 C} ----- ENDIF ! (id%MYID .eq. MASTER) C C ===================== ERROR handling and propagation ================ 30 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C C NBCOL_INBLOC depends on loop IF (KEEP(248)==1 & ) THEN CALL MPI_BCAST( NBCOL_INBLOC,1, MPI_INTEGER, & MASTER, id%COMM,IERR) ELSE NBCOL_INBLOC = NBRHS_EFF ENDIF JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN C Only case (in previous block) for which C NBRHS_EFF has been modified only on master ! case of general sparse: in case of empty columns ! modifed version of ! NBRHS_EFF need be broadcasted since it is used ! to update BEG_RHS at the end of the DO WHILE CALL MPI_BCAST( NBRHS_EFF,1, MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(NB_RHSSKIPPED,1,MPI_INTEGER,MASTER, & id%COMM,IERR) ENDIF IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0) & .AND.(KEEP(221).NE.2 ).AND.(KEEP(248).EQ.1) ) THEN C{ ---------------------------- C -- SPARSE RIGHT-HAND-SIDE C ---------------------------- CALL MPI_BCAST( NZ_THIS_BLOCK,1, MPI_INTEGER, & MASTER, id%COMM,IERR) IF (id%MYID.NE.MASTER .and. NZ_THIS_BLOCK.NE.0) THEN ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 45 endif IRHS_SPARSE_COPY_ALLOCATED=.TRUE. C RHS_SPARSE_COPY is broadcasted C for A-1 even if on the slaves the initialisation of the RHS C could be only based on the pattern. Doing so we C broadcast the scaled version of the RHS (scaling arrays C that are not available on slaves). ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 45 endif RHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*(K34_8+K35_8) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NBCOL_INBLOC+1 GOTO 45 endif IRHS_PTR_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C C ===================== ERROR handling and propagation ================ 45 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== IF (NZ_THIS_BLOCK > 0) THEN CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(IRHS_PTR_COPY(1), & NBCOL_INBLOC+1, & MPI_INTEGER, & MASTER, id%COMM,IERR) ENDIF C} ENDIF C C ========================================================= C INITIALIZE C - nodes_FWD and nodes_BWD C ========================================================= IF (FIRST_CALL_NODES_FWD_BWD) THEN C{ First time SMUMPS_NODES_FWD_BWD_SIZE_FILL C is called allocated Pruned_Sons_FWD IF (allocated(Pruned_Sons_FWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_FWD) * K34_8 DEALLOCATE(Pruned_Sons_FWD) ENDIF IF (allocated(Pruned_Sons_BWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_BWD) * K34_8 DEALLOCATE(Pruned_Sons_BWD) ENDIF ALLOCATE (Pruned_Sons_FWD(KEEP(28)), & Pruned_Sons_BWD(KEEP(28)), & stat=allocok) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)= 2*KEEP(28) ELSE NB_BYTES = NB_BYTES + & int(size(Pruned_Sons_FWD),8)*K34_8 + & int(size(Pruned_Sons_BWD),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C} ENDIF C ===================== ERROR handling and propagation ============== CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C===================================================================== C Reset FIRST_CALL_NODES_FWD_BWD for not allocating C (Pruned_Sons_FWD/BWD within loop) FIRST_CALL_NODES_FWD_BWD = .FALSE. C IF (CALL_NODES_FWD_BWD) THEN C{ fill = .FALSE. nodes_FWD_PTR => IDUMMY_TARGET Lnodes_FWD_PTR = 1 nodes_BWD_PTR => IDUMMY_TARGET Lnodes_BWD_PTR = 1 CALL SMUMPS_NODES_FWD_BWD_SIZE_FILL ( & fill, id%ICNTL(1), & id%N, id%KEEP(28), id%KEEP(1), & id%STEP(1), id%Step2node(1), & IRHS_loc_PTR(1), id%Nloc_RHS, & IRHS_PTR_COPY(1), NBCOL_INBLOC, IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, PERM_RHS, size(PERM_RHS), JBEG_RHS, & UNS_PERM_INV, size(UNS_PERM_INV), ! size 1 if not used & ICNTL21, & id%MYID, id%COMM, & id%INFO, & Pruned_Sons_FWD, Pruned_Sons_BWD, & Lnodes_FWD, Lnodes_BWD & , nodes_FWD_PTR(1), nodes_BWD_PTR(1) & , Lnodes_FWD_PTR, Lnodes_BWD_PTR & ) C C ALLOCATE nodes_FWD and nodes_BWD if needed C IF (Lnodes_FWD.GT.0) THEN C NBT is inout in MUMPS_REALLOC and should be initialized. NBT = 0 CALL MUMPS_REALLOC(nodes_FWD, Lnodes_FWD, id%INFO, LP, & FORCE=.FALSE., & STRING='nodes_FWD', MEMCNT=NBT, ERRCODE=-13) IF (INFO(1).LT.0) GOTO 46 C nodes_FWD_PTR => nodes_FWD Lnodes_FWD_PTR = Lnodes_FWD NB_BYTES = NB_BYTES + NBT NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE nodes_FWD_PTR => IDUMMY_TARGET Lnodes_FWD_PTR = 1 ENDIF IF (Lnodes_BWD.GT.0) THEN C NBT is inout in MUMPS_REALLOC and should be initialized. NBT = 0 CALL MUMPS_REALLOC(nodes_BWD, Lnodes_BWD, id%INFO, LP, & FORCE=.FALSE., & STRING='nodes_BWD', MEMCNT=NBT, ERRCODE=-13) IF (INFO(1).LT.0) GOTO 46 C nodes_BWD_PTR => nodes_BWD Lnodes_BWD_PTR = Lnodes_BWD NB_BYTES = NB_BYTES + NBT NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE nodes_BWD_PTR => IDUMMY_TARGET Lnodes_BWD_PTR = 1 ENDIF C C ===================== ERROR handling and propagation ============== 46 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C===================================================================== IF (Lnodes_FWD.GT.0 .OR. Lnodes_BWD.GT.0) THEN C{ C we build nodes_FWD_PTR and/or nodes_BWD_PTR C that will be used to prune flops C and even if one of the steps FWD/BWD does not C lead to pruning (in this case C POSTINRHS_COMP will not benefit from pruning). fill = .TRUE. CALL SMUMPS_NODES_FWD_BWD_SIZE_FILL ( & fill, id%ICNTL(1), & id%N, id%KEEP(28), id%KEEP(1), & id%STEP(1), id%Step2node(1), & IRHS_loc_PTR(1), id%Nloc_RHS, & IRHS_PTR_COPY(1), NBCOL_INBLOC, IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, PERM_RHS, size(PERM_RHS), JBEG_RHS, & UNS_PERM_INV, size(UNS_PERM_INV), ! size 1 if not used & ICNTL21, & id%MYID, id%COMM, & id%INFO, & Pruned_Sons_FWD, Pruned_Sons_BWD, & Lnodes_FWD, Lnodes_BWD & , nodes_FWD_PTR(1), nodes_BWD_PTR(1) & , Lnodes_FWD_PTR, Lnodes_BWD_PTR & ) C} ENDIF C ------------------------------------------------ C Update CALL_NODES_FWD_BWD and free workspace if C not used again in loop of RHS C ------------------------------------------------ IF ( & (KEEP(237) .NE. 0).OR. ! AM1 & ((KEEP(235) .NE. 0).AND.KEEP(248).NE.-1) ! GS & ) THEN C target nodes for chain pruning C need be updated in case of AM1 or General Sparse CALL_NODES_FWD_BWD = .TRUE. ELSE C all other cases including C distributed RHS and distributed solution CALL_NODES_FWD_BWD = .FALSE. ENDIF IF (.NOT. CALL_NODES_FWD_BWD & ) THEN C Not needed anymore in the loop of RHS IF (allocated(Pruned_Sons_FWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_FWD) * K34_8 DEALLOCATE(Pruned_Sons_FWD) ENDIF IF (allocated(Pruned_Sons_BWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_BWD) * K34_8 DEALLOCATE(Pruned_Sons_BWD) ENDIF C ELSE C deallocate later ENDIF C} ENDIF C ========================================================= C INITIALIZE C - GLOB2LOC_RHS/SOL, RHSINTR and related data C - For distributed RHS, initialize RHSMAPINFO (at 1st block) C ========================================================= C C Fwd in facto: in this case only POSINRHSINTR need be computed C C (GLOB2LOC_RHS/SOL indirection arrays should C have been allocated once outside loop) C Compute size of RHSINTR since it might depend C on the process index and of the sparsity of the RHS C if it is exploited. C Initialize GLOB2LOC_RHS/SOL C C Note that id%LD_RHSINTR and id%KEEP8(25) C are not set on the host in this routine in C the case of a non-working host. C Note that POSINRHSINTR is now always computed in SOL_DRIVER C at least during the first block of RHS when sparsity of RHS C is not exploited. C ------------------------------- C INITTIALZE GLOB2LOC_RHS/SOL C ------------------------------- C C next block ok for Schur only IF ( KEEP(221).EQ.2 .AND. KEEP(252).EQ.0 & .AND. (KEEP(248).NE.1 .OR. (id%NRHS.EQ.1)) & ) THEN C Reduced RHS (Schur feature) was already computed during C a previous forward step AND is valid. C By valid we mean: C -no forward in facto (KEEP(252)==0) during which C POSINRHSINTR was not computed C AND C -no exploit sparsity with multiple RHS C because in this case POSINRHSINTR would C be valid only for the last block processed during fwd. C In those cases since we only perform the backward step, c we do not need to compute POSINRHSINTR BUILD_POSINRHSINTR = .FALSE. ENDIF C ------------------------ C INITIALIZE POSINRHSINTR C ------------------------ IF (BUILD_POSINRHSINTR) THEN C{ -- we first set MTYPE_LOC and C -- reset BUILD_POSINRHSINTR for next iteration in loop C C general case only POSINRHSINTR is computed BUILD_POSINRHSINTR = .FALSE. ! POSINRHSINTR does not change between blocks MTYPE_LOC = MTYPE C IF ( (KEEP(111).NE.0) .OR. (KEEP(237).NE.0) .OR. & (KEEP(252).NE.0) ) THEN C IF (KEEP(111).NE.0) THEN C -- in the context of null space, we need to C -- build RHSINTR to skip SOL_R. Therefore C -- we need to know for each concerned C -- row index its position in C -- RHSINTR C We use row indices, as these are the ones that C were used to detect zero pivots during factorization. C GLOB2LOC_RHS will allow to find the (row) index of a C zero in RHSINTR before calling SMUMPS_SOL_S. Then C SMUMPS_SOL_S uses column indices to build the solution C (corresponding to null space vectors) MTYPE_LOC = 1 ELSE IF (KEEP(252).NE.0) THEN C -- Fwd in facto: since fwd is skipped we need to build POSINRHSINTR MTYPE_LOC = 1 ! (no transpose) ELSE C -- A-1 only MTYPE_LOC = MTYPE BUILD_POSINRHSINTR = .TRUE. ENDIF ENDIF C -- compute POSINRHSINTR LIW_PASSED=max(1,LIW) IF ( C no sparsity at fwd or bwd: & (Lnodes_FWD.EQ.-1).OR.(Lnodes_BWD.EQ.-1) C & ) THEN C C RHSINTR is not sparse (in the sense that it has N rows C distributed on the MPI procs) and thus POSINRHSINTR C does not change with loop. C Remarks: C 1/ sparsity might still be exploited during C fwd or bwd to reduce the number of operations. C 2/ BUILD_POSINRHSINTR = .FALSE. C IF ( I_AM_SLAVE ) THEN C{ CALL SMUMPS_BUILD_GLOB2LOC( & 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%GLOB2LOC_RHS(1), id%GLOB2LOC_SOL(1), & id%GLOB2LOC_SOL_ALLOC, & MTYPE_LOC, & NBENT_RHSINTR, NB_FS_RHSINTR_TOT ) NB_FS_RHSINTR_F = NB_FS_RHSINTR_TOT C} ENDIF C ELSE C C Note that POSINRHSINTR* need not be recomputed before IR : C because distributed solution => NO IR. C C Exploit sparsity in solution and RHS C (AM1 or (Sparse RHS and solution) ) C Since sparsity is exploited during C both fwd and bwd then we need to recompute C POSINRHSINTR only when CALL_NODES_FWD_BWD will C be performed at next iteration. IF (CALL_NODES_FWD_BWD) BUILD_POSINRHSINTR = .TRUE. C IF ( I_AM_SLAVE ) THEN C{ CALL SMUMPS_BUILD_GLOB2LOC_NODES_ES( & id%NSLAVES,id%N, & id%MYID_NODES, id%PTLUST_S(1), id%DAD_STEPS(1), & id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), id%IS(1), LIW, & id%STEP(1), C & Lnodes_FWD, Lnodes_BWD, & nodes_FWD_PTR(1), nodes_BWD_PTR(1), C & id%GLOB2LOC_RHS(1), id%GLOB2LOC_SOL(1), & id%GLOB2LOC_SOL_ALLOC, & MTYPE_LOC, & NBENT_RHSINTR, & NB_FS_RHSINTR_F, NB_FS_RHSINTR_TOT & ) C} ENDIF ENDIF C} ENDIF ! BUILD_POSINRHSINTR=.TRUE. IF (BUILD_RHSMAPINFO .AND. KEEP(248).EQ.-1 & ) THEN C C Prepare symbolic data for sends. C For the moment: only MAP_RHS_loc C C id%GLOB2LOC_RHS is always associated to the C forward step (with or without transposed system) IF ( I_AM_SLAVE ) THEN C{ CALL MUMPS_SOL_RHSMAPINFO( id%N, id%Nloc_RHS, id%KEEP(89), & IRHS_loc_PTR(1), MAP_RHS_loc, id%GLOB2LOC_RHS(1), & id%NSLAVES, id%MYID_NODES, & id%COMM_NODES, id%ICNTL(1), id%INFO(1) ) BUILD_RHSMAPINFO = .FALSE. C MUMPS_SOL_RHSMAPINFO does not propagate errors C} ENDIF ! I_AM_SLAVE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF ( BUILD_SCALING_RHSINTR ) THEN C{ IF (SCALING_RHSINTR_BWD_ALLOCATED) THEN NB_BYTES = NB_BYTES - LSCALING_RHSINTR_BWD * K16_8 DEALLOCATE(SCALING_RHSINTR_BWD) ENDIF IF (SCALING_RHSINTR_FWD_ALLOCATED) THEN NB_BYTES = NB_BYTES - LSCALING_RHSINTR_FWD * K16_8 DEALLOCATE(SCALING_RHSINTR_FWD) ENDIF NULLIFY(SCALING_RHSINTR_BWD) NULLIFY(SCALING_RHSINTR_FWD) SCALING_RHSINTR_BWD_ALLOCATED = .FALSE. SCALING_RHSINTR_FWD_ALLOCATED = .FALSE. SCALING_RHSINTR_BWD => RDUMMY_TARGET SCALING_RHSINTR_FWD => RDUMMY_TARGET LSCALING_RHSINTR_BWD = 1 LSCALING_RHSINTR_FWD = 1 C Define or allocate SCALING_RHSINTR if needed: IF (LSCAL .AND. I_AM_SLAVE ) THEN IF (KEEP(221).EQ.2) THEN C In case of sparsity during bwd, we cannot C rely on the value of Lnodes_FWD to know C whether the scaling will match SCALING_LOC C and should thus consider that (Lnodes_FWD.NE.-1) ES_RHSINTR = (Lnodes_BWD.NE.-1) ELSE C sparsity at fwd and at bwd: ES_RHSINTR = (Lnodes_FWD.NE.-1).AND.(Lnodes_BWD.NE.-1) ENDIF C Scaling allocations performed only if needed C Forward or normal solve: IF ( ES_RHSINTR ) THEN LSCALING_RHSINTR_FWD = max(1, NB_FS_RHSINTR_F ) ALLOCATE(SCALING_RHSINTR_FWD(LSCALING_RHSINTR_FWD), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=LSCALING_RHSINTR_FWD ELSE SCALING_RHSINTR_FWD_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + LSCALING_RHSINTR_FWD * K16_8 ENDIF ELSE C RHSINTR matches SCALING_loc, no need to C allocate and compute a different scaling LSCALING_RHSINTR_FWD = max(1,KEEP(89)) #if defined(USE_OLD_SCALING) #else SCALING_RHSINTR_FWD => SCALING_LOC_FWD #endif ENDIF IF (ES_RHSINTR) THEN LSCALING_RHSINTR_BWD = max(1, NB_FS_RHSINTR_TOT ) ALLOCATE(SCALING_RHSINTR_BWD(LSCALING_RHSINTR_BWD), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=LSCALING_RHSINTR_BWD ELSE SCALING_RHSINTR_BWD_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + LSCALING_RHSINTR_BWD * K16_8 ENDIF ELSE C RHSINTR matches SCALING_loc, no need to C allocate and compute a different scaling LSCALING_RHSINTR_BWD = max(1,KEEP(89)) #if defined(USE_OLD_SCALING) SCALING_RHSINTR_BWD => scaling_data_sol%SCALING_LOC #else SCALING_RHSINTR_BWD => SCALING_LOC_BWD SCALING_RHSINTR_FWD => SCALING_LOC_FWD #endif ENDIF ENDIF C} ENDIF CALL MUMPS_PROPINFO( id%ICNTL, id%INFO, id%COMM,id%MYID) IF (id%INFO(1) .LT.0 ) GOTO 90 IF (BUILD_SCALING_RHSINTR) THEN C{ IF ( LSCAL .AND. I_AM_SLAVE. AND. ES_RHSINTR ) THEN #if ! defined(USE_OLD_SCALING) C SCALING_RHSINTR_FWD has been allocated and should C now be filled. It is a compressed version of the C local scaling array SCALING_LOC_FWD: IF (MTYPE.eq.0 .AND. KEEP(50).EQ.0) THEN ! tranpose ROWORCOL = 2 ! access 2nd list -- col indices ELSE ROWORCOL = 1 ! access 1st list -- row indices ENDIF CALL SMUMPS_SCALINGRHSINTR(LSCAL, id%N, & SCALING_LOC_FWD(1), & SCALING_RHSINTR_FWD(1), & LSCALING_RHSINTR_FWD, id%GLOB2LOC_RHS(1), & id%KEEP, ROWORCOL, id%PTLUST_S(1), & id%IS(1), max(1,LIW), & id%MYID_NODES, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES) C SCALING_RHSINTR_BWD has been allocated and should C now be filled. It is a compressed version of the C local scaling array SCALING_LOC_BWD: IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN ! no tranpose C access 2nd list corresponding to col indices ROWORCOL = 2 ELSE C access 1st list corresponding to row indices ROWORCOL = 1 ENDIF CALL SMUMPS_SCALINGRHSINTR(LSCAL, id%N, & SCALING_LOC_BWD(1), & SCALING_RHSINTR_BWD(1), & LSCALING_RHSINTR_BWD, id%GLOB2LOC_SOL(1), & id%KEEP, ROWORCOL, id%PTLUST_S(1), & id%IS(1), max(1,LIW), & id%MYID_NODES, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES) #endif #if defined(USE_OLD_SCALING) #endif ENDIF C Rebuild SCALING_RHSINTR* next time C only if POSINRHSINTR has to be built C again next time: BUILD_SCALING_RHSINTR= BUILD_POSINRHSINTR C} ENDIF IF (I_AM_SLAVE) THEN IF ((KEEP(221).EQ.1).OR.KEEP(221).EQ.-1) THEN C For the following cases: C -[Schur] we need to save the reduced RHS for all RHS C to perform later the backward phase with an C updated reduced RHS C -[Fwd only] return RHSINTR to user C -KEEP(221)=-1, allocate RHSINTR to enable bwd only step C We need to allocate NRHS_NONEMPTY columns in one shot. C Note that C -RHSINTR might have been allocated in previous block C -RHSINTR has been deallocated previous to entering C loop on RHS IF (.not. associated(id%RHSINTR)) THEN C So far we cannot combine this to exploit sparsity C so that NBENT_RHSINTR will not change in the loop C and can be used to dimension RHSINTR C C Furthermore, during bwd phase the REDRHS provided C by the user might also have a different non empty C column pattern than the sparse RHS provided on input to C this phase: thus we need to allocate id%NRHS columns too. id%LD_RHSINTR = max(NBENT_RHSINTR,1) id%KEEP8(25) = int(id%LD_RHSINTR,8)*int(id%NRHS,8) ALLOCATE (id%RHSINTR(id%KEEP8(25)), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(25),INFO(2)) id%KEEP8(25)=0_8 GOTO 41 END IF NB_BYTES = NB_BYTES + id%KEEP8(25)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C C IF ((KEEP(221).NE.1).AND. & ((KEEP(221).NE.2).OR.(KEEP(252).NE.0)) & ) THEN C ------------------ C Allocate RHSINTR C (case of RHSINTR allocated at each block of RHS) C ------------------ C RHSINTR allocated per block of maximum size NBRHS C NBRHS_EFF could be used instead on NBRHS IF (associated(id%RHSINTR)) THEN C RHSINTR already associated for previous C block, check if we can reuse it. id%LD_RHSINTR = max(NBENT_RHSINTR, 1) IF (id%KEEP8(25).LT.int(id%LD_RHSINTR,8)*int(NBRHS,8)) & THEN ! deallocate and reallocate since larger array is needed NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25) = 0_8 id%LD_RHSINTR = 0 ENDIF ENDIF IF (.not. associated(id%RHSINTR)) THEN id%LD_RHSINTR = max(NBENT_RHSINTR, 1) id%KEEP8(25) = int(id%LD_RHSINTR,8)*int(NBRHS,8) ALLOCATE (id%RHSINTR(id%KEEP8(25)), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(25),INFO(2)) GOTO 41 END IF NB_BYTES = NB_BYTES + id%KEEP8(25)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C C Shift on RHSINTR C IF ( KEEP(221).EQ.0 ) THEN C -- RHSINTR reused in the loop IBEG_RHSINTR= 1_8 ELSE C Initialize IBEG_RHSINTR C IBEG_RHSINTR= int(JBEG_RHS-1,8)*int(id%LD_RHSINTR,8)+1_8 ENDIF ENDIF ! I_AM_SLAVE C ===================== ERROR handling and propagation ================ 41 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C C --------------------------- C Prepare RHS on master (case C of dense and sparse RHS) C --------------------------- IF (id%MYID .eq. MASTER & ) THEN C ========================= IF (KEEP(23) .NE. 0) THEN C ========================= * maximum transversal was performed IF (MTYPE .NE. 1) THEN * At x = b is asked while * we have AP = LU where P is the column permutation * due to max trans. * Therefore we need to modify rhs: * b' = P-1 b (P-1=Pt) * Apply column permutation to the right hand side RHS * Column J of the permuted matrix corresponds to * column PERMW(J) of the original matrix. * IF (KEEP(248)==0) THEN C ========= C DENSE RHS : permute values in RHS C ========= ALLOCATE( C_RW2( id%N ),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating C_RW2 in SMUMPS_SOLVE_DRIVE' END IF GOTO 30 END IF C We directly permute in id%RHS. DO K = 1, NBRHS_EFF KDEC = IBEG+int(K-1,8)*int(LD_RHS,8) DO I = 1, id%N C_RW2(I)=id%RHS(I-1+KDEC) END DO DO I = 1, id%N JPERM = id%UNS_PERM(I) id%RHS(I-1+KDEC) = C_RW2(JPERM) END DO END DO DEALLOCATE(C_RW2) ENDIF ENDIF ENDIF C IF (POSTPros) THEN IF ( KEEP(248) == 0 ) THEN DO K = 1, NBRHS_EFF KDEC = IBEG+int(K-1,8)*int(LD_RHS,8) DO I = 1, id%N SAVERHS(I+(K-1)*id%N) = id%RHS(KDEC+I-1) END DO ENDDO ELSE IF (KEEP(248)==1) THEN SAVERHS(:) = ZERO DO K = 1, NBRHS DO J = id%IRHS_PTR(K), id%IRHS_PTR(K+1)-1 I = id%IRHS_SPARSE(J) SAVERHS(I+(K-1)*id%N) = id%RHS_SPARSE(J) ENDDO ENDDO ENDIF ENDIF #if defined(USE_OLD_SCALING) C C RHS is set to scaled right hand side C (case of centralized scaling only) C IF (LSCAL) THEN C scaling was performed IF (KEEP(248)==0) THEN C dense RHS IF (MTYPE .EQ. 1) THEN C we solve Ax=b, use ROWSCA to scale the RHS DO K =1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHS,8) + int(IBEG-1,8) DO I = 1, id%N id%RHS(KDEC+I) = id%RHS(KDEC+I) * & id%ROWSCA(I) ENDDO ENDDO ELSE C we solve Atx=b, use COLSCA to scale the RHS DO K =1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHS,8) + int(IBEG-1,8) DO I = 1, id%N id%RHS(KDEC+I) = id%RHS(KDEC+I) * & id%COLSCA(I) ENDDO ENDDO ENDIF ELSE IF (KEEP(248)==1) THEN C ------------------------- C KEEP(248)==1 (and MASTER) C ------------------------- KDEC=int(id%IRHS_PTR(JBEG_RHS),8) C Compute IF ((KEEP(248)==1) .AND. & (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) & ) THEN C -- copy from RHS_SPARSE need be done per C column following PERM_RHS C Columns are not contiguous and need be copied one by one IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN IPERM = PERM_RHS(I) ENDIF J = J+1 C Note that we work here on compressed IRHS_PTR_COPY COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) C -- skip empty column IF (COLSIZE .EQ. 0) CYCLE IF (id%KEEP(237).NE.0) THEN IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN C if A-1 only, then, for each non empty target C column PERM_RHS(I), scale in first position C in column the diagonal entry C build the scaled rhs ej on each slave. RHS_SPARSE_COPY(IPOS) = id%ROWSCA(IPERM) * & ONE ELSE RHS_SPARSE_COPY(IPOS) = id%ROWSCA(I) * ONE ENDIF ELSE C Loop over nonzeros in column DO K = 1, COLSIZE C Formula for II below is ok, except in case C of maximum transversal (KEEP(23).NE.0) and C transpose system (MTYPE .NE. 1): C II = id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K-1) C In case of maximum transversal + transpose, one C should then apply II=UNS_PERM_INV(II) after the C above definition of II. C C Instead, we rely on IRHS_SPARSE_COPY, whose row C indices have already been permuted in case of C maximum transversal. II = IRHS_SPARSE_COPY( & IRHS_PTR_COPY(I-JBEG_RHS+1) & +K-1) C PERM_RHS(I) corresponds to column in original RHS. C Original IRHS_PTR must be used to access id%RHS_SPARSE IF (MTYPE.EQ.1) THEN RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(IPERM)+K-1)* & id%ROWSCA(II) ELSE RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(IPERM)+K-1)* & id%COLSCA(II) ENDIF ENDDO ENDIF IPOS = IPOS + COLSIZE ENDDO ELSE ! general sparse RHS ! without permutation IF (MTYPE .eq. 1) THEN DO IZ=1,NZ_THIS_BLOCK I=IRHS_SPARSE_COPY(IZ) RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* & id%ROWSCA(I) ENDDO ELSE DO IZ=1,NZ_THIS_BLOCK I=IRHS_SPARSE_COPY(IZ) RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* & id%COLSCA(I) ENDDO ENDIF ENDIF ENDIF ! KEEP(248)==1 ENDIF ! LSCAL #endif ENDIF ! id%MYID.EQ.MASTER #if defined(V_T) CALL VTEND(perm_scal_ini,IERR) #endif C C Prepare RHS on master C END C ===================== C ----------------------------------- C Two main cases depending on option C for null space computation: C C KEEP(111)=0 : use RHS from user C (sparse or dense) C KEEP(111)!=0: build an RHS on each C proc for null space C computations C ----------------------------------- #if defined(V_T) CALL VTBEGIN(soln_dist,IERR) #endif TIMESCATTER1=MPI_WTIME() IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0) & .AND.(KEEP(221).NE.2 )) THEN C{ ------------------------ C Use RHS provided by user C when not null space and not Fwd in facto C ------------------------ IF (KEEP(248) == 0) THEN C ---------------------------- C -- DENSE RIGHT-HAND-SIDE C ---------------------------- IF ( .NOT.I_AM_SLAVE ) THEN C -- Master not working CALL SMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, LSCAL, SCALING_LOC_FWD(1), & MTYPE, id%RHS(IBEG), LD_RHS, NBRHS_EFF, & NBRHS_EFF, & C_DUMMY, 1, 1, & IDUMMY, 0, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ELSE IF (id%MYID .eq. MASTER) THEN PTR_RHS => id%RHS LD_RHS_loc = LD_RHS NCOL_RHS_loc = NBRHS_EFF IBEG_loc = IBEG ELSE PTR_RHS => CDUMMY_TARGET LD_RHS_loc = 1 NCOL_RHS_loc = 1 IBEG_loc = 1_8 ENDIF LIW_PASSED = max( LIW, 1 ) CALL SMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, LSCAL, SCALING_LOC_FWD(1), & MTYPE, PTR_RHS(IBEG_loc),LD_RHS_loc,NCOL_RHS_loc, & NBRHS_EFF, & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, NBRHS_EFF, & id%GLOB2LOC_RHS(1), NB_FS_RHSINTR_F, C & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).LT.0) GOTO 90 ELSE IF (KEEP(248) .EQ. -1) THEN IF (I_AM_SLAVE) THEN IF (id%Nloc_RHS .NE. 0) THEN RHS_loc_size=int(id%LRHS_loc,8)*int(NBRHS_EFF-1,8)+ & int(id%Nloc_RHS,8) RHS_loc_shift=1_8+int(BEG_RHS-1,8)*id%LRHS_loc ELSE RHS_loc_size=1_8 RHS_loc_shift=1_8 ENDIF CALL SMUMPS_SCATTER_DIST_RHS(id%NSLAVES, id%N, & id%MYID_NODES, id%COMM_NODES, & NBRHS_EFF, id%Nloc_RHS, id%LRHS_loc, & MAP_RHS_loc, & IRHS_loc_PTR(1), & idRHS_loc(RHS_loc_shift), & RHS_loc_size, & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, & id%GLOB2LOC_RHS(1), NB_FS_RHSINTR_F, & LSCAL, #if defined(USE_OLD_SCALING) & scaling_data_dr, #else & SCALING_RHSINTR_FWD(1), LSCALING_RHSINTR_FWD, #endif & LP, LPOK, KEEP(1), NB_BYTES_LOC, INFO(1)) C NB_BYTES_LOC were allocated and freed above NB_BYTES_MAX = max(NB_BYTES_MAX, & NB_BYTES_MAX+NB_BYTES_LOC) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).LT.0) GOTO 90 ELSE C === KEEP(248)==1 ========= C -- SPARSE RIGHT-HAND-SIDE C ---------------------------- IF (NZ_THIS_BLOCK > 0 #if ! defined(USE_OLD_SCALING) C For AM1, no need to broadcast RHS_SPARSE C when using local scalings. RHSINTR will C be initialized directly and RHS_SPARSE C is used during SMUMPS_GATHER_SOLUTION_AM1 & .AND. id%KEEP(237) .EQ.0 #endif & ) THEN CALL MPI_BCAST(RHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_REAL, & MASTER, id%COMM, IERR) ENDIF C IF (KEEP(237).NE.0) THEN IF ( I_AM_SLAVE ) THEN C ----- C case of A-1 C ----- C - Take columns with non-zero entry, say j, C - to build Ej and store it in RHSINTR K=1 ! Column index in RHSINTR id%RHSINTR(1_8:int(NBRHS_EFF,8)*int(id%LD_RHSINTR,8)) & = ZERO IPOS = 1 DO I = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) IF (COLSIZE.GT.0) THEN ! Find global column index J and set ! column K of RHSINTR to ej (here IBEG is one) J = I - 1 + JBEG_RHS IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN J = PERM_RHS(J) ENDIF IPOSRHSINTR = id%GLOB2LOC_RHS(J) C IF ( (IPOSRHSINTR.LE.NB_FS_RHSINTR_F) C & .AND.(IPOSRHSINTR.GT.0) ) THEN IF (IPOSRHSINTR.GT.0) THEN C Columns J corresponds to ej and thus to variable j C that is on my proc. C We know that only one entry is needed, C the diagonal entry (for the forward with A-1). C #if defined(USE_OLD_SCALING) id%RHSINTR(int(K-1,8)*int(id%LD_RHSINTR,8)+ & int(IPOSRHSINTR,8)) = & RHS_SPARSE_COPY(IPOS) #else IF (LSCAL) THEN id%RHSINTR(int(K-1,8)*int(id%LD_RHSINTR,8)+ & int(IPOSRHSINTR,8)) = & SCALING_RHSINTR_FWD(IPOSRHSINTR) ELSE id%RHSINTR(int(K-1,8)*int(id%LD_RHSINTR,8)+ & int(IPOSRHSINTR,8)) = ONE ENDIF #endif ENDIF ! End of J on my proc K = K + 1 IPOS = IPOS + COLSIZE ! go to next column ENDIF ENDDO IF (K.NE.NBRHS_EFF+1) THEN WRITE(6,*) 'Internal Error 9 in solution driver ', & K,NBRHS_EFF call MUMPS_ABORT() ENDIF ENDIF ! I_AM_SLAVE C ------- c END A-1 C ------- ELSE C -------------- C General sparse C -------------- C -- At this point each process has a copy of the C -- sparse RHS. We need to store it into RHSINTR. C -- reset to zero RHSINTR for skipped columns (if any) IF ((KEEP(221).EQ.1).AND.(NB_RHSSKIPPED.GT.0) & .AND.I_AM_SLAVE) THEN DO K = JBEG_RHS-NB_RHSSKIPPED, JBEG_RHS-1 DO I = 1, id%LD_RHSINTR id%RHSINTR(int(K-1,8)*int(id%LD_RHSINTR,8) & + int(I,8)) = ZERO ENDDO ENDDO ENDIF IF (I_AM_SLAVE) THEN DO K = 1, NBCOL_INBLOC ! it is equal to NBRHS_EFF in this case KDEC = int(K-1,8) * int(id%LD_RHSINTR,8) + & IBEG_RHSINTR - 1_8 id%RHSINTR(KDEC+1_8:KDEC+NBENT_RHSINTR) = ZERO #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 I=IRHS_SPARSE_COPY(IZ) IPOSRHSINTR = id%GLOB2LOC_RHS(I) C Since all fully summed variables mapped C on each proc are stored at the beginning C of RHSINTR, we can compare to KEEP(89) C to know if RHSINTR should be initialized C So far the tree has not been pruned to exploit C sparsity to compress RHSINTR so we compare to C NB_FS_RHSINTR_TOT IF ( (IPOSRHSINTR.LE.NB_FS_RHSINTR_TOT) & .AND.(IPOSRHSINTR.GT.0) ) THEN C ! I is fully summed var mapped on my proc id%RHSINTR(KDEC+IPOSRHSINTR)= & id%RHSINTR(KDEC+IPOSRHSINTR) + & RHS_SPARSE_COPY(IZ) & * SCALING_RHSINTR_FWD(IPOSRHSINTR) ENDIF ENDDO ELSE #endif DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 I=IRHS_SPARSE_COPY(IZ) IPOSRHSINTR = id%GLOB2LOC_RHS(I) C Since all fully summed variables mapped C on each proc are stored at the beginning C of RHSINTR, we can compare to KEEP(89) C to know if RHSINTR should be initialized C So far the tree has not been pruned to exploit C sparsity to compress RHSINTR so we compare to C NB_FS_RHSINTR_TOT IF ( (IPOSRHSINTR.LE.NB_FS_RHSINTR_TOT) & .AND.(IPOSRHSINTR.GT.0) ) THEN C ! I is fully summed var mapped on my proc id%RHSINTR(KDEC+IPOSRHSINTR)= & id%RHSINTR(KDEC+IPOSRHSINTR) + & RHS_SPARSE_COPY(IZ) ENDIF ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif ENDDO END IF ! I_AM_SLAVE ENDIF ! KEEP(237) ENDIF ! ==== KEEP(248)==1 ===== C} ELSE IF (I_AM_SLAVE) THEN ! I_AM_SLAVE AND (null space or Fwd in facto) IF (KEEP(111).NE.0) THEN C{ ----------------------- C Null space computations C ----------------------- C C We are working on columns BEG_RHS:BEG_RHS+NBRHS_EFF-1 C of RHS. C Columns in 1..KEEP(112): C Put a one in corresponding C position of the right-hand-side, C and zeros in other places. C Columns in KEEP(112)+1: KEEP(112)+KEEP(17): C root node => set C 0 everywhere and compute the local range C corresponding to IBEG/IEND in root C that will be passed to SMUMPS_SEQ_SOLVE_ROOT_RR C Also keep track of which part of C SMUMPS_RHS must be passed to C SMUMPS_SEQ_SOLVE_ROOT_RR. C IF (KEEP(111).GT.0) THEN IBEG_GLOB_DEF = KEEP(111) IEND_GLOB_DEF = KEEP(111) ELSE IBEG_GLOB_DEF = BEG_RHS IEND_GLOB_DEF = BEG_RHS+NBRHS_EFF-1 ENDIF IF ( id%KEEP(112) .GT. 0 .AND. DO_NULL_PIV) THEN IF (IBEG_GLOB_DEF .GT.id%KEEP(112)) THEN id%KEEP(235) = 0 DO_NULL_PIV = .FALSE. ENDIF IF (IBEG_GLOB_DEF .LT.id%KEEP(112) & .AND. IEND_GLOB_DEF .GT.id%KEEP(112) & .AND. DO_NULL_PIV ) THEN C IEND_GLOB_DEF = id%KEEP(112) C forcing exploit sparsity C - cannot be done at this point C - and is not what the user would have expected the C code to to do anyway !!!! C suppress: id%KEEP(235) = 1 ! End Block of sparsity ON DO_NULL_PIV = .FALSE. ENDIF ENDIF IF (id%KEEP(235).NE.0) THEN C Exploit Sparsity in null space computations C We build /allocate the sparse RHS on MASTER C based on pivnul_list. Then we broadcast it C on the slaves C In this case we have ONLY ONE ENTRY per RHS C NZ_THIS_BLOCK=IEND_GLOB_DEF-IBEG_GLOB_DEF+1 ALLOCATE(IRHS_PTR_COPY(NZ_THIS_BLOCK+1),stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 50 ENDIF IRHS_PTR_COPY_ALLOCATED = .TRUE. ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK),stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 50 ENDIF IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + & int(NZ_THIS_BLOCK,8)*(K34_8+K34_8) & + K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.eq.MASTER) THEN ! compute IRHS_PTR and IRHS_SPARSE_COPY II = 1 DO I = IBEG_GLOB_DEF, IEND_GLOB_DEF IRHS_PTR_COPY(I-IBEG_GLOB_DEF+1) = I IRHS_SPARSE_COPY(II) = id%PIVNUL_LIST(I) II = II +1 ENDDO IRHS_PTR_COPY(NZ_THIS_BLOCK+1) = NZ_THIS_BLOCK+1 ENDIF C C ===================== ERROR handling and propagation ================ 50 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(IRHS_PTR_COPY(1), & NZ_THIS_BLOCK+1, & MPI_INTEGER, & MASTER, id%COMM,IERR) C End IF Exploit Sparsity ENDIF c C Initialize RHSINTR to 0 ! to be suppressed DO K=1, NBRHS_EFF KDEC = int(K-1,8) * int(id%LD_RHSINTR,8) id%RHSINTR(KDEC+1_8:KDEC+int(id%LD_RHSINTR,8))=ZERO END DO C Loop over the columns. C Note that if ( KEEP(220)+KEEP(109)-1 < IBEG_GLOB_DEF C .OR. KEEP(220) > IEND_GLOB_DEF ) then we do not enter C the loop. C Note that local processor has indices C KEEP(220):KEEP(220)+KEEP(109)-1 C C Computation of null space and computation of backward C step incompatible, do one or the other. DO I=max(IBEG_GLOB_DEF,KEEP(220)), & min(IEND_GLOB_DEF,KEEP(220)+KEEP(109)-1) C Local processor is concerned by I-th column of C global right-hand side. JJ= id%GLOB2LOC_RHS(id%PIVNUL_LIST(I-KEEP(220)+1)) IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN ! unsymmetric : always set to fixation id%RHSINTR( IBEG_RHSINTR+ & int(I-IBEG_GLOB_DEF,8)*int(id%LD_RHSINTR,8)+ & int(JJ-1,8) ) = & id%DKEEP(2) ELSE ! Symmetric: always set to one id%RHSINTR( IBEG_RHSINTR+ & int(I-IBEG_GLOB_DEF,8)*int(id%LD_RHSINTR,8)+ & int(JJ-1,8) )= & ONE ENDIF ENDIF ENDDO IF ( KEEP(17).NE.0 .AND. & id%MYID_NODES.EQ.MASTER_ROOT) THEN C --------------------------- C Deficiency of the root node C Find range relative to root C --------------------------- C Among IBEG_GLOB_DEF:IEND_GLOB_DEF, find C intersection with KEEP(112)+1:KEEP(112)+KEEP(17) IBEG_ROOT_DEF = max(IBEG_GLOB_DEF,KEEP(112)+1) IEND_ROOT_DEF = min(IEND_GLOB_DEF,KEEP(112)+KEEP(17)) C First column of right-hand side that must C be passed to SMUMPS_SEQ_SOLVE_ROOT_RR is: IROOT_DEF_RHS_COL1 = IBEG_ROOT_DEF-IBEG_GLOB_DEF + 1 C We look for indices relatively to the root node, C substract number of null pivots outside root node IBEG_ROOT_DEF = IBEG_ROOT_DEF-KEEP(112) IEND_ROOT_DEF = IEND_ROOT_DEF-KEEP(112) C Note that if IBEG_ROOT_DEF > IEND_ROOT_DEF, then this C means that nothing must be done on the root node C for this set of right-hand sides. ELSE IBEG_ROOT_DEF = -90999 IEND_ROOT_DEF = -95999 IROOT_DEF_RHS_COL1= 1 ENDIF C} ELSE ! End of null space (test on KEEP(111)) C case of Fwd in facto C id%RHSINTR need not be initialized. It will be set on the fly C to zero for normal fully summed variables of the fronts and C to -1 on the roots for the id%N+KEEP(253) variables added C to the roots. ENDIF ! End of null space (test on KEEP(111)) ENDIF ! I am slave TIMESCATTER2=MPI_WTIME()-TIMESCATTER1+TIMESCATTER2 IF (KEEP(221) .EQ. 2 .AND. KEEP(60).NE.0 ) THEN C Copy/send REDRHS in PTR_RHS_ROOT C (column by column if leading dimension LD_REDRHS C of REDRHS is not equal to SIZE_ROOT). C REDRHS was provided on the host IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN C -- Same proc : copy is possible: II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8)-1_8 DO I = 1, SIZE_ROOT PTR_RHS_ROOT(II+I) = id%REDRHS(KDEC+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE C -- send REDRHS IF ( id%MYID .EQ. MASTER) THEN C -- send to MASTER_ROOT_IN_COMM using COMM communicator C assert: id%KEEP(116).EQ.SIZE_ROOT IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- One send KDEC = IBEG_REDRHS CALL MPI_SEND(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_REAL, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSE C -- NBRHS_EFF sends DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) CALL MPI_SEND(id%REDRHS(KDEC),SIZE_ROOT, & MPI_REAL, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ENDDO ENDIF ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN C -- receive from MASTER II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- receive all in on shot CALL MPI_RECV(PTR_RHS_ROOT(II), & SIZE_ROOT*NBRHS_EFF, & MPI_REAL, & MASTER, 0, id%COMM,STATUS,IERR) ELSE DO K=1, NBRHS_EFF CALL MPI_RECV(PTR_RHS_ROOT(II),SIZE_ROOT, & MPI_REAL, & MASTER, 0, id%COMM,STATUS,IERR) II = II + SIZE_ROOT ENDDO ENDIF ENDIF C -- other procs are not concerned ENDIF ENDIF TIMEC1=MPI_WTIME() IF ( I_AM_SLAVE ) THEN C { LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) C FROM_PP = .FALSE. NBSPARSE_LOC = (DO_NBSPARSE.AND.NBRHS_EFF.GT.1) C ----------------------------------------- C Define arguments to have a single call to C SOL_C with and without exploit sparsity. C ----------------------------------------- IF (Lnodes_FWD.EQ.-1 .AND. Lnodes_BWD.EQ.-1) THEN NZ_THIS_BLOCK_ARG = 1 NBCOL_INBLOC_ARG = 1 Step2node_ARG => IDUMMY_TARGET LStep2node_ARG = 1 IRHS_SPARSE_COPY_ARG => IDUMMY_TARGET IRHS_PTR_COPY_ARG => IDUMMY_TARGET NB_FS_RHSINTR_F_ARG = 1 NB_FS_RHSINTR_TOT_ARG = 1 #if defined(STAT_ES_SOLVE) SIZE_WORKING = 1 SIZE_IPTR_WORKING = 1 idIPTR_WORKING => IDUMMY_TARGET idWORKING => IDUMMY_TARGET #endif ELSE NZ_THIS_BLOCK_ARG = NZ_THIS_BLOCK NBCOL_INBLOC_ARG = NBCOL_INBLOC Step2node_ARG => id%Step2node LStep2node_ARG = KEEP(28) IRHS_SPARSE_COPY_ARG => IRHS_SPARSE_COPY IRHS_PTR_COPY_ARG => IRHS_PTR_COPY NB_FS_RHSINTR_F_ARG = NB_FS_RHSINTR_F NB_FS_RHSINTR_TOT_ARG = NB_FS_RHSINTR_TOT #if defined(STAT_ES_SOLVE) SIZE_WORKING = 1 SIZE_IPTR_WORKING = 1 IF((KEEP(235).NE.0).OR.(KEEP(237).NE.0)) THEN IF(id%MYID.EQ.MASTER) THEN SIZE_WORKING = id%IPTR_WORKING(id%NPROCS+1)-1 SIZE_IPTR_WORKING = id%NPROCS+1 END IF ENDIF #endif ENDIF CALL SMUMPS_SOL_C(idintr%root,idintr%roota,id%N,id%S(1), &LA_PASSED,IS(1),LIW_PASSED,WORK_WCB(1),LWCB8,IWCB,LIWCB, &NBRHS_EFF,id%NA(1),id%LNA,id%NE_STEPS(1),SRW3, MTYPE, ICNTL(1), &FROM_PP,id%STEP(1),id%FRERE_STEPS(1),id%DAD_STEPS(1),id%FILS(1), &id%PTLUST_S(1),id%PTRFAC(1),IWK_SOLVE,LIWK_SOLVE,PTRACB, &LIWK_PTRACB,id%PROCNODE_STEPS(1),id%NSLAVES,INFO(1),KEEP(1), &KEEP8(1),id%DKEEP(1),id%COMM_NODES,id%MYID,id%MYID_NODES,BUFR(1), &LBUFR,LBUFR_BYTES,id%ISTEP_TO_INIV2(1),id%TAB_POS_IN_PERE(1,1), &IBEG_ROOT_DEF,IEND_ROOT_DEF,IROOT_DEF_RHS_COL1, PTR_RHS_ROOT(1), &LPTR_RHS_ROOT,SIZE_ROOT,MASTER_ROOT,id%RHSINTR(IBEG_RHSINTR), &id%LD_RHSINTR,id%GLOB2LOC_RHS(1),id%GLOB2LOC_SOL(1), &Lnodes_FWD, Lnodes_BWD, nodes_FWD_PTR(1), nodes_BWD_PTR(1), &NZ_THIS_BLOCK_ARG, NBCOL_INBLOC_ARG, JBEG_RHS, Step2node_ARG(1), &LStep2node_ARG, IRHS_SPARSE_COPY_ARG(1), IRHS_PTR_COPY_ARG(1), &size(PERM_RHS), PERM_RHS, size(UNS_PERM_INV), UNS_PERM_INV, &NB_FS_RHSINTR_F, NB_FS_RHSINTR_TOT, NBSPARSE_LOC, &PTR_RHS_BOUNDS(1), LPTR_RHS_BOUNDS #if defined(STAT_ES_SOLVE) &,idIPTR_WORKING(1),SIZE_IPTR_WORKING,idWORKING(1),SIZE_WORKING #endif & , id%IPOOL_B_L0_OMP(1), id%LPOOL_B_L0_OMP, id%IPOOL_A_L0_OMP(1), & id%LPOOL_A_L0_OMP, id%L_VIRT_L0_OMP, id%VIRT_L0_OMP(1), & id%L_PHYS_L0_OMP, id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1), & id%PTR_LEAFS_L0_OMP(1), id%L0_OMP_MAPPING(1), id%LL0_OMP_MAPPING, & idintr%L0_OMP_FACTORS(1), id%LL0_OMP_FACTORS & ) C C ================================================================ C C } END IF ! I_AM_SLAVE C ----------------- C End of slave code C ----------------- C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) TIMEC2=MPI_WTIME()-TIMEC1+TIMEC2 C C Change error code. IF (INFO(1).eq.-2) then INFO(1)=-11 IF (LPOK) & write(LP,*) & ' WARNING : -11 error code obtained in solve' END IF IF (INFO(1).eq.-3) then INFO(1)=-14 IF (LPOK) & write(LP,*) & ' WARNING : -14 error code obtained in solve' END IF C C Return in case of error. IF (INFO(1).LT.0) GO TO 90 C C ====================================================== C ONLY FORWARD was performed (case of reduced RHS with Schur C option during factorisation) C ====================================================== IF ( (KEEP(60).NE.0) .AND. & KEEP(221) .EQ. 1 ) THEN ! === Begin OF REDUCED RHS ====== C -------------------------------------- C Send (or copy) reduced RHS from PTR_RHS_ROOT located on C MASTER_ROOT_IN_COMM to REDRHS located on MASTER (host node). C (column by column if leading dimension LD_REDRHS C of REDRHS is not equal to SIZE_ROOT) C -------------------------------------- IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN C -- same proc --> copy II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) - 1_8 DO I = 1, SIZE_ROOT id%REDRHS(KDEC+I) = PTR_RHS_ROOT(II+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE C -- recv in REDRHS IF ( id%MYID .EQ. MASTER ) THEN C -- recv from MASTER_ROOT_IN_COMM IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- One message to receive KDEC = IBEG_REDRHS CALL MPI_RECV(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_REAL, & MASTER_ROOT_IN_COMM, 0, id%COMM, & STATUS,IERR) ELSE C -- NBRHS_EFF receives DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) CALL MPI_RECV(id%REDRHS(KDEC),SIZE_ROOT, & MPI_REAL, & MASTER_ROOT_IN_COMM, 0, id%COMM, & STATUS,IERR) ENDDO ENDIF ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN C -- send to MASTER II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- send all in on shot CALL MPI_SEND(PTR_RHS_ROOT(II), & SIZE_ROOT*NBRHS_EFF, & MPI_REAL, & MASTER, 0, id%COMM,IERR) ELSE DO K=1, NBRHS_EFF CALL MPI_SEND(PTR_RHS_ROOT(II),SIZE_ROOT, & MPI_REAL, & MASTER, 0, id%COMM,IERR) II = II + SIZE_ROOT ENDDO ENDIF ENDIF C -- other procs are not concerned ENDIF ENDIF ! ===== END OF REDUCED RHS (Schur+Fwd only performed) == C ======================================================= C BACKWARD was PERFORMED C Postprocess solution that is distributed IF ( KEEP(221) .NE. 1 ) THEN ! BACKWARD was PERFORMED C -- KEEP(221).NE.1 => we are sure that backward has been performed IF (ICNTL21 == 0) THEN ! CENTRALIZED SOLUTION C{ ======================================================== C GATHER SOLUTION computed during bwd C Each proc holds the pieces of solution corresponding C to all fully summed variables mapped on that processor C (i.e. corresponding to master nodes mapped on that proc) C In case of A-1 we gather directly in RHS_SPARSE C the distributed solution. C Scaling is done in all case on the fly of the reception C Note that when only FORWARD has been performed C RSH_MUMPS holds the solution computed during forward step C (SMUMPS_SOL_R) C there is no need to copy back in RSH_MUMPS the solution C ======================================================== C centralized solution IF (KEEP(237).EQ.0) THEN C CWORK not needed for AM1 LCWORK = max(max(KEEP(247),KEEP(246)),1) ALLOCATE( CWORK(LCWORK), stat=allocok ) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) ENDIF ENDIF IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & .AND. (id%NSLAVES.NE.1)) THEN C Precompute map of indices in current column C (no need to reset it between columns ALLOCATE (MAP_RHS(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) ' Problem allocation of MAP_RHS at solve' ENDIF INFO(1) = -13 INFO(2) = id%N ELSE NB_BYTES = NB_BYTES + int(id%N,8) * K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) C Return in case of error. IF (INFO(1).LT.0) GO TO 90 #if defined(USE_OLD_SCALING) 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 #endif LIW_PASSED = max( LIW, 1 ) TIMEGATHER1=MPI_WTIME() IF ( .NOT.I_AM_SLAVE ) THEN C I did not participate to computing part of the solution C (id%RHSINTR not set/allocate) : receive solution, store C it and scale it. IF (KEEP(237).EQ.0) THEN C We need a workspace of minimal size KEEP(247) C in order to unpack pieces of the solution. CALL SMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & MTYPE, id%RHS(1), LD_RHS, id%NRHS, JBEG_RHS, & JDUMMY, id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), IDUMMY, 1, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), LCWORK, LSCAL, #if defined(USE_OLD_SCALING) & PT_SCALING(1), size(PT_SCALING), #else & SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), #endif & C_DUMMY, 1 , 1, IDUMMY, 1, & PERM_RHS, size(PERM_RHS) ! for sparse permuted RHS & ) ELSE C only gather target entries of A-1 CALL SMUMPS_GATHER_SOLUTION_AM1(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & C_DUMMY, 1, 1, & id%KEEP(1), BUFR(1), LBUFR, LBUFR_BYTES, #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING) #else & LSCAL, SCALING_RHSINTR_BWD(1), & size(SCALING_RHSINTR_BWD) #endif C --- A-1 related entries & ,IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), & UNS_PERM_INV, size(UNS_PERM_INV), & IDUMMY, 1, 0 & ) ENDIF ELSE C Avoid temporary copy (IS(1)) that some old C compilers would do otherwise IF (KEEP(237).EQ.0) THEN IF (id%MYID.EQ.MASTER) THEN PTR_RHS => id%RHS NCOL_RHS_loc = id%NRHS LD_RHS_loc = LD_RHS JBEG_RHS_loc = JBEG_RHS ELSE PTR_RHS => CDUMMY_TARGET NCOL_RHS_loc = 1 LD_RHS_loc = 1 JBEG_RHS_loc = 1 ENDIF CALL SMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, MTYPE, & PTR_RHS(1), LD_RHS_loc, NCOL_RHS_loc, JBEG_RHS_loc, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), IS(1), LIW_PASSED, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), LCWORK, #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING), #else & LSCAL, SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), #endif & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, NBRHS_EFF, & id%GLOB2LOC_SOL(1), id%N, & PERM_RHS, size(PERM_RHS) ! For sparse permuted RHS & ) ELSE ! only gather target entries of A-1 CALL SMUMPS_GATHER_SOLUTION_AM1(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, NBRHS_EFF, & id%KEEP(1), BUFR(1), LBUFR, LBUFR_BYTES, #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING) #else & LSCAL, SCALING_RHSINTR_BWD(1), size(SCALING_RHSINTR_BWD) #endif C --- A-1 related entries & , IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), & UNS_PERM_INV, size(UNS_PERM_INV), & id%GLOB2LOC_SOL(1), id%N, NB_FS_RHSINTR_TOT & ) ENDIF ENDIF TIMEGATHER2=MPI_WTIME()-TIMEGATHER1+TIMEGATHER2 IF (KEEP(237).EQ.0) DEALLOCATE( CWORK ) IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & ) THEN C Copy back solution from RHS_SPARSE_COPY TO RHS_SPARSE DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN PJ = PERM_RHS(J) ELSE PJ =J ENDIF COLSIZE = id%IRHS_PTR(PJ+1) - & id%IRHS_PTR(PJ) IF (COLSIZE.EQ.0) CYCLE JJ = J-JBEG_RHS+1 C Precompute map of indices in current column C (no need to reset it between columns IF (id%NSLAVES.NE.1) THEN DO II=1, COLSIZE MAP_RHS(id%IRHS_SPARSE( & id%IRHS_PTR(PJ) + II - 1)) = II ENDDO DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 II = IRHS_SPARSE_COPY(IZ2) id%RHS_SPARSE(id%IRHS_PTR(PJ)+MAP_RHS(II)-1)= & RHS_SPARSE_COPY(IZ2) ENDDO ELSE C Entries within a column are in order C IZ - Column index in Sparse RHS DO IZ= id%IRHS_PTR(PJ), id%IRHS_PTR(PJ+1)-1 IZ2 = IRHS_PTR_COPY(JJ) + & IZ - id%IRHS_PTR(PJ) id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDIF ENDDO IF (id%NSLAVES.NE.1) THEN NB_BYTES = NB_BYTES - int(size(MAP_RHS),8) * K34_8 DEALLOCATE ( MAP_RHS ) ENDIF ENDIF ! end A-1 on master C C} -- END of backward was performed with centralized solution ELSE ! (KEEP(221).NE.1) .AND.(ICNTL21.NE.0)) C C BEGIN of backward performed with distributed solution C time local copy + scaling TIMECOPYSCALE1=MPI_WTIME() C The non working host should not do this: IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF ( KEEP(89) .GT. 0 ) THEN IF ( LSCAL .AND. id%KEEP(89).GT.0) THEN #if defined(USE_OLD_SCALING) SCALING_LOC_BWD => scaling_data_sol%SCALING_LOC #else IF (MTYPE.EQ.1) THEN SCALING_LOC_BWD => id%COLSCA_loc ELSE SCALING_LOC_BWD => id%ROWSCA_loc ENDIF #endif ELSE SCALING_LOC_BWD => RDUMMY_TARGET ENDIF CALL SMUMPS_DISTRIBUTED_SOLUTION(id%NSLAVES, & id%N,id%MYID_NODES, & MTYPE, id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, & NBRHS_EFF, id%GLOB2LOC_SOL(1), & id%ISOL_loc(1), id%SOL_loc(1), id%NRHS, & JBEG_RHS-NB_RHSSKIPPED, id%LSOL_loc, & id%PTLUST_S(1), id%PROCNODE_STEPS(1), & id%KEEP(1),id%KEEP8(1), & IS(1), LIW_PASSED, id%STEP(1), & SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), & LSCAL, NB_RHSSKIPPED, & PERM_RHS, size(PERM_RHS) ) ! For permuted sparse RHS ENDIF ENDIF TIMECOPYSCALE2=MPI_WTIME()-TIMECOPYSCALE1+TIMECOPYSCALE2 ENDIF C === BACKWARD was PERFORMED WITH DISTRIBUTED SOLUTION === C ======================================================== ENDIF ! ==== END of BACKWARD was PERFORMED (KEEP(221).NE.1) C note that the main DO-loop on blocks is not ended yet C C ============================================ C BEGIN C C ITERATIVE REFINEMENT AND/OR ERROR ANALYSIS C C ============================================ IF ( ICNTL10 > 0 .AND. NBRHS_EFF > 1 ) THEN C C ---------------------------------- C Multiple RHS: apply a fixed number C of iterative refinement steps C ---------------------------------- C DO I = 1, ICNTL10 write(6,*) ' Internal error 15 in sol_driver ' C Compute residual: Y <- SAVERHS - A * RHS C Solve RHS <- A^-1 Y, Y modified C Assemble in RHS(REDUCE) C RHS <- RHS + Y C END DO END IF IF (POSTPros) THEN C{ C SAVERHS holds the original right hand side C Sparse rhs are saved in SAVERHS as dense rhs C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C Start iterative refinements. The master is managing the C organisation of work, but slaves are used to solve systems of C equations and, in case of distributed matrix, perform C matrix-vector products. It is more complicated to do this with C the SPMD version than it was with the master/slave approach. C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * c IF ( PROK .AND. ICNTL10 .NE. 0 ) WRITE( MP, 270 ) IF ( PROKG .AND. ICNTL10 .NE. 0 ) WRITE( MPG, 270 ) C Initializations and allocations NITREF = abs(ICNTL10) ALLOCATE(R_Y(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 ALLOCATE(C_Y(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 IF ( id%MYID .EQ. MASTER ) THEN ALLOCATE( IW1( 2 * id%N ),stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=2 * id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(2*id%N,8)*K34_8 ALLOCATE( C_W(id%N), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 ALLOCATE( R_W(2*id%N), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(2*id%N,8)*K16_8 C end allocations on Master END IF ALLOCATE(C_LOCWK54(id%N),stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 ALLOCATE(R_LOCWK54(id%N),stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 KASE = 0 C Synchro point with broadcast of errors 777 CONTINUE NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 C TIMEEA needed if EA and IR with stopping criterium C and IR with fixed n.of steps. TIMEEA = 0.0E0 C TIMEEA1 needed if EA and IR with fixed n.of steps TIMEEA1 = 0.0E0 CALL MUMPS_SECDEB(TIMEIT) C ------------------------- C C RHSOL holds the initial guess for the solution C We start the loop on the Iterative refinement procedure C C C C |- IRefin. L O O P -| C V V C C ========================================================= C Computation of the infinity norm of A C ========================================================= IF ((ICNTL11.GT.0).OR.(ICNTL10.GT.0)) THEN C We don't get through these lines if ICNTL10<=0 AND ICNTL11<=0 IF ( KEEP(54) .eq. 0 ) THEN C ------------------ C Centralized matrix C ------------------ IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------------- C Call SMUMPS_SOL_X outside, if needed, C in order to compute w(i,2)=sum|Aij|,j=1:n C in vector R_W(id%N+i) C ----------------------------------------- IF (KEEP(55).NE.0) THEN C unassembled matrix and norm of row required CALL SMUMPS_SOL_X_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), id%A_ELT(1), & R_W(id%N+1), KEEP(1),KEEP8(1) ) ELSE C assembled matrix IF ( MTYPE .eq. 1 ) THEN CALL SMUMPS_SOL_X & ( id%A(1), id%KEEP8(28), id%N, id%IRN(1), id%JCN(1), & R_W(id%N+1), KEEP(1),KEEP8(1), & 0, id%SYM_PERM(1) ) ELSE CALL SMUMPS_SOL_X & ( id%A(1), id%KEEP8(28), id%N, id%JCN(1), id%IRN(1), & R_W(id%N+1), KEEP(1),KEEP8(1), & 0, id%SYM_PERM(1) ) END IF ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL SMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1), & 0, id%SYM_PERM(1) ) ELSE CALL SMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%JCN_loc(1), id%IRN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1), & 0, id%SYM_PERM(1) ) END IF ELSE R_LOCWK54 = RZERO END IF C ------------------------- C Assemble result on master C ------------------------- IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_W( id%N + 1 ), & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) END IF C End if KEEP(54) END IF C IF ( id%MYID .eq. MASTER ) THEN C R_W is available on the master process only RINFOG(4) = real(ZERO) DO I = 1, id%N RINFOG(4) = max(R_W( id%N +I), RINFOG(4)) ENDDO ENDIF C end ICNTL11 =/0 v ICNTL10>0 ENDIF C ========================================================= C END norm of A C ========================================================= C Initializations for the IR NOITER = 0 IFLAG_IR = 0 TESTConv = .FALSE. IF ( id%MYID .eq. MASTER ) THEN IF (ICNTL10.GT.0) THEN C Test of convergence should be made TESTConv = .TRUE. ARRET = CNTL(2) IF (ARRET .LT. 0.0E0) THEN ARRET = sqrt(epsilon(0.0E0)) END IF IF ( PROKG ) THEN WRITE( MPG, 240) NITREF, ARRET,id%DKEEP(22) ENDIF ELSE IF ( PROKG ) THEN WRITE( MPG, 245) NITREF ENDIF ENDIF C ========================================================= C Starting IR DO 22 IRStep = 1, NITREF +1 C ========================================================= C C ========================================================= C Refine the solution starting from the second step of do loop C ========================================================= IF (( id%MYID .eq. MASTER ).AND.(IRStep.GT.1)) THEN NOITER = NOITER + 1 DO I = 1, id%N id%RHS(IBEG+I-1) = id%RHS(IBEG+I-1) + C_Y(I) ENDDO ENDIF C =========================================== C Computation of the RESIDUAL and of |A||x| C =========================================== IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN IF (KEEP(55).NE.0) THEN C input matrix by element CALL SMUMPS_ELTYD( MTYPE, id%N, & id%NELT, id%ELTPTR(1), id%LELTVAR, & id%ELTVAR(1), id%KEEP8(30), id%A_ELT(1), & SAVERHS, id%RHS(IBEG), & C_Y, R_W, KEEP(50)) ELSE IF ( MTYPE .eq. 1 ) THEN CALL SMUMPS_SOL_Y(id%A(1), id%KEEP8(28), & id%N, id%IRN(1), & id%JCN(1), SAVERHS, & id%RHS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ELSE CALL SMUMPS_SOL_Y(id%A(1), id%KEEP8(28), & id%N, id%JCN(1), & id%IRN(1), SAVERHS, & id%RHS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ENDIF ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- CALL MPI_BCAST( RHS_IR(IBEG), id%N, & MPI_REAL, MASTER, & id%COMM, IERR ) C -------------------------------------- C Compute Y = SAVERHS - A * RHS C Y, SAVERHS defined only on master C -------------------------------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN CALL SMUMPS_LOC_MV8( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_Y, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) C =========================== C_Y = SAVERHS - C_Y C =========================== ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) END IF C -------------------------------------- C Compute C * If MTYPE = 1 C W(i) = Sum | Aij | | RHSj | C j C * If MTYPE = 0 C W(j) = Sum | Aij | | RHSi | C i C R_LOCWK54 used as local array for W C RHS has been broadcasted C -------------------------------------- IF ( I_AM_SLAVE .and. id%KEEP8(29) .NE. 0_8 ) THEN CALL SMUMPS_LOC_OMEGA1( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), R_LOCWK54, KEEP(50), MTYPE ) ELSE R_LOCWK54 = RZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_W, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, & id%N, MPI_REAL, & MPI_SUM, MASTER, id%COMM, IERR) ENDIF ENDIF C ===================================== C END computation RESIDUAL and |A||x| C ===================================== IF ( id%MYID .eq. MASTER ) THEN C IF ((ICNTL11.GT.0).OR.(ICNTL10.GT.0)) THEN C -------------- C Error analysis and test of convergence, C Compute the sparse componentwise backward error: C - at each step if test of convergence of IR is C requested (ICNTL(10)>0) C - at step 1 and NITREF+1 if error analysis C to be computed (ICNTL(11)>0) and if ICNTL(10)< 0 IF (((ICNTL11.GT.0).OR.((ICNTL10.LT.0).AND. & ((IRStep.EQ.1).OR.(IRStep.EQ.NITREF+1))) & .OR.((ICNTL10.EQ.0).AND.(IRStep.EQ.1))) & .OR.(ICNTL10.GT.0)) THEN C Compute w1 and w2 C always if ICNTL10>0 in the other case if ICNTL11>0 C ----------------- IF (ICNTL10.LT.0) CALL MUMPS_SECDEB(TIMEEA1) CALL SMUMPS_SOL_OMEGA(id%N,SAVERHS, & id%RHS(IBEG), C_Y, R_W, C_W, IW1, IFLAG_IR, & RINFOG(7), NOITER, TESTConv, & MP, ARRET, KEEP(361), id%DKEEP(22) ) IF (ICNTL10.LT.0) THEN CALL MUMPS_SECFIN(TIMEEA1) id%DKEEP(120)=id%DKEEP(120)+real(TIMEEA1) ENDIF ENDIF IF ((ICNTL11.GT.0).AND.( & (ICNTL10.LT.0.AND.(IRStep.EQ.1.OR.IRStep.EQ.NITREF+1)) & .OR.((ICNTL10.GE.0).AND.(IRStep.EQ.1)) & )) THEN C Error analysis before iterative refinement C or for last if icntl10<0 C ------------------------------------------ CALL MUMPS_SECDEB(TIMEEA) IF (ICNTL10.EQ.0) THEN C No IR : there will be only the EA of the 1st sol. IF ( MPG .GT. 0 ) WRITE( MPG, 170 ) ELSEIF (IRStep.EQ.1) THEN C IR : we print the EA of the 1st sol. IF ( MPG .GT. 0 ) WRITE( MPG, 55 ) ELSEIF ((ICNTL10.LT.0).AND.(IRStep.EQ.NITREF+1)) THEN C IR with fixed n. of steps: we print the EA C of the last sol. IF ( MPG .GT. 0 ) THEN WRITE( MPG, 81 ) WRITE( MPG, * ) WRITE( MPG, 141 ) & 'NUMBER OF STEPS OF ITERATIVE REFINEMENT REQUESTED =', & NOITER ENDIF ENDIF GIVSOL = .TRUE. CALL SMUMPS_SOL_Q(MTYPE,INFO(1),id%N, & id%RHS(IBEG), & SAVERHS,R_W(id%N+1),C_Y,GIVSOL, & RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) IF ( MPG .GT. 0 ) THEN C Error analysis before iterative refinement WRITE( MPG, 115 ) & 'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', & RINFOG(7) WRITE( MPG, 115 ) & '------(8):---------------------------- (W2)=', & RINFOG(8) END IF CALL MUMPS_SECFIN(TIMEEA) id%DKEEP(120)=id%DKEEP(120)+real(TIMEEA) C end EA of the first solution END IF END IF C -------------- IF (IRStep.EQ.NITREF +1) THEN C If we are at the NITREF+1 step , we have refined the C solution NITREF times so we have to stop. KASE = 0 C If we test the convergence (ICNTL10.GT.0) and C IFLAG_IR = 0 we set a warning : more than NITREF steps C needed IF ((ICNTL10.GT.0).AND.(IFLAG_IR.EQ.0)) & id%INFO(1) = id%INFO(1) + 8 ELSE IF (ICNTL10.GT.0) THEN C ------------------- C Results of the test of convergence. C IFLAG_IR = 0 we should try to improve the solution C = 1 the stopping criterium is satisfied C = 2 the method is diverging, we go back C to the previous iterate C = 3 the convergence is too slow IF (IFLAG_IR.GT.0) THEN C If the convergence criterion is satisfied C or the convergence too slow C we set KASE=0 (end of the Iterative refinement) KASE = 0 C If the convergence is not improved, C we go back to the previous iterate. C IFLAG_IR can be equal to 2 only if IRStep >= 2 IF (IFLAG_IR.EQ.2) NOITER = NOITER - 1 ELSE C IFLAG_IR=0, try to improve the solution KASE = 2 ENDIF ELSEIF (ICNTL10.LT.0) THEN C ------------------- KASE = 2 ELSE C ICNTL10 = 0, we want to perform only EA and not IR. C ----------------- KASE = 0 END IF ENDIF C End Master ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C If Kase= 0 we quit the IR process IF (KASE.LE.0) GOTO 666 IF (KASE.LT.0) THEN WRITE(*,*) "Internal error 17 in SMUMPS_SOL_DRIVER" ENDIF C ========================================================= C COMPUTE the solution of Ay = r C ========================================================= C Call internal routine to avoid code duplication CALL SMUMPS_PP_SOLVE() IF (INFO(1) .LT. 0) GOTO 90 C ----------------------- C Go back to beginning of C loop to apply next step C of iterative refinement C ----------------------- 22 CONTINUE 666 CONTINUE C ************************************************ C C End of the iterative refinement procedure C C ************************************************ CALL MUMPS_SECFIN(TIMEIT) IF ( id%MYID .EQ. MASTER ) THEN IF ( NITREF .GT. 0 ) THEN id%INFOG(15) = NOITER END IF C id%DKEEP(114) time for the iterative refinement C id%DKEEP(120) time for the error analysis C id%DKEEP(121) time for condition number C these values are meaningful only on the host. IF (ICNTL10.EQ.0) THEN C No IR has been requested. All the time is needed C for computing EA id%DKEEP(120)=real(TIMEIT) ELSE C IR has been requested id%DKEEP(114)=real(TIMEIT)-id%DKEEP(120) ENDIF END IF IF ( PROKG ) THEN IF (ICNTL10.GT.0) THEN WRITE( MPG, 81 ) WRITE( MPG, * ) WRITE( MPG, 141 ) & 'NUMBER OF STEPS OF ITERATIVE REFINEMENTS PERFORMED =', & NOITER ENDIF ENDIF C C ================================================== C BEGIN C Perform error analysis after iterative refinement C ================================================== IF ((ICNTL11 .GT. 0).AND.(ICNTL10.GT.0)) THEN C If IR is requested with test of convergence, C the EA of the last step of IR is done here, C otherwise EA of the last step is done at the C end of IR CALL MUMPS_SECDEB(TIMEEA) KASE = 0 IF (id%MYID .eq. MASTER ) THEN C Test if IFLAG_IR = 2, that is if the the IR was diverging, C we went back to the previous iterate C We have to do EA on the last computed solution. IF (IFLAG_IR.EQ.2) KASE = 2 ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KASE.EQ.2) THEN C We went back to the previous iterate C We have to do EA on the last computed solution. C Compute the residual in C_Y using IRN, JCN, ASPK C and the solution RHS(IBEG) C The norm of the ith row in R_Y(I). IF ( KEEP(54) .eq. 0 ) THEN C --------------------- C Matrix is centralized C --------------------- IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN CALL SMUMPS_QD2( MTYPE, id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), & id%RHS(IBEG), SAVERHS, R_Y, C_Y, KEEP(1),KEEP8(1)) ELSE CALL SMUMPS_ELTQD2( MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), id%A_ELT(1), & id%RHS(IBEG), SAVERHS, R_Y, C_Y, KEEP(1),KEEP8(1)) ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- CALL MPI_BCAST( RHS_IR(IBEG), id%N, & MPI_REAL, MASTER, & id%COMM, IERR ) C ---------------- C Compute residual C ---------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN CALL SMUMPS_LOC_MV8( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_Y, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) C_Y = SAVERHS - C_Y ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) END IF ENDIF ENDIF ! KASE.EQ.2 IF (id%MYID .EQ. MASTER) THEN C Compute which equations are associated to w1 and which C ones are associated to w2 in case of IFLAG_IR=2. C If IFLAG_IR = 0 or 1 IW1 should be correct IF (IFLAG_IR.EQ.2) THEN TESTConv = .FALSE. CALL SMUMPS_SOL_OMEGA(id%N,SAVERHS, & id%RHS(IBEG), C_Y, R_W, C_W, IW1, IFLAG_IR, & RINFOG(7), 0, TESTConv, & MP, ARRET, KEEP(361), id%DKEEP(22) ) ENDIF ! (IFLAG_IR.EQ.2) c Compute some statistics for GIVSOL = .TRUE. CALL SMUMPS_SOL_Q(MTYPE,INFO(1),id%N, & id%RHS(IBEG), & SAVERHS,R_W(id%N+1),C_Y,GIVSOL, & RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) ENDIF ! Master CALL MUMPS_SECFIN(TIMEEA) id%DKEEP(120)=id%DKEEP(120)+real(TIMEEA) ENDIF ! ICNTL11>0 and ICNTL10>0 C ========================================================= C Compute the Condition number associated if requested. C ========================================================= CALL MUMPS_SECDEB(TIMELCOND) IF (ICNTL11 .EQ. 1) THEN IF ( id%MYID .eq. MASTER ) THEN C Notice that D is always the identity ALLOCATE( D(id%N),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 DO I = 1, id%N D( I ) = RONE END DO ENDIF KASE = 0 222 CONTINUE IF ( id%MYID .EQ. MASTER ) THEN CALL SMUMPS_SOL_LCOND(id%N, SAVERHS, & id%RHS(IBEG), C_Y, D, R_W, C_W, IW1, KASE, & RINFOG(7), RINFOG(9), RINFOG(10), & MP, KEEP(1),KEEP8(1)) ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C KASE <= 0 C We reach the end of iterative method to compute C LCOND1 and LCOND2 IF (KASE.LE.0) GOTO 224 CALL SMUMPS_PP_SOLVE() IF (INFO(1) .LT. 0) GOTO 90 C --------------------------- C Go back to beginning of C loop to apply next step C of iterative method C ----------------------- GO TO 222 C End ICNTL11 = 1 ENDIF 224 CONTINUE CALL MUMPS_SECFIN(TIMELCOND) id%DKEEP(121)=id%DKEEP(121)+real(TIMELCOND) IF ((id%MYID .EQ. MASTER).AND.(ICNTL11.GT.0)) THEN IF (ICNTL10.GT.0) THEN C If ICNTL10<0 these stats have been printed before IR IF ( MPG .GT. 0 ) THEN WRITE( MPG, 115 ) & 'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', & RINFOG(7) WRITE( MPG, 115 ) & '------(8):---------------------------- (W2)=', & RINFOG(8) ENDIF END IF IF (ICNTL11.EQ.1) THEN C If ICNTL11/=1 these stats haven't been computed IF (MPG.GT.0) THEN WRITE( MPG, 115 ) & '------(9):Upper bound ERROR ...............=', & RINFOG(9) WRITE( MPG, 115 ) & '-----(10):CONDITION NUMBER (1) ............=', & RINFOG(10) WRITE( MPG, 115 ) & '-----(11):CONDITION NUMBER (2) ............=', & RINFOG(11) END IF END IF END IF ! MASTER && ICNTL11.GT.0 IF ( PROKG ) THEN WRITE( MPG, * ) IF (abs(ICNTL10) .GT.0 ) WRITE( MPG, 101 ) id%DKEEP(114) IF (ICNTL11 .GT.0 ) WRITE( MPG, 102 ) id%DKEEP(120) IF (ICNTL11 .EQ.1 ) WRITE( MPG, 103 ) id%DKEEP(121) WRITE( MPG, * ) ENDIF IF ( PROKG .AND. abs(ICNTL10) .GT.0 ) WRITE( MPG, 131 ) C=================================================== C Perform error analysis after iterative refinements C END C=================================================== C IF (id%MYID == MASTER) THEN NB_BYTES = NB_BYTES - int(size(C_W),8)*K35_8 DEALLOCATE(C_W) NB_BYTES = NB_BYTES - int(size(R_W),8)*K16_8 & - int(size(IW1),8)*K34_8 DEALLOCATE(R_W) DEALLOCATE(IW1) IF (ICNTL11 .EQ. 1) THEN C We have used D only for LCOND1,2 NB_BYTES = NB_BYTES - int(size(D ),8)*K16_8 DEALLOCATE(D) ENDIF ENDIF NB_BYTES = NB_BYTES - & (int(size(R_Y),8)+int(size(R_LOCWK54),8))*K16_8 NB_BYTES = NB_BYTES - & (int(size(C_Y),8)+int(size(C_LOCWK54),8))*K35_8 DEALLOCATE(R_Y) DEALLOCATE(C_Y) DEALLOCATE(R_LOCWK54) DEALLOCATE(C_LOCWK54) C} End POSTPros END IF C============================================ C C ITERATIVE REFINEMENT AND/OR ERROR ANALYSIS C C END C C============================================ C ========================== C Begin reordering on master C corresponding to maximum transversal permutation C in case of centralized solution C (ICNTL21==0) C IF ( id%MYID .EQ. MASTER .AND. ICNTL21==0 & .AND. KEEP(23) .NE. 0.AND.KEEP(237).EQ.0) THEN C ((No transpose and backward performed and NO A-1) C or null space computation): permutation C must be done on solution. IF ((KEEP(221).NE.1 .AND. MTYPE .EQ. 1) & .OR. KEEP(111) .NE.0 .OR. KEEP(252).NE.0 ) THEN C Permute the solution RHS according to the column C permutation held in UNS_PERM C Column J of the permuted matrix corresponds to C column UNS_PERM(J) of the original matrix. C RHS holds the permuted solution C Note that id%N>1 since KEEP(23)=0 when id%N=1 C ALLOCATE( C_RW1( id%N ),stat =allocok ) ! temporary not in NB_BYTES IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) & WRITE(LP,*) 'could not allocate ', id%N, 'integers.' CALL MUMPS_ABORT() END IF DO K = 1, NBRHS_EFF IF (KEEP(242).EQ.0) THEN KDEC = (K-1)*LD_RHS+IBEG-1 ELSE C ------------------------------- C Columns just computed might not C be contiguous in original RHS C ------------------------------- KDEC = int(PERM_RHS(K-1+JBEG_RHS)-1,8)*int(LD_RHS,8) ENDIF DO I = 1, id%N C_RW1(I) = id%RHS(KDEC+I) ENDDO DO I = 1, id%N JPERM = id%UNS_PERM(I) id%RHS( KDEC+JPERM ) = C_RW1( I ) ENDDO ENDDO DEALLOCATE( C_RW1 ) !temporary not in NB_BYTES END IF END IF C C End reordering on master C ======================== IF (id%MYID.EQ.MASTER .and.ICNTL21==0.and.KEEP(221).NE.1.AND. & (KEEP(237).EQ.0) ) THEN * print out the solution IF ( INFO(1) .GE. 0 .AND. ICNTL(4).GE.3 .AND. ICNTL(3).GT.0) & THEN K = min(10, id%N) IF (ICNTL(4) .eq. 4 ) K = id%N J = min(10,NBRHS_EFF) IF (ICNTL(4) .eq. 4 ) J = NBRHS_EFF DO II=1, J WRITE(ICNTL(3),110) BEG_RHS+II-1 WRITE(ICNTL(3),160) & (id%RHS(IBEG+(II-1)*LD_RHS+I-1),I=1,K) ENDDO END IF END IF C ========================== C blocking for multiple RHS (END OF DO WHILE (BEG_RHS.LE.NBRHS) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN ! case of general sparse: in case of empty columns ! NBRHS_EFF might has been updated and broadcasted ! and holds the effective size of a contiguous block of ! non empty columns BEG_RHS = BEG_RHS + NBRHS_EFF ! nb of nonempty columns ELSE BEG_RHS = BEG_RHS + NBRHS ENDIF C } ENDDO C END DO WHILE (BEG_RHS.LE.id%NRHS) C ================================= C C ======================================================== C Reset RHS to zero for all remaining columns that C have not been processed because they were emtpy C ======================================================== IF ( (id%MYID.EQ.MASTER) & .AND. ( KEEP(248).NE.0 ) ! sparse RHS on input & .AND. ( KEEP(237).EQ.0 ) ! No A-1 & .AND. ( ICNTL21.EQ.0 ) ! Centralized solution & .AND. ( KEEP(221) .NE.1 ) ! Not Reduced RHS step of Schur & .AND. ( JEND_RHS .LT. id%NRHS ) & ) & THEN JBEG_NEW = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%N id%RHS(int(PERM_RHS(JBEG_NEW) -1,8)*int(LD_RHS,8)+I) & = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ELSE DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%N id%RHS(int(JBEG_NEW -1,8)*int(LD_RHS,8) + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ENDIF C ======================================================== C Reset id%SOL_loc to zero for all remaining columns that C have not been processed because they were empty C ======================================================== IF ( I_AM_SLAVE .AND. (ICNTL21.NE.0) .AND. & ( JEND_RHS .LT. id%NRHS ) .AND. KEEP(221).NE.1 ) THEN JBEG_NEW = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, NSOL_loc id%SOL_loc(int(PERM_RHS(JBEG_NEW) -1,8)* & int(id%LSOL_loc,8)+int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ELSE C DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, NSOL_loc id%SOL_loc((JBEG_NEW -1)*id%LSOL_loc + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF C C ================================================================ C Reset id%RHSINTR and id%REDRHS to zero for all remaining columns C that have not been processed because they were emtpy C ================================================================ IF ((KEEP(221).EQ.1) .AND. & ( JEND_RHS .LT. id%NRHS ) ) THEN IF (id%MYID .EQ. MASTER) THEN JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%SIZE_SCHUR id%REDRHS(int(JBEG_NEW -1,8)*int(LD_REDRHS,8) + & int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF IF (I_AM_SLAVE) THEN JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1,NBENT_RHSINTR id%RHSINTR(int(JBEG_NEW -1,8)*int(id%LD_RHSINTR,8) + & int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF C C C ! maximum size used on that proc id%INFO(26) = int(NB_BYTES_MAX / 1000000_8) C Centralize memory statistics on the host C C INFOG(30) = size of mem in bytes for solve C for the processor using largest memory C INFOG(31) = size of mem in bytes for solve C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(26), id%INFOG(30), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I10) ') & ' ** Rank of processor needing largest memory in solve :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used by this processor for solve :', & id%INFOG(30) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during solve :', & ( id%INFOG(31)-id%INFO(26) ) / id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during solve :', & id%INFOG(31) / id%NSLAVES END IF ELSE WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used for solve :', & id%INFOG(30) ENDIF END IF *=============================== *End of Solve Phase *=============================== C Store and print timings CALL MUMPS_SECFIN(TIME3) id%DKEEP(112)=real(TIME3) id%DKEEP(113)=real(TIMEC2) id%DKEEP(115)=real(TIMESCATTER2) id%DKEEP(116)=real(TIMEGATHER2) id%DKEEP(122)=real(TIMECOPYSCALE2) C Reductions of DKEEP(115,116,117,118,119,122): CALL MPI_REDUCE( id%DKEEP(115), id%DKEEP(160),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(116), id%DKEEP(161),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(117), id%DKEEP(162),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(118), id%DKEEP(163),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(119), id%DKEEP(164),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(122), id%DKEEP(165),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) C IF (PROKG) THEN WRITE ( MPG, *) WRITE ( MPG, *) "Leaving solve with ..." WRITE( MPG, 434 ) id%DKEEP(160) ! max id%DKEEP(115) WRITE( MPG, 432 ) id%DKEEP(113) ! ok without reduction WRITE( MPG, 435 ) id%DKEEP(162) ! max id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MPG, 437 ) id%DKEEP(164) ! id%DKEEP(119) WRITE( MPG, 436 ) id%DKEEP(163) ! id%DKEEP(118) WRITE( MPG, 433 ) id%DKEEP(161) ! max(DKEEP(116)) -- Gather WRITE( MPG, 431 ) id%DKEEP(165) ! max(DKEEP(122)) -- Dist. sol. ENDIF IF ( PROK ) THEN WRITE ( MP, *) WRITE ( MP, *) "Local statistics" WRITE( MP, 434 ) id%DKEEP(115) WRITE( MP, 432 ) id%DKEEP(113) WRITE( MP, 435 ) id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MP, 437 ) id%DKEEP(119) WRITE( MP, 436 ) id%DKEEP(118) WRITE( MP, 433 ) id%DKEEP(116) WRITE( MP, 431 ) id%DKEEP(122) END IF 90 CONTINUE IF (KEEP(400) .GT. 0) THEN CALL MUMPS_SOL_L0OMP_LD(KEEP(400)) ENDIF IF (INFO(1) .LT.0 ) THEN IF (INFO(1) .EQ. -80) INFO(1) = -81 ENDIF C -- related to exploit sparsity IF (associated(nodes_FWD)) THEN NB_BYTES = NB_BYTES - size(nodes_FWD) * K34_8 DEALLOCATE(nodes_FWD) NULLIFY(nodes_FWD) ENDIF IF (associated(nodes_BWD)) THEN NB_BYTES = NB_BYTES - size(nodes_BWD) * K34_8 DEALLOCATE(nodes_BWD) NULLIFY(nodes_BWD) ENDIF IF (allocated(Pruned_Sons_FWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_FWD) * K34_8 DEALLOCATE(Pruned_Sons_FWD) ENDIF IF (allocated(Pruned_Sons_BWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_BWD) * K34_8 DEALLOCATE(Pruned_Sons_BWD) ENDIF IF (SCALING_RHSINTR_FWD_ALLOCATED) THEN NB_BYTES = NB_BYTES - LSCALING_RHSINTR_FWD * K16_8 DEALLOCATE(SCALING_RHSINTR_FWD) ENDIF SCALING_RHSINTR_FWD_ALLOCATED = .FALSE. NULLIFY(SCALING_RHSINTR_FWD) IF (SCALING_RHSINTR_BWD_ALLOCATED) THEN NB_BYTES = NB_BYTES - LSCALING_RHSINTR_BWD * K16_8 DEALLOCATE(SCALING_RHSINTR_BWD) ENDIF SCALING_RHSINTR_BWD_ALLOCATED = .FALSE. NULLIFY(SCALING_RHSINTR_BWD) IF (KEEP(485) .EQ. 1) THEN KEEP(350) = KEEP350_SAVE IF (IS_LR_MOD_TO_STRUC_DONE) THEN CALL SMUMPS_BLR_MOD_TO_STRUC(id%BLRARRAY_ENCODING) CALL MUMPS_FDM_MOD_TO_STRUC('F',id%FDM_F_ENCODING, & id%INFO(1)) ENDIF ENDIF IF (KEEP(19).EQ.0.AND.KEEP(53).NE.0) THEN C restore KEEP(20) KEEP(20) = KEEP20_SAVE ENDIF IF (KEEP(201).GT.0)THEN IF (IS_INIT_OOC_DONE) THEN CALL SMUMPS_OOC_END_SOLVE(IERR) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) ENDIF C ------------------------ C Check allocation before C to deallocate (cases of C errors that could happen C before or after allocate C statement) C C Sparse RHS C Free space and reset pointers if needed IF (IRHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_SPARSE_COPY),8)*K34_8 DEALLOCATE(IRHS_SPARSE_COPY) IRHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_SPARSE_COPY) ENDIF IF (IRHS_PTR_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_PTR_COPY),8)*K34_8 DEALLOCATE(IRHS_PTR_COPY) IRHS_PTR_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_PTR_COPY) ENDIF IF (RHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(RHS_SPARSE_COPY),8)*K35_8 DEALLOCATE(RHS_SPARSE_COPY) RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_SPARSE_COPY) ENDIF IF (allocated(MAP_RHS_loc)) THEN NB_BYTES = NB_BYTES - int(size(MAP_RHS_loc),8)*K34_8 DEALLOCATE(MAP_RHS_loc) ENDIF IF (IRHS_loc_PTR_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(IRHS_loc_PTR),8)*K34_8 DEALLOCATE(IRHS_loc_PTR) NULLIFY(IRHS_loc_PTR) IRHS_loc_PTR_ALLOCATED = .FALSE. ENDIF #if defined(USE_OLD_SCALING) IF (I_AM_SLAVE.AND.LSCAL.AND.KEEP(248).EQ.-1) THEN IF (associated(scaling_data_dr%SCALING_LOC)) THEN NB_BYTES = NB_BYTES - & int(size(scaling_data_dr%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data_dr%SCALING_LOC) NULLIFY (scaling_data_dr%SCALING_LOC) ENDIF ENDIF #endif IF (allocated(PERM_RHS)) THEN NB_BYTES = NB_BYTES - int(size(PERM_RHS),8)*K34_8 DEALLOCATE(PERM_RHS) ENDIF C END A-1 IF (allocated(UNS_PERM_INV)) THEN NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 DEALLOCATE(UNS_PERM_INV) ENDIF IF (allocated(BUFR)) THEN NB_BYTES = NB_BYTES - int(size(BUFR),8)*K34_8 DEALLOCATE(BUFR) ENDIF IF ( I_AM_SLAVE ) THEN IF (allocated(RHS_BOUNDS)) THEN NB_BYTES = NB_BYTES - & int(size(RHS_BOUNDS),8)*K34_8 DEALLOCATE(RHS_BOUNDS) ENDIF IF (allocated(IWK_SOLVE)) THEN NB_BYTES = NB_BYTES - int(size(IWK_SOLVE),8)*K34_8 DEALLOCATE( IWK_SOLVE ) ENDIF IF (allocated(PTRACB)) THEN NB_BYTES = NB_BYTES - int(size(PTRACB),8)*K34_8* & int(KEEP(10),8) DEALLOCATE( PTRACB ) ENDIF IF (allocated(IWCB)) THEN NB_BYTES = NB_BYTES - int(size(IWCB),8)*K34_8 DEALLOCATE( IWCB ) ENDIF C ------------------------ C SLAVE CODE C ----------------------- C Deallocate send buffers C ----------------------- IF (id%NSLAVES .GT. 1) THEN CALL MUMPS_BUF_DEALL_CB( IERR ) CALL MUMPS_BUF_DEALL_SMALL_BUF( IERR ) ENDIF END IF C IF ( id%MYID .eq. MASTER ) THEN C ------------------------ C SAVERHS may have been C allocated only on master C ------------------------ IF (allocated(SAVERHS)) THEN NB_BYTES = NB_BYTES - int(size(SAVERHS),8)*K35_8 DEALLOCATE( SAVERHS) ENDIF C Nullify RHS_IR might have been pointing to id%RHS NULLIFY(RHS_IR) ELSE C -------------------- C Free right-hand-side C on slave processors C -------------------- IF (associated(RHS_IR)) THEN NB_BYTES = NB_BYTES - int(size(RHS_IR),8)*K35_8 DEALLOCATE(RHS_IR) NULLIFY(RHS_IR) END IF END IF IF (I_AM_SLAVE) THEN C Deallocate temporary workspace SRW3 IF (allocated(SRW3)) THEN NB_BYTES = NB_BYTES - int(size(SRW3),8)*K151_8 DEALLOCATE(SRW3) ENDIF #if defined(USE_OLD_SCALING) C Free local scaling arrays IF (LSCAL .AND. ICNTL21 .NE. 0) THEN IF (associated(scaling_data_sol%SCALING_LOC)) THEN NB_BYTES = NB_BYTES - & int(size(scaling_data_sol%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data_sol%SCALING_LOC) NULLIFY(scaling_data_sol%SCALING_LOC) ENDIF ENDIF #endif #if defined(USE_OLD_SCALING) #endif C Free memory until next call to SMUMPS IF (WK_USER_PROVIDED) THEN C S points to WK_USER provided by user C KEEP8(24) holds size of WK_USER C it should be kept on exit because it will be used C at a future solve to check that size provided is consistent C (see error -41) NULLIFY(id%S) ELSE IF (ALLOCATE_S) THEN C S was allocated, free it NB_BYTES = NB_BYTES - KEEP8(23)*K35_8 id%KEEP8(23)=0_8 DEALLOCATE(id%S) NULLIFY(id%S) NB_BYTES = NB_BYTES - KEEP8(23) * K35_8 KEEP8(23) = 0_8 ENDIF IF (KEEP(221).NE.1 & ) THEN C -- After reduction of RHS to Schur variables C -- keep compressed RHS generated during FWD step C -- to be used for future expansion IF (associated(id%RHSINTR)) THEN NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25) = 0_8 id%LD_RHSINTR = 0 ENDIF IF (associated(id%GLOB2LOC_RHS)) THEN NB_BYTES = NB_BYTES - & int(size(id%GLOB2LOC_RHS),8)*K34_8 DEALLOCATE(id%GLOB2LOC_RHS) NULLIFY(id%GLOB2LOC_RHS) ENDIF IF (id%GLOB2LOC_SOL_ALLOC) THEN NB_BYTES = NB_BYTES - & int(size(id%GLOB2LOC_SOL),8)*K34_8 DEALLOCATE(id%GLOB2LOC_SOL) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF ENDIF IF ( WORK_WCB_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(WORK_WCB),8)*K151_8 DEALLOCATE( WORK_WCB ) NULLIFY ( WORK_WCB ) ELSE C Otherwise, WORK_WCB may point to some C position inside id%S, nullify it NULLIFY( WORK_WCB ) ENDIF IF ( PTR_RHS_ROOT_ALLOCATED ) THEN DEALLOCATE(PTR_RHS_ROOT) NB_BYTES = NB_BYTES - LPTR_RHS_ROOT * K151_8 ENDIF NULLIFY(PTR_RHS_ROOT) ENDIF #if defined(STAT_ES_SOLVE) IF ( & (id%MYID.EQ.MASTER).AND. & ( (id%KEEP(235).NE.0).OR.(id%KEEP(212).NE.0) ) & ) & THEN C If exploit sparsity then C stats saved in DKEEP(200:204) and C set RINFOG(24), RINFOG(25), RINFOG(26) CALL SMUMPS_SOL_ES_PRINT_STATS( & id%KEEP(212), id%KEEP(235), id%KEEP(237), & id%KEEP(485), id%KEEP(497), & id%KEEP8(110),id%NRHS, id%ICNTL(27), id%N, & id%KEEP(50), id%DKEEP(200:204), & id%RINFOG(24:28), MPG) END IF #endif 500 CONTINUE RETURN 55 FORMAT (//' ERROR ANALYSIS BEFORE ITERATIVE REFINEMENT') 100 FORMAT(//' ****** SOLVE & CHECK STEP ********'/) 110 FORMAT (//' Vector solution for column ',I12) 115 FORMAT(1X, A44,1P,D9.2) 434 FORMAT(' Time to build/scatter RHS =',F15.6) 432 FORMAT(' Time in solution step (fwd/bwd) =',F15.6) 435 FORMAT(' .. Time in forward (fwd) step = ',F15.6) 437 FORMAT(' .. Time in ScaLAPACK root = ',F15.6) 436 FORMAT(' .. Time in backward (bwd) step = ',F15.6) 433 FORMAT(' Time to gather solution(cent.sol)=',F15.6) 431 FORMAT(' Time for distributed solution =',F15.6) 150 FORMAT(' GLOBAL STATISTICS PRIOR SOLVE PHASE ...........'/ & ' Number of right-hand-sides =',I12/ & ' Blocking factor for multiple rhs =',I12/ & ' ICNTL (9) =',I12/ & ' --- (10) =',I12/ & ' --- (11) =',I12/ & ' --- (20) =',I12/ & ' --- (21) =',I12/ & ' --- (30) =',I12/ & ' --- (35) =',I12/ & ' --- (48) (effective) =',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 ( & 2X, "Maximum number of steps = ",I4/, & 2X, "Effective stopping criterion (based on CNTL(2)) = ",E14.6/ & 2x, "Slow convergence threshold (W1+W2 ratio) = ",E14.6) 245 FORMAT ( & 2X, "Number of steps is fixed = ",I4) 270 FORMAT (/' BEGIN ITERATIVE REFINEMENT' ) 81 FORMAT (/' STATISTICS AFTER ITERATIVE REFINEMENT ') 101 FORMAT(' Time for Iterative Refinement =',F12.4) 102 FORMAT(' Time for Error Analysis =',F12.4) 103 FORMAT(' Time for Condition Number =',F12.4) 131 FORMAT (' END ITERATIVE REFINEMENT '/) 141 FORMAT(1X, A52,I4) ! Number of steps performed CONTAINS SUBROUTINE SMUMPS_CHECK_DISTRHS( & idNloc_RHS, & idLRHS_loc, & NRHS, & idIRHS_loc, & idRHS_loc, & I_AM_SLAVE, & INFO) C C Purpose: C ======= C C Check distributed RHS format. We assume that C the user has indicated that he/she provided C a distributed RHS (KEEP(248)=-1). We also C assume that the nb of RHS columns NRHS has C been broadcasted to all processes. This C routine should then be called on the workers. C C Arguments: C ========= C INTEGER, INTENT( IN ) :: idNloc_RHS INTEGER, INTENT( IN ) :: idLRHS_loc INTEGER, INTENT( IN ) :: NRHS LOGICAL, INTENT( IN ) :: I_AM_SLAVE #if defined(MUMPS_NOF2003) INTEGER, POINTER :: idIRHS_loc (:) REAL, POINTER :: idRHS_loc (:) #else INTEGER, INTENT( IN ), POINTER :: idIRHS_loc (:) REAL, INTENT( IN ), POINTER :: idRHS_loc (:) #endif INTEGER, INTENT( INOUT ) :: INFO(80) C C Local declarations: C ================== C INTEGER(8) :: REQSIZE8 C C Executable statements: C ===================== C C Quick return if nothing on this proc IF (idNloc_RHS .LE. 0) RETURN IF (idNloc_RHS .GT. 0 .AND. .NOT. I_AM_SLAVE) THEN C Nloc_RHS should not be greater than 0 C on a non working host because the distribution C of the RHS does not include the non working host. INFO(1)=-55 INFO(2)=-idLRHS_loc RETURN ENDIF C Check for leading dimension IF (NRHS.NE.1) THEN IF ( idLRHS_loc .LT. idNloc_RHS) THEN INFO(1)=-55 INFO(2)=idLRHS_loc RETURN ENDIF ENDIF IF (idNloc_RHS .GT. 0) THEN C Check association and size of index array idIRHS_loc IF (.NOT. associated(idIRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=17 RETURN ELSE IF (size(idIRHS_loc) .LT. idNloc_RHS) THEN INFO(1)=-22 INFO(2)= 17 RETURN ENDIF C Check association and size of value array idRHS_loc IF (.NOT. associated(idRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=18 RETURN ELSE C Check size of array of values idRHS_loc REQSIZE8 = int(idLRHS_loc,8)*int(NRHS,8) & + int(-idLRHS_loc+idNloc_RHS,8) #if defined(MUMPS_NOF2003) IF ( REQSIZE8 .LE. int(huge(idNloc_RHS),8) .AND. & size(idRHS_loc) .LT. int(REQSIZE8) ) THEN #else IF (size(idRHS_loc,kind=8) .LT. REQSIZE8) THEN #endif INFO(1)=-22 INFO(2)=18 RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_CHECK_DISTRHS SUBROUTINE SMUMPS_PP_SOLVE() IMPLICIT NONE C C Purpose: C ======= C Scatter right-hand side, solve the system, C and gather the solution on the host during C post-processing. C We use an internal subroutine to avoid code C duplication without the complication of adding C new parameters or local variables. All variables C in this routine have the scope of SMUMPS_SOL_DRIVER. C C IF (KASE .NE. 1 .AND. KASE .NE. 2) THEN WRITE(*,*) "Internal error 1 in SMUMPS_PP_SOLVE" CALL MUMPS_ABORT() ENDIF IF ( id%MYID .eq. MASTER ) THEN C Define matrix B as follows: C MTYPE=1 => B=A other values B=At C The user asked to solve the system Bx=b C C THEN C KASE = 1........ RW1 = INV(TRANSPOSE(B)) * RW1 C KASE = 2........ RW1 = INV(B) * RW1 IF ( MTYPE .EQ. 1 ) THEN SOLVET = KASE - 1 ELSE SOLVET = KASE END IF C SOLVET= 1 -> solve A x = B, other values solve Atx=b C We force SOLVET to have value either 0 or 1, in order C to be able to test both values, and also, be able to C test whether SOLVET = MTYPE or not. IF ( SOLVET.EQ.2 ) SOLVET = 0 #if defined(USE_OLD_SCALING) IF ( LSCAL ) THEN IF ( SOLVET .EQ. 1 ) THEN C Apply rowscaling DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%ROWSCA( K ) END DO ELSE C Apply column scaling DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%COLSCA( K ) END DO END IF END IF #endif END IF ! MYID.EQ.MASTER C ------------------------------ C Broadcast SOLVET to the slaves C ------------------------------ CALL MPI_BCAST( SOLVET, 1, MPI_INTEGER, MASTER, & id%COMM, IERR) #if ! defined(USE_OLD_SCALING) IF (LSCAL .AND. id%KEEP(89) .GT. 0) THEN IF (SOLVET .EQ. 1) THEN SCALING_LOC_FWD => id%ROWSCA_LOC ELSE SCALING_LOC_FWD => id%COLSCA_LOC ENDIF ELSE SCALING_LOC_FWD => RDUMMY_TARGET ENDIF #endif C -------------------------------------------- C Scatter the right hand side C_Y on all procs C -------------------------------------------- IF ( .NOT.I_AM_SLAVE ) THEN C -- Master not working CALL SMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, LSCAL, SCALING_LOC_FWD(1), & SOLVET, C_Y(1), id%N, 1, & 1, & C_DUMMY, 1, 1, & IDUMMY, 0, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ELSE IF (SOLVET.EQ.MTYPE) THEN C GLOB2LOC_RHS is with respect to the C original linear system (transposed or not) PTR_POSINRHSINTR_FWD => id%GLOB2LOC_RHS ELSE C Transposed, use column indices of original C system (ie, col indices of A or A^T) PTR_POSINRHSINTR_FWD => id%GLOB2LOC_SOL ENDIF LIW_PASSED = max( LIW, 1 ) CALL SMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, LSCAL, SCALING_LOC_FWD(1), & SOLVET, C_Y(1), id%N, 1, & 1, & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, 1, & PTR_POSINRHSINTR_FWD(1), NB_FS_RHSINTR_F, C & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ENDIF IF (INFO(1).LT.0) GOTO 89 C C Solve the system C IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) IF (SOLVET.EQ.MTYPE) THEN PTR_POSINRHSINTR_FWD => id%GLOB2LOC_RHS PTR_POSINRHSINTR_BWD => id%GLOB2LOC_SOL ELSE PTR_POSINRHSINTR_FWD => id%GLOB2LOC_SOL PTR_POSINRHSINTR_BWD => id%GLOB2LOC_RHS ENDIF FROM_PP=.TRUE. NBSPARSE_LOC = .FALSE. CALL SMUMPS_SOL_C(idintr%root,idintr%roota, & id%N,id%S(1),LA_PASSED,id%IS(1), & LIW_PASSED,WORK_WCB(1),LWCB8,IWCB,LIWCB,NBRHS_EFF,id%NA(1), & id%LNA,id%NE_STEPS(1),SRW3,SOLVET,ICNTL(1),FROM_PP,id%STEP(1), & id%FRERE_STEPS(1),id%DAD_STEPS(1),id%FILS(1),id%PTLUST_S(1), & id%PTRFAC(1), IWK_SOLVE(1), LIWK_SOLVE, PTRACB, LIWK_PTRACB, & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1), KEEP(1), KEEP8(1), & id%DKEEP(1),id%COMM_NODES,id%MYID,id%MYID_NODES, BUFR(1), LBUFR, & LBUFR_BYTES, id%ISTEP_TO_INIV2(1), id%TAB_POS_IN_PERE(1,1), C Next 3 arguments are not used in this call & IBEG_ROOT_DEF,IEND_ROOT_DEF,IROOT_DEF_RHS_COL1, PTR_RHS_ROOT(1), & LPTR_RHS_ROOT, SIZE_ROOT, MASTER_ROOT, id%RHSINTR(IBEG_RHSINTR), & id%LD_RHSINTR,PTR_POSINRHSINTR_FWD(1),PTR_POSINRHSINTR_BWD(1), & -1, -1, & IDUMMY(1), IDUMMY(1), & 1,1,1, IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY, 1,1, & NBSPARSE_LOC, PTR_RHS_BOUNDS(1), LPTR_RHS_BOUNDS #if defined(STAT_ES_SOLVE) & , IDUMMY, 1, JDUMMY, 1 #endif & , id%IPOOL_B_L0_OMP(1), id%LPOOL_B_L0_OMP, id%IPOOL_A_L0_OMP(1), & id%LPOOL_A_L0_OMP, id%L_VIRT_L0_OMP, id%VIRT_L0_OMP(1), & id%L_PHYS_L0_OMP, id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1), & id%PTR_LEAFS_L0_OMP(1), id%L0_OMP_MAPPING(1), id%LL0_OMP_MAPPING, & idintr%L0_OMP_FACTORS(1), id%LL0_OMP_FACTORS & ) END IF C ------------------ C Change error codes C ------------------ IF (INFO(1).eq.-2) INFO(1)=-12 IF (INFO(1).eq.-3) INFO(1)=-15 C IF (INFO(1) .GE. 0) THEN C We need a workspace of minimal size KEEP(247) C in order to unpack pieces of the solution during C SMUMPS_GATHER_SOLUTION below C - Avoid allocation if error already occurred. C - DEALLOCATE called after GATHER_SOLUTION C CWORK not needed for AM1 ALLOCATE( CWORK(max(max(KEEP(247),KEEP(246)),1)), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- 89 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) C C Return in case of error. IF (INFO(1).LT.0) RETURN C ------------------------------- C Assemble the solution on master C ------------------------------- C (Note: currently, if this part of code is executed, C then necessarily NBRHS_EFF = 1) C C === GATHER and SCALE solution ============== C #if defined(USE_OLD_SCALING) 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 #else IF (id%KEEP(89) .EQ. 0 .OR. .NOT. LSCAL) THEN SCALING_LOC_BWD => RDUMMY_TARGET ELSE IF (SOLVET.EQ.1) THEN SCALING_LOC_BWD => id%COLSCA_loc ELSE SCALING_LOC_BWD => id%ROWSCA_loc ENDIF ENDIF #endif LIW_PASSED = max( LIW, 1 ) C Solution computed during SMUMPS_SOL_C has been stored C in id%RHSINTR and is gathered on the master in C_Y IF ( .NOT. I_AM_SLAVE ) THEN C I did not participate to computing part of the solution C (id%RHSINTR not set/allocate) : receive solution, store C it and scale it. CALL SMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & SOLVET, C_Y, id%N, NBRHS_EFF, 1, & JDUMMY, id%KEEP(1),id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), size(CWORK), #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING), #else & LSCAL, SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), #endif ! RHSINTR not on non-working master & C_DUMMY, 1 , 1, IDUMMY, 1, ! for sparse permuted RHS on host & PERM_RHS, size(PERM_RHS) & ) ELSE CALL SMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & SOLVET, C_Y, id%N, NBRHS_EFF, 1, & id%PTLUST_S(1), id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), size(CWORK), #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING), #else & LSCAL, SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), #endif & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, NBRHS_EFF, & PTR_POSINRHSINTR_BWD(1), id%N, & PERM_RHS, size(PERM_RHS)) ! for sparse permuted RHS on host ENDIF DEALLOCATE( CWORK ) END SUBROUTINE SMUMPS_PP_SOLVE END SUBROUTINE SMUMPS_SOLVE_DRIVER MUMPS_5.8.1/src/sfac_mem_stack_aux.F0000664000175000017500000002300215042446437017156 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_COMPACT_FACTORS_SYM(A, LDA, NPIV, NBROW, KEEP, & SIZEA, IW ) IMPLICIT NONE INTEGER, INTENT(IN) :: LDA, NPIV, NBROW INTEGER(8), INTENT(IN) :: SIZEA INTEGER, INTENT(IN) :: IW( NPIV ) INTEGER :: KEEP(500) REAL :: A(SIZEA) INTEGER(8) :: IOLD, INEW, J8 INTEGER I , ILAST INTEGER NBROW_L_RECTANGLE_TO_MOVE INTEGER :: ICOL_BEG, ICOL_END, NBPANELS, NB_TARGET INTEGER :: NBCOLS_PANEL, NBROWS_PANEL INTEGER(8) :: SIZE_COPY LOGICAL :: OMP_FLAG IF ( NPIV .EQ. 0 ) GOTO 500 NB_TARGET = NPIV IF ( KEEP(459) .GT. 1 ) THEN CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, NB_TARGET, KEEP ) ENDIF IF ( NB_TARGET .EQ. NPIV ) THEN IF (LDA.EQ.NPIV) GOTO 500 IOLD = int(LDA + 1,8) INEW = int(NPIV + 1,8) IF (IOLD .EQ. INEW ) THEN WRITE(*,*) " Internal error in SMUMPS_COMPACT_FACTORS", & IOLD, INEW, NPIV CALL MUMPS_ABORT() ENDIF 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 ELSE ICOL_BEG = 1 NBPANELS = 0 INEW = 1_8 NBROWS_PANEL = NPIV DO WHILE ( ICOL_BEG .LE. NPIV ) NBPANELS=NBPANELS + 1 ICOL_END = min(NB_TARGET * NBPANELS, NPIV) IF ( IW( ICOL_END ) < 0 ) THEN ICOL_END = ICOL_END + 1 ENDIF NBCOLS_PANEL = ICOL_END - ICOL_BEG + 1 IOLD = int(ICOL_BEG-1,8) * int(LDA,8) + int(ICOL_BEG,8) DO I =1, NBROWS_PANEL IF (IOLD .NE. INEW) THEN DO J8=0, min(I+1, NBCOLS_PANEL)-1 A(INEW+J8) = A(IOLD+J8) ENDDO ENDIF INEW = INEW + int(NBCOLS_PANEL,8) IOLD = IOLD + int(LDA,8) ENDDO NBROWS_PANEL = NBROWS_PANEL - NBCOLS_PANEL ICOL_BEG = ICOL_END + 1 ENDDO IOLD = 1_8 + int(LDA,8)*int(NPIV,8) ENDIF NBROW_L_RECTANGLE_TO_MOVE = NBROW SIZE_COPY = int(NBROW_L_RECTANGLE_TO_MOVE,8) * int(NPIV,8) OMP_FLAG = SIZE_COPY .GT. int(KEEP(361),8) .AND. KEEP(405).EQ.0 IF (OMP_FLAG &) THEN !$OMP PARALLEL DO COLLAPSE(2) DO I = 0, NBROW_L_RECTANGLE_TO_MOVE-1 DO J8 = 0_8, int(NPIV - 1,8) A( INEW + J8 + int(I,8)*int(NPIV,8) ) = & A( IOLD + J8 + int(I,8)*int(LDA,8)) END DO ENDDO !$OMP END PARALLEL DO ELSE DO I = 0, NBROW_L_RECTANGLE_TO_MOVE-1 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 ENDIF 500 RETURN END SUBROUTINE SMUMPS_COMPACT_FACTORS_SYM SUBROUTINE SMUMPS_COMPACT_FACTORS_UNSYM(A, LDA, NPIV, NCONTIG, & KEEP, SIZEA ) IMPLICIT NONE INTEGER, INTENT(IN) :: NCONTIG, NPIV, LDA INTEGER(8), INTENT(IN) :: SIZEA REAL, INTENT(INOUT) :: A(SIZEA) INTEGER, INTENT(IN) :: KEEP(500) INTEGER I INTEGER(8) :: IDEST, ISRC INTEGER(8) :: J8 INTEGER :: NBLK2COPY INTEGER(8) :: IBLK, NBLK IF (int(NCONTIG,8) * int(NPIV,8) .LE. int(KEEP(361),8) & ) THEN IDEST = int(NPIV+1,8) ISRC = int(LDA+1,8) DO I = 2, NCONTIG DO J8 = 0_8, int(NPIV-1,8) A(IDEST+J8)=A(ISRC+J8) ENDDO ISRC = ISRC + int(LDA,8) IDEST = IDEST + int(NPIV,8) ENDDO ELSE NBLK2COPY = NCONTIG-1 IDEST = int(NPIV+1,8) ISRC = int(LDA+1,8) DO WHILE ( NBLK2COPY .GT. 0 .AND. & ISRC - IDEST .LT. int(max(KEEP(361),NPIV),8) ) DO J8 = 0, int(NPIV-1,8) A(IDEST+J8) = A(ISRC+J8) ENDDO ISRC = ISRC + int(LDA,8) IDEST = IDEST + int(NPIV,8) NBLK2COPY = NBLK2COPY - 1 END DO DO WHILE ( NBLK2COPY .GT. 0 ) NBLK = min( (ISRC - IDEST) / int(NPIV,8), int(NBLK2COPY,8) ) !$OMP PARALLEL DO COLLAPSE(2) DO IBLK = 0_8, NBLK - 1_8 DO J8 = 0_8, int(NPIV-1,8) A( IDEST + J8 + IBLK * int(NPIV,8) ) = & A( ISRC + J8 + IBLK * int(LDA,8) ) ENDDO ENDDO !$OMP END PARALLEL DO NBLK2COPY = NBLK2COPY - int(NBLK) ISRC = ISRC + NBLK * int(LDA,8) IDEST = IDEST + NBLK * int(NPIV,8) ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_COMPACT_FACTORS_UNSYM SUBROUTINE SMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, POSELT, & IPTRLU, NPIV, & NBCOL_STACK, NBROW_STACK, & NBROW_SEND, SIZECB, KEEP, PACKED_CB, & LAST_ALLOWED, NBROW_ALREADY_STACKED ) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: PACKED_CB REAL A(LA) INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND INTEGER, intent(inout) :: NBROW_ALREADY_STACKED INTEGER(8), intent(in) :: LAST_ALLOWED INTEGER(8) :: APOS, NPOS INTEGER NBROW INTEGER(8) :: J INTEGER I, KEEP(500) #if defined(ZERO_TRIANGLE) REAL ZERO PARAMETER( ZERO = 0.0E0 ) #endif NBROW = NBROW_STACK + NBROW_SEND IF (NBROW_STACK .NE. 0 ) THEN NPOS = IPTRLU + SIZECB APOS = POSELT + int(NPIV+NBROW,8) & * int(LDA,8) - 1_8 IF ( KEEP(50) .EQ. 0 .OR. .NOT. PACKED_CB ) THEN APOS = APOS - int(LDA,8) * int(NBROW_ALREADY_STACKED,8) NPOS = NPOS & - int(NBCOL_STACK,8) * int(NBROW_ALREADY_STACKED,8) ELSE APOS = APOS - int(LDA - 1,8) * int(NBROW_ALREADY_STACKED,8) NPOS = NPOS - ( int(NBROW_ALREADY_STACKED,8) * & int(NBROW_ALREADY_STACKED+1,8) ) / 2_8 ENDIF DO I = NBROW - NBROW_ALREADY_STACKED, NBROW_SEND+1, -1 IF (KEEP(50).EQ.0) THEN IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. & LAST_ALLOWED ) THEN EXIT ENDIF DO J= 1_8,int(NBCOL_STACK,8) A(NPOS-J+1_8) = A(APOS-J+1_8) ENDDO NPOS = NPOS - int(NBCOL_STACK,8) ELSE IF (.NOT. PACKED_CB) THEN IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. & LAST_ALLOWED ) THEN EXIT ENDIF #if defined(ZERO_TRIANGLE) DO J = 1_8, int(NBCOL_STACK - I,8) A(NPOS - J + 1_8) = ZERO END DO #endif NPOS = NPOS + int(- NBCOL_STACK + I,8) ENDIF IF ( NPOS - int(I,8) + 1_8 .LT. LAST_ALLOWED ) THEN EXIT ENDIF DO J =1_8, int(I,8) A(NPOS-J+1_8) = A(APOS-J+1_8) ENDDO NPOS = NPOS - int(I,8) ENDIF IF (KEEP(50).EQ.0) THEN APOS = APOS - int(LDA,8) ELSE APOS = APOS - int(LDA + 1,8) ENDIF NBROW_ALREADY_STACKED = NBROW_ALREADY_STACKED + 1 ENDDO END IF RETURN END SUBROUTINE SMUMPS_COPY_CB_RIGHT_TO_LEFT SUBROUTINE SMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, POSELT, & IPTRLU, NPIV, & NBCOL_STACK, NBROW_STACK, & NBROW_SEND, SIZECB, KEEP, PACKED_CB) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: PACKED_CB REAL A(LA) INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND INTEGER(8) :: APOS, NPOS, APOS_ini, NPOS_ini INTEGER I, KEEP(500) INTEGER(8) :: J, LDA8 #if defined(ZERO_TRIANGLE) REAL ZERO PARAMETER( ZERO = 0.0E0 ) #endif LDA8 = int(LDA,8) NPOS_ini = IPTRLU + 1_8 APOS_ini = POSELT + int(NPIV+NBROW_SEND,8)* LDA8 + int(NPIV,8) !$OMP PARALLEL DO PRIVATE(J, NPOS, APOS) IF (NBROW_STACK > KEEP(360)) DO I = 1, NBROW_STACK IF (PACKED_CB) THEN NPOS = NPOS_ini + int(I-1,8) * int(I,8)/2_8 + & int(I-1,8) * int(NBROW_SEND,8) ELSE NPOS = NPOS_ini + int(I-1,8) * int(NBCOL_STACK,8) ENDIF APOS = APOS_ini + int(I-1,8) * LDA8 IF (KEEP(50).EQ.0) THEN DO J = 1_8, int(NBCOL_STACK,8) A(NPOS+J-1_8) = A(APOS+J-1_8) ENDDO ELSE DO J = 1_8, int(I + NBROW_SEND,8) A(NPOS+J-1_8)=A(APOS+J-1_8) ENDDO #if defined(ZERO_TRIANGLE) IF (.NOT. PACKED_CB) THEN A(NPOS+int(I+NBROW_SEND,8): & NPOS+int(NBCOL_STACK-1,8))=ZERO ENDIF #endif ENDIF ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE SMUMPS_COPY_CB_LEFT_TO_RIGHT MUMPS_5.8.1/src/zmumps_gpu.h0000664000175000017500000000114315042446422015606 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef ZMUMPS_GPU_H #define ZMUMPS_GPU_H #include "mumps_compat.h" #include "mumps_common.h" void MUMPS_CALL zmumps_gpu_return(); #endif /* ZMUMPS_GPU_H */ MUMPS_5.8.1/src/mumps_common.h0000664000175000017500000001030215042446422016106 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_COMMON_H #define MUMPS_COMMON_H #include "mumps_compat.h" #include "mumps_c_types.h" /** * F_SYMBOL is a macro that converts a couple (lower case symbol, upper * case symbol) into the symbol defined by the compiler convention. * Example: For MUMPS_XXX, first define * #define MUMPS_XXX F_SYMBOL(xxx,XXX) and then use * MUMPS_XXX in the code to get rid of any symbol convention annoyance. * * NB: We need to provide both upper and lower case versions because to our * knowledge, there is no way to perform the conversion with CPP * directives only. */ #if defined(UPPER) || defined(MUMPS_WIN32) # define F_SYMBOL(lower_case,upper_case) MUMPS_##upper_case #elif defined(Add_) # define F_SYMBOL(lower_case,upper_case) mumps_##lower_case##_ #elif defined(Add__) # define F_SYMBOL(lower_case,upper_case) mumps_##lower_case##__ #else # define F_SYMBOL(lower_case,upper_case) mumps_##lower_case #endif MUMPS_INT* mumps_get_mapping(); #define MUMPS_ASSIGN_MAPPING \ F_SYMBOL(assign_mapping,ASSIGN_MAPPING) void MUMPS_CALL MUMPS_ASSIGN_MAPPING(MUMPS_INT *f77mapping); #define MUMPS_NULLIFY_C_MAPPING F_SYMBOL(nullify_c_mapping,NULLIFY_C_MAPPING) void MUMPS_CALL MUMPS_NULLIFY_C_MAPPING(); MUMPS_INT* mumps_get_pivnul_list(); #define MUMPS_ASSIGN_PIVNUL_LIST \ F_SYMBOL(assign_pivnul_list,ASSIGN_PIVNUL_LIST) void MUMPS_CALL MUMPS_ASSIGN_PIVNUL_LIST(MUMPS_INT *f77pivnul_list); #define MUMPS_NULLIFY_C_PIVNUL_LIST \ F_SYMBOL(nullify_c_pivnul_list,NULLIFY_C_PIVNUL_LIST) void MUMPS_CALL MUMPS_NULLIFY_C_PIVNUL_LIST(); MUMPS_INT* mumps_get_uns_perm(); #define MUMPS_ASSIGN_UNS_PERM \ F_SYMBOL(assign_uns_perm,ASSIGN_UNS_PERM) void MUMPS_CALL MUMPS_ASSIGN_UNS_PERM(MUMPS_INT *f77sym_perm); #define MUMPS_NULLIFY_C_UNS_PERM \ F_SYMBOL(nullify_c_uns_perm,NULLIFY_C_UNS_PERM) void MUMPS_CALL MUMPS_NULLIFY_C_UNS_PERM(); MUMPS_INT* mumps_get_sym_perm(); #define MUMPS_ASSIGN_SYM_PERM \ F_SYMBOL(assign_sym_perm,ASSIGN_SYM_PERM) void MUMPS_CALL MUMPS_ASSIGN_SYM_PERM(MUMPS_INT * f77sym_perm); #define MUMPS_NULLIFY_C_SYM_PERM \ F_SYMBOL(nullify_c_sym_perm,NULLIFY_C_SYM_PERM) void MUMPS_CALL MUMPS_NULLIFY_C_SYM_PERM(); MUMPS_INT* mumps_get_glob2loc_rhs(); #define MUMPS_ASSIGN_GLOB2LOC_RHS \ F_SYMBOL(assign_glob2loc_rhs,ASSIGN_GLOB2LOC_RHS) void MUMPS_CALL MUMPS_ASSIGN_GLOB2LOC_RHS(MUMPS_INT * f77glob2loc_rhs); #define MUMPS_NULLIFY_C_GLOB2LOC_RHS \ F_SYMBOL(nullify_c_glob2loc_rhs,NULLIFY_C_GLOB2LOC_RHS) void MUMPS_CALL MUMPS_NULLIFY_C_GLOB2LOC_RHS(); MUMPS_INT* mumps_get_glob2loc_sol(); #define MUMPS_ASSIGN_GLOB2LOC_SOL \ F_SYMBOL(assign_glob2loc_sol,ASSIGN_GLOB2LOC_SOL) void MUMPS_CALL MUMPS_ASSIGN_GLOB2LOC_SOL(MUMPS_INT * f77glob2loc_sol); #define MUMPS_NULLIFY_C_GLOB2LOC_SOL \ F_SYMBOL(nullify_c_glob2loc_sol,NULLIFY_C_GLOB2LOC_SOL) void MUMPS_CALL MUMPS_NULLIFY_C_GLOB2LOC_SOL(); #define MUMPS_ICOPY_32TO64_64C_IP_C \ F_SYMBOL(icopy_32to64_64c_ip_c,ICOPY_32TO64_64C_IP_C) void MUMPS_CALL MUMPS_ICOPY_32TO64_64C_IP_C(MUMPS_INT *inouttab, MUMPS_INT8 *sizetab); #define MUMPS_ICOPY_64TO32_64C_IP_C \ F_SYMBOL(icopy_64to32_64c_ip_c,ICOPY_64TO32_64C_IP_C) void MUMPS_CALL MUMPS_ICOPY_64to32_64C_IP_C(MUMPS_INT8 *inouttab, MUMPS_INT8 *sizetab); #define MUMPS_MALLOC_C \ F_SYMBOL(malloc_c,MALLOC_C) void MUMPS_CALL MUMPS_MALLOC_C(MUMPS_INT8 *address, MUMPS_INT8 *size); #define MUMPS_FREE_C \ F_SYMBOL(free_c,FREE_C) void MUMPS_CALL MUMPS_FREE_C(void *address); #define MUMPS_RCOPY_32TO64_64C_IP_C \ F_SYMBOL(rcopy_32to64_64c_ip_c,RCOPY_32TO64_64C_IP_C) void MUMPS_CALL MUMPS_RCOPY_32TO64_64C_IP_C(float *inouttab, MUMPS_INT8 *sizetab); #define MUMPS_RCOPY_64TO32_64C_IP_C \ F_SYMBOL(rcopy_64to32_64c_ip_c,RCOPY_64TO32_64C_IP_C) void MUMPS_CALL MUMPS_RCOPY_64to32_64C_IP_C(double *inouttab, MUMPS_INT8 *sizetab); #endif /* MUMPS_COMMON_H */ MUMPS_5.8.1/src/zfac_front_type2_aux.F0000664000175000017500000007565515042446441017515 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_FRONT_TYPE2_AUX_M CONTAINS SUBROUTINE ZMUMPS_FAC_I_LDLT_NIV2( & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, & NFRONT, NASS, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK, & NASS2, TIPIV, & N, INODE, IW, LIW, A, LA, NNEGW, NNULLNEGW, & NB22T2W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INOPV, IFLAG,IERROR, & IOLDPS, POSELT, UU, & SEUIL,KEEP,KEEP8,PIVSIZ, & DKEEP, PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & PP_FIRST2SWAP_L, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled, & PIVOT_OPTION, & Inextpiv, IEND_BLR, LR_ACTIVATED, & OOC_EFFECTIVE_ON_FRONT) USE MUMPS_OOC_COMMON, ONLY : TYPEF_L USE ZMUMPS_FAC_FRONT_AUX_M USE MUMPS_PIVNUL_MOD IMPLICIT NONE INTEGER SIZEDIAG_ORIG DOUBLE PRECISION DIAG_ORIG(SIZEDIAG_ORIG) DOUBLE PRECISION GW_FACTCUMUL INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,IERROR,INOPV INTEGER NASS2, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK INTEGER, intent(inout) :: NNEGW, NNULLNEGW, NB22T2W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW INTEGER TIPIV( NASS2 ) INTEGER PIVSIZ,LPIV INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER(8) :: LA COMPLEX(kind=8) A(LA) DOUBLE PRECISION UU, UULOC, SEUIL COMPLEX(kind=8) CSEUIL INTEGER IW(LIW) INTEGER IOLDPS INTEGER(8) :: POSELT INTEGER KEEP(500) INTEGER(8) KEEP8(150) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT LOGICAL :: SWAP_OCCURRED DOUBLE PRECISION DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled include 'mpif.h' INTEGER(8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX INTEGER :: IPIVNUL, HF DOUBLE PRECISION RMAX,AMAX,TMAX,RMAX_NORELAX,MAX_PREV_in_PARPIV DOUBLE PRECISION MAXPIV, ABS_PIVOT DOUBLE PRECISION RMAX_NOSLAVE, TMAX_NOSLAVE COMPLEX(kind=8) PIVOT,DETPIV DOUBLE PRECISION ABSDETPIV INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX, APOSROW INTEGER(8) :: APOS INTEGER(8) :: J1, J2, JJ, KK DOUBLE PRECISION :: GROWTH, RSWOP DOUBLE PRECISION :: UULOCM1 INTEGER :: LDAFS INTEGER(8) :: LDAFS8 DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: RONE = 1.0D0 COMPLEX(kind=8) ZERO, ONE PARAMETER( ZERO = (0.0D0,0.0D0) ) PARAMETER( ONE = (1.0D0,0.0D0) ) DOUBLE PRECISION PIVNUL, VALTMP COMPLEX(kind=8) FIXA INTEGER NPIV,IPIV,K219 INTEGER NPIVP1,ILOC,K,J INTEGER ISHIFT, K206, IPIV_END, IPIV_SHIFT INTRINSIC max INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L DOUBLE PRECISION GW_FACT GW_FACT = RONE AMAX = RZERO RMAX = RZERO TMAX = RZERO RMAX_NOSLAVE = RZERO PIVOT = ONE HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) K206 = KEEP(206) PIVNUL = DKEEP(1) FIXA = cmplx(DKEEP(2),kind=kind(FIXA)) CSEUIL = cmplx(SEUIL,kind=kind(CSEUIL)) LDAFS = NASS LDAFS8 = int(LDAFS,8) IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+KEEP(IXSZ)) & +KEEP(IXSZ), & IW, LIW) ENDIF UULOC = UU K219 = KEEP(219) IF (UULOC.GT.RZERO) THEN UULOCM1 = RONE/UULOC ELSE K219=0 UULOCM1 = RONE ENDIF IF (K219.LT.2) GW_FACTCUMUL = RONE PIVSIZ = 1 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NPIVP1 = NPIV + 1 ILOC = NPIVP1 - IBEG_BLOCK_TO_SEND + 1 TIPIV( ILOC ) = ILOC APOSMAX = POSELT+LDAFS8*LDAFS8-1_8 IF(INOPV .EQ. -1) THEN APOS = POSELT + LDAFS8*int(NPIVP1-1,8) + int(NPIV,8) POSPV1 = APOS ABS_PIVOT = abs(PIVOT) CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, & DKEEP, KEEP, .TRUE.) IF(ABS_PIVOT.LT.SEUIL) THEN IF(dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE.0 ) THEN CALL ZMUMPS_UPDATEDETER( A(APOS), DET_MANTW, DET_EXPW ) ENDIF IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 IF ((K219.GE.2).AND.(NPIVP1.EQ.1)) THEN GW_FACTCUMUL = RONE IF (K219.EQ.3) THEN DO IPIV=1,NASS DIAG_ORIG (IPIV) = abs(A(POSELT + & (LDAFS8+1_8)*int(IPIV-1,8))) ENDDO ELSE IF (K219.GE.4) THEN DIAG_ORIG = RZERO DO IPIV=1,NASS APOS = POSELT + LDAFS8*int(IPIV-1,8) POSPV1 = APOS + int(IPIV - 1,8) DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) DO J=IPIV+1,NASS DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) DIAG_ORIG(IPIV+J-IPIV) = max( abs(A(POSPV1)), & DIAG_ORIG(IPIV+J-IPIV) ) POSPV1 = POSPV1 + LDAFS8 ENDDO ENDDO ENDIF ENDIF ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + LDAFS8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN IF(ABS_PIVOT.LT.SEUIL) THEN CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, & DKEEP, KEEP, .TRUE.) IF(dble(PIVOT) .GE. RZERO) THEN A(POSPV1) = CSEUIL ELSE A(POSPV1) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (ABS_PIVOT.EQ.RZERO) THEN GO TO 630 ELSE CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF ENDIF GO TO 420 ENDIF AMAX = -RONE JMAX = 0 J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDAFS8 DO J=1, IEND_BLOCK - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDAFS8 ENDDO RMAX_NOSLAVE = RZERO IF (PIVOT_OPTION.EQ.2) THEN DO J=1,NASS - IEND_BLOCK RMAX_NOSLAVE = max(abs(A(J1+LDAFS8*int(J-1,8))), & RMAX_NOSLAVE) ENDDO ENDIF IF (K219.NE.0) THEN RMAX_NORELAX = dble(A(APOSMAX+int(IPIV,8))) RMAX = RMAX_NORELAX IF (K219.GE.2) THEN IF (ABS_PIVOT.NE.RZERO.AND. & ABS_PIVOT.GE.UULOC*max(RMAX,RMAX_NOSLAVE,AMAX)) & THEN GROWTH = RONE IF (K219.EQ.3) THEN IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN DIAG_ORIG(IPIV) = ABS_PIVOT ELSE GROWTH = ABS_PIVOT / DIAG_ORIG(IPIV) ENDIF ELSE IF (K219.GE.4) THEN IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN DIAG_ORIG(IPIV) = max(AMAX,RMAX_NOSLAVE) ELSE GROWTH = max(ABS_PIVOT,AMAX,RMAX_NOSLAVE)/ & DIAG_ORIG(IPIV) ENDIF ENDIF RMAX = RMAX*max(GROWTH,GW_FACTCUMUL) ENDIF ENDIF ELSE RMAX = RZERO RMAX_NORELAX = RZERO ENDIF RMAX_NOSLAVE = max(RMAX_NORELAX,RMAX_NOSLAVE) RMAX = max(RMAX,RMAX_NOSLAVE) IF (max(AMAX,RMAX,ABS_PIVOT).LE.PIVNUL) THEN IF ((K219.NE.0) & .AND.(K219.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & dble(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + LDAFS8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) THEN GOTO 460 ENDIF ENDDO ENDIF ENDIF CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(POSPV1)), DKEEP, KEEP, .TRUE.) KEEP(109) = KEEP(109) + 1 IPIVNUL = KEEP(109) IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST.LT.KEEP(109)) & THEN CALL MUMPS_RESIZE_PIVNUL(KEEP, N, PIVNUL_LIST_STRUCT, & IPIVNUL, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 430 ENDIF PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) IF (dble(FIXA).GT.RZERO) THEN IF(dble(PIVOT) .GE. RZERO) THEN A(POSPV1) = FIXA ELSE A(POSPV1) = -FIXA ENDIF ELSE J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 A(JJ) = ZERO ENDDO DO J=1, NASS-IPIV A(POSPV1+int(J,8)*LDAFS8) = ZERO ENDDO VALTMP = max(1.0D10*RMAX, sqrt(huge(RMAX))/1.0D8) A(POSPV1) = cmplx(VALTMP,kind=kind(A)) ENDIF PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) GO TO 415 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF (ABS_PIVOT.GE.UULOC*max(RMAX,AMAX) & .AND. ABS_PIVOT .GT. max(SEUIL, tiny(RMAX))) THEN CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL ZMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) THEN GOTO 460 ELSE IF (JMAX .EQ.0) THEN GOTO 460 ENDIF IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN GOTO 460 ENDIF IF (RMAX_NOSLAVE.LT.AMAX) THEN J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN RMAX_NOSLAVE = max(RMAX_NOSLAVE,abs(A(JJ))) ENDIF ENDDO DO J=1,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX_NOSLAVE = max(abs(A(POSPV1+LDAFS8*int(J,8))), & RMAX_NOSLAVE) ENDIF ENDDO RMAX = max(RMAX, RMAX_NOSLAVE) ENDIF APOSJ = POSELT + int(JMAX-1,8)*LDAFS8 + int(NPIV,8) POSPV2 = APOSJ + int(JMAX - NPIVP1,8) IF (IPIV.LT.JMAX) THEN OFFDAG = APOSJ + int(IPIV - NPIVP1,8) ELSE OFFDAG = APOS + int(JMAX - NPIVP1,8) END IF TMAX_NOSLAVE = RZERO IF(JMAX .LT. IPIV) THEN JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+LDAFS8 IF (JMAX+K.NE.IPIV) THEN TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) ENDIF ENDDO DO KK = APOSJ, POSPV2-1_8 TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) ENDDO ELSE JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+LDAFS8 TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) ENDDO DO KK = APOSJ, POSPV2 - 1_8 IF (KK.NE.OFFDAG) THEN TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) ENDIF ENDDO ENDIF IF (K219.NE.0) THEN TMAX = max(SEUIL*UULOCM1, & abs(dble(A(APOSMAX+int(JMAX,8)))) & ) ELSE TMAX = SEUIL*UULOCM1 ENDIF IF (K219.GE.2) THEN GROWTH = RONE IF (K219.EQ.3) THEN IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN DIAG_ORIG(JMAX) = abs(A(POSPV2)) ELSE GROWTH = abs(A(POSPV2))/DIAG_ORIG(JMAX) ENDIF ELSE IF (K219.EQ.4) THEN IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN DIAG_ORIG(JMAX)=max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) ELSE GROWTH = max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) & / DIAG_ORIG(JMAX) ENDIF ENDIF TMAX = TMAX*max(GROWTH,GW_FACTCUMUL) ENDIF TMAX = max (TMAX,TMAX_NOSLAVE) DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)*A(OFFDAG) ABSDETPIV = abs(DETPIV) IF (SEUIL.GT.RZERO) THEN IF (sqrt(ABSDETPIV) .LE. SEUIL ) THEN GOTO 460 ENDIF ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN GO TO 460 ENDIF IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN GO TO 460 ENDIF CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( sqrt(abs(DETPIV)), & DKEEP, KEEP, .FALSE.) IF (KEEP(258).NE.0) THEN CALL ZMUMPS_UPDATEDETER(DETPIV, DET_MANTW, DET_EXPW ) ENDIF PIVSIZ = 2 NB22T2W = NB22T2W+1 415 CONTINUE IF (K206.GE.1) THEN Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) ENDIF DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2 ) THEN IF (K==1) THEN LPIV = min(IPIV, JMAX) TIPIV(ILOC) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) ELSE LPIV = max(IPIV, JMAX) TIPIV(ILOC+1) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) ENDIF ELSE LPIV = IPIV TIPIV(ILOC) = IPIV - IBEG_BLOCK_TO_SEND + 1 ENDIF IF (LPIV.EQ.NPIVP1) THEN GOTO 416 ENDIF KEEP8(80) = KEEP8(80)+1 CALL ZMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDAFS, NFRONT, 2, K219, KEEP(50), & KEEP(IXSZ), IBEG_BLOCK_TO_SEND ) SWAP_OCCURRED = .TRUE. IF (K219.GE.3) THEN RSWOP = DIAG_ORIG(LPIV) DIAG_ORIG(LPIV) = DIAG_ORIG(NPIVP1) DIAG_ORIG(NPIVP1) = RSWOP ENDIF 416 CONTINUE IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL ZMUMPS_STORE_PERMINFO( & IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF NPIVP1 = NPIVP1+1 ENDDO IF(PIVSIZ .EQ. 2) THEN A(POSELT+LDAFS8*int(NPIV,8)+int(NPIV+1,8)) = DETPIV ENDIF GOTO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE IFLAG = -10 420 CONTINUE IF (K219.GE.2) THEN IF(INOPV .EQ. 0) THEN IF(PIVSIZ .EQ. 1) THEN GW_FACT = max(AMAX,RMAX_NOSLAVE)/ABS_PIVOT ELSE IF(PIVSIZ .EQ. 2) THEN GW_FACT = max( & (abs(A(POSPV2))*RMAX_NOSLAVE+AMAX*TMAX_NOSLAVE) & / ABSDETPIV , & (abs(A(POSPV1))*TMAX_NOSLAVE+AMAX*RMAX_NOSLAVE) & / ABSDETPIV & ) ENDIF GW_FACT = min(GW_FACT, UULOCM1) GW_FACTCUMUL = max(GW_FACT,GW_FACTCUMUL) ENDIF ENDIF 430 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_I_LDLT_NIV2 SUBROUTINE ZMUMPS_FAC_MQ_LDLT_NIV2 & (IEND_BLOCK, & NASS, NPIV, INODE, A, LA, LDAFS, & POSELT,IFINB,PIVSIZ, & K219, PIVOT_OPTION, IEND_BLR, LR_ACTIVATED) IMPLICIT NONE INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: K219 COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER, intent(in) :: IEND_BLOCK INTEGER, intent(in) :: NPIV, PIVSIZ INTEGER, intent(in) :: NASS,INODE,LDAFS INTEGER, intent(out) :: IFINB INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED COMPLEX(kind=8) VALPIV INTEGER NCB1 INTEGER(8) :: APOS, APOSMAX INTEGER(8) :: LPOS, LPOS1, LPOS2, K1POS INTEGER(8) :: JJ, K1, K2 INTEGER(8) :: POSPV1, POSPV2, OFFDAG, OFFDAG_OLD INTEGER(8) :: LDAFS8 INTEGER NEL2 COMPLEX(kind=8) ONE, ALPHA COMPLEX(kind=8) ZERO INTEGER NPIV_NEW, I INTEGER(8) :: IBEG, IEND, IROW, J8 INTEGER :: J2 COMPLEX(kind=8) SWOP,DETPIV,MULT1,MULT2, A11, A22, A12 PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) INCLUDE 'mumps_headers.h' LDAFS8 = int(LDAFS,8) NPIV_NEW = NPIV + PIVSIZ IFINB = 0 NEL2 = IEND_BLOCK - NPIV_NEW IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ENDIF IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDAFS8 DO I = 1, NEL2 K1POS = LPOS + int(I-1,8)*LDAFS8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ=1_8, int(I,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO IF (PIVOT_OPTION.EQ.2) THEN NCB1 = NASS - IEND_BLOCK ELSE NCB1 = IEND_BLR - IEND_BLOCK ENDIF !$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) DO I=NEL2+1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDAFS8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO !$OMP END PARALLEL DO IF (K219.eq. -1) THEN APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) A(APOSMAX) = A(APOSMAX) * abs(VALPIV) DO J8 = 1_8, int(NEL2+NCB1,8) A(APOSMAX+J8) = A(APOSMAX+J8) + & A(APOSMAX) * abs(A(APOS+J8)) ENDDO ENDIF ELSE POSPV1 = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) POSPV2 = POSPV1+LDAFS8+1_8 OFFDAG_OLD = POSPV2 - 1_8 OFFDAG = POSPV1+1_8 SWOP = A(POSPV2) DETPIV = A(OFFDAG) A22 = A(POSPV1)/DETPIV A11 = SWOP/DETPIV A12 = -A(OFFDAG_OLD)/DETPIV A(OFFDAG) = A(OFFDAG_OLD) A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDAFS8 - 1_8 LPOS2 = LPOS1 + 1_8 CALL zcopy(NASS-NPIV_NEW, A(LPOS1), LDAFS, A(POSPV1+2_8), 1) CALL zcopy(NASS-NPIV_NEW, A(LPOS2), LDAFS, A(POSPV2+1_8), 1) JJ = POSPV2 + int(NASS-1,8) IBEG = JJ + 2_8 IEND = IBEG DO J2 = 1,NEL2 K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1+2_8 K2 = POSPV2+1_8 DO IROW = IBEG,IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = -MULT1 A(JJ+1_8) = -MULT2 IBEG = IBEG + int(NASS,8) IEND = IEND + int(NASS + 1,8) JJ = JJ+int(NASS,8) ENDDO IEND = IEND-1_8 DO J2 = IEND_BLOCK+1,NASS K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1+2_8 K2 = POSPV2+1_8 DO IROW = IBEG,IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = -MULT1 A(JJ+1_8) = -MULT2 IBEG = IBEG + int(NASS,8) IEND = IEND + int(NASS,8) JJ = JJ+int(NASS,8) ENDDO IF (K219.eq. -1) THEN APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) JJ = APOSMAX K1 = JJ K2 = JJ + 1_8 MULT1 = abs(A11)*A(K1)+abs(A12)*A(K2) MULT2 = abs(A12)*A(K1)+abs(A22)*A(K2) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 IBEG = APOSMAX + 2_8 IEND = APOSMAX + 1_8 + NASS - NPIV_NEW DO IROW = IBEG, IEND A(IROW) = A(IROW) + MULT1*abs(A(K1)) + MULT2*abs(A(K2)) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = MULT1 A(JJ+1_8) = MULT2 ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_MQ_LDLT_NIV2 SUBROUTINE ZMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, N, & INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, LDA_FS, & IBEG_PANEL, IEND, TIPIV, LPIV, LASTPANEL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED, NPARTSASS, CURRENT_BLR_PANEL & , BLR_LorU & , LRGROUPS & ) USE ZMUMPS_BUF USE MUMPS_LOAD USE ZMUMPS_LR_TYPE USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, IBEG_PANEL, IEND, LPIV, & IOLDPS, LDA_FS, NB_BLOC_FAC INTEGER(8) :: POSELT, LA INTEGER IW(LIW), TIPIV(LPIV) LOGICAL LASTPANEL COMPLEX(kind=8) A(LA) INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL, & SLAVEF, ICNTL(60) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), & PERM(N), PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL, intent(in) :: LR_ACTIVATED TYPE (LRB_TYPE), DIMENSION(:) :: BLR_LorU INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER :: NELIM INTEGER, intent(in) :: NPARTSASS, CURRENT_BLR_PANEL INCLUDE 'mumps_headers.h' INTEGER(8) :: APOS, LREQA INTEGER NPIV, NCOL, PDEST, NSLAVES, WIDTH INTEGER IERR, LREQI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED DOUBLE PRECISION FLOP1,FLOP2 LOGICAL COMPRESS_CB INTEGER NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 IF (NSLAVES.EQ.0) THEN WRITE(6,*) ' ERROR 1 in ZMUMPS_SEND_FACTORED_PANEL ' CALL MUMPS_ABORT() ENDIF NPIV = IEND - IBEG_PANEL + 1 NCOL = LDA_FS - IBEG_PANEL + 1 APOS = POSELT + int(LDA_FS,8)*int(IBEG_PANEL-1,8) + & int(IBEG_PANEL - 1,8) IF (IBEG_PANEL > 0) THEN CALL MUMPS_GET_FLOPS_COST( LDA_FS, IBEG_PANEL-1, LPIV, & KEEP(50),2,FLOP1) ELSE FLOP1=0.0D0 ENDIF CALL MUMPS_GET_FLOPS_COST( LDA_FS, IEND, LPIV, & KEEP(50),2,FLOP2) FLOP2 = FLOP1 - FLOP2 CALL MUMPS_LOAD_UPDATE(1, .FALSE., FLOP2, KEEP,KEEP8) IF ((NPIV.GT.0) .OR. & ((NPIV.EQ.0).AND.(LASTPANEL)) & ) THEN IF ((NPIV.EQ.0).AND.(LASTPANEL)) THEN IF (COMPRESS_CB) THEN IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 COMPRESS_CB = .FALSE. ENDIF ENDIF PDEST = IOLDPS + 6 + KEEP(IXSZ) IF (( NPIV .NE. 0 ).AND.(KEEP(50).NE.0)) THEN NB_BLOC_FAC = NB_BLOC_FAC + 1 END IF IERR = -1 DO WHILE (IERR .EQ.-1) WIDTH = NSLAVES CALL ZMUMPS_BUF_SEND_BLOCFACTO( INODE, LDA_FS, NCOL, & NPIV, FPERE, LASTPANEL, TIPIV, A(APOS), & IW(PDEST), NSLAVES, KEEP, NB_BLOC_FAC, & NSLAVES, WIDTH, COMM, & NELIM, NPARTSASS, CURRENT_BLR_PANEL, & LR_ACTIVATED, BLR_LorU, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & IBEG_PANEL, COMPRESS_CB, & ICNTL, IERR ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (MESSAGE_RECEIVED) THEN POSELT = PTRAST(STEP(INODE)) APOS = POSELT + int(LDA_FS,8)*int(IBEG_PANEL-1,8) + & int(IBEG_PANEL - 1,8) ENDIF IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2 .OR. IERR.EQ.-3 ) THEN IF (IERR.EQ.-2) IFLAG = -17 IF (IERR.EQ.-3) IFLAG = -20 LREQA = int(NCOL,8)*int(NPIV,8) LREQI = NPIV + 6 + 2*NSLAVES + 2 CALL MUMPS_SET_IERROR( & int(LREQI,8) * int(KEEP(34),8) + LREQA * int(KEEP(35),8), & IERROR) GOTO 300 ENDIF ENDIF GOTO 500 300 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_SEND_FACTORED_PANEL END MODULE ZMUMPS_FAC_FRONT_TYPE2_AUX_M MUMPS_5.8.1/src/mumps_flytes.h0000664000175000017500000000124715042446422016134 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* $Id */ #ifndef MUMPS_FLYTES_H #define MUMPS_FLYTES_H #include #include "mumps_common.h" #if !defined(USE_AVX512_VBMI) #undef __AVX512F__ #undef __AVX512VBMI__ #endif void MUMPS_CALL mumps_flyte_return(); #endif MUMPS_5.8.1/src/ana_set_ordering.F0000664000175000017500000000577315042446423016657 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_SET_ORDERING(N, KEEP, SYM, NPROCS, IORD, & NBQD, AvgDens, & PROK, MP) IMPLICIT NONE INTEGER, intent(in) :: N, KEEP(500), NPROCS, SYM INTEGER, intent(in) :: NBQD, AvgDens, MP LOGICAL, intent(in) :: PROK INTEGER, intent(inout) :: IORD INTEGER MAXQD PARAMETER (MAXQD=2) INTEGER SMALLSYM, SMALLUNS PARAMETER (SMALLUNS=5000, SMALLSYM=10000) #if ! defined(metis) && ! defined(parmetis) && ! defined(metis4) && ! defined(parmetis3) IF ( IORD .EQ. 5 ) THEN IF (PROK) WRITE(MP,*) & 'WARNING: METIS not available. Ordering set to default.' IORD = 7 END IF #endif #if ! defined(pord) IF ( IORD .EQ. 4 ) THEN IF (PROK) WRITE(MP,*) & 'WARNING: PORD not available. Ordering set to default.' IORD = 7 END IF #endif #if ! defined(scotch) && ! defined(ptscotch) IF ( IORD .EQ. 3 ) THEN IF (PROK) WRITE(MP,*) & 'WARNING: SCOTCH not available. Ordering set to default.' IORD = 7 END IF #endif IF (IORD.EQ.4.AND.N.EQ.1) THEN IF (PROK) WRITE(MP,*) & 'WARNING: PORD not available for matrices of order 1' IORD=0 ENDIF IF (IORD.EQ.7) THEN IF (SYM.NE.0) THEN IF ( N.LE.SMALLSYM ) THEN IF (NBQD.GE.MAXQD) THEN IORD = 6 ELSE IF (KEEP(53).GT.0) THEN IORD = 0 ELSE IORD = 2 ENDIF ENDIF ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IORD = 5 #else # if defined(scotch) || defined(ptscotch) IORD = 3 # else # if defined(pord) IORD = 4 # else IORD = 6 # endif # endif #endif ENDIF ELSE IF ( N.LE.SMALLUNS ) THEN IF (NBQD.GE.MAXQD) THEN IORD = 6 ELSE IF (KEEP(53).GT.0) THEN IORD = 0 ELSE IORD = 2 ENDIF ENDIF ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IORD = 5 #else # if defined(scotch) || defined(ptscotch) IORD = 3 # else # if defined(pord) IORD = 4 # else IORD = 6 # endif # endif #endif ENDIF ENDIF ENDIF IF (IORD.EQ.4.AND.N.EQ.1) IORD=0 RETURN END SUBROUTINE MUMPS_SET_ORDERING MUMPS_5.8.1/src/zmumps_comm_buffer.F0000664000175000017500000032413215042446441017244 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_BUF USE MUMPS_BUF_COMMON, ONLY: BUF_CB, SIZE_RBUF_BYTES, & SIZEofINT, SIZEofREAL, OVHSIZE, BUF_ADJUST, BUF_LOOK, & MUMPS_BUF_SIZE_AVAILABLE PRIVATE INTEGER, SAVE :: BUF_LMAX_ARRAY DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE & , SAVE, TARGET :: BUF_MAX_ARRAY PUBLIC :: BUF_LMAX_ARRAY, BUF_MAX_ARRAY PUBLIC :: ZMUMPS_BUF_DEALL_MAX_ARRAY, & ZMUMPS_BUF_MAX_ARRAY_MINSIZE PUBLIC :: ZMUMPS_BUF_SEND_CB, & ZMUMPS_BUF_SEND_MASTER2SLAVE, & ZMUMPS_BUF_SEND_VCB, & ZMUMPS_BUF_SEND_MAITRE2, & ZMUMPS_BUF_SEND_CONTRIB_TYPE2, & ZMUMPS_BUF_SEND_BLOCFACTO, & ZMUMPS_BUF_SEND_BLFAC_SLAVE, & ZMUMPS_BUF_SEND_CONTRIB_TYPE3, & ZMUMPS_BUF_SEND_BACKVEC, & ZMUMPS_MPI_UNPACK_LRB CONTAINS SUBROUTINE ZMUMPS_BUF_DEALL_MAX_ARRAY() IMPLICIT NONE IF (allocated( BUF_MAX_ARRAY)) DEALLOCATE( BUF_MAX_ARRAY ) RETURN END SUBROUTINE ZMUMPS_BUF_DEALL_MAX_ARRAY SUBROUTINE ZMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IMPLICIT NONE INTEGER IERR, NFS4FATHER IERR = 0 IF (allocated( BUF_MAX_ARRAY)) THEN IF (BUF_LMAX_ARRAY .GE. NFS4FATHER) RETURN DEALLOCATE( BUF_MAX_ARRAY ) ENDIF BUF_LMAX_ARRAY=max(1,NFS4FATHER) ALLOCATE(BUF_MAX_ARRAY(BUF_LMAX_ARRAY),stat=IERR) IF ( IERR .GT. 0 ) THEN IERR = -1 RETURN END IF RETURN END SUBROUTINE ZMUMPS_BUF_MAX_ARRAY_MINSIZE SUBROUTINE ZMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, LCONT, & NASS, NPIV, & IWROW, IWCOL, A, PACKED_CB, & DEST, TAG, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER DEST, TAG, COMM, IERR INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER INODE, FPERE, NFRONT, LCONT, NASS, NPIV INTEGER IWROW( LCONT ), IWCOL( LCONT ) COMPLEX(kind=8) A( * ) LOGICAL PACKED_CB INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER NBROWS_PACKET INTEGER POSITION, IREQ, IPOS, I, J1 INTEGER SIZE1, SIZE2, SIZE_PACK, SIZE_AV, SIZE_AV_REALS INTEGER IZERO, IONE INTEGER SIZECB INTEGER LCONT_SENT INTEGER DEST2(1) PARAMETER( IZERO = 0, IONE = 1 ) LOGICAL RECV_BUF_SMALLER_THAN_SEND DOUBLE PRECISION TMP DEST2(1) = DEST IERR = 0 IF (NBROWS_ALREADY_SENT .EQ. 0) THEN CALL MPI_PACK_SIZE( 11 + LCONT + LCONT, MPI_INTEGER, & COMM, SIZE1, IERR_MPI) ELSE CALL MPI_PACK_SIZE( 5, MPI_INTEGER, COMM, SIZE1, IERR_MPI) ENDIF CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE SIZE_AV = SIZE_RBUF_BYTES RECV_BUF_SMALLER_THAN_SEND = .TRUE. ENDIF SIZE_AV_REALS = ( SIZE_AV - SIZE1 ) / SIZEofREAL IF (SIZE_AV_REALS < 0 ) THEN NBROWS_PACKET = 0 ELSE IF (PACKED_CB) THEN TMP=2.0D0*dble(NBROWS_ALREADY_SENT)+1.0D0 NBROWS_PACKET = int( & ( sqrt( TMP * TMP & + 8.0D0 * dble(SIZE_AV_REALS)) - TMP ) & / 2.0D0 ) ELSE IF (LCONT.EQ.0) THEN NBROWS_PACKET = 0 ELSE NBROWS_PACKET = SIZE_AV_REALS / LCONT ENDIF ENDIF ENDIF 10 CONTINUE NBROWS_PACKET = max(0, & min(NBROWS_PACKET, LCONT - NBROWS_ALREADY_SENT)) IF (NBROWS_PACKET .EQ. 0 .AND. LCONT .NE. 0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (PACKED_CB) THEN SIZECB = (NBROWS_ALREADY_SENT*NBROWS_PACKET)+(NBROWS_PACKET & *(NBROWS_PACKET+1))/2 ELSE SIZECB = NBROWS_PACKET * LCONT ENDIF CALL MPI_PACK_SIZE( SIZECB, MPI_DOUBLE_COMPLEX, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV ) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF (NBROWS_PACKET > 0) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.LCONT .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 10 & .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , DEST2) IF (IERR .EQ. -1 .OR. IERR .EQ. -2) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF ( NBROWS_PACKET > 0 ) GOTO 10 ENDIF IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (PACKED_CB) THEN LCONT_SENT=-LCONT ELSE LCONT_SENT=LCONT ENDIF CALL MPI_PACK( LCONT_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NBROWS_ALREADY_SENT == 0) THEN CALL MPI_PACK( LCONT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NASS-NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LCONT , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IONE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IWROW, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IWCOL, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF IF ( LCONT .NE. 0 ) THEN J1 = 1 + NBROWS_ALREADY_SENT * NFRONT IF (PACKED_CB) THEN DO I = NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( A( J1 ), I, MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) J1 = J1 + NFRONT END DO ELSE DO I = NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( A( J1 ), LCONT, MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) J1 = J1 + NFRONT END DO ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN WRITE(*,*) 'Error Try_send_cb: SIZE, POSITION=',SIZE_PACK, & POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET IF (NBROWS_ALREADY_SENT .NE. LCONT ) THEN IERR = -1 RETURN ENDIF 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_BUF_SEND_CB SUBROUTINE ZMUMPS_BUF_SEND_MASTER2SLAVE( NRHS, INODE, IFATH, & EFF_CB_SIZE, LD_CB, LD_PIV, NPIV, & JBDEB, JBFIN, & CB, SOL, & DEST, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER NRHS, INODE, IFATH, EFF_CB_SIZE, LD_CB, LD_PIV, NPIV INTEGER DEST, COMM, IERR, JBDEB, JBFIN COMPLEX(kind=8) CB( LD_CB*(NRHS-1)+EFF_CB_SIZE ) COMPLEX(kind=8) SOL( max(1, LD_PIV*(NRHS-1)+NPIV) ) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE, SIZE1, SIZE2, K INTEGER POSITION, IREQ, IPOS INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 CALL MPI_PACK_SIZE( 6, MPI_INTEGER, COMM, SIZE1, IERR ) CALL MPI_PACK_SIZE( NRHS * (EFF_CB_SIZE + NPIV), & MPI_DOUBLE_COMPLEX, COMM, & SIZE2, IERR_MPI ) SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IFATH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( EFF_CB_SIZE , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPIV , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBDEB , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBFIN , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) DO K = 1, NRHS CALL MPI_PACK( CB ( 1 + LD_CB * (K-1) ), & EFF_CB_SIZE, MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) END DO IF ( NPIV .GT. 0 ) THEN DO K=1, NRHS CALL MPI_PACK( SOL(1+LD_PIV*(K-1)), & NPIV, MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDDO END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, Master2Slave, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) 'Try_send_master2slave: SIZE, POSITION = ', & SIZE, POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE ZMUMPS_BUF_SEND_MASTER2SLAVE SUBROUTINE ZMUMPS_BUF_SEND_VCB( NRHS_B, NODE1, NODE2, NCB, LDW, & LONG, & IW, W, JBDEB, JBFIN, & RHSINTR, NRHS, LRHSINTR, IPOSINRHSINTR, NPIV, & KEEP, & DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER LDW, DEST, TAG, COMM, IERR INTEGER NRHS_B, NODE1, NODE2, NCB, LONG, JBDEB, JBFIN INTEGER IW( max( 1, LONG ) ) INTEGER, INTENT(IN) :: LRHSINTR, NRHS, IPOSINRHSINTR, NPIV COMPLEX(kind=8) W( max( 1, LDW * NRHS_B ) ) COMPLEX(kind=8) RHSINTR(LRHSINTR,NRHS) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS INTEGER SIZE1, SIZE2, SIZE, K INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1)=DEST IERR = 0 IF ( NODE2 .EQ. 0 ) THEN CALL MPI_PACK_SIZE( 4+LONG, MPI_INTEGER, COMM, SIZE1, & IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 6+LONG, MPI_INTEGER, COMM, SIZE1, & IERR_MPI ) END IF SIZE2 = 0 IF ( LONG .GT. 0 ) THEN CALL MPI_PACK_SIZE( NRHS_B*LONG, MPI_DOUBLE_COMPLEX, & COMM, SIZE2, IERR_MPI ) END IF SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = 0 CALL MPI_PACK( NODE1, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF ( NODE2 .NE. 0 ) THEN CALL MPI_PACK( NODE2, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( JBDEB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBFIN, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LONG, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF ( LONG .GT. 0 ) THEN CALL MPI_PACK( IW, LONG, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF (NODE2.EQ.0) THEN DO K=1, NRHS_B IF (NPIV.GT.0) THEN CALL MPI_PACK( RHSINTR(IPOSINRHSINTR,JBDEB+K-1), NPIV, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF IF (LONG-NPIV .NE.0) THEN CALL MPI_PACK( W(NPIV+1+(K-1)*LDW), LONG-NPIV, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF END DO ELSE DO K=1, NRHS_B CALL MPI_PACK( W(1+(K-1)*LDW), LONG, MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) END DO ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE ZMUMPS_BUF_SEND_VCB SUBROUTINE ZMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, & IPERE, ISON, NROW, & IROW, NCOL, ICOL, VAL, LDA, NELIM, TYPE_SON, & NSLAVES, SLAVES, DEST, COMM, IERR, & & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER LDA, NELIM, TYPE_SON INTEGER IPERE, ISON, NROW, NCOL, NSLAVES INTEGER IROW( NROW ) INTEGER ICOL( NCOL ) INTEGER SLAVES( NSLAVES ) COMPLEX(kind=8) VAL(LDA, *) INTEGER IPOS, IREQ, DEST, COMM, IERR INTEGER SLAVEF, KEEP(500), INIV2 INTEGER(8) KEEP8(150) INTEGER TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE1, SIZE2, SIZE3, SIZE_PACK, POSITION, I INTEGER NBROWS_PACKET, NCOL_SEND INTEGER SIZE_AV LOGICAL RECV_BUF_SMALLER_THAN_SEND INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 IF ( NELIM .NE. NROW ) THEN WRITE(*,*) 'Error in TRY_SEND_MAITRE2:',NELIM, NROW CALL MUMPS_ABORT() END IF IF (NBROWS_ALREADY_SENT .EQ. 0) THEN CALL MPI_PACK_SIZE( NROW+NCOL+7+NSLAVES, MPI_INTEGER, & COMM, SIZE1, IERR_MPI ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK_SIZE( NSLAVES+1, MPI_INTEGER, & COMM, SIZE3, IERR_MPI ) ELSE SIZE3 = 0 ENDIF SIZE1=SIZE1+SIZE3 ELSE CALL MPI_PACK_SIZE(7, MPI_INTEGER,COMM,SIZE1,IERR_MPI) ENDIF IF ( KEEP(50).ne.0 .AND. TYPE_SON .eq. 2 ) THEN NCOL_SEND = NROW ELSE NCOL_SEND = NCOL ENDIF CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF IF (NROW .GT. 0 ) THEN NBROWS_PACKET = (SIZE_AV - SIZE1) / NCOL_SEND / SIZEofREAL NBROWS_PACKET = min(NBROWS_PACKET, NROW - NBROWS_ALREADY_SENT) NBROWS_PACKET = max(NBROWS_PACKET, 0) ELSE NBROWS_PACKET =0 ENDIF IF (NBROWS_PACKET .EQ. 0 .AND. NROW .NE. 0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR=-1 GOTO 100 ENDIF ENDIF 10 CONTINUE CALL MPI_PACK_SIZE( NBROWS_PACKET * NCOL_SEND, & MPI_DOUBLE_COMPLEX, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF ( NBROWS_PACKET .GT. 0 ) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NROW .AND. & SIZE_PACK - SIZE1 .LT. ( SIZE_RBUF_BYTES - SIZE1 ) / 10 & .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN GOTO 100 ENDIF POSITION = 0 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSLAVES, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NBROWS_ALREADY_SENT .EQ. 0) THEN IF (NSLAVES.GT.0) THEN CALL MPI_PACK( SLAVES, NSLAVES, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( IROW, NROW, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ICOL, NCOL, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK( TAB_POS_IN_PERE(1,INIV2), NSLAVES+1, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF IF (NBROWS_PACKET.GE.1) THEN DO I=NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( VAL(1,I), NCOL_SEND, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO ENDIF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, MAITRE2, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN write(*,*) 'Try_send_maitre2, SIZE,POSITION=', & SIZE_PACK,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET IF ( NBROWS_ALREADY_SENT .NE. NROW ) THEN IERR = -1 ENDIF 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_BUF_SEND_MAITRE2 SUBROUTINE ZMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESC_IN_LU, & IPERE, NFRONT_PERE, NASS_PERE, NFS4FATHER, NSLAVES_PERE, & ISON, NBROW, LMAP, MAPROW, POS_FIRST_ROW_TO_PDEST, & IW_CBSON, A_CBSON, LA_CBSON, & ISLAVE, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP253_LOC, NVSCHUR, & SON_NIV, MYID ) USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_DATA_M USE MUMPS_BUF_COMMON IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT(inout):: NBCOLS_ALREADY_SENT, & NBLRB_ALREADY_SENT INTEGER, INTENT (in) :: KEEP253_LOC, NVSCHUR INTEGER, INTENT (in) :: SON_NIV INTEGER, INTENT(in) :: POS_FIRST_ROW_TO_PDEST INTEGER IPERE, ISON, NBROW, MYID INTEGER PDEST, ISLAVE, COMM, IERR INTEGER PDEST_MASTER, NASS_PERE, NSLAVES_PERE, & NFRONT_PERE, LMAP INTEGER MAPROW( LMAP ) INTEGER IW_CBSON( * ) COMPLEX(kind=8) A_CBSON( : ) INTEGER(8) :: LA_CBSON LOGICAL DESC_IN_LU, PACKED_CB INTEGER KEEP(500), N , SLAVEF INTEGER(8) KEEP8(150) INTEGER STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER NFS4FATHER,SIZE3,PS1,NCA,LROW1 INTEGER(8) :: ASIZE LOGICAL COMPUTE_MAX DOUBLE PRECISION, POINTER, DIMENSION(:) :: M_ARRAY INTEGER NBROWS_PACKET INTEGER NBLRB_TOTAL INTEGER NBLRB_PACKET INTEGER MAX_ROW_LENGTH INTEGER LROW, NELIM INTEGER(8) :: ITMP8 INTEGER NPIV, NFRONT, HS INTEGER SIZE_PACK, SIZE0, SIZE1, SIZE2, POSITION,I INTEGER SIZE_INTEGERS, B, SIZE_REALS, TMPSIZE, ONEorTWO, SIZE_AV INTEGER SIZE_NEXT_BLOCK 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 LOGICAL AVOID_TOO_SMALL_GRANULARITY INTEGER PDEST2(1) LOGICAL CB_IS_LR TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL, & BEGS_BLR_STA INTEGER :: NB_ROW_SHIFT, NB_COL_SHIFT, NASS_SHIFT, PANEL2SEND, & CURRENT_PANEL_SIZE, NB_BLR_ROWS, NB_BLR_COLS, & CB_IS_LR_INT, NCOL_SHIFT, NROW_SHIFT, & PANEL_BEG_OFFSET INTEGER :: NPIV_LR, LNEXT DOUBLE PRECISION :: K170PER1000 PARAMETER ( IONE=1 ) INCLUDE 'mumps_headers.h' DOUBLE PRECISION ZERO PARAMETER (ZERO = 0.0D0) CB_IS_LR = (IW_CBSON(1+XXLR).EQ.1 & .OR. IW_CBSON(1+XXLR).EQ.3) NBLRB_PACKET = 0 NBLRB_TOTAL = 0 IF (CB_IS_LR) THEN CB_IS_LR_INT = 1 ELSE CB_IS_LR_INT = 0 ENDIF AVOID_TOO_SMALL_GRANULARITY = .TRUE. IF (KEEP(173).EQ.1) AVOID_TOO_SMALL_GRANULARITY = .FALSE. COMPUTE_MAX = (KEEP(219) .NE. 0) .AND. & (KEEP(50) .EQ. 2) .AND. & (PDEST.EQ.PDEST_MASTER) & .AND. (NBCOLS_ALREADY_SENT.EQ.0) & .AND. (NBROWS_ALREADY_SENT.EQ.0) IF (COMPUTE_MAX) THEN CALL ZMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERR = -4 RETURN ENDIF ENDIF PDEST2(1) = PDEST IERR = 0 LROW = IW_CBSON( 1 + KEEP(IXSZ)) NELIM = IW_CBSON( 2 + KEEP(IXSZ)) NPIV = IW_CBSON( 4 + KEEP(IXSZ)) IF ( NPIV .LT. 0 ) THEN NPIV = 0 END IF NROW = IW_CBSON( 3 + KEEP(IXSZ)) NFRONT = LROW + NPIV HS = 6 + IW_CBSON( 6 + KEEP(IXSZ)) + KEEP(IXSZ) IF (CB_IS_LR.AND.NBROW.GT.0) THEN CALL ZMUMPS_BLR_RETRIEVE_CB_LRB(IW_CBSON(1+XXF), CB_LRB) IF (SON_NIV.EQ.1) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW_CBSON(1+XXF), & BEGS_BLR_ROW) CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_DYN(IW_CBSON(1+XXF), & BEGS_BLR_COL) NB_BLR_ROWS = size(BEGS_BLR_ROW) - 1 CALL ZMUMPS_BLR_RETRIEVE_NB_PANELS(IW_CBSON(1+XXF), & NB_COL_SHIFT) NB_ROW_SHIFT = NB_COL_SHIFT NASS_SHIFT = BEGS_BLR_ROW(NB_ROW_SHIFT+1)-1 NPIV_LR = BEGS_BLR_COL(NB_COL_SHIFT+1)-1 ELSE NPIV_LR=NPIV CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW_CBSON(1+XXF), & BEGS_BLR_STA) NB_BLR_ROWS = size(BEGS_BLR_STA) - 2 BEGS_BLR_ROW => BEGS_BLR_STA(2:NB_BLR_ROWS+2) CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C(IW_CBSON(1+XXF), & BEGS_BLR_COL, NB_COL_SHIFT) NASS_SHIFT = 0 NB_ROW_SHIFT = 0 ENDIF PANEL2SEND = -1 DO I=NB_ROW_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR_ROW(I+1)-1-NASS_SHIFT & .GT.NBROWS_ALREADY_SENT+POS_FIRST_ROW_TO_PDEST-1) THEN PANEL2SEND = I EXIT ENDIF ENDDO IF (PANEL2SEND.EQ.-1) THEN write(*,*) 'Internal error: PANEL2SEND not found' CALL MUMPS_ABORT() ENDIF CURRENT_PANEL_SIZE = BEGS_BLR_ROW(PANEL2SEND+1) & - BEGS_BLR_ROW(PANEL2SEND) PANEL_BEG_OFFSET = POS_FIRST_ROW_TO_PDEST + & NBROWS_ALREADY_SENT - & BEGS_BLR_ROW(PANEL2SEND) + NASS_SHIFT IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR_COL) - 1 ELSEIF (SON_NIV.EQ.1) THEN NB_BLR_COLS = PANEL2SEND ELSE NB_BLR_COLS = -1 NCOL_SHIFT = NPIV_LR NROW_SHIFT = LROW - NROW DO I=NB_COL_SHIFT+1,size(BEGS_BLR_COL)-1 IF (BEGS_BLR_COL(I+1)-NCOL_SHIFT.GT. & ( min ( & BEGS_BLR_ROW(PANEL2SEND+1)-POS_FIRST_ROW_TO_PDEST, & NBROW & ) & + NROW_SHIFT + POS_FIRST_ROW_TO_PDEST-1 ) & ) THEN NB_BLR_COLS = I EXIT ENDIF ENDDO IF (NB_BLR_COLS.EQ.-1) THEN write(*,*) 'Internal error: NB_BLR_COLS not found' CALL MUMPS_ABORT() ENDIF MAX_ROW_LENGTH = BEGS_BLR_ROW(PANEL2SEND)-1+NROW_SHIFT & + min(NBROW-NBROWS_ALREADY_SENT + PANEL_BEG_OFFSET, & CURRENT_PANEL_SIZE) ENDIF NBLRB_TOTAL = NB_BLR_COLS - NB_COL_SHIFT ENDIF STATE_SON = IW_CBSON(1+XXS) IF (STATE_SON .EQ. S_NOLCBCONTIG) THEN LDA_SON8 = int(LROW,8) SHIFTCB_SON = int(NPIV,8)*int(NROW,8) ELSE IF (STATE_SON .EQ. S_NOLCLEANED) THEN LDA_SON8 = int(LROW,8) SHIFTCB_SON = 0_8 ELSE LDA_SON8 = int(NFRONT,8) SHIFTCB_SON = int(NPIV,8) ENDIF CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (PDEST .EQ. PDEST_MASTER) THEN SIZE_DESC_BANDE=0 ELSE SIZE_DESC_BANDE=(11+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, & 11+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(COMPUTE_MAX) THEN CALL MPI_PACK_SIZE(1, MPI_INTEGER, & COMM, SIZE0, IERR_MPI ) IF(NFS4FATHER .GT. 0) THEN CALL MPI_PACK_SIZE( NFS4FATHER, MPI_DOUBLE_PRECISION, & COMM, SIZE1, IERR_MPI ) ENDIF SIZE1 = SIZE1+SIZE0 ENDIF ONEorTWO = 1 IF (PDEST .EQ.PDEST_MASTER) THEN L = 0 ELSE IF (KEEP(50) .EQ. 0) THEN L = LROW ELSE L = LROW + POS_FIRST_ROW_TO_PDEST-LMAP+NBROWS_ALREADY_SENT-1 ONEorTWO=ONEorTWO+1 ENDIF NBINT = 6 + L + 1 IF (CB_IS_LR.AND.NBROW.GT.0) THEN NBINT = NBINT + 4*(NB_BLR_COLS-NB_COL_SHIFT) + 3 ENDIF CALL MPI_PACK_SIZE( NBINT, MPI_INTEGER, & COMM, TMPSIZE, IERR_MPI ) SIZE1 = SIZE1 + TMPSIZE SIZE_AV = SIZE_AV - SIZE1 NOT_ENOUGH_SPACE=.FALSE. IF (SIZE_AV .LT.0 ) THEN NBROWS_PACKET = 0 NOT_ENOUGH_SPACE=.TRUE. ELSE IF ( KEEP(50) .EQ. 0 ) THEN NBROWS_PACKET = & SIZE_AV / ( ONEorTWO*SIZEofINT+LROW*SIZEofREAL) ELSE B = 2 * ONEorTWO + & ( -1 + 2 * LROW + 2 * POS_FIRST_ROW_TO_PDEST -2*LMAP & + 2 * NBROWS_ALREADY_SENT ) & * SIZEofREAL / SIZEofINT NBROWS_PACKET=int((dble(-B)+sqrt((dble(B)*dble(B))+ & dble(4)*dble(2)*dble(SIZE_AV)/dble(SIZEofINT) * & dble(SIZEofREAL/SIZEofINT)))* & dble(SIZEofINT) / dble(2) / dble(SIZEofREAL)) ENDIF ENDIF 10 CONTINUE SIZE_NEXT_BLOCK = 0 IF (CB_IS_LR) THEN IF ( NBROW .GT. 0) THEN NBROWS_PACKET = CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET ELSE NBROWS_PACKET = 0 ENDIF ENDIF NBROWS_PACKET = max( 0, NBROWS_PACKET) NBROWS_PACKET = min(NBROW-NBROWS_ALREADY_SENT, NBROWS_PACKET) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE .OR. & (NBROWS_PACKET .EQ.0.AND. NBROW.NE.0) IF (CB_IS_LR.AND.NBROW.GT.0.AND..NOT.NOT_ENOUGH_SPACE) THEN CALL MPI_PACK_SIZE( ONEorTWO* NBROWS_PACKET, MPI_INTEGER, & COMM, TMPSIZE, IERR_MPI ) CALL ZMUMPS_BLR_GET_SIZEREALS_CB_LRB( & SIZE_AV-TMPSIZE, CB_LRB, & NB_ROW_SHIFT, PANEL2SEND, & NBLRB_ALREADY_SENT, NBLRB_TOTAL, & NBLRB_PACKET, SIZE_REALS, SIZE_NEXT_BLOCK & , KEEP(173) & ) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE.OR.(NBLRB_PACKET.EQ.0) ENDIF IF ( (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NBROW) .AND. & .NOT.CB_IS_LR & ) THEN IF (KEEP(50).EQ.0) THEN LNEXT = LROW + 1 ELSE MAX_ROW_LENGTH = LROW + POS_FIRST_ROW_TO_PDEST - LMAP & + NBROWS_ALREADY_SENT & + NBROWS_PACKET-1 LNEXT = MAX_ROW_LENGTH + 1 ENDIF LNEXT = LNEXT + ONEorTWO CALL MPI_PACK_SIZE( LNEXT, & MPI_DOUBLE_COMPLEX, & COMM, SIZE_NEXT_BLOCK, IERR_MPI ) ENDIF IF (SIZE_NEXT_BLOCK.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF IF (NOT_ENOUGH_SPACE) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (CB_IS_LR.AND.NBROW.GT.0) THEN IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 ELSEIF (SON_NIV.EQ.1) THEN MAX_ROW_LENGTH = LROW+POS_FIRST_ROW_TO_PDEST -LMAP & + NBROWS_ALREADY_SENT & + NBROWS_PACKET-1 ENDIF ELSE IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 SIZE_REALS = NBROWS_PACKET * LROW ELSE SIZE_REALS = ( LROW + POS_FIRST_ROW_TO_PDEST - LMAP & + NBROWS_ALREADY_SENT ) * & NBROWS_PACKET + ( NBROWS_PACKET * & ( NBROWS_PACKET - 1) ) / 2 MAX_ROW_LENGTH = LROW + POS_FIRST_ROW_TO_PDEST - LMAP & + NBROWS_ALREADY_SENT & + NBROWS_PACKET-1 ENDIF ENDIF SIZE_INTEGERS = ONEorTWO* NBROWS_PACKET CALL MPI_PACK_SIZE( SIZE_REALS, MPI_DOUBLE_COMPLEX, & COMM, SIZE2, IERR_MPI ) CALL MPI_PACK_SIZE( SIZE_INTEGERS, MPI_INTEGER, & COMM, SIZE3, IERR_MPI ) IF (SIZE2 + SIZE3 .GT. SIZE_AV .AND. .NOT.CB_IS_LR) THEN NBROWS_PACKET = NBROWS_PACKET -1 IF (NBROWS_PACKET .GT. 0 .AND..NOT.CB_IS_LR) THEN GOTO 10 ENDIF IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF SIZE_PACK = SIZE1 + SIZE2 + SIZE3 K170PER1000 = dble(min(KEEP(170),500))/dble(1000) IF ( .NOT.CB_IS_LR & .AND. (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NBROW) & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND & .AND. ( SIZE_PACK .LT. & int(dble(SIZE_RBUF_BYTES)*K170PER1000) ) & .AND. & ( int(SIZE_PACK,8) + int(SIZE_NEXT_BLOCK,8) .LE. & int(SIZE_RBUF_BYTES,8) ) & ) THEN IERR = -1 GOTO 100 ENDIF IF ( CB_IS_LR.AND. & ( NBROWS_PACKET.NE.0 ).AND. & ( NBLRB_ALREADY_SENT+NBLRB_PACKET.NE. NBLRB_TOTAL ) & .AND. ( SIZE_PACK .LT. & int(dble(SIZE_RBUF_BYTES)*K170PER1000) ) & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND & .AND. AVOID_TOO_SMALL_GRANULARITY & .AND. ( & int(SIZE_PACK,8) + int(SIZE_NEXT_BLOCK,8) .LE. & int(SIZE_RBUF_BYTES,8) ) & ) THEN IERR = -1 GOTO 100 ENDIF IF (SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , PDEST2) IF (IERR .EQ. -1 .OR. IERR.EQ. -2) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF (NBROWS_PACKET > 0 ) GOTO 10 ENDIF IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (KEEP(50)==0) THEN CALL MPI_PACK( LROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE IF (CB_IS_LR.AND. & NBLRB_ALREADY_SENT+NBLRB_PACKET .EQ. NBLRB_TOTAL) THEN CALL MPI_PACK( -MAX_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE CALL MPI_PACK( MAX_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( CB_IS_LR_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF ( PDEST .NE. PDEST_MASTER ) THEN IF (KEEP(50)==0) THEN CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), LROW, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE IF (MAX_ROW_LENGTH > 0) THEN CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), & MAX_ROW_LENGTH, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF END IF DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = POS_FIRST_ROW_TO_PDEST + J -1 INDICE_PERE=MAPROW(I) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IPERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE CALL MPI_PACK( INDICE_PERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO IF (CB_IS_LR.AND.(NBROW.GT.0)) THEN CALL ZMUMPS_BLR_PACK_CB_LRB( & CB_LRB, NB_ROW_SHIFT, & NBCOLS_ALREADY_SENT, & NBLRB_ALREADY_SENT, NBLRB_PACKET, & PANEL2SEND, & PANEL_BEG_OFFSET+1, PANEL_BEG_OFFSET+NBROWS_PACKET, & BUF_CB%CONTENT(IPOS:), & SIZE_PACK, POSITION, COMM, IERR & ) GOTO 200 ENDIF DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = POS_FIRST_ROW_TO_PDEST + J -1 IF (KEEP(50).ne.0) THEN THIS_ROW_LENGTH = LROW + I - LMAP ELSE THIS_ROW_LENGTH = LROW ENDIF IF (DESC_IN_LU) THEN IF ( PACKED_CB ) THEN IF (NELIM.EQ.0) THEN ITMP8 = int(I,8) ELSE ITMP8 = int(NELIM+I,8) ENDIF APOS = ITMP8 * (ITMP8-1_8) / 2_8 + 1_8 ELSE APOS = int(I+NELIM-1, 8) * int(LROW,8) + 1_8 ENDIF ELSE IF ( PACKED_CB ) THEN IF ( LROW .EQ. NROW ) THEN ITMP8 = int(I,8) APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 ELSE ITMP8 = int(I + LROW - NROW,8) APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 - & int(LROW - NROW, 8) * int(LROW-NROW+1,8) / 2_8 ENDIF ELSE APOS = int( I - 1, 8 ) * LDA_SON8 + SHIFTCB_SON + 1_8 ENDIF ENDIF CALL MPI_PACK( A_CBSON( APOS ), THIS_ROW_LENGTH, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO 200 CONTINUE IF (COMPUTE_MAX) THEN CALL MPI_PACK(NFS4FATHER,1, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NFS4FATHER .GT. 0) THEN IF (CB_IS_LR) THEN CALL ZMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW_CBSON(1+XXF), M_ARRAY) CALL MPI_PACK(M_ARRAY(1), NFS4FATHER, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL ZMUMPS_BLR_FREE_M_ARRAY ( IW_CBSON(1+XXF) ) ELSE BUF_MAX_ARRAY(1:NFS4FATHER) = ZERO IF(MAPROW(NROW) .GT. NASS_PERE) THEN DO PS1=1,NROW IF(MAPROW(PS1).GT.NASS_PERE) EXIT ENDDO IF (DESC_IN_LU) THEN IF (PACKED_CB) THEN APOS = int(NELIM+PS1,8) * int(NELIM+PS1-1,8) / & 2_8 + 1_8 NCA = -44444 ASIZE = int(NROW,8) * int(NROW+1,8)/2_8 - & int(NELIM+PS1,8) * int(NELIM+PS1-1,8)/2_8 LROW1 = PS1 + NELIM ELSE APOS = int(PS1+NELIM-1,8) * int(LROW,8) + 1_8 NCA = LROW ASIZE = int(NCA,8) * int(NROW-PS1+1,8) LROW1 = LROW ENDIF ELSE IF (PACKED_CB) THEN IF (NPIV.NE.0) THEN WRITE(*,*) "Error in PARPIV/ZMUMPS_BUF_SEND_CONTRIB_TYPE2" CALL MUMPS_ABORT() ENDIF LROW1=LROW-NROW+PS1 ITMP8 = int(PS1 + LROW - NROW,8) APOS = ITMP8 * (ITMP8 - 1_8) / 2_8 + 1_8 - & int(LROW-NROW,8)*int(LROW-NROW+1,8)/2_8 ASIZE = int(LROW,8)*int(LROW+1,8)/2_8 - & ITMP8*(ITMP8-1_8)/2_8 NCA = -555555 ELSE APOS = int(PS1-1,8) * LDA_SON8 + 1_8 + SHIFTCB_SON NCA = int(LDA_SON8) ASIZE = LA_CBSON - APOS + 1_8 LROW1=-666666 ENDIF ENDIF IF ( NROW-PS1+1-KEEP253_LOC-NVSCHUR .GT. 0 ) THEN CALL ZMUMPS_COMPUTE_MAXPERCOL( & A_CBSON(APOS),ASIZE,NCA, & NROW-PS1+1-KEEP253_LOC-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB,LROW1) ENDIF ENDIF CALL MPI_PACK(BUF_MAX_ARRAY, NFS4FATHER, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF ENDIF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & PDEST, CONTRIB_TYPE2, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE_PACK.LT. POSITION ) THEN WRITE(*,*) ' contniv2: SIZE, POSITION =',SIZE_PACK, POSITION WRITE(*,*) ' NBROW, LROW = ', NBROW, LROW CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) IF (CB_IS_LR) THEN IF (NBLRB_ALREADY_SENT+NBLRB_PACKET.EQ.NBLRB_TOTAL) THEN NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ELSE NBLRB_ALREADY_SENT = NBLRB_ALREADY_SENT + NBLRB_PACKET ENDIF ELSE NBROWS_ALREADY_SENT=NBROWS_ALREADY_SENT + NBROWS_PACKET ENDIF IF (NBROWS_ALREADY_SENT .NE. NBROW ) THEN IERR = -1 ENDIF 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_BUF_SEND_CONTRIB_TYPE2 SUBROUTINE ZMUMPS_BUF_SEND_BLOCFACTO( INODE, NFRONT, & NCOL, NPIV, FPERE, LASTPANEL, IPIV, VAL, & PDEST, NDEST, KEEP, NB_BLOC_FAC, & NSLAVES_TOT, WIDTH, COMM, & NELIM, NPARTSASS, CURRENT_BLR_PANEL, & LR_ACTIVATED, BLR_LorU, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & IBEG_PANEL, COMPRESS_CB, & ICNTL, IERR ) USE ZMUMPS_LR_TYPE IMPLICIT NONE INTEGER, intent(in) :: INODE, NCOL, NPIV, & FPERE, NFRONT, NDEST INTEGER, intent(in) :: IPIV( NPIV ) COMPLEX(kind=8), intent(in) :: VAL( NFRONT, * ) INTEGER, intent(in) :: PDEST( NDEST ) INTEGER, intent(inout) :: KEEP(500) INTEGER, intent(in) :: NB_BLOC_FAC, & NSLAVES_TOT, COMM, WIDTH LOGICAL, intent(in) :: LASTPANEL LOGICAL, intent(in) :: COMPRESS_CB LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(in) :: NELIM, NPARTSASS, CURRENT_BLR_PANEL, & IBEG_PANEL TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(inout) :: IERR INTEGER, INTENT(inout):: NBCOLS_ALREADY_SENT, & NBLRB_ALREADY_SENT INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE3, SIZET, & IDEST, IPOSMSG, I, SIZE_MSG_BYTES LOGICAL OVERFLOW INTEGER(8) :: SIZE2_8, SIZE3_8, SIZET_8, SIZE_OVERFLOW INTEGER NPIVSENT INTEGER :: LP LOGICAL :: LPOK LOGICAL :: RECV_BUF_SMALLER_THAN_SEND, NOT_ENOUGH_SPACE INTEGER :: DEST_BLOCFACTO, TAG_BLOCFACTO INTEGER :: LR_ACTIVATED_INT INTEGER :: NBINT, SIZE_AV, SIZE_AV_ADJUSTED INTEGER :: JBEG_BLOCK, NCOL_SEND, NCOL_MAX, & SIZE_BLR_LorU_SENT, NCOL_DIAG, NEWCOL_SENT INTEGER :: NBLRB_PACKET, SIZE_NEXT_BLOCK LOGICAL :: AVOID_TOO_SMALL_GRANULARITY INTEGER, PARAMETER :: kmaxcol=3 DOUBLE PRECISION :: K170PER1000 LP = ICNTL( 1 ) LPOK = ( LP.GT.0 .AND. ICNTL(4).GE.1 ) IERR = 0 OVERFLOW = .FALSE. NOT_ENOUGH_SPACE = .FALSE. NBLRB_PACKET = -9988 NCOL_DIAG = -9988 AVOID_TOO_SMALL_GRANULARITY = .TRUE. IF (KEEP(173).EQ.1) AVOID_TOO_SMALL_GRANULARITY = .FALSE. SIZE_OVERFLOW = 0_8 JBEG_BLOCK = NBCOLS_ALREADY_SENT + 1 NCOL_SEND = NCOL - JBEG_BLOCK + 1 NEWCOL_SENT = NCOL_SEND CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF IF ( & (KEEP(50).NE.0) .OR. & (KEEP(50).EQ.0.AND.JBEG_BLOCK.EQ.1) & ) THEN NBINT = NPIV ELSE NBINT = 0 ENDIF IF ( LASTPANEL ) THEN IF ( KEEP(50) .eq. 0 ) THEN NBINT = 9 + NBINT ELSE NBINT = 11 + NBINT END IF ELSE IF ( KEEP(50) .eq. 0 ) THEN NBINT = 8 + NBINT ELSE NBINT = 10 + NBINT END IF END IF IF (LR_ACTIVATED.AND.KEEP(50).EQ.0) THEN IF ( COMPRESS_CB .AND.(NPIV.GT.0) & .AND. IBEG_PANEL.EQ.1 .AND. (JBEG_BLOCK.EQ.1) & ) THEN NBINT = NBINT + size(BLR_LorU) + 1 ELSE NBINT = NBINT + 1 ENDIF ENDIF CALL MPI_PACK_SIZE( NBINT + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE2_8 = 0_8 SIZE_AV_ADJUSTED = SIZE_AV SIZE_NEXT_BLOCK = 0 IF ( (NPIV.GT.0) & ) THEN SIZE_AV_ADJUSTED = SIZE_AV_ADJUSTED - int(SIZE2_8) - SIZE1 NOT_ENOUGH_SPACE = (SIZE_AV_ADJUSTED.LE.0) IF (.NOT. LR_ACTIVATED) THEN NCOL_MAX = (SIZE_AV_ADJUSTED) / (NPIV*SIZEofREAL) NCOL_MAX = max(NCOL_MAX,0) NCOL_SEND = min( NCOL_SEND, NCOL_MAX) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE.OR. & (NCOL_SEND.EQ.0) .OR. & ((JBEG_BLOCK.EQ.1).AND.(NCOL_MAX.LT.NPIV)) IF (JBEG_BLOCK.EQ.1) NCOL_SEND = max(NCOL_SEND, NPIV) IF (KEEP(173).EQ.1) THEN IF (JBEG_BLOCK.EQ.1) THEN NCOL_SEND = min(NCOL_SEND, kmaxcol+NPIV) ELSE NCOL_SEND = min(NCOL_SEND, kmaxcol) ENDIF ENDIF NOT_ENOUGH_SPACE= NOT_ENOUGH_SPACE.OR. & (NCOL_SEND .GT. NCOL_MAX) SIZE3_8 = int(NPIV,8)*int(NCOL_SEND,8)*int(KEEP(35),8) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ELSE CALL MPI_PACK_SIZE( NPIV*NCOL_SEND, & MPI_DOUBLE_COMPLEX, & COMM, SIZE3, IERR_MPI ) SIZE2_8 = SIZE2_8 + int(SIZE3,8) ENDIF NEWCOL_SENT = NCOL_SEND IF (NBCOLS_ALREADY_SENT+NEWCOL_SENT.LT.NCOL) THEN CALL MPI_PACK_SIZE( NPIV, & MPI_DOUBLE_COMPLEX, & COMM, SIZE_NEXT_BLOCK, IERR_MPI ) ENDIF ELSE NCOL_DIAG = -9995 IF ((KEEP(50).NE.0).OR.(JBEG_BLOCK.EQ.1)) THEN SIZE3_8 = int(NPIV,8)*int(NPIV+NELIM,8)*int(KEEP(35),8) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ELSE CALL MPI_PACK_SIZE( NPIV*(NPIV+NELIM), & MPI_DOUBLE_COMPLEX, & COMM, SIZE3, IERR_MPI ) SIZE2_8 = SIZE2_8+int(SIZE3,8) NCOL_SEND = NPIV+NELIM SIZE_AV_ADJUSTED = SIZE_AV_ADJUSTED - int(SIZE2_8) ENDIF ELSE NCOL_SEND = 0 ENDIF NCOL_DIAG = NCOL_SEND IF (JBEG_BLOCK.EQ.1) THEN NEWCOL_SENT = NCOL_DIAG ELSE NEWCOL_SENT = 0 ENDIF NOT_ENOUGH_SPACE = ( NOT_ENOUGH_SPACE.OR. & (SIZE_AV_ADJUSTED.LE.0) ) CALL ZMUMPS_MPI_PACK_SIZE_LR_PARTIAL ( 0, & BLR_LorU, NBLRB_ALREADY_SENT, & SIZE_AV_ADJUSTED, KEEP(173), & NBLRB_PACKET, NCOL_SEND, SIZE3_8, & SIZE_NEXT_BLOCK, & COMM, IERR & ) NEWCOL_SENT = NEWCOL_SENT + (NCOL_SEND-NCOL_DIAG) NOT_ENOUGH_SPACE= ( NOT_ENOUGH_SPACE.OR. & (NEWCOL_SENT.EQ.0).OR. & (SIZE3_8.GT.int(SIZE_AV_ADJUSTED,8)) ) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ENDIF SIZE2_8 = SIZE2_8+SIZE3_8 ENDIF ENDIF IF (SIZE_NEXT_BLOCK.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF IF (NOT_ENOUGH_SPACE & ) THEN IF (RECV_BUF_SMALLER_THAN_SEND & ) THEN IERR = -3 RETURN ELSE IERR = -1 RETURN ENDIF ENDIF SIZET_8 = int(SIZE1,8) + SIZE2_8 IF (SIZET_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZET_8 ENDIF IF (OVERFLOW) THEN IERR=-3 IF (LPOK) WRITE(LP,*) & "Integer overflow message inZMUMPS_BUF_SEND_BLOCFACTO", & "SIZE_OVERFLOW,NPIV,NFRONT,NELIM=", & SIZE_OVERFLOW, NPIV, NFRONT, NELIM RETURN ENDIF SIZET = int(SIZET_8) IF (SIZET.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF K170PER1000 = dble(min(KEEP(170),500))/dble(1000) IF ( (NBCOLS_ALREADY_SENT+NEWCOL_SENT.LT.NCOL) & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND & .AND. ( SIZET .LT. & int(dble(SIZE_RBUF_BYTES)*K170PER1000) ) & .AND. ( & int(SIZET,8) + int(SIZE_NEXT_BLOCK,8) .LE. & int(SIZE_RBUF_BYTES,8) ) & .AND. AVOID_TOO_SMALL_GRANULARITY & ) THEN IERR = -1 RETURN ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NDEST , PDEST) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_CB%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST SIZE_MSG_BYTES = SIZET - OVHSIZE * (NDEST-1) * KEEP(34) POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) NPIVSENT = NPIV IF (LASTPANEL) NPIVSENT = -NPIV CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF ( LASTPANEL .OR. KEEP(50).ne.0 ) THEN CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) END IF IF ( LASTPANEL .AND. KEEP(50) .NE. 0 ) THEN CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) END IF CALL MPI_PACK( NEWCOL_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBEG_BLOCK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NELIM, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPARTSASS, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( CURRENT_BLR_PANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN LR_ACTIVATED_INT = 1 ELSE LR_ACTIVATED_INT = 0 ENDIF CALL MPI_PACK( LR_ACTIVATED_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF ( KEEP(50) .ne. 0 ) THEN CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDIF IF (LR_ACTIVATED.AND.KEEP(50).EQ.0) THEN SIZE_BLR_LorU_SENT = 0 IF ( COMPRESS_CB .AND.(NPIV.GT.0) & .AND. IBEG_PANEL.EQ.1 .AND. (JBEG_BLOCK.EQ.1) & ) THEN SIZE_BLR_LorU_SENT = size(BLR_LorU) ENDIF CALL MPI_PACK( SIZE_BLR_LorU_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), & SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF (SIZE_BLR_LorU_SENT.GT.0) THEN DO I=1, size(BLR_LorU) CALL MPI_PACK( BLR_LorU(I)%M, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), & SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDDO ENDIF ENDIF IF ( (NPIV.GT.0) & ) THEN IF ( & (KEEP(50).NE.0) .OR. & (KEEP(50).EQ.0.AND.JBEG_BLOCK.EQ.1) & ) THEN CALL MPI_PACK( IPIV, NPIV, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(50).NE.0.OR.JBEG_BLOCK.EQ.1) THEN DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NPIV+NELIM, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) END DO ENDIF CALL ZMUMPS_MPI_PACK_LR_PARTIAL( & BLR_LorU, NBLRB_ALREADY_SENT, NBLRB_PACKET, & BUF_CB%CONTENT(IPOSMSG: & IPOSMSG+(SIZE_MSG_BYTES+KEEP(34)-1)/KEEP(34)-1), & SIZE_MSG_BYTES, POSITION, COMM, IERR,KEEP(34) ) ELSE DO I = 1, NPIV CALL MPI_PACK( VAL(JBEG_BLOCK,I), NCOL_SEND, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) END DO ENDIF ENDIF DO IDEST = NDEST, 1, -1 DEST_BLOCFACTO = PDEST(IDEST) IF ( KEEP(50) .EQ. 0) THEN TAG_BLOCFACTO = BLOC_FACTO KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, & MPI_PACKED, & DEST_BLOCFACTO, TAG_BLOCFACTO, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) ELSE KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, & MPI_PACKED, & DEST_BLOCFACTO, BLOC_FACTO_SYM, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) END IF END DO IF (NBCOLS_ALREADY_SENT+NEWCOL_SENT.EQ.NCOL & ) THEN NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ELSE NBCOLS_ALREADY_SENT = NBCOLS_ALREADY_SENT + NEWCOL_SENT IF (LR_ACTIVATED) THEN NBLRB_ALREADY_SENT = NBLRB_ALREADY_SENT + NBLRB_PACKET ENDIF IERR = -1 ENDIF IF ( SIZE_MSG_BYTES .LT. POSITION ) THEN WRITE(*,*) ' Error sending blocfacto : size < position' WRITE(*,*) ' INODE= ', INODE, & ' Size,position= ',SIZE_MSG_BYTES,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_MSG_BYTES .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE ZMUMPS_BUF_SEND_BLOCFACTO SUBROUTINE ZMUMPS_BUF_SEND_BLFAC_SLAVE( INODE, & NPIV, FPERE, IPOSK, JPOSK, UIP21K, LUIP21K, NCOLU, & NDEST, PDEST, COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & NOTHING_WAS_SENT, & A , LA, POSBLOCFACTO, LD_BLOCFACTO, & IPIV, MAXI_CLUSTER, IERR, IERROR ) USE ZMUMPS_LR_TYPE IMPLICIT NONE INTEGER INODE, NCOLU, IPOSK, JPOSK, NPIV, NDEST, FPERE INTEGER(8) :: LUIP21K COMPLEX(kind=8) UIP21K( : ) INTEGER PDEST( NDEST ) INTEGER COMM, IERR, IERROR INTEGER, INTENT(INOUT) :: KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: NBCOLS_ALREADY_SENT, & NBLRB_ALREADY_SENT LOGICAL, intent(out) :: NOTHING_WAS_SENT TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS INTEGER(8), intent(in) :: LA, POSBLOCFACTO INTEGER, intent(in) :: LD_BLOCFACTO, IPIV(NPIV), & MAXI_CLUSTER, IPANEL COMPLEX(kind=8), intent(inout) :: A(LA) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER LR_ACTIVATED_INT INTEGER POSITION, IREQ, IPOS, SIZE1, SIZET, & IDEST, IPOSMSG, SSS, SIZE3, SIZE_MSG_BYTES INTEGER(8) :: SIZE2_8, SIZE3_8, SIZET_8, SIZE_OVERFLOW LOGICAL :: OVERFLOW, LASTBL_INPANEL INTEGER :: JBEG_BLOCK, NCOL_SEND, NCOL_MAX INTEGER :: SIZE_AV, SIZE_AV_ADJUSTED LOGICAL :: RECV_BUF_SMALLER_THAN_SEND, NOT_ENOUGH_SPACE INTEGER :: NBLRB_PACKET, SIZE_NEXT_BLOCK LOGICAL :: AVOID_TOO_SMALL_GRANULARITY INTEGER, PARAMETER :: kmaxcol=3 DOUBLE PRECISION :: K170PER1000 IERR = 0 OVERFLOW = .FALSE. SIZE_OVERFLOW = 0_8 JBEG_BLOCK = NBCOLS_ALREADY_SENT + 1 NCOL_SEND = NCOLU - JBEG_BLOCK + 1 NBLRB_PACKET = -9977 NOTHING_WAS_SENT = .TRUE. AVOID_TOO_SMALL_GRANULARITY = .TRUE. IF (KEEP(173).EQ.1) AVOID_TOO_SMALL_GRANULARITY = .FALSE. CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF CALL MPI_PACK_SIZE( 8 + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE2_8 = 0_8 SIZE_AV_ADJUSTED = SIZE_AV - SIZE1 SIZE_NEXT_BLOCK = 0 NOT_ENOUGH_SPACE = (SIZE_AV_ADJUSTED.LE.0) IF (.NOT. LR_ACTIVATED) THEN NCOL_MAX = (SIZE_AV_ADJUSTED) / (NPIV*SIZEofREAL) NCOL_MAX = max(NCOL_MAX,0) NCOL_SEND = min( NCOL_SEND, NCOL_MAX) IF (KEEP(173).EQ.1) THEN NCOL_SEND = min(NCOL_SEND, kmaxcol) ENDIF NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE.OR.(NCOL_SEND.EQ.0) SIZE3_8 = int(NPIV,8)*int(NCOL_SEND,8) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ELSE CALL MPI_PACK_SIZE( abs(NPIV)*NCOL_SEND, & MPI_DOUBLE_COMPLEX, & COMM, SIZE3, IERR_MPI ) SIZE2_8=SIZE2_8 + int(SIZE3,8) ENDIF IF (NBCOLS_ALREADY_SENT+NCOL_SEND.LT.NCOLU) THEN CALL MPI_PACK_SIZE( NPIV, & MPI_DOUBLE_COMPLEX, & COMM, SIZE_NEXT_BLOCK, IERR_MPI ) ENDIF ELSE NCOL_SEND = 0 NOT_ENOUGH_SPACE = ( NOT_ENOUGH_SPACE.OR. & (SIZE_AV_ADJUSTED.LE.0) ) CALL ZMUMPS_MPI_PACK_SIZE_LR_PARTIAL ( 1, & BLR_LS, NBLRB_ALREADY_SENT, & SIZE_AV_ADJUSTED, KEEP(173), & NBLRB_PACKET, NCOL_SEND, SIZE3_8, & SIZE_NEXT_BLOCK, & COMM, IERR & ) NOT_ENOUGH_SPACE= ( NOT_ENOUGH_SPACE.OR. & (NCOL_SEND.EQ.0).OR. & (SIZE3_8.GT.int(SIZE_AV_ADJUSTED,8)) ) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ENDIF SIZE2_8 = SIZE2_8+SIZE3_8 ENDIF IF (SIZE_NEXT_BLOCK.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF IF (NOT_ENOUGH_SPACE) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 RETURN ELSE IERR = -1 RETURN ENDIF ENDIF SIZET_8 = int(SIZE1,8) + SIZE2_8 IF (SIZET_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZET_8 ENDIF IF (OVERFLOW) THEN IERR=-3 RETURN ENDIF SIZET = int(SIZET_8) IF (SIZET.GT.SIZE_RBUF_BYTES) THEN CALL MPI_PACK_SIZE( 6 , & MPI_INTEGER, COMM, SSS, IERR_MPI ) SIZE2_8 = int(SSS,8)+SIZE2_8 IF (int(SIZE2_8).GT.SIZE_RBUF_BYTES) THEN IERR = -2 RETURN ENDIF END IF K170PER1000 = dble(min(KEEP(170),500))/dble(1000) IF ((NBCOLS_ALREADY_SENT+NCOL_SEND.LT.NCOLU) & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND & .AND. ( SIZET .LT. & int(dble(SIZE_RBUF_BYTES)*K170PER1000) ) & .AND. ( & int(SIZET,8) + int(SIZE_NEXT_BLOCK,8) .LE. & int(SIZE_RBUF_BYTES,8) ) & .AND. AVOID_TOO_SMALL_GRANULARITY & ) THEN IERR = -1 RETURN ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NDEST, PDEST) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_CB%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST SIZE_MSG_BYTES = SIZET - OVHSIZE * (NDEST-1) * KEEP(34) POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JPOSK+JBEG_BLOCK-1, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) LASTBL_INPANEL = (NBCOLS_ALREADY_SENT+NCOL_SEND.EQ.NCOLU) IF (LASTBL_INPANEL) THEN CALL MPI_PACK( -NCOL_SEND, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ELSE CALL MPI_PACK( NCOL_SEND, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDIF IF (LR_ACTIVATED) THEN LR_ACTIVATED_INT = 1 ELSE LR_ACTIVATED_INT = 0 ENDIF CALL MPI_PACK( LR_ACTIVATED_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IPANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN CALL ZMUMPS_MPI_PACKSCALE_LR_PARTIAL( BLR_LS, & NBLRB_ALREADY_SENT, NBLRB_PACKET, & BUF_CB%CONTENT( IPOSMSG: & IPOSMSG+(SIZE_MSG_BYTES+KEEP(34)-1)/KEEP(34)-1 ), & SIZE_MSG_BYTES, POSITION, COMM, & A, LA, POSBLOCFACTO, LD_BLOCFACTO, & IPIV, NPIV, MAXI_CLUSTER, IERR, IERROR ) IF (IERR.LT.0) RETURN ELSE CALL MPI_PACK( UIP21K(1_8+int(JBEG_BLOCK-1,8)*int(NPIV,8)), & NPIV * NCOL_SEND, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDIF NOTHING_WAS_SENT = .FALSE. DO IDEST = 1, NDEST KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, & PDEST(IDEST), BLOC_FACTO_SYM_SLAVE, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) END DO IF ( LASTBL_INPANEL ) THEN NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ELSE NBCOLS_ALREADY_SENT = NBCOLS_ALREADY_SENT + NCOL_SEND IF (LR_ACTIVATED) THEN NBLRB_ALREADY_SENT = NBLRB_ALREADY_SENT + NBLRB_PACKET ENDIF IERR = -1 ENDIF IF ( SIZE_MSG_BYTES .LT. POSITION ) THEN WRITE(*,*) ' Error sending blfac slave : size < position' WRITE(*,*) ' Size,position=',SIZE_MSG_BYTES,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_MSG_BYTES .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE ZMUMPS_BUF_SEND_BLFAC_SLAVE SUBROUTINE ZMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) 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, INTENT(IN) :: RG2L(N) INTEGER NSUPROW, NSUPCOL INTEGER(8), INTENT(IN) :: TABSIZE INTEGER SIZE_PACK INTEGER KEEP(500) COMPLEX(kind=8) VAL_SON( LD_SON, * ), TAB(*) LOGICAL TRANSP INTEGER N_ALREADY_SENT INTEGER :: NELIM_ROOT, NELIM_ROW, NELIM_COL INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER SIZE1, SIZE2, SIZE_AV, POSITION INTEGER SIZE_CBP, SIZE_TMP INTEGER IREQ, IPOS, ITAB INTEGER ISUB, JSUB, I, J INTEGER ILOC_ROOT, JLOC_ROOT INTEGER IPOS_ROOT, JPOS_ROOT INTEGER IONE LOGICAL RECV_BUF_SMALLER_THAN_SEND INTEGER PDEST2(1) PARAMETER ( IONE=1 ) INTEGER N_PACKET INTEGER NSUBSET_ROW_EFF, NSUBSET_COL_EFF, NSUPCOL_EFF PDEST2(1) = PDEST IERR = 0 IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF SIZE_AV = min(SIZE_AV, SIZE_RBUF_BYTES) CALL MPI_PACK_SIZE(8 + NSUBSET_COL, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE_CBP = 0 IF (N_ALREADY_SENT .EQ. 0 .AND. & min(NSUPROW,NSUPCOL) .GT.0) THEN CALL MPI_PACK_SIZE(NSUPROW, MPI_INTEGER, COMM, & SIZE_CBP, IERR_MPI ) CALL MPI_PACK_SIZE(NSUPCOL, MPI_INTEGER, COMM, & SIZE_TMP, IERR_MPI ) SIZE_CBP = SIZE_CBP + SIZE_TMP CALL MPI_PACK_SIZE(NSUPROW*NSUPCOL, & MPI_DOUBLE_COMPLEX, COMM, & SIZE_TMP, IERR_MPI ) SIZE_CBP = SIZE_CBP + SIZE_TMP SIZE1 = SIZE1 + SIZE_CBP ENDIF IF (BBPCBP.EQ.1) THEN NSUBSET_COL_EFF = NSUBSET_COL - NSUPCOL NSUPCOL_EFF = 0 ELSE NSUBSET_COL_EFF = NSUBSET_COL NSUPCOL_EFF = NSUPCOL ENDIF NSUBSET_ROW_EFF = NSUBSET_ROW - NSUPROW N_PACKET = & (SIZE_AV - SIZE1) / (SIZEofINT + NSUBSET_COL_EFF * SIZEofREAL) 10 CONTINUE N_PACKET = min( N_PACKET, & NSUBSET_ROW_EFF-N_ALREADY_SENT ) IF (N_PACKET .LE. 0 .AND. & NSUBSET_ROW_EFF-N_ALREADY_SENT.GT.0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF CALL MPI_PACK_SIZE( 8 + NSUBSET_COL_EFF + N_PACKET, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE1 = SIZE1 + SIZE_CBP CALL MPI_PACK_SIZE( N_PACKET * NSUBSET_COL_EFF, & MPI_DOUBLE_COMPLEX, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV) THEN N_PACKET = N_PACKET - 1 IF ( N_PACKET > 0 ) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (N_PACKET + N_ALREADY_SENT .NE. NSUBSET_ROW - NSUPROW & .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 10 & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF ELSE N_PACKET = 0 CALL MPI_PACK_SIZE(8,MPI_INTEGER, COMM, SIZE_PACK, IERR_MPI ) END IF IF ( SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE, PDEST2 & ) IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUBSET_ROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUPROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUBSET_COL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUPCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( N_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( N_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( BBPCBP, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN IF (N_ALREADY_SENT .EQ. 0 .AND. & min(NSUPROW, NSUPCOL) .GT. 0) THEN DO ISUB = NSUBSET_ROW-NSUPROW+1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IF ( I .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L(INDCOL_SON( I )) ENDIF ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO DO ISUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( ISUB ) JPOS_ROOT = INDROW_SON( J ) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO IF ( TABSIZE.GE.int(NSUPROW,8)*int(NSUPCOL,8) ) THEN ITAB = 1 DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW J = SUBSET_ROW(JSUB) DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL I = SUBSET_COL(ISUB) TAB(ITAB) = VAL_SON(J, I) ITAB = ITAB + 1 ENDDO ENDDO CALL MPI_PACK(TAB(1), NSUPROW*NSUPCOL, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ELSE DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW J = SUBSET_ROW(JSUB) DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL I = SUBSET_COL(ISUB) CALL MPI_PACK(VAL_SON(J,I), 1, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO ENDDO ENDIF ENDIF IF ( .NOT. TRANSP ) THEN DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) IF ( I .LE. NELIM_ROW ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L( INDROW_SON( I ) ) ENDIF ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO JSUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF J = SUBSET_COL( JSUB ) IF ( J .LE. NELIM_COL ) THEN JPOS_ROOT = NELIM_ROOT + J - 1 ELSE JPOS_ROOT = RG2L( INDCOL_SON( J ) ) ENDIF JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO JSUB = NSUBSET_COL_EFF-NSUPCOL_EFF+1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) JPOS_ROOT = INDCOL_SON( J ) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO ELSE DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) IF ( J .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + J - 1 ELSE IPOS_ROOT = RG2L( INDCOL_SON( J ) ) ENDIF ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO ISUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF I = SUBSET_COL( ISUB ) IF ( I .LE. NELIM_ROW ) THEN JPOS_ROOT = NELIM_ROOT + I - 1 ELSE JPOS_ROOT = RG2L( INDROW_SON( I ) ) ENDIF JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO ISUB = NSUBSET_COL_EFF - NSUPCOL_EFF + 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) JPOS_ROOT = INDROW_SON(I) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO END IF IF ( TABSIZE.GE.int(N_PACKET,8)*int(NSUBSET_COL_EFF,8) ) THEN IF ( .NOT. TRANSP ) THEN ITAB = 1 DO ISUB = N_ALREADY_SENT+1, & N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) DO JSUB = 1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) TAB( ITAB ) = VAL_SON(J,I) ITAB = ITAB + 1 END DO END DO CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ELSE ITAB = 1 DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) DO ISUB = 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) TAB( ITAB ) = VAL_SON( J, I ) ITAB = ITAB + 1 END DO END DO CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END IF ELSE IF ( .NOT. TRANSP ) THEN DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) DO JSUB = 1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) CALL MPI_PACK( VAL_SON( J, I ), 1, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO END DO ELSE DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) DO ISUB = 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) CALL MPI_PACK( VAL_SON( J, I ), 1, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO END DO END IF ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & PDEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN WRITE(*,*) ' Error sending contribution to root:Size 0) THEN SCALED(1:BLR(I)%K,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * BLR(I)%R(1:BLR(I)%K,J) J = J+1 CALL MPI_PACK( SCALED(1,1), BLR(I)%K, & MPI_DOUBLE_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) ELSE PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) PIV2 = A(POSELTD+LD_DIAG*J+J) OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) BLOCK(1:BLR(I)%K) = BLR(I)%R(1:BLR(I)%K,J) SCALED(1:BLR(I)%K,1) = PIV1 * BLR(I)%R(1:BLR(I)%K,J) & + OFFDIAG * BLR(I)%R(1:BLR(I)%K,J+1) CALL MPI_PACK( SCALED(1,1), BLR(I)%K, & MPI_DOUBLE_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) SCALED(1:BLR(I)%K,2) = OFFDIAG * BLOCK(1:BLR(I)%K) & + PIV2 * BLR(I)%R(1:BLR(I)%K,J+1) J =J+2 CALL MPI_PACK( SCALED(1,2), BLR(I)%K, & MPI_DOUBLE_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) ENDIF END DO ENDIF ELSE J = 1 DO WHILE (J <= BLR(I)%N) IF (IPIV(J) > 0) THEN SCALED(1:BLR(I)%M,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * BLR(I)%Q(1:BLR(I)%M,J) CALL MPI_PACK( SCALED(1,1), BLR(I)%M, & MPI_DOUBLE_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) J = J+1 ELSE PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) PIV2 = A(POSELTD+LD_DIAG*J+J) OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) BLOCK(1:BLR(I)%M) = BLR(I)%Q(1:BLR(I)%M,J) SCALED(1:BLR(I)%M,1) = PIV1 * BLR(I)%Q(1:BLR(I)%M,J) & + OFFDIAG * BLR(I)%Q(1:BLR(I)%M,J+1) CALL MPI_PACK( SCALED(1,1), BLR(I)%M, & MPI_DOUBLE_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) SCALED(1:BLR(I)%M,2) = OFFDIAG * BLOCK(1:BLR(I)%M) & + PIV2 * BLR(I)%Q(1:BLR(I)%M,J+1) CALL MPI_PACK( SCALED(1,2), BLR(I)%M, & MPI_DOUBLE_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) J=J+2 ENDIF END DO ENDIF ENDDO 500 CONTINUE IF (allocated(BLOCK)) deallocate(BLOCK) IF (allocated(SCALED)) deallocate(SCALED) 600 CONTINUE RETURN END SUBROUTINE ZMUMPS_MPI_PACKSCALE_LR_PARTIAL END MODULE ZMUMPS_BUF MUMPS_5.8.1/src/mumps_scotch_int.h0000664000175000017500000000133215042446422016756 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_SCOTCH_INT_H #define MUMPS_SCOTCH_INT_H #include "mumps_common.h" /* includes mumps_compat.h and mumps_c_types.h */ #define MUMPS_SCOTCH_INTSIZE \ F_SYMBOL(scotch_intsize,SCOTCH_INTSIZE) void MUMPS_CALL MUMPS_SCOTCH_INTSIZE(MUMPS_INT *scotch_int_size); #endif MUMPS_5.8.1/src/mumps_scotch64.c0000664000175000017500000001437415042446422016263 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Interfacing with 64-bit SCOTCH and pt-SCOTCH */ #include #include #include #include "mumps_scotch64.h" #if defined(scotch) || defined(ptscotch) void MUMPS_CALL MUMPS_SCOTCH_ORD_64( const MUMPS_INT8 * const n, /* in */ const MUMPS_INT8 * const iwlen, /* in */ MUMPS_INT8 * const petab, /* inout */ const MUMPS_INT8 * const pfree, /* in */ MUMPS_INT8 * const lentab, /* in (modified in ANA_H) */ MUMPS_INT8 * const iwtab, /* in (modified in ANA_H) */ MUMPS_INT8 * const nvtab, /* out or inout if weight used on entry */ MUMPS_INT8 * const elentab, /* out permutation on output */ MUMPS_INT8 * const lasttab, /* out */ MUMPS_INT * const ncmpa, /* out */ #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) SCOTCH_Context * const contextptr, #endif MUMPS_INT * const weightused, /* out */ MUMPS_INT * const weightrequested ) /* in */ { /* weightused(out) = weightrequested since it is always used to build graph FIXME it is not exploited on output and could be suppressed from interface = 0 otherwise */ /* weightused(out) = weightrequested since it is always used to build graph FIXME it is not exploited on output and could be suppressed from interface = 0 otherwise */ MUMPS_INT8 * vendtab ; /* Vertex end array */ SCOTCH_Graph grafdat; /* Graph */ #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) SCOTCH_Graph grafdat_with_context; #endif SCOTCH_Strat stratdat; MUMPS_INT8 vertnum; int ierr; *weightused = *weightrequested; vendtab=malloc(*n * sizeof(MUMPS_INT8)); for (vertnum = 0; vertnum < *n; vertnum ++) vendtab[vertnum] = petab[vertnum] + lentab[vertnum]; ierr=SCOTCH_graphInit (&grafdat); if ( *weightrequested == 1 ) { ierr=SCOTCH_graphBuild (&grafdat, 1, *n, (SCOTCH_Num *) petab, (SCOTCH_Num *) vendtab, (SCOTCH_Num *) nvtab, NULL, *iwlen, (SCOTCH_Num *) iwtab, NULL); /* Assume Fortran-based indexing */ } else { ierr=SCOTCH_graphBuild (&grafdat, 1, *n, (SCOTCH_Num *) petab, (SCOTCH_Num *) vendtab, NULL, NULL, *iwlen, (SCOTCH_Num *) iwtab, NULL); /* Assume Fortran-based indexing */ } ierr=SCOTCH_stratInit(&stratdat); #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) /* Initialize and bind grafdat_with_context */ ierr=SCOTCH_graphInit (&grafdat_with_context); ierr=SCOTCH_contextBindGraph(contextptr, &grafdat, &grafdat_with_context); *ncmpa=SCOTCH_graphOrder(&grafdat_with_context, &stratdat, (SCOTCH_Num *) elentab, (SCOTCH_Num *) lasttab, NULL, NULL, NULL); #else /* order grafdat without threads context */ *ncmpa=SCOTCH_graphOrder(&grafdat, &stratdat, (SCOTCH_Num *) elentab, (SCOTCH_Num *) lasttab, NULL, NULL, NULL); #endif #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) SCOTCH_graphExit(&grafdat_with_context); #endif SCOTCH_stratExit(&stratdat); SCOTCH_graphExit(&grafdat); free(vendtab); } void MUMPS_CALL MUMPS_SCOTCH_64( const MUMPS_INT8 * const n, /* in */ const MUMPS_INT8 * const iwlen, /* in */ MUMPS_INT8 * const petab, /* inout */ const MUMPS_INT8 * const pfree, /* in */ MUMPS_INT8 * const lentab, /* in (modified in ANA_H) */ MUMPS_INT8 * const iwtab, /* in (modified in ANA_H) */ MUMPS_INT8 * const nvtab, /* out or inout if weight used on entry */ MUMPS_INT8 * const elentab, /* out */ MUMPS_INT8 * const lasttab, /* out */ MUMPS_INT * const ncmpa, /* out */ #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) SCOTCH_Context * const contextptr, #endif MUMPS_INT * const weightused, /* out */ MUMPS_INT * const weightrequested ) /* in */ { /* weightused(out) = 1 if weight of nodes provided in nvtab are used (esmumpsv is called) = 0 otherwise */ #if ((SCOTCH_VERSION == 6) && (SCOTCH_RELEASE >= 1)) || (SCOTCH_VERSION >= 7) /* esmumpsv with integer weights of nodes in the graph are used on entry (nvtab) */ if ( *weightrequested == 1 ) { #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) #if ((SCOTCH_VERSION == 7) && (SCOTCH_RELEASE == 0)) || (SCOTCH_VERSION <= 6) *ncmpa = -1; printf(" ** internal error: esmumpsv with threads context but Scotch version < 7.1\n"); return; #else *ncmpa = esmumpsvc( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab, contextptr ); #endif #else *ncmpa = esmumpsv( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab ); #endif *weightused=1; } else { /* esmumps (weights of nodes not used on entry) */ #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) #if ((SCOTCH_VERSION == 7) && (SCOTCH_RELEASE == 0)) || (SCOTCH_VERSION <= 6) *ncmpa = -1; printf(" ** internal error: esmumps called with threads context but Scotch version < 7.1\n"); return; #else *ncmpa = esmumpsc( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab, contextptr ); #endif #else *ncmpa = esmumps( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab ); #endif *weightused=0; } #else /* esmumps for Scotch before 6.1: no weights and no context */ *ncmpa = esmumps( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab ); *weightused=0; #endif } #endif MUMPS_5.8.1/src/sini_defaults.F0000664000175000017500000016737115042446441016210 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C********************************************************************** C SUBROUTINE SMUMPS_SET_TYPE_SIZES( K34, K149, K150, K10 ) IMPLICIT NONE C C Purpose: C ======= C C Set the size in bytes of an "INTEGER" in K34 C Set the size of the default arithmetic (REAL, DOUBLE PRECISION, C REAL or DOUBLE REAL) in K149 C Set the size of floating-point types that are real or double C precision even for complex versions of MUMPS (REAL for S and C C versions, DOUBLE PRECISION for D and Z versions) C Assuming that the size of an INTEGER(8) is 8, store the ratio C nb_bytes(INTEGER(8)) / nb_bytes(INTEGER) = 8 / K34 into K10. C C In practice, we have: C C K149: Arithmetic Value Value for T3E C S 4 8 C D 8 16 C C 8 16 C Z 16 32 C C K150 = K149 for S and D arithmetics C K150 = K149 / 2 for C and Z arithmetics C C K34= 4 and K10 = 2, except on CRAY machines or when compilation C flag -i8 is used, in which case, K34 = 8 and K10 = 1 C INTEGER, INTENT(OUT) :: K34, K149, K10, K150 INTEGER(8) :: SIZE_INT, SIZE_REAL_OR_DOUBLE ! matches MUMPS_INT8 INTEGER I(2) REAL R(2) ! Will be DOUBLE PRECISION if 0 CALL MUMPS_SIZE_C(I(1),I(2),SIZE_INT) CALL MUMPS_SIZE_C(R(1),R(2),SIZE_REAL_OR_DOUBLE) K34 = int(SIZE_INT) K10 = 8 / K34 K150 = int(SIZE_REAL_OR_DOUBLE) K149 = K150 RETURN END SUBROUTINE SMUMPS_SET_TYPE_SIZES C C********************************************************************** C SUBROUTINE SMUMPSID( NSLAVES, LWK_USER, CNTL, ICNTL, & KEEP,KEEP8, & INFO, INFOG, RINFO, RINFOG, SYM, PAR, & DKEEP, MYID ) !$ USE OMP_LIB IMPLICIT NONE C C Purpose C ======= C C The elements of the arrays CNTL and ICNTL control the action of C SMUMPS, SMUMPS_ANA_DRIVER, SMUMPS_FAC_DRIVER, SMUMPS_SOLVE_DRIVER C Default values for the elements are set in this routine. C REAL DKEEP(230) REAL CNTL(15), RINFO(40), RINFOG(40) INTEGER ICNTL(60), KEEP(500), SYM, PAR, NSLAVES, MYID INTEGER INFO(80), INFOG(80) INTEGER(8) KEEP8(150) INTEGER LWK_USER C C Parameters C ========== C=========================================== C Arrays for control and information C=========================================== C C N Matrix order C C NELT Number of elements for matrix in ELt format C C C SYM = 0 ... initializes the defaults for unsymmetric code C = 1,2 ... initializes the defaults for symmetric code C C C C PAR = 0 ... instance where host is not working C = 1 ... instance where host is working as a normal node. C (host uses more memory than other processors in C the latter case) C C CNTL and the elements of the array ICNTL control the action of C SMUMPS Default values C are set by SMUMPSID. The elements of the arrays RINFO C and INFO provide information on the action of SMUMPS. C C CNTL(1) threshold for partial pivoting C has default -1.0 (automatic choice): C 0.1 in case of rank-revealing (ICNTL(56)=1,2) C otherwise 0.0 when SYM=1 and 0.01 otherwise. C Values greater than 1.0 are treated as 1.0 for C SYM=1 and as 0.5 for SYM=2 C In general, a larger value of CNTL(1) leads to C greater fill-in but a more accurate factorization. C If CNTL(1) is nonzero, numerical pivoting will be performed. C If CNTL(1) is zero, no pivoting will be performed and C the subroutine will fail if a zero pivot is encountered. C If the matrix A is diagonally dominant, then C setting CNTL(1) to zero will decrease the factorization C time while still providing a stable decomposition. C C CNTL(2) must be set to the tolerance for convergence of iterative C refinement. C Default value is sqrt(macheps). C Values less than zero are treated as sqrt(macheps). C C CNTL(3) is used with null pivot row detection (ICNTL(24) .eq. 1) C and/or with Rank-Revealing (RR) option (ICNTL(56)). C Default value is 0.0. C Let A_{preproc} be the preprocessed matrix to be factored (see C equation in the user's guide). C A pivot is considered to be null if the infinite norm of its C row/column is smaller than a threshold. Let MACHEPS be the C machine precision and ||.|| be the infinite norm. C The absolute value to detect a null pivot row (when ICNTL(24) .EQ.1) C is stored in DKEEP(1). C In case of RR, CNTL(3) will define the thresholds for : C C - Postponing pseudo singularities (SEUIL): C The computed threshold value for postponing pivots C is stored in "SEUIL" and then "SEUIL_LDLT_NIV2" C which are identical in current version. C C - Defining singularities on root (DKEEP(9)) C C - Defining null pivot rows if ICNTL(24).EQ.1 (DKEEP(1)) C in this case DKEEP(1) must be smaller than DKEEP(9) C C IF (ICNTL(56).NE.0) THEN C RR on root is active C IF (CNTL3 .LT. ZERO) THEN C DKEEP(9) = abs(CNTL(3)) C ELSE IF (CNTL3 .GT. ZERO) THEN C DKEEP(9) = CNTL3*||A_{preproc}|| C ELSE ! (CNTL(3) .EQ. ZERO) THEN C DKEEP(9) = sqrt(N_h)*MACHEPS*||A_{preproc}|| C where Nh is the number of pivots on the deepest branch C of the elimination tree. C ENDIF C IF (ICNTL(24).EQ.1) THEN C null pivot detection C DKEEP(1) = DKEEP(9)*DKEEP(10) C ENDIF C C ELSE (ONLY NULL PIVOT detection is active) C IF CNTL(3) > 0 THEN C DKEEP(1) = CNTL(3) ||A_{preproc}|| C ELSE IF CNTL(3) = 0.0 THEN C DKEEP(1) = MACHEPS sqrt(N_h)||A_{preproc}|| C ELSE IF CNTL(3) < 0 THEN C DKEEP(1) = abs(CNTL(3))! this was added for EDF C ! in the context of SOLSTICE project C ENDIF C ENDIF C C CNTL(4) must be set to value for static pivoting. C Default value is -1.0 C Note that static pivoting is enabled only when C Rank-Revealing and null pivot detection C are off (KEEP(19).EQ.0).AND.(KEEP(110).EQ.0). C If negative, static pivoting will be set OFF (KEEP(97)=0) C If positive, static pivoting is ON (KEEP(97=1) with C threshold CNTL(4) C If = 0, static pivoting is ON with threshold MACHEPS^1/2 || A || C C CNTL(5) fixation for null pivots C Default value is 0.0 C Only active if ICNTL(24) = 1 C If > 0 after finding a null pivot, it is set to CNTL(5) x ||A|| C (This value is stored in DKEEP(2)) C If <= 0 then C SYM=2: C the row/column (except the pivot) is set to zero C and the pivot is set to 1 C SYM=0: C the fixation is automatically C set to a large potitive value and the pivot row of the C U factors is set to zero. C Default is 0. C C CNTL(6) not used yet C C CNTL(7) tolerance for Low Rank approximation of the Blocks (BLR). C Dropping parameter expressed with a double precision, C real value, controlling C compression and used to truncate the RRQR algorithm C default value is 0.0. (i.e. no approximation). C The truncated RRQR operation is implemented as C as variant of the LAPACK GEQP3 and LAQPS routines. C 0.0 : full precision approximation. C > 0.0 : the dropping parameter is DKEEP(8). C C Warning: using negative values is an experimental and C non recommended setting. C < 0.0 : the dropping parameter is |DKEEP(8)|*|Apre|, Apre C as defined in user's guide C C C ----------------------------------------- C C ICNTL(1) has default value 6. C It is the output stream for error messages. C If it is set to zero, these C messages will be suppressed. C C ICNTL(2) has default value 0. C It is the output stream for diagnostic printing and C for warning messages that are local to each MPI process. C If it is set to zero, these messages are suppressed. C C ICNTL(3) -- Host only C It is the output stream for diagnostic printing C and for warning messages. Default value is 6. C If it is set to zero, these messages are suppressed. C C ICNTL(4) is used by SMUMPS to control printing of error, C warning, and diagnostic messages. It has default value 2. C Possible values are: C C <1 __No messages output. C 1 __Only error messages printed. C 2 __Errors and warnings printed. C 3 __Errors and warnings and terse diagnostics C (only first ten entries C of arrays printed). C 4 __Errors and warnings and all information C on input and output parameters printed. C C C ICNTL(5) is the format of the input matrix and rhs C 0: assembled matrix, assembled rhs C 1: elemental matrix, assembled rhs C Default value is 0. C C ICNTL(6) has default value 7 for unsymmetric and C general symmetric matrices, and 0 for SPD matrices. C It is only accessed and operational C on a call that includes an analysis phase C (JOB = 1, 4, or 6). C In these cases, if ICNTL(6)=1, 2, 3, 4, 5, 6 or 7, C a column permutation based on algorithms described in C Duff and Koster, 1997, *SIMAX <20>, 4, 889-901, C is applied to the original matrix. Column permutations are C then applied to the original matrix to get a zero-free diagonal. C Except for ICNTL(6)=1, the numerical values of the C original matrix, id%A(NE), need be provided by the user C during the analysis phase. C If ICNTL(6)=7, based on the structural symmetry of the C input matrix the value of ICNTL(6) is automatically chosen. C If the ordering is provided by the user C (ICNTL(7)=1) then the value of ICNTL(6) is ignored. C C ICNTL(7) has default value 7 and must be set by the user to C 1 if the pivot order in IS is to be used. C Effective value of ordering stored in KEEP(256). C Possible values are (depending on the softwares installed) C 0 AMD: Approximate minimum degree (included in SMUMPS package) C 1 Ordering provided by the user C 2 Approximate minimum fill (included in SMUMPS package) C 3 SCOTCH (see http://gforge.inria.fr/projects/scotch/) C should be downloaded/installed separately. C 4 PORD from Juergen Schulze (js@juergenschulze.de) C PORD package is extracted from the SPACE-1.0 package developed at the C University of Paderborn by Juergen Schulze C and is provided as a separate package. C 5 Metis ordering should be downloaded/installed separately. C 6 Approximate minimum degree with automatic quasi C dense row detection (included in SMUMPS package). C (to be used when ordering time with AMD is abnormally large) C 7 Automatic choice done during analysis phase C For any other C value of ICNTL(7), a suitable pivot order will be C chosen automatically. C C ICNTL(8) is used to describe the scaling strategy. C Default value is 77. C Note that scaling is performed only when the numerical C factorization step is performed (JOB = 2, 4>, 5>, or 6>). C If ICNTL(8) is not equal to C any of the values listed below then ICNTL(8) is treated C as if it had its default value of 0 (no scaling). C If the matrix is known to be very badly scaled, C our experience has been that option 6 is the most robust but C the best scaling is very problem dependent. C If ICNTL(8)=0, COLSCA and ROWSCA are dummy arguments C of the subroutine that are not accessed. C Possible values of ICNTL(8) are: C C -2 scaling computed during analysis (and applied during the C factorization) C C -1 the user must provide the scaling in arrays C COLSCA and ROWSCA C C 0 no scaling C C 1 Diagonal scaling C C 2 not defined C C 3 Column scaling C C 4 Row and column scaling C C 5,6 not defined C 7, 8 Scaling based on Daniel Ruiz and Bora Ucar's work done C during the ANR-SOLSTICE project. C Reference for this work are: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C This scaling can work on both centralized and distributed C assembled input matrix format. (it works for both symmetric C and unsymmetric matrices) C Option 8 is similar to 7 but more rigourous and expensive to compute. C 77 Automatic choice of scaling value done. Proposed algo: C if (sym=1) then C option = 0 C else C if distributed matrix entry then C option = 7 C else C if (maximum transversal is called C and makes use of numerical values) then C option=-2 and ordering is computed during analysis C else C option = 7 C endif C endif C endif C C ICNTL(9) has default value 1. If ICNTL(9)=1 C the system of equations A * x = b is solved. For other C values the system A^T * x = b is solved. C When ICNTL(30) (compute selected entries in A-1) is activated C ICNTL(9) is ignored. C C ICNTL(10) has default value 0. C If ICNTL(10)=0 : iterative refinement is not performed. C Values of ICNTL(10) < 0 : a fix number of steps equal C to ICNTL(10) of IR is done. C Values of ICNTL(10) > 0 : mean a maximum of ICNTL(10) number C of steps of IR is done, and a test of C convergence is used C C ICNTL(11) has default value 0. C A value equal to 1 will return a backward error estimate in C RINFO(4-11). C A value equal to 2 will return a backward error estimate in C RINFO(4-8). No LCOND 1, 2 and forward error are computed. C If ICNTL(11) is negative, zero or greater than 2 no estimate C is returned. C C C ICNTL(12) has default value 0 and defines the strategy for C LDLT orderings C 0 : automatic choice C 1 : usual ordering (nothing done) C 2 : ordering on the compressed graph, available with all orderings C except with AMD C 3 : constraint ordering, only available with AMF, C -> reset to 2 with other orderings C Other values are treated as 1 (nothing done). C On output KEEP(95) holds the internal value used and INFOG(24) gives C access to KEEP(95) to the user. C in LU facto it is always reset to 1 C C - ICNTL(12) = 3 has a lower priority than ICNTL(7) C thus if ICNTL(12) = 3 and the ordering required is not AMF C then ICNTL(12) is set to 2 C C - ICNTL(12) = 2 has a higher priority than ICNTL(7) C thus if ICNTL(12) = 2 and the ordering required is AMD C then the ordering used is QAMD C C - ICNTL(12) has a higher priority than ICNTL(6) and ICNTL(8) C thus if ICNTL(12) = 2 then ICNTL(6) is automatically C considered as if it was set to a value between 1-6 C if ICNTL(12) = 3 then ICNTL(6) is considered as if C set to 5 and ICNTL(8) as if set to -2 (we need the scaling C factors to define free and constrained variables) C C ICNTL(13) has default value 0 and allows for selecting Type 3 node. C IF ICNTL(13).GT. 0 scalapack is forbidden. Otherwise, C scalapack will be activated if the root is large enough. C Furthermore C IF ((ICNTL(13).GT.0) .AND. (NSLAVES.GT.ICNTL(13), C or ICNTL(13)=-1 THEN C extra splitting of the root will be activated C and is controlled by abs(KEEP(82)). C The order of the root node is divided by KEEP(82) C ENDIF C If ICNTL(13) .EQ. -1 then splitting of the root C is done whatever the nb of procs is. C Authorizing extra root spliting during analysis might be C interesting to further split the root node (combined for C example with null pivot detection option ICNTL(24)=1 OR ICNTL(56)) C C To summarize: C -1 : root splitting and scalapack on C 0 or < -1 : root splitting off and sclalapack on C > 0 : scalapack off C C ICNTL(14) has default value 20 (5 if NSLAVES=1 and SYM=1) C and is the value for memory relaxation C so called "PERLU" in the following. C C C ICNTL(15) : Describes the compression of the graph of the input matrix C The analysis step is then performed on the compressed C graph C Must be set during analysis on the master C 0 : OFF C 1 : Compression provided by the user: C BLKPTR(1:id%NBLK+1) and C BLKVAR(1:N or N_LOC if distributed format) C (BLKVAR(BLKPTR(iblk):BLKPTR(iblk+1)-1): C dof list for iblk) C - If BLKVAR is not provided then BLKVAR is C treated as the identity C (contiguous variables in blocks) C - Distributed format if on MASTER N_LOC#N C C ICNTL(16) : number of OpenMP threads asked by the user. C C ICNTL(17) not used in this version C C ICNTL(18) has default value 0 and is only accessed by the host during C the analysis phase if the matrix is assembled (ICNTL(5))= 0). C ICNTL(18) defines the strategy for the distributed input matrix. C Possible values are: C 0: input matrix is centralized on the host. This is the default C 1: user provides the structure of the matrix on the host at analysis, C SMUMPS returns C a mapping and user should provide the matrix distributed according C to the mapping C 2: user provides the structure of the matrix on the host at analysis, C and the C distributed matrix on all slave processors at factorization. C Any distribution is allowed C 3: user directly provides the distributed matrix input both C for analysis and factorization C C For flexibility and performance issues, option 3 is recommended. C C ICNTL(19) has default value 0 and is only accessed by the host C during the analysis phase. If ICNTL(19) \neq 0 then Schur matrix will C be returned to the user. C The user must set on entry on the host node (before analysis): C the integer variable SIZE\_SCHUR to the size fo the Schur matrix, C the integer array pointer LISTVAR\_SCHUR to the list of indices C of the schur matrix. C if = 0 : Schur is off and the root node gets factorized C if = 1 : Schur is on and the Schur complement is returned entirely C on a memory area provided by the user ONLY on the host node C if = 2 or 3 : Schur is on and the Schur complement is returned in a C distributed fashion according to a 2D block-cyclic C distribution. In the case where the matrix is symmetric C the lower part is returned if =2 or the complete C matrix if =3. C C ICNTL(20) has default value 0 and is only accessed by the host C during the solve phase. If ICNTL(20)=0, the right-hand side must given C in dense form in the structure component RHS. C If ICNTL(20)=1,2,3, then the right-hand side must be given in sparse form C using the structure components IRHS\_SPARSE, RHS\_SPARSE, IRHS\_PTR and C NZ\_RHS. C When the right-hand side is provided in sparse form then duplicate entries C are summed. C C 0 : dense RHS C 1,2,3 : Sparse RHS C 1 The decision of exploiting sparsity of the right-hand side to C accelerate the solution phase is done automatically. C 2 Sparsity of the right-hand sides is NOT exploited C to improve solution phase. C 3 Sparsity of the right-hand sides is exploited C to improve solution phase. C Values different from 0,1, 2,3 are treated as 0. C For sparse RHS recommended value is 1. C C ICNTL(21) has default value 0 and is only accessed by the host C during the solve phase. If ICNTL(21)=0, the solution vector will be assembled C and stored in the structure component RHS, that must have been allocated by C the user. If ICNTL(21)=1, the solution vector is kept distributed at the C end of the solve phase, and will be available on each slave processor C in the structure components ISOL_loc and SOL_loc. ISOL_loc and SOL_loc C must then have been allocated by the user and must be of size at least C INFO(23), where INFO(23) has been returned by SMUMPS at the end of the C factorization phase. C Values of ICNTL(21) different from 0 and 1 are currently treated as 0. C C ICNTL(22) (saved in KEEP(201) controls the OOC setting (0=incore, 1 =OOC) C It has default value 0 (incore).Out-of-range values are treated as 0. C If set before analysis then special setting and massage of the tree C might be done (so far only extra splitting CUTNODES) is performed. C It is then accessed by the host C during the factorization phase. If ICNTL(22)=0, then no attempt C to use the disks is made. If ICNTL(22)=1, then SMUMPS will store C the computed factors on disk for later use during the solution C phase. C C ICNTL(23) has default value 0 and is accessed by ALL processors C at the beginning of the factorization phase. If positive C it corresponds to the maximum size of the working memory C in MegaBytes that MUMPS can allocate per working processor. C If only the host C value is non zero, then other processors also use the value on C the host. Otherwise, each processor uses the local value C provided. C C ICNTL(24) default value is 0 C if = 0 no null pivot detection (CNTL(5) and CNTL(3) are inactive), C = 1 null pivot row detection; CNTL(3) and CNTL(5) are C then used to describe the action taken. C C C ICNTL(25) has default value 0 and is only accessed by the C host during the solution stage. It is only significant if C a null space basis was requested during the factorization C phase (INFOG(28) .GT. 0); otherwise a normal solution step C is performed. C If ICNTL(25)=0, then a normal solution step is performed, C on the internal problem (excluding the null space). C No special property on the solution (discussion with Serge) C If ICNTL(25)=i, 1 <= i <= INFOG(28), then the i-th vector C of the null space basis is computed. In that case, note C that NRHS should be set to 1. C If ICNTL(25)=-1, then all null space is computed. The C user should set NRHS=INFOG(28) in that case. C Note that centralized or distributed solutions are C applicable in that case, but that iterative refinement, C error analysis, etc... are excluded. Note also that the C option to solve the transpose system (ICNTL(9)) is ignored. C C C ICNTL(26) has default value 0 and is accessed on the host only C at the beginning of the solution step. C It is only effective if the Schur option is ON. C (copy in KEEP(221)) C C C During the solution step, a value of 0 will perform a normal C solution step on the reduced problem not involving the Schur C variables. C During the solution step, if ICNTL(26)=1 or 2, then REDRHS C should be allocated of size at least LREDRHS*(NRHS-1)+ C SIZE_SCHUR, where LREDRHS is the leading dimension of C LREDRHS (LREDRHS >= SIZE_SCHUR). C C If ICNTL(26)=1, then only a forward substitution is performed, C and a reduced RHS will be computed and made available in C REDRHS(i+(k-1)*LREDRHS), i=1, ..., SIZE_SCHUR, k=1, ..., NRHS. C If ICNTL(26)=2, then REDRHS(i+(k-1)*LREDRHS),i=1, SIZE_SCHUR, C k=1,NRHS is considered to be the solution corresponding to the C Schur variables. It is injected in SMUMPS, that computes the C solution on the "internal" problem during the backward C substitution. C C ICNTL(27) controls the blocking factor for multiple right-hand-sides C during the solution phase. C It influences both the memory used (see INFOG(30-31)) and C the solution time C (Larger values of ICNTL(27) leads to larger memory requirements). C Its tuning can be critical when C the factors are written on disk (out-of core, ICNTL(22)=1). C A negative value indicates that automatic setting is C performed by the solver. C C C ICNTL(28) decides whether parallel or sequential analysis should be used. Three C values are possible at the moment: C 0: automatic. This defaults to sequential analysis C 1: sequential. In this case the ordering strategy is defined by ICNTL(7) C 2: parallel. In this case the ordering strategy is defined by ICNTL(29) C C ICNTL(29) defines the ordering too to be used during the parallel analysis. Three C values are possible at the moment: C 0: automatic. This defaults to PT-SCOTCH C 1: PT-SCOTCH. C 2: ParMetis. C C C ICNTL(30) controls the activation of functionality A-1. C It has default value 0 and is only accessed by the master C during the solution phase. It enables the solver to C compute entries in the inverse of the original matrix. C Possible values are: C 0 normal solution C other values: compute entries in A-1 C When ICNTL(30).NE.0 then the user C must describe on entry to the solution phase, C in the sparse right-hand-side C (NZ_RHS, NRHS, RHS_SPARSE, IRHS_SPARSE, IRHS_PTR) C the target entries of A-1 that need be computed. C Note that RHS_SPARSE must be allocated but need not be C initialized. C On output RHS_SPARSE then holds the requested C computed values of A-1. C Note that when ICNTL(30).NE.0 then C - sparse right hand side interface is implicitly used C functionality (ICNTL(20)= 1) but RHS need not be C allocated since computed A-1 entries will be stored C in place. C - ICNTL(9) option (solve Ax=b or Atx=b) is ignored C In case of duplicate entries in the sparse rhs then C on output duplicate entries in the solution are provided C in the same place. C This need not be mentioned in the spec since it is a C "natural" extension. C C ----------- C Fwd in facto C ----------- C ICNTL(31) Must be set before analysis to control storage C of LU factors. Default value is 0. Out of range C values considered as 0. C (copied in KEEP(251) and broadcast, C when setting of ICNTL(31) C results in not factors to be stored then C KEEP(201) = -1, OOC is "suppressed") C 0 Keep factors needed for solution phase C (when option forward during facto is used then C on unsymmetric matrices L factors are not stored) C 1 Solve not needed (solve phase will never be called). C When the user is only interested in the inertia or the C determinant then C all factor matrices need not be stored. C This can also be useful for testing : C to experiment facto OOC without C effective storage of factors on disk. C 2 L factors not stored: meaningful when both C - matrix is unsymmetric and fwd performed during facto C - the user is only interested in the null-space basis C and thus only need the U factors to be stored. C Currently, L factors are always stored in IC. C C ----------- C Fwd in facto C ----------- C ICNTL(32) Must be set before analysis to indicate whether C forward is performed during factorization. C Default value is 0 (normal factorization without fwd) C (copied in KEEP(252) and broadcast) C 0 Normal factorization (default value) C 1 Forward performed during factorization C C C ICNTL(33) Must be set before the factorization phase to compute C the determinant. See also KEEP(258), KEEP(259), C DKEEP(6), DKEEP(7), INFOG(34), RINFOG(12) C C If ICNTL(33)=0 the determinant is not computed C For all other values, the determinant is computed. Note that C null pivots and static pivots are excluded from the C computation of the determinant. C #if ! defined(NO_SAVE_RESTORE) C ICNTL(34) Must be set before a call to MUMPS with JOB=-3 in case C the save/restore feature was used and user wants to clean C save/restore files (and possibly OOC files). C ICTNL(34)=0 => user wants to be able to restore instance later C ICTNL(34)=1 => user will not restore the instance again (clean C to be done) #endif C C ICNTL(35) : Block Low-Rank (BLR) functionality, C need be set before analysis C Default value is 0 C 0: FR factorization and FR solve C 1: Automatic BLR option setting (=> 2) C 2: BLR factorization + BLR Solve C => keep BLR factors only C 3: BLR factorization + FR Solve C Other values are treated as zero C Note that this functionality is currently incompatible C with elemental matrices (ICNTL(5) = 1) and with C forward elimination during factorization (ICNTL(32) = 1) C C ICNTL(36) : Block Low-Rank variant choice C Default value is 0 C 0: UFSC variant, no recompression: Compress step is C performed after the Solve; the low-rank updates are not C recompressed C 1: UFCS variant, no recompression: Factor (with pivoting) on full-rank blocks, C then Compress and finally Solve on low-rank blocks (those where pivoting is not needed, C which depends on the context) C C ICNTL(37) : Compress CB strategy need be set before factorization C 0 = DONT compress CB (default) C 1 = SYSTEMATIC compress CB: compress CB for all candidate fronts C C ICNTL(38): Compression rate of LU factors, can be set before C analysis/factorization C Between 0 and 1000; other values ares treated as 0; C ICNTL(38)/10 is a percentage representing the typical C compressed factors compression of the factor matrices C in BLR fronts: C ICNTL(38)/10= compressed/uncompressed factors × 100. C Default value: 600 C (when factors of BLR fronts are compressed, C their size is 60% of their full- rank size). C ICNTL(39) : Compression rate of Contribution Blocks (CBs) C can be set before analysis/factorization C Between 0 and 1000; other values ares treated as 0; C corresponds to an estimated compression rate of C ICNTL(39)/1000%. C Default value: 500 (50.0% compression rate). C ICNTL(48) : Controls L0_OMP feature. It must be set on the host C before the analysis phase to prepare datastructures C for factorization. C If ICNTL(48) was nonzero during analysis, C L0-OMP will be activated during factorization. C OMP_NUM_THREADS should not change between analysis C and factorization, as long as L0 task scheduling during C factorization is static. C ICNTL(48) can however change between factorization C and solve phases. If activated during analysis, the C number of threads for L0OMP (for both analysis and C factorization) is saved in KEEP(400) (see above). C For LO_OMP feature to be effective during solve C both KEEP(400)>0 and ICNTL(48)>0 are needed C Possible values at analysis: C 0 : off -- L0-OMP is not activated for analysis C and factorization C >0 : on -- L0-OMP is activated for analysis C and factorization C out-of-range values (<0) : off C Possible values at solve: C 0 : off --L0-OMP is not activated for solve. C Possible even if L0-OMP was activated during C analysis/factorization C >0 : on --L0-OMP activated for solve. C Possible only if L0-OMP was activated during C analysis/factorization C if (defined(_OPENMP)) then C default value is 1 (L0-thread ON) C else C default value is 0 (L0thread OFF) C endif C out of range values are treated as 0 C C C ICNTL(49): compact workarray id%S before solution phase C must be set before factorization C 0 : nothing is done. C 1 : compact workarray id%S(MAXS) at the end of the C factorization phase while satisfying the C memory contraint that might have been provided C with ICNTL(23) feature. C 2 : compact workarray id%S(MAXS) at the end of the C factorization phase. The memory C constraint that might have been provided with C ICNTL(23) feature does not apply to this process C Other values are treated as 0. C Default value: 0 C C C ICNTL(56) has default value 0 and is only accessed by the host. C During the analysis phase, a positive value prepares the data for C later use of null space functionalities (saved in KEEP(53)). C (the tree is modified to have only one root in analysis) C If ICNTL(56) is negative or zero, null space feature will C be forbidden during the factorization phase. C During the factorization phase, if ICNTL(56) was positive C (KEEP(53)>0) for analysis, then the values of ICNTL(56) (saved C in KEEP(19)) have the following meaning. C 0: No null space analysis, C 1: Null space analysis on last root node using SVD, C 2: Null space analysis on last root node using QR, C C The singular values (ICNTL(56)=1) or the diagonal entries of R C (ICNTL(56)=2) are available in root%SINGULAR_VALUES C C C C ICNTL(58): strategy for symbolic factorization used C with centralized ordering based on METIS (ICNTL(7)=5) C or with given given ordering (ICNTL(7)=1) C C Default value 2 C 1 => SYMBQAMD based symbolic factorization C 2 => Column count based symbolic factorization C Symbolic factorization based on C [GIMP94] "An efficient algorithm to compute row and column C counts for sparse cholesky factorization" C John R. Gilbert, Esmond G. Ng, and Barry W. Peyton C SIMAX 1994 C implementation of the algorithm described in figure 3 C of the [GINP94] article C C Other values are treated as 1 C C========================= C ARRAYS FOR INFORMATION C======================== C C----- C INFO is an INTEGER array of length 80 that need not be C set by the user. C----- C C INFO(1) is zero if the routine is successful, is negative if an C error occurred, and is positive for a warning (see SMUMPS for C a partial documentation and the userguide for a full documentation C of INFO(1)). C C INFO(2) holds additional information concerning the C error (see SMUMPS). C C ------------------------------------------ C Statistics produced after analysis phase C ------------------------------------------ C C INFO(3) Estimated real space needed for factors. C C INFO(4) Estimated integer space needed for factors. C C INFO(5) Estimated maximum frontal size. C C INFO(6) Number of nodes in the tree. C C INFO(7) Minimum value of integer working array IS (old MAXIS) C estimated by the analysis phase C to run the numerical factorization. C C INFO(8) Minimum value of real/complex array S (old MAXS) C estimated by the analysis phase C to run the numerical factorization. C C INFO(15) Estimated size in MBytes of all SMUMPS internal data C structures to run factorization C C INFO(17) provides an estimation (minimum in Megabytes) C of the total memory required to run C the numerical phases out-of-core. C This memory estimation corresponds to C the least memory consuming out-of-core strategy and it can be C used as a lower bound if the user wishes to provide ICNTL(23). C --------------------------------------- C Statistics produced after factorization C --------------------------------------- C INFO(9) Size of the real space used to store the LU factors possibly C including BLR compressed factors C C INFO(10) Size of the integer space used to store the LU factors C C INFO(11) Order of largest frontal matrix. C C INFO(12) Number of off-diagonal pivots in unsymmetric case / C number of negative pivots in symmetric case C C INFO(13) Number of uneliminated variables sent to the father. C C INFO(14) Number of memory compresses. C C INFO(18) On exit to factorization: C Local number of null pivots (ICNTL(24)=1) C on the local processor even on master. C (local size of array PIVNUL_LIST). C Note that it also includes null pivots C that might have been further detected on C the root if ICNTL(56).NE.0. and root C processed by MYID C C INFO(19) - after analysis: C Estimated size of the main internal integer workarray IS C (old MAXIS) to run the numerical factorization out-of-core. C C INFO(21) - after factorization: Effective space used in the main C real/complex workarray S -- or in the workarray WK_USER, C in the case where WK_USER is provided. C C INFO(22) - after factorization: C Size in millions of bytes of memory effectively used during C factorization. C This includes the memory effectively used in the workarray C WK_USER, in the case where WK_user is provided. C C INFO(23) - after factorization: total number of pivots eliminated C on the processor. In the case of a distributed solution (see C ICNTL(21)), this should be used by the user to allocate solution C vectors ISOL_loc and SOL_loc of appropriate dimensions C (ISOL_LOC of size INFO(23), SOL_LOC of size LSOL_LOC * NRHS C where LSOL_LOC >= INFO(23)) on that processor, between the C factorization and solve steps. C C INFO(24) - after analysis: estimated number of entries in factors on C the processor. If negative, then C the absolute value corresponds to {\it millions} of entries C in the factors. C Note that in the unsymmetric case, INFO(24)=INFO(3). C In the symmetric case, however, INFO(24) < INFO(3). C INFO(25) - after factorization: number of tiny pivots (number of C pivots modified by static pivoting) detected on the processor. C INFO(26) - after solution: C effective size in Megabytes of all working space C to run the solution phase. C (The maximum and sum over all processors are returned C respectively in INFOG(30) and INFOG(31)). C INFO(27) - after factorization: effective number of entries in factors C on the processor. If negative, then C the absolute value corresponds to {\it millions} of entries C in the factors. C Note that in the unsymmetric case, INFO(27)=INFO(9). C In the symmetric case, however, INFO(27) < INFO(9). C The total number of entries over all processors is C available in INFOG(29). C C C ------------------------------------------------------------- C ------------------------------------------------------------- C RINFO is a REAL/DOUBLE PRECISION array of length 40 that C need not be set by the user. This array supplies C local information on the execution of SMUMPS. C C C RINFOG is a REAL/DOUBLE PRECISION array of length 40 that C need not be set by the user. This array supplies C global information on the execution of SMUMPS. C RINFOG is only significant on processor 0 C C C RINFO(1) hold the estimated number of floating-point operations C for the elimination process on the local processor C C RINFOG(1) hold the estimated number of floating-point operations C for the elimination process on all processors C C RINFO(2) Number of floating-point operations C for the assembly process on local processor. C C RINFOG(2) Number of floating-point operations C for the assembly process. C C RINFO(3) Number of floating-point operations C for the elimination process on the local processor. C C RINFOG(3) Number of floating-point operations C for the elimination process on all processors. C C---------------------------------------------------- C Statistics produced after solve with error analysis C---------------------------------------------------- C C RINFOG(4) Infinite norm of the input matrix. C C RINFOG(5) Infinite norm of the computed solution, where C C RINFOG(6) Norm of scaled residuals C C RINFOG(7), `RINFOG(8) and `RINFOG(9) are used to hold information C on the backward error. C We calculate an estimate of the sparse backward error using the C theory and measure developed C by Arioli, Demmel, and Duff (1989). The scaled residual w1 C is calculated for all equations except those C for which numerator is nonzero and the denominator is small. C For the exceptional equations, w2, is used instead. C The largest scaled residual (w1) is returned in C RINFOG(7) and the largest scaled C residual (w2) is returned in `RINFOG(8)>. If all equations are C non exceptional then zero is returned in `RINFOG(8). C The upper bound error is returned in `RINFOG(9). C C RINFOG(14) Number of floating-point operations C for the elimination process (on all fronts, BLR or not) C performed when BLR option is activated on all processors. C (equal to zero if BLR option not used, ICNTL(35).EQ.1) C C RINFOG(15) - after analysis: if the user decides to perform an C out-of-core factorization (ICNTL(22)=1), then a rough C estimation of the total size of the disk space in MegaBytes of C the files written by all processors is provided in RINFOG(15). C C RINFOG(16) - after factorization: in the case of an out-of-core C execution (ICNTL(22)=1), the total C size in MegaBytes of the disk space used by the files written C by all processors is provided. C C RINFOG(17) - after each job: sum over all processors of the sizes C (in MegaBytes) of the files used to save the instance C C RINFOG(18) - after each job: sum over all processors of the sizes C (in MegaBytes) of the MUMPS structures. C C RINFOG(19) - after factorization: smallest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre and considering also C small pivots selected as null-pivots (see ICNTL(24)) C and pivots on which static pivoting was applied C C RINFOG(20) - after factorization: smallest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre and NOT considering C small pivots selected as null-pivots (see ICNTL(24)) C and pivots on which static pivoting was applied C C RINFOG(21) - after factorization: largest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre. C C RINFOG(22) - after factorization: C total number of floating-point operations offloaded to C the accelerator(s) by all MPI processes (see RINFO(9)) C C RINFOG(23) - after factorization: average (over all MPI processes) C time spent in operations offloaded to the accelerators C including communication (see RINFO(10)). C C Computed when solve involves exploit sparsity (fwd and/or bwd) C here we only report off diagonal flops) C #if defined(STAT_ES_SOLVE) C RINFOG(24) - FR FLOPS (off diagonal flops) C RINFOG(25) - FR FLOPS (off diag) with Exploit sparsity C (possibly with nb_sparse algo used) #endif C C C=========================== C DESCRIPTION OF KEEP8 ARRAY C=========================== C C KEEP8 is a 64-bit integer array of length 150 that need not C be set by the user C #if ! defined(NO_SAVE_RESTORE) #endif C=========================== C DESCRIPTION OF KEEP ARRAY C=========================== C C KEEP is an INTEGER array of length 500 that need not C be set by the user. C C C============================= C Description of DKEEP array C============================= C C DKEEP internal control array for REAL parameters C of size 30 C=================================== C Default values for control arrays C================================== C uninitialized values should be 0 LWK_USER = 0 KEEP(1:500) = 0 KEEP8(1:150)= 0_8 INFO(1:80) = 0 INFOG(1:80) = 0 ICNTL(1:60) = 0 RINFO(1:40) = 0.0E0 RINFOG(1:40)= 0.0E0 CNTL(1:15) = 0.0E0 DKEEP(1:230) = 0.0E0 C ---------------- C Symmetric code ? C ---------------- KEEP( 50 ) = SYM C ------------------------------------- C Only options 0, 1, or 2 are available C ------------------------------------- IF ( KEEP(50).NE.1 .and. KEEP(50).NE.2 ) KEEP( 50 ) = 0 C threshold value for pivoting C Automatic choice depending on (SYM and ICNTL(56)) CNTL(1) = -1.0E0 CNTL(2) = sqrt(epsilon(0.0E0)) CNTL(3) = 0.0E0 CNTL(4) = -1.0E0 CNTL(5) = 0.0E0 C Working host ? KEEP(46) = PAR IF ( KEEP(46) .NE. 0 .AND. & KEEP(46) .NE. 1 ) THEN C ---------------------- C If out-of-range value, C use a working host C ---------------------- KEEP(46) = 1 END IF C control printing ICNTL(1) = 6 ICNTL(2) = 0 ICNTL(3) = 6 ICNTL(4) = 2 C format of input matrix ICNTL(5) = 0 C maximum transversal (0=NO, 7=automatic) IF (SYM.NE.1) THEN ICNTL(6) = 7 ELSE ICNTL(6) = 0 ENDIF C Ordering option (icntl(7)) C Default is automatic choice done during analysis ICNTL(7) = 7 C ask for scaling (0=NO, 4=Row and Column) C Default value is 77: automatic choice for analysis ICNTL(8) = 77 C solve Ax=b (1) or Atx=b (other values) ICNTL(9) = 1 C Naximum number of IR (0=NO) ICNTL(10) = 0 C Error analysis (0=NO) ICNTL(11) = 0 C Control ordering strategy C automatic choice IF(SYM .EQ. 2) THEN ICNTL(12) = 0 ELSE ICNTL(12) = 1 ENDIF C Control of the use of ScaLAPACK for root node C If null space options asked, ScaLAPACK is always ignored C and ICNTL(13) is not significant C ICNTL(13) = 0 : Root parallelism on (if size large enough) C ICNTL(13) = 1 : Root parallelism off #if defined(NOSCALAPACK) ICNTL(13) = 1 #else ICNTL(13) = 0 #endif C Default value for the memory relaxation IF (SYM.eq.1.AND.NSLAVES.EQ.1) THEN ICNTL(14) = 5 ! it should work with 0 ELSE ICNTL(14) = 20 END IF IF (NSLAVES.GT.4) ICNTL(14) = ICNTL(14) + 5 IF (NSLAVES.GT.8) ICNTL(14) = ICNTL(14) + 5 IF (NSLAVES.GT.16) ICNTL(14)= ICNTL(14) + 5 C Distributed matrix entry ICNTL(18) = 0 C Schur (default is not active) ICNTL(19) = 0 C dense RHS by default ICNTL(20) = 0 C solution vector centralized on host ICNTL(21) = 0 C out-of-core flag ICNTL(22) = 0 C MEM_ALLOWED (0: not provided) ICNTL(23) = 0 C null pivots ICNTL(24) = 0 C blocking factor for multiple RHS during solution phase ICNTL(27) = -32 C analysis strategy: 0=auto, 1=sequential, 2=parallel ICNTL(28) = 1 C tool used for parallel ordering computation : C 0 = auto, 1 = PT-SCOTCH, 2 = ParMETIS ICNTL(29) = 0 C Default BLR compression rate of factors (60%) ICNTL(38) = 600 C Default BLR compression rate of factors (50%) ICNTL(39) = 500 C L0-thread feature #if defined(_OPENMP) C Activate L0OMP ICNTL(48) = 1 #else C Do not activate L0OMP ICNTL(48) = 0 #endif ICNTL(55) = 0 ICNTL(56) = 0 ICNTL(57) = 0 ICNTL(58) = 2 C=================================== C Default values for some components C of KEEP array C=================================== KEEP(12) = 0 KEEP(24) = 18 KEEP(68) = 0 KEEP(30) = 2000 KEEP(36) = 1 KEEP(1) = 5 KEEP(7) = 150 KEEP(8) = 120 KEEP(57) = 2000 KEEP(58) = 1000 IF ( SYM .eq. 0 ) THEN KEEP(4) = 32 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 32 KEEP(9) = 700 KEEP(85) = 300 KEEP(62) = 10 ELSE KEEP(4) = 24 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 32 KEEP(9) = 400 KEEP(85) = 100 KEEP(62) = 10 END IF KEEP(11)=200 KEEP(63) = 60 KEEP(48) = 5 CALL SMUMPS_SET_TYPE_SIZES( KEEP(34), KEEP(149), & KEEP(150), KEEP(10) ) KEEP(35)=KEEP(149) KEEP(16)=KEEP(150) KEEP(151)=KEEP(35) KEEP(51) = 70 KEEP(37) = max(800, int(sqrt(real(NSLAVES+1))*real(KEEP(51)))) IF ( NSLAVES > 256 ) THEN KEEP(39) = 10000 ELSEIF ( NSLAVES > 128 ) THEN KEEP(39) = 20000 ELSEIF ( NSLAVES > 64 ) THEN KEEP(39) = 40000 ELSEIF ( NSLAVES > 16 ) THEN KEEP(39) = 80000 ELSE KEEP(39) = 160000 END IF KEEP(40) = -1 - 456789 KEEP(45) = 0 KEEP(47) = 2 KEEP(64) = 20 KEEP(69) = 4 C To disable SMP management when using new mapping strategy C KEEP(69) = 1 C Forcing proportional is ok with strategy 5 KEEP(75) = 1 KEEP(76) = 2 KEEP(77) = 0 KEEP(78)= 0 KEEP(79) = 0 ! old splitting KEEP(210) = 2 KEEP8(79) = -10_8 KEEP(80) = 1 KEEP(81) = 0 IF (SYM.EQ.0) THEN KEEP(82)= 15 ELSE KEEP(82) = 10 ENDIF KEEP(83) = -1 KEEP(86)=1 KEEP(87)=0 KEEP(88)=0 KEEP(90)=1 KEEP(91)= -1 KEEP(102)= -1 #if defined(OLD_OOC_NOPANEL) KEEP(99)=0 ! no panel -> synchronous / no buffer #else KEEP(99)=4 ! new OOC -> asynchronous + buffer #endif KEEP(100)=0 KEEP(114) = 1 C Threshold value for null pîvot detection during C LU factorization on root in case of RR KEEP(118)=41 C strategy for MUMPS_BLOC2_GET_NSLAVESMIN KEEP(119)=0 C Scaling is enabled by default with the Schur complement option KEEP(125)=1 C Columns of LMAT handled by block of size KEEP(147) KEEP(147)=20000 C Control buffer size estimation and minimum granularities: C Try to avoid messages smaller than KEEP(170)/1000 of recv buf C ... minimum number of blocks KEEP(171)=10 C ... buffer size reduction factor with respect to worst case IF (SYM.EQ.0) THEN KEEP(172)= 5 ELSE KEEP(172)= 3 ENDIF KEEP(173)= 0 ! 0 = normal IF (SYM.EQ.0) THEN KEEP(178)= 2 ELSE KEEP(178)= 3 ENDIF KEEP(179)= 10 ! default outer block size increase by factor K179 IF (SYM.EQ.0) THEN KEEP(180) = 80 ! % of KEEP(44) to bound MIN_BUF_SIZE_FR KEEP(181) = 50 ! % of KEEP(44) to bound MIN_BUF_SIZE_BLR ELSE KEEP(180) = 200 ! % of KEEP(44) to bound MIN_BUF_SIZE_FR KEEP(181) = 200 ! % of KEEP(44) to bound MIN_BUF_SIZE_BLR ENDIF C amalgamation: to define sons KEEP(191) larger than fathers KEEP(191)= 50 C amalgamation: to define tiny son nodes C (KEEP(192 smaller than father) KEEP(192)= 900 C to limit the amalgamation of tiny nodes KEEP(193)= 50 C More amalgamation of tiny fronts KEEP(197)=1 C KEEP(199) for MUMPS_PROCNODE, MUMPS_TYPENODE, etc C KEEP(199)=NSLAVES + 7 KEEP(199)=-1 KEEP(200)=0 ! root pre-assembled in id%S C Pre-assemble type 3 root in id%S if no L0-OMP, C allocate id%S later otherwise. KEEP(200) = -1 KEEP(204)=0 KEEP(205)=0 KEEP(209)=-1 KEEP(104) = 16 KEEP(107)=0 KEEP(121)=-999999 KEEP(122)=15 C Size of CB for which we want to force BLR compressCB C even if NASS is small. KEEP(123)=10000 KEEP(141)=1 ! min needed KEEP(206)=1 KEEP(207) = 1 KEEP(211)=2 IF (SYM.EQ.0) THEN KEEP(213) = 301 ELSE KEEP(213) = 401 ENDIF KEEP(217)=0 KEEP(215)=0 KEEP(216)=1 KEEP(218)=250 IF (SYM.EQ.2) THEN KEEP(219)=1 ELSE KEEP(219)=0 ENDIF IF (KEEP(50).EQ.2) THEN KEEP(227)= max(2,32) ELSE KEEP(227)= max(1,32) ENDIF KEEP(231) = 1 KEEP(232) = 3 KEEP(233) = 0 KEEP(239) = 1 KEEP(240) = 10 DKEEP(4) = -1.0E0 DKEEP(5) = -1.0E0 DKEEP(10) = -9E0 ! default value is 10E-1 set in fac_driver.F DKEEP(13) = -9E0 ! to define SEUIL for postponing with RR ! (default value is 10 set in fac_driver.F) DKEEP(24) = 1000.0E0 ! gap should be larger than dkeep(14) DKEEP(25) = 10.0E0 ! gap precision DKEEP(22) = 0.5E0 ! to check for slow convergence KEEP(238)=24 KEEP(234)= 1 KEEP(235)=-1 DKEEP(3) =-5.0E0 DKEEP(18)= 1.0E12 KEEP(242) = -9 KEEP(243) = -1 KEEP(255)=100 C Multithreading of norm1 loop during scaling KEEP(281)=8 KEEP(337) = 1 C Parallel analysis compatible with analysis by blocks C and detection out-of-range KEEP(339)= 1 KEEP(249)=1 !$ KEEP(249) = OMP_GET_MAX_THREADS() KEEP(250) = 1 KEEP(261) = 1 KEEP(262) = 0 KEEP(263) = 1 KEEP(266) = 0 KEEP(267) = 0 KEEP(268)=77 KEEP(350) = 2 KEEP(351) = 1 KEEP(360) = 256 KEEP(361) = 2048 KEEP(362) = 4 KEEP(363) = 512 KEEP(364) = 32768 ! 32KiB KEEP(365) = 1024*1024 ! 1MiB KEEP(366) = 450 KEEP(370) = 1 KEEP(375) = 1 KEEP(378) = 1 C OMP parallelization of arrowheads KEEP(399) = -1 KEEP(397) = -1 KEEP(402) = 1 KEEP(405) = 0 ! 1 under L0OMP KEEP(406) = 2 #if defined(__PGLLVM__) C With aocc version of Classic flang, we want to C avoid an OpenMP bug during L0thread copies by C switching to simpler copy algorithm. C Since we cannot test __aocc__ in Fortran, we rely on the C slower algorithm as soon as __PGLLVM__ is detected, even C if this is "too careful". KEEP(406)=0 #endif C 0.9 equilibration KEEP(408) = 90 KEEP(420) = 4*KEEP(6) ! if KEEP(6)=32 then 128 #if defined(GEMMT_AVAILABLE) KEEP(421) = -1 #if defined(__ve__) KEEP(421) = 3000 #endif #endif #if defined(ANA_BLKAUTO) C automatic graph compression effective C only if reduction of the number of nodes C in graph smaller than 75% KEEP(440) = 75 #endif C Default size of KEEP(424) is defined below. C It does not depend on arithmetic, C it is related to L1 cache size: 250 * 64 bytes C is about half of the cache size (32768 bytes). C This leaves space in cache for the destination, C of size 250*sizeof(arith). (4k bytes for z) C At each new block of size KEEP(424), there is C probably a cache miss on the pivot. KEEP(424) = 250 KEEP(448) = 0 KEEP(458)=0 #if defined(__ve__) KEEP(458)=1 #endif KEEP(459) = 10 ! max number of panels KEEP(460) = 63 ! min panel size KEEP(461) = 10 KEEP(462) = 100 KEEP(466) = 1 KEEP(468) = 3 KEEP(469) = 3 KEEP(471) = -1 KEEP(479) = 1 KEEP(480) = 3 KEEP(472) = 1 KEEP(476) = 50 KEEP(477) = 100 KEEP(483) = 80 KEEP(484) = 80 KEEP(487) = 1 IF (KEEP(472).EQ.1) THEN KEEP(488) = 768 ELSE KEEP(488) = 8*KEEP(6) ! if KEEP(6)=32 then 256 ENDIF KEEP(490) = 128 KEEP(491) = 1000 #if defined(__ve__) KEEP(490)=512 KEEP(491)=8000 #endif KEEP(492) = 1 KEEP(493) = 0 KEEP(496) = 1 KEEP(495) = -1 KEEP(497) = -1 C RETURN END SUBROUTINE SMUMPSID SUBROUTINE SMUMPS_SET_KEEP72(id, LP) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE (SMUMPS_STRUC) :: id INTEGER LP IF (id%KEEP(72)==1) THEN id%KEEP(37) = 2*id%NSLAVES id%KEEP(3)=3 id%KEEP(4)=2 id%KEEP(5)=1 id%KEEP(6)=2 id%KEEP(9)=3 C KEEP(11) not too small either id%KEEP(11)=3 id%KEEP(39)=300 id%KEEP(7) = 3 id%KEEP(8) = 2 id%KEEP(57)= 3 id%KEEP(58)= 2 id%KEEP(63)=3 id%CNTL(1)=0.1E0 id%KEEP(213) = 101 id%KEEP(85)=2 id%KEEP(85)=-4 id%KEEP(62) = 2 id%KEEP(1) = 1 id%KEEP(123) = 6 id%KEEP(147) = 3 id%KEEP(197) = 0 id%KEEP(51) = 2 !$ id%KEEP(360) = 2 !$ id%KEEP(361) = 2 !$ id%KEEP(362) = 1 !$ id%KEEP(363) = 2 id%KEEP(364) = 10 id%KEEP(366) = 2 id%KEEP(420) = 4 id%KEEP(488) = 4 id%KEEP(490) = 5 id%KEEP(491) = 5 id%ICNTL(27)=-3 id%KEEP(227)=3 id%KEEP(30) = 1000 C ... Try to avoid messages smaller than KEEP(170)/1000 of recv buf C large value to test deadlock C (no effect with KEEP(173)=1) id%KEEP(170) = 500 ! default is 100 C reduce buffer size estimated during analysis C with respect to message size without SMB mechanism C ... minimum nb of blocks is reduced to stress more buffers id%KEEP(171) = 3 ! default is 10 blocs C ... buffer size factor of reduction is increased C to stress more buffers id%KEEP(172) = 10 ! default is 3 C both values of KEEP(173) should be tested id%KEEP(173) = 1 ! 0=normal 1=force blocking id%KEEP(178) = 1 ! reduce it to one panel for FR LDLT CB buf C ... factor of reduction of CB messages is increased id%KEEP(238) = 36 ! default is 24 ELSE IF (id%KEEP(72)==2) THEN C{ id%KEEP(85)=2 ! default is id%KEEP(85)=-10000 ! default is 160 id%KEEP(210) = 1 ! defaults is 0 (automatic) id%KEEP8(79) = 160000_8 id%KEEP(1) = 2 ! default is 8 id%KEEP(102) = 110 ! defaults is 150 up to 48 procs C reduce buffer size estimated during analysis C with respect to message size without SMB mechanism C ... minimum nb of blocks is reduced to stress more buffers id%KEEP(171) = 3 ! default is 10 blocs C ... buffer size factor of reduction is increased C to stress more buffers id%KEEP(172) = 10 ! default is 3 id%KEEP(213) = 121 ! default is 201 C} END IF RETURN END SUBROUTINE SMUMPS_SET_KEEP72 MUMPS_5.8.1/src/fac_asm_build_sort_index_m.F0000664000175000017500000005566315042446423020701 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_BUILD_SORT_INDEX_M CONTAINS SUBROUTINE MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE_STEPS, & SON_LEVEL2, NIV1, KEEP,KEEP8, IFLAG, & ISON_IN_PLACE, PROCNODE_STEPS, SLAVEF, & SONROWS_PER_ROW, LSONROWS_PER_ROW & , MUMPS_TPS_ARR, L0_OMP_MAPPING & ) USE MUMPS_TPS_M IMPLICIT NONE INTEGER INODE, N, IOLDPS, HF, NFRONT, NASS1, LIW, NASS, & NUMSTK, NUMORG, IFSON, MYID, LP LOGICAL, intent(in) :: LPOK INTEGER, intent(in) :: ISON_IN_PLACE INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER STEP(N), PIMASTER(KEEP(28)), PTRIST(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), FRERE_STEPS(KEEP(28)), & PERM(N) INTEGER, TARGET :: IW(LIW) INTEGER, INTENT(IN), TARGET :: IWPOSCB INTEGER, INTENT(IN) :: IWPOS INTEGER(8), INTENT(IN) :: LINTARR INTEGER :: INTARR(LINTARR) LOGICAL, intent(in) :: NIV1 INTEGER, intent(inout) :: IFLAG LOGICAL, intent(out) :: SON_LEVEL2 INTEGER, intent(out) :: NFRONT_EFF INTEGER, intent(in) :: DAD (KEEP(28)) INTEGER, intent(in) :: PROCNODE_STEPS(KEEP(28)), SLAVEF TYPE (MUMPS_TPS_T), TARGET, OPTIONAL :: MUMPS_TPS_ARR(:) INTEGER, intent(in), OPTIONAL :: L0_OMP_MAPPING(:) INTEGER, intent(in) :: LSONROWS_PER_ROW INTEGER, intent(out) :: SONROWS_PER_ROW(LSONROWS_PER_ROW) INTEGER NELIM_SON_IN_PLACE INTEGER NEWEL, IOLDP2, INEW, INEW1, & IN, NTOTFS, ICT11, NELIM, NPIVS, NSLSON, NCOLS, & ITRANS, J, JT1, ISON, IELL, LSTK, & NROWS, HS, IP1, IP2, IBROT, IORG, & I, K, ILOC, NEWEL_SAVE, NEWEL1_SAVE, & LAST_J_ASS, JMIN, MIN_PERM LOGICAL LEVEL1_SON INTEGER :: K1, K2, K3, KK INTEGER(8) :: J18, J28, JJ8, JDEBROW8 INTEGER INBPROCFILS_SON INTEGER TYPESPLIT INCLUDE 'mumps_headers.h' INTEGER :: ITHREAD INTEGER, POINTER :: SON_IWPOSCB INTEGER, POINTER, DIMENSION(:) :: SON_IW INTEGER, POINTER, DIMENSION(:) :: PTTRI, PTLAST INTEGER :: LREQ, allocok INTEGER, ALLOCATABLE, TARGET :: TMP_ALLOC_ARRAY(:) INTEGER :: ISTEP, IARR1, IARR1DAD, IORGDAD INTEGER MUMPS_TYPESPLIT, MUMPS_TYPENODE EXTERNAL MUMPS_TYPESPLIT, MUMPS_TYPENODE IW(IOLDPS+XXNBPR) = 0 ISTEP = STEP(INODE) IARR1 = PTRDEBARR( ISTEP ) TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(ISTEP), & KEEP(199)) SON_LEVEL2 = .FALSE. IOLDP2 = IOLDPS + HF - 1 ICT11 = IOLDP2 + NFRONT NTOTFS = 0 NELIM_SON_IN_PLACE = 0 IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) ) THEN K2 = PIMASTER(STEP(IFSON)) LSTK = IW(K2 +KEEP(IXSZ)) NELIM = IW(K2 + 1+KEEP(IXSZ)) IF ( ISON_IN_PLACE > 0 ) THEN IF (ISON_IN_PLACE.NE.IFSON) THEN write(6,*) MYID, ':', & ' Internal error 1 in MUMPS_BUILD_SORT_INDEX ', & ' in place node is not the first son a interior split node ' CALL MUMPS_ABORT() ENDIF NELIM_SON_IN_PLACE = NELIM ENDIF NPIVS = IW(K2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = IW(K2 + 5+KEEP(IXSZ)) IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. LEVEL1_SON = NSLSON.EQ.0 NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF (NIV1) THEN write(6,*) MYID, ':', & ' Internal error 2 in MUMPS_BUILD_SORT_INDEX ', & ' interior split node of type 1 ' CALL MUMPS_ABORT() ENDIF I= MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFSON)),KEEP(199)) J= MUMPS_TYPESPLIT(PROCNODE_STEPS(STEP(IFSON)), & KEEP(199)) IF (LEVEL1_SON.or.J.LT.4) THEN write(6,*) MYID, ':', & ' Internal error 3 in MUMPS_BUILD_SORT_INDEX ', & ' son', IFSON, & ' of interior split node', INODE, ' of type 1 ', & ' NSLSON =', NSLSON, ' TYPE_SON=', I, 'TYPESPLIT_SON=', J CALL MUMPS_ABORT() ENDIF SON_IW => IW SON_IWPOSCB => IWPOSCB IF (KEEP(400) .GT. 0 ) THEN IF (present( L0_OMP_MAPPING )) THEN ITHREAD=L0_OMP_MAPPING(STEP(IFSON)) IF (ITHREAD .GT. 0) THEN SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW SON_IWPOSCB => MUMPS_TPS_ARR(ITHREAD)%IWPOSCB ENDIF ENDIF ENDIF IF (K2 .GT. SON_IWPOSCB) THEN INBPROCFILS_SON = K2 + XXNBPR ELSE INBPROCFILS_SON = PTRIST(STEP(IFSON))+XXNBPR ENDIF IW(IOLDPS+XXNBPR)=NSLSON SON_IW(INBPROCFILS_SON) = NSLSON SONROWS_PER_ROW(1:NFRONT-NASS1) = 1 IF ( K2.GT. IWPOSCB ) THEN NROWS = IW(K2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) K1 = K2 + HS + NROWS + NPIVS K2 = K1 + LSTK - 1 K3 = K1 + NELIM - 1 IF (NELIM.GT.0) THEN DO KK=K1,K3 NTOTFS = NTOTFS + 1 JT1 = IW(KK) IW(ICT11 + NTOTFS) = JT1 IW(KK) = NTOTFS IW(IOLDP2 + NTOTFS) = IW(KK - ITRANS) ENDDO ENDIF DO KK =K3+1, K3+NUMORG NTOTFS = NTOTFS + 1 JT1 = IW(KK) ITLOC(JT1) = NTOTFS IW(KK) = NTOTFS IW(ICT11 + NTOTFS) = JT1 IW(IOLDP2 + NTOTFS) = JT1 ENDDO DO KK =K3+NUMORG+1, K2 NTOTFS = NTOTFS + 1 JT1 = IW(KK) ITLOC(JT1) = NTOTFS IW(KK) = NTOTFS IW(ICT11 + NTOTFS) = JT1 IW(IOLDP2 + NTOTFS) = JT1 ENDDO NFRONT_EFF = NTOTFS DO IORG = 1, NUMORG J18 = PTR8ARR(IARR1+IORG-1) JT1 = INTARR(J18) INTARR(J18) = ITLOC(JT1) J28 = J18 +NINCOLARR(IARR1+IORG-1)+NINROWARR(IARR1+IORG-1) J18 = J18 + 1 IF (J18 .LE. J28) THEN DO JJ8 = J18, J28 J = INTARR(JJ8) INTARR(JJ8) = ITLOC(J) ENDDO ENDIF ENDDO K1 = IOLDPS+HF DO KK=K1+NELIM,K1+NFRONT_EFF-1 ITLOC(IW(KK)) = 0 ENDDO RETURN ENDIF LREQ= 2*NUMSTK+2 IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN ALLOCATE(TMP_ALLOC_ARRAY(LREQ), stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 GOTO 800 ENDIF PTTRI => TMP_ALLOC_ARRAY(1:NUMSTK+1) PTLAST => TMP_ALLOC_ARRAY(NUMSTK+2:LREQ) ELSE PTTRI => IW(IWPOS:IWPOS+NUMSTK) PTLAST => IW(IWPOS+NUMSTK+1:IWPOS+LREQ-1) ENDIF NFRONT_EFF = NASS1 IF ( ISON_IN_PLACE > 0 ) THEN ISON = ISON_IN_PLACE K2 = PIMASTER(STEP(ISON)) LSTK = IW(K2 +KEEP(IXSZ)) NELIM = IW(K2 + 1+KEEP(IXSZ)) NPIVS = IW(K2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = IW(K2 + 5+KEEP(IXSZ)) NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF ( K2 .GT. IWPOSCB ) THEN NROWS = IW(K2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) K1 = K2 + HS + NROWS + NPIVS K2 = K1 + LSTK - 1 K3 = K1 + NELIM - 1 DO KK = K1, K3 NTOTFS = NTOTFS + 1 JT1 = IW(KK) IW(ICT11 + NTOTFS) = JT1 ITLOC(JT1) = NTOTFS IW(KK) = NTOTFS IW(IOLDP2 + NTOTFS) = IW(KK - ITRANS) ENDDO NELIM_SON_IN_PLACE = NTOTFS ENDIF IF (.NOT. NIV1) SONROWS_PER_ROW(1:NFRONT-NASS1) = 0 IN = INODE INEW = IOLDPS + HF + NTOTFS INEW1 = NTOTFS + 1 JDEBROW8 = PTR8ARR(IARR1) + 1 PTTRI(NUMSTK+1) = 0 PTLAST(NUMSTK+1) = NINCOLARR(IARR1)-1 IORG = 0 50 CONTINUE IORG = IORG + 1 J18 = PTR8ARR(IARR1+IORG-1) JT1 = INTARR(J18) INTARR(J18) = INEW1 ITLOC(JT1) = INEW1 IW(INEW) = JT1 IW(INEW+NFRONT) = JT1 INEW = INEW + 1 INEW1 = INEW1 + 1 IN = FILS(IN) IF (IN .GT. 0) GOTO 50 NTOTFS = NTOTFS + NUMORG IF (NUMSTK .NE. 0) THEN ISON = IFSON DO IELL = 1, NUMSTK K2 = PIMASTER(STEP(ISON)) SON_IW => IW SON_IWPOSCB => IWPOSCB IF ( KEEP(400) .GT. 0 ) THEN IF (present( L0_OMP_MAPPING )) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .GT. 0) THEN SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW SON_IWPOSCB => MUMPS_TPS_ARR(ITHREAD)%IWPOSCB ENDIF ENDIF ENDIF LSTK = SON_IW(K2 +KEEP(IXSZ)) NELIM = SON_IW(K2 + 1+KEEP(IXSZ)) NPIVS = SON_IW(K2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = SON_IW(K2 + 5+KEEP(IXSZ)) IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. LEVEL1_SON = NSLSON.EQ.0 NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF ( K2 .GT. SON_IWPOSCB ) THEN INBPROCFILS_SON = K2+XXNBPR ELSE INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR ENDIF IF (NIV1) THEN SON_IW(INBPROCFILS_SON) = NSLSON IW(IOLDPS+XXNBPR) = IW(IOLDPS+XXNBPR) + NSLSON ELSE IF (LEVEL1_SON) THEN SON_IW(INBPROCFILS_SON) = 1 ELSE SON_IW(INBPROCFILS_SON) = NSLSON ENDIF IW(IOLDPS+XXNBPR) = IW(IOLDPS+XXNBPR) + & SON_IW(INBPROCFILS_SON) ENDIF IF (K2.GT.SON_IWPOSCB) THEN NROWS = SON_IW(K2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) K1 = K2 + HS + NROWS + NPIVS K2 = K1 + LSTK - 1 - KEEP(253) K3 = K1 + NELIM - 1 IF (NELIM .NE. 0 .AND. ISON.NE.ISON_IN_PLACE) THEN DO KK = K1, K3 NTOTFS = NTOTFS + 1 JT1 = SON_IW(KK) IW(ICT11 + NTOTFS) = JT1 ITLOC(JT1) = NTOTFS SON_IW(KK) = NTOTFS IW(IOLDP2 + NTOTFS) = SON_IW(KK - ITRANS) ENDDO ENDIF PTTRI(IELL) = K2+1 PTLAST(IELL) = K2 K1 = K3 + 1 IF (NASS1 .NE. NFRONT - KEEP(253)) THEN DO KK = K1, K2 J = SON_IW(KK) IF (ITLOC(J) .EQ. 0) THEN PTTRI(IELL) = KK EXIT ENDIF ENDDO ELSE DO KK = K1, K2 SON_IW(KK) = ITLOC(SON_IW(KK)) ENDDO DO KK=K2+1, K2+KEEP(253) SON_IW(KK)=NFRONT-KEEP(253)+KK-K2 ENDDO ENDIF ISON = FRERE_STEPS(STEP(ISON)) ENDDO ENDIF IF (NFRONT-KEEP(253).EQ.NASS1) GOTO 500 199 CONTINUE IF ( PTTRI( NUMSTK + 1 ) .LE. PTLAST( NUMSTK + 1 ) ) THEN IF ( ITLOC( INTARR( JDEBROW8+PTTRI( NUMSTK + 1 ) ) ) .NE. 0 ) THEN PTTRI( NUMSTK + 1 ) = PTTRI( NUMSTK + 1 ) + 1 GOTO 199 END IF END IF MIN_PERM = N + 1 IF (KEEP(400) .GT. 0) THEN ISON = IFSON ENDIF DO IELL = 1, NUMSTK SON_IW => IW IF ( KEEP(400) .GT. 0 ) THEN IF (present( MUMPS_TPS_ARR )) THEN ITHREAD = L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .GT. 0) THEN SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW ENDIF ENDIF ENDIF ILOC = PTTRI( IELL ) IF ( ILOC .LE. PTLAST( IELL ) ) THEN IF ( PERM( SON_IW( ILOC ) ) .LT. MIN_PERM ) THEN JMIN = SON_IW( ILOC ) MIN_PERM = PERM( JMIN ) END IF END IF IF (KEEP(400) .GT. 0) THEN ISON = FRERE_STEPS(STEP(ISON)) ENDIF END DO IELL = NUMSTK + 1 ILOC = PTTRI( IELL ) IF ( ILOC .LE. PTLAST( IELL ) ) THEN IF ( PERM( INTARR( JDEBROW8+ILOC ) ) .LT. MIN_PERM ) THEN JMIN = INTARR( JDEBROW8+ILOC ) MIN_PERM = PERM( JMIN ) END IF END IF NEWEL = IOLDP2 + NASS1 + NFRONT DO WHILE ( MIN_PERM .NE. N + 1 ) NEWEL = NEWEL + 1 NFRONT_EFF = NFRONT_EFF + 1 IW( NEWEL ) = JMIN ITLOC( JMIN ) = NFRONT_EFF LAST_J_ASS = JMIN MIN_PERM = N + 1 IF (KEEP(400) .GT. 0) THEN ISON = IFSON ENDIF DO IELL = 1, NUMSTK SON_IW => IW IF (KEEP(400) .GT. 0) THEN IF (present( MUMPS_TPS_ARR )) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .GT. 0) THEN SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW ENDIF ENDIF ENDIF IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN IF ( SON_IW( PTTRI( IELL ) ) .eq. LAST_J_ASS ) & PTTRI( IELL ) = PTTRI( IELL ) + 1 ENDIF IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN IF ( PERM(SON_IW( PTTRI( IELL )) ) .LT. MIN_PERM ) THEN JMIN = SON_IW( PTTRI( IELL ) ) MIN_PERM = PERM( JMIN ) END IF END IF IF (KEEP(400).GT.0) THEN ISON = FRERE_STEPS(STEP(ISON)) ENDIF END DO IELL = NUMSTK + 1 145 CONTINUE IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN IF ( INTARR( JDEBROW8+PTTRI( IELL ) ) .eq. LAST_J_ASS ) THEN PTTRI( IELL ) = PTTRI( IELL ) + 1 GOTO 145 END IF END IF IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN IF (PERM(INTARR( JDEBROW8+PTTRI(IELL) )) .LT. MIN_PERM) THEN JMIN = INTARR( JDEBROW8+PTTRI(IELL) ) MIN_PERM = PERM( JMIN ) END IF END IF END DO NEWEL_SAVE = NEWEL NEWEL1_SAVE = NFRONT_EFF IF (NEWEL1_SAVE.LT.NFRONT - KEEP(253)) THEN DO IORG = 1, NUMORG J18 = PTR8ARR(IARR1+IORG-1) J28 = J18 + NINCOLARR(IARR1+IORG-1) + NINROWARR(IARR1+IORG-1) IF ( IORG.EQ. 1) THEN IF ( KEEP(50).NE.0 ) GOTO 100 J18 = J18 + 1 + NINCOLARR(IARR1+IORG-1) ELSE J18 = J18 + 1 ENDIF DO JJ8 = J18, J28 J = INTARR( JJ8 ) IF ( ITLOC( J ) .eq. 0 ) THEN NEWEL = NEWEL + 1 NFRONT_EFF = NFRONT_EFF + 1 IW( NEWEL ) = J ITLOC( J ) = NFRONT_EFF END IF ENDDO 100 CONTINUE ENDDO IF ( (TYPESPLIT.EQ.4).AND. & (NFRONT_EFF.LT.NFRONT-KEEP(253)) ) THEN IBROT = INODE DO WHILE & ( & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),KEEP(199)) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),KEEP(199)) & .EQ.6 & ) & ) IBROT = DAD(STEP(IBROT)) IARR1DAD= PTRDEBARR(STEP(IBROT)) IORGDAD = 0 IN = IBROT DO WHILE (IN.GT.0.AND.NFRONT_EFF.LT.NFRONT-KEEP(253)) IORGDAD = IORGDAD + 1 J18 = PTR8ARR(IARR1DAD+IORGDAD-1) J28 = J18 + NINCOLARR(IARR1DAD+IORGDAD-1) + & NINROWARR(IARR1DAD+IORGDAD-1) IN = FILS( IN ) DO JJ8 = J18, J28 J = INTARR( JJ8 ) IF ( ITLOC( J ) .eq. 0 ) THEN NEWEL = NEWEL + 1 NFRONT_EFF = NFRONT_EFF + 1 IW( NEWEL ) = J ITLOC( J ) = NFRONT_EFF END IF ENDDO ENDDO IF (NFRONT_EFF.EQ.NFRONT-KEEP(253)) EXIT ENDDO IF (NFRONT_EFF.NE.NFRONT-KEEP(253) .AND. & .NOT. (KEEP(376).EQ.1 .AND. KEEP(79) .GE.1)) THEN write(6,*) MYID, ': INODE', INODE, ' of type 4 ', & ' not yet fully assembled ', & ' NFRONT_EFF, NFRONT =', NFRONT_EFF, NFRONT CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF ( NEWEL1_SAVE .eq. NFRONT_EFF ) THEN DO KK=NASS1+1, NFRONT_EFF IW( IOLDP2+KK ) = IW( ICT11+KK ) ENDDO ELSE CALL MUMPS_SORT( N, PERM, & IW( NEWEL_SAVE + 1 ), NFRONT_EFF - NEWEL1_SAVE ) CALL MUMPS_SORTED_MERGE( N, NASS1, PERM, ITLOC, & IW( NEWEL_SAVE + 1), NFRONT_EFF - NEWEL1_SAVE, & IW( ICT11 + NASS1 + 1 ), NEWEL1_SAVE - NASS1, & IW( IOLDP2 + NASS1 + 1 ), NFRONT_EFF - NASS1 ) DO KK = NASS1+1, NFRONT_EFF IW(ICT11 + KK) = IW(IOLDP2+KK) ENDDO END IF 500 CONTINUE IF ( KEEP(253).GT.0) THEN IP1 = IOLDPS + HF + NFRONT_EFF IP2 = IOLDPS + HF + NFRONT + NFRONT_EFF DO I= 1, KEEP(253) IW(IP1+I-1) = N+I IW(IP2+I-1) = N+I ITLOC(N+I) = NFRONT_EFF + I ENDDO NFRONT_EFF = NFRONT_EFF + KEEP(253) ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN IP1 = IOLDPS + NFRONT + HF IP2 = IOLDPS + NFRONT_EFF + HF DO I=1, NFRONT_EFF IW(IP2+I-1)=IW(IP1+I-1) ENDDO ELSE IF (NFRONT .LT. NFRONT_EFF) THEN IF (LPOK) THEN WRITE(LP,*) " Error in MUMPS_BUILD_SORT_INDEX:", & " matrix structure might have changed,", & " analysis (JOB=1) should be performed again ", & " NFRONTexpected, NFRONTeffective=", NFRONT, NFRONT_EFF ENDIF IFLAG = -53 GOTO 800 ENDIF IF ( NUMSTK .NE. 0 & .AND. (NFRONT-KEEP(253).GT.NASS1) & ) THEN ISON = IFSON DO IELL = 1, NUMSTK K2 = PIMASTER(STEP(ISON)) SON_IW => IW SON_IWPOSCB => IWPOSCB IF (KEEP(400).GT.0) THEN IF (present( MUMPS_TPS_ARR )) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .GT. 0) THEN SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW SON_IWPOSCB => MUMPS_TPS_ARR(ITHREAD)%IWPOSCB ENDIF ENDIF ENDIF LSTK = SON_IW(K2+KEEP(IXSZ)) NELIM = SON_IW(K2 + 1 +KEEP(IXSZ)) NPIVS = SON_IW(K2 + 3 +KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = SON_IW(K2 + 5 +KEEP(IXSZ)) LEVEL1_SON = (NSLSON .EQ. 0) NCOLS = NPIVS + LSTK NROWS = NCOLS IF (K2.GT.SON_IWPOSCB) THEN NROWS = SON_IW(K2 + 2+KEEP(IXSZ)) ENDIF HS = NSLSON + 6 +KEEP(IXSZ) K1 = K2 + HS + NROWS + NPIVS K2 = K1 + LSTK - 1 K3 = K1 + NELIM - 1 K1 = K3 + 1 IF (NFRONT-KEEP(253).GT.NASS1) THEN DO KK = K1, K2 J = SON_IW(KK) SON_IW(KK) = ITLOC(J) IF (NIV1 .AND. NSLSON.EQ.0) THEN ELSE IF (SON_IW(KK) .LE. NASS1 .OR. NIV1) THEN ELSE SONROWS_PER_ROW(SON_IW(KK)-NASS1) = & SONROWS_PER_ROW(SON_IW(KK)-NASS1) + 1 ENDIF ENDIF ENDDO ELSE IF (.not. NIV1) THEN WRITE(*,*) "Internal error 1 in MUMPS_BUILD_SORT_INDEX" CALL MUMPS_ABORT() ENDIF IF (.not.LEVEL1_SON) THEN ENDIF ENDIF ISON = FRERE_STEPS(STEP(ISON)) ENDDO ENDIF DO IORG = 1, NUMORG J18 = PTR8ARR(IARR1+IORG-1) J28 = J18 + NINCOLARR(IARR1+IORG-1) + NINROWARR(IARR1+IORG-1) J18 = J18 + 1 DO JJ8 = J18, J28 J = INTARR(JJ8) INTARR(JJ8) = ITLOC(J) ENDDO ENDDO K1 = IOLDPS + HF K2 = K1 + NFRONT_EFF -1 IF (KEEP(50).EQ.0) K2 = K2 + NELIM_SON_IN_PLACE DO K = K1, K2 I = IW(K) ITLOC(I) = 0 ENDDO IF (KEEP(50).EQ.0) THEN K1 = IOLDPS+HF+NFRONT_EFF+NELIM_SON_IN_PLACE+NUMORG K2 = K1 + NASS -NELIM_SON_IN_PLACE - 1 DO K = K1, K2 I = IW(K) ITLOC(I) = 0 ENDDO ENDIF 800 CONTINUE IF (allocated(TMP_ALLOC_ARRAY)) DEALLOCATE(TMP_ALLOC_ARRAY) RETURN END SUBROUTINE MUMPS_BUILD_SORT_INDEX END MODULE MUMPS_BUILD_SORT_INDEX_M SUBROUTINE MUMPS_SORT( N, PERM, IW, LIW ) IMPLICIT NONE INTEGER N, LIW INTEGER PERM( N ), IW( LIW ) INTEGER I, SWAP LOGICAL DONE DONE = .FALSE. DO WHILE ( .NOT. DONE ) DONE = .TRUE. DO I = 1, LIW - 1 IF ( PERM( IW( I ) ) .GT. PERM( IW( I + 1 ) ) ) THEN DONE = .FALSE. SWAP = IW( I + 1 ) IW( I + 1 ) = IW( I ) IW( I ) = SWAP END IF END DO END DO RETURN END SUBROUTINE MUMPS_SORT SUBROUTINE MUMPS_SORTED_MERGE( N, NASS1, PERM, ITLOC, & SMALL, LSMALL, & LARGE, LLARGE, & MERGE, LMERGE ) IMPLICIT NONE INTEGER N, NASS1, LSMALL, LLARGE, LMERGE INTEGER PERM( N ), ITLOC( N ) INTEGER SMALL(LSMALL), LARGE(LLARGE), MERGE(LMERGE) INTEGER PSMALL, PLARGE, PMERGE, VSMALL, VLARGE, VMERGE PSMALL = 1 PLARGE = 1 PMERGE = 1 DO WHILE ( PSMALL .LE. LSMALL .or. PLARGE.LE. LLARGE ) IF ( PSMALL .GT. LSMALL ) THEN VMERGE = LARGE( PLARGE ) PLARGE = PLARGE + 1 ELSE IF ( PLARGE .GT. LLARGE ) THEN VMERGE = SMALL( PSMALL ) PSMALL = PSMALL + 1 ELSE VSMALL = SMALL( PSMALL ) VLARGE = LARGE( PLARGE ) IF ( PERM( VSMALL ) .LT. PERM( VLARGE ) ) THEN VMERGE = VSMALL PSMALL = PSMALL + 1 ELSE VMERGE = VLARGE PLARGE = PLARGE + 1 END IF END IF MERGE( PMERGE ) = VMERGE ITLOC( VMERGE ) = PMERGE + NASS1 PMERGE = PMERGE + 1 END DO PMERGE = PMERGE - 1 RETURN END SUBROUTINE MUMPS_SORTED_MERGE MUMPS_5.8.1/src/cana_aux.F0000664000175000017500000043042115042446440015122 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if defined(__ve__) #if defined(VHOFFLOAD) #include 've.h' #endif #endif MODULE CMUMPS_ANA_AUX_M IMPLICIT NONE CONTAINS SUBROUTINE CMUMPS_ANA_F(N, NZ8, IRN, ICN, LIWALLOC, & IKEEP1, IKEEP2, IKEEP3, & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, & CNTL4, COLSCA, ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , METIS_OPTIONS #endif & , NORIG_ARG, SIZEOFBLOCKS, GCOMP_PROVIDED_IN, GCOMP & ) USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY : COMPACT_GRAPH_T IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR, NSLAVES INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: LIWALLOC INTEGER, INTENT(in) :: LISTVAR_SCHUR(:) INTEGER, POINTER :: IRN(:), ICN(:) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: INFO(80), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(OUT) :: NFSIZ(:), FILS(:), FRERE(:) INTEGER, INTENT(INOUT) :: PIV(:) INTEGER, INTENT(INOUT) :: IKEEP1(:), IKEEP2(:), IKEEP3(:) REAL :: CNTL4 REAL, POINTER :: COLSCA(:), ROWSCA(:) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER, INTENT(IN) :: METIS_OPTIONS(40) #endif INTEGER, INTENT(IN), OPTIONAL :: NORIG_ARG INTEGER, INTENT(IN), TARGET, OPTIONAL :: SIZEOFBLOCKS(N) LOGICAL, INTENT(IN), OPTIONAL :: GCOMP_PROVIDED_IN TYPE(COMPACT_GRAPH_T), OPTIONAL :: GCOMP INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: IWALLOC INTEGER, DIMENSION(:), POINTER :: IW INTEGER(8), DIMENSION(:), ALLOCATABLE, TARGET :: IPEALLOC INTEGER(8), DIMENSION(:), POINTER :: IPE INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8 INTEGER, DIMENSION(:,:), ALLOCATABLE :: PTRAR INTEGER, DIMENSION(:), ALLOCATABLE :: PARENT INTEGER, DIMENSION(:), ALLOCATABLE :: IWL1 INTEGER NBBUCK INTEGER, DIMENSION(:), ALLOCATABLE :: WTEMP INTEGER IERR INTEGER I, K, NCMPA, IN, IFSON INTEGER(8) :: J8, I8 INTEGER :: NORIG INTEGER(8) :: IFIRST, ILAST INTEGER(8) IWFR8 INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry INTEGER NBQD, AvgDens LOGICAL PROK, COMPRESS_SCHUR, LPOK, COMPUTE_PERM #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) INTEGER NUMFLAG #endif INTEGER METIS_IDX_SIZE INTEGER OPT_METIS_SIZE #endif #if defined(scotch) || defined(ptscotch) INTEGER :: SCOTCH_INT_SIZE #endif #if defined(pord) INTEGER :: PORD_INT_SIZE #endif REAL, DIMENSION(:), ALLOCATABLE :: COLSCA_TEMP INTEGER THRESH, IVersion LOGICAL AGG6 INTEGER MINSYM PARAMETER (MINSYM=50) INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) INTEGER MTRANS, COMPRESS,NCMP,IERROR,J,JPERM,NCST INTEGER TOTEL INTEGER NFR #if defined(pord) INTEGER TOTW #endif INTEGER WEIGHTUSED #if defined(scotch) || defined(ptscotch) INTEGER WEIGHTREQUESTED #endif INTEGER HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & NBSONS_Scalapack_CAND LOGICAL SCOTCH_SYMBOLIC LOGICAL IDENT,SPLITROOT LOGICAL FREE_CENTRALIZED_MATRIX LOGICAL GCOMP_PROVIDED LOGICAL INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH INTEGER(8) :: LIW8, NZG8 DOUBLE PRECISION TIMEB INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR INTEGER, TARGET :: IDUMMY_ARRAY(1) INTEGER :: LSIZEOFBLOCKS_PTR LOGICAL :: SIZEOFBLOCKS_AVAIL #if defined (MUMPS_SCOTCHIMPORTOMPTHREADS) INTEGER :: ESMUMPSCONTEXT #endif EXTERNAL MUMPS_ANA_H, CMUMPS_ANA_J, & CMUMPS_ANA_K, CMUMPS_ANA_GNEW, & CMUMPS_ANA_LNEW, CMUMPS_ANA_M EXTERNAL CMUMPS_GNEW_SCHUR EXTERNAL CMUMPS_LDLT_COMPRESS, CMUMPS_EXPAND_PERMUTATION, & CMUMPS_SET_CONSTRAINTS ALLOCATE( IWL1 (N), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF ALLOCATE( PTRAR (N,3), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 3*N GOTO 90 ENDIF SCOTCH_SYMBOLIC=(KEEP(270).EQ.0) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL MUMPS_SCOTCH_ESMUMPSCONTEXT( ESMUMPSCONTEXT ) SCOTCH_SYMBOLIC=SCOTCH_SYMBOLIC .AND. (ESMUMPSCONTEXT.EQ.1) #endif symmetry = INFO(8) NBQD = 0 GCOMP_PROVIDED=.FALSE. WEIGHTUSED = 0 NORIG = N IF (present(NORIG_ARG)) THEN NORIG=NORIG_ARG ENDIF IF (present(GCOMP_PROVIDED_IN)) & GCOMP_PROVIDED = GCOMP_PROVIDED_IN IF (GCOMP_PROVIDED.AND.(.NOT. present(GCOMP))) THEN INFO(1) = -900 WRITE(6,*) " INTERNAL ERROR in MUMPS(ANA_F) ", & GCOMP_PROVIDED_IN, present(GCOMP) INFO(2) = 1 RETURN ENDIF IF (GCOMP_PROVIDED) THEN NZG8 = GCOMP%NZG LIW8 = NZG8 + int(GCOMP%NG,8)+1_8 IW => GCOMP%ADJ(1:LIW8) IPE => GCOMP%IPE(1:GCOMP%NG+1) DO I=1,GCOMP%NG PTRAR(I,2) = int(IPE(I+1)-IPE(I)) ENDDO ELSE IF (LIWALLOC.GT.0_8) THEN ALLOCATE( IWALLOC (LIWALLOC), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(LIWALLOC,INFO(2)) GOTO 90 ENDIF ENDIF IF ( LIWALLOC.EQ.0_8 ) THEN INFO(1) = -900 WRITE(6,*) " INTERNAL ERROR in MUMPS(ANA_F) ", & "LIWALLOC, GCOMP_PROVIDED=", LIWALLOC, GCOMP_PROVIDED INFO(2) = 2 RETURN ENDIF LIW8 = LIWALLOC NZG8 = NZ8 IW => IWALLOC(1:LIW8) ALLOCATE( IPEALLOC(N+1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (N+1)*KEEP(10) GOTO 90 ENDIF IPE => IPEALLOC(1:N+1) ENDIF LP = ICNTL(1) MP = ICNTL(3) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) LDIAG = ICNTL(4) COMPRESS_SCHUR = .FALSE. IF (present(SIZEOFBLOCKS)) THEN SIZEOFBLOCKS_PTR => SIZEOFBLOCKS(1:N) LSIZEOFBLOCKS_PTR = N SIZEOFBLOCKS_AVAIL = .TRUE. ELSE SIZEOFBLOCKS_PTR => IDUMMY_ARRAY SIZEOFBLOCKS_AVAIL = .FALSE. LSIZEOFBLOCKS_PTR = 1 IDUMMY_ARRAY(1) = -1 ENDIF IF (PROK) THEN IF (present(GCOMP)) THEN WRITE(MP,'(A,I10,A,I13,A)') " Processing a graph of size:", N & ," with ", GCOMP%NZG, " edges" ELSE WRITE(MP,'(A,I10)') " Processing a graph of size:", N ENDIF ENDIF IF (GCOMP_PROVIDED) THEN FREE_CENTRALIZED_MATRIX = .FALSE. ELSE FREE_CENTRALIZED_MATRIX = ( & (KEEP(54).EQ.3).AND. & (KEEP(494).EQ.0).AND. & (KEEP(106).NE.3) & ) ENDIF INPLACE64_GRAPH_COPY = .FALSE. INPLACE64_RESTORE_GRAPH = .TRUE. IF (KEEP(1).LT.0) KEEP(1) = 0 NEMIN = KEEP(1) IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (present(SIZEOFBLOCKS)) THEN K = min(10,GCOMP%NG) IF (LDIAG.EQ.4) K = GCOMP%NG WRITE (MP,99909) N, NZG8, INFO(1) I8= 0_8 WRITE(MP,'(A)') " Graph adjacency " DO J=1, K IFIRST = GCOMP%IPE(J) ILAST= min(GCOMP%IPE(J+1)-1,GCOMP%IPE(J)+K-1) write(MP,'(A,I10)') " .... node/column:", J write(MP,'(8X,10I9)') & (GCOMP%ADJ(I8),I8=IFIRST,ILAST) ENDDO ELSE J8 = min(NZG8, 10_8) IF (LDIAG .EQ.4) J8 = NZG8 WRITE (MP,99999) N, NZG8, LIW8, INFO(1) IF (J8.GT.0_8) WRITE (MP,99998) (IRN(I8),ICN(I8),I8=1_8,J8) ENDIF K = min(10,N) IF (LDIAG.EQ.4) K = N IF (IORD.EQ.1 .AND. K.GT.0) THEN WRITE (MP,99997) (IKEEP1(I),I=1,K) ENDIF ENDIF NCMP = N IF (KEEP(60).NE.0) THEN IF ((SIZE_SCHUR.LE.0 ).OR. & (SIZE_SCHUR.GE.N) ) GOTO 90 ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF ( ( KEEP(60).NE.0).AND.(SIZE_SCHUR.GT.0) & .AND. & ((IORD.EQ.7).OR.(IORD.EQ.5)) & )THEN COMPRESS_SCHUR=.TRUE. NCMP = N-SIZE_SCHUR ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL CMUMPS_GNEW_SCHUR(N,NCMP,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, & KEEP(264), KEEP(265), & LISTVAR_SCHUR(1), SIZE_SCHUR, FRERE(1), FILS(1), & INPLACE64_GRAPH_COPY) INFO(8) = symmetry INPLACE64_GRAPH_COPY = INPLACE64_GRAPH_COPY.AND. & (.NOT.FREE_CENTRALIZED_MATRIX) DEALLOCATE(IPQ8) IORD = 5 KEEP(95) = 1 NBQD = 0 ELSE #endif IF (GCOMP_PROVIDED) THEN IWFR8 = GCOMP%NZG+1_8 ELSE ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF CALL CMUMPS_ANA_GNEW(N,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, KEEP(264), KEEP(265), & .TRUE., INPLACE64_GRAPH_COPY) INFO(8) = symmetry INPLACE64_GRAPH_COPY = INPLACE64_GRAPH_COPY.AND. & (.NOT.FREE_CENTRALIZED_MATRIX) DEALLOCATE(IPQ8) ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif IF(NBQD .GT. 0) THEN IF( KEEP(50) .EQ. 2 .AND. ICNTL(12) .EQ. 0 ) THEN IF(KEEP(95) .NE. 1) THEN IF ( PROK ) & WRITE( MP,*) & 'Compressed/constrained ordering set OFF' KEEP(95) = 1 ENDIF ENDIF ENDIF IF ( (KEEP(60).NE.0) .AND. (IORD.GT.1) .AND. & .NOT. COMPRESS_SCHUR ) THEN IORD = 0 ENDIF IF ( (KEEP(50).EQ.2) & .AND. (KEEP(95) .EQ. 3) & .AND. (IORD .EQ. 7) ) THEN IORD = 2 ENDIF CALL MUMPS_SET_ORDERING( NORIG, KEEP, & KEEP(50), NSLAVES, IORD, & NBQD, AvgDens, & PROK, MP ) IF(KEEP(50) .EQ. 2) THEN IF(KEEP(95) .EQ. 3 .AND. IORD .NE. 2) THEN IF (PROK) WRITE(MP,*) & 'WARNING: CMUMPS_ANA_F constrained ordering not '// & ' available with selected ordering. Move to' // & ' compressed ordering.' KEEP(95) = 2 ENDIF ELSE KEEP(95) = 1 ENDIF MTRANS = KEEP(23) COMPRESS = KEEP(95) - 1 IF(COMPRESS .GT. 0 .AND. KEEP(52) .EQ. -2) THEN IF(CNTL4 .GE. 0.0E0) THEN IF (KEEP(1).LE.8) THEN NEMIN = 16 ELSE NEMIN = 2*KEEP(1) ENDIF ENDIF ENDIF IF(MTRANS .GT. 0 .AND. KEEP(50) .EQ. 2) THEN KEEP(23) = 0 ENDIF IF (COMPRESS .EQ. 2) THEN IF (IORD.NE.2) THEN WRITE(*,*) "IORD not compatible with COMPRESS:", & IORD, COMPRESS CALL MUMPS_ABORT() ENDIF CALL CMUMPS_SET_CONSTRAINTS( & N,PIV(1),FRERE(1),FILS(1),NFSIZ(1),IKEEP1(1), & NCST,KEEP,KEEP8, ROWSCA(1) & ) ENDIF IF ( IORD .NE. 1 ) THEN IF (COMPRESS .GE. 1) THEN ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL CMUMPS_LDLT_COMPRESS( & N, NZ8, IRN(1), ICN(1), PIV(1), & NCMP, IW(1), LIW8, IPE(1), PTRAR(1,2), IPQ8, & IWL1, FILS(1), IWFR8, & IERROR, KEEP, KEEP8, ICNTL, INPLACE64_GRAPH_COPY) DEALLOCATE(IPQ8) symmetry = 100 ENDIF IF ( (symmetry.LT.MINSYM).AND.(KEEP(50).EQ.0) ) THEN IF(KEEP(23) .EQ. 7 ) THEN KEEP(23) = -5 GOTO 90 ELSE IF(KEEP(23) .EQ. -9876543) THEN IDENT = .TRUE. KEEP(23) = 5 IF (PROK) WRITE(MP,'(A)') & ' ... Apply column permutation (already computed)' DO J=1,N JPERM = PIV(J) FILS(JPERM) = J IF (JPERM.NE.J) IDENT = .FALSE. ENDDO IF (.NOT.IDENT) THEN DO J8=1_8,NZ8 J = ICN(J8) IF ((J.LE.0).OR.(J.GT.N)) CYCLE ICN(J8) = FILS(J) ENDDO ALLOCATE(COLSCA_TEMP(N), stat=IERR) IF ( IERR > 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF DO J = 1, N COLSCA_TEMP(J)=COLSCA(J) ENDDO DO J=1, N COLSCA(FILS(J))=COLSCA_TEMP(J) ENDDO DEALLOCATE(COLSCA_TEMP) IF (PROK) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL CMUMPS_ANA_GNEW & (N,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264), KEEP(265), & .TRUE.,INPLACE64_GRAPH_COPY) INFO(8) = symmetry DEALLOCATE(IPQ8) NCMP = N ELSE KEEP(23) = 0 ENDIF ENDIF ELSE IF (KEEP(23) .EQ. 7 .OR. KEEP(23) .EQ. -9876543 ) THEN IF (PROK) WRITE(MP,'(A)') & ' ... No column permutation' KEEP(23) = 0 ENDIF ENDIF IF (FREE_CENTRALIZED_MATRIX & .AND.COMPRESS.EQ.0.AND.(.NOT.COMPRESS_SCHUR)) THEN deallocate(IRN) NULLIFY(IRN) deallocate(ICN) NULLIFY(ICN) ENDIF INPLACE64_RESTORE_GRAPH = & INPLACE64_RESTORE_GRAPH.AND.(COMPRESS.NE.1) ALLOCATE( PARENT ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF IF (IORD.NE.1 .AND. IORD.NE.5) THEN IF ( KEEP(60) .NE. 0 ) THEN IORD = 0 ENDIF IF (PROK) THEN IF (IORD.EQ.2) THEN WRITE(MP,'(A)') ' Ordering based on AMF ' #if defined(scotch) || defined(ptscotch) ELSE IF (IORD.EQ.3) THEN WRITE(MP,'(A)') ' Ordering based on SCOTCH ' #endif #if defined(pord) ELSE IF (IORD.EQ.4) THEN WRITE(MP,'(A)') ' Ordering based on PORD ' #endif ELSE IF (IORD.EQ.6) THEN WRITE(MP,'(A)') ' Ordering based on QAMD ' ELSE WRITE(MP,'(A)') ' Ordering based on AMD ' ENDIF ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF IF ( KEEP(60) .NE. 0 ) THEN CALL MUMPS_HAMD(N, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP1(1), & IKEEP2(1), NCMPA, FILS(1), IKEEP3(1), & PTRAR, PTRAR(1,3), & PARENT, & LISTVAR_SCHUR(1), SIZE_SCHUR) IF (KEEP(60)==1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ELSE IF ( .FALSE. ) THEN #if defined(pord) ELSEIF (IORD .EQ. 4) THEN CALL MUMPS_PORD_INTSIZE(PORD_INT_SIZE) TOTW = N IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) & ) THEN IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IF & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) THEN TOTW = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF IF (PORD_INT_SIZE .EQ. 64) THEN CALL MUMPS_PORDF_WND_MIXEDto64(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, TOTW, PARENT, & INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY & ) ELSE IF (PORD_INT_SIZE .EQ. 32) THEN CALL MUMPS_PORDF_WND_MIXEDto32(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, TOTW, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE WRITE(*,*) & "Internal error in PORD wrappers, PORD_INT_SIZE=", & PORD_INT_SIZE CALL MUMPS_ABORT() ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 GOTO 90 ENDIF IF (INFO(1) .LT.0) GOTO 90 IF (COMPRESS.EQ.1) THEN CALL CMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS(1)) CALL CMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP1(1), & FRERE(1),PTRAR(1,1)) DO I=1,NCMP IKEEP2(IKEEP1(I))=I ENDDO ENDIF ELSE IF (PORD_INT_SIZE.EQ.64) THEN CALL MUMPS_PORDF_MIXEDto64(NCMP, IWFR8-1_8, IPE, & IW, & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY & ) ELSE IF (PORD_INT_SIZE.EQ.32) THEN CALL MUMPS_PORDF_MIXEDto32(NCMP, IWFR8-1_8, IPE, & IW, & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE WRITE(*,*) & "Internal error in PORD wrappers, PORD_INT_SIZE=", & PORD_INT_SIZE CALL MUMPS_ABORT() ENDIF ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 GOTO 90 ENDIF IF (INFO(1) .LT. 0) GOTO 90 #endif #if defined(scotch) || defined(ptscotch) ELSEIF (IORD .EQ. 3) THEN CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE) IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) & ) THEN WEIGHTREQUESTED=1 IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IF & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) THEN DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF ELSE WEIGHTREQUESTED = 0 DO I= 1, N IWL1(I) = 1 ENDDO ENDIF IF (SCOTCH_INT_SIZE.EQ.32) THEN IF (KEEP(10).EQ.1) THEN INFO(1) = -52 INFO(2) = 2 ELSE CALL MUMPS_SCOTCH_MIXEDto32(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, & WEIGHTUSED, WEIGHTREQUESTED, SCOTCH_SYMBOLIC) ENDIF ELSE IF (SCOTCH_INT_SIZE.EQ.64) THEN CALL MUMPS_SCOTCH_MIXEDto64(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH, & WEIGHTUSED, WEIGHTREQUESTED, SCOTCH_SYMBOLIC) ELSE WRITE(*,*) & "Internal error in SCOTCH wrappers, SCOTCH_INT_SIZE=", & SCOTCH_INT_SIZE CALL MUMPS_ABORT() ENDIF IF (INFO(1) .LT. 0) GOTO 90 IF (.NOT. SCOTCH_SYMBOLIC) THEN IF ( COMPRESS .EQ. 1 ) THEN CALL CMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94), & KEEP(93),PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF ELSE IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS).AND. & (WEIGHTUSED.EQ.0) ) & ) THEN CALL CMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS(1)) CALL CMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP1(1), & FRERE(1),PTRAR(1,1)) DO I=1,NCMP IKEEP2(IKEEP1(I))=I ENDDO ENDIF #endif ELSEIF (IORD .EQ. 2) THEN NBBUCK = 2*N COMPUTE_PERM=.FALSE. IF(COMPRESS .GE. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.GE.1) THEN CALL MUMPS_ABORT() ENDIF NBBUCK = max(NBBUCK, NORIG-N) NBBUCK = max(NBBUCK, 2*NORIG) NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF ALLOCATE( WTEMP ( 0: NBBUCK + 1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = NBBUCK+2 GOTO 90 ENDIF IF(COMPRESS .LE. 1) THEN CALL MUMPS_HAMF4 & (TOTEL, NCMP, COMPUTE_PERM, NBBUCK, LIW8, IPE(1), & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), WTEMP, PARENT(1)) ELSE IF(PROK) WRITE(MP,'(A)') & ' Constrained Ordering based on AMF' CALL MUMPS_CST_AMF(NCMP, NBBUCK, LIW8, IPE(1), & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), WTEMP, & NFSIZ(1), FRERE(1), PARENT(1)) ENDIF DEALLOCATE(WTEMP) ELSEIF (IORD .EQ. 6) THEN ALLOCATE( WTEMP ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF THRESH = 1 IVersion = 2 COMPUTE_PERM=.FALSE. IF(COMPRESS .EQ. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.EQ.1) THEN CALL MUMPS_ABORT() ENDIF NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL MUMPS_QAMD & (TOTEL,COMPUTE_PERM,IVersion, THRESH, WTEMP, & NCMP, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), PARENT(1)) DEALLOCATE(WTEMP) ELSE COMPUTE_PERM=.FALSE. IF(COMPRESS .EQ. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.EQ.1) THEN CALL MUMPS_ABORT() ENDIF NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL MUMPS_ANA_H(TOTEL, COMPUTE_PERM, & NCMP, LIW8, IPE(1), IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), PARENT(1)) ENDIF ENDIF IF(COMPRESS .GE. 1) THEN CALL CMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94),KEEP(93), & PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) #if defined(scotch) || defined(ptscotch) IF (IORD.EQ.3) THEN WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME SPENT IN SCOTCH reordering =', TIMEB ENDIF #endif ENDIF ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MP,'(A)') ' Ordering based on METIS' ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN INFO(1) = -52 INFO(2) = 1 GOTO 90 ENDIF #if defined(metis4) || defined(parmetis3) NUMFLAG = 1 OPT_METIS_SIZE = 8 #else OPT_METIS_SIZE = 40 #endif IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 FRERE(I) = 2 ENDDO DO I=KEEP(93)/2+1,NCMP FRERE(I) = 1 ENDDO #if defined(metis4) || defined(parmetis3) IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEWND_MIXEDto32( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ELSE IF ((NORIG.NE.N).AND.present(SIZEOFBLOCKS)) THEN DO I=1, N FRERE(I) = SIZEOFBLOCKS(I) ENDDO IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEWND_MIXEDto32( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ELSE IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW, NUMFLAG, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW, NUMFLAG, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP,LPOK,KEEP(10), & LIW8, INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ENDIF ENDIF #else ELSE IF (present(SIZEOFBLOCKS)) THEN DO I=1,N FRERE(I) = SIZEOFBLOCKS(I) ENDDO ELSE DO I=1,NCMP FRERE(I) = 1 ENDDO ENDIF ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW, FRERE, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW, FRERE, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP,LPOK,KEEP(10), & LIW8, INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH) ELSE IF (LPOK) WRITE(LP,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF #endif IF (INFO(1) .LT.0) GOTO 90 IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME SPENT IN METIS reordering =', TIMEB ENDIF IF ( COMPRESS_SCHUR ) THEN CALL CMUMPS_EXPAND_PERM_SCHUR( & N, NCMP, IKEEP1(1),IKEEP2(1), & LISTVAR_SCHUR(1), SIZE_SCHUR, FILS(1)) COMPRESS = -1 ENDIF IF (COMPRESS .EQ. 1) THEN CALL CMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94), & KEEP(93),PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF ENDIF #endif IF (PROK) THEN IF (IORD.EQ.1) THEN WRITE(MP,'(A)') ' Ordering given is used' ENDIF ENDIF IF (IORD.EQ.1 .OR. IORD.EQ.5 .OR. COMPRESS.EQ.-1 & .OR. ( (IORD.EQ.3).AND.(.NOT.SCOTCH_SYMBOLIC) ) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) .AND.(IORD.EQ.3) & .AND. (WEIGHTUSED.EQ.0) & ) & ) THEN IF ((KEEP(106).EQ.1).OR.(KEEP(106).EQ.2).OR.(KEEP(106).EQ.4) & .OR.(KEEP(60).NE.0)) THEN IF ( COMPRESS .EQ. -1 ) THEN ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL CMUMPS_ANA_GNEW(N,NZ8,IRN(1),ICN(1),IW(1),LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264),KEEP(265), .TRUE., & INPLACE64_GRAPH_COPY) DEALLOCATE(IPQ8) ENDIF COMPRESS = 0 IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF IF (KEEP(106).EQ.2) THEN IF (PROK) THEN WRITE(MP,'(A)') " SYMBOLIC based on column counts " ENDIF IF (present(SIZEOFBLOCKS)) THEN DO I=1, N FRERE(I) = SIZEOFBLOCKS(I) ENDDO ELSE FRERE(1) = -1 ENDIF CALL MUMPS_WRAP_GINP94 ( & N, IPE(1), IW(1), IWFR8, & IKEEP1(1), & FRERE(1), & KEEP(60), LISTVAR_SCHUR(1), SIZE_SCHUR, & KEEP(378), & IWL1, PARENT, & IKEEP2(1), IKEEP3(1), NFSIZ(1), & PTRAR(1,1), PTRAR(1,2), PTRAR(1,3), & INFO ) IF (INFO(1).LT.0) GOTO 90 ELSE IF ((KEEP(106).EQ.4).AND.(KEEP(60).EQ.0).AND. & (.NOT.present(SIZEOFBLOCKS) .OR. (NORIG.EQ.N)) & ) THEN WRITE(MP,*) " Undefined option for ICNTL(58) " INFO(1)= -99998 GOTO 90 ELSE ALLOCATE( WTEMP ( 2_8*int(N,8) ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(2_8*int(N,8), INFO(2) ) GOTO 90 ENDIF THRESH = -1 IF (KEEP(60) == 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR ENDIF AGG6 =.FALSE. IF (present(SIZEOFBLOCKS)) THEN DO I=1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO TOTEL = NORIG ELSE IWL1(1) = -1 TOTEL = N ENDIF CALL MUMPS_SYMQAMD(THRESH, WTEMP, & N, TOTEL, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1(1), WTEMP(N+1), & IKEEP2(1), NCMPA, FILS(1), IKEEP3(1), PTRAR, & PTRAR(1,3),IKEEP1(1), LISTVAR_SCHUR(1), ITEMP, & AGG6, PARENT) DEALLOCATE(WTEMP) ENDIF IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME IN symbolic factorization =', TIMEB ENDIF ELSE CALL CMUMPS_ANA_J(N, NZ8, IRN(1), ICN(1), IKEEP1(1), IW(1), & LIW8, IPE(1), & PTRAR(1,2), IWL1, IWFR8, & INFO(1),INFO(2), MP) IF (KEEP(60) .EQ. 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR ENDIF CALL CMUMPS_ANA_K(N, IPE(1), IW(1), LIW8, IWFR8, IKEEP1(1), & IKEEP2(1), IWL1, & PTRAR, NCMPA, ITEMP, PARENT) ENDIF ENDIF IF (KEEP(60) .NE. 0) THEN IF (KEEP(60)==1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ENDIF IF (allocated(IPEALLOC)) DEALLOCATE(IPEALLOC) ALLOCATE(WTEMP(N), stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF CALL CMUMPS_ANA_LNEW & (N, PARENT, IWL1, IKEEP1(1), IKEEP2(1), IKEEP3(1), & NFSIZ(1), PTRAR, INFO(6), FILS(1), FRERE(1), & PTRAR(1,3), NEMIN, WTEMP, KEEP(60), & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), & ICNTL(13), KEEP(37), KEEP(197), NSLAVES, KEEP(250).EQ.1, & SIZEOFBLOCKS_AVAIL, SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR & , INODE_Scalapack_CAND, NBSONS_Scalapack_CAND, & KEEP(11), KEEP(191), KEEP(192), KEEP(193) & ) DEALLOCATE(WTEMP) IF (KEEP(60).NE.0) THEN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO WHILE (IN.GT.0) IN = FILS (IN) END DO IFSON = -IN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO I=2,SIZE_SCHUR FILS(IN) = LISTVAR_SCHUR (I) IN = FILS(IN) FRERE (IN) = N+1 ENDDO FILS(IN) = -IFSON ENDIF CALL CMUMPS_ANA_M(IKEEP2(1), & PTRAR(1,3), INFO(6), & INFO(5), KEEP(2), KEEP(50), & KEEP8(101), KEEP(108), KEEP(5), & KEEP(6), KEEP(226), KEEP(253)) KEEP(59) = INFO(5) IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) INODE_Scalapack_CAND = KEEP(20) NBSONS_Scalapack_CAND = 1 END IF IF ( (KEEP(48) == 4 .AND. KEEP8(21).GT.0_8) & .OR. & (KEEP (48)==5 .AND. KEEP8(21) .GT. 0_8 ) & .OR. & (KEEP(24).NE.0.AND.KEEP8(21).GT.0_8) ) THEN CALL CMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2), & KEEP(48), KEEP(50), NSLAVES) END IF IF (KEEP(210).LT.1.OR.KEEP(210).GT.2) KEEP(210)=2 IF (KEEP(210).EQ.2) KEEP8(79)=huge(KEEP8(79)) IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF IF (KEEP(11).EQ.0) THEN IF ( (KEEP(79).EQ.0).OR.(KEEP(79).EQ.2).OR. & (KEEP(79).EQ.3).OR.(KEEP(79).EQ.5).OR. & (KEEP(79).EQ.6) & ) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN CALL CMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF (PROK) THEN WRITE(MP,*) " Number of split nodes in pre-splitting=", & KEEP(61) ENDIF ENDIF ENDIF ENDIF ENDIF HOW_TO_SPLIT_ROOT = 0 SPLITROOT = ICNTL(13) .EQ. -1 IF (KEEP(11).GT.1) THEN NFR = NFSIZ(INODE_Scalapack_CAND) #if defined(NOSCALAPACK) SPLITROOT = SPLITROOT .OR. & ( NSLAVES.GT.0.AND. & ( REAL(NFR) - REAL(NFR)/REAL(max(2,NSLAVES)) & .GT. REAL(KEEP(9)) ) & ) #else SPLITROOT = SPLITROOT .OR. & ( ICNTL(13).GT.0 .AND. NSLAVES .GT. ICNTL(13). AND. & ( REAL(NFR) - REAL(NFR)/REAL(max(2,NSLAVES)) & .GT. REAL(KEEP(9)) ) & ) #endif ELSE #if defined(NOSCALAPACK) SPLITROOT = SPLITROOT .OR. NSLAVES.GT.0 #else SPLITROOT = SPLITROOT .OR. & (ICNTL(13).GT.0 .AND. NSLAVES .GT. ICNTL(13) & ) #endif ENDIF IF (SPLITROOT.AND.KEEP(11).GT.0) HOW_TO_SPLIT_ROOT =1 IF (KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. IF (KEEP(11).GT.0) HOW_TO_SPLIT_ROOT = 2 ENDIF #if defined(NOSCALAPACK) #else IF ( KEEP(11).GT.0) THEN IF (.NOT.SPLITROOT .AND. & (KEEP(60).EQ.0).AND. & ( (NFSIZ(INODE_Scalapack_CAND).GT.KEEP(37)) & .AND.(ICNTL(13).LE.0) ) & .AND. & (NBSONS_Scalapack_CAND.GT.KEEP(11)) & ) THEN HOW_TO_SPLIT_ROOT = 3 SPLITROOT=.TRUE. ENDIF ENDIF #endif SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) )) IF (SPLITROOT) THEN IF (KEEP(11).EQ.0) THEN CALL CMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) ENDIF ELSE CALL CMUMPS_SPLIT_ROOT( NSLAVES, & HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(1), KEEP8(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, INFO(6)) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN K = min(10,N) IF (LDIAG.EQ.4) K = N IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) ENDIF GO TO 90 90 CONTINUE IF (INFO(1) .NE. 0) THEN IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE (LP,99996) INFO(1), INFO(2) ENDIF IF (allocated(IWALLOC)) DEALLOCATE(IWALLOC) IF (allocated(IWL1)) DEALLOCATE(IWL1) IF (allocated(IPEALLOC)) DEALLOCATE(IPEALLOC) IF (allocated(PTRAR)) DEALLOCATE(PTRAR) IF (allocated(PARENT)) DEALLOCATE(PARENT) RETURN 99999 FORMAT (/'Entering ordering phase with ...'/ & ' N NNZ LIW INFO(1)'/, & 6X, I10, I11, I12, I10) 99998 FORMAT ('Matrix entries: IRN() ICN()'/ & (I12, I9, I12, I9, I12, I9)) 99909 FORMAT (/'Entering ordering phase with graph dimensions ...'/ & ' |V| |E| INFO(1)'/, & 10X, I10, I13, I10) 99997 FORMAT ('IKEEP1(.)=', 10I8/(12X, 10I8)) 99996 FORMAT & (/'** Error/warning return ** from Analysis * INFO(1:2)= ', & (I3, I16)) 99989 FORMAT ('FILS (.) =', 10I9/(11X, 10I9)) 99988 FORMAT ('FRERE(.) =', 10I9/(11X, 10I9)) 99987 FORMAT ('NFSIZ(.) =', 10I9/(11X, 10I9)) END SUBROUTINE CMUMPS_ANA_F SUBROUTINE CMUMPS_ANA_N_DIST( id, NBINCOL, NBINROW ) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_STRUC IMPLICIT NONE include 'mpif.h' TYPE(CMUMPS_STRUC), INTENT(INOUT), TARGET :: id INTEGER, INTENT(OUT), TARGET :: NBINCOL(:) INTEGER, INTENT(OUT), TARGET :: NBINROW(:) INTEGER :: IERR, allocok INTEGER :: IOLD, JOLD, INEW, JNEW INTEGER(8) :: K, INZ INTEGER, POINTER :: IIRN(:), IJCN(:) INTEGER, POINTER :: IWORK1(:), IWORK2(:) LOGICAL :: IDO IF(id%KEEP(54) .EQ. 3) THEN IIRN => id%IRN_loc IJCN => id%JCN_loc INZ = id%KEEP8(29) IWORK1 => NBINROW(1:id%N) allocate(IWORK2(id%N),stat=allocok) IF (allocok > 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%N RETURN ENDIF IDO = .TRUE. ELSE IIRN => id%IRN IJCN => id%JCN INZ = id%KEEP8(28) IWORK1 => NBINCOL(1:id%N) IWORK2 => NBINROW(1:id%N) IDO = id%MYID .EQ. 0 END IF DO 50 IOLD=1,id%N IWORK1(IOLD) = 0_8 IWORK2(IOLD) = 0_8 50 CONTINUE IF(IDO) THEN DO 70 K=1_8,INZ IOLD = IIRN(K) JOLD = IJCN(K) IF ( (IOLD.GT.id%N).OR.(JOLD.GT.id%N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) GOTO 70 IF (IOLD.NE.JOLD) THEN INEW = id%SYM_PERM(IOLD) JNEW = id%SYM_PERM(JOLD) IF ( id%KEEP( 50 ) .EQ. 0 ) THEN IF (INEW.LT.JNEW) THEN IWORK2(IOLD) = IWORK2(IOLD) + 1 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 (id%KEEP(54) .EQ. 3) THEN CALL MUMPS_BIGALLREDUCE(.FALSE., IWORK1(1), NBINCOL(1), id%N, & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) CALL MUMPS_BIGALLREDUCE(.FALSE., IWORK2(1), NBINROW(1), id%N, & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) deallocate(IWORK2) ELSE CALL MPI_BCAST( NBINCOL(1), id%N, MPI_INTEGER, & 0, id%COMM, IERR ) CALL MPI_BCAST( NBINROW(1), id%N, MPI_INTEGER, & 0, id%COMM, IERR ) END IF RETURN END SUBROUTINE CMUMPS_ANA_N_DIST SUBROUTINE CMUMPS_ANA_O( N, NZ, MTRANS, PERM, & IKEEPALLOC, LIKEEPALLOC, & idIRN, idJCN, idA, idROWSCA, idCOLSCA, WORK2, KEEP, & ICNTL, INFO, INFOG ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ INTEGER, INTENT(OUT) :: PERM(:) INTEGER, POINTER, DIMENSION(:) :: idIRN, idJCN COMPLEX, POINTER, DIMENSION(:) :: idA REAL, POINTER, DIMENSION(:) :: idROWSCA, idCOLSCA INTEGER(8), INTENT(IN) :: LIKEEPALLOC INTEGER, TARGET :: IKEEPALLOC(LIKEEPALLOC) INTEGER, INTENT(INOUT) :: MTRANS INTEGER :: KEEP(500) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(INOUT) :: INFOG(80) INTEGER, TARGET :: WORK2(N) INTEGER :: allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: IW REAL, ALLOCATABLE, DIMENSION(:) :: S2 TARGET :: S2 INTEGER ICNTL64(10), INFO64(10) INTEGER ICNTL_SYM_MWM(10),INFO_SYM_MWM(10) REAL CNTL64(10) INTEGER MPRINT,LP, MP INTEGER JPERM INTEGER NUMNZ, I, J, JPOS LOGICAL PROK, IDENT, DUPPLI INTEGER K50, KER_SIZE, NZER_DIAG, MTRANSLOC,RZ_DIAG INTEGER(8) :: LIWG INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8 INTEGER :: LSC INTEGER(8) :: NZTOT, NZREAL, IPIW, LIW, LIWMIN, NZsave, & K, KPOS, LDW, LDWMIN, IRNW, RSPOS, CSPOS, & LS2,J8, N8 LOGICAL SCALINGLOC INTEGER,POINTER,DIMENSION(:) :: ZERODIAG INTEGER,POINTER,DIMENSION(:) :: STR_KER INTEGER,POINTER,DIMENSION(:) :: MARKED INTEGER,POINTER,DIMENSION(:) :: FLAG INTEGER,POINTER,DIMENSION(:) :: PIV_OUT REAL THEMIN, THEMAX, COLNORM,MAXDBL, ABSAK REAL ZERO,TWO,ONE PARAMETER(ZERO = 0.0E0,TWO = 2.0E0,ONE = 1.0E0) N8 = int(N,8) MPRINT = ICNTL(3) LP = ICNTL(1) MP = ICNTL(2) PROK = ((MPRINT.GT.0).AND.(ICNTL(4).GE.2)) K50 = KEEP(50) SCALINGLOC = .FALSE. IF(KEEP(52) .EQ. -2) THEN IF(.not.associated(idA)) THEN ELSE SCALINGLOC = .TRUE. ENDIF ELSE IF(KEEP(52) .EQ. 77) THEN SCALINGLOC = .TRUE. IF( MTRANS .NE. 5 .AND. MTRANS .NE. 6 & .AND. MTRANS .NE. 7) THEN SCALINGLOC = .FALSE. ENDIF IF(.not.associated(idA)) THEN SCALINGLOC = .FALSE. IF (PROK) & WRITE(MPRINT,*) 'Analysis: auto scaling OFF because ', & 'A not provided at analysis ' ENDIF ENDIF IF ( (KEEP(50).EQ.2).AND.(ICNTL(8).NE.-2).AND. & (MTRANS .EQ. 7 .OR. KEEP(95) .EQ. 0) ) THEN ZERODIAG => IKEEPALLOC(1:N) ZERODIAG = 0 NZER_DIAG = N RZ_DIAG = 0 DO K=1,NZ I = idIRN(K) J = idJCN(K) IF (I.NE.J) CYCLE IF ( (J.LE.N).AND.(J.GE.1) ) THEN IF(ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = 1 IF(associated(idA)) THEN ABSAK= abs(idA(K)) IF(ABSAK .EQ. real(0.0E0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ENDIF NZER_DIAG = NZER_DIAG - 1 ENDIF ENDIF ENDDO IF( (NZER_DIAG+RZ_DIAG) .LT. max(1,(N/10)) ) THEN MTRANS = 0 KEEP(95) = 1 GOTO 500 ENDIF ENDIF IF(SCALINGLOC) THEN IF (PROK) WRITE(MPRINT,*) & 'Scaling will be computed during analysis' ENDIF IF( MTRANS.NE.0 .AND. (.NOT.associated(idA)) ) MTRANS=1 MTRANSLOC = MTRANS IF (MTRANS.LT.0 .OR. MTRANS.GT.7) GO TO 500 IF (K50 .EQ. 0) THEN IF(.NOT. SCALINGLOC .AND. MTRANS .EQ. 7) THEN GO TO 500 ENDIF IF(SCALINGLOC) THEN IF (MTRANSLOC.NE.6) THEN MTRANSLOC = 5 ENDIF ENDIF ELSE IF (MTRANS .EQ. 7) MTRANSLOC = 5 ENDIF IF(SCALINGLOC .AND. MTRANSLOC .NE. 5 .AND. & MTRANSLOC .NE. 6 ) THEN IF (PROK) WRITE(MPRINT,*) & 'WARNING scaling required: set MTRANS option to 5' MTRANSLOC = 5 ENDIF IF (N.EQ.1) THEN MTRANS = 0 KEEP(95) = 1 GO TO 500 ENDIF IF(K50 .NE. 0) THEN NZTOT = 2_8*NZ+N8 ELSE NZTOT = NZ ENDIF ZERODIAG => IKEEPALLOC(1:N) STR_KER => IKEEPALLOC(int(N+1,8):2_8*int(N,8)) CALL CMUMPS_MTRANSI(ICNTL64,CNTL64) ICNTL64(1) = ICNTL(1) ICNTL64(2) = ICNTL(2) ICNTL64(3) = ICNTL(3) ICNTL64(4) = -1 IF (ICNTL(4).EQ.3) ICNTL64(4) = 0 IF (ICNTL(4).EQ.4) ICNTL64(4) = 1 ICNTL64(5) = -1 IF (PROK) THEN WRITE(MPRINT,'(A,I3)') & 'Compute maximum matching (Maximum Transversal):', & MTRANSLOC IF (MTRANSLOC.EQ.1) & WRITE(MPRINT,'(A,I3)')' ... JOB =',MTRANSLOC IF (MTRANSLOC.EQ.2) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': BOTTLENECK THESIS' IF (MTRANSLOC.EQ.3) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': BOTTLENECK SIMAX' IF (MTRANSLOC.EQ.4) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': MAXIMIZE SUM DIAGONAL' IF (MTRANSLOC.EQ.5 .OR. MTRANSLOC.EQ.6) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC, & ': MAXIMIZE PRODUCT DIAGONAL AND SCALE' ENDIF INFOG(23) = MTRANSLOC CNTL64(2) = huge(CNTL64(2)) IRNW = 1 IPIW = IRNW + NZTOT IF (MTRANSLOC.EQ.1) LIWMIN = 5_8*N8 IF (MTRANSLOC.EQ.2) LIWMIN = 3_8*N8 IF (MTRANSLOC.EQ.3) LIWMIN = 10_8*N8 + NZTOT IF (MTRANSLOC.EQ.4) LIWMIN = 2_8*N8 IF (MTRANSLOC.EQ.5) LIWMIN = 5_8*N8 IF (MTRANSLOC.EQ.6) LIWMIN = 5_8*N8 + NZTOT LIW = LIWMIN LIWG = LIW + NZTOT ALLOCATE(IW(LIWG), stat=allocok) IF (allocok .GT. 0 ) THEN GOTO 410 ENDIF ALLOCATE( IPQ8(N), IPE(N+1), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR( (2_8*int(N,8)+1_8) * int(KEEP(10),8), & INFO(2) ) GOTO 500 ENDIF IF (MTRANSLOC.EQ.1) THEN LDWMIN = N8+3_8 ENDIF IF (MTRANSLOC.EQ.2) LDWMIN = max( N8+NZTOT , N8+3_8 ) IF (MTRANSLOC.EQ.3) LDWMIN = max( NZTOT+1_8 , N8+3_8 ) IF (MTRANSLOC.EQ.4) LDWMIN = 2_8 * N8 + & max( NZTOT , N8+3_8 ) IF (MTRANSLOC.EQ.5) LDWMIN = 3_8 * N8 + NZTOT IF (MTRANSLOC.EQ.6) LDWMIN = 4_8 * N8 + NZTOT LDW = LDWMIN ALLOCATE(S2(LDW), stat=allocok) IF (allocok .GT. 0 ) THEN GOTO 430 ENDIF IF(MTRANSLOC .NE. 1) LDW = LDW-NZTOT RSPOS = NZTOT CSPOS = RSPOS+N8 NZREAL = 0_8 DO 5 J=1,N IPQ8(J) = 0_8 5 CONTINUE IF(K50 .EQ. 0) THEN DO 10 K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1).AND. & (I.LE.N).AND.(I.GE.1) ) THEN IPQ8(J) = IPQ8(J) + 1_8 NZREAL = NZREAL + 1_8 ENDIF 10 CONTINUE ELSE ZERODIAG = 0 NZER_DIAG = N RZ_DIAG = 0 DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1).AND. & (I.LE.N).AND.(I.GE.1) ) THEN IPQ8(J) = IPQ8(J) + 1_8 NZREAL = NZREAL + 1_8 IF(I .NE. J) THEN IPQ8(I) = IPQ8(I) + 1_8 NZREAL = NZREAL + 1_8 ELSE IF (ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = 1 IF(associated(idA)) THEN ABSAK= abs(idA(K)) IF(ABSAK .EQ. real(0.0E0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ZERODIAG(I) = exponent(ABSAK) if ( ZERODIAG(I).EQ.0) ZERODIAG(I)=1 ENDIF NZER_DIAG = NZER_DIAG - 1 ELSE IF(associated(idA)) THEN ABSAK= abs(idA(K)) ZERODIAG(I) = ZERODIAG(I)+ exponent(ABSAK) if ( ZERODIAG(I).EQ.0) ZERODIAG(I)=1 ENDIF ENDIF ENDIF ENDIF ENDDO IF(MTRANSLOC .GE. 4) THEN DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN IPQ8(I) = IPQ8(I) + 1_8 NZREAL = NZREAL + 1_8 ENDIF ENDDO ENDIF ENDIF IPE(1) = 1 DO 20 J=1,N IPE(J+1) = IPE(J)+IPQ8(J) 20 CONTINUE DO 25 J=1, N IPQ8(J ) = IPE(J) 25 CONTINUE IF(K50 .EQ. 0) THEN IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1_8) = I IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ELSE IF ( .not.associated(idA)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1) = I S2(KPOS) = abs(idA(K)) IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ENDIF ELSE IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1) = I IPQ8(J) = IPQ8(J) + 1_8 IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDIF ENDDO ELSE IF ( .not.associated(idA) ) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF THEMAX = ZERO THEMIN = huge(THEMIN) DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1_8) = I S2(KPOS) = abs(idA(K)) IPQ8(J) = IPQ8(J) + 1_8 IF(abs(idA(K)) .GT. THEMAX) THEN THEMAX = abs(idA(K)) ELSE IF(abs(idA(K)) .LT. THEMIN & .AND. abs(idA(K)).GT. ZERO) THEN THEMIN = abs(idA(K)) ENDIF IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J S2(KPOS) = abs(idA(K)) IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDIF ENDDO DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = I S2(KPOS) = ZERO IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDDO IF ( THEMAX .NE. ZERO ) THEN CNTL64(2) = (log(THEMAX/THEMIN))*(real(N)) & - log(THEMIN) + ONE ENDIF ENDIF ENDIF DUPPLI = .FALSE. NZsave = NZREAL FLAG => IKEEPALLOC(2_8*int(N,8)+1:3_8*int(N,8)) IF(MTRANSLOC.NE.1) THEN CALL CMUMPS_SUPPRESS_DUPPLI_VAL(N,NZREAL,IPE(1),IW(IRNW),S2, & PERM(1),IPQ8(1)) ELSE CALL CMUMPS_SUPPRESS_DUPPLI_STR(N,NZREAL,IPE(1),IW(IRNW), & PERM(1)) ENDIF IF(NZREAL .NE. NZsave) DUPPLI = .TRUE. LS2 = NZTOT IF ( MTRANSLOC .EQ. 1 ) THEN LS2 = 1_8 LDW = 1_8 ENDIF CALL CMUMPS_MTRANS_DRIVER(MTRANSLOC ,N, N, NZREAL, & IPE, IW(IRNW), S2(1), LS2, & NUMNZ, PERM(1), LIW, IW(IPIW), LDW, S2(LS2+1), & IPQ8, & ICNTL64, CNTL64, INFO64, INFO) IF (INFO(1).LT.0) THEN IF (LP.GT.0 .AND. ICNTL(4).GE.1) & WRITE(LP,'(A,I5)') & ' Not enough memory in MAXTRANS INFO(1)=',INFO(1) GOTO 500 ENDIF IF (INFO64(1).LT.0) THEN IF (LP.GT.0 .AND. ICNTL(4).GE.1) & WRITE(LP,'(A,I5)') & ' INTERNAL ERROR in MAXTRANS INFO(1)=',INFO64(1) INFO(1) = -9964 INFO(2) = INFO64(1) GO TO 500 ENDIF IF (INFO64(1).GT.0) THEN IF (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(A,I5)') & ' WARNING in MAXTRANS INFO(1)=',INFO64(1) ENDIF KER_SIZE = 0 IF(K50 .EQ. 2) THEN DO I=1,N IF(ZERODIAG(I) .EQ. 0) THEN IF(PERM(I) .EQ. I) THEN KER_SIZE = KER_SIZE + 1 PERM(I) = -I STR_KER(KER_SIZE) = I ENDIF ENDIF ENDDO ENDIF IF (NUMNZ.LT.N) then IF (MTRANSLOC.EQ.1) THEN IF (MINVAL(PERM(1:N)) .LE. 0) THEN GOTO 400 ENDIF ELSE GO TO 400 ENDIF ENDIF IF(K50 .EQ. 0) THEN IDENT = .TRUE. IF (MTRANS .EQ. 0 ) GOTO 102 DO 80 J=1,N JPERM = PERM(J) IW(IRNW+int(JPERM-1,8)) = J IF (JPERM.NE.J) IDENT = .FALSE. 80 CONTINUE IF(IDENT) THEN MTRANS = 0 ELSE IF(MTRANS .EQ. 7) THEN MTRANS = -9876543 GOTO 102 ENDIF IF (PROK) WRITE(MPRINT,'(A)') & ' ... Apply column permutation' DO 100 K=1,NZ J = idJCN(K) IF ((J.LE.0).OR.(J.GT.N)) GO TO 100 idJCN(K) = IW(IRNW+int(J-1,8)) 100 CONTINUE IF (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' ENDIF 102 CONTINUE IF (SCALINGLOC) THEN IF ( associated(idCOLSCA)) & DEALLOCATE( idCOLSCA ) IF ( associated(idROWSCA)) & DEALLOCATE( idROWSCA ) ALLOCATE( idCOLSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in CMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of COLSCA' GOTO 500 ENDIF ENDIF ALLOCATE( idROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in CMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of ROWSCA' GOTO 500 ENDIF ENDIF KEEP(52) = -2 KEEP(74) = 1 MAXDBL = log(huge(MAXDBL)) DO J=1,N IF(S2(RSPOS+J) .GT. MAXDBL) THEN S2(RSPOS+J) = ZERO ENDIF IF(S2(CSPOS+J) .GT. MAXDBL) THEN S2(CSPOS+J)= ZERO ENDIF ENDDO DO 105 J=1,N J8 = int(J,8) idROWSCA(J) = exp(S2(RSPOS+J8)) IF(idROWSCA(J) .EQ. ZERO) THEN idROWSCA(J) = ONE ENDIF IF ( MTRANS .EQ. -9876543 .OR. MTRANS.EQ. 0 ) THEN idCOLSCA(J)= exp(S2(CSPOS+J8)) IF(idCOLSCA(J) .EQ. ZERO) THEN idCOLSCA(J) = ONE ENDIF ELSE idCOLSCA(IW(IRNW+J8-1_8))= exp(S2(CSPOS+J8)) IF(idCOLSCA(IW(IRNW+J8-1_8)) .EQ. ZERO) THEN idCOLSCA(IW(IRNW+J8-1_8)) = ONE ENDIF ENDIF 105 CONTINUE ENDIF ELSE IDENT = .FALSE. IF(SCALINGLOC) THEN IF ( associated(idCOLSCA)) DEALLOCATE( idCOLSCA ) IF ( associated(idROWSCA)) DEALLOCATE( idROWSCA ) ALLOCATE( idCOLSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in CMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of COLSCA' GOTO 500 ENDIF ENDIF ALLOCATE( idROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in CMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of ROWSCA' GOTO 500 ENDIF ENDIF KEEP(52) = -2 KEEP(74) = 1 MAXDBL = log(huge(MAXDBL)) DO J=1,N J8 = int(J,8) IF(S2(RSPOS+J8)+S2(CSPOS+J8) .GT. MAXDBL) THEN S2(RSPOS+J8) = ZERO S2(CSPOS+J8)= ZERO ENDIF ENDDO DO J=1,N J8 = int(J,8) IF(PERM(J) .GT. 0) THEN idROWSCA(J) = & exp((S2(RSPOS+J8)+S2(CSPOS+J8))/TWO) IF(idROWSCA(J) .EQ. ZERO) THEN idROWSCA(J) = ONE ENDIF idCOLSCA(J)= idROWSCA(J) ENDIF ENDDO DO JPOS=1,KER_SIZE I = STR_KER(JPOS) COLNORM = ZERO DO K = IPE(I),IPE(I+1) - 1 IF ( PERM( IW( IRNW+K-1_8) ) > 0 ) THEN COLNORM = max(COLNORM,S2(J)) ENDIF ENDDO COLNORM = exp(COLNORM) idROWSCA(I) = ONE / COLNORM idCOLSCA(I) = idROWSCA(I) ENDDO ENDIF IF(MTRANS .EQ. 7 .OR. KEEP(95) .EQ. 0) THEN IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) & .AND. KEEP(95) .EQ. 0) THEN MTRANS = 0 KEEP(95) = 1 GOTO 390 ELSE IF(KEEP(95) .EQ. 0) THEN IF(SCALINGLOC) THEN KEEP(95) = 3 ELSE KEEP(95) = 2 ENDIF ENDIF IF(MTRANS .EQ. 7) MTRANS = 5 ENDIF ENDIF IF(MTRANS .EQ. 0) GOTO 390 ICNTL_SYM_MWM = 0 INFO_SYM_MWM = 0 IF(MTRANS .EQ. 5 .OR. MTRANS .EQ. 6 .OR. & MTRANS .EQ. 7) THEN ICNTL_SYM_MWM(1) = 0 ICNTL_SYM_MWM(2) = 1 ELSE IF(MTRANS .EQ. 4) THEN ICNTL_SYM_MWM(1) = 2 ICNTL_SYM_MWM(2) = 1 ELSE ICNTL_SYM_MWM(1) = 0 ICNTL_SYM_MWM(2) = 1 ENDIF MARKED => IKEEPALLOC( int(N,8)+1_8 : 2_8*int(N,8)) FLAG => IKEEPALLOC(2_8*int(N,8)+1_8 : 3_8*int(N,8)) PIV_OUT => WORK2(1:N) IF(MTRANSLOC .LT. 4) THEN LSC = 1 ELSE LSC = 2*N ENDIF CALL CMUMPS_SYM_MWM( & N, NZREAL, IPE, IW(IRNW), S2(1),LSC, PERM(1), & ZERODIAG(1), & ICNTL_SYM_MWM, S2(LSC+1),MARKED(1),FLAG(1), & PIV_OUT(1), INFO_SYM_MWM) IF(INFO_SYM_MWM(1) .NE. 0) THEN WRITE(*,*) '** Error in CMUMPS_ANA_O' RETURN ENDIF IF(INFO_SYM_MWM(3) .EQ. N) THEN IDENT = .TRUE. ELSEIF ( (ICNTL(12).EQ.0).AND. & ( (N-INFO_SYM_MWM(4)-INFO_SYM_MWM(3)) .GT. N/10 ) & ) THEN IDENT = .TRUE. KEEP(95) = 1 ELSE DO I=1,N PERM(I) = PIV_OUT(I) ENDDO ENDIF KEEP(93) = INFO_SYM_MWM(4) KEEP(94) = INFO_SYM_MWM(3) IF (IDENT) MTRANS=0 ENDIF 390 IF(MTRANS .EQ. 0) THEN KEEP(95) = 1 IF (PROK) THEN WRITE (MPRINT,'(A)') & ' ... Column permutation not used' ENDIF ENDIF GO TO 500 400 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) & WRITE (LP,'(/A)') '** Error: Matrix is structurally singular' INFO(1) = -6 INFO(2) = NUMNZ GOTO 500 410 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in CMUMPS_ANA_O' WRITE (LP,'(A,I14)') & '** Failure during allocation of INTEGER array of size ', & LIWG ENDIF INFO(1) = -7 CALL MUMPS_SET_IERROR(LIWG,INFO(2)) GOTO 500 430 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in CMUMPS_ANA_O' WRITE (LP,'(A)') '** Failure during allocation of S2' ENDIF INFO(1) = -5 CALL MUMPS_SET_IERROR(LDW,INFO(2)) 500 CONTINUE IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(S2)) DEALLOCATE(S2) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(IPQ8)) DEALLOCATE(IPQ8) RETURN END SUBROUTINE CMUMPS_ANA_O END MODULE CMUMPS_ANA_AUX_M SUBROUTINE CMUMPS_ANA_K(N,IPE, IW, LW, IWFR, IPS, IPV, & NV, FLAG, & NCMPA, SIZE_SCHUR, PARENT) IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR INTEGER, INTENT(IN) :: IPS(N) INTEGER(8), INTENT(IN) :: LW INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: IPV(N), NV(N), PARENT(N) INTEGER(8), INTENT(INOUT) :: IWFR INTEGER(8), INTENT(INOUT) :: IPE(N) INTEGER, INTENT(INOUT) :: IW(LW) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER I,J,ML,MS,ME,MINJS,IE,KDUMMY INTEGER LN,JS,JE INTEGER(8) :: JP, JP1, JP2, LWFR, IP DO 10 I=1,N FLAG(I) = 0 NV(I) = 0 J = IPS(I) IPV(J) = I 10 CONTINUE NCMPA = 0 DO 100 ML=1,N-SIZE_SCHUR MS = IPV(ML) ME = MS FLAG(MS) = ME IP = IWFR MINJS = N IE = ME DO 70 KDUMMY=1,N JP = IPE(IE) LN = 0 IF (JP.LE.0_8) GO TO 60 LN = IW(JP) DO 50 JP1=1_8,int(LN,8) JP = JP + 1_8 JS = IW(JP) IF (FLAG(JS).EQ.ME) GO TO 50 FLAG(JS) = ME IF (IWFR.LT.LW) GO TO 40 IPE(IE) = JP IW(JP) = LN - int(JP1) CALL CMUMPS_ANA_D(N, IPE, IW, IP-1_8, LWFR, NCMPA) JP2 = IWFR - 1 IWFR = LWFR IF (IP.GT.JP2) GO TO 30 DO 20 JP=IP,JP2 IW(IWFR) = IW(JP) IWFR = IWFR + 1_8 20 CONTINUE 30 IP = LWFR JP = IPE(IE) 40 IW(IWFR) = JS MINJS = min(MINJS,IPS(JS)+0) IWFR = IWFR + 1_8 50 CONTINUE 60 IPE(IE) = int(-ME,8) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 80 70 CONTINUE 80 IF (IWFR.GT.IP) GO TO 90 IPE(ME) = 0_8 NV(ME) = 1 GO TO 100 90 MINJS = IPV(MINJS) NV(ME) = NV(MINJS) NV(MINJS) = ME IW(IWFR) = IW(IP) IW(IP) = int(IWFR - IP) IPE(ME) = IP IWFR = IWFR + 1_8 100 CONTINUE IF (SIZE_SCHUR == 0) GOTO 500 DO ML = N-SIZE_SCHUR+1,N ME = IPV(ML) IE = ME DO KDUMMY=1,N JP = IPE(IE) LN = 0 IF (JP.LE.0_8) GO TO 160 LN = IW(JP) 160 IPE(IE) = int(-IPV(N-SIZE_SCHUR+1),8) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 190 ENDDO 190 NV(ME) = 0 IPE(ME) = int(-IPV(N-SIZE_SCHUR+1),8) ENDDO ME = IPV(N-SIZE_SCHUR+1) IPE(ME) = 0_8 NV(ME) = SIZE_SCHUR 500 DO I=1,N PARENT(I) = int(IPE(I)) ENDDO RETURN END SUBROUTINE CMUMPS_ANA_K SUBROUTINE CMUMPS_ANA_J(N, NZ, IRN, ICN, PERM, & IW, LW, IPE, IQ, FLAG, & IWFR, IFLAG, IERROR, MP) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ, LW INTEGER, INTENT(IN) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: PERM(N) INTEGER, INTENT(IN) :: MP INTEGER(8), INTENT(OUT):: IWFR INTEGER, INTENT(OUT) :: IERROR INTEGER, INTENT(OUT) :: IQ(N) INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER, INTENT(OUT) :: IW(LW) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER, INTENT(INOUT) :: IFLAG INTEGER :: I,J,LBIG,IN,LEN,JDUMMY,L1 INTEGER(8) :: K, K1, K2, KL, KID IERROR = 0 DO 10 I=1,N IQ(I) = 0 10 CONTINUE DO 80 K=1_8,NZ I = IRN(K) J = ICN(K) IW(K) = -I IF (I.EQ.J) GOTO 40 IF (I.GT.J) GOTO 30 IF (I.GE.1 .AND. J.LE.N) GO TO 60 GO TO 50 30 IF (J.GE.1 .AND. I.LE.N) GO TO 60 GO TO 50 40 IW(K) = 0 IF (I.GE.1 .AND. I.LE.N) GO TO 80 50 IERROR = IERROR + 1 IW(K) = 0 IF (IERROR.LE.1 .AND. MP.GT.0) WRITE (MP,99999) IF (IERROR.LE.10 .AND. MP.GT.0) WRITE (MP,99998) K, I, J GO TO 80 60 IF (PERM(J).GT.PERM(I)) GO TO 70 IQ(J) = IQ(J) + 1 GO TO 80 70 IQ(I) = IQ(I) + 1 80 CONTINUE IF (IERROR.GE.1) THEN IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 ENDIF IWFR = 1_8 LBIG = 0 DO 100 I=1,N L1 = IQ(I) LBIG = max(L1,LBIG) IWFR = IWFR + int(L1,8) IPE(I) = IWFR - 1_8 100 CONTINUE DO 140 K=1_8,NZ I = -IW(K) IF (I.LE.0) GO TO 140 KL = K IW(K) = 0 DO 130 KID=1,NZ J = ICN(KL) IF (PERM(I).LT.PERM(J)) GO TO 110 KL = IPE(J) IPE(J) = KL - 1_8 IN = IW(KL) IW(KL) = I GO TO 120 110 KL = IPE(I) IPE(I) = KL - 1_8 IN = IW(KL) IW(KL) = J 120 I = -IN IF (I.LE.0) GO TO 140 130 CONTINUE 140 CONTINUE K = IWFR - 1_8 KL = K + int(N,8) IWFR = KL + 1_8 DO 170 I=1,N FLAG(I) = 0 J = N + 1 - I LEN = IQ(J) IF (LEN.LE.0) GO TO 160 DO 150 JDUMMY=1,LEN IW(KL) = IW(K) K = K - 1_8 KL = KL - 1_8 150 CONTINUE 160 IPE(J) = KL KL = KL - 1_8 170 CONTINUE IF (LBIG.GE.huge(N)) GO TO 190 DO 180 I=1,N K = IPE(I) IW(K) = IQ(I) IF (IQ(I).EQ.0) IPE(I) = 0_8 180 CONTINUE GO TO 230 190 IWFR = 1_8 DO 220 I=1,N K1 = IPE(I) + 1_8 K2 = IPE(I) + int(IQ(I),8) IF (K1.LE.K2) GO TO 200 IPE(I) = 0_8 GO TO 220 200 IPE(I) = IWFR IWFR = IWFR + 1_8 DO 210 K=K1,K2 J = IW(K) IF (FLAG(J).EQ.I) GO TO 210 IW(IWFR) = J IWFR = IWFR + 1_8 FLAG(J) = I 210 CONTINUE K = IPE(I) IW(K) = int(IWFR - K - 1_8) 220 CONTINUE 230 RETURN 99999 FORMAT (' *** WARNING MESSAGE FROM CMUMPS_ANA_J ***' ) 99998 FORMAT (I6, ' NON-ZERO (IN ROW, I6, 11H AND COLUMN ', I6, & ') IGNORED') END SUBROUTINE CMUMPS_ANA_J SUBROUTINE CMUMPS_ANA_D(N, IPE, IW, LW, IWFR,NCMPA) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(INOUT):: IPE(N) INTEGER, INTENT(INOUT) :: NCMPA INTEGER, INTENT(INOUT) :: IW(LW) INTEGER :: I, IR INTEGER(8) :: K1, K, K2, LWFR NCMPA = NCMPA + 1 DO 10 I=1,N K1 = IPE(I) IF (K1.LE.0_8) GO TO 10 IPE(I) = int(IW(K1), 8) IW(K1) = -I 10 CONTINUE IWFR = 1_8 LWFR = IWFR DO 60 IR=1,N IF (LWFR.GT.LW) GO TO 70 DO 20 K=LWFR,LW IF (IW(K).LT.0) GO TO 30 20 CONTINUE GO TO 70 30 I = -IW(K) IW(IWFR) = int(IPE(I)) IPE(I) = int(IWFR,8) K1 = K + 1_8 K2 = K + int(IW(IWFR),8) IWFR = IWFR + 1_8 IF (K1.GT.K2) GO TO 50 DO 40 K=K1,K2 IW(IWFR) = IW(K) IWFR = IWFR + 1_8 40 CONTINUE 50 LWFR = K2 + 1_8 60 CONTINUE 70 RETURN END SUBROUTINE CMUMPS_ANA_D SUBROUTINE CMUMPS_ANA_LNEW(N, IPE, NV, IPS, NE, NA, NFSIZ, & NODE, NSTEPS, & FILS, FRERE, ND, NEMIN, SUBORD, KEEP60, & KEEP20, KEEP38, NAMALG,NAMALGMAX, & CUMUL,KEEP50, ICNTL13, KEEP37, KEEP197, NSLAVES, & ALLOW_AMALG_TINY_NODES & , BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS & , INODE_Scalapack_CAND, NBSONS_Scalapack_CAND & , KEEP11, KEEP191, KEEP192, KEEP193 & ) IMPLICIT NONE INTEGER N, NSTEPS, KEEP60, KEEP20, KEEP38, KEEP50 INTEGER ND(N), NFSIZ(N) INTEGER IPE(N), FILS(N), FRERE(N), SUBORD(N) INTEGER NV(N), IPS(N), NE(N), NA(N), NODE(N) INTEGER NEMIN,AMALG_COUNT INTEGER NAMALG(N),NAMALGMAX, CUMUL(N) DOUBLE PRECISION SIZE_DADI_AMALGAMATED, PERCENT_FILL DOUBLE PRECISION ACCU, FLOPS_FATHER, FLOPS_SON, & FLOPS_AVANT, FLOPS_APRES INTEGER ICNTL13, KEEP37, NSLAVES LOGICAL ALLOW_AMALG_TINY_NODES INTEGER KEEP197 LOGICAL, INTENT(IN) :: BLKON INTEGER, INTENT(IN) :: LSIZEOFBLOCKS INTEGER, INTENT(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) INTEGER, INTENT(OUT):: INODE_Scalapack_CAND, & NBSONS_Scalapack_CAND INTEGER, INTENT(IN) :: KEEP11, KEEP191, KEEP192, KEEP193 #if defined(NOAMALGTOFATHER) #else #endif INTEGER I,IF,IS,NR,INS INTEGER K,L,ISON,IN,IFSON,INO INTEGER INOS,IB,IL INTEGER IPERM INTEGER MAXNODE INTEGER SIZE_Scalapack_CAND, NBSONS_current_root LOGICAL ROOT_WITH_FEW_SONS #if defined(NOAMALGTOFATHER) INTEGER INB,INF,INFS,INL,INSW,INT1,NR1 #else INTEGER DADI #endif LOGICAL AMALG_TO_father_OK AMALG_COUNT = 0 INODE_Scalapack_CAND = -1 NBSONS_Scalapack_CAND = -1 SIZE_Scalapack_CAND = -1 NBSONS_current_root = 0 DO 10 I=1,N CUMUL(I)= 0 IPS(I) = 0 NE(I) = 0 SUBORD(I) = 0 NAMALG(I) = 0 10 CONTINUE DO I=1,N IF (BLKON) THEN NODE(I) = SIZEOFBLOCKS(I) ELSE NODE(I) = 1 ENDIF ENDDO FRERE(1:N) = IPE(1:N) NR = N + 1 MAXNODE = 1 DO 50 I=1,N IF = -FRERE(I) IF (NV(I).EQ.0) THEN IF (SUBORD(IF).NE.0) SUBORD(I) = SUBORD(IF) SUBORD(IF) = I IF (BLKON) THEN NODE(IF) = NODE(IF)+SIZEOFBLOCKS(I) ELSE NODE(IF) = NODE(IF)+1 ENDIF MAXNODE = max(NODE(IF),MAXNODE) ELSE IF (IF.NE.0) THEN IS = -IPS(IF) IF (IS.GT.0) FRERE(I) = IS IPS(IF) = -I ELSE NR = NR - 1 NE(NR) = I ENDIF ENDIF 50 CONTINUE MAXNODE = int(dble(MAXNODE)*dble(NEMIN) / dble(100)) MAXNODE = max(MAXNODE,2000) #if defined(NOAMALGTOFATHER) DO 999 I=1,N FILS(I) = IPS(I) 999 CONTINUE NR1 = NR INS = 0 1000 IF (NR1.GT.N) GO TO 1151 INS = NE(NR1) NR1 = NR1 + 1 1070 INL = FILS(INS) IF (INL.LT.0) THEN INS = -INL GO TO 1070 ENDIF 1080 IF (FRERE(INS).LT.0) THEN INS = -FRERE(INS) FILS(INS) = 0 GO TO 1080 ENDIF IF (FRERE(INS).EQ.0) THEN INS = 0 GO TO 1000 ENDIF INB = FRERE(INS) IF (NV(INB).GE.NV(INS)) THEN INS = INB GO TO 1070 ENDIF INF = INB 1090 INF = FRERE(INF) IF (INF.GT.0) GO TO 1090 INF = -INF INFS = -FILS(INF) IF (INFS.EQ.INS) THEN FILS(INF) = -INB IPS(INF) = -INB FRERE(INS) = FRERE(INB) FRERE(INB) = INS ELSE INSW = INFS 1100 INFS = FRERE(INSW) IF (INFS.NE.INS) THEN INSW = INFS GO TO 1100 ENDIF FRERE(INS) = FRERE(INB) FRERE(INB) = INS FRERE(INSW)= INB ENDIF INS = INB GO TO 1070 1151 CONTINUE #endif DO 51 I=1,N FILS(I) = IPS(I) 51 CONTINUE IS = 1 I = 0 IPERM = 1 DO 160 K=1,N AMALG_TO_father_OK=.FALSE. IF (I.LE.0) THEN IF (NR.GT.N) EXIT I = NE(NR) NE(NR) = 0 NR = NR + 1 IL = N NA(N) = 0 NBSONS_current_root =0 IF (IPS(I).LT.0) THEN IB = -IPS(I) NBSONS_current_root = NBSONS_current_root + 1 69 IB =FRERE(IB) IF (IB.GT.0) THEN NBSONS_current_root = NBSONS_current_root + 1 GOTO 69 ENDIF ENDIF 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 DADI = -IPE(I) IF (DADI.EQ.0) THEN IF (NV(I) .GT. SIZE_Scalapack_CAND) THEN INODE_Scalapack_CAND = I SIZE_Scalapack_CAND = NV(I) ENDIF ENDIF #if ! defined(NOAMALGTOFATHER) IF ( (DADI.NE.0) .AND. & ( & (KEEP60.EQ.0).OR. & ( (KEEP20.NE.DADI).AND.(KEEP38.NE.DADI) ) & ) & ) THEN ACCU = dble(2)*dble(NODE(I))*dble(NV(DADI)-NV(I)+NODE(I)) SIZE_DADI_AMALGAMATED = & dble(NV(DADI)+NODE(I)) * & dble(NV(DADI)+NODE(I)) PERCENT_FILL = dble(100) * ACCU / SIZE_DADI_AMALGAMATED ACCU = ACCU + dble(CUMUL(I)) AMALG_TO_father_OK = ( & ( (NODE(I).LE.MAXNODE).AND.(NODE(DADI).LE.MAXNODE) ) & .OR. & ( (NODE(I).LE.NEMIN.and. NODE(DADI).GT. MAXNODE) & .OR.(NODE(DADI).LE.NEMIN .and. NODE(I).GT.MAXNODE))) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( PERCENT_FILL < dble(NEMIN) ) ) IF (KEEP197 .EQ. 1 ) THEN AMALG_TO_father_OK = AMALG_TO_father_OK.OR. & ( NODE(I).LE.2*NEMIN .AND. NODE(DADI).LT.4*NEMIN) ENDIF AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( ACCU / SIZE_DADI_AMALGAMATED .LE. dble(NEMIN)) ) IF (AMALG_TO_father_OK) THEN CALL MUMPS_GET_FLOPS_COST(NV(I),NODE(I),NODE(I), & KEEP50,1,FLOPS_SON) CALL MUMPS_GET_FLOPS_COST(NV(DADI),NODE(DADI), & NODE(DADI), & KEEP50,1,FLOPS_FATHER) FLOPS_AVANT = FLOPS_FATHER+FLOPS_SON & + max(dble(200.0) * dble(NV(I)-NODE(I)) & * dble(NV(I)-NODE(I)), & dble(10000.0)) CALL MUMPS_GET_FLOPS_COST(NV(DADI)+NODE(I), & NODE(DADI)+NODE(I), & NODE(DADI)+NODE(I), & KEEP50,1,FLOPS_APRES) IF (FLOPS_APRES.GT.FLOPS_AVANT* & (dble(1)+dble(max(8,NEMIN)-8)/dble(100))) THEN AMALG_TO_father_OK = .FALSE. ENDIF ENDIF ROOT_WITH_FEW_SONS =.TRUE. IF (KEEP11.GT.0) THEN IF (IPE(DADI).EQ.0) THEN IF & (NA(IL)+max(NA(IL+1),NBSONS_current_root) & .GT.KEEP11) & ROOT_WITH_FEW_SONS= .FALSE. ELSE IF & (NA(IL)+NA(IL+1)+max(NA(N),NBSONS_current_root) & .GT.KEEP11) & ROOT_WITH_FEW_SONS= .FALSE. ENDIF ENDIF IF ( (NV(I).GT. max(KEEP191,1)*NV(DADI)) & .AND. (NSLAVES.GT.1) & .AND. (ICNTL13.LE.0) & .AND. (NV(I).GT. KEEP37) & .AND. ROOT_WITH_FEW_SONS & ) THEN IF ( ( ACCU / SIZE_DADI_AMALGAMATED ) .LT. & 10.0D0/dble(max(KEEP191,1)) ) THEN AMALG_TO_father_OK = .TRUE. ENDIF ENDIF IF ( ALLOW_AMALG_TINY_NODES .AND. & (NODE(I)*max(KEEP192,1)) .LE. (NV(DADI)-NAMALG(DADI)) ) & THEN IF ( NAMALG(DADI) < & (NV(DADI)-NAMALG(DADI))/max(KEEP193,1) ) THEN AMALG_TO_father_OK = .TRUE. NAMALG(DADI) = NAMALG(DADI) + NODE(I) ENDIF ENDIF IF ( DADI .EQ. -FRERE(I) & .AND. -FILS(DADI).EQ.I & ) THEN AMALG_TO_father_OK = ( AMALG_TO_father_OK .OR. & ( NV(I)-NODE(I).EQ.NV(DADI)) ) ENDIF IF (AMALG_TO_father_OK) THEN CUMUL(DADI)=CUMUL(DADI)+nint(ACCU) NAMALG(DADI) = NAMALG(DADI) + NAMALG(I) AMALG_COUNT = AMALG_COUNT+1 IN = DADI 75 IF (SUBORD(IN).EQ.0) GOTO 76 IN = SUBORD(IN) GOTO 75 76 CONTINUE SUBORD(IN) = I NV(I) = 0 IFSON = -FILS(DADI) IF (IFSON.EQ.I) THEN IF (FILS(I).LT.0) THEN FILS(DADI) = FILS(I) GOTO 78 ELSE IF (FRERE(I).GT.0) THEN FILS(DADI) = -FRERE(I) ELSE FILS(DADI) = 0 ENDIF GOTO 90 ENDIF ENDIF IN = IFSON 77 INS = IN IN = FRERE(IN) IF (IN.NE.I) GOTO 77 IF (FILS(I) .LT.0) THEN FRERE(INS) = -FILS(I) ELSE FRERE(INS) = FRERE(I) GOTO 90 ENDIF 78 CONTINUE IN = -FILS(I) 79 INO = IN IN = FRERE(IN) IF (IN.GT.0) GOTO 79 FRERE(INO) = FRERE(I) 90 CONTINUE NODE(DADI) = NODE(DADI)+ NODE(I) NV(DADI) = NV(DADI) + NODE(I) NA(IL+1) = NA(IL+1) + NA(IL) GOTO 120 ENDIF ENDIF #endif NE(IS) = NE(IS) + NODE(I) IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1 NA(IS) = NA(IL) ND(IS) = NV(I) NODE(I) = IS IPS(I) = IPERM IPERM = IPERM + 1 IN = I 777 IF (SUBORD(IN).EQ.0) GO TO 778 IN = SUBORD(IN) NODE(IN) = IS IPS(IN) = IPERM IPERM = IPERM + 1 GO TO 777 778 IF (NA(IS).LE.0) GO TO 110 #if defined(NOAMALGTOFATHER) IF ( (KEEP60.NE.0).AND. & (NE(IS).EQ.ND(IS)) ) GOTO 110 IF (ND(IS-1)-NE(IS-1).EQ.ND(IS)) THEN GO TO 100 ENDIF IF(NAMALG(IS-1) .GE. NAMALGMAX) THEN GOTO 110 ENDIF IF ((NE(IS-1).GE.NEMIN).AND. & (NE(IS).GE.NEMIN) ) GO TO 110 IF (2*NE(IS-1)*(ND(IS)-ND(IS-1)+NE(IS-1)).GE. & ((ND(IS)+NE(IS-1))* & (ND(IS)+NE(IS-1))*NEMIN/100)) GO TO 110 NAMALG(IS-1) = NAMALG(IS-1)+1 100 NA(IS-1) = NA(IS-1) + NA(IS) - 1 ND(IS-1) = ND(IS) + NE(IS-1) NE(IS-1) = NE(IS) + NE(IS-1) NE(IS) = 0 NODE(I) = IS-1 IFSON = -FILS(I) IN = IFSON 102 INO = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 102 NV(INO) = 0 IN = I 888 IF (SUBORD(IN).EQ.0) GO TO 889 IN = SUBORD(IN) GO TO 888 889 SUBORD(IN) = INO INOS = -FILS(INO) IF (IFSON.EQ.INO) THEN FILS(I) = -INOS GO TO 107 ENDIF IN = IFSON 105 INS = IN IN = FRERE(IN) IF (IN.NE.INO) GO TO 105 IF (INOS.EQ.0) THEN FRERE(INS) = -I GO TO 120 ELSE FRERE(INS) = INOS ENDIF 107 IN = INOS IF (IN.EQ.0) GO TO 120 108 INT1 = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 108 FRERE(INT1) = -I GO TO 120 #endif 110 IS = IS + 1 120 IB = FRERE(I) IF (IB.GE.0) THEN IF (IB.GT.0) NA(IL) = 0 I = IB ELSE I = -IB IL = IL + 1 ENDIF 160 CONTINUE NSTEPS = IS - 1 I = INODE_Scalapack_CAND INOS = -FILS(I) NBSONS_Scalapack_CAND = 0 IF (INOS.GT.0) THEN NBSONS_Scalapack_CAND = NBSONS_Scalapack_CAND+1 INO = FRERE(INOS) DO WHILE (INO.GT.0 .AND. INO.LE.N) NBSONS_Scalapack_CAND = NBSONS_Scalapack_CAND+1 INO = FRERE(INO) ENDDO ENDIF DO I=1, N IF (NV(I).EQ.0) THEN FRERE(I) = N+1 NFSIZ(I) = 0 ELSE NFSIZ(I) = ND(NODE(I)) IF (SUBORD(I) .NE.0) THEN INOS = -FILS(I) INO = I DO WHILE (SUBORD(INO).NE.0) IS = SUBORD(INO) FILS(INO) = IS INO = IS END DO FILS(INO) = -INOS ENDIF ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_ANA_LNEW SUBROUTINE CMUMPS_ANA_M(NE, ND, NSTEPS, & MAXFR, MAXELIM, K50, SIZEFAC_TOT, MAXNPIV, & K5,K6,PANEL_SIZE,K253) IMPLICIT NONE INTEGER, INTENT(in) :: NSTEPS, K50, K253, K5, K6 INTEGER, INTENT(in) :: NE(NSTEPS), ND(NSTEPS) INTEGER, INTENT(out) :: MAXNPIV, PANEL_SIZE INTEGER, INTENT(out) :: MAXFR, MAXELIM INTEGER(8), INTENT(out):: SIZEFAC_TOT INTEGER ITREE, NFR, NELIM INTEGER LKJIB INTEGER(8) :: SIZEFAC LKJIB = max(K5,K6) MAXFR = 0 MAXELIM = 0 MAXNPIV = 0 PANEL_SIZE = 0 SIZEFAC_TOT = 0_8 DO ITREE=1,NSTEPS NELIM = NE(ITREE) NFR = ND(ITREE) + K253 IF (NFR.GT.MAXFR) MAXFR = NFR IF (NFR-NELIM.GT.MAXELIM) MAXELIM = NFR - NELIM IF (NELIM .GT. MAXNPIV) THEN MAXNPIV = NELIM ENDIF IF (K50.EQ.0) THEN SIZEFAC = (2_8*int(NFR,8) - int(NELIM,8))*int(NELIM,8) PANEL_SIZE = max(PANEL_SIZE, NFR*(LKJIB+1)) ELSE SIZEFAC = int(NFR,8) * int(NELIM,8) PANEL_SIZE = max(PANEL_SIZE, NELIM*(LKJIB+1)) PANEL_SIZE = max(PANEL_SIZE, (NFR-NELIM)*(LKJIB+1)) ENDIF SIZEFAC_TOT = SIZEFAC_TOT + SIZEFAC END DO RETURN END SUBROUTINE CMUMPS_ANA_M SUBROUTINE CMUMPS_ANA_R( N, FILS, FRERE, & NSTK, NA ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: FILS(N), FRERE(N) INTEGER, INTENT(OUT) :: NSTK(N), NA(N) INTEGER NBROOT, NBLEAF, ILEAF, I, IN, ISON NA = 0 NSTK = 0 NBROOT = 0 ILEAF = 1 DO 11 I=1,N IF (FRERE(I).EQ. N+1) CYCLE IF (FRERE(I).EQ.0) NBROOT = NBROOT + 1 IN = I 12 IN = FILS(IN) IF (IN.GT.0) GO TO 12 IF (IN.EQ.0) THEN NA(ILEAF) = I ILEAF = ILEAF + 1 CYCLE ENDIF ISON = -IN 13 NSTK(I) = NSTK(I) + 1 ISON = FRERE(ISON) IF (ISON.GT.0) GO TO 13 11 CONTINUE NBLEAF = ILEAF-1 IF (N.GT.1) THEN IF (NBLEAF.GT.N-2) THEN IF (NBLEAF.EQ.N-1) THEN NA(N-1) = -NA(N-1)-1 NA(N) = NBROOT ELSE NA(N) = -NA(N)-1 ENDIF ELSE NA(N-1) = NBLEAF NA(N) = NBROOT ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_ANA_R SUBROUTINE CMUMPS_DIAG_ANA &( MYID, COMM, KEEP,KEEP8, INFO, INFOG, RINFO, RINFOG, ICNTL, & SIZE_SCHUR ) IMPLICIT NONE INTEGER, INTENT(IN) :: COMM, MYID, KEEP(500), INFO(80), & ICNTL(60), INFOG(80), SIZE_SCHUR INTEGER(8), INTENT(IN) :: KEEP8(150) REAL, INTENT(IN) :: RINFO(40), RINFOG(40) INCLUDE 'mpif.h' INTEGER MASTER, MPG INTEGER ITMP, ICNTL48_EFF PARAMETER( MASTER = 0 ) MPG = ICNTL(3) IF ( MYID.eq.MASTER.and.MPG.GT.0.AND.ICNTL(4).GE.2) THEN ITMP = KEEP(13) IF (ICNTL(15).EQ.0) THEN ITMP = 0 ENDIF IF (KEEP(400).GT.0) THEN ICNTL48_EFF=1 ELSE ICNTL48_EFF=0 ENDIF 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(95), ICNTL(13), KEEP(12), & ITMP, & ICNTL(18), KEEP(252), KEEP(494), & ICNTL48_EFF, & KEEP(106), & 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), SIZE_SCHUR IF (KEEP(251).GT.0) WRITE(MPG, 99997) KEEP(251) IF (KEEP(253).GT.0) WRITE(MPG, 99996) KEEP(253) ENDIF RETURN 99992 FORMAT(/'Leaving analysis phase with ...'/ & ' INFOG(1) =',I16/ & ' INFOG(2) =',I16/ & ' -- (20) Number of entries in factors (estim.) =',I16/ & ' -- (3) Real space for factors (estimated) =',I16/ & ' -- (4) Integer space for factors (estimated) =',I16/ & ' -- (5) Maximum frontal size (estimated) =',I16/ & ' -- (6) Number of nodes in the tree =',I16/ & ' -- (32) Type of analysis effectively used =',I16/ & ' -- (7) Ordering option effectively used =',I16/ & ' ICNTL (6) Maximum transversal option =',I16/ & ' ICNTL (7) Pivot order option =',I16/ & ' ICNTL(12) Ordering symmetric indef. matrices =',I16/ & ' ICNTL(13) Parallelism/splitting of root node =',I16/ & ' ICNTL(14) Percentage of memory relaxation =',I16/ & ' ICNTL(15) Analysis by block effectively used =',I16/ & ' ICNTL(18) Distributed input matrix (on if >0) =',I16/ & ' ICNTL(32) Forward elimination during facto. =',I16/ & ' ICNTL(35) BLR activation =',I16/ & ' ICNTL(48) Tree based multithreading (effective)=',I16/ & ' ICNTL(58) Symbolic factorization option =',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/ & ' Size of Schur (SIZE_SCHUR) =',I16) 99996 FORMAT(' Forward solution during factorization, NRHS =',I16) 99997 FORMAT(' ICNTL(31) Discard factors (eff. value) =',I16) END SUBROUTINE CMUMPS_DIAG_ANA SUBROUTINE CMUMPS_CUTNODES & ( N, FRERE, FILS, NFSIZ, SIZEOFBLOCKS, LSIZEOFBLOCKS, & NSTEPS, NSLAVES, & KEEP, KEEP8, SPLITROOT, MP, LDIAG, INFO1, INFO2 ) IMPLICIT NONE INTEGER N, NSTEPS, NSLAVES, KEEP(500) INTEGER(8) KEEP8(150) INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) INTEGER LSIZEOFBLOCKS INTEGER SIZEOFBLOCKS(LSIZEOFBLOCKS) LOGICAL SPLITROOT INTEGER MP, LDIAG INTEGER INFO1, INFO2 INTEGER, DIMENSION(:), ALLOCATABLE :: IPOOL INTEGER INODE, DEPTH, I, IBEG, IEND, IIPOOL, NROOT INTEGER MAX_DEPTH, ISON, TOT_CUT, MAX_CUT, STRAT INTEGER(8) :: K79 INTEGER K82, allocok LOGICAL BLKON BLKON = .NOT.(SIZEOFBLOCKS(1).EQ.-1) K79 = KEEP8(79) K82 = abs(KEEP(82)) STRAT= KEEP(62) IF (KEEP(210).EQ.1) THEN MAX_DEPTH = 2*NSLAVES*K82 STRAT = STRAT/4 ELSE IF (( NSLAVES .eq. 1 ).AND. (.NOT. SPLITROOT) ) RETURN IF (NSLAVES.EQ.1) THEN MAX_DEPTH=1 ELSE MAX_DEPTH = int( log( real( NSLAVES - 1 ) ) & / log(2.0E0) ) ENDIF ENDIF ALLOCATE(IPOOL(NSTEPS+1), stat=allocok) IF (allocok.GT.0) THEN INFO1= -7 INFO2= NSTEPS+1 RETURN ENDIF NROOT = 0 DO INODE = 1, N IF ( FRERE(INODE) .eq. 0 ) THEN NROOT = NROOT + 1 IPOOL( NROOT ) = INODE END IF END DO IBEG = 1 IEND = NROOT IIPOOL = NROOT + 1 IF (SPLITROOT) THEN MAX_DEPTH=0 ENDIF DO DEPTH = 1, MAX_DEPTH DO I = IBEG, IEND INODE = IPOOL( I ) ISON = INODE DO WHILE ( ISON .GT. 0 ) ISON = FILS( ISON ) END DO ISON = - ISON DO WHILE ( ISON .GT. 0 ) IPOOL( IIPOOL ) = ISON IIPOOL = IIPOOL + 1 ISON = FRERE( ISON ) END DO END DO IPOOL( IBEG ) = -IPOOL( IBEG ) IBEG = IEND + 1 IEND = IIPOOL - 1 END DO IPOOL( IBEG ) = -IPOOL( IBEG ) TOT_CUT = 0 IF (SPLITROOT) THEN MAX_CUT = NROOT*max(K82,2) IF (KEEP(72).EQ.1) THEN K79 = min(3_8*3_8,K79) ELSE K79 = min(2000_8*2000_8,K79) IF (KEEP(376) .EQ. 1) THEN K79 = min(int(KEEP(9)+1,8)*int(KEEP(9)+1,8),K79) ENDIF ENDIF IF (KEEP(53).NE.0) THEN K79 = 121_8*121_8 ENDIF ELSE MAX_CUT = 2 * NSLAVES IF (KEEP(210).EQ.1) THEN MAX_CUT = 4 * (MAX_CUT + 4) ENDIF ENDIF DEPTH = -1 DO I = 1, IIPOOL - 1 INODE = IPOOL( I ) IF ( INODE .LT. 0 ) THEN INODE = -INODE DEPTH = DEPTH + 1 END IF CALL CMUMPS_SPLIT_1NODE & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, & KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IF ( TOT_CUT > MAX_CUT ) EXIT END DO KEEP(61) = TOT_CUT DEALLOCATE(IPOOL) RETURN END SUBROUTINE CMUMPS_CUTNODES RECURSIVE SUBROUTINE CMUMPS_SPLIT_1NODE & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, KEEP,KEEP8, & TOT_CUT, STRAT, DEPTH, K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IMPLICIT NONE INTEGER(8) :: K79 INTEGER INODE, N, NSTEPS, NSLAVES, KEEP(500), STRAT, & DEPTH, TOT_CUT, MP, LDIAG INTEGER(8) KEEP8(150) INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) LOGICAL SPLITROOT LOGICAL BLKON INTEGER LSIZEOFBLOCKS INTEGER SIZEOFBLOCKS(LSIZEOFBLOCKS) INTEGER I, IN, NPIV, NFRONT, NSLAVES_ESTIM REAL WK_SLAVE, WK_MASTER INTEGER INODE_SON, INODE_FATH, IN_SON, IN_FATH, IN_GRANDFATH INTEGER NPIV_COMPG, NPIV_SON_COMPG, NPIV_FATH_COMPG INTEGER NPIV_SON, NPIV_FATH, NPIV_TEMP INTEGER NCB, NSLAVESMIN, NSLAVESMAX INTEGER MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX EXTERNAL MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX IF ( (KEEP(210).EQ.1.AND.KEEP(60).EQ.0) .OR. & (SPLITROOT) ) THEN IF ( FRERE ( INODE ) .eq. 0 ) THEN NFRONT = NFSIZ( INODE ) NPIV = NFRONT IF (BLKON) THEN IN = INODE NPIV_COMPG = 0 DO WHILE( IN > 0 ) NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) ENDDO ELSE NPIV_COMPG = NPIV ENDIF NCB = 0 IF ( int(NFRONT,8)*int(NFRONT,8).GT.K79 & ) THEN GOTO 333 ENDIF ENDIF ENDIF IF ( FRERE ( INODE ) .eq. 0 ) RETURN NFRONT = NFSIZ( INODE ) IN = INODE NPIV = 0 NPIV_COMPG = 0 DO WHILE( IN > 0 ) IF (BLKON) THEN NPIV = NPIV + SIZEOFBLOCKS(IN) ENDIF NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) END DO IF (.NOT.BLKON) NPIV = NPIV_COMPG NCB = NFRONT - NPIV IF ( (NFRONT - (NPIV/2)) .LE. KEEP(9)) RETURN IF ((KEEP(50) == 0.and.int(NFRONT,8) * int(NPIV,8) > K79 ) .OR. &(KEEP(50) .NE.0.and.int(NPIV,8) * int(NPIV,8) > K79 )) GOTO 333 IF (KEEP(210).EQ.1) THEN NSLAVESMIN = 1 NSLAVESMAX = 64 NSLAVES_ESTIM = 32+NSLAVES ELSE NSLAVESMIN = MUMPS_BLOC2_GET_NSLAVESMIN & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375), KEEP(119)) NSLAVESMAX = MUMPS_BLOC2_GET_NSLAVESMAX & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375), KEEP(119)) NSLAVES_ESTIM = max (1, & nint( real(NSLAVESMAX-NSLAVESMIN)/real(3) ) & ) NSLAVES_ESTIM = min (NSLAVES_ESTIM, NSLAVES-1) ENDIF IF ( KEEP(50) .eq. 0 ) THEN WK_MASTER = 0.6667E0 * & real(NPIV)*real(NPIV)*real(NPIV) + & real(NPIV)*real(NPIV)*real(NCB) WK_SLAVE = real( NPIV ) * real( NCB ) * & ( 2.0E0 * real(NFRONT) - real(NPIV) ) & / real(NSLAVES_ESTIM) ELSE WK_MASTER = real(NPIV)*real(NPIV)*real(NPIV) / real(3) WK_SLAVE = & (real(NPIV)*real(NCB)*real(NFRONT)) & / real(NSLAVES_ESTIM) ENDIF IF (KEEP(210).EQ.1) THEN IF ( real( 100 + STRAT ) & * WK_SLAVE / real(100) .GE. WK_MASTER ) RETURN ELSE IF ( real( 100 + STRAT * max( DEPTH-1, 1 ) ) & * WK_SLAVE / real(100) .GE. WK_MASTER ) RETURN ENDIF 333 CONTINUE IF (NPIV .LE. 1 ) RETURN NPIV_SON = max(NPIV/2,1) NPIV_FATH = NPIV - NPIV_SON IF (SPLITROOT) THEN IF (NCB .NE .0) THEN WRITE(*,*) "Error splitting" CALL MUMPS_ABORT() ENDIF NPIV_FATH = min(int(sqrt(real(K79))), int(NPIV/2)) NPIV_SON = NPIV - NPIV_FATH ENDIF INODE_SON = INODE IF (BLKON) THEN NPIV_TEMP = 0 NPIV_SON_COMPG = 0 IN_SON = INODE DO WHILE (IN_SON > 0) NPIV_TEMP = NPIV_TEMP + SIZEOFBLOCKS(IN_SON) NPIV_SON_COMPG = NPIV_SON_COMPG +1 IF (NPIV_TEMP.GE.NPIV_SON) EXIT IN_SON = FILS( IN_SON ) END DO NPIV_FATH_COMPG = NPIV_COMPG - NPIV_SON_COMPG NPIV_SON = NPIV_TEMP NPIV_FATH = NPIV - NPIV_SON ELSE NPIV_SON_COMPG = NPIV_SON NPIV_FATH_COMPG = NPIV_FATH IN_SON = INODE DO I = 1, NPIV_SON_COMPG - 1 IN_SON = FILS( IN_SON ) END DO ENDIF IF (NPIV_FATH_COMPG.EQ.0) RETURN NSTEPS = NSTEPS + 1 TOT_CUT = TOT_CUT + 1 INODE_FATH = FILS( IN_SON ) IF ( INODE_FATH .LT. 0 ) THEN write(*,*) 'Error: INODE_FATH < 0 ', INODE_FATH END IF IN_FATH = INODE_FATH DO WHILE ( FILS( IN_FATH ) > 0 ) IN_FATH = FILS( IN_FATH ) END DO FRERE( INODE_FATH ) = FRERE( INODE_SON ) FRERE( INODE_SON ) = - INODE_FATH FILS ( IN_SON ) = FILS( IN_FATH ) FILS ( IN_FATH ) = - INODE_SON IN = FRERE( INODE_FATH ) DO WHILE ( IN > 0 ) IN = FRERE( IN ) END DO IF ( IN .eq. 0 ) GO TO 10 IN = -IN DO WHILE ( FILS( IN ) > 0 ) IN = FILS( IN ) END DO IN_GRANDFATH = IN IF ( FILS( IN_GRANDFATH ) .eq. - INODE_SON ) THEN FILS( IN_GRANDFATH ) = -INODE_FATH ELSE IN = IN_GRANDFATH IN = - FILS ( IN ) DO WHILE ( FRERE( IN ) > 0 ) IF ( FRERE( IN ) .eq. INODE_SON ) THEN FRERE( IN ) = INODE_FATH GOTO 10 END IF IN = FRERE( IN ) END DO WRITE(*,*) 'ERROR 2 in SPLIT NODE', & IN_GRANDFATH, IN, FRERE(IN) END IF 10 CONTINUE NFSIZ(INODE_SON) = NFRONT NFSIZ(INODE_FATH) = NFRONT - NPIV_SON KEEP(2) = max( KEEP(2), NFRONT - NPIV_SON ) IF (SPLITROOT) THEN RETURN ENDIF CALL CMUMPS_SPLIT_1NODE & ( INODE_FATH, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IF (.NOT. SPLITROOT) THEN CALL CMUMPS_SPLIT_1NODE & ( INODE_SON, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) ENDIF RETURN END SUBROUTINE CMUMPS_SPLIT_1NODE SUBROUTINE CMUMPS_SPLIT_ROOT & ( NSLAVES, HOW, INODE, N, FRERE, FILS, NFSIZ, KEEP, KEEP8, & SIZEOFBLOCKS, LSIZEOFBLOCKS, NSTEPS) IMPLICIT NONE INTEGER, INTENT(in) :: NSLAVES, HOW INTEGER, INTENT(in) :: INODE, N INTEGER(8), INTENT(in) :: KEEP8(150) INTEGER, INTENT(inout) :: NSTEPS INTEGER, INTENT(inout) :: KEEP(500) INTEGER, INTENT(inout) :: FRERE( N ), FILS( N ), NFSIZ( N ) INTEGER, INTENT(IN) :: LSIZEOFBLOCKS INTEGER, INTENT(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) LOGICAL :: BLKON INTEGER(8) :: K79 INTEGER I, IN, NPIV, NFRONT INTEGER INODE_SON, INODE_FATH, IN_SON, IN_FATH, IN_GRANDFATH INTEGER NPIV_COMPG, NPIV_SON_COMPG, NPIV_FATH_COMPG INTEGER NPIV_SON, NPIV_FATH, NPIV_TEMP INTEGER, PARAMETER :: K_HOW1 = 4000 IF (FRERE(INODE).NE.0) RETURN BLKON = .NOT.(SIZEOFBLOCKS(1).EQ.-1) K79 = max(KEEP8(79), 4_8) K79 = min(20000_8*20000_8,K79) IF (KEEP(72).EQ.1) THEN K79 = min(3_8*3_8,K79) ENDIF IF ((HOW.LT.1) .OR. (HOW.GT.3)) THEN RETURN ENDIF IF (HOW.EQ.2) THEN K79 = min(K79, 121_8*121_8) ENDIF NFRONT = NFSIZ (INODE) NPIV = NFRONT IF (NPIV .LE. 1 ) RETURN IF (BLKON) THEN IN = INODE NPIV_COMPG = 0 DO WHILE( IN > 0 ) NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) ENDDO ELSE NPIV_COMPG = NPIV ENDIF IF (HOW.EQ.1) THEN IF ( (NFRONT/2) .LT. K_HOW1 ) RETURN NPIV_FATH = max(NFRONT/max(NSLAVES,2), 1) NPIV_FATH = max(NPIV_FATH, K_HOW1/2) NPIV_FATH = min(NPIV_FATH, max(NFRONT/2,1)) NPIV_FATH = min(int(sqrt(real(K79))), NPIV_FATH) NPIV_SON = NPIV - NPIV_FATH ELSE IF (HOW.EQ.2) THEN NPIV_FATH = min(int(sqrt(real(K79))), int(NPIV/2)) NPIV_SON = NPIV - NPIV_FATH ELSE NPIV_FATH = max(NFRONT - 3*KEEP(6),1) NPIV_SON = NPIV - NPIV_FATH ENDIF INODE_SON = INODE IF (BLKON) THEN NPIV_TEMP = 0 NPIV_SON_COMPG = 0 IN_SON = INODE DO WHILE (IN_SON > 0) NPIV_TEMP = NPIV_TEMP + SIZEOFBLOCKS(IN_SON) NPIV_SON_COMPG = NPIV_SON_COMPG +1 IF (NPIV_TEMP.GE.NPIV_SON) EXIT IN_SON = FILS( IN_SON ) END DO NPIV_FATH_COMPG = NPIV_COMPG - NPIV_SON_COMPG NPIV_SON = NPIV_TEMP NPIV_FATH = NPIV - NPIV_SON ELSE NPIV_SON_COMPG = NPIV_SON NPIV_FATH_COMPG = NPIV_FATH IN_SON = INODE DO I = 1, NPIV_SON_COMPG - 1 IN_SON = FILS( IN_SON ) END DO ENDIF IF (NPIV_FATH_COMPG.EQ.0) RETURN 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 ) NSTEPS = NSTEPS + 1 IF ( (KEEP(53).EQ.0) .AND. NSLAVES.GT.1) THEN KEEP(38) = INODE_FATH ENDIF IF ( KEEP(53).NE.0 ) THEN KEEP(20) = INODE_FATH ENDIF RETURN END SUBROUTINE CMUMPS_SPLIT_ROOT SUBROUTINE CMUMPS_ANA_GNEW & (N, NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, NBQD, AvgDens, & KEEP264, KEEP265, PRINTSTAT, & INPLACE64_GRAPH_COPY & ) IMPLICIT NONE INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) INTEGER, intent(inout) :: IERROR INTEGER, intent(out) :: symmetry INTEGER, intent(out) :: NBQD, AvgDens INTEGER, intent(out) :: LEN(N), IW(LW) INTEGER(8), intent(out):: IWFR INTEGER(8), intent(out):: NRORM, NIORM INTEGER(8), intent(out):: IPE(N+1) INTEGER, intent(inout) :: IFLAG, KEEP264, KEEP265 INTEGER(8), intent(out):: IQ(N) INTEGER, intent(out) :: FLAG(N) LOGICAL, intent(in) :: PRINTSTAT LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, MPG, I, J, N1 INTEGER :: NBERR, THRESH, IERROR_LOC INTEGER(8) :: K8, K1, K2, LAST, NDUP INTEGER(8) :: NZOFFA, NDIAGA, L, N8 REAL :: RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) NZOFFA = 0_8 NDIAGA = 0 IERROR_LOC = 0 N8 = int(N,8) DO I=1,N+1 IPE(I) = 0_8 ENDDO IF (KEEP264.EQ.0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR_LOC = IERROR_LOC + 1 ELSE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR_LOC = IERROR_LOC + 1 ELSE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.EQ.J) THEN NDIAGA = NDIAGA + 1_8 ELSE IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDDO ENDIF ENDIF NIORM = NZOFFA + 3_8*N8 IF ((IERROR_LOC.GE.1).AND.(mod(IFLAG,2) .EQ. 0)) THEN IFLAG = IFLAG+1 IERROR = IERROR_LOC IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN NBERR = 0 WRITE (MP,99999) DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR. & (10_8.LE.K8 .AND. K8.LE.20_8)) THEN WRITE (MP,'(I16,A,I10,A,I10,A)') & K8,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K8,10_8).EQ.1_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'st entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.2_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.3_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE EXIT ENDIF ENDIF ENDDO ENDIF ENDIF NRORM = NIORM - 2_8*N8 IQ(1) = 1_8 N1 = N - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(N)+IQ(N)-1,IQ(N)) FLAG(1:N) = 0 IPE(1:N) = IQ(1:N) IW(1:LAST) = 0 IWFR = LAST + 1_8 IF (KEEP264 .EQ. 0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF (I.LT.J) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDDO ENDIF ENDIF IF (KEEP265.EQ.0) THEN NDUP = 0_8 DO I=1,N K1 = IPE(I) K2 = IQ(I) - 1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) EXIT IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE L = IQ(J) IW(L) = I IQ(J) = L + 1 IW(K8) = J FLAG(J) = I ENDIF END DO LEN(I) = int((IQ(I) - IPE(I))) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,N IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K1 = IPE(I) K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF 270 CONTINUE LEN(I) = int(IWFR - L) ENDDO ELSE KEEP265 = 1 ENDIF IPE(N+1) = IPE(N) + int(LEN(N),8) IWFR = IPE(N+1) ELSE IPE(1) = 1_8 DO I = 1, N LEN(I) = int(IQ(I) - IPE(I)) ENDDO DO I = 1, N IPE(I+1) = IPE(I) + int(LEN(I),8) ENDDO IWFR = IPE(N+1) ENDIF symmetry = 100 IF (SYM.EQ.0) THEN RSYM = real(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/ & real(NZOFFA+NDIAGA) IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) & THEN KEEP265 = -1 ENDIF symmetry = min(nint (100.0E0*RSYM), 100) IF (PRINTSTAT) THEN IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) ) & write(MPG,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) ) & write(MP,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry ENDIF ELSE ENDIF AvgDens = nint(real(IWFR-1_8)/real(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN DO I= 1, N J = max(LEN(I),1) IF (J.GT.THRESH) NBQD = NBQD+1 ENDDO ENDIF INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1_8)) IF (PRINTSTAT) THEN IF (MPG .GT. 0.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2)) & write(MP,'(A,1I5)') & ' Average density of rows/columns =', AvgDens ENDIF RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE CMUMPS_ANA_GNEW SUBROUTINE CMUMPS_SET_K821_SURFACE & (KEEP821, KEEP2, KEEP48 ,KEEP50, NSLAVES) IMPLICIT NONE INTEGER NSLAVES, KEEP2, KEEP48, KEEP50 INTEGER (8) :: KEEP821 INTEGER(8) KEEP2_SQUARE, NSLAVES8 NSLAVES8= int(NSLAVES,8) KEEP2_SQUARE = int(KEEP2,8) * int(KEEP2,8) KEEP821 = max(KEEP821*int(KEEP2,8),1_8) #if defined(t3e) KEEP821 = min(1500000_8, KEEP821) #elif defined(SP_) KEEP821 = min(3000000_8, KEEP821) #else KEEP821 = min(2000000_8, KEEP821) #endif #if defined(t3e) IF (NSLAVES .GT. 64) THEN KEEP821 = & min(8_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ELSE KEEP821 = & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ENDIF #else IF (NSLAVES.GT.64) THEN KEEP821 = & min(6_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ELSE KEEP821 = & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ENDIF #endif IF (KEEP50 .EQ. 0 ) THEN KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) ELSE KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) ENDIF IF (KEEP50 .EQ. 0 ) THEN #if defined(t3e) KEEP821 = max(KEEP821,200000_8) #else KEEP821 = max(KEEP821,300000_8) #endif ELSE #if defined(t3e) KEEP821 = max(KEEP821,40000_8) #else KEEP821 = max(KEEP821,80000_8) #endif ENDIF KEEP821 = -KEEP821 RETURN END SUBROUTINE CMUMPS_SET_K821_SURFACE SUBROUTINE CMUMPS_MTRANS_DRIVER(JOB,M,N,NE, & IP,IRN,A,LA,NUM,PERM,LIW,IW,LDW,DW, & IPQ8, & ICNTL,CNTL,INFO, INFOMUMPS) IMPLICIT NONE INTEGER :: NICNTL, NCNTL, NINFO, INFOMUMPS(80) PARAMETER (NICNTL=10, NCNTL=10, NINFO=10) INTEGER :: JOB,M,N,NUM INTEGER(8), INTENT(IN) :: NE, LIW,LDW, LA INTEGER(8) :: IP(N+1), IPQ8(N) INTEGER :: IRN(NE),PERM(M),IW(LIW) INTEGER :: ICNTL(NICNTL),INFO(NINFO) REAL :: A(LA) REAL :: DW(LDW),CNTL(NCNTL) INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWtemp8 INTEGER :: allocok INTEGER :: I,J,WARN1,WARN2,WARN4 INTEGER(8) :: K REAL :: FACT,ZERO,ONE,RINF,RINF2,RINF3 PARAMETER (ZERO=0.0E+00,ONE=1.0E+0) EXTERNAL CMUMPS_MTRANSZ,CMUMPS_MTRANSB,CMUMPS_MTRANSR, & CMUMPS_MTRANSS,CMUMPS_MTRANSW INTRINSIC abs,log RINF = CNTL(2) RINF2 = huge(RINF2)/real(int(2,8)*int(N,8)) RINF3 = 0.0E0 WARN1 = 0 WARN2 = 0 WARN4 = 0 IF (JOB.LT.1 .OR. JOB.GT.6) THEN INFO(1) = -1 INFO(2) = JOB IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'JOB',JOB GO TO 99 ENDIF IF (M.LT.1 .OR. M.LT.N) THEN INFO(1) = -2 INFO(2) = M IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'M',M GO TO 99 ENDIF IF (N.LT.1) THEN INFO(1) = -2 INFO(2) = N IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'N',N GO TO 99 ENDIF IF (NE.LT.1) THEN INFO(1) = -3 CALL MUMPS_SET_IERROR(NE,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'NE',NE GO TO 99 ENDIF IF (JOB.EQ.1) K = 4_8*int(N,8)+int(M,8) IF (JOB.EQ.2) K = int(N,8) + 2_8*int(M,8) IF (JOB.EQ.3) K = 8_8*int(N,8) + 2*int(M,8) + NE IF (JOB.EQ.4) K = int(N,8) + int(M,8) IF (JOB.EQ.5) K = 3_8*int(N,8) + 2_8*int(M,8) IF (JOB.EQ.6) K = 3_8*int(N,8) + 2_8*int(M,8) + NE IF (LIW.LT.K) THEN INFO(1) = -4 CALL MUMPS_SET_IERROR(K,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9004) INFO(1),K GO TO 99 ENDIF IF (JOB.GT.1) THEN IF (JOB.EQ.2) K = int(M,8) IF (JOB.EQ.3) K = int(1,8) IF (JOB.EQ.4) K = 2_8*int(M,8) IF (JOB.EQ.5) K = int(N,8) + 2_8*int(M,8) IF (JOB.EQ.6) K = int(N,8) + 3_8*int(M,8) IF (LDW .LT. K) THEN INFO(1) = -5 CALL MUMPS_SET_IERROR(K,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9005) INFO(1),K GO TO 99 ENDIF ENDIF IF (ICNTL(5).EQ.0) THEN DO 3 I = 1,M IW(I) = 0 3 CONTINUE DO 6 J = 1,N DO 4 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (I.LT.1 .OR. I.GT.M) THEN INFO(1) = -6 INFO(2) = J IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9006) INFO(1),J,I GO TO 99 ENDIF IF (IW(I).EQ.J) THEN INFO(1) = -7 INFO(2) = J IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9007) INFO(1),J,I GO TO 99 ELSE IW(I) = J ENDIF 4 CONTINUE 6 CONTINUE ENDIF IF (ICNTL(3).GT.0) THEN IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9020) JOB,M,N,NE IF (ICNTL(4).EQ.0) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,min(10,N+1)) WRITE(ICNTL(3),9022) (IRN(K),K=1_8,min(10_8,NE)) IF (JOB.GT.1) WRITE(ICNTL(3),9023) & (A(K),K=1_8,min(10_8,NE)) ELSEIF (ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,N+1) WRITE(ICNTL(3),9022) (IRN(K),K=1_8,NE) IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(K),K=1_8,NE) ENDIF WRITE(ICNTL(3),9024) (ICNTL(J),J=1,NICNTL) WRITE(ICNTL(3),9025) (CNTL(J),J=1,NCNTL) ENDIF ENDIF DO 8 I=1,NINFO INFO(I) = 0 8 CONTINUE IF (JOB.EQ.1) THEN DO 10 J = 1,N IW(J) = int(IP(J+1) - IP(J)) 10 CONTINUE CALL CMUMPS_MTRANSZ(M,N,IRN,NE,IP,IW(1),PERM,NUM, & IW( int(N,8)+1_8), & IW(2_8*int(N,8)+1_8), & IW(3_8*int(N,8)+1_8), & IW(3_8*int(N,8)+int(M,8)+1_8)) GO TO 90 ENDIF IF (JOB.EQ.2) THEN DW(1) = max(ZERO,CNTL(1)) CALL CMUMPS_MTRANSB(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IPQ8,IW(int(N,8)+1_8), & IW(int(N,8)+int(M,8)+1_8), & DW,RINF2) GO TO 90 ENDIF IF (JOB.EQ.3) THEN DO 20 K = 1,NE IW(K) = IRN(K) 20 CONTINUE CALL CMUMPS_MTRANSR(N,NE,IP,IW,A) FACT = max(ZERO,CNTL(1)) CALL CMUMPS_MTRANSS(M,N,NE,IP,IW(1),A,PERM,NUM,IW(NE+1_8), & IW(NE+int(N,8)+1_8),IW(NE+2_8*int(N,8)+1_8), & IW(NE+3_8*int(N,8)+1_8), & IW(NE+4_8*int(N,8)+1_8), & IW(NE+5_8*int(N,8)+1_8), & IW(NE+5_8*int(N,8)+int(M,8)+1_8), & FACT,RINF2) GO TO 90 ENDIF IF ((JOB.EQ.4).OR.(JOB.EQ.5).or.(JOB.EQ.6)) THEN ALLOCATE(IWtemp8(int(M,8)+int(N,8)+int(N,8)), stat=allocok) IF (allocok.GT.0) THEN INFOMUMPS(1) = -7 CALL MUMPS_SET_IERROR( int(M,8)+int(N,8)+int(N,8), & INFOMUMPS(2) ) GOTO 90 ENDIF ENDIF IF (JOB.EQ.4) THEN DO 50 J = 1,N FACT = ZERO DO 30 K = IP(J),IP(J+1)-1_8 IF (abs(A(K)).GT.FACT) FACT = abs(A(K)) 30 CONTINUE IF(FACT .GT. RINF3) RINF3 = FACT DO 40 K = IP(J),IP(J+1)-1_8 A(K) = FACT - abs(A(K)) 40 CONTINUE 50 CONTINUE DW(1) = max(ZERO,CNTL(1)) DW(2) = RINF3 IWtemp8(1) = int(JOB,8) CALL CMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(int(N,8)+1_8),IPQ8, & IW(int(N,8)+1_8), & IWtemp8(2_8*int(N,8)+1_8), & DW(1),DW(int(M,8)+1_8),RINF2) DEALLOCATE(IWtemp8) GO TO 90 ENDIF IF (JOB.EQ.5 .or. JOB.EQ.6) THEN RINF3=ONE IF (JOB.EQ.5) THEN DO 75 J = 1,N FACT = ZERO DO 60 K = IP(J),IP(J+1)-1_8 IF (A(K).GT.FACT) FACT = A(K) 60 CONTINUE DW(2_8*int(M,8)+int(J,8)) = FACT IF (FACT.NE.ZERO) THEN FACT = log(FACT) IF(FACT .GT. RINF3) RINF3=FACT DO 70 K = IP(J),IP(J+1)-1_8 IF (A(K).NE.ZERO) THEN A(K) = FACT - log(A(K)) IF(A(K) .GT. RINF3) RINF3=A(K) ELSE A(K) = FACT + RINF ENDIF 70 CONTINUE ELSE DO 71 K = IP(J),IP(J+1)-1_8 A(K) = ONE 71 CONTINUE ENDIF 75 CONTINUE ENDIF IF (JOB.EQ.6) THEN DO 175 K = 1,NE IW(3_8*int(N,8)+2_8*int(M,8)+int(K,8)) = IRN(K) 175 CONTINUE DO 61 I = 1,M DW(2_8*int(M,8)+int(N,8)+int(I,8)) = ZERO 61 CONTINUE DO 63 J = 1,N DO 62 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (A(K).GT.DW(2_8*int(M,8)+int(N,8)+int(I,8))) THEN DW(2_8*int(M,8)+int(N,8)+int(I,8)) = A(K) ENDIF 62 CONTINUE 63 CONTINUE DO 64 I = 1,M IF (DW(2_8*int(M,8)+int(N,8)+int(I,8)).NE.ZERO) THEN DW(2_8*int(M,8)+int(N,8)+int(I,8)) = & 1.0E0/DW(2_8*int(M,8)+int(N,8)+int(I,8)) ENDIF 64 CONTINUE DO 66 J = 1,N DO 65 K = IP(J),IP(J+1)-1 I = IRN(K) A(K) = DW(2_8*int(M,8)+int(N,8)+int(I,8)) * A(K) 65 CONTINUE 66 CONTINUE CALL CMUMPS_MTRANSR(N,NE,IP, & IW(3_8*int(N,8)+2_8*int(M,8)+1_8),A) DO 176 J = 1,N IF (IP(J).NE.IP(J+1)) THEN FACT = A(IP(J)) ELSE FACT = ZERO ENDIF DW(2_8*int(M,8)+int(J,8)) = FACT IF (FACT.NE.ZERO) THEN FACT = log(FACT) DO 170 K = IP(J),IP(J+1)-1_8 IF (A(K).NE.ZERO) THEN A(K) = FACT - log(A(K)) IF(A(K) .GT. RINF3) RINF3=A(K) ELSE A(K) = FACT + RINF ENDIF 170 CONTINUE ELSE DO 171 K = IP(J),IP(J+1)-1_8 A(K) = ONE 171 CONTINUE ENDIF 176 CONTINUE ENDIF DW(1) = max(ZERO,CNTL(1)) RINF3 = RINF3+ONE DW(2) = RINF3 IWtemp8(1) = int(JOB,8) IF (JOB.EQ.5) THEN CALL CMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(int(N,8)+1_8),IPQ8, & IW(int(N,8)+1_8), & IWtemp8(2_8*int(N,8)+1_8), & DW(1),DW(int(M,8)+1_8),RINF2) ENDIF IF (JOB.EQ.6) THEN CALL CMUMPS_MTRANSW(M,N,NE,IP, & IW(3_8*int(N,8)+2_8*int(M,8)+1_8),A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(int(N,8)+1_8),IPQ8, & IW(int(N,8)+1_8), & IWtemp8(2_8*int(N,8)+1_8), & DW(1),DW(int(M,8)+1_8),RINF2) ENDIF IF ((JOB.EQ.5).or.(JOB.EQ.6)) THEN DEALLOCATE(IWtemp8) ENDIF IF (JOB.EQ.6) THEN DO 79 I = 1,M IF (DW(2_8*int(M,8)+int(N,8)+int(I,8)).NE.0.0E0) THEN DW(I) = DW(I) + log(DW(2_8*int(M,8)+int(N,8)+int(I,8))) ENDIF 79 CONTINUE ENDIF IF (NUM.EQ.N) THEN DO 80 J = 1,N IF (DW(2_8*int(M,8)+int(J,8)).NE.ZERO) THEN DW(int(M,8)+int(J,8)) = DW(int(M,8)+int(J,8)) - & log(DW(2_8*int(M,8)+int(J,8))) ELSE DW(int(M,8)+int(J,8)) = ZERO ENDIF 80 CONTINUE ENDIF FACT = 0.5E0*log(RINF2) DO 86 I = 1,M IF (DW(I).LT.FACT) GO TO 86 WARN2 = 2 GO TO 90 86 CONTINUE DO 87 J = 1,N IF (DW(M+J).LT.FACT) GO TO 87 WARN2 = 2 GO TO 90 87 CONTINUE ENDIF 90 IF (INFOMUMPS(1).LT.0) RETURN IF (NUM.LT.N) WARN1 = 1 IF (JOB.EQ.4 .OR. JOB.EQ.5 .OR. JOB.EQ.6) THEN IF (CNTL(1).LT.ZERO) WARN4 = 4 ENDIF IF (INFO(1).EQ.0) THEN INFO(1) = WARN1 + WARN2 + WARN4 IF (INFO(1).GT.0 .AND. ICNTL(2).GT.0) THEN WRITE(ICNTL(2),9010) INFO(1) IF (WARN1.EQ.1) WRITE(ICNTL(2),9011) IF (WARN2.EQ.2) WRITE(ICNTL(2),9012) IF (WARN4.EQ.4) WRITE(ICNTL(2),9014) ENDIF ENDIF IF (ICNTL(3).GE.0) THEN IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9030) (INFO(J),J=1,2) WRITE(ICNTL(3),9031) NUM IF (ICNTL(4).EQ.0) THEN WRITE(ICNTL(3),9032) (PERM(J),J=1,min(10,M)) IF (JOB.EQ.5 .OR. JOB.EQ.6) THEN WRITE(ICNTL(3),9033) (DW(J),J=1,min(10,M)) WRITE(ICNTL(3),9034) (DW(int(M,8)+int(J,8)), & 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(int(M,8)+int(J,8)), & J=1,N) ENDIF ENDIF ENDIF ENDIF 99 RETURN 9001 FORMAT (' ****** Error in CMUMPS_MTRANSA. INFO(1) = ',I2, & ' because ',(A),' = ',I14) 9004 FORMAT (' ****** Error in CMUMPS_MTRANSA. INFO(1) = ',I2/ & ' LIW too small, must be at least ',I14) 9005 FORMAT (' ****** Error in CMUMPS_MTRANSA. INFO(1) = ',I2/ & ' LDW too small, must be at least ',I14) 9006 FORMAT (' ****** Error in CMUMPS_MTRANSA. INFO(1) = ',I2/ & ' Column ',I8, & ' contains an entry with invalid row index ',I8) 9007 FORMAT (' ****** Error in CMUMPS_MTRANSA. INFO(1) = ',I2/ & ' Column ',I8, & ' contains two or more entries with row index ',I8) 9010 FORMAT (' ****** Warning from CMUMPS_MTRANSA. INFO(1) = ',I2) 9011 FORMAT (' - The matrix is structurally singular.') 9012 FORMAT (' - Some scaling factors may be too large.') 9014 FORMAT (' - CNTL(1) is negative and was treated as zero.') 9020 FORMAT (' ****** Input parameters for CMUMPS_MTRANSA:'/ & ' JOB =',I10/' M =',I10/' N =',I10/' NE =',I14) 9021 FORMAT (' IP(1:N+1) = ',8I8/(15X,8I8)) 9022 FORMAT (' IRN(1:NE) = ',8I8/(15X,8I8)) 9023 FORMAT (' A(1:NE) = ',4(1PD14.4)/(15X,4(1PD14.4))) 9024 FORMAT (' ICNTL(1:10) = ',8I8/(15X,2I8)) 9025 FORMAT (' CNTL(1:10) = ',4(1PD14.4)/(15X,4(1PD14.4))) 9030 FORMAT (' ****** Output parameters for CMUMPS_MTRANSA:'/ & ' INFO(1:2) = ',2I8) 9031 FORMAT (' NUM = ',I8) 9032 FORMAT (' PERM(1:M) = ',8I8/(15X,8I8)) 9033 FORMAT (' DW(1:M) = ',5(F11.3)/(15X,5(F11.3))) 9034 FORMAT (' DW(M+1:M+N) = ',5(F11.3)/(15X,5(F11.3))) END SUBROUTINE CMUMPS_MTRANS_DRIVER SUBROUTINE CMUMPS_SUPPRESS_DUPPLI_VAL(N,NZ,IP,IRN,A,FLAG,POSI) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(INOUT) :: NZ INTEGER(8), INTENT(INOUT) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NZ) REAL, INTENT(INOUT) :: A(NZ) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER(8), INTENT(OUT) :: POSI(N) INTEGER :: ROW, COL INTEGER(8) :: K, WR_POS, BEG_COL, SV_POS FLAG = 0 WR_POS = 1_8 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1_8 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW A(WR_POS) = A(K) FLAG(ROW) = COL POSI(ROW) = WR_POS WR_POS = WR_POS+1 ELSE SV_POS = POSI(ROW) A(SV_POS) = A(SV_POS) + A(K) ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1_8 RETURN END SUBROUTINE CMUMPS_SUPPRESS_DUPPLI_VAL SUBROUTINE CMUMPS_SUPPRESS_DUPPLI_STR(N,NZ,IP,IRN,FLAG) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(INOUT) :: NZ INTEGER(8), INTENT(INOUT) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NZ) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER :: ROW, COL INTEGER(8) :: K, WR_POS, BEG_COL FLAG = 0 WR_POS = 1_8 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1_8 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW FLAG(ROW) = COL WR_POS = WR_POS+1_8 ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1_8 RETURN END SUBROUTINE CMUMPS_SUPPRESS_DUPPLI_STR SUBROUTINE CMUMPS_SORT_PERM( N, NA, LNA, NE_STEPS, & PERM, FILS, & DAD_STEPS, STEP, NSTEPS, & KEEP60, KEEP20, KEEP38, & INFO) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA INTEGER, INTENT(IN) :: FILS( N ), STEP(N), NA(LNA) INTEGER, INTENT(IN) :: DAD_STEPS ( NSTEPS ), NE_STEPS (NSTEPS) INTEGER, INTENT(IN) :: KEEP60, KEEP20, KEEP38 INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(OUT) :: PERM( N ) INTEGER :: IPERM, INODE, IN, ISCHUR INTEGER :: INBLEAF, INBROOT, allocok INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, NSTK INBLEAF = NA(1) INBROOT = NA(2) ALLOCATE(POOL(INBLEAF), NSTK(NSTEPS), stat=allocok) IF (allocok > 0 ) THEN INFO(1) = -7 INFO(2) = INBLEAF + NSTEPS RETURN ENDIF POOL(1:INBLEAF) = NA(3:2+INBLEAF) NSTK(1:NSTEPS) = NE_STEPS(1:NSTEPS) ISCHUR = 0 IF ( KEEP60.GT.0 ) THEN ISCHUR = max (KEEP20, KEEP38) ENDIF IPERM = 1 DO WHILE ( INBLEAF .NE. 0 ) INODE = POOL( INBLEAF ) INBLEAF = INBLEAF - 1 IN = INODE IF (INODE.NE.ISCHUR) THEN DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO ENDIF IN = DAD_STEPS(STEP( INODE )) IF ( IN .eq. 0 ) THEN INBROOT = INBROOT - 1 ELSE NSTK( STEP(IN) ) = NSTK( STEP(IN) ) - 1 IF ( NSTK( STEP(IN) ) .eq. 0 ) THEN INBLEAF = INBLEAF + 1 POOL( INBLEAF ) = IN END IF END IF END DO IF (IPERM.LE.N) THEN IF (ISCHUR.GT.0) THEN IN = ISCHUR DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO ENDIF ENDIF DEALLOCATE(POOL, NSTK) RETURN END SUBROUTINE CMUMPS_SORT_PERM SUBROUTINE CMUMPS_EXPAND_TREE_STEPS( ICNTL, & N, NBLK, BLKPTR, BLKVAR, & FILS_OLD, FILS_NEW, NSTEPS, & STEP_OLD, STEP_NEW, PAR2_NODES, NB_NIV2, & DAD_STEPS, FRERE_STEPS, & NA, LNA, & LRGROUPS_OLD, SIZELRGROUPS_OLD, & LRGROUPS_NEW, SIZELRGROUPS_NEW, & K20, K38, K494 & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NBLK, ICNTL(60), NSTEPS, LNA, & NB_NIV2, K494 INTEGER, INTENT(IN) :: BLKPTR(NBLK+1), BLKVAR(N) INTEGER, INTENT(IN) :: SIZELRGROUPS_OLD, SIZELRGROUPS_NEW INTEGER, INTENT(IN) :: FILS_OLD(NBLK), STEP_OLD(NBLK), & LRGROUPS_OLD(SIZELRGROUPS_OLD) INTEGER, INTENT(INOUT) :: DAD_STEPS(NSTEPS), FRERE_STEPS(NSTEPS) INTEGER, INTENT(INOUT) :: NA(LNA), PAR2_NODES(NB_NIV2), K20,K38 INTEGER, INTENT(OUT) :: FILS_NEW(N), STEP_NEW(N), & LRGROUPS_NEW(SIZELRGROUPS_NEW) INTEGER :: IB, I, IBFS, IBNB, IFS, INB INTEGER NBLEAF, NBROOT, ISTEP, IGROUP INTEGER :: II IF (K20.GT.0) K20 = BLKVAR(BLKPTR(K20)) IF (K38.GT.0) K38 = BLKVAR(BLKPTR(K38)) NBLEAF = NA(1) NBROOT = NA(2) IF (NBLK.GT.1) THEN DO I= 3, 3+NBLEAF+NBROOT-1 IBNB = NA(I) INB = BLKVAR(BLKPTR(IBNB)) NA(I) = INB ENDDO ENDIF IF (PAR2_NODES(1).GT.0) THEN DO I=1, NB_NIV2 IBNB = PAR2_NODES(I) INB = BLKVAR(BLKPTR(IBNB)) PAR2_NODES(I) = INB ENDDO ENDIF DO I= 1, NSTEPS IBNB = DAD_STEPS(I) IF (IBNB.EQ.0) THEN INB = 0 ELSE INB = BLKVAR(BLKPTR(IBNB)) ENDIF DAD_STEPS(I) = INB ENDDO DO I= 1, NSTEPS IBNB = FRERE_STEPS(I) IF (IBNB.EQ.0) THEN INB = 0 ELSE INB = BLKVAR(BLKPTR(abs(IBNB))) IF (IBNB.LT.0) INB=-INB ENDIF FRERE_STEPS(I) = INB ENDDO DO IB=1, NBLK IBFS = FILS_OLD(IB) IF (IBFS.EQ.0) THEN IFS = 0 ELSE IFS = BLKVAR(BLKPTR(abs(IBFS))) IF (IBFS.LT.0) IFS=-IFS ENDIF IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE DO II=BLKPTR(IB), BLKPTR(IB+1)-1 IF (II.LT. BLKPTR(IB+1)-1) THEN FILS_NEW(BLKVAR(II))= BLKVAR(II+1) ELSE FILS_NEW(BLKVAR(II))= IFS ENDIF ENDDO ENDDO DO IB=1, NBLK ISTEP = STEP_OLD(IB) IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE IF (ISTEP.LT.0) THEN DO II=BLKPTR(IB), BLKPTR(IB+1)-1 STEP_NEW(BLKVAR(II)) = ISTEP ENDDO ELSE I = BLKVAR(BLKPTR(IB)) STEP_NEW(I) = ISTEP DO II=BLKPTR(IB)+1, BLKPTR(IB+1)-1 STEP_NEW(BLKVAR(II)) = -ISTEP ENDDO ENDIF ENDDO IF (K494.NE.0) THEN DO IB=1, NBLK IGROUP = LRGROUPS_OLD(IB) IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE DO II=BLKPTR(IB), BLKPTR(IB+1)-1 LRGROUPS_NEW(BLKVAR(II)) = IGROUP ENDDO ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_EXPAND_TREE_STEPS SUBROUTINE CMUMPS_DIST_AVOID_COPIES(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,PEAK,IERR & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) USE MUMPS_STATIC_MAPPING IMPLICIT NONE INTEGER N, NSLAVES, NBSA, IERR INTEGER ICNTL(60),INFOG(80),KEEP(500) INTEGER(8) KEEP8(150) INTEGER NE(N),NFSIZ(N),FRERE(N),FILS(N),PROCNODE(N) INTEGER SSARBR(N) REAL PEAK INTEGER, intent(IN) :: LSIZEOFBLOCKS INTEGER, intent(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) CALL MUMPS_SET_K78_83_91 (NSLAVES,KEEP(78),KEEP(83),KEEP(91)) CALL MUMPS_DISTRIBUTE(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,dble(PEAK),IERR & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) RETURN END SUBROUTINE CMUMPS_DIST_AVOID_COPIES SUBROUTINE CMUMPS_SET_PROCNODE(INODE, PROCNODE, VALUE, FILS, N) INTEGER, intent(in) :: INODE, N, VALUE INTEGER, intent(in) :: FILS(N) INTEGER, intent(inout) :: PROCNODE(N) INTEGER IN IN=INODE DO WHILE ( IN > 0 ) PROCNODE( IN ) = VALUE IN=FILS( IN ) ENDDO RETURN END SUBROUTINE CMUMPS_SET_PROCNODE MUMPS_5.8.1/src/dfac_dist_arrowheads_omp.F0000664000175000017500000015131715042446440020361 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if ! defined(PCPRET) SUBROUTINE DMUMPS_FAC_DIST_ARROWHEADS_OMP ( & N, NZ_loc8, & A_loc, IRN_loc, JCN_loc, & SIZESCAL, LSCAL, COLSCA, ROWSCA, & DBLARR, LDBLARR, INTARR, LINTARR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & FILS, KEEP,KEEP8, MYID, COMM, NBRECORDS, & & S, LA, root, roota, PROCNODE_STEPS, NPROCS, SLAVEF, PERM, STEP, & ICNTL, INFO, NSEND8, NLOCAL8, & ISTEP_TO_INIV2, CANDIDATES & ) !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZESCAL LOGICAL, INTENT(IN) :: LSCAL INTEGER(8), INTENT(IN) :: NZ_loc8 INTEGER, INTENT(IN) :: IRN_LOC(max(1_8,NZ_loc8)), & JCN_LOC(max(1_8,NZ_loc8)) DOUBLE PRECISION, INTENT(IN) :: A_loc(max(1_8,NZ_loc8)) DOUBLE PRECISION, INTENT(IN) :: ROWSCA(SIZESCAL), & COLSCA(SIZESCAL) INTEGER(8), INTENT(IN) :: LDBLARR, LINTARR DOUBLE PRECISION, INTENT(OUT) :: DBLARR( LDBLARR ) INTEGER, INTENT(OUT) :: INTARR( LINTARR ) INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER(8), INTENT(INOUT):: KEEP8(150) INTEGER, INTENT(IN) :: FILS( N ) INTEGER, INTENT(IN) :: MYID, COMM, NBRECORDS INTEGER(8), INTENT(IN) :: LA INTEGER, INTENT(IN) :: NPROCS, SLAVEF INTEGER(8), INTENT(OUT):: NSEND8, NLOCAL8 INTEGER, INTENT(IN) :: ISTEP_TO_INIV2(KEEP(71)) INTEGER, INTENT(IN) :: CANDIDATES(SLAVEF+1, max(1,KEEP(56))) DOUBLE PRECISION, INTENT(INOUT) :: S( LA ) TYPE (MUMPS_ROOT_STRUC), INTENT(INOUT) :: root TYPE (DMUMPS_ROOT_STRUC), INTENT(INOUT) :: roota INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), & PERM( N ), STEP( N ) INTEGER, INTENT(INOUT) :: INFO( 80 ) INTEGER, INTENT(IN) :: ICNTL(60) INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: PTRAW INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFSENDI DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: BUFSENDR INTEGER, ALLOCATABLE, DIMENSION(:,:) :: BUFSEND_POSRESERVED INTEGER, ALLOCATABLE, DIMENSION(:,:) :: BUFRECVI DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: BUFRECVR INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, ISENDREQI, ISENDREQR LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE INTEGER, ALLOCATABLE, DIMENSION(:) :: IRECVREQI, IRECVREQR INTEGER, ALLOCATABLE, DIMENSION(:):: RECV_BUF_STATUS INTEGER, PARAMETER :: Processed_IrecNeeded = 1 INTEGER, PARAMETER :: IrecPosted = 2 INTEGER, PARAMETER :: Received_NotProcessed = 3 INTEGER, PARAMETER :: Processed_IrecNotneeded = 4 INTEGER, PARAMETER :: Treating = 5 INTEGER, PARAMETER :: BeingTreatednotbyme = 6 INTEGER(8) :: ILOC8 INTEGER :: EndNZloc, NB_END_MSG_2_RECV LOGICAL :: MPI_End_Send, End_TreatRecvBuf, MPI_InvolvedinSend, & MPI_InvolvedinRecv, TH_InvolvedinComm, & NO_ATOMIC_Wsendbuf, NO_ATOMIC_Warrow, FINISHED, & TH_InvolvedinArrange, TH_InvolvedinTreatRecv INTEGER(8) :: PTR_ROOT INTEGER :: LOCAL_M, LOCAL_N, ARROW_ROOT LOGICAL :: EARLYT3ROOTINS LOGICAL :: I_AM_SLAVE, OneMPI INTEGER :: IARR1, IORG, NOMP, NOMP_MAX INTEGER :: ISTEP, ISLAVE_MAIN, IMAIN, JMAIN INTEGER :: allocok LOGICAL :: OMP_FLAG INTEGER(8) :: IS8MAIN INTEGER :: TYPE_NODE_P, MASTER_NODE_P, NBJ_P INTEGER(8) :: IS8_P INTEGER :: LP, MP LOGICAL :: LPOK, PROK INTEGER(8) :: NB_RANGE_8 INTEGER :: SHIFT_PID INTEGER :: NOMP_SHARED LOGICAL :: NOTHINGTOARRANGE_P INTEGER :: IOMP, NB_RANGE_P, EndNZloc_P LOGICAL :: ThWorking INTEGER(8) :: ILOC8_P INTEGER :: NBRECORDS_LOC INTEGER, PARAMETER :: MPI_MASTER = 0 NSEND8 = 0_8 NLOCAL8 = 0_8 LP = ICNTL(1) MP = ICNTL(2) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) NB_RANGE_8 = int(max(NBRECORDS/10, 1), 8) IF (KEEP(46).EQ.0) THEN SHIFT_PID = 1 ELSE SHIFT_PID = 0 ENDIF I_AM_SLAVE = (MYID.NE.0.OR.KEEP(46).EQ.1) OneMPI = NPROCS.EQ.1 IF (OneMPI) THEN NBRECORDS_LOC = 1 ELSE NBRECORDS_LOC = NBRECORDS ENDIF IF ( OneMPI.OR. & (KEEP(54).EQ.0.AND.(MYID.NE.MPI_MASTER)) & ) THEN MPI_InvolvedinSend = .FALSE. MPI_End_Send = .TRUE. ELSE MPI_InvolvedinSend = .TRUE. MPI_End_Send = .FALSE. ENDIF ALLOCATE( & BUFSENDI(NBRECORDS_LOC * 2 + 1, 2, NPROCS), & BUFSENDR(NBRECORDS_LOC, 2, NPROCS), & IACT(NPROCS), SEND_ACTIVE(NPROCS), & ISENDREQI(NPROCS), ISENDREQR(NPROCS), & BUFSEND_POSRESERVED(2, NPROCS), & stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LPOK ) THEN WRITE(LP,*) & '** Error allocating SEND buffers for matrix distribution' END IF INFO(1) = -13 INFO(2) = ( NBRECORDS_LOC * 2 + 1 ) * NPROCS * 2 + & NBRECORDS_LOC * NPROCS * 2 + & NPROCS*6 GOTO 20 END IF IF (.NOT.OneMPI) THEN DO ISLAVE_MAIN=1, NPROCS IACT (ISLAVE_MAIN) = 1 ISENDREQI(ISLAVE_MAIN) = MPI_REQUEST_NULL ISENDREQR(ISLAVE_MAIN) = MPI_REQUEST_NULL BUFSENDI(1, 1, ISLAVE_MAIN) = 0 BUFSEND_POSRESERVED(1,ISLAVE_MAIN)= 0 BUFSENDI(1, 2, ISLAVE_MAIN) = NBRECORDS_LOC BUFSEND_POSRESERVED(2,ISLAVE_MAIN)= NBRECORDS_LOC SEND_ACTIVE(ISLAVE_MAIN) = .FALSE. ENDDO ENDIF IF (OneMPI.OR. & (KEEP(54).EQ.0.AND.(MYID.EQ.MPI_MASTER)) & ) THEN NB_END_MSG_2_RECV = 0 MPI_InvolvedinRecv = .FALSE. End_TreatRecvBuf = .TRUE. ELSE IF (KEEP(54).EQ.0.AND.MYID.NE.MPI_MASTER) THEN NB_END_MSG_2_RECV = 1 MPI_InvolvedinRecv = .TRUE. End_TreatRecvBuf = .FALSE. ELSE NB_END_MSG_2_RECV = NPROCS-1 MPI_InvolvedinRecv = .TRUE. End_TreatRecvBuf = .FALSE. ENDIF ALLOCATE( & BUFRECVI(NBRECORDS_LOC * 2 + 1, NPROCS), & BUFRECVR(NBRECORDS_LOC, NPROCS), & IRECVREQI(NPROCS), IRECVREQR(NPROCS), & RECV_BUF_STATUS(NPROCS), & stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LPOK ) THEN WRITE(LP,*) & '** Error allocating RECV buffers for matrix distribution' END IF INFO(1) = -13 INFO(2) = ( NBRECORDS_LOC * 2 + 1 ) * NPROCS + & NBRECORDS_LOC * NPROCS + & NPROCS*3 GOTO 20 ENDIF IF (.NOT.OneMPI) THEN BUFRECVI(1, 1:NPROCS) = 0 IRECVREQI(1:NPROCS) = MPI_REQUEST_NULL IRECVREQR(1:NPROCS) = MPI_REQUEST_NULL RECV_BUF_STATUS (1:NPROCS)= Processed_IrecNeeded RECV_BUF_STATUS (MYID+1) = Processed_IrecNotneeded IF (KEEP(54).EQ.0) THEN DO ISLAVE_MAIN=1, NPROCS RECV_BUF_STATUS (ISLAVE_MAIN)= Processed_IrecNotneeded ENDDO IF (MYID.NE.MPI_MASTER) THEN RECV_BUF_STATUS(MPI_MASTER+1) = Processed_IrecNeeded ENDIF ENDIF ENDIF ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8) * 2_8, INFO(2) ) GOTO 20 END IF ALLOCATE( PTRAW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8) * KEEP(10), INFO(2) ) GOTO 20 END IF 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 100 ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) IF (I_AM_SLAVE) THEN DO JMAIN = 1, N ISTEP=STEP(JMAIN) IF (ISTEP .GT. 0) THEN IARR1 = PTRDEBARR( ISTEP ) IF ( IARR1 .GT. 0 ) THEN IMAIN = JMAIN IORG = 0 DO WHILE ( IMAIN .GT. 0 ) IORG = IORG + 1 IW4(IMAIN, 1) = NINCOLARR( IARR1 + IORG - 1 ) IW4(IMAIN, 2) = NINROWARR( IARR1 + IORG - 1 ) + & NINCOLARR( IARR1 + IORG - 1 ) IS8MAIN = PTR8ARR( IARR1 + IORG - 1 ) PTRAW( IMAIN ) = IS8MAIN INTARR( IS8MAIN ) = IMAIN DBLARR( IS8MAIN ) = ZERO IMAIN = FILS(IMAIN) ENDDO ENDIF ENDIF ENDDO IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL DMUMPS_GET_ROOT_INFO(root, LOCAL_M, & LOCAL_N, PTR_ROOT, LA) CALL DMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, S, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 ENDIF NOMP=1 !$ NOMP=omp_get_max_threads() NOMP_MAX = NOMP IF (NOMP_MAX.GT.2.AND.KEEP(399).EQ.2) THEN IF (.NOT.OneMPI) THEN NOMP_MAX = 2 ENDIF ENDIF IF (NOMP_MAX.GT.3.AND.KEEP(399).EQ.3) THEN IF (.NOT.OneMPI) THEN NOMP_MAX = 3 ENDIF ENDIF ILOC8 = 1_8 OMP_FLAG = ((NOMP .GE.2).AND.(KEEP(399).NE.99)) FINISHED = .FALSE. NOMP_SHARED = 1 !$OMP PARALLEL !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& PRIVATE( !$OMP& IOMP, ThWorking, ILOC8_P, NB_RANGE_P, !$OMP& NOTHINGTOARRANGE_P, EndNZloc_P, TH_InvolvedinComm, !$OMP& TH_InvolvedinTreatRecv, TH_InvolvedinArrange ) !$OMP& REDUCTION(+:NSEND8, NLOCAL8, ARROW_ROOT) !$OMP& IF (OMP_FLAG) IOMP = 0 !$ IOMP=omp_get_thread_num() !$OMP SINGLE !$ NOMP_SHARED= omp_get_num_threads() IF (OneMPI) THEN EndNZloc = NOMP_SHARED ELSE EndNZloc = max(1,NOMP_SHARED -1) IF ( KEEP(399).EQ.2.OR.KEEP(399).EQ.3 ) THEN EndNZloc = min(EndNZloc,1) ENDIF ENDIF IF (NZ_loc8.EQ.0_8) EndNZloc = 0 IF (.NOT.MPI_InvolvedinSend.AND.(EndNZloc.EQ.0)) EndNZloc=-1 NO_ATOMIC_Wsendbuf = ( NOMP_SHARED.EQ.1 ) NO_ATOMIC_Warrow = ( NOMP_SHARED.EQ.1 ) IF (NPROCS.GT.1) THEN NO_ATOMIC_Warrow = (NOMP_SHARED.LE.2) IF ( KEEP(399).EQ.2 .OR. KEEP(399).EQ.3) THEN NO_ATOMIC_Wsendbuf = .TRUE. IF (.NOT.MPI_InvolvedinSend) NO_ATOMIC_Warrow=.TRUE. IF (.NOT.MPI_InvolvedinRecv) NO_ATOMIC_Warrow=.TRUE. ENDIF ENDIF !$OMP END SINGLE ThWorking = OneMPI.OR. & (NOMP_SHARED.EQ.1) .OR. (IOMP.NE.0) TH_InvolvedinTreatRecv = (MPI_InvolvedinRecv.AND.ThWorking) IF ( TH_InvolvedinTreatRecv.AND. & (NOMP_SHARED.EQ.3).AND.(KEEP(399).EQ.3) ) THEN IF (IOMP.NE.2) TH_InvolvedinTreatRecv = .FALSE. ENDIF TH_InvolvedinArrange = ThWorking IF (.NOT.OneMPI.AND.ThWorking) THEN IF (KEEP(399).EQ.2.OR.KEEP(399).EQ.3) & THEN IF ((NOMP_SHARED.NE.1).AND.(IOMP.NE.1)) & TH_InvolvedinArrange = .FALSE. ENDIF ENDIF TH_InvolvedinComm = ((.NOT.OneMPI).AND.(IOMP.EQ.0)) NOTHINGTOARRANGE_P = (NZ_loc8.EQ.0_8) ILOC8_P = 0_8 DO WHILE ( .NOT.FINISHED ) IF (TH_InvolvedinComm) THEN CALL DMUMPS_ARROW_TRY_PROGRESS_COMM ( IOMP, MYID, & NPROCS, NBRECORDS_LOC, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ENDIF IF (.NOT.ThWorking) THEN CALL MUMPS_USLEEP(20) GOTO 50 ENDIF IF (TH_InvolvedinTreatRecv) THEN CALL DMUMPS_ARROW_TRY_TREAT_RECV_BUF ( IOMP, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, & NPROCS, NBRECORDS_LOC, N, IW4, & KEEP, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, S, LA, & NB_END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR, & NOMP_SHARED, EARLYT3ROOTINS, NO_ATOMIC_Warrow ) IF (NOMP_SHARED.EQ.1) THEN CALL DMUMPS_ARROW_TRY_PROGRESS_COMM ( IOMP, MYID, & NPROCS, NBRECORDS_LOC, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ENDIF ENDIF IF (.NOT. NOTHINGTOARRANGE_P.AND.TH_InvolvedinArrange) THEN !$OMP ATOMIC CAPTURE ILOC8_P = ILOC8 ILOC8 = ILOC8 + NB_RANGE_8 !$OMP END ATOMIC IF (ILOC8_P.LE.NZ_loc8) THEN NB_RANGE_P = int(min(NB_RANGE_8, NZ_loc8-ILOC8_P+1)) CALL DMUMPS_FAC_ARROW_ARRANGE ( MYID, IOMP, N, SHIFT_PID, & SLAVEF, LSCAL, NSEND8, NLOCAL8, ILOC8_P, NB_RANGE_P, & NZ_loc8, IRN_LOC, JCN_LOC, A_loc, SIZESCAL, ROWSCA, COLSCA, & ISTEP_TO_INIV2, CANDIDATES, KEEP, MPI_MASTER, NO_ATOMIC_Warrow, & NO_ATOMIC_Wsendbuf, TH_InvolvedinTreatRecv, & NPROCS, NBRECORDS_LOC, MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, IACT, & SEND_ACTIVE, BUFSEND_POSRESERVED, IRECVREQI, IRECVREQR, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, EndNZloc, MPI_End_Send, & End_TreatRecvBuf, & root, roota, PTR_ROOT, ARROW_ROOT, EARLYT3ROOTINS, & LOCAL_M, LOCAL_N, & S, LA, NB_END_MSG_2_RECV, PROCNODE_STEPS, IW4, PTRAW, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, PERM, STEP, INTARR, LINTARR, & DBLARR, LDBLARR, NOMP_SHARED ) ENDIF IF (ILOC8_P+NB_RANGE_8.GT.NZ_loc8) THEN IF (.NOT. NOTHINGTOARRANGE_P) THEN NOTHINGTOARRANGE_P=.TRUE. !$OMP ATOMIC CAPTURE EndNZloc = EndNZloc-1 EndNZloc_P = EndNZloc !$OMP END ATOMIC IF (MPI_End_Send.AND.EndNZloc_P.EQ.0) THEN !$OMP ATOMIC WRITE EndNZloc=-1 !$OMP END ATOMIC ENDIF ENDIF ENDIF ENDIF 50 CONTINUE !$OMP MASTER !$OMP ATOMIC WRITE FINISHED = ( (EndNZloc.EQ.-1) & .AND.(MPI_End_Send.OR.(.not.MPI_InvolvedinSend)) & .AND. End_TreatRecvBuf & ) !$OMP END ATOMIC !$OMP END MASTER ENDDO !$OMP END PARALLEL !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) !$OMP& PRIVATE(ISTEP, TYPE_NODE_P, MASTER_NODE_P, NBJ_P, !$OMP& IARR1, IS8_P ) !$OMP& IF (OMP_FLAG) DO ISTEP=1, KEEP(28) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE_P, MASTER_NODE_P, & PROCNODE_STEPS(ISTEP), KEEP(199) ) MASTER_NODE_P = MASTER_NODE_P + SHIFT_PID IF ( MASTER_NODE_P.NE.MYID.OR. & ( (TYPE_NODE_P.NE.1) .AND. (TYPE_NODE_P.NE.2) ) & ) CYCLE IARR1 = PTRDEBARR( ISTEP ) NBJ_P = NINCOLARR( IARR1) IF (NBJ_P.LE.0) CYCLE IS8_P = PTR8ARR( IARR1) + 1_8 CALL DMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( IS8_P ), & DBLARR( IS8_P ), & NBJ_P, 1, NBJ_P ) ENDDO !$OMP END PARALLEL DO 100 CONTINUE IF (ALLOCATED(IW4)) DEALLOCATE( IW4 ) IF (ALLOCATED(PTRAW)) DEALLOCATE( PTRAW ) IF (ALLOCATED(BUFSENDI)) DEALLOCATE( BUFSENDI ) IF (ALLOCATED(BUFSENDR)) DEALLOCATE( BUFSENDR ) IF (ALLOCATED(BUFRECVI)) DEALLOCATE( BUFRECVI ) IF (ALLOCATED(BUFRECVR)) DEALLOCATE( BUFRECVR ) IF (ALLOCATED(IACT)) DEALLOCATE( IACT ) IF (ALLOCATED(ISENDREQI)) DEALLOCATE( ISENDREQI ) IF (ALLOCATED(ISENDREQR)) DEALLOCATE( ISENDREQR ) IF (ALLOCATED(IRECVREQI)) DEALLOCATE( IRECVREQI ) IF (ALLOCATED(IRECVREQR)) DEALLOCATE( IRECVREQR ) IF (ALLOCATED(SEND_ACTIVE)) DEALLOCATE( SEND_ACTIVE ) IF (ALLOCATED(BUFSEND_POSRESERVED)) & DEALLOCATE( BUFSEND_POSRESERVED ) IF (ALLOCATED(RECV_BUF_STATUS)) DEALLOCATE( RECV_BUF_STATUS ) RETURN END SUBROUTINE DMUMPS_FAC_DIST_ARROWHEADS_OMP SUBROUTINE DMUMPS_ARROW_TRY_PROGRESS_COMM ( IOMP, MYID, & NPROCS, NBRECORDS, MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) IMPLICIT NONE INTEGER, INTENT(IN) :: IOMP, MYID, NPROCS, NBRECORDS, COMM LOGICAL, INTENT(IN) :: MPI_InvolvedinSend, MPI_InvolvedinRecv INTEGER, INTENT(IN) :: NB_END_MSG_2_RECV INTEGER, INTENT(INOUT) :: EndNZloc LOGICAL, INTENT(INOUT) :: MPI_End_Send, End_TreatRecvBuf INTEGER, INTENT(INOUT) :: & ISENDREQI(NPROCS), ISENDREQR(NPROCS), & BUFSENDI(NBRECORDS * 2 + 1, 2, NPROCS), & IACT(NPROCS), BUFSEND_POSRESERVED(2,NPROCS) DOUBLE PRECISION, INTENT(INOUT) :: BUFSENDR(NBRECORDS, 2, NPROCS) LOGICAL, INTENT(INOUT) :: SEND_ACTIVE(NPROCS) INTEGER, INTENT(INOUT) :: & IRECVREQI(NPROCS), IRECVREQR(NPROCS), & BUFRECVI(NBRECORDS * 2 + 1, NPROCS), & RECV_BUF_STATUS(NPROCS) DOUBLE PRECISION, INTENT(INOUT) :: BUFRECVR(NBRECORDS, NPROCS) INTEGER, PARAMETER :: Processed_IrecNeeded = 1 INTEGER, PARAMETER :: IrecPosted = 2 INTEGER, PARAMETER :: Received_NotProcessed = 3 INTEGER, PARAMETER :: Processed_IrecNotneeded = 4 INTEGER, PARAMETER :: Treating = 5 INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: EndNZloc_copy, ISLAVE, NBREC, STATE, & NB_END_MSG_2_RECV_COPY, ISLAVE_RECV INTEGER :: IERR, IACT_P, NEXT_IACT INTEGER :: TAILLE_SEND_I, TAILLE_SEND_R LOGICAL :: FLAG, FLAGRECV, ALL_LAST_MESS_SENT INTEGER :: STATUS(MPI_STATUS_SIZE) IF (MPI_InvolvedinSend.and.(.NOT.MPI_End_Send)) THEN DO ISLAVE = 1, NPROCS IF (ISLAVE-1.EQ.MYID) CYCLE IF (SEND_ACTIVE( ISLAVE )) THEN CALL MPI_TEST( ISENDREQR( ISLAVE ), FLAG, STATUS, IERR ) IF (FLAG) THEN CALL MPI_WAIT( ISENDREQI( ISLAVE ), STATUS, IERR ) SEND_ACTIVE( ISLAVE ) = .FALSE. ENDIF ENDIF ENDDO !$OMP ATOMIC READ EndNZloc_copy = EndNZloc !$OMP END ATOMIC ALL_LAST_MESS_SENT = (EndNZloc_copy.EQ.0) IF (EndNZloc_copy.NE.-1) THEN DO ISLAVE=1, NPROCS IF (ISLAVE-1.EQ.MYID) CYCLE IF (EndNZloc_copy .EQ. 0) THEN NBREC = & min(BUFSEND_POSRESERVED(IACT(ISLAVE),ISLAVE),NBRECORDS) IF (NBREC.EQ.-99) CYCLE BUFSENDI(1,IACT(ISLAVE),ISLAVE) = - NBREC ELSE !$OMP ATOMIC READ NBREC = BUFSENDI(1,IACT(ISLAVE),ISLAVE) !$OMP END ATOMIC ENDIF IF ((EndNZloc_copy.EQ.0).OR.(NBREC.EQ.NBRECORDS)) THEN IF (.NOT.SEND_ACTIVE(ISLAVE)) THEN TAILLE_SEND_I = NBREC * 2 + 1 TAILLE_SEND_R = NBREC IACT_P = IACT(ISLAVE) CALL MPI_ISEND( BUFSENDI(1, IACT_P, ISLAVE ), & TAILLE_SEND_I, & MPI_INTEGER, ISLAVE - 1, & ARR_INT, COMM, & ISENDREQI( ISLAVE ), IERR ) CALL MPI_ISEND( BUFSENDR(1, IACT_P, ISLAVE ), & TAILLE_SEND_R, & MPI_DOUBLE_PRECISION, ISLAVE - 1, & ARR_REAL, COMM, & ISENDREQR( ISLAVE ), IERR ) SEND_ACTIVE( ISLAVE ) = .TRUE. IF (EndNZloc_copy.NE.0) THEN NEXT_IACT = 3-IACT_P !$OMP ATOMIC WRITE BUFSEND_POSRESERVED(NEXT_IACT,ISLAVE) = 0 !$OMP END ATOMIC !$OMP ATOMIC WRITE BUFSENDI(1,NEXT_IACT,ISLAVE) = 0 !$OMP END ATOMIC !$OMP ATOMIC WRITE IACT( ISLAVE ) = NEXT_IACT !$OMP END ATOMIC ELSE BUFSEND_POSRESERVED(IACT_P,ISLAVE) = -99 ENDIF ELSE ALL_LAST_MESS_SENT=.FALSE. ENDIF ENDIF ENDDO ENDIF IF (EndNZloc_copy.EQ.0.AND.ALL_LAST_MESS_SENT) THEN EndNZloc = -1 EndNZloc_copy = -1 ENDIF IF (.NOT.MPI_End_Send) THEN IF ( (EndNZloc_copy.EQ.-1) ) THEN MPI_End_Send = .TRUE. DO ISLAVE = 1, NPROCS IF (ISLAVE-1.EQ.MYID) CYCLE IF (SEND_ACTIVE( ISLAVE )) THEN MPI_End_Send=.FALSE. EXIT ENDIF ENDDO ENDIF ENDIF ENDIF IF (MPI_InvolvedinRecv.AND.(.NOT.End_TreatRecvBuf)) THEN CALL MPI_TESTANY(NPROCS, IRECVREQR, ISLAVE_RECV, & FLAGRECV, STATUS,IERR) IF (FLAGRECV.AND.(ISLAVE_RECV.NE.MPI_UNDEFINED)) & THEN CALL MPI_WAIT(IRECVREQI(ISLAVE_RECV),STATUS,IERR) !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE_RECV)=Received_NotProcessed !$OMP END ATOMIC ENDIF DO ISLAVE = 1, NPROCS IF (ISLAVE - 1 .EQ. MYID) CYCLE !$OMP ATOMIC READ STATE = RECV_BUF_STATUS(ISLAVE) !$OMP END ATOMIC IF (STATE.EQ.Processed_IrecNeeded) THEN CALL MPI_IRECV ( BUFRECVI(1,ISLAVE), NBRECORDS * 2 + 1, & MPI_INTEGER, ISLAVE-1, ARR_INT, COMM, & IRECVREQI(ISLAVE), IERR) CALL MPI_IRECV ( BUFRECVR(1,ISLAVE), NBRECORDS, & MPI_DOUBLE_PRECISION, ISLAVE-1, & ARR_REAL, COMM, & IRECVREQR(ISLAVE), IERR) !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = IrecPosted !$OMP END ATOMIC ENDIF ENDDO !$OMP ATOMIC READ NB_END_MSG_2_RECV_COPY = NB_END_MSG_2_RECV !$OMP END ATOMIC IF (NB_END_MSG_2_RECV_COPY.EQ.0) THEN End_TreatRecvBuf = .TRUE. DO ISLAVE = 1, NPROCS IF (ISLAVE - 1 .EQ. MYID) CYCLE IF (RECV_BUF_STATUS(ISLAVE).NE.Processed_IrecNotneeded) THEN End_TreatRecvBuf = .FALSE. EXIT ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_ARROW_TRY_PROGRESS_COMM SUBROUTINE DMUMPS_ARROW_TRY_TREAT_RECV_BUF (IOMP, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, & NPROCS, NBRECORDS, N, IW4, & KEEP, LOCAL_M, LOCAL_N, root, roota, & PTR_ROOT, S, LA, & NB_END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR, & NOMP_SHARED, EARLYT3ROOTINS, NO_ATOMIC_Warrow ) USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER, INTENT(IN):: IOMP, NPROCS, NBRECORDS, N, MYID, SLAVEF, & NOMP_SHARED LOGICAL, INTENT(IN):: EARLYT3ROOTINS INTEGER, INTENT(IN):: BUFRECVI( NBRECORDS * 2 + 1, NPROCS ) DOUBLE PRECISION, INTENT(IN):: BUFRECVR( NBRECORDS, NPROCS ) INTEGER, INTENT(INOUT) :: RECV_BUF_STATUS(NPROCS) INTEGER, INTENT(INOUT):: IW4( N, 2 ) INTEGER, INTENT(IN):: KEEP(500) INTEGER, INTENT(INOUT):: NB_END_MSG_2_RECV INTEGER(8), INTENT(IN) :: PTRAW( N ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER, INTENT(IN) :: PERM( N ), STEP( N ) INTEGER, INTENT(IN) :: PROCNODE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER, INTENT(INOUT) :: INTARR( LINTARR ) INTEGER, INTENT(IN):: LOCAL_M, LOCAL_N INTEGER(8), INTENT(IN) :: PTR_ROOT, LA DOUBLE PRECISION, INTENT(INOUT) :: S( LA ), DBLARR( LDBLARR ) LOGICAL, INTENT(IN) :: NO_ATOMIC_Warrow INTEGER, PARAMETER :: Processed_IrecNeeded = 1 INTEGER, PARAMETER :: IrecPosted = 2 INTEGER, PARAMETER :: Received_NotProcessed = 3 INTEGER, PARAMETER :: Processed_IrecNotneeded = 4 INTEGER, PARAMETER :: Treating = 5 INTEGER, PARAMETER :: BeingTreatednotbyme = 6 INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE INTEGER STATE, ISLAVE DO ISLAVE =1, NPROCS IF (MYID.EQ.ISLAVE-1) CYCLE !$OMP ATOMIC READ STATE = RECV_BUF_STATUS(ISLAVE) !$OMP END ATOMIC IF (STATE.EQ.Treating) CYCLE IF (STATE.EQ.Received_NotProcessed) THEN IF (NOMP_SHARED.EQ.1) THEN RECV_BUF_STATUS(ISLAVE) = Treating STATE = Treating ELSE IF (KEEP(399).LE.3) THEN !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Treating !$OMP END ATOMIC STATE = Treating ELSE !$OMP CRITICAL(ARROW_RECV_BUF_STATUS) !$OMP ATOMIC READ STATE = RECV_BUF_STATUS(ISLAVE) !$OMP END ATOMIC IF (STATE.EQ.Received_NotProcessed) THEN !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Treating !$OMP END ATOMIC STATE = Treating ELSE STATE = BeingTreatednotbyme ENDIF !$OMP END CRITICAL(ARROW_RECV_BUF_STATUS) ENDIF ENDIF IF (STATE.NE.Treating) CYCLE IF (NO_ATOMIC_Warrow) THEN CALL DMUMPS_ARROW_TREAT_RECV_BUF_1TH() ELSE CALL DMUMPS_ARROW_TREAT_RECV_BUF() ENDIF ENDDO RETURN CONTAINS SUBROUTINE DMUMPS_ARROW_TREAT_RECV_BUF() INTEGER :: IREC, NB_REC, TYPE_NODE INTEGER :: IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER(8) :: IS8 INTEGER :: IARR, JARR, IW4_CAPTURED INTEGER :: NB_END_MSG_2_RECV_COPY DOUBLE PRECISION :: VAL LOGICAL :: LAST_MESSAGE LAST_MESSAGE = .FALSE. NB_REC = BUFRECVI( 1, ISLAVE ) TYPE_NODE = -998 IF ( NB_REC .LE. 0 ) THEN LAST_MESSAGE = .TRUE. !$OMP ATOMIC CAPTURE NB_END_MSG_2_RECV_COPY = NB_END_MSG_2_RECV NB_END_MSG_2_RECV = NB_END_MSG_2_RECV - 1 !$OMP END ATOMIC NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) GOTO 100 DO IREC = 1, NB_REC IARR = BUFRECVI( IREC * 2, ISLAVE ) JARR = BUFRECVI( IREC * 2 + 1, ISLAVE ) VAL = BUFRECVR( IREC, ISLAVE ) IF (EARLYT3ROOTINS) THEN TYPE_NODE = MUMPS_TYPENODE( & PROCNODE_STEPS(abs(STEP(abs( IARR )))), & KEEP(199) ) ENDIF IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JARR ) ELSE IPOSROOT = root%RG2L( JARR ) JPOSROOT = root%RG2L( -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 !$OMP ATOMIC UPDATE S( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = S( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL !$OMP END ATOMIC ELSE !$OMP ATOMIC UPDATE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL !$OMP END ATOMIC ENDIF ELSE IF (IARR.GE.0) THEN IF (IARR.EQ.JARR) THEN IS8 = PTRAW(IARR) !$OMP ATOMIC UPDATE DBLARR(IS8) = DBLARR(IS8) + VAL !$OMP END ATOMIC ELSE !$OMP ATOMIC CAPTURE IW4_CAPTURED= IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 !$OMP END ATOMIC IS8 = PTRAW(IARR)+int(IW4_CAPTURED,8) INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ELSE IARR = -IARR !$OMP ATOMIC CAPTURE IW4_CAPTURED = IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 !$OMP END ATOMIC IS8 = PTRAW(IARR) + int(IW4_CAPTURED,8) INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ENDDO 100 CONTINUE IF (LAST_MESSAGE) THEN !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Processed_IrecNotneeded !$OMP END ATOMIC ELSE !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Processed_IrecNeeded !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE DMUMPS_ARROW_TREAT_RECV_BUF SUBROUTINE DMUMPS_ARROW_TREAT_RECV_BUF_1TH() INTEGER :: IREC, NB_REC, TYPE_NODE INTEGER :: IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER(8) :: IS8 INTEGER :: IARR, JARR INTEGER :: NB_END_MSG_2_RECV_COPY DOUBLE PRECISION :: VAL LOGICAL :: LAST_MESSAGE TYPE_NODE = -997 LAST_MESSAGE = .FALSE. NB_REC = BUFRECVI( 1, ISLAVE ) IF ( NB_REC .LE. 0 ) THEN LAST_MESSAGE = .TRUE. !$OMP ATOMIC CAPTURE NB_END_MSG_2_RECV_COPY = NB_END_MSG_2_RECV NB_END_MSG_2_RECV = NB_END_MSG_2_RECV - 1 !$OMP END ATOMIC NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) GOTO 100 DO IREC = 1, NB_REC IARR = BUFRECVI( IREC * 2, ISLAVE ) JARR = BUFRECVI( IREC * 2 + 1, ISLAVE ) VAL = BUFRECVR( IREC, ISLAVE ) IF (EARLYT3ROOTINS) THEN TYPE_NODE = MUMPS_TYPENODE( & PROCNODE_STEPS(abs(STEP(abs( IARR )))), & KEEP(199) ) ENDIF IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JARR ) ELSE IPOSROOT = root%RG2L( JARR ) JPOSROOT = root%RG2L( -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 S( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = S( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%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 IS8 = PTRAW(IARR) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IS8 = PTRAW(IARR)+IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ENDDO 100 CONTINUE IF (LAST_MESSAGE) THEN !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Processed_IrecNotneeded !$OMP END ATOMIC ELSE !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Processed_IrecNeeded !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE DMUMPS_ARROW_TREAT_RECV_BUF_1TH END SUBROUTINE DMUMPS_ARROW_TRY_TREAT_RECV_BUF SUBROUTINE DMUMPS_FAC_ARROW_ARRANGE ( & MYID, IOMP, N, SHIFT_PID, SLAVEF, LSCAL, NSEND8, NLOCAL8, & ILOC8_P, NB_RANGE_P, NZ_loc8, IRN_LOC, JCN_LOC, A_loc, SIZESCAL, & ROWSCA, COLSCA, ISTEP_TO_INIV2, CANDIDATES, KEEP, MPI_MASTER, & NO_ATOMIC_Warrow, NO_ATOMIC_Wsendbuf, TH_InvolvedinTreatRecv, & NPROCS, NBRECORDS, MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, IACT, & SEND_ACTIVE, BUFSEND_POSRESERVED, IRECVREQI, IRECVREQR, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, EndNZloc, MPI_End_Send, & End_TreatRecvBuf, & root, roota, & PTR_ROOT, ARROW_ROOT, EARLYT3ROOTINS, LOCAL_M, LOCAL_N, & S, LA, NB_END_MSG_2_RECV, PROCNODE_STEPS, IW4, PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, INTARR, LINTARR, DBLARR, LDBLARR, NOMP_SHARED ) !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, IOMP, N, SHIFT_PID, & SLAVEF, SIZESCAL, MPI_MASTER INTEGER, INTENT(IN) :: NB_RANGE_P, KEEP(500) INTEGER(8), INTENT(IN) :: NZ_loc8, ILOC8_P INTEGER(8), INTENT(INOUT):: NSEND8, NLOCAL8 INTEGER, INTENT(IN) :: IRN_LOC(max(1_8,NZ_loc8)), & JCN_LOC(max(1_8,NZ_loc8)) INTEGER, INTENT(IN):: ISTEP_TO_INIV2(KEEP(71)) INTEGER, INTENT(IN):: CANDIDATES(SLAVEF+1, max(1,KEEP(56))) DOUBLE PRECISION, INTENT(IN):: A_loc(max(1_8,NZ_loc8)) DOUBLE PRECISION, INTENT(IN) :: ROWSCA(SIZESCAL), & COLSCA(SIZESCAL) LOGICAL, INTENT(IN):: NO_ATOMIC_Warrow, NO_ATOMIC_Wsendbuf, & TH_InvolvedinTreatRecv INTEGER, INTENT(IN) :: NPROCS, NBRECORDS, COMM, NOMP_SHARED LOGICAL, INTENT(IN) :: MPI_InvolvedinSend, MPI_InvolvedinRecv, & LSCAL INTEGER, INTENT(INOUT) :: EndNZloc LOGICAL, INTENT(INOUT) :: MPI_End_Send, End_TreatRecvBuf INTEGER, INTENT(INOUT) :: ISENDREQI(NPROCS), ISENDREQR(NPROCS), & BUFSENDI(NBRECORDS * 2 + 1, 2, NPROCS), & IACT(NPROCS), BUFSEND_POSRESERVED(2,NPROCS) DOUBLE PRECISION, INTENT(INOUT) :: BUFSENDR(NBRECORDS, 2, NPROCS) LOGICAL, INTENT(INOUT) :: SEND_ACTIVE(NPROCS) INTEGER, INTENT(INOUT) :: IRECVREQI(NPROCS), IRECVREQR(NPROCS), & BUFRECVI(NBRECORDS * 2 + 1, NPROCS), & RECV_BUF_STATUS(NPROCS) DOUBLE PRECISION, INTENT(INOUT) :: BUFRECVR(NBRECORDS, NPROCS) INTEGER, PARAMETER :: Processed_IrecNeeded = 1 INTEGER, PARAMETER :: IrecPosted = 2 INTEGER, PARAMETER :: Received_NotProcessed = 3 INTEGER, PARAMETER :: Processed_IrecNotneeded = 4 INTEGER, PARAMETER :: Treating = 5 TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER, INTENT(IN) :: LOCAL_M, LOCAL_N LOGICAL, INTENT(IN) :: EARLYT3ROOTINS INTEGER, INTENT(INOUT) :: ARROW_ROOT INTEGER, INTENT(INOUT):: IW4( N, 2 ) INTEGER, INTENT(INOUT):: NB_END_MSG_2_RECV INTEGER(8), INTENT(IN) :: PTRAW( N ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER, INTENT(IN) :: PERM( N ), STEP( N ) INTEGER, INTENT(IN) :: PROCNODE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER, INTENT(INOUT) :: INTARR( LINTARR ) INTEGER(8), INTENT(IN) :: PTR_ROOT, LA DOUBLE PRECISION, INTENT(INOUT) :: S( LA ), DBLARR( LDBLARR ) INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT INTEGER :: DEST, JSEND, ISEND , DEST_SAVE INTEGER :: I, INIV2, NCAND, T4MASTER INTEGER :: IOLD, JOLD, IARR, TYPESPLIT INTEGER(8) :: IS8, IZ8, LAST8 LOGICAL :: T4_MASTER_CONCERNED INTEGER :: MASTER_NODE, TYPE_NODE, ISTEP_P INTEGER :: IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER :: IROW_GRID, JCOL_GRID, IW4_CAPTURED LOGICAL :: LOCAL_ASSEMBLY, LOCAL DOUBLE PRECISION :: VAL INTEGER :: ISTEP_T3_1PROC LAST8 = ILOC8_P + int(NB_RANGE_P-1,8) LOCAL_ASSEMBLY = (NPROCS.EQ.1) IF (NPROCS.EQ.1 .AND. KEEP(38).EQ.0) THEN TYPE_NODE = 1 ISTEP_T3_1PROC = -9999 ELSE IF (NPROCS.EQ.1 .AND. KEEP(38).NE.0) THEN ISTEP_T3_1PROC = STEP(KEEP(38)) ELSE ISTEP_T3_1PROC = -99999 ENDIF DO IZ8=ILOC8_P, LAST8 IOLD = IRN_loc(IZ8) JOLD = JCN_loc(IZ8) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE ENDIF IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = IOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF VAL = A_loc(IZ8) IF (LSCAL) THEN VAL = VAL * ROWSCA(IOLD)*COLSCA(JOLD) ENDIF IF (NPROCS.GT.1 .OR. KEEP(38).NE.0) THEN ISTEP_P = abs(STEP(IARR)) IF ( NPROCS.EQ.1 .AND. ISTEP_P.NE.ISTEP_T3_1PROC ) THEN TYPE_NODE=1 ELSE IF (NPROCS.EQ.1) THEN TYPE_NODE=3 IF (EARLYT3ROOTINS) THEN IF ( ISEND < 0 ) THEN IPOSROOT = root%RG2L(JSEND) JPOSROOT = root%RG2L(IARR ) ELSE IPOSROOT = root%RG2L(IARR ) JPOSROOT = root%RG2L(JSEND) END IF END IF ELSE ISTEP_P = abs(STEP(IARR)) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP_P), KEEP(199) ) MASTER_NODE = MASTER_NODE + SHIFT_PID T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 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 INIV2 = ISTEP_TO_INIV2(ISTEP_P) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP_P), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER= & CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & + SHIFT_PID ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND < 0 ) THEN IPOSROOT = root%RG2L(JSEND) JPOSROOT = root%RG2L(IARR ) ELSE IPOSROOT = root%RG2L(IARR ) JPOSROOT = root%RG2L(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 + SHIFT_PID ELSE DEST = -2 ENDIF ENDIF IF (DEST .eq. -1) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .EQ. -2) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .eq.MYID ) THEN NLOCAL8 = NLOCAL8 + 1_8 ELSE NSEND8 = NSEND8 + 1_8 ENDIF ENDIF LOCAL_ASSEMBLY = .FALSE. IF ( DEST.EQ.-1) THEN INIV2 = ISTEP_TO_INIV2(ISTEP_P) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79) .GT. 0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) + SHIFT_PID IF (DEST.LT.0) EXIT LOCAL = (DEST.EQ.MYID) IF (LOCAL) LOCAL_ASSEMBLY = .TRUE. IF (LOCAL) CYCLE IF (I.EQ.NCAND+1) CYCLE CALL DMUMPS_DIST_FILL_SEND_BUFFER() ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) + SHIFT_PID LOCAL = (DEST.EQ.MYID) IF (LOCAL) LOCAL_ASSEMBLY = .TRUE. IF (LOCAL) CYCLE CALL DMUMPS_DIST_FILL_SEND_BUFFER() ENDDO ENDIF IF ( LOCAL_ASSEMBLY ) THEN DEST_SAVE = DEST DEST = MASTER_NODE IF (DEST.NE.MYID) & CALL DMUMPS_DIST_FILL_SEND_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER IF (DEST.NE.MYID) & CALL DMUMPS_DIST_FILL_SEND_BUFFER() ENDIF DEST = DEST_SAVE ELSE DEST=MASTER_NODE LOCAL_ASSEMBLY = (DEST.EQ.MYID) IF (.NOT.LOCAL_ASSEMBLY) & CALL DMUMPS_DIST_FILL_SEND_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER LOCAL_ASSEMBLY = (DEST.EQ.MYID) IF (.NOT.LOCAL_ASSEMBLY) & CALL DMUMPS_DIST_FILL_SEND_BUFFER() ENDIF ENDIF ELSE IF (DEST .GE. 0) THEN LOCAL_ASSEMBLY = (DEST.EQ.MYID) IF (.NOT.LOCAL_ASSEMBLY) & CALL DMUMPS_DIST_FILL_SEND_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER LOCAL_ASSEMBLY = (DEST.EQ.MYID) IF (.NOT.LOCAL_ASSEMBLY) & CALL DMUMPS_DIST_FILL_SEND_BUFFER() ENDIF ELSE IF (DEST .EQ. -2) THEN DO I = 0, SLAVEF-1 DEST=I + SHIFT_PID IF (DEST.NE.MYID) & CALL DMUMPS_DIST_FILL_SEND_BUFFER() ENDDO IF (SHIFT_PID.EQ.1.AND.MYID.EQ.MPI_MASTER) THEN LOCAL_ASSEMBLY=.FALSE. ELSE LOCAL_ASSEMBLY=.TRUE. ENDIF ENDIF ENDIF ENDIF IF (LOCAL_ASSEMBLY) THEN IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN !$OMP ATOMIC UPDATE S( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = S( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL !$OMP END ATOMIC ELSE !$OMP ATOMIC UPDATE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL !$OMP END ATOMIC ENDIF ELSE IF (NO_ATOMIC_Warrow) THEN IF (ISEND.EQ.JSEND) THEN IS8 = PTRAW(ISEND) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IF (ISEND.GE.0) THEN IS8 = PTRAW(IARR)+IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL ELSE IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL ENDIF ELSE IF (ISEND.EQ.JSEND) THEN IS8 = PTRAW(ISEND) !$OMP ATOMIC UPDATE DBLARR(IS8) = DBLARR(IS8) + VAL !$OMP END ATOMIC ELSE IF (ISEND.GE.0) THEN !$OMP ATOMIC CAPTURE IW4_CAPTURED = IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 !$OMP END ATOMIC IS8 = PTRAW(IARR) + int(IW4_CAPTURED,8) INTARR(IS8) = JSEND DBLARR(IS8) = VAL ELSE !$OMP ATOMIC CAPTURE IW4_CAPTURED = IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 !$OMP END ATOMIC IS8 = PTRAW(IARR) + int(IW4_CAPTURED,8) INTARR(IS8) = JSEND DBLARR(IS8) = VAL ENDIF ENDIF ENDIF ENDIF ENDDO RETURN CONTAINS SUBROUTINE DMUMPS_DIST_FILL_SEND_BUFFER( ) INTEGER IREQ, IACT_P, ISLAVE ISLAVE = DEST+1 100 CONTINUE !$OMP ATOMIC READ IACT_P = IACT(ISLAVE) !$OMP END ATOMIC IF (NO_ATOMIC_Wsendbuf) THEN BUFSEND_POSRESERVED(IACT_P,ISLAVE) = & BUFSEND_POSRESERVED(IACT_P, ISLAVE) + 1 IREQ = BUFSEND_POSRESERVED(IACT_P, ISLAVE) IF (IREQ > NBRECORDS ) THEN IF (IREQ > huge(NBRECORDS)-1000 - NOMP_SHARED-2) THEN BUFSEND_POSRESERVED(IACT_P, ISLAVE) = min(NBRECORDS+1, & BUFSEND_POSRESERVED(IACT_P, ISLAVE) ) ENDIF IF (NOMP_SHARED.EQ.1) & CALL DMUMPS_ARROW_TRY_PROGRESS_COMM (IOMP, & MYID, NPROCS, NBRECORDS, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) IF (TH_InvolvedinTreatRecv) & CALL DMUMPS_ARROW_TRY_TREAT_RECV_BUF (IOMP, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, & NPROCS, NBRECORDS, N, IW4, & KEEP, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, S, LA, & NB_END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR, & NOMP_SHARED, EARLYT3ROOTINS, NO_ATOMIC_Warrow) IF (NOMP_SHARED.EQ.1) THEN CALL DMUMPS_ARROW_TRY_PROGRESS_COMM (IOMP, & MYID, NPROCS, NBRECORDS, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ELSE IF (.NOT.TH_InvolvedinTreatRecv) THEN CALL MUMPS_USLEEP(200) ELSE CALL MUMPS_USLEEP(20) ENDIF ENDIF GOTO 100 ENDIF BUFSENDI(IREQ*2,IACT_P,ISLAVE) = ISEND BUFSENDI(IREQ*2+1,IACT_P,ISLAVE) = JSEND BUFSENDR(IREQ,IACT_P,ISLAVE ) = VAL IF (IREQ.EQ.NBRECORDS) THEN !$OMP ATOMIC WRITE BUFSENDI(1,IACT_P,ISLAVE) = NBRECORDS !$OMP END ATOMIC ENDIF ELSE !$OMP ATOMIC CAPTURE BUFSEND_POSRESERVED(IACT_P,ISLAVE) = & BUFSEND_POSRESERVED(IACT_P, ISLAVE) + 1 IREQ = BUFSEND_POSRESERVED(IACT_P, ISLAVE) !$OMP END ATOMIC IF (IREQ > huge(NBRECORDS)-NOMP_SHARED-2) THEN !$OMP ATOMIC UPDATE BUFSEND_POSRESERVED(IACT_P, ISLAVE) = min(NBRECORDS+1, & BUFSEND_POSRESERVED(IACT_P, ISLAVE) ) !$OMP END ATOMIC ENDIF IF (IREQ > NBRECORDS ) THEN IF (NOMP_SHARED.EQ.1) THEN CALL DMUMPS_ARROW_TRY_PROGRESS_COMM (IOMP, & MYID, NPROCS, NBRECORDS, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ENDIF IF (TH_InvolvedinTreatRecv) & CALL DMUMPS_ARROW_TRY_TREAT_RECV_BUF (IOMP, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, & NPROCS, NBRECORDS, N, IW4, & KEEP, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, S, LA, & NB_END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR, & NOMP_SHARED, EARLYT3ROOTINS, NO_ATOMIC_Warrow) IF (NOMP_SHARED.EQ.1) THEN CALL DMUMPS_ARROW_TRY_PROGRESS_COMM (IOMP, & MYID, NPROCS, NBRECORDS, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ELSE IF (.NOT.TH_InvolvedinTreatRecv) THEN CALL MUMPS_USLEEP(200) ELSE CALL MUMPS_USLEEP(20) ENDIF ENDIF GOTO 100 ENDIF BUFSENDI(IREQ*2,IACT_P,ISLAVE) = ISEND BUFSENDI(IREQ*2+1,IACT_P,ISLAVE) = JSEND BUFSENDR(IREQ,IACT_P,ISLAVE ) = VAL !$OMP ATOMIC UPDATE BUFSENDI(1,IACT_P,ISLAVE) = BUFSENDI(1,IACT_P,ISLAVE) + 1 !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE DMUMPS_DIST_FILL_SEND_BUFFER END SUBROUTINE DMUMPS_FAC_ARROW_ARRANGE #endif MUMPS_5.8.1/src/dfac_determinant.F0000664000175000017500000001773015042446440016636 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_UPDATEDETER(PIV, DETER, NEXP) IMPLICIT NONE DOUBLE PRECISION, intent(in) :: PIV DOUBLE PRECISION, intent(inout) :: DETER INTEGER, intent(inout) :: NEXP DETER=DETER*fraction(PIV) NEXP=NEXP+exponent(PIV)+exponent(DETER) DETER=fraction(DETER) RETURN END SUBROUTINE DMUMPS_UPDATEDETER SUBROUTINE DMUMPS_UPDATEDETER_SCALING(PIV, DETER, NEXP) IMPLICIT NONE DOUBLE PRECISION, intent(in) :: PIV DOUBLE PRECISION, intent(inout) :: DETER INTEGER, intent(inout) :: NEXP DETER=DETER*fraction(PIV) NEXP=NEXP+exponent(PIV)+exponent(DETER) DETER=fraction(DETER) RETURN END SUBROUTINE DMUMPS_UPDATEDETER_SCALING SUBROUTINE DMUMPS_GETDETER2D(BLOCK_SIZE,IPIV, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, & DETER,NEXP,SYM) IMPLICIT NONE INTEGER, intent (in) :: SYM INTEGER, intent (inout) :: NEXP DOUBLE PRECISION, intent (inout) :: DETER INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, & LOCAL_M, LOCAL_N, N INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) DOUBLE PRECISION, intent(in) :: A(*) INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, & ROW_PROC,COL_PROC, K DI = LOCAL_M + 1 NBLOCK = ( N - 1 ) / BLOCK_SIZE DO IBLOCK = 0, NBLOCK ROW_PROC = mod( IBLOCK, NPROW ) IF ( MYROW.EQ.ROW_PROC ) THEN COL_PROC = mod( IBLOCK, NPCOL ) IF ( MYCOL.EQ.COL_PROC ) THEN ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE I = ILOC + JLOC * LOCAL_M + 1 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M & + 1 K=1 DO WHILE ( I .LT. IMX ) CALL DMUMPS_UPDATEDETER(A(I),DETER,NEXP) IF (SYM.EQ.1) THEN CALL DMUMPS_UPDATEDETER(A(I),DETER,NEXP) ENDIF IF (SYM.NE.1) THEN IF (IPIV(ILOC+K) .NE. IBLOCK*BLOCK_SIZE+K) THEN DETER = -DETER ENDIF ENDIF K = K + 1 I = I + DI END DO END IF END IF END DO RETURN END SUBROUTINE DMUMPS_GETDETER2D SUBROUTINE DMUMPS_DETER_REDUCTION( & COMM, DETER_IN, NEXP_IN, & DETER_OUT, NEXP_OUT, NPROCS) IMPLICIT NONE INTEGER, intent(in) :: COMM, NPROCS DOUBLE PRECISION, intent(in) :: DETER_IN INTEGER,intent(in) :: NEXP_IN DOUBLE PRECISION,intent(out):: DETER_OUT INTEGER,intent(out):: NEXP_OUT INTEGER :: IERR_MPI EXTERNAL DMUMPS_DETERREDUCE_FUNC INTEGER TWO_SCALARS_TYPE, DETERREDUCE_OP DOUBLE PRECISION :: INV(2) DOUBLE PRECISION :: OUTV(2) INCLUDE 'mpif.h' IF (NPROCS .EQ. 1) THEN DETER_OUT = DETER_IN NEXP_OUT = NEXP_IN RETURN ENDIF CALL MPI_TYPE_CONTIGUOUS(2, MPI_DOUBLE_PRECISION, & TWO_SCALARS_TYPE, & IERR_MPI) CALL MPI_TYPE_COMMIT(TWO_SCALARS_TYPE, IERR_MPI) CALL MPI_OP_CREATE(DMUMPS_DETERREDUCE_FUNC, & .TRUE., & DETERREDUCE_OP, & IERR_MPI) INV(1)=DETER_IN INV(2)=dble(NEXP_IN) CALL MPI_ALLREDUCE( INV, OUTV, 1, TWO_SCALARS_TYPE, & DETERREDUCE_OP, COMM, IERR_MPI) CALL MPI_OP_FREE(DETERREDUCE_OP, IERR_MPI) CALL MPI_TYPE_FREE(TWO_SCALARS_TYPE, IERR_MPI) DETER_OUT = OUTV(1) NEXP_OUT = int(OUTV(2)) RETURN END SUBROUTINE DMUMPS_DETER_REDUCTION SUBROUTINE DMUMPS_DETERREDUCE_FUNC(INV, INOUTV, NEL, DATATYPE) IMPLICIT NONE #if defined(WORKAROUNDINTELILP64MPI2INTEGER) || defined(WORKAROUNDILP64MPICUSTOMREDUCE) INTEGER(4), INTENT(IN) :: NEL, DATATYPE #else INTEGER, INTENT(IN) :: NEL, DATATYPE #endif DOUBLE PRECISION, INTENT(IN) :: INV ( 2 * NEL ) DOUBLE PRECISION, INTENT(INOUT) :: INOUTV ( 2 * NEL ) INTEGER I, TMPEXPIN, TMPEXPINOUT DO I = 1, NEL TMPEXPIN = int(INV (I*2)) TMPEXPINOUT = int(INOUTV(I*2)) CALL DMUMPS_UPDATEDETER(INV(I*2-1), & INOUTV(I*2-1), & TMPEXPINOUT) TMPEXPINOUT = TMPEXPINOUT + TMPEXPIN INOUTV(I*2) = dble(TMPEXPINOUT) ENDDO RETURN END SUBROUTINE DMUMPS_DETERREDUCE_FUNC SUBROUTINE DMUMPS_DETER_SQUARE(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP DOUBLE PRECISION, intent (inout) :: DETER DETER=DETER*DETER NEXP=NEXP+NEXP RETURN END SUBROUTINE DMUMPS_DETER_SQUARE SUBROUTINE DMUMPS_DETER_SCALING_INVERSE(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP DOUBLE PRECISION, intent (inout) :: DETER DETER=1.0D0/DETER NEXP=-NEXP RETURN END SUBROUTINE DMUMPS_DETER_SCALING_INVERSE SUBROUTINE DMUMPS_DETER_SIGN_PERM(DETER, N, PERM) IMPLICIT NONE DOUBLE PRECISION, intent(inout) :: DETER INTEGER, intent(in) :: N INTEGER, intent(inout) :: PERM(N) INTEGER I, J, K K = 0 DO I = 1, N IF (PERM(I) .LT. 0) THEN PERM(I)=-PERM(I) ELSE J = PERM(I) DO WHILE (J.NE.I) PERM(J)=-PERM(J) K = K + 1 J = -PERM(J) ENDDO ENDIF ENDDO IF (mod(K,2).EQ.1) THEN DETER = -DETER ENDIF RETURN END SUBROUTINE DMUMPS_DETER_SIGN_PERM SUBROUTINE DMUMPS_PAR_ROOT_MINMAX_PIV_UPD ( & BLOCK_SIZE,IPIV, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, & DKEEP, KEEP, SYM) USE DMUMPS_FAC_FRONT_AUX_M, & ONLY : DMUMPS_UPDATE_MINMAX_PIVOT IMPLICIT NONE INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, & LOCAL_M, LOCAL_N, N, SYM INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) DOUBLE PRECISION, intent(in) :: A(*) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER, INTENT(IN) :: KEEP(500) INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, & ROW_PROC,COL_PROC, K DOUBLE PRECISION :: ABSPIVOT DI = LOCAL_M + 1 NBLOCK = ( N - 1 ) / BLOCK_SIZE DO IBLOCK = 0, NBLOCK ROW_PROC = mod( IBLOCK, NPROW ) IF ( MYROW.EQ.ROW_PROC ) THEN COL_PROC = mod( IBLOCK, NPCOL ) IF ( MYCOL.EQ.COL_PROC ) THEN ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE I = ILOC + JLOC * LOCAL_M + 1 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M & + 1 K=1 DO WHILE ( I .LT. IMX ) IF (SYM.NE.1) THEN ABSPIVOT = abs(A(I)) ELSE ABSPIVOT = abs(A(I)*A(I)) ENDIF CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( ABSPIVOT, & DKEEP, KEEP, .FALSE.) K = K + 1 I = I + DI END DO END IF END IF END DO RETURN END SUBROUTINE DMUMPS_PAR_ROOT_MINMAX_PIV_UPD MUMPS_5.8.1/src/dmumps_f77.F0000664000175000017500000004411315042446437015340 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, NBLK, ICNTL, & CNTL, KEEP, DKEEP, KEEP8, NZ, NNZ, IRN, IRNhere, JCN, & JCNhere, A, Ahere, NZ_loc, NNZ_loc, IRN_loc, IRN_lochere, & JCN_loc, JCN_lochere, A_loc, A_lochere, NELT, ELTPTR, & ELTPTRhere, ELTVAR, ELTVARhere, A_ELT, A_ELThere, & BLKPTR, BLKPTRhere, BLKVAR, BLKVARhere, PERM_IN, PERM_INhere, & ROWIND, ROWINDhere, COLIND, COLINDhere, PIVOTS, PIVOTShere, & RHS, RHShere, REDRHS, REDRHShere, & INFO, RINFO, INFOG, RINFOG, DEFICIENCY, LWK_USER, & SIZE_SCHUR, LISTVAR_SCHUR, LISTVAR_SCHURhere, SCHUR, & SCHURhere, WK_USER, WK_USERhere, COLSCA, COLSCAhere, & ROWSCA, ROWSCAhere, INSTANCE_NUMBER, NRHS, LRHS, LREDRHS, & RHS_SPARSE, RHS_SPARSEhere, SOL_loc, SOL_lochere, & RHS_loc, RHS_lochere, & IRHS_SPARSE, IRHS_SPARSEhere, IRHS_PTR, IRHS_PTRhere, & ISOL_loc, ISOL_lochere, IRHS_loc, IRHS_lochere, NZ_RHS, & LSOL_loc, LRHS_loc, NSOL_loc, Nloc_RHS, & SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD, & MBLOCK, NBLOCK, NPROW, NPCOL, LD_RHSINTR, & OOC_TMPDIR, OOC_PREFIX, WRITE_PROBLEM, #if ! defined(NO_SAVE_RESTORE) & SAVE_DIR, SAVE_PREFIX, #endif & TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN, #if ! defined(NO_SAVE_RESTORE) & SAVE_DIRLEN, SAVE_PREFIXLEN, #endif & METIS_OPTIONS & ) USE DMUMPS_STRUC_DEF IMPLICIT NONE INTEGER OOC_PREFIX_MAX_LENGTH, OOC_TMPDIR_MAX_LENGTH INTEGER PB_MAX_LENGTH PARAMETER(OOC_PREFIX_MAX_LENGTH=255, OOC_TMPDIR_MAX_LENGTH=1023) PARAMETER(PB_MAX_LENGTH=1023) #if ! defined(NO_SAVE_RESTORE) INTEGER, PARAMETER :: SAVE_DIR_MAX_LENGTH = 1023 INTEGER, PARAMETER :: SAVE_PREFIX_MAX_LENGTH = 255 #endif INTEGER JOB, SYM, PAR, COMM_F77, N, NBLK, NZ, NZ_loc, NELT, & DEFICIENCY, LWK_USER, SIZE_SCHUR, INSTANCE_NUMBER, & NRHS, LRHS, & NZ_RHS, LSOL_loc,Nloc_RHS, LRHS_loc, NSOL_loc, LREDRHS INTEGER(8) :: NNZ, NNZ_loc INTEGER ICNTL(60), INFO(80), INFOG(80), KEEP(500) INTEGER SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER MBLOCK, NBLOCK, NPROW, NPCOL INTEGER LD_RHSINTR INTEGER TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN DOUBLE PRECISION CNTL(15), RINFO(40), RINFOG(40), DKEEP(230) INTEGER(8) KEEP8(150) INTEGER, TARGET :: IRN(*), JCN(*), ELTPTR(*), ELTVAR(*) INTEGER, TARGET :: PERM_IN(*), IRN_loc(*), JCN_loc(*) INTEGER, TARGET :: LISTVAR_SCHUR(*) INTEGER, TARGET :: IRHS_PTR(*), IRHS_SPARSE(*) INTEGER, TARGET :: ISOL_loc(*), IRHS_loc(*) INTEGER, TARGET :: BLKPTR(*), BLKVAR(*) DOUBLE PRECISION, TARGET :: A(*), A_ELT(*), A_loc(*), RHS(*) INTEGER, TARGET :: ROWIND(*), COLIND(*) DOUBLE PRECISION, TARGET :: PIVOTS(*) DOUBLE PRECISION, TARGET :: WK_USER(*) DOUBLE PRECISION, TARGET :: REDRHS(*) DOUBLE PRECISION, TARGET :: ROWSCA(*), COLSCA(*) DOUBLE PRECISION, TARGET :: SCHUR(*) DOUBLE PRECISION, TARGET :: RHS_SPARSE(*), SOL_loc(*), RHS_loc(*) INTEGER, INTENT(inout) :: OOC_TMPDIR(OOC_TMPDIR_MAX_LENGTH) INTEGER, INTENT(inout) :: OOC_PREFIX(OOC_PREFIX_MAX_LENGTH) INTEGER, INTENT(in) :: WRITE_PROBLEM(PB_MAX_LENGTH) #if ! defined(NO_SAVE_RESTORE) INTEGER SAVE_DIRLEN, SAVE_PREFIXLEN INTEGER, INTENT(in) :: SAVE_DIR(SAVE_DIR_MAX_LENGTH) INTEGER, INTENT(in) :: SAVE_PREFIX(SAVE_PREFIX_MAX_LENGTH) #endif INTEGER METIS_OPTIONS(40) INTEGER IRNhere, JCNhere, Ahere, ELTPTRhere, ELTVARhere, & A_ELThere, BLKPTRhere, BLKVARhere, PERM_INhere, & WK_USERhere, ROWINDhere, COLINDhere, PIVOTShere, & RHShere, REDRHShere, IRN_lochere, & JCN_lochere, A_lochere, LISTVAR_SCHURhere, & SCHURhere, COLSCAhere, ROWSCAhere, RHS_SPARSEhere, & SOL_lochere, RHS_lochere, IRHS_PTRhere, IRHS_SPARSEhere, & ISOL_lochere, IRHS_lochere INCLUDE 'mpif.h' TYPE DMUMPS_STRUC_PTR TYPE (DMUMPS_STRUC), POINTER :: PTR END TYPE DMUMPS_STRUC_PTR TYPE (DMUMPS_STRUC), POINTER :: mumps_par TYPE (DMUMPS_STRUC_PTR), DIMENSION (:), POINTER, SAVE :: & mumps_par_array TYPE (DMUMPS_STRUC_PTR), DIMENSION (:), POINTER :: & mumps_par_array_bis INTEGER, SAVE :: DMUMPS_STRUC_ARRAY_SIZE = 0 INTEGER, SAVE :: N_INSTANCES = 0 INTEGER I, Np, IERR INTEGER(8) :: A_ELT_SIZE, NNZ_i INTEGER DMUMPS_STRUC_ARRAY_SIZE_INIT PARAMETER (DMUMPS_STRUC_ARRAY_SIZE_INIT=10) EXTERNAL MUMPS_ASSIGN_MAPPING, & MUMPS_ASSIGN_PIVNUL_LIST, & MUMPS_ASSIGN_SYM_PERM, & MUMPS_ASSIGN_UNS_PERM, & MUMPS_ASSIGN_GLOB2LOC_RHS, & MUMPS_ASSIGN_GLOB2LOC_SOL EXTERNAL MUMPS_NULLIFY_C_MAPPING, & MUMPS_NULLIFY_C_PIVNUL_LIST, & MUMPS_NULLIFY_C_SYM_PERM, & MUMPS_NULLIFY_C_UNS_PERM, & MUMPS_NULLIFY_C_GLOB2LOC_RHS, & MUMPS_NULLIFY_C_GLOB2LOC_SOL EXTERNAL DMUMPS_ASSIGN_COLSCA, & DMUMPS_ASSIGN_ROWSCA, & DMUMPS_ASSIGN_ROWSCA_LOC, & DMUMPS_ASSIGN_COLSCA_LOC, & DMUMPS_ASSIGN_RHSINTR, & DMUMPS_ASSIGN_SINGULAR_VALUES EXTERNAL DMUMPS_NULLIFY_C_COLSCA, & DMUMPS_NULLIFY_C_ROWSCA, & DMUMPS_NULLIFY_C_ROWSCA_LOC, & DMUMPS_NULLIFY_C_COLSCA_LOC, & DMUMPS_NULLIFY_C_RHSINTR, & DMUMPS_NULLIFY_C_SING_VALUES IF (JOB == -1) THEN DO I = 1, DMUMPS_STRUC_ARRAY_SIZE IF ( .NOT. associated(mumps_par_array(I)%PTR) ) GOTO 10 END DO ALLOCATE( mumps_par_array_bis(DMUMPS_STRUC_ARRAY_SIZE + & DMUMPS_STRUC_ARRAY_SIZE_INIT), stat=IERR) IF (IERR /= 0) THEN WRITE(*,*) ' ** Allocation Error 1 in DMUMPS_F77.' CALL MUMPS_ABORT() END IF DO I = 1, DMUMPS_STRUC_ARRAY_SIZE mumps_par_array_bis(I)%PTR=>mumps_par_array(I)%PTR ENDDO IF (associated(mumps_par_array)) DEALLOCATE(mumps_par_array) mumps_par_array=>mumps_par_array_bis NULLIFY(mumps_par_array_bis) DO I = DMUMPS_STRUC_ARRAY_SIZE+1, DMUMPS_STRUC_ARRAY_SIZE + & DMUMPS_STRUC_ARRAY_SIZE_INIT NULLIFY(mumps_par_array(I)%PTR) ENDDO I = DMUMPS_STRUC_ARRAY_SIZE+1 DMUMPS_STRUC_ARRAY_SIZE = DMUMPS_STRUC_ARRAY_SIZE + & DMUMPS_STRUC_ARRAY_SIZE_INIT 10 CONTINUE INSTANCE_NUMBER = I N_INSTANCES = N_INSTANCES+1 ALLOCATE( mumps_par_array(INSTANCE_NUMBER)%PTR,stat=IERR ) IF (IERR /= 0) THEN WRITE(*,*) '** Allocation Error 2 in DMUMPS_F77.' CALL MUMPS_ABORT() ENDIF ICNTL(1:60) = 0 CNTL(1:15) = 0.0D0 KEEP(1:500) = 0 DKEEP(1:230) = 0.0D0 KEEP8(1:150) = 0_8 METIS_OPTIONS(1:40) = 0 mumps_par_array(INSTANCE_NUMBER)%PTR%INSTANCE_NUMBER = & INSTANCE_NUMBER END IF IF ( INSTANCE_NUMBER .LE. 0 .OR. INSTANCE_NUMBER .GT. & DMUMPS_STRUC_ARRAY_SIZE ) THEN WRITE(*,*) ' ** Instance Error 1 in DMUMPS_F77', & INSTANCE_NUMBER CALL MUMPS_ABORT() END IF IF ( .NOT. associated ( mumps_par_array(INSTANCE_NUMBER)%PTR ) ) & THEN WRITE(*,*) ' Instance Error 2 in DMUMPS_F77', & INSTANCE_NUMBER CALL MUMPS_ABORT() END IF mumps_par => mumps_par_array(INSTANCE_NUMBER)%PTR mumps_par%SYM = SYM mumps_par%PAR = PAR mumps_par%JOB = JOB mumps_par%N = N mumps_par%NBLK = NBLK mumps_par%NZ = NZ mumps_par%NNZ = NNZ mumps_par%NZ_loc = NZ_loc mumps_par%NNZ_loc = NNZ_loc mumps_par%LWK_USER = LWK_USER mumps_par%SIZE_SCHUR = SIZE_SCHUR mumps_par%NELT= NELT mumps_par%ICNTL(1:60)=ICNTL(1:60) mumps_par%CNTL(1:15)=CNTL(1:15) mumps_par%KEEP(1:500)=KEEP(1:500) mumps_par%DKEEP(1:230)=DKEEP(1:230) mumps_par%KEEP8(1:150)=KEEP8(1:150) CALL MUMPS_ADDR_C( ICNTL(50), mumps_par%KEEP8(83) ) CALL MUMPS_ADDR_C( RINFO(3), mumps_par%KEEP8(84) ) mumps_par%METIS_OPTIONS(1:40)=METIS_OPTIONS(1:40) mumps_par%NRHS = NRHS mumps_par%LRHS = LRHS mumps_par%LREDRHS = LREDRHS mumps_par%NZ_RHS = NZ_RHS mumps_par%LSOL_loc = LSOL_loc mumps_par%Nloc_RHS = Nloc_RHS mumps_par%LRHS_loc = LRHS_loc mumps_par%NSOL_loc = NSOL_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 mumps_par%LD_RHSINTR = LD_RHSINTR IF ( COMM_F77 .NE. -987654 ) THEN mumps_par%COMM = COMM_F77 ELSE mumps_par%COMM = MPI_COMM_WORLD ENDIF CALL MPI_BCAST(NRHS,1,MPI_INTEGER,0,mumps_par%COMM,IERR) CALL MUMPS_GET_NNZ_INTERNAL(NNZ,NZ,NNZ_i) IF ( IRNhere /= 0 ) mumps_par%IRN => IRN(1:NNZ_i) IF ( JCNhere /= 0 ) mumps_par%JCN => JCN(1:NNZ_i) IF ( Ahere /= 0 ) mumps_par%A => A(1:NNZ_i) CALL MUMPS_GET_NNZ_INTERNAL(NNZ_loc,NZ_loc,NNZ_i) IF ( IRN_lochere /= 0 ) mumps_par%IRN_loc => IRN_loc(1:NNZ_i) IF ( JCN_lochere /= 0 ) mumps_par%JCN_loc => JCN_loc(1:NNZ_i) IF ( A_lochere /= 0 ) mumps_par%A_loc => A_loc(1:NNZ_i) IF ( ELTPTRhere /= 0 ) mumps_par%ELTPTR => ELTPTR(1:NELT+1) IF ( ELTVARhere /= 0 ) mumps_par%ELTVAR => & ELTVAR(1:ELTPTR(NELT+1)-1) IF ( A_ELThere /= 0 ) THEN A_ELT_SIZE = 0_8 DO I = 1, NELT Np = ELTPTR(I+1) -ELTPTR(I) IF (SYM == 0) THEN A_ELT_SIZE = A_ELT_SIZE + Np * Np ELSE A_ELT_SIZE = A_ELT_SIZE + Np * ( Np + 1 ) / 2 END IF END DO mumps_par%A_ELT => A_ELT(1_8:A_ELT_SIZE) END IF IF ( BLKPTRhere /= 0 ) mumps_par%BLKPTR => BLKPTR(1:NBLK+1) IF ( BLKVARhere /= 0 ) mumps_par%BLKVAR => BLKVAR(1:N) IF ( PERM_INhere /= 0) mumps_par%PERM_IN => PERM_IN(1:N) IF ( LISTVAR_SCHURhere /= 0) & mumps_par%LISTVAR_SCHUR =>LISTVAR_SCHUR(1:SIZE_SCHUR) IF ( SCHURhere /= 0 ) THEN mumps_par%SCHUR_CINTERFACE=>SCHUR(1:1) ENDIF IF (ROWINDhere /= 0) THEN mumps_par%ROWIND => ROWIND(1:KEEP(89)) ENDIF IF (COLINDhere /= 0) THEN mumps_par%COLIND => COLIND(1:KEEP(89)) ENDIF IF (PIVOTShere /= 0) THEN IF (KEEP(50) .EQ.0 .OR.KEEP(50).EQ.1) THEN mumps_par%PIVOTS => PIVOTS(1:KEEP(89)) ELSE mumps_par%PIVOTS => PIVOTS(1_8: & int(KEEP(89),8)+int(KEEP(89),8)) ENDIF ENDIF IF (NRHS .NE. 1) THEN IF ( RHShere /= 0 ) mumps_par%RHS => & RHS(1_8:int(NRHS,8)*int(LRHS,8)) IF (REDRHShere /= 0)mumps_par%REDRHS=> & REDRHS(1_8:int(NRHS,8)*int(LREDRHS,8)) ELSE IF ( RHShere /= 0 ) mumps_par%RHS => RHS(1:N) IF (REDRHShere /= 0)mumps_par%REDRHS=>REDRHS(1:SIZE_SCHUR) ENDIF IF ( WK_USERhere /=0 ) THEN IF (LWK_USER > 0 ) THEN mumps_par%WK_USER => WK_USER(1:LWK_USER) ELSE mumps_par%WK_USER => WK_USER(1_8:-int(LWK_USER,8)*1000000_8) ENDIF ENDIF IF ( COLSCAhere /= 0) mumps_par%COLSCA => COLSCA(1:N) IF ( ROWSCAhere /= 0) mumps_par%ROWSCA => ROWSCA(1:N) IF ( RHS_SPARSEhere /=0 ) mumps_par%RHS_SPARSE=> & RHS_SPARSE(1:NZ_RHS) IF ( IRHS_SPARSEhere /=0 ) mumps_par%IRHS_SPARSE=> & IRHS_SPARSE(1:NZ_RHS) IF ( SOL_lochere /=0 ) mumps_par%SOL_loc=> & SOL_loc(1_8:int(LSOL_loc,8)*int(NRHS,8)) IF ( RHS_lochere /=0 ) mumps_par%RHS_loc=> & RHS_loc(1_8:int(LRHS_loc,8)*int(NRHS,8)) IF ( ISOL_lochere /=0 ) mumps_par%ISOL_loc=> & ISOL_loc(1:LSOL_loc) IF ( IRHS_lochere /=0 ) mumps_par%IRHS_loc=> & IRHS_loc(1:LRHS_loc) IF ( IRHS_PTRhere /=0 ) mumps_par%IRHS_PTR=> & IRHS_PTR(1:NRHS+1) DO I=1,TMPDIRLEN mumps_par%OOC_TMPDIR(I:I)=char(OOC_TMPDIR(I)) ENDDO DO I=TMPDIRLEN+1,OOC_TMPDIR_MAX_LENGTH mumps_par%OOC_TMPDIR(I:I)=' ' ENDDO DO I=1,PREFIXLEN mumps_par%OOC_PREFIX(I:I)=char(OOC_PREFIX(I)) ENDDO DO I=PREFIXLEN+1,OOC_PREFIX_MAX_LENGTH mumps_par%OOC_PREFIX(I:I)=' ' ENDDO DO I=1,WRITE_PROBLEMLEN mumps_par%WRITE_PROBLEM(I:I)=char(WRITE_PROBLEM(I)) ENDDO DO I=WRITE_PROBLEMLEN+1,PB_MAX_LENGTH mumps_par%WRITE_PROBLEM(I:I)=' ' ENDDO #if ! defined(NO_SAVE_RESTORE) DO I=1,SAVE_DIRLEN mumps_par%SAVE_DIR(I:I)=char(SAVE_DIR(I)) ENDDO DO I=SAVE_DIRLEN+1,SAVE_DIR_MAX_LENGTH mumps_par%SAVE_DIR(I:I)=' ' ENDDO DO I=1,SAVE_PREFIXLEN mumps_par%SAVE_PREFIX(I:I)=char(SAVE_PREFIX(I)) ENDDO DO I=SAVE_PREFIXLEN+1,SAVE_PREFIX_MAX_LENGTH mumps_par%SAVE_PREFIX(I:I)=' ' ENDDO #endif CALL DMUMPS( mumps_par ) INFO(1:80)=mumps_par%INFO(1:80) INFOG(1:80)=mumps_par%INFOG(1:80) RINFO(1:40)=mumps_par%RINFO(1:40) RINFOG(1:40)=mumps_par%RINFOG(1:40) ICNTL(1:60) = mumps_par%ICNTL(1:60) CNTL(1:15) = mumps_par%CNTL(1:15) KEEP(1:500) = mumps_par%KEEP(1:500) DKEEP(1:230) = mumps_par%DKEEP(1:230) KEEP8(1:150) = mumps_par%KEEP8(1:150) METIS_OPTIONS(1:40) = mumps_par%METIS_OPTIONS(1:40) SYM = mumps_par%SYM PAR = mumps_par%PAR JOB = mumps_par%JOB N = mumps_par%N NBLK = mumps_par%NBLK NZ = mumps_par%NZ NNZ = mumps_par%NNZ NRHS = mumps_par%NRHS LRHS = mumps_par%LRHS LREDRHS = mumps_par%LREDRHS NZ_loc = mumps_par%NZ_loc NNZ_loc = mumps_par%NNZ_loc NZ_RHS = mumps_par%NZ_RHS LSOL_loc = mumps_par%LSOL_loc Nloc_RHS = mumps_par%Nloc_RHS LRHS_loc = mumps_par%LRHS_loc NSOL_loc = mumps_par%NSOL_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 LD_RHSINTR = mumps_par%LD_RHSINTR IF ( associated (mumps_par%MAPPING) ) THEN CALL MUMPS_ASSIGN_MAPPING(mumps_par%MAPPING(1)) ELSE CALL MUMPS_NULLIFY_C_MAPPING() ENDIF IF ( associated (mumps_par%PIVNUL_LIST) ) THEN CALL MUMPS_ASSIGN_PIVNUL_LIST(mumps_par%PIVNUL_LIST(1)) ELSE CALL MUMPS_NULLIFY_C_PIVNUL_LIST() ENDIF IF ( associated (mumps_par%SINGULAR_VALUES) ) THEN CALL DMUMPS_ASSIGN_SINGULAR_VALUES( & mumps_par%SINGULAR_VALUES(1)) ELSE CALL DMUMPS_NULLIFY_C_SING_VALUES() ENDIF IF ( associated (mumps_par%SYM_PERM) ) THEN CALL MUMPS_ASSIGN_SYM_PERM(mumps_par%SYM_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_SYM_PERM() ENDIF IF ( associated (mumps_par%UNS_PERM) ) THEN CALL MUMPS_ASSIGN_UNS_PERM(mumps_par%UNS_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_UNS_PERM() ENDIF IF ( associated (mumps_par%COLSCA_loc) ) THEN CALL DMUMPS_ASSIGN_COLSCA_LOC(1) ELSE CALL DMUMPS_NULLIFY_C_COLSCA_LOC() ENDIF IF ( associated (mumps_par%ROWSCA_loc) ) THEN CALL DMUMPS_ASSIGN_ROWSCA_LOC(1) ELSE CALL DMUMPS_NULLIFY_C_ROWSCA_LOC() ENDIF IF (associated( mumps_par%COLSCA )) THEN CALL DMUMPS_ASSIGN_COLSCA(mumps_par%COLSCA(1)) ELSE CALL DMUMPS_NULLIFY_C_COLSCA() ENDIF IF (associated( mumps_par%ROWSCA )) THEN CALL DMUMPS_ASSIGN_ROWSCA(mumps_par%ROWSCA(1)) ELSE CALL DMUMPS_NULLIFY_C_ROWSCA() ENDIF IF (associated( mumps_par%RHSINTR )) THEN CALL DMUMPS_ASSIGN_RHSINTR(mumps_par%RHSINTR(1)) ELSE CALL DMUMPS_NULLIFY_C_RHSINTR() ENDIF IF (associated(mumps_par%GLOB2LOC_RHS)) THEN CALL MUMPS_ASSIGN_GLOB2LOC_RHS(mumps_par%GLOB2LOC_RHS(1)) ELSE CALL MUMPS_NULLIFY_C_GLOB2LOC_RHS() ENDIF IF (associated(mumps_par%GLOB2LOC_SOL)) THEN CALL MUMPS_ASSIGN_GLOB2LOC_SOL(mumps_par%GLOB2LOC_SOL(1)) ELSE CALL MUMPS_NULLIFY_C_GLOB2LOC_SOL() ENDIF TMPDIRLEN=len_trim(mumps_par%OOC_TMPDIR) DO I=1,TMPDIRLEN OOC_TMPDIR(I)=ichar(mumps_par%OOC_TMPDIR(I:I)) ENDDO PREFIXLEN=len_trim(mumps_par%OOC_PREFIX) DO I=1,PREFIXLEN OOC_PREFIX(I)=ichar(mumps_par%OOC_PREFIX(I:I)) ENDDO IF ( JOB == -2 ) THEN IF (associated(mumps_par_array(INSTANCE_NUMBER)%PTR))THEN DEALLOCATE(mumps_par_array(INSTANCE_NUMBER)%PTR) NULLIFY (mumps_par_array(INSTANCE_NUMBER)%PTR) N_INSTANCES = N_INSTANCES - 1 IF ( N_INSTANCES == 0 ) THEN DEALLOCATE(mumps_par_array) DMUMPS_STRUC_ARRAY_SIZE = 0 END IF ELSE WRITE(*,*) "** Warning: instance already freed" WRITE(*,*) " this should normally not happen." ENDIF END IF RETURN END SUBROUTINE DMUMPS_F77 MUMPS_5.8.1/src/dsol_aux.F0000664000175000017500000016237315042446437015177 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_FREETOPSO( N, KEEP28, IWCB, LIWW, & W, LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER(8), INTENT(IN) :: LWC INTEGER(8), INTENT(INOUT) :: POSWCB INTEGER N,LIWW,IWPOSCB, KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28) INTEGER(8) :: PTRACB(KEEP28) DOUBLE PRECISION W(LWC) INTEGER SIZFI, SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN DO WHILE ( IWCB( IWPOSCB + 2 ) .eq. 0 ) SIZFR = IWCB( IWPOSCB + 1 ) SIZFI = 2 IWPOSCB = IWPOSCB + SIZFI POSWCB = POSWCB + SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN END DO RETURN END SUBROUTINE DMUMPS_FREETOPSO SUBROUTINE DMUMPS_COMPSO(N,KEEP28,IWCB,LIWW,W,LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER(8), INTENT(IN) :: LWC INTEGER(8), INTENT(INOUT) :: POSWCB INTEGER N,LIWW,IWPOSCB,KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28) INTEGER(8) :: PTRACB(KEEP28) DOUBLE PRECISION W(LWC) INTEGER IPTIW,SIZFI,LONGI INTEGER(8) :: IPTA, LONGR, SIZFR, I8 INTEGER :: I IPTIW = IWPOSCB IPTA = POSWCB LONGI = 0 LONGR = 0_8 IF ( IPTIW .EQ. LIWW ) RETURN 10 CONTINUE IF (IWCB(IPTIW+2).EQ.0) THEN SIZFR = int(IWCB(IPTIW+1),8) SIZFI = 2 IF (LONGI.NE.0) THEN DO 20 I=0,LONGI-1 IWCB(IPTIW + SIZFI - I) = IWCB (IPTIW - I) 20 CONTINUE DO 30 I8=0,LONGR-1 W(IPTA + SIZFR - I8) = W(IPTA - I8) 30 CONTINUE ENDIF DO 40 I=1,KEEP28 IF ((PTRICB(I).LE.(IPTIW+1)).AND. & (PTRICB(I).GT.IWPOSCB) ) THEN PTRICB(I) = PTRICB(I) + SIZFI PTRACB(I) = PTRACB(I) + SIZFR ENDIF 40 CONTINUE IWPOSCB = IWPOSCB + SIZFI IPTIW = IPTIW + SIZFI POSWCB = POSWCB + SIZFR IPTA = IPTA + SIZFR ELSE SIZFR = int(IWCB(IPTIW+1),8) SIZFI = 2 IPTIW = IPTIW + SIZFI LONGI = LONGI + SIZFI IPTA = IPTA + SIZFR LONGR = LONGR + SIZFR ENDIF IF (IPTIW.NE.LIWW) GOTO 10 RETURN END SUBROUTINE DMUMPS_COMPSO SUBROUTINE DMUMPS_SOL_X(A, NZ8, N, IRN, ICN, Z, KEEP,KEEP8, & EFF_SIZE_SCHUR, SYM_PERM ) INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) DOUBLE PRECISION, INTENT(IN) :: A(NZ8) DOUBLE PRECISION, INTENT(OUT) :: Z(N) INTEGER, INTENT(IN) :: EFF_SIZE_SCHUR, SYM_PERM(N) INTEGER :: I, J LOGICAL :: SKIP_COLinSchur DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 INTEGER(8) :: K INTRINSIC abs DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE SKIP_COLinSchur = (EFF_SIZE_SCHUR.GT.0) IF (KEEP(264).EQ.0) THEN IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE IF ( SKIP_COLinSchur.AND. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR)) CYCLE IF ( SKIP_COLinSchur.AND. & (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR)) CYCLE Z(I) = Z(I) + abs(A(K)) ENDDO ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE IF ( SKIP_COLinSchur.AND. & ( (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR) & .OR. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR) & ) & ) CYCLE Z(I) = Z(I) + abs(A(K)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)) ENDIF ENDDO ENDIF ELSE IF (KEEP(50) .EQ.0) THEN IF (SKIP_COLinSchur) THEN DO K = 1_8, NZ8 J = ICN(K) IF ( SYM_PERM(J).GT.N-EFF_SIZE_SCHUR ) CYCLE I = IRN(K) IF ( SYM_PERM(I).GT.N-EFF_SIZE_SCHUR ) CYCLE Z(I) = Z(I) + abs(A(K)) ENDDO ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) Z(I) = Z(I) + abs(A(K)) ENDDO ENDIF ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ( SKIP_COLinSchur.AND. & ( (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR) & .OR. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR) & ) & ) CYCLE Z(I) = Z(I) + abs(A(K)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SOL_X SUBROUTINE DMUMPS_SCAL_X(A, NZ8, N, IRN, ICN, Z, & KEEP, KEEP8, COLSCA, & EFF_SIZE_SCHUR, SYM_PERM ) INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) DOUBLE PRECISION, INTENT(IN) :: A(NZ8) DOUBLE PRECISION, INTENT(IN) :: COLSCA(N) DOUBLE PRECISION, INTENT(OUT) :: Z(N) INTEGER, INTENT(IN) :: EFF_SIZE_SCHUR, SYM_PERM(N) DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 INTEGER :: I, J INTEGER(8) :: K LOGICAL :: SKIP_COLinSchur DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE SKIP_COLinSchur = (EFF_SIZE_SCHUR.GT.0) IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE IF ( SKIP_COLinSchur.AND. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR)) CYCLE IF ( SKIP_COLinSchur.AND. & (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR)) CYCLE Z(I) = Z(I) + abs(A(K)*COLSCA(J)) ENDDO ELSE DO K = 1, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE IF ( SKIP_COLinSchur.AND. & ( (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR) & .OR. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR) & ) & ) CYCLE Z(I) = Z(I) + abs(A(K)*COLSCA(J)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)*COLSCA(I)) ENDIF ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_SCAL_X SUBROUTINE DMUMPS_SOL_Y(A, NZ8, N, IRN, ICN, RHS, X, R, W, & KEEP,KEEP8) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) DOUBLE PRECISION, INTENT(IN) :: A(NZ8), RHS(N), X(N) DOUBLE PRECISION, INTENT(OUT) :: W(N) DOUBLE PRECISION, INTENT(OUT) :: R(N) INTEGER I, J INTEGER(8) :: K8 DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 DOUBLE PRECISION D DO I = 1, N R(I) = RHS(I) W(I) = ZERO ENDDO IF (KEEP(264).EQ.0) THEN IF (KEEP(50) .EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. & (J .LT. 1)) CYCLE D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. & (J .LT. 1)) CYCLE D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF (I.NE.J) THEN D = A(K8) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO ENDIF ELSE IF (KEEP(50) .EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF (I.NE.J) THEN D = A(K8) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SOL_Y SUBROUTINE DMUMPS_SOL_MULR(N, R, W) INTEGER, intent(in) :: N DOUBLE PRECISION, intent(in) :: W(N) DOUBLE PRECISION, intent(inout) :: R(N) INTEGER I DO 10 I = 1, N R(I) = R(I) * W(I) 10 CONTINUE RETURN END SUBROUTINE DMUMPS_SOL_MULR SUBROUTINE DMUMPS_SOL_B(N, KASE, X, EST, W, IW, GRAIN) INTEGER, intent(in) :: N INTEGER, intent(inout) :: KASE INTEGER IW(N) DOUBLE PRECISION W(N), X(N) DOUBLE PRECISION, intent(inout) :: EST INTEGER, intent(in) :: GRAIN INTRINSIC abs, nint, sign INTRINSIC dble INTEGER DMUMPS_IXAMAX EXTERNAL DMUMPS_IXAMAX INTEGER ITMAX PARAMETER (ITMAX = 5) INTEGER I, ITER, J, JLAST, JUMP DOUBLE PRECISION ALTSGN DOUBLE PRECISION TEMP SAVE ITER, J, JLAST, JUMP DOUBLE PRECISION ZERO, ONE PARAMETER( ZERO = 0.0D0 ) PARAMETER( ONE = 1.0D0 ) DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: RONE = 1.0D0 IF (KASE .EQ. 0) THEN DO 10 I = 1, N X(I) = ONE / dble(N) 10 CONTINUE KASE = 1 JUMP = 1 RETURN ENDIF SELECT CASE (JUMP) CASE (1) GOTO 20 CASE(2) GOTO 40 CASE(3) GOTO 70 CASE(4) GOTO 120 CASE(5) GOTO 160 CASE DEFAULT END SELECT 20 CONTINUE IF (N .EQ. 1) THEN W(1) = X(1) EST = abs(W(1)) GOTO 190 ENDIF DO 30 I = 1, N X(I) = sign( RONE,dble(X(I)) ) IW(I) = nint(dble(X(I))) 30 CONTINUE KASE = 2 JUMP = 2 RETURN 40 CONTINUE J = DMUMPS_IXAMAX(N, X, 1, GRAIN) ITER = 2 50 CONTINUE DO 60 I = 1, N X(I) = ZERO 60 CONTINUE X(J) = ONE KASE = 1 JUMP = 3 RETURN 70 CONTINUE DO 80 I = 1, N W(I) = X(I) 80 CONTINUE DO 90 I = 1, N IF (nint(sign(RONE, dble(X(I)))) .NE. IW(I)) GOTO 100 90 CONTINUE GOTO 130 100 CONTINUE DO 110 I = 1, N X(I) = sign(RONE, dble(X(I))) IW(I) = nint(dble(X(I))) 110 CONTINUE KASE = 2 JUMP = 4 RETURN 120 CONTINUE JLAST = J J = DMUMPS_IXAMAX(N, X, 1, GRAIN) IF ((abs(X(JLAST)) .NE. abs(X(J))) .AND. (ITER .LT. ITMAX)) THEN ITER = ITER + 1 GOTO 50 ENDIF 130 CONTINUE EST = RZERO DO 140 I = 1, N EST = EST + abs(W(I)) 140 CONTINUE ALTSGN = RONE DO 150 I = 1, N X(I) = ALTSGN * (RONE + dble(I - 1) / dble(N - 1)) ALTSGN = -ALTSGN 150 CONTINUE KASE = 1 JUMP = 5 RETURN 160 CONTINUE TEMP = RZERO DO 170 I = 1, N TEMP = TEMP + abs(X(I)) 170 CONTINUE TEMP = 2.0D0/3.0D0 * TEMP / dble(N) IF (TEMP .GT. EST) THEN DO 180 I = 1, N W(I) = X(I) 180 CONTINUE EST = TEMP ENDIF 190 KASE = 0 RETURN END SUBROUTINE DMUMPS_SOL_B SUBROUTINE DMUMPS_QD2( MTYPE, N, NZ8, ASPK, IRN, ICN, & LHS, WRHS, W, RHS, KEEP,KEEP8) IMPLICIT NONE INTEGER MTYPE, N INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(IN) :: IRN( NZ8 ), ICN( NZ8 ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(IN) :: ASPK( NZ8 ) DOUBLE PRECISION, INTENT(IN) :: LHS( N ), WRHS( N ) DOUBLE PRECISION, INTENT(OUT):: RHS( N ) DOUBLE PRECISION, INTENT(OUT):: W( N ) INTEGER I, J INTEGER(8) :: K8 DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0 DO I = 1, N W(I) = DZERO RHS(I) = WRHS(I) ENDDO IF ( KEEP(50) .EQ. 0 ) THEN IF (MTYPE .EQ. 1) THEN IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) ENDDO ENDIF ELSE IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDDO ENDIF ENDIF ELSE IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDIF ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_QD2 SUBROUTINE DMUMPS_ELTQD2( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & LHS, WRHS, W, RHS, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION A_ELT(NA_ELT8) DOUBLE PRECISION LHS( N ), WRHS( N ), RHS( N ) DOUBLE PRECISION W(N) CALL DMUMPS_MV_ELT(N, NELT, ELTPTR, ELTVAR, A_ELT, & LHS, RHS, KEEP(50), MTYPE ) RHS = WRHS - RHS CALL DMUMPS_SOL_X_ELT( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8 ) RETURN END SUBROUTINE DMUMPS_ELTQD2 SUBROUTINE DMUMPS_SOL_X_ELT( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION A_ELT(NA_ELT8) DOUBLE PRECISION TEMP DOUBLE PRECISION W(N) INTEGER I, J, IEL, SIZEI, IELPTR INTEGER(8) :: K8 DOUBLE PRECISION DZERO PARAMETER(DZERO = 0.0D0) W = DZERO K8 = 1_8 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( KEEP(50).EQ.0 ) THEN IF (MTYPE.EQ.1) THEN DO J = 1, SIZEI DO I = 1, SIZEI W( ELTVAR( IELPTR + I) ) = & W( ELTVAR( IELPTR + I) ) & + abs(A_ELT( K8 )) K8 = K8 + 1_8 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + abs( A_ELT(K8)) K8 = K8 + 1_8 END DO W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + TEMP END DO ENDIF ELSE DO J = 1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K8 )) K8 = K8 + 1_8 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K8 )) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + abs(A_ELT( K8 )) K8 = K8 + 1_8 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_SOL_X_ELT SUBROUTINE DMUMPS_SOL_SCALX_ELT(MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8, COLSCA ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION COLSCA(N) DOUBLE PRECISION A_ELT(NA_ELT8) DOUBLE PRECISION W(N) DOUBLE PRECISION TEMP, TEMP2 INTEGER I, J, IEL, SIZEI, IELPTR INTEGER(8) :: K8 DOUBLE PRECISION DZERO PARAMETER(DZERO = 0.0D0) W = DZERO K8 = 1_8 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( KEEP(50).EQ.0 ) THEN IF (MTYPE.EQ.1) THEN DO J = 1, SIZEI TEMP2 = abs(COLSCA(ELTVAR( IELPTR + J) )) DO I = 1, SIZEI W( ELTVAR( IELPTR + I) ) = & W( ELTVAR( IELPTR + I) ) & + abs(A_ELT( K8 )) * TEMP2 K8 = K8 + 1_8 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) TEMP2= abs(COLSCA(ELTVAR( IELPTR + J) )) DO I = 1, SIZEI TEMP = TEMP + abs(A_ELT( K8 )) * TEMP2 K8 = K8 + 1_8 END DO W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + TEMP END DO ENDIF ELSE DO J = 1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs( A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + J)) ) K8 = K8 + 1_8 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs(A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + J))) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + & abs(A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + I))) K8 = K8 + 1_8 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_SOL_SCALX_ELT SUBROUTINE DMUMPS_ELTYD( MTYPE, N, NELT, ELTPTR, & LELTVAR, ELTVAR, NA_ELT8, A_ELT, & SAVERHS, X, Y, W, K50 ) IMPLICIT NONE INTEGER N, NELT, K50, MTYPE, LELTVAR INTEGER(8) :: NA_ELT8 INTEGER ELTPTR( NELT + 1 ), ELTVAR( LELTVAR ) DOUBLE PRECISION A_ELT( NA_ELT8 ), X( N ), Y( N ), & SAVERHS(N) DOUBLE PRECISION W(N) INTEGER IEL, I , J, K, SIZEI, IELPTR DOUBLE PRECISION ZERO DOUBLE PRECISION TEMP DOUBLE PRECISION TEMP2 PARAMETER( ZERO = 0.0D0 ) Y = SAVERHS W = ZERO K = 1 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( K50 .eq. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN DO J = 1, SIZEI TEMP = X( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) - & A_ELT( K ) * TEMP W( ELTVAR( IELPTR + I ) ) = & W( ELTVAR( IELPTR + I ) ) + & abs( A_ELT( K ) * TEMP ) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) TEMP2 = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP - & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) TEMP2 = TEMP2 + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) K = K + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP W( ELTVAR( IELPTR + J ) ) = TEMP2 END DO END IF ELSE DO J = 1, SIZEI Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) W( ELTVAR( IELPTR + J ) ) = & W( ELTVAR( IELPTR + J ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) K = K + 1 DO I = J+1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) W( ELTVAR( IELPTR + I ) ) = & W( ELTVAR( IELPTR + I ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) W( ELTVAR( IELPTR + J ) ) = & W( ELTVAR( IELPTR + J ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) K = K + 1 END DO END DO END IF END DO RETURN END SUBROUTINE DMUMPS_ELTYD SUBROUTINE DMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) USE DMUMPS_OOC IMPLICIT NONE INTEGER INODE,KEEP(500),N INTEGER(8) KEEP8(150) INTEGER(8) :: LA INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER IERR DOUBLE PRECISION A(LA) INTEGER RETURN_VALUE LOGICAL MUST_BE_PERMUTED RETURN_VALUE=DMUMPS_SOLVE_IS_INODE_IN_MEM(INODE,PTRFAC, & KEEP(28),A,LA,IERR) IF(RETURN_VALUE.EQ.OOC_NODE_NOT_IN_MEM)THEN IF(IERR.LT.0)THEN RETURN ENDIF CALL DMUMPS_SOLVE_ALLOC_FACTOR_SPACE(INODE,PTRFAC, & KEEP,KEEP8,A,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL DMUMPS_READ_OOC( & A(PTRFAC(STEP(INODE))), & INODE,IERR & ) IF(IERR.LT.0)THEN RETURN ENDIF ELSE IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF(RETURN_VALUE.NE.OOC_NODE_PERMUTED)THEN MUST_BE_PERMUTED=.TRUE. CALL DMUMPS_SOLVE_MODIFY_STATE_NODE(INODE) ELSE MUST_BE_PERMUTED=.FALSE. ENDIF RETURN END SUBROUTINE DMUMPS_SOLVE_GET_OOC_NODE SUBROUTINE DMUMPS_BUILD_MAPPING_INFO(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' TYPE(DMUMPS_STRUC), TARGET :: id INTEGER, ALLOCATABLE, DIMENSION(:) :: LOCAL_LIST INTEGER :: I,IERR,TMP,NSTEPS,N_LOCAL_LIST INTEGER :: MASTER,TAG_SIZE,TAG_LIST INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: I_AM_SLAVE PARAMETER(MASTER=0, TAG_SIZE=85,TAG_LIST=86) I_AM_SLAVE = (id%MYID .NE. MASTER & .OR. ((id%MYID.EQ.MASTER).AND.(id%KEEP(46).EQ.1))) NSTEPS = id%KEEP(28) ALLOCATE(LOCAL_LIST(NSTEPS),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating LOCAL_LIST' CALL MUMPS_ABORT() END IF N_LOCAL_LIST = 0 IF(I_AM_SLAVE) THEN DO I=1,NSTEPS IF(id%PTLUST_S(I).NE.0) THEN N_LOCAL_LIST = N_LOCAL_LIST + 1 LOCAL_LIST(N_LOCAL_LIST) = I END IF END DO IF(id%MYID.NE.MASTER) THEN CALL MPI_SEND(N_LOCAL_LIST, 1, & MPI_INTEGER, MASTER, TAG_SIZE, id%COMM,IERR) CALL MPI_SEND(LOCAL_LIST, N_LOCAL_LIST, & MPI_INTEGER, MASTER, TAG_LIST, id%COMM,IERR) DEALLOCATE(LOCAL_LIST) ALLOCATE(id%IPTR_WORKING(1), & id%WORKING(1), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating ', & 'IPTR_WORKING and WORKING' CALL MUMPS_ABORT() END IF END IF END IF IF(id%MYID.EQ.MASTER) THEN ALLOCATE(id%IPTR_WORKING(id%NPROCS+1), STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating IPTR_WORKING' CALL MUMPS_ABORT() END IF id%IPTR_WORKING = 0 id%IPTR_WORKING(1) = 1 id%IPTR_WORKING(MASTER+2) = N_LOCAL_LIST DO I=1, id%NPROCS-1 CALL MPI_RECV(TMP, 1, MPI_INTEGER, MPI_ANY_SOURCE, & TAG_SIZE, id%COMM, STATUS, IERR) id%IPTR_WORKING(STATUS(MPI_SOURCE)+2) = TMP END DO DO I=2, id%NPROCS+1 id%IPTR_WORKING(I) = id%IPTR_WORKING(I) & + id%IPTR_WORKING(I-1) END DO ALLOCATE(id%WORKING(id%IPTR_WORKING(id%NPROCS+1)-1),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating LOCAL_LIST' CALL MUMPS_ABORT() END IF TMP = MASTER + 1 IF (I_AM_SLAVE) THEN id%WORKING(id%IPTR_WORKING(TMP):id%IPTR_WORKING(TMP+1)-1) & = LOCAL_LIST(1:id%IPTR_WORKING(TMP+1) & -id%IPTR_WORKING(TMP)) ENDIF DO I=1,id%NPROCS-1 CALL MPI_RECV(LOCAL_LIST, NSTEPS, MPI_INTEGER, & MPI_ANY_SOURCE, TAG_LIST, id%COMM, STATUS, IERR) TMP = STATUS(MPI_SOURCE)+1 id%WORKING(id%IPTR_WORKING(TMP):id%IPTR_WORKING(TMP+1)-1) & = LOCAL_LIST(1:id%IPTR_WORKING(TMP+1)- & id%IPTR_WORKING(TMP)) END DO DEALLOCATE(LOCAL_LIST) END IF END SUBROUTINE DMUMPS_BUILD_MAPPING_INFO SUBROUTINE DMUMPS_SOL_OMEGA(N, RHS, & X, Y, R_W, C_W, IW, IFLAG, & OMEGA, NOITER, TESTConv, & LP, ARRET, GRAIN, CGCE ) IMPLICIT NONE INTEGER N, IFLAG INTEGER IW(N,2) DOUBLE PRECISION RHS(N) DOUBLE PRECISION X(N), Y(N) DOUBLE PRECISION R_W(N,2) DOUBLE PRECISION C_W(N) INTEGER LP, NOITER LOGICAL TESTConv DOUBLE PRECISION OMEGA(2) DOUBLE PRECISION ARRET DOUBLE PRECISION CGCE INTEGER, intent(in) :: GRAIN DOUBLE PRECISION, PARAMETER :: CTAU=1.0D3 INTEGER I, IMAX DOUBLE PRECISION OM1, OM2, DXMAX DOUBLE PRECISION TAU, DD DOUBLE PRECISION OLDOMG(2) DOUBLE PRECISION, PARAMETER :: ZERO=0.0D0 DOUBLE PRECISION, PARAMETER :: ONE=1.0D0 INTEGER DMUMPS_IXAMAX SAVE OM1, OLDOMG IMAX = DMUMPS_IXAMAX(N, X, 1, GRAIN) DXMAX = abs(X(IMAX)) OMEGA(1) = ZERO OMEGA(2) = ZERO DO I = 1, N TAU = (R_W(I, 2) * DXMAX + abs(RHS(I))) * dble(N) * CTAU DD = R_W(I, 1) + abs(RHS(I)) IF (DD .GT. TAU * epsilon(CTAU)) THEN OMEGA(1) = max(OMEGA(1), abs(Y(I)) / DD) IW(I, 1) = 1 ELSE IF (TAU .GT. ZERO) THEN OMEGA(2) = max(OMEGA(2), & abs(Y(I)) / (DD + R_W(I, 2) * DXMAX)) ENDIF IW(I, 1) = 2 ENDIF ENDDO IF (TESTConv) THEN OM2 = OMEGA(1) + OMEGA(2) IF (OM2 .LT. ARRET ) THEN IFLAG = 1 GOTO 70 ENDIF IF (NOITER .GE. 1) THEN IF (OM2 .GT. OM1 * CGCE) THEN IF (OM2 .GT. OM1) THEN OMEGA(1) = OLDOMG(1) OMEGA(2) = OLDOMG(2) DO I = 1, N X(I) = C_W(I) ENDDO IFLAG = 2 GOTO 70 ENDIF IFLAG = 3 GOTO 70 ENDIF ENDIF DO I = 1, N C_W(I) = X(I) ENDDO OLDOMG(1) = OMEGA(1) OLDOMG(2) = OMEGA(2) OM1 = OM2 ENDIF IFLAG = 0 RETURN 70 CONTINUE RETURN END SUBROUTINE DMUMPS_SOL_OMEGA SUBROUTINE DMUMPS_SOL_LCOND(N, RHS, & X, Y, D, R_W, C_W, IW, KASE, & OMEGA, ERX, COND, & LP, KEEP,KEEP8 ) IMPLICIT NONE INTEGER N, KASE, KEEP(500) INTEGER(8) KEEP8(150) INTEGER IW(N,2) DOUBLE PRECISION RHS(N) DOUBLE PRECISION X(N), Y(N) DOUBLE PRECISION D(N) DOUBLE PRECISION R_W(N,2) DOUBLE PRECISION C_W(N) INTEGER LP DOUBLE PRECISION COND(2),OMEGA(2) LOGICAL LCOND1, LCOND2 INTEGER JUMP, I, IMAX DOUBLE PRECISION ERX, DXMAX DOUBLE PRECISION DXIMAX DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: ONE = 1.0D0 INTEGER DMUMPS_IXAMAX INTRINSIC abs SAVE LCOND1, LCOND2, JUMP, DXIMAX, DXMAX IF (KASE .EQ. 0) THEN LCOND1 = .FALSE. LCOND2 = .FALSE. COND(1) = ONE COND(2) = ONE ERX = ZERO JUMP = 1 ENDIF SELECT CASE (JUMP) CASE (1) GOTO 30 CASE(2) GOTO 10 CASE(3) GOTO 110 CASE(4) GOTO 150 CASE(5) GOTO 35 CASE DEFAULT END SELECT 10 CONTINUE 30 CONTINUE 35 CONTINUE IMAX = DMUMPS_IXAMAX(N, X, 1, KEEP(361)) DXMAX = abs(X(IMAX)) DO I = 1, N IF (IW(I, 1) .EQ. 1) THEN R_W(I, 1) = R_W(I, 1) + abs(RHS(I)) R_W(I, 2) = ZERO LCOND1 = .TRUE. ELSE R_W(I, 2) = R_W(I, 2) * DXMAX + R_W(I, 1) R_W(I, 1) = ZERO LCOND2 = .TRUE. ENDIF ENDDO DO I = 1, N C_W(I) = X(I) * D(I) ENDDO IMAX = DMUMPS_IXAMAX(N, C_W(1), 1, KEEP(361)) DXIMAX = abs(C_W(IMAX)) IF (.NOT.LCOND1) GOTO 130 100 CONTINUE CALL DMUMPS_SOL_B(N, KASE, Y, COND(1), C_W, IW(1, 2), KEEP(361)) IF (KASE .EQ. 0) GOTO 120 IF (KASE .EQ. 1) CALL DMUMPS_SOL_MULR(N, Y, D) IF (KASE .EQ. 2) CALL DMUMPS_SOL_MULR(N, Y, R_W) JUMP = 3 RETURN 110 CONTINUE IF (KASE .EQ. 1) CALL DMUMPS_SOL_MULR(N, Y, R_W) IF (KASE .EQ. 2) CALL DMUMPS_SOL_MULR(N, Y, D) GOTO 100 120 CONTINUE IF (DXIMAX .GT. ZERO) COND(1) = COND(1) / DXIMAX ERX = OMEGA(1) * COND(1) 130 CONTINUE IF (.NOT.LCOND2) GOTO 170 KASE = 0 140 CONTINUE CALL DMUMPS_SOL_B(N, KASE, Y, COND(2), C_W, IW(1, 2), KEEP(361)) IF (KASE .EQ. 0) GOTO 160 IF (KASE .EQ. 1) CALL DMUMPS_SOL_MULR(N, Y, D) IF (KASE .EQ. 2) CALL DMUMPS_SOL_MULR(N, Y, R_W(1, 2)) JUMP = 4 RETURN 150 CONTINUE IF (KASE .EQ. 1) CALL DMUMPS_SOL_MULR(N, Y, R_W(1, 2)) IF (KASE .EQ. 2) CALL DMUMPS_SOL_MULR(N, Y, D) GOTO 140 160 IF (DXIMAX .GT. ZERO) THEN COND(2) = COND(2) / DXIMAX ENDIF ERX = ERX + OMEGA(2) * COND(2) 170 CONTINUE RETURN END SUBROUTINE DMUMPS_SOL_LCOND SUBROUTINE DMUMPS_SOL_CPY_FS2RHSINTR( JBDEB, JBFIN, NBROWS, & KEEP, RHSINTR, NRHS, LRHSINTR, FIRST_ROW_RHSINTR, W, LD_W, & FIRST_ROW_W ) INTEGER :: JBDEB, JBFIN, NBROWS INTEGER :: NRHS, LRHSINTR INTEGER :: FIRST_ROW_RHSINTR INTEGER, INTENT(IN) :: KEEP(500) DOUBLE PRECISION, INTENT(INOUT) :: RHSINTR(LRHSINTR,NRHS) INTEGER :: LD_W, FIRST_ROW_W DOUBLE PRECISION :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER :: JJ, K, ISHIFT !$OMP PARALLEL DO PRIVATE(ISHIFT, JJ), IF !$OMP& (JBFIN-JBDEB+1 > 2*KEEP(362) .AND. !$OMP& NBROWS * (JBFIN-JBDEB+1) > 2*KEEP(363)) DO K = JBDEB, JBFIN ISHIFT = FIRST_ROW_W + LD_W * (K-JBDEB) DO JJ = 0, NBROWS-1 RHSINTR(FIRST_ROW_RHSINTR+JJ,K) = W(ISHIFT+JJ) END DO END DO !$OMP END PARALLEL DO RETURN END SUBROUTINE DMUMPS_SOL_CPY_FS2RHSINTR SUBROUTINE DMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSINTR, NRHS, LRHSINTR, W, LD_W, FIRST_ROW_W, & IW, LIW, KEEP, N, POSINRHSINTR_BWD ) INTEGER, INTENT(IN) :: JBDEB, JBFIN, J1, J2 INTEGER, INTENT(IN) :: NRHS, LRHSINTR INTEGER, INTENT(IN) :: FIRST_ROW_W, LD_W, LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: KEEP(500) DOUBLE PRECISION, INTENT(INOUT) :: RHSINTR(LRHSINTR,NRHS) DOUBLE PRECISION :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: POSINRHSINTR_BWD(N) INTEGER :: ISHIFT, JJ, K, IPOSINRHSINTR !$OMP PARALLEL DO PRIVATE(JJ,ISHIFT,IPOSINRHSINTR), IF !$OMP& ((JBFIN-JBDEB+1 > 2*KEEP(362) .AND. !$OMP& (JBFIN-JBDEB+1)*(J2-KEEP(253)-J1+1)>2*KEEP(363))) DO K=JBDEB, JBFIN ISHIFT = FIRST_ROW_W+(K-JBDEB)*LD_W DO JJ = J1, J2-KEEP(253) IPOSINRHSINTR = abs(POSINRHSINTR_BWD(IW(JJ))) W(ISHIFT+JJ-J1)= RHSINTR(IPOSINRHSINTR,K) ENDDO ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE DMUMPS_SOL_BWD_GTHR SUBROUTINE DMUMPS_SOL_Q(MTYPE, IFLAG, N, & LHS, WRHS, W, RES, GIVNORM, ANORM, XNORM, SCLNRM, & MPRINT, ICNTL, KEEP,KEEP8) INTEGER MTYPE,N,IFLAG,ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION RES(N),LHS(N) DOUBLE PRECISION WRHS(N) DOUBLE PRECISION W(N) DOUBLE PRECISION RESMAX,RESL2,XNORM, SCLNRM DOUBLE PRECISION ANORM,DZERO LOGICAL GIVNORM,PROK INTEGER MPRINT, MP INTEGER K INTRINSIC abs, max, sqrt MP = ICNTL(2) PROK = (MPRINT .GT. 0) DZERO = 0.0D0 IF (.NOT.GIVNORM) ANORM = DZERO RESMAX = DZERO RESL2 = DZERO DO 40 K = 1, N RESMAX = max(RESMAX, abs(RES(K))) RESL2 = RESL2 + abs(RES(K)) * abs(RES(K)) IF (.NOT.GIVNORM) ANORM = max(ANORM, W(K)) 40 CONTINUE XNORM = DZERO DO 50 K = 1, N XNORM = max(XNORM, abs(LHS(K))) 50 CONTINUE IF ( XNORM .EQ. DZERO .OR. (exponent(XNORM) .LT. & minexponent(XNORM) + KEEP(122) ) & .OR. & ( exponent(ANORM)+exponent(XNORM) .LT. & minexponent(XNORM) + KEEP(122) ) & .OR. & ( exponent(ANORM) + exponent(XNORM) -exponent(RESMAX) & .LT. minexponent(XNORM) + KEEP(122) ) & ) THEN IF (mod(IFLAG/2,2) .EQ. 0) THEN IFLAG = IFLAG + 2 ENDIF IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) & ' max-NORM of computed solut. is zero or close to zero. ' ENDIF IF (RESMAX .EQ. DZERO) THEN SCLNRM = DZERO ELSE SCLNRM = RESMAX / (ANORM * XNORM) ENDIF RESL2 = sqrt(RESL2) IF (PROK) WRITE( MPRINT, 90 ) RESMAX, RESL2, ANORM, XNORM, & SCLNRM 90 FORMAT (/' RESIDUAL IS ............ (INF-NORM) =',1PD9.2/ & ' .. (2-NORM) =',1PD9.2/ & ' RINFOG(4):NORM OF input Matrix (INF-NORM)=',1PD9.2/ & ' RINFOG(5):NORM OF Computed SOLUT (INF-NORM)=',1PD9.2/ & ' RINFOG(6):SCALED RESIDUAL ...... (INF-NORM)=',1PD9.2) RETURN END SUBROUTINE DMUMPS_SOL_Q SUBROUTINE DMUMPS_SOLVE_FWD_TRSOLVE (A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LDADIAG, NPIV, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT DOUBLE PRECISION, INTENT(IN) :: A(LA) DOUBLE PRECISION, INTENT(INOUT) :: WCB(LWCB) DOUBLE PRECISION ONE PARAMETER (ONE = 1.0D0) IF (KEEP(50).NE.0 .OR. MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dtrsv( 'U', 'T', 'U', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL dtrsm( 'L','U','T','U', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dtrsv( 'L', 'N', 'N', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL dtrsm( 'L','L','N','N', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF RETURN END SUBROUTINE DMUMPS_SOLVE_FWD_TRSOLVE SUBROUTINE DMUMPS_SOLVE_BWD_TRSOLVE (A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LDADIAG, NPIV, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT DOUBLE PRECISION, INTENT(IN) :: A(LA) DOUBLE PRECISION, INTENT(INOUT) :: WCB(LWCB) DOUBLE PRECISION ONE PARAMETER (ONE = 1.0D0) IF (MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dtrsv( 'L', 'T', 'N', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL dtrsm( 'L','L','T','N', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dtrsv( 'U', 'N', 'U', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL dtrsm( 'L','U','N','U', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF RETURN END SUBROUTINE DMUMPS_SOLVE_BWD_TRSOLVE SUBROUTINE DMUMPS_SOLVE_FWD_PANELS( & A, LA, APOS, NPIV, IW, & NRHS_B, WCB, LWCB, LDA_WCB, & PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, NPIV, KEEP(500) INTEGER, INTENT(IN) :: IW(NPIV) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT DOUBLE PRECISION, INTENT(IN) :: A(LA) DOUBLE PRECISION, INTENT(INOUT) :: WCB(LWCB) INTEGER :: NB_TARGET INTEGER :: NBPANELS INTEGER :: NBROWS_PANEL, NBCOLS_PANEL, ICOL_BEG, ICOL_END INTEGER(8) :: PANEL_APOS, PPIV_PANEL DOUBLE PRECISION, PARAMETER :: ONE=1.0D0 IF (KEEP(459) .LE. 1) THEN WRITE(*,*) " Internal error in DMUMPS_SOLVE_FWD_PANELS" CALL MUMPS_ABORT() ENDIF CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, NB_TARGET, KEEP ) PANEL_APOS = APOS NBPANELS = 0 ICOL_BEG = 1 NBROWS_PANEL = NPIV PPIV_PANEL = PPIV_COURANT DO WHILE ( ICOL_BEG .LE. NPIV ) NBPANELS = NBPANELS + 1 ICOL_END = min(NB_TARGET * NBPANELS, NPIV) IF ( IW(ICOL_END) .LT. 0 ) ICOL_END=ICOL_END+1 NBCOLS_PANEL = ICOL_END - ICOL_BEG + 1 CALL DMUMPS_SOLVE_FWD_TRSOLVE (A, LA, PANEL_APOS, & NBCOLS_PANEL, NBCOLS_PANEL, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_PANEL, MTYPE, KEEP) IF ( NBROWS_PANEL .GT. NBCOLS_PANEL ) THEN CALL DMUMPS_SOLVE_GEMM_UPDATE( A, LA, & PANEL_APOS + int(NBCOLS_PANEL,8) * int(NBCOLS_PANEL,8), & NBCOLS_PANEL, NBCOLS_PANEL, NBROWS_PANEL-NBCOLS_PANEL, & NRHS_B, WCB, LWCB, PPIV_PANEL, LDA_WCB, & PPIV_PANEL+NBCOLS_PANEL, LDA_WCB, & MTYPE, KEEP, ONE ) ENDIF ICOL_BEG = ICOL_END + 1 PANEL_APOS = PANEL_APOS + int(NBCOLS_PANEL,8) * & int(NBROWS_PANEL,8) NBROWS_PANEL = NBROWS_PANEL - NBCOLS_PANEL PPIV_PANEL = PPIV_PANEL + NBCOLS_PANEL ENDDO RETURN END SUBROUTINE DMUMPS_SOLVE_FWD_PANELS SUBROUTINE DMUMPS_SOLVE_BWD_PANELS( & A, LA, APOS, NPIV, IW, & NRHS_B, WCB, LWCB, LDA_WCB, & PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, NPIV, KEEP(500) INTEGER, INTENT(IN) :: IW(NPIV) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT DOUBLE PRECISION, INTENT(IN) :: A(LA) DOUBLE PRECISION, INTENT(INOUT) :: WCB(LWCB) INTEGER, PARAMETER :: PANEL_TABSIZE = 20 INTEGER(8) :: PANEL_POS(PANEL_TABSIZE) INTEGER :: PANEL_COL(PANEL_TABSIZE) INTEGER :: IPANEL, NBPANELS, NB_TARGET INTEGER :: NBROWS_PANEL, NBCOLS_PANEL INTEGER(8) :: PPIV_PANEL INTEGER :: MTYPE_TEMP DOUBLE PRECISION, PARAMETER :: ONE=1.0D0 IF (KEEP(459) .LE. 1) THEN WRITE(*,*) " Internal error 1 in DMUMPS_SOLVE_BWD_PANELS" CALL MUMPS_ABORT() ENDIF IF ( KEEP(459)+1 .GT. PANEL_TABSIZE ) THEN WRITE(*,*) " Internal error 2 in DMUMPS_SOLVE_BWD_PANELS" CALL MUMPS_ABORT() ENDIF CALL MUMPS_LDLTPANEL_PANELINFOS( NPIV, KEEP, IW, &NB_TARGET, NBPANELS, PANEL_COL, PANEL_POS, PANEL_TABSIZE, &.FALSE. ) DO IPANEL = NBPANELS, 1, -1 NBCOLS_PANEL = PANEL_COL( IPANEL+1 ) - PANEL_COL( IPANEL ) NBROWS_PANEL = NPIV - PANEL_COL( IPANEL ) + 1 PPIV_PANEL = PPIV_COURANT + PANEL_COL( IPANEL ) - 1 IF ( NBROWS_PANEL .GT. NBCOLS_PANEL ) THEN MTYPE_TEMP = 0 CALL DMUMPS_SOLVE_GEMM_UPDATE( A, LA, & APOS-1_8+PANEL_POS(IPANEL)+ & int(NBCOLS_PANEL,8)*int(NBCOLS_PANEL,8), & NBROWS_PANEL-NBCOLS_PANEL, NBCOLS_PANEL, & NBCOLS_PANEL, & NRHS_B, WCB, LWCB, PPIV_PANEL+NBCOLS_PANEL, LDA_WCB, & PPIV_PANEL, LDA_WCB, & MTYPE_TEMP, KEEP, ONE ) ENDIF CALL DMUMPS_SOLVE_BWD_TRSOLVE (A, LA, & APOS+PANEL_POS(IPANEL)-1_8, & NBCOLS_PANEL, NBCOLS_PANEL, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_PANEL, MTYPE, KEEP) ENDDO RETURN END SUBROUTINE DMUMPS_SOLVE_BWD_PANELS SUBROUTINE DMUMPS_SOLVE_GEMM_UPDATE & (A, LA, APOS1, NX, LDA, NY, & NRHS_B, WCB, LWCB, PTRX, LDX, & PTRY, LDY, & MTYPE, KEEP, COEF_Y ) INTEGER, INTENT(IN) :: MTYPE, NY, NX, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDY, LDA, LDX INTEGER(8), INTENT(IN) :: LA, APOS1, LWCB, PTRX, & PTRY DOUBLE PRECISION, INTENT(IN) :: A(LA) DOUBLE PRECISION, INTENT(INOUT) :: WCB(LWCB) DOUBLE PRECISION, INTENT(IN) :: COEF_Y DOUBLE PRECISION ALPHA, ZERO, ONE PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, ALPHA=-1.0D0) IF ( NX .NE. 0 .AND. NY.NE.0 ) THEN IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dgemv('T', NX, NY, ALPHA, A(APOS1), & LDA, WCB(PTRX), 1, COEF_Y, & WCB(PTRY), 1) ELSE #endif CALL dgemm('T', 'N', NY, NRHS_B, NX, ALPHA, & A(APOS1), LDA, WCB(PTRX), LDX, COEF_Y, & WCB(PTRY), LDY) #if defined(MUMPS_USE_BLAS2) END IF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dgemv('N',NY, NX, ALPHA, A(APOS1), & LDA, WCB(PTRX), 1, & COEF_Y, WCB(PTRY), 1 ) ELSE #endif CALL dgemm('N', 'N', NY, NRHS_B, NX, ALPHA, & A(APOS1), LDA, WCB(PTRX), LDX, & COEF_Y, WCB(PTRY), LDY) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF END IF RETURN END SUBROUTINE DMUMPS_SOLVE_GEMM_UPDATE SUBROUTINE DMUMPS_SOL_LD_AND_RELOAD_PANEL ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & IGNORE_K459 & ) USE DMUMPS_OOC IMPLICIT NONE INTEGER, INTENT(IN) :: MTYPE, INODE, N, NPIV, LIELL, & NELIM, NSLAVES INTEGER, INTENT(IN) :: LRHSINTR, NRHS, LIW, JBDEB, JBFIN INTEGER, INTENT(IN) :: IW(LIW), IPOS, POSINRHSINTR_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, APOS, LA, PPIV_COURANT INTEGER, INTENT(IN) :: LD_WCBPIV INTEGER, INTENT(IN) :: KEEP(500) DOUBLE PRECISION, INTENT(IN) :: WCB( LWCB ) DOUBLE PRECISION, INTENT(IN) :: A( LA ) DOUBLE PRECISION, INTENT(INOUT) :: RHSINTR(LRHSINTR, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL, INTENT(IN) :: IGNORE_K459 INTEGER :: J1, J3 INTEGER :: IPOSINRHSINTR, JJ, K, & LDAJ, NRHS_B INTEGER(8) :: IFR8 , APOS1, APOS2, APOSOFF, IFR_ini8, & POSWCB1, POSWCB2 DOUBLE PRECISION :: VALPIV, A11, A22, A12, DETPIV INTEGER, PARAMETER :: PANEL_TABSIZE = 20 INTEGER(8) :: PANEL_POS(PANEL_TABSIZE) INTEGER :: PANEL_COL(PANEL_TABSIZE) INTEGER :: IPANEL, ICOL, NBPANELS, NB_TARGET LOGICAL :: SKIP_IT LOGICAL :: OMP_FLAG DOUBLE PRECISION ONE PARAMETER (ONE = 1.0D0) IF ( NPIV.EQ. 0 ) RETURN NRHS_B = JBFIN-JBDEB+1 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J3 = IPOS + LIELL + NPIV END IF IPOSINRHSINTR = POSINRHSINTR_FWD(IW(J1)) IF ( KEEP(50) .eq. 0 ) THEN OMP_FLAG = .FALSE. !$ OMP_FLAG=(int(NRHS_B,8)*int(NPIV,8).GE.int(KEEP(363),8)) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(IFR8) COLLAPSE(2) DO K = JBDEB, JBFIN DO IFR8 = 0_8, int(NPIV-1,8) RHSINTR(IPOSINRHSINTR+IFR8, K) = & WCB(PPIV_COURANT+(K-JBDEB)*LD_WCBPIV+IFR8) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K = JBDEB, JBFIN DO IFR8 = 0_8, int(NPIV-1,8) RHSINTR(IPOSINRHSINTR+IFR8, K) = & WCB(PPIV_COURANT+(K-JBDEB)*LD_WCBPIV+IFR8) ENDDO ENDDO ENDIF ELSE CALL MUMPS_LDLTPANEL_PANELINFOS( NPIV, KEEP, IW(IPOS+LIELL+1), & NB_TARGET, NBPANELS, PANEL_COL, PANEL_POS, PANEL_TABSIZE, & IGNORE_K459 ) IFR_ini8 = PPIV_COURANT !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & ((J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363))) !$OMP PARALLEL DO PRIVATE(JJ,IFR8,APOS1,APOS2,APOSOFF,VALPIV, !$OMP& IPANEL,ICOL, !$OMP& POSWCB1,POSWCB2,A11,A22,A12,DETPIV,LDAJ,SKIP_IT) !$OMP& IF(OMP_FLAG) DO K = JBDEB, JBFIN DO JJ = J1, J3 IPANEL = (JJ-J1)/NB_TARGET + 1 IF ( JJ-J1+1 .LT. PANEL_COL(IPANEL) ) IPANEL = IPANEL -1 ICOL = JJ-J1+1 - PANEL_COL(IPANEL) + 1 LDAJ = PANEL_COL(IPANEL+1) - PANEL_COL(IPANEL) APOS1 = APOS-1_8+PANEL_POS( IPANEL ) + int(ICOL-1,8) * & int(LDAJ+1,8) IFR8 = IFR_ini8 + int(K-JBDEB,8)*int(LD_WCBPIV,8) + & int(JJ-J1,8) IF ( JJ .NE. J1 ) THEN IF ( IW(LIELL+JJ-1) .LT. 0 ) THEN SKIP_IT = .TRUE. ELSE SKIP_IT = .FALSE. ENDIF ELSE SKIP_IT = .FALSE. ENDIF IF (SKIP_IT) THEN ELSE IF ( IW(JJ+LIELL) .GT. 0 ) THEN VALPIV = ONE/A( APOS1 ) RHSINTR(IPOSINRHSINTR+JJ-J1 , K ) = & WCB( IFR8 ) * VALPIV APOS1 = APOS1 + int(LDAJ + 1,8) ELSE APOS2 = APOS1+int(LDAJ+1,8) APOSOFF=APOS1+1_8 A11 = A(APOS1) A22 = A(APOS2) A12 = A(APOSOFF) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(APOS2)/DETPIV A12 = -A12/DETPIV POSWCB1 = IFR8 POSWCB2 = POSWCB1+1_8 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSINTR(IPOSINRHSINTR+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 ENDIF ENDDO ENDDO !$OMP END PARALLEL DO END IF RETURN END SUBROUTINE DMUMPS_SOL_LD_AND_RELOAD_PANEL SUBROUTINE DMUMPS_SOL_LD_AND_RELOAD ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & IGNORE_K459 & ) USE DMUMPS_OOC INTEGER, INTENT(IN) :: MTYPE, INODE, N, NPIV, LIELL, & NELIM, NSLAVES INTEGER, INTENT(IN) :: LRHSINTR, NRHS, LIW, JBDEB, JBFIN INTEGER, INTENT(IN) :: IW(LIW), IPOS, POSINRHSINTR_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, APOS, LA, PPIV_COURANT INTEGER, INTENT(IN) :: LD_WCBPIV INTEGER, INTENT(IN) :: KEEP(500) DOUBLE PRECISION, INTENT(IN) :: WCB( LWCB ) DOUBLE PRECISION, INTENT(IN) :: A( LA ) DOUBLE PRECISION, INTENT(INOUT) :: RHSINTR(LRHSINTR, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL, INTENT(IN) :: IGNORE_K459 INTEGER :: TempNROW, J1, J3, PANEL_SIZE INTEGER :: IPOSINRHSINTR, JJ, K, NBK, LDAJ, & LDAJ_ini, NBK_ini, LDAJ_FIRST_PANEL, NRHS_B INTEGER(8) :: IFR8 , APOS1, APOS2, APOSOFF, IFR_ini8, & POSWCB1, POSWCB2 DOUBLE PRECISION :: VALPIV, A11, A22, A12, DETPIV !$ LOGICAL :: OMP_FLAG DOUBLE PRECISION ONE PARAMETER (ONE = 1.0D0) NRHS_B = JBFIN-JBDEB+1 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J3 = IPOS + LIELL + NPIV END IF IPOSINRHSINTR = POSINRHSINTR_FWD(IW(J1)) IF ( KEEP(50) .eq. 0 ) THEN !$ OMP_FLAG=(NRHS_B.GE.KEEP(362).AND.NRHS_B*NPIV.GE.KEEP(363)) !$OMP PARALLEL DO PRIVATE(IFR8) IF (OMP_FLAG) DO K=JBDEB,JBFIN IFR8 = PPIV_COURANT + (K-JBDEB)*LD_WCBPIV RHSINTR(IPOSINRHSINTR:IPOSINRHSINTR+NPIV-1, K) = & WCB(IFR8:IFR8+int(NPIV-1,8)) ENDDO !$OMP END PARALLEL DO ELSE IFR8 = PPIV_COURANT - 1_8 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN IF (MTYPE.EQ.1) THEN IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN TempNROW= NPIV+NELIM LDAJ_FIRST_PANEL=TempNROW ELSE TempNROW= LIELL LDAJ_FIRST_PANEL=TempNROW ENDIF ELSE TempNROW= NPIV LDAJ_FIRST_PANEL=LIELL ENDIF PANEL_SIZE = DMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) LDAJ = TempNROW ELSE IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 & .AND. .NOT. IGNORE_K459 ) THEN CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, PANEL_SIZE, KEEP ) LDAJ = PANEL_SIZE ELSE PANEL_SIZE = -1 LDAJ = NPIV ENDIF ENDIF IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN NBK = 0 ENDIF IFR_ini8 = PPIV_COURANT - 1_8 LDAJ_ini = LDAJ IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & NBK_ini = NBK !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & ((J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363))) !$OMP PARALLEL DO PRIVATE(JJ,IFR8,NBK,APOS1,APOS2,APOSOFF,VALPIV, !$OMP& POSWCB1, POSWCB2,A11,A22,A12,DETPIV,LDAJ) IF(OMP_FLAG) DO K = JBDEB, JBFIN IFR8 = IFR_ini8 + int(K-JBDEB,8)*int(LD_WCBPIV,8) NBK = NBK_ini APOS1 = APOS LDAJ = LDAJ_ini JJ = J1 DO IF (JJ .GT. J3) EXIT IFR8 = IFR8 + 1_8 IF (IW(JJ+LIELL) .GT. 0) THEN VALPIV = ONE/A( APOS1 ) RHSINTR(IPOSINRHSINTR+JJ-J1 , K ) = & WCB( IFR8 ) * VALPIV IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 IF (NBK.EQ.PANEL_SIZE) THEN NBK = 0 LDAJ = LDAJ - PANEL_SIZE ENDIF ENDIF APOS1 = APOS1 + int(LDAJ + 1,8) JJ = JJ+1 ELSE IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 ENDIF APOS2 = APOS1+int(LDAJ+1,8) IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN APOSOFF = APOS1+int(LDAJ,8) ELSE APOSOFF=APOS1+1_8 ENDIF A11 = A(APOS1) A22 = A(APOS2) A12 = A(APOSOFF) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(APOS2)/DETPIV A12 = -A12/DETPIV POSWCB1 = IFR8 POSWCB2 = POSWCB1+1_8 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSINTR(IPOSINRHSINTR+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 IF (NBK.GE.PANEL_SIZE) THEN LDAJ = LDAJ - NBK NBK = 0 ENDIF ENDIF APOS1 = APOS2 + int(LDAJ + 1,8) JJ = JJ+2 IFR8 = IFR8+1_8 ENDIF ENDDO ENDDO !$OMP END PARALLEL DO END IF RETURN END SUBROUTINE DMUMPS_SOL_LD_AND_RELOAD SUBROUTINE DMUMPS_SET_SCALING_LOC( scaling_data, N, ILOC, LILOC, & COMM, MYID, I_AM_SLAVE, MASTER, NB_BYTES, NB_BYTES_MAX, & K16_8, LP, LPOK, ICNTL, INFO ) IMPLICIT NONE type scaling_data_t SEQUENCE DOUBLE PRECISION, dimension(:), pointer :: SCALING DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC INTEGER, dimension(:), pointer :: SCALING_IND end type scaling_data_t type (scaling_data_t), INTENT(INOUT) :: scaling_data INTEGER, INTENT(IN) :: N, LILOC, COMM, MYID, MASTER, LP INTEGER, INTENT(IN) :: ILOC(LILOC) INTEGER(8), INTENT(INOUT) :: NB_BYTES, NB_BYTES_MAX INTEGER(8), INTENT(IN) :: K16_8 LOGICAL, INTENT(IN) :: I_AM_SLAVE, LPOK INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(IN) :: ICNTL(60) DOUBLE PRECISION, POINTER, DIMENSION(:) :: SCALING INTEGER :: I, IERR_MPI, allocok INCLUDE 'mpif.h' NULLIFY(scaling_data%SCALING_LOC) IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data%SCALING_LOC(max(1,LILOC)), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(1,LILOC) GOTO 35 ENDIF NB_BYTES = NB_BYTES + int(max(1,LILOC),8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF IF (MYID .NE. MASTER) THEN ALLOCATE(SCALING(N), stat=allocok) IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating temporary scaling array' ENDIF INFO(1)=-13 INFO(2)=N GOTO 35 ENDIF NB_BYTES = NB_BYTES + int(N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE SCALING => scaling_data%SCALING ENDIF 35 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF (INFO(1) .LT. 0) GOTO 90 CALL MPI_BCAST( SCALING(1), N, MPI_DOUBLE_PRECISION, & MASTER, COMM, IERR_MPI) IF ( I_AM_SLAVE ) THEN DO I = 1, LILOC IF (ILOC(I) .GE. 1 .AND. ILOC(I) .LE. N) THEN scaling_data%SCALING_LOC(I) = SCALING(ILOC(I)) ENDIF ENDDO ENDIF 90 CONTINUE IF (MYID.NE. MASTER) THEN IF (associated(SCALING)) THEN DEALLOCATE(SCALING) NB_BYTES = NB_BYTES - int(N,8)*K16_8 ENDIF ENDIF NULLIFY(SCALING) IF (INFO(1) .LT. 0) THEN IF (associated(scaling_data%SCALING_LOC)) THEN DEALLOCATE(scaling_data%SCALING_LOC) NULLIFY(scaling_data%SCALING_LOC) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SET_SCALING_LOC MUMPS_5.8.1/src/mumps_mpitoomp_m.F0000664000175000017500000000103115042446423016734 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_MPITOOMP_M_RETURN() RETURN END SUBROUTINE MUMPS_MPITOOMP_M_RETURN MUMPS_5.8.1/src/stype3_root.F0000664000175000017500000016052515042446437015650 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ASS_ROOT( root, roota, KEEP50, & NROW_SON, NCOL_SON, INDROW_SON, & INDCOL_SON, NSUPCOL, VAL_SON, VAL_ROOT, & LOCAL_M, LOCAL_N, & RHS_ROOT, NLOC_ROOT, CBP ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER, INTENT(IN) :: KEEP50 INTEGER NCOL_SON, NROW_SON, NSUPCOL INTEGER, intent(in) :: CBP INTEGER INDROW_SON( NROW_SON ), INDCOL_SON( NCOL_SON ) INTEGER LOCAL_M, LOCAL_N REAL VAL_SON( NCOL_SON, NROW_SON ) REAL VAL_ROOT( LOCAL_M, LOCAL_N ) INTEGER NLOC_ROOT REAL RHS_ROOT( LOCAL_M, NLOC_ROOT ) INTEGER I, J, INDROW, INDCOL, IPOSROOT, JPOSROOT IF (CBP .EQ. 0) THEN DO I = 1, NROW_SON INDROW = INDROW_SON(I) IPOSROOT = (root%NPROW*((INDROW-1)/root%MBLOCK)+root%MYROW) & * root%MBLOCK + mod(INDROW-1,root%MBLOCK) + 1 DO J = 1, NCOL_SON-NSUPCOL INDCOL = INDCOL_SON(J) IF (KEEP50.NE.0) THEN JPOSROOT = (root%NPCOL*((INDCOL-1)/root%NBLOCK)+root%MYCOL) & * root%NBLOCK + mod(INDCOL-1,root%NBLOCK) + 1 IF (IPOSROOT < JPOSROOT) THEN CYCLE ENDIF ENDIF VAL_ROOT( INDROW, INDCOL ) = & VAL_ROOT( INDROW, INDCOL ) + VAL_SON(J,I) END DO DO J = NCOL_SON-NSUPCOL+1, NCOL_SON INDCOL = INDCOL_SON(J) RHS_ROOT( INDROW, INDCOL ) = & RHS_ROOT( INDROW, INDCOL ) + VAL_SON(J,I) ENDDO END DO ELSE DO I=1, NROW_SON DO J = 1, NCOL_SON RHS_ROOT( INDROW_SON( I ), INDCOL_SON(J)) = & RHS_ROOT(INDROW_SON(I),INDCOL_SON(J)) + VAL_SON(J,I) ENDDO ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_ASS_ROOT RECURSIVE SUBROUTINE SMUMPS_BUILD_AND_SEND_CB_ROOT & ( COMM_LOAD, ASS_IRECV, N, ISON, IROOT, & PTRI, PTRR, & root, roota, NBROW, NBCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, SHIFT_VAL_SON_ARG, LDA_ARG, TAG, & MYID, COMM, BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,TRANSPOSE_ASM, & ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS, NELIM_ROOT, NELIM_ROW, NELIM_COL & ) USE SMUMPS_OOC USE SMUMPS_BUF USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER N, ISON, IROOT, TAG INTEGER PTRI( KEEP(28) ) INTEGER(8) :: PTRR( KEEP(28) ) INTEGER NBROW, NBCOL INTEGER, INTENT(IN):: LDA_ARG INTEGER(8), INTENT(IN) :: SHIFT_VAL_SON_ARG INTEGER SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER MYID, COMM LOGICAL TRANSPOSE_ASM INTEGER :: NELIM_ROOT, NELIM_ROW, NELIM_COL INCLUDE 'mpif.h' INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NSTK( N ) INTEGER COMP, IFLAG, IERROR INTEGER PERM(N) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28)) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER INTARR( KEEP8(27) ) REAL DBLARR( KEEP8(26) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) REAL, DIMENSION(:), POINTER :: SONA_PTR INTEGER(8) :: LSONA_PTR, POSSONA_PTR INTEGER allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: PTRROW, PTRCOL INTEGER, ALLOCATABLE, DIMENSION(:) :: NSUPROW, NSUPCOL INTEGER, ALLOCATABLE, DIMENSION(:) :: ROW_INDEX_LIST INTEGER, ALLOCATABLE, DIMENSION(:) :: COL_INDEX_LIST INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER I, POS_IN_ROOT, IROW, JCOL, IGLOB, JGLOB INTEGER PDEST, IERR INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: POSROOT INTEGER NSUBSET_ROW, NSUBSET_COL INTEGER NRLOCAL, NCLOCAL INTEGER :: LDA INTEGER(8) :: SHIFT_VAL_SON LOGICAL SET_IRECV, BLOCKING, MESSAGE_RECEIVED INTEGER NBROWS_ALREADY_SENT INTEGER SIZE_MSG INTEGER LP INCLUDE 'mumps_headers.h' LOGICAL SKIPLAST_RHS_ROWS, BCP_SYM_NONEMPTY INTEGER BBPCBP BBPCBP = 0 LP = ICNTL(1) IF ( ICNTL(4) .LE. 0 ) LP = -1 IF (LDA_ARG < 0) THEN CALL SMUMPS_SET_LDA_SHIFT_VAL_SON(IW, LIW, PTRI(STEP(ISON)), & LDA, SHIFT_VAL_SON) ELSE LDA = LDA_ARG SHIFT_VAL_SON = SHIFT_VAL_SON_ARG ENDIF ALLOCATE(PTRROW(root%NPROW + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPROW + 1 endif ALLOCATE(PTRCOL(root%NPCOL + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPCOL + 1 endif ALLOCATE(NSUPROW(root%NPROW + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPROW + 1 endif ALLOCATE(NSUPCOL(root%NPCOL + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPCOL + 1 endif IF (IFLAG.LT.0) THEN IF (LP > 0) write(6,*) MYID, ' : MEMORY ALLOCATION ', & 'FAILURE in SMUMPS_BUILD_AND_SEND_CB_ROOT' CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF SKIPLAST_RHS_ROWS = ((KEEP(253).GT.0).AND.(KEEP(50).EQ.0)) BCP_SYM_NONEMPTY = .FALSE. PTRROW = 0 PTRCOL = 0 NSUPROW = 0 NSUPCOL = 0 DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (IGLOB.GT.N) THEN BCP_SYM_NONEMPTY = .TRUE. POS_IN_ROOT = IGLOB - N JCOL = mod((POS_IN_ROOT-1)/root%NBLOCK,root%NPCOL) NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 ELSE IF ( I .LE. NELIM_ROW ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( IGLOB ) ENDIF 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 IF ( I .LE. NELIM_ROW ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( IGLOB ) ENDIF ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, root%NPCOL ) IF (IGLOB.GT.N) & NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 END IF END DO IF (KEEP(50).NE.0 .AND.(.NOT.TRANSPOSE_ASM).AND.BCP_SYM_NONEMPTY) & BBPCBP = 1 DO I = 1, NBCOL JGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_COL_SON + I - 1 ) IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (KEEP(50).EQ.0) THEN IF (JGLOB.LE.N) THEN IF ( I.LE.NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L(JGLOB) ENDIF 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 IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( JGLOB ) ENDIF JCOL = mod((POS_IN_ROOT-1) / root%NBLOCK, root%NPCOL ) PTRCOL ( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 IF (BCP_SYM_NONEMPTY) THEN 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 IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( JGLOB ) ENDIF ELSE POS_IN_ROOT = JGLOB-N ENDIF IROW = mod( ( POS_IN_ROOT - 1 ) / & root%MBLOCK, root%NPROW ) PTRROW ( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 END IF END DO PTRROW( 1 ) = 1 DO IROW = 2, root%NPROW + 1 PTRROW( IROW ) = PTRROW( IROW ) + PTRROW( IROW - 1 ) END DO PTRCOL( 1 ) = 1 DO JCOL = 2, root%NPCOL + 1 PTRCOL( JCOL ) = PTRCOL( JCOL ) + PTRCOL( JCOL - 1 ) END DO ALLOCATE(ROW_INDEX_LIST(PTRROW(root%NPROW+1)-1+1), & stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = PTRROW(root%NPROW+1)-1+1 endif ALLOCATE(COL_INDEX_LIST(PTRCOL(root%NPCOL+1)-1+1), & stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = PTRCOL(root%NPCOL+1)-1+1 endif DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (IGLOB.GT.N) CYCLE IF ( I .LE. NELIM_ROW ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( IGLOB ) 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 ELSE IF (IGLOB.LE.N) THEN IF ( I .LE. NELIM_ROW ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( IGLOB ) ENDIF ELSE POS_IN_ROOT = IGLOB - N ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, & root%NPCOL ) COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 END IF END DO DO I = 1, NBCOL JGLOB = IW( PTRI(STEP(ISON))+SHIFT_LIST_COL_SON+I - 1 ) IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF ( JGLOB.LE.N ) THEN IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( JGLOB ) ENDIF 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 IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( JGLOB ) ENDIF 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 IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L(JGLOB) ENDIF ENDIF IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I PTRROW( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 ENDDO ENDIF DO IROW = root%NPROW, 2, -1 PTRROW( IROW ) = PTRROW( IROW - 1 ) END DO PTRROW( 1 ) = 1 DO JCOL = root%NPCOL, 2, -1 PTRCOL( JCOL ) = PTRCOL( JCOL - 1 ) END DO PTRCOL( 1 ) = 1 JCOL = root%MYCOL IROW = root%MYROW IF ( root%yes ) THEN if (IROW .ne. root%MYROW .or. JCOL.ne.root%MYCOL) then write(*,*) ' error in grid position buildandsendcbroot' CALL MUMPS_ABORT() end if IF ( PTRIST(STEP(IROOT)).EQ.0.AND. & PTLUST_S(STEP(IROOT)).EQ.0) THEN CALL SMUMPS_ROOT_ALLOC_STATIC(root, roota, IROOT, N, IW, LIW, & A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP, IERROR ) KEEP(121) = -1 IF (IFLAG.LT.0) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF ELSE KEEP(121) = KEEP(121) - 1 IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL SMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL SMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL SMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT+N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF END IF CALL SMUMPS_DM_SET_DYNPTR( IW(PTRI(STEP(ISON))+XXS), A, LA, & PTRR(STEP(ISON)), IW(PTRI(STEP(ISON))+XXD), & IW(PTRI(STEP(ISON))+XXR), & SONA_PTR, POSSONA_PTR, LSONA_PTR ) IF (KEEP(60) .NE. 0 ) THEN LOCAL_M = root%SCHUR_LLD LOCAL_N = root%SCHUR_NLOC NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) CALL SMUMPS_ROOT_LOCAL_ASSEMBLY( N, & roota%SCHUR_POINTER(1), & LOCAL_M, LOCAL_N, & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NRLOCAL, & NCLOCAL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%RG2L(1), TRANSPOSE_ASM, & KEEP, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) ELSE IF ( PTRIST(STEP( IROOT )) .GE. 0 ) THEN IF ( PTRIST(STEP( IROOT )) .EQ. 0 ) THEN LOCAL_N = IW( PTLUST_S(STEP(IROOT)) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST_S(STEP(IROOT)) + 2 + KEEP(IXSZ)) POSROOT = PTRFAC(IW( PTLUST_S(STEP(IROOT)) +4+KEEP(IXSZ) )) ELSE LOCAL_N = - IW( PTRIST(STEP(IROOT)) +KEEP(IXSZ)) LOCAL_M = IW( PTRIST(STEP(IROOT)) + 1 +KEEP(IXSZ)) POSROOT = PAMASTER(STEP( IROOT )) ENDIF NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) CALL SMUMPS_ROOT_LOCAL_ASSEMBLY( N, A( POSROOT ), & LOCAL_M, LOCAL_N, & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NRLOCAL, & NCLOCAL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%RG2L(1), TRANSPOSE_ASM, & KEEP, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) END IF ENDIF END IF DO IROW = 0, root%NPROW - 1 DO JCOL = 0, root%NPCOL - 1 PDEST = IROW * root%NPCOL + JCOL IF ( (root%MYROW.eq.IROW.and.root%MYCOL.eq.JCOL) .and. & MYID.ne.PDEST) THEN write(*,*) 'error: myrow,mycol=',root%MYROW,root%MYCOL write(*,*) ' MYID,PDEST=',MYID,PDEST CALL MUMPS_ABORT() END IF IF ( root%MYROW .NE. IROW .OR. root%MYCOL .NE. JCOL) THEN NBROWS_ALREADY_SENT = 0 IERR = -1 DO WHILE ( IERR .EQ. -1 ) NSUBSET_ROW = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) NSUBSET_COL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) IF ( LRLU .LT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) & .AND. LRLUS .GT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) ) & THEN CALL SMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) MYID,": pb compress in", & "SMUMPS_BUILD_AND_SEND_CB_ROOT" WRITE(*,*) MYID,': LRLU, LRLUS=',LRLU,LRLUS CALL MUMPS_ABORT() END IF END IF CALL SMUMPS_DM_SET_DYNPTR( & IW(PTRI(STEP(ISON))+XXS), A, LA, & PTRR(STEP(ISON)), IW(PTRI(STEP(ISON))+XXD), & IW(PTRI(STEP(ISON))+XXR), & SONA_PTR, POSSONA_PTR, LSONA_PTR ) CALL SMUMPS_BUF_SEND_CONTRIB_TYPE3_I( N, ISON, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & TAG, & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NSUBSET_ROW, NSUBSET_COL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%NPROW, root%NPCOL, root%MBLOCK, & root%RG2L(1), & root%NBLOCK, PDEST, & COMM, IERR, A( POSFAC ), LRLU, TRANSPOSE_ASM, & SIZE_MSG, NBROWS_ALREADY_SENT, KEEP, BBPCBP, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK, & COMP, IFLAG, IERROR, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, MYID, SLAVEF, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW,PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (LDA_ARG < 0) THEN CALL SMUMPS_SET_LDA_SHIFT_VAL_SON( & IW, LIW, PTRI(STEP(ISON)), & LDA, SHIFT_VAL_SON) ENDIF END IF END DO IF ( IERR == -2 ) THEN IFLAG = -17 IERROR = SIZE_MSG IF (LP > 0) WRITE(LP, *) "FAILURE, SEND BUFFER TOO & SMALL DURING SMUMPS_BUILD_AND_SEND_CB_ROOT" CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 500 ENDIF IF ( IERR == -3 ) THEN IF (LP > 0) WRITE(LP, *) "FAILURE, RECV BUFFER TOO & SMALL DURING SMUMPS_BUILD_AND_SEND_CB_ROOT" IFLAG = -20 IERROR = SIZE_MSG CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 500 ENDIF END IF END DO END DO 500 CONTINUE DEALLOCATE(PTRROW) DEALLOCATE(PTRCOL) DEALLOCATE(ROW_INDEX_LIST) DEALLOCATE(COL_INDEX_LIST) RETURN CONTAINS SUBROUTINE SMUMPS_SET_LDA_SHIFT_VAL_SON(IW, LIW, IOLDPS, & LDA, SHIFT_VAL_SON) INTEGER, INTENT(IN) :: LIW, IOLDPS INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT) :: LDA INTEGER(8), INTENT(OUT) :: SHIFT_VAL_SON INCLUDE 'mumps_headers.h' INTEGER :: LCONT, NROW, NPIV, NASS, NELIM LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV IF (IW(IOLDPS+XXS).EQ.S_NOLCBNOCONTIG38.OR. & IW(IOLDPS+XXS).EQ.S_ALL) THEN SHIFT_VAL_SON = int(NPIV,8) LDA = LCONT + NPIV ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCBCONTIG38) THEN SHIFT_VAL_SON = int(NROW,8)*int(LCONT+NPIV-NELIM,8) LDA = NELIM ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCLEANED38) THEN SHIFT_VAL_SON=0_8 LDA = NELIM ELSE WRITE(*,*) MYID, & ": internal error in SMUMPS_SET_LDA_SHIFT_VAL_SON", & IW(IOLDPS+XXS), "ISON=",ISON CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE SMUMPS_SET_LDA_SHIFT_VAL_SON END SUBROUTINE SMUMPS_BUILD_AND_SEND_CB_ROOT SUBROUTINE SMUMPS_ROOT_LOCAL_ASSEMBLY( N, VAL_ROOT, & LOCAL_M, LOCAL_N, & NPCOL, NPROW, MBLOCK, NBLOCK, NBCOL_SON, NBROW_SON, INDCOL_SON, & INDROW_SON, LD_SON, VAL_SON, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, NSUPROW, NSUPCOL, & RG2L, TRANSPOSE_ASM, & KEEP, RHS_ROOT, NLOC, NELIM_ROOT, NELIM_ROW, NELIM_COL ) IMPLICIT NONE INTEGER N, LOCAL_M, LOCAL_N REAL VAL_ROOT( LOCAL_M, LOCAL_N ) INTEGER NPCOL, NPROW, MBLOCK, NBLOCK INTEGER NBCOL_SON, NBROW_SON INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER LD_SON INTEGER NSUPROW, NSUPCOL REAL VAL_SON( LD_SON, NBROW_SON ) INTEGER KEEP(500) INTEGER NSUBSET_ROW, NSUBSET_COL INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER RG2L( N ) LOGICAL TRANSPOSE_ASM INTEGER NLOC REAL RHS_ROOT( LOCAL_M, NLOC) INTEGER :: NELIM_ROOT, NELIM_ROW, NELIM_COL 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 ) IF ( I .LE. NELIM_ROW ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L( IGLOB ) ENDIF 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 ) IF ( J .LE. NELIM_COL ) THEN JPOS_ROOT = NELIM_ROOT + J - 1 ELSE JPOS_ROOT = RG2L( JGLOB ) ENDIF JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO DO JSUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( JSUB ) JGLOB = INDCOL_SON( J ) JPOS_ROOT = JGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 RHS_ROOT(ILOC_ROOT, JLOC_ROOT) = & RHS_ROOT(ILOC_ROOT, JLOC_ROOT) + VAL_SON( J, I ) ENDDO END DO ELSE IF ( .NOT. TRANSPOSE_ASM ) THEN DO ISUB = 1, NSUBSET_ROW - NSUPROW I = SUBSET_ROW( ISUB ) IGLOB = INDROW_SON( I ) IF ( I .LE. NELIM_ROW ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L( IGLOB ) ENDIF 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 ) IF ( J .LE. NELIM_COL ) THEN JPOS_ROOT = NELIM_ROOT + J - 1 ELSE JPOS_ROOT = RG2L( JGLOB ) ENDIF IF (KEEP(50).NE.0. AND. JPOS_ROOT .GT. IPOS_ROOT) CYCLE JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO END DO DO JSUB = NSUBSET_COL -NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( JSUB ) JGLOB = INDROW_SON( J ) JPOS_ROOT = JGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 DO ISUB = NSUBSET_ROW - NSUPROW +1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IGLOB = INDCOL_SON( I ) IF ( I .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L(IGLOB) ENDIF 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 ) IF ( I .LE. NELIM_ROW ) THEN JPOS_ROOT = NELIM_ROOT + I - 1 ELSE JPOS_ROOT = RG2L( IGLOB ) ENDIF 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 ) IF ( J .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + J - 1 ELSE IPOS_ROOT = RG2L( JGLOB ) ENDIF 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 ) IF ( J .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + J - 1 ELSE IPOS_ROOT = RG2L( JGLOB ) ENDIF ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) = & RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO ENDDO END IF END IF RETURN END SUBROUTINE SMUMPS_ROOT_LOCAL_ASSEMBLY SUBROUTINE SMUMPS_INIT_ROOT_ANA &( MYID, NPROCS, N, root, COMM_ROOT, IROOT, FILS, & K50, K46, K51 & , K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK & ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC IMPLICIT NONE INTEGER MYID, MYID_ROOT TYPE (MUMPS_ROOT_STRUC)::root INTEGER COMM_ROOT INTEGER N, IROOT, NPROCS, K50, K46, K51 INTEGER FILS( N ) INTEGER K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK INTEGER INODE #if ! defined(NOSCALAPACK) INTEGER NPROWtemp, NPCOLtemp #endif LOGICAL SLAVE root%ROOT_SIZE = 0 root%TOT_ROOT_SIZE = 0 SLAVE = ( MYID .ne. 0 .or. & ( MYID .eq. 0 .and. K46 .eq. 1 ) ) INODE = IROOT DO WHILE ( INODE .GT. 0 ) INODE = FILS( INODE ) root%ROOT_SIZE = root%ROOT_SIZE + 1 END DO IF ( ( K60 .NE. 2 .AND. K60 .NE. 3 ) .OR. & IDNPROW .LE. 0 .OR. IDNPCOL .LE. 0 & .OR. IDMBLOCK .LE.0 .OR. IDNBLOCK.LE.0 & .OR. IDNPROW * IDNPCOL .GT. NPROCS ) THEN root%MBLOCK = K51 root%NBLOCK = K51 CALL SMUMPS_DEF_GRID( NPROCS, root%NPROW, root%NPCOL, & root%ROOT_SIZE, K50 ) IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN IDNPROW = root%NPROW IDNPCOL = root%NPCOL IDMBLOCK = root%MBLOCK IDNBLOCK = root%NBLOCK ENDIF ELSE IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN root%NPROW = IDNPROW root%NPCOL = IDNPCOL root%MBLOCK = IDMBLOCK root%NBLOCK = IDNBLOCK ENDIF IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN IF (SLAVE) THEN root%LPIV = 0 IF (K46.EQ.0) THEN MYID_ROOT=MYID-1 ELSE MYID_ROOT=MYID ENDIF IF (MYID_ROOT < root%NPROW*root%NPCOL) THEN root%MYROW = MYID_ROOT / root%NPCOL root%MYCOL = mod(MYID_ROOT, root%NPCOL) root%yes = .true. ELSE root%MYROW = -1 root%MYCOL = -1 root%yes = .FALSE. ENDIF ELSE root%yes = .FALSE. ENDIF #if ! defined(NOSCALAPACK) ELSE IF ( SLAVE ) THEN IF ( root%gridinit_done) THEN IF (root%yes) THEN CALL blacs_gridexit( root%CNTXT_BLACS ) root%gridinit_done = .FALSE. ENDIF END IF root%CNTXT_BLACS = COMM_ROOT CALL blacs_gridinit( root%CNTXT_BLACS, 'R', & root%NPROW, root%NPCOL ) root%gridinit_done = .TRUE. CALL blacs_gridinfo( root%CNTXT_BLACS, & NPROWtemp, NPCOLtemp, & root%MYROW, root%MYCOL ) IF ( root%MYROW .NE. -1 ) THEN root%yes = .true. ELSE root%yes = .false. END IF root%LPIV = 0 #endif ELSE root%yes = .FALSE. ENDIF RETURN END SUBROUTINE SMUMPS_INIT_ROOT_ANA SUBROUTINE SMUMPS_INIT_ROOT_FAC( N, MYID, root, & FILS, KEEP ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC IMPLICIT NONE TYPE ( MUMPS_ROOT_STRUC ):: root INTEGER, INTENT(IN) :: N, MYID, KEEP(500) INTEGER FILS( N ) INTEGER INODE, I LOGICAL INITIALIZE_RG2L INITIALIZE_RG2L = ( KEEP(38) .NE. 0 ) INITIALIZE_RG2L = .TRUE. IF ( INITIALIZE_RG2L ) THEN INODE = KEEP(38) I = 1 DO WHILE ( INODE .GT. 0 ) root%RG2L( INODE ) = I I = I + 1 INODE = FILS( INODE ) END DO ENDIF root%TOT_ROOT_SIZE=0 RETURN END SUBROUTINE SMUMPS_INIT_ROOT_FAC SUBROUTINE SMUMPS_DEF_GRID( NPROCS, NPROW, NPCOL, SIZE, K50 ) IMPLICIT NONE INTEGER NPROCS, NPROW, NPCOL, SIZE, K50 INTEGER NPROWtemp, NPCOLtemp, NPROCSused, FLATNESS LOGICAL KEEPIT IF ( K50 .EQ. 1 ) THEN FLATNESS = 2 ELSE FLATNESS = 3 ENDIF NPROW = int(sqrt(real(NPROCS))) NPROWtemp = NPROW NPCOL = int(NPROCS / NPROW) NPCOLtemp = NPCOL NPROCSused = NPROWtemp * NPCOLtemp 10 CONTINUE IF ( NPROWtemp >= NPCOLtemp/FLATNESS .AND. NPROWtemp > 1) THEN NPROWtemp = NPROWtemp - 1 NPCOLtemp = int(NPROCS / NPROWtemp) KEEPIT=.FALSE. IF ( NPROWtemp * NPCOLtemp .GE. NPROCSused ) THEN IF ( ( K50 .NE. 1 .AND. NPROWtemp >= NPCOLtemp/FLATNESS) & .OR. NPROWtemp * NPCOLtemp .GT. NPROCSused ) & KEEPIT=.TRUE. END IF IF ( KEEPIT ) THEN NPROW = NPROWtemp NPCOL = NPCOLtemp NPROCSused = NPROW * NPCOL END IF GO TO 10 END IF RETURN END SUBROUTINE SMUMPS_DEF_GRID SUBROUTINE SMUMPS_SCATTER_ROOT(MYID, M, N, ASEQ, & LOCAL_M, LOCAL_N, & MBLOCK, NBLOCK, & APAR, & MASTER_ROOT, & NPROW, NPCOL, & COMM) IMPLICIT NONE INTEGER MYID, MASTER_ROOT, COMM INTEGER M, N INTEGER NPROW, NPCOL INTEGER LOCAL_M, LOCAL_N INTEGER MBLOCK, NBLOCK REAL APAR( LOCAL_M, LOCAL_N ) REAL ASEQ( M, N ) INCLUDE 'mpif.h' INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, IDEST, IROW, ICOL INTEGER IBLOCK, JBLOCK, II, JJ, KK INTEGER IAPAR, JAPAR, IERR, allocok INTEGER :: STATUS(MPI_STATUS_SIZE) REAL, DIMENSION(:), ALLOCATABLE :: WK LOGICAL JUPDATE ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of WK in ' & // 'routine SMUMPS_SCATTER_ROOT ' CALL MUMPS_ABORT() endif IAPAR = 1 JAPAR = 1 DO J = 1, N, NBLOCK SIZE_JBLOCK = NBLOCK IF ( J + NBLOCK > N ) THEN SIZE_JBLOCK = N - J + 1 END IF JUPDATE = .FALSE. DO I = 1, M, MBLOCK SIZE_IBLOCK = MBLOCK IF ( I + MBLOCK > M ) THEN SIZE_IBLOCK = M - I + 1 END IF IBLOCK = I / MBLOCK JBLOCK = J / NBLOCK IROW = mod ( IBLOCK, NPROW ) ICOL = mod ( JBLOCK, NPCOL ) IDEST = IROW * NPCOL + ICOL IF ( IDEST .NE. MASTER_ROOT ) THEN IF ( MYID .EQ. MASTER_ROOT ) THEN KK=1 DO JJ=J,J+SIZE_JBLOCK-1 DO II=I,I+SIZE_IBLOCK-1 WK(KK)=ASEQ(II,JJ) KK=KK+1 END DO END DO CALL MPI_SEND( WK, SIZE_IBLOCK*SIZE_JBLOCK, & MPI_REAL, & IDEST, 128, COMM, IERR ) ELSE IF ( MYID .EQ. IDEST ) THEN CALL MPI_RECV( WK(1), & SIZE_IBLOCK*SIZE_JBLOCK, & MPI_REAL, & MASTER_ROOT,128,COMM,STATUS,IERR) KK=1 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 APAR(II,JJ)=WK(KK) KK=KK+1 END DO END DO JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, & JAPAR:JAPAR+SIZE_JBLOCK-1 ) & = ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF END DO IF ( JUPDATE ) THEN IAPAR = 1 JAPAR = JAPAR + SIZE_JBLOCK END IF END DO DEALLOCATE(WK) RETURN END SUBROUTINE SMUMPS_SCATTER_ROOT SUBROUTINE SMUMPS_GATHER_ROOT(MYID, M, N, ASEQ, & LOCAL_M, LOCAL_N, & MBLOCK, NBLOCK, & APAR, & MASTER_ROOT, & NPROW, NPCOL, & COMM) IMPLICIT NONE INTEGER MYID, MASTER_ROOT, COMM INTEGER M, N INTEGER NPROW, NPCOL INTEGER LOCAL_M, LOCAL_N INTEGER MBLOCK, NBLOCK REAL APAR( LOCAL_M, LOCAL_N ) REAL ASEQ( M, N ) INCLUDE 'mpif.h' INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, ISOUR, IROW, ICOL INTEGER IBLOCK, JBLOCK, II, JJ, KK INTEGER IAPAR, JAPAR, IERR, allocok INTEGER :: STATUS(MPI_STATUS_SIZE) REAL,DIMENSION(:), ALLOCATABLE :: WK LOGICAL JUPDATE ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of WK in ' & // 'routine SMUMPS_GATHER_ROOT ' CALL MUMPS_ABORT() endif IAPAR = 1 JAPAR = 1 DO J = 1, N, NBLOCK SIZE_JBLOCK = NBLOCK IF ( J + NBLOCK > N ) THEN SIZE_JBLOCK = N - J + 1 END IF JUPDATE = .FALSE. DO I = 1, M, MBLOCK SIZE_IBLOCK = MBLOCK IF ( I + MBLOCK > M ) THEN SIZE_IBLOCK = M - I + 1 END IF IBLOCK = I / MBLOCK JBLOCK = J / NBLOCK IROW = mod ( IBLOCK, NPROW ) ICOL = mod ( JBLOCK, NPCOL ) ISOUR = IROW * NPCOL + ICOL IF ( ISOUR .NE. MASTER_ROOT ) THEN IF ( MYID .EQ. MASTER_ROOT ) THEN CALL MPI_RECV( WK(1), SIZE_IBLOCK*SIZE_JBLOCK, & MPI_REAL, & ISOUR, 128, COMM, STATUS, IERR ) KK=1 DO JJ=J,J+SIZE_JBLOCK-1 DO II=I,I+SIZE_IBLOCK-1 ASEQ(II,JJ)=WK(KK) KK=KK+1 END DO END DO ELSE IF ( MYID .EQ. ISOUR ) THEN KK=1 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 WK(KK)=APAR(II,JJ) KK=KK+1 END DO END DO CALL MPI_SEND( WK( 1 ), & SIZE_IBLOCK*SIZE_JBLOCK, & MPI_REAL, & MASTER_ROOT,128,COMM,IERR) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) & = APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, & JAPAR:JAPAR+SIZE_JBLOCK-1 ) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF END DO IF ( JUPDATE ) THEN IAPAR = 1 JAPAR = JAPAR + SIZE_JBLOCK END IF END DO DEALLOCATE(WK) RETURN END SUBROUTINE SMUMPS_GATHER_ROOT SUBROUTINE SMUMPS_ROOT_ALLOC_STATIC(root, roota, IROOT, N, & IW, LIW, A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) TYPE (MUMPS_ROOT_STRUC ) :: root TYPE (SMUMPS_ROOT_STRUC ) :: roota INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER IROOT, LIW, N, IWPOS, IWPOSCB INTEGER IW( LIW ) REAL A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER ITLOC( N + KEEP(253) ) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER COMP, IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER FILS( N ), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER INTARR(KEEP8(27)) REAL DBLARR(KEEP8(26)) INTEGER, EXTERNAL :: MUMPS_NUMROC REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER(8) :: LREQA_ROOT INTEGER LREQI_ROOT, LOCAL_M, LOCAL_N, allocok LOGICAL :: EARLYT3ROOTINS LOCAL_M = MUMPS_NUMROC( root%ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) LOCAL_M = max( 1, LOCAL_M ) LOCAL_N = MUMPS_NUMROC( root%ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) IF (KEEP(253).GT.0) THEN root%RHS_NLOC = MUMPS_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( roota%RHS_ROOT) ) & DEALLOCATE (roota%RHS_ROOT) ALLOCATE(roota%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 roota%RHS_ROOT = ZERO CALL SMUMPS_ASM_RHS_ROOT ( N, FILS, & root, roota, KEEP, KEEP8, RHS_MUMPS, & IFLAG, IERROR ) IF ( IFLAG .LT. 0 ) RETURN ENDIF IF (KEEP(60) .NE. 0) THEN PTRIST(STEP(IROOT)) = -6666666 ELSE LREQI_ROOT = 2 + KEEP(IXSZ) LREQA_ROOT = int(LOCAL_M,8) * int(LOCAL_N,8) IF (LREQA_ROOT.EQ.0_8) THEN PTRIST(STEP(IROOT)) = -9999999 RETURN ENDIF CALL SMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LREQI_ROOT, & LREQA_ROOT, IROOT, S_NOTFREE, .TRUE., COMP, & LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PTRIST ( STEP(IROOT) ) = IWPOSCB + 1 PAMASTER( STEP(IROOT) ) = IPTRLU + 1_8 IW( IWPOSCB + 1 + KEEP(IXSZ)) = - LOCAL_N IW( IWPOSCB + 2 + KEEP(IXSZ)) = LOCAL_M ENDIF EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) IF (LOCAL_N > 0 .AND. .NOT. EARLYT3ROOTINS ) THEN IF (KEEP(60) .EQ. 0) THEN CALL SMUMPS_SET_TO_ZERO(A(IPTRLU+1_8), LOCAL_M, & LOCAL_M, LOCAL_N, KEEP) ELSE CALL SMUMPS_SET_TO_ZERO(roota%SCHUR_POINTER(1), & root%SCHUR_LLD, LOCAL_M, LOCAL_N, KEEP) ENDIF IF (KEEP(55) .eq. 0) THEN IF (KEEP(60) .EQ. 0) THEN CALL SMUMPS_ASM_ARR_ROOT( N, root, roota, & IROOT, STEP(IROOT), & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N, & FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL SMUMPS_ASM_ARR_ROOT( N, root, roota, & IROOT, STEP(IROOT), & roota%SCHUR_POINTER(1), root%SCHUR_LLD, & LOCAL_M, LOCAL_N, & FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ENDIF ELSE IF (KEEP(60) .EQ. 0) THEN CALL SMUMPS_ASM_ELT_ROOT( N, root, roota, & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ELSE CALL SMUMPS_ASM_ELT_ROOT( N, root, roota, & roota%SCHUR_POINTER(1), root%SCHUR_LLD, & root%SCHUR_MLOC, root%SCHUR_NLOC, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_ROOT_ALLOC_STATIC SUBROUTINE SMUMPS_ASM_ELT_ROOT( N, root, roota, & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & INTARR, DBLARR, LINTARR, LDBLARR, & KEEP, KEEP8, & MYID) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER :: N, MYID, LOCAL_M, LOCAL_N, KEEP(500) INTEGER :: LOCAL_M_LLD INTEGER(8) KEEP8(150) REAL VALROOT(LOCAL_M_LLD,LOCAL_N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER, INTENT(INOUT) :: INTARR(LINTARR) REAL DBLARR(LDBLARR) INTEGER(8) :: J1, J2, K8, IPTR INTEGER :: IELT, I, J, IGLOB, SIZEI, IBEG INTEGER :: ARROW_ROOT INTEGER :: IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INTEGER :: ILOCROOT, JLOCROOT ARROW_ROOT = 0 DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1 IELT = FRTELT( IPTR ) J1 = PTRAIW(IELT) J2 = PTRAIW(IELT+1)-1 K8 = PTRARW(IELT) SIZEI=int(J2-J1)+1 DO J=1, SIZEI IGLOB = INTARR(J1+J-1) INTARR(J1+J-1) = root%RG2L(IGLOB) ENDDO DO J = 1, SIZEI IGLOB = INTARR(J1+J-1) IF ( KEEP(50).eq. 0 ) THEN IBEG = 1 ELSE IBEG = J END IF DO I = IBEG, SIZEI IF ( KEEP(50).eq.0 ) THEN IPOSROOT = INTARR(J1+I-1) JPOSROOT = INTARR(J1+J-1) ELSE IF ( INTARR(J1+I-1).GT. INTARR(J1+J-1) ) THEN IPOSROOT = INTARR(J1+I-1) JPOSROOT = INTARR(J1+J-1) ELSE IPOSROOT = INTARR(J1+J-1) JPOSROOT = INTARR(J1+I-1) END IF END IF IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, & root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, & root%NPCOL ) IF ( IROW_GRID.EQ.root%MYROW .AND. & JCOL_GRID.EQ.root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + DBLARR(K8) ENDIF K8 = K8 + 1_8 END DO END DO ARROW_ROOT = ARROW_ROOT + int(PTRARW(IELT+1_8)-PTRARW(IELT)) END DO KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE SMUMPS_ASM_ELT_ROOT SUBROUTINE SMUMPS_ASM_RHS_ROOT & ( N, FILS, root, roota, KEEP, KEEP8, RHS_MUMPS, & IFLAG, IERROR ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, KEEP(500), IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER FILS(N) TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota REAL :: RHS_MUMPS(KEEP8(85)) 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( 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 roota%RHS_ROOT(ILOCRHS, JLOCRHS) = & RHS_MUMPS(INODE+(JCOL-1)*KEEP(254)) ENDDO 100 CONTINUE INODE=FILS(INODE) ENDDO RETURN END SUBROUTINE SMUMPS_ASM_RHS_ROOT SUBROUTINE SMUMPS_ASM_ARR_ROOT( N, root, roota, IROOT, STEP_IROOT, & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, LINTARR, LDBLARR, & MYID) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER :: N, MYID, IROOT, STEP_IROOT, LOCAL_M, LOCAL_N INTEGER :: LOCAL_M_LLD INTEGER FILS( N ) INTEGER :: KEEP(500) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) REAL VALROOT(LOCAL_M_LLD,LOCAL_N) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER INTARR(LINTARR) REAL DBLARR(LDBLARR) REAL VAL INTEGER(8) :: JJ, J1,J2,J3, J4, AINPUT INTEGER IORG, NUMORG, & IROW, JCOL, IARR1 INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INTEGER ILOCROOT, JLOCROOT NUMORG = root%ROOT_SIZE IARR1=PTRDEBARR(STEP_IROOT) DO IORG = 1, NUMORG AINPUT = PTR8ARR(IARR1+IORG-1) J1 = AINPUT J2 = J1 + NINCOLARR(IARR1+IORG-1) J3 = J2 + 1 J4 = J2 + NINROWARR(IARR1+IORG-1) JCOL = INTARR(J1) DO JJ = J1, J2 IROW = INTARR(JJ) VAL = DBLARR(AINPUT) AINPUT = AINPUT + 1 IPOSROOT = root%RG2L( IROW ) JPOSROOT = root%RG2L( JCOL ) IROW_GRID = mod( ( IPOSROOT - 1 ) / root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 ) / root%NBLOCK, root%NPCOL ) IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + VAL END IF END DO IF (J3 .LE. J4) THEN IROW = INTARR(J1) DO JJ= J3,J4 JCOL = INTARR(JJ) VAL = DBLARR(AINPUT) AINPUT = AINPUT + 1 IPOSROOT = root%RG2L( IROW ) JPOSROOT = root%RG2L( JCOL ) IROW_GRID= mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW) JCOL_GRID= mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL) IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + VAL END IF END DO ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_ASM_ARR_ROOT MUMPS_5.8.1/src/zfac_lr.F0000664000175000017500000030135415042446441014766 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_LR USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_CORE IMPLICIT NONE CONTAINS SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING_LDLT( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, & NELIM, IW2, BLOCK, & MAXI_CLUSTER, NPIV, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & NELIM, MAXI_CLUSTER, NPIV, NIV, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR COMPLEX(kind=8), intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_L(:) COMPLEX(kind=8), INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, intent(in) :: IW2(*) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL, J, MID_RANK LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER(8) :: POSELTT, POSELTD COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(CURRENT_BLR)-1,8) & + int(BEGS_BLR(CURRENT_BLR) - 1,8) OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC, CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, !$OMP& MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL*(NB_BLOCKS_PANEL+1)/2) IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT + int(NFRONT,8) * & int(BEGS_BLR(CURRENT_BLR+I)-1,8) & + int(BEGS_BLR(CURRENT_BLR+J) - 1, 8) CALL ZMUMPS_LRGEMM4(MONE, & BLR_L(J), BLR_L(I), ONE, A, LA, & POSELTT, NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_L(J)%M, BLR_L(J)%N, BLR_L(J)%K, & BLR_L(J)%ISLR, BLR_L(I)%M, BLR_L(I)%N, BLR_L(I)%K, & BLR_L(I)%ISLR, MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), .FALSE.) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif END SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING_LDLT SUBROUTINE ZMUMPS_BLR_SLV_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, JBEG_BLOCK, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA, LA_BLOCFACTO COMPLEX(kind=8), intent(inout) :: A(LA) COMPLEX(kind=8), intent(in) :: A_BLOCFACTO(LA_BLOCFACTO) INTEGER(8), intent(in) :: POSELT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), TOL_OPT, & MAXI_CLUSTER, LD_BLOCFACTO, & JBEG_BLOCK INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS, & ISHIFT_LM, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS COMPLEX(kind=8), INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM), & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_LM, NB_BLOCKS_PANEL_LS, J, MID_RANK LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER(8) :: POSELTT COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) NB_BLOCKS_PANEL_LM = NB_BLR_LM-CURRENT_BLR_LM NB_BLOCKS_PANEL_LS = NB_BLR_LS-CURRENT_BLR_LS OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_LS*NB_BLOCKS_PANEL_LM) IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_BLOCKS_PANEL_LM+1 J = IBIS - (I-1)*NB_BLOCKS_PANEL_LM #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT & + int(NCOL,8) * & int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8) & + int((BEGS_BLR_LM(CURRENT_BLR_LM+J)+ISHIFT_LM-1),8) CALL ZMUMPS_LRGEMM4(MONE, & BLR_LM(J), BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A_BLOCFACTO, LD_DIAG=LD_BLOCFACTO, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_LM(J)%M, BLR_LM(J)%N, BLR_LM(J)%K, & BLR_LM(J)%ISLR, BLR_LS(I)%M, BLR_LS(I)%N, BLR_LS(I)%K, & BLR_LS(I)%ISLR, MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., .FALSE.) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO IF (IFLAG.LT.0) RETURN IF (JBEG_BLOCK.NE.1) RETURN !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, MID_RANK, OMP_NUM, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_LS*(NB_BLOCKS_PANEL_LS+1)/2) IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT & + int(NCOL,8) * & int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8) & + int((NCOL-NROW+(BEGS_BLR_LS(CURRENT_BLR_LS+J)-1)),8) CALL ZMUMPS_LRGEMM4(MONE, & BLR_LS(J),BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A_BLOCFACTO, LD_DIAG=LD_BLOCFACTO, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_LS(J)%M, BLR_LS(J)%N, BLR_LS(J)%K, & BLR_LS(J)%ISLR, BLR_LS(I)%M, BLR_LS(I)%N, BLR_LS(I)%K, & BLR_LS(I)%ISLR, MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), .FALSE.) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif RETURN END SUBROUTINE ZMUMPS_BLR_SLV_UPD_TRAIL_LDLT SUBROUTINE ZMUMPS_BLR_UPD_NELIM_VAR_U( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_U, NB_BLR, & FIRST_BLOCK, IBEG_BLR, NPIV, NELIM) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & IBEG_BLR, NPIV, NELIM, FIRST_BLOCK INTEGER, intent(inout) :: IFLAG, IERROR COMPLEX(kind=8), TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(:) INTEGER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: IP INTEGER :: allocok INTEGER(8) :: LPOS, UPOS COMPLEX(kind=8), ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) IF (NELIM.NE.0) THEN LPOS = POSELT + int(NFRONT,8)*int(NPIV,8) + int(IBEG_BLR-1,8) #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(LRB, UPOS) #endif DO IP = FIRST_BLOCK, NB_BLR IF (IFLAG.LT.0) CYCLE LRB => BLR_U(IP-CURRENT_BLR) UPOS = POSELT + int(NFRONT,8)*int(NPIV,8) & + int(BEGS_BLR(IP)-1,8) IF (LRB%ISLR) THEN IF (LRB%K.GT.0) THEN allocate(TEMP_BLOCK( LRB%K, NELIM ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * LRB%K GOTO 100 ENDIF CALL zgemm('N', 'N', LRB%K, NELIM, LRB%N, ONE, & LRB%R(1,1), LRB%K, A(LPOS), NFRONT, & ZERO, TEMP_BLOCK, LRB%K) CALL zgemm('N', 'N', LRB%M, NELIM, LRB%K, MONE, & LRB%Q(1,1), LRB%M, TEMP_BLOCK, LRB%K, & ONE, A(UPOS), NFRONT) deallocate(TEMP_BLOCK) ENDIF ELSE CALL zgemm('N', 'N', LRB%M, NELIM, LRB%N, MONE, & LRB%Q(1,1), LRB%M, A(LPOS), NFRONT, & ONE, A(UPOS), NFRONT) ENDIF 100 CONTINUE ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO #endif ENDIF END SUBROUTINE ZMUMPS_BLR_UPD_NELIM_VAR_U SUBROUTINE ZMUMPS_BLR_UPD_NELIM_VAR_L( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA_U, LA_L INTEGER(8), intent(in) :: UPOS, LPOS INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR, & NELIM, FIRST_BLOCK CHARACTER(len=1),INTENT(IN) :: UTRANS INTEGER, intent(inout) :: IFLAG, IERROR COMPLEX(kind=8), TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U) TYPE(LRB_TYPE),intent(in) :: BLR_L(:) INTEGER :: BEGS_BLR_L(:) INTEGER :: I, NB_BLOCKS_PANEL_L, KL, ML, NL INTEGER :: allocok INTEGER(8) :: IPOS COMPLEX(kind=8), ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR IF (NELIM.NE.0) THEN #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(KL, ML, NL, IPOS) #endif DO I = FIRST_BLOCK-CURRENT_BLR, NB_BLOCKS_PANEL_L IF (IFLAG.LT.0) CYCLE KL = BLR_L(I)%K ML = BLR_L(I)%M NL = BLR_L(I)%N IPOS = LPOS + int(LDL,8) * & int(BEGS_BLR_L(CURRENT_BLR+I)-BEGS_BLR_L(CURRENT_BLR+1),8) IF (BLR_L(I)%ISLR) THEN IF (KL.GT.0) THEN allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * KL write(*,*) 'Allocation problem in BLR routine & ZMUMPS_BLR_UPD_NELIM_VAR_L: ', & 'not enough memory? memory requested = ', IERROR GOTO 100 ENDIF CALL zgemm(UTRANS , 'T' , NELIM, KL, NL , ONE , & A_U(UPOS) , LDU , BLR_L(I)%R(1,1) , KL , & ZERO , TEMP_BLOCK , NELIM) CALL zgemm('N' , 'T' , NELIM , ML , KL , MONE , & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , & ONE , A_L(IPOS) , LDL) deallocate(TEMP_BLOCK) ENDIF ELSE CALL zgemm(UTRANS , 'T' , NELIM, ML, NL , MONE , & A_U(UPOS) , LDU , BLR_L(I)%Q(1,1) , ML , & ONE , A_L(IPOS) , LDL) ENDIF 100 CONTINUE ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO #endif ENDIF END SUBROUTINE ZMUMPS_BLR_UPD_NELIM_VAR_L SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, & CURRENT_BLR, & NELIM, NIV, SYM, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT COMPLEX(kind=8), intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(:) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(:) INTEGER :: BEGS_BLR_L(:), BEGS_BLR_U(:) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_L, NB_BLOCKS_PANEL_U, & KL, ML, NL, J, IS, MID_RANK INTEGER :: allocok LOGICAL :: BUILDQ INTEGER :: IBIS #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB, POSELT_TOP COMPLEX(kind=8), ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR NB_BLOCKS_PANEL_U = NB_BLR_U-CURRENT_BLR IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS = 0 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif IF (NELIM.NE.0) THEN DO I = 1, NB_BLOCKS_PANEL_L KL = BLR_L(I)%K ML = BLR_L(I)%M NL = BLR_L(I)%N IF (BLR_L(I)%ISLR) THEN IF (KL.GT.0) THEN allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * KL GOTO 100 ENDIF POSELT_TOP = POSELT & + int(NFRONT,8) * int((BEGS_BLR_U(CURRENT_BLR)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1,8) POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) CALL zgemm('N' , 'T' , NELIM, KL, NL , ONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%R(1,1) , KL , & ZERO , TEMP_BLOCK , NELIM) CALL zgemm('N' , 'T' , NELIM , ML , KL , MONE , & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) deallocate(TEMP_BLOCK) ENDIF ELSE POSELT_TOP = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1, 8) CALL zgemm('N' , 'T' , NELIM, ML, NL , MONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) ENDIF ENDDO ENDIF 100 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 200 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELT_INCB, MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_L*NB_BLOCKS_PANEL_U) IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_BLOCKS_PANEL_U+1 J = IBIS - (I-1)*NB_BLOCKS_PANEL_U POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+J) +IS - 1,8) CALL ZMUMPS_LRGEMM4(MONE, BLR_U(J), & BLR_L(I), ONE, A, LA, POSELT_INCB, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT, MID_RANK, BUILDQ, .FALSE.) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_U(J)%M, BLR_U(J)%N, BLR_U(J)%K, & BLR_U(J)%ISLR, BLR_L(I)%M, BLR_L(I)%N, BLR_L(I)%K, & BLR_L(I)%ISLR, MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., .FALSE.) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif 200 CONTINUE END SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING SUBROUTINE ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT( & A, LA, POSELT, NFRONT, IWHANDLER, & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, IW2, BLOCK, ACC_LUA, & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, & KEEP8, & FIRST_BLOCK & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS, & CURRENT_BLR, IWHANDLER, TOL_OPT, & NELIM, NIV, K480, K479, K478, & MAXI_CLUSTER, MAXI_RANK, & KPERCENT_LUA, KPERCENT COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER, intent(in) :: IW2(*) COMPLEX(kind=8) :: BLOCK(MAXI_CLUSTER,*) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:) INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER,intent(inout) :: IFLAG, IERROR INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK TYPE(LRB_TYPE), POINTER :: BLR_L(:), NEXT_BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES, & I, II, J, JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX, & MAXRANK, NB_DEC, FR_RANK INTEGER :: MID_RANK, allocok INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) LOGICAL :: BUILDQ, COMPRESSED_FR INTEGER :: OFFSET_IW INTEGER :: OMP_NUM #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB, POSELTD COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR ACC_LRB => ACC_LUA(1) IF (K480.GE.5) THEN IF (NB_BLOCKS_PANEL.GT.1) THEN CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & CURRENT_BLR+1, NEXT_BLR_L) ENDIF IF (.not.(present(FIRST_BLOCK))) THEN write(*,*) "Internal error in & ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT: KEEP(480)=",K480, & ">= 5, but FIRST_BLOCK argument is missing" CALL MUMPS_ABORT() ENDIF ENDIF OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ, K_MAX, !$OMP& BLR_L, OMP_NUM, J_ORDER, J_RANK, !$OMP& IND_U, IND_L, ACC_LRB, POSELTD, NB_DEC, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, COMPRESSED_FR, FR_RANK, II, OFFSET_IW) #endif DO I = 1, NB_BLOCKS_PANEL #if ! defined(BLR_NOOPENMP) IF (IFLAG.LT.0) CYCLE OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR(CURRENT_BLR+1)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+I+1)-BEGS_BLR(CURRENT_BLR+I) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 COMPRESSED_FR = .FALSE. IF (K480.EQ.2) THEN DO J = 1, CURRENT_BLR J_ORDER(J) = J ENDDO ELSE CALL ZMUMPS_GET_LUA_ORDER(CURRENT_BLR, J_ORDER, J_RANK, & IWHANDLER, & 1, 0, I, 0, & FRFR_UPDATES) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL ZMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF ENDIF NB_DEC = FRFR_UPDATES DO JJ = 1, CURRENT_BLR J = J_ORDER(JJ) K_MAX = J_RANK(JJ) POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(J)-1,8) & + int(BEGS_BLR(J) - 1,8) OFFSET_IW = BEGS_BLR(J) IND_L = CURRENT_BLR+I-J IND_U = CURRENT_BLR+1-J CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & J, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = JJ-1 CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL ZMUMPS_LRGEMM4(MONE, & BLR_L(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_INCB, & NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=0, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, & IW2=IW2(OFFSET_IW), & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_L(IND_U)%M, BLR_L(IND_U)%N, & BLR_L(IND_U)%K, BLR_L(IND_U)%ISLR, BLR_L(IND_L)%M, & BLR_L(IND_L)%N, BLR_L(IND_L)%K, BLR_L(IND_L)%ISLR, & MIDBLK_COMPRESS, MID_RANK, BUILDQ, (I.EQ.1), (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN J_RANK(JJ) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN IF (ACC_LRB%K.GT.0) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (JJ.EQ.FRFR_UPDATES) THEN CALL ZMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K IF (COMPRESSED_FR) THEN J_RANK(JJ) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) ELSE allocate(POS_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,CURRENT_BLR POS_LIST(II+1)=POS_LIST(II)+J_RANK(II-1) ENDDO allocate(RANK_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,CURRENT_BLR+1 RANK_LIST(II) = J_RANK(II-1) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & CURRENT_BLR+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = floor(dble(ACC_LRB%M*ACC_LRB%N)/dble(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ALLOC_LRB_FROM_ACC(ACC_LRB, NEXT_BLR_L(I-1), & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, 0, & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE ACC_LRB%K = 0 ELSE IF (I.NE.1) NEXT_BLR_L(I-1)%ISLR=.FALSE. CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) ENDIF ENDIF 100 CONTINUE ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif END SUBROUTINE ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT SUBROUTINE ZMUMPS_BLR_UPD_PANEL_LEFT( & A, LA, POSELT, NFRONT, IWHANDLER, LorU, & BEGS_BLR, BEGS_BLR_U, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, NIV, SYM, & LBANDSLAVE, IFLAG, IERROR, ISHIFT, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, & MAXI_CLUSTER, MAXI_RANK, & K474, FSorCB, BLR_U_COL, KEEP8, & FIRST_BLOCK, BEG_I_IN, END_I_IN) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS, & CURRENT_BLR, IWHANDLER, LorU, & NELIM, NIV, SYM, K480, K479, K478, & MAXI_CLUSTER, MAXI_RANK, & KPERCENT_LUA, KPERCENT, ISHIFT, & K474, FSorCB LOGICAL, intent(in) :: LBANDSLAVE COMPLEX(kind=8), TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:) INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER,intent(inout) :: IFLAG, IERROR INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:), NEXT_BLR(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES, & NB_DEC, FR_RANK, MAXRANK, BEG_I, END_I INTEGER :: I,II,J,JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX INTEGER :: MID_RANK, allocok INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) LOGICAL :: BUILDQ, COMPRESSED_FR #if ! defined(BLR_NOOPENMP) INTEGER :: OMP_NUM INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) IF (NIV.EQ.2.AND.LorU.EQ.0) THEN IF (LBANDSLAVE) THEN NB_BLOCKS_PANEL = NB_BLR ELSE NB_BLOCKS_PANEL = NPARTSASS-CURRENT_BLR ENDIF ELSE NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR ENDIF ACC_LRB => ACC_LUA(1) IF (K480.GE.5) THEN IF (NB_BLOCKS_PANEL.GT.1) THEN CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & LorU, & CURRENT_BLR+1, NEXT_BLR) ENDIF IF (.not.(present(FIRST_BLOCK))) THEN write(*,*) "Internal error in & ZMUMPS_BLR_UPD_PANEL_LEFT: KEEP(480)=",K480, & ">=5, but FIRST_BLOCK argument is missing" CALL MUMPS_ABORT() ENDIF ENDIF IF (LorU.EQ.0) THEN BEG_I = 1 ELSE BEG_I = 2 ENDIF END_I = NB_BLOCKS_PANEL IF (K474.EQ.3) THEN IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN - CURRENT_BLR ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN - CURRENT_BLR ENDIF ENDIF #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ, !$OMP& BLR_U, BLR_L, J_ORDER, J_RANK, K_MAX, !$OMP& IND_U, IND_L, OMP_NUM, ACC_LRB, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, FR_RANK, COMPRESSED_FR) #endif DO I = BEG_I, END_I IF (IFLAG.LT.0) CYCLE #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif IF (LorU.EQ.0) THEN IF (LBANDSLAVE) THEN POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(I+1)-1),8) & + int(BEGS_BLR_U(2)+ISHIFT-1,8) ACC_LRB%N = BEGS_BLR(I+2)-BEGS_BLR(I+1) ACC_LRB%M = BEGS_BLR_U(3)-BEGS_BLR_U(2) IF (K474.GE.2) THEN BLR_U => BLR_U_COL ENDIF ELSE POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR(CURRENT_BLR+1)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+I+1) & -BEGS_BLR(CURRENT_BLR+I) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) ENDIF ELSE POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+1)-1),8) & + int(BEGS_BLR(CURRENT_BLR+I)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+I+1)-BEGS_BLR(CURRENT_BLR+I) ENDIF MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 COMPRESSED_FR = .FALSE. IF (K480.EQ.2) THEN DO J = 1, CURRENT_BLR J_ORDER(J) = J ENDDO ELSE CALL ZMUMPS_GET_LUA_ORDER(CURRENT_BLR, J_ORDER, J_RANK, & IWHANDLER, & 0, 0, I, LorU, & FRFR_UPDATES, & LBANDSLAVE, K474, BLR_U_COL) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL ZMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, LorU, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF ENDIF NB_DEC = FRFR_UPDATES DO JJ = 1, CURRENT_BLR J = J_ORDER(JJ) K_MAX = J_RANK(JJ) IF (LorU.EQ.0) THEN IF (LBANDSLAVE) THEN IND_L = I IF (K474.LT.2) THEN IND_U = CURRENT_BLR+1-J ELSE IND_U = J ENDIF ELSE IND_L = CURRENT_BLR+I-J IND_U = CURRENT_BLR+1-J ENDIF ELSE IND_L = CURRENT_BLR+1-J IND_U = CURRENT_BLR+I-J ENDIF CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & J, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (.NOT.LBANDSLAVE.OR.K474.LT.2) THEN CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, & J, BLR_U) ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = JJ-1 CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL ZMUMPS_LRGEMM4(MONE, & BLR_U(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_INCB, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=LorU, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER & ) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_U(IND_U)%M, BLR_U(IND_U)%N, & BLR_U(IND_U)%K, BLR_U(IND_U)%ISLR, BLR_L(IND_L)%M, & BLR_L(IND_L)%N, BLR_L(IND_L)%K, BLR_L(IND_L)%ISLR, & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN J_RANK(JJ) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (JJ.EQ.FRFR_UPDATES) THEN CALL ZMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, LorU, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K IF (COMPRESSED_FR) THEN J_RANK(JJ) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF ENDIF ENDIF ENDIF ENDDO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) ELSE allocate(POS_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,CURRENT_BLR POS_LIST(II+1)=POS_LIST(II)+J_RANK(II-1) ENDDO allocate(RANK_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,CURRENT_BLR+1 RANK_LIST(II) = J_RANK(II-1) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & CURRENT_BLR+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(dble(ACC_LRB%M*ACC_LRB%N)/dble(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ALLOC_LRB_FROM_ACC(ACC_LRB, NEXT_BLR(I-1), & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, LorU, & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE ACC_LRB%K = 0 ELSE IF (I.NE.1) NEXT_BLR(I-1)%ISLR=.FALSE. CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) ENDIF ENDIF 100 CONTINUE ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO NOWAIT #endif END SUBROUTINE ZMUMPS_BLR_UPD_PANEL_LEFT SUBROUTINE ZMUMPS_BLR_UPD_CB_LEFT_LDLT(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR_DYN, NB_INCB, NB_INASM, NASS, & IWHANDLER, & IW2, BLOCK, ACC_LUA, & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, KEEP8) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_INCB, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & MAXI_RANK, K480, K479, K478, NASS, & KPERCENT_LUA, KPERCENT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER, DIMENSION(:) :: BEGS_BLR_DYN COMPLEX(kind=8), INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, intent(in) :: IW2(*) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: M, N, allocok INTEGER :: I, II, J, K, KK, IND_L, IND_U, K_MAX, IBIS, & K_ORDER(NB_INASM), K_RANK(NB_INASM), NB_DEC INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) INTEGER(8) :: POSELT_BLOCK, POSELTD INTEGER :: MID_RANK, FRFR_UPDATES, MAXRANK, FR_RANK LOGICAL :: BUILDQ, COMPRESSED_FR TYPE(LRB_TYPE), POINTER :: BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK INTEGER :: OFFSET_IW INTEGER :: OMP_NUM #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) ACC_LRB => ACC_LUA(1) OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ, !$OMP& BLR_L, IND_U, IND_L, M, N, K_ORDER, K_RANK, !$OMP& K_MAX, OMP_NUM, ACC_LRB, POSELTD, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, FR_RANK, NB_DEC, II) #endif DO IBIS = 1,NB_INCB*(NB_INCB+1)/2 IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 I = I+NB_INASM J = J+NB_INASM #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 M = BEGS_BLR(I+1)-BEGS_BLR(I) N = BEGS_BLR(J+1)-BEGS_BLR(J) POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR(J)-1,8) ACC_LRB%M = N ACC_LRB%N = M IF (K480.EQ.2) THEN DO K = 1, NB_INASM K_ORDER(K) = K ENDDO ELSE CALL ZMUMPS_GET_LUA_ORDER(NB_INASM, K_ORDER, K_RANK, & IWHANDLER, & 1, 1, I, J, & FRFR_UPDATES) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.J)) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL ZMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) FR_RANK = ACC_LRB%K MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K ENDIF ENDIF NB_DEC = FRFR_UPDATES DO KK = 1, NB_INASM K = K_ORDER(KK) K_MAX = K_RANK(KK) POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR_DYN(K)-1,8) & + int(BEGS_BLR_DYN(K) - 1,8) OFFSET_IW = BEGS_BLR_DYN(K) IND_L = I-K IND_U = J-K CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & K, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = KK-1 CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, 2) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL ZMUMPS_LRGEMM4(MONE, & BLR_L(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_BLOCK, & NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=2, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, & IW2=IW2(OFFSET_IW), & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_L(IND_U)%M, BLR_L(IND_U)%N, & BLR_L(IND_U)%K, BLR_L(IND_U)%ISLR, BLR_L(IND_L)%M, & BLR_L(IND_L)%N, BLR_L(IND_L)%K, BLR_L(IND_L)%ISLR, & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN K_RANK(KK) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN IF (ACC_LRB%K.GT.0) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.J)) THEN IF (KK.EQ.FRFR_UPDATES) THEN CALL ZMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) IF (COMPRESSED_FR) THEN K_RANK(KK) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF END DO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) ELSE allocate(POS_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,NB_INASM POS_LIST(II+1)=POS_LIST(II)+K_RANK(II-1) ENDDO allocate(RANK_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,NB_INASM+1 RANK_LIST(II) = K_RANK(II-1) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & NB_INASM+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(dble(ACC_LRB%M*ACC_LRB%N)/dble(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2, & COUNT_FLOPS=.FALSE.) ELSE CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & KEEP8, NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ENDIF 100 CONTINUE END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif END SUBROUTINE ZMUMPS_BLR_UPD_CB_LEFT_LDLT SUBROUTINE ZMUMPS_BLR_UPD_CB_LEFT(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_INCB, NB_INASM, NASS, & IWHANDLER, NIV, LBANDSLAVE, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & ACC_LUA, K480, K479, K478, KPERCENT_LUA, & KPERCENT, & MAXI_CLUSTER, MAXI_RANK, & K474, FSorCB, BLR_U_COL, COMPRESS_CB, CB_LRB, KEEP8) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_ROWS, NB_INCB, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & MAXI_RANK, KPERCENT_LUA, KPERCENT INTEGER, INTENT(IN) :: K480, K479, K478, NASS, K474, & FSorCB INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U #if defined(MUMPS_NOF2003) TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) #else TYPE(LRB_TYPE), POINTER, intent(inout) :: CB_LRB(:,:) #endif TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:) INTEGER(8) :: KEEP8(150) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT DOUBLE PRECISION,intent(in) :: TOLEPS LOGICAL, intent(in) :: LBANDSLAVE, COMPRESS_CB INTEGER :: M, N, allocok INTEGER :: I, II, J, K, KK, IND_L, IND_U, IBIS, & K_ORDER(NB_INASM), K_RANK(NB_INASM) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) INTEGER(8) :: POSELT_BLOCK INTEGER :: MID_RANK, K_MAX, FRFR_UPDATES, NB_DEC LOGICAL :: BUILDQ, COMPRESSED_FR TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB, LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, MAXRANK, & FR_RANK #if ! defined(BLR_NOOPENMP) INTEGER :: OMP_NUM INTEGER :: CHUNK #endif COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) ACC_LRB => ACC_LUA(1) #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ, !$OMP& BLR_U, BLR_L, IND_U, IND_L, M, N, !$OMP& ACC_LRB, OMP_NUM, K_MAX, K_ORDER, K_RANK, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, LRB) #endif DO IBIS = 1,NB_ROWS*NB_INCB IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_INCB+1 J = IBIS - (I-1)*NB_INCB IF (.NOT.LBANDSLAVE) THEN I = I+NB_INASM ENDIF J = J+NB_INASM #if ! defined(BLR_NOOPENMP) OMP_NUM=0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 IF (LBANDSLAVE) THEN M = BEGS_BLR(I+2)-BEGS_BLR(I+1) IF (K474.EQ.1) THEN POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I+1)-1,8) & +int(NASS,8) + int(BEGS_BLR_U(J-NB_INASM+1)-1,8) N = BEGS_BLR_U(J-NB_INASM+2)-BEGS_BLR_U(J-NB_INASM+1) ELSEIF (K474.GE.2) THEN BLR_U => BLR_U_COL POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I+1)-1,8) & + int(NASS-1,8) N = BEGS_BLR_U(3)-BEGS_BLR_U(2) ELSE write(*,*) 'Internal error in ZMUMPS_BLR_UPD_CB_LEFT', & LBANDSLAVE,K474 CALL MUMPS_ABORT() ENDIF ELSE M = BEGS_BLR(I+1)-BEGS_BLR(I) POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR_U(J)-1,8) N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ENDIF ACC_LRB%M = N ACC_LRB%N = M IF (K480.EQ.2) THEN DO K = 1, NB_INASM K_ORDER(K) = K ENDDO ELSE CALL ZMUMPS_GET_LUA_ORDER(NB_INASM, K_ORDER, K_RANK, & IWHANDLER, & 0, 1, I, J, & FRFR_UPDATES, & LBANDSLAVE, K474, BLR_U_COL) ENDIF COMPRESSED_FR = .FALSE. FR_RANK = 0 DO KK = 1, NB_INASM IF ((K480.GE.5.OR.COMPRESS_CB).AND.I.NE.J) THEN IF (KK-1.EQ.FRFR_UPDATES) THEN CALL ZMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) IF (COMPRESSED_FR) THEN K_RANK(KK) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF K = K_ORDER(KK) K_MAX = K_RANK(KK) IF (LBANDSLAVE) THEN IND_L = I IF (K474.LT.2) THEN IND_U = J-K ELSE IND_U = K ENDIF ELSE IND_L = I-K IND_U = J-K ENDIF CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & K, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (.NOT.LBANDSLAVE.OR.K474.LT.2) THEN CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, & K, BLR_U) ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN COMPRESSED_FR = .FALSE. NB_DEC = KK-1 CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, 2) MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL ZMUMPS_LRGEMM4(MONE, & BLR_U(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_BLOCK, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=2, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_U(IND_U)%M, BLR_U(IND_U)%N, & BLR_U(IND_U)%K, BLR_U(IND_U)%ISLR, BLR_L(IND_L)%M, & BLR_L(IND_L)%N, BLR_L(IND_L)%K, BLR_L(IND_L)%ISLR, & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN K_RANK(KK) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF END DO IF (K480.GE.3) THEN IF (K480.GE.5.OR.COMPRESS_CB) THEN IF (K480.GE.5.AND.(COMPRESSED_FR.OR.K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) ELSE allocate(POS_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,NB_INASM POS_LIST(II+1)=POS_LIST(II)+K_RANK(II-1) ENDDO allocate(RANK_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,NB_INASM+1 RANK_LIST(II) = K_RANK(II-1) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & NB_INASM+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(dble(ACC_LRB%M*ACC_LRB%N)/dble(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN LRB => CB_LRB(I-NB_INASM,J-NB_INASM) CALL ALLOC_LRB_FROM_ACC(ACC_LRB, LRB, & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, 0, & IFLAG, IERROR, KEEP8) CALL UPD_MRY_CB_LRGAIN(LRB%M, LRB%N, LRB%K & ) ACC_LRB%K = 0 IF (IFLAG.LT.0) GOTO 100 ELSE CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) LRB => CB_LRB(I-NB_INASM,J-NB_INASM) CALL ALLOC_LRB(LRB, ACC_LRB%K, ACC_LRB%N, ACC_LRB%M, & .FALSE., IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 100 DO II=1,ACC_LRB%N LRB%Q(II,1:ACC_LRB%M) = & A( POSELT_BLOCK+int((II-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((II-1),8)*int(NFRONT,8) & +int(ACC_LRB%M-1,8) ) END DO ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & KEEP8,NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ENDIF 100 CONTINUE END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF (COMPRESS_CB) THEN CALL UPD_MRY_CB_FR(NFRONT-NASS, NFRONT-NASS, 0) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER #endif END SUBROUTINE ZMUMPS_BLR_UPD_CB_LEFT SUBROUTINE ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, DECOMP_TIMER, & BEG_I_IN, END_I_IN, ONLY_NELIM_IN & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: COPY_DENSE_BLOCKS INTEGER, intent(in) :: NB_BLR, CURRENT_BLR INTEGER, intent(in) :: BEGS_BLR_DIAG, & BEGS_BLR_FIRST_OFFDIAG TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(:) CHARACTER(len=1) :: DIR INTEGER, intent(in) :: LDA11, LDA21 INTEGER, intent(in) :: DECOMP_TIMER INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN, ONLY_NELIM_IN INTEGER :: IP, M, N, BIP, BIP_START, BEG_I, END_I, ONLY_NELIM #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER :: K, I DOUBLE PRECISION :: PROMOTE_COST INTEGER(8) :: POSELT_BLOCK, LD_BLK_IN_FRONT COMPLEX(kind=8) :: ONE, ALPHA, ZERO PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN ELSE BEG_I = CURRENT_BLR+1 ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN ELSE END_I = NB_BLR ENDIF IF(present(ONLY_NELIM_IN)) THEN ONLY_NELIM = ONLY_NELIM_IN ELSE ONLY_NELIM = 0 ENDIF LD_BLK_IN_FRONT = int(LDA11,8) BIP_START = BEGS_BLR_FIRST_OFFDIAG IF (BEG_I .NE. CURRENT_BLR+1) THEN DO I = 1, BEG_I - CURRENT_BLR - 1 BIP_START = BIP_START + BLR_PANEL(I)%M ENDDO ENDIF #if defined(BLR_NOOPENMP) BIP = BIP_START #endif #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC, CHUNK) #endif DO IP = BEG_I, END_I #if ! defined(BLR_NOOPENMP) BIP = BIP_START DO I = BEG_I, IP-1 BIP = BIP + BLR_PANEL(I-CURRENT_BLR)%M ENDDO #endif IF (DIR .eq. 'V') THEN IF (BIP .LE. LDA21) THEN POSELT_BLOCK = POSELT + int(LDA11,8)*int(BIP-1,8) + & int(BEGS_BLR_DIAG - 1,8) ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(LDA21,8)+ & int(BEGS_BLR_DIAG - 1,8) POSELT_BLOCK = POSELT_BLOCK + & int(LDA21,8)*int(BIP-1-LDA21,8) LD_BLK_IN_FRONT=int(LDA21,8) ENDIF ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(BEGS_BLR_DIAG-1,8) & + int(BIP-1,8) ENDIF M = BLR_PANEL(IP-CURRENT_BLR)%M N = BLR_PANEL(IP-CURRENT_BLR)%N IF(present(ONLY_NELIM_IN)) THEN ONLY_NELIM = ONLY_NELIM_IN ELSE ONLY_NELIM = N ENDIF K = BLR_PANEL(IP-CURRENT_BLR)%K IF (BLR_PANEL(IP-CURRENT_BLR)%ISLR) THEN IF (K.EQ.0) THEN IF (DIR .eq. 'V') THEN DO I = 1, M IF (BIP+I-1.GT.LDA21) THEN LD_BLK_IN_FRONT = int(LDA21,8) ENDIF A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT & + int(N-1,8)) = ZERO ENDDO ELSE DO I = N-ONLY_NELIM+1, N A(POSELT_BLOCK+int(I-1,8)*int(LDA11,8): & POSELT_BLOCK+int(I-1,8)*int(LDA11,8) + int(M-1,8)) & = ZERO ENDDO ENDIF GOTO 1800 ENDIF IF (DIR .eq. 'V') THEN IF (DIR .eq.'V' .AND. BIP .LE. LDA21 & .AND. BIP + M - 1 .GT. LDA21) THEN CALL zgemm('T', 'T', N, LDA21-BIP+1, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) CALL zgemm('T', 'T', N, BIP+M-LDA21-1, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(LDA21-BIP+2,1) , M, & ZERO, A(POSELT_BLOCK+int(LDA21-BIP,8)*int(LDA11,8)), & LDA21) ELSE CALL zgemm('T', 'T', N, M, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) ENDIF ELSE CALL zgemm('N', 'N', M, ONLY_NELIM, K, ONE, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1), M, & BLR_PANEL(IP-CURRENT_BLR)%R(1,N-ONLY_NELIM+1), K, ZERO, & A(POSELT_BLOCK+int(N-ONLY_NELIM,8)*int(LDA11,8)), LDA11) ENDIF PROMOTE_COST = 2.0D0*M*K*ONLY_NELIM IF(present(ONLY_NELIM_IN)) THEN CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .FALSE.) ENDIF ELSE IF (COPY_DENSE_BLOCKS) THEN IF (DIR .eq. 'V') THEN DO I = 1, M IF (BIP+I-1.GT.LDA21) THEN LD_BLK_IN_FRONT = int(LDA21,8) ENDIF A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT & + int(N-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N) ENDDO ELSE DO I = N-ONLY_NELIM+1, N A(POSELT_BLOCK+int(I-1,8)*int(LDA11,8): & POSELT_BLOCK+int(I-1,8)*int(LDA11,8) + int(M-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) ENDDO ENDIF ENDIF 1800 CONTINUE #if defined(BLR_NOOPENMP) BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif END SUBROUTINE ZMUMPS_DECOMPRESS_PANEL SUBROUTINE ZMUMPS_COMPRESS_CB(A, LA, POSELT, LDA, & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY, & NELIM, & NBROWSinF & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & KPERCENT, TOL_OPT, LWORK INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), TARGET, intent(inout) :: CB_LRB(:,:) INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U DOUBLE PRECISION, TARGET, DIMENSION(:) :: RWORK COMPLEX(kind=8), TARGET, DIMENSION(:,:) :: BLOCK COMPLEX(kind=8), TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER(8) :: KEEP8(150) DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500) DOUBLE PRECISION, OPTIONAL :: M_ARRAY(max(NFS4FATHER,1)) INTEGER, intent(in), OPTIONAL :: NELIM INTEGER, intent(in), OPTIONAL :: NBROWSinF INTEGER :: M, N, INFO INTEGER :: I, J, IBIS, IBIS_END, RANK, MAXRANK, II, JJ INTEGER(8) :: POSELT_BLOCK LOGICAL :: ISLR TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: OMP_NUM INTEGER(8) :: POSA, ASIZE INTEGER :: NROWS_CM #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif DOUBLE PRECISION, POINTER, DIMENSION(:) :: RWORK_THR COMPLEX(kind=8), POINTER, DIMENSION(:,:) :: BLOCK_THR COMPLEX(kind=8), POINTER, DIMENSION(:) :: WORK_THR, TAU_THR INTEGER, POINTER, DIMENSION(:) :: JPVT_THR COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & (NFS4FATHER.GT.0) ) THEN IF (NIV.EQ.1) THEN NROWS_CM = NROWS - (NFS4FATHER-NELIM) ELSE NROWS_CM = NROWS - NBROWSinF ENDIF IF (NROWS_CM-NVSCHUR_K253.GT.0) THEN IF (NIV.EQ.1) THEN POSA = POSELT & + int(LDA,8)*int(NPIV+NFS4FATHER,8) & + int(NPIV,8) ASIZE = int(LDA,8)*int(LDA,8) & - int(LDA,8)*int(NPIV+NFS4FATHER,8) & - int(NPIV,8) ELSE POSA = POSELT & + int(LDA,8)*int(NBROWSinF,8) & + int(NPIV,8) ASIZE = int(NROWS,8)*int(LDA,8) & - int(LDA,8)*int(NBROWSinF,8) & - int(NPIV,8) ENDIF CALL ZMUMPS_COMPUTE_MAXPERCOL ( & A(POSA), ASIZE, LDA, & NROWS_CM-NVSCHUR_K253, & M_ARRAY(1), NFS4FATHER, .FALSE., & -9999) ELSE DO I=1, NFS4FATHER M_ARRAY(I) = ZERO ENDDO ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (SYM.EQ.0.OR.NIV.EQ.2) THEN IBIS_END = NB_ROWS*NB_COLS ELSE IBIS_END = NB_ROWS*(NB_COLS+1)/2 ENDIF #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELT_BLOCK, M, N, OMP_NUM, INFO, RANK, !$OMP& MAXRANK, ISLR, II, JJ, LRB) #endif DO IBIS = 1,IBIS_END IF (IFLAG.LT.0) CYCLE OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) WORK_THR => WORK(OMP_NUM*LWORK+1: & (OMP_NUM+1)*LWORK) RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: & (OMP_NUM+1)*2*MAXI_CLUSTER) IF (SYM.EQ.0.OR.NIV.EQ.2) THEN I = (IBIS-1)/NB_COLS+1 J = IBIS - (I-1)*NB_COLS ELSE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 ENDIF IF (NIV.EQ.1) THEN I = I+NB_INASM J = J+NB_INASM ELSE J = J+NB_INASM IF (SYM.NE.0) THEN IF (BEGS_BLR_U(J).GE.BEGS_BLR(I+2)+NCOLS-NROWS-1+ & BEGS_BLR_U(NB_INASM+1)) THEN CYCLE ENDIF ENDIF ENDIF IF (NIV.EQ.1) THEN M = BEGS_BLR(I+1)-BEGS_BLR(I) POSELT_BLOCK = POSELT + int(LDA,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR_U(J)-1,8) IF (I .EQ. NB_INASM+1 .AND. present(NELIM)) THEN POSELT_BLOCK = POSELT_BLOCK + int(NELIM,8)*int(LDA,8) M = M - NELIM ENDIF N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ELSE M = BEGS_BLR(I+2)-BEGS_BLR(I+1) POSELT_BLOCK = POSELT + int(LDA,8)*int(BEGS_BLR(I+1)-1,8) & + int(BEGS_BLR_U(J)-1,8) IF (SYM.EQ.0) THEN N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ELSE N = min(BEGS_BLR_U(J+1), BEGS_BLR(I+2) + NCOLS - NROWS -1 & + BEGS_BLR_U(NB_INASM+1)) - BEGS_BLR_U(J) ENDIF ENDIF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (NIV.EQ.1) THEN LRB => CB_LRB(I-NB_INASM,J-NB_INASM) ELSE LRB => CB_LRB(I,J-NB_INASM) ENDIF IF (K489.EQ.3) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 ISLR = .FALSE. GOTO 3800 ENDIF DO II=1,M BLOCK_THR(II,1:N)= & A( POSELT_BLOCK+int(II-1,8)*int(LDA,8) : & POSELT_BLOCK+int(II-1,8)*int(LDA,8)+int(N-1,8) ) ENDDO MAXRANK = floor(dble(M*N)/dble(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL ZMUMPS_TRUNCATED_RRQR( M, N, & BLOCK_THR(1,1), & MAXI_CLUSTER, JPVT_THR(1), & TAU_THR(1), & WORK_THR(1), N, & RWORK_THR(1), & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO, & ISLR) 3800 CONTINUE IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A CB BLOCK" CALL MUMPS_ABORT() END IF CALL ALLOC_LRB(LRB, RANK, M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF (ISLR) THEN IF (RANK .GT. 0) THEN DO JJ=1,N DO II=1,MIN(RANK,JJ) LRB%R(II,JPVT_THR(JJ)) = BLOCK_THR(II,JJ) ENDDO IF(JJ.LT.RANK) LRB%R(MIN(RANK,JJ)+1:RANK,JPVT_THR(JJ)) & = ZERO ENDDO CALL zungqr & (M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & WORK_THR(1), LWORK, INFO ) DO II=1,RANK DO JJ= 1, M LRB%Q(JJ,II) = BLOCK_THR(JJ,II) ENDDO END DO IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNGQR WHILE COMPRESSING A CB BLOCK" CALL MUMPS_ABORT() END IF IF (K489.NE.3) THEN CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, & LRB%ISLR, CB_COMPRESS=.TRUE.) ENDIF END IF CALL UPD_MRY_CB_LRGAIN(LRB%M, LRB%N, LRB%K & ) ELSE DO II=1,M LRB%Q(II,1:N) = & A( POSELT_BLOCK+int((II-1),8)*int(LDA,8) : & POSELT_BLOCK+int((II-1),8)*int(LDA,8) & +int(N-1,8) ) END DO IF (K489.NE.3) THEN CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, & LRB%ISLR, CB_COMPRESS=.TRUE.) ENDIF LRB%K = -1 END IF END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif CALL UPD_MRY_CB_FR(NROWS, NCOLS, SYM) #if ! defined(BLR_NOOPENMP) !$OMP END MASTER #endif END SUBROUTINE ZMUMPS_COMPRESS_CB SUBROUTINE ZMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K458, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8, & K480, BEG_I_IN, END_I_IN, FRSWAP & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), TARGET, intent(inout) :: BLR_PANEL(:) DOUBLE PRECISION, TARGET, DIMENSION(:) :: RWORK COMPLEX(kind=8), TARGET, DIMENSION(:,:) :: BLOCK COMPLEX(kind=8), TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER :: BEGS_BLR(:) INTEGER(8) :: KEEP8(150) INTEGER, OPTIONAL, intent(in) :: K480 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN LOGICAL, OPTIONAL, intent(in) :: FRSWAP INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, & K458, K473, TOL_OPT LOGICAL, intent(in) :: LBANDSLAVE INTEGER :: MAXI_CLUSTER, LWORK, NELIM DOUBLE PRECISION,intent(in) :: TOLEPS CHARACTER(len=1) :: DIR INTEGER :: IP, NB_BLOCKS_PANEL, M, N, RANK, MAXRANK INTEGER :: INFO, I, J, K, IS, BEG_I, END_I INTEGER(8) :: POSELT_BLOCK LOGICAL :: ISLR COMPLEX(kind=8) :: ONE, ALPHA, ZERO PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: OMP_NUM DOUBLE PRECISION, POINTER, DIMENSION(:) :: RWORK_THR COMPLEX(kind=8), POINTER, DIMENSION(:,:) :: BLOCK_THR COMPLEX(kind=8), POINTER, DIMENSION(:) :: WORK_THR, TAU_THR INTEGER, POINTER, DIMENSION(:) :: JPVT_THR #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN ELSE BEG_I = CURRENT_BLR+1 ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN ELSE END_I = NB_BLR ENDIF IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS=0 ENDIF IF (DIR .eq. 'V') THEN IF (LBANDSLAVE) THEN N = NPIV ELSE N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ENDIF ELSE IF (DIR .eq. 'H') THEN N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ELSE WRITE(*,*) " WRONG ARGUMENT IN ZMUMPS_COMPRESS_PANEL " CALL MUMPS_ABORT() END IF NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO PRIVATE(INFO, POSELT_BLOCK, RANK, MAXRANK, I, J, OMP_NUM, LRB) !$OMP& SCHEDULE(DYNAMIC,CHUNK) #endif DO IP = BEG_I, END_I IF (IFLAG.LT.0) CYCLE #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) WORK_THR => WORK(OMP_NUM*LWORK+1: & (OMP_NUM+1)*LWORK) RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: & (OMP_NUM+1)*2*MAXI_CLUSTER) LRB => BLR_PANEL(IP-CURRENT_BLR) RANK = 0 M = BEGS_BLR(IP+1)-BEGS_BLR(IP) IF (DIR .eq. 'V') THEN POSELT_BLOCK = POSELT + & int(NFRONT,8) * int(BEGS_BLR(IP)-1,8) + & int(BEGS_BLR(CURRENT_BLR) + IS - 1,8) ELSE POSELT_BLOCK = POSELT + & int(NFRONT,8)*int(BEGS_BLR(CURRENT_BLR)-1,8) + & int( BEGS_BLR(IP) - 1,8) ENDIF IF (present(K480)) then IF (K480.GE.5) THEN IF (LRB%ISLR) THEN IF (M.NE.LRB%M) THEN write(*,*) 'Internal error in ZMUMPS_COMPRESS_PANEL', & ' M size inconsistency',M, & LRB%M CALL MUMPS_ABORT() ENDIF IF (N.NE.LRB%N) THEN write(*,*) 'Internal error in ZMUMPS_COMPRESS_PANEL', & ' N size inconsistency',N, & LRB%N CALL MUMPS_ABORT() ENDIF MAXRANK = floor(dble(M*N)/dble(M+N)) IF (LRB%K.GT.MAXRANK) THEN write(*,*) 'Internal error in ZMUMPS_COMPRESS_PANEL', & ' MAXRANK inconsistency',MAXRANK, & LRB%K CALL MUMPS_ABORT() ENDIF GOTO 3000 ENDIF ENDIF ENDIF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (K473.EQ.1 .OR. IP .LT. BEG_I+K458) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 ISLR = .FALSE. GOTO 3800 ENDIF IF (DIR .eq. 'V') THEN DO I=1,M BLOCK_THR(I,1:N)= & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(N-1,8) ) END DO ELSE DO I=1,N BLOCK_THR(1:M,I)= & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) END DO END IF MAXRANK = floor(dble(M*N)/dble(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL ZMUMPS_TRUNCATED_RRQR( M, N, & BLOCK_THR(1,1), & MAXI_CLUSTER, JPVT_THR(1), & TAU_THR(1), & WORK_THR(1), N, & RWORK_THR(1), & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO, & ISLR) 3800 CONTINUE IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF CALL ALLOC_LRB(LRB, RANK, & M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF ((M.EQ.0).OR.(N.EQ.0)) THEN GOTO 3000 ENDIF IF (ISLR) THEN IF (RANK .EQ. 0) THEN ELSE DO J=1,N DO K=1,min(RANK,J) LRB%R(K, JPVT_THR(J)) = BLOCK_THR(K,J) ENDDO IF(J.LT.RANK) THEN LRB%R(J+1:RANK,JPVT_THR(J)) = ZERO ENDIF ENDDO CALL zungqr & (M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & WORK_THR(1), LWORK, INFO ) DO I=1,RANK DO K=1,M LRB%Q(K,I) = BLOCK_THR(K,I) ENDDO END DO IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNGQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF IF (present(FRSWAP)) THEN CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, LRB%ISLR, & FRSWAP=FRSWAP) ELSE CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, LRB%ISLR) ENDIF END IF ELSE IF (DIR .eq. 'V') THEN DO I=1,M LRB%Q(I,1:N) = & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) & +int(N-1,8) ) END DO ELSE DO I=1,N LRB%Q(1:M,I) = & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) & +int(M-1,8) ) END DO END IF IF (K473.EQ.0) THEN IF (present(FRSWAP)) THEN CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, LRB%ISLR, & FRSWAP=FRSWAP) ELSE CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, LRB%ISLR) ENDIF ENDIF LRB%K = -1 END IF 3000 CONTINUE END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO NOWAIT #endif RETURN END SUBROUTINE ZMUMPS_COMPRESS_PANEL SUBROUTINE ZMUMPS_BLR_PANEL_LRTRSM( & A, & LA, POSELT, NFRONT, & IBEG_BLOCK, NB_BLR, & BLR_LorU, & CURRENT_BLR, FIRST_BLOCK, LAST_BLOCK, & NIV, SYM, LorU, LBANDSLAVE, & IW, OFFSET_IW, NASS) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & NIV, SYM, LorU LOGICAL, intent(in) :: LBANDSLAVE INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: IBEG_BLOCK, FIRST_BLOCK, LAST_BLOCK INTEGER, OPTIONAL, intent(in) :: NASS COMPLEX(kind=8), intent(inout) :: A(LA) TYPE(LRB_TYPE), intent(inout) :: BLR_LorU(:) INTEGER, OPTIONAL :: OFFSET_IW INTEGER, OPTIONAL :: IW(*) INTEGER(8) :: POSELT_LOCAL INTEGER :: IP, LDA #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) LDA = NFRONT IF (LorU.EQ.0.AND.SYM.NE.0.AND.NIV.EQ.2 & .AND.(.NOT.LBANDSLAVE)) THEN IF (present(NASS)) THEN LDA = NASS ELSE write(*,*) 'Internal error in ZMUMPS_BLR_PANEL_LRTRSM' CALL MUMPS_ABORT() ENDIF ENDIF IF (LBANDSLAVE) THEN POSELT_LOCAL = POSELT ELSE POSELT_LOCAL = POSELT + & int(IBEG_BLOCK-1,8)*int(LDA,8) + int(IBEG_BLOCK - 1,8) ENDIF #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO !$OMP& SCHEDULE(DYNAMIC,CHUNK) #endif DO IP = FIRST_BLOCK, LAST_BLOCK CALL ZMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA, & BLR_LorU(IP-CURRENT_BLR), NIV, SYM, LorU, & IW, OFFSET_IW) END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO NOWAIT #endif END SUBROUTINE ZMUMPS_BLR_PANEL_LRTRSM END MODULE ZMUMPS_FAC_LR MUMPS_5.8.1/src/zana_reordertree.F0000664000175000017500000012235715042446441016705 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_REORDER_TREE(N,FRERE, STEP, FILS, & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, & NSTEPS,PERM,SYM,INFO,LP,K215,K234,K55,K199, & PROCNODE,SLAVEF, PEAK,SBTR_WHICH_M & ) IMPLICIT NONE INTEGER N,PERM,SYM, NSTEPS, LNA, LP,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER K215,K234,K55,K199 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) INTEGER :: SBTR_WHICH_M DOUBLE PRECISION PEAK DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: COST_TRAV INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH INTEGER IFATH,IN,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 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 EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR DOUBLE PRECISION COST_NODE INCLUDE 'mumps_headers.h' TOTAL_MEM_SIZE=0_8 ROOT_OF_CUR_SBTR=0 IF((PERM.EQ.0).OR.(PERM.EQ.1).OR. & (PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4).OR. & (PERM.EQ.5).OR.(PERM.EQ.6))THEN LOCAL_PERM=0 ENDIF SBTR_M=.FALSE. MEM_SIZE=0_8 FACT_SIZE=0_8 IF ((PERM.LT.0 .OR. PERM.GT.7)) THEN WRITE(*,*) "Internal Error in ZMUMPS_REORDER_TREE",PERM CALL MUMPS_ABORT() END IF NBLEAF = NA(1) NBROOT = NA(2) IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) RETURN IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ENDIF IF(PERM.NE.7)THEN ALLOCATE(M(NSTEPS),stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error &in ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ALLOCATE( IPOOL(NBLEAF), fact(NSTEPS),TNSTK(NSTEPS), & stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF II=0 DO I=1,NSTEPS TNSTK(I) = NE(I) IF(NE(I).GE.II) II=NE(I) ENDDO SIZE_TAB=max(II,NBROOT) ALLOCATE(SON(II), TEMP(II), & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), & RESULT(SIZE_TAB),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SIZE_TAB RETURN ENDIF IF(PERM.EQ.7) THEN GOTO 001 ENDIF IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN ALLOCATE(COST_TRAV(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error & in ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF COST_TRAV=0.0D0 COST_NODE=0.0d0 ENDIF IF(NBROOT.EQ.NBLEAF)THEN IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN WRITE(*,*)'Internal Error in reordertree:' WRITE(*,*)' problem with perm parameter in reordertree' CALL MUMPS_ABORT() ENDIF DO I=1,NBROOT TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) IPOOL(I)=NA(I+2+NBLEAF) M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) ENDDO CALL ZMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) GOTO 789 ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN ALLOCATE(DEPTH(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DEPTH=0 NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) 499 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 4602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 4602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) SON(I)=IN IN=FRERE(STEP(IN)) ENDDO DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN LEAF=LEAF-1 ELSE fin=fin-1 GOTO 499 ENDIF fin=fin-1 IF(fin.EQ.0) GOTO 489 GOTO 499 489 CONTINUE ENDIF DO I=1,NSTEPS M(I)=0_8 IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN M_TOTAL(I)=0_8 ENDIF ENDIF ENDDO DO I=1,NSTEPS fact(I)=0_8 ENDDO IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 91 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 96 CONTINUE NFR = int(ND(STEP(INODE)),8) NELIM4 = 0 IN = INODE 101 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 101 NELIM=int(NELIM4,8) IF(NE(STEP(INODE)).EQ.0) THEN M(STEP(INODE))=NFR*NFR IF (SBTR_M.OR.(PERM.EQ.2)) THEN M_TOTAL(STEP(INODE))=NFR*NFR ENDIF ENDIF IF((PERM.EQ.4).OR.(PERM.EQ.3))THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN DEPTH(STEP(INODE))=0 ENDIF ENDIF IF ( SYM .eq. 0 ) THEN fact(STEP(INODE))=fact(STEP(INODE))+ & (2_8*NFR*NELIM)-(NELIM*NELIM) ELSE fact(STEP(INODE))=fact(STEP(INODE))+NFR*NELIM ENDIF IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 113 IN = FRERE(IN) IF (IN.GT.0) GO TO 113 IFATH = -IN ENDIF IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 116 GOTO 91 ELSE fact(STEP(IFATH))=fact(STEP(IFATH))+fact(STEP(INODE)) IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEPTH(STEP(IFATH))=max(DEPTH(STEP(INODE)), & DEPTH(STEP(IFATH))) ENDIF ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH IN=INODE dernier=IN I=1 5700 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN I=I+1 GOTO 5700 ENDIF NCB=int(ND(STEP(INODE))-I,8) IN=-IN IF(PERM.NE.7)THEN DO I=1,NE(STEP(INODE)) SON(I)=IN TEMP(I)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) ENDDO ELSE DO I=NE(STEP(INODE)),1,-1 SON(I)=IN TEMP(I)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) ENDDO ENDIF NFR = int(ND(STEP(INODE)),8) DO II=1,NE(STEP(INODE)) TAB1(II)=0_8 TAB2(II)=0_8 cour=SON(II) NELIM4=1 151 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 151 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0)) THEN SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) & *(int(ND(STEP(SON(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) & *(int(ND(STEP(SON(II))),8)- & NELIM+1_8)/2_8 ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.5))THEN IF (K234 .NE. 0 .AND. K55.EQ.0 ) THEN TMP8=NFR TMP8=TMP8*TMP8 TAB1(II)=max(TMP8, M(STEP(SON(II)))) - SIZECB TAB2(II)=SIZECB ELSE TAB1(II)=M(STEP(SON(II)))- SIZECB TAB2(II)=SIZECB ENDIF ENDIF IF((PERM.EQ.1).OR.(PERM.EQ.6)) THEN TAB1(II)=M(STEP(SON(II)))-SIZECB TAB1(II)=TAB1(II)-fact(STEP(SON(II))) TAB2(II)=SIZECB+fact(STEP(SON(II))) ENDIF IF(PERM.EQ.2)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M_TOTAL(STEP(SON(II)))-SIZECB & -fact(STEP(SON(II))) TAB2(II)=SIZECB ELSE TAB1(II)=M(STEP(SON(II)))-SIZECB TAB2(II)=SIZECB ENDIF ENDIF IF(PERM.EQ.3)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M(STEP(SON(II)))-SIZECB TAB2(II)=SIZECB ELSE TAB1(II)=int(DEPTH(STEP(SON(II))),8) TAB2(II)=M(STEP(SON(II))) ENDIF ENDIF IF(PERM.EQ.4)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M(STEP(SON(II)))- & SIZECB-fact(STEP(SON(II))) TAB2(II)=SIZECB ELSE TAB1(II)=int(DEPTH(STEP(SON(II))),8) TAB2(II)=M(STEP(SON(II))) ENDIF ENDIF ENDDO CALL ZMUMPS_FUSION_SORT(SON,NE(STEP(INODE)),TAB1,TAB2, & LOCAL_PERM & ,RESULT,T1,T2) IF(PERM.EQ.0) THEN DO II=1,NE(STEP(INODE)) cour=TEMP(II) NELIM4=1 153 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 153 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 ENDIF TAB1(II)=SIZECB ENDDO CALL ZMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, & RESULT,T1,T2) ENDIF IF(PERM.EQ.1) THEN DO II=1,NE(STEP(INODE)) cour=TEMP(II) NELIM4=1 187 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 187 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 ENDIF TAB1(II)=SIZECB+fact(STEP(TEMP(II))) ENDDO CALL ZMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, & RESULT,T1,T2) ENDIF 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 TMP_SUM=0_8 IF(II.EQ.1) TAB=>SON IF(II.EQ.2) TAB=>TEMP DO I=1,NE(STEP(INODE)) cour=TAB(I) NELIM4=1 149 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 149 ENDIF NELIM=int(NELIM4, 8) NFR=int(ND(STEP(TAB(I))),8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF MEM_SIZE=max(MEM_SIZE,(M(STEP(TAB(I)))+SUM+FACT_SIZE)) IF (SBTR_M.OR.(PERM.EQ.2)) THEN MEM_SIZE_T=max(MEM_SIZE_T,(M_TOTAL(STEP(TAB(I)))+ & SUM+ & FACT_SIZE_T)) FACT_SIZE_T=FACT_SIZE_T+fact(STEP(TAB(I))) ENDIF TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & (M(STEP(TAB(I)))+SUM+FACT_SIZE)) TMP_SUM=TMP_SUM+fact(STEP(TAB(I))) SUM=SUM+SIZECB SIZECB_LASTSON = SIZECB IF((PERM.EQ.1).OR.(PERM.EQ.4))THEN FACT_SIZE=FACT_SIZE+fact(STEP(TAB(I))) ENDIF ENDDO IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=NCB*NCB ELSE SIZECB=(NCB*(NCB+1_8))/2_8 ENDIF IF (K234.NE.0 .AND. K55.EQ.0) THEN TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8) ) & + SUM-SIZECB_LASTSON+TMP_SUM ) & ) ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8) ) & + SUM + TMP_SUM ) & ) ELSE TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8)) & + max(SUM,SIZECB) + TMP_SUM ) & ) ENDIF IF(II.EQ.1)THEN TMP_TOTAL_MEM_SIZE=TOTAL_MEM_SIZE ENDIF IF(II.EQ.1)THEN IF (K234.NE.0 .AND. K55.EQ.0) THEN M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+SUM-SIZECB_LASTSON+ & FACT_SIZE)) ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+SUM+FACT_SIZE)) ELSE M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN M_TOTAL(STEP(IFATH))=max(MEM_SIZE_T, & ((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+ & FACT_SIZE_T)) ENDIF ENDIF IF((II.EQ.2).AND.(PERM.EQ.1).OR.(PERM.EQ.0).OR. & (PERM.EQ.5).OR.(PERM.EQ.6).OR. & (.NOT.SBTR_M.OR.(SBTR_WHICH_M.NE.1)))THEN MEM_SEC_PERM=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) ENDIF IF((PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4))THEN MEM_SEC_PERM=huge(MEM_SEC_PERM) ENDIF ENDDO IF(MEM_SEC_PERM.EQ.M(STEP(IFATH))) THEN TAB=>TEMP ELSE IF (MEM_SEC_PERM.LT.M(STEP(IFATH))) THEN WRITE(*,*)'Internal error 1 in ZMUMPS_REORDER_TREE', & MEM_SEC_PERM, M(STEP(IFATH)) CALL MUMPS_ABORT() ELSE TOTAL_MEM_SIZE=TMP_TOTAL_MEM_SIZE TAB=>SON ENDIF DO I=NE(STEP(INODE)),1,-1 IF(I.EQ.NE(STEP(INODE))) THEN FILS(dernier)=-TAB(I) dernier=TAB(I) GOTO 222 ENDIF IF(I.EQ.1) THEN FRERE(STEP(dernier))=TAB(I) FRERE(STEP(TAB(I)))=-INODE GOTO 222 ENDIF IF(I.GT.1) THEN FRERE(STEP(dernier))=TAB(I) dernier=TAB(I) GOTO 222 ENDIF 222 CONTINUE ENDDO GOTO 96 ELSE GOTO 91 ENDIF 116 CONTINUE NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) IF (PERM.eq.1) THEN DO I=1,NBROOT TAB1(I)=M(STEP(NA(I+2+NBLEAF)))-fact(STEP(NA(I+2+NBLEAF))) TAB1(I)=-TAB1(I) ENDDO CALL ZMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) ENDIF 001 CONTINUE fin=NBROOT LEAF=NA(1) 999 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 5602 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN GOTO 5602 ENDIF IN=-IN IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF(SLAVEF.NE.1)THEN IF (USE_DAD) THEN IFATH=DAD(INODE) ELSE IN = INODE 395 IN = FRERE(IN) IF (IN.GT.0) GO TO 395 IFATH = -IN ENDIF NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 IN = INODE 396 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 396 NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),K199))THEN COST_TRAV(STEP(INODE))=COST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE COST_TRAV(STEP(INODE))=dble(COST_NODE)+ & COST_TRAV(STEP(IFATH))+ & dble(SIZECB*18_8) ENDIF ELSE COST_TRAV(STEP(INODE))=dble(COST_NODE) ENDIF ENDIF ENDIF DO I=1,NE(STEP(INODE)) TEMP(I)=IN IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)),K199)))THEN NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 II = TEMP(I) 845 NELIM4 = NELIM4 + 1 II = FILS(II) IF (II .GT. 0 ) GOTO 845 NELIM=int(NELIM4,8) CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) TAB1(I)=int(dble(COST_NODE)+ & COST_TRAV(STEP(INODE)),8) TAB2(I)=0_8 ELSE SON(I)=IN ENDIF ELSE SON(I)=IN ENDIF IN=FRERE(STEP(IN)) ENDDO IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)),K199)))THEN CALL ZMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2, & LOCAL_PERM & ,RESULT,T1,T2) TAB=>TEMP DO I=NE(STEP(INODE)),1,-1 IF(I.EQ.NE(STEP(INODE))) THEN FILS(dernier)=-TAB(I) dernier=TAB(I) GOTO 221 ENDIF IF(I.EQ.1) THEN FRERE(STEP(dernier))=TAB(I) FRERE(STEP(TAB(I)))=-INODE GOTO 221 ENDIF IF(I.GT.1) THEN FRERE(STEP(dernier))=TAB(I) dernier=TAB(I) GOTO 221 ENDIF 221 CONTINUE SON(NE(STEP(INODE))-I+1)=TAB(I) ENDDO ENDIF ENDIF DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN IF(PERM.NE.7)THEN NA(LEAF+2)=INODE ENDIF LEAF=LEAF-1 ELSE fin=fin-1 GOTO 999 ENDIF fin=fin-1 IF(fin.EQ.0) THEN GOTO 789 ENDIF GOTO 999 789 CONTINUE IF(PERM.EQ.7) GOTO 5483 NBROOT=NA(2) NBLEAF=NA(1) PEAK=0.0D0 FACT_SIZE=0_8 DO I=1,NBROOT PEAK=max(PEAK,dble(M(STEP(NA(2+NBLEAF+I))))) FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) ENDDO 5483 CONTINUE DEALLOCATE(IPOOL) DEALLOCATE(fact) DEALLOCATE(TNSTK) DEALLOCATE(SON) DEALLOCATE(TAB2) DEALLOCATE(TAB1) DEALLOCATE(T1) DEALLOCATE(T2) DEALLOCATE(RESULT) DEALLOCATE(TEMP) IF(PERM.NE.7)THEN DEALLOCATE(M) ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEALLOCATE(DEPTH) ENDIF IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN DEALLOCATE(COST_TRAV) ENDIF IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN DEALLOCATE(M_TOTAL) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_REORDER_TREE SUBROUTINE ZMUMPS_BUILD_LOAD_MEM_INFO(N,FRERE, STEP, FILS, & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, & NSTEPS,PERM,SYM,INFO,LP,K47,K81,K76,K215,K234,K55,KEEP199, & PROCNODE,MEM_SUBTREE,SLAVEF, SIZE_MEM_SBTR, PEAK & ,SBTR_WHICH_M,SIZE_DEPTH_FIRST,SIZE_COST_TRAV, & DEPTH_FIRST_TRAV,DEPTH_FIRST_SEQ,COST_TRAV,MY_FIRST_LEAF, & MY_NB_LEAF,MY_ROOT_SBTR,SBTR_ID & ) IMPLICIT NONE INTEGER N,PERM,SYM, NSTEPS, LNA, LP, SIZE_MEM_SBTR,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER K47,K81,K76,K215,K234,K55,KEEP199 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) DOUBLE PRECISION, intent(out) :: MEM_SUBTREE(SIZE_MEM_SBTR,SLAVEF) INTEGER :: SBTR_WHICH_M INTEGER MY_FIRST_LEAF(SIZE_MEM_SBTR,SLAVEF), & MY_ROOT_SBTR(SIZE_MEM_SBTR,SLAVEF), & MY_NB_LEAF(SIZE_MEM_SBTR,SLAVEF) EXTERNAL MUMPS_ROOTSSARBR,MUMPS_PROCNODE LOGICAL MUMPS_ROOTSSARBR INTEGER MUMPS_PROCNODE DOUBLE PRECISION PEAK INTEGER SIZE_DEPTH_FIRST,DEPTH_FIRST_TRAV(SIZE_DEPTH_FIRST), & DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST) INTEGER SIZE_COST_TRAV INTEGER SBTR_ID(SIZE_DEPTH_FIRST),OOC_CUR_SBTR DOUBLE PRECISION COST_TRAV(SIZE_COST_TRAV) INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH INTEGER IFATH,IN,INODE,I,allocok 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,fin,RANK_TRAV INTEGER II INTEGER ROOT_OF_CUR_SBTR INTEGER(8), DIMENSION (:), ALLOCATABLE :: T1,T2 INTEGER, DIMENSION (:), ALLOCATABLE :: RESULT INTEGER(8) FACT_SIZE, & SIZECB LOGICAL SBTR_M INTEGER,DIMENSION(:),ALLOCATABLE :: INDICE INTEGER ID,FIRST_LEAF,SIZE_SBTR EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR DOUBLE PRECISION COST_NODE INTEGER CUR_DEPTH_FIRST_RANK INCLUDE 'mumps_headers.h' ROOT_OF_CUR_SBTR=0 ALLOCATE(INDICE( SLAVEF ), stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in &ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SLAVEF RETURN ENDIF IF (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)))) FACT_SIZE=0_8 IF ((PERM.GT.7).AND. & (.NOT.(K47 == 4 .OR. ((K47.GE.2).AND.(K81 .GE. 1))))) THEN WRITE(*,*) "Internal Error in ZMUMPS_REORDER_TREE",PERM CALL MUMPS_ABORT() END IF NBLEAF = NA(1) NBROOT = NA(2) CUR_DEPTH_FIRST_RANK=1 IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) THEN DEALLOCATE(INDICE) RETURN ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ENDIF ALLOCATE( IPOOL(NBLEAF), M(NSTEPS), fact(NSTEPS), & TNSTK(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF II=0 DO I=1,NSTEPS TNSTK(I) = NE(I) IF(NE(I).GE.II) II=NE(I) ENDDO SIZE_TAB=max(II,NBROOT) ALLOCATE(SON(II), TEMP(II), & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), & RESULT(SIZE_TAB),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SIZE_TAB RETURN ENDIF IF(NBROOT.EQ.NBLEAF)THEN IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN WRITE(*,*)'Internal Error in reordertree:' WRITE(*,*)' problem with perm parameter in reordertree' CALL MUMPS_ABORT() ENDIF DO I=1,NBROOT TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) IPOOL(I)=NA(I+2+NBLEAF) M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) ENDDO CALL ZMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) GOTO 789 ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN ALLOCATE(DEPTH(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DEPTH=0 NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) 499 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 4602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 4602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) SON(I)=IN IN=FRERE(STEP(IN)) ENDDO DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN LEAF=LEAF-1 ELSE fin=fin-1 GOTO 499 ENDIF fin=fin-1 IF(fin.EQ.0) GOTO 489 GOTO 499 489 CONTINUE ENDIF IF(K76.EQ.4.OR.(K76.EQ.6))THEN RANK_TRAV=NSTEPS DEPTH_FIRST_TRAV=0 DEPTH_FIRST_SEQ=0 ENDIF IF((K76.EQ.5).OR.(PERM.EQ.5).OR.(PERM.EQ.6))THEN COST_TRAV=0.0D0 COST_NODE=0.0d0 ENDIF DO I=1,NSTEPS M(I)=0_8 IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN M_TOTAL(I)=0_8 ENDIF ENDIF ENDDO DO I=1,NSTEPS fact(I)=0_8 ENDDO NBROOT = NA(2) NBLEAF = NA(1) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) FIRST_LEAF=-9999 SIZE_SBTR=0 999 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IF(SIZE_SBTR.NE.0)THEN IF(.NOT.MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1))THEN MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR FIRST_LEAF=-9999 SIZE_SBTR=0 ENDIF ENDIF ENDIF ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN ROOT_OF_CUR_SBTR=INODE ENDIF IF (K76.EQ.4)THEN IF(SLAVEF.NE.1)THEN WRITE(*,*)'INODE=',INODE,'RANK',RANK_TRAV IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN DEPTH_FIRST_TRAV(STEP(INODE))=DEPTH_FIRST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE DEPTH_FIRST_TRAV(STEP(INODE))=RANK_TRAV ENDIF RANK_TRAV=RANK_TRAV-1 ENDIF ENDIF IF (K76.EQ.5)THEN IF(SLAVEF.NE.1)THEN IF (USE_DAD) THEN IFATH=DAD(INODE) ELSE IN = INODE 395 IN = FRERE(IN) IF (IN.GT.0) GO TO 395 IFATH = -IN ENDIF NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 IN = INODE 396 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 396 NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN COST_TRAV(STEP(INODE))=COST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE COST_TRAV(STEP(INODE))=dble(COST_NODE)+ & COST_TRAV(STEP(IFATH))+ & dble(SIZECB*18_8) ENDIF ELSE COST_TRAV(STEP(INODE))=dble(COST_NODE) ENDIF IF(K76.EQ.5)THEN WRITE(*,*)'INODE=',INODE,'COST=',COST_TRAV(STEP(INODE)) ENDIF ENDIF ENDIF IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1).AND. & MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF (NE(STEP(INODE)).NE.0) THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M_TOTAL(STEP(INODE))) ELSE MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M(STEP(INODE))) ENDIF MY_ROOT_SBTR(INDICE(ID+1),ID+1)=INODE INDICE(ID+1)=INDICE(ID+1)+1 ENDIF ENDIF IF((SLAVEF.EQ.1).AND.FRERE(STEP(INODE)).EQ.0)THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M_TOTAL(STEP(INODE))) ELSE MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M(STEP(INODE))) ENDIF INDICE(ID+1)=INDICE(ID+1)+1 ENDIF ENDIF IN=INODE 5602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 5602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) IPOOL(fin)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF(SLAVEF.NE.1)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF(FIRST_LEAF.EQ.-9999)THEN FIRST_LEAF=INODE ENDIF SIZE_SBTR=SIZE_SBTR+1 ENDIF ENDIF ENDIF IF(PERM.NE.7)THEN NA(LEAF+2)=INODE ENDIF LEAF=LEAF-1 ELSE fin=fin-1 GOTO 999 ENDIF fin=fin-1 IF(fin.EQ.0) THEN IF(SIZE_SBTR.NE.0)THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1))THEN MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR FIRST_LEAF=-9999 SIZE_SBTR=0 ENDIF ENDIF ENDIF GOTO 789 ENDIF GOTO 999 789 CONTINUE IF(K76.EQ.6)THEN OOC_CUR_SBTR=1 DO I=1,NSTEPS TNSTK(I) = NE(I) ENDDO NBROOT=NA(2) NBLEAF=NA(1) IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 9100 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 9600 CONTINUE IF(SLAVEF.NE.1)THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) DEPTH_FIRST_TRAV(STEP(INODE))=CUR_DEPTH_FIRST_RANK DEPTH_FIRST_SEQ(CUR_DEPTH_FIRST_RANK)=INODE CUR_DEPTH_FIRST_RANK=CUR_DEPTH_FIRST_RANK+1 IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP199))THEN SBTR_ID(STEP(INODE))=OOC_CUR_SBTR ELSE SBTR_ID(STEP(INODE))=-9999 ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)), & KEEP199))THEN OOC_CUR_SBTR=OOC_CUR_SBTR+1 ENDIF ENDIF IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 1133 IN = FRERE(IN) IF (IN.GT.0) GO TO 1133 IFATH = -IN ENDIF IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 1163 GOTO 9100 ENDIF TNSTK(STEP(IFATH))=TNSTK(STEP(IFATH))-1 IF(TNSTK(STEP(IFATH)).EQ.0) THEN INODE=IFATH GOTO 9600 ELSE GOTO 9100 ENDIF 1163 CONTINUE ENDIF PEAK=0.0D0 FACT_SIZE=0_8 DO I=1,NBROOT PEAK=max(PEAK,dble(M(STEP(NA(2+NBLEAF+I))))) FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) ENDDO DEALLOCATE(IPOOL) DEALLOCATE(M) DEALLOCATE(fact) DEALLOCATE(TNSTK) DEALLOCATE(SON) DEALLOCATE(TAB2) DEALLOCATE(TAB1) DEALLOCATE(T1) DEALLOCATE(T2) DEALLOCATE(RESULT) DEALLOCATE(TEMP) DEALLOCATE(INDICE) IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEALLOCATE(DEPTH) ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN DEALLOCATE(M_TOTAL) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_BUILD_LOAD_MEM_INFO RECURSIVE SUBROUTINE ZMUMPS_FUSION_SORT(TAB,DIM,TAB1,TAB2,PERM, & RESULT,TEMP1,TEMP2) IMPLICIT NONE INTEGER DIM INTEGER(8) TAB1(DIM),TAB2(DIM) INTEGER(8) TEMP1(DIM),TEMP2(DIM) INTEGER TAB(DIM), PERM,RESULT(DIM) INTEGER I,J,I1,I2 IF(DIM.EQ.1) THEN RESULT(1)=TAB(1) TEMP1(1)=TAB1(1) TEMP2(1)=TAB2(1) RETURN ENDIF I=DIM/2 CALL ZMUMPS_FUSION_SORT(TAB(1),I,TAB1(1),TAB2(1),PERM, & RESULT(1),TEMP1(1),TEMP2(1)) CALL ZMUMPS_FUSION_SORT(TAB(I+1),DIM-I,TAB1(I+1),TAB2(I+1), & PERM,RESULT(I+1),TEMP1(I+1),TEMP2(I+1)) I1=1 I2=I+1 J=1 DO WHILE ((I1.LE.I).AND.(I2.LE.DIM)) IF((PERM.EQ.3))THEN IF(TEMP1(I1).LE.TEMP1(I2))THEN TAB(J)=RESULT(I1) TAB1(J)=TEMP1(I1) J=J+1 I1=I1+1 ELSE TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) J=J+1 I2=I2+1 ENDIF GOTO 3 ENDIF IF((PERM.EQ.4).OR.(PERM.EQ.5))THEN IF (TEMP1(I1).GE.TEMP1(I2))THEN TAB(J)=RESULT(I1) TAB1(J)=TEMP1(I1) J=J+1 I1=I1+1 ELSE TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) J=J+1 I2=I2+1 ENDIF GOTO 3 ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.1).OR.(PERM.EQ.2)) THEN IF(TEMP1(I1).GT.TEMP1(I2))THEN TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 GOTO 3 ENDIF IF(TEMP1(I1).LT.TEMP1(I2))THEN TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) TAB(J)=RESULT(I2) J=J+1 I2=I2+1 GOTO 3 ENDIF IF((TEMP1(I1).EQ.TEMP1(I2)))THEN IF(TEMP2(I1).LE.TEMP2(I2))THEN TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 ELSE TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) TAB(J)=RESULT(I2) J=J+1 I2=I2+1 ENDIF ENDIF ENDIF 3 CONTINUE ENDDO IF(I1.GT.I)THEN DO WHILE(I2.LE.DIM) TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) J=J+1 I2=I2+1 ENDDO ELSE IF(I2.GT.DIM)THEN DO WHILE(I1.LE.I) TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 ENDDO ENDIF ENDIF DO I=1,DIM TEMP1(I)=TAB1(I) TEMP2(I)=TAB2(I) RESULT(I)=TAB(I) ENDDO RETURN END SUBROUTINE ZMUMPS_FUSION_SORT MUMPS_5.8.1/src/sfac_mem_alloc_cb.F0000664000175000017500000001556015042446437016744 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, PROCESS_BANDE, & MYID,N, KEEP,KEEP8,DKEEP, & IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LREQ, LREQCB, NODE_ARG, STATE_ARG, SET_HEADER, & COMP, LRLUS, LRLUSM, IFLAG, IERROR ) !$ USE OMP_LIB USE MUMPS_LOAD IMPLICIT NONE INTEGER N,LIW, KEEP(500) INTEGER(8) LA, LRLU, IPTRLU, LRLUS, LRLUSM, LREQCB INTEGER(8) PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER IWPOS,IWPOSCB INTEGER(8) :: MIN_SPACE_IN_PLACE INTEGER NODE_ARG, STATE_ARG INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER IW(LIW),PTRIST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER MYID, IXXP REAL A(LA) LOGICAL INPLACE, PROCESS_BANDE, SSARBR, SET_HEADER INTEGER COMP, LREQ, IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER INODE_LOC,NPIV,NASS,NROW,NCB INTEGER ISIZEHOLE INTEGER(8) :: MEM_GAIN, RSIZEHOLE, LREQCB_EFF, LREQCB_WISHED INTEGER(8) :: DYN_SIZE, KEEP8TMPCOPY IF ( INPLACE ) THEN LREQCB_EFF = MIN_SPACE_IN_PLACE IF ( MIN_SPACE_IN_PLACE > 0_8 ) THEN LREQCB_WISHED = LREQCB ELSE LREQCB_WISHED = 0_8 ENDIF ELSE LREQCB_EFF = LREQCB LREQCB_WISHED = LREQCB ENDIF IF (IWPOSCB.EQ.LIW) THEN IF (LREQ.NE.KEEP(IXSZ).OR.LREQCB.NE.0_8 & .OR. .NOT. SET_HEADER) THEN WRITE(*,*) "Internal error in SMUMPS_ALLOC_CB ", & SET_HEADER, LREQ, LREQCB CALL MUMPS_ABORT() ENDIF IF (IWPOSCB-IWPOS+1 .LT. KEEP(IXSZ)) THEN WRITE(*,*) "Problem with integer stack size",IWPOSCB, & IWPOS, KEEP(IXSZ) IFLAG = -8 IERROR = LREQ RETURN ENDIF IWPOSCB=IWPOSCB-KEEP(IXSZ) IW(IWPOSCB+1+XXI)=KEEP(IXSZ) CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXR)) CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXD)) IW(IWPOSCB+1+XXN)=-919191 IW(IWPOSCB+1+XXS)=S_NOTFREE IW(IWPOSCB+1+XXP)=TOP_OF_STACK RETURN ENDIF CALL MUMPS_GETI8( DYN_SIZE, IW(IWPOSCB+1 + XXD)) IF (DYN_SIZE .EQ. 0_8 & .AND. KEEP(214).EQ.1.AND. & KEEP(216).EQ.1.AND. & IWPOSCB.NE.LIW) THEN IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG.OR. & IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN NCB = IW( IWPOSCB+1 + KEEP(IXSZ) ) NROW = IW( IWPOSCB+1 + KEEP(IXSZ) + 2) NPIV = IW( IWPOSCB+1 + KEEP(IXSZ) + 3) INODE_LOC= IW( IWPOSCB+1 + XXN) CALL SMUMPS_GET_SIZEHOLE(IWPOSCB+1,IW,LIW, & ISIZEHOLE,RSIZEHOLE) IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG) THEN CALL SMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, & NROW,NCB,NPIV+NCB,0, & IW(IWPOSCB+1 + XXS),RSIZEHOLE) IW(IWPOSCB+1 + XXS) =S_NOLCLEANED MEM_GAIN = int(NROW,8)*int(NPIV,8) ENDIF IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN NASS = IW( IWPOSCB+1 + KEEP(IXSZ) + 4) CALL SMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, & NROW,NCB,NPIV+NCB,NASS-NPIV, & IW(IWPOSCB+1 + XXS),RSIZEHOLE) IW(IWPOSCB+1 + XXS) =S_NOLCLEANED38 MEM_GAIN = int(NROW,8)*int(NPIV+NCB-(NASS-NPIV),8) ENDIF IF (ISIZEHOLE.NE.0) THEN CALL SMUMPS_ISHIFT( IW,LIW,IWPOSCB+1, & IWPOSCB+IW(IWPOSCB+1+XXI), & ISIZEHOLE ) IWPOSCB=IWPOSCB+ISIZEHOLE IW(IWPOSCB+1+XXP+IW(IWPOSCB+1+XXI))=IWPOSCB+1 PTRIST(STEP(INODE_LOC))=PTRIST(STEP(INODE_LOC))+ & ISIZEHOLE ENDIF CALL MUMPS_SUBTRI8TOARRAY(IW(IWPOSCB+1+XXR), MEM_GAIN) IPTRLU = IPTRLU+MEM_GAIN+RSIZEHOLE LRLU = LRLU+MEM_GAIN+RSIZEHOLE PTRAST(STEP(INODE_LOC))= & PTRAST(STEP(INODE_LOC))+MEM_GAIN+RSIZEHOLE ENDIF ENDIF IF (LRLU.LT.LREQCB_WISHED)THEN IF (LREQCB_EFF.LT.LREQCB_WISHED) THEN CALL SMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD) ENDIF ENDIF CALL SMUMPS_GET_SIZE_NEEDED & (LREQ, LREQCB_EFF, .FALSE., & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 650 IXXP=IWPOSCB+XXP+1 IF (IXXP.GT.LIW) THEN WRITE(*,*) "Internal error 3 in SMUMPS_ALLOC_CB ",IXXP ENDIF IF (IW(IXXP).GT.0) THEN WRITE(*,*) "Internal error 2 in SMUMPS_ALLOC_CB ",IW(IXXP),IXXP ENDIF IWPOSCB = IWPOSCB - LREQ IF (SET_HEADER) THEN IW(IXXP)= IWPOSCB + 1 IW(IWPOSCB+1:IWPOSCB+1+KEEP(IXSZ))=-99999 IW(IWPOSCB+1+XXI)=LREQ CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXR)) CALL MUMPS_STOREI8(0_8, IW(IWPOSCB+1+XXD)) IW(IWPOSCB+1+XXS)=STATE_ARG IW(IWPOSCB+1+XXN)=NODE_ARG IW(IWPOSCB+1+XXP)=TOP_OF_STACK IW(IWPOSCB+1+XXNBPR)=0 ENDIF IPTRLU = IPTRLU - LREQCB LRLU = LRLU - LREQCB LRLUS = LRLUS - LREQCB_EFF LRLUSM = min(LRLUS, LRLUSM) IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) + LREQCB_EFF KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + LREQCB_EFF KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC ENDIF CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) 650 CONTINUE RETURN END SUBROUTINE SMUMPS_ALLOC_CB MUMPS_5.8.1/src/mumps_scotch.h0000664000175000017500000001126315042446422016110 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_SCOTCH_H #define MUMPS_SCOTCH_H #include "mumps_common.h" #if defined(scotch) || defined(ptscotch) #include "scotch.h" /* Instead of the prototypes below, one could include esmumps.h, * when provided in include directory of scotch installation */ #if ((SCOTCH_VERSION == 6) && (SCOTCH_RELEASE >= 1)) || (SCOTCH_VERSION >= 7) /* esmumpsv prototype with weights of nodes in the graph are used on entry (nv) */ MUMPS_INT esmumpsv( const MUMPS_INT n, const MUMPS_INT iwlen, MUMPS_INT * const pe, const MUMPS_INT pfree, MUMPS_INT * const len, MUMPS_INT * const iw, MUMPS_INT * const nv, MUMPS_INT * const elen, MUMPS_INT * const last); #endif /* esmumps prototype (weights of nodes not used on entry) */ MUMPS_INT esmumps( const MUMPS_INT n, const MUMPS_INT iwlen, MUMPS_INT * const pe, const MUMPS_INT pfree, MUMPS_INT * const len, MUMPS_INT * const iw, MUMPS_INT * const nv, MUMPS_INT * const elen, MUMPS_INT * const last); #if ((SCOTCH_VERSION == 7) && (SCOTCH_RELEASE >= 1)) || (SCOTCH_VERSION >= 8) /* prototypes with contexts */ MUMPS_INT esmumpsvc( const MUMPS_INT n, const MUMPS_INT iwlen, MUMPS_INT * const pe, const MUMPS_INT pfree, MUMPS_INT * const len, MUMPS_INT * const iw, MUMPS_INT * const nv, MUMPS_INT * const elen, MUMPS_INT * const last, SCOTCH_Context * const esmumpscontext ); MUMPS_INT esmumpsc( const MUMPS_INT n, const MUMPS_INT iwlen, MUMPS_INT * const pe, const MUMPS_INT pfree, MUMPS_INT * const len, MUMPS_INT * const iw, MUMPS_INT * const nv, MUMPS_INT * const elen, MUMPS_INT * const last, SCOTCH_Context * const esmumpscontext ); #endif #define MUMPS_SCOTCH_WEIGHTUSED \ F_SYMBOL(scotch_weightused,SCOTCH_WEIGHTUSED) void MUMPS_CALL MUMPS_SCOTCH_WEIGHTUSED( MUMPS_INT * const weightused ); #define MUMPS_SCOTCH_ESMUMPSCONTEXT \ F_SYMBOL(scotch_esmumpscontext,SCOTCH_ESMUMPSCONTEXT) void MUMPS_CALL MUMPS_SCOTCH_ESMUMPSCONTEXT( MUMPS_INT * const esmumpscontext ); #define MUMPS_SCOTCH_ORD \ F_SYMBOL(scotch_ord,SCOTCH_ORD) void MUMPS_CALL MUMPS_SCOTCH_ORD( const MUMPS_INT * const n, const MUMPS_INT * const iwlen, MUMPS_INT * const petab, const MUMPS_INT * const pfree, MUMPS_INT * const lentab, MUMPS_INT * const iwtab, MUMPS_INT * const nvtab, MUMPS_INT * const elentab, MUMPS_INT * const lasttab, MUMPS_INT * const ncmpa, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) SCOTCH_Context * const contextptr, #endif MUMPS_INT * const weightused, MUMPS_INT * const weightrequested ); #define MUMPS_SCOTCH \ F_SYMBOL(scotch,SCOTCH) void MUMPS_CALL MUMPS_SCOTCH( const MUMPS_INT * const n, const MUMPS_INT * const iwlen, MUMPS_INT * const petab, const MUMPS_INT * const pfree, MUMPS_INT * const lentab, MUMPS_INT * const iwtab, MUMPS_INT * const nvtab, MUMPS_INT * const elentab, MUMPS_INT * const lasttab, MUMPS_INT * const ncmpa, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) SCOTCH_Context * const contextptr, #endif MUMPS_INT * const weightused, MUMPS_INT * const weightrequested ); #define MUMPS_SCOTCH_VERSION \ F_SYMBOL(scotch_version,SCOTCH_VERSION) void MUMPS_CALL MUMPS_SCOTCH_VERSION(MUMPS_INT *version); #define MUMPS_SCOTCH_GET_PTHREAD_NUMBER \ F_SYMBOL(scotch_get_pthread_number,SCOTCH_GET_PTHREAD_NUMBER) void MUMPS_CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (MUMPS_INT *PTHREAD_NUMBER); #define MUMPS_SCOTCH_SET_PTHREAD_NUMBER \ F_SYMBOL(scotch_set_pthread_number,SCOTCH_SET_PTHREAD_NUMBER) void MUMPS_CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (MUMPS_INT *PTHREAD_NUMBER); #endif /*scotch or ptscotch*/ #if defined(ptscotch) #include "mpi.h" #include "ptscotch.h" #define MUMPS_DGRAPHINIT \ F_SYMBOL(dgraphinit,DGRAPHINIT) void MUMPS_CALL MUMPS_DGRAPHINIT(SCOTCH_Dgraph *graphptr, MPI_Fint *comm, MPI_Fint *ierr); #endif /*ptscotch*/ #endif MUMPS_5.8.1/src/fac_asm_build_sort_index_ELT_m.F0000664000175000017500000004244015042446423021372 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_BUILD_SORT_INDEX_ELT_M CONTAINS SUBROUTINE MUMPS_ELT_BUILD_SORT( & NUMELT, LIST_ELT, & MYID, INODE, N, IOLDPS, & HF, NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, & IW, LIW, & INTARR, LINTARR, ITLOC, & FILS, FRERE_STEPS, & KEEP, SON_LEVEL2, NIV1, IFLAG, & DAD, PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & SONROWS_PER_ROW, LSONROWS_PER_ROW & , MUMPS_TPS_ARR, L0_OMP_MAPPING & ) USE MUMPS_TPS_M IMPLICIT NONE INTEGER NELT, INODE, N, IOLDPS, HF, NFRONT, NASS1, LIW, NASS, & NUMSTK, NUMORG, IFSON, MYID, IFLAG, & NUMELT INTEGER KEEP(500) INTEGER LIST_ELT(*) INTEGER(8), INTENT(IN) :: PTRAIW(NELT+1) INTEGER STEP(N), PIMASTER(KEEP(28)), PTRIST(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), FRERE_STEPS(KEEP(28)), & PERM(N) INTEGER, TARGET :: IW(LIW) INTEGER, INTENT(IN), TARGET :: IWPOSCB INTEGER, INTENT(IN) :: IWPOS INTEGER(8), INTENT(IN) :: LINTARR INTEGER :: INTARR(LINTARR) LOGICAL, intent(in) :: NIV1 LOGICAL, intent(out) :: SON_LEVEL2 INTEGER, intent(out) :: NFRONT_EFF INTEGER, intent(in) :: DAD (KEEP(28)) INTEGER, intent(in) :: PROCNODE_STEPS(KEEP(28)), SLAVEF TYPE (MUMPS_TPS_T), TARGET, OPTIONAL :: MUMPS_TPS_ARR(:) INTEGER, intent(in), OPTIONAL :: L0_OMP_MAPPING(:) INTEGER, intent(in) :: FRT_PTR(N+1), FRT_ELT(NELT) INTEGER, intent(out) :: Pos_First_NUMORG INTEGER, intent(in) :: LSONROWS_PER_ROW INTEGER, intent(out) :: SONROWS_PER_ROW(LSONROWS_PER_ROW) INTEGER NEWEL, IOLDP2, INEW, INEW1, & IN, NTOTFS, ICT11, NELIM, NPIVS, NSLSON, NCOLS, & ITRANS, J, JT1, ISON, IELL, LSTK, & NROWS, HS, IP1, IP2, IBROT, & I, ILOC, NEWEL_SAVE, NEWEL1_SAVE, & LAST_J_ASS, JMIN, MIN_PERM INTEGER :: K, K1, K2, K3, KK INTEGER(8) :: JJ8, J18, J28 LOGICAL LEVEL1_SON INTEGER INBPROCFILS_SON INTEGER TYPESPLIT INTEGER ELTI, NUMELT_IBROT INCLUDE 'mumps_headers.h' INTEGER :: ITHREAD INTEGER, POINTER :: SON_IWPOSCB INTEGER, POINTER, DIMENSION(:) :: SON_IW INTEGER, POINTER, DIMENSION(:) :: PTTRI, PTLAST INTEGER :: LREQ, allocok INTEGER, ALLOCATABLE, TARGET :: TMP_ALLOC_ARRAY(:) INTEGER MUMPS_TYPESPLIT, MUMPS_TYPENODE EXTERNAL MUMPS_TYPESPLIT, MUMPS_TYPENODE IW(IOLDPS+XXNBPR) = 0 Pos_First_NUMORG = 1 TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) SON_LEVEL2 = .FALSE. IOLDP2 = IOLDPS + HF - 1 ICT11 = IOLDP2 + NFRONT NFRONT_EFF = NASS1 NTOTFS = 0 IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) ) THEN K2 = PIMASTER(STEP(IFSON)) LSTK = IW(K2 +KEEP(IXSZ)) NELIM = IW(K2 + 1+KEEP(IXSZ)) NPIVS = IW(K2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = IW(K2 + 5+KEEP(IXSZ)) IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. LEVEL1_SON = NSLSON.EQ.0 NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF (NIV1) THEN write(6,*) MYID, ':', & ' Internal error 2 in MUMPS_ELT_BUILD_SORT ', & ' interior split node of type 1 ' CALL MUMPS_ABORT() ENDIF I= MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFSON)),KEEP(199)) J= MUMPS_TYPESPLIT(PROCNODE_STEPS(STEP(IFSON)), & KEEP(199)) IF (LEVEL1_SON.or.J.LT.4) THEN write(6,*) MYID, ':', & ' Internal error 3 in MUMPS_ELT_BUILD_SORT ', & ' son', IFSON, & ' of interior split node', INODE, ' of type 1 ', & ' NSLSON =', NSLSON, ' TYPE_SON=', I, 'TYPESPLIT_SON=', J CALL MUMPS_ABORT() ENDIF SON_IW => IW SON_IWPOSCB => IWPOSCB IF (KEEP(400) .GT. 0 ) THEN IF (present( L0_OMP_MAPPING )) THEN ITHREAD=L0_OMP_MAPPING(STEP(IFSON)) IF (ITHREAD .GT. 0) THEN SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW SON_IWPOSCB => MUMPS_TPS_ARR(ITHREAD)%IWPOSCB ENDIF ENDIF ENDIF IF (K2 .GT. SON_IWPOSCB) THEN INBPROCFILS_SON = K2 + XXNBPR ELSE INBPROCFILS_SON = PTRIST(STEP(IFSON))+XXNBPR ENDIF IW(IOLDPS+XXNBPR)=NSLSON SON_IW(INBPROCFILS_SON) = NSLSON SONROWS_PER_ROW(1:NFRONT-NASS1) = 1 IF ( K2.GT. IWPOSCB ) THEN NROWS = IW(K2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) K1 = K2 + HS + NROWS + NPIVS K2 = K1 + LSTK - 1 K3 = K1 + NELIM - 1 IF (NELIM.GT.0) THEN DO KK=K1,K3 NTOTFS = NTOTFS + 1 JT1 = IW(KK) IW(ICT11 + NTOTFS) = JT1 IW(KK) = NTOTFS IW(IOLDP2 + NTOTFS) = IW(KK - ITRANS) ENDDO ENDIF DO KK =K3+1, K2 NTOTFS = NTOTFS + 1 JT1 = IW(KK) ITLOC(JT1) = NTOTFS IW(KK) = NTOTFS IW(ICT11 + NTOTFS) = JT1 IW(IOLDP2 + NTOTFS) = JT1 ENDDO NFRONT_EFF = NTOTFS DO IELL=1,NUMELT ELTI = LIST_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1 DO JJ8=J18,J28 J = INTARR(JJ8) INTARR(JJ8) = ITLOC(J) ENDDO ENDDO Pos_First_NUMORG = ITLOC(INODE) K1 = IOLDPS+HF DO KK=K1+NELIM,K1+NFRONT_EFF-1 ITLOC(IW(KK)) = 0 ENDDO RETURN ENDIF LREQ= 2*NUMSTK IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN ALLOCATE(TMP_ALLOC_ARRAY(LREQ), stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 GOTO 800 ENDIF PTTRI => TMP_ALLOC_ARRAY(1:NUMSTK) PTLAST => TMP_ALLOC_ARRAY(NUMSTK+1:LREQ) ELSE PTTRI => IW(IWPOS:IWPOS+NUMSTK-1) PTLAST => IW(IWPOS+NUMSTK:IWPOS+LREQ) ENDIF IF (.NOT. NIV1) SONROWS_PER_ROW(1:NFRONT-NASS1) = 0 IN = INODE INEW = IOLDPS + HF INEW1 = 1 DO WHILE (IN.GT.0) ITLOC(IN) = INEW1 IW(INEW) = IN IW(INEW+NFRONT) = IN INEW1 = INEW1 + 1 INEW = INEW + 1 IN = FILS(IN) END DO NTOTFS = NUMORG IF (NUMSTK .NE. 0) THEN ISON = IFSON DO IELL = 1, NUMSTK K2 = PIMASTER(STEP(ISON)) SON_IW => IW SON_IWPOSCB => IWPOSCB IF ( KEEP(400) .GT. 0 ) THEN IF (present( L0_OMP_MAPPING )) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .GT. 0) THEN SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW SON_IWPOSCB => MUMPS_TPS_ARR(ITHREAD)%IWPOSCB ENDIF ENDIF ENDIF LSTK = SON_IW(K2 +KEEP(IXSZ)) NELIM = SON_IW(K2 + 1+KEEP(IXSZ)) NPIVS = SON_IW(K2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = SON_IW(K2 + 5+KEEP(IXSZ)) IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. LEVEL1_SON = NSLSON.EQ.0 NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF (K2 .GT. SON_IWPOSCB) THEN INBPROCFILS_SON = K2+XXNBPR ELSE INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR ENDIF IF (NIV1) THEN SON_IW(INBPROCFILS_SON) = NSLSON IW(IOLDPS+XXNBPR) = IW(IOLDPS+XXNBPR) + NSLSON ELSE IF (LEVEL1_SON) THEN SON_IW(INBPROCFILS_SON) = 1 ELSE SON_IW(INBPROCFILS_SON) = NSLSON ENDIF IW(IOLDPS+XXNBPR) = IW(IOLDPS+XXNBPR) + & SON_IW(INBPROCFILS_SON) ENDIF IF (K2.GT.SON_IWPOSCB) THEN NROWS = SON_IW(K2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) K1 = K2 + HS + NROWS + NPIVS K2 = K1 + LSTK - 1 - KEEP(253) K3 = K1 + NELIM - 1 IF (NELIM .NE. 0) THEN DO KK = K1, K3 NTOTFS = NTOTFS + 1 JT1 = SON_IW(KK) IW(ICT11 + NTOTFS) = JT1 ITLOC(JT1) = NTOTFS SON_IW(KK) = NTOTFS IW(IOLDP2 + NTOTFS) = SON_IW(KK - ITRANS) ENDDO ENDIF PTTRI(IELL) = K2+1 PTLAST(IELL) = K2 K1 = K3 + 1 IF (NASS1 .NE. NFRONT - KEEP(253)) THEN DO KK = K1, K2 J = SON_IW(KK) IF (ITLOC(J) .EQ. 0) THEN PTTRI(IELL) = KK EXIT ENDIF ENDDO ELSE DO KK = K1, K2 SON_IW(KK) = ITLOC(SON_IW(KK)) ENDDO DO KK=K2+1, K2+KEEP(253) SON_IW(KK)=NFRONT-KEEP(253)+KK-K2 ENDDO ENDIF ISON = FRERE_STEPS(STEP(ISON)) ENDDO ENDIF IF (NFRONT-KEEP(253).EQ.NASS1) GOTO 500 MIN_PERM = N + 1 IF (KEEP(400) .GT. 0) THEN ISON = IFSON ENDIF JMIN = -1 DO IELL = 1, NUMSTK SON_IW => IW IF ( KEEP(400) .GT. 0 ) THEN IF (present( MUMPS_TPS_ARR )) THEN ITHREAD = L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .GT. 0) THEN SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW ENDIF ENDIF ENDIF ILOC = PTTRI( IELL ) IF ( ILOC .LE. PTLAST( IELL ) ) THEN IF ( PERM( SON_IW( ILOC ) ) .LT. MIN_PERM ) THEN JMIN = SON_IW( ILOC ) MIN_PERM = PERM( JMIN ) END IF END IF IF (KEEP(400) .GT. 0) THEN ISON = FRERE_STEPS(STEP(ISON)) ENDIF 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 IF (KEEP(400) .GT. 0) THEN ISON = IFSON ENDIF DO IELL = 1, NUMSTK SON_IW => IW IF (KEEP(400) .GT. 0) THEN IF (present( MUMPS_TPS_ARR )) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .GT. 0) THEN SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW ENDIF ENDIF ENDIF IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN IF ( SON_IW( PTTRI( IELL ) ) .eq. LAST_J_ASS ) & PTTRI( IELL ) = PTTRI( IELL ) + 1 ENDIF IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN IF ( PERM(SON_IW( PTTRI( IELL )) ) .LT. MIN_PERM ) THEN JMIN = SON_IW( PTTRI( IELL ) ) MIN_PERM = PERM( JMIN ) END IF END IF IF (KEEP(400).GT.0) THEN ISON = FRERE_STEPS(STEP(ISON)) ENDIF END DO END DO NEWEL_SAVE = NEWEL NEWEL1_SAVE = NFRONT_EFF IF (NEWEL1_SAVE.LT.NFRONT - KEEP(253)) THEN DO IELL = 1,NUMELT ELTI = LIST_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1_8 DO JJ8=J18,J28 J = INTARR( JJ8 ) IF ( ITLOC( J ) .eq. 0 ) THEN NEWEL = NEWEL + 1 NFRONT_EFF = NFRONT_EFF + 1 IW( NEWEL ) = J ITLOC( J ) = NFRONT_EFF END IF ENDDO ENDDO IF ( (TYPESPLIT.EQ.4).AND. & (NFRONT_EFF.LT.NFRONT-KEEP(253)) ) THEN IBROT = INODE DO WHILE & ( & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),KEEP(199)) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),KEEP(199)) & .EQ.6 & ) & ) IBROT = DAD(STEP(IBROT)) NUMELT_IBROT = FRT_PTR(IBROT+1) - FRT_PTR(IBROT) IF (NUMELT_IBROT.EQ.0) CYCLE DO IELL = FRT_PTR(IBROT), FRT_PTR(IBROT+1) ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1 DO JJ8 = J18, J28 J = INTARR( JJ8 ) IF ( ITLOC( J ) .eq. 0 ) THEN NEWEL = NEWEL + 1 NFRONT_EFF = NFRONT_EFF + 1 IW( NEWEL ) = J ITLOC( J ) = NFRONT_EFF END IF ENDDO ENDDO IF (NFRONT_EFF.EQ.NFRONT-KEEP(253)) EXIT ENDDO IF (NFRONT_EFF.NE.NFRONT-KEEP(253) .AND. & .NOT. (KEEP(376).EQ.1 .AND. KEEP(79) .GE.1)) THEN write(6,*) MYID, ': INODE', INODE, ' of type 4 ', & ' not yet fully assembled ', & ' NFRONT_EFF, NFRONT =', NFRONT_EFF, NFRONT CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF ( NEWEL1_SAVE .eq. NFRONT_EFF ) THEN DO KK=NASS1+1, NFRONT_EFF IW( IOLDP2+KK ) = IW( ICT11+KK ) ENDDO ELSE CALL MUMPS_SORT( N, PERM, & IW( NEWEL_SAVE + 1 ), NFRONT_EFF - NEWEL1_SAVE ) CALL MUMPS_SORTED_MERGE( N, NASS1, PERM, ITLOC, & IW( NEWEL_SAVE + 1), NFRONT_EFF - NEWEL1_SAVE, & IW( ICT11 + NASS1 + 1 ), NEWEL1_SAVE - NASS1, & IW( IOLDP2 + NASS1 + 1 ), NFRONT_EFF - NASS1 ) DO KK = NASS1+1, NFRONT_EFF IW(ICT11 + KK) = IW(IOLDP2+KK) ENDDO END IF 500 CONTINUE IF ( KEEP(253).GT.0) THEN IP1 = IOLDPS + HF + NFRONT_EFF IP2 = IOLDPS + HF + NFRONT + NFRONT_EFF DO I= 1, KEEP(253) IW(IP1+I-1) = N+I IW(IP2+I-1) = N+I ITLOC(N+I) = NFRONT_EFF + I ENDDO NFRONT_EFF = NFRONT_EFF + KEEP(253) ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN IP1 = IOLDPS + NFRONT + HF IP2 = IOLDPS + NFRONT_EFF + HF DO I=1, NFRONT_EFF IW(IP2+I-1)=IW(IP1+I-1) ENDDO ELSE IF (NFRONT .LT. NFRONT_EFF) THEN WRITE(*,*) "Internal error in MUMPS_ELT_BUILD_SORT", & NFRONT, NFRONT_EFF IFLAG = -53 GOTO 800 ENDIF IF ( (NUMSTK .NE.0) & .AND. (NFRONT-KEEP(253).GT.NASS1 ) & ) THEN ISON = IFSON DO IELL = 1, NUMSTK K2 = PIMASTER(STEP(ISON)) SON_IW => IW SON_IWPOSCB => IWPOSCB IF (KEEP(400).GT.0) THEN IF (present( MUMPS_TPS_ARR )) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .GT. 0) THEN SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW SON_IWPOSCB => MUMPS_TPS_ARR(ITHREAD)%IWPOSCB ENDIF ENDIF ENDIF LSTK = SON_IW(K2+KEEP(IXSZ)) NELIM = SON_IW(K2 + 1 +KEEP(IXSZ)) NPIVS = SON_IW(K2 + 3 +KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = SON_IW(K2 + 5 +KEEP(IXSZ)) LEVEL1_SON = (NSLSON .EQ. 0) NCOLS = NPIVS + LSTK NROWS = NCOLS IF (K2.GT.SON_IWPOSCB) THEN NROWS = SON_IW(K2 + 2+KEEP(IXSZ)) ENDIF HS = NSLSON + 6 +KEEP(IXSZ) K1 = K2 + HS + NROWS + NPIVS K2 = K1 + LSTK - 1 K3 = K1 + NELIM - 1 K1 = K3 + 1 IF (NFRONT-KEEP(253).GT.NASS1) THEN DO KK = K1, K2 J = SON_IW(KK) SON_IW(KK) = ITLOC(J) IF (NIV1 .AND. NSLSON.EQ.0) THEN ELSE IF (SON_IW(KK) .LE. NASS1 .OR. NIV1) THEN ELSE SONROWS_PER_ROW(SON_IW(KK)-NASS1) = & SONROWS_PER_ROW(SON_IW(KK)-NASS1) + 1 ENDIF ENDIF ENDDO ELSE IF (.not. NIV1) THEN WRITE(*,*) "Internal error 1 in MUMPS_ELT_BUILD_SORT" CALL MUMPS_ABORT() ENDIF IF (.not.LEVEL1_SON) THEN ENDIF ENDIF ISON = FRERE_STEPS(STEP(ISON)) ENDDO ENDIF DO IELL=1,NUMELT ELTI = LIST_ELT(IELL) J18 = PTRAIW(ELTI) J28 = PTRAIW(ELTI+1)-1 DO JJ8=J18,J28 J = INTARR(JJ8) INTARR(JJ8) = ITLOC(J) ENDDO ENDDO K1 = IOLDPS + HF + NUMORG K2 = K1 + NFRONT_EFF - 1 + NASS DO K = K1, K2 I = IW(K) ITLOC(I) = 0 ENDDO 800 CONTINUE IF (allocated(TMP_ALLOC_ARRAY)) DEALLOCATE(TMP_ALLOC_ARRAY) RETURN END SUBROUTINE MUMPS_ELT_BUILD_SORT END MODULE MUMPS_BUILD_SORT_INDEX_ELT_M MUMPS_5.8.1/src/bcast_errors.F0000664000175000017500000000200715042446423016027 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_PROPINFO( ICNTL, INFO, COMM, ID ) INTEGER ICNTL(60), INFO(80), COMM, ID INCLUDE 'mpif.h' #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) :: IN( 2 ), OUT( 2 ) #else INTEGER :: IN( 2 ), OUT( 2 ) #endif INTEGER :: IERR IN( 1 ) = INFO ( 1 ) IN( 2 ) = ID CALL MPI_ALLREDUCE( IN, OUT, 1, MPI_2INTEGER, MPI_MINLOC, & COMM, IERR) IF ( OUT( 1 ) .LT. 0 .and. INFO(1) .GE. 0 ) THEN INFO( 1 ) = -001 INFO( 2 ) = OUT( 2 ) END IF RETURN END SUBROUTINE MUMPS_PROPINFO MUMPS_5.8.1/src/dmumps_config_file.F0000664000175000017500000000103315042446437017173 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_CONFIG_FILE_RETURN() RETURN END SUBROUTINE DMUMPS_CONFIG_FILE_RETURN MUMPS_5.8.1/src/domp_tps_m.F0000664000175000017500000000126215042446437015507 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_TPS_M TYPE DMUMPS_TPS_T DOUBLE PRECISION, DIMENSION(:), POINTER :: A END TYPE DMUMPS_TPS_T END MODULE DMUMPS_TPS_M SUBROUTINE DMUMPS_TPS_M_RETURN() RETURN END SUBROUTINE DMUMPS_TPS_M_RETURN MUMPS_5.8.1/src/sfac_process_maprow.F0000664000175000017500000023067215042446437017416 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE SMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW, & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, & LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_BUF USE MUMPS_LOAD USE SMUMPS_LR_DATA_M USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR USE SMUMPS_FAC_FRONT_AUX_M, ONLY : SMUMPS_GET_SIZE_SCHUR_IN_FRONT #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE #if ! defined(NO_FDM_MAPROW) #endif TYPE (MUMPS_ROOT_STRUC ) :: root TYPE (SMUMPS_ROOT_STRUC ) :: roota INTEGER LBUFR, LBUFR_BYTES INTEGER ICNTL( 60 ), KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER COMP INTEGER NSTK( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM, MYID INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER INODE_PERE, ISON INTEGER :: NFS4FATHER INTEGER NBROWS_ALREADY_SENT INTEGER NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE( * ) INTEGER LMAP INTEGER TROW( LMAP ) DOUBLE PRECISION OPASSW, OPELIW REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER NOSLA, I INTEGER I_POSMYIDIN_PERE INTEGER INDICE_PERE INTEGER PDEST, PDEST_MASTER LOGICAL :: LOCAL_ASSEMBLY_TO_BE_DONE INTEGER NROWS_TO_SEND INTEGER PDEST_MASTER_ISON, IPOS_IN_SLAVE LOGICAL DESCLU, SLAVE_ISON LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG INTEGER LP LOGICAL PACKED_CB LOGICAL IS_ERROR_BROADCASTED, IS_ofType5or6 INTEGER ITYPE_SON, TYPESPLIT INTEGER :: KEEP253_LOC INTEGER :: NVSCHUR, NSLAVES_L, NROW_L, IROW_L, NASS_L, NELIM_L LOGICAL :: CB_IS_LR INTEGER :: IWXXF_HANDLER REAL :: ADummy(1) REAL, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: IACHK, RECSIZE #if ! defined(NO_FDM_MAPROW) INTEGER :: INFO_TMP(2) #endif INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM_LOC IS_ERROR_BROADCASTED = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) ITYPE_SON = MUMPS_TYPENODE( PROCNODE_STEPS(STEP(ISON)), & KEEP(199) ) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 #if ! defined(NO_FDM_MAPROW) #endif ALLOCATE(SLAVES_PERE(0:max(1,NSLAVES_PERE)), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) THEN write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in SMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 endif IF (NSLAVES_PERE.GT.0) &SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) THEN write(LP,*) MYID, & ' : PB allocation NBROW in SMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 670 endif LMAP_LOC = LMAP ALLOCATE(MAP(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) THEN write(LP,*) MYID, ' : PB allocation LMAP in SMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = LMAP GOTO 680 endif MAP( 1 : LMAP ) = TROW( 1 : LMAP ) PDEST_MASTER_ISON = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) SLAVE_ISON = PDEST_MASTER_ISON .NE. MYID IF (SLAVE_ISON) THEN IF ( PTRIST(STEP( ISON )) .EQ. 0 ) THEN CALL SMUMPS_TREAT_DESCBAND( ISON, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END IF #if ! defined(NO_FDM_MAPROW) IF ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) & THEN INFO_TMP=0 CALL MUMPS_FMRD_SAVE_MAPROW( & IW(PTRIST(STEP(ISON))+XXA), & INODE_PERE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER, & SLAVES_PERE(1:NSLAVES_PERE), & MAP, & INFO_TMP) IF (INFO_TMP(1) < 0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF GOTO 670 ELSE GOTO 10 ENDIF #endif DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END DO ENDIF #if ! defined(NO_FDM_MAPROW) 10 CONTINUE #endif IF ( NSLAVES_PERE .EQ. 0 ) THEN NBROW( 0 ) = LMAP_LOC ELSE DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) NBROW( NOSLA ) = NBROW( NOSLA ) + 1 END DO DO I = 1, NSLAVES_PERE NBROW(I)=NBROW(I)+NBROW(I-1) ENDDO ENDIF ALLOCATE(PERM_LOC(LMAP_LOC), stat=allocok) IF (allocok .GT. 0) THEN IF (LP.GT.0) THEN write(LP,*) MYID,': PB allocation PERM_LOC in SMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 670 ENDIF KEEP253_LOC = 0 DO I = LMAP_LOC, 1, -1 INDICE_PERE = MAP( I ) IF (INDICE_PERE > NFRONT_PERE - KEEP(253)) THEN KEEP253_LOC = KEEP253_LOC + 1 ENDIF CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) PERM_LOC( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO IF ((KEEP(114).EQ.1) .AND. (KEEP(50).EQ.2) .AND. & (KEEP(116).GT.0) .AND. ((LMAP_LOC-KEEP253_LOC).GT.0) & ) THEN IF (ITYPE_SON.EQ.1) THEN NELIM_L = IW(PTLUST(STEP(ISON))+1+KEEP(IXSZ)) NASS_L = NELIM_L + & IW(PTLUST(STEP(ISON))+3+KEEP(IXSZ)) IROW_L = PTLUST(STEP(ISON))+6+KEEP(IXSZ)+NASS_L NROW_L = LMAP_LOC ELSE NROW_L = LMAP_LOC NSLAVES_L = IW( PTRIST(STEP( ISON )) + 5 + KEEP(IXSZ) ) IROW_L = PTRIST(STEP(ISON)) + 6 + NSLAVES_L + KEEP(IXSZ) ENDIF CALL SMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NROW_L-KEEP253_LOC, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR ) ELSE NVSCHUR = 0 ENDIF PDEST_MASTER = SLAVES_PERE(0) I_POSMYIDIN_PERE = -99999 LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. DO I = 0, NSLAVES_PERE IF (SLAVES_PERE(I) .EQ. MYID) THEN I_POSMYIDIN_PERE = I LOCAL_ASSEMBLY_TO_BE_DONE = .TRUE. #if ! defined(NO_FDM_DESCBAND) IF (PTRIST(STEP(INODE_PERE)) .EQ. 0 & .AND. MYID .NE. PDEST_MASTER) THEN CALL SMUMPS_TREAT_DESCBAND( INODE_PERE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF #endif ENDIF END DO IF (KEEP(120).NE.0 .AND. LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL SMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, LPTRAR, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 CB_IS_LR = (IW(PTRIST(STEP(ISON))+XXLR).EQ.1 .OR. & IW(PTRIST(STEP(ISON))+XXLR).EQ.3) IWXXF_HANDLER = IW(PTRIST(STEP(ISON))+XXF) DO I = NSLAVES_PERE, 0, -1 PDEST = SLAVES_PERE( I ) IF ( PDEST .NE. MYID ) THEN DESCLU = .FALSE. NBROWS_ALREADY_SENT = 0 IF (CB_IS_LR) THEN NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ENDIF IF (I == NSLAVES_PERE) THEN NROWS_TO_SEND=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_SEND=NBROW(I+1)-NBROW(I) ENDIF PACKED_CB=(IW(PTRIST(STEP(ISON))+XXS).EQ.S_CB1COMP) IERR = -1 DO WHILE (IERR .EQ. -1) IF ( IW ( PTRIST(STEP(ISON) )+KEEP(IXSZ) ) & .GT. N + KEEP(253) ) THEN WRITE(*,*) MYID,': Internal error in Maplig' WRITE(*,*) MYID,': PTRIST(STEP(ISON))/N=', & PTRIST(STEP(ISON)), N WRITE(*,*) MYID,': I, NBROW(I)=',I, NBROW(I) WRITE(*,*) MYID,': NSLAVES_PERE=',NSLAVES_PERE WRITE(*,*) MYID,': ISON, INODE_PERE=',ISON,INODE_PERE WRITE(*,*) MYID,': Son header=', & IW(PTRIST(STEP(ISON)): PTRIST(STEP(ISON))+5+KEEP(IXSZ)) CALL MUMPS_ABORT() END IF IF (NROWS_TO_SEND .EQ. 0 .AND. PDEST.NE.PDEST_MASTER) THEN IERR = 0 CYCLE ENDIF IF (CB_IS_LR) THEN CALL SMUMPS_BUF_SEND_CONTRIB_TYPE2( NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, ISON, & NROWS_TO_SEND, LMAP_LOC, MAP, & min(LMAP_LOC,NBROW(I)), & IW( PTRIST(STEP(ISON))), & ADummy, 1_8, & I, PDEST, PDEST_MASTER, & COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PACKED_CB, & KEEP253_LOC, NVSCHUR, & ITYPE_SON, MYID ) ELSE CALL SMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) CALL SMUMPS_BUF_SEND_CONTRIB_TYPE2( NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, ISON, & NROWS_TO_SEND, LMAP_LOC, MAP, & min(LMAP_LOC,NBROW(I)), & IW( PTRIST(STEP(ISON))), & SON_A(IACHK:IACHK+RECSIZE-1_8), & RECSIZE, & I, PDEST, PDEST_MASTER, & COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PACKED_CB, & KEEP253_LOC, NVSCHUR, & ITYPE_SON, MYID) ENDIF IF ( IERR .EQ. -2 ) THEN IFLAG = -17 IF (LP .GT. 0) THEN WRITE(LP,*) & "FAILURE: SEND BUFFER TOO SMALL IN SMUMPS_MAPLIG" ENDIF IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * IW(PTRIST(STEP(ISON))+KEEP(IXSZ)) & * KEEP( 35 ) GO TO 600 END IF IF ( IERR .EQ. -3 ) THEN IF (LP .GT. 0) THEN WRITE(LP,*) & "FAILURE: RECV BUFFER TOO SMALL IN SMUMPS_MAPLIG" ENDIF IFLAG = -20 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * IW(PTRIST(STEP(ISON))+KEEP(IXSZ)) & * KEEP( 35 ) GOTO 600 ENDIF IF (KEEP(219).NE.0) THEN IF ( IERR .EQ. -4 ) THEN IFLAG = -13 IERROR = NFS4FATHER IF (LP .GT. 0) THEN WRITE(LP, *) & "FAILURE: MAX_ARRAY allocation failed IN SMUMPS_MAPLIG" ENDIF GO TO 600 END IF END IF IF ( IERR .EQ. -1 ) THEN IF (LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL SMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, & LPTRAR, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ELSE BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE,LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED=.TRUE. GOTO 600 ENDIF IF (.NOT. MESSAGE_RECEIVED) THEN CALL MUMPS_USLEEP(1000) ENDIF END IF END IF ENDDO ENDIF END DO IF (LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL SMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, LPTRAR, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF IF (CB_IS_LR) THEN IF (IWXXF_HANDLER.LE.0) CALL MUMPS_ABORT() CALL SMUMPS_BLR_FREE_CB_LRB(IWXXF_HANDLER, & .FALSE., KEEP8, KEEP(34)) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN CALL SMUMPS_BLR_END_FRONT(IWXXF_HANDLER, IFLAG, KEEP8, & KEEP(34)) ENDIF ENDIF IF (KEEP(214) .EQ. 2) THEN CALL SMUMPS_STACK_BAND( N, ISON, & PTRIST, PTRAST, PTLUST, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, & COMM, KEEP,KEEP8, DKEEP, ITYPE_SON ) IF (IFLAG .LT. 0) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF CALL SMUMPS_FREE_BAND( N, ISON, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, & STEP, MYID, KEEP, KEEP8, ITYPE_SON &) 600 CONTINUE DEALLOCATE(PERM_LOC) 670 CONTINUE DEALLOCATE(MAP) 680 CONTINUE DEALLOCATE(NBROW) DEALLOCATE(SLAVES_PERE) 700 CONTINUE IF (IFLAG .LT. 0 .AND. .NOT. IS_ERROR_BROADCASTED) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE SMUMPS_MAPLIG SUBROUTINE SMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW, & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, & LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_BUF USE MUMPS_LOAD USE SMUMPS_LR_TYPE USE MUMPS_LR_STATS USE SMUMPS_FAC_FRONT_AUX_M, ONLY : SMUMPS_GET_SIZE_SCHUR_IN_FRONT USE SMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR & , SMUMPS_DM_FREE_BLOCK IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER ICNTL( 60 ), KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER COMP INTEGER IFLAG, IERROR, COMM, MYID INTEGER LPOOL, LEAF INTEGER INODE_PERE, ISON INTEGER NFS4FATHER REAL, POINTER, DIMENSION(:) :: M_ARRAY LOGICAL :: M_ARRAY_RETRIEVED INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE(NSLAVES_PERE) INTEGER NELIM, LMAP, TROW( LMAP ), NASS DOUBLE PRECISION OPASSW, OPELIW REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPTRAR, NELT INTEGER IW( LIW ) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ) INTEGER NSTK( KEEP(28) ), ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PERM(N) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) 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 NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT INTEGER INDICE_PERE INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER PDEST, PDEST_MASTER, NFRONT LOGICAL SAME_PROC, DESCLU INTEGER(8) :: IACHK, POSROW, ASIZE, RECSIZE REAL, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYNSIZE INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND, & NPIV, NROWS_TO_STACK, II, IROW_SON, & IPOS_IN_SLAVE, DECR, ITYPE_SON INTEGER NBCOLS_EFF LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL PACKED_CB LOGICAL :: CB_IS_LR INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR_COLS, NB_BLR_ROWS, & NB_BLR_SHIFT, PANEL2DECOMPRESS, & CURRENT_PANEL_SIZE, PANEL_BEG_OFFSET, & NROWS_ALREADY_STACKED, NROWS_TO_STACK_LOC INTEGER :: ICOL_BEG, ICOL_END INTEGER :: IROW_BEG, IROW_END INTEGER :: IBLOCK, MAXI_CLUSTER DOUBLE PRECISION :: PROMOTE_COST INTEGER :: NVSCHUR, IROW_L INTEGER(8) :: LA_TEMP REAL :: ADummy(1) REAL, ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: LRB TYPE (LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER :: XXG_STATUS INCLUDE 'mumps_headers.h' REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM_LOC LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 if (NSLAVES_PERE.le.0) then write(6,*) ' error 2 in maplig_fils_niv1 ', NSLAVES_PERE CALL MUMPS_ABORT() endif ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) IF (allocok .GT. 0) THEN IF (LP > 0) & write(LP,*) MYID, & ' : PB allocation NBROW in SMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF ALLOCATE(SLAVES_PERE(0:NSLAVES_PERE), stat =allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in SMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) LMAP_LOC = LMAP ALLOCATE(MAP(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation LMAP in SMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = LMAP_LOC GOTO 700 endif MAP( 1 : LMAP_LOC ) = TROW( 1 : LMAP_LOC ) DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO IF (NSLAVES_PERE == 0) THEN NBROW(0) = LMAP_LOC ELSE DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) NBROW( NOSLA ) = NBROW( NOSLA ) + 1 END DO DO I = 1, NSLAVES_PERE NBROW(I)=NBROW(I)+NBROW(I-1) ENDDO ENDIF ALLOCATE(PERM_LOC(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) THEN write(LP,*) MYID, & ': PB allocation PERM_LOC in SMUMPS_MAPLIG_FILS_NIV1' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 700 endif ISTCHK = PIMASTER(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) DO I = LMAP_LOC, 1, -1 INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) PERM_LOC( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO PDEST_MASTER = MYID IF ( SLAVES_PERE(0) .NE. MYID ) THEN WRITE(*,*) 'Error 1 in MAPLIG_FILS_NIV1:',MYID, SLAVES_PERE CALL MUMPS_ABORT() END IF PDEST = PDEST_MASTER I = 0 ISTCHK = PIMASTER(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) NELIM = IW(ISTCHK+1+KEEP(IXSZ)) NROW = IW(ISTCHK+2+KEEP(IXSZ)) NPIV = IW(ISTCHK+3+KEEP(IXSZ)) NASS = NPIV+NELIM IF (NPIV.LT.0) THEN write(6,*) ' Error 2 in SMUMPS_MAPLIG_FILS_NIV1 ', NPIV CALL MUMPS_ABORT() ENDIF NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) NFRONT = NPIV + NBCOLS PACKED_CB=(IW(PTRIST(STEP(ISON))+XXS) .eq. S_CB1COMP) IF (I == NSLAVES_PERE) THEN NROWS_TO_STACK=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_STACK=NBROW(I+1)-NBROW(I) ENDIF IF ((KEEP(114).EQ.1) .AND. (KEEP(50).EQ.2) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) + NASS CALL SMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR ) ELSE NVSCHUR = 0 ENDIF DECR=1 IW(PTLUST(STEP(INODE_PERE))+XXNBPR) = & IW(PTLUST(STEP(INODE_PERE))+XXNBPR) - DECR IW(PTRIST(STEP(ISON))+XXNBPR) = & IW(PTRIST(STEP(ISON))+XXNBPR) - DECR CB_IS_LR = (IW(ISTCHK+XXLR).EQ.1 .OR. & IW(ISTCHK+XXLR).EQ.3) NROWS_ALREADY_STACKED = 0 IF (CB_IS_LR) THEN 100 CONTINUE IF (NROWS_TO_STACK.GT.0) THEN PANEL_BEG_OFFSET = 0 CALL SMUMPS_BLR_RETRIEVE_CB_LRB( & IW(ISTCHK+XXF), CB_LRB) CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR) NB_BLR_ROWS = size(BEGS_BLR) - 1 CALL SMUMPS_BLR_RETRIEVE_NB_PANELS(IW(ISTCHK+XXF), & NB_BLR_SHIFT) PANEL2DECOMPRESS = -1 DO II=NB_BLR_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR(II+1)-1-NASS.GT. & NROWS_ALREADY_STACKED+NBROW(I)-1) THEN PANEL2DECOMPRESS = II EXIT ENDIF ENDDO IF (PANEL2DECOMPRESS.EQ.-1) THEN write(*,*) 'Internal error: PANEL2DECOMPRESS not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR) - 1 ELSE NB_BLR_COLS = PANEL2DECOMPRESS ENDIF CURRENT_PANEL_SIZE = BEGS_BLR(PANEL2DECOMPRESS+1) & - BEGS_BLR(PANEL2DECOMPRESS) PANEL_BEG_OFFSET = NBROW(I) + NROWS_ALREADY_STACKED & - BEGS_BLR(PANEL2DECOMPRESS) + NASS NROWS_TO_STACK_LOC = & min(NROWS_TO_STACK-NROWS_ALREADY_STACKED, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) MAXI_CLUSTER = 1 DO IBLOCK=1,NB_BLR_COLS-NB_BLR_SHIFT LRB => CB_LRB(PANEL2DECOMPRESS-NB_BLR_SHIFT,IBLOCK) MAXI_CLUSTER = max(MAXI_CLUSTER, LRB%N) ENDDO LA_TEMP = NROWS_TO_STACK_LOC*MAXI_CLUSTER #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(A_TEMP, LRB, II, IBLOCK, ICOL_BEG, ICOL_END, !$OMP& allocok, PROMOTE_COST, IROW_SON, INDICE_PERE, !$OMP& POSROW, NBCOLS_EFF, IROW_BEG, IROW_END, !$OMP& INDICE_PERE_ARRAY_ARG, NOSLA, IPOS_IN_SLAVE) #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 GOTO 550 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP DO SCHEDULE(dynamic,1) #endif DO IBLOCK=1,NB_BLR_COLS-NB_BLR_SHIFT IF (IFLAG.LT.0) CYCLE ICOL_BEG = 1 DO II = 1,IBLOCK-1 LRB => CB_LRB(PANEL2DECOMPRESS-NB_BLR_SHIFT,II) ICOL_BEG = ICOL_BEG + LRB%N ENDDO LRB => CB_LRB(PANEL2DECOMPRESS-NB_BLR_SHIFT,IBLOCK) IF (LRB%ISLR .AND. LRB%K.EQ.0) CYCLE IROW_BEG = PANEL_BEG_OFFSET+1 IROW_END = PANEL_BEG_OFFSET+NROWS_TO_STACK_LOC IF (LRB%ISLR) THEN CALL sgemm('T','T', LRB%N, NROWS_TO_STACK_LOC, LRB%K, & ONE, LRB%R(1,1), LRB%K, LRB%Q(IROW_BEG,1), & LRB%M, ZERO, A_TEMP(1), LRB%N) PROMOTE_COST = 2.0D0*LRB%N*NROWS_TO_STACK_LOC*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE DO II = IROW_BEG, IROW_END A_TEMP( 1+(II-IROW_BEG)*LRB%N : (II-IROW_BEG+1)*LRB%N ) & = LRB%Q(II,1:LRB%N) ENDDO ENDIF CALL SMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON=PERM_LOC(NBROW(I)+II-1) INDICE_PERE = MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF (PACKED_CB) THEN POSROW = IACHK + & int(NELIM+IROW_SON,8)*int(NELIM+IROW_SON-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+IROW_SON-1,8)*int(NBCOLS,8) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = NELIM + IROW_SON ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE ICOL_END = min(ICOL_BEG+LRB%N-1, NBCOLS_EFF) CALL SMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, ICOL_END-ICOL_BEG+1, & INDICE_PERE_ARRAY_ARG, & A_TEMP(1+(II-NROWS_ALREADY_STACKED-1)*LRB%N), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS,ICOL_BEG) ENDDO ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO #endif IF (IFLAG.LT.0) GOTO 550 deallocate(A_TEMP) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) 550 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 NROWS_ALREADY_STACKED = NROWS_ALREADY_STACKED & + NROWS_TO_STACK_LOC IF (NROWS_ALREADY_STACKED.LT.NROWS_TO_STACK) THEN GOTO 100 ENDIF ENDIF ELSE CALL SMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK IROW_SON=PERM_LOC(NBROW(I)+II-1) INDICE_PERE = MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF (PACKED_CB) THEN POSROW = IACHK + & int(NELIM+IROW_SON,8)*int(NELIM+IROW_SON-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+IROW_SON-1,8)*int(NBCOLS,8) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = NELIM + IROW_SON ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE CALL SMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS_EFF,1) ENDDO ENDIF IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2 & .AND. NFS4FATHER .GT. 0) THEN IF (CB_IS_LR) THEN CALL SMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW(ISTCHK+XXF), M_ARRAY) M_ARRAY_RETRIEVED = .TRUE. ELSE IF (PACKED_CB) THEN POSROW = IACHK & + int(NELIM+NBROW(1),8)*int(NELIM+NBROW(1)-1,8)/2_8 ASIZE = int(LMAP_LOC+NELIM,8)*int(NELIM+LMAP_LOC+1,8)/2_8 & - int(NELIM+NBROW(1),8)*int(NELIM+NBROW(1)-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+NBROW(1)-1,8)*int(NBCOLS,8) ASIZE = int(LMAP_LOC-NBROW(1)+1,8) * int(NBCOLS,8) ENDIF CALL SMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP > 0) WRITE(LP,*) MYID, & ": PB allocation MAX_ARRAY during SMUMPS_MAPLIG_FILS_NIV1" IFLAG=-13 IERROR=NFS4FATHER GOTO 700 ENDIF IF ( LMAP_LOC-NBROW(1)+1-KEEP(253)-NVSCHUR.GT. 0 ) THEN CALL SMUMPS_COMPUTE_MAXPERCOL( & SON_A(POSROW),ASIZE,NBCOLS, & LMAP_LOC-NBROW(1)+1-KEEP(253)-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB, & NELIM+NBROW(1)) ELSE CALL SMUMPS_SETMAXTOZERO(BUF_MAX_ARRAY, & NFS4FATHER) ENDIF M_ARRAY => BUF_MAX_ARRAY M_ARRAY_RETRIEVED = .FALSE. ENDIF CALL SMUMPS_ASM_MAX(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & M_ARRAY(1), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB,MYID, KEEP,KEEP8) IF ( M_ARRAY_RETRIEVED ) & CALL SMUMPS_BLR_FREE_M_ARRAY ( IW(ISTCHK+XXF) ) ENDIF ENDIF IF (IW(PTRIST(STEP(ISON))+XXNBPR) .EQ. 0 & ) THEN ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF (SAME_PROC) THEN CALL SMUMPS_RESTORE_INDICES(N, ISON, INODE_PERE, & IWPOSCB, PIMASTER, PTLUST, IW, LIW, STEP, & KEEP,KEEP8) ENDIF ENDIF IF ( IW(PTLUST(STEP(INODE_PERE))+XXNBPR) .EQ. 0 & ) THEN CALL SMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, INODE_PERE+N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 DO I = 0, NSLAVES_PERE PDEST = SLAVES_PERE( I ) IF ( PDEST .NE. MYID ) THEN NBROWS_ALREADY_SENT = 0 IF (CB_IS_LR) THEN NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ENDIF 95 CONTINUE NFRONT = IW(PIMASTER(STEP(ISON))+KEEP(IXSZ)) NELIM = IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) DESCLU = .TRUE. IF (I == NSLAVES_PERE) THEN NROWS_TO_SEND=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_SEND=NBROW(I+1)-NBROW(I) ENDIF IF ( NROWS_TO_SEND .EQ. 0) CYCLE ITYPE_SON = MUMPS_TYPENODE( PROCNODE_STEPS(STEP(ISON)), & KEEP(199) ) IF (CB_IS_LR) THEN CALL SMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NROWS_TO_SEND, LMAP_LOC, & MAP, min(LMAP_LOC,NBROW(I)), & IW(PIMASTER(STEP(ISON))), & ADummy, 1_8, & I, PDEST, PDEST_MASTER, COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP(253), NVSCHUR, & ITYPE_SON, MYID ) ELSE CALL SMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) CALL SMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NROWS_TO_SEND, LMAP_LOC, & MAP, min(LMAP_LOC,NBROW(I)), & IW(PIMASTER(STEP(ISON))), & SON_A(IACHK:IACHK+RECSIZE-1_8), & RECSIZE, & I, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP(253), NVSCHUR, & ITYPE_SON, MYID) ENDIF IF ( IERR .EQ. -2 ) THEN IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING SMUMPS_MAPLIG_FILS_NIV1" IFLAG = -17 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * KEEP( 35 ) GO TO 700 END IF IF ( IERR .EQ. -3 ) THEN IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING SMUMPS_MAPLIG_FILS_NIV1" IFLAG = -20 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * KEEP( 35 ) GO TO 700 ENDIF IF (KEEP(219).NE.0) THEN IF ( IERR .EQ. -4 ) THEN IFLAG = -13 IERROR = BUF_LMAX_ARRAY IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, MAX_ARRAY ALLOC FAILED DURING SMUMPS_MAPLIG_FILS_NIV1" GO TO 700 ENDIF ENDIF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 GO TO 95 END IF END IF END DO ISTCHK = PTRIST(STEP(ISON)) PTRIST(STEP( ISON )) = -77777777 IF ( IW(ISTCHK+KEEP(IXSZ)) .GE. 0 ) THEN WRITE(*,*) 'error 3 in SMUMPS_MAPLIG_FILS_NIV1' CALL MUMPS_ABORT() ENDIF CALL MUMPS_GETI8(DYNSIZE,IW(ISTCHK+XXD)) XXG_STATUS = IW(ISTCHK+XXG) CALL SMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) IF (DYNSIZE .GT. 0_8) THEN CALL SMUMPS_DM_FREE_BLOCK( XXG_STATUS, SON_A, DYNSIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF GOTO 600 700 CONTINUE CALL SMUMPS_BDC_ERROR(MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF (CB_IS_LR) THEN CALL SMUMPS_BLR_FREE_CB_LRB(IW(ISTCHK+XXF), & .FALSE., KEEP8, KEEP(34)) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN CALL SMUMPS_BLR_END_FRONT(IW(ISTCHK+XXF), IFLAG, KEEP8, & KEEP(34)) ENDIF ENDIF IF (allocated(NBROW)) DEALLOCATE(NBROW) IF (allocated(MAP)) DEALLOCATE(MAP) IF (allocated(PERM_LOC)) DEALLOCATE(PERM_LOC) IF (allocated(SLAVES_PERE)) DEALLOCATE(SLAVES_PERE) RETURN END SUBROUTINE SMUMPS_MAPLIG_FILS_NIV1 SUBROUTINE SMUMPS_LOCAL_ASSEMBLY_TYPE2(I, PDEST, MYID, & PDEST_MASTER, ISON, IFATH, NSLAVES_PERE, NASS_PERE, & NFRONT_PERE, NFS4FATHER, LMAP_LOC, MAP, & NBROW, PERM, IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, & IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, & LPTRAR, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & SON_NIV, LRGROUPS) USE SMUMPS_BUF, ONLY: SMUMPS_BUF_MAX_ARRAY_MINSIZE, & BUF_MAX_ARRAY USE SMUMPS_LR_TYPE USE MUMPS_LR_STATS USE SMUMPS_LR_DATA_M USE MUMPS_LOAD, ONLY : MUMPS_LOAD_POOL_UPD_NEW_POOL USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR & , SMUMPS_DM_SET_PTR, SMUMPS_DM_FREE_BLOCK IMPLICIT NONE INTEGER ICNTL(60) INTEGER, intent(in) :: I, PDEST, MYID, PDEST_MASTER, IFATH, ISON INTEGER, intent(in) :: N, SLAVEF INTEGER, intent(in) :: NSLAVES_PERE, NASS_PERE, NFRONT_PERE INTEGER, intent(in) :: NFS4FATHER INTEGER, intent(in) :: KEEP(500), STEP(N) INTEGER, intent(in) :: LMAP_LOC INTEGER, intent(in) :: NBROW(0:NSLAVES_PERE) INTEGER, intent(in) :: MAP(LMAP_LOC), PERM(LMAP_LOC) INTEGER, intent(inout) :: IFLAG, IERROR INTEGER(8), intent(inout) :: KEEP8(150) INTEGER, intent(in) :: LIW, NELT, LPTRAR INTEGER(8), intent(in) :: LA INTEGER(8), intent(inout) :: IPTRLU, LRLU, LRLUS INTEGER, intent(inout) :: IWPOSCB INTEGER, intent(inout) :: IW(LIW) REAL, intent(inout) :: A( LA ) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER :: PTRIST(KEEP(28)), PIMASTER(KEEP(28)), ND(KEEP(28)) INTEGER :: PTLUST(KEEP(28)) INTEGER, intent(inout) :: ITLOC(N) INTEGER, intent(in) :: FRTPTR( N+1 ), FRTELT( NELT ) DOUBLE PRECISION, intent(inout) :: OPASSW, OPELIW REAL :: RHS_MUMPS(KEEP8(85)) INTEGER, intent(in) :: KEEP253_LOC, NVSCHUR INTEGER, intent(in) :: FILS(N), DAD( KEEP(28) ) INTEGER(8), intent(in) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER, intent(in) :: PROCNODE_STEPS( KEEP(28) ), COMM_LOAD INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPOOL INTEGER IPOOL( LPOOL ) LOGICAL, intent(in) :: IS_ofType5or6 INTEGER, intent(in) :: SON_NIV INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INTEGER :: XXG_STATUS INTEGER :: ISTCHK, ISTCHK_LOC, NBCOLS, & NROW, NPIV, NSLSON, & NFRONT, LDA_SON, NROWS_TO_STACK, II, INDICE_PERE, & NOSLA, COLLIST, IPOS_IN_SLAVE, IROW_SON, ITMP, & NBCOLS_EFF, DECR, NELIM INTEGER :: NB_POSTPONED LOGICAL :: PACKED_CB, SAME_PROC INTEGER(8) :: SIZFR, POSROW, SHIFTCB_SON INTEGER(8) :: IACHK INTEGER :: SON_XXS REAL, DIMENSION(:), POINTER :: SON_A REAL, DIMENSION(:), POINTER :: SON_A_MASTER INTEGER(8) :: DYN_SIZE INTEGER :: IERR, LP INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER :: INBPROCFILS_SON LOGICAL :: CB_IS_LR REAL, POINTER, DIMENSION(:) :: M_ARRAY LOGICAL :: M_ARRAY_RETRIEVED INTEGER(8) :: POSELT INTEGER :: IOLDPS, PARPIV_T1 LOGICAL :: LR_ACTIVATED INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL, & BEGS_BLR_STA INTEGER :: NB_BLR_COLS, NB_BLR_ROWS, & NB_COL_SHIFT, PANEL2DECOMPRESS, & CURRENT_PANEL_SIZE, PANEL_BEG_OFFSET, & allocok, NROWS_ALREADY_STACKED, NROWS_TO_STACK_LOC, & NB_ROW_SHIFT, NASS_SHIFT, NCOL_SHIFT, NROW_SHIFT INTEGER :: ICOL_BEG, ICOL_END INTEGER :: IROW_BEG, IROW_END INTEGER :: IBLOCK, MAXI_CLUSTER DOUBLE PRECISION :: PROMOTE_COST INTEGER(8) :: LA_TEMP REAL, ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: LRB TYPE (LRB_TYPE), POINTER :: CB_LRB(:,:) REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 IF (I == NSLAVES_PERE) THEN NROWS_TO_STACK = LMAP_LOC - NBROW(I) + 1 ELSE NROWS_TO_STACK = NBROW(I+1) - NBROW(I) ENDIF DECR = 1 IF ( MYID .EQ. PDEST_MASTER ) THEN IW(PTLUST(STEP(IFATH))+XXNBPR) = & IW(PTLUST(STEP(IFATH))+XXNBPR) - DECR IF ( PDEST .EQ. PDEST_MASTER .AND. DECR .NE. 0) THEN IW(PIMASTER(STEP(ISON))+XXNBPR) = & IW(PIMASTER(STEP(ISON))+XXNBPR) - DECR ENDIF ENDIF ISTCHK = PTRIST(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) NROW = IW(ISTCHK+2+KEEP(IXSZ)) NPIV = IW(ISTCHK+3+KEEP(IXSZ)) NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) NFRONT = NPIV + NBCOLS SON_XXS = IW(ISTCHK+XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) CALL SMUMPS_DM_SET_DYNPTR( & SON_XXS, & A, LA, & PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR) CB_IS_LR = (IW(ISTCHK+XXLR).EQ.1 .OR. & IW(ISTCHK+XXLR).EQ.3) IF (CB_IS_LR.AND.IS_ofType5or6) THEN write(*,*) 'Compress CB + Type5or6 fronts not coded yet!!' CALL MUMPS_ABORT() ENDIF NELIM = -9999 IF (CB_IS_LR.AND.(SON_NIV.EQ.1).AND. & KEEP(50).NE.0) THEN ISTCHK_LOC = PTLUST(STEP(ISON)) NELIM = IW(ISTCHK_LOC+1+KEEP(IXSZ)) NPIV = IW(ISTCHK_LOC+3+KEEP(IXSZ)) NFRONT = IW(ISTCHK_LOC+2+KEEP(IXSZ)) NROW = NFRONT - NPIV NFRONT = NBCOLS NPIV = 0 ENDIF IF (CB_IS_LR) THEN LDA_SON = NBCOLS SHIFTCB_SON = -9999 ELSE IF (SON_XXS.EQ.S_NOLCBCONTIG ) THEN LDA_SON = NBCOLS SHIFTCB_SON = int(NPIV,8)*int(NROW,8) ELSE IF (IW(ISTCHK+XXS).EQ.S_NOLCLEANED) THEN LDA_SON = NBCOLS SHIFTCB_SON = 0_8 ELSE LDA_SON = NFRONT SHIFTCB_SON = int(NPIV,8) ENDIF ENDIF IF (PDEST .NE. PDEST_MASTER) THEN IF ( KEEP(55) .eq. 0 ) THEN CALL SMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, IFATH, IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ELSE CALL SMUMPS_ELT_ASM_S_2_S_INIT(NELT, FRTPTR, FRTELT, & N, IFATH, IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP, KEEP8, MYID, LRGROUPS ) ENDIF ENDIF NROWS_ALREADY_STACKED = 0 100 CONTINUE NROWS_TO_STACK_LOC = NROWS_TO_STACK PANEL_BEG_OFFSET = 0 IF (CB_IS_LR) THEN IF (NROWS_TO_STACK.GT.0) THEN CALL SMUMPS_BLR_RETRIEVE_CB_LRB( & IW(ISTCHK+XXF), CB_LRB) IF (SON_NIV.EQ.1) THEN CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR_ROW) CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_DYN( & IW(ISTCHK+XXF), BEGS_BLR_COL) NB_BLR_ROWS = size(BEGS_BLR_ROW) - 1 CALL SMUMPS_BLR_RETRIEVE_NB_PANELS(IW(ISTCHK+XXF), & NB_COL_SHIFT) NB_ROW_SHIFT = NB_COL_SHIFT NASS_SHIFT = BEGS_BLR_ROW(NB_ROW_SHIFT+1)-1 ELSE CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR_STA) NB_BLR_ROWS = size(BEGS_BLR_STA) - 2 BEGS_BLR_ROW => BEGS_BLR_STA(2:NB_BLR_ROWS+2) CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_C( & IW(ISTCHK+XXF), BEGS_BLR_COL, & NB_COL_SHIFT) NB_ROW_SHIFT = 0 NASS_SHIFT = 0 ENDIF PANEL2DECOMPRESS = -1 DO II=NB_ROW_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR_ROW(II+1)-1-NASS_SHIFT.GT. & NROWS_ALREADY_STACKED+NBROW(I)-1) THEN PANEL2DECOMPRESS = II EXIT ENDIF ENDDO IF (PANEL2DECOMPRESS.EQ.-1) THEN write(*,*) 'Internal error: PANEL2DECOMPRESS not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR_COL) - 1 ELSEIF (SON_NIV.EQ.1) THEN NB_BLR_COLS = PANEL2DECOMPRESS ELSE NB_BLR_COLS = -1 NCOL_SHIFT = NPIV NROW_SHIFT = NBCOLS-NROW DO II=NB_COL_SHIFT+1,size(BEGS_BLR_COL)-1 IF (BEGS_BLR_COL(II+1)-NCOL_SHIFT.GT. & BEGS_BLR_ROW(PANEL2DECOMPRESS+1)-1+NROW_SHIFT) THEN NB_BLR_COLS = II EXIT ENDIF ENDDO IF (NB_BLR_COLS.EQ.-1) THEN write(*,*) 'Internal error: NB_BLR_COLS not found' CALL MUMPS_ABORT() ENDIF ENDIF CURRENT_PANEL_SIZE = BEGS_BLR_ROW(PANEL2DECOMPRESS+1) & - BEGS_BLR_ROW(PANEL2DECOMPRESS) PANEL_BEG_OFFSET = NBROW(I) + NROWS_ALREADY_STACKED & - BEGS_BLR_ROW(PANEL2DECOMPRESS) + NASS_SHIFT NROWS_TO_STACK_LOC = & min(NROWS_TO_STACK-NROWS_ALREADY_STACKED, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) MAXI_CLUSTER = 1 DO IBLOCK=1,NB_BLR_COLS-NB_COL_SHIFT LRB => CB_LRB(PANEL2DECOMPRESS-NB_ROW_SHIFT,IBLOCK) MAXI_CLUSTER = max(MAXI_CLUSTER, LRB%N) ENDDO LA_TEMP = NROWS_TO_STACK_LOC*MAXI_CLUSTER #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(A_TEMP, LRB, II, IBLOCK, ICOL_BEG, ICOL_END, !$OMP& allocok, PROMOTE_COST, IROW_BEG, IROW_END, IROW_SON, !$OMP& INDICE_PERE, ITMP, POSROW, NBCOLS_EFF, ISTCHK, !$OMP& ISTCHK_LOC, COLLIST, NOSLA, IPOS_IN_SLAVE, !$OMP& INDICE_PERE_ARRAY_ARG) #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 GOTO 550 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP DO SCHEDULE(dynamic,1) #endif DO IBLOCK=1,NB_BLR_COLS-NB_COL_SHIFT IF (IFLAG.LT.0) CYCLE ICOL_BEG = 1 DO II = 1,IBLOCK-1 LRB => CB_LRB(PANEL2DECOMPRESS-NB_ROW_SHIFT,II) ICOL_BEG = ICOL_BEG + LRB%N ENDDO LRB => CB_LRB(PANEL2DECOMPRESS-NB_ROW_SHIFT,IBLOCK) IF (LRB%ISLR .AND. LRB%K.EQ.0) CYCLE IROW_BEG = PANEL_BEG_OFFSET+1 IROW_END = PANEL_BEG_OFFSET+NROWS_TO_STACK_LOC IF (LRB%ISLR) THEN CALL sgemm('T','T', LRB%N, NROWS_TO_STACK_LOC, LRB%K, & ONE, LRB%R(1,1), LRB%K, LRB%Q(IROW_BEG,1), & LRB%M, ZERO, A_TEMP(1), LRB%N) PROMOTE_COST = 2.0D0*LRB%N*NROWS_TO_STACK_LOC*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE DO II = IROW_BEG, IROW_END A_TEMP( 1+(II-IROW_BEG)*LRB%N : & (II-IROW_BEG+1)*LRB%N ) = LRB%Q(II,1:LRB%N) ENDDO ENDIF DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON = PERM(NBROW(I)+II-1) INDICE_PERE=MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IFATH, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF ( PACKED_CB ) THEN ITMP = IROW_SON + NBCOLS - NROW POSROW = IACHK & + int(ITMP,8) * int(ITMP-1,8) / 2_8 & - int(NBCOLS-NROW,8) * int(NBCOLS-NROW+1,8)/2_8 ELSE POSROW = IACHK + SHIFTCB_SON & +int(IROW_SON-1,8)*int(LDA_SON,8) ENDIF IF (PDEST .EQ. 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 ICOL_END = min(ICOL_BEG+LRB%N-1, NBCOLS_EFF) CALL SMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, ICOL_END - ICOL_BEG + 1, & INDICE_PERE_ARRAY_ARG, & A_TEMP(1+(II-NROWS_ALREADY_STACKED-1)*LRB%N), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, NBCOLS, ICOL_BEG ) ELSE ISTCHK = PTRIST(STEP(ISON)) COLLIST = ISTCHK + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) + NROW + NPIV IF ((SON_NIV.EQ.1).AND. KEEP(50).NE.0) THEN ISTCHK_LOC = PTLUST(STEP(ISON)) COLLIST = ISTCHK_LOC + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) & + IW(ISTCHK_LOC+2+KEEP(IXSZ)) & + IW(ISTCHK_LOC+3+KEEP(IXSZ)) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = IROW_SON + NBCOLS - NROW IF (SON_NIV.EQ.1) THEN NBCOLS_EFF = IROW_SON + NBCOLS - (NROW-NELIM) ENDIF ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE ICOL_END = min(ICOL_BEG+LRB%N-1, NBCOLS_EFF) CALL SMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, ICOL_END-ICOL_BEG+1, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST + ICOL_BEG - 1 ), & A_TEMP(1+(II-NROWS_ALREADY_STACKED-1)*LRB%N), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, NBCOLS) ENDIF ENDDO ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO #endif IF (IFLAG.LT.0) GOTO 550 deallocate(A_TEMP) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) 550 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) RETURN IF (PDEST .NE. PDEST_MASTER) THEN IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - NROWS_TO_STACK_LOC ENDIF NROWS_ALREADY_STACKED = NROWS_ALREADY_STACKED & + NROWS_TO_STACK_LOC IF (NROWS_ALREADY_STACKED.LT.NROWS_TO_STACK) THEN GOTO 100 ENDIF ENDIF ELSE DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON = PERM(NBROW(I)+II-1) INDICE_PERE=MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IFATH, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF ( PACKED_CB ) THEN ITMP = IROW_SON + NBCOLS - NROW POSROW = IACHK & + int(ITMP,8) * int(ITMP-1,8) / 2_8 & - int(NBCOLS-NROW,8) * int(NBCOLS-NROW+1,8)/2_8 ELSE POSROW = IACHK + SHIFTCB_SON & +int(IROW_SON-1,8)*int(LDA_SON,8) ENDIF IF (PDEST == PDEST_MASTER) THEN IF (KEEP(50).NE.0) THEN NBCOLS_EFF = IROW_SON + NBCOLS - NROW ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE IF ((IS_ofType5or6).AND.(KEEP(50).EQ.0)) THEN CALL SMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON, 1 & ) EXIT ELSE IF ( (KEEP(50).NE.0) .AND. & (.NOT.PACKED_CB).AND.(IS_ofType5or6) ) THEN CALL SMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, & NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON, 1 & ) EXIT ELSE CALL SMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON, 1 ) 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.PACKED_CB) ) & ) & ) THEN CALL SMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), SON_A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - NROWS_TO_STACK EXIT ELSE CALL SMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), SON_A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - 1 ENDIF ENDIF ENDDO ENDIF IF (PDEST.EQ.PDEST_MASTER) THEN IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2 & .AND. NFS4FATHER .GT. 0) THEN IF (CB_IS_LR) THEN CALL SMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW(ISTCHK+XXF), M_ARRAY) M_ARRAY_RETRIEVED = .TRUE. ELSE IF (PACKED_CB) THEN WRITE(*,*) "Error 1 in PARPIV/SMUMPS_MAPLIG" CALL MUMPS_ABORT() ELSE POSROW = IACHK + SHIFTCB_SON+ & int(NBROW(1)-1,8)*int(LDA_SON,8) ENDIF CALL SMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP .GT. 0) THEN WRITE(LP, *) "MAX_ARRAY allocation failed" ENDIF IFLAG=-13 IERROR=NFS4FATHER RETURN ENDIF ITMP=-9999 IF (LMAP_LOC-NBROW(1)+1-KEEP253_LOC-NVSCHUR.NE.0) & THEN CALL SMUMPS_COMPUTE_MAXPERCOL( & SON_A(POSROW), & SIZFR-SHIFTCB_SON-int(NBROW(1)-1,8)*int(LDA_SON,8), & LDA_SON, & LMAP_LOC-NBROW(1)+1-KEEP253_LOC-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB,ITMP) ELSE CALL SMUMPS_SETMAXTOZERO( & BUF_MAX_ARRAY, NFS4FATHER) ENDIF M_ARRAY => BUF_MAX_ARRAY(1:size(BUF_MAX_ARRAY)) M_ARRAY_RETRIEVED = .FALSE. ENDIF CALL SMUMPS_ASM_MAX(N, IFATH, IW, LIW, & A, LA, ISON, NFS4FATHER, & M_ARRAY(1), PTLUST, PTRAST, & STEP, PIMASTER, & OPASSW,IWPOSCB,MYID, KEEP,KEEP8) IF ( M_ARRAY_RETRIEVED ) & CALL SMUMPS_BLR_FREE_M_ARRAY ( IW(ISTCHK+XXF) ) ENDIF ENDIF ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF ( SAME_PROC ) THEN INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR WRITE(*,*) & "Internal error 0 in SMUMPS_LOCAL_ASSEMBLY_TYPE2", & INBPROCFILS_SON, PIMASTER(STEP(ISON)) CALL MUMPS_ABORT() ELSE INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ENDIF IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN IF (SAME_PROC) THEN CALL SMUMPS_RESTORE_INDICES(N, ISON, IFATH, & IWPOSCB, PIMASTER, PTLUST, IW, LIW, STEP, & KEEP,KEEP8) ENDIF IF (SAME_PROC) THEN ISTCHK_LOC = PTRIST(STEP(ISON)) PTRIST(STEP( ISON) ) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_LOC+XXD)) XXG_STATUS = IW(ISTCHK_LOC+XXG) IF (DYN_SIZE .GT. 0_8) THEN CALL SMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), & DYN_SIZE, SON_A_MASTER ) ENDIF CALL SMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., MYID, N, & ISTCHK_LOC, & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) IF (DYN_SIZE .GT. 0_8) THEN CALL SMUMPS_DM_FREE_BLOCK( XXG_STATUS, SON_A_MASTER, & DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF IF ( IW(PTLUST(STEP(IFATH))+XXNBPR) .EQ. 0 & ) THEN IOLDPS = PTLUST(STEP(IFATH)) IF (NSLAVES_PERE.EQ.0) THEN POSELT = PTRAST(STEP(IFATH)) PARPIV_T1 = -999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) NB_POSTPONED = max(NFRONT - ND(STEP(IFATH)),0) CALL SMUMPS_PARPIVT1_SET_NVSCHUR_MAX ( & N, IFATH, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT_PERE, NASS_PERE, LR_ACTIVATED, PARPIV_T1, & NB_POSTPONED ) ENDIF CALL SMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, IFATH+N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF ELSE CALL SMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, IFATH, IW, LIW, & NBROW(I), STEP, PTRIST, ITLOC, RHS_MUMPS, & KEEP,KEEP8) END IF RETURN END SUBROUTINE SMUMPS_LOCAL_ASSEMBLY_TYPE2 MUMPS_5.8.1/src/zfac_mem_compress_cb.F0000664000175000017500000005050415042446441017504 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SIZEFREEINREC(IW,LREC,SIZE_FREE,XSIZE) IMPLICIT NONE INTEGER, intent(in) :: LREC, XSIZE INTEGER, intent(in) :: IW(LREC) INTEGER(8), intent(out):: SIZE_FREE INTEGER(8) :: SIZE_STA, SIZE_DYN INCLUDE 'mumps_headers.h' CALL MUMPS_GETI8( SIZE_STA,IW(1+XXR) ) CALL MUMPS_GETI8( SIZE_DYN,IW(1+XXD) ) IF ( SIZE_DYN .GT. 0) THEN SIZE_FREE = SIZE_STA ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG .OR. & IW(1+XXS).EQ.S_NOLCBNOCONTIG) THEN SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE+3),8) ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG38 .OR. & IW(1+XXS).EQ.S_NOLCBNOCONTIG38) THEN SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE)+ & IW(1+XSIZE + 3) - & ( IW(1+XSIZE + 4) & - IW(1+XSIZE + 3) ), 8) ELSE IF (IW(1+XXS).EQ.S_NOLNOCB) THEN SIZE_FREE = SIZE_STA ELSE SIZE_FREE=0_8 ENDIF RETURN END SUBROUTINE ZMUMPS_SIZEFREEINREC SUBROUTINE ZMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, IW, XSIZE, KEEP216) IMPLICIT NONE LOGICAL, INTENT(out) :: RECORD_CAN_BE_COMPRESSED INTEGER, INTENT(in) :: XSIZE, KEEP216 INTEGER, INTENT(in) :: IW(XSIZE) INCLUDE 'mumps_headers.h' INTEGER(8) :: SIZE_DYN, SIZE_STA CALL MUMPS_GETI8( SIZE_STA, IW(1+XXR)) CALL MUMPS_GETI8( SIZE_DYN, IW(1+XXD)) IF (IW(1+XXS) .EQ. S_FREE) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE IF ( SIZE_DYN .GT. 0_8 .AND. SIZE_STA .GT. 0_8) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE IF ( IW(1+XXS) .EQ. S_NOLNOCB) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE RECORD_CAN_BE_COMPRESSED = & ( IW(1+XXS) .EQ. S_NOLCBNOCONTIG .OR. & IW(1+XXS) .EQ. S_NOLCBCONTIG .OR. & IW(1+XXS) .EQ. S_NOLCBNOCONTIG38 .OR. & IW(1+XXS) .EQ. S_NOLCBCONTIG38 ) & .AND. KEEP216.NE.3 ENDIF RETURN END SUBROUTINE ZMUMPS_CAN_RECORD_BE_COMPRESSED SUBROUTINE ZMUMPS_MOVETONEXTRECORD &(IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER(8) :: RCURRENT INTEGER LIW,IXXP,ICURRENT,NEXT,ISIZE2SHIFT INTEGER IW(LIW) INTEGER(8) :: RSIZE ICURRENT=NEXT CALL MUMPS_GETI8( RSIZE, IW(ICURRENT + XXR) ) RCURRENT = RCURRENT - RSIZE NEXT=IW(ICURRENT+XXP) IW(IXXP)=ICURRENT+ISIZE2SHIFT IXXP=ICURRENT+XXP RETURN END SUBROUTINE ZMUMPS_MOVETONEXTRECORD SUBROUTINE ZMUMPS_ISHIFT(IW,LIW,BEG2SHIFT,END2SHIFT,ISIZE2SHIFT) IMPLICIT NONE INTEGER LIW, BEG2SHIFT, END2SHIFT, ISIZE2SHIFT INTEGER IW(LIW) INTEGER I IF (ISIZE2SHIFT.GT.0) THEN DO I=END2SHIFT,BEG2SHIFT,-1 IW(I+ISIZE2SHIFT)=IW(I) ENDDO ELSE IF (ISIZE2SHIFT.LT.0) THEN DO I=BEG2SHIFT,END2SHIFT IW(I+ISIZE2SHIFT)=IW(I) ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_ISHIFT SUBROUTINE ZMUMPS_RSHIFT(A, LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT) IMPLICIT NONE INTEGER(8) :: LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT COMPLEX(kind=8) A(LA) INTEGER(8) :: I IF (RSIZE2SHIFT.GT.0_8) THEN DO I=END2SHIFT,BEG2SHIFT,-1_8 A(I+RSIZE2SHIFT)=A(I) ENDDO ELSE IF (RSIZE2SHIFT.LT.0_8) THEN DO I=BEG2SHIFT,END2SHIFT A(I+RSIZE2SHIFT)=A(I) ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_RSHIFT SUBROUTINE ZMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY: ZMUMPS_DM_PAMASTERORPTRAST IMPLICIT NONE INTEGER, INTENT(in) :: N, LIW, XSIZE INTEGER, INTENT(in) :: KEEP(500) INTEGER(8), INTENT(in) :: LA INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS INTEGER, INTENT(inout) :: IWPOSCB INTEGER :: IWPOS INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP(28)), & PIMASTER(KEEP(28)) INTEGER, INTENT(in) :: STEP(N), SLAVEF INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) COMPLEX(kind=8), INTENT(inout) :: A(LA) INTEGER, INTENT(inout) :: COMP DOUBLE PRECISION, INTENT(inout) :: ACC_TIME INTEGER, INTENT(in) :: MYID INCLUDE 'mumps_headers.h' INTEGER ICURRENT, NEXT, STATE_NEXT INTEGER(8) :: RCURRENT INTEGER ISIZE2SHIFT INTEGER(8) :: RSIZE2SHIFT INTEGER IBEGCONTIG INTEGER(8) :: RBEGCONTIG INTEGER(8) :: RBEG2SHIFT, REND2SHIFT INTEGER INODE LOGICAL :: IS_PAMASTER, IS_PTRAST INTEGER(8) :: FREE_IN_REC INTEGER(8) :: RCURRENT_SIZE, DYN_SIZE LOGICAL :: RECORD_CAN_BE_COMPRESSED INTEGER IXXP EXTERNAL MPI_WTIME DOUBLE PRECISION MPI_WTIME DOUBLE PRECISION TIME_STRT DOUBLE PRECISION TIME_COMP TIME_STRT = MPI_WTIME() ISIZE2SHIFT=0 RSIZE2SHIFT=0_8 ICURRENT = LIW-XSIZE+1 RCURRENT = LA+1_8 IBEGCONTIG = -999999 RBEGCONTIG = -999999_8 NEXT = IW(ICURRENT+XXP) IF (NEXT.EQ.TOP_OF_STACK) GOTO 120 COMP=COMP+1 STATE_NEXT = IW(NEXT+XXS) IXXP = ICURRENT+XXP 10 CONTINUE CALL ZMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, & IW(NEXT), XSIZE, KEEP(216)) IF ( .NOT. RECORD_CAN_BE_COMPRESSED ) THEN CALL ZMUMPS_MOVETONEXTRECORD(IW,LIW, & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) CALL MUMPS_GETI8(DYN_SIZE, IW(ICURRENT+XXD)) CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) IF (IBEGCONTIG < 0) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF IF (RBEGCONTIG < 0_8) THEN RBEGCONTIG=RCURRENT+RCURRENT_SIZE-1_8 ENDIF INODE=IW(ICURRENT+XXN) IF ( DYN_SIZE .EQ. 0_8 ) THEN IF (RSIZE2SHIFT .NE. 0_8) THEN CALL ZMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, & KEEP(28), KEEP(199), & INODE, IW(ICURRENT+XXS), & IW(ICURRENT+XXD:ICURRENT+XXD+1), STEP, & DAD, PROCNODE_STEPS, RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF (IS_PTRAST) THEN PTRAST(STEP(INODE))= & PTRAST(STEP(INODE))+RSIZE2SHIFT ELSE IF (IS_PAMASTER) THEN PAMASTER(STEP(INODE))= & PAMASTER(STEP(INODE))+RSIZE2SHIFT ENDIF ENDIF ENDIF IF (ISIZE2SHIFT .NE. 0) THEN IF (PTRIST(STEP(INODE)).EQ.ICURRENT) & PTRIST(STEP(INODE))= & PTRIST(STEP(INODE))+ISIZE2SHIFT IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) & PIMASTER(STEP(INODE))= & PIMASTER(STEP(INODE))+ISIZE2SHIFT ENDIF IF (NEXT .NE. TOP_OF_STACK) THEN STATE_NEXT=IW(NEXT+XXS) GOTO 10 ENDIF ENDIF 20 CONTINUE IF (IBEGCONTIG.NE.0 .AND. ISIZE2SHIFT .NE. 0) THEN CALL ZMUMPS_ISHIFT(IW,LIW,ICURRENT,IBEGCONTIG,ISIZE2SHIFT) IF (IXXP .LE.IBEGCONTIG) THEN IXXP=IXXP+ISIZE2SHIFT ENDIF ENDIF IBEGCONTIG=-9999 25 CONTINUE IF (RBEGCONTIG .GT.0_8 .AND. RSIZE2SHIFT .NE. 0_8) THEN CALL ZMUMPS_RSHIFT(A,LA,RCURRENT,RBEGCONTIG,RSIZE2SHIFT) ENDIF RBEGCONTIG=-99999_8 30 CONTINUE IF (NEXT.EQ. TOP_OF_STACK) GOTO 100 CALL ZMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, IW(NEXT), XSIZE, KEEP(216)) IF ( STATE_NEXT .NE. S_FREE .AND. & RECORD_CAN_BE_COMPRESSED ) THEN IF (RBEGCONTIG > 0_8) GOTO 25 CALL ZMUMPS_MOVETONEXTRECORD & (IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IF (IBEGCONTIG < 0 ) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF CALL ZMUMPS_SIZEFREEINREC(IW(ICURRENT), & LIW-ICURRENT+1, & FREE_IN_REC, & XSIZE) CALL MUMPS_GETI8(DYN_SIZE, IW(ICURRENT+XXD)) IF (DYN_SIZE .GT. 0_8) THEN ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG) THEN CALL ZMUMPS_MAKECBCONTIG(A,LA,RCURRENT, & IW(ICURRENT+XSIZE+2), & IW(ICURRENT+XSIZE), & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), 0, & IW(ICURRENT+XXS),RSIZE2SHIFT) IW(ICURRENT+XXS) = S_NOLCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN CALL ZMUMPS_MAKECBCONTIG(A,LA,RCURRENT, & IW(ICURRENT+XSIZE+2), & IW(ICURRENT+XSIZE), & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), & IW(ICURRENT+XSIZE+4)-IW(ICURRENT+XSIZE+3), & IW(ICURRENT+XXS),RSIZE2SHIFT) IW(ICURRENT+XXS) = S_NOLCLEANED38 ELSE IF (STATE_NEXT.EQ.S_NOLNOCB) THEN IW(ICURRENT+XXS) = S_NOLNOCBCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38) THEN IF (STATE_NEXT .EQ. S_NOLCBCONTIG) THEN IW(ICURRENT+XXS) = S_NOLCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG38) THEN IW(ICURRENT+XXS) = S_NOLCLEANED38 ENDIF IF (RSIZE2SHIFT .GT.0_8) THEN RBEG2SHIFT = RCURRENT + FREE_IN_REC CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) REND2SHIFT = RCURRENT + RCURRENT_SIZE - 1_8 CALL ZMUMPS_RSHIFT(A, LA, & RBEG2SHIFT, REND2SHIFT, & RSIZE2SHIFT) ENDIF ELSE WRITE(*,*) "Internal error 3 in ZMUMPS_COMPRE_NEW", & STATE_NEXT, DYN_SIZE, FREE_IN_REC CALL MUMPS_ABORT() ENDIF INODE = IW(ICURRENT+XXN) IF ( DYN_SIZE .GT. 0_8 ) THEN IF (PTRIST(STEP(INODE)).EQ.ICURRENT) & PTRIST(STEP(INODE))= & PTRIST(STEP(INODE))+ISIZE2SHIFT IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) & PIMASTER(STEP(INODE))= & PIMASTER(STEP(INODE))+ISIZE2SHIFT ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLNOCB ) THEN IF (ISIZE2SHIFT.NE.0) THEN PTRIST(STEP(INODE))=PTRIST(STEP(INODE))+ISIZE2SHIFT ENDIF PTRAST(STEP(INODE))=PTRAST(STEP(INODE))+RSIZE2SHIFT+ & FREE_IN_REC ELSE WRITE(*,*) "Internal error 4 in ZMUMPS_COMPRE_NEW", & STATE_NEXT CALL MUMPS_ABORT() ENDIF CALL MUMPS_SUBTRI8TOARRAY(IW(ICURRENT+XXR),FREE_IN_REC) RSIZE2SHIFT=RSIZE2SHIFT+FREE_IN_REC RBEGCONTIG=-9999_8 IF (NEXT.EQ.TOP_OF_STACK) THEN GOTO 20 ELSE STATE_NEXT=IW(NEXT+XXS) ENDIF GOTO 30 ENDIF IF (IBEGCONTIG.GT.0) THEN GOTO 20 ENDIF 40 CONTINUE IF (STATE_NEXT == S_FREE) THEN ICURRENT = NEXT CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT + XXR) ) ISIZE2SHIFT = ISIZE2SHIFT + IW(ICURRENT+XXI) RSIZE2SHIFT = RSIZE2SHIFT + RCURRENT_SIZE RCURRENT = RCURRENT - RCURRENT_SIZE NEXT=IW(ICURRENT+XXP) IF (NEXT.EQ.TOP_OF_STACK) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_COMPRE_NEW" CALL MUMPS_ABORT() ENDIF STATE_NEXT = IW(NEXT+XXS) GOTO 40 ENDIF GOTO 10 100 CONTINUE IWPOSCB = IWPOSCB + ISIZE2SHIFT LRLU = LRLU + RSIZE2SHIFT IPTRLU = IPTRLU + RSIZE2SHIFT 120 CONTINUE TIME_COMP = MPI_WTIME() - TIME_STRT IF (KEEP(405).EQ.0) THEN ACC_TIME = ACC_TIME + TIME_COMP ELSE !$OMP ATOMIC UPDATE ACC_TIME = ACC_TIME + TIME_COMP !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE ZMUMPS_COMPRE_NEW SUBROUTINE ZMUMPS_GET_SIZEHOLE(IREC, IW, LIW, & ISIZEHOLE, RSIZEHOLE) IMPLICIT NONE INTEGER, intent(in) :: IREC, LIW INTEGER, intent(in) :: IW(LIW) INTEGER, intent(out):: ISIZEHOLE INTEGER(8), intent(out) :: RSIZEHOLE INTEGER IRECLOC INTEGER(8) :: RECLOC_SIZE INCLUDE 'mumps_headers.h' ISIZEHOLE=0 RSIZEHOLE=0_8 IRECLOC = IREC + IW( IREC+XXI ) 10 CONTINUE CALL MUMPS_GETI8(RECLOC_SIZE, IW(IRECLOC+XXR)) IF (IW(IRECLOC+XXS).EQ.S_FREE) THEN ISIZEHOLE=ISIZEHOLE+IW(IRECLOC+XXI) RSIZEHOLE=RSIZEHOLE+RECLOC_SIZE IRECLOC=IRECLOC+IW(IRECLOC+XXI) GOTO 10 ENDIF RETURN END SUBROUTINE ZMUMPS_GET_SIZEHOLE SUBROUTINE ZMUMPS_MAKECBCONTIG(A, LA, RCURRENT, & NROW, NCB, LD, NELIM, NODESTATE, ISHIFT) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER LD, NROW, NCB, NELIM, NODESTATE INTEGER(8) :: ISHIFT INTEGER(8) :: LA, RCURRENT COMPLEX(kind=8) A(LA) INTEGER I,J INTEGER(8) :: IOLD,INEW LOGICAL NELIM_ROOT NELIM_ROOT=.TRUE. IF (NODESTATE.EQ. S_NOLCBNOCONTIG) THEN NELIM_ROOT=.FALSE. IF (NELIM.NE.0) THEN WRITE(*,*) "Internal error 1 IN ZMUMPS_MAKECBCONTIG" CALL MUMPS_ABORT() ENDIF ELSE IF (NODESTATE .NE. S_NOLCBNOCONTIG38) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_MAKECBCONTIG" & ,NODESTATE CALL MUMPS_ABORT() ENDIF IF (ISHIFT .LT.0_8) THEN WRITE(*,*) "Internal error 3 in ZMUMPS_MAKECBCONTIG",ISHIFT CALL MUMPS_ABORT() ENDIF IF (NELIM_ROOT) THEN IOLD=RCURRENT+int(LD,8)*int(NROW,8)+int(NELIM-1-NCB,8) ELSE IOLD = RCURRENT+int(LD,8)*int(NROW,8)-1_8 ENDIF INEW = RCURRENT+int(LD,8)*int(NROW,8)+ISHIFT-1_8 DO I = NROW, 1, -1 IF (I.EQ.NROW .AND. ISHIFT.EQ.0_8.AND. & .NOT. NELIM_ROOT) THEN IOLD=IOLD-int(LD,8) INEW=INEW-int(NCB,8) CYCLE ENDIF IF (NELIM_ROOT) THEN DO J=1,NELIM A( INEW ) = A( IOLD + int(- J + 1,8)) INEW = INEW - 1_8 ENDDO ELSE DO J=1, NCB A( INEW ) = A( IOLD + int(- J + 1, 8)) INEW = INEW - 1_8 ENDDO ENDIF IOLD = IOLD - int(LD,8) ENDDO IF (NELIM_ROOT) THEN NODESTATE=S_NOLCBCONTIG38 ELSE NODESTATE=S_NOLCBCONTIG ENDIF RETURN END SUBROUTINE ZMUMPS_MAKECBCONTIG SUBROUTINE ZMUMPS_GET_SIZE_NEEDED( & SIZEI_NEEDED, SIZER_NEEDED, SKIP_TOP_STACK, & KEEP, KEEP8, & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR & ) #if ! defined(NODYNAMICCB) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY: ZMUMPS_DM_CBSTATIC2DYNAMIC #endif IMPLICIT NONE INTEGER, INTENT(in) :: SIZEI_NEEDED INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: KEEP(500) INTEGER(8), INTENT(inout):: KEEP8(150) INTEGER, INTENT(in) :: N, LIW, XSIZE INTEGER(8), INTENT(in) :: LA INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS INTEGER, INTENT(inout) :: IWPOSCB INTEGER, INTENT(inout) :: IWPOS INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP(28)), & PIMASTER(KEEP(28)) INTEGER, INTENT(in) :: STEP(N), SLAVEF INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) COMPLEX(kind=8), INTENT(inout) :: A(LA) INTEGER, INTENT(inout) :: COMP DOUBLE PRECISION, INTENT(inout) :: ACC_TIME INTEGER, INTENT(iN) :: MYID INTEGER, INTENT(inout) :: IFLAG, IERROR LOGICAL ZMUMPS_COMPRE_NEW_CALLED ZMUMPS_COMPRE_NEW_CALLED = .FALSE. IF (IWPOSCB-IWPOS+1 .LT. SIZEI_NEEDED) THEN CALL ZMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 1 in ZMUMPS_GET_SIZE_NEEDED ', & 'PB compress... ZMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ZMUMPS_COMPRE_NEW_CALLED = .TRUE. IF (IWPOSCB-IWPOS+1 .LT. SIZEI_NEEDED) THEN IFLAG = -8 IERROR = SIZEI_NEEDED GOTO 500 ENDIF ENDIF IF ( .NOT.ZMUMPS_COMPRE_NEW_CALLED.AND. & (LRLU.LT.SIZER_NEEDED).AND. & (LRLUS.GE.SIZER_NEEDED).AND. & (LRLU.NE.LRLUS) & ) THEN CALL ZMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) ZMUMPS_COMPRE_NEW_CALLED = .TRUE. IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 2 ', & 'in ZMUMPS_GET_SIZE_NEEDED ', & 'PB compress... ZMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF IF (LRLUS.LT.SIZER_NEEDED) THEN #if ! defined(NODYNAMICCB) IF (.NOT. ZMUMPS_COMPRE_NEW_CALLED) THEN CALL ZMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 2 ', & 'in ZMUMPS_GET_SIZE_NEEDED ', & 'PB compress... ZMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF CALL ZMUMPS_DM_CBSTATIC2DYNAMIC(KEEP(141), & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 500 IF (LRLU.LT.SIZER_NEEDED) THEN CALL ZMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 4 ', & 'in ZMUMPS_GET_SIZE_NEEDED ', & 'PB compress... ZMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF #else IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) GOTO 500 #endif ENDIF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_GET_SIZE_NEEDED MUMPS_5.8.1/src/dini_defaults.F0000664000175000017500000016756115042446441016172 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C********************************************************************** C SUBROUTINE DMUMPS_SET_TYPE_SIZES( K34, K149, K150, K10 ) IMPLICIT NONE C C Purpose: C ======= C C Set the size in bytes of an "INTEGER" in K34 C Set the size of the default arithmetic (DOUBLE PRECISION, DOUBLE PRECISION, C DOUBLE PRECISION or DOUBLE DOUBLE PRECISION) in K149 C Set the size of floating-point types that are real or double C precision even for complex versions of MUMPS (DOUBLE PRECISION for S and C C versions, DOUBLE PRECISION for D and Z versions) C Assuming that the size of an INTEGER(8) is 8, store the ratio C nb_bytes(INTEGER(8)) / nb_bytes(INTEGER) = 8 / K34 into K10. C C In practice, we have: C C K149: Arithmetic Value Value for T3E C S 4 8 C D 8 16 C C 8 16 C Z 16 32 C C K150 = K149 for S and D arithmetics C K150 = K149 / 2 for C and Z arithmetics C C K34= 4 and K10 = 2, except on CRAY machines or when compilation C flag -i8 is used, in which case, K34 = 8 and K10 = 1 C INTEGER, INTENT(OUT) :: K34, K149, K10, K150 INTEGER(8) :: SIZE_INT, SIZE_REAL_OR_DOUBLE ! matches MUMPS_INT8 INTEGER I(2) DOUBLE PRECISION R(2) ! Will be DOUBLE PRECISION if 1 CALL MUMPS_SIZE_C(I(1),I(2),SIZE_INT) CALL MUMPS_SIZE_C(R(1),R(2),SIZE_REAL_OR_DOUBLE) K34 = int(SIZE_INT) K10 = 8 / K34 K150 = int(SIZE_REAL_OR_DOUBLE) K149 = K150 RETURN END SUBROUTINE DMUMPS_SET_TYPE_SIZES C C********************************************************************** C SUBROUTINE DMUMPSID( NSLAVES, LWK_USER, CNTL, ICNTL, & KEEP,KEEP8, & INFO, INFOG, RINFO, RINFOG, SYM, PAR, & DKEEP, MYID ) !$ USE OMP_LIB IMPLICIT NONE C C Purpose C ======= C C The elements of the arrays CNTL and ICNTL control the action of C DMUMPS, DMUMPS_ANA_DRIVER, DMUMPS_FAC_DRIVER, DMUMPS_SOLVE_DRIVER C Default values for the elements are set in this routine. C DOUBLE PRECISION DKEEP(230) DOUBLE PRECISION CNTL(15), RINFO(40), RINFOG(40) INTEGER ICNTL(60), KEEP(500), SYM, PAR, NSLAVES, MYID INTEGER INFO(80), INFOG(80) INTEGER(8) KEEP8(150) INTEGER LWK_USER C C Parameters C ========== C=========================================== C Arrays for control and information C=========================================== C C N Matrix order C C NELT Number of elements for matrix in ELt format C C C SYM = 0 ... initializes the defaults for unsymmetric code C = 1,2 ... initializes the defaults for symmetric code C C C C PAR = 0 ... instance where host is not working C = 1 ... instance where host is working as a normal node. C (host uses more memory than other processors in C the latter case) C C CNTL and the elements of the array ICNTL control the action of C DMUMPS Default values C are set by DMUMPSID. The elements of the arrays RINFO C and INFO provide information on the action of DMUMPS. C C CNTL(1) threshold for partial pivoting C has default -1.0 (automatic choice): C 0.1 in case of rank-revealing (ICNTL(56)=1,2) C otherwise 0.0 when SYM=1 and 0.01 otherwise. C Values greater than 1.0 are treated as 1.0 for C SYM=1 and as 0.5 for SYM=2 C In general, a larger value of CNTL(1) leads to C greater fill-in but a more accurate factorization. C If CNTL(1) is nonzero, numerical pivoting will be performed. C If CNTL(1) is zero, no pivoting will be performed and C the subroutine will fail if a zero pivot is encountered. C If the matrix A is diagonally dominant, then C setting CNTL(1) to zero will decrease the factorization C time while still providing a stable decomposition. C C CNTL(2) must be set to the tolerance for convergence of iterative C refinement. C Default value is sqrt(macheps). C Values less than zero are treated as sqrt(macheps). C C CNTL(3) is used with null pivot row detection (ICNTL(24) .eq. 1) C and/or with Rank-Revealing (RR) option (ICNTL(56)). C Default value is 0.0. C Let A_{preproc} be the preprocessed matrix to be factored (see C equation in the user's guide). C A pivot is considered to be null if the infinite norm of its C row/column is smaller than a threshold. Let MACHEPS be the C machine precision and ||.|| be the infinite norm. C The absolute value to detect a null pivot row (when ICNTL(24) .EQ.1) C is stored in DKEEP(1). C In case of RR, CNTL(3) will define the thresholds for : C C - Postponing pseudo singularities (SEUIL): C The computed threshold value for postponing pivots C is stored in "SEUIL" and then "SEUIL_LDLT_NIV2" C which are identical in current version. C C - Defining singularities on root (DKEEP(9)) C C - Defining null pivot rows if ICNTL(24).EQ.1 (DKEEP(1)) C in this case DKEEP(1) must be smaller than DKEEP(9) C C IF (ICNTL(56).NE.0) THEN C RR on root is active C IF (CNTL3 .LT. ZERO) THEN C DKEEP(9) = abs(CNTL(3)) C ELSE IF (CNTL3 .GT. ZERO) THEN C DKEEP(9) = CNTL3*||A_{preproc}|| C ELSE ! (CNTL(3) .EQ. ZERO) THEN C DKEEP(9) = sqrt(N_h)*MACHEPS*||A_{preproc}|| C where Nh is the number of pivots on the deepest branch C of the elimination tree. C ENDIF C IF (ICNTL(24).EQ.1) THEN C null pivot detection C DKEEP(1) = DKEEP(9)*DKEEP(10) C ENDIF C C ELSE (ONLY NULL PIVOT detection is active) C IF CNTL(3) > 0 THEN C DKEEP(1) = CNTL(3) ||A_{preproc}|| C ELSE IF CNTL(3) = 0.0 THEN C DKEEP(1) = MACHEPS sqrt(N_h)||A_{preproc}|| C ELSE IF CNTL(3) < 0 THEN C DKEEP(1) = abs(CNTL(3))! this was added for EDF C ! in the context of SOLSTICE project C ENDIF C ENDIF C C CNTL(4) must be set to value for static pivoting. C Default value is -1.0 C Note that static pivoting is enabled only when C Rank-Revealing and null pivot detection C are off (KEEP(19).EQ.0).AND.(KEEP(110).EQ.0). C If negative, static pivoting will be set OFF (KEEP(97)=0) C If positive, static pivoting is ON (KEEP(97=1) with C threshold CNTL(4) C If = 0, static pivoting is ON with threshold MACHEPS^1/2 || A || C C CNTL(5) fixation for null pivots C Default value is 0.0 C Only active if ICNTL(24) = 1 C If > 0 after finding a null pivot, it is set to CNTL(5) x ||A|| C (This value is stored in DKEEP(2)) C If <= 0 then C SYM=2: C the row/column (except the pivot) is set to zero C and the pivot is set to 1 C SYM=0: C the fixation is automatically C set to a large potitive value and the pivot row of the C U factors is set to zero. C Default is 0. C C CNTL(6) not used yet C C CNTL(7) tolerance for Low Rank approximation of the Blocks (BLR). C Dropping parameter expressed with a double precision, C real value, controlling C compression and used to truncate the RRQR algorithm C default value is 0.0. (i.e. no approximation). C The truncated RRQR operation is implemented as C as variant of the LAPACK GEQP3 and LAQPS routines. C 0.0 : full precision approximation. C > 0.0 : the dropping parameter is DKEEP(8). C C Warning: using negative values is an experimental and C non recommended setting. C < 0.0 : the dropping parameter is |DKEEP(8)|*|Apre|, Apre C as defined in user's guide C C C ----------------------------------------- C C ICNTL(1) has default value 6. C It is the output stream for error messages. C If it is set to zero, these C messages will be suppressed. C C ICNTL(2) has default value 0. C It is the output stream for diagnostic printing and C for warning messages that are local to each MPI process. C If it is set to zero, these messages are suppressed. C C ICNTL(3) -- Host only C It is the output stream for diagnostic printing C and for warning messages. Default value is 6. C If it is set to zero, these messages are suppressed. C C ICNTL(4) is used by DMUMPS to control printing of error, C warning, and diagnostic messages. It has default value 2. C Possible values are: C C <1 __No messages output. C 1 __Only error messages printed. C 2 __Errors and warnings printed. C 3 __Errors and warnings and terse diagnostics C (only first ten entries C of arrays printed). C 4 __Errors and warnings and all information C on input and output parameters printed. C C C ICNTL(5) is the format of the input matrix and rhs C 0: assembled matrix, assembled rhs C 1: elemental matrix, assembled rhs C Default value is 0. C C ICNTL(6) has default value 7 for unsymmetric and C general symmetric matrices, and 0 for SPD matrices. C It is only accessed and operational C on a call that includes an analysis phase C (JOB = 1, 4, or 6). C In these cases, if ICNTL(6)=1, 2, 3, 4, 5, 6 or 7, C a column permutation based on algorithms described in C Duff and Koster, 1997, *SIMAX <20>, 4, 889-901, C is applied to the original matrix. Column permutations are C then applied to the original matrix to get a zero-free diagonal. C Except for ICNTL(6)=1, the numerical values of the C original matrix, id%A(NE), need be provided by the user C during the analysis phase. C If ICNTL(6)=7, based on the structural symmetry of the C input matrix the value of ICNTL(6) is automatically chosen. C If the ordering is provided by the user C (ICNTL(7)=1) then the value of ICNTL(6) is ignored. C C ICNTL(7) has default value 7 and must be set by the user to C 1 if the pivot order in IS is to be used. C Effective value of ordering stored in KEEP(256). C Possible values are (depending on the softwares installed) C 0 AMD: Approximate minimum degree (included in DMUMPS package) C 1 Ordering provided by the user C 2 Approximate minimum fill (included in DMUMPS package) C 3 SCOTCH (see http://gforge.inria.fr/projects/scotch/) C should be downloaded/installed separately. C 4 PORD from Juergen Schulze (js@juergenschulze.de) C PORD package is extracted from the SPACE-1.0 package developed at the C University of Paderborn by Juergen Schulze C and is provided as a separate package. C 5 Metis ordering should be downloaded/installed separately. C 6 Approximate minimum degree with automatic quasi C dense row detection (included in DMUMPS package). C (to be used when ordering time with AMD is abnormally large) C 7 Automatic choice done during analysis phase C For any other C value of ICNTL(7), a suitable pivot order will be C chosen automatically. C C ICNTL(8) is used to describe the scaling strategy. C Default value is 77. C Note that scaling is performed only when the numerical C factorization step is performed (JOB = 2, 4>, 5>, or 6>). C If ICNTL(8) is not equal to C any of the values listed below then ICNTL(8) is treated C as if it had its default value of 0 (no scaling). C If the matrix is known to be very badly scaled, C our experience has been that option 6 is the most robust but C the best scaling is very problem dependent. C If ICNTL(8)=0, COLSCA and ROWSCA are dummy arguments C of the subroutine that are not accessed. C Possible values of ICNTL(8) are: C C -2 scaling computed during analysis (and applied during the C factorization) C C -1 the user must provide the scaling in arrays C COLSCA and ROWSCA C C 0 no scaling C C 1 Diagonal scaling C C 2 not defined C C 3 Column scaling C C 4 Row and column scaling C C 5,6 not defined C 7, 8 Scaling based on Daniel Ruiz and Bora Ucar's work done C during the ANR-SOLSTICE project. C Reference for this work are: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C This scaling can work on both centralized and distributed C assembled input matrix format. (it works for both symmetric C and unsymmetric matrices) C Option 8 is similar to 7 but more rigourous and expensive to compute. C 77 Automatic choice of scaling value done. Proposed algo: C if (sym=1) then C option = 0 C else C if distributed matrix entry then C option = 7 C else C if (maximum transversal is called C and makes use of numerical values) then C option=-2 and ordering is computed during analysis C else C option = 7 C endif C endif C endif C C ICNTL(9) has default value 1. If ICNTL(9)=1 C the system of equations A * x = b is solved. For other C values the system A^T * x = b is solved. C When ICNTL(30) (compute selected entries in A-1) is activated C ICNTL(9) is ignored. C C ICNTL(10) has default value 0. C If ICNTL(10)=0 : iterative refinement is not performed. C Values of ICNTL(10) < 0 : a fix number of steps equal C to ICNTL(10) of IR is done. C Values of ICNTL(10) > 0 : mean a maximum of ICNTL(10) number C of steps of IR is done, and a test of C convergence is used C C ICNTL(11) has default value 0. C A value equal to 1 will return a backward error estimate in C RINFO(4-11). C A value equal to 2 will return a backward error estimate in C RINFO(4-8). No LCOND 1, 2 and forward error are computed. C If ICNTL(11) is negative, zero or greater than 2 no estimate C is returned. C C C ICNTL(12) has default value 0 and defines the strategy for C LDLT orderings C 0 : automatic choice C 1 : usual ordering (nothing done) C 2 : ordering on the compressed graph, available with all orderings C except with AMD C 3 : constraint ordering, only available with AMF, C -> reset to 2 with other orderings C Other values are treated as 1 (nothing done). C On output KEEP(95) holds the internal value used and INFOG(24) gives C access to KEEP(95) to the user. C in LU facto it is always reset to 1 C C - ICNTL(12) = 3 has a lower priority than ICNTL(7) C thus if ICNTL(12) = 3 and the ordering required is not AMF C then ICNTL(12) is set to 2 C C - ICNTL(12) = 2 has a higher priority than ICNTL(7) C thus if ICNTL(12) = 2 and the ordering required is AMD C then the ordering used is QAMD C C - ICNTL(12) has a higher priority than ICNTL(6) and ICNTL(8) C thus if ICNTL(12) = 2 then ICNTL(6) is automatically C considered as if it was set to a value between 1-6 C if ICNTL(12) = 3 then ICNTL(6) is considered as if C set to 5 and ICNTL(8) as if set to -2 (we need the scaling C factors to define free and constrained variables) C C ICNTL(13) has default value 0 and allows for selecting Type 3 node. C IF ICNTL(13).GT. 0 scalapack is forbidden. Otherwise, C scalapack will be activated if the root is large enough. C Furthermore C IF ((ICNTL(13).GT.0) .AND. (NSLAVES.GT.ICNTL(13), C or ICNTL(13)=-1 THEN C extra splitting of the root will be activated C and is controlled by abs(KEEP(82)). C The order of the root node is divided by KEEP(82) C ENDIF C If ICNTL(13) .EQ. -1 then splitting of the root C is done whatever the nb of procs is. C Authorizing extra root spliting during analysis might be C interesting to further split the root node (combined for C example with null pivot detection option ICNTL(24)=1 OR ICNTL(56)) C C To summarize: C -1 : root splitting and scalapack on C 0 or < -1 : root splitting off and sclalapack on C > 0 : scalapack off C C ICNTL(14) has default value 20 (5 if NSLAVES=1 and SYM=1) C and is the value for memory relaxation C so called "PERLU" in the following. C C C ICNTL(15) : Describes the compression of the graph of the input matrix C The analysis step is then performed on the compressed C graph C Must be set during analysis on the master C 0 : OFF C 1 : Compression provided by the user: C BLKPTR(1:id%NBLK+1) and C BLKVAR(1:N or N_LOC if distributed format) C (BLKVAR(BLKPTR(iblk):BLKPTR(iblk+1)-1): C dof list for iblk) C - If BLKVAR is not provided then BLKVAR is C treated as the identity C (contiguous variables in blocks) C - Distributed format if on MASTER N_LOC#N C C ICNTL(16) : number of OpenMP threads asked by the user. C C ICNTL(17) not used in this version C C ICNTL(18) has default value 0 and is only accessed by the host during C the analysis phase if the matrix is assembled (ICNTL(5))= 0). C ICNTL(18) defines the strategy for the distributed input matrix. C Possible values are: C 0: input matrix is centralized on the host. This is the default C 1: user provides the structure of the matrix on the host at analysis, C DMUMPS returns C a mapping and user should provide the matrix distributed according C to the mapping C 2: user provides the structure of the matrix on the host at analysis, C and the C distributed matrix on all slave processors at factorization. C Any distribution is allowed C 3: user directly provides the distributed matrix input both C for analysis and factorization C C For flexibility and performance issues, option 3 is recommended. C C ICNTL(19) has default value 0 and is only accessed by the host C during the analysis phase. If ICNTL(19) \neq 0 then Schur matrix will C be returned to the user. C The user must set on entry on the host node (before analysis): C the integer variable SIZE\_SCHUR to the size fo the Schur matrix, C the integer array pointer LISTVAR\_SCHUR to the list of indices C of the schur matrix. C if = 0 : Schur is off and the root node gets factorized C if = 1 : Schur is on and the Schur complement is returned entirely C on a memory area provided by the user ONLY on the host node C if = 2 or 3 : Schur is on and the Schur complement is returned in a C distributed fashion according to a 2D block-cyclic C distribution. In the case where the matrix is symmetric C the lower part is returned if =2 or the complete C matrix if =3. C C ICNTL(20) has default value 0 and is only accessed by the host C during the solve phase. If ICNTL(20)=0, the right-hand side must given C in dense form in the structure component RHS. C If ICNTL(20)=1,2,3, then the right-hand side must be given in sparse form C using the structure components IRHS\_SPARSE, RHS\_SPARSE, IRHS\_PTR and C NZ\_RHS. C When the right-hand side is provided in sparse form then duplicate entries C are summed. C C 0 : dense RHS C 1,2,3 : Sparse RHS C 1 The decision of exploiting sparsity of the right-hand side to C accelerate the solution phase is done automatically. C 2 Sparsity of the right-hand sides is NOT exploited C to improve solution phase. C 3 Sparsity of the right-hand sides is exploited C to improve solution phase. C Values different from 0,1, 2,3 are treated as 0. C For sparse RHS recommended value is 1. C C ICNTL(21) has default value 0 and is only accessed by the host C during the solve phase. If ICNTL(21)=0, the solution vector will be assembled C and stored in the structure component RHS, that must have been allocated by C the user. If ICNTL(21)=1, the solution vector is kept distributed at the C end of the solve phase, and will be available on each slave processor C in the structure components ISOL_loc and SOL_loc. ISOL_loc and SOL_loc C must then have been allocated by the user and must be of size at least C INFO(23), where INFO(23) has been returned by DMUMPS at the end of the C factorization phase. C Values of ICNTL(21) different from 0 and 1 are currently treated as 0. C C ICNTL(22) (saved in KEEP(201) controls the OOC setting (0=incore, 1 =OOC) C It has default value 0 (incore).Out-of-range values are treated as 0. C If set before analysis then special setting and massage of the tree C might be done (so far only extra splitting CUTNODES) is performed. C It is then accessed by the host C during the factorization phase. If ICNTL(22)=0, then no attempt C to use the disks is made. If ICNTL(22)=1, then DMUMPS will store C the computed factors on disk for later use during the solution C phase. C C ICNTL(23) has default value 0 and is accessed by ALL processors C at the beginning of the factorization phase. If positive C it corresponds to the maximum size of the working memory C in MegaBytes that MUMPS can allocate per working processor. C If only the host C value is non zero, then other processors also use the value on C the host. Otherwise, each processor uses the local value C provided. C C ICNTL(24) default value is 0 C if = 0 no null pivot detection (CNTL(5) and CNTL(3) are inactive), C = 1 null pivot row detection; CNTL(3) and CNTL(5) are C then used to describe the action taken. C C C ICNTL(25) has default value 0 and is only accessed by the C host during the solution stage. It is only significant if C a null space basis was requested during the factorization C phase (INFOG(28) .GT. 0); otherwise a normal solution step C is performed. C If ICNTL(25)=0, then a normal solution step is performed, C on the internal problem (excluding the null space). C No special property on the solution (discussion with Serge) C If ICNTL(25)=i, 1 <= i <= INFOG(28), then the i-th vector C of the null space basis is computed. In that case, note C that NRHS should be set to 1. C If ICNTL(25)=-1, then all null space is computed. The C user should set NRHS=INFOG(28) in that case. C Note that centralized or distributed solutions are C applicable in that case, but that iterative refinement, C error analysis, etc... are excluded. Note also that the C option to solve the transpose system (ICNTL(9)) is ignored. C C C ICNTL(26) has default value 0 and is accessed on the host only C at the beginning of the solution step. C It is only effective if the Schur option is ON. C (copy in KEEP(221)) C C C During the solution step, a value of 0 will perform a normal C solution step on the reduced problem not involving the Schur C variables. C During the solution step, if ICNTL(26)=1 or 2, then REDRHS C should be allocated of size at least LREDRHS*(NRHS-1)+ C SIZE_SCHUR, where LREDRHS is the leading dimension of C LREDRHS (LREDRHS >= SIZE_SCHUR). C C If ICNTL(26)=1, then only a forward substitution is performed, C and a reduced RHS will be computed and made available in C REDRHS(i+(k-1)*LREDRHS), i=1, ..., SIZE_SCHUR, k=1, ..., NRHS. C If ICNTL(26)=2, then REDRHS(i+(k-1)*LREDRHS),i=1, SIZE_SCHUR, C k=1,NRHS is considered to be the solution corresponding to the C Schur variables. It is injected in DMUMPS, that computes the C solution on the "internal" problem during the backward C substitution. C C ICNTL(27) controls the blocking factor for multiple right-hand-sides C during the solution phase. C It influences both the memory used (see INFOG(30-31)) and C the solution time C (Larger values of ICNTL(27) leads to larger memory requirements). C Its tuning can be critical when C the factors are written on disk (out-of core, ICNTL(22)=1). C A negative value indicates that automatic setting is C performed by the solver. C C C ICNTL(28) decides whether parallel or sequential analysis should be used. Three C values are possible at the moment: C 0: automatic. This defaults to sequential analysis C 1: sequential. In this case the ordering strategy is defined by ICNTL(7) C 2: parallel. In this case the ordering strategy is defined by ICNTL(29) C C ICNTL(29) defines the ordering too to be used during the parallel analysis. Three C values are possible at the moment: C 0: automatic. This defaults to PT-SCOTCH C 1: PT-SCOTCH. C 2: ParMetis. C C C ICNTL(30) controls the activation of functionality A-1. C It has default value 0 and is only accessed by the master C during the solution phase. It enables the solver to C compute entries in the inverse of the original matrix. C Possible values are: C 0 normal solution C other values: compute entries in A-1 C When ICNTL(30).NE.0 then the user C must describe on entry to the solution phase, C in the sparse right-hand-side C (NZ_RHS, NRHS, RHS_SPARSE, IRHS_SPARSE, IRHS_PTR) C the target entries of A-1 that need be computed. C Note that RHS_SPARSE must be allocated but need not be C initialized. C On output RHS_SPARSE then holds the requested C computed values of A-1. C Note that when ICNTL(30).NE.0 then C - sparse right hand side interface is implicitly used C functionality (ICNTL(20)= 1) but RHS need not be C allocated since computed A-1 entries will be stored C in place. C - ICNTL(9) option (solve Ax=b or Atx=b) is ignored C In case of duplicate entries in the sparse rhs then C on output duplicate entries in the solution are provided C in the same place. C This need not be mentioned in the spec since it is a C "natural" extension. C C ----------- C Fwd in facto C ----------- C ICNTL(31) Must be set before analysis to control storage C of LU factors. Default value is 0. Out of range C values considered as 0. C (copied in KEEP(251) and broadcast, C when setting of ICNTL(31) C results in not factors to be stored then C KEEP(201) = -1, OOC is "suppressed") C 0 Keep factors needed for solution phase C (when option forward during facto is used then C on unsymmetric matrices L factors are not stored) C 1 Solve not needed (solve phase will never be called). C When the user is only interested in the inertia or the C determinant then C all factor matrices need not be stored. C This can also be useful for testing : C to experiment facto OOC without C effective storage of factors on disk. C 2 L factors not stored: meaningful when both C - matrix is unsymmetric and fwd performed during facto C - the user is only interested in the null-space basis C and thus only need the U factors to be stored. C Currently, L factors are always stored in IC. C C ----------- C Fwd in facto C ----------- C ICNTL(32) Must be set before analysis to indicate whether C forward is performed during factorization. C Default value is 0 (normal factorization without fwd) C (copied in KEEP(252) and broadcast) C 0 Normal factorization (default value) C 1 Forward performed during factorization C C C ICNTL(33) Must be set before the factorization phase to compute C the determinant. See also KEEP(258), KEEP(259), C DKEEP(6), DKEEP(7), INFOG(34), RINFOG(12) C C If ICNTL(33)=0 the determinant is not computed C For all other values, the determinant is computed. Note that C null pivots and static pivots are excluded from the C computation of the determinant. C #if ! defined(NO_SAVE_RESTORE) C ICNTL(34) Must be set before a call to MUMPS with JOB=-3 in case C the save/restore feature was used and user wants to clean C save/restore files (and possibly OOC files). C ICTNL(34)=0 => user wants to be able to restore instance later C ICTNL(34)=1 => user will not restore the instance again (clean C to be done) #endif C C ICNTL(35) : Block Low-Rank (BLR) functionality, C need be set before analysis C Default value is 0 C 0: FR factorization and FR solve C 1: Automatic BLR option setting (=> 2) C 2: BLR factorization + BLR Solve C => keep BLR factors only C 3: BLR factorization + FR Solve C Other values are treated as zero C Note that this functionality is currently incompatible C with elemental matrices (ICNTL(5) = 1) and with C forward elimination during factorization (ICNTL(32) = 1) C C ICNTL(36) : Block Low-Rank variant choice C Default value is 0 C 0: UFSC variant, no recompression: Compress step is C performed after the Solve; the low-rank updates are not C recompressed C 1: UFCS variant, no recompression: Factor (with pivoting) on full-rank blocks, C then Compress and finally Solve on low-rank blocks (those where pivoting is not needed, C which depends on the context) C C ICNTL(37) : Compress CB strategy need be set before factorization C 0 = DONT compress CB (default) C 1 = SYSTEMATIC compress CB: compress CB for all candidate fronts C C ICNTL(38): Compression rate of LU factors, can be set before C analysis/factorization C Between 0 and 1000; other values ares treated as 0; C ICNTL(38)/10 is a percentage representing the typical C compressed factors compression of the factor matrices C in BLR fronts: C ICNTL(38)/10= compressed/uncompressed factors × 100. C Default value: 600 C (when factors of BLR fronts are compressed, C their size is 60% of their full- rank size). C ICNTL(39) : Compression rate of Contribution Blocks (CBs) C can be set before analysis/factorization C Between 0 and 1000; other values ares treated as 0; C corresponds to an estimated compression rate of C ICNTL(39)/1000%. C Default value: 500 (50.0% compression rate). C ICNTL(48) : Controls L0_OMP feature. It must be set on the host C before the analysis phase to prepare datastructures C for factorization. C If ICNTL(48) was nonzero during analysis, C L0-OMP will be activated during factorization. C OMP_NUM_THREADS should not change between analysis C and factorization, as long as L0 task scheduling during C factorization is static. C ICNTL(48) can however change between factorization C and solve phases. If activated during analysis, the C number of threads for L0OMP (for both analysis and C factorization) is saved in KEEP(400) (see above). C For LO_OMP feature to be effective during solve C both KEEP(400)>0 and ICNTL(48)>0 are needed C Possible values at analysis: C 0 : off -- L0-OMP is not activated for analysis C and factorization C >0 : on -- L0-OMP is activated for analysis C and factorization C out-of-range values (<0) : off C Possible values at solve: C 0 : off --L0-OMP is not activated for solve. C Possible even if L0-OMP was activated during C analysis/factorization C >0 : on --L0-OMP activated for solve. C Possible only if L0-OMP was activated during C analysis/factorization C if (defined(_OPENMP)) then C default value is 1 (L0-thread ON) C else C default value is 0 (L0thread OFF) C endif C out of range values are treated as 0 C C C ICNTL(49): compact workarray id%S before solution phase C must be set before factorization C 0 : nothing is done. C 1 : compact workarray id%S(MAXS) at the end of the C factorization phase while satisfying the C memory contraint that might have been provided C with ICNTL(23) feature. C 2 : compact workarray id%S(MAXS) at the end of the C factorization phase. The memory C constraint that might have been provided with C ICNTL(23) feature does not apply to this process C Other values are treated as 0. C Default value: 0 C C C ICNTL(56) has default value 0 and is only accessed by the host. C During the analysis phase, a positive value prepares the data for C later use of null space functionalities (saved in KEEP(53)). C (the tree is modified to have only one root in analysis) C If ICNTL(56) is negative or zero, null space feature will C be forbidden during the factorization phase. C During the factorization phase, if ICNTL(56) was positive C (KEEP(53)>0) for analysis, then the values of ICNTL(56) (saved C in KEEP(19)) have the following meaning. C 0: No null space analysis, C 1: Null space analysis on last root node using SVD, C 2: Null space analysis on last root node using QR, C C The singular values (ICNTL(56)=1) or the diagonal entries of R C (ICNTL(56)=2) are available in root%SINGULAR_VALUES C C C C ICNTL(58): strategy for symbolic factorization used C with centralized ordering based on METIS (ICNTL(7)=5) C or with given given ordering (ICNTL(7)=1) C C Default value 2 C 1 => SYMBQAMD based symbolic factorization C 2 => Column count based symbolic factorization C Symbolic factorization based on C [GIMP94] "An efficient algorithm to compute row and column C counts for sparse cholesky factorization" C John R. Gilbert, Esmond G. Ng, and Barry W. Peyton C SIMAX 1994 C implementation of the algorithm described in figure 3 C of the [GINP94] article C C Other values are treated as 1 C C========================= C ARRAYS FOR INFORMATION C======================== C C----- C INFO is an INTEGER array of length 80 that need not be C set by the user. C----- C C INFO(1) is zero if the routine is successful, is negative if an C error occurred, and is positive for a warning (see DMUMPS for C a partial documentation and the userguide for a full documentation C of INFO(1)). C C INFO(2) holds additional information concerning the C error (see DMUMPS). C C ------------------------------------------ C Statistics produced after analysis phase C ------------------------------------------ C C INFO(3) Estimated real space needed for factors. C C INFO(4) Estimated integer space needed for factors. C C INFO(5) Estimated maximum frontal size. C C INFO(6) Number of nodes in the tree. C C INFO(7) Minimum value of integer working array IS (old MAXIS) C estimated by the analysis phase C to run the numerical factorization. C C INFO(8) Minimum value of real/complex array S (old MAXS) C estimated by the analysis phase C to run the numerical factorization. C C INFO(15) Estimated size in MBytes of all DMUMPS internal data C structures to run factorization C C INFO(17) provides an estimation (minimum in Megabytes) C of the total memory required to run C the numerical phases out-of-core. C This memory estimation corresponds to C the least memory consuming out-of-core strategy and it can be C used as a lower bound if the user wishes to provide ICNTL(23). C --------------------------------------- C Statistics produced after factorization C --------------------------------------- C INFO(9) Size of the real space used to store the LU factors possibly C including BLR compressed factors C C INFO(10) Size of the integer space used to store the LU factors C C INFO(11) Order of largest frontal matrix. C C INFO(12) Number of off-diagonal pivots in unsymmetric case / C number of negative pivots in symmetric case C C INFO(13) Number of uneliminated variables sent to the father. C C INFO(14) Number of memory compresses. C C INFO(18) On exit to factorization: C Local number of null pivots (ICNTL(24)=1) C on the local processor even on master. C (local size of array PIVNUL_LIST). C Note that it also includes null pivots C that might have been further detected on C the root if ICNTL(56).NE.0. and root C processed by MYID C C INFO(19) - after analysis: C Estimated size of the main internal integer workarray IS C (old MAXIS) to run the numerical factorization out-of-core. C C INFO(21) - after factorization: Effective space used in the main C real/complex workarray S -- or in the workarray WK_USER, C in the case where WK_USER is provided. C C INFO(22) - after factorization: C Size in millions of bytes of memory effectively used during C factorization. C This includes the memory effectively used in the workarray C WK_USER, in the case where WK_user is provided. C C INFO(23) - after factorization: total number of pivots eliminated C on the processor. In the case of a distributed solution (see C ICNTL(21)), this should be used by the user to allocate solution C vectors ISOL_loc and SOL_loc of appropriate dimensions C (ISOL_LOC of size INFO(23), SOL_LOC of size LSOL_LOC * NRHS C where LSOL_LOC >= INFO(23)) on that processor, between the C factorization and solve steps. C C INFO(24) - after analysis: estimated number of entries in factors on C the processor. If negative, then C the absolute value corresponds to {\it millions} of entries C in the factors. C Note that in the unsymmetric case, INFO(24)=INFO(3). C In the symmetric case, however, INFO(24) < INFO(3). C INFO(25) - after factorization: number of tiny pivots (number of C pivots modified by static pivoting) detected on the processor. C INFO(26) - after solution: C effective size in Megabytes of all working space C to run the solution phase. C (The maximum and sum over all processors are returned C respectively in INFOG(30) and INFOG(31)). C INFO(27) - after factorization: effective number of entries in factors C on the processor. If negative, then C the absolute value corresponds to {\it millions} of entries C in the factors. C Note that in the unsymmetric case, INFO(27)=INFO(9). C In the symmetric case, however, INFO(27) < INFO(9). C The total number of entries over all processors is C available in INFOG(29). C C C ------------------------------------------------------------- C ------------------------------------------------------------- C RINFO is a DOUBLE PRECISION/DOUBLE PRECISION array of length 40 that C need not be set by the user. This array supplies C local information on the execution of DMUMPS. C C C RINFOG is a DOUBLE PRECISION/DOUBLE PRECISION array of length 40 that C need not be set by the user. This array supplies C global information on the execution of DMUMPS. C RINFOG is only significant on processor 0 C C C RINFO(1) hold the estimated number of floating-point operations C for the elimination process on the local processor C C RINFOG(1) hold the estimated number of floating-point operations C for the elimination process on all processors C C RINFO(2) Number of floating-point operations C for the assembly process on local processor. C C RINFOG(2) Number of floating-point operations C for the assembly process. C C RINFO(3) Number of floating-point operations C for the elimination process on the local processor. C C RINFOG(3) Number of floating-point operations C for the elimination process on all processors. C C---------------------------------------------------- C Statistics produced after solve with error analysis C---------------------------------------------------- C C RINFOG(4) Infinite norm of the input matrix. C C RINFOG(5) Infinite norm of the computed solution, where C C RINFOG(6) Norm of scaled residuals C C RINFOG(7), `RINFOG(8) and `RINFOG(9) are used to hold information C on the backward error. C We calculate an estimate of the sparse backward error using the C theory and measure developed C by Arioli, Demmel, and Duff (1989). The scaled residual w1 C is calculated for all equations except those C for which numerator is nonzero and the denominator is small. C For the exceptional equations, w2, is used instead. C The largest scaled residual (w1) is returned in C RINFOG(7) and the largest scaled C residual (w2) is returned in `RINFOG(8)>. If all equations are C non exceptional then zero is returned in `RINFOG(8). C The upper bound error is returned in `RINFOG(9). C C RINFOG(14) Number of floating-point operations C for the elimination process (on all fronts, BLR or not) C performed when BLR option is activated on all processors. C (equal to zero if BLR option not used, ICNTL(35).EQ.1) C C RINFOG(15) - after analysis: if the user decides to perform an C out-of-core factorization (ICNTL(22)=1), then a rough C estimation of the total size of the disk space in MegaBytes of C the files written by all processors is provided in RINFOG(15). C C RINFOG(16) - after factorization: in the case of an out-of-core C execution (ICNTL(22)=1), the total C size in MegaBytes of the disk space used by the files written C by all processors is provided. C C RINFOG(17) - after each job: sum over all processors of the sizes C (in MegaBytes) of the files used to save the instance C C RINFOG(18) - after each job: sum over all processors of the sizes C (in MegaBytes) of the MUMPS structures. C C RINFOG(19) - after factorization: smallest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre and considering also C small pivots selected as null-pivots (see ICNTL(24)) C and pivots on which static pivoting was applied C C RINFOG(20) - after factorization: smallest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre and NOT considering C small pivots selected as null-pivots (see ICNTL(24)) C and pivots on which static pivoting was applied C C RINFOG(21) - after factorization: largest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre. C C RINFOG(22) - after factorization: C total number of floating-point operations offloaded to C the accelerator(s) by all MPI processes (see RINFO(9)) C C RINFOG(23) - after factorization: average (over all MPI processes) C time spent in operations offloaded to the accelerators C including communication (see RINFO(10)). C C Computed when solve involves exploit sparsity (fwd and/or bwd) C here we only report off diagonal flops) C #if defined(STAT_ES_SOLVE) C RINFOG(24) - FR FLOPS (off diagonal flops) C RINFOG(25) - FR FLOPS (off diag) with Exploit sparsity C (possibly with nb_sparse algo used) #endif C C C=========================== C DESCRIPTION OF KEEP8 ARRAY C=========================== C C KEEP8 is a 64-bit integer array of length 150 that need not C be set by the user C #if ! defined(NO_SAVE_RESTORE) #endif C=========================== C DESCRIPTION OF KEEP ARRAY C=========================== C C KEEP is an INTEGER array of length 500 that need not C be set by the user. C C C============================= C Description of DKEEP array C============================= C C DKEEP internal control array for DOUBLE PRECISION parameters C of size 30 C=================================== C Default values for control arrays C================================== C uninitialized values should be 0 LWK_USER = 0 KEEP(1:500) = 0 KEEP8(1:150)= 0_8 INFO(1:80) = 0 INFOG(1:80) = 0 ICNTL(1:60) = 0 RINFO(1:40) = 0.0D0 RINFOG(1:40)= 0.0D0 CNTL(1:15) = 0.0D0 DKEEP(1:230) = 0.0D0 C ---------------- C Symmetric code ? C ---------------- KEEP( 50 ) = SYM C ------------------------------------- C Only options 0, 1, or 2 are available C ------------------------------------- IF ( KEEP(50).NE.1 .and. KEEP(50).NE.2 ) KEEP( 50 ) = 0 C threshold value for pivoting C Automatic choice depending on (SYM and ICNTL(56)) CNTL(1) = -1.0D0 CNTL(2) = sqrt(epsilon(0.0D0)) CNTL(3) = 0.0D0 CNTL(4) = -1.0D0 CNTL(5) = 0.0D0 C Working host ? KEEP(46) = PAR IF ( KEEP(46) .NE. 0 .AND. & KEEP(46) .NE. 1 ) THEN C ---------------------- C If out-of-range value, C use a working host C ---------------------- KEEP(46) = 1 END IF C control printing ICNTL(1) = 6 ICNTL(2) = 0 ICNTL(3) = 6 ICNTL(4) = 2 C format of input matrix ICNTL(5) = 0 C maximum transversal (0=NO, 7=automatic) IF (SYM.NE.1) THEN ICNTL(6) = 7 ELSE ICNTL(6) = 0 ENDIF C Ordering option (icntl(7)) C Default is automatic choice done during analysis ICNTL(7) = 7 C ask for scaling (0=NO, 4=Row and Column) C Default value is 77: automatic choice for analysis ICNTL(8) = 77 C solve Ax=b (1) or Atx=b (other values) ICNTL(9) = 1 C Naximum number of IR (0=NO) ICNTL(10) = 0 C Error analysis (0=NO) ICNTL(11) = 0 C Control ordering strategy C automatic choice IF(SYM .EQ. 2) THEN ICNTL(12) = 0 ELSE ICNTL(12) = 1 ENDIF C Control of the use of ScaLAPACK for root node C If null space options asked, ScaLAPACK is always ignored C and ICNTL(13) is not significant C ICNTL(13) = 0 : Root parallelism on (if size large enough) C ICNTL(13) = 1 : Root parallelism off #if defined(NOSCALAPACK) ICNTL(13) = 1 #else ICNTL(13) = 0 #endif C Default value for the memory relaxation IF (SYM.eq.1.AND.NSLAVES.EQ.1) THEN ICNTL(14) = 5 ! it should work with 0 ELSE ICNTL(14) = 20 END IF IF (NSLAVES.GT.4) ICNTL(14) = ICNTL(14) + 5 IF (NSLAVES.GT.8) ICNTL(14) = ICNTL(14) + 5 IF (NSLAVES.GT.16) ICNTL(14)= ICNTL(14) + 5 C Distributed matrix entry ICNTL(18) = 0 C Schur (default is not active) ICNTL(19) = 0 C dense RHS by default ICNTL(20) = 0 C solution vector centralized on host ICNTL(21) = 0 C out-of-core flag ICNTL(22) = 0 C MEM_ALLOWED (0: not provided) ICNTL(23) = 0 C null pivots ICNTL(24) = 0 C blocking factor for multiple RHS during solution phase ICNTL(27) = -32 C analysis strategy: 0=auto, 1=sequential, 2=parallel ICNTL(28) = 1 C tool used for parallel ordering computation : C 0 = auto, 1 = PT-SCOTCH, 2 = ParMETIS ICNTL(29) = 0 C Default BLR compression rate of factors (60%) ICNTL(38) = 600 C Default BLR compression rate of factors (50%) ICNTL(39) = 500 C L0-thread feature #if defined(_OPENMP) C Activate L0OMP ICNTL(48) = 1 #else C Do not activate L0OMP ICNTL(48) = 0 #endif ICNTL(55) = 0 ICNTL(56) = 0 ICNTL(57) = 0 ICNTL(58) = 2 C=================================== C Default values for some components C of KEEP array C=================================== KEEP(12) = 0 KEEP(24) = 18 KEEP(68) = 0 KEEP(30) = 2000 KEEP(36) = 1 KEEP(1) = 5 KEEP(7) = 150 KEEP(8) = 120 KEEP(57) = 2000 KEEP(58) = 1000 IF ( SYM .eq. 0 ) THEN KEEP(4) = 32 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 32 KEEP(9) = 700 KEEP(85) = 300 KEEP(62) = 10 ELSE KEEP(4) = 24 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 32 KEEP(9) = 400 KEEP(85) = 100 KEEP(62) = 10 END IF KEEP(11)=200 KEEP(63) = 60 KEEP(48) = 5 CALL DMUMPS_SET_TYPE_SIZES( KEEP(34), KEEP(149), & KEEP(150), KEEP(10) ) KEEP(35)=KEEP(149) KEEP(16)=KEEP(150) KEEP(151)=KEEP(35) KEEP(51) = 70 KEEP(37) = max(800, int(sqrt(dble(NSLAVES+1))*dble(KEEP(51)))) IF ( NSLAVES > 256 ) THEN KEEP(39) = 10000 ELSEIF ( NSLAVES > 128 ) THEN KEEP(39) = 20000 ELSEIF ( NSLAVES > 64 ) THEN KEEP(39) = 40000 ELSEIF ( NSLAVES > 16 ) THEN KEEP(39) = 80000 ELSE KEEP(39) = 160000 END IF KEEP(40) = -1 - 456789 KEEP(45) = 0 KEEP(47) = 2 KEEP(64) = 20 KEEP(69) = 4 C To disable SMP management when using new mapping strategy C KEEP(69) = 1 C Forcing proportional is ok with strategy 5 KEEP(75) = 1 KEEP(76) = 2 KEEP(77) = 0 KEEP(78)= 0 KEEP(79) = 0 ! old splitting KEEP(210) = 2 KEEP8(79) = -10_8 KEEP(80) = 1 KEEP(81) = 0 IF (SYM.EQ.0) THEN KEEP(82)= 15 ELSE KEEP(82) = 10 ENDIF KEEP(83) = -1 KEEP(86)=1 KEEP(87)=0 KEEP(88)=0 KEEP(90)=1 KEEP(91)= -1 KEEP(102)= -1 #if defined(OLD_OOC_NOPANEL) KEEP(99)=0 ! no panel -> synchronous / no buffer #else KEEP(99)=4 ! new OOC -> asynchronous + buffer #endif KEEP(100)=0 KEEP(114) = 1 C Threshold value for null pîvot detection during C LU factorization on root in case of RR KEEP(118)=41 C strategy for MUMPS_BLOC2_GET_NSLAVESMIN KEEP(119)=0 C Scaling is enabled by default with the Schur complement option KEEP(125)=1 C Columns of LMAT handled by block of size KEEP(147) KEEP(147)=20000 C Control buffer size estimation and minimum granularities: C Try to avoid messages smaller than KEEP(170)/1000 of recv buf C ... minimum number of blocks KEEP(171)=10 C ... buffer size reduction factor with respect to worst case IF (SYM.EQ.0) THEN KEEP(172)= 5 ELSE KEEP(172)= 3 ENDIF KEEP(173)= 0 ! 0 = normal IF (SYM.EQ.0) THEN KEEP(178)= 2 ELSE KEEP(178)= 3 ENDIF KEEP(179)= 10 ! default outer block size increase by factor K179 IF (SYM.EQ.0) THEN KEEP(180) = 80 ! % of KEEP(44) to bound MIN_BUF_SIZE_FR KEEP(181) = 50 ! % of KEEP(44) to bound MIN_BUF_SIZE_BLR ELSE KEEP(180) = 200 ! % of KEEP(44) to bound MIN_BUF_SIZE_FR KEEP(181) = 200 ! % of KEEP(44) to bound MIN_BUF_SIZE_BLR ENDIF C amalgamation: to define sons KEEP(191) larger than fathers KEEP(191)= 50 C amalgamation: to define tiny son nodes C (KEEP(192 smaller than father) KEEP(192)= 900 C to limit the amalgamation of tiny nodes KEEP(193)= 50 C More amalgamation of tiny fronts KEEP(197)=1 C KEEP(199) for MUMPS_PROCNODE, MUMPS_TYPENODE, etc C KEEP(199)=NSLAVES + 7 KEEP(199)=-1 KEEP(200)=0 ! root pre-assembled in id%S C Pre-assemble type 3 root in id%S if no L0-OMP, C allocate id%S later otherwise. KEEP(200) = -1 KEEP(204)=0 KEEP(205)=0 KEEP(209)=-1 KEEP(104) = 16 KEEP(107)=0 KEEP(121)=-999999 KEEP(122)=150 C Size of CB for which we want to force BLR compressCB C even if NASS is small. KEEP(123)=10000 KEEP(141)=1 ! min needed KEEP(206)=1 KEEP(207) = 1 KEEP(211)=2 IF (SYM.EQ.0) THEN KEEP(213) = 301 ELSE KEEP(213) = 401 ENDIF KEEP(217)=0 KEEP(215)=0 KEEP(216)=1 KEEP(218)=250 IF (SYM.EQ.2) THEN KEEP(219)=1 ELSE KEEP(219)=0 ENDIF IF (KEEP(50).EQ.2) THEN KEEP(227)= max(2,32) ELSE KEEP(227)= max(1,32) ENDIF KEEP(231) = 1 KEEP(232) = 3 KEEP(233) = 0 KEEP(239) = 1 KEEP(240) = 10 DKEEP(4) = -1.0D0 DKEEP(5) = -1.0D0 DKEEP(10) = -9D0 ! default value is 10D-1 set in fac_driver.F DKEEP(13) = -9D0 ! to define SEUIL for postponing with RR ! (default value is 10 set in fac_driver.F) DKEEP(24) = 1000.0D0 ! gap should be larger than dkeep(14) DKEEP(25) = 10.0D0 ! gap precision DKEEP(22) = 0.5D0 ! to check for slow convergence KEEP(238)=24 KEEP(234)= 1 KEEP(235)=-1 DKEEP(3) =-5.0D0 DKEEP(18)= 1.0D12 KEEP(242) = -9 KEEP(243) = -1 KEEP(255)=100 C Multithreading of norm1 loop during scaling KEEP(281)=8 KEEP(337) = 1 C Parallel analysis compatible with analysis by blocks C and detection out-of-range KEEP(339)= 1 KEEP(249)=1 !$ KEEP(249) = OMP_GET_MAX_THREADS() KEEP(250) = 1 KEEP(261) = 1 KEEP(262) = 0 KEEP(263) = 1 KEEP(266) = 0 KEEP(267) = 0 KEEP(268)=77 KEEP(350) = 2 KEEP(351) = 1 KEEP(360) = 256 KEEP(361) = 2048 KEEP(362) = 4 KEEP(363) = 512 KEEP(364) = 32768 ! 32KiB KEEP(365) = 1024*1024 ! 1MiB KEEP(366) = 450 KEEP(370) = 1 KEEP(375) = 1 KEEP(378) = 1 C OMP parallelization of arrowheads KEEP(399) = -1 KEEP(397) = -1 KEEP(402) = 1 KEEP(405) = 0 ! 1 under L0OMP KEEP(406) = 2 #if defined(__PGLLVM__) C With aocc version of Classic flang, we want to C avoid an OpenMP bug during L0thread copies by C switching to simpler copy algorithm. C Since we cannot test __aocc__ in Fortran, we rely on the C slower algorithm as soon as __PGLLVM__ is detected, even C if this is "too careful". KEEP(406)=0 #endif C 0.9 equilibration KEEP(408) = 90 KEEP(420) = 4*KEEP(6) ! if KEEP(6)=32 then 128 #if defined(GEMMT_AVAILABLE) KEEP(421) = -1 #if defined(__ve__) KEEP(421) = 650 #endif #endif #if defined(ANA_BLKAUTO) C automatic graph compression effective C only if reduction of the number of nodes C in graph smaller than 75% KEEP(440) = 75 #endif C Default size of KEEP(424) is defined below. C It does not depend on arithmetic, C it is related to L1 cache size: 250 * 64 bytes C is about half of the cache size (32768 bytes). C This leaves space in cache for the destination, C of size 250*sizeof(arith). (4k bytes for z) C At each new block of size KEEP(424), there is C probably a cache miss on the pivot. KEEP(424) = 250 KEEP(448) = 0 KEEP(458)=0 #if defined(__ve__) KEEP(458)=1 #endif KEEP(459) = 10 ! max number of panels KEEP(460) = 63 ! min panel size KEEP(461) = 10 KEEP(462) = 100 KEEP(466) = 1 KEEP(468) = 3 KEEP(469) = 3 KEEP(471) = -1 KEEP(479) = 1 KEEP(480) = 3 KEEP(472) = 1 KEEP(476) = 50 KEEP(477) = 100 KEEP(483) = 80 KEEP(484) = 80 KEEP(487) = 1 IF (KEEP(472).EQ.1) THEN KEEP(488) = 768 ELSE KEEP(488) = 8*KEEP(6) ! if KEEP(6)=32 then 256 ENDIF KEEP(490) = 128 KEEP(491) = 1000 #if defined(__ve__) KEEP(490)=512 KEEP(491)=8000 #endif KEEP(492) = 1 KEEP(493) = 0 KEEP(496) = 1 KEEP(495) = -1 KEEP(497) = -1 C RETURN END SUBROUTINE DMUMPSID SUBROUTINE DMUMPS_SET_KEEP72(id, LP) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE (DMUMPS_STRUC) :: id INTEGER LP IF (id%KEEP(72)==1) THEN id%KEEP(37) = 2*id%NSLAVES id%KEEP(3)=3 id%KEEP(4)=2 id%KEEP(5)=1 id%KEEP(6)=2 id%KEEP(9)=3 C KEEP(11) not too small either id%KEEP(11)=3 id%KEEP(39)=300 id%KEEP(7) = 3 id%KEEP(8) = 2 id%KEEP(57)= 3 id%KEEP(58)= 2 id%KEEP(63)=3 id%CNTL(1)=0.1D0 id%KEEP(213) = 101 id%KEEP(85)=2 id%KEEP(85)=-4 id%KEEP(62) = 2 id%KEEP(1) = 1 id%KEEP(123) = 6 id%KEEP(147) = 3 id%KEEP(197) = 0 id%KEEP(51) = 2 !$ id%KEEP(360) = 2 !$ id%KEEP(361) = 2 !$ id%KEEP(362) = 1 !$ id%KEEP(363) = 2 id%KEEP(364) = 10 id%KEEP(366) = 2 id%KEEP(420) = 4 id%KEEP(488) = 4 id%KEEP(490) = 5 id%KEEP(491) = 5 id%ICNTL(27)=-3 id%KEEP(227)=3 id%KEEP(30) = 1000 C ... Try to avoid messages smaller than KEEP(170)/1000 of recv buf C large value to test deadlock C (no effect with KEEP(173)=1) id%KEEP(170) = 500 ! default is 100 C reduce buffer size estimated during analysis C with respect to message size without SMB mechanism C ... minimum nb of blocks is reduced to stress more buffers id%KEEP(171) = 3 ! default is 10 blocs C ... buffer size factor of reduction is increased C to stress more buffers id%KEEP(172) = 10 ! default is 3 C both values of KEEP(173) should be tested id%KEEP(173) = 1 ! 0=normal 1=force blocking id%KEEP(178) = 1 ! reduce it to one panel for FR LDLT CB buf C ... factor of reduction of CB messages is increased id%KEEP(238) = 36 ! default is 24 ELSE IF (id%KEEP(72)==2) THEN C{ id%KEEP(85)=2 ! default is id%KEEP(85)=-10000 ! default is 160 id%KEEP(210) = 1 ! defaults is 0 (automatic) id%KEEP8(79) = 160000_8 id%KEEP(1) = 2 ! default is 8 id%KEEP(102) = 110 ! defaults is 150 up to 48 procs C reduce buffer size estimated during analysis C with respect to message size without SMB mechanism C ... minimum nb of blocks is reduced to stress more buffers id%KEEP(171) = 3 ! default is 10 blocs C ... buffer size factor of reduction is increased C to stress more buffers id%KEEP(172) = 10 ! default is 3 id%KEEP(213) = 121 ! default is 201 C} END IF RETURN END SUBROUTINE DMUMPS_SET_KEEP72 MUMPS_5.8.1/src/cmumps_struc_def.F0000664000175000017500000000102415042446440016676 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_STRUC_DEF INCLUDE 'cmumps_struc.h' END MODULE CMUMPS_STRUC_DEF MUMPS_5.8.1/src/cfac_mem_stack_aux.F0000664000175000017500000002304415042446440017136 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_COMPACT_FACTORS_SYM(A, LDA, NPIV, NBROW, KEEP, & SIZEA, IW ) IMPLICIT NONE INTEGER, INTENT(IN) :: LDA, NPIV, NBROW INTEGER(8), INTENT(IN) :: SIZEA INTEGER, INTENT(IN) :: IW( NPIV ) INTEGER :: KEEP(500) COMPLEX :: A(SIZEA) INTEGER(8) :: IOLD, INEW, J8 INTEGER I , ILAST INTEGER NBROW_L_RECTANGLE_TO_MOVE INTEGER :: ICOL_BEG, ICOL_END, NBPANELS, NB_TARGET INTEGER :: NBCOLS_PANEL, NBROWS_PANEL INTEGER(8) :: SIZE_COPY LOGICAL :: OMP_FLAG IF ( NPIV .EQ. 0 ) GOTO 500 NB_TARGET = NPIV IF ( KEEP(459) .GT. 1 ) THEN CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, NB_TARGET, KEEP ) ENDIF IF ( NB_TARGET .EQ. NPIV ) THEN IF (LDA.EQ.NPIV) GOTO 500 IOLD = int(LDA + 1,8) INEW = int(NPIV + 1,8) IF (IOLD .EQ. INEW ) THEN WRITE(*,*) " Internal error in CMUMPS_COMPACT_FACTORS", & IOLD, INEW, NPIV CALL MUMPS_ABORT() ENDIF 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 ELSE ICOL_BEG = 1 NBPANELS = 0 INEW = 1_8 NBROWS_PANEL = NPIV DO WHILE ( ICOL_BEG .LE. NPIV ) NBPANELS=NBPANELS + 1 ICOL_END = min(NB_TARGET * NBPANELS, NPIV) IF ( IW( ICOL_END ) < 0 ) THEN ICOL_END = ICOL_END + 1 ENDIF NBCOLS_PANEL = ICOL_END - ICOL_BEG + 1 IOLD = int(ICOL_BEG-1,8) * int(LDA,8) + int(ICOL_BEG,8) DO I =1, NBROWS_PANEL IF (IOLD .NE. INEW) THEN DO J8=0, min(I+1, NBCOLS_PANEL)-1 A(INEW+J8) = A(IOLD+J8) ENDDO ENDIF INEW = INEW + int(NBCOLS_PANEL,8) IOLD = IOLD + int(LDA,8) ENDDO NBROWS_PANEL = NBROWS_PANEL - NBCOLS_PANEL ICOL_BEG = ICOL_END + 1 ENDDO IOLD = 1_8 + int(LDA,8)*int(NPIV,8) ENDIF NBROW_L_RECTANGLE_TO_MOVE = NBROW SIZE_COPY = int(NBROW_L_RECTANGLE_TO_MOVE,8) * int(NPIV,8) OMP_FLAG = SIZE_COPY .GT. int(KEEP(361),8) .AND. KEEP(405).EQ.0 IF (OMP_FLAG &) THEN !$OMP PARALLEL DO COLLAPSE(2) DO I = 0, NBROW_L_RECTANGLE_TO_MOVE-1 DO J8 = 0_8, int(NPIV - 1,8) A( INEW + J8 + int(I,8)*int(NPIV,8) ) = & A( IOLD + J8 + int(I,8)*int(LDA,8)) END DO ENDDO !$OMP END PARALLEL DO ELSE DO I = 0, NBROW_L_RECTANGLE_TO_MOVE-1 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 ENDIF 500 RETURN END SUBROUTINE CMUMPS_COMPACT_FACTORS_SYM SUBROUTINE CMUMPS_COMPACT_FACTORS_UNSYM(A, LDA, NPIV, NCONTIG, & KEEP, SIZEA ) IMPLICIT NONE INTEGER, INTENT(IN) :: NCONTIG, NPIV, LDA INTEGER(8), INTENT(IN) :: SIZEA COMPLEX, INTENT(INOUT) :: A(SIZEA) INTEGER, INTENT(IN) :: KEEP(500) INTEGER I INTEGER(8) :: IDEST, ISRC INTEGER(8) :: J8 INTEGER :: NBLK2COPY INTEGER(8) :: IBLK, NBLK IF (int(NCONTIG,8) * int(NPIV,8) .LE. int(KEEP(361),8) & ) THEN IDEST = int(NPIV+1,8) ISRC = int(LDA+1,8) DO I = 2, NCONTIG DO J8 = 0_8, int(NPIV-1,8) A(IDEST+J8)=A(ISRC+J8) ENDDO ISRC = ISRC + int(LDA,8) IDEST = IDEST + int(NPIV,8) ENDDO ELSE NBLK2COPY = NCONTIG-1 IDEST = int(NPIV+1,8) ISRC = int(LDA+1,8) DO WHILE ( NBLK2COPY .GT. 0 .AND. & ISRC - IDEST .LT. int(max(KEEP(361),NPIV),8) ) DO J8 = 0, int(NPIV-1,8) A(IDEST+J8) = A(ISRC+J8) ENDDO ISRC = ISRC + int(LDA,8) IDEST = IDEST + int(NPIV,8) NBLK2COPY = NBLK2COPY - 1 END DO DO WHILE ( NBLK2COPY .GT. 0 ) NBLK = min( (ISRC - IDEST) / int(NPIV,8), int(NBLK2COPY,8) ) !$OMP PARALLEL DO COLLAPSE(2) DO IBLK = 0_8, NBLK - 1_8 DO J8 = 0_8, int(NPIV-1,8) A( IDEST + J8 + IBLK * int(NPIV,8) ) = & A( ISRC + J8 + IBLK * int(LDA,8) ) ENDDO ENDDO !$OMP END PARALLEL DO NBLK2COPY = NBLK2COPY - int(NBLK) ISRC = ISRC + NBLK * int(LDA,8) IDEST = IDEST + NBLK * int(NPIV,8) ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_COMPACT_FACTORS_UNSYM SUBROUTINE CMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, POSELT, & IPTRLU, NPIV, & NBCOL_STACK, NBROW_STACK, & NBROW_SEND, SIZECB, KEEP, PACKED_CB, & LAST_ALLOWED, NBROW_ALREADY_STACKED ) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: PACKED_CB COMPLEX A(LA) INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND INTEGER, intent(inout) :: NBROW_ALREADY_STACKED INTEGER(8), intent(in) :: LAST_ALLOWED INTEGER(8) :: APOS, NPOS INTEGER NBROW INTEGER(8) :: J INTEGER I, KEEP(500) #if defined(ZERO_TRIANGLE) COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) #endif NBROW = NBROW_STACK + NBROW_SEND IF (NBROW_STACK .NE. 0 ) THEN NPOS = IPTRLU + SIZECB APOS = POSELT + int(NPIV+NBROW,8) & * int(LDA,8) - 1_8 IF ( KEEP(50) .EQ. 0 .OR. .NOT. PACKED_CB ) THEN APOS = APOS - int(LDA,8) * int(NBROW_ALREADY_STACKED,8) NPOS = NPOS & - int(NBCOL_STACK,8) * int(NBROW_ALREADY_STACKED,8) ELSE APOS = APOS - int(LDA - 1,8) * int(NBROW_ALREADY_STACKED,8) NPOS = NPOS - ( int(NBROW_ALREADY_STACKED,8) * & int(NBROW_ALREADY_STACKED+1,8) ) / 2_8 ENDIF DO I = NBROW - NBROW_ALREADY_STACKED, NBROW_SEND+1, -1 IF (KEEP(50).EQ.0) THEN IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. & LAST_ALLOWED ) THEN EXIT ENDIF DO J= 1_8,int(NBCOL_STACK,8) A(NPOS-J+1_8) = A(APOS-J+1_8) ENDDO NPOS = NPOS - int(NBCOL_STACK,8) ELSE IF (.NOT. PACKED_CB) THEN IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. & LAST_ALLOWED ) THEN EXIT ENDIF #if defined(ZERO_TRIANGLE) DO J = 1_8, int(NBCOL_STACK - I,8) A(NPOS - J + 1_8) = ZERO END DO #endif NPOS = NPOS + int(- NBCOL_STACK + I,8) ENDIF IF ( NPOS - int(I,8) + 1_8 .LT. LAST_ALLOWED ) THEN EXIT ENDIF DO J =1_8, int(I,8) A(NPOS-J+1_8) = A(APOS-J+1_8) ENDDO NPOS = NPOS - int(I,8) ENDIF IF (KEEP(50).EQ.0) THEN APOS = APOS - int(LDA,8) ELSE APOS = APOS - int(LDA + 1,8) ENDIF NBROW_ALREADY_STACKED = NBROW_ALREADY_STACKED + 1 ENDDO END IF RETURN END SUBROUTINE CMUMPS_COPY_CB_RIGHT_TO_LEFT SUBROUTINE CMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, POSELT, & IPTRLU, NPIV, & NBCOL_STACK, NBROW_STACK, & NBROW_SEND, SIZECB, KEEP, PACKED_CB) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: PACKED_CB COMPLEX A(LA) INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND INTEGER(8) :: APOS, NPOS, APOS_ini, NPOS_ini INTEGER I, KEEP(500) INTEGER(8) :: J, LDA8 #if defined(ZERO_TRIANGLE) COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) #endif LDA8 = int(LDA,8) NPOS_ini = IPTRLU + 1_8 APOS_ini = POSELT + int(NPIV+NBROW_SEND,8)* LDA8 + int(NPIV,8) !$OMP PARALLEL DO PRIVATE(J, NPOS, APOS) IF (NBROW_STACK > KEEP(360)) DO I = 1, NBROW_STACK IF (PACKED_CB) THEN NPOS = NPOS_ini + int(I-1,8) * int(I,8)/2_8 + & int(I-1,8) * int(NBROW_SEND,8) ELSE NPOS = NPOS_ini + int(I-1,8) * int(NBCOL_STACK,8) ENDIF APOS = APOS_ini + int(I-1,8) * LDA8 IF (KEEP(50).EQ.0) THEN DO J = 1_8, int(NBCOL_STACK,8) A(NPOS+J-1_8) = A(APOS+J-1_8) ENDDO ELSE DO J = 1_8, int(I + NBROW_SEND,8) A(NPOS+J-1_8)=A(APOS+J-1_8) ENDDO #if defined(ZERO_TRIANGLE) IF (.NOT. PACKED_CB) THEN A(NPOS+int(I+NBROW_SEND,8): & NPOS+int(NBCOL_STACK-1,8))=ZERO ENDIF #endif ENDIF ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE CMUMPS_COPY_CB_LEFT_TO_RIGHT MUMPS_5.8.1/src/sol_ds_common_m.F0000664000175000017500000000101715042446423016506 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_SOL_DS_RETURN() RETURN END SUBROUTINE MUMPS_SOL_DS_RETURN MUMPS_5.8.1/src/zfac_asm_master_m.F0000664000175000017500000022560315042446441017022 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_ASM_MASTER_M CONTAINS SUBROUTINE ZMUMPS_FAC_ASM_NIV1( COMM_LOAD, ASS_IRECV, & UU, N, INODE, IW, LIW, A, LA, INFO, ND, & FILS, FRERE, DAD, MAXFRW, root, roota, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, LRLUSM, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, JOBASS, ETATASS & , LRGROUPS & , MUMPS_TPS_ARR, ZMUMPS_TPS_ARR, L0_OMP_MAPPING & ) !$ USE OMP_LIB USE MUMPS_TPS_M USE ZMUMPS_TPS_M USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_PTR, & ZMUMPS_DM_FREE_BLOCK USE MUMPS_BUILD_SORT_INDEX_M USE MUMPS_BUF_COMMON, ONLY: MUMPS_BUF_SEND_MAPLIG USE MUMPS_LOAD USE ZMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE, & ZMUMPS_BLR_ASM_NIV1 USE ZMUMPS_LR_DATA_M, ONLY : ZMUMPS_BLR_INIT_FRONT, & ZMUMPS_BLR_SAVE_NFS4FATHER USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N, NSTEPS INTEGER(8) LA, LRLU, LRLUS, LRLUSM, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) DOUBLE PRECISION UU INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS, LIW TYPE (MUMPS_TPS_T), TARGET, OPTIONAL :: MUMPS_TPS_ARR(:) TYPE (ZMUMPS_TPS_T), TARGET, OPTIONAL :: ZMUMPS_TPS_ARR(:) INTEGER, INTENT(IN), OPTIONAL :: L0_OMP_MAPPING(:) INTEGER IDUMMY(1) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER, TARGET :: IW(LIW) INTEGER(8), INTENT(IN) :: PTRARW(1), PTRAIW(1) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ITLOC(N+KEEP(253)), & ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)), & PAMASTER(KEEP(28)) INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER JOBASS,ETATASS LOGICAL SON_LEVEL2 COMPLEX(kind=8), TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR COMPLEX(kind=8) DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) LOGICAL PACKED_CB, IS_CB_LR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF LOGICAL LPOK INTEGER NBPANELS_L, NBPANELS_U INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER(8) NFRONT8, LAELL8, LAELL_REQ8, ITMP8, KEEP8TMPCOPY INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER LREQ_OOC INTEGER :: SON_XXS, SON_XXLR, SON_XXG INTEGER(8) LSTK8, SIZFR8 LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM, IORG, IBROT INTEGER IARR1 #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER JPOS,ICT11 INTEGER IJROW,NBCOL,NUMORG,IOLDPS INTEGER(8) IACHK, POSELT, LAPOS2, IACHK_ini INTEGER(8) APOS, APOS2, APOS3, POSEL1, ICT12 INTEGER(8) :: JJ2, ICT13 INTEGER(8) :: J18, J28, J38, J48, JJ8 INTEGER(8) :: AINPUT8 INTEGER :: K1, K2, K3, KK, KK1 INTEGER :: J253 INTEGER NSLAVES, NSLSON, NPIVS,NPIV_ANA,NPIV INTEGER PTRCOL, ISLAVE, PDEST,LEVEL INTEGER ISON_IN_PLACE LOGICAL SKIP_TOP_STACK INTEGER ISON_TOP INTEGER(8) SIZE_ISON_TOP8, DYN_SIZE_ISON_TOP8 LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE !$ LOGICAL OMP_PARALLEL_FLAG LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE INTEGER INDX, FIRST_INDEX, SHIFT_INDEX INTEGER PARPIV_T1 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: ITHREAD INTEGER, POINTER :: SON_IWPOS, SON_LIW INTEGER, POINTER, DIMENSION(:) :: SON_IW COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTEGER PIVOT_OPTION COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER NELT, LPTRAR EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR LOGICAL SSARBR DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR !$ NOMP = OMP_GET_MAX_THREADS() LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) NELT = 1 LPTRAR = 1 NFS4FATHER = -1 PACKED_CB = .FALSE. IS_CB_LR = .FALSE. IN = INODE LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (LEVEL.NE.1) THEN WRITE(*,*) 'INTERNAL ERROR 1 in ZMUMPS_FAC_ASM_NIV1 ' CALL MUMPS_ABORT() END IF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) IF (JOBASS.EQ.0) THEN ETATASS= 0 ELSE ETATASS= 2 IOLDPS = PTLUST(STEP(INODE)) NFRONT = IW(IOLDPS + KEEP(IXSZ)) NASS1 = abs(IW(IOLDPS + 2 + KEEP(IXSZ))) ICT11 = IOLDPS + HF - 1 + NFRONT SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 ISON = FRERE(STEP(ISON)) ENDDO ENDIF GOTO 123 ENDIF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) END DO NPIV_ANA=NUMORG NSTEPS = NSTEPS + 1 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 SON_IW => IW IF (KEEP(400).GT.0) THEN IF (present(L0_OMP_MAPPING)) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .NE.0) THEN SON_IW=>MUMPS_TPS_ARR(ITHREAD)%IW ENDIF ENDIF ENDIF NASS = NASS + SON_IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG CALL IS_FRONT_BLR_CANDIDATE(INODE, 1, ND(STEP(INODE)), & NUMORG, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, KEEP(280), LRGROUPS) IF (DAD(STEP(INODE)).NE.0) THEN IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199) ) & .NE. MYID & .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199)) & .EQ.1 & ) THEN IF (LRSTATUS.EQ.1 .OR. LRSTATUS.EQ.3) THEN LRSTATUS = LRSTATUS-1 ENDIF ENDIF ENDIF COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_OOC_GET_PP_SIZES(KEEP(50), NFRONT, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL ZMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, SLAVEF, & PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'INTERNAL ERROR 2 after compress ' WRITE(LP, * ) 'IN ZMUMPS_FAC_ASM_NIV1 ' WRITE(LP, * ) 'LRLU,LRLUS=', LRLU,LRLUS ENDIF GOTO 270 END IF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 END IF IOLDPS = IWPOS IWPOS = IWPOS + LREQ ISON_TOP = -9999 ISON_IN_PLACE = -9999 SIZE_ISON_TOP8 = 0_8 IF (KEEP(234).NE.0) THEN IF ( IWPOSCB .NE. LIW ) THEN IF ( IWPOSCB+IW(IWPOSCB+1+XXI).NE.LIW) THEN ISON = IW( IWPOSCB + 1 + XXN ) IF ( DAD( STEP( ISON ) ) .EQ. INODE .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)),KEEP(199)) & .EQ. 1 ) & THEN ISON_TOP = ISON CALL MUMPS_GETI8(SIZE_ISON_TOP8,IW(IWPOSCB + 1 + XXR)) CALL MUMPS_GETI8(DYN_SIZE_ISON_TOP8, IW(IWPOSCB + 1 + XXD)) IF (DYN_SIZE_ISON_TOP8 .EQ. 0_8) THEN IF (LRLU .LT. int(NFRONT,8) * int(NFRONT,8)) THEN ISON_IN_PLACE = ISON ENDIF ENDIF END IF END IF END IF END IF NIV1 = .TRUE. IF (.NOT. present(MUMPS_TPS_ARR).AND. & .NOT. present(L0_OMP_MAPPING) ) THEN CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP, KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, IDUMMY, LIDUMMY ) ELSE CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP, KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, IDUMMY, LIDUMMY & , MUMPS_TPS_ARR, L0_OMP_MAPPING ) ENDIF IF (INFO(1).LT.0) GOTO 300 IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL MUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1-FLOP1_EFF, & KEEP,KEEP8) ENDIF IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) ' INTERNAL ERROR 3 ', & ' IN ZMUMPS_FAC_ASM_NIV1 ', & ' NFRONT, NFRONT_EFF = ', & NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF NCB = NFRONT - NASS1 MAXFRW = max(MAXFRW, NFRONT) ICT11 = IOLDPS + HF - 1 + NFRONT CALL ZMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) PIVOT_OPTION = KEEP(468) IF (UU.EQ.ZERO) THEN PIVOT_OPTION=0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF(PARPIV_T1.NE.0) THEN LAELL8 = LAELL8+int(NASS1,8) ENDIF LAELL_REQ8 = LAELL8 IF ( ISON_IN_PLACE > 0 ) THEN LAELL_REQ8 = LAELL8 - SIZE_ISON_TOP8 ENDIF SKIP_TOP_STACK = (ISON_IN_PLACE.GT.0) CALL ZMUMPS_GET_SIZE_NEEDED & (0, LAELL_REQ8, SKIP_TOP_STACK, & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 LRLUSM = min( LRLUS, LRLUSM ) ITMP8 = LAELL8 - SIZE_ISON_TOP8 IF (KEEP(405).EQ.0) THEN KEEP8(69) = KEEP8(69) + ITMP8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + ITMP8 KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ENDIF POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8-SIZE_ISON_TOP8, & KEEP,KEEP8, & LRLUS) IF (KEEP(405).EQ.0) KEEP(429)= KEEP(429)+1 #if defined(ZERO_TRIANGLE) LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) !$ CHUNK8=int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (LAPOS2 - POSELT + 1_8 > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8), KEEP(218))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & NCB, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1,TOPDIAG) ENDIF IF (ETATASS.EQ.1) THEN IF (KEEP(234).NE.0) THEN WRITE(*,*) & "Internal error: ETATASS.EQ.1 and IN-PLACE ACTIVATED" CALL MUMPS_ABORT() ENDIF #if defined(__ve__) !NEC$ IVDEP #endif !$ CHUNK = max( KEEP(360)/2, (NFRONT+NOMP-1) / NOMP ) !$OMP PARALLEL DO PRIVATE(APOS, JJ3) SCHEDULE( STATIC, CHUNK ) !$OMP& IF (NFRONT8 - 1_8 > KEEP(360)) DO JJ8 = 0_8, NFRONT8 - 1_8 JJ3 = min(JJ8+TOPDIAG,int(NASS1-1,8)) APOS = POSELT + JJ8 * NFRONT8 A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO ELSE NUMROWS = min(NFRONT8, (IPTRLU-POSELT) / NFRONT8 ) !$ CHUNK = max(KEEP(360)/2, !$ & ( ((int(NUMROWS)+NOMP-1) / NOMP + 2) / 3) ) #if defined(__ve__) !NEC$ IVDEP #endif !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK ) !$OMP& IF (int(NUMROWS - 1) .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = POSELT + JJ8 * NFRONT8 JJ3 = min( NFRONT8 - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS + JJ3) = ZERO ENDDO !$OMP END PARALLEL DO IF( NUMROWS .LT. NFRONT8 ) THEN APOS = POSELT + NFRONT8*NUMROWS A(APOS : min(IPTRLU,APOS+NUMROWS)) = ZERO ENDIF ENDIF END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS IW(IOLDPS + KEEP(IXSZ)) = NFRONT IW(IOLDPS + KEEP(IXSZ)+ 1) = 0 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN CALL ZMUMPS_BLR_INIT_FRONT (IW(IOLDPS+XXF), INFO, & MTK405=KEEP(405)) IF (INFO(1).LT.0) GOTO 500 ENDIF ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL ZMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) CALL ZMUMPS_BLR_SAVE_NFS4FATHER ( IW(IOLDPS+XXF), & ESTIM_NFS4FATHER_ATSON ) IF (INFO(1).LT.0) GOTO 500 ENDIF ENDIF ENDIF 123 CONTINUE IF (NUMSTK.NE.0) THEN IF (ISON_TOP > 0) THEN ISON = ISON_TOP ELSE ISON = IFSON ENDIF DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_LIW => LIW SON_IWPOS => IWPOS SON_A => A ITHREAD = 0 IF (KEEP(400).GT.0) THEN IF (present(L0_OMP_MAPPING)) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .NE.0) THEN SON_LIW => MUMPS_TPS_ARR(ITHREAD)%LIW SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW SON_IWPOS => MUMPS_TPS_ARR(ITHREAD)%IWPOS SON_A => ZMUMPS_TPS_ARR(ITHREAD)%A ENDIF ENDIF ENDIF LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + KEEP(IXSZ) + 1) NPIVS = SON_IW(ISTCHK + KEEP(IXSZ) + 3) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = SON_IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.SON_IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT = PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT = ISTCHK ENDIF SON_XXS = SON_IW(ISTCHK_CB_RIGHT+XXS) SON_XXLR = SON_IW(ISTCHK_CB_RIGHT+XXLR) SON_XXG = SON_IW(ISTCHK_CB_RIGHT+XXG) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IS_CB_LR = ( SON_XXLR.EQ.1 .OR. SON_XXLR.EQ.3 ) & .AND. (KEEP(489).EQ.1.OR.KEEP(489).EQ.3) LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = SON_IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF K1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN K2 = K1 + LSTK - 1 IF (PACKED_CB) THEN SIZFR8 = (LSTK8*(LSTK8+1_8)/2_8) ELSE SIZFR8 = LSTK8*LSTK8 ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * LSTK8 ELSE IF (PACKED_CB) THEN SIZFR8 = int(NELIM,8) * int(NELIM+1,8)/2_8 ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) ENDIF END IF K2 = K1 + NELIM - 1 ENDIF IF (JOBASS.EQ.0) THEN IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + LSTK8*LSTK8 ELSE OPASSW = OPASSW + LSTK8*(LSTK8+1)/2_8 ENDIF ELSE IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + int(NELIM,8)*LSTK8 ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM,8)/2_8 ENDIF ENDIF ENDIF CALL MUMPS_GETI8(DYN_SIZE, SON_IW(ISTCHK_CB_RIGHT+XXD)) IS_DYNAMIC_CB = DYN_SIZE .GT. 0_8 IF ( IS_DYNAMIC_CB ) THEN CALL ZMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) ENDIF IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (NFRONT .EQ. LSTK.AND. ISON.EQ.ISON_IN_PLACE & .AND.IACHK + SIZFR8 - 1_8 .EQ. POSFAC - 1_8 ) THEN GOTO 205 ENDIF IF (K2.GE.K1) THEN RESET_TO_ZERO = (IACHK .LT. POSFAC .AND. & ISON.EQ.ISON_IN_PLACE) RISK_OF_SAME_POS = IACHK + SIZFR8 - 1_8 .EQ. POSFAC - 1_8 & .AND. ISON.EQ.ISON_IN_PLACE RISK_OF_SAME_POS_THIS_LINE = .FALSE. IACHK_ini = IACHK !$ OMP_PARALLEL_FLAG = (RESET_TO_ZERO.EQV..FALSE.).AND. !$ & ((K2-K1).GT.KEEP(360)) !$OMP PARALLEL IF(OMP_PARALLEL_FLAG) PRIVATE(APOS, KK1, JJ2,IACHK) !$OMP& FIRSTPRIVATE(RISK_OF_SAME_POS_THIS_LINE,RESET_TO_ZERO) !$OMP DO DO 170 KK = K1, K2 APOS = POSEL1 + int(SON_IW(KK),8) * int(NFRONT,8) IACHK = IACHK_ini + int(KK-K1,8)*int(LSTK,8) IF (RESET_TO_ZERO) THEN IF (RISK_OF_SAME_POS) THEN IF (KK.EQ.K2) THEN RISK_OF_SAME_POS_THIS_LINE = & (ISON .EQ. ISON_IN_PLACE) & .AND. ( APOS + int(SON_IW(K1+LSTK-1)-1,8).EQ. & IACHK+int(LSTK-1,8) ) ENDIF ENDIF IF ((IACHK .GE. POSFAC).AND.(KK>K1))THEN RESET_TO_ZERO =.FALSE. ENDIF IF (RISK_OF_SAME_POS_THIS_LINE) THEN DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1 + KK1 - 1) - 1,8) IF ( IACHK+int(KK1-1,8) .NE. JJ2 ) THEN A(JJ2) = A(IACHK + int(KK1 - 1,8)) A(IACHK + int(KK1 -1,8)) = ZERO ENDIF ENDDO ELSE #if defined(__ve__) !NEC$ IVDEP #endif DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(IACHK + int(KK1 - 1,8)) A(IACHK + int(KK1 -1,8)) = ZERO ENDDO ENDIF ELSE #if defined(__ve__) !NEC$ IVDEP #endif DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) ENDDO ENDIF 170 CONTINUE !$OMP END DO !$OMP END PARALLEL END IF ELSE IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (ISON .EQ. ISON_IN_PLACE) THEN CALL ZMUMPS_LDLT_ASM_NIV12_IP(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB) ELSE IF (SIZFR8 .GT. 0) THEN CALL ZMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF ENDIF IF (IS_CB_LR .AND. LEVEL1) THEN POSEL1 = PTRAST(STEP(INODE)) CALL ZMUMPS_BLR_ASM_NIV1 (A, LA, & POSEL1, NFRONT, NASS1, SON_IW(ISTCHK+XXF), & SON_IW, SON_LIW, & LSTK, NELIM, K1, K1+LSTK-1, KEEP(50), & KEEP, KEEP8, OPASSW) ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF ((SAME_PROC).AND.ETATASS.NE.1) THEN IF (KEEP(50).NE.0) THEN K2 = K1 + LSTK - 1 #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K1, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO ELSE K2 = K1 + LSTK - 1 K3 = K1 + NELIM #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K3, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO IF (NELIM .NE. 0) THEN K3 = K3 - 1 #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K1, K3 JPOS = SON_IW(KK) + ICT11 SON_IW(KK) = IW(JPOS) ENDDO ENDIF ENDIF ENDIF IF (ETATASS.NE.1) THEN IF ( SAME_PROC ) THEN PTRIST(STEP(ISON)) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF IF (ITHREAD .EQ. 0) THEN CALL ZMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & (ISON .EQ. ISON_TOP) & ) ELSE CALL MUMPS_LOAD_DISABLE() CALL ZMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & MUMPS_TPS_ARR(ITHREAD)%IW(1), & MUMPS_TPS_ARR(ITHREAD)%LIW, & MUMPS_TPS_ARR(ITHREAD)%LRLU, & MUMPS_TPS_ARR(ITHREAD)%LRLUS, & MUMPS_TPS_ARR(ITHREAD)%IPTRLU, & MUMPS_TPS_ARR(ITHREAD)%IWPOSCB, & MUMPS_TPS_ARR(ITHREAD)%LA, KEEP,KEEP8, .FALSE. & ) CALL MUMPS_LOAD_ENABLE() ENDIF IF (IS_DYNAMIC_CB) THEN CALL ZMUMPS_DM_FREE_BLOCK(SON_XXG, & SON_A, SIZFR8, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF ELSE PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP, KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL ZMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, IDUMMY, & NFRONT, NASS1, NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & IZERO, IDUMMY, IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP, KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE., LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) IF (ISON .LE. 0) THEN ISON = IFSON ENDIF 220 CONTINUE END IF IF (ETATASS.EQ.2) GOTO 500 POSELT = PTRAST(STEP(INODE)) IBROT = INODE IARR1 = PTRDEBARR(STEP(INODE)) DO 260 IORG = 1, NUMORG AINPUT8 = PTR8ARR(IARR1+IORG-1) J18 = AINPUT8 J28 = J18 + NINCOLARR(IARR1+IORG-1) J38 = J28 + 1 J48 = J28 + NINROWARR(IARR1+IORG-1) IJROW = INTARR(J18) ICT12 = POSELT + int(IJROW - NFRONT - 1,8) #if defined(__ve__) IF ( KEEP(265).NE. 0 ) THEN !NEC$ IVDEP #endif DO JJ8 = J18, J28 APOS2 = ICT12 + int(INTARR(JJ8),8) * NFRONT8 A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + 1_8 ENDDO #if defined(__ve__) ELSE DO JJ8 = J18, J28 APOS2 = ICT12 + int(INTARR(JJ8),8) * NFRONT8 A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + 1_8 ENDDO ENDIF #endif IF (J38 .LE. J48) THEN ICT13 = POSELT + int(IJROW - 1,8) * NFRONT8 NBCOL = int(J48 - J38 + 1_8) #if defined(__ve__) IF ( KEEP(265) .NE. 0 ) THEN !NEC$ IVDEP #endif DO JJ8 = 1_8, int(NBCOL,8) APOS3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8) - 1_8,8) A(APOS3) = A(APOS3) + DBLARR(AINPUT8 + JJ8 - 1_8) ENDDO #if defined(__ve__) ELSE DO JJ8 = 1_8, int(NBCOL,8) APOS3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8) - 1_8,8) A(APOS3) = A(APOS3) + DBLARR(AINPUT8 + JJ8 - 1_8) ENDDO ENDIF #endif ENDIF IF (KEEP(50).EQ.0) THEN DO J253=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ELSE DO J253=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+J253-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE IF (PARPIV_T1.NE.0.AND.(.NOT.SON_LEVEL2)) THEN IOLDPS = PTLUST(STEP(INODE)) CALL ZMUMPS_PARPIVT1_SET_NVSCHUR_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1, NASS) ENDIF GOTO 500 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING ZMUMPS_FAC_ASM' ENDIF GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING ZMUMPS_FAC_ASM' ENDIF INFO(1) = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, RECV BUFFER TOO SMALL DURING ZMUMPS_FAC_ASM' ENDIF INFO(1) = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF( INFO(1).EQ.-13 ) THEN IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING ZMUMPS_FAC_ASM' ENDIF INFO(2) = NUMSTK + 1 ENDIF 490 CONTINUE IF ( KEEP(405) .EQ. 0 ) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_ASM_NIV1 SUBROUTINE ZMUMPS_FAC_ASM_NIV2(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, INFO, & ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, roota, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, MEM_DISTRIB & , LRGROUPS & ) !$ USE OMP_LIB USE MUMPS_BUILD_SORT_INDEX_M USE MUMPS_BUF_COMMON, ONLY: MUMPS_BUF_SEND_MAPLIG, & MUMPS_BUF_SEND_DESC_BANDE USE MUMPS_LOAD USE ZMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_PTR, & ZMUMPS_DM_IS_DYNAMIC USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC, LA INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE, MAXFRW, LPOOL, LEAF, & IWPOS, IWPOSCB, COMP, SLAVEF COMPLEX(kind=8), TARGET :: A(LA) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(1), PTRAIW(1) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PROCNODE_STEPS(KEEP(28)), BUFR(LBUFR) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR COMPLEX(kind=8) DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INTEGER LP, HS, HF, HF_OLD, NCBSON, NSLAVES_OLD LOGICAL LPOK INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL COMPLEX(kind=8), DIMENSION(:), POINTER :: SON_A INTEGER :: MAXWASTEDPROCS PARAMETER (MAXWASTEDPROCS=1) INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER I INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER :: SON_XXS INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL PACKED_CB, IS_CB_LR INTEGER(8) :: LCB LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER MP INTEGER :: K1, K2, KK, KK1 INTEGER :: J253 INTEGER(8) :: AINPUT8, J18, J28, J38, J48, JJ8 INTEGER(8) :: LAPOS2, JJ2, JJ3 INTEGER(8) :: ICT13 INTEGER(8) :: IACHK, APOS, APOS2, POSELT, ICT12, POSEL1 #if ! defined(ZERO_TRIANGLE) INTEGER :: TOPDIAG #endif !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM,NPIVS,NCOLS,NROWS, & IORG INTEGER LDAFS, LDA_SON, IJROW, IBROT INTEGER IARR1 INTEGER NBCOL,NUMORG,IOLDPS, NUMORG_SPLIT INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, PDEST INTEGER PDEST1(1) INTEGER :: ISLAVE INTEGER TYPESPLIT INTEGER ISON_IN_PLACE LOGICAL IS_ofType5or6, SPLIT_MAP_RESTART INTEGER NMB_OF_CAND, NMB_OF_CAND_ORIG LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER IZERO INTEGER IDUMMY(1) PARAMETER( IZERO = 0 ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT COMPLEX(kind=8) ZERO DOUBLE PRECISION RZERO PARAMETER( RZERO = 0.0D0 ) PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER NELT, LPTRAR logical :: force_cand INTEGER ETATASS INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX DOUBLE PRECISION MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER, ALLOCATABLE, DIMENSION(:) :: SONROWS_PER_ROW INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IS_ofType5or6 = .FALSE. PACKED_CB = .FALSE. ETATASS = 0 IN = INODE NSTEPS = NSTEPS + 1 KEEP(429) = KEEP(429)+1 NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON NCBSON_MAX = 0 NELT = 1 LPTRAR = 1 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 IF ( KEEP(48)==5 .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) ENDIF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 CALL IS_FRONT_BLR_CANDIDATE(INODE, 2, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, KEEP(280), LRGROUPS) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then force_cand=.FALSE. ELSE force_cand=(mod(KEEP(24),2).eq.0) end if TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) SPLIT_MAP_RESTART = .FALSE. IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) NMB_OF_CAND = CAND( SLAVEF+1, INIV2 ) NMB_OF_CAND_ORIG = NMB_OF_CAND SIZE_TMP_SLAVES_LIST = NMB_OF_CAND IF (IS_ofType5or6) THEN DO I=NMB_OF_CAND+1,SLAVEF IF ( CAND( I, INIV2 ).LT.0) EXIT NMB_OF_CAND = NMB_OF_CAND +1 ENDDO SIZE_TMP_SLAVES_LIST = NSLSON-1 IF (INODE.EQ.-999999) THEN SPLIT_MAP_RESTART = .TRUE. ENDIF ENDIF IF (IS_ofType5or6.AND.SPLIT_MAP_RESTART) THEN TYPESPLIT = 4 IS_ofType5or6 = .FALSE. SIZE_TMP_SLAVES_LIST = NMB_OF_CAND CAND (SLAVEF+1, INIV2) = SIZE_TMP_SLAVES_LIST ENDIF ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 NMB_OF_CAND = SLAVEF - 1 NMB_OF_CAND_ORIG = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF IF ( (TYPESPLIT.EQ.4) & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) & ) THEN IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) IF (SPLIT_MAP_RESTART) THEN IS_ofType5or6 = .TRUE. TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) CAND( SLAVEF+1, INIV2 ) = NMB_OF_CAND_ORIG ENDIF ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) IF (KEEP(376) .EQ. 1) THEN NFRONT = IW( PIMASTER(STEP(IFSON)) + KEEP(IXSZ)) ENDIF CALL MUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND(1,INIV2), NMB_OF_CAND_ORIG, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES, & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST & ) ENDIF ELSE CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_OOC_GET_PP_SIZES(KEEP(50), NASS1, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL ZMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & LRLUS,KEEP(IXSZ), & COMP, DKEEP(97), MYID, SLAVEF, & PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress ZMUMPS_FAC_ASM_NIV2 ', & 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. ALLOCATE(SONROWS_PER_ROW(NFRONT-NASS1), stat=allocok) IF (allocok > 0) THEN GOTO 275 ENDIF ISON_IN_PLACE = -9999 CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP,KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, SONROWS_PER_ROW, & NFRONT-NASS1 ) IF (INFO(1).LT.0) GOTO 250 IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN WRITE(*,*) ' Internal error 1 in fac_ass due to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF WRITE(*,*) ' SPLITTING NOT YET READY FOR THAT' CALL MUMPS_ABORT() ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN NCB = NFRONT_EFF - NASS1 NSLAVES_OLD = NSLAVES HF_OLD = HF IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP, KEEP8, ICNTL, & CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - & (NSLAVES_OLD - NSLAVES) IF (NSLAVES_OLD .NE. NSLAVES) THEN IF (NSLAVES_OLD > NSLAVES) THEN DO KK=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+KK)=IW(IOLDPS+HF_OLD+KK) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO KK=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+KK) = IW(IOLDPS+HF_OLD+KK) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) MYID,': INTERNAL ERROR 2 ', & ' IN ZMUMPS_FAC_ASM_NIV2 , INODE=', & INODE, ' NFRONT, NFRONT_EFF=', NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max(MAXFRW, NFRONT) PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+KEEP(IXSZ)) = NFRONT IW(IOLDPS + 1+KEEP(IXSZ)) = 0 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+NSLAVES+KEEP(IXSZ))= & TMP_SLAVES_LIST(1:NSLAVES) ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL ZMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) ENDIF ENDIF ENDIF CALL MUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM_LOAD, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP, KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) IF(KEEP(86).EQ.1)THEN IF(mod(KEEP(24),2).eq.0)THEN CALL MUMPS_LOAD_SEND_MD_INFO(SLAVEF, & CAND(SLAVEF+1,INIV2), & CAND(1,INIV2), & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN CALL MUMPS_LOAD_SEND_MD_INFO(SLAVEF, & SLAVEF-1, & TMP_SLAVES_LIST, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ENDIF ENDIF DEALLOCATE(TMP_SLAVES_LIST) IF (KEEP(50).EQ.0) THEN LAELL8 = int(NASS1,8) * int(NFRONT,8) LDAFS = NFRONT ELSE LAELL8 = int(NASS1,8)*int(NASS1,8) IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) & LAELL8 = LAELL8+int(NASS1,8) LDAFS = NASS1 ENDIF CALL ZMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= LRSTATUS IW(IOLDPS+XXG) = MemNotPinned CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8,LRLUS) POSEL1 = POSELT - int(LDAFS,8) #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8 = int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (LAPOS2 - POSELT > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO JJ8 = POSELT, LAPOS2 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max(KEEP(360)/2, !$ & ( (( LDAFS + NOMP -1 ) / NOMP + 2) / 3) ) APOS = POSELT #if defined(__ve__) !NEC$ IVDEP #endif !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK) !$OMP& IF (LDAFS - 1 .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(LDAFS-1,8) APOS = POSELT + JJ8 * int(LDAFS,8) JJ3 = min( int(LDAFS,8) - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) A(APOSMAX:APOSMAX+int(LDAFS-1,8))=ZERO ENDIF END IF #endif IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) IF (NELIM.EQ.0) GOTO 210 LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT=PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT=ISTCHK ENDIF SON_XXS = IW(ISTCHK_CB_RIGHT + XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF IF (KEEP(50).EQ.0) THEN LDA_SON = LSTK LCB = int(NELIM,8)*int(LSTK,8) ELSE IF (NSLSON.EQ.0) THEN IF (SAME_PROC) THEN IS_CB_LR = IW(ISTCHK_CB_RIGHT+XXLR).EQ. 1 .OR. & IW(ISTCHK_CB_RIGHT+XXLR).EQ. 3 IF (IS_CB_LR) THEN LDA_SON = NELIM ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = NELIM ENDIF IF (PACKED_CB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN OPASSW = OPASSW + dble(LCB) ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM+1,8)/2_8 ENDIF IS_DYNAMIC_CB = & ZMUMPS_DM_IS_DYNAMIC(IW(ISTCHK_CB_RIGHT+XXD: & ISTCHK_CB_RIGHT+XXD+1)) IF ( IS_DYNAMIC_CB ) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_CB_RIGHT+XXD)) CALL ZMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) SON_A=>A ENDIF K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IF (KEEP(50).eq.0) THEN IF (IS_ofType5or6) THEN APOS = POSELT DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + SON_A(IACHK+JJ8-1_8) ENDDO ELSE DO 170 KK = K1, K2 APOS = POSEL1 + int(IW(KK),8) * int(LDAFS,8) DO 160 KK1 = 1, LSTK JJ2 = APOS + int(IW(K1 + KK1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (LCB .GT. 0) THEN CALL ZMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF IBROT = INODE APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) IARR1 = PTRDEBARR(STEP(INODE)) DO 260 IORG = 1, NUMORG AINPUT8 = PTR8ARR(IARR1+IORG-1) J18 = AINPUT8 J28 = J18 + NINCOLARR(IARR1+IORG-1) J38 = J28 + 1_8 J48 = J28 + NINROWARR(IARR1+IORG-1) IJROW = INTARR(J18) ICT12 = POSELT + int(IJROW - 1 - LDAFS, 8) MAXARR = RZERO DO JJ8 = J18, J28 IF (KEEP(219).NE.0) THEN IF (INTARR(JJ8).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ8),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) ELSEIF (KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AINPUT8))) ENDIF ELSE IF (INTARR(JJ8).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ8),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) ENDIF ENDIF AINPUT8 = AINPUT8 + 1_8 ENDDO IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(IJROW-1,8)) = cmplx(MAXARR,kind=kind(A)) ENDIF IF (J38 .GT. J48) GOTO 255 ICT13 = POSELT + int(IJROW - 1,8) * int(LDAFS,8) NBCOL = int(J48 - J38 + 1_8) DO JJ8 = 1_8, int(NBCOL,8) JJ3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8),8) - 1_8 A(JJ3) = A(JJ3) + DBLARR(AINPUT8 + JJ8 - 1_8) ENDDO 255 CONTINUE IF (KEEP(50).EQ.0) THEN DO J253 = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & NBLIG, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 IERR = -1 DO WHILE (IERR .EQ.-1) IF ( KEEP(50) .eq. 0 ) THEN NBCOL = NFRONT CALL MUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL MUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF ENDDO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 ENDDO DEALLOCATE(SONROWS_PER_ROW) IF (NUMSTK.EQ.0) GOTO 500 ISON = IFSON DO IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + 2 + KEEP(IXSZ) ) ELSE NROWS = NCOLS ENDIF PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN NFS4FATHER = NCBSON DO I=0,NCBSON-1 IF(IW(PTRCOL+I) .GT. NASS1) THEN NFS4FATHER = I EXIT ENDIF ENDDO NFS4FATHER = NFS4FATHER + NELIM ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) IF (PDEST1(1).EQ.MYID) THEN CALL ZMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & NFRONT, NASS1, NFS4FATHER, NCBSON, IW( PTRCOL ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, roota, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, PDEST1, NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, & NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL ZMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & NFRONT, NASS1,NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), INFO(2), & MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, LPTRAR, NELT, IW, & IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(2) = NUMSTK + 1 ENDIF GOTO 490 245 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING COPY_CAND', & ' DURING ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = SLAVEF+1 GOTO 490 265 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING ZMUMPS_FAC_ASM_NIV2' ENDIF GOTO 490 275 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING SONROWS_PER_ROW', & ' DURING ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = NFRONT-NASS1 GOTO 490 290 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (1) DURING ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (1) DURING ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (2)', &' DURING ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (2)', &' DURING ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -20 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 490 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_ASM_NIV2 END MODULE ZMUMPS_FAC_ASM_MASTER_M MUMPS_5.8.1/src/zmumps_iXamax.F0000664000175000017500000000543515042446441016211 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C INTEGER FUNCTION ZMUMPS_IXAMAX(N,X,INCX,GRAIN) !$ USE OMP_LIB IMPLICIT NONE COMPLEX(kind=8), intent(in) :: X(*) INTEGER, intent(in) :: INCX,N INTEGER, intent(in) :: GRAIN DOUBLE PRECISION ABSMAX INTEGER :: I INTEGER(8) :: IX !$ INTEGER :: NOMP, CHUNK !$ INTEGER :: IMAX !$ DOUBLE PRECISION :: XMAX, VALABS !$ DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 !$ NOMP = OMP_GET_MAX_THREADS() ZMUMPS_IXAMAX = 0 IF ( N.LT.1 ) RETURN ZMUMPS_IXAMAX = 1 IF ( N.EQ.1 .OR. INCX.LE.0 ) RETURN !$ IF (NOMP.GT.1 .AND. N.GE.GRAIN*2) THEN !$ IF ( INCX.EQ.1 ) THEN !$ CHUNK = max(GRAIN,(N+NOMP-1)/NOMP) !$ ABSMAX = RZERO !$OMP PARALLEL PRIVATE(I, VALABS, XMAX, IMAX) !$OMP& FIRSTPRIVATE(N, CHUNK) !$ XMAX = RZERO !$OMP DO SCHEDULE(static, CHUNK) !$ DO I = 1, N !$ VALABS = abs(X(I)) !$ IF ( VALABS .GT. XMAX ) THEN !$ XMAX = VALABS !$ IMAX = I !$ ENDIF !$ ENDDO !$OMP END DO !$ IF (XMAX .GT. RZERO) THEN !$OMP CRITICAL !$ IF (XMAX .GT. ABSMAX) THEN !$ ZMUMPS_IXAMAX = IMAX !$ ABSMAX = XMAX !$ ENDIF !$OMP END CRITICAL !$ ENDIF !$OMP END PARALLEL !$ ELSE !$ CHUNK = max(GRAIN,(N+NOMP-1)/NOMP) !$ ABSMAX = RZERO !$OMP PARALLEL PRIVATE(I, VALABS, XMAX, IMAX, IX) !$OMP& FIRSTPRIVATE(N, CHUNK, INCX) !$ XMAX = RZERO !$OMP DO SCHEDULE(static, CHUNK) !$ DO I = 1, N !$ IX = 1 + int((I-1),8)*int(INCX,8) !$ VALABS = abs(X(IX)) !$ IF ( VALABS .GT. XMAX ) THEN !$ XMAX = VALABS !$ IMAX = I !$ ENDIF !$ ENDDO !$OMP END DO !$ IF (XMAX .GT. RZERO) THEN !$OMP CRITICAL !$ IF (XMAX .GT. ABSMAX) THEN !$ ZMUMPS_IXAMAX = IMAX !$ ABSMAX = XMAX !$ ENDIF !$OMP END CRITICAL !$ ENDIF !$OMP END PARALLEL !$ ENDIF !$ ELSE IF ( INCX.EQ.1 ) THEN ABSMAX = abs(X(1)) DO I = 2, N IF ( abs(X(I)) .LE. ABSMAX ) CYCLE ZMUMPS_IXAMAX = I ABSMAX = abs(X(I)) ENDDO ELSE IX = 1 ABSMAX = abs(X(1)) IX = IX + INCX DO I = 2, N IF ( abs(X(IX)).LE.ABSMAX ) GOTO 5 ZMUMPS_IXAMAX = I ABSMAX = abs(X(IX)) 5 IX = IX + INCX ENDDO ENDIF !$ ENDIF RETURN END FUNCTION ZMUMPS_IXAMAX MUMPS_5.8.1/src/zfac_front_LU_type1.F0000664000175000017500000012401315042446441017216 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC1_LU_M CONTAINS SUBROUTINE ZMUMPS_FAC1_LU( & N, INODE, IW, LIW, A, & LA, & IOLDPS, POSELT, IFLAG, IERROR, UU, & NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, & IWPOS & , LRGROUPS & , PERM & ) USE ZMUMPS_FAC_FRONT_AUX_M USE ZMUMPS_OOC USE ZMUMPS_FAC_LR USE ZMUMPS_LR_TYPE USE MUMPS_LR_STATS USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_DATA_M USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T #if ! defined(BLR_NOOPENMP) #endif !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, INTENT(INOUT) :: NOFFW, NPVW, NBTINYW INTEGER, INTENT(INOUT) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), INTENT(INOUT) :: DET_MANTW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER MYID, SLAVEF, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ), STEP(N) DOUBLE PRECISION UU, SEUIL LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)), PERM(N) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER LAST_ROW, LAST_COL, FIRST_COL LOGICAL CALL_LTRSM, CALL_UTRSM DOUBLE PRECISION UUTEMP LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC INTEGER PIVOT_OPTION INTEGER LRTRSM_OPTION INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U INTEGER TYPEF_LOC TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PARPIV_T1 INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER :: K473_LOC INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER INFO_TMP(2), MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM, NELIM_LOC INTEGER :: IROW_L, NVSCHUR INTEGER, POINTER, DIMENSION(:) :: PTDummy INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_U, BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL COMPLEX(kind=8), POINTER, DIMENSION(:) :: DIAG INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, LorU, I, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG CHARACTER(len=1) :: DIR COMPLEX(kind=8), ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) COMPLEX(kind=8), ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok,J INTEGER :: OMP_NUM INTEGER :: IP INTEGER(8) :: UPOS, LPOS INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_U, NEXT_BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC COMPLEX(kind=8) :: ZERO PARAMETER (ZERO=(0.0D0,0.0D0)) LOGICAL :: SWAP_OCCURRED INCLUDE 'mumps_headers.h' FIRST_BLOCK = -99999 LAST_BLOCK = -99999 IP=0 IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF SWAP_OCCURRED = .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 PIVOT_OPTION = KEEP(468) LRTRSM_OPTION = KEEP(475) LAFAC = -9999_8 XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) NASS = abs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED = .FALSE. COMPRESS_PANEL = .FALSE. COMPRESS_CB = .FALSE. NULLIFY(PTDummy) NULLIFY(BEGS_BLR) NULLIFY(CB_LRB) NULLIFY(ACC_LUA) NULLIFY(BLR_U) NULLIFY(BLR_L) NULLIFY(BEGS_BLR_TMP) NULLIFY(BLR_PANEL) NULLIFY(DIAG) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN K473_LOC = 1 ELSE K473_LOC = KEEP(473) ENDIF K473_LOC = KEEP(473) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL ZMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS, KEEP, & LR_ACTIVATED, PARPIV_T1) IF (UUTEMP.EQ.ZERO) THEN PIVOT_OPTION=0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF IF (LR_ACTIVATED) THEN IF (LRTRSM_OPTION.EQ.3) THEN PIVOT_OPTION = MIN(PIVOT_OPTION,1) ELSEIF (LRTRSM_OPTION.EQ.2) THEN PIVOT_OPTION = MIN(PIVOT_OPTION, 2) ENDIF ENDIF IF (PIVOT_OPTION.LE.1) THEN PARPIV_T1 = 0 ENDIF CALL ZMUMPS_SET_INNERBLOCKSIZE( NBKJIB_ORIG, NASS, KEEP) IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = IOLDPS+6+XSIZE+NASS CALL ZMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF ( OOC_EFFECTIVE_ON_FRONT ) THEN LNextPiv2beWritten = 1 UNextPiv2beWritten = 1 PP_FIRST2SWAP_L = LNextPiv2beWritten PP_FIRST2SWAP_U = UNextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%LastPanelWritten_U = 0 PP_LastPIVRPTRFilled_L = 0 PP_LastPIVRPTRFilled_U = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 1 MonBloc%NROW = NFRONT MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -88877 NULLIFY(MonBloc%INDICES) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(405) .EQ. 1) THEN !$OMP ATOMIC UPDATE CNT_NODES = CNT_NODES + 1 !$OMP END ATOMIC ELSE CNT_NODES = CNT_NODES + 1 ENDIF ELSE IF (KEEP(486).NE.0) THEN ENDIF OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472), & NFRONT, KEEP(1)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 490 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL ZMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .FALSE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF IF (COMPRESS_CB) THEN IF (NPARTSCB.GT.0) THEN allocate(CB_LRB(NPARTSCB,NPARTSCB),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSCB*NPARTSCB GOTO 490 ENDIF CALL ZMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF ENDIF DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = BEGS_BLR(CURRENT_BLR+1)-1 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(480).GE.5) THEN IF (CURRENT_BLR.EQ.1) THEN ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR) THEN BLR_U(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) BLR_L(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ELSE IF (NB_BLR.GT.CURRENT_BLR) THEN CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF IF (CURRENT_BLR.LT.NPARTSASS) THEN ALLOCATE(NEXT_BLR_U(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF ALLOCATE(NEXT_BLR_L(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR+1) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR+1, NEXT_BLR_U, 0) CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR+1, NEXT_BLR_L, 0) ENDIF ENDIF ELSE ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE CALL ZMUMPS_FAC_I(NFRONT,NASS,NFRONT, & IBEG_BLOCK,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, & DKEEP(1), PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1 & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF ELSE IF ( INOPV.LE.0 ) THEN INOPV = 0 IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL ZMUMPS_FAC_MQ(IBEG_BLOCK, IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED & ) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) THEN GOTO 50 ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_U, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL ZMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, & NPIV, NFRONT, IEND_BLR, LAST_COL, & A, LA, POSELT, & -66666, & .TRUE., .FALSE., .TRUE., & .FALSE., & LR_ACTIVATED & ) ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN IF (PIVOT_OPTION.EQ.4) THEN LAST_ROW = NFRONT ELSE LAST_ROW = NASS ENDIF IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSE LAST_COL = NASS ENDIF IF (IEND_BLR.LT.LAST_ROW) THEN CALL ZMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, LAST_ROW, LAST_COL, & A, LA, POSELT, IEND_BLR, .TRUE., (PIVOT_OPTION.LT.2), & .TRUE., .FALSE., & LR_ACTIVATED) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_U(J)%M=0 BLR_U(J)%N=0 BLR_U(J)%K=0 BLR_U(J)%ISLR=.FALSE. NULLIFY(BLR_U(J)%Q) NULLIFY(BLR_U(J)%R) ENDDO CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) NULLIFY(BLR_L) NULLIFY(BLR_U) IF (KEEP(480).GE.2 .AND. IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = 1 ELSE FIRST_BLOCK = NPARTSASS-CURRENT_BLR ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL ZMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) IF (IFLAG.LT.0) GOTO 900 CALL ZMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) 900 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF ENDIF GOTO 100 ENDIF IF (PIVOT_OPTION.GE.3) THEN FIRST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN FIRST_COL = NASS ELSE FIRST_COL = IEND_BLR ENDIF IF (LRTRSM_OPTION.EQ.3) THEN LAST_COL = IEND_BLR ELSEIF (LRTRSM_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = NFRONT ENDIF CALL_LTRSM = (LRTRSM_OPTION.EQ.0) CALL_UTRSM = (LAST_COL-FIRST_COL.GT.0) IF ((IEND_BLR.LT.NFRONT) .AND. & (CALL_LTRSM.OR.CALL_UTRSM)) THEN CALL ZMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NFRONT, & LAST_COL, & A, LA, POSELT, & FIRST_COL, CALL_LTRSM, & CALL_UTRSM, .FALSE., & .FALSE., & LR_ACTIVATED) ENDIF #if ! defined(BLR_NOOPENMP) #endif #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(UPOS,LPOS) FIRSTPRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), & KEEP(458), K473_LOC, & BLR_U, CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), & KEEP(458), K473_LOC, BLR_L, & CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER !$OMP MASTER #endif IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (LRTRSM_OPTION.GT.0) THEN CALL ZMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NB_BLR, 1, 0, 0, .FALSE.) IF (PIVOT_OPTION.LT.3.AND.LRTRSM_OPTION.GE.2) THEN IF (PIVOT_OPTION.LE.1.AND.LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF CALL ZMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, NB_BLR, BLR_U, & CURRENT_BLR, FIRST_BLOCK, NB_BLR, & 1, 0, 1, .FALSE.) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif CALL ZMUMPS_BLR_UPD_NELIM_VAR_U( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_U, NB_BLR, & FIRST_BLOCK, IBEG_BLR, NPIV, NELIM) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(480).GE.2) THEN UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) LPOS = POSELT+int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) CALL ZMUMPS_BLR_UPD_NELIM_VAR_L(A, LA, UPOS, A, LA, & LPOS, IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & CURRENT_BLR+1, NELIM, 'N') IF (IFLAG.LT.0) GOTO 444 IF (IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = 1 ELSE FIRST_BLOCK = NPARTSASS-CURRENT_BLR ENDIF CALL ZMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) IF (IFLAG.LT.0) GOTO 442 CALL ZMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) 442 CONTINUE ENDIF 444 CONTINUE ELSE CALL ZMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & BLR_U, NB_BLR, & NELIM,.FALSE., 0, & 1, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(486).NE.2) THEN LAST_BLOCK = NB_BLR ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF IF (LRTRSM_OPTION.GT.0) THEN FIRST_BLOCK = CURRENT_BLR+1 CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_L, CURRENT_BLR, 'V', 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) #if ! defined(BLR_NOOPENMP) #endif ENDIF IF (LRTRSM_OPTION.GE.2) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_U, CURRENT_BLR, 'H', 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL(BLR_U, NB_BLR-CURRENT_BLR, KEEP8, & KEEP(34)) CALL DEALLOC_BLR_PANEL(BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & KEEP(34)) DEALLOCATE(BLR_U,BLR_L) ENDIF ENDIF NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN IF (PIVOT_OPTION.LT.4) THEN TYPEF_LOC = TYPEF_U ELSE TYPEF_LOC = TYPEF_BOTH_LU ENDIF MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_LOC, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO IP=1,NB_BLR+1 BEGS_BLR_TMP(IP) = BEGS_BLR_STATIC(IP) ENDDO ENDIF ENDIF MEM_TOT = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP& PRIVATE(IP, LorU, DIR, NELIM_LOC, BLR_PANEL) #endif IF ( & (KEEP(486).EQ.2) & ) THEN #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*(2*DIAGSIZ_STA-DIAGSIZ_DYN) MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA IF (I.LE.DIAGSIZ_DYN) THEN DIAG(DPOS:DPOS+DIAGSIZ_STA-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_STA-1,8)) DPOS = DPOS + DIAGSIZ_STA ELSE DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN ENDIF POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL ZMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG, KEEP(34)) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO !$OMP SINGLE #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM_TOT,8), & (KEEP(405).NE.0), KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 447 IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN DO IP=1,NPARTSASS NELIM_LOC = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) DO LorU=0,1 CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8, & KEEP(34)) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (LorU.EQ.0) THEN DIR = 'V' ELSE DIR = 'H' ENDIF CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(458), K473_LOC, & BLR_PANEL, IP, & DIR, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM_LOC, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif 445 CONTINUE ENDIF 447 CONTINUE ENDIF IF (IFLAG .LT. 0) GOTO 450 IF (KEEP(480) .GE. 2) THEN #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif CALL ZMUMPS_BLR_UPD_CB_LEFT(A, LA, POSELT, NFRONT, & BEGS_BLR_STATIC, BEGS_BLR_STATIC, & NPARTSCB, NPARTSCB, NPARTSASS, NASS, & IW(IOLDPS+XXF), & 1, .FALSE., IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & ACC_LUA, KEEP(480),KEEP(479),KEEP(478),KEEP(476), & KEEP(484), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & .FALSE., & CB_LRB, KEEP8) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF IF (IFLAG.LT.0) GOTO 450 #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF (COMPRESS_CB & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL ZMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (COMPRESS_CB) THEN IEND_BLR = BEGS_BLR(CURRENT_BLR+2) IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) ENDIF ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (COMPRESS_CB) THEN CALL ZMUMPS_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR, NPARTSCB, NPARTSCB, NPARTSASS, & NFRONT-NASS, NFRONT-NASS, INODE, & IW(IOLDPS+XXF), 0, 1, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & -9999, -9999, -9999, KEEP(1), & NELIM=NELIM) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF 450 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF ( & ( & (KEEP(486).EQ.2) & ) & .AND.UU.GT.0 .AND. SWAP_OCCURRED & ) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 0, NASS-NPIV) DO IP=1,NPARTSASS DO LorU=0,1 CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NB_BLR-IP & ) ENDDO ENDDO CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NPIV, 0, 1) ENDIF IF ( (PIVOT_OPTION.LT.4) .AND. (.NOT.LR_ACTIVATED) ) THEN CALL ZMUMPS_FAC_FR_UPDATE_CBROWS( INODE, & NFRONT, NASS, (PIVOT_OPTION.LT.3), A, LA, LAFAC, POSELT, & IW, LIW, IOLDPS, MonBloc, MYID, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR ) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 0, 1) ENDIF ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF CALL ZMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 490 CONTINUE 500 CONTINUE 600 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(WORK)) deallocate(WORK) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) deallocate(TAU) IF (allocated(JPVT)) deallocate(JPVT) IF (allocated(BLOCK)) deallocate(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) ENDDO ENDIF DEALLOCATE(ACC_LUA) NULLIFY(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL ZMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 2, & KEEP8, KEEP(34)) ENDIF ENDIF IF ( LR_ACTIVATED .AND. KEEP(486).EQ. 2 .AND. & KEEP(251) .EQ. 2) THEN CALL ZMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8, KEEP(34)) ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND. .NOT.COMPRESS_CB) THEN CALL ZMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34), MTK405=KEEP(405)) ENDIF ENDIF NPVW = NPVW + IW(IOLDPS+1+XSIZE) RETURN END SUBROUTINE ZMUMPS_FAC1_LU END MODULE ZMUMPS_FAC1_LU_M SUBROUTINE ZMUMPS_FAC1_LU_I( N, INODE, IW, LIW, A, & LA, & IOLDPS, POSELT, IFLAG, IERROR, UU, & NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, & IWPOS & , LRGROUPS & , PERM & ) USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T USE ZMUMPS_FAC1_LU_M, ONLY: ZMUMPS_FAC1_LU IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, INTENT(INOUT) :: NOFFW, NPVW, NBTINYW INTEGER, INTENT(INOUT) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), INTENT(INOUT) :: DET_MANTW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER MYID, SLAVEF, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ), STEP(N) DOUBLE PRECISION UU, SEUIL LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)), PERM(N) CALL ZMUMPS_FAC1_LU( N, INODE, IW, LIW, A, & LA, & IOLDPS, POSELT, IFLAG, IERROR, UU, & NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, & IWPOS & , LRGROUPS & , PERM & ) RETURN END SUBROUTINE ZMUMPS_FAC1_LU_I MUMPS_5.8.1/src/cana_aux_par.F0000664000175000017500000044367215042446440016000 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_PARALLEL_ANALYSIS USE CMUMPS_STRUC_DEF USE MUMPS_MEMORY_MOD USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T, COMPACT_GRAPH_T INCLUDE 'mpif.h' PUBLIC CMUMPS_ANA_F_PAR INTERFACE CMUMPS_ANA_F_PAR MODULE PROCEDURE CMUMPS_ANA_F_PAR END INTERFACE PRIVATE TYPE ORD_TYPE INTEGER :: CBLKNBR, N INTEGER, POINTER :: PERMTAB(:) => null() INTEGER, POINTER :: PERITAB(:) => null() INTEGER, POINTER :: RANGTAB(:) => null() INTEGER, POINTER :: TREETAB(:) => null() INTEGER, POINTER :: BROTHER(:) => null() INTEGER, POINTER :: SON(:) => null() INTEGER, POINTER :: NW(:) => null() INTEGER, POINTER :: FIRST(:) => null() INTEGER, POINTER :: LAST(:) => null() INTEGER, POINTER :: TOPNODES(:) => null() INTEGER :: COMM, NPROCS, MYID, & COMM_PARAORD, NPROCS_PARAORD, MYID_PARAORD, & RKinSYMB_PROC0ORD INTEGER :: TOPSTRAT, SUBSTRAT, ORDTOOL, TOPVARS LOGICAL :: IDO END TYPE ORD_TYPE TYPE GRAPH_TYPE INTEGER(8) :: NZ_LOC INTEGER, POINTER :: IRN_LOC(:) => null() INTEGER, POINTER :: JCN_LOC(:) => null() END TYPE GRAPH_TYPE TYPE ARRPNT INTEGER, POINTER :: BUF(:) => null() END TYPE ARRPNT INTEGER :: MP, MPG, LP, NRL, TOPROWS INTEGER(8) :: MEMCNT, MAXMEM LOGICAL :: PROK, PROKG, LPOK INTEGER N, NORIG CONTAINS SUBROUTINE CMUMPS_ANA_F_PAR(id, WORK1, WORK2, LWORK1, LWORK2, & NFSIZ, FILS, & FRERE, COMM_PARASYMB, LUMAT, SIZEOFBLOCKS, & COMM_PARAORD, NPROCS_PARAORD, & RKinSYMB_PROC0ORD) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id INTEGER, TARGET :: WORK1(:), WORK2(:) INTEGER(8), INTENT(IN) :: LWORK1, LWORK2 #if defined(MUMPS_NOF2003) INTEGER, POINTER :: FILS(:) #else INTEGER, ALLOCATABLE :: FILS(:) #endif INTEGER, POINTER :: NFSIZ(:), FRERE(:) INTEGER, INTENT(IN) :: COMM_PARASYMB TYPE(LMATRIX_T), OPTIONAL :: LUMAT INTEGER, INTENT(IN), TARGET, OPTIONAL :: SIZEOFBLOCKS(id%NBLK) INTEGER, INTENT(IN), OPTIONAL :: COMM_PARAORD, & NPROCS_PARAORD, & RKinSYMB_PROC0ORD 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 DOUBLE PRECISION :: TIMEB INTEGER HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & NBSONS_Scalapack_CAND INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR INTEGER, TARGET :: IDUMMY_ARRAY(1) INTEGER :: LSIZEOFBLOCKS_PTR LOGICAL :: SIZEOFBLOCKS_AVAIL nullify(IPE, NV, NE, NA, NODE, ND, SUBORD, NAMALG, IPS, & CUMUL, SAVEIRN, SAVEJCN) CALL MPI_COMM_RANK (COMM_PARASYMB, MYID, IERR) CALL MPI_COMM_SIZE (COMM_PARASYMB, NPROCS, IERR) NORIG = id%N IF (id%KEEP(339).NE.0) THEN N = id%NBLK ELSE N = NORIG ENDIF ord%N = N LP = id%ICNTL(1) MP = id%ICNTL(2) MPG = id%ICNTL(3) PROK = (MP.GT.0) PROKG = (MPG.GT.0) .AND. (MYID .EQ. 0) LPOK = (LP.GT.0) .AND. (id%ICNTL(4).GE.1) LDIAG = id%ICNTL(4) IF (present(SIZEOFBLOCKS)) THEN SIZEOFBLOCKS_PTR => SIZEOFBLOCKS(1:N) LSIZEOFBLOCKS_PTR = N SIZEOFBLOCKS_AVAIL = .TRUE. ELSE SIZEOFBLOCKS_PTR => IDUMMY_ARRAY SIZEOFBLOCKS_AVAIL = .FALSE. LSIZEOFBLOCKS_PTR = 1 IDUMMY_ARRAY(1) = -1 ENDIF IF (PROKG) THEN WRITE(MPG,'(A,I10)') & " Parallel analysis, processing a graph of size:", N ENDIF IF (id%KEEP(339).GT.0) THEN IF (.NOT.present(LUMAT) .OR. .NOT. present(SIZEOFBLOCKS)) THEN IF (PROK) THEN WRITE(MP,*) MYID, " Internal error in CMUMPS_ANA_F_PAR" ENDIF id%INFO(1) = -9991 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM_PARASYMB, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN ENDIF IF (id%KEEP(339).GT.0) THEN MEMCNT = MEMCNT + LUMAT%NZL + LUMAT%NBCOL_LOC + 3 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ENDIF CALL CMUMPS_SET_PAR_ORD(id, COMM_PARASYMB, MYID, NPROCS, & ord, COMM_PARAORD, NPROCS_PARAORD, & RKinSYMB_PROC0ORD) IF ( LWORK1 .LT. 3_8 *int(N,8) ) THEN WRITE(LP,*) & 'Insufficient workspace in CMUMPS_ANA_F_PAR' CALL MUMPS_ABORT() ENDIF IF ( ord%COMM .NE. MPI_COMM_NULL ) THEN ord%PERMTAB => WORK1( 1 : N) ord%PERITAB => WORK1( int(N,8)+1_8 : 2_8*int(N,8)) ord%TREETAB => WORK1(2_8*int(N,8)+1_8 : 3_8*int(N,8)) ENDIF IF ( id%KEEP(54) .NE. 3 ) THEN IF(MYID.EQ.0) THEN SAVEIRN => id%IRN_loc SAVEJCN => id%JCN_loc id%IRN_loc => id%IRN id%JCN_loc => id%JCN id%KEEP8(29) = id%KEEP8(28) ELSE id%KEEP8(29)=0_8 END IF END IF MAXMEM=0 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT id%INFOG(7) = id%KEEP(245) IF (PROKG) CALL MUMPS_SECDEB( TIMEB ) IF (id%KEEP(339).GT.0) THEN CALL CMUMPS_DO_PAR_ORD(id, MYID, NPROCS, & ord, WORK2, LWORK2, LUMAT, SIZEOFBLOCKS) ELSE CALL CMUMPS_DO_PAR_ORD(id, MYID, NPROCS, & ord, WORK2, LWORK2) ENDIF IF (PROKG) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE(MPG, & '(" ELAPSED time in parallel ordering =",F12.4)') & TIMEB ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF(ord%MYID .EQ. 0) THEN CALL MUMPS_REALLOC(IPE, N, id%INFO, LP, FORCE=.FALSE., & COPY=.FALSE., STRING='', & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, N, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT END IF ord%SUBSTRAT = 0 ord%TOPSTRAT = 0 IF (id%KEEP(339).NE.0) THEN CALL CMUMPS_PARSYMFACT_LUMAT(id, ord, IPE, NV, & WORK2, LWORK2, LUMAT, & SIZEOFBLOCKS) ELSE CALL CMUMPS_PARSYMFACT(id, ord, IPE, NV, WORK2, LWORK2) ENDIF IF(id%KEEP(54) .NE. 3) THEN IF(ord%MYID.EQ.0) THEN id%IRN_loc => SAVEIRN id%JCN_loc => SAVEJCN END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN NULLIFY(ord%PERMTAB) NULLIFY(ord%PERITAB) NULLIFY(ord%TREETAB) CALL MUMPS_IDEALLOC(ord%FIRST, ord%LAST, MEMCNT=MEMCNT) IF (MYID .EQ. 0) THEN IPS => WORK1(1:N) NE => WORK1( int(N,8)+1_8 : 2_8*int(N,8)) NA => WORK1(2_8*int(N,8)+1_8 : 3_8*int(N,8)) NODE => WORK2( 1 : N ) ND => WORK2( int(N,8)+1_8 : 2_8*int(N,8)) SUBORD => WORK2(2_8*int(N,8)+1_8 : 3_8*int(N,8)) NAMALG => WORK2(3_8*int(N,8)+1_8 : 4_8*int(N,8)) CALL MUMPS_REALLOC(CUMUL, N, id%INFO, LP, & STRING='CUMUL', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT NEMIN = id%KEEP(1) CALL CMUMPS_ANA_LNEW(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%KEEP(197), & id%NSLAVES, id%KEEP(250).EQ.1, SIZEOFBLOCKS_AVAIL, & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, & INODE_Scalapack_CAND, NBSONS_Scalapack_CAND, & id%KEEP(11), id%KEEP(191), id%KEEP(192), id%KEEP(193)) CALL MUMPS_DEALLOC(CUMUL, NV, IPE, MEMCNT=MEMCNT) CALL CMUMPS_ANA_M(NE(1), ND(1), id%INFOG(6), id%INFOG(5), & id%KEEP(2), id%KEEP(50), id%KEEP8(101), id%KEEP(108), & id%KEEP(5), id%KEEP(6), id%KEEP(226), id%KEEP(253)) IF ( id%KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT(N, FRERE(1), FILS(1), NFSIZ(1), & id%KEEP(20)) INODE_Scalapack_CAND = id%KEEP(20) NBSONS_Scalapack_CAND = 1 END IF IF ( (id%KEEP(48) == 4 .AND. id%KEEP8(21).GT.0_8) & .OR. & (id%KEEP (48)==5 .AND. id%KEEP8(21) .GT. 0_8 ) & .OR. & (id%KEEP(24).NE.0.AND.id%KEEP8(21).GT.0_8) ) THEN CALL CMUMPS_SET_K821_SURFACE(id%KEEP8(21), id%KEEP(2), & id%KEEP(48), id%KEEP(50), id%NSLAVES) END IF IF (id%KEEP(210).LT.1.OR.id%KEEP(210).GT.2) id%KEEP(210)=2 IF (id%KEEP(210).EQ.2) id%KEEP8(79)=huge(id%KEEP8(79)) IF (id%KEEP(210).EQ.1.AND.id%KEEP8(79).LE.0_8) THEN id%KEEP8(79)=K79REF * int(id%NSLAVES,8) ENDIF IF (id%KEEP(11).EQ.0) THEN IF ( (id%KEEP(79).EQ.0).OR.(id%KEEP(79).EQ.2).OR. & (id%KEEP(79).EQ.3).OR.(id%KEEP(79).EQ.5).OR. & (id%KEEP(79).EQ.6) & ) THEN IF (id%KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( id%KEEP(62).GE.1) THEN CALL CMUMPS_CUTNODES(N, FRERE(1), FILS(1), & NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, 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 ENDIF HOW_TO_SPLIT_ROOT = 0 SPLITROOT = id%ICNTL(13) .EQ. -1 #if defined(NOSCALAPACK) SPLITROOT = SPLITROOT .OR. id%NSLAVES.GT.0 #else SPLITROOT = SPLITROOT .OR. & (id%ICNTL(13).GT.0 .AND. id%NSLAVES.GT.id%ICNTL(13)) #endif IF (SPLITROOT.AND.id%KEEP(11).GT.0) HOW_TO_SPLIT_ROOT =1 IF (id%KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. IF (id%KEEP(11).GT.0) HOW_TO_SPLIT_ROOT = 2 ENDIF #if defined(NOSCALAPACK) #else IF ( id%KEEP(11).GT.0 .AND. (id%KEEP(339).NE.0) ) THEN IF (.NOT.SPLITROOT .AND. & (id%KEEP(60).EQ.0).AND. & ( (NFSIZ(INODE_Scalapack_CAND).GT.id%KEEP(37)) & .AND.(id%ICNTL(13).LE.0) ) & .AND. & (NBSONS_Scalapack_CAND.GT.id%KEEP(11)) & ) THEN HOW_TO_SPLIT_ROOT = 3 SPLITROOT=.TRUE. ENDIF ENDIF #endif SPLITROOT = (SPLITROOT.AND.( (id%KEEP(60).EQ.0) )) IF (SPLITROOT) THEN IF (id%KEEP(339).EQ.0) THEN CALL CMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, id%INFOG(6), & id%NSLAVES, id%KEEP(1), id%KEEP8(1), & SPLITROOT, MP, LDIAG, id%INFOG(1), id%INFOG(2)) ELSE IF (id%KEEP(11).EQ.0) THEN CALL CMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, 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 IF ( id%KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT(N, FRERE(1), FILS(1), NFSIZ(1), & id%KEEP(20)) END IF ELSE CALL CMUMPS_SPLIT_ROOT( id%NSLAVES, & HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & N, FRERE(1), FILS(1), NFSIZ(1), & id%KEEP(1), id%KEEP8(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, & id%INFOG(6)) END IF END IF ENDIF END IF RETURN END SUBROUTINE CMUMPS_ANA_F_PAR SUBROUTINE CMUMPS_SET_PAR_ORD(id, COMM_PARASYMB, MYID, NPROCS, & ord, & COMM_PARAORD, NPROCS_PARAORD, RKinSYMB_PROC0ORD) TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, INTENT(IN) :: COMM_PARASYMB, MYID, NPROCS INTEGER, INTENT(IN), OPTIONAL :: COMM_PARAORD, NPROCS_PARAORD, & RKinSYMB_PROC0ORD INTEGER :: IERR #if defined(parmetis) || defined(parmetis3) INTEGER :: I INTEGER :: COLOR, BASE, WORKERS LOGICAL :: IDO #endif IF (id%KEEP(339).GT.0) THEN ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%COMM = COMM_PARASYMB ord%MYID = MYID ord%NPROCS = NPROCS ord%COMM_PARAORD = COMM_PARAORD ord%RKinSYMB_PROC0ORD = RKinSYMB_PROC0ORD ord%NPROCS_PARAORD = NPROCS_PARAORD ord%IDO = (COMM_PARAORD.NE.MPI_COMM_NULL) IF (ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ELSE ord%MYID_PARAORD = -1 ENDIF IF (id%KEEP(245) .EQ. 1) THEN #if defined(ptscotch) ord%ORDTOOL = 1 IF(PROKG) WRITE(MPG, & '(" Using PT-SCOTCH for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(ord%MYID .EQ.0 ) WRITE(LP, & '(" PT-SCOTCH not available")') RETURN #endif ELSE IF (id%KEEP(245) .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) ord%ORDTOOL = 2 IF(PROKG) WRITE(MPG, & '(" Using ParMETIS for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(ord%MYID .EQ.0 ) WRITE(LP, & '(" ParMETIS not available.")') RETURN #endif END IF ELSE ord%NPROCS = NPROCS ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%COMM = COMM_PARASYMB ord%MYID = MYID ord%RKinSYMB_PROC0ORD = NPROCS-id%NSLAVES 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%COMM_PARAORD = id%COMM_NODES ord%NPROCS_PARAORD = id%NSLAVES ord%IDO = (ord%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1) IF (ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ELSE ord%MYID_PARAORD = -1 ENDIF IF(PROKG) WRITE(MPG, & '(" Using PT-SCOTCH for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(ord%MYID .EQ.0 ) WRITE(LP, & '(" PT-SCOTCH not available")') RETURN #endif ELSE IF (id%KEEP(245) .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) BASE = ord%NPROCS-id%NSLAVES IF(N.LE.100) THEN WORKERS = 2 ELSE WORKERS = min(id%NSLAVES,N/16) END IF I=1 DO IF (I .GT. WORKERS) EXIT ord%NPROCS_PARAORD = I I = I*2 END DO IDO = (ord%MYID .GE. BASE) .AND. & (ord%MYID .LE. BASE+ord%NPROCS_PARAORD-1) ord%IDO = IDO IF ( IDO ) THEN COLOR = 1 ELSE COLOR = MPI_UNDEFINED END IF CALL MPI_COMM_SPLIT( COMM_PARASYMB, COLOR, 0, ord%COMM_PARAORD, & IERR ) IF (ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ELSE ord%MYID_PARAORD = -1 ENDIF ord%ORDTOOL = 2 IF(PROKG) WRITE(MPG, & '(" Using ParMETIS for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(ord%MYID .EQ.0 ) WRITE(LP, & '(" ParMETIS not available.")') RETURN #endif END IF ENDIF END SUBROUTINE CMUMPS_SET_PAR_ORD SUBROUTINE CMUMPS_DO_PAR_ORD(id, MYID, NPROCS, ord, & WORK, LWORK, LUMAT, & SIZEOFBLOCKS) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id INTEGER, INTENT(IN) :: MYID, NPROCS TYPE(ORD_TYPE) :: ord INTEGER :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK TYPE(LMATRIX_T), OPTIONAL :: LUMAT INTEGER, INTENT(IN), OPTIONAL :: SIZEOFBLOCKS(N) #if defined(parmetis) || defined(parmetis3) INTEGER :: IERR #endif TYPE(COMPACT_GRAPH_T) :: GCOMP_DIST IF (id%KEEP(339).NE.0) THEN CALL MUMPS_AB_LMAT_TO_CLEAN_G ( ord%MYID, & .FALSE., & .FALSE., & LUMAT, GCOMP_DIST, id%INFO, id%ICNTL & , MEMCNT & ) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ENDIF IF (ord%ORDTOOL .EQ. 1) THEN #if defined(ptscotch) IF (id%KEEP(339).NE.0) THEN CALL CMUMPS_PTSCOTCH_ORD(id, ord, WORK, LWORK, & GCOMP_DIST, & SIZEOFBLOCKS ) ELSE CALL CMUMPS_PTSCOTCH_ORD(id, ord, WORK, LWORK) ENDIF #else id%INFOG(1) = -38 id%INFO(1) = -38 WRITE(LP,*)'PT-SCOTCH not available. Aborting...' CALL MUMPS_ABORT() #endif ELSE IF (ord%ORDTOOL .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) IF (id%KEEP(339).GT.0) THEN CALL CMUMPS_PARMETIS_ORD_LUMAT (id, ord, WORK, LWORK, & GCOMP_DIST, & SIZEOFBLOCKS) ELSE CALL CMUMPS_PARMETIS_ORD(id, ord, WORK, LWORK) ENDIF IF (id%KEEP(339).EQ.0) THEN if(ord%IDO) CALL MPI_COMM_FREE(ord%COMM_PARAORD, IERR) ENDIF #else id%INFOG(1) = -38 id%INFO(1) = -38 WRITE(LP,*)'ParMETIS not available. Aborting...' CALL MUMPS_ABORT() #endif END IF IF (id%KEEP(339).NE.0) THEN CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST, MEMCNT) ENDIF RETURN END SUBROUTINE CMUMPS_DO_PAR_ORD #if defined(parmetis) || defined(parmetis3) SUBROUTINE CMUMPS_PARMETIS_ORD(id, ord, WORK, LWORK) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT (IN) :: LWORK INTEGER :: I, MYID, NPROCS, IERR, BASE, METIS_IDX_SIZE INTEGER, POINTER :: FIRST(:), LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & OPTIONS(10) INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:), RCVCNTS(:) INTEGER(8) :: EDGELOCNBR INTEGER, POINTER :: SIZES(:), ORDER(:) INTEGER, POINTER :: IDUMMY_PTR(:) INTEGER :: SIZE_IDUMMY_PTR nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB, RCVCNTS, & SIZES, ORDER, IDUMMY_PTR) MYID = ord%MYID NPROCS = ord%NPROCS IERR = 0 SIZE_IDUMMY_PTR = 0 IF( LWORK.LT. int(N,8)*3_8 .OR. LWORK .LT. int(NPROCS+1,8)) THEN WRITE(LP, & '("Insufficient workspace inside CMUMPS_PARMETIS_ORD")') CALL MUMPS_ABORT() END IF BASEVAL = 1 CALL MUMPS_REALLOC(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT BASE = id%NPROCS-id%NSLAVES CALL CMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK(1_8: 2_8*int(N,8)), & 2_8*int(N,8), TYPE=2) VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 CALL MUMPS_I8REALLOC(VERTLOCTAB, VERTLOCNBR+1, id%INFO, & LP, STRING='VERTLOCTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT SWORK => WORK(int(N+1,8):3_8*int(N,8)) CALL CMUMPS_BUILD_DIST_GRAPH(id, ord, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK, 2_8 * int(N,8)) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF(id%INFO(1).LT.0) GOTO 20 EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1_8 OPTIONS(:) = 0 ORDER => WORK(1:N) CALL MUMPS_REALLOC(SIZES, 2*ord%NPROCS_PARAORD, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IF(ord%IDO) THEN CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 1 ELSE CALL MUMPS_PARMETIS_MIXEDto32(id, & BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & IDUMMY_PTR, SIZE_IDUMMY_PTR, & SIZES, ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ENDIF ELSE IF (METIS_IDX_SIZE.EQ.64) THEN CALL MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & IDUMMY_PTR, SIZE_IDUMMY_PTR, & SIZES, ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ELSE WRITE(*,*) & "Internal error in PARMETIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() END IF END IF IF (id%KEEP(339).NE.0) THEN nullify(VERTLOCTAB, EDGELOCTAB) ELSE CALL MUMPS_IDEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(VERTLOCTAB) ENDIF IF(IERR.GT.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 20 CALL MPI_BCAST(SIZES(1), 2*ord%NPROCS_PARAORD, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) ord%CBLKNBR = 2*ord%NPROCS_PARAORD-1 CALL MUMPS_REALLOC(RCVCNTS, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, id%NPROCS RCVCNTS(I) = max(LAST(I)-FIRST(I)+1,0) END DO FIRST = FIRST-1 IF(FIRST(1) .LT. 0) THEN FIRST(1) = 0 END IF CALL MPI_ALLGATHERV ( ORDER(1), VERTLOCNBR, MPI_INTEGER, & ord%PERMTAB(1), & RCVCNTS(1), FIRST(1), MPI_INTEGER, ord%COMM, IERR ) DO I=1, N ord%PERITAB(ord%PERMTAB(I)) = I END DO CALL MUMPS_REALLOC(ord%RANGTAB, 2*ord%NPROCS_PARAORD, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL CMUMPS_BUILD_TREETAB(ord%TREETAB, ord%RANGTAB, & SIZES, ord%CBLKNBR) CALL MUMPS_DEALLOC(SIZES, FIRST, LAST, & RCVCNTS, MEMCNT=MEMCNT) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL CMUMPS_BUILD_TREE(ord) RETURN 20 CONTINUE CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(SIZES , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) RETURN END SUBROUTINE CMUMPS_PARMETIS_ORD SUBROUTINE CMUMPS_PARMETIS_ORD_LUMAT (id, ord, WORK, LWORK, & GCOMP_DIST, & SIZEOFBLOCKS ) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK TYPE(COMPACT_GRAPH_T), OPTIONAL :: GCOMP_DIST INTEGER, INTENT(IN), OPTIONAL, TARGET :: SIZEOFBLOCKS(N) INTEGER :: I, MYID, NPROCS, IERR, BASE, METIS_IDX_SIZE INTEGER :: MASTER PARAMETER (MASTER=0) INTEGER, POINTER :: FIRST(:), LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & OPTIONS(10) INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:), RCVCNTS(:) INTEGER(8) :: EDGELOCNBR INTEGER, POINTER :: SIZES(:), ORDER(:) INTEGER, POINTER :: VELOLOCTAB(:) INTEGER :: SIZE_VELOLOCTAB INTEGER, TARGET :: IDUMMY(1) nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB, RCVCNTS, & SIZES, ORDER ) VELOLOCTAB => IDUMMY MYID = ord%MYID NPROCS = ord%NPROCS IERR = 0 SIZE_VELOLOCTAB = 0 IF( LWORK.LT. int(N,8)*3_8 .OR. LWORK .LT. int(NPROCS+1,8)) THEN WRITE(LP, & '("Insufficient workspace inside CMUMPS_PARMETIS_ORD")') CALL MUMPS_ABORT() END IF IF(ord%IDO) THEN CALL MUMPS_REALLOC(FIRST, ord%NPROCS_PARAORD+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, ord%NPROCS_PARAORD+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_REALLOC(SIZES, 2*ord%NPROCS_PARAORD, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 20 IF(ord%IDO) THEN CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) VERTLOCNBR = GCOMP_DIST%LAST-GCOMP_DIST%FIRST+1 EDGELOCNBR = GCOMP_DIST%NZG VERTLOCTAB => GCOMP_DIST%IPE EDGELOCTAB => GCOMP_DIST%ADJ IF (id%KEEP(339).NE.0) THEN VELOLOCTAB=>SIZEOFBLOCKS(GCOMP_DIST%FIRST:GCOMP_DIST%LAST) SIZE_VELOLOCTAB = VERTLOCNBR ENDIF DO I=1,ord%NPROCS_PARAORD+1 FIRST(I) = -99 LAST(I) = -99 ENDDO BASE = 0 #if defined(AVOID_MPI_IN_PLACE) CALL MPI_ALLGATHER( GCOMP_DIST%FIRST, 1, MPI_INTEGER, & FIRST, 1, MPI_INTEGER, ord%COMM_PARAORD, IERR ) CALL MPI_ALLGATHER( GCOMP_DIST%LAST, 1, MPI_INTEGER, & LAST, 1, MPI_INTEGER, ord%COMM_PARAORD, IERR ) #else FIRST(ord%MYID_PARAORD + 1)= GCOMP_DIST%FIRST LAST (ord%MYID_PARAORD + 1)= GCOMP_DIST%LAST CALL MPI_ALLREDUCE(MPI_IN_PLACE, FIRST(1), & ord%NPROCS_PARAORD+1, & MPI_INTEGER, MPI_MAX, ord%COMM_PARAORD, IERR) CALL MPI_ALLREDUCE(MPI_IN_PLACE, LAST(1), & ord%NPROCS_PARAORD+1, & MPI_INTEGER, MPI_MAX, ord%COMM_PARAORD, IERR) #endif DO I=1, ord%NPROCS_PARAORD+1 IF (FIRST(I).EQ.-99) THEN FIRST(I) = GCOMP_DIST%NG+1 ENDIF IF (LAST(I).EQ.-99) THEN LAST (I) = GCOMP_DIST%NG ENDIF ENDDO OPTIONS(:) = 0 ORDER => WORK(1:N) BASEVAL = 1 IF (METIS_IDX_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 1 ELSE CALL MUMPS_PARMETIS_MIXEDto32(id, & BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & VELOLOCTAB, SIZE_VELOLOCTAB, & SIZES, ord%COMM_PARAORD, ord%MYID_PARAORD, & IERR) ENDIF ELSE IF (METIS_IDX_SIZE.EQ.64) THEN CALL MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & VELOLOCTAB, SIZE_VELOLOCTAB, & SIZES, ord%COMM_PARAORD, ord%MYID_PARAORD, & IERR) ELSE WRITE(*,*) & "Internal error in PARMETIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() END IF END IF nullify(VERTLOCTAB, EDGELOCTAB) IF(IERR.GT.0) THEN id%INFO(1:2) = -50 END IF ord%CBLKNBR = 2*ord%NPROCS_PARAORD-1 CALL MUMPS_REALLOC(ord%RANGTAB, ord%CBLKNBR+1, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_REALLOC(RCVCNTS, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 20 IF (ord%IDO) THEN DO I=1, ord%NPROCS_PARAORD 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_GATHERV ( ORDER(1), VERTLOCNBR, MPI_INTEGER, & ord%PERMTAB(1), & RCVCNTS(1), FIRST(1), MPI_INTEGER, MASTER, & ord%COMM_PARAORD, IERR ) END IF IF (ord%MYID_PARAORD.EQ.MASTER) THEN DO I=1, N ord%PERITAB(ord%PERMTAB(I)) = I END DO CALL MUMPS_REALLOC(ord%TREETAB, ord%CBLKNBR, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL CMUMPS_BUILD_TREETAB(ord%TREETAB, ord%RANGTAB, & SIZES, ord%CBLKNBR) ENDIF CALL MUMPS_DEALLOC(SIZES, FIRST, LAST, & RCVCNTS, MEMCNT=MEMCNT) CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%PERMTAB(1), N, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%PERITAB(1), N, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%RANGTAB(1), ord%CBLKNBR+1, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%TREETAB(1), ord%CBLKNBR, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL CMUMPS_BUILD_TREE(ord) RETURN 20 CONTINUE CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(SIZES , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) RETURN END SUBROUTINE CMUMPS_PARMETIS_ORD_LUMAT #endif #if defined(ptscotch) SUBROUTINE CMUMPS_PTSCOTCH_ORD(id, ord, WORK, LWORK, GCOMP_DIST, & SIZEOFBLOCKS) !$ USE OMP_LIB IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK TYPE(COMPACT_GRAPH_T), OPTIONAL :: GCOMP_DIST INTEGER, INTENT(IN), OPTIONAL, TARGET:: SIZEOFBLOCKS(N) INTEGER :: MYID, NPROCS, IERR INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & BASE, SCOTCH_INT_SIZE INTEGER(8) :: EDGELOCNBR INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:) INTEGER, POINTER :: VELOLOCTAB(:) INTEGER :: SIZE_VELOLOCTAB INTEGER, TARGET :: IDUMMY(1) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) INCLUDE 'scotchf.h' INTEGER :: IOMP, NOMP DOUBLE PRECISION :: CONTDAT(SCOTCH_CONTEXTDIM) INTEGER(4) :: IERR_SCOTCH #else INTEGER :: PTHREAD_NUMBER, NOMP #endif nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB) VELOLOCTAB => IDUMMY CALL MPI_BARRIER(ord%COMM, IERR) MYID = ord%MYID NPROCS = ord%NPROCS SIZE_VELOLOCTAB = 0 BASEVAL = 1 IF (id%KEEP(339).NE.0) THEN VERTLOCNBR = GCOMP_DIST%LAST-GCOMP_DIST%FIRST+1 EDGELOCNBR = GCOMP_DIST%NZG VERTLOCTAB => GCOMP_DIST%IPE EDGELOCTAB => GCOMP_DIST%ADJ IF (id%KEEP(339).NE.0) THEN VELOLOCTAB => SIZEOFBLOCKS(GCOMP_DIST%FIRST:GCOMP_DIST%LAST) SIZE_VELOLOCTAB = VERTLOCNBR ENDIF ELSE IF (LWORK .LT. int(N,8)*3_8) THEN WRITE(LP, & '("Insufficient workspace inside CMUMPS_PTSCOTCH_ORD")') CALL MUMPS_ABORT() END IF BASE = id%NPROCS-id%NSLAVES CALL MUMPS_REALLOC(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL CMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK(1: 2_8*int(N,8)), & 2_8*int(N,8), TYPE=2) VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 CALL MUMPS_I8REALLOC(VERTLOCTAB, VERTLOCNBR+1, id%INFO, & LP, STRING='VERTLOCTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT SWORK => WORK(int(N+1,8):3_8*int(N,8)) CALL CMUMPS_BUILD_DIST_GRAPH(id, ord, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK, 2_8*int(N,8)) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 11 EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1_8 ENDIF CALL MUMPS_REALLOC(ord%PERMTAB, N, id%INFO, & LP, STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%PERITAB, N, id%INFO, & LP, STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%RANGTAB, N+1, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%TREETAB, N, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IF(ord%IDO) THEN CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) !$OMP PARALLEL PRIVATE(IOMP, IERR_SCOTCH) !$OMP SINGLE NOMP=omp_get_num_threads() !$OMP END SINGLE IOMP=omp_get_thread_num() IF (IOMP.EQ.0) THEN CALL SCOTCHFCONTEXTINIT(CONTDAT, IERR_SCOTCH) CALL SCOTCHFCONTEXTRANDOMCLONE(CONTDAT, IERR_SCOTCH) CALL SCOTCHFCONTEXTTHREADIMPORT1(CONTDAT, NOMP, IERR_SCOTCH) ENDIF !$OMP BARRIER CALL SCOTCHFCONTEXTTHREADIMPORT2(CONTDAT, IOMP, IERR_SCOTCH) #else NOMP=0 !$ NOMP=omp_get_max_threads() IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (PTHREAD_NUMBER) CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (NOMP) ENDIF #endif #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) IF (IOMP.EQ.0) THEN #endif IF(SCOTCH_INT_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 2 ELSE CALL MUMPS_PTSCOTCH_MIXEDto32(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & VELOLOCTAB, SIZE_VELOLOCTAB, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, SCOTCH_CONTEXTDIM, #endif & IERR) ENDIF ELSE CALL MUMPS_PTSCOTCH_MIXEDto64(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & VELOLOCTAB, SIZE_VELOLOCTAB, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, SCOTCH_CONTEXTDIM, #endif & IERR) END IF #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL SCOTCHFCONTEXTEXIT(CONTDAT) ENDIF !$OMP END PARALLEL #else IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (PTHREAD_NUMBER) ENDIF #endif END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 11 CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%PERMTAB(1), N, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%PERITAB(1), N, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%RANGTAB(1), ord%CBLKNBR+1, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%TREETAB(1), ord%CBLKNBR, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) CALL CMUMPS_BUILD_TREE(ord) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ord%N = N IF (id%KEEP(339).NE.0) THEN nullify(VERTLOCTAB, EDGELOCTAB) ELSE CALL MUMPS_DEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(VERTLOCTAB, MEMCNT=MEMCNT) ENDIF RETURN 11 CONTINUE IF (id%KEEP(339).NE.0) THEN CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(VERTLOCTAB, MEMCNT=MEMCNT) ELSE CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) nullify(VERTLOCTAB, EDGELOCTAB) ENDIF RETURN END SUBROUTINE CMUMPS_PTSCOTCH_ORD #endif FUNCTION CMUMPS_STOP_DESCENT(id, ord, NACTIVE, ANODE, RPROC, & ALIST, LIST, PEAKMEM, NNODES, CHECKMEM) IMPLICIT NONE LOGICAL :: CMUMPS_STOP_DESCENT INTEGER :: NACTIVE, RPROC, ANODE, PEAKMEM, NNODES INTEGER :: ALIST(NNODES), LIST(NNODES) TYPE(ORD_TYPE) :: ord TYPE(CMUMPS_STRUC) :: id LOGICAL, OPTIONAL :: CHECKMEM INTEGER :: IPEAKMEM, BIG, MAX_NROWS, MIN_NROWS INTEGER :: TOPROWS, NRL, HOSTMEM, SUBMEM INTEGER :: I, NZ_ROW, WEIGHT LOGICAL :: ICHECKMEM INTEGER :: NZ4 IF(present(CHECKMEM)) THEN ICHECKMEM = CHECKMEM ELSE ICHECKMEM = .FALSE. END IF CMUMPS_STOP_DESCENT = .FALSE. IF(NACTIVE .GE. RPROC) THEN CMUMPS_STOP_DESCENT = .TRUE. RETURN END IF IF(NACTIVE .EQ. 0) THEN CMUMPS_STOP_DESCENT = .TRUE. RETURN END IF IF(.NOT. ICHECKMEM) RETURN BIG = ALIST(NACTIVE) IF(NACTIVE .GT. 1) THEN MAX_NROWS = ord%NW(ALIST(NACTIVE-1)) MIN_NROWS = ord%NW(ALIST(1)) ELSE MAX_NROWS = 0 MIN_NROWS = 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 *N HOSTMEM = 12*N NZ4=int(id%KEEP8(28)) NZ_ROW = 2*(NZ4/N) IF (id%KEEP(339).NE.0) THEN NRL = 0 ELSE IF(id%KEEP(46) .EQ. 0) THEN NRL = 0 ELSE NRL = MIN_NROWS END IF ENDIF HOSTMEM = HOSTMEM + 2*TOPROWS*NZ_ROW HOSTMEM = HOSTMEM +NRL HOSTMEM = HOSTMEM + max(NRL,TOPROWS)*(NZ_ROW+2) HOSTMEM = HOSTMEM + 6*max(NRL,TOPROWS) HOSTMEM = HOSTMEM + 3*TOPROWS NRL = MAX_NROWS SUBMEM = SUBMEM +NRL SUBMEM = SUBMEM + NRL*(NZ_ROW+2) SUBMEM = SUBMEM + 6*NRL IPEAKMEM = max(HOSTMEM, SUBMEM) IF((IPEAKMEM .GT. PEAKMEM) .AND. & (PEAKMEM .NE. 0)) THEN CMUMPS_STOP_DESCENT = .TRUE. RETURN ELSE CMUMPS_STOP_DESCENT = .FALSE. PEAKMEM = IPEAKMEM RETURN END IF END FUNCTION CMUMPS_STOP_DESCENT FUNCTION CMUMPS_CNT_KIDS(NODE, ord) IMPLICIT NONE INTEGER :: CMUMPS_CNT_KIDS INTEGER :: NODE TYPE(ORD_TYPE) :: ord INTEGER :: CURR CMUMPS_CNT_KIDS = 0 IF(ord%SON(NODE) .EQ. -1) THEN RETURN ELSE CMUMPS_CNT_KIDS = 1 CURR = ord%SON(NODE) DO IF(ord%BROTHER(CURR) .NE. -1) THEN CMUMPS_CNT_KIDS = CMUMPS_CNT_KIDS+1 CURR = ord%BROTHER(CURR) ELSE EXIT END IF END DO END IF RETURN END FUNCTION CMUMPS_CNT_KIDS SUBROUTINE CMUMPS_GET_SUBTREES(ord, id) USE MUMPS_TOOLS_COMMON_M, ONLY : MUMPS_MERGESORT, & MUMPS_MERGESWAP IMPLICIT NONE TYPE(ORD_TYPE) :: ord TYPE(CMUMPS_STRUC) :: id INTEGER, ALLOCATABLE :: ALIST(:), AWEIGHTS(:), LIST(:), WORK(:) INTEGER :: NNODES, BIG, CURR, ND, NACTIVE, RPROC, ANODE, BASE, I, & NK, PEAKMEM, allocok, Iprocdeb LOGICAL :: SD NNODES = ord%NPROCS_PARAORD CALL MUMPS_REALLOC(ord%TOPNODES, 2*max(NNODES,2), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%FIRST, ord%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%LAST, ord%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(ALIST(NNODES), AWEIGHTS(NNODES), LIST(NNODES), & WORK(0:NNODES+1), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=4*NNODES+2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 NACTIVE = 0 DO I=1, ord%CBLKNBR IF (ord%TREETAB(I).EQ.-1) THEN NACTIVE = NACTIVE+1 IF(NACTIVE.LE.NNODES) THEN ALIST(NACTIVE) = I AWEIGHTS(NACTIVE) = ord%NW(I) END IF END IF END DO IF((ord%CBLKNBR .EQ. 1) .OR. & (NACTIVE.GT.NNODES) .OR. & ( NNODES .LT. CMUMPS_CNT_KIDS(ord%CBLKNBR, ord) )) THEN ord%TOPNODES =0 ord%TOPNODES(1) = 1 ord%TOPNODES(2) = ord%RANGTAB(ord%CBLKNBR+1) - ord%RANGTAB(1) ord%TOPNODES(3) = ord%RANGTAB(1) ord%TOPNODES(4) = ord%RANGTAB(ord%CBLKNBR+1)-1 ord%FIRST = 0 ord%LAST = -1 RETURN END IF CALL MUMPS_MERGESORT(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL MUMPS_MERGESWAP(NACTIVE, WORK(0:NACTIVE+1), & AWEIGHTS(1:NACTIVE), & ALIST(1:NACTIVE)) RPROC = NNODES ANODE = 0 PEAKMEM = 0 ord%TOPNODES = 0 DO IF(NACTIVE .EQ. 0) EXIT BIG = ALIST(NACTIVE) NK = CMUMPS_CNT_KIDS(BIG, ord) IF((NK .GT. (RPROC-NACTIVE+1)) .OR. (NK .EQ. 0)) THEN ANODE = ANODE+1 LIST(ANODE) = BIG NACTIVE = NACTIVE-1 RPROC = RPROC-1 CYCLE END IF SD = CMUMPS_STOP_DESCENT(id, ord, NACTIVE, ANODE, & RPROC, ALIST, LIST, PEAKMEM, NNODES, CHECKMEM=.TRUE.) IF ( SD ) & THEN IF(NACTIVE.GT.0) THEN LIST(ANODE+1:ANODE+NACTIVE) = ALIST(1:NACTIVE) ANODE = ANODE+NACTIVE END IF EXIT END IF ord%TOPNODES(1) = ord%TOPNODES(1)+1 ord%TOPNODES(2) = ord%TOPNODES(2) + & ord%RANGTAB(BIG+1) - ord%RANGTAB(BIG) ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+1) = ord%RANGTAB(BIG) ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+2) = & ord%RANGTAB(BIG+1)-1 CURR = ord%SON(BIG) ALIST(NACTIVE) = CURR AWEIGHTS(NACTIVE) = ord%NW(CURR) DO IF(ord%BROTHER(CURR) .EQ. -1) EXIT NACTIVE = NACTIVE+1 CURR = ord%BROTHER(CURR) ALIST(NACTIVE) = CURR AWEIGHTS(NACTIVE) = ord%NW(CURR) END DO CALL MUMPS_MERGESORT(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL MUMPS_MERGESWAP(NACTIVE, WORK(0:NACTIVE+1), & AWEIGHTS(1:NACTIVE), & ALIST(1:NACTIVE)) END DO DO I=1, ANODE AWEIGHTS(I) = ord%NW(LIST(I)) END DO CALL MUMPS_MERGESORT(ANODE, AWEIGHTS(1:ANODE), WORK(0:ANODE+1)) CALL MUMPS_MERGESWAP(ANODE, WORK(0:ANODE+1), AWEIGHTS(1:ANODE), & ALIST(1:ANODE)) IF (id%KEEP(339).NE.0) THEN Iprocdeb = ord%NPROCS-ANODE+1 IF (Iprocdeb.GT.1) THEN DO I=1, Iprocdeb-1 ord%FIRST(I) = 0 ord%LAST(I) = -1 ENDDO ENDIF 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(Iprocdeb) = ord%RANGTAB(ND) ord%LAST(Iprocdeb) = ord%RANGTAB(CURR+1)-1 Iprocdeb = Iprocdeb +1 ENDDO ELSE 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) = N+1 ord%LAST(BASE+I) = N END DO ENDIF DEALLOCATE(LIST, ALIST, AWEIGHTS, WORK) 90 continue RETURN END SUBROUTINE CMUMPS_GET_SUBTREES SUBROUTINE CMUMPS_PARSYMFACT(id, ord, GPE, GNV, WORK, LWORK) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: GPE(:), GNV(:) INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:), IPET(:), & BUF_PE1(:), BUF_PE2(:), TMP1(:) INTEGER, POINTER :: PE(:), LENG(:), I_HALO_MAP(:) INTEGER, POINTER :: NDENSE(:), LAST(:), & DEGREE(:), W(:), PERM(:), & LISTVAR_SCHUR(:), NEXT(:), & HEAD(:), NV(:), ELEN(:), & LSTVAR(:) INTEGER, POINTER :: MYLIST(:), LPERM(:), LIPERM(:), & NVT(:), BUF_NV1(:), & BUF_NV2(:), ROOTPERM(:), & TMP2(:), BWORK(:), NCLIQUES(:) INTEGER :: MYNCLIQUES, MYMAXVARS, ICLIQUES, & TOTNCLIQUES INTEGER(8) :: MYNVARS, TOTNVARS INTEGER(8), POINTER :: LVARPT(:) INTEGER :: HIDX, TOTEL, & NCMPA, I, J, SIZE_SCHUR, MYID, & NPROCS, IERR, NROWS_LOC, GLOB_IDX, TMP, & NTVAR, TGSIZE, MAXS, RHANDPE, & RHANDNV, RIDX, PROC, JOB, K INTEGER(8) :: PFREES, PFS_SAVE, PELEN, PFREET, PFT_SAVE INTEGER :: STATUSPE(MPI_STATUS_SIZE) INTEGER :: STATUSNV(MPI_STATUS_SIZE) INTEGER :: STATUSCLIQUES(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30 LOGICAL :: AGG6 INTEGER :: THRESH nullify(PE, IPE, LENG, I_HALO_MAP, NCLIQUES) nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, & NEXT, HEAD, NV, ELEN, LSTVAR) nullify(MYLIST, LVARPT, & LPERM, LIPERM, IPET, NVT, BUF_PE1, BUF_PE2, & BUF_NV1, BUF_NV2, ROOTPERM, TMP1, TMP2, BWORK) MYID = ord%MYID NPROCS = ord%NPROCS IF(LWORK .LT. 4_8*int(N,8)) THEN WRITE(LP,*)'Insufficient workspace in CMUMPS_PARSYMFACT' CALL MUMPS_ABORT() ELSE HEAD => WORK( 1 : N ) ELEN => WORK( int(N,8)+1 : 2_8*int(N,8) ) LENG => WORK( 2_8*int(N,8)+1 : 3_8*int(N,8) ) PERM => WORK( 3_8*int(N,8)+1 : 4_8*int(N,8) ) END IF CALL CMUMPS_GET_SUBTREES(ord, id) CALL MUMPS_IDEALLOC(ord%SON, ord%BROTHER, ord%NW, & ord%RANGTAB, MEMCNT=MEMCNT) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 NRL = NROWS_LOC TOPROWS = ord%TOPNODES(2) BWORK => WORK(1_8 : 2_8*int(N,8)) CALL CMUMPS_BUILD_LOC_GRAPH(id, ord, HIDX, IPE, PE, LENG, & I_HALO_MAP, top_graph, BWORK, 2_8*int(N,8)) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF(id%INFO(1).lt.0) RETURN TMP = N DO I=1, NPROCS TMP = TMP-(ord%LAST(I)-ord%FIRST(I)+1) END DO TMP = ceiling(real(TMP)*1.10E0) IF(MYID .EQ. 0) THEN TMP = max(max(TMP, HIDX),1) ELSE TMP = max(HIDX,1) END IF SIZE_SCHUR = HIDX - NROWS_LOC CALL MUMPS_REALLOC(NDENSE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, SIZE_SCHUR LISTVAR_SCHUR(I) = NROWS_LOC+I END DO THRESH = -1 AGG6 = .FALSE. PFREES = IPE(NROWS_LOC+1) PFS_SAVE = PFREES PELEN = PFREES-1 + 2_8*int(NROWS_LOC+ord%TOPNODES(2),8) DO I=1, HIDX PERM(I) = I END DO IF(SIZE_SCHUR.EQ.0) THEN JOB = 0 ELSE JOB = 1 END IF IF(HIDX .GT.0) THEN TOTEL = HIDX NV(1) = -1 CALL MUMPS_SYMQAMD_NEW(JOB, THRESH, NDENSE(1), HIDX, & TOTEL, PELEN, IPE(1), PFREES, LENG(1), PE(1), NV(1), & ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), NEXT(1), & W(1), PERM(1), LISTVAR_SCHUR(1), SIZE_SCHUR, AGG6) ENDIF MYNCLIQUES = 0 MYNVARS = 0 MYMAXVARS = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN MYMAXVARS = MAX(MYMAXVARS,LENG(I)) MYNVARS = MYNVARS+LENG(I) MYNCLIQUES = MYNCLIQUES+1 END IF END DO CALL MPI_REDUCE(MYNVARS, TOTNVARS, 1, MPI_INTEGER8, & MPI_SUM, 0, ord%COMM, IERR) CALL MUMPS_REALLOC(NCLIQUES, NPROCS, id%INFO, & LP, STRING='NCLIQUES', MEMCNT=MEMCNT, ERRCODE=-7) CALL MPI_GATHER(MYNCLIQUES, 1, MPI_INTEGER, NCLIQUES(1), 1, & MPI_INTEGER, 0, ord%COMM, IERR) IF(ord%MYID.EQ.0) THEN TOTNCLIQUES = sum(NCLIQUES) CALL MUMPS_I8REALLOC(LVARPT, TOTNCLIQUES+1, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(LSTVAR, TOTNVARS, id%INFO, & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) LVARPT(1) = 1_8 ICLIQUES = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN ICLIQUES = ICLIQUES+1 LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+LENG(I) DO J=0, LENG(I)-1 LSTVAR(LVARPT(ICLIQUES)+J) = & I_HALO_MAP(PE(IPE(I)+J)-NROWS_LOC) END DO END IF END DO DO PROC=1, NPROCS-1 DO I=1, NCLIQUES(PROC+1) ICLIQUES = ICLIQUES+1 CALL MPI_RECV(K, 1, MPI_INTEGER, PROC, ITAG, ord%COMM, & STATUSCLIQUES, IERR) LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+K CALL MPI_RECV(LSTVAR(LVARPT(ICLIQUES)), K, MPI_INTEGER, & PROC, ITAG, ord%COMM, STATUSCLIQUES, IERR) END DO END DO LPERM => WORK(3_8*int(N,8)+1_8 : 4_8*int(N,8)) NTVAR = ord%TOPNODES(2) CALL CMUMPS_MAKE_LOC_IDX(id, ord%TOPNODES, LPERM, LIPERM, ord) CALL CMUMPS_ASSEMBLE_TOP_GRAPH(id, ord%TOPNODES(2), LPERM, & top_graph, TOTNCLIQUES, LSTVAR, LVARPT, IPET, PE, & LENG, ELEN) TGSIZE = ord%TOPNODES(2)+TOTNCLIQUES PFREET = IPET(TGSIZE+1) PFT_SAVE = PFREET nullify(LPERM) ELSE CALL MUMPS_REALLOC(MYLIST, MYMAXVARS, id%INFO, & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, HIDX IF(IPE(I) .GT. 0) THEN DO J=1, LENG(I) MYLIST(J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) END DO CALL MPI_SEND(LENG(I), 1, MPI_INTEGER, 0, ITAG, & ord%COMM, IERR) CALL MPI_SEND(MYLIST(1), LENG(I), MPI_INTEGER, 0, ITAG, & ord%COMM, IERR) END IF END DO END IF CALL MUMPS_IDEALLOC(top_graph%IRN_LOC, & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN CALL MUMPS_IREALLOC8(PE, max(PFREET+int(TGSIZE,8),1_8),id%INFO, & LP, COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, & ERRCODE=-7) CALL MUMPS_REALLOC(NDENSE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NVT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, max(TGSIZE,1), id%INFO, LP, & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, max(TGSIZE,1), id%INFO, LP, & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(TOTNCLIQUES,1), id%INFO, & LP, STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TOTNCLIQUES LISTVAR_SCHUR(I) = NTVAR+I END DO THRESH = -1 CALL MUMPS_REALLOC(HEAD, max(TGSIZE,1), id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(PERM, max(TGSIZE,1), id%INFO, & LP, COPY=.TRUE., STRING='J2:PERM', & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TGSIZE PERM(I) = I END DO PELEN = max(PFREET+int(TGSIZE,8),1_8) IF(TGSIZE.GT.0) THEN TOTEL = TGSIZE NVT(1) = -1 CALL MUMPS_SYMQAMD_NEW(2, -1, NDENSE(1), TGSIZE, & TOTEL, PELEN, IPET(1), PFREET, LENG(1), PE(1), & NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), & NEXT(1), W(1), PERM(1), LISTVAR_SCHUR(1), TOTNCLIQUES, & AGG6) ENDIF END IF CALL MPI_BARRIER(ord%COMM, IERR) CALL MPI_BARRIER(ord%COMM, IERR) CALL MUMPS_DEALLOC(LISTVAR_SCHUR, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN MAXS = NROWS_LOC DO I=2, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) & MAXS = (ord%LAST(I)-ord%FIRST(I)+1) END DO CALL MUMPS_I8REALLOC(BUF_PE1, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(BUF_PE2, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV1, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV2, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GPE, N, id%INFO, & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GNV, N, id%INFO, & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ROOTPERM, TOTNCLIQUES, id%INFO, & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RIDX = 0 TMP1 => BUF_PE1 TMP2 => BUF_NV1 NULLIFY(BUF_PE1, BUF_NV1) BUF_PE1 => IPE BUF_NV1 => NV DO PROC=0, NPROCS-2 CALL MPI_IRECV(BUF_PE2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER8, PROC+1, PROC+1, & ord%COMM, RHANDPE, IERR) CALL MPI_IRECV(BUF_NV2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER, PROC+1, PROC+1, & ord%COMM, RHANDNV, IERR) DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO CALL MPI_WAIT(RHANDPE, STATUSPE, IERR) CALL MPI_WAIT(RHANDNV, STATUSNV, IERR) IF(PROC .NE. 0) THEN TMP1 => BUF_PE1 TMP2 => BUF_NV1 END IF BUF_PE1 => BUF_PE2 BUF_NV1 => BUF_NV2 NULLIFY(BUF_PE2, BUF_NV2) BUF_PE2 => TMP1 BUF_NV2 => TMP2 NULLIFY(TMP1, TMP2) END DO DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO DO I=1, NTVAR GLOB_IDX = LIPERM(I) IF(IPET(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = NVT(I) ELSE GPE(GLOB_IDX) = -LIPERM(-IPET(I)) GNV(GLOB_IDX) = NVT(I) END IF END DO DO I=1, TOTNCLIQUES GLOB_IDX = ROOTPERM(I) GPE(GLOB_IDX) = -LIPERM(-IPET(NTVAR+I)) END DO ELSE CALL MPI_SEND(IPE(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER8, 0, MYID, ord%COMM, IERR) CALL MPI_SEND(NV(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER, 0, MYID, ord%COMM, IERR) END IF CALL MUMPS_DEALLOC(BUF_NV1, BUF_NV2, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(BUF_PE1, BUF_PE2, IPE, IPET, & TMP1, LVARPT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, I_HALO_MAP, NDENSE, & LAST, DEGREE, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(W, LISTVAR_SCHUR, NEXT, & NV, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LSTVAR, NCLIQUES, MYLIST, & MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LPERM, LIPERM, NVT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ROOTPERM, TMP2, MEMCNT=MEMCNT) NULLIFY(HEAD, ELEN, LENG, PERM) RETURN END SUBROUTINE CMUMPS_PARSYMFACT SUBROUTINE CMUMPS_PARSYMFACT_LUMAT(id, ord, GPE, GNV, WORK, LWORK, & LUMAT, SIZEOFBLOCKS) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: GPE(:), GNV(:) INTEGER, TARGET :: WORK(:) TYPE(LMATRIX_T), INTENT(IN) :: LUMAT INTEGER, INTENT(IN) :: SIZEOFBLOCKS(id%NBLK) TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:), IPET(:), & BUF_PE1(:), BUF_PE2(:), TMP1(:) INTEGER, POINTER :: PE(:), & LENG(:), I_HALO_MAP(:) INTEGER, POINTER :: NDENSE(:), LAST(:), & DEGREE(:), W(:), PERM(:), & LISTVAR_SCHUR(:), NEXT(:), & HEAD(:), NV(:), ELEN(:), & LSTVAR(:) INTEGER, POINTER :: MYLIST(:), & LPERM(:), & LIPERM(:), & NVT(:), BUF_NV1(:), & BUF_NV2(:), ROOTPERM(:), & TMP2(:), BWORK(:), NCLIQUES(:), MAPTAB(:) INTEGER :: MYNCLIQUES, MYMAXVARS, ICLIQUES, & TOTNCLIQUES INTEGER(8) :: MYNVARS, TOTNVARS, LWORK INTEGER(8), POINTER :: LVARPT(:) INTEGER :: HIDX, TOTEL, & NCMPA, I, J, SIZE_SCHUR, MYID, & NPROCS, IERR, NROWS_LOC, GLOB_IDX, TMP, & NTVAR, TGSIZE, MAXS, RHANDPE, & RHANDNV, RIDX, PROC, JOB, K INTEGER(8) :: PFREES, PFS_SAVE, PELEN, PFREET, PFT_SAVE INTEGER :: STATUSPE(MPI_STATUS_SIZE) INTEGER :: STATUSNV(MPI_STATUS_SIZE) INTEGER :: STATUSCLIQUES(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30 LOGICAL :: AGG6 INTEGER :: THRESH nullify(PE, IPE, LENG, I_HALO_MAP, NCLIQUES) nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, & NEXT, HEAD, NV, ELEN, LSTVAR) nullify(MYLIST, LVARPT, MAPTAB, & LPERM, LIPERM, IPET, NVT, BUF_PE1, BUF_PE2, & BUF_NV1, BUF_NV2, ROOTPERM, TMP1, TMP2, BWORK, MAPTAB) MYID = ord%MYID NPROCS = ord%NPROCS IF( LWORK .LT. 4_8*int(N,8) ) THEN WRITE(LP,*) & 'Insufficient workspace in CMUMPS_PARSYMFACT_LUMAT' CALL MUMPS_ABORT() ENDIF HEAD => WORK( 1 : N ) ELEN => WORK( int(N,8)+1_8 : 2_8*int(N,8) ) LENG => WORK( 2_8*int(N,8)+1_8 : 3_8*int(N,8) ) PERM => WORK( 3_8*int(N,8)+1_8 : 4_8*int(N,8) ) CALL CMUMPS_GET_SUBTREES(ord, id) CALL MUMPS_IDEALLOC(ord%SON, ord%BROTHER, ord%NW, & ord%RANGTAB, MEMCNT=MEMCNT) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 NRL = NROWS_LOC TOPROWS = ord%TOPNODES(2) BWORK => WORK(1_8 : 2_8*int(N,8)) CALL CMUMPS_LUMAT_TO_LOC_GRAPH( & LUMAT, id, ord, HIDX, IPE, PE, LENG, & I_HALO_MAP, BWORK, 2_8*int(N,8)) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF(id%INFO(1).lt.0) RETURN TMP = N DO I=1, NPROCS TMP = TMP-(ord%LAST(I)-ord%FIRST(I)+1) END DO TMP = ceiling(real(TMP)*1.10E0) IF(MYID .EQ. 0) THEN TMP = max(max(TMP, HIDX),1) ELSE TMP = max(HIDX,1) END IF SIZE_SCHUR = HIDX - NROWS_LOC CALL MUMPS_REALLOC(NDENSE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, SIZE_SCHUR LISTVAR_SCHUR(I) = NROWS_LOC+I END DO THRESH = -1 AGG6 = .FALSE. PFREES = IPE(NROWS_LOC+1) PFS_SAVE = PFREES PELEN = PFREES-1 + 2_8*int(NROWS_LOC+ord%TOPNODES(2),8) DO I=1, HIDX PERM(I) = I END DO IF(SIZE_SCHUR.EQ.0) THEN JOB = 0 ELSE JOB = 1 END IF IF(HIDX .GT.0) THEN NV(1) = -1 TOTEL = HIDX IF ((N.LT.NORIG).OR.(id%KEEP(339).NE.0)) THEN TOTEL = 0 DO I=1,NROWS_LOC NV(I) = SIZEOFBLOCKS ( & ord%PERITAB(ord%FIRST(MYID+1)+I-1) & ) TOTEL = TOTEL + NV(I) ENDDO DO I=NROWS_LOC+1, HIDX NV(I) = SIZEOFBLOCKS (I_HALO_MAP(I-NROWS_LOC)) TOTEL = TOTEL + NV(I) ENDDO ENDIF CALL MUMPS_SYMQAMD_NEW(JOB, THRESH, NDENSE(1), HIDX, & TOTEL, PELEN, IPE(1), PFREES, LENG(1), PE(1), NV(1), & ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), NEXT(1), & W(1), PERM(1), LISTVAR_SCHUR(1), SIZE_SCHUR, AGG6) ENDIF MYNCLIQUES = 0 MYNVARS = 0 MYMAXVARS = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN MYMAXVARS = MAX(MYMAXVARS,LENG(I)) MYNVARS = MYNVARS+LENG(I) MYNCLIQUES = MYNCLIQUES+1 END IF END DO CALL MPI_REDUCE(MYNVARS, TOTNVARS, 1, MPI_INTEGER8, & MPI_SUM, 0, ord%COMM, IERR) CALL MUMPS_REALLOC(NCLIQUES, NPROCS, id%INFO, & LP, STRING='NCLIQUES', MEMCNT=MEMCNT, ERRCODE=-7) CALL MPI_GATHER(MYNCLIQUES, 1, MPI_INTEGER, NCLIQUES(1), 1, & MPI_INTEGER, 0, ord%COMM, IERR) IF(ord%MYID.EQ.0) THEN TOTNCLIQUES = sum(NCLIQUES) CALL MUMPS_I8REALLOC(LVARPT, TOTNCLIQUES+1, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(LSTVAR, TOTNVARS, id%INFO, & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) LVARPT(1) = 1_8 ICLIQUES = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN ICLIQUES = ICLIQUES+1 LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+LENG(I) DO J=0, LENG(I)-1 LSTVAR(LVARPT(ICLIQUES)+J) = & I_HALO_MAP(PE(IPE(I)+J)-NROWS_LOC) END DO END IF END DO DO PROC=1, NPROCS-1 DO I=1, NCLIQUES(PROC+1) ICLIQUES = ICLIQUES+1 CALL MPI_RECV(K, 1, MPI_INTEGER, PROC, ITAG, ord%COMM, & STATUSCLIQUES, IERR) LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+K CALL MPI_RECV(LSTVAR(LVARPT(ICLIQUES)), K, MPI_INTEGER, & PROC, ITAG, ord%COMM, STATUSCLIQUES, IERR) END DO END DO ELSE CALL MUMPS_REALLOC(MYLIST, MYMAXVARS, id%INFO, & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, HIDX IF(IPE(I) .GT. 0) THEN DO J=1, LENG(I) MYLIST(J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) END DO CALL MPI_SEND(LENG(I), 1, MPI_INTEGER, 0, ITAG, & ord%COMM, IERR) CALL MPI_SEND(MYLIST(1), LENG(I), MPI_INTEGER, 0, ITAG, & ord%COMM, IERR) END IF END DO END IF CALL MUMPS_DEALLOC(PE, MEMCNT=MEMCNT) IF (id%KEEP(339).NE.0) THEN MAPTAB => WORK(1:N) CALL MUMPS_BUILD_TOP_GRAPH (LUMAT, id, ord, top_graph, MAPTAB) ENDIF IF (MYID.EQ.0) THEN LPERM => WORK( 3_8*int(N,8)+1_8 : 4_8*int(N,8) ) NTVAR = ord%TOPNODES(2) CALL CMUMPS_MAKE_LOC_IDX(id, ord%TOPNODES, LPERM, LIPERM, ord) CALL CMUMPS_ASSEMBLE_TOP_GRAPH(id, ord%TOPNODES(2), LPERM, & top_graph, TOTNCLIQUES, LSTVAR, LVARPT, IPET, PE, & LENG, ELEN) TGSIZE = ord%TOPNODES(2)+TOTNCLIQUES PFREET = IPET(TGSIZE+1) PFT_SAVE = PFREET nullify(LPERM) ENDIF CALL MUMPS_IDEALLOC(top_graph%IRN_LOC, & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN CALL MUMPS_IREALLOC8(PE, max(PFREET+int(TGSIZE,8),1_8),id%INFO, & LP, COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, & ERRCODE=-7) CALL MUMPS_REALLOC(NDENSE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NVT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, max(TGSIZE,1), id%INFO, LP, & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, max(TGSIZE,1), id%INFO, LP, & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(TOTNCLIQUES,1), id%INFO, & LP, STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TOTNCLIQUES LISTVAR_SCHUR(I) = NTVAR+I END DO THRESH = -1 CALL MUMPS_REALLOC(HEAD, max(TGSIZE,1), id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(PERM, max(TGSIZE,1), id%INFO, & LP, COPY=.TRUE., STRING='J2:PERM', & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TGSIZE PERM(I) = I END DO PELEN = max(PFREET+int(TGSIZE,8),1_8) IF(TGSIZE.GT.0) THEN NVT(1) = -1 TOTEL = TGSIZE IF ((N.LT.NORIG).OR.(id%KEEP(339).NE.0)) THEN TOTEL = TOTNCLIQUES DO I=1,NTVAR NVT(I) = SIZEOFBLOCKS( LIPERM(I) ) TOTEL = TOTEL + NVT(I) ENDDO ENDIF CALL MUMPS_SYMQAMD_NEW(2, -1, NDENSE(1), & TGSIZE, TOTEL, PELEN, IPET(1), PFREET, LENG(1), PE(1), & NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), & NEXT(1), W(1), PERM(1), LISTVAR_SCHUR(1), TOTNCLIQUES, & AGG6) ENDIF CALL MUMPS_DEALLOC(PE, MEMCNT=MEMCNT) END IF CALL MPI_BARRIER(ord%COMM, IERR) CALL MPI_BARRIER(ord%COMM, IERR) CALL MUMPS_DEALLOC(LISTVAR_SCHUR, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN MAXS = NROWS_LOC DO I=2, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) & MAXS = (ord%LAST(I)-ord%FIRST(I)+1) END DO CALL MUMPS_I8REALLOC(BUF_PE1, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(BUF_PE2, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV1, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV2, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GPE, N, id%INFO, & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GNV, N, id%INFO, & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ROOTPERM, TOTNCLIQUES, id%INFO, & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RIDX = 0 TMP1 => BUF_PE1 TMP2 => BUF_NV1 NULLIFY(BUF_PE1, BUF_NV1) BUF_PE1 => IPE BUF_NV1 => NV DO PROC=0, NPROCS-2 CALL MPI_IRECV(BUF_PE2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER8, PROC+1, PROC+1, & ord%COMM, RHANDPE, IERR) CALL MPI_IRECV(BUF_NV2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER, PROC+1, PROC+1, & ord%COMM, RHANDNV, IERR) DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO CALL MPI_WAIT(RHANDPE, STATUSPE, IERR) CALL MPI_WAIT(RHANDNV, STATUSNV, IERR) IF(PROC .NE. 0) THEN TMP1 => BUF_PE1 TMP2 => BUF_NV1 END IF BUF_PE1 => BUF_PE2 BUF_NV1 => BUF_NV2 NULLIFY(BUF_PE2, BUF_NV2) BUF_PE2 => TMP1 BUF_NV2 => TMP2 NULLIFY(TMP1, TMP2) END DO DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO DO I=1, NTVAR GLOB_IDX = LIPERM(I) IF(IPET(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = NVT(I) ELSE GPE(GLOB_IDX) = -LIPERM(-IPET(I)) GNV(GLOB_IDX) = NVT(I) END IF END DO DO I=1, TOTNCLIQUES GLOB_IDX = ROOTPERM(I) GPE(GLOB_IDX) = -LIPERM(-IPET(NTVAR+I)) END DO ELSE CALL MPI_SEND(IPE(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER8, 0, MYID, ord%COMM, IERR) CALL MPI_SEND(NV(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER, 0, MYID, ord%COMM, IERR) END IF CALL MUMPS_DEALLOC(BUF_NV1, BUF_NV2, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(BUF_PE1, BUF_PE2, IPE, IPET, & TMP1, LVARPT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, I_HALO_MAP, NDENSE, & LAST, DEGREE, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(W, LISTVAR_SCHUR, NEXT, & NV, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LSTVAR, NCLIQUES, MYLIST, & MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LPERM, LIPERM, NVT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ROOTPERM, TMP2, MEMCNT=MEMCNT) NULLIFY(HEAD, ELEN, LENG, PERM, BWORK, MAPTAB, LPERM) RETURN END SUBROUTINE CMUMPS_PARSYMFACT_LUMAT SUBROUTINE CMUMPS_MAKE_LOC_IDX(id, TOPNODES, LPERM, LIPERM, ord) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id INTEGER, POINTER :: TOPNODES(:), LPERM(:), LIPERM(:) TYPE(ORD_TYPE) :: ord INTEGER :: I, J, K, GIDX CALL MUMPS_REALLOC(LPERM , ord%N, id%INFO, & LP, STRING='LIDX:LPERM', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LIPERM, TOPNODES(2), id%INFO, & LP, STRING='LIDX:LIPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LPERM = 0 K = 1 DO I=TOPNODES(1), 1, -1 DO J=TOPNODES(2*I+1), TOPNODES(2*I+2) GIDX = ord%PERITAB(J) LPERM(GIDX) = K LIPERM(K) = GIDX K = K+1 END DO END DO RETURN END SUBROUTINE CMUMPS_MAKE_LOC_IDX SUBROUTINE CMUMPS_ASSEMBLE_TOP_GRAPH(id, NLOCVARS, LPERM, & top_graph, NCLIQUES, LSTVAR, LVARPT, IPE, PE, LENG, ELEN) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(GRAPH_TYPE) :: top_graph INTEGER, POINTER :: LPERM(:), LSTVAR(:), & PE(:), LENG(:), ELEN(:) INTEGER(8) :: LVARPT(:) INTEGER :: NCLIQUES INTEGER(8), POINTER :: IPE(:) INTEGER :: I, IDX, NLOCVARS INTEGER(8) :: INNZ, PNT, SAVEPNT CALL MUMPS_REALLOC(LENG, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:LENG', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ELEN, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:ELEN', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(IPE , NLOCVARS+NCLIQUES+1, id%INFO, & LP, STRING='ATG:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG = 0 ELEN = 0 DO INNZ=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(INNZ)) .NE. 0) .AND. & (top_graph%JCN_LOC(INNZ) .NE. top_graph%IRN_LOC(INNZ))) & THEN LENG(LPERM(top_graph%IRN_LOC(INNZ))) = & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1 END IF END DO DO I=1, NCLIQUES DO INNZ=LVARPT(I), LVARPT(I+1)-1 ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 END DO END DO IPE(1) = 1 DO I=1, NLOCVARS+NCLIQUES IPE(I+1) = IPE(I)+int(LENG(I),8)+int(ELEN(I),8) END DO CALL MUMPS_IREALLOC8(PE, IPE(NLOCVARS+NCLIQUES+1)+ & int(NLOCVARS,8)+int(NCLIQUES,8), & id%INFO, LP, STRING='ATG:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG = 0 ELEN = 0 DO I=1, NCLIQUES DO INNZ=LVARPT(I), LVARPT(I+1)-1 IDX = LPERM(LSTVAR(INNZ)) PE(IPE(IDX)+int(ELEN(IDX),8)) = NLOCVARS+I PE(IPE(NLOCVARS+I)+int(LENG(NLOCVARS+I),8)) = IDX ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 end do end do DO INNZ=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(INNZ)) .NE. 0) .AND. & (top_graph%JCN_LOC(INNZ) .NE. top_graph%IRN_LOC(INNZ))) & THEN PE(IPE(LPERM(top_graph%IRN_LOC(INNZ)))+ & ELEN(LPERM(top_graph%IRN_LOC(INNZ))) + & LENG(LPERM(top_graph%IRN_LOC(INNZ)))) = & LPERM(top_graph%JCN_LOC(INNZ)) LENG(LPERM(top_graph%IRN_LOC(INNZ))) = & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1 END IF END DO DO I=1, NLOCVARS+NCLIQUES LENG(I) = LENG(I)+ELEN(I) END DO SAVEPNT = 1 PNT = 0 LPERM(1:NLOCVARS+NCLIQUES) = 0 DO I=1, NLOCVARS+NCLIQUES DO INNZ=IPE(I), IPE(I+1)-1 IF(LPERM(PE(INNZ)) .EQ. I) THEN LENG(I) = LENG(I)-1 ELSE LPERM(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NLOCVARS+NCLIQUES+1) = SAVEPNT RETURN END SUBROUTINE CMUMPS_ASSEMBLE_TOP_GRAPH #if defined(parmetis) || defined(parmetis3) SUBROUTINE CMUMPS_BUILD_TREETAB(TREETAB, RANGTAB, SIZES, CBLKNBR) INTEGER, POINTER :: TREETAB(:), RANGTAB(:), SIZES(:) INTEGER :: CBLKNBR,allocok INTEGER :: LCHILD, RCHILD, K, I INTEGER, POINTER :: PERM(:) ALLOCATE(PERM(CBLKNBR),stat=allocok) if(allocok.GT.0) then write(*,*) "Allocation error of PERM in CMUMPS_BUILD_TREETAB" return endif TREETAB(CBLKNBR) = -1 IF(CBLKNBR .EQ. 1) THEN DEALLOCATE(PERM) TREETAB(1) = -1 RANGTAB(1) = 1 RANGTAB(2)= SIZES(1)+1 RETURN END IF LCHILD = CBLKNBR - (CBLKNBR+1)/2 RCHILD = CBLKNBR-1 K = 1 PERM(CBLKNBR) = CBLKNBR PERM(LCHILD) = CBLKNBR+1 - (2*K+1) PERM(RCHILD) = CBLKNBR+1 - (2*K) TREETAB(RCHILD) = CBLKNBR TREETAB(LCHILD) = CBLKNBR IF(CBLKNBR .GT. 3) THEN CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, & LCHILD, CBLKNBR, 2*K+1) CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, & RCHILD, CBLKNBR, 2*K) END IF RANGTAB(1)=1 DO I=1, CBLKNBR RANGTAB(I+1) = RANGTAB(I)+SIZES(PERM(I)) END DO DEALLOCATE(PERM) RETURN CONTAINS RECURSIVE SUBROUTINE REC_TREETAB(TREETAB, PERM, SUBNODES, & ROOTN, CBLKNBR, K) INTEGER, POINTER :: TREETAB(:), PERM(:) INTEGER :: SUBNODES, ROOTN, K, CBLKNBR INTEGER :: LCHILD, RCHILD LCHILD = ROOTN - (SUBNODES+1)/2 RCHILD = ROOTN-1 PERM(LCHILD) = CBLKNBR+1 - (2*K+1) PERM(RCHILD) = CBLKNBR+1 - (2*K) TREETAB(RCHILD) = ROOTN TREETAB(LCHILD) = ROOTN IF(SUBNODES .GT. 3) THEN CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, LCHILD, & CBLKNBR, 2*K+1) CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, RCHILD, & CBLKNBR, 2*K) END IF END SUBROUTINE REC_TREETAB END SUBROUTINE CMUMPS_BUILD_TREETAB #endif #if defined(ptscotch) || defined(parmetis) || defined(parmetis3) SUBROUTINE CMUMPS_BUILD_DIST_GRAPH(id, ord, FIRST, LAST, IPE, & PE, WORK, LWORK) #if defined(DETERMINISTIC_PARALLEL_GRAPH) USE MUMPS_TOOLS_COMMON_M, ONLY : MUMPS_MERGESORT, & MUMPS_MERGESWAP1 #endif IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: FIRST(:), LAST(:), PE(:), & WORK(:) INTEGER(8), INTENT(IN) :: LWORK INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, OFFDIAG, & RCVPNT, PNT, SAVEPNT, DUPS, TOTDUPS INTEGER :: NROWS_LOC INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, POINTER :: MAPTAB(:) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: RDISPL(:), BUFLEVEL(:), & SIPES(:,:), LENG(:) INTEGER, POINTER :: TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER, PARAMETER :: ITAG=30 LOGICAL :: FLAG DOUBLE PRECISION :: SYMMETRY INTEGER(KIND=8) :: TLEN #if defined(DETERMINISTIC_PARALLEL_GRAPH) INTEGER :: L #endif nullify(MAPTAB, SNDCNT, RCVCNT) nullify(RDISPL, MSGCNT, SIPES, LENG, BUFLEVEL) nullify(TSENDI, TSENDJ, RCVBUF, APNT) MYID = ord%MYID NPROCS = ord%NPROCS IF(LWORK .LT. int(N,8)*2_8) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_SCOTCH_GRAPH")') CALL MUMPS_ABORT() END IF CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 BUFSIZE = 1000 BUFSIZE = id%KEEP(39) LOCNNZ = id%KEEP8(29) NROWS_LOC = LAST(MYID+1)-FIRST(MYID+1)+1 MAPTAB => WORK( 1 : N ) LENG => WORK( int(N+1,8) : 2_8*int(N,8) ) MAXS = 0 DO I=1, NPROCS IF((LAST(I)-FIRST(I)+1) .GT. MAXS) THEN MAXS = LAST(I)-FIRST(I)+1 END IF DO J=FIRST(I), LAST(I) MAPTAB(J) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 OFFDIAG=0 SIPES=0 DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN OFFDIAG = OFFDIAG+1 PROC = MAPTAB(id%IRN_loc(INNZ)) LOC_ROW = id%IRN_loc(INNZ)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 PROC = MAPTAB(id%JCN_loc(INNZ)) LOC_ROW = id%JCN_loc(INNZ)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF END DO CALL MPI_ALLREDUCE (OFFDIAG, id%KEEP8(127), 1, MPI_INTEGER8, & MPI_SUM, ord%COMM, IERR) id%KEEP8(127) = id%KEEP8(127)+3*N id%KEEP8(126) = id%KEEP8(127)-2*N CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, ord%COMM, IERR) CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, ord%COMM, IERR ) DEALLOCATE(SIPES) TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO CALL MUMPS_IREALLOC8(PE, max(IPE(NROWS_LOC+1)-1_8,1_8), id%INFO, & LP, STRING='PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ+RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO RCVPNT = 1 BUFLEVEL = 0 DO INNZ=1, LOCNNZ IF(mod(INNZ,int(BUFSIZE,8)/10_8) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, ord%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, ord%COMM, STATUS, IERR) CALL CMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%IRN_loc(INNZ)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%JCN_loc(INNZ) BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF PROC = MAPTAB(id%JCN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%JCN_loc(INNZ)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%IRN_loc(INNZ) BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF END IF END DO CALL CMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(MAPTAB(PE(INNZ)) .EQ. I) THEN DUPS = DUPS+1 ELSE MAPTAB(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO CALL MPI_REDUCE( DUPS, TOTDUPS, 1, MPI_INTEGER8, MPI_SUM, & 0, ord%COMM, IERR ) IF(MYID .EQ. 0) THEN SYMMETRY = dble(TOTDUPS)/(dble(id%KEEP8(28))-dble(N)) SYMMETRY = min(SYMMETRY,1.0d0) IF(id%KEEP(50) .GE. 1) SYMMETRY = 1.d0 IF(PROKG) WRITE(MPG,'(" Structural symmetry is:",i3,"%")') & ceiling(SYMMETRY*100.d0) id%INFOG(8) = ceiling(SYMMETRY*100.0d0) END IF IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) #if defined(DETERMINISTIC_PARALLEL_GRAPH) DO I=1, LAST(MYID+1)-FIRST(MYID+1)+1 L = int(IPE(I+1)-IPE(I)) CALL MUMPS_MERGESORT(L, & PE(IPE(I):IPE(I+1)-1), & WORK(:)) CALL MUMPS_MERGESWAP1(L, WORK(:), & PE(IPE(I):IPE(I+1)-1)) END DO #endif 90 continue RETURN END SUBROUTINE CMUMPS_BUILD_DIST_GRAPH #endif SUBROUTINE CMUMPS_BUILD_LOC_GRAPH(id, ord, GSIZE, IPE, PE, LENG, & I_HALO_MAP, top_graph, WORK, LWORK) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: PE(:), LENG(:), & I_HALO_MAP(:), WORK(:) INTEGER(8), INTENT(in) :: LWORK INTEGER :: GSIZE INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, TOP_CNT, TIDX, & RCVPNT INTEGER :: IIDX,JJDX INTEGER :: HALO_SIZE, NROWS_LOC, DUPS INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: MAPTAB(:), & HALO_MAP(:), BUFLEVEL(:) INTEGER, POINTER :: RDISPL(:), & SIPES(:,:) INTEGER, POINTER :: TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER(8) :: PNT, SAVEPNT INTEGER, PARAMETER :: ITAG=30 INTEGER(KIND=8) :: TLEN LOGICAL :: FLAG nullify(MAPTAB, SNDCNT, RCVCNT, HALO_MAP) nullify(RDISPL, MSGCNT, SIPES, BUFLEVEL) nullify(TSENDI, TSENDJ, RCVBUF, APNT) MYID = ord%MYID NPROCS = ord%NPROCS IF( LWORK .LT. int(N,8)*2_8 ) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_LOC_GRAPH")') CALL MUMPS_ABORT() END IF MAPTAB => WORK( 1 : N ) HALO_MAP => WORK(int(N+1,8) : 2_8*int(N,8)) CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 TOP_CNT = 0 BUFSIZE = 10000 BUFSIZE = id%KEEP(39) LOCNNZ = id%KEEP8(29) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 MAPTAB = 0 MAXS = 0 DO I=1, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) THEN MAXS = ord%LAST(I)-ord%FIRST(I)+1 END IF DO J=ord%FIRST(I), ord%LAST(I) MAPTAB(ord%PERITAB(J)) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SIPES(:,:) = 0 TOP_CNT = 0 DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%IRN_loc(INNZ)) LOC_ROW = IIDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF PROC = MAPTAB(id%JCN_loc(INNZ)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%JCN_loc(INNZ)) LOC_ROW = IIDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF END IF END DO CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, ord%COMM, IERR) I = ceiling(real(MAXS)*1.20E0) CALL MUMPS_REALLOC(LENG, max(I,1), id%INFO, & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, ord%COMM, IERR ) DEALLOCATE(SIPES) I = ceiling(real(NROWS_LOC+1)*1.20E0) CALL MUMPS_I8REALLOC(IPE, max(I,1), id%INFO, & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO CALL MUMPS_IREALLOC8(TSENDI, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(TSENDJ, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ + RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO CALL MUMPS_IREALLOC8(PE, max(NEW_LOCNNZ+ & 2_8*int(NROWS_LOC+ord%TOPNODES(2),8),1_8), & id%INFO, LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RCVPNT = 1 BUFLEVEL = 0 TIDX = 0 DO INNZ=1, LOCNNZ IF(mod(INNZ,int(BUFSIZE/10,8)) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, ord%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, ord%COMM, STATUS, IERR) CALL CMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) IF((MAPTAB(id%JCN_loc(INNZ)).NE.PROC) .AND. & (MAPTAB(id%JCN_loc(INNZ)).NE.0) .AND. & (PROC.NE.0)) THEN IERR = -50 id%INFO(1) = IERR END IF IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%IRN_loc(INNZ) TSENDJ(TIDX) = id%JCN_loc(INNZ) ELSE IIDX = ord%PERMTAB(id%IRN_loc(INNZ)) JJDX = ord%PERMTAB(id%JCN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1)=IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%JCN_loc(INNZ) END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF END IF PROC = MAPTAB(id%JCN_loc(INNZ)) IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%JCN_loc(INNZ) TSENDJ(TIDX) = id%IRN_loc(INNZ) ELSE IIDX = ord%PERMTAB(id%JCN_loc(INNZ)) JJDX = ord%PERMTAB(id%IRN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = & IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%IRN_loc(INNZ) END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF END IF END IF END DO CALL CMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB(:) = 0 HALO_MAP(:) = 0 HALO_SIZE = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(PE(INNZ) .LT. 0) THEN IF(HALO_MAP(-PE(INNZ)) .EQ. 0) THEN HALO_SIZE = HALO_SIZE+1 HALO_MAP(-PE(INNZ)) = NROWS_LOC+HALO_SIZE END IF PE(INNZ) = HALO_MAP(-PE(INNZ)) END IF IF(MAPTAB(PE(INNZ)) .EQ. I) THEN DUPS = DUPS+1 LENG(I) = LENG(I)-1 ELSE MAPTAB(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_REALLOC(I_HALO_MAP, HALO_SIZE, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT J=0 DO I=1, N IF(HALO_MAP(I) .GT. 0) THEN J = J+1 I_HALO_MAP(HALO_MAP(I)-NROWS_LOC) = I END IF IF(J .EQ. HALO_SIZE) EXIT END DO CALL MUMPS_REALLOC(LENG, max(NROWS_LOC+HALO_SIZE,1), id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:leng', MEMCNT=MEMCNT, ERRCODE=-7) LENG(NROWS_LOC+1:NROWS_LOC+HALO_SIZE) = 0 CALL MUMPS_I8REALLOC(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IPE(NROWS_LOC+2:NROWS_LOC+HALO_SIZE+1) = IPE(NROWS_LOC+1) GSIZE = NROWS_LOC + HALO_SIZE CALL MPI_GATHER(TOP_CNT, 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, 0, ord%COMM, IERR) IF(MYID.EQ.0) THEN NEW_LOCNNZ = sum(RCVCNT) top_graph%NZ_LOC = NEW_LOCNNZ CALL MUMPS_IREALLOC8(top_graph%IRN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(top_graph%JCN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1), & stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 END IF IF(MYID.EQ.0) THEN top_graph%IRN_LOC(1:TOP_CNT) = TSENDI(1:TOP_CNT) top_graph%JCN_LOC(1:TOP_CNT) = TSENDJ(1:TOP_CNT) DO PROC=2, NPROCS DO WHILE (RCVCNT(PROC) .GT. 0) I = int(min(int(BUFSIZE,8), RCVCNT(PROC))) CALL MPI_RECV(top_graph%IRN_LOC(TOP_CNT+1), I, & MPI_INTEGER, PROC-1, ITAG, ord%COMM, STATUS, IERR) CALL MPI_RECV(top_graph%JCN_LOC(TOP_CNT+1), I, & MPI_INTEGER, PROC-1, ITAG, ord%COMM, STATUS, IERR) RCVCNT(PROC) = RCVCNT(PROC)-I TOP_CNT = TOP_CNT+I END DO END DO ELSE DO WHILE (TOP_CNT .GT. 0) I = int(MIN(int(BUFSIZE,8), TOP_CNT)) CALL MPI_SEND(TSENDI(TOP_CNT-I+1), I, & MPI_INTEGER, 0, ITAG, ord%COMM, IERR) CALL MPI_SEND(TSENDJ(TOP_CNT-I+1), I, & MPI_INTEGER, 0, ITAG, ord%COMM, IERR) TOP_CNT = TOP_CNT-I END DO END IF CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, TSENDI, & TSENDJ, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) 90 continue RETURN END SUBROUTINE CMUMPS_BUILD_LOC_GRAPH SUBROUTINE CMUMPS_LUMAT_TO_LOC_GRAPH & (LUMAT, id, ord, GSIZE, IPE, PE, LENG, & I_HALO_MAP, WORK, LWORK) IMPLICIT NONE TYPE(LMATRIX_T), INTENT(IN) :: LUMAT TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: PE(:), LENG(:), & I_HALO_MAP(:), WORK(:) INTEGER(8), INTENT(IN) :: LWORK INTEGER :: GSIZE INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER :: ROWSIZE, IORIG, JORIG, PROCJ INTEGER(8) :: INNZ, NEW_LOCNNZ, RCVPNT INTEGER :: IIDX,JJDX INTEGER :: HALO_SIZE, NROWS_LOC INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: MAPTAB(:) INTEGER, POINTER :: HALO_MAP(:), BUFLEVEL(:) INTEGER, POINTER :: RDISPL(:), SIPES(:,:) INTEGER, POINTER :: RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER, PARAMETER :: ITAG=30 INTEGER(KIND=8) :: TLEN LOGICAL :: FLAG nullify(MAPTAB, SNDCNT, RCVCNT, HALO_MAP) nullify(RDISPL, MSGCNT, SIPES, BUFLEVEL) nullify( RCVBUF, APNT) MYID = ord%MYID NPROCS = ord%NPROCS IF ( LWORK .LT.2_8 * int(N,8) ) THEN WRITE(LP, & '("Insufficient workspace inside CMUMPS_LUMAT_TO_LOC_GRAPH")') CALL MUMPS_ABORT() END IF MAPTAB => WORK( 1 : N ) HALO_MAP => WORK( int(N+1,8) : 2_8*int(N,8)) CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 BUFSIZE = 10000 BUFSIZE = id%KEEP(39) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 MAPTAB = 0 MAXS = 0 DO I=1, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) THEN MAXS = ord%LAST(I)-ord%FIRST(I)+1 END IF DO J=ord%FIRST(I), ord%LAST(I) MAPTAB(ord%PERITAB(J)) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SIPES = 0 DO J =1, LUMAT%NBCOL_LOC ROWSIZE = LUMAT%COL(J)%NBINCOL JORIG = J + LUMAT%FIRST -1 PROC = MAPTAB(JORIG) IF(PROC .EQ. 0) CYCLE JJDX = ord%PERMTAB(JORIG) LOC_ROW = JJDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+ROWSIZE SNDCNT(PROC) = SNDCNT(PROC)+ROWSIZE ENDDO CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, ord%COMM, IERR) I = ceiling(real(MAXS)*1.20E0) CALL MUMPS_REALLOC(LENG, max(I,1), id%INFO, & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, ord%COMM, IERR ) DEALLOCATE(SIPES) I = ceiling(real(NROWS_LOC+1)*1.20E0) CALL MUMPS_I8REALLOC(IPE, max(I,1), id%INFO, & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ + RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO CALL MUMPS_IREALLOC8(PE, max(NEW_LOCNNZ+ & 2_8*int(NROWS_LOC+ord%TOPNODES(2),8),1_8), & id%INFO, LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RCVPNT = 1 BUFLEVEL = 0 INNZ = 1 DO I=1, LUMAT%NBCOL_LOC IF ( LUMAT%COL(I)%NBINCOL.EQ.0) CYCLE IORIG = I + LUMAT%FIRST -1 PROC = MAPTAB(IORIG) DO J=1, LUMAT%COL(I)%NBINCOL IF(mod(INNZ,int(BUFSIZE/10,8)) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, ord%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, ord%COMM, STATUS, IERR) CALL CMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF INNZ = INNZ +1 JORIG = LUMAT%COL(I)%IRN(J) PROCJ = MAPTAB(JORIG) IF((PROCJ.NE.PROC) .AND. & (PROC.NE.0) .AND. & (PROCJ.NE.0)) THEN IERR = -50 id%INFO(1) = IERR END IF IF (PROC.NE.0) THEN IIDX = ord%PERMTAB(IORIG) JJDX = ord%PERMTAB(JORIG) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1)=IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -JORIG END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF END IF ENDDO ENDDO CALL CMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) HALO_MAP(:) = 0 HALO_SIZE = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(PE(INNZ) .LT. 0) THEN IF(HALO_MAP(-PE(INNZ)) .EQ. 0) THEN HALO_SIZE = HALO_SIZE+1 HALO_MAP(-PE(INNZ)) = NROWS_LOC+HALO_SIZE END IF PE(INNZ) = HALO_MAP(-PE(INNZ)) END IF END DO END DO CALL MUMPS_REALLOC(I_HALO_MAP, HALO_SIZE, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT J=0 DO I=1, N IF(HALO_MAP(I) .GT. 0) THEN J = J+1 I_HALO_MAP(HALO_MAP(I)-NROWS_LOC) = I END IF IF(J .EQ. HALO_SIZE) EXIT END DO CALL MUMPS_REALLOC(LENG, max(NROWS_LOC+HALO_SIZE,1), id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:leng', MEMCNT=MEMCNT, ERRCODE=-7) LENG(NROWS_LOC+1:NROWS_LOC+HALO_SIZE) = 0 CALL MUMPS_I8REALLOC(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IPE(NROWS_LOC+2:NROWS_LOC+HALO_SIZE+1) = IPE(NROWS_LOC+1) GSIZE = NROWS_LOC + HALO_SIZE CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) 90 continue RETURN END SUBROUTINE CMUMPS_LUMAT_TO_LOC_GRAPH SUBROUTINE MUMPS_BUILD_TOP_GRAPH & (LUMAT, id, ord, top_graph, MAPTAB) IMPLICIT NONE TYPE(LMATRIX_T), INTENT(IN) :: LUMAT TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord TYPE(GRAPH_TYPE) :: top_graph INTEGER, POINTER :: MAPTAB(:) INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, PROCJ INTEGER :: ROWSIZE, IORIG, JORIG INTEGER(8) :: NEW_LOCNNZ, TOP_CNT, TIDX INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER(8), POINTER :: RCVCNT(:) INTEGER, POINTER :: TSENDI(:), TSENDJ(:) INTEGER :: BUFSIZE, allocok INTEGER, PARAMETER :: ITAG=30 nullify(RCVCNT,TSENDI,TSENDJ) MYID = ord%MYID NPROCS = ord%NPROCS MAPTAB = 0 DO I=1, NPROCS DO J=ord%FIRST(I), ord%LAST(I) MAPTAB(ord%PERITAB(J)) = I END DO END DO CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 TOP_CNT = 0 BUFSIZE = 10000 BUFSIZE = id%KEEP(39) TOP_CNT = 0 DO J =1, LUMAT%NBCOL_LOC JORIG = J + LUMAT%FIRST -1 PROC = MAPTAB(JORIG) IF(PROC .EQ. 0) THEN ROWSIZE = LUMAT%COL(J)%NBINCOL TOP_CNT = TOP_CNT+ROWSIZE ENDIF ENDDO CALL MUMPS_IREALLOC8(TSENDI, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(TSENDJ, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT TIDX = 0 DO I=1, LUMAT%NBCOL_LOC IF ( LUMAT%COL(I)%NBINCOL.EQ.0) CYCLE IORIG = I + LUMAT%FIRST -1 PROC = MAPTAB(IORIG) IF (PROC.NE.0) CYCLE DO J=1, LUMAT%COL(I)%NBINCOL JORIG = LUMAT%COL(I)%IRN(J) PROCJ = MAPTAB(JORIG) IF (PROCJ.EQ.0) THEN TIDX = TIDX+1 TSENDI(TIDX) = IORIG TSENDJ(TIDX) = JORIG ENDIF ENDDO ENDDO CALL MPI_GATHER(TIDX, 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, 0, ord%COMM, IERR) IF(MYID.EQ.0) THEN NEW_LOCNNZ = sum(RCVCNT) ELSE NEW_LOCNNZ = 0_8 ENDIF top_graph%NZ_LOC = NEW_LOCNNZ IF(MYID.EQ.0) THEN CALL MUMPS_IREALLOC8(top_graph%IRN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(top_graph%JCN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1), & stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=2 ENDIF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 IF(MYID.EQ.0) THEN top_graph%IRN_LOC(1:TIDX) = TSENDI(1:TIDX) top_graph%JCN_LOC(1:TIDX) = TSENDJ(1:TIDX) DO PROC=2, NPROCS DO WHILE (RCVCNT(PROC) .GT. 0) I = int(min(int(BUFSIZE,8), RCVCNT(PROC))) CALL MPI_RECV(top_graph%IRN_LOC(TIDX+1), I, & MPI_INTEGER, PROC-1, ITAG, ord%COMM, STATUS, IERR) CALL MPI_RECV(top_graph%JCN_LOC(TIDX+1), I, & MPI_INTEGER, PROC-1, ITAG, ord%COMM, STATUS, IERR) RCVCNT(PROC) = RCVCNT(PROC)-I TIDX = TIDX+I END DO END DO ELSE DO WHILE (TIDX .GT. 0) I = int(MIN(int(BUFSIZE,8), TIDX)) CALL MPI_SEND(TSENDI(TIDX-I+1), I, & MPI_INTEGER, 0, ITAG, ord%COMM, IERR) CALL MPI_SEND(TSENDJ(TIDX-I+1), I, & MPI_INTEGER, 0, ITAG, ord%COMM, IERR) TIDX = TIDX-I END DO END IF CALL MUMPS_DEALLOC( TSENDI, TSENDJ, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(RCVCNT, MEMCNT=MEMCNT) 90 continue RETURN END SUBROUTINE MUMPS_BUILD_TOP_GRAPH SUBROUTINE CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, COMM) IMPLICIT NONE INTEGER :: NPROCS, PROC, COMM, allocok TYPE(ARRPNT) :: APNT(:) INTEGER :: BUFSIZE INTEGER, POINTER :: RCVBUF(:), LENG(:), PE(:) INTEGER :: SNDCNT(:) INTEGER(8) :: MSGCNT(:), IPE(:) LOGICAL, SAVE :: INIT = .TRUE. INTEGER, POINTER, SAVE :: SPACE(:,:,:) LOGICAL, POINTER, SAVE :: PENDING(:) INTEGER, POINTER, SAVE :: REQ(:), CPNT(:) INTEGER :: IERR, MYID, I, SOURCE INTEGER(8) :: TOTMSG LOGICAL :: FLAG, TFLAG INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: TSTATUS(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30, FTAG=31 INTEGER, POINTER :: TMPI(:), RCVCNT(:) CALL MPI_COMM_RANK (COMM, MYID, IERR) CALL MPI_COMM_SIZE (COMM, NPROCS, IERR) IF(INIT) THEN ALLOCATE(SPACE(2*BUFSIZE, 2, NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of SPACE in CMUMPS_SEND_BUF" return ENDIF ALLOCATE(RCVBUF(2*BUFSIZE), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of RCVBUF in CMUMPS_SEND_BUF" return ENDIF ALLOCATE(PENDING(NPROCS), CPNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of PENDING/CPNT" & ," in CMUMPS_SEND_BUF" return ENDIF ALLOCATE(REQ(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of REQ in CMUMPS_SEND_BUF" return ENDIF PENDING = .FALSE. DO I=1, NPROCS APNT(I)%BUF => SPACE(:,1,I) CPNT(I) = 1 END DO INIT = .FALSE. RETURN END IF IF(PROC .EQ. -1) THEN TOTMSG = sum(MSGCNT) DO IF(TOTMSG .EQ. 0) EXIT CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, ITAG, COMM, STATUS, IERR) CALL CMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) SOURCE = STATUS(MPI_SOURCE) TOTMSG = TOTMSG-1 MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 END DO DO I=1, NPROCS IF(PENDING(I)) THEN CALL MPI_WAIT(REQ(I), TSTATUS, IERR) END IF END DO ALLOCATE(RCVCNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of RCVCNT in CMUMPS_SEND_BUF" return ENDIF CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, COMM, IERR) DO I=1, NPROCS IF(SNDCNT(I) .GT. 0) THEN TMPI => APNT(I)%BUF(:) CALL MPI_ISEND(TMPI(1), 2*SNDCNT(I), MPI_INTEGER, I-1, & FTAG, COMM, REQ(I), IERR) END IF END DO DO I=1, NPROCS IF(RCVCNT(I) .GT. 0) THEN CALL MPI_RECV(RCVBUF(1), 2*RCVCNT(I), MPI_INTEGER, I-1, & FTAG, COMM, STATUS, IERR) CALL CMUMPS_ASSEMBLE_MSG(RCVCNT(I), RCVBUF, & IPE, PE, LENG) END IF END DO DO I=1, NPROCS IF(SNDCNT(I) .GT. 0) THEN CALL MPI_WAIT(REQ(I), TSTATUS, IERR) END IF END DO DEALLOCATE(SPACE) DEALLOCATE(PENDING, CPNT) DEALLOCATE(REQ) DEALLOCATE(RCVBUF, RCVCNT) nullify(SPACE, PENDING, CPNT, REQ, RCVBUF, RCVCNT) INIT = .TRUE. RETURN END IF IF(PENDING(PROC)) THEN DO CALL MPI_TEST(REQ(PROC), TFLAG, TSTATUS, IERR) IF(TFLAG) THEN PENDING(PROC) = .FALSE. EXIT ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, & SOURCE, ITAG, COMM, STATUS, IERR) CALL CMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, & PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 END IF END IF END DO END IF TMPI => APNT(PROC)%BUF(:) CALL MPI_ISEND(TMPI(1), 2*BUFSIZE, MPI_INTEGER, PROC-1, & ITAG, COMM, REQ(PROC), IERR) PENDING(PROC) = .TRUE. CPNT(PROC) = mod(CPNT(PROC),2)+1 APNT(PROC)%BUF => SPACE(:,CPNT(PROC),PROC) SNDCNT(PROC) = 0 RETURN END SUBROUTINE CMUMPS_SEND_BUF SUBROUTINE CMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) IMPLICIT NONE INTEGER :: BUFSIZE INTEGER :: RCVBUF(:), PE(:), LENG(:) INTEGER(8) :: IPE(:) INTEGER :: I, ROW, COL DO I=1, 2*BUFSIZE, 2 ROW = RCVBUF(I) COL = RCVBUF(I+1) PE(IPE(ROW)+LENG(ROW)) = COL LENG(ROW) = LENG(ROW) + 1 END DO RETURN END SUBROUTINE CMUMPS_ASSEMBLE_MSG #if defined(ptscotch) || defined(parmetis) || defined(parmetis3) SUBROUTINE CMUMPS_BUILD_TREE(ord) TYPE(ORD_TYPE) :: ord INTEGER :: I ord%SON = -1 ord%BROTHER = -1 ord%NW = 0 DO I=1, ord%CBLKNBR ord%NW(I) = ord%NW(I)+ord%RANGTAB(I+1) - ord%RANGTAB(I) IF (ord%TREETAB(I) .NE. -1) THEN IF (ord%SON(ord%TREETAB(I)) .EQ. -1) THEN ord%SON(ord%TREETAB(I)) = I ELSE ord%BROTHER(I) = ord%SON(ord%TREETAB(I)) ord%SON(ord%TREETAB(I)) = I END IF ord%NW(ord%TREETAB(I)) = ord%NW(ord%TREETAB(I))+ ord%NW(I) END IF END DO RETURN END SUBROUTINE CMUMPS_BUILD_TREE SUBROUTINE CMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK, LWORK, TYPE) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: FIRST(:), LAST(:), BASE, NPROCS, TYPE INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK INTEGER, POINTER :: TMP(:), NZ_ROW(:) INTEGER :: I, IERR, P, F, J INTEGER(8) :: LOCNNZ, INNZ, LOCOFFDIAG, & OFFDIAG, T, SHARE DO I=0, BASE-1 FIRST(I+1) = 0 LAST(I+1) = -1 END DO IF(TYPE.EQ.1) THEN SHARE = int(N/ord%NPROCS_PARAORD,8) DO I=1, ord%NPROCS_PARAORD FIRST(BASE+I) = (I-1)*int(SHARE)+1 LAST (BASE+I) = (I)*int(SHARE) END DO LAST(BASE+ord%NPROCS_PARAORD) = & MAX(LAST(BASE+ord%NPROCS_PARAORD), N) DO I = ord%NPROCS_PARAORD+1, id%NSLAVES+1 FIRST(BASE+I) = N+1 LAST (BASE+I) = N END DO ELSE IF (TYPE.EQ.2) THEN IF (LWORK .LT. 2_8*int(N,8)) THEN WRITE(*,*) "Insufficient workspace in CMUMPS_GRAPH_DIST" CALL MUMPS_ABORT() ENDIF TMP => WORK(1:N) NZ_ROW => WORK(int(N+1,8):2-8*int(N,8)) TMP = 0 LOCOFFDIAG = 0_8 LOCNNZ = id%KEEP8(29) DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN TMP(id%IRN_loc(INNZ)) = TMP(id%IRN_loc(INNZ))+1 LOCOFFDIAG = LOCOFFDIAG+1 IF(id%SYM.GT.0) THEN TMP(id%JCN_loc(INNZ)) = TMP(id%JCN_loc(INNZ))+1 LOCOFFDIAG = LOCOFFDIAG+1 END IF END IF END DO CALL MUMPS_BIGALLREDUCE(.FALSE., TMP(1), NZ_ROW(1), N, & MPI_INTEGER, MPI_SUM, ord%COMM, IERR) CALL MPI_ALLREDUCE(LOCOFFDIAG, OFFDIAG, 1, & MPI_INTEGER8, MPI_SUM, ord%COMM, IERR) nullify(TMP) SHARE = (OFFDIAG-1_8)/int(ord%NPROCS_PARAORD,8) + 1_8 P = 0 T = 0_8 F = 1 DO I=1, N T = T+int(NZ_ROW(I),8) IF ( & (T .GE. SHARE) .OR. & ((N-I).EQ.(ord%NPROCS_PARAORD-P-1)) .OR. & (I.EQ.N) & ) THEN P = P+1 IF(P.EQ.ord%NPROCS_PARAORD) THEN FIRST(BASE+P) = F LAST(BASE+P) = N EXIT ELSE FIRST(BASE+P) = F LAST(BASE+P) = I F = I+1 T = 0_8 END IF END IF END DO DO J=P+1, NPROCS+1-BASE FIRST(BASE+J) = N+1 LAST(BASE+J) = N END DO END IF RETURN END SUBROUTINE CMUMPS_GRAPH_DIST #endif FUNCTION MUMPS_GETSIZE(A) INTEGER, POINTER :: A(:) INTEGER :: MUMPS_GETSIZE IF(associated(A)) THEN MUMPS_GETSIZE = size(A) ELSE MUMPS_GETSIZE = 0_8 END IF RETURN END FUNCTION MUMPS_GETSIZE #if defined(parmetis) || defined(parmetis3) SUBROUTINE MUMPS_PARMETIS_MIXEDto32(id, & BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & VELOLOCTAB, SIZE_VELOLOCTAB, & SIZES, COMM, MYID, IERR) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:) INTEGER :: SIZES(:), ORDER(:) INTEGER(8) :: VERTLOCTAB(:) INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, MYID, & BASE INTEGER :: VELOLOCTAB(:) INTEGER :: SIZE_VELOLOCTAB INTEGER, POINTER :: VERTLOCTAB_I4(:) IF( VERTLOCTAB(VERTLOCNBR+1).GT.huge(VERTLOCNBR)) THEN id%INFO(1) = -51 CALL MUMPS_SET_IERROR( & VERTLOCTAB(VERTLOCNBR+1), id%INFO(2)) RETURN END IF nullify(VERTLOCTAB_I4) CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1), & VERTLOCNBR+1, VERTLOCTAB_I4(1)) IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_PARMETIS_VWGT(FIRST(1+BASE), VERTLOCTAB_I4(1), & EDGELOCTAB(1), BASEVAL, OPTIONS(1), ORDER(1), & SIZES(1), COMM, VELOLOCTAB(1), IERR) ELSE CALL MUMPS_PARMETIS(FIRST(1+BASE), VERTLOCTAB_I4(1), & EDGELOCTAB(1), BASEVAL, OPTIONS(1), ORDER(1), & SIZES(1), COMM, IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT) RETURN END SUBROUTINE MUMPS_PARMETIS_MIXEDto32 SUBROUTINE MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & VELOLOCTAB, SIZE_VELOLOCTAB, & SIZES, COMM, MYID, IERR) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:) INTEGER :: SIZES(:), ORDER(:) INTEGER(8) :: VERTLOCTAB(:) INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, MYID, & BASE INTEGER :: VELOLOCTAB(:) INTEGER :: SIZE_VELOLOCTAB INTEGER(8), POINTER :: FIRST_I8(:), EDGELOCTAB_I8(:), & SIZES_I8(:), ORDER_I8(:), VELOLOCTAB_I8(:) INTEGER(8) :: VERTLOCNBR_I8 #if defined(parmetis) INTEGER(8), POINTER :: OPTIONS_I8(:) INTEGER(8) :: BASEVAL_I8 nullify(OPTIONS_I8) IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8REALLOC(OPTIONS_I8, size(OPTIONS), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64(OPTIONS(1), size(OPTIONS) & , OPTIONS_I8(1)) BASEVAL_I8 = int(BASEVAL,8) END IF #endif nullify(FIRST_I8, EDGELOCTAB_I8, SIZES_I8, ORDER_I8, & VELOLOCTAB_I8) IF (id%KEEP(10).EQ.1) THEN IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_PARMETIS_VWGT_64(FIRST(1+BASE), VERTLOCTAB(1), & EDGELOCTAB(1), & BASEVAL, OPTIONS(1), & ORDER(1), & SIZES(1), COMM, VELOLOCTAB(1), IERR) ELSE CALL MUMPS_PARMETIS_64(FIRST(1+BASE), VERTLOCTAB(1), & EDGELOCTAB(1), & BASEVAL, OPTIONS(1), & ORDER(1), & SIZES(1), COMM, IERR) ENDIF ELSE CALL MUMPS_I8REALLOC(FIRST_I8, size(FIRST), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_I8REALLOC(VELOLOCTAB_I8, VERTLOCNBR, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 ENDIF CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8, & VERTLOCTAB(VERTLOCNBR+1)-1_8, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(SIZES_I8, size(SIZES), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(ORDER_I8, size(ORDER), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 5 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64(FIRST(1), size(FIRST), FIRST_I8(1)) CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1), & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1)) IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN VERTLOCNBR_I8 = int(VERTLOCNBR,8) CALL MUMPS_ICOPY_32TO64_64C(VELOLOCTAB(1), & VERTLOCNBR_I8, VELOLOCTAB_I8(1)) ENDIF IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_PARMETIS_VWGT_64(FIRST_I8(1+BASE), VERTLOCTAB(1), & EDGELOCTAB_I8(1), #if defined(parmetis3) & BASEVAL, OPTIONS(1), #else & BASEVAL_I8, OPTIONS_I8(1), #endif & ORDER_I8(1), & SIZES_I8(1), COMM, VELOLOCTAB_I8(1), & IERR) ELSE CALL MUMPS_PARMETIS_64(FIRST_I8(1+BASE), VERTLOCTAB(1), & EDGELOCTAB_I8(1), #if defined(parmetis3) & BASEVAL, OPTIONS(1), #else & BASEVAL_I8, OPTIONS_I8(1), #endif & ORDER_I8(1), & SIZES_I8(1), COMM, IERR) ENDIF END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF ( id%KEEP(10) .NE. 1 ) THEN CALL MUMPS_ICOPY_64TO32(ORDER_I8(1), & size(ORDER), ORDER(1)) CALL MUMPS_ICOPY_64TO32(SIZES_I8(1), & size(SIZES), SIZES(1)) ENDIF 10 CONTINUE CALL MUMPS_I8DEALLOC(FIRST_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(SIZES_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(ORDER_I8, MEMCNT=MEMCNT) IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) & CALL MUMPS_I8DEALLOC(VELOLOCTAB_I8, MEMCNT=MEMCNT) #if defined(parmetis) CALL MUMPS_I8DEALLOC(OPTIONS_I8, MEMCNT=MEMCNT) #endif RETURN END SUBROUTINE MUMPS_PARMETIS_MIXEDto64 #endif #if defined(ptscotch) SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & VELOLOCTAB, SIZE_VELOLOCTAB, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, LCONTDAT, #endif & IERR) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: BASEVAL, VERTLOCNBR INTEGER(8) :: EDGELOCNBR INTEGER(8) :: VERTLOCTAB(:) INTEGER :: EDGELOCTAB(:) INTEGER :: VELOLOCTAB(:) INTEGER, INTENT(IN) :: SIZE_VELOLOCTAB INTEGER :: IERR INTEGER, POINTER :: VERTLOCTAB_I4(:) INTEGER :: EDGELOCNBR_I4, MYWORKID DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) INTEGER :: LCONTDAT DOUBLE PRECISION :: CONTDAT(LCONTDAT) DOUBLE PRECISION :: GRAPHDAT_BEFORE_CONTEXT(SCOTCH_DGRAPHDIM) #endif IF (.NOT.ord%IDO) RETURN nullify(VERTLOCTAB_I4) CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1), & VERTLOCNBR+1, VERTLOCTAB_I4(1)) EDGELOCNBR_I4 = int(EDGELOCNBR) IF(ord%SUBSTRAT .NE. 0) THEN STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// & 'proc=1,seq=q{strat=m{type=h,vert=100,'// & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' END IF IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, MYWORKID, IERR) ELSE MYWORKID = -1 END IF #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL MUMPS_DGRAPHINIT(GRAPHDAT_BEFORE_CONTEXT, ord%COMM_PARAORD, & IERR) CALL SCOTCHFCONTEXTBINDDGRAPH(CONTDAT, GRAPHDAT_BEFORE_CONTEXT, & GRAPHDAT, IERR) #else CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_PARAORD, IERR) #endif IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB_I4(1), VERTLOCTAB_I4(2), & VELOLOCTAB(1), VERTLOCTAB_I4(1), EDGELOCNBR_I4, & EDGELOCNBR_I4, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ELSE CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB_I4(1), VERTLOCTAB_I4(2), & VERTLOCTAB_I4(1), VERTLOCTAB_I4(1), EDGELOCNBR_I4, & EDGELOCNBR_I4, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(ord%SUBSTRAT .NE. 0) THEN CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR, & ord%RANGTAB(1), ord%TREETAB(1), IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT_BEFORE_CONTEXT) #endif 10 CONTINUE CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT) RETURN END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32 SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & VELOLOCTAB, SIZE_VELOLOCTAB, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, LCONTDAT, #endif & IERR) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: BASEVAL, VERTLOCNBR INTEGER(8) :: EDGELOCNBR INTEGER(8) :: VERTLOCTAB(:) INTEGER :: EDGELOCTAB(:) INTEGER :: VELOLOCTAB(:) INTEGER, INTENT(IN) :: SIZE_VELOLOCTAB INTEGER :: IERR INTEGER :: MYWORKID DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) INTEGER :: LCONTDAT DOUBLE PRECISION :: CONTDAT(LCONTDAT) DOUBLE PRECISION :: GRAPHDAT_BEFORE_CONTEXT(SCOTCH_DGRAPHDIM) #endif INTEGER(8), POINTER :: EDGELOCTAB_I8(:), PERMTAB_I8(:), & PERITAB_I8(:), RANGTAB_I8(:), TREETAB_I8(:), VELOLOCTAB_I8(:) INTEGER(8) :: CBLKNBR_I8, VERTLOCNBR_I8, BASEVAL_I8 IF(ord%SUBSTRAT .NE. 0) THEN STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// & 'proc=1,seq=q{strat=m{type=h,vert=100,'// & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' END IF IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, MYWORKID, IERR) ELSE MYWORKID = -1 END IF nullify(EDGELOCTAB_I8, PERMTAB_I8, PERITAB_I8, & RANGTAB_I8, TREETAB_I8, VELOLOCTAB_I8) IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8, & VERTLOCTAB(VERTLOCNBR+1)-1_8, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_I8REALLOC(VELOLOCTAB_I8, VERTLOCNBR, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 ENDIF IF (MYWORKID .EQ. 0) THEN CALL MUMPS_I8REALLOC(PERMTAB_I8, size(ord%PERMTAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(PERITAB_I8, size(ord%PERITAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(TREETAB_I8, size(ord%TREETAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(RANGTAB_I8, size(ord%RANGTAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) END IF 5 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1), & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1)) VERTLOCNBR_I8 = int(VERTLOCNBR,8) IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_ICOPY_32TO64_64C(VELOLOCTAB(1), & VERTLOCNBR_I8, VELOLOCTAB_I8(1)) ENDIF BASEVAL_I8 = int(BASEVAL,8) ENDIF #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL MUMPS_DGRAPHINIT(GRAPHDAT_BEFORE_CONTEXT, ord%COMM_PARAORD, & IERR) CALL SCOTCHFCONTEXTBINDDGRAPH(CONTDAT, GRAPHDAT_BEFORE_CONTEXT, & GRAPHDAT, IERR) #else CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_PARAORD, IERR) #endif IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL_I8, VERTLOCNBR_I8, & VERTLOCNBR_I8, VERTLOCTAB(1), VERTLOCTAB(2), & VELOLOCTAB_I8(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB_I8(1), EDGELOCTAB_I8(1), & EDGELOCTAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), & VELOLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ENDIF ELSE IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL_I8, VERTLOCNBR_I8, & VERTLOCNBR_I8, VERTLOCTAB(1), VERTLOCTAB(2), & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB_I8(1), EDGELOCTAB_I8(1), & EDGELOCTAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ENDIF ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(ord%SUBSTRAT .NE. 0) THEN CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & PERMTAB_I8(1), PERITAB_I8(1), CBLKNBR_I8, RANGTAB_I8(1), & TREETAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR, & ord%RANGTAB(1),ord%TREETAB(1), IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT_BEFORE_CONTEXT) #endif 10 CONTINUE IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT) IF (SIZE_VELOLOCTAB.GT.0) & CALL MUMPS_I8DEALLOC(VELOLOCTAB_I8, MEMCNT=MEMCNT) IF(MYWORKID .EQ. 0) THEN CALL MUMPS_ICOPY_64TO32(PERMTAB_I8(1), & size(ord%PERMTAB), ord%PERMTAB(1)) CALL MUMPS_ICOPY_64TO32(PERITAB_I8(1), & size(ord%PERITAB), ord%PERITAB(1)) CALL MUMPS_ICOPY_64TO32(TREETAB_I8(1), & size(ord%TREETAB), ord%TREETAB(1)) CALL MUMPS_ICOPY_64TO32(RANGTAB_I8(1), & size(ord%RANGTAB), ord%RANGTAB(1)) ord%CBLKNBR = int(CBLKNBR_I8) CALL MUMPS_I8DEALLOC(PERMTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(PERITAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(RANGTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(TREETAB_I8, MEMCNT=MEMCNT) END IF ENDIF RETURN END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64 #endif END MODULE MUMPS_5.8.1/src/zmumps_intr_types.F0000664000175000017500000001077015042446442017161 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_INTR_TYPES USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC PRIVATE PUBLIC :: ZMUMPS_ROOT_STRUC, & ZMUMPS_L0OMPFAC_T, & ZMUMPS_INTR_STRUC, & ZMUMPS_INIT_INTR_ENCODING, & ZMUMPS_FREE_INTR_ENCODING, & ZMUMPS_ENCODE_INTR, & ZMUMPS_DECODE_INTR C ZMUMPS_ROOT_STRUC no longer contains INTEGERS TYPE ZMUMPS_ROOT_STRUC ! 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 ! 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 ! for SVD on root (#define try_null_space) COMPLEX(kind=8), DIMENSION(:,:), POINTER :: SVD_U, SVD_VT ! for RR on root (#define try_null_space) DOUBLE PRECISION, DIMENSION(:), POINTER :: SINGULAR_VALUES ! END TYPE ZMUMPS_ROOT_STRUC ! multicore TYPE ZMUMPS_L0OMPFAC_T COMPLEX(kind=8), POINTER, DIMENSION(:) :: A INTEGER(8) :: LA END TYPE ZMUMPS_L0OMPFAC_T C C All MUMPS internal datatypes are in an internal structure: TYPE ZMUMPS_INTR_STRUC TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota TYPE (ZMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & L0_OMP_FACTORS END TYPE ZMUMPS_INTR_STRUC C ================================================================= CONTAINS C ================================================================= SUBROUTINE ZMUMPS_INIT_INTR_ENCODING(id_intr_ENCODING) IMPLICIT NONE CHARACTER, DIMENSION(:), POINTER :: id_intr_ENCODING C To be called only before JOB=-1 NULLIFY(id_intr_ENCODING) END SUBROUTINE ZMUMPS_INIT_INTR_ENCODING C ================================================================= SUBROUTINE ZMUMPS_FREE_INTR_ENCODING(id_intr_ENCODING) IMPLICIT NONE CHARACTER, DIMENSION(:), POINTER :: id_intr_ENCODING C To be called only after JOB=-2 DEALLOCATE(id_intr_ENCODING) NULLIFY(id_intr_ENCODING) RETURN END SUBROUTINE ZMUMPS_FREE_INTR_ENCODING C ================================================================= SUBROUTINE ZMUMPS_ENCODE_INTR(id_intr_ENCODING, id_intr) IMPLICIT NONE C C Arguments: C ========= CHARACTER, DIMENSION(:), POINTER :: id_intr_ENCODING TYPE (ZMUMPS_INTR_STRUC) :: id_intr C C Local variables: C =============== CHARACTER :: CHAR_ARRAY(1) INTEGER :: CHAR_LENGTH, IERR C IF (associated(id_intr_ENCODING)) THEN C Should be unassociated on entry WRITE(*,*) "Internal error in ZMUMPS_ENCODE_INTR:", & " id_intr_ENCODING already allocated" CALL MUMPS_ABORT() ENDIF CHAR_LENGTH=size(transfer(id_intr,CHAR_ARRAY)) ALLOCATE(id_intr_ENCODING(CHAR_LENGTH), stat=IERR) IF (IERR > 0 ) THEN WRITE(*,*) "Allocation error in MUMPS_ENCODE_INTR" CALL MUMPS_ABORT() ENDIF C Fill with derived datatype id_intr_ENCODING=transfer(id_intr,CHAR_ARRAY) RETURN END SUBROUTINE ZMUMPS_ENCODE_INTR C ================================================================= SUBROUTINE ZMUMPS_DECODE_INTR(id_intr_ENCODING, id_intr) IMPLICIT NONE CHARACTER(len=1), DIMENSION(:), POINTER :: id_intr_ENCODING TYPE (ZMUMPS_INTR_STRUC) :: id_intr IF (.NOT.associated(id_intr_ENCODING)) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_DECODE_INTR" CALL MUMPS_ABORT() ENDIf id_intr=transfer(id_intr_ENCODING,id_intr) DEALLOCATE(id_intr_ENCODING) NULLIFY(id_intr_ENCODING) RETURN END SUBROUTINE ZMUMPS_DECODE_INTR END MODULE ZMUMPS_INTR_TYPES MUMPS_5.8.1/src/zfac_type3_symmetrize.F0000664000175000017500000001374015042446441017704 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SYMMETRIZE( BUF, BLOCK_SIZE, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, COMM ) IMPLICIT NONE INTEGER BLOCK_SIZE, NPROW, NPCOL, LOCAL_M, LOCAL_N, N, COMM INTEGER MYROW, MYCOL, MYID COMPLEX(kind=8) BUF( BLOCK_SIZE * BLOCK_SIZE ) COMPLEX(kind=8) A( LOCAL_M, LOCAL_N ) INTEGER NBLOCK, IBLOCK, JBLOCK, IBLOCK_SIZE, JBLOCK_SIZE INTEGER ROW_SOURCE, ROW_DEST, COL_SOURCE, COL_DEST INTEGER IGLOB, JGLOB INTEGER IROW_LOC_SOURCE, JCOL_LOC_SOURCE INTEGER IROW_LOC_DEST, JCOL_LOC_DEST INTEGER PROC_SOURCE, PROC_DEST NBLOCK = ( N - 1 ) / BLOCK_SIZE + 1 DO IBLOCK = 1, NBLOCK IF ( IBLOCK .NE. NBLOCK & ) THEN IBLOCK_SIZE = BLOCK_SIZE ELSE IBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE END IF ROW_SOURCE = mod( IBLOCK - 1, NPROW ) COL_DEST = mod( IBLOCK - 1, NPCOL ) IGLOB = ( IBLOCK - 1 ) * BLOCK_SIZE + 1 IROW_LOC_SOURCE = BLOCK_SIZE * & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 JCOL_LOC_DEST = BLOCK_SIZE * & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 DO JBLOCK = 1, IBLOCK IF ( JBLOCK .NE. NBLOCK & ) THEN JBLOCK_SIZE = BLOCK_SIZE ELSE JBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE END IF COL_SOURCE = mod( JBLOCK - 1, NPCOL ) ROW_DEST = mod( JBLOCK - 1, NPROW ) PROC_SOURCE = ROW_SOURCE * NPCOL + COL_SOURCE PROC_DEST = ROW_DEST * NPCOL + COL_DEST IF ( PROC_SOURCE .eq. PROC_DEST ) THEN IF ( MYID .eq. PROC_DEST ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 JCOL_LOC_SOURCE = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 IROW_LOC_DEST = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 IF ( IBLOCK .eq. JBLOCK ) THEN IF ( IBLOCK_SIZE .ne. JBLOCK_SIZE ) THEN WRITE(*,*) MYID,': Error in calling transdiag:unsym' CALL MUMPS_ABORT() END IF CALL ZMUMPS_TRANS_DIAG( A( IROW_LOC_SOURCE, & JCOL_LOC_SOURCE), & IBLOCK_SIZE, LOCAL_M ) ELSE CALL ZMUMPS_TRANSPO( & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), & A( IROW_LOC_DEST, JCOL_LOC_DEST ), & IBLOCK_SIZE, JBLOCK_SIZE, LOCAL_M ) END IF END IF ELSE IF ( MYROW .eq. ROW_SOURCE & .AND. MYCOL .eq. COL_SOURCE ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 JCOL_LOC_SOURCE = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 CALL ZMUMPS_SEND_BLOCK( BUF, & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), LOCAL_M, & IBLOCK_SIZE, JBLOCK_SIZE, COMM, PROC_DEST ) ELSE IF ( MYROW .eq. ROW_DEST & .AND. MYCOL .eq. COL_DEST ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 IROW_LOC_DEST = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 CALL ZMUMPS_RECV_BLOCK( BUF, & A( IROW_LOC_DEST, JCOL_LOC_DEST ), LOCAL_M, & JBLOCK_SIZE, IBLOCK_SIZE, COMM, PROC_SOURCE ) END IF END DO END DO RETURN END SUBROUTINE ZMUMPS_SYMMETRIZE SUBROUTINE ZMUMPS_SEND_BLOCK( BUF, A, LDA, M, N, COMM, DEST ) IMPLICIT NONE INTEGER M, N, LDA, DEST, COMM COMPLEX(kind=8) BUF(*), A(LDA,*) INTEGER I, IBUF, IERR INTEGER J INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IBUF = 1 DO J = 1, N BUF( IBUF: IBUF + M - 1 ) = A( 1 : M, J ) DO I = 1, M END DO IBUF = IBUF + M END DO CALL MPI_SEND( BUF, M * N, MPI_DOUBLE_COMPLEX, & DEST, SYMMETRIZE, COMM, IERR ) RETURN END SUBROUTINE ZMUMPS_SEND_BLOCK SUBROUTINE ZMUMPS_RECV_BLOCK( BUF, A, LDA, M, N, COMM, SOURCE ) IMPLICIT NONE INTEGER LDA, M, N, COMM, SOURCE COMPLEX(kind=8) BUF(*), A( LDA, *) INTEGER I, IBUF, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) CALL MPI_RECV( BUF(1), M * N, MPI_DOUBLE_COMPLEX, SOURCE, & SYMMETRIZE, COMM, STATUS, IERR ) IBUF = 1 DO I = 1, M CALL zcopy( N, BUF(IBUF), 1, A(I,1), LDA ) IBUF = IBUF + N END DO RETURN END SUBROUTINE ZMUMPS_RECV_BLOCK SUBROUTINE ZMUMPS_TRANS_DIAG( A, N, LDA ) IMPLICIT NONE INTEGER N,LDA COMPLEX(kind=8) A( LDA, * ) INTEGER I, J DO I = 2, N DO J = 1, I - 1 A( J, I ) = A( I, J ) END DO END DO RETURN END SUBROUTINE ZMUMPS_TRANS_DIAG SUBROUTINE ZMUMPS_TRANSPO( A1, A2, M, N, LD ) IMPLICIT NONE INTEGER M,N,LD COMPLEX(kind=8) A1( LD,* ), A2( LD, * ) INTEGER I, J DO J = 1, N DO I = 1, M A2( J, I ) = A1( I, J ) END DO END DO RETURN END SUBROUTINE ZMUMPS_TRANSPO MUMPS_5.8.1/src/dfac_distrib_distentry.F0000664000175000017500000007462115042446440020073 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_BUILD_MAPPING & ( N, MAPPING, NNZ, IRN, JCN, PROCNODE, STEP, & SLAVEF, PERM, FILS, & RG2L, KEEP,KEEP8, MBLOCK, NBLOCK, NPROW, NPCOL ) USE DMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, SLAVEF, MBLOCK, NBLOCK, NPROW, NPCOL iNTEGER(8) :: NNZ INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN( NNZ ), JCN( NNZ ) INTEGER MAPPING( NNZ ), STEP( N ) INTEGER PROCNODE( KEEP(28) ), PERM( N ), FILS( N ), RG2L( N ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE INTEGER K4, IOLD, JOLD, INEW, JNEW, ISEND, JSEND, IARR, INODE INTEGER(8) :: K8 INTEGER TYPE_NODE, DEST INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INODE = KEEP(38) K4 = 1 DO WHILE ( INODE .GT. 0 ) RG2L( INODE ) = K4 INODE = FILS( INODE ) K4 = K4 + 1 END DO DO K8 = 1_8, NNZ IOLD = IRN( K8 ) JOLD = JCN( K8 ) IF ( IOLD .GT. N .OR. IOLD .LT. 1 .OR. & JOLD .GT. N .OR. JOLD .LT. 1 ) THEN MAPPING( K8 ) = -1 CYCLE END IF IF ( IOLD .eq. JOLD ) THEN ISEND = IOLD JSEND = JOLD ELSE INEW = PERM( IOLD ) JNEW = PERM( JOLD ) IF ( INEW .LT. JNEW ) THEN ISEND = IOLD IF ( KEEP(50) .ne. 0 ) ISEND = -IOLD JSEND = JOLD ELSE ISEND = -JOLD JSEND = IOLD END IF END IF IARR = abs( ISEND ) TYPE_NODE = MUMPS_TYPENODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) + 1 ELSE DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) END IF ELSE IF ( ISEND .LT. 0 ) THEN IPOSROOT = RG2L( JSEND ) JPOSROOT = RG2L( IARR ) ELSE IPOSROOT = RG2L( IARR ) JPOSROOT = RG2L( JSEND ) END IF IROW_GRID = mod( ( IPOSROOT - 1 )/MBLOCK, NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/NBLOCK, NPCOL ) IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = IROW_GRID * NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * NPCOL + JCOL_GRID END IF END IF MAPPING( K8 ) = DEST END DO RETURN END SUBROUTINE DMUMPS_BUILD_MAPPING SUBROUTINE DMUMPS_REDISTRIBUTION( & N, NZ_loc8, id, & DBLARR, LDBLARR, INTARR, LINTARR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & FILS, KEEP,KEEP8, MYID, COMM, NBRECORDS, & & A, LA, root, roota, PROCNODE_STEPS, SLAVEF, PERM, STEP, & ICNTL, INFO, NSEND8, NLOCAL8, & ISTEP_TO_INIV2, CANDIDATES & ) !$ USE OMP_LIB USE DMUMPS_STRUC_DEF, ONLY: DMUMPS_STRUC USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N INTEGER(8) :: NZ_loc8 TYPE (DMUMPS_STRUC) :: id INTEGER(8) :: LDBLARR, LINTARR DOUBLE PRECISION DBLARR( LDBLARR ) INTEGER INTARR( LINTARR ) INTEGER KEEP(500) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER(8) KEEP8(150) INTEGER, INTENT(IN) :: FILS( N ) 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 (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER PROCNODE_STEPS(KEEP(28)), PERM( N ), STEP( N ) INTEGER INFO( 80 ), ICNTL(60) INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: IERR, MSGSOU INTEGER :: STATUS(MPI_STATUS_SIZE) DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: PTRAW INTEGER END_MSG_2_RECV INTEGER I, J INTEGER(8) :: IS8 INTEGER(8) :: K8 INTEGER :: IARR1, IORG INTEGER TYPE_NODE, DEST, DEST_SHR INTEGER IOLD, JOLD, IARR, ISEND, JSEND INTEGER ISEND_SHR, JSEND_SHR INTEGER allocok, TYPESPLIT, T4MASTER, INIV2, NCAND LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS DOUBLE PRECISION VAL, VAL_SHR INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, ARROW_ROOT INTEGER IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT, & ILOCROOT, JLOCROOT INTEGER MP,LP INTEGER KPROBE, FREQPROBE INTEGER TAILLE INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFI DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: BUFRECR INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, IREQI, IREQR LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE LOGICAL :: FLAG INTEGER(8), INTENT(OUT) :: NSEND8, NLOCAL8 INTEGER MASTER_NODE, ISTEP LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P INTEGER NOMP, NOMP_P, IOMP, P2 NSEND8 = 0_8 NLOCAL8 = 0_8 LP = ICNTL(1) MP = ICNTL(2) END_MSG_2_RECV = SLAVEF ALLOCATE( IACT(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IACT in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQI(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQI in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQR(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQR in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( SEND_ACTIVE(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating SEND_ACTIVE in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = ( NBRECORDS * 2 + 1 ) * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFR( NBRECORDS, 2, SLAVEF), stat = allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating real buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFRECI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS * 2 + 1 GOTO 20 END IF ALLOCATE( BUFRECR( NBRECORDS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS GOTO 20 END IF ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8) * 2_8, INFO(2) ) GOTO 20 END IF ALLOCATE( PTRAW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8) * KEEP(10), INFO(2) ) GOTO 20 END IF 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 100 ARROW_ROOT = 0 DO J = 1, N ISTEP=STEP(J) IF (ISTEP .GT. 0) THEN IARR1 = PTRDEBARR( ISTEP ) IF ( IARR1 .GT. 0 ) THEN I = J IORG = 0 DO WHILE ( I .GT. 0 ) IORG = IORG + 1 IW4(I, 1) = NINCOLARR( IARR1 + IORG - 1 ) IW4(I, 2) = NINROWARR( IARR1 + IORG - 1 ) + & NINCOLARR( IARR1 + IORG - 1 ) IS8 = PTR8ARR( IARR1 + IORG - 1 ) PTRAW( I ) = IS8 INTARR( IS8 ) = I DBLARR( IS8 ) = ZERO I = FILS(I) ENDDO ENDIF ENDIF ENDDO EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL DMUMPS_GET_ROOT_INFO(root,LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL DMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF DO I = 1, SLAVEF BUFI( 1, 1, I ) = 0 END DO DO I = 1, SLAVEF BUFI( 1, 2, I ) = 0 END DO DO I = 1, SLAVEF SEND_ACTIVE( I ) = .FALSE. IACT( I ) = 1 END DO KPROBE = 0 FREQPROBE = max(1,NBRECORDS/10) IF (SLAVEF .EQ. 1) FREQPROBE = huge(FREQPROBE) NOMP = 1 !$ NOMP=omp_get_max_threads() OMP_FLAG = KEEP(399).EQ.1 .AND. NOMP .GE.2 .AND. SLAVEF.EQ.1 !$OMP PARALLEL PRIVATE( K8, I, DEST, TAILLE, !$OMP& T4MASTER, T4_MASTER_CONCERNED, !$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT, !$OMP& ILOCROOT, JLOCROOT, !$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE, !$OMP& IS8, VAL, !$OMP& IARR, ISTEP, ISEND, JSEND, !$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P ) !$OMP& REDUCTION(+:NSEND8, NLOCAL8, ARROW_ROOT) IF (OMP_FLAG) IOMP=0 !$ IOMP=omp_get_thread_num() NOMP_P=1 !$ NOMP_P=omp_get_num_threads() OMP_FLAG_P = .FALSE. !$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1 IF (OMP_FLAG_P) THEN IF ( NOMP_P .GE. 16 ) THEN NOMP_P=16 P2 = 4 ELSE IF (NOMP_P.GE.8) THEN NOMP_P=8 P2 = 3 ELSE IF (NOMP_P.GE.4) THEN NOMP_P=4 P2 = 2 ELSE IF (NOMP_P.GE.2) THEN NOMP_P=2 P2 = 1 ENDIF ELSE NOMP_P = 1 P2 = 0 ENDIF IF ( IOMP .LT. NOMP_P ) THEN DO K8 = 1_8, NZ_loc8 IF ( SLAVEF .GT. 1 ) THEN !$OMP MASTER KPROBE = KPROBE + 1 IF ( KPROBE .eq. FREQPROBE ) THEN KPROBE = 0 CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, & MPI_INTEGER, & MSGSOU, ARR_INT, COMM, STATUS, IERR ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, & MPI_DOUBLE_PRECISION, & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) CALL DMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, & root, roota, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF END IF !$OMP END MASTER ENDIF IOLD = id%IRN_loc(K8) JOLD = id%JCN_loc(K8) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE ENDIF IF (OMP_FLAG_P) THEN IF (IOLD.EQ.JOLD) THEN IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD ELSE IARR = JOLD ENDIF DOIT = ( IOMP .EQ. ibits(IARR, P2-1, P2)) ELSE DOIT = .TRUE. ENDIF IF (DOIT) THEN IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = IOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF ISTEP = abs(STEP(IARR)) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP), KEEP(199) ) T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 VAL = id%A_loc(K8) IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN VAL = VAL * id%ROWSCA(IOLD)*id%COLSCA(JOLD) ENDIF IF ( TYPE_NODE .eq. 1 ) THEN DEST = MASTER_NODE IF (DEST.EQ.MYID) THEN NLOCAL8 = NLOCAL8 + 1_8 IF (ISEND.EQ.JSEND) THEN IS8 = PTRAW(ISEND) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IF (ISEND.GE.0) THEN IS8 = PTRAW(IARR) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL ELSE IS8 = PTRAW(IARR) + IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL DMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF ENDIF CYCLE ENDIF ELSE IF ( TYPE_NODE .eq. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE DEST = MASTER_NODE END IF INIV2 = ISTEP_TO_INIV2(ISTEP) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND < 0 ) THEN IPOSROOT = root%RG2L(JSEND) JPOSROOT = root%RG2L(IARR ) ELSE IPOSROOT = root%RG2L(IARR ) JPOSROOT = root%RG2L(JSEND) END IF IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL ) DEST = IROW_GRID * root%NPCOL + JCOL_GRID ELSE DEST = -2 ENDIF IF ( OMP_FLAG_P ) THEN IF ( EARLYT3ROOTINS ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE IF (ISEND.EQ.JSEND) THEN IS8 = PTRAW(ISEND) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IF (ISEND.GE.0) THEN IS8 = PTRAW(IARR)+IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL ELSE IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL DMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF ENDIF ENDIF CYCLE ENDIF END IF IF (DEST .eq. -1) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .EQ. -2) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .eq.MYID ) THEN NLOCAL8 = NLOCAL8 + 1_8 ELSE NSEND8 = NSEND8 + 1_8 ENDIF ENDIF IF ( DEST.EQ.-1) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79) .GT. 0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) IF (DEST.LT.0) EXIT IF (I.EQ.NCAND+1) CYCLE DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL DMUMPS_DIST_FILL_BUFFER() ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL DMUMPS_DIST_FILL_BUFFER() ENDDO ENDIF DEST=MASTER_NODE DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL DMUMPS_DIST_FILL_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL DMUMPS_DIST_FILL_BUFFER() ENDIF ELSE IF (DEST .GE. 0) THEN DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL DMUMPS_DIST_FILL_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL DMUMPS_DIST_FILL_BUFFER() ENDIF ELSE IF (DEST .EQ. -2) THEN DO I = 0, SLAVEF-1 DEST=I DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL DMUMPS_DIST_FILL_BUFFER() ENDDO ENDIF ENDIF END DO ENDIF !$OMP END PARALLEL DEST_SHR = -3 CALL DMUMPS_DIST_FILL_BUFFER() DO WHILE ( END_MSG_2_RECV .NE. 0 ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, MPI_INTEGER, & MPI_ANY_SOURCE, ARR_INT, COMM, STATUS, IERR ) MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, MPI_DOUBLE_PRECISION, & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) CALL DMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END DO DO I = 1, SLAVEF IF ( SEND_ACTIVE( I ) ) THEN CALL MPI_WAIT( IREQI( I ), STATUS, IERR ) CALL MPI_WAIT( IREQR( I ), STATUS, IERR ) END IF END DO KEEP(49) = ARROW_ROOT 100 CONTINUE IF (ALLOCATED(IW4)) DEALLOCATE( IW4 ) IF (ALLOCATED(PTRAW)) DEALLOCATE( PTRAW ) IF (ALLOCATED(BUFI)) DEALLOCATE( BUFI ) IF (ALLOCATED(BUFR)) DEALLOCATE( BUFR ) IF (ALLOCATED(BUFRECI)) DEALLOCATE( BUFRECI ) IF (ALLOCATED(BUFRECR)) DEALLOCATE( BUFRECR ) IF (ALLOCATED(IACT)) DEALLOCATE( IACT ) IF (ALLOCATED(IREQI)) DEALLOCATE( IREQI ) IF (ALLOCATED(IREQR)) DEALLOCATE( IREQR ) IF (ALLOCATED(SEND_ACTIVE)) DEALLOCATE( SEND_ACTIVE ) RETURN CONTAINS SUBROUTINE DMUMPS_DIST_FILL_BUFFER() IMPLICIT NONE INTEGER ISLAVE, IBEG, IEND, NBREC, IREQ INTEGER TAILLE_SEND_I, TAILLE_SEND_R LOGICAL SEND_LOCAL IF ( DEST_SHR .eq. -3 ) THEN IBEG = 1 IEND = SLAVEF ELSE IBEG = DEST_SHR + 1 IEND = DEST_SHR + 1 END IF SEND_LOCAL = .FALSE. DO ISLAVE = IBEG, IEND NBREC = BUFI(1,IACT(ISLAVE),ISLAVE) IF ( DEST_SHR .eq. -3 ) THEN BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC END IF IF ( DEST_SHR .eq. -3 .or. NBREC + 1 > NBRECORDS ) THEN DO WHILE ( SEND_ACTIVE( ISLAVE ) ) CALL MPI_TEST( IREQR( ISLAVE ), FLAG, STATUS, IERR ) IF ( .NOT. FLAG ) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS(MPI_SOURCE) CALL MPI_RECV( BUFRECI(1), 2*NBRECORDS+1, & MPI_INTEGER, MSGSOU, ARR_INT, COMM, & STATUS, IERR ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, & MPI_DOUBLE_PRECISION, MSGSOU, & ARR_REAL, COMM, STATUS, IERR ) CALL DMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & 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_SHR .ne. -3 ) THEN IREQ = BUFI(1,IACT(ISLAVE),ISLAVE) + 1 BUFI(1,IACT(ISLAVE),ISLAVE) = IREQ BUFI(IREQ*2,IACT(ISLAVE),ISLAVE) = ISEND_SHR BUFI(IREQ*2+1,IACT(ISLAVE),ISLAVE) = JSEND_SHR BUFR(IREQ,IACT(ISLAVE),ISLAVE ) = VAL_SHR END IF END DO IF ( SEND_LOCAL ) THEN ISLAVE = MYID + 1 CALL DMUMPS_DIST_TREAT_RECV_BUF( & BUFI(1,3-IACT(ISLAVE),ISLAVE), & BUFR(1,3-IACT(ISLAVE),ISLAVE), & NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF RETURN END SUBROUTINE DMUMPS_DIST_FILL_BUFFER END SUBROUTINE DMUMPS_REDISTRIBUTION SUBROUTINE DMUMPS_DIST_TREAT_RECV_BUF & ( BUFI, BUFR, NBRECORDS, N, IW4, & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, roota, & PTR_ROOT, A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER NBRECORDS, N, MYID, SLAVEF INTEGER BUFI( NBRECORDS * 2 + 1 ) DOUBLE PRECISION BUFR( NBRECORDS ) INTEGER IW4( N, 2 ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER END_MSG_2_RECV INTEGER(8), INTENT(IN) :: PTRAW( N ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER :: PERM( N ), STEP( N ) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER INTARR( LINTARR ) INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT, LA DOUBLE PRECISION A( LA ), DBLARR( LDBLARR ) INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER IREC, NB_REC, NODE_TYPE, IPROC INTEGER IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER(8) :: IS8 INTEGER IARR, JARR INTEGER TAILLE LOGICAL :: EARLYT3ROOTINS DOUBLE PRECISION VAL EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) NB_REC = BUFI( 1 ) IF ( NB_REC .LE. 0 ) THEN END_MSG_2_RECV = END_MSG_2_RECV - 1 NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) GOTO 100 DO IREC = 1, NB_REC IARR = BUFI( IREC * 2 ) JARR = BUFI( IREC * 2 + 1 ) VAL = BUFR( IREC ) NODE_TYPE = MUMPS_TYPENODE( & PROCNODE_STEPS(abs(STEP(abs( IARR )))), & KEEP(199) ) IF ( NODE_TYPE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JARR ) ELSE IPOSROOT = root%RG2L( JARR ) JPOSROOT = root%RG2L( -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 roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%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 IS8 = PTRAW(IARR) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IS8 = PTRAW(IARR)+IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)), & KEEP(199) ) IF ( IPROC .EQ. MYID ) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL DMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) ENDIF END IF ENDIF ENDDO 100 CONTINUE RETURN END SUBROUTINE DMUMPS_DIST_TREAT_RECV_BUF MUMPS_5.8.1/src/ssol_matvec.F0000664000175000017500000002371215042446441015664 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_MV_ELT( N, NELT, ELTPTR, ELTVAR, A_ELT, & X, Y, K50, MTYPE ) IMPLICIT NONE C C Purpose C ======= C C To perform the matrix vector product C A_ELT X = Y if MTYPE = 1 C A_ELT^T X = Y if MTYPE = 0 C C If K50 is different from 0, then the elements are C supposed to be in symmetric packed storage; the C lower part is stored by columns. C Otherwise, the element is square, stored by columns. C C Note C ==== C C A_ELT is processed entry by entry and this code is not C optimized. In particular, one could gather/scatter C X / Y for each element to improve performance. C C Arguments C ========= C INTEGER N, NELT, K50, MTYPE INTEGER ELTPTR( NELT + 1 ), ELTVAR( * ) REAL A_ELT( * ), X( N ), Y( N ) C C Local variables C =============== C INTEGER IEL, I , J, SIZEI, IELPTR INTEGER(8) :: K8 REAL TEMP REAL ZERO PARAMETER( ZERO = 0.0E0 ) C C C Executable statements C ===================== C Y = ZERO K8 = 1_8 C -------------------- C Process the elements C -------------------- DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( K50 .eq. 0 ) THEN C ------------------- C Unsymmetric element C stored by columns C ------------------- IF ( MTYPE .eq. 1 ) THEN C ----------------- C Compute A_ELT x X C ----------------- DO J = 1, SIZEI TEMP = X( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) + & A_ELT( K8 ) * TEMP K8 = K8 + 1 END DO END DO ELSE C ------------------- C Compute A_ELT^T x X C ------------------- DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + & A_ELT( K8 ) * X( ELTVAR( IELPTR + I ) ) K8 = K8 + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP END DO END IF ELSE C ----------------- C Symmetric element C L stored by cols C ----------------- DO J = 1, SIZEI C Diagonal counted once Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + J ) ) K8 = K8 + 1 DO I = J+1, SIZEI C Off diagonal + transpose Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + J ) ) Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + I ) ) K8 = K8 + 1 END DO END DO END IF END DO RETURN END SUBROUTINE SMUMPS_MV_ELT SUBROUTINE SMUMPS_LOC_MV8 &( N, NZ_loc8, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE C C Purpose: C ======= C C Perform a distributed matrix vector product. C Y_loc <- A X if MTYPE = 1 C Y_loc <- A^T X if MTYPE = 0 C C Notes: C ===== C C 1) assembly of all Y_loc still has to be done on exit. C 2) X should be available on all processors. C C Arguments: C ========= C INTEGER N INTEGER(8) :: NZ_loc8 INTEGER IRN_loc( NZ_loc8 ), JCN_loc( NZ_loc8 ) REAL A_loc( NZ_loc8 ), X( N ), Y_loc( N ) INTEGER LDLT, MTYPE C C Locals variables: C ================ C INTEGER I, J INTEGER(8) :: K8 REAL ZERO PARAMETER( ZERO = 0.0E0 ) Y_loc = ZERO IF ( LDLT .eq. 0 ) THEN C Unsymmetric IF ( MTYPE .eq. 1 ) THEN C No transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + A_loc(K8) * X(J) ENDDO ELSE C Transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) & .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(J) = Y_loc(J) + A_loc(K8) * X(I) ENDDO END IF ELSE C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + A_loc(K8) * X(J) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + A_loc(K8) * X(I) ENDIF ENDDO END IF RETURN END SUBROUTINE SMUMPS_LOC_MV8 SUBROUTINE SMUMPS_MV8( N, NZ8, IRN, ICN, ASPK, X, Y, & LDLT, MTYPE, MAXTRANS, PERM, & IFLAG, IERROR ) C C Purpose: C ======= C C Perform matrix-vector product C Y <- A X if MTYPE = 1 C Y <- A^T X if MTYPE = 0 C C C Note: C ==== C C MAXTRANS should be set to 1 if a column permutation C was applied on A and we still want the matrix vector C product wrt the original matrix. C C Arguments: C ========= C INTEGER N, LDLT, MTYPE, MAXTRANS INTEGER(8) :: NZ8 INTEGER IRN( NZ8 ), ICN( NZ8 ) INTEGER PERM( N ) REAL ASPK( NZ8 ), X( N ), Y( N ) INTEGER, intent(inout) :: IFLAG, IERROR C C Local variables C =============== C INTEGER I, J INTEGER(8) :: K8 REAL, DIMENSION(:), ALLOCATABLE :: PX REAL ZERO INTEGER :: allocok PARAMETER( ZERO = 0.0E0 ) Y = ZERO ALLOCATE(PX(N), stat=allocok) IF (allocok < 0) THEN IFLAG = -13 IERROR = N RETURN ENDIF C C -------------------------------------- C Permute X if A has been permuted C with some max-trans column permutation C -------------------------------------- IF ( MAXTRANS .eq. 1 .and. MTYPE .eq. 1) THEN DO I = 1, N PX(I) = X( PERM( I ) ) END DO ELSE PX = X END IF IF ( LDLT .eq. 0 ) THEN C C Complete unsymmetric matrix was provided (LU facto) IF (MTYPE .EQ. 1) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K8) * PX(J) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(J) = Y(J) + ASPK(K8) * PX(I) ENDDO ENDIF C ELSE C C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K8) * PX(J) IF (J.NE.I) THEN Y(J) = Y(J) + ASPK(K8) * PX(I) ENDIF ENDDO END IF IF ( MAXTRANS .EQ. 1 .AND. MTYPE .eq. 0 ) THEN PX = Y DO I = 1, N Y( PERM( I ) ) = PX( I ) END DO END IF DEALLOCATE(PX) RETURN END SUBROUTINE SMUMPS_MV8 C C SUBROUTINE SMUMPS_LOC_OMEGA1 &( N, NZ_loc8, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE C C Purpose: C ======= C Compute C * If MTYPE = 1 C Y_loc(i) = Sum | Aij | | Xj | C j C * If MTYPE = 0 C Y_loc(j) = Sum | Aij | | Xi | C C C Notes: C ===== C C 1) assembly of all Y_loc still has to be done. C 2) X should be available on all processors. C C Arguments: C ========= C INTEGER N INTEGER(8) :: NZ_loc8 INTEGER IRN_loc( NZ_loc8 ), JCN_loc( NZ_loc8 ) REAL A_loc( NZ_loc8 ), X( N ) REAL Y_loc( N ) INTEGER LDLT, MTYPE C C Local variables: C =============== C INTEGER I, J INTEGER(8) :: K8 REAL, PARAMETER :: RZERO=0.0E0 C Y_loc = RZERO IF ( LDLT .eq. 0 ) THEN C Unsymmetric IF ( MTYPE .eq. 1 ) THEN C No transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + abs( A_loc(K8) * X(J) ) ENDDO ELSE C Transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) & .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(J) = Y_loc(J) + abs( A_loc(K8) * X(I) ) ENDDO END IF ELSE C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + abs( A_loc(K8) * X(J) ) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + abs( A_loc(K8) * X(I) ) ENDIF ENDDO END IF RETURN END SUBROUTINE SMUMPS_LOC_OMEGA1 MUMPS_5.8.1/src/zana_LDLT_preprocess.F0000664000175000017500000007155615042446441017373 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SET_CONSTRAINTS( & N,PIV,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8, ROWSCA & ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(OUT) :: NCST INTEGER :: PIV(N),FRERE(N),FILS(N),NFSIZ(N),IKEEP(N) INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: ROWSCA(N) INTEGER I,P11,P1,P2,K1,K2,NLOCKED LOGICAL V1,V2 NCST = 0 NLOCKED = 0 P11 = KEEP(93) DO I=KEEP(93)-1,1,-2 P1 = PIV(I) P2 = PIV(I+1) K1 = IKEEP(P1) IF (K1 .NE. 0) THEN V1 = (K1+2*exponent(ROWSCA(P1)) .GE. -3) ELSE V1 = .FALSE. ENDIF K2 = IKEEP(P2) IF (K2 .NE. 0) THEN V2 = (K2+exponent(ROWSCA(P2)**2) .GE. -3) ELSE V2 = .FALSE. ENDIF IF(V1 .AND. V2) THEN PIV(P11) = P1 P11 = P11 - 1 PIV(P11) = P2 P11 = P11 - 1 ELSE IF(V1) THEN NCST = NCST+1 FRERE(NCST) = P1 NCST = NCST+1 FRERE(NCST) = P2 ELSE IF(V2) THEN NCST = NCST+1 FRERE(NCST) = P2 NCST = NCST+1 FRERE(NCST) = P1 ELSE NLOCKED = NLOCKED + 1 FILS(NLOCKED) = P1 NLOCKED = NLOCKED + 1 FILS(NLOCKED) = P2 ENDIF ENDDO DO I=1,NLOCKED PIV(I) = FILS(I) ENDDO KEEP(94) = KEEP(94) + KEEP(93) - NLOCKED KEEP(93) = NLOCKED DO I=1,NCST NLOCKED = NLOCKED + 1 PIV(NLOCKED) = FRERE(I) ENDDO DO I=1,KEEP(93)/2 NFSIZ(I) = 0 ENDDO DO I=(KEEP(93)/2)+1,(KEEP(93)/2)+NCST,2 NFSIZ(I) = I+1 NFSIZ(I+1) = -1 ENDDO DO I=(KEEP(93)/2)+NCST+1,(KEEP(93)/2)+KEEP(94) NFSIZ(I) = 0 ENDDO END SUBROUTINE ZMUMPS_SET_CONSTRAINTS SUBROUTINE ZMUMPS_EXPAND_PERMUTATION(N,NCMP,N11,N22,PIV, & INVPERM,PERM) IMPLICIT NONE INTEGER N11,N22,N,NCMP INTEGER, intent(in) :: PIV(N),PERM(N) INTEGER, intent (out):: INVPERM(N) INTEGER CMP_POS,EXP_POS,I,J,N2,K N2 = N22/2 EXP_POS = 1 DO CMP_POS=1,NCMP J = PERM(CMP_POS) IF(J .LE. N2) THEN K = 2*J-1 I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 K = K+1 I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ELSE K = N2 + J I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ENDIF ENDDO DO K=N22+N11+1,N I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ENDDO RETURN END SUBROUTINE ZMUMPS_EXPAND_PERMUTATION SUBROUTINE ZMUMPS_LDLT_COMPRESS( & N,NZ, IRN, ICN, PIV, & NCMP, IW, LW, IPE, LEN, IQ, & FLAG, ICMP, IWFR, & IERROR, KEEP,KEEP8, ICNTL,INPLACE64_GRAPH_COPY) IMPLICIT NONE INTEGER, intent(in) :: N INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: IRN(NZ), ICN(NZ), PIV(N) INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(out) :: NCMP, IERROR INTEGER(8), intent(out) :: IWFR, IPE(N+1) INTEGER, intent(out) :: IW(LW) INTEGER, intent(out) :: LEN(N) INTEGER(8), intent(out) :: IQ(N) INTEGER, intent(out) :: FLAG(N), ICMP(N) LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: N11, N22 INTEGER :: I, J, N1, K INTEGER(8) :: NDUP, L, K8, K1, K2, LAST IERROR = 0 N22 = KEEP(93) N11 = KEEP(94) NCMP = N22/2 + N11 DO I=1,NCMP IPE(I) = 0 ENDDO K = 1 DO I=1,N22/2 J = PIV(K) ICMP(J) = I K = K + 1 J = PIV(K) ICMP(J) = I K = K + 1 ENDDO K = N22/2 + 1 DO I=N22+1,N22+N11 J = PIV(I) ICMP(J) = K K = K + 1 ENDDO DO I=N11+N22+1,N J = PIV(I) ICMP(J) = 0 ENDDO DO K8=1,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ICMP(I) J = ICMP(J) IF ((I.NE.0).AND.(J.NE.0).AND.(I.NE.J)) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 ENDIF ENDIF ENDDO IQ(1) = 1_8 N1 = NCMP - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(NCMP)+IQ(NCMP)-1_8,IQ(NCMP)) DO I = 1,NCMP FLAG(I) = 0 IPE(I) = IQ(I) ENDDO IW(1:LAST) = 0 IWFR = LAST + 1_8 DO K8=1,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ICMP(I) J = ICMP(J) IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1_8 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1_8 ENDIF ENDIF ENDIF ENDDO NDUP = 0_8 DO I=1,NCMP K1 = IPE(I) K2 = IQ(I) -1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) GO TO 250 L = IQ(J) IQ(J) = L + 1_8 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(L) = 0 IW(K8) = 0 ELSE IW(L) = I IW(K8) = J FLAG(J) = I ENDIF ENDDO 250 LEN(I) = int(IQ(I) - IPE(I)) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,NCMP K1 = IPE(I) IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF ENDDO LEN(I) = int(IWFR - L) ENDDO ENDIF IPE(NCMP+1) = IPE(NCMP) + int(LEN(NCMP),8) IWFR = IPE(NCMP+1) INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1_8)) RETURN END SUBROUTINE ZMUMPS_LDLT_COMPRESS SUBROUTINE ZMUMPS_SYM_MWM( & N, NE, IP, IRN, SCALING,LSC,CPERM, DIAG, & ICNTL, WEIGHT,MARKED,FLAG, & PIV_OUT, INFO) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NE INTEGER :: ICNTL(10), INFO(10),LSC INTEGER :: CPERM(N),PIV_OUT(N), IRN(NE), DIAG(N) INTEGER(8), INTENT(IN) :: IP(N+1) DOUBLE PRECISION :: SCALING(LSC),WEIGHT(N+2) INTEGER :: MARKED(N),FLAG(N) INTEGER :: NUM1,NUM2,NUMTOT,PATH_LENGTH,NLAST INTEGER :: I,BEST_BEG, CUR_EL,CUR_EL_PATH,CUR_EL_PATH_NEXT INTEGER :: L1,L2,TUP,T22 INTEGER(8) :: PTR_SET1,PTR_SET2 DOUBLE PRECISION :: BEST_SCORE,CUR_VAL,TMP,VAL DOUBLE PRECISION INITSCORE, ZMUMPS_UPDATESCORE, & ZMUMPS_UPDATE_INVERSE, ZMUMPS_METRIC2x2 LOGICAL VRAI,FAUX,MAX_CARD_DIAG,USE_SCALING INTEGER SUM DOUBLE PRECISION ZERO,ONE PARAMETER (SUM = 1, VRAI = .TRUE., FAUX = .FALSE.) PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) MAX_CARD_DIAG = .TRUE. NUM1 = 0 NUM2 = 0 NUMTOT = 0 NLAST = N INFO = 0 MARKED = 1 FLAG = 0 VAL = ONE IF(LSC .GT. 1) THEN USE_SCALING = .TRUE. ELSE USE_SCALING = .FALSE. ENDIF TUP = ICNTL(2) IF(TUP .EQ. SUM) THEN INITSCORE = ZERO ELSE INITSCORE = ONE ENDIF IF(ICNTL(2) .GT. 2 .OR. ICNTL(2) .LE. 0) THEN WRITE(*,*) & 'ERROR: WRONG VALUE FOR ICNTL(2) = ',ICNTL(2) INFO(1) = -1 RETURN ENDIF T22 = ICNTL(1) IF(ICNTL(1) .LT. 0 .OR. ICNTL(1) .GT. 2) THEN WRITE(*,*) & 'ERROR: WRONG VALUE FOR ICNTL(1) = ',ICNTL(1) INFO(1) = -1 RETURN ENDIF DO CUR_EL=1,N IF(MARKED(CUR_EL) .LE. 0) THEN CYCLE ENDIF IF(CPERM(CUR_EL) .LT. 0) THEN MARKED(CUR_EL) = -1 CYCLE ENDIF PATH_LENGTH = 2 CUR_EL_PATH = CPERM(CUR_EL) IF(CUR_EL_PATH .EQ. CUR_EL) THEN MARKED(CUR_EL) = -1 CYCLE ENDIF MARKED(CUR_EL) = 0 WEIGHT(1) = INITSCORE WEIGHT(2) = INITSCORE L1 = int(IP(CUR_EL+1)-IP(CUR_EL)) L2 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH)) PTR_SET1 = IP(CUR_EL) PTR_SET2 = IP(CUR_EL_PATH) IF(USE_SCALING) THEN VAL = -SCALING(CUR_EL_PATH) - SCALING(CUR_EL+N) ENDIF CUR_VAL = ZMUMPS_METRIC2x2( & CUR_EL,CUR_EL_PATH, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,FAUX,T22) WEIGHT(PATH_LENGTH+1) = & ZMUMPS_UPDATESCORE(WEIGHT(1),CUR_VAL,TUP) DO IF(CUR_EL_PATH .EQ. CUR_EL) EXIT PATH_LENGTH = PATH_LENGTH+1 MARKED(CUR_EL_PATH) = 0 CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH) L1 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH)) L2 = int(IP(CUR_EL_PATH_NEXT+1)-IP(CUR_EL_PATH_NEXT)) PTR_SET1 = IP(CUR_EL_PATH) PTR_SET2 = IP(CUR_EL_PATH_NEXT) IF(USE_SCALING) THEN VAL = -SCALING(CUR_EL_PATH_NEXT) & - SCALING(CUR_EL_PATH+N) ENDIF CUR_VAL = ZMUMPS_METRIC2x2( & CUR_EL_PATH,CUR_EL_PATH_NEXT, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,VRAI,T22) WEIGHT(PATH_LENGTH+1) = & ZMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH-1),CUR_VAL,TUP) CUR_EL_PATH = CUR_EL_PATH_NEXT ENDDO IF(mod(PATH_LENGTH,2) .EQ. 1) THEN IF(WEIGHT(PATH_LENGTH+1) .GE. WEIGHT(PATH_LENGTH)) THEN CUR_EL_PATH = CPERM(CUR_EL) ELSE CUR_EL_PATH = CUR_EL ENDIF DO I=1,(PATH_LENGTH-1)/2 NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO NUMTOT = NUMTOT + PATH_LENGTH - 1 ELSE IF(MAX_CARD_DIAG) THEN CUR_EL_PATH = CPERM(CUR_EL) IF(DIAG(CUR_EL) .NE. 0) THEN BEST_BEG = CUR_EL_PATH GOTO 1000 ENDIF DO I=1,(PATH_LENGTH/2) CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH) IF(DIAG(CUR_EL_PATH) .NE. 0) THEN BEST_BEG = CUR_EL_PATH_NEXT GOTO 1000 ENDIF ENDDO ENDIF BEST_BEG = CUR_EL BEST_SCORE = WEIGHT(PATH_LENGTH-1) CUR_EL_PATH = CPERM(CUR_EL) DO I=1,(PATH_LENGTH/2)-1 TMP = ZMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH), & WEIGHT(2*I-1),TUP) TMP = ZMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I),TUP) IF(TMP .GT. BEST_SCORE) THEN BEST_SCORE = TMP BEST_BEG = CUR_EL_PATH ENDIF CUR_EL_PATH = CPERM(CUR_EL_PATH) TMP = ZMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH+1), & WEIGHT(2*I),TUP) TMP = ZMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I+1),TUP) IF(TMP .GT. BEST_SCORE) THEN BEST_SCORE = TMP BEST_BEG = CUR_EL_PATH ENDIF CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO 1000 CUR_EL_PATH = BEST_BEG DO I=1,(PATH_LENGTH/2)-1 NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO NUMTOT = NUMTOT + PATH_LENGTH - 2 MARKED(CUR_EL_PATH) = -1 ENDIF ENDDO DO I=1,N IF(MARKED(I) .LT. 0) THEN IF(DIAG(I) .EQ. 0) THEN PIV_OUT(NLAST) = I NLAST = NLAST - 1 ELSE NUM1 = NUM1 + 1 PIV_OUT(NUM2+NUM1) = I NUMTOT = NUMTOT + 1 ENDIF ENDIF ENDDO INFO(2) = NUMTOT INFO(3) = NUM1 INFO(4) = NUM2 RETURN END SUBROUTINE ZMUMPS_SYM_MWM FUNCTION ZMUMPS_UPDATESCORE(A,B,T) IMPLICIT NONE DOUBLE PRECISION ZMUMPS_UPDATESCORE DOUBLE PRECISION A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN ZMUMPS_UPDATESCORE = A+B ELSE ZMUMPS_UPDATESCORE = A*B ENDIF END FUNCTION ZMUMPS_UPDATESCORE FUNCTION ZMUMPS_UPDATE_INVERSE(A,B,T) IMPLICIT NONE DOUBLE PRECISION ZMUMPS_UPDATE_INVERSE DOUBLE PRECISION A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN ZMUMPS_UPDATE_INVERSE = A-B ELSE ZMUMPS_UPDATE_INVERSE = A/B ENDIF END FUNCTION ZMUMPS_UPDATE_INVERSE FUNCTION ZMUMPS_METRIC2x2(CUR_EL,CUR_EL_PATH, & SET1,SET2,L1,L2,VAL,DIAG,N,FLAG,FLAGON,T) IMPLICIT NONE DOUBLE PRECISION ZMUMPS_METRIC2x2 INTEGER CUR_EL,CUR_EL_PATH,L1,L2,N INTEGER SET1(L1),SET2(L2),DIAG(N),FLAG(N) DOUBLE PRECISION VAL LOGICAL FLAGON INTEGER T INTEGER I,INTER,MERGE INTEGER STRUCT,MA47 PARAMETER(STRUCT=0,MA47=1) IF(T .EQ. STRUCT) THEN IF(.NOT. FLAGON) THEN DO I=1,L1 FLAG(SET1(I)) = CUR_EL ENDDO ENDIF INTER = 0 DO I=1,L2 IF(FLAG(SET2(I)) .EQ. CUR_EL) THEN INTER = INTER + 1 FLAG(SET2(I)) = CUR_EL_PATH ENDIF ENDDO MERGE = L1 + L2 - INTER ZMUMPS_METRIC2x2 = dble(INTER) / dble(MERGE) ELSE IF (T .EQ. MA47) THEN MERGE = 3 IF(DIAG(CUR_EL) .NE. 0) MERGE = 2 IF(DIAG(CUR_EL_PATH) .NE. 0) MERGE = MERGE - 2 IF(MERGE .EQ. 0) THEN ZMUMPS_METRIC2x2 = dble(L1+L2-2) ZMUMPS_METRIC2x2 = -(ZMUMPS_METRIC2x2**2)/2.0D0 ELSE IF(MERGE .EQ. 1) THEN ZMUMPS_METRIC2x2 = - dble(L1+L2-4) * dble(L1-2) ELSE IF(MERGE .EQ. 2) THEN ZMUMPS_METRIC2x2 = - dble(L1+L2-4) * dble(L2-2) ELSE ZMUMPS_METRIC2x2 = - dble(L1-2) * dble(L2-2) ENDIF ELSE ZMUMPS_METRIC2x2 = VAL ENDIF RETURN END FUNCTION SUBROUTINE ZMUMPS_EXPAND_PERM_SCHUR(NA, NCMP, & INVPERM,PERM, & LISTVAR_SCHUR, SIZE_SCHUR, AOTOA) IMPLICIT NONE INTEGER, INTENT(IN):: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN):: NA, NCMP INTEGER, INTENT(IN):: AOTOA(NCMP), PERM(NCMP) INTEGER, INTENT(OUT):: INVPERM(NA) INTEGER CMP_POS, IO, I, K, IPOS DO CMP_POS=1, NCMP IO = PERM(CMP_POS) INVPERM(AOTOA(IO)) = CMP_POS ENDDO IPOS = NCMP DO K =1, SIZE_SCHUR I = LISTVAR_SCHUR(K) IPOS = IPOS+1 INVPERM(I) = IPOS ENDDO RETURN END SUBROUTINE ZMUMPS_EXPAND_PERM_SCHUR SUBROUTINE ZMUMPS_GNEW_SCHUR & (NA, N, NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, NBQD, AvgDens, & KEEP264, KEEP265, & LISTVAR_SCHUR, SIZE_SCHUR, ATOAO, AOTOA, & INPLACE64_GRAPH_COPY & ) IMPLICIT NONE INTEGER, intent(in) :: NA INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, intent(out) :: IERROR, symmetry INTEGER, intent(out) :: NBQD, AvgDens INTEGER, intent(out) :: LEN(N), IW(LW) INTEGER(8), intent(out):: IWFR INTEGER(8), intent(out):: NRORM, NIORM INTEGER(8), intent(out):: IPE(N+1) INTEGER, INTENT(OUT) :: AOTOA(N) INTEGER, INTENT(OUT) :: ATOAO(NA) INTEGER, intent(inout) :: IFLAG, KEEP264 INTEGER, intent(in) :: KEEP265 INTEGER(8), intent(out):: IQ(N) INTEGER, intent(out) :: FLAG(N) LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, MPG, I, J, N1 INTEGER :: NBERR, THRESH, IAO INTEGER(8) :: K8, K1, K2, LAST, NDUP INTEGER(8) :: NZOFFA, NDIAGA, L, N8 DOUBLE PRECISION :: RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) ATOAO(1:NA) = 0 DO I = 1, SIZE_SCHUR ATOAO(LISTVAR_SCHUR(I)) = -1 ENDDO IAO = 0 DO I= 1, NA IF (ATOAO(I).LT.0) CYCLE IAO = IAO +1 ATOAO(I) = IAO AOTOA(IAO) = I ENDDO NZOFFA = 0_8 NDIAGA = 0 IERROR = 0 N8 = int(N,8) DO I=1,N+1 IPE(I) = 0_8 ENDDO IF (KEEP264.EQ.0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ENDIF IF (IERROR.GE.1) THEN KEEP264 = 0 ELSE KEEP264 = 1 ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.EQ.J) THEN NDIAGA = NDIAGA + 1_8 ELSE IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDDO ENDIF ENDIF NIORM = NZOFFA + 3_8*N8 IF (IERROR.GE.1) THEN NBERR = 0 IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN WRITE (MP,99999) DO 70 K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR. & (10_8.LE.K8 .AND. K8.LE.20_8)) THEN WRITE (MP,'(I16,A,I10,A,I10,A)') & K8,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K8,10_8).EQ.1_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'st entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.2_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.3_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2_8*N8 IQ(1) = 1_8 N1 = N - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(N)+IQ(N)-1,IQ(N)) FLAG(1:N) = 0 IPE(1:N) = IQ(1:N) IW(1:LAST) = 0 IWFR = LAST + 1_8 IF (KEEP264 .EQ. 0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF (I.LT.J) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDDO ENDIF ENDIF IF (KEEP265.EQ.0) THEN NDUP = 0_8 DO I=1,N K1 = IPE(I) K2 = IQ(I) - 1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) EXIT IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE L = IQ(J) IQ(J) = L + 1 IW(L) = I IW(K8) = J FLAG(J) = I ENDIF END DO LEN(I) = int(IQ(I) - IPE(I)) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,N IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K1 = IPE(I) K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF 270 CONTINUE LEN(I) = int(IWFR - L) ENDDO ENDIF IPE(N+1) = IPE(N) + int(LEN(N),8) IWFR = IPE(N+1) ELSE IPE(1) = 1_8 DO I = 1, N LEN(I) = int(IQ(I) - IPE(I)) ENDDO DO I = 1, N IPE(I+1) = IPE(I) + int(LEN(I),8) ENDDO IWFR = IPE(N+1) ENDIF symmetry = 100 IF (SYM.EQ.0) THEN RSYM = dble(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/ & dble(NZOFFA+NDIAGA) IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) THEN ENDIF symmetry = nint (100.0D0*RSYM) IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) ) & write(MPG,'(A,A,I5)') & ' Case of Schur:', & ' structural symmetry (in percent) of interior block=', & symmetry IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) ) & write(MP,'(A,A,I5)') & ' Case of Schur:', & ' structural symmetry (in percent) of interior block=', & symmetry ELSE symmetry = 100 ENDIF INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1)) AvgDens = nint(dble(IWFR-1_8)/dble(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN DO I= 1, N J = max(LEN(I),1) IF (J.GT.THRESH) NBQD = NBQD+1 ENDDO ENDIF IF (MPG .GT. 0.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE ZMUMPS_GNEW_SCHUR SUBROUTINE ZMUMPS_GET_PERM_FROM_PE(N,PE,INVPERM,NFILS,WORK) IMPLICIT NONE INTEGER N INTEGER PE(N),INVPERM(N),NFILS(N),WORK(N) INTEGER I,FATHER,STKLEN,STKPOS,PERMPOS,CURVAR NFILS = 0 DO I=1,N FATHER = -PE(I) IF(FATHER .NE. 0) NFILS(FATHER) = NFILS(FATHER) + 1 ENDDO STKLEN = 0 PERMPOS = 1 DO I=1,N IF(NFILS(I) .EQ. 0) THEN STKLEN = STKLEN + 1 WORK(STKLEN) = I INVPERM(I) = PERMPOS PERMPOS = PERMPOS + 1 ENDIF ENDDO DO STKPOS = 1,STKLEN CURVAR = WORK(STKPOS) FATHER = -PE(CURVAR) DO IF(FATHER .EQ. 0) EXIT IF(NFILS(FATHER) .EQ. 1) THEN INVPERM(FATHER) = PERMPOS FATHER = -PE(FATHER) PERMPOS = PERMPOS + 1 ELSE NFILS(FATHER) = NFILS(FATHER) - 1 EXIT ENDIF ENDDO ENDDO RETURN END SUBROUTINE ZMUMPS_GET_PERM_FROM_PE SUBROUTINE ZMUMPS_GET_ELIM_TREE(N,PE,NV,WORK) IMPLICIT NONE INTEGER N INTEGER PE(N),NV(N),WORK(N) INTEGER I,FATHER,LEN,NEWSON,NEWFATHER DO I=1,N IF(NV(I) .GT. 0) CYCLE LEN = 1 WORK(LEN) = I FATHER = -PE(I) DO IF(NV(FATHER) .GT. 0) THEN NEWSON = FATHER EXIT ENDIF LEN = LEN + 1 WORK(LEN) = FATHER NV(FATHER) = 1 FATHER = -PE(FATHER) ENDDO NEWFATHER = -PE(FATHER) PE(WORK(LEN)) = -NEWFATHER PE(NEWSON) = -WORK(1) ENDDO END SUBROUTINE ZMUMPS_GET_ELIM_TREE MUMPS_5.8.1/src/dfac_mem_stack_aux.F0000664000175000017500000002311215042446440017133 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_COMPACT_FACTORS_SYM(A, LDA, NPIV, NBROW, KEEP, & SIZEA, IW ) IMPLICIT NONE INTEGER, INTENT(IN) :: LDA, NPIV, NBROW INTEGER(8), INTENT(IN) :: SIZEA INTEGER, INTENT(IN) :: IW( NPIV ) INTEGER :: KEEP(500) DOUBLE PRECISION :: A(SIZEA) INTEGER(8) :: IOLD, INEW, J8 INTEGER I , ILAST INTEGER NBROW_L_RECTANGLE_TO_MOVE INTEGER :: ICOL_BEG, ICOL_END, NBPANELS, NB_TARGET INTEGER :: NBCOLS_PANEL, NBROWS_PANEL INTEGER(8) :: SIZE_COPY LOGICAL :: OMP_FLAG IF ( NPIV .EQ. 0 ) GOTO 500 NB_TARGET = NPIV IF ( KEEP(459) .GT. 1 ) THEN CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, NB_TARGET, KEEP ) ENDIF IF ( NB_TARGET .EQ. NPIV ) THEN IF (LDA.EQ.NPIV) GOTO 500 IOLD = int(LDA + 1,8) INEW = int(NPIV + 1,8) IF (IOLD .EQ. INEW ) THEN WRITE(*,*) " Internal error in DMUMPS_COMPACT_FACTORS", & IOLD, INEW, NPIV CALL MUMPS_ABORT() ENDIF 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 ELSE ICOL_BEG = 1 NBPANELS = 0 INEW = 1_8 NBROWS_PANEL = NPIV DO WHILE ( ICOL_BEG .LE. NPIV ) NBPANELS=NBPANELS + 1 ICOL_END = min(NB_TARGET * NBPANELS, NPIV) IF ( IW( ICOL_END ) < 0 ) THEN ICOL_END = ICOL_END + 1 ENDIF NBCOLS_PANEL = ICOL_END - ICOL_BEG + 1 IOLD = int(ICOL_BEG-1,8) * int(LDA,8) + int(ICOL_BEG,8) DO I =1, NBROWS_PANEL IF (IOLD .NE. INEW) THEN DO J8=0, min(I+1, NBCOLS_PANEL)-1 A(INEW+J8) = A(IOLD+J8) ENDDO ENDIF INEW = INEW + int(NBCOLS_PANEL,8) IOLD = IOLD + int(LDA,8) ENDDO NBROWS_PANEL = NBROWS_PANEL - NBCOLS_PANEL ICOL_BEG = ICOL_END + 1 ENDDO IOLD = 1_8 + int(LDA,8)*int(NPIV,8) ENDIF NBROW_L_RECTANGLE_TO_MOVE = NBROW SIZE_COPY = int(NBROW_L_RECTANGLE_TO_MOVE,8) * int(NPIV,8) OMP_FLAG = SIZE_COPY .GT. int(KEEP(361),8) .AND. KEEP(405).EQ.0 IF (OMP_FLAG &) THEN !$OMP PARALLEL DO COLLAPSE(2) DO I = 0, NBROW_L_RECTANGLE_TO_MOVE-1 DO J8 = 0_8, int(NPIV - 1,8) A( INEW + J8 + int(I,8)*int(NPIV,8) ) = & A( IOLD + J8 + int(I,8)*int(LDA,8)) END DO ENDDO !$OMP END PARALLEL DO ELSE DO I = 0, NBROW_L_RECTANGLE_TO_MOVE-1 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 ENDIF 500 RETURN END SUBROUTINE DMUMPS_COMPACT_FACTORS_SYM SUBROUTINE DMUMPS_COMPACT_FACTORS_UNSYM(A, LDA, NPIV, NCONTIG, & KEEP, SIZEA ) IMPLICIT NONE INTEGER, INTENT(IN) :: NCONTIG, NPIV, LDA INTEGER(8), INTENT(IN) :: SIZEA DOUBLE PRECISION, INTENT(INOUT) :: A(SIZEA) INTEGER, INTENT(IN) :: KEEP(500) INTEGER I INTEGER(8) :: IDEST, ISRC INTEGER(8) :: J8 INTEGER :: NBLK2COPY INTEGER(8) :: IBLK, NBLK IF (int(NCONTIG,8) * int(NPIV,8) .LE. int(KEEP(361),8) & ) THEN IDEST = int(NPIV+1,8) ISRC = int(LDA+1,8) DO I = 2, NCONTIG DO J8 = 0_8, int(NPIV-1,8) A(IDEST+J8)=A(ISRC+J8) ENDDO ISRC = ISRC + int(LDA,8) IDEST = IDEST + int(NPIV,8) ENDDO ELSE NBLK2COPY = NCONTIG-1 IDEST = int(NPIV+1,8) ISRC = int(LDA+1,8) DO WHILE ( NBLK2COPY .GT. 0 .AND. & ISRC - IDEST .LT. int(max(KEEP(361),NPIV),8) ) DO J8 = 0, int(NPIV-1,8) A(IDEST+J8) = A(ISRC+J8) ENDDO ISRC = ISRC + int(LDA,8) IDEST = IDEST + int(NPIV,8) NBLK2COPY = NBLK2COPY - 1 END DO DO WHILE ( NBLK2COPY .GT. 0 ) NBLK = min( (ISRC - IDEST) / int(NPIV,8), int(NBLK2COPY,8) ) !$OMP PARALLEL DO COLLAPSE(2) DO IBLK = 0_8, NBLK - 1_8 DO J8 = 0_8, int(NPIV-1,8) A( IDEST + J8 + IBLK * int(NPIV,8) ) = & A( ISRC + J8 + IBLK * int(LDA,8) ) ENDDO ENDDO !$OMP END PARALLEL DO NBLK2COPY = NBLK2COPY - int(NBLK) ISRC = ISRC + NBLK * int(LDA,8) IDEST = IDEST + NBLK * int(NPIV,8) ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_COMPACT_FACTORS_UNSYM SUBROUTINE DMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, POSELT, & IPTRLU, NPIV, & NBCOL_STACK, NBROW_STACK, & NBROW_SEND, SIZECB, KEEP, PACKED_CB, & LAST_ALLOWED, NBROW_ALREADY_STACKED ) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: PACKED_CB DOUBLE PRECISION A(LA) INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND INTEGER, intent(inout) :: NBROW_ALREADY_STACKED INTEGER(8), intent(in) :: LAST_ALLOWED INTEGER(8) :: APOS, NPOS INTEGER NBROW INTEGER(8) :: J INTEGER I, KEEP(500) #if defined(ZERO_TRIANGLE) DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) #endif NBROW = NBROW_STACK + NBROW_SEND IF (NBROW_STACK .NE. 0 ) THEN NPOS = IPTRLU + SIZECB APOS = POSELT + int(NPIV+NBROW,8) & * int(LDA,8) - 1_8 IF ( KEEP(50) .EQ. 0 .OR. .NOT. PACKED_CB ) THEN APOS = APOS - int(LDA,8) * int(NBROW_ALREADY_STACKED,8) NPOS = NPOS & - int(NBCOL_STACK,8) * int(NBROW_ALREADY_STACKED,8) ELSE APOS = APOS - int(LDA - 1,8) * int(NBROW_ALREADY_STACKED,8) NPOS = NPOS - ( int(NBROW_ALREADY_STACKED,8) * & int(NBROW_ALREADY_STACKED+1,8) ) / 2_8 ENDIF DO I = NBROW - NBROW_ALREADY_STACKED, NBROW_SEND+1, -1 IF (KEEP(50).EQ.0) THEN IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. & LAST_ALLOWED ) THEN EXIT ENDIF DO J= 1_8,int(NBCOL_STACK,8) A(NPOS-J+1_8) = A(APOS-J+1_8) ENDDO NPOS = NPOS - int(NBCOL_STACK,8) ELSE IF (.NOT. PACKED_CB) THEN IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. & LAST_ALLOWED ) THEN EXIT ENDIF #if defined(ZERO_TRIANGLE) DO J = 1_8, int(NBCOL_STACK - I,8) A(NPOS - J + 1_8) = ZERO END DO #endif NPOS = NPOS + int(- NBCOL_STACK + I,8) ENDIF IF ( NPOS - int(I,8) + 1_8 .LT. LAST_ALLOWED ) THEN EXIT ENDIF DO J =1_8, int(I,8) A(NPOS-J+1_8) = A(APOS-J+1_8) ENDDO NPOS = NPOS - int(I,8) ENDIF IF (KEEP(50).EQ.0) THEN APOS = APOS - int(LDA,8) ELSE APOS = APOS - int(LDA + 1,8) ENDIF NBROW_ALREADY_STACKED = NBROW_ALREADY_STACKED + 1 ENDDO END IF RETURN END SUBROUTINE DMUMPS_COPY_CB_RIGHT_TO_LEFT SUBROUTINE DMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, POSELT, & IPTRLU, NPIV, & NBCOL_STACK, NBROW_STACK, & NBROW_SEND, SIZECB, KEEP, PACKED_CB) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: PACKED_CB DOUBLE PRECISION A(LA) INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND INTEGER(8) :: APOS, NPOS, APOS_ini, NPOS_ini INTEGER I, KEEP(500) INTEGER(8) :: J, LDA8 #if defined(ZERO_TRIANGLE) DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) #endif LDA8 = int(LDA,8) NPOS_ini = IPTRLU + 1_8 APOS_ini = POSELT + int(NPIV+NBROW_SEND,8)* LDA8 + int(NPIV,8) !$OMP PARALLEL DO PRIVATE(J, NPOS, APOS) IF (NBROW_STACK > KEEP(360)) DO I = 1, NBROW_STACK IF (PACKED_CB) THEN NPOS = NPOS_ini + int(I-1,8) * int(I,8)/2_8 + & int(I-1,8) * int(NBROW_SEND,8) ELSE NPOS = NPOS_ini + int(I-1,8) * int(NBCOL_STACK,8) ENDIF APOS = APOS_ini + int(I-1,8) * LDA8 IF (KEEP(50).EQ.0) THEN DO J = 1_8, int(NBCOL_STACK,8) A(NPOS+J-1_8) = A(APOS+J-1_8) ENDDO ELSE DO J = 1_8, int(I + NBROW_SEND,8) A(NPOS+J-1_8)=A(APOS+J-1_8) ENDDO #if defined(ZERO_TRIANGLE) IF (.NOT. PACKED_CB) THEN A(NPOS+int(I+NBROW_SEND,8): & NPOS+int(NBCOL_STACK-1,8))=ZERO ENDIF #endif ENDIF ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE DMUMPS_COPY_CB_LEFT_TO_RIGHT MUMPS_5.8.1/src/cmumps_mpi3_mod.F0000664000175000017500000000137615042446440016441 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_MPI3_MOD IMPLICIT NONE INTEGER, PARAMETER :: WIN_SYM_PERM272 = 272 INTEGER, PARAMETER :: WIN_FILS273 = 273 INTEGER, PARAMETER :: WIN_STEP274 = 274 INTEGER, PARAMETER :: WIN_LRGROUPS275 = 275 INTEGER, PARAMETER :: WIN_RG2L276 = 276 END MODULE CMUMPS_MPI3_MOD MUMPS_5.8.1/src/zlr_core.F0000664000175000017500000022604315042446442015167 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C Note: the last routine of this file, xMUMPS_TRUNCATED_RRQR is derived from C the LAPACK package, for which BSD 3-clause license applies C (see header of the routine). MODULE ZMUMPS_LR_CORE USE MUMPS_LR_COMMON USE ZMUMPS_LR_TYPE USE MUMPS_LR_STATS USE ZMUMPS_LR_DATA_M !$ USE OMP_LIB IMPLICIT NONE CONTAINS SUBROUTINE INIT_LRB(LRB_OUT,K,M,N,ISLR) C This routine simply initializes a LR block but does NOT allocate it C (allocation occurs somewhere else) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,M,N LOGICAL,INTENT(IN) :: ISLR LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%ISLR = ISLR NULLIFY(LRB_OUT%Q) NULLIFY(LRB_OUT%R) END SUBROUTINE INIT_LRB C C SUBROUTINE IS_FRONT_BLR_CANDIDATE(INODE, NIV, NFRONT, NASS, & BLRON, K489, & K490, K491, K492, K20, K60, IDAD, K38, & K123, LRSTATUS, K280, LRGROUPS) INTEGER,INTENT(IN) :: INODE, NFRONT, NASS, BLRON, K123, & K489, K490, & K491, K492, NIV, K20, K60, IDAD, K38 INTEGER,INTENT(OUT):: LRSTATUS INTEGER, INTENT(IN):: K280 INTEGER, INTENT(IN), OPTIONAL :: LRGROUPS(K280) C C Local variables LOGICAL :: COMPRESS_PANEL, COMPRESS_CB LRSTATUS = 0 C Type 3 node is not BLR IF (NIV.EQ.3) RETURN COMPRESS_PANEL = .FALSE. IF ((BLRON.NE.0).and.( & ((K492.LT.0).and.INODE.EQ.abs(K492)) & .or. & ( (K492.GT.0).and.(K491.LE.NFRONT) & .and.(K490.LE.NASS)))) THEN COMPRESS_PANEL = .TRUE. C Compression for NASS =1 is useless IF (NASS.LE.1) THEN COMPRESS_PANEL =.FALSE. ENDIF IF (present(LRGROUPS)) THEN IF (LRGROUPS (INODE) .LT. 0) COMPRESS_PANEL = .FALSE. ENDIF ENDIF COMPRESS_CB = .FALSE. IF ((BLRON.NE.0).and. & (K489.GT.0.AND.(K489.NE.2.OR.NIV.EQ.2)) & .and.( & ((K492.LT.0).and.INODE.EQ.abs(K492)) & .or. & ((K492.GT.0).AND.(NFRONT-NASS.GT.K491)))) & THEN COMPRESS_CB = .TRUE. ENDIF IF (.NOT.COMPRESS_PANEL) COMPRESS_CB=.FALSE. IF (COMPRESS_PANEL.OR.COMPRESS_CB) THEN IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN LRSTATUS = 1 ELSE IF (COMPRESS_PANEL.AND.(.NOT.COMPRESS_CB)) THEN LRSTATUS = 2 ELSE LRSTATUS = 3 ENDIF ELSE LRSTATUS = 0 ENDIF C C Schur complement cannot be BLR for now C IF ( INODE .EQ. K20 .AND. K60 .NE. 0 ) THEN LRSTATUS = 0 ENDIF C C Do not compress CB of children of root C IF ( IDAD .EQ. K38 .AND. K38 .NE.0 ) THEN COMPRESS_CB = .FALSE. IF (LRSTATUS.GE.2) THEN LRSTATUS = 2 ELSE LRSTATUS = 0 ENDIF ENDIF RETURN END SUBROUTINE IS_FRONT_BLR_CANDIDATE SUBROUTINE ALLOC_LRB(LRB_OUT,K,M,N,ISLR,IFLAG,IERROR,KEEP8) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,M,N INTEGER,INTENT(INOUT) :: IFLAG, IERROR LOGICAL,INTENT(IN) :: ISLR INTEGER(8) :: KEEP8(150) INTEGER :: MEM, allocok COMPLEX(kind=8) :: ZERO PARAMETER (ZERO=(0.0D0,0.0D0)) LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%ISLR = ISLR IF ((M.EQ.0).OR.(N.EQ.0)) THEN nullify(LRB_OUT%Q) nullify(LRB_OUT%R) RETURN ENDIF IF (ISLR) THEN IF (K.EQ.0) THEN nullify(LRB_OUT%Q) nullify(LRB_OUT%R) ELSE allocate(LRB_OUT%Q(M,K),LRB_OUT%R(K,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = K*(M+N) RETURN ENDIF ENDIF ELSE nullify(LRB_OUT%R) allocate(LRB_OUT%Q(M,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = M*N RETURN ENDIF ENDIF IF (ISLR) THEN MEM = M*K + N*K ELSE MEM = M*N ENDIF CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM,8), & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) RETURN END SUBROUTINE ALLOC_LRB SUBROUTINE ALLOC_LRB_FROM_ACC(ACC_LRB, LRB_OUT, K, M, N, LorU, & IFLAG, IERROR, KEEP8) TYPE(LRB_TYPE), INTENT(IN) :: ACC_LRB TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K, M, N, LorU INTEGER,INTENT(INOUT) :: IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER :: I IF (LorU.EQ.1) THEN CALL ALLOC_LRB(LRB_OUT,K,M,N,.TRUE.,IFLAG,IERROR,KEEP8) IF (IFLAG.LT.0) RETURN DO I=1,K LRB_OUT%Q(1:M,I) = ACC_LRB%Q(1:M,I) LRB_OUT%R(I,1:N) = -ACC_LRB%R(I,1:N) ENDDO ELSE CALL ALLOC_LRB(LRB_OUT,K,N,M,.TRUE.,IFLAG,IERROR,KEEP8) IF (IFLAG.LT.0) RETURN DO I=1,K LRB_OUT%Q(1:N,I) = ACC_LRB%R(I,1:N) LRB_OUT%R(I,1:M) = -ACC_LRB%Q(1:M,I) ENDDO ENDIF END SUBROUTINE ALLOC_LRB_FROM_ACC SUBROUTINE REGROUPING2(CUT, NPARTSASS, NASS, & NPARTSCB, NCB, IBCKSZ, ONLYCB, K472, & NFRONT, KEEP) INTEGER, INTENT(IN) :: IBCKSZ, NASS, NCB, NFRONT, KEEP(500) INTEGER, INTENT(INOUT) :: NPARTSCB, NPARTSASS INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER, POINTER, DIMENSION(:) :: NEW_CUT INTEGER :: I, INEW, MINSIZE, NEW_NPARTSASS, allocok LOGICAL :: ONLYCB, TRACE INTEGER, INTENT(IN) :: K472 INTEGER :: IBCKSZ2,IFLAG,IERROR ALLOCATE(NEW_CUT(max(NPARTSASS,1)+NPARTSCB+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = max(NPARTSASS,1)+NPARTSCB+1 write(*,*) 'Allocation problem in BLR routine REGROUPING2:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF CALL COMPUTE_BLR_VCS(K472, IBCKSZ2, IBCKSZ, NASS, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) NEW_NPARTSASS = max(NPARTSASS,1) IF (.NOT. ONLYCB) THEN NEW_CUT(1) = 1 INEW = 2 I = 2 DO WHILE (I .LE. NPARTSASS + 1) NEW_CUT(INEW) = CUT(I) TRACE = .FALSE. IF (NEW_CUT(INEW) - NEW_CUT(INEW-1) .GT. MINSIZE) THEN INEW = INEW + 1 TRACE = .TRUE. ENDIF I = I + 1 END DO IF (TRACE) THEN INEW = INEW - 1 ELSE IF (INEW .NE. 2) THEN NEW_CUT(INEW-1) = NEW_CUT(INEW) INEW = INEW - 1 ENDIF ENDIF NEW_NPARTSASS = INEW - 1 ENDIF IF (ONLYCB) THEN DO I=1,max(NPARTSASS,1)+1 NEW_CUT(I) = CUT(I) ENDDO ENDIF IF (NCB .EQ. 0) GO TO 50 INEW = NEW_NPARTSASS+2 I = max(NPARTSASS,1) + 2 DO WHILE (I .LE. max(NPARTSASS,1) + NPARTSCB + 1) NEW_CUT(INEW) = CUT(I) TRACE = .FALSE. IF (NEW_CUT(INEW) - NEW_CUT(INEW-1) .GT. MINSIZE) THEN INEW = INEW + 1 TRACE = .TRUE. ENDIF I = I + 1 END DO IF (TRACE) THEN INEW = INEW - 1 ELSE IF (INEW .NE. NEW_NPARTSASS+2) THEN NEW_CUT(INEW-1) = NEW_CUT(INEW) INEW = INEW - 1 ENDIF ENDIF NPARTSCB = INEW - 1 - NEW_NPARTSASS 50 CONTINUE NPARTSASS = NEW_NPARTSASS DEALLOCATE(CUT) ALLOCATE(CUT(NPARTSASS+NPARTSCB+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSASS+NPARTSCB+1 write(*,*) 'Allocation problem in BLR routine REGROUPING2:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF DO I=1,NPARTSASS+NPARTSCB+1 CUT(I) = NEW_CUT(I) ENDDO DEALLOCATE(NEW_CUT) END SUBROUTINE REGROUPING2 SUBROUTINE UPD_MRY_LU_LRGAIN( BLR_PANEL, NBBLOCKS & ) C Updates the memory gain associated with a given BLR panel INTEGER,INTENT(IN) :: NBBLOCKS TYPE(LRB_TYPE), INTENT(IN) :: BLR_PANEL(:) DOUBLE PRECISION :: MRY INTEGER :: I C MRY = 0.0D0 DO I = 1, NBBLOCKS IF (BLR_PANEL(I)%ISLR) THEN MRY = MRY + dble(BLR_PANEL(I)%M*BLR_PANEL(I)%N & - BLR_PANEL(I)%K*(BLR_PANEL(I)%M + BLR_PANEL(I)%N)) ELSE ! islr MRY = MRY + 0.0d0 ENDIF ! islr ENDDO !$OMP ATOMIC UPDATE MRY_LU_LRGAIN = MRY_LU_LRGAIN + MRY !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_LU_LRGAIN SUBROUTINE ZMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA, LRB, & NIV, SYM, LorU, IW, OFFSET_IW) C ----------- C Parameters C ----------- INTEGER(8), intent(in) :: LA INTEGER, intent(in) :: NFRONT, NIV, SYM, LorU, LDA INTEGER(8), intent(in) :: POSELT_LOCAL COMPLEX(kind=8), intent(inout) :: A(LA) TYPE(LRB_TYPE), intent(inout) :: LRB INTEGER, OPTIONAL:: OFFSET_IW INTEGER, OPTIONAL :: IW(*) C ----------- C Local variables C ----------- INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER :: M, N, I, J COMPLEX(kind=8), POINTER :: LR_BLOCK_PTR(:,:) COMPLEX(kind=8) :: ONE, MONE, ZERO COMPLEX(kind=8) :: MULT1, MULT2, A11, DETPIV, A22, A12 PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) N = LRB%N IF (LRB%ISLR) THEN M = LRB%K LR_BLOCK_PTR => LRB%R ELSE M = LRB%M LR_BLOCK_PTR => LRB%Q END IF IF (M.NE.0) THEN C Why is it Right, Lower, Tranpose? C Because A is stored by rows C but BLR_L is stored by columns IF (SYM.EQ.0.AND.LorU.EQ.0) THEN CALL ztrsm('R', 'L', 'T', 'N', M, N, ONE, & A(POSELT_LOCAL), NFRONT, & LR_BLOCK_PTR(1,1), M) ELSE CALL ztrsm('R', 'U', 'N', 'U', M, N, ONE, & A(POSELT_LOCAL), LDA, & LR_BLOCK_PTR(1,1), M) IF (LorU.EQ.0) THEN C Now apply D scaling IF (.NOT.present(OFFSET_IW)) THEN write(*,*) 'Internal error in ', & 'ZMUMPS_LRTRSM' CALL MUMPS_ABORT() ENDIF DPOS = POSELT_LOCAL I = 1 DO IF(I .GT. N) EXIT IF(IW(OFFSET_IW+I-1) .GT. 0) THEN C 1x1 pivot A11 = ONE/A(DPOS) CALL zscal(M, A11, LR_BLOCK_PTR(1,I), 1) DPOS = DPOS + int(LDA + 1,8) I = I+1 ELSE C 2x2 pivot POSPV1 = DPOS POSPV2 = DPOS+ int(LDA + 1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV DO J = 1,M MULT1 = A11*LR_BLOCK_PTR(J,I)+A12*LR_BLOCK_PTR(J,I+1) MULT2 = A12*LR_BLOCK_PTR(J,I)+A22*LR_BLOCK_PTR(J,I+1) LR_BLOCK_PTR(J,I) = MULT1 LR_BLOCK_PTR(J,I+1) = MULT2 ENDDO DPOS = POSPV2 + int(LDA + 1,8) I = I+2 ENDIF ENDDO ENDIF ENDIF ENDIF CALL UPD_FLOP_TRSM(LRB%M, LRB%N, LRB%K, LRB%ISLR, LorU) END SUBROUTINE ZMUMPS_LRTRSM SUBROUTINE ZMUMPS_LRGEMM_SCALING(LRB, SCALED, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, MAXI_CLUSTER) C This routine does the scaling (for the symmetric case) before C computing the LR product (done in ZMUMPS_LRGEMM4) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) COMPLEX(kind=8), intent(inout), DIMENSION(:,:) :: SCALED INTEGER,INTENT(IN) :: LD_DIAG, NFRONT, IW2(*) INTEGER(8), INTENT(IN) :: POSELTT COMPLEX(kind=8), INTENT(IN), OPTIONAL :: DIAG(*) INTEGER, INTENT(IN) :: MAXI_CLUSTER COMPLEX(kind=8), intent(inout) :: BLOCK(MAXI_CLUSTER) INTEGER :: J, NROWS COMPLEX(kind=8) :: PIV1, PIV2, OFFDIAG IF (LRB%ISLR) THEN NROWS = LRB%K ELSE NROWS = LRB%M ENDIF J = 1 DO WHILE (J <= LRB%N) IF (IW2(J) > 0) THEN SCALED(1:NROWS,J) = DIAG(1+LD_DIAG*(J-1)+J-1) & * SCALED(1:NROWS,J) J = J+1 ELSE !2x2 pivot PIV1 = DIAG(1+LD_DIAG*(J-1)+J-1) PIV2 = DIAG(1+LD_DIAG*J+J) OFFDIAG = DIAG(1+LD_DIAG*(J-1)+J) BLOCK(1:NROWS) = SCALED(1:NROWS,J) SCALED(1:NROWS,J) = PIV1 * SCALED(1:NROWS,J) & + OFFDIAG * SCALED(1:NROWS,J+1) SCALED(1:NROWS,J+1) = OFFDIAG * BLOCK(1:NROWS) & + PIV2 * SCALED(1:NROWS,J+1) J=J+2 ENDIF END DO END SUBROUTINE ZMUMPS_LRGEMM_SCALING SUBROUTINE ZMUMPS_LRGEMM4(ALPHA, & LRB1, LRB2, BETA, & A, LA, POSELTT, NFRONT, SYM, & IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & RANK, BUILDQ, & LUA_ACTIVATED, C Start of OPTIONAL arguments & LorU, & LRB3, MAXI_RANK, & MAXI_CLUSTER, & DIAG, LD_DIAG, IW2, BLOCK & ) C CC TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, SYM, TOL_OPT INTEGER,INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), INTENT(IN) :: POSELTT COMPLEX(kind=8), INTENT(IN), OPTIONAL :: DIAG(*) INTEGER,INTENT(IN), OPTIONAL :: LD_DIAG, IW2(*) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION, intent(in) :: TOLEPS COMPLEX(kind=8) :: ALPHA,BETA LOGICAL, INTENT(OUT) :: BUILDQ COMPLEX(kind=8), intent(inout), OPTIONAL :: BLOCK(*) INTEGER, INTENT(IN), OPTIONAL :: LorU LOGICAL, INTENT(IN) :: LUA_ACTIVATED INTEGER, INTENT(IN), OPTIONAL :: MAXI_CLUSTER INTEGER, INTENT(IN), OPTIONAL :: MAXI_RANK TYPE(LRB_TYPE), INTENT(INOUT), OPTIONAL :: LRB3 COMPLEX(kind=8), POINTER, DIMENSION(:,:) :: XY_YZ COMPLEX(kind=8), ALLOCATABLE, TARGET, DIMENSION(:,:) :: XQ, R_Y COMPLEX(kind=8), POINTER, DIMENSION(:,:) :: X, Y, Y1, Y2, Z CHARACTER(len=1) :: SIDE, TRANSY INTEGER :: K_XY, K_YZ, LDY, LDY1, LDY2, K_Y INTEGER :: LDXY_YZ, SAVE_K INTEGER :: I, J, RANK, MAXRANK, INFO, LWORK DOUBLE PRECISION, ALLOCATABLE :: RWORK_RRQR(:) COMPLEX(kind=8), ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:), & Y_RRQR(:,:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: allocok, MREQ COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) IF (LRB1%M.EQ.0) THEN RETURN ENDIF IF (LRB2%M.EQ.0) THEN ENDIF RANK = 0 BUILDQ = .FALSE. IF (LRB1%ISLR.AND.LRB2%ISLR) THEN IF ((LRB1%K.EQ.0).OR.(LRB2%K.EQ.0)) THEN GOTO 1200 ENDIF allocate(Y(LRB1%K,LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K GOTO 1570 ENDIF X => LRB1%Q K_Y = LRB1%N IF (SYM .EQ. 0) THEN Y1 => LRB1%R ELSE allocate(Y1(LRB1%K,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%K Y1(I,J) = LRB1%R(I,J) ENDDO ENDDO CALL ZMUMPS_LRGEMM_SCALING(LRB1, Y1, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY1 = LRB1%K Z => LRB2%Q Y2 => LRB2%R LDY2 = LRB2%K CALL zgemm('N', 'T', LRB1%K, LRB2%K, K_Y, ONE, & Y1(1,1), LDY1, Y2(1,1), LDY2, ZERO, Y(1,1), LRB1%K ) IF (MIDBLK_COMPRESS.GE.1) THEN LWORK = LRB2%K*(LRB2%K+1) allocate(Y_RRQR(LRB1%K,LRB2%K), & WORK_RRQR(LWORK), RWORK_RRQR(2*LRB2%K), & TAU_RRQR(MIN(LRB1%K,LRB2%K)), & JPVT_RRQR(LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K + LWORK + 2*LRB2%K + & MIN(LRB1%K,LRB2%K) + LRB2%K GOTO 1570 ENDIF DO J=1,LRB2%K DO I=1,LRB1%K Y_RRQR(I,J) = Y(I,J) ENDDO ENDDO MAXRANK = MIN(LRB1%K, LRB2%K)-1 MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) JPVT_RRQR = 0 CALL ZMUMPS_TRUNCATED_RRQR(LRB1%K, LRB2%K, Y_RRQR(1,1), & LRB1%K, JPVT_RRQR, TAU_RRQR, WORK_RRQR, & LRB2%K, RWORK_RRQR, TOLEPS, TOL_OPT, RANK, & MAXRANK, INFO, & BUILDQ) IF (RANK.GT.MAXRANK) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) BUILDQ = .FALSE. ELSE BUILDQ = .TRUE. ENDIF IF (BUILDQ) THEN IF (RANK.EQ.0) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) deallocate(Y) nullify(Y) C GOTO 1580 not ok because BUILDQ .EQV. true C would try to free XQ and R_Y that are not allocated C in that case. So we free Y1 now if it was allocated. IF (SYM .NE. 0) deallocate(Y1) GOTO 1200 ELSE allocate(XQ(LRB1%M,RANK), R_Y(RANK,LRB2%K), & stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*RANK + RANK*LRB2%K GOTO 1570 ENDIF DO J=1, LRB2%K R_Y(1:MIN(RANK,J),JPVT_RRQR(J)) = & Y_RRQR(1:MIN(RANK,J),J) IF(J.LT.RANK) R_Y(MIN(RANK,J)+1: & RANK,JPVT_RRQR(J))= ZERO END DO C LWORK=LRB2%K*(LRB2%K+1), with LRB2%K>RANK C large enough for zungqr CALL zungqr & (LRB1%K, RANK, RANK, Y_RRQR(1,1), & LRB1%K, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) CALL zgemm('N', 'N', LRB1%M, RANK, LRB1%K, ONE, & X(1,1), LRB1%M, Y_RRQR(1,1), LRB1%K, ZERO, & XQ(1,1), LRB1%M) deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) nullify(X) X => XQ K_XY = RANK deallocate(Y) nullify(Y) Y => R_Y LDY = RANK K_YZ = LRB2%K TRANSY = 'N' SIDE = 'R' ENDIF ENDIF ENDIF IF (.NOT.BUILDQ) THEN LDY = LRB1%K K_XY = LRB1%K K_YZ = LRB2%K TRANSY = 'N' IF (LRB1%K .GE. LRB2%K) THEN SIDE = 'L' ELSE SIDE = 'R' ENDIF ENDIF ENDIF IF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN IF (LRB1%K.EQ.0) THEN GOTO 1200 ENDIF SIDE = 'R' K_XY = LRB1%K TRANSY = 'N' Z => LRB2%Q X => LRB1%Q LDY = LRB1%K IF (SYM .EQ. 0) THEN Y => LRB1%R ELSE allocate(Y(LRB1%K,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%K Y(I,J) = LRB1%R(I,J) ENDDO ENDDO CALL ZMUMPS_LRGEMM_SCALING(LRB1, Y, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF K_YZ = LRB2%N ENDIF IF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN IF (LRB2%K.EQ.0) THEN GOTO 1200 ENDIF SIDE = 'L' K_YZ = LRB2%K X => LRB1%Q TRANSY = 'T' K_XY = LRB1%N IF (SYM .EQ. 0) THEN Y => LRB2%R ELSE allocate(Y(LRB2%K,LRB2%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB2%K*LRB2%N GOTO 1570 ENDIF DO J=1,LRB2%N DO I=1,LRB2%K Y(I,J) = LRB2%R(I,J) ENDDO ENDDO CALL ZMUMPS_LRGEMM_SCALING(LRB2, Y, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY = LRB2%K Z => LRB2%Q ENDIF IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .EQ. 0) THEN X => LRB1%Q ELSE allocate(X(LRB1%M,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%M X(I,J) = LRB1%Q(I,J) ENDDO ENDDO CALL ZMUMPS_LRGEMM_SCALING(LRB1, X, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF SIDE = 'N' Z => LRB2%Q K_XY = LRB1%N ENDIF IF (LUA_ACTIVATED) THEN SAVE_K = LRB3%K IF (SIDE == 'L') THEN LRB3%K = LRB3%K+K_YZ ELSEIF (SIDE == 'R') THEN LRB3%K = LRB3%K+K_XY ENDIF ENDIF IF (SIDE == 'L') THEN ! LEFT: XY_YZ = X*Y; A = XY_YZ*Z IF (.NOT.LUA_ACTIVATED) THEN allocate(XY_YZ(LRB1%M,K_YZ),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*K_YZ GOTO 1570 ENDIF LDXY_YZ = LRB1%M ELSE IF (SAVE_K+K_YZ.GT.MAXI_RANK) THEN write(*,*) 'Internal error in ZMUMPS_LRGEMM4 1a', & 'K_ACC+K_CUR>K_MAX:',SAVE_K,K_YZ,MAXI_RANK CALL MUMPS_ABORT() ENDIF IF (LRB3%M.NE.LRB1%M) THEN write(*,*) 'Internal error in ZMUMPS_LRGEMM4 1b', & 'LRB1%M =/= LRB3%M',LRB1%M,LRB3%M CALL MUMPS_ABORT() ENDIF XY_YZ => LRB3%Q(1:LRB1%M,SAVE_K+1:SAVE_K+K_YZ) LDXY_YZ = MAXI_CLUSTER DO I=1,K_YZ LRB3%R(SAVE_K+I,1:LRB2%M) = Z(1:LRB2%M,I) ENDDO ENDIF CALL zgemm('N', TRANSY, LRB1%M, K_YZ, K_XY, ONE, & X(1,1), LRB1%M, Y(1,1), LDY, ZERO, XY_YZ(1,1), & LDXY_YZ) IF (.NOT.LUA_ACTIVATED) THEN CALL zgemm('N', 'T', LRB1%M, LRB2%M, K_YZ, ALPHA, & XY_YZ(1,1), LRB1%M, Z(1,1), LRB2%M, BETA, & A(POSELTT), NFRONT) deallocate(XY_YZ) ENDIF ELSEIF (SIDE == 'R') THEN ! RIGHT: XY_YZ = Y*Z; A = X*XY_YZ IF (.NOT.LUA_ACTIVATED) THEN allocate(XY_YZ(K_XY,LRB2%M),stat=allocok) IF (allocok > 0) THEN MREQ = K_XY*LRB2%M GOTO 1570 ENDIF LDXY_YZ = K_XY ELSE IF (SAVE_K+K_XY.GT.MAXI_RANK) THEN write(*,*) 'Internal error in ZMUMPS_LRGEMM4 2a', & 'K_ACC+K_CUR>K_MAX:',SAVE_K,K_XY,MAXI_RANK CALL MUMPS_ABORT() ENDIF IF (LRB3%N.NE.LRB2%M) THEN write(*,*) 'Internal error in ZMUMPS_LRGEMM4 2b', & 'LRB2%M =/= LRB3%N',LRB2%M,LRB3%N CALL MUMPS_ABORT() ENDIF XY_YZ => LRB3%R(SAVE_K+1:SAVE_K+K_XY,1:LRB2%M) LDXY_YZ = MAXI_RANK DO I=1,K_XY LRB3%Q(1:LRB1%M,SAVE_K+I) = X(1:LRB1%M,I) ENDDO ENDIF CALL zgemm(TRANSY, 'T', K_XY, LRB2%M, K_YZ, ONE, & Y(1,1), LDY, Z(1,1), LRB2%M, ZERO, XY_YZ(1,1), & LDXY_YZ) IF (.NOT.LUA_ACTIVATED) THEN CALL zgemm('N', 'N', LRB1%M, LRB2%M, K_XY, ALPHA, & X(1,1), LRB1%M, XY_YZ(1,1), K_XY, BETA, A(POSELTT), & NFRONT) deallocate(XY_YZ) ENDIF ELSE ! SIDE == 'N' : NONE; A = X*Z CALL zgemm('N', 'T', LRB1%M, LRB2%M, K_XY, ALPHA, & X(1,1), LRB1%M, Z(1,1), LRB2%M, BETA, A(POSELTT), & NFRONT) ENDIF GOTO 1580 1570 CONTINUE C Alloc NOT ok!! IFLAG = -13 IERROR = MREQ RETURN 1580 CONTINUE C Alloc ok!! IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .NE. 0) deallocate(X) ELSEIF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN IF (SYM .NE. 0) deallocate(Y) ELSEIF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .NE. 0) deallocate(Y) ELSE IF (SYM .NE. 0) deallocate(Y1) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN deallocate(XQ) deallocate(R_Y) ELSE deallocate(Y) ENDIF ENDIF 1200 CONTINUE END SUBROUTINE ZMUMPS_LRGEMM4 SUBROUTINE ZMUMPS_DECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, LorU, & COUNT_FLOPS) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK INTEGER(8), INTENT(IN) :: POSELTT LOGICAL, OPTIONAL :: COUNT_FLOPS LOGICAL :: COUNT_FLOPS_LOC INTEGER :: LorU COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) IF (present(COUNT_FLOPS)) THEN COUNT_FLOPS_LOC=COUNT_FLOPS ELSE COUNT_FLOPS_LOC=.TRUE. ENDIF CALL zgemm('N', 'N', ACC_LRB%M, ACC_LRB%N, ACC_LRB%K, & MONE, ACC_LRB%Q(1,1), MAXI_CLUSTER, ACC_LRB%R(1,1), & MAXI_RANK, ONE, A(POSELTT), NFRONT) ACC_LRB%K = 0 END SUBROUTINE ZMUMPS_DECOMPRESS_ACC SUBROUTINE ZMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & TOLEPS, TOL_OPT, KPERCENT, BUILDQ, LorU, CB_COMPRESS) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, LorU, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT INTEGER(8), INTENT(IN) :: POSELTT DOUBLE PRECISION, intent(in) :: TOLEPS LOGICAL, INTENT(OUT) :: BUILDQ LOGICAL, INTENT(IN) :: CB_COMPRESS DOUBLE PRECISION, ALLOCATABLE :: RWORK_RRQR(:) COMPLEX(kind=8), ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: INFO, RANK, MAXRANK, LWORK INTEGER :: I, J, M, N INTEGER :: allocok, MREQ COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) M = ACC_LRB%M N = ACC_LRB%N MAXRANK = floor(dble(M*N)/dble(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) LWORK = N*(N+1) allocate(WORK_RRQR(LWORK), RWORK_RRQR(2*N), & TAU_RRQR(N), & JPVT_RRQR(N), stat=allocok) IF (allocok > 0) THEN MREQ = LWORK +4 *N GOTO 100 ENDIF DO I=1,N ACC_LRB%Q(1:M,I)= & - A(POSELTT+int(I-1,8)*int(NFRONT,8) : & POSELTT+int(I-1,8)*int(NFRONT,8) + int(M-1,8) ) END DO JPVT_RRQR = 0 CALL ZMUMPS_TRUNCATED_RRQR(M, N, ACC_LRB%Q(1,1), & MAXI_CLUSTER, JPVT_RRQR(1), TAU_RRQR(1), & WORK_RRQR(1), & N, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK, MAXRANK, INFO, & BUILDQ) IF (BUILDQ) THEN DO J=1, N ACC_LRB%R(1:MIN(RANK,J),JPVT_RRQR(J)) = & ACC_LRB%Q(1:MIN(RANK,J),J) IF(J.LT.RANK) ACC_LRB%R(MIN(RANK,J)+1: & RANK,JPVT_RRQR(J))= ZERO END DO CALL zungqr & (M, RANK, RANK, ACC_LRB%Q(1,1), & MAXI_CLUSTER, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) DO I=1,N A( POSELTT+int(I-1,8)*int(NFRONT,8) : & POSELTT+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) = ZERO END DO ACC_LRB%K = RANK CALL UPD_FLOP_COMPRESS(ACC_LRB%M, ACC_LRB%N, ACC_LRB%K, & ACC_LRB%ISLR, CB_COMPRESS=CB_COMPRESS) ELSE ACC_LRB%K = RANK ACC_LRB%ISLR = .FALSE. CALL UPD_FLOP_COMPRESS(ACC_LRB%M, ACC_LRB%N, ACC_LRB%K, & ACC_LRB%ISLR, CB_COMPRESS=CB_COMPRESS) ACC_LRB%ISLR = .TRUE. ACC_LRB%K = 0 ENDIF deallocate(JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & ZMUMPS_COMPRESS_FR_UPDATES: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE ZMUMPS_COMPRESS_FR_UPDATES SUBROUTINE ZMUMPS_RECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER :: IFLAG, IERROR INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER,INTENT(INOUT) :: NEW_ACC_RANK INTEGER(8), INTENT(IN) :: POSELTT INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB DOUBLE PRECISION, intent(in) :: TOLEPS DOUBLE PRECISION, ALLOCATABLE:: RWORK_RRQR(:) COMPLEX(kind=8), ALLOCATABLE:: WORK_RRQR(:), TAU_RRQR(:) COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:),TARGET:: Q1, R1, & Q2, R2 INTEGER, ALLOCATABLE :: JPVT_RRQR(:) TYPE(LRB_TYPE) :: LRB1, LRB2 INTEGER :: INFO, RANK1, RANK2, RANK, MAXRANK, LWORK LOGICAL :: BUILDQ, BUILDQ1, BUILDQ2, SKIP1, SKIP2 INTEGER :: I, J, M, N, K INTEGER :: allocok, MREQ COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) SKIP1 = .FALSE. SKIP2 = .FALSE. SKIP1 = .TRUE. 1500 CONTINUE M = ACC_LRB%M N = ACC_LRB%N K = ACC_LRB%K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) IF (.FALSE.) THEN CALL ZMUMPS_RECOMPRESS_ACC_V2(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, & NEW_ACC_RANK) K = ACC_LRB%K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) SKIP1 = .TRUE. SKIP2 = K.EQ.0 ENDIF IF (SKIP1.AND.SKIP2) GOTO 1600 allocate(Q1(M,K), Q2(N,K), & WORK_RRQR(LWORK), & RWORK_RRQR(2*K), & TAU_RRQR(K), & JPVT_RRQR(K), stat=allocok) IF (allocok > 0) THEN MREQ = LWORK + M*N + N*K+ 4 * K GOTO 100 ENDIF IF (SKIP1) THEN BUILDQ1 = .FALSE. ELSE DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J) ENDDO ENDDO JPVT_RRQR = 0 CALL ZMUMPS_TRUNCATED_RRQR(M, K, Q1(1,1), & M, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, RANK1, & MAXRANK, INFO, & BUILDQ1) ENDIF IF (BUILDQ1) THEN allocate(R1(RANK1,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK1*K GOTO 100 ENDIF DO J=1, K R1(1:MIN(RANK1,J),JPVT_RRQR(J)) = & Q1(1:MIN(RANK1,J),J) IF(J.LT.RANK1) R1(MIN(RANK1,J)+1: & RANK1,JPVT_RRQR(J))= ZERO END DO CALL zungqr & (M, RANK1, RANK1, Q1(1,1), & M, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) ENDIF IF (SKIP2) THEN BUILDQ2 = .FALSE. ELSE DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J,I) ENDDO ENDDO JPVT_RRQR = 0 CALL ZMUMPS_TRUNCATED_RRQR(N, K, Q2(1,1), & N, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK2, MAXRANK, INFO, & BUILDQ2) ENDIF IF (BUILDQ2) THEN allocate(R2(RANK2,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK2*K GOTO 100 ENDIF DO J=1, K R2(1:MIN(RANK2,J),JPVT_RRQR(J)) = & Q2(1:MIN(RANK2,J),J) IF(J.LT.RANK2) R2(MIN(RANK2,J)+1: & RANK2,JPVT_RRQR(J))= ZERO END DO CALL zungqr & (N, RANK2, RANK2, Q2(1,1), & N, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) ENDIF CALL INIT_LRB(LRB1,RANK1,M,K,BUILDQ1) CALL INIT_LRB(LRB2,RANK2,N,K,BUILDQ2) IF (BUILDQ1.OR.BUILDQ2) THEN IF (BUILDQ1) THEN LRB1%R => R1 ELSE DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J) ENDDO ENDDO ENDIF LRB1%Q => Q1 IF (BUILDQ2) THEN LRB2%R => R2 ELSE DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J,I) ENDDO ENDDO ENDIF LRB2%Q => Q2 ACC_LRB%K = 0 CALL ZMUMPS_LRGEMM4(MONE, LRB1, LRB2, ONE, & A, LA, POSELTT, NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS-1, TOLEPS, TOL_OPT, & KPERCENT_RMB, & RANK, BUILDQ, .TRUE., LRB3=ACC_LRB, & MAXI_RANK=MAXI_RANK, MAXI_CLUSTER=MAXI_CLUSTER) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(LRB1%M, LRB1%N, LRB1%K, LRB1%ISLR, & LRB2%M, LRB2%N, LRB2%K, LRB2%ISLR, & MIDBLK_COMPRESS-1, RANK, BUILDQ, & .TRUE., .FALSE., REC_ACC=.TRUE.) ENDIF IF (.NOT. SKIP1) & CALL UPD_FLOP_COMPRESS(LRB1%M, LRB1%N, LRB1%K, & LRB1%ISLR, REC_ACC=.TRUE.) IF (.NOT. SKIP2) & CALL UPD_FLOP_COMPRESS(LRB2%M, LRB2%N, LRB2%K, & LRB2%ISLR, REC_ACC=.TRUE.) deallocate(Q1,Q2) IF (BUILDQ1) deallocate(R1) IF (BUILDQ2) deallocate(R2) deallocate(JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) IF (SKIP1.AND.(RANK2.GT.0)) THEN SKIP1 = .FALSE. SKIP2 = .TRUE. GOTO 1500 ENDIF 1600 CONTINUE NEW_ACC_RANK = 0 RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & ZMUMPS_RECOMPRESS_ACC: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE ZMUMPS_RECOMPRESS_ACC RECURSIVE SUBROUTINE ZMUMPS_RECOMPRESS_ACC_NARYTREE( & ACC_LRB, MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, & KPERCENT_LUA, K478, RANK_LIST, POS_LIST, NB_NODES, & LEVEL, ACC_TMP) TYPE(LRB_TYPE),TARGET,INTENT(INOUT) :: ACC_LRB TYPE(LRB_TYPE),TARGET,INTENT(INOUT),OPTIONAL :: ACC_TMP INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER(8), INTENT(IN) :: POSELTT INTEGER(8) :: KEEP8(150) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB DOUBLE PRECISION, intent(in) :: TOLEPS INTEGER,INTENT(IN) :: K478, NB_NODES, LEVEL INTEGER,INTENT(INOUT) :: RANK_LIST(NB_NODES), POS_LIST(NB_NODES) TYPE(LRB_TYPE) :: LRB, ACC_NEW TYPE(LRB_TYPE), POINTER :: LRB_PTR LOGICAL :: RESORT INTEGER :: I, J, M, N, L, NODE_RANK, NARY, IOFF, IMAX, CURPOS INTEGER :: NB_NODES_NEW, KTOT, NEW_ACC_RANK INTEGER, ALLOCATABLE :: RANK_LIST_NEW(:), POS_LIST_NEW(:) COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) INTEGER :: allocok RESORT = .FALSE. M = ACC_LRB%M N = ACC_LRB%N NARY = -K478 IOFF = 0 NB_NODES_NEW = NB_NODES/NARY IF (NB_NODES_NEW*NARY.NE.NB_NODES) THEN NB_NODES_NEW = NB_NODES_NEW + 1 ENDIF ALLOCATE(RANK_LIST_NEW(NB_NODES_NEW),POS_LIST_NEW(NB_NODES_NEW), & stat=allocok) IF (allocok > 0) THEN write(*,*) 'Allocation error of RANK_LIST_NEW/POS_LIST_NEW ', & 'in ZMUMPS_RECOMPRESS_ACC_NARYTREE' call MUMPS_ABORT() ENDIF DO J=1,NB_NODES_NEW NODE_RANK = RANK_LIST(IOFF+1) CURPOS = POS_LIST(IOFF+1) IMAX = MIN(NARY,NB_NODES-IOFF) IF (IMAX.GE.2) THEN DO I=2,IMAX IF (POS_LIST(IOFF+I).NE.CURPOS+NODE_RANK) THEN DO L=0,RANK_LIST(IOFF+I)-1 ACC_LRB%Q(1:M,CURPOS+NODE_RANK+L) = & ACC_LRB%Q(1:M,POS_LIST(IOFF+I)+L) ACC_LRB%R(CURPOS+NODE_RANK+L,1:N) = & ACC_LRB%R(POS_LIST(IOFF+I)+L,1:N) ENDDO POS_LIST(IOFF+I) = CURPOS+NODE_RANK ENDIF NODE_RANK = NODE_RANK+RANK_LIST(IOFF+I) ENDDO CALL INIT_LRB(LRB,NODE_RANK,M,N,.TRUE.) IF (.NOT.RESORT.OR.LEVEL.EQ.0) THEN LRB%Q => ACC_LRB%Q(1:M,CURPOS:CURPOS+NODE_RANK) LRB%R => ACC_LRB%R(CURPOS:CURPOS+NODE_RANK,1:N) ELSE LRB%Q => ACC_TMP%Q(1:M,CURPOS:CURPOS+NODE_RANK) LRB%R => ACC_TMP%R(CURPOS:CURPOS+NODE_RANK,1:N) ENDIF NEW_ACC_RANK = NODE_RANK-RANK_LIST(IOFF+1) IF (NEW_ACC_RANK.GT.0) THEN CALL ZMUMPS_RECOMPRESS_ACC(LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF RANK_LIST_NEW(J) = LRB%K POS_LIST_NEW(J) = CURPOS ELSE RANK_LIST_NEW(J) = NODE_RANK POS_LIST_NEW(J) = CURPOS ENDIF IOFF = IOFF+IMAX ENDDO IF (NB_NODES_NEW.GT.1) THEN IF (RESORT) THEN KTOT = SUM(RANK_LIST_NEW) CALL INIT_LRB(ACC_NEW,KTOT,M,N,.TRUE.) ALLOCATE(ACC_NEW%Q(MAXI_CLUSTER,MAXI_RANK), & ACC_NEW%R(MAXI_RANK,MAXI_CLUSTER), stat=allocok) IF (allocok > 0) THEN write(*,*) 'Allocation error of ACC_NEW%Q/ACC_NEW%R ', & 'in ZMUMPS_RECOMPRESS_ACC_NARYTREE' call MUMPS_ABORT() ENDIF CALL MUMPS_SORT_INT(NB_NODES_NEW, RANK_LIST_NEW, & POS_LIST_NEW) CURPOS = 1 IF (LEVEL.EQ.0) THEN LRB_PTR => ACC_LRB ELSE LRB_PTR => ACC_TMP ENDIF DO J=1,NB_NODES_NEW DO L=0,RANK_LIST_NEW(J)-1 ACC_NEW%Q(1:M,CURPOS+L) = & LRB_PTR%Q(1:M,POS_LIST_NEW(J)+L) ACC_NEW%R(CURPOS+L,1:N) = & LRB_PTR%R(POS_LIST_NEW(J)+L,1:N) ENDDO POS_LIST_NEW(J) = CURPOS CURPOS = CURPOS + RANK_LIST_NEW(J) ENDDO IF (LEVEL.GT.0) THEN CALL DEALLOC_LRB(ACC_TMP, KEEP8, 4) ENDIF CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST_NEW, POS_LIST_NEW, NB_NODES_NEW, & LEVEL+1, ACC_NEW) ELSE CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST_NEW, POS_LIST_NEW, NB_NODES_NEW, LEVEL+1) ENDIF ELSE IF (POS_LIST_NEW(1).NE.1) THEN write(*,*) 'Internal error in ', & 'ZMUMPS_RECOMPRESS_ACC_NARYTREE', POS_LIST_NEW(1) ENDIF ACC_LRB%K = RANK_LIST_NEW(1) IF (RESORT.AND.LEVEL.GT.0) THEN DO L=1,ACC_LRB%K DO I=1,M ACC_LRB%Q(I,L) = ACC_TMP%Q(I,L) ENDDO DO I=1,N ACC_LRB%R(L,I) = ACC_TMP%R(L,I) ENDDO ENDDO CALL DEALLOC_LRB(ACC_TMP, KEEP8, 4) ENDIF ENDIF DEALLOCATE(RANK_LIST_NEW, POS_LIST_NEW) END SUBROUTINE ZMUMPS_RECOMPRESS_ACC_NARYTREE SUBROUTINE ZMUMPS_RECOMPRESS_ACC_V2(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER,INTENT(INOUT) :: NEW_ACC_RANK INTEGER(8), INTENT(IN) :: POSELTT INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB DOUBLE PRECISION, intent(in) :: TOLEPS DOUBLE PRECISION, ALLOCATABLE :: RWORK_RRQR(:) COMPLEX(kind=8), ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:), TARGET :: & Q1, R1, Q2, PROJ INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: INFO, RANK1, MAXRANK, LWORK LOGICAL :: BUILDQ1 INTEGER :: I, J, M, N, K, K1 INTEGER :: allocok, MREQ COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) M = ACC_LRB%M N = ACC_LRB%N K = NEW_ACC_RANK K1 = ACC_LRB%K - K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) allocate(Q1(M,K), PROJ(K1, K), & WORK_RRQR(LWORK), RWORK_RRQR(2*K), & TAU_RRQR(K), & JPVT_RRQR(K), stat=allocok) IF (allocok > 0) THEN MREQ = M * K + K1 * K + LWORK + 4 * K GOTO 100 ENDIF DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J+K1) ENDDO ENDDO CALL zgemm('T', 'N', K1, K, M, ONE, ACC_LRB%Q(1,1), & MAXI_CLUSTER, Q1(1,1), M, ZERO, PROJ(1,1), K1) CALL zgemm('N', 'N', M, K, K1, MONE, ACC_LRB%Q(1,1), & MAXI_CLUSTER, PROJ(1,1), K1, ONE, Q1(1,1), M) JPVT_RRQR = 0 CALL ZMUMPS_TRUNCATED_RRQR(M, K, Q1(1,1), & M, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK1, MAXRANK, INFO, & BUILDQ1) IF (BUILDQ1) THEN allocate(Q2(N,K), stat=allocok) IF (allocok > 0) THEN MREQ = N*K GOTO 100 ENDIF DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J+K1,I) ENDDO ENDDO CALL zgemm('N', 'T', K1, N, K, ONE, PROJ(1,1), K1, & Q2(1,1), N, ONE, ACC_LRB%R(1,1), MAXI_RANK) IF (RANK1.GT.0) THEN allocate(R1(RANK1,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK1*K GOTO 100 ENDIF DO J=1, K R1(1:MIN(RANK1,J),JPVT_RRQR(J)) = & Q1(1:MIN(RANK1,J),J) IF(J.LT.RANK1) R1(MIN(RANK1,J)+1: & RANK1,JPVT_RRQR(J))= ZERO END DO CALL zungqr & (M, RANK1, RANK1, Q1(1,1), & M, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) DO J=1,K DO I=1,M ACC_LRB%Q(I,J+K1) = Q1(I,J) ENDDO ENDDO CALL zgemm('N', 'T', RANK1, N, K, ONE, R1(1,1), RANK1, & Q2(1,1), N, ZERO, ACC_LRB%R(K1+1,1), MAXI_RANK) deallocate(R1) ENDIF deallocate(Q2) ACC_LRB%K = K1 + RANK1 ENDIF deallocate(PROJ) deallocate(Q1, JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & ZMUMPS_RECOMPRESS_ACC_V2: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE ZMUMPS_RECOMPRESS_ACC_V2 SUBROUTINE MAX_CLUSTER(CUT,CUT_SIZE,MAXI_CLUSTER) INTEGER, intent(in) :: CUT_SIZE INTEGER, intent(out) :: MAXI_CLUSTER INTEGER, DIMENSION(:), intent(in) :: CUT INTEGER :: I MAXI_CLUSTER = 0 DO I = 1, CUT_SIZE IF (CUT(I+1) - CUT(I) .GE. MAXI_CLUSTER) THEN MAXI_CLUSTER = CUT(I+1) - CUT(I) END IF END DO END SUBROUTINE MAX_CLUSTER SUBROUTINE ZMUMPS_GET_LUA_ORDER(NB_BLOCKS, ORDER, RANK, IWHANDLER, & SYM, FS_OR_CB, I, J, FRFR_UPDATES, & LBANDSLAVE_IN, K474, BLR_U_COL) C ----------- C Parameters C ----------- INTEGER, INTENT(IN) :: NB_BLOCKS, IWHANDLER, SYM, FS_OR_CB, I, J INTEGER, INTENT(OUT) :: ORDER(NB_BLOCKS), RANK(NB_BLOCKS), & FRFR_UPDATES LOGICAL, OPTIONAL, INTENT(IN) :: LBANDSLAVE_IN INTEGER, OPTIONAL, INTENT(IN) :: K474 TYPE(LRB_TYPE), POINTER, OPTIONAL :: BLR_U_COL(:) C ----------- C Local variables C ----------- INTEGER :: K, IND_L, IND_U LOGICAL :: LBANDSLAVE TYPE(LRB_TYPE), POINTER :: BLR_L(:), BLR_U(:) IF (PRESENT(LBANDSLAVE_IN)) THEN LBANDSLAVE = LBANDSLAVE_IN ELSE LBANDSLAVE = .FALSE. ENDIF IF ((SYM.NE.0).AND.(FS_OR_CB.EQ.0).AND.(J.NE.0)) THEN write(6,*) 'Internal error in ZMUMPS_GET_LUA_ORDER', & 'SYM, FS_OR_CB, J = ',SYM,FS_OR_CB,J CALL MUMPS_ABORT() ENDIF FRFR_UPDATES = 0 DO K = 1, NB_BLOCKS ORDER(K) = K IF (FS_OR_CB.EQ.0) THEN ! FS IF (J.EQ.0) THEN ! L panel IND_L = NB_BLOCKS+I-K IND_U = NB_BLOCKS+1-K ELSE ! U panel IND_L = NB_BLOCKS+1-K IND_U = NB_BLOCKS+I-K ENDIF ELSE ! CB IND_L = I-K IND_U = J-K ENDIF IF (LBANDSLAVE) THEN IND_L = I IF (K474.GE.2) THEN IND_U = K ENDIF ENDIF CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, ! L Panel & K, BLR_L) IF (SYM.EQ.0) THEN IF (LBANDSLAVE.AND.K474.GE.2) THEN BLR_U => BLR_U_COL ELSE CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, ! L Panel & K, BLR_U) ENDIF ELSE BLR_U => BLR_L ENDIF IF (BLR_L(IND_L)%ISLR) THEN IF (BLR_U(IND_U)%ISLR) THEN RANK(K) = min(BLR_L(IND_L)%K, BLR_U(IND_U)%K) ELSE RANK(K) = BLR_L(IND_L)%K ENDIF ELSE IF (BLR_U(IND_U)%ISLR) THEN RANK(K) = BLR_U(IND_U)%K ELSE RANK(K) = -1 FRFR_UPDATES = FRFR_UPDATES + 1 ENDIF ENDIF ENDDO CALL MUMPS_SORT_INT(NB_BLOCKS, RANK, ORDER) END SUBROUTINE ZMUMPS_GET_LUA_ORDER SUBROUTINE ZMUMPS_BLR_ASM_NIV1 (A, LA, POSEL1, NFRONT, NASS1, & IWHANDLER, SON_IW, LIW, LSTK, NELIM, K1, K2, SYM, & KEEP, KEEP8, OPASSW) C C Purpose C ======= C C Called by a level 1 master assembling the contribution C block of a level 1 son that has been BLR-compressed C C C Parameters C ========== C INTEGER(8) :: LA, POSEL1 INTEGER :: LIW, NFRONT, NASS1, LSTK, NELIM, K1, K2, IWHANDLER COMPLEX(kind=8) :: A(LA) C INTEGER :: SON_IW(LIW) INTEGER :: SON_IW(:) ! contiguity information lost but no copy INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER :: SYM DOUBLE PRECISION, INTENT(INOUT) :: OPASSW C C Local variables C =============== C COMPLEX(kind=8), ALLOCATABLE :: SON_A(:) INTEGER(8) :: APOS, SON_APOS, IACHK, JJ2, NFRONT8 INTEGER :: KK, KK1, allocok, SON_LA TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:), LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_DYNAMIC INTEGER :: NB_INCB, NB_INASM, NB_BLR, I, J, M, N, II, NPIV, & IBIS, IBIS_END, FIRST_ROW, LAST_ROW, FIRST_COL, LAST_COL, & SON_LDA DOUBLE PRECISION :: PROMOTE_COST COMPLEX(kind=8) :: ONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_DYN(IWHANDLER, & BEGS_BLR_DYNAMIC) CALL ZMUMPS_BLR_RETRIEVE_CB_LRB(IWHANDLER, CB_LRB) NB_BLR = size(BEGS_BLR_DYNAMIC)-1 NB_INCB = size(CB_LRB,1) NB_INASM = NB_BLR - NB_INCB NPIV = BEGS_BLR_DYNAMIC(NB_INASM+1)-1 NFRONT8 = int(NFRONT,8) IF (SYM.EQ.0) THEN IBIS_END = NB_INCB*NB_INCB ELSE IBIS_END = NB_INCB*(NB_INCB+1)/2 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP DO PRIVATE(IBIS, I, J, M, N, SON_LA, SON_LDA, FIRST_ROW, !$OMP& LAST_ROW, FIRST_COL, LAST_COL, LRB, SON_A, II, KK, !$OMP& APOS, IACHK, KK1, JJ2, PROMOTE_COST, allocok, SON_APOS) #endif DO IBIS = 1,IBIS_END C Determining I,J from IBIS IF (SYM.EQ.0) THEN I = (IBIS-1)/NB_INCB+1 J = IBIS - (I-1)*NB_INCB ELSE I = ceiling((1.0D0+sqrt(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 ENDIF I = I+NB_INASM J = J+NB_INASM IF (I.EQ.NB_INASM+1) THEN C first CB block, add NELIM because FIRST_ROW starts at NELIM+1 FIRST_ROW = BEGS_BLR_DYNAMIC(I)-NPIV+NELIM ELSE FIRST_ROW = BEGS_BLR_DYNAMIC(I)-NPIV ENDIF LAST_ROW = BEGS_BLR_DYNAMIC(I+1)-1-NPIV M=LAST_ROW-FIRST_ROW+1 FIRST_COL = BEGS_BLR_DYNAMIC(J)-NPIV LAST_COL = BEGS_BLR_DYNAMIC(J+1)-1-NPIV N = BEGS_BLR_DYNAMIC(J+1)-BEGS_BLR_DYNAMIC(J) SON_APOS = 1_8 SON_LA = M*N SON_LDA = N LRB => CB_LRB(I-NB_INASM,J-NB_INASM) IF (LRB%ISLR.AND.LRB%K.EQ.0) THEN C No need to perform extend-add CALL DEALLOC_LRB(LRB, KEEP8, KEEP(34)) NULLIFY(LRB) CYCLE ENDIF allocate(SON_A(SON_LA),stat=allocok) IF (allocok.GT.0) THEN write(*,*) 'Not enough memory in ZMUMPS_BLR_ASM_NIV1', & ", Memory requested = ", SON_LA CALL MUMPS_ABORT() ENDIF C decompress block IF (LRB%ISLR) THEN CALL zgemm('T', 'T', N, M, LRB%K, ONE, LRB%R(1,1), LRB%K, & LRB%Q(1,1), M, ZERO, SON_A(SON_APOS), SON_LDA) PROMOTE_COST = 2.0D0*M*N*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE IF (I.EQ.J.AND.SYM.NE.0) THEN C Diag block and LDLT, copy only lower half IF (J-NB_INASM.EQ.1.AND.NELIM.GT.0) THEN C The first diagonal block is rectangular !! C with NELIM more cols than rows DO II=1,M DO KK=1,II+NELIM SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ELSE DO II=1,M DO KK=1,II SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ENDIF ELSE DO II=1,M DO KK=1,N SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ENDIF ENDIF C Deallocate block CALL DEALLOC_LRB(LRB, KEEP8, KEEP(34)) NULLIFY(LRB) C extend add in father IF (SYM.NE.0.AND.J-NB_INASM.EQ.1.AND.NELIM.GT.0) THEN C Case of LDLT with NELIM: first-block column is treated C differently as the NELIM are assembled at the end of the C father DO KK = FIRST_ROW, LAST_ROW IACHK = 1_8 + int(KK-FIRST_ROW,8)*int(SON_LDA,8) IF (SON_IW(KK+K1-1).LE.NASS1) THEN C Fully summed row of the father => permute destination in C father, symmetric swap to be done C First NELIM columns APOS = POSEL1 + int(SON_IW(KK+K1-1),8) - 1_8 DO KK1 = FIRST_COL, FIRST_COL+NELIM-1 JJ2 = APOS + int(SON_IW(K1+KK1-1)-1,8)*NFRONT8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO C Remaining columns APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 C DO KK1 = FIRST_COL+NELIM, LAST_COL C In case I=J and first block, one may have C LAST_COL > KK, but only lower triangular part C should be assembled. We use min(LAST_COL,KK) C below index to cover this case. DO KK1 = FIRST_COL+NELIM, min(LAST_COL,KK) JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ELSE APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 DO KK1 = FIRST_COL, min(LAST_COL,KK) JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ENDIF ENDDO ELSE C Case of LDLT without NELIM or LU: everything is simpler DO KK = FIRST_ROW, LAST_ROW APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 IACHK = 1_8 + int(KK-FIRST_ROW,8)*int(SON_LDA,8) IF (I.EQ.J.AND.SYM.NE.0) THEN C LDLT diag block: assemble only lower half DO KK1 = FIRST_COL, KK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ELSE DO KK1 = FIRST_COL, LAST_COL JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ENDIF ENDDO ENDIF C Deallocate SON_A DEALLOCATE(SON_A) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO !$OMP END PARALLEL #endif CALL ZMUMPS_BLR_FREE_CB_LRB(IWHANDLER, C Only CB_LRB structure is left to deallocate & .TRUE., KEEP8, KEEP(34)) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN C Case of FR solve: the BLR structure could not be freed C in ZMUMPS_END_FACTO_SLAVE and should be freed here C Not reachable in case of error: set INFO1 to 0 CALL ZMUMPS_BLR_END_FRONT(IWHANDLER, 0, KEEP8, KEEP(34), & MTK405=KEEP(405)) ENDIF END SUBROUTINE ZMUMPS_BLR_ASM_NIV1 END MODULE ZMUMPS_LR_CORE C -------------------------------------------------------------------- SUBROUTINE ZMUMPS_TRUNCATED_RRQR( M, N, A, LDA, JPVT, TAU, WORK, & LDW, RWORK, TOLEPS, TOL_OPT, RANK, MAXRANK, INFO, & ISLR) C This routine computes a Rank-Revealing QR factorization of a dense C matrix A. The factorization is truncated when the absolute value of C a diagonal coefficient of the R factor becomes smaller than a C prescribed threshold TOLEPS. The resulting partial Q and R factors C provide a rank-k approximation of the input matrix A with accuracy C TOLEPS. C C This routine is obtained by merging the LAPACK C (http://www.netlib.org/lapack/) CGEQP3 and CLAQPS routines and by C applying a minor modification to the outer factorization loop in C order to stop computations as soon as possible when the required C accuracy is reached. C C Copyright (c) 1992-2017 The University of Tennessee and The C University of Tennessee Research Foundation. All rights reserved. C Copyright (c) 2000-2017 The University of California Berkeley. C All rights reserved. C Copyright (c) 2006-2017 The University of Colorado Denver. C All rights reserved. C C Redistribution and use in source and binary forms, with or without C modification, are permitted provided that the following conditions C are met: C C - Redistributions of source code must retain the above copyright C notice, this list of conditions and the following disclaimer. C C - Redistributions in binary form must reproduce the above C copyright notice, this list of conditions and the following C disclaimer listed in this license in the documentation and/or C other materials provided with the distribution. C C - Neither the name of the copyright holders nor the names of its C contributors may be used to endorse or promote products derived from C this software without specific prior written permission. C C The copyright holders provide no reassurances that the source code C provided does not infringe any patent, copyright, or any other C intellectual property rights of third parties. The copyright holders C disclaim any liability to any recipient for claims brought against C recipient by any third party for infringement of that parties C intellectual property rights. C C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. C IMPLICIT NONE C INTEGER :: INFO, LDA, LDW, M, N, RANK, MAXRANK C TOL_OPT controls the tolerance option used C >0 => use 2-norm (||.||_X = ||.||_2) C <0 => use Frobenius-norm (||.||_X = ||.||_F) C Furthermore, depending on abs(TOL_OPT): C 1 => absolute: ||B_{I(k+1:end),J(k+1:end)}||_X <= TOLEPS C 2 => relative to 2-norm of the compressed block: C ||B_{I(k+1:end),J(k+1:end)}||_X <= TOLEPS*||B_{I,J}||_2 C 3 => relative to the max of the 2-norms of the row and column diagonal blocks C ||B_{I(k+1:end),J{k+1:end}}||_X <= TOLEPS*max(||B_{I,I}||_2,||B_{J,J}||_2) C 4 => relative to the sqrt of product of the 2-norms of the row and column diagonal blocks C ||B_{I(k+1:end),J{k+1:end}}||_X <= TOLEPS*sqrt(||B_{I,I}||_2*||B_{J,J}||_2) INTEGER :: TOL_OPT DOUBLE PRECISION :: TOLEPS INTEGER :: JPVT(*) DOUBLE PRECISION :: RWORK(*) COMPLEX(kind=8) :: A(LDA,*), TAU(*) COMPLEX(kind=8) :: WORK(LDW,*) LOGICAL :: ISLR DOUBLE PRECISION :: TOLEPS_EFF, TRUNC_ERR INTEGER, PARAMETER :: INB=1, INBMIN=2 INTEGER :: J, JB, MINMN, NB INTEGER :: OFFSET, ITEMP INTEGER :: LSTICC, PVT, K, RK DOUBLE PRECISION :: TEMP, TEMP2, TOL3Z COMPLEX(kind=8) :: AKK LOGICAL INADMISSIBLE DOUBLE PRECISION, PARAMETER :: RZERO=0.0D+0, RONE=1.0D+0 COMPLEX(kind=8) :: ZERO COMPLEX(kind=8) :: ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) DOUBLE PRECISION :: dlamch INTEGER :: ilaenv, idamax EXTERNAL :: idamax, dlamch EXTERNAL zgeqrf, zunmqr, xerbla EXTERNAL ilaenv EXTERNAL zgemm, zgemv, zlarfg, zswap DOUBLE PRECISION, EXTERNAL :: dznrm2 DOUBLE PRECISION, EXTERNAL :: dnrm2 INFO = 0 ISLR = .FALSE. IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.EQ.0 ) THEN IF( LDW.LT.N ) THEN INFO = -8 END IF END IF IF( INFO.NE.0 ) THEN WRITE(*,999) -INFO RETURN END IF MINMN = MIN(M,N) IF( MINMN.EQ.0 ) THEN RANK = 0 RETURN END IF NB = ilaenv( INB, 'CGEQRF', ' ', M, N, -1, -1 ) SELECT CASE(abs(TOL_OPT)) CASE(1) TOLEPS_EFF = TOLEPS CASE(2) C TOLEPS_EFF will be computed at step K=1 below CASE DEFAULT write(*,*) 'Internal error in ZMUMPS_TRUNCATED_RRQR: TOL_OPT =', & TOL_OPT CALL MUMPS_ABORT() END SELECT TOLEPS_EFF = TOLEPS C C Avoid pointers (and TARGET attribute on RWORK/WORK) C because of implicit interface. An implicit interface C is needed to avoid intermediate array copies C VN1 => RWORK(1:N) C VN2 => RWORK(N+1:2*N) C AUXV => WORK(1:LDW,1:1) C F => WORK(1:LDW,2:NB+1) C LDF = LDW * Initialize partial column norms. The first N elements of work * store the exact column norms. DO J = 1, N C VN1( J ) = dznrm2( M, A( 1, J ), 1 ) RWORK( J ) = dznrm2( M, A( 1, J ), 1 ) C VN2( J ) = VN1( J ) RWORK( N + J ) = RWORK( J ) JPVT(J) = J END DO IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for first step C TRUNC_ERR = dnrm2( N, VN1( 1 ), 1 ) TRUNC_ERR = dnrm2( N, RWORK( 1 ), 1 ) ENDIF OFFSET = 0 TOL3Z = SQRT(dlamch('Epsilon')) DO JB = MIN(NB,MINMN-OFFSET) LSTICC = 0 K = 0 DO IF(K.EQ.JB) EXIT K = K+1 RK = OFFSET+K C PVT = ( RK-1 ) + IDAMAX( N-RK+1, VN1( RK ), 1 ) PVT = ( RK-1 ) + idamax( N-RK+1, RWORK( RK ), 1 ) IF (RK.EQ.1) THEN C IF (abs(TOL_OPT).EQ.2) TOLEPS_EFF = VN1(PVT)*TOLEPS IF (abs(TOL_OPT).EQ.2) TOLEPS_EFF = RWORK(PVT)*TOLEPS ENDIF IF (TOL_OPT.GT.0) THEN C TRUNC_ERR = VN1(PVT) TRUNC_ERR = RWORK(PVT) C ELSE C TRUNC_ERR has been already computed at previous step ENDIF IF(TRUNC_ERR.LT.TOLEPS_EFF) THEN RANK = RK-1 ISLR = .TRUE. RETURN ENDIF INADMISSIBLE = (RK.GT.MAXRANK) IF (INADMISSIBLE) THEN RANK = RK INFO = RK ISLR = .FALSE. RETURN END IF IF( PVT.NE.RK ) THEN CALL zswap( M, A( 1, PVT ), 1, A( 1, RK ), 1 ) c CALL zswap( K-1, F( PVT-OFFSET, 1 ), LDF, c & F( K, 1 ), LDF ) CALL zswap( K-1, WORK( PVT-OFFSET, 2 ), LDW, & WORK( K, 2 ), LDW ) ITEMP = JPVT(PVT) JPVT(PVT) = JPVT(RK) JPVT(RK) = ITEMP C VN1(PVT) = VN1(RK) C VN2(PVT) = VN2(RK) RWORK(PVT) = RWORK(RK) RWORK(N+PVT) = RWORK(N+RK) END IF * Apply previous Householder reflectors to column K: * A(RK:M,RK) := A(RK:M,RK) - A(RK:M,OFFSET+1:RK-1)*F(K,1:K-1)**H. IF( K.GT.1 ) THEN DO J = 1, K-1 C F( K, J ) = CONJG( F( K, J ) ) WORK( K, J+1 ) = CONJG( WORK( K, J+1 ) ) END DO CALL zgemv( 'No transpose', M-RK+1, K-1, -ONE, C & A(RK,OFFSET+1), LDA, F(K,1), LDF, & A(RK,OFFSET+1), LDA, WORK(K,2), LDW, & ONE, A(RK,RK), 1 ) DO J = 1, K - 1 C F( K, J ) = CONJG( F( K, J ) ) WORK( K, J + 1 ) = CONJG( WORK( K, J + 1 ) ) END DO END IF * Generate elementary reflector H(k). IF( RK.LT.M ) THEN CALL zlarfg( M-RK+1, A(RK,RK), A(RK+1,RK), 1, TAU(RK) ) ELSE CALL zlarfg( 1, A(RK,RK), A(RK,RK), 1, TAU(RK) ) END IF AKK = A(RK,RK) A(RK,RK) = ONE * Compute Kth column of F: * F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**H*A(RK:M,K). IF( RK.LT.N ) THEN CALL zgemv( 'Conjugate transpose', M-RK+1, N-RK, TAU(RK), & A(RK,RK+1), LDA, A(RK,RK), 1, ZERO, C & F( K+1, K ), 1 ) & WORK( K+1, K+1 ), 1 ) END IF * Padding F(1:K,K) with zeros. DO J = 1, K C F( J, K ) = ZERO WORK( J, K+1 ) = ZERO END DO * Incremental updating of F: * F(1:N,K) := F(1:N-OFFSET,K) - * tau(RK)*F(1:N,1:K-1)*A(RK:M,OFFSET+1:RK-1)**H*A(RK:M,RK). IF( K.GT.1 ) THEN CALL zgemv( 'Conjugate transpose', M-RK+1, K-1, -TAU(RK), & A(RK,OFFSET+1), LDA, A(RK,RK), 1, ZERO, & WORK(1,1), 1 ) C & AUXV(1,1), 1 ) CALL zgemv( 'No transpose', N-OFFSET, K-1, ONE, & WORK(1,2), LDW, WORK(1,1), 1, ONE, WORK(1,K+1), 1 ) C & F(1,1), LDF, AUXV(1,1), 1, ONE, F(1,K), 1 ) END IF * Update the current row of A: * A(RK,RK+1:N) := A(RK,RK+1:N) - A(RK,OFFSET+1:RK)*F(K+1:N,1:K)**H. IF( RK.LT.N ) THEN CALL zgemm( 'No transpose', 'Conjugate transpose', & 1, N-RK, C & K, -ONE, A( RK, OFFSET+1 ), LDA, F( K+1, 1 ), LDF, & K, -ONE, A( RK, OFFSET+1 ), LDA, WORK( K+1,2 ), LDW, & ONE, A( RK, RK+1 ), LDA ) END IF * Update partial column norms. * IF( RK.LT.MINMN ) THEN DO J = RK + 1, N C IF( VN1( J ).NE.RZERO ) THEN IF( RWORK( J ).NE.RZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * C TEMP = ABS( A( RK, J ) ) / VN1( J ) TEMP = ABS( A( RK, J ) ) / RWORK( J ) TEMP = MAX( RZERO, ( RONE+TEMP )*( RONE-TEMP ) ) C TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 TEMP2 = TEMP*( RWORK( J ) / RWORK( N+J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN C VN2( J ) = dble( LSTICC ) RWORK( N+J ) = dble( LSTICC ) LSTICC = J ELSE C VN1( J ) = VN1( J )*SQRT( TEMP ) RWORK( J ) = RWORK( J )*SQRT( TEMP ) END IF END IF END DO END IF A( RK, RK ) = AKK IF (LSTICC.NE.0) EXIT IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for next step C TRUNC_ERR = dnrm2( N-RK, VN1( RK+1 ), 1 ) TRUNC_ERR = dnrm2( N-RK, RWORK( RK+1 ), 1 ) ENDIF END DO * Apply the block reflector to the rest of the matrix: * A(RK+1:M,RK+1:N) := A(RK+1:M,RK+1:N) - * A(RK+1:M,OFFSET+1:RK)*F(K+1:N-OFFSET,1:K)**H. IF( RK.LT.MIN(N,M) ) THEN CALL zgemm( 'No transpose', 'Conjugate transpose', M-RK, & N-RK, K, -ONE, A(RK+1,OFFSET+1), LDA, C & F(K+1,1), LDF, ONE, A(RK+1,RK+1), LDA ) & WORK(K+1,2), LDW, ONE, A(RK+1,RK+1), LDA ) END IF * Recomputation of difficult columns. DO WHILE( LSTICC.GT.0 ) C ITEMP = NINT( VN2( LSTICC ) ) ITEMP = NINT( RWORK( N + LSTICC ) ) C VN1( LSTICC ) = dznrm2( M-RK, A( RK+1, LSTICC ), 1 ) RWORK( LSTICC ) = dznrm2( M-RK, A( RK+1, LSTICC ), 1 ) * * NOTE: The computation of RWORK( LSTICC ) relies on the fact that * SNRM2 does not fail on vectors with norm below the value of * SQRT(DLAMCH('S')) * C VN2( LSTICC ) = VN1( LSTICC ) RWORK( N + LSTICC ) = RWORK( LSTICC ) LSTICC = ITEMP END DO IF(RK.GE.MINMN) EXIT OFFSET = RK IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for next step C TRUNC_ERR = dnrm2( N-RK, VN1( RK+1 ), 1 ) TRUNC_ERR = dnrm2( N-RK, RWORK( RK+1 ), 1 ) ENDIF END DO RANK = RK ISLR = .NOT.(RK.GT.MAXRANK) RETURN 999 FORMAT ('On entry to ZMUMPS_TRUNCATED_RRQR, parameter number', & I2,' had an illegal value') END SUBROUTINE ZMUMPS_TRUNCATED_RRQR MUMPS_5.8.1/src/zsol_fwd.F0000664000175000017500000001632715042446441015200 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SOL_R(N, A, LA, IW, LIW, WCB, LWCB, & NRHS, & PTRICB, IWCB, LIWCB, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & STEP, & FRERE, DAD, FILS, & NSTK, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, MYROOT, & INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) USE ZMUMPS_STATIC_PTR_M, ONLY : ZMUMPS_SET_STATIC_PTR, & ZMUMPS_GET_TMP_PTR USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_L0OMPFAC_T IMPLICIT NONE INTEGER MTYPE INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER, INTENT(IN) :: N, LIW, LPOOL, LIWCB INTEGER, INTENT(IN) :: SLAVEF, MYLEAF, MYROOT, COMM, MYID INTEGER INFO( 80 ), KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER NRHS COMPLEX(kind=8) A( LA ), WCB( LWCB ) INTEGER(8), intent(in) :: LRHS_ROOT COMPLEX(kind=8) RHS_ROOT( LRHS_ROOT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER STEP( N ), FRERE( KEEP(28) ), FILS( N ), & DAD( KEEP(28) ) INTEGER NSTK(KEEP(28)), IPOOL( LPOOL ) INTEGER PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTRICB( KEEP(28) ) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) INTEGER IW( LIW ), IWCB( LIWCB ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, intent(in) :: POSINRHSINTR_FWD(N), LRHSINTR COMPLEX(kind=8), intent(inout) :: RHSINTR(LRHSINTR,NRHS) LOGICAL, intent(in) :: FROM_PP INTEGER, INTENT( in ) :: LL0_OMP_MAPPING, LL0_OMP_FACTORS INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) TYPE (ZMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY(1) LOGICAL FLAG COMPLEX(kind=8), DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER :: UNDERL0MAP INTEGER NBFIN, MYROOT_LEFT INTEGER POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INODE, IFATH INTEGER III, LEAF LOGICAL BLOQ EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE LOGICAL ERROR_WAS_BROADCASTED DUMMY(1) = 1 KEEP(266)=0 POSIWCB = LIWCB POSWCB = LWCB PLEFTWCB= 1_8 PTRICB = 0 LEAF = MYLEAF + 1 III = 1 NBFIN = SLAVEF MYROOT_LEFT = MYROOT IF ( MYROOT_LEFT .EQ. 0 ) THEN NBFIN = NBFIN - 1 CALL ZMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, & RACINE_SOLVE, SLAVEF, KEEP) IF (NBFIN.EQ.0) GOTO 260 END IF IF ( INFO(1) .LT. 0 ) THEN GOTO 260 ENDIF 50 CONTINUE IF (SLAVEF .EQ. 1) THEN CALL ZMUMPS_GET_INODE_FROM_POOL & ( IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF IF (SLAVEF .EQ. 1) THEN FLAG = .FALSE. ELSE BLOQ = ( ( III .EQ. LEAF ) & ) CALL ZMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) ENDIF IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 IF (.not. FLAG) THEN IF (III .NE. LEAF) THEN CALL ZMUMPS_GET_INODE_FROM_POOL & (IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF ENDIF GOTO 50 60 CONTINUE IF (KEEP(400) .GT. 0 ) THEN UNDERL0MAP = L0_OMP_MAPPING(STEP(INODE)) ELSE UNDERL0MAP = 0 ENDIF IF (UNDERL0MAP .EQ. 0 .OR. KEEP(201).GT.0) THEN CALL ZMUMPS_SET_STATIC_PTR(A) CALL ZMUMPS_GET_TMP_PTR(A_PTR) LA_PTR = LA ELSE A_PTR => L0_OMP_FACTORS(UNDERL0MAP)%A LA_PTR = L0_OMP_FACTORS(UNDERL0MAP)%LA ENDIF CALL ZMUMPS_SOLVE_NODE_FWD( INODE, & huge(INODE), huge(INODE), & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, N, & IPOOL, LPOOL, LEAF, NBFIN, NSTK, & IWCB, LIWCB, WCB, LWCB, A_PTR(1), LA_PTR, & IW, LIW, NRHS, & POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE & , FROM_PP & , ERROR_WAS_BROADCASTED & ) IF ( INFO(1) .LT. 0 ) THEN IF (.NOT. ERROR_WAS_BROADCASTED) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF GOTO 260 ENDIF IFATH = DAD(STEP(INODE)) IF ( IFATH .EQ. 0 ) THEN MYROOT_LEFT = MYROOT_LEFT - 1 IF (MYROOT_LEFT .EQ. 0) THEN NBFIN = NBFIN - 1 IF (SLAVEF .GT. 1) THEN CALL ZMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, & COMM, RACINE_SOLVE, SLAVEF, KEEP) ENDIF END IF ELSE IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IFATH)), KEEP(199)) & .EQ. MYID ) THEN IF ( PTRICB(STEP(INODE)) .EQ. 1 .OR. & PTRICB(STEP(INODE)) .EQ. -1 ) THEN NSTK(STEP(IFATH)) = NSTK(STEP(IFATH)) - 1 IF (NSTK(STEP(IFATH)) .EQ. 0) THEN IPOOL(LEAF) = IFATH LEAF = LEAF + 1 IF (LEAF .GT. LPOOL) THEN WRITE(*,*) & 'Internal error ZMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() ENDIF ENDIF PTRICB(STEP(INODE)) = 0 ENDIF ENDIF ENDIF IF ( NBFIN .EQ. 0 ) GOTO 260 GOTO 50 260 CONTINUE CALL MUMPS_CLEAN_PENDING(INFO(1), KEEP, BUFR, LBUFR,LBUFR_BYTES, & COMM, DUMMY(1), & SLAVEF, .TRUE., .FALSE.) RETURN END SUBROUTINE ZMUMPS_SOL_R MUMPS_5.8.1/src/dfac_process_end_facto_slave.F0000664000175000017500000002743515042446440021201 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE DMUMPS_END_FACTO_SLAVE( & COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, roota, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_LOAD #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif USE DMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER INODE, FPERE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER COMM, MYID INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER N INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP, IFLAG, IERROR INTEGER PERM(N) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER ND( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER FRERE(KEEP(28)) INTEGER INTARR( KEEP8(27) ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER MRS_INODE INTEGER MRS_ISON INTEGER MRS_NSLAVES_PERE INTEGER MRS_NASS_PERE INTEGER MRS_NFRONT_PERE INTEGER MRS_LMAP INTEGER MRS_NFS4FATHER INTEGER, POINTER, DIMENSION(:) :: MRS_SLAVES_PERE, MRS_TROW INTEGER ITYPE2 INTEGER IHDR_REC PARAMETER (ITYPE2=2) INTEGER IOLDPS, NROW, LDA INTEGER NPIV, LCONT, NELIM, NASS, NCOL_TO_SEND, & SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER(8) :: SHIFT_VAL_SON INTEGER(8) :: MEM_GAIN INTEGER(8) :: DYN_SIZE #if ! defined(NO_FDM_MAPROW) TYPE(MAPROW_STRUC_T), POINTER :: MRS #endif INTEGER :: IWHANDLER_SAVE INTEGER :: LRSTATUS LOGICAL :: CB_STORED_IN_BLRSTRUC, COMPRESS_CB IF (KEEP(50).EQ.0) THEN IHDR_REC=6 ELSE IHDR_REC=8 ENDIF IOLDPS = PTRIST(STEP(INODE)) IWHANDLER_SAVE = IW(IOLDPS+XXA) LRSTATUS = IW(IOLDPS+XXLR) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND..NOT.COMPRESS_CB) THEN CALL DMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34)) ENDIF IW(IOLDPS+XXS)=S_ALL IOLDPS = PTRIST(STEP(INODE)) LRSTATUS = IW(IOLDPS+XXLR) IF ( (KEEP(214).EQ.1) & ) THEN CALL DMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP,KEEP8, DKEEP, ITYPE2 & ) IOLDPS = PTRIST(STEP(INODE)) IF (KEEP(38).NE.FPERE) THEN CB_STORED_IN_BLRSTRUC = .FALSE. LRSTATUS = IW(IOLDPS+XXLR) IF ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) THEN CB_STORED_IN_BLRSTRUC = .TRUE. IW(IOLDPS+XXS) = S_NOLNOCB CALL MUMPS_GETI8(MEM_GAIN, IW(IOLDPS+XXR)) LRLUS = LRLUS + MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ELSE IW(IOLDPS+XXS)=S_NOLCBNOCONTIG CALL MUMPS_GETI8( DYN_SIZE, IW(IOLDPS+XXD)) IF (DYN_SIZE .GT.0) THEN ELSE IF (KEEP(216).NE.3) THEN MEM_GAIN=int(IW( IOLDPS + 2 + KEEP(IXSZ) ),8)* & int(IW( IOLDPS + 3 + KEEP(IXSZ) ),8) LRLUS = LRLUS+MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ENDIF ENDIF ENDIF CALL MUMPS_GETI8( DYN_SIZE, IW(IOLDPS+XXD)) IF (DYN_SIZE > 0_8) THEN ELSE IF (KEEP(216).EQ.2) THEN IF (FPERE.NE.KEEP(38)) THEN IF (.NOT. CB_STORED_IN_BLRSTRUC) THEN CALL DMUMPS_MAKECBCONTIG(A,LA,PTRAST(STEP(INODE)), & IW( IOLDPS + 2 + KEEP(IXSZ) ), & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 3 + KEEP(IXSZ) )+ & IW( IOLDPS + KEEP(IXSZ) ), 0, & IW( IOLDPS + XXS ), 0_8 ) IW(IOLDPS+XXS)=S_NOLCBCONTIG ENDIF ENDIF ENDIF ENDIF IF ( KEEP(38).EQ.FPERE) THEN LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV NCOL_TO_SEND = LCONT-NELIM SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NASS SHIFT_VAL_SON = int(NASS,8) LDA = LCONT + NPIV IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOTBAND_INIT) THEN IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_REC_CONTSTATIC ELSE ENDIF CALL DMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTRIST, PTRAST, & root, roota, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, & ROOT_CONT_STATIC, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE.,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS, 0, 0, 0 & ) IF ( IFLAG < 0 ) GOTO 600 IF (NELIM.EQ.0) THEN IF (KEEP(214).EQ.2) THEN CALL DMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, & COMM, KEEP,KEEP8,DKEEP, ITYPE2 & ) ENDIF CALL DMUMPS_FREE_BAND( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP, KEEP8, ITYPE2 & ) ELSE IOLDPS = PTRIST(STEP(INODE)) IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOT2SON_CALLED) THEN CALL DMUMPS_FREE_BAND( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP, KEEP8, ITYPE2 & ) ELSE IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_ROOTBAND_INIT IF (KEEP(214).EQ.1.AND.KEEP(216).NE.3) THEN IW(IOLDPS+XXS)=S_NOLCBNOCONTIG38 CALL DMUMPS_SIZEFREEINREC( IW(IOLDPS), & LIW-IOLDPS+1, & MEM_GAIN, KEEP(IXSZ) ) LRLUS = LRLUS + MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) IF (KEEP(216).EQ.2) THEN CALL DMUMPS_MAKECBCONTIG(A,LA,PTRAST(STEP(INODE)), & IW( IOLDPS + 2 + KEEP(IXSZ) ), & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 3 + KEEP(IXSZ) )+ & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 4 + KEEP(IXSZ) ) - & IW( IOLDPS + 3 + KEEP(IXSZ) ), & IW( IOLDPS + XXS ),0_8) IW(IOLDPS+XXS)=S_NOLCBCONTIG38 ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE #if ! defined(NO_FDM_MAPROW) IOLDPS = PTRIST(STEP(INODE)) IF (FPERE .NE. KEEP(38)) THEN IF (MUMPS_FMRD_IS_MAPROW_STORED( IW(IOLDPS+XXA) )) THEN CALL MUMPS_FMRD_RETRIEVE_MAPROW( IW(IOLDPS+XXA), MRS ) IF (FPERE .NE. MRS%INODE) THEN WRITE(*,*) " Internal error 1 in DMUMPS_END_FACTO_SLAVE", & INODE, MRS%INODE, FPERE CALL MUMPS_ABORT() ENDIF MRS_INODE = MRS%INODE MRS_ISON = MRS%ISON MRS_NSLAVES_PERE = MRS%NSLAVES_PERE MRS_NASS_PERE = MRS%NASS_PERE MRS_NFRONT_PERE = MRS%NFRONT_PERE MRS_LMAP = MRS%LMAP MRS_NFS4FATHER = MRS%NFS4FATHER MRS_SLAVES_PERE => MRS%SLAVES_PERE MRS_TROW => MRS%TROW CALL DMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & MRS_INODE, MRS_ISON, & MRS_NSLAVES_PERE, MRS_SLAVES_PERE(1), & MRS_NFRONT_PERE, MRS_NASS_PERE, MRS_NFS4FATHER, & MRS_LMAP, MRS_TROW(1), & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) CALL MUMPS_FMRD_FREE_MAPROW_STRUC( IWHANDLER_SAVE ) ENDIF ENDIF #endif RETURN END SUBROUTINE DMUMPS_END_FACTO_SLAVE MUMPS_5.8.1/src/zfac_mem_dynamic.F0000664000175000017500000005177015042446441016637 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_DYNAMIC_MEMORY_M CONTAINS SUBROUTINE ZMUMPS_DM_ALLOC_S_WK(S, MAXS, allocok, & KEEP430, KEEP35 ) IMPLICIT NONE COMPLEX(kind=8), DIMENSION(:), POINTER :: S INTEGER(8) :: MAXS INTEGER, INTENT(IN) :: KEEP35 INTEGER, INTENT(IN) :: KEEP430 INTEGER, INTENT(OUT) :: allocok INTEGER(8) :: TMP_ADDRESS8 IF (KEEP430.EQ.0) THEN ALLOCATE(S(MAXS), stat=allocok) ELSE IF (KEEP430.EQ.1) THEN CALL MUMPS_MALLOC_C( TMP_ADDRESS8, max(MAXS,1_8) * KEEP35 ) ELSE WRITE(*,*) "KEEP430: wrong value", KEEP430 CALL MUMPS_ABORT() ENDIF IF (TMP_ADDRESS8 .EQ. 0_8) THEN allocok = 1 ELSE allocok = 0 CALL ZMUMPS_DM_SET_PTR( TMP_ADDRESS8, max(MAXS,1_8), S ) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_DM_ALLOC_S_WK SUBROUTINE ZMUMPS_DM_FREE_S_WK( S, KEEP430 ) IMPLICIT NONE COMPLEX(kind=8), DIMENSION(:), POINTER :: S INTEGER, INTENT(IN) :: KEEP430 IF ( KEEP430 .EQ. 0 ) THEN DEALLOCATE(S) ELSE IF ( KEEP430 .EQ. 1 ) THEN CALL MUMPS_FREE_C(S(1)) #if defined(USE_XKBLAS) #endif ELSE WRITE(*,*) "KEEP430: wrong value", KEEP430 CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE ZMUMPS_DM_FREE_S_WK SUBROUTINE ZMUMPS_DM_SET_DYNPTR( CB_STATE, A, LA, & PAMASTER_OR_PTRAST, IXXD, & IXXR, SON_A, IACHK, RECSIZE ) IMPLICIT NONE INTEGER, INTENT(IN) :: CB_STATE INTEGER, INTENT(IN) :: IXXR(2), IXXD(2) INTEGER(8), INTENT(IN) :: LA, PAMASTER_OR_PTRAST COMPLEX(kind=8), INTENT(IN), TARGET :: A( LA ) #if defined(MUMPS_NOF2003) COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A #else COMPLEX(kind=8), POINTER, DIMENSION(:), INTENT(OUT) :: SON_A #endif INTEGER(8), INTENT(OUT) :: IACHK, RECSIZE IF ( ZMUMPS_DM_IS_DYNAMIC( IXXD ) ) THEN CALL MUMPS_GETI8(RECSIZE, IXXD) CALL ZMUMPS_DM_SET_PTR( PAMASTER_OR_PTRAST, RECSIZE, SON_A ) IACHK = 1_8 ELSE CALL MUMPS_GETI8(RECSIZE, IXXR) IACHK = PAMASTER_OR_PTRAST SON_A => A ENDIF RETURN END SUBROUTINE ZMUMPS_DM_SET_DYNPTR SUBROUTINE ZMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP28, & KEEP199, INODE, CB_STATE, IXXD, & STEP, DAD, PROCNODE_STEPS, & RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IMPLICIT NONE INTEGER, INTENT(in) :: KEEP28, N, SLAVEF, MYID, INODE, CB_STATE INTEGER, INTENT(in) :: KEEP199 INTEGER, INTENT(in) :: IXXD(2) INTEGER, INTENT(in) :: DAD(KEEP28) INTEGER, INTENT(in) :: STEP(N) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP28) LOGICAL, INTENT(out) :: IS_PAMASTER, IS_PTRAST INTEGER(8), INTENT(in) :: PAMASTER(KEEP28), PTRAST(KEEP28) INTEGER(8), INTENT(in) :: RCURRENT LOGICAL :: DAD_TYPE2_NOT_ON_MYID INTEGER :: NODETYPE, DADTYPE INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE IS_PAMASTER = .FALSE. IS_PTRAST = .FALSE. IF (CB_STATE .EQ. S_FREE) THEN RETURN ENDIF NODETYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), KEEP199) DADTYPE=-99999 DAD_TYPE2_NOT_ON_MYID = .FALSE. IF (DAD(STEP(INODE)) .NE. 0) THEN DADTYPE= MUMPS_TYPENODE( & PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP199) IF (DADTYPE .EQ. 2 .AND. & MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP199).NE.MYID & ) THEN DAD_TYPE2_NOT_ON_MYID = .TRUE. ENDIF ENDIF IF (ZMUMPS_DM_ISBAND(CB_STATE)) THEN IS_PTRAST=.TRUE. ELSE IF (NODETYPE.EQ.1 & .AND. MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP199).EQ.MYID & .AND. DAD_TYPE2_NOT_ON_MYID) & THEN IS_PTRAST=.TRUE. ELSE IS_PAMASTER=.TRUE. ENDIF RETURN END SUBROUTINE ZMUMPS_DM_PAMASTERORPTRAST LOGICAL FUNCTION ZMUMPS_DM_ISBAND(XXSTATE) INTEGER, INTENT(IN) :: XXSTATE INCLUDE 'mumps_headers.h' SELECT CASE (XXSTATE) CASE(S_NOTFREE, S_CB1COMP); ZMUMPS_DM_ISBAND = .FALSE. CASE(S_ACTIVE, S_ALL, & S_NOLCBCONTIG, S_NOLCBNOCONTIG, S_NOLCLEANED, & S_NOLCBNOCONTIG38, S_NOLCBCONTIG38, S_NOLCLEANED38, & S_NOLNOCB, S_NOLNOCBCLEANED); ZMUMPS_DM_ISBAND = .TRUE. CASE(S_FREE); ZMUMPS_DM_ISBAND = .FALSE. CASE DEFAULT; WRITE(*,*) "Wrong state during ZMUMPS_DM_ISBAND", XXSTATE CALL MUMPS_ABORT() END SELECT RETURN END FUNCTION ZMUMPS_DM_ISBAND LOGICAL FUNCTION ZMUMPS_DM_IS_DYNAMIC(IXXD) INTEGER :: IXXD(2) INTEGER(8) :: DYN_SIZE CALL MUMPS_GETI8( DYN_SIZE, IXXD ) ZMUMPS_DM_IS_DYNAMIC = DYN_SIZE > 0_8 RETURN END FUNCTION ZMUMPS_DM_IS_DYNAMIC SUBROUTINE ZMUMPS_DM_FAC_ALLOC_ALLOWED & (MEM_COUNT_TO_ALLOCATE, KEEP8, & IFLAG, IERROR) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_COUNT_TO_ALLOCATE INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR IF ( KEEP8(73) + MEM_COUNT_TO_ALLOCATE & .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & KEEP8(73) + MEM_COUNT_TO_ALLOCATE -KEEP8(75), & IERROR ) ENDIF RETURN END SUBROUTINE ZMUMPS_DM_FAC_ALLOC_ALLOWED SUBROUTINE ZMUMPS_DM_CBSTATIC2DYNAMIC( STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) !$ USE OMP_LIB USE MUMPS_LOAD, ONLY : MUMPS_LOAD_MEM_UPDATE IMPLICIT NONE INTEGER, INTENT(in) :: STRATEGY INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS COMPLEX(kind=8), INTENT(in) :: A( LA ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER, INTENT(inout) :: IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER :: ICURRENT, INODE, TYPEINODE, CB_STATE INTEGER(8) :: RCURRENT, RCURRENT_SIZE, SIZEHOLE INTEGER(8) :: KEEP8TMPCOPY LOGICAL :: MOVE2DYNAMIC LOGICAL :: SSARBRDAD INTEGER(8) :: TMP_ADDRESS, ITMP8 INTEGER(8) :: I8 COMPLEX(kind=8), DIMENSION(:), POINTER :: DYNAMIC_CB LOGICAL :: IS_PAMASTER, IS_PTRAST INTEGER :: allocok !$ INTEGER(8) :: CHUNK8 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP LOGICAL :: IFLAG_M13_OCCURED, IFLAG_M19_OCCURED INTEGER(8) :: MIN_SIZE_M13, MIN_SIZE_M19 INTEGER, EXTERNAL :: MUMPS_TYPENODE IF ( STRATEGY .EQ. 0 ) THEN IF (LRLUS.LT.SIZER_NEEDED) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) ENDIF RETURN ENDIF IFLAG_M13_OCCURED = .FALSE. MIN_SIZE_M13 = huge(MIN_SIZE_M13) IFLAG_M19_OCCURED = .FALSE. MIN_SIZE_M19 = huge(MIN_SIZE_M19) !$ NOMP = OMP_GET_MAX_THREADS() ICURRENT = IWPOSCB + 1 RCURRENT = IPTRLU + 1 IF (STRATEGY.EQ.1 .AND. SIZER_NEEDED.LE.LRLUS) GOTO 500 IF (( KEEP8(73) + SIZER_NEEDED-LRLUS).GT. & KEEP8(75)) THEN IFLAG = -19 CALL MUMPS_SET_IERROR & (KEEP8(73) + SIZER_NEEDED-LRLUS-KEEP8(75), IERROR) GOTO 500 ENDIF DO WHILE (ICURRENT .NE. LIW-KEEP(IXSZ)+1) INODE = IW(ICURRENT+XXN) CB_STATE = IW(ICURRENT+XXS) CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT+XXR)) CALL ZMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP(28), & KEEP(199), INODE, CB_STATE, & IW(ICURRENT+XXD:ICURRENT+XXD+1), & STEP, DAD, PROCNODE_STEPS, & RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF ( CB_STATE .NE. S_FREE .AND. & .NOT. ZMUMPS_DM_IS_DYNAMIC(IW(ICURRENT+XXD)) ) THEN TYPEINODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IF (STRATEGY .EQ. -1) THEN MOVE2DYNAMIC = .FALSE. MOVE2DYNAMIC = MOVE2DYNAMIC .OR. & CB_STATE .EQ. S_NOLCBCONTIG .OR. & CB_STATE .EQ. S_NOLCBNOCONTIG .OR. & CB_STATE .EQ. S_NOLCLEANED .OR. & CB_STATE .EQ. S_ALL .OR. & CB_STATE .EQ. S_ACTIVE ELSE IF (STRATEGY .EQ. 2 .OR. STRATEGY .EQ. 3) THEN MOVE2DYNAMIC = .TRUE. MOVE2DYNAMIC = MOVE2DYNAMIC .AND. (TYPEINODE.NE.3) ELSE IF (STRATEGY .EQ. 1) THEN MOVE2DYNAMIC = .FALSE. IF (LRLUS.GT.SIZER_NEEDED) GOTO 500 IF (TYPEINODE.EQ.3) GOTO 100 MOVE2DYNAMIC = MOVE2DYNAMIC.OR..TRUE. ELSE WRITE(*,*) "Internal error in ZMUMPS_DM_CBSTATIC2DYNAMIC", & MOVE2DYNAMIC CALL MUMPS_ABORT() ENDIF MOVE2DYNAMIC = MOVE2DYNAMIC .AND. (RCURRENT_SIZE .NE. 0_8) MOVE2DYNAMIC = MOVE2DYNAMIC .AND. & .NOT. ((ICURRENT.EQ.IWPOSCB + 1).AND.(SKIP_TOP_STACK)) IF (STRATEGY .NE. 3) THEN IF ( KEEP(405) .EQ. 1 ) THEN !$OMP ATOMIC READ KEEP8TMPCOPY = KEEP8(73) !$OMP END ATOMIC ELSE KEEP8TMPCOPY = KEEP8(73) ENDIF IF ( RCURRENT_SIZE + KEEP8TMPCOPY .GT. KEEP8(75) ) THEN IFLAG_M19_OCCURED= .TRUE. MIN_SIZE_M19 = min( MIN_SIZE_M19, & RCURRENT_SIZE+KEEP8(73)-KEEP8(75) ) MOVE2DYNAMIC = .FALSE. ENDIF ENDIF IF ( MOVE2DYNAMIC ) THEN #if defined(MUMPS_ALLOC_FROM_C) || defined(_CRAYFTN) CALL MUMPS_MALLOC_C( TMP_ADDRESS, & RCURRENT_SIZE * KEEP(35) ) IF (TMP_ADDRESS .EQ. 0_8) THEN allocok=1 ELSE allocok=0 ENDIF #else ALLOCATE(DYNAMIC_CB(RCURRENT_SIZE), stat=allocok) #endif IF (allocok .GT. 0) THEN IF ( (STRATEGY .NE. 1).OR. & (SIZER_NEEDED-LRLUS).GE.RCURRENT_SIZE) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) GOTO 500 ENDIF IFLAG_M13_OCCURED = .TRUE. MIN_SIZE_M13 = min(MIN_SIZE_M13, RCURRENT_SIZE) GOTO 100 ENDIF SIZEHOLE=0_8 IF (KEEP(216).NE.3) THEN CALL ZMUMPS_SIZEFREEINREC( IW(ICURRENT), & LIW-ICURRENT+1, SIZEHOLE, KEEP(IXSZ)) ENDIF CALL MUMPS_STOREI8(RCURRENT_SIZE,IW(ICURRENT+XXD)) #if defined(MUMPS_ALLOC_FROM_C) || defined(_CRAYFTN) CALL ZMUMPS_DM_SET_PTR( TMP_ADDRESS, RCURRENT_SIZE, & DYNAMIC_CB ) #else CALL MUMPS_ADDR_C(DYNAMIC_CB(1), TMP_ADDRESS) #endif IF (IS_PTRAST) THEN PTRAST(STEP(INODE)) = TMP_ADDRESS ELSE IF (IS_PAMASTER) THEN PAMASTER(STEP(INODE)) = TMP_ADDRESS ELSE WRITE(*,*) & "Internal error 3 in ZMUMPS_DM_CBSTATIC2DYNAMIC", & RCURRENT, PTRAST(STEP(INODE)), PAMASTER(STEP(INODE)) CALL MUMPS_ABORT() ENDIF ITMP8 = (RCURRENT_SIZE-SIZEHOLE) LRLUS = LRLUS + ITMP8 IF (KEEP(405).EQ.1) THEN IF (SIZEHOLE .NE. 0_8) THEN !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + SIZEHOLE KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max( KEEP8(68), KEEP8TMPCOPY ) !$OMP END ATOMIC ENDIF ELSE KEEP8(69) = KEEP8(69) + SIZEHOLE KEEP8(68) = max( KEEP8(68), KEEP8(69) ) ENDIF CALL MUMPS_SET_SSARBR_DAD(SSARBRDAD, INODE, & DAD, N, KEEP(28), & STEP, PROCNODE_STEPS, KEEP(199)) CALL MUMPS_LOAD_MEM_UPDATE( SSARBRDAD, .FALSE., & LA - LRLUS, 0_8, -(RCURRENT_SIZE-SIZEHOLE), & KEEP, KEEP8, LRLUS) IF (ICURRENT .EQ. IWPOSCB+1) THEN IPTRLU = IPTRLU + RCURRENT_SIZE LRLU = LRLU + RCURRENT_SIZE CALL MUMPS_STOREI8(0_8, IW(ICURRENT+XXR)) ENDIF IF (STRATEGY .NE. 3) THEN CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS ( & RCURRENT_SIZE, KEEP(405).EQ.1, KEEP8, & IFLAG, IERROR, .FALSE., .FALSE.) IF (IFLAG.LT.0) GOTO 500 ENDIF !$ CHUNK8 = max( int(KEEP(361),8), !$ & (RCURRENT_SIZE+NOMP-1) / NOMP) !$ OMP_FLAG = ( (RCURRENT_SIZE > int(KEEP(361),8)) !$ & .AND.(NOMP.GT.1) !$ & ) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (OMP_FLAG) DO I8=1_8, RCURRENT_SIZE DYNAMIC_CB(I8) = A(RCURRENT+I8-1_8) ENDDO !$OMP END PARALLEL DO ENDIF ENDIF 100 CONTINUE RCURRENT = RCURRENT + RCURRENT_SIZE ICURRENT = ICURRENT + IW(ICURRENT+XXI) END DO IF (LRLUS.LT.SIZER_NEEDED) THEN IF (IFLAG_M19_OCCURED) THEN IFLAG = -19 CALL MUMPS_SET_IERROR(MIN_SIZE_M19, IERROR) ELSE IF (IFLAG_M13_OCCURED) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(MIN_SIZE_M13, IERROR) ELSE IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_DM_CBSTATIC2DYNAMIC SUBROUTINE ZMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(in) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) LOGICAL, INTENT(in) :: ATOMIC_UPDATES INCLUDE 'mumps_headers.h' INTEGER :: ICURRENT, INODE INTEGER :: CB_STATE INTEGER(8) :: DYN_SIZE, TMP_ADDRESS INTEGER(8), PARAMETER :: RDUMMY = -987654 LOGICAL :: IS_PAMASTER, IS_PTRAST COMPLEX(kind=8), DIMENSION(:), POINTER :: TMP_PTR ICURRENT = IWPOSCB + 1 IF (KEEP8(73) .NE. 0_8) THEN DO WHILE (ICURRENT .LT. LIW-KEEP(IXSZ)+1) INODE = IW(ICURRENT+XXN) CB_STATE = IW(ICURRENT+XXS) IF (CB_STATE.NE.S_FREE) THEN CALL MUMPS_GETI8( DYN_SIZE, IW(ICURRENT+XXD) ) IF (DYN_SIZE .GT. 0_8) THEN CALL ZMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP(28), & KEEP(199), INODE, CB_STATE, IW(ICURRENT+XXD), & STEP, DAD, PROCNODE_STEPS, & RDUMMY, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF (IS_PAMASTER) THEN TMP_ADDRESS = PAMASTER(STEP(INODE)) ELSE IF (IS_PTRAST) THEN TMP_ADDRESS = PTRAST(STEP(INODE)) ELSE WRITE(*,*) "Internal error 1 in ZMUMPS_DM_FREEALLDYNAMICCB" & , IS_PTRAST, IS_PAMASTER ENDIF CALL ZMUMPS_DM_SET_PTR(TMP_ADDRESS, DYN_SIZE, TMP_PTR) CALL ZMUMPS_DM_FREE_BLOCK( IW(ICURRENT+XXG), & TMP_PTR, DYN_SIZE, & ATOMIC_UPDATES, KEEP8 ) CALL MUMPS_STOREI8(0_8, IW(ICURRENT+XXD)) ENDIF ENDIF ICURRENT = ICURRENT + IW(ICURRENT+XXI) ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_DM_FREEALLDYNAMICCB SUBROUTINE ZMUMPS_DM_SET_PTR(ADDRESS, SIZFR8, CBPTR) USE ZMUMPS_STATIC_PTR_M, ONLY : ZMUMPS_GET_TMP_PTR IMPLICIT NONE INTEGER(8), INTENT(IN) :: ADDRESS, SIZFR8 #if defined(MUMPS_NOF2003) COMPLEX(kind=8), DIMENSION(:), POINTER :: CBPTR #else COMPLEX(kind=8), DIMENSION(:), POINTER, INTENT(out) :: CBPTR #endif !$OMP CRITICAL(STATIC_PTR_ACCESS) CALL ZMUMPS_SET_TMP_PTR_C( ADDRESS, SIZFR8 ) CALL ZMUMPS_GET_TMP_PTR( CBPTR ) !$OMP END CRITICAL(STATIC_PTR_ACCESS) RETURN END SUBROUTINE ZMUMPS_DM_SET_PTR SUBROUTINE ZMUMPS_DM_FREE_BLOCK( XXG_STATUS, DYNPTR, SIZFR8, & ATOMIC_UPDATES, KEEP8 ) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER :: XXG_STATUS COMPLEX(kind=8), POINTER, DIMENSION(:) :: DYNPTR INTEGER(8) :: SIZFR8 LOGICAL, INTENT(IN) :: ATOMIC_UPDATES INTEGER(8) :: KEEP8(150) INTEGER IDUMMY #if defined(MUMPS_ALLOC_FROM_C) || defined(_CRAYFTN) CALL MUMPS_FREE_C(DYNPTR(1)) #else DEALLOCATE(DYNPTR) #endif NULLIFY(DYNPTR) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS ( & -SIZFR8, ATOMIC_UPDATES, KEEP8, IDUMMY, IDUMMY, & .TRUE., .FALSE.) RETURN END SUBROUTINE ZMUMPS_DM_FREE_BLOCK END MODULE ZMUMPS_DYNAMIC_MEMORY_M SUBROUTINE ZMUMPS_DM_FREEALLDYNAMICCB_I( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_FREEALLDYNAMICCB IMPLICIT NONE INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(in) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) LOGICAL, INTENT(in) :: ATOMIC_UPDATES CALL ZMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) RETURN END SUBROUTINE ZMUMPS_DM_FREEALLDYNAMICCB_I SUBROUTINE ZMUMPS_DM_CBSTATIC2DYNAMIC_I( & STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_CBSTATIC2DYNAMIC IMPLICIT NONE INTEGER, INTENT(in) :: STRATEGY INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS COMPLEX(kind=8), INTENT(in) :: A( LA ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER, INTENT(inout) :: IFLAG, IERROR CALL ZMUMPS_DM_CBSTATIC2DYNAMIC( STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) RETURN END SUBROUTINE ZMUMPS_DM_CBSTATIC2DYNAMIC_I MUMPS_5.8.1/src/dfac_process_message.F0000664000175000017500000010014615042446440017500 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE DMUMPS_TRAITER_MESSAGE( & COMM_LOAD, ASS_IRECV, & MSGSOU, MSGTAG, MSGLEN, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER KEEP(500), ICNTL( 60 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION A( LA ) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER COMM_LOAD, ASS_IRECV INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER INIV2, ISHIFT, IBEG INTEGER ISHIFT_HDR INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL FLAG INTEGER LP INTEGER TMP( 2 ) INTEGER NBRECU, POSITION, INODE, ISON, IROOT INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE, & LMAP, FPERE, NELIM, & HDMAPLIG,NFS4FATHER, & TOT_ROOT_SIZE, TOT_CONT_TO_RECV DOUBLE PRECISION FLOP1 CHARACTER(LEN=35) :: SUBNAME INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) LP = ICNTL(1) SUBNAME="??????" CALL MUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF ( MSGTAG .EQ. RACINE ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NBRECU, & 1, MPI_INTEGER, COMM, IERR) NBRECU = BUFR( 1 ) NBFIN = NBFIN - NBRECU ELSEIF ( MSGTAG .EQ. NOEUD ) THEN CALL DMUMPS_PROCESS_NODE( MYID, KEEP, KEEP8, DKEEP, & BUFR, LBUFR, LBUFR_BYTES, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) SUBNAME="DMUMPS_PROCESS_NODE" IF ( IFLAG .LT. 0 ) GO TO 500 IF ( FLAG ) THEN CALL DMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( FPERE, N, & PROCNODE_STEPS,KEEP(199), & ND, FILS, FRERE, STEP, PIMASTER, & KEEP(28), KEEP(50), KEEP(253), FLOP1, & IW, LIW, KEEP(IXSZ) ) IF (FPERE.NE.KEEP(20)) & CALL MUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ELSEIF ( MSGTAG .EQ. END_NIV2_LDLT ) THEN INODE = BUFR( 1 ) CALL DMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, -INODE ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ELSEIF ( MSGTAG .EQ. TERREUR ) THEN IFLAG = -001 IERROR = MSGSOU GOTO 100 ELSEIF ( MSGTAG .EQ. MAITRE_DESC_BANDE ) THEN CALL DMUMPS_PROCESS_DESC_BANDE( MYID,BUFR, LBUFR, & LBUFR_BYTES, IWPOS, & IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, #if ! defined (NO_FDM_DESCBAND) & -1, #endif & IFLAG, IERROR ) SUBNAME="DMUMPS_PROCESS_DESC_BANDE" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. MAITRE2 ) THEN CALL DMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, SLAVEF, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & KEEP, KEEP8, DKEEP, ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) SUBNAME="DMUMPS_PROCESS_MASTER2" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. BLOC_FACTO .OR. & MSGTAG .EQ. BLOC_FACTO_RELAY ) THEN CALL DMUMPS_PROCESS_BLOCFACTO( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM , IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM_SLAVE ) THEN CALL DMUMPS_PROCESS_BLFAC_SLAVE( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM ) THEN CALL DMUMPS_PROCESS_SYM_BLOCFACTO( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. CONTRIB_TYPE2 ) THEN CALL DMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, & MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, & N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, PERM, COMP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, NBFIN, MYID, COMM, & ICNTL,KEEP,KEEP8,DKEEP,IFLAG, IERROR, IPOOL, LPOOL, LEAF, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSEIF ( MSGTAG .EQ. MAPLIG ) THEN HDMAPLIG = 7 INODE = BUFR( 1 ) ISON = BUFR( 2 ) NSLAVES_PERE = BUFR( 3 ) NFRONT_PERE = BUFR( 4 ) NASS_PERE = BUFR( 5 ) LMAP = BUFR( 6 ) NFS4FATHER = BUFR( 7 ) IF ( NSLAVES_PERE.NE.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ISHIFT = NSLAVES_PERE+1 TAB_POS_IN_PERE(1:NSLAVES_PERE+1, INIV2) = & BUFR(HDMAPLIG+1:HDMAPLIG+1+NSLAVES_PERE) TAB_POS_IN_PERE(SLAVEF+2, INIV2) = NSLAVES_PERE ELSE ISHIFT = 0 ENDIF IBEG = HDMAPLIG+1+ISHIFT CALL DMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES_PERE, & BUFR(IBEG), & NFRONT_PERE, NASS_PERE, NFS4FATHER,LMAP, & BUFR(IBEG+NSLAVES_PERE), & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, roota, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_CONT_STATIC ) THEN CALL DMUMPS_PROCESS_CONTRIB_TYPE3( & BUFR, LBUFR, LBUFR_BYTES, & root, roota, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF, OPASSW) SUBNAME="DMUMPS_PROCESS_CONTRIB_TYPE3" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_NON_ELIM_CB ) THEN IROOT = KEEP( 38 ) MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), & KEEP(199) ) IF ( PTLUST( STEP(IROOT)) .EQ. 0 ) THEN KEEP(266)=KEEP(266)-1 CALL MPI_RECV( TMP, 2 * KEEP(34), MPI_PACKED, & MSGSOU, ROOT_2SLAVE, & COMM, STATUS, IERR ) CALL DMUMPS_PROCESS_ROOT2SLAVE( TMP( 1 ), TMP( 2 ), & root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP,ND ) SUBNAME="DMUMPS_PROCESS_ROOT2SLAVE" IF ( IFLAG .LT. 0 ) GOTO 500 END IF CALL DMUMPS_PROCESS_CONTRIB_TYPE3( & BUFR, LBUFR, LBUFR_BYTES, & root, roota, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF, OPASSW ) SUBNAME="DMUMPS_PROCESS_CONTRIB_TYPE3" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_2SON ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) CALL DMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & ISON, NELIM, root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 IF ( MYID.NE.MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) ) THEN IF (KEEP(50).EQ.0) THEN ISHIFT_HDR = 6 ELSE ISHIFT_HDR = 8 ENDIF IF (IW(PTRIST(STEP(ISON))+ISHIFT_HDR+KEEP(IXSZ)).EQ. & S_REC_CONTSTATIC) THEN IW(PTRIST(STEP(ISON))+ISHIFT_HDR+KEEP(IXSZ)) = & S_ROOT2SON_CALLED ELSE CALL DMUMPS_FREE_BAND( N, ISON, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)),KEEP(199)) & ) ENDIF ENDIF ELSE IF ( MSGTAG .EQ. ROOT_2SLAVE ) THEN TOT_ROOT_SIZE = BUFR( 1 ) TOT_CONT_TO_RECV = BUFR( 2 ) CALL DMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, & TOT_CONT_TO_RECV, root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP, ND ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_NELIM_INDICES ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) NSLAVES_PERE = BUFR( 3 ) CALL DMUMPS_PROCESS_RTNELIND( root, roota, & ISON, NELIM, NSLAVES_PERE, BUFR(4), BUFR(4+BUFR(2)), & BUFR(4+2*BUFR(2)), & & PROCNODE_STEPS, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND) SUBNAME="DMUMPS_PROCESS_RTNELIND" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. UPDATE_LOAD ) THEN WRITE(*,*) "Internal error 3 in DMUMPS_TRAITER_MESSAGE" CALL MUMPS_ABORT() ELSE IF ( MSGTAG .EQ. TAG_DUMMY ) THEN ELSE IF ( LP > 0 ) & WRITE(LP,*) MYID, &': Internal error, routine DMUMPS_TRAITER_MESSAGE.',MSGTAG IFLAG = -100 IERROR= MSGTAG GOTO 500 ENDIF 100 CONTINUE RETURN 500 CONTINUE IF ( ICNTL(1) .GT. 0 .AND. ICNTL(4).GE.1 ) THEN LP=ICNTL(1) IF (IFLAG.EQ.-9) THEN WRITE(LP,*) 'FAILURE, WORKSPACE TOO SMALL DURING ',SUBNAME ENDIF IF (IFLAG.EQ.-8) THEN WRITE(LP,*) 'FAILURE IN INTEGER ALLOCATION DURING ',SUBNAME ENDIF IF (IFLAG.EQ.-13) THEN WRITE(LP,*) 'FAILURE IN DYNAMIC ALLOCATION DURING ',SUBNAME ENDIF ENDIF CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE DMUMPS_TRAITER_MESSAGE RECURSIVE SUBROUTINE DMUMPS_RECV_AND_TREAT( & COMM_LOAD, ASS_IRECV, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT , & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, LA, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST( KEEP(28) ) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER MSGSOU, MSGTAG, MSGLEN, IERR MSGSOU = STATUS( MPI_SOURCE ) MSGTAG = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN IFLAG = -20 IERROR = MSGLEN WRITE(*,*) ' RECEPTION BUF TOO SMALL, Msgtag/len=', & MSGTAG,MSGLEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF KEEP(266)=KEEP(266)-1 CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, & COMM, STATUS, IERR ) CALL DMUMPS_TRAITER_MESSAGE( & COMM_LOAD, ASS_IRECV, & MSGSOU, MSGTAG, MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS ) RETURN END SUBROUTINE DMUMPS_RECV_AND_TREAT RECURSIVE SUBROUTINE DMUMPS_TRY_RECVTREAT( & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, & MESSAGE_RECEIVED, MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED, LRGROUPS ) USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL, INTENT (IN) :: BLOCKING LOGICAL, INTENT (IN) :: SET_IRECV LOGICAL, INTENT (INOUT) :: MESSAGE_RECEIVED INTEGER, INTENT (IN) :: MSGSOU, MSGTAG INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST(KEEP(28)) INTEGER STEP(N), & PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) DOUBLE PRECISION DBLARR( KEEP8(26) ) LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED LOGICAL FLAG, RIGHT_MESS, FLAGbis INTEGER LP, MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC INTEGER IERR INTEGER :: STATUS_BIS(MPI_STATUS_SIZE) INTEGER, SAVE :: RECURS = 0 CALL MUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF ( .NOT. STACK_RIGHT_AUTHORIZED ) THEN RETURN ENDIF RECURS = RECURS + 1 LP = ICNTL(1) IF (ICNTL(4).LT.1) LP=-1 IF ( MESSAGE_RECEIVED ) THEN MSGSOU_LOC = MPI_ANY_SOURCE MSGTAG_LOC = MPI_ANY_TAG GOTO 250 ENDIF IF ( ASS_IRECV .NE. MPI_REQUEST_NULL) THEN RIGHT_MESS = .TRUE. IF (BLOCKING) THEN CALL MPI_WAIT(ASS_IRECV, & STATUS, IERR) FLAG = .TRUE. IF ( ( (MSGSOU.NE.MPI_ANY_SOURCE) .OR. & (MSGTAG.NE.MPI_ANY_TAG) ) ) THEN IF ( MSGSOU.NE.MPI_ANY_SOURCE) THEN RIGHT_MESS = MSGSOU.EQ.STATUS(MPI_SOURCE) ENDIF IF ( MSGTAG.NE.MPI_ANY_TAG) THEN RIGHT_MESS = & ( (MSGTAG.EQ.STATUS(MPI_TAG)).AND.RIGHT_MESS ) ENDIF IF (.NOT.RIGHT_MESS) THEN CALL MPI_PROBE(MSGSOU,MSGTAG, & COMM, STATUS_BIS, IERR) ENDIF ENDIF ELSE CALL MPI_TEST(ASS_IRECV, & FLAG, STATUS, IERR) ENDIF IF (IERR.LT.0) THEN IFLAG = -20 IF (LP.GT.0) & write(LP,*) ' Error return from MPI_TEST ', & IFLAG, ' in DMUMPS_TRY_RECVTREAT' CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF IF ( FLAG ) THEN KEEP(266)=KEEP(266)-1 MESSAGE_RECEIVED = .TRUE. MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN_LOC, IERR ) IF (.NOT.RIGHT_MESS) RECURS = RECURS + 10 CALL DMUMPS_TRAITER_MESSAGE( COMM_LOAD, ASS_IRECV, & MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (.NOT.RIGHT_MESS) RECURS = RECURS - 10 IF ( IFLAG .LT. 0 ) RETURN IF (.NOT.RIGHT_MESS) THEN IF (ASS_IRECV .NE. MPI_REQUEST_NULL) THEN CALL MUMPS_ABORT() ENDIF CALL MPI_IPROBE(MSGSOU,MSGTAG, & COMM, FLAGbis, STATUS, IERR) IF (FLAGbis) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL DMUMPS_RECV_AND_TREAT( COMM_LOAD, ASS_IRECV, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL,LEAF,NBFIN,MYID,SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & KEEP,KEEP8, DKEEP,ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF ENDIF ENDIF ELSE IF (BLOCKING) THEN CALL MPI_PROBE(MSGSOU,MSGTAG, & COMM, STATUS, IERR) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, FLAG, STATUS, IERR) ENDIF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) MESSAGE_RECEIVED = .TRUE. CALL DMUMPS_RECV_AND_TREAT( COMM_LOAD, ASS_IRECV, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF ENDIF 250 CONTINUE RECURS = RECURS - 1 IF ( NBFIN .EQ. 0 ) RETURN IF ( RECURS .GT. 3 ) RETURN IF ( KEEP(36).EQ.1 .AND. SET_IRECV .AND. & (ASS_IRECV.EQ.MPI_REQUEST_NULL) .AND. & MESSAGE_RECEIVED ) THEN CALL MPI_IRECV ( BUFR(1), & LBUFR_BYTES, MPI_PACKED, MPI_ANY_SOURCE, & MPI_ANY_TAG, COMM, & ASS_IRECV, IERR ) ENDIF RETURN END SUBROUTINE DMUMPS_TRY_RECVTREAT SUBROUTINE DMUMPS_CANCEL_IRECV( INFO1, & KEEP, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & COMM, & MYID, SLAVEF) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER LBUFR, LBUFR_BYTES INTEGER ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER COMM INTEGER MYID, SLAVEF, INFO1, DEST INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL NO_ACTIVE_IRECV INTEGER IERR, DUMMY INTRINSIC mod IF (SLAVEF .EQ. 1) RETURN IF (ASS_IRECV.EQ.MPI_REQUEST_NULL) THEN NO_ACTIVE_IRECV=.TRUE. ELSE CALL MPI_TEST(ASS_IRECV, NO_ACTIVE_IRECV, & STATUS, IERR) IF (NO_ACTIVE_IRECV) THEN KEEP(266) = KEEP(266) - 1 ENDIF ENDIF CALL MPI_BARRIER(COMM,IERR) DUMMY = 1 DEST = mod(MYID+1, SLAVEF) CALL MUMPS_BUF_SEND_1INT & (DUMMY, DEST, TAG_DUMMY, COMM, KEEP, IERR) IF (NO_ACTIVE_IRECV) THEN CALL MPI_RECV( BUFR, LBUFR, & MPI_INTEGER, MPI_ANY_SOURCE, & TAG_DUMMY, COMM, STATUS, IERR ) ELSE CALL MPI_WAIT(ASS_IRECV, & STATUS, IERR) ENDIF KEEP(266)=KEEP(266)-1 RETURN END SUBROUTINE DMUMPS_CANCEL_IRECV MUMPS_5.8.1/src/dend_driver.F0000664000175000017500000006131015042446441015626 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_END_DRIVER( id, idintr ) USE DMUMPS_STRUC_DEF, ONLY: DMUMPS_STRUC USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_INTR_STRUC IMPLICIT NONE C C Purpose: C ======= C C Terminate a MUMPS instance. Free all internal data structure and C suppress OOC files on disk, if any. C C Argument: C ======== C TYPE( DMUMPS_STRUC ) :: id TYPE( DMUMPS_INTR_STRUC ) :: idintr C C Local declarations C ================== INTEGER IERR INTEGER, PARAMETER :: MASTER = 0 C C Executable statements C ===================== C C First, free all MUMPS internal data except communicators created C during a call to MUMPS wit JOB=-1 CALL DMUMPS_FREE_DATA_ANAFACSOL( id, idintr ) C C Allocated during JOB=-1: IF ( id%MYID .NE. MASTER .OR. id%KEEP(46) .ne. 0 ) THEN C Note that on some very old platforms, COMM_NODES would have been C freed inside BLACS_GRIDEXIT, which may cause problems C in the call to MPI_COMM_FREE. CALL MPI_COMM_FREE( id%COMM_NODES, IERR ) C Free communicator related to load messages. CALL MPI_COMM_FREE( id%COMM_LOAD, IERR ) END IF CALL MUMPS_DESTROY_ARCH_NODE_COMM( id%KEEP(411), id%KEEP(410), & id%KEEP(413) ) C Nullifying id%SCHUR_CINTERFACE here is not necessary, C it is freed systematically each time we exit DMUMPS_DRIVER C and reset each time we enter MUMPS through its C interface. NULLIFY(id%SCHUR_CINTERFACE) C RETURN END SUBROUTINE DMUMPS_END_DRIVER C SUBROUTINE DMUMPS_END_ROOT(roota) USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE(DMUMPS_ROOT_STRUC) :: roota IF (associated(roota%RHS_CNTR_MASTER_ROOT)) THEN DEALLOCATE(roota%RHS_CNTR_MASTER_ROOT) NULLIFY(roota%RHS_CNTR_MASTER_ROOT) ENDIF IF (associated(roota%RHS_ROOT))THEN DEALLOCATE(roota%RHS_ROOT) NULLIFY(roota%RHS_ROOT) ENDIF CALL DMUMPS_RR_FREE_POINTERS(roota) RETURN END SUBROUTINE DMUMPS_END_ROOT C SUBROUTINE DMUMPS_FREE_DATA_ANAFACSOL(id, idintr) USE DMUMPS_STRUC_DEF USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_INTR_STRUC IMPLICIT NONE C C Purpose: C ======= C Free all MUMPS internal data, except communicators built during C a JOB=-1 call. Called by DMUMPS_END_DRIVER and DMUMPS_ANA_DRIVER. C Calls DMUMPS_FREE_DATA_FACTO, which frees most of the data allocated C during factorization and solve, except: C - scaling arrays, because they are sometimes allocated at analysis C - STEP2NODE, which can be reused when analysis does not change C Therefore, scaling arrays and STEP2NODE are freed here. C C Arguments C ========= TYPE( DMUMPS_STRUC ) :: id TYPE( DMUMPS_INTR_STRUC ) :: idintr C Local declarations C ================== LOGICAL I_AM_SLAVE INTEGER, PARAMETER :: MASTER = 0 C C Executable statements C --------------------- C I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) C C First, free data from factoriation and solve: CALL DMUMPS_FREE_DATA_FACTO(id,idintr) C ------------------------------------- C Right-hand-side and solutions are C always user data, we do not free them C ------------------------------------- IF (associated(id%MEM_DIST)) THEN DEALLOCATE(id%MEM_DIST) NULLIFY(id%MEM_DIST) ENDIF C --------------------------------- C Allocated by DMUMPS, Used by user. C DMUMPS deallocates. User should C use them before DMUMPS_END_DRIVER or C copy. C --------------------------------- IF (associated(id%MAPPING)) THEN DEALLOCATE(id%MAPPING) NULLIFY(id%MAPPING) END IF C ------------------------------------- C Always deallocate scaling arrays C if they are associated, except C when provided by the user (on master) C ------------------------------------- IF ( id%KEEP(52) .NE. -1 .or. id%MYID .ne. MASTER ) THEN IF (associated(id%COLSCA)) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ENDIF IF (associated(id%ROWSCA)) THEN DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF END IF C Begin PRUN_NODES C Info for pruning tree IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF C END PRUN_NODES c --------------------- C Allocated during analysis: IF (associated(id%NE_STEPS)) THEN DEALLOCATE(id%NE_STEPS) NULLIFY(id%NE_STEPS) ENDIF C Allocated during analysis: IF (associated(id%ND_STEPS)) THEN DEALLOCATE(id%ND_STEPS) NULLIFY(id%ND_STEPS) ENDIF C Allocated during analysis: IF (associated(id%FRERE_STEPS)) THEN DEALLOCATE(id%FRERE_STEPS) NULLIFY(id%FRERE_STEPS) ENDIF C Allocated during analysis: IF (associated(id%DAD_STEPS)) THEN DEALLOCATE(id%DAD_STEPS) NULLIFY(id%DAD_STEPS) ENDIF C Allocated during analysis: IF (associated(id%SYM_PERM)) THEN DEALLOCATE(id%SYM_PERM) NULLIFY(id%SYM_PERM) ENDIF IF (associated(id%STEP)) THEN DEALLOCATE(id%STEP) NULLIFY(id%STEP) ENDIF IF (associated(id%LRGROUPS)) THEN DEALLOCATE(id%LRGROUPS) NULLIFY(id%LRGROUPS) ENDIF IF (associated(id%FILS)) THEN DEALLOCATE(id%FILS) NULLIFY(id%FILS) ENDIF IF (associated(id%UNS_PERM)) THEN DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF CC Allocated during analysis: IF (associated(id%FRTPTR)) THEN DEALLOCATE(id%FRTPTR) NULLIFY(id%FRTPTR) ENDIF C Allocated during analysis: IF (associated(id%FRTELT)) THEN DEALLOCATE(id%FRTELT) NULLIFY(id%FRTELT) ENDIF C Allocated during analysis: IF (associated(id%NA)) THEN DEALLOCATE(id%NA) NULLIFY(id%NA) ENDIF C Allocated during analysis: IF (associated(id%PROCNODE_STEPS)) THEN DEALLOCATE(id%PROCNODE_STEPS) NULLIFY(id%PROCNODE_STEPS) ENDIF IF (associated(id%ELTPROC)) THEN DEALLOCATE(id%ELTPROC) NULLIFY(id%ELTPROC) ENDIF C Allocated at analysis: IF (associated(id%CANDIDATES)) THEN DEALLOCATE(id%CANDIDATES) NULLIFY(id%CANDIDATES) ENDIF C Allocated at analysis: IF (associated(id%I_AM_CAND)) THEN DEALLOCATE(id%I_AM_CAND) NULLIFY(id%I_AM_CAND) ENDIF C Allocated at analysis: IF (associated(id%ISTEP_TO_INIV2)) THEN DEALLOCATE(id%ISTEP_TO_INIV2) NULLIFY(id%ISTEP_TO_INIV2) ENDIF C Node partitionning (only allocated on slaves) IF (I_AM_SLAVE) THEN C Allocated at analysis: IF (associated(id%TAB_POS_IN_PERE)) THEN DEALLOCATE(id%TAB_POS_IN_PERE) NULLIFY(id%TAB_POS_IN_PERE) ENDIF ENDIF IF (I_AM_SLAVE) THEN C Allocated at analysis: IF (associated(id%FUTURE_NIV2)) THEN DEALLOCATE(id%FUTURE_NIV2) NULLIFY(id%FUTURE_NIV2) ENDIF ENDIF C Allocated at analysis: IF(associated(id%DEPTH_FIRST))THEN DEALLOCATE(id%DEPTH_FIRST) NULLIFY(id%DEPTH_FIRST) ENDIF C Allocated at analysis: IF(associated(id%DEPTH_FIRST_SEQ))THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) NULLIFY(id%DEPTH_FIRST_SEQ) ENDIF C Allocated at analysis: IF(associated(id%SBTR_ID))THEN DEALLOCATE(id%SBTR_ID) NULLIFY(id%SBTR_ID) ENDIF C Allocated and initialized at analysis: IF(associated(id%SCHED_DEP))THEN DEALLOCATE(id%SCHED_DEP) NULLIFY(id%SCHED_DEP) ENDIF C Allocated and initialized at analysis: IF(associated(id%SCHED_SBTR))THEN DEALLOCATE(id%SCHED_SBTR) NULLIFY(id%SCHED_SBTR) ENDIF C Allocated and initialized at analysis: IF(associated(id%SCHED_GRP))THEN DEALLOCATE(id%SCHED_GRP) NULLIFY(id%SCHED_GRP) ENDIF C Allocated and initialized at analysis: IF(associated(id%CROIX_MANU))THEN DEALLOCATE(id%CROIX_MANU) NULLIFY(id%CROIX_MANU) ENDIF C Allocated during analysis: IF (associated(id%PTRAR)) THEN DEALLOCATE(id%PTRAR) NULLIFY(id%PTRAR) ENDIF C Allocated at analysis: IF (associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) NULLIFY(id%MEM_SUBTREE) ENDIF C Allocated at analysis: IF (associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) NULLIFY(id%MY_ROOT_SBTR) ENDIF C Allocated at analysis: IF (associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) NULLIFY(id%MY_FIRST_LEAF) ENDIF C Allocated at analysis: IF (associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) NULLIFY(id%MY_NB_LEAF) ENDIF C Allocated at analysis: IF (associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) NULLIFY(id%COST_TRAV) ENDIF C Allocated at analysis: IF (associated(id%CB_SON_SIZE)) THEN DEALLOCATE(id%CB_SON_SIZE) NULLIFY(id%CB_SON_SIZE) ENDIF C Allocated at analysis: IF (associated(id%SUP_PROC)) THEN DEALLOCATE(id%SUP_PROC) NULLIFY(id%SUP_PROC) ENDIF ! IF(id%KEEP(486).NE.0) THEN C Allocated at analysis: IF (associated(id%LRGROUPS)) THEN DEALLOCATE(id%LRGROUPS) NULLIFY(id%LRGROUPS) ENDIF ! ENDIF C C free data concerned when redoing cheap analysis CALL DMUMPS_FREE_DATA_REDO_ANA( id ) C C gridinit performed at analysis: #if ! defined(NOSCALAPACK) IF (idintr%root%gridinit_done) THEN IF ( id%KEEP(38).NE.0 .and. idintr%root%yes ) THEN CALL blacs_gridexit( idintr%root%CNTXT_BLACS ) idintr%root%gridinit_done = .FALSE. END IF END IF #endif RETURN END SUBROUTINE DMUMPS_FREE_DATA_ANAFACSOL SUBROUTINE DMUMPS_FREE_DATA_REDO_ANA ( id ) USE DMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C Free all MUMPS internal data concerned C when redoing a cheap analysis : C - data related to MPI2KOMP allocated during analysis C - data related to L0OMP allocated during analysis C - data related to building arrowheads because C of EARLYT3ROOTINS that might change when of C L0-thread (KEEP(400) C Arguments C ========= TYPE( DMUMPS_STRUC ) :: id C C Executable statements C --------------------- CCN#if defined(MPI_TO_K_OMP) C Allocated at analysis: IF (associated(id%MTKO_PROCS_MAP)) THEN DEALLOCATE(id%MTKO_PROCS_MAP) NULLIFY(id%MTKO_PROCS_MAP) ENDIF C Allocated at analysis: IF (associated(id%IPOOL_B_L0_OMP)) THEN DEALLOCATE(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_B_L0_OMP) END IF IF (associated(id%IPOOL_A_L0_OMP)) THEN DEALLOCATE(id%IPOOL_A_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) END IF IF (associated(id%PHYS_L0_OMP)) THEN DEALLOCATE(id%PHYS_L0_OMP) NULLIFY(id%PHYS_L0_OMP) END IF IF (associated(id%VIRT_L0_OMP)) THEN DEALLOCATE(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP) END IF IF (associated(id%VIRT_L0_OMP_MAPPING)) THEN DEALLOCATE(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%VIRT_L0_OMP_MAPPING) END IF IF (associated(id%PERM_L0_OMP)) THEN DEALLOCATE(id%PERM_L0_OMP) NULLIFY(id%PERM_L0_OMP) END IF IF (associated(id%PTR_LEAFS_L0_OMP)) THEN DEALLOCATE(id%PTR_LEAFS_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) END IF C Allocated at analysis: IF (associated(id%I4_L0_OMP)) THEN DEALLOCATE(id%I4_L0_OMP) NULLIFY(id%I4_L0_OMP) END IF C Allocated at analysis: IF (associated(id%I8_L0_OMP)) THEN DEALLOCATE(id%I8_L0_OMP) NULLIFY(id%I8_L0_OMP) END IF C ================================================= C BEGIN Pointers to original matrix C allocated during analysis C in format ready for assembly during factorization C (arrowheads if assembled format) C Allocated during analysis: C id%PTRAR is allocated in ana_driver and C should not be deallocated here (it does not C change in sze) IF (associated(id%PTR8ARR)) THEN DEALLOCATE(id%PTR8ARR) NULLIFY(id%PTR8ARR) ENDIF C Allocated during analysis: IF (associated(id%NINCOLARR)) THEN DEALLOCATE(id%NINCOLARR) NULLIFY(id%NINCOLARR) ENDIF C Allocated during analysis: IF (associated(id%NINROWARR)) THEN DEALLOCATE(id%NINROWARR) NULLIFY(id%NINROWARR) ENDIF C Allocated during analysis: IF (associated(id%PTRDEBARR)) THEN DEALLOCATE(id%PTRDEBARR) NULLIFY(id%PTRDEBARR) ENDIF C ================================================= RETURN END SUBROUTINE DMUMPS_FREE_DATA_REDO_ANA SUBROUTINE DMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8, K34) USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_END USE DMUMPS_LR_DATA_M, only : DMUMPS_BLR_STRUC_TO_MOD, & DMUMPS_BLR_END_MODULE IMPLICIT NONE C C Purpose: C ======= C C Free data from modules kept from one phase to the other C and referenced through the main MUMPS structure, id. C C Both id%FDM_F_ENCODING and id%BLRARRAY_ENCODING C are concerned. C C C C Arguments: C ========= C # if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) INTEGER, intent(in) :: K34 C IF (associated(id_FDM_F_ENCODING)) THEN C Allow access to FDM_F data for BLR_END_MODULE CALL MUMPS_FDM_STRUC_TO_MOD('F', id_FDM_F_ENCODING) IF (associated(id_BLRARRAY_ENCODING)) THEN C Pass id_BLRARRAY_ENCODING control to module C and terminate BLR module of current instance CALL DMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) CALL DMUMPS_BLR_END_MODULE(0, KEEP8, K34, & LRSOLVE_ACT_OPT=.TRUE.) ENDIF C --------------------------------------- C FDM data structures are still allocated C in the module and should be freed C --------------------------------------- CALL MUMPS_FDM_END('F') ENDIF RETURN END SUBROUTINE DMUMPS_FREE_ID_DATA_MODULES C C ----------------------------------------------------------------- C SUBROUTINE DMUMPS_FREE_DATA_FACTO(id,idintr) C C Purpose: C ------- C C DMUMPS_FREE_DATA_FACTO frees data that was allocated during C factorization and that can be useful for the solve. Afterwards, C data from analysis is kept so that a new factorization phase C is possible. C C Module depencies C ---------------- USE DMUMPS_STRUC_DEF, ONLY: DMUMPS_STRUC USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_INTR_STRUC USE DMUMPS_FACSOL_L0OMP_M, ONLY : DMUMPS_FREE_L0_OMP_FACTORS USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_FREE_S_WK USE MUMPS_BUF_COMMON, ONLY : & MUMPS_BUF_DEALL_CB, & MUMPS_BUF_DEALL_SMALL_BUF IMPLICIT NONE C C Argument: C -------- C C id is the main MUMPS structure, giving with idintr access C to all internal objects allocated by the package. C TYPE( DMUMPS_STRUC) :: id TYPE( DMUMPS_INTR_STRUC ) :: idintr C C Local declarations C ------------------ INTEGER :: IERR LOGICAL :: I_AM_SLAVE INTEGER, PARAMETER :: MASTER = 0 C C Interface blocks C ---------------- INTERFACE C (explicit needed because of pointer arguments) SUBROUTINE DMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8, K34) # if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) INTEGER, intent(in) :: K34 END SUBROUTINE DMUMPS_FREE_ID_DATA_MODULES END INTERFACE C I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) C C Free OOC-related data C --------------------- C (this includes suppression of OOC files) IF (id%KEEP(201).GT.0 .AND. I_AM_SLAVE) THEN CALL DMUMPS_CLEAN_OOC_DATA(id,IERR) IF (IERR < 0) THEN id%INFO(1) = -90 id%INFO(2) = 0 ENDIF END IF CALL MUMPS_PROPINFO(id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID) IF (associated(id%PTLUST_S)) THEN DEALLOCATE(id%PTLUST_S) NULLIFY(id%PTLUST_S) END IF IF (associated(id%PTRFAC)) THEN DEALLOCATE(id%PTRFAC) NULLIFY(id%PTRFAC) END IF IF (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) ENDIF IF (associated(id%PIVNUL_LIST)) THEN DEALLOCATE(id%PIVNUL_LIST) NULLIFY(id%PIVNUL_LIST) ENDIF IF (associated(id%ROWSCA_loc)) THEN DEALLOCATE(id%ROWSCA_loc) NULLIFY(id%ROWSCA_loc) ENDIF IF (id%KEEP(50) .EQ. 0) THEN IF (associated(id%COLSCA_loc)) THEN DEALLOCATE(id%COLSCA_loc) ENDIF ENDIF NULLIFY(id%COLSCA_loc) C IPIV is used both for ScaLAPACK and RR C Keep it outside DMUMPS_RR_FREE_POINTERS IF (associated(idintr%root%IPIV)) THEN DEALLOCATE(idintr%root%IPIV) NULLIFY(idintr%root%IPIV) ENDIF CALL DMUMPS_END_ROOT(idintr%roota) IF (associated(id%SINGULAR_VALUES)) THEN DEALLOCATE(id%SINGULAR_VALUES) NULLIFY(id%SINGULAR_VALUES) ENDIF C Free module data from factorization: CALL DMUMPS_FREE_ID_DATA_MODULES(id%FDM_F_ENCODING, ! done & id%BLRARRAY_ENCODING, id%KEEP8(1), id%KEEP(34)) C --------------------------- C Deallocate main workarray S C --------------------------- IF (id%KEEP8(24).EQ.0_8) THEN C -- deallocate only when not provided/allocated by the user IF (associated(id%S)) THEN CALL DMUMPS_DM_FREE_S_WK(id%S, id%KEEP(430)) ENDIF C Reset KEEP(430)=0 since S is free C KEEP(430) will be redefined during facto id%KEEP(430) = 0 C Update allocated size of S: id%KEEP8(23)=0_8 ENDIF NULLIFY(id%S) IF (I_AM_SLAVE) THEN C ------------------------ C Deallocate buffer for C contrib-blocks (facto/ C solve). Note that this C will cancel all possible C pending requests. C ------------------------ CALL MUMPS_BUF_DEALL_CB( IERR ) C Deallocate buffer for integers (facto/solve) CALL MUMPS_BUF_DEALL_SMALL_BUF( IERR ) END IF C IF (associated(id%L0_OMP_MAPPING)) THEN DEALLOCATE(id%L0_OMP_MAPPING) NULLIFY(id%L0_OMP_MAPPING) END IF IF (associated(idintr%L0_OMP_FACTORS)) THEN CALL DMUMPS_FREE_L0_OMP_FACTORS(idintr%L0_OMP_FACTORS) END IF C C Data allocated during solve C --------------------------- C C (or for some of it, factorization -- forward during factorization) IF (associated(id%RHSINTR)) THEN DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25)=0_8 ENDIF IF (associated(id%GLOB2LOC_RHS)) THEN DEALLOCATE(id%GLOB2LOC_RHS) NULLIFY(id%GLOB2LOC_RHS) ENDIF IF (id%GLOB2LOC_SOL_ALLOC) THEN DEALLOCATE(id%GLOB2LOC_SOL) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF C Allocated during solve: C (even in case of fwd in facto) IF (associated(id%IPTR_WORKING)) THEN DEALLOCATE(id%IPTR_WORKING) NULLIFY(id%IPTR_WORKING) END IF IF (associated(id%WORKING)) THEN DEALLOCATE(id%WORKING) NULLIFY(id%WORKING) END IF RETURN END SUBROUTINE DMUMPS_FREE_DATA_FACTO SUBROUTINE DMUMPS_FREE_DATA_RHSINTR(id) C C Purpose: C ------- C Free RHSINTR related data that might C have been generated after a forward only step (ICNTL(26)=1) C Module depencies C ---------------- USE DMUMPS_STRUC_DEF IMPLICIT NONE C C Argument: C -------- C C id is the main MUMPS structure, giving with idintr access C to all internal objects allocated by the package. C TYPE( DMUMPS_STRUC) :: id C IF (associated(id%RHSINTR)) THEN DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25)=0_8 id%LD_RHSINTR = 0 ENDIF IF (associated(id%GLOB2LOC_RHS)) THEN DEALLOCATE(id%GLOB2LOC_RHS) NULLIFY(id%GLOB2LOC_RHS) ENDIF IF (id%GLOB2LOC_SOL_ALLOC) THEN DEALLOCATE(id%GLOB2LOC_SOL) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF RETURN END SUBROUTINE DMUMPS_FREE_DATA_RHSINTR SUBROUTINE DMUMPS_CLEAN_OOC_DATA(id,IERR) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_STRUC IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id INTEGER IERR IERR=0 CALL DMUMPS_OOC_CLEAN_FILES(id,IERR) IF(associated(id%OOC_TOTAL_NB_NODES))THEN DEALLOCATE(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_TOTAL_NB_NODES) ENDIF IF(associated(id%OOC_INODE_SEQUENCE))THEN DEALLOCATE(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_INODE_SEQUENCE) ENDIF IF(associated(id%OOC_SIZE_OF_BLOCK))THEN DEALLOCATE(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_SIZE_OF_BLOCK) ENDIF IF(associated(id%OOC_VADDR))THEN DEALLOCATE(id%OOC_VADDR) NULLIFY(id%OOC_VADDR) ENDIF RETURN END SUBROUTINE DMUMPS_CLEAN_OOC_DATA SUBROUTINE DMUMPS_OOC_CLEAN_FILES(id,IERR) USE DMUMPS_STRUC_DEF USE MUMPS_OOC_COMMON, ONLY : ERR_STR_OOC, & DIM_ERR_STR_OOC, & FILENAMELENGTH IMPLICIT NONE EXTERNAL MUMPS_OOC_REMOVE_FILE_C TYPE(DMUMPS_STRUC) :: id INTEGER IERR INTEGER I,J,I1,K CHARACTER(len=1):: TMP_NAME(FILENAMELENGTH) C Note that Fortran initializes IERR to 0. C The C layer modifies it in case of error. IERR=0 K=1 C WHEN SAVE/RESTORE IS ON, OOC FILES ASSOCIATED TO A SAVED INSTANCE C ARE NOT REMOVED IF(.NOT. id%ASSOCIATED_OOC_FILES) THEN IF(associated(id%OOC_FILE_NAMES).AND. & associated(id%OOC_FILE_NAME_LENGTH))THEN DO I1=1,id%OOC_NB_FILE_TYPE DO I=1,id%OOC_NB_FILES(I1) DO J=1,id%OOC_FILE_NAME_LENGTH(K) TMP_NAME(J)=id%OOC_FILE_NAMES(K,J) ENDDO C Note that termination character '0' is included CALL MUMPS_OOC_REMOVE_FILE_C(IERR, TMP_NAME(1)) IF(IERR.LT.0)THEN IF (id%ICNTL(1).GT.0 .AND. id%ICNTL(4).GE.1)THEN WRITE(id%ICNTL(1),*) id%MYID,': ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF ENDIF K=K+1 ENDDO ENDDO ENDIF ENDIF IF(associated(id%OOC_FILE_NAMES))THEN DEALLOCATE(id%OOC_FILE_NAMES) NULLIFY(id%OOC_FILE_NAMES) ENDIF IF(associated(id%OOC_FILE_NAME_LENGTH))THEN DEALLOCATE(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAME_LENGTH) ENDIF IF(associated(id%OOC_NB_FILES))THEN DEALLOCATE(id%OOC_NB_FILES) NULLIFY(id%OOC_NB_FILES) ENDIF RETURN END SUBROUTINE DMUMPS_OOC_CLEAN_FILES MUMPS_5.8.1/src/cfac_process_band.F0000664000175000017500000003221615042446440016761 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_PROCESS_DESC_BANDE( MYID, BUFR, LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP,KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, #if ! defined(NO_FDM_DESCBAND) & IWHANDLER_IN, #endif & IFLAG, IERROR ) USE MUMPS_LOAD USE CMUMPS_LR_DATA_M, ONLY: CMUMPS_BLR_INIT_FRONT, & CMUMPS_BLR_SAVE_NFS4FATHER #if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M #endif IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB, N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), & ITLOC( N + KEEP(253) ) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER :: ISTEP_TO_INIV2(KEEP(71)) #if ! defined(NO_FDM_DESCBAND) INTEGER IWHANDLER_IN #endif INTEGER COMP, IFLAG, IERROR INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES INTEGER NSLAVES_HDR, NFRONT INTEGER LREQ INTEGER :: IBUFR INTEGER(8) :: LREQCB #if ! defined(NO_FDM_DESCBAND) INTEGER :: IWHANDLER_LOC #endif DOUBLE PRECISION FLOP1 INCLUDE 'mumps_headers.h' #if ! defined(NO_FDM_DESCBAND) INTEGER :: INFO_TMP(2) #else #endif INTEGER :: LRSTATUS INTEGER :: ESTIM_NFS4FATHER_ATSON LOGICAL :: LR_ACTIVATED, COMPRESS_CB COMPLEX, POINTER, DIMENSION(:) :: DYNAMIC_CB INTEGER(8) :: TMP_ADDRESS INTEGER :: allocok INODE = BUFR( 2 ) NBPROCFILS = BUFR( 3 ) NROW = BUFR( 4 ) NCOL = BUFR( 5 ) NASS = BUFR( 6 ) NFRONT = BUFR( 7 ) NSLAVES_HDR = BUFR( 8 ) NSLAVES = BUFR( 9 ) LRSTATUS = BUFR(10 ) ESTIM_NFS4FATHER_ATSON = BUFR(11) IBUFR = 12 #if ! defined(NO_FDM_DESCBAND) IWHANDLER_LOC = IWHANDLER_IN IF ((IWHANDLER_IN .LE. 0) .AND. & (INODE .NE. INODE_WAITED_FOR)) THEN INFO_TMP=0 CALL MUMPS_FDBD_SAVE_DESCBAND(INODE, BUFR(1), BUFR, & IWHANDLER_LOC, INFO_TMP) IF (INFO_TMP(1) < 0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) RETURN ENDIF GOTO 555 ENDIF #endif IF ( KEEP(50) .eq. 0 ) THEN FLOP1 = dble( NASS * NROW ) + & dble(NROW*NASS)*dble(2*NCOL-NASS-1) ELSE FLOP1 = dble( NASS ) * dble( NROW ) & * dble( 2 * NCOL - NROW - NASS + 1) END IF CALL MUMPS_LOAD_UPDATE(1,.TRUE.,FLOP1, KEEP,KEEP8) IF ( KEEP(50) .eq. 0 ) THEN NSLAVES = NSLAVES_HDR + XTRA_SLAVES_UNSYM ELSE NSLAVES = NSLAVES_HDR + XTRA_SLAVES_SYM END IF LREQ = NROW + NCOL + 6 + NSLAVES + KEEP(IXSZ) LREQCB = int(NCOL,8) * int(NROW,8) IF ( LREQCB .GT. LRLUS .AND. KEEP(101) .EQ. 0 .AND. & KEEP8(73) + LREQCB .LE. KEEP8(75) ) THEN CALL CMUMPS_ALLOC_CB(.FALSE., 0_8, .FALSE.,.TRUE., & MYID,N, KEEP, KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, & LREQ, 0_8, & INODE, S_ACTIVE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN #if defined(MUMPS_ALLOC_FROM_C) || defined(_CRAYFTN) CALL MUMPS_MALLOC_C( TMP_ADDRESS, & LREQCB * int(KEEP(35),8) ) IF (TMP_ADDRESS .EQ. 0_8) THEN allocok=1 ELSE allocok=0 ENDIF #else ALLOCATE(DYNAMIC_CB(LREQCB), stat=allocok) #endif IF (allocok .GT. 0) THEN CALL CMUMPS_FREE_BLOCK_CB_STATIC( .FALSE., MYID, N, & IWPOSCB + 1, IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP, KEEP8, .FALSE. ) ELSE CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( LREQCB, & KEEP(405).EQ.1, & KEEP8, IFLAG, IERROR, & .TRUE., & .FALSE. ) #if ! defined(MUMPS_ALLOC_FROM_C) && ! defined(_CRAYFTN) CALL MUMPS_ADDR_C( DYNAMIC_CB(1), TMP_ADDRESS ) #endif CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXD)) PTRIST(STEP(INODE)) = IWPOSCB + 1 PTRAST(STEP(INODE)) = TMP_ADDRESS ENDIF ENDIF IF ( PTRIST(STEP(INODE)) .EQ. 0 ) THEN CALL CMUMPS_ALLOC_CB(.FALSE., 0_8, .FALSE.,.TRUE., & MYID,N, KEEP, KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, & LREQ, LREQCB, INODE, S_ACTIVE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PTRIST(STEP(INODE)) = IWPOSCB + 1 PTRAST(STEP(INODE)) = IPTRLU + 1_8 ENDIF # if ! defined(NO_FDM_DESCBAND) 555 CONTINUE # endif # if ! defined(NO_FDM_DESCBAND) IF ((IWHANDLER_IN .LE. 0) .AND. & (INODE .NE. INODE_WAITED_FOR)) THEN RETURN ENDIF IW(IWPOSCB+1+XXA) = IWHANDLER_LOC # endif IW(IWPOSCB+1+XXF) = -9999 IW( IWPOSCB + 1+KEEP(IXSZ) ) = NCOL IW( IWPOSCB + 2+KEEP(IXSZ) ) = - NASS IW( IWPOSCB + 3+KEEP(IXSZ) ) = NROW IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 5+KEEP(IXSZ) ) = NASS IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES IW( IWPOSCB + 7+KEEP(IXSZ)+NSLAVES : & IWPOSCB + 6+KEEP(IXSZ)+NSLAVES + NROW + NCOL ) &= BUFR( IBUFR + NSLAVES_HDR : & IBUFR + NSLAVES_HDR + NROW + NCOL - 1 ) IF ( KEEP(50) .eq. 0 ) THEN IW( IWPOSCB + 7+KEEP(IXSZ) ) = S_ROOTBAND_INIT IF (NSLAVES_HDR.GT.0) THEN write(6,*) " Internal error in CMUMPS_PROCESS_DESC_BANDE " CALL MUMPS_ABORT() ENDIF ELSE IW( IWPOSCB+7+KEEP(IXSZ) ) = huge(IW(IWPOSCB+7+KEEP(IXSZ))) IW( IWPOSCB + 8+KEEP(IXSZ) ) = NFRONT IW( IWPOSCB + 9+KEEP(IXSZ) ) = S_ROOTBAND_INIT IW( IWPOSCB + 7+XTRA_SLAVES_SYM+KEEP(IXSZ): & IWPOSCB + 6+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_HDR ) = & BUFR( IBUFR: IBUFR - 1 + NSLAVES_HDR ) END IF IW(IWPOSCB+1+XXNBPR)=NBPROCFILS IW(IWPOSCB+1+XXLR)=LRSTATUS COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP=0 CALL CMUMPS_BLR_INIT_FRONT (IW(IWPOSCB+1+XXF), INFO_TMP) IF (INFO_TMP(1).LT.0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) RETURN ENDIF IF (COMPRESS_CB.AND. & (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & (ESTIM_NFS4FATHER_ATSON.GE.0) & ) THEN CALL CMUMPS_BLR_SAVE_NFS4FATHER ( IW(IWPOSCB+1+XXF), & ESTIM_NFS4FATHER_ATSON ) ENDIF ENDIF IF (NBPROCFILS .EQ. 0) THEN ENDIF RETURN END SUBROUTINE CMUMPS_PROCESS_DESC_BANDE RECURSIVE SUBROUTINE CMUMPS_TREAT_DESCBAND( INODE, & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED & , LRGROUPS & ) # if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M # endif USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER, INTENT(IN) :: INODE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST(KEEP(28)) INTEGER STEP(N), & PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) COMPLEX DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' LOGICAL :: BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: SRC_DESCBAND #if ! defined(NO_FDM_DESCBAND) INTEGER :: IWHANDLER TYPE(DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC #endif INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE SRC_DESCBAND = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) # if ! defined(NO_FDM_DESCBAND) IF (MUMPS_FDBD_IS_DESCBAND_STORED( INODE, IWHANDLER )) THEN CALL MUMPS_FDBD_RETRIEVE_DESCBAND(IWHANDLER, DESCBAND_STRUC) CALL CMUMPS_PROCESS_DESC_BANDE( MYID, DESCBAND_STRUC%BUFR(1), & DESCBAND_STRUC%LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, & IWHANDLER, & IFLAG, IERROR ) IF (IFLAG .LT. 0) GOTO 500 CALL MUMPS_FDBD_FREE_DESCBAND_STRUC(IW(PTRIST(STEP(INODE))+XXA)) ELSE IF (INODE_WAITED_FOR.GT.0) THEN WRITE(*,*) " Internal error 1 in CMUMPS_TREAT_DESCBAND", & INODE, INODE_WAITED_FOR CALL MUMPS_ABORT() ENDIF INODE_WAITED_FOR = INODE # endif DO WHILE (PTRIST(STEP(INODE)) .EQ. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT(COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & SRC_DESCBAND, MAITRE_DESC_BANDE, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (IFLAG .LT. 0) THEN RETURN ENDIF ENDDO # if ! defined(NO_FDM_DESCBAND) INODE_WAITED_FOR = -1 ENDIF # endif RETURN 500 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE CMUMPS_TREAT_DESCBAND MUMPS_5.8.1/src/dfac_process_contrib_type3.F0000664000175000017500000002601315042446440020640 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_PROCESS_CONTRIB_TYPE3(BUFR,LBUFR, & LBUFR_BYTES, & root, roota, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND,PROCNODE_STEPS, SLAVEF, OPASSW ) USE MUMPS_LOAD USE DMUMPS_OOC USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC ) :: root TYPE (DMUMPS_ROOT_STRUC ) :: roota INTEGER :: KEEP( 500 ) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: DKEEP(230) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER LBUFR, LBUFR_BYTES, N, LIW, & IWPOS, IWPOSCB, COMP, COMM, COMM_LOAD, IFLAG, & IERROR INTEGER LPOOL, LEAF INTEGER IPOOL( LEAF ) INTEGER PTRIST(KEEP(28)) INTEGER PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), ITLOC( N+KEEP(253) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER BUFR( LBUFR_BYTES ) INTEGER IW( LIW ) INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER SLAVEF DOUBLE PRECISION A( LA ) INTEGER MYID INTEGER FILS( N ), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER INTARR(KEEP8(27)) DOUBLE PRECISION DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW 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( STEP(IROOT)) .NE. 0 ) THEN IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NSUBSET_ROW & - NSUPROW .OR. NSUBSET_ROW - NSUPROW.EQ.0 .OR. & NSUBSET_COL_EFF .EQ. 0)THEN KEEP(121) = KEEP(121) - 1 IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL DMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSEIF (KEEP(201).EQ.2) THEN CALL DMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL DMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), & KEEP(28), KEEP(76), & KEEP(80), KEEP(47), & STEP, IROOT + N) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ENDIF ENDIF ELSE IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. & NSUBSET_ROW - NSUPROW .OR. & NSUBSET_ROW - NSUPROW.EQ.0 .OR. & NSUBSET_COL_EFF .EQ. 0)THEN KEEP(121)=-1 ENDIF CALL DMUMPS_ROOT_ALLOC_STATIC( root, roota, IROOT, N, & IW, LIW, A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) IF ( IFLAG .LT. 0 ) RETURN END IF IF (KEEP(60) .EQ.0) THEN IF ( PTRIST(STEP(IROOT)) .GE. 0 ) THEN IF ( PTRIST(STEP(IROOT)) .NE. 0 ) THEN LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) POS_ROOT = PAMASTER(STEP( IROOT )) ELSE LOCAL_N = IW( PTLUST(STEP( IROOT ) ) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST(STEP( IROOT ) ) + 2 + KEEP(IXSZ)) POS_ROOT = PTRFAC(IW(PTLUST(STEP(IROOT))+4+ & KEEP(IXSZ))) END IF ENDIF ELSE LOCAL_M = root%SCHUR_LLD LOCAL_N = root%SCHUR_NLOC ENDIF IF ( (BBPCBP.EQ.1).AND. (NBROWS_ALREADY_SENT.EQ.0).AND. & (min(NSUPROW, NSUPCOL) .GT. 0) & ) THEN LREQI = NSUPROW+NSUPCOL LREQA = int(NSUPROW,8) * int(NSUPCOL,8) IF ( (LREQA.NE.0_8) .AND. & (PTRIST(STEP(IROOT)).LT.0).AND. & KEEP(60)==0) THEN WRITE(*,*) ' Error in DMUMPS_PROCESS_CONTRIB_TYPE3' CALL MUMPS_ABORT() ENDIF CALL DMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 1 ), LREQI, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( IPTRLU + 1_8 ), int(LREQA), & MPI_DOUBLE_PRECISION, COMM, IERR ) OPASSW = OPASSW + LREQA CALL DMUMPS_ASS_ROOT( root, roota, KEEP(50), NSUPROW, NSUPCOL, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NSUPROW + 1 ), NSUPCOL, & A( IPTRLU + 1_8 ), & A( 1 ), & LOCAL_M, LOCAL_N, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & 1) IWPOSCB = IWPOSCB + LREQI IPTRLU = IPTRLU + LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) ENDIF LREQI = NBROWS_PACKET + NSUBSET_COL_EFF LREQA = int(NBROWS_PACKET,8) * int(NSUBSET_COL_EFF,8) IF ( (LREQA.NE.0_8) .AND. & (PTRIST(STEP(IROOT)).LT.0).AND. & KEEP(60)==0) THEN WRITE(*,*) ' Error in DMUMPS_PROCESS_CONTRIB_TYPE3' CALL MUMPS_ABORT() ENDIF IF (LREQA.NE.0_8) THEN CALL DMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 1 ), LREQI, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( IPTRLU + 1_8 ), int(LREQA), & MPI_DOUBLE_PRECISION, COMM, IERR ) OPASSW = OPASSW + LREQA IF (KEEP(60).EQ.0) THEN CALL DMUMPS_ASS_ROOT( root, roota, KEEP(50), & NBROWS_PACKET, NSUBSET_COL_EFF, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NBROWS_PACKET + 1 ), & NSUPCOL_EFF, & A( IPTRLU + 1_8 ), & A( POS_ROOT ), LOCAL_M, LOCAL_N, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & 0) ELSE CALL DMUMPS_ASS_ROOT( root, roota, KEEP(50), & NBROWS_PACKET, NSUBSET_COL_EFF, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NBROWS_PACKET + 1 ), & NSUPCOL_EFF, & A( IPTRLU + 1_8 ), & roota%SCHUR_POINTER(1), & root%SCHUR_LLD , root%SCHUR_NLOC, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & 0) ENDIF IWPOSCB = IWPOSCB + LREQI IPTRLU = IPTRLU + LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) ENDIF RETURN END SUBROUTINE DMUMPS_PROCESS_CONTRIB_TYPE3 MUMPS_5.8.1/src/estim_flops.F0000664000175000017500000001207415042446423015670 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_ESTIM_FLOPS( INODE, N, PROCNODE_STEPS, & KEEP199, & ND, FILS, FRERE_STEPS, STEP, PIMASTER, & KEEP28, KEEP50, KEEP253, & FLOP1, & IW, LIW, XSIZE ) IMPLICIT NONE INTEGER INODE, N, KEEP50, LIW, KEEP199, KEEP28, KEEP253 INTEGER PROCNODE_STEPS(KEEP28), ND(KEEP28), & FILS(N), FRERE_STEPS(KEEP28), & STEP(N), & PIMASTER(KEEP28), & IW( LIW ) INTEGER XSIZE DOUBLE PRECISION FLOP1 INTEGER NUMORG, IN, NASS, IFSON, NUMSTK, NFRONT, NPIV, & LEVEL, ISON LOGICAL MUMPS_IN_OR_ROOT_SSARBR INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_IN_OR_ROOT_SSARBR, MUMPS_TYPENODE INCLUDE 'mumps_headers.h' FLOP1 = 0.0D0 IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP199) ) RETURN IN = INODE NUMORG = 0 10 NUMORG = NUMORG + 1 IN = FILS(IN) IF (IN .GT. 0) GOTO 10 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .EQ. 0) GOTO 30 20 NUMSTK = NUMSTK + 1 NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 +XSIZE) ISON = FRERE_STEPS(STEP(ISON)) IF (ISON .GT. 0) GOTO 20 30 NFRONT = ND(STEP(INODE)) + NASS + KEEP253 NPIV = NASS + NUMORG LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP199) CALL MUMPS_GET_FLOPS_COST(NFRONT,NPIV,NPIV,KEEP50,LEVEL,FLOP1) RETURN END SUBROUTINE MUMPS_ESTIM_FLOPS SUBROUTINE MUMPS_UPDATE_FLOPS_ROOT(OPELIW, KEEP50, NFRONT, NPIV, & NPROW, NPCOL, MYID) DOUBLE PRECISION, intent(inout) :: OPELIW INTEGER, intent(in) :: KEEP50, NFRONT, NPIV, & NPROW, NPCOL, MYID DOUBLE PRECISION :: COST, COST_PER_PROC INTEGER, PARAMETER :: LEVEL3 = 3 CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NFRONT, KEEP50, LEVEL3, & COST) COST_PER_PROC = dble(int( COST,8) / int(NPROW * NPCOL,8)) OPELIW = OPELIW + COST_PER_PROC RETURN END SUBROUTINE MUMPS_UPDATE_FLOPS_ROOT SUBROUTINE MUMPS_GET_FLOPS_COST(NFRONT,NPIV,NASS, & KEEP50,LEVEL,COST) IMPLICIT NONE INTEGER, intent(in) :: NFRONT,NPIV,KEEP50,LEVEL, NASS DOUBLE PRECISION, intent(out) :: COST IF (KEEP50.EQ.0) THEN IF (LEVEL.EQ.1 .OR. LEVEL.EQ.3) THEN COST = dble(2) * dble(NFRONT) * dble(NPIV) * & dble(NFRONT - NPIV - 1) + & dble(NPIV) * dble(NPIV + 1) * dble(2 * NPIV + 1) & / dble(3) COST = COST + dble(2 * NFRONT - NPIV - 1) & * dble(NPIV) /dble(2) ELSEIF (LEVEL.EQ.2) THEN COST = dble(2*NASS)*dble(NFRONT) - & dble(NASS+NFRONT)*dble(NPIV+1) COST = dble(NPIV)*COST + & dble(2 * NASS - NPIV - 1) * dble(NPIV) / dble(2) + & dble(NPIV) * dble(NPIV + 1) * & dble(2 * NPIV + 1) /dble(3) ENDIF ELSE IF (LEVEL.EQ.1 .OR. (LEVEL.EQ.3 .AND. KEEP50.EQ.1)) THEN COST = dble(NPIV) * ( & dble( NFRONT ) * dble( NFRONT ) + & dble( NFRONT ) - ( & dble( NFRONT)*dble(NPIV) + dble(NPIV+1) & )) +( dble(NPIV)*dble(NPIV+1) & *dble(2*NPIV+1))/ dble(6) ELSE IF (LEVEL.EQ.3.AND.KEEP50.EQ.2) THEN COST = dble(2) * dble(NFRONT) * dble(NPIV) * & dble(NFRONT - NPIV - 1) + & dble(NPIV) * dble(NPIV + 1) * & dble(2 * NPIV + 1) / dble(3) COST = COST + dble(2 * NFRONT - NPIV - 1) & * dble(NPIV) / dble(2) ELSE COST = dble(NPIV) * ( & dble( NASS ) * dble( NASS ) + dble( NASS ) & - ( dble( NASS) * dble(NPIV) + dble( NPIV + 1 ) ) ) & + ( dble(NPIV)*dble(NPIV+1)*dble(2*NPIV+1) ) & / dble( 6 ) ENDIF ENDIF RETURN END SUBROUTINE MUMPS_GET_FLOPS_COST SUBROUTINE MUMPS_PRINT_STILL_ACTIVE(MYID, KEEP, DKEEP17, OPELIW, & OPLAST_PRINTED, MPA) IMPLICIT NONE INTEGER, intent(in) :: KEEP (500), MYID, MPA DOUBLE PRECISION :: DKEEP17 DOUBLE PRECISION, intent(in) :: OPELIW DOUBLE PRECISION, intent(inout) :: OPLAST_PRINTED IF (MPA.GT.0) THEN IF ( (OPELIW-OPLAST_PRINTED).GT. DKEEP17) THEN WRITE(MPA,'(A,I6,A,A,1PD10.3)') & ' ... MPI process', MYID, & ': theoretical number of flops locally performed', & ' so far = ', & OPELIW OPLAST_PRINTED = OPELIW ENDIF ENDIF RETURN END SUBROUTINE MUMPS_PRINT_STILL_ACTIVE MUMPS_5.8.1/src/dfac_process_root2son.F0000664000175000017500000003246015042446440017644 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE & DMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & INODE, NELIM_ROOT, root, roota, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER KEEP(500), ICNTL( 60 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER INODE, NELIM_ROOT INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER INTARR(KEEP8(27)) DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER LCONT, NCOL_TO_SEND, LDA INTEGER(8) :: SHIFT_VAL_SON, POSELT INTEGER FPERE, IOLDPS, NFRONT, NPIV, NASS, NSLAVES, & H_INODE, NELIM, NBCOL, TYPE_SON, & NROW, NCOL, NBROW, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, LDAFS, IERR, & ISON, PDEST_MASTER_ISON INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG LOGICAL TRANSPOSE_ASM INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE FPERE = KEEP(38) TYPE_SON = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ).EQ.MYID) THEN IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NASS = abs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) H_INODE = 6 + NSLAVES + KEEP(IXSZ) NELIM = NASS - NPIV NBCOL = NFRONT - NPIV IF (NELIM.LE.0) THEN write(6,*) ' ERROR 1 in DMUMPS_PROCESS_ROOT2SON ', NELIM write(6,*) MYID,':Process root2son: INODE=',INODE, & 'Header=',IW(PTLUST_S(STEP(INODE)):PTLUST_S(STEP(INODE)) & +5+KEEP(IXSZ)) CALL MUMPS_ABORT() ENDIF NBROW = NFRONT - NPIV NROW = NELIM IF ( KEEP( 50 ) .eq. 0 ) THEN NCOL = NFRONT - NPIV ELSE NCOL = NELIM END IF SHIFT_LIST_ROW_SON = H_INODE + NPIV SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV IF ( KEEP(50).eq.0 .OR. TYPE_SON .eq. 1 ) THEN LDAFS = NFRONT ELSE LDAFS = NASS END IF SHIFT_VAL_SON = int(NPIV,8) * int(LDAFS,8) + int(NPIV,8) CALL DMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, & ASS_IRECV, & N, INODE, FPERE, & PTLUST_S(1), PTRAST(1), & root, roota, NROW, NCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDAFS, & ROOT_NON_ELIM_CB, MYID, COMM, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S(1), PTRFAC(1), PTRAST(1), & STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE.,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS, NELIM_ROOT, NELIM, NELIM & ) IF (IFLAG.LT.0 ) RETURN IF (TYPE_SON.EQ.1) THEN NROW = NFRONT - NASS NCOL = NELIM SHIFT_LIST_ROW_SON = H_INODE + NASS SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV SHIFT_VAL_SON = int(NASS,8) * int(NFRONT,8) + int(NPIV,8) IF ( KEEP( 50 ) .eq. 0 ) THEN TRANSPOSE_ASM = .FALSE. ELSE TRANSPOSE_ASM = .TRUE. END IF CALL DMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTLUST_S, PTRAST, & root, roota, NROW, NCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, & ROOT_NON_ELIM_CB, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP, & TRANSPOSE_ASM,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS, & NELIM_ROOT, 0, NELIM ) 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 IF (KEEP(50).NE.0) THEN CALL DMUMPS_COMPACT_FACTORS_SYM(A(POSELT), LDA, & NPIV, NBROW, KEEP, & int(LDA,8)*int(NBROW+NPIV,8), IW(IOLDPS+H_INODE+NFRONT)) ELSE CALL DMUMPS_COMPACT_FACTORS_UNSYM( & A(POSELT+int(NPIV,8)*int(LDA,8)), LDA, & NPIV, NBROW, KEEP, & int(LDA,8)*int(NBROW+NPIV,8) ) ENDIF IW(IOLDPS + KEEP(IXSZ)) = NBCOL IW(IOLDPS + 1 +KEEP(IXSZ)) = NASS - NPIV IF (TYPE_SON.EQ.2) THEN IW(IOLDPS + 2 +KEEP(IXSZ)) = NASS ELSE IW(IOLDPS + 2 +KEEP(IXSZ)) = NFRONT ENDIF IW(IOLDPS + 3 +KEEP(IXSZ)) = NPIV CALL DMUMPS_COMPRESS_LU(0_8,MYID,N,IOLDPS,TYPE_SON,IW,LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST,PTRFAC,STEP, KEEP,KEEP8, .FALSE.,INODE,IERR & , LRGROUPS, NASS & ) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 RETURN ENDIF ELSE ISON = INODE PDEST_MASTER_ISON = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(ISON)), KEEP(199) ) IF ( PTRIST(STEP(ISON)) .EQ. 0) THEN CALL DMUMPS_TREAT_DESCBAND( ISON, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE,LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 +KEEP(IXSZ)) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN END DO IOLDPS = PTRIST(STEP(INODE)) LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV IF (NELIM.LE.0) THEN write(6,*) MYID,': INODE,LCONT, NROW, NPIV, NASS, NELIM=', & INODE,LCONT, NROW, NPIV, NASS, NELIM write(6,*) MYID,': IOLDPS=',IOLDPS write(6,*) MYID,': ERROR 2 in DMUMPS_PROCESS_ROOT2SON ' CALL MUMPS_ABORT() ENDIF NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) H_INODE = 6 + NSLAVES + KEEP(IXSZ) SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NPIV NCOL_TO_SEND = NELIM LDA = -9999 SHIFT_VAL_SON = -9999_8 IF ( KEEP( 50 ) .eq. 0 ) THEN TRANSPOSE_ASM = .FALSE. ELSE TRANSPOSE_ASM = .TRUE. END IF CALL DMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTRIST, PTRAST, & root, roota, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, & ROOT_NON_ELIM_CB, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,TRANSPOSE_ASM, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS, & NELIM_ROOT, 0, NCOL_TO_SEND ) IF (IFLAG.LT.0 ) RETURN IF (KEEP(214).EQ.2) THEN CALL DMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP, KEEP8, DKEEP,TYPE_SON & ) ENDIF IF (IFLAG.LT.0) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_PROCESS_ROOT2SON MUMPS_5.8.1/src/zmumps_ooc.F0000664000175000017500000036317615042446441015553 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_OOC USE MUMPS_OOC_COMMON !$ USE OMP_LIB, ONLY : OMP_LOCK_KIND, OMP_SET_LOCK, OMP_UNSET_LOCK, !$ & OMP_INIT_LOCK, OMP_DESTROY_LOCK, OMP_TEST_LOCK IMPLICIT NONE !$ INTEGER(KIND=OMP_LOCK_KIND) :: LOCK_FOR_L0OMP INTEGER NOT_IN_MEM,BEING_READ,NOT_USED,PERMUTED,USED, & USED_NOT_PERMUTED,ALREADY_USED PARAMETER (NOT_IN_MEM=0,BEING_READ=-1,NOT_USED=-2, & PERMUTED=-3,USED=-4,USED_NOT_PERMUTED=-5,ALREADY_USED=-6) INTEGER OOC_NODE_NOT_IN_MEM,OOC_NODE_PERMUTED, & OOC_NODE_NOT_PERMUTED PARAMETER (OOC_NODE_NOT_IN_MEM=-20, & OOC_NODE_PERMUTED=-21,OOC_NODE_NOT_PERMUTED=-22) INTEGER(8), DIMENSION(:,:),POINTER :: SIZE_OF_BLOCK INTEGER, DIMENSION(:),POINTER :: TOTAL_NB_OOC_NODES INTEGER :: OOC_SOLVE_TYPE_FCT INTEGER, DIMENSION(:),ALLOCATABLE :: IO_REQ INTEGER(8), DIMENSION(:), ALLOCATABLE:: LRLUS_SOLVE INTEGER(8), DIMENSION(:), ALLOCATABLE:: SIZE_SOLVE_Z, & LRLU_SOLVE_T, POSFAC_SOLVE, IDEB_SOLVE_Z, LRLU_SOLVE_B INTEGER, DIMENSION(:),ALLOCATABLE :: PDEB_SOLVE_Z INTEGER (8),SAVE :: FACT_AREA_SIZE, & SIZE_ZONE_SOLVE,SIZE_SOLVE_EMM,TMP_SIZE_FACT, & MAX_SIZE_FACTOR_OOC INTEGER(8), SAVE :: MIN_SIZE_READ INTEGER, SAVE :: TMP_NB_NODES, MAX_NB_NODES_FOR_ZONE,MAX_NB_REQ, & CURRENT_SOLVE_READ_ZONE, & CUR_POS_SEQUENCE,NB_Z,SOLVE_STEP, & NB_ZONE_REQ,MTYPE_OOC,NB_ACT & ,NB_CALLED,REQ_ACT,NB_CALL INTEGER(8), SAVE :: OOC_VADDR_PTR INTEGER(8), SAVE :: SIZE_ZONE_REQ INTEGER(8), DIMENSION(:), ALLOCATABLE :: SIZE_OF_READ, READ_DEST INTEGER,DIMENSION(:),ALLOCATABLE :: FIRST_POS_IN_READ, & READ_MNG,REQ_TO_ZONE,POS_HOLE_T, & POS_HOLE_B,REQ_ID,OOC_STATE_NODE INTEGER ZMUMPS_ELEMENTARY_DATA_SIZE,N_OOC INTEGER, DIMENSION(:), ALLOCATABLE :: POS_IN_MEM, INODE_TO_POS INTEGER, DIMENSION(:), ALLOCATABLE :: CURRENT_POS_T,CURRENT_POS_B LOGICAL IS_ROOT_SPECIAL INTEGER SPECIAL_ROOT_NODE PUBLIC :: ZMUMPS_OOC_INIT_FACTO,ZMUMPS_NEW_FACTOR, & ZMUMPS_READ_OOC, & ZMUMPS_SOLVE_ALLOC_FACTOR_SPACE, & ZMUMPS_IS_THERE_FREE_SPACE, & ZMUMPS_OOC_END_SOLVE, & ZMUMPS_SOLVE_INIT_OOC_FWD,ZMUMPS_SOLVE_INIT_OOC_BWD, & ZMUMPS_INITIATE_READ_OPS,ZMUMPS_OOC_INIT_SOLVE INTEGER, PARAMETER, PUBLIC :: TYPEF_BOTH_LU = -99976 PUBLIC ZMUMPS_OOC_IO_LU_PANEL, & ZMUMPS_OOC_PANEL_SIZE PRIVATE ZMUMPS_OOC_STORE_LorU, & ZMUMPS_OOC_WRT_IN_PANELS_LorU CONTAINS SUBROUTINE ZMUMPS_SET_STRAT_IO_FLAGS( STRAT_IO_ARG, & STRAT_IO_ASYNC_ARG, WITH_BUF_ARG, LOW_LEVEL_STRAT_IO_ARG ) IMPLICIT NONE INTEGER, intent(out) :: LOW_LEVEL_STRAT_IO_ARG LOGICAL, intent(out) :: STRAT_IO_ASYNC_ARG, WITH_BUF_ARG INTEGER, intent(in) :: STRAT_IO_ARG INTEGER TMP CALL MUMPS_OOC_IS_ASYNC_AVAIL(TMP) STRAT_IO_ASYNC_ARG=.FALSE. WITH_BUF_ARG=.FALSE. IF(TMP.EQ.1)THEN IF((STRAT_IO_ARG.EQ.1).OR.(STRAT_IO_ARG.EQ.2))THEN STRAT_IO_ASYNC=.TRUE. WITH_BUF=.FALSE. ELSEIF((STRAT_IO_ARG.EQ.4).OR.(STRAT_IO_ARG.EQ.5))THEN STRAT_IO_ASYNC_ARG=.TRUE. WITH_BUF_ARG=.TRUE. ELSEIF(STRAT_IO_ARG.EQ.3)THEN STRAT_IO_ASYNC_ARG=.FALSE. WITH_BUF_ARG=.TRUE. ENDIF LOW_LEVEL_STRAT_IO_ARG=mod(STRAT_IO_ARG,3) ELSE LOW_LEVEL_STRAT_IO_ARG=0 IF(STRAT_IO_ARG.GE.3)THEN WITH_BUF_ARG=.TRUE. ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SET_STRAT_IO_FLAGS FUNCTION ZMUMPS_IS_THERE_FREE_SPACE(INODE,ZONE) IMPLICIT NONE INTEGER INODE,ZONE LOGICAL ZMUMPS_IS_THERE_FREE_SPACE ZMUMPS_IS_THERE_FREE_SPACE=(LRLUS_SOLVE(ZONE).GE. & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) RETURN END FUNCTION ZMUMPS_IS_THERE_FREE_SPACE SUBROUTINE ZMUMPS_INIT_FACT_AREA_SIZE_S(LA) IMPLICIT NONE INTEGER(8) :: LA FACT_AREA_SIZE=LA END SUBROUTINE ZMUMPS_INIT_FACT_AREA_SIZE_S SUBROUTINE ZMUMPS_OOC_INIT_FACTO(idICNTL1, idICNTL4, & idN, idNSLAVES, & idMYID, MAXS, idOOC_NB_FILE_TYPE, & idKEEP, idKEEP8, idSTEP, idPROCNODE_STEPS, & idOOC_SIZE_OF_BLOCK, & idOOC_VADDR, idINFO, idOOC_TMPDIR, idOOC_PREFIX, & idOOC_NB_FILES, idOOC_INODE_SEQUENCE) & USE ZMUMPS_STRUC_DEF USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER :: idICNTL1, idICNTL4, idN, idNSLAVES, idMYID INTEGER :: idOOC_NB_FILE_TYPE INTEGER, TARGET :: idKEEP(500) INTEGER :: idINFO(2) INTEGER(8), TARGET :: idKEEP8(150) INTEGER, POINTER, DIMENSION(:) :: idSTEP, idPROCNODE_STEPS INTEGER(8),DIMENSION(:,:), POINTER :: idOOC_SIZE_OF_BLOCK INTEGER(8), DIMENSION(:,:), POINTER :: idOOC_VADDR INTEGER(8), INTENT(IN) :: MAXS INTEGER OOC_TMPDIR_MAX_LENGTH, OOC_PREFIX_MAX_LENGTH PARAMETER (OOC_TMPDIR_MAX_LENGTH=1023, OOC_PREFIX_MAX_LENGTH=255) CHARACTER(LEN=OOC_TMPDIR_MAX_LENGTH) :: idOOC_TMPDIR CHARACTER(LEN=OOC_PREFIX_MAX_LENGTH) :: idOOC_PREFIX INTEGER, DIMENSION(:), POINTER :: idOOC_NB_FILES INTEGER, DIMENSION(:,:), POINTER :: idOOC_INODE_SEQUENCE INTEGER IERR INTEGER allocok INTEGER DIM_TMPDIR,DIM_PREFIX INTEGER, DIMENSION(:), ALLOCATABLE :: FILE_FLAG_TAB INTEGER TMP INTEGER KEEP211_LOC ICNTL1 = idICNTL1 IF (idICNTL4 .LT. 1) idICNTL1=0 MAX_SIZE_FACTOR_OOC=0_8 N_OOC=idN SOLVE=.FALSE. IERR=0 IF (idKEEP(400).GT.0) THEN !$ CALL OMP_INIT_LOCK( LOCK_FOR_L0OMP ) 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(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_VADDR))THEN NULLIFY(OOC_VADDR) ENDIF IF(allocated(I_CUR_HBUF_NEXTPOS))THEN DEALLOCATE(I_CUR_HBUF_NEXTPOS) ENDIF OOC_NB_FILE_TYPE=idOOC_NB_FILE_TYPE IF(IERR.LT.0)THEN IF (ICNTL1 > 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) idINFO(1) = IERR idINFO(2) = 0 RETURN ENDIF CALL MUMPS_OOC_INIT_FILETYPE(TYPEF_L, TYPEF_U, TYPEF_CB, & idKEEP(201), idKEEP(251), idKEEP(50), TYPEF_INVALID ) IF (idKEEP(201).EQ.2) THEN OOC_FCT_TYPE=1 ENDIF STEP_OOC=>idSTEP PROCNODE_OOC=>idPROCNODE_STEPS MYID_OOC=idMYID SLAVEF_OOC=idNSLAVES KEEP_OOC => idKEEP SIZE_OF_BLOCK=>idOOC_SIZE_OF_BLOCK OOC_VADDR=>idOOC_VADDR IF(idKEEP(107).GT.0)THEN SIZE_SOLVE_EMM=max(idKEEP8(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(idKEEP(107)),8)) IF(SIZE_ZONE_SOLVE.EQ.SIZE_SOLVE_EMM)THEN SIZE_SOLVE_EMM=idKEEP8(19) SIZE_ZONE_SOLVE=int((dble(MAXS)*0.9d0- & dble(SIZE_SOLVE_EMM))/dble(idKEEP(107)),8) ENDIF ELSE SIZE_ZONE_SOLVE=int(dble(MAXS)*0.9d0,8) SIZE_SOLVE_EMM=SIZE_ZONE_SOLVE ENDIF ZMUMPS_ELEMENTARY_DATA_SIZE = idKEEP(35) SIZE_OF_BLOCK=0_8 ALLOCATE(idOOC_NB_FILES(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF idINFO(1) = -13 idINFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF idOOC_NB_FILES=0 OOC_VADDR_PTR=0_8 CALL ZMUMPS_SET_STRAT_IO_FLAGS( idKEEP(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=>idOOC_INODE_SEQUENCE ALLOCATE(I_CUR_HBUF_NEXTPOS(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF idINFO(1) = -13 idINFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF I_CUR_HBUF_NEXTPOS = 1 IF(WITH_BUF)THEN CALL ZMUMPS_INIT_OOC_BUF(idINFO(1),idINFO(2),IERR) IF(IERR.LT.0)THEN RETURN ENDIF 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_TMPDIR=len(trim(idOOC_TMPDIR)) DIM_PREFIX=len(trim(idOOC_PREFIX)) CALL MUMPS_LOW_LEVEL_INIT_PREFIX(DIM_PREFIX, idOOC_PREFIX) CALL MUMPS_LOW_LEVEL_INIT_TMPDIR(DIM_TMPDIR, idOOC_TMPDIR) ALLOCATE(FILE_FLAG_TAB(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1 .GT. 0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF idINFO(1) = -13 idINFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF FILE_FLAG_TAB(1:OOC_NB_FILE_TYPE)=0 IERR=0 TMP=int(idKEEP8(11)/1000000_8)+1 IF((idKEEP(201).EQ.1).AND.(idKEEP(50).EQ.0) & ) THEN TMP=max(1,TMP/2) ENDIF CALL MUMPS_LOW_LEVEL_INIT_OOC_C(MYID_OOC,TMP, & idKEEP(35),LOW_LEVEL_STRAT_IO,KEEP211_LOC,OOC_NB_FILE_TYPE, & FILE_FLAG_TAB,idKEEP(255),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 idINFO(1) = IERR idINFO(2) = 0 RETURN ENDIF DEALLOCATE(FILE_FLAG_TAB) RETURN END SUBROUTINE ZMUMPS_OOC_INIT_FACTO SUBROUTINE ZMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZE,IERR) USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) :: LA INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)), SIZE COMPLEX(kind=8) A(LA) INTEGER IERR,REQUEST INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=FCT IERR=0 SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)=SIZE MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,SIZE) OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)=OOC_VADDR_PTR OOC_VADDR_PTR=OOC_VADDR_PTR+SIZE TMP_SIZE_FACT=TMP_SIZE_FACT+SIZE TMP_NB_NODES=TMP_NB_NODES+1 IF(TMP_SIZE_FACT.GT.SIZE_ZONE_SOLVE)THEN MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE,TMP_NB_NODES) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 ENDIF IF (.NOT. WITH_BUF) THEN CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & A(PTRFAC(STEP_OOC(INODE))),SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE).GT.KEEP_OOC(28))THEN WRITE(*,*)MYID_OOC,': Internal error (37) in OOC ' CALL MUMPS_ABORT() ENDIF OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE)=INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)= & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)+1 ELSE IF(SIZE.LE.HBUF_SIZE)THEN CALL ZMUMPS_OOC_COPY_DATA_TO_BUFFER & (A(PTRFAC(STEP_OOC(INODE))),SIZE,IERR) OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE) = INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE) = & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE) + 1 PTRFAC(STEP_OOC(INODE))=-777777_8 RETURN ELSE CALL ZMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL ZMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & A(PTRFAC(STEP_OOC(INODE))),SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(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 (38) in OOC ' CALL MUMPS_ABORT() ENDIF OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE)=INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)= & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)+1 CALL ZMUMPS_OOC_NEXT_HBUF(OOC_FCT_TYPE) ENDIF END IF PTRFAC(STEP_OOC(INODE))=-777777_8 IF(STRAT_IO_ASYNC)THEN IERR=0 CALL MUMPS_WAIT_REQUEST(REQUEST,IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_NEW_FACTOR SUBROUTINE ZMUMPS_READ_OOC(DEST,INODE,IERR & ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR,INODE COMPLEX(kind=8) DEST INTEGER 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 IERR=0 OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_LOW_LEVEL_DIRECT_READ(DEST, & SIZE_INT1,SIZE_INT2, & TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) WRITE(ICNTL1,*)MYID_OOC, & ': Problem in MUMPS_LOW_LEVEL_DIRECT_READ' ENDIF RETURN ENDIF 555 CONTINUE IF(.NOT.ZMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE).EQ. & INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL ZMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_READ_OOC SUBROUTINE ZMUMPS_OOC_CLEAN_PENDING(IERR) USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out):: IERR IERR=0 IF (WITH_BUF) THEN CALL ZMUMPS_OOC_BUF_CLEAN_PENDING(IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF RETURN END SUBROUTINE ZMUMPS_OOC_CLEAN_PENDING SUBROUTINE ZMUMPS_OOC_END_FACTO(idKEEP,idKEEP8, & idOOC_MAX_NB_NODES_FOR_ZONE, & idOOC_TOTAL_NB_NODES, & idOOC_FILE_NAMES,idINFO, & idOOC_FILE_NAME_LENGTH, & idOOC_NB_FILES, & IERR) USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER :: idKEEP(500), idINFO(2) INTEGER(8) :: idKEEP8(150) INTEGER :: idOOC_MAX_NB_NODES_FOR_ZONE INTEGER,DIMENSION(:), POINTER :: idOOC_TOTAL_NB_NODES CHARACTER,DIMENSION(:,:), POINTER :: idOOC_FILE_NAMES INTEGER,DIMENSION(:), POINTER :: idOOC_FILE_NAME_LENGTH INTEGER,DIMENSION(:), POINTER :: idOOC_NB_FILES INTEGER, intent(out) :: IERR INTEGER I,SOLVE_OR_FACTO IERR=0 IF (idKEEP(400).GT.0) THEN !$ CALL OMP_DESTROY_LOCK( LOCK_FOR_L0OMP ) ENDIF IF(WITH_BUF)THEN CALL ZMUMPS_END_OOC_BUF() ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_VADDR))THEN NULLIFY(OOC_VADDR) ENDIF CALL MUMPS_OOC_END_WRITE_C(IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) GOTO 500 ENDIF idOOC_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 idOOC_TOTAL_NB_NODES(I)=I_CUR_HBUF_NEXTPOS(I)-1 ENDDO DEALLOCATE(I_CUR_HBUF_NEXTPOS) ENDIF idKEEP8(20)=MAX_SIZE_FACTOR_OOC CALL ZMUMPS_STRUC_STORE_FILE_NAME( idOOC_NB_FILES, & idOOC_FILE_NAMES, idOOC_FILE_NAME_LENGTH, & idINFO, IERR) IF(IERR.LT.0)THEN GOTO 500 ENDIF 500 CONTINUE SOLVE_OR_FACTO=0 CALL MUMPS_CLEAN_IO_DATA_C(MYID_OOC,SOLVE_OR_FACTO,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_END_FACTO SUBROUTINE ZMUMPS_OOC_INIT_SOLVE(idICNTL1, idICNTL4, idN, & idNSLAVES, idMYID, idOOC_NB_FILE_TYPE, idKEEP, idKEEP8, & idINFO, idSTEP, idPROCNODE_STEPS, idOOC_SIZE_OF_BLOCK, & idOOC_INODE_SEQUENCE, & idOOC_VADDR, idOOC_MAX_NB_NODES_FOR_ZONE, idOOC_TOTAL_NB_NODES, & idOOC_NB_FILES, idOOC_FILE_NAME_LENGTH, idOOC_FILE_NAMES, & idCOMM_NODES, idrootyes) IMPLICIT NONE INTEGER :: idICNTL1, idICNTL4, idN, idNSLAVES, idMYID INTEGER :: idOOC_NB_FILE_TYPE INTEGER, TARGET :: idKEEP(500) INTEGER(8) :: idKEEP8(150) INTEGER :: idINFO(2) INTEGER,POINTER,DIMENSION(:) :: idSTEP, idPROCNODE_STEPS INTEGER(8),DIMENSION(:,:), POINTER :: idOOC_SIZE_OF_BLOCK INTEGER, DIMENSION(:,:), POINTER :: idOOC_INODE_SEQUENCE INTEGER(8), DIMENSION(:,:),POINTER :: idOOC_VADDR INTEGER :: idOOC_MAX_NB_NODES_FOR_ZONE INTEGER, DIMENSION(:), POINTER :: idOOC_TOTAL_NB_NODES INTEGER :: idCOMM_NODES LOGICAL :: idrootyes INTEGER,DIMENSION(:), POINTER :: idOOC_NB_FILES INTEGER,DIMENSION(:), POINTER :: idOOC_FILE_NAME_LENGTH CHARACTER,DIMENSION(:,:), POINTER :: idOOC_FILE_NAMES INCLUDE 'mpif.h' INTEGER TMP,I,J INTEGER(8) :: TMP_SIZE8 INTEGER allocok,IERR EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER MASTER_ROOT IERR=0 ICNTL1=idICNTL1 IF (idICNTL4 > 1) ICNTL1 = 0 SOLVE=.TRUE. N_OOC=idN IF(allocated(LRLUS_SOLVE))THEN DEALLOCATE(LRLUS_SOLVE) ENDIF IF(allocated(LRLU_SOLVE_T))THEN DEALLOCATE(LRLU_SOLVE_T) ENDIF IF(allocated(LRLU_SOLVE_B))THEN DEALLOCATE(LRLU_SOLVE_B) ENDIF IF(allocated(POSFAC_SOLVE))THEN DEALLOCATE(POSFAC_SOLVE) ENDIF IF(allocated(IDEB_SOLVE_Z))THEN DEALLOCATE(IDEB_SOLVE_Z) ENDIF IF(allocated(PDEB_SOLVE_Z))THEN DEALLOCATE(PDEB_SOLVE_Z) ENDIF IF(allocated(SIZE_SOLVE_Z))THEN DEALLOCATE(SIZE_SOLVE_Z) ENDIF IF(allocated(CURRENT_POS_T))THEN DEALLOCATE(CURRENT_POS_T) ENDIF IF(allocated(CURRENT_POS_B))THEN DEALLOCATE(CURRENT_POS_B) ENDIF IF(allocated(POS_HOLE_T))THEN DEALLOCATE(POS_HOLE_T) ENDIF IF(allocated(POS_HOLE_B))THEN DEALLOCATE(POS_HOLE_B) ENDIF IF(allocated(OOC_STATE_NODE))THEN DEALLOCATE(OOC_STATE_NODE) ENDIF IF(allocated(POS_IN_MEM))THEN DEALLOCATE(POS_IN_MEM) ENDIF IF(allocated(INODE_TO_POS))THEN DEALLOCATE(INODE_TO_POS) ENDIF IF(allocated(SIZE_OF_READ))THEN DEALLOCATE(SIZE_OF_READ) ENDIF IF(allocated(FIRST_POS_IN_READ))THEN DEALLOCATE(FIRST_POS_IN_READ) ENDIF IF(allocated(READ_DEST))THEN DEALLOCATE(READ_DEST) ENDIF IF(allocated(READ_MNG))THEN DEALLOCATE(READ_MNG) ENDIF IF(allocated(REQ_TO_ZONE))THEN DEALLOCATE(REQ_TO_ZONE) ENDIF IF(allocated(REQ_ID))THEN DEALLOCATE(REQ_ID) ENDIF IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF OOC_NB_FILE_TYPE=idOOC_NB_FILE_TYPE CALL MUMPS_OOC_INIT_FILETYPE(TYPEF_L, TYPEF_U, TYPEF_CB, & idKEEP(201), idKEEP(251), idKEEP(50), TYPEF_INVALID ) DIM_ERR_STR_OOC = ERR_STR_OOC_MAX_LEN CALL MUMPS_LOW_LEVEL_INIT_ERR_STR(DIM_ERR_STR_OOC,ERR_STR_OOC) CALL ZMUMPS_OOC_OPEN_FILES_FOR_SOLVE(idINFO, idOOC_NB_FILES, & idMYID, idKEEP, idOOC_FILE_NAME_LENGTH, idOOC_FILE_NAMES ) IF(idINFO(1).LT.0)THEN RETURN ENDIF STEP_OOC=>idSTEP PROCNODE_OOC=>idPROCNODE_STEPS SLAVEF_OOC=idNSLAVES MYID_OOC=idMYID KEEP_OOC => idKEEP SIZE_OF_BLOCK=>idOOC_SIZE_OF_BLOCK OOC_INODE_SEQUENCE=>idOOC_INODE_SEQUENCE OOC_VADDR=>idOOC_VADDR ALLOCATE(IO_REQ(idKEEP(28)), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = idKEEP(28) RETURN ENDIF ZMUMPS_ELEMENTARY_DATA_SIZE = idKEEP(35) MAX_NB_NODES_FOR_ZONE=idOOC_MAX_NB_NODES_FOR_ZONE TOTAL_NB_OOC_NODES=>idOOC_TOTAL_NB_NODES CALL ZMUMPS_SET_STRAT_IO_FLAGS( idKEEP(204), STRAT_IO_ASYNC, & WITH_BUF, LOW_LEVEL_STRAT_IO) IF(idKEEP(107).GT.0)THEN SIZE_SOLVE_EMM=max(idKEEP8(20), & FACT_AREA_SIZE / 5_8) SIZE_ZONE_SOLVE=max(SIZE_SOLVE_EMM, & int((dble(FACT_AREA_SIZE)- & dble(SIZE_SOLVE_EMM))/dble(idKEEP(107)),8)) SIZE_ZONE_SOLVE=max(SIZE_ZONE_SOLVE,0_8) IF(SIZE_ZONE_SOLVE.EQ.SIZE_SOLVE_EMM)THEN SIZE_SOLVE_EMM=idKEEP8(20) SIZE_ZONE_SOLVE=int((dble(FACT_AREA_SIZE)- & dble(SIZE_SOLVE_EMM))/dble(idKEEP(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.idKEEP8(20))THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': More space needed for & solution step in ZMUMPS_OOC_INIT_SOLVE' idINFO(1) = -11 CALL MUMPS_SET_IERROR(idKEEP8(20), idINFO(2)) ENDIF TMP=MAX_NB_NODES_FOR_ZONE CALL MPI_ALLREDUCE(TMP,MAX_NB_NODES_FOR_ZONE,1, & MPI_INTEGER,MPI_MAX,idCOMM_NODES, IERR) NB_Z=KEEP_OOC(107)+1 ALLOCATE(POS_IN_MEM(MAX_NB_NODES_FOR_ZONE*NB_Z), & INODE_TO_POS(KEEP_OOC(28)), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = idKEEP(28)+(MAX_NB_NODES_FOR_ZONE*NB_Z) RETURN ENDIF ALLOCATE(OOC_STATE_NODE(KEEP_OOC(28)),stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = idKEEP(28) RETURN ENDIF OOC_STATE_NODE(1:KEEP_OOC(28))=0 INODE_TO_POS=0 POS_IN_MEM=0 ALLOCATE(LRLUS_SOLVE(NB_Z), LRLU_SOLVE_T(NB_Z),LRLU_SOLVE_B(NB_Z), & POSFAC_SOLVE(NB_Z),IDEB_SOLVE_Z(NB_Z), & PDEB_SOLVE_Z(NB_Z),SIZE_SOLVE_Z(NB_Z), & CURRENT_POS_T(NB_Z),CURRENT_POS_B(NB_Z), & POS_HOLE_T(NB_Z),POS_HOLE_B(NB_Z), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = 9*(NB_Z+1) RETURN ENDIF IERR=0 CALL MUMPS_GET_MAX_NB_REQ_C(MAX_NB_REQ,IERR) ALLOCATE(SIZE_OF_READ(MAX_NB_REQ),FIRST_POS_IN_READ(MAX_NB_REQ), & READ_DEST(MAX_NB_REQ),READ_MNG(MAX_NB_REQ), & REQ_TO_ZONE(MAX_NB_REQ),REQ_ID(MAX_NB_REQ),stat=allocok) SIZE_OF_READ=-9999_8 FIRST_POS_IN_READ=-9999 READ_DEST=-9999_8 READ_MNG=-9999 REQ_TO_ZONE=-9999 REQ_ID=-9999 IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = 6*(NB_Z+1) RETURN ENDIF MIN_SIZE_READ=min(max((1024_8*1024_8)/int(idKEEP(35),8), & SIZE_ZONE_SOLVE/3_8), & SIZE_ZONE_SOLVE) TMP_SIZE8=1_8 J=1 DO I=1,NB_Z-1 IDEB_SOLVE_Z(I)=TMP_SIZE8 POSFAC_SOLVE(I)=TMP_SIZE8 LRLUS_SOLVE(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_T(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_B(I)=0_8 SIZE_SOLVE_Z(I)=SIZE_ZONE_SOLVE CURRENT_POS_T(I)=J CURRENT_POS_B(I)=J PDEB_SOLVE_Z(I)=J POS_HOLE_T(I)=J POS_HOLE_B(I)=J J=J+MAX_NB_NODES_FOR_ZONE TMP_SIZE8=TMP_SIZE8+SIZE_ZONE_SOLVE ENDDO IDEB_SOLVE_Z(NB_Z)=TMP_SIZE8 PDEB_SOLVE_Z(NB_Z)=J POSFAC_SOLVE(NB_Z)=TMP_SIZE8 LRLUS_SOLVE(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_T(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_B(NB_Z)=0_8 SIZE_SOLVE_Z(NB_Z)=SIZE_SOLVE_EMM CURRENT_POS_T(NB_Z)=J CURRENT_POS_B(NB_Z)=J POS_HOLE_T(NB_Z)=J POS_HOLE_B(NB_Z)=J IO_REQ=-77777 REQ_ACT=0 OOC_STATE_NODE(1:KEEP_OOC(28))=NOT_IN_MEM IF(KEEP_OOC(38).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(38))), & KEEP_OOC(199) ) SPECIAL_ROOT_NODE=KEEP_OOC(38) ELSEIF(KEEP_OOC(20).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(20))), & KEEP_OOC(199) ) SPECIAL_ROOT_NODE=KEEP_OOC(20) ELSE MASTER_ROOT=-111111 SPECIAL_ROOT_NODE=-2222222 ENDIF IF ( KEEP_OOC(60).EQ.0 .AND. & ( & (KEEP_OOC(38).NE.0 .AND. idrootyes) & .OR. & (KEEP_OOC(20).NE.0 .AND. MYID_OOC.EQ.MASTER_ROOT)) & ) & THEN IS_ROOT_SPECIAL = .TRUE. ELSE IS_ROOT_SPECIAL = .FALSE. ENDIF NB_ZONE_REQ=0 SIZE_ZONE_REQ=0_8 CURRENT_SOLVE_READ_ZONE=0 NB_CALLED=0 NB_CALL=0 SOLVE_STEP=-9999 RETURN END SUBROUTINE ZMUMPS_OOC_INIT_SOLVE SUBROUTINE ZMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER I IERR=0 IF(NB_Z.GT.1)THEN IF(STRAT_IO_ASYNC)THEN DO I=1,NB_Z-1 CALL ZMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO ELSE CALL ZMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_INITIATE_READ_OPS SUBROUTINE ZMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER ZONE CALL ZMUMPS_SOLVE_SELECT_ZONE(ZONE) IERR=0 CALL ZMUMPS_SOLVE_ZONE_READ(ZONE,A,LA,PTRFAC,NSTEPS,IERR) RETURN END SUBROUTINE ZMUMPS_SUBMIT_READ_FOR_Z SUBROUTINE ZMUMPS_READ_SOLVE_BLOCK(DEST,INDICE,SIZE, & ZONE,PTRFAC,NSTEPS,POS_SEQ,NB_NODES,FLAG,IERR) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER ZONE,NSTEPS,FLAG,POS_SEQ,NB_NODES COMPLEX(kind=8) DEST INTEGER (8) :: INDICE, SIZE, PTRFAC(NSTEPS) INTEGER REQUEST,INODE,IERR INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=OOC_SOLVE_TYPE_FCT IERR=0 INODE=OOC_INODE_SEQUENCE(POS_SEQ,OOC_FCT_TYPE) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_READ_OOC_C(LOW_LEVEL_STRAT_IO, & DEST,SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(STRAT_IO_ASYNC)THEN CALL ZMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL ZMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL ZMUMPS_SOLVE_UPDATE_POINTERS(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF END SUBROUTINE ZMUMPS_READ_SOLVE_BLOCK SUBROUTINE ZMUMPS_SOLVE_UPDATE_POINTERS(REQUEST,PTRFAC, & NSTEPS) IMPLICIT NONE INTEGER NSTEPS,REQUEST INTEGER (8) :: PTRFAC(NSTEPS) INTEGER (8) :: LAST, POS_IN_S, J INTEGER ZONE INTEGER POS_REQ,I,TMP_NODE,POS_IN_MANAGE INTEGER (8) SIZE LOGICAL DONT_USE EXTERNAL MUMPS_TYPENODE,MUMPS_PROCNODE INTEGER MUMPS_TYPENODE,MUMPS_PROCNODE POS_REQ=mod(REQUEST,MAX_NB_REQ)+1 SIZE=SIZE_OF_READ(POS_REQ) I=FIRST_POS_IN_READ(POS_REQ) POS_IN_S=READ_DEST(POS_REQ) POS_IN_MANAGE=READ_MNG(POS_REQ) ZONE=REQ_TO_ZONE(POS_REQ) DONT_USE=.FALSE. J=0_8 DO WHILE((J.LT.SIZE).AND.(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))) TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) LAST=SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN I=I+1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(TMP_NODE)).NE.0).AND. & (INODE_TO_POS(STEP_OOC(TMP_NODE)).LT. & -((N_OOC+1)*NB_Z)))THEN DONT_USE= & (((MTYPE_OOC.EQ.1).AND.(KEEP_OOC(50).EQ.0).AND. & (SOLVE_STEP.EQ.1).AND. & ((MUMPS_TYPENODE(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & KEEP_OOC(199)).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),KEEP_OOC(199)).NE. & MYID_OOC))) & .OR. & ((MTYPE_OOC.NE.1).AND.(KEEP_OOC(50).EQ.0).AND. & (SOLVE_STEP.EQ.0).AND. & ((MUMPS_TYPENODE(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & KEEP_OOC(199)).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),KEEP_OOC(199)).NE. & MYID_OOC)))).OR. & (OOC_STATE_NODE(STEP_OOC(TMP_NODE)).EQ.ALREADY_USED) IF(DONT_USE)THEN PTRFAC(STEP_OOC(TMP_NODE))=-POS_IN_S ELSE PTRFAC(STEP_OOC(TMP_NODE))=POS_IN_S ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).LT. & IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Inernal error (42) in OOC ', & PTRFAC(STEP_OOC(TMP_NODE)),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).GT. & (IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)-1_8))THEN WRITE(*,*)MYID_OOC,': Inernal error (43) in OOC ' CALL MUMPS_ABORT() ENDIF IF(DONT_USE)THEN POS_IN_MEM(POS_IN_MANAGE)=-TMP_NODE INODE_TO_POS(STEP_OOC(TMP_NODE))=-POS_IN_MANAGE IF(OOC_STATE_NODE(STEP_OOC(TMP_NODE)).NE. & ALREADY_USED)THEN OOC_STATE_NODE(STEP_OOC(TMP_NODE))=USED_NOT_PERMUTED ENDIF LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+LAST ELSE POS_IN_MEM(POS_IN_MANAGE)=TMP_NODE INODE_TO_POS(STEP_OOC(TMP_NODE))=POS_IN_MANAGE OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED ENDIF IO_REQ(STEP_OOC(TMP_NODE))=-7777 ELSE POS_IN_MEM(POS_IN_MANAGE)=0 ENDIF POS_IN_S=POS_IN_S+LAST POS_IN_MANAGE=POS_IN_MANAGE+1 J=J+LAST I=I+1 ENDDO SIZE_OF_READ(POS_REQ)=-9999_8 FIRST_POS_IN_READ(POS_REQ)=-9999 READ_DEST(POS_REQ)=-9999_8 READ_MNG(POS_REQ)=-9999 REQ_TO_ZONE(POS_REQ)=-9999 REQ_ID(POS_REQ)=-9999 RETURN END SUBROUTINE ZMUMPS_SOLVE_UPDATE_POINTERS SUBROUTINE ZMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,DEST,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER INODE,ZONE,REQUEST,FLAG,POS_SEQ,NB_NODES,NSTEPS INTEGER(8) :: SIZE INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: DEST, LOCAL_DEST, J8 INTEGER I,TMP_NODE,LOC_I,POS_REQ,NB INTEGER(8)::LAST INTEGER, intent(out) :: IERR IERR=0 IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN RETURN ENDIF NB=0 LOCAL_DEST=DEST I=POS_SEQ POS_REQ=mod(REQUEST,MAX_NB_REQ)+1 IF(REQ_ID(POS_REQ).NE.-9999)THEN CALL MUMPS_WAIT_REQUEST(REQ_ID(POS_REQ),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF CALL ZMUMPS_SOLVE_UPDATE_POINTERS(REQUEST,PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF SIZE_OF_READ(POS_REQ)=SIZE FIRST_POS_IN_READ(POS_REQ)=I READ_DEST(POS_REQ)=DEST IF(FLAG.EQ.0)THEN READ_MNG(POS_REQ)=CURRENT_POS_B(ZONE)-NB_NODES+1 ELSEIF(FLAG.EQ.1)THEN READ_MNG(POS_REQ)=CURRENT_POS_T(ZONE) ENDIF REQ_TO_ZONE(POS_REQ)=ZONE REQ_ID(POS_REQ)=REQUEST J8=0_8 IF(FLAG.EQ.0)THEN LOC_I=CURRENT_POS_B(ZONE)-NB_NODES+1 ENDIF DO WHILE((J8.LT.SIZE).AND.(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))) TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) LAST=SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I+1 CYCLE ENDIF IF((IO_REQ(STEP_OOC(TMP_NODE)).GE.0).OR. & (INODE_TO_POS(STEP_OOC(TMP_NODE)).NE.0))THEN IF(FLAG.EQ.1)THEN POS_IN_MEM(CURRENT_POS_T(ZONE))=0 ELSEIF(FLAG.EQ.0)THEN POS_IN_MEM(CURRENT_POS_B(ZONE))=0 ENDIF ELSE IO_REQ(STEP_OOC(TMP_NODE))=REQUEST LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)-LAST IF(FLAG.EQ.1)THEN IF(POSFAC_SOLVE(ZONE).EQ.IDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)+LAST LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)-LAST POS_IN_MEM(CURRENT_POS_T(ZONE))=-TMP_NODE- & ((N_OOC+1)*NB_Z) INODE_TO_POS(STEP_OOC(TMP_NODE))=-CURRENT_POS_T(ZONE)- & ((N_OOC+1)*NB_Z) OOC_STATE_NODE(STEP_OOC(TMP_NODE))=BEING_READ PTRFAC(STEP_OOC(TMP_NODE))=-LOCAL_DEST LOCAL_DEST=LOCAL_DEST+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(FLAG.EQ.0)THEN LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)-LAST POS_IN_MEM(LOC_I)=-TMP_NODE-((N_OOC+1)*NB_Z) IF(LOC_I.EQ.POS_HOLE_T(ZONE))THEN IF(POS_HOLE_T(ZONE).LT.CURRENT_POS_T(ZONE))THEN POS_HOLE_T(ZONE)=POS_HOLE_T(ZONE)+1 ENDIF ENDIF INODE_TO_POS(STEP_OOC(TMP_NODE))=-LOC_I-((N_OOC+1)*NB_Z) OOC_STATE_NODE(STEP_OOC(TMP_NODE))=BEING_READ PTRFAC(STEP_OOC(TMP_NODE))=-LOCAL_DEST LOCAL_DEST=LOCAL_DEST+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSE WRITE(*,*)MYID_OOC,': Internal error (39) in OOC ', & ' Invalid Flag Value in ', & ' ZMUMPS_UPDATE_READ_REQ_NODE',FLAG CALL MUMPS_ABORT() ENDIF ENDIF IF(POS_IN_MEM(CURRENT_POS_T(ZONE)).NE.0)THEN IF(POS_IN_MEM(CURRENT_POS_T(ZONE)).EQ. & POS_IN_MEM(PDEB_SOLVE_Z(ZONE)))THEN IF(CURRENT_POS_T(ZONE).NE.PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (40) in OOC ', & CURRENT_POS_T(ZONE), & PDEB_SOLVE_Z(ZONE), & POS_IN_MEM(CURRENT_POS_T(ZONE)), & POS_IN_MEM(PDEB_SOLVE_Z(ZONE)) CALL MUMPS_ABORT() ENDIF ENDIF ENDIF J8=J8+LAST IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (41) in OOC ', & ' LRLUS_SOLVE must be (1) > 0', & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF I=I+1 IF(FLAG.EQ.1)THEN CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)+1 IF(CURRENT_POS_T(ZONE).GT. & MAX_NB_NODES_FOR_ZONE+PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (1) in OOC ' CALL MUMPS_ABORT() ENDIF POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) ELSEIF(FLAG.EQ.0)THEN IF(POS_HOLE_B(ZONE).LT.PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (2) in OOC ', & POS_HOLE_B(ZONE),LOC_I CALL MUMPS_ABORT() ENDIF CURRENT_POS_B(ZONE)=CURRENT_POS_B(ZONE)-1 POS_HOLE_B(ZONE)=CURRENT_POS_B(ZONE) IF(POS_HOLE_B(ZONE).LT.PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF ELSE WRITE(*,*)MYID_OOC,': Internal error (3) in OOC ', & ' Invalid Flag Value in ', & ' ZMUMPS_UPDATE_READ_REQ_NODE',FLAG CALL MUMPS_ABORT() ENDIF IF(FLAG.EQ.0)THEN LOC_I=LOC_I+1 ENDIF NB=NB+1 ENDDO IF(NB.NE.NB_NODES)THEN WRITE(*,*)MYID_OOC,': Internal error (4) in OOC ', & ' ZMUMPS_UPDATE_READ_REQ_NODE ',NB,NB_NODES ENDIF IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=I ELSE CUR_POS_SEQUENCE=POS_SEQ-1 ENDIF RETURN END SUBROUTINE ZMUMPS_UPDATE_READ_REQ_NODE SUBROUTINE ZMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,NSTEPS,A, & LA,FLAG,IERR) IMPLICIT NONE INTEGER(8) :: LA INTEGER, intent(out):: IERR COMPLEX(kind=8) A(LA) INTEGER INODE,NSTEPS INTEGER(8) :: PTRFAC(NSTEPS) LOGICAL FLAG INTEGER(8) FREE_SIZE INTEGER TMP,TMP_NODE,I,ZONE,J INTEGER WHICH INTEGER(8) :: DUMMY_SIZE DUMMY_SIZE=1_8 IERR = 0 WHICH=-1 IF(INODE_TO_POS(STEP_OOC(INODE)).LE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (5) in OOC ', & ' Problem in ZMUMPS_FREE_FACTORS_FOR_SOLVE', & INODE, STEP_OOC(INODE), INODE_TO_POS(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE).EQ.0_8)THEN INODE_TO_POS(STEP_OOC(INODE))=0 OOC_STATE_NODE(STEP_OOC(INODE))=ALREADY_USED RETURN ENDIF CALL ZMUMPS_SOLVE_FIND_ZONE(INODE,ZONE,PTRFAC,NSTEPS) TMP=INODE_TO_POS(STEP_OOC(INODE)) INODE_TO_POS(STEP_OOC(INODE))=-TMP POS_IN_MEM(TMP)=-INODE PTRFAC(STEP_OOC(INODE))=-PTRFAC(STEP_OOC(INODE)) IF (KEEP_OOC(237).eq.0) THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).NE.PERMUTED)THEN WRITE(*,*)MYID_OOC,': INTERNAL ERROR (53) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF ENDIF OOC_STATE_NODE(STEP_OOC(INODE))=USED LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (6) in OOC ', & ': LRLUS_SOLVE must be (2) > 0' CALL MUMPS_ABORT() ENDIF IF(ZONE.EQ.NB_Z)THEN IF(INODE.NE.SPECIAL_ROOT_NODE)THEN CALL ZMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & DUMMY_SIZE,PTRFAC,KEEP_OOC(28),ZONE,IERR) ENDIF ELSE IF(SOLVE_STEP.EQ.0)THEN IF(TMP.GT.POS_HOLE_B(ZONE))THEN WHICH=0 ELSEIF(TMP.LT.POS_HOLE_T(ZONE))THEN WHICH=1 ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(TMP.LT.POS_HOLE_T(ZONE))THEN WHICH=1 ELSEIF(TMP.GT.POS_HOLE_B(ZONE))THEN WHICH=0 ENDIF ENDIF IF(WHICH.EQ.1)THEN J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_T(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE=0_8 DO I=J,TMP,-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN GOTO 666 ENDIF ENDDO POS_HOLE_T(ZONE)=TMP 666 CONTINUE ELSEIF(WHICH.EQ.0)THEN J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_B(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE=0_8 DO I=J,TMP IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN IF(J.EQ.PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 CURRENT_POS_B(ZONE)=-9999 ENDIF GOTO 777 ENDIF ENDDO POS_HOLE_B(ZONE)=TMP 777 CONTINUE ENDIF IERR=0 ENDIF IF((NB_Z.GT.1).AND.FLAG)THEN CALL ZMUMPS_SOLVE_TRY_ZONE_FOR_READ(ZONE) IF((LRLUS_SOLVE(ZONE).GE.MIN_SIZE_READ).OR. & (LRLUS_SOLVE(ZONE).GE. & int(0.3D0*dble(SIZE_SOLVE_Z(ZONE)),8)))THEN CALL ZMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL ZMUMPS_SOLVE_SELECT_ZONE(ZONE) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_FREE_FACTORS_FOR_SOLVE FUNCTION ZMUMPS_SOLVE_IS_INODE_IN_MEM(INODE,PTRFAC,NSTEPS,A,LA, & IERR) IMPLICIT NONE INTEGER INODE,NSTEPS INTEGER(8) :: LA INTEGER, INTENT(out)::IERR COMPLEX(kind=8) A(LA) INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZMUMPS_SOLVE_IS_INODE_IN_MEM IERR=0 IF(INODE_TO_POS(STEP_OOC(INODE)).GT.0)THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN ZMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_PERMUTED ELSE ZMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_PERMUTED ENDIF IF(.NOT.ZMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE) & .EQ.INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL ZMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF ELSEIF(INODE_TO_POS(STEP_OOC(INODE)).LT.0)THEN IF(INODE_TO_POS(STEP_OOC(INODE)).LT.-((N_OOC+1)*NB_Z))THEN CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(INODE)),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': Internal error (7) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF CALL ZMUMPS_SOLVE_UPDATE_POINTERS(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ELSE CALL ZMUMPS_SOLVE_UPD_NODE_INFO(INODE,PTRFAC,NSTEPS) IF(.NOT.ZMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE).EQ. & INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL ZMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF ENDIF IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN ZMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_PERMUTED ELSE ZMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_PERMUTED ENDIF ELSE ZMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_IN_MEM ENDIF RETURN END FUNCTION ZMUMPS_SOLVE_IS_INODE_IN_MEM SUBROUTINE ZMUMPS_SOLVE_MODIFY_STATE_NODE(INODE) IMPLICIT NONE INTEGER INODE IF ( (KEEP_OOC(237).EQ.0) & .AND. (KEEP_OOC(235).EQ.0) & .AND. (KEEP_OOC(212).EQ.0) & ) THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).NE.NOT_USED)THEN WRITE(*,*)MYID_OOC,': INTERNAL ERROR (51) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF ENDIF OOC_STATE_NODE(STEP_OOC(INODE))=PERMUTED END SUBROUTINE ZMUMPS_SOLVE_MODIFY_STATE_NODE SUBROUTINE ZMUMPS_SOLVE_UPD_NODE_INFO(INODE,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER INODE,NSTEPS INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZONE INODE_TO_POS(STEP_OOC(INODE))=-INODE_TO_POS(STEP_OOC(INODE)) POS_IN_MEM(INODE_TO_POS(STEP_OOC(INODE)))= & -POS_IN_MEM(INODE_TO_POS(STEP_OOC(INODE))) PTRFAC(STEP_OOC(INODE))=-PTRFAC(STEP_OOC(INODE)) IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.USED_NOT_PERMUTED)THEN OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED ELSEIF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.USED)THEN OOC_STATE_NODE(STEP_OOC(INODE))=PERMUTED ELSE WRITE(*,*)MYID_OOC,': Internal error (52) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)), & INODE_TO_POS(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_SEARCH_SOLVE(PTRFAC(STEP_OOC(INODE)),ZONE) IF(INODE_TO_POS(STEP_OOC(INODE)).LE.POS_HOLE_B(ZONE))THEN IF(INODE_TO_POS(STEP_OOC(INODE)).GT. & PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)= & INODE_TO_POS(STEP_OOC(INODE))-1 ELSE CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF ENDIF IF(INODE_TO_POS(STEP_OOC(INODE)).GE.POS_HOLE_T(ZONE))THEN IF(INODE_TO_POS(STEP_OOC(INODE)).LT. & CURRENT_POS_T(ZONE)-1)THEN POS_HOLE_T(ZONE)=INODE_TO_POS(STEP_OOC(INODE))+1 ELSE POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) ENDIF ENDIF CALL ZMUMPS_OOC_UPDATE_SOLVE_STAT(INODE,PTRFAC,NSTEPS,1) END SUBROUTINE ZMUMPS_SOLVE_UPD_NODE_INFO SUBROUTINE ZMUMPS_SOLVE_FIND_ZONE(INODE,ZONE,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER INODE,ZONE,NSTEPS INTEGER (8) :: PTRFAC(NSTEPS) ZONE=1 DO WHILE (ZONE.LE.NB_Z) IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN ZONE=ZONE-1 EXIT ENDIF ZONE=ZONE+1 ENDDO IF(ZONE.EQ.NB_Z+1)THEN ZONE=ZONE-1 ENDIF END SUBROUTINE ZMUMPS_SOLVE_FIND_ZONE SUBROUTINE ZMUMPS_SOLVE_TRY_ZONE_FOR_READ(ZONE) IMPLICIT NONE INTEGER ZONE ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1)+1 END SUBROUTINE ZMUMPS_SOLVE_TRY_ZONE_FOR_READ SUBROUTINE ZMUMPS_SOLVE_SELECT_ZONE(ZONE) IMPLICIT NONE INTEGER ZONE IF(NB_Z.GT.1)THEN CURRENT_SOLVE_READ_ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1) ZONE=CURRENT_SOLVE_READ_ZONE+1 ELSE ZONE=NB_Z ENDIF END SUBROUTINE ZMUMPS_SOLVE_SELECT_ZONE SUBROUTINE ZMUMPS_SOLVE_ALLOC_FACTOR_SPACE(INODE,PTRFAC, & KEEP,KEEP8, & A,IERR) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER, intent(out)::IERR INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX(kind=8) A(FACT_AREA_SIZE) INTEGER(8) :: REQUESTED_SIZE INTEGER ZONE,IFLAG IERR=0 IFLAG=0 IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) & .EQ.0_8)THEN INODE_TO_POS(STEP_OOC(INODE))=1 OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED PTRFAC(STEP_OOC(INODE))=1_8 RETURN ENDIF REQUESTED_SIZE=SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ZONE=NB_Z IF(CURRENT_POS_T(ZONE).GT. & (PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1))THEN CALL ZMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF((LRLU_SOLVE_T(ZONE).GT.SIZE_OF_BLOCK(STEP_OOC(INODE), & OOC_FCT_TYPE)).AND. & (CURRENT_POS_T(ZONE).LE. & (PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1)))THEN CALL ZMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(LRLU_SOLVE_B(ZONE).GT.SIZE_OF_BLOCK(STEP_OOC(INODE), & OOC_FCT_TYPE).AND. & (CURRENT_POS_B(ZONE).GT.0))THEN CALL ZMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSE IF(ZMUMPS_IS_THERE_FREE_SPACE(INODE,ZONE))THEN IF(SOLVE_STEP.EQ.0)THEN CALL ZMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL ZMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL ZMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL ZMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ELSE CALL ZMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL ZMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL ZMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL ZMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ENDIF IF(IFLAG.EQ.0)THEN CALL ZMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL ZMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ELSE WRITE(*,*)MYID_OOC,': Internal error (8) in OOC ', & ' Not enough space for Solve',INODE, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE), & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF ENDIF IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (9) in OOC ', & ' LRLUS_SOLVE must be (3) > 0' CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE ZMUMPS_SOLVE_ALLOC_FACTOR_SPACE SUBROUTINE ZMUMPS_GET_TOP_AREA_SPACE(A,LA,REQUESTED_SIZE,PTRFAC, & NSTEPS,ZONE,FLAG,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE,FLAG INTEGER(8) :: REQUESTED_SIZE, LA INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: FREE_SIZE, FREE_HOLE, FREE_HOLE_POS COMPLEX(kind=8) A(LA) INTEGER I,TMP_NODE,FREE_HOLE_FLAG, J INTEGER, intent(out)::IERR IERR=0 FLAG=0 IF(LRLU_SOLVE_T(ZONE).EQ.SIZE_SOLVE_Z(ZONE).AND. & (.NOT.(CURRENT_POS_T(ZONE) & .GT.PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1)))THEN GOTO 50 ENDIF J=max(POS_HOLE_B(ZONE),PDEB_SOLVE_Z(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) DO I=POS_HOLE_T(ZONE)-1,J,-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) ELSEIF(POS_IN_MEM(I).NE.0)THEN EXIT ENDIF ENDDO POS_HOLE_T(ZONE)=I+1 IF((POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE)).OR. & (POS_HOLE_T(ZONE).LE.POS_HOLE_B(ZONE)).OR. & (POS_HOLE_T(ZONE).EQ.POS_HOLE_B(ZONE)+1))THEN CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_T(ZONE)=PDEB_SOLVE_Z(ZONE) ENDIF FREE_HOLE=0_8 FREE_SIZE=0_8 FREE_HOLE_FLAG=0 FREE_HOLE_POS=POSFAC_SOLVE(ZONE) DO I=CURRENT_POS_T(ZONE)-1,POS_HOLE_T(ZONE),-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) FREE_HOLE_FLAG=0 FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE))) PTRFAC(STEP_OOC(TMP_NODE))=-777777_8 INODE_TO_POS(STEP_OOC(TMP_NODE))=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED POS_IN_MEM(I)=0 FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).EQ.0)THEN FREE_HOLE_FLAG=1 ELSEIF(POS_IN_MEM(I).NE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (10) in OOC ', & ' ZMUMPS_GET_TOP_AREA_SPACE', & CURRENT_POS_T(ZONE)-1,POS_HOLE_T(ZONE),I CALL MUMPS_ABORT() ENDIF ENDDO IF(POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE))THEN IF(FREE_HOLE_FLAG.EQ.0)THEN FREE_HOLE_FLAG=1 ENDIF ENDIF IF(FREE_HOLE_FLAG.EQ.1)THEN IF(POS_HOLE_T(ZONE)-1.GT.PDEB_SOLVE_Z(ZONE))THEN I=POS_HOLE_T(ZONE)-1 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.(N_OOC+1)*NB_Z)THEN TMP_NODE=TMP_NODE-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (11) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL ZMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSEIF(TMP_NODE.EQ.0)THEN DO J=I,PDEB_SOLVE_Z(ZONE),-1 IF(POS_IN_MEM(J).NE.0) EXIT ENDDO IF(POS_IN_MEM(J).LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (12) in OOC ', & ' ZMUMPS_GET_TOP_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF(J.GE.PDEB_SOLVE_Z(ZONE))THEN TMP_NODE=POS_IN_MEM(J) FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE FREE_HOLE=FREE_HOLE_POS-IDEB_SOLVE_Z(ZONE) ENDIF ELSEIF(TMP_NODE.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (13) in OOC', & ' ZMUMPS_GET_TOP_AREA_SPACE' CALL MUMPS_ABORT() ELSE FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ENDIF ELSE FREE_HOLE=FREE_HOLE_POS-IDEB_SOLVE_Z(ZONE) ENDIF FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF CURRENT_POS_T(ZONE)=POS_HOLE_T(ZONE) LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)+FREE_SIZE POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)-FREE_SIZE 50 CONTINUE IF(REQUESTED_SIZE.LE.LRLU_SOLVE_T(ZONE))THEN FLAG=1 ELSE FLAG=0 ENDIF RETURN END SUBROUTINE ZMUMPS_GET_TOP_AREA_SPACE SUBROUTINE ZMUMPS_GET_BOTTOM_AREA_SPACE(A,LA,REQUESTED_SIZE, & PTRFAC,NSTEPS,ZONE,FLAG,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE,FLAG INTEGER (8) :: REQUESTED_SIZE INTEGER (8) :: LA INTEGER (8) :: PTRFAC(NSTEPS) COMPLEX(kind=8) A(LA) INTEGER(8) :: FREE_SIZE, FREE_HOLE_POS, FREE_HOLE INTEGER I,J,TMP_NODE,FREE_HOLE_FLAG INTEGER, intent(out) :: IERR IERR=0 FLAG=0 IF(LRLU_SOLVE_B(ZONE).EQ.SIZE_SOLVE_Z(ZONE))THEN GOTO 50 ENDIF IF(POS_HOLE_B(ZONE).EQ.-9999)THEN GOTO 50 ENDIF J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_T(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE = 0_8 DO I=POS_HOLE_B(ZONE)+1,J IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN EXIT ENDIF ENDDO POS_HOLE_B(ZONE)=I-1 IF((POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE)).OR. & (POS_HOLE_T(ZONE).LE.POS_HOLE_B(ZONE)).OR. & (POS_HOLE_T(ZONE).EQ.POS_HOLE_B(ZONE)+1))THEN CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_T(ZONE)=PDEB_SOLVE_Z(ZONE) ENDIF FREE_HOLE=0_8 FREE_SIZE=0_8 FREE_HOLE_FLAG=0 FREE_HOLE_POS=IDEB_SOLVE_Z(ZONE) IF(POS_HOLE_B(ZONE).EQ.-9999)THEN GOTO 50 ENDIF DO I=PDEB_SOLVE_Z(ZONE),POS_HOLE_B(ZONE) IF((POS_IN_MEM(I).LE.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) IF(TMP_NODE.NE.0)THEN IF(I.EQ.PDEB_SOLVE_Z(ZONE))THEN IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).NE. & IDEB_SOLVE_Z(ZONE))THEN FREE_SIZE=FREE_SIZE+abs(PTRFAC(STEP_OOC(TMP_NODE))) & -IDEB_SOLVE_Z(ZONE) ENDIF ENDIF IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(TMP_NODE))=-777777_8 INODE_TO_POS(STEP_OOC(TMP_NODE))=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSE FREE_HOLE_FLAG=1 ENDIF POS_IN_MEM(I)=0 ELSEIF(POS_IN_MEM(I).NE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (14) in OOC ', & ' ZMUMPS_GET_BOTTOM_AREA_SPACE', & CURRENT_POS_T(ZONE)-1,POS_HOLE_B(ZONE),I,POS_IN_MEM(I) CALL MUMPS_ABORT() ENDIF ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN IF(POS_HOLE_B(ZONE)+1.LT.CURRENT_POS_T(ZONE)-1)THEN I=POS_HOLE_B(ZONE)+1 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.(N_OOC+1)*NB_Z)THEN TMP_NODE=TMP_NODE-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (15) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL ZMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))-FREE_HOLE_POS ELSEIF(TMP_NODE.EQ.0)THEN DO J=I,CURRENT_POS_T(ZONE)-1 IF(POS_IN_MEM(J).NE.0) EXIT ENDDO IF(POS_IN_MEM(J).LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (16) in OOC ', & ' ZMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF(J.LE.CURRENT_POS_T(ZONE)-1)THEN TMP_NODE=POS_IN_MEM(J) FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS ELSE FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS ENDIF ELSEIF(TMP_NODE.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (17) in OOC ', & ' ZMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ELSE FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS ENDIF ELSE FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS ENDIF FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF LRLU_SOLVE_B(ZONE)=FREE_SIZE IF(POS_HOLE_B(ZONE).LT.CURRENT_POS_T(ZONE)-1)THEN TMP_NODE=POS_IN_MEM(POS_HOLE_B(ZONE)+1) IF(TMP_NODE.LT.-(N_OOC+1)*NB_Z)THEN TMP_NODE=abs(TMP_NODE)-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (18) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL ZMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) ENDIF LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)+ & (abs(PTRFAC(STEP_OOC(abs(TMP_NODE))))-IDEB_SOLVE_Z(ZONE)- & LRLU_SOLVE_B(ZONE)) ENDIF CURRENT_POS_B(ZONE)=POS_HOLE_B(ZONE) 50 CONTINUE IF((POS_HOLE_B(ZONE).EQ.-9999).AND. & (LRLU_SOLVE_B(ZONE).NE.0_8))THEN WRITE(*,*)MYID_OOC,': Internal error (19) in OOC ', & 'ZMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF((REQUESTED_SIZE.LE.LRLU_SOLVE_B(ZONE)).AND. & (POS_HOLE_B(ZONE).NE.-9999))THEN FLAG=1 ELSE FLAG=0 ENDIF END SUBROUTINE ZMUMPS_GET_BOTTOM_AREA_SPACE SUBROUTINE ZMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8, A,ZONE) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX(kind=8) A(FACT_AREA_SIZE) INTEGER ZONE LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(INODE))=POSFAC_SOLVE(ZONE) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED IF(POSFAC_SOLVE(ZONE).EQ.IDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (20) in OOC ', & ' Problem avec debut (2)',INODE, & PTRFAC(STEP_OOC(INODE)),IDEB_SOLVE_Z(ZONE),ZONE CALL MUMPS_ABORT() ENDIF INODE_TO_POS(STEP_OOC(INODE))=CURRENT_POS_T(ZONE) POS_IN_MEM(CURRENT_POS_T(ZONE))=INODE IF(CURRENT_POS_T(ZONE).GT.(PDEB_SOLVE_Z(ZONE)+ & MAX_NB_NODES_FOR_ZONE-1))THEN WRITE(*,*)MYID_OOC,': Internal error (21) in OOC ', & ' Problem with CURRENT_POS_T', & CURRENT_POS_T(ZONE),ZONE CALL MUMPS_ABORT() ENDIF CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)+1 POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) END SUBROUTINE ZMUMPS_SOLVE_ALLOC_PTR_UPD_T SUBROUTINE ZMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8, & A,ZONE) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX(kind=8) A(FACT_AREA_SIZE) INTEGER ZONE IF(POS_HOLE_B(ZONE).EQ.-9999)THEN WRITE(*,*)MYID_OOC,': Internal error (22) in OOC ', & ' ZMUMPS_SOLVE_ALLOC_PTR_UPD_B' CALL MUMPS_ABORT() ENDIF LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(INODE))=IDEB_SOLVE_Z(ZONE)+ & LRLU_SOLVE_B(ZONE) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (23) in OOC ', & PTRFAC(STEP_OOC(INODE)),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF INODE_TO_POS(STEP_OOC(INODE))=CURRENT_POS_B(ZONE) IF(CURRENT_POS_B(ZONE).EQ.0)THEN WRITE(*,*)MYID_OOC,': Internal error (23b) in OOC ' CALL MUMPS_ABORT() ENDIF POS_IN_MEM(CURRENT_POS_B(ZONE))=INODE CURRENT_POS_B(ZONE)=CURRENT_POS_B(ZONE)-1 POS_HOLE_B(ZONE)=CURRENT_POS_B(ZONE) END SUBROUTINE ZMUMPS_SOLVE_ALLOC_PTR_UPD_B SUBROUTINE ZMUMPS_FREE_SPACE_FOR_SOLVE(A,LA,REQUESTED_SIZE,PTRFAC, & NSTEPS,ZONE,IERR) IMPLICIT NONE INTEGER(8) :: LA, REQUESTED_SIZE INTEGER NSTEPS,ZONE INTEGER, intent(out) :: IERR INTEGER(8) :: PTRFAC(NSTEPS) COMPLEX(kind=8) A(LA) INTEGER (8) :: APOS_FIRST_FREE, & SIZE_HOLE, & FREE_HOLE, & FREE_HOLE_POS INTEGER J,I,TMP_NODE, NB_FREE, IPOS_FIRST_FREE INTEGER(8) :: K8, AREA_POINTER INTEGER FREE_HOLE_FLAG IERR=0 IF(LRLU_SOLVE_T(ZONE).EQ.SIZE_SOLVE_Z(ZONE))THEN RETURN ENDIF AREA_POINTER=IDEB_SOLVE_Z(ZONE) SIZE_HOLE=0_8 DO I=PDEB_SOLVE_Z(ZONE),CURRENT_POS_T(ZONE)-1 IF((POS_IN_MEM(I).LE.0).AND. & (POS_IN_MEM(I).GT.-((N_OOC+1)*NB_Z))) GOTO 666 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.((N_OOC+1)*NB_Z))THEN TMP_NODE=TMP_NODE-((N_OOC+1)*NB_Z) ENDIF AREA_POINTER=AREA_POINTER+ & abs(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ENDDO 666 CONTINUE IF((I.EQ.CURRENT_POS_T(ZONE)-1).AND. & (PDEB_SOLVE_Z(ZONE).NE.CURRENT_POS_T(ZONE)-1))THEN IF((POS_IN_MEM(I).GT.0).OR. & (POS_IN_MEM(I).LT.-((N_OOC+1)*NB_Z)))THEN WRITE(*,*)MYID_OOC,': Internal error (25) in OOC ', & ': There are no free blocks ', & 'in ZMUMPS_FREE_SPACE_FOR_SOLVE',PDEB_SOLVE_Z(ZONE), & CURRENT_POS_T(ZONE) CALL MUMPS_ABORT() ENDIF ENDIF IF(POS_IN_MEM(I).EQ.0)THEN APOS_FIRST_FREE=AREA_POINTER FREE_HOLE_POS=AREA_POINTER ELSE TMP_NODE=abs(POS_IN_MEM(I)) APOS_FIRST_FREE=abs(PTRFAC(STEP_OOC(TMP_NODE))) ENDIF IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).NE.0)THEN IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=abs(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)))- & ((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL ZMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) ELSE TMP_NODE=abs(POS_IN_MEM(PDEB_SOLVE_Z(ZONE))) ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).NE.IDEB_SOLVE_Z(ZONE))THEN IF((POS_IN_MEM(I).NE.0).OR.(I.EQ.CURRENT_POS_T(ZONE)))THEN SIZE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & IDEB_SOLVE_Z(ZONE) ENDIF APOS_FIRST_FREE=IDEB_SOLVE_Z(ZONE) IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).GT.0)THEN DO J=PDEB_SOLVE_Z(ZONE),I-1 TMP_NODE=POS_IN_MEM(J) IF(TMP_NODE.LE.0)THEN IF(TMP_NODE.LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=abs(POS_IN_MEM(J))-((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST( & IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL ZMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=POS_IN_MEM(J) ELSE WRITE(*,*)MYID_OOC,': Internal error (26) in OOC ', & ' ZMUMPS_FREE_SPACE_FOR_SOLVE',TMP_NODE, & J,I-1,(N_OOC+1)*NB_Z CALL MUMPS_ABORT() ENDIF ENDIF DO K8=1_8, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) A(APOS_FIRST_FREE+K8-1_8)= & A(PTRFAC(STEP_OOC(TMP_NODE))+K8-1_8) ENDDO PTRFAC(STEP_OOC(TMP_NODE))=APOS_FIRST_FREE APOS_FIRST_FREE=APOS_FIRST_FREE+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) ENDDO ENDIF ENDIF ENDIF NB_FREE=0 FREE_HOLE=0_8 FREE_HOLE_FLAG=0 DO J=I,CURRENT_POS_T(ZONE)-1 TMP_NODE=abs(POS_IN_MEM(J)) IF(POS_IN_MEM(J).LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=TMP_NODE-((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL ZMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=abs(POS_IN_MEM(J)) ENDIF IF(POS_IN_MEM(J).GT.0)THEN DO K8=1_8,SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) A(APOS_FIRST_FREE+K8-1_8)= & A(PTRFAC(STEP_OOC(TMP_NODE))+K8-1_8) ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(TMP_NODE))=APOS_FIRST_FREE APOS_FIRST_FREE=APOS_FIRST_FREE+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(J).EQ.0)THEN FREE_HOLE_FLAG=1 NB_FREE=NB_FREE+1 ELSE NB_FREE=NB_FREE+1 IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) SIZE_HOLE=SIZE_HOLE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) PTRFAC(STEP_OOC(abs(POS_IN_MEM(J))))=-77777_8 ENDIF ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF IPOS_FIRST_FREE=I DO J=I,CURRENT_POS_T(ZONE)-1 IF(POS_IN_MEM(J).LT.0)THEN TMP_NODE=abs(POS_IN_MEM(J)) INODE_TO_POS(STEP_OOC(TMP_NODE))=0 POS_IN_MEM(J)=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED ELSEIF(POS_IN_MEM(J).GT.0)THEN TMP_NODE=abs(POS_IN_MEM(J)) POS_IN_MEM(IPOS_FIRST_FREE)=POS_IN_MEM(J) INODE_TO_POS(STEP_OOC(TMP_NODE))=IPOS_FIRST_FREE IPOS_FIRST_FREE=IPOS_FIRST_FREE+1 ENDIF ENDDO LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)+SIZE_HOLE POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)-SIZE_HOLE CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)-NB_FREE POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 IF(LRLU_SOLVE_T(ZONE).NE.LRLUS_SOLVE(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (27) in OOC ', & LRLU_SOLVE_T(ZONE), & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF LRLU_SOLVE_T(ZONE)=LRLUS_SOLVE(ZONE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (28) in OOC ', & ' LRLUS_SOLVE must be (4) > 0' CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (29) in OOC ', & POSFAC_SOLVE(ZONE),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).NE.(IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)- & LRLUS_SOLVE(ZONE)))THEN WRITE(*,*)MYID_OOC,': Internal error (30) in OOC ', & ' Problem avec debut POSFAC_SOLVE', & POSFAC_SOLVE(ZONE),(SIZE_SOLVE_Z(ZONE)- & LRLUS_SOLVE(ZONE))+IDEB_SOLVE_Z(ZONE),LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).GT. & (IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)-1_8))THEN WRITE(*,*)MYID_OOC,': Internal error (31) in OOC ', & POSFAC_SOLVE(ZONE),IDEB_SOLVE_Z(ZONE)+ & SIZE_SOLVE_Z(ZONE)-1_8 CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE ZMUMPS_FREE_SPACE_FOR_SOLVE SUBROUTINE ZMUMPS_OOC_UPDATE_SOLVE_STAT(INODE,PTRFAC,NSTEPS,FLAG) IMPLICIT NONE INTEGER INODE,NSTEPS,FLAG INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZONE IF((FLAG.LT.0).OR.(FLAG.GT.1))THEN WRITE(*,*)MYID_OOC,': Internal error (32) in OOC ', & ' ZMUMPS_OOC_UPDATE_SOLVE_STAT' CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_SEARCH_SOLVE(PTRFAC(STEP_OOC(INODE)),ZONE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (33) in OOC ', & ' LRLUS_SOLVE must be (5) ++ > 0' CALL MUMPS_ABORT() ENDIF IF(FLAG.EQ.0)THEN LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ELSE LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ENDIF IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (34) in OOC ', & ' LRLUS_SOLVE must be (5) > 0' CALL MUMPS_ABORT() ENDIF END SUBROUTINE ZMUMPS_OOC_UPDATE_SOLVE_STAT SUBROUTINE ZMUMPS_SEARCH_SOLVE(ADDR,ZONE) IMPLICIT NONE INTEGER (8) :: ADDR INTEGER ZONE INTEGER I I=1 DO WHILE (I.LE.NB_Z) IF(ADDR.LT.IDEB_SOLVE_Z(I))THEN EXIT ENDIF I=I+1 ENDDO ZONE=I-1 END SUBROUTINE ZMUMPS_SEARCH_SOLVE FUNCTION ZMUMPS_SOLVE_IS_END_REACHED() IMPLICIT NONE LOGICAL ZMUMPS_SOLVE_IS_END_REACHED ZMUMPS_SOLVE_IS_END_REACHED=.FALSE. IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN ZMUMPS_SOLVE_IS_END_REACHED=.TRUE. ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.LT.1)THEN ZMUMPS_SOLVE_IS_END_REACHED=.TRUE. ENDIF ENDIF RETURN END FUNCTION ZMUMPS_SOLVE_IS_END_REACHED SUBROUTINE ZMUMPS_SOLVE_ZONE_READ(ZONE,A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE INTEGER(8), INTENT(IN) :: LA INTEGER, intent(out) :: IERR COMPLEX(kind=8) A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: SIZE, DEST INTEGER(8) :: NEEDED_SIZE INTEGER FLAG,TMP_FLAG,POS_SEQ,TMP_NODE, & NB_NODES IERR=0 TMP_FLAG=0 FLAG=0 IF(ZMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE).GT. & SIZE_SOLVE_Z(ZONE)) CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 IF(ZMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL ZMUMPS_OOC_SKIP_NULL_SIZE_NODE() NEEDED_SIZE=max(MIN_SIZE_READ, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE NEEDED_SIZE=MIN_SIZE_READ ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.GE.1)THEN TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE).GT. & SIZE_SOLVE_Z(ZONE)) CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 IF(ZMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL ZMUMPS_OOC_SKIP_NULL_SIZE_NODE() NEEDED_SIZE=max(MIN_SIZE_READ, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE NEEDED_SIZE=MIN_SIZE_READ ENDIF ENDIF IF(LRLUS_SOLVE(ZONE).LT.NEEDED_SIZE)THEN RETURN ELSEIF((LRLU_SOLVE_T(ZONE).LT.NEEDED_SIZE).AND. & (LRLU_SOLVE_B(ZONE).LT.NEEDED_SIZE).AND. & (dble(LRLUS_SOLVE(ZONE)).LT.0.3d0* & dble(SIZE_SOLVE_Z(ZONE)))) THEN RETURN ENDIF IF((LRLU_SOLVE_T(ZONE).GT.NEEDED_SIZE).AND.(SOLVE_STEP.EQ.0).AND. & ((CURRENT_POS_T(ZONE)-PDEB_SOLVE_Z(ZONE)+1).LT. & MAX_NB_NODES_FOR_ZONE))THEN FLAG=1 ELSE IF(SOLVE_STEP.EQ.0)THEN CALL ZMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 IF(TMP_FLAG.EQ.0)THEN CALL ZMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=0 ENDIF ELSE CALL ZMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=0 IF(TMP_FLAG.EQ.0)THEN CALL ZMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF IF(TMP_FLAG.EQ.0)THEN CALL ZMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF CALL ZMUMPS_SOLVE_COMPUTE_READ_SIZE(ZONE,SIZE,DEST,POS_SEQ, & NB_NODES,FLAG,PTRFAC,NSTEPS) IF(SIZE.EQ.0_8)THEN RETURN ENDIF NB_ZONE_REQ=NB_ZONE_REQ+1 SIZE_ZONE_REQ=SIZE_ZONE_REQ+SIZE REQ_ACT=REQ_ACT+1 CALL ZMUMPS_READ_SOLVE_BLOCK(A(DEST),DEST,SIZE,ZONE,PTRFAC,NSTEPS, & POS_SEQ,NB_NODES,FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END SUBROUTINE ZMUMPS_SOLVE_ZONE_READ SUBROUTINE ZMUMPS_SOLVE_COMPUTE_READ_SIZE(ZONE,SIZE,DEST,POS_SEQ, & NB_NODES,FLAG,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER(8) :: SIZE, DEST INTEGER ZONE,FLAG,POS_SEQ,NSTEPS INTEGER(8) :: PTRFAC(NSTEPS), MAX_SIZE, LAST, J8 INTEGER I,START_NODE,K,MAX_NB, & NB_NODES INTEGER NB_NODES_LOC LOGICAL ALREADY IF(ZMUMPS_SOLVE_IS_END_REACHED())THEN SIZE=0_8 RETURN ENDIF IF(FLAG.EQ.0)THEN MAX_SIZE=LRLU_SOLVE_B(ZONE) MAX_NB=max(0,CURRENT_POS_B(ZONE)-PDEB_SOLVE_Z(ZONE)+1) ELSEIF(FLAG.EQ.1)THEN MAX_SIZE=LRLU_SOLVE_T(ZONE) MAX_NB=MAX_NB_NODES_FOR_ZONE ELSE WRITE(*,*)MYID_OOC,': Internal error (35) in OOC ', & ' Unknown Flag value in ', & ' ZMUMPS_SOLVE_COMPUTE_READ_SIZE',FLAG CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_OOC_SKIP_NULL_SIZE_NODE() I=CUR_POS_SEQUENCE START_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ALREADY=.FALSE. NB_NODES=0 NB_NODES_LOC=0 IF(ZONE.EQ.NB_Z)THEN SIZE=SIZE_OF_BLOCK(STEP_OOC(START_NODE),OOC_FCT_TYPE) ELSE J8=0_8 IF(FLAG.EQ.0)THEN K=0 ELSEIF(FLAG.EQ.1)THEN K=CURRENT_POS_T(ZONE)-PDEB_SOLVE_Z(ZONE)+1 ENDIF IF(SOLVE_STEP.EQ.0)THEN I=CUR_POS_SEQUENCE DO WHILE(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) IF(SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF I=I+1 ENDDO CUR_POS_SEQUENCE=min(I,TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) I=CUR_POS_SEQUENCE DO WHILE((J8.LE.MAX_SIZE).AND. & (I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)).AND. & (K.LT.MAX_NB) ) LAST=SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ENDIF I=I+1 NB_NODES_LOC=NB_NODES_LOC+1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))) & .NE.0).OR. & (IO_REQ(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))).GE. & 0))THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 I=I+1 CYCLE ELSE EXIT ENDIF ENDIF ALREADY=.TRUE. J8=J8+LAST I=I+1 K=K+1 NB_NODES_LOC=NB_NODES_LOC+1 NB_NODES=NB_NODES+1 ENDDO IF(J8.GT.MAX_SIZE)THEN SIZE=J8-LAST NB_NODES=NB_NODES-1 NB_NODES_LOC=NB_NODES_LOC-1 ELSE SIZE=J8 ENDIF DO WHILE (CUR_POS_SEQUENCE+NB_NODES_LOC-1.GE. & CUR_POS_SEQUENCE) IF(SIZE_OF_BLOCK(STEP_OOC( & OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE+NB_NODES-1, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF NB_NODES_LOC=NB_NODES_LOC-1 ENDDO POS_SEQ=CUR_POS_SEQUENCE ELSEIF(SOLVE_STEP.EQ.1)THEN DO WHILE(I.GE.1) IF(SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF I=I-1 ENDDO CUR_POS_SEQUENCE=max(I,1) I=CUR_POS_SEQUENCE DO WHILE((J8.LE.MAX_SIZE).AND.(I.GE.1).AND. & (K.LT.MAX_NB)) LAST=SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF NB_NODES_LOC=NB_NODES_LOC+1 I=I-1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))) & .NE.0).OR. & (IO_REQ(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))).GE. & 0))THEN IF(.NOT.ALREADY)THEN I=I-1 CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 CYCLE ELSE EXIT ENDIF ENDIF ALREADY=.TRUE. J8=J8+LAST I=I-1 K=K+1 NB_NODES=NB_NODES+1 NB_NODES_LOC=NB_NODES_LOC+1 ENDDO IF(J8.GT.MAX_SIZE)THEN SIZE=J8-LAST NB_NODES=NB_NODES-1 NB_NODES_LOC=NB_NODES_LOC-1 ELSE SIZE=J8 ENDIF I=CUR_POS_SEQUENCE-NB_NODES_LOC+1 DO WHILE (I.LE.CUR_POS_SEQUENCE) IF(SIZE_OF_BLOCK(STEP_OOC( & OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE)), & OOC_FCT_TYPE).NE.0_8)THEN EXIT ENDIF I=I+1 NB_NODES_LOC=NB_NODES_LOC-1 ENDDO POS_SEQ=CUR_POS_SEQUENCE-NB_NODES_LOC+1 ENDIF ENDIF IF(FLAG.EQ.0)THEN DEST=IDEB_SOLVE_Z(ZONE)+LRLU_SOLVE_B(ZONE)-SIZE ELSE DEST=POSFAC_SOLVE(ZONE) ENDIF END SUBROUTINE ZMUMPS_SOLVE_COMPUTE_READ_SIZE SUBROUTINE ZMUMPS_OOC_END_SOLVE(IERR) IMPLICIT NONE INTEGER SOLVE_OR_FACTO INTEGER, intent(out) :: IERR IERR=0 IF(allocated(LRLUS_SOLVE))THEN DEALLOCATE(LRLUS_SOLVE) ENDIF IF(allocated(LRLU_SOLVE_T))THEN DEALLOCATE(LRLU_SOLVE_T) ENDIF IF(allocated(LRLU_SOLVE_B))THEN DEALLOCATE(LRLU_SOLVE_B) ENDIF IF(allocated(POSFAC_SOLVE))THEN DEALLOCATE(POSFAC_SOLVE) ENDIF IF(allocated(IDEB_SOLVE_Z))THEN DEALLOCATE(IDEB_SOLVE_Z) ENDIF IF(allocated(PDEB_SOLVE_Z))THEN DEALLOCATE(PDEB_SOLVE_Z) ENDIF IF(allocated(SIZE_SOLVE_Z))THEN DEALLOCATE(SIZE_SOLVE_Z) ENDIF IF(allocated(CURRENT_POS_T))THEN DEALLOCATE(CURRENT_POS_T) ENDIF IF(allocated(CURRENT_POS_B))THEN DEALLOCATE(CURRENT_POS_B) ENDIF IF(allocated(POS_HOLE_T))THEN DEALLOCATE(POS_HOLE_T) ENDIF IF(allocated(POS_HOLE_B))THEN DEALLOCATE(POS_HOLE_B) ENDIF IF(allocated(OOC_STATE_NODE))THEN DEALLOCATE(OOC_STATE_NODE) ENDIF IF(allocated(POS_IN_MEM))THEN DEALLOCATE(POS_IN_MEM) ENDIF IF(allocated(INODE_TO_POS))THEN DEALLOCATE(INODE_TO_POS) ENDIF IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(allocated(SIZE_OF_READ))THEN DEALLOCATE(SIZE_OF_READ) ENDIF IF(allocated(FIRST_POS_IN_READ))THEN DEALLOCATE(FIRST_POS_IN_READ) ENDIF IF(allocated(READ_DEST))THEN DEALLOCATE(READ_DEST) ENDIF IF(allocated(READ_MNG))THEN DEALLOCATE(READ_MNG) ENDIF IF(allocated(REQ_TO_ZONE))THEN DEALLOCATE(REQ_TO_ZONE) ENDIF IF(allocated(REQ_ID))THEN DEALLOCATE(REQ_ID) ENDIF SOLVE_OR_FACTO=1 CALL MUMPS_CLEAN_IO_DATA_C(MYID_OOC,SOLVE_OR_FACTO,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF END SUBROUTINE ZMUMPS_OOC_END_SOLVE SUBROUTINE ZMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS, & A,LA) IMPLICIT NONE INTEGER, INTENT(in) :: NSTEPS INTEGER(8), INTENT(INOUT) :: PTRFAC(NSTEPS) INTEGER(8), INTENT(IN) :: LA COMPLEX(kind=8) :: A(LA) INTEGER :: I, TMP, ZONE, IPAS, IBEG, IEND INTEGER(8) :: SAVE_PTR LOGICAL :: COMPRESS_TO_BE_DONE, SET_POS_SEQUENCE INTEGER :: J, IERR INTEGER(8) :: DUMMY_SIZE COMPRESS_TO_BE_DONE = .FALSE. DUMMY_SIZE = 1_8 IERR = 0 SET_POS_SEQUENCE = .TRUE. IF(SOLVE_STEP.EQ.0)THEN IBEG = 1 IEND = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) IPAS = 1 ELSE IBEG = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) IEND = 1 IPAS = -1 ENDIF DO I=IBEG,IEND,IPAS J = OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) TMP=INODE_TO_POS(STEP_OOC(J)) IF(TMP.EQ.0)THEN IF (SET_POS_SEQUENCE) THEN SET_POS_SEQUENCE = .FALSE. CUR_POS_SEQUENCE = I ENDIF IF (KEEP_OOC(237).EQ.0 .AND. KEEP_OOC(235).EQ.0 & .AND. KEEP_OOC(212).EQ.0 ) THEN OOC_STATE_NODE(STEP_OOC(J)) = NOT_IN_MEM ENDIF CYCLE ELSE IF(TMP.LT.0)THEN IF(TMP.GT.-(N_OOC+1)*NB_Z)THEN SAVE_PTR=PTRFAC(STEP_OOC(J)) PTRFAC(STEP_OOC(J)) = abs(SAVE_PTR) CALL ZMUMPS_SOLVE_FIND_ZONE(J, & ZONE,PTRFAC,NSTEPS) PTRFAC(STEP_OOC(J)) = SAVE_PTR IF(ZONE.EQ.NB_Z)THEN IF(J.NE.SPECIAL_ROOT_NODE)THEN WRITE(*,*)MYID_OOC,': Internal error 6 ', & ' Node ', J, & ' is in status USED in the & emmergency buffer ' CALL MUMPS_ABORT() ENDIF ENDIF IF (KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0 & .OR. KEEP_OOC(212).NE.0 ) & THEN IF (OOC_STATE_NODE(STEP_OOC(J)).EQ.NOT_IN_MEM) THEN OOC_STATE_NODE(STEP_OOC(J)) = USED IF((SOLVE_STEP.NE.0).AND.(J.NE.SPECIAL_ROOT_NODE) & .AND.(ZONE.NE.NB_Z))THEN CALL ZMUMPS_SOLVE_UPD_NODE_INFO(J,PTRFAC,NSTEPS) ENDIF CYCLE ELSEIF(OOC_STATE_NODE(STEP_OOC(J)).EQ.USED) & THEN COMPRESS_TO_BE_DONE = .TRUE. ELSE WRITE(*,*)MYID_OOC,': Internal error Mila 4 ', & ' wrong node status :', OOC_STATE_NODE(STEP_OOC(J)), & ' on node ', J CALL MUMPS_ABORT() ENDIF ENDIF IF (KEEP_OOC(237).EQ.0 .AND. KEEP_OOC(235).EQ.0 & .AND. KEEP_OOC(212).EQ.0 ) THEN CALL ZMUMPS_SOLVE_UPD_NODE_INFO(J,PTRFAC,NSTEPS) ENDIF ENDIF ENDIF ENDDO IF (KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0 .OR. & KEEP_OOC(212).NE.0 ) & THEN IF (COMPRESS_TO_BE_DONE) THEN DO ZONE=1,NB_Z-1 CALL ZMUMPS_FREE_SPACE_FOR_SOLVE(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,ZONE,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error Mila 5 ', & ' IERR on return to ZMUMPS_FREE_SPACE_FOR_SOLVE =', & IERR CALL MUMPS_ABORT() ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SOLVE_PREPARE_PREF SUBROUTINE ZMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,NSTEPS,MTYPE, & A,LA,DOPREFETCH,IERR) IMPLICIT NONE INTEGER NSTEPS,MTYPE INTEGER, intent(out)::IERR INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER(8) :: PTRFAC(NSTEPS) LOGICAL DOPREFETCH INTEGER MUMPS_OOC_GET_FCT_TYPE EXTERNAL MUMPS_OOC_GET_FCT_TYPE IERR = 0 OOC_FCT_TYPE=MUMPS_OOC_GET_FCT_TYPE("F",MTYPE,KEEP_OOC(201), & KEEP_OOC(50)) OOC_SOLVE_TYPE_FCT = OOC_FCT_TYPE - 1 IF (KEEP_OOC(201).NE.1) THEN OOC_SOLVE_TYPE_FCT = FCT ENDIF SOLVE_STEP=0 CUR_POS_SEQUENCE=1 MTYPE_OOC=MTYPE IF ( KEEP_OOC(201).NE.1 & .OR. KEEP_OOC(50).NE.0 & ) THEN CALL ZMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS,A,LA) ELSE CALL ZMUMPS_SOLVE_STAT_REINIT_PANEL(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) ENDIF IF (DOPREFETCH) THEN CALL ZMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC, & KEEP_OOC(28),IERR) ELSE CUR_POS_SEQUENCE = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) ENDIF RETURN END SUBROUTINE ZMUMPS_SOLVE_INIT_OOC_FWD SUBROUTINE ZMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,NSTEPS,MTYPE, & I_WORKED_ON_ROOT,IROOT,A,LA,IERR) IMPLICIT NONE INTEGER NSTEPS INTEGER(8) :: LA INTEGER(8) :: PTRFAC(NSTEPS) INTEGER MTYPE INTEGER IROOT LOGICAL I_WORKED_ON_ROOT INTEGER, intent(out):: IERR COMPLEX(kind=8) A(LA) INTEGER(8) :: DUMMY_SIZE INTEGER ZONE INTEGER MUMPS_OOC_GET_FCT_TYPE EXTERNAL MUMPS_OOC_GET_FCT_TYPE IERR=0 OOC_FCT_TYPE=MUMPS_OOC_GET_FCT_TYPE("B",MTYPE,KEEP_OOC(201), & KEEP_OOC(50)) OOC_SOLVE_TYPE_FCT = OOC_FCT_TYPE - 1 IF (KEEP_OOC(201).NE.1) OOC_SOLVE_TYPE_FCT=FCT SOLVE_STEP=1 CUR_POS_SEQUENCE=TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) MTYPE_OOC=MTYPE IF ( KEEP_OOC(201).NE.1 & .OR. KEEP_OOC(50).NE.0 & ) THEN CALL ZMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS,A,LA) IF (I_WORKED_ON_ROOT.AND. $ ((IROOT.GT.0)))THEN IF(SIZE_OF_BLOCK(STEP_OOC(IROOT),OOC_FCT_TYPE).NE.0) THEN IF (.NOT.(KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0)) & THEN CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE ( IROOT, & PTRFAC, KEEP_OOC(28), A, LA,.FALSE.,IERR) IF (IERR .LT. 0) RETURN ENDIF CALL ZMUMPS_SOLVE_FIND_ZONE(IROOT, & ZONE,PTRFAC,NSTEPS) IF(ZONE.EQ.NB_Z)THEN DUMMY_SIZE=1_8 CALL ZMUMPS_FREE_SPACE_FOR_SOLVE(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,NB_Z,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error in & ZMUMPS_FREE_SPACE_FOR_SOLVE', & IERR CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ENDIF IF (NB_Z.GT.1) THEN CALL ZMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC, & KEEP_OOC(28),IERR) IF (IERR .LT. 0) RETURN ENDIF ELSE CALL ZMUMPS_SOLVE_STAT_REINIT_PANEL(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) CALL ZMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC,KEEP_OOC(28),IERR) IF (IERR .LT. 0 ) RETURN ENDIF RETURN END SUBROUTINE ZMUMPS_SOLVE_INIT_OOC_BWD SUBROUTINE ZMUMPS_STRUC_STORE_FILE_NAME(idOOC_NB_FILES, & idOOC_FILE_NAMES, idOOC_FILE_NAME_LENGTH, idINFO, IERR) IMPLICIT NONE INTEGER,DIMENSION(:), POINTER :: idOOC_NB_FILES CHARACTER,DIMENSION(:,:), POINTER :: idOOC_FILE_NAMES INTEGER,DIMENSION(:), POINTER :: idOOC_FILE_NAME_LENGTH INTEGER :: idINFO(2) INTEGER, intent(out) :: IERR INTEGER I,DIM,J,TMP,SIZE,K,I1 CHARACTER(len=1):: TMP_NAME(FILENAMELENGTH) 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) idOOC_NB_FILES(J)=I SIZE=SIZE+I ENDDO IF(associated(idOOC_FILE_NAMES))THEN DEALLOCATE(idOOC_FILE_NAMES) NULLIFY(idOOC_FILE_NAMES) ENDIF ALLOCATE(idOOC_FILE_NAMES(SIZE,FILENAMELENGTH),stat=IERR) IF (IERR .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'ZMUMPS_STRUC_STORE_FILE_NAME' ENDIF IERR=-1 IF(idINFO(1).GE.0)THEN idINFO(1) = -13 idINFO(2) = SIZE*FILENAMELENGTH RETURN ENDIF ENDIF IF(associated(idOOC_FILE_NAME_LENGTH))THEN DEALLOCATE(idOOC_FILE_NAME_LENGTH) NULLIFY(idOOC_FILE_NAME_LENGTH) ENDIF ALLOCATE(idOOC_FILE_NAME_LENGTH(SIZE),stat=IERR) IF (IERR .GT. 0) THEN IERR=-1 IF(idINFO(1).GE.0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) & 'PB allocation in ZMUMPS_STRUC_STORE_FILE_NAME' ENDIF idINFO(1) = -13 idINFO(2) = SIZE RETURN ENDIF ENDIF K=1 DO I1=1,OOC_NB_FILE_TYPE TMP=I1-1 DO I=1,idOOC_NB_FILES(I1) CALL MUMPS_OOC_GET_FILE_NAME_C(TMP,I,DIM,TMP_NAME(1)) DO J=1,DIM+1 idOOC_FILE_NAMES(K,J)=TMP_NAME(J) ENDDO idOOC_FILE_NAME_LENGTH(K)=DIM+1 K=K+1 ENDDO ENDDO RETURN END SUBROUTINE ZMUMPS_STRUC_STORE_FILE_NAME SUBROUTINE ZMUMPS_OOC_OPEN_FILES_FOR_SOLVE(idINFO, idOOC_NB_FILES, & idMYID, idKEEP, idOOC_FILE_NAME_LENGTH, & idOOC_FILE_NAMES) IMPLICIT NONE INTEGER :: idINFO(2), idMYID INTEGER, DIMENSION(:), POINTER :: idOOC_NB_FILES INTEGER, DIMENSION(:), POINTER :: idOOC_FILE_NAME_LENGTH CHARACTER,DIMENSION(:,:), POINTER :: idOOC_FILE_NAMES INTEGER :: idKEEP(500) CHARACTER(len=1):: TMP_NAME(FILENAMELENGTH) INTEGER I,I1,TMP,J,K,L,DIM,IERR INTEGER, DIMENSION(:),ALLOCATABLE :: NB_FILES ALLOCATE(NB_FILES(OOC_NB_FILE_TYPE),stat=IERR) IF (IERR .GT. 0) THEN IERR=-1 IF(idINFO(1).GE.0)THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) & 'PB allocation in ZMUMPS_OOC_OPEN_FILES_FOR_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF ENDIF IERR=0 NB_FILES=idOOC_NB_FILES I=idMYID K=idKEEP(35) L=mod(idKEEP(204),3) 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) idINFO(1)=IERR RETURN ENDIF CALL MUMPS_OOC_INIT_VARS_C(I,K,L,idKEEP(211),idKEEP(255),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) idINFO(1)=IERR RETURN ENDIF K=1 DO I1=1,OOC_NB_FILE_TYPE DO I=1,NB_FILES(I1) DIM=idOOC_FILE_NAME_LENGTH(K) DO J=1,DIM TMP_NAME(J)=idOOC_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) idINFO(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) idINFO(1)=IERR RETURN ENDIF DEALLOCATE(NB_FILES) RETURN END SUBROUTINE ZMUMPS_OOC_OPEN_FILES_FOR_SOLVE SUBROUTINE ZMUMPS_FORCE_WRITE_BUF(IERR) USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF CALL ZMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF (IERR < 0) THEN RETURN ENDIF RETURN END SUBROUTINE ZMUMPS_FORCE_WRITE_BUF SUBROUTINE ZMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR INTEGER I IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF DO I=1,OOC_NB_FILE_TYPE CALL ZMUMPS_OOC_DO_IO_AND_CHBUF(I,IERR) IF (IERR < 0) RETURN ENDDO RETURN END SUBROUTINE ZMUMPS_OOC_FORCE_WRT_BUF_PANEL SUBROUTINE ZMUMPS_SOLVE_STAT_REINIT_PANEL(NSTEPS, & KEEP38, KEEP20) IMPLICIT NONE INTEGER NSTEPS INTEGER I, J INTEGER(8) :: TMP_SIZE8 INTEGER KEEP38, KEEP20 INODE_TO_POS = 0 POS_IN_MEM = 0 OOC_STATE_NODE(1:NSTEPS)=0 TMP_SIZE8=1_8 J=1 DO I=1,NB_Z-1 IDEB_SOLVE_Z(I)=TMP_SIZE8 PDEB_SOLVE_Z(I)=J POSFAC_SOLVE(I)=TMP_SIZE8 LRLUS_SOLVE(I) =SIZE_ZONE_SOLVE LRLU_SOLVE_T(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_B(I)=0_8 SIZE_SOLVE_Z(I)=SIZE_ZONE_SOLVE CURRENT_POS_T(I)=J CURRENT_POS_B(I)=J POS_HOLE_T(I) =J POS_HOLE_B(I) =J J = J + MAX_NB_NODES_FOR_ZONE TMP_SIZE8 = TMP_SIZE8 + SIZE_ZONE_SOLVE ENDDO IDEB_SOLVE_Z(NB_Z)=TMP_SIZE8 PDEB_SOLVE_Z(NB_Z)=J POSFAC_SOLVE(NB_Z)=TMP_SIZE8 LRLUS_SOLVE(NB_Z) =SIZE_SOLVE_EMM LRLU_SOLVE_T(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_B(NB_Z)=0_8 SIZE_SOLVE_Z(NB_Z)=SIZE_SOLVE_EMM CURRENT_POS_T(NB_Z)=J CURRENT_POS_B(NB_Z)=J POS_HOLE_T(NB_Z) =J POS_HOLE_B(NB_Z) =J IO_REQ=-77777 SIZE_OF_READ=-9999_8 FIRST_POS_IN_READ=-9999 READ_DEST=-9999_8 READ_MNG=-9999 REQ_TO_ZONE=-9999 REQ_ID=-9999 RETURN END SUBROUTINE ZMUMPS_SOLVE_STAT_REINIT_PANEL SUBROUTINE ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) IMPLICIT NONE TYPE(IO_BLOCK), INTENT(INOUT):: MonBloc INTEGER(8) :: LAFAC INTEGER, INTENT(IN) :: STRAT, LIWFAC, & MYID, TYPEFile INTEGER, INTENT(INOUT) :: IW(0:LIWFAC-1) COMPLEX(kind=8), INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LNextPiv2beWritten, & UNextPiv2beWritten INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL INTEGER(8) :: TMPSIZE_OF_BLOCK INTEGER :: TempFTYPE LOGICAL WRITE_L, WRITE_U LOGICAL DO_U_FIRST INCLUDE 'mumps_headers.h' IERR = 0 IF (KEEP_OOC(50).EQ.0 & .AND.KEEP_OOC(251).EQ.2) THEN WRITE_L = .FALSE. ELSE WRITE_L = (TYPEFile.EQ.TYPEF_BOTH_LU .OR. TYPEFile.EQ.TYPEF_L) ENDIF WRITE_U = (TYPEFile.EQ.TYPEF_BOTH_LU .OR. TYPEFile.EQ.TYPEF_U) #if defined(_OPENMP) IF (KEEP_OOC(400).GT.0 .AND. KEEP_OOC(405) .GT. 0) THEN IF ( STRAT .EQ. STRAT_WRITE_MAX .OR. LAST_CALL ) THEN CALL OMP_SET_LOCK(LOCK_FOR_L0OMP) #if defined(_WIN32) ELSE #else ELSE IF ( .NOT. OMP_TEST_LOCK(LOCK_FOR_L0OMP )) THEN #endif RETURN ENDIF ENDIF #endif DO_U_FIRST = .FALSE. IF ( TYPEFile.EQ.TYPEF_BOTH_LU ) THEN IF ( LNextPiv2beWritten .GT. UNextPiv2beWritten ) THEN DO_U_FIRST = .TRUE. END IF END IF IF (DO_U_FIRST) GOTO 200 100 IF (WRITE_L .AND. TYPEF_L > 0 ) THEN TempFTYPE = TYPEF_L IF ((MonBloc%Typenode.EQ.2).AND.(.NOT.MonBloc%MASTER)) & THEN TMPSIZE_OF_BLOCK = SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE), & TempFTYPE) IF (TMPSIZE_OF_BLOCK .LT. 0_8) THEN TMPSIZE_OF_BLOCK = -TMPSIZE_OF_BLOCK - 1_8 ENDIF LNextPiv2beWritten = & int( & TMPSIZE_OF_BLOCK & / int(MonBloc%NROW,8) & ) & + 1 ENDIF CALL ZMUMPS_OOC_STORE_LorU( STRAT, & TempFTYPE, AFAC, LAFAC, MonBloc, & IERR, & LNextPiv2beWritten, & OOC_VADDR(STEP_OOC(MonBloc%INODE),TempFTYPE), & SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE),TempFTYPE), & FILESIZE, LAST_CALL ) IF (IERR .LT. 0) GOTO 300 IF (DO_U_FIRST) GOTO 300 ENDIF 200 IF (WRITE_U) THEN TempFTYPE = TYPEF_U CALL ZMUMPS_OOC_STORE_LorU( STRAT, & TempFTYPE, AFAC, LAFAC, MonBloc, & IERR, & UNextPiv2beWritten, & OOC_VADDR(STEP_OOC(MonBloc%INODE),TempFTYPE), & SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE),TempFTYPE), & FILESIZE, LAST_CALL) IF (IERR .LT. 0) GOTO 300 IF (DO_U_FIRST) GOTO 100 ENDIF 300 CONTINUE #if defined(_OPENMP) IF (KEEP_OOC(400).GT.0 .AND. KEEP_OOC(405) .GT. 0) THEN CALL OMP_UNSET_LOCK(LOCK_FOR_L0OMP) ENDIF #endif RETURN END SUBROUTINE ZMUMPS_OOC_IO_LU_PANEL SUBROUTINE ZMUMPS_OOC_STORE_LorU( STRAT, TYPEF, & AFAC, LAFAC, MonBloc, & IERR, & LorU_NextPiv2beWritten, & LorU_AddVirtNodeI8, LorUSIZE_OF_BLOCK, & FILESIZE, LAST_CALL & ) USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, INTENT(IN) :: STRAT INTEGER, INTENT(IN) :: TYPEF INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER(8), INTENT(IN) :: LAFAC COMPLEX(kind=8), INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LorU_NextPiv2beWritten INTEGER(8), INTENT(INOUT) :: LorU_AddVirtNodeI8 INTEGER(8), INTENT(INOUT) :: LorUSIZE_OF_BLOCK TYPE(IO_BLOCK), INTENT(INOUT) :: MonBloc INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL INTEGER NNMAX INTEGER(8) :: TOTSIZE, EFFSIZE INTEGER(8) :: TailleEcrite INTEGER SIZE_PANEL INTEGER(8) :: AddVirtCour LOGICAL VIRT_ADD_RESERVED_BEF_CALL LOGICAL VIRTUAL_ADDRESS_JUST_RESERVED LOGICAL HOLE_PROCESSED_BEFORE_CALL LOGICAL TMP_ESTIM INTEGER ICUR, INODE_CUR INTEGER(8) :: ADDR_LAST IERR = 0 IF (TYPEF == TYPEF_L ) THEN NNMAX = MonBloc%NROW ELSE NNMAX = MonBloc%NCOL ENDIF SIZE_PANEL = ZMUMPS_OOC_PANEL_SIZE(NNMAX) IF ( (.NOT.MonBloc%Last) .AND. & (MonBloc%LastPiv-LorU_NextPiv2beWritten+1.LT.SIZE_PANEL)) & THEN RETURN ENDIF TMP_ESTIM = .TRUE. TOTSIZE = ZMUMPS_OOC_NBENTRIES_PANEL_123 & (MonBloc%NFS, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) IF (MonBloc%Last) THEN TMP_ESTIM=.FALSE. EFFSIZE = ZMUMPS_OOC_NBENTRIES_PANEL_123 & (MonBloc%LastPiv, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) ELSE EFFSIZE = -1034039740327_8 ENDIF IF (MonBloc%Typenode.EQ.3.AND. MonBloc%NFS.NE.MonBloc%NCOL) THEN WRITE(*,*) 'Internal error in ZMUMPS_OOC_STORE_LorU for type3', & MonBloc%NFS,MonBloc%NCOL CALL MUMPS_ABORT() ENDIF IF (MonBloc%Typenode.EQ.3.AND. TYPEF.NE.TYPEF_L) THEN WRITE(*,*) 'Internal error in ZMUMPS_OOC_STORE_LorU,TYPEF=', & TYPEF, 'for typenode=3' CALL MUMPS_ABORT() ENDIF IF (MonBloc%Typenode.EQ.2.AND. & TYPEF.EQ.TYPEF_U.AND. & .NOT. MonBloc%MASTER ) THEN WRITE(*,*) 'Internal error in ZMUMPS_OOC_STORE_LorU', & MonBloc%MASTER,MonBloc%Typenode, TYPEF CALL MUMPS_ABORT() ENDIF HOLE_PROCESSED_BEFORE_CALL = (LorUSIZE_OF_BLOCK .LT. 0_8) IF (HOLE_PROCESSED_BEFORE_CALL.AND.(.NOT.MonBloc%Last)) THEN WRITE(6,*) ' Internal error in ZMUMPS_OOC_STORE_LorU ', & ' last is false after earlier calls with last=true' CALL MUMPS_ABORT() ENDIF IF (HOLE_PROCESSED_BEFORE_CALL) THEN LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 TOTSIZE = -99999999_8 ENDIF VIRTUAL_ADDRESS_JUST_RESERVED = .FALSE. VIRT_ADD_RESERVED_BEF_CALL = & ( LorUSIZE_OF_BLOCK .NE. 0_8 .OR. & HOLE_PROCESSED_BEFORE_CALL ) IF (MonBloc%Last .AND. .NOT. HOLE_PROCESSED_BEFORE_CALL) THEN KEEP_OOC(228) = max(KEEP_OOC(228), & (MonBloc%LastPiv+SIZE_PANEL-1) / SIZE_PANEL) IF (VIRT_ADD_RESERVED_BEF_CALL) THEN IF (AddVirtLibre(TYPEF).EQ. & (LorU_AddVirtNodeI8+TOTSIZE) ) THEN AddVirtLibre(TYPEF) = LorU_AddVirtNodeI8 + EFFSIZE ENDIF ELSE VIRTUAL_ADDRESS_JUST_RESERVED = .TRUE. IF (EFFSIZE .EQ. 0_8) THEN LorU_AddVirtNodeI8 = -9999_8 ELSE LorU_AddVirtNodeI8 = AddVirtLibre(TYPEF) ENDIF AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) + EFFSIZE ENDIF ELSE IF (.NOT. VIRT_ADD_RESERVED_BEF_CALL & ) THEN LorU_AddVirtNodeI8 = AddVirtLibre(TYPEF) AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) + TOTSIZE ENDIF ENDIF AddVirtCour = LorU_AddVirtNodeI8 + LorUSIZE_OF_BLOCK CALL ZMUMPS_OOC_WRT_IN_PANELS_LorU( STRAT, TYPEF, MonBloc, & SIZE_PANEL, & AFAC, LAFAC, & LorU_NextPiv2beWritten, AddVirtCour, & TailleEcrite, & IERR ) IF ( IERR .LT. 0 ) RETURN LorUSIZE_OF_BLOCK = LorUSIZE_OF_BLOCK + TailleEcrite IF (LorUSIZE_OF_BLOCK.EQ.0_8 ) THEN IF ( .NOT. VIRT_ADD_RESERVED_BEF_CALL & .AND. .NOT. VIRTUAL_ADDRESS_JUST_RESERVED ) & THEN AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) - TOTSIZE LorU_AddVirtNodeI8 = 0_8 ENDIF ELSE IF (.NOT. VIRT_ADD_RESERVED_BEF_CALL ) THEN VIRTUAL_ADDRESS_JUST_RESERVED = .TRUE. ENDIF IF ( VIRTUAL_ADDRESS_JUST_RESERVED) THEN OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(TYPEF), & TYPEF) = MonBloc%INODE I_CUR_HBUF_NEXTPOS(TYPEF) = I_CUR_HBUF_NEXTPOS(TYPEF) + 1 IF (MonBloc%Last) THEN MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,EFFSIZE) TMP_SIZE_FACT=TMP_SIZE_FACT+EFFSIZE ELSE MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,TOTSIZE) TMP_SIZE_FACT=TMP_SIZE_FACT+TOTSIZE ENDIF TMP_NB_NODES=TMP_NB_NODES+1 IF(TMP_SIZE_FACT.GT.SIZE_ZONE_SOLVE)THEN MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE, & TMP_NB_NODES) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 ENDIF ENDIF IF (MonBloc%Last) THEN LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 ENDIF IF (LAST_CALL) THEN IF (.NOT.MonBloc%Last) THEN WRITE(6,*) ' Internal error in ZMUMPS_OOC_STORE_LorU ', & ' LAST and LAST_CALL are incompatible ' CALL MUMPS_ABORT() ENDIF LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 ICUR = I_CUR_HBUF_NEXTPOS(TYPEF) - 1 INODE_CUR = OOC_INODE_SEQUENCE(ICUR,TYPEF) ADDR_LAST = AddVirtLibre(TYPEF) IF ( INODE_CUR .NE. MonBloc%INODE .AND. & OOC_VADDR(STEP_OOC(MonBloc%INODE),TYPEF) .NE. -9999 ) THEN 10 CONTINUE IF ( OOC_VADDR(STEP_OOC(INODE_CUR),TYPEF) .NE. -9999_8) THEN ADDR_LAST = OOC_VADDR(STEP_OOC(INODE_CUR), TYPEF) ENDIF ICUR = ICUR - 1 INODE_CUR = OOC_INODE_SEQUENCE(ICUR,TYPEF) IF (INODE_CUR .EQ. MonBloc%INODE) THEN LorUSIZE_OF_BLOCK = ADDR_LAST - & OOC_VADDR(STEP_OOC(INODE_CUR),TYPEF) ELSE IF (ICUR .LE. 1) THEN WRITE(*,*) "Internal error in ZMUMPS_OOC_STORE_LorU" WRITE(*,*) "Did not find current node in sequence" CALL MUMPS_ABORT() ENDIF GOTO 10 ENDIF ENDIF FILESIZE = FILESIZE + LorUSIZE_OF_BLOCK ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_STORE_LorU SUBROUTINE ZMUMPS_OOC_WRT_IN_PANELS_LorU( & STRAT, TYPEF, MonBloc, & SIZE_PANEL, & AFAC, LAFAC, & NextPiv2beWritten, AddVirtCour, & TailleEcrite, IERR ) USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, INTENT(IN) :: STRAT, TYPEF, SIZE_PANEL INTEGER(8) :: LAFAC INTEGER(8), INTENT(IN) :: AddVirtCour COMPLEX(kind=8), INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: NextPiv2beWritten TYPE(IO_BLOCK),INTENT(INOUT) :: MonBloc INTEGER(8), INTENT(OUT) :: TailleEcrite INTEGER, INTENT(OUT) :: IERR INTEGER :: I, NBeff, LPANELeff, IEND INTEGER(8) :: AddVirtDeb IERR = 0 TailleEcrite = 0_8 AddVirtDeb = AddVirtCour I = NextPiv2beWritten IF ( NextPiv2beWritten .GT. MonBloc%LastPiv ) THEN RETURN ENDIF 10 CONTINUE NBeff = min(SIZE_PANEL,MonBloc%LastPiv-I+1 ) IF ((NBeff.NE.SIZE_PANEL) .AND. (.NOT.MonBloc%Last)) THEN GOTO 20 ENDIF IF (TYPEF.EQ.TYPEF_L.AND.MonBloc%MASTER.AND. & KEEP_OOC(50).EQ.2 .AND. MonBloc%Typenode.NE.3) THEN IF (MonBloc%INDICES(NBeff+I-1) < 0) & THEN NBeff=NBeff+1 ENDIF ENDIF IEND = I + NBeff -1 CALL ZMUMPS_COPY_LU_TO_BUFFER( STRAT, TYPEF, MonBloc, & AFAC, LAFAC, & AddVirtDeb, I, IEND, LPANELeff, & IERR) IF ( IERR .LT. 0 ) THEN RETURN ENDIF IF ( IERR .EQ. 1 ) THEN IERR=0 GOTO 20 ENDIF IF (TYPEF .EQ. TYPEF_L) THEN MonBloc%LastPanelWritten_L = MonBloc%LastPanelWritten_L+1 ELSE MonBloc%LastPanelWritten_U = MonBloc%LastPanelWritten_U+1 ENDIF AddVirtDeb = AddVirtDeb + int(LPANELeff,8) TailleEcrite = TailleEcrite + int(LPANELeff,8) I=I+NBeff IF ( I .LE. MonBloc%LastPiv ) GOTO 10 20 CONTINUE NextPiv2beWritten = I RETURN END SUBROUTINE ZMUMPS_OOC_WRT_IN_PANELS_LorU INTEGER(8) FUNCTION ZMUMPS_OOC_NBENTRIES_PANEL_123 & (NFSorNPIV, NNMAX, SIZE_PANEL, MonBloc, ESTIM) IMPLICIT NONE TYPE(IO_BLOCK), INTENT(IN):: MonBloc INTEGER, INTENT(IN) :: NFSorNPIV, NNMAX, SIZE_PANEL LOGICAL, INTENT(IN) :: ESTIM INTEGER :: I, NBeff INTEGER(8) :: TOTSIZE TOTSIZE = 0_8 IF (NFSorNPIV.EQ.0) GOTO 100 IF (.NOT. MonBloc%MASTER .OR. MonBloc%Typenode.EQ.3) THEN TOTSIZE = int(NFSorNPIV,8) * int(NNMAX,8) ELSE I = 1 10 CONTINUE NBeff = min(SIZE_PANEL, NFSorNPIV-I+1) IF (KEEP_OOC(50).EQ.2) THEN IF (ESTIM) THEN NBeff = NBeff + 1 ELSE IF (MonBloc%INDICES(I+NBeff-1) < 0) THEN NBeff = NBeff + 1 ENDIF ENDIF ENDIF TOTSIZE = TOTSIZE + & int(NNMAX-I+1,8) * int(NBeff,8) I = I + NBeff IF ( I .LE. NFSorNPIV ) GOTO 10 ENDIF 100 CONTINUE ZMUMPS_OOC_NBENTRIES_PANEL_123 = TOTSIZE RETURN END FUNCTION ZMUMPS_OOC_NBENTRIES_PANEL_123 INTEGER FUNCTION ZMUMPS_OOC_PANEL_SIZE( NNMAX ) IMPLICIT NONE INTEGER, INTENT(IN) :: NNMAX INTEGER ZMUMPS_OOC_GET_PANEL_SIZE ZMUMPS_OOC_PANEL_SIZE=ZMUMPS_OOC_GET_PANEL_SIZE( & int(KEEP_OOC(223),8), NNMAX, KEEP_OOC(227),KEEP_OOC(50)) RETURN END FUNCTION ZMUMPS_OOC_PANEL_SIZE SUBROUTINE ZMUMPS_OOC_SKIP_NULL_SIZE_NODE() IMPLICIT NONE INTEGER I,TMP_NODE IF(.NOT.ZMUMPS_SOLVE_IS_END_REACHED())THEN IF(SOLVE_STEP.EQ.0)THEN I=CUR_POS_SEQUENCE TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE ((I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)).AND. & (SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) & .EQ.0_8)) INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I+1 IF(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ENDIF ENDDO CUR_POS_SEQUENCE=min(I,TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) ELSE I=CUR_POS_SEQUENCE TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE ((I.GE.1).AND. & (SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) & .EQ.0_8)) INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I-1 IF(I.GE.1)THEN TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ENDIF ENDDO CUR_POS_SEQUENCE=max(I,1) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_SKIP_NULL_SIZE_NODE SUBROUTINE ZMUMPS_OOC_SET_STATES_ES(N,KEEP201, & Pruned_List,nb_prun_nodes,STEP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP201, nb_prun_nodes INTEGER, INTENT(IN) :: STEP(N), & Pruned_List(nb_prun_nodes) INTEGER I, ISTEP IF (KEEP201 .GT. 0) THEN OOC_STATE_NODE(:) = ALREADY_USED DO I = 1, nb_prun_nodes ISTEP = STEP(Pruned_List(I)) OOC_STATE_NODE(ISTEP) = NOT_IN_MEM ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_SET_STATES_ES END MODULE ZMUMPS_OOC MUMPS_5.8.1/src/mumps_io.h0000664000175000017500000001523615042446422015240 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_IO_H #define MUMPS_IO_H #include "mumps_common.h" #include "mumps_c_types.h" /* * Two character arrays that are used by low_level_init_prefix * and low_level_init_tmpdir to store intermediate file names. * They are passed to mumps_io_basic.c inside the routine * mumps_low_level_init_ooc_c. * Note that both low_level_init_prefix and low_level_init_tmpdir * MUST be called before low_level_init_ooc_c. * */ #define MUMPS_OOC_PREFIX_MAX_LENGTH 255 #define MUMPS_OOC_TMPDIR_MAX_LENGTH 1023 static char MUMPS_OOC_STORE_PREFIX[MUMPS_OOC_PREFIX_MAX_LENGTH]; static MUMPS_INT MUMPS_OOC_STORE_PREFIXLEN=-1; static char MUMPS_OOC_STORE_TMPDIR[MUMPS_OOC_TMPDIR_MAX_LENGTH]; static MUMPS_INT MUMPS_OOC_STORE_TMPDIRLEN=-1; #define MUMPS_DUMPRHSBINARY_C \ F_SYMBOL(dumprhsbinary_c,DUMPRHSBINARY_C) void MUMPS_CALL MUMPS_DUMPRHSBINARY_C ( MUMPS_INT *N, MUMPS_INT *NRHS, MUMPS_INT *LRHS, float *RHS, MUMPS_INT *K35, char *filename, mumps_ftnlen l1 ); #define MUMPS_DUMPMATBINARY_C \ F_SYMBOL(dumpmatbinary_c,DUMPMATBINARY_C) void MUMPS_CALL MUMPS_DUMPMATBINARY_C ( MUMPS_INT* N, MUMPS_INT8 *NNZ, MUMPS_INT* K35, MUMPS_INT *irn, MUMPS_INT *jcn, void *A, MUMPS_INT *is_A_provided, char *file_name, mumps_ftnlen l1 ); #define MUMPS_LOW_LEVEL_INIT_PREFIX \ F_SYMBOL(low_level_init_prefix,LOW_LEVEL_INIT_PREFIX) void MUMPS_CALL MUMPS_LOW_LEVEL_INIT_PREFIX(MUMPS_INT * dim, char * str, mumps_ftnlen l1); #define MUMPS_LOW_LEVEL_INIT_TMPDIR \ F_SYMBOL(low_level_init_tmpdir,LOW_LEVEL_INIT_TMPDIR) void MUMPS_CALL MUMPS_LOW_LEVEL_INIT_TMPDIR(MUMPS_INT * dim, char * str, mumps_ftnlen l1); MUMPS_INLINE MUMPS_INT mumps_convert_2fint_to_longlong( MUMPS_INT *, MUMPS_INT *, long long *); #define MUMPS_LOW_LEVEL_INIT_OOC_C \ F_SYMBOL(low_level_init_ooc_c,LOW_LEVEL_INIT_OOC_C) void MUMPS_CALL MUMPS_LOW_LEVEL_INIT_OOC_C(MUMPS_INT *_myid, MUMPS_INT *total_size_io,MUMPS_INT *size_element, MUMPS_INT *async, MUMPS_INT *k211, MUMPS_INT *nb_file_type, MUMPS_INT *flag_tab , MUMPS_INT *keep255, 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_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 *keep211, MUMPS_INT *keep255, MUMPS_INT *ierr); #define MUMPS_OOC_START_LOW_LEVEL \ F_SYMBOL(ooc_start_low_level,OOC_START_LOW_LEVEL) void MUMPS_CALL MUMPS_OOC_START_LOW_LEVEL(MUMPS_INT *ierr); #define MUMPS_OOC_PRINT_STATS \ F_SYMBOL(ooc_print_stats,OOC_PRINT_STATS) void MUMPS_CALL MUMPS_OOC_PRINT_STATS(); #define MUMPS_OOC_REMOVE_FILE_C \ F_SYMBOL(ooc_remove_file_c,OOC_REMOVE_FILE_C) void MUMPS_CALL MUMPS_OOC_REMOVE_FILE_C(MUMPS_INT *ierr, char *name, mumps_ftnlen l1); #define MUMPS_OOC_END_WRITE_C \ F_SYMBOL(ooc_end_write_c,OOC_END_WRITE_C) void MUMPS_CALL MUMPS_OOC_END_WRITE_C(MUMPS_INT *ierr); #define MUMPS_OOC_IS_ASYNC_AVAIL \ F_SYMBOL(ooc_is_async_avail,OOC_IS_ASYNC_AVAIL) void MUMPS_CALL MUMPS_OOC_IS_ASYNC_AVAIL(MUMPS_INT *flag); #endif /* MUMPS_IO_H */ MUMPS_5.8.1/src/ssol_aux.F0000664000175000017500000015775315042446437015224 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_FREETOPSO( N, KEEP28, IWCB, LIWW, & W, LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER(8), INTENT(IN) :: LWC INTEGER(8), INTENT(INOUT) :: POSWCB INTEGER N,LIWW,IWPOSCB, KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28) INTEGER(8) :: PTRACB(KEEP28) REAL W(LWC) INTEGER SIZFI, SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN DO WHILE ( IWCB( IWPOSCB + 2 ) .eq. 0 ) SIZFR = IWCB( IWPOSCB + 1 ) SIZFI = 2 IWPOSCB = IWPOSCB + SIZFI POSWCB = POSWCB + SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN END DO RETURN END SUBROUTINE SMUMPS_FREETOPSO SUBROUTINE SMUMPS_COMPSO(N,KEEP28,IWCB,LIWW,W,LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER(8), INTENT(IN) :: LWC INTEGER(8), INTENT(INOUT) :: POSWCB INTEGER N,LIWW,IWPOSCB,KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28) INTEGER(8) :: PTRACB(KEEP28) REAL W(LWC) INTEGER IPTIW,SIZFI,LONGI INTEGER(8) :: IPTA, LONGR, SIZFR, I8 INTEGER :: I IPTIW = IWPOSCB IPTA = POSWCB LONGI = 0 LONGR = 0_8 IF ( IPTIW .EQ. LIWW ) RETURN 10 CONTINUE IF (IWCB(IPTIW+2).EQ.0) THEN SIZFR = int(IWCB(IPTIW+1),8) SIZFI = 2 IF (LONGI.NE.0) THEN DO 20 I=0,LONGI-1 IWCB(IPTIW + SIZFI - I) = IWCB (IPTIW - I) 20 CONTINUE DO 30 I8=0,LONGR-1 W(IPTA + SIZFR - I8) = W(IPTA - I8) 30 CONTINUE ENDIF DO 40 I=1,KEEP28 IF ((PTRICB(I).LE.(IPTIW+1)).AND. & (PTRICB(I).GT.IWPOSCB) ) THEN PTRICB(I) = PTRICB(I) + SIZFI PTRACB(I) = PTRACB(I) + SIZFR ENDIF 40 CONTINUE IWPOSCB = IWPOSCB + SIZFI IPTIW = IPTIW + SIZFI POSWCB = POSWCB + SIZFR IPTA = IPTA + SIZFR ELSE SIZFR = int(IWCB(IPTIW+1),8) SIZFI = 2 IPTIW = IPTIW + SIZFI LONGI = LONGI + SIZFI IPTA = IPTA + SIZFR LONGR = LONGR + SIZFR ENDIF IF (IPTIW.NE.LIWW) GOTO 10 RETURN END SUBROUTINE SMUMPS_COMPSO SUBROUTINE SMUMPS_SOL_X(A, NZ8, N, IRN, ICN, Z, KEEP,KEEP8, & EFF_SIZE_SCHUR, SYM_PERM ) INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) REAL, INTENT(IN) :: A(NZ8) REAL, INTENT(OUT) :: Z(N) INTEGER, INTENT(IN) :: EFF_SIZE_SCHUR, SYM_PERM(N) INTEGER :: I, J LOGICAL :: SKIP_COLinSchur REAL, PARAMETER :: ZERO = 0.0E0 INTEGER(8) :: K INTRINSIC abs DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE SKIP_COLinSchur = (EFF_SIZE_SCHUR.GT.0) IF (KEEP(264).EQ.0) THEN IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE IF ( SKIP_COLinSchur.AND. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR)) CYCLE IF ( SKIP_COLinSchur.AND. & (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR)) CYCLE Z(I) = Z(I) + abs(A(K)) ENDDO ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE IF ( SKIP_COLinSchur.AND. & ( (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR) & .OR. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR) & ) & ) CYCLE Z(I) = Z(I) + abs(A(K)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)) ENDIF ENDDO ENDIF ELSE IF (KEEP(50) .EQ.0) THEN IF (SKIP_COLinSchur) THEN DO K = 1_8, NZ8 J = ICN(K) IF ( SYM_PERM(J).GT.N-EFF_SIZE_SCHUR ) CYCLE I = IRN(K) IF ( SYM_PERM(I).GT.N-EFF_SIZE_SCHUR ) CYCLE Z(I) = Z(I) + abs(A(K)) ENDDO ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) Z(I) = Z(I) + abs(A(K)) ENDDO ENDIF ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ( SKIP_COLinSchur.AND. & ( (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR) & .OR. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR) & ) & ) CYCLE Z(I) = Z(I) + abs(A(K)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SOL_X SUBROUTINE SMUMPS_SCAL_X(A, NZ8, N, IRN, ICN, Z, & KEEP, KEEP8, COLSCA, & EFF_SIZE_SCHUR, SYM_PERM ) INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) REAL, INTENT(IN) :: A(NZ8) REAL, INTENT(IN) :: COLSCA(N) REAL, INTENT(OUT) :: Z(N) INTEGER, INTENT(IN) :: EFF_SIZE_SCHUR, SYM_PERM(N) REAL, PARAMETER :: ZERO = 0.0E0 INTEGER :: I, J INTEGER(8) :: K LOGICAL :: SKIP_COLinSchur DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE SKIP_COLinSchur = (EFF_SIZE_SCHUR.GT.0) IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE IF ( SKIP_COLinSchur.AND. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR)) CYCLE IF ( SKIP_COLinSchur.AND. & (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR)) CYCLE Z(I) = Z(I) + abs(A(K)*COLSCA(J)) ENDDO ELSE DO K = 1, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE IF ( SKIP_COLinSchur.AND. & ( (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR) & .OR. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR) & ) & ) CYCLE Z(I) = Z(I) + abs(A(K)*COLSCA(J)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)*COLSCA(I)) ENDIF ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_SCAL_X SUBROUTINE SMUMPS_SOL_Y(A, NZ8, N, IRN, ICN, RHS, X, R, W, & KEEP,KEEP8) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) REAL, INTENT(IN) :: A(NZ8), RHS(N), X(N) REAL, INTENT(OUT) :: W(N) REAL, INTENT(OUT) :: R(N) INTEGER I, J INTEGER(8) :: K8 REAL, PARAMETER :: ZERO = 0.0E0 REAL D DO I = 1, N R(I) = RHS(I) W(I) = ZERO ENDDO IF (KEEP(264).EQ.0) THEN IF (KEEP(50) .EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. & (J .LT. 1)) CYCLE D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. & (J .LT. 1)) CYCLE D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF (I.NE.J) THEN D = A(K8) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO ENDIF ELSE IF (KEEP(50) .EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF (I.NE.J) THEN D = A(K8) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SOL_Y SUBROUTINE SMUMPS_SOL_MULR(N, R, W) INTEGER, intent(in) :: N REAL, intent(in) :: W(N) REAL, intent(inout) :: R(N) INTEGER I DO 10 I = 1, N R(I) = R(I) * W(I) 10 CONTINUE RETURN END SUBROUTINE SMUMPS_SOL_MULR SUBROUTINE SMUMPS_SOL_B(N, KASE, X, EST, W, IW, GRAIN) INTEGER, intent(in) :: N INTEGER, intent(inout) :: KASE INTEGER IW(N) REAL W(N), X(N) REAL, intent(inout) :: EST INTEGER, intent(in) :: GRAIN INTRINSIC abs, nint, sign INTRINSIC real INTEGER SMUMPS_IXAMAX EXTERNAL SMUMPS_IXAMAX INTEGER ITMAX PARAMETER (ITMAX = 5) INTEGER I, ITER, J, JLAST, JUMP REAL ALTSGN REAL TEMP SAVE ITER, J, JLAST, JUMP REAL ZERO, ONE PARAMETER( ZERO = 0.0E0 ) PARAMETER( ONE = 1.0E0 ) REAL, PARAMETER :: RZERO = 0.0E0 REAL, PARAMETER :: RONE = 1.0E0 IF (KASE .EQ. 0) THEN DO 10 I = 1, N X(I) = ONE / real(N) 10 CONTINUE KASE = 1 JUMP = 1 RETURN ENDIF SELECT CASE (JUMP) CASE (1) GOTO 20 CASE(2) GOTO 40 CASE(3) GOTO 70 CASE(4) GOTO 120 CASE(5) GOTO 160 CASE DEFAULT END SELECT 20 CONTINUE IF (N .EQ. 1) THEN W(1) = X(1) EST = abs(W(1)) GOTO 190 ENDIF DO 30 I = 1, N X(I) = sign( RONE,real(X(I)) ) IW(I) = nint(real(X(I))) 30 CONTINUE KASE = 2 JUMP = 2 RETURN 40 CONTINUE J = SMUMPS_IXAMAX(N, X, 1, GRAIN) ITER = 2 50 CONTINUE DO 60 I = 1, N X(I) = ZERO 60 CONTINUE X(J) = ONE KASE = 1 JUMP = 3 RETURN 70 CONTINUE DO 80 I = 1, N W(I) = X(I) 80 CONTINUE DO 90 I = 1, N IF (nint(sign(RONE, real(X(I)))) .NE. IW(I)) GOTO 100 90 CONTINUE GOTO 130 100 CONTINUE DO 110 I = 1, N X(I) = sign(RONE, real(X(I))) IW(I) = nint(real(X(I))) 110 CONTINUE KASE = 2 JUMP = 4 RETURN 120 CONTINUE JLAST = J J = SMUMPS_IXAMAX(N, X, 1, GRAIN) IF ((abs(X(JLAST)) .NE. abs(X(J))) .AND. (ITER .LT. ITMAX)) THEN ITER = ITER + 1 GOTO 50 ENDIF 130 CONTINUE EST = RZERO DO 140 I = 1, N EST = EST + abs(W(I)) 140 CONTINUE ALTSGN = RONE DO 150 I = 1, N X(I) = ALTSGN * (RONE + real(I - 1) / real(N - 1)) ALTSGN = -ALTSGN 150 CONTINUE KASE = 1 JUMP = 5 RETURN 160 CONTINUE TEMP = RZERO DO 170 I = 1, N TEMP = TEMP + abs(X(I)) 170 CONTINUE TEMP = 2.0E0/3.0E0 * TEMP / real(N) IF (TEMP .GT. EST) THEN DO 180 I = 1, N W(I) = X(I) 180 CONTINUE EST = TEMP ENDIF 190 KASE = 0 RETURN END SUBROUTINE SMUMPS_SOL_B SUBROUTINE SMUMPS_QD2( MTYPE, N, NZ8, ASPK, IRN, ICN, & LHS, WRHS, W, RHS, KEEP,KEEP8) IMPLICIT NONE INTEGER MTYPE, N INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(IN) :: IRN( NZ8 ), ICN( NZ8 ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL, INTENT(IN) :: ASPK( NZ8 ) REAL, INTENT(IN) :: LHS( N ), WRHS( N ) REAL, INTENT(OUT):: RHS( N ) REAL, INTENT(OUT):: W( N ) INTEGER I, J INTEGER(8) :: K8 REAL, PARAMETER :: DZERO = 0.0E0 DO I = 1, N W(I) = DZERO RHS(I) = WRHS(I) ENDDO IF ( KEEP(50) .EQ. 0 ) THEN IF (MTYPE .EQ. 1) THEN IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) ENDDO ENDIF ELSE IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDDO ENDIF ENDIF ELSE IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDIF ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_QD2 SUBROUTINE SMUMPS_ELTQD2( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & LHS, WRHS, W, RHS, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL A_ELT(NA_ELT8) REAL LHS( N ), WRHS( N ), RHS( N ) REAL W(N) CALL SMUMPS_MV_ELT(N, NELT, ELTPTR, ELTVAR, A_ELT, & LHS, RHS, KEEP(50), MTYPE ) RHS = WRHS - RHS CALL SMUMPS_SOL_X_ELT( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8 ) RETURN END SUBROUTINE SMUMPS_ELTQD2 SUBROUTINE SMUMPS_SOL_X_ELT( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL A_ELT(NA_ELT8) REAL TEMP REAL W(N) INTEGER I, J, IEL, SIZEI, IELPTR INTEGER(8) :: K8 REAL DZERO PARAMETER(DZERO = 0.0E0) W = DZERO K8 = 1_8 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( KEEP(50).EQ.0 ) THEN IF (MTYPE.EQ.1) THEN DO J = 1, SIZEI DO I = 1, SIZEI W( ELTVAR( IELPTR + I) ) = & W( ELTVAR( IELPTR + I) ) & + abs(A_ELT( K8 )) K8 = K8 + 1_8 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + abs( A_ELT(K8)) K8 = K8 + 1_8 END DO W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + TEMP END DO ENDIF ELSE DO J = 1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K8 )) K8 = K8 + 1_8 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K8 )) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + abs(A_ELT( K8 )) K8 = K8 + 1_8 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_SOL_X_ELT SUBROUTINE SMUMPS_SOL_SCALX_ELT(MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8, COLSCA ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL COLSCA(N) REAL A_ELT(NA_ELT8) REAL W(N) REAL TEMP, TEMP2 INTEGER I, J, IEL, SIZEI, IELPTR INTEGER(8) :: K8 REAL DZERO PARAMETER(DZERO = 0.0E0) W = DZERO K8 = 1_8 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( KEEP(50).EQ.0 ) THEN IF (MTYPE.EQ.1) THEN DO J = 1, SIZEI TEMP2 = abs(COLSCA(ELTVAR( IELPTR + J) )) DO I = 1, SIZEI W( ELTVAR( IELPTR + I) ) = & W( ELTVAR( IELPTR + I) ) & + abs(A_ELT( K8 )) * TEMP2 K8 = K8 + 1_8 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) TEMP2= abs(COLSCA(ELTVAR( IELPTR + J) )) DO I = 1, SIZEI TEMP = TEMP + abs(A_ELT( K8 )) * TEMP2 K8 = K8 + 1_8 END DO W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + TEMP END DO ENDIF ELSE DO J = 1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs( A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + J)) ) K8 = K8 + 1_8 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs(A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + J))) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + & abs(A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + I))) K8 = K8 + 1_8 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_SOL_SCALX_ELT SUBROUTINE SMUMPS_ELTYD( MTYPE, N, NELT, ELTPTR, & LELTVAR, ELTVAR, NA_ELT8, A_ELT, & SAVERHS, X, Y, W, K50 ) IMPLICIT NONE INTEGER N, NELT, K50, MTYPE, LELTVAR INTEGER(8) :: NA_ELT8 INTEGER ELTPTR( NELT + 1 ), ELTVAR( LELTVAR ) REAL A_ELT( NA_ELT8 ), X( N ), Y( N ), & SAVERHS(N) REAL W(N) INTEGER IEL, I , J, K, SIZEI, IELPTR REAL ZERO REAL TEMP REAL TEMP2 PARAMETER( ZERO = 0.0E0 ) Y = SAVERHS W = ZERO K = 1 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( K50 .eq. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN DO J = 1, SIZEI TEMP = X( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) - & A_ELT( K ) * TEMP W( ELTVAR( IELPTR + I ) ) = & W( ELTVAR( IELPTR + I ) ) + & abs( A_ELT( K ) * TEMP ) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) TEMP2 = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP - & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) TEMP2 = TEMP2 + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) K = K + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP W( ELTVAR( IELPTR + J ) ) = TEMP2 END DO END IF ELSE DO J = 1, SIZEI Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) W( ELTVAR( IELPTR + J ) ) = & W( ELTVAR( IELPTR + J ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) K = K + 1 DO I = J+1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) W( ELTVAR( IELPTR + I ) ) = & W( ELTVAR( IELPTR + I ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) W( ELTVAR( IELPTR + J ) ) = & W( ELTVAR( IELPTR + J ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) K = K + 1 END DO END DO END IF END DO RETURN END SUBROUTINE SMUMPS_ELTYD SUBROUTINE SMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) USE SMUMPS_OOC IMPLICIT NONE INTEGER INODE,KEEP(500),N INTEGER(8) KEEP8(150) INTEGER(8) :: LA INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER IERR REAL A(LA) INTEGER RETURN_VALUE LOGICAL MUST_BE_PERMUTED RETURN_VALUE=SMUMPS_SOLVE_IS_INODE_IN_MEM(INODE,PTRFAC, & KEEP(28),A,LA,IERR) IF(RETURN_VALUE.EQ.OOC_NODE_NOT_IN_MEM)THEN IF(IERR.LT.0)THEN RETURN ENDIF CALL SMUMPS_SOLVE_ALLOC_FACTOR_SPACE(INODE,PTRFAC, & KEEP,KEEP8,A,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL SMUMPS_READ_OOC( & A(PTRFAC(STEP(INODE))), & INODE,IERR & ) IF(IERR.LT.0)THEN RETURN ENDIF ELSE IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF(RETURN_VALUE.NE.OOC_NODE_PERMUTED)THEN MUST_BE_PERMUTED=.TRUE. CALL SMUMPS_SOLVE_MODIFY_STATE_NODE(INODE) ELSE MUST_BE_PERMUTED=.FALSE. ENDIF RETURN END SUBROUTINE SMUMPS_SOLVE_GET_OOC_NODE SUBROUTINE SMUMPS_BUILD_MAPPING_INFO(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' TYPE(SMUMPS_STRUC), TARGET :: id INTEGER, ALLOCATABLE, DIMENSION(:) :: LOCAL_LIST INTEGER :: I,IERR,TMP,NSTEPS,N_LOCAL_LIST INTEGER :: MASTER,TAG_SIZE,TAG_LIST INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: I_AM_SLAVE PARAMETER(MASTER=0, TAG_SIZE=85,TAG_LIST=86) I_AM_SLAVE = (id%MYID .NE. MASTER & .OR. ((id%MYID.EQ.MASTER).AND.(id%KEEP(46).EQ.1))) NSTEPS = id%KEEP(28) ALLOCATE(LOCAL_LIST(NSTEPS),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating LOCAL_LIST' CALL MUMPS_ABORT() END IF N_LOCAL_LIST = 0 IF(I_AM_SLAVE) THEN DO I=1,NSTEPS IF(id%PTLUST_S(I).NE.0) THEN N_LOCAL_LIST = N_LOCAL_LIST + 1 LOCAL_LIST(N_LOCAL_LIST) = I END IF END DO IF(id%MYID.NE.MASTER) THEN CALL MPI_SEND(N_LOCAL_LIST, 1, & MPI_INTEGER, MASTER, TAG_SIZE, id%COMM,IERR) CALL MPI_SEND(LOCAL_LIST, N_LOCAL_LIST, & MPI_INTEGER, MASTER, TAG_LIST, id%COMM,IERR) DEALLOCATE(LOCAL_LIST) ALLOCATE(id%IPTR_WORKING(1), & id%WORKING(1), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating ', & 'IPTR_WORKING and WORKING' CALL MUMPS_ABORT() END IF END IF END IF IF(id%MYID.EQ.MASTER) THEN ALLOCATE(id%IPTR_WORKING(id%NPROCS+1), STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating IPTR_WORKING' CALL MUMPS_ABORT() END IF id%IPTR_WORKING = 0 id%IPTR_WORKING(1) = 1 id%IPTR_WORKING(MASTER+2) = N_LOCAL_LIST DO I=1, id%NPROCS-1 CALL MPI_RECV(TMP, 1, MPI_INTEGER, MPI_ANY_SOURCE, & TAG_SIZE, id%COMM, STATUS, IERR) id%IPTR_WORKING(STATUS(MPI_SOURCE)+2) = TMP END DO DO I=2, id%NPROCS+1 id%IPTR_WORKING(I) = id%IPTR_WORKING(I) & + id%IPTR_WORKING(I-1) END DO ALLOCATE(id%WORKING(id%IPTR_WORKING(id%NPROCS+1)-1),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating LOCAL_LIST' CALL MUMPS_ABORT() END IF TMP = MASTER + 1 IF (I_AM_SLAVE) THEN id%WORKING(id%IPTR_WORKING(TMP):id%IPTR_WORKING(TMP+1)-1) & = LOCAL_LIST(1:id%IPTR_WORKING(TMP+1) & -id%IPTR_WORKING(TMP)) ENDIF DO I=1,id%NPROCS-1 CALL MPI_RECV(LOCAL_LIST, NSTEPS, MPI_INTEGER, & MPI_ANY_SOURCE, TAG_LIST, id%COMM, STATUS, IERR) TMP = STATUS(MPI_SOURCE)+1 id%WORKING(id%IPTR_WORKING(TMP):id%IPTR_WORKING(TMP+1)-1) & = LOCAL_LIST(1:id%IPTR_WORKING(TMP+1)- & id%IPTR_WORKING(TMP)) END DO DEALLOCATE(LOCAL_LIST) END IF END SUBROUTINE SMUMPS_BUILD_MAPPING_INFO SUBROUTINE SMUMPS_SOL_OMEGA(N, RHS, & X, Y, R_W, C_W, IW, IFLAG, & OMEGA, NOITER, TESTConv, & LP, ARRET, GRAIN, CGCE ) IMPLICIT NONE INTEGER N, IFLAG INTEGER IW(N,2) REAL RHS(N) REAL X(N), Y(N) REAL R_W(N,2) REAL C_W(N) INTEGER LP, NOITER LOGICAL TESTConv REAL OMEGA(2) REAL ARRET REAL CGCE INTEGER, intent(in) :: GRAIN REAL, PARAMETER :: CTAU=1.0E3 INTEGER I, IMAX REAL OM1, OM2, DXMAX REAL TAU, DD REAL OLDOMG(2) REAL, PARAMETER :: ZERO=0.0E0 REAL, PARAMETER :: ONE=1.0E0 INTEGER SMUMPS_IXAMAX SAVE OM1, OLDOMG IMAX = SMUMPS_IXAMAX(N, X, 1, GRAIN) DXMAX = abs(X(IMAX)) OMEGA(1) = ZERO OMEGA(2) = ZERO DO I = 1, N TAU = (R_W(I, 2) * DXMAX + abs(RHS(I))) * real(N) * CTAU DD = R_W(I, 1) + abs(RHS(I)) IF (DD .GT. TAU * epsilon(CTAU)) THEN OMEGA(1) = max(OMEGA(1), abs(Y(I)) / DD) IW(I, 1) = 1 ELSE IF (TAU .GT. ZERO) THEN OMEGA(2) = max(OMEGA(2), & abs(Y(I)) / (DD + R_W(I, 2) * DXMAX)) ENDIF IW(I, 1) = 2 ENDIF ENDDO IF (TESTConv) THEN OM2 = OMEGA(1) + OMEGA(2) IF (OM2 .LT. ARRET ) THEN IFLAG = 1 GOTO 70 ENDIF IF (NOITER .GE. 1) THEN IF (OM2 .GT. OM1 * CGCE) THEN IF (OM2 .GT. OM1) THEN OMEGA(1) = OLDOMG(1) OMEGA(2) = OLDOMG(2) DO I = 1, N X(I) = C_W(I) ENDDO IFLAG = 2 GOTO 70 ENDIF IFLAG = 3 GOTO 70 ENDIF ENDIF DO I = 1, N C_W(I) = X(I) ENDDO OLDOMG(1) = OMEGA(1) OLDOMG(2) = OMEGA(2) OM1 = OM2 ENDIF IFLAG = 0 RETURN 70 CONTINUE RETURN END SUBROUTINE SMUMPS_SOL_OMEGA SUBROUTINE SMUMPS_SOL_LCOND(N, RHS, & X, Y, D, R_W, C_W, IW, KASE, & OMEGA, ERX, COND, & LP, KEEP,KEEP8 ) IMPLICIT NONE INTEGER N, KASE, KEEP(500) INTEGER(8) KEEP8(150) INTEGER IW(N,2) REAL RHS(N) REAL X(N), Y(N) REAL D(N) REAL R_W(N,2) REAL C_W(N) INTEGER LP REAL COND(2),OMEGA(2) LOGICAL LCOND1, LCOND2 INTEGER JUMP, I, IMAX REAL ERX, DXMAX REAL DXIMAX REAL, PARAMETER :: ZERO = 0.0E0 REAL, PARAMETER :: ONE = 1.0E0 INTEGER SMUMPS_IXAMAX INTRINSIC abs SAVE LCOND1, LCOND2, JUMP, DXIMAX, DXMAX IF (KASE .EQ. 0) THEN LCOND1 = .FALSE. LCOND2 = .FALSE. COND(1) = ONE COND(2) = ONE ERX = ZERO JUMP = 1 ENDIF SELECT CASE (JUMP) CASE (1) GOTO 30 CASE(2) GOTO 10 CASE(3) GOTO 110 CASE(4) GOTO 150 CASE(5) GOTO 35 CASE DEFAULT END SELECT 10 CONTINUE 30 CONTINUE 35 CONTINUE IMAX = SMUMPS_IXAMAX(N, X, 1, KEEP(361)) DXMAX = abs(X(IMAX)) DO I = 1, N IF (IW(I, 1) .EQ. 1) THEN R_W(I, 1) = R_W(I, 1) + abs(RHS(I)) R_W(I, 2) = ZERO LCOND1 = .TRUE. ELSE R_W(I, 2) = R_W(I, 2) * DXMAX + R_W(I, 1) R_W(I, 1) = ZERO LCOND2 = .TRUE. ENDIF ENDDO DO I = 1, N C_W(I) = X(I) * D(I) ENDDO IMAX = SMUMPS_IXAMAX(N, C_W(1), 1, KEEP(361)) DXIMAX = abs(C_W(IMAX)) IF (.NOT.LCOND1) GOTO 130 100 CONTINUE CALL SMUMPS_SOL_B(N, KASE, Y, COND(1), C_W, IW(1, 2), KEEP(361)) IF (KASE .EQ. 0) GOTO 120 IF (KASE .EQ. 1) CALL SMUMPS_SOL_MULR(N, Y, D) IF (KASE .EQ. 2) CALL SMUMPS_SOL_MULR(N, Y, R_W) JUMP = 3 RETURN 110 CONTINUE IF (KASE .EQ. 1) CALL SMUMPS_SOL_MULR(N, Y, R_W) IF (KASE .EQ. 2) CALL SMUMPS_SOL_MULR(N, Y, D) GOTO 100 120 CONTINUE IF (DXIMAX .GT. ZERO) COND(1) = COND(1) / DXIMAX ERX = OMEGA(1) * COND(1) 130 CONTINUE IF (.NOT.LCOND2) GOTO 170 KASE = 0 140 CONTINUE CALL SMUMPS_SOL_B(N, KASE, Y, COND(2), C_W, IW(1, 2), KEEP(361)) IF (KASE .EQ. 0) GOTO 160 IF (KASE .EQ. 1) CALL SMUMPS_SOL_MULR(N, Y, D) IF (KASE .EQ. 2) CALL SMUMPS_SOL_MULR(N, Y, R_W(1, 2)) JUMP = 4 RETURN 150 CONTINUE IF (KASE .EQ. 1) CALL SMUMPS_SOL_MULR(N, Y, R_W(1, 2)) IF (KASE .EQ. 2) CALL SMUMPS_SOL_MULR(N, Y, D) GOTO 140 160 IF (DXIMAX .GT. ZERO) THEN COND(2) = COND(2) / DXIMAX ENDIF ERX = ERX + OMEGA(2) * COND(2) 170 CONTINUE RETURN END SUBROUTINE SMUMPS_SOL_LCOND SUBROUTINE SMUMPS_SOL_CPY_FS2RHSINTR( JBDEB, JBFIN, NBROWS, & KEEP, RHSINTR, NRHS, LRHSINTR, FIRST_ROW_RHSINTR, W, LD_W, & FIRST_ROW_W ) INTEGER :: JBDEB, JBFIN, NBROWS INTEGER :: NRHS, LRHSINTR INTEGER :: FIRST_ROW_RHSINTR INTEGER, INTENT(IN) :: KEEP(500) REAL, INTENT(INOUT) :: RHSINTR(LRHSINTR,NRHS) INTEGER :: LD_W, FIRST_ROW_W REAL :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER :: JJ, K, ISHIFT !$OMP PARALLEL DO PRIVATE(ISHIFT, JJ), IF !$OMP& (JBFIN-JBDEB+1 > 2*KEEP(362) .AND. !$OMP& NBROWS * (JBFIN-JBDEB+1) > 2*KEEP(363)) DO K = JBDEB, JBFIN ISHIFT = FIRST_ROW_W + LD_W * (K-JBDEB) DO JJ = 0, NBROWS-1 RHSINTR(FIRST_ROW_RHSINTR+JJ,K) = W(ISHIFT+JJ) END DO END DO !$OMP END PARALLEL DO RETURN END SUBROUTINE SMUMPS_SOL_CPY_FS2RHSINTR SUBROUTINE SMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSINTR, NRHS, LRHSINTR, W, LD_W, FIRST_ROW_W, & IW, LIW, KEEP, N, POSINRHSINTR_BWD ) INTEGER, INTENT(IN) :: JBDEB, JBFIN, J1, J2 INTEGER, INTENT(IN) :: NRHS, LRHSINTR INTEGER, INTENT(IN) :: FIRST_ROW_W, LD_W, LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: KEEP(500) REAL, INTENT(INOUT) :: RHSINTR(LRHSINTR,NRHS) REAL :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: POSINRHSINTR_BWD(N) INTEGER :: ISHIFT, JJ, K, IPOSINRHSINTR !$OMP PARALLEL DO PRIVATE(JJ,ISHIFT,IPOSINRHSINTR), IF !$OMP& ((JBFIN-JBDEB+1 > 2*KEEP(362) .AND. !$OMP& (JBFIN-JBDEB+1)*(J2-KEEP(253)-J1+1)>2*KEEP(363))) DO K=JBDEB, JBFIN ISHIFT = FIRST_ROW_W+(K-JBDEB)*LD_W DO JJ = J1, J2-KEEP(253) IPOSINRHSINTR = abs(POSINRHSINTR_BWD(IW(JJ))) W(ISHIFT+JJ-J1)= RHSINTR(IPOSINRHSINTR,K) ENDDO ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE SMUMPS_SOL_BWD_GTHR SUBROUTINE SMUMPS_SOL_Q(MTYPE, IFLAG, N, & LHS, WRHS, W, RES, GIVNORM, ANORM, XNORM, SCLNRM, & MPRINT, ICNTL, KEEP,KEEP8) INTEGER MTYPE,N,IFLAG,ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) REAL RES(N),LHS(N) REAL WRHS(N) REAL W(N) REAL RESMAX,RESL2,XNORM, SCLNRM REAL ANORM,DZERO LOGICAL GIVNORM,PROK INTEGER MPRINT, MP INTEGER K INTRINSIC abs, max, sqrt MP = ICNTL(2) PROK = (MPRINT .GT. 0) DZERO = 0.0E0 IF (.NOT.GIVNORM) ANORM = DZERO RESMAX = DZERO RESL2 = DZERO DO 40 K = 1, N RESMAX = max(RESMAX, abs(RES(K))) RESL2 = RESL2 + abs(RES(K)) * abs(RES(K)) IF (.NOT.GIVNORM) ANORM = max(ANORM, W(K)) 40 CONTINUE XNORM = DZERO DO 50 K = 1, N XNORM = max(XNORM, abs(LHS(K))) 50 CONTINUE IF ( XNORM .EQ. DZERO .OR. (exponent(XNORM) .LT. & minexponent(XNORM) + KEEP(122) ) & .OR. & ( exponent(ANORM)+exponent(XNORM) .LT. & minexponent(XNORM) + KEEP(122) ) & .OR. & ( exponent(ANORM) + exponent(XNORM) -exponent(RESMAX) & .LT. minexponent(XNORM) + KEEP(122) ) & ) THEN IF (mod(IFLAG/2,2) .EQ. 0) THEN IFLAG = IFLAG + 2 ENDIF IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) & ' max-NORM of computed solut. is zero or close to zero. ' ENDIF IF (RESMAX .EQ. DZERO) THEN SCLNRM = DZERO ELSE SCLNRM = RESMAX / (ANORM * XNORM) ENDIF RESL2 = sqrt(RESL2) IF (PROK) WRITE( MPRINT, 90 ) RESMAX, RESL2, ANORM, XNORM, & SCLNRM 90 FORMAT (/' RESIDUAL IS ............ (INF-NORM) =',1PD9.2/ & ' .. (2-NORM) =',1PD9.2/ & ' RINFOG(4):NORM OF input Matrix (INF-NORM)=',1PD9.2/ & ' RINFOG(5):NORM OF Computed SOLUT (INF-NORM)=',1PD9.2/ & ' RINFOG(6):SCALED RESIDUAL ...... (INF-NORM)=',1PD9.2) RETURN END SUBROUTINE SMUMPS_SOL_Q SUBROUTINE SMUMPS_SOLVE_FWD_TRSOLVE (A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LDADIAG, NPIV, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT REAL, INTENT(IN) :: A(LA) REAL, INTENT(INOUT) :: WCB(LWCB) REAL ONE PARAMETER (ONE = 1.0E0) IF (KEEP(50).NE.0 .OR. MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL strsv( 'U', 'T', 'U', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL strsm( 'L','U','T','U', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL strsv( 'L', 'N', 'N', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL strsm( 'L','L','N','N', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF RETURN END SUBROUTINE SMUMPS_SOLVE_FWD_TRSOLVE SUBROUTINE SMUMPS_SOLVE_BWD_TRSOLVE (A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LDADIAG, NPIV, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT REAL, INTENT(IN) :: A(LA) REAL, INTENT(INOUT) :: WCB(LWCB) REAL ONE PARAMETER (ONE = 1.0E0) IF (MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL strsv( 'L', 'T', 'N', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL strsm( 'L','L','T','N', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL strsv( 'U', 'N', 'U', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL strsm( 'L','U','N','U', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF RETURN END SUBROUTINE SMUMPS_SOLVE_BWD_TRSOLVE SUBROUTINE SMUMPS_SOLVE_FWD_PANELS( & A, LA, APOS, NPIV, IW, & NRHS_B, WCB, LWCB, LDA_WCB, & PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, NPIV, KEEP(500) INTEGER, INTENT(IN) :: IW(NPIV) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT REAL, INTENT(IN) :: A(LA) REAL, INTENT(INOUT) :: WCB(LWCB) INTEGER :: NB_TARGET INTEGER :: NBPANELS INTEGER :: NBROWS_PANEL, NBCOLS_PANEL, ICOL_BEG, ICOL_END INTEGER(8) :: PANEL_APOS, PPIV_PANEL REAL, PARAMETER :: ONE=1.0E0 IF (KEEP(459) .LE. 1) THEN WRITE(*,*) " Internal error in SMUMPS_SOLVE_FWD_PANELS" CALL MUMPS_ABORT() ENDIF CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, NB_TARGET, KEEP ) PANEL_APOS = APOS NBPANELS = 0 ICOL_BEG = 1 NBROWS_PANEL = NPIV PPIV_PANEL = PPIV_COURANT DO WHILE ( ICOL_BEG .LE. NPIV ) NBPANELS = NBPANELS + 1 ICOL_END = min(NB_TARGET * NBPANELS, NPIV) IF ( IW(ICOL_END) .LT. 0 ) ICOL_END=ICOL_END+1 NBCOLS_PANEL = ICOL_END - ICOL_BEG + 1 CALL SMUMPS_SOLVE_FWD_TRSOLVE (A, LA, PANEL_APOS, & NBCOLS_PANEL, NBCOLS_PANEL, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_PANEL, MTYPE, KEEP) IF ( NBROWS_PANEL .GT. NBCOLS_PANEL ) THEN CALL SMUMPS_SOLVE_GEMM_UPDATE( A, LA, & PANEL_APOS + int(NBCOLS_PANEL,8) * int(NBCOLS_PANEL,8), & NBCOLS_PANEL, NBCOLS_PANEL, NBROWS_PANEL-NBCOLS_PANEL, & NRHS_B, WCB, LWCB, PPIV_PANEL, LDA_WCB, & PPIV_PANEL+NBCOLS_PANEL, LDA_WCB, & MTYPE, KEEP, ONE ) ENDIF ICOL_BEG = ICOL_END + 1 PANEL_APOS = PANEL_APOS + int(NBCOLS_PANEL,8) * & int(NBROWS_PANEL,8) NBROWS_PANEL = NBROWS_PANEL - NBCOLS_PANEL PPIV_PANEL = PPIV_PANEL + NBCOLS_PANEL ENDDO RETURN END SUBROUTINE SMUMPS_SOLVE_FWD_PANELS SUBROUTINE SMUMPS_SOLVE_BWD_PANELS( & A, LA, APOS, NPIV, IW, & NRHS_B, WCB, LWCB, LDA_WCB, & PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, NPIV, KEEP(500) INTEGER, INTENT(IN) :: IW(NPIV) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT REAL, INTENT(IN) :: A(LA) REAL, INTENT(INOUT) :: WCB(LWCB) INTEGER, PARAMETER :: PANEL_TABSIZE = 20 INTEGER(8) :: PANEL_POS(PANEL_TABSIZE) INTEGER :: PANEL_COL(PANEL_TABSIZE) INTEGER :: IPANEL, NBPANELS, NB_TARGET INTEGER :: NBROWS_PANEL, NBCOLS_PANEL INTEGER(8) :: PPIV_PANEL INTEGER :: MTYPE_TEMP REAL, PARAMETER :: ONE=1.0E0 IF (KEEP(459) .LE. 1) THEN WRITE(*,*) " Internal error 1 in SMUMPS_SOLVE_BWD_PANELS" CALL MUMPS_ABORT() ENDIF IF ( KEEP(459)+1 .GT. PANEL_TABSIZE ) THEN WRITE(*,*) " Internal error 2 in SMUMPS_SOLVE_BWD_PANELS" CALL MUMPS_ABORT() ENDIF CALL MUMPS_LDLTPANEL_PANELINFOS( NPIV, KEEP, IW, &NB_TARGET, NBPANELS, PANEL_COL, PANEL_POS, PANEL_TABSIZE, &.FALSE. ) DO IPANEL = NBPANELS, 1, -1 NBCOLS_PANEL = PANEL_COL( IPANEL+1 ) - PANEL_COL( IPANEL ) NBROWS_PANEL = NPIV - PANEL_COL( IPANEL ) + 1 PPIV_PANEL = PPIV_COURANT + PANEL_COL( IPANEL ) - 1 IF ( NBROWS_PANEL .GT. NBCOLS_PANEL ) THEN MTYPE_TEMP = 0 CALL SMUMPS_SOLVE_GEMM_UPDATE( A, LA, & APOS-1_8+PANEL_POS(IPANEL)+ & int(NBCOLS_PANEL,8)*int(NBCOLS_PANEL,8), & NBROWS_PANEL-NBCOLS_PANEL, NBCOLS_PANEL, & NBCOLS_PANEL, & NRHS_B, WCB, LWCB, PPIV_PANEL+NBCOLS_PANEL, LDA_WCB, & PPIV_PANEL, LDA_WCB, & MTYPE_TEMP, KEEP, ONE ) ENDIF CALL SMUMPS_SOLVE_BWD_TRSOLVE (A, LA, & APOS+PANEL_POS(IPANEL)-1_8, & NBCOLS_PANEL, NBCOLS_PANEL, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_PANEL, MTYPE, KEEP) ENDDO RETURN END SUBROUTINE SMUMPS_SOLVE_BWD_PANELS SUBROUTINE SMUMPS_SOLVE_GEMM_UPDATE & (A, LA, APOS1, NX, LDA, NY, & NRHS_B, WCB, LWCB, PTRX, LDX, & PTRY, LDY, & MTYPE, KEEP, COEF_Y ) INTEGER, INTENT(IN) :: MTYPE, NY, NX, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDY, LDA, LDX INTEGER(8), INTENT(IN) :: LA, APOS1, LWCB, PTRX, & PTRY REAL, INTENT(IN) :: A(LA) REAL, INTENT(INOUT) :: WCB(LWCB) REAL, INTENT(IN) :: COEF_Y REAL ALPHA, ZERO, ONE PARAMETER (ZERO = 0.0E0, ONE = 1.0E0, ALPHA=-1.0E0) IF ( NX .NE. 0 .AND. NY.NE.0 ) THEN IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL sgemv('T', NX, NY, ALPHA, A(APOS1), & LDA, WCB(PTRX), 1, COEF_Y, & WCB(PTRY), 1) ELSE #endif CALL sgemm('T', 'N', NY, NRHS_B, NX, ALPHA, & A(APOS1), LDA, WCB(PTRX), LDX, COEF_Y, & WCB(PTRY), LDY) #if defined(MUMPS_USE_BLAS2) END IF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL sgemv('N',NY, NX, ALPHA, A(APOS1), & LDA, WCB(PTRX), 1, & COEF_Y, WCB(PTRY), 1 ) ELSE #endif CALL sgemm('N', 'N', NY, NRHS_B, NX, ALPHA, & A(APOS1), LDA, WCB(PTRX), LDX, & COEF_Y, WCB(PTRY), LDY) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF END IF RETURN END SUBROUTINE SMUMPS_SOLVE_GEMM_UPDATE SUBROUTINE SMUMPS_SOL_LD_AND_RELOAD_PANEL ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & IGNORE_K459 & ) USE SMUMPS_OOC IMPLICIT NONE INTEGER, INTENT(IN) :: MTYPE, INODE, N, NPIV, LIELL, & NELIM, NSLAVES INTEGER, INTENT(IN) :: LRHSINTR, NRHS, LIW, JBDEB, JBFIN INTEGER, INTENT(IN) :: IW(LIW), IPOS, POSINRHSINTR_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, APOS, LA, PPIV_COURANT INTEGER, INTENT(IN) :: LD_WCBPIV INTEGER, INTENT(IN) :: KEEP(500) REAL, INTENT(IN) :: WCB( LWCB ) REAL, INTENT(IN) :: A( LA ) REAL, INTENT(INOUT) :: RHSINTR(LRHSINTR, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL, INTENT(IN) :: IGNORE_K459 INTEGER :: J1, J3 INTEGER :: IPOSINRHSINTR, JJ, K, & LDAJ, NRHS_B INTEGER(8) :: IFR8 , APOS1, APOS2, APOSOFF, IFR_ini8, & POSWCB1, POSWCB2 REAL :: VALPIV, A11, A22, A12, DETPIV INTEGER, PARAMETER :: PANEL_TABSIZE = 20 INTEGER(8) :: PANEL_POS(PANEL_TABSIZE) INTEGER :: PANEL_COL(PANEL_TABSIZE) INTEGER :: IPANEL, ICOL, NBPANELS, NB_TARGET LOGICAL :: SKIP_IT LOGICAL :: OMP_FLAG REAL ONE PARAMETER (ONE = 1.0E0) IF ( NPIV.EQ. 0 ) RETURN NRHS_B = JBFIN-JBDEB+1 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J3 = IPOS + LIELL + NPIV END IF IPOSINRHSINTR = POSINRHSINTR_FWD(IW(J1)) IF ( KEEP(50) .eq. 0 ) THEN OMP_FLAG = .FALSE. !$ OMP_FLAG=(int(NRHS_B,8)*int(NPIV,8).GE.int(KEEP(363),8)) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(IFR8) COLLAPSE(2) DO K = JBDEB, JBFIN DO IFR8 = 0_8, int(NPIV-1,8) RHSINTR(IPOSINRHSINTR+IFR8, K) = & WCB(PPIV_COURANT+(K-JBDEB)*LD_WCBPIV+IFR8) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K = JBDEB, JBFIN DO IFR8 = 0_8, int(NPIV-1,8) RHSINTR(IPOSINRHSINTR+IFR8, K) = & WCB(PPIV_COURANT+(K-JBDEB)*LD_WCBPIV+IFR8) ENDDO ENDDO ENDIF ELSE CALL MUMPS_LDLTPANEL_PANELINFOS( NPIV, KEEP, IW(IPOS+LIELL+1), & NB_TARGET, NBPANELS, PANEL_COL, PANEL_POS, PANEL_TABSIZE, & IGNORE_K459 ) IFR_ini8 = PPIV_COURANT !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & ((J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363))) !$OMP PARALLEL DO PRIVATE(JJ,IFR8,APOS1,APOS2,APOSOFF,VALPIV, !$OMP& IPANEL,ICOL, !$OMP& POSWCB1,POSWCB2,A11,A22,A12,DETPIV,LDAJ,SKIP_IT) !$OMP& IF(OMP_FLAG) DO K = JBDEB, JBFIN DO JJ = J1, J3 IPANEL = (JJ-J1)/NB_TARGET + 1 IF ( JJ-J1+1 .LT. PANEL_COL(IPANEL) ) IPANEL = IPANEL -1 ICOL = JJ-J1+1 - PANEL_COL(IPANEL) + 1 LDAJ = PANEL_COL(IPANEL+1) - PANEL_COL(IPANEL) APOS1 = APOS-1_8+PANEL_POS( IPANEL ) + int(ICOL-1,8) * & int(LDAJ+1,8) IFR8 = IFR_ini8 + int(K-JBDEB,8)*int(LD_WCBPIV,8) + & int(JJ-J1,8) IF ( JJ .NE. J1 ) THEN IF ( IW(LIELL+JJ-1) .LT. 0 ) THEN SKIP_IT = .TRUE. ELSE SKIP_IT = .FALSE. ENDIF ELSE SKIP_IT = .FALSE. ENDIF IF (SKIP_IT) THEN ELSE IF ( IW(JJ+LIELL) .GT. 0 ) THEN VALPIV = ONE/A( APOS1 ) RHSINTR(IPOSINRHSINTR+JJ-J1 , K ) = & WCB( IFR8 ) * VALPIV APOS1 = APOS1 + int(LDAJ + 1,8) ELSE APOS2 = APOS1+int(LDAJ+1,8) APOSOFF=APOS1+1_8 A11 = A(APOS1) A22 = A(APOS2) A12 = A(APOSOFF) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(APOS2)/DETPIV A12 = -A12/DETPIV POSWCB1 = IFR8 POSWCB2 = POSWCB1+1_8 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSINTR(IPOSINRHSINTR+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 ENDIF ENDDO ENDDO !$OMP END PARALLEL DO END IF RETURN END SUBROUTINE SMUMPS_SOL_LD_AND_RELOAD_PANEL SUBROUTINE SMUMPS_SOL_LD_AND_RELOAD ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & IGNORE_K459 & ) USE SMUMPS_OOC INTEGER, INTENT(IN) :: MTYPE, INODE, N, NPIV, LIELL, & NELIM, NSLAVES INTEGER, INTENT(IN) :: LRHSINTR, NRHS, LIW, JBDEB, JBFIN INTEGER, INTENT(IN) :: IW(LIW), IPOS, POSINRHSINTR_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, APOS, LA, PPIV_COURANT INTEGER, INTENT(IN) :: LD_WCBPIV INTEGER, INTENT(IN) :: KEEP(500) REAL, INTENT(IN) :: WCB( LWCB ) REAL, INTENT(IN) :: A( LA ) REAL, INTENT(INOUT) :: RHSINTR(LRHSINTR, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL, INTENT(IN) :: IGNORE_K459 INTEGER :: TempNROW, J1, J3, PANEL_SIZE INTEGER :: IPOSINRHSINTR, JJ, K, NBK, LDAJ, & LDAJ_ini, NBK_ini, LDAJ_FIRST_PANEL, NRHS_B INTEGER(8) :: IFR8 , APOS1, APOS2, APOSOFF, IFR_ini8, & POSWCB1, POSWCB2 REAL :: VALPIV, A11, A22, A12, DETPIV !$ LOGICAL :: OMP_FLAG REAL ONE PARAMETER (ONE = 1.0E0) NRHS_B = JBFIN-JBDEB+1 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J3 = IPOS + LIELL + NPIV END IF IPOSINRHSINTR = POSINRHSINTR_FWD(IW(J1)) IF ( KEEP(50) .eq. 0 ) THEN !$ OMP_FLAG=(NRHS_B.GE.KEEP(362).AND.NRHS_B*NPIV.GE.KEEP(363)) !$OMP PARALLEL DO PRIVATE(IFR8) IF (OMP_FLAG) DO K=JBDEB,JBFIN IFR8 = PPIV_COURANT + (K-JBDEB)*LD_WCBPIV RHSINTR(IPOSINRHSINTR:IPOSINRHSINTR+NPIV-1, K) = & WCB(IFR8:IFR8+int(NPIV-1,8)) ENDDO !$OMP END PARALLEL DO ELSE IFR8 = PPIV_COURANT - 1_8 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN IF (MTYPE.EQ.1) THEN IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN TempNROW= NPIV+NELIM LDAJ_FIRST_PANEL=TempNROW ELSE TempNROW= LIELL LDAJ_FIRST_PANEL=TempNROW ENDIF ELSE TempNROW= NPIV LDAJ_FIRST_PANEL=LIELL ENDIF PANEL_SIZE = SMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) LDAJ = TempNROW ELSE IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 & .AND. .NOT. IGNORE_K459 ) THEN CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, PANEL_SIZE, KEEP ) LDAJ = PANEL_SIZE ELSE PANEL_SIZE = -1 LDAJ = NPIV ENDIF ENDIF IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN NBK = 0 ENDIF IFR_ini8 = PPIV_COURANT - 1_8 LDAJ_ini = LDAJ IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & NBK_ini = NBK !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & ((J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363))) !$OMP PARALLEL DO PRIVATE(JJ,IFR8,NBK,APOS1,APOS2,APOSOFF,VALPIV, !$OMP& POSWCB1, POSWCB2,A11,A22,A12,DETPIV,LDAJ) IF(OMP_FLAG) DO K = JBDEB, JBFIN IFR8 = IFR_ini8 + int(K-JBDEB,8)*int(LD_WCBPIV,8) NBK = NBK_ini APOS1 = APOS LDAJ = LDAJ_ini JJ = J1 DO IF (JJ .GT. J3) EXIT IFR8 = IFR8 + 1_8 IF (IW(JJ+LIELL) .GT. 0) THEN VALPIV = ONE/A( APOS1 ) RHSINTR(IPOSINRHSINTR+JJ-J1 , K ) = & WCB( IFR8 ) * VALPIV IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 IF (NBK.EQ.PANEL_SIZE) THEN NBK = 0 LDAJ = LDAJ - PANEL_SIZE ENDIF ENDIF APOS1 = APOS1 + int(LDAJ + 1,8) JJ = JJ+1 ELSE IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 ENDIF APOS2 = APOS1+int(LDAJ+1,8) IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN APOSOFF = APOS1+int(LDAJ,8) ELSE APOSOFF=APOS1+1_8 ENDIF A11 = A(APOS1) A22 = A(APOS2) A12 = A(APOSOFF) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(APOS2)/DETPIV A12 = -A12/DETPIV POSWCB1 = IFR8 POSWCB2 = POSWCB1+1_8 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSINTR(IPOSINRHSINTR+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 IF (NBK.GE.PANEL_SIZE) THEN LDAJ = LDAJ - NBK NBK = 0 ENDIF ENDIF APOS1 = APOS2 + int(LDAJ + 1,8) JJ = JJ+2 IFR8 = IFR8+1_8 ENDIF ENDDO ENDDO !$OMP END PARALLEL DO END IF RETURN END SUBROUTINE SMUMPS_SOL_LD_AND_RELOAD SUBROUTINE SMUMPS_SET_SCALING_LOC( scaling_data, N, ILOC, LILOC, & COMM, MYID, I_AM_SLAVE, MASTER, NB_BYTES, NB_BYTES_MAX, & K16_8, LP, LPOK, ICNTL, INFO ) IMPLICIT NONE type scaling_data_t SEQUENCE REAL, dimension(:), pointer :: SCALING REAL, dimension(:), pointer :: SCALING_LOC INTEGER, dimension(:), pointer :: SCALING_IND end type scaling_data_t type (scaling_data_t), INTENT(INOUT) :: scaling_data INTEGER, INTENT(IN) :: N, LILOC, COMM, MYID, MASTER, LP INTEGER, INTENT(IN) :: ILOC(LILOC) INTEGER(8), INTENT(INOUT) :: NB_BYTES, NB_BYTES_MAX INTEGER(8), INTENT(IN) :: K16_8 LOGICAL, INTENT(IN) :: I_AM_SLAVE, LPOK INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(IN) :: ICNTL(60) REAL, POINTER, DIMENSION(:) :: SCALING INTEGER :: I, IERR_MPI, allocok INCLUDE 'mpif.h' NULLIFY(scaling_data%SCALING_LOC) IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data%SCALING_LOC(max(1,LILOC)), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(1,LILOC) GOTO 35 ENDIF NB_BYTES = NB_BYTES + int(max(1,LILOC),8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF IF (MYID .NE. MASTER) THEN ALLOCATE(SCALING(N), stat=allocok) IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating temporary scaling array' ENDIF INFO(1)=-13 INFO(2)=N GOTO 35 ENDIF NB_BYTES = NB_BYTES + int(N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE SCALING => scaling_data%SCALING ENDIF 35 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF (INFO(1) .LT. 0) GOTO 90 CALL MPI_BCAST( SCALING(1), N, MPI_REAL, & MASTER, COMM, IERR_MPI) IF ( I_AM_SLAVE ) THEN DO I = 1, LILOC IF (ILOC(I) .GE. 1 .AND. ILOC(I) .LE. N) THEN scaling_data%SCALING_LOC(I) = SCALING(ILOC(I)) ENDIF ENDDO ENDIF 90 CONTINUE IF (MYID.NE. MASTER) THEN IF (associated(SCALING)) THEN DEALLOCATE(SCALING) NB_BYTES = NB_BYTES - int(N,8)*K16_8 ENDIF ENDIF NULLIFY(SCALING) IF (INFO(1) .LT. 0) THEN IF (associated(scaling_data%SCALING_LOC)) THEN DEALLOCATE(scaling_data%SCALING_LOC) NULLIFY(scaling_data%SCALING_LOC) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SET_SCALING_LOC MUMPS_5.8.1/src/sana_mtrans.F0000664000175000017500000007732215042446441015661 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C History: C ------- C This maximum transversal set of routines are C based on the work done by Jacko Koster at CERFACS for C his PhD thesis from Institut National Polytechnique de Toulouse C at CERFACS (1995-1997) and includes modifications provided C by the author as well as work done by Stephane Pralet C first at CERFACS during his PhD thesis (2003-2004) then C at INPT-IRIT (2004-2005) during his post-doctoral position. C C The main research publication references for this work are: C [1] I. S. Duff, (1981), C "Algorithm 575. Permutations for a zero-free diagonal", C ACM Trans. Math. Software 7(3), 387-390. C [2] I. S. Duff and J. Koster, (1998), C "The design and use of algorithms for permuting large C entries to the diagonal of sparse matrices", C SIAM J. Matrix Anal. Appl., vol. 20, no. 4, pp. 889-901. C [3] I. S. Duff and J. Koster, (2001), C "On algorithms for permuting large entries to the diagonal C of sparse matrices", C SIAM J. Matrix Anal. Appl., vol. 22, no. 4, pp. 973-996. C SUBROUTINE SMUMPS_MTRANSI(ICNTL,CNTL) IMPLICIT NONE INTEGER NICNTL, NCNTL PARAMETER (NICNTL=10, NCNTL=10) INTEGER ICNTL(NICNTL) REAL CNTL(NCNTL) INTEGER I ICNTL(1) = 6 ICNTL(2) = 6 ICNTL(3) = -1 ICNTL(4) = -1 ICNTL(5) = 0 DO 10 I = 6,NICNTL ICNTL(I) = 0 10 CONTINUE CNTL(1) = 0.0E0 CNTL(2) = 0.0E0 DO 20 I = 3,NCNTL CNTL(I) = 0.0E0 20 CONTINUE RETURN END SUBROUTINE SMUMPS_MTRANSI SUBROUTINE SMUMPS_MTRANSB & (M,N,NE,IP,IRN,A,IPERM,NUM,JPERM,PR,Q,L,D,RINF) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: NE INTEGER :: IRN(NE),IPERM(M),JPERM(N),Q(M),L(M) INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER(8), INTENT(OUT) :: PR(N) REAL :: A(NE) REAL :: D(M), RINF INTEGER :: I,II,J,JJ,JORD,Q0,QLEN,IDUM,JDUM,ISP,JSP, & I0,UP,LOW, IK INTEGER(8) :: K,KK,KK1,KK2 REAL CSP,DI,DNEW,DQ0,AI,A0,BV,TBV,RLX REAL ZERO,MINONE,ONE PARAMETER (ZERO=0.0E0,MINONE=-1.0E0,ONE=1.0E0) INTRINSIC abs,min EXTERNAL SMUMPS_MTRANSD, SMUMPS_MTRANSE, & SMUMPS_MTRANSF, SMUMPS_MTRANSX RLX = D(1) NUM = 0 BV = RINF DO 10 I = 1,N JPERM(I) = 0 PR(I) = IP(I) 10 CONTINUE DO 12 I = 1,M IPERM(I) = 0 D(I) = ZERO 12 CONTINUE DO 30 J = 1,N A0 = MINONE DO 20 K = IP(J),IP(J+1)-1_8 I = IRN(K) AI = abs(A(K)) IF (AI.GT.D(I)) D(I) = AI IF (JPERM(J).NE.0) GO TO 20 IF (AI.GE.BV) THEN A0 = BV IF (IPERM(I).NE.0) GO TO 20 JPERM(J) = I IPERM(I) = J NUM = NUM + 1 ELSE IF (AI.LE.A0) GO TO 20 A0 = AI I0 = I ENDIF 20 CONTINUE IF (A0.NE.MINONE .AND. A0.LT.BV) THEN BV = A0 IF (IPERM(I0).NE.0) GO TO 30 IPERM(I0) = J JPERM(J) = I0 NUM = NUM + 1 ENDIF 30 CONTINUE IF (M.EQ.N) THEN DO 35 I = 1,M BV = min(BV,D(I)) 35 CONTINUE ENDIF IF (NUM.EQ.N) GO TO 1000 DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 DO 50 K = IP(J),IP(J+1)-1_8 I = IRN(K) AI = abs(A(K)) IF (AI.LT.BV) GO TO 50 IF (IPERM(I).EQ.0) GO TO 90 JJ = IPERM(I) KK1 = PR(JJ) KK2 = IP(JJ+1) - 1_8 IF (KK1.GT.KK2) GO TO 50 DO 70 KK = KK1,KK2 II = IRN(KK) IF (IPERM(II).NE.0) GO TO 70 IF (abs(A(KK)).GE.BV) GO TO 80 70 CONTINUE PR(JJ) = KK2 + 1_8 50 CONTINUE GO TO 95 80 JPERM(JJ) = II IPERM(II) = JJ PR(JJ) = KK + 1_8 90 NUM = NUM + 1 JPERM(J) = I IPERM(I) = J PR(J) = K + 1_8 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = MINONE L(I) = 0 99 CONTINUE TBV = BV * (ONE-RLX) DO 100 JORD = 1,N IF (JPERM(JORD).NE.0) GO TO 100 QLEN = 0 LOW = M + 1 UP = M + 1 CSP = MINONE J = JORD PR(J) = -1_8 DO 115 K = IP(J),IP(J+1)-1_8 I = IRN(K) DNEW = abs(A(K)) IF (CSP.GE.DNEW) GO TO 115 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = I JSP = J IF (CSP.GE.TBV) GO TO 160 ELSE D(I) = DNEW IF (DNEW.GE.TBV) THEN LOW = LOW - 1 Q(LOW) = I ELSE QLEN = QLEN + 1 L(I) = QLEN CALL SMUMPS_MTRANSD(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = int(J,8) ENDIF 115 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = Q(1) IF (CSP.GE.D(I)) GO TO 160 BV = D(I) TBV = BV * (ONE-RLX) DO 152 IDUM = 1,M CALL SMUMPS_MTRANSE(QLEN,M,Q,D,L,1) L(I) = 0 LOW = LOW - 1 Q(LOW) = I IF (QLEN.EQ.0) GO TO 153 I = Q(1) IF (D(I).LT.TBV) GO TO 153 152 CONTINUE ENDIF 153 UP = UP - 1 Q0 = Q(UP) DQ0 = D(Q0) L(Q0) = UP J = IPERM(Q0) DO 155 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (L(I).GE.UP) GO TO 155 DNEW = min(DQ0,abs(A(K))) IF (CSP.GE.DNEW) GO TO 155 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = I JSP = J IF (CSP.GE.TBV) GO TO 160 ELSE DI = D(I) IF (DI.GE.TBV .OR. DI.GE.DNEW) GO TO 155 D(I) = DNEW IF (DNEW.GE.TBV) THEN IF (DI.NE.MINONE) THEN CALL SMUMPS_MTRANSF(L(I),QLEN,M,Q,D,L,1) ENDIF L(I) = 0 LOW = LOW - 1 Q(LOW) = I ELSE IF (DI.EQ.MINONE) THEN QLEN = QLEN + 1 L(I) = QLEN ENDIF CALL SMUMPS_MTRANSD(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = int(J,8) ENDIF 155 CONTINUE 150 CONTINUE 160 IF (CSP.EQ.MINONE) GO TO 190 BV = min(BV,CSP) TBV = BV * (ONE-RLX) NUM = NUM + 1 I = ISP J = JSP DO 170 JDUM = 1,NUM+1 I0 = JPERM(J) JPERM(J) = I IPERM(I) = J J = int(PR(J)) IF (J.EQ.-1) GO TO 190 I = I0 170 CONTINUE 190 DO 191 IK = UP,M I = Q(IK) D(I) = MINONE L(I) = 0 191 CONTINUE DO 192 IK = LOW,UP-1 I = Q(IK) D(I) = MINONE 192 CONTINUE DO 193 IK = 1,QLEN I = Q(IK) D(I) = MINONE L(I) = 0 193 CONTINUE 100 CONTINUE 1000 IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL SMUMPS_MTRANSX(M,N,IPERM,L,JPERM) 2000 RETURN END SUBROUTINE SMUMPS_MTRANSB SUBROUTINE SMUMPS_MTRANSD(I,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER I,N,IWAY INTEGER Q(N),L(N) REAL D(N) INTEGER IDUM,K,POS,POSK,QK PARAMETER (K=2) REAL DI POS = L(I) IF (POS.LE.1) GO TO 20 DI = D(I) IF (IWAY.EQ.1) THEN DO 10 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.LE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 10 CONTINUE ELSE DO 15 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.GE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 15 CONTINUE ENDIF 20 Q(POS) = I L(I) = POS RETURN END SUBROUTINE SMUMPS_MTRANSD SUBROUTINE SMUMPS_MTRANSE(QLEN,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER QLEN,N,IWAY INTEGER Q(N),L(N) REAL D(N) INTEGER I,IDUM,K,POS,POSK PARAMETER (K=2) REAL DK,DR,DI I = Q(QLEN) DI = D(I) QLEN = QLEN - 1 POS = 1 IF (IWAY.EQ.1) THEN DO 10 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 20 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.LT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.GE.DK) GO TO 20 Q(POS) = Q(POSK) L(Q(POS)) = POS POS = POSK 10 CONTINUE ELSE DO 15 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 20 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.GT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.LE.DK) GO TO 20 Q(POS) = Q(POSK) L(Q(POS)) = POS POS = POSK 15 CONTINUE ENDIF 20 Q(POS) = I L(I) = POS RETURN END SUBROUTINE SMUMPS_MTRANSE SUBROUTINE SMUMPS_MTRANSF(POS0,QLEN,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER POS0,QLEN,N,IWAY INTEGER Q(N),L(N) REAL D(N) INTEGER I,IDUM,K,POS,POSK,QK PARAMETER (K=2) REAL DK,DR,DI IF (QLEN.EQ.POS0) THEN QLEN = QLEN - 1 RETURN ENDIF I = Q(QLEN) DI = D(I) QLEN = QLEN - 1 POS = POS0 IF (IWAY.EQ.1) THEN IF (POS.LE.1) GO TO 20 DO 10 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.LE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 10 CONTINUE 20 Q(POS) = I L(I) = POS IF (POS.NE.POS0) RETURN DO 30 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 40 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.LT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.GE.DK) GO TO 40 QK = Q(POSK) Q(POS) = QK L(QK) = POS POS = POSK 30 CONTINUE ELSE IF (POS.LE.1) GO TO 34 DO 32 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.GE.D(QK)) GO TO 34 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 34 32 CONTINUE 34 Q(POS) = I L(I) = POS IF (POS.NE.POS0) RETURN DO 36 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 40 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.GT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.LE.DK) GO TO 40 QK = Q(POSK) Q(POS) = QK L(QK) = POS POS = POSK 36 CONTINUE ENDIF 40 Q(POS) = I L(I) = POS RETURN END SUBROUTINE SMUMPS_MTRANSF SUBROUTINE SMUMPS_MTRANSQ(IP,LENL,LENH,W,WLEN,A,NVAL,VAL) IMPLICIT NONE INTEGER ::WLEN,NVAL INTEGER :: LENL(*),LENH(*),W(*) INTEGER(8) :: IP(*) REAL :: A(*),VAL INTEGER XX,J,K,S,POS INTEGER(8) :: II PARAMETER (XX=10) REAL SPLIT(XX),HA NVAL = 0 DO 10 K = 1,WLEN J = W(K) DO 15 II = IP(J)+int(LENL(J),8),IP(J)+int(LENH(J)-1,8) HA = A(II) IF (NVAL.EQ.0) THEN SPLIT(1) = HA NVAL = 1 ELSE DO 20 S = NVAL,1,-1 IF (SPLIT(S).EQ.HA) GO TO 15 IF (SPLIT(S).GT.HA) THEN POS = S + 1 GO TO 21 ENDIF 20 CONTINUE POS = 1 21 DO 22 S = NVAL,POS,-1 SPLIT(S+1) = SPLIT(S) 22 CONTINUE SPLIT(POS) = HA NVAL = NVAL + 1 ENDIF IF (NVAL.EQ.XX) GO TO 11 15 CONTINUE 10 CONTINUE 11 IF (NVAL.GT.0) VAL = SPLIT((NVAL+1)/2) RETURN END SUBROUTINE SMUMPS_MTRANSQ SUBROUTINE SMUMPS_MTRANSR(N,NE,IP,IRN,A) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NE INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NE) REAL, INTENT(INOUT) :: A(NE) INTEGER :: THRESH,TDLEN PARAMETER (THRESH=15,TDLEN=50) INTEGER :: J, LEN, HI INTEGER(8) :: K, IPJ, TD, FIRST, LAST, MID, R, S REAL :: HA, KEY INTEGER(8) :: TODO(TDLEN) DO 100 J = 1,N LEN = int(IP(J+1) - IP(J)) IF (LEN.LE.1) GO TO 100 IPJ = IP(J) IF (LEN.LT.THRESH) GO TO 400 TODO(1) = IPJ TODO(2) = IPJ +int(LEN,8) TD = 2_8 500 CONTINUE FIRST = TODO(TD-1) LAST = TODO(TD) KEY = A((FIRST+LAST)/2) DO 475 K = FIRST,LAST-1 HA = A(K) IF (HA.EQ.KEY) GO TO 475 IF (HA.GT.KEY) GO TO 470 KEY = HA GO TO 470 475 CONTINUE TD = TD - 2_8 GO TO 425 470 MID = FIRST DO 450 K = FIRST,LAST-1 IF (A(K).LE.KEY) GO TO 450 HA = A(MID) A(MID) = A(K) A(K) = HA HI = IRN(MID) IRN(MID) = IRN(K) IRN(K) = HI MID = MID + 1 450 CONTINUE IF (MID-FIRST.GE.LAST-MID) THEN TODO(TD+2) = LAST TODO(TD+1) = MID TODO(TD) = MID ELSE TODO(TD+2) = MID TODO(TD+1) = FIRST TODO(TD) = LAST TODO(TD-1) = MID ENDIF TD = TD + 2_8 425 CONTINUE IF (TD.EQ.0_8) GO TO 400 IF (TODO(TD)-TODO(TD-1).GE.int(THRESH,8)) GO TO 500 TD = TD - 2_8 GO TO 425 400 DO 200 R = IPJ+1_8,IPJ+int(LEN-1,8) IF (A(R-1) .LT. A(R)) THEN HA = A(R) HI = IRN(R) A(R) = A(R-1_8) IRN(R) = IRN(R-1_8) DO 300 S = R-1,IPJ+1_8,-1_8 IF (A(S-1) .LT. HA) THEN A(S) = A(S-1) IRN(S) = IRN(S-1) ELSE A(S) = HA IRN(S) = HI GO TO 200 END IF 300 CONTINUE A(IPJ) = HA IRN(IPJ) = HI END IF 200 CONTINUE 100 CONTINUE RETURN END SUBROUTINE SMUMPS_MTRANSR SUBROUTINE SMUMPS_MTRANSS(M,N,NE,IP,IRN,A,IPERM,NUMX, & W,LEN,LENL,LENH,FC,IW,IW4,RLX,RINF) IMPLICIT NONE INTEGER, INTENT(IN) :: M,N INTEGER(8), INTENT(IN) :: NE INTEGER, INTENT(OUT) :: NUMX INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER :: IRN(NE),IPERM(N), & W(N),LEN(N),LENL(N),LENH(N),FC(N),IW(M),IW4(3*N+M) REAL A(NE),RLX,RINF INTEGER :: NUM,NVAL,WLEN,I,J,L,CNT,MOD, IDUM INTEGER(8) :: K, II, KDUM1, KDUM2 REAL :: BVAL,BMIN,BMAX EXTERNAL SMUMPS_MTRANSQ,SMUMPS_MTRANSU,SMUMPS_MTRANSX DO 20 J = 1,N FC(J) = J LEN(J) = int(IP(J+1) - IP(J)) 20 CONTINUE DO 21 I = 1,M IW(I) = 0 21 CONTINUE CNT = 1 MOD = 1 NUMX = 0 CALL SMUMPS_MTRANSU(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW, & NUMX,N, & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) NUM = NUMX IF (NUM.NE.N) THEN BMAX = RINF ELSE BMAX = RINF DO 30 J = 1,N BVAL = 0.0E0 DO 25 K = IP(J),IP(J+1)-1_8 IF (A(K).GT.BVAL) BVAL = A(K) 25 CONTINUE IF (BVAL.LT.BMAX) BMAX = BVAL 30 CONTINUE BMAX = 1.001E0 * BMAX ENDIF BVAL = 0.0E0 BMIN = 0.0E0 WLEN = 0 DO 48 J = 1,N L = int(IP(J+1) - IP(J)) LENH(J) = L LEN(J) = L DO 45 K = IP(J),IP(J+1)-1_8 IF (A(K).LT.BMAX) GO TO 46 45 CONTINUE K = IP(J+1) 46 LENL(J) = int(K - IP(J)) IF (LENL(J).EQ.L) GO TO 48 WLEN = WLEN + 1 W(WLEN) = J 48 CONTINUE DO 90 KDUM1 = 1_8,NE IF (NUM.EQ.NUMX) THEN DO 50 I = 1,M IPERM(I) = IW(I) 50 CONTINUE DO 80 KDUM2 = 1_8,NE BMIN = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL SMUMPS_MTRANSQ(IP,LENL,LEN,W,WLEN,A,NVAL,BVAL) IF (NVAL.LE.1) GO TO 1000 K = 1 DO 70 IDUM = 1,N IF (K.GT.WLEN) GO TO 71 J = W(K) DO 55 II = IP(J)+int(LEN(J)-1,8), & IP(J)+int(LENL(J),8),-1_8 IF (A(II).GE.BVAL) GO TO 60 I = IRN(II) IF (IW(I).NE.J) GO TO 55 IW(I) = 0 NUM = NUM - 1 FC(N-NUM) = J 55 CONTINUE 60 LENH(J) = LEN(J) LEN(J) = int(II - IP(J) + 1) IF (LENL(J).EQ.LENH(J)) THEN W(K) = W(WLEN) WLEN = WLEN - 1 ELSE K = K + 1 ENDIF 70 CONTINUE 71 IF (NUM.LT.NUMX) GO TO 81 80 CONTINUE 81 MOD = 1 ELSE BMAX = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL SMUMPS_MTRANSQ(IP,LEN,LENH,W,WLEN,A,NVAL,BVAL) IF (NVAL.EQ.0. OR. BVAL.EQ.BMIN) GO TO 1000 K = 1 DO 87 IDUM = 1,N IF (K.GT.WLEN) GO TO 88 J = W(K) DO 85 II = IP(J)+int(LEN(J),8),IP(J)+int(LENH(J)-1,8) IF (A(II).LT.BVAL) GO TO 86 85 CONTINUE 86 LENL(J) = LEN(J) LEN(J) = int(II - IP(J)) IF (LENL(J).EQ.LENH(J)) THEN W(K) = W(WLEN) WLEN = WLEN - 1 ELSE K = K + 1 ENDIF 87 CONTINUE 88 MOD = 0 ENDIF CNT = CNT + 1 CALL SMUMPS_MTRANSU(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW, & NUM,NUMX, & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) 90 CONTINUE 1000 IF (M.EQ.N .and. NUMX.EQ.N) GO TO 2000 CALL SMUMPS_MTRANSX(M,N,IPERM,IW,W) 2000 RETURN END SUBROUTINE SMUMPS_MTRANSS C SUBROUTINE SMUMPS_MTRANSU & (ID,MOD,M,N,IRN,LIRN,IP,LENC,FC,IPERM,NUM,NUMX, & PR,ARP,CV,OUT) IMPLICIT NONE INTEGER :: ID,MOD,M,N,NUM,NUMX INTEGER(8), INTENT(IN) :: LIRN INTEGER :: ARP(N),CV(M),IRN(LIRN), & FC(N),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER(8), INTENT(IN) :: IP(N) INTEGER I,J,J1,JORD,NFC,K,KK, & NUM0,NUM1,NUM2,ID0,ID1,LAST INTEGER(8) :: IN1, IN2, II IF (ID.EQ.1) THEN DO 5 I = 1,M CV(I) = 0 5 CONTINUE DO 6 J = 1,N ARP(J) = 0 6 CONTINUE NUM1 = N NUM2 = N ELSE IF (MOD.EQ.1) THEN DO 8 J = 1,N ARP(J) = 0 8 CONTINUE ENDIF NUM1 = NUMX NUM2 = N - NUMX ENDIF NUM0 = NUM NFC = 0 ID0 = (ID-1)*N DO 100 JORD = NUM0+1,N ID1 = ID0 + JORD J = FC(JORD-NUM0) PR(J) = -1 DO 70 K = 1,JORD IF (ARP(J).GE.LENC(J)) GO TO 30 IN1 = IP(J) + int(ARP(J),8) IN2 = IP(J) + int(LENC(J) - 1,8) DO 20 II = IN1,IN2 I = IRN(II) IF (IPERM(I).EQ.0) GO TO 80 20 CONTINUE ARP(J) = LENC(J) 30 OUT(J) = LENC(J) - 1 DO 60 KK = 1,JORD IN1 = int(OUT(J),8) IF (IN1.LT.0) GO TO 50 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 40 II = IN1,IN2 I = IRN(II) IF (CV(I).EQ.ID1) GO TO 40 J1 = J J = IPERM(I) CV(I) = ID1 PR(J) = J1 OUT(J1) = int(IN2 - II) - 1 GO TO 70 40 CONTINUE 50 J1 = PR(J) IF (J1.EQ.-1) THEN NFC = NFC + 1 FC(NFC) = J IF (NFC.GT.NUM2) THEN LAST = JORD GO TO 101 ENDIF GO TO 100 ENDIF J = J1 60 CONTINUE 70 CONTINUE 80 IPERM(I) = J ARP(J) = int(II - IP(J)) + 1 NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 95 II = IP(J) + int(LENC(J) - OUT(J) - 2,8) I = IRN(II) IPERM(I) = J 90 CONTINUE 95 IF (NUM.EQ.NUM1) THEN LAST = JORD GO TO 101 ENDIF 100 CONTINUE LAST = N 101 DO 110 JORD = LAST+1,N NFC = NFC + 1 FC(NFC) = FC(JORD-NUM0) 110 CONTINUE RETURN END SUBROUTINE SMUMPS_MTRANSU C SUBROUTINE SMUMPS_MTRANSW(M,N,NE,IP,IRN,A,IPERM,NUM, & JPERM,L32,OUT,PR,Q,L,U,D,RINF) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: NE INTEGER :: IRN(NE),IPERM(M),Q(M),L32(max(M,N)) INTEGER(8) :: IP(N+1), PR(N), L(M), JPERM(N), OUT(N) REAL A(NE),U(M),D(M),RINF,RINF3 INTEGER :: I,I0,II,J,JJ,JORD,Q0,QLEN,JDUM,JSP, & UP,LOW,IK INTEGER(8) :: K, KK, KK1, KK2, K0, K1, K2, ISP REAL :: CSP,DI,DMIN,DNEW,DQ0,VJ,RLX LOGICAL :: LORD REAL :: ZERO, ONE PARAMETER (ZERO=0.0E0,ONE=1.0E0) EXTERNAL SMUMPS_MTRANSD, SMUMPS_MTRANSE, & SMUMPS_MTRANSF, SMUMPS_MTRANSX RLX = U(1) RINF3 = U(2) LORD = (JPERM(1).EQ.6) NUM = 0 DO 10 I = 1,N JPERM(I) = 0_8 PR(I) = IP(I) D(I) = RINF 10 CONTINUE DO 15 I = 1,M U(I) = RINF3 IPERM(I) = 0 L(I) = 0_8 15 CONTINUE DO 30 J = 1,N IF (int(IP(J+1)-IP(J)) .GT. N/10 .AND. N.GT.50) GO TO 30 DO 20 K = IP(J),IP(J+1)-1 I = IRN(K) IF (A(K).GT.U(I)) GO TO 20 U(I) = A(K) IPERM(I) = J L(I) = K 20 CONTINUE 30 CONTINUE DO 40 I = 1,M J = IPERM(I) IF (J.EQ.0) GO TO 40 IF (JPERM(J).EQ.0_8) THEN JPERM(J) = L(I) D(J) = U(I) NUM = NUM + 1 ELSEIF (D(J).GT.U(I)) THEN K = JPERM(J) II = IRN(K) IPERM(II) = 0 JPERM(J) = L(I) D(J) = U(I) ELSE IPERM(I) = 0 ENDIF 40 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 45 I = 1,M D(I) = ZERO 45 CONTINUE DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 K1 = IP(J) K2 = IP(J+1) - 1_8 IF (K1.GT.K2) GO TO 95 VJ = RINF DO 50 K = K1,K2 I = IRN(K) DI = A(K) - U(I) IF (DI.GT.VJ) GO TO 50 IF (DI.LT.VJ .OR. DI.EQ.RINF) GO TO 55 IF (IPERM(I).NE.0 .OR. IPERM(I0).EQ.0) GO TO 50 55 VJ = DI I0 = I K0 = K 50 CONTINUE D(J) = VJ K = K0 I = I0 IF (IPERM(I).EQ.0) GO TO 90 DO 60 K = K0,K2 I = IRN(K) IF (A(K)-U(I).GT.VJ) GO TO 60 JJ = IPERM(I) KK1 = PR(JJ) KK2 = IP(JJ+1) - 1_8 IF (KK1.GT.KK2) GO TO 60 DO 70 KK = KK1,KK2 II = IRN(KK) IF (IPERM(II).GT.0) GO TO 70 IF (A(KK)-U(II).LE.D(JJ)) GO TO 80 70 CONTINUE PR(JJ) = KK2 + 1_8 60 CONTINUE GO TO 95 80 JPERM(JJ) = KK IPERM(II) = JJ PR(JJ) = KK + 1_8 90 NUM = NUM + 1 JPERM(J) = K IPERM(I) = J PR(J) = K + 1_8 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = RINF Q(I) = 0 99 CONTINUE DO 100 JORD = 1,N IF (JPERM(JORD).NE.0) GO TO 100 DMIN = RINF QLEN = 0 LOW = M + 1 UP = M + 1 CSP = RINF J = JORD PR(J) = -1_8 DO 115 K = IP(J),IP(J+1)-1_8 I = IRN(K) DNEW = A(K) - U(I) IF (DNEW.GE.CSP) GO TO 115 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = K JSP = J ELSE IF (DNEW.LT.DMIN) DMIN = DNEW D(I) = DNEW QLEN = QLEN + 1 L(QLEN) = K ENDIF 115 CONTINUE Q0 = QLEN QLEN = 0 DO 120 IK = 1,Q0 K = L(IK) I = IRN(K) IF (CSP.LE.D(I)) THEN D(I) = RINF GO TO 120 ENDIF IF (D(I).LE.DMIN) THEN LOW = LOW - 1 L32(LOW) = I Q(I) = LOW ELSE QLEN = QLEN + 1 Q(I) = QLEN CALL SMUMPS_MTRANSD(I,M,L32,D,Q,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = int(J,8) 120 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = L32(1) IF (D(I).LT.RINF) DMIN = D(I)*(ONE+RLX) IF (DMIN.GE.CSP) GO TO 160 152 CALL SMUMPS_MTRANSE(QLEN,M,L32,D,Q,2) LOW = LOW - 1 L32(LOW) = I Q(I) = LOW IF (QLEN.EQ.0) GO TO 153 I = L32(1) IF (D(I).GT.DMIN) GO TO 153 GO TO 152 ENDIF 153 Q0 = L32(UP-1) DQ0 = D(Q0) IF (DQ0.GE.CSP) GO TO 160 IF (DMIN.GE.CSP) GO TO 160 UP = UP - 1 J = IPERM(Q0) VJ = DQ0 - A(JPERM(J)) + U(Q0) K1 = IP(J+1)-1_8 IF (LORD) THEN IF (CSP.NE.RINF) THEN DI = CSP - VJ IF (A(K1).GE.DI) THEN K0 = JPERM(J) IF (K0.GE.K1-6) GO TO 178 177 CONTINUE K = (K0+K1)/2 IF (A(K).GE.DI) THEN K1 = K ELSE K0 = K ENDIF IF (K0.GE.K1-6) GO TO 178 GO TO 177 178 DO 179 K = K0+1,K1 IF (A(K).LT.DI) GO TO 179 K1 = K - 1 GO TO 181 179 CONTINUE ENDIF ENDIF 181 IF (K1.EQ.JPERM(J)) K1 = K1 - 1 ENDIF K0 = IP(J) DI = CSP - VJ DO 155 K = K0,K1 I = IRN(K) IF (Q(I).GE.LOW) GO TO 155 DNEW = A(K) - U(I) IF (DNEW.GE.DI) GO TO 155 DNEW = DNEW + VJ IF (DNEW.GT.D(I)) GO TO 155 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = K JSP = J DI = CSP - VJ ELSE IF (DNEW.GE.D(I)) GO TO 155 D(I) = DNEW IF (DNEW.LE.DMIN) THEN IF (Q(I).NE.0) THEN CALL SMUMPS_MTRANSF(Q(I),QLEN,M,L32,D,Q,2) ENDIF LOW = LOW - 1 L32(LOW) = I Q(I) = LOW ELSE IF (Q(I).EQ.0) THEN QLEN = QLEN + 1 Q(I) = QLEN ENDIF CALL SMUMPS_MTRANSD(I,M,L32,D,Q,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = int(J,8) ENDIF 155 CONTINUE 150 CONTINUE 160 IF (CSP.EQ.RINF) GO TO 190 NUM = NUM + 1 I = IRN(ISP) J = JSP IPERM(I) = J JPERM(J) = ISP DO 170 JDUM = 1,NUM JJ = int(PR(J)) IF (JJ.EQ.-1) GO TO 180 K = OUT(J) I = IRN(K) IPERM(I) = JJ JPERM(JJ) = K J = JJ 170 CONTINUE 180 DO 182 JJ = UP,M I = L32(JJ) U(I) = U(I) + D(I) - CSP 182 CONTINUE 190 DO 191 JJ = UP,M I = L32(JJ) D(I) = RINF Q(I) = 0 191 CONTINUE DO 192 JJ = LOW,UP-1 I = L32(JJ) D(I) = RINF Q(I) = 0 192 CONTINUE DO 193 JJ = 1,QLEN I = L32(JJ) D(I) = RINF Q(I) = 0 193 CONTINUE 100 CONTINUE 1000 CONTINUE DO 1200 J = 1,N K = JPERM(J) IF (K.NE.0) THEN D(J) = A(K) - U(IRN(K)) ELSE D(J) = ZERO ENDIF 1200 CONTINUE DO 1201 I = 1,M IF (IPERM(I).EQ.0) U(I) = ZERO 1201 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL SMUMPS_MTRANSX(M,N,IPERM,Q,L32) 2000 RETURN END SUBROUTINE SMUMPS_MTRANSW SUBROUTINE SMUMPS_MTRANSZ & (M,N,IRN,LIRN,IP,LENC,IPERM,NUM,PR,ARP,CV,OUT) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: LIRN INTEGER :: ARP(N),CV(M),IRN(LIRN),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER(8), INTENT(IN) :: IP(N) C Local variables INTEGER :: I,J,J1,JORD,K,KK INTEGER(8) :: II, IN1, IN2 INTEGER, PARAMETER :: KXX = 100 ! default REAL :: R INTEGER :: MAXNUM EXTERNAL SMUMPS_MTRANSX R = REAL(KXX)/REAL(100) MAXNUM = min(N, INT(N*R)) DO 10 I = 1,M CV(I) = 0 IPERM(I) = 0 10 CONTINUE DO 12 J = 1,N ARP(J) = LENC(J) - 1 12 CONTINUE NUM = 0 DO 1000 JORD = 1,N J = JORD PR(J) = -1 DO 70 K = 1,JORD IN1 = int(ARP(J),8) IF (IN1.LT.0_8) GO TO 30 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 20 II = IN1,IN2 I = IRN(II) IF (IPERM(I).EQ.0) GO TO 80 20 CONTINUE ARP(J) = -1 30 CONTINUE OUT(J) = LENC(J) - 1 DO 60 KK = 1,JORD IN1 = int(OUT(J),8) IF (IN1.LT.0_8) GO TO 50 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 40 II = IN1,IN2 I = IRN(II) IF (CV(I).EQ.JORD) GO TO 40 J1 = J J = IPERM(I) CV(I) = JORD PR(J) = J1 OUT(J1) = int(IN2 - II - 1_8) GO TO 70 40 CONTINUE 50 CONTINUE J = PR(J) IF (J.EQ.-1) GO TO 999 60 CONTINUE 70 CONTINUE 80 CONTINUE IPERM(I) = J ARP(J) = int(IN2 - II - 1_8) NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 999 II = IP(J) + int(LENC(J) - OUT(J) - 2,8) I = IRN(II) IPERM(I) = J 90 CONTINUE 999 CONTINUE IF (KXX.GE.100) GOTO 1000 C we may stop if NUM large enough IF (NUM.GE.MAXNUM) EXIT 1000 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL SMUMPS_MTRANSX(M,N,IPERM,CV,ARP) 2000 RETURN END SUBROUTINE SMUMPS_MTRANSZ SUBROUTINE SMUMPS_MTRANSX(M,N,IPERM,RW,CW) IMPLICIT NONE INTEGER M,N INTEGER RW(M),CW(N),IPERM(M) INTEGER I,J,K INTEGER, PARAMETER :: KXX = 100 INTEGER SIG SIG = -1 IF (KXX.LT.100) SIG = 1 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*SIG 30 CONTINUE DO 40 J = N+1,M K = K + 1 I = RW(K) IPERM(I) = J*SIG 40 CONTINUE RETURN END SUBROUTINE SMUMPS_MTRANSX MUMPS_5.8.1/src/dfac_asm_ELT.F0000664000175000017500000002421315042446440015602 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ELT_ASM_S_2_S_INIT( & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP, KEEP8, MYID, LRGROUPS) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER NELT, N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID INTEGER NBROWS, NBCOLS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER INTARR(KEEP8(27)) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) DOUBLE PRECISION :: A(LA) DOUBLE PRECISION :: DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) INTEGER(8) :: POSELT DOUBLE PRECISION, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL DMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) IF (NASS.LT.0) THEN NASS = -NASS IW(IOLDPS+1+KEEP(IXSZ)) = NASS CALL DMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, FILS, & PTRAIW, PTRARW, & INTARR, DBLARR, KEEP8(27), KEEP8(26), FRT_PTR, FRT_ELT, & RHS_MUMPS, LRGROUPS) ENDIF IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_ELT_ASM_S_2_S_INIT SUBROUTINE DMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW, &IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, PTRARW, &INTARR, DBLARR, LINTARR, LDBLARR, FRT_PTR, FRT_ELT, RHS_MUMPS, &LRGROUPS) !$ USE OMP_LIB USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, intent(in) :: N, NELT, LIW, IOLDPS, INODE INTEGER(8), intent(in) :: LA, POSELT, LINTARR, LDBLARR INTEGER, intent(in) :: IW(LIW) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(inout) :: ITLOC(N+KEEP(253)) DOUBLE PRECISION, intent(inout) :: A(LA) DOUBLE PRECISION, intent(in) :: RHS_MUMPS(KEEP8(85)) INTEGER, intent(in) :: INTARR(LINTARR) DOUBLE PRECISION, intent(in) :: DBLARR(LDBLARR) INTEGER, intent(in) :: FRT_PTR(N+1), FRT_ELT(NELT) INTEGER, intent(in) :: FILS(N) INTEGER(8), intent(in) :: PTRAIW(NELT+1), PTRARW(NELT+1) INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 !$ INTEGER :: CHUNK INCLUDE 'mumps_headers.h' INTEGER :: HF, NBROWF, NBCOLF, NASS, NSLAVES INTEGER :: ILOC, IELL, ELTI, ELBEG, NUMELT INTEGER(8) :: SIZE_ELTI8 INTEGER :: I, J, K, K1, K2 INTEGER :: IPOS, IPOS1, IPOS2, JPOS, IJROW INTEGER :: IN INTEGER(8) :: II8, JJ8, J18, J28 INTEGER(8) :: AINPUT8 INTEGER(8) :: AII8 INTEGER(8) :: APOS, APOS2, ICT12 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE, TOPDIAG INTEGER(8) :: JJ3 INTEGER :: K1RHS, K2RHS, JFirstRHS DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) !$ NOMP = OMP_GET_MAX_THREADS() IF (KEEP(50) .EQ. 0 .OR. NBROWF .LT. KEEP(63)) THEN !$ CHUNK8 = int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8) !$OMP& .AND. NOMP .GT. 1) DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = 0 IF (IW(IOLDPS+XXLR).GE.1) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0, & NBROWF, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) NB_BLR_LS = NPARTSCB call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR_LS) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS, & NBCOLF, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max( KEEP(360)/2, !$ & ((NBROWF+NOMP-1)/NOMP +2) / 3 ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK) !$OMP& IF (NBROWF .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(NBROWF-1,8) APOS = POSELT+ JJ8*int(NBCOLF,8) JJ3 = min( int(NBCOLF,8) - 1_8, & JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG ) A(APOS: APOS+JJ3) = ZERO ENDDO !$OMP END PARALLEL DO ENDIF K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = -JPOS JPOS = JPOS + 1 END DO K1 = IOLDPS + HF K2 = K1 + NBROWF - 1 JPOS = 1 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN K1RHS = 0 K2RHS = -1 DO K = K1, K2 J = IW(K) ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN K1RHS = K JFirstRHS=J-N ENDIF JPOS = JPOS + 1 ENDDO IF (K1RHS.GT.0) K2RHS=K2 IF ( K2RHS.GE.K1RHS ) THEN IN = INODE DO WHILE (IN.GT.0) IJROW = -ITLOC(IN) DO K = K1RHS, K2RHS J = IW(K) I = ITLOC(J) ILOC = mod(I,NBCOLF) APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+ IN) ENDDO IN = FILS(IN) ENDDO ENDIF ELSE DO K = K1, K2 J = IW(K) ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS JPOS = JPOS + 1 END DO ENDIF ELBEG = FRT_PTR(INODE) NUMELT = FRT_PTR(INODE+1) - ELBEG DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1_8 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = ITLOC(INTARR(II8)) IF (KEEP(50).EQ.0) THEN IF (I.LE.0) CYCLE AINPUT8 = AII8 + II8 - J18 IPOS = mod(I,NBCOLF) ICT12 = POSELT + int(IPOS-1,8) * int(NBCOLF,8) DO JJ8 = J18, J28 JPOS = ITLOC(INTARR(JJ8)) IF (JPOS.LE.0) THEN JPOS = -JPOS ELSE JPOS = JPOS/NBCOLF END IF APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ELSE IF ( I .EQ. 0 ) THEN AII8 = AII8 + J28 - II8 + 1_8 CYCLE ENDIF IF ( I .LE. 0 ) THEN IPOS1 = -I IPOS2 = 0 ELSE IPOS1 = I/NBCOLF IPOS2 = mod(I,NBCOLF) END IF ICT12 = POSELT + int(IPOS2-1,8)*int(NBCOLF,8) DO JJ8=II8,J28 AII8 = AII8 + 1_8 J = ITLOC(INTARR(JJ8)) IF ( J .EQ. 0 ) CYCLE IF ( IPOS2.EQ.0 .AND. J.LE.0) CYCLE IF ( J .LE. 0 ) THEN JPOS = -J ELSE JPOS = J/NBCOLF END IF IF ( (IPOS1.GE.JPOS) .AND. (IPOS2.GT.0) ) THEN APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AII8-1_8) END IF IF ( (IPOS1.LT.JPOS) .AND. (J.GT.0) ) THEN IPOS = mod(J,NBCOLF) JPOS = IPOS1 APOS2 = POSELT + int(IPOS-1,8)*int(NBCOLF,8) & + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AII8-1_8) END IF END DO END IF END DO END DO K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 END DO END SUBROUTINE DMUMPS_ASM_SLAVE_ELEMENTS MUMPS_5.8.1/src/smumps_comm_buffer.F0000664000175000017500000032252415042446437017245 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_BUF USE MUMPS_BUF_COMMON, ONLY: BUF_CB, SIZE_RBUF_BYTES, & SIZEofINT, SIZEofREAL, OVHSIZE, BUF_ADJUST, BUF_LOOK, & MUMPS_BUF_SIZE_AVAILABLE PRIVATE INTEGER, SAVE :: BUF_LMAX_ARRAY REAL, DIMENSION(:), ALLOCATABLE & , SAVE, TARGET :: BUF_MAX_ARRAY PUBLIC :: BUF_LMAX_ARRAY, BUF_MAX_ARRAY PUBLIC :: SMUMPS_BUF_DEALL_MAX_ARRAY, & SMUMPS_BUF_MAX_ARRAY_MINSIZE PUBLIC :: SMUMPS_BUF_SEND_CB, & SMUMPS_BUF_SEND_MASTER2SLAVE, & SMUMPS_BUF_SEND_VCB, & SMUMPS_BUF_SEND_MAITRE2, & SMUMPS_BUF_SEND_CONTRIB_TYPE2, & SMUMPS_BUF_SEND_BLOCFACTO, & SMUMPS_BUF_SEND_BLFAC_SLAVE, & SMUMPS_BUF_SEND_CONTRIB_TYPE3, & SMUMPS_BUF_SEND_BACKVEC, & SMUMPS_MPI_UNPACK_LRB CONTAINS SUBROUTINE SMUMPS_BUF_DEALL_MAX_ARRAY() IMPLICIT NONE IF (allocated( BUF_MAX_ARRAY)) DEALLOCATE( BUF_MAX_ARRAY ) RETURN END SUBROUTINE SMUMPS_BUF_DEALL_MAX_ARRAY SUBROUTINE SMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IMPLICIT NONE INTEGER IERR, NFS4FATHER IERR = 0 IF (allocated( BUF_MAX_ARRAY)) THEN IF (BUF_LMAX_ARRAY .GE. NFS4FATHER) RETURN DEALLOCATE( BUF_MAX_ARRAY ) ENDIF BUF_LMAX_ARRAY=max(1,NFS4FATHER) ALLOCATE(BUF_MAX_ARRAY(BUF_LMAX_ARRAY),stat=IERR) IF ( IERR .GT. 0 ) THEN IERR = -1 RETURN END IF RETURN END SUBROUTINE SMUMPS_BUF_MAX_ARRAY_MINSIZE SUBROUTINE SMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, LCONT, & NASS, NPIV, & IWROW, IWCOL, A, PACKED_CB, & DEST, TAG, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER DEST, TAG, COMM, IERR INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER INODE, FPERE, NFRONT, LCONT, NASS, NPIV INTEGER IWROW( LCONT ), IWCOL( LCONT ) REAL A( * ) LOGICAL PACKED_CB INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER NBROWS_PACKET INTEGER POSITION, IREQ, IPOS, I, J1 INTEGER SIZE1, SIZE2, SIZE_PACK, SIZE_AV, SIZE_AV_REALS INTEGER IZERO, IONE INTEGER SIZECB INTEGER LCONT_SENT INTEGER DEST2(1) PARAMETER( IZERO = 0, IONE = 1 ) LOGICAL RECV_BUF_SMALLER_THAN_SEND DOUBLE PRECISION TMP DEST2(1) = DEST IERR = 0 IF (NBROWS_ALREADY_SENT .EQ. 0) THEN CALL MPI_PACK_SIZE( 11 + LCONT + LCONT, MPI_INTEGER, & COMM, SIZE1, IERR_MPI) ELSE CALL MPI_PACK_SIZE( 5, MPI_INTEGER, COMM, SIZE1, IERR_MPI) ENDIF CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE SIZE_AV = SIZE_RBUF_BYTES RECV_BUF_SMALLER_THAN_SEND = .TRUE. ENDIF SIZE_AV_REALS = ( SIZE_AV - SIZE1 ) / SIZEofREAL IF (SIZE_AV_REALS < 0 ) THEN NBROWS_PACKET = 0 ELSE IF (PACKED_CB) THEN TMP=2.0D0*dble(NBROWS_ALREADY_SENT)+1.0D0 NBROWS_PACKET = int( & ( sqrt( TMP * TMP & + 8.0D0 * dble(SIZE_AV_REALS)) - TMP ) & / 2.0D0 ) ELSE IF (LCONT.EQ.0) THEN NBROWS_PACKET = 0 ELSE NBROWS_PACKET = SIZE_AV_REALS / LCONT ENDIF ENDIF ENDIF 10 CONTINUE NBROWS_PACKET = max(0, & min(NBROWS_PACKET, LCONT - NBROWS_ALREADY_SENT)) IF (NBROWS_PACKET .EQ. 0 .AND. LCONT .NE. 0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (PACKED_CB) THEN SIZECB = (NBROWS_ALREADY_SENT*NBROWS_PACKET)+(NBROWS_PACKET & *(NBROWS_PACKET+1))/2 ELSE SIZECB = NBROWS_PACKET * LCONT ENDIF CALL MPI_PACK_SIZE( SIZECB, MPI_REAL, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV ) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF (NBROWS_PACKET > 0) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.LCONT .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 10 & .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , DEST2) IF (IERR .EQ. -1 .OR. IERR .EQ. -2) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF ( NBROWS_PACKET > 0 ) GOTO 10 ENDIF IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (PACKED_CB) THEN LCONT_SENT=-LCONT ELSE LCONT_SENT=LCONT ENDIF CALL MPI_PACK( LCONT_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NBROWS_ALREADY_SENT == 0) THEN CALL MPI_PACK( LCONT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NASS-NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LCONT , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IONE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IWROW, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IWCOL, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF IF ( LCONT .NE. 0 ) THEN J1 = 1 + NBROWS_ALREADY_SENT * NFRONT IF (PACKED_CB) THEN DO I = NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( A( J1 ), I, MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) J1 = J1 + NFRONT END DO ELSE DO I = NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( A( J1 ), LCONT, MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) J1 = J1 + NFRONT END DO ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN WRITE(*,*) 'Error Try_send_cb: SIZE, POSITION=',SIZE_PACK, & POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET IF (NBROWS_ALREADY_SENT .NE. LCONT ) THEN IERR = -1 RETURN ENDIF 100 CONTINUE RETURN END SUBROUTINE SMUMPS_BUF_SEND_CB SUBROUTINE SMUMPS_BUF_SEND_MASTER2SLAVE( NRHS, INODE, IFATH, & EFF_CB_SIZE, LD_CB, LD_PIV, NPIV, & JBDEB, JBFIN, & CB, SOL, & DEST, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER NRHS, INODE, IFATH, EFF_CB_SIZE, LD_CB, LD_PIV, NPIV INTEGER DEST, COMM, IERR, JBDEB, JBFIN REAL CB( LD_CB*(NRHS-1)+EFF_CB_SIZE ) REAL SOL( max(1, LD_PIV*(NRHS-1)+NPIV) ) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE, SIZE1, SIZE2, K INTEGER POSITION, IREQ, IPOS INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 CALL MPI_PACK_SIZE( 6, MPI_INTEGER, COMM, SIZE1, IERR ) CALL MPI_PACK_SIZE( NRHS * (EFF_CB_SIZE + NPIV), & MPI_REAL, COMM, & SIZE2, IERR_MPI ) SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IFATH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( EFF_CB_SIZE , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPIV , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBDEB , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBFIN , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) DO K = 1, NRHS CALL MPI_PACK( CB ( 1 + LD_CB * (K-1) ), & EFF_CB_SIZE, MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) END DO IF ( NPIV .GT. 0 ) THEN DO K=1, NRHS CALL MPI_PACK( SOL(1+LD_PIV*(K-1)), & NPIV, MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDDO END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, Master2Slave, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) 'Try_send_master2slave: SIZE, POSITION = ', & SIZE, POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE SMUMPS_BUF_SEND_MASTER2SLAVE SUBROUTINE SMUMPS_BUF_SEND_VCB( NRHS_B, NODE1, NODE2, NCB, LDW, & LONG, & IW, W, JBDEB, JBFIN, & RHSINTR, NRHS, LRHSINTR, IPOSINRHSINTR, NPIV, & KEEP, & DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER LDW, DEST, TAG, COMM, IERR INTEGER NRHS_B, NODE1, NODE2, NCB, LONG, JBDEB, JBFIN INTEGER IW( max( 1, LONG ) ) INTEGER, INTENT(IN) :: LRHSINTR, NRHS, IPOSINRHSINTR, NPIV REAL W( max( 1, LDW * NRHS_B ) ) REAL RHSINTR(LRHSINTR,NRHS) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS INTEGER SIZE1, SIZE2, SIZE, K INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1)=DEST IERR = 0 IF ( NODE2 .EQ. 0 ) THEN CALL MPI_PACK_SIZE( 4+LONG, MPI_INTEGER, COMM, SIZE1, & IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 6+LONG, MPI_INTEGER, COMM, SIZE1, & IERR_MPI ) END IF SIZE2 = 0 IF ( LONG .GT. 0 ) THEN CALL MPI_PACK_SIZE( NRHS_B*LONG, MPI_REAL, & COMM, SIZE2, IERR_MPI ) END IF SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = 0 CALL MPI_PACK( NODE1, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF ( NODE2 .NE. 0 ) THEN CALL MPI_PACK( NODE2, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( JBDEB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBFIN, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LONG, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF ( LONG .GT. 0 ) THEN CALL MPI_PACK( IW, LONG, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF (NODE2.EQ.0) THEN DO K=1, NRHS_B IF (NPIV.GT.0) THEN CALL MPI_PACK( RHSINTR(IPOSINRHSINTR,JBDEB+K-1), NPIV, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF IF (LONG-NPIV .NE.0) THEN CALL MPI_PACK( W(NPIV+1+(K-1)*LDW), LONG-NPIV, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF END DO ELSE DO K=1, NRHS_B CALL MPI_PACK( W(1+(K-1)*LDW), LONG, MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) END DO ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE SMUMPS_BUF_SEND_VCB SUBROUTINE SMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, & IPERE, ISON, NROW, & IROW, NCOL, ICOL, VAL, LDA, NELIM, TYPE_SON, & NSLAVES, SLAVES, DEST, COMM, IERR, & & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER LDA, NELIM, TYPE_SON INTEGER IPERE, ISON, NROW, NCOL, NSLAVES INTEGER IROW( NROW ) INTEGER ICOL( NCOL ) INTEGER SLAVES( NSLAVES ) REAL VAL(LDA, *) INTEGER IPOS, IREQ, DEST, COMM, IERR INTEGER SLAVEF, KEEP(500), INIV2 INTEGER(8) KEEP8(150) INTEGER TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE1, SIZE2, SIZE3, SIZE_PACK, POSITION, I INTEGER NBROWS_PACKET, NCOL_SEND INTEGER SIZE_AV LOGICAL RECV_BUF_SMALLER_THAN_SEND INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 IF ( NELIM .NE. NROW ) THEN WRITE(*,*) 'Error in TRY_SEND_MAITRE2:',NELIM, NROW CALL MUMPS_ABORT() END IF IF (NBROWS_ALREADY_SENT .EQ. 0) THEN CALL MPI_PACK_SIZE( NROW+NCOL+7+NSLAVES, MPI_INTEGER, & COMM, SIZE1, IERR_MPI ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK_SIZE( NSLAVES+1, MPI_INTEGER, & COMM, SIZE3, IERR_MPI ) ELSE SIZE3 = 0 ENDIF SIZE1=SIZE1+SIZE3 ELSE CALL MPI_PACK_SIZE(7, MPI_INTEGER,COMM,SIZE1,IERR_MPI) ENDIF IF ( KEEP(50).ne.0 .AND. TYPE_SON .eq. 2 ) THEN NCOL_SEND = NROW ELSE NCOL_SEND = NCOL ENDIF CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF IF (NROW .GT. 0 ) THEN NBROWS_PACKET = (SIZE_AV - SIZE1) / NCOL_SEND / SIZEofREAL NBROWS_PACKET = min(NBROWS_PACKET, NROW - NBROWS_ALREADY_SENT) NBROWS_PACKET = max(NBROWS_PACKET, 0) ELSE NBROWS_PACKET =0 ENDIF IF (NBROWS_PACKET .EQ. 0 .AND. NROW .NE. 0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR=-1 GOTO 100 ENDIF ENDIF 10 CONTINUE CALL MPI_PACK_SIZE( NBROWS_PACKET * NCOL_SEND, & MPI_REAL, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF ( NBROWS_PACKET .GT. 0 ) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NROW .AND. & SIZE_PACK - SIZE1 .LT. ( SIZE_RBUF_BYTES - SIZE1 ) / 10 & .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN GOTO 100 ENDIF POSITION = 0 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSLAVES, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NBROWS_ALREADY_SENT .EQ. 0) THEN IF (NSLAVES.GT.0) THEN CALL MPI_PACK( SLAVES, NSLAVES, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( IROW, NROW, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ICOL, NCOL, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK( TAB_POS_IN_PERE(1,INIV2), NSLAVES+1, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF IF (NBROWS_PACKET.GE.1) THEN DO I=NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( VAL(1,I), NCOL_SEND, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO ENDIF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, MAITRE2, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN write(*,*) 'Try_send_maitre2, SIZE,POSITION=', & SIZE_PACK,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET IF ( NBROWS_ALREADY_SENT .NE. NROW ) THEN IERR = -1 ENDIF 100 CONTINUE RETURN END SUBROUTINE SMUMPS_BUF_SEND_MAITRE2 SUBROUTINE SMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESC_IN_LU, & IPERE, NFRONT_PERE, NASS_PERE, NFS4FATHER, NSLAVES_PERE, & ISON, NBROW, LMAP, MAPROW, POS_FIRST_ROW_TO_PDEST, & IW_CBSON, A_CBSON, LA_CBSON, & ISLAVE, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP253_LOC, NVSCHUR, & SON_NIV, MYID ) USE SMUMPS_LR_TYPE USE SMUMPS_LR_DATA_M USE MUMPS_BUF_COMMON IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT(inout):: NBCOLS_ALREADY_SENT, & NBLRB_ALREADY_SENT INTEGER, INTENT (in) :: KEEP253_LOC, NVSCHUR INTEGER, INTENT (in) :: SON_NIV INTEGER, INTENT(in) :: POS_FIRST_ROW_TO_PDEST INTEGER IPERE, ISON, NBROW, MYID INTEGER PDEST, ISLAVE, COMM, IERR INTEGER PDEST_MASTER, NASS_PERE, NSLAVES_PERE, & NFRONT_PERE, LMAP INTEGER MAPROW( LMAP ) INTEGER IW_CBSON( * ) REAL A_CBSON( : ) INTEGER(8) :: LA_CBSON LOGICAL DESC_IN_LU, PACKED_CB INTEGER KEEP(500), N , SLAVEF INTEGER(8) KEEP8(150) INTEGER STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER NFS4FATHER,SIZE3,PS1,NCA,LROW1 INTEGER(8) :: ASIZE LOGICAL COMPUTE_MAX REAL, POINTER, DIMENSION(:) :: M_ARRAY INTEGER NBROWS_PACKET INTEGER NBLRB_TOTAL INTEGER NBLRB_PACKET INTEGER MAX_ROW_LENGTH INTEGER LROW, NELIM INTEGER(8) :: ITMP8 INTEGER NPIV, NFRONT, HS INTEGER SIZE_PACK, SIZE0, SIZE1, SIZE2, POSITION,I INTEGER SIZE_INTEGERS, B, SIZE_REALS, TMPSIZE, ONEorTWO, SIZE_AV INTEGER SIZE_NEXT_BLOCK 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 LOGICAL AVOID_TOO_SMALL_GRANULARITY INTEGER PDEST2(1) LOGICAL CB_IS_LR TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL, & BEGS_BLR_STA INTEGER :: NB_ROW_SHIFT, NB_COL_SHIFT, NASS_SHIFT, PANEL2SEND, & CURRENT_PANEL_SIZE, NB_BLR_ROWS, NB_BLR_COLS, & CB_IS_LR_INT, NCOL_SHIFT, NROW_SHIFT, & PANEL_BEG_OFFSET INTEGER :: NPIV_LR, LNEXT REAL :: K170PER1000 PARAMETER ( IONE=1 ) INCLUDE 'mumps_headers.h' REAL ZERO PARAMETER (ZERO = 0.0E0) CB_IS_LR = (IW_CBSON(1+XXLR).EQ.1 & .OR. IW_CBSON(1+XXLR).EQ.3) NBLRB_PACKET = 0 NBLRB_TOTAL = 0 IF (CB_IS_LR) THEN CB_IS_LR_INT = 1 ELSE CB_IS_LR_INT = 0 ENDIF AVOID_TOO_SMALL_GRANULARITY = .TRUE. IF (KEEP(173).EQ.1) AVOID_TOO_SMALL_GRANULARITY = .FALSE. COMPUTE_MAX = (KEEP(219) .NE. 0) .AND. & (KEEP(50) .EQ. 2) .AND. & (PDEST.EQ.PDEST_MASTER) & .AND. (NBCOLS_ALREADY_SENT.EQ.0) & .AND. (NBROWS_ALREADY_SENT.EQ.0) IF (COMPUTE_MAX) THEN CALL SMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERR = -4 RETURN ENDIF ENDIF PDEST2(1) = PDEST IERR = 0 LROW = IW_CBSON( 1 + KEEP(IXSZ)) NELIM = IW_CBSON( 2 + KEEP(IXSZ)) NPIV = IW_CBSON( 4 + KEEP(IXSZ)) IF ( NPIV .LT. 0 ) THEN NPIV = 0 END IF NROW = IW_CBSON( 3 + KEEP(IXSZ)) NFRONT = LROW + NPIV HS = 6 + IW_CBSON( 6 + KEEP(IXSZ)) + KEEP(IXSZ) IF (CB_IS_LR.AND.NBROW.GT.0) THEN CALL SMUMPS_BLR_RETRIEVE_CB_LRB(IW_CBSON(1+XXF), CB_LRB) IF (SON_NIV.EQ.1) THEN CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW_CBSON(1+XXF), & BEGS_BLR_ROW) CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_DYN(IW_CBSON(1+XXF), & BEGS_BLR_COL) NB_BLR_ROWS = size(BEGS_BLR_ROW) - 1 CALL SMUMPS_BLR_RETRIEVE_NB_PANELS(IW_CBSON(1+XXF), & NB_COL_SHIFT) NB_ROW_SHIFT = NB_COL_SHIFT NASS_SHIFT = BEGS_BLR_ROW(NB_ROW_SHIFT+1)-1 NPIV_LR = BEGS_BLR_COL(NB_COL_SHIFT+1)-1 ELSE NPIV_LR=NPIV CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW_CBSON(1+XXF), & BEGS_BLR_STA) NB_BLR_ROWS = size(BEGS_BLR_STA) - 2 BEGS_BLR_ROW => BEGS_BLR_STA(2:NB_BLR_ROWS+2) CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_C(IW_CBSON(1+XXF), & BEGS_BLR_COL, NB_COL_SHIFT) NASS_SHIFT = 0 NB_ROW_SHIFT = 0 ENDIF PANEL2SEND = -1 DO I=NB_ROW_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR_ROW(I+1)-1-NASS_SHIFT & .GT.NBROWS_ALREADY_SENT+POS_FIRST_ROW_TO_PDEST-1) THEN PANEL2SEND = I EXIT ENDIF ENDDO IF (PANEL2SEND.EQ.-1) THEN write(*,*) 'Internal error: PANEL2SEND not found' CALL MUMPS_ABORT() ENDIF CURRENT_PANEL_SIZE = BEGS_BLR_ROW(PANEL2SEND+1) & - BEGS_BLR_ROW(PANEL2SEND) PANEL_BEG_OFFSET = POS_FIRST_ROW_TO_PDEST + & NBROWS_ALREADY_SENT - & BEGS_BLR_ROW(PANEL2SEND) + NASS_SHIFT IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR_COL) - 1 ELSEIF (SON_NIV.EQ.1) THEN NB_BLR_COLS = PANEL2SEND ELSE NB_BLR_COLS = -1 NCOL_SHIFT = NPIV_LR NROW_SHIFT = LROW - NROW DO I=NB_COL_SHIFT+1,size(BEGS_BLR_COL)-1 IF (BEGS_BLR_COL(I+1)-NCOL_SHIFT.GT. & ( min ( & BEGS_BLR_ROW(PANEL2SEND+1)-POS_FIRST_ROW_TO_PDEST, & NBROW & ) & + NROW_SHIFT + POS_FIRST_ROW_TO_PDEST-1 ) & ) THEN NB_BLR_COLS = I EXIT ENDIF ENDDO IF (NB_BLR_COLS.EQ.-1) THEN write(*,*) 'Internal error: NB_BLR_COLS not found' CALL MUMPS_ABORT() ENDIF MAX_ROW_LENGTH = BEGS_BLR_ROW(PANEL2SEND)-1+NROW_SHIFT & + min(NBROW-NBROWS_ALREADY_SENT + PANEL_BEG_OFFSET, & CURRENT_PANEL_SIZE) ENDIF NBLRB_TOTAL = NB_BLR_COLS - NB_COL_SHIFT ENDIF STATE_SON = IW_CBSON(1+XXS) IF (STATE_SON .EQ. S_NOLCBCONTIG) THEN LDA_SON8 = int(LROW,8) SHIFTCB_SON = int(NPIV,8)*int(NROW,8) ELSE IF (STATE_SON .EQ. S_NOLCLEANED) THEN LDA_SON8 = int(LROW,8) SHIFTCB_SON = 0_8 ELSE LDA_SON8 = int(NFRONT,8) SHIFTCB_SON = int(NPIV,8) ENDIF CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (PDEST .EQ. PDEST_MASTER) THEN SIZE_DESC_BANDE=0 ELSE SIZE_DESC_BANDE=(11+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, & 11+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(COMPUTE_MAX) THEN CALL MPI_PACK_SIZE(1, MPI_INTEGER, & COMM, SIZE0, IERR_MPI ) IF(NFS4FATHER .GT. 0) THEN CALL MPI_PACK_SIZE( NFS4FATHER, MPI_REAL, & COMM, SIZE1, IERR_MPI ) ENDIF SIZE1 = SIZE1+SIZE0 ENDIF ONEorTWO = 1 IF (PDEST .EQ.PDEST_MASTER) THEN L = 0 ELSE IF (KEEP(50) .EQ. 0) THEN L = LROW ELSE L = LROW + POS_FIRST_ROW_TO_PDEST-LMAP+NBROWS_ALREADY_SENT-1 ONEorTWO=ONEorTWO+1 ENDIF NBINT = 6 + L + 1 IF (CB_IS_LR.AND.NBROW.GT.0) THEN NBINT = NBINT + 4*(NB_BLR_COLS-NB_COL_SHIFT) + 3 ENDIF CALL MPI_PACK_SIZE( NBINT, MPI_INTEGER, & COMM, TMPSIZE, IERR_MPI ) SIZE1 = SIZE1 + TMPSIZE SIZE_AV = SIZE_AV - SIZE1 NOT_ENOUGH_SPACE=.FALSE. IF (SIZE_AV .LT.0 ) THEN NBROWS_PACKET = 0 NOT_ENOUGH_SPACE=.TRUE. ELSE IF ( KEEP(50) .EQ. 0 ) THEN NBROWS_PACKET = & SIZE_AV / ( ONEorTWO*SIZEofINT+LROW*SIZEofREAL) ELSE B = 2 * ONEorTWO + & ( -1 + 2 * LROW + 2 * POS_FIRST_ROW_TO_PDEST -2*LMAP & + 2 * NBROWS_ALREADY_SENT ) & * SIZEofREAL / SIZEofINT NBROWS_PACKET=int((dble(-B)+sqrt((dble(B)*dble(B))+ & dble(4)*dble(2)*dble(SIZE_AV)/dble(SIZEofINT) * & dble(SIZEofREAL/SIZEofINT)))* & dble(SIZEofINT) / dble(2) / dble(SIZEofREAL)) ENDIF ENDIF 10 CONTINUE SIZE_NEXT_BLOCK = 0 IF (CB_IS_LR) THEN IF ( NBROW .GT. 0) THEN NBROWS_PACKET = CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET ELSE NBROWS_PACKET = 0 ENDIF ENDIF NBROWS_PACKET = max( 0, NBROWS_PACKET) NBROWS_PACKET = min(NBROW-NBROWS_ALREADY_SENT, NBROWS_PACKET) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE .OR. & (NBROWS_PACKET .EQ.0.AND. NBROW.NE.0) IF (CB_IS_LR.AND.NBROW.GT.0.AND..NOT.NOT_ENOUGH_SPACE) THEN CALL MPI_PACK_SIZE( ONEorTWO* NBROWS_PACKET, MPI_INTEGER, & COMM, TMPSIZE, IERR_MPI ) CALL SMUMPS_BLR_GET_SIZEREALS_CB_LRB( & SIZE_AV-TMPSIZE, CB_LRB, & NB_ROW_SHIFT, PANEL2SEND, & NBLRB_ALREADY_SENT, NBLRB_TOTAL, & NBLRB_PACKET, SIZE_REALS, SIZE_NEXT_BLOCK & , KEEP(173) & ) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE.OR.(NBLRB_PACKET.EQ.0) ENDIF IF ( (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NBROW) .AND. & .NOT.CB_IS_LR & ) THEN IF (KEEP(50).EQ.0) THEN LNEXT = LROW + 1 ELSE MAX_ROW_LENGTH = LROW + POS_FIRST_ROW_TO_PDEST - LMAP & + NBROWS_ALREADY_SENT & + NBROWS_PACKET-1 LNEXT = MAX_ROW_LENGTH + 1 ENDIF LNEXT = LNEXT + ONEorTWO CALL MPI_PACK_SIZE( LNEXT, & MPI_REAL, & COMM, SIZE_NEXT_BLOCK, IERR_MPI ) ENDIF IF (SIZE_NEXT_BLOCK.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF IF (NOT_ENOUGH_SPACE) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (CB_IS_LR.AND.NBROW.GT.0) THEN IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 ELSEIF (SON_NIV.EQ.1) THEN MAX_ROW_LENGTH = LROW+POS_FIRST_ROW_TO_PDEST -LMAP & + NBROWS_ALREADY_SENT & + NBROWS_PACKET-1 ENDIF ELSE IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 SIZE_REALS = NBROWS_PACKET * LROW ELSE SIZE_REALS = ( LROW + POS_FIRST_ROW_TO_PDEST - LMAP & + NBROWS_ALREADY_SENT ) * & NBROWS_PACKET + ( NBROWS_PACKET * & ( NBROWS_PACKET - 1) ) / 2 MAX_ROW_LENGTH = LROW + POS_FIRST_ROW_TO_PDEST - LMAP & + NBROWS_ALREADY_SENT & + NBROWS_PACKET-1 ENDIF ENDIF SIZE_INTEGERS = ONEorTWO* NBROWS_PACKET CALL MPI_PACK_SIZE( SIZE_REALS, MPI_REAL, & COMM, SIZE2, IERR_MPI ) CALL MPI_PACK_SIZE( SIZE_INTEGERS, MPI_INTEGER, & COMM, SIZE3, IERR_MPI ) IF (SIZE2 + SIZE3 .GT. SIZE_AV .AND. .NOT.CB_IS_LR) THEN NBROWS_PACKET = NBROWS_PACKET -1 IF (NBROWS_PACKET .GT. 0 .AND..NOT.CB_IS_LR) THEN GOTO 10 ENDIF IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF SIZE_PACK = SIZE1 + SIZE2 + SIZE3 K170PER1000 = real(min(KEEP(170),500))/real(1000) IF ( .NOT.CB_IS_LR & .AND. (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NBROW) & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND & .AND. ( SIZE_PACK .LT. & int(real(SIZE_RBUF_BYTES)*K170PER1000) ) & .AND. & ( int(SIZE_PACK,8) + int(SIZE_NEXT_BLOCK,8) .LE. & int(SIZE_RBUF_BYTES,8) ) & ) THEN IERR = -1 GOTO 100 ENDIF IF ( CB_IS_LR.AND. & ( NBROWS_PACKET.NE.0 ).AND. & ( NBLRB_ALREADY_SENT+NBLRB_PACKET.NE. NBLRB_TOTAL ) & .AND. ( SIZE_PACK .LT. & int(real(SIZE_RBUF_BYTES)*K170PER1000) ) & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND & .AND. AVOID_TOO_SMALL_GRANULARITY & .AND. ( & int(SIZE_PACK,8) + int(SIZE_NEXT_BLOCK,8) .LE. & int(SIZE_RBUF_BYTES,8) ) & ) THEN IERR = -1 GOTO 100 ENDIF IF (SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , PDEST2) IF (IERR .EQ. -1 .OR. IERR.EQ. -2) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF (NBROWS_PACKET > 0 ) GOTO 10 ENDIF IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (KEEP(50)==0) THEN CALL MPI_PACK( LROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE IF (CB_IS_LR.AND. & NBLRB_ALREADY_SENT+NBLRB_PACKET .EQ. NBLRB_TOTAL) THEN CALL MPI_PACK( -MAX_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE CALL MPI_PACK( MAX_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( CB_IS_LR_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF ( PDEST .NE. PDEST_MASTER ) THEN IF (KEEP(50)==0) THEN CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), LROW, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE IF (MAX_ROW_LENGTH > 0) THEN CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), & MAX_ROW_LENGTH, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF END IF DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = POS_FIRST_ROW_TO_PDEST + J -1 INDICE_PERE=MAPROW(I) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IPERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE CALL MPI_PACK( INDICE_PERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO IF (CB_IS_LR.AND.(NBROW.GT.0)) THEN CALL SMUMPS_BLR_PACK_CB_LRB( & CB_LRB, NB_ROW_SHIFT, & NBCOLS_ALREADY_SENT, & NBLRB_ALREADY_SENT, NBLRB_PACKET, & PANEL2SEND, & PANEL_BEG_OFFSET+1, PANEL_BEG_OFFSET+NBROWS_PACKET, & BUF_CB%CONTENT(IPOS:), & SIZE_PACK, POSITION, COMM, IERR & ) GOTO 200 ENDIF DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = POS_FIRST_ROW_TO_PDEST + J -1 IF (KEEP(50).ne.0) THEN THIS_ROW_LENGTH = LROW + I - LMAP ELSE THIS_ROW_LENGTH = LROW ENDIF IF (DESC_IN_LU) THEN IF ( PACKED_CB ) THEN IF (NELIM.EQ.0) THEN ITMP8 = int(I,8) ELSE ITMP8 = int(NELIM+I,8) ENDIF APOS = ITMP8 * (ITMP8-1_8) / 2_8 + 1_8 ELSE APOS = int(I+NELIM-1, 8) * int(LROW,8) + 1_8 ENDIF ELSE IF ( PACKED_CB ) THEN IF ( LROW .EQ. NROW ) THEN ITMP8 = int(I,8) APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 ELSE ITMP8 = int(I + LROW - NROW,8) APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 - & int(LROW - NROW, 8) * int(LROW-NROW+1,8) / 2_8 ENDIF ELSE APOS = int( I - 1, 8 ) * LDA_SON8 + SHIFTCB_SON + 1_8 ENDIF ENDIF CALL MPI_PACK( A_CBSON( APOS ), THIS_ROW_LENGTH, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO 200 CONTINUE IF (COMPUTE_MAX) THEN CALL MPI_PACK(NFS4FATHER,1, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NFS4FATHER .GT. 0) THEN IF (CB_IS_LR) THEN CALL SMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW_CBSON(1+XXF), M_ARRAY) CALL MPI_PACK(M_ARRAY(1), NFS4FATHER, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL SMUMPS_BLR_FREE_M_ARRAY ( IW_CBSON(1+XXF) ) ELSE BUF_MAX_ARRAY(1:NFS4FATHER) = ZERO IF(MAPROW(NROW) .GT. NASS_PERE) THEN DO PS1=1,NROW IF(MAPROW(PS1).GT.NASS_PERE) EXIT ENDDO IF (DESC_IN_LU) THEN IF (PACKED_CB) THEN APOS = int(NELIM+PS1,8) * int(NELIM+PS1-1,8) / & 2_8 + 1_8 NCA = -44444 ASIZE = int(NROW,8) * int(NROW+1,8)/2_8 - & int(NELIM+PS1,8) * int(NELIM+PS1-1,8)/2_8 LROW1 = PS1 + NELIM ELSE APOS = int(PS1+NELIM-1,8) * int(LROW,8) + 1_8 NCA = LROW ASIZE = int(NCA,8) * int(NROW-PS1+1,8) LROW1 = LROW ENDIF ELSE IF (PACKED_CB) THEN IF (NPIV.NE.0) THEN WRITE(*,*) "Error in PARPIV/SMUMPS_BUF_SEND_CONTRIB_TYPE2" CALL MUMPS_ABORT() ENDIF LROW1=LROW-NROW+PS1 ITMP8 = int(PS1 + LROW - NROW,8) APOS = ITMP8 * (ITMP8 - 1_8) / 2_8 + 1_8 - & int(LROW-NROW,8)*int(LROW-NROW+1,8)/2_8 ASIZE = int(LROW,8)*int(LROW+1,8)/2_8 - & ITMP8*(ITMP8-1_8)/2_8 NCA = -555555 ELSE APOS = int(PS1-1,8) * LDA_SON8 + 1_8 + SHIFTCB_SON NCA = int(LDA_SON8) ASIZE = LA_CBSON - APOS + 1_8 LROW1=-666666 ENDIF ENDIF IF ( NROW-PS1+1-KEEP253_LOC-NVSCHUR .GT. 0 ) THEN CALL SMUMPS_COMPUTE_MAXPERCOL( & A_CBSON(APOS),ASIZE,NCA, & NROW-PS1+1-KEEP253_LOC-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB,LROW1) ENDIF ENDIF CALL MPI_PACK(BUF_MAX_ARRAY, NFS4FATHER, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF ENDIF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & PDEST, CONTRIB_TYPE2, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE_PACK.LT. POSITION ) THEN WRITE(*,*) ' contniv2: SIZE, POSITION =',SIZE_PACK, POSITION WRITE(*,*) ' NBROW, LROW = ', NBROW, LROW CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) IF (CB_IS_LR) THEN IF (NBLRB_ALREADY_SENT+NBLRB_PACKET.EQ.NBLRB_TOTAL) THEN NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ELSE NBLRB_ALREADY_SENT = NBLRB_ALREADY_SENT + NBLRB_PACKET ENDIF ELSE NBROWS_ALREADY_SENT=NBROWS_ALREADY_SENT + NBROWS_PACKET ENDIF IF (NBROWS_ALREADY_SENT .NE. NBROW ) THEN IERR = -1 ENDIF 100 CONTINUE RETURN END SUBROUTINE SMUMPS_BUF_SEND_CONTRIB_TYPE2 SUBROUTINE SMUMPS_BUF_SEND_BLOCFACTO( INODE, NFRONT, & NCOL, NPIV, FPERE, LASTPANEL, IPIV, VAL, & PDEST, NDEST, KEEP, NB_BLOC_FAC, & NSLAVES_TOT, WIDTH, COMM, & NELIM, NPARTSASS, CURRENT_BLR_PANEL, & LR_ACTIVATED, BLR_LorU, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & IBEG_PANEL, COMPRESS_CB, & ICNTL, IERR ) USE SMUMPS_LR_TYPE IMPLICIT NONE INTEGER, intent(in) :: INODE, NCOL, NPIV, & FPERE, NFRONT, NDEST INTEGER, intent(in) :: IPIV( NPIV ) REAL, intent(in) :: VAL( NFRONT, * ) INTEGER, intent(in) :: PDEST( NDEST ) INTEGER, intent(inout) :: KEEP(500) INTEGER, intent(in) :: NB_BLOC_FAC, & NSLAVES_TOT, COMM, WIDTH LOGICAL, intent(in) :: LASTPANEL LOGICAL, intent(in) :: COMPRESS_CB LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(in) :: NELIM, NPARTSASS, CURRENT_BLR_PANEL, & IBEG_PANEL TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(inout) :: IERR INTEGER, INTENT(inout):: NBCOLS_ALREADY_SENT, & NBLRB_ALREADY_SENT INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE3, SIZET, & IDEST, IPOSMSG, I, SIZE_MSG_BYTES LOGICAL OVERFLOW INTEGER(8) :: SIZE2_8, SIZE3_8, SIZET_8, SIZE_OVERFLOW INTEGER NPIVSENT INTEGER :: LP LOGICAL :: LPOK LOGICAL :: RECV_BUF_SMALLER_THAN_SEND, NOT_ENOUGH_SPACE INTEGER :: DEST_BLOCFACTO, TAG_BLOCFACTO INTEGER :: LR_ACTIVATED_INT INTEGER :: NBINT, SIZE_AV, SIZE_AV_ADJUSTED INTEGER :: JBEG_BLOCK, NCOL_SEND, NCOL_MAX, & SIZE_BLR_LorU_SENT, NCOL_DIAG, NEWCOL_SENT INTEGER :: NBLRB_PACKET, SIZE_NEXT_BLOCK LOGICAL :: AVOID_TOO_SMALL_GRANULARITY INTEGER, PARAMETER :: kmaxcol=3 REAL :: K170PER1000 LP = ICNTL( 1 ) LPOK = ( LP.GT.0 .AND. ICNTL(4).GE.1 ) IERR = 0 OVERFLOW = .FALSE. NOT_ENOUGH_SPACE = .FALSE. NBLRB_PACKET = -9988 NCOL_DIAG = -9988 AVOID_TOO_SMALL_GRANULARITY = .TRUE. IF (KEEP(173).EQ.1) AVOID_TOO_SMALL_GRANULARITY = .FALSE. SIZE_OVERFLOW = 0_8 JBEG_BLOCK = NBCOLS_ALREADY_SENT + 1 NCOL_SEND = NCOL - JBEG_BLOCK + 1 NEWCOL_SENT = NCOL_SEND CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF IF ( & (KEEP(50).NE.0) .OR. & (KEEP(50).EQ.0.AND.JBEG_BLOCK.EQ.1) & ) THEN NBINT = NPIV ELSE NBINT = 0 ENDIF IF ( LASTPANEL ) THEN IF ( KEEP(50) .eq. 0 ) THEN NBINT = 9 + NBINT ELSE NBINT = 11 + NBINT END IF ELSE IF ( KEEP(50) .eq. 0 ) THEN NBINT = 8 + NBINT ELSE NBINT = 10 + NBINT END IF END IF IF (LR_ACTIVATED.AND.KEEP(50).EQ.0) THEN IF ( COMPRESS_CB .AND.(NPIV.GT.0) & .AND. IBEG_PANEL.EQ.1 .AND. (JBEG_BLOCK.EQ.1) & ) THEN NBINT = NBINT + size(BLR_LorU) + 1 ELSE NBINT = NBINT + 1 ENDIF ENDIF CALL MPI_PACK_SIZE( NBINT + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE2_8 = 0_8 SIZE_AV_ADJUSTED = SIZE_AV SIZE_NEXT_BLOCK = 0 IF ( (NPIV.GT.0) & ) THEN SIZE_AV_ADJUSTED = SIZE_AV_ADJUSTED - int(SIZE2_8) - SIZE1 NOT_ENOUGH_SPACE = (SIZE_AV_ADJUSTED.LE.0) IF (.NOT. LR_ACTIVATED) THEN NCOL_MAX = (SIZE_AV_ADJUSTED) / (NPIV*SIZEofREAL) NCOL_MAX = max(NCOL_MAX,0) NCOL_SEND = min( NCOL_SEND, NCOL_MAX) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE.OR. & (NCOL_SEND.EQ.0) .OR. & ((JBEG_BLOCK.EQ.1).AND.(NCOL_MAX.LT.NPIV)) IF (JBEG_BLOCK.EQ.1) NCOL_SEND = max(NCOL_SEND, NPIV) IF (KEEP(173).EQ.1) THEN IF (JBEG_BLOCK.EQ.1) THEN NCOL_SEND = min(NCOL_SEND, kmaxcol+NPIV) ELSE NCOL_SEND = min(NCOL_SEND, kmaxcol) ENDIF ENDIF NOT_ENOUGH_SPACE= NOT_ENOUGH_SPACE.OR. & (NCOL_SEND .GT. NCOL_MAX) SIZE3_8 = int(NPIV,8)*int(NCOL_SEND,8)*int(KEEP(35),8) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ELSE CALL MPI_PACK_SIZE( NPIV*NCOL_SEND, & MPI_REAL, & COMM, SIZE3, IERR_MPI ) SIZE2_8 = SIZE2_8 + int(SIZE3,8) ENDIF NEWCOL_SENT = NCOL_SEND IF (NBCOLS_ALREADY_SENT+NEWCOL_SENT.LT.NCOL) THEN CALL MPI_PACK_SIZE( NPIV, & MPI_REAL, & COMM, SIZE_NEXT_BLOCK, IERR_MPI ) ENDIF ELSE NCOL_DIAG = -9995 IF ((KEEP(50).NE.0).OR.(JBEG_BLOCK.EQ.1)) THEN SIZE3_8 = int(NPIV,8)*int(NPIV+NELIM,8)*int(KEEP(35),8) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ELSE CALL MPI_PACK_SIZE( NPIV*(NPIV+NELIM), & MPI_REAL, & COMM, SIZE3, IERR_MPI ) SIZE2_8 = SIZE2_8+int(SIZE3,8) NCOL_SEND = NPIV+NELIM SIZE_AV_ADJUSTED = SIZE_AV_ADJUSTED - int(SIZE2_8) ENDIF ELSE NCOL_SEND = 0 ENDIF NCOL_DIAG = NCOL_SEND IF (JBEG_BLOCK.EQ.1) THEN NEWCOL_SENT = NCOL_DIAG ELSE NEWCOL_SENT = 0 ENDIF NOT_ENOUGH_SPACE = ( NOT_ENOUGH_SPACE.OR. & (SIZE_AV_ADJUSTED.LE.0) ) CALL SMUMPS_MPI_PACK_SIZE_LR_PARTIAL ( 0, & BLR_LorU, NBLRB_ALREADY_SENT, & SIZE_AV_ADJUSTED, KEEP(173), & NBLRB_PACKET, NCOL_SEND, SIZE3_8, & SIZE_NEXT_BLOCK, & COMM, IERR & ) NEWCOL_SENT = NEWCOL_SENT + (NCOL_SEND-NCOL_DIAG) NOT_ENOUGH_SPACE= ( NOT_ENOUGH_SPACE.OR. & (NEWCOL_SENT.EQ.0).OR. & (SIZE3_8.GT.int(SIZE_AV_ADJUSTED,8)) ) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ENDIF SIZE2_8 = SIZE2_8+SIZE3_8 ENDIF ENDIF IF (SIZE_NEXT_BLOCK.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF IF (NOT_ENOUGH_SPACE & ) THEN IF (RECV_BUF_SMALLER_THAN_SEND & ) THEN IERR = -3 RETURN ELSE IERR = -1 RETURN ENDIF ENDIF SIZET_8 = int(SIZE1,8) + SIZE2_8 IF (SIZET_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZET_8 ENDIF IF (OVERFLOW) THEN IERR=-3 IF (LPOK) WRITE(LP,*) & "Integer overflow message inSMUMPS_BUF_SEND_BLOCFACTO", & "SIZE_OVERFLOW,NPIV,NFRONT,NELIM=", & SIZE_OVERFLOW, NPIV, NFRONT, NELIM RETURN ENDIF SIZET = int(SIZET_8) IF (SIZET.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF K170PER1000 = real(min(KEEP(170),500))/real(1000) IF ( (NBCOLS_ALREADY_SENT+NEWCOL_SENT.LT.NCOL) & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND & .AND. ( SIZET .LT. & int(real(SIZE_RBUF_BYTES)*K170PER1000) ) & .AND. ( & int(SIZET,8) + int(SIZE_NEXT_BLOCK,8) .LE. & int(SIZE_RBUF_BYTES,8) ) & .AND. AVOID_TOO_SMALL_GRANULARITY & ) THEN IERR = -1 RETURN ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NDEST , PDEST) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_CB%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST SIZE_MSG_BYTES = SIZET - OVHSIZE * (NDEST-1) * KEEP(34) POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) NPIVSENT = NPIV IF (LASTPANEL) NPIVSENT = -NPIV CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF ( LASTPANEL .OR. KEEP(50).ne.0 ) THEN CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) END IF IF ( LASTPANEL .AND. KEEP(50) .NE. 0 ) THEN CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) END IF CALL MPI_PACK( NEWCOL_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBEG_BLOCK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NELIM, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPARTSASS, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( CURRENT_BLR_PANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN LR_ACTIVATED_INT = 1 ELSE LR_ACTIVATED_INT = 0 ENDIF CALL MPI_PACK( LR_ACTIVATED_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF ( KEEP(50) .ne. 0 ) THEN CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDIF IF (LR_ACTIVATED.AND.KEEP(50).EQ.0) THEN SIZE_BLR_LorU_SENT = 0 IF ( COMPRESS_CB .AND.(NPIV.GT.0) & .AND. IBEG_PANEL.EQ.1 .AND. (JBEG_BLOCK.EQ.1) & ) THEN SIZE_BLR_LorU_SENT = size(BLR_LorU) ENDIF CALL MPI_PACK( SIZE_BLR_LorU_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), & SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF (SIZE_BLR_LorU_SENT.GT.0) THEN DO I=1, size(BLR_LorU) CALL MPI_PACK( BLR_LorU(I)%M, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), & SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDDO ENDIF ENDIF IF ( (NPIV.GT.0) & ) THEN IF ( & (KEEP(50).NE.0) .OR. & (KEEP(50).EQ.0.AND.JBEG_BLOCK.EQ.1) & ) THEN CALL MPI_PACK( IPIV, NPIV, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(50).NE.0.OR.JBEG_BLOCK.EQ.1) THEN DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NPIV+NELIM, & MPI_REAL, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) END DO ENDIF CALL SMUMPS_MPI_PACK_LR_PARTIAL( & BLR_LorU, NBLRB_ALREADY_SENT, NBLRB_PACKET, & BUF_CB%CONTENT(IPOSMSG: & IPOSMSG+(SIZE_MSG_BYTES+KEEP(34)-1)/KEEP(34)-1), & SIZE_MSG_BYTES, POSITION, COMM, IERR,KEEP(34) ) ELSE DO I = 1, NPIV CALL MPI_PACK( VAL(JBEG_BLOCK,I), NCOL_SEND, & MPI_REAL, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) END DO ENDIF ENDIF DO IDEST = NDEST, 1, -1 DEST_BLOCFACTO = PDEST(IDEST) IF ( KEEP(50) .EQ. 0) THEN TAG_BLOCFACTO = BLOC_FACTO KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, & MPI_PACKED, & DEST_BLOCFACTO, TAG_BLOCFACTO, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) ELSE KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, & MPI_PACKED, & DEST_BLOCFACTO, BLOC_FACTO_SYM, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) END IF END DO IF (NBCOLS_ALREADY_SENT+NEWCOL_SENT.EQ.NCOL & ) THEN NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ELSE NBCOLS_ALREADY_SENT = NBCOLS_ALREADY_SENT + NEWCOL_SENT IF (LR_ACTIVATED) THEN NBLRB_ALREADY_SENT = NBLRB_ALREADY_SENT + NBLRB_PACKET ENDIF IERR = -1 ENDIF IF ( SIZE_MSG_BYTES .LT. POSITION ) THEN WRITE(*,*) ' Error sending blocfacto : size < position' WRITE(*,*) ' INODE= ', INODE, & ' Size,position= ',SIZE_MSG_BYTES,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_MSG_BYTES .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE SMUMPS_BUF_SEND_BLOCFACTO SUBROUTINE SMUMPS_BUF_SEND_BLFAC_SLAVE( INODE, & NPIV, FPERE, IPOSK, JPOSK, UIP21K, LUIP21K, NCOLU, & NDEST, PDEST, COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & NOTHING_WAS_SENT, & A , LA, POSBLOCFACTO, LD_BLOCFACTO, & IPIV, MAXI_CLUSTER, IERR, IERROR ) USE SMUMPS_LR_TYPE IMPLICIT NONE INTEGER INODE, NCOLU, IPOSK, JPOSK, NPIV, NDEST, FPERE INTEGER(8) :: LUIP21K REAL UIP21K( : ) INTEGER PDEST( NDEST ) INTEGER COMM, IERR, IERROR INTEGER, INTENT(INOUT) :: KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: NBCOLS_ALREADY_SENT, & NBLRB_ALREADY_SENT LOGICAL, intent(out) :: NOTHING_WAS_SENT TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS INTEGER(8), intent(in) :: LA, POSBLOCFACTO INTEGER, intent(in) :: LD_BLOCFACTO, IPIV(NPIV), & MAXI_CLUSTER, IPANEL REAL, intent(inout) :: A(LA) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER LR_ACTIVATED_INT INTEGER POSITION, IREQ, IPOS, SIZE1, SIZET, & IDEST, IPOSMSG, SSS, SIZE3, SIZE_MSG_BYTES INTEGER(8) :: SIZE2_8, SIZE3_8, SIZET_8, SIZE_OVERFLOW LOGICAL :: OVERFLOW, LASTBL_INPANEL INTEGER :: JBEG_BLOCK, NCOL_SEND, NCOL_MAX INTEGER :: SIZE_AV, SIZE_AV_ADJUSTED LOGICAL :: RECV_BUF_SMALLER_THAN_SEND, NOT_ENOUGH_SPACE INTEGER :: NBLRB_PACKET, SIZE_NEXT_BLOCK LOGICAL :: AVOID_TOO_SMALL_GRANULARITY INTEGER, PARAMETER :: kmaxcol=3 REAL :: K170PER1000 IERR = 0 OVERFLOW = .FALSE. SIZE_OVERFLOW = 0_8 JBEG_BLOCK = NBCOLS_ALREADY_SENT + 1 NCOL_SEND = NCOLU - JBEG_BLOCK + 1 NBLRB_PACKET = -9977 NOTHING_WAS_SENT = .TRUE. AVOID_TOO_SMALL_GRANULARITY = .TRUE. IF (KEEP(173).EQ.1) AVOID_TOO_SMALL_GRANULARITY = .FALSE. CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF CALL MPI_PACK_SIZE( 8 + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE2_8 = 0_8 SIZE_AV_ADJUSTED = SIZE_AV - SIZE1 SIZE_NEXT_BLOCK = 0 NOT_ENOUGH_SPACE = (SIZE_AV_ADJUSTED.LE.0) IF (.NOT. LR_ACTIVATED) THEN NCOL_MAX = (SIZE_AV_ADJUSTED) / (NPIV*SIZEofREAL) NCOL_MAX = max(NCOL_MAX,0) NCOL_SEND = min( NCOL_SEND, NCOL_MAX) IF (KEEP(173).EQ.1) THEN NCOL_SEND = min(NCOL_SEND, kmaxcol) ENDIF NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE.OR.(NCOL_SEND.EQ.0) SIZE3_8 = int(NPIV,8)*int(NCOL_SEND,8) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ELSE CALL MPI_PACK_SIZE( abs(NPIV)*NCOL_SEND, & MPI_REAL, & COMM, SIZE3, IERR_MPI ) SIZE2_8=SIZE2_8 + int(SIZE3,8) ENDIF IF (NBCOLS_ALREADY_SENT+NCOL_SEND.LT.NCOLU) THEN CALL MPI_PACK_SIZE( NPIV, & MPI_REAL, & COMM, SIZE_NEXT_BLOCK, IERR_MPI ) ENDIF ELSE NCOL_SEND = 0 NOT_ENOUGH_SPACE = ( NOT_ENOUGH_SPACE.OR. & (SIZE_AV_ADJUSTED.LE.0) ) CALL SMUMPS_MPI_PACK_SIZE_LR_PARTIAL ( 1, & BLR_LS, NBLRB_ALREADY_SENT, & SIZE_AV_ADJUSTED, KEEP(173), & NBLRB_PACKET, NCOL_SEND, SIZE3_8, & SIZE_NEXT_BLOCK, & COMM, IERR & ) NOT_ENOUGH_SPACE= ( NOT_ENOUGH_SPACE.OR. & (NCOL_SEND.EQ.0).OR. & (SIZE3_8.GT.int(SIZE_AV_ADJUSTED,8)) ) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ENDIF SIZE2_8 = SIZE2_8+SIZE3_8 ENDIF IF (SIZE_NEXT_BLOCK.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF IF (NOT_ENOUGH_SPACE) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 RETURN ELSE IERR = -1 RETURN ENDIF ENDIF SIZET_8 = int(SIZE1,8) + SIZE2_8 IF (SIZET_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZET_8 ENDIF IF (OVERFLOW) THEN IERR=-3 RETURN ENDIF SIZET = int(SIZET_8) IF (SIZET.GT.SIZE_RBUF_BYTES) THEN CALL MPI_PACK_SIZE( 6 , & MPI_INTEGER, COMM, SSS, IERR_MPI ) SIZE2_8 = int(SSS,8)+SIZE2_8 IF (int(SIZE2_8).GT.SIZE_RBUF_BYTES) THEN IERR = -2 RETURN ENDIF END IF K170PER1000 = real(min(KEEP(170),500))/real(1000) IF ((NBCOLS_ALREADY_SENT+NCOL_SEND.LT.NCOLU) & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND & .AND. ( SIZET .LT. & int(real(SIZE_RBUF_BYTES)*K170PER1000) ) & .AND. ( & int(SIZET,8) + int(SIZE_NEXT_BLOCK,8) .LE. & int(SIZE_RBUF_BYTES,8) ) & .AND. AVOID_TOO_SMALL_GRANULARITY & ) THEN IERR = -1 RETURN ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NDEST, PDEST) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_CB%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST SIZE_MSG_BYTES = SIZET - OVHSIZE * (NDEST-1) * KEEP(34) POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JPOSK+JBEG_BLOCK-1, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) LASTBL_INPANEL = (NBCOLS_ALREADY_SENT+NCOL_SEND.EQ.NCOLU) IF (LASTBL_INPANEL) THEN CALL MPI_PACK( -NCOL_SEND, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ELSE CALL MPI_PACK( NCOL_SEND, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDIF IF (LR_ACTIVATED) THEN LR_ACTIVATED_INT = 1 ELSE LR_ACTIVATED_INT = 0 ENDIF CALL MPI_PACK( LR_ACTIVATED_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IPANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN CALL SMUMPS_MPI_PACKSCALE_LR_PARTIAL( BLR_LS, & NBLRB_ALREADY_SENT, NBLRB_PACKET, & BUF_CB%CONTENT( IPOSMSG: & IPOSMSG+(SIZE_MSG_BYTES+KEEP(34)-1)/KEEP(34)-1 ), & SIZE_MSG_BYTES, POSITION, COMM, & A, LA, POSBLOCFACTO, LD_BLOCFACTO, & IPIV, NPIV, MAXI_CLUSTER, IERR, IERROR ) IF (IERR.LT.0) RETURN ELSE CALL MPI_PACK( UIP21K(1_8+int(JBEG_BLOCK-1,8)*int(NPIV,8)), & NPIV * NCOL_SEND, & MPI_REAL, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDIF NOTHING_WAS_SENT = .FALSE. DO IDEST = 1, NDEST KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, & PDEST(IDEST), BLOC_FACTO_SYM_SLAVE, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) END DO IF ( LASTBL_INPANEL ) THEN NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ELSE NBCOLS_ALREADY_SENT = NBCOLS_ALREADY_SENT + NCOL_SEND IF (LR_ACTIVATED) THEN NBLRB_ALREADY_SENT = NBLRB_ALREADY_SENT + NBLRB_PACKET ENDIF IERR = -1 ENDIF IF ( SIZE_MSG_BYTES .LT. POSITION ) THEN WRITE(*,*) ' Error sending blfac slave : size < position' WRITE(*,*) ' Size,position=',SIZE_MSG_BYTES,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_MSG_BYTES .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE SMUMPS_BUF_SEND_BLFAC_SLAVE SUBROUTINE SMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) 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, INTENT(IN) :: RG2L(N) INTEGER NSUPROW, NSUPCOL INTEGER(8), INTENT(IN) :: TABSIZE INTEGER SIZE_PACK INTEGER KEEP(500) REAL VAL_SON( LD_SON, * ), TAB(*) LOGICAL TRANSP INTEGER N_ALREADY_SENT INTEGER :: NELIM_ROOT, NELIM_ROW, NELIM_COL INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER SIZE1, SIZE2, SIZE_AV, POSITION INTEGER SIZE_CBP, SIZE_TMP INTEGER IREQ, IPOS, ITAB INTEGER ISUB, JSUB, I, J INTEGER ILOC_ROOT, JLOC_ROOT INTEGER IPOS_ROOT, JPOS_ROOT INTEGER IONE LOGICAL RECV_BUF_SMALLER_THAN_SEND INTEGER PDEST2(1) PARAMETER ( IONE=1 ) INTEGER N_PACKET INTEGER NSUBSET_ROW_EFF, NSUBSET_COL_EFF, NSUPCOL_EFF PDEST2(1) = PDEST IERR = 0 IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF SIZE_AV = min(SIZE_AV, SIZE_RBUF_BYTES) CALL MPI_PACK_SIZE(8 + NSUBSET_COL, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE_CBP = 0 IF (N_ALREADY_SENT .EQ. 0 .AND. & min(NSUPROW,NSUPCOL) .GT.0) THEN CALL MPI_PACK_SIZE(NSUPROW, MPI_INTEGER, COMM, & SIZE_CBP, IERR_MPI ) CALL MPI_PACK_SIZE(NSUPCOL, MPI_INTEGER, COMM, & SIZE_TMP, IERR_MPI ) SIZE_CBP = SIZE_CBP + SIZE_TMP CALL MPI_PACK_SIZE(NSUPROW*NSUPCOL, & MPI_REAL, COMM, & SIZE_TMP, IERR_MPI ) SIZE_CBP = SIZE_CBP + SIZE_TMP SIZE1 = SIZE1 + SIZE_CBP ENDIF IF (BBPCBP.EQ.1) THEN NSUBSET_COL_EFF = NSUBSET_COL - NSUPCOL NSUPCOL_EFF = 0 ELSE NSUBSET_COL_EFF = NSUBSET_COL NSUPCOL_EFF = NSUPCOL ENDIF NSUBSET_ROW_EFF = NSUBSET_ROW - NSUPROW N_PACKET = & (SIZE_AV - SIZE1) / (SIZEofINT + NSUBSET_COL_EFF * SIZEofREAL) 10 CONTINUE N_PACKET = min( N_PACKET, & NSUBSET_ROW_EFF-N_ALREADY_SENT ) IF (N_PACKET .LE. 0 .AND. & NSUBSET_ROW_EFF-N_ALREADY_SENT.GT.0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF CALL MPI_PACK_SIZE( 8 + NSUBSET_COL_EFF + N_PACKET, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE1 = SIZE1 + SIZE_CBP CALL MPI_PACK_SIZE( N_PACKET * NSUBSET_COL_EFF, & MPI_REAL, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV) THEN N_PACKET = N_PACKET - 1 IF ( N_PACKET > 0 ) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (N_PACKET + N_ALREADY_SENT .NE. NSUBSET_ROW - NSUPROW & .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 10 & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF ELSE N_PACKET = 0 CALL MPI_PACK_SIZE(8,MPI_INTEGER, COMM, SIZE_PACK, IERR_MPI ) END IF IF ( SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE, PDEST2 & ) IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUBSET_ROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUPROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUBSET_COL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUPCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( N_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( N_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( BBPCBP, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN IF (N_ALREADY_SENT .EQ. 0 .AND. & min(NSUPROW, NSUPCOL) .GT. 0) THEN DO ISUB = NSUBSET_ROW-NSUPROW+1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IF ( I .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L(INDCOL_SON( I )) ENDIF ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO DO ISUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( ISUB ) JPOS_ROOT = INDROW_SON( J ) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO IF ( TABSIZE.GE.int(NSUPROW,8)*int(NSUPCOL,8) ) THEN ITAB = 1 DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW J = SUBSET_ROW(JSUB) DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL I = SUBSET_COL(ISUB) TAB(ITAB) = VAL_SON(J, I) ITAB = ITAB + 1 ENDDO ENDDO CALL MPI_PACK(TAB(1), NSUPROW*NSUPCOL, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ELSE DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW J = SUBSET_ROW(JSUB) DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL I = SUBSET_COL(ISUB) CALL MPI_PACK(VAL_SON(J,I), 1, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO ENDDO ENDIF ENDIF IF ( .NOT. TRANSP ) THEN DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) IF ( I .LE. NELIM_ROW ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L( INDROW_SON( I ) ) ENDIF ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO JSUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF J = SUBSET_COL( JSUB ) IF ( J .LE. NELIM_COL ) THEN JPOS_ROOT = NELIM_ROOT + J - 1 ELSE JPOS_ROOT = RG2L( INDCOL_SON( J ) ) ENDIF JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO JSUB = NSUBSET_COL_EFF-NSUPCOL_EFF+1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) JPOS_ROOT = INDCOL_SON( J ) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO ELSE DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) IF ( J .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + J - 1 ELSE IPOS_ROOT = RG2L( INDCOL_SON( J ) ) ENDIF ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO ISUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF I = SUBSET_COL( ISUB ) IF ( I .LE. NELIM_ROW ) THEN JPOS_ROOT = NELIM_ROOT + I - 1 ELSE JPOS_ROOT = RG2L( INDROW_SON( I ) ) ENDIF JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO ISUB = NSUBSET_COL_EFF - NSUPCOL_EFF + 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) JPOS_ROOT = INDROW_SON(I) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO END IF IF ( TABSIZE.GE.int(N_PACKET,8)*int(NSUBSET_COL_EFF,8) ) THEN IF ( .NOT. TRANSP ) THEN ITAB = 1 DO ISUB = N_ALREADY_SENT+1, & N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) DO JSUB = 1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) TAB( ITAB ) = VAL_SON(J,I) ITAB = ITAB + 1 END DO END DO CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ELSE ITAB = 1 DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) DO ISUB = 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) TAB( ITAB ) = VAL_SON( J, I ) ITAB = ITAB + 1 END DO END DO CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END IF ELSE IF ( .NOT. TRANSP ) THEN DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) DO JSUB = 1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) CALL MPI_PACK( VAL_SON( J, I ), 1, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO END DO ELSE DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) DO ISUB = 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) CALL MPI_PACK( VAL_SON( J, I ), 1, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO END DO END IF ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & PDEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN WRITE(*,*) ' Error sending contribution to root:Size 0) THEN SCALED(1:BLR(I)%K,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * BLR(I)%R(1:BLR(I)%K,J) J = J+1 CALL MPI_PACK( SCALED(1,1), BLR(I)%K, & MPI_REAL, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) ELSE PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) PIV2 = A(POSELTD+LD_DIAG*J+J) OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) BLOCK(1:BLR(I)%K) = BLR(I)%R(1:BLR(I)%K,J) SCALED(1:BLR(I)%K,1) = PIV1 * BLR(I)%R(1:BLR(I)%K,J) & + OFFDIAG * BLR(I)%R(1:BLR(I)%K,J+1) CALL MPI_PACK( SCALED(1,1), BLR(I)%K, & MPI_REAL, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) SCALED(1:BLR(I)%K,2) = OFFDIAG * BLOCK(1:BLR(I)%K) & + PIV2 * BLR(I)%R(1:BLR(I)%K,J+1) J =J+2 CALL MPI_PACK( SCALED(1,2), BLR(I)%K, & MPI_REAL, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) ENDIF END DO ENDIF ELSE J = 1 DO WHILE (J <= BLR(I)%N) IF (IPIV(J) > 0) THEN SCALED(1:BLR(I)%M,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * BLR(I)%Q(1:BLR(I)%M,J) CALL MPI_PACK( SCALED(1,1), BLR(I)%M, & MPI_REAL, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) J = J+1 ELSE PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) PIV2 = A(POSELTD+LD_DIAG*J+J) OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) BLOCK(1:BLR(I)%M) = BLR(I)%Q(1:BLR(I)%M,J) SCALED(1:BLR(I)%M,1) = PIV1 * BLR(I)%Q(1:BLR(I)%M,J) & + OFFDIAG * BLR(I)%Q(1:BLR(I)%M,J+1) CALL MPI_PACK( SCALED(1,1), BLR(I)%M, & MPI_REAL, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) SCALED(1:BLR(I)%M,2) = OFFDIAG * BLOCK(1:BLR(I)%M) & + PIV2 * BLR(I)%Q(1:BLR(I)%M,J+1) CALL MPI_PACK( SCALED(1,2), BLR(I)%M, & MPI_REAL, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) J=J+2 ENDIF END DO ENDIF ENDDO 500 CONTINUE IF (allocated(BLOCK)) deallocate(BLOCK) IF (allocated(SCALED)) deallocate(SCALED) 600 CONTINUE RETURN END SUBROUTINE SMUMPS_MPI_PACKSCALE_LR_PARTIAL END MODULE SMUMPS_BUF MUMPS_5.8.1/src/dana_aux_par.F0000664000175000017500000044367215042446437016007 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_PARALLEL_ANALYSIS USE DMUMPS_STRUC_DEF USE MUMPS_MEMORY_MOD USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T, COMPACT_GRAPH_T INCLUDE 'mpif.h' PUBLIC DMUMPS_ANA_F_PAR INTERFACE DMUMPS_ANA_F_PAR MODULE PROCEDURE DMUMPS_ANA_F_PAR END INTERFACE PRIVATE TYPE ORD_TYPE INTEGER :: CBLKNBR, N INTEGER, POINTER :: PERMTAB(:) => null() INTEGER, POINTER :: PERITAB(:) => null() INTEGER, POINTER :: RANGTAB(:) => null() INTEGER, POINTER :: TREETAB(:) => null() INTEGER, POINTER :: BROTHER(:) => null() INTEGER, POINTER :: SON(:) => null() INTEGER, POINTER :: NW(:) => null() INTEGER, POINTER :: FIRST(:) => null() INTEGER, POINTER :: LAST(:) => null() INTEGER, POINTER :: TOPNODES(:) => null() INTEGER :: COMM, NPROCS, MYID, & COMM_PARAORD, NPROCS_PARAORD, MYID_PARAORD, & RKinSYMB_PROC0ORD INTEGER :: TOPSTRAT, SUBSTRAT, ORDTOOL, TOPVARS LOGICAL :: IDO END TYPE ORD_TYPE TYPE GRAPH_TYPE INTEGER(8) :: NZ_LOC INTEGER, POINTER :: IRN_LOC(:) => null() INTEGER, POINTER :: JCN_LOC(:) => null() END TYPE GRAPH_TYPE TYPE ARRPNT INTEGER, POINTER :: BUF(:) => null() END TYPE ARRPNT INTEGER :: MP, MPG, LP, NRL, TOPROWS INTEGER(8) :: MEMCNT, MAXMEM LOGICAL :: PROK, PROKG, LPOK INTEGER N, NORIG CONTAINS SUBROUTINE DMUMPS_ANA_F_PAR(id, WORK1, WORK2, LWORK1, LWORK2, & NFSIZ, FILS, & FRERE, COMM_PARASYMB, LUMAT, SIZEOFBLOCKS, & COMM_PARAORD, NPROCS_PARAORD, & RKinSYMB_PROC0ORD) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id INTEGER, TARGET :: WORK1(:), WORK2(:) INTEGER(8), INTENT(IN) :: LWORK1, LWORK2 #if defined(MUMPS_NOF2003) INTEGER, POINTER :: FILS(:) #else INTEGER, ALLOCATABLE :: FILS(:) #endif INTEGER, POINTER :: NFSIZ(:), FRERE(:) INTEGER, INTENT(IN) :: COMM_PARASYMB TYPE(LMATRIX_T), OPTIONAL :: LUMAT INTEGER, INTENT(IN), TARGET, OPTIONAL :: SIZEOFBLOCKS(id%NBLK) INTEGER, INTENT(IN), OPTIONAL :: COMM_PARAORD, & NPROCS_PARAORD, & RKinSYMB_PROC0ORD 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 DOUBLE PRECISION :: TIMEB INTEGER HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & NBSONS_Scalapack_CAND INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR INTEGER, TARGET :: IDUMMY_ARRAY(1) INTEGER :: LSIZEOFBLOCKS_PTR LOGICAL :: SIZEOFBLOCKS_AVAIL nullify(IPE, NV, NE, NA, NODE, ND, SUBORD, NAMALG, IPS, & CUMUL, SAVEIRN, SAVEJCN) CALL MPI_COMM_RANK (COMM_PARASYMB, MYID, IERR) CALL MPI_COMM_SIZE (COMM_PARASYMB, NPROCS, IERR) NORIG = id%N IF (id%KEEP(339).NE.0) THEN N = id%NBLK ELSE N = NORIG ENDIF ord%N = N LP = id%ICNTL(1) MP = id%ICNTL(2) MPG = id%ICNTL(3) PROK = (MP.GT.0) PROKG = (MPG.GT.0) .AND. (MYID .EQ. 0) LPOK = (LP.GT.0) .AND. (id%ICNTL(4).GE.1) LDIAG = id%ICNTL(4) IF (present(SIZEOFBLOCKS)) THEN SIZEOFBLOCKS_PTR => SIZEOFBLOCKS(1:N) LSIZEOFBLOCKS_PTR = N SIZEOFBLOCKS_AVAIL = .TRUE. ELSE SIZEOFBLOCKS_PTR => IDUMMY_ARRAY SIZEOFBLOCKS_AVAIL = .FALSE. LSIZEOFBLOCKS_PTR = 1 IDUMMY_ARRAY(1) = -1 ENDIF IF (PROKG) THEN WRITE(MPG,'(A,I10)') & " Parallel analysis, processing a graph of size:", N ENDIF IF (id%KEEP(339).GT.0) THEN IF (.NOT.present(LUMAT) .OR. .NOT. present(SIZEOFBLOCKS)) THEN IF (PROK) THEN WRITE(MP,*) MYID, " Internal error in DMUMPS_ANA_F_PAR" ENDIF id%INFO(1) = -9991 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM_PARASYMB, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN ENDIF IF (id%KEEP(339).GT.0) THEN MEMCNT = MEMCNT + LUMAT%NZL + LUMAT%NBCOL_LOC + 3 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ENDIF CALL DMUMPS_SET_PAR_ORD(id, COMM_PARASYMB, MYID, NPROCS, & ord, COMM_PARAORD, NPROCS_PARAORD, & RKinSYMB_PROC0ORD) IF ( LWORK1 .LT. 3_8 *int(N,8) ) THEN WRITE(LP,*) & 'Insufficient workspace in DMUMPS_ANA_F_PAR' CALL MUMPS_ABORT() ENDIF IF ( ord%COMM .NE. MPI_COMM_NULL ) THEN ord%PERMTAB => WORK1( 1 : N) ord%PERITAB => WORK1( int(N,8)+1_8 : 2_8*int(N,8)) ord%TREETAB => WORK1(2_8*int(N,8)+1_8 : 3_8*int(N,8)) ENDIF IF ( id%KEEP(54) .NE. 3 ) THEN IF(MYID.EQ.0) THEN SAVEIRN => id%IRN_loc SAVEJCN => id%JCN_loc id%IRN_loc => id%IRN id%JCN_loc => id%JCN id%KEEP8(29) = id%KEEP8(28) ELSE id%KEEP8(29)=0_8 END IF END IF MAXMEM=0 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT id%INFOG(7) = id%KEEP(245) IF (PROKG) CALL MUMPS_SECDEB( TIMEB ) IF (id%KEEP(339).GT.0) THEN CALL DMUMPS_DO_PAR_ORD(id, MYID, NPROCS, & ord, WORK2, LWORK2, LUMAT, SIZEOFBLOCKS) ELSE CALL DMUMPS_DO_PAR_ORD(id, MYID, NPROCS, & ord, WORK2, LWORK2) ENDIF IF (PROKG) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE(MPG, & '(" ELAPSED time in parallel ordering =",F12.4)') & TIMEB ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF(ord%MYID .EQ. 0) THEN CALL MUMPS_REALLOC(IPE, N, id%INFO, LP, FORCE=.FALSE., & COPY=.FALSE., STRING='', & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, N, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT END IF ord%SUBSTRAT = 0 ord%TOPSTRAT = 0 IF (id%KEEP(339).NE.0) THEN CALL DMUMPS_PARSYMFACT_LUMAT(id, ord, IPE, NV, & WORK2, LWORK2, LUMAT, & SIZEOFBLOCKS) ELSE CALL DMUMPS_PARSYMFACT(id, ord, IPE, NV, WORK2, LWORK2) ENDIF IF(id%KEEP(54) .NE. 3) THEN IF(ord%MYID.EQ.0) THEN id%IRN_loc => SAVEIRN id%JCN_loc => SAVEJCN END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN NULLIFY(ord%PERMTAB) NULLIFY(ord%PERITAB) NULLIFY(ord%TREETAB) CALL MUMPS_IDEALLOC(ord%FIRST, ord%LAST, MEMCNT=MEMCNT) IF (MYID .EQ. 0) THEN IPS => WORK1(1:N) NE => WORK1( int(N,8)+1_8 : 2_8*int(N,8)) NA => WORK1(2_8*int(N,8)+1_8 : 3_8*int(N,8)) NODE => WORK2( 1 : N ) ND => WORK2( int(N,8)+1_8 : 2_8*int(N,8)) SUBORD => WORK2(2_8*int(N,8)+1_8 : 3_8*int(N,8)) NAMALG => WORK2(3_8*int(N,8)+1_8 : 4_8*int(N,8)) CALL MUMPS_REALLOC(CUMUL, N, id%INFO, LP, & STRING='CUMUL', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT NEMIN = id%KEEP(1) CALL DMUMPS_ANA_LNEW(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%KEEP(197), & id%NSLAVES, id%KEEP(250).EQ.1, SIZEOFBLOCKS_AVAIL, & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, & INODE_Scalapack_CAND, NBSONS_Scalapack_CAND, & id%KEEP(11), id%KEEP(191), id%KEEP(192), id%KEEP(193)) CALL MUMPS_DEALLOC(CUMUL, NV, IPE, MEMCNT=MEMCNT) CALL DMUMPS_ANA_M(NE(1), ND(1), id%INFOG(6), id%INFOG(5), & id%KEEP(2), id%KEEP(50), id%KEEP8(101), id%KEEP(108), & id%KEEP(5), id%KEEP(6), id%KEEP(226), id%KEEP(253)) IF ( id%KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT(N, FRERE(1), FILS(1), NFSIZ(1), & id%KEEP(20)) INODE_Scalapack_CAND = id%KEEP(20) NBSONS_Scalapack_CAND = 1 END IF IF ( (id%KEEP(48) == 4 .AND. id%KEEP8(21).GT.0_8) & .OR. & (id%KEEP (48)==5 .AND. id%KEEP8(21) .GT. 0_8 ) & .OR. & (id%KEEP(24).NE.0.AND.id%KEEP8(21).GT.0_8) ) THEN CALL DMUMPS_SET_K821_SURFACE(id%KEEP8(21), id%KEEP(2), & id%KEEP(48), id%KEEP(50), id%NSLAVES) END IF IF (id%KEEP(210).LT.1.OR.id%KEEP(210).GT.2) id%KEEP(210)=2 IF (id%KEEP(210).EQ.2) id%KEEP8(79)=huge(id%KEEP8(79)) IF (id%KEEP(210).EQ.1.AND.id%KEEP8(79).LE.0_8) THEN id%KEEP8(79)=K79REF * int(id%NSLAVES,8) ENDIF IF (id%KEEP(11).EQ.0) THEN IF ( (id%KEEP(79).EQ.0).OR.(id%KEEP(79).EQ.2).OR. & (id%KEEP(79).EQ.3).OR.(id%KEEP(79).EQ.5).OR. & (id%KEEP(79).EQ.6) & ) THEN IF (id%KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( id%KEEP(62).GE.1) THEN CALL DMUMPS_CUTNODES(N, FRERE(1), FILS(1), & NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, 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 ENDIF HOW_TO_SPLIT_ROOT = 0 SPLITROOT = id%ICNTL(13) .EQ. -1 #if defined(NOSCALAPACK) SPLITROOT = SPLITROOT .OR. id%NSLAVES.GT.0 #else SPLITROOT = SPLITROOT .OR. & (id%ICNTL(13).GT.0 .AND. id%NSLAVES.GT.id%ICNTL(13)) #endif IF (SPLITROOT.AND.id%KEEP(11).GT.0) HOW_TO_SPLIT_ROOT =1 IF (id%KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. IF (id%KEEP(11).GT.0) HOW_TO_SPLIT_ROOT = 2 ENDIF #if defined(NOSCALAPACK) #else IF ( id%KEEP(11).GT.0 .AND. (id%KEEP(339).NE.0) ) THEN IF (.NOT.SPLITROOT .AND. & (id%KEEP(60).EQ.0).AND. & ( (NFSIZ(INODE_Scalapack_CAND).GT.id%KEEP(37)) & .AND.(id%ICNTL(13).LE.0) ) & .AND. & (NBSONS_Scalapack_CAND.GT.id%KEEP(11)) & ) THEN HOW_TO_SPLIT_ROOT = 3 SPLITROOT=.TRUE. ENDIF ENDIF #endif SPLITROOT = (SPLITROOT.AND.( (id%KEEP(60).EQ.0) )) IF (SPLITROOT) THEN IF (id%KEEP(339).EQ.0) THEN CALL DMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, id%INFOG(6), & id%NSLAVES, id%KEEP(1), id%KEEP8(1), & SPLITROOT, MP, LDIAG, id%INFOG(1), id%INFOG(2)) ELSE IF (id%KEEP(11).EQ.0) THEN CALL DMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, 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 IF ( id%KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT(N, FRERE(1), FILS(1), NFSIZ(1), & id%KEEP(20)) END IF ELSE CALL DMUMPS_SPLIT_ROOT( id%NSLAVES, & HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & N, FRERE(1), FILS(1), NFSIZ(1), & id%KEEP(1), id%KEEP8(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, & id%INFOG(6)) END IF END IF ENDIF END IF RETURN END SUBROUTINE DMUMPS_ANA_F_PAR SUBROUTINE DMUMPS_SET_PAR_ORD(id, COMM_PARASYMB, MYID, NPROCS, & ord, & COMM_PARAORD, NPROCS_PARAORD, RKinSYMB_PROC0ORD) TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, INTENT(IN) :: COMM_PARASYMB, MYID, NPROCS INTEGER, INTENT(IN), OPTIONAL :: COMM_PARAORD, NPROCS_PARAORD, & RKinSYMB_PROC0ORD INTEGER :: IERR #if defined(parmetis) || defined(parmetis3) INTEGER :: I INTEGER :: COLOR, BASE, WORKERS LOGICAL :: IDO #endif IF (id%KEEP(339).GT.0) THEN ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%COMM = COMM_PARASYMB ord%MYID = MYID ord%NPROCS = NPROCS ord%COMM_PARAORD = COMM_PARAORD ord%RKinSYMB_PROC0ORD = RKinSYMB_PROC0ORD ord%NPROCS_PARAORD = NPROCS_PARAORD ord%IDO = (COMM_PARAORD.NE.MPI_COMM_NULL) IF (ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ELSE ord%MYID_PARAORD = -1 ENDIF IF (id%KEEP(245) .EQ. 1) THEN #if defined(ptscotch) ord%ORDTOOL = 1 IF(PROKG) WRITE(MPG, & '(" Using PT-SCOTCH for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(ord%MYID .EQ.0 ) WRITE(LP, & '(" PT-SCOTCH not available")') RETURN #endif ELSE IF (id%KEEP(245) .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) ord%ORDTOOL = 2 IF(PROKG) WRITE(MPG, & '(" Using ParMETIS for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(ord%MYID .EQ.0 ) WRITE(LP, & '(" ParMETIS not available.")') RETURN #endif END IF ELSE ord%NPROCS = NPROCS ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%COMM = COMM_PARASYMB ord%MYID = MYID ord%RKinSYMB_PROC0ORD = NPROCS-id%NSLAVES 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%COMM_PARAORD = id%COMM_NODES ord%NPROCS_PARAORD = id%NSLAVES ord%IDO = (ord%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1) IF (ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ELSE ord%MYID_PARAORD = -1 ENDIF IF(PROKG) WRITE(MPG, & '(" Using PT-SCOTCH for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(ord%MYID .EQ.0 ) WRITE(LP, & '(" PT-SCOTCH not available")') RETURN #endif ELSE IF (id%KEEP(245) .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) BASE = ord%NPROCS-id%NSLAVES IF(N.LE.100) THEN WORKERS = 2 ELSE WORKERS = min(id%NSLAVES,N/16) END IF I=1 DO IF (I .GT. WORKERS) EXIT ord%NPROCS_PARAORD = I I = I*2 END DO IDO = (ord%MYID .GE. BASE) .AND. & (ord%MYID .LE. BASE+ord%NPROCS_PARAORD-1) ord%IDO = IDO IF ( IDO ) THEN COLOR = 1 ELSE COLOR = MPI_UNDEFINED END IF CALL MPI_COMM_SPLIT( COMM_PARASYMB, COLOR, 0, ord%COMM_PARAORD, & IERR ) IF (ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ELSE ord%MYID_PARAORD = -1 ENDIF ord%ORDTOOL = 2 IF(PROKG) WRITE(MPG, & '(" Using ParMETIS for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(ord%MYID .EQ.0 ) WRITE(LP, & '(" ParMETIS not available.")') RETURN #endif END IF ENDIF END SUBROUTINE DMUMPS_SET_PAR_ORD SUBROUTINE DMUMPS_DO_PAR_ORD(id, MYID, NPROCS, ord, & WORK, LWORK, LUMAT, & SIZEOFBLOCKS) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id INTEGER, INTENT(IN) :: MYID, NPROCS TYPE(ORD_TYPE) :: ord INTEGER :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK TYPE(LMATRIX_T), OPTIONAL :: LUMAT INTEGER, INTENT(IN), OPTIONAL :: SIZEOFBLOCKS(N) #if defined(parmetis) || defined(parmetis3) INTEGER :: IERR #endif TYPE(COMPACT_GRAPH_T) :: GCOMP_DIST IF (id%KEEP(339).NE.0) THEN CALL MUMPS_AB_LMAT_TO_CLEAN_G ( ord%MYID, & .FALSE., & .FALSE., & LUMAT, GCOMP_DIST, id%INFO, id%ICNTL & , MEMCNT & ) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ENDIF IF (ord%ORDTOOL .EQ. 1) THEN #if defined(ptscotch) IF (id%KEEP(339).NE.0) THEN CALL DMUMPS_PTSCOTCH_ORD(id, ord, WORK, LWORK, & GCOMP_DIST, & SIZEOFBLOCKS ) ELSE CALL DMUMPS_PTSCOTCH_ORD(id, ord, WORK, LWORK) ENDIF #else id%INFOG(1) = -38 id%INFO(1) = -38 WRITE(LP,*)'PT-SCOTCH not available. Aborting...' CALL MUMPS_ABORT() #endif ELSE IF (ord%ORDTOOL .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) IF (id%KEEP(339).GT.0) THEN CALL DMUMPS_PARMETIS_ORD_LUMAT (id, ord, WORK, LWORK, & GCOMP_DIST, & SIZEOFBLOCKS) ELSE CALL DMUMPS_PARMETIS_ORD(id, ord, WORK, LWORK) ENDIF IF (id%KEEP(339).EQ.0) THEN if(ord%IDO) CALL MPI_COMM_FREE(ord%COMM_PARAORD, IERR) ENDIF #else id%INFOG(1) = -38 id%INFO(1) = -38 WRITE(LP,*)'ParMETIS not available. Aborting...' CALL MUMPS_ABORT() #endif END IF IF (id%KEEP(339).NE.0) THEN CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST, MEMCNT) ENDIF RETURN END SUBROUTINE DMUMPS_DO_PAR_ORD #if defined(parmetis) || defined(parmetis3) SUBROUTINE DMUMPS_PARMETIS_ORD(id, ord, WORK, LWORK) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT (IN) :: LWORK INTEGER :: I, MYID, NPROCS, IERR, BASE, METIS_IDX_SIZE INTEGER, POINTER :: FIRST(:), LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & OPTIONS(10) INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:), RCVCNTS(:) INTEGER(8) :: EDGELOCNBR INTEGER, POINTER :: SIZES(:), ORDER(:) INTEGER, POINTER :: IDUMMY_PTR(:) INTEGER :: SIZE_IDUMMY_PTR nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB, RCVCNTS, & SIZES, ORDER, IDUMMY_PTR) MYID = ord%MYID NPROCS = ord%NPROCS IERR = 0 SIZE_IDUMMY_PTR = 0 IF( LWORK.LT. int(N,8)*3_8 .OR. LWORK .LT. int(NPROCS+1,8)) THEN WRITE(LP, & '("Insufficient workspace inside DMUMPS_PARMETIS_ORD")') CALL MUMPS_ABORT() END IF BASEVAL = 1 CALL MUMPS_REALLOC(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT BASE = id%NPROCS-id%NSLAVES CALL DMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK(1_8: 2_8*int(N,8)), & 2_8*int(N,8), TYPE=2) VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 CALL MUMPS_I8REALLOC(VERTLOCTAB, VERTLOCNBR+1, id%INFO, & LP, STRING='VERTLOCTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT SWORK => WORK(int(N+1,8):3_8*int(N,8)) CALL DMUMPS_BUILD_DIST_GRAPH(id, ord, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK, 2_8 * int(N,8)) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF(id%INFO(1).LT.0) GOTO 20 EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1_8 OPTIONS(:) = 0 ORDER => WORK(1:N) CALL MUMPS_REALLOC(SIZES, 2*ord%NPROCS_PARAORD, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IF(ord%IDO) THEN CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 1 ELSE CALL MUMPS_PARMETIS_MIXEDto32(id, & BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & IDUMMY_PTR, SIZE_IDUMMY_PTR, & SIZES, ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ENDIF ELSE IF (METIS_IDX_SIZE.EQ.64) THEN CALL MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & IDUMMY_PTR, SIZE_IDUMMY_PTR, & SIZES, ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ELSE WRITE(*,*) & "Internal error in PARMETIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() END IF END IF IF (id%KEEP(339).NE.0) THEN nullify(VERTLOCTAB, EDGELOCTAB) ELSE CALL MUMPS_IDEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(VERTLOCTAB) ENDIF IF(IERR.GT.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 20 CALL MPI_BCAST(SIZES(1), 2*ord%NPROCS_PARAORD, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) ord%CBLKNBR = 2*ord%NPROCS_PARAORD-1 CALL MUMPS_REALLOC(RCVCNTS, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, id%NPROCS RCVCNTS(I) = max(LAST(I)-FIRST(I)+1,0) END DO FIRST = FIRST-1 IF(FIRST(1) .LT. 0) THEN FIRST(1) = 0 END IF CALL MPI_ALLGATHERV ( ORDER(1), VERTLOCNBR, MPI_INTEGER, & ord%PERMTAB(1), & RCVCNTS(1), FIRST(1), MPI_INTEGER, ord%COMM, IERR ) DO I=1, N ord%PERITAB(ord%PERMTAB(I)) = I END DO CALL MUMPS_REALLOC(ord%RANGTAB, 2*ord%NPROCS_PARAORD, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL DMUMPS_BUILD_TREETAB(ord%TREETAB, ord%RANGTAB, & SIZES, ord%CBLKNBR) CALL MUMPS_DEALLOC(SIZES, FIRST, LAST, & RCVCNTS, MEMCNT=MEMCNT) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL DMUMPS_BUILD_TREE(ord) RETURN 20 CONTINUE CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(SIZES , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) RETURN END SUBROUTINE DMUMPS_PARMETIS_ORD SUBROUTINE DMUMPS_PARMETIS_ORD_LUMAT (id, ord, WORK, LWORK, & GCOMP_DIST, & SIZEOFBLOCKS ) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK TYPE(COMPACT_GRAPH_T), OPTIONAL :: GCOMP_DIST INTEGER, INTENT(IN), OPTIONAL, TARGET :: SIZEOFBLOCKS(N) INTEGER :: I, MYID, NPROCS, IERR, BASE, METIS_IDX_SIZE INTEGER :: MASTER PARAMETER (MASTER=0) INTEGER, POINTER :: FIRST(:), LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & OPTIONS(10) INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:), RCVCNTS(:) INTEGER(8) :: EDGELOCNBR INTEGER, POINTER :: SIZES(:), ORDER(:) INTEGER, POINTER :: VELOLOCTAB(:) INTEGER :: SIZE_VELOLOCTAB INTEGER, TARGET :: IDUMMY(1) nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB, RCVCNTS, & SIZES, ORDER ) VELOLOCTAB => IDUMMY MYID = ord%MYID NPROCS = ord%NPROCS IERR = 0 SIZE_VELOLOCTAB = 0 IF( LWORK.LT. int(N,8)*3_8 .OR. LWORK .LT. int(NPROCS+1,8)) THEN WRITE(LP, & '("Insufficient workspace inside DMUMPS_PARMETIS_ORD")') CALL MUMPS_ABORT() END IF IF(ord%IDO) THEN CALL MUMPS_REALLOC(FIRST, ord%NPROCS_PARAORD+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, ord%NPROCS_PARAORD+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_REALLOC(SIZES, 2*ord%NPROCS_PARAORD, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 20 IF(ord%IDO) THEN CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) VERTLOCNBR = GCOMP_DIST%LAST-GCOMP_DIST%FIRST+1 EDGELOCNBR = GCOMP_DIST%NZG VERTLOCTAB => GCOMP_DIST%IPE EDGELOCTAB => GCOMP_DIST%ADJ IF (id%KEEP(339).NE.0) THEN VELOLOCTAB=>SIZEOFBLOCKS(GCOMP_DIST%FIRST:GCOMP_DIST%LAST) SIZE_VELOLOCTAB = VERTLOCNBR ENDIF DO I=1,ord%NPROCS_PARAORD+1 FIRST(I) = -99 LAST(I) = -99 ENDDO BASE = 0 #if defined(AVOID_MPI_IN_PLACE) CALL MPI_ALLGATHER( GCOMP_DIST%FIRST, 1, MPI_INTEGER, & FIRST, 1, MPI_INTEGER, ord%COMM_PARAORD, IERR ) CALL MPI_ALLGATHER( GCOMP_DIST%LAST, 1, MPI_INTEGER, & LAST, 1, MPI_INTEGER, ord%COMM_PARAORD, IERR ) #else FIRST(ord%MYID_PARAORD + 1)= GCOMP_DIST%FIRST LAST (ord%MYID_PARAORD + 1)= GCOMP_DIST%LAST CALL MPI_ALLREDUCE(MPI_IN_PLACE, FIRST(1), & ord%NPROCS_PARAORD+1, & MPI_INTEGER, MPI_MAX, ord%COMM_PARAORD, IERR) CALL MPI_ALLREDUCE(MPI_IN_PLACE, LAST(1), & ord%NPROCS_PARAORD+1, & MPI_INTEGER, MPI_MAX, ord%COMM_PARAORD, IERR) #endif DO I=1, ord%NPROCS_PARAORD+1 IF (FIRST(I).EQ.-99) THEN FIRST(I) = GCOMP_DIST%NG+1 ENDIF IF (LAST(I).EQ.-99) THEN LAST (I) = GCOMP_DIST%NG ENDIF ENDDO OPTIONS(:) = 0 ORDER => WORK(1:N) BASEVAL = 1 IF (METIS_IDX_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 1 ELSE CALL MUMPS_PARMETIS_MIXEDto32(id, & BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & VELOLOCTAB, SIZE_VELOLOCTAB, & SIZES, ord%COMM_PARAORD, ord%MYID_PARAORD, & IERR) ENDIF ELSE IF (METIS_IDX_SIZE.EQ.64) THEN CALL MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & VELOLOCTAB, SIZE_VELOLOCTAB, & SIZES, ord%COMM_PARAORD, ord%MYID_PARAORD, & IERR) ELSE WRITE(*,*) & "Internal error in PARMETIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() END IF END IF nullify(VERTLOCTAB, EDGELOCTAB) IF(IERR.GT.0) THEN id%INFO(1:2) = -50 END IF ord%CBLKNBR = 2*ord%NPROCS_PARAORD-1 CALL MUMPS_REALLOC(ord%RANGTAB, ord%CBLKNBR+1, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_REALLOC(RCVCNTS, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 20 IF (ord%IDO) THEN DO I=1, ord%NPROCS_PARAORD 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_GATHERV ( ORDER(1), VERTLOCNBR, MPI_INTEGER, & ord%PERMTAB(1), & RCVCNTS(1), FIRST(1), MPI_INTEGER, MASTER, & ord%COMM_PARAORD, IERR ) END IF IF (ord%MYID_PARAORD.EQ.MASTER) THEN DO I=1, N ord%PERITAB(ord%PERMTAB(I)) = I END DO CALL MUMPS_REALLOC(ord%TREETAB, ord%CBLKNBR, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL DMUMPS_BUILD_TREETAB(ord%TREETAB, ord%RANGTAB, & SIZES, ord%CBLKNBR) ENDIF CALL MUMPS_DEALLOC(SIZES, FIRST, LAST, & RCVCNTS, MEMCNT=MEMCNT) CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%PERMTAB(1), N, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%PERITAB(1), N, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%RANGTAB(1), ord%CBLKNBR+1, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%TREETAB(1), ord%CBLKNBR, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL DMUMPS_BUILD_TREE(ord) RETURN 20 CONTINUE CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(SIZES , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) RETURN END SUBROUTINE DMUMPS_PARMETIS_ORD_LUMAT #endif #if defined(ptscotch) SUBROUTINE DMUMPS_PTSCOTCH_ORD(id, ord, WORK, LWORK, GCOMP_DIST, & SIZEOFBLOCKS) !$ USE OMP_LIB IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK TYPE(COMPACT_GRAPH_T), OPTIONAL :: GCOMP_DIST INTEGER, INTENT(IN), OPTIONAL, TARGET:: SIZEOFBLOCKS(N) INTEGER :: MYID, NPROCS, IERR INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & BASE, SCOTCH_INT_SIZE INTEGER(8) :: EDGELOCNBR INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:) INTEGER, POINTER :: VELOLOCTAB(:) INTEGER :: SIZE_VELOLOCTAB INTEGER, TARGET :: IDUMMY(1) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) INCLUDE 'scotchf.h' INTEGER :: IOMP, NOMP DOUBLE PRECISION :: CONTDAT(SCOTCH_CONTEXTDIM) INTEGER(4) :: IERR_SCOTCH #else INTEGER :: PTHREAD_NUMBER, NOMP #endif nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB) VELOLOCTAB => IDUMMY CALL MPI_BARRIER(ord%COMM, IERR) MYID = ord%MYID NPROCS = ord%NPROCS SIZE_VELOLOCTAB = 0 BASEVAL = 1 IF (id%KEEP(339).NE.0) THEN VERTLOCNBR = GCOMP_DIST%LAST-GCOMP_DIST%FIRST+1 EDGELOCNBR = GCOMP_DIST%NZG VERTLOCTAB => GCOMP_DIST%IPE EDGELOCTAB => GCOMP_DIST%ADJ IF (id%KEEP(339).NE.0) THEN VELOLOCTAB => SIZEOFBLOCKS(GCOMP_DIST%FIRST:GCOMP_DIST%LAST) SIZE_VELOLOCTAB = VERTLOCNBR ENDIF ELSE IF (LWORK .LT. int(N,8)*3_8) THEN WRITE(LP, & '("Insufficient workspace inside DMUMPS_PTSCOTCH_ORD")') CALL MUMPS_ABORT() END IF BASE = id%NPROCS-id%NSLAVES CALL MUMPS_REALLOC(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL DMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK(1: 2_8*int(N,8)), & 2_8*int(N,8), TYPE=2) VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 CALL MUMPS_I8REALLOC(VERTLOCTAB, VERTLOCNBR+1, id%INFO, & LP, STRING='VERTLOCTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT SWORK => WORK(int(N+1,8):3_8*int(N,8)) CALL DMUMPS_BUILD_DIST_GRAPH(id, ord, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK, 2_8*int(N,8)) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 11 EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1_8 ENDIF CALL MUMPS_REALLOC(ord%PERMTAB, N, id%INFO, & LP, STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%PERITAB, N, id%INFO, & LP, STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%RANGTAB, N+1, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%TREETAB, N, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IF(ord%IDO) THEN CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) !$OMP PARALLEL PRIVATE(IOMP, IERR_SCOTCH) !$OMP SINGLE NOMP=omp_get_num_threads() !$OMP END SINGLE IOMP=omp_get_thread_num() IF (IOMP.EQ.0) THEN CALL SCOTCHFCONTEXTINIT(CONTDAT, IERR_SCOTCH) CALL SCOTCHFCONTEXTRANDOMCLONE(CONTDAT, IERR_SCOTCH) CALL SCOTCHFCONTEXTTHREADIMPORT1(CONTDAT, NOMP, IERR_SCOTCH) ENDIF !$OMP BARRIER CALL SCOTCHFCONTEXTTHREADIMPORT2(CONTDAT, IOMP, IERR_SCOTCH) #else NOMP=0 !$ NOMP=omp_get_max_threads() IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (PTHREAD_NUMBER) CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (NOMP) ENDIF #endif #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) IF (IOMP.EQ.0) THEN #endif IF(SCOTCH_INT_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 2 ELSE CALL MUMPS_PTSCOTCH_MIXEDto32(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & VELOLOCTAB, SIZE_VELOLOCTAB, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, SCOTCH_CONTEXTDIM, #endif & IERR) ENDIF ELSE CALL MUMPS_PTSCOTCH_MIXEDto64(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & VELOLOCTAB, SIZE_VELOLOCTAB, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, SCOTCH_CONTEXTDIM, #endif & IERR) END IF #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL SCOTCHFCONTEXTEXIT(CONTDAT) ENDIF !$OMP END PARALLEL #else IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (PTHREAD_NUMBER) ENDIF #endif END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 11 CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%PERMTAB(1), N, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%PERITAB(1), N, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%RANGTAB(1), ord%CBLKNBR+1, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%TREETAB(1), ord%CBLKNBR, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) CALL DMUMPS_BUILD_TREE(ord) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ord%N = N IF (id%KEEP(339).NE.0) THEN nullify(VERTLOCTAB, EDGELOCTAB) ELSE CALL MUMPS_DEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(VERTLOCTAB, MEMCNT=MEMCNT) ENDIF RETURN 11 CONTINUE IF (id%KEEP(339).NE.0) THEN CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(VERTLOCTAB, MEMCNT=MEMCNT) ELSE CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) nullify(VERTLOCTAB, EDGELOCTAB) ENDIF RETURN END SUBROUTINE DMUMPS_PTSCOTCH_ORD #endif FUNCTION DMUMPS_STOP_DESCENT(id, ord, NACTIVE, ANODE, RPROC, & ALIST, LIST, PEAKMEM, NNODES, CHECKMEM) IMPLICIT NONE LOGICAL :: DMUMPS_STOP_DESCENT INTEGER :: NACTIVE, RPROC, ANODE, PEAKMEM, NNODES INTEGER :: ALIST(NNODES), LIST(NNODES) TYPE(ORD_TYPE) :: ord TYPE(DMUMPS_STRUC) :: id LOGICAL, OPTIONAL :: CHECKMEM INTEGER :: IPEAKMEM, BIG, MAX_NROWS, MIN_NROWS INTEGER :: TOPROWS, NRL, HOSTMEM, SUBMEM INTEGER :: I, NZ_ROW, WEIGHT LOGICAL :: ICHECKMEM INTEGER :: NZ4 IF(present(CHECKMEM)) THEN ICHECKMEM = CHECKMEM ELSE ICHECKMEM = .FALSE. END IF DMUMPS_STOP_DESCENT = .FALSE. IF(NACTIVE .GE. RPROC) THEN DMUMPS_STOP_DESCENT = .TRUE. RETURN END IF IF(NACTIVE .EQ. 0) THEN DMUMPS_STOP_DESCENT = .TRUE. RETURN END IF IF(.NOT. ICHECKMEM) RETURN BIG = ALIST(NACTIVE) IF(NACTIVE .GT. 1) THEN MAX_NROWS = ord%NW(ALIST(NACTIVE-1)) MIN_NROWS = ord%NW(ALIST(1)) ELSE MAX_NROWS = 0 MIN_NROWS = 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 *N HOSTMEM = 12*N NZ4=int(id%KEEP8(28)) NZ_ROW = 2*(NZ4/N) IF (id%KEEP(339).NE.0) THEN NRL = 0 ELSE IF(id%KEEP(46) .EQ. 0) THEN NRL = 0 ELSE NRL = MIN_NROWS END IF ENDIF HOSTMEM = HOSTMEM + 2*TOPROWS*NZ_ROW HOSTMEM = HOSTMEM +NRL HOSTMEM = HOSTMEM + max(NRL,TOPROWS)*(NZ_ROW+2) HOSTMEM = HOSTMEM + 6*max(NRL,TOPROWS) HOSTMEM = HOSTMEM + 3*TOPROWS NRL = MAX_NROWS SUBMEM = SUBMEM +NRL SUBMEM = SUBMEM + NRL*(NZ_ROW+2) SUBMEM = SUBMEM + 6*NRL IPEAKMEM = max(HOSTMEM, SUBMEM) IF((IPEAKMEM .GT. PEAKMEM) .AND. & (PEAKMEM .NE. 0)) THEN DMUMPS_STOP_DESCENT = .TRUE. RETURN ELSE DMUMPS_STOP_DESCENT = .FALSE. PEAKMEM = IPEAKMEM RETURN END IF END FUNCTION DMUMPS_STOP_DESCENT FUNCTION DMUMPS_CNT_KIDS(NODE, ord) IMPLICIT NONE INTEGER :: DMUMPS_CNT_KIDS INTEGER :: NODE TYPE(ORD_TYPE) :: ord INTEGER :: CURR DMUMPS_CNT_KIDS = 0 IF(ord%SON(NODE) .EQ. -1) THEN RETURN ELSE DMUMPS_CNT_KIDS = 1 CURR = ord%SON(NODE) DO IF(ord%BROTHER(CURR) .NE. -1) THEN DMUMPS_CNT_KIDS = DMUMPS_CNT_KIDS+1 CURR = ord%BROTHER(CURR) ELSE EXIT END IF END DO END IF RETURN END FUNCTION DMUMPS_CNT_KIDS SUBROUTINE DMUMPS_GET_SUBTREES(ord, id) USE MUMPS_TOOLS_COMMON_M, ONLY : MUMPS_MERGESORT, & MUMPS_MERGESWAP IMPLICIT NONE TYPE(ORD_TYPE) :: ord TYPE(DMUMPS_STRUC) :: id INTEGER, ALLOCATABLE :: ALIST(:), AWEIGHTS(:), LIST(:), WORK(:) INTEGER :: NNODES, BIG, CURR, ND, NACTIVE, RPROC, ANODE, BASE, I, & NK, PEAKMEM, allocok, Iprocdeb LOGICAL :: SD NNODES = ord%NPROCS_PARAORD CALL MUMPS_REALLOC(ord%TOPNODES, 2*max(NNODES,2), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%FIRST, ord%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%LAST, ord%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(ALIST(NNODES), AWEIGHTS(NNODES), LIST(NNODES), & WORK(0:NNODES+1), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=4*NNODES+2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 NACTIVE = 0 DO I=1, ord%CBLKNBR IF (ord%TREETAB(I).EQ.-1) THEN NACTIVE = NACTIVE+1 IF(NACTIVE.LE.NNODES) THEN ALIST(NACTIVE) = I AWEIGHTS(NACTIVE) = ord%NW(I) END IF END IF END DO IF((ord%CBLKNBR .EQ. 1) .OR. & (NACTIVE.GT.NNODES) .OR. & ( NNODES .LT. DMUMPS_CNT_KIDS(ord%CBLKNBR, ord) )) THEN ord%TOPNODES =0 ord%TOPNODES(1) = 1 ord%TOPNODES(2) = ord%RANGTAB(ord%CBLKNBR+1) - ord%RANGTAB(1) ord%TOPNODES(3) = ord%RANGTAB(1) ord%TOPNODES(4) = ord%RANGTAB(ord%CBLKNBR+1)-1 ord%FIRST = 0 ord%LAST = -1 RETURN END IF CALL MUMPS_MERGESORT(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL MUMPS_MERGESWAP(NACTIVE, WORK(0:NACTIVE+1), & AWEIGHTS(1:NACTIVE), & ALIST(1:NACTIVE)) RPROC = NNODES ANODE = 0 PEAKMEM = 0 ord%TOPNODES = 0 DO IF(NACTIVE .EQ. 0) EXIT BIG = ALIST(NACTIVE) NK = DMUMPS_CNT_KIDS(BIG, ord) IF((NK .GT. (RPROC-NACTIVE+1)) .OR. (NK .EQ. 0)) THEN ANODE = ANODE+1 LIST(ANODE) = BIG NACTIVE = NACTIVE-1 RPROC = RPROC-1 CYCLE END IF SD = DMUMPS_STOP_DESCENT(id, ord, NACTIVE, ANODE, & RPROC, ALIST, LIST, PEAKMEM, NNODES, CHECKMEM=.TRUE.) IF ( SD ) & THEN IF(NACTIVE.GT.0) THEN LIST(ANODE+1:ANODE+NACTIVE) = ALIST(1:NACTIVE) ANODE = ANODE+NACTIVE END IF EXIT END IF ord%TOPNODES(1) = ord%TOPNODES(1)+1 ord%TOPNODES(2) = ord%TOPNODES(2) + & ord%RANGTAB(BIG+1) - ord%RANGTAB(BIG) ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+1) = ord%RANGTAB(BIG) ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+2) = & ord%RANGTAB(BIG+1)-1 CURR = ord%SON(BIG) ALIST(NACTIVE) = CURR AWEIGHTS(NACTIVE) = ord%NW(CURR) DO IF(ord%BROTHER(CURR) .EQ. -1) EXIT NACTIVE = NACTIVE+1 CURR = ord%BROTHER(CURR) ALIST(NACTIVE) = CURR AWEIGHTS(NACTIVE) = ord%NW(CURR) END DO CALL MUMPS_MERGESORT(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL MUMPS_MERGESWAP(NACTIVE, WORK(0:NACTIVE+1), & AWEIGHTS(1:NACTIVE), & ALIST(1:NACTIVE)) END DO DO I=1, ANODE AWEIGHTS(I) = ord%NW(LIST(I)) END DO CALL MUMPS_MERGESORT(ANODE, AWEIGHTS(1:ANODE), WORK(0:ANODE+1)) CALL MUMPS_MERGESWAP(ANODE, WORK(0:ANODE+1), AWEIGHTS(1:ANODE), & ALIST(1:ANODE)) IF (id%KEEP(339).NE.0) THEN Iprocdeb = ord%NPROCS-ANODE+1 IF (Iprocdeb.GT.1) THEN DO I=1, Iprocdeb-1 ord%FIRST(I) = 0 ord%LAST(I) = -1 ENDDO ENDIF 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(Iprocdeb) = ord%RANGTAB(ND) ord%LAST(Iprocdeb) = ord%RANGTAB(CURR+1)-1 Iprocdeb = Iprocdeb +1 ENDDO ELSE 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) = N+1 ord%LAST(BASE+I) = N END DO ENDIF DEALLOCATE(LIST, ALIST, AWEIGHTS, WORK) 90 continue RETURN END SUBROUTINE DMUMPS_GET_SUBTREES SUBROUTINE DMUMPS_PARSYMFACT(id, ord, GPE, GNV, WORK, LWORK) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: GPE(:), GNV(:) INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:), IPET(:), & BUF_PE1(:), BUF_PE2(:), TMP1(:) INTEGER, POINTER :: PE(:), LENG(:), I_HALO_MAP(:) INTEGER, POINTER :: NDENSE(:), LAST(:), & DEGREE(:), W(:), PERM(:), & LISTVAR_SCHUR(:), NEXT(:), & HEAD(:), NV(:), ELEN(:), & LSTVAR(:) INTEGER, POINTER :: MYLIST(:), LPERM(:), LIPERM(:), & NVT(:), BUF_NV1(:), & BUF_NV2(:), ROOTPERM(:), & TMP2(:), BWORK(:), NCLIQUES(:) INTEGER :: MYNCLIQUES, MYMAXVARS, ICLIQUES, & TOTNCLIQUES INTEGER(8) :: MYNVARS, TOTNVARS INTEGER(8), POINTER :: LVARPT(:) INTEGER :: HIDX, TOTEL, & NCMPA, I, J, SIZE_SCHUR, MYID, & NPROCS, IERR, NROWS_LOC, GLOB_IDX, TMP, & NTVAR, TGSIZE, MAXS, RHANDPE, & RHANDNV, RIDX, PROC, JOB, K INTEGER(8) :: PFREES, PFS_SAVE, PELEN, PFREET, PFT_SAVE INTEGER :: STATUSPE(MPI_STATUS_SIZE) INTEGER :: STATUSNV(MPI_STATUS_SIZE) INTEGER :: STATUSCLIQUES(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30 LOGICAL :: AGG6 INTEGER :: THRESH nullify(PE, IPE, LENG, I_HALO_MAP, NCLIQUES) nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, & NEXT, HEAD, NV, ELEN, LSTVAR) nullify(MYLIST, LVARPT, & LPERM, LIPERM, IPET, NVT, BUF_PE1, BUF_PE2, & BUF_NV1, BUF_NV2, ROOTPERM, TMP1, TMP2, BWORK) MYID = ord%MYID NPROCS = ord%NPROCS IF(LWORK .LT. 4_8*int(N,8)) THEN WRITE(LP,*)'Insufficient workspace in DMUMPS_PARSYMFACT' CALL MUMPS_ABORT() ELSE HEAD => WORK( 1 : N ) ELEN => WORK( int(N,8)+1 : 2_8*int(N,8) ) LENG => WORK( 2_8*int(N,8)+1 : 3_8*int(N,8) ) PERM => WORK( 3_8*int(N,8)+1 : 4_8*int(N,8) ) END IF CALL DMUMPS_GET_SUBTREES(ord, id) CALL MUMPS_IDEALLOC(ord%SON, ord%BROTHER, ord%NW, & ord%RANGTAB, MEMCNT=MEMCNT) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 NRL = NROWS_LOC TOPROWS = ord%TOPNODES(2) BWORK => WORK(1_8 : 2_8*int(N,8)) CALL DMUMPS_BUILD_LOC_GRAPH(id, ord, HIDX, IPE, PE, LENG, & I_HALO_MAP, top_graph, BWORK, 2_8*int(N,8)) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF(id%INFO(1).lt.0) RETURN TMP = N DO I=1, NPROCS TMP = TMP-(ord%LAST(I)-ord%FIRST(I)+1) END DO TMP = ceiling(dble(TMP)*1.10D0) IF(MYID .EQ. 0) THEN TMP = max(max(TMP, HIDX),1) ELSE TMP = max(HIDX,1) END IF SIZE_SCHUR = HIDX - NROWS_LOC CALL MUMPS_REALLOC(NDENSE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, SIZE_SCHUR LISTVAR_SCHUR(I) = NROWS_LOC+I END DO THRESH = -1 AGG6 = .FALSE. PFREES = IPE(NROWS_LOC+1) PFS_SAVE = PFREES PELEN = PFREES-1 + 2_8*int(NROWS_LOC+ord%TOPNODES(2),8) DO I=1, HIDX PERM(I) = I END DO IF(SIZE_SCHUR.EQ.0) THEN JOB = 0 ELSE JOB = 1 END IF IF(HIDX .GT.0) THEN TOTEL = HIDX NV(1) = -1 CALL MUMPS_SYMQAMD_NEW(JOB, THRESH, NDENSE(1), HIDX, & TOTEL, PELEN, IPE(1), PFREES, LENG(1), PE(1), NV(1), & ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), NEXT(1), & W(1), PERM(1), LISTVAR_SCHUR(1), SIZE_SCHUR, AGG6) ENDIF MYNCLIQUES = 0 MYNVARS = 0 MYMAXVARS = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN MYMAXVARS = MAX(MYMAXVARS,LENG(I)) MYNVARS = MYNVARS+LENG(I) MYNCLIQUES = MYNCLIQUES+1 END IF END DO CALL MPI_REDUCE(MYNVARS, TOTNVARS, 1, MPI_INTEGER8, & MPI_SUM, 0, ord%COMM, IERR) CALL MUMPS_REALLOC(NCLIQUES, NPROCS, id%INFO, & LP, STRING='NCLIQUES', MEMCNT=MEMCNT, ERRCODE=-7) CALL MPI_GATHER(MYNCLIQUES, 1, MPI_INTEGER, NCLIQUES(1), 1, & MPI_INTEGER, 0, ord%COMM, IERR) IF(ord%MYID.EQ.0) THEN TOTNCLIQUES = sum(NCLIQUES) CALL MUMPS_I8REALLOC(LVARPT, TOTNCLIQUES+1, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(LSTVAR, TOTNVARS, id%INFO, & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) LVARPT(1) = 1_8 ICLIQUES = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN ICLIQUES = ICLIQUES+1 LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+LENG(I) DO J=0, LENG(I)-1 LSTVAR(LVARPT(ICLIQUES)+J) = & I_HALO_MAP(PE(IPE(I)+J)-NROWS_LOC) END DO END IF END DO DO PROC=1, NPROCS-1 DO I=1, NCLIQUES(PROC+1) ICLIQUES = ICLIQUES+1 CALL MPI_RECV(K, 1, MPI_INTEGER, PROC, ITAG, ord%COMM, & STATUSCLIQUES, IERR) LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+K CALL MPI_RECV(LSTVAR(LVARPT(ICLIQUES)), K, MPI_INTEGER, & PROC, ITAG, ord%COMM, STATUSCLIQUES, IERR) END DO END DO LPERM => WORK(3_8*int(N,8)+1_8 : 4_8*int(N,8)) NTVAR = ord%TOPNODES(2) CALL DMUMPS_MAKE_LOC_IDX(id, ord%TOPNODES, LPERM, LIPERM, ord) CALL DMUMPS_ASSEMBLE_TOP_GRAPH(id, ord%TOPNODES(2), LPERM, & top_graph, TOTNCLIQUES, LSTVAR, LVARPT, IPET, PE, & LENG, ELEN) TGSIZE = ord%TOPNODES(2)+TOTNCLIQUES PFREET = IPET(TGSIZE+1) PFT_SAVE = PFREET nullify(LPERM) ELSE CALL MUMPS_REALLOC(MYLIST, MYMAXVARS, id%INFO, & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, HIDX IF(IPE(I) .GT. 0) THEN DO J=1, LENG(I) MYLIST(J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) END DO CALL MPI_SEND(LENG(I), 1, MPI_INTEGER, 0, ITAG, & ord%COMM, IERR) CALL MPI_SEND(MYLIST(1), LENG(I), MPI_INTEGER, 0, ITAG, & ord%COMM, IERR) END IF END DO END IF CALL MUMPS_IDEALLOC(top_graph%IRN_LOC, & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN CALL MUMPS_IREALLOC8(PE, max(PFREET+int(TGSIZE,8),1_8),id%INFO, & LP, COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, & ERRCODE=-7) CALL MUMPS_REALLOC(NDENSE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NVT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, max(TGSIZE,1), id%INFO, LP, & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, max(TGSIZE,1), id%INFO, LP, & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(TOTNCLIQUES,1), id%INFO, & LP, STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TOTNCLIQUES LISTVAR_SCHUR(I) = NTVAR+I END DO THRESH = -1 CALL MUMPS_REALLOC(HEAD, max(TGSIZE,1), id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(PERM, max(TGSIZE,1), id%INFO, & LP, COPY=.TRUE., STRING='J2:PERM', & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TGSIZE PERM(I) = I END DO PELEN = max(PFREET+int(TGSIZE,8),1_8) IF(TGSIZE.GT.0) THEN TOTEL = TGSIZE NVT(1) = -1 CALL MUMPS_SYMQAMD_NEW(2, -1, NDENSE(1), TGSIZE, & TOTEL, PELEN, IPET(1), PFREET, LENG(1), PE(1), & NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), & NEXT(1), W(1), PERM(1), LISTVAR_SCHUR(1), TOTNCLIQUES, & AGG6) ENDIF END IF CALL MPI_BARRIER(ord%COMM, IERR) CALL MPI_BARRIER(ord%COMM, IERR) CALL MUMPS_DEALLOC(LISTVAR_SCHUR, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN MAXS = NROWS_LOC DO I=2, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) & MAXS = (ord%LAST(I)-ord%FIRST(I)+1) END DO CALL MUMPS_I8REALLOC(BUF_PE1, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(BUF_PE2, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV1, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV2, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GPE, N, id%INFO, & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GNV, N, id%INFO, & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ROOTPERM, TOTNCLIQUES, id%INFO, & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RIDX = 0 TMP1 => BUF_PE1 TMP2 => BUF_NV1 NULLIFY(BUF_PE1, BUF_NV1) BUF_PE1 => IPE BUF_NV1 => NV DO PROC=0, NPROCS-2 CALL MPI_IRECV(BUF_PE2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER8, PROC+1, PROC+1, & ord%COMM, RHANDPE, IERR) CALL MPI_IRECV(BUF_NV2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER, PROC+1, PROC+1, & ord%COMM, RHANDNV, IERR) DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO CALL MPI_WAIT(RHANDPE, STATUSPE, IERR) CALL MPI_WAIT(RHANDNV, STATUSNV, IERR) IF(PROC .NE. 0) THEN TMP1 => BUF_PE1 TMP2 => BUF_NV1 END IF BUF_PE1 => BUF_PE2 BUF_NV1 => BUF_NV2 NULLIFY(BUF_PE2, BUF_NV2) BUF_PE2 => TMP1 BUF_NV2 => TMP2 NULLIFY(TMP1, TMP2) END DO DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO DO I=1, NTVAR GLOB_IDX = LIPERM(I) IF(IPET(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = NVT(I) ELSE GPE(GLOB_IDX) = -LIPERM(-IPET(I)) GNV(GLOB_IDX) = NVT(I) END IF END DO DO I=1, TOTNCLIQUES GLOB_IDX = ROOTPERM(I) GPE(GLOB_IDX) = -LIPERM(-IPET(NTVAR+I)) END DO ELSE CALL MPI_SEND(IPE(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER8, 0, MYID, ord%COMM, IERR) CALL MPI_SEND(NV(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER, 0, MYID, ord%COMM, IERR) END IF CALL MUMPS_DEALLOC(BUF_NV1, BUF_NV2, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(BUF_PE1, BUF_PE2, IPE, IPET, & TMP1, LVARPT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, I_HALO_MAP, NDENSE, & LAST, DEGREE, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(W, LISTVAR_SCHUR, NEXT, & NV, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LSTVAR, NCLIQUES, MYLIST, & MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LPERM, LIPERM, NVT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ROOTPERM, TMP2, MEMCNT=MEMCNT) NULLIFY(HEAD, ELEN, LENG, PERM) RETURN END SUBROUTINE DMUMPS_PARSYMFACT SUBROUTINE DMUMPS_PARSYMFACT_LUMAT(id, ord, GPE, GNV, WORK, LWORK, & LUMAT, SIZEOFBLOCKS) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: GPE(:), GNV(:) INTEGER, TARGET :: WORK(:) TYPE(LMATRIX_T), INTENT(IN) :: LUMAT INTEGER, INTENT(IN) :: SIZEOFBLOCKS(id%NBLK) TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:), IPET(:), & BUF_PE1(:), BUF_PE2(:), TMP1(:) INTEGER, POINTER :: PE(:), & LENG(:), I_HALO_MAP(:) INTEGER, POINTER :: NDENSE(:), LAST(:), & DEGREE(:), W(:), PERM(:), & LISTVAR_SCHUR(:), NEXT(:), & HEAD(:), NV(:), ELEN(:), & LSTVAR(:) INTEGER, POINTER :: MYLIST(:), & LPERM(:), & LIPERM(:), & NVT(:), BUF_NV1(:), & BUF_NV2(:), ROOTPERM(:), & TMP2(:), BWORK(:), NCLIQUES(:), MAPTAB(:) INTEGER :: MYNCLIQUES, MYMAXVARS, ICLIQUES, & TOTNCLIQUES INTEGER(8) :: MYNVARS, TOTNVARS, LWORK INTEGER(8), POINTER :: LVARPT(:) INTEGER :: HIDX, TOTEL, & NCMPA, I, J, SIZE_SCHUR, MYID, & NPROCS, IERR, NROWS_LOC, GLOB_IDX, TMP, & NTVAR, TGSIZE, MAXS, RHANDPE, & RHANDNV, RIDX, PROC, JOB, K INTEGER(8) :: PFREES, PFS_SAVE, PELEN, PFREET, PFT_SAVE INTEGER :: STATUSPE(MPI_STATUS_SIZE) INTEGER :: STATUSNV(MPI_STATUS_SIZE) INTEGER :: STATUSCLIQUES(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30 LOGICAL :: AGG6 INTEGER :: THRESH nullify(PE, IPE, LENG, I_HALO_MAP, NCLIQUES) nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, & NEXT, HEAD, NV, ELEN, LSTVAR) nullify(MYLIST, LVARPT, MAPTAB, & LPERM, LIPERM, IPET, NVT, BUF_PE1, BUF_PE2, & BUF_NV1, BUF_NV2, ROOTPERM, TMP1, TMP2, BWORK, MAPTAB) MYID = ord%MYID NPROCS = ord%NPROCS IF( LWORK .LT. 4_8*int(N,8) ) THEN WRITE(LP,*) & 'Insufficient workspace in DMUMPS_PARSYMFACT_LUMAT' CALL MUMPS_ABORT() ENDIF HEAD => WORK( 1 : N ) ELEN => WORK( int(N,8)+1_8 : 2_8*int(N,8) ) LENG => WORK( 2_8*int(N,8)+1_8 : 3_8*int(N,8) ) PERM => WORK( 3_8*int(N,8)+1_8 : 4_8*int(N,8) ) CALL DMUMPS_GET_SUBTREES(ord, id) CALL MUMPS_IDEALLOC(ord%SON, ord%BROTHER, ord%NW, & ord%RANGTAB, MEMCNT=MEMCNT) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 NRL = NROWS_LOC TOPROWS = ord%TOPNODES(2) BWORK => WORK(1_8 : 2_8*int(N,8)) CALL DMUMPS_LUMAT_TO_LOC_GRAPH( & LUMAT, id, ord, HIDX, IPE, PE, LENG, & I_HALO_MAP, BWORK, 2_8*int(N,8)) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF(id%INFO(1).lt.0) RETURN TMP = N DO I=1, NPROCS TMP = TMP-(ord%LAST(I)-ord%FIRST(I)+1) END DO TMP = ceiling(dble(TMP)*1.10D0) IF(MYID .EQ. 0) THEN TMP = max(max(TMP, HIDX),1) ELSE TMP = max(HIDX,1) END IF SIZE_SCHUR = HIDX - NROWS_LOC CALL MUMPS_REALLOC(NDENSE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, SIZE_SCHUR LISTVAR_SCHUR(I) = NROWS_LOC+I END DO THRESH = -1 AGG6 = .FALSE. PFREES = IPE(NROWS_LOC+1) PFS_SAVE = PFREES PELEN = PFREES-1 + 2_8*int(NROWS_LOC+ord%TOPNODES(2),8) DO I=1, HIDX PERM(I) = I END DO IF(SIZE_SCHUR.EQ.0) THEN JOB = 0 ELSE JOB = 1 END IF IF(HIDX .GT.0) THEN NV(1) = -1 TOTEL = HIDX IF ((N.LT.NORIG).OR.(id%KEEP(339).NE.0)) THEN TOTEL = 0 DO I=1,NROWS_LOC NV(I) = SIZEOFBLOCKS ( & ord%PERITAB(ord%FIRST(MYID+1)+I-1) & ) TOTEL = TOTEL + NV(I) ENDDO DO I=NROWS_LOC+1, HIDX NV(I) = SIZEOFBLOCKS (I_HALO_MAP(I-NROWS_LOC)) TOTEL = TOTEL + NV(I) ENDDO ENDIF CALL MUMPS_SYMQAMD_NEW(JOB, THRESH, NDENSE(1), HIDX, & TOTEL, PELEN, IPE(1), PFREES, LENG(1), PE(1), NV(1), & ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), NEXT(1), & W(1), PERM(1), LISTVAR_SCHUR(1), SIZE_SCHUR, AGG6) ENDIF MYNCLIQUES = 0 MYNVARS = 0 MYMAXVARS = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN MYMAXVARS = MAX(MYMAXVARS,LENG(I)) MYNVARS = MYNVARS+LENG(I) MYNCLIQUES = MYNCLIQUES+1 END IF END DO CALL MPI_REDUCE(MYNVARS, TOTNVARS, 1, MPI_INTEGER8, & MPI_SUM, 0, ord%COMM, IERR) CALL MUMPS_REALLOC(NCLIQUES, NPROCS, id%INFO, & LP, STRING='NCLIQUES', MEMCNT=MEMCNT, ERRCODE=-7) CALL MPI_GATHER(MYNCLIQUES, 1, MPI_INTEGER, NCLIQUES(1), 1, & MPI_INTEGER, 0, ord%COMM, IERR) IF(ord%MYID.EQ.0) THEN TOTNCLIQUES = sum(NCLIQUES) CALL MUMPS_I8REALLOC(LVARPT, TOTNCLIQUES+1, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(LSTVAR, TOTNVARS, id%INFO, & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) LVARPT(1) = 1_8 ICLIQUES = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN ICLIQUES = ICLIQUES+1 LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+LENG(I) DO J=0, LENG(I)-1 LSTVAR(LVARPT(ICLIQUES)+J) = & I_HALO_MAP(PE(IPE(I)+J)-NROWS_LOC) END DO END IF END DO DO PROC=1, NPROCS-1 DO I=1, NCLIQUES(PROC+1) ICLIQUES = ICLIQUES+1 CALL MPI_RECV(K, 1, MPI_INTEGER, PROC, ITAG, ord%COMM, & STATUSCLIQUES, IERR) LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+K CALL MPI_RECV(LSTVAR(LVARPT(ICLIQUES)), K, MPI_INTEGER, & PROC, ITAG, ord%COMM, STATUSCLIQUES, IERR) END DO END DO ELSE CALL MUMPS_REALLOC(MYLIST, MYMAXVARS, id%INFO, & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, HIDX IF(IPE(I) .GT. 0) THEN DO J=1, LENG(I) MYLIST(J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) END DO CALL MPI_SEND(LENG(I), 1, MPI_INTEGER, 0, ITAG, & ord%COMM, IERR) CALL MPI_SEND(MYLIST(1), LENG(I), MPI_INTEGER, 0, ITAG, & ord%COMM, IERR) END IF END DO END IF CALL MUMPS_DEALLOC(PE, MEMCNT=MEMCNT) IF (id%KEEP(339).NE.0) THEN MAPTAB => WORK(1:N) CALL MUMPS_BUILD_TOP_GRAPH (LUMAT, id, ord, top_graph, MAPTAB) ENDIF IF (MYID.EQ.0) THEN LPERM => WORK( 3_8*int(N,8)+1_8 : 4_8*int(N,8) ) NTVAR = ord%TOPNODES(2) CALL DMUMPS_MAKE_LOC_IDX(id, ord%TOPNODES, LPERM, LIPERM, ord) CALL DMUMPS_ASSEMBLE_TOP_GRAPH(id, ord%TOPNODES(2), LPERM, & top_graph, TOTNCLIQUES, LSTVAR, LVARPT, IPET, PE, & LENG, ELEN) TGSIZE = ord%TOPNODES(2)+TOTNCLIQUES PFREET = IPET(TGSIZE+1) PFT_SAVE = PFREET nullify(LPERM) ENDIF CALL MUMPS_IDEALLOC(top_graph%IRN_LOC, & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN CALL MUMPS_IREALLOC8(PE, max(PFREET+int(TGSIZE,8),1_8),id%INFO, & LP, COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, & ERRCODE=-7) CALL MUMPS_REALLOC(NDENSE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NVT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, max(TGSIZE,1), id%INFO, LP, & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, max(TGSIZE,1), id%INFO, LP, & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(TOTNCLIQUES,1), id%INFO, & LP, STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TOTNCLIQUES LISTVAR_SCHUR(I) = NTVAR+I END DO THRESH = -1 CALL MUMPS_REALLOC(HEAD, max(TGSIZE,1), id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(PERM, max(TGSIZE,1), id%INFO, & LP, COPY=.TRUE., STRING='J2:PERM', & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TGSIZE PERM(I) = I END DO PELEN = max(PFREET+int(TGSIZE,8),1_8) IF(TGSIZE.GT.0) THEN NVT(1) = -1 TOTEL = TGSIZE IF ((N.LT.NORIG).OR.(id%KEEP(339).NE.0)) THEN TOTEL = TOTNCLIQUES DO I=1,NTVAR NVT(I) = SIZEOFBLOCKS( LIPERM(I) ) TOTEL = TOTEL + NVT(I) ENDDO ENDIF CALL MUMPS_SYMQAMD_NEW(2, -1, NDENSE(1), & TGSIZE, TOTEL, PELEN, IPET(1), PFREET, LENG(1), PE(1), & NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), & NEXT(1), W(1), PERM(1), LISTVAR_SCHUR(1), TOTNCLIQUES, & AGG6) ENDIF CALL MUMPS_DEALLOC(PE, MEMCNT=MEMCNT) END IF CALL MPI_BARRIER(ord%COMM, IERR) CALL MPI_BARRIER(ord%COMM, IERR) CALL MUMPS_DEALLOC(LISTVAR_SCHUR, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN MAXS = NROWS_LOC DO I=2, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) & MAXS = (ord%LAST(I)-ord%FIRST(I)+1) END DO CALL MUMPS_I8REALLOC(BUF_PE1, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(BUF_PE2, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV1, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV2, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GPE, N, id%INFO, & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GNV, N, id%INFO, & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ROOTPERM, TOTNCLIQUES, id%INFO, & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RIDX = 0 TMP1 => BUF_PE1 TMP2 => BUF_NV1 NULLIFY(BUF_PE1, BUF_NV1) BUF_PE1 => IPE BUF_NV1 => NV DO PROC=0, NPROCS-2 CALL MPI_IRECV(BUF_PE2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER8, PROC+1, PROC+1, & ord%COMM, RHANDPE, IERR) CALL MPI_IRECV(BUF_NV2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER, PROC+1, PROC+1, & ord%COMM, RHANDNV, IERR) DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO CALL MPI_WAIT(RHANDPE, STATUSPE, IERR) CALL MPI_WAIT(RHANDNV, STATUSNV, IERR) IF(PROC .NE. 0) THEN TMP1 => BUF_PE1 TMP2 => BUF_NV1 END IF BUF_PE1 => BUF_PE2 BUF_NV1 => BUF_NV2 NULLIFY(BUF_PE2, BUF_NV2) BUF_PE2 => TMP1 BUF_NV2 => TMP2 NULLIFY(TMP1, TMP2) END DO DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO DO I=1, NTVAR GLOB_IDX = LIPERM(I) IF(IPET(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = NVT(I) ELSE GPE(GLOB_IDX) = -LIPERM(-IPET(I)) GNV(GLOB_IDX) = NVT(I) END IF END DO DO I=1, TOTNCLIQUES GLOB_IDX = ROOTPERM(I) GPE(GLOB_IDX) = -LIPERM(-IPET(NTVAR+I)) END DO ELSE CALL MPI_SEND(IPE(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER8, 0, MYID, ord%COMM, IERR) CALL MPI_SEND(NV(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER, 0, MYID, ord%COMM, IERR) END IF CALL MUMPS_DEALLOC(BUF_NV1, BUF_NV2, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(BUF_PE1, BUF_PE2, IPE, IPET, & TMP1, LVARPT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, I_HALO_MAP, NDENSE, & LAST, DEGREE, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(W, LISTVAR_SCHUR, NEXT, & NV, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LSTVAR, NCLIQUES, MYLIST, & MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LPERM, LIPERM, NVT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ROOTPERM, TMP2, MEMCNT=MEMCNT) NULLIFY(HEAD, ELEN, LENG, PERM, BWORK, MAPTAB, LPERM) RETURN END SUBROUTINE DMUMPS_PARSYMFACT_LUMAT SUBROUTINE DMUMPS_MAKE_LOC_IDX(id, TOPNODES, LPERM, LIPERM, ord) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id INTEGER, POINTER :: TOPNODES(:), LPERM(:), LIPERM(:) TYPE(ORD_TYPE) :: ord INTEGER :: I, J, K, GIDX CALL MUMPS_REALLOC(LPERM , ord%N, id%INFO, & LP, STRING='LIDX:LPERM', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LIPERM, TOPNODES(2), id%INFO, & LP, STRING='LIDX:LIPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LPERM = 0 K = 1 DO I=TOPNODES(1), 1, -1 DO J=TOPNODES(2*I+1), TOPNODES(2*I+2) GIDX = ord%PERITAB(J) LPERM(GIDX) = K LIPERM(K) = GIDX K = K+1 END DO END DO RETURN END SUBROUTINE DMUMPS_MAKE_LOC_IDX SUBROUTINE DMUMPS_ASSEMBLE_TOP_GRAPH(id, NLOCVARS, LPERM, & top_graph, NCLIQUES, LSTVAR, LVARPT, IPE, PE, LENG, ELEN) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(GRAPH_TYPE) :: top_graph INTEGER, POINTER :: LPERM(:), LSTVAR(:), & PE(:), LENG(:), ELEN(:) INTEGER(8) :: LVARPT(:) INTEGER :: NCLIQUES INTEGER(8), POINTER :: IPE(:) INTEGER :: I, IDX, NLOCVARS INTEGER(8) :: INNZ, PNT, SAVEPNT CALL MUMPS_REALLOC(LENG, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:LENG', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ELEN, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:ELEN', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(IPE , NLOCVARS+NCLIQUES+1, id%INFO, & LP, STRING='ATG:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG = 0 ELEN = 0 DO INNZ=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(INNZ)) .NE. 0) .AND. & (top_graph%JCN_LOC(INNZ) .NE. top_graph%IRN_LOC(INNZ))) & THEN LENG(LPERM(top_graph%IRN_LOC(INNZ))) = & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1 END IF END DO DO I=1, NCLIQUES DO INNZ=LVARPT(I), LVARPT(I+1)-1 ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 END DO END DO IPE(1) = 1 DO I=1, NLOCVARS+NCLIQUES IPE(I+1) = IPE(I)+int(LENG(I),8)+int(ELEN(I),8) END DO CALL MUMPS_IREALLOC8(PE, IPE(NLOCVARS+NCLIQUES+1)+ & int(NLOCVARS,8)+int(NCLIQUES,8), & id%INFO, LP, STRING='ATG:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG = 0 ELEN = 0 DO I=1, NCLIQUES DO INNZ=LVARPT(I), LVARPT(I+1)-1 IDX = LPERM(LSTVAR(INNZ)) PE(IPE(IDX)+int(ELEN(IDX),8)) = NLOCVARS+I PE(IPE(NLOCVARS+I)+int(LENG(NLOCVARS+I),8)) = IDX ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 end do end do DO INNZ=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(INNZ)) .NE. 0) .AND. & (top_graph%JCN_LOC(INNZ) .NE. top_graph%IRN_LOC(INNZ))) & THEN PE(IPE(LPERM(top_graph%IRN_LOC(INNZ)))+ & ELEN(LPERM(top_graph%IRN_LOC(INNZ))) + & LENG(LPERM(top_graph%IRN_LOC(INNZ)))) = & LPERM(top_graph%JCN_LOC(INNZ)) LENG(LPERM(top_graph%IRN_LOC(INNZ))) = & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1 END IF END DO DO I=1, NLOCVARS+NCLIQUES LENG(I) = LENG(I)+ELEN(I) END DO SAVEPNT = 1 PNT = 0 LPERM(1:NLOCVARS+NCLIQUES) = 0 DO I=1, NLOCVARS+NCLIQUES DO INNZ=IPE(I), IPE(I+1)-1 IF(LPERM(PE(INNZ)) .EQ. I) THEN LENG(I) = LENG(I)-1 ELSE LPERM(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NLOCVARS+NCLIQUES+1) = SAVEPNT RETURN END SUBROUTINE DMUMPS_ASSEMBLE_TOP_GRAPH #if defined(parmetis) || defined(parmetis3) SUBROUTINE DMUMPS_BUILD_TREETAB(TREETAB, RANGTAB, SIZES, CBLKNBR) INTEGER, POINTER :: TREETAB(:), RANGTAB(:), SIZES(:) INTEGER :: CBLKNBR,allocok INTEGER :: LCHILD, RCHILD, K, I INTEGER, POINTER :: PERM(:) ALLOCATE(PERM(CBLKNBR),stat=allocok) if(allocok.GT.0) then write(*,*) "Allocation error of PERM in DMUMPS_BUILD_TREETAB" return endif TREETAB(CBLKNBR) = -1 IF(CBLKNBR .EQ. 1) THEN DEALLOCATE(PERM) TREETAB(1) = -1 RANGTAB(1) = 1 RANGTAB(2)= SIZES(1)+1 RETURN END IF LCHILD = CBLKNBR - (CBLKNBR+1)/2 RCHILD = CBLKNBR-1 K = 1 PERM(CBLKNBR) = CBLKNBR PERM(LCHILD) = CBLKNBR+1 - (2*K+1) PERM(RCHILD) = CBLKNBR+1 - (2*K) TREETAB(RCHILD) = CBLKNBR TREETAB(LCHILD) = CBLKNBR IF(CBLKNBR .GT. 3) THEN CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, & LCHILD, CBLKNBR, 2*K+1) CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, & RCHILD, CBLKNBR, 2*K) END IF RANGTAB(1)=1 DO I=1, CBLKNBR RANGTAB(I+1) = RANGTAB(I)+SIZES(PERM(I)) END DO DEALLOCATE(PERM) RETURN CONTAINS RECURSIVE SUBROUTINE REC_TREETAB(TREETAB, PERM, SUBNODES, & ROOTN, CBLKNBR, K) INTEGER, POINTER :: TREETAB(:), PERM(:) INTEGER :: SUBNODES, ROOTN, K, CBLKNBR INTEGER :: LCHILD, RCHILD LCHILD = ROOTN - (SUBNODES+1)/2 RCHILD = ROOTN-1 PERM(LCHILD) = CBLKNBR+1 - (2*K+1) PERM(RCHILD) = CBLKNBR+1 - (2*K) TREETAB(RCHILD) = ROOTN TREETAB(LCHILD) = ROOTN IF(SUBNODES .GT. 3) THEN CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, LCHILD, & CBLKNBR, 2*K+1) CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, RCHILD, & CBLKNBR, 2*K) END IF END SUBROUTINE REC_TREETAB END SUBROUTINE DMUMPS_BUILD_TREETAB #endif #if defined(ptscotch) || defined(parmetis) || defined(parmetis3) SUBROUTINE DMUMPS_BUILD_DIST_GRAPH(id, ord, FIRST, LAST, IPE, & PE, WORK, LWORK) #if defined(DETERMINISTIC_PARALLEL_GRAPH) USE MUMPS_TOOLS_COMMON_M, ONLY : MUMPS_MERGESORT, & MUMPS_MERGESWAP1 #endif IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: FIRST(:), LAST(:), PE(:), & WORK(:) INTEGER(8), INTENT(IN) :: LWORK INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, OFFDIAG, & RCVPNT, PNT, SAVEPNT, DUPS, TOTDUPS INTEGER :: NROWS_LOC INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, POINTER :: MAPTAB(:) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: RDISPL(:), BUFLEVEL(:), & SIPES(:,:), LENG(:) INTEGER, POINTER :: TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER, PARAMETER :: ITAG=30 LOGICAL :: FLAG DOUBLE PRECISION :: SYMMETRY INTEGER(KIND=8) :: TLEN #if defined(DETERMINISTIC_PARALLEL_GRAPH) INTEGER :: L #endif nullify(MAPTAB, SNDCNT, RCVCNT) nullify(RDISPL, MSGCNT, SIPES, LENG, BUFLEVEL) nullify(TSENDI, TSENDJ, RCVBUF, APNT) MYID = ord%MYID NPROCS = ord%NPROCS IF(LWORK .LT. int(N,8)*2_8) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_SCOTCH_GRAPH")') CALL MUMPS_ABORT() END IF CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 BUFSIZE = 1000 BUFSIZE = id%KEEP(39) LOCNNZ = id%KEEP8(29) NROWS_LOC = LAST(MYID+1)-FIRST(MYID+1)+1 MAPTAB => WORK( 1 : N ) LENG => WORK( int(N+1,8) : 2_8*int(N,8) ) MAXS = 0 DO I=1, NPROCS IF((LAST(I)-FIRST(I)+1) .GT. MAXS) THEN MAXS = LAST(I)-FIRST(I)+1 END IF DO J=FIRST(I), LAST(I) MAPTAB(J) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 OFFDIAG=0 SIPES=0 DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN OFFDIAG = OFFDIAG+1 PROC = MAPTAB(id%IRN_loc(INNZ)) LOC_ROW = id%IRN_loc(INNZ)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 PROC = MAPTAB(id%JCN_loc(INNZ)) LOC_ROW = id%JCN_loc(INNZ)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF END DO CALL MPI_ALLREDUCE (OFFDIAG, id%KEEP8(127), 1, MPI_INTEGER8, & MPI_SUM, ord%COMM, IERR) id%KEEP8(127) = id%KEEP8(127)+3*N id%KEEP8(126) = id%KEEP8(127)-2*N CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, ord%COMM, IERR) CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, ord%COMM, IERR ) DEALLOCATE(SIPES) TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO CALL MUMPS_IREALLOC8(PE, max(IPE(NROWS_LOC+1)-1_8,1_8), id%INFO, & LP, STRING='PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL DMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ+RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO RCVPNT = 1 BUFLEVEL = 0 DO INNZ=1, LOCNNZ IF(mod(INNZ,int(BUFSIZE,8)/10_8) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, ord%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, ord%COMM, STATUS, IERR) CALL DMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%IRN_loc(INNZ)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%JCN_loc(INNZ) BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL DMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF PROC = MAPTAB(id%JCN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%JCN_loc(INNZ)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%IRN_loc(INNZ) BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL DMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF END IF END DO CALL DMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(MAPTAB(PE(INNZ)) .EQ. I) THEN DUPS = DUPS+1 ELSE MAPTAB(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO CALL MPI_REDUCE( DUPS, TOTDUPS, 1, MPI_INTEGER8, MPI_SUM, & 0, ord%COMM, IERR ) IF(MYID .EQ. 0) THEN SYMMETRY = dble(TOTDUPS)/(dble(id%KEEP8(28))-dble(N)) SYMMETRY = min(SYMMETRY,1.0d0) IF(id%KEEP(50) .GE. 1) SYMMETRY = 1.d0 IF(PROKG) WRITE(MPG,'(" Structural symmetry is:",i3,"%")') & ceiling(SYMMETRY*100.d0) id%INFOG(8) = ceiling(SYMMETRY*100.0d0) END IF IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) #if defined(DETERMINISTIC_PARALLEL_GRAPH) DO I=1, LAST(MYID+1)-FIRST(MYID+1)+1 L = int(IPE(I+1)-IPE(I)) CALL MUMPS_MERGESORT(L, & PE(IPE(I):IPE(I+1)-1), & WORK(:)) CALL MUMPS_MERGESWAP1(L, WORK(:), & PE(IPE(I):IPE(I+1)-1)) END DO #endif 90 continue RETURN END SUBROUTINE DMUMPS_BUILD_DIST_GRAPH #endif SUBROUTINE DMUMPS_BUILD_LOC_GRAPH(id, ord, GSIZE, IPE, PE, LENG, & I_HALO_MAP, top_graph, WORK, LWORK) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: PE(:), LENG(:), & I_HALO_MAP(:), WORK(:) INTEGER(8), INTENT(in) :: LWORK INTEGER :: GSIZE INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, TOP_CNT, TIDX, & RCVPNT INTEGER :: IIDX,JJDX INTEGER :: HALO_SIZE, NROWS_LOC, DUPS INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: MAPTAB(:), & HALO_MAP(:), BUFLEVEL(:) INTEGER, POINTER :: RDISPL(:), & SIPES(:,:) INTEGER, POINTER :: TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER(8) :: PNT, SAVEPNT INTEGER, PARAMETER :: ITAG=30 INTEGER(KIND=8) :: TLEN LOGICAL :: FLAG nullify(MAPTAB, SNDCNT, RCVCNT, HALO_MAP) nullify(RDISPL, MSGCNT, SIPES, BUFLEVEL) nullify(TSENDI, TSENDJ, RCVBUF, APNT) MYID = ord%MYID NPROCS = ord%NPROCS IF( LWORK .LT. int(N,8)*2_8 ) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_LOC_GRAPH")') CALL MUMPS_ABORT() END IF MAPTAB => WORK( 1 : N ) HALO_MAP => WORK(int(N+1,8) : 2_8*int(N,8)) CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 TOP_CNT = 0 BUFSIZE = 10000 BUFSIZE = id%KEEP(39) LOCNNZ = id%KEEP8(29) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 MAPTAB = 0 MAXS = 0 DO I=1, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) THEN MAXS = ord%LAST(I)-ord%FIRST(I)+1 END IF DO J=ord%FIRST(I), ord%LAST(I) MAPTAB(ord%PERITAB(J)) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SIPES(:,:) = 0 TOP_CNT = 0 DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%IRN_loc(INNZ)) LOC_ROW = IIDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF PROC = MAPTAB(id%JCN_loc(INNZ)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%JCN_loc(INNZ)) LOC_ROW = IIDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF END IF END DO CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, ord%COMM, IERR) I = ceiling(dble(MAXS)*1.20D0) CALL MUMPS_REALLOC(LENG, max(I,1), id%INFO, & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, ord%COMM, IERR ) DEALLOCATE(SIPES) I = ceiling(dble(NROWS_LOC+1)*1.20D0) CALL MUMPS_I8REALLOC(IPE, max(I,1), id%INFO, & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO CALL MUMPS_IREALLOC8(TSENDI, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(TSENDJ, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL DMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ + RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO CALL MUMPS_IREALLOC8(PE, max(NEW_LOCNNZ+ & 2_8*int(NROWS_LOC+ord%TOPNODES(2),8),1_8), & id%INFO, LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RCVPNT = 1 BUFLEVEL = 0 TIDX = 0 DO INNZ=1, LOCNNZ IF(mod(INNZ,int(BUFSIZE/10,8)) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, ord%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, ord%COMM, STATUS, IERR) CALL DMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) IF((MAPTAB(id%JCN_loc(INNZ)).NE.PROC) .AND. & (MAPTAB(id%JCN_loc(INNZ)).NE.0) .AND. & (PROC.NE.0)) THEN IERR = -50 id%INFO(1) = IERR END IF IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%IRN_loc(INNZ) TSENDJ(TIDX) = id%JCN_loc(INNZ) ELSE IIDX = ord%PERMTAB(id%IRN_loc(INNZ)) JJDX = ord%PERMTAB(id%JCN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1)=IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%JCN_loc(INNZ) END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL DMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF END IF PROC = MAPTAB(id%JCN_loc(INNZ)) IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%JCN_loc(INNZ) TSENDJ(TIDX) = id%IRN_loc(INNZ) ELSE IIDX = ord%PERMTAB(id%JCN_loc(INNZ)) JJDX = ord%PERMTAB(id%IRN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = & IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%IRN_loc(INNZ) END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL DMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF END IF END IF END DO CALL DMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB(:) = 0 HALO_MAP(:) = 0 HALO_SIZE = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(PE(INNZ) .LT. 0) THEN IF(HALO_MAP(-PE(INNZ)) .EQ. 0) THEN HALO_SIZE = HALO_SIZE+1 HALO_MAP(-PE(INNZ)) = NROWS_LOC+HALO_SIZE END IF PE(INNZ) = HALO_MAP(-PE(INNZ)) END IF IF(MAPTAB(PE(INNZ)) .EQ. I) THEN DUPS = DUPS+1 LENG(I) = LENG(I)-1 ELSE MAPTAB(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_REALLOC(I_HALO_MAP, HALO_SIZE, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT J=0 DO I=1, N IF(HALO_MAP(I) .GT. 0) THEN J = J+1 I_HALO_MAP(HALO_MAP(I)-NROWS_LOC) = I END IF IF(J .EQ. HALO_SIZE) EXIT END DO CALL MUMPS_REALLOC(LENG, max(NROWS_LOC+HALO_SIZE,1), id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:leng', MEMCNT=MEMCNT, ERRCODE=-7) LENG(NROWS_LOC+1:NROWS_LOC+HALO_SIZE) = 0 CALL MUMPS_I8REALLOC(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IPE(NROWS_LOC+2:NROWS_LOC+HALO_SIZE+1) = IPE(NROWS_LOC+1) GSIZE = NROWS_LOC + HALO_SIZE CALL MPI_GATHER(TOP_CNT, 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, 0, ord%COMM, IERR) IF(MYID.EQ.0) THEN NEW_LOCNNZ = sum(RCVCNT) top_graph%NZ_LOC = NEW_LOCNNZ CALL MUMPS_IREALLOC8(top_graph%IRN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(top_graph%JCN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1), & stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 END IF IF(MYID.EQ.0) THEN top_graph%IRN_LOC(1:TOP_CNT) = TSENDI(1:TOP_CNT) top_graph%JCN_LOC(1:TOP_CNT) = TSENDJ(1:TOP_CNT) DO PROC=2, NPROCS DO WHILE (RCVCNT(PROC) .GT. 0) I = int(min(int(BUFSIZE,8), RCVCNT(PROC))) CALL MPI_RECV(top_graph%IRN_LOC(TOP_CNT+1), I, & MPI_INTEGER, PROC-1, ITAG, ord%COMM, STATUS, IERR) CALL MPI_RECV(top_graph%JCN_LOC(TOP_CNT+1), I, & MPI_INTEGER, PROC-1, ITAG, ord%COMM, STATUS, IERR) RCVCNT(PROC) = RCVCNT(PROC)-I TOP_CNT = TOP_CNT+I END DO END DO ELSE DO WHILE (TOP_CNT .GT. 0) I = int(MIN(int(BUFSIZE,8), TOP_CNT)) CALL MPI_SEND(TSENDI(TOP_CNT-I+1), I, & MPI_INTEGER, 0, ITAG, ord%COMM, IERR) CALL MPI_SEND(TSENDJ(TOP_CNT-I+1), I, & MPI_INTEGER, 0, ITAG, ord%COMM, IERR) TOP_CNT = TOP_CNT-I END DO END IF CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, TSENDI, & TSENDJ, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) 90 continue RETURN END SUBROUTINE DMUMPS_BUILD_LOC_GRAPH SUBROUTINE DMUMPS_LUMAT_TO_LOC_GRAPH & (LUMAT, id, ord, GSIZE, IPE, PE, LENG, & I_HALO_MAP, WORK, LWORK) IMPLICIT NONE TYPE(LMATRIX_T), INTENT(IN) :: LUMAT TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: PE(:), LENG(:), & I_HALO_MAP(:), WORK(:) INTEGER(8), INTENT(IN) :: LWORK INTEGER :: GSIZE INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER :: ROWSIZE, IORIG, JORIG, PROCJ INTEGER(8) :: INNZ, NEW_LOCNNZ, RCVPNT INTEGER :: IIDX,JJDX INTEGER :: HALO_SIZE, NROWS_LOC INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: MAPTAB(:) INTEGER, POINTER :: HALO_MAP(:), BUFLEVEL(:) INTEGER, POINTER :: RDISPL(:), SIPES(:,:) INTEGER, POINTER :: RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER, PARAMETER :: ITAG=30 INTEGER(KIND=8) :: TLEN LOGICAL :: FLAG nullify(MAPTAB, SNDCNT, RCVCNT, HALO_MAP) nullify(RDISPL, MSGCNT, SIPES, BUFLEVEL) nullify( RCVBUF, APNT) MYID = ord%MYID NPROCS = ord%NPROCS IF ( LWORK .LT.2_8 * int(N,8) ) THEN WRITE(LP, & '("Insufficient workspace inside DMUMPS_LUMAT_TO_LOC_GRAPH")') CALL MUMPS_ABORT() END IF MAPTAB => WORK( 1 : N ) HALO_MAP => WORK( int(N+1,8) : 2_8*int(N,8)) CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 BUFSIZE = 10000 BUFSIZE = id%KEEP(39) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 MAPTAB = 0 MAXS = 0 DO I=1, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) THEN MAXS = ord%LAST(I)-ord%FIRST(I)+1 END IF DO J=ord%FIRST(I), ord%LAST(I) MAPTAB(ord%PERITAB(J)) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SIPES = 0 DO J =1, LUMAT%NBCOL_LOC ROWSIZE = LUMAT%COL(J)%NBINCOL JORIG = J + LUMAT%FIRST -1 PROC = MAPTAB(JORIG) IF(PROC .EQ. 0) CYCLE JJDX = ord%PERMTAB(JORIG) LOC_ROW = JJDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+ROWSIZE SNDCNT(PROC) = SNDCNT(PROC)+ROWSIZE ENDDO CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, ord%COMM, IERR) I = ceiling(dble(MAXS)*1.20D0) CALL MUMPS_REALLOC(LENG, max(I,1), id%INFO, & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, ord%COMM, IERR ) DEALLOCATE(SIPES) I = ceiling(dble(NROWS_LOC+1)*1.20D0) CALL MUMPS_I8REALLOC(IPE, max(I,1), id%INFO, & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL DMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ + RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO CALL MUMPS_IREALLOC8(PE, max(NEW_LOCNNZ+ & 2_8*int(NROWS_LOC+ord%TOPNODES(2),8),1_8), & id%INFO, LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RCVPNT = 1 BUFLEVEL = 0 INNZ = 1 DO I=1, LUMAT%NBCOL_LOC IF ( LUMAT%COL(I)%NBINCOL.EQ.0) CYCLE IORIG = I + LUMAT%FIRST -1 PROC = MAPTAB(IORIG) DO J=1, LUMAT%COL(I)%NBINCOL IF(mod(INNZ,int(BUFSIZE/10,8)) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, ord%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, ord%COMM, STATUS, IERR) CALL DMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF INNZ = INNZ +1 JORIG = LUMAT%COL(I)%IRN(J) PROCJ = MAPTAB(JORIG) IF((PROCJ.NE.PROC) .AND. & (PROC.NE.0) .AND. & (PROCJ.NE.0)) THEN IERR = -50 id%INFO(1) = IERR END IF IF (PROC.NE.0) THEN IIDX = ord%PERMTAB(IORIG) JJDX = ord%PERMTAB(JORIG) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1)=IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -JORIG END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL DMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF END IF ENDDO ENDDO CALL DMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) HALO_MAP(:) = 0 HALO_SIZE = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(PE(INNZ) .LT. 0) THEN IF(HALO_MAP(-PE(INNZ)) .EQ. 0) THEN HALO_SIZE = HALO_SIZE+1 HALO_MAP(-PE(INNZ)) = NROWS_LOC+HALO_SIZE END IF PE(INNZ) = HALO_MAP(-PE(INNZ)) END IF END DO END DO CALL MUMPS_REALLOC(I_HALO_MAP, HALO_SIZE, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT J=0 DO I=1, N IF(HALO_MAP(I) .GT. 0) THEN J = J+1 I_HALO_MAP(HALO_MAP(I)-NROWS_LOC) = I END IF IF(J .EQ. HALO_SIZE) EXIT END DO CALL MUMPS_REALLOC(LENG, max(NROWS_LOC+HALO_SIZE,1), id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:leng', MEMCNT=MEMCNT, ERRCODE=-7) LENG(NROWS_LOC+1:NROWS_LOC+HALO_SIZE) = 0 CALL MUMPS_I8REALLOC(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IPE(NROWS_LOC+2:NROWS_LOC+HALO_SIZE+1) = IPE(NROWS_LOC+1) GSIZE = NROWS_LOC + HALO_SIZE CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) 90 continue RETURN END SUBROUTINE DMUMPS_LUMAT_TO_LOC_GRAPH SUBROUTINE MUMPS_BUILD_TOP_GRAPH & (LUMAT, id, ord, top_graph, MAPTAB) IMPLICIT NONE TYPE(LMATRIX_T), INTENT(IN) :: LUMAT TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord TYPE(GRAPH_TYPE) :: top_graph INTEGER, POINTER :: MAPTAB(:) INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, PROCJ INTEGER :: ROWSIZE, IORIG, JORIG INTEGER(8) :: NEW_LOCNNZ, TOP_CNT, TIDX INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER(8), POINTER :: RCVCNT(:) INTEGER, POINTER :: TSENDI(:), TSENDJ(:) INTEGER :: BUFSIZE, allocok INTEGER, PARAMETER :: ITAG=30 nullify(RCVCNT,TSENDI,TSENDJ) MYID = ord%MYID NPROCS = ord%NPROCS MAPTAB = 0 DO I=1, NPROCS DO J=ord%FIRST(I), ord%LAST(I) MAPTAB(ord%PERITAB(J)) = I END DO END DO CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 TOP_CNT = 0 BUFSIZE = 10000 BUFSIZE = id%KEEP(39) TOP_CNT = 0 DO J =1, LUMAT%NBCOL_LOC JORIG = J + LUMAT%FIRST -1 PROC = MAPTAB(JORIG) IF(PROC .EQ. 0) THEN ROWSIZE = LUMAT%COL(J)%NBINCOL TOP_CNT = TOP_CNT+ROWSIZE ENDIF ENDDO CALL MUMPS_IREALLOC8(TSENDI, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(TSENDJ, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT TIDX = 0 DO I=1, LUMAT%NBCOL_LOC IF ( LUMAT%COL(I)%NBINCOL.EQ.0) CYCLE IORIG = I + LUMAT%FIRST -1 PROC = MAPTAB(IORIG) IF (PROC.NE.0) CYCLE DO J=1, LUMAT%COL(I)%NBINCOL JORIG = LUMAT%COL(I)%IRN(J) PROCJ = MAPTAB(JORIG) IF (PROCJ.EQ.0) THEN TIDX = TIDX+1 TSENDI(TIDX) = IORIG TSENDJ(TIDX) = JORIG ENDIF ENDDO ENDDO CALL MPI_GATHER(TIDX, 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, 0, ord%COMM, IERR) IF(MYID.EQ.0) THEN NEW_LOCNNZ = sum(RCVCNT) ELSE NEW_LOCNNZ = 0_8 ENDIF top_graph%NZ_LOC = NEW_LOCNNZ IF(MYID.EQ.0) THEN CALL MUMPS_IREALLOC8(top_graph%IRN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(top_graph%JCN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1), & stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=2 ENDIF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 IF(MYID.EQ.0) THEN top_graph%IRN_LOC(1:TIDX) = TSENDI(1:TIDX) top_graph%JCN_LOC(1:TIDX) = TSENDJ(1:TIDX) DO PROC=2, NPROCS DO WHILE (RCVCNT(PROC) .GT. 0) I = int(min(int(BUFSIZE,8), RCVCNT(PROC))) CALL MPI_RECV(top_graph%IRN_LOC(TIDX+1), I, & MPI_INTEGER, PROC-1, ITAG, ord%COMM, STATUS, IERR) CALL MPI_RECV(top_graph%JCN_LOC(TIDX+1), I, & MPI_INTEGER, PROC-1, ITAG, ord%COMM, STATUS, IERR) RCVCNT(PROC) = RCVCNT(PROC)-I TIDX = TIDX+I END DO END DO ELSE DO WHILE (TIDX .GT. 0) I = int(MIN(int(BUFSIZE,8), TIDX)) CALL MPI_SEND(TSENDI(TIDX-I+1), I, & MPI_INTEGER, 0, ITAG, ord%COMM, IERR) CALL MPI_SEND(TSENDJ(TIDX-I+1), I, & MPI_INTEGER, 0, ITAG, ord%COMM, IERR) TIDX = TIDX-I END DO END IF CALL MUMPS_DEALLOC( TSENDI, TSENDJ, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(RCVCNT, MEMCNT=MEMCNT) 90 continue RETURN END SUBROUTINE MUMPS_BUILD_TOP_GRAPH SUBROUTINE DMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, COMM) IMPLICIT NONE INTEGER :: NPROCS, PROC, COMM, allocok TYPE(ARRPNT) :: APNT(:) INTEGER :: BUFSIZE INTEGER, POINTER :: RCVBUF(:), LENG(:), PE(:) INTEGER :: SNDCNT(:) INTEGER(8) :: MSGCNT(:), IPE(:) LOGICAL, SAVE :: INIT = .TRUE. INTEGER, POINTER, SAVE :: SPACE(:,:,:) LOGICAL, POINTER, SAVE :: PENDING(:) INTEGER, POINTER, SAVE :: REQ(:), CPNT(:) INTEGER :: IERR, MYID, I, SOURCE INTEGER(8) :: TOTMSG LOGICAL :: FLAG, TFLAG INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: TSTATUS(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30, FTAG=31 INTEGER, POINTER :: TMPI(:), RCVCNT(:) CALL MPI_COMM_RANK (COMM, MYID, IERR) CALL MPI_COMM_SIZE (COMM, NPROCS, IERR) IF(INIT) THEN ALLOCATE(SPACE(2*BUFSIZE, 2, NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of SPACE in DMUMPS_SEND_BUF" return ENDIF ALLOCATE(RCVBUF(2*BUFSIZE), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of RCVBUF in DMUMPS_SEND_BUF" return ENDIF ALLOCATE(PENDING(NPROCS), CPNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of PENDING/CPNT" & ," in DMUMPS_SEND_BUF" return ENDIF ALLOCATE(REQ(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of REQ in DMUMPS_SEND_BUF" return ENDIF PENDING = .FALSE. DO I=1, NPROCS APNT(I)%BUF => SPACE(:,1,I) CPNT(I) = 1 END DO INIT = .FALSE. RETURN END IF IF(PROC .EQ. -1) THEN TOTMSG = sum(MSGCNT) DO IF(TOTMSG .EQ. 0) EXIT CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, ITAG, COMM, STATUS, IERR) CALL DMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) SOURCE = STATUS(MPI_SOURCE) TOTMSG = TOTMSG-1 MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 END DO DO I=1, NPROCS IF(PENDING(I)) THEN CALL MPI_WAIT(REQ(I), TSTATUS, IERR) END IF END DO ALLOCATE(RCVCNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of RCVCNT in DMUMPS_SEND_BUF" return ENDIF CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, COMM, IERR) DO I=1, NPROCS IF(SNDCNT(I) .GT. 0) THEN TMPI => APNT(I)%BUF(:) CALL MPI_ISEND(TMPI(1), 2*SNDCNT(I), MPI_INTEGER, I-1, & FTAG, COMM, REQ(I), IERR) END IF END DO DO I=1, NPROCS IF(RCVCNT(I) .GT. 0) THEN CALL MPI_RECV(RCVBUF(1), 2*RCVCNT(I), MPI_INTEGER, I-1, & FTAG, COMM, STATUS, IERR) CALL DMUMPS_ASSEMBLE_MSG(RCVCNT(I), RCVBUF, & IPE, PE, LENG) END IF END DO DO I=1, NPROCS IF(SNDCNT(I) .GT. 0) THEN CALL MPI_WAIT(REQ(I), TSTATUS, IERR) END IF END DO DEALLOCATE(SPACE) DEALLOCATE(PENDING, CPNT) DEALLOCATE(REQ) DEALLOCATE(RCVBUF, RCVCNT) nullify(SPACE, PENDING, CPNT, REQ, RCVBUF, RCVCNT) INIT = .TRUE. RETURN END IF IF(PENDING(PROC)) THEN DO CALL MPI_TEST(REQ(PROC), TFLAG, TSTATUS, IERR) IF(TFLAG) THEN PENDING(PROC) = .FALSE. EXIT ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, & SOURCE, ITAG, COMM, STATUS, IERR) CALL DMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, & PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 END IF END IF END DO END IF TMPI => APNT(PROC)%BUF(:) CALL MPI_ISEND(TMPI(1), 2*BUFSIZE, MPI_INTEGER, PROC-1, & ITAG, COMM, REQ(PROC), IERR) PENDING(PROC) = .TRUE. CPNT(PROC) = mod(CPNT(PROC),2)+1 APNT(PROC)%BUF => SPACE(:,CPNT(PROC),PROC) SNDCNT(PROC) = 0 RETURN END SUBROUTINE DMUMPS_SEND_BUF SUBROUTINE DMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) IMPLICIT NONE INTEGER :: BUFSIZE INTEGER :: RCVBUF(:), PE(:), LENG(:) INTEGER(8) :: IPE(:) INTEGER :: I, ROW, COL DO I=1, 2*BUFSIZE, 2 ROW = RCVBUF(I) COL = RCVBUF(I+1) PE(IPE(ROW)+LENG(ROW)) = COL LENG(ROW) = LENG(ROW) + 1 END DO RETURN END SUBROUTINE DMUMPS_ASSEMBLE_MSG #if defined(ptscotch) || defined(parmetis) || defined(parmetis3) SUBROUTINE DMUMPS_BUILD_TREE(ord) TYPE(ORD_TYPE) :: ord INTEGER :: I ord%SON = -1 ord%BROTHER = -1 ord%NW = 0 DO I=1, ord%CBLKNBR ord%NW(I) = ord%NW(I)+ord%RANGTAB(I+1) - ord%RANGTAB(I) IF (ord%TREETAB(I) .NE. -1) THEN IF (ord%SON(ord%TREETAB(I)) .EQ. -1) THEN ord%SON(ord%TREETAB(I)) = I ELSE ord%BROTHER(I) = ord%SON(ord%TREETAB(I)) ord%SON(ord%TREETAB(I)) = I END IF ord%NW(ord%TREETAB(I)) = ord%NW(ord%TREETAB(I))+ ord%NW(I) END IF END DO RETURN END SUBROUTINE DMUMPS_BUILD_TREE SUBROUTINE DMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK, LWORK, TYPE) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: FIRST(:), LAST(:), BASE, NPROCS, TYPE INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK INTEGER, POINTER :: TMP(:), NZ_ROW(:) INTEGER :: I, IERR, P, F, J INTEGER(8) :: LOCNNZ, INNZ, LOCOFFDIAG, & OFFDIAG, T, SHARE DO I=0, BASE-1 FIRST(I+1) = 0 LAST(I+1) = -1 END DO IF(TYPE.EQ.1) THEN SHARE = int(N/ord%NPROCS_PARAORD,8) DO I=1, ord%NPROCS_PARAORD FIRST(BASE+I) = (I-1)*int(SHARE)+1 LAST (BASE+I) = (I)*int(SHARE) END DO LAST(BASE+ord%NPROCS_PARAORD) = & MAX(LAST(BASE+ord%NPROCS_PARAORD), N) DO I = ord%NPROCS_PARAORD+1, id%NSLAVES+1 FIRST(BASE+I) = N+1 LAST (BASE+I) = N END DO ELSE IF (TYPE.EQ.2) THEN IF (LWORK .LT. 2_8*int(N,8)) THEN WRITE(*,*) "Insufficient workspace in DMUMPS_GRAPH_DIST" CALL MUMPS_ABORT() ENDIF TMP => WORK(1:N) NZ_ROW => WORK(int(N+1,8):2-8*int(N,8)) TMP = 0 LOCOFFDIAG = 0_8 LOCNNZ = id%KEEP8(29) DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN TMP(id%IRN_loc(INNZ)) = TMP(id%IRN_loc(INNZ))+1 LOCOFFDIAG = LOCOFFDIAG+1 IF(id%SYM.GT.0) THEN TMP(id%JCN_loc(INNZ)) = TMP(id%JCN_loc(INNZ))+1 LOCOFFDIAG = LOCOFFDIAG+1 END IF END IF END DO CALL MUMPS_BIGALLREDUCE(.FALSE., TMP(1), NZ_ROW(1), N, & MPI_INTEGER, MPI_SUM, ord%COMM, IERR) CALL MPI_ALLREDUCE(LOCOFFDIAG, OFFDIAG, 1, & MPI_INTEGER8, MPI_SUM, ord%COMM, IERR) nullify(TMP) SHARE = (OFFDIAG-1_8)/int(ord%NPROCS_PARAORD,8) + 1_8 P = 0 T = 0_8 F = 1 DO I=1, N T = T+int(NZ_ROW(I),8) IF ( & (T .GE. SHARE) .OR. & ((N-I).EQ.(ord%NPROCS_PARAORD-P-1)) .OR. & (I.EQ.N) & ) THEN P = P+1 IF(P.EQ.ord%NPROCS_PARAORD) THEN FIRST(BASE+P) = F LAST(BASE+P) = N EXIT ELSE FIRST(BASE+P) = F LAST(BASE+P) = I F = I+1 T = 0_8 END IF END IF END DO DO J=P+1, NPROCS+1-BASE FIRST(BASE+J) = N+1 LAST(BASE+J) = N END DO END IF RETURN END SUBROUTINE DMUMPS_GRAPH_DIST #endif FUNCTION MUMPS_GETSIZE(A) INTEGER, POINTER :: A(:) INTEGER :: MUMPS_GETSIZE IF(associated(A)) THEN MUMPS_GETSIZE = size(A) ELSE MUMPS_GETSIZE = 0_8 END IF RETURN END FUNCTION MUMPS_GETSIZE #if defined(parmetis) || defined(parmetis3) SUBROUTINE MUMPS_PARMETIS_MIXEDto32(id, & BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & VELOLOCTAB, SIZE_VELOLOCTAB, & SIZES, COMM, MYID, IERR) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:) INTEGER :: SIZES(:), ORDER(:) INTEGER(8) :: VERTLOCTAB(:) INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, MYID, & BASE INTEGER :: VELOLOCTAB(:) INTEGER :: SIZE_VELOLOCTAB INTEGER, POINTER :: VERTLOCTAB_I4(:) IF( VERTLOCTAB(VERTLOCNBR+1).GT.huge(VERTLOCNBR)) THEN id%INFO(1) = -51 CALL MUMPS_SET_IERROR( & VERTLOCTAB(VERTLOCNBR+1), id%INFO(2)) RETURN END IF nullify(VERTLOCTAB_I4) CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1), & VERTLOCNBR+1, VERTLOCTAB_I4(1)) IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_PARMETIS_VWGT(FIRST(1+BASE), VERTLOCTAB_I4(1), & EDGELOCTAB(1), BASEVAL, OPTIONS(1), ORDER(1), & SIZES(1), COMM, VELOLOCTAB(1), IERR) ELSE CALL MUMPS_PARMETIS(FIRST(1+BASE), VERTLOCTAB_I4(1), & EDGELOCTAB(1), BASEVAL, OPTIONS(1), ORDER(1), & SIZES(1), COMM, IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT) RETURN END SUBROUTINE MUMPS_PARMETIS_MIXEDto32 SUBROUTINE MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & VELOLOCTAB, SIZE_VELOLOCTAB, & SIZES, COMM, MYID, IERR) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:) INTEGER :: SIZES(:), ORDER(:) INTEGER(8) :: VERTLOCTAB(:) INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, MYID, & BASE INTEGER :: VELOLOCTAB(:) INTEGER :: SIZE_VELOLOCTAB INTEGER(8), POINTER :: FIRST_I8(:), EDGELOCTAB_I8(:), & SIZES_I8(:), ORDER_I8(:), VELOLOCTAB_I8(:) INTEGER(8) :: VERTLOCNBR_I8 #if defined(parmetis) INTEGER(8), POINTER :: OPTIONS_I8(:) INTEGER(8) :: BASEVAL_I8 nullify(OPTIONS_I8) IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8REALLOC(OPTIONS_I8, size(OPTIONS), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64(OPTIONS(1), size(OPTIONS) & , OPTIONS_I8(1)) BASEVAL_I8 = int(BASEVAL,8) END IF #endif nullify(FIRST_I8, EDGELOCTAB_I8, SIZES_I8, ORDER_I8, & VELOLOCTAB_I8) IF (id%KEEP(10).EQ.1) THEN IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_PARMETIS_VWGT_64(FIRST(1+BASE), VERTLOCTAB(1), & EDGELOCTAB(1), & BASEVAL, OPTIONS(1), & ORDER(1), & SIZES(1), COMM, VELOLOCTAB(1), IERR) ELSE CALL MUMPS_PARMETIS_64(FIRST(1+BASE), VERTLOCTAB(1), & EDGELOCTAB(1), & BASEVAL, OPTIONS(1), & ORDER(1), & SIZES(1), COMM, IERR) ENDIF ELSE CALL MUMPS_I8REALLOC(FIRST_I8, size(FIRST), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_I8REALLOC(VELOLOCTAB_I8, VERTLOCNBR, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 ENDIF CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8, & VERTLOCTAB(VERTLOCNBR+1)-1_8, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(SIZES_I8, size(SIZES), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(ORDER_I8, size(ORDER), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 5 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64(FIRST(1), size(FIRST), FIRST_I8(1)) CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1), & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1)) IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN VERTLOCNBR_I8 = int(VERTLOCNBR,8) CALL MUMPS_ICOPY_32TO64_64C(VELOLOCTAB(1), & VERTLOCNBR_I8, VELOLOCTAB_I8(1)) ENDIF IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_PARMETIS_VWGT_64(FIRST_I8(1+BASE), VERTLOCTAB(1), & EDGELOCTAB_I8(1), #if defined(parmetis3) & BASEVAL, OPTIONS(1), #else & BASEVAL_I8, OPTIONS_I8(1), #endif & ORDER_I8(1), & SIZES_I8(1), COMM, VELOLOCTAB_I8(1), & IERR) ELSE CALL MUMPS_PARMETIS_64(FIRST_I8(1+BASE), VERTLOCTAB(1), & EDGELOCTAB_I8(1), #if defined(parmetis3) & BASEVAL, OPTIONS(1), #else & BASEVAL_I8, OPTIONS_I8(1), #endif & ORDER_I8(1), & SIZES_I8(1), COMM, IERR) ENDIF END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF ( id%KEEP(10) .NE. 1 ) THEN CALL MUMPS_ICOPY_64TO32(ORDER_I8(1), & size(ORDER), ORDER(1)) CALL MUMPS_ICOPY_64TO32(SIZES_I8(1), & size(SIZES), SIZES(1)) ENDIF 10 CONTINUE CALL MUMPS_I8DEALLOC(FIRST_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(SIZES_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(ORDER_I8, MEMCNT=MEMCNT) IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) & CALL MUMPS_I8DEALLOC(VELOLOCTAB_I8, MEMCNT=MEMCNT) #if defined(parmetis) CALL MUMPS_I8DEALLOC(OPTIONS_I8, MEMCNT=MEMCNT) #endif RETURN END SUBROUTINE MUMPS_PARMETIS_MIXEDto64 #endif #if defined(ptscotch) SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & VELOLOCTAB, SIZE_VELOLOCTAB, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, LCONTDAT, #endif & IERR) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: BASEVAL, VERTLOCNBR INTEGER(8) :: EDGELOCNBR INTEGER(8) :: VERTLOCTAB(:) INTEGER :: EDGELOCTAB(:) INTEGER :: VELOLOCTAB(:) INTEGER, INTENT(IN) :: SIZE_VELOLOCTAB INTEGER :: IERR INTEGER, POINTER :: VERTLOCTAB_I4(:) INTEGER :: EDGELOCNBR_I4, MYWORKID DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) INTEGER :: LCONTDAT DOUBLE PRECISION :: CONTDAT(LCONTDAT) DOUBLE PRECISION :: GRAPHDAT_BEFORE_CONTEXT(SCOTCH_DGRAPHDIM) #endif IF (.NOT.ord%IDO) RETURN nullify(VERTLOCTAB_I4) CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1), & VERTLOCNBR+1, VERTLOCTAB_I4(1)) EDGELOCNBR_I4 = int(EDGELOCNBR) IF(ord%SUBSTRAT .NE. 0) THEN STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// & 'proc=1,seq=q{strat=m{type=h,vert=100,'// & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' END IF IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, MYWORKID, IERR) ELSE MYWORKID = -1 END IF #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL MUMPS_DGRAPHINIT(GRAPHDAT_BEFORE_CONTEXT, ord%COMM_PARAORD, & IERR) CALL SCOTCHFCONTEXTBINDDGRAPH(CONTDAT, GRAPHDAT_BEFORE_CONTEXT, & GRAPHDAT, IERR) #else CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_PARAORD, IERR) #endif IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB_I4(1), VERTLOCTAB_I4(2), & VELOLOCTAB(1), VERTLOCTAB_I4(1), EDGELOCNBR_I4, & EDGELOCNBR_I4, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ELSE CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB_I4(1), VERTLOCTAB_I4(2), & VERTLOCTAB_I4(1), VERTLOCTAB_I4(1), EDGELOCNBR_I4, & EDGELOCNBR_I4, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(ord%SUBSTRAT .NE. 0) THEN CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR, & ord%RANGTAB(1), ord%TREETAB(1), IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT_BEFORE_CONTEXT) #endif 10 CONTINUE CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT) RETURN END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32 SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & VELOLOCTAB, SIZE_VELOLOCTAB, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, LCONTDAT, #endif & IERR) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: BASEVAL, VERTLOCNBR INTEGER(8) :: EDGELOCNBR INTEGER(8) :: VERTLOCTAB(:) INTEGER :: EDGELOCTAB(:) INTEGER :: VELOLOCTAB(:) INTEGER, INTENT(IN) :: SIZE_VELOLOCTAB INTEGER :: IERR INTEGER :: MYWORKID DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) INTEGER :: LCONTDAT DOUBLE PRECISION :: CONTDAT(LCONTDAT) DOUBLE PRECISION :: GRAPHDAT_BEFORE_CONTEXT(SCOTCH_DGRAPHDIM) #endif INTEGER(8), POINTER :: EDGELOCTAB_I8(:), PERMTAB_I8(:), & PERITAB_I8(:), RANGTAB_I8(:), TREETAB_I8(:), VELOLOCTAB_I8(:) INTEGER(8) :: CBLKNBR_I8, VERTLOCNBR_I8, BASEVAL_I8 IF(ord%SUBSTRAT .NE. 0) THEN STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// & 'proc=1,seq=q{strat=m{type=h,vert=100,'// & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' END IF IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, MYWORKID, IERR) ELSE MYWORKID = -1 END IF nullify(EDGELOCTAB_I8, PERMTAB_I8, PERITAB_I8, & RANGTAB_I8, TREETAB_I8, VELOLOCTAB_I8) IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8, & VERTLOCTAB(VERTLOCNBR+1)-1_8, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_I8REALLOC(VELOLOCTAB_I8, VERTLOCNBR, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 ENDIF IF (MYWORKID .EQ. 0) THEN CALL MUMPS_I8REALLOC(PERMTAB_I8, size(ord%PERMTAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(PERITAB_I8, size(ord%PERITAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(TREETAB_I8, size(ord%TREETAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(RANGTAB_I8, size(ord%RANGTAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) END IF 5 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1), & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1)) VERTLOCNBR_I8 = int(VERTLOCNBR,8) IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_ICOPY_32TO64_64C(VELOLOCTAB(1), & VERTLOCNBR_I8, VELOLOCTAB_I8(1)) ENDIF BASEVAL_I8 = int(BASEVAL,8) ENDIF #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL MUMPS_DGRAPHINIT(GRAPHDAT_BEFORE_CONTEXT, ord%COMM_PARAORD, & IERR) CALL SCOTCHFCONTEXTBINDDGRAPH(CONTDAT, GRAPHDAT_BEFORE_CONTEXT, & GRAPHDAT, IERR) #else CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_PARAORD, IERR) #endif IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL_I8, VERTLOCNBR_I8, & VERTLOCNBR_I8, VERTLOCTAB(1), VERTLOCTAB(2), & VELOLOCTAB_I8(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB_I8(1), EDGELOCTAB_I8(1), & EDGELOCTAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), & VELOLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ENDIF ELSE IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL_I8, VERTLOCNBR_I8, & VERTLOCNBR_I8, VERTLOCTAB(1), VERTLOCTAB(2), & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB_I8(1), EDGELOCTAB_I8(1), & EDGELOCTAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ENDIF ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(ord%SUBSTRAT .NE. 0) THEN CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & PERMTAB_I8(1), PERITAB_I8(1), CBLKNBR_I8, RANGTAB_I8(1), & TREETAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR, & ord%RANGTAB(1),ord%TREETAB(1), IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT_BEFORE_CONTEXT) #endif 10 CONTINUE IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT) IF (SIZE_VELOLOCTAB.GT.0) & CALL MUMPS_I8DEALLOC(VELOLOCTAB_I8, MEMCNT=MEMCNT) IF(MYWORKID .EQ. 0) THEN CALL MUMPS_ICOPY_64TO32(PERMTAB_I8(1), & size(ord%PERMTAB), ord%PERMTAB(1)) CALL MUMPS_ICOPY_64TO32(PERITAB_I8(1), & size(ord%PERITAB), ord%PERITAB(1)) CALL MUMPS_ICOPY_64TO32(TREETAB_I8(1), & size(ord%TREETAB), ord%TREETAB(1)) CALL MUMPS_ICOPY_64TO32(RANGTAB_I8(1), & size(ord%RANGTAB), ord%RANGTAB(1)) ord%CBLKNBR = int(CBLKNBR_I8) CALL MUMPS_I8DEALLOC(PERMTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(PERITAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(RANGTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(TREETAB_I8, MEMCNT=MEMCNT) END IF ENDIF RETURN END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64 #endif END MODULE MUMPS_5.8.1/src/csol_root_parallel.F0000664000175000017500000000745615042446440017232 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ROOT_SOLVE( NRHS, DESCA_PAR, & CNTXT_PAR,LOCAL_M,LOCAL_N,MBLOCK,NBLOCK, & IPIV,LPIV,MASTER_ROOT,MYID,COMM, & RHS_SEQ,SIZE_ROOT,A,INFO,MTYPE,LDLT ) IMPLICIT NONE INTEGER NRHS, MTYPE INTEGER DESCA_PAR( 9 ) INTEGER LOCAL_M, LOCAL_N, MBLOCK, NBLOCK INTEGER CNTXT_PAR, MASTER_ROOT, SIZE_ROOT INTEGER MYID, COMM INTEGER LPIV, IPIV( LPIV ) INTEGER INFO(80), LDLT COMPLEX RHS_SEQ( SIZE_ROOT *NRHS) COMPLEX A( LOCAL_M, LOCAL_N ) #if ! defined(NOSCALAPACK) INTEGER IERR, NPROW, NPCOL, MYROW, MYCOL INTEGER LOCAL_N_RHS COMPLEX, ALLOCATABLE, DIMENSION( :,: ) ::RHS_PAR INTEGER, EXTERNAL :: MUMPS_NUMROC INTEGER allocok CALL blacs_gridinfo( CNTXT_PAR, NPROW, NPCOL, MYROW, MYCOL ) LOCAL_N_RHS = MUMPS_NUMROC(NRHS, NBLOCK, MYCOL, 0, NPCOL) LOCAL_N_RHS = max(1,LOCAL_N_RHS) ALLOCATE(RHS_PAR(LOCAL_M, LOCAL_N_RHS),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) ' Problem during solve of the root.' WRITE(*,*) ' Reduce number of right hand sides.' CALL MUMPS_ABORT() ENDIF CALL CMUMPS_SCATTER_ROOT( MYID, SIZE_ROOT, NRHS, RHS_SEQ, & LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) CALL CMUMPS_SOLVE_2D_BCYCLIC (SIZE_ROOT, NRHS, MTYPE, & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, & IPIV, LPIV, RHS_PAR, LDLT, & MBLOCK, NBLOCK, CNTXT_PAR, & IERR) CALL CMUMPS_GATHER_ROOT( MYID, SIZE_ROOT, NRHS, & RHS_SEQ, LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) DEALLOCATE(RHS_PAR) #endif RETURN END SUBROUTINE CMUMPS_ROOT_SOLVE #if ! defined(NOSCALAPACK) SUBROUTINE CMUMPS_SOLVE_2D_BCYCLIC (SIZE_ROOT, NRHS, MTYPE, & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, & IPIV, LPIV, RHS_PAR, LDLT, & MBLOCK, NBLOCK, CNTXT_PAR, & IERR) IMPLICIT NONE INTEGER, intent (in) :: SIZE_ROOT, NRHS, LDLT, LOCAL_M, & LOCAL_N, LOCAL_N_RHS, & MBLOCK, NBLOCK, CNTXT_PAR, MTYPE INTEGER, intent (in) :: DESCA_PAR( 9 ) INTEGER, intent (in) :: LPIV, IPIV( LPIV ) COMPLEX, intent (in) :: A( LOCAL_M, LOCAL_N ) COMPLEX, intent (inout) :: RHS_PAR(LOCAL_M, LOCAL_N_RHS) INTEGER, intent (out) :: IERR INTEGER :: DESCB_PAR( 9 ) IERR = 0 CALL DESCINIT( DESCB_PAR, SIZE_ROOT, & NRHS, MBLOCK, NBLOCK, 0, 0, & CNTXT_PAR, LOCAL_M, IERR ) IF (IERR.NE.0) THEN WRITE(*,*) 'After DESCINIT, IERR = ', IERR CALL MUMPS_ABORT() END IF IF ( LDLT .eq. 0 .OR. LDLT .eq. 2 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL pcgetrs('N',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, & RHS_PAR,1,1,DESCB_PAR,IERR) ELSE CALL pcgetrs('T',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, & RHS_PAR, 1, 1, DESCB_PAR,IERR) END IF ELSE CALL pcpotrs( 'L', SIZE_ROOT, NRHS, A, 1, 1, DESCA_PAR, & RHS_PAR, 1, 1, DESCB_PAR, IERR ) END IF IF ( IERR .LT. 0 ) THEN WRITE(*,*) ' Problem during solve of the root' CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE CMUMPS_SOLVE_2D_BCYCLIC #endif MUMPS_5.8.1/src/mumps_metis_int.h0000664000175000017500000000156515042446422016624 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_METIS_INT_H #define MUMPS_METIS_INT_H #include "mumps_common.h" /* includes mumps_compat.h and mumps_c_types.h */ #define MUMPS_METIS_IDXSIZE \ F_SYMBOL(metis_idxsize,METIS_IDXSIZE) void MUMPS_CALL MUMPS_METIS_IDXSIZE(MUMPS_INT *metis_idx_size); #define MUMPS_METIS_OPTION_NUMBERING \ F_SYMBOL(metis_option_numbering,METIS_OPTION_NUMBERING) void MUMPS_CALL MUMPS_METIS_OPTION_NUMBERING(MUMPS_INT *i); #endif MUMPS_5.8.1/src/cmumps_iXamax.F0000664000175000017500000000536115042446440016157 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C INTEGER FUNCTION CMUMPS_IXAMAX(N,X,INCX,GRAIN) !$ USE OMP_LIB IMPLICIT NONE COMPLEX, intent(in) :: X(*) INTEGER, intent(in) :: INCX,N INTEGER, intent(in) :: GRAIN REAL ABSMAX INTEGER :: I INTEGER(8) :: IX !$ INTEGER :: NOMP, CHUNK !$ INTEGER :: IMAX !$ REAL :: XMAX, VALABS !$ REAL, PARAMETER :: RZERO = 0.0E0 !$ NOMP = OMP_GET_MAX_THREADS() CMUMPS_IXAMAX = 0 IF ( N.LT.1 ) RETURN CMUMPS_IXAMAX = 1 IF ( N.EQ.1 .OR. INCX.LE.0 ) RETURN !$ IF (NOMP.GT.1 .AND. N.GE.GRAIN*2) THEN !$ IF ( INCX.EQ.1 ) THEN !$ CHUNK = max(GRAIN,(N+NOMP-1)/NOMP) !$ ABSMAX = RZERO !$OMP PARALLEL PRIVATE(I, VALABS, XMAX, IMAX) !$OMP& FIRSTPRIVATE(N, CHUNK) !$ XMAX = RZERO !$OMP DO SCHEDULE(static, CHUNK) !$ DO I = 1, N !$ VALABS = abs(X(I)) !$ IF ( VALABS .GT. XMAX ) THEN !$ XMAX = VALABS !$ IMAX = I !$ ENDIF !$ ENDDO !$OMP END DO !$ IF (XMAX .GT. RZERO) THEN !$OMP CRITICAL !$ IF (XMAX .GT. ABSMAX) THEN !$ CMUMPS_IXAMAX = IMAX !$ ABSMAX = XMAX !$ ENDIF !$OMP END CRITICAL !$ ENDIF !$OMP END PARALLEL !$ ELSE !$ CHUNK = max(GRAIN,(N+NOMP-1)/NOMP) !$ ABSMAX = RZERO !$OMP PARALLEL PRIVATE(I, VALABS, XMAX, IMAX, IX) !$OMP& FIRSTPRIVATE(N, CHUNK, INCX) !$ XMAX = RZERO !$OMP DO SCHEDULE(static, CHUNK) !$ DO I = 1, N !$ IX = 1 + int((I-1),8)*int(INCX,8) !$ VALABS = abs(X(IX)) !$ IF ( VALABS .GT. XMAX ) THEN !$ XMAX = VALABS !$ IMAX = I !$ ENDIF !$ ENDDO !$OMP END DO !$ IF (XMAX .GT. RZERO) THEN !$OMP CRITICAL !$ IF (XMAX .GT. ABSMAX) THEN !$ CMUMPS_IXAMAX = IMAX !$ ABSMAX = XMAX !$ ENDIF !$OMP END CRITICAL !$ ENDIF !$OMP END PARALLEL !$ ENDIF !$ ELSE IF ( INCX.EQ.1 ) THEN ABSMAX = abs(X(1)) DO I = 2, N IF ( abs(X(I)) .LE. ABSMAX ) CYCLE CMUMPS_IXAMAX = I ABSMAX = abs(X(I)) ENDDO ELSE IX = 1 ABSMAX = abs(X(1)) IX = IX + INCX DO I = 2, N IF ( abs(X(IX)).LE.ABSMAX ) GOTO 5 CMUMPS_IXAMAX = I ABSMAX = abs(X(IX)) 5 IX = IX + INCX ENDDO ENDIF !$ ENDIF RETURN END FUNCTION CMUMPS_IXAMAX MUMPS_5.8.1/src/csol_distrhs.F0000664000175000017500000006035415042446440016047 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SCATTER_DIST_RHS( & NSLAVES, N, & MYID_NODES, COMM_NODES, & NRHS_COL, NRHS_loc, LRHS_loc, & MAP_RHS_loc, & IRHS_loc, RHS_loc, RHS_loc_size, & RHSINTR, LD_RHSINTR, & POSINRHSINTR_FWD, NB_FS_IN_RHSINTR, & LSCAL, #if defined(USE_OLD_SCALING) & scaling_data_dr, #else & SCALING_RHSINTR_FWD, LSCALING_RHSINTR_FWD, #endif & LP, LPOK, KEEP, NB_BYTES_LOC, INFO ) USE CMUMPS_STRUC_DEF !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN) :: NSLAVES, N, MYID_NODES INTEGER, INTENT(IN) :: NRHS_loc, LRHS_loc INTEGER, INTENT(IN) :: NRHS_COL INTEGER, INTENT(IN) :: COMM_NODES INTEGER, INTENT(IN) :: MAP_RHS_loc(max(1,NRHS_loc)) INTEGER, INTENT(IN) :: IRHS_loc(NRHS_loc) INTEGER(8), INTENT(IN) :: RHS_loc_size COMPLEX, INTENT(IN) :: RHS_loc(RHS_loc_size) INTEGER, INTENT(IN) :: NB_FS_IN_RHSINTR, LD_RHSINTR INTEGER, INTENT(IN) :: POSINRHSINTR_FWD(N) COMPLEX, INTENT(OUT) :: RHSINTR(LD_RHSINTR, NRHS_COL) INTEGER :: KEEP(500) LOGICAL, INTENT(IN) :: LSCAL #if defined(USE_OLD_SCALING) type scaling_data_t SEQUENCE REAL, dimension(:), pointer :: SCALING REAL, dimension(:), pointer :: SCALING_LOC INTEGER, dimension(:), pointer :: SCALING_IND end type scaling_data_t type(scaling_data_t), INTENT(IN) :: scaling_data_dr #else INTEGER :: LSCALING_RHSINTR_FWD REAL :: SCALING_RHSINTR_FWD( LSCALING_RHSINTR_FWD ) #endif LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: LP INTEGER, INTENT(INOUT) :: INFO(2) INTEGER(8), INTENT(OUT):: NB_BYTES_LOC INCLUDE 'mpif.h' INTEGER :: IERR_MPI LOGICAL :: OMP_FLAG !$ INTEGER :: CHUNK, NOMP !$ INTEGER(8) :: CHUNK8 INTEGER :: allocok INTEGER :: MAXRECORDS INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROWSTOSEND INTEGER, ALLOCATABLE, DIMENSION(:) :: NEXTROWTOSEND COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI COMPLEX, ALLOCATABLE, DIMENSION(:) :: BUFRECR LOGICAL, ALLOCATABLE, DIMENSION(:) :: IS_SEND_ACTIVE, TOUCHED INTEGER, ALLOCATABLE, DIMENSION(:) :: MPI_REQI, MPI_REQR INTEGER, ALLOCATABLE, DIMENSION(:) :: IRHS_loc_sorted INTEGER :: Iloc INTEGER :: Iloc_sorted INTEGER :: IREQ INTEGER :: IMAP, IPROC_MAX INTEGER :: IFS INTEGER :: MAX_ACTIVE_SENDS INTEGER :: NB_ACTIVE_SENDS INTEGER :: NB_FS_TOUCHED INTEGER :: NBROWSTORECV COMPLEX, PARAMETER :: ZERO = (0.0E0, 0.0E0) #if defined(AVOID_MPI_IN_PLACE) INTEGER :: allocoktmp #endif !$ NOMP = OMP_GET_MAX_THREADS() NB_BYTES_LOC = 0_8 ALLOCATE( NBROWSTOSEND (NSLAVES), & NEXTROWTOSEND (NSLAVES), & IRHS_loc_sorted (NRHS_loc), & stat=allocok ) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = NSLAVES+NSLAVES+NRHS_loc ELSE NB_BYTES_LOC = int(2*NSLAVES+NRHS_loc,8)*KEEP(34) ENDIF #if defined(AVOID_MPI_IN_PLACE) allocoktmp=allocok CALL MPI_ALLREDUCE( allocoktmp, allocok, 1, #else CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1, #endif & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI ) IF (allocok .GT. 0) RETURN NBROWSTOSEND(1:NSLAVES) = 0 DO Iloc = 1, NRHS_loc IF (IRHS_loc(Iloc) .GE. 1 .AND. & IRHS_loc(Iloc) .LE. N) THEN IMAP = MAP_RHS_loc(Iloc) NBROWSTOSEND(IMAP+1) = NBROWSTOSEND(IMAP+1)+1 ENDIF ENDDO NEXTROWTOSEND(1)=1 DO IMAP=1, NSLAVES-1 NEXTROWTOSEND(IMAP+1)=NEXTROWTOSEND(IMAP)+NBROWSTOSEND(IMAP) ENDDO NBROWSTOSEND=0 DO Iloc = 1, NRHS_loc IF (IRHS_loc(Iloc) .GE. 1 .AND. & IRHS_loc(Iloc) .LE. N) THEN IMAP = MAP_RHS_loc(Iloc) Iloc_sorted = NEXTROWTOSEND(IMAP+1)+NBROWSTOSEND(IMAP+1) IRHS_loc_sorted(Iloc_sorted) = Iloc NBROWSTOSEND(IMAP+1)=NBROWSTOSEND(IMAP+1)+1 ENDIF ENDDO CALL CMUMPS_DR_BUILD_NBROWSTORECV() MAX_ACTIVE_SENDS = min(10, NSLAVES) IF (KEEP(72) .EQ.1 ) THEN MAXRECORDS = 15 ELSE MAXRECORDS = min(200000,2000000/NRHS_COL) MAXRECORDS = min(MAXRECORDS, & 50000000 / MAX_ACTIVE_SENDS / NRHS_COL) MAXRECORDS = max(MAXRECORDS, 50) ENDIF ALLOCATE(BUFR(MAXRECORDS*NRHS_COL, & MAX_ACTIVE_SENDS), & MPI_REQI(MAX_ACTIVE_SENDS), & MPI_REQR(MAX_ACTIVE_SENDS), & IS_SEND_ACTIVE(MAX_ACTIVE_SENDS), & BUFRECI(MAXRECORDS), & BUFRECR(MAXRECORDS*NRHS_COL), & TOUCHED(NB_FS_IN_RHSINTR), & stat=allocok) IF (allocok .GT. 0) THEN IF (LP .GT. 0) WRITE(LP, '(A)') & 'Error: Allocation problem in CMUMPS_SCATTER_DIST_RHS' INFO(1)=-13 INFO(2)=NRHS_COL*MAXRECORDS*MAX_ACTIVE_SENDS+ & 3*MAX_ACTIVE_SENDS+MAXRECORDS*(1+NRHS_COL) & + NB_FS_IN_RHSINTR ENDIF NB_BYTES_LOC=NB_BYTES_LOC + & KEEP(34) * ( int(2*MAX_ACTIVE_SENDS,8) + int(MAXRECORDS,8) ) + & KEEP(34) * (int(MAX_ACTIVE_SENDS,8) + int(NB_FS_IN_RHSINTR,8)) + & KEEP(35) * ( & int( MAXRECORDS,8)*int(NRHS_COL,8)*int(MAX_ACTIVE_SENDS,8) & + int(MAXRECORDS,8) * int(NRHS_COL,8) ) CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1, & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI ) IF (allocok .NE. 0) RETURN NB_ACTIVE_SENDS = 0 DO IREQ = 1, MAX_ACTIVE_SENDS IS_SEND_ACTIVE(IREQ) = .FALSE. ENDDO NB_FS_TOUCHED = 0 DO IFS = 1, NB_FS_IN_RHSINTR TOUCHED(IFS) = .FALSE. ENDDO IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1 DO WHILE (NBROWSTOSEND(IPROC_MAX+1) .NE. 0) IF (IPROC_MAX .EQ. MYID_NODES) THEN CALL CMUMPS_DR_ASSEMBLE_LOCAL() ELSE CALL CMUMPS_DR_TRY_SEND(IPROC_MAX) ENDIF CALL CMUMPS_DR_TRY_RECV() CALL CMUMPS_DR_TRY_FREE_SEND() IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1 ENDDO DO WHILE ( NBROWSTORECV .NE. 0) CALL CMUMPS_DR_TRY_RECV() CALL CMUMPS_DR_TRY_FREE_SEND() ENDDO DO WHILE (NB_ACTIVE_SENDS .NE. 0) CALL CMUMPS_DR_TRY_FREE_SEND() ENDDO CALL CMUMPS_DR_EMPTY_ROWS() RETURN CONTAINS SUBROUTINE CMUMPS_DR_BUILD_NBROWSTORECV() INTEGER :: IPROC DO IPROC = 0, NSLAVES-1 CALL MPI_REDUCE( NBROWSTOSEND(IPROC+1), NBROWSTORECV, & 1, MPI_INTEGER, & MPI_SUM, IPROC, COMM_NODES, IERR_MPI ) ENDDO END SUBROUTINE CMUMPS_DR_BUILD_NBROWSTORECV SUBROUTINE CMUMPS_DR_TRY_RECV() IMPLICIT NONE INCLUDE 'mumps_tags.h' INTEGER :: MPI_STATUS(MPI_STATUS_SIZE), MSGSOU INTEGER :: NBRECORDS LOGICAL :: FLAG CALL MPI_IPROBE( MPI_ANY_SOURCE, DistRhsI, COMM_NODES, & FLAG, MPI_STATUS, IERR_MPI ) IF (FLAG) THEN MSGSOU = MPI_STATUS( MPI_SOURCE ) CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER, & NBRECORDS, IERR_MPI) CALL MPI_RECV(BUFRECI(1), NBRECORDS, MPI_INTEGER, & MSGSOU, DistRhsI, & COMM_NODES, MPI_STATUS, IERR_MPI) CALL MPI_RECV(BUFRECR(1), NBRECORDS*NRHS_COL, & MPI_COMPLEX, & MSGSOU, DistRhsR, & COMM_NODES, MPI_STATUS, IERR_MPI) CALL CMUMPS_DR_ASSEMBLE_FROM_BUFREC(NBRECORDS, & BUFRECI, BUFRECR) ENDIF RETURN END SUBROUTINE CMUMPS_DR_TRY_RECV SUBROUTINE CMUMPS_DR_ASSEMBLE_FROM_BUFREC & (NBRECORDS, BUFRECI_ARG, BUFRECR_ARG) IMPLICIT NONE INTEGER, INTENT(IN) :: NBRECORDS INTEGER, INTENT(INOUT) :: BUFRECI_ARG(NBRECORDS) COMPLEX, INTENT(IN) :: BUFRECR_ARG(NBRECORDS, & NRHS_COL) INTEGER :: I, K, IRHSINTR, IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IFIRSTNOTTOUCHED = NBRECORDS+1 ILASTNOTTOUCHED = 0 DO I = 1, NBRECORDS IF (BUFRECI(I) .LE. 0) THEN WRITE(*,*) "Internal error 1 in CMUMPS_DR_TRY_RECV", & I, BUFRECI(I), BUFRECI(1) CALL MUMPS_ABORT() ENDIF IRHSINTR=POSINRHSINTR_FWD(BUFRECI(I)) BUFRECI_ARG(I)=IRHSINTR IF ( .NOT. TOUCHED(IRHSINTR) ) THEN IFIRSTNOTTOUCHED=min(IFIRSTNOTTOUCHED,I) ILASTNOTTOUCHED=max(ILASTNOTTOUCHED,I) ENDIF ENDDO OMP_FLAG = .FALSE. !$ OMP_FLAG = ( NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(I,IRHSINTR) DO K = 1, NRHS_COL DO I = IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IRHSINTR=BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSINTR)) THEN RHSINTR(IRHSINTR,K)=ZERO ENDIF ENDDO #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO I = 1, NBRECORDS IRHSINTR=BUFRECI_ARG(I) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & SCALING_RHSINTR_FWD(IRHSINTR) * & BUFRECR_ARG(I,K) ENDDO ELSE #endif DO I = 1, NBRECORDS IRHSINTR=BUFRECI_ARG(I) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & BUFRECR_ARG(I,K) ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif ENDDO !$OMP END PARALLEL DO ELSE DO K = 1, NRHS_COL DO I = IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IRHSINTR=BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSINTR)) THEN RHSINTR(IRHSINTR,K)=ZERO ENDIF ENDDO #if ! defined(USE_OLD_SCALING) IF ( LSCAL ) THEN DO I = 1, NBRECORDS IRHSINTR=BUFRECI_ARG(I) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & SCALING_RHSINTR_FWD(IRHSINTR) * & BUFRECR_ARG(I,K) ENDDO ELSE #endif DO I = 1, NBRECORDS IRHSINTR=BUFRECI_ARG(I) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & BUFRECR_ARG(I,K) ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif ENDDO ENDIF DO I = 1, NBRECORDS IRHSINTR = BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSINTR)) THEN NB_FS_TOUCHED = NB_FS_TOUCHED + 1 TOUCHED(IRHSINTR) = .TRUE. ENDIF ENDDO NBROWSTORECV = NBROWSTORECV - NBRECORDS RETURN END SUBROUTINE CMUMPS_DR_ASSEMBLE_FROM_BUFREC SUBROUTINE CMUMPS_DR_ASSEMBLE_LOCAL() INTEGER :: NBRECORDS, I, K, IFIRSTNOTTOUCHED INTEGER :: Iloc INTEGER :: Iglob INTEGER :: IRHSINTR INTEGER(8) :: ISHIFT IF ( NBROWSTOSEND(MYID_NODES+1) .EQ. 0) THEN WRITE(*,*) "Internal error in CMUMPS_DR_ASSEMBLE_LOCAL" CALL MUMPS_ABORT() ENDIF NBRECORDS=min(MAXRECORDS, NBROWSTOSEND(MYID_NODES+1)) IFIRSTNOTTOUCHED=NBRECORDS+1 DO I = 1, NBRECORDS IRHSINTR = POSINRHSINTR_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSINTR)) THEN IFIRSTNOTTOUCHED=I EXIT ENDIF ENDDO IF (LSCAL) THEN !$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSINTR, Iloc, Iglob) !$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG) DO K = 1, NRHS_COL ISHIFT = int(K-1,8) * int(LRHS_loc,8) DO I = IFIRSTNOTTOUCHED, NBRECORDS IRHSINTR = POSINRHSINTR_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSINTR)) THEN RHSINTR(IRHSINTR,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1) Iglob = IRHS_loc(Iloc) IRHSINTR = POSINRHSINTR_FWD(Iglob) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K)+ & RHS_loc(Iloc+ISHIFT)* #if defined(USE_OLD_SCALING) & scaling_data_dr%SCALING_LOC(Iloc) #else & SCALING_RHSINTR_FWD(IRHSINTR) #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSINTR, Iloc, Iglob) !$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG) DO K = 1, NRHS_COL ISHIFT = int(K-1,8) * int(LRHS_loc,8) DO I = IFIRSTNOTTOUCHED, NBRECORDS IRHSINTR = POSINRHSINTR_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSINTR)) THEN RHSINTR(IRHSINTR,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1) Iglob = IRHS_loc(Iloc) IRHSINTR = POSINRHSINTR_FWD(Iglob) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & RHS_loc(Iloc+ISHIFT) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF DO I = 1, NBRECORDS IRHSINTR = POSINRHSINTR_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSINTR)) THEN NB_FS_TOUCHED = NB_FS_TOUCHED + 1 TOUCHED(IRHSINTR) = .TRUE. ENDIF ENDDO NEXTROWTOSEND(MYID_NODES+1)=NEXTROWTOSEND(MYID_NODES+1)+ & NBRECORDS NBROWSTOSEND(MYID_NODES+1)=NBROWSTOSEND(MYID_NODES+1)- & NBRECORDS NBROWSTORECV = NBROWSTORECV - NBRECORDS RETURN END SUBROUTINE CMUMPS_DR_ASSEMBLE_LOCAL SUBROUTINE CMUMPS_DR_GET_NEW_BUF( IBUF ) INTEGER, INTENT(OUT) :: IBUF INTEGER :: I IBUF = -1 IF (NB_ACTIVE_SENDS .NE. MAX_ACTIVE_SENDS) THEN DO I=1, MAX_ACTIVE_SENDS IF (.NOT. IS_SEND_ACTIVE(I)) THEN IBUF = I EXIT ENDIF ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_DR_GET_NEW_BUF SUBROUTINE CMUMPS_DR_TRY_FREE_SEND() INTEGER :: MPI_STATUS(MPI_STATUS_SIZE) INTEGER :: I LOGICAL :: FLAG IF (NB_ACTIVE_SENDS .GT. 0) THEN DO I=1, MAX_ACTIVE_SENDS IF (IS_SEND_ACTIVE(I)) THEN CALL MPI_TEST( MPI_REQR(I), FLAG, MPI_STATUS, IERR_MPI ) IF (FLAG) THEN CALL MPI_WAIT(MPI_REQI(I), MPI_STATUS, IERR_MPI) NB_ACTIVE_SENDS = NB_ACTIVE_SENDS - 1 IS_SEND_ACTIVE(I)=.FALSE. IF (NB_ACTIVE_SENDS .EQ. 0) THEN RETURN ENDIF ENDIF ENDIF ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_DR_TRY_FREE_SEND SUBROUTINE CMUMPS_DR_TRY_SEND(IPROC_ARG) IMPLICIT NONE INTEGER, INTENT(IN) :: IPROC_ARG INCLUDE 'mumps_tags.h' INTEGER :: NBRECORDS, IBUF, I, K INTEGER(8) :: IPOSRHS INTEGER :: IPOSBUF IF (IPROC_ARG .EQ. MYID_NODES) THEN WRITE(*,*) "Internal error 1 in CMUMPS_DR_TRY_SEND" CALL MUMPS_ABORT() ENDIF IF (NBROWSTOSEND(IPROC_ARG+1) .EQ. 0) THEN WRITE(*,*) "Internal error 2 in CMUMPS_DR_TRY_SEND" CALL MUMPS_ABORT() ENDIF CALL CMUMPS_DR_GET_NEW_BUF(IBUF) IF (IBUF .GT. 0) THEN NBRECORDS = min(MAXRECORDS,NBROWSTOSEND(IPROC_ARG+1)) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS_COL*NBRECORDS !$ IF (CHUNK .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((CHUNK+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF IF (LSCAL) THEN !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) !$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG) DO K=1, NRHS_COL DO I = 1, NBRECORDS IPOSBUF = (K-1)*NBRECORDS IPOSRHS = int(K-1,8)*int(LRHS_loc,8) Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) BUFR( IPOSBUF + I, IBUF ) & = RHS_loc( IPOSRHS + Iloc ) #if defined(USE_OLD_SCALING) & * scaling_data_dr%SCALING_LOC(Iloc) #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) !$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG) DO K=1, NRHS_COL DO I = 1, NBRECORDS IPOSBUF = (K-1)*NBRECORDS IPOSRHS = int(K-1,8)*int(LRHS_loc,8) Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) BUFR( IPOSBUF + I, IBUF ) & = RHS_loc( IPOSRHS + Iloc ) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) & = IRHS_loc(Iloc) ENDDO CALL MPI_ISEND( IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)), & NBRECORDS, MPI_INTEGER, IPROC_ARG, DistRhsI, & COMM_NODES, MPI_REQI(IBUF), IERR_MPI ) CALL MPI_ISEND( BUFR(1,IBUF), NBRECORDS*NRHS_COL, & MPI_COMPLEX, & IPROC_ARG, DistRhsR, & COMM_NODES, MPI_REQR(IBUF), IERR_MPI ) NEXTROWTOSEND(IPROC_ARG+1)=NEXTROWTOSEND(IPROC_ARG+1)+ & NBRECORDS NBROWSTOSEND(IPROC_ARG+1)=NBROWSTOSEND(IPROC_ARG+1)-NBRECORDS NB_ACTIVE_SENDS = NB_ACTIVE_SENDS + 1 IS_SEND_ACTIVE(IBUF)=.TRUE. ENDIF RETURN END SUBROUTINE CMUMPS_DR_TRY_SEND SUBROUTINE CMUMPS_DR_EMPTY_ROWS() INTEGER :: K, IFS IF ( NB_FS_TOUCHED .NE. NB_FS_IN_RHSINTR ) THEN !$ OMP_FLAG = (NRHS_COL .GE. KEEP(362)) .AND. !$ & (NRHS_COL*NB_FS_IN_RHSINTR > KEEP(363)/2) !$OMP PARALLEL DO FIRSTPRIVATE(NB_FS_IN_RHSINTR) !$OMP& PRIVATE(IFS) IF (OMP_FLAG) DO K = 1, NRHS_COL DO IFS = 1, NB_FS_IN_RHSINTR IF ( .NOT. TOUCHED(IFS) ) THEN RHSINTR( IFS, K) = ZERO ENDIF ENDDO DO IFS = NB_FS_IN_RHSINTR +1, LD_RHSINTR RHSINTR (IFS, K) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$ OMP_FLAG = .FALSE. !$ CHUNK8 = int(NRHS_COL,8)*int(LD_RHSINTR-NB_FS_IN_RHSINTR,8) !$ CHUNK8 = max(CHUNK8,1_8) !$ IF (CHUNK8 .GE. int(KEEP(363),8)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK8 = max((CHUNK8+NOMP-1)/NOMP,int(KEEP(363)/2,8)) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK8) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS_COL DO IFS = NB_FS_IN_RHSINTR +1, LD_RHSINTR RHSINTR (IFS, K) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE CMUMPS_DR_EMPTY_ROWS END SUBROUTINE CMUMPS_SCATTER_DIST_RHS SUBROUTINE CMUMPS_SOL_INIT_IRHS_loc(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE (CMUMPS_STRUC) :: id INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ROW_OR_COL_INDICES INTEGER :: IERR_MPI LOGICAL :: I_AM_SLAVE INTEGER, POINTER :: idIRHS_loc(:) INTEGER, POINTER :: UNS_PERM(:) INTEGER :: UNS_PERM_TO_BE_DONE, I, allocok INTEGER, TARGET :: IDUMMY(1) INCLUDE 'mpif.h' NULLIFY(UNS_PERM) IF (id%JOB .NE. 9) THEN WRITE(*,*) "Internal error 1 in CMUMPS_SOL_INIT_IRHS_loc" CALL MUMPS_ABORT() ENDIF I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (id%MYID .EQ. MASTER) THEN IF (id%KEEP(50).NE.0) THEN ROW_OR_COL_INDICES = 0 ELSE IF (id%ICNTL(20).EQ.10 .OR. id%KEEP(50).EQ.0) THEN ROW_OR_COL_INDICES = 0 ELSE IF (id%ICNTL(20).EQ.11) THEN ROW_OR_COL_INDICES = 1 ELSE ROW_OR_COL_INDICES = 0 ENDIF IF (id%ICNTL(9) .NE. 1) THEN ROW_OR_COL_INDICES = 1 - ROW_OR_COL_INDICES ENDIF ENDIF IF (id%KEEP(23).NE.0 .AND. id%ICNTL(9) .NE.1) THEN UNS_PERM_TO_BE_DONE = 1 ELSE UNS_PERM_TO_BE_DONE = 0 ENDIF ENDIF CALL MPI_BCAST(ROW_OR_COL_INDICES,1,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) CALL MPI_BCAST(UNS_PERM_TO_BE_DONE,1,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) IF ( I_AM_SLAVE ) THEN IF (id%KEEP(89) .GT. 0) THEN IF (.NOT. associated(id%IRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=17 ELSE IF (size(id%IRHS_loc) < id%KEEP(89) ) THEN id%INFO(1)=-22 id%INFO(2)=17 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) goto 500 IF (I_AM_SLAVE) THEN IF (associated(id%IRHS_loc)) THEN IF (size(id%IRHS_loc) .GT. 0) THEN idIRHS_loc => id%IRHS_loc ELSE idIRHS_loc => IDUMMY ENDIF ELSE idIRHS_loc => IDUMMY ENDIF CALL MUMPS_GET_INDICES & (id%MYID_NODES, id%NSLAVES, id%N, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), id%IS(1), & max(1, id%KEEP(32)), & id%STEP(1), id%PROCNODE_STEPS(1), idIRHS_loc(1), & ROW_OR_COL_INDICES) ENDIF IF (UNS_PERM_TO_BE_DONE .EQ. 1) THEN IF (id%MYID.NE.MASTER) THEN ALLOCATE(UNS_PERM(id%N),stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=id%N GOTO 100 ENDIF ENDIF 100 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) GOTO 500 IF ( id%MYID .EQ. MASTER ) THEN UNS_PERM => id%UNS_PERM ENDIF CALL MPI_BCAST(UNS_PERM(1),id%N,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) IF (I_AM_SLAVE .AND. id%KEEP(89) .NE.0) THEN DO I=1, id%KEEP(89) id%IRHS_loc(I)=UNS_PERM(id%IRHS_loc(I)) ENDDO ENDIF ENDIF 500 CONTINUE IF (id%MYID.NE.MASTER) THEN IF (associated(UNS_PERM)) DEALLOCATE(UNS_PERM) ENDIF NULLIFY(UNS_PERM) RETURN END SUBROUTINE CMUMPS_SOL_INIT_IRHS_loc MUMPS_5.8.1/src/dana_dist_m.F0000664000175000017500000040631215042446437015615 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ANA_COMPUTE_ESTIMATES ( id, idintr ) USE DMUMPS_STRUC_DEF, ONLY: DMUMPS_STRUC USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_INTR_STRUC USE MUMPS_ANA_OMP_M, ONLY: MUMPS_ANA_L0_OMP IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR, MASTER PARAMETER( MASTER = 0 ) TYPE(DMUMPS_STRUC), TARGET :: id TYPE(DMUMPS_INTR_STRUC) :: idintr INTEGER, DIMENSION(:), POINTER :: KEEP, INFO, INFOG INTEGER :: allocok INTEGER(8), DIMENSION(:), POINTER :: KEEP8 DOUBLE PRECISION, DIMENSION(:), POINTER :: RINFO DOUBLE PRECISION, DIMENSION(:), POINTER :: RINFOG INTEGER, DIMENSION(:), POINTER :: ICNTL INTEGER IRANK INTEGER :: LP, MP, MPG LOGICAL :: PROK, PROKG, LPOK LOGICAL :: I_AM_SLAVE, PERLU_ON, PRINT_MAXAVG LOGICAL :: SUM_OF_PEAKS, PRINT_NODEINFO INTEGER :: TOTAL_MBYTES_UNDER_L0 INTEGER(8) :: TOTAL_BYTES_UNDER_L0 INTEGER :: NBSTATS_I4, NBSTATS_I8 PARAMETER (NBSTATS_I4=4, NBSTATS_I8=24) INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: TNSTK_afterL0 INTEGER, ALLOCATABLE, DIMENSION(:) :: FLAGGED_LEAVES INTEGER(8) :: PEAK_UNDER_L0, PEAK_ABOVE_L0 INTEGER(8) :: SUM_NRLADU, MAX_NRLADU, MIN_NRLADU, & SUM_NRLADU_if_LR_LU, & SUM_NRLADULR_UD, SUM_NRLADULR_WC, & SUM_NRLNEC, SUM_NRLNEC_ACTIVE, & MIN_NRLNEC INTEGER :: SUM_NIRADU, & SUM_NIRADU_OOC, & SUM_NIRNEC, SUM_NIRNEC_OOC INTEGER :: LIPOOL_local INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: IPOOL INTEGER :: I, LIPOOL INTEGER(4) :: I4 INTEGER, POINTER, DIMENSION(:) :: NE_STEPSPTR INTEGER, POINTER, DIMENSION(:) :: IPOOLPTR LOGICAL :: BDUMMY INTEGER(8) :: K8_33relaxed, K8_34relaxed, K8_35relaxed, & K8_50relaxed INTEGER(8) :: ENTRIES_IN_FACTORS_LOC_MASTERS INTEGER :: OOC_STRAT, BLR_STRAT, IDUMMY, ISTEP, NBNODES_BLR INTEGER(8) :: TOTAL_BYTES, ITMP8 INTEGER(8) :: MAX_FRONT_SURFACE_LOCAL_L0, & MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO INTEGER :: MAXFR_UNDER_L0 DOUBLE PRECISION :: COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0 INTEGER(8):: SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB LOGICAL :: ABOVE_L0 INTEGER :: locMYID_NODES LOGICAL, POINTER :: locI_AM_CAND(:) INTEGER LOCAL_M, LOCAL_N INTEGER, EXTERNAL :: MUMPS_NUMROC INTEGER SBUF_SEND_FR, SBUF_REC_FR INTEGER SBUF_SEND_LR, SBUF_REC_LR INTEGER TOTAL_MBYTES INTEGER(8) SUM_KEEP811_THIS_NODE, MAX_SUM_KEEP811_THIS_NODE INTEGER SUM_INFO15_THIS_NODE, MAX_SUM_INFO15_THIS_NODE INTEGER SUM_INFO17_THIS_NODE, MAX_SUM_INFO17_THIS_NODE INTEGER(8) SBUF_RECOLD8, MIN_BUF_SIZE8 LOGICAL UPDATE_BUFFER INTEGER MIN_BUF_SIZE, SIZE_DESC_BANDE, & MaxBlocSize_FR, MaxBlocSize_BLR, & MIN_BUF_SIZE_FR, MIN_BUF_SIZE_BLR INTEGER(8) MAX_SIZE_FACTOR_TMP, KEEP26_I8_TMP KEEP => id%KEEP KEEP8 => id%KEEP8 INFO => id%INFO RINFO => id%RINFO INFOG => id%INFOG RINFOG => id%RINFOG ICNTL => id%ICNTL LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) PRINT_NODEINFO = PRINT_MAXAVG .AND. id%NPROCS .NE. id%KEEP(412) IDUMMY = 1 BDUMMY = .FALSE. IF ( I_AM_SLAVE ) THEN locI_AM_CAND => id%I_AM_CAND locMYID_NODES = id%MYID_NODES IF ( idintr%root%yes ) THEN LOCAL_M = MUMPS_NUMROC( & id%ND_STEPS(id%STEP(KEEP(38))), & idintr%root%MBLOCK, idintr%root%MYROW, 0, & idintr%root%NPROW ) LOCAL_M = max(1, LOCAL_M) LOCAL_N = MUMPS_NUMROC( & id%ND_STEPS(id%STEP(KEEP(38))), & idintr%root%NBLOCK, idintr%root%MYCOL, 0, & idintr%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 idintr%root%SCHUR_MLOC=LOCAL_M idintr%root%SCHUR_NLOC=LOCAL_N ENDIF IF ( .NOT. associated(id%CANDIDATES)) THEN ALLOCATE(id%CANDIDATES(id%NSLAVES+1,1), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF INFO(1)= -7 INFO(2)= id%NSLAVES+1 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF (KEEP(400) .GT. 0 ) THEN IF ( I_AM_SLAVE ) THEN CALL MUMPS_ANA_L0_OMP( & KEEP(400), id%N, KEEP(28), & KEEP(50), id%NSLAVES, id%DAD_STEPS, id%FRERE_STEPS, & id%FILS, id%NE_STEPS, id%ND_STEPS, id%STEP, & id%PROCNODE_STEPS, KEEP, KEEP8, locMYID_NODES, & id%NA, id%LNA, "DMUMPS"(1:1), & id%LPOOL_B_L0_OMP, id%IPOOL_B_L0_OMP, & id%LPOOL_A_L0_OMP, id%IPOOL_A_L0_OMP, & id%L_VIRT_L0_OMP,id%VIRT_L0_OMP, id%VIRT_L0_OMP_MAPPING, & id%L_PHYS_L0_OMP,id%PHYS_L0_OMP, id%PERM_L0_OMP, & id%PTR_LEAFS_L0_OMP, & id%INFO, id%ICNTL) IF (id%INFO(1) .GE. 0) THEN ALLOCATE( & id%I4_L0_OMP(NBSTATS_I4, KEEP(400)), & id%I8_L0_OMP(NBSTATS_I8, KEEP(400)), & TNSTK_afterL0(KEEP(28)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'L0_OMP stats' END IF INFO(1)= -7 INFO(2)= NBSTATS_I4* KEEP(400) + & NBSTATS_I8* KEEP(400)*KEEP(10) & + KEEP(28) ENDIF ENDIF ELSE ALLOCATE(id%I4_L0_OMP(1,1), id%I8_L0_OMP(1,1), stat=allocok) IF (allocok.gt.0) THEN INFO(1)= -7 INFO(2)= 2 ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN CALL DMUMPS_ANA_DISTM_UNDERL0OMP( & id%LPOOL_B_L0_OMP, id%IPOOL_B_L0_OMP(1), & id%L_VIRT_L0_OMP, & id%VIRT_L0_OMP(1), id%VIRT_L0_OMP_MAPPING(1), & id%L_PHYS_L0_OMP, id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1), & id%PTR_LEAFS_L0_OMP(1), & id%KEEP(1), id%N, id%NE_STEPS(1), id%STEP(1), & id%FRERE_STEPS(1), id%FILS(1), id%DAD_STEPS(1), & id%ND_STEPS(1), & locMYID_NODES, id%PROCNODE_STEPS(1), & id%I4_L0_OMP(1,1), NBSTATS_I4, & id%I8_L0_OMP(1,1), NBSTATS_I8, KEEP(400), & SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB, & TNSTK_afterL0, MAXFR_UNDER_L0, & MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0, NBNODES_BLR, & INFO(1), INFO(2) & ) CALL MPI_ALLREDUCE (NBNODES_BLR, KEEP(470), 1, & MPI_INTEGER, MPI_SUM, id%COMM_NODES, IERR) ENDIF ELSE IF ( I_AM_SLAVE ) THEN id%LPOOL_B_L0_OMP = 1 id%LPOOL_A_L0_OMP = 1 id%L_VIRT_L0_OMP = 1 id%L_PHYS_L0_OMP = 1 id%THREAD_LA = -1_8 ALLOCATE ( id%VIRT_L0_OMP ( id%L_VIRT_L0_OMP ), & id%VIRT_L0_OMP_MAPPING ( id%L_VIRT_L0_OMP ), & id%PERM_L0_OMP ( id%L_PHYS_L0_OMP ), & id%PTR_LEAFS_L0_OMP ( id%L_PHYS_L0_OMP + 1 ), & id%IPOOL_B_L0_OMP ( id%LPOOL_B_L0_OMP ), & id%IPOOL_A_L0_OMP ( id%LPOOL_A_L0_OMP ), & id%PHYS_L0_OMP( id%L_PHYS_L0_OMP ), & id%I4_L0_OMP(1,1), id%I8_L0_OMP(1,1), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'Allocation error in multicore' END IF INFO(1)= -7 INFO(2)= id%L_VIRT_L0_OMP & + id%L_PHYS_L0_OMP & + id%L_PHYS_L0_OMP + 1 & + id%LPOOL_B_L0_OMP & + id%LPOOL_A_L0_OMP & + id%L_PHYS_L0_OMP + 1 + KEEP(10) ENDIF ELSE ALLOCATE(id%I4_L0_OMP(1,1), id%I8_L0_OMP(1,1), stat=allocok) IF (allocok.gt.0) THEN INFO(1)= -7 INFO(2)= 2 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN IF (KEEP(400).GT.0) THEN IF (id%NSLAVES .GT.1) THEN ALLOCATE (FLAGGED_LEAVES(KEEP(28)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'L0_OMP FLAGGED LEAVES' END IF INFO(1)= -7 INFO(2)= KEEP(28) ENDIF ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN IF (KEEP(400).GT.0) THEN IF (id%NSLAVES .GT.1) THEN LIPOOL_local= & id%IPOOL_A_L0_OMP(id%LPOOL_A_L0_OMP) CALL DMUMPS_PREP_ANA_DISTM_ABOVEL0( & id%N, id%NSLAVES, id%COMM_NODES, id%MYID_NODES, & id%STEP(1), id%DAD_STEPS(1),id%ICNTL,LP,LPOK, & id%INFO, & id%PHYS_L0_OMP(1), id%L_PHYS_L0_OMP, & id%IPOOL_A_L0_OMP(1), LIPOOL_local, & id%KEEP, TNSTK_afterL0, & FLAGGED_LEAVES & ) IF ( INFO(1).LT.0 ) GOTO 75 LIPOOL= 0 DO ISTEP=1,KEEP(28) IF (FLAGGED_LEAVES(ISTEP).GT.0) LIPOOL=LIPOOL+1 ENDDO ALLOCATE( IPOOL(max(LIPOOL,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'Allocation IPOOL' END IF INFO(1)= -7 INFO(2)= LIPOOL ENDIF ELSE LIPOOL = id%IPOOL_A_L0_OMP(id%LPOOL_A_L0_OMP) ENDIF ELSE LIPOOL = id%NA(1) ENDIF ENDIF 75 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN IF (KEEP(400) .GT. 0 ) THEN IF (id%NSLAVES .GT.1) THEN IF (LIPOOL .GT.0) THEN I =LIPOOL DO ISTEP=1, KEEP(28) IF (FLAGGED_LEAVES(ISTEP).GT.0) THEN IPOOL(I) = FLAGGED_LEAVES(ISTEP) I=I-1 ENDIF IF (I.EQ.0) EXIT ENDDO ENDIF DEALLOCATE(FLAGGED_LEAVES) IPOOLPTR => IPOOL ELSE IPOOLPTR => id%IPOOL_A_L0_OMP ENDIF ABOVE_L0 =.TRUE. NE_STEPSPTR => TNSTK_afterL0(1:KEEP(28)) ELSE IPOOLPTR => id%NA(3:3+max(LIPOOL,1)-1) ABOVE_L0 =.FALSE. SIZECB_UNDER_L0 = 0_8 SIZECB_UNDER_L0_IF_LRCB = 0_8 MAX_FRONT_SURFACE_LOCAL_L0 = 0_8 MAX_SIZE_FACTOR_L0 = 0_8 ENTRIES_IN_FACTORS_UNDER_L0= 0_8 ENTRIES_IN_FACTORS_MASTERS_LO = 0_8 MAXFR_UNDER_L0 = 0 COST_SUBTREES_UNDER_L0 = 0.0D0 OPSA_UNDER_L0 = 0.0D0 NE_STEPSPTR => id%NE_STEPS ENDIF KEEP(139) = MAXFR_UNDER_L0 CALL DMUMPS_ANA_DISTM( locMYID_NODES, id%N, id%STEP(1), & id%FRERE_STEPS(1), id%FILS(1), IPOOLPTR(1), LIPOOL, NE_STEPSPTR & (1), id%DAD_STEPS(1), id%ND_STEPS(1), id%PROCNODE_STEPS(1), & id%NSLAVES, ABOVE_L0,SIZECB_UNDER_L0,SIZECB_UNDER_L0_IF_LRCB, & MAXFR_UNDER_L0, MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0, KEEP8(53), KEEP8(54), & KEEP8(11), KEEP(26), KEEP(15), KEEP8(12), KEEP8(14), & KEEP8(32), KEEP8(33), KEEP8(34), KEEP8(35), KEEP8(50), & KEEP8(36), KEEP8(47), KEEP8(37), KEEP8(38), KEEP8(39), & KEEP8(40), KEEP8(41), KEEP8(42), KEEP8(43), KEEP8(44), KEEP8(45), & KEEP8(46), KEEP8(51), KEEP8(52), KEEP(224),KEEP(225),KEEP(27), & RINFO(1),id%CNTL(1), KEEP(1), KEEP8(1), LOCAL_M, LOCAL_N, & SBUF_RECOLD8, SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR, & SBUF_REC_LR, id%COST_SUBTREES, KEEP(28), locI_AM_CAND(1), & max(KEEP(56),1), id%ISTEP_TO_INIV2(1), id%CANDIDATES(1,1), & INFO(1), INFO(2), KEEP8(15),MAX_SIZE_FACTOR_TMP, & KEEP8(9), ENTRIES_IN_FACTORS_LOC_MASTERS, & idintr%root%yes, idintr%root%NPROW, idintr%root%NPCOL & ) IF (ALLOCATED(IPOOL)) DEALLOCATE(IPOOL) NULLIFY(NE_STEPSPTR,IPOOLPTR) IF (KEEP(400) .GT. 0) THEN DEALLOCATE (TNSTK_afterL0) SUM_NIRNEC = 0 SUM_NIRADU = 0 SUM_NIRADU_OOC = 0 SUM_NIRNEC_OOC = 0 DO I=1, KEEP(400) SUM_NIRADU = SUM_NIRADU + id%I4_L0_OMP(1,I) SUM_NIRNEC = SUM_NIRNEC + id%I4_L0_OMP(2,I) SUM_NIRADU_OOC = SUM_NIRADU_OOC+ id%I4_L0_OMP(3,I) SUM_NIRNEC_OOC = SUM_NIRNEC_OOC+ id%I4_L0_OMP(4,I) ENDDO KEEP(26) = KEEP(26) + SUM_NIRADU KEEP(224) = KEEP(224) + SUM_NIRADU_OOC KEEP(15) = max(KEEP(15),KEEP(26)) KEEP(225) = max(KEEP(225),KEEP(224)) KEEP(137) = SUM_NIRNEC KEEP(138) = SUM_NIRNEC_OOC SUM_NIRNEC = int( & (dble(SUM_NIRNEC)*dble(KEEP(34)))/dble(KEEP(35)) & ) SUM_NIRNEC_OOC = int( & (dble(SUM_NIRNEC_OOC)*dble(KEEP(34)))/dble(KEEP(35)) & ) MAX_NRLADU = 0_8 MIN_NRLADU = id%I8_L0_OMP(1,1) SUM_NRLADU = 0_8 SUM_NRLNEC = 0_8 MIN_NRLNEC = huge(MIN_NRLNEC) SUM_NRLNEC_ACTIVE = 0_8 SUM_NRLADU_if_LR_LU = 0_8 SUM_NRLADULR_UD = 0_8 SUM_NRLADULR_WC = 0_8 DO I=1, KEEP(400) MIN_NRLADU = min(MIN_NRLADU, id%I8_L0_OMP(1,I)) MAX_NRLADU = max(MAX_NRLADU, id%I8_L0_OMP(1,I)) SUM_NRLADU = SUM_NRLADU + id%I8_L0_OMP(1,I) SUM_NRLNEC = SUM_NRLNEC + id%I8_L0_OMP(2,I) MIN_NRLNEC = min(MIN_NRLNEC, id%I8_L0_OMP(2,I)) SUM_NRLNEC_ACTIVE = SUM_NRLNEC_ACTIVE + & id%I8_L0_OMP(3,I) SUM_NRLADU_if_LR_LU = SUM_NRLADU_if_LR_LU + & id%I8_L0_OMP(4,I) SUM_NRLADULR_UD = SUM_NRLADULR_UD + & id%I8_L0_OMP(9,I) SUM_NRLADULR_WC = SUM_NRLADULR_WC + & id%I8_L0_OMP(10,I) ENDDO KEEP8(81) = KEEP8(11) KEEP8(11) = KEEP8(11) + SUM_NRLADU KEEP8(82) = KEEP8(32) KEEP8(32) = KEEP8(32) + SUM_NRLADU_if_LR_LU PEAK_UNDER_L0 = SUM_NRLNEC + MIN_NRLNEC + & int( & (dble(id%N*KEEP(400))*dble(KEEP(34)))/dble(KEEP(35)), & 8) PEAK_ABOVE_L0 = KEEP8(53)+ SUM_NRLADU + & & max( int(SBUF_SEND_FR,8), 100000_8) + & & int( & (dble(KEEP(15))*dble(KEEP(34)))/dble(KEEP(35)), & 8) KEEP8(53) = KEEP8(53)+ SUM_NRLADU KEEP8(40) = KEEP8(40)+ & SUM_NRLADU_if_LR_LU + SUM_NRLADULR_UD KEEP8(41) = KEEP8(41)+ SUM_NRLADULR_UD KEEP8(42) = KEEP8(42)+ SUM_NRLADULR_WC KEEP8(43) = KEEP8(43)+ & SUM_NRLADU_if_LR_LU + SUM_NRLADULR_UD KEEP8(44) = KEEP8(44)+ & SUM_NRLADU_if_LR_LU + SUM_NRLADULR_WC KEEP8(45) = KEEP8(45)+ SUM_NRLADULR_UD KEEP8(46) = KEEP8(46)+ SUM_NRLADULR_WC KEEP8(51) = KEEP8(51)+ SUM_NRLADU KEEP8(52) = KEEP8(52)+ SUM_NRLADULR_UD ELSE KEEP(137)=0 KEEP(138)=0 ENDIF id%DKEEP(15) = RINFO(1)/1000000.0D0 IF(ASSOCIATED(locI_AM_CAND)) NULLIFY(locI_AM_CAND) id%MAX_SURF_MASTER = KEEP8(15) KEEP8(19)=MAX_SIZE_FACTOR_TMP KEEP( 29 ) = KEEP(15) + 3* max(KEEP(12),10) & * ( KEEP(15) / 100 + 1) INFO( 19 ) = KEEP(225) + 3* 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) K8_33relaxed = KEEP8(33) + int(KEEP(12),8) * & ( KEEP8(33) /100_8 +1_8) K8_34relaxed = KEEP8(34) + int(KEEP(12),8) * & ( KEEP8(34) /100_8 +1_8) K8_35relaxed = KEEP8(35) + int(KEEP(12),8) * & ( KEEP8(35) /100_8 +1_8) K8_50relaxed = KEEP8(50) + int(KEEP(12),8) * & ( KEEP8(50) /100_8 +1_8) CALL MUMPS_ALLREDUCEI8 ( SBUF_RECOLD8, KEEP8(22), MPI_MAX, & id%COMM_NODES ) IF ( (id%NSLAVES.GT.1) & ) THEN SBUF_SEND_FR = max(SBUF_SEND_FR,KEEP(27)) SBUF_SEND_LR = max(SBUF_SEND_LR,KEEP(27)) SBUF_REC_FR = max(SBUF_REC_FR ,KEEP(27)) SBUF_REC_LR = max(SBUF_REC_LR ,KEEP(27)) ENDIF CALL MPI_ALLREDUCE (SBUF_REC_FR, KEEP(44), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) CALL MPI_ALLREDUCE (SBUF_REC_LR, KEEP(380), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) IF (KEEP(48)==5) THEN KEEP(43) = KEEP(44) KEEP(379) = KEEP(380) ELSE KEEP(43)=SBUF_SEND_FR KEEP(379)=SBUF_SEND_LR ENDIF UPDATE_BUFFER = .TRUE. MIN_BUF_SIZE8 = KEEP8(22) / int(KEEP(238),8) MIN_BUF_SIZE8 = min(MIN_BUF_SIZE8, & int(huge(I4),8)/int(KEEP(35),8) ) MIN_BUF_SIZE = max(int( MIN_BUF_SIZE8 ), KEEP(127)) SIZE_DESC_BANDE=(11+id%NSLAVES+KEEP(127)*2) MaxBlocSize_FR = min (KEEP(420), KEEP(127)) MaxBlocSize_FR = MaxBlocSize_FR*MaxBlocSize_FR MaxBlocSize_BLR = min (KEEP(142), KEEP(127)) MaxBlocSize_BLR = MaxBlocSize_BLR*MaxBlocSize_BLR MIN_BUF_SIZE_FR = MIN_BUF_SIZE MIN_BUF_SIZE_BLR = MIN_BUF_SIZE MIN_BUF_SIZE_FR = min ( MIN_BUF_SIZE_FR, & int ( min ( & dble(KEEP(44)) * & (dble(abs(KEEP(180))) / dble(100)) , & dble(huge(I4))/dble(KEEP(35)) & ) ) & ) MIN_BUF_SIZE_BLR = min ( MIN_BUF_SIZE_BLR, & int ( min ( & dble(KEEP(44)) * & (dble(abs(KEEP(181))) / dble(100)) , & dble(huge(I4))/dble(KEEP(35)) & ) ) & ) IF (KEEP(50).EQ.0) THEN KEEP(43) = max( & min(KEEP(43),MaxBlocSize_FR*max(KEEP(171),3)), & int(KEEP(43)/KEEP(172)) ) KEEP(44) = max( & min(KEEP(44), MaxBlocSize_FR*max(KEEP(171),3)), & int(KEEP(44)/KEEP(172)) ) ELSE KEEP(43) = max( & min(KEEP(43),MaxBlocSize_FR*max(KEEP(171),3)), & int((KEEP(43)*KEEP(178))/KEEP(172)) ) KEEP(44) = max( & min(KEEP(44), MaxBlocSize_FR*max(KEEP(171),3)), & int((KEEP(44)*KEEP(178))/KEEP(172)) ) ENDIF KEEP(379) = max( & min(KEEP(379), MaxBlocSize_BLR*max(KEEP(171),3)), & int(KEEP(379)/KEEP(172)) ) KEEP(380) = max( & min(KEEP(380),MaxBlocSize_BLR*max(KEEP(171),3)), & int(KEEP(380)/KEEP(172)) ) IF (UPDATE_BUFFER) THEN KEEP(43) = max(KEEP(43),MIN_BUF_SIZE_FR) + & (SIZE_DESC_BANDE * KEEP(34))/KEEP(35) KEEP(379)= max(KEEP(379),MIN_BUF_SIZE_BLR)+ & (SIZE_DESC_BANDE * KEEP(34))/KEEP(35) ENDIF IF ( (KEEP(38).NE.0) .OR. UPDATE_BUFFER) THEN KEEP(44) = max(KEEP(44),MIN_BUF_SIZE_FR) + & (SIZE_DESC_BANDE * KEEP(34))/KEEP(35) KEEP(380)= max(KEEP(380),MIN_BUF_SIZE_BLR)+ & (SIZE_DESC_BANDE * KEEP(34))/KEEP(35) ENDIF IF ( int(KEEP(43),8)*int(KEEP(35),8) .GE. & int(huge(I4)-100,8)) THEN KEEP(43) = huge(KEEP(43))-100 ENDIF IF ( int(KEEP(44),8)*int(KEEP(35),8) .GE. & int(huge(I4)-100,8)) THEN KEEP(44) = huge(KEEP(44))-100 ENDIF IF ( int(KEEP(379),8)*int(KEEP(35),8) .GE. & int(huge(I4)-100,8)) THEN KEEP(379) = huge(KEEP(379))-100 ENDIF IF ( int(KEEP(380),8)*int(KEEP(35),8) .GE. & int(huge(I4)-100,8)) THEN KEEP(380) = huge(KEEP(380))-100 ENDIF IF ( PROK ) THEN WRITE(MP,'(A,I16) ') & ' Estimated INTEGER space for factors :', & KEEP(26) WRITE(MP,'(A,I16) ') & ' INFO(3), est. real space to store factors :', & KEEP8(11) WRITE(MP,'(A,I16) ') & ' Estimated number of entries in factors :', & KEEP8(9) WRITE(MP,'(A,I16) ') & ' Current value of space relaxation parameter :', & KEEP(12) WRITE(MP,'(A,I16) ') & ' Estimated size of IS (In Core factorization):', & KEEP(29) WRITE(MP,'(A,I16) ') & ' Estimated size of S (In Core factorization):', & KEEP8(13) WRITE(MP,'(A,I16) ') & ' Estimated size of S (OOC factorization) :', & KEEP8(17) END IF ELSE ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 KEEP8(13) = 0_8 KEEP(29) = 0 KEEP8(17)= 0_8 INFO(19) = 0 KEEP8(11) = 0_8 KEEP8(81) = 0_8 KEEP8(82) = 0_8 KEEP(26) = 0 KEEP(27) = 0 RINFO(1) = 0.0D0 K8_33relaxed = 0_8 K8_34relaxed = 0_8 K8_35relaxed = 0_8 K8_50relaxed = 0_8 IF (KEEP(400) .GT.0) THEN SUM_NIRNEC = 0 SUM_NIRADU = 0 SUM_NIRADU_OOC = 0 SUM_NIRNEC_OOC = 0 MAX_NRLADU = 0_8 MIN_NRLADU = 0_8 SUM_NRLADU = 0_8 SUM_NRLNEC = 0_8 SUM_NRLNEC_ACTIVE = 0_8 SUM_NRLADU_if_LR_LU = 0_8 SUM_NRLADULR_UD = 0_8 SUM_NRLADULR_WC = 0_8 ENDIF END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 CALL MUMPS_ALLREDUCEI8( ENTRIES_IN_FACTORS_LOC_MASTERS, & KEEP8(109), MPI_SUM, id%COMM) CALL MUMPS_ALLREDUCEI8( KEEP8(19), KEEP8(119), & MPI_MAX, id%COMM) CALL MPI_ALLREDUCE( KEEP(27), KEEP(127), 1, & MPI_INTEGER, MPI_MAX, & id%COMM, IERR) KEEP26_I8_TMP = int(KEEP(26),8) CALL MUMPS_ALLREDUCEI8( KEEP26_I8_TMP, & KEEP8(129), MPI_SUM, id%COMM) CALL MUMPS_REDUCEI8( KEEP8(11), & KEEP8(111), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4( KEEP8(111), INFOG(3) ) RINFO(5) = dble(KEEP8(32) & *int(KEEP(35),8))/1D6 CALL MUMPS_REDUCEI8( KEEP8(32), & ITMP8, MPI_SUM, & MASTER, id%COMM ) IF (id%MYID.EQ.MASTER) THEN RINFOG(15) = dble(ITMP8*int(KEEP(35),8))/1D6 ENDIF CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1, & MPI_DOUBLE_PRECISION, MPI_SUM, & id%COMM, IERR) CALL MUMPS_SETI8TOI4( KEEP8(11), INFO(3) ) INFO ( 4 ) = KEEP( 26 ) INFO ( 5 ) = KEEP( 27 ) INFO ( 7 ) = KEEP( 29 ) CALL MUMPS_SETI8TOI4( KEEP8(13), INFO(8) ) CALL MUMPS_SETI8TOI4( KEEP8(17), INFO(20) ) CALL MUMPS_SETI8TOI4( KEEP8(9), INFO(24) ) CALL MUMPS_SETI8TOI4( K8_33relaxed, INFO(29) ) CALL MUMPS_SETI8TOI4( K8_34relaxed, INFO(32) ) CALL MUMPS_SETI8TOI4( K8_35relaxed, INFO(33) ) CALL MUMPS_SETI8TOI4( K8_50relaxed, INFO(36) ) CALL MUMPS_SETI8TOI4( KEEP8(129), INFOG(4) ) INFOG( 5 ) = KEEP( 127 ) CALL MUMPS_SETI8TOI4( KEEP8(109), INFOG(20) ) CALL DMUMPS_DIAG_ANA(id%MYID, id%COMM, KEEP(1), KEEP8(1), & INFO(1), INFOG(1), RINFO(1), RINFOG(1), ICNTL(1), & id%SIZE_SCHUR ) IF (PROK) WRITE( MP, 112 ) IF (PROKG .AND. (MPG.NE.MP)) WRITE( MPG, 112 ) SUM_KEEP811_THIS_NODE=0_8 CALL MPI_REDUCE( KEEP8(11), SUM_KEEP811_THIS_NODE, 1, & MPI_INTEGER8, & MPI_SUM, 0, id%KEEP(411), IERR ) CALL MPI_REDUCE( SUM_KEEP811_THIS_NODE, MAX_SUM_KEEP811_THIS_NODE, & 1, MPI_INTEGER8, MPI_MAX, 0, id%COMM, IERR ) IF (PROKG .AND. PRINT_NODEINFO) THEN WRITE(MPG,'(A,I16)') & ' Max. estimated space for factors per compute node :', & MAX_SUM_KEEP811_THIS_NODE ENDIF OOC_STRAT = KEEP(201) BLR_STRAT = 0 IF (KEEP(201) .NE. -1) OOC_STRAT=0 PERLU_ON = .FALSE. CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, .FALSE., & .TRUE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF KEEP8(2) = TOTAL_BYTES PERLU_ON = .TRUE. CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, & id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, .FALSE., & .TRUE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF IF ( PROK ) THEN WRITE(MP,'(A,I16) ') & ' Estimated space in MBytes for IC factorization (INFO(15)):', & TOTAL_MBYTES END IF id%INFO(15) = TOTAL_MBYTES CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(15), id%INFOG(16), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I16) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(16)):', & id%INFOG(16) ENDIF WRITE(MPG,'(A,I16) ') & ' Total space in MBytes, IC factorization (INFOG(17)):' & ,id%INFOG(17) END IF SUM_INFO15_THIS_NODE=0 CALL MPI_REDUCE( INFO(15), SUM_INFO15_THIS_NODE, 1, MPI_INTEGER, & MPI_SUM, 0, id%KEEP(411), IERR ) CALL MPI_REDUCE( SUM_INFO15_THIS_NODE, MAX_SUM_INFO15_THIS_NODE, & 1, MPI_INTEGER, MPI_MAX, 0, id%COMM, IERR ) IF ( PROKG .AND. PRINT_NODEINFO ) THEN WRITE(MPG,'(A,I16)') & ' Max. estim. space per compute node, in MBytes, IC fact :', & MAX_SUM_INFO15_THIS_NODE ENDIF OOC_STRAT = KEEP(201) BLR_STRAT = 0 #if defined(OLD_OOC_NOPANEL) IF (OOC_STRAT .NE. -1) OOC_STRAT=2 #else IF (OOC_STRAT .NE. -1) OOC_STRAT=1 #endif PERLU_ON = .FALSE. CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, .FALSE., & .TRUE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF KEEP8(3) = TOTAL_BYTES PERLU_ON = .TRUE. CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, .FALSE., & .TRUE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF id%INFO(17) = TOTAL_MBYTES CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(17), id%INFOG(26), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I16) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(26)):', & id%INFOG(26) ENDIF WRITE(MPG,'(A,I16) ') & ' Total space in MBytes, OOC factorization (INFOG(27)):' & ,id%INFOG(27) END IF SUM_INFO17_THIS_NODE=0 CALL MPI_REDUCE( INFO(17), SUM_INFO17_THIS_NODE, 1, MPI_INTEGER, & MPI_SUM, 0, id%KEEP(411), IERR ) CALL MPI_REDUCE( SUM_INFO17_THIS_NODE, MAX_SUM_INFO17_THIS_NODE, & 1, MPI_INTEGER, MPI_MAX, 0, id%COMM, IERR ) IF (PROKG .AND. PRINT_NODEINFO) THEN WRITE(MPG,'(A,I16)') & ' Max. estim. space per compute node, in MBytes, OOC fact :', & MAX_SUM_INFO17_THIS_NODE ENDIF IF (KEEP(494).NE.0) THEN SUM_OF_PEAKS = .TRUE. CALL DMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, & KEEP(1), KEEP8(1), & id%MYID, id%COMM, & id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), id%NSLAVES, & id%INFO, id%INFOG, PROK, MP, PROKG, MPG & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) END IF 500 CONTINUE IF (allocated(TNSTK_afterL0)) DEALLOCATE(TNSTK_afterL0) IF (allocated(FLAGGED_LEAVES)) DEALLOCATE(FLAGGED_LEAVES) IF (INFO(1) .LT. 0) THEN IF (associated(id%IPOOL_B_L0_OMP)) THEN DEALLOCATE(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_B_L0_OMP) ENDIF IF (associated(id%IPOOL_A_L0_OMP)) THEN DEALLOCATE(id%IPOOL_A_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) ENDIF IF (associated(id%VIRT_L0_OMP)) THEN DEALLOCATE(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP) ENDIF IF (associated(id%VIRT_L0_OMP_MAPPING)) THEN DEALLOCATE(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%VIRT_L0_OMP_MAPPING) ENDIF IF (associated(id%PERM_L0_OMP)) THEN DEALLOCATE(id%PERM_L0_OMP) NULLIFY(id%PERM_L0_OMP) ENDIF IF (associated(id%PTR_LEAFS_L0_OMP)) THEN DEALLOCATE(id%PTR_LEAFS_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) ENDIF ENDIF RETURN 112 FORMAT(/' MEMORY ESTIMATIONS ... '/ & ' Estimations with standard Full-Rank (FR) factorization:') 150 FORMAT( & /' ** FAILURE DURING DMUMPS_ANA_DRIVER, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE DMUMPS_ANA_COMPUTE_ESTIMATES SUBROUTINE DMUMPS_ANA_DISTM(MYID, N, STEP, FRERE, FILS, IPOOL, & LIPOOL, NE, DAD, ND, PROCNODE, SLAVEF, ABOVE_L0, SIZECB_UNDER_L0, & SIZECB_UNDER_L0_IF_LRCB, MAXFR_UNDER_L0, & MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_LO, OPSA_UNDER_L0, PEAK_FR, PEAK_FR_OOC, & NRLADU, NIRADU, NIRNEC, NRLNEC, NRLNEC_ACTIVE, & NRLADU_if_LR_LU, NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, NRLNEC_if_LR_CB, NRLADULR_UD, NRLADULR_WC, & NRLNECLR_CB_UD, NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC, & PEAK_LRLU_UD,PEAK_OOC_LRLU_UD,PEAK_OOC_LRLU_WC, PEAK_LRLUCB_UD, & PEAK_LRLUCB_WC,PEAK_OOC_LRLUCB_UD, PEAK_OOC_LRLUCB_WC, & PEAK_LRCB_UD, PEAK_OOC_LRCB_UD, NIRADU_OOC, NIRNEC_OOC, MAXFR, & OPSA, UU, KEEP,KEEP8, LOCAL_M, LOCAL_N, SBUF_RECOLD, & SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR, SBUF_REC_LR, & OPS_SUBTREE, NSTEPS, I_AM_CAND,NMB_PAR2, ISTEP_TO_INIV2, & CANDIDATES, IFLAG, IERROR, MAX_FRONT_SURFACE_LOCAL, & MAX_SIZE_FACTOR, ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS, ROOT_yes, ROOT_NPROW, ROOT_NPCOL & ) USE DMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE IMPLICIT NONE LOGICAL, intent(in) :: ROOT_yes INTEGER, intent(in) :: ROOT_NPROW, ROOT_NPCOL INTEGER, intent(in) :: MYID, N, LIPOOL LOGICAL, intent(in) :: ABOVE_L0 INTEGER, intent(in) :: MAXFR_UNDER_L0 INTEGER(8), intent(in) :: MAX_FRONT_SURFACE_LOCAL_L0, & MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO DOUBLE PRECISION, intent(in) :: COST_SUBTREES_UNDER_LO, & OPSA_UNDER_L0 INTEGER(8), intent(inout) :: SIZECB_UNDER_L0, & SIZECB_UNDER_L0_IF_LRCB INTEGER, intent(inout) :: IFLAG, IERROR INTEGER NIRADU, NIRNEC INTEGER(8) NRLADU, NRLNEC, NRLNEC_ACTIVE INTEGER(8), intent(out) :: NRLADU_if_LR_LU, & NRLADULR_UD, NRLADULR_WC, & NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, NRLNEC_if_LR_CB, & NRLNECOOC_if_LR_LUCB, NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC INTEGER(8), intent(out):: & PEAK_FR, PEAK_FR_OOC, & PEAK_LRLU_UD, & PEAK_OOC_LRLU_UD, PEAK_OOC_LRLU_WC, & PEAK_LRLUCB_UD, PEAK_LRLUCB_WC, & PEAK_OOC_LRLUCB_UD, PEAK_OOC_LRLUCB_WC, & PEAK_LRCB_UD, PEAK_OOC_LRCB_UD INTEGER(8) NRLADU_CURRENT, NRLADU_ROOT_3 INTEGER NIRADU_OOC, NIRNEC_OOC INTEGER MAXFR, NSTEPS INTEGER(8) MAX_FRONT_SURFACE_LOCAL INTEGER STEP(N) INTEGER FRERE(NSTEPS), FILS(N), IPOOL(max(LIPOOL,1)), NE(NSTEPS), & ND(NSTEPS), PROCNODE(NSTEPS), DAD(NSTEPS) DOUBLE PRECISION UU INTEGER SLAVEF, KEEP(500), LOCAL_M, LOCAL_N INTEGER(8) KEEP8(150) INTEGER(8) ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS INTEGER SBUF_SEND_FR, SBUF_REC_FR INTEGER SBUF_SEND_LR, SBUF_REC_LR INTEGER(8) SBUF_RECOLD INTEGER NMB_PAR2 INTEGER ISTEP_TO_INIV2( KEEP(71) ) LOGICAL I_AM_CAND(NMB_PAR2) INTEGER CANDIDATES( SLAVEF+1, NMB_PAR2 ) INTEGER PHASE PARAMETER (PHASE=0) DOUBLE PRECISION OPSA DOUBLE PRECISION OPSA_LOC INTEGER(8) MAX_SIZE_FACTOR DOUBLE PRECISION OPS_SUBTREE DOUBLE PRECISION OPS_SBTR_LOC INTEGER, ALLOCATABLE, DIMENSION(:) :: TNSTK, LSTKI INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR_if_LRCB, & LSTKRLR_CB_UD, & LSTKRLR_CB_WC LOGICAL OUTER_SENDS_FR INTEGER(8) :: SAVE_SIZECB_UNDER_L0, & SAVE_SIZECB_UNDER_L0_IF_LRCB INTEGER SBUFR_FR, SBUFS_FR INTEGER SBUFR_LR, SBUFS_LR INTEGER(8) SBUFS_CB, SBUFR_CB INTEGER ITOP,NELIM,NFR INTEGER(8) ISTKR, LSTK INTEGER(8) :: NRLADU_CURRENT_MISSING INTEGER(8) :: NRLADU_CURRENT_K60_1 LOGICAL :: I_PROCESS_SCHUR_K60_1 INTEGER(8) :: ISTKR_if_LRCB, ISTKRLR_CB_UD, ISTKRLR_CB_WC, & K464_8, K465_8 INTEGER :: LRSTATUS, IDUMMY INTEGER :: NBNODES_BLR LOGICAL :: COMPRESS_PANEL, COMPRESS_CB INTEGER ISTKI, STKI, ISTKI_OOC INTEGER K,NSTK, IFATH INTEGER INODE, LEAF, IN INTEGER LEVEL, MAXITEMPCB INTEGER(8) CURRENT_ACTIVE_MEM, MAXTEMPCB LOGICAL UPDATE, UPDATEF, MASTER, MASTERF, INSSARBR INTEGER LEVELF, NCB, SIZECBI INTEGER(8) NCB8 INTEGER(8) NFR8, NELIM8 INTEGER(8) :: SIZEFRNOCBLU INTEGER :: IDUMMY_ARRAY(1) INTEGER(8) SIZECB, SIZECBINFR, SIZECB_SLAVE INTEGER(8) SIZECB_if_LRCB, SIZECB_SLAVE_if_LRCB INTEGER(8) SIZECBLR_SLAVE_UD, SIZECBLR_SLAVE_WC INTEGER(8) SIZECBLR_UD, SIZECBLR_WC INTEGER(8) SIZECBSLR, NCBS8, & SIZECBS, SIZECBINFRS INTEGER NFRS, NELIMS, NCBS, LEVELS, LRSTATUSS LOGICAL COMPRESS_CBS INTEGER(8) :: PEAK_DYN_LRLU_UD, PEAK_DYN_LRCB_UD, & PEAK_DYN_LRLUCB_UD, PEAK_DYN_LRLU_WC, & PEAK_DYN_LRLUCB_WC INTEGER SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC INTEGER EXTRA_PERM_INFO_OOC INTEGER NBROWMAX, NSLAVES_LOC, NSLAVES_PASSED, & NELIMF, NFRF, NCBF, & NBROWMAXF, LKJIB_FR, LKJIB_LR, & NBR, NBCOLFAC INTEGER(8) LEV3MAXREC, CBMAXR, CBMAXS INTEGER ALLOCOK INTEGER PANEL_SIZE LOGICAL PACKED_CB DOUBLE PRECISION OPS_NODE, OPS_NODE_MASTER, OPS_NODE_SLAVE INTEGER(8) ENTRIES_NODE_UPPER_PART, ENTRIES_NODE_LOWER_PART INTEGER :: FLAG_L0OMP PARAMETER (FLAG_L0OMP=-2014) INCLUDE 'mumps_headers.h' LOGICAL ROOT_OWNER INTEGER(8) LWK_RR INTEGER LIWK_RR INTEGER IROOT, SIZE_ROOT INTEGER WHAT INTEGER(8) IDUMMY8 INTRINSIC min, int INTRINSIC dble INTEGER DMUMPS_OOC_GET_PANEL_SIZE EXTERNAL DMUMPS_OOC_GET_PANEL_SIZE INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR EXTERNAL MUMPS_MAX_SURFCB_NBROWS EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, & MUMPS_IN_OR_ROOT_SSARBR logical :: FORCE_CAND, CONCERNED, UPDATES, STACKCB, MASTERSON integer :: IFSON, LEVELSON IDUMMY_ARRAY(1) = 0 IF (KEEP(50).eq.2) THEN EXTRA_PERM_INFO_OOC = 1 ELSE IF (KEEP(50).eq.0) THEN EXTRA_PERM_INFO_OOC = 2 ELSE EXTRA_PERM_INFO_OOC = 0 ENDIF PACKED_CB=( KEEP(215).EQ.0 .AND. KEEP(50).NE.0 ) MAX_FRONT_SURFACE_LOCAL=0_8 MAX_SIZE_FACTOR=0_8 ALLOCATE( LSTKR(NSTEPS), TNSTK(NSTEPS), & LSTKI(NSTEPS) , & LSTKR_if_LRCB(NSTEPS), LSTKRLR_CB_UD(NSTEPS), & LSTKRLR_CB_WC(NSTEPS), & stat=ALLOCOK) if (ALLOCOK .GT. 0) THEN IFLAG =-7 IERROR = 6*NSTEPS RETURN endif LKJIB_FR = max(KEEP(5),KEEP(6)) OUTER_SENDS_FR = (KEEP(263).NE.0 .OR. & KEEP(50).EQ.0. AND. (KEEP(468).LT.3 .OR. UU.EQ.0.0D0)) IF ( OUTER_SENDS_FR ) THEN LKJIB_FR = max(LKJIB_FR, KEEP(420)) ENDIF LKJIB_LR = max(LKJIB_FR,KEEP(142)) IF (KEEP(198).NE.0.AND.SLAVEF.GT.1) THEN LKJIB_FR = min(LKJIB_FR*KEEP(179), KEEP(435)) ENDIF TNSTK = NE LEAF = LIPOOL+1 #if defined(OLD_OOC_NOPANEL) XSIZE_OOC=XSIZE_OOC_NOPANEL #else IF (KEEP(50).EQ.0) THEN XSIZE_OOC=XSIZE_OOC_UNSYM ELSE XSIZE_OOC=XSIZE_OOC_SYM ENDIF #endif SIZEHEADER_OOC = XSIZE_OOC+6 SIZEHEADER = XSIZE_IC + 6 ISTKR_if_LRCB = 0_8 ISTKRLR_CB_UD = 0_8 ISTKRLR_CB_WC = 0_8 ISTKR = 0_8 ISTKI = 0 ISTKI_OOC = 0 NBNODES_BLR = 0 OPSA_LOC = 0.0D0 ENTRIES_IN_FACTORS_LOC = 0_8 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 OPS_SBTR_LOC = 0.0D0 NRLADU = 0_8 NIRADU = 0 NIRADU_OOC = 0 NRLADU_CURRENT_K60_1 = 0_8 I_PROCESS_SCHUR_K60_1 = .FALSE. NRLADU_CURRENT = 0_8 NRLADULR_UD = 0_8 NRLADULR_WC = 0_8 NRLADU_ROOT_3 = 0_8 NRLNEC_ACTIVE = 0_8 IF (ABOVE_L0) THEN SAVE_SIZECB_UNDER_L0 = SIZECB_UNDER_L0 SAVE_SIZECB_UNDER_L0_IF_LRCB = SIZECB_UNDER_L0_IF_LRCB ELSE SAVE_SIZECB_UNDER_L0 = 0_8 SAVE_SIZECB_UNDER_L0_IF_LRCB = 0_8 ENDIF PEAK_DYN_LRLU_UD = SAVE_SIZECB_UNDER_L0 PEAK_DYN_LRCB_UD = SAVE_SIZECB_UNDER_L0_IF_LRCB PEAK_DYN_LRLUCB_UD = SAVE_SIZECB_UNDER_L0_IF_LRCB PEAK_DYN_LRLU_WC = SAVE_SIZECB_UNDER_L0 PEAK_DYN_LRLUCB_WC = SAVE_SIZECB_UNDER_L0 NRLNEC = 0_8 NRLADU_if_LR_LU = 0_8 NRLNEC_if_LR_LU = 0_8 NRLNEC_if_LR_CB = 0_8 NRLNEC_if_LR_LUCB = 0_8 NRLNECOOC_if_LR_LUCB = 0_8 NRLNECLR_CB_UD = 0_8 NRLNECLR_LUCB_UD = 0_8 NRLNECLR_LUCB_WC = 0_8 NIRNEC = 0 NIRNEC_OOC = 0 MAXFR = 0 PEAK_FR = 0_8 PEAK_FR_OOC = 0_8 PEAK_LRLU_UD = 0_8 PEAK_OOC_LRLU_UD = 0_8 PEAK_OOC_LRLU_WC = 0_8 PEAK_LRLUCB_UD = 0_8 PEAK_LRLUCB_WC = 0_8 PEAK_OOC_LRLUCB_UD= 0_8 PEAK_OOC_LRLUCB_WC= 0_8 PEAK_LRCB_UD = 0_8 PEAK_OOC_LRCB_UD = 0_8 ITOP = 0 MAXTEMPCB = 0_8 MAXITEMPCB = 0 SBUFS_CB = 1_8 SBUFS_FR = 1 SBUFS_LR = 1 SBUFR_CB = 1_8 SBUFR_FR = 1 SBUFR_LR = 1 IF (KEEP(38) .NE. 0 .AND. KEEP(60).EQ.0) THEN INODE = KEEP(38) NRLADU_ROOT_3 = int(LOCAL_M,8)*int(LOCAL_N,8) NRLADU = NRLADU_ROOT_3 NRLNEC_ACTIVE = NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_ROOT_3) NRLNEC = NRLADU NRLADU_if_LR_LU = NRLADU_ROOT_3 NRLNECOOC_if_LR_LUCB = NRLNEC_ACTIVE NRLNEC_if_LR_LU = NRLADU NRLNEC_if_LR_CB = NRLADU NRLNEC_if_LR_LUCB = NRLADU PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD + SIZECB_UNDER_L0) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF IF (MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID) THEN NIRADU = SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) NIRADU_OOC = SIZEHEADER_OOC+2*(ND(STEP(INODE))+KEEP(253)) ELSE NIRADU = SIZEHEADER NIRADU_OOC = SIZEHEADER_OOC ENDIF NIRNEC = NIRADU NIRNEC_OOC = NIRADU_OOC ENDIF IF((KEEP(24).eq.0).OR.(KEEP(24).eq.1)) THEN FORCE_CAND=.FALSE. ELSE FORCE_CAND=(mod(KEEP(24),2).eq.0) END IF 90 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF - 1 INODE = IPOOL(LEAF) ELSE IF (LIPOOL.NE.0) THEN WRITE(MYID+6,*) ' ERROR 1 in DMUMPS_ANA_DISTM ' CALL MUMPS_ABORT() ELSE GOTO 115 ENDIF ENDIF 95 CONTINUE NFR = ND(STEP(INODE))+KEEP(253) NFR8 = int(NFR,8) NSTK = NE(STEP(INODE)) NELIM = 0 IN = INODE 100 NELIM = NELIM + 1 NELIM8=int(NELIM,8) IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IFSON = -IN IFATH = DAD(STEP(INODE)) MASTER = MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID LEVEL = MUMPS_TYPENODE(PROCNODE(STEP(INODE)),KEEP(199)) INSSARBR = MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) UPDATE=.FALSE. if(.NOT.FORCE_CAND) then UPDATE = ( (MASTER.AND.(LEVEL.NE.3) ).OR. LEVEL.EQ.2 ) else if(MASTER.and.(LEVEL.ne.3)) then UPDATE = .TRUE. else if(LEVEL.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(INODE)))) THEN UPDATE = .TRUE. end if end if end if NCB = NFR-NELIM NCB8 = int(NCB,8) SIZECBINFR = NCB8*NCB8 IF (KEEP(50).EQ.0) THEN SIZECB = SIZECBINFR ELSE IFATH = DAD(STEP(INODE)) IF ( IFATH.NE.KEEP(38) .AND. PACKED_CB ) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = SIZECBINFR ENDIF ENDIF IDUMMY = -99999 CALL IS_FRONT_BLR_CANDIDATE (INODE, LEVEL, NFR, NELIM, & KEEP(494), 1, KEEP(490), & KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, IDUMMY) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) IF (COMPRESS_PANEL.OR.COMPRESS_CB) NBNODES_BLR = NBNODES_BLR+1 IF (COMPRESS_PANEL) THEN K464_8 = int(KEEP(464),8) ELSE K464_8 = 1000_8 ENDIF IF (COMPRESS_CB) THEN K465_8 = int(KEEP(465),8) SIZECB_if_LRCB = 0_8 SIZECBLR_UD = SIZECB*K465_8/1000_8 SIZECBLR_WC = SIZECB ELSE K465_8 = 1000_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = SIZECB ENDIF SIZECBI = 2* NCB + SIZEHEADER IF (LEVEL.NE.2) THEN NSLAVES_LOC = -99999999 SIZECB_SLAVE = -99999997_8 SIZECB_SLAVE_if_LRCB = SIZECB_SLAVE NBROWMAX = NCB ELSE IF (KEEP(48) .EQ. 5) THEN WHAT = 5 IF (FORCE_CAND) THEN NSLAVES_LOC=CANDIDATES(SLAVEF+1, & ISTEP_TO_INIV2(STEP(INODE))) ELSE NSLAVES_LOC=SLAVEF-1 ENDIF NSLAVES_PASSED=NSLAVES_LOC ELSE WHAT = 2 NSLAVES_PASSED=SLAVEF NSLAVES_LOC =SLAVEF-1 ENDIF CALL MUMPS_MAX_SURFCB_NBROWS(WHAT, KEEP,KEEP8, & NCB, NFR, NSLAVES_PASSED, NBROWMAX, SIZECB_SLAVE & ) IF (COMPRESS_CB) THEN SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_SLAVE_UD = SIZECB_SLAVE*K465_8/1000_8 SIZECBLR_SLAVE_WC = SIZECB_SLAVE ELSE SIZECB_SLAVE_if_LRCB = SIZECB_SLAVE SIZECBLR_SLAVE_UD = 0_8 SIZECBLR_SLAVE_WC = 0_8 ENDIF ENDIF IF (KEEP(60).GT.1) THEN IF (MASTER .AND. INODE.EQ.KEEP(38)) THEN NIRADU = NIRADU+SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC+ & 2*(ND(STEP(INODE))+KEEP(253)) ENDIF ENDIF IF (LEVEL.EQ.3) THEN IF ( & KEEP(60).LE.1 & ) THEN NRLADU_CURRENT = int(LOCAL_M,8)*int(LOCAL_N,8) NRLNEC = max(NRLNEC,NRLADU+ISTKR+ & NRLADU_CURRENT) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR+ & NRLADU_CURRENT) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB , & NRLADU+ISTKR_if_LRCB+ & NRLADU_CURRENT) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU+ISTKR_if_LRCB+ & NRLADU_CURRENT) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR_if_LRCB) PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF ENDIF IF (MASTER) THEN IF (NFR.GT.MAXFR) MAXFR = NFR ENDIF ENDIF IF(KEEP(86).EQ.1)THEN IF(MASTER.AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)), KEEP(199))) & )THEN IF(LEVEL.EQ.1)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8) IF (KEEP(268).NE.0) THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8+NELIM8) ENDIF ELSEIF(LEVEL.EQ.2)THEN IF(KEEP(50).EQ.0)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NELIM8) ELSE MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NELIM8*NELIM8) IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NELIM8*(NELIM8+1_8)) ENDIF ENDIF ENDIF ENDIF ENDIF IF (LEVEL.EQ.2) THEN IF (MASTER) THEN IF (KEEP(50).EQ.0) THEN SBUFS_FR = max(SBUFS_FR, NFR*LKJIB_FR+LKJIB_FR+4) SBUFS_LR = max(SBUFS_LR, NFR*LKJIB_LR+LKJIB_LR+4) ELSE SBUFS_FR = max(SBUFS_FR, NELIM*LKJIB_FR+NELIM+6) SBUFS_LR = max(SBUFS_LR, NELIM*LKJIB_LR+NELIM+6) ENDIF ELSEIF (UPDATE) THEN if (KEEP(50).EQ.0) THEN SBUFR_FR = max(SBUFR_FR, NFR*LKJIB_FR+LKJIB_FR+4) SBUFR_LR = max(SBUFR_LR, NFR*LKJIB_LR+LKJIB_LR+4) else SBUFR_FR = max( SBUFR_FR, NELIM*LKJIB_FR+NELIM+6 ) SBUFR_LR = max( SBUFR_LR, NELIM*LKJIB_LR+NELIM+6 ) SBUFS_FR = max( SBUFS_FR, NBROWMAX*LKJIB_FR+6 ) SBUFS_LR = max( SBUFS_LR, NBROWMAX*LKJIB_LR+6 ) SBUFR_FR = max( SBUFR_FR, NBROWMAX*LKJIB_FR+6 ) SBUFR_LR = max( SBUFR_LR, NBROWMAX*LKJIB_LR+6 ) endif ENDIF ENDIF IF ( UPDATE ) THEN IF ( (MASTER) .AND. (LEVEL.EQ.1) ) THEN NIRADU = NIRADU + 2*NFR + SIZEHEADER NIRADU_OOC = NIRADU_OOC + 2*NFR + SIZEHEADER_OOC PANEL_SIZE = DMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NFR, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) IF (KEEP(50).EQ.0) THEN IF (KEEP(251) .EQ. 2) THEN NRLADU_CURRENT = int(NELIM,8) * int(NFR,8) SIZEFRNOCBLU = int(NFR-NELIM,8)*int(NELIM) ELSE NRLADU_CURRENT = int(NELIM,8)*int(2*NFR-NELIM,8) SIZEFRNOCBLU = 0_8 ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR = max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ELSE IF ( KEEP(459) .GT. 1 .AND. KEEP(50).NE.0 ) THEN CALL MUMPS_LDLTPANEL_STORAGE( NELIM, KEEP, & IDUMMY_ARRAY(1), NRLADU_CURRENT ) SIZEFRNOCBLU = int(NELIM,8)*int(NELIM,8) - & NRLADU_CURRENT NRLADU_CURRENT = NRLADU_CURRENT + & int(NELIM,8) * int(NFR-NELIM,8) ELSE SIZEFRNOCBLU = 0_8 NRLADU_CURRENT = int(NELIM,8)*int(NFR,8) ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ENDIF IF (INODE.EQ.KEEP(20).AND.(KEEP(60).EQ.1)) THEN I_PROCESS_SCHUR_K60_1 = .TRUE. NRLADU_CURRENT_K60_1 = NRLADU_CURRENT ENDIF IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_CURRENT_MISSING = 0_8 NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT ENDIF SIZECBI = 2* NCB + SIZEHEADER ELSEIF (LEVEL.EQ.2) THEN IF (MASTER) THEN NIRADU = NIRADU+SIZEHEADER +SLAVEF-1+2*NFR NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC +SLAVEF-1+2*NFR IF (KEEP(50).EQ.0) THEN NRLADU_CURRENT = int(NFR,8)*int(NELIM,8) SIZEFRNOCBLU = 0_8 NBCOLFAC = NFR ELSE NBCOLFAC = NELIM IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 ) THEN CALL MUMPS_LDLTPANEL_STORAGE( NELIM, KEEP, & IDUMMY_ARRAY(1), NRLADU_CURRENT ) SIZEFRNOCBLU = int(NELIM,8)*int(NELIM,8) - & NRLADU_CURRENT ELSE SIZEFRNOCBLU = 0_8 NRLADU_CURRENT = int(NELIM,8)*int(NELIM,8) ENDIF ENDIF PANEL_SIZE = DMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NBCOLFAC, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) NRLADU = NRLADU + NRLADU_CURRENT IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_CURRENT_MISSING = 0_8 NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT ENDIF MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) SIZECB = 0_8 SIZECBINFR = 0_8 SIZECB_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECB=SIZECB_SLAVE SIZECBINFR = SIZECB NIRADU = NIRADU+4+NELIM+NBROWMAX NIRADU_OOC = NIRADU_OOC+4+NELIM+NBROWMAX IF (KEEP(50).EQ.0) THEN IF (KEEP(251) .EQ. 2) THEN NRLADU_CURRENT = 0_8 SIZEFRNOCBLU = int(NELIM,8)*int(NBROWMAX,8) ELSE NRLADU_CURRENT = int(NELIM,8)*int(NBROWMAX,8) SIZEFRNOCBLU = 0_8 ENDIF ELSE NRLADU_CURRENT = int(NELIM,8)*int(NCB/NSLAVES_LOC,8) SIZEFRNOCBLU = 0_8 ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_CURRENT_MISSING = 0_8 NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT ENDIF IF (KEEP(50).EQ.0) THEN SIZECBI = 7 + NBROWMAX + NCB ELSE SIZECBI = 8 + NBROWMAX + NCB ENDIF IF (KEEP(50).NE.0) THEN SIZECBI=SIZECBI+NSLAVES_LOC+ & XTRA_SLAVES_SYM ELSE SIZECBI=SIZECBI+NSLAVES_LOC+ & XTRA_SLAVES_UNSYM ENDIF ENDIF ENDIF NIRNEC = max(NIRNEC, & NIRADU+ISTKI+SIZECBI+MAXITEMPCB) NIRNEC_OOC = max(NIRNEC_OOC, & NIRADU_OOC+ISTKI_OOC+SIZECBI+MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) CURRENT_ACTIVE_MEM = ISTKR+SIZECBINFR IF ( KEEP(50).NE.0 .AND. LEVEL.EQ.1 ) THEN SIZEFRNOCBLU = SIZEFRNOCBLU + int(NELIM,8)*int(NCB,8) ENDIF CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + SIZEFRNOCBLU IF (MASTER .AND. KEEP(219).NE.0.AND. & KEEP(50).EQ.2.AND.LEVEL.EQ.2) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + int(NELIM,8) ENDIF IF (SLAVEF.EQ.1) THEN NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = & max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & MAXTEMPCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING+ & MAXTEMPCB) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & MAXTEMPCB) ENDIF IF (NSTK .NE. 0 .AND. INSSARBR .AND. & KEEP(234).NE.0 .AND. KEEP(55).EQ.0) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTKR(ITOP) ENDIF IF (SLAVEF.EQ.1) THEN NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT_MISSING) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+MAXTEMPCB+ & NRLADU_CURRENT_MISSING) ENDIF NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF IF (NFR.GT.MAXFR) MAXFR = NFR IF (ABOVE_L0.AND.MASTER.AND.(LEVEL.EQ.1)) THEN DO WHILE (IFSON.GT.0) IF (TNSTK(STEP(IFSON)).EQ.FLAG_L0OMP) THEN LEVELS = MUMPS_TYPENODE(PROCNODE(STEP(IFSON)),KEEP(199)) NFRS = ND(STEP(IFSON))+KEEP(253) NELIMS= 0 IN = IFSON DO WHILE (IN.GT.0) IN = FILS(IN) NELIMS = NELIMS + 1 ENDDO NCBS = NFRS-NELIMS NCBS8 = int(NCBS,8) SIZECBINFRS = NCBS8*NCBS8 IF (KEEP(50).EQ.0) THEN SIZECBS = SIZECBINFRS ELSE IF ( PACKED_CB ) THEN SIZECBS = (NCBS8*(NCBS8+1_8))/2_8 ELSE SIZECBS = SIZECBINFRS ENDIF ENDIF IDUMMY = -99999 CALL IS_FRONT_BLR_CANDIDATE & (IFSON, LEVELS, NFRS, NELIMS, & KEEP(494), 1, KEEP(490), & KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(IFSON)), KEEP(38), & KEEP(123), LRSTATUSS, IDUMMY) COMPRESS_CBS = ((LRSTATUSS.EQ.1).OR.(LRSTATUSS.EQ.3)) IF (COMPRESS_CBS) THEN K465_8 = int(KEEP(465),8) SIZECBSLR = SIZECBS*K465_8/1000_8 ELSE SIZECBSLR = SIZECBS ENDIF SIZECB_UNDER_L0 = SIZECB_UNDER_L0 - SIZECBS SIZECB_UNDER_L0_IF_LRCB = SIZECB_UNDER_L0_IF_LRCB & - SIZECBSLR ENDIF IFSON = FRERE(STEP(IFSON)) ENDDO ENDIF IF (NSTK.GT.0) THEN DO 70 K=1,NSTK LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK IF (K==1 .AND. INSSARBR.AND.KEEP(234).NE.0 & .AND.KEEP(55).EQ.0) THEN ELSE CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTK ENDIF LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in DMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF 70 CONTINUE ENDIF ELSE IF (LEVEL.NE.3) THEN DO WHILE (IFSON.GT.0) UPDATES=.FALSE. MASTERSON = MUMPS_PROCNODE(PROCNODE(STEP(IFSON)),KEEP(199)) & .EQ.MYID LEVELSON = MUMPS_TYPENODE(PROCNODE(STEP(IFSON)),KEEP(199)) if(.NOT.FORCE_CAND) then UPDATES =((MASTERSON.AND.(LEVELSON.NE.3)).OR. & LEVELSON.EQ.2) else if(MASTERSON.and.(LEVELSON.ne.3)) then UPDATES = .TRUE. else if(LEVELSON.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFSON)))) then UPDATES = .TRUE. end if end if end if IF (UPDATES) THEN LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in DMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF ENDIF IFSON = FRERE(STEP(IFSON)) END DO ENDIF IF ( & ( (INODE.NE.KEEP(20)).OR.(KEEP(60).EQ.0) ) & .AND. & ( (INODE.NE.KEEP(38)).OR.(KEEP(60).LE.1) ) & ) & THEN ENTRIES_NODE_LOWER_PART = int(NFR-NELIM,8) * int(NELIM,8) IF ( KEEP(50).EQ.0 ) THEN ENTRIES_NODE_UPPER_PART = int(NFR,8) * int(NELIM,8) ELSE ENTRIES_NODE_UPPER_PART = & (int(NELIM,8)*int(NELIM+1,8))/2_8 ENDIF IF (KEEP(50).EQ.2 .AND. LEVEL.EQ.3) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM, 0, & 1,OPS_NODE) ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) ENDIF IF (LEVEL.EQ.2) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 2,OPS_NODE_MASTER) OPS_NODE_SLAVE=OPS_NODE-OPS_NODE_MASTER ENDIF ELSE OPS_NODE = 0.0D0 ENTRIES_NODE_UPPER_PART = 0_8 ENTRIES_NODE_LOWER_PART = 0_8 ENDIF IF ( MASTER ) THEN ENTRIES_IN_FACTORS_LOC_MASTERS = & ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ENDIF IF (UPDATE.OR.LEVEL.EQ.3) THEN IF ( LEVEL .EQ. 3 ) THEN IF (ROOT_yes) THEN OPSA_LOC = OPSA_LOC + & dble( & int(OPS_NODE,8)/ & int(ROOT_NPROW*ROOT_NPCOL,8) & ) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART / & int(ROOT_NPROW*ROOT_NPCOL,8) IF (MASTER) THEN ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & mod(ENTRIES_NODE_UPPER_PART, & int(SLAVEF,8)) ENDIF ENDIF ELSE IF (MASTER .AND. LEVEL.EQ.2) THEN OPSA_LOC = OPSA_LOC + OPS_NODE_MASTER ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART + & mod(ENTRIES_NODE_LOWER_PART, & int(NSLAVES_LOC,8)) ELSE IF (MASTER .AND. LEVEL.EQ.1) THEN OPSA_LOC = OPSA_LOC + OPS_NODE ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ELSE IF (UPDATE) THEN OPSA_LOC = OPSA_LOC + & dble(OPS_NODE_SLAVE)/dble(NSLAVES_LOC) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC & + ENTRIES_NODE_LOWER_PART / & int(NSLAVES_LOC,8) ENDIF IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) .OR. NE(STEP(INODE))==0) THEN IF (LEVEL == 1) THEN OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ENDIF ENDIF ENDIF IF (IFATH .EQ. 0) THEN IF (LEAF.GT.1) THEN GOTO 90 ELSE GOTO 115 ENDIF ELSE NFRF = ND(STEP(IFATH))+KEEP(253) IF (DAD(STEP(IFATH)).EQ.0) THEN NELIMF = NFRF-KEEP(253) IF (ABOVE_L0) IN=0 ELSE NELIMF = 0 IN = IFATH DO WHILE (IN.GT.0) IN = FILS(IN) NELIMF = NELIMF+1 ENDDO ENDIF NCBF = NFRF - NELIMF LEVELF = MUMPS_TYPENODE(PROCNODE(STEP(IFATH)),KEEP(199)) MASTERF= MUMPS_PROCNODE(PROCNODE(STEP(IFATH)), & KEEP(199)).EQ.MYID UPDATEF= .FALSE. if(.NOT.FORCE_CAND) then UPDATEF= ((MASTERF.AND.(LEVELF.NE.3)).OR.LEVELF.EQ.2) else if(MASTERF.and.(LEVELF.ne.3)) then UPDATEF = .TRUE. else if (LEVELF.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFATH)))) THEN UPDATEF = .TRUE. end if end if end if CONCERNED = UPDATEF .OR. UPDATE IF (LEVELF .NE. 2) THEN NBROWMAXF = -999999 ELSE IF (KEEP(48) .EQ. 5) THEN WHAT = 4 IF (FORCE_CAND) THEN NSLAVES_LOC=CANDIDATES(SLAVEF+1, & ISTEP_TO_INIV2(STEP(IFATH))) ELSE NSLAVES_LOC=SLAVEF-1 ENDIF ELSE WHAT = 1 NSLAVES_LOC=SLAVEF ENDIF CALL MUMPS_MAX_SURFCB_NBROWS( WHAT, KEEP, KEEP8, & NCBF, NFRF, NSLAVES_LOC, NBROWMAXF, IDUMMY8 & ) ENDIF IF(LEVEL.EQ.1.AND.UPDATE.AND. & (UPDATEF.OR.LEVELF.EQ.2) & .AND.LEVELF.NE.3) THEN IF ( INSSARBR .AND. KEEP(234).NE.0) THEN NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+SIZECB+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) ENDIF PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) 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,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) IF (.NOT.COMPRESS_PANEL) THEN NRLNEC_if_LR_LU = max( & NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT) NRLNEC_if_LR_CB = max( & NRLNEC_if_LR_CB ,NRLADU + & CURRENT_ACTIVE_MEM-ISTKR + & ISTKR_if_LRCB+NRLADU_CURRENT) NRLNEC_if_LR_LUCB = max( & NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR + & ISTKR_if_LRCB+NRLADU_CURRENT) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF ENDIF ENDIF IF (LEVELF.EQ.3) THEN IF (LEVEL.EQ.1) THEN LEV3MAXREC = int(min(NCB,LOCAL_M),8) * & int(min(NCB,LOCAL_N),8) ELSE LEV3MAXREC = min(SIZECB, & int(min(NBROWMAX,LOCAL_M),8) & *int(min(NCB,LOCAL_N),8)) ENDIF MAXTEMPCB = max(MAXTEMPCB, LEV3MAXREC) MAXITEMPCB = max(MAXITEMPCB,SIZECBI+SIZEHEADER) SBUFR_CB = max(SBUFR_CB, LEV3MAXREC+int(SIZECBI,8)) NIRNEC = max(NIRNEC,NIRADU+ISTKI+ & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) ENDIF IF (CONCERNED) THEN IF (LEVELF.EQ.2) THEN IF (UPDATE.AND.(LEVEL.NE.2.OR..NOT.MASTER)) THEN IF(MASTERF)THEN NBR = min(NBROWMAXF,NBROWMAX) ELSE NBR = min(max(NELIMF,NBROWMAXF),NBROWMAX) ENDIF IF (KEEP(50).EQ.0) THEN CBMAXS = int(NBR,8)*int(NCB,8) ELSE CBMAXS = int(NBR,8)*int(NCB,8) - & (int(NBR,8)*int(NBR-1,8))/2_8 ENDIF ELSE CBMAXS = 0_8 END IF IF (MASTERF) THEN IF (LEVEL.EQ.1) THEN IF (.NOT.UPDATE) THEN NBR = min(NELIMF, NCB) ELSE NBR = 0 ENDIF ELSE NBR = min(NELIMF, NBROWMAX) ENDIF IF (KEEP(50).EQ.0) THEN CBMAXR = int(NBR,8)*NCB8 ELSE CBMAXR = int(NBR,8)*int(min(NCB,NELIMF),8)- & (int(NBR,8)*int(NBR-1,8))/2_8 CBMAXR = min(CBMAXR, int(NELIMF,8)*int(NELIMF+1,8)/2_8) CBMAXR = min(CBMAXR, SIZECB) IF ((LEVEL.EQ.1).AND.(.NOT. PACKED_CB)) THEN CBMAXR = min(CBMAXR,(NCB8*(NCB8+1_8))/2_8) ENDIF ENDIF ELSE IF (UPDATEF) THEN NBR = min(NBROWMAXF,NBROWMAX) CBMAXR = int(NBR,8) * NCB8 IF (KEEP(50).NE.0) THEN CBMAXR = CBMAXR - (int(NBR,8)*(int(NBR-1,8)))/2_8 ENDIF ELSE CBMAXR = 0_8 ENDIF ELSEIF (LEVELF.EQ.3) THEN CBMAXR = LEV3MAXREC IF (UPDATE.AND. .NOT. (MASTER.AND.LEVEL.EQ.2)) THEN CBMAXS = LEV3MAXREC ELSE CBMAXS = 0_8 ENDIF ELSE IF (MASTERF) THEN CBMAXS = 0_8 NBR = min(NFRF,NBROWMAX) IF ((LEVEL.EQ.1).AND.UPDATE) THEN NBR = 0 ENDIF CBMAXR = int(NBR,8)*int(min(NFRF,NCB),8) IF (LEVEL.EQ.2) & CBMAXR = min(CBMAXR, SIZECB_SLAVE) IF ( KEEP(50).NE.0 ) THEN CBMAXR = min(CBMAXR,(int(NFRF,8)*int(NFRF+1,8))/2_8) ELSE CBMAXR = min(CBMAXR,int(NFRF,8)*int(NFRF,8)) ENDIF ELSE CBMAXR = 0_8 CBMAXS = SIZECB ENDIF ENDIF IF (UPDATE) THEN CBMAXS = min(CBMAXS, SIZECB) IF ( .not. ( LEVELF .eq. 1 .AND. UPDATEF ) )THEN SBUFS_CB = max(SBUFS_CB, CBMAXS+int(SIZECBI,8)) ENDIF ENDIF STACKCB = .FALSE. IF (UPDATEF) THEN STACKCB = .TRUE. SIZECBI = 2 * NCB + SIZEHEADER IF (LEVEL.EQ.1) THEN IF (KEEP(50).NE.0.AND.LEVELF.NE.3 & .AND.PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF IF (MASTER) THEN IF (MASTERF) THEN SIZECBI = 2+ XSIZE_IC ENDIF ELSE IF (LEVELF.EQ.1) THEN SIZECB = min(CBMAXR,SIZECB) IF (COMPRESS_CB) THEN SIZECBLR_UD = min(SIZECBLR_UD,SIZECB) SIZECBLR_WC = min(SIZECBLR_WC,SIZECB) SIZECB_if_LRCB = min(SIZECB_if_LRCB,SIZECB) ENDIF SIZECBI = 2 * NCB + 9 SBUFR_CB = max(SBUFR_CB, int(SIZECBI,8)+SIZECB) SIZECBI = 2 * NCB + SIZEHEADER ELSE SIZECBI = 2 * NCB + 9 SBUFR_CB = max(SBUFR_CB, & min(SIZECB,CBMAXR) + int(SIZECBI,8)) MAXTEMPCB = max(MAXTEMPCB, min(SIZECB,CBMAXR)) SIZECBI = 2 * NCB + SIZEHEADER MAXITEMPCB = max(MAXITEMPCB, SIZECBI) IF ( .NOT. MASTERF ) THEN SIZECBI = 0 ELSE SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ENDIF SIZECB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = 0_8 ENDIF ELSE SIZECB = SIZECB_SLAVE SIZECBLR_UD = SIZECBLR_SLAVE_UD SIZECBLR_WC = SIZECBLR_SLAVE_WC SIZECB_if_LRCB = SIZECB_SLAVE_if_LRCB MAXTEMPCB = max(MAXTEMPCB, min(CBMAXR,SIZECB) ) MAXITEMPCB = max(MAXITEMPCB,NBROWMAX+NCB+SIZEHEADER) IF (.NOT. & (UPDATE.AND.(.NOT.MASTER).AND.(NSLAVES_LOC.EQ.1)) & ) & SBUFR_CB = max(SBUFR_CB, & min(CBMAXR,SIZECB) + int(NBROWMAX + NCB + 6,8)) IF (MASTER) THEN SIZECB = 0_8 SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 IF (MASTERF) THEN SIZECBI = 2 + XSIZE_IC ELSE SIZECBI = 0 ENDIF ELSE IF (UPDATE) THEN IF (MASTERF) THEN SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECBI = 0 ENDIF IF (KEEP(50).EQ.0) THEN SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER ELSE SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER+ NSLAVES_LOC ENDIF ELSE SIZECB = 0_8 IF ( MASTERF ) THEN SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECBI = 0 ENDIF SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 ENDIF ENDIF ELSE IF (LEVELF.NE.3) THEN STACKCB = .TRUE. SIZECB = 0_8 SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECBI = 0 IF ( (LEVEL.EQ.1) .AND. (LEVELF.NE.1) ) THEN IF (PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF SIZECBI = 2 * NCB + SIZEHEADER ELSE IF (LEVEL.EQ.2) THEN IF (MASTER) THEN SIZECBI=0 ELSE SIZECB = SIZECB_SLAVE SIZECBLR_UD = SIZECBLR_SLAVE_UD SIZECBLR_WC = SIZECBLR_SLAVE_WC SIZECB_if_LRCB = SIZECB_SLAVE_if_LRCB SIZECBI = NBROWMAX + NFR + SIZEHEADER ENDIF ENDIF ENDIF ENDIF IF (STACKCB) THEN IF (FRERE(STEP(INODE)).EQ.0) THEN write(*,*) ' ERROR 3 in DMUMPS_ANA_DISTM' CALL MUMPS_ABORT() ENDIF ITOP = ITOP + 1 IF ( ITOP .GT. NSTEPS ) THEN WRITE(*,*) 'ERROR 4 in DMUMPS_ANA_DISTM ' ENDIF LSTKI(ITOP) = SIZECBI ISTKI=ISTKI + SIZECBI ISTKI_OOC = ISTKI_OOC + SIZECBI + (XSIZE_OOC-XSIZE_IC) LSTKR(ITOP) = SIZECB ISTKR = ISTKR + LSTKR(ITOP) NRLNEC = max(NRLNEC,NRLADU+ISTKR+MAXTEMPCB) NIRNEC = max(NIRNEC,NIRADU+ISTKI+MAXITEMPCB) NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ & MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR+MAXTEMPCB) LSTKR_if_LRCB(ITOP) = SIZECB_if_LRCB ISTKR_if_LRCB = ISTKR_if_LRCB + LSTKR_if_LRCB(ITOP) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB, & NRLADU_if_LR_LU+ISTKR_if_LRCB + & MAXTEMPCB) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU+ISTKR_if_LRCB + & MAXTEMPCB) LSTKRLR_CB_UD(ITOP) = SIZECBLR_UD ISTKRLR_CB_UD = ISTKRLR_CB_UD + LSTKRLR_CB_UD(ITOP) LSTKRLR_CB_WC(ITOP) = SIZECBLR_WC ISTKRLR_CB_WC = ISTKRLR_CB_WC + LSTKRLR_CB_WC(ITOP) NRLNECLR_CB_UD = max(NRLNECLR_CB_UD, ISTKRLR_CB_UD) NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) ENDIF ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH GOTO 95 ELSE GOTO 90 ENDIF ENDIF 115 CONTINUE IF ( KEEP(53) .NE. 0 ) THEN IF ( KEEP(38) .ne. 0 ) THEN IROOT = KEEP( 38 ) ELSE IROOT = KEEP( 20 ) END IF ROOT_OWNER = ( MYID .eq. & MUMPS_PROCNODE( PROCNODE(STEP(IROOT)), KEEP(199) ) ) SIZE_ROOT = ND(STEP(IROOT))+KEEP(253) CALL DMUMPS_SVD_QR_ESTIM_WK( PHASE, & KEEP(51), KEEP(51), SIZE_ROOT, & LOCAL_M, LOCAL_N, ROOT_OWNER, KEEP,KEEP8, & LIWK_RR, LWK_RR ) IF ( NRLNEC-NRLADU .LT. LWK_RR ) THEN NRLNEC = NRLADU + LWK_RR NRLNEC_if_LR_LU = NRLNEC_if_LR_LU + LWK_RR NRLNEC_if_LR_CB = NRLNEC_if_LR_CB + LWK_RR NRLNEC_if_LR_LUCB = NRLNEC_if_LR_LUCB + LWK_RR NRLNEC_ACTIVE = NRLNEC_ACTIVE + LWK_RR NRLNECOOC_if_LR_LUCB = NRLNECOOC_if_LR_LUCB + LWK_RR PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF END IF IF ( NIRNEC-NIRADU .LT. LIWK_RR ) THEN NIRNEC = NIRADU + LIWK_RR END IF IF ( NIRNEC_OOC-NIRADU_OOC .LT. LIWK_RR ) THEN NIRNEC_OOC = NIRADU_OOC + LIWK_RR END IF END IF NRLNEC = max(NRLNEC, NRLADU+int(KEEP(30),8)) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE, MAX_SIZE_FACTOR+ & int(KEEP(30),8)) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU + int(KEEP(30),8)) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU + int(KEEP(30),8)) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB, & NRLADU + int(KEEP(30),8)) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & MAX_SIZE_FACTOR+ int(KEEP(30),8)) PEAK_FR = SAVE_SIZECB_UNDER_L0 + NRLNEC PEAK_FR_OOC = SAVE_SIZECB_UNDER_L0 + NRLNEC_ACTIVE PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) IF (KEEP(60).EQ.1) THEN IF (I_PROCESS_SCHUR_K60_1) THEN NRLADU = NRLADU - NRLADU_CURRENT_K60_1 NRLADU_IF_LR_LU = NRLADU_IF_LR_LU - NRLADU_CURRENT_K60_1 ENDIF ENDIF IF (ABOVE_L0) THEN PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + SAVE_SIZECB_UNDER_L0_IF_LRCB) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + PEAK_DYN_LRCB_UD) PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + SAVE_SIZECB_UNDER_L0) PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + PEAK_DYN_LRLU_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + SAVE_SIZECB_UNDER_L0) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + PEAK_DYN_LRLU_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + SAVE_SIZECB_UNDER_L0) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + PEAK_DYN_LRLU_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + SAVE_SIZECB_UNDER_L0_IF_LRCB) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + PEAK_DYN_LRLUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + SAVE_SIZECB_UNDER_L0) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + PEAK_DYN_LRLUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + SAVE_SIZECB_UNDER_L0_IF_LRCB) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + PEAK_DYN_LRLUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + SAVE_SIZECB_UNDER_L0) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + PEAK_DYN_LRLUCB_WC) ENDIF SBUF_RECOLD = max(SBUFR_CB, & MAXTEMPCB+int(MAXITEMPCB,8)) + 10_8 SBUF_REC_FR = max(SBUFR_FR, int(min(100000_8,SBUFR_CB))) + 17 SBUF_REC_LR = max(SBUFR_LR, int(min(100000_8,SBUFR_CB))) + 17 SBUF_REC_FR = SBUF_REC_FR + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_REC_LR = SBUF_REC_LR + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_SEND_FR = max(SBUFS_FR, int(min(100000_8,SBUFR_CB)))+17 SBUF_SEND_LR = max(SBUFS_LR, int(min(100000_8,SBUFR_CB)))+17 IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN SBUF_RECOLD = SBUF_RECOLD+int(KEEP(108)+1,8) SBUF_REC_FR = SBUF_REC_FR+KEEP(108)+1 SBUF_REC_LR = SBUF_REC_LR+KEEP(108)+1 SBUF_SEND_FR = SBUF_SEND_FR+KEEP(108)+1 SBUF_SEND_LR = SBUF_SEND_LR+KEEP(108)+1 ENDIF IF (SLAVEF.EQ.1) THEN SBUF_RECOLD = 1_8 SBUF_REC_FR = 1 SBUF_REC_LR = 1 SBUF_SEND_FR= 1 SBUF_SEND_LR= 1 ENDIF DEALLOCATE( LSTKR, TNSTK, LSTKI, & LSTKR_if_LRCB, LSTKRLR_CB_UD, LSTKRLR_CB_WC & ) IF (ABOVE_L0) THEN KEEP(470) = KEEP(470)+ NBNODES_BLR ELSE KEEP(470) = NBNODES_BLR ENDIF IF (.NOT.ABOVE_L0) THEN PEAK_FR = NRLNEC PEAK_FR_OOC = NRLNEC_ACTIVE ENDIF MAXFR = max(MAXFR, MAXFR_UNDER_L0) MAX_FRONT_SURFACE_LOCAL = max (MAX_FRONT_SURFACE_LOCAL, & MAX_FRONT_SURFACE_LOCAL_L0) MAX_SIZE_FACTOR = max (MAX_SIZE_FACTOR, & MAX_SIZE_FACTOR_L0) ENTRIES_IN_FACTORS_LOC_MASTERS = ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_IN_FACTORS_MASTERS_LO ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_IN_FACTORS_UNDER_L0 OPS_SBTR_LOC = OPS_SBTR_LOC + COST_SUBTREES_UNDER_LO OPSA_LOC = OPSA_LOC + OPSA_UNDER_L0 OPS_SUBTREE = dble(OPS_SBTR_LOC) OPSA = dble(OPSA_LOC) RETURN END SUBROUTINE DMUMPS_ANA_DISTM SUBROUTINE DMUMPS_ANA_DISTM_UNDERL0OMP( & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP , VIRT_L0_OMP , VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP , PHYS_L0_OMP , PERM_L0_OMP, & PTR_LEAFS_L0_OMP, & KEEP, N, NE, STEP, FRERE, FILS, DAD, ND, & MYID, PROCNODE, & I4_L0, NBSTATS_I4, I8_L0, NBSTATS_I8, NBTHREADS, & SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB_UD, & TNSTK, MAXFR, & MAX_FRONT_SURFACE_LOCAL, MAX_SIZE_FACTOR, & ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS, & OPS_SBTR_LOC, OPSA_LOC, NBNODES_BLR, & IFLAG, IERROR ) IMPLICIT NONE INTEGER, INTENT(IN) :: LPOOL_B_L0_OMP, & L_VIRT_L0_OMP, L_PHYS_L0_OMP INTEGER, INTENT(IN) :: IPOOL_B_L0_OMP ( LPOOL_B_L0_OMP ) INTEGER, INTENT(IN) :: VIRT_L0_OMP ( L_VIRT_L0_OMP ) INTEGER, INTENT(IN) :: VIRT_L0_OMP_MAPPING ( L_VIRT_L0_OMP ) INTEGER, INTENT(IN) :: PHYS_L0_OMP ( L_PHYS_L0_OMP ) INTEGER, INTENT(IN) :: PERM_L0_OMP ( L_PHYS_L0_OMP ) INTEGER, INTENT(IN) :: PTR_LEAFS_L0_OMP ( L_PHYS_L0_OMP + 1 ) INTEGER, INTENT(IN) :: N INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER, INTENT(IN) :: NE(KEEP(28)) INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: FRERE(KEEP(28)) INTEGER, INTENT(IN) :: FILS(N) INTEGER, INTENT(IN) :: DAD(KEEP(28)), ND(KEEP(28)) INTEGER, INTENT(IN) :: MYID, PROCNODE(KEEP(28)) INTEGER, INTENT(IN) :: NBSTATS_I4, NBSTATS_I8, NBTHREADS INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(OUT) :: TNSTK(KEEP(28)) INTEGER, INTENT(OUT) :: I4_L0 (NBSTATS_I4, NBTHREADS) INTEGER(8), INTENT(OUT):: I8_L0 (NBSTATS_I8, NBTHREADS) INTEGER(8), INTENT(OUT):: ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS, & SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB_UD INTEGER, INTENT(OUT) :: MAXFR, NBNODES_BLR INTEGER(8), INTENT(OUT):: MAX_FRONT_SURFACE_LOCAL, & MAX_SIZE_FACTOR DOUBLE PRECISION, INTENT(OUT) :: OPS_SBTR_LOC, OPSA_LOC INTEGER, ALLOCATABLE, DIMENSION(:) :: LSTKI INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR_if_LRCB, & LSTKRLR_CB_UD, & LSTKRLR_CB_WC DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: OPSA_LOC_L0_OMP INTEGER :: ITH INTEGER :: NSTEPS INTEGER :: allocok INTEGER(8):: ISTKR, ISTKR_if_LRCB, ISTKRLR_CB_UD, & ISTKRLR_CB_WC INTEGER :: ISTKI, ISTKI_OOC, ITOP NSTEPS = KEEP(28) ALLOCATE( LSTKR(NSTEPS), LSTKI(NSTEPS) , & LSTKR_if_LRCB(NSTEPS), LSTKRLR_CB_UD(NSTEPS), & LSTKRLR_CB_WC(NSTEPS), & OPSA_LOC_L0_OMP(NBTHREADS), & & stat=allocok) IF ( allocok .GT. 0 ) THEN IFLAG =-7 IERROR = 4*NSTEPS+NBTHREADS RETURN ENDIF TNSTK = NE OPSA_LOC_L0_OMP(1:NBTHREADS) = 0.0D0 OPS_SBTR_LOC = 0.0D0 OPSA_LOC = 0.0D0 I4_L0(1:NBSTATS_I4, 1:NBTHREADS) = 0 I8_L0(1:NBSTATS_I8, 1:NBTHREADS) = 0_8 NBNODES_BLR = 0 SIZECB_UNDER_L0 = 0_8 SIZECB_UNDER_L0_IF_LRCB_UD = 0_8 MAXFR = 0 MAX_FRONT_SURFACE_LOCAL = 0_8 MAX_SIZE_FACTOR = 0_8 ENTRIES_IN_FACTORS_LOC = 0_8 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 DO ITH = 1, NBTHREADS ISTKI = 0 ISTKI_OOC = 0 ITOP = 0 ISTKR = 0_8 ISTKR_if_LRCB = 0_8 ISTKRLR_CB_UD = 0_8 ISTKRLR_CB_WC = 0_8 ISTKR = 0_8 CALL DMUMPS_ANA_DISTM_UNDERL0_1THR ( ITH, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP , VIRT_L0_OMP , VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP , PHYS_L0_OMP , PERM_L0_OMP, & PTR_LEAFS_L0_OMP, KEEP, N, NE, NSTEPS, & STEP, FRERE, FILS, DAD, ND, MYID, PROCNODE, & ISTKR, ISTKI, ISTKI_OOC, ISTKR_if_LRCB, ISTKRLR_CB_UD, & ISTKRLR_CB_WC, ITOP, & LSTKI, LSTKR, LSTKR_if_LRCB, LSTKRLR_CB_UD, LSTKRLR_CB_WC, & I4_L0(1,ITH), I4_L0(2,ITH), I4_L0(3,ITH), I4_L0(4,ITH), & I8_L0(1,ITH), I8_L0(2,ITH), I8_L0(3,ITH), I8_L0(4,ITH), & I8_L0(5,ITH), I8_L0(6,ITH), I8_L0(7,ITH), I8_L0(8,ITH), & I8_L0(9,ITH), I8_L0(10,ITH), I8_L0(11,ITH), I8_L0(12,ITH), & I8_L0(13,ITH), I8_L0(14,ITH), I8_L0(15,ITH), I8_L0(16,ITH), & I8_L0(17,ITH), I8_L0(18,ITH), I8_L0(19,ITH), I8_L0(20,ITH), & I8_L0(21,ITH), I8_L0(22,ITH), & NBNODES_BLR, TNSTK, MAXFR, & MAX_FRONT_SURFACE_LOCAL, MAX_SIZE_FACTOR, & ENTRIES_IN_FACTORS_LOC, ENTRIES_IN_FACTORS_LOC_MASTERS, & OPS_SBTR_LOC, OPSA_LOC_L0_OMP(ITH), IFLAG, IERROR ) OPSA_LOC = OPSA_LOC + OPSA_LOC_L0_OMP(ITH) I8_L0(23,ITH) = ISTKR SIZECB_UNDER_L0 = SIZECB_UNDER_L0 + ISTKR I8_L0(24,ITH) = ISTKR_if_LRCB + ISTKRLR_CB_UD SIZECB_UNDER_L0_IF_LRCB_UD = SIZECB_UNDER_L0_IF_LRCB_UD + & ISTKR_if_LRCB + ISTKRLR_CB_UD ENDDO DEALLOCATE( LSTKR, LSTKI , & LSTKR_if_LRCB, LSTKRLR_CB_UD, & LSTKRLR_CB_WC, & OPSA_LOC_L0_OMP) RETURN END SUBROUTINE DMUMPS_ANA_DISTM_UNDERL0OMP SUBROUTINE DMUMPS_ANA_DISTM_UNDERL0_1THR ( ITHREAD, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP , VIRT_L0_OMP , VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP , PHYS_L0_OMP , PERM_L0_OMP, & PTR_LEAFS_L0_OMP, KEEP, N, NE, NSTEPS, STEP, FRERE, FILS, DAD, & ND, MYID, PROCNODE, ISTKR, ISTKI, ISTKI_OOC, ISTKR_if_LRCB, & ISTKRLR_CB_UD, ISTKRLR_CB_WC, ITOP, & LSTKI, LSTKR, LSTKR_if_LRCB, LSTKRLR_CB_UD, LSTKRLR_CB_WC, & NIRADU, NIRNEC, NIRADU_OOC, NIRNEC_OOC, NRLADU, NRLNEC, & NRLNEC_ACTIVE, NRLADU_if_LR_LU, NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, NRLNECOOC_if_LR_LUCB, NRLNEC_if_LR_CB, & NRLADULR_UD, NRLADULR_WC, NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC, & PEAK_LRLU_UD, PEAK_OOC_LRLU_UD, PEAK_OOC_LRLU_WC, & PEAK_LRLUCB_UD, PEAK_LRLUCB_WC, PEAK_OOC_LRLUCB_UD, & PEAK_OOC_LRLUCB_WC, PEAK_LRCB_UD, PEAK_OOC_LRCB_UD, & NBNODES_BLR, TNSTK, MAXFR, & MAX_FRONT_SURFACE_LOCAL, MAX_SIZE_FACTOR, & ENTRIES_IN_FACTORS_LOC, ENTRIES_IN_FACTORS_LOC_MASTERS, & OPS_SBTR_LOC, OPSA_LOC, IFLAG, IERROR ) USE DMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE IMPLICIT NONE INTEGER, INTENT(IN) :: ITHREAD, LPOOL_B_L0_OMP, & L_VIRT_L0_OMP, L_PHYS_L0_OMP INTEGER, INTENT(IN) :: IPOOL_B_L0_OMP ( LPOOL_B_L0_OMP ) INTEGER, INTENT(IN) :: VIRT_L0_OMP ( L_VIRT_L0_OMP ) INTEGER, INTENT(IN) :: VIRT_L0_OMP_MAPPING ( L_VIRT_L0_OMP ) INTEGER, INTENT(IN) :: PHYS_L0_OMP ( L_PHYS_L0_OMP ) INTEGER, INTENT(IN) :: PERM_L0_OMP ( L_PHYS_L0_OMP ) INTEGER, INTENT(IN) :: PTR_LEAFS_L0_OMP ( L_PHYS_L0_OMP + 1 ) INTEGER, INTENT(IN) :: KEEP(500), N, NSTEPS INTEGER, INTENT(IN) :: NE(NSTEPS) INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: FRERE(NSTEPS) INTEGER, INTENT(IN) :: FILS(N) INTEGER, INTENT(IN) :: DAD(NSTEPS), ND(NSTEPS) INTEGER, INTENT(IN) :: MYID, PROCNODE(NSTEPS) DOUBLE PRECISION, INTENT(INOUT) :: OPS_SBTR_LOC DOUBLE PRECISION, INTENT(OUT) :: OPSA_LOC INTEGER, INTENT(INOUT) :: NBNODES_BLR INTEGER, INTENT(INOUT) :: TNSTK(NSTEPS) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: MAXFR INTEGER(8), INTENT(INOUT):: MAX_FRONT_SURFACE_LOCAL, & MAX_SIZE_FACTOR INTEGER(8), INTENT(INOUT):: ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS INTEGER(8), INTENT(INOUT) :: & ISTKR, ISTKR_if_LRCB, & ISTKRLR_CB_UD, ISTKRLR_CB_WC INTEGER, INTENT(INOUT) :: ISTKI, ISTKI_OOC, ITOP INTEGER, INTENT(INOUT) :: LSTKI(NSTEPS) INTEGER(8), INTENT(INOUT) :: LSTKR(NSTEPS), & LSTKR_if_LRCB(NSTEPS), & LSTKRLR_CB_UD(NSTEPS), & LSTKRLR_CB_WC(NSTEPS) INTEGER, INTENT(OUT) :: NIRADU, NIRNEC, NIRADU_OOC, NIRNEC_OOC INTEGER(8), INTENT(OUT):: NRLADU, NRLNEC, NRLNEC_ACTIVE, & NRLADU_if_LR_LU, NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, NRLNEC_if_LR_CB, & NRLADULR_UD, NRLADULR_WC, NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC, & PEAK_LRLU_UD, PEAK_OOC_LRLU_UD, PEAK_OOC_LRLU_WC, & PEAK_LRLUCB_UD, PEAK_LRLUCB_WC, PEAK_OOC_LRLUCB_UD, & PEAK_OOC_LRLUCB_WC, PEAK_LRCB_UD, PEAK_OOC_LRCB_UD LOGICAL :: INSSARBR INTEGER :: VIRTUAL_TASK, PHYSICAL_TASK INTEGER :: INODE, IFATH, I INTEGER :: SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC INTEGER :: EXTRA_PERM_INFO_OOC LOGICAL :: PACKED_CB INTEGER(8) :: NRLADU_ROOT_3 INTEGER :: FLAG_L0OMP PARAMETER (FLAG_L0OMP=-2014) INCLUDE 'mumps_headers.h' IF (KEEP(50).eq.2) THEN EXTRA_PERM_INFO_OOC = 1 ELSE IF (KEEP(50).eq.0) THEN EXTRA_PERM_INFO_OOC = 2 ELSE EXTRA_PERM_INFO_OOC = 0 ENDIF PACKED_CB=( KEEP(215).EQ.0 .AND. KEEP(50).NE.0 ) NRLADU_ROOT_3 = 0_8 #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 DO VIRTUAL_TASK = 1, L_VIRT_L0_OMP - 1 IF (VIRT_L0_OMP_MAPPING(VIRTUAL_TASK) .EQ. ITHREAD) THEN DO PHYSICAL_TASK= & VIRT_L0_OMP ( VIRTUAL_TASK ), & VIRT_L0_OMP ( VIRTUAL_TASK + 1 ) - 1 DO I = PTR_LEAFS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK ) ), & PTR_LEAFS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK )+1 ) +1, & - 1 INODE = IPOOL_B_L0_OMP(I) IF (INODE .LE. 0) THEN CYCLE ENDIF 10 CONTINUE IFATH = DAD(STEP(INODE)) CALL DMUMPS_PROCESS_NODE_UNDERL0 () IF (IFATH .NE. 0) THEN TNSTK( STEP(IFATH) ) = TNSTK( STEP(IFATH) ) - 1 ENDIF IF ( PHYS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK ) ) & .EQ. INODE ) THEN TNSTK(STEP(INODE)) = FLAG_L0OMP ELSE IF ( TNSTK( STEP(IFATH) ) .EQ. 0 ) THEN INODE = IFATH GOTO 10 ENDIF ENDDO ENDDO ENDIF ENDDO RETURN CONTAINS SUBROUTINE DMUMPS_PROCESS_NODE_UNDERL0 IMPLICIT NONE INTEGER :: LRSTATUS, IDUMMY LOGICAL :: COMPRESS_PANEL, COMPRESS_CB INTEGER :: STKI INTEGER(8) :: LSTK INTEGER :: K, NFR, NFRF, NELIM, NELIMF, NCB, NSTK, & LEVEL, LEVELF, IN, & MAXITEMPCB, PANEL_SIZE, SIZECBI INTEGER(8):: NFR8, NCB8, & K464_8, K465_8, & CURRENT_ACTIVE_MEM, & ENTRIES_NODE_LOWER_PART, ENTRIES_NODE_UPPER_PART, & NRLADU_CURRENT, NRLADU_CURRENT_MISSING INTEGER(8) :: SIZEFRNOCBLU INTEGER :: IDUMMY_ARRAY(1) INTEGER(8):: SIZECB, SIZECBINFR INTEGER(8):: SIZECB_if_LRCB INTEGER(8):: SIZECBLR_UD, SIZECBLR_WC LOGICAL :: MASTER, MASTERF, STACKCB DOUBLE PRECISION :: OPS_NODE INTRINSIC int INTEGER DMUMPS_OOC_GET_PANEL_SIZE EXTERNAL DMUMPS_OOC_GET_PANEL_SIZE INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR EXTERNAL MUMPS_MAX_SURFCB_NBROWS EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, & MUMPS_IN_OR_ROOT_SSARBR MAXITEMPCB = 0 STACKCB = .TRUE. NFR = ND(STEP(INODE))+KEEP(253) NFR8 = int(NFR,8) NSTK = NE(STEP(INODE)) NELIM = 0 IN = INODE 100 NELIM = NELIM + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IFATH = DAD(STEP(INODE)) MASTER = MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID LEVEL = MUMPS_TYPENODE(PROCNODE(STEP(INODE)),KEEP(199)) INSSARBR = MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) IDUMMY_ARRAY(1) = 0 NCB = NFR-NELIM NCB8 = int(NCB,8) SIZECBINFR = NCB8*NCB8 IF (KEEP(50).EQ.0) THEN SIZECB = SIZECBINFR ELSE IF ( PACKED_CB ) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = SIZECBINFR ENDIF ENDIF IDUMMY = -99999 CALL IS_FRONT_BLR_CANDIDATE (INODE, LEVEL, NFR, NELIM, & KEEP(494), 1, KEEP(490), & KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, IDUMMY) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) IF (COMPRESS_PANEL.OR.COMPRESS_CB) NBNODES_BLR = NBNODES_BLR+1 IF (COMPRESS_PANEL) THEN K464_8 = int(KEEP(464),8) ELSE K464_8 = 1000_8 ENDIF IF (COMPRESS_CB) THEN K465_8 = int(KEEP(465),8) SIZECB_if_LRCB = 0_8 SIZECBLR_UD = SIZECB*K465_8/1000_8 SIZECBLR_WC = SIZECB ELSE K465_8 = 1000_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = SIZECB ENDIF SIZECBI = 2* NCB + SIZEHEADER IF(KEEP(86).EQ.1)THEN IF(MASTER.AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)), KEEP(199))) & )THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8) ENDIF ENDIF NIRADU = NIRADU + 2*NFR + SIZEHEADER NIRADU_OOC = NIRADU_OOC + 2*NFR + SIZEHEADER_OOC PANEL_SIZE = DMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NFR, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) IF (KEEP(50).EQ.0) THEN IF (KEEP(251) .EQ. 2) THEN NRLADU_CURRENT = int(NELIM,8) * int(NFR,8) SIZEFRNOCBLU = int(NFR-NELIM,8)*int(NELIM) ELSE NRLADU_CURRENT = int(NELIM,8)*int(2*NFR-NELIM,8) SIZEFRNOCBLU = 0_8 ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR = max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ELSE IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 ) THEN CALL MUMPS_LDLTPANEL_STORAGE( NELIM, KEEP, & IDUMMY_ARRAY(1), NRLADU_CURRENT ) SIZEFRNOCBLU = int(NELIM,8)*int(NELIM,8) - & NRLADU_CURRENT NRLADU_CURRENT = NRLADU_CURRENT + & int(NELIM,8) * int(NFR-NELIM,8) ELSE SIZEFRNOCBLU = 0_8 NRLADU_CURRENT = int(NELIM,8)*int(NFR,8) ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ENDIF IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_CURRENT_MISSING = 0_8 NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT ENDIF SIZECBI = 2* NCB + SIZEHEADER NIRNEC = max(NIRNEC, & NIRADU+ISTKI+SIZECBI+MAXITEMPCB) NIRNEC_OOC = max(NIRNEC_OOC, & NIRADU_OOC+ISTKI_OOC+SIZECBI+MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) CURRENT_ACTIVE_MEM = ISTKR+SIZECBINFR IF ( KEEP(50).NE.0 .AND. LEVEL.EQ.1 ) THEN SIZEFRNOCBLU = SIZEFRNOCBLU + int(NELIM,8)*int(NCB,8) ENDIF CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + SIZEFRNOCBLU NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = & max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) 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 NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT_MISSING) NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (NFR.GT.MAXFR) MAXFR = NFR IF (NSTK.GT.0) THEN DO 70 K=1,NSTK LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK IF (K==1 .AND. INSSARBR.AND.KEEP(234).NE.0 & .AND.KEEP(55).EQ.0) THEN ELSE CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTK ENDIF LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in DMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF 70 CONTINUE ENDIF IF ( & ( (INODE.NE.KEEP(20)).OR.(KEEP(60).EQ.0) ) & .AND. & ( (INODE.NE.KEEP(38)).OR.(KEEP(60).LE.1) ) & ) & THEN ENTRIES_NODE_LOWER_PART = int(NFR-NELIM,8) * int(NELIM,8) IF ( KEEP(50).EQ.0 ) THEN ENTRIES_NODE_UPPER_PART = int(NFR,8) * int(NELIM,8) ELSE ENTRIES_NODE_UPPER_PART = & (int(NELIM,8)*int(NELIM+1,8))/2_8 ENDIF IF (KEEP(50).EQ.2 .AND. LEVEL.EQ.3) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM, 0, & 1,OPS_NODE) ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) ENDIF ELSE OPS_NODE = 0.0D0 ENTRIES_NODE_UPPER_PART = 0_8 ENTRIES_NODE_LOWER_PART = 0_8 ENDIF ENTRIES_IN_FACTORS_LOC_MASTERS = & ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC_MASTERS OPSA_LOC = OPSA_LOC + dble(OPS_NODE) IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) .OR. NE(STEP(INODE))==0) THEN OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ENDIF IF (IFATH .EQ. 0) THEN RETURN 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 LEVELF = MUMPS_TYPENODE(PROCNODE(STEP(IFATH)),KEEP(199)) MASTERF= MUMPS_PROCNODE(PROCNODE(STEP(IFATH)), & KEEP(199)).EQ.MYID IF ( INSSARBR .AND. KEEP(234).NE.0) THEN NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+SIZECB+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) ENDIF PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (KEEP(50).NE.0.AND.LEVELF.NE.3 & .AND.PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF SIZECBI = 2+ XSIZE_IC IF (STACKCB) THEN IF (FRERE(STEP(INODE)).EQ.0) THEN write(*,*) ' ERROR 3 in DMUMPS_ANA_DISTM' CALL MUMPS_ABORT() ENDIF ITOP = ITOP + 1 IF ( ITOP .GT. NSTEPS ) THEN WRITE(*,*) 'ERROR 4 in DMUMPS_ANA_DISTM ' CALL MUMPS_ABORT() 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) NIRNEC = max(NIRNEC,NIRADU+ISTKI) NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR) LSTKR_if_LRCB(ITOP) = SIZECB_if_LRCB ISTKR_if_LRCB = ISTKR_if_LRCB + LSTKR_if_LRCB(ITOP) LSTKRLR_CB_UD(ITOP) = SIZECBLR_UD ISTKRLR_CB_UD = ISTKRLR_CB_UD + LSTKRLR_CB_UD(ITOP) LSTKRLR_CB_WC(ITOP) = SIZECBLR_WC ISTKRLR_CB_WC = ISTKRLR_CB_WC + LSTKRLR_CB_WC(ITOP) NRLNECLR_CB_UD = max(NRLNECLR_CB_UD, ISTKRLR_CB_UD) NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) ENDIF ENDIF END SUBROUTINE DMUMPS_PROCESS_NODE_UNDERL0 END SUBROUTINE DMUMPS_ANA_DISTM_UNDERL0_1THR SUBROUTINE DMUMPS_PREP_ANA_DISTM_ABOVEL0 ( & N, SLAVEF, COMM, MYID, & STEP, DAD, ICNTL, LP, LPOK, INFO, & PHYS_L0_OMP, L_PHYS_L0_OMP, & IPOOL_A_L0_OMP, LPOOL_A_L0_OMP, & KEEP, TNSTK_afterL0, & FLAGGED_LEAVES & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, INTENT(IN) :: N, SLAVEF, COMM, MYID, ICNTL(60), & LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: L_PHYS_L0_OMP, LPOOL_A_L0_OMP INTEGER, INTENT(IN) :: PHYS_L0_OMP(max(1,L_PHYS_L0_OMP)), & IPOOL_A_L0_OMP(max(1,LPOOL_A_L0_OMP)) INTEGER, INTENT(IN) :: KEEP(500) INTEGER, INTENT(IN) :: STEP(N), DAD(KEEP(28)) INTEGER, INTENT(OUT) :: FLAGGED_LEAVES(KEEP(28)) INTEGER, INTENT(INOUT) :: TNSTK_afterL0(KEEP(28)), INFO(80) INTEGER :: ISLAVE, IERR, INODE, I, NSTEPS, allocok INTEGER :: SIZE_BUFREC, Itemp, SIZE_RECEIVED INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFREC INTEGER, ALLOCATABLE, DIMENSION(:) :: IREQ INTEGER :: MPI_STATUS(MPI_STATUS_SIZE) SIZE_BUFREC = 0 CALL MPI_ALLREDUCE(L_PHYS_L0_OMP, Itemp, 1, & MPI_INTEGER, MPI_MAX, COMM, IERR) SIZE_BUFREC = Itemp CALL MPI_ALLREDUCE(LPOOL_A_L0_OMP, Itemp, 1, & MPI_INTEGER, MPI_MAX, COMM, IERR) SIZE_BUFREC= max(SIZE_BUFREC, Itemp) ALLOCATE(IREQ(SLAVEF), BUFREC(SIZE_BUFREC), stat=allocok) IF (allocok.GT.0) THEN IF ( LPOK ) THEN WRITE(LP, '(A)') & ' Allocation failed in DMUMPS_PREP_ANA_DISTM_ABOVEL0' END IF INFO(1)= -7 INFO(2)= SLAVEF+SIZE_BUFREC ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) RETURN NSTEPS = KEEP(28) DO I=1, NSTEPS FLAGGED_LEAVES(I) = 0 ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_ISEND( IPOOL_A_L0_OMP, LPOOL_A_L0_OMP, & MPI_INTEGER, ISLAVE - 1, F_IPOOLAFTER, COMM, & IREQ( ISLAVE ), IERR ) ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_RECV( BUFREC(1), SIZE_BUFREC, & MPI_INTEGER, ISLAVE-1, & F_IPOOLAFTER, COMM, MPI_STATUS, IERR ) CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER, & SIZE_RECEIVED, IERR) DO I=1,SIZE_RECEIVED INODE = BUFREC(I) FLAGGED_LEAVES(STEP(INODE))=INODE ENDDO ENDDO IF (LPOOL_A_L0_OMP.GT.0) THEN DO I=1, LPOOL_A_L0_OMP INODE = IPOOL_A_L0_OMP(I) FLAGGED_LEAVES(STEP(INODE))=INODE ENDDO ENDIF DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_WAIT( IREQ( ISLAVE ), MPI_STATUS, IERR ) ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_ISEND(PHYS_L0_OMP, L_PHYS_L0_OMP, & MPI_INTEGER, ISLAVE - 1, F_PHYS_L0, COMM, & IREQ( ISLAVE ), IERR ) ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_RECV( BUFREC(1), SIZE_BUFREC, & MPI_INTEGER, ISLAVE-1, & F_PHYS_L0, COMM, MPI_STATUS, IERR ) CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER, & SIZE_RECEIVED, IERR) DO I=1,SIZE_RECEIVED INODE = BUFREC(I) IF (DAD(STEP(INODE)).NE.0) THEN TNSTK_afterL0(STEP(DAD(STEP(INODE)))) & = TNSTK_afterL0(STEP(DAD(STEP(INODE)))) - 1 ENDIF ENDDO ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_WAIT( IREQ( ISLAVE ), MPI_STATUS, IERR ) ENDDO IF (allocated(IREQ)) DEALLOCATE(IREQ) IF (allocated(BUFREC)) DEALLOCATE(BUFREC) RETURN END SUBROUTINE DMUMPS_PREP_ANA_DISTM_ABOVEL0 MUMPS_5.8.1/src/mumps_common.c0000664000175000017500000001010215042446422016077 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include #include "mumps_common.h" /* 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; static MUMPS_INT * MUMPS_GLOB2LOC_RHS; static MUMPS_INT * MUMPS_GLOB2LOC_SOL; MUMPS_INT* mumps_get_mapping() { return MUMPS_MAPPING; } void MUMPS_CALL MUMPS_ASSIGN_MAPPING(MUMPS_INT * f77mapping) { MUMPS_MAPPING = f77mapping; } void MUMPS_CALL MUMPS_NULLIFY_C_MAPPING() { MUMPS_MAPPING = 0; } MUMPS_INT* mumps_get_pivnul_list() { return MUMPS_PIVNUL_LIST; } void MUMPS_CALL MUMPS_ASSIGN_PIVNUL_LIST(MUMPS_INT * f77pivnul_list) { MUMPS_PIVNUL_LIST = f77pivnul_list; } void MUMPS_CALL MUMPS_NULLIFY_C_PIVNUL_LIST() { MUMPS_PIVNUL_LIST = 0; } MUMPS_INT* mumps_get_sym_perm() { return MUMPS_SYM_PERM; } void MUMPS_CALL MUMPS_ASSIGN_SYM_PERM(MUMPS_INT * f77sym_perm) { MUMPS_SYM_PERM = f77sym_perm; } void MUMPS_CALL MUMPS_NULLIFY_C_SYM_PERM() { MUMPS_SYM_PERM = 0; } MUMPS_INT* mumps_get_uns_perm() { return MUMPS_UNS_PERM; } void MUMPS_CALL MUMPS_ASSIGN_UNS_PERM(MUMPS_INT * f77uns_perm) { MUMPS_UNS_PERM = f77uns_perm; } void MUMPS_CALL MUMPS_NULLIFY_C_UNS_PERM() { MUMPS_UNS_PERM = 0; } MUMPS_INT* mumps_get_glob2loc_rhs() { return MUMPS_GLOB2LOC_RHS; } void MUMPS_CALL MUMPS_ASSIGN_GLOB2LOC_RHS(MUMPS_INT * f77glob2loc_rhs) { MUMPS_GLOB2LOC_RHS = f77glob2loc_rhs; } void MUMPS_CALL MUMPS_NULLIFY_C_GLOB2LOC_RHS() { MUMPS_GLOB2LOC_RHS = 0; } MUMPS_INT* mumps_get_glob2loc_sol() { return MUMPS_GLOB2LOC_SOL; } void MUMPS_CALL MUMPS_ASSIGN_GLOB2LOC_SOL(MUMPS_INT * f77glob2loc_sol) { MUMPS_GLOB2LOC_SOL = f77glob2loc_sol; } void MUMPS_CALL MUMPS_NULLIFY_C_GLOB2LOC_SOL() { MUMPS_GLOB2LOC_SOL = 0; } void MUMPS_CALL MUMPS_ICOPY_32TO64_64C_IP_C(MUMPS_INT *inouttab, MUMPS_INT8 *sizetab) /* Copies in-place *sizetab int values starting at address inouttab into *sizetab int64_t values starting at the same address. */ { MUMPS_INT8 i8; /* signed integer needed for reversed loop below */ for (i8=*sizetab-1; i8 >=0; i8--) { /* outtab8[i8]=(MUMPS_INT8)intab4[i8]; */ ((MUMPS_INT8 *)inouttab)[i8]=(MUMPS_INT8)inouttab[i8]; } } void MUMPS_CALL MUMPS_ICOPY_64TO32_64C_IP_C(MUMPS_INT8 *inouttab, MUMPS_INT8 *sizetab) /* Copies in-place *sizetab int64_t values starting at address inouttab into *sizetab int values starting at the same address */ { MUMPS_INT8 i8; for (i8=0; i8 < *sizetab; i8++) { /* outtab4[i8]=(MUMPS_INT)intab8[i8]; */ ((MUMPS_INT *)inouttab)[i8]=(MUMPS_INT)inouttab[i8]; } } void MUMPS_CALL MUMPS_MALLOC_C(MUMPS_INT8 *address, MUMPS_INT8 *size) { void * ptr; ptr=malloc(*size); *address=(MUMPS_INT8)(ptr); } void MUMPS_CALL MUMPS_FREE_C(void *address) { free(address); } void MUMPS_CALL MUMPS_RCOPY_32TO64_64C_IP_C(float *inouttab, MUMPS_INT8 *sizetab) /* Copies in-place *sizetab float values starting at address inouttab into *sizetab double values starting at the same address. */ { MUMPS_INT8 i8; /* signed integer needed for reversed loop below */ for (i8=*sizetab-1; i8 >=0; i8--) { ((double *)inouttab)[i8]=(double)inouttab[i8]; } } void MUMPS_CALL MUMPS_RCOPY_64TO32_64C_IP_C(double *inouttab, MUMPS_INT8 *sizetab) /* Copies in-place *sizetab double values starting at address inouttab into *sizetab float values starting at the same address */ { MUMPS_INT8 i8; for (i8=0; i8 < *sizetab; i8++) { /* outtab4[i8]=(MUMPS_INT)intab8[i8]; */ ((float *)inouttab)[i8]=(float)inouttab[i8]; } } MUMPS_5.8.1/src/sfac_front_LU_type2.F0000664000175000017500000011611015042446437017214 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC2_LU_M CONTAINS SUBROUTINE SMUMPS_FAC2_LU( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP,PIVNUL_LIST_STRUCT & , LRGROUPS & ) !$ USE OMP_LIB USE SMUMPS_FAC_FRONT_AUX_M USE SMUMPS_FAC_FRONT_TYPE2_AUX_M USE SMUMPS_OOC USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_TEST USE SMUMPS_FAC_LR USE SMUMPS_LR_CORE USE SMUMPS_LR_TYPE USE MUMPS_LR_STATS USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_DATA_M !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW INTEGER, intent(inout) :: NOFFW, NPVW, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW INTEGER(8) :: LA INTEGER IW( LIW ) REAL A( LA ) REAL UU, SEUIL TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) INTEGER NBFIN, SLAVEF, & IFLAG, IERROR, LEAF, LPOOL INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N), & PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL AVOID_DELAYED TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER :: IBEG_BLOCK_FOR_IPIV INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv LOGICAL LASTPANEL INTEGER(8) :: POSELT INTEGER IOLDPS, allocok, K263,J INTEGER idummy REAL UUTEMP LOGICAL STATICMODE REAL SEUIL_LOC INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER CURRENT_BLR, NELIM LOGICAL LR_ACTIVATED, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER :: IROW_L, NVSCHUR, NSLAVES INTEGER :: PIVOT_OPTION, LAST_COL, FIRST_COL INTEGER :: PARPIV_T1 INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER :: INFO_TMP(2) INTEGER :: MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR, END_I INTEGER MAXI_CLUSTER, LWORK TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_U, BLR_SEND REAL, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP, BEGS_BLR_STATIC INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, LorU, I, IP, MEM, & MEM_TOT INTEGER(8) :: POSELT_DIAG CHARACTER(len=1) :: DIR REAL, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) REAL, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER(8) :: UPOS, LPOS INTEGER :: MY_NUM LOGICAL :: SWAP_OCCURRED INCLUDE 'mumps_headers.h' NULLIFY(BLR_L,BLR_U) NULLIFY(PTDummy) NULLIFY(ACC_LUA) NULLIFY(BEGS_BLR) NULLIFY(BLR_L, BLR_U, BLR_SEND) NULLIFY(DIAG) NULLIFY(BLR_PANEL) NULLIFY( BEGS_BLR_TMP, BEGS_BLR_STATIC) IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF SWAP_OCCURRED = .FALSE. idummy = 0 IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) NASS = abs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) PARPIV_T1 = 0 INOPV = 0 SEUIL_LOC = SEUIL IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE UUTEMP=UU ENDIF CALL SMUMPS_SET_INNERBLOCKSIZE( NBKJIB_ORIG, NASS, KEEP) IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN NSLAVES = IW(IOLDPS+5+XSIZE) IROW_L = IOLDPS+6+XSIZE+NSLAVES+NASS CALL SMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IF (LR_ACTIVATED) THEN K263 = 1 ELSE K263 = KEEP(263) IF (K263 .NE. 0 .AND. NASS/NBLR_ORIG < 4) THEN IF ( NBLR_ORIG .GT. NBKJIB_ORIG * 4 ) THEN NBLR_ORIG = max(NBKJIB_ORIG, (NASS+3)/4) ELSE K263 = 0 ENDIF ENDIF ENDIF PIVOT_OPTION = KEEP(468) IF ( UUTEMP == 0.0E0 .AND. & .NOT.( & OOC_EFFECTIVE_ON_FRONT & ) & ) THEN IF (K263.EQ.1.AND.(.NOT.LR_ACTIVATED)) THEN PIVOT_OPTION = 0 ENDIF ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID,' : SMUMPS_FAC2_LU :failed to allocate ', & NASS, ' integers' IFLAG = -13 IERROR =NASS GO TO 500 END IF CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF ( OOC_EFFECTIVE_ON_FRONT ) THEN LNextPiv2beWritten = 1 UNextPiv2beWritten = 1 PP_FIRST2SWAP_L = LNextPiv2beWritten PP_FIRST2SWAP_U = UNextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%LastPanelWritten_U = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 2 MonBloc%NROW = NASS MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -68877 NULLIFY(MonBloc%INDICES) ENDIF IF (LR_ACTIVATED) THEN PIVOT_OPTION = 4 IF (KEEP(475).EQ.1) THEN PIVOT_OPTION = 3 ELSEIF (KEEP(475).EQ.2) THEN PIVOT_OPTION = 3 ELSEIF (KEEP(475).EQ.3) THEN IF (UUTEMP == 0.0E0) THEN PIVOT_OPTION = 0 ELSE PIVOT_OPTION = 1 ENDIF ENDIF CNT_NODES = CNT_NODES + 1 ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472), & NFRONT, KEEP(1)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) & ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL SMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 CALL SMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .TRUE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF LASTPANEL = .FALSE. DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = BEGS_BLR(CURRENT_BLR+1)-1 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 500 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (K263.EQ.0) THEN IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK ELSE IBEG_BLOCK_FOR_IPIV = IBEG_BLR ENDIF CALL SMUMPS_FAC_I(NFRONT,NASS,NASS, & IBEG_BLOCK_FOR_IPIV,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, & DKEEP(1), PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, & TIPIV=IPIV & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTPANEL = .TRUE. ELSE IF (INOPV .LE. 0) THEN INOPV = 0 IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL SMUMPS_FAC_MQ(IBEG_BLOCK, IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 NPVW = NPVW + 1 IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB .EQ. -1) THEN LASTPANEL = .TRUE. ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF (K263.EQ.0) THEN NELIM = IEND_BLR - NPIV CALL SMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, & NFRONT, IBEG_BLOCK, NPIV, IPIV,NASS,LASTPANEL,idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR, ICNTL,KEEP,KEEP8, & DKEEP,ND,FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, .FALSE. & , NPARTSASS, CURRENT_BLR & , BLR_DUMMY, LRGROUPS & ) END IF IF ( IFLAG .LT. 0 ) GOTO 500 IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_U, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN CALL MUMPS_BUF_TEST() IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL SMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, & NPIV, NFRONT, IEND_BLR, LAST_COL, & A, LA, POSELT, & -77777, & .TRUE., .FALSE., .TRUE., & .FALSE., & LR_ACTIVATED) ENDIF CALL MUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 500 ENDIF ALLOCATE(BLR_L(NPARTSASS-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSASS-CURRENT_BLR GOTO 500 ENDIF NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_U(J)%M=0 BLR_U(J)%N=0 BLR_U(J)%K=0 BLR_U(J)%ISLR=.FALSE. NULLIFY(BLR_U(J)%Q) NULLIFY(BLR_U(J)%R) ENDDO CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) DO J=1,NPARTSASS-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF GOTO 101 ENDIF END_I=NB_BLR #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), & KEEP(458), KEEP(473), BLR_U, & CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, 2, KEEP(483), KEEP8, & END_I_IN=END_I & ) IF (IFLAG.LT.0) GOTO 300 IF ((KEEP(480).NE.0.AND.NB_BLR.GT.CURRENT_BLR) & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (PIVOT_OPTION.LT.3) THEN IF (PIVOT_OPTION.LT.2) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF LAST_BLOCK=NB_BLR CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_U, CURRENT_BLR, & FIRST_BLOCK, LAST_BLOCK, 2, 0, 1, & .FALSE.) ENDIF 300 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif ENDIF 101 CONTINUE IF (LR_ACTIVATED .OR. (K263.NE.0.AND.PIVOT_OPTION.GE.3)) THEN NELIM = IEND_BLR - NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_U)) THEN BLR_SEND=>BLR_U ENDIF CALL SMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, NFRONT, & IBEG_BLR, NPIV, IPIV, NASS,LASTPANEL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR & , BLR_SEND, LRGROUPS & ) ENDIF IF (.NOT. LR_ACTIVATED) THEN LAST_COL = NFRONT IF (PIVOT_OPTION.EQ.2) THEN FIRST_COL = NASS ELSE FIRST_COL = NPIV ENDIF IF (IEND_BLR.LT.NASS .OR. PIVOT_OPTION.LT.3) THEN CALL SMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, LAST_COL, & A, LA, POSELT, FIRST_COL, .TRUE., (PIVOT_OPTION.LT.3), & .TRUE., (KEEP(377).EQ.1), & LR_ACTIVATED) ENDIF IF (K263.NE.0 .AND. PIVOT_OPTION.LT.3) THEN NELIM = IEND_BLR - NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_U)) THEN BLR_SEND=>BLR_U ENDIF CALL SMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, & NFRONT, IBEG_BLR, NPIV, IPIV, NASS,LASTPANEL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR & , BLR_SEND, LRGROUPS & ) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL SMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8 & ) IF (IFLAG.LT.0) GOTO 600 CALL SMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8, & END_I_IN=END_I & ) 600 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF ENDIF GOTO 100 ENDIF IF (KEEP(475).EQ.0) THEN IF (IEND_BLR.LT.NFRONT) THEN CALL SMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & -77777, & A, LA, POSELT, & -77777, & .TRUE., .FALSE., .FALSE., & .FALSE., & LR_ACTIVATED) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(UPOS,LPOS,FIRST_BLOCK,LAST_BLOCK) #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NPARTSASS, DKEEP(8), KEEP(466), & KEEP(458), KEEP(473), & BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8 & ) #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF ((KEEP(480).NE.0.AND.NB_BLR.GT.CURRENT_BLR) & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(475).GT.0) THEN CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NPARTSASS, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NPARTSASS, 2, 0, 0, .FALSE.) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF IF (KEEP(480).GE.2) THEN UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) LPOS = POSELT+int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) CALL SMUMPS_BLR_UPD_NELIM_VAR_L(A, LA, UPOS, A, LA, LPOS, & IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NPARTSASS, & CURRENT_BLR+1, NELIM, 'N') IF (IFLAG.LT.0) GOTO 444 IF (IEND_BLR.LT.NASS) THEN CALL SMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8 & ) IF (IFLAG.LT.0) GOTO 442 CALL SMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8, & END_I_IN=END_I & ) 442 CONTINUE ENDIF 444 CONTINUE ELSE CALL SMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, BLR_L, NPARTSASS, & BLR_U, NB_BLR, NELIM, .FALSE., 0, & 2, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(475).GT.0) THEN FIRST_BLOCK = CURRENT_BLR+1 IF (KEEP(486).EQ.2.AND.UU.EQ.0) THEN LAST_BLOCK = CURRENT_BLR ELSE LAST_BLOCK = NPARTSASS ENDIF CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NPARTSASS, BLR_L, CURRENT_BLR, 'V', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) #if ! defined(BLR_NOOPENMP) #endif ENDIF IF (KEEP(475).GE.2) THEN IF (KEEP(475).EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF IF (KEEP(486).NE.2) THEN LAST_BLOCK = END_I ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_U, CURRENT_BLR, 'H', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0.OR.NB_BLR.EQ.CURRENT_BLR) THEN CALL DEALLOC_BLR_PANEL(BLR_U, NB_BLR-CURRENT_BLR, & KEEP8, KEEP(34)) CALL DEALLOC_BLR_PANEL(BLR_L, NPARTSASS-CURRENT_BLR, & KEEP8, KEEP(34)) DEALLOCATE(BLR_U,BLR_L) ENDIF ENDIF NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_TRY_WRITE MonBloc%LastPiv = NPIV LAST_CALL= .FALSE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO IP=1,NB_BLR+1 BEGS_BLR_TMP(IP) = BEGS_BLR_STATIC(IP) ENDDO ENDIF ENDIF IF ( & (KEEP(486).EQ.2) & ) THEN MEM_TOT = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP& PRIVATE(IP, LorU, DIR, NELIM) #endif #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*(2*DIAGSIZ_STA-DIAGSIZ_DYN) MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA IF (I.LE.DIAGSIZ_DYN) THEN DIAG(DPOS:DPOS+DIAGSIZ_STA-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_STA-1,8)) DPOS = DPOS + DIAGSIZ_STA ELSE DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN ENDIF POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL SMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG, KEEP(34)) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO !$OMP SINGLE #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM_TOT,8), & .FALSE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 460 IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN DO IP=1,NPARTSASS NELIM = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) DO LorU=0,1 #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8, & KEEP(34)) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (LorU.EQ.0) THEN DIR = 'V' ELSE DIR = 'H' ENDIF CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(458), KEEP(473), & BLR_PANEL, IP, & DIR, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 440 ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif 440 CONTINUE ENDIF 460 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN deallocate(BEGS_BLR_TMP) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 500 IF ( & (KEEP(486).EQ.2) & ) THEN CALL SMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (IFLAG.GE.0) THEN CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 0, NELIM) DO IP=1,NPARTSASS CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NPARTSASS-IP & ) CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 1, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NB_BLR-IP & ) ENDDO CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NASS-NELIM, 0, 2) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 0, 2) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 500 IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF CALL SMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 700 480 CONTINUE 500 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 700 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL SMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 2, & KEEP8, KEEP(34)) ENDIF ENDIF IF ( LR_ACTIVATED .AND. KEEP(486).EQ. 2 .AND. & KEEP(251) .EQ. 2) THEN CALL SMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8, KEEP(34)) ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL SMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34)) ENDIF ENDIF DEALLOCATE( IPIV ) RETURN END SUBROUTINE SMUMPS_FAC2_LU END MODULE SMUMPS_FAC2_LU_M MUMPS_5.8.1/src/dbcast_int.F0000664000175000017500000000314015042446437015455 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_MCAST2(DATA, LDATA, MPITYPE, ROOT, COMMW, TAG, &SLAVEF, KEEP) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER LDATA, ROOT, COMMW, TAG, MPITYPE, SLAVEF INTEGER DEST INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER DATA(LDATA) DO 10 DEST = 0, SLAVEF - 1 IF (DEST .NE. ROOT) THEN IF ( LDATA .EQ. 1 .and. MPITYPE .EQ. MPI_INTEGER ) THEN CALL MUMPS_BUF_SEND_1INT( DATA(1), DEST, TAG, & COMMW, KEEP, IERR ) ELSE WRITE(*,*) 'Error : bad argument to DMUMPS_MCAST2' CALL MUMPS_ABORT() END IF ENDIF 10 CONTINUE RETURN END SUBROUTINE DMUMPS_MCAST2 SUBROUTINE DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) INTEGER MYID, SLAVEF, COMM INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY (1) DUMMY(1) = -98765 CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERREUR, SLAVEF, KEEP ) RETURN END SUBROUTINE DMUMPS_BDC_ERROR MUMPS_5.8.1/src/sfac_lastrtnelind.F0000664000175000017500000002070215042446437017045 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, & root, roota, FRERE, IROOT, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_ROOT2SLAVE, & MUMPS_BUF_SEND_ROOT2SON USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER IROOT INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC,IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER(8) :: LA INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND(KEEP(28)), FRERE(KEEP(28)) REAL DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER I, NELIM, NB_CONTRI_GLOBAL, NUMORG, & NFRONT, IROW, JCOL, PDEST, HF, IOLDPS, & IN, DEB_ROW, ILOC_ROW, IFSON, ILOC_COL, & IPOS_SON, NELIM_SON, NSLAVES_SON, HS, & IROW_SON, ICOL_SON, ISLAVE, IERR, & NELIM_SENT, IPOS_STATREC, TYPE_SON INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' NB_CONTRI_GLOBAL = KEEP(41) NUMORG = root%ROOT_SIZE NELIM = KEEP(42) NFRONT = NUMORG + KEEP(42) DO IROW = 0, root%NPROW - 1 DO JCOL = 0, root%NPCOL - 1 PDEST = IROW * root%NPCOL + JCOL IF ( PDEST .NE. MYID ) THEN CALL MUMPS_BUF_SEND_ROOT2SLAVE(NFRONT, & NB_CONTRI_GLOBAL, PDEST, COMM, KEEP, IERR) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'MUMPS_BUF_SEND_ROOT2SLAVE' CALL MUMPS_ABORT() endif ENDIF END DO END DO CALL SMUMPS_PROCESS_ROOT2SLAVE( NFRONT, & NB_CONTRI_GLOBAL, root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND ) IF (IFLAG < 0 ) RETURN HF = 6 + KEEP(IXSZ) IOLDPS = PTLUST_S(STEP(IROOT)) IN = IROOT DEB_ROW = IOLDPS + HF ILOC_ROW = DEB_ROW DO WHILE (IN.GT.0) IW(ILOC_ROW) = IN IW(ILOC_ROW+NFRONT) = IN ILOC_ROW = ILOC_ROW + 1 IN = FILS(IN) END DO IFSON = -IN ILOC_ROW = IOLDPS + HF + NUMORG ILOC_COL = ILOC_ROW + NFRONT IF ( NELIM.GT.0 ) THEN IN = IFSON DO WHILE (IN.GT.0) IPOS_SON = PIMASTER(STEP(IN)) IF (IPOS_SON .EQ. 0) GOTO 100 NELIM_SON = IW(IPOS_SON+1+KEEP(IXSZ)) if (NELIM_SON.eq.0) then write(6,*) ' error 1 in process_last_rtnelind' CALL MUMPS_ABORT() endif NSLAVES_SON = IW(IPOS_SON+5+KEEP(IXSZ)) HS = 6 + NSLAVES_SON + KEEP(IXSZ) IROW_SON = IPOS_SON + HS ICOL_SON = IROW_SON + NELIM_SON DO I = 1, NELIM_SON IW( ILOC_ROW+I-1 ) = IW( IROW_SON+I-1 ) ENDDO DO I = 1, NELIM_SON IW( ILOC_COL+I-1 ) = IW( ICOL_SON+I-1 ) ENDDO NELIM_SENT = ILOC_ROW - IOLDPS - HF + 1 DO ISLAVE = 0,NSLAVES_SON IF (ISLAVE.EQ.0) THEN PDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)),KEEP(199)) ELSE PDEST = IW(IPOS_SON + 5 + ISLAVE+KEEP(IXSZ)) ENDIF IF (PDEST.NE.MYID) THEN CALL MUMPS_BUF_SEND_ROOT2SON(IN, NELIM_SENT, & PDEST, COMM, KEEP, IERR ) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'MUMPS_BUF_SEND_ROOT2SON' CALL MUMPS_ABORT() endif ELSE CALL SMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & IN, NELIM_SENT, root, roota, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( ISLAVE .NE. 0 ) THEN IF (KEEP(50) .EQ. 0) THEN IPOS_STATREC = PTRIST(STEP(IN))+6+KEEP(IXSZ) ELSE IPOS_STATREC = PTRIST(STEP(IN))+8+KEEP(IXSZ) ENDIF IF (IW(IPOS_STATREC).EQ. S_REC_CONTSTATIC) THEN IW(IPOS_STATREC) = S_ROOT2SON_CALLED ELSE IF (NSLAVES_SON .EQ. 0) THEN TYPE_SON = 1 ELSE TYPE_SON = 2 ENDIF CALL SMUMPS_FREE_BAND( N, IN, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON & ) ENDIF ENDIF IPOS_SON = PIMASTER(STEP(IN)) ENDIF END DO CALL SMUMPS_FREE_BLOCK_CB_STATIC( & .FALSE., MYID, N, IPOS_SON, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) ILOC_ROW = ILOC_ROW + NELIM_SON ILOC_COL = ILOC_COL + NELIM_SON 100 CONTINUE IN = FRERE(STEP(IN)) ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_LAST_RTNELIND MUMPS_5.8.1/src/cfac_par_m.F0000664000175000017500000015262415042446440015423 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC_PAR_M CONTAINS SUBROUTINE CMUMPS_FAC_PAR(N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NULLNEGPV, NB22T1, NB22T2, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & PTRIST, PTRAST, PIMASTER, PAMASTER, PTRARW, PTRAIW, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & MUMPS_TPS_ARR, CMUMPS_TPS_ARR, LTPS_ARR, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & NBROOT_UNDER_L0, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8, PROCNODE_STEPS, & SLAVEF,MYID, COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & INTARR, DBLARR, root, roota, PERM, NELT, FRTPTR, FRTELT, LPTRAR, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, & DKEEP, PIVNUL_LIST_STRUCT, LRGROUPS ) !$ USE OMP_LIB USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : & CMUMPS_DM_FREEALLDYNAMICCB USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_TEST USE MUMPS_LOAD USE CMUMPS_OOC, ONLY: CMUMPS_OOC_CLEAN_PENDING, & IO_BLOCK, & CMUMPS_OOC_FORCE_WRT_BUF_PANEL, & CMUMPS_NEW_FACTOR, & CMUMPS_OOC_IO_LU_PANEL, & CMUMPS_FORCE_WRITE_BUF USE MUMPS_OOC_COMMON, ONLY: TYPEF_L, STRAT_WRITE_MAX USE CMUMPS_FAC_ASM_MASTER_M USE CMUMPS_FAC_ASM_MASTER_ELT_M USE CMUMPS_FAC1_LDLT_M USE CMUMPS_FAC2_LDLT_M USE CMUMPS_FAC1_LU_M USE CMUMPS_FAC2_LU_M USE OMP_LIB USE MUMPS_TPS_M USE CMUMPS_TPS_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC USE MUMPS_PIVNUL_MOD IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80) DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI INTEGER, INTENT(INOUT) :: NELVA, COMP INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV, & NULLNEGPV INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP COMPLEX, INTENT(INOUT) :: DET_MANT INTEGER(8) :: LA COMPLEX, TARGET :: A(LA) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER LPOOL INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER IW(LIW), NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST(KEEP(28)), PERM(N) INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IPOOL(LPOOL) INTEGER NE(KEEP(28)) REAL RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU INTEGER IWPOS, LEAF, NBROOT, NBRTOT INTEGER, INTENT(in) :: NBROOT_UNDER_L0 INTEGER COMM_LOAD, ASS_IRECV REAL UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) COMPLEX DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) LOGICAL IS_ISOLATED_NODE TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER LRGROUPS(KEEP(280)) INTEGER, INTENT( IN ) :: LTPS_ARR TYPE (MUMPS_TPS_T), TARGET :: MUMPS_TPS_ARR( LTPS_ARR ) TYPE (CMUMPS_TPS_T), TARGET :: CMUMPS_TPS_ARR( LTPS_ARR ) INTEGER, INTENT( IN ) :: LL0_OMP_MAPPING INTEGER, INTENT( IN ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 INTEGER INODE INTEGER IWPOSCB INTEGER FPERE, TYPEF INTEGER MP, LP, DUMMY(1) INTEGER NBFIN, NBROOT_TRAITEES INTEGER NFRONT, IOLDPS 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 !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 INTEGER LIWK_RR, PHASE, MBLOCK, NBLOCK INTEGER(8) :: LWK_RR INTEGER(8) :: I8 INTEGER I, K, KEEP17_LU INTEGER NOFFNEGPV_ROOT, NTOTPV_ROOT, NB22T1_ROOT, NBTINY_ROOT, & NULLNEGPV_ROOT, & DET_EXP_ROOT, DET_SIGN_ROOT, & LRecord, Header_ROOT(5) COMPLEX DET_MANT_ROOT REAL DKEEP_SAVE(230) COMPLEX, DIMENSION(:), POINTER :: A_ROOT_SAVE LOGICAL :: IS_A_ROOT_SAVE_ALLOCATED INTEGER, DIMENSION(:), ALLOCATABLE :: RECORD_ROOT INTEGER KEEP_SAVE(500) INTEGER(8) KEEP8_SAVE(150) EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE LOGICAL MUMPS_INSSARBR EXTERNAL MUMPS_INSSARBR LOGICAL CMUMPS_POOL_EMPTY EXTERNAL CMUMPS_POOL_EMPTY, CMUMPS_EXTRACT_POOL LOGICAL STACK_RIGHT_AUTHORIZED INTEGER, EXTERNAL :: MUMPS_NUMROC INTEGER JOBASS, ETATASS INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY INTEGER(8) :: ITMP8 TYPE(IO_BLOCK) :: MonBloc INCLUDE 'mumps_headers.h' INTEGER MPA DOUBLE PRECISION OPLAST_PRINTED DOUBLE PRECISION :: ROOTTIME INTEGER:: ITH DOUBLE PRECISION :: DUMMY_FLOP_ESTIM_ACC DUMMY_FLOP_ESTIM_ACC = 0.0d0 ITLOC(1:N+KEEP(253)) =0 ASS_IRECV = MPI_REQUEST_NULL MP = ICNTL(2) LP = ICNTL(1) IWPOSCB = LIW NULLIFY(BUFRX) IS_BUFRX_ALLOCATED = .FALSE. KEEP(143) = -1 KEEP17_LU = -1 NULLIFY(A_ROOT_SAVE) IS_A_ROOT_SAVE_ALLOCATED = .FALSE. IF ( INFO(1) .LT. 0 ) THEN GOTO 640 ENDIF OPLAST_PRINTED = DONE MPA = ICNTL(2) IF (ICNTL(4).LT.2) MPA=0 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) CALL CMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) STACK_RIGHT_AUTHORIZED = .TRUE. CALL CMUMPS_ALLOC_CB( .FALSE., 0_8, & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, DKEEP, & IW, LIW, A, LA, LRLU, IPTRLU, IWPOS, IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, LRLUS, KEEP8(67), & INFO(1), INFO(2) & ) JOBASS = 0 ETATASS = 0 NBFIN = NBRTOT NBROOT_TRAITEES = 0 KEEP(121)=0 IF ( KEEP(38).NE.0 ) THEN IF (root%yes) THEN CALL CMUMPS_ROOT_ALLOC_STATIC( & root, roota, KEEP(38), N, IW, LIW, & A, LA, & FILS, DAD, MYID_NODES, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, INFO(1), KEEP,KEEP8, DKEEP, INFO(2) ) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 635 END IF IF (KEEP(400).GT.0) THEN NBROOT_TRAITEES = NBROOT_UNDER_L0 IF (NBROOT_TRAITEES .GT.0) THEN IF (NBROOT_TRAITEES.EQ.NBROOT) THEN NBFIN = NBFIN - NBROOT IF (SLAVEF .GT. 1) THEN CALL CMUMPS_MCAST2( NBROOT, 1, MPI_INTEGER, & MYID_NODES, COMM_NODES, RACINE, SLAVEF, KEEP ) ENDIF ENDIF ENDIF IF (NBFIN .EQ. 0) GOTO 640 ENDIF KEEP(429)=0 20 CONTINUE CALL CMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 635 NIV1_FLAG=0 SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .FALSE. IF ( SLAVEF .GT. 1 ) THEN CALL CMUMPS_TRY_RECVTREAT( & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, & MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, & COMP, INFO(1), INFO(2), COMM_NODES, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, & root, roota, OPASS, OPELI, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED & , LRGROUPS & ) CALL MUMPS_LOAD_RECV_MSGS(COMM_LOAD) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (MESSAGE_RECEIVED) THEN IF ( INFO(1) .LT. 0 ) GO TO 640 IF ( NBFIN .eq. 0 ) GOTO 640 ELSE IF ( .NOT. CMUMPS_POOL_EMPTY( IPOOL, LPOOL) )THEN CALL CMUMPS_EXTRACT_POOL( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, STEP, INODE, KEEP,KEEP8, MYID_NODES, ND, & (.NOT. STACK_RIGHT_AUTHORIZED) ) STACK_RIGHT_AUTHORIZED = .TRUE. IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF IF (KEEP(47).EQ.4) THEN IF(INODE.GT.0.AND.INODE.LE.N)THEN IF((NE(STEP(INODE)).EQ.0).AND. & (FRERE(STEP(INODE)).EQ.0))THEN IS_ISOLATED_NODE=.TRUE. ELSE IS_ISOLATED_NODE=.FALSE. ENDIF ENDIF CALL MUMPS_LOAD_SBTR_UPD_NEW_POOL( & IS_ISOLATED_NODE,INODE,IPOOL,LPOOL, & MYID_NODES,SLAVEF,COMM_LOAD,KEEP,KEEP8) ENDIF IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. & ( KEEP(47) == 4 )).OR. & (KEEP(80) == 1 .AND. KEEP(47) .GE. 1)) THEN CALL MUMPS_UPPER_PREDICT(INODE,STEP,KEEP(28), & PROCNODE_STEPS,FRERE,ND,COMM_LOAD,SLAVEF, & MYID_NODES,KEEP,KEEP8,N) END IF GOTO 30 ELSE CALL MUMPS_BUF_TEST() ENDIF ENDIF GO TO 20 30 CONTINUE IF ( INODE .LT. 0 ) THEN INODE = -INODE FPERE = DAD(STEP(INODE)) GOTO 130 ELSE IF (INODE.GT.N) THEN INODE = INODE - N IF (INODE.EQ.KEEP(38)) THEN NBROOT_TRAITEES = NBROOT_TRAITEES + 1 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN NBFIN = NBFIN - NBROOT IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL CMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID_NODES, & COMM_NODES, RACINE, SLAVEF, KEEP ) END IF ENDIF IF (NBFIN.EQ.0) GOTO 640 GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (TYPE.EQ.1) GOTO 100 FPERE = DAD(STEP(INODE)) AVOID_DELAYED = ( (FPERE .eq. KEEP(20) .OR. FPERE .eq. KEEP(38)) & .AND. KEEP(60).ne.0 ) IF ( KEEP(50) .eq. 0 ) THEN CALL CMUMPS_FAC2_LU( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, & NOFFNEGPV, NTOTPV, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, & NBFIN,LEAF, INFO(1), INFO(2), IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_STEPS,PERM,PROCNODE_STEPS, & root, roota, OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & 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_STRUCT & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) ELSE CALL CMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, & NOFFNEGPV, NULLNEGPV, NTOTPV, & NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, & NBFIN,LEAF, INFO(1), INFO(2), IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_STEPS,PERM,PROCNODE_STEPS, & root, roota, OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & 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_STRUCT & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF ( IW( PTLUST(STEP(INODE)) + KEEP(IXSZ) + 5 ) .GT. 1 ) THEN GOTO 20 END IF END IF GOTO 130 ENDIF IF (INODE.EQ.KEEP(38)) THEN CALL CMUMPS_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, & root, roota, FRERE, & INODE, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, COMP, & INFO(1), INFO(2), COMM_NODES, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID_NODES, SLAVEF, & & OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP, ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (TYPE.EQ.1) THEN IF (KEEP(55).NE.0) THEN CALL CMUMPS_FAC_ASM_NIV1_ELT( COMM_LOAD, ASS_IRECV, & UU, NELT, FRTPTR, FRTELT, & N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,roota,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP, & INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS,PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & , MUMPS_TPS_ARR, CMUMPS_TPS_ARR, & L0_OMP_MAPPING & ) ELSE JOBASS = 0 CALL CMUMPS_FAC_ASM_NIV1(COMM_LOAD, ASS_IRECV, & UU, N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,roota,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP, INTARR,KEEP8(27), & DBLARR,KEEP8(26), & NSTK_STEPS,PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, JOBASS,ETATASS & , LRGROUPS & , MUMPS_TPS_ARR, CMUMPS_TPS_ARR, & L0_OMP_MAPPING & ) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF ( INFO(1) .LT. 0 ) GOTO 640 IF ((IW(PTLUST(STEP(INODE))+XXNBPR).GT.0).OR.(SON_LEVEL2)) THEN GOTO 20 ENDIF ELSE IF ( KEEP(55) .eq. 0 ) THEN CALL CMUMPS_FAC_ASM_NIV2(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, & INFO(1), & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, & root, roota, OPASS, OPELI, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) ELSE CALL CMUMPS_FAC_ASM_NIV2_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, INFO(1), & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, & root, roota, OPASS, OPELI, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) END IF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 640 GOTO 20 ENDIF 100 CONTINUE FPERE = DAD(STEP(INODE)) IF ( INODE .eq. KEEP(20) ) THEN POSELT = PTRAST(STEP(INODE)) IF (PTRFAC(STEP(INODE)).NE.POSELT) THEN WRITE(*,*) "ERROR 2 in CMUMPS_FAC_PAR", POSELT GOTO 635 ENDIF IF (KEEP(118).GE.40) THEN IOLDPS = PTLUST(STEP(INODE)) LRecord = IW(IOLDPS+XXI) IF (allocated(RECORD_ROOT)) DEALLOCATE(RECORD_ROOT) ALLOCATE(RECORD_ROOT(LRecord), stat=IERR) IF (IERR.GT.0) THEN INFO(1)= -13 INFO(2)= LRecord IF (LP > 0) & write(LP,*) "ERROR allocate RECORD_ROOT" GOTO 635 ENDIF RECORD_ROOT(1:LRecord) = IW(IOLDPS:IOLDPS+LRecord-1) ENDIF CALL CMUMPS_CHANGE_HEADER & ( IW(PTLUST(STEP(INODE))+KEEP(IXSZ)), KEEP(253) ) IF (KEEP(118).GE.40) THEN Header_ROOT(1:5) = IW(PTLUST(STEP(INODE))+KEEP(IXSZ): & PTLUST(STEP(INODE))+KEEP(IXSZ)+4) ENDIF GOTO 200 END IF POSELT = PTRAST(STEP(INODE)) IOLDPS = PTLUST(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_FAC1_LU ( & N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFNEGPV, NTOTPV, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & KEEP,KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) GOTO 635 ELSE IW( IOLDPS+4+KEEP(IXSZ) ) = 1 CALL CMUMPS_FAC1_LDLT( N, INODE, & IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFNEGPV, NULLNEGPV, NTOTPV, & NB22T1, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, & ETATASS, & DKEEP(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) GOTO 635 IW( IOLDPS+4+KEEP(IXSZ) ) = STEP(INODE) ENDIF JOBASS = ETATASS IF (JOBASS.EQ.1) THEN CALL CMUMPS_FAC_ASM_NIV1(COMM_LOAD, ASS_IRECV, & UU, N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,roota,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, & PTRARW,PTRAIW,PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & JOBASS,ETATASS & , LRGROUPS & ) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 635 130 CONTINUE TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF ( FPERE .NE. 0 ) THEN TYPEF = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(FPERE)),KEEP(199)) ELSE TYPEF = -9999 END IF CALL CMUMPS_FAC_STACK( COMM_LOAD, ASS_IRECV, & N,INODE,TYPE,TYPEF,LA,IW,LIW,A, & INFO(1),INFO(2),OPELI,NELVA,NMAXNPIV, & PTRIST,PTLUST,PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NE, POSFAC,LRLU, LRLUS,KEEP8(67), & IPTRLU,ICNTL,KEEP,KEEP8,DKEEP,COMP,IWPOS,IWPOSCB, & PROCNODE_STEPS,SLAVEF,FPERE,COMM_NODES,MYID_NODES, & IPOOL, LPOOL, LEAF, & NSTK_STEPS, PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, & root, roota, & OPASS, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ,DUMMY_FLOP_ESTIM_ACC & ) IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 640 200 CONTINUE IF ( INODE .eq. KEEP(38) ) THEN WRITE(*,*) 'Error .. in CMUMPS_FAC_PAR: ', & ' INODE == KEEP(38)' CALL MUMPS_ABORT() END IF IF ( FPERE.EQ.0 ) THEN NBROOT_TRAITEES = NBROOT_TRAITEES + 1 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN IF (KEEP(201).EQ.1) THEN CALL CMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF ( KEEP(201).EQ.2) THEN CALL CMUMPS_FORCE_WRITE_BUF(IERR) ENDIF NBFIN = NBFIN - NBROOT IF ( NBFIN .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in CMUMPS_FAC_PAR: ', & ' NBFIN=', NBFIN CALL MUMPS_ABORT() END IF IF ( NBROOT .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in CMUMPS_FAC_PAR: ', & ' NBROOT=', NBROOT CALL MUMPS_ABORT() END IF IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL CMUMPS_MCAST2( DUMMY(1), 1, MPI_INTEGER, & MYID_NODES, COMM_NODES, RACINE, SLAVEF, KEEP ) END IF ENDIF IF (NBFIN.EQ.0)THEN GOTO 640 ENDIF ELSEIF ( FPERE.NE.KEEP(38) .AND. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID_NODES ) THEN NSTK_STEPS(STEP(FPERE)) = NSTK_STEPS(STEP(FPERE))-1 IF ( NSTK_STEPS( STEP( FPERE )).EQ.0) THEN IF (KEEP(234).NE.0 .AND. & MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199))) & THEN STACK_RIGHT_AUTHORIZED = .FALSE. ENDIF CALL CMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( FPERE, N, PROCNODE_STEPS,KEEP(199), & ND, FILS, FRERE, STEP, PIMASTER, KEEP(28), & KEEP(50), KEEP(253), FLOP1, & IW, LIW, KEEP(IXSZ) ) IF (FPERE.NE.KEEP(20)) & CALL MUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ENDIF GO TO 20 635 CONTINUE IF (allocated(RECORD_ROOT)) DEALLOCATE(RECORD_ROOT) CALL CMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP ) 640 CONTINUE CALL CMUMPS_CANCEL_IRECV( INFO(1), & KEEP, & ASS_IRECV, BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, & MYID_NODES, SLAVEF) CALL MUMPS_CLEAN_PENDING( INFO(1), KEEP, & BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, & .TRUE., & .TRUE.) CALL MPI_BARRIER( COMM_NODES, IERR ) IF (INFO(1) .LT. 0) THEN CALL CMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & .FALSE. ) IF ( KEEP(400) .GT. 0 & ) THEN !$OMP PARALLEL DO SCHEDULE(STATIC,1) DO ITH = 1, KEEP(400) IF (associated(MUMPS_TPS_ARR(ITH)%IW)) THEN CALL CMUMPS_DM_FREEALLDYNAMICCB_I( MYID, N, SLAVEF, & KEEP, KEEP8, & MUMPS_TPS_ARR(ITH)%IW(1), MUMPS_TPS_ARR(ITH)%LIW, & MUMPS_TPS_ARR(ITH)%IWPOSCB, MUMPS_TPS_ARR(ITH)%IWPOS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & .TRUE. ) ENDIF ENDDO !$OMP END PARALLEL DO ENDIF ENDIF IF ( INFO(1) .GE. 0 ) THEN IF( KEEP(38) .NE. 0 .OR. KEEP(20).NE.0) THEN CALL MUMPS_SECDEB(ROOTTIME) MASTER_ROOT = MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(max(KEEP(38),KEEP(20)))), & KEEP(199)) ROOT_OWNER = (MASTER_ROOT .EQ. MYID_NODES) IF ( KEEP(38) .NE. 0 ) THEN IF (KEEP(60).EQ.0) THEN IOLDPS = PTLUST(STEP(KEEP(38))) LOCAL_M = IW(IOLDPS+2+KEEP(IXSZ)) LOCAL_N = IW(IOLDPS+1+KEEP(IXSZ)) ELSE IOLDPS = -999 LOCAL_M = root%SCHUR_MLOC LOCAL_N = root%SCHUR_NLOC ENDIF ITMP8 = int(LOCAL_M,8)*int(LOCAL_N,8) LBUFRX = min(int(root%MBLOCK,8)*int(root%NBLOCK,8), & int(root%TOT_ROOT_SIZE,8)*int(root%TOT_ROOT_SIZE,8) ) IS_BUFRX_ALLOCATED = .FALSE. IF ( LRLU .GT. LBUFRX ) THEN BUFRX => A(POSFAC:POSFAC+LRLU-1_8) LBUFRX=LRLU ELSE ALLOCATE( BUFRX( LBUFRX ), stat = IERR ) IF (IERR.gt.0) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR(LBUFRX, INFO(2) ) IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before CMUMPS_FACTO_ROOT', LBUFRX ELSE IS_BUFRX_ALLOCATED = .TRUE. ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL, INFO, & COMM_NODES, MYID_NODES ) IF (INFO(1).GE.0) THEN CALL CMUMPS_FACTO_ROOT( & MPA, MYID_NODES, MASTER_ROOT, & root, roota, N, KEEP(38), & COMM_NODES, IW, LIW, IWPOS + 1, & A, LA, PTRAST, PTLUST, PTRFAC, STEP, & INFO(1), KEEP(50), KEEP(19), & BUFRX(1), LBUFRX, KEEP,KEEP8, DKEEP, & OPELI, DET_EXP, DET_MANT, DET_SIGN ) CALL CMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IS_BUFRX_ALLOCATED = .FALSE. CALL MUMPS_PROPINFO( ICNTL, INFO, & COMM_NODES, MYID_NODES ) ENDIF IF ( MYID_NODES .eq. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))), & KEEP(199)) & ) THEN IF ( INFO(1) .EQ. -10 .OR. INFO(1) .EQ. -40 ) THEN NTOTPV = NTOTPV + INFO(2) ELSE IF ( INFO(1) .GE. 0 ) THEN NTOTPV = NTOTPV + root%TOT_ROOT_SIZE NMAXNPIV = max(NMAXNPIV,root%TOT_ROOT_SIZE) END IF END IF IF (INFO(1).GE.0.AND.KEEP(60).EQ.0) THEN IF (root%yes) THEN IF (KEEP(252).EQ.0) THEN IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_L NextPiv2beWritten = 1 MonBloc%INODE = KEEP(38) MonBloc%MASTER = .TRUE. MonBloc%Typenode = 3 MonBloc%NROW = LOCAL_M MonBloc%NCOL = LOCAL_N MonBloc%NFS = MonBloc%NCOL MonBloc%Last = .TRUE. MonBloc%LastPiv = MonBloc%NCOL MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. LAST_CALL = .TRUE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(PTRFAC(STEP(KEEP(38)))), & LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IERR,LAST_CALL) IF (IERR .LT.0) THEN INFO(1) = IERR IF (LP > 0 ) THEN WRITE(LP,*)MYID, & ': Error in CMUMPS_OOC_IO_LU_PANEL',IERR ENDIF ENDIF ELSE IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+ ITMP8 CALL CMUMPS_NEW_FACTOR(KEEP(38),PTRFAC, & KEEP,KEEP8,A,LA, ITMP8, IERR) IF(IERR.LT.0)THEN INFO(1)=IERR IF (LP > 0 ) THEN WRITE(LP,*)MYID, & ': Error in CMUMPS_NEW_FACTOR',IERR ENDIF ENDIF ENDIF ENDIF IF (KEEP(201).NE.0 .OR. KEEP(252).NE.0) THEN LRLUS = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 IF (KEEP(252).NE.0) THEN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,0_8,-ITMP8, & KEEP,KEEP8,LRLUS) ELSE CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLUS) ENDIF IF (PTRFAC(STEP(KEEP(38))).EQ.POSFAC-ITMP8) THEN POSFAC = POSFAC - ITMP8 LRLU = LRLU + ITMP8 ENDIF ELSE CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLUS) ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL, INFO, & COMM_NODES, MYID_NODES ) ENDIF IF ( INFO(1).GE.0 .AND. KEEP(252) .NE. 0 .AND. & (KEEP(60).EQ.0 .OR. KEEP(221).EQ.1)) THEN IF (root%yes) 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(roota%RHS_CNTR_MASTER_ROOT( & LRHS_CNTR_MASTER_ROOT), stat=IERR ) IF (IERR.gt.0) THEN INFO(1) = -13 INFO(2) = LRHS_CNTR_MASTER_ROOT IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'CNTR_MASTER_ROOT of size', & LRHS_CNTR_MASTER_ROOT ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL, INFO, COMM_NODES, & MYID_NODES) IF (root%yes .AND. INFO(1).GE.0) THEN FWD_LOCAL_N_RHS = MUMPS_NUMROC(KEEP(253), & root%NBLOCK, root%MYCOL, 0, root%NPCOL) FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) CALL CMUMPS_GATHER_ROOT( MYID_NODES, & root%TOT_ROOT_SIZE, KEEP(253), & roota%RHS_CNTR_MASTER_ROOT(1), LOCAL_M, & FWD_LOCAL_N_RHS, root%MBLOCK, root%NBLOCK, & roota%RHS_ROOT(1,1), MASTER_ROOT, & root%NPROW, root%NPCOL, COMM_NODES ) ENDIF ENDIF ELSE IF (KEEP(19).NE.0) THEN CALL MPI_REDUCE(KEEP(109), GLOBK109, 1, & MPI_INTEGER, MPI_SUM, & MASTER_ROOT, & COMM_NODES, IERR) ENDIF IF (ROOT_OWNER) THEN IPOSROOT = PTLUST(STEP(KEEP(20))) NFRONT = IW(IPOSROOT+KEEP(IXSZ)+3) NFRONT8 = int(NFRONT,8) IPOSROOTROWINDICES=IPOSROOT+6+KEEP(IXSZ)+ & IW(IPOSROOT+5+KEEP(IXSZ)) NTOTPV = NTOTPV + NFRONT NMAXNPIV = max(NMAXNPIV,NFRONT) END IF IF ( KEEP(60) .EQ. 0 ) THEN IF ( ROOT_OWNER ) THEN IF (KEEP(118).GE.40) THEN NOFFNEGPV_ROOT = 0 NULLNEGPV_ROOT = 0 NTOTPV_ROOT = 0 NB22T1_ROOT = 0 NBTINY_ROOT = 0 DET_SIGN_ROOT = 1 DET_EXP_ROOT = 0 DET_MANT_ROOT = cmplx(1.0E0,0.0E0, & kind=kind(1.0E0)) DKEEP_SAVE(:) = DKEEP(:) KEEP_SAVE(:) = KEEP(:) KEEP8_SAVE(:) = KEEP8(:) KEEP_SAVE(201) = 0 IF (KEEP(110).EQ.0) THEN KEEP_SAVE(110)= 1 IF (KEEP(118).EQ.40) THEN IF ((DKEEP(10).LE.0).OR.(DKEEP(10).GT.1)) THEN DKEEP_SAVE(1) = DKEEP(9)*1E-1 ELSE DKEEP_SAVE(1) = DKEEP(9)*DKEEP(10) ENDIF ELSE IF (KEEP(118).EQ.41) THEN DKEEP_SAVE(1) = DKEEP(9) ELSE IF (KEEP(118).EQ.42) THEN IF (DKEEP(13).LT.1) THEN DKEEP_SAVE(1) = DKEEP(9)*10 ELSE DKEEP_SAVE(1) = DKEEP(9)*DKEEP(13) ENDIF ENDIF ELSE DKEEP_SAVE(1) = DKEEP(9) ENDIF IS_A_ROOT_SAVE_ALLOCATED = .FALSE. IF (LRLU.GT.NFRONT8*NFRONT8) THEN A_ROOT_SAVE => A(POSFAC:POSFAC+LRLU-1_8) ELSE IF (associated(A_ROOT_SAVE)) & DEALLOCATE(A_ROOT_SAVE) ALLOCATE(A_ROOT_SAVE(NFRONT8*NFRONT8),stat=IERR) IF (IERR.GT.0) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR(NFRONT8*NFRONT8, INFO(2) ) IF (LP > 0 ) & write(LP,*) "ERROR allocating A_ROOT_SAVE ", & " of size ", NFRONT*NFRONT GOTO 735 ENDIF IS_A_ROOT_SAVE_ALLOCATED = .TRUE. ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK8=int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF ( NFRONT8*NFRONT8 > int(KEEP(361),8) .AND. NOMP .GT. 1) DO I8 =1_8, NFRONT8*NFRONT8 A_ROOT_SAVE(I8) = & A(PTRAST(STEP(KEEP(20)))+I8-1_8) ENDDO IW(PTLUST(STEP(INODE))+KEEP(IXSZ): & PTLUST(STEP(INODE))+KEEP(IXSZ)+4) & = RECORD_ROOT(KEEP(IXSZ)+1:KEEP(IXSZ)+5) IW(PTLUST(STEP(INODE))+XXLR) = 0 AVOID_DELAYED = .TRUE. IF (KEEP(50).EQ.0) THEN CALL CMUMPS_FAC1_LU_I ( & N, INODE, IW, LIW, A_ROOT_SAVE(1), & NFRONT8*NFRONT8, IPOSROOT, 1_8, & INFO(1), INFO(2), UU, NOFFNEGPV_ROOT, NTOTPV_ROOT, & NBTINY_ROOT, & DET_EXP_ROOT, DET_MANT_ROOT, DET_SIGN_ROOT, & KEEP_SAVE,KEEP8_SAVE, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP_SAVE(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) THEN IF (LP.GT.0) & write(LP,*) "ERROR after CMUMPS_FAC1_LU ", & "on the root INFO(1)= ", INFO(1) GOTO 735 ENDIF ELSE CALL CMUMPS_FAC1_LDLT_I (N,KEEP_SAVE(20), & IW, LIW, A_ROOT_SAVE(1), NFRONT8*NFRONT8, & IPOSROOT, 1_8, & INFO(1), INFO(2), UU, & NOFFNEGPV_ROOT, NULLNEGPV_ROOT, NTOTPV_ROOT, & NB22T1_ROOT, NBTINY_ROOT, & DET_EXP_ROOT, DET_MANT_ROOT, DET_SIGN_ROOT, & KEEP_SAVE,KEEP8_SAVE, MYID_NODES, SEUIL, & AVOID_DELAYED, ETATASS, DKEEP_SAVE(1), & PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) THEN IF (LP.GT.0) & write(LP,*) "ERROR after CMUMPS_FAC1_LDLT ", & "on the root INFO(1)= ", INFO(1) GOTO 735 ENDIF ENDIF LRecord = IW(IOLDPS+XXI) IW(PTLUST(STEP(INODE)): & PTLUST(STEP(INODE))+LRecord-1) = & RECORD_ROOT(1:LRecord) IW(PTLUST(STEP(INODE))+KEEP(IXSZ): & PTLUST(STEP(INODE))+KEEP(IXSZ)+4) = & Header_ROOT(1:5) KEEP17_LU = KEEP_SAVE(109)-KEEP(109) IF (KEEP_SAVE(109).GT.KEEP(109)) THEN K = 1 DO I = KEEP(109)+1, KEEP(109)+KEEP17_LU RECORD_ROOT(K) = & PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) K = K+1 ENDDO ENDIF IF (IS_A_ROOT_SAVE_ALLOCATED) DEALLOCATE(A_ROOT_SAVE) NULLIFY(A_ROOT_SAVE) IS_A_ROOT_SAVE_ALLOCATED = .FALSE. DET_SIGN = DET_SIGN * DET_SIGN_ROOT DET_EXP = DET_EXP + DET_EXP_ROOT CALL CMUMPS_UPDATEDETER ( DET_MANT_ROOT, & DET_MANT, DET_EXP) NOFFNEGPV = NOFFNEGPV + NOFFNEGPV_ROOT NULLNEGPV = NULLNEGPV + NULLNEGPV_ROOT ENDIF LOCAL_M = 0 LOCAL_N = 0 MBLOCK = 0 NBLOCK = 0 PHASE = 1 CALL CMUMPS_SVD_QR_ESTIM_WK( PHASE, & MBLOCK, NBLOCK, NFRONT, LOCAL_M, LOCAL_N, & ROOT_OWNER, KEEP,KEEP8, & LIWK_RR, LWK_RR ) LBUFRX = LWK_RR IS_BUFRX_ALLOCATED = .FALSE. IF ( LRLU .GT. LBUFRX ) THEN BUFRX => A(POSFAC:POSFAC+LBUFRX-1_8) ELSE ALLOCATE( BUFRX( LBUFRX ), stat = IERR ) IF (IERR.gt.0) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR(LBUFRX, INFO(2)) IF (LP.GT.0) & write(LP,*) ' Error allocating, real & array ','of size ', LBUFRX, & ' before CMUMPS_SEQ_FACTO_ROOT_SVD_QR' GOTO 735 ENDIF IS_BUFRX_ALLOCATED = .TRUE. ENDIF IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST .LT. & KEEP(109)+NFRONT) THEN CALL MUMPS_RESIZE_PIVNUL(KEEP, N, PIVNUL_LIST_STRUCT, & KEEP(109)+NFRONT, INFO(1), INFO(2) ) IF (INFO(1).LT.0) GOTO 735 ENDIF CALL CMUMPS_SEQ_FACTO_ROOT_SVD_QR( & NFRONT,A(PTRAST(STEP(KEEP(20)))), & root, roota, & BUFRX(1), int(LBUFRX), & KEEP,KEEP8, INFO, LP, DKEEP, & GLOBK109, OPELI, & PIVNUL_LIST_STRUCT%PIVNUL_LIST(KEEP(109)+1), & PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST- KEEP(109), & IW(IPOSROOTROWINDICES)) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IS_BUFRX_ALLOCATED = .FALSE. IF (INFO(1).LT.0) GOTO 735 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) CALL CMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) KEEP(143) = KEEP17_LU IF (KEEP(118).GE.40) THEN K = 1 IF (KEEP(17).GT.0) THEN DO I = KEEP(109)+1, KEEP(109)+KEEP(17) IF ( K .GT. KEEP17_LU ) THEN PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) = -1 ELSE PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) = & RECORD_ROOT(K) ENDIF K = K+1 ENDDO ENDIF ENDIF IF (allocated(RECORD_ROOT)) DEALLOCATE(RECORD_ROOT) IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC, IW(IPOSROOT+XXR)) LIWFAC = IW(IPOSROOT+XXI) TYPEFile = TYPEF_L NextPiv2beWritten = 1 MonBloc%INODE = KEEP(20) MonBloc%MASTER = .TRUE. MonBloc%Typenode = 3 MonBloc%NCOL = NFRONT MonBloc%NROW = NFRONT MonBloc%NFS = NFRONT MonBloc%Last = .TRUE. MonBloc%LastPiv = MonBloc%NCOL MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. LAST_CALL = .TRUE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(PTRAST(STEP(KEEP(20)))), & LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IPOSROOT), LIWFAC, & MYID, KEEP8(31), IERR, LAST_CALL) IF(IERR.LT.0)THEN IF (LP > 0) & WRITE(LP,*)MYID, & ': Error raised in CMUMPS_OOC_IO_LU_PANEL', & IERR INFO(1)=IERR ENDIF ELSE IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+NFRONT8*NFRONT8 CALL CMUMPS_NEW_FACTOR(KEEP(20),PTRFAC, & KEEP,KEEP8,A,LA, NFRONT8*NFRONT8, IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID, & ': Internal error in CMUMPS_NEW_FACTOR', & IERR GOTO 735 ENDIF ENDIF ITMP8 = NFRONT8*NFRONT8 IF(KEEP(201).NE.0)THEN IF (PTRFAC(STEP(KEEP(20))).EQ. & POSFAC-ITMP8) THEN POSFAC = POSFAC - ITMP8 LRLU = LRLU + ITMP8 LRLUS = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 ELSE IF (LP.GT.0) & WRITE(LP,*) "Internal error", & POSFAC,NFRONT8, & "root KEEP(20) not on top in OOC" GOTO 735 ENDIF ENDIF CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,ITMP8,0_8,KEEP,KEEP8,LRLUS) ENDIF 735 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM_NODES, MYID_NODES ) IF (INFO(1).LT.0) GOTO 745 CALL MPI_BCAST( KEEP(17), 1, MPI_INTEGER, & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(20))), & KEEP(199)), & COMM_NODES, IERR ) CALL MPI_BCAST( KEEP(143), 1, MPI_INTEGER, & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(20))), & KEEP(199)), & COMM_NODES, IERR ) END IF IF (ROOT_OWNER.AND.KEEP(60).NE.0) THEN ITMP8 = NFRONT8*NFRONT8 IF ( PTRFAC(STEP(KEEP(20))) .EQ. POSFAC - & ITMP8 ) THEN POSFAC = POSFAC - ITMP8 LRLUS = LRLUS + ITMP8 LRLU = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-ITMP8,KEEP,KEEP8,LRLUS) ENDIF ENDIF END IF GOTO 750 745 CONTINUE IF (allocated(RECORD_ROOT)) DEALLOCATE(RECORD_ROOT) IF (IS_A_ROOT_SAVE_ALLOCATED) DEALLOCATE(A_ROOT_SAVE) NULLIFY(A_ROOT_SAVE) 750 CONTINUE IF (INFO(1).LT.0) GOTO 500 CALL MUMPS_SECFIN(ROOTTIME) DKEEP(99)=real(ROOTTIME) END IF END IF 500 CONTINUE IF ( KEEP(38) .NE. 0 ) THEN IF (MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))),KEEP(199)) & ) THEN MAXFRT = max ( MAXFRT, root%TOT_ROOT_SIZE) END IF END IF IF ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.2)) THEN CALL CMUMPS_OOC_CLEAN_PENDING(IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ENDIF CALL MUMPS_PROPINFO( ICNTL, INFO, COMM_NODES, MYID_NODES ) ENDIF IF (associated(roota%RHS_ROOT)) THEN DEALLOCATE(roota%RHS_ROOT) NULLIFY(roota%RHS_ROOT) ENDIF RETURN END SUBROUTINE CMUMPS_FAC_PAR SUBROUTINE CMUMPS_CHANGE_HEADER( HEADER, KEEP253 ) INTEGER HEADER( 6 ), KEEP253 INTEGER NFRONT, NASS NFRONT = HEADER(1) IF ( HEADER(2) .ne. 0 ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 1 :',HEADER(2) CALL MUMPS_ABORT() END IF NASS = abs( HEADER( 3 ) ) IF ( NASS .NE. abs( HEADER( 4 ) ) ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 2 :',HEADER(3:4) CALL MUMPS_ABORT() END IF IF ( NASS+KEEP253 .NE. NFRONT ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 3 : not root', & NASS, KEEP253, NFRONT CALL MUMPS_ABORT() END IF HEADER( 1 ) = KEEP253 HEADER( 2 ) = 0 HEADER( 3 ) = NFRONT HEADER( 4 ) = NFRONT-KEEP253 RETURN END SUBROUTINE CMUMPS_CHANGE_HEADER END MODULE CMUMPS_FAC_PAR_M MUMPS_5.8.1/src/cfac_mem_free_block_cb.F0000664000175000017500000000562215042446440017715 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, IPOSBLOCK, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP, KEEP8, IN_PLACE_STATS & ) !$ USE OMP_LIB USE MUMPS_LOAD IMPLICIT NONE INTEGER IPOSBLOCK, & LIW, IWPOSCB, N INTEGER(8) :: LA, LRLU, LRLUS, IPTRLU LOGICAL IN_PLACE_STATS INTEGER IW( LIW ), KEEP(500) INTEGER(8) KEEP8(150) INTEGER MYID LOGICAL SSARBR INTEGER SIZFI_BLOCK, SIZFI INTEGER(8) :: SIZFR, SIZFR_BLOCK, SIZFR_BLOCK_EFF, & SIZEHOLE, MEM_INC, DYNSIZE_BLOCK INCLUDE 'mumps_headers.h' SIZFI_BLOCK=IW(IPOSBLOCK+XXI) CALL MUMPS_GETI8( SIZFR_BLOCK, IW(IPOSBLOCK+XXR) ) CALL MUMPS_GETI8( DYNSIZE_BLOCK,IW(IPOSBLOCK+XXD) ) IF (DYNSIZE_BLOCK .GT. 0_8) THEN SIZFR_BLOCK_EFF = 0_8 ELSE IF (KEEP(216).eq.3 & ) THEN SIZFR_BLOCK_EFF = SIZFR_BLOCK ELSE CALL CMUMPS_SIZEFREEINREC( IW(IPOSBLOCK), & LIW-IPOSBLOCK+1, & SIZEHOLE, KEEP(IXSZ)) SIZFR_BLOCK_EFF = SIZFR_BLOCK - SIZEHOLE ENDIF IF (.NOT. IN_PLACE_STATS) THEN LRLUS = LRLUS + SIZFR_BLOCK_EFF IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) - SIZFR_BLOCK_EFF ELSE !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - SIZFR_BLOCK_EFF !$OMP END ATOMIC ENDIF ENDIF IF ( IPOSBLOCK .eq. IWPOSCB + 1 ) THEN IPTRLU = IPTRLU + SIZFR_BLOCK IWPOSCB = IWPOSCB + SIZFI_BLOCK LRLU = LRLU + SIZFR_BLOCK MEM_INC = -SIZFR_BLOCK_EFF IF (IN_PLACE_STATS) THEN MEM_INC= 0_8 ENDIF CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,MEM_INC,KEEP,KEEP8,LRLUS) 90 IF ( IWPOSCB .eq. LIW ) GO TO 100 SIZFI = IW( IWPOSCB+1+XXI ) CALL MUMPS_GETI8( SIZFR, IW(IWPOSCB+1+XXR) ) IF ( IW( IWPOSCB+1+XXS ) .EQ. S_FREE ) THEN IPTRLU = IPTRLU + SIZFR LRLU = LRLU + SIZFR IWPOSCB = IWPOSCB + SIZFI GO TO 90 ENDIF 100 CONTINUE IW( IWPOSCB+1+XXP)=TOP_OF_STACK ELSE IW( IPOSBLOCK +XXS)=S_FREE CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,-SIZFR_BLOCK_EFF,KEEP,KEEP8,LRLUS) END IF RETURN END SUBROUTINE CMUMPS_FREE_BLOCK_CB_STATIC MUMPS_5.8.1/src/zana_lr.F0000664000175000017500000017736315042446441015007 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_ANA_LR USE ZMUMPS_LR_CORE USE MUMPS_LR_STATS USE MUMPS_LR_COMMON USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY: LMATRIX_T !$ USE OMP_LIB, ONLY: omp_get_max_threads IMPLICIT NONE CONTAINS SUBROUTINE GET_CUT(IWR, NASS, NCB, LRGROUPS, NPARTSCB, & NPARTSASS, CUT) INTEGER, INTENT(IN) :: NASS, NCB INTEGER, INTENT(IN) :: IWR(*) INTEGER, INTENT(IN), DIMENSION(:) :: LRGROUPS INTEGER, INTENT(OUT) :: NPARTSCB, NPARTSASS INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: I, CURRENT_PART, CUTBUILDER,allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: BIG_CUT ALLOCATE(BIG_CUT(max(NASS,1)+NCB+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of BIG_CUT in GET_CUT" CALL MUMPS_ABORT() ENDIF CURRENT_PART = LRGROUPS(IWR(1)) BIG_CUT(1) = 1 BIG_CUT(2) = 2 CUTBUILDER = 2 NPARTSASS = 0 NPARTSCB = 0 DO I = 2,NASS + NCB IF (LRGROUPS(IWR(I)) == CURRENT_PART) THEN BIG_CUT(CUTBUILDER) = BIG_CUT(CUTBUILDER) + 1 ELSE CUTBUILDER = CUTBUILDER + 1 BIG_CUT(CUTBUILDER) = BIG_CUT(CUTBUILDER-1) + 1 CURRENT_PART = LRGROUPS(IWR(I)) END IF IF (I == NASS) NPARTSASS = CUTBUILDER - 1 END DO IF (NASS.EQ.1) NPARTSASS= 1 NPARTSCB = CUTBUILDER - 1 - NPARTSASS ALLOCATE(CUT(max(NPARTSASS,1)+NPARTSCB+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of CUT in GET_CUT" CALL MUMPS_ABORT() ENDIF IF (NPARTSASS.EQ.0) THEN CUT(1) = 1 CUT(2:2+NPARTSCB) = BIG_CUT(1:1+NPARTSCB) ELSE CUT = BIG_CUT(1:NPARTSASS+NPARTSCB+1) ENDIF if(allocated(BIG_CUT)) DEALLOCATE(BIG_CUT) END SUBROUTINE GET_CUT SUBROUTINE SEP_GROUPING( NFRONT, KEEP, & NV, VLIST, N, NZ, LRGROUPS, NBGROUPS, IW, & LW, IPE, LEN, GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, NODE, & GEN2HALO, K482, K472, K469, SEP_SIZE, MAXSIZE_PARTS, & KEEP10, LP, LPOK, IFLAG, IERROR) INTEGER, INTENT(IN) :: NFRONT, KEEP(500) INTEGER(8), INTENT(IN) :: NZ, LW INTEGER, INTENT(IN) :: NV, N, GROUP_SIZE, HALO_DEPTH INTEGER, INTENT(IN) :: IW(LW), LEN(N), NODE, K482 INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: K472, K469, SEP_SIZE, KEEP10, LP LOGICAL :: LPOK INTEGER, INTENT(INOUT) :: NBGROUPS, WORKH(N) INTEGER, INTENT(INOUT) :: VLIST(NV), TRACE(N) INTEGER :: LRGROUPS(:) INTEGER, INTENT(INOUT) :: GEN2HALO(N) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: MAXSIZE_PARTS INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IPTRHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: PARTS, JCNHALO INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBG_CAPT, & NBGROUPS_KWAY, I, GROUP_SIZE2, LRGROUPS_SIGN, IERR INTEGER :: MAXSIZE_PARTS_LOC #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) INTEGER :: METIS_IDX_SIZE #endif #if defined (scotch) || defined (ptscotch) INTEGER :: SCOTCH_IDX_SIZE #endif CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV, & NFRONT, KEEP(35)) NBGROUPS_KWAY = MAX( & INT(dble(NV+GROUP_SIZE2-1)/dble(GROUP_SIZE2)) & ,1) IF (NV .GE. SEP_SIZE) THEN LRGROUPS_SIGN = 1 ELSE LRGROUPS_SIGN = -1 ENDIF IF (NBGROUPS_KWAY > 1) THEN IF (K469.EQ.3) THEN !$OMP CRITICAL(gethalo_cri) CALL GETHALONODES(N, IW, LW, IPE, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, LEN, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(max(HALOEDGENBR,1)), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) ENDIF CALL GETHALOGRAPH(WORKH, NHALO, N, IW, LW, IPE, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO) !$OMP END CRITICAL(gethalo_cri) IF (IFLAG.LT.0) RETURN ELSE CALL GETHALONODES(N, IW, LW, IPE, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, LEN, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(max(HALOEDGENBR,1)), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) RETURN ENDIF CALL GETHALOGRAPH(WORKH, NHALO, N, IW, LW, IPE, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO) ENDIF IF (K482.EQ.1) THEN #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_KWAY_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ELSE IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 1 ELSE CALL MUMPS_METIS_KWAY_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ENDIF #endif ELSE IF (K482.EQ.2) THEN #if defined (scotch) || defined (ptscotch) CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_IDX_SIZE) IF (SCOTCH_IDX_SIZE .EQ. 32) THEN IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 2 ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto32( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto64( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) END IF IF ((IFLAG.LT.0).AND.LPOK) THEN WRITE(LP,*) " Internal error in SCOTCH during ", & " Kway partitioning, SCOTCHFGRAPHPART, " WRITE(LP,*) & " please also provide METIS package to MUMPS " ENDIF #endif ELSE WRITE(6,*) " Internal ERROR K482=", K482 CALL MUMPS_ABORT() END IF IF (IFLAG.LT.0) GOTO 500 CALL GET_GLOBAL_GROUPS(PARTS, VLIST, NV, & NBGROUPS_KWAY, LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN, & MAXSIZE_PARTS_LOC, .FALSE., GROUP_SIZE2) MAXSIZE_PARTS = max(MAXSIZE_PARTS, MAXSIZE_PARTS_LOC) ELSE MAXSIZE_PARTS = max(MAXSIZE_PARTS,NV) !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + 1 !$OMP END ATOMIC DO I=1,NV LRGROUPS(VLIST(I)) = LRGROUPS_SIGN*(NBG_CAPT + 1) END DO END IF 500 IF (allocated(IPTRHALO)) then DEALLOCATE(IPTRHALO) ENDIF IF (allocated(PARTS)) then DEALLOCATE(PARTS) ENDIF IF (allocated(JCNHALO)) then DEALLOCATE(JCNHALO ) ENDIF RETURN END SUBROUTINE SEP_GROUPING SUBROUTINE SEP_GROUPING_AB ( NFRONT, KEEP, & NV, NVEXPANDED, & VLIST, N, LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, NODE, & GEN2HALO, K482, K472, K469, SEP_SIZE, MAXSIZE_PARTS, & KEEP10, LP, LPOK, IFLAG, IERROR) INTEGER, INTENT(IN) :: NFRONT, KEEP(500) TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: NV, NVEXPANDED, & N, GROUP_SIZE, HALO_DEPTH INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: NODE, K482 INTEGER, INTENT(IN) :: K472, K469, SEP_SIZE, KEEP10, LP LOGICAL :: LPOK INTEGER, INTENT(INOUT) :: NBGROUPS, WORKH(N) INTEGER, INTENT(INOUT) :: VLIST(NV), TRACE(N) INTEGER :: LRGROUPS(:) INTEGER, INTENT(INOUT) :: GEN2HALO(N) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: MAXSIZE_PARTS INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IPTRHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: PARTS, JCNHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: VWGT INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBG_CAPT, & NBGROUPS_KWAY, I, GROUP_SIZE2, LRGROUPS_SIGN, IERR INTEGER :: MAXSIZE_PARTS_LOC DOUBLE PRECISION :: COMPRESS_RATIO LOGICAL :: AB_ACTIVE #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) INTEGER :: METIS_IDX_SIZE #endif #if defined (scotch) || defined (ptscotch) INTEGER :: SCOTCH_IDX_SIZE #endif AB_ACTIVE = (NVEXPANDED.GT.NV) CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED, & NFRONT, KEEP(35)) COMPRESS_RATIO= dble(NVEXPANDED)/dble(NV) NBGROUPS_KWAY = MAX( & INT(dble(NVEXPANDED+GROUP_SIZE2-1)/dble(GROUP_SIZE2)) & ,1) NBGROUPS_KWAY = min(NBGROUPS_KWAY, NV) IF (NVEXPANDED .GE. SEP_SIZE) THEN LRGROUPS_SIGN = 1 ELSE LRGROUPS_SIGN = -1 ENDIF IF (NBGROUPS_KWAY > 1) THEN IF (K469.EQ.3) THEN !$OMP CRITICAL(gethalo_cri) CALL GETHALONODES_AB(N, LUMAT, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(max(HALOEDGENBR,1)), VWGT(NHALO), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) ENDIF DO I=1, NHALO VWGT(I) = SIZEOFBLOCKS(WORKH(I)) ENDDO CALL GETHALOGRAPH_AB(WORKH, NV, & NHALO, N, LUMAT, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO, PARTS) !$OMP END CRITICAL(gethalo_cri) IF (IFLAG.LT.0) RETURN ELSE CALL GETHALONODES_AB(N, LUMAT, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(max(HALOEDGENBR,1)), VWGT(NHALO), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) RETURN ENDIF DO I=1, NHALO VWGT(I) = SIZEOFBLOCKS(WORKH(I)) ENDDO CALL GETHALOGRAPH_AB(WORKH, NV, & NHALO, N, LUMAT, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO, PARTS) ENDIF IF (K482.EQ.1) THEN #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_KWAY_AB_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) ELSE IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 1 ELSE CALL MUMPS_METIS_KWAY_AB_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ENDIF #endif ELSE IF (K482.EQ.2) THEN #if defined (scotch) || defined (ptscotch) CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_IDX_SIZE) IF (SCOTCH_IDX_SIZE .EQ. 32) THEN IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 2 ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto32( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto64( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) END IF IF ((IFLAG.LT.0).AND.LPOK) THEN WRITE(LP,*) " Internal error in SCOTCH during ", & " Kway partitioning, SCOTCHFGRAPHPART, " WRITE(LP,*) & " also provide METIS package to MUMPS " ENDIF #endif ELSE WRITE(6,*) " Internal ERROR K482=", K482 CALL MUMPS_ABORT() END IF IF (IFLAG.LT.0) GOTO 500 CALL GET_GLOBAL_GROUPS(PARTS,VLIST, NV, & NBGROUPS_KWAY, LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN, & MAXSIZE_PARTS_LOC, AB_ACTIVE, GROUP_SIZE2) MAXSIZE_PARTS = max( MAXSIZE_PARTS, & int(dble(MAXSIZE_PARTS_LOC*COMPRESS_RATIO)) ) ELSE MAXSIZE_PARTS = max(MAXSIZE_PARTS,NV) !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + 1 !$OMP END ATOMIC DO I=1,NV LRGROUPS(VLIST(I)) = LRGROUPS_SIGN*(NBG_CAPT + 1) END DO END IF 500 IF (allocated(IPTRHALO)) then DEALLOCATE(IPTRHALO) ENDIF IF (allocated(PARTS)) then DEALLOCATE(PARTS) ENDIF IF (allocated(JCNHALO)) then DEALLOCATE(JCNHALO ) ENDIF IF (allocated(VWGT)) then DEALLOCATE(VWGT) ENDIF RETURN END SUBROUTINE SEP_GROUPING_AB SUBROUTINE GETHALONODES_AB(N, LUMAT, IND, NIND, PMAX, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) TYPE(LMATRIX_T) :: LUMAT INTEGER,DIMENSION(:),INTENT(IN) :: IND INTEGER, INTENT(IN) :: N, NODE INTEGER, INTENT(IN) :: PMAX,NIND INTEGER, INTENT(OUT) :: NHALO INTEGER, INTENT(INOUT) :: TRACE(N), WORKH(N) INTEGER :: GEN2HALO(N) INTEGER(8), INTENT(OUT) :: HALOEDGENBR INTEGER :: I, J, II INTEGER :: HALOI, NB, NEWNHALO INTEGER(8) :: SEPEDGES_TOTAL, & SEPEDGES_INTERNAL WORKH(1:NIND) = IND NHALO = NIND NEWNHALO = 0 HALOEDGENBR = 0_8 SEPEDGES_TOTAL = 0_8 SEPEDGES_INTERNAL = 0_8 DO I=1,NIND HALOI = WORKH(I) GEN2HALO(HALOI) = I IF (TRACE(HALOI) .NE. NODE) THEN TRACE(HALOI) = NODE END IF ENDDO DO I=1,NIND HALOI = WORKH(I) NB = LUMAT%COL(HALOI)%NBINCOL SEPEDGES_TOTAL = SEPEDGES_TOTAL + int(NB,8) DO J=1, NB II = LUMAT%COL(HALOI)%IRN(J) IF (TRACE(II).NE.NODE) THEN NEWNHALO = NEWNHALO + 1 WORKH(NHALO+NEWNHALO) = II GEN2HALO(II) = NHALO+NEWNHALO TRACE(II) = NODE ELSE IF (GEN2HALO(II).LE.NHALO) THEN SEPEDGES_INTERNAL = SEPEDGES_INTERNAL + 1_8 ENDIF ENDIF ENDDO END DO HALOEDGENBR = SEPEDGES_TOTAL + & (SEPEDGES_TOTAL - SEPEDGES_INTERNAL) NHALO = NHALO + NEWNHALO END SUBROUTINE GETHALONODES_AB SUBROUTINE GETHALOGRAPH_AB(HALO,NSEP,NHALO, & N,LUMAT,IPTRHALO,JCNHALO, & HALOEDGENBR,TRACE,NODE, GEN2HALO, IQ) INTEGER, INTENT(IN) :: N TYPE(LMATRIX_T) :: LUMAT INTEGER,INTENT(IN):: NSEP, NHALO, NODE INTEGER,INTENT(IN):: GEN2HALO(N) INTEGER,DIMENSION(NHALO),INTENT(IN) :: HALO INTEGER, INTENT(IN) :: TRACE(N) INTEGER(8),INTENT(IN) :: HALOEDGENBR INTEGER(8), INTENT(OUT) :: IPTRHALO(NHALO+1) INTEGER, INTENT(OUT) :: JCNHALO(max(HALOEDGENBR,1)) INTEGER :: IQ(NHALO) INTEGER::I,J,NB,II,JJ,HALOI,HALOJ DO I=NSEP+1, NHALO IQ(I) = 0 ENDDO DO I=1,NSEP HALOI = HALO(I) NB = LUMAT%COL(HALOI)%NBINCOL IQ(I) = NB DO JJ=1, NB II = LUMAT%COL(HALOI)%IRN(JJ) J = GEN2HALO(II) IF (J.GT.NSEP) THEN IQ(J) = IQ(J) + 1 ENDIF ENDDO ENDDO IPTRHALO(1) = 1_8 DO I=1,NHALO IPTRHALO(I+1) = IPTRHALO(I)+int(IQ(I),8) ENDDO DO I=1,NSEP HALOI = HALO(I) NB = LUMAT%COL(HALOI)%NBINCOL DO JJ=1, NB HALOJ = LUMAT%COL(HALOI)%IRN(JJ) J = GEN2HALO(HALOJ) JCNHALO(IPTRHALO(I)) = J IPTRHALO(I) = IPTRHALO(I) + 1 IF (J.GT.NSEP) THEN JCNHALO(IPTRHALO(J)) = I IPTRHALO(J) = IPTRHALO(J) + 1 ENDIF ENDDO ENDDO IPTRHALO(1) = 1_8 DO I=1,NHALO IPTRHALO(I+1) = IPTRHALO(I)+int(IQ(I),8) ENDDO END SUBROUTINE GETHALOGRAPH_AB SUBROUTINE GET_GLOBAL_GROUPS(PARTS, SEP, NSEP, NPARTS, & LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN, & MAXSIZE_PARTS_LOC, AB_ACTIVE, GROUP_SIZE2) INTEGER,INTENT(IN) :: NSEP, N, LRGROUPS_SIGN, GROUP_SIZE2 INTEGER :: PARTS(:) LOGICAL :: AB_ACTIVE INTEGER,DIMENSION(:),INTENT(INOUT) :: SEP INTEGER, INTENT(INOUT) :: NPARTS INTEGER, INTENT(INOUT) :: NBGROUPS INTEGER :: LRGROUPS(:) INTEGER, INTENT(OUT) :: MAXSIZE_PARTS_LOC INTRINSIC maxval INTEGER:: I,CNT,NB_PARTS_WITHOUT_SEP_NODE,allocok INTEGER:: TARGET_SIZE_KWAY INTEGER:: MAXSIZE_PARTS_LOC_NEW, NBG_CAPT INTEGER,DIMENSION(:),ALLOCATABLE::SIZES, RIGHTPART INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR #if ! defined(NO_SPLIT_IN_BLRGROUPING) INTEGER :: NB_PARTS_WITH_SPLIT, IP, SZ_FINAL, II, NB_SPLIT INTEGER :: TARGET_SIZE_SPLIT #endif INTEGER,DIMENSION(:),ALLOCATABLE :: NEWSEP ALLOCATE( NEWSEP(NSEP), & SIZES(NPARTS), & RIGHTPART(NPARTS), & PARTPTR(NPARTS+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GLOBAL_GROUPS" CALL MUMPS_ABORT() ENDIF TARGET_SIZE_KWAY = GROUP_SIZE2 TARGET_SIZE_SPLIT = TARGET_SIZE_KWAY IF (AB_ACTIVE) TARGET_SIZE_SPLIT =huge(TARGET_SIZE_SPLIT) NB_PARTS_WITHOUT_SEP_NODE = 0 RIGHTPART = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = SIZES(PARTS(I)) + 1 END DO MAXSIZE_PARTS_LOC = maxval(SIZES) CNT = 0 PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) IF (SIZES(I-1)==0) THEN NB_PARTS_WITHOUT_SEP_NODE = NB_PARTS_WITHOUT_SEP_NODE + 1 ELSE CNT = CNT + 1 RIGHTPART(I-1) = CNT #if ! defined(NO_SPLIT_IN_BLRGROUPING) SIZES(CNT) = SIZES(I-1) #endif END IF END DO NPARTS = NPARTS - NB_PARTS_WITHOUT_SEP_NODE #if ! defined(NO_SPLIT_IN_BLRGROUPING) IF (MAXSIZE_PARTS_LOC.LT.TARGET_SIZE_SPLIT) THEN #endif !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + NPARTS !$OMP END ATOMIC DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) LRGROUPS(SEP(I)) = LRGROUPS_SIGN*(RIGHTPART(PARTS(I)) & + NBG_CAPT) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO SEP = NEWSEP #if ! defined(NO_SPLIT_IN_BLRGROUPING) ELSE DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO SEP = NEWSEP PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) ENDDO NB_PARTS_WITH_SPLIT = 0 MAXSIZE_PARTS_LOC_NEW = 0 DO IP =1, NPARTS NB_SPLIT = (SIZES(IP) + TARGET_SIZE_SPLIT-1) & / TARGET_SIZE_SPLIT SZ_FINAL = (SIZES(IP) + NB_SPLIT-1) / NB_SPLIT NB_PARTS_WITH_SPLIT = NB_PARTS_WITH_SPLIT + & ( & ( (PARTPTR(IP+1) - PARTPTR(IP))+ SZ_FINAL-1 ) / & SZ_FINAL & ) ENDDO !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + NB_PARTS_WITH_SPLIT !$OMP END ATOMIC NB_PARTS_WITH_SPLIT = 0 DO IP=1,NPARTS NB_SPLIT = (SIZES(IP) + TARGET_SIZE_SPLIT-1) & / TARGET_SIZE_SPLIT SZ_FINAL = (SIZES(IP) + NB_SPLIT-1) / NB_SPLIT MAXSIZE_PARTS_LOC_NEW = max(MAXSIZE_PARTS_LOC_NEW, & SZ_FINAL) DO I=PARTPTR(IP), PARTPTR(IP+1)-1, SZ_FINAL NB_PARTS_WITH_SPLIT = NB_PARTS_WITH_SPLIT +1 DO II=I, min(I+SZ_FINAL-1,PARTPTR(IP+1)-1) LRGROUPS(SEP(II)) = LRGROUPS_SIGN*(NB_PARTS_WITH_SPLIT & + NBG_CAPT) ENDDO ENDDO ENDDO NPARTS = NB_PARTS_WITH_SPLIT MAXSIZE_PARTS_LOC = MAXSIZE_PARTS_LOC_NEW ENDIF #endif DEALLOCATE(NEWSEP,SIZES,RIGHTPART,PARTPTR) END SUBROUTINE GET_GLOBAL_GROUPS SUBROUTINE GETHALONODES(N, IW, LW, IPE, IND, NIND, PMAX, & NHALO, TRACE, WORKH, NODE, LEN, CNT, & GEN2HALO) INTEGER,DIMENSION(:),INTENT(IN) :: IND INTEGER(8), INTENT(IN) :: LW INTEGER, INTENT(IN) :: N, NODE INTEGER, INTENT(IN) :: IW(LW), LEN(N) INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: PMAX,NIND INTEGER, INTENT(OUT) :: NHALO INTEGER, INTENT(INOUT) :: TRACE(N), WORKH(N) INTEGER :: GEN2HALO(N) INTEGER(8), INTENT(OUT) :: CNT INTEGER :: DEPTH, I, LAST_LVL_START INTEGER :: HALOI INTEGER(8) :: J WORKH(1:NIND) = IND LAST_LVL_START = 1 NHALO = NIND CNT = 0 DO I=1,NIND HALOI = WORKH(I) GEN2HALO(HALOI) = I IF (TRACE(HALOI) .NE. NODE) THEN TRACE(HALOI) = NODE END IF DO J=IPE(HALOI),IPE(HALOI+1)-1 IF (TRACE(IW(J)).EQ.NODE) THEN CNT = CNT + 2 END IF END DO END DO DO DEPTH=1,PMAX CALL NEIGHBORHOOD(WORKH, NHALO, N, IW, LW, IPE, & TRACE, NODE, LEN, CNT, LAST_LVL_START, & DEPTH, PMAX, GEN2HALO) END DO END SUBROUTINE GETHALONODES SUBROUTINE NEIGHBORHOOD(HALO, NHALO, N, IW, LW, IPE, & TRACE, NODE, LEN, CNT, LAST_LVL_START, & DEPTH, PMAX, GEN2HALO) INTEGER, INTENT(IN) :: N, NODE, DEPTH, PMAX INTEGER,INTENT(INOUT) :: NHALO, GEN2HALO(N) INTEGER, INTENT(INOUT) :: LAST_LVL_START INTEGER(8), INTENT(INOUT) :: CNT INTEGER,DIMENSION(:),INTENT(INOUT) :: HALO INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, TARGET, INTENT(IN) :: IW(LW) INTEGER, INTENT(IN) :: LEN(N) INTEGER,DIMENSION(:) :: TRACE INTEGER :: AvgDens, THRESH INTEGER :: I,INEI,NADJI,NEWNHALO, NEIGH INTEGER, DIMENSION(:), POINTER :: ADJI INTEGER(8) :: J NEWNHALO = 0 AvgDens = nint(dble(IPE(N+1)-1_8)/dble(N)) THRESH = AvgDens*10 DO I=LAST_LVL_START,NHALO NADJI = LEN(HALO(I)) IF (NADJI.GT.THRESH) CYCLE ADJI => IW(IPE(HALO(I)):IPE(HALO(I)+1)-1) DO INEI=1,NADJI IF (TRACE(ADJI(INEI)) .NE. NODE) THEN NEIGH = ADJI(INEI) IF (LEN(NEIGH).GT.THRESH) CYCLE TRACE(NEIGH) = NODE NEWNHALO = NEWNHALO + 1 HALO(NHALO+NEWNHALO) = NEIGH GEN2HALO(NEIGH) = NHALO + NEWNHALO DO J=IPE(NEIGH),IPE(NEIGH+1)-1 IF (TRACE(IW(J)).EQ.NODE) THEN CNT = CNT + 2 END IF END DO END IF END DO END DO LAST_LVL_START = NHALO + 1 NHALO = NHALO + NEWNHALO END SUBROUTINE NEIGHBORHOOD SUBROUTINE GETHALOGRAPH(HALO,NHALO,N,IW,LW,IPE,IPTRHALO,JCNHALO, & HALOEDGENBR,TRACE,NODE, GEN2HALO) INTEGER, INTENT(IN) :: N INTEGER,INTENT(IN):: NHALO, NODE INTEGER,INTENT(IN):: GEN2HALO(N) INTEGER,DIMENSION(NHALO),INTENT(IN) :: HALO INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: IW(LW), TRACE(N) INTEGER(8),INTENT(IN) :: HALOEDGENBR INTEGER(8), INTENT(OUT) :: IPTRHALO(NHALO+1) INTEGER, INTENT(OUT) :: JCNHALO(max(HALOEDGENBR,1)) INTEGER::I,IPTR_CNT,JCN_CNT,HALOI INTEGER(8) :: J, CNT CNT = 0 IPTR_CNT = 2 JCN_CNT = 1 IPTRHALO(1) = 1 DO I=1,NHALO HALOI = HALO(I) DO J=IPE(HALOI),IPE(HALOI+1)-1 IF (TRACE(IW(J))==NODE) THEN CNT = CNT + 1 JCNHALO(JCN_CNT) = GEN2HALO(IW(J)) JCN_CNT = JCN_CNT + 1 END IF END DO IPTRHALO(IPTR_CNT) = CNT + 1 IPTR_CNT = IPTR_CNT + 1 END DO END SUBROUTINE GETHALOGRAPH SUBROUTINE GET_GROUPS(NHALO,PARTS,SEP,NSEP,NPARTS, & CUT,NEWSEP,PERM,IPERM) INTEGER,INTENT(IN) :: NHALO,NSEP INTEGER,DIMENSION(:),INTENT(IN) :: SEP INTEGER,POINTER,DIMENSION(:)::PARTS INTEGER,POINTER,DIMENSION(:)::CUT,NEWSEP,PERM, & IPERM INTEGER,INTENT(INOUT) :: NPARTS INTEGER::I,CNT,NB_PARTS_WITHOUT_SEP_NODE,allocok INTEGER,DIMENSION(:),ALLOCATABLE::SIZES INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR ALLOCATE(NEWSEP(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(PERM(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(IPERM(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(SIZES(NPARTS),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(PARTPTR(NPARTS+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF NB_PARTS_WITHOUT_SEP_NODE = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = & SIZES(PARTS(I))+1 END DO PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) IF (SIZES(I-1)==0) THEN NB_PARTS_WITHOUT_SEP_NODE = NB_PARTS_WITHOUT_SEP_NODE + 1 END IF END DO ALLOCATE(CUT(NPARTS-NB_PARTS_WITHOUT_SEP_NODE+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF CUT(1) = 1 CNT = 2 DO I=2,NPARTS+1 IF (SIZES(I-1).NE.0) THEN CUT(CNT) = PARTPTR(I) CNT = CNT + 1 END IF END DO NPARTS = NPARTS - NB_PARTS_WITHOUT_SEP_NODE CUT(NPARTS+1) = NSEP+1 DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) PERM(PARTPTR(PARTS(I))) = I IPERM(I) = PARTPTR(PARTS(I)) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO DEALLOCATE(SIZES,PARTPTR) END SUBROUTINE GET_GROUPS SUBROUTINE ZMUMPS_LR_GROUPING(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, NE_STEPS, STEP, NA, LNA, & LRGROUPS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, SEP_SIZE, & K38, K20, K60, & IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K10, & K54, K142, LPOK, LP, GATHER_MATRIX_ALLOCATED, & KEEP, ND_STEPS) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, K60, K54 INTEGER, INTENT(IN) :: LP INTEGER, INTENT(OUT) :: K142 LOGICAL, INTENT(IN) :: LPOK INTEGER, POINTER, DIMENSION(:) :: IRN, JCN INTEGER, INTENT(IN) :: NE_STEPS(:), ICNTL(60) INTEGER :: FRERE_STEPS(:), NA(:), DAD_STEPS(:) INTEGER :: FILS(N), STEP(N), LRGROUPS(N) INTEGER, INTENT(IN) :: K472, MAXFRONT LOGICAL, INTENT(INOUT) :: GATHER_MATRIX_ALLOCATED INTEGER, INTENT(IN) :: KEEP(500), ND_STEPS(:) INTEGER :: K482_LOC, K38ou20 INTEGER :: I, F, PV, NV, NLEAVES, NROOTS, PP, C, NF, NODE, & SYMTRY, NBQD, AD INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: LPTR, RPTR, NBGROUPS LOGICAL :: FIRST INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, GEN2HALO INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR LOGICAL :: INPLACE64_GRAPH_COPY K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF NBGROUPS = 0 IF (K265.EQ.-1) THEN LW = NZ8 ELSE LW = 2_8 * NZ8 ENDIF ALLOCATE(IW(LW), IPE(N+1), LEN(N), IQ(N), & POOL(NA(1)), PVS(NSTEPS), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * LW+int(N,8)+int(K10*(2*N+1),8) IFLAG = -7 CALL MUMPS_SET_IERROR(LW+int(N,8)+int(K10*(2*N+1),8),IERROR) GOTO 500 ENDIF CALL ZMUMPS_ANA_GNEW(N, NZ8, IRN(1), JCN(1), IW(1), LW, IPE(1), & LEN(1), IQ(1), LRGROUPS(1), IWFR, NRORM, NIORM, & IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265,.FALSE., & INPLACE64_GRAPH_COPY) IF (K54.EQ.3) THEN deallocate(IRN) deallocate(JCN) NULLIFY(IRN) NULLIFY(JCN) GATHER_MATRIX_ALLOCATED = .FALSE. ENDIF IF (allocated(IQ)) DEALLOCATE(IQ) LRGROUPS = -1 NLEAVES = NA(1) NROOTS = NA(2) LPTR = 2+NLEAVES RPTR = 2+NLEAVES+NROOTS DO I = 1, NROOTS POOL(I) = NA(2+NLEAVES+I) END DO PP = NROOTS ALLOCATE(WORK(MAXFRONT), TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * 3*N+MAXFRONT IFLAG = -7 IERROR = 3*N+MAXFRONT RETURN ENDIF TRACE = 0 K142 = 0 DO WHILE(PP .GT. 0) PV = ABS(POOL(PP)) NODE = STEP(PV) FIRST = POOL(PP) .LT. 0 NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV, & ND_STEPS(NODE), KEEP(35)) IF (NV .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + ( (NV-1)/GROUP_SIZE2 + 1 ) K142 = max(K142, min(NV,GROUP_SIZE2)) ELSE CALL SEP_GROUPING( ND_STEPS(NODE), KEEP, & NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE(1), WORKH(1), NODE, & GEN2HALO(1), K482_LOC, K472, 0, SEP_SIZE, K142, & K10, LP, LPOK, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 500 END IF ELSE IF (NV .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = (NBGROUPS + 1) ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -(NBGROUPS + 1) ENDDO ENDIF NBGROUPS = NBGROUPS + 1 K142 = max (K142,NV) ENDIF CALL MUMPS_UPD_TREE(NV, NSTEPS, N, FIRST, LPTR, RPTR, F, & WORK(1), & FILS, FRERE_STEPS, STEP, DAD_STEPS, & NE_STEPS, NA, LNA, PVS(1), K38ou20, & STEP_SCALAPACK_ROOT) IF (STEP_SCALAPACK_ROOT.GT.0) THEN IF (K38.GT.0) THEN K38 = K38ou20 ELSE K20 = K38ou20 ENDIF ENDIF PP = PP-1 NF = NE_STEPS(NODE) IF(NF .GT. 0) THEN PP = PP+1 POOL(PP) = F C = STEP(-F) F = FRERE_STEPS(C) DO WHILE(F .GT. 0) PP = PP+1 POOL(PP) = F C = STEP(F) F = FRERE_STEPS(C) END DO END IF END DO 500 IF (allocated(POOL)) DEALLOCATE(POOL) IF (allocated(PVS)) DEALLOCATE(PVS) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(LEN)) DEALLOCATE(LEN) IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) RETURN END SUBROUTINE ZMUMPS_LR_GROUPING SUBROUTINE ZMUMPS_LR_GROUPING_NEW(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, K142, LPOK, LP, GATHER_MATRIX_ALLOCATED, & KEEP, ND_STEPS) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, POINTER, DIMENSION(:) :: IRN, JCN INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FRERE_STEPS(:), NA(:), DAD_STEPS(:) INTEGER :: FILS(N), STEP(N), LRGROUPS(N) INTEGER, INTENT(IN) :: K472, K469 LOGICAL, INTENT(INOUT) :: GATHER_MATRIX_ALLOCATED INTEGER, INTENT(OUT) :: K142 INTEGER, INTENT(IN) :: KEEP(500), ND_STEPS(:) INTEGER :: K482_LOC, K469_LOC, K38ou20 INTEGER :: I, F, PV, NV, NODE, & SYMTRY, NBQD, AD LOGICAL :: PVSCHANGED INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: NBGROUPS, NBGROUPS_local, NBG_CAPT INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: INPLACE64_GRAPH_COPY #if defined(ptscotch) || defined(scotch) INTEGER :: VSCOTCH LOGICAL :: SCOTCH_IS_THREAD_SAFE INTEGER :: PTHREAD_NUMBER, NOMP #endif K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF K469_LOC = K469 #if defined(ptscotch) || defined(scotch) SCOTCH_IS_THREAD_SAFE = .FALSE. IF (K482_LOC.EQ.2) THEN CALL MUMPS_SCOTCH_VERSION (VSCOTCH) IF (VSCOTCH.GE.7) SCOTCH_IS_THREAD_SAFE=.TRUE. ENDIF IF (K482_LOC.EQ.2.AND.(.NOT.SCOTCH_IS_THREAD_SAFE) ) THEN K469_LOC = 1 ENDIF #endif NBGROUPS = 0 LW = 2_8 * NZ8 ALLOCATE(IW(LW), IPE(N+1), LEN(N), IQ(N), & PVS(NSTEPS), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * LW+int(N,8)+int(K10*(2*N+1),8) IFLAG = -7 CALL MUMPS_SET_IERROR(LW+int(N,8)+int(K10*(2*N+1),8),IERROR) GOTO 501 ENDIF CALL ZMUMPS_ANA_GNEW(N, NZ8, IRN(1), JCN(1), IW(1), LW, IPE(1), & LEN(1), IQ(1), LRGROUPS(1), IWFR, NRORM, NIORM, & IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265,.FALSE., & INPLACE64_GRAPH_COPY) IF (K54.EQ.3) THEN deallocate(IRN) deallocate(JCN) NULLIFY(IRN) NULLIFY(JCN) GATHER_MATRIX_ALLOCATED = .FALSE. ENDIF IF (allocated(IQ)) DEALLOCATE(IQ) LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 501 ENDIF ENDIF #if defined(ptscotch) || defined(scotch) IF (K482_LOC.EQ.2) THEN NOMP=0 !$ NOMP=omp_get_max_threads() IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (PTHREAD_NUMBER) NOMP =1 CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (NOMP) ENDIF ENDIF #endif K142 = 0 PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = omp_get_max_threads() OMP_NUM = min(OMP_NUM,5) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local !$OMP& ) !$OMP& REDUCTION( max : K142) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(MAXFRONT), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", MAXFRONT !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = MAXFRONT !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 3*N !$OMP END ATOMIC ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 500 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE PV = PVS(NODE) NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV, & ND_STEPS(NODE), KEEP(35)) IF (NV .GE. GROUP_SIZE2 & .AND. NV.GE.int(dble(SEP_SIZE)*dble(1.5)) & ) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + ( (NV-1)/GROUP_SIZE2 + 1 ) !$OMP END ATOMIC DO I=1,NV LRGROUPS(WORK(I))=NBG_CAPT+1+(I-1)/GROUP_SIZE2 END DO K142 = max(K142, min(NV,GROUP_SIZE2)) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING( ND_STEPS(NODE), KEEP, & NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K142, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING( ND_STEPS(NODE), KEEP, & NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K142, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NV .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF K142 = max (K142,NV) ENDIF ENDDO !$OMP END DO IF (IFLAG.LT.0) GOTO 500 IF (.NOT.PVSCHANGED) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL #if defined(ptscotch) || defined(scotch) IF (K482_LOC.EQ.2.AND.NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (PTHREAD_NUMBER) ENDIF #endif 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(LEN)) DEALLOCATE(LEN) RETURN END SUBROUTINE ZMUMPS_LR_GROUPING_NEW SUBROUTINE ZMUMPS_AB_LR_MPI_GROUPING( & N, MAPCOL, SIZEMAPCOL, & NSTEPS, LUMAT, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SIZEOFBLOCKS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, & SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, K142, LPOK, LP, & COMM, MYID, NPROCS_ARG, & KEEP, ND_STEPS & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, INTENT(IN) :: MYID, COMM, NPROCS_ARG TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER, INTENT(IN) :: SIZEMAPCOL INTEGER, INTENT(IN) :: MAPCOL(SIZEMAPCOL) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(OUT) :: K142 INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FRERE_STEPS(:), NA(:), DAD_STEPS(:) INTEGER :: FILS(N), STEP(N), LRGROUPS(N) INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: K472, K469 INTEGER, INTENT(IN) :: KEEP(500), ND_STEPS(:) INTEGER :: NPROCS INTEGER :: K482_LOC, K469_LOC, K38ou20, K142_GLOB INTEGER :: I, F, PV, NV, NVEXPANDED, NODE DOUBLE PRECISION :: COMPRESS_RATIO LOGICAL :: PVSCHANGED INTEGER :: PVSCHANGED_INT, PVSCHANGED_INT_GLOB, IPROC INTEGER :: NBGROUPS, NBGROUPS_local, NBG_CAPT INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER :: NBGROUPS_sent INTEGER :: NBNODES_LOC, SIZE_SENT, ISHIFT, & MSGSOU, ILOOP INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, GROUP_SIZE2_TMP, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: MAPCOL_PROVIDED #if defined(ptscotch) || defined(scotch) INTEGER :: VSCOTCH LOGICAL :: SCOTCH_IS_THREAD_SAFE INTEGER :: PTHREAD_NUMBER, NOMP #endif MAPCOL_PROVIDED = (MAPCOL(1).GE.0) NPROCS = NPROCS_ARG IF (.NOT.MAPCOL_PROVIDED) NPROCS=1 K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF (MAPCOL_PROVIDED) THEN CALL MPI_BCAST( FILS(1), N, MPI_INTEGER, & MASTER, COMM, IERR ) ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF K469_LOC = K469 #if defined(ptscotch) || defined(scotch) SCOTCH_IS_THREAD_SAFE = .FALSE. IF (K482_LOC.EQ.2) THEN CALL MUMPS_SCOTCH_VERSION (VSCOTCH) IF (VSCOTCH.GE.7) SCOTCH_IS_THREAD_SAFE=.TRUE. ENDIF IF (K482_LOC.EQ.2.AND.(.NOT.SCOTCH_IS_THREAD_SAFE) ) THEN K469_LOC = 1 ENDIF #endif NBGROUPS = 0 K142 = 0 ALLOCATE( PVS(NSTEPS), STAT=IERR) IF (IERR.GT.0) THEN IFLAG = -7 IERROR = NSTEPS IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", IERROR GOTO 491 ENDIF LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 491 ENDIF ENDIF 491 CONTINUE IF (NPROCS.GT.1) THEN CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) ENDIF IF (IFLAG.LT.0) GOTO 501 #if defined(ptscotch) || defined(scotch) NOMP=0 IF (K482_LOC.EQ.2) THEN !$ NOMP=omp_get_max_threads() IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (PTHREAD_NUMBER) NOMP =1 CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (NOMP) ENDIF ENDIF #endif K142 = 0 PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = omp_get_max_threads() OMP_NUM = min(OMP_NUM,5) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local, !$OMP& NVEXPANDED, COMPRESS_RATIO, IPROC, GROUP_SIZE2_TMP !$OMP& ) !$OMP& REDUCTION( max : K142) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(2*MAXFRONT+1), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 2*MAXFRONT+1 !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 2*MAXFRONT+1 !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 3*N !$OMP END ATOMIC ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 498 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE IF (MAPCOL_PROVIDED) THEN IPROC = MAPCOL(NODE) IF (IPROC.NE.MYID) THEN PVS(NODE) = -999 CYCLE ENDIF ENDIF PV = PVS(NODE) NV = 0 NVEXPANDED = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 NVEXPANDED = NVEXPANDED+SIZEOFBLOCKS(F) WORK(NV) = F F = FILS(F) END DO COMPRESS_RATIO = dble(NVEXPANDED)/dble(NV) CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED, & ND_STEPS(NODE), KEEP(35)) IF (NVEXPANDED .GE. GROUP_SIZE2 & .AND. NVEXPANDED.GE.int(dble(SEP_SIZE)*dble(1.5)) & ) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN GROUP_SIZE2_TMP = GROUP_SIZE2 GROUP_SIZE2_TMP = max( int(dble(GROUP_SIZE2_TMP) & /COMPRESS_RATIO), 1) !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + ( (NV-1)/GROUP_SIZE2_TMP + 1 ) !$OMP END ATOMIC DO I=1,NV LRGROUPS(WORK(I))=NBG_CAPT+1+(I-1)/GROUP_SIZE2_TMP END DO K142 = max(K142, min(NV,GROUP_SIZE2_TMP)) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING_AB( ND_STEPS(NODE), KEEP, & NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K142, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING_AB( ND_STEPS(NODE), KEEP, & NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K142, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NVEXPANDED .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF K142 = max (K142,NV) ENDIF ENDDO !$OMP END DO 498 CONTINUE IF (NPROCS.GT.1) THEN !$OMP MASTER CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) !$OMP END MASTER !$OMP BARRIER ENDIF IF (IFLAG.LT.0) GOTO 500 IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP MASTER IF (K469_LOC.NE.2) THEN IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF !$OMP END MASTER IF (.NOT.MAPCOL_PROVIDED) THEN !$OMP MASTER IF (PVSCHANGED) THEN PVSCHANGED_INT_GLOB = 1 ELSE PVSCHANGED_INT_GLOB = 0 ENDIF !$OMP END MASTER ELSE !$OMP MASTER IF (PVSCHANGED) THEN PVSCHANGED_INT = 1 ELSE PVSCHANGED_INT = 0 ENDIF CALL MPI_ALLREDUCE( PVSCHANGED_INT, PVSCHANGED_INT_GLOB, 1, & MPI_INTEGER, & MPI_MAX, COMM, IERR_MPI ) PVSCHANGED_INT_GLOB = 1 IF (PVSCHANGED_INT_GLOB.NE.0) THEN IF (NPROCS.GT.1) THEN ALLOCATE(WORKH(2*N+3*NSTEPS+1), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of ", & "size: ", 2*MAXFRONT+1 IFLAG = -7 IERROR = 2*N+3*NSTEPS+1 ENDIF CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) IF (IFLAG.LT.0) GOTO 499 IF (MYID.EQ.MASTER) THEN IPROC = 0 DO WHILE (IPROC.NE.NPROCS-1) IPROC = IPROC + 1 CALL MPI_RECV( NBNODES_LOC, 1, MPI_INTEGER, & MPI_ANY_SOURCE, & GROUPING, COMM, STATUS, IERR ) MSGSOU = STATUS( MPI_SOURCE ) IF (NBNODES_LOC.EQ.0) THEN CYCLE ENDIF CALL MPI_RECV( NBGROUPS_sent, 1, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) CALL MPI_RECV( SIZE_SENT, 1, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) CALL MPI_RECV( WORKH, SIZE_SENT, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) ISHIFT = 0 DO ILOOP=1, NBNODES_LOC ISHIFT = ISHIFT+1 NODE = WORKH (ISHIFT) ISHIFT = ISHIFT+1 NV = WORKH(ISHIFT) PVS(NODE) = WORKH(ISHIFT+1) STEP(WORKH(ISHIFT+1)) = NODE IF (STEP(WORKH(ISHIFT+1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORKH(ISHIFT+1) ELSE K20 = WORKH(ISHIFT+1) END IF END IF DO I=2, NV STEP(WORKH(I+ISHIFT)) = -NODE END DO DO I=1, NV FILS(WORKH(I+ISHIFT)) = WORKH(I+1+ISHIFT) IF (WORKH(NV+1+I+ISHIFT).LT.0) THEN LRGROUPS(WORKH(I+ISHIFT)) = & - NBGROUPS + WORKH(NV+1+I+ISHIFT) ELSE LRGROUPS(WORKH(I+ISHIFT)) = & NBGROUPS + WORKH(NV+1+I+ISHIFT) END IF END DO ISHIFT = ISHIFT + 2*NV +1 END DO NBGROUPS = NBGROUPS + NBGROUPS_sent ENDDO ELSE NBNODES_LOC = 0 SIZE_SENT = 0 ISHIFT = 0 DO NODE = 1,NSTEPS IPROC = MAPCOL(NODE) IF (IPROC.EQ.MYID) THEN NBNODES_LOC = NBNODES_LOC + 1 ISHIFT = ISHIFT +1 WORKH(ISHIFT) = NODE ISHIFT = ISHIFT +1 NV = 0 F = PVS(NODE) DO WHILE (F.GT.0) NV = NV + 1 WORKH(NV+ISHIFT) = F F = FILS(F) ENDDO WORKH(ISHIFT) = NV WORKH(NV+1+ISHIFT) = F DO I=1, NV WORKH(NV+1+I+ISHIFT) = LRGROUPS(WORKH(I+ISHIFT)) ENDDO ISHIFT = ISHIFT + 2*NV+1 ENDIF ENDDO SIZE_SENT = ISHIFT CALL MPI_SEND( NBNODES_LOC, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) IF (NBNODES_LOC.GT.0) THEN CALL MPI_SEND( NBGROUPS, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) CALL MPI_SEND( SIZE_SENT, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) CALL MPI_SEND( WORKH, SIZE_SENT, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) ENDIF ENDIF ENDIF ENDIF 499 CONTINUE !$OMP END MASTER ENDIF !$OMP BARRIER IF (IFLAG.LT.0) GOTO 500 IF (MYID.EQ.MASTER) THEN IF (PVSCHANGED_INT_GLOB.EQ.0) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO ENDIF 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL IF (NPROCS.GT.1) THEN K142_GLOB = 0 CALL MPI_REDUCE( K142, K142_GLOB, 1, & MPI_INTEGER, & MPI_MAX, MASTER, COMM, IERR_MPI ) K142 = K142_GLOB ENDIF #if defined(ptscotch) || defined(scotch) IF (K482_LOC.EQ.2.AND.NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (PTHREAD_NUMBER) ENDIF #endif 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) RETURN END SUBROUTINE ZMUMPS_AB_LR_MPI_GROUPING END MODULE ZMUMPS_ANA_LR MUMPS_5.8.1/src/dmumps_save_restore_files.F0000664000175000017500000002740715042446437020627 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if ! defined(NO_SAVE_RESTORE) MODULE DMUMPS_SAVE_RESTORE_FILES USE DMUMPS_STRUC_DEF IMPLICIT NONE INTEGER, PARAMETER :: LEN_SAVE_FILE = 1318 CONTAINS SUBROUTINE MUMPS_READ_HEADER(fileunit, ierr, size_read, SIZE_INT & ,SIZE_INT8, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE & ,READ_ARITH, READ_INT_TYPE_64 & ,READ_OOC_FILE_NAME_LENGTH, READ_OOC_FIRST_FILE_NAME & ,READ_HASH,READ_SYM,READ_PAR,READ_NPROCS & ,FORTRAN_VERSION_OK) INTEGER,intent(in) :: fileunit INTEGER,intent(out) :: ierr INTEGER(8), intent(inout) :: size_read INTEGER,intent(in) :: SIZE_INT, SIZE_INT8 INTEGER(8), intent(out) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE CHARACTER, intent(out) :: READ_ARITH LOGICAL, intent(out) :: READ_INT_TYPE_64 INTEGER, intent(out) :: READ_OOC_FILE_NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE),intent(out)::READ_OOC_FIRST_FILE_NAME CHARACTER(len=23), intent(out) :: READ_HASH INTEGER, intent(out) :: READ_SYM,READ_PAR,READ_NPROCS LOGICAL, intent(out) :: FORTRAN_VERSION_OK CHARACTER(len=5) :: READ_FORTRAN_VERSION INTEGER :: SIZE_CHARACTER, SIZE_LOGICAL INTEGER :: dummy SIZE_CHARACTER = 1 SIZE_LOGICAL = 4 FORTRAN_VERSION_OK = .true. read(fileunit,iostat=ierr) READ_FORTRAN_VERSION if(ierr.ne.0) GOTO 100 if (READ_FORTRAN_VERSION.NE."MUMPS") THEN ierr = 0 FORTRAN_VERSION_OK = .false. GOTO 100 endif size_read=size_read+int(5*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_HASH if(ierr.ne.0) GOTO 100 size_read=size_read+int(23*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(ierr.ne.0) GOTO 100 size_read=size_read+int(2*SIZE_INT8,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_ARITH if(ierr.ne.0) GOTO 100 size_read=size_read+int(1,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_SYM,READ_PAR,READ_NPROCS if(ierr.ne.0) GOTO 100 size_read=size_read+int(3*SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_INT_TYPE_64 if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_LOGICAL,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_OOC_FILE_NAME_LENGTH if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif IF(READ_OOC_FILE_NAME_LENGTH.EQ.-999) THEN read(fileunit,iostat=ierr) dummy if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif ELSE read(fileunit,iostat=ierr) & READ_OOC_FIRST_FILE_NAME(1:READ_OOC_FILE_NAME_LENGTH) if(ierr.ne.0) GOTO 100 size_read=size_read+int( & READ_OOC_FILE_NAME_LENGTH*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif ENDIF 100 continue RETURN END SUBROUTINE MUMPS_READ_HEADER SUBROUTINE DMUMPS_CHECK_HEADER(id, BASIC_CHECK, READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) INCLUDE 'mpif.h' TYPE (DMUMPS_STRUC),intent(inout) :: id LOGICAL, intent(in) :: BASIC_CHECK LOGICAL, intent(in) :: READ_INT_TYPE_64 CHARACTER(len=23), intent(in) :: READ_HASH INTEGER, intent(in) :: READ_NPROCS CHARACTER, intent(in) :: READ_ARITH INTEGER, intent(in) :: READ_SYM,READ_PAR LOGICAL :: INT_TYPE_64 CHARACTER(len=23) :: HASH_MASTER CHARACTER :: ARITH INTEGER :: IERR IF(id%KEEP(10).EQ.1) THEN INT_TYPE_64=.TRUE. ELSE INT_TYPE_64=.FALSE. ENDIF if(INT_TYPE_64.neqv.READ_INT_TYPE_64) THEN id%INFO(1) = -73 id%INFO(2) = 2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(id%MYID.EQ.0) THEN HASH_MASTER=READ_HASH ENDIF call MPI_BCAST(HASH_MASTER,23,MPI_CHARACTER,0,id%COMM,IERR) if(HASH_MASTER.ne.READ_HASH) THEN id%INFO(1) = -73 id%INFO(2) = 3 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(id%NPROCS.ne.READ_NPROCS) THEN id%INFO(1) = -73 id%INFO(2) = 4 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 IF (.NOT.BASIC_CHECK) THEN ARITH="DMUMPS"(1:1) if(ARITH.ne.READ_ARITH) THEN id%INFO(1) = -73 id%INFO(2) = 5 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if((id%MYID.EQ.0).AND.(id%SYM.ne.READ_SYM)) THEN id%INFO(1) = -73 id%INFO(2) = 6 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if((id%MYID.EQ.0).AND.(id%PAR.ne.READ_PAR)) THEN write (*,*) id%MYID, 'PAR ',id%PAR, 'READ_PAR ', READ_PAR id%INFO(1) = -73 id%INFO(2) = 7 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF 100 continue RETURN END SUBROUTINE DMUMPS_CHECK_HEADER SUBROUTINE MUMPS_CLEAN_SAVED_DATA(MYID,ierr,SUPPFILE,INFOFILE) INCLUDE 'mpif.h' INTEGER,intent(in) :: MYID INTEGER,intent(out) :: ierr CHARACTER(len=LEN_SAVE_FILE),intent(in):: SUPPFILE,INFOFILE INTEGER::supp,tmp_err ierr = 0 tmp_err = 0 CALL MUMPS_FIND_UNIT(supp) IF ( supp .EQ. -1 ) THEN ierr=-79 RETURN ENDIF open(UNIT=supp,FILE=SUPPFILE,STATUS='old', & form='unformatted',iostat=tmp_err) if (tmp_err.eq.0) THEN close(UNIT=supp,STATUS='delete',iostat=tmp_err) if(tmp_err.ne.0) then ierr = 1 tmp_err = 0 endif endif if (ierr .eq. 0) then if (tmp_err.ne.0) then ierr = 1 tmp_err = 0 endif open(UNIT=supp,FILE=INFOFILE,STATUS='old',iostat=tmp_err) if (tmp_err.eq.0) THEN close(UNIT=supp,STATUS='delete',iostat=tmp_err) endif if (tmp_err.ne.0) THEN ierr = ierr + 2 tmp_err = 0 endif endif RETURN END SUBROUTINE MUMPS_CLEAN_SAVED_DATA SUBROUTINE DMUMPS_GET_SAVE_FILES(id,SAVE_FILE,INFO_FILE) INCLUDE 'mpif.h' TYPE (DMUMPS_STRUC),intent(inout) :: id CHARACTER(len=LEN_SAVE_FILE),intent(out):: SAVE_FILE, INFO_FILE INTEGER::len_save_dir,len_save_prefix INTEGER, PARAMETER :: SAVE_PREFIX_MAX_LENGTH = 255 INTEGER, PARAMETER :: SAVE_DIR_MAX_LENGTH = 1023 CHARACTER(len=SAVE_DIR_MAX_LENGTH) :: tmp_save_dir CHARACTER(len=SAVE_DIR_MAX_LENGTH) :: save_dir CHARACTER(len=SAVE_PREFIX_MAX_LENGTH) :: save_prefix CHARACTER(len=SAVE_PREFIX_MAX_LENGTH) :: tmp_save_prefix CHARACTER(len=10):: STRING_MYID CHARACTER:: LAST_CHAR_DIR INFO_FILE='' SAVE_FILE='' tmp_save_dir='' tmp_save_prefix='' IF(id%SAVE_DIR.EQ."NAME_NOT_INITIALIZED") THEN call MUMPS_GET_SAVE_DIR_C(len_save_dir,tmp_save_dir) if (len_save_dir > SAVE_DIR_MAX_LENGTH) then id%INFO(1) = -77 id%INFO(2) = SAVE_DIR_MAX_LENGTH else if(tmp_save_dir(1:len_save_dir).EQ."NAME_NOT_INITIALIZED") & then id%INFO(1) = -77 id%INFO(2) = 0 else save_dir=trim(adjustl(tmp_save_dir(1:len_save_dir))) len_save_dir=len_trim(save_dir(1:len_save_dir)) endif ELSE save_dir=trim(adjustl(id%SAVE_DIR)) len_save_dir=len_trim(save_dir) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 IF(id%SAVE_PREFIX.EQ."NAME_NOT_INITIALIZED") THEN call MUMPS_GET_SAVE_PREFIX_C(len_save_prefix,tmp_save_prefix) if(len_save_prefix.GT.SAVE_PREFIX_MAX_LENGTH) then id%INFO(1)=-77 id%INFO(2)=-SAVE_PREFIX_MAX_LENGTH else if(tmp_save_prefix(1:len_save_prefix).EQ. & "NAME_NOT_INITIALIZED") then save_prefix="save" len_save_prefix=len_trim(save_prefix) else save_prefix= & trim(adjustl(tmp_save_prefix(1:len_save_prefix))) len_save_prefix=len_trim(save_prefix(1:len_save_prefix)) endif ELSE save_prefix=trim(adjustl(id%SAVE_PREFIX)) len_save_prefix=len_trim(save_prefix) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(STRING_MYID,'(I10)') id%MYID LAST_CHAR_DIR=save_dir(len_save_dir:len_save_dir) if(LAST_CHAR_DIR.NE."/") then SAVE_FILE=trim(adjustl(save_dir))//"/" else SAVE_FILE=trim(adjustl(save_dir)) endif INFO_FILE=trim(adjustl(SAVE_FILE)) SAVE_FILE=trim(adjustl(SAVE_FILE)) & //trim(adjustl(save_prefix)) & //"_" & //trim(adjustl(STRING_MYID)) & //".mumps" INFO_FILE=trim(adjustl(INFO_FILE)) & //trim(adjustl(save_prefix)) & //"_" & //trim(adjustl(STRING_MYID)) & //".info" 100 continue RETURN END SUBROUTINE DMUMPS_GET_SAVE_FILES SUBROUTINE DMUMPS_CHECK_FILE_NAME(id,NAME_LENGTH,FILE_NAME,CHECK) TYPE (DMUMPS_STRUC),intent(in) :: id INTEGER,intent(in) :: NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE),intent(in) :: FILE_NAME LOGICAL,intent(out) :: CHECK INTEGER :: I CHECK = .false. IF (NAME_LENGTH.NE.-999) THEN IF (associated(id%OOC_FILE_NAME_LENGTH) .AND. & associated(id%OOC_FILE_NAMES)) THEN IF (NAME_LENGTH .EQ. id%OOC_FILE_NAME_LENGTH(1)) THEN CHECK = .true. I = 1 DO WHILE(I.LE.NAME_LENGTH) IF (FILE_NAME(I:I).NE.id%OOC_FILE_NAMES(1,I)) THEN CHECK = .false. I = NAME_LENGTH + 1 ELSE I = I + 1 ENDIF END DO ENDIF ENDIF ENDIF END SUBROUTINE DMUMPS_CHECK_FILE_NAME END MODULE DMUMPS_SAVE_RESTORE_FILES #else SUBROUTINE DMUMPS_SAVE_FILES_RETURN() RETURN END SUBROUTINE DMUMPS_SAVE_FILES_RETURN #endif MUMPS_5.8.1/src/zfac_b.F0000664000175000017500000006140215042446441014567 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_FAC_B( N, S_IS_POINTERS, LA, LIW, SYM_PERM, & NA, LNA, NE_STEPS, NFSIZ, FILS, STEP, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PTRAR, LDPTRAR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, PTRIST, & PTLUST_S, PTRFAC, IW1, IW2, ITLOC, RHS_MUMPS, POOL, LPOOL, & CNTL1, ICNTL, INFO, RINFO, KEEP, KEEP8, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & ZMUMPS_LBUF, INTARR, DBLARR, root, roota, NELT, FRTPTR, FRTELT, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, & DKEEP, PIVNUL_LIST_STRUCT, LRGROUPS & ,IPOOL_B_L0_OMP, LPOOL_B_L0_OMP, IPOOL_A_L0_OMP, & LPOOL_A_L0_OMP, L_VIRT_L0_OMP, VIRT_L0_OMP, & VIRT_L0_OMP_MAPPING, L_PHYS_L0_OMP, PHYS_L0_OMP, PERM_L0_OMP, & PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, THREAD_LA, & L0_OMP_FACTORS, LL0_OMP_FACTORS, I4_L0_OMP, NBSTATS_I4, & NBCOLS_I4, I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) USE MUMPS_LOAD USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_ALLOC_CB, & MUMPS_BUF_DEALL_CB USE ZMUMPS_BUF, ONLY : ZMUMPS_BUF_MAX_ARRAY_MINSIZE & , ZMUMPS_BUF_DEALL_MAX_ARRAY USE ZMUMPS_FAC_S_IS_POINTERS_M, ONLY : ZMUMPS_S_IS_POINTERS_T USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T USE OMP_LIB USE MUMPS_TPS_M USE ZMUMPS_TPS_M USE ZMUMPS_FAC_OMP_M USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY: ZMUMPS_DM_ALLOC_S_WK, & ZMUMPS_DM_FREE_S_WK USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC & , ZMUMPS_L0OMPFAC_T IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER(8) :: LA INTEGER N,LIW,LPOOL,SLAVEF,COMM_NODES INTEGER MYID, MYID_NODES,LNA TYPE (ZMUMPS_S_IS_POINTERS_T) :: S_IS_POINTERS DOUBLE PRECISION RINFO(40) INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES INTEGER :: BUFR( LBUFR ) INTEGER, INTENT( IN ) :: ZMUMPS_LBUF INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER NELT, LDPTRAR INTEGER FRTPTR(*), FRTELT(*) DOUBLE PRECISION CNTL1 INTEGER ICNTL(60) INTEGER INFO(80), KEEP(500) INTEGER(8) KEEP8(150) INTEGER LRGROUPS(KEEP(280)) INTEGER SYM_PERM(N), NA(LNA), & NE_STEPS(KEEP(28)), FILS(N), & FRERE(KEEP(28)), NFSIZ(KEEP(28)), & DAD(KEEP(28)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER STEP(N) INTEGER(8), INTENT(IN) :: PTRAR(LDPTRAR,2) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IW1(2*KEEP(28)), ITLOC(N+KEEP(253)), POOL(LPOOL) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: IW2(2*KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER COMM_LOAD, ASS_IRECV INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) DOUBLE PRECISION SEUIL, SEUIL_LDLT_NIV2 TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER, INTENT (IN) :: LPOOL_B_L0_OMP INTEGER, INTENT (IN) :: IPOOL_B_L0_OMP( LPOOL_B_L0_OMP ) INTEGER, INTENT (IN) :: LPOOL_A_L0_OMP INTEGER, INTENT (IN) :: IPOOL_A_L0_OMP( LPOOL_A_L0_OMP ) INTEGER, INTENT (IN) :: L_PHYS_L0_OMP INTEGER, INTENT (IN) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT (IN) :: L_VIRT_L0_OMP INTEGER, INTENT (IN) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT (IN) :: VIRT_L0_OMP_MAPPING( L_VIRT_L0_OMP ) INTEGER, INTENT (IN) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT (IN) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT (IN) :: LL0_OMP_MAPPING INTEGER, INTENT (OUT):: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INTEGER, INTENT (IN) :: LL0_OMP_FACTORS TYPE(ZMUMPS_L0OMPFAC_T), INTENT (INOUT) :: L0_OMP_FACTORS( & LL0_OMP_FACTORS ) INTEGER, INTENT (IN) :: NBSTATS_I4, NBSTATS_I8 INTEGER, INTENT (IN) :: NBCOLS_I4, NBCOLS_I8 INTEGER, INTENT (IN) :: I4_L0_OMP(NBSTATS_I4, NBCOLS_I4) INTEGER(8), INTENT (IN) :: I8_L0_OMP(NBSTATS_I8, NBCOLS_I8) INTEGER(8), INTENT ( IN ) :: THREAD_LA INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER allocok DOUBLE PRECISION UULOC INTEGER IERR INTEGER LP, MPRINT LOGICAL LPOK INTEGER NSTK,PTRAST INTEGER PIMASTER, PAMASTER LOGICAL PROK DOUBLE PRECISION,PARAMETER :: ZERO = 0.0D0 INTEGER I INTEGER LTPS_ARR TYPE (MUMPS_TPS_T), DIMENSION(:), ALLOCATABLE :: MUMPS_TPS_ARR TYPE (ZMUMPS_TPS_T), DIMENSION(:), ALLOCATABLE :: ZMUMPS_TPS_ARR INTEGER NBROOT_UNDER_L0 INTEGER :: NSTEPSDONE DOUBLE PRECISION :: OPASS, OPELI INTEGER :: NELVA, COMP INTEGER :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV, NULLNEGPV INTEGER :: NB22T1, NB22T2, NBTINY, DET_EXP, DET_SIGN COMPLEX(kind=8) :: DET_MANT INTEGER :: NTOTPVTOT INTEGER(8) :: POSFAC, LRLU, IPTRLU, LRLUS INTEGER IWPOS, LEAF, NBROOT, NROOT INTEGER :: LIW_ARG_FAC_PAR INTEGER(8) :: LA_ARG_FAC_PAR COMPLEX(kind=8), TARGET:: CDUMMY(1) INTEGER, TARGET :: IDUMMY(1) LOGICAL :: IW_DUMMY, A_DUMMY, & IW_ALLOCATED_HERE, A_ALLOCATED_HERE KEEP(41)=0 KEEP(42)=0 LP = ICNTL(1) LPOK = (LP.GT.0) .AND. (ICNTL(4).GE.1) MPRINT = ICNTL(2) PROK = (MPRINT.GT.0) .AND. (ICNTL(4).GE.2) UULOC = CNTL1 PIMASTER = 1 NSTK = PIMASTER + KEEP(28) PTRAST = 1 PAMASTER = 1 + KEEP(28) IF (KEEP(4).LE.0) KEEP(4)=32 IF (KEEP(5).LE.0) KEEP(5)=16 IF (KEEP(5).GT.KEEP(4)) KEEP(5) = KEEP(4) IF (KEEP(6).LE.0) KEEP(6)=24 IF (KEEP(3).LE.KEEP(4)) KEEP(3)=KEEP(4)*2 IF (KEEP(6).GT.KEEP(3)) KEEP(6) = KEEP(3) POSFAC = 1_8 IWPOS = 1 LRLU = LA LRLUS = LRLU KEEP8(62) = 0_8 KEEP8(63) = 0_8 KEEP8(64) = 0_8 KEEP8(65) = 0_8 KEEP8(66) = 0_8 KEEP8(68) = 0_8 KEEP8(69) = 0_8 KEEP8(70) = 0_8 KEEP8(71) = 0_8 KEEP8(73) = 0_8 KEEP8(74) = 0_8 IPTRLU = LRLU DKEEP(19)=huge(0.0D0) DKEEP(20)=huge(0.0D0) DKEEP(21)=0.0D0 NSTEPSDONE = 0 OPASS = 0.0D0 OPELI = 0.0D0 NELVA = 0 COMP = 0 MAXFRT = 0 NMAXNPIV = 0 NTOTPV = 0 NOFFNEGPV = 0 NULLNEGPV = 0 NB22T1 = 0 NB22T2 = 0 NBTINY = 0 DET_EXP = 0 DET_SIGN = 1 DET_MANT = cmplx(1.0D0,0.0D0, kind=kind(1.0D0)) IW1(NSTK:NSTK+KEEP(28)-1) = NE_STEPS(1:KEEP(28)) CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, NROOT, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP, STEP, & PROCNODE_STEPS) IF (KEEP(400) .GT. 0 & ) THEN IF (LPOOL .NE. LPOOL_A_L0_OMP) THEN WRITE(*,*) "Check LPOOL vs. LPOOL_A_L0_OMP", & LPOOL, LPOOL_A_L0_OMP, KEEP(28) CALL MUMPS_ABORT() ENDIF DO I = 1, LPOOL POOL(I) = IPOOL_A_L0_OMP(I) ENDDO ELSE CALL MUMPS_INIT_POOL_DIST(N, LEAF, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, & POOL, LPOOL) CALL ZMUMPS_INIT_POOL_LAST3(POOL, LPOOL, LEAF) ENDIF CALL MUMPS_LOAD_INIT_SBTR_STRUCT(POOL, LPOOL,KEEP,KEEP8) IF ( KEEP( 38 ) .NE. 0 ) THEN NBROOT = NBROOT + root%NPROW * root%NPCOL - 1 END IF IF ( root%yes ) THEN IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(KEEP(38))), & KEEP(199) ) & .NE. MYID_NODES ) THEN NROOT = NROOT + 1 END IF END IF PTRIST(1:KEEP(28))=0 PTLUST_S(1:KEEP(28))=0 PTRFAC(1:KEEP(28))=-99999_8 IW2(PTRAST:PTRAST+KEEP(28)-1)=0_8 IW1(PIMASTER:PIMASTER+KEEP(28)-1)=-99999_8 KEEP(405) = 0 NBROOT_UNDER_L0 = 0 IF (KEEP(400).GT.0 & ) THEN KEEP(405)=1 ALLOCATE( MUMPS_TPS_ARR( KEEP(400) ), stat=allocok ) IF (allocok .GT. 0) THEN IF (LPOK) THEN WRITE(LP,*) "Problem allocating MUMPS_TPS_ARR", & KEEP(400) ENDIF CALL MUMPS_ABORT() ENDIF ALLOCATE( ZMUMPS_TPS_ARR( KEEP(400) ), stat=allocok ) IF (allocok .GT. 0) THEN WRITE(*,*) "Problem allocating ZMUMPS_TPS_ARR", KEEP(400) CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_FAC_L0_OMP(N,LIW, IW1(NSTK), NFSIZ, FILS,STEP,FRERE, & DAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, PTRIST, IW2(PTRAST), & IW1(PIMASTER), IW2(PAMASTER), PTRAR(1,2), PTRAR(1,1), & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, RINFO, NROOT, NBROOT, NBROOT_UNDER_L0, & UULOC, ICNTL, PTLUST_S, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS,SLAVEF, COMM_NODES, MYID, MYID_NODES, BUFR, & LBUFR,LBUFR_BYTES,INTARR,DBLARR,root,roota,SYM_PERM,NELT,FRTPTR, & FRTELT, LDPTRAR, COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB, NE_STEPS, DKEEP, PIVNUL_LIST_STRUCT, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, L_VIRT_L0_OMP, & VIRT_L0_OMP, VIRT_L0_OMP_MAPPING, L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, & THREAD_LA, MUMPS_TPS_ARR, ZMUMPS_TPS_ARR, NSTEPSDONE, & OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, NOFFNEGPV, & NULLNEGPV, NB22T1, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & LRGROUPS(1), L0_OMP_FACTORS, LL0_OMP_FACTORS, & I4_L0_OMP, NBSTATS_I4, NBCOLS_I4, & I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 ) KEEP(405)=0 DKEEP(16) = OPELI KEEP8(75)=KEEP8(76) KEEP8(63)=KEEP8(74) KEEP8(62) = KEEP8(74)-KEEP8(62) IF (INFO(1) .LT. 0) THEN KEEP8(69) = KEEP8(73) ENDIF KEEP8(74) = KEEP8(73) IF ((INFO(1).GE.0).AND.(KEEP8(74).GT.KEEP8(75))) THEN INFO(1) = -19 CALL MUMPS_SET_IERROR ( & KEEP8(74)-KEEP8(75), INFO(2)) IF (LPOK) THEN WRITE(LP,'(/A/,A,I8,A,I10/,A/,A/)') & '** ERROR: memory allowed (ICNTL(23)) is not large enough:', & ' INFO(1)=', INFO(1), ' INFO(2)=', INFO(2), & ' memory used at the end of the treatment of L0 thread ', & ' does not enable processing nodes above L0 thread ' ENDIF ENDIF KEEP8(66) = KEEP8(68) KEEP8(65) = KEEP8(64) + KEEP8(71) ENDIF KEEP8(67) = LRLUS IW_ALLOCATED_HERE = .FALSE. A_ALLOCATED_HERE = .FALSE. IF (associated(S_IS_POINTERS%IW)) THEN WRITE(*,*) " Internal error ZMUMPS_FAC_B IW" CALL MUMPS_ABORT() ENDIF IF (INFO(1) .GE. 0 ) THEN ALLOCATE(S_IS_POINTERS%IW(LIW), stat=allocok) IF (allocok .GT.0) THEN INFO(1) = -13 INFO(2) = LIW IF (LPOK) THEN WRITE(LP,*) & 'Allocation error for id%IS(',LIW,') on worker', & MYID_NODES ENDIF ELSE IW_ALLOCATED_HERE = .TRUE. ENDIF ENDIF IF (INFO(1) .GE. 0) THEN IF (.NOT. associated(S_IS_POINTERS%A)) THEN CALL ZMUMPS_DM_ALLOC_S_WK(S_IS_POINTERS%A, & LA, allocok, KEEP(430), KEEP(35) ) IF (allocok .GT. 0) THEN INFO(1) = -13 CALL MUMPS_SETI8TOI4(LA, INFO(2)) DEALLOCATE(S_IS_POINTERS%IW); NULLIFY(S_IS_POINTERS%IW) IW_ALLOCATED_HERE = .FALSE. KEEP8(23)=0_8 ELSE A_ALLOCATED_HERE = .TRUE. KEEP8(23)=LA ENDIF ENDIF ENDIF IF (INFO(1) .GE. 0) THEN CALL MUMPS_BUF_ALLOC_CB( ZMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1)= -13 INFO(2)= (ZMUMPS_LBUF+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) & 'Allocation error in ZMUMPS_BUF_ALLOC_CB' & ,INFO(2), ' on worker', MYID_NODES ENDIF ELSE IF ((KEEP(50).EQ.2).AND.(KEEP(219).NE.0)) THEN CALL ZMUMPS_BUF_MAX_ARRAY_MINSIZE(max(KEEP(108),1),IERR) IF (IERR .NE. 0) THEN INFO(1) = -13 INFO(2) = max(KEEP(108),1) END IF ENDIF ENDIF ENDIF IF ( KEEP(400) .EQ. 0 & ) THEN LTPS_ARR = 1 ALLOCATE( MUMPS_TPS_ARR(1)) ALLOCATE(ZMUMPS_TPS_ARR(1)) ELSE LTPS_ARR = KEEP(400) ENDIF IW_DUMMY = .FALSE.; A_DUMMY = .FALSE.; IF (INFO(1) .GE. 0) THEN LIW_ARG_FAC_PAR = LIW LA_ARG_FAC_PAR = LA ELSE IF (IW_ALLOCATED_HERE) THEN DEALLOCATE(S_IS_POINTERS%IW) NULLIFY(S_IS_POINTERS%IW) IW_ALLOCATED_HERE = .FALSE. ENDIF IF (A_ALLOCATED_HERE) THEN CALL ZMUMPS_DM_FREE_S_WK(S_IS_POINTERS%A, KEEP(430)) NULLIFY(S_IS_POINTERS%A) A_ALLOCATED_HERE = .FALSE. ENDIF LIW_ARG_FAC_PAR = 1 LA_ARG_FAC_PAR = 1_8 IF (.NOT. associated(S_IS_POINTERS%IW)) THEN S_IS_POINTERS%IW => IDUMMY IW_DUMMY = .TRUE. ENDIF IF (.NOT. associated(S_IS_POINTERS%A)) THEN S_IS_POINTERS%A => CDUMMY A_DUMMY = .TRUE. ENDIF ENDIF IF ( INFO(1) .LT. 0 ) THEN CALL ZMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP ) ENDIF KEEP(398)=NSTEPSDONE CALL ZMUMPS_FAC_PAR_I(N,S_IS_POINTERS%IW(1),LIW_ARG_FAC_PAR, & S_IS_POINTERS%A(1),LA_ARG_FAC_PAR,IW1(NSTK), NFSIZ,FILS,STEP, & FRERE,DAD,CAND,ISTEP_TO_INIV2, TAB_POS_IN_PERE, NSTEPSDONE, & OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, NOFFNEGPV, & NULLNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & PTRIST, IW2(PTRAST), IW1(PIMASTER), IW2(PAMASTER), & PTRAR(1,2), PTRAR(1,1), PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, POOL, LPOOL, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & MUMPS_TPS_ARR, ZMUMPS_TPS_ARR, LTPS_ARR, & RINFO, POSFAC, IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NROOT, NBROOT, & NBROOT_UNDER_L0, & UULOC, ICNTL, PTLUST_S, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS,SLAVEF,MYID,COMM_NODES, MYID_NODES, BUFR, LBUFR, & LBUFR_BYTES, INTARR, DBLARR, root, roota, SYM_PERM, NELT, FRTPTR, & FRTELT, LDPTRAR, COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB,NE_STEPS, DKEEP(1),PIVNUL_LIST_STRUCT, & LRGROUPS(1) ) IF (IW_DUMMY) THEN NULLIFY( S_IS_POINTERS%IW ) ENDIF IF (A_DUMMY) THEN NULLIFY( S_IS_POINTERS%A ) ENDIF IF ((KEEP(50).EQ.2).AND.(KEEP(219).NE.0)) THEN CALL ZMUMPS_BUF_DEALL_MAX_ARRAY() ENDIF CALL MUMPS_BUF_DEALL_CB( IERR ) RINFO(2) = dble(OPASS) RINFO(3) = dble(OPELI) INFO(13) = NELVA INFO(14) = COMP KEEP(33) = MAXFRT; INFO(11) = MAXFRT KEEP(246) = NMAXNPIV KEEP(89) = NTOTPV; INFO(23) = NTOTPV INFO(12) = NOFFNEGPV INFO(40) = NULLNEGPV KEEP(103) = NB22T1 KEEP(105) = NB22T2 KEEP(98) = NBTINY IF (KEEP(258) .NE. 0) THEN KEEP(260) = KEEP(260) * DET_SIGN KEEP(259) = KEEP(259) + DET_EXP CALL ZMUMPS_UPDATEDETER( DET_MANT, DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(400) .GT. 0 & ) THEN IF (LL0_OMP_FACTORS.NE.KEEP(400)) THEN WRITE(*,*) "Internal error in ZMUMPS_FAC_B, KEEP(400), L..=", & KEEP(400), LL0_OMP_FACTORS CALL MUMPS_ABORT() ENDIF IF ( INFO(1) .GE. 0 ) THEN CALL ZMUMPS_L0OMP_COPY_IW(S_IS_POINTERS%IW, & LIW, IWPOS, MUMPS_TPS_ARR, KEEP, PTLUST_S, & ICNTL, INFO) ENDIF !$OMP PARALLEL DO DO I=1, KEEP(400) IF (INFO(1) .LT. 0) THEN IF ( associated( L0_OMP_FACTORS(I)%A ) ) THEN DEALLOCATE( L0_OMP_FACTORS(I)%A ) NULLIFY ( L0_OMP_FACTORS(I)%A ) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -L0_OMP_FACTORS(I)%LA, .TRUE., & KEEP8, INFO(1), INFO(2), .TRUE., .FALSE. ) ENDIF L0_OMP_FACTORS(I)%LA = -99999_8 ENDIF IF (associated(MUMPS_TPS_ARR(I)%IW)) THEN DEALLOCATE(MUMPS_TPS_ARR(I)%IW) NULLIFY(MUMPS_TPS_ARR(I)%IW) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -((int(MUMPS_TPS_ARR(I)%LIW,8) * int(KEEP(34),8)) & / int(KEEP(35),8)), & .TRUE., & KEEP8, INFO(1), INFO(2), .TRUE., .FALSE. ) ENDIF ENDDO !$OMP END PARALLEL DO ENDIF IF (allocated(MUMPS_TPS_ARR)) THEN DEALLOCATE(MUMPS_TPS_ARR) ENDIF IF (allocated(ZMUMPS_TPS_ARR)) THEN DEALLOCATE(ZMUMPS_TPS_ARR) ENDIF POSFAC = POSFAC -1_8 IWPOS = IWPOS -1 IF (KEEP(201).LE.0) THEN IF (KEEP(201) .EQ. -1 .AND. INFO(1) .LT. 0) THEN POSFAC = 0_8 ENDIF KEEP8(31) = POSFAC RINFO(6) = ZERO ELSE RINFO(6) = dble(KEEP8(31)*int(KEEP(35),8))/1D6 ENDIF KEEP8(48) = KEEP8(31)+KEEP8(71)+KEEP8(64) KEEP(32) = IWPOS CALL MUMPS_SETI8TOI4(KEEP8(48), INFO(9)) INFO(10) = KEEP(32) KEEP8(67) = LA - KEEP8(67) CALL MPI_ALLREDUCE(NTOTPV, NTOTPVTOT, 1, MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR) IF ( ( (INFO(1).EQ.-10 .OR. INFO(1).EQ.-40) & .AND. (NTOTPVTOT.EQ.N) ) & .OR. ( NTOTPVTOT.GT.N ) ) THEN write(*,*) ' Error 1 NTOTPVTOT=', NTOTPVTOT,N CALL MUMPS_ABORT() ENDIF IF ( (KEEP(19).NE.0 ) .AND. (NTOTPVTOT.NE.N) .AND. & (INFO(1).GE.0) ) THEN write(*,*) ' Error 2 NTOTPVTOT=', NTOTPVTOT CALL MUMPS_ABORT() ENDIF IF ( (INFO(1) .GE. 0 ) & .AND. (NTOTPVTOT.NE.N) ) THEN INFO(1) = -10 ENDIF IF (INFO(1).EQ.-10) THEN INFO(2) = NTOTPVTOT ENDIF IF (PROK) THEN WRITE (MPRINT,99980) INFO(1), INFO(2), & KEEP(28), KEEP8(48), INFO(10), INFO(11) IF(KEEP(50) .EQ. 0) THEN WRITE(MPRINT,99982) INFO(12) ENDIF WRITE (MPRINT, 99986) & INFO(13), INFO(14), RINFO(2), RINFO(3) IF (KEEP(97) .NE. 0) THEN WRITE (MPRINT, 99987) INFO(25) ENDIF ENDIF RETURN 99980 FORMAT (/' LEAVING FACTORIZATION PHASE WITH ...'/ & ' INFO (1) =',I15/ & ' --- (2) =',I15/ & ' Number of nodes in the tree =',I15/ & ' INFO (9) Real space for factors =',I15/ & ' --- (10) Integer space for factors =',I15/ & ' --- (11) Maximum size of frontal matrices =',I15) 99982 FORMAT (' --- (12) Number of off diagonal pivots =',I15) 99986 FORMAT (' --- (13) Number of delayed pivots =',I15/ & ' --- (14) Number of memory compresses =',I15/ & ' RINFO(2) Operations during node assembly =',1PD10.3/ & ' -----(3) Operations during node elimination =',1PD10.3) 99987 FORMAT (' INFO (25) Number of tiny pivots(static) =',I15) END SUBROUTINE ZMUMPS_FAC_B SUBROUTINE ZMUMPS_FAC_PAR_I(N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NULLNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, & DET_SIGN,PTRIST,PTRAST,PIMASTER,PAMASTER,PTRARW,PTRAIW,PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & MUMPS_TPS_ARR, ZMUMPS_TPS_ARR, LTPS_ARR, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & NBROOT_UNDER_L0, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS, SLAVEF, MYID, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, INTARR, DBLARR, root, roota, & PERM, NELT, FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV, & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP, & PIVNUL_LIST_STRUCT, LRGROUPS ) USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T USE ZMUMPS_TPS_M, ONLY: ZMUMPS_TPS_T USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_FAC_PAR_M, ONLY : ZMUMPS_FAC_PAR USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80) DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI INTEGER, INTENT(INOUT) :: NELVA, COMP INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV INTEGER, INTENT(INOUT) :: NULLNEGPV INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP COMPLEX(kind=8), INTENT(INOUT) :: DET_MANT INTEGER(8) :: LA COMPLEX(kind=8) :: A(LA) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER LPOOL INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER IW(LIW), NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST(KEEP(28)), PERM(N) INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IPOOL(LPOOL) INTEGER NE(KEEP(28)) DOUBLE PRECISION RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU INTEGER IWPOS, LEAF, NBROOT, NBRTOT INTEGER, INTENT(in) :: NBROOT_UNDER_L0 INTEGER COMM_LOAD, ASS_IRECV DOUBLE PRECISION UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER LRGROUPS(KEEP(280)) INTEGER, INTENT( IN ) :: LTPS_ARR, LL0_OMP_MAPPING TYPE (MUMPS_TPS_T) :: MUMPS_TPS_ARR(LTPS_ARR) TYPE (ZMUMPS_TPS_T) :: ZMUMPS_TPS_ARR(LTPS_ARR) INTEGER, INTENT( IN ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) CALL ZMUMPS_FAC_PAR( N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NULLNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, & DET_SIGN,PTRIST,PTRAST,PIMASTER,PAMASTER,PTRARW,PTRAIW,PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & MUMPS_TPS_ARR, ZMUMPS_TPS_ARR, LTPS_ARR, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & NBROOT_UNDER_L0, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8, & PROCNODE_STEPS,SLAVEF,MYID, COMM_NODES, MYID_NODES, & BUFR,LBUFR,LBUFR_BYTES,INTARR,DBLARR,root,roota,PERM, NELT, & FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV, & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP, & PIVNUL_LIST_STRUCT, LRGROUPS ) RETURN END SUBROUTINE ZMUMPS_FAC_PAR_I MUMPS_5.8.1/src/zfac_process_end_facto_slave.F0000664000175000017500000002743215042446441021225 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE ZMUMPS_END_FACTO_SLAVE( & COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, roota, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_LOAD #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif USE ZMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER INODE, FPERE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER COMM, MYID INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER N INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP, IFLAG, IERROR INTEGER PERM(N) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER ND( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER FRERE(KEEP(28)) INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER MRS_INODE INTEGER MRS_ISON INTEGER MRS_NSLAVES_PERE INTEGER MRS_NASS_PERE INTEGER MRS_NFRONT_PERE INTEGER MRS_LMAP INTEGER MRS_NFS4FATHER INTEGER, POINTER, DIMENSION(:) :: MRS_SLAVES_PERE, MRS_TROW INTEGER ITYPE2 INTEGER IHDR_REC PARAMETER (ITYPE2=2) INTEGER IOLDPS, NROW, LDA INTEGER NPIV, LCONT, NELIM, NASS, NCOL_TO_SEND, & SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER(8) :: SHIFT_VAL_SON INTEGER(8) :: MEM_GAIN INTEGER(8) :: DYN_SIZE #if ! defined(NO_FDM_MAPROW) TYPE(MAPROW_STRUC_T), POINTER :: MRS #endif INTEGER :: IWHANDLER_SAVE INTEGER :: LRSTATUS LOGICAL :: CB_STORED_IN_BLRSTRUC, COMPRESS_CB IF (KEEP(50).EQ.0) THEN IHDR_REC=6 ELSE IHDR_REC=8 ENDIF IOLDPS = PTRIST(STEP(INODE)) IWHANDLER_SAVE = IW(IOLDPS+XXA) LRSTATUS = IW(IOLDPS+XXLR) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND..NOT.COMPRESS_CB) THEN CALL ZMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34)) ENDIF IW(IOLDPS+XXS)=S_ALL IOLDPS = PTRIST(STEP(INODE)) LRSTATUS = IW(IOLDPS+XXLR) IF ( (KEEP(214).EQ.1) & ) THEN CALL ZMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP,KEEP8, DKEEP, ITYPE2 & ) IOLDPS = PTRIST(STEP(INODE)) IF (KEEP(38).NE.FPERE) THEN CB_STORED_IN_BLRSTRUC = .FALSE. LRSTATUS = IW(IOLDPS+XXLR) IF ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) THEN CB_STORED_IN_BLRSTRUC = .TRUE. IW(IOLDPS+XXS) = S_NOLNOCB CALL MUMPS_GETI8(MEM_GAIN, IW(IOLDPS+XXR)) LRLUS = LRLUS + MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ELSE IW(IOLDPS+XXS)=S_NOLCBNOCONTIG CALL MUMPS_GETI8( DYN_SIZE, IW(IOLDPS+XXD)) IF (DYN_SIZE .GT.0) THEN ELSE IF (KEEP(216).NE.3) THEN MEM_GAIN=int(IW( IOLDPS + 2 + KEEP(IXSZ) ),8)* & int(IW( IOLDPS + 3 + KEEP(IXSZ) ),8) LRLUS = LRLUS+MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ENDIF ENDIF ENDIF CALL MUMPS_GETI8( DYN_SIZE, IW(IOLDPS+XXD)) IF (DYN_SIZE > 0_8) THEN ELSE IF (KEEP(216).EQ.2) THEN IF (FPERE.NE.KEEP(38)) THEN IF (.NOT. CB_STORED_IN_BLRSTRUC) THEN CALL ZMUMPS_MAKECBCONTIG(A,LA,PTRAST(STEP(INODE)), & IW( IOLDPS + 2 + KEEP(IXSZ) ), & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 3 + KEEP(IXSZ) )+ & IW( IOLDPS + KEEP(IXSZ) ), 0, & IW( IOLDPS + XXS ), 0_8 ) IW(IOLDPS+XXS)=S_NOLCBCONTIG ENDIF ENDIF ENDIF ENDIF IF ( KEEP(38).EQ.FPERE) THEN LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV NCOL_TO_SEND = LCONT-NELIM SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NASS SHIFT_VAL_SON = int(NASS,8) LDA = LCONT + NPIV IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOTBAND_INIT) THEN IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_REC_CONTSTATIC ELSE ENDIF CALL ZMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTRIST, PTRAST, & root, roota, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, & ROOT_CONT_STATIC, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE.,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS, 0, 0, 0 & ) IF ( IFLAG < 0 ) GOTO 600 IF (NELIM.EQ.0) THEN IF (KEEP(214).EQ.2) THEN CALL ZMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, & COMM, KEEP,KEEP8,DKEEP, ITYPE2 & ) ENDIF CALL ZMUMPS_FREE_BAND( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP, KEEP8, ITYPE2 & ) ELSE IOLDPS = PTRIST(STEP(INODE)) IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOT2SON_CALLED) THEN CALL ZMUMPS_FREE_BAND( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP, KEEP8, ITYPE2 & ) ELSE IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_ROOTBAND_INIT IF (KEEP(214).EQ.1.AND.KEEP(216).NE.3) THEN IW(IOLDPS+XXS)=S_NOLCBNOCONTIG38 CALL ZMUMPS_SIZEFREEINREC( IW(IOLDPS), & LIW-IOLDPS+1, & MEM_GAIN, KEEP(IXSZ) ) LRLUS = LRLUS + MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) IF (KEEP(216).EQ.2) THEN CALL ZMUMPS_MAKECBCONTIG(A,LA,PTRAST(STEP(INODE)), & IW( IOLDPS + 2 + KEEP(IXSZ) ), & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 3 + KEEP(IXSZ) )+ & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 4 + KEEP(IXSZ) ) - & IW( IOLDPS + 3 + KEEP(IXSZ) ), & IW( IOLDPS + XXS ),0_8) IW(IOLDPS+XXS)=S_NOLCBCONTIG38 ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE #if ! defined(NO_FDM_MAPROW) IOLDPS = PTRIST(STEP(INODE)) IF (FPERE .NE. KEEP(38)) THEN IF (MUMPS_FMRD_IS_MAPROW_STORED( IW(IOLDPS+XXA) )) THEN CALL MUMPS_FMRD_RETRIEVE_MAPROW( IW(IOLDPS+XXA), MRS ) IF (FPERE .NE. MRS%INODE) THEN WRITE(*,*) " Internal error 1 in ZMUMPS_END_FACTO_SLAVE", & INODE, MRS%INODE, FPERE CALL MUMPS_ABORT() ENDIF MRS_INODE = MRS%INODE MRS_ISON = MRS%ISON MRS_NSLAVES_PERE = MRS%NSLAVES_PERE MRS_NASS_PERE = MRS%NASS_PERE MRS_NFRONT_PERE = MRS%NFRONT_PERE MRS_LMAP = MRS%LMAP MRS_NFS4FATHER = MRS%NFS4FATHER MRS_SLAVES_PERE => MRS%SLAVES_PERE MRS_TROW => MRS%TROW CALL ZMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & MRS_INODE, MRS_ISON, & MRS_NSLAVES_PERE, MRS_SLAVES_PERE(1), & MRS_NFRONT_PERE, MRS_NASS_PERE, MRS_NFS4FATHER, & MRS_LMAP, MRS_TROW(1), & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) CALL MUMPS_FMRD_FREE_MAPROW_STRUC( IWHANDLER_SAVE ) ENDIF ENDIF #endif RETURN END SUBROUTINE ZMUMPS_END_FACTO_SLAVE MUMPS_5.8.1/src/omp_tps_common_m.F0000664000175000017500000000215415042446423016707 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_TPS_M TYPE MUMPS_TPS_T INTEGER :: LIW, LPOOL, LEAF, IOLDPS INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU, POSELT INTEGER :: INODE, IFATH, IFLAG, IERROR, CURRENT_TASK INTEGER :: JOBASS, ETATASS INTEGER :: MAXFRW, NOFFW, NPVW, NELVAW, NMAXNPIV INTEGER :: TYPE, TYPEF INTEGER :: COMP INTEGER :: IWPOS, IWPOSCB LOGICAL AVOID_DELAYED DOUBLE PRECISION :: OPASSW, OPELIW INTEGER, DIMENSION(:), POINTER :: IW, ITLOC END TYPE MUMPS_TPS_T END MODULE MUMPS_TPS_M SUBROUTINE MUMPS_TPS_M_RETURN() RETURN END SUBROUTINE MUMPS_TPS_M_RETURN MUMPS_5.8.1/src/mumps_pord.c0000664000175000017500000002335215042446422015566 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* * This file contains interfaces to external ordering packages. * At the moment, PORD (J. Schulze) and SCOTCH are interfaced. */ #include "mumps_pord.h" void MUMPS_CALL MUMPS_PORD_INTSIZE(MUMPS_INT *pord_intsize) { #if defined(pord) # if defined(PORD_INTSIZE64) || defined(INTSIZE64) *pord_intsize=64; # else *pord_intsize=32; # endif #else *pord_intsize=-99999; #endif } #if defined(pord) /* Interface to PORD */ #if defined(INTSIZE64) || defined(PORD_INTSIZE64) void MUMPS_CALL MUMPS_PORDF( MUMPS_INT8 *nvtx, MUMPS_INT8 *nedges, MUMPS_INT8 *xadj, MUMPS_INT8 *adjncy, MUMPS_INT8 *nv, MUMPS_INT *ncmpa ) #else void MUMPS_CALL MUMPS_PORDF( MUMPS_INT *nvtx, MUMPS_INT *nedges, MUMPS_INT *xadj, MUMPS_INT *adjncy, MUMPS_INT *nv, MUMPS_INT *ncmpa ) #endif { *ncmpa = mumps_pord( *nvtx, *nedges, xadj, adjncy, nv ); } /* Interface to PORD with weighted graph */ #if defined(INTSIZE64) || defined(PORD_INTSIZE64) void MUMPS_CALL MUMPS_PORDF_WND( MUMPS_INT8 *nvtx, MUMPS_INT8 *nedges, MUMPS_INT8 *xadj, MUMPS_INT8 *adjncy, MUMPS_INT8 *nv, MUMPS_INT *ncmpa, MUMPS_INT8 *totw ) #else void MUMPS_CALL MUMPS_PORDF_WND( MUMPS_INT *nvtx, MUMPS_INT *nedges, MUMPS_INT *xadj, MUMPS_INT *adjncy, MUMPS_INT *nv, MUMPS_INT *ncmpa, MUMPS_INT *totw ) #endif { *ncmpa = mumps_pord_wnd( *nvtx, *nedges, xadj, adjncy, nv, totw ); } /************************************************************ mumps_pord is used in ana_aux.F permutation and inverse permutation not set on output, but may be printed in default file: "perm_pord" and "iperm_pord", if associated part uncommneted. But, if uncommetnted a bug occurs in psl_ma41_analysi.F ******************************************************************/ /*********************************************************/ MUMPS_INT mumps_pord ( PORD_INT nvtx, PORD_INT nedges, /* NZ-like */ PORD_INT *xadj_pe, /* NZ-like */ PORD_INT *adjncy, PORD_INT *nv ) { /********************************** Arguments: input: ----- - nvtx : dimension of the Problem (N) - nedges : number of entries (NZ) - adjncy : non-zeros entries (IW input) input/output: ------------- - xadj_pe : in: pointer through beginning of column non-zeros entries out: "father array" (PE) ouput: ------ - nv : "nfront array" (NV) *************************************/ graph_t *G; elimtree_t *T; timings_t cpus[12]; options_t options[] = { SPACE_ORDTYPE, SPACE_NODE_SELECTION1, SPACE_NODE_SELECTION2, SPACE_NODE_SELECTION3, SPACE_DOMAIN_SIZE, 0 }; PORD_INT *ncolfactor, *ncolupdate, *parent, *vtx2front; PORD_INT *first, *link, nfronts, J, K, u, vertex, vertex_root, count; /* Explicit shifting of indices to be optimized */ for (u = nvtx; u >= 0; u--) { xadj_pe[u] = xadj_pe[u] - 1; } for (K = nedges-1; K >= 0; K--) { adjncy[K] = adjncy[K] - 1; } /* initialization of the graph */ mymalloc(G, 1, graph_t); G->xadj = xadj_pe; G->adjncy = adjncy; G->nvtx = nvtx; G->nedges = nedges; /* FIXME: G->vwght and G->tocwght accessed if G->type==UNWEIGHTED? */ mymalloc(G->vwght, nvtx, PORD_INT); G->type = UNWEIGHTED; G->totvwght = nvtx; for (u = 0; u < nvtx; u++) G->vwght[u] = 1; /* main function of the Ordering */ T = SPACE_ordering(G, options, cpus); nfronts = T->nfronts; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; parent = T->parent; /* firstchild = T->firstchild; */ vtx2front = T->vtx2front; /* ----------------------------------------------------------- store the vertices/columns of a front in a bucket structure ----------------------------------------------------------- */ mymalloc(first, nfronts, PORD_INT); mymalloc(link, nvtx, PORD_INT); for (J = 0; J < nfronts; J++) first[J] = -1; for (u = nvtx-1; u >= 0; u--) { J = vtx2front[u]; link[u] = first[J]; first[J] = u; } /* ----------------------------------------------------------- fill the two arrays corresponding to the MUMPS tree structure ----------------------------------------------------------- */ count = 0; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { vertex_root = first[K]; if (vertex_root == -1) { /* Should never happen */ # if defined(PORD_INTSIZE64) || defined(INTSIZE64) printf(" Internal error in mumps_pord, %ld\n",K); # else printf(" Internal error in mumps_pord, %d\n",K); # endif exit(-1); } /* for the principal column of the supervariable */ if (parent[K] == -1) xadj_pe[vertex_root] = 0; /* root of the tree */ else xadj_pe[vertex_root] = - (first[parent[K]]+1); nv[vertex_root] = ncolfactor[K] + ncolupdate[K]; count++; for (vertex = link[vertex_root]; vertex != -1; vertex = link[vertex]) /* for the secondary columns of the supervariable */ { xadj_pe[vertex] = - (vertex_root+1); nv[vertex] = 0; count++; } } /* ---------------------- free memory and return ---------------------- */ free(first); free(link); free(G->vwght); free(G); freeElimTree(T); return (0); } /*********************************************************/ MUMPS_INT mumps_pord_wnd ( PORD_INT nvtx, PORD_INT nedges, PORD_INT *xadj_pe, PORD_INT *adjncy, PORD_INT *nv, PORD_INT *totw ) { /********************************** Arguments: input: ----- - nvtx : dimension of the Problem (N) - nedges : number of entries (NZ) - adjncy : non-zeros entries (IW input) - totw : sum of the weigth of the vertices input/output: ------------- - xadj_pe : in: pointer through beginning of column non-zeros entries out: "father array" (PE) - nv : in: weight of the vertices out: "nfront array" (NV) *************************************/ graph_t *G; elimtree_t *T; timings_t cpus[12]; options_t options[] = { SPACE_ORDTYPE, SPACE_NODE_SELECTION1, SPACE_NODE_SELECTION2, SPACE_NODE_SELECTION3, SPACE_DOMAIN_SIZE, 0 }; PORD_INT *ncolfactor, *ncolupdate, *parent, *vtx2front; PORD_INT *first, *link, nfronts, J, K, u, vertex, vertex_root, count; /* Explicit shifting of indices to be optimized */ for (u = nvtx; u >= 0; u--) { xadj_pe[u] = xadj_pe[u] - 1; } for (K = nedges-1; K >= 0; K--) { adjncy[K] = adjncy[K] - 1; } /* initialization of the graph */ mymalloc(G, 1, graph_t); G->xadj = xadj_pe; G->adjncy= adjncy; G->nvtx = nvtx; G->nedges = nedges; G->type = WEIGHTED; G->totvwght = (*totw); /* FIXME: avoid allocation and do: G->vwght=nv; instead? */ mymalloc(G->vwght, nvtx, PORD_INT); for (u = 0; u < nvtx; u++) G->vwght[u] = nv[u]; /* main function of the Ordering */ T = SPACE_ordering(G, options, cpus); nfronts = T->nfronts; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; parent = T->parent; /* firstchild = T->firstchild; */ vtx2front = T->vtx2front; /* ----------------------------------------------------------- store the vertices/columns of a front in a bucket structure ----------------------------------------------------------- */ mymalloc(first, nfronts, PORD_INT); mymalloc(link, nvtx, PORD_INT); for (J = 0; J < nfronts; J++) first[J] = -1; for (u = nvtx-1; u >= 0; u--) { J = vtx2front[u]; link[u] = first[J]; first[J] = u; } /* ----------------------------------------------------------- fill the two arrays corresponding to the MUMPS tree structure ----------------------------------------------------------- */ count = 0; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { vertex_root = first[K]; if (vertex_root == -1) { /* Should never happen */ # if defined(PORD_INTSIZE64) || defined(INTSIZE64) printf(" Internal error in mumps_pord, %ld\n",K); # else printf(" Internal error in mumps_pord, %d\n",K); # endif exit(-1); } /* for the principal column of the supervariable */ if (parent[K] == -1) xadj_pe[vertex_root] = 0; /* root of the tree */ else xadj_pe[vertex_root] = - (first[parent[K]]+1); nv[vertex_root] = ncolfactor[K] + ncolupdate[K]; count++; for (vertex = link[vertex_root]; vertex != -1; vertex = link[vertex]) /* for the secondary columns of the supervariable */ { xadj_pe[vertex] = - (vertex_root+1); nv[vertex] = 0; count++; } } /* ---------------------- free memory and return ---------------------- */ free(first); free(link); free(G->vwght); free(G); freeElimTree(T); return (0); } #endif /* pord */ MUMPS_5.8.1/src/sfac_dist_arrowheads_omp.F0000664000175000017500000015072315042446437020406 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if ! defined(PCPRET) SUBROUTINE SMUMPS_FAC_DIST_ARROWHEADS_OMP ( & N, NZ_loc8, & A_loc, IRN_loc, JCN_loc, & SIZESCAL, LSCAL, COLSCA, ROWSCA, & DBLARR, LDBLARR, INTARR, LINTARR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & FILS, KEEP,KEEP8, MYID, COMM, NBRECORDS, & & S, LA, root, roota, PROCNODE_STEPS, NPROCS, SLAVEF, PERM, STEP, & ICNTL, INFO, NSEND8, NLOCAL8, & ISTEP_TO_INIV2, CANDIDATES & ) !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZESCAL LOGICAL, INTENT(IN) :: LSCAL INTEGER(8), INTENT(IN) :: NZ_loc8 INTEGER, INTENT(IN) :: IRN_LOC(max(1_8,NZ_loc8)), & JCN_LOC(max(1_8,NZ_loc8)) REAL, INTENT(IN) :: A_loc(max(1_8,NZ_loc8)) REAL, INTENT(IN) :: ROWSCA(SIZESCAL), & COLSCA(SIZESCAL) INTEGER(8), INTENT(IN) :: LDBLARR, LINTARR REAL, INTENT(OUT) :: DBLARR( LDBLARR ) INTEGER, INTENT(OUT) :: INTARR( LINTARR ) INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER(8), INTENT(INOUT):: KEEP8(150) INTEGER, INTENT(IN) :: FILS( N ) INTEGER, INTENT(IN) :: MYID, COMM, NBRECORDS INTEGER(8), INTENT(IN) :: LA INTEGER, INTENT(IN) :: NPROCS, SLAVEF INTEGER(8), INTENT(OUT):: NSEND8, NLOCAL8 INTEGER, INTENT(IN) :: ISTEP_TO_INIV2(KEEP(71)) INTEGER, INTENT(IN) :: CANDIDATES(SLAVEF+1, max(1,KEEP(56))) REAL, INTENT(INOUT) :: S( LA ) TYPE (MUMPS_ROOT_STRUC), INTENT(INOUT) :: root TYPE (SMUMPS_ROOT_STRUC), INTENT(INOUT) :: roota INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), & PERM( N ), STEP( N ) INTEGER, INTENT(INOUT) :: INFO( 80 ) INTEGER, INTENT(IN) :: ICNTL(60) INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: PTRAW INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFSENDI REAL, ALLOCATABLE, DIMENSION(:,:,:) :: BUFSENDR INTEGER, ALLOCATABLE, DIMENSION(:,:) :: BUFSEND_POSRESERVED INTEGER, ALLOCATABLE, DIMENSION(:,:) :: BUFRECVI REAL, ALLOCATABLE, DIMENSION(:,:) :: BUFRECVR INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, ISENDREQI, ISENDREQR LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE INTEGER, ALLOCATABLE, DIMENSION(:) :: IRECVREQI, IRECVREQR INTEGER, ALLOCATABLE, DIMENSION(:):: RECV_BUF_STATUS INTEGER, PARAMETER :: Processed_IrecNeeded = 1 INTEGER, PARAMETER :: IrecPosted = 2 INTEGER, PARAMETER :: Received_NotProcessed = 3 INTEGER, PARAMETER :: Processed_IrecNotneeded = 4 INTEGER, PARAMETER :: Treating = 5 INTEGER, PARAMETER :: BeingTreatednotbyme = 6 INTEGER(8) :: ILOC8 INTEGER :: EndNZloc, NB_END_MSG_2_RECV LOGICAL :: MPI_End_Send, End_TreatRecvBuf, MPI_InvolvedinSend, & MPI_InvolvedinRecv, TH_InvolvedinComm, & NO_ATOMIC_Wsendbuf, NO_ATOMIC_Warrow, FINISHED, & TH_InvolvedinArrange, TH_InvolvedinTreatRecv INTEGER(8) :: PTR_ROOT INTEGER :: LOCAL_M, LOCAL_N, ARROW_ROOT LOGICAL :: EARLYT3ROOTINS LOGICAL :: I_AM_SLAVE, OneMPI INTEGER :: IARR1, IORG, NOMP, NOMP_MAX INTEGER :: ISTEP, ISLAVE_MAIN, IMAIN, JMAIN INTEGER :: allocok LOGICAL :: OMP_FLAG INTEGER(8) :: IS8MAIN INTEGER :: TYPE_NODE_P, MASTER_NODE_P, NBJ_P INTEGER(8) :: IS8_P INTEGER :: LP, MP LOGICAL :: LPOK, PROK INTEGER(8) :: NB_RANGE_8 INTEGER :: SHIFT_PID INTEGER :: NOMP_SHARED LOGICAL :: NOTHINGTOARRANGE_P INTEGER :: IOMP, NB_RANGE_P, EndNZloc_P LOGICAL :: ThWorking INTEGER(8) :: ILOC8_P INTEGER :: NBRECORDS_LOC INTEGER, PARAMETER :: MPI_MASTER = 0 NSEND8 = 0_8 NLOCAL8 = 0_8 LP = ICNTL(1) MP = ICNTL(2) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) NB_RANGE_8 = int(max(NBRECORDS/10, 1), 8) IF (KEEP(46).EQ.0) THEN SHIFT_PID = 1 ELSE SHIFT_PID = 0 ENDIF I_AM_SLAVE = (MYID.NE.0.OR.KEEP(46).EQ.1) OneMPI = NPROCS.EQ.1 IF (OneMPI) THEN NBRECORDS_LOC = 1 ELSE NBRECORDS_LOC = NBRECORDS ENDIF IF ( OneMPI.OR. & (KEEP(54).EQ.0.AND.(MYID.NE.MPI_MASTER)) & ) THEN MPI_InvolvedinSend = .FALSE. MPI_End_Send = .TRUE. ELSE MPI_InvolvedinSend = .TRUE. MPI_End_Send = .FALSE. ENDIF ALLOCATE( & BUFSENDI(NBRECORDS_LOC * 2 + 1, 2, NPROCS), & BUFSENDR(NBRECORDS_LOC, 2, NPROCS), & IACT(NPROCS), SEND_ACTIVE(NPROCS), & ISENDREQI(NPROCS), ISENDREQR(NPROCS), & BUFSEND_POSRESERVED(2, NPROCS), & stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LPOK ) THEN WRITE(LP,*) & '** Error allocating SEND buffers for matrix distribution' END IF INFO(1) = -13 INFO(2) = ( NBRECORDS_LOC * 2 + 1 ) * NPROCS * 2 + & NBRECORDS_LOC * NPROCS * 2 + & NPROCS*6 GOTO 20 END IF IF (.NOT.OneMPI) THEN DO ISLAVE_MAIN=1, NPROCS IACT (ISLAVE_MAIN) = 1 ISENDREQI(ISLAVE_MAIN) = MPI_REQUEST_NULL ISENDREQR(ISLAVE_MAIN) = MPI_REQUEST_NULL BUFSENDI(1, 1, ISLAVE_MAIN) = 0 BUFSEND_POSRESERVED(1,ISLAVE_MAIN)= 0 BUFSENDI(1, 2, ISLAVE_MAIN) = NBRECORDS_LOC BUFSEND_POSRESERVED(2,ISLAVE_MAIN)= NBRECORDS_LOC SEND_ACTIVE(ISLAVE_MAIN) = .FALSE. ENDDO ENDIF IF (OneMPI.OR. & (KEEP(54).EQ.0.AND.(MYID.EQ.MPI_MASTER)) & ) THEN NB_END_MSG_2_RECV = 0 MPI_InvolvedinRecv = .FALSE. End_TreatRecvBuf = .TRUE. ELSE IF (KEEP(54).EQ.0.AND.MYID.NE.MPI_MASTER) THEN NB_END_MSG_2_RECV = 1 MPI_InvolvedinRecv = .TRUE. End_TreatRecvBuf = .FALSE. ELSE NB_END_MSG_2_RECV = NPROCS-1 MPI_InvolvedinRecv = .TRUE. End_TreatRecvBuf = .FALSE. ENDIF ALLOCATE( & BUFRECVI(NBRECORDS_LOC * 2 + 1, NPROCS), & BUFRECVR(NBRECORDS_LOC, NPROCS), & IRECVREQI(NPROCS), IRECVREQR(NPROCS), & RECV_BUF_STATUS(NPROCS), & stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LPOK ) THEN WRITE(LP,*) & '** Error allocating RECV buffers for matrix distribution' END IF INFO(1) = -13 INFO(2) = ( NBRECORDS_LOC * 2 + 1 ) * NPROCS + & NBRECORDS_LOC * NPROCS + & NPROCS*3 GOTO 20 ENDIF IF (.NOT.OneMPI) THEN BUFRECVI(1, 1:NPROCS) = 0 IRECVREQI(1:NPROCS) = MPI_REQUEST_NULL IRECVREQR(1:NPROCS) = MPI_REQUEST_NULL RECV_BUF_STATUS (1:NPROCS)= Processed_IrecNeeded RECV_BUF_STATUS (MYID+1) = Processed_IrecNotneeded IF (KEEP(54).EQ.0) THEN DO ISLAVE_MAIN=1, NPROCS RECV_BUF_STATUS (ISLAVE_MAIN)= Processed_IrecNotneeded ENDDO IF (MYID.NE.MPI_MASTER) THEN RECV_BUF_STATUS(MPI_MASTER+1) = Processed_IrecNeeded ENDIF ENDIF ENDIF ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8) * 2_8, INFO(2) ) GOTO 20 END IF ALLOCATE( PTRAW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8) * KEEP(10), INFO(2) ) GOTO 20 END IF 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 100 ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) IF (I_AM_SLAVE) THEN DO JMAIN = 1, N ISTEP=STEP(JMAIN) IF (ISTEP .GT. 0) THEN IARR1 = PTRDEBARR( ISTEP ) IF ( IARR1 .GT. 0 ) THEN IMAIN = JMAIN IORG = 0 DO WHILE ( IMAIN .GT. 0 ) IORG = IORG + 1 IW4(IMAIN, 1) = NINCOLARR( IARR1 + IORG - 1 ) IW4(IMAIN, 2) = NINROWARR( IARR1 + IORG - 1 ) + & NINCOLARR( IARR1 + IORG - 1 ) IS8MAIN = PTR8ARR( IARR1 + IORG - 1 ) PTRAW( IMAIN ) = IS8MAIN INTARR( IS8MAIN ) = IMAIN DBLARR( IS8MAIN ) = ZERO IMAIN = FILS(IMAIN) ENDDO ENDIF ENDIF ENDDO IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL SMUMPS_GET_ROOT_INFO(root, LOCAL_M, & LOCAL_N, PTR_ROOT, LA) CALL SMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, S, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 ENDIF NOMP=1 !$ NOMP=omp_get_max_threads() NOMP_MAX = NOMP IF (NOMP_MAX.GT.2.AND.KEEP(399).EQ.2) THEN IF (.NOT.OneMPI) THEN NOMP_MAX = 2 ENDIF ENDIF IF (NOMP_MAX.GT.3.AND.KEEP(399).EQ.3) THEN IF (.NOT.OneMPI) THEN NOMP_MAX = 3 ENDIF ENDIF ILOC8 = 1_8 OMP_FLAG = ((NOMP .GE.2).AND.(KEEP(399).NE.99)) FINISHED = .FALSE. NOMP_SHARED = 1 !$OMP PARALLEL !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& PRIVATE( !$OMP& IOMP, ThWorking, ILOC8_P, NB_RANGE_P, !$OMP& NOTHINGTOARRANGE_P, EndNZloc_P, TH_InvolvedinComm, !$OMP& TH_InvolvedinTreatRecv, TH_InvolvedinArrange ) !$OMP& REDUCTION(+:NSEND8, NLOCAL8, ARROW_ROOT) !$OMP& IF (OMP_FLAG) IOMP = 0 !$ IOMP=omp_get_thread_num() !$OMP SINGLE !$ NOMP_SHARED= omp_get_num_threads() IF (OneMPI) THEN EndNZloc = NOMP_SHARED ELSE EndNZloc = max(1,NOMP_SHARED -1) IF ( KEEP(399).EQ.2.OR.KEEP(399).EQ.3 ) THEN EndNZloc = min(EndNZloc,1) ENDIF ENDIF IF (NZ_loc8.EQ.0_8) EndNZloc = 0 IF (.NOT.MPI_InvolvedinSend.AND.(EndNZloc.EQ.0)) EndNZloc=-1 NO_ATOMIC_Wsendbuf = ( NOMP_SHARED.EQ.1 ) NO_ATOMIC_Warrow = ( NOMP_SHARED.EQ.1 ) IF (NPROCS.GT.1) THEN NO_ATOMIC_Warrow = (NOMP_SHARED.LE.2) IF ( KEEP(399).EQ.2 .OR. KEEP(399).EQ.3) THEN NO_ATOMIC_Wsendbuf = .TRUE. IF (.NOT.MPI_InvolvedinSend) NO_ATOMIC_Warrow=.TRUE. IF (.NOT.MPI_InvolvedinRecv) NO_ATOMIC_Warrow=.TRUE. ENDIF ENDIF !$OMP END SINGLE ThWorking = OneMPI.OR. & (NOMP_SHARED.EQ.1) .OR. (IOMP.NE.0) TH_InvolvedinTreatRecv = (MPI_InvolvedinRecv.AND.ThWorking) IF ( TH_InvolvedinTreatRecv.AND. & (NOMP_SHARED.EQ.3).AND.(KEEP(399).EQ.3) ) THEN IF (IOMP.NE.2) TH_InvolvedinTreatRecv = .FALSE. ENDIF TH_InvolvedinArrange = ThWorking IF (.NOT.OneMPI.AND.ThWorking) THEN IF (KEEP(399).EQ.2.OR.KEEP(399).EQ.3) & THEN IF ((NOMP_SHARED.NE.1).AND.(IOMP.NE.1)) & TH_InvolvedinArrange = .FALSE. ENDIF ENDIF TH_InvolvedinComm = ((.NOT.OneMPI).AND.(IOMP.EQ.0)) NOTHINGTOARRANGE_P = (NZ_loc8.EQ.0_8) ILOC8_P = 0_8 DO WHILE ( .NOT.FINISHED ) IF (TH_InvolvedinComm) THEN CALL SMUMPS_ARROW_TRY_PROGRESS_COMM ( IOMP, MYID, & NPROCS, NBRECORDS_LOC, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ENDIF IF (.NOT.ThWorking) THEN CALL MUMPS_USLEEP(20) GOTO 50 ENDIF IF (TH_InvolvedinTreatRecv) THEN CALL SMUMPS_ARROW_TRY_TREAT_RECV_BUF ( IOMP, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, & NPROCS, NBRECORDS_LOC, N, IW4, & KEEP, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, S, LA, & NB_END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR, & NOMP_SHARED, EARLYT3ROOTINS, NO_ATOMIC_Warrow ) IF (NOMP_SHARED.EQ.1) THEN CALL SMUMPS_ARROW_TRY_PROGRESS_COMM ( IOMP, MYID, & NPROCS, NBRECORDS_LOC, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ENDIF ENDIF IF (.NOT. NOTHINGTOARRANGE_P.AND.TH_InvolvedinArrange) THEN !$OMP ATOMIC CAPTURE ILOC8_P = ILOC8 ILOC8 = ILOC8 + NB_RANGE_8 !$OMP END ATOMIC IF (ILOC8_P.LE.NZ_loc8) THEN NB_RANGE_P = int(min(NB_RANGE_8, NZ_loc8-ILOC8_P+1)) CALL SMUMPS_FAC_ARROW_ARRANGE ( MYID, IOMP, N, SHIFT_PID, & SLAVEF, LSCAL, NSEND8, NLOCAL8, ILOC8_P, NB_RANGE_P, & NZ_loc8, IRN_LOC, JCN_LOC, A_loc, SIZESCAL, ROWSCA, COLSCA, & ISTEP_TO_INIV2, CANDIDATES, KEEP, MPI_MASTER, NO_ATOMIC_Warrow, & NO_ATOMIC_Wsendbuf, TH_InvolvedinTreatRecv, & NPROCS, NBRECORDS_LOC, MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, IACT, & SEND_ACTIVE, BUFSEND_POSRESERVED, IRECVREQI, IRECVREQR, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, EndNZloc, MPI_End_Send, & End_TreatRecvBuf, & root, roota, PTR_ROOT, ARROW_ROOT, EARLYT3ROOTINS, & LOCAL_M, LOCAL_N, & S, LA, NB_END_MSG_2_RECV, PROCNODE_STEPS, IW4, PTRAW, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, PERM, STEP, INTARR, LINTARR, & DBLARR, LDBLARR, NOMP_SHARED ) ENDIF IF (ILOC8_P+NB_RANGE_8.GT.NZ_loc8) THEN IF (.NOT. NOTHINGTOARRANGE_P) THEN NOTHINGTOARRANGE_P=.TRUE. !$OMP ATOMIC CAPTURE EndNZloc = EndNZloc-1 EndNZloc_P = EndNZloc !$OMP END ATOMIC IF (MPI_End_Send.AND.EndNZloc_P.EQ.0) THEN !$OMP ATOMIC WRITE EndNZloc=-1 !$OMP END ATOMIC ENDIF ENDIF ENDIF ENDIF 50 CONTINUE !$OMP MASTER !$OMP ATOMIC WRITE FINISHED = ( (EndNZloc.EQ.-1) & .AND.(MPI_End_Send.OR.(.not.MPI_InvolvedinSend)) & .AND. End_TreatRecvBuf & ) !$OMP END ATOMIC !$OMP END MASTER ENDDO !$OMP END PARALLEL !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) !$OMP& PRIVATE(ISTEP, TYPE_NODE_P, MASTER_NODE_P, NBJ_P, !$OMP& IARR1, IS8_P ) !$OMP& IF (OMP_FLAG) DO ISTEP=1, KEEP(28) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE_P, MASTER_NODE_P, & PROCNODE_STEPS(ISTEP), KEEP(199) ) MASTER_NODE_P = MASTER_NODE_P + SHIFT_PID IF ( MASTER_NODE_P.NE.MYID.OR. & ( (TYPE_NODE_P.NE.1) .AND. (TYPE_NODE_P.NE.2) ) & ) CYCLE IARR1 = PTRDEBARR( ISTEP ) NBJ_P = NINCOLARR( IARR1) IF (NBJ_P.LE.0) CYCLE IS8_P = PTR8ARR( IARR1) + 1_8 CALL SMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( IS8_P ), & DBLARR( IS8_P ), & NBJ_P, 1, NBJ_P ) ENDDO !$OMP END PARALLEL DO 100 CONTINUE IF (ALLOCATED(IW4)) DEALLOCATE( IW4 ) IF (ALLOCATED(PTRAW)) DEALLOCATE( PTRAW ) IF (ALLOCATED(BUFSENDI)) DEALLOCATE( BUFSENDI ) IF (ALLOCATED(BUFSENDR)) DEALLOCATE( BUFSENDR ) IF (ALLOCATED(BUFRECVI)) DEALLOCATE( BUFRECVI ) IF (ALLOCATED(BUFRECVR)) DEALLOCATE( BUFRECVR ) IF (ALLOCATED(IACT)) DEALLOCATE( IACT ) IF (ALLOCATED(ISENDREQI)) DEALLOCATE( ISENDREQI ) IF (ALLOCATED(ISENDREQR)) DEALLOCATE( ISENDREQR ) IF (ALLOCATED(IRECVREQI)) DEALLOCATE( IRECVREQI ) IF (ALLOCATED(IRECVREQR)) DEALLOCATE( IRECVREQR ) IF (ALLOCATED(SEND_ACTIVE)) DEALLOCATE( SEND_ACTIVE ) IF (ALLOCATED(BUFSEND_POSRESERVED)) & DEALLOCATE( BUFSEND_POSRESERVED ) IF (ALLOCATED(RECV_BUF_STATUS)) DEALLOCATE( RECV_BUF_STATUS ) RETURN END SUBROUTINE SMUMPS_FAC_DIST_ARROWHEADS_OMP SUBROUTINE SMUMPS_ARROW_TRY_PROGRESS_COMM ( IOMP, MYID, & NPROCS, NBRECORDS, MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) IMPLICIT NONE INTEGER, INTENT(IN) :: IOMP, MYID, NPROCS, NBRECORDS, COMM LOGICAL, INTENT(IN) :: MPI_InvolvedinSend, MPI_InvolvedinRecv INTEGER, INTENT(IN) :: NB_END_MSG_2_RECV INTEGER, INTENT(INOUT) :: EndNZloc LOGICAL, INTENT(INOUT) :: MPI_End_Send, End_TreatRecvBuf INTEGER, INTENT(INOUT) :: & ISENDREQI(NPROCS), ISENDREQR(NPROCS), & BUFSENDI(NBRECORDS * 2 + 1, 2, NPROCS), & IACT(NPROCS), BUFSEND_POSRESERVED(2,NPROCS) REAL, INTENT(INOUT) :: BUFSENDR(NBRECORDS, 2, NPROCS) LOGICAL, INTENT(INOUT) :: SEND_ACTIVE(NPROCS) INTEGER, INTENT(INOUT) :: & IRECVREQI(NPROCS), IRECVREQR(NPROCS), & BUFRECVI(NBRECORDS * 2 + 1, NPROCS), & RECV_BUF_STATUS(NPROCS) REAL, INTENT(INOUT) :: BUFRECVR(NBRECORDS, NPROCS) INTEGER, PARAMETER :: Processed_IrecNeeded = 1 INTEGER, PARAMETER :: IrecPosted = 2 INTEGER, PARAMETER :: Received_NotProcessed = 3 INTEGER, PARAMETER :: Processed_IrecNotneeded = 4 INTEGER, PARAMETER :: Treating = 5 INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: EndNZloc_copy, ISLAVE, NBREC, STATE, & NB_END_MSG_2_RECV_COPY, ISLAVE_RECV INTEGER :: IERR, IACT_P, NEXT_IACT INTEGER :: TAILLE_SEND_I, TAILLE_SEND_R LOGICAL :: FLAG, FLAGRECV, ALL_LAST_MESS_SENT INTEGER :: STATUS(MPI_STATUS_SIZE) IF (MPI_InvolvedinSend.and.(.NOT.MPI_End_Send)) THEN DO ISLAVE = 1, NPROCS IF (ISLAVE-1.EQ.MYID) CYCLE IF (SEND_ACTIVE( ISLAVE )) THEN CALL MPI_TEST( ISENDREQR( ISLAVE ), FLAG, STATUS, IERR ) IF (FLAG) THEN CALL MPI_WAIT( ISENDREQI( ISLAVE ), STATUS, IERR ) SEND_ACTIVE( ISLAVE ) = .FALSE. ENDIF ENDIF ENDDO !$OMP ATOMIC READ EndNZloc_copy = EndNZloc !$OMP END ATOMIC ALL_LAST_MESS_SENT = (EndNZloc_copy.EQ.0) IF (EndNZloc_copy.NE.-1) THEN DO ISLAVE=1, NPROCS IF (ISLAVE-1.EQ.MYID) CYCLE IF (EndNZloc_copy .EQ. 0) THEN NBREC = & min(BUFSEND_POSRESERVED(IACT(ISLAVE),ISLAVE),NBRECORDS) IF (NBREC.EQ.-99) CYCLE BUFSENDI(1,IACT(ISLAVE),ISLAVE) = - NBREC ELSE !$OMP ATOMIC READ NBREC = BUFSENDI(1,IACT(ISLAVE),ISLAVE) !$OMP END ATOMIC ENDIF IF ((EndNZloc_copy.EQ.0).OR.(NBREC.EQ.NBRECORDS)) THEN IF (.NOT.SEND_ACTIVE(ISLAVE)) THEN TAILLE_SEND_I = NBREC * 2 + 1 TAILLE_SEND_R = NBREC IACT_P = IACT(ISLAVE) CALL MPI_ISEND( BUFSENDI(1, IACT_P, ISLAVE ), & TAILLE_SEND_I, & MPI_INTEGER, ISLAVE - 1, & ARR_INT, COMM, & ISENDREQI( ISLAVE ), IERR ) CALL MPI_ISEND( BUFSENDR(1, IACT_P, ISLAVE ), & TAILLE_SEND_R, & MPI_REAL, ISLAVE - 1, & ARR_REAL, COMM, & ISENDREQR( ISLAVE ), IERR ) SEND_ACTIVE( ISLAVE ) = .TRUE. IF (EndNZloc_copy.NE.0) THEN NEXT_IACT = 3-IACT_P !$OMP ATOMIC WRITE BUFSEND_POSRESERVED(NEXT_IACT,ISLAVE) = 0 !$OMP END ATOMIC !$OMP ATOMIC WRITE BUFSENDI(1,NEXT_IACT,ISLAVE) = 0 !$OMP END ATOMIC !$OMP ATOMIC WRITE IACT( ISLAVE ) = NEXT_IACT !$OMP END ATOMIC ELSE BUFSEND_POSRESERVED(IACT_P,ISLAVE) = -99 ENDIF ELSE ALL_LAST_MESS_SENT=.FALSE. ENDIF ENDIF ENDDO ENDIF IF (EndNZloc_copy.EQ.0.AND.ALL_LAST_MESS_SENT) THEN EndNZloc = -1 EndNZloc_copy = -1 ENDIF IF (.NOT.MPI_End_Send) THEN IF ( (EndNZloc_copy.EQ.-1) ) THEN MPI_End_Send = .TRUE. DO ISLAVE = 1, NPROCS IF (ISLAVE-1.EQ.MYID) CYCLE IF (SEND_ACTIVE( ISLAVE )) THEN MPI_End_Send=.FALSE. EXIT ENDIF ENDDO ENDIF ENDIF ENDIF IF (MPI_InvolvedinRecv.AND.(.NOT.End_TreatRecvBuf)) THEN CALL MPI_TESTANY(NPROCS, IRECVREQR, ISLAVE_RECV, & FLAGRECV, STATUS,IERR) IF (FLAGRECV.AND.(ISLAVE_RECV.NE.MPI_UNDEFINED)) & THEN CALL MPI_WAIT(IRECVREQI(ISLAVE_RECV),STATUS,IERR) !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE_RECV)=Received_NotProcessed !$OMP END ATOMIC ENDIF DO ISLAVE = 1, NPROCS IF (ISLAVE - 1 .EQ. MYID) CYCLE !$OMP ATOMIC READ STATE = RECV_BUF_STATUS(ISLAVE) !$OMP END ATOMIC IF (STATE.EQ.Processed_IrecNeeded) THEN CALL MPI_IRECV ( BUFRECVI(1,ISLAVE), NBRECORDS * 2 + 1, & MPI_INTEGER, ISLAVE-1, ARR_INT, COMM, & IRECVREQI(ISLAVE), IERR) CALL MPI_IRECV ( BUFRECVR(1,ISLAVE), NBRECORDS, & MPI_REAL, ISLAVE-1, & ARR_REAL, COMM, & IRECVREQR(ISLAVE), IERR) !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = IrecPosted !$OMP END ATOMIC ENDIF ENDDO !$OMP ATOMIC READ NB_END_MSG_2_RECV_COPY = NB_END_MSG_2_RECV !$OMP END ATOMIC IF (NB_END_MSG_2_RECV_COPY.EQ.0) THEN End_TreatRecvBuf = .TRUE. DO ISLAVE = 1, NPROCS IF (ISLAVE - 1 .EQ. MYID) CYCLE IF (RECV_BUF_STATUS(ISLAVE).NE.Processed_IrecNotneeded) THEN End_TreatRecvBuf = .FALSE. EXIT ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_ARROW_TRY_PROGRESS_COMM SUBROUTINE SMUMPS_ARROW_TRY_TREAT_RECV_BUF (IOMP, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, & NPROCS, NBRECORDS, N, IW4, & KEEP, LOCAL_M, LOCAL_N, root, roota, & PTR_ROOT, S, LA, & NB_END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR, & NOMP_SHARED, EARLYT3ROOTINS, NO_ATOMIC_Warrow ) USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER, INTENT(IN):: IOMP, NPROCS, NBRECORDS, N, MYID, SLAVEF, & NOMP_SHARED LOGICAL, INTENT(IN):: EARLYT3ROOTINS INTEGER, INTENT(IN):: BUFRECVI( NBRECORDS * 2 + 1, NPROCS ) REAL, INTENT(IN):: BUFRECVR( NBRECORDS, NPROCS ) INTEGER, INTENT(INOUT) :: RECV_BUF_STATUS(NPROCS) INTEGER, INTENT(INOUT):: IW4( N, 2 ) INTEGER, INTENT(IN):: KEEP(500) INTEGER, INTENT(INOUT):: NB_END_MSG_2_RECV INTEGER(8), INTENT(IN) :: PTRAW( N ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER, INTENT(IN) :: PERM( N ), STEP( N ) INTEGER, INTENT(IN) :: PROCNODE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER, INTENT(INOUT) :: INTARR( LINTARR ) INTEGER, INTENT(IN):: LOCAL_M, LOCAL_N INTEGER(8), INTENT(IN) :: PTR_ROOT, LA REAL, INTENT(INOUT) :: S( LA ), DBLARR( LDBLARR ) LOGICAL, INTENT(IN) :: NO_ATOMIC_Warrow INTEGER, PARAMETER :: Processed_IrecNeeded = 1 INTEGER, PARAMETER :: IrecPosted = 2 INTEGER, PARAMETER :: Received_NotProcessed = 3 INTEGER, PARAMETER :: Processed_IrecNotneeded = 4 INTEGER, PARAMETER :: Treating = 5 INTEGER, PARAMETER :: BeingTreatednotbyme = 6 INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE INTEGER STATE, ISLAVE DO ISLAVE =1, NPROCS IF (MYID.EQ.ISLAVE-1) CYCLE !$OMP ATOMIC READ STATE = RECV_BUF_STATUS(ISLAVE) !$OMP END ATOMIC IF (STATE.EQ.Treating) CYCLE IF (STATE.EQ.Received_NotProcessed) THEN IF (NOMP_SHARED.EQ.1) THEN RECV_BUF_STATUS(ISLAVE) = Treating STATE = Treating ELSE IF (KEEP(399).LE.3) THEN !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Treating !$OMP END ATOMIC STATE = Treating ELSE !$OMP CRITICAL(ARROW_RECV_BUF_STATUS) !$OMP ATOMIC READ STATE = RECV_BUF_STATUS(ISLAVE) !$OMP END ATOMIC IF (STATE.EQ.Received_NotProcessed) THEN !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Treating !$OMP END ATOMIC STATE = Treating ELSE STATE = BeingTreatednotbyme ENDIF !$OMP END CRITICAL(ARROW_RECV_BUF_STATUS) ENDIF ENDIF IF (STATE.NE.Treating) CYCLE IF (NO_ATOMIC_Warrow) THEN CALL SMUMPS_ARROW_TREAT_RECV_BUF_1TH() ELSE CALL SMUMPS_ARROW_TREAT_RECV_BUF() ENDIF ENDDO RETURN CONTAINS SUBROUTINE SMUMPS_ARROW_TREAT_RECV_BUF() INTEGER :: IREC, NB_REC, TYPE_NODE INTEGER :: IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER(8) :: IS8 INTEGER :: IARR, JARR, IW4_CAPTURED INTEGER :: NB_END_MSG_2_RECV_COPY REAL :: VAL LOGICAL :: LAST_MESSAGE LAST_MESSAGE = .FALSE. NB_REC = BUFRECVI( 1, ISLAVE ) TYPE_NODE = -998 IF ( NB_REC .LE. 0 ) THEN LAST_MESSAGE = .TRUE. !$OMP ATOMIC CAPTURE NB_END_MSG_2_RECV_COPY = NB_END_MSG_2_RECV NB_END_MSG_2_RECV = NB_END_MSG_2_RECV - 1 !$OMP END ATOMIC NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) GOTO 100 DO IREC = 1, NB_REC IARR = BUFRECVI( IREC * 2, ISLAVE ) JARR = BUFRECVI( IREC * 2 + 1, ISLAVE ) VAL = BUFRECVR( IREC, ISLAVE ) IF (EARLYT3ROOTINS) THEN TYPE_NODE = MUMPS_TYPENODE( & PROCNODE_STEPS(abs(STEP(abs( IARR )))), & KEEP(199) ) ENDIF IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JARR ) ELSE IPOSROOT = root%RG2L( JARR ) JPOSROOT = root%RG2L( -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 !$OMP ATOMIC UPDATE S( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = S( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL !$OMP END ATOMIC ELSE !$OMP ATOMIC UPDATE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL !$OMP END ATOMIC ENDIF ELSE IF (IARR.GE.0) THEN IF (IARR.EQ.JARR) THEN IS8 = PTRAW(IARR) !$OMP ATOMIC UPDATE DBLARR(IS8) = DBLARR(IS8) + VAL !$OMP END ATOMIC ELSE !$OMP ATOMIC CAPTURE IW4_CAPTURED= IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 !$OMP END ATOMIC IS8 = PTRAW(IARR)+int(IW4_CAPTURED,8) INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ELSE IARR = -IARR !$OMP ATOMIC CAPTURE IW4_CAPTURED = IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 !$OMP END ATOMIC IS8 = PTRAW(IARR) + int(IW4_CAPTURED,8) INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ENDDO 100 CONTINUE IF (LAST_MESSAGE) THEN !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Processed_IrecNotneeded !$OMP END ATOMIC ELSE !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Processed_IrecNeeded !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE SMUMPS_ARROW_TREAT_RECV_BUF SUBROUTINE SMUMPS_ARROW_TREAT_RECV_BUF_1TH() INTEGER :: IREC, NB_REC, TYPE_NODE INTEGER :: IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER(8) :: IS8 INTEGER :: IARR, JARR INTEGER :: NB_END_MSG_2_RECV_COPY REAL :: VAL LOGICAL :: LAST_MESSAGE TYPE_NODE = -997 LAST_MESSAGE = .FALSE. NB_REC = BUFRECVI( 1, ISLAVE ) IF ( NB_REC .LE. 0 ) THEN LAST_MESSAGE = .TRUE. !$OMP ATOMIC CAPTURE NB_END_MSG_2_RECV_COPY = NB_END_MSG_2_RECV NB_END_MSG_2_RECV = NB_END_MSG_2_RECV - 1 !$OMP END ATOMIC NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) GOTO 100 DO IREC = 1, NB_REC IARR = BUFRECVI( IREC * 2, ISLAVE ) JARR = BUFRECVI( IREC * 2 + 1, ISLAVE ) VAL = BUFRECVR( IREC, ISLAVE ) IF (EARLYT3ROOTINS) THEN TYPE_NODE = MUMPS_TYPENODE( & PROCNODE_STEPS(abs(STEP(abs( IARR )))), & KEEP(199) ) ENDIF IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JARR ) ELSE IPOSROOT = root%RG2L( JARR ) JPOSROOT = root%RG2L( -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 S( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = S( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%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 IS8 = PTRAW(IARR) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IS8 = PTRAW(IARR)+IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ENDDO 100 CONTINUE IF (LAST_MESSAGE) THEN !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Processed_IrecNotneeded !$OMP END ATOMIC ELSE !$OMP ATOMIC WRITE RECV_BUF_STATUS(ISLAVE) = Processed_IrecNeeded !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE SMUMPS_ARROW_TREAT_RECV_BUF_1TH END SUBROUTINE SMUMPS_ARROW_TRY_TREAT_RECV_BUF SUBROUTINE SMUMPS_FAC_ARROW_ARRANGE ( & MYID, IOMP, N, SHIFT_PID, SLAVEF, LSCAL, NSEND8, NLOCAL8, & ILOC8_P, NB_RANGE_P, NZ_loc8, IRN_LOC, JCN_LOC, A_loc, SIZESCAL, & ROWSCA, COLSCA, ISTEP_TO_INIV2, CANDIDATES, KEEP, MPI_MASTER, & NO_ATOMIC_Warrow, NO_ATOMIC_Wsendbuf, TH_InvolvedinTreatRecv, & NPROCS, NBRECORDS, MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, IACT, & SEND_ACTIVE, BUFSEND_POSRESERVED, IRECVREQI, IRECVREQR, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, EndNZloc, MPI_End_Send, & End_TreatRecvBuf, & root, roota, & PTR_ROOT, ARROW_ROOT, EARLYT3ROOTINS, LOCAL_M, LOCAL_N, & S, LA, NB_END_MSG_2_RECV, PROCNODE_STEPS, IW4, PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, INTARR, LINTARR, DBLARR, LDBLARR, NOMP_SHARED ) !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, IOMP, N, SHIFT_PID, & SLAVEF, SIZESCAL, MPI_MASTER INTEGER, INTENT(IN) :: NB_RANGE_P, KEEP(500) INTEGER(8), INTENT(IN) :: NZ_loc8, ILOC8_P INTEGER(8), INTENT(INOUT):: NSEND8, NLOCAL8 INTEGER, INTENT(IN) :: IRN_LOC(max(1_8,NZ_loc8)), & JCN_LOC(max(1_8,NZ_loc8)) INTEGER, INTENT(IN):: ISTEP_TO_INIV2(KEEP(71)) INTEGER, INTENT(IN):: CANDIDATES(SLAVEF+1, max(1,KEEP(56))) REAL, INTENT(IN):: A_loc(max(1_8,NZ_loc8)) REAL, INTENT(IN) :: ROWSCA(SIZESCAL), & COLSCA(SIZESCAL) LOGICAL, INTENT(IN):: NO_ATOMIC_Warrow, NO_ATOMIC_Wsendbuf, & TH_InvolvedinTreatRecv INTEGER, INTENT(IN) :: NPROCS, NBRECORDS, COMM, NOMP_SHARED LOGICAL, INTENT(IN) :: MPI_InvolvedinSend, MPI_InvolvedinRecv, & LSCAL INTEGER, INTENT(INOUT) :: EndNZloc LOGICAL, INTENT(INOUT) :: MPI_End_Send, End_TreatRecvBuf INTEGER, INTENT(INOUT) :: ISENDREQI(NPROCS), ISENDREQR(NPROCS), & BUFSENDI(NBRECORDS * 2 + 1, 2, NPROCS), & IACT(NPROCS), BUFSEND_POSRESERVED(2,NPROCS) REAL, INTENT(INOUT) :: BUFSENDR(NBRECORDS, 2, NPROCS) LOGICAL, INTENT(INOUT) :: SEND_ACTIVE(NPROCS) INTEGER, INTENT(INOUT) :: IRECVREQI(NPROCS), IRECVREQR(NPROCS), & BUFRECVI(NBRECORDS * 2 + 1, NPROCS), & RECV_BUF_STATUS(NPROCS) REAL, INTENT(INOUT) :: BUFRECVR(NBRECORDS, NPROCS) INTEGER, PARAMETER :: Processed_IrecNeeded = 1 INTEGER, PARAMETER :: IrecPosted = 2 INTEGER, PARAMETER :: Received_NotProcessed = 3 INTEGER, PARAMETER :: Processed_IrecNotneeded = 4 INTEGER, PARAMETER :: Treating = 5 TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER, INTENT(IN) :: LOCAL_M, LOCAL_N LOGICAL, INTENT(IN) :: EARLYT3ROOTINS INTEGER, INTENT(INOUT) :: ARROW_ROOT INTEGER, INTENT(INOUT):: IW4( N, 2 ) INTEGER, INTENT(INOUT):: NB_END_MSG_2_RECV INTEGER(8), INTENT(IN) :: PTRAW( N ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER, INTENT(IN) :: PERM( N ), STEP( N ) INTEGER, INTENT(IN) :: PROCNODE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER, INTENT(INOUT) :: INTARR( LINTARR ) INTEGER(8), INTENT(IN) :: PTR_ROOT, LA REAL, INTENT(INOUT) :: S( LA ), DBLARR( LDBLARR ) INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT INTEGER :: DEST, JSEND, ISEND , DEST_SAVE INTEGER :: I, INIV2, NCAND, T4MASTER INTEGER :: IOLD, JOLD, IARR, TYPESPLIT INTEGER(8) :: IS8, IZ8, LAST8 LOGICAL :: T4_MASTER_CONCERNED INTEGER :: MASTER_NODE, TYPE_NODE, ISTEP_P INTEGER :: IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER :: IROW_GRID, JCOL_GRID, IW4_CAPTURED LOGICAL :: LOCAL_ASSEMBLY, LOCAL REAL :: VAL INTEGER :: ISTEP_T3_1PROC LAST8 = ILOC8_P + int(NB_RANGE_P-1,8) LOCAL_ASSEMBLY = (NPROCS.EQ.1) IF (NPROCS.EQ.1 .AND. KEEP(38).EQ.0) THEN TYPE_NODE = 1 ISTEP_T3_1PROC = -9999 ELSE IF (NPROCS.EQ.1 .AND. KEEP(38).NE.0) THEN ISTEP_T3_1PROC = STEP(KEEP(38)) ELSE ISTEP_T3_1PROC = -99999 ENDIF DO IZ8=ILOC8_P, LAST8 IOLD = IRN_loc(IZ8) JOLD = JCN_loc(IZ8) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE ENDIF IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = IOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF VAL = A_loc(IZ8) IF (LSCAL) THEN VAL = VAL * ROWSCA(IOLD)*COLSCA(JOLD) ENDIF IF (NPROCS.GT.1 .OR. KEEP(38).NE.0) THEN ISTEP_P = abs(STEP(IARR)) IF ( NPROCS.EQ.1 .AND. ISTEP_P.NE.ISTEP_T3_1PROC ) THEN TYPE_NODE=1 ELSE IF (NPROCS.EQ.1) THEN TYPE_NODE=3 IF (EARLYT3ROOTINS) THEN IF ( ISEND < 0 ) THEN IPOSROOT = root%RG2L(JSEND) JPOSROOT = root%RG2L(IARR ) ELSE IPOSROOT = root%RG2L(IARR ) JPOSROOT = root%RG2L(JSEND) END IF END IF ELSE ISTEP_P = abs(STEP(IARR)) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP_P), KEEP(199) ) MASTER_NODE = MASTER_NODE + SHIFT_PID T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 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 INIV2 = ISTEP_TO_INIV2(ISTEP_P) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP_P), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER= & CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & + SHIFT_PID ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND < 0 ) THEN IPOSROOT = root%RG2L(JSEND) JPOSROOT = root%RG2L(IARR ) ELSE IPOSROOT = root%RG2L(IARR ) JPOSROOT = root%RG2L(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 + SHIFT_PID ELSE DEST = -2 ENDIF ENDIF IF (DEST .eq. -1) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .EQ. -2) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .eq.MYID ) THEN NLOCAL8 = NLOCAL8 + 1_8 ELSE NSEND8 = NSEND8 + 1_8 ENDIF ENDIF LOCAL_ASSEMBLY = .FALSE. IF ( DEST.EQ.-1) THEN INIV2 = ISTEP_TO_INIV2(ISTEP_P) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79) .GT. 0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) + SHIFT_PID IF (DEST.LT.0) EXIT LOCAL = (DEST.EQ.MYID) IF (LOCAL) LOCAL_ASSEMBLY = .TRUE. IF (LOCAL) CYCLE IF (I.EQ.NCAND+1) CYCLE CALL SMUMPS_DIST_FILL_SEND_BUFFER() ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) + SHIFT_PID LOCAL = (DEST.EQ.MYID) IF (LOCAL) LOCAL_ASSEMBLY = .TRUE. IF (LOCAL) CYCLE CALL SMUMPS_DIST_FILL_SEND_BUFFER() ENDDO ENDIF IF ( LOCAL_ASSEMBLY ) THEN DEST_SAVE = DEST DEST = MASTER_NODE IF (DEST.NE.MYID) & CALL SMUMPS_DIST_FILL_SEND_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER IF (DEST.NE.MYID) & CALL SMUMPS_DIST_FILL_SEND_BUFFER() ENDIF DEST = DEST_SAVE ELSE DEST=MASTER_NODE LOCAL_ASSEMBLY = (DEST.EQ.MYID) IF (.NOT.LOCAL_ASSEMBLY) & CALL SMUMPS_DIST_FILL_SEND_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER LOCAL_ASSEMBLY = (DEST.EQ.MYID) IF (.NOT.LOCAL_ASSEMBLY) & CALL SMUMPS_DIST_FILL_SEND_BUFFER() ENDIF ENDIF ELSE IF (DEST .GE. 0) THEN LOCAL_ASSEMBLY = (DEST.EQ.MYID) IF (.NOT.LOCAL_ASSEMBLY) & CALL SMUMPS_DIST_FILL_SEND_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER LOCAL_ASSEMBLY = (DEST.EQ.MYID) IF (.NOT.LOCAL_ASSEMBLY) & CALL SMUMPS_DIST_FILL_SEND_BUFFER() ENDIF ELSE IF (DEST .EQ. -2) THEN DO I = 0, SLAVEF-1 DEST=I + SHIFT_PID IF (DEST.NE.MYID) & CALL SMUMPS_DIST_FILL_SEND_BUFFER() ENDDO IF (SHIFT_PID.EQ.1.AND.MYID.EQ.MPI_MASTER) THEN LOCAL_ASSEMBLY=.FALSE. ELSE LOCAL_ASSEMBLY=.TRUE. ENDIF ENDIF ENDIF ENDIF IF (LOCAL_ASSEMBLY) THEN IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN !$OMP ATOMIC UPDATE S( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = S( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL !$OMP END ATOMIC ELSE !$OMP ATOMIC UPDATE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL !$OMP END ATOMIC ENDIF ELSE IF (NO_ATOMIC_Warrow) THEN IF (ISEND.EQ.JSEND) THEN IS8 = PTRAW(ISEND) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IF (ISEND.GE.0) THEN IS8 = PTRAW(IARR)+IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL ELSE IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL ENDIF ELSE IF (ISEND.EQ.JSEND) THEN IS8 = PTRAW(ISEND) !$OMP ATOMIC UPDATE DBLARR(IS8) = DBLARR(IS8) + VAL !$OMP END ATOMIC ELSE IF (ISEND.GE.0) THEN !$OMP ATOMIC CAPTURE IW4_CAPTURED = IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 !$OMP END ATOMIC IS8 = PTRAW(IARR) + int(IW4_CAPTURED,8) INTARR(IS8) = JSEND DBLARR(IS8) = VAL ELSE !$OMP ATOMIC CAPTURE IW4_CAPTURED = IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 !$OMP END ATOMIC IS8 = PTRAW(IARR) + int(IW4_CAPTURED,8) INTARR(IS8) = JSEND DBLARR(IS8) = VAL ENDIF ENDIF ENDIF ENDIF ENDDO RETURN CONTAINS SUBROUTINE SMUMPS_DIST_FILL_SEND_BUFFER( ) INTEGER IREQ, IACT_P, ISLAVE ISLAVE = DEST+1 100 CONTINUE !$OMP ATOMIC READ IACT_P = IACT(ISLAVE) !$OMP END ATOMIC IF (NO_ATOMIC_Wsendbuf) THEN BUFSEND_POSRESERVED(IACT_P,ISLAVE) = & BUFSEND_POSRESERVED(IACT_P, ISLAVE) + 1 IREQ = BUFSEND_POSRESERVED(IACT_P, ISLAVE) IF (IREQ > NBRECORDS ) THEN IF (IREQ > huge(NBRECORDS)-1000 - NOMP_SHARED-2) THEN BUFSEND_POSRESERVED(IACT_P, ISLAVE) = min(NBRECORDS+1, & BUFSEND_POSRESERVED(IACT_P, ISLAVE) ) ENDIF IF (NOMP_SHARED.EQ.1) & CALL SMUMPS_ARROW_TRY_PROGRESS_COMM (IOMP, & MYID, NPROCS, NBRECORDS, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) IF (TH_InvolvedinTreatRecv) & CALL SMUMPS_ARROW_TRY_TREAT_RECV_BUF (IOMP, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, & NPROCS, NBRECORDS, N, IW4, & KEEP, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, S, LA, & NB_END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR, & NOMP_SHARED, EARLYT3ROOTINS, NO_ATOMIC_Warrow) IF (NOMP_SHARED.EQ.1) THEN CALL SMUMPS_ARROW_TRY_PROGRESS_COMM (IOMP, & MYID, NPROCS, NBRECORDS, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ELSE IF (.NOT.TH_InvolvedinTreatRecv) THEN CALL MUMPS_USLEEP(200) ELSE CALL MUMPS_USLEEP(20) ENDIF ENDIF GOTO 100 ENDIF BUFSENDI(IREQ*2,IACT_P,ISLAVE) = ISEND BUFSENDI(IREQ*2+1,IACT_P,ISLAVE) = JSEND BUFSENDR(IREQ,IACT_P,ISLAVE ) = VAL IF (IREQ.EQ.NBRECORDS) THEN !$OMP ATOMIC WRITE BUFSENDI(1,IACT_P,ISLAVE) = NBRECORDS !$OMP END ATOMIC ENDIF ELSE !$OMP ATOMIC CAPTURE BUFSEND_POSRESERVED(IACT_P,ISLAVE) = & BUFSEND_POSRESERVED(IACT_P, ISLAVE) + 1 IREQ = BUFSEND_POSRESERVED(IACT_P, ISLAVE) !$OMP END ATOMIC IF (IREQ > huge(NBRECORDS)-NOMP_SHARED-2) THEN !$OMP ATOMIC UPDATE BUFSEND_POSRESERVED(IACT_P, ISLAVE) = min(NBRECORDS+1, & BUFSEND_POSRESERVED(IACT_P, ISLAVE) ) !$OMP END ATOMIC ENDIF IF (IREQ > NBRECORDS ) THEN IF (NOMP_SHARED.EQ.1) THEN CALL SMUMPS_ARROW_TRY_PROGRESS_COMM (IOMP, & MYID, NPROCS, NBRECORDS, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ENDIF IF (TH_InvolvedinTreatRecv) & CALL SMUMPS_ARROW_TRY_TREAT_RECV_BUF (IOMP, & BUFRECVI, BUFRECVR, RECV_BUF_STATUS, & NPROCS, NBRECORDS, N, IW4, & KEEP, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, S, LA, & NB_END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR, & NOMP_SHARED, EARLYT3ROOTINS, NO_ATOMIC_Warrow) IF (NOMP_SHARED.EQ.1) THEN CALL SMUMPS_ARROW_TRY_PROGRESS_COMM (IOMP, & MYID, NPROCS, NBRECORDS, & MPI_InvolvedinSend, MPI_InvolvedinRecv, & COMM, ISENDREQI, ISENDREQR, BUFSENDI, BUFSENDR, & IACT, SEND_ACTIVE, BUFSEND_POSRESERVED, & IRECVREQI, IRECVREQR, BUFRECVI, BUFRECVR, & RECV_BUF_STATUS, NB_END_MSG_2_RECV, & EndNZloc, MPI_End_Send, End_TreatRecvBuf & ) ELSE IF (.NOT.TH_InvolvedinTreatRecv) THEN CALL MUMPS_USLEEP(200) ELSE CALL MUMPS_USLEEP(20) ENDIF ENDIF GOTO 100 ENDIF BUFSENDI(IREQ*2,IACT_P,ISLAVE) = ISEND BUFSENDI(IREQ*2+1,IACT_P,ISLAVE) = JSEND BUFSENDR(IREQ,IACT_P,ISLAVE ) = VAL !$OMP ATOMIC UPDATE BUFSENDI(1,IACT_P,ISLAVE) = BUFSENDI(1,IACT_P,ISLAVE) + 1 !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE SMUMPS_DIST_FILL_SEND_BUFFER END SUBROUTINE SMUMPS_FAC_ARROW_ARRANGE #endif MUMPS_5.8.1/src/zfac_process_bf.F0000664000175000017500000000103115042446441016463 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_PROCESS_BF_RETURN() RETURN END SUBROUTINE ZMUMPS_PROCESS_BF_RETURN MUMPS_5.8.1/src/mumps_flytes.c0000664000175000017500000000153115042446422016123 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include #include #if defined(USE_AVX512_VBMI) #include #endif // NB : mumps_flytes undef __AVX512{F__/VBMI__} flags if USE_AVX512_VBMI is not defined #include "mumps_flytes.h" /* this implementation exists to avoid depending on a c++ compiler * this is inspired from * https://gitlab.com/AntJego/adaptative-precision-blr */ void MUMPS_CALL mumps_flyte_return() {}; MUMPS_5.8.1/src/zmumps_driver.F0000664000175000017500000030726515042446442016264 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C =========================== C FORTRAN 90 Driver for ZMUMPS C (MPI based code) C =========================== C SUBROUTINE ZMUMPS( id ) USE MUMPS_MEMORY_MOD USE ZMUMPS_STRUC_DEF USE ZMUMPS_STATIC_PTR_M ! For Schur pointer #if ! defined(NO_SAVE_RESTORE) USE ZMUMPS_SAVE_RESTORE #endif USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_INTR_STRUC, & ZMUMPS_ENCODE_INTR, & ZMUMPS_DECODE_INTR, & ZMUMPS_INIT_INTR_ENCODING, & ZMUMPS_FREE_INTR_ENCODING C !$ USE OMP_LIB C IMPLICIT NONE C C ======= C Purpose C ======= C C TO SOLVE a SPARSE SYSTEM OF LINEAR EQUATIONS. C GIVEN AN UNSYMMETRIC, SYMMETRIC, OR SYMMETRIC POSITIVE DEFINITE C SPARSE MATRIX A AND AN N-VECTOR B, THIS SUBROUTINE SOLVES THE C SYSTEM A x = b or ATRANSPOSE x = b. C C List of main functionalities provided by the package: C ---------------------------------------------------- C -Unsymmetric solver with partial pivoting (LU factorization) C -Symmetric positive definite solver (LDLT factorization) C -General symmetric solver with pivoting C -Either elemental or assembled matrix input C -Analysis/Factorization/Solve callable separately C -Deficient matrices (symmetric or unsymmetric) C -Rank revealing C -Null space basis computation C -Solution C -Return the Schur complement matrix while C also providing solution of interior problem C -Distributed input matrix and analysis phase C -Sequential or parallel MPI version (any number of processors) C -Error analysis and iterative refinement C -Out-of-Core factorization and solution C -Solution phase: C -Multiple Right-Hand-sides (RHS) C -Sparse RHS C -Distributed RHS C -Computation of selected entries of the inverse of C original matrix. C - Block Low-Rank (BLR) approximation based factorization C C Method C ------ C The method used is a parallel direct method C based on a sparse multifrontal variant C of Gaussian elimination with partial numerical pivoting. C An initial ordering for the pivotal sequence C is chosen using the pattern of the matrix A + A^T and is C later modified for reasons of numerical stability. Thus this code C performs best on matrices whose pattern is symmetric, or nearly so. C For symmetric sparse matrices or for very unsymmetric and C very sparse matrices, other software might be more appropriate. C C C References : C ----------- C Please see https://mumps-solver.org/index.php?page=doc C C============================================ C Argument lists and calling sequences C============================================ C C There is only one entry: * * A Fortran 90 driver subroutine ZMUMPS has been designed as a user * friendly interface to the multifrontal code. * This driver, in addition to providing the * normal functionality of a sparse solver, incorporates some * pre- and post-processing. * This driver enables the user to preprocess the matrix to obtain a * maximum * transversal so that the permuted matrix has a zero-free diagonal, * to perform prescaling * of the original matrix (a choice of scaling strategies is provided), * to use iterative refinement to improve the solution, * and finally to perform error analysis. * * The driver routine ZMUMPS offers similar functionalities to other * sparse direct solvers, depending on the value of one of * its parameters (JOB). The main ones are: * * (i) JOB = -1 C initializes an instance of the package. This must be C called before any other call to the package concerning that instance. C It sets default values for other C components of ZMUMPS_STRUC, which may then be altered before C subsequent calls to ZMUMPS. C Note that three components of the structure must always be set by the C user (on all processors) before a call with JOB=-1. These are C id%COMM, C id%SYM, and C id%PAR. C CNTL, ICNTL can then be modified (see documentation) by the user. C * A value of JOB = -1 cannot be combined with other values for JOB * * (ii) JOB = 1 accepts the pattern of matrix A and chooses pivots * from the diagonal using a selection criterion to * preserve sparsity. It uses the pattern of A + A^T * but ignores numerical values. It subsequently constructs subsidiary * information for the actual factorization by a call with JOB_=_2. * An option exists for the user to * input the pivot sequence, in which case only the necessary * information for a JOB = 2 entry will be generated. We call the JOB=1 * entry, the analysis phase. C The following components of the structure define the centralized matrix C pattern and must be set by the user (on the host only) C before a call with JOB=1: C --- id%N, id%NZ (32-bit int) or id%NNZ (64-bit int), C id%IRN, and id%JCN C if the user wishes to input the structure of the C matrix in assembled format (ICNTL(5)=0, and ICNTL(18) $\neq$ 3), C --- id%ELTPTR, and id%ELTVAR C if the user wishes to input the matrix in elemental C format (ICNTL(5)=1). C A distributed matrix format is also available (see documentation) C * (iii) JOB = 2 factorizes a matrix A using the information * from a previous call with JOB = 1. The actual pivot sequence * used may differ slightly from that of this earlier call if A is not * diagonally dominant. * * (iv) JOB = 3 uses the factors generated by a JOB = 2 call to solve * a system of equations A X = B or A^T X =B, where X and B are matrices * that can be either dense or sparse. * The sparsity of B is exploited to limit the number of operations * performed during solution. When only part of the solution is * also needed (such as when computing selected entries of A^1) then * further reduction of the number of operations is performed. * This is particularly beneficial in the context of an * out-of-core factorization. * * (v) JOB = -2 frees all internal data allocated by the package. * * A call with JOB=3 must be preceded by a call with JOB=2, * which in turn must be preceded by a call with JOB=1, which * in turn must be preceded by a call with JOB=-1. Since the * information passed from one call to the next is not * corrupted by the second, several calls with JOB=2 for matrices * with the same sparsity pattern but different values may follow * a single call with JOB=1, and similarly several calls with JOB=3 * can be used for different right-hand sides. * Values 4, 5, 6 for the parameter JOB can invoke combinations * of the three basic operations corresponding to JOB=1, 2 or 3. * * JOB = -4 : frees all data structures from the factorization * while keeping data structures from the analysis. Can be * followed by a JOB = 2 call. * #if ! defined(NO_SAVE_RESTORE) * JOB = -3, 7, 8 : save and restore feature, see userguide #endif * JOB = 9 : provide suggested data distribution for IRHS_LOC C ********* C -------------------------------------- C Explicit interface needed for routines C using a target argument if they appear C in the same compilation unit. C -------------------------------------- INTERFACE SUBROUTINE ZMUMPS_CHECK_DENSE_RHS &(idRHS, idINFO, idN, idNRHS, idLRHS) COMPLEX(kind=8), DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE ZMUMPS_CHECK_DENSE_RHS SUBROUTINE ZMUMPS_ANA_DRIVER( id, idintr ) USE ZMUMPS_STRUC_DEF USE ZMUMPS_INTR_TYPES TYPE (ZMUMPS_STRUC), TARGET :: id TYPE (ZMUMPS_INTR_STRUC) :: idintr END SUBROUTINE ZMUMPS_ANA_DRIVER SUBROUTINE ZMUMPS_FAC_DRIVER( id, idintr ) USE ZMUMPS_STRUC_DEF USE ZMUMPS_INTR_TYPES TYPE (ZMUMPS_STRUC), TARGET :: id TYPE (ZMUMPS_INTR_STRUC) :: idintr END SUBROUTINE ZMUMPS_FAC_DRIVER SUBROUTINE ZMUMPS_SOLVE_DRIVER( id, idintr ) USE ZMUMPS_STRUC_DEF USE ZMUMPS_INTR_TYPES TYPE (ZMUMPS_STRUC), TARGET :: id TYPE (ZMUMPS_INTR_STRUC) :: idintr END SUBROUTINE ZMUMPS_SOLVE_DRIVER SUBROUTINE ZMUMPS_PRINT_ICNTL(id, LP) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP END SUBROUTINE ZMUMPS_PRINT_ICNTL END INTERFACE * MPI * === INCLUDE 'mpif.h' INTEGER MASTER PARAMETER ( MASTER = 0 ) INTEGER IERR * * ========== * Parameters * ========== TYPE (ZMUMPS_STRUC) :: id C C Main components of the structure are: C ------------------------------------ C C (see documentation for a complete description) C C JOB is an INTEGER variable which must be set by the user to C characterize the factorization step. Possible values of JOB C are given below C C 1 Analysis: Ordering and symbolic factorization steps. C 2 Scaling and Numerical Factorization C 3 Solve and Error analysis C 4 Analysis followed by numerical factorization C 5 Numerical factorization followed by Solving step C 6 Analysis, Numerical factorization and Solve C C N is an INTEGER variable which must be set by the user to the C order n of the matrix A. It is not altered by the C subroutine. C C NZ / NNZ are INTEGER / INTEGER(8) variables which must be set by the user C to the number of entries being input, in case of centralized assembled C entry. It is not altered by the subroutine. Only used if C ICNTL(5).eq.0 and ICNTL(18) .ne. 3 (assembled matrix entry, C or, at least, centralized matrix graph during analysis). C C Restriction: NZ > 0 or NNZ > 0. C If NNZ is different from 0, NNZ is used. Otherwise, NZ is used. C C NELT is an INTEGER variable which must be set by the user to the C number of elements being input. It is not altered by the C subroutine. Only used if ICNTL(5).eq.1 (elemental matrix entry). C Restriction: NELT > 0. C C IRN and JCN are INTEGER arrays of length [N]NZ. C IRN(k) and JCN(k), k=1..[N]NZ must be set on entry to hold C the row and column indices respectively. C They are not altered by the subroutine except when ICNTL(6) = 1. C (in which case only the column indices are modified). C The arrays are only used if ICNTL(5).eq.0 (assembled entry) C or out-of-range. C C ELTPTR is an INTEGER array of length NELT+1. C ELTVAR is an INTEGER array of length ELTPTR(NELT+1)-1. C ELTPTR(I) points in ELTVAR to the first variable in the list of C variables that correspond to element I. ELTPTR(NELT+1) points C to the first unused location in ELTVAR. C The positions ELTVAR(I) .. ELTPTR(I+1)-1 contain the variables C for element I. No free space is allowed between variable lists. C ELTPTR/ELTVAR are not altered by the subroutine. C The arrays are only used if ICNTL(5).ne.0 (element entry). C C A is a COMPLEX(kind=8) array of length [N]NZ. C The user must set A(k) to the value C of the entry in row IRN(k) and column JCN(k) of the matrix. C It is not altered by the subroutine. C (Note that the matrix can also be provided in a distributed C assembled input format) C C RHS is a COMPLEX(kind=8) array of length N that is only accessed when C JOB = 3, 5, or 6. On entry, RHS(i) C must hold the i th component of the right-hand side of the C equations being solved. C On exit, RHS(i) will hold the i th component of the C solution vector. For other values of JOB, RHS is not accessed and C can be declared to have size one. C RHS should only be available on the host processor. If C it is associated on other processors, an error is raised. C (Note that the right-hand sides can also be provided in a C sparse format). C C COLSCA, ROWSCA are DOUBLE PRECISION C arrays of length N that are used to hold C the values used to scale the columns and the rows C of the original matrix, respectively. C These arrays need to be set by the user C only if ICNTL(8) is set to -1. If ICNTL(8)=0, C COLSCA and ROWSCA are not accessed and C so can be declared to have size one. C For any other values of ICNTL(8), C the scaling arrays are computed before C numerical factorization. The factors of the scaled matrix C diag(ROWSCA(i)) automatic choice IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ( id%KEEP(52) .EQ. 2 .OR. id%KEEP(52).EQ.5 & .OR. id%KEEP(52) .EQ. 6 ) & id%KEEP(52) = 77 IF ((id%KEEP(52).EQ.77).AND.(id%KEEP(50).EQ.1)) THEN ! for SPD matrices default is no scaling id%KEEP(52) = 0 ENDIF IF ( id%KEEP(52).EQ.77 .OR. id%KEEP(52).LE.-2) THEN C -- suppress scaling computed during analysis C -- if centralized matrix is not associated IF (.not.associated(id%A)) id%KEEP(52) = 0 ENDIF C deactivate analysis scaling if scaling given IF(id%KEEP(52) .EQ. -1) id%KEEP(52) = 0 C C deactivate analysis scaling if C permutation to zero-free diagonal not requested IF (id%ICNTL(6).EQ.0) id%KEEP(52) = 0 C deactivate analysis scaling for SPD matrices IF (id%KEEP(50).EQ.1) id%KEEP(52) = 0 C IF (id%KEEP(52).EQ.-2) THEN C deallocate scalings in case of ordering allocated/computed C during analysis. This is needed because in case of C KEEP(52)=-2 then one cannot be sure that C scaling will be effectivly computed during analysis C Thus to test if scaling was effectively allocated/computed C during analysis after ZMUMPS_ANA_DRIVER one must C be sure that scaling arrays are nullified. IF ( associated(id%COLSCA)) THEN DEALLOCATE( id%COLSCA ) NULLIFY(id%COLSCA) ENDIF IF ( associated(id%ROWSCA)) THEN DEALLOCATE( id%ROWSCA ) NULLIFY(id%ROWSCA) ENDIF ENDIF C C} ENDIF C C ANALYSIS PHASE: CALL ZMUMPS_ANA_DRIVER( id, idintr ) C restore values id%KEEP(77) = KEEP77SAVE id%KEEP(78) = KEEP78SAVE id%KEEP(83) = KEEP83SAVE id%KEEP(91) = KEEP91SAVE id%KEEP(172) = KEEP172SAVE id%KEEP(178) = KEEP178SAVE #if ! defined(LARGEMATRICES) IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0) THEN IF (.not.associated(id%UNS_PERM)) THEN C I may happen C (for ex in case of error -7 during analysis: C UNS_PERM can be not associated, C KEEP(23) was set to to automatic choice(=7) and C an error of memory allocation occurs during analysis C before having decided value of KEEP(23)) C UNS_PERM not associated and KEEP(23).NE.0 C Permuting JCN back does not make sense and KEEP(23) C should be reset to zero id%KEEP(23) = 0 ELSE UNS_PERM_DONE = .TRUE. ENDIF ENDIF #endif C C Check and save scaling option in INFOG(33) IF (id%MYID .eq. MASTER) THEN C{ IF (id%KEEP(52).EQ.0) id%INFOG(33)=id%ICNTL(8) IF (id%KEEP(52).EQ.-2) THEN C Scaling should have been computed during analysis IF (.not.associated(id%COLSCA).OR. & .not.associated(id%ROWSCA) & ) THEN C scaling was not computed reset KEEP(52) C the user can then decide during factorization C to activate scaling id%KEEP(52) =0 id%INFOG(33)=0 IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') & ' Warning; scaling was not computed during analysis' ENDIF IF ( associated(id%COLSCA)) THEN DEALLOCATE( id%COLSCA ) NULLIFY(id%COLSCA) ENDIF IF ( associated(id%ROWSCA)) THEN DEALLOCATE( id%ROWSCA ) NULLIFY(id%ROWSCA) ENDIF ENDIF ENDIF IF (id%KEEP(52) .NE. 0) THEN id%INFOG(33)=id%KEEP(52) ENDIF C} ENDIF C return value of ICNTL(12) effectively used C that was saved on the master in KEEP(95) IF (id%MYID .eq. MASTER) id%INFOG(24)=id%KEEP(95) C TIMINGS: IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(71) = TIMEG ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in analysis driver= ', TIMEG END IF C ----------------------- C Return in case of error C ----------------------- IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 id%KEEP(40) = 1 -456789 END IF C C------------------------------------------------------- C- C C BEGIN FACTORIZATION PHASE C C- C------------------------------------------------------- IF ( LFACTO ) THEN C{ IF (id%MYID .eq. MASTER) THEN id%DKEEP(91)=0.0D0 CALL MUMPS_SECDEB(TIMEG) END IF C ---------------------- C Reset KEEP(40) to 1 in C case of error in facto C ---------------------- id%KEEP(40) = 1 - 456789 C C------------------------------------------------------- C- C- CHECKS, SCALING, ARROWHEAD + FACTORIZATION PHASE C- C------------------------------------------------------- C C Broadcast the value of KEEP(125) to decide if performing C the scaling with the Schur complement feature. CALL MPI_BCAST( id%KEEP(125), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) IF ( id%MYID .EQ. MASTER ) THEN C ------------------------- C Check if Schur complement C is allocated. C ------------------------- IF (id%KEEP(60).EQ.1) THEN IF ( associated( id%SCHUR_CINTERFACE)) THEN C Called from C interface... C Since id%SCHUR_CINTERFACE is of size 1, C instruction below which causes bound check C errors should be avoided. We cheat by first C setting a static pointer with a routine with C implicit interface, and then copying this pointer C into id%SCHUR. CALL ZMUMPS_SET_TMP_PTR(id%SCHUR_CINTERFACE(1), & int(id%SIZE_SCHUR,8)*int(id%SIZE_SCHUR,8)) CALL ZMUMPS_GET_TMP_PTR(id%SCHUR) NULLIFY(id%SCHUR_CINTERFACE) ENDIF IF ( .NOT. associated (id%SCHUR)) THEN IF (LP.GT.0) & write(LP,'(A)') & ' SCHUR not associated' id%INFO(1)=-22 id%INFO(2)=9 ELSE IF ( size(id%SCHUR) .LT. & id%SIZE_SCHUR * id%SIZE_SCHUR ) THEN IF (LP.GT.0) & write(LP,'(A)') & ' SCHUR allocated but too small' id%INFO(1)=-22 id%INFO(2)=9 END IF END IF C ------------------------------------------------------------ C Assembled entry: check input parameterd IRN,JCN,A C Element entry: check input parameters ELTPTR,ELTVAR,A_ELT C ------------------------------------------------------------ IF ( id%KEEP(54) .EQ. 0 ) THEN IF ( id%KEEP(55).eq.0 ) THEN C Assembled entry IF ( .not. associated( id%IRN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 #if defined(MUMPS_NOF2003) C size with kind=8 output not available. One can still C check that if NZ can be stored in a 32-bit integer, C the 32-bit size(id%IRN) (which we then assume not C to overflow...) is large enough ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%IRN) < int(id%KEEP8(28)) ) THEN #else ELSE IF ( size( id%IRN, KIND=8 ) < id%KEEP8(28) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%JCN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 #if defined(MUMPS_NOF2003) C Same as for IRN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%JCN) < int(id%KEEP8(28)) ) THEN #else ELSE IF ( size( id%JCN, KIND=8 ) < id%KEEP8(28) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( .not. associated( id%A ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 #if defined(MUMPS_NOF2003) C Same as for IRN/JCN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size( id%A ) < int(id%KEEP8(28)) ) THEN #else ELSE IF ( size( id%A, KIND=8 ) < id%KEEP8(28) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 END IF ELSE C Element entry IF ( .not. associated( id%ELTPTR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( size( id%ELTPTR ) < id%NELT+1 ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%ELTVAR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( size( id%ELTVAR ) < id%LELTVAR ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( .not. associated( id%A_ELT ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ELSE #if defined(MUMPS_NOF2003) IF ( id%KEEP8(30) < int(huge(id%NZ),8) .AND. & size( id%A_ELT ) < int(id%KEEP8(30)) ) THEN #else IF ( size( id%A_ELT, KIND=8 ) < id%KEEP8(30) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ENDIF END IF ENDIF ENDIF C ---------------------- C Get the value of PERLU C ---------------------- CALL MUMPS_GET_PERLU(id%KEEP(12),id%ICNTL(14), & id%KEEP(50),id%KEEP(54),id%ICNTL(6),id%ICNTL(8)) C C ---------------------- C Get null space options C Note that nullspace is forbidden in case of Schur complement C ---------------------- CALL ZMUMPS_GET_NS_OPTIONS_FACTO(id%N,id%KEEP(1), & id%ICNTL(1),MPG) C ======================================== C Decode and set scaling options for facto C ======================================== IF (.NOT. ((id%KEEP(52).EQ.-2).AND.(id%ICNTL(8).EQ.77)) ) & THEN C if scaling was computed during analysis and automatic C choice of scaling then we do not recompute scaling id%KEEP(52)=id%ICNTL(8) ENDIF IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ( id%KEEP(52) .EQ. 2 .OR. id%KEEP(52).EQ.5 & .OR. id%KEEP(52) .EQ. 6 ) & id%KEEP(52) = 77 IF (id%KEEP(52).EQ.77) THEN IF (id%KEEP(50).EQ.1) THEN ! for SPD matrices the default is "no scaling" id%KEEP(52) = 0 ELSE ! SYM .ne. 1 the default is cheap SIMSCA id%KEEP(52) = 7 ENDIF ENDIF IF (id%KEEP(23) .NE. 0 .AND. id%ICNTL(8) .EQ. -1) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** WARNING : SCALING' WRITE(MPG,'(A)') & ' ** column permutation applied:' WRITE(MPG,'(A)') & ' ** column scaling has to be permuted' ENDIF ENDIF C ----------------------------------- C If Schur has been asked for C choose to disable or enable scaling C ---------------------------------- IF (id%KEEP(125).EQ.0) THEN C ------------------------ C scaling is disabled C ------------------------ IF ( id%KEEP(60) .ne. 0 .and. id%KEEP(52) .ne. 0 ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 .AND. id%ICNTL(8) .NE. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: scaling not applied.' WRITE(MPG,'(A)') ' ** (disabled with Schur)' END IF END IF END IF C ------------------------------- C If matrix is distributed on C entry, only options 7 and 8 C of scaling are allowed. C ------------------------------- IF (id%KEEP(54) .NE. 0 .AND. & id%KEEP(52).NE.7 .AND. id%KEEP(52).NE.8 .AND. & id%KEEP(52) .NE. 0 ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 .and. id%ICNTL(8) .ne. 0 ) THEN WRITE(MPG,'(A)') & ' ** Warning: requested scaling option not available' WRITE(MPG,'(A)') ' ** for distributed matrix entry' END IF END IF C ------------------------------------ C If matrix is symmetric, only scaling C options -1 (given scaling), 1 C (diagonal scaling), 7 and 8 (SIMSCALING) C are allowed. C ------------------------------------ IF ( id%KEEP(50) .NE. 0 ) THEN IF ( id%KEEP(52).ne. 1 .and. & id%KEEP(52).ne. -1 .and. & id%KEEP(52).ne. 0 .and. & id%KEEP(52).ne. 7 .and. & id%KEEP(52).ne. 8 .and. & id%KEEP(52).ne. -2 .and. & id%KEEP(52).ne. 77) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') & ' ** Warning: scaling option n.a. for symmetric matrix' END IF id%KEEP(52) = 0 END IF END IF C ---------------------------------- C If matrix is elemental on entry, C automatic scaling is now forbidden C ---------------------------------- IF (id%KEEP(55) .NE. 0 .AND. & ( id%KEEP(52) .gt. 0 ) ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: scaling not applied.' WRITE(MPG,'(A)') & ' ** (only user scaling av. for elt. entry)' END IF END IF C -------------------------------------- C Check input parameters ROWSCA / COLSCA C -------------------------------------- IF ( id%KEEP(52) .eq. -1 ) THEN IF ( .not. associated( id%ROWSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( .not. associated( id%COLSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 6 ELSE IF ( size( id%COLSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 6 END IF END IF C C Allocate -- if required, C ROWSCA and COLSCA on the master C C Allocation of scaling arrays. C IF (KEEP(52)==-2 then scaling should have been allocated C and computed during analysis C C If ICNTL(8) == -1, ROWSCA and COLSCA must have been associated and C filled by the user. If ICNTL(8) is >0 and <= 8, the scaling is C computed at the beginning of ZMUMPS_FAC_DRIVER and is allocated now. C IF (id%KEEP(52).GT.0 .AND. & id%KEEP(52) .LE.8) THEN IF ( associated(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(id%N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=id%N ENDIF ALLOCATE( id%ROWSCA(id%N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=id%N ENDIF END IF C C Allocate scaling arrays of size 1 if C they are not used to avoid problems C when passing them in arguments C IF (.NOT. associated(id%COLSCA)) THEN ALLOCATE( id%COLSCA(1), stat=IERR) END IF IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 ENDIF IF (.NOT. associated(id%ROWSCA)) & ALLOCATE( id%ROWSCA(1), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF ( LPOK ) WRITE(LP,'(A)') & 'Problems in allocations before facto' GOTO 200 END IF IF (id%KEEP(252) .EQ. 1) THEN CALL ZMUMPS_CHECK_DENSE_RHS & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) C Sets KEEP(221) and do some checks C in case of Schur check if reduced RHS C requested CALL ZMUMPS_SET_K221(id,.FALSE.) CALL ZMUMPS_CHECK_K221andREDRHS(id) ENDIF 200 CONTINUE END IF ! End of IF (MYID .eq. MASTER) C KEEP(221) was set in ZMUMPS_SET_K221 but not broadcast CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) C broadcast RR option CALL MPI_BCAST( id%KEEP(19), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) C C Check distributed matrices on all processors. I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (I_AM_SLAVE .AND. & id%KEEP(54).NE.0 .AND. id%KEEP8(29).GT.0_8) THEN IF ( .not. associated( id%IRN_loc ) ) THEN id%INFO(1) = -22 id%INFO(2) = 16 #if defined(MUMPS_NOF2003) C size with kind=8 output not available. One can still C check that if NZ_loc can be stored in a 32-bit integer, C the 32-bit size(id%IRN_loc) (which we then assume not C to overflow...) is large enough ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size(id%IRN_loc) < int(id%KEEP8(29)) ) THEN #else ELSE IF ( size( id%IRN_loc, KIND=8 ) < id%KEEP8(29) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 16 ELSE IF ( .not. associated( id%JCN_loc ) ) THEN id%INFO(1) = -22 id%INFO(2) = 16 #if defined(MUMPS_NOF2003) C Same as for IRN_loc above ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size(id%JCN_loc) < int(id%KEEP8(29)) ) THEN #else ELSE IF ( size( id%JCN_loc, KIND=8 ) < id%KEEP8(29) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 16 ELSEIF ( .not. associated( id%A_loc ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 16 #if defined(MUMPS_NOF2003) C Same as for IRN_loc/JCN_loc above ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size( id%A_loc ) < int(id%KEEP8(29)) ) THEN #else ELSE IF ( size( id%A_loc, KIND=8 ) < id%KEEP8(29) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 16 END IF ENDIF C C Check Schur complement on all processors. C ZMUMPS_PROPINFO will be called right after those checks. C IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF ( idintr%root%yes ) THEN IF ( associated( id%SCHUR_CINTERFACE )) THEN C Called from C interface... C The next instruction may cause C bound check errors at runtime C id%SCHUR=>id%SCHUR_CINTERFACE C & (1:id%SCHUR_LLD*(idintr%root%SCHUR_NLOC-1)+ C & idintr%root%SCHUR_MLOC) C Instead, we set a temporary C pointer and then retrieve it CALL ZMUMPS_SET_TMP_PTR(id%SCHUR_CINTERFACE(1), & int(id%SCHUR_LLD,8)*int(idintr%root%SCHUR_NLOC-1,8)+ & int(idintr%root%SCHUR_MLOC,8)) CALL ZMUMPS_GET_TMP_PTR(id%SCHUR) NULLIFY(id%SCHUR_CINTERFACE) ENDIF C Check that SCHUR_LLD is large enough IF (id%SCHUR_LLD < idintr%root%SCHUR_MLOC) THEN IF (LP.GT.0) write(LP,*) & ' SCHUR leading dimension SCHUR_LLD ', & id%SCHUR_LLD, 'too small with respect to', & idintr%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*(idintr%root%SCHUR_NLOC-1)+ & idintr%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=', idintr%root%SCHUR_NLOC, & ' SCHUR_NLOC=', idintr%root%SCHUR_NLOC ENDIF id%INFO(1)=-22 id%INFO(2)= 9 ELSE C We initialize the pointer that C we will use within ZMUMPS here. idintr%root%SCHUR_LLD=id%SCHUR_LLD IF (idintr%root%SCHUR_NLOC==0) THEN ALLOCATE(idintr%roota%SCHUR_POINTER(1), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF ( LPOK ) THEN WRITE(LP,'(A)') & 'Problems in allocations before facto' ENDIF END IF ELSE idintr%roota%SCHUR_POINTER=>id%SCHUR ENDIF ENDIF ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 C ----------------------------------------------- C Call factorization procedure ZMUMPS_FAC_DRIVER C ----------------------------------------------- CALL ZMUMPS_FAC_DRIVER(id,idintr) C Save scaling in INFOG(33) IF (id%MYID .eq. MASTER) id%INFOG(33)=id%KEEP(52) C C In the case of Schur, free or not associated C idintr%roota%SCHUR_POINTER now rather than in end_driver.F C (Case of repeated factorizations). IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF (idintr%root%yes) THEN IF (idintr%root%SCHUR_NLOC==0) THEN DEALLOCATE(idintr%roota%SCHUR_POINTER) NULLIFY(idintr%roota%SCHUR_POINTER) ELSE NULLIFY(idintr%roota%SCHUR_POINTER) ENDIF ENDIF ENDIF IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(91) = TIMEG ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in factorization driver =', & TIMEG END IF C C Check for errors after FACTO C (it was propagated inside) IF(id%INFO(1).LT.0) THEN C ------------------------------------------------------- C Free data from this factorization. Since factorization C fails, factors, etc. can not be used to perform a solve C ------------------------------------------------------- CALL ZMUMPS_FREE_DATA_FACTO(id,idintr) GO TO 499 ENDIF C C Update last successful step C id%KEEP(40) = 2 - 456789 C} END IF C------------------------------------------------------- C- C C BEGIN SOLVE PHASE C C- C------------------------------------------------------- IF (LSOLVE) THEN IF (id%MYID .eq. MASTER) THEN id%DKEEP(111)=0.0D0 CALL MUMPS_SECDEB(TIMEG) END IF C --------------------- C Reset KEEP(40) to 2. C (last successful step C was facto) C --------------------- id%KEEP(40) = 2 -456789 C ------------------------------------------ C Call solution procedure ZMUMPS_SOLVE_DRIVER C ------------------------------------------ IF (id%MYID .eq. MASTER) THEN KEEP235SAVE = id%KEEP(235) KEEP242SAVE = id%KEEP(242) KEEP243SAVE = id%KEEP(243) KEEP495SAVE = id%KEEP(495) KEEP497SAVE = id%KEEP(497) ! if no permutation of RHS asked then suppress request ! to interleave the RHS ! to interleave the RHS on ordering given then ! using option to set permutation to identity should be ! used (note though that ! they # with A-1/sparseRHS and Null Space) IF (id%KEEP(242).EQ.0) id%KEEP(243)=0 C -------------------------------------- C Check input parameters ROWSCA / COLSCA C Only if KEEP(52).NE.0 because C only 0 means that no colsca/rowsca are needed C -------------------------------------- IF ( id%KEEP(52) .ne. 0) THEN IF ( .not. associated( id%ROWSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( .not. associated( id%COLSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 6 ELSE IF ( size( id%COLSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 6 END IF ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 CALL ZMUMPS_SOLVE_DRIVER(id,idintr) IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(111) = TIMEG ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in solve driver= ', TIMEG END IF IF (id%MYID .eq. MASTER) THEN id%KEEP(235) = KEEP235SAVE id%KEEP(242) = KEEP242SAVE id%KEEP(243) = KEEP243SAVE id%KEEP(495) = KEEP495SAVE id%KEEP(497) = KEEP497SAVE ENDIF IF (id%INFO(1).LT.0) GOTO 499 C --------------------------- C Update last successful step C --------------------------- id%KEEP(40) = 3 -456789 ENDIF C C What was actually done is saved in KEEP(40) C IF (PROK) CALL ZMUMPS_PRINT_ICNTL(id, MP) GOTO 500 * *================= * ERROR section *================= 499 CONTINUE * Print error message if PROK IF (LPOK) WRITE (LP,99995) id%INFO(1) IF (LPOK) WRITE (LP,99994) id%INFO(2) * 500 CONTINUE #if ! defined(LARGEMATRICES) C --------------------------------- C Permute JCN on output to ZMUMPS if C KEEP(23) is different from 0. C --------------------------------- IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0 & .AND. NOERRORBEFOREPERM) THEN C ------------------------------- C IF JOB=3 and PERM was not C done (no iterative refinement/ C error analysis), then we do not C permute JCN back. C ------------------------------- IF (UNS_PERM_DONE) THEN DO I8 = 1_8, id%KEEP8(28) J=id%JCN(I8) C -- skip out-of range (that are ignored in ANA_O) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I8)=id%UNS_PERM(J) END DO END IF END IF #endif 510 CONTINUE C ------------------------------------ C Set INFOG(1:2): same value on all C processors + broadcast other entries C ------------------------------------ CALL ZMUMPS_SET_INFOG(id%INFO(1), id%INFOG(1), id%COMM, id%MYID) C C -------------------------------- C Broadcast RINFOG entries to make C them available on all procs. C -------------------------------- CALL MPI_BCAST( id%RINFOG(1), 40, MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) IF (id%INFOG(1).GE.0 .AND. JOB.NE.-1 & .AND. JOB.NE.-2 ) THEN IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMETOTAL) id%DKEEP(70) = TIMETOTAL ENDIF ENDIF C ------------------------------------------------------------ C SCHUR_CINTERFACE is no longer needed. It will be set again C the next time MUMPS is entered through its C interface. C ------------------------------------------------------------ NULLIFY(id%SCHUR_CINTERFACE) C #if ! defined(NO_SAVE_RESTORE) *======================= * Compute space for save *======================= IF (id%INFOG(1).GE.0) THEN IF ( IDINTR_MEANINGFUL_ON_EXIT ) THEN C Only do this if idintr is meaningful on exit. This includes C the case of JOB -2 that needs to update statistics. This excludes C the cases of JOBs that did not decode idintr, for which the save C restore statistics have not changed. CALL ZMUMPS_COMPUTE_MEMORY_SAVE(id,idintr,FILE_SIZE,STRUC_SIZE) id%KEEP8(55)=FILE_SIZE call MPI_ALLREDUCE(id%KEEP8(55),id%KEEP8(57),1, & MPI_INTEGER8, MPI_SUM,id%COMM,IERR) id%KEEP8(56)=STRUC_SIZE call MPI_ALLREDUCE(id%KEEP8(56),id%KEEP8(58),1, & MPI_INTEGER8, MPI_SUM,id%COMM,IERR) id%RINFO(7)=dble(id%KEEP8(55))/1D6 id%RINFO(8)=dble(id%KEEP8(56))/1D6 id%RINFOG(17)=dble(id%KEEP8(57))/1D6 id%RINFOG(18)=dble(id%KEEP8(58))/1D6 ENDIF ENDIF #endif !$ IF (ICNTL16_LOC .GT. 0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(PREVIOUS_OMP_THREADS_NUM,4)) #else !$ CALL omp_set_num_threads(PREVIOUS_OMP_THREADS_NUM) #endif !$ ICNTL16_LOC = 0 !$ ENDIF *=============== * ERRORG section *=============== IF (id%MYID.EQ.MASTER.and.MPG.GT.0.and. & id%INFOG(1).lt.0) THEN WRITE(MPG,'(A,I16)') ' On return from ZMUMPS, INFOG(1)=', & id%INFOG(1) WRITE(MPG,'(A,I16)') ' On return from ZMUMPS, INFOG(2)=', & id%INFOG(2) END IF C ------------------------- C Restore user communicator C ------------------------- CALL MPI_COMM_FREE( id%COMM, IERR ) id%COMM = COMM_SAVE C ------------------------------------ C Set id%INTR_ENCODING from idintr C ------------------------------------ IF (MUST_ENCODE_IDINTR_ON_EXIT) THEN CALL ZMUMPS_ENCODE_INTR(id%INTR_ENCODING, idintr) ENDIF RETURN * 99995 FORMAT (' ** ERROR RETURN ** FROM ZMUMPS INFO(1)=', I5) 99994 FORMAT (' ** INFO(2)=', I16) 99993 FORMAT (' ** Allocation error: could not permute JCN.') END SUBROUTINE ZMUMPS * SUBROUTINE ZMUMPS_SET_INFOG( INFO, INFOG, COMM, MYID ) IMPLICIT NONE INCLUDE 'mpif.h' C C Purpose: C ======= C C If one proc has INFO(1).lt.0 and INFO(1) .ne. -1, C puts INFO(1:2) of this proc on all procs in INFOG C C Arguments: C ========= C INTEGER, PARAMETER :: SIZE_INFOG = 80 INTEGER :: INFO(80) INTEGER :: INFOG(SIZE_INFOG) ! INFOG(80) INTEGER :: COMM, MYID C C Local variables C =============== C #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) :: TMP1(2),TMP(2) #else INTEGER :: TMP1(2),TMP(2) #endif INTEGER ROOT, IERR INTEGER MASTER, WARNING_COUNT PARAMETER (MASTER=0) C C IF ( INFO(1) .ge. 0 ) THEN C C This can only happen if the phase was successful C on all procs. If one proc failed, then all other C procs would have INFO(1)=-1. C IF (INFO(1) .GT.0) THEN WARNING_COUNT=1 ELSE WARNING_COUNT=0 ENDIF INFOG(1) = INFO(1) INFOG(2) = INFO(2) CALL MPI_ALLREDUCE(WARNING_COUNT, INFOG(2), 1,MPI_INTEGER, & MPI_SUM, COMM, IERR) CALL MPI_ALLREDUCE(INFO(1),INFOG(1),1, MPI_INTEGER, & MPI_BOR, COMM, IERR) ELSE C --------------------- C Find who has smallest C error code INFO(1) C --------------------- INFOG(1) = INFO(1) C INFOG(2) = MYID TMP1(1) = INFO(1) TMP1(2) = MYID CALL MPI_ALLREDUCE(TMP1,TMP,1,MPI_2INTEGER, & MPI_MINLOC,COMM,IERR ) INFOG(2) = INFO(2) ROOT = TMP(2) CALL MPI_BCAST( INFOG(1), 1, MPI_INTEGER, ROOT, COMM, IERR ) CALL MPI_BCAST( INFOG(2), 1, MPI_INTEGER, ROOT, COMM, IERR ) END IF C C Make INFOG available on all procs: C CALL MPI_BCAST(INFOG(3), SIZE_INFOG-2, MPI_INTEGER, & MASTER, COMM, IERR ) RETURN END SUBROUTINE ZMUMPS_SET_INFOG C-------------------------------------------------------------------- SUBROUTINE ZMUMPS_PRINT_ICNTL (id, LP) USE ZMUMPS_STRUC_DEF * * Purpose: * Print main control parameters CNTL and ICNTL * * ========== * Parameters * ========== TYPE (ZMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP ** Local Variables INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL DOUBLE PRECISION, DIMENSION(:),POINTER::CNTL INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL CNTL=>id%CNTL IF (id%MYID.EQ.MASTER) THEN SELECT CASE (JOB) CASE(1); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ENDIF IF ((ICNTL(6).EQ.5).OR.(ICNTL(6).EQ.6).OR. & (ICNTL(12).NE.1) ) THEN WRITE (LP,992) ICNTL(8) ENDIF IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) WRITE (LP,996) ICNTL(56) CASE(2); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36), ICNTL(49) WRITE (LP,996) ICNTL(56) 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),ICNTL(26) CASE(4); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ENDIF WRITE (LP,992) ICNTL(8) IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36), ICNTL(49) WRITE (LP,996) ICNTL(56) CASE(5); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ENDIF WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21),ICNTL(26) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36), ICNTL(49) WRITE (LP,996) ICNTL(56) CASE(6); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ENDIF IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,992) ICNTL(8) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21), ICNTL(26) WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36), ICNTL(49) WRITE (LP,996) ICNTL(56) END SELECT ENDIF 980 FORMAT (/'***********CONTROL PARAMETERS (ICNTL)**************'/) 981 FORMAT ( & ' CNTL(1) Threshold for numerical pivoting =',D16.4/ & ' CNTL(3) Threshold to detect singularities =',D16.4/ & ' CNTL(4) Threshold for static pivoting =',D16.4/ & ' CNTL(5) Fixation for null pivots =',D16.4/ & ' CNTL(7) Dropping threshold for BLR compression =',D16.4) 990 FORMAT ( & 'ICNTL(1) Output stream for error messages =',I10/ & 'ICNTL(2) Output stream for diagnostic messages =',I10/ & 'ICNTL(3) Output stream for global information =',I10/ & 'ICNTL(4) Level of printing =',I10) 991 FORMAT ( & 'ICNTL(5) Matrix format =',I10/ & 'ICNTL(6) Maximum transversal =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(12) LDLT ordering strat =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(15) Analysis by block =',I10/ & 'ICNTL(18) Distributed matrix =',I10/ & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-of-core option (1=on, off otherwise)=',I10/ & 'ICNTL(48) Tree based multithreading =',I10/ & 'ICNTL(58) Symbolic factorization option =',I10) 891 FORMAT ( & 'ICNTL(5) Matrix format =',I10/ & 'ICNTL(6) Maximum transversal =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(15) Analysis by block =',I10/ & 'ICNTL(18) Distributed matrix =',I10/ & 'ICNTL(19) Schur option ( 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-of-core option (1=on, off otherwise)=',I10/ & 'ICNTL(48) Tree based multithreading =',I10/ & 'ICNTL(58) Symbolic factorization option =',I10) 992 FORMAT ( & 'ICNTL(8) Scaling strategy =',I10) 923 FORMAT ( & 'ICNTL(24) Null pivot detection (0=off) =',I10/ & 'ICNTL(31) Discard factors (0=off, else=on) =',I10/ & 'ICNTL(32) Forward elimination during facto (0=off)=',I10/ & 'ICNTL(33) Compute determinant (0=off) =',I10/ & 'ICNTL(35) Block Low Rank (BLR, 0=off >0=on) =',I10/ & 'ICNTL(36) BLR variant =',I10/ & 'ICNTL(49) Compact workarray S (end of facto.) =',I10) 993 FORMAT ( & 'ICNTL(14) Percent of memory increase =',I10) 996 FORMAT ( & 'ICNTL(56) Null space functionality =',I10) 995 FORMAT ( & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ & 'ICNTL(10) Max steps iterative refinement =',I10/ & 'ICNTL(11) Error analysis (1=all,2=some,else=off) =',I10/ & 'ICNTL(20) Den.(0)/sparse(1,2,3)/dist.(10,11) RHS =',I10/ & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10/ & 'ICNTL(26) Solution step =',I10) 998 FORMAT ( & ' Size of SCHUR matrix (SIZE_SCHUR) =',I10) END SUBROUTINE ZMUMPS_PRINT_ICNTL C-------------------------------------------------------------------- SUBROUTINE ZMUMPS_PRINT_KEEP(id, LP) USE ZMUMPS_STRUC_DEF * * ========== * Parameters * ========== TYPE (ZMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER ::LP ** Local Variables INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL, KEEP INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL KEEP=>id%KEEP IF (id%MYID.EQ.MASTER) THEN SELECT CASE (JOB) CASE(1); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6))THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) CASE(2); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (KEEP(23).EQ.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) WRITE (LP,996) KEEP(19), KEEP(118) WRITE (LP,994) KEEP(21) 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), ICNTL(26) 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), ICNTL(26) WRITE (LP,993) KEEP(12) WRITE (LP,997) KEEP(53) WRITE (LP,996) KEEP(19), KEEP(118) WRITE (LP,994) KEEP(21) 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) WRITE (LP,996) KEEP(19), KEEP(118) WRITE (LP,994) KEEP(21) 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), ICNTL(26) WRITE (LP,993) KEEP(12) WRITE (LP,997) KEEP(53) WRITE (LP,996) KEEP(19), KEEP(118) WRITE (LP,994) KEEP(21) 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-of-core option (1=on, off otherwise)=',I10) 992 FORMAT ( & 'ICNTL(8) Scaling strategy ( keep(52) ) =',I10) 993 FORMAT ( & 'ICNTL(14) Percent of memory increase ( keep(12) ) =',I10) 995 FORMAT ( & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ & 'ICNTL(10) Max steps iterative refinement =',I10/ & 'ICNTL(11) Error analysis ( 0= off, else=on) =',I10/ & 'ICNTL(20) Den.(0)/sparse(1,2,3)/dist.(10,11) RHS =',I10/ & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10/ & 'ICNTL(26) Solution step =',I10) 997 FORMAT ( & 'ICNTL(56) Null space-analysis ( keep(53) ) =',I10) 996 FORMAT ( & 'ICNTL(56) Null space-factorisation ( keep(19) ) =',I10/ & 'KEEP(118) Algorithm used for null space =',I10) 994 FORMAT ( & 'ICNTL(57) Estimate of null space size ( keep(21) )=',I10) END SUBROUTINE ZMUMPS_PRINT_KEEP SUBROUTINE ZMUMPS_CHECK_DENSE_RHS & (idRHS, idINFO, idN, idNRHS, idLRHS) IMPLICIT NONE C C Purpose: C ======= C C Check that the dense RHS is associated and of C correct size. Called on master only, when dense C RHS is supposed to be allocated. This can be used C either at the beginning of the solve phase or C at the beginning of the factorization phase C if forward solve is done during factorization C (see ICNTL(32)) ; idINFO(1), idINFO(2) may be C modified. C C C Arguments: C ========= C C id* : see corresponding components of the main C MUMPS structure. C COMPLEX(kind=8), DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) IF ( .not. associated( idRHS ) ) THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 ELSE IF (idNRHS.EQ.1) THEN IF ( size( idRHS ) < idN ) THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 ENDIF ELSE IF (idLRHS < idN) & THEN idINFO( 1 ) = -26 idINFO( 2 ) = idLRHS ELSE IF #if defined(MUMPS_NOF2003) C size with kind=8 not available. One can still C perform the check if minimal size small enough. & (int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN & .LE. int(huge(idN),8) & .and. & size(idRHS) < int(int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN)) #else & (size(idRHS,kind=8) < & int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN) #endif & THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 END IF RETURN END SUBROUTINE ZMUMPS_CHECK_DENSE_RHS C SUBROUTINE ZMUMPS_SET_K221(id,ATSOLVE) USE ZMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C Sets KEEP(221) on master. C [Schur only] must be called before ZMUMPS_CHECK_REDRHS C C Can be called at factorization C (in case of fwd in facto) or at solve phase C ATSOLVE=.TRUE. if called during solve phase C TYPE (ZMUMPS_STRUC) :: id LOGICAL, INTENT(IN) :: ATSOLVE LOGICAL :: PROKG INTEGER :: MPG INTEGER MASTER PARAMETER( MASTER = 0 ) MPG = id%ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) IF (id%MYID.EQ.MASTER) THEN id%KEEP(221)=id%ICNTL(26) IF (id%KEEP(221).NE.0 .AND. id%KEEP(221) .NE.1 & .AND.id%KEEP(221).NE.2) id%KEEP(221)=0 ENDIF RETURN END SUBROUTINE ZMUMPS_SET_K221 C SUBROUTINE ZMUMPS_CHECK_K221andREDRHS(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C * Decode API related to REDRHS and check REDRHS C * Can be called at factorization or solve phase C * Constraints: C - Must be called after solve phase. C - KEEP(60) must have been set (ok to check C since KEEP(60) was set during analysis phase) C * Remark that during solve phase, ICNTL(26)#0 is C forbidden in case of fwd in facto. C TYPE (ZMUMPS_STRUC) :: id INTEGER MASTER PARAMETER( MASTER = 0 ) C write(6,*) " Entering ZMUMPS_CHECK_K221andREDRHS with : ", C & " id%JOB, id%KEEP(221), id%KEEP(60), id%SIZE_SCHUR= ", C & id%JOB, id%KEEP(221), id%KEEP(60), id%SIZE_SCHUR 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 .NE.3 ) & ) THEN id%INFO(1)=-33 id%INFO(2)=id%JOB 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) C write(6,*) " id%KEEP(60), id%SIZE_SCHUR=", C & id%KEEP(60), id%SIZE_SCHUR GOTO 333 ENDIF IF ( id%KEEP(60).NE.0 ) THEN C Schur feature IF ( 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 ENDIF 333 CONTINUE C Error is not propagated. It should be propagated outside. C The reason to propagate it outside is that there can be C one call to PROPINFO instead of several ones. RETURN END SUBROUTINE ZMUMPS_CHECK_K221andREDRHS MUMPS_5.8.1/src/ztype3_root.F0000664000175000017500000016127315042446441015653 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ASS_ROOT( root, roota, KEEP50, & NROW_SON, NCOL_SON, INDROW_SON, & INDCOL_SON, NSUPCOL, VAL_SON, VAL_ROOT, & LOCAL_M, LOCAL_N, & RHS_ROOT, NLOC_ROOT, CBP ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER, INTENT(IN) :: KEEP50 INTEGER NCOL_SON, NROW_SON, NSUPCOL INTEGER, intent(in) :: CBP INTEGER INDROW_SON( NROW_SON ), INDCOL_SON( NCOL_SON ) INTEGER LOCAL_M, LOCAL_N COMPLEX(kind=8) VAL_SON( NCOL_SON, NROW_SON ) COMPLEX(kind=8) VAL_ROOT( LOCAL_M, LOCAL_N ) INTEGER NLOC_ROOT COMPLEX(kind=8) RHS_ROOT( LOCAL_M, NLOC_ROOT ) INTEGER I, J, INDROW, INDCOL, IPOSROOT, JPOSROOT IF (CBP .EQ. 0) THEN DO I = 1, NROW_SON INDROW = INDROW_SON(I) IPOSROOT = (root%NPROW*((INDROW-1)/root%MBLOCK)+root%MYROW) & * root%MBLOCK + mod(INDROW-1,root%MBLOCK) + 1 DO J = 1, NCOL_SON-NSUPCOL INDCOL = INDCOL_SON(J) IF (KEEP50.NE.0) THEN JPOSROOT = (root%NPCOL*((INDCOL-1)/root%NBLOCK)+root%MYCOL) & * root%NBLOCK + mod(INDCOL-1,root%NBLOCK) + 1 IF (IPOSROOT < JPOSROOT) THEN CYCLE ENDIF ENDIF VAL_ROOT( INDROW, INDCOL ) = & VAL_ROOT( INDROW, INDCOL ) + VAL_SON(J,I) END DO DO J = NCOL_SON-NSUPCOL+1, NCOL_SON INDCOL = INDCOL_SON(J) RHS_ROOT( INDROW, INDCOL ) = & RHS_ROOT( INDROW, INDCOL ) + VAL_SON(J,I) ENDDO END DO ELSE DO I=1, NROW_SON DO J = 1, NCOL_SON RHS_ROOT( INDROW_SON( I ), INDCOL_SON(J)) = & RHS_ROOT(INDROW_SON(I),INDCOL_SON(J)) + VAL_SON(J,I) ENDDO ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_ASS_ROOT RECURSIVE SUBROUTINE ZMUMPS_BUILD_AND_SEND_CB_ROOT & ( COMM_LOAD, ASS_IRECV, N, ISON, IROOT, & PTRI, PTRR, & root, roota, NBROW, NBCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, SHIFT_VAL_SON_ARG, LDA_ARG, TAG, & MYID, COMM, BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,TRANSPOSE_ASM, & ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS, NELIM_ROOT, NELIM_ROW, NELIM_COL & ) USE ZMUMPS_OOC USE ZMUMPS_BUF USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER N, ISON, IROOT, TAG INTEGER PTRI( KEEP(28) ) INTEGER(8) :: PTRR( KEEP(28) ) INTEGER NBROW, NBCOL INTEGER, INTENT(IN):: LDA_ARG INTEGER(8), INTENT(IN) :: SHIFT_VAL_SON_ARG INTEGER SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER MYID, COMM LOGICAL TRANSPOSE_ASM INTEGER :: NELIM_ROOT, NELIM_ROW, NELIM_COL INCLUDE 'mpif.h' INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NSTK( N ) INTEGER COMP, IFLAG, IERROR INTEGER PERM(N) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) COMPLEX(kind=8), DIMENSION(:), POINTER :: SONA_PTR INTEGER(8) :: LSONA_PTR, POSSONA_PTR INTEGER allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: PTRROW, PTRCOL INTEGER, ALLOCATABLE, DIMENSION(:) :: NSUPROW, NSUPCOL INTEGER, ALLOCATABLE, DIMENSION(:) :: ROW_INDEX_LIST INTEGER, ALLOCATABLE, DIMENSION(:) :: COL_INDEX_LIST INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER I, POS_IN_ROOT, IROW, JCOL, IGLOB, JGLOB INTEGER PDEST, IERR INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: POSROOT INTEGER NSUBSET_ROW, NSUBSET_COL INTEGER NRLOCAL, NCLOCAL INTEGER :: LDA INTEGER(8) :: SHIFT_VAL_SON LOGICAL SET_IRECV, BLOCKING, MESSAGE_RECEIVED INTEGER NBROWS_ALREADY_SENT INTEGER SIZE_MSG INTEGER LP INCLUDE 'mumps_headers.h' LOGICAL SKIPLAST_RHS_ROWS, BCP_SYM_NONEMPTY INTEGER BBPCBP BBPCBP = 0 LP = ICNTL(1) IF ( ICNTL(4) .LE. 0 ) LP = -1 IF (LDA_ARG < 0) THEN CALL ZMUMPS_SET_LDA_SHIFT_VAL_SON(IW, LIW, PTRI(STEP(ISON)), & LDA, SHIFT_VAL_SON) ELSE LDA = LDA_ARG SHIFT_VAL_SON = SHIFT_VAL_SON_ARG ENDIF ALLOCATE(PTRROW(root%NPROW + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPROW + 1 endif ALLOCATE(PTRCOL(root%NPCOL + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPCOL + 1 endif ALLOCATE(NSUPROW(root%NPROW + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPROW + 1 endif ALLOCATE(NSUPCOL(root%NPCOL + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPCOL + 1 endif IF (IFLAG.LT.0) THEN IF (LP > 0) write(6,*) MYID, ' : MEMORY ALLOCATION ', & 'FAILURE in ZMUMPS_BUILD_AND_SEND_CB_ROOT' CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF SKIPLAST_RHS_ROWS = ((KEEP(253).GT.0).AND.(KEEP(50).EQ.0)) BCP_SYM_NONEMPTY = .FALSE. PTRROW = 0 PTRCOL = 0 NSUPROW = 0 NSUPCOL = 0 DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (IGLOB.GT.N) THEN BCP_SYM_NONEMPTY = .TRUE. POS_IN_ROOT = IGLOB - N JCOL = mod((POS_IN_ROOT-1)/root%NBLOCK,root%NPCOL) NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 ELSE IF ( I .LE. NELIM_ROW ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( IGLOB ) ENDIF 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 IF ( I .LE. NELIM_ROW ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( IGLOB ) ENDIF ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, root%NPCOL ) IF (IGLOB.GT.N) & NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 END IF END DO IF (KEEP(50).NE.0 .AND.(.NOT.TRANSPOSE_ASM).AND.BCP_SYM_NONEMPTY) & BBPCBP = 1 DO I = 1, NBCOL JGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_COL_SON + I - 1 ) IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (KEEP(50).EQ.0) THEN IF (JGLOB.LE.N) THEN IF ( I.LE.NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L(JGLOB) ENDIF 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 IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( JGLOB ) ENDIF JCOL = mod((POS_IN_ROOT-1) / root%NBLOCK, root%NPCOL ) PTRCOL ( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 IF (BCP_SYM_NONEMPTY) THEN 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 IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( JGLOB ) ENDIF ELSE POS_IN_ROOT = JGLOB-N ENDIF IROW = mod( ( POS_IN_ROOT - 1 ) / & root%MBLOCK, root%NPROW ) PTRROW ( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 END IF END DO PTRROW( 1 ) = 1 DO IROW = 2, root%NPROW + 1 PTRROW( IROW ) = PTRROW( IROW ) + PTRROW( IROW - 1 ) END DO PTRCOL( 1 ) = 1 DO JCOL = 2, root%NPCOL + 1 PTRCOL( JCOL ) = PTRCOL( JCOL ) + PTRCOL( JCOL - 1 ) END DO ALLOCATE(ROW_INDEX_LIST(PTRROW(root%NPROW+1)-1+1), & stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = PTRROW(root%NPROW+1)-1+1 endif ALLOCATE(COL_INDEX_LIST(PTRCOL(root%NPCOL+1)-1+1), & stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = PTRCOL(root%NPCOL+1)-1+1 endif DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (IGLOB.GT.N) CYCLE IF ( I .LE. NELIM_ROW ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( IGLOB ) 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 ELSE IF (IGLOB.LE.N) THEN IF ( I .LE. NELIM_ROW ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( IGLOB ) ENDIF ELSE POS_IN_ROOT = IGLOB - N ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, & root%NPCOL ) COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 END IF END DO DO I = 1, NBCOL JGLOB = IW( PTRI(STEP(ISON))+SHIFT_LIST_COL_SON+I - 1 ) IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF ( JGLOB.LE.N ) THEN IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( JGLOB ) ENDIF 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 IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L( JGLOB ) ENDIF 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 IF ( I .LE. NELIM_COL ) THEN POS_IN_ROOT = NELIM_ROOT + I - 1 ELSE POS_IN_ROOT = root%RG2L(JGLOB) ENDIF ENDIF IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I PTRROW( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 ENDDO ENDIF DO IROW = root%NPROW, 2, -1 PTRROW( IROW ) = PTRROW( IROW - 1 ) END DO PTRROW( 1 ) = 1 DO JCOL = root%NPCOL, 2, -1 PTRCOL( JCOL ) = PTRCOL( JCOL - 1 ) END DO PTRCOL( 1 ) = 1 JCOL = root%MYCOL IROW = root%MYROW IF ( root%yes ) THEN if (IROW .ne. root%MYROW .or. JCOL.ne.root%MYCOL) then write(*,*) ' error in grid position buildandsendcbroot' CALL MUMPS_ABORT() end if IF ( PTRIST(STEP(IROOT)).EQ.0.AND. & PTLUST_S(STEP(IROOT)).EQ.0) THEN CALL ZMUMPS_ROOT_ALLOC_STATIC(root, roota, IROOT, N, IW, LIW, & A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP, IERROR ) KEEP(121) = -1 IF (IFLAG.LT.0) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF ELSE KEEP(121) = KEEP(121) - 1 IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL ZMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL ZMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL ZMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT+N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF END IF CALL ZMUMPS_DM_SET_DYNPTR( IW(PTRI(STEP(ISON))+XXS), A, LA, & PTRR(STEP(ISON)), IW(PTRI(STEP(ISON))+XXD), & IW(PTRI(STEP(ISON))+XXR), & SONA_PTR, POSSONA_PTR, LSONA_PTR ) IF (KEEP(60) .NE. 0 ) THEN LOCAL_M = root%SCHUR_LLD LOCAL_N = root%SCHUR_NLOC NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) CALL ZMUMPS_ROOT_LOCAL_ASSEMBLY( N, & roota%SCHUR_POINTER(1), & LOCAL_M, LOCAL_N, & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NRLOCAL, & NCLOCAL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%RG2L(1), TRANSPOSE_ASM, & KEEP, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) ELSE IF ( PTRIST(STEP( IROOT )) .GE. 0 ) THEN IF ( PTRIST(STEP( IROOT )) .EQ. 0 ) THEN LOCAL_N = IW( PTLUST_S(STEP(IROOT)) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST_S(STEP(IROOT)) + 2 + KEEP(IXSZ)) POSROOT = PTRFAC(IW( PTLUST_S(STEP(IROOT)) +4+KEEP(IXSZ) )) ELSE LOCAL_N = - IW( PTRIST(STEP(IROOT)) +KEEP(IXSZ)) LOCAL_M = IW( PTRIST(STEP(IROOT)) + 1 +KEEP(IXSZ)) POSROOT = PAMASTER(STEP( IROOT )) ENDIF NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) CALL ZMUMPS_ROOT_LOCAL_ASSEMBLY( N, A( POSROOT ), & LOCAL_M, LOCAL_N, & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NRLOCAL, & NCLOCAL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%RG2L(1), TRANSPOSE_ASM, & KEEP, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) END IF ENDIF END IF DO IROW = 0, root%NPROW - 1 DO JCOL = 0, root%NPCOL - 1 PDEST = IROW * root%NPCOL + JCOL IF ( (root%MYROW.eq.IROW.and.root%MYCOL.eq.JCOL) .and. & MYID.ne.PDEST) THEN write(*,*) 'error: myrow,mycol=',root%MYROW,root%MYCOL write(*,*) ' MYID,PDEST=',MYID,PDEST CALL MUMPS_ABORT() END IF IF ( root%MYROW .NE. IROW .OR. root%MYCOL .NE. JCOL) THEN NBROWS_ALREADY_SENT = 0 IERR = -1 DO WHILE ( IERR .EQ. -1 ) NSUBSET_ROW = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) NSUBSET_COL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) IF ( LRLU .LT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) & .AND. LRLUS .GT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) ) & THEN CALL ZMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) MYID,": pb compress in", & "ZMUMPS_BUILD_AND_SEND_CB_ROOT" WRITE(*,*) MYID,': LRLU, LRLUS=',LRLU,LRLUS CALL MUMPS_ABORT() END IF END IF CALL ZMUMPS_DM_SET_DYNPTR( & IW(PTRI(STEP(ISON))+XXS), A, LA, & PTRR(STEP(ISON)), IW(PTRI(STEP(ISON))+XXD), & IW(PTRI(STEP(ISON))+XXR), & SONA_PTR, POSSONA_PTR, LSONA_PTR ) CALL ZMUMPS_BUF_SEND_CONTRIB_TYPE3_I( N, ISON, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & TAG, & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NSUBSET_ROW, NSUBSET_COL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%NPROW, root%NPCOL, root%MBLOCK, & root%RG2L(1), & root%NBLOCK, PDEST, & COMM, IERR, A( POSFAC ), LRLU, TRANSPOSE_ASM, & SIZE_MSG, NBROWS_ALREADY_SENT, KEEP, BBPCBP, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK, & COMP, IFLAG, IERROR, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, MYID, SLAVEF, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW,PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (LDA_ARG < 0) THEN CALL ZMUMPS_SET_LDA_SHIFT_VAL_SON( & IW, LIW, PTRI(STEP(ISON)), & LDA, SHIFT_VAL_SON) ENDIF END IF END DO IF ( IERR == -2 ) THEN IFLAG = -17 IERROR = SIZE_MSG IF (LP > 0) WRITE(LP, *) "FAILURE, SEND BUFFER TOO & SMALL DURING ZMUMPS_BUILD_AND_SEND_CB_ROOT" CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 500 ENDIF IF ( IERR == -3 ) THEN IF (LP > 0) WRITE(LP, *) "FAILURE, RECV BUFFER TOO & SMALL DURING ZMUMPS_BUILD_AND_SEND_CB_ROOT" IFLAG = -20 IERROR = SIZE_MSG CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 500 ENDIF END IF END DO END DO 500 CONTINUE DEALLOCATE(PTRROW) DEALLOCATE(PTRCOL) DEALLOCATE(ROW_INDEX_LIST) DEALLOCATE(COL_INDEX_LIST) RETURN CONTAINS SUBROUTINE ZMUMPS_SET_LDA_SHIFT_VAL_SON(IW, LIW, IOLDPS, & LDA, SHIFT_VAL_SON) INTEGER, INTENT(IN) :: LIW, IOLDPS INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT) :: LDA INTEGER(8), INTENT(OUT) :: SHIFT_VAL_SON INCLUDE 'mumps_headers.h' INTEGER :: LCONT, NROW, NPIV, NASS, NELIM LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV IF (IW(IOLDPS+XXS).EQ.S_NOLCBNOCONTIG38.OR. & IW(IOLDPS+XXS).EQ.S_ALL) THEN SHIFT_VAL_SON = int(NPIV,8) LDA = LCONT + NPIV ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCBCONTIG38) THEN SHIFT_VAL_SON = int(NROW,8)*int(LCONT+NPIV-NELIM,8) LDA = NELIM ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCLEANED38) THEN SHIFT_VAL_SON=0_8 LDA = NELIM ELSE WRITE(*,*) MYID, & ": internal error in ZMUMPS_SET_LDA_SHIFT_VAL_SON", & IW(IOLDPS+XXS), "ISON=",ISON CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE ZMUMPS_SET_LDA_SHIFT_VAL_SON END SUBROUTINE ZMUMPS_BUILD_AND_SEND_CB_ROOT SUBROUTINE ZMUMPS_ROOT_LOCAL_ASSEMBLY( N, VAL_ROOT, & LOCAL_M, LOCAL_N, & NPCOL, NPROW, MBLOCK, NBLOCK, NBCOL_SON, NBROW_SON, INDCOL_SON, & INDROW_SON, LD_SON, VAL_SON, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, NSUPROW, NSUPCOL, & RG2L, TRANSPOSE_ASM, & KEEP, RHS_ROOT, NLOC, NELIM_ROOT, NELIM_ROW, NELIM_COL ) IMPLICIT NONE INTEGER N, LOCAL_M, LOCAL_N COMPLEX(kind=8) VAL_ROOT( LOCAL_M, LOCAL_N ) INTEGER NPCOL, NPROW, MBLOCK, NBLOCK INTEGER NBCOL_SON, NBROW_SON INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER LD_SON INTEGER NSUPROW, NSUPCOL COMPLEX(kind=8) VAL_SON( LD_SON, NBROW_SON ) INTEGER KEEP(500) INTEGER NSUBSET_ROW, NSUBSET_COL INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER RG2L( N ) LOGICAL TRANSPOSE_ASM INTEGER NLOC COMPLEX(kind=8) RHS_ROOT( LOCAL_M, NLOC) INTEGER :: NELIM_ROOT, NELIM_ROW, NELIM_COL 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 ) IF ( I .LE. NELIM_ROW ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L( IGLOB ) ENDIF 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 ) IF ( J .LE. NELIM_COL ) THEN JPOS_ROOT = NELIM_ROOT + J - 1 ELSE JPOS_ROOT = RG2L( JGLOB ) ENDIF JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO DO JSUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( JSUB ) JGLOB = INDCOL_SON( J ) JPOS_ROOT = JGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 RHS_ROOT(ILOC_ROOT, JLOC_ROOT) = & RHS_ROOT(ILOC_ROOT, JLOC_ROOT) + VAL_SON( J, I ) ENDDO END DO ELSE IF ( .NOT. TRANSPOSE_ASM ) THEN DO ISUB = 1, NSUBSET_ROW - NSUPROW I = SUBSET_ROW( ISUB ) IGLOB = INDROW_SON( I ) IF ( I .LE. NELIM_ROW ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L( IGLOB ) ENDIF 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 ) IF ( J .LE. NELIM_COL ) THEN JPOS_ROOT = NELIM_ROOT + J - 1 ELSE JPOS_ROOT = RG2L( JGLOB ) ENDIF IF (KEEP(50).NE.0. AND. JPOS_ROOT .GT. IPOS_ROOT) CYCLE JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO END DO DO JSUB = NSUBSET_COL -NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( JSUB ) JGLOB = INDROW_SON( J ) JPOS_ROOT = JGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 DO ISUB = NSUBSET_ROW - NSUPROW +1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IGLOB = INDCOL_SON( I ) IF ( I .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L(IGLOB) ENDIF 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 ) IF ( I .LE. NELIM_ROW ) THEN JPOS_ROOT = NELIM_ROOT + I - 1 ELSE JPOS_ROOT = RG2L( IGLOB ) ENDIF 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 ) IF ( J .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + J - 1 ELSE IPOS_ROOT = RG2L( JGLOB ) ENDIF 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 ) IF ( J .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + J - 1 ELSE IPOS_ROOT = RG2L( JGLOB ) ENDIF ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) = & RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO ENDDO END IF END IF RETURN END SUBROUTINE ZMUMPS_ROOT_LOCAL_ASSEMBLY SUBROUTINE ZMUMPS_INIT_ROOT_ANA &( MYID, NPROCS, N, root, COMM_ROOT, IROOT, FILS, & K50, K46, K51 & , K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK & ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC IMPLICIT NONE INTEGER MYID, MYID_ROOT TYPE (MUMPS_ROOT_STRUC)::root INTEGER COMM_ROOT INTEGER N, IROOT, NPROCS, K50, K46, K51 INTEGER FILS( N ) INTEGER K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK INTEGER INODE #if ! defined(NOSCALAPACK) INTEGER NPROWtemp, NPCOLtemp #endif LOGICAL SLAVE root%ROOT_SIZE = 0 root%TOT_ROOT_SIZE = 0 SLAVE = ( MYID .ne. 0 .or. & ( MYID .eq. 0 .and. K46 .eq. 1 ) ) INODE = IROOT DO WHILE ( INODE .GT. 0 ) INODE = FILS( INODE ) root%ROOT_SIZE = root%ROOT_SIZE + 1 END DO IF ( ( K60 .NE. 2 .AND. K60 .NE. 3 ) .OR. & IDNPROW .LE. 0 .OR. IDNPCOL .LE. 0 & .OR. IDMBLOCK .LE.0 .OR. IDNBLOCK.LE.0 & .OR. IDNPROW * IDNPCOL .GT. NPROCS ) THEN root%MBLOCK = K51 root%NBLOCK = K51 CALL ZMUMPS_DEF_GRID( NPROCS, root%NPROW, root%NPCOL, & root%ROOT_SIZE, K50 ) IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN IDNPROW = root%NPROW IDNPCOL = root%NPCOL IDMBLOCK = root%MBLOCK IDNBLOCK = root%NBLOCK ENDIF ELSE IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN root%NPROW = IDNPROW root%NPCOL = IDNPCOL root%MBLOCK = IDMBLOCK root%NBLOCK = IDNBLOCK ENDIF IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN IF (SLAVE) THEN root%LPIV = 0 IF (K46.EQ.0) THEN MYID_ROOT=MYID-1 ELSE MYID_ROOT=MYID ENDIF IF (MYID_ROOT < root%NPROW*root%NPCOL) THEN root%MYROW = MYID_ROOT / root%NPCOL root%MYCOL = mod(MYID_ROOT, root%NPCOL) root%yes = .true. ELSE root%MYROW = -1 root%MYCOL = -1 root%yes = .FALSE. ENDIF ELSE root%yes = .FALSE. ENDIF #if ! defined(NOSCALAPACK) ELSE IF ( SLAVE ) THEN IF ( root%gridinit_done) THEN IF (root%yes) THEN CALL blacs_gridexit( root%CNTXT_BLACS ) root%gridinit_done = .FALSE. ENDIF END IF root%CNTXT_BLACS = COMM_ROOT CALL blacs_gridinit( root%CNTXT_BLACS, 'R', & root%NPROW, root%NPCOL ) root%gridinit_done = .TRUE. CALL blacs_gridinfo( root%CNTXT_BLACS, & NPROWtemp, NPCOLtemp, & root%MYROW, root%MYCOL ) IF ( root%MYROW .NE. -1 ) THEN root%yes = .true. ELSE root%yes = .false. END IF root%LPIV = 0 #endif ELSE root%yes = .FALSE. ENDIF RETURN END SUBROUTINE ZMUMPS_INIT_ROOT_ANA SUBROUTINE ZMUMPS_INIT_ROOT_FAC( N, MYID, root, & FILS, KEEP ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC IMPLICIT NONE TYPE ( MUMPS_ROOT_STRUC ):: root INTEGER, INTENT(IN) :: N, MYID, KEEP(500) INTEGER FILS( N ) INTEGER INODE, I LOGICAL INITIALIZE_RG2L INITIALIZE_RG2L = ( KEEP(38) .NE. 0 ) INITIALIZE_RG2L = .TRUE. IF ( INITIALIZE_RG2L ) THEN INODE = KEEP(38) I = 1 DO WHILE ( INODE .GT. 0 ) root%RG2L( INODE ) = I I = I + 1 INODE = FILS( INODE ) END DO ENDIF root%TOT_ROOT_SIZE=0 RETURN END SUBROUTINE ZMUMPS_INIT_ROOT_FAC SUBROUTINE ZMUMPS_DEF_GRID( NPROCS, NPROW, NPCOL, SIZE, K50 ) IMPLICIT NONE INTEGER NPROCS, NPROW, NPCOL, SIZE, K50 INTEGER NPROWtemp, NPCOLtemp, NPROCSused, FLATNESS LOGICAL KEEPIT IF ( K50 .EQ. 1 ) THEN FLATNESS = 2 ELSE FLATNESS = 3 ENDIF NPROW = int(sqrt(dble(NPROCS))) NPROWtemp = NPROW NPCOL = int(NPROCS / NPROW) NPCOLtemp = NPCOL NPROCSused = NPROWtemp * NPCOLtemp 10 CONTINUE IF ( NPROWtemp >= NPCOLtemp/FLATNESS .AND. NPROWtemp > 1) THEN NPROWtemp = NPROWtemp - 1 NPCOLtemp = int(NPROCS / NPROWtemp) KEEPIT=.FALSE. IF ( NPROWtemp * NPCOLtemp .GE. NPROCSused ) THEN IF ( ( K50 .NE. 1 .AND. NPROWtemp >= NPCOLtemp/FLATNESS) & .OR. NPROWtemp * NPCOLtemp .GT. NPROCSused ) & KEEPIT=.TRUE. END IF IF ( KEEPIT ) THEN NPROW = NPROWtemp NPCOL = NPCOLtemp NPROCSused = NPROW * NPCOL END IF GO TO 10 END IF RETURN END SUBROUTINE ZMUMPS_DEF_GRID SUBROUTINE ZMUMPS_SCATTER_ROOT(MYID, M, N, ASEQ, & LOCAL_M, LOCAL_N, & MBLOCK, NBLOCK, & APAR, & MASTER_ROOT, & NPROW, NPCOL, & COMM) IMPLICIT NONE INTEGER MYID, MASTER_ROOT, COMM INTEGER M, N INTEGER NPROW, NPCOL INTEGER LOCAL_M, LOCAL_N INTEGER MBLOCK, NBLOCK COMPLEX(kind=8) APAR( LOCAL_M, LOCAL_N ) COMPLEX(kind=8) ASEQ( M, N ) INCLUDE 'mpif.h' INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, IDEST, IROW, ICOL INTEGER IBLOCK, JBLOCK, II, JJ, KK INTEGER IAPAR, JAPAR, IERR, allocok INTEGER :: STATUS(MPI_STATUS_SIZE) COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE :: WK LOGICAL JUPDATE ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of WK in ' & // 'routine ZMUMPS_SCATTER_ROOT ' CALL MUMPS_ABORT() endif IAPAR = 1 JAPAR = 1 DO J = 1, N, NBLOCK SIZE_JBLOCK = NBLOCK IF ( J + NBLOCK > N ) THEN SIZE_JBLOCK = N - J + 1 END IF JUPDATE = .FALSE. DO I = 1, M, MBLOCK SIZE_IBLOCK = MBLOCK IF ( I + MBLOCK > M ) THEN SIZE_IBLOCK = M - I + 1 END IF IBLOCK = I / MBLOCK JBLOCK = J / NBLOCK IROW = mod ( IBLOCK, NPROW ) ICOL = mod ( JBLOCK, NPCOL ) IDEST = IROW * NPCOL + ICOL IF ( IDEST .NE. MASTER_ROOT ) THEN IF ( MYID .EQ. MASTER_ROOT ) THEN KK=1 DO JJ=J,J+SIZE_JBLOCK-1 DO II=I,I+SIZE_IBLOCK-1 WK(KK)=ASEQ(II,JJ) KK=KK+1 END DO END DO CALL MPI_SEND( WK, SIZE_IBLOCK*SIZE_JBLOCK, & MPI_DOUBLE_COMPLEX, & IDEST, 128, COMM, IERR ) ELSE IF ( MYID .EQ. IDEST ) THEN CALL MPI_RECV( WK(1), & SIZE_IBLOCK*SIZE_JBLOCK, & MPI_DOUBLE_COMPLEX, & MASTER_ROOT,128,COMM,STATUS,IERR) KK=1 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 APAR(II,JJ)=WK(KK) KK=KK+1 END DO END DO JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, & JAPAR:JAPAR+SIZE_JBLOCK-1 ) & = ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF END DO IF ( JUPDATE ) THEN IAPAR = 1 JAPAR = JAPAR + SIZE_JBLOCK END IF END DO DEALLOCATE(WK) RETURN END SUBROUTINE ZMUMPS_SCATTER_ROOT SUBROUTINE ZMUMPS_GATHER_ROOT(MYID, M, N, ASEQ, & LOCAL_M, LOCAL_N, & MBLOCK, NBLOCK, & APAR, & MASTER_ROOT, & NPROW, NPCOL, & COMM) IMPLICIT NONE INTEGER MYID, MASTER_ROOT, COMM INTEGER M, N INTEGER NPROW, NPCOL INTEGER LOCAL_M, LOCAL_N INTEGER MBLOCK, NBLOCK COMPLEX(kind=8) APAR( LOCAL_M, LOCAL_N ) COMPLEX(kind=8) ASEQ( M, N ) INCLUDE 'mpif.h' INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, ISOUR, IROW, ICOL INTEGER IBLOCK, JBLOCK, II, JJ, KK INTEGER IAPAR, JAPAR, IERR, allocok INTEGER :: STATUS(MPI_STATUS_SIZE) COMPLEX(kind=8),DIMENSION(:), ALLOCATABLE :: WK LOGICAL JUPDATE ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of WK in ' & // 'routine ZMUMPS_GATHER_ROOT ' CALL MUMPS_ABORT() endif IAPAR = 1 JAPAR = 1 DO J = 1, N, NBLOCK SIZE_JBLOCK = NBLOCK IF ( J + NBLOCK > N ) THEN SIZE_JBLOCK = N - J + 1 END IF JUPDATE = .FALSE. DO I = 1, M, MBLOCK SIZE_IBLOCK = MBLOCK IF ( I + MBLOCK > M ) THEN SIZE_IBLOCK = M - I + 1 END IF IBLOCK = I / MBLOCK JBLOCK = J / NBLOCK IROW = mod ( IBLOCK, NPROW ) ICOL = mod ( JBLOCK, NPCOL ) ISOUR = IROW * NPCOL + ICOL IF ( ISOUR .NE. MASTER_ROOT ) THEN IF ( MYID .EQ. MASTER_ROOT ) THEN CALL MPI_RECV( WK(1), SIZE_IBLOCK*SIZE_JBLOCK, & MPI_DOUBLE_COMPLEX, & ISOUR, 128, COMM, STATUS, IERR ) KK=1 DO JJ=J,J+SIZE_JBLOCK-1 DO II=I,I+SIZE_IBLOCK-1 ASEQ(II,JJ)=WK(KK) KK=KK+1 END DO END DO ELSE IF ( MYID .EQ. ISOUR ) THEN KK=1 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 WK(KK)=APAR(II,JJ) KK=KK+1 END DO END DO CALL MPI_SEND( WK( 1 ), & SIZE_IBLOCK*SIZE_JBLOCK, & MPI_DOUBLE_COMPLEX, & MASTER_ROOT,128,COMM,IERR) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) & = APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, & JAPAR:JAPAR+SIZE_JBLOCK-1 ) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF END DO IF ( JUPDATE ) THEN IAPAR = 1 JAPAR = JAPAR + SIZE_JBLOCK END IF END DO DEALLOCATE(WK) RETURN END SUBROUTINE ZMUMPS_GATHER_ROOT SUBROUTINE ZMUMPS_ROOT_ALLOC_STATIC(root, roota, IROOT, N, & IW, LIW, A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) TYPE (MUMPS_ROOT_STRUC ) :: root TYPE (ZMUMPS_ROOT_STRUC ) :: roota INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER IROOT, LIW, N, IWPOS, IWPOSCB INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER ITLOC( N + KEEP(253) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER COMP, IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER FILS( N ), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER INTARR(KEEP8(27)) COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER, EXTERNAL :: MUMPS_NUMROC COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER(8) :: LREQA_ROOT INTEGER LREQI_ROOT, LOCAL_M, LOCAL_N, allocok LOGICAL :: EARLYT3ROOTINS LOCAL_M = MUMPS_NUMROC( root%ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) LOCAL_M = max( 1, LOCAL_M ) LOCAL_N = MUMPS_NUMROC( root%ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) IF (KEEP(253).GT.0) THEN root%RHS_NLOC = MUMPS_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( roota%RHS_ROOT) ) & DEALLOCATE (roota%RHS_ROOT) ALLOCATE(roota%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 roota%RHS_ROOT = ZERO CALL ZMUMPS_ASM_RHS_ROOT ( N, FILS, & root, roota, KEEP, KEEP8, RHS_MUMPS, & IFLAG, IERROR ) IF ( IFLAG .LT. 0 ) RETURN ENDIF IF (KEEP(60) .NE. 0) THEN PTRIST(STEP(IROOT)) = -6666666 ELSE LREQI_ROOT = 2 + KEEP(IXSZ) LREQA_ROOT = int(LOCAL_M,8) * int(LOCAL_N,8) IF (LREQA_ROOT.EQ.0_8) THEN PTRIST(STEP(IROOT)) = -9999999 RETURN ENDIF CALL ZMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LREQI_ROOT, & LREQA_ROOT, IROOT, S_NOTFREE, .TRUE., COMP, & LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PTRIST ( STEP(IROOT) ) = IWPOSCB + 1 PAMASTER( STEP(IROOT) ) = IPTRLU + 1_8 IW( IWPOSCB + 1 + KEEP(IXSZ)) = - LOCAL_N IW( IWPOSCB + 2 + KEEP(IXSZ)) = LOCAL_M ENDIF EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) IF (LOCAL_N > 0 .AND. .NOT. EARLYT3ROOTINS ) THEN IF (KEEP(60) .EQ. 0) THEN CALL ZMUMPS_SET_TO_ZERO(A(IPTRLU+1_8), LOCAL_M, & LOCAL_M, LOCAL_N, KEEP) ELSE CALL ZMUMPS_SET_TO_ZERO(roota%SCHUR_POINTER(1), & root%SCHUR_LLD, LOCAL_M, LOCAL_N, KEEP) ENDIF IF (KEEP(55) .eq. 0) THEN IF (KEEP(60) .EQ. 0) THEN CALL ZMUMPS_ASM_ARR_ROOT( N, root, roota, & IROOT, STEP(IROOT), & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N, & FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL ZMUMPS_ASM_ARR_ROOT( N, root, roota, & IROOT, STEP(IROOT), & roota%SCHUR_POINTER(1), root%SCHUR_LLD, & LOCAL_M, LOCAL_N, & FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ENDIF ELSE IF (KEEP(60) .EQ. 0) THEN CALL ZMUMPS_ASM_ELT_ROOT( N, root, roota, & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ELSE CALL ZMUMPS_ASM_ELT_ROOT( N, root, roota, & roota%SCHUR_POINTER(1), root%SCHUR_LLD, & root%SCHUR_MLOC, root%SCHUR_NLOC, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_ROOT_ALLOC_STATIC SUBROUTINE ZMUMPS_ASM_ELT_ROOT( N, root, roota, & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & INTARR, DBLARR, LINTARR, LDBLARR, & KEEP, KEEP8, & MYID) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER :: N, MYID, LOCAL_M, LOCAL_N, KEEP(500) INTEGER :: LOCAL_M_LLD INTEGER(8) KEEP8(150) COMPLEX(kind=8) VALROOT(LOCAL_M_LLD,LOCAL_N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER, INTENT(INOUT) :: INTARR(LINTARR) COMPLEX(kind=8) DBLARR(LDBLARR) INTEGER(8) :: J1, J2, K8, IPTR INTEGER :: IELT, I, J, IGLOB, SIZEI, IBEG INTEGER :: ARROW_ROOT INTEGER :: IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INTEGER :: ILOCROOT, JLOCROOT ARROW_ROOT = 0 DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1 IELT = FRTELT( IPTR ) J1 = PTRAIW(IELT) J2 = PTRAIW(IELT+1)-1 K8 = PTRARW(IELT) SIZEI=int(J2-J1)+1 DO J=1, SIZEI IGLOB = INTARR(J1+J-1) INTARR(J1+J-1) = root%RG2L(IGLOB) ENDDO DO J = 1, SIZEI IGLOB = INTARR(J1+J-1) IF ( KEEP(50).eq. 0 ) THEN IBEG = 1 ELSE IBEG = J END IF DO I = IBEG, SIZEI IF ( KEEP(50).eq.0 ) THEN IPOSROOT = INTARR(J1+I-1) JPOSROOT = INTARR(J1+J-1) ELSE IF ( INTARR(J1+I-1).GT. INTARR(J1+J-1) ) THEN IPOSROOT = INTARR(J1+I-1) JPOSROOT = INTARR(J1+J-1) ELSE IPOSROOT = INTARR(J1+J-1) JPOSROOT = INTARR(J1+I-1) END IF END IF IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, & root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, & root%NPCOL ) IF ( IROW_GRID.EQ.root%MYROW .AND. & JCOL_GRID.EQ.root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + DBLARR(K8) ENDIF K8 = K8 + 1_8 END DO END DO ARROW_ROOT = ARROW_ROOT + int(PTRARW(IELT+1_8)-PTRARW(IELT)) END DO KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE ZMUMPS_ASM_ELT_ROOT SUBROUTINE ZMUMPS_ASM_RHS_ROOT & ( N, FILS, root, roota, KEEP, KEEP8, RHS_MUMPS, & IFLAG, IERROR ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, KEEP(500), IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER FILS(N) TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) 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( 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 roota%RHS_ROOT(ILOCRHS, JLOCRHS) = & RHS_MUMPS(INODE+(JCOL-1)*KEEP(254)) ENDDO 100 CONTINUE INODE=FILS(INODE) ENDDO RETURN END SUBROUTINE ZMUMPS_ASM_RHS_ROOT SUBROUTINE ZMUMPS_ASM_ARR_ROOT( N, root, roota, IROOT, STEP_IROOT, & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, LINTARR, LDBLARR, & MYID) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER :: N, MYID, IROOT, STEP_IROOT, LOCAL_M, LOCAL_N INTEGER :: LOCAL_M_LLD INTEGER FILS( N ) INTEGER :: KEEP(500) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) COMPLEX(kind=8) VALROOT(LOCAL_M_LLD,LOCAL_N) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER INTARR(LINTARR) COMPLEX(kind=8) DBLARR(LDBLARR) COMPLEX(kind=8) VAL INTEGER(8) :: JJ, J1,J2,J3, J4, AINPUT INTEGER IORG, NUMORG, & IROW, JCOL, IARR1 INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INTEGER ILOCROOT, JLOCROOT NUMORG = root%ROOT_SIZE IARR1=PTRDEBARR(STEP_IROOT) DO IORG = 1, NUMORG AINPUT = PTR8ARR(IARR1+IORG-1) J1 = AINPUT J2 = J1 + NINCOLARR(IARR1+IORG-1) J3 = J2 + 1 J4 = J2 + NINROWARR(IARR1+IORG-1) JCOL = INTARR(J1) DO JJ = J1, J2 IROW = INTARR(JJ) VAL = DBLARR(AINPUT) AINPUT = AINPUT + 1 IPOSROOT = root%RG2L( IROW ) JPOSROOT = root%RG2L( JCOL ) IROW_GRID = mod( ( IPOSROOT - 1 ) / root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 ) / root%NBLOCK, root%NPCOL ) IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + VAL END IF END DO IF (J3 .LE. J4) THEN IROW = INTARR(J1) DO JJ= J3,J4 JCOL = INTARR(JJ) VAL = DBLARR(AINPUT) AINPUT = AINPUT + 1 IPOSROOT = root%RG2L( IROW ) JPOSROOT = root%RG2L( JCOL ) IROW_GRID= mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW) JCOL_GRID= mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL) IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + VAL END IF END DO ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_ASM_ARR_ROOT MUMPS_5.8.1/src/zmumps_lr_data_m.F0000664000175000017500000036725015042446441016712 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_LR_DATA_M USE ZMUMPS_LR_TYPE IMPLICIT NONE PRIVATE PUBLIC :: ZMUMPS_BLR_END_FRONT, ZMUMPS_BLR_INIT_MODULE, & ZMUMPS_BLR_END_MODULE, ZMUMPS_BLR_INIT_FRONT, & ZMUMPS_BLR_SAVE_INIT, & ZMUMPS_BLR_SAVE_PANEL_LORU, ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L, & ZMUMPS_BLR_SAVE_BEGS_BLR_C, ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C, & ZMUMPS_BLR_DEC_AND_RETRIEVE_L, ZMUMPS_BLR_RETRIEVE_PANEL_LORU, & ZMUMPS_BLR_DEC_AND_TRYFREE_L, ZMUMPS_BLR_TRY_FREE_PANEL, & ZMUMPS_BLR_FORCE_FREE_PANEL_L, & ZMUMPS_BLR_FREE_CB_LRB, ZMUMPS_BLR_FREE_ALL_PANELS, & ZMUMPS_BLR_SAVE_CB_LRB, & ZMUMPS_BLR_RETRIEVE_CB_LRB, ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA, & ZMUMPS_BLR_SAVE_BEGS_BLR_DYN, ZMUMPS_BLR_RETRIEVE_BEGSBLR_DYN, & ZMUMPS_BLR_RETRIEVE_NB_PANELS, ZMUMPS_BLR_EMPTY_PANEL_LORU, & ZMUMPS_BLR_SAVE_NFS4FATHER, ZMUMPS_BLR_RETRIEVE_NFS4FATHER, & ZMUMPS_BLR_SAVE_M_ARRAY, ZMUMPS_BLR_RETRIEVE_M_ARRAY, & ZMUMPS_BLR_FREE_M_ARRAY & , ZMUMPS_BLR_STRUC_TO_MOD, ZMUMPS_BLR_MOD_TO_STRUC, BLR_ARRAY #if defined(MUMPS_NOF2003) & , BLR_STRUC_T, blr_panel_type, diag_block_type #endif & , ZMUMPS_BLR_SAVE_DIAG_BLOCK, ZMUMPS_BLR_RETRIEVE_DIAG_BLOCK #if ! defined(NO_SAVE_RESTORE) & , ZMUMPS_SAVE_RESTORE_BLR #endif TYPE blr_panel_type integer :: NB_ACCESSES_LEFT type(LRB_TYPE), pointer :: LRB_PANEL(:) END TYPE blr_panel_type TYPE diag_block_type COMPLEX(kind=8), POINTER :: DIAG_BLOCK(:) END TYPE diag_block_type TYPE BLR_STRUC_T LOGICAL :: IsSYM, IsT2, IsSLAVE TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_L TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_U TYPE(LRB_TYPE), pointer :: CB_LRB(:,:) TYPE(diag_block_type), DIMENSION (:), POINTER :: DIAG_BLOCKS INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_STATIC INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_DYNAMIC INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: NB_ACCESSES_INIT INTEGER :: NB_PANELS INTEGER :: NFS4FATHER DOUBLE PRECISION, DIMENSION(:), POINTER :: M_ARRAY END TYPE BLR_STRUC_T type(BLR_STRUC_T), POINTER, DIMENSION(:), SAVE :: BLR_ARRAY TYPE BLR_ARRAY_T type(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY END TYPE BLR_ARRAY_T INTEGER BLR_ARRAY_FREE, PANELS_NOTUSED, PANELS_FREED, & NB_PANELS_NOTINIT, NFS4FATHER_NOTINIT PARAMETER (BLR_ARRAY_FREE=-9999, & PANELS_NOTUSED=-1111, PANELS_FREED=-2222, & NB_PANELS_NOTINIT=-3333, & NFS4FATHER_NOTINIT=-4444 ) #if ! defined(NO_SAVE_RESTORE) INCLUDE 'mumps_save_restore_modes.h' #endif CONTAINS SUBROUTINE ZMUMPS_BLR_INIT_MODULE(INITIAL_SIZE, INFO & ) INTEGER, INTENT(IN) :: INITIAL_SIZE INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR ALLOCATE(BLR_ARRAY( INITIAL_SIZE ), stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=INITIAL_SIZE RETURN ENDIF DO I=1, INITIAL_SIZE NULLIFY(BLR_ARRAY(I)%PANELS_L) NULLIFY(BLR_ARRAY(I)%PANELS_U) NULLIFY(BLR_ARRAY(I)%CB_LRB) NULLIFY(BLR_ARRAY(I)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_DYNAMIC) BLR_ARRAY(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY(I)%NB_PANELS = NB_PANELS_NOTINIT NULLIFY(BLR_ARRAY(I)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_COL) BLR_ARRAY(I)%NFS4FATHER = NFS4FATHER_NOTINIT NULLIFY(BLR_ARRAY(I)%M_ARRAY) ENDDO RETURN END SUBROUTINE ZMUMPS_BLR_INIT_MODULE SUBROUTINE ZMUMPS_BLR_END_MODULE(INFO1, KEEP8, K34 & , LRSOLVE_ACT_OPT & ) INTEGER, INTENT(IN) :: INFO1, K34 LOGICAL, OPTIONAL, INTENT(IN) :: LRSOLVE_ACT_OPT INTEGER(8) :: KEEP8(150) INTEGER :: I, ILOOP IF (.NOT. associated(BLR_ARRAY)) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_END_MODULE" CALL MUMPS_ABORT() ENDIF DO I=1, size(BLR_ARRAY) ILOOP= I IF (associated(BLR_ARRAY(I)%PANELS_L).OR. & associated(BLR_ARRAY(I)%PANELS_U).OR. & associated(BLR_ARRAY(I)%CB_LRB).OR. & associated(BLR_ARRAY(I)%DIAG_BLOCKS) & ) THEN IF (present(LRSOLVE_ACT_OPT)) THEN CALL ZMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8, K34 & , LRSOLVE_ACT_OPT & ) ELSE CALL ZMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8, K34 ) ENDIF ENDIF ENDDO DEALLOCATE(BLR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE ZMUMPS_BLR_END_MODULE SUBROUTINE ZMUMPS_BLR_MOD_TO_STRUC(id_BLRARRAY_ENCODING) # if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING # else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING # endif CHARACTER :: CHAR_ARRAY(1) INTEGER :: CHAR_LENGTH, IERR TYPE(BLR_ARRAY_T) :: BLR_ARRAY_VAR IF (associated(id_BLRARRAY_ENCODING)) THEN WRITE(*,*) "Internal error 1 in MUMPS_BLR_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF BLR_ARRAY_VAR%BLR_ARRAY => BLR_ARRAY CHAR_LENGTH=size(transfer(BLR_ARRAY_VAR,CHAR_ARRAY)) ALLOCATE(id_BLRARRAY_ENCODING(CHAR_LENGTH), stat=IERR) IF (IERR > 0 ) THEN WRITE(*,*) "Allocation error in MUMPS_BLR_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF id_BLRARRAY_ENCODING=transfer(BLR_ARRAY_VAR,CHAR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE ZMUMPS_BLR_MOD_TO_STRUC SUBROUTINE ZMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) # if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING # else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING # endif TYPE (BLR_ARRAY_T) :: BLR_ARRAY_VAR IF (.NOT.associated(id_BLRARRAY_ENCODING)) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_STRUC_TO_MOD" ENDIF BLR_ARRAY_VAR = transfer(id_BLRARRAY_ENCODING,BLR_ARRAY_VAR) BLR_ARRAY => BLR_ARRAY_VAR%BLR_ARRAY DEALLOCATE(id_BLRARRAY_ENCODING) NULLIFY(id_BLRARRAY_ENCODING) RETURN END SUBROUTINE ZMUMPS_BLR_STRUC_TO_MOD SUBROUTINE ZMUMPS_BLR_INIT_FRONT(IWHANDLER, & INFO, MTK405) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX !$ USE OMP_LIB INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) INTEGER, INTENT(IN), OPTIONAL :: MTK405 TYPE(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY_TMP INTEGER :: OLD_SIZE, NEW_SIZE INTEGER :: I INTEGER :: IERR LOGICAL :: NEEDS_THREAD_SAFETY NEEDS_THREAD_SAFETY = .FALSE. IF (present(MTK405)) THEN IF (MTK405 .EQ. 1 ) THEN NEEDS_THREAD_SAFETY = .TRUE. ENDIF ENDIF IF ( NEEDS_THREAD_SAFETY ) THEN !$OMP CRITICAL(critical_blr_idx) CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) !$OMP END CRITICAL(critical_blr_idx) ELSE CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) ENDIF IF (IWHANDLER > size(BLR_ARRAY)) THEN OLD_SIZE = size(BLR_ARRAY) NEW_SIZE = max( (OLD_SIZE * 3) / 2 + 1, IWHANDLER) ALLOCATE(BLR_ARRAY_TMP(NEW_SIZE),stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=NEW_SIZE GOTO 500 ENDIF DO I=1, OLD_SIZE BLR_ARRAY_TMP(I)=BLR_ARRAY(I) ENDDO DO I=OLD_SIZE+1, NEW_SIZE NULLIFY(BLR_ARRAY_TMP(I)%PANELS_L) NULLIFY(BLR_ARRAY_TMP(I)%PANELS_U) NULLIFY(BLR_ARRAY_TMP(I)%CB_LRB) NULLIFY(BLR_ARRAY_TMP(I)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_DYNAMIC) BLR_ARRAY_TMP(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY_TMP(I)%NB_PANELS = NB_PANELS_NOTINIT NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_L) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_COL) BLR_ARRAY_TMP(I)%NFS4FATHER = NFS4FATHER_NOTINIT NULLIFY(BLR_ARRAY_TMP(I)%M_ARRAY) ENDDO DEALLOCATE(BLR_ARRAY) BLR_ARRAY => BLR_ARRAY_TMP NULLIFY(BLR_ARRAY_TMP) 500 CONTINUE ENDIF RETURN END SUBROUTINE ZMUMPS_BLR_INIT_FRONT SUBROUTINE ZMUMPS_BLR_SAVE_INIT(IWHANDLER, & IsSYM, IsT2, IsSLAVE, & NB_PANELS, & BEGS_BLR_L, BEGS_BLR_COL, & NB_ACCESSES_INIT, INFO) LOGICAL, INTENT(IN) :: IsSYM, IsT2, IsSLAVE INTEGER, INTENT(IN) :: NB_PANELS, IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: NB_ACCESSES_INIT INTEGER, INTENT(IN), DIMENSION(:) :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: I INTEGER :: IERR IF (NB_PANELS.EQ.0) THEN WRITE(6,*) " Internal error 1 in ZMUMPS_BLR_SAVE_INIT ", & NB_PANELS ENDIF IF (IWHANDLER .LE.0 ) THEN WRITE(6,*) " Internal error 2 in ZMUMPS_BLR_SAVE_INIT ", & IWHANDLER ENDIF IF (associated(BEGS_BLR_COL)) THEN ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=size(BEGS_BLR_COL) RETURN ENDIF ENDIF IF (NB_ACCESSES_INIT.EQ.0) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=3*size(BEGS_BLR_L) RETURN ENDIF ELSE IF (IsSYM) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & stat=IERR) ELSE ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%PANELS_U(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & stat=IERR) ENDIF IF (IERR .GT. 0) THEN INFO(1)=-13 IF (IsSYM) THEN INFO(2)=NB_PANELS+3*size(BEGS_BLR_L) ELSE INFO(2)=NB_PANELS+NB_PANELS+3*size(BEGS_BLR_L) ENDIF RETURN ENDIF IF (.NOT.IsSLAVE) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(NB_PANELS), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=NB_PANELS RETURN ENDIF ENDIF DO I=1,NB_PANELS NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L(I)%LRB_PANEL) IF (.NOT.IsSYM) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U(I)%LRB_PANEL) ENDIF IF (.NOT.IsSLAVE) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(I)%DIAG_BLOCK) ENDIF ENDDO ENDIF BLR_ARRAY(IWHANDLER)%IsSYM = IsSYM BLR_ARRAY(IWHANDLER)%IsT2 = IsT2 BLR_ARRAY(IWHANDLER)%IsSLAVE = IsSLAVE BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS BLR_ARRAY(IWHANDLER)%BEGS_BLR_L = BEGS_BLR_L BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC = BEGS_BLR_L BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC = -999991 IF (NB_ACCESSES_INIT.EQ.0) THEN BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = PANELS_NOTUSED ELSE BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = NB_ACCESSES_INIT ENDIF IF (associated(BEGS_BLR_COL)) THEN DO I=1,size(BEGS_BLR_COL) BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) ENDDO ELSE NULLIFY( BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL ) ENDIF RETURN END SUBROUTINE ZMUMPS_BLR_SAVE_INIT SUBROUTINE ZMUMPS_BLR_END_FRONT(IWHANDLER, INFO1, KEEP8, K34 & , LRSOLVE_ACT_OPT, MTK405 ) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX INTEGER, INTENT(INOUT) :: IWHANDLER INTEGER, INTENT(IN) :: INFO1 INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: K34 LOGICAL, OPTIONAL, INTENT(IN) :: LRSOLVE_ACT_OPT INTEGER, OPTIONAL, INTENT(IN) :: MTK405 INTEGER :: IPANEL, JPANEL INTEGER(8) :: MEM_FREED INTEGER :: IDUMMY, JDUMMY TYPE(blr_panel_type), POINTER :: THEPANEL LOGICAL :: LRSOLVE_ACT, NEEDS_THREAD_SAFETY TYPE(diag_block_type), POINTER :: THEBLOCK LRSOLVE_ACT = .FALSE. IF (present(LRSOLVE_ACT_OPT)) LRSOLVE_ACT = LRSOLVE_ACT_OPT IF (IWHANDLER.LE.0) THEN RETURN ENDIF NEEDS_THREAD_SAFETY = .FALSE. IF (present(MTK405)) THEN IF (MTK405 .EQ. 1 ) THEN NEEDS_THREAD_SAFETY = .TRUE. ENDIF ENDIF IF (IWHANDLER .GT. size(BLR_ARRAY)) THEN RETURN END IF IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ.BLR_ARRAY_FREE) & RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.NE. & PANELS_NOTUSED) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 2a in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated", & " NB_ACCESSES_LEFT= ",THEPANEL%NB_ACCESSES_LEFT CALL MUMPS_ABORT() ELSE CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDDO IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 2b in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated" CALL MUMPS_ABORT() ELSE CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDDO IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN MEM_FREED = 0_8 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) THEBLOCK => BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL) IF (associated(THEBLOCK%DIAG_BLOCK)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 3 in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated" CALL MUMPS_ABORT() ENDIF MEM_FREED = MEM_FREED + int(size(THEBLOCK%DIAG_BLOCK),8) DEALLOCATE (THEBLOCK%DIAG_BLOCK) NULLIFY (THEBLOCK%DIAG_BLOCK) ENDIF ENDDO IF ( MEM_FREED .GT. 0_8 ) THEN CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-MEM_FREED, & NEEDS_THREAD_SAFETY, KEEP8, & IDUMMY, JDUMMY, & .TRUE., .TRUE.) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsT2.OR. & BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN IF (associated(BLR_ARRAY(IWHANDLER)%CB_LRB)) THEN IF (INFO1 .GE. 0) THEN WRITE(*,*) & " Internal Error 4 in MUMPS_BLR_END_FRONT ", & IWHANDLER, "CB block still associated", & BLR_ARRAY(IWHANDLER)%IsT2, & BLR_ARRAY(IWHANDLER)%IsSLAVE CALL MUMPS_ABORT() ELSE DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%CB_LRB,1) DO JPANEL = 1, size(BLR_ARRAY(IWHANDLER)%CB_LRB,2) CALL DEALLOC_LRB( & BLR_ARRAY(IWHANDLER)%CB_LRB(IPANEL,JPANEL), & KEEP8, K34) ENDDO ENDDO DEALLOCATE(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) ENDIF ENDIF ENDIF ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) ENDIF BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS_NOTINIT BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER_NOTINIT IF (associated(BLR_ARRAY(IWHANDLER)%M_ARRAY)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY) NULLIFY(BLR_ARRAY(IWHANDLER)%M_ARRAY) ENDIF IF (NEEDS_THREAD_SAFETY) THEN !$OMP CRITICAL(critical_blr_idx) CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) !$OMP END CRITICAL(critical_blr_idx) ELSE CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) ENDIF RETURN END SUBROUTINE ZMUMPS_BLR_END_FRONT SUBROUTINE ZMUMPS_BLR_SAVE_PANEL_LORU ( & IWHANDLER, LORU, IPANEL, LRB_PANEL, NB_ACCESSES_INIT_IN ) type(LRB_TYPE), DIMENSION(:), pointer :: LRB_PANEL INTEGER, INTENT(IN) :: IWHANDLER, IPANEL, NB_ACCESSES_INIT_IN INTEGER, INTENT(IN) :: LORU TYPE(blr_panel_type), POINTER :: THEPANEL IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_SAVE_PANEL_LORU" CALL MUMPS_ABORT() ENDIF IF (LORU.EQ.0) THEN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) ELSE THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) ENDIF IF (NB_ACCESSES_INIT_IN.GT.0) THEN THEPANEL%NB_ACCESSES_LEFT = NB_ACCESSES_INIT_IN ELSE THEPANEL%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT ENDIF THEPANEL%LRB_PANEL => LRB_PANEL RETURN END SUBROUTINE ZMUMPS_BLR_SAVE_PANEL_LORU SUBROUTINE ZMUMPS_BLR_SAVE_CB_LRB ( & IWHANDLER, CB_LRB ) #if defined(MUMPS_NOF2003) TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) #else TYPE(LRB_TYPE), POINTER, INTENT(IN) :: CB_LRB(:,:) #endif INTEGER, INTENT(IN) :: IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_SAVE_CB_LRB" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%CB_LRB => CB_LRB RETURN END SUBROUTINE ZMUMPS_BLR_SAVE_CB_LRB SUBROUTINE ZMUMPS_BLR_SAVE_DIAG_BLOCK ( & IWHANDLER, IPANEL, D, KEEP34 ) use iso_c_binding COMPLEX(kind=8),POINTER :: D(:) INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER, INTENT(IN) :: KEEP34 IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_SAVE_DIAG_BLOCK" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_BLR_SAVE_DIAG_BLOCK" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK => D RETURN END SUBROUTINE ZMUMPS_BLR_SAVE_DIAG_BLOCK SUBROUTINE ZMUMPS_BLR_SAVE_BEGS_BLR_C ( & IWHANDLER, BEGS_BLR_COL, INFO) INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_SAVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_BLR_SAVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF ALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=size(BEGS_BLR_COL) RETURN ENDIF DO I=1,size(BEGS_BLR_COL) BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) ENDDO RETURN END SUBROUTINE ZMUMPS_BLR_SAVE_BEGS_BLR_C SUBROUTINE ZMUMPS_BLR_SAVE_BEGS_BLR_DYN ( & IWHANDLER, BEGS_BLR_DYNAMIC ) INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_DYNAMIC INTEGER, INTENT(IN) :: IWHANDLER INTEGER :: I IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_SAVE_BEGS_BLR_DYN" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_BLR_SAVE_BEGS_BLR_DYN" CALL MUMPS_ABORT() ENDIF DO I=1,size(BEGS_BLR_DYNAMIC) BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(I) = BEGS_BLR_DYNAMIC(I) ENDDO RETURN END SUBROUTINE ZMUMPS_BLR_SAVE_BEGS_BLR_DYN SUBROUTINE ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L & ( IWHANDLER, BEGS_BLR_L ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L" CALL MUMPS_ABORT() ENDIF BEGS_BLR_L => BLR_ARRAY(IWHANDLER)%BEGS_BLR_L RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L SUBROUTINE ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA & ( IWHANDLER, BEGS_BLR_STATIC ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_STATIC #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA" CALL MUMPS_ABORT() ENDIF BEGS_BLR_STATIC => BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA SUBROUTINE ZMUMPS_BLR_RETRIEVE_BEGSBLR_DYN & ( IWHANDLER, BEGS_BLR_DYNAMIC ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_DYNAMIC #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_DYNAMIC #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_BEGSBLR_DYN" CALL MUMPS_ABORT() ENDIF BEGS_BLR_DYNAMIC => BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_BEGSBLR_DYN SUBROUTINE ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C & ( IWHANDLER, BEGS_BLR_COL, NB_PANELS ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NB_PANELS #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_COL #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_COL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF BEGS_BLR_COL => BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C SUBROUTINE ZMUMPS_BLR_RETRIEVE_NB_PANELS & ( IWHANDLER, NB_PANELS ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NB_PANELS IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_NB_PANELS" CALL MUMPS_ABORT() ENDIF NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_NB_PANELS SUBROUTINE ZMUMPS_BLR_DEC_AND_RETRIEVE_L(IWHANDLER, IPANEL, & BEGS_BLR_L, THELRBPANEL, & NBDEC ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: IPANEL, NBDEC #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) "Internal error 3 in ZMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L( IWHANDLER, BEGS_BLR_L ) THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - NBDEC RETURN END SUBROUTINE ZMUMPS_BLR_DEC_AND_RETRIEVE_L LOGICAL FUNCTION ZMUMPS_BLR_EMPTY_PANEL_LORU & (IWHANDLER, LorU, IPANEL) INTEGER, INTENT(IN) :: LorU, IPANEL, IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF (LorU.EQ.0) THEN IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) & "Internal error 2 in ZMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF ZMUMPS_BLR_EMPTY_PANEL_LORU = .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 3 in ZMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF ZMUMPS_BLR_EMPTY_PANEL_LORU = .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ENDIF RETURN END FUNCTION ZMUMPS_BLR_EMPTY_PANEL_LORU SUBROUTINE ZMUMPS_BLR_RETRIEVE_PANEL_LORU & (IWHANDLER, LORU, IPANEL, & THELRBPANEL) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: LORU INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_NOF2003) TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL #else TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF (LORU.EQ.0) THEN IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) & "Internal error 2 in ZMUMPS_BLR_RETRIEVE_PANEL_LORU", & " IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) & "Internal error 3 in ZMUMPS_BLR_RETRIEVE_PANEL_LORU", & " IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 4 in ZMUMPS_BLR_RETRIEVE_PANEL_LORU", & " IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) & "Internal error 5 in ZMUMPS_BLR_RETRIEVE_PANEL_LORU", & " IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL ENDIF RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_PANEL_LORU SUBROUTINE ZMUMPS_BLR_RETRIEVE_DIAG_BLOCK & (IWHANDLER, IPANEL, & THEBLOCK) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_NOF2003) COMPLEX(kind=8), POINTER :: THEBLOCK(:) #else COMPLEX(kind=8), POINTER, INTENT(OUT) :: THEBLOCK(:) #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN WRITE(*,*) & "Internal error 2 in ZMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK)) & THEN WRITE(*,*) & "Internal error 3 in ZMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THEBLOCK => & BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_DIAG_BLOCK SUBROUTINE ZMUMPS_BLR_RETRIEVE_CB_LRB & (IWHANDLER, THECB) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) TYPE(LRB_TYPE), POINTER :: THECB(:,:) #else TYPE(LRB_TYPE), POINTER, INTENT(OUT) :: THECB(:,:) #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_RETRIEVE_CB_LRB" CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%CB_LRB)) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_BLR_RETRIEVE_CB_LRB" CALL MUMPS_ABORT() ENDIF THECB => BLR_ARRAY(IWHANDLER)%CB_LRB RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_CB_LRB SUBROUTINE ZMUMPS_BLR_SAVE_NFS4FATHER & ( IWHANDLER, NFS4FATHER ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: NFS4FATHER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_NFS4FATHER" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER RETURN END SUBROUTINE ZMUMPS_BLR_SAVE_NFS4FATHER SUBROUTINE ZMUMPS_BLR_RETRIEVE_NFS4FATHER & ( IWHANDLER, NFS4FATHER ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NFS4FATHER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_NFS4FATHER" CALL MUMPS_ABORT() ENDIF NFS4FATHER = BLR_ARRAY(IWHANDLER)%NFS4FATHER RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_NFS4FATHER SUBROUTINE ZMUMPS_BLR_SAVE_M_ARRAY ( & IWHANDLER, M_ARRAY, INFO) DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: M_ARRAY INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_SAVE_M_ARRAY" CALL MUMPS_ABORT() ENDIF ALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY(size(M_ARRAY)), & stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=size(M_ARRAY) RETURN ENDIF DO I=1,size(M_ARRAY) BLR_ARRAY(IWHANDLER)%M_ARRAY(I) = M_ARRAY(I) ENDDO BLR_ARRAY(IWHANDLER)%NFS4FATHER = size(M_ARRAY) RETURN END SUBROUTINE ZMUMPS_BLR_SAVE_M_ARRAY SUBROUTINE ZMUMPS_BLR_RETRIEVE_M_ARRAY ( IWHANDLER, M_ARRAY) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) DOUBLE PRECISION, DIMENSION(:), POINTER :: M_ARRAY #else DOUBLE PRECISION, DIMENSION(:), POINTER, INTENT(OUT) :: M_ARRAY #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_RETRIEVE_M_ARRAY" CALL MUMPS_ABORT() ENDIF M_ARRAY => BLR_ARRAY(IWHANDLER)%M_ARRAY RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_M_ARRAY SUBROUTINE ZMUMPS_BLR_FREE_M_ARRAY ( IWHANDLER ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_FREE_M_ARRAY" CALL MUMPS_ABORT() ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%M_ARRAY)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY) NULLIFY(BLR_ARRAY(IWHANDLER)%M_ARRAY) ENDIF BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER_NOTINIT RETURN END SUBROUTINE ZMUMPS_BLR_FREE_M_ARRAY SUBROUTINE ZMUMPS_BLR_DEC_AND_TRYFREE_L( IWHANDLER, IPANEL, & KEEP8, K34, NBDEC) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL, K34, NBDEC INTEGER(8) :: KEEP8(150) IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) & RETURN BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - NBDEC CALL ZMUMPS_BLR_TRY_FREE_PANEL (IWHANDLER, IPANEL, & KEEP8, K34) RETURN END SUBROUTINE ZMUMPS_BLR_DEC_AND_TRYFREE_L SUBROUTINE ZMUMPS_BLR_FORCE_FREE_PANEL_L( IWHANDLER, IPANEL, & KEEP8, K34 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: K34 TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) & RETURN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED RETURN END SUBROUTINE ZMUMPS_BLR_FORCE_FREE_PANEL_L SUBROUTINE ZMUMPS_BLR_TRY_FREE_PANEL( IWHANDLER, IPANEL, & KEEP8, K34 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: K34 TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0.OR. & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.eq.huge(IPANEL) ) & RETURN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF ( THEPANEL%NB_ACCESSES_LEFT .EQ. 0 ) THEN IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF RETURN END SUBROUTINE ZMUMPS_BLR_TRY_FREE_PANEL SUBROUTINE ZMUMPS_BLR_FREE_CB_LRB ( IWHANDLER, FREE_ONLY_STRUCT, & KEEP8, K34 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, K34 LOGICAL, INTENT(IN) :: FREE_ONLY_STRUCT INTEGER(8) :: KEEP8(150) TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER :: IPANEL, JPANEL TYPE(LRB_TYPE), POINTER :: THELRB IF (BLR_ARRAY(IWHANDLER)%IsT2.AND. & .NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN write(*,*) 'Internal error 1 in ZMUMPS_BLR_FREE_CB_LRB' CALL MUMPS_ABORT() ENDIF CB_LRB => BLR_ARRAY(IWHANDLER)%CB_LRB IF (.NOT.associated(CB_LRB)) THEN write(*,*) 'Internal error 2 in ZMUMPS_BLR_FREE_CB_LRB' CALL MUMPS_ABORT() ENDIF IF (.NOT.FREE_ONLY_STRUCT) THEN DO IPANEL = 1,size(CB_LRB,1) DO JPANEL = 1,size(CB_LRB,2) THELRB => CB_LRB(IPANEL,JPANEL) IF (associated(THELRB)) THEN CALL DEALLOC_LRB(THELRB, KEEP8, K34) ENDIF ENDDO ENDDO ENDIF DEALLOCATE(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) RETURN END SUBROUTINE ZMUMPS_BLR_FREE_CB_LRB SUBROUTINE ZMUMPS_BLR_FREE_ALL_PANELS ( IWHANDLER, & LorU, KEEP8, K34) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, LorU, K34 INTEGER(8) :: KEEP8(150) INTEGER :: IPANEL INTEGER :: IDUMMY, JDUMMY TYPE(blr_panel_type), POINTER :: THEPANEL TYPE(diag_block_type), POINTER :: THEBLOCK INTEGER(8) :: MEM_FREED IF (IWHANDLER.LE.0) RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ. & PANELS_NOTUSED) RETURN IF (LorU.EQ.0.OR.LorU.EQ.2) THEN IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF ENDIF IF (LorU.GE.1.AND..NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF ENDIF IF (LorU.GE.1.AND..NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN IF (associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN MEM_FREED = 0_8 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) THEBLOCK => BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL) IF (associated(THEBLOCK%DIAG_BLOCK)) THEN MEM_FREED = MEM_FREED + int(size(THEBLOCK%DIAG_BLOCK),8) DEALLOCATE(THEBLOCK%DIAG_BLOCK) NULLIFY (THEBLOCK%DIAG_BLOCK) ENDIF ENDDO IF (MEM_FREED .GT. 0 ) THEN CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-MEM_FREED, & .TRUE., KEEP8, & IDUMMY, JDUMMY, & .TRUE., .TRUE.) ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_BLR_FREE_ALL_PANELS #if ! defined(NO_SAVE_RESTORE) SUBROUTINE ZMUMPS_SAVE_RESTORE_BLR(id_BLRARRAY_ENCODING & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: j1,NbRecords,NbSubRecords,size_array1,dummy,allocok,err INTEGER:: SIZE_GEST_BLR_ARRAY,SIZE_GEST_BLR_ARRAY_j1 INTEGER(8):: SIZE_VARIABLES_BLR_ARRAY,SIZE_VARIABLES_BLR_ARRAY_j1 INTEGER(4) :: I4 NbRecords=0 SIZE_GEST_BLR_ARRAY=0 SIZE_GEST_BLR_ARRAY_j1=0 SIZE_VARIABLES_BLR_ARRAY=0_8 SIZE_VARIABLES_BLR_ARRAY_j1=0_8 SIZE_GEST=0 SIZE_VARIABLES=0_8 if(mode.EQ.memory_save_mode.OR.mode.EQ.save_mode) then call ZMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) endif if(mode.EQ.memory_save_mode) then IF(associated(BLR_ARRAY)) THEN NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 DO j1=1,size(BLR_ARRAY,1) CALL ZMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_BLR_ARRAY=SIZE_GEST_BLR_ARRAY+ & SIZE_GEST_BLR_ARRAY_j1 SIZE_VARIABLES_BLR_ARRAY=SIZE_VARIABLES_BLR_ARRAY+ & SIZE_VARIABLES_BLR_ARRAY_j1 ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_ARRAY)) THEN NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 write(unit,iostat=err) size(BLR_ARRAY,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 DO j1=1,size(BLR_ARRAY,1) CALL ZMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_ARRAY) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 allocate(BLR_ARRAY(size_array1), stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL ZMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_BLR_ARRAY=SIZE_GEST_BLR_ARRAY+ & SIZE_GEST_BLR_ARRAY_j1 SIZE_VARIABLES_BLR_ARRAY=SIZE_VARIABLES_BLR_ARRAY+ & SIZE_VARIABLES_BLR_ARRAY_j1 ENDDO endif endif if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(mode.EQ.memory_save_mode) then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_BLR_ARRAY SIZE_GEST=SIZE_GEST+SIZE_GEST_BLR_ARRAY #if defined(MUMPS_NOF2003) SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif call ZMUMPS_BLR_MOD_TO_STRUC(id_BLRARRAY_ENCODING) 100 continue RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_BLR SUBROUTINE ZMUMPS_SAVE_RESTORE_BLR_STRUC(BLR_STRUC & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(BLR_STRUC_T) :: BLR_STRUC INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER, PARAMETER :: NBVARIABLES_BLR_STRUC_T = 15 INTEGER, PARAMETER :: B_IsSYM=1 INTEGER, PARAMETER :: B_IsT2=2 INTEGER, PARAMETER :: B_IsSLAVE=3 INTEGER, PARAMETER :: B_PANELS_L=4 INTEGER, PARAMETER :: B_PANELS_U=5 INTEGER, PARAMETER :: B_CB_LRB=6 INTEGER, PARAMETER :: B_DIAG_BLOCKS=7 INTEGER, PARAMETER :: B_BEGS_BLR_STATIC=8 INTEGER, PARAMETER :: B_BEGS_BLR_DYNAMIC=9 INTEGER, PARAMETER :: B_BEGS_BLR_L=10 INTEGER, PARAMETER :: B_BEGS_BLR_COL=11 INTEGER, PARAMETER :: B_NB_ACCESSES_INIT=12 INTEGER, PARAMETER :: B_NB_PANELS=13 INTEGER, PARAMETER :: B_NFS4FATHER=14 INTEGER, PARAMETER :: B_M_ARRAY=15 INTEGER(8),dimension(NBVARIABLES_BLR_STRUC_T):: & SIZE_VARIABLES_BLR_STRUC_T INTEGER,dimension(NBVARIABLES_BLR_STRUC_T)::SIZE_GEST_BLR_STRUC_T INTEGER,dimension(NBVARIABLES_BLR_STRUC_T)::NbRecords_BLR_STRUC_T INTEGER:: size_array1,size_array2,dummy,allocok INTEGER:: err,i1,j1,j2,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER::SIZE_GEST_PANELS_L,SIZE_GEST_PANELS_L_j1 INTEGER(8)::SIZE_VARIABLES_PANELS_L,SIZE_VARIABLES_PANELS_L_j1 INTEGER::SIZE_GEST_PANELS_U,SIZE_GEST_PANELS_U_j1 INTEGER(8)::SIZE_VARIABLES_PANELS_U,SIZE_VARIABLES_PANELS_U_j1 INTEGER::SIZE_GEST_CB_LRB,SIZE_GEST_CB_LRB_j1j2 INTEGER(8)::SIZE_VARIABLES_CB_LRB,SIZE_VARIABLES_CB_LRB_j1j2 INTEGER::SIZE_GEST_DIAG_BLOCKS,SIZE_GEST_DIAG_BLOCKS_j1 INTEGER(8)::SIZE_VARIABLES_DIAG_BLOCKS INTEGER(8)::SIZE_VARIABLES_DIAG_BLOCKS_j1 INTEGER(4)::I4 SIZE_VARIABLES_BLR_STRUC_T(:)=0_8 SIZE_GEST_BLR_STRUC_T(:)=0 NbRecords_BLR_STRUC_T(:)=0 SIZE_GEST_PANELS_L=0 SIZE_GEST_PANELS_L_j1=0 SIZE_VARIABLES_PANELS_L=0_8 SIZE_VARIABLES_PANELS_L_j1=0_8 SIZE_GEST_PANELS_U=0 SIZE_GEST_PANELS_U_j1=0 SIZE_VARIABLES_PANELS_U=0_8 SIZE_VARIABLES_PANELS_U_j1=0_8 SIZE_GEST_CB_LRB=0 SIZE_GEST_CB_LRB_j1j2=0 SIZE_VARIABLES_CB_LRB=0_8 SIZE_VARIABLES_CB_LRB_j1j2=0_8 SIZE_GEST_DIAG_BLOCKS=0 SIZE_GEST_DIAG_BLOCKS_j1=0 SIZE_VARIABLES_DIAG_BLOCKS=0_8 SIZE_VARIABLES_DIAG_BLOCKS_j1=0_8 DO i1=1,NBVARIABLES_BLR_STRUC_T SELECT CASE(i1) CASE(B_IsSYM) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsSYM if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsSYM if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_IsT2) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsT2 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsT2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_IsSLAVE) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsSLAVE if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsSLAVE if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_BEGS_BLR_STATIC) NbRecords_BLR_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_STATIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_STATIC,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_STATIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_STATIC,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_STATIC,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_STATIC ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%BEGS_BLR_STATIC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_STATIC(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_STATIC endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_BEGS_BLR_DYNAMIC) NbRecords_BLR_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_DYNAMIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_DYNAMIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_DYNAMIC ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%BEGS_BLR_DYNAMIC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_DYNAMIC(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_DYNAMIC endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_BEGS_BLR_L) NbRecords_BLR_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_L)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_L,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_L)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_L,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_L,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_L ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%BEGS_BLR_L) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_L(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_L endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_BEGS_BLR_COL) NbRecords_BLR_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_COL)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_COL,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_COL)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_COL,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_COL,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_COL ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%BEGS_BLR_COL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_COL(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_COL endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_NB_ACCESSES_INIT) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NB_ACCESSES_INIT if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NB_ACCESSES_INIT if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_NB_PANELS) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NB_PANELS if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NB_PANELS if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_PANELS_L) if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%PANELS_L)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%PANELS_L,1) CALL ZMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_L=SIZE_GEST_PANELS_L+ & SIZE_GEST_PANELS_L_j1 SIZE_VARIABLES_PANELS_L=SIZE_VARIABLES_PANELS_L+ & SIZE_VARIABLES_PANELS_L_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%PANELS_L)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%PANELS_L,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%PANELS_L,1) CALL ZMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%PANELS_L) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%PANELS_L(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL ZMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_L=SIZE_GEST_PANELS_L+ & SIZE_GEST_PANELS_L_j1 SIZE_VARIABLES_PANELS_L=SIZE_VARIABLES_PANELS_L+ & SIZE_VARIABLES_PANELS_L_j1 ENDDO endif endif CASE(B_PANELS_U) if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%PANELS_U)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%PANELS_U,1) CALL ZMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_U=SIZE_GEST_PANELS_U+ & SIZE_GEST_PANELS_U_j1 SIZE_VARIABLES_PANELS_U=SIZE_VARIABLES_PANELS_U+ & SIZE_VARIABLES_PANELS_U_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%PANELS_U)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%PANELS_U,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%PANELS_U,1) CALL ZMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%PANELS_U) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%PANELS_U(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL ZMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_U=SIZE_GEST_PANELS_U+ & SIZE_GEST_PANELS_U_j1 SIZE_VARIABLES_PANELS_U=SIZE_VARIABLES_PANELS_U+ & SIZE_VARIABLES_PANELS_U_j1 ENDDO endif endif CASE(B_CB_LRB) if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%CB_LRB)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%CB_LRB,1) DO j2=1,size(BLR_STRUC%CB_LRB,2) CALL ZMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_CB_LRB=SIZE_GEST_CB_LRB+ & SIZE_GEST_CB_LRB_j1j2 SIZE_VARIABLES_CB_LRB=SIZE_VARIABLES_CB_LRB+ & SIZE_VARIABLES_CB_LRB_j1j2 ENDDO ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%CB_LRB)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%CB_LRB,1),size(BLR_STRUC%CB_LRB,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%CB_LRB,1) DO j2=1,size(BLR_STRUC%CB_LRB,2) CALL ZMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,save_mode & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%CB_LRB) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%CB_LRB(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 DO j2=1,size_array2 CALL ZMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,restore_mode & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_CB_LRB=SIZE_GEST_CB_LRB+ & SIZE_GEST_CB_LRB_j1j2 SIZE_VARIABLES_CB_LRB=SIZE_VARIABLES_CB_LRB+ & SIZE_VARIABLES_CB_LRB_j1j2 ENDDO ENDDO endif endif CASE(B_DIAG_BLOCKS) if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%DIAG_BLOCKS)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%DIAG_BLOCKS,1) CALL ZMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_DIAG_BLOCKS=SIZE_GEST_DIAG_BLOCKS+ & SIZE_GEST_DIAG_BLOCKS_j1 SIZE_VARIABLES_DIAG_BLOCKS= & SIZE_VARIABLES_DIAG_BLOCKS+ & SIZE_VARIABLES_DIAG_BLOCKS_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%DIAG_BLOCKS)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%DIAG_BLOCKS,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%DIAG_BLOCKS,1) CALL ZMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%DIAG_BLOCKS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%DIAG_BLOCKS(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL ZMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_DIAG_BLOCKS=SIZE_GEST_DIAG_BLOCKS+ & SIZE_GEST_DIAG_BLOCKS_j1 SIZE_VARIABLES_DIAG_BLOCKS= & SIZE_VARIABLES_DIAG_BLOCKS+ & SIZE_VARIABLES_DIAG_BLOCKS_j1 ENDDO endif endif CASE(B_NFS4FATHER) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NFS4FATHER if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NFS4FATHER if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_M_ARRAY) if(mode.EQ.restore_mode) then nullify(BLR_STRUC%M_ARRAY) endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_BLR_STRUC_T(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_BLR_STRUC_T(i1)=NbRecords_BLR_STRUC_T(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_BLR_STRUC_T(i1) & +int(SIZE_GEST_BLR_STRUC_T(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_BLR_STRUC_T(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_BLR_STRUC_T(i1) size_read=size_read+SIZE_VARIABLES_BLR_STRUC_T(i1) & +int(SIZE_GEST_BLR_STRUC_T(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_BLR_STRUC_T(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_BLR_STRUC_T) & +SIZE_VARIABLES_PANELS_L & +SIZE_VARIABLES_PANELS_U & +SIZE_VARIABLES_CB_LRB & +SIZE_VARIABLES_DIAG_BLOCKS Local_SIZE_GEST=sum(SIZE_GEST_BLR_STRUC_T) & +SIZE_GEST_PANELS_L & +SIZE_GEST_PANELS_U & +SIZE_GEST_CB_LRB & +SIZE_GEST_DIAG_BLOCKS #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_BLR_STRUC_T) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 100 continue RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_BLR_STRUC SUBROUTINE ZMUMPS_SAVE_RESTORE_LRB(LRB_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(LRB_TYPE) :: LRB_T INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER, PARAMETER :: LRB_Q=1 INTEGER, PARAMETER :: LRB_R=2 INTEGER, PARAMETER :: LRB_K=3 INTEGER, PARAMETER :: LRB_M=4 INTEGER, PARAMETER :: LRB_N=5 INTEGER, PARAMETER :: LRB_ISLR=6 INTEGER, PARAMETER :: NBVARIABLES_LRB_TYPE=6 INTEGER(8),dimension(NBVARIABLES_LRB_TYPE):: & SIZE_VARIABLES_LRB_TYPE INTEGER,dimension(NBVARIABLES_LRB_TYPE):: & SIZE_GEST_LRB_TYPE INTEGER,dimension(NBVARIABLES_LRB_TYPE):: & NbRecords_LRB_TYPE INTEGER:: size_array1,size_array2,dummy,allocok INTEGER:: err,i1,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER(4) ::I4 SIZE_VARIABLES_LRB_TYPE(:)=0_8 SIZE_GEST_LRB_TYPE(:)=0 NbRecords_LRB_TYPE(:)=0 DO i1=1,NBVARIABLES_LRB_TYPE SELECT CASE(i1) CASE(LRB_Q) NbRecords_LRB_TYPE(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(LRB_T%Q)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%Q,1)*size(LRB_T%Q,2) & * SIZE_ARITH_DEP ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(LRB_T%Q)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%Q,1)*size(LRB_T%Q,2) & * SIZE_ARITH_DEP write(unit,iostat=err) size(LRB_T%Q,1),size(LRB_T%Q,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) LRB_T%Q ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then nullify(LRB_T%Q) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(size_array1.EQ.-999) then SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size_array1*size_array2*SIZE_ARITH_DEP allocate(LRB_T%Q(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) LRB_T%Q endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_R) NbRecords_LRB_TYPE(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(LRB_T%R)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%R,1)*size(LRB_T%R,2) & * SIZE_ARITH_DEP ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(LRB_T%R)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%R,1)*size(LRB_T%R,2) & * SIZE_ARITH_DEP write(unit,iostat=err) size(LRB_T%R,1),size(LRB_T%R,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) LRB_T%R ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then nullify(LRB_T%R) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(size_array1.EQ.-999) then SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size_array1*size_array2*SIZE_ARITH_DEP allocate(LRB_T%R(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) LRB_T%R endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_K) NbRecords_LRB_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%K if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%K if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_M) NbRecords_LRB_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%M if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%M if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_N) NbRecords_LRB_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%N if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%N if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_ISLR) NbRecords_LRB_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL write(unit,iostat=err) LRB_T%ISLR if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL read(unit,iostat=err) LRB_T%ISLR if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_LRB_TYPE(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_LRB_TYPE(i1)= & NbRecords_LRB_TYPE(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_LRB_TYPE(i1) & +int(SIZE_GEST_LRB_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_LRB_TYPE(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_LRB_TYPE(i1) size_read=size_read+SIZE_VARIABLES_LRB_TYPE(i1) & +int(SIZE_GEST_LRB_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_LRB_TYPE(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_LRB_TYPE) Local_SIZE_GEST=sum(SIZE_GEST_LRB_TYPE) #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_LRB_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 300 continue RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_LRB SUBROUTINE ZMUMPS_SAVE_RESTORE_BLR_PANEL(BLR_PANEL_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(blr_panel_type) :: BLR_PANEL_T INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER, PARAMETER :: P_NB_ACCESSES_LEFT=1 INTEGER, PARAMETER :: P_LRB_PANEL=2 INTEGER, PARAMETER :: NBVARIABLES_BLR_PANEL_TYPE = 2 INTEGER(8),dimension(NBVARIABLES_BLR_PANEL_TYPE):: & SIZE_VARIABLES_BLR_PANEL_TYPE INTEGER,dimension(NBVARIABLES_BLR_PANEL_TYPE):: & SIZE_GEST_BLR_PANEL_TYPE INTEGER,dimension(NBVARIABLES_BLR_PANEL_TYPE):: & NbRecords_BLR_PANEL_TYPE INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,j1,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER:: SIZE_GEST_LRB_PANEL_j1,SIZE_GEST_LRB_PANEL INTEGER(8)::SIZE_VARIABLES_LRB_PANEL_j1,SIZE_VARIABLES_LRB_PANEL INTEGER(4)::I4 SIZE_VARIABLES_BLR_PANEL_TYPE(:)=0_8 SIZE_GEST_BLR_PANEL_TYPE(:)=0 NbRecords_BLR_PANEL_TYPE(:)=0 SIZE_GEST_LRB_PANEL_j1=0 SIZE_GEST_LRB_PANEL=0 SIZE_VARIABLES_LRB_PANEL_j1=0_8 SIZE_VARIABLES_LRB_PANEL=0_8 DO i1=1,NBVARIABLES_BLR_PANEL_TYPE SELECT CASE(i1) CASE(P_NB_ACCESSES_LEFT) NbRecords_BLR_PANEL_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT write(unit,iostat=err) BLR_PANEL_T%NB_ACCESSES_LEFT if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT read(unit,iostat=err) BLR_PANEL_T%NB_ACCESSES_LEFT if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 endif CASE(P_LRB_PANEL) if(mode.EQ.memory_save_mode) then IF(associated(BLR_PANEL_T%LRB_PANEL)) THEN NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 DO j1=1,size(BLR_PANEL_T%LRB_PANEL,1) CALL ZMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_LRB_PANEL=SIZE_GEST_LRB_PANEL+ & SIZE_GEST_LRB_PANEL_j1 SIZE_VARIABLES_LRB_PANEL=SIZE_VARIABLES_LRB_PANEL+ & SIZE_VARIABLES_LRB_PANEL_j1 ENDDO ELSE NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_PANEL_T%LRB_PANEL)) THEN NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 write(unit,iostat=err) size(BLR_PANEL_T%LRB_PANEL,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 DO j1=1,size(BLR_PANEL_T%LRB_PANEL,1) CALL ZMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 400 ENDDO ELSE NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_PANEL_T%LRB_PANEL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 if(size_array1.EQ.-999) then NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 else NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 allocate(BLR_PANEL_T%LRB_PANEL(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL ZMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_LRB_PANEL=SIZE_GEST_LRB_PANEL+ & SIZE_GEST_LRB_PANEL_j1 SIZE_VARIABLES_LRB_PANEL=SIZE_VARIABLES_LRB_PANEL+ & SIZE_VARIABLES_LRB_PANEL_j1 ENDDO endif endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_BLR_PANEL_TYPE(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_BLR_PANEL_TYPE(i1)= & NbRecords_BLR_PANEL_TYPE(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_BLR_PANEL_TYPE(i1) & +int(SIZE_GEST_BLR_PANEL_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_BLR_PANEL_TYPE(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_BLR_PANEL_TYPE(i1) size_read=size_read+SIZE_VARIABLES_BLR_PANEL_TYPE(i1) & +int(SIZE_GEST_BLR_PANEL_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_BLR_PANEL_TYPE(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_BLR_PANEL_TYPE)+ & SIZE_VARIABLES_LRB_PANEL Local_SIZE_GEST=sum(SIZE_GEST_BLR_PANEL_TYPE)+ & SIZE_GEST_LRB_PANEL #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_BLR_PANEL_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 400 continue RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_BLR_PANEL SUBROUTINE ZMUMPS_SAVE_RESTORE_DIAG_BLOCK(DIAG_BLOCK_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(diag_block_type) :: DIAG_BLOCK_T INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER, PARAMETER :: D_DIAG_BLOCK=1 INTEGER, PARAMETER :: NBVARIABLES_DIAG_BLOCK_TYPE = 1 INTEGER(8),dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & SIZE_VARIABLES_DIAG_BLOCK_TYPE INTEGER,dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & SIZE_GEST_DIAG_BLOCK_TYPE INTEGER,dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & NbRecords_DIAG_BLOCK_TYPE INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER(4) :: I4 SIZE_VARIABLES_DIAG_BLOCK_TYPE(:)=0_8 SIZE_GEST_DIAG_BLOCK_TYPE(:)=0 NbRecords_DIAG_BLOCK_TYPE(:)=0 DO i1=1,NBVARIABLES_DIAG_BLOCK_TYPE SELECT CASE(i1) CASE(D_DIAG_BLOCK) NbRecords_DIAG_BLOCK_TYPE(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(DIAG_BLOCK_T%DIAG_BLOCK)) THEN SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size(DIAG_BLOCK_T%DIAG_BLOCK,1) & * SIZE_ARITH_DEP ELSE SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(DIAG_BLOCK_T%DIAG_BLOCK)) THEN SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size(DIAG_BLOCK_T%DIAG_BLOCK,1) & * SIZE_ARITH_DEP write(unit,iostat=err) size(DIAG_BLOCK_T%DIAG_BLOCK,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 write(unit,iostat=err) DIAG_BLOCK_T%DIAG_BLOCK ELSE SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 elseif(mode.EQ.restore_mode) then nullify(DIAG_BLOCK_T%DIAG_BLOCK) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 if(size_array1.EQ.-999) then SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size_array1*SIZE_ARITH_DEP allocate(DIAG_BLOCK_T%DIAG_BLOCK(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) GOTO 200 endif read(unit,iostat=err) DIAG_BLOCK_T%DIAG_BLOCK endif if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 200 endif endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)/ & huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_DIAG_BLOCK_TYPE(i1)= & NbRecords_DIAG_BLOCK_TYPE(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) & +int(SIZE_GEST_DIAG_BLOCK_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_DIAG_BLOCK_TYPE(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) size_read=size_read+SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) & +int(SIZE_GEST_DIAG_BLOCK_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_DIAG_BLOCK_TYPE(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_DIAG_BLOCK_TYPE) Local_SIZE_GEST=sum(SIZE_GEST_DIAG_BLOCK_TYPE) #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_DIAG_BLOCK_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 200 continue RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_DIAG_BLOCK #endif END MODULE ZMUMPS_LR_DATA_M MUMPS_5.8.1/src/dmumps_ooc_buffer.F0000664000175000017500000004333715042446437017055 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_OOC_BUFFER USE MUMPS_OOC_COMMON IMPLICIT NONE PUBLIC INTEGER FIRST_HBUF,SECOND_HBUF PARAMETER (FIRST_HBUF=0, SECOND_HBUF=1) INTEGER,SAVE :: OOC_FCT_TYPE_LOC DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE :: BUF_IO LOGICAL,SAVE :: PANEL_FLAG INTEGER,SAVE :: EARLIEST_WRITE_MIN_SIZE INTEGER(8),SAVE,DIMENSION(:), ALLOCATABLE :: & I_SHIFT_FIRST_HBUF, I_SHIFT_SECOND_HBUF, & I_SHIFT_CUR_HBUF, I_REL_POS_CUR_HBUF INTEGER, SAVE, DIMENSION(:), ALLOCATABLE :: & LAST_IOREQUEST, CUR_HBUF INTEGER, DIMENSION(:),ALLOCATABLE :: I_CUR_HBUF_NEXTPOS INTEGER,SAVE :: I_CUR_HBUF_FSTPOS, & I_SUB_HBUF_FSTPOS INTEGER(8) :: BufferEmpty PARAMETER (BufferEmpty=-1_8) INTEGER(8), DIMENSION(:),ALLOCATABLE :: NextAddVirtBuffer INTEGER(8), DIMENSION(:),ALLOCATABLE :: FIRST_VADDR_IN_BUF CONTAINS SUBROUTINE DMUMPS_OOC_NEXT_HBUF(TYPEF_ARG) IMPLICIT NONE INTEGER TYPEF_ARG SELECT CASE(CUR_HBUF(TYPEF_ARG)) CASE (FIRST_HBUF) CUR_HBUF(TYPEF_ARG) = SECOND_HBUF I_SHIFT_CUR_HBUF(TYPEF_ARG) = & I_SHIFT_SECOND_HBUF(TYPEF_ARG) CASE (SECOND_HBUF) CUR_HBUF(TYPEF_ARG) = FIRST_HBUF I_SHIFT_CUR_HBUF(TYPEF_ARG) = & I_SHIFT_FIRST_HBUF(TYPEF_ARG) END SELECT IF(.NOT.PANEL_FLAG)THEN I_SUB_HBUF_FSTPOS =I_CUR_HBUF_FSTPOS I_CUR_HBUF_FSTPOS =I_CUR_HBUF_NEXTPOS(TYPEF_ARG) ENDIF I_REL_POS_CUR_HBUF(TYPEF_ARG) = 1_8 RETURN END SUBROUTINE DMUMPS_OOC_NEXT_HBUF SUBROUTINE DMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_ARG,IERR) IMPLICIT NONE INTEGER TYPEF_ARG INTEGER NEW_IOREQUEST INTEGER IERR IERR=0 CALL DMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF_ARG,NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL MUMPS_WAIT_REQUEST(LAST_IOREQUEST(TYPEF_ARG),IERR) IF(IERR.LT.0)THEN IF (ICNTL1>0) & WRITE(ICNTL1,*) MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF LAST_IOREQUEST(TYPEF_ARG) = NEW_IOREQUEST CALL DMUMPS_OOC_NEXT_HBUF(TYPEF_ARG) IF(PANEL_FLAG)THEN NextAddVirtBuffer(TYPEF_ARG)=BufferEmpty ENDIF RETURN END SUBROUTINE DMUMPS_OOC_DO_IO_AND_CHBUF SUBROUTINE DMUMPS_OOC_BUF_CLEAN_PENDING(IERR) IMPLICIT NONE INTEGER, intent(out) :: IERR INTEGER TYPEF_LAST INTEGER TYPEF_LOC IERR = 0 TYPEF_LAST = OOC_NB_FILE_TYPE DO TYPEF_LOC = 1, TYPEF_LAST IERR=0 CALL DMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL DMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_OOC_BUF_CLEAN_PENDING SUBROUTINE DMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF_ARG,IOREQUEST, & IERR) IMPLICIT NONE INTEGER IOREQUEST,IERR INTEGER TYPEF_ARG INTEGER FIRST_INODE INTEGER(8) :: FROM_BUFIO_POS, SIZE INTEGER TYPE INTEGER ADDR_INT1,ADDR_INT2 INTEGER(8) TMP_VADDR INTEGER SIZE_INT1,SIZE_INT2 IERR=0 IF (I_REL_POS_CUR_HBUF(TYPEF_ARG) == 1_8) THEN IOREQUEST=-1 RETURN END IF IF(PANEL_FLAG)THEN TYPE=TYPEF_ARG-1 FIRST_INODE=-9999 TMP_VADDR=FIRST_VADDR_IN_BUF(TYPEF_ARG) ELSE TYPE=FCT FIRST_INODE = & OOC_INODE_SEQUENCE(I_CUR_HBUF_FSTPOS,TYPEF_ARG) TMP_VADDR=OOC_VADDR(STEP_OOC(FIRST_INODE),TYPEF_ARG) ENDIF FROM_BUFIO_POS=I_SHIFT_CUR_HBUF(TYPEF_ARG)+1_8 SIZE = I_REL_POS_CUR_HBUF(TYPEF_ARG)-1_8 CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & TMP_VADDR) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & BUF_IO(FROM_BUFIO_POS),SIZE_INT1,SIZE_INT2, & FIRST_INODE,IOREQUEST, & TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1>0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF RETURN END SUBROUTINE DMUMPS_OOC_WRT_CUR_BUF2DISK SUBROUTINE DMUMPS_INIT_OOC_BUF(I1,I2,IERR) IMPLICIT NONE INTEGER I1,I2,IERR INTEGER allocok IERR=0 PANEL_FLAG=.FALSE. IF(allocated(I_SHIFT_FIRST_HBUF))THEN DEALLOCATE(I_SHIFT_FIRST_HBUF) ENDIF IF(allocated(I_SHIFT_SECOND_HBUF))THEN DEALLOCATE(I_SHIFT_SECOND_HBUF) ENDIF IF(allocated(I_SHIFT_CUR_HBUF))THEN DEALLOCATE(I_SHIFT_CUR_HBUF) ENDIF IF(allocated(I_REL_POS_CUR_HBUF))THEN DEALLOCATE(I_REL_POS_CUR_HBUF) ENDIF IF(allocated(LAST_IOREQUEST))THEN DEALLOCATE(LAST_IOREQUEST) ENDIF IF(allocated(CUR_HBUF))THEN DEALLOCATE(CUR_HBUF) ENDIF DIM_BUF_IO = int(KEEP_OOC(100),8) ALLOCATE(I_SHIFT_FIRST_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_SHIFT_SECOND_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_SHIFT_CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_REL_POS_CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(LAST_IOREQUEST(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF OOC_FCT_TYPE_LOC=OOC_NB_FILE_TYPE ALLOCATE(BUF_IO(DIM_BUF_IO), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF I1 = -13 CALL MUMPS_SET_IERROR(DIM_BUF_IO, I2) RETURN ENDIF PANEL_FLAG=(KEEP_OOC(201).EQ.1) IF (PANEL_FLAG) THEN IERR=0 KEEP_OOC(228)=0 IF(allocated(AddVirtLibre))THEN DEALLOCATE(AddVirtLibre) ENDIF ALLOCATE(AddVirtLibre(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'DMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF AddVirtLibre(1:OOC_NB_FILE_TYPE)=0_8 IF(allocated(NextAddVirtBuffer))THEN DEALLOCATE(NextAddVirtBuffer) ENDIF ALLOCATE(NextAddVirtBuffer(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'DMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF NextAddVirtBuffer (1:OOC_NB_FILE_TYPE) = BufferEmpty IF(allocated(FIRST_VADDR_IN_BUF))THEN DEALLOCATE(FIRST_VADDR_IN_BUF) ENDIF ALLOCATE(FIRST_VADDR_IN_BUF(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'DMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF CALL DMUMPS_OOC_INIT_DB_BUFFER_PANEL() ELSE CALL DMUMPS_OOC_INIT_DB_BUFFER() ENDIF KEEP_OOC(223)=int(HBUF_SIZE) RETURN END SUBROUTINE DMUMPS_INIT_OOC_BUF SUBROUTINE DMUMPS_END_OOC_BUF() IMPLICIT NONE IF(allocated(BUF_IO))THEN DEALLOCATE(BUF_IO) ENDIF IF(allocated(I_SHIFT_FIRST_HBUF))THEN DEALLOCATE(I_SHIFT_FIRST_HBUF) ENDIF IF(allocated(I_SHIFT_SECOND_HBUF))THEN DEALLOCATE(I_SHIFT_SECOND_HBUF) ENDIF IF(allocated(I_SHIFT_CUR_HBUF))THEN DEALLOCATE(I_SHIFT_CUR_HBUF) ENDIF IF(allocated(I_REL_POS_CUR_HBUF))THEN DEALLOCATE(I_REL_POS_CUR_HBUF) ENDIF IF(allocated(LAST_IOREQUEST))THEN DEALLOCATE(LAST_IOREQUEST) ENDIF IF(allocated(CUR_HBUF))THEN DEALLOCATE(CUR_HBUF) ENDIF IF(PANEL_FLAG)THEN IF(allocated(NextAddVirtBuffer))THEN DEALLOCATE(NextAddVirtBuffer) ENDIF IF(allocated(AddVirtLibre))THEN DEALLOCATE(AddVirtLibre) ENDIF IF(allocated(FIRST_VADDR_IN_BUF))THEN DEALLOCATE(FIRST_VADDR_IN_BUF) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_END_OOC_BUF SUBROUTINE DMUMPS_OOC_INIT_DB_BUFFER() IMPLICIT NONE OOC_FCT_TYPE_LOC=1 HBUF_SIZE = DIM_BUF_IO / int(2,kind=kind(DIM_BUF_IO)) EARLIEST_WRITE_MIN_SIZE = 0 I_SHIFT_FIRST_HBUF(OOC_FCT_TYPE_LOC) = 0_8 I_SHIFT_SECOND_HBUF(OOC_FCT_TYPE_LOC) = HBUF_SIZE LAST_IOREQUEST(OOC_FCT_TYPE_LOC) = -1 I_CUR_HBUF_NEXTPOS = 1 I_CUR_HBUF_FSTPOS = 1 I_SUB_HBUF_FSTPOS = 1 CUR_HBUF(OOC_FCT_TYPE_LOC) = SECOND_HBUF CALL DMUMPS_OOC_NEXT_HBUF(OOC_FCT_TYPE_LOC) END SUBROUTINE DMUMPS_OOC_INIT_DB_BUFFER SUBROUTINE DMUMPS_OOC_COPY_DATA_TO_BUFFER(BLOCK,SIZE_OF_BLOCK, & IERR) IMPLICIT NONE INTEGER(8) :: SIZE_OF_BLOCK DOUBLE PRECISION BLOCK(SIZE_OF_BLOCK) INTEGER, intent(out) :: IERR INTEGER(8) :: I IERR=0 IF (I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + & SIZE_OF_BLOCK <= HBUF_SIZE + 1_8) THEN ELSE CALL DMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF DO I = 1_8, SIZE_OF_BLOCK BUF_IO(I_SHIFT_CUR_HBUF(OOC_FCT_TYPE_LOC) + & I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + I - 1_8) = & BLOCK(I) END DO I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) = & I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + SIZE_OF_BLOCK RETURN END SUBROUTINE DMUMPS_OOC_COPY_DATA_TO_BUFFER SUBROUTINE DMUMPS_OOC_INIT_DB_BUFFER_PANEL() IMPLICIT NONE INTEGER(8) :: DIM_BUF_IO_L_OR_U INTEGER TYPEF, TYPEF_LAST INTEGER NB_DOUBLE_BUFFERS TYPEF_LAST = OOC_NB_FILE_TYPE NB_DOUBLE_BUFFERS = OOC_NB_FILE_TYPE DIM_BUF_IO_L_OR_U = DIM_BUF_IO / & int(NB_DOUBLE_BUFFERS,kind=kind(DIM_BUF_IO_L_OR_U)) IF(.NOT.STRAT_IO_ASYNC)THEN HBUF_SIZE = DIM_BUF_IO_L_OR_U ELSE HBUF_SIZE = DIM_BUF_IO_L_OR_U / 2_8 ENDIF DO TYPEF = 1, TYPEF_LAST LAST_IOREQUEST(TYPEF) = -1 IF (TYPEF == 1 ) THEN I_SHIFT_FIRST_HBUF(TYPEF) = 0_8 ELSE I_SHIFT_FIRST_HBUF(TYPEF) = DIM_BUF_IO_L_OR_U ENDIF IF(.NOT.STRAT_IO_ASYNC)THEN I_SHIFT_SECOND_HBUF(TYPEF) = I_SHIFT_FIRST_HBUF(TYPEF) ELSE I_SHIFT_SECOND_HBUF(TYPEF) = I_SHIFT_FIRST_HBUF(TYPEF) + & HBUF_SIZE ENDIF CUR_HBUF(TYPEF) = SECOND_HBUF CALL DMUMPS_OOC_NEXT_HBUF(TYPEF) ENDDO I_CUR_HBUF_NEXTPOS = 1 RETURN END SUBROUTINE DMUMPS_OOC_INIT_DB_BUFFER_PANEL SUBROUTINE DMUMPS_OOC_TRYIO_CHBUF_PANEL(TYPEF,IERR) IMPLICIT NONE INTEGER, INTENT(in) :: TYPEF INTEGER, INTENT(out) :: IERR INTEGER IFLAG INTEGER NEW_IOREQUEST IERR=0 CALL MUMPS_TEST_REQUEST_C(LAST_IOREQUEST(TYPEF),IFLAG, & IERR) IF (IFLAG.EQ.1) THEN IERR = 0 CALL DMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF, & NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF LAST_IOREQUEST(TYPEF) = NEW_IOREQUEST CALL DMUMPS_OOC_NEXT_HBUF(TYPEF) NextAddVirtBuffer(TYPEF)=BufferEmpty RETURN ELSE IF(IFLAG.LT.0)THEN WRITE(*,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ELSE IERR = 1 RETURN ENDIF END SUBROUTINE DMUMPS_OOC_TRYIO_CHBUF_PANEL SUBROUTINE DMUMPS_OOC_UPD_VADDR_CUR_BUF (TYPEF,VADDR) IMPLICIT NONE INTEGER(8), INTENT(in) :: VADDR INTEGER, INTENT(in) :: TYPEF IF(I_REL_POS_CUR_HBUF(TYPEF).EQ.1_8)THEN FIRST_VADDR_IN_BUF(TYPEF)=VADDR ENDIF RETURN END SUBROUTINE DMUMPS_OOC_UPD_VADDR_CUR_BUF SUBROUTINE DMUMPS_COPY_LU_TO_BUFFER( STRAT, TYPEF, MonBloc, & AFAC, LAFAC, & AddVirtCour, IPIVBEG, IPIVEND, LPANELeff, & IERR) IMPLICIT NONE INTEGER, INTENT(IN) :: TYPEF, IPIVBEG, IPIVEND, STRAT INTEGER(8), INTENT(IN) :: LAFAC DOUBLE PRECISION, INTENT(IN) :: AFAC(LAFAC) INTEGER(8), INTENT(IN) :: AddVirtCour TYPE(IO_BLOCK), INTENT(IN) :: MonBloc INTEGER, INTENT(OUT):: LPANELeff INTEGER, INTENT(OUT):: IERR INTEGER :: II, NBPIVeff INTEGER(8) :: IPOS, IDIAG, IDEST INTEGER(8) :: DeltaIPOS INTEGER :: StrideIPOS IERR=0 IF (STRAT.NE.STRAT_WRITE_MAX.AND.STRAT.NE.STRAT_TRY_WRITE) THEN write(6,*) ' DMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented ' CALL MUMPS_ABORT() ENDIF NBPIVeff = IPIVEND - IPIVBEG + 1 IF (MonBloc%MASTER .AND. MonBloc%Typenode .NE. 3) THEN IF (TYPEF.EQ.TYPEF_L) THEN LPANELeff = (MonBloc%NROW-IPIVBEG+1)*NBPIVeff ELSE LPANELeff = (MonBloc%NCOL-IPIVBEG+1)*NBPIVeff ENDIF ELSE LPANELeff = MonBloc%NROW*NBPIVeff ENDIF IF ( ( I_REL_POS_CUR_HBUF(TYPEF) + int(LPANELeff - 1,8) & > & HBUF_SIZE ) & .OR. & ( (AddVirtCour.NE.NextAddVirtBuffer(TYPEF)) .AND. & (NextAddVirtBuffer(TYPEF).NE.BufferEmpty) ) & ) THEN IF (STRAT.EQ.STRAT_WRITE_MAX) THEN CALL DMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF,IERR) ELSE IF (STRAT.EQ.STRAT_TRY_WRITE) THEN CALL DMUMPS_OOC_TRYIO_CHBUF_PANEL(TYPEF,IERR) IF (IERR.EQ.1) RETURN ELSE write(6,*) 'DMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented' ENDIF ENDIF IF (IERR < 0 ) THEN RETURN ENDIF IF (NextAddVirtBuffer(TYPEF).EQ. BufferEmpty) THEN CALL DMUMPS_OOC_UPD_VADDR_CUR_BUF (TYPEF,AddVirtCour) NextAddVirtBuffer(TYPEF) = AddVirtCour ENDIF IF (MonBloc%MASTER .AND. MonBloc%Typenode .NE. 3) THEN IDIAG = int(IPIVBEG-1,8)*int(MonBloc%NCOL,8) + int(IPIVBEG,8) IPOS = IDIAG IDEST = I_SHIFT_CUR_HBUF(TYPEF) + & I_REL_POS_CUR_HBUF(TYPEF) IF (TYPEF.EQ.TYPEF_L) THEN DO II = IPIVBEG, IPIVEND CALL dcopy(MonBloc%NROW-IPIVBEG+1, & AFAC(IPOS), MonBloc%NCOL, & BUF_IO(IDEST), 1) IDEST = IDEST + int(MonBloc%NROW-IPIVBEG+1,8) IPOS = IPOS + 1_8 ENDDO ELSE DO II = IPIVBEG, IPIVEND CALL dcopy(MonBloc%NCOL-IPIVBEG+1, & AFAC(IPOS), 1, & BUF_IO(IDEST), 1) IDEST = IDEST + int(MonBloc%NCOL-IPIVBEG+1,8) IPOS = IPOS + int(MonBloc%NCOL,8) ENDDO ENDIF ELSE IDEST = I_SHIFT_CUR_HBUF(TYPEF) + & I_REL_POS_CUR_HBUF(TYPEF) IF (MonBloc%Typenode.EQ.3) THEN DeltaIPOS = int(MonBloc%NROW,8) StrideIPOS = 1 ELSE DeltaIPOS = 1_8 StrideIPOS = MonBloc%NCOL ENDIF IPOS = 1_8 + int(IPIVBEG - 1,8) * DeltaIPOS DO II = IPIVBEG, IPIVEND CALL dcopy(MonBloc%NROW, & AFAC(IPOS), StrideIPOS, & BUF_IO(IDEST), 1) IDEST = IDEST+int(MonBloc%NROW,8) IPOS = IPOS + DeltaIPOS ENDDO ENDIF I_REL_POS_CUR_HBUF(TYPEF) = & I_REL_POS_CUR_HBUF(TYPEF) + int(LPANELeff,8) NextAddVirtBuffer(TYPEF) = NextAddVirtBuffer(TYPEF) & + int(LPANELeff,8) RETURN END SUBROUTINE DMUMPS_COPY_LU_TO_BUFFER END MODULE DMUMPS_OOC_BUFFER MUMPS_5.8.1/src/zooc_panel_piv.F0000664000175000017500000002771315042446442016362 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C This file contains routines related to OOC, C panels, and pivoting. They are used to store C permutation information of what is already on C disk to be able to permute things back at the C solve stage. C They do not need to be in the MUMPS_OOC C module (most of them do not use any variable C from the module, or are called from routines C where we do not necessarily want to do a C USE ZMUMPS_OOC). INTEGER FUNCTION ZMUMPS_OOC_GET_PANEL_SIZE & ( HBUF_SIZE, NNMAX, K227, K50 ) IMPLICIT NONE C C Arguments: C ========= C INTEGER, INTENT(IN) :: NNMAX, K227, K50 INTEGER(8), INTENT(IN) :: HBUF_SIZE C C Purpose: C ======= C C - Compute the effective size (maximum number of pivots in a panel) C for a front with NNMAX entries in its row (for U) / C column (for L). C - Be able to adapt the fixed number of columns in panel C depending on NNMAX, and size of IO buffer HBUF_SIZE C C Local variables C =============== C INTEGER K227_LOC INTEGER NBCOL_MAX INTEGER EFFECTIVE_SIZE NBCOL_MAX=int(HBUF_SIZE / int(NNMAX,8)) C KEEP(227): Maximum size (nb of col/row) of a panel K227_LOC = abs(K227) IF (K50.EQ.2) THEN C for 2x2 pivots we may end-up having the first part C of a 2x2 pivot in the last col of the panel; the C adopted solution consists in adding the next column C to the panel; therefore we need be able to C dynamically increase the panel size by one. C note that we also maintain property: C KEEP(227): Maximum size (nb of col/row) of a panel K227_LOC=max(K227_LOC,2) EFFECTIVE_SIZE = min(NBCOL_MAX-1, K227_LOC-1) cN - during bwd the effective size is useless ELSE C complete buffer space can be used for a panel EFFECTIVE_SIZE = min(NBCOL_MAX, K227_LOC) ENDIF IF (EFFECTIVE_SIZE.LE.0) THEN write(6,*) 'Internal buffers too small to store ', & ' ONE col/row of size', NNMAX CALL MUMPS_ABORT() ENDIF ZMUMPS_OOC_GET_PANEL_SIZE = EFFECTIVE_SIZE RETURN END FUNCTION ZMUMPS_OOC_GET_PANEL_SIZE C SUBROUTINE ZMUMPS_PERMUTE_PANEL( IPIV, LPIV, ISHIFT, & THE_PANEL, NBROW, NBCOL, KbeforePanel ) IMPLICIT NONE C C Purpose: C ======= C C Permute rows of a panel, stored by columns, according C to permutation array IPIV. C IPIV is such that, for I = 1 to LPIV, row ISHIFT + I C in the front must be permuted with row IPIV( I ) C C Since the panel is not necessary at the beginning of C the front, let KbeforePanel be the number of pivots in the C front before the first pivot of the panel. C C In the panel, row ISHIFT+I-KbeforePanel is permuted with C row IPIV(I)-KbeforePanel C C Note: C ==== C C This routine can also be used to permute the columns of C a matrix (U) stored by rows. In that case, the argument C NBROW represents the number of columns, and NBCOL represents C the number of rows. C C C Arguments: C ========= C INTEGER LPIV, ISHIFT, NBROW, NBCOL, KbeforePanel INTEGER IPIV(LPIV) COMPLEX(kind=8) THE_PANEL(NBROW, NBCOL) C C Local variables: C =============== C INTEGER I, IPERM C C Executable statements C ===================== C DO I = 1, LPIV C Swap rows ISHIFT + I and PIV(I) IPERM=IPIV(I) IF ( I+ISHIFT.NE.IPERM) THEN CALL zswap(NBCOL, & THE_PANEL(I+ISHIFT-KbeforePanel,1), NBROW, & THE_PANEL(IPERM-KbeforePanel,1), NBROW) ENDIF END DO RETURN END SUBROUTINE ZMUMPS_PERMUTE_PANEL SUBROUTINE ZMUMPS_GET_OOC_PERM_PTR(TYPEF, & NBPANELS, & I_PIVPTR, I_PIV, IPOS, IW, LIW) USE MUMPS_OOC_COMMON ! To access TYPEF_L and TYPEF_U IMPLICIT NONE INCLUDE 'mumps_headers.h' C C Purpose: C ======= C C Get the pointers in IW on pivoting information to be stored C during factorization and used during the solve phase. This C routine is both for the symmetric (TYPEF=TYPEF_L) and unsymmetric C cases (TYPEF=TYPEF_L or TYPEF_U). C The total size of this space is estimated during C fac_ass.F / fac_ass_ELT.F and must be: C * Symmetric case: 1 for NASS + 1 for NBPANELS_L + NBPANELS_L + NASS C * Unsymmetric case: 1 + (1+NBPANELS_L+NASS) + (1+NBPANELS_U+NASS) C Size computation is in routine ZMUMPS_OOC_GET_PP_SIZES. C C At the end of the standard description of the structure of a node C (header, nb slaves, , row indices, col indices), we C add, when panel version with pivoting is used: C C NASS (nb of fully summed variables) C NBPANELS_L C PIVRPTR(1:NBPANELS_L) C PIV_L (1:NASS) NASS (=IW(IPOS)(or NASS-PIVRPTR(1) in C the future, after compression) C NBPANELS_U C PIVRPTR(1:NBPANELS_U) C PIV_U (1:NASS) NASS (=IW(IPOS)(or NASS-PIVRPTR(1) in C the future, after compression) C C C Output parameters: C ================= C NBPANELS : nb of panels as estimated during assembly C I_PIVPTR : position in IW of the starting of the pointer list C (of size NBPANELS) of the pointers to the list of pivots C I_PIV : position in IW of the starting of the pivot permutation list C INTEGER, intent(out) :: NBPANELS, I_PIVPTR, I_PIV INTEGER, intent(in) :: TYPEF ! TYPEF_L or TYPEF_U INTEGER, intent(in) :: LIW, IPOS INTEGER IW(LIW) C Locals INTEGER I_NBPANELS, I_NASS C I_NASS = IPOS I_NBPANELS = I_NASS + 1 ! L NBPANELS = IW(I_NBPANELS) ! L I_PIVPTR = I_NBPANELS + 1 ! L I_PIV = I_PIVPTR + NBPANELS ! L C ... of size NASS = IW(I_NASS) IF (TYPEF==TYPEF_U) THEN I_NBPANELS = I_PIV+IW(I_NASS) ! U NBPANELS = IW(I_NBPANELS) ! U I_PIVPTR = I_NBPANELS + 1 ! U I_PIV = I_PIVPTR + NBPANELS ! U ENDIF RETURN END SUBROUTINE ZMUMPS_GET_OOC_PERM_PTR SUBROUTINE ZMUMPS_OOC_PP_SET_PTR(K50,NBPANELS_L,NBPANELS_U, & NASS, IPOS, IW, LIW ) IMPLICIT NONE C C Purpose: C ======= C C Initialize the contents of PIV/PIVPTR/etc. that will store C pivoting information during the factorization. C NASS and NBPANELS are recorded. PIVPTR(1:NBPANELS) C is initialized to NASS+1. This will be modified during C the factorization in cases where permutations have to C be performed during the solve phase. C C Arguments: C ========= C INTEGER K50 INTEGER IPOS, NASS, NBPANELS_L, NBPANELS_U, LIW INTEGER IW(LIW) C C Local variables: C =============== C INTEGER IPOS_U C Executable statements IF (K50.EQ.1) THEN WRITE(*,*) "Internal error: ZMUMPS_OOC_PP_SET_PTR called" ENDIF IW(IPOS)=NASS IW(IPOS+1)=NBPANELS_L IW(IPOS+2:IPOS+1+NBPANELS_L)=NASS+1 IF (K50 == 0) THEN IPOS_U=IPOS+2+NASS+NBPANELS_L IW(IPOS_U)=NBPANELS_U IW(IPOS_U+1:IPOS_U+NBPANELS_U)=NASS+1 ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_PP_SET_PTR SUBROUTINE ZMUMPS_OOC_PP_TRYRELEASE_SPACE ( & IWPOS, IOLDPS, IW, LIW, MonBloc, NFRONT, KEEP & ) USE ZMUMPS_OOC IMPLICIT NONE INCLUDE 'mumps_headers.h' C C Purpose: C ======= C If space used was at the top of the stack then C try to free space by detecting that C no permutation needs to be applied during C solve on panels. C One position is left (I_NASS) and set to -1 C to indicate that permutation not needed at solve. C C Arguments: C ========= C INTEGER, INTENT(IN) :: IOLDPS, LIW, NFRONT, & KEEP(500) INTEGER, INTENT(INOUT) :: IWPOS, IW(LIW) TYPE(IO_BLOCK), INTENT(IN):: MonBloc C C Local variables: C =============== C INTEGER :: NBPANELS_L,I_PIVRPTR_L, I_PIVR_L, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, XSIZE, IBEGOOC LOGICAL FREESPACE ! set to true when permutation not needed C Executable statements IF (KEEP(50).EQ.1) RETURN ! no pivoting C -------------------------------- C quick return if record is not at C the top of stack of L factors IF ((IOLDPS+IW(IOLDPS+XXI)).NE.IWPOS) RETURN C --------------------------------------------- C Panel+pivoting: get pointers on each subarray C --------------------------------------------- XSIZE = KEEP(IXSZ) IBEGOOC = IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE C -- get L related data CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IBEGOOC, IW, LIW) FREESPACE = & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_L)-1)) IF (KEEP(50).EQ.0) THEN C -- get U related dataA CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IBEGOOC, IW, LIW) FREESPACE = FREESPACE .AND. & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_U)-1)) ENDIF C --------------------------------- C Check if permutations eed be C performed on panels during solve C -------------------------------- IF (FREESPACE) THEN C -- compress memory for that node: keep one entry set to -7777 IW(IBEGOOC) = -7777 ! will be tested during solve IW(IOLDPS+XXI) = IBEGOOC & - IOLDPS + 1 ! new size of inode's record IWPOS = IBEGOOC+1 ! move back to top of stack ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_PP_TRYRELEASE_SPACE C SUBROUTINE ZMUMPS_OOC_GET_PP_SIZES(K50, NBROW_L, NBCOL_U, NASS, & NBPANELS_L, NBPANELS_U, LREQ) USE ZMUMPS_OOC ! To call ZMUMPS_OOC_PANEL_SIZE IMPLICIT NONE C C Purpose C ======= C C Compute the size of the workspace required to store the permutation C information during factorization, so that solve can permute back C what has to be permuted (this could not be done during factorization C because it was already on disk). C C Arguments C ========= C INTEGER, intent(IN) :: K50, NBROW_L, NBCOL_U, NASS INTEGER, intent(OUT) :: NBPANELS_L, NBPANELS_U, LREQ NBPANELS_L=-99999 NBPANELS_U=-99999 C C Quick return in SPD case (no pivoting) C IF (K50.EQ.1) THEN LREQ = 0 RETURN ENDIF C C L information is always computed C NBPANELS_L = (NASS / ZMUMPS_OOC_PANEL_SIZE(NBROW_L))+1 LREQ = 1 ! Store NASS & + 1 ! Store NBPANELS_L & + NASS ! Store permutations & + NBPANELS_L ! Store pointers on permutations IF (K50.eq.0) THEN C C Also take U information into account C NBPANELS_U = (NASS / ZMUMPS_OOC_PANEL_SIZE(NBCOL_U) ) +1 LREQ = LREQ + 1 ! Store NBPANELS_U & + NASS ! Store permutations & + NBPANELS_U ! Store pointers on permutations ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_GET_PP_SIZES SUBROUTINE ZMUMPS_OOC_PP_CHECK_PERM_FREED & (IW_LOCATION, MUST_BE_PERMUTED) IMPLICIT NONE INTEGER, INTENT(IN) :: IW_LOCATION LOGICAL, INTENT(INOUT) :: MUST_BE_PERMUTED C C Purpose C ======= C C Reset MUST_BE_PERMUTED to .FALSE. when we detect C that the ZMUMPS_OOC_PP_TRY_RELEASE_SPACE has freed C the permutation information (see that routine). C IF (IW_LOCATION .EQ. -7777) THEN MUST_BE_PERMUTED = .FALSE. ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_PP_CHECK_PERM_FREED MUMPS_5.8.1/src/dfac_front_LU_type1.F0000664000175000017500000012401315042446437017175 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC1_LU_M CONTAINS SUBROUTINE DMUMPS_FAC1_LU( & N, INODE, IW, LIW, A, & LA, & IOLDPS, POSELT, IFLAG, IERROR, UU, & NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, & IWPOS & , LRGROUPS & , PERM & ) USE DMUMPS_FAC_FRONT_AUX_M USE DMUMPS_OOC USE DMUMPS_FAC_LR USE DMUMPS_LR_TYPE USE MUMPS_LR_STATS USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_DATA_M USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T #if ! defined(BLR_NOOPENMP) #endif !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, INTENT(INOUT) :: NOFFW, NPVW, NBTINYW INTEGER, INTENT(INOUT) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, INTENT(INOUT) :: DET_MANTW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER MYID, SLAVEF, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ), STEP(N) DOUBLE PRECISION UU, SEUIL LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)), PERM(N) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER LAST_ROW, LAST_COL, FIRST_COL LOGICAL CALL_LTRSM, CALL_UTRSM DOUBLE PRECISION UUTEMP LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC INTEGER PIVOT_OPTION INTEGER LRTRSM_OPTION INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U INTEGER TYPEF_LOC TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PARPIV_T1 INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER :: K473_LOC INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER INFO_TMP(2), MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM, NELIM_LOC INTEGER :: IROW_L, NVSCHUR INTEGER, POINTER, DIMENSION(:) :: PTDummy INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_U, BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL DOUBLE PRECISION, POINTER, DIMENSION(:) :: DIAG INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, LorU, I, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG CHARACTER(len=1) :: DIR DOUBLE PRECISION, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) DOUBLE PRECISION, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok,J INTEGER :: OMP_NUM INTEGER :: IP INTEGER(8) :: UPOS, LPOS INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_U, NEXT_BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC DOUBLE PRECISION :: ZERO PARAMETER (ZERO=0.0D0) LOGICAL :: SWAP_OCCURRED INCLUDE 'mumps_headers.h' FIRST_BLOCK = -99999 LAST_BLOCK = -99999 IP=0 IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF SWAP_OCCURRED = .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 PIVOT_OPTION = KEEP(468) LRTRSM_OPTION = KEEP(475) LAFAC = -9999_8 XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) NASS = abs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED = .FALSE. COMPRESS_PANEL = .FALSE. COMPRESS_CB = .FALSE. NULLIFY(PTDummy) NULLIFY(BEGS_BLR) NULLIFY(CB_LRB) NULLIFY(ACC_LUA) NULLIFY(BLR_U) NULLIFY(BLR_L) NULLIFY(BEGS_BLR_TMP) NULLIFY(BLR_PANEL) NULLIFY(DIAG) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN K473_LOC = 1 ELSE K473_LOC = KEEP(473) ENDIF K473_LOC = KEEP(473) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL DMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS, KEEP, & LR_ACTIVATED, PARPIV_T1) IF (UUTEMP.EQ.ZERO) THEN PIVOT_OPTION=0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF IF (LR_ACTIVATED) THEN IF (LRTRSM_OPTION.EQ.3) THEN PIVOT_OPTION = MIN(PIVOT_OPTION,1) ELSEIF (LRTRSM_OPTION.EQ.2) THEN PIVOT_OPTION = MIN(PIVOT_OPTION, 2) ENDIF ENDIF IF (PIVOT_OPTION.LE.1) THEN PARPIV_T1 = 0 ENDIF CALL DMUMPS_SET_INNERBLOCKSIZE( NBKJIB_ORIG, NASS, KEEP) IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = IOLDPS+6+XSIZE+NASS CALL DMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF ( OOC_EFFECTIVE_ON_FRONT ) THEN LNextPiv2beWritten = 1 UNextPiv2beWritten = 1 PP_FIRST2SWAP_L = LNextPiv2beWritten PP_FIRST2SWAP_U = UNextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%LastPanelWritten_U = 0 PP_LastPIVRPTRFilled_L = 0 PP_LastPIVRPTRFilled_U = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 1 MonBloc%NROW = NFRONT MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -88877 NULLIFY(MonBloc%INDICES) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(405) .EQ. 1) THEN !$OMP ATOMIC UPDATE CNT_NODES = CNT_NODES + 1 !$OMP END ATOMIC ELSE CNT_NODES = CNT_NODES + 1 ENDIF ELSE IF (KEEP(486).NE.0) THEN ENDIF OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472), & NFRONT, KEEP(1)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 490 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL DMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .FALSE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF IF (COMPRESS_CB) THEN IF (NPARTSCB.GT.0) THEN allocate(CB_LRB(NPARTSCB,NPARTSCB),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSCB*NPARTSCB GOTO 490 ENDIF CALL DMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF ENDIF DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = BEGS_BLR(CURRENT_BLR+1)-1 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(480).GE.5) THEN IF (CURRENT_BLR.EQ.1) THEN ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR) THEN BLR_U(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) BLR_L(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ELSE IF (NB_BLR.GT.CURRENT_BLR) THEN CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF IF (CURRENT_BLR.LT.NPARTSASS) THEN ALLOCATE(NEXT_BLR_U(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF ALLOCATE(NEXT_BLR_L(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR+1) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR+1, NEXT_BLR_U, 0) CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR+1, NEXT_BLR_L, 0) ENDIF ENDIF ELSE ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE CALL DMUMPS_FAC_I(NFRONT,NASS,NFRONT, & IBEG_BLOCK,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, & DKEEP(1), PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1 & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF ELSE IF ( INOPV.LE.0 ) THEN INOPV = 0 IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL DMUMPS_FAC_MQ(IBEG_BLOCK, IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED & ) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) THEN GOTO 50 ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_U, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL DMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, & NPIV, NFRONT, IEND_BLR, LAST_COL, & A, LA, POSELT, & -66666, & .TRUE., .FALSE., .TRUE., & .FALSE., & LR_ACTIVATED & ) ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN IF (PIVOT_OPTION.EQ.4) THEN LAST_ROW = NFRONT ELSE LAST_ROW = NASS ENDIF IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSE LAST_COL = NASS ENDIF IF (IEND_BLR.LT.LAST_ROW) THEN CALL DMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, LAST_ROW, LAST_COL, & A, LA, POSELT, IEND_BLR, .TRUE., (PIVOT_OPTION.LT.2), & .TRUE., .FALSE., & LR_ACTIVATED) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_U(J)%M=0 BLR_U(J)%N=0 BLR_U(J)%K=0 BLR_U(J)%ISLR=.FALSE. NULLIFY(BLR_U(J)%Q) NULLIFY(BLR_U(J)%R) ENDDO CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) NULLIFY(BLR_L) NULLIFY(BLR_U) IF (KEEP(480).GE.2 .AND. IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = 1 ELSE FIRST_BLOCK = NPARTSASS-CURRENT_BLR ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL DMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) IF (IFLAG.LT.0) GOTO 900 CALL DMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) 900 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF ENDIF GOTO 100 ENDIF IF (PIVOT_OPTION.GE.3) THEN FIRST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN FIRST_COL = NASS ELSE FIRST_COL = IEND_BLR ENDIF IF (LRTRSM_OPTION.EQ.3) THEN LAST_COL = IEND_BLR ELSEIF (LRTRSM_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = NFRONT ENDIF CALL_LTRSM = (LRTRSM_OPTION.EQ.0) CALL_UTRSM = (LAST_COL-FIRST_COL.GT.0) IF ((IEND_BLR.LT.NFRONT) .AND. & (CALL_LTRSM.OR.CALL_UTRSM)) THEN CALL DMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NFRONT, & LAST_COL, & A, LA, POSELT, & FIRST_COL, CALL_LTRSM, & CALL_UTRSM, .FALSE., & .FALSE., & LR_ACTIVATED) ENDIF #if ! defined(BLR_NOOPENMP) #endif #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(UPOS,LPOS) FIRSTPRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), & KEEP(458), K473_LOC, & BLR_U, CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), & KEEP(458), K473_LOC, BLR_L, & CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER !$OMP MASTER #endif IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (LRTRSM_OPTION.GT.0) THEN CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NB_BLR, 1, 0, 0, .FALSE.) IF (PIVOT_OPTION.LT.3.AND.LRTRSM_OPTION.GE.2) THEN IF (PIVOT_OPTION.LE.1.AND.LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, NB_BLR, BLR_U, & CURRENT_BLR, FIRST_BLOCK, NB_BLR, & 1, 0, 1, .FALSE.) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif CALL DMUMPS_BLR_UPD_NELIM_VAR_U( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_U, NB_BLR, & FIRST_BLOCK, IBEG_BLR, NPIV, NELIM) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(480).GE.2) THEN UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) LPOS = POSELT+int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) CALL DMUMPS_BLR_UPD_NELIM_VAR_L(A, LA, UPOS, A, LA, & LPOS, IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & CURRENT_BLR+1, NELIM, 'N') IF (IFLAG.LT.0) GOTO 444 IF (IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = 1 ELSE FIRST_BLOCK = NPARTSASS-CURRENT_BLR ENDIF CALL DMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) IF (IFLAG.LT.0) GOTO 442 CALL DMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) 442 CONTINUE ENDIF 444 CONTINUE ELSE CALL DMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & BLR_U, NB_BLR, & NELIM,.FALSE., 0, & 1, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(486).NE.2) THEN LAST_BLOCK = NB_BLR ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF IF (LRTRSM_OPTION.GT.0) THEN FIRST_BLOCK = CURRENT_BLR+1 CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_L, CURRENT_BLR, 'V', 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) #if ! defined(BLR_NOOPENMP) #endif ENDIF IF (LRTRSM_OPTION.GE.2) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_U, CURRENT_BLR, 'H', 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL(BLR_U, NB_BLR-CURRENT_BLR, KEEP8, & KEEP(34)) CALL DEALLOC_BLR_PANEL(BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & KEEP(34)) DEALLOCATE(BLR_U,BLR_L) ENDIF ENDIF NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN IF (PIVOT_OPTION.LT.4) THEN TYPEF_LOC = TYPEF_U ELSE TYPEF_LOC = TYPEF_BOTH_LU ENDIF MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_LOC, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO IP=1,NB_BLR+1 BEGS_BLR_TMP(IP) = BEGS_BLR_STATIC(IP) ENDDO ENDIF ENDIF MEM_TOT = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP& PRIVATE(IP, LorU, DIR, NELIM_LOC, BLR_PANEL) #endif IF ( & (KEEP(486).EQ.2) & ) THEN #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*(2*DIAGSIZ_STA-DIAGSIZ_DYN) MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA IF (I.LE.DIAGSIZ_DYN) THEN DIAG(DPOS:DPOS+DIAGSIZ_STA-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_STA-1,8)) DPOS = DPOS + DIAGSIZ_STA ELSE DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN ENDIF POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL DMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG, KEEP(34)) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO !$OMP SINGLE #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM_TOT,8), & (KEEP(405).NE.0), KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 447 IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN DO IP=1,NPARTSASS NELIM_LOC = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) DO LorU=0,1 CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8, & KEEP(34)) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (LorU.EQ.0) THEN DIR = 'V' ELSE DIR = 'H' ENDIF CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(458), K473_LOC, & BLR_PANEL, IP, & DIR, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM_LOC, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif 445 CONTINUE ENDIF 447 CONTINUE ENDIF IF (IFLAG .LT. 0) GOTO 450 IF (KEEP(480) .GE. 2) THEN #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif CALL DMUMPS_BLR_UPD_CB_LEFT(A, LA, POSELT, NFRONT, & BEGS_BLR_STATIC, BEGS_BLR_STATIC, & NPARTSCB, NPARTSCB, NPARTSASS, NASS, & IW(IOLDPS+XXF), & 1, .FALSE., IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & ACC_LUA, KEEP(480),KEEP(479),KEEP(478),KEEP(476), & KEEP(484), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & .FALSE., & CB_LRB, KEEP8) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF IF (IFLAG.LT.0) GOTO 450 #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF (COMPRESS_CB & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL DMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (COMPRESS_CB) THEN IEND_BLR = BEGS_BLR(CURRENT_BLR+2) IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) ENDIF ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (COMPRESS_CB) THEN CALL DMUMPS_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR, NPARTSCB, NPARTSCB, NPARTSASS, & NFRONT-NASS, NFRONT-NASS, INODE, & IW(IOLDPS+XXF), 0, 1, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & -9999, -9999, -9999, KEEP(1), & NELIM=NELIM) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF 450 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF ( & ( & (KEEP(486).EQ.2) & ) & .AND.UU.GT.0 .AND. SWAP_OCCURRED & ) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 0, NASS-NPIV) DO IP=1,NPARTSASS DO LorU=0,1 CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NB_BLR-IP & ) ENDDO ENDDO CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NPIV, 0, 1) ENDIF IF ( (PIVOT_OPTION.LT.4) .AND. (.NOT.LR_ACTIVATED) ) THEN CALL DMUMPS_FAC_FR_UPDATE_CBROWS( INODE, & NFRONT, NASS, (PIVOT_OPTION.LT.3), A, LA, LAFAC, POSELT, & IW, LIW, IOLDPS, MonBloc, MYID, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR ) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 0, 1) ENDIF ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF CALL DMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 490 CONTINUE 500 CONTINUE 600 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(WORK)) deallocate(WORK) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) deallocate(TAU) IF (allocated(JPVT)) deallocate(JPVT) IF (allocated(BLOCK)) deallocate(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) ENDDO ENDIF DEALLOCATE(ACC_LUA) NULLIFY(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL DMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 2, & KEEP8, KEEP(34)) ENDIF ENDIF IF ( LR_ACTIVATED .AND. KEEP(486).EQ. 2 .AND. & KEEP(251) .EQ. 2) THEN CALL DMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8, KEEP(34)) ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND. .NOT.COMPRESS_CB) THEN CALL DMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34), MTK405=KEEP(405)) ENDIF ENDIF NPVW = NPVW + IW(IOLDPS+1+XSIZE) RETURN END SUBROUTINE DMUMPS_FAC1_LU END MODULE DMUMPS_FAC1_LU_M SUBROUTINE DMUMPS_FAC1_LU_I( N, INODE, IW, LIW, A, & LA, & IOLDPS, POSELT, IFLAG, IERROR, UU, & NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, & IWPOS & , LRGROUPS & , PERM & ) USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T USE DMUMPS_FAC1_LU_M, ONLY: DMUMPS_FAC1_LU IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, INTENT(INOUT) :: NOFFW, NPVW, NBTINYW INTEGER, INTENT(INOUT) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, INTENT(INOUT) :: DET_MANTW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER MYID, SLAVEF, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ), STEP(N) DOUBLE PRECISION UU, SEUIL LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)), PERM(N) CALL DMUMPS_FAC1_LU( N, INODE, IW, LIW, A, & LA, & IOLDPS, POSELT, IFLAG, IERROR, UU, & NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, & IWPOS & , LRGROUPS & , PERM & ) RETURN END SUBROUTINE DMUMPS_FAC1_LU_I MUMPS_5.8.1/src/fac_future_niv2_mod.F0000664000175000017500000000106415042446423017261 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_FUTURE_NIV2 INTEGER, DIMENSION(:), ALLOCATABLE, PUBLIC :: FUTURE_NIV2 END MODULE MUMPS_FUTURE_NIV2 MUMPS_5.8.1/src/zfac_process_rtnelind.F0000664000175000017500000001137015042446441017722 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_PROCESS_RTNELIND( root, roota, & INODE, NELIM, NSLAVES, ROW_LIST, & COL_LIST, SLAVE_LIST, & & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND ) USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER INODE, NELIM, NSLAVES INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER ROW_LIST(*), COL_LIST(*), & SLAVE_LIST(*) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), ITLOC( N + KEEP(253) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER IFLAG, IERROR INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF INTEGER COMM, COMM_LOAD, ND(KEEP(28)), FILS(N), DAD(KEEP(28)) INTEGER IROOT, TYPE_INODE, DEB_ROW, DEB_COL, & NOINT INTEGER(8) :: NOREAL INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE IROOT = KEEP(38) NSTK_S(STEP(IROOT))= NSTK_S(STEP(IROOT)) - 1 KEEP(42) = KEEP(42) + NELIM TYPE_INODE= MUMPS_TYPENODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IF (TYPE_INODE.EQ.1) THEN IF (NELIM.EQ.0) THEN KEEP(41) = KEEP(41) + 1 ELSE KEEP(41) = KEEP(41) + 3 ENDIF ELSE IF (NELIM.EQ.0) THEN KEEP(41) = KEEP(41) + NSLAVES ELSE KEEP(41) = KEEP(41) + 2*NSLAVES + 1 ENDIF ENDIF IF (NELIM.EQ.0) THEN PIMASTER(STEP(INODE)) = 0 ELSE NOINT = 6 + NSLAVES + NELIM + NELIM + KEEP(IXSZ) NOREAL= 0_8 CALL ZMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) THEN WRITE(*,*) ' Failure in int space allocation in CB area ', & ' during assembly of root : ZMUMPS_PROCESS_RTNELIND', & ' size required was :', NOINT, & 'INODE=',INODE,' NELIM=',NELIM, ' NSLAVES=', NSLAVES RETURN ENDIF PIMASTER(STEP( INODE )) = IWPOSCB + 1 PAMASTER(STEP( INODE )) = IPTRLU + 1_8 IW( IWPOSCB + 1+KEEP(IXSZ) ) = 2*NELIM IW( IWPOSCB + 2+KEEP(IXSZ) ) = NELIM IW( IWPOSCB + 3+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 5+KEEP(IXSZ) ) = 1 IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES IF (NSLAVES.GT.0) THEN IW( IWPOSCB+7+KEEP(IXSZ):IWPOSCB+7+KEEP(IXSZ)+NSLAVES-1) = & SLAVE_LIST(1:NSLAVES) ENDIF DEB_ROW = IWPOSCB+7+NSLAVES+KEEP(IXSZ) IW(DEB_ROW : DEB_ROW+NELIM -1) = ROW_LIST(1:NELIM) DEB_COL = DEB_ROW + NELIM IW(DEB_COL : DEB_COL+NELIM -1) = COL_LIST(1:NELIM) ENDIF IF (NSTK_S(STEP(IROOT)) .EQ. 0 ) THEN CALL ZMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN END SUBROUTINE ZMUMPS_PROCESS_RTNELIND MUMPS_5.8.1/src/dsol_distsol.F0000664000175000017500000000101115042446437016040 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_DS_RETURN() RETURN END SUBROUTINE DMUMPS_DS_RETURN MUMPS_5.8.1/src/zmumps_struc_def.F0000664000175000017500000000102415042446441016726 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_STRUC_DEF INCLUDE 'zmumps_struc.h' END MODULE ZMUMPS_STRUC_DEF MUMPS_5.8.1/src/cfac_process_contrib_type3.F0000664000175000017500000002572215042446440020645 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_PROCESS_CONTRIB_TYPE3(BUFR,LBUFR, & LBUFR_BYTES, & root, roota, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND,PROCNODE_STEPS, SLAVEF, OPASSW ) USE MUMPS_LOAD USE CMUMPS_OOC USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC ) :: root TYPE (CMUMPS_ROOT_STRUC ) :: roota INTEGER :: KEEP( 500 ) INTEGER(8) :: KEEP8(150) REAL :: DKEEP(230) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER LBUFR, LBUFR_BYTES, N, LIW, & IWPOS, IWPOSCB, COMP, COMM, COMM_LOAD, IFLAG, & IERROR INTEGER LPOOL, LEAF INTEGER IPOOL( LEAF ) INTEGER PTRIST(KEEP(28)) INTEGER PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), ITLOC( N+KEEP(253) ) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER BUFR( LBUFR_BYTES ) INTEGER IW( LIW ) INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER SLAVEF COMPLEX A( LA ) INTEGER MYID INTEGER FILS( N ), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER INTARR(KEEP8(27)) COMPLEX DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW 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( STEP(IROOT)) .NE. 0 ) THEN IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NSUBSET_ROW & - NSUPROW .OR. NSUBSET_ROW - NSUPROW.EQ.0 .OR. & NSUBSET_COL_EFF .EQ. 0)THEN KEEP(121) = KEEP(121) - 1 IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL CMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSEIF (KEEP(201).EQ.2) THEN CALL CMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL CMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), & KEEP(28), KEEP(76), & KEEP(80), KEEP(47), & STEP, IROOT + N) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ENDIF ENDIF ELSE IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. & NSUBSET_ROW - NSUPROW .OR. & NSUBSET_ROW - NSUPROW.EQ.0 .OR. & NSUBSET_COL_EFF .EQ. 0)THEN KEEP(121)=-1 ENDIF CALL CMUMPS_ROOT_ALLOC_STATIC( root, roota, IROOT, N, & IW, LIW, A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) IF ( IFLAG .LT. 0 ) RETURN END IF IF (KEEP(60) .EQ.0) THEN IF ( PTRIST(STEP(IROOT)) .GE. 0 ) THEN IF ( PTRIST(STEP(IROOT)) .NE. 0 ) THEN LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) POS_ROOT = PAMASTER(STEP( IROOT )) ELSE LOCAL_N = IW( PTLUST(STEP( IROOT ) ) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST(STEP( IROOT ) ) + 2 + KEEP(IXSZ)) POS_ROOT = PTRFAC(IW(PTLUST(STEP(IROOT))+4+ & KEEP(IXSZ))) END IF ENDIF ELSE LOCAL_M = root%SCHUR_LLD LOCAL_N = root%SCHUR_NLOC ENDIF IF ( (BBPCBP.EQ.1).AND. (NBROWS_ALREADY_SENT.EQ.0).AND. & (min(NSUPROW, NSUPCOL) .GT. 0) & ) THEN LREQI = NSUPROW+NSUPCOL LREQA = int(NSUPROW,8) * int(NSUPCOL,8) IF ( (LREQA.NE.0_8) .AND. & (PTRIST(STEP(IROOT)).LT.0).AND. & KEEP(60)==0) THEN WRITE(*,*) ' Error in CMUMPS_PROCESS_CONTRIB_TYPE3' CALL MUMPS_ABORT() ENDIF CALL CMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 1 ), LREQI, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( IPTRLU + 1_8 ), int(LREQA), & MPI_COMPLEX, COMM, IERR ) OPASSW = OPASSW + LREQA CALL CMUMPS_ASS_ROOT( root, roota, KEEP(50), NSUPROW, NSUPCOL, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NSUPROW + 1 ), NSUPCOL, & A( IPTRLU + 1_8 ), & A( 1 ), & LOCAL_M, LOCAL_N, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & 1) IWPOSCB = IWPOSCB + LREQI IPTRLU = IPTRLU + LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) ENDIF LREQI = NBROWS_PACKET + NSUBSET_COL_EFF LREQA = int(NBROWS_PACKET,8) * int(NSUBSET_COL_EFF,8) IF ( (LREQA.NE.0_8) .AND. & (PTRIST(STEP(IROOT)).LT.0).AND. & KEEP(60)==0) THEN WRITE(*,*) ' Error in CMUMPS_PROCESS_CONTRIB_TYPE3' CALL MUMPS_ABORT() ENDIF IF (LREQA.NE.0_8) THEN CALL CMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 1 ), LREQI, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( IPTRLU + 1_8 ), int(LREQA), & MPI_COMPLEX, COMM, IERR ) OPASSW = OPASSW + LREQA IF (KEEP(60).EQ.0) THEN CALL CMUMPS_ASS_ROOT( root, roota, KEEP(50), & NBROWS_PACKET, NSUBSET_COL_EFF, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NBROWS_PACKET + 1 ), & NSUPCOL_EFF, & A( IPTRLU + 1_8 ), & A( POS_ROOT ), LOCAL_M, LOCAL_N, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & 0) ELSE CALL CMUMPS_ASS_ROOT( root, roota, KEEP(50), & NBROWS_PACKET, NSUBSET_COL_EFF, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NBROWS_PACKET + 1 ), & NSUPCOL_EFF, & A( IPTRLU + 1_8 ), & roota%SCHUR_POINTER(1), & root%SCHUR_LLD , root%SCHUR_NLOC, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & 0) ENDIF IWPOSCB = IWPOSCB + LREQI IPTRLU = IPTRLU + LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) ENDIF RETURN END SUBROUTINE CMUMPS_PROCESS_CONTRIB_TYPE3 MUMPS_5.8.1/src/csol_omp_m.F0000664000175000017500000004742615042446440015503 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_SOL_L0OMP_M CONTAINS SUBROUTINE CMUMPS_SOL_L0OMP_R(N, MTYPE, & NRHS, LIW, IW, PTRICB, RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & STEP, FRERE, DAD, FILS, NSTK, PTRIST, PTRFAC, INFO, & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF, & COMM, MYID, & BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, & FROM_PP, & NBROOT_UNDER_L0, LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS, & DO_PRUN, TO_PROCESS ) USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_L0OMPFAC_T !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT( in ) :: N, MTYPE, NRHS, SLAVEF, LIW INTEGER, INTENT( in ) :: IW(LIW) INTEGER :: INFO( 80 ), KEEP(500) INTEGER(8) :: KEEP8(150) REAL :: DKEEP(230) INTEGER, INTENT( in ) :: PROCNODE_STEPS( KEEP(28) ) INTEGER :: PTRICB( KEEP(28) ) INTEGER, INTENT( in ) :: POSINRHSINTR_FWD(N), LRHSINTR COMPLEX, INTENT(inout):: RHSINTR(LRHSINTR,NRHS) INTEGER, INTENT( in ) :: STEP(N), FRERE( KEEP(28) ), FILS( N ), & DAD( KEEP(28) ) INTEGER, INTENT( inout ) :: NSTK(KEEP(28)) INTEGER, INTENT( in ) :: PTRIST(KEEP(28)) INTEGER(8), INTENT( in ) :: PTRFAC(KEEP(28)) INTEGER, INTENT( IN ) :: COMM, MYID INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES INTEGER :: BUFR(LBUFR) INTEGER(8), INTENT(IN) :: LRHS_ROOT COMPLEX :: RHS_ROOT(LRHS_ROOT) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) LOGICAL, INTENT( in ) :: DO_NBSPARSE INTEGER, INTENT( in ) :: LRHS_BOUNDS INTEGER, INTENT( in ) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, INTENT( in ) :: FROM_PP INTEGER, INTENT( out ):: NBROOT_UNDER_L0 INTEGER, INTENT( in ) :: LPOOL_B_L0_OMP INTEGER, INTENT( in ) :: IPOOL_B_L0_OMP & ( LPOOL_B_L0_OMP ) INTEGER, INTENT( in ) :: L_PHYS_L0_OMP INTEGER, INTENT( in ) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT( in ) :: L_VIRT_L0_OMP INTEGER, INTENT( in ) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT( in ) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT( in ) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT( in ) :: LL0_OMP_MAPPING INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INTEGER, INTENT( in ) :: LL0_OMP_FACTORS LOGICAL, INTENT( in ) :: DO_PRUN LOGICAL, INTENT( in ) :: TO_PROCESS( KEEP(28) ) TYPE (CMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER :: LASTFSSBTRSTA_P, LASTFSSBTRDYN_P INTEGER :: THREAD_ID, IL0OMPFAC INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOOL_P INTEGER, ALLOCATABLE, DIMENSION(:) :: IWCB_P COMPLEX, ALLOCATABLE, DIMENSION(:) :: WCB_P INTEGER :: LPOOL_P, LEAF_P, LIWCB_P INTEGER(8) :: LWCB_P INTEGER(8) :: POSWCB_P, PLEFTWCB_P INTEGER :: POSIWCB_P LOGICAL :: IS_INODE_PROCESSED_P LOGICAL :: ERROR_WAS_BROADCASTED_P INTEGER :: INFO_P(2), allocok INTEGER :: I, VIRTUAL_TASK, PHYSICAL_TASK INTEGER :: INODE, IFATH, IROOT_SBTR INTEGER :: NBROOT_PROCESSED INTEGER :: NEXT_TASK_DYN !$ INTEGER :: NOMP_SAVE INTEGER :: NBFIN_DUMMY !$ INTEGER :: NOMP_TOTAL !$ INTEGER :: NOMP_INNER !$ LOGICAL :: SAVE_NESTED NBFIN_DUMMY = huge(NBFIN_DUMMY) NBROOT_PROCESSED = 0 PTRICB = 0 !$ NOMP_INNER = 1 !$ IF (KEEP(369).GT.0) THEN !$ NOMP_TOTAL = omp_get_max_threads() !$ IF (NOMP_TOTAL .NE. KEEP(400)) THEN !$ IF (KEEP(439) .GT. 1) THEN !$ NOMP_INNER = KEEP(439) !$ ELSE IF ( KEEP(439) .EQ. -1 !$ & ) THEN !$ NOMP_INNER = NOMP_TOTAL / KEEP(400) !$ ENDIF !$ ENDIF !$ IF (NOMP_INNER .GT. 1) THEN !$ SAVE_NESTED = omp_get_nested() !$ CALL OMP_SET_NESTED(.TRUE.) !$ ENDIF #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(KEEP(400),4)) #else !$ CALL omp_set_num_threads(KEEP(400)) #endif !$ ENDIF NEXT_TASK_DYN = KEEP(400)+1 !$OMP PARALLEL !$OMP& SHARED ( NEXT_TASK_DYN, IPOOL_B_L0_OMP, !$OMP& LPOOL_B_L0_OMP, NBFIN_DUMMY ) !$OMP& PRIVATE ( THREAD_ID, IL0OMPFAC, VIRTUAL_TASK, PHYSICAL_TASK, !$OMP& IPOOL_P, LPOOL_P, LEAF_P, !$OMP& LIWCB_P, LWCB_P, IWCB_P, WCB_P, !$OMP& PLEFTWCB_P, POSWCB_P, POSIWCB_P, !$OMP& LASTFSSBTRSTA_P, LASTFSSBTRDYN_P, !$OMP& INODE, IROOT_SBTR, IFATH, !$OMP& IS_INODE_PROCESSED_P, !$OMP& INFO_P, ERROR_WAS_BROADCASTED_P, NOMP_SAVE, allocok ) !$OMP& REDUCTION( + : NBROOT_PROCESSED ) !$ NOMP_SAVE = omp_get_max_threads() THREAD_ID = 1 !$ THREAD_ID = OMP_GET_THREAD_NUM() + 1 !$OMP BARRIER !$ CALL omp_set_num_threads(NOMP_INNER) LPOOL_P = LPOOL_B_L0_OMP INFO_P(1:2) = 0 LWCB_P = int(KEEP(133),8)*int(NRHS,8) LIWCB_P = KEEP(133) PLEFTWCB_P = 1_8 POSWCB_P = LWCB_P POSIWCB_P = LIWCB_P ALLOCATE(IPOOL_P(LPOOL_P), IWCB_P(LIWCB_P), WCB_P( LWCB_P), & stat=allocok) IF ( allocok > 0 ) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4(LPOOL_P + LIWCB_P + LWCB_P, & INFO(2)) !$OMP CRITICAL(critical_info) INFO(1) = -13 INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ENDIF !$OMP BARRIER IF (INFO(1) .LT. 0) THEN GOTO 50 ENDIF VIRTUAL_TASK = THREAD_ID 600 CONTINUE IF (VIRTUAL_TASK .LT. L_VIRT_L0_OMP) THEN DO PHYSICAL_TASK = VIRT_L0_OMP( VIRTUAL_TASK ), & VIRT_L0_OMP ( VIRTUAL_TASK + 1 ) - 1 LEAF_P = 1 DO I = PTR_LEAFS_L0_OMP( PERM_L0_OMP( PHYSICAL_TASK )+1 )+1, & PTR_LEAFS_L0_OMP( PERM_L0_OMP( PHYSICAL_TASK ) ) IF ( IPOOL_B_L0_OMP(I) .GT. 0 ) THEN IPOOL_P(LEAF_P) = IPOOL_B_L0_OMP(I) LEAF_P = LEAF_P + 1 ENDIF ENDDO IF ( LEAF_P .EQ. 1 ) THEN WRITE(*,*) " Internal error 1 in CMUMPS_SOL_L0OMP_R", & LEAF_P ENDIF IROOT_SBTR = PHYS_L0_OMP( PERM_L0_OMP( PHYSICAL_TASK )) IF (DO_PRUN) THEN IF (.NOT. TO_PROCESS(STEP(IROOT_SBTR))) THEN CYCLE ENDIF ENDIF INODE = IROOT_SBTR DO WHILE (INODE .GT. 0) LASTFSSBTRSTA_P = INODE INODE=FILS(INODE) ENDDO CALL MUMPS_COMPUTE_LASTFS_DYN( IROOT_SBTR, LASTFSSBTRDYN_P, & MTYPE, KEEP, IW, LIW, N, STEP, PTRIST, FILS, FRERE ) DO WHILE (LEAF_P .NE.1 .AND. INFO_P(1) .GE. 0) LEAF_P = LEAF_P - 1 INODE = IPOOL_P(LEAF_P) IFATH = DAD(STEP(INODE) ) IL0OMPFAC = L0_OMP_MAPPING(STEP(INODE)) IF (IL0OMPFAC .NE. THREAD_ID) THEN ENDIF IF (DO_PRUN) THEN IS_INODE_PROCESSED_P = TO_PROCESS(STEP(INODE)) ELSE IS_INODE_PROCESSED_P = .TRUE. ENDIF IF ( IS_INODE_PROCESSED_P ) THEN CALL CMUMPS_SOLVE_NODE_FWD( INODE, & LASTFSSBTRSTA_P, LASTFSSBTRDYN_P, & BUFR, LBUFR, LBUFR_BYTES, MYID, SLAVEF, COMM, & N, IPOOL_P, LPOOL_P, LEAF_P, NBFIN_DUMMY, NSTK, & IWCB_P, LIWCB_P, WCB_P, LWCB_P, & L0_OMP_FACTORS(IL0OMPFAC)%A(1), & L0_OMP_FACTORS(IL0OMPFAC)%LA, & IW, LIW, & NRHS, POSWCB_P, PLEFTWCB_P, POSIWCB_P, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, INFO_P, KEEP, KEEP8, DKEEP, & RHS_ROOT, LRHS_ROOT, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED_P ) IF (INFO_P(1) .LT. 0) THEN !$OMP CRITICAL(critical_info) INFO(1) = INFO_P(1) INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 50 IF (ERROR_WAS_BROADCASTED_P) THEN WRITE(*,*) " Internal error 2 in CMUMPS_SOL_L0OMP_R", & ERROR_WAS_BROADCASTED_P ENDIF ENDIF IF ( IFATH .EQ. 0 ) THEN IF ( IS_INODE_PROCESSED_P ) THEN NBROOT_PROCESSED = NBROOT_PROCESSED + 1 ENDIF ELSE PTRICB(STEP(INODE)) = 0 IF (IFATH .NE. 0) THEN IF ( INODE .NE. IROOT_SBTR ) THEN IF ( IS_INODE_PROCESSED_P ) THEN NSTK(STEP(IFATH)) = NSTK(STEP(IFATH)) - 1 ENDIF IF (NSTK(STEP(IFATH)) .EQ. 0 .OR. & NSTK(STEP(IFATH)) .EQ. -1 ) THEN IPOOL_P( LEAF_P ) = IFATH LEAF_P = LEAF_P + 1 IF (DO_PRUN) THEN NSTK(STEP(IFATH)) = huge(NSTK(STEP(IFATH))) ENDIF ENDIF ELSE IF ( IS_INODE_PROCESSED_P ) THEN !$OMP ATOMIC UPDATE NSTK(STEP(IFATH)) = NSTK(STEP(IFATH)) - 1 !$OMP END ATOMIC ENDIF ENDIF ENDIF ENDIF ENDDO ENDDO !$OMP ATOMIC CAPTURE VIRTUAL_TASK = NEXT_TASK_DYN NEXT_TASK_DYN = NEXT_TASK_DYN + 1 !$OMP END ATOMIC GOTO 600 ENDIF 50 CONTINUE IF (allocated(IPOOL_P)) DEALLOCATE(IPOOL_P) IF (allocated(IWCB_P)) DEALLOCATE(IWCB_P) IF (allocated(WCB_P)) DEALLOCATE(WCB_P) #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_SAVE,4)) #else !$ CALL omp_set_num_threads(NOMP_SAVE) #endif !$OMP END PARALLEL !$ IF (KEEP(369).GT.0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_TOTAL),4)) #else !$ CALL omp_set_num_threads(NOMP_TOTAL) #endif !$ IF (NOMP_INNER .GT. 1) THEN !$ CALL OMP_SET_NESTED(SAVE_NESTED) !$ ENDIF !$ ENDIF NBROOT_UNDER_L0 = NBROOT_PROCESSED RETURN END SUBROUTINE CMUMPS_SOL_L0OMP_R SUBROUTINE CMUMPS_SOL_L0OMP_S(N, MTYPE, NRHS, LIW, IW, & PTRICB, PTRACB, RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & STEP, FRERE, FILS, NE_STEPS, PTRIST, PTRFAC, INFO, & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, RHS_ROOT, LRHS_ROOT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP, LPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS ) USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_L0OMPFAC_T USE OMP_LIB IMPLICIT NONE INTEGER, INTENT( in ) :: N, MTYPE, NRHS, SLAVEF, LIW INTEGER, INTENT( in ) :: IW(LIW) INTEGER :: INFO( 80 ), KEEP(500) INTEGER(8) :: KEEP8(150) REAL :: DKEEP(230) INTEGER, INTENT( in ) :: PROCNODE_STEPS( KEEP(28) ) INTEGER :: PTRICB( KEEP(28) ) INTEGER(8) :: PTRACB( KEEP(28) ) INTEGER, INTENT( in ) :: POSINRHSINTR_BWD(N), LRHSINTR COMPLEX, INTENT(inout):: RHSINTR(LRHSINTR,NRHS) INTEGER, INTENT( in ) :: STEP(N), FRERE( KEEP(28) ), FILS( N ) INTEGER, INTENT( inout ) :: NE_STEPS(KEEP(28)) INTEGER, INTENT( in ) :: PTRIST(KEEP(28)) INTEGER(8), INTENT( in ) :: PTRFAC(KEEP(28)) INTEGER, INTENT( IN ) :: COMM, MYID INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES INTEGER :: BUFR(LBUFR) INTEGER(8), INTENT(IN) :: LRHS_ROOT COMPLEX :: RHS_ROOT(LRHS_ROOT) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER :: LPANEL_POS INTEGER :: PANEL_POS(LPANEL_POS) LOGICAL, INTENT( in ) :: DO_NBSPARSE INTEGER, INTENT( in ) :: LRHS_BOUNDS INTEGER, INTENT( in ) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, INTENT( in ) :: PRUN_BELOW_BWD INTEGER, INTENT( in ) :: SIZE_TO_PROCESS LOGICAL, INTENT( in ) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, INTENT( in ) :: FROM_PP INTEGER, INTENT( in ) :: LPOOL_B_L0_OMP INTEGER, INTENT( in ) :: L_PHYS_L0_OMP INTEGER, INTENT( in ) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT( in ) :: L_VIRT_L0_OMP INTEGER, INTENT( in ) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT( in ) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT( in ) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT( in ) :: LL0_OMP_MAPPING INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INTEGER, INTENT( in ) :: LL0_OMP_FACTORS TYPE (CMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER :: THREAD_ID, IL0OMPFAC INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOOL_P INTEGER, ALLOCATABLE, DIMENSION(:) :: IWCB_P COMPLEX, ALLOCATABLE, DIMENSION(:) :: WCB_P COMPLEX, ALLOCATABLE, DIMENSION(:) :: W2_P INTEGER, ALLOCATABLE, DIMENSION(:) :: PANEL_POS_P INTEGER :: LPOOL_P, IIPOOL_P, LIWCB_P, LPANEL_POS_P INTEGER :: MYLEAF_LEFT_HUGE_P INTEGER(8) :: LWCB_P INTEGER(8) :: POSWCB_P, PLEFTWCB_P INTEGER :: POSIWCB_P LOGICAL :: DO_MCAST2_TERMBWD_P LOGICAL :: ERROR_WAS_BROADCASTED_P INTEGER :: INFO_P(2), allocok INTEGER :: VIRTUAL_TASK, PHYSICAL_TASK INTEGER :: INODE INTEGER :: NEXT_TASK_DYN !$ INTEGER :: NOMP_SAVE INTEGER :: NBFIN_DUMMY LOGICAL, ALLOCATABLE, DIMENSION(:) :: DEJA_SEND_DUMMY !$ INTEGER :: NOMP_TOTAL NBFIN_DUMMY = huge(NBFIN_DUMMY) ALLOCATE(DEJA_SEND_DUMMY( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of DEJA_SEND_DUMMY in ' & //'routine CMUMPS_SOL_S ' INFO(1)=-13 INFO(2)=SLAVEF GOTO 100 endif !$ IF (KEEP(369).GT.0) THEN !$ NOMP_TOTAL = omp_get_max_threads() #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(KEEP(400),4)) #else !$ CALL omp_set_num_threads(KEEP(400)) #endif !$ ENDIF PTRICB = 0 NEXT_TASK_DYN = KEEP(400)+1 !$OMP PARALLEL !$OMP& SHARED ( NEXT_TASK_DYN, LPOOL_B_L0_OMP, !$OMP& NBFIN_DUMMY, DEJA_SEND_DUMMY ) !$OMP& PRIVATE ( THREAD_ID, IL0OMPFAC, VIRTUAL_TASK, PHYSICAL_TASK, !$OMP& IPOOL_P, LPOOL_P, IIPOOL_P, MYLEAF_LEFT_HUGE_P, !$OMP& LIWCB_P, LWCB_P, IWCB_P, WCB_P, W2_P, LPANEL_POS_P, !$OMP& PANEL_POS_P, !$OMP& PLEFTWCB_P, POSWCB_P, POSIWCB_P, !$OMP& INODE, !$OMP& INFO_P, DO_MCAST2_TERMBWD_P, !$OMP& ERROR_WAS_BROADCASTED_P, NOMP_SAVE, allocok ) !$ NOMP_SAVE = omp_get_max_threads() THREAD_ID = 1 !$ THREAD_ID = OMP_GET_THREAD_NUM() + 1 !$OMP BARRIER !$ CALL omp_set_num_threads(1) LPOOL_P = LPOOL_B_L0_OMP INFO_P(1:2) = 0 LWCB_P = int(KEEP(133),8)*int(NRHS,8) LIWCB_P = KEEP(133) PLEFTWCB_P = 1_8 POSWCB_P = LWCB_P POSIWCB_P = LIWCB_P IF (KEEP(201).EQ.1) THEN LPANEL_POS_P = KEEP(228)+1 CALL MUMPS_ABORT() ELSE LPANEL_POS_P = 1 ENDIF ALLOCATE(IPOOL_P(LPOOL_P), IWCB_P(LIWCB_P), WCB_P( LWCB_P), & W2_P(KEEP(133)), PANEL_POS_P(LPANEL_POS_P), stat=allocok) IF ( allocok > 0 ) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4(LPOOL_P + LIWCB_P + LWCB_P + & KEEP(133)+LPANEL_POS_P, INFO(2)) !$OMP CRITICAL(critical_info) INFO(1) = -13 INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ENDIF !$OMP BARRIER IF (INFO(1) .LT. 0) THEN GOTO 50 ENDIF VIRTUAL_TASK = THREAD_ID 600 CONTINUE IF (VIRTUAL_TASK .LT. L_VIRT_L0_OMP) THEN DO PHYSICAL_TASK = VIRT_L0_OMP( VIRTUAL_TASK ), & VIRT_L0_OMP ( VIRTUAL_TASK + 1 ) - 1 INODE = PHYS_L0_OMP( PERM_L0_OMP( PHYSICAL_TASK ) ) IPOOL_P(1) = INODE IIPOOL_P = 2 MYLEAF_LEFT_HUGE_P = huge(MYLEAF_LEFT_HUGE_P) IF ( PRUN_BELOW_BWD ) THEN IF ( .NOT. TO_PROCESS(STEP(INODE)) ) THEN CYCLE ENDIF ENDIF DO WHILE (IIPOOL_P .NE.1 .AND. INFO_P(1) .GE. 0) IIPOOL_P = IIPOOL_P - 1 INODE = IPOOL_P(IIPOOL_P) IL0OMPFAC = L0_OMP_MAPPING(STEP(INODE)) IF (IL0OMPFAC .NE. THREAD_ID) THEN ENDIF CALL CMUMPS_SOLVE_NODE_BWD( INODE, N, IPOOL_P, LPOOL_P, & IIPOOL_P, NBFIN_DUMMY, L0_OMP_FACTORS(IL0OMPFAC)%A(1), & L0_OMP_FACTORS(IL0OMPFAC)%LA, IW, LIW, & WCB_P, LWCB_P, NRHS, POSWCB_P, PLEFTWCB_P, POSIWCB_P, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PTRICB, PTRACB, IWCB_P, LIWCB_P, W2_P, NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, MYLEAF_LEFT_HUGE_P, INFO_P, & PROCNODE_STEPS, & DEJA_SEND_DUMMY, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP, KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS_P, LPANEL_POS_P, & PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED_P & , DO_MCAST2_TERMBWD_P & ) IF (INFO_P(1) .LT. 0) THEN !$OMP CRITICAL(critical_info) INFO(1) = INFO_P(1) INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 50 IF (ERROR_WAS_BROADCASTED_P) THEN WRITE(*,*) " Internal error 1 in CMUMPS_SOL_L0OMP_R", & ERROR_WAS_BROADCASTED_P ENDIF IF (DO_MCAST2_TERMBWD_P) THEN WRITE(*,*) " Internal error 2 in CMUMPS_SOL_L0OMP_R", & DO_MCAST2_TERMBWD_P ENDIF ENDDO ENDDO !$OMP ATOMIC CAPTURE VIRTUAL_TASK = NEXT_TASK_DYN NEXT_TASK_DYN = NEXT_TASK_DYN + 1 !$OMP END ATOMIC GOTO 600 ENDIF 50 CONTINUE IF (allocated(IPOOL_P)) DEALLOCATE(IPOOL_P) IF (allocated(IWCB_P)) DEALLOCATE(IWCB_P) IF (allocated(WCB_P)) DEALLOCATE(WCB_P) IF (allocated(W2_P)) DEALLOCATE(W2_P) IF (allocated(PANEL_POS_P)) DEALLOCATE(PANEL_POS_P) #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_SAVE,4)) #else !$ CALL omp_set_num_threads(NOMP_SAVE) #endif !$OMP END PARALLEL !$ IF (KEEP(369).GT.0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_TOTAL),4)) #else !$ CALL omp_set_num_threads(NOMP_TOTAL) #endif !$ ENDIF 100 CONTINUE IF (allocated(DEJA_SEND_DUMMY)) DEALLOCATE(DEJA_SEND_DUMMY) RETURN END SUBROUTINE CMUMPS_SOL_L0OMP_S END MODULE CMUMPS_SOL_L0OMP_M MUMPS_5.8.1/src/smumps_f77.F0000664000175000017500000004375315042446437015370 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, NBLK, ICNTL, & CNTL, KEEP, DKEEP, KEEP8, NZ, NNZ, IRN, IRNhere, JCN, & JCNhere, A, Ahere, NZ_loc, NNZ_loc, IRN_loc, IRN_lochere, & JCN_loc, JCN_lochere, A_loc, A_lochere, NELT, ELTPTR, & ELTPTRhere, ELTVAR, ELTVARhere, A_ELT, A_ELThere, & BLKPTR, BLKPTRhere, BLKVAR, BLKVARhere, PERM_IN, PERM_INhere, & ROWIND, ROWINDhere, COLIND, COLINDhere, PIVOTS, PIVOTShere, & RHS, RHShere, REDRHS, REDRHShere, & INFO, RINFO, INFOG, RINFOG, DEFICIENCY, LWK_USER, & SIZE_SCHUR, LISTVAR_SCHUR, LISTVAR_SCHURhere, SCHUR, & SCHURhere, WK_USER, WK_USERhere, COLSCA, COLSCAhere, & ROWSCA, ROWSCAhere, INSTANCE_NUMBER, NRHS, LRHS, LREDRHS, & RHS_SPARSE, RHS_SPARSEhere, SOL_loc, SOL_lochere, & RHS_loc, RHS_lochere, & IRHS_SPARSE, IRHS_SPARSEhere, IRHS_PTR, IRHS_PTRhere, & ISOL_loc, ISOL_lochere, IRHS_loc, IRHS_lochere, NZ_RHS, & LSOL_loc, LRHS_loc, NSOL_loc, Nloc_RHS, & SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD, & MBLOCK, NBLOCK, NPROW, NPCOL, LD_RHSINTR, & OOC_TMPDIR, OOC_PREFIX, WRITE_PROBLEM, #if ! defined(NO_SAVE_RESTORE) & SAVE_DIR, SAVE_PREFIX, #endif & TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN, #if ! defined(NO_SAVE_RESTORE) & SAVE_DIRLEN, SAVE_PREFIXLEN, #endif & METIS_OPTIONS & ) USE SMUMPS_STRUC_DEF IMPLICIT NONE INTEGER OOC_PREFIX_MAX_LENGTH, OOC_TMPDIR_MAX_LENGTH INTEGER PB_MAX_LENGTH PARAMETER(OOC_PREFIX_MAX_LENGTH=255, OOC_TMPDIR_MAX_LENGTH=1023) PARAMETER(PB_MAX_LENGTH=1023) #if ! defined(NO_SAVE_RESTORE) INTEGER, PARAMETER :: SAVE_DIR_MAX_LENGTH = 1023 INTEGER, PARAMETER :: SAVE_PREFIX_MAX_LENGTH = 255 #endif INTEGER JOB, SYM, PAR, COMM_F77, N, NBLK, NZ, NZ_loc, NELT, & DEFICIENCY, LWK_USER, SIZE_SCHUR, INSTANCE_NUMBER, & NRHS, LRHS, & NZ_RHS, LSOL_loc,Nloc_RHS, LRHS_loc, NSOL_loc, LREDRHS INTEGER(8) :: NNZ, NNZ_loc INTEGER ICNTL(60), INFO(80), INFOG(80), KEEP(500) INTEGER SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER MBLOCK, NBLOCK, NPROW, NPCOL INTEGER LD_RHSINTR INTEGER TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN REAL CNTL(15), RINFO(40), RINFOG(40), DKEEP(230) INTEGER(8) KEEP8(150) INTEGER, TARGET :: IRN(*), JCN(*), ELTPTR(*), ELTVAR(*) INTEGER, TARGET :: PERM_IN(*), IRN_loc(*), JCN_loc(*) INTEGER, TARGET :: LISTVAR_SCHUR(*) INTEGER, TARGET :: IRHS_PTR(*), IRHS_SPARSE(*) INTEGER, TARGET :: ISOL_loc(*), IRHS_loc(*) INTEGER, TARGET :: BLKPTR(*), BLKVAR(*) REAL, TARGET :: A(*), A_ELT(*), A_loc(*), RHS(*) INTEGER, TARGET :: ROWIND(*), COLIND(*) REAL, TARGET :: PIVOTS(*) REAL, TARGET :: WK_USER(*) REAL, TARGET :: REDRHS(*) REAL, TARGET :: ROWSCA(*), COLSCA(*) REAL, TARGET :: SCHUR(*) REAL, TARGET :: RHS_SPARSE(*), SOL_loc(*), RHS_loc(*) INTEGER, INTENT(inout) :: OOC_TMPDIR(OOC_TMPDIR_MAX_LENGTH) INTEGER, INTENT(inout) :: OOC_PREFIX(OOC_PREFIX_MAX_LENGTH) INTEGER, INTENT(in) :: WRITE_PROBLEM(PB_MAX_LENGTH) #if ! defined(NO_SAVE_RESTORE) INTEGER SAVE_DIRLEN, SAVE_PREFIXLEN INTEGER, INTENT(in) :: SAVE_DIR(SAVE_DIR_MAX_LENGTH) INTEGER, INTENT(in) :: SAVE_PREFIX(SAVE_PREFIX_MAX_LENGTH) #endif INTEGER METIS_OPTIONS(40) INTEGER IRNhere, JCNhere, Ahere, ELTPTRhere, ELTVARhere, & A_ELThere, BLKPTRhere, BLKVARhere, PERM_INhere, & WK_USERhere, ROWINDhere, COLINDhere, PIVOTShere, & RHShere, REDRHShere, IRN_lochere, & JCN_lochere, A_lochere, LISTVAR_SCHURhere, & SCHURhere, COLSCAhere, ROWSCAhere, RHS_SPARSEhere, & SOL_lochere, RHS_lochere, IRHS_PTRhere, IRHS_SPARSEhere, & ISOL_lochere, IRHS_lochere INCLUDE 'mpif.h' TYPE SMUMPS_STRUC_PTR TYPE (SMUMPS_STRUC), POINTER :: PTR END TYPE SMUMPS_STRUC_PTR TYPE (SMUMPS_STRUC), POINTER :: mumps_par TYPE (SMUMPS_STRUC_PTR), DIMENSION (:), POINTER, SAVE :: & mumps_par_array TYPE (SMUMPS_STRUC_PTR), DIMENSION (:), POINTER :: & mumps_par_array_bis INTEGER, SAVE :: SMUMPS_STRUC_ARRAY_SIZE = 0 INTEGER, SAVE :: N_INSTANCES = 0 INTEGER I, Np, IERR INTEGER(8) :: A_ELT_SIZE, NNZ_i INTEGER SMUMPS_STRUC_ARRAY_SIZE_INIT PARAMETER (SMUMPS_STRUC_ARRAY_SIZE_INIT=10) EXTERNAL MUMPS_ASSIGN_MAPPING, & MUMPS_ASSIGN_PIVNUL_LIST, & MUMPS_ASSIGN_SYM_PERM, & MUMPS_ASSIGN_UNS_PERM, & MUMPS_ASSIGN_GLOB2LOC_RHS, & MUMPS_ASSIGN_GLOB2LOC_SOL EXTERNAL MUMPS_NULLIFY_C_MAPPING, & MUMPS_NULLIFY_C_PIVNUL_LIST, & MUMPS_NULLIFY_C_SYM_PERM, & MUMPS_NULLIFY_C_UNS_PERM, & MUMPS_NULLIFY_C_GLOB2LOC_RHS, & MUMPS_NULLIFY_C_GLOB2LOC_SOL EXTERNAL SMUMPS_ASSIGN_COLSCA, & SMUMPS_ASSIGN_ROWSCA, & SMUMPS_ASSIGN_ROWSCA_LOC, & SMUMPS_ASSIGN_COLSCA_LOC, & SMUMPS_ASSIGN_RHSINTR, & SMUMPS_ASSIGN_SINGULAR_VALUES EXTERNAL SMUMPS_NULLIFY_C_COLSCA, & SMUMPS_NULLIFY_C_ROWSCA, & SMUMPS_NULLIFY_C_ROWSCA_LOC, & SMUMPS_NULLIFY_C_COLSCA_LOC, & SMUMPS_NULLIFY_C_RHSINTR, & SMUMPS_NULLIFY_C_SING_VALUES IF (JOB == -1) THEN DO I = 1, SMUMPS_STRUC_ARRAY_SIZE IF ( .NOT. associated(mumps_par_array(I)%PTR) ) GOTO 10 END DO ALLOCATE( mumps_par_array_bis(SMUMPS_STRUC_ARRAY_SIZE + & SMUMPS_STRUC_ARRAY_SIZE_INIT), stat=IERR) IF (IERR /= 0) THEN WRITE(*,*) ' ** Allocation Error 1 in SMUMPS_F77.' CALL MUMPS_ABORT() END IF DO I = 1, SMUMPS_STRUC_ARRAY_SIZE mumps_par_array_bis(I)%PTR=>mumps_par_array(I)%PTR ENDDO IF (associated(mumps_par_array)) DEALLOCATE(mumps_par_array) mumps_par_array=>mumps_par_array_bis NULLIFY(mumps_par_array_bis) DO I = SMUMPS_STRUC_ARRAY_SIZE+1, SMUMPS_STRUC_ARRAY_SIZE + & SMUMPS_STRUC_ARRAY_SIZE_INIT NULLIFY(mumps_par_array(I)%PTR) ENDDO I = SMUMPS_STRUC_ARRAY_SIZE+1 SMUMPS_STRUC_ARRAY_SIZE = SMUMPS_STRUC_ARRAY_SIZE + & SMUMPS_STRUC_ARRAY_SIZE_INIT 10 CONTINUE INSTANCE_NUMBER = I N_INSTANCES = N_INSTANCES+1 ALLOCATE( mumps_par_array(INSTANCE_NUMBER)%PTR,stat=IERR ) IF (IERR /= 0) THEN WRITE(*,*) '** Allocation Error 2 in SMUMPS_F77.' CALL MUMPS_ABORT() ENDIF ICNTL(1:60) = 0 CNTL(1:15) = 0.0E0 KEEP(1:500) = 0 DKEEP(1:230) = 0.0E0 KEEP8(1:150) = 0_8 METIS_OPTIONS(1:40) = 0 mumps_par_array(INSTANCE_NUMBER)%PTR%INSTANCE_NUMBER = & INSTANCE_NUMBER END IF IF ( INSTANCE_NUMBER .LE. 0 .OR. INSTANCE_NUMBER .GT. & SMUMPS_STRUC_ARRAY_SIZE ) THEN WRITE(*,*) ' ** Instance Error 1 in SMUMPS_F77', & INSTANCE_NUMBER CALL MUMPS_ABORT() END IF IF ( .NOT. associated ( mumps_par_array(INSTANCE_NUMBER)%PTR ) ) & THEN WRITE(*,*) ' Instance Error 2 in SMUMPS_F77', & INSTANCE_NUMBER CALL MUMPS_ABORT() END IF mumps_par => mumps_par_array(INSTANCE_NUMBER)%PTR mumps_par%SYM = SYM mumps_par%PAR = PAR mumps_par%JOB = JOB mumps_par%N = N mumps_par%NBLK = NBLK mumps_par%NZ = NZ mumps_par%NNZ = NNZ mumps_par%NZ_loc = NZ_loc mumps_par%NNZ_loc = NNZ_loc mumps_par%LWK_USER = LWK_USER mumps_par%SIZE_SCHUR = SIZE_SCHUR mumps_par%NELT= NELT mumps_par%ICNTL(1:60)=ICNTL(1:60) mumps_par%CNTL(1:15)=CNTL(1:15) mumps_par%KEEP(1:500)=KEEP(1:500) mumps_par%DKEEP(1:230)=DKEEP(1:230) mumps_par%KEEP8(1:150)=KEEP8(1:150) CALL MUMPS_ADDR_C( ICNTL(50), mumps_par%KEEP8(83) ) CALL MUMPS_ADDR_C( RINFO(3), mumps_par%KEEP8(84) ) mumps_par%METIS_OPTIONS(1:40)=METIS_OPTIONS(1:40) mumps_par%NRHS = NRHS mumps_par%LRHS = LRHS mumps_par%LREDRHS = LREDRHS mumps_par%NZ_RHS = NZ_RHS mumps_par%LSOL_loc = LSOL_loc mumps_par%Nloc_RHS = Nloc_RHS mumps_par%LRHS_loc = LRHS_loc mumps_par%NSOL_loc = NSOL_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 mumps_par%LD_RHSINTR = LD_RHSINTR IF ( COMM_F77 .NE. -987654 ) THEN mumps_par%COMM = COMM_F77 ELSE mumps_par%COMM = MPI_COMM_WORLD ENDIF CALL MPI_BCAST(NRHS,1,MPI_INTEGER,0,mumps_par%COMM,IERR) CALL MUMPS_GET_NNZ_INTERNAL(NNZ,NZ,NNZ_i) IF ( IRNhere /= 0 ) mumps_par%IRN => IRN(1:NNZ_i) IF ( JCNhere /= 0 ) mumps_par%JCN => JCN(1:NNZ_i) IF ( Ahere /= 0 ) mumps_par%A => A(1:NNZ_i) CALL MUMPS_GET_NNZ_INTERNAL(NNZ_loc,NZ_loc,NNZ_i) IF ( IRN_lochere /= 0 ) mumps_par%IRN_loc => IRN_loc(1:NNZ_i) IF ( JCN_lochere /= 0 ) mumps_par%JCN_loc => JCN_loc(1:NNZ_i) IF ( A_lochere /= 0 ) mumps_par%A_loc => A_loc(1:NNZ_i) IF ( ELTPTRhere /= 0 ) mumps_par%ELTPTR => ELTPTR(1:NELT+1) IF ( ELTVARhere /= 0 ) mumps_par%ELTVAR => & ELTVAR(1:ELTPTR(NELT+1)-1) IF ( A_ELThere /= 0 ) THEN A_ELT_SIZE = 0_8 DO I = 1, NELT Np = ELTPTR(I+1) -ELTPTR(I) IF (SYM == 0) THEN A_ELT_SIZE = A_ELT_SIZE + Np * Np ELSE A_ELT_SIZE = A_ELT_SIZE + Np * ( Np + 1 ) / 2 END IF END DO mumps_par%A_ELT => A_ELT(1_8:A_ELT_SIZE) END IF IF ( BLKPTRhere /= 0 ) mumps_par%BLKPTR => BLKPTR(1:NBLK+1) IF ( BLKVARhere /= 0 ) mumps_par%BLKVAR => BLKVAR(1:N) IF ( PERM_INhere /= 0) mumps_par%PERM_IN => PERM_IN(1:N) IF ( LISTVAR_SCHURhere /= 0) & mumps_par%LISTVAR_SCHUR =>LISTVAR_SCHUR(1:SIZE_SCHUR) IF ( SCHURhere /= 0 ) THEN mumps_par%SCHUR_CINTERFACE=>SCHUR(1:1) ENDIF IF (ROWINDhere /= 0) THEN mumps_par%ROWIND => ROWIND(1:KEEP(89)) ENDIF IF (COLINDhere /= 0) THEN mumps_par%COLIND => COLIND(1:KEEP(89)) ENDIF IF (PIVOTShere /= 0) THEN IF (KEEP(50) .EQ.0 .OR.KEEP(50).EQ.1) THEN mumps_par%PIVOTS => PIVOTS(1:KEEP(89)) ELSE mumps_par%PIVOTS => PIVOTS(1_8: & int(KEEP(89),8)+int(KEEP(89),8)) ENDIF ENDIF IF (NRHS .NE. 1) THEN IF ( RHShere /= 0 ) mumps_par%RHS => & RHS(1_8:int(NRHS,8)*int(LRHS,8)) IF (REDRHShere /= 0)mumps_par%REDRHS=> & REDRHS(1_8:int(NRHS,8)*int(LREDRHS,8)) ELSE IF ( RHShere /= 0 ) mumps_par%RHS => RHS(1:N) IF (REDRHShere /= 0)mumps_par%REDRHS=>REDRHS(1:SIZE_SCHUR) ENDIF IF ( WK_USERhere /=0 ) THEN IF (LWK_USER > 0 ) THEN mumps_par%WK_USER => WK_USER(1:LWK_USER) ELSE mumps_par%WK_USER => WK_USER(1_8:-int(LWK_USER,8)*1000000_8) ENDIF ENDIF IF ( COLSCAhere /= 0) mumps_par%COLSCA => COLSCA(1:N) IF ( ROWSCAhere /= 0) mumps_par%ROWSCA => ROWSCA(1:N) IF ( RHS_SPARSEhere /=0 ) mumps_par%RHS_SPARSE=> & RHS_SPARSE(1:NZ_RHS) IF ( IRHS_SPARSEhere /=0 ) mumps_par%IRHS_SPARSE=> & IRHS_SPARSE(1:NZ_RHS) IF ( SOL_lochere /=0 ) mumps_par%SOL_loc=> & SOL_loc(1_8:int(LSOL_loc,8)*int(NRHS,8)) IF ( RHS_lochere /=0 ) mumps_par%RHS_loc=> & RHS_loc(1_8:int(LRHS_loc,8)*int(NRHS,8)) IF ( ISOL_lochere /=0 ) mumps_par%ISOL_loc=> & ISOL_loc(1:LSOL_loc) IF ( IRHS_lochere /=0 ) mumps_par%IRHS_loc=> & IRHS_loc(1:LRHS_loc) IF ( IRHS_PTRhere /=0 ) mumps_par%IRHS_PTR=> & IRHS_PTR(1:NRHS+1) DO I=1,TMPDIRLEN mumps_par%OOC_TMPDIR(I:I)=char(OOC_TMPDIR(I)) ENDDO DO I=TMPDIRLEN+1,OOC_TMPDIR_MAX_LENGTH mumps_par%OOC_TMPDIR(I:I)=' ' ENDDO DO I=1,PREFIXLEN mumps_par%OOC_PREFIX(I:I)=char(OOC_PREFIX(I)) ENDDO DO I=PREFIXLEN+1,OOC_PREFIX_MAX_LENGTH mumps_par%OOC_PREFIX(I:I)=' ' ENDDO DO I=1,WRITE_PROBLEMLEN mumps_par%WRITE_PROBLEM(I:I)=char(WRITE_PROBLEM(I)) ENDDO DO I=WRITE_PROBLEMLEN+1,PB_MAX_LENGTH mumps_par%WRITE_PROBLEM(I:I)=' ' ENDDO #if ! defined(NO_SAVE_RESTORE) DO I=1,SAVE_DIRLEN mumps_par%SAVE_DIR(I:I)=char(SAVE_DIR(I)) ENDDO DO I=SAVE_DIRLEN+1,SAVE_DIR_MAX_LENGTH mumps_par%SAVE_DIR(I:I)=' ' ENDDO DO I=1,SAVE_PREFIXLEN mumps_par%SAVE_PREFIX(I:I)=char(SAVE_PREFIX(I)) ENDDO DO I=SAVE_PREFIXLEN+1,SAVE_PREFIX_MAX_LENGTH mumps_par%SAVE_PREFIX(I:I)=' ' ENDDO #endif CALL SMUMPS( mumps_par ) INFO(1:80)=mumps_par%INFO(1:80) INFOG(1:80)=mumps_par%INFOG(1:80) RINFO(1:40)=mumps_par%RINFO(1:40) RINFOG(1:40)=mumps_par%RINFOG(1:40) ICNTL(1:60) = mumps_par%ICNTL(1:60) CNTL(1:15) = mumps_par%CNTL(1:15) KEEP(1:500) = mumps_par%KEEP(1:500) DKEEP(1:230) = mumps_par%DKEEP(1:230) KEEP8(1:150) = mumps_par%KEEP8(1:150) METIS_OPTIONS(1:40) = mumps_par%METIS_OPTIONS(1:40) SYM = mumps_par%SYM PAR = mumps_par%PAR JOB = mumps_par%JOB N = mumps_par%N NBLK = mumps_par%NBLK NZ = mumps_par%NZ NNZ = mumps_par%NNZ NRHS = mumps_par%NRHS LRHS = mumps_par%LRHS LREDRHS = mumps_par%LREDRHS NZ_loc = mumps_par%NZ_loc NNZ_loc = mumps_par%NNZ_loc NZ_RHS = mumps_par%NZ_RHS LSOL_loc = mumps_par%LSOL_loc Nloc_RHS = mumps_par%Nloc_RHS LRHS_loc = mumps_par%LRHS_loc NSOL_loc = mumps_par%NSOL_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 LD_RHSINTR = mumps_par%LD_RHSINTR IF ( associated (mumps_par%MAPPING) ) THEN CALL MUMPS_ASSIGN_MAPPING(mumps_par%MAPPING(1)) ELSE CALL MUMPS_NULLIFY_C_MAPPING() ENDIF IF ( associated (mumps_par%PIVNUL_LIST) ) THEN CALL MUMPS_ASSIGN_PIVNUL_LIST(mumps_par%PIVNUL_LIST(1)) ELSE CALL MUMPS_NULLIFY_C_PIVNUL_LIST() ENDIF IF ( associated (mumps_par%SINGULAR_VALUES) ) THEN CALL SMUMPS_ASSIGN_SINGULAR_VALUES( & mumps_par%SINGULAR_VALUES(1)) ELSE CALL SMUMPS_NULLIFY_C_SING_VALUES() ENDIF IF ( associated (mumps_par%SYM_PERM) ) THEN CALL MUMPS_ASSIGN_SYM_PERM(mumps_par%SYM_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_SYM_PERM() ENDIF IF ( associated (mumps_par%UNS_PERM) ) THEN CALL MUMPS_ASSIGN_UNS_PERM(mumps_par%UNS_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_UNS_PERM() ENDIF IF ( associated (mumps_par%COLSCA_loc) ) THEN CALL SMUMPS_ASSIGN_COLSCA_LOC(1) ELSE CALL SMUMPS_NULLIFY_C_COLSCA_LOC() ENDIF IF ( associated (mumps_par%ROWSCA_loc) ) THEN CALL SMUMPS_ASSIGN_ROWSCA_LOC(1) ELSE CALL SMUMPS_NULLIFY_C_ROWSCA_LOC() ENDIF IF (associated( mumps_par%COLSCA )) THEN CALL SMUMPS_ASSIGN_COLSCA(mumps_par%COLSCA(1)) ELSE CALL SMUMPS_NULLIFY_C_COLSCA() ENDIF IF (associated( mumps_par%ROWSCA )) THEN CALL SMUMPS_ASSIGN_ROWSCA(mumps_par%ROWSCA(1)) ELSE CALL SMUMPS_NULLIFY_C_ROWSCA() ENDIF IF (associated( mumps_par%RHSINTR )) THEN CALL SMUMPS_ASSIGN_RHSINTR(mumps_par%RHSINTR(1)) ELSE CALL SMUMPS_NULLIFY_C_RHSINTR() ENDIF IF (associated(mumps_par%GLOB2LOC_RHS)) THEN CALL MUMPS_ASSIGN_GLOB2LOC_RHS(mumps_par%GLOB2LOC_RHS(1)) ELSE CALL MUMPS_NULLIFY_C_GLOB2LOC_RHS() ENDIF IF (associated(mumps_par%GLOB2LOC_SOL)) THEN CALL MUMPS_ASSIGN_GLOB2LOC_SOL(mumps_par%GLOB2LOC_SOL(1)) ELSE CALL MUMPS_NULLIFY_C_GLOB2LOC_SOL() ENDIF TMPDIRLEN=len_trim(mumps_par%OOC_TMPDIR) DO I=1,TMPDIRLEN OOC_TMPDIR(I)=ichar(mumps_par%OOC_TMPDIR(I:I)) ENDDO PREFIXLEN=len_trim(mumps_par%OOC_PREFIX) DO I=1,PREFIXLEN OOC_PREFIX(I)=ichar(mumps_par%OOC_PREFIX(I:I)) ENDDO IF ( JOB == -2 ) THEN IF (associated(mumps_par_array(INSTANCE_NUMBER)%PTR))THEN DEALLOCATE(mumps_par_array(INSTANCE_NUMBER)%PTR) NULLIFY (mumps_par_array(INSTANCE_NUMBER)%PTR) N_INSTANCES = N_INSTANCES - 1 IF ( N_INSTANCES == 0 ) THEN DEALLOCATE(mumps_par_array) SMUMPS_STRUC_ARRAY_SIZE = 0 END IF ELSE WRITE(*,*) "** Warning: instance already freed" WRITE(*,*) " this should normally not happen." ENDIF END IF RETURN END SUBROUTINE SMUMPS_F77 MUMPS_5.8.1/src/mumps_memory_mod.F0000664000175000017500000007565215042446423016747 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_MEMORY_MOD INTERFACE MUMPS_DEALLOC MODULE PROCEDURE MUMPS_IDEALLOC END INTERFACE INTERFACE MUMPS_REALLOC MODULE PROCEDURE MUMPS_IREALLOC MODULE PROCEDURE MUMPS_DREALLOC, MUMPS_SREALLOC, MUMPS_ZREALLOC MODULE PROCEDURE MUMPS_CREALLOC END INTERFACE INTEGER(8), PRIVATE :: ISIZE, I8SIZE, SSIZE, DSIZE, CSIZE, ZSIZE CONTAINS SUBROUTINE MUMPS_MEMORY_SET_DATA_SIZES() INTEGER :: I(2) INTEGER(8) :: I8(2) REAL(kind(1.e0)) :: S(2) REAL(kind(1.d0)) :: D(2) COMPLEX(kind(1.e0)) :: C(2) COMPLEX(kind(1.d0)) :: Z(2) CALL MUMPS_SIZE_C(I (1), I (2), ISIZE) CALL MUMPS_SIZE_C(S (1), S (2), SSIZE) CALL MUMPS_SIZE_C(D (1), D (2), DSIZE) CALL MUMPS_SIZE_C(C (1), C (2), CSIZE) CALL MUMPS_SIZE_C(Z (1), Z (2), ZSIZE) CALL MUMPS_SIZE_C(I8(1), I8(2), I8SIZE) RETURN END SUBROUTINE MUMPS_MEMORY_SET_DATA_SIZES SUBROUTINE MUMPS_IREALLOC(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) INTEGER, POINTER :: ARRAY(:) INTEGER :: INFO(:) INTEGER :: MINSIZE, LP LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE INTEGER(8), OPTIONAL :: MEMCNT LOGICAL :: ICOPY, IFORCE INTEGER, POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER(len=60) :: FMTA, FMTD IF(present(COPY)) THEN ICOPY = COPY ELSE ICOPY = .FALSE. END IF IF (present(FORCE)) THEN IFORCE = FORCE ELSE IFORCE = .FALSE. END IF IF (present(STRING)) THEN FMTA = "Allocation failed inside realloc: "//STRING FMTD = "Deallocation failed inside realloc: "//STRING ELSE FMTA = "Allocation failed inside realloc: " FMTD = "Deallocation failed inside realloc: " END IF IF (present(ERRCODE)) THEN ERRTPL(1) = ERRCODE ERRTPL(2) = MINSIZE ELSE ERRTPL(1) = -13 ERRTPL(2) = MINSIZE END IF IF(ICOPY) THEN IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN allocate(TEMP(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT))MEMCNT = MEMCNT+ & int(MINSIZE,8)*ISIZE END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*ISIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF NULLIFY(ARRAY) ARRAY => TEMP NULLIFY(TEMP) END IF ELSE WRITE(LP, & '("Input array is not associated. nothing to copy here")') RETURN END IF ELSE IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*ISIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF ELSE RETURN END IF END IF allocate(ARRAY(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT)) MEMCNT = MEMCNT+ & MINSIZE*ISIZE END IF END IF RETURN END SUBROUTINE MUMPS_IREALLOC SUBROUTINE MUMPS_I8REALLOC(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) INTEGER(8), POINTER :: ARRAY(:) INTEGER :: INFO(:) INTEGER :: MINSIZE, LP LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE INTEGER(8), OPTIONAL :: MEMCNT LOGICAL :: ICOPY, IFORCE INTEGER(8), POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER(len=60) :: FMTA, FMTD IF(present(COPY)) THEN ICOPY = COPY ELSE ICOPY = .FALSE. END IF IF (present(FORCE)) THEN IFORCE = FORCE ELSE IFORCE = .FALSE. END IF IF (present(STRING)) THEN FMTA = "Allocation failed inside realloc: "//STRING FMTD = "Deallocation failed inside realloc: "//STRING ELSE FMTA = "Allocation failed inside realloc: " FMTD = "Deallocation failed inside realloc: " END IF IF (present(ERRCODE)) THEN ERRTPL(1) = ERRCODE ERRTPL(2) = MINSIZE ELSE ERRTPL(1) = -13 ERRTPL(2) = MINSIZE END IF IF(ICOPY) THEN IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN allocate(TEMP(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT))MEMCNT = MEMCNT+ & int(MINSIZE,8)*I8SIZE END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*I8SIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF NULLIFY(ARRAY) ARRAY => TEMP NULLIFY(TEMP) END IF ELSE WRITE(LP, & '("Input array is not associated. nothing to copy here")') RETURN END IF ELSE IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*I8SIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF ELSE RETURN END IF END IF allocate(ARRAY(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT)) MEMCNT = MEMCNT+ & int(MINSIZE,8)*I8SIZE END IF END IF RETURN END SUBROUTINE MUMPS_I8REALLOC SUBROUTINE MUMPS_IREALLOC8(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) INTEGER, POINTER :: ARRAY(:) INTEGER :: INFO(:) INTEGER :: LP INTEGER(8) :: MINSIZE LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE INTEGER(8), OPTIONAL :: MEMCNT LOGICAL :: ICOPY, IFORCE INTEGER, POINTER :: TEMP(:) INTEGER(8) :: I INTEGER :: IERR, ERRTPL(2) CHARACTER(len=60) :: FMTA, FMTD IF(present(COPY)) THEN ICOPY = COPY ELSE ICOPY = .FALSE. END IF IF (present(FORCE)) THEN IFORCE = FORCE ELSE IFORCE = .FALSE. END IF IF (present(STRING)) THEN FMTA = "Allocation failed inside realloc: "//STRING FMTD = "Deallocation failed inside realloc: "//STRING ELSE FMTA = "Allocation failed inside realloc: " FMTD = "Deallocation failed inside realloc: " END IF IF (present(ERRCODE)) THEN ERRTPL(1) = ERRCODE ERRTPL(2) = int(min(MINSIZE,huge(I))) ELSE ERRTPL(1) = -13 ERRTPL(2) = int(min(MINSIZE,huge(I))) END IF IF(ICOPY) THEN IF(associated(ARRAY)) THEN IF ((int(size(ARRAY),8) .LT. MINSIZE) .OR. & ((int(size(ARRAY),8).NE.MINSIZE) .AND. IFORCE)) THEN allocate(TEMP(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT))MEMCNT = MEMCNT+MINSIZE*ISIZE END IF DO I=1, min(int(size(ARRAY),8), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*ISIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF NULLIFY(ARRAY) ARRAY => TEMP NULLIFY(TEMP) END IF ELSE WRITE(LP, & '("Input array is not associated. nothing to copy here")') RETURN END IF ELSE IF(associated(ARRAY)) THEN IF ((int(size(ARRAY),8) .LT. MINSIZE) .OR. & ((int(size(ARRAY),8).NE.MINSIZE) .AND. IFORCE)) THEN IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*ISIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF ELSE RETURN END IF END IF allocate(ARRAY(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT)) MEMCNT = MEMCNT+MINSIZE*ISIZE END IF END IF RETURN END SUBROUTINE MUMPS_IREALLOC8 SUBROUTINE MUMPS_I8REALLOC8(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) INTEGER(8), POINTER :: ARRAY(:) INTEGER :: INFO(:), LP INTEGER(8) :: MINSIZE LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE INTEGER(8), OPTIONAL :: MEMCNT LOGICAL :: ICOPY, IFORCE INTEGER(8), POINTER :: TEMP(:) INTEGER :: IERR, ERRTPL(2) CHARACTER(len=60) :: FMTA, FMTD INTEGER(8) :: ASIZE, I ASIZE = int(size(ARRAY),8) IF(present(COPY)) THEN ICOPY = COPY ELSE ICOPY = .FALSE. END IF IF (present(FORCE)) THEN IFORCE = FORCE ELSE IFORCE = .FALSE. END IF IF (present(STRING)) THEN FMTA = "Allocation failed inside realloc: "//STRING FMTD = "Deallocation failed inside realloc: "//STRING ELSE FMTA = "Allocation failed inside realloc: " FMTD = "Deallocation failed inside realloc: " END IF IF (present(ERRCODE)) THEN ERRTPL(1) = ERRCODE ERRTPL(2) = int(MINSIZE) ELSE ERRTPL(1) = -13 ERRTPL(2) = int(MINSIZE) END IF IF(ICOPY) THEN IF(associated(ARRAY)) THEN IF ((ASIZE .LT. MINSIZE) .OR. & ((ASIZE.NE.MINSIZE) .AND. IFORCE)) THEN allocate(TEMP(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT))MEMCNT = MEMCNT+ & int(MINSIZE,8)*I8SIZE END IF DO I=1, min(ASIZE, MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT- & ASIZE*I8SIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF NULLIFY(ARRAY) ARRAY => TEMP NULLIFY(TEMP) END IF ELSE WRITE(LP, & '("Input array is not associated. nothing to copy here")') RETURN END IF ELSE IF(associated(ARRAY)) THEN IF ((ASIZE .LT. MINSIZE) .OR. & ((ASIZE.NE.MINSIZE) .AND. IFORCE)) THEN IF(present(MEMCNT))MEMCNT = MEMCNT- & ASIZE*I8SIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF ELSE RETURN END IF END IF allocate(ARRAY(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT)) MEMCNT = MEMCNT+ & int(MINSIZE,8)*I8SIZE END IF END IF RETURN END SUBROUTINE MUMPS_I8REALLOC8 SUBROUTINE MUMPS_SREALLOC(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) REAL(kind(1.E0)), POINTER :: ARRAY(:) INTEGER :: INFO(:) INTEGER :: MINSIZE, LP LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE INTEGER(8), OPTIONAL :: MEMCNT LOGICAL :: ICOPY, IFORCE REAL(kind(1.E0)), POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER(len=60) :: FMTA, FMTD IF(present(COPY)) THEN ICOPY = COPY ELSE ICOPY = .FALSE. END IF IF (present(FORCE)) THEN IFORCE = FORCE ELSE IFORCE = .FALSE. END IF IF (present(STRING)) THEN FMTA = "Allocation failed inside realloc: "//STRING FMTD = "Deallocation failed inside realloc: "//STRING ELSE FMTA = "Allocation failed inside realloc: " FMTD = "Deallocation failed inside realloc: " END IF IF (present(ERRCODE)) THEN ERRTPL(1) = ERRCODE ERRTPL(2) = MINSIZE ELSE ERRTPL(1) = -13 ERRTPL(2) = MINSIZE END IF IF(ICOPY) THEN IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN allocate(TEMP(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT))MEMCNT = MEMCNT+ & int(MINSIZE,8)*SSIZE END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*SSIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF NULLIFY(ARRAY) ARRAY => TEMP NULLIFY(TEMP) END IF ELSE WRITE(LP, & '("Input array is not associated. nothing to copy here")') RETURN END IF ELSE IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*SSIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF ELSE RETURN END IF END IF allocate(ARRAY(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT)) MEMCNT = MEMCNT+MINSIZE*SSIZE END IF END IF RETURN END SUBROUTINE MUMPS_SREALLOC SUBROUTINE MUMPS_DREALLOC(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) REAL(kind(1.D0)), POINTER :: ARRAY(:) INTEGER :: INFO(:) INTEGER :: MINSIZE, LP LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE INTEGER(8), OPTIONAL :: MEMCNT LOGICAL :: ICOPY, IFORCE REAL(kind(1.D0)), POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER(len=60) :: FMTA, FMTD IF(present(COPY)) THEN ICOPY = COPY ELSE ICOPY = .FALSE. END IF IF (present(FORCE)) THEN IFORCE = FORCE ELSE IFORCE = .FALSE. END IF IF (present(STRING)) THEN FMTA = "Allocation failed inside realloc: "//STRING FMTD = "Deallocation failed inside realloc: "//STRING ELSE FMTA = "Allocation failed inside realloc: " FMTD = "Deallocation failed inside realloc: " END IF IF (present(ERRCODE)) THEN ERRTPL(1) = ERRCODE ERRTPL(2) = MINSIZE ELSE ERRTPL(1) = -13 ERRTPL(2) = MINSIZE END IF IF(ICOPY) THEN IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN allocate(TEMP(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT))MEMCNT = MEMCNT+ & int(MINSIZE,8)*DSIZE END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*DSIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF NULLIFY(ARRAY) ARRAY => TEMP NULLIFY(TEMP) END IF ELSE WRITE(LP, & '("Input array is not associated. nothing to copy here")') RETURN END IF ELSE IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*DSIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF ELSE RETURN END IF END IF allocate(ARRAY(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT)) MEMCNT = MEMCNT+ & int(MINSIZE,8)*DSIZE END IF END IF RETURN END SUBROUTINE MUMPS_DREALLOC SUBROUTINE MUMPS_CREALLOC(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) COMPLEX(kind((1.E0,1.E0))), POINTER :: ARRAY(:) INTEGER :: INFO(:) INTEGER :: MINSIZE, LP LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE INTEGER(8), OPTIONAL :: MEMCNT LOGICAL :: ICOPY, IFORCE COMPLEX(kind((1.E0,1.E0))), POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER(len=60) :: FMTA, FMTD IF(present(COPY)) THEN ICOPY = COPY ELSE ICOPY = .FALSE. END IF IF (present(FORCE)) THEN IFORCE = FORCE ELSE IFORCE = .FALSE. END IF IF (present(STRING)) THEN FMTA = "Allocation failed inside realloc: "//STRING FMTD = "Deallocation failed inside realloc: "//STRING ELSE FMTA = "Allocation failed inside realloc: " FMTD = "Deallocation failed inside realloc: " END IF IF (present(ERRCODE)) THEN ERRTPL(1) = ERRCODE ERRTPL(2) = MINSIZE ELSE ERRTPL(1) = -13 ERRTPL(2) = MINSIZE END IF IF(ICOPY) THEN IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN allocate(TEMP(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT))MEMCNT = MEMCNT+ & int(MINSIZE,8)*CSIZE END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*CSIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF NULLIFY(ARRAY) ARRAY => TEMP NULLIFY(TEMP) END IF ELSE WRITE(LP, & '("Input array is not associated. nothing to copy here")') RETURN END IF ELSE IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*CSIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF ELSE RETURN END IF END IF allocate(ARRAY(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT)) MEMCNT = MEMCNT+ & int(MINSIZE,8)*CSIZE END IF END IF RETURN END SUBROUTINE MUMPS_CREALLOC SUBROUTINE MUMPS_ZREALLOC(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) COMPLEX(kind((1.D0,1.D0))), POINTER :: ARRAY(:) INTEGER :: INFO(:) INTEGER :: MINSIZE, LP LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE INTEGER(8), OPTIONAL :: MEMCNT LOGICAL :: ICOPY, IFORCE COMPLEX(kind((1.D0,1.D0))), POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER(len=60) :: FMTA, FMTD IF(present(COPY)) THEN ICOPY = COPY ELSE ICOPY = .FALSE. END IF IF (present(FORCE)) THEN IFORCE = FORCE ELSE IFORCE = .FALSE. END IF IF (present(STRING)) THEN FMTA = "Allocation failed inside realloc: "//STRING FMTD = "Deallocation failed inside realloc: "//STRING ELSE FMTA = "Allocation failed inside realloc: " FMTD = "Deallocation failed inside realloc: " END IF IF (present(ERRCODE)) THEN ERRTPL(1) = ERRCODE ERRTPL(2) = MINSIZE ELSE ERRTPL(1) = -13 ERRTPL(2) = MINSIZE END IF IF(ICOPY) THEN IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN allocate(TEMP(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT))MEMCNT = MEMCNT+int(MINSIZE,8)*16_8 END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT =MEMCNT- & int(size(ARRAY),8)*ZSIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF NULLIFY(ARRAY) ARRAY => TEMP NULLIFY(TEMP) END IF ELSE WRITE(LP, & '("Input array is not associated. nothing to copy here")') RETURN END IF ELSE IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN IF(present(MEMCNT))MEMCNT =MEMCNT- & int(size(ARRAY),8)*ZSIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF ELSE RETURN END IF END IF allocate(ARRAY(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT)) MEMCNT = MEMCNT+ & int(MINSIZE,8)*ZSIZE END IF END IF RETURN END SUBROUTINE MUMPS_ZREALLOC SUBROUTINE MUMPS_IDEALLOC(A1, A2, A3, A4, A5, A6, A7, MEMCNT) INTEGER, POINTER :: A1(:) INTEGER, POINTER, OPTIONAL :: A2(:), A3(:), A4(:), A5(:), & A6(:), A7(:) INTEGER(8), OPTIONAL :: MEMCNT INTEGER(8) :: IMEMCNT IMEMCNT = 0 IF(associated(A1)) THEN IMEMCNT = IMEMCNT+int(size(A1),8)*ISIZE DEALLOCATE(A1) NULLIFY(A1) END IF IF(present(A2)) THEN IF(associated(A2)) THEN IMEMCNT = IMEMCNT+int(size(A2),8)*ISIZE DEALLOCATE(A2) NULLIFY(A2) END IF END IF IF(present(A3)) THEN IF(associated(A3)) THEN IMEMCNT = IMEMCNT+int(size(A3),8)*ISIZE DEALLOCATE(A3) NULLIFY(A3) END IF END IF IF(present(A4)) THEN IF(associated(A4)) THEN IMEMCNT = IMEMCNT+int(size(A4),8)*ISIZE DEALLOCATE(A4) NULLIFY(A4) END IF END IF IF(present(A5)) THEN IF(associated(A5)) THEN IMEMCNT = IMEMCNT+int(size(A5),8)*ISIZE DEALLOCATE(A5) NULLIFY(A5) END IF END IF IF(present(A6)) THEN IF(associated(A6)) THEN IMEMCNT = IMEMCNT+int(size(A6),8)*ISIZE DEALLOCATE(A6) NULLIFY(A6) END IF END IF IF(present(A7)) THEN IF(associated(A7)) THEN IMEMCNT = IMEMCNT+int(size(A7),8)*ISIZE DEALLOCATE(A7) NULLIFY(A7) END IF END IF IF(present(MEMCNT)) MEMCNT = MEMCNT-IMEMCNT RETURN END SUBROUTINE MUMPS_IDEALLOC SUBROUTINE MUMPS_I8DEALLOC(A1, A2, A3, A4, A5, A6, A7, MEMCNT) INTEGER(8), POINTER :: A1(:) INTEGER(8), POINTER, OPTIONAL :: A2(:), A3(:), A4(:), A5(:), & A6(:), A7(:) INTEGER(8), OPTIONAL :: MEMCNT INTEGER(8) :: IMEMCNT IMEMCNT = 0 IF(associated(A1)) THEN IMEMCNT = IMEMCNT+int(size(A1),8)*I8SIZE DEALLOCATE(A1) NULLIFY(A1) END IF IF(present(A2)) THEN IF(associated(A2)) THEN IMEMCNT = IMEMCNT+int(size(A2),8)*I8SIZE DEALLOCATE(A2) NULLIFY(A2) END IF END IF IF(present(A3)) THEN IF(associated(A3)) THEN IMEMCNT = IMEMCNT+int(size(A3),8)*I8SIZE DEALLOCATE(A3) NULLIFY(A3) END IF END IF IF(present(A4)) THEN IF(associated(A4)) THEN IMEMCNT = IMEMCNT+int(size(A4),8)*I8SIZE DEALLOCATE(A4) NULLIFY(A4) END IF END IF IF(present(A5)) THEN IF(associated(A5)) THEN IMEMCNT = IMEMCNT+int(size(A5),8)*I8SIZE DEALLOCATE(A5) NULLIFY(A5) END IF END IF IF(present(A6)) THEN IF(associated(A6)) THEN IMEMCNT = IMEMCNT+int(size(A6),8)*I8SIZE DEALLOCATE(A6) NULLIFY(A6) END IF END IF IF(present(A7)) THEN IF(associated(A7)) THEN IMEMCNT = IMEMCNT+int(size(A7),8)*I8SIZE DEALLOCATE(A7) NULLIFY(A7) END IF END IF IF(present(MEMCNT)) MEMCNT = MEMCNT-IMEMCNT RETURN END SUBROUTINE MUMPS_I8DEALLOC END MODULE MUMPS_MEMORY_MOD MUMPS_5.8.1/src/sana_dist_m.F0000664000175000017500000040620415042446436015633 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ANA_COMPUTE_ESTIMATES ( id, idintr ) USE SMUMPS_STRUC_DEF, ONLY: SMUMPS_STRUC USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_INTR_STRUC USE MUMPS_ANA_OMP_M, ONLY: MUMPS_ANA_L0_OMP IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR, MASTER PARAMETER( MASTER = 0 ) TYPE(SMUMPS_STRUC), TARGET :: id TYPE(SMUMPS_INTR_STRUC) :: idintr INTEGER, DIMENSION(:), POINTER :: KEEP, INFO, INFOG INTEGER :: allocok INTEGER(8), DIMENSION(:), POINTER :: KEEP8 REAL, DIMENSION(:), POINTER :: RINFO REAL, DIMENSION(:), POINTER :: RINFOG INTEGER, DIMENSION(:), POINTER :: ICNTL INTEGER IRANK INTEGER :: LP, MP, MPG LOGICAL :: PROK, PROKG, LPOK LOGICAL :: I_AM_SLAVE, PERLU_ON, PRINT_MAXAVG LOGICAL :: SUM_OF_PEAKS, PRINT_NODEINFO INTEGER :: TOTAL_MBYTES_UNDER_L0 INTEGER(8) :: TOTAL_BYTES_UNDER_L0 INTEGER :: NBSTATS_I4, NBSTATS_I8 PARAMETER (NBSTATS_I4=4, NBSTATS_I8=24) INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: TNSTK_afterL0 INTEGER, ALLOCATABLE, DIMENSION(:) :: FLAGGED_LEAVES INTEGER(8) :: PEAK_UNDER_L0, PEAK_ABOVE_L0 INTEGER(8) :: SUM_NRLADU, MAX_NRLADU, MIN_NRLADU, & SUM_NRLADU_if_LR_LU, & SUM_NRLADULR_UD, SUM_NRLADULR_WC, & SUM_NRLNEC, SUM_NRLNEC_ACTIVE, & MIN_NRLNEC INTEGER :: SUM_NIRADU, & SUM_NIRADU_OOC, & SUM_NIRNEC, SUM_NIRNEC_OOC INTEGER :: LIPOOL_local INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: IPOOL INTEGER :: I, LIPOOL INTEGER(4) :: I4 INTEGER, POINTER, DIMENSION(:) :: NE_STEPSPTR INTEGER, POINTER, DIMENSION(:) :: IPOOLPTR LOGICAL :: BDUMMY INTEGER(8) :: K8_33relaxed, K8_34relaxed, K8_35relaxed, & K8_50relaxed INTEGER(8) :: ENTRIES_IN_FACTORS_LOC_MASTERS INTEGER :: OOC_STRAT, BLR_STRAT, IDUMMY, ISTEP, NBNODES_BLR INTEGER(8) :: TOTAL_BYTES, ITMP8 INTEGER(8) :: MAX_FRONT_SURFACE_LOCAL_L0, & MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO INTEGER :: MAXFR_UNDER_L0 DOUBLE PRECISION :: COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0 INTEGER(8):: SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB LOGICAL :: ABOVE_L0 INTEGER :: locMYID_NODES LOGICAL, POINTER :: locI_AM_CAND(:) INTEGER LOCAL_M, LOCAL_N INTEGER, EXTERNAL :: MUMPS_NUMROC INTEGER SBUF_SEND_FR, SBUF_REC_FR INTEGER SBUF_SEND_LR, SBUF_REC_LR INTEGER TOTAL_MBYTES INTEGER(8) SUM_KEEP811_THIS_NODE, MAX_SUM_KEEP811_THIS_NODE INTEGER SUM_INFO15_THIS_NODE, MAX_SUM_INFO15_THIS_NODE INTEGER SUM_INFO17_THIS_NODE, MAX_SUM_INFO17_THIS_NODE INTEGER(8) SBUF_RECOLD8, MIN_BUF_SIZE8 LOGICAL UPDATE_BUFFER INTEGER MIN_BUF_SIZE, SIZE_DESC_BANDE, & MaxBlocSize_FR, MaxBlocSize_BLR, & MIN_BUF_SIZE_FR, MIN_BUF_SIZE_BLR INTEGER(8) MAX_SIZE_FACTOR_TMP, KEEP26_I8_TMP KEEP => id%KEEP KEEP8 => id%KEEP8 INFO => id%INFO RINFO => id%RINFO INFOG => id%INFOG RINFOG => id%RINFOG ICNTL => id%ICNTL LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) PRINT_NODEINFO = PRINT_MAXAVG .AND. id%NPROCS .NE. id%KEEP(412) IDUMMY = 1 BDUMMY = .FALSE. IF ( I_AM_SLAVE ) THEN locI_AM_CAND => id%I_AM_CAND locMYID_NODES = id%MYID_NODES IF ( idintr%root%yes ) THEN LOCAL_M = MUMPS_NUMROC( & id%ND_STEPS(id%STEP(KEEP(38))), & idintr%root%MBLOCK, idintr%root%MYROW, 0, & idintr%root%NPROW ) LOCAL_M = max(1, LOCAL_M) LOCAL_N = MUMPS_NUMROC( & id%ND_STEPS(id%STEP(KEEP(38))), & idintr%root%NBLOCK, idintr%root%MYCOL, 0, & idintr%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 idintr%root%SCHUR_MLOC=LOCAL_M idintr%root%SCHUR_NLOC=LOCAL_N ENDIF IF ( .NOT. associated(id%CANDIDATES)) THEN ALLOCATE(id%CANDIDATES(id%NSLAVES+1,1), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF INFO(1)= -7 INFO(2)= id%NSLAVES+1 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF (KEEP(400) .GT. 0 ) THEN IF ( I_AM_SLAVE ) THEN CALL MUMPS_ANA_L0_OMP( & KEEP(400), id%N, KEEP(28), & KEEP(50), id%NSLAVES, id%DAD_STEPS, id%FRERE_STEPS, & id%FILS, id%NE_STEPS, id%ND_STEPS, id%STEP, & id%PROCNODE_STEPS, KEEP, KEEP8, locMYID_NODES, & id%NA, id%LNA, "SMUMPS"(1:1), & id%LPOOL_B_L0_OMP, id%IPOOL_B_L0_OMP, & id%LPOOL_A_L0_OMP, id%IPOOL_A_L0_OMP, & id%L_VIRT_L0_OMP,id%VIRT_L0_OMP, id%VIRT_L0_OMP_MAPPING, & id%L_PHYS_L0_OMP,id%PHYS_L0_OMP, id%PERM_L0_OMP, & id%PTR_LEAFS_L0_OMP, & id%INFO, id%ICNTL) IF (id%INFO(1) .GE. 0) THEN ALLOCATE( & id%I4_L0_OMP(NBSTATS_I4, KEEP(400)), & id%I8_L0_OMP(NBSTATS_I8, KEEP(400)), & TNSTK_afterL0(KEEP(28)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'L0_OMP stats' END IF INFO(1)= -7 INFO(2)= NBSTATS_I4* KEEP(400) + & NBSTATS_I8* KEEP(400)*KEEP(10) & + KEEP(28) ENDIF ENDIF ELSE ALLOCATE(id%I4_L0_OMP(1,1), id%I8_L0_OMP(1,1), stat=allocok) IF (allocok.gt.0) THEN INFO(1)= -7 INFO(2)= 2 ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN CALL SMUMPS_ANA_DISTM_UNDERL0OMP( & id%LPOOL_B_L0_OMP, id%IPOOL_B_L0_OMP(1), & id%L_VIRT_L0_OMP, & id%VIRT_L0_OMP(1), id%VIRT_L0_OMP_MAPPING(1), & id%L_PHYS_L0_OMP, id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1), & id%PTR_LEAFS_L0_OMP(1), & id%KEEP(1), id%N, id%NE_STEPS(1), id%STEP(1), & id%FRERE_STEPS(1), id%FILS(1), id%DAD_STEPS(1), & id%ND_STEPS(1), & locMYID_NODES, id%PROCNODE_STEPS(1), & id%I4_L0_OMP(1,1), NBSTATS_I4, & id%I8_L0_OMP(1,1), NBSTATS_I8, KEEP(400), & SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB, & TNSTK_afterL0, MAXFR_UNDER_L0, & MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0, NBNODES_BLR, & INFO(1), INFO(2) & ) CALL MPI_ALLREDUCE (NBNODES_BLR, KEEP(470), 1, & MPI_INTEGER, MPI_SUM, id%COMM_NODES, IERR) ENDIF ELSE IF ( I_AM_SLAVE ) THEN id%LPOOL_B_L0_OMP = 1 id%LPOOL_A_L0_OMP = 1 id%L_VIRT_L0_OMP = 1 id%L_PHYS_L0_OMP = 1 id%THREAD_LA = -1_8 ALLOCATE ( id%VIRT_L0_OMP ( id%L_VIRT_L0_OMP ), & id%VIRT_L0_OMP_MAPPING ( id%L_VIRT_L0_OMP ), & id%PERM_L0_OMP ( id%L_PHYS_L0_OMP ), & id%PTR_LEAFS_L0_OMP ( id%L_PHYS_L0_OMP + 1 ), & id%IPOOL_B_L0_OMP ( id%LPOOL_B_L0_OMP ), & id%IPOOL_A_L0_OMP ( id%LPOOL_A_L0_OMP ), & id%PHYS_L0_OMP( id%L_PHYS_L0_OMP ), & id%I4_L0_OMP(1,1), id%I8_L0_OMP(1,1), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'Allocation error in multicore' END IF INFO(1)= -7 INFO(2)= id%L_VIRT_L0_OMP & + id%L_PHYS_L0_OMP & + id%L_PHYS_L0_OMP + 1 & + id%LPOOL_B_L0_OMP & + id%LPOOL_A_L0_OMP & + id%L_PHYS_L0_OMP + 1 + KEEP(10) ENDIF ELSE ALLOCATE(id%I4_L0_OMP(1,1), id%I8_L0_OMP(1,1), stat=allocok) IF (allocok.gt.0) THEN INFO(1)= -7 INFO(2)= 2 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN IF (KEEP(400).GT.0) THEN IF (id%NSLAVES .GT.1) THEN ALLOCATE (FLAGGED_LEAVES(KEEP(28)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'L0_OMP FLAGGED LEAVES' END IF INFO(1)= -7 INFO(2)= KEEP(28) ENDIF ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN IF (KEEP(400).GT.0) THEN IF (id%NSLAVES .GT.1) THEN LIPOOL_local= & id%IPOOL_A_L0_OMP(id%LPOOL_A_L0_OMP) CALL SMUMPS_PREP_ANA_DISTM_ABOVEL0( & id%N, id%NSLAVES, id%COMM_NODES, id%MYID_NODES, & id%STEP(1), id%DAD_STEPS(1),id%ICNTL,LP,LPOK, & id%INFO, & id%PHYS_L0_OMP(1), id%L_PHYS_L0_OMP, & id%IPOOL_A_L0_OMP(1), LIPOOL_local, & id%KEEP, TNSTK_afterL0, & FLAGGED_LEAVES & ) IF ( INFO(1).LT.0 ) GOTO 75 LIPOOL= 0 DO ISTEP=1,KEEP(28) IF (FLAGGED_LEAVES(ISTEP).GT.0) LIPOOL=LIPOOL+1 ENDDO ALLOCATE( IPOOL(max(LIPOOL,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'Allocation IPOOL' END IF INFO(1)= -7 INFO(2)= LIPOOL ENDIF ELSE LIPOOL = id%IPOOL_A_L0_OMP(id%LPOOL_A_L0_OMP) ENDIF ELSE LIPOOL = id%NA(1) ENDIF ENDIF 75 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN IF (KEEP(400) .GT. 0 ) THEN IF (id%NSLAVES .GT.1) THEN IF (LIPOOL .GT.0) THEN I =LIPOOL DO ISTEP=1, KEEP(28) IF (FLAGGED_LEAVES(ISTEP).GT.0) THEN IPOOL(I) = FLAGGED_LEAVES(ISTEP) I=I-1 ENDIF IF (I.EQ.0) EXIT ENDDO ENDIF DEALLOCATE(FLAGGED_LEAVES) IPOOLPTR => IPOOL ELSE IPOOLPTR => id%IPOOL_A_L0_OMP ENDIF ABOVE_L0 =.TRUE. NE_STEPSPTR => TNSTK_afterL0(1:KEEP(28)) ELSE IPOOLPTR => id%NA(3:3+max(LIPOOL,1)-1) ABOVE_L0 =.FALSE. SIZECB_UNDER_L0 = 0_8 SIZECB_UNDER_L0_IF_LRCB = 0_8 MAX_FRONT_SURFACE_LOCAL_L0 = 0_8 MAX_SIZE_FACTOR_L0 = 0_8 ENTRIES_IN_FACTORS_UNDER_L0= 0_8 ENTRIES_IN_FACTORS_MASTERS_LO = 0_8 MAXFR_UNDER_L0 = 0 COST_SUBTREES_UNDER_L0 = 0.0D0 OPSA_UNDER_L0 = 0.0D0 NE_STEPSPTR => id%NE_STEPS ENDIF KEEP(139) = MAXFR_UNDER_L0 CALL SMUMPS_ANA_DISTM( locMYID_NODES, id%N, id%STEP(1), & id%FRERE_STEPS(1), id%FILS(1), IPOOLPTR(1), LIPOOL, NE_STEPSPTR & (1), id%DAD_STEPS(1), id%ND_STEPS(1), id%PROCNODE_STEPS(1), & id%NSLAVES, ABOVE_L0,SIZECB_UNDER_L0,SIZECB_UNDER_L0_IF_LRCB, & MAXFR_UNDER_L0, MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0, KEEP8(53), KEEP8(54), & KEEP8(11), KEEP(26), KEEP(15), KEEP8(12), KEEP8(14), & KEEP8(32), KEEP8(33), KEEP8(34), KEEP8(35), KEEP8(50), & KEEP8(36), KEEP8(47), KEEP8(37), KEEP8(38), KEEP8(39), & KEEP8(40), KEEP8(41), KEEP8(42), KEEP8(43), KEEP8(44), KEEP8(45), & KEEP8(46), KEEP8(51), KEEP8(52), KEEP(224),KEEP(225),KEEP(27), & RINFO(1),id%CNTL(1), KEEP(1), KEEP8(1), LOCAL_M, LOCAL_N, & SBUF_RECOLD8, SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR, & SBUF_REC_LR, id%COST_SUBTREES, KEEP(28), locI_AM_CAND(1), & max(KEEP(56),1), id%ISTEP_TO_INIV2(1), id%CANDIDATES(1,1), & INFO(1), INFO(2), KEEP8(15),MAX_SIZE_FACTOR_TMP, & KEEP8(9), ENTRIES_IN_FACTORS_LOC_MASTERS, & idintr%root%yes, idintr%root%NPROW, idintr%root%NPCOL & ) IF (ALLOCATED(IPOOL)) DEALLOCATE(IPOOL) NULLIFY(NE_STEPSPTR,IPOOLPTR) IF (KEEP(400) .GT. 0) THEN DEALLOCATE (TNSTK_afterL0) SUM_NIRNEC = 0 SUM_NIRADU = 0 SUM_NIRADU_OOC = 0 SUM_NIRNEC_OOC = 0 DO I=1, KEEP(400) SUM_NIRADU = SUM_NIRADU + id%I4_L0_OMP(1,I) SUM_NIRNEC = SUM_NIRNEC + id%I4_L0_OMP(2,I) SUM_NIRADU_OOC = SUM_NIRADU_OOC+ id%I4_L0_OMP(3,I) SUM_NIRNEC_OOC = SUM_NIRNEC_OOC+ id%I4_L0_OMP(4,I) ENDDO KEEP(26) = KEEP(26) + SUM_NIRADU KEEP(224) = KEEP(224) + SUM_NIRADU_OOC KEEP(15) = max(KEEP(15),KEEP(26)) KEEP(225) = max(KEEP(225),KEEP(224)) KEEP(137) = SUM_NIRNEC KEEP(138) = SUM_NIRNEC_OOC SUM_NIRNEC = int( & (REAL(SUM_NIRNEC)*REAL(KEEP(34)))/REAL(KEEP(35)) & ) SUM_NIRNEC_OOC = int( & (REAL(SUM_NIRNEC_OOC)*REAL(KEEP(34)))/REAL(KEEP(35)) & ) MAX_NRLADU = 0_8 MIN_NRLADU = id%I8_L0_OMP(1,1) SUM_NRLADU = 0_8 SUM_NRLNEC = 0_8 MIN_NRLNEC = huge(MIN_NRLNEC) SUM_NRLNEC_ACTIVE = 0_8 SUM_NRLADU_if_LR_LU = 0_8 SUM_NRLADULR_UD = 0_8 SUM_NRLADULR_WC = 0_8 DO I=1, KEEP(400) MIN_NRLADU = min(MIN_NRLADU, id%I8_L0_OMP(1,I)) MAX_NRLADU = max(MAX_NRLADU, id%I8_L0_OMP(1,I)) SUM_NRLADU = SUM_NRLADU + id%I8_L0_OMP(1,I) SUM_NRLNEC = SUM_NRLNEC + id%I8_L0_OMP(2,I) MIN_NRLNEC = min(MIN_NRLNEC, id%I8_L0_OMP(2,I)) SUM_NRLNEC_ACTIVE = SUM_NRLNEC_ACTIVE + & id%I8_L0_OMP(3,I) SUM_NRLADU_if_LR_LU = SUM_NRLADU_if_LR_LU + & id%I8_L0_OMP(4,I) SUM_NRLADULR_UD = SUM_NRLADULR_UD + & id%I8_L0_OMP(9,I) SUM_NRLADULR_WC = SUM_NRLADULR_WC + & id%I8_L0_OMP(10,I) ENDDO KEEP8(81) = KEEP8(11) KEEP8(11) = KEEP8(11) + SUM_NRLADU KEEP8(82) = KEEP8(32) KEEP8(32) = KEEP8(32) + SUM_NRLADU_if_LR_LU PEAK_UNDER_L0 = SUM_NRLNEC + MIN_NRLNEC + & int( & (real(id%N*KEEP(400))*real(KEEP(34)))/real(KEEP(35)), & 8) PEAK_ABOVE_L0 = KEEP8(53)+ SUM_NRLADU + & & max( int(SBUF_SEND_FR,8), 100000_8) + & & int( & (real(KEEP(15))*real(KEEP(34)))/real(KEEP(35)), & 8) KEEP8(53) = KEEP8(53)+ SUM_NRLADU KEEP8(40) = KEEP8(40)+ & SUM_NRLADU_if_LR_LU + SUM_NRLADULR_UD KEEP8(41) = KEEP8(41)+ SUM_NRLADULR_UD KEEP8(42) = KEEP8(42)+ SUM_NRLADULR_WC KEEP8(43) = KEEP8(43)+ & SUM_NRLADU_if_LR_LU + SUM_NRLADULR_UD KEEP8(44) = KEEP8(44)+ & SUM_NRLADU_if_LR_LU + SUM_NRLADULR_WC KEEP8(45) = KEEP8(45)+ SUM_NRLADULR_UD KEEP8(46) = KEEP8(46)+ SUM_NRLADULR_WC KEEP8(51) = KEEP8(51)+ SUM_NRLADU KEEP8(52) = KEEP8(52)+ SUM_NRLADULR_UD ELSE KEEP(137)=0 KEEP(138)=0 ENDIF id%DKEEP(15) = RINFO(1)/1000000.0E0 IF(ASSOCIATED(locI_AM_CAND)) NULLIFY(locI_AM_CAND) id%MAX_SURF_MASTER = KEEP8(15) KEEP8(19)=MAX_SIZE_FACTOR_TMP KEEP( 29 ) = KEEP(15) + 3* max(KEEP(12),10) & * ( KEEP(15) / 100 + 1) INFO( 19 ) = KEEP(225) + 3* 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) K8_33relaxed = KEEP8(33) + int(KEEP(12),8) * & ( KEEP8(33) /100_8 +1_8) K8_34relaxed = KEEP8(34) + int(KEEP(12),8) * & ( KEEP8(34) /100_8 +1_8) K8_35relaxed = KEEP8(35) + int(KEEP(12),8) * & ( KEEP8(35) /100_8 +1_8) K8_50relaxed = KEEP8(50) + int(KEEP(12),8) * & ( KEEP8(50) /100_8 +1_8) CALL MUMPS_ALLREDUCEI8 ( SBUF_RECOLD8, KEEP8(22), MPI_MAX, & id%COMM_NODES ) IF ( (id%NSLAVES.GT.1) & ) THEN SBUF_SEND_FR = max(SBUF_SEND_FR,KEEP(27)) SBUF_SEND_LR = max(SBUF_SEND_LR,KEEP(27)) SBUF_REC_FR = max(SBUF_REC_FR ,KEEP(27)) SBUF_REC_LR = max(SBUF_REC_LR ,KEEP(27)) ENDIF CALL MPI_ALLREDUCE (SBUF_REC_FR, KEEP(44), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) CALL MPI_ALLREDUCE (SBUF_REC_LR, KEEP(380), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) IF (KEEP(48)==5) THEN KEEP(43) = KEEP(44) KEEP(379) = KEEP(380) ELSE KEEP(43)=SBUF_SEND_FR KEEP(379)=SBUF_SEND_LR ENDIF UPDATE_BUFFER = .TRUE. MIN_BUF_SIZE8 = KEEP8(22) / int(KEEP(238),8) MIN_BUF_SIZE8 = min(MIN_BUF_SIZE8, & int(huge(I4),8)/int(KEEP(35),8) ) MIN_BUF_SIZE = max(int( MIN_BUF_SIZE8 ), KEEP(127)) SIZE_DESC_BANDE=(11+id%NSLAVES+KEEP(127)*2) MaxBlocSize_FR = min (KEEP(420), KEEP(127)) MaxBlocSize_FR = MaxBlocSize_FR*MaxBlocSize_FR MaxBlocSize_BLR = min (KEEP(142), KEEP(127)) MaxBlocSize_BLR = MaxBlocSize_BLR*MaxBlocSize_BLR MIN_BUF_SIZE_FR = MIN_BUF_SIZE MIN_BUF_SIZE_BLR = MIN_BUF_SIZE MIN_BUF_SIZE_FR = min ( MIN_BUF_SIZE_FR, & int ( min ( & real(KEEP(44)) * & (real(abs(KEEP(180))) / real(100)) , & real (huge(I4))/real(KEEP(35)) & ) ) & ) MIN_BUF_SIZE_BLR = min ( MIN_BUF_SIZE_BLR, & int ( min ( & real(KEEP(44)) * & (real(abs(KEEP(181))) / real(100)) , & real (huge(I4))/real(KEEP(35)) & ) ) & ) IF (KEEP(50).EQ.0) THEN KEEP(43) = max( & min(KEEP(43),MaxBlocSize_FR*max(KEEP(171),3)), & int(KEEP(43)/KEEP(172)) ) KEEP(44) = max( & min(KEEP(44), MaxBlocSize_FR*max(KEEP(171),3)), & int(KEEP(44)/KEEP(172)) ) ELSE KEEP(43) = max( & min(KEEP(43),MaxBlocSize_FR*max(KEEP(171),3)), & int((KEEP(43)*KEEP(178))/KEEP(172)) ) KEEP(44) = max( & min(KEEP(44), MaxBlocSize_FR*max(KEEP(171),3)), & int((KEEP(44)*KEEP(178))/KEEP(172)) ) ENDIF KEEP(379) = max( & min(KEEP(379), MaxBlocSize_BLR*max(KEEP(171),3)), & int(KEEP(379)/KEEP(172)) ) KEEP(380) = max( & min(KEEP(380),MaxBlocSize_BLR*max(KEEP(171),3)), & int(KEEP(380)/KEEP(172)) ) IF (UPDATE_BUFFER) THEN KEEP(43) = max(KEEP(43),MIN_BUF_SIZE_FR) + & (SIZE_DESC_BANDE * KEEP(34))/KEEP(35) KEEP(379)= max(KEEP(379),MIN_BUF_SIZE_BLR)+ & (SIZE_DESC_BANDE * KEEP(34))/KEEP(35) ENDIF IF ( (KEEP(38).NE.0) .OR. UPDATE_BUFFER) THEN KEEP(44) = max(KEEP(44),MIN_BUF_SIZE_FR) + & (SIZE_DESC_BANDE * KEEP(34))/KEEP(35) KEEP(380)= max(KEEP(380),MIN_BUF_SIZE_BLR)+ & (SIZE_DESC_BANDE * KEEP(34))/KEEP(35) ENDIF IF ( int(KEEP(43),8)*int(KEEP(35),8) .GE. & int(huge(I4)-100,8)) THEN KEEP(43) = huge(KEEP(43))-100 ENDIF IF ( int(KEEP(44),8)*int(KEEP(35),8) .GE. & int(huge(I4)-100,8)) THEN KEEP(44) = huge(KEEP(44))-100 ENDIF IF ( int(KEEP(379),8)*int(KEEP(35),8) .GE. & int(huge(I4)-100,8)) THEN KEEP(379) = huge(KEEP(379))-100 ENDIF IF ( int(KEEP(380),8)*int(KEEP(35),8) .GE. & int(huge(I4)-100,8)) THEN KEEP(380) = huge(KEEP(380))-100 ENDIF IF ( PROK ) THEN WRITE(MP,'(A,I16) ') & ' Estimated INTEGER space for factors :', & KEEP(26) WRITE(MP,'(A,I16) ') & ' INFO(3), est. real space to store factors :', & KEEP8(11) WRITE(MP,'(A,I16) ') & ' Estimated number of entries in factors :', & KEEP8(9) WRITE(MP,'(A,I16) ') & ' Current value of space relaxation parameter :', & KEEP(12) WRITE(MP,'(A,I16) ') & ' Estimated size of IS (In Core factorization):', & KEEP(29) WRITE(MP,'(A,I16) ') & ' Estimated size of S (In Core factorization):', & KEEP8(13) WRITE(MP,'(A,I16) ') & ' Estimated size of S (OOC factorization) :', & KEEP8(17) END IF ELSE ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 KEEP8(13) = 0_8 KEEP(29) = 0 KEEP8(17)= 0_8 INFO(19) = 0 KEEP8(11) = 0_8 KEEP8(81) = 0_8 KEEP8(82) = 0_8 KEEP(26) = 0 KEEP(27) = 0 RINFO(1) = 0.0E0 K8_33relaxed = 0_8 K8_34relaxed = 0_8 K8_35relaxed = 0_8 K8_50relaxed = 0_8 IF (KEEP(400) .GT.0) THEN SUM_NIRNEC = 0 SUM_NIRADU = 0 SUM_NIRADU_OOC = 0 SUM_NIRNEC_OOC = 0 MAX_NRLADU = 0_8 MIN_NRLADU = 0_8 SUM_NRLADU = 0_8 SUM_NRLNEC = 0_8 SUM_NRLNEC_ACTIVE = 0_8 SUM_NRLADU_if_LR_LU = 0_8 SUM_NRLADULR_UD = 0_8 SUM_NRLADULR_WC = 0_8 ENDIF END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 CALL MUMPS_ALLREDUCEI8( ENTRIES_IN_FACTORS_LOC_MASTERS, & KEEP8(109), MPI_SUM, id%COMM) CALL MUMPS_ALLREDUCEI8( KEEP8(19), KEEP8(119), & MPI_MAX, id%COMM) CALL MPI_ALLREDUCE( KEEP(27), KEEP(127), 1, & MPI_INTEGER, MPI_MAX, & id%COMM, IERR) KEEP26_I8_TMP = int(KEEP(26),8) CALL MUMPS_ALLREDUCEI8( KEEP26_I8_TMP, & KEEP8(129), MPI_SUM, id%COMM) CALL MUMPS_REDUCEI8( KEEP8(11), & KEEP8(111), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4( KEEP8(111), INFOG(3) ) RINFO(5) = real(KEEP8(32) & *int(KEEP(35),8))/1E6 CALL MUMPS_REDUCEI8( KEEP8(32), & ITMP8, MPI_SUM, & MASTER, id%COMM ) IF (id%MYID.EQ.MASTER) THEN RINFOG(15) = real(ITMP8*int(KEEP(35),8))/1E6 ENDIF CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1, & MPI_REAL, MPI_SUM, & id%COMM, IERR) CALL MUMPS_SETI8TOI4( KEEP8(11), INFO(3) ) INFO ( 4 ) = KEEP( 26 ) INFO ( 5 ) = KEEP( 27 ) INFO ( 7 ) = KEEP( 29 ) CALL MUMPS_SETI8TOI4( KEEP8(13), INFO(8) ) CALL MUMPS_SETI8TOI4( KEEP8(17), INFO(20) ) CALL MUMPS_SETI8TOI4( KEEP8(9), INFO(24) ) CALL MUMPS_SETI8TOI4( K8_33relaxed, INFO(29) ) CALL MUMPS_SETI8TOI4( K8_34relaxed, INFO(32) ) CALL MUMPS_SETI8TOI4( K8_35relaxed, INFO(33) ) CALL MUMPS_SETI8TOI4( K8_50relaxed, INFO(36) ) CALL MUMPS_SETI8TOI4( KEEP8(129), INFOG(4) ) INFOG( 5 ) = KEEP( 127 ) CALL MUMPS_SETI8TOI4( KEEP8(109), INFOG(20) ) CALL SMUMPS_DIAG_ANA(id%MYID, id%COMM, KEEP(1), KEEP8(1), & INFO(1), INFOG(1), RINFO(1), RINFOG(1), ICNTL(1), & id%SIZE_SCHUR ) IF (PROK) WRITE( MP, 112 ) IF (PROKG .AND. (MPG.NE.MP)) WRITE( MPG, 112 ) SUM_KEEP811_THIS_NODE=0_8 CALL MPI_REDUCE( KEEP8(11), SUM_KEEP811_THIS_NODE, 1, & MPI_INTEGER8, & MPI_SUM, 0, id%KEEP(411), IERR ) CALL MPI_REDUCE( SUM_KEEP811_THIS_NODE, MAX_SUM_KEEP811_THIS_NODE, & 1, MPI_INTEGER8, MPI_MAX, 0, id%COMM, IERR ) IF (PROKG .AND. PRINT_NODEINFO) THEN WRITE(MPG,'(A,I16)') & ' Max. estimated space for factors per compute node :', & MAX_SUM_KEEP811_THIS_NODE ENDIF OOC_STRAT = KEEP(201) BLR_STRAT = 0 IF (KEEP(201) .NE. -1) OOC_STRAT=0 PERLU_ON = .FALSE. CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, .FALSE., & .TRUE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF KEEP8(2) = TOTAL_BYTES PERLU_ON = .TRUE. CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, & id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, .FALSE., & .TRUE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF IF ( PROK ) THEN WRITE(MP,'(A,I16) ') & ' Estimated space in MBytes for IC factorization (INFO(15)):', & TOTAL_MBYTES END IF id%INFO(15) = TOTAL_MBYTES CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(15), id%INFOG(16), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I16) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(16)):', & id%INFOG(16) ENDIF WRITE(MPG,'(A,I16) ') & ' Total space in MBytes, IC factorization (INFOG(17)):' & ,id%INFOG(17) END IF SUM_INFO15_THIS_NODE=0 CALL MPI_REDUCE( INFO(15), SUM_INFO15_THIS_NODE, 1, MPI_INTEGER, & MPI_SUM, 0, id%KEEP(411), IERR ) CALL MPI_REDUCE( SUM_INFO15_THIS_NODE, MAX_SUM_INFO15_THIS_NODE, & 1, MPI_INTEGER, MPI_MAX, 0, id%COMM, IERR ) IF ( PROKG .AND. PRINT_NODEINFO ) THEN WRITE(MPG,'(A,I16)') & ' Max. estim. space per compute node, in MBytes, IC fact :', & MAX_SUM_INFO15_THIS_NODE ENDIF OOC_STRAT = KEEP(201) BLR_STRAT = 0 #if defined(OLD_OOC_NOPANEL) IF (OOC_STRAT .NE. -1) OOC_STRAT=2 #else IF (OOC_STRAT .NE. -1) OOC_STRAT=1 #endif PERLU_ON = .FALSE. CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, .FALSE., & .TRUE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF KEEP8(3) = TOTAL_BYTES PERLU_ON = .TRUE. CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, .FALSE., & .TRUE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF id%INFO(17) = TOTAL_MBYTES CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(17), id%INFOG(26), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I16) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(26)):', & id%INFOG(26) ENDIF WRITE(MPG,'(A,I16) ') & ' Total space in MBytes, OOC factorization (INFOG(27)):' & ,id%INFOG(27) END IF SUM_INFO17_THIS_NODE=0 CALL MPI_REDUCE( INFO(17), SUM_INFO17_THIS_NODE, 1, MPI_INTEGER, & MPI_SUM, 0, id%KEEP(411), IERR ) CALL MPI_REDUCE( SUM_INFO17_THIS_NODE, MAX_SUM_INFO17_THIS_NODE, & 1, MPI_INTEGER, MPI_MAX, 0, id%COMM, IERR ) IF (PROKG .AND. PRINT_NODEINFO) THEN WRITE(MPG,'(A,I16)') & ' Max. estim. space per compute node, in MBytes, OOC fact :', & MAX_SUM_INFO17_THIS_NODE ENDIF IF (KEEP(494).NE.0) THEN SUM_OF_PEAKS = .TRUE. CALL SMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, & KEEP(1), KEEP8(1), & id%MYID, id%COMM, & id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), id%NSLAVES, & id%INFO, id%INFOG, PROK, MP, PROKG, MPG & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) END IF 500 CONTINUE IF (allocated(TNSTK_afterL0)) DEALLOCATE(TNSTK_afterL0) IF (allocated(FLAGGED_LEAVES)) DEALLOCATE(FLAGGED_LEAVES) IF (INFO(1) .LT. 0) THEN IF (associated(id%IPOOL_B_L0_OMP)) THEN DEALLOCATE(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_B_L0_OMP) ENDIF IF (associated(id%IPOOL_A_L0_OMP)) THEN DEALLOCATE(id%IPOOL_A_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) ENDIF IF (associated(id%VIRT_L0_OMP)) THEN DEALLOCATE(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP) ENDIF IF (associated(id%VIRT_L0_OMP_MAPPING)) THEN DEALLOCATE(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%VIRT_L0_OMP_MAPPING) ENDIF IF (associated(id%PERM_L0_OMP)) THEN DEALLOCATE(id%PERM_L0_OMP) NULLIFY(id%PERM_L0_OMP) ENDIF IF (associated(id%PTR_LEAFS_L0_OMP)) THEN DEALLOCATE(id%PTR_LEAFS_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) ENDIF ENDIF RETURN 112 FORMAT(/' MEMORY ESTIMATIONS ... '/ & ' Estimations with standard Full-Rank (FR) factorization:') 150 FORMAT( & /' ** FAILURE DURING SMUMPS_ANA_DRIVER, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE SMUMPS_ANA_COMPUTE_ESTIMATES SUBROUTINE SMUMPS_ANA_DISTM(MYID, N, STEP, FRERE, FILS, IPOOL, & LIPOOL, NE, DAD, ND, PROCNODE, SLAVEF, ABOVE_L0, SIZECB_UNDER_L0, & SIZECB_UNDER_L0_IF_LRCB, MAXFR_UNDER_L0, & MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_LO, OPSA_UNDER_L0, PEAK_FR, PEAK_FR_OOC, & NRLADU, NIRADU, NIRNEC, NRLNEC, NRLNEC_ACTIVE, & NRLADU_if_LR_LU, NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, NRLNEC_if_LR_CB, NRLADULR_UD, NRLADULR_WC, & NRLNECLR_CB_UD, NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC, & PEAK_LRLU_UD,PEAK_OOC_LRLU_UD,PEAK_OOC_LRLU_WC, PEAK_LRLUCB_UD, & PEAK_LRLUCB_WC,PEAK_OOC_LRLUCB_UD, PEAK_OOC_LRLUCB_WC, & PEAK_LRCB_UD, PEAK_OOC_LRCB_UD, NIRADU_OOC, NIRNEC_OOC, MAXFR, & OPSA, UU, KEEP,KEEP8, LOCAL_M, LOCAL_N, SBUF_RECOLD, & SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR, SBUF_REC_LR, & OPS_SUBTREE, NSTEPS, I_AM_CAND,NMB_PAR2, ISTEP_TO_INIV2, & CANDIDATES, IFLAG, IERROR, MAX_FRONT_SURFACE_LOCAL, & MAX_SIZE_FACTOR, ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS, ROOT_yes, ROOT_NPROW, ROOT_NPCOL & ) USE SMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE IMPLICIT NONE LOGICAL, intent(in) :: ROOT_yes INTEGER, intent(in) :: ROOT_NPROW, ROOT_NPCOL INTEGER, intent(in) :: MYID, N, LIPOOL LOGICAL, intent(in) :: ABOVE_L0 INTEGER, intent(in) :: MAXFR_UNDER_L0 INTEGER(8), intent(in) :: MAX_FRONT_SURFACE_LOCAL_L0, & MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO DOUBLE PRECISION, intent(in) :: COST_SUBTREES_UNDER_LO, & OPSA_UNDER_L0 INTEGER(8), intent(inout) :: SIZECB_UNDER_L0, & SIZECB_UNDER_L0_IF_LRCB INTEGER, intent(inout) :: IFLAG, IERROR INTEGER NIRADU, NIRNEC INTEGER(8) NRLADU, NRLNEC, NRLNEC_ACTIVE INTEGER(8), intent(out) :: NRLADU_if_LR_LU, & NRLADULR_UD, NRLADULR_WC, & NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, NRLNEC_if_LR_CB, & NRLNECOOC_if_LR_LUCB, NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC INTEGER(8), intent(out):: & PEAK_FR, PEAK_FR_OOC, & PEAK_LRLU_UD, & PEAK_OOC_LRLU_UD, PEAK_OOC_LRLU_WC, & PEAK_LRLUCB_UD, PEAK_LRLUCB_WC, & PEAK_OOC_LRLUCB_UD, PEAK_OOC_LRLUCB_WC, & PEAK_LRCB_UD, PEAK_OOC_LRCB_UD INTEGER(8) NRLADU_CURRENT, NRLADU_ROOT_3 INTEGER NIRADU_OOC, NIRNEC_OOC INTEGER MAXFR, NSTEPS INTEGER(8) MAX_FRONT_SURFACE_LOCAL INTEGER STEP(N) INTEGER FRERE(NSTEPS), FILS(N), IPOOL(max(LIPOOL,1)), NE(NSTEPS), & ND(NSTEPS), PROCNODE(NSTEPS), DAD(NSTEPS) REAL UU INTEGER SLAVEF, KEEP(500), LOCAL_M, LOCAL_N INTEGER(8) KEEP8(150) INTEGER(8) ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS INTEGER SBUF_SEND_FR, SBUF_REC_FR INTEGER SBUF_SEND_LR, SBUF_REC_LR INTEGER(8) SBUF_RECOLD INTEGER NMB_PAR2 INTEGER ISTEP_TO_INIV2( KEEP(71) ) LOGICAL I_AM_CAND(NMB_PAR2) INTEGER CANDIDATES( SLAVEF+1, NMB_PAR2 ) INTEGER PHASE PARAMETER (PHASE=0) REAL OPSA DOUBLE PRECISION OPSA_LOC INTEGER(8) MAX_SIZE_FACTOR REAL OPS_SUBTREE DOUBLE PRECISION OPS_SBTR_LOC INTEGER, ALLOCATABLE, DIMENSION(:) :: TNSTK, LSTKI INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR_if_LRCB, & LSTKRLR_CB_UD, & LSTKRLR_CB_WC LOGICAL OUTER_SENDS_FR INTEGER(8) :: SAVE_SIZECB_UNDER_L0, & SAVE_SIZECB_UNDER_L0_IF_LRCB INTEGER SBUFR_FR, SBUFS_FR INTEGER SBUFR_LR, SBUFS_LR INTEGER(8) SBUFS_CB, SBUFR_CB INTEGER ITOP,NELIM,NFR INTEGER(8) ISTKR, LSTK INTEGER(8) :: NRLADU_CURRENT_MISSING INTEGER(8) :: NRLADU_CURRENT_K60_1 LOGICAL :: I_PROCESS_SCHUR_K60_1 INTEGER(8) :: ISTKR_if_LRCB, ISTKRLR_CB_UD, ISTKRLR_CB_WC, & K464_8, K465_8 INTEGER :: LRSTATUS, IDUMMY INTEGER :: NBNODES_BLR LOGICAL :: COMPRESS_PANEL, COMPRESS_CB INTEGER ISTKI, STKI, ISTKI_OOC INTEGER K,NSTK, IFATH INTEGER INODE, LEAF, IN INTEGER LEVEL, MAXITEMPCB INTEGER(8) CURRENT_ACTIVE_MEM, MAXTEMPCB LOGICAL UPDATE, UPDATEF, MASTER, MASTERF, INSSARBR INTEGER LEVELF, NCB, SIZECBI INTEGER(8) NCB8 INTEGER(8) NFR8, NELIM8 INTEGER(8) :: SIZEFRNOCBLU INTEGER :: IDUMMY_ARRAY(1) INTEGER(8) SIZECB, SIZECBINFR, SIZECB_SLAVE INTEGER(8) SIZECB_if_LRCB, SIZECB_SLAVE_if_LRCB INTEGER(8) SIZECBLR_SLAVE_UD, SIZECBLR_SLAVE_WC INTEGER(8) SIZECBLR_UD, SIZECBLR_WC INTEGER(8) SIZECBSLR, NCBS8, & SIZECBS, SIZECBINFRS INTEGER NFRS, NELIMS, NCBS, LEVELS, LRSTATUSS LOGICAL COMPRESS_CBS INTEGER(8) :: PEAK_DYN_LRLU_UD, PEAK_DYN_LRCB_UD, & PEAK_DYN_LRLUCB_UD, PEAK_DYN_LRLU_WC, & PEAK_DYN_LRLUCB_WC INTEGER SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC INTEGER EXTRA_PERM_INFO_OOC INTEGER NBROWMAX, NSLAVES_LOC, NSLAVES_PASSED, & NELIMF, NFRF, NCBF, & NBROWMAXF, LKJIB_FR, LKJIB_LR, & NBR, NBCOLFAC INTEGER(8) LEV3MAXREC, CBMAXR, CBMAXS INTEGER ALLOCOK INTEGER PANEL_SIZE LOGICAL PACKED_CB DOUBLE PRECISION OPS_NODE, OPS_NODE_MASTER, OPS_NODE_SLAVE INTEGER(8) ENTRIES_NODE_UPPER_PART, ENTRIES_NODE_LOWER_PART INTEGER :: FLAG_L0OMP PARAMETER (FLAG_L0OMP=-2014) INCLUDE 'mumps_headers.h' LOGICAL ROOT_OWNER INTEGER(8) LWK_RR INTEGER LIWK_RR INTEGER IROOT, SIZE_ROOT INTEGER WHAT INTEGER(8) IDUMMY8 INTRINSIC min, int INTRINSIC real INTEGER SMUMPS_OOC_GET_PANEL_SIZE EXTERNAL SMUMPS_OOC_GET_PANEL_SIZE INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR EXTERNAL MUMPS_MAX_SURFCB_NBROWS EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, & MUMPS_IN_OR_ROOT_SSARBR logical :: FORCE_CAND, CONCERNED, UPDATES, STACKCB, MASTERSON integer :: IFSON, LEVELSON IDUMMY_ARRAY(1) = 0 IF (KEEP(50).eq.2) THEN EXTRA_PERM_INFO_OOC = 1 ELSE IF (KEEP(50).eq.0) THEN EXTRA_PERM_INFO_OOC = 2 ELSE EXTRA_PERM_INFO_OOC = 0 ENDIF PACKED_CB=( KEEP(215).EQ.0 .AND. KEEP(50).NE.0 ) MAX_FRONT_SURFACE_LOCAL=0_8 MAX_SIZE_FACTOR=0_8 ALLOCATE( LSTKR(NSTEPS), TNSTK(NSTEPS), & LSTKI(NSTEPS) , & LSTKR_if_LRCB(NSTEPS), LSTKRLR_CB_UD(NSTEPS), & LSTKRLR_CB_WC(NSTEPS), & stat=ALLOCOK) if (ALLOCOK .GT. 0) THEN IFLAG =-7 IERROR = 6*NSTEPS RETURN endif LKJIB_FR = max(KEEP(5),KEEP(6)) OUTER_SENDS_FR = (KEEP(263).NE.0 .OR. & KEEP(50).EQ.0. AND. (KEEP(468).LT.3 .OR. UU.EQ.0.0E0)) IF ( OUTER_SENDS_FR ) THEN LKJIB_FR = max(LKJIB_FR, KEEP(420)) ENDIF LKJIB_LR = max(LKJIB_FR,KEEP(142)) IF (KEEP(198).NE.0.AND.SLAVEF.GT.1) THEN LKJIB_FR = min(LKJIB_FR*KEEP(179), KEEP(435)) ENDIF TNSTK = NE LEAF = LIPOOL+1 #if defined(OLD_OOC_NOPANEL) XSIZE_OOC=XSIZE_OOC_NOPANEL #else IF (KEEP(50).EQ.0) THEN XSIZE_OOC=XSIZE_OOC_UNSYM ELSE XSIZE_OOC=XSIZE_OOC_SYM ENDIF #endif SIZEHEADER_OOC = XSIZE_OOC+6 SIZEHEADER = XSIZE_IC + 6 ISTKR_if_LRCB = 0_8 ISTKRLR_CB_UD = 0_8 ISTKRLR_CB_WC = 0_8 ISTKR = 0_8 ISTKI = 0 ISTKI_OOC = 0 NBNODES_BLR = 0 OPSA_LOC = 0.0D0 ENTRIES_IN_FACTORS_LOC = 0_8 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 OPS_SBTR_LOC = 0.0D0 NRLADU = 0_8 NIRADU = 0 NIRADU_OOC = 0 NRLADU_CURRENT_K60_1 = 0_8 I_PROCESS_SCHUR_K60_1 = .FALSE. NRLADU_CURRENT = 0_8 NRLADULR_UD = 0_8 NRLADULR_WC = 0_8 NRLADU_ROOT_3 = 0_8 NRLNEC_ACTIVE = 0_8 IF (ABOVE_L0) THEN SAVE_SIZECB_UNDER_L0 = SIZECB_UNDER_L0 SAVE_SIZECB_UNDER_L0_IF_LRCB = SIZECB_UNDER_L0_IF_LRCB ELSE SAVE_SIZECB_UNDER_L0 = 0_8 SAVE_SIZECB_UNDER_L0_IF_LRCB = 0_8 ENDIF PEAK_DYN_LRLU_UD = SAVE_SIZECB_UNDER_L0 PEAK_DYN_LRCB_UD = SAVE_SIZECB_UNDER_L0_IF_LRCB PEAK_DYN_LRLUCB_UD = SAVE_SIZECB_UNDER_L0_IF_LRCB PEAK_DYN_LRLU_WC = SAVE_SIZECB_UNDER_L0 PEAK_DYN_LRLUCB_WC = SAVE_SIZECB_UNDER_L0 NRLNEC = 0_8 NRLADU_if_LR_LU = 0_8 NRLNEC_if_LR_LU = 0_8 NRLNEC_if_LR_CB = 0_8 NRLNEC_if_LR_LUCB = 0_8 NRLNECOOC_if_LR_LUCB = 0_8 NRLNECLR_CB_UD = 0_8 NRLNECLR_LUCB_UD = 0_8 NRLNECLR_LUCB_WC = 0_8 NIRNEC = 0 NIRNEC_OOC = 0 MAXFR = 0 PEAK_FR = 0_8 PEAK_FR_OOC = 0_8 PEAK_LRLU_UD = 0_8 PEAK_OOC_LRLU_UD = 0_8 PEAK_OOC_LRLU_WC = 0_8 PEAK_LRLUCB_UD = 0_8 PEAK_LRLUCB_WC = 0_8 PEAK_OOC_LRLUCB_UD= 0_8 PEAK_OOC_LRLUCB_WC= 0_8 PEAK_LRCB_UD = 0_8 PEAK_OOC_LRCB_UD = 0_8 ITOP = 0 MAXTEMPCB = 0_8 MAXITEMPCB = 0 SBUFS_CB = 1_8 SBUFS_FR = 1 SBUFS_LR = 1 SBUFR_CB = 1_8 SBUFR_FR = 1 SBUFR_LR = 1 IF (KEEP(38) .NE. 0 .AND. KEEP(60).EQ.0) THEN INODE = KEEP(38) NRLADU_ROOT_3 = int(LOCAL_M,8)*int(LOCAL_N,8) NRLADU = NRLADU_ROOT_3 NRLNEC_ACTIVE = NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_ROOT_3) NRLNEC = NRLADU NRLADU_if_LR_LU = NRLADU_ROOT_3 NRLNECOOC_if_LR_LUCB = NRLNEC_ACTIVE NRLNEC_if_LR_LU = NRLADU NRLNEC_if_LR_CB = NRLADU NRLNEC_if_LR_LUCB = NRLADU PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD + SIZECB_UNDER_L0) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF IF (MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID) THEN NIRADU = SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) NIRADU_OOC = SIZEHEADER_OOC+2*(ND(STEP(INODE))+KEEP(253)) ELSE NIRADU = SIZEHEADER NIRADU_OOC = SIZEHEADER_OOC ENDIF NIRNEC = NIRADU NIRNEC_OOC = NIRADU_OOC ENDIF IF((KEEP(24).eq.0).OR.(KEEP(24).eq.1)) THEN FORCE_CAND=.FALSE. ELSE FORCE_CAND=(mod(KEEP(24),2).eq.0) END IF 90 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF - 1 INODE = IPOOL(LEAF) ELSE IF (LIPOOL.NE.0) THEN WRITE(MYID+6,*) ' ERROR 1 in SMUMPS_ANA_DISTM ' CALL MUMPS_ABORT() ELSE GOTO 115 ENDIF ENDIF 95 CONTINUE NFR = ND(STEP(INODE))+KEEP(253) NFR8 = int(NFR,8) NSTK = NE(STEP(INODE)) NELIM = 0 IN = INODE 100 NELIM = NELIM + 1 NELIM8=int(NELIM,8) IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IFSON = -IN IFATH = DAD(STEP(INODE)) MASTER = MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID LEVEL = MUMPS_TYPENODE(PROCNODE(STEP(INODE)),KEEP(199)) INSSARBR = MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) UPDATE=.FALSE. if(.NOT.FORCE_CAND) then UPDATE = ( (MASTER.AND.(LEVEL.NE.3) ).OR. LEVEL.EQ.2 ) else if(MASTER.and.(LEVEL.ne.3)) then UPDATE = .TRUE. else if(LEVEL.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(INODE)))) THEN UPDATE = .TRUE. end if end if end if NCB = NFR-NELIM NCB8 = int(NCB,8) SIZECBINFR = NCB8*NCB8 IF (KEEP(50).EQ.0) THEN SIZECB = SIZECBINFR ELSE IFATH = DAD(STEP(INODE)) IF ( IFATH.NE.KEEP(38) .AND. PACKED_CB ) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = SIZECBINFR ENDIF ENDIF IDUMMY = -99999 CALL IS_FRONT_BLR_CANDIDATE (INODE, LEVEL, NFR, NELIM, & KEEP(494), 1, KEEP(490), & KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, IDUMMY) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) IF (COMPRESS_PANEL.OR.COMPRESS_CB) NBNODES_BLR = NBNODES_BLR+1 IF (COMPRESS_PANEL) THEN K464_8 = int(KEEP(464),8) ELSE K464_8 = 1000_8 ENDIF IF (COMPRESS_CB) THEN K465_8 = int(KEEP(465),8) SIZECB_if_LRCB = 0_8 SIZECBLR_UD = SIZECB*K465_8/1000_8 SIZECBLR_WC = SIZECB ELSE K465_8 = 1000_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = SIZECB ENDIF SIZECBI = 2* NCB + SIZEHEADER IF (LEVEL.NE.2) THEN NSLAVES_LOC = -99999999 SIZECB_SLAVE = -99999997_8 SIZECB_SLAVE_if_LRCB = SIZECB_SLAVE NBROWMAX = NCB ELSE IF (KEEP(48) .EQ. 5) THEN WHAT = 5 IF (FORCE_CAND) THEN NSLAVES_LOC=CANDIDATES(SLAVEF+1, & ISTEP_TO_INIV2(STEP(INODE))) ELSE NSLAVES_LOC=SLAVEF-1 ENDIF NSLAVES_PASSED=NSLAVES_LOC ELSE WHAT = 2 NSLAVES_PASSED=SLAVEF NSLAVES_LOC =SLAVEF-1 ENDIF CALL MUMPS_MAX_SURFCB_NBROWS(WHAT, KEEP,KEEP8, & NCB, NFR, NSLAVES_PASSED, NBROWMAX, SIZECB_SLAVE & ) IF (COMPRESS_CB) THEN SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_SLAVE_UD = SIZECB_SLAVE*K465_8/1000_8 SIZECBLR_SLAVE_WC = SIZECB_SLAVE ELSE SIZECB_SLAVE_if_LRCB = SIZECB_SLAVE SIZECBLR_SLAVE_UD = 0_8 SIZECBLR_SLAVE_WC = 0_8 ENDIF ENDIF IF (KEEP(60).GT.1) THEN IF (MASTER .AND. INODE.EQ.KEEP(38)) THEN NIRADU = NIRADU+SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC+ & 2*(ND(STEP(INODE))+KEEP(253)) ENDIF ENDIF IF (LEVEL.EQ.3) THEN IF ( & KEEP(60).LE.1 & ) THEN NRLADU_CURRENT = int(LOCAL_M,8)*int(LOCAL_N,8) NRLNEC = max(NRLNEC,NRLADU+ISTKR+ & NRLADU_CURRENT) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR+ & NRLADU_CURRENT) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB , & NRLADU+ISTKR_if_LRCB+ & NRLADU_CURRENT) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU+ISTKR_if_LRCB+ & NRLADU_CURRENT) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR_if_LRCB) PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF ENDIF IF (MASTER) THEN IF (NFR.GT.MAXFR) MAXFR = NFR ENDIF ENDIF IF(KEEP(86).EQ.1)THEN IF(MASTER.AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)), KEEP(199))) & )THEN IF(LEVEL.EQ.1)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8) IF (KEEP(268).NE.0) THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8+NELIM8) ENDIF ELSEIF(LEVEL.EQ.2)THEN IF(KEEP(50).EQ.0)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NELIM8) ELSE MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NELIM8*NELIM8) IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NELIM8*(NELIM8+1_8)) ENDIF ENDIF ENDIF ENDIF ENDIF IF (LEVEL.EQ.2) THEN IF (MASTER) THEN IF (KEEP(50).EQ.0) THEN SBUFS_FR = max(SBUFS_FR, NFR*LKJIB_FR+LKJIB_FR+4) SBUFS_LR = max(SBUFS_LR, NFR*LKJIB_LR+LKJIB_LR+4) ELSE SBUFS_FR = max(SBUFS_FR, NELIM*LKJIB_FR+NELIM+6) SBUFS_LR = max(SBUFS_LR, NELIM*LKJIB_LR+NELIM+6) ENDIF ELSEIF (UPDATE) THEN if (KEEP(50).EQ.0) THEN SBUFR_FR = max(SBUFR_FR, NFR*LKJIB_FR+LKJIB_FR+4) SBUFR_LR = max(SBUFR_LR, NFR*LKJIB_LR+LKJIB_LR+4) else SBUFR_FR = max( SBUFR_FR, NELIM*LKJIB_FR+NELIM+6 ) SBUFR_LR = max( SBUFR_LR, NELIM*LKJIB_LR+NELIM+6 ) SBUFS_FR = max( SBUFS_FR, NBROWMAX*LKJIB_FR+6 ) SBUFS_LR = max( SBUFS_LR, NBROWMAX*LKJIB_LR+6 ) SBUFR_FR = max( SBUFR_FR, NBROWMAX*LKJIB_FR+6 ) SBUFR_LR = max( SBUFR_LR, NBROWMAX*LKJIB_LR+6 ) endif ENDIF ENDIF IF ( UPDATE ) THEN IF ( (MASTER) .AND. (LEVEL.EQ.1) ) THEN NIRADU = NIRADU + 2*NFR + SIZEHEADER NIRADU_OOC = NIRADU_OOC + 2*NFR + SIZEHEADER_OOC PANEL_SIZE = SMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NFR, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) IF (KEEP(50).EQ.0) THEN IF (KEEP(251) .EQ. 2) THEN NRLADU_CURRENT = int(NELIM,8) * int(NFR,8) SIZEFRNOCBLU = int(NFR-NELIM,8)*int(NELIM) ELSE NRLADU_CURRENT = int(NELIM,8)*int(2*NFR-NELIM,8) SIZEFRNOCBLU = 0_8 ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR = max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ELSE IF ( KEEP(459) .GT. 1 .AND. KEEP(50).NE.0 ) THEN CALL MUMPS_LDLTPANEL_STORAGE( NELIM, KEEP, & IDUMMY_ARRAY(1), NRLADU_CURRENT ) SIZEFRNOCBLU = int(NELIM,8)*int(NELIM,8) - & NRLADU_CURRENT NRLADU_CURRENT = NRLADU_CURRENT + & int(NELIM,8) * int(NFR-NELIM,8) ELSE SIZEFRNOCBLU = 0_8 NRLADU_CURRENT = int(NELIM,8)*int(NFR,8) ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ENDIF IF (INODE.EQ.KEEP(20).AND.(KEEP(60).EQ.1)) THEN I_PROCESS_SCHUR_K60_1 = .TRUE. NRLADU_CURRENT_K60_1 = NRLADU_CURRENT ENDIF IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_CURRENT_MISSING = 0_8 NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT ENDIF SIZECBI = 2* NCB + SIZEHEADER ELSEIF (LEVEL.EQ.2) THEN IF (MASTER) THEN NIRADU = NIRADU+SIZEHEADER +SLAVEF-1+2*NFR NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC +SLAVEF-1+2*NFR IF (KEEP(50).EQ.0) THEN NRLADU_CURRENT = int(NFR,8)*int(NELIM,8) SIZEFRNOCBLU = 0_8 NBCOLFAC = NFR ELSE NBCOLFAC = NELIM IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 ) THEN CALL MUMPS_LDLTPANEL_STORAGE( NELIM, KEEP, & IDUMMY_ARRAY(1), NRLADU_CURRENT ) SIZEFRNOCBLU = int(NELIM,8)*int(NELIM,8) - & NRLADU_CURRENT ELSE SIZEFRNOCBLU = 0_8 NRLADU_CURRENT = int(NELIM,8)*int(NELIM,8) ENDIF ENDIF PANEL_SIZE = SMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NBCOLFAC, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) NRLADU = NRLADU + NRLADU_CURRENT IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_CURRENT_MISSING = 0_8 NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT ENDIF MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) SIZECB = 0_8 SIZECBINFR = 0_8 SIZECB_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECB=SIZECB_SLAVE SIZECBINFR = SIZECB NIRADU = NIRADU+4+NELIM+NBROWMAX NIRADU_OOC = NIRADU_OOC+4+NELIM+NBROWMAX IF (KEEP(50).EQ.0) THEN IF (KEEP(251) .EQ. 2) THEN NRLADU_CURRENT = 0_8 SIZEFRNOCBLU = int(NELIM,8)*int(NBROWMAX,8) ELSE NRLADU_CURRENT = int(NELIM,8)*int(NBROWMAX,8) SIZEFRNOCBLU = 0_8 ENDIF ELSE NRLADU_CURRENT = int(NELIM,8)*int(NCB/NSLAVES_LOC,8) SIZEFRNOCBLU = 0_8 ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_CURRENT_MISSING = 0_8 NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT ENDIF IF (KEEP(50).EQ.0) THEN SIZECBI = 7 + NBROWMAX + NCB ELSE SIZECBI = 8 + NBROWMAX + NCB ENDIF IF (KEEP(50).NE.0) THEN SIZECBI=SIZECBI+NSLAVES_LOC+ & XTRA_SLAVES_SYM ELSE SIZECBI=SIZECBI+NSLAVES_LOC+ & XTRA_SLAVES_UNSYM ENDIF ENDIF ENDIF NIRNEC = max(NIRNEC, & NIRADU+ISTKI+SIZECBI+MAXITEMPCB) NIRNEC_OOC = max(NIRNEC_OOC, & NIRADU_OOC+ISTKI_OOC+SIZECBI+MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) CURRENT_ACTIVE_MEM = ISTKR+SIZECBINFR IF ( KEEP(50).NE.0 .AND. LEVEL.EQ.1 ) THEN SIZEFRNOCBLU = SIZEFRNOCBLU + int(NELIM,8)*int(NCB,8) ENDIF CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + SIZEFRNOCBLU IF (MASTER .AND. KEEP(219).NE.0.AND. & KEEP(50).EQ.2.AND.LEVEL.EQ.2) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + int(NELIM,8) ENDIF IF (SLAVEF.EQ.1) THEN NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = & max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & MAXTEMPCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING+ & MAXTEMPCB) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & MAXTEMPCB) ENDIF IF (NSTK .NE. 0 .AND. INSSARBR .AND. & KEEP(234).NE.0 .AND. KEEP(55).EQ.0) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTKR(ITOP) ENDIF IF (SLAVEF.EQ.1) THEN NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT_MISSING) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+MAXTEMPCB+ & NRLADU_CURRENT_MISSING) ENDIF NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF IF (NFR.GT.MAXFR) MAXFR = NFR IF (ABOVE_L0.AND.MASTER.AND.(LEVEL.EQ.1)) THEN DO WHILE (IFSON.GT.0) IF (TNSTK(STEP(IFSON)).EQ.FLAG_L0OMP) THEN LEVELS = MUMPS_TYPENODE(PROCNODE(STEP(IFSON)),KEEP(199)) NFRS = ND(STEP(IFSON))+KEEP(253) NELIMS= 0 IN = IFSON DO WHILE (IN.GT.0) IN = FILS(IN) NELIMS = NELIMS + 1 ENDDO NCBS = NFRS-NELIMS NCBS8 = int(NCBS,8) SIZECBINFRS = NCBS8*NCBS8 IF (KEEP(50).EQ.0) THEN SIZECBS = SIZECBINFRS ELSE IF ( PACKED_CB ) THEN SIZECBS = (NCBS8*(NCBS8+1_8))/2_8 ELSE SIZECBS = SIZECBINFRS ENDIF ENDIF IDUMMY = -99999 CALL IS_FRONT_BLR_CANDIDATE & (IFSON, LEVELS, NFRS, NELIMS, & KEEP(494), 1, KEEP(490), & KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(IFSON)), KEEP(38), & KEEP(123), LRSTATUSS, IDUMMY) COMPRESS_CBS = ((LRSTATUSS.EQ.1).OR.(LRSTATUSS.EQ.3)) IF (COMPRESS_CBS) THEN K465_8 = int(KEEP(465),8) SIZECBSLR = SIZECBS*K465_8/1000_8 ELSE SIZECBSLR = SIZECBS ENDIF SIZECB_UNDER_L0 = SIZECB_UNDER_L0 - SIZECBS SIZECB_UNDER_L0_IF_LRCB = SIZECB_UNDER_L0_IF_LRCB & - SIZECBSLR ENDIF IFSON = FRERE(STEP(IFSON)) ENDDO ENDIF IF (NSTK.GT.0) THEN DO 70 K=1,NSTK LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK IF (K==1 .AND. INSSARBR.AND.KEEP(234).NE.0 & .AND.KEEP(55).EQ.0) THEN ELSE CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTK ENDIF LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in SMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF 70 CONTINUE ENDIF ELSE IF (LEVEL.NE.3) THEN DO WHILE (IFSON.GT.0) UPDATES=.FALSE. MASTERSON = MUMPS_PROCNODE(PROCNODE(STEP(IFSON)),KEEP(199)) & .EQ.MYID LEVELSON = MUMPS_TYPENODE(PROCNODE(STEP(IFSON)),KEEP(199)) if(.NOT.FORCE_CAND) then UPDATES =((MASTERSON.AND.(LEVELSON.NE.3)).OR. & LEVELSON.EQ.2) else if(MASTERSON.and.(LEVELSON.ne.3)) then UPDATES = .TRUE. else if(LEVELSON.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFSON)))) then UPDATES = .TRUE. end if end if end if IF (UPDATES) THEN LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in SMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF ENDIF IFSON = FRERE(STEP(IFSON)) END DO ENDIF IF ( & ( (INODE.NE.KEEP(20)).OR.(KEEP(60).EQ.0) ) & .AND. & ( (INODE.NE.KEEP(38)).OR.(KEEP(60).LE.1) ) & ) & THEN ENTRIES_NODE_LOWER_PART = int(NFR-NELIM,8) * int(NELIM,8) IF ( KEEP(50).EQ.0 ) THEN ENTRIES_NODE_UPPER_PART = int(NFR,8) * int(NELIM,8) ELSE ENTRIES_NODE_UPPER_PART = & (int(NELIM,8)*int(NELIM+1,8))/2_8 ENDIF IF (KEEP(50).EQ.2 .AND. LEVEL.EQ.3) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM, 0, & 1,OPS_NODE) ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) ENDIF IF (LEVEL.EQ.2) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 2,OPS_NODE_MASTER) OPS_NODE_SLAVE=OPS_NODE-OPS_NODE_MASTER ENDIF ELSE OPS_NODE = 0.0D0 ENTRIES_NODE_UPPER_PART = 0_8 ENTRIES_NODE_LOWER_PART = 0_8 ENDIF IF ( MASTER ) THEN ENTRIES_IN_FACTORS_LOC_MASTERS = & ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ENDIF IF (UPDATE.OR.LEVEL.EQ.3) THEN IF ( LEVEL .EQ. 3 ) THEN IF (ROOT_yes) THEN OPSA_LOC = OPSA_LOC + & dble( & int(OPS_NODE,8)/ & int(ROOT_NPROW*ROOT_NPCOL,8) & ) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART / & int(ROOT_NPROW*ROOT_NPCOL,8) IF (MASTER) THEN ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & mod(ENTRIES_NODE_UPPER_PART, & int(SLAVEF,8)) ENDIF ENDIF ELSE IF (MASTER .AND. LEVEL.EQ.2) THEN OPSA_LOC = OPSA_LOC + OPS_NODE_MASTER ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART + & mod(ENTRIES_NODE_LOWER_PART, & int(NSLAVES_LOC,8)) ELSE IF (MASTER .AND. LEVEL.EQ.1) THEN OPSA_LOC = OPSA_LOC + OPS_NODE ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ELSE IF (UPDATE) THEN OPSA_LOC = OPSA_LOC + & dble(OPS_NODE_SLAVE)/dble(NSLAVES_LOC) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC & + ENTRIES_NODE_LOWER_PART / & int(NSLAVES_LOC,8) ENDIF IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) .OR. NE(STEP(INODE))==0) THEN IF (LEVEL == 1) THEN OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ENDIF ENDIF ENDIF IF (IFATH .EQ. 0) THEN IF (LEAF.GT.1) THEN GOTO 90 ELSE GOTO 115 ENDIF ELSE NFRF = ND(STEP(IFATH))+KEEP(253) IF (DAD(STEP(IFATH)).EQ.0) THEN NELIMF = NFRF-KEEP(253) IF (ABOVE_L0) IN=0 ELSE NELIMF = 0 IN = IFATH DO WHILE (IN.GT.0) IN = FILS(IN) NELIMF = NELIMF+1 ENDDO ENDIF NCBF = NFRF - NELIMF LEVELF = MUMPS_TYPENODE(PROCNODE(STEP(IFATH)),KEEP(199)) MASTERF= MUMPS_PROCNODE(PROCNODE(STEP(IFATH)), & KEEP(199)).EQ.MYID UPDATEF= .FALSE. if(.NOT.FORCE_CAND) then UPDATEF= ((MASTERF.AND.(LEVELF.NE.3)).OR.LEVELF.EQ.2) else if(MASTERF.and.(LEVELF.ne.3)) then UPDATEF = .TRUE. else if (LEVELF.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFATH)))) THEN UPDATEF = .TRUE. end if end if end if CONCERNED = UPDATEF .OR. UPDATE IF (LEVELF .NE. 2) THEN NBROWMAXF = -999999 ELSE IF (KEEP(48) .EQ. 5) THEN WHAT = 4 IF (FORCE_CAND) THEN NSLAVES_LOC=CANDIDATES(SLAVEF+1, & ISTEP_TO_INIV2(STEP(IFATH))) ELSE NSLAVES_LOC=SLAVEF-1 ENDIF ELSE WHAT = 1 NSLAVES_LOC=SLAVEF ENDIF CALL MUMPS_MAX_SURFCB_NBROWS( WHAT, KEEP, KEEP8, & NCBF, NFRF, NSLAVES_LOC, NBROWMAXF, IDUMMY8 & ) ENDIF IF(LEVEL.EQ.1.AND.UPDATE.AND. & (UPDATEF.OR.LEVELF.EQ.2) & .AND.LEVELF.NE.3) THEN IF ( INSSARBR .AND. KEEP(234).NE.0) THEN NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+SIZECB+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) ENDIF PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) 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,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) IF (.NOT.COMPRESS_PANEL) THEN NRLNEC_if_LR_LU = max( & NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT) NRLNEC_if_LR_CB = max( & NRLNEC_if_LR_CB ,NRLADU + & CURRENT_ACTIVE_MEM-ISTKR + & ISTKR_if_LRCB+NRLADU_CURRENT) NRLNEC_if_LR_LUCB = max( & NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR + & ISTKR_if_LRCB+NRLADU_CURRENT) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF ENDIF ENDIF IF (LEVELF.EQ.3) THEN IF (LEVEL.EQ.1) THEN LEV3MAXREC = int(min(NCB,LOCAL_M),8) * & int(min(NCB,LOCAL_N),8) ELSE LEV3MAXREC = min(SIZECB, & int(min(NBROWMAX,LOCAL_M),8) & *int(min(NCB,LOCAL_N),8)) ENDIF MAXTEMPCB = max(MAXTEMPCB, LEV3MAXREC) MAXITEMPCB = max(MAXITEMPCB,SIZECBI+SIZEHEADER) SBUFR_CB = max(SBUFR_CB, LEV3MAXREC+int(SIZECBI,8)) NIRNEC = max(NIRNEC,NIRADU+ISTKI+ & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) ENDIF IF (CONCERNED) THEN IF (LEVELF.EQ.2) THEN IF (UPDATE.AND.(LEVEL.NE.2.OR..NOT.MASTER)) THEN IF(MASTERF)THEN NBR = min(NBROWMAXF,NBROWMAX) ELSE NBR = min(max(NELIMF,NBROWMAXF),NBROWMAX) ENDIF IF (KEEP(50).EQ.0) THEN CBMAXS = int(NBR,8)*int(NCB,8) ELSE CBMAXS = int(NBR,8)*int(NCB,8) - & (int(NBR,8)*int(NBR-1,8))/2_8 ENDIF ELSE CBMAXS = 0_8 END IF IF (MASTERF) THEN IF (LEVEL.EQ.1) THEN IF (.NOT.UPDATE) THEN NBR = min(NELIMF, NCB) ELSE NBR = 0 ENDIF ELSE NBR = min(NELIMF, NBROWMAX) ENDIF IF (KEEP(50).EQ.0) THEN CBMAXR = int(NBR,8)*NCB8 ELSE CBMAXR = int(NBR,8)*int(min(NCB,NELIMF),8)- & (int(NBR,8)*int(NBR-1,8))/2_8 CBMAXR = min(CBMAXR, int(NELIMF,8)*int(NELIMF+1,8)/2_8) CBMAXR = min(CBMAXR, SIZECB) IF ((LEVEL.EQ.1).AND.(.NOT. PACKED_CB)) THEN CBMAXR = min(CBMAXR,(NCB8*(NCB8+1_8))/2_8) ENDIF ENDIF ELSE IF (UPDATEF) THEN NBR = min(NBROWMAXF,NBROWMAX) CBMAXR = int(NBR,8) * NCB8 IF (KEEP(50).NE.0) THEN CBMAXR = CBMAXR - (int(NBR,8)*(int(NBR-1,8)))/2_8 ENDIF ELSE CBMAXR = 0_8 ENDIF ELSEIF (LEVELF.EQ.3) THEN CBMAXR = LEV3MAXREC IF (UPDATE.AND. .NOT. (MASTER.AND.LEVEL.EQ.2)) THEN CBMAXS = LEV3MAXREC ELSE CBMAXS = 0_8 ENDIF ELSE IF (MASTERF) THEN CBMAXS = 0_8 NBR = min(NFRF,NBROWMAX) IF ((LEVEL.EQ.1).AND.UPDATE) THEN NBR = 0 ENDIF CBMAXR = int(NBR,8)*int(min(NFRF,NCB),8) IF (LEVEL.EQ.2) & CBMAXR = min(CBMAXR, SIZECB_SLAVE) IF ( KEEP(50).NE.0 ) THEN CBMAXR = min(CBMAXR,(int(NFRF,8)*int(NFRF+1,8))/2_8) ELSE CBMAXR = min(CBMAXR,int(NFRF,8)*int(NFRF,8)) ENDIF ELSE CBMAXR = 0_8 CBMAXS = SIZECB ENDIF ENDIF IF (UPDATE) THEN CBMAXS = min(CBMAXS, SIZECB) IF ( .not. ( LEVELF .eq. 1 .AND. UPDATEF ) )THEN SBUFS_CB = max(SBUFS_CB, CBMAXS+int(SIZECBI,8)) ENDIF ENDIF STACKCB = .FALSE. IF (UPDATEF) THEN STACKCB = .TRUE. SIZECBI = 2 * NCB + SIZEHEADER IF (LEVEL.EQ.1) THEN IF (KEEP(50).NE.0.AND.LEVELF.NE.3 & .AND.PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF IF (MASTER) THEN IF (MASTERF) THEN SIZECBI = 2+ XSIZE_IC ENDIF ELSE IF (LEVELF.EQ.1) THEN SIZECB = min(CBMAXR,SIZECB) IF (COMPRESS_CB) THEN SIZECBLR_UD = min(SIZECBLR_UD,SIZECB) SIZECBLR_WC = min(SIZECBLR_WC,SIZECB) SIZECB_if_LRCB = min(SIZECB_if_LRCB,SIZECB) ENDIF SIZECBI = 2 * NCB + 9 SBUFR_CB = max(SBUFR_CB, int(SIZECBI,8)+SIZECB) SIZECBI = 2 * NCB + SIZEHEADER ELSE SIZECBI = 2 * NCB + 9 SBUFR_CB = max(SBUFR_CB, & min(SIZECB,CBMAXR) + int(SIZECBI,8)) MAXTEMPCB = max(MAXTEMPCB, min(SIZECB,CBMAXR)) SIZECBI = 2 * NCB + SIZEHEADER MAXITEMPCB = max(MAXITEMPCB, SIZECBI) IF ( .NOT. MASTERF ) THEN SIZECBI = 0 ELSE SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ENDIF SIZECB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = 0_8 ENDIF ELSE SIZECB = SIZECB_SLAVE SIZECBLR_UD = SIZECBLR_SLAVE_UD SIZECBLR_WC = SIZECBLR_SLAVE_WC SIZECB_if_LRCB = SIZECB_SLAVE_if_LRCB MAXTEMPCB = max(MAXTEMPCB, min(CBMAXR,SIZECB) ) MAXITEMPCB = max(MAXITEMPCB,NBROWMAX+NCB+SIZEHEADER) IF (.NOT. & (UPDATE.AND.(.NOT.MASTER).AND.(NSLAVES_LOC.EQ.1)) & ) & SBUFR_CB = max(SBUFR_CB, & min(CBMAXR,SIZECB) + int(NBROWMAX + NCB + 6,8)) IF (MASTER) THEN SIZECB = 0_8 SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 IF (MASTERF) THEN SIZECBI = 2 + XSIZE_IC ELSE SIZECBI = 0 ENDIF ELSE IF (UPDATE) THEN IF (MASTERF) THEN SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECBI = 0 ENDIF IF (KEEP(50).EQ.0) THEN SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER ELSE SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER+ NSLAVES_LOC ENDIF ELSE SIZECB = 0_8 IF ( MASTERF ) THEN SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECBI = 0 ENDIF SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 ENDIF ENDIF ELSE IF (LEVELF.NE.3) THEN STACKCB = .TRUE. SIZECB = 0_8 SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECBI = 0 IF ( (LEVEL.EQ.1) .AND. (LEVELF.NE.1) ) THEN IF (PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF SIZECBI = 2 * NCB + SIZEHEADER ELSE IF (LEVEL.EQ.2) THEN IF (MASTER) THEN SIZECBI=0 ELSE SIZECB = SIZECB_SLAVE SIZECBLR_UD = SIZECBLR_SLAVE_UD SIZECBLR_WC = SIZECBLR_SLAVE_WC SIZECB_if_LRCB = SIZECB_SLAVE_if_LRCB SIZECBI = NBROWMAX + NFR + SIZEHEADER ENDIF ENDIF ENDIF ENDIF IF (STACKCB) THEN IF (FRERE(STEP(INODE)).EQ.0) THEN write(*,*) ' ERROR 3 in SMUMPS_ANA_DISTM' CALL MUMPS_ABORT() ENDIF ITOP = ITOP + 1 IF ( ITOP .GT. NSTEPS ) THEN WRITE(*,*) 'ERROR 4 in SMUMPS_ANA_DISTM ' ENDIF LSTKI(ITOP) = SIZECBI ISTKI=ISTKI + SIZECBI ISTKI_OOC = ISTKI_OOC + SIZECBI + (XSIZE_OOC-XSIZE_IC) LSTKR(ITOP) = SIZECB ISTKR = ISTKR + LSTKR(ITOP) NRLNEC = max(NRLNEC,NRLADU+ISTKR+MAXTEMPCB) NIRNEC = max(NIRNEC,NIRADU+ISTKI+MAXITEMPCB) NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ & MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR+MAXTEMPCB) LSTKR_if_LRCB(ITOP) = SIZECB_if_LRCB ISTKR_if_LRCB = ISTKR_if_LRCB + LSTKR_if_LRCB(ITOP) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB, & NRLADU_if_LR_LU+ISTKR_if_LRCB + & MAXTEMPCB) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU+ISTKR_if_LRCB + & MAXTEMPCB) LSTKRLR_CB_UD(ITOP) = SIZECBLR_UD ISTKRLR_CB_UD = ISTKRLR_CB_UD + LSTKRLR_CB_UD(ITOP) LSTKRLR_CB_WC(ITOP) = SIZECBLR_WC ISTKRLR_CB_WC = ISTKRLR_CB_WC + LSTKRLR_CB_WC(ITOP) NRLNECLR_CB_UD = max(NRLNECLR_CB_UD, ISTKRLR_CB_UD) NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) ENDIF ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH GOTO 95 ELSE GOTO 90 ENDIF ENDIF 115 CONTINUE IF ( KEEP(53) .NE. 0 ) THEN IF ( KEEP(38) .ne. 0 ) THEN IROOT = KEEP( 38 ) ELSE IROOT = KEEP( 20 ) END IF ROOT_OWNER = ( MYID .eq. & MUMPS_PROCNODE( PROCNODE(STEP(IROOT)), KEEP(199) ) ) SIZE_ROOT = ND(STEP(IROOT))+KEEP(253) CALL SMUMPS_SVD_QR_ESTIM_WK( PHASE, & KEEP(51), KEEP(51), SIZE_ROOT, & LOCAL_M, LOCAL_N, ROOT_OWNER, KEEP,KEEP8, & LIWK_RR, LWK_RR ) IF ( NRLNEC-NRLADU .LT. LWK_RR ) THEN NRLNEC = NRLADU + LWK_RR NRLNEC_if_LR_LU = NRLNEC_if_LR_LU + LWK_RR NRLNEC_if_LR_CB = NRLNEC_if_LR_CB + LWK_RR NRLNEC_if_LR_LUCB = NRLNEC_if_LR_LUCB + LWK_RR NRLNEC_ACTIVE = NRLNEC_ACTIVE + LWK_RR NRLNECOOC_if_LR_LUCB = NRLNECOOC_if_LR_LUCB + LWK_RR PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF END IF IF ( NIRNEC-NIRADU .LT. LIWK_RR ) THEN NIRNEC = NIRADU + LIWK_RR END IF IF ( NIRNEC_OOC-NIRADU_OOC .LT. LIWK_RR ) THEN NIRNEC_OOC = NIRADU_OOC + LIWK_RR END IF END IF NRLNEC = max(NRLNEC, NRLADU+int(KEEP(30),8)) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE, MAX_SIZE_FACTOR+ & int(KEEP(30),8)) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU + int(KEEP(30),8)) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU + int(KEEP(30),8)) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB, & NRLADU + int(KEEP(30),8)) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & MAX_SIZE_FACTOR+ int(KEEP(30),8)) PEAK_FR = SAVE_SIZECB_UNDER_L0 + NRLNEC PEAK_FR_OOC = SAVE_SIZECB_UNDER_L0 + NRLNEC_ACTIVE PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) IF (KEEP(60).EQ.1) THEN IF (I_PROCESS_SCHUR_K60_1) THEN NRLADU = NRLADU - NRLADU_CURRENT_K60_1 NRLADU_IF_LR_LU = NRLADU_IF_LR_LU - NRLADU_CURRENT_K60_1 ENDIF ENDIF IF (ABOVE_L0) THEN PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + SAVE_SIZECB_UNDER_L0_IF_LRCB) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + PEAK_DYN_LRCB_UD) PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + SAVE_SIZECB_UNDER_L0) PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + PEAK_DYN_LRLU_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + SAVE_SIZECB_UNDER_L0) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + PEAK_DYN_LRLU_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + SAVE_SIZECB_UNDER_L0) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + PEAK_DYN_LRLU_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + SAVE_SIZECB_UNDER_L0_IF_LRCB) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + PEAK_DYN_LRLUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + SAVE_SIZECB_UNDER_L0) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + PEAK_DYN_LRLUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + SAVE_SIZECB_UNDER_L0_IF_LRCB) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + PEAK_DYN_LRLUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + SAVE_SIZECB_UNDER_L0) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + PEAK_DYN_LRLUCB_WC) ENDIF SBUF_RECOLD = max(SBUFR_CB, & MAXTEMPCB+int(MAXITEMPCB,8)) + 10_8 SBUF_REC_FR = max(SBUFR_FR, int(min(100000_8,SBUFR_CB))) + 17 SBUF_REC_LR = max(SBUFR_LR, int(min(100000_8,SBUFR_CB))) + 17 SBUF_REC_FR = SBUF_REC_FR + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_REC_LR = SBUF_REC_LR + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_SEND_FR = max(SBUFS_FR, int(min(100000_8,SBUFR_CB)))+17 SBUF_SEND_LR = max(SBUFS_LR, int(min(100000_8,SBUFR_CB)))+17 IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN SBUF_RECOLD = SBUF_RECOLD+int(KEEP(108)+1,8) SBUF_REC_FR = SBUF_REC_FR+KEEP(108)+1 SBUF_REC_LR = SBUF_REC_LR+KEEP(108)+1 SBUF_SEND_FR = SBUF_SEND_FR+KEEP(108)+1 SBUF_SEND_LR = SBUF_SEND_LR+KEEP(108)+1 ENDIF IF (SLAVEF.EQ.1) THEN SBUF_RECOLD = 1_8 SBUF_REC_FR = 1 SBUF_REC_LR = 1 SBUF_SEND_FR= 1 SBUF_SEND_LR= 1 ENDIF DEALLOCATE( LSTKR, TNSTK, LSTKI, & LSTKR_if_LRCB, LSTKRLR_CB_UD, LSTKRLR_CB_WC & ) IF (ABOVE_L0) THEN KEEP(470) = KEEP(470)+ NBNODES_BLR ELSE KEEP(470) = NBNODES_BLR ENDIF IF (.NOT.ABOVE_L0) THEN PEAK_FR = NRLNEC PEAK_FR_OOC = NRLNEC_ACTIVE ENDIF MAXFR = max(MAXFR, MAXFR_UNDER_L0) MAX_FRONT_SURFACE_LOCAL = max (MAX_FRONT_SURFACE_LOCAL, & MAX_FRONT_SURFACE_LOCAL_L0) MAX_SIZE_FACTOR = max (MAX_SIZE_FACTOR, & MAX_SIZE_FACTOR_L0) ENTRIES_IN_FACTORS_LOC_MASTERS = ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_IN_FACTORS_MASTERS_LO ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_IN_FACTORS_UNDER_L0 OPS_SBTR_LOC = OPS_SBTR_LOC + COST_SUBTREES_UNDER_LO OPSA_LOC = OPSA_LOC + OPSA_UNDER_L0 OPS_SUBTREE = real(OPS_SBTR_LOC) OPSA = real(OPSA_LOC) RETURN END SUBROUTINE SMUMPS_ANA_DISTM SUBROUTINE SMUMPS_ANA_DISTM_UNDERL0OMP( & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP , VIRT_L0_OMP , VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP , PHYS_L0_OMP , PERM_L0_OMP, & PTR_LEAFS_L0_OMP, & KEEP, N, NE, STEP, FRERE, FILS, DAD, ND, & MYID, PROCNODE, & I4_L0, NBSTATS_I4, I8_L0, NBSTATS_I8, NBTHREADS, & SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB_UD, & TNSTK, MAXFR, & MAX_FRONT_SURFACE_LOCAL, MAX_SIZE_FACTOR, & ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS, & OPS_SBTR_LOC, OPSA_LOC, NBNODES_BLR, & IFLAG, IERROR ) IMPLICIT NONE INTEGER, INTENT(IN) :: LPOOL_B_L0_OMP, & L_VIRT_L0_OMP, L_PHYS_L0_OMP INTEGER, INTENT(IN) :: IPOOL_B_L0_OMP ( LPOOL_B_L0_OMP ) INTEGER, INTENT(IN) :: VIRT_L0_OMP ( L_VIRT_L0_OMP ) INTEGER, INTENT(IN) :: VIRT_L0_OMP_MAPPING ( L_VIRT_L0_OMP ) INTEGER, INTENT(IN) :: PHYS_L0_OMP ( L_PHYS_L0_OMP ) INTEGER, INTENT(IN) :: PERM_L0_OMP ( L_PHYS_L0_OMP ) INTEGER, INTENT(IN) :: PTR_LEAFS_L0_OMP ( L_PHYS_L0_OMP + 1 ) INTEGER, INTENT(IN) :: N INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER, INTENT(IN) :: NE(KEEP(28)) INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: FRERE(KEEP(28)) INTEGER, INTENT(IN) :: FILS(N) INTEGER, INTENT(IN) :: DAD(KEEP(28)), ND(KEEP(28)) INTEGER, INTENT(IN) :: MYID, PROCNODE(KEEP(28)) INTEGER, INTENT(IN) :: NBSTATS_I4, NBSTATS_I8, NBTHREADS INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(OUT) :: TNSTK(KEEP(28)) INTEGER, INTENT(OUT) :: I4_L0 (NBSTATS_I4, NBTHREADS) INTEGER(8), INTENT(OUT):: I8_L0 (NBSTATS_I8, NBTHREADS) INTEGER(8), INTENT(OUT):: ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS, & SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB_UD INTEGER, INTENT(OUT) :: MAXFR, NBNODES_BLR INTEGER(8), INTENT(OUT):: MAX_FRONT_SURFACE_LOCAL, & MAX_SIZE_FACTOR DOUBLE PRECISION, INTENT(OUT) :: OPS_SBTR_LOC, OPSA_LOC INTEGER, ALLOCATABLE, DIMENSION(:) :: LSTKI INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR_if_LRCB, & LSTKRLR_CB_UD, & LSTKRLR_CB_WC DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: OPSA_LOC_L0_OMP INTEGER :: ITH INTEGER :: NSTEPS INTEGER :: allocok INTEGER(8):: ISTKR, ISTKR_if_LRCB, ISTKRLR_CB_UD, & ISTKRLR_CB_WC INTEGER :: ISTKI, ISTKI_OOC, ITOP NSTEPS = KEEP(28) ALLOCATE( LSTKR(NSTEPS), LSTKI(NSTEPS) , & LSTKR_if_LRCB(NSTEPS), LSTKRLR_CB_UD(NSTEPS), & LSTKRLR_CB_WC(NSTEPS), & OPSA_LOC_L0_OMP(NBTHREADS), & & stat=allocok) IF ( allocok .GT. 0 ) THEN IFLAG =-7 IERROR = 4*NSTEPS+NBTHREADS RETURN ENDIF TNSTK = NE OPSA_LOC_L0_OMP(1:NBTHREADS) = 0.0D0 OPS_SBTR_LOC = 0.0D0 OPSA_LOC = 0.0D0 I4_L0(1:NBSTATS_I4, 1:NBTHREADS) = 0 I8_L0(1:NBSTATS_I8, 1:NBTHREADS) = 0_8 NBNODES_BLR = 0 SIZECB_UNDER_L0 = 0_8 SIZECB_UNDER_L0_IF_LRCB_UD = 0_8 MAXFR = 0 MAX_FRONT_SURFACE_LOCAL = 0_8 MAX_SIZE_FACTOR = 0_8 ENTRIES_IN_FACTORS_LOC = 0_8 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 DO ITH = 1, NBTHREADS ISTKI = 0 ISTKI_OOC = 0 ITOP = 0 ISTKR = 0_8 ISTKR_if_LRCB = 0_8 ISTKRLR_CB_UD = 0_8 ISTKRLR_CB_WC = 0_8 ISTKR = 0_8 CALL SMUMPS_ANA_DISTM_UNDERL0_1THR ( ITH, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP , VIRT_L0_OMP , VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP , PHYS_L0_OMP , PERM_L0_OMP, & PTR_LEAFS_L0_OMP, KEEP, N, NE, NSTEPS, & STEP, FRERE, FILS, DAD, ND, MYID, PROCNODE, & ISTKR, ISTKI, ISTKI_OOC, ISTKR_if_LRCB, ISTKRLR_CB_UD, & ISTKRLR_CB_WC, ITOP, & LSTKI, LSTKR, LSTKR_if_LRCB, LSTKRLR_CB_UD, LSTKRLR_CB_WC, & I4_L0(1,ITH), I4_L0(2,ITH), I4_L0(3,ITH), I4_L0(4,ITH), & I8_L0(1,ITH), I8_L0(2,ITH), I8_L0(3,ITH), I8_L0(4,ITH), & I8_L0(5,ITH), I8_L0(6,ITH), I8_L0(7,ITH), I8_L0(8,ITH), & I8_L0(9,ITH), I8_L0(10,ITH), I8_L0(11,ITH), I8_L0(12,ITH), & I8_L0(13,ITH), I8_L0(14,ITH), I8_L0(15,ITH), I8_L0(16,ITH), & I8_L0(17,ITH), I8_L0(18,ITH), I8_L0(19,ITH), I8_L0(20,ITH), & I8_L0(21,ITH), I8_L0(22,ITH), & NBNODES_BLR, TNSTK, MAXFR, & MAX_FRONT_SURFACE_LOCAL, MAX_SIZE_FACTOR, & ENTRIES_IN_FACTORS_LOC, ENTRIES_IN_FACTORS_LOC_MASTERS, & OPS_SBTR_LOC, OPSA_LOC_L0_OMP(ITH), IFLAG, IERROR ) OPSA_LOC = OPSA_LOC + OPSA_LOC_L0_OMP(ITH) I8_L0(23,ITH) = ISTKR SIZECB_UNDER_L0 = SIZECB_UNDER_L0 + ISTKR I8_L0(24,ITH) = ISTKR_if_LRCB + ISTKRLR_CB_UD SIZECB_UNDER_L0_IF_LRCB_UD = SIZECB_UNDER_L0_IF_LRCB_UD + & ISTKR_if_LRCB + ISTKRLR_CB_UD ENDDO DEALLOCATE( LSTKR, LSTKI , & LSTKR_if_LRCB, LSTKRLR_CB_UD, & LSTKRLR_CB_WC, & OPSA_LOC_L0_OMP) RETURN END SUBROUTINE SMUMPS_ANA_DISTM_UNDERL0OMP SUBROUTINE SMUMPS_ANA_DISTM_UNDERL0_1THR ( ITHREAD, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP , VIRT_L0_OMP , VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP , PHYS_L0_OMP , PERM_L0_OMP, & PTR_LEAFS_L0_OMP, KEEP, N, NE, NSTEPS, STEP, FRERE, FILS, DAD, & ND, MYID, PROCNODE, ISTKR, ISTKI, ISTKI_OOC, ISTKR_if_LRCB, & ISTKRLR_CB_UD, ISTKRLR_CB_WC, ITOP, & LSTKI, LSTKR, LSTKR_if_LRCB, LSTKRLR_CB_UD, LSTKRLR_CB_WC, & NIRADU, NIRNEC, NIRADU_OOC, NIRNEC_OOC, NRLADU, NRLNEC, & NRLNEC_ACTIVE, NRLADU_if_LR_LU, NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, NRLNECOOC_if_LR_LUCB, NRLNEC_if_LR_CB, & NRLADULR_UD, NRLADULR_WC, NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC, & PEAK_LRLU_UD, PEAK_OOC_LRLU_UD, PEAK_OOC_LRLU_WC, & PEAK_LRLUCB_UD, PEAK_LRLUCB_WC, PEAK_OOC_LRLUCB_UD, & PEAK_OOC_LRLUCB_WC, PEAK_LRCB_UD, PEAK_OOC_LRCB_UD, & NBNODES_BLR, TNSTK, MAXFR, & MAX_FRONT_SURFACE_LOCAL, MAX_SIZE_FACTOR, & ENTRIES_IN_FACTORS_LOC, ENTRIES_IN_FACTORS_LOC_MASTERS, & OPS_SBTR_LOC, OPSA_LOC, IFLAG, IERROR ) USE SMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE IMPLICIT NONE INTEGER, INTENT(IN) :: ITHREAD, LPOOL_B_L0_OMP, & L_VIRT_L0_OMP, L_PHYS_L0_OMP INTEGER, INTENT(IN) :: IPOOL_B_L0_OMP ( LPOOL_B_L0_OMP ) INTEGER, INTENT(IN) :: VIRT_L0_OMP ( L_VIRT_L0_OMP ) INTEGER, INTENT(IN) :: VIRT_L0_OMP_MAPPING ( L_VIRT_L0_OMP ) INTEGER, INTENT(IN) :: PHYS_L0_OMP ( L_PHYS_L0_OMP ) INTEGER, INTENT(IN) :: PERM_L0_OMP ( L_PHYS_L0_OMP ) INTEGER, INTENT(IN) :: PTR_LEAFS_L0_OMP ( L_PHYS_L0_OMP + 1 ) INTEGER, INTENT(IN) :: KEEP(500), N, NSTEPS INTEGER, INTENT(IN) :: NE(NSTEPS) INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: FRERE(NSTEPS) INTEGER, INTENT(IN) :: FILS(N) INTEGER, INTENT(IN) :: DAD(NSTEPS), ND(NSTEPS) INTEGER, INTENT(IN) :: MYID, PROCNODE(NSTEPS) DOUBLE PRECISION, INTENT(INOUT) :: OPS_SBTR_LOC DOUBLE PRECISION, INTENT(OUT) :: OPSA_LOC INTEGER, INTENT(INOUT) :: NBNODES_BLR INTEGER, INTENT(INOUT) :: TNSTK(NSTEPS) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: MAXFR INTEGER(8), INTENT(INOUT):: MAX_FRONT_SURFACE_LOCAL, & MAX_SIZE_FACTOR INTEGER(8), INTENT(INOUT):: ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS INTEGER(8), INTENT(INOUT) :: & ISTKR, ISTKR_if_LRCB, & ISTKRLR_CB_UD, ISTKRLR_CB_WC INTEGER, INTENT(INOUT) :: ISTKI, ISTKI_OOC, ITOP INTEGER, INTENT(INOUT) :: LSTKI(NSTEPS) INTEGER(8), INTENT(INOUT) :: LSTKR(NSTEPS), & LSTKR_if_LRCB(NSTEPS), & LSTKRLR_CB_UD(NSTEPS), & LSTKRLR_CB_WC(NSTEPS) INTEGER, INTENT(OUT) :: NIRADU, NIRNEC, NIRADU_OOC, NIRNEC_OOC INTEGER(8), INTENT(OUT):: NRLADU, NRLNEC, NRLNEC_ACTIVE, & NRLADU_if_LR_LU, NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, NRLNEC_if_LR_CB, & NRLADULR_UD, NRLADULR_WC, NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC, & PEAK_LRLU_UD, PEAK_OOC_LRLU_UD, PEAK_OOC_LRLU_WC, & PEAK_LRLUCB_UD, PEAK_LRLUCB_WC, PEAK_OOC_LRLUCB_UD, & PEAK_OOC_LRLUCB_WC, PEAK_LRCB_UD, PEAK_OOC_LRCB_UD LOGICAL :: INSSARBR INTEGER :: VIRTUAL_TASK, PHYSICAL_TASK INTEGER :: INODE, IFATH, I INTEGER :: SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC INTEGER :: EXTRA_PERM_INFO_OOC LOGICAL :: PACKED_CB INTEGER(8) :: NRLADU_ROOT_3 INTEGER :: FLAG_L0OMP PARAMETER (FLAG_L0OMP=-2014) INCLUDE 'mumps_headers.h' IF (KEEP(50).eq.2) THEN EXTRA_PERM_INFO_OOC = 1 ELSE IF (KEEP(50).eq.0) THEN EXTRA_PERM_INFO_OOC = 2 ELSE EXTRA_PERM_INFO_OOC = 0 ENDIF PACKED_CB=( KEEP(215).EQ.0 .AND. KEEP(50).NE.0 ) NRLADU_ROOT_3 = 0_8 #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 DO VIRTUAL_TASK = 1, L_VIRT_L0_OMP - 1 IF (VIRT_L0_OMP_MAPPING(VIRTUAL_TASK) .EQ. ITHREAD) THEN DO PHYSICAL_TASK= & VIRT_L0_OMP ( VIRTUAL_TASK ), & VIRT_L0_OMP ( VIRTUAL_TASK + 1 ) - 1 DO I = PTR_LEAFS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK ) ), & PTR_LEAFS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK )+1 ) +1, & - 1 INODE = IPOOL_B_L0_OMP(I) IF (INODE .LE. 0) THEN CYCLE ENDIF 10 CONTINUE IFATH = DAD(STEP(INODE)) CALL SMUMPS_PROCESS_NODE_UNDERL0 () IF (IFATH .NE. 0) THEN TNSTK( STEP(IFATH) ) = TNSTK( STEP(IFATH) ) - 1 ENDIF IF ( PHYS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK ) ) & .EQ. INODE ) THEN TNSTK(STEP(INODE)) = FLAG_L0OMP ELSE IF ( TNSTK( STEP(IFATH) ) .EQ. 0 ) THEN INODE = IFATH GOTO 10 ENDIF ENDDO ENDDO ENDIF ENDDO RETURN CONTAINS SUBROUTINE SMUMPS_PROCESS_NODE_UNDERL0 IMPLICIT NONE INTEGER :: LRSTATUS, IDUMMY LOGICAL :: COMPRESS_PANEL, COMPRESS_CB INTEGER :: STKI INTEGER(8) :: LSTK INTEGER :: K, NFR, NFRF, NELIM, NELIMF, NCB, NSTK, & LEVEL, LEVELF, IN, & MAXITEMPCB, PANEL_SIZE, SIZECBI INTEGER(8):: NFR8, NCB8, & K464_8, K465_8, & CURRENT_ACTIVE_MEM, & ENTRIES_NODE_LOWER_PART, ENTRIES_NODE_UPPER_PART, & NRLADU_CURRENT, NRLADU_CURRENT_MISSING INTEGER(8) :: SIZEFRNOCBLU INTEGER :: IDUMMY_ARRAY(1) INTEGER(8):: SIZECB, SIZECBINFR INTEGER(8):: SIZECB_if_LRCB INTEGER(8):: SIZECBLR_UD, SIZECBLR_WC LOGICAL :: MASTER, MASTERF, STACKCB DOUBLE PRECISION :: OPS_NODE INTRINSIC int INTEGER SMUMPS_OOC_GET_PANEL_SIZE EXTERNAL SMUMPS_OOC_GET_PANEL_SIZE INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR EXTERNAL MUMPS_MAX_SURFCB_NBROWS EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, & MUMPS_IN_OR_ROOT_SSARBR MAXITEMPCB = 0 STACKCB = .TRUE. NFR = ND(STEP(INODE))+KEEP(253) NFR8 = int(NFR,8) NSTK = NE(STEP(INODE)) NELIM = 0 IN = INODE 100 NELIM = NELIM + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IFATH = DAD(STEP(INODE)) MASTER = MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID LEVEL = MUMPS_TYPENODE(PROCNODE(STEP(INODE)),KEEP(199)) INSSARBR = MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) IDUMMY_ARRAY(1) = 0 NCB = NFR-NELIM NCB8 = int(NCB,8) SIZECBINFR = NCB8*NCB8 IF (KEEP(50).EQ.0) THEN SIZECB = SIZECBINFR ELSE IF ( PACKED_CB ) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = SIZECBINFR ENDIF ENDIF IDUMMY = -99999 CALL IS_FRONT_BLR_CANDIDATE (INODE, LEVEL, NFR, NELIM, & KEEP(494), 1, KEEP(490), & KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, IDUMMY) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) IF (COMPRESS_PANEL.OR.COMPRESS_CB) NBNODES_BLR = NBNODES_BLR+1 IF (COMPRESS_PANEL) THEN K464_8 = int(KEEP(464),8) ELSE K464_8 = 1000_8 ENDIF IF (COMPRESS_CB) THEN K465_8 = int(KEEP(465),8) SIZECB_if_LRCB = 0_8 SIZECBLR_UD = SIZECB*K465_8/1000_8 SIZECBLR_WC = SIZECB ELSE K465_8 = 1000_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = SIZECB ENDIF SIZECBI = 2* NCB + SIZEHEADER IF(KEEP(86).EQ.1)THEN IF(MASTER.AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)), KEEP(199))) & )THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8) ENDIF ENDIF NIRADU = NIRADU + 2*NFR + SIZEHEADER NIRADU_OOC = NIRADU_OOC + 2*NFR + SIZEHEADER_OOC PANEL_SIZE = SMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NFR, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) IF (KEEP(50).EQ.0) THEN IF (KEEP(251) .EQ. 2) THEN NRLADU_CURRENT = int(NELIM,8) * int(NFR,8) SIZEFRNOCBLU = int(NFR-NELIM,8)*int(NELIM) ELSE NRLADU_CURRENT = int(NELIM,8)*int(2*NFR-NELIM,8) SIZEFRNOCBLU = 0_8 ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR = max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ELSE IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 ) THEN CALL MUMPS_LDLTPANEL_STORAGE( NELIM, KEEP, & IDUMMY_ARRAY(1), NRLADU_CURRENT ) SIZEFRNOCBLU = int(NELIM,8)*int(NELIM,8) - & NRLADU_CURRENT NRLADU_CURRENT = NRLADU_CURRENT + & int(NELIM,8) * int(NFR-NELIM,8) ELSE SIZEFRNOCBLU = 0_8 NRLADU_CURRENT = int(NELIM,8)*int(NFR,8) ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ENDIF IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_CURRENT_MISSING = 0_8 NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT ENDIF SIZECBI = 2* NCB + SIZEHEADER NIRNEC = max(NIRNEC, & NIRADU+ISTKI+SIZECBI+MAXITEMPCB) NIRNEC_OOC = max(NIRNEC_OOC, & NIRADU_OOC+ISTKI_OOC+SIZECBI+MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) CURRENT_ACTIVE_MEM = ISTKR+SIZECBINFR IF ( KEEP(50).NE.0 .AND. LEVEL.EQ.1 ) THEN SIZEFRNOCBLU = SIZEFRNOCBLU + int(NELIM,8)*int(NCB,8) ENDIF CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + SIZEFRNOCBLU NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = & max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) 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 NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT_MISSING) NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (NFR.GT.MAXFR) MAXFR = NFR IF (NSTK.GT.0) THEN DO 70 K=1,NSTK LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK IF (K==1 .AND. INSSARBR.AND.KEEP(234).NE.0 & .AND.KEEP(55).EQ.0) THEN ELSE CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTK ENDIF LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in SMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF 70 CONTINUE ENDIF IF ( & ( (INODE.NE.KEEP(20)).OR.(KEEP(60).EQ.0) ) & .AND. & ( (INODE.NE.KEEP(38)).OR.(KEEP(60).LE.1) ) & ) & THEN ENTRIES_NODE_LOWER_PART = int(NFR-NELIM,8) * int(NELIM,8) IF ( KEEP(50).EQ.0 ) THEN ENTRIES_NODE_UPPER_PART = int(NFR,8) * int(NELIM,8) ELSE ENTRIES_NODE_UPPER_PART = & (int(NELIM,8)*int(NELIM+1,8))/2_8 ENDIF IF (KEEP(50).EQ.2 .AND. LEVEL.EQ.3) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM, 0, & 1,OPS_NODE) ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) ENDIF ELSE OPS_NODE = 0.0D0 ENTRIES_NODE_UPPER_PART = 0_8 ENTRIES_NODE_LOWER_PART = 0_8 ENDIF ENTRIES_IN_FACTORS_LOC_MASTERS = & ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC_MASTERS OPSA_LOC = OPSA_LOC + dble(OPS_NODE) IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) .OR. NE(STEP(INODE))==0) THEN OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ENDIF IF (IFATH .EQ. 0) THEN RETURN 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 LEVELF = MUMPS_TYPENODE(PROCNODE(STEP(IFATH)),KEEP(199)) MASTERF= MUMPS_PROCNODE(PROCNODE(STEP(IFATH)), & KEEP(199)).EQ.MYID IF ( INSSARBR .AND. KEEP(234).NE.0) THEN NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+SIZECB+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) ENDIF PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (KEEP(50).NE.0.AND.LEVELF.NE.3 & .AND.PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF SIZECBI = 2+ XSIZE_IC IF (STACKCB) THEN IF (FRERE(STEP(INODE)).EQ.0) THEN write(*,*) ' ERROR 3 in SMUMPS_ANA_DISTM' CALL MUMPS_ABORT() ENDIF ITOP = ITOP + 1 IF ( ITOP .GT. NSTEPS ) THEN WRITE(*,*) 'ERROR 4 in SMUMPS_ANA_DISTM ' CALL MUMPS_ABORT() 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) NIRNEC = max(NIRNEC,NIRADU+ISTKI) NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR) LSTKR_if_LRCB(ITOP) = SIZECB_if_LRCB ISTKR_if_LRCB = ISTKR_if_LRCB + LSTKR_if_LRCB(ITOP) LSTKRLR_CB_UD(ITOP) = SIZECBLR_UD ISTKRLR_CB_UD = ISTKRLR_CB_UD + LSTKRLR_CB_UD(ITOP) LSTKRLR_CB_WC(ITOP) = SIZECBLR_WC ISTKRLR_CB_WC = ISTKRLR_CB_WC + LSTKRLR_CB_WC(ITOP) NRLNECLR_CB_UD = max(NRLNECLR_CB_UD, ISTKRLR_CB_UD) NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) ENDIF ENDIF END SUBROUTINE SMUMPS_PROCESS_NODE_UNDERL0 END SUBROUTINE SMUMPS_ANA_DISTM_UNDERL0_1THR SUBROUTINE SMUMPS_PREP_ANA_DISTM_ABOVEL0 ( & N, SLAVEF, COMM, MYID, & STEP, DAD, ICNTL, LP, LPOK, INFO, & PHYS_L0_OMP, L_PHYS_L0_OMP, & IPOOL_A_L0_OMP, LPOOL_A_L0_OMP, & KEEP, TNSTK_afterL0, & FLAGGED_LEAVES & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, INTENT(IN) :: N, SLAVEF, COMM, MYID, ICNTL(60), & LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: L_PHYS_L0_OMP, LPOOL_A_L0_OMP INTEGER, INTENT(IN) :: PHYS_L0_OMP(max(1,L_PHYS_L0_OMP)), & IPOOL_A_L0_OMP(max(1,LPOOL_A_L0_OMP)) INTEGER, INTENT(IN) :: KEEP(500) INTEGER, INTENT(IN) :: STEP(N), DAD(KEEP(28)) INTEGER, INTENT(OUT) :: FLAGGED_LEAVES(KEEP(28)) INTEGER, INTENT(INOUT) :: TNSTK_afterL0(KEEP(28)), INFO(80) INTEGER :: ISLAVE, IERR, INODE, I, NSTEPS, allocok INTEGER :: SIZE_BUFREC, Itemp, SIZE_RECEIVED INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFREC INTEGER, ALLOCATABLE, DIMENSION(:) :: IREQ INTEGER :: MPI_STATUS(MPI_STATUS_SIZE) SIZE_BUFREC = 0 CALL MPI_ALLREDUCE(L_PHYS_L0_OMP, Itemp, 1, & MPI_INTEGER, MPI_MAX, COMM, IERR) SIZE_BUFREC = Itemp CALL MPI_ALLREDUCE(LPOOL_A_L0_OMP, Itemp, 1, & MPI_INTEGER, MPI_MAX, COMM, IERR) SIZE_BUFREC= max(SIZE_BUFREC, Itemp) ALLOCATE(IREQ(SLAVEF), BUFREC(SIZE_BUFREC), stat=allocok) IF (allocok.GT.0) THEN IF ( LPOK ) THEN WRITE(LP, '(A)') & ' Allocation failed in SMUMPS_PREP_ANA_DISTM_ABOVEL0' END IF INFO(1)= -7 INFO(2)= SLAVEF+SIZE_BUFREC ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) RETURN NSTEPS = KEEP(28) DO I=1, NSTEPS FLAGGED_LEAVES(I) = 0 ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_ISEND( IPOOL_A_L0_OMP, LPOOL_A_L0_OMP, & MPI_INTEGER, ISLAVE - 1, F_IPOOLAFTER, COMM, & IREQ( ISLAVE ), IERR ) ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_RECV( BUFREC(1), SIZE_BUFREC, & MPI_INTEGER, ISLAVE-1, & F_IPOOLAFTER, COMM, MPI_STATUS, IERR ) CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER, & SIZE_RECEIVED, IERR) DO I=1,SIZE_RECEIVED INODE = BUFREC(I) FLAGGED_LEAVES(STEP(INODE))=INODE ENDDO ENDDO IF (LPOOL_A_L0_OMP.GT.0) THEN DO I=1, LPOOL_A_L0_OMP INODE = IPOOL_A_L0_OMP(I) FLAGGED_LEAVES(STEP(INODE))=INODE ENDDO ENDIF DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_WAIT( IREQ( ISLAVE ), MPI_STATUS, IERR ) ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_ISEND(PHYS_L0_OMP, L_PHYS_L0_OMP, & MPI_INTEGER, ISLAVE - 1, F_PHYS_L0, COMM, & IREQ( ISLAVE ), IERR ) ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_RECV( BUFREC(1), SIZE_BUFREC, & MPI_INTEGER, ISLAVE-1, & F_PHYS_L0, COMM, MPI_STATUS, IERR ) CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER, & SIZE_RECEIVED, IERR) DO I=1,SIZE_RECEIVED INODE = BUFREC(I) IF (DAD(STEP(INODE)).NE.0) THEN TNSTK_afterL0(STEP(DAD(STEP(INODE)))) & = TNSTK_afterL0(STEP(DAD(STEP(INODE)))) - 1 ENDIF ENDDO ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_WAIT( IREQ( ISLAVE ), MPI_STATUS, IERR ) ENDDO IF (allocated(IREQ)) DEALLOCATE(IREQ) IF (allocated(BUFREC)) DEALLOCATE(BUFREC) RETURN END SUBROUTINE SMUMPS_PREP_ANA_DISTM_ABOVEL0 MUMPS_5.8.1/src/ana_blk_m.F0000664000175000017500000000205615042446423015246 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_ANA_BLK_M TYPE COL_LMATRIX_T INTEGER :: NBINCOL INTEGER, POINTER :: IRN(:) => null() END TYPE COL_LMATRIX_T TYPE LMATRIX_T INTEGER :: NBCOL INTEGER :: NBCOL_LOC, FIRST INTEGER(8) :: NZL TYPE(COL_LMATRIX_T), POINTER :: COL(:) => null() END TYPE LMATRIX_T TYPE COMPACT_GRAPH_T INTEGER(8) :: NZG, SIZEADJALLOCATED INTEGER :: NG INTEGER :: FIRST, LAST INTEGER(8), POINTER :: IPE(:) => null() INTEGER, POINTER :: ADJ(:) => null() END TYPE COMPACT_GRAPH_T END MODULE MUMPS_ANA_BLK_M MUMPS_5.8.1/src/cana_aux_ELT.F0000664000175000017500000011300215042446440015617 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ANA_F_ELT(N, NELT, ELTPTR, ELTVAR, LIW, & IKEEP, & IORD, NFSIZ, FILS, FRERE, & LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, & NSLAVES, & XNODEL, NODEL #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , METIS_OPTIONS #endif & ) USE MUMPS_ANA_ORD_WRAPPERS IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, SIZE_SCHUR, NSLAVES INTEGER(8), INTENT(IN) :: LIW INTEGER, INTENT(IN) :: ELTPTR(NELT+1) INTEGER, INTENT(IN) :: ELTVAR(ELTPTR(NELT+1)-1) INTEGER, INTENT(IN) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: IKEEP(N,3) INTEGER, INTENT(INOUT) :: INFO(80), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(OUT) :: NFSIZ(N), FILS(N), FRERE(N) INTEGER, INTENT(OUT) :: XNODEL(N+1), NODEL(ELTPTR(NELT+1)-1) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER, INTENT(IN) :: METIS_OPTIONS(40) #endif INTEGER K,I,NCMPA,IFSON,IN INTEGER(8) :: L1, L2 INTEGER NEMIN, MPRINT, LP, MP, LDIAG INTEGER(8) :: NZ8, LLIW8, IWFR8 INTEGER allocok, ITEMP LOGICAL PROK, NOSUPERVAR, LPOK INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) LOGICAL SPLITROOT INTEGER HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & NBSONS_Scalapack_CAND INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER :: IDUMMY(1) INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER, DIMENSION(:), ALLOCATABLE :: IW2 INTEGER, DIMENSION(:), ALLOCATABLE :: PARENT INTEGER, DIMENSION(:,:), ALLOCATABLE :: IWtemp INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE8 #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) INTEGER :: NUMFLAG #else INTEGER, DIMENSION(:), ALLOCATABLE :: NUMFLAG #endif INTEGER :: OPT_METIS_SIZE, METIS_IDX_SIZE INTEGER :: IERR #endif INTEGER IDUM EXTERNAL CMUMPS_ANA_G11_ELT, CMUMPS_ANA_G12_ELT, & CMUMPS_ANA_G1_ELT, CMUMPS_ANA_G2_ELT, & CMUMPS_ANA_G2_ELTNEW, & CMUMPS_ANA_J1_ELT, CMUMPS_ANA_J2_ELT, & CMUMPS_ANA_K, & CMUMPS_ANA_LNEW, CMUMPS_ANA_M, & MUMPS_AMD_ELT ALLOCATE( IW ( LIW ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(LIW, INFO( 2 )) GOTO 90 ENDIF ALLOCATE( IPE8 ( N + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (N+1)*KEEP(10) GOTO 90 ENDIF ALLOCATE( PARENT(N), IWtemp ( N, 3 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(4_8*int(N,8), INFO( 2 )) GOTO 90 ENDIF MPRINT= ICNTL(3) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MP = ICNTL(3) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) LDIAG = ICNTL(4) IF (KEEP(60).NE.0) THEN NOSUPERVAR=.TRUE. IF (IORD.GT.1) IORD = 0 ELSE NOSUPERVAR=.FALSE. ENDIF IF (IORD == 7) THEN IF ( N < 10000 ) THEN IORD = 0 ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IORD = 5 #else IORD = 0 #endif ENDIF END IF #if ! defined(metis) && ! defined(parmetis) && ! defined(metis4) && ! defined(parmetis3) IF (IORD == 5) IORD = 0 #endif IF (KEEP(1).LT.1) KEEP(1) = 1 NEMIN = KEEP(1) IF (LDIAG.LE.2 .OR. MP.LE.0) GO TO 10 WRITE (MP,99999) N, NELT, LIW, INFO(1) K = min(10,NELT+1) IF (LDIAG.EQ.4) K = NELT+1 IF (K.GT.0) WRITE (MP,99998) (ELTPTR(I),I=1,K) K = min(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 = min(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_8 L2 = L1 + int(N,8) IF (LIW .LT. 3_8*int(N,8)) THEN INFO(1) = -2002 CALL MUMPS_SET_IERROR( LIW, INFO(2) ) ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF ( IORD == 5 ) THEN IF (LIW .LT. int(N,8)+int(N,8)+1_8) THEN INFO(1)= -2002 CALL MUMPS_SET_IERROR( LIW, INFO(2) ) GOTO 90 ENDIF ELSE #endif IF (NOSUPERVAR) THEN IF ( LIW .LT. 2_8*int(N,8) ) THEN INFO(1)= -2002 CALL MUMPS_SET_IERROR( LIW, INFO(2) ) GOTO 90 END IF ELSE IF ( LIW .LT. 4_8*int(N,8)+4_8 ) THEN INFO(1)= -2002 CALL MUMPS_SET_IERROR( LIW, INFO(2) ) GOTO 90 END IF ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif IDUM=0 CALL CMUMPS_NODEL(NELT, N, ELTPTR(NELT+1)-1, ELTPTR, ELTVAR, & XNODEL, NODEL, IW(L1), IDUM, ICNTL) IF (IORD.NE.1 .AND. IORD .NE. 5) THEN IORD = 0 IF (NOSUPERVAR) THEN CALL CMUMPS_ANA_G1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), IW(L1)) ELSE CALL CMUMPS_ANA_G11_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), 4_8*int(N,8)+4_8, IW(L1)) ENDIF LLIW8 = max(NZ8,int(N,8)) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8, INFO(2)) GOTO 90 ENDIF IF (NOSUPERVAR) THEN CALL CMUMPS_ANA_G2_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) ELSE CALL CMUMPS_ANA_G12_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) ENDIF IF (NOSUPERVAR) THEN CALL MUMPS_HAMD(N, LLIW8, IPE8, IWFR8, IWtemp(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), IWtemp(1,3), & IWtemp, & LISTVAR_SCHUR, SIZE_SCHUR) IF (KEEP(60) == 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSEIF (KEEP(60) == 2 .OR. KEEP(60) == 3 ) THEN KEEP(38) = LISTVAR_SCHUR(1) ELSE WRITE(*,*) "Internal error in CMUMPS_ANA_F_ELT",KEEP(60) CALL MUMPS_ABORT() ENDIF ELSE CALL MUMPS_AMD_ELT(N, LLIW8, IPE8, IWFR8, IWtemp(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), IWtemp(1,3), & IWtemp) ENDIF ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MPRINT,'(A)') ' Ordering based on METIS' ENDIF CALL CMUMPS_ANA_G1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), IW(L1)) LLIW8 = max(NZ8,int(N,8)) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8, INFO(2)) GOTO 90 ENDIF CALL CMUMPS_ANA_G2_ELTNEW(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) #if defined(metis4) || defined(parmetis3) NUMFLAG = 1 OPT_METIS_SIZE = 8 #else ALLOCATE( NUMFLAG ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF DO I=1,N NUMFLAG(I) = 1 ENDDO OPT_METIS_SIZE = 40 #endif CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN INFO(1) = -52 INFO(2) = 1 GOTO 90 ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32(N, IPE8, IW2, #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG, #endif & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP(1:N,2), IKEEP(1:N,1), INFO(1), LP, LPOK) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64(N, IPE8, IW2, #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG, #endif & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP(1:N,2), IKEEP(1:N,1), INFO(1), & LP, LPOK, KEEP(10), & LLIW8, .FALSE., .TRUE. ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF IF (INFO(1) .LT. 0) GOTO 90 DEALLOCATE(IW2) ELSE IF (IORD.NE.1) THEN WRITE(*,*) IORD WRITE(*,*) 'bad option for ordering' CALL MUMPS_ABORT() ENDIF #endif DO K=1,N IW(L1+int(K,8)) = 0 ENDDO DO K=1,N IF ((IKEEP(K,1).LE.0).OR.(IKEEP(K,1).GT.N)) & GO TO 40 IF (IW(L1+int(IKEEP(K,1),8)).EQ.1) THEN GOTO 40 ELSE IW(L1+int(IKEEP(K,1),8)) = 1 ENDIF ENDDO CALL CMUMPS_ANA_J1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IWtemp(1,2), IW(L1)) LLIW8 = NZ8+int(N,8) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8,INFO(2)) GOTO 90 ENDIF CALL CMUMPS_ANA_J2_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) IF (KEEP(60) == 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR IF (KEEP(60) == 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSEIF (KEEP(60) == 2 .OR. KEEP(60) == 3 ) THEN KEEP(38) = LISTVAR_SCHUR(1) ELSE WRITE(*,*) "Internal error in CMUMPS_ANA_F_ELT",KEEP(60) CALL MUMPS_ABORT() ENDIF ENDIF CALL CMUMPS_ANA_K(N, IPE8, IW2, LLIW8, IWFR8, IKEEP, & IKEEP(1,2), IW(L1), & IW(L2), NCMPA, ITEMP, IWtemp) ENDIF CALL CMUMPS_ANA_LNEW(N, IWtemp, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, IWtemp(1,2), & INFO(6), FILS, FRERE, IWtemp(1,3), NEMIN, & IW(L2), KEEP(60), KEEP(20), KEEP(38), & IW2,KEEP(104),IW(L2+int(N,8)),KEEP(50), & ICNTL(13), KEEP(37), KEEP(197), NSLAVES, KEEP(250).EQ.1, & .FALSE., IDUMMY, LIDUMMY, & INODE_Scalapack_CAND, NBSONS_Scalapack_CAND, & KEEP(11), KEEP(191), KEEP(192), KEEP(193) ) DEALLOCATE(IW2) IF (KEEP(60).NE.0) THEN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO WHILE (IN.GT.0) IN = FILS (IN) END DO IFSON = -IN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO I=2,SIZE_SCHUR FILS(IN) = LISTVAR_SCHUR (I) IN = FILS(IN) FRERE (IN) = N+1 ENDDO FILS(IN) = -IFSON ENDIF CALL CMUMPS_ANA_M(IKEEP(1,2), & IWtemp(1,3), INFO(6), & INFO(5), KEEP(2),KEEP(50), & KEEP8(101), KEEP(108),KEEP(5), & KEEP(6), KEEP(226), KEEP(253)) IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, KEEP(20) ) INODE_Scalapack_CAND = KEEP(20) NBSONS_Scalapack_CAND = 1 END IF IF ( KEEP(48) == 4 .OR. & ( (KEEP(24).NE.0).AND.(KEEP8(21).GT.0_8) ) ) THEN CALL CMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2), & KEEP(48), KEEP(50), NSLAVES) END IF IF (KEEP(210).LT.1.OR.KEEP(210).GT.2) KEEP(210)=2 IF (KEEP(210).EQ.2) KEEP8(79)=huge(KEEP8(79)) IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF IF (KEEP(11).EQ.0) THEN IF (KEEP(79).EQ.0) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN IDUMMY(1)= -1 CALL CMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ, & IDUMMY, LIDUMMY, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF (PROK) THEN WRITE(MP,*) " Number of split nodes in pre-splitting=", & KEEP(61) ENDIF ENDIF ENDIF ENDIF ENDIF HOW_TO_SPLIT_ROOT = 0 SPLITROOT = ICNTL(13) .EQ. -1 #if defined(NOSCALAPACK) SPLITROOT = SPLITROOT .OR. NSLAVES.GT.0 #else SPLITROOT = SPLITROOT .OR. & (ICNTL(13).GT.0 .AND. NSLAVES .GT. ICNTL(13)) #endif HOW_TO_SPLIT_ROOT = 0 IF (SPLITROOT.AND.KEEP(11).GT.0) HOW_TO_SPLIT_ROOT =1 IF (KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. IF (KEEP(11).GT.0) HOW_TO_SPLIT_ROOT = 2 ENDIF SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) )) #if defined(NOSCALAPACK) #else IF ( KEEP(11).GT.0) THEN IF (.NOT.SPLITROOT .AND. & (KEEP(60).EQ.0).AND. & ( (NFSIZ(INODE_Scalapack_CAND).GT.KEEP(37)) & .AND.(ICNTL(13).LE.0) ) & .AND. & (NBSONS_Scalapack_CAND.GT.KEEP(11)) & ) THEN HOW_TO_SPLIT_ROOT = 3 SPLITROOT=.TRUE. ENDIF ENDIF #endif IF (SPLITROOT) THEN IDUMMY(1) = -1 IF (KEEP(11).EQ.0) THEN CALL CMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & IDUMMY, LIDUMMY, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) ENDIF ELSE CALL CMUMPS_SPLIT_ROOT( NSLAVES, & HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & N, FRERE(1), FILS(1), NFSIZ(1), & KEEP, KEEP8, & IDUMMY, LIDUMMY, INFO(6)) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN K = min(10,N) IF (LDIAG.EQ.4) K = N IF (K.GT.0) WRITE (MP,99997) (IKEEP(I,1),I=1,K) IF (K.GT.0) WRITE (MP,99991) (IKEEP(I,2),I=1,K) IF (K.GT.0) WRITE (MP,99990) (IKEEP(I,3),I=1,K) IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) ENDIF GO TO 90 40 INFO(1) = -4 INFO(2) = K 90 CONTINUE IF (INFO(1) .LT.0) THEN IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99996) INFO(1) IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99982) INFO(2) ENDIF IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(IPE8)) DEALLOCATE(IPE8) IF (allocated(IW2)) DEALLOCATE(IW2) IF (allocated(IWtemp)) DEALLOCATE(IWtemp) RETURN 99999 FORMAT (/'Entering analysis phase with ...'/ & ' N NELT LIW INFO(1)'/, & 9X, I10, I11, I12, I14) 99998 FORMAT ('Element pointers: ELTPTR() '/(9X, 7I10)) 99995 FORMAT ('Element variables: ELTVAR() '/(9X, 7I10)) 99997 FORMAT ('IKEEP(.,1)=', 10I6/(12X, 10I6)) 99996 FORMAT (/'** Error return ** from Analysis * INFO(1)=', I3) 99991 FORMAT ('IKEEP(.,2)=', 10I6/(12X, 10I6)) 99990 FORMAT ('IKEEP(.,3)=', 10I6/(12X, 10I6)) 99989 FORMAT ('FILS (.) =', 10I6/(12X, 10I6)) 99988 FORMAT ('FRERE(.) =', 10I6/(12X, 10I6)) 99987 FORMAT ('NFSIZ(.) =', 10I6/(12X, 10I6)) 99982 FORMAT ('Error in permutation array KEEP INFO(2)=', I3) END SUBROUTINE CMUMPS_ANA_F_ELT SUBROUTINE CMUMPS_NODEL( NELT, N, NELNOD, XELNOD, ELNOD, & XNODEL, NODEL, FLAG, IERROR, ICNTL ) IMPLICIT NONE INTEGER NELT, N, NELNOD, IERROR, ICNTL(60) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & FLAG(N) INTEGER I, J, K, MP, NBERR MP = ICNTL(2) FLAG(1:N) = 0 XNODEL(1:N) = 0 IERROR = 0 DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF ( J.LT.1 .OR. J.GT.N ) THEN IERROR = IERROR + 1 ELSE IF ( FLAG(J).NE.I ) THEN XNODEL(J) = XNODEL(J) + 1 FLAG(J) = I ENDIF ENDIF ENDDO ENDDO IF ( IERROR.GT.0 .AND. MP.GT.0 .AND. ICNTL(4).GE.2 ) THEN NBERR = 0 WRITE(MP,99999) DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF ( J.LT.1 .OR. J.GT.N ) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN WRITE(MP,'(A,I8,A,I8,A)') & 'Element ',I,' variable ',J,' ignored.' ELSE GO TO 100 ENDIF ENDIF ENDDO ENDDO ENDIF 100 CONTINUE K = 1 DO I = 1, N K = K + XNODEL(I) XNODEL(I) = K ENDDO XNODEL(N+1) = XNODEL(N) FLAG(1:N) = 0 DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF (FLAG(J).NE.I) THEN XNODEL(J) = XNODEL(J) - 1 NODEL(XNODEL(J)) = I FLAG(J) = I ENDIF ENDDO ENDDO RETURN 99999 FORMAT (/'*** Warning message from subroutine CMUMPS_NODEL ***') END SUBROUTINE CMUMPS_NODEL SUBROUTINE CMUMPS_ANA_G1_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, FLAG) IMPLICIT NONE INTEGER N, NELT, NELNOD INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & FLAG(N) INTEGER I,J,K1,K2,K3 FLAG(1:N) = 0 LEN(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN LEN(I) = LEN(I) + 1 LEN(J) = LEN(J) + 1 FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO NZ = 0_8 DO I = 1,N NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE CMUMPS_ANA_G1_ELT SUBROUTINE CMUMPS_ANA_G2_ELTNEW(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N+1) INTEGER LEN(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IWFR = IWFR + int(LEN(I),8) IPE(I) = IWFR ENDDO IPE(N+1)=IPE(N) FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1 IW(IPE(I)) = J IPE(J) = IPE(J) - 1 IW(IPE(J)) = I FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE CMUMPS_ANA_G2_ELTNEW SUBROUTINE CMUMPS_ANA_G2_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER LEN(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IWFR = IWFR + int(LEN(I),8) IF (LEN(I).GT.0) THEN IPE(I) = IWFR ELSE IPE(I) = 0_8 ENDIF ENDDO FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1_8 IW(IPE(I)) = J IPE(J) = IPE(J) - 1_8 IW(IPE(J)) = I FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE CMUMPS_ANA_G2_ELT SUBROUTINE CMUMPS_ANA_J1_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, LEN, FLAG) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), FLAG(N) INTEGER I,J,K1,K2,K3 FLAG(1:N) = 0 LEN(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IF (PERM(J).GT.PERM(I)) THEN LEN(I) = LEN(I) + 1 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO NZ = 0_8 DO I = 1,N NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE CMUMPS_ANA_J1_ELT SUBROUTINE CMUMPS_ANA_J2_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), IW(LW), & FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 0_8 DO I = 1,N IWFR = IWFR + int(LEN(I) + 1,8) IPE(I) = IWFR ENDDO IWFR = IWFR + 1_8 FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IF (PERM(J).GT.PERM(I)) THEN IW(IPE(I)) = J IPE(I) = IPE(I) - 1_8 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO DO I = 1,N J = int(IPE(I)) IW(J) = LEN(I) IF (LEN(I).EQ.0) IPE(I) = 0_8 ENDDO RETURN END SUBROUTINE CMUMPS_ANA_J2_ELT SUBROUTINE CMUMPS_ANA_DIST_ELEMENTS( MYID, SLAVEF, N, & PROCNODE, STEP, PTRAIW, PTRARW, & NELT, FRTPTR, FRTELT, & KEEP,KEEP8, ICNTL, SYM ) IMPLICIT NONE INTEGER MYID, SLAVEF, N, NELT, SYM INTEGER KEEP( 500 ), ICNTL( 60 ) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAIW( NELT+1 ), PTRARW( NELT+1 ) INTEGER STEP( N ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PROCNODE( KEEP(28) ) INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER(8) :: IPTRI8, IPTRR8, NVAR8 INTEGER ELT, I, K INTEGER TYPE_PARALL, ITYPE, IRANK LOGICAL :: EARLYT3ROOTINS TYPE_PARALL = KEEP(46) PTRAIW( 1:NELT ) = 0_8 EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) DO I = 1, N IF (STEP(I).LT.0) CYCLE ITYPE = MUMPS_TYPENODE( PROCNODE(abs(STEP(I))), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(abs(STEP(I))), KEEP(199) ) IF ( TYPE_PARALL .eq. 0 ) THEN IRANK = IRANK + 1 END IF IF ( (ITYPE .EQ. 2) .OR. & (ITYPE .EQ. 3 .AND. .NOT. EARLYT3ROOTINS ) .OR. & (ITYPE .EQ. 1 .AND. IRANK .EQ. MYID) ) THEN DO K = FRTPTR(I),FRTPTR(I+1)-1 ELT = FRTELT(K) PTRAIW( ELT ) = PTRARW(ELT+1) - PTRARW(ELT) ENDDO ELSE END IF END DO IPTRI8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT ) PTRAIW( ELT ) = IPTRI8 IPTRI8 = IPTRI8 + NVAR8 ENDDO PTRAIW( NELT+1 ) = IPTRI8 KEEP8(27) = IPTRI8 - 1 IF ( .TRUE. ) THEN IF (SYM .EQ. 0) THEN IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + NVAR8*NVAR8 ENDDO PTRARW( NELT+1 ) = IPTRR8 ELSE IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + (NVAR8*(NVAR8+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR8 ENDIF ELSE IF (SYM .EQ. 0) THEN IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + NVAR8*NVAR8 ENDDO PTRARW( NELT+1 ) = IPTRR8 ELSE IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + (NVAR8*(NVAR8+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR8 ENDIF ENDIF KEEP8(26) = IPTRR8 - 1_8 RETURN END SUBROUTINE CMUMPS_ANA_DIST_ELEMENTS SUBROUTINE CMUMPS_ELTPROC( N, NELT, ELTPROC, SLAVEF, PROCNODE, & KEEP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, SLAVEF INTEGER, INTENT(IN) :: PROCNODE( N ) INTEGER, INTENT(INOUT) :: ELTPROC( NELT ) INTEGER :: KEEP(500) INTEGER ELT, I, ITYPE LOGICAL :: EARLYT3ROOTINS INTEGER, EXTERNAL :: MUMPS_TYPENODE, MUMPS_PROCNODE EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) DO ELT = 1, NELT I = ELTPROC(ELT) IF ( I .NE. 0) THEN ITYPE = MUMPS_TYPENODE(PROCNODE(I),KEEP(199)) IF (ITYPE.EQ.1) THEN ELTPROC(ELT) = MUMPS_PROCNODE(PROCNODE(I),KEEP(199)) ELSE IF ( ITYPE.EQ.2 .OR. .NOT. EARLYT3ROOTINS ) THEN ELTPROC(ELT) = -1 ELSE ELTPROC(ELT) = -2 ENDIF ELSE ELTPROC(ELT) = -3 ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_ELTPROC SUBROUTINE CMUMPS_FRTELT(N, NELT, NELNOD, FRERE, FILS, NA, NE, & XNODEL, NODEL, FRTPTR, FRTELT, ELTNOD) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, NELNOD INTEGER, INTENT(IN) :: FRERE(N), FILS(N), NA(N), NE(N) INTEGER, INTENT(OUT):: FRTPTR(N+1), FRTELT(NELT), ELTNOD(NELT) INTEGER, INTENT(IN) :: XNODEL(N+1), NODEL(NELNOD) INTEGER, DIMENSION(:), ALLOCATABLE :: TNSTK, IPOOL INTEGER I, K, IFATH, allocok INTEGER INODE, LEAF, NBLEAF, NBROOT, III, IN ALLOCATE(TNSTK( N ), stat=allocok) IF (allocok.ne.0) THEN WRITE(6,*) ' Allocation error of TNSTK in ' & // 'routine CMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF ALLOCATE(IPOOL( N ), stat=allocok) IF (allocok.ne.0) THEN WRITE(6,*) ' Allocation error of IPOOL in ' & // 'routine CMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF TNSTK = NE LEAF = 1 IF (N.EQ.1) THEN NBROOT = 1 NBLEAF = 1 IPOOL(1) = 1 LEAF = LEAF + 1 ELSEIF (NA(N).LT.0) THEN NBLEAF = N NBROOT = N DO 20 I=1,NBLEAF-1 INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 20 CONTINUE INODE = -NA(N)-1 IPOOL(LEAF) = INODE LEAF = LEAF + 1 ELSEIF (NA(N-1).LT.0) THEN NBLEAF = N-1 NBROOT = NA(N) IF (NBLEAF-1.GT.0) THEN DO 30 I=1,NBLEAF-1 INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 30 CONTINUE ENDIF INODE = -NA(N-1)-1 IPOOL(LEAF) = INODE LEAF = LEAF + 1 ELSE NBLEAF = NA(N-1) NBROOT = NA(N) DO 40 I = 1,NBLEAF INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 40 CONTINUE ENDIF ELTNOD(1:NELT) = 0 III = 1 90 CONTINUE IF (III.NE.LEAF) THEN INODE=IPOOL(III) III = III + 1 ELSE WRITE(6,*) ' ERROR 1 in subroutine CMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF 95 CONTINUE IN = INODE 100 CONTINUE DO K = XNODEL(IN),XNODEL(IN+1)-1 I = NODEL(K) IF (ELTNOD(I).EQ.0) ELTNOD(I) = INODE ENDDO IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IN = INODE 110 IN = FRERE(IN) IF (IN.GT.0) GO TO 110 IF (IN.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 115 GOTO 90 ELSE IFATH = -IN ENDIF TNSTK(IFATH) = TNSTK(IFATH) - 1 IF ( TNSTK(IFATH) .EQ. 0 ) THEN INODE = IFATH GOTO 95 ELSE GOTO 90 ENDIF 115 CONTINUE FRTPTR(1:N) = 0 DO I = 1,NELT IF (ELTNOD(I) .NE. 0) THEN FRTPTR(ELTNOD(I)) = FRTPTR(ELTNOD(I)) + 1 ENDIF ENDDO K = 1 DO I = 1,N K = K + FRTPTR(I) FRTPTR(I) = K ENDDO FRTPTR(N+1) = FRTPTR(N) DO K = 1,NELT INODE = ELTNOD(K) IF (INODE .NE. 0) THEN FRTPTR(INODE) = FRTPTR(INODE) - 1 FRTELT(FRTPTR(INODE)) = K ENDIF ENDDO DEALLOCATE(TNSTK, IPOOL) RETURN END SUBROUTINE CMUMPS_FRTELT SUBROUTINE CMUMPS_ANA_G11_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, LW, IW) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8) :: LW INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW) INTEGER I,J,K1,K2,K3,LP,NSUP,SUPVAR INTEGER INFO44(6) EXTERNAL CMUMPS_SUPVAR LP = 6 CALL CMUMPS_SUPVAR(N,NELT,XELNOD(NELT+1)-1,ELNOD,XELNOD, & NSUP,IW(3_8*int(N,8)+3_8+1_8), & 3_8*int(N,8)+3_8,IW,LP,INFO44) IF (INFO44(1) .LT. 0) THEN IF (LP.GE.0) WRITE(LP,*) & 'Error return from CMUMPS_SUPVAR. INFO(1) = ',INFO44(1) ENDIF IW(1:NSUP) = 0 LEN(1:N) = 0 DO I = 1,N SUPVAR = IW(3_8*int(N,8)+3_8+1_8+int(I,8)) IF (SUPVAR .EQ. 0) CYCLE IF (IW(SUPVAR).NE.0) THEN LEN(I) = -IW(SUPVAR) ELSE IW(SUPVAR) = I ENDIF ENDDO IW(int(N+1,8):2_8*int(N,8)) = 0 NZ = 0_8 DO SUPVAR = 1,NSUP I = IW(SUPVAR) DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF (LEN(J).GE.0) THEN IF ((I.NE.J) .AND. (IW(int(N,8)+int(J,8)).NE.I)) THEN IW(int(N,8)+int(J,8)) = I LEN(I) = LEN(I) + 1 ENDIF ENDIF ENDIF ENDDO ENDDO NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE CMUMPS_ANA_G11_ELT SUBROUTINE CMUMPS_ANA_G12_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IF (LEN(I).GT.0) THEN IWFR = IWFR + int(LEN(I),8) IPE(I) = IWFR ELSE IPE(I) = 0_8 ENDIF ENDDO FLAG(1:N) = 0 DO I = 1,N IF (LEN(I).LE.0) CYCLE DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF (LEN(J) .GT. 0) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1 IW(IPE(I)) = J FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE CMUMPS_ANA_G12_ELT SUBROUTINE CMUMPS_SUPVAR(N,NELT,NZ,ELTVAR,ELTPTR,NSUP,SVAR, & LIW,IW,LP,INFO) INTEGER LP,N,NELT,NSUP,NZ INTEGER(8)::LIW INTEGER INFO(6) INTEGER ELTPTR(NELT+1),ELTVAR(NZ) INTEGER IW(LIW),SVAR(0:N) INTEGER(8) :: FLAG,NEW,VARS 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) = N + 1 GO TO 40 END IF NEW = 1_8 VARS = NEW + LIW/3_8 FLAG = VARS + LIW/3_8 CALL CMUMPS_SUPVARB(N,NELT,ELTPTR,NZ,ELTVAR,SVAR,NSUP, & int(min(int(huge(NSUP)-1,8),LIW/3_8-1_8)), & IW(NEW),IW(VARS),IW(FLAG),INFO) IF (INFO(1).EQ.-4) THEN INFO(4) = N + 1 GO TO 40 ELSE INFO(4) = NSUP + 1 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) 3_8*int(INFO(4),8) END IF 50 RETURN 9000 FORMAT (/3X,'Error message from CMUMPS_SUPVAR: INFO(1) = ',I2) 9010 FORMAT (3X,'LIW is insufficient. Upper bound on required work', & 'space is ',I12) END SUBROUTINE CMUMPS_SUPVAR SUBROUTINE CMUMPS_SUPVARB( N, NELT, ELTPTR, NZ, ELTVAR, & SVAR, NSUP, MAXSUP, NEW, VARS, FLAG, INFO ) INTEGER MAXSUP,N,NELT,NSUP,NZ INTEGER ELTPTR(NELT+1),ELTVAR(NZ) INTEGER INFO(6) INTEGER FLAG(0:MAXSUP), NEW(0:MAXSUP),SVAR(0:N), & VARS(0:MAXSUP) INTEGER I,IS,J,JS,K,K1,K2 DO 10 I = 0,N SVAR(I) = 0 10 CONTINUE VARS(0) = N + 1 NEW(0) = -1 FLAG(0) = 0 NSUP = 0 DO 40 J = 1,NELT K1 = ELTPTR(J) K2 = ELTPTR(J+1) - 1 DO 20 K = K1,K2 I = ELTVAR(K) IF (I.LT.1 .OR. I.GT.N) THEN INFO(2) = INFO(2) + 1 GO TO 20 END IF IS = SVAR(I) IF (IS.LT.0) THEN ELTVAR(K) = 0 INFO(3) = INFO(3) + 1 GO TO 20 END IF SVAR(I) = SVAR(I) - N - 2 VARS(IS) = VARS(IS) - 1 20 CONTINUE DO 30 K = K1,K2 I = ELTVAR(K) IF (I.LT.1 .OR. I.GT.N) GO TO 30 IS = SVAR(I) + N + 2 IF (FLAG(IS).LT.J) THEN FLAG(IS) = J IF (VARS(IS).GT.0) THEN NSUP = NSUP + 1 IF (NSUP.GT.MAXSUP) THEN INFO(1) = -4 RETURN END IF VARS(NSUP) = 1 FLAG(NSUP) = J NEW(IS) = NSUP SVAR(I) = NSUP ELSE VARS(IS) = 1 NEW(IS) = IS SVAR(I) = IS END IF ELSE JS = NEW(IS) VARS(JS) = VARS(JS) + 1 SVAR(I) = JS END IF 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE CMUMPS_SUPVARB MUMPS_5.8.1/src/sfac_front_type2_aux.F0000664000175000017500000007560015042446437017501 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_FRONT_TYPE2_AUX_M CONTAINS SUBROUTINE SMUMPS_FAC_I_LDLT_NIV2( & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, & NFRONT, NASS, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK, & NASS2, TIPIV, & N, INODE, IW, LIW, A, LA, NNEGW, NNULLNEGW, & NB22T2W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INOPV, IFLAG,IERROR, & IOLDPS, POSELT, UU, & SEUIL,KEEP,KEEP8,PIVSIZ, & DKEEP, PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & PP_FIRST2SWAP_L, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled, & PIVOT_OPTION, & Inextpiv, IEND_BLR, LR_ACTIVATED, & OOC_EFFECTIVE_ON_FRONT) USE MUMPS_OOC_COMMON, ONLY : TYPEF_L USE SMUMPS_FAC_FRONT_AUX_M USE MUMPS_PIVNUL_MOD IMPLICIT NONE INTEGER SIZEDIAG_ORIG REAL DIAG_ORIG(SIZEDIAG_ORIG) REAL GW_FACTCUMUL INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,IERROR,INOPV INTEGER NASS2, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK INTEGER, intent(inout) :: NNEGW, NNULLNEGW, NB22T2W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW INTEGER TIPIV( NASS2 ) INTEGER PIVSIZ,LPIV INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER(8) :: LA REAL A(LA) REAL UU, UULOC, SEUIL REAL CSEUIL INTEGER IW(LIW) INTEGER IOLDPS INTEGER(8) :: POSELT INTEGER KEEP(500) INTEGER(8) KEEP8(150) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT LOGICAL :: SWAP_OCCURRED REAL DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled include 'mpif.h' INTEGER(8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX INTEGER :: IPIVNUL, HF REAL RMAX,AMAX,TMAX,RMAX_NORELAX,MAX_PREV_in_PARPIV REAL MAXPIV, ABS_PIVOT REAL RMAX_NOSLAVE, TMAX_NOSLAVE REAL PIVOT,DETPIV REAL ABSDETPIV INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX, APOSROW INTEGER(8) :: APOS INTEGER(8) :: J1, J2, JJ, KK REAL :: GROWTH, RSWOP REAL :: UULOCM1 INTEGER :: LDAFS INTEGER(8) :: LDAFS8 REAL, PARAMETER :: RZERO = 0.0E0 REAL, PARAMETER :: RONE = 1.0E0 REAL ZERO, ONE PARAMETER( ZERO = 0.0E0 ) PARAMETER( ONE = 1.0E0 ) REAL PIVNUL, VALTMP REAL FIXA INTEGER NPIV,IPIV,K219 INTEGER NPIVP1,ILOC,K,J INTEGER ISHIFT, K206, IPIV_END, IPIV_SHIFT INTRINSIC max INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L REAL GW_FACT GW_FACT = RONE AMAX = RZERO RMAX = RZERO TMAX = RZERO RMAX_NOSLAVE = RZERO PIVOT = ONE HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) K206 = KEEP(206) PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL LDAFS = NASS LDAFS8 = int(LDAFS,8) IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+KEEP(IXSZ)) & +KEEP(IXSZ), & IW, LIW) ENDIF UULOC = UU K219 = KEEP(219) IF (UULOC.GT.RZERO) THEN UULOCM1 = RONE/UULOC ELSE K219=0 UULOCM1 = RONE ENDIF IF (K219.LT.2) GW_FACTCUMUL = RONE PIVSIZ = 1 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NPIVP1 = NPIV + 1 ILOC = NPIVP1 - IBEG_BLOCK_TO_SEND + 1 TIPIV( ILOC ) = ILOC APOSMAX = POSELT+LDAFS8*LDAFS8-1_8 IF(INOPV .EQ. -1) THEN APOS = POSELT + LDAFS8*int(NPIVP1-1,8) + int(NPIV,8) POSPV1 = APOS ABS_PIVOT = abs(PIVOT) CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, & DKEEP, KEEP, .TRUE.) IF(ABS_PIVOT.LT.SEUIL) THEN IF(real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL NNEGW = NNEGW+1 ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE.0 ) THEN CALL SMUMPS_UPDATEDETER( A(APOS), DET_MANTW, DET_EXPW ) ENDIF IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 IF ((K219.GE.2).AND.(NPIVP1.EQ.1)) THEN GW_FACTCUMUL = RONE IF (K219.EQ.3) THEN DO IPIV=1,NASS DIAG_ORIG (IPIV) = abs(A(POSELT + & (LDAFS8+1_8)*int(IPIV-1,8))) ENDDO ELSE IF (K219.GE.4) THEN DIAG_ORIG = RZERO DO IPIV=1,NASS APOS = POSELT + LDAFS8*int(IPIV-1,8) POSPV1 = APOS + int(IPIV - 1,8) DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) DO J=IPIV+1,NASS DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) DIAG_ORIG(IPIV+J-IPIV) = max( abs(A(POSPV1)), & DIAG_ORIG(IPIV+J-IPIV) ) POSPV1 = POSPV1 + LDAFS8 ENDDO ENDDO ENDIF ENDIF ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + LDAFS8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN IF(ABS_PIVOT.LT.SEUIL) THEN CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, & DKEEP, KEEP, .TRUE.) IF(real(PIVOT) .GE. RZERO) THEN A(POSPV1) = CSEUIL ELSE A(POSPV1) = -CSEUIL NNEGW = NNEGW+1 ENDIF NBTINYW = NBTINYW + 1 ELSE IF (ABS_PIVOT.EQ.RZERO) THEN GO TO 630 ELSE IF (PIVOT.LT.RZERO) NNEGW = NNEGW+1 CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF ENDIF GO TO 420 ENDIF AMAX = -RONE JMAX = 0 J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDAFS8 DO J=1, IEND_BLOCK - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDAFS8 ENDDO RMAX_NOSLAVE = RZERO IF (PIVOT_OPTION.EQ.2) THEN DO J=1,NASS - IEND_BLOCK RMAX_NOSLAVE = max(abs(A(J1+LDAFS8*int(J-1,8))), & RMAX_NOSLAVE) ENDDO ENDIF IF (K219.NE.0) THEN RMAX_NORELAX = real(A(APOSMAX+int(IPIV,8))) RMAX = RMAX_NORELAX IF (K219.GE.2) THEN IF (ABS_PIVOT.NE.RZERO.AND. & ABS_PIVOT.GE.UULOC*max(RMAX,RMAX_NOSLAVE,AMAX)) & THEN GROWTH = RONE IF (K219.EQ.3) THEN IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN DIAG_ORIG(IPIV) = ABS_PIVOT ELSE GROWTH = ABS_PIVOT / DIAG_ORIG(IPIV) ENDIF ELSE IF (K219.GE.4) THEN IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN DIAG_ORIG(IPIV) = max(AMAX,RMAX_NOSLAVE) ELSE GROWTH = max(ABS_PIVOT,AMAX,RMAX_NOSLAVE)/ & DIAG_ORIG(IPIV) ENDIF ENDIF RMAX = RMAX*max(GROWTH,GW_FACTCUMUL) ENDIF ENDIF ELSE RMAX = RZERO RMAX_NORELAX = RZERO ENDIF RMAX_NOSLAVE = max(RMAX_NORELAX,RMAX_NOSLAVE) RMAX = max(RMAX,RMAX_NOSLAVE) IF (max(AMAX,RMAX,ABS_PIVOT).LE.PIVNUL) THEN IF ((K219.NE.0) & .AND.(K219.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & real(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + LDAFS8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) THEN GOTO 460 ENDIF ENDDO ENDIF ENDIF CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(POSPV1)), DKEEP, KEEP, .TRUE.) IF ( A(POSPV1) .LT. RZERO ) NNULLNEGW=NNULLNEGW+1 KEEP(109) = KEEP(109) + 1 IPIVNUL = KEEP(109) IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST.LT.KEEP(109)) & THEN CALL MUMPS_RESIZE_PIVNUL(KEEP, N, PIVNUL_LIST_STRUCT, & IPIVNUL, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 430 ENDIF PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) IF (real(FIXA).GT.RZERO) THEN IF(real(PIVOT) .GE. RZERO) THEN A(POSPV1) = FIXA ELSE A(POSPV1) = -FIXA ENDIF ELSE J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 A(JJ) = ZERO ENDDO DO J=1, NASS-IPIV A(POSPV1+int(J,8)*LDAFS8) = ZERO ENDDO VALTMP = max(1.0E10*RMAX, sqrt(huge(RMAX))/1.0E8) A(POSPV1) = VALTMP ENDIF PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) GO TO 415 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF (ABS_PIVOT.GE.UULOC*max(RMAX,AMAX) & .AND. ABS_PIVOT .GT. max(SEUIL, tiny(RMAX))) THEN IF (A(POSPV1).LT.RZERO) NNEGW = NNEGW+1 CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL SMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) THEN GOTO 460 ELSE IF (JMAX .EQ.0) THEN GOTO 460 ENDIF IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN GOTO 460 ENDIF IF (RMAX_NOSLAVE.LT.AMAX) THEN J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN RMAX_NOSLAVE = max(RMAX_NOSLAVE,abs(A(JJ))) ENDIF ENDDO DO J=1,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX_NOSLAVE = max(abs(A(POSPV1+LDAFS8*int(J,8))), & RMAX_NOSLAVE) ENDIF ENDDO RMAX = max(RMAX, RMAX_NOSLAVE) ENDIF APOSJ = POSELT + int(JMAX-1,8)*LDAFS8 + int(NPIV,8) POSPV2 = APOSJ + int(JMAX - NPIVP1,8) IF (IPIV.LT.JMAX) THEN OFFDAG = APOSJ + int(IPIV - NPIVP1,8) ELSE OFFDAG = APOS + int(JMAX - NPIVP1,8) END IF TMAX_NOSLAVE = RZERO IF(JMAX .LT. IPIV) THEN JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+LDAFS8 IF (JMAX+K.NE.IPIV) THEN TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) ENDIF ENDDO DO KK = APOSJ, POSPV2-1_8 TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) ENDDO ELSE JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+LDAFS8 TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) ENDDO DO KK = APOSJ, POSPV2 - 1_8 IF (KK.NE.OFFDAG) THEN TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) ENDIF ENDDO ENDIF IF (K219.NE.0) THEN TMAX = max(SEUIL*UULOCM1, & abs(real(A(APOSMAX+int(JMAX,8)))) & ) ELSE TMAX = SEUIL*UULOCM1 ENDIF IF (K219.GE.2) THEN GROWTH = RONE IF (K219.EQ.3) THEN IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN DIAG_ORIG(JMAX) = abs(A(POSPV2)) ELSE GROWTH = abs(A(POSPV2))/DIAG_ORIG(JMAX) ENDIF ELSE IF (K219.EQ.4) THEN IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN DIAG_ORIG(JMAX)=max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) ELSE GROWTH = max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) & / DIAG_ORIG(JMAX) ENDIF ENDIF TMAX = TMAX*max(GROWTH,GW_FACTCUMUL) ENDIF TMAX = max (TMAX,TMAX_NOSLAVE) DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)*A(OFFDAG) ABSDETPIV = abs(DETPIV) IF (SEUIL.GT.RZERO) THEN IF (sqrt(ABSDETPIV) .LE. SEUIL ) THEN GOTO 460 ENDIF ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN GO TO 460 ENDIF IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN GO TO 460 ENDIF CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( sqrt(abs(DETPIV)), & DKEEP, KEEP, .FALSE.) IF (KEEP(258).NE.0) THEN CALL SMUMPS_UPDATEDETER(DETPIV, DET_MANTW, DET_EXPW ) ENDIF PIVSIZ = 2 NB22T2W = NB22T2W+1 IF(DETPIV .LT. RZERO) THEN NNEGW = NNEGW+1 ELSE IF(A(POSPV2) .LT. RZERO) THEN NNEGW = NNEGW+2 ENDIF 415 CONTINUE IF (K206.GE.1) THEN Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) ENDIF DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2 ) THEN IF (K==1) THEN LPIV = min(IPIV, JMAX) TIPIV(ILOC) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) ELSE LPIV = max(IPIV, JMAX) TIPIV(ILOC+1) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) ENDIF ELSE LPIV = IPIV TIPIV(ILOC) = IPIV - IBEG_BLOCK_TO_SEND + 1 ENDIF IF (LPIV.EQ.NPIVP1) THEN GOTO 416 ENDIF KEEP8(80) = KEEP8(80)+1 CALL SMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDAFS, NFRONT, 2, K219, KEEP(50), & KEEP(IXSZ), IBEG_BLOCK_TO_SEND ) SWAP_OCCURRED = .TRUE. IF (K219.GE.3) THEN RSWOP = DIAG_ORIG(LPIV) DIAG_ORIG(LPIV) = DIAG_ORIG(NPIVP1) DIAG_ORIG(NPIVP1) = RSWOP ENDIF 416 CONTINUE IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL SMUMPS_STORE_PERMINFO( & IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF NPIVP1 = NPIVP1+1 ENDDO IF(PIVSIZ .EQ. 2) THEN A(POSELT+LDAFS8*int(NPIV,8)+int(NPIV+1,8)) = DETPIV ENDIF GOTO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE IFLAG = -10 420 CONTINUE IF (K219.GE.2) THEN IF(INOPV .EQ. 0) THEN IF(PIVSIZ .EQ. 1) THEN GW_FACT = max(AMAX,RMAX_NOSLAVE)/ABS_PIVOT ELSE IF(PIVSIZ .EQ. 2) THEN GW_FACT = max( & (abs(A(POSPV2))*RMAX_NOSLAVE+AMAX*TMAX_NOSLAVE) & / ABSDETPIV , & (abs(A(POSPV1))*TMAX_NOSLAVE+AMAX*RMAX_NOSLAVE) & / ABSDETPIV & ) ENDIF GW_FACT = min(GW_FACT, UULOCM1) GW_FACTCUMUL = max(GW_FACT,GW_FACTCUMUL) ENDIF ENDIF 430 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_I_LDLT_NIV2 SUBROUTINE SMUMPS_FAC_MQ_LDLT_NIV2 & (IEND_BLOCK, & NASS, NPIV, INODE, A, LA, LDAFS, & POSELT,IFINB,PIVSIZ, & K219, PIVOT_OPTION, IEND_BLR, LR_ACTIVATED) IMPLICIT NONE INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: K219 REAL, intent(inout) :: A(LA) INTEGER, intent(in) :: IEND_BLOCK INTEGER, intent(in) :: NPIV, PIVSIZ INTEGER, intent(in) :: NASS,INODE,LDAFS INTEGER, intent(out) :: IFINB INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED REAL VALPIV INTEGER NCB1 INTEGER(8) :: APOS, APOSMAX INTEGER(8) :: LPOS, LPOS1, LPOS2, K1POS INTEGER(8) :: JJ, K1, K2 INTEGER(8) :: POSPV1, POSPV2, OFFDAG, OFFDAG_OLD INTEGER(8) :: LDAFS8 INTEGER NEL2 REAL ONE, ALPHA REAL ZERO INTEGER NPIV_NEW, I INTEGER(8) :: IBEG, IEND, IROW, J8 INTEGER :: J2 REAL SWOP,DETPIV,MULT1,MULT2, A11, A22, A12 PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) PARAMETER (ZERO=0.0E0) INCLUDE 'mumps_headers.h' LDAFS8 = int(LDAFS,8) NPIV_NEW = NPIV + PIVSIZ IFINB = 0 NEL2 = IEND_BLOCK - NPIV_NEW IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ENDIF IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDAFS8 DO I = 1, NEL2 K1POS = LPOS + int(I-1,8)*LDAFS8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ=1_8, int(I,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO IF (PIVOT_OPTION.EQ.2) THEN NCB1 = NASS - IEND_BLOCK ELSE NCB1 = IEND_BLR - IEND_BLOCK ENDIF !$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) DO I=NEL2+1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDAFS8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO !$OMP END PARALLEL DO IF (K219.eq. -1) THEN APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) A(APOSMAX) = A(APOSMAX) * abs(VALPIV) DO J8 = 1_8, int(NEL2+NCB1,8) A(APOSMAX+J8) = A(APOSMAX+J8) + & A(APOSMAX) * abs(A(APOS+J8)) ENDDO ENDIF ELSE POSPV1 = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) POSPV2 = POSPV1+LDAFS8+1_8 OFFDAG_OLD = POSPV2 - 1_8 OFFDAG = POSPV1+1_8 SWOP = A(POSPV2) DETPIV = A(OFFDAG) A22 = A(POSPV1)/DETPIV A11 = SWOP/DETPIV A12 = -A(OFFDAG_OLD)/DETPIV A(OFFDAG) = A(OFFDAG_OLD) A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDAFS8 - 1_8 LPOS2 = LPOS1 + 1_8 CALL scopy(NASS-NPIV_NEW, A(LPOS1), LDAFS, A(POSPV1+2_8), 1) CALL scopy(NASS-NPIV_NEW, A(LPOS2), LDAFS, A(POSPV2+1_8), 1) JJ = POSPV2 + int(NASS-1,8) IBEG = JJ + 2_8 IEND = IBEG DO J2 = 1,NEL2 K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1+2_8 K2 = POSPV2+1_8 DO IROW = IBEG,IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = -MULT1 A(JJ+1_8) = -MULT2 IBEG = IBEG + int(NASS,8) IEND = IEND + int(NASS + 1,8) JJ = JJ+int(NASS,8) ENDDO IEND = IEND-1_8 DO J2 = IEND_BLOCK+1,NASS K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1+2_8 K2 = POSPV2+1_8 DO IROW = IBEG,IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = -MULT1 A(JJ+1_8) = -MULT2 IBEG = IBEG + int(NASS,8) IEND = IEND + int(NASS,8) JJ = JJ+int(NASS,8) ENDDO IF (K219.eq. -1) THEN APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) JJ = APOSMAX K1 = JJ K2 = JJ + 1_8 MULT1 = abs(A11)*A(K1)+abs(A12)*A(K2) MULT2 = abs(A12)*A(K1)+abs(A22)*A(K2) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 IBEG = APOSMAX + 2_8 IEND = APOSMAX + 1_8 + NASS - NPIV_NEW DO IROW = IBEG, IEND A(IROW) = A(IROW) + MULT1*abs(A(K1)) + MULT2*abs(A(K2)) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = MULT1 A(JJ+1_8) = MULT2 ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_FAC_MQ_LDLT_NIV2 SUBROUTINE SMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, N, & INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, LDA_FS, & IBEG_PANEL, IEND, TIPIV, LPIV, LASTPANEL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED, NPARTSASS, CURRENT_BLR_PANEL & , BLR_LorU & , LRGROUPS & ) USE SMUMPS_BUF USE MUMPS_LOAD USE SMUMPS_LR_TYPE USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, IBEG_PANEL, IEND, LPIV, & IOLDPS, LDA_FS, NB_BLOC_FAC INTEGER(8) :: POSELT, LA INTEGER IW(LIW), TIPIV(LPIV) LOGICAL LASTPANEL REAL A(LA) INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL, & SLAVEF, ICNTL(60) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), & PERM(N), PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL, intent(in) :: LR_ACTIVATED TYPE (LRB_TYPE), DIMENSION(:) :: BLR_LorU INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER :: NELIM INTEGER, intent(in) :: NPARTSASS, CURRENT_BLR_PANEL INCLUDE 'mumps_headers.h' INTEGER(8) :: APOS, LREQA INTEGER NPIV, NCOL, PDEST, NSLAVES, WIDTH INTEGER IERR, LREQI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED DOUBLE PRECISION FLOP1,FLOP2 LOGICAL COMPRESS_CB INTEGER NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 IF (NSLAVES.EQ.0) THEN WRITE(6,*) ' ERROR 1 in SMUMPS_SEND_FACTORED_PANEL ' CALL MUMPS_ABORT() ENDIF NPIV = IEND - IBEG_PANEL + 1 NCOL = LDA_FS - IBEG_PANEL + 1 APOS = POSELT + int(LDA_FS,8)*int(IBEG_PANEL-1,8) + & int(IBEG_PANEL - 1,8) IF (IBEG_PANEL > 0) THEN CALL MUMPS_GET_FLOPS_COST( LDA_FS, IBEG_PANEL-1, LPIV, & KEEP(50),2,FLOP1) ELSE FLOP1=0.0D0 ENDIF CALL MUMPS_GET_FLOPS_COST( LDA_FS, IEND, LPIV, & KEEP(50),2,FLOP2) FLOP2 = FLOP1 - FLOP2 CALL MUMPS_LOAD_UPDATE(1, .FALSE., FLOP2, KEEP,KEEP8) IF ((NPIV.GT.0) .OR. & ((NPIV.EQ.0).AND.(LASTPANEL)) & ) THEN IF ((NPIV.EQ.0).AND.(LASTPANEL)) THEN IF (COMPRESS_CB) THEN IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 COMPRESS_CB = .FALSE. ENDIF ENDIF PDEST = IOLDPS + 6 + KEEP(IXSZ) IF (( NPIV .NE. 0 ).AND.(KEEP(50).NE.0)) THEN NB_BLOC_FAC = NB_BLOC_FAC + 1 END IF IERR = -1 DO WHILE (IERR .EQ.-1) WIDTH = NSLAVES CALL SMUMPS_BUF_SEND_BLOCFACTO( INODE, LDA_FS, NCOL, & NPIV, FPERE, LASTPANEL, TIPIV, A(APOS), & IW(PDEST), NSLAVES, KEEP, NB_BLOC_FAC, & NSLAVES, WIDTH, COMM, & NELIM, NPARTSASS, CURRENT_BLR_PANEL, & LR_ACTIVATED, BLR_LorU, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & IBEG_PANEL, COMPRESS_CB, & ICNTL, IERR ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (MESSAGE_RECEIVED) THEN POSELT = PTRAST(STEP(INODE)) APOS = POSELT + int(LDA_FS,8)*int(IBEG_PANEL-1,8) + & int(IBEG_PANEL - 1,8) ENDIF IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2 .OR. IERR.EQ.-3 ) THEN IF (IERR.EQ.-2) IFLAG = -17 IF (IERR.EQ.-3) IFLAG = -20 LREQA = int(NCOL,8)*int(NPIV,8) LREQI = NPIV + 6 + 2*NSLAVES + 2 CALL MUMPS_SET_IERROR( & int(LREQI,8) * int(KEEP(34),8) + LREQA * int(KEEP(35),8), & IERROR) GOTO 300 ENDIF ENDIF GOTO 500 300 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE SMUMPS_SEND_FACTORED_PANEL END MODULE SMUMPS_FAC_FRONT_TYPE2_AUX_M MUMPS_5.8.1/src/dfac_mem_stack.F0000664000175000017500000005747415042446440016300 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_FAC_STACK(COMM_LOAD, ASS_IRECV, & N, INODE, TYPE, TYPEF, & LA, IW, LIW, A, & IFLAG, IERROR, OPELIW, NELVAW, NMAXNPIV, & PTRIST, PTLUST_S, & PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, NE, & POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP,KEEP8,DKEEP, & COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, SLAVEF, & FPERE, COMM, MYID, IPOOL, LPOOL, LEAF, NSTK_S, & PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, root, roota, & OPASSW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & , FLOP_ESTIM_ACC & ) USE DMUMPS_BUF, ONLY : DMUMPS_BUF_SEND_CB, DMUMPS_BUF_SEND_MAITRE2 USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_RTNELIND, & MUMPS_BUF_SEND_ROOT2SON USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER COMM, MYID, TYPE, TYPEF INTEGER N, LIW, INODE,IFLAG,IERROR INTEGER ICNTL(60), KEEP(500) DOUBLE PRECISION DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU INTEGER IWPOSCB, IWPOS, & FPERE, SLAVEF, NELVAW, NMAXNPIV INTEGER IW(LIW),PROCNODE_STEPS(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NE(KEEP(28)) DOUBLE PRECISION A(LA) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER LPOOL, LEAF, COMP INTEGER IPOOL( LPOOL ) INTEGER NSTK_S( KEEP(28) ) INTEGER PERM(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER NBFIN INTEGER NFRONT_ESTIM,NELIM_ESTIM DOUBLE PRECISION FLOP_ESTIM_ACC INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER NBROWS_ALREADY_SENT INTEGER(8) :: POSELT, OPSFAC INTEGER(8) :: IOLD, INEW, FACTOR_POS, I8 INTEGER NSLAVES, NCB, & H_INODE, IERR, NBCOL, NBROW, NBROW_SEND, & NELIM INTEGER NBROW_STACK, NBROW_INDICES, NBCOL_STACK INTEGER NCBROW_ALREADY_MOVED, NCBROW_PREVIOUSLY_MOVED, &NCBROW_NEWLY_MOVED INTEGER(8) :: LAST_ALLOWED_POS INTEGER(8) :: LREQCB, MIN_SPACE_IN_PLACE INTEGER(8) :: SHIFT_VAL_SON INTEGER SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, & LIST_ROW_SON, LIST_COL_SON, LIST_SLAVES INTEGER IOLDPS,NFRONT,NPIV,NASS,IOLDP1,PTROWEND, & LREQI, LCONT INTEGER I,LDA, INIV2 INTEGER MSGDEST, MSGTAG, CHK_LOAD INCLUDE 'mumps_headers.h' LOGICAL MUST_COMPACT_FACTORS LOGICAL PACKED_CB, COMPRESS_PANEL, COMPRESS_CB, LR_SOLVE LOGICAL INPLACE INTEGER(8) :: SIZE_INPLACE, FAC_ENTRIES, COUNT_EXTRA_IP_COPIES INTEGER INTSIZ DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL SSARBR, SSARBR_ROOT, MUMPS_INSSARBR, & MUMPS_IN_OR_ROOT_SSARBR EXTERNAL MUMPS_INSSARBR, MUMPS_IN_OR_ROOT_SSARBR 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 = abs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) H_INODE= 6 + NSLAVES + KEEP(IXSZ) LCONT = NFRONT - NPIV NBCOL = LCONT SSARBR = MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) SSARBR_ROOT = MUMPS_IN_OR_ROOT_SSARBR & (PROCNODE_STEPS(STEP(INODE)),KEEP(199)) LREQCB = 0_8 INPLACE = .FALSE. PACKED_CB = ((KEEP(215).EQ.0) & .AND.(KEEP(50).NE.0) & .AND.(TYPEF.EQ.1 & .OR.TYPEF.EQ.2 & ) & .AND.(TYPE.EQ.1)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = (IW(IOLDPS+XXLR).EQ.1.OR.IW(IOLDPS+XXLR).EQ.3) LR_SOLVE = (KEEP(486).EQ.2) MUST_COMPACT_FACTORS = .TRUE. IF (KEEP(201).EQ.1 .OR. KEEP(201).EQ.-1 & .OR. (COMPRESS_PANEL.AND.LR_SOLVE) & ) THEN MUST_COMPACT_FACTORS = .FALSE. ENDIF IF ((FPERE.EQ.0).AND.(NASS.NE.NPIV)) THEN IFLAG = -10 GOTO 600 ENDIF NBROW = LCONT IF (TYPE.EQ.2) NBROW = NASS - NPIV IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN LDA = NASS ELSE LDA = NFRONT ENDIF NBROW_SEND = NBROW NELIM = NASS-NPIV IF (TYPEF.EQ.2) NBROW_SEND = NELIM POSELT = PTRAST(STEP(INODE)) IF (POSELT .ne. PTRFAC(STEP(INODE))) THEN WRITE(*,*) MYID,":Error 1 in DMUMPS_FAC_STACK:" WRITE(*,*) "INODE, PTRAST, PTRFAC =", & INODE, PTRAST(STEP(INODE)), PTRFAC(STEP(INODE)) WRITE(*,*) "PACKED_CB, NFRONT, NPIV, NASS, NSLAVES", & PACKED_CB, NFRONT, NPIV, NASS, NSLAVES WRITE(*,*) "TYPE, TYPEF, FPERE ", & TYPE, TYPEF, FPERE CALL MUMPS_ABORT() END IF NELVAW = NELVAW + NASS - NPIV IF (KEEP(50) .eq. 0) THEN FAC_ENTRIES = int(NPIV,8) * int(NFRONT,8) ELSE FAC_ENTRIES = ( int(NPIV,8)*int(NPIV+1,8) )/ 2_8 ENDIF FAC_ENTRIES = FAC_ENTRIES + int(NBROW,8) * int(NPIV,8) IF ( KEEP(405) .EQ. 0 ) THEN KEEP8(10) = KEEP8(10) + FAC_ENTRIES KEEP(429) = KEEP(429) - 1 ELSE !$OMP ATOMIC UPDATE KEEP8(10) = KEEP8(10) + FAC_ENTRIES !$OMP END ATOMIC ENDIF CALL MUMPS_GET_FLOPS_COST( NFRONT, NPIV, NASS, & KEEP(50), TYPE,FLOP1 ) IF ( (.NOT. SSARBR_ROOT) .and. TYPE == 1) THEN IF (NE(STEP(INODE))==0) THEN CHK_LOAD=0 ELSE CHK_LOAD=1 ENDIF CALL MUMPS_LOAD_UPDATE(CHK_LOAD, .FALSE., -FLOP1, & KEEP,KEEP8) ENDIF FLOP1_EFFECTIVE = FLOP1 OPELIW = OPELIW + FLOP1 IF ( NPIV .NE. NASS ) THEN CALL MUMPS_GET_FLOPS_COST( NFRONT, NASS, NASS, & KEEP(50), TYPE,FLOP1 ) IF (.NOT. SSARBR_ROOT ) THEN IF (NE(STEP(INODE))==0) THEN CHK_LOAD=0 ELSE CHK_LOAD=1 ENDIF CALL MUMPS_LOAD_UPDATE(CHK_LOAD, .FALSE., & FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) ENDIF END IF IF ( SSARBR_ROOT ) THEN NFRONT_ESTIM=ND(STEP(INODE)) + KEEP(253) NELIM_ESTIM=NASS-(NFRONT-NFRONT_ESTIM) CALL MUMPS_GET_FLOPS_COST(NFRONT_ESTIM,NELIM_ESTIM,NELIM_ESTIM, & KEEP(50),1,FLOP1) END IF FLOP1=-FLOP1 IF (KEEP(400).GT.0) THEN FLOP_ESTIM_ACC = FLOP_ESTIM_ACC + FLOP1 ENDIF IF (SSARBR_ROOT) THEN CALL MUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1,KEEP,KEEP8) ELSE CALL MUMPS_LOAD_UPDATE(2,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF IF ( FPERE .EQ. 0 ) THEN IF ( KEEP(253) .NE. 0 .AND. KEEP(201).NE.-1 & .AND. KEEP(201).NE.1 & .AND. (.NOT.COMPRESS_PANEL.OR..NOT.LR_SOLVE) & ) THEN MUST_COMPACT_FACTORS = .TRUE. GOTO 190 ELSE IF ( KEEP(50) .NE. 0 .AND. KEEP(459).GT.1) THEN MUST_COMPACT_FACTORS = .TRUE. GOTO 190 ELSE MUST_COMPACT_FACTORS = .FALSE. GOTO 190 ENDIF ENDIF IF ( FPERE.EQ.KEEP(38) ) THEN NCB = NFRONT - NASS SHIFT_LIST_ROW_SON = H_INODE + NASS SHIFT_LIST_COL_SON = H_INODE + NFRONT + NASS SHIFT_VAL_SON = int(NASS,8)*int(NFRONT+1,8) IF (TYPE.EQ.1) THEN CALL DMUMPS_BUILD_AND_SEND_CB_ROOT( & COMM_LOAD, ASS_IRECV, N, INODE, FPERE, & PTLUST_S, PTRAST, & root, roota, NCB, NCB, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, & ROOT_CONT_STATIC, MYID, COMM, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE., ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS, 0, 0, 0 ) IF (IFLAG < 0 ) GOTO 500 ENDIF MSGDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)),KEEP(199)) IOLDPS = PTLUST_S(STEP(INODE)) LIST_ROW_SON = IOLDPS + H_INODE + NPIV LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) IF (MSGDEST.EQ.MYID) THEN CALL DMUMPS_PROCESS_RTNELIND( root, roota, & INODE, NELIM, NSLAVES, IW(LIST_ROW_SON), & IW(LIST_COL_SON), IW(LIST_SLAVES), & & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND) IF (IFLAG.LT.0) GOTO 600 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) CALL MUMPS_BUF_SEND_RTNELIND( INODE, NELIM, & IW(LIST_ROW_SON), IW(LIST_COL_SON), NSLAVES, & IW(LIST_SLAVES), MSGDEST, COMM, KEEP, IERR) IF ( IERR .EQ. -1 ) THEN BLOCKING =.FALSE. SET_IRECV =.TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, & ND, FRERE, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & .TRUE., LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IOLDPS = PTLUST_S(STEP(INODE)) LIST_ROW_SON = IOLDPS + H_INODE + NPIV LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) ENDIF ENDDO IF ( IERR .EQ. -2 ) THEN IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) IFLAG = - 17 GOTO 600 ELSE IF ( IERR .EQ. -3 ) THEN IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) IFLAG = -20 GOTO 600 ENDIF ENDIF IF (NELIM.EQ.0) THEN POSELT = PTRAST(STEP(INODE)) OPSFAC = POSELT + int(NPIV,8) * int(NFRONT,8) + int(NPIV,8) GOTO 190 ELSE GOTO 500 ENDIF ENDIF OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .NE. MYID ) THEN MSGTAG =NOEUD MSGDEST=MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), KEEP(199) ) IERR = -1 NBROWS_ALREADY_SENT = 0 DO WHILE (IERR.EQ.-1) IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN CALL DMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, & LCONT, NASS, NPIV, IW( IOLDPS + H_INODE + NPIV ), & IW( IOLDPS + H_INODE + NPIV + NFRONT ), & A( OPSFAC ), PACKED_CB, & MSGDEST, MSGTAG, COMM, KEEP, IERR ) ELSE IF ( TYPE.EQ.2 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ELSE INIV2 = -9999 ENDIF CALL DMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, & FPERE, INODE, & NBROW_SEND, IW(IOLDPS + H_INODE + NPIV ), & NBCOL, IW(IOLDPS + H_INODE + NPIV + NFRONT ), & A(OPSFAC), LDA, NELIM, TYPE, & NSLAVES, IW(IOLDPS+6+KEEP(IXSZ)), MSGDEST, & COMM, IERR, & & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) END IF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IOLDPS = PTLUST_S(STEP( INODE )) OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) END DO IF ( IERR .EQ. -2 .OR. IERR .EQ. -3 ) THEN IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN IERROR = ( 2*LCONT + 9 ) * KEEP( 34 ) + & LCONT*LCONT * KEEP( 35 ) ELSE IF (KEEP(50).ne.0 .AND. TYPE .eq. 2 ) THEN IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) & * KEEP( 34 ) + & NBROW_SEND*NBROW_SEND*KEEP( 35 ) ELSE IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) * KEEP( 34 ) + & NBROW_SEND*NBCOL*KEEP( 35 ) ENDIF IF (IERR .EQ. -2) THEN IFLAG = -17 IF ( LP > 0 ) THEN WRITE(LP, *) MYID, & ": FAILURE, SEND BUFFER TOO SMALL DURING & DMUMPS_FAC_STACK", TYPE, TYPEF ENDIF ENDIF IF (IERR .EQ. -3) THEN IFLAG = -20 IF ( LP > 0 ) THEN WRITE(LP, *) MYID, & ": FAILURE, RECV BUFFER TOO SMALL DURING & DMUMPS_FAC_STACK", TYPE, TYPEF ENDIF ENDIF GOTO 600 ENDIF ENDIF IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID ) THEN NBROW_SEND = 0 LREQI = 2 + KEEP(IXSZ) NBROW_STACK = NBROW NBROW_INDICES = NBROW IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN NBCOL_STACK = NELIM ELSE NBCOL_STACK = NBCOL ENDIF IF (COMPRESS_CB) THEN NBROW_STACK=NELIM IF (KEEP(50).NE.0) NBCOL_STACK = NELIM ENDIF ELSE NBROW_STACK = NBROW-NBROW_SEND NBROW_INDICES = NBROW-NBROW_SEND NBCOL_STACK = NBCOL IF (COMPRESS_CB) THEN NBROW_STACK = 0 NBCOL_STACK = 0 ENDIF LREQI = 6 + NBROW_INDICES + NBCOL + KEEP(IXSZ) IF (.NOT. (TYPE.EQ.1 .AND. TYPEF.EQ.2 ) ) GOTO 190 IF (FPERE.EQ.0) GOTO 190 ENDIF IF (PACKED_CB) THEN IF (NBROW_STACK.EQ.0.OR.NBCOL_STACK.EQ.0) THEN LREQCB = 0 ELSE LREQCB = ( int(NBCOL_STACK,8) * int( NBCOL_STACK + 1, 8) ) / 2_8 & - ( int(NBROW_SEND ,8) * int( NBROW_SEND + 1, 8) ) / 2_8 ENDIF ELSE LREQCB = int(NBROW_STACK,8) * int(NBCOL_STACK,8) ENDIF INPLACE = ( KEEP(234).NE.0 ) IF (KEEP(50).NE.0 .AND. TYPE .EQ. 2) INPLACE = .FALSE. INPLACE = INPLACE .OR. .NOT. MUST_COMPACT_FACTORS INPLACE = INPLACE .AND. & ( PTLUST_S(STEP(INODE)) + INTSIZ .EQ. IWPOS ) MIN_SPACE_IN_PLACE = 0_8 IF ( INPLACE .AND. KEEP(50).eq. 0 .AND. & MUST_COMPACT_FACTORS) THEN MIN_SPACE_IN_PLACE = int(NBCOL_STACK,8) ENDIF IF ( MIN_SPACE_IN_PLACE .GT. LREQCB ) THEN INPLACE = .FALSE. ENDIF CALL DMUMPS_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, .FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER,PAMASTER, & LREQI, LREQCB, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, LRLUSM, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 600 IW(IWPOSCB+1+XXF) = IW(IOLDPS+XXF) IW(IWPOSCB+1+XXLR) = IW(IOLDPS+XXLR) PTRIST(STEP(INODE)) = IWPOSCB+1 IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID ) THEN PIMASTER (STEP(INODE)) = PTLUST_S(STEP(INODE)) PAMASTER(STEP(INODE)) = IPTRLU + 1_8 PTRAST(STEP(INODE)) = -99999999_8 IW(IWPOSCB+1+KEEP(IXSZ)) = min(-NBCOL_STACK,-1) IW(IWPOSCB+2+KEEP(IXSZ)) = NBROW_STACK IF (PACKED_CB) IW(IWPOSCB+1+XXS) = S_CB1COMP ELSE PTRAST(STEP(INODE)) = IPTRLU+1_8 IF (PACKED_CB) IW(IWPOSCB+1+XXS)=S_CB1COMP IW(IWPOSCB+1+KEEP(IXSZ)) = NBCOL IW(IWPOSCB+2+KEEP(IXSZ)) = 0 IW(IWPOSCB+3+KEEP(IXSZ)) = NBROW_STACK IW(IWPOSCB+4+KEEP(IXSZ)) = 0 IW(IWPOSCB+5+KEEP(IXSZ)) = 1 IW(IWPOSCB+6+KEEP(IXSZ)) = 0 IOLDP1 = PTLUST_S(STEP(INODE))+H_INODE PTROWEND = IWPOSCB+6+NBROW_STACK+KEEP(IXSZ) DO I = 1, NBROW_STACK IW(IWPOSCB+7+KEEP(IXSZ)+I-1) = & IW(IOLDP1+NFRONT-NBROW_STACK+I-1) ENDDO DO I = 1, NBCOL IW(PTROWEND+I)=IW(IOLDP1+NFRONT+NPIV+I-1) ENDDO END IF IF ( KEEP(50).NE.0 .AND. TYPE .EQ. 1 & .AND. MUST_COMPACT_FACTORS ) THEN POSELT = PTRFAC(STEP(INODE)) CALL DMUMPS_COMPACT_FACTORS_SYM( A(POSELT), LDA, & NPIV, NBROW, KEEP, & int(LDA,8)*int(NBROW+NPIV,8), & IW( PTLUST_S(STEP(INODE)) + H_INODE + NFRONT ) ) MUST_COMPACT_FACTORS = .FALSE. ENDIF IF (COMPRESS_CB.AND.(LREQCB.EQ.0)) GOTO 190 IF ( KEEP(50).EQ.0 .AND. MUST_COMPACT_FACTORS ) & THEN LAST_ALLOWED_POS = POSELT + int(LDA,8)*int(NPIV+NBROW-1,8) & + int(NPIV,8) ELSE LAST_ALLOWED_POS = -1_8 ENDIF NCBROW_ALREADY_MOVED = 0 COUNT_EXTRA_IP_COPIES = 0_8 10 CONTINUE NCBROW_PREVIOUSLY_MOVED = NCBROW_ALREADY_MOVED IF (IPTRLU .LT. POSFAC ) THEN CALL DMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, PACKED_CB, & LAST_ALLOWED_POS, NCBROW_ALREADY_MOVED ) ELSE CALL DMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, PACKED_CB ) NCBROW_ALREADY_MOVED = NBROW_STACK ENDIF IF (LAST_ALLOWED_POS .NE. -1_8) THEN MUST_COMPACT_FACTORS =.FALSE. IF ( NCBROW_ALREADY_MOVED .EQ. NBROW_STACK ) THEN IF (COMPRESS_CB) THEN NCBROW_ALREADY_MOVED = NBROW ELSE NCBROW_ALREADY_MOVED = NCBROW_ALREADY_MOVED + NBROW_SEND ENDIF ENDIF NCBROW_NEWLY_MOVED = NCBROW_ALREADY_MOVED & - NCBROW_PREVIOUSLY_MOVED FACTOR_POS = POSELT + & int(LDA,8)*int(NPIV+NBROW-NCBROW_ALREADY_MOVED,8) CALL DMUMPS_COMPACT_FACTORS_UNSYM( A(FACTOR_POS), LDA, NPIV, & NCBROW_NEWLY_MOVED, KEEP, & int(NCBROW_NEWLY_MOVED,8) * int(LDA,8) ) INEW = FACTOR_POS + int(NPIV,8) * int(NCBROW_NEWLY_MOVED,8) IOLD = INEW + int(NCBROW_NEWLY_MOVED,8) * int(NBCOL_STACK,8) DO I8 = 0_8, int(NCBROW_PREVIOUSLY_MOVED,8)*int(NPIV,8)-1 A(INEW) = A(IOLD) IOLD = IOLD + 1_8 INEW = INEW + 1_8 ENDDO COUNT_EXTRA_IP_COPIES = COUNT_EXTRA_IP_COPIES + & int(NCBROW_PREVIOUSLY_MOVED,8) & * int(NPIV,8) LAST_ALLOWED_POS = INEW IF (NCBROW_ALREADY_MOVED.LT.NBROW_STACK) THEN GOTO 10 ENDIF ENDIF IF ( COUNT_EXTRA_IP_COPIES .GT. 0_8 ) THEN !$OMP ATOMIC UPDATE KEEP8(8) = KEEP8(8) + COUNT_EXTRA_IP_COPIES !$OMP END ATOMIC COUNT_EXTRA_IP_COPIES = 0_8 ENDIF 190 CONTINUE IF (MUST_COMPACT_FACTORS) THEN POSELT = PTRFAC(STEP(INODE)) IF (KEEP(50).NE.0) THEN CALL DMUMPS_COMPACT_FACTORS_SYM( A(POSELT), LDA, & NPIV, NBROW, KEEP, & int(LDA,8)*int(NBROW+NPIV,8), & IW( PTLUST_S(STEP(INODE)) + H_INODE + NFRONT ) ) ELSE CALL DMUMPS_COMPACT_FACTORS_UNSYM( & A(POSELT+int(NPIV,8)*int(LDA,8)), & LDA, NPIV, NBROW, KEEP, int(NBROW,8)*int(LDA,8) ) ENDIF MUST_COMPACT_FACTORS = .FALSE. ENDIF IOLDPS = PTLUST_S(STEP(INODE)) IW(IOLDPS+KEEP(IXSZ)) = NBCOL IW(IOLDPS + 1+KEEP(IXSZ)) = NASS - NPIV IF (TYPE.EQ.2) THEN IW(IOLDPS + 2+KEEP(IXSZ)) = NASS ELSE IW(IOLDPS + 2+KEEP(IXSZ)) = NFRONT ENDIF IW(IOLDPS + 3+KEEP(IXSZ)) = NPIV IF (INPLACE) THEN SIZE_INPLACE = LREQCB - MIN_SPACE_IN_PLACE ELSE SIZE_INPLACE = 0_8 ENDIF CALL DMUMPS_COMPRESS_LU(SIZE_INPLACE,MYID,N,IOLDPS,TYPE, IW, LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, SSARBR,INODE,IERR & , LRGROUPS, NASS & ) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 GOTO 600 ENDIF 500 CONTINUE RETURN 600 CONTINUE IF (IFLAG .NE. -1 .AND. KEEP(405) .EQ. 0) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE DMUMPS_FAC_STACK MUMPS_5.8.1/src/zfac_distrib_distentry.F0000664000175000017500000007461015042446441020120 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_BUILD_MAPPING & ( N, MAPPING, NNZ, IRN, JCN, PROCNODE, STEP, & SLAVEF, PERM, FILS, & RG2L, KEEP,KEEP8, MBLOCK, NBLOCK, NPROW, NPCOL ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, SLAVEF, MBLOCK, NBLOCK, NPROW, NPCOL iNTEGER(8) :: NNZ INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN( NNZ ), JCN( NNZ ) INTEGER MAPPING( NNZ ), STEP( N ) INTEGER PROCNODE( KEEP(28) ), PERM( N ), FILS( N ), RG2L( N ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE INTEGER K4, IOLD, JOLD, INEW, JNEW, ISEND, JSEND, IARR, INODE INTEGER(8) :: K8 INTEGER TYPE_NODE, DEST INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INODE = KEEP(38) K4 = 1 DO WHILE ( INODE .GT. 0 ) RG2L( INODE ) = K4 INODE = FILS( INODE ) K4 = K4 + 1 END DO DO K8 = 1_8, NNZ IOLD = IRN( K8 ) JOLD = JCN( K8 ) IF ( IOLD .GT. N .OR. IOLD .LT. 1 .OR. & JOLD .GT. N .OR. JOLD .LT. 1 ) THEN MAPPING( K8 ) = -1 CYCLE END IF IF ( IOLD .eq. JOLD ) THEN ISEND = IOLD JSEND = JOLD ELSE INEW = PERM( IOLD ) JNEW = PERM( JOLD ) IF ( INEW .LT. JNEW ) THEN ISEND = IOLD IF ( KEEP(50) .ne. 0 ) ISEND = -IOLD JSEND = JOLD ELSE ISEND = -JOLD JSEND = IOLD END IF END IF IARR = abs( ISEND ) TYPE_NODE = MUMPS_TYPENODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) + 1 ELSE DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) END IF ELSE IF ( ISEND .LT. 0 ) THEN IPOSROOT = RG2L( JSEND ) JPOSROOT = RG2L( IARR ) ELSE IPOSROOT = RG2L( IARR ) JPOSROOT = RG2L( JSEND ) END IF IROW_GRID = mod( ( IPOSROOT - 1 )/MBLOCK, NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/NBLOCK, NPCOL ) IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = IROW_GRID * NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * NPCOL + JCOL_GRID END IF END IF MAPPING( K8 ) = DEST END DO RETURN END SUBROUTINE ZMUMPS_BUILD_MAPPING SUBROUTINE ZMUMPS_REDISTRIBUTION( & N, NZ_loc8, id, & DBLARR, LDBLARR, INTARR, LINTARR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & FILS, KEEP,KEEP8, MYID, COMM, NBRECORDS, & & A, LA, root, roota, PROCNODE_STEPS, SLAVEF, PERM, STEP, & ICNTL, INFO, NSEND8, NLOCAL8, & ISTEP_TO_INIV2, CANDIDATES & ) !$ USE OMP_LIB USE ZMUMPS_STRUC_DEF, ONLY: ZMUMPS_STRUC USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N INTEGER(8) :: NZ_loc8 TYPE (ZMUMPS_STRUC) :: id INTEGER(8) :: LDBLARR, LINTARR COMPLEX(kind=8) DBLARR( LDBLARR ) INTEGER INTARR( LINTARR ) INTEGER KEEP(500) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER(8) KEEP8(150) INTEGER, INTENT(IN) :: FILS( N ) 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 (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER PROCNODE_STEPS(KEEP(28)), PERM( N ), STEP( N ) INTEGER INFO( 80 ), ICNTL(60) INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: IERR, MSGSOU INTEGER :: STATUS(MPI_STATUS_SIZE) COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: PTRAW INTEGER END_MSG_2_RECV INTEGER I, J INTEGER(8) :: IS8 INTEGER(8) :: K8 INTEGER :: IARR1, IORG INTEGER TYPE_NODE, DEST, DEST_SHR INTEGER IOLD, JOLD, IARR, ISEND, JSEND INTEGER ISEND_SHR, JSEND_SHR INTEGER allocok, TYPESPLIT, T4MASTER, INIV2, NCAND LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS COMPLEX(kind=8) VAL, VAL_SHR INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, ARROW_ROOT INTEGER IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT, & ILOCROOT, JLOCROOT INTEGER MP,LP INTEGER KPROBE, FREQPROBE INTEGER TAILLE INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFI COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:,:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: BUFRECR INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, IREQI, IREQR LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE LOGICAL :: FLAG INTEGER(8), INTENT(OUT) :: NSEND8, NLOCAL8 INTEGER MASTER_NODE, ISTEP LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P INTEGER NOMP, NOMP_P, IOMP, P2 NSEND8 = 0_8 NLOCAL8 = 0_8 LP = ICNTL(1) MP = ICNTL(2) END_MSG_2_RECV = SLAVEF ALLOCATE( IACT(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IACT in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQI(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQI in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQR(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQR in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( SEND_ACTIVE(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating SEND_ACTIVE in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = ( NBRECORDS * 2 + 1 ) * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFR( NBRECORDS, 2, SLAVEF), stat = allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating real buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFRECI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS * 2 + 1 GOTO 20 END IF ALLOCATE( BUFRECR( NBRECORDS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS GOTO 20 END IF ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8) * 2_8, INFO(2) ) GOTO 20 END IF ALLOCATE( PTRAW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8) * KEEP(10), INFO(2) ) GOTO 20 END IF 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 100 ARROW_ROOT = 0 DO J = 1, N ISTEP=STEP(J) IF (ISTEP .GT. 0) THEN IARR1 = PTRDEBARR( ISTEP ) IF ( IARR1 .GT. 0 ) THEN I = J IORG = 0 DO WHILE ( I .GT. 0 ) IORG = IORG + 1 IW4(I, 1) = NINCOLARR( IARR1 + IORG - 1 ) IW4(I, 2) = NINROWARR( IARR1 + IORG - 1 ) + & NINCOLARR( IARR1 + IORG - 1 ) IS8 = PTR8ARR( IARR1 + IORG - 1 ) PTRAW( I ) = IS8 INTARR( IS8 ) = I DBLARR( IS8 ) = ZERO I = FILS(I) ENDDO ENDIF ENDIF ENDDO EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL ZMUMPS_GET_ROOT_INFO(root,LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL ZMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF DO I = 1, SLAVEF BUFI( 1, 1, I ) = 0 END DO DO I = 1, SLAVEF BUFI( 1, 2, I ) = 0 END DO DO I = 1, SLAVEF SEND_ACTIVE( I ) = .FALSE. IACT( I ) = 1 END DO KPROBE = 0 FREQPROBE = max(1,NBRECORDS/10) IF (SLAVEF .EQ. 1) FREQPROBE = huge(FREQPROBE) NOMP = 1 !$ NOMP=omp_get_max_threads() OMP_FLAG = KEEP(399).EQ.1 .AND. NOMP .GE.2 .AND. SLAVEF.EQ.1 !$OMP PARALLEL PRIVATE( K8, I, DEST, TAILLE, !$OMP& T4MASTER, T4_MASTER_CONCERNED, !$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT, !$OMP& ILOCROOT, JLOCROOT, !$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE, !$OMP& IS8, VAL, !$OMP& IARR, ISTEP, ISEND, JSEND, !$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P ) !$OMP& REDUCTION(+:NSEND8, NLOCAL8, ARROW_ROOT) IF (OMP_FLAG) IOMP=0 !$ IOMP=omp_get_thread_num() NOMP_P=1 !$ NOMP_P=omp_get_num_threads() OMP_FLAG_P = .FALSE. !$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1 IF (OMP_FLAG_P) THEN IF ( NOMP_P .GE. 16 ) THEN NOMP_P=16 P2 = 4 ELSE IF (NOMP_P.GE.8) THEN NOMP_P=8 P2 = 3 ELSE IF (NOMP_P.GE.4) THEN NOMP_P=4 P2 = 2 ELSE IF (NOMP_P.GE.2) THEN NOMP_P=2 P2 = 1 ENDIF ELSE NOMP_P = 1 P2 = 0 ENDIF IF ( IOMP .LT. NOMP_P ) THEN DO K8 = 1_8, NZ_loc8 IF ( SLAVEF .GT. 1 ) THEN !$OMP MASTER KPROBE = KPROBE + 1 IF ( KPROBE .eq. FREQPROBE ) THEN KPROBE = 0 CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, & MPI_INTEGER, & MSGSOU, ARR_INT, COMM, STATUS, IERR ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, & MPI_DOUBLE_COMPLEX, & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) CALL ZMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, & root, roota, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF END IF !$OMP END MASTER ENDIF IOLD = id%IRN_loc(K8) JOLD = id%JCN_loc(K8) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE ENDIF IF (OMP_FLAG_P) THEN IF (IOLD.EQ.JOLD) THEN IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD ELSE IARR = JOLD ENDIF DOIT = ( IOMP .EQ. ibits(IARR, P2-1, P2)) ELSE DOIT = .TRUE. ENDIF IF (DOIT) THEN IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = IOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF ISTEP = abs(STEP(IARR)) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP), KEEP(199) ) T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 VAL = id%A_loc(K8) IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN VAL = VAL * id%ROWSCA(IOLD)*id%COLSCA(JOLD) ENDIF IF ( TYPE_NODE .eq. 1 ) THEN DEST = MASTER_NODE IF (DEST.EQ.MYID) THEN NLOCAL8 = NLOCAL8 + 1_8 IF (ISEND.EQ.JSEND) THEN IS8 = PTRAW(ISEND) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IF (ISEND.GE.0) THEN IS8 = PTRAW(IARR) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL ELSE IS8 = PTRAW(IARR) + IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL ZMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF ENDIF CYCLE ENDIF ELSE IF ( TYPE_NODE .eq. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE DEST = MASTER_NODE END IF INIV2 = ISTEP_TO_INIV2(ISTEP) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND < 0 ) THEN IPOSROOT = root%RG2L(JSEND) JPOSROOT = root%RG2L(IARR ) ELSE IPOSROOT = root%RG2L(IARR ) JPOSROOT = root%RG2L(JSEND) END IF IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL ) DEST = IROW_GRID * root%NPCOL + JCOL_GRID ELSE DEST = -2 ENDIF IF ( OMP_FLAG_P ) THEN IF ( EARLYT3ROOTINS ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE IF (ISEND.EQ.JSEND) THEN IS8 = PTRAW(ISEND) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IF (ISEND.GE.0) THEN IS8 = PTRAW(IARR)+IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL ELSE IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL ZMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF ENDIF ENDIF CYCLE ENDIF END IF IF (DEST .eq. -1) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .EQ. -2) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .eq.MYID ) THEN NLOCAL8 = NLOCAL8 + 1_8 ELSE NSEND8 = NSEND8 + 1_8 ENDIF ENDIF IF ( DEST.EQ.-1) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79) .GT. 0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) IF (DEST.LT.0) EXIT IF (I.EQ.NCAND+1) CYCLE DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL ZMUMPS_DIST_FILL_BUFFER() ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL ZMUMPS_DIST_FILL_BUFFER() ENDDO ENDIF DEST=MASTER_NODE DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL ZMUMPS_DIST_FILL_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL ZMUMPS_DIST_FILL_BUFFER() ENDIF ELSE IF (DEST .GE. 0) THEN DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL ZMUMPS_DIST_FILL_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL ZMUMPS_DIST_FILL_BUFFER() ENDIF ELSE IF (DEST .EQ. -2) THEN DO I = 0, SLAVEF-1 DEST=I DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL ZMUMPS_DIST_FILL_BUFFER() ENDDO ENDIF ENDIF END DO ENDIF !$OMP END PARALLEL DEST_SHR = -3 CALL ZMUMPS_DIST_FILL_BUFFER() DO WHILE ( END_MSG_2_RECV .NE. 0 ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, MPI_INTEGER, & MPI_ANY_SOURCE, ARR_INT, COMM, STATUS, IERR ) MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, MPI_DOUBLE_COMPLEX, & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) CALL ZMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END DO DO I = 1, SLAVEF IF ( SEND_ACTIVE( I ) ) THEN CALL MPI_WAIT( IREQI( I ), STATUS, IERR ) CALL MPI_WAIT( IREQR( I ), STATUS, IERR ) END IF END DO KEEP(49) = ARROW_ROOT 100 CONTINUE IF (ALLOCATED(IW4)) DEALLOCATE( IW4 ) IF (ALLOCATED(PTRAW)) DEALLOCATE( PTRAW ) IF (ALLOCATED(BUFI)) DEALLOCATE( BUFI ) IF (ALLOCATED(BUFR)) DEALLOCATE( BUFR ) IF (ALLOCATED(BUFRECI)) DEALLOCATE( BUFRECI ) IF (ALLOCATED(BUFRECR)) DEALLOCATE( BUFRECR ) IF (ALLOCATED(IACT)) DEALLOCATE( IACT ) IF (ALLOCATED(IREQI)) DEALLOCATE( IREQI ) IF (ALLOCATED(IREQR)) DEALLOCATE( IREQR ) IF (ALLOCATED(SEND_ACTIVE)) DEALLOCATE( SEND_ACTIVE ) RETURN CONTAINS SUBROUTINE ZMUMPS_DIST_FILL_BUFFER() IMPLICIT NONE INTEGER ISLAVE, IBEG, IEND, NBREC, IREQ INTEGER TAILLE_SEND_I, TAILLE_SEND_R LOGICAL SEND_LOCAL IF ( DEST_SHR .eq. -3 ) THEN IBEG = 1 IEND = SLAVEF ELSE IBEG = DEST_SHR + 1 IEND = DEST_SHR + 1 END IF SEND_LOCAL = .FALSE. DO ISLAVE = IBEG, IEND NBREC = BUFI(1,IACT(ISLAVE),ISLAVE) IF ( DEST_SHR .eq. -3 ) THEN BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC END IF IF ( DEST_SHR .eq. -3 .or. NBREC + 1 > NBRECORDS ) THEN DO WHILE ( SEND_ACTIVE( ISLAVE ) ) CALL MPI_TEST( IREQR( ISLAVE ), FLAG, STATUS, IERR ) IF ( .NOT. FLAG ) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS(MPI_SOURCE) CALL MPI_RECV( BUFRECI(1), 2*NBRECORDS+1, & MPI_INTEGER, MSGSOU, ARR_INT, COMM, & STATUS, IERR ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, & MPI_DOUBLE_COMPLEX, MSGSOU, & ARR_REAL, COMM, STATUS, IERR ) CALL ZMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & 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_SHR .ne. -3 ) THEN IREQ = BUFI(1,IACT(ISLAVE),ISLAVE) + 1 BUFI(1,IACT(ISLAVE),ISLAVE) = IREQ BUFI(IREQ*2,IACT(ISLAVE),ISLAVE) = ISEND_SHR BUFI(IREQ*2+1,IACT(ISLAVE),ISLAVE) = JSEND_SHR BUFR(IREQ,IACT(ISLAVE),ISLAVE ) = VAL_SHR END IF END DO IF ( SEND_LOCAL ) THEN ISLAVE = MYID + 1 CALL ZMUMPS_DIST_TREAT_RECV_BUF( & BUFI(1,3-IACT(ISLAVE),ISLAVE), & BUFR(1,3-IACT(ISLAVE),ISLAVE), & NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF RETURN END SUBROUTINE ZMUMPS_DIST_FILL_BUFFER END SUBROUTINE ZMUMPS_REDISTRIBUTION SUBROUTINE ZMUMPS_DIST_TREAT_RECV_BUF & ( BUFI, BUFR, NBRECORDS, N, IW4, & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, roota, & PTR_ROOT, A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER NBRECORDS, N, MYID, SLAVEF INTEGER BUFI( NBRECORDS * 2 + 1 ) COMPLEX(kind=8) BUFR( NBRECORDS ) INTEGER IW4( N, 2 ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER END_MSG_2_RECV INTEGER(8), INTENT(IN) :: PTRAW( N ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER :: PERM( N ), STEP( N ) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER INTARR( LINTARR ) INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT, LA COMPLEX(kind=8) A( LA ), DBLARR( LDBLARR ) INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER IREC, NB_REC, NODE_TYPE, IPROC INTEGER IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER(8) :: IS8 INTEGER IARR, JARR INTEGER TAILLE LOGICAL :: EARLYT3ROOTINS COMPLEX(kind=8) VAL EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) NB_REC = BUFI( 1 ) IF ( NB_REC .LE. 0 ) THEN END_MSG_2_RECV = END_MSG_2_RECV - 1 NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) GOTO 100 DO IREC = 1, NB_REC IARR = BUFI( IREC * 2 ) JARR = BUFI( IREC * 2 + 1 ) VAL = BUFR( IREC ) NODE_TYPE = MUMPS_TYPENODE( & PROCNODE_STEPS(abs(STEP(abs( IARR )))), & KEEP(199) ) IF ( NODE_TYPE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JARR ) ELSE IPOSROOT = root%RG2L( JARR ) JPOSROOT = root%RG2L( -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 roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%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 IS8 = PTRAW(IARR) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IS8 = PTRAW(IARR)+IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)), & KEEP(199) ) IF ( IPROC .EQ. MYID ) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL ZMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) ENDIF END IF ENDIF ENDDO 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_DIST_TREAT_RECV_BUF MUMPS_5.8.1/src/send_driver.F0000664000175000017500000006131015042446441015645 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_END_DRIVER( id, idintr ) USE SMUMPS_STRUC_DEF, ONLY: SMUMPS_STRUC USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_INTR_STRUC IMPLICIT NONE C C Purpose: C ======= C C Terminate a MUMPS instance. Free all internal data structure and C suppress OOC files on disk, if any. C C Argument: C ======== C TYPE( SMUMPS_STRUC ) :: id TYPE( SMUMPS_INTR_STRUC ) :: idintr C C Local declarations C ================== INTEGER IERR INTEGER, PARAMETER :: MASTER = 0 C C Executable statements C ===================== C C First, free all MUMPS internal data except communicators created C during a call to MUMPS wit JOB=-1 CALL SMUMPS_FREE_DATA_ANAFACSOL( id, idintr ) C C Allocated during JOB=-1: IF ( id%MYID .NE. MASTER .OR. id%KEEP(46) .ne. 0 ) THEN C Note that on some very old platforms, COMM_NODES would have been C freed inside BLACS_GRIDEXIT, which may cause problems C in the call to MPI_COMM_FREE. CALL MPI_COMM_FREE( id%COMM_NODES, IERR ) C Free communicator related to load messages. CALL MPI_COMM_FREE( id%COMM_LOAD, IERR ) END IF CALL MUMPS_DESTROY_ARCH_NODE_COMM( id%KEEP(411), id%KEEP(410), & id%KEEP(413) ) C Nullifying id%SCHUR_CINTERFACE here is not necessary, C it is freed systematically each time we exit SMUMPS_DRIVER C and reset each time we enter MUMPS through its C interface. NULLIFY(id%SCHUR_CINTERFACE) C RETURN END SUBROUTINE SMUMPS_END_DRIVER C SUBROUTINE SMUMPS_END_ROOT(roota) USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE(SMUMPS_ROOT_STRUC) :: roota IF (associated(roota%RHS_CNTR_MASTER_ROOT)) THEN DEALLOCATE(roota%RHS_CNTR_MASTER_ROOT) NULLIFY(roota%RHS_CNTR_MASTER_ROOT) ENDIF IF (associated(roota%RHS_ROOT))THEN DEALLOCATE(roota%RHS_ROOT) NULLIFY(roota%RHS_ROOT) ENDIF CALL SMUMPS_RR_FREE_POINTERS(roota) RETURN END SUBROUTINE SMUMPS_END_ROOT C SUBROUTINE SMUMPS_FREE_DATA_ANAFACSOL(id, idintr) USE SMUMPS_STRUC_DEF USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_INTR_STRUC IMPLICIT NONE C C Purpose: C ======= C Free all MUMPS internal data, except communicators built during C a JOB=-1 call. Called by SMUMPS_END_DRIVER and SMUMPS_ANA_DRIVER. C Calls SMUMPS_FREE_DATA_FACTO, which frees most of the data allocated C during factorization and solve, except: C - scaling arrays, because they are sometimes allocated at analysis C - STEP2NODE, which can be reused when analysis does not change C Therefore, scaling arrays and STEP2NODE are freed here. C C Arguments C ========= TYPE( SMUMPS_STRUC ) :: id TYPE( SMUMPS_INTR_STRUC ) :: idintr C Local declarations C ================== LOGICAL I_AM_SLAVE INTEGER, PARAMETER :: MASTER = 0 C C Executable statements C --------------------- C I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) C C First, free data from factoriation and solve: CALL SMUMPS_FREE_DATA_FACTO(id,idintr) C ------------------------------------- C Right-hand-side and solutions are C always user data, we do not free them C ------------------------------------- IF (associated(id%MEM_DIST)) THEN DEALLOCATE(id%MEM_DIST) NULLIFY(id%MEM_DIST) ENDIF C --------------------------------- C Allocated by SMUMPS, Used by user. C SMUMPS deallocates. User should C use them before SMUMPS_END_DRIVER or C copy. C --------------------------------- IF (associated(id%MAPPING)) THEN DEALLOCATE(id%MAPPING) NULLIFY(id%MAPPING) END IF C ------------------------------------- C Always deallocate scaling arrays C if they are associated, except C when provided by the user (on master) C ------------------------------------- IF ( id%KEEP(52) .NE. -1 .or. id%MYID .ne. MASTER ) THEN IF (associated(id%COLSCA)) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ENDIF IF (associated(id%ROWSCA)) THEN DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF END IF C Begin PRUN_NODES C Info for pruning tree IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF C END PRUN_NODES c --------------------- C Allocated during analysis: IF (associated(id%NE_STEPS)) THEN DEALLOCATE(id%NE_STEPS) NULLIFY(id%NE_STEPS) ENDIF C Allocated during analysis: IF (associated(id%ND_STEPS)) THEN DEALLOCATE(id%ND_STEPS) NULLIFY(id%ND_STEPS) ENDIF C Allocated during analysis: IF (associated(id%FRERE_STEPS)) THEN DEALLOCATE(id%FRERE_STEPS) NULLIFY(id%FRERE_STEPS) ENDIF C Allocated during analysis: IF (associated(id%DAD_STEPS)) THEN DEALLOCATE(id%DAD_STEPS) NULLIFY(id%DAD_STEPS) ENDIF C Allocated during analysis: IF (associated(id%SYM_PERM)) THEN DEALLOCATE(id%SYM_PERM) NULLIFY(id%SYM_PERM) ENDIF IF (associated(id%STEP)) THEN DEALLOCATE(id%STEP) NULLIFY(id%STEP) ENDIF IF (associated(id%LRGROUPS)) THEN DEALLOCATE(id%LRGROUPS) NULLIFY(id%LRGROUPS) ENDIF IF (associated(id%FILS)) THEN DEALLOCATE(id%FILS) NULLIFY(id%FILS) ENDIF IF (associated(id%UNS_PERM)) THEN DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF CC Allocated during analysis: IF (associated(id%FRTPTR)) THEN DEALLOCATE(id%FRTPTR) NULLIFY(id%FRTPTR) ENDIF C Allocated during analysis: IF (associated(id%FRTELT)) THEN DEALLOCATE(id%FRTELT) NULLIFY(id%FRTELT) ENDIF C Allocated during analysis: IF (associated(id%NA)) THEN DEALLOCATE(id%NA) NULLIFY(id%NA) ENDIF C Allocated during analysis: IF (associated(id%PROCNODE_STEPS)) THEN DEALLOCATE(id%PROCNODE_STEPS) NULLIFY(id%PROCNODE_STEPS) ENDIF IF (associated(id%ELTPROC)) THEN DEALLOCATE(id%ELTPROC) NULLIFY(id%ELTPROC) ENDIF C Allocated at analysis: IF (associated(id%CANDIDATES)) THEN DEALLOCATE(id%CANDIDATES) NULLIFY(id%CANDIDATES) ENDIF C Allocated at analysis: IF (associated(id%I_AM_CAND)) THEN DEALLOCATE(id%I_AM_CAND) NULLIFY(id%I_AM_CAND) ENDIF C Allocated at analysis: IF (associated(id%ISTEP_TO_INIV2)) THEN DEALLOCATE(id%ISTEP_TO_INIV2) NULLIFY(id%ISTEP_TO_INIV2) ENDIF C Node partitionning (only allocated on slaves) IF (I_AM_SLAVE) THEN C Allocated at analysis: IF (associated(id%TAB_POS_IN_PERE)) THEN DEALLOCATE(id%TAB_POS_IN_PERE) NULLIFY(id%TAB_POS_IN_PERE) ENDIF ENDIF IF (I_AM_SLAVE) THEN C Allocated at analysis: IF (associated(id%FUTURE_NIV2)) THEN DEALLOCATE(id%FUTURE_NIV2) NULLIFY(id%FUTURE_NIV2) ENDIF ENDIF C Allocated at analysis: IF(associated(id%DEPTH_FIRST))THEN DEALLOCATE(id%DEPTH_FIRST) NULLIFY(id%DEPTH_FIRST) ENDIF C Allocated at analysis: IF(associated(id%DEPTH_FIRST_SEQ))THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) NULLIFY(id%DEPTH_FIRST_SEQ) ENDIF C Allocated at analysis: IF(associated(id%SBTR_ID))THEN DEALLOCATE(id%SBTR_ID) NULLIFY(id%SBTR_ID) ENDIF C Allocated and initialized at analysis: IF(associated(id%SCHED_DEP))THEN DEALLOCATE(id%SCHED_DEP) NULLIFY(id%SCHED_DEP) ENDIF C Allocated and initialized at analysis: IF(associated(id%SCHED_SBTR))THEN DEALLOCATE(id%SCHED_SBTR) NULLIFY(id%SCHED_SBTR) ENDIF C Allocated and initialized at analysis: IF(associated(id%SCHED_GRP))THEN DEALLOCATE(id%SCHED_GRP) NULLIFY(id%SCHED_GRP) ENDIF C Allocated and initialized at analysis: IF(associated(id%CROIX_MANU))THEN DEALLOCATE(id%CROIX_MANU) NULLIFY(id%CROIX_MANU) ENDIF C Allocated during analysis: IF (associated(id%PTRAR)) THEN DEALLOCATE(id%PTRAR) NULLIFY(id%PTRAR) ENDIF C Allocated at analysis: IF (associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) NULLIFY(id%MEM_SUBTREE) ENDIF C Allocated at analysis: IF (associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) NULLIFY(id%MY_ROOT_SBTR) ENDIF C Allocated at analysis: IF (associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) NULLIFY(id%MY_FIRST_LEAF) ENDIF C Allocated at analysis: IF (associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) NULLIFY(id%MY_NB_LEAF) ENDIF C Allocated at analysis: IF (associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) NULLIFY(id%COST_TRAV) ENDIF C Allocated at analysis: IF (associated(id%CB_SON_SIZE)) THEN DEALLOCATE(id%CB_SON_SIZE) NULLIFY(id%CB_SON_SIZE) ENDIF C Allocated at analysis: IF (associated(id%SUP_PROC)) THEN DEALLOCATE(id%SUP_PROC) NULLIFY(id%SUP_PROC) ENDIF ! IF(id%KEEP(486).NE.0) THEN C Allocated at analysis: IF (associated(id%LRGROUPS)) THEN DEALLOCATE(id%LRGROUPS) NULLIFY(id%LRGROUPS) ENDIF ! ENDIF C C free data concerned when redoing cheap analysis CALL SMUMPS_FREE_DATA_REDO_ANA( id ) C C gridinit performed at analysis: #if ! defined(NOSCALAPACK) IF (idintr%root%gridinit_done) THEN IF ( id%KEEP(38).NE.0 .and. idintr%root%yes ) THEN CALL blacs_gridexit( idintr%root%CNTXT_BLACS ) idintr%root%gridinit_done = .FALSE. END IF END IF #endif RETURN END SUBROUTINE SMUMPS_FREE_DATA_ANAFACSOL SUBROUTINE SMUMPS_FREE_DATA_REDO_ANA ( id ) USE SMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C Free all MUMPS internal data concerned C when redoing a cheap analysis : C - data related to MPI2KOMP allocated during analysis C - data related to L0OMP allocated during analysis C - data related to building arrowheads because C of EARLYT3ROOTINS that might change when of C L0-thread (KEEP(400) C Arguments C ========= TYPE( SMUMPS_STRUC ) :: id C C Executable statements C --------------------- CCN#if defined(MPI_TO_K_OMP) C Allocated at analysis: IF (associated(id%MTKO_PROCS_MAP)) THEN DEALLOCATE(id%MTKO_PROCS_MAP) NULLIFY(id%MTKO_PROCS_MAP) ENDIF C Allocated at analysis: IF (associated(id%IPOOL_B_L0_OMP)) THEN DEALLOCATE(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_B_L0_OMP) END IF IF (associated(id%IPOOL_A_L0_OMP)) THEN DEALLOCATE(id%IPOOL_A_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) END IF IF (associated(id%PHYS_L0_OMP)) THEN DEALLOCATE(id%PHYS_L0_OMP) NULLIFY(id%PHYS_L0_OMP) END IF IF (associated(id%VIRT_L0_OMP)) THEN DEALLOCATE(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP) END IF IF (associated(id%VIRT_L0_OMP_MAPPING)) THEN DEALLOCATE(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%VIRT_L0_OMP_MAPPING) END IF IF (associated(id%PERM_L0_OMP)) THEN DEALLOCATE(id%PERM_L0_OMP) NULLIFY(id%PERM_L0_OMP) END IF IF (associated(id%PTR_LEAFS_L0_OMP)) THEN DEALLOCATE(id%PTR_LEAFS_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) END IF C Allocated at analysis: IF (associated(id%I4_L0_OMP)) THEN DEALLOCATE(id%I4_L0_OMP) NULLIFY(id%I4_L0_OMP) END IF C Allocated at analysis: IF (associated(id%I8_L0_OMP)) THEN DEALLOCATE(id%I8_L0_OMP) NULLIFY(id%I8_L0_OMP) END IF C ================================================= C BEGIN Pointers to original matrix C allocated during analysis C in format ready for assembly during factorization C (arrowheads if assembled format) C Allocated during analysis: C id%PTRAR is allocated in ana_driver and C should not be deallocated here (it does not C change in sze) IF (associated(id%PTR8ARR)) THEN DEALLOCATE(id%PTR8ARR) NULLIFY(id%PTR8ARR) ENDIF C Allocated during analysis: IF (associated(id%NINCOLARR)) THEN DEALLOCATE(id%NINCOLARR) NULLIFY(id%NINCOLARR) ENDIF C Allocated during analysis: IF (associated(id%NINROWARR)) THEN DEALLOCATE(id%NINROWARR) NULLIFY(id%NINROWARR) ENDIF C Allocated during analysis: IF (associated(id%PTRDEBARR)) THEN DEALLOCATE(id%PTRDEBARR) NULLIFY(id%PTRDEBARR) ENDIF C ================================================= RETURN END SUBROUTINE SMUMPS_FREE_DATA_REDO_ANA SUBROUTINE SMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8, K34) USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_END USE SMUMPS_LR_DATA_M, only : SMUMPS_BLR_STRUC_TO_MOD, & SMUMPS_BLR_END_MODULE IMPLICIT NONE C C Purpose: C ======= C C Free data from modules kept from one phase to the other C and referenced through the main MUMPS structure, id. C C Both id%FDM_F_ENCODING and id%BLRARRAY_ENCODING C are concerned. C C C C Arguments: C ========= C # if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) INTEGER, intent(in) :: K34 C IF (associated(id_FDM_F_ENCODING)) THEN C Allow access to FDM_F data for BLR_END_MODULE CALL MUMPS_FDM_STRUC_TO_MOD('F', id_FDM_F_ENCODING) IF (associated(id_BLRARRAY_ENCODING)) THEN C Pass id_BLRARRAY_ENCODING control to module C and terminate BLR module of current instance CALL SMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) CALL SMUMPS_BLR_END_MODULE(0, KEEP8, K34, & LRSOLVE_ACT_OPT=.TRUE.) ENDIF C --------------------------------------- C FDM data structures are still allocated C in the module and should be freed C --------------------------------------- CALL MUMPS_FDM_END('F') ENDIF RETURN END SUBROUTINE SMUMPS_FREE_ID_DATA_MODULES C C ----------------------------------------------------------------- C SUBROUTINE SMUMPS_FREE_DATA_FACTO(id,idintr) C C Purpose: C ------- C C SMUMPS_FREE_DATA_FACTO frees data that was allocated during C factorization and that can be useful for the solve. Afterwards, C data from analysis is kept so that a new factorization phase C is possible. C C Module depencies C ---------------- USE SMUMPS_STRUC_DEF, ONLY: SMUMPS_STRUC USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_INTR_STRUC USE SMUMPS_FACSOL_L0OMP_M, ONLY : SMUMPS_FREE_L0_OMP_FACTORS USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_FREE_S_WK USE MUMPS_BUF_COMMON, ONLY : & MUMPS_BUF_DEALL_CB, & MUMPS_BUF_DEALL_SMALL_BUF IMPLICIT NONE C C Argument: C -------- C C id is the main MUMPS structure, giving with idintr access C to all internal objects allocated by the package. C TYPE( SMUMPS_STRUC) :: id TYPE( SMUMPS_INTR_STRUC ) :: idintr C C Local declarations C ------------------ INTEGER :: IERR LOGICAL :: I_AM_SLAVE INTEGER, PARAMETER :: MASTER = 0 C C Interface blocks C ---------------- INTERFACE C (explicit needed because of pointer arguments) SUBROUTINE SMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8, K34) # if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) INTEGER, intent(in) :: K34 END SUBROUTINE SMUMPS_FREE_ID_DATA_MODULES END INTERFACE C I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) C C Free OOC-related data C --------------------- C (this includes suppression of OOC files) IF (id%KEEP(201).GT.0 .AND. I_AM_SLAVE) THEN CALL SMUMPS_CLEAN_OOC_DATA(id,IERR) IF (IERR < 0) THEN id%INFO(1) = -90 id%INFO(2) = 0 ENDIF END IF CALL MUMPS_PROPINFO(id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID) IF (associated(id%PTLUST_S)) THEN DEALLOCATE(id%PTLUST_S) NULLIFY(id%PTLUST_S) END IF IF (associated(id%PTRFAC)) THEN DEALLOCATE(id%PTRFAC) NULLIFY(id%PTRFAC) END IF IF (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) ENDIF IF (associated(id%PIVNUL_LIST)) THEN DEALLOCATE(id%PIVNUL_LIST) NULLIFY(id%PIVNUL_LIST) ENDIF IF (associated(id%ROWSCA_loc)) THEN DEALLOCATE(id%ROWSCA_loc) NULLIFY(id%ROWSCA_loc) ENDIF IF (id%KEEP(50) .EQ. 0) THEN IF (associated(id%COLSCA_loc)) THEN DEALLOCATE(id%COLSCA_loc) ENDIF ENDIF NULLIFY(id%COLSCA_loc) C IPIV is used both for ScaLAPACK and RR C Keep it outside SMUMPS_RR_FREE_POINTERS IF (associated(idintr%root%IPIV)) THEN DEALLOCATE(idintr%root%IPIV) NULLIFY(idintr%root%IPIV) ENDIF CALL SMUMPS_END_ROOT(idintr%roota) IF (associated(id%SINGULAR_VALUES)) THEN DEALLOCATE(id%SINGULAR_VALUES) NULLIFY(id%SINGULAR_VALUES) ENDIF C Free module data from factorization: CALL SMUMPS_FREE_ID_DATA_MODULES(id%FDM_F_ENCODING, ! done & id%BLRARRAY_ENCODING, id%KEEP8(1), id%KEEP(34)) C --------------------------- C Deallocate main workarray S C --------------------------- IF (id%KEEP8(24).EQ.0_8) THEN C -- deallocate only when not provided/allocated by the user IF (associated(id%S)) THEN CALL SMUMPS_DM_FREE_S_WK(id%S, id%KEEP(430)) ENDIF C Reset KEEP(430)=0 since S is free C KEEP(430) will be redefined during facto id%KEEP(430) = 0 C Update allocated size of S: id%KEEP8(23)=0_8 ENDIF NULLIFY(id%S) IF (I_AM_SLAVE) THEN C ------------------------ C Deallocate buffer for C contrib-blocks (facto/ C solve). Note that this C will cancel all possible C pending requests. C ------------------------ CALL MUMPS_BUF_DEALL_CB( IERR ) C Deallocate buffer for integers (facto/solve) CALL MUMPS_BUF_DEALL_SMALL_BUF( IERR ) END IF C IF (associated(id%L0_OMP_MAPPING)) THEN DEALLOCATE(id%L0_OMP_MAPPING) NULLIFY(id%L0_OMP_MAPPING) END IF IF (associated(idintr%L0_OMP_FACTORS)) THEN CALL SMUMPS_FREE_L0_OMP_FACTORS(idintr%L0_OMP_FACTORS) END IF C C Data allocated during solve C --------------------------- C C (or for some of it, factorization -- forward during factorization) IF (associated(id%RHSINTR)) THEN DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25)=0_8 ENDIF IF (associated(id%GLOB2LOC_RHS)) THEN DEALLOCATE(id%GLOB2LOC_RHS) NULLIFY(id%GLOB2LOC_RHS) ENDIF IF (id%GLOB2LOC_SOL_ALLOC) THEN DEALLOCATE(id%GLOB2LOC_SOL) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF C Allocated during solve: C (even in case of fwd in facto) IF (associated(id%IPTR_WORKING)) THEN DEALLOCATE(id%IPTR_WORKING) NULLIFY(id%IPTR_WORKING) END IF IF (associated(id%WORKING)) THEN DEALLOCATE(id%WORKING) NULLIFY(id%WORKING) END IF RETURN END SUBROUTINE SMUMPS_FREE_DATA_FACTO SUBROUTINE SMUMPS_FREE_DATA_RHSINTR(id) C C Purpose: C ------- C Free RHSINTR related data that might C have been generated after a forward only step (ICNTL(26)=1) C Module depencies C ---------------- USE SMUMPS_STRUC_DEF IMPLICIT NONE C C Argument: C -------- C C id is the main MUMPS structure, giving with idintr access C to all internal objects allocated by the package. C TYPE( SMUMPS_STRUC) :: id C IF (associated(id%RHSINTR)) THEN DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25)=0_8 id%LD_RHSINTR = 0 ENDIF IF (associated(id%GLOB2LOC_RHS)) THEN DEALLOCATE(id%GLOB2LOC_RHS) NULLIFY(id%GLOB2LOC_RHS) ENDIF IF (id%GLOB2LOC_SOL_ALLOC) THEN DEALLOCATE(id%GLOB2LOC_SOL) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF RETURN END SUBROUTINE SMUMPS_FREE_DATA_RHSINTR SUBROUTINE SMUMPS_CLEAN_OOC_DATA(id,IERR) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_STRUC IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id INTEGER IERR IERR=0 CALL SMUMPS_OOC_CLEAN_FILES(id,IERR) IF(associated(id%OOC_TOTAL_NB_NODES))THEN DEALLOCATE(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_TOTAL_NB_NODES) ENDIF IF(associated(id%OOC_INODE_SEQUENCE))THEN DEALLOCATE(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_INODE_SEQUENCE) ENDIF IF(associated(id%OOC_SIZE_OF_BLOCK))THEN DEALLOCATE(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_SIZE_OF_BLOCK) ENDIF IF(associated(id%OOC_VADDR))THEN DEALLOCATE(id%OOC_VADDR) NULLIFY(id%OOC_VADDR) ENDIF RETURN END SUBROUTINE SMUMPS_CLEAN_OOC_DATA SUBROUTINE SMUMPS_OOC_CLEAN_FILES(id,IERR) USE SMUMPS_STRUC_DEF USE MUMPS_OOC_COMMON, ONLY : ERR_STR_OOC, & DIM_ERR_STR_OOC, & FILENAMELENGTH IMPLICIT NONE EXTERNAL MUMPS_OOC_REMOVE_FILE_C TYPE(SMUMPS_STRUC) :: id INTEGER IERR INTEGER I,J,I1,K CHARACTER(len=1):: TMP_NAME(FILENAMELENGTH) C Note that Fortran initializes IERR to 0. C The C layer modifies it in case of error. IERR=0 K=1 C WHEN SAVE/RESTORE IS ON, OOC FILES ASSOCIATED TO A SAVED INSTANCE C ARE NOT REMOVED IF(.NOT. id%ASSOCIATED_OOC_FILES) THEN IF(associated(id%OOC_FILE_NAMES).AND. & associated(id%OOC_FILE_NAME_LENGTH))THEN DO I1=1,id%OOC_NB_FILE_TYPE DO I=1,id%OOC_NB_FILES(I1) DO J=1,id%OOC_FILE_NAME_LENGTH(K) TMP_NAME(J)=id%OOC_FILE_NAMES(K,J) ENDDO C Note that termination character '0' is included CALL MUMPS_OOC_REMOVE_FILE_C(IERR, TMP_NAME(1)) IF(IERR.LT.0)THEN IF (id%ICNTL(1).GT.0 .AND. id%ICNTL(4).GE.1)THEN WRITE(id%ICNTL(1),*) id%MYID,': ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF ENDIF K=K+1 ENDDO ENDDO ENDIF ENDIF IF(associated(id%OOC_FILE_NAMES))THEN DEALLOCATE(id%OOC_FILE_NAMES) NULLIFY(id%OOC_FILE_NAMES) ENDIF IF(associated(id%OOC_FILE_NAME_LENGTH))THEN DEALLOCATE(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAME_LENGTH) ENDIF IF(associated(id%OOC_NB_FILES))THEN DEALLOCATE(id%OOC_NB_FILES) NULLIFY(id%OOC_NB_FILES) ENDIF RETURN END SUBROUTINE SMUMPS_OOC_CLEAN_FILES MUMPS_5.8.1/src/csol_matvec.F0000664000175000017500000002377515042446441015655 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_MV_ELT( N, NELT, ELTPTR, ELTVAR, A_ELT, & X, Y, K50, MTYPE ) IMPLICIT NONE C C Purpose C ======= C C To perform the matrix vector product C A_ELT X = Y if MTYPE = 1 C A_ELT^T X = Y if MTYPE = 0 C C If K50 is different from 0, then the elements are C supposed to be in symmetric packed storage; the C lower part is stored by columns. C Otherwise, the element is square, stored by columns. C C Note C ==== C C A_ELT is processed entry by entry and this code is not C optimized. In particular, one could gather/scatter C X / Y for each element to improve performance. C C Arguments C ========= C INTEGER N, NELT, K50, MTYPE INTEGER ELTPTR( NELT + 1 ), ELTVAR( * ) COMPLEX A_ELT( * ), X( N ), Y( N ) C C Local variables C =============== C INTEGER IEL, I , J, SIZEI, IELPTR INTEGER(8) :: K8 COMPLEX TEMP COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) C C C Executable statements C ===================== C Y = ZERO K8 = 1_8 C -------------------- C Process the elements C -------------------- DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( K50 .eq. 0 ) THEN C ------------------- C Unsymmetric element C stored by columns C ------------------- IF ( MTYPE .eq. 1 ) THEN C ----------------- C Compute A_ELT x X C ----------------- DO J = 1, SIZEI TEMP = X( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) + & A_ELT( K8 ) * TEMP K8 = K8 + 1 END DO END DO ELSE C ------------------- C Compute A_ELT^T x X C ------------------- DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + & A_ELT( K8 ) * X( ELTVAR( IELPTR + I ) ) K8 = K8 + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP END DO END IF ELSE C ----------------- C Symmetric element C L stored by cols C ----------------- DO J = 1, SIZEI C Diagonal counted once Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + J ) ) K8 = K8 + 1 DO I = J+1, SIZEI C Off diagonal + transpose Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + J ) ) Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + I ) ) K8 = K8 + 1 END DO END DO END IF END DO RETURN END SUBROUTINE CMUMPS_MV_ELT SUBROUTINE CMUMPS_LOC_MV8 &( N, NZ_loc8, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE C C Purpose: C ======= C C Perform a distributed matrix vector product. C Y_loc <- A X if MTYPE = 1 C Y_loc <- A^T X if MTYPE = 0 C C Notes: C ===== C C 1) assembly of all Y_loc still has to be done on exit. C 2) X should be available on all processors. C C Arguments: C ========= C INTEGER N INTEGER(8) :: NZ_loc8 INTEGER IRN_loc( NZ_loc8 ), JCN_loc( NZ_loc8 ) COMPLEX A_loc( NZ_loc8 ), X( N ), Y_loc( N ) INTEGER LDLT, MTYPE C C Locals variables: C ================ C INTEGER I, J INTEGER(8) :: K8 COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) Y_loc = ZERO IF ( LDLT .eq. 0 ) THEN C Unsymmetric IF ( MTYPE .eq. 1 ) THEN C No transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + A_loc(K8) * X(J) ENDDO ELSE C Transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) & .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(J) = Y_loc(J) + A_loc(K8) * X(I) ENDDO END IF ELSE C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + A_loc(K8) * X(J) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + A_loc(K8) * X(I) ENDIF ENDDO END IF RETURN END SUBROUTINE CMUMPS_LOC_MV8 SUBROUTINE CMUMPS_MV8( N, NZ8, IRN, ICN, ASPK, X, Y, & LDLT, MTYPE, MAXTRANS, PERM, & IFLAG, IERROR ) C C Purpose: C ======= C C Perform matrix-vector product C Y <- A X if MTYPE = 1 C Y <- A^T X if MTYPE = 0 C C C Note: C ==== C C MAXTRANS should be set to 1 if a column permutation C was applied on A and we still want the matrix vector C product wrt the original matrix. C C Arguments: C ========= C INTEGER N, LDLT, MTYPE, MAXTRANS INTEGER(8) :: NZ8 INTEGER IRN( NZ8 ), ICN( NZ8 ) INTEGER PERM( N ) COMPLEX ASPK( NZ8 ), X( N ), Y( N ) INTEGER, intent(inout) :: IFLAG, IERROR C C Local variables C =============== C INTEGER I, J INTEGER(8) :: K8 COMPLEX, DIMENSION(:), ALLOCATABLE :: PX COMPLEX ZERO INTEGER :: allocok PARAMETER( ZERO = (0.0E0,0.0E0) ) Y = ZERO ALLOCATE(PX(N), stat=allocok) IF (allocok < 0) THEN IFLAG = -13 IERROR = N RETURN ENDIF C C -------------------------------------- C Permute X if A has been permuted C with some max-trans column permutation C -------------------------------------- IF ( MAXTRANS .eq. 1 .and. MTYPE .eq. 1) THEN DO I = 1, N PX(I) = X( PERM( I ) ) END DO ELSE PX = X END IF IF ( LDLT .eq. 0 ) THEN C C Complete unsymmetric matrix was provided (LU facto) IF (MTYPE .EQ. 1) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K8) * PX(J) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(J) = Y(J) + ASPK(K8) * PX(I) ENDDO ENDIF C ELSE C C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K8) * PX(J) IF (J.NE.I) THEN Y(J) = Y(J) + ASPK(K8) * PX(I) ENDIF ENDDO END IF IF ( MAXTRANS .EQ. 1 .AND. MTYPE .eq. 0 ) THEN PX = Y DO I = 1, N Y( PERM( I ) ) = PX( I ) END DO END IF DEALLOCATE(PX) RETURN END SUBROUTINE CMUMPS_MV8 C C SUBROUTINE CMUMPS_LOC_OMEGA1 &( N, NZ_loc8, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE C C Purpose: C ======= C Compute C * If MTYPE = 1 C Y_loc(i) = Sum | Aij | | Xj | C j C * If MTYPE = 0 C Y_loc(j) = Sum | Aij | | Xi | C C C Notes: C ===== C C 1) assembly of all Y_loc still has to be done. C 2) X should be available on all processors. C C Arguments: C ========= C INTEGER N INTEGER(8) :: NZ_loc8 INTEGER IRN_loc( NZ_loc8 ), JCN_loc( NZ_loc8 ) COMPLEX A_loc( NZ_loc8 ), X( N ) REAL Y_loc( N ) INTEGER LDLT, MTYPE C C Local variables: C =============== C INTEGER I, J INTEGER(8) :: K8 REAL, PARAMETER :: RZERO=0.0E0 C Y_loc = RZERO IF ( LDLT .eq. 0 ) THEN C Unsymmetric IF ( MTYPE .eq. 1 ) THEN C No transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + abs( A_loc(K8) * X(J) ) ENDDO ELSE C Transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) & .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(J) = Y_loc(J) + abs( A_loc(K8) * X(I) ) ENDDO END IF ELSE C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + abs( A_loc(K8) * X(J) ) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + abs( A_loc(K8) * X(I) ) ENDIF ENDDO END IF RETURN END SUBROUTINE CMUMPS_LOC_OMEGA1 MUMPS_5.8.1/src/dmumps_struc_def.F0000664000175000017500000000102415042446437016705 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_STRUC_DEF INCLUDE 'dmumps_struc.h' END MODULE DMUMPS_STRUC_DEF MUMPS_5.8.1/src/smumps_struc_def.F0000664000175000017500000000102415042446437016724 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_STRUC_DEF INCLUDE 'smumps_struc.h' END MODULE SMUMPS_STRUC_DEF MUMPS_5.8.1/src/dfac_omp_m.F0000664000175000017500000015352015042446440015431 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_OMP_M INTEGER(8), PARAMETER :: UnderL0 = -20_8 INTEGER(8), PARAMETER :: CopyNotStarted = -19_8 INTEGER(8), PARAMETER :: WaitMem = -18_8 INTEGER(8), PARAMETER :: CopyFactorsFinished = -17_8 INTEGER(8), PARAMETER :: AllocateViderCBEnCours = -16_8 INTEGER(8), PARAMETER :: Finished = -15_8 CONTAINS SUBROUTINE DMUMPS_FAC_L0_OMP(N,LIW, NSTK_STEPS, ND, & FILS,STEP, FRERE, DAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PTRIST, PTRAST, PIMASTER, PAMASTER, PTRARW, PTRAIW, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, & RHS_MUMPS, RINFO, NBROOT, NBRTOT, NBROOT_UNDER_L0, UU, ICNTL, & PTLUST_S, PTRFAC, INFO, KEEP, KEEP8, PROCNODE_STEPS,SLAVEF, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & INTARR, DBLARR, root, roota, PERM, NELT, FRTPTR, FRTELT, LPTRAR, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB, NE, DKEEP, PIVNUL_LIST_STRUCT, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP, PHYS_L0_OMP, PERM_L0_OMP, PTR_LEAFS_L0_OMP, & L0_OMP_MAPPING, LL0_OMP_MAPPING, THREAD_LA, & MUMPS_TPS_ARR, DMUMPS_TPS_ARR, & NSTEPSW, OPASSW, OPELIW, NELVAW, COMP, & MAXFRW, NMAXNPIVW, NPVW, NOFFNEGW, NULLNEGW, & NB22T1W, NBTINYW, DET_EXPW, DET_MANTW, DET_SIGNW, & LRGROUPS, L0_OMP_FACTORS, LL0_OMP_FACTORS, & I4_L0_OMP, NBSTATS_I4, NBCOLS_I4, & I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 ) USE MUMPS_LOAD !$ USE OMP_LIB USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T USE DMUMPS_TPS_M, ONLY : DMUMPS_TPS_T USE MUMPS_LR_STATS USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC, & DMUMPS_L0OMPFAC_T USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : & DMUMPS_DM_FAC_ALLOC_ALLOWED, & DMUMPS_DM_ALLOC_S_WK, & DMUMPS_DM_FREE_S_WK USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER N,LIW, LPTRAR, & NSTEPSW, INFO(80) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER(8), INTENT(IN) :: THREAD_LA INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST_S(KEEP(28)), PERM(N) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NE(KEEP(28)) DOUBLE PRECISION RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER NBROOT INTEGER NBRTOT INTEGER, intent(out) :: NBROOT_UNDER_L0 INTEGER COMM_LOAD, ASS_IRECV DOUBLE PRECISION UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) DOUBLE PRECISION :: OPASSW, OPELIW INTEGER LRGROUPS(KEEP(280)) INTEGER, INTENT ( IN ) :: LPOOL_B_L0_OMP INTEGER, INTENT ( IN ) :: IPOOL_B_L0_OMP & ( LPOOL_B_L0_OMP ) INTEGER, INTENT ( IN ) :: L_PHYS_L0_OMP INTEGER, INTENT ( IN ) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT ( IN ) :: L_VIRT_L0_OMP INTEGER, INTENT ( IN ) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT ( IN ) :: VIRT_L0_OMP_MAPPING( L_VIRT_L0_OMP ) INTEGER, INTENT ( IN ) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT ( IN ) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT ( IN ) :: LL0_OMP_MAPPING INTEGER, INTENT ( OUT ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) TYPE (MUMPS_TPS_T), DIMENSION(:) :: MUMPS_TPS_ARR TYPE (DMUMPS_TPS_T), DIMENSION(:) :: DMUMPS_TPS_ARR INTEGER, INTENT ( IN ) :: LL0_OMP_FACTORS TYPE (DMUMPS_L0OMPFAC_T), INTENT(INOUT) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER, INTENT (IN) :: NBSTATS_I4, NBSTATS_I8 INTEGER, INTENT (IN) :: NBCOLS_I4, NBCOLS_I8 INTEGER, INTENT (IN) :: I4_L0_OMP(NBSTATS_I4, NBCOLS_I4) INTEGER(8), INTENT (IN) :: I8_L0_OMP(NBSTATS_I8, NBCOLS_I8) LOGICAL DMUMPS_POOL_EMPTY EXTERNAL DMUMPS_POOL_EMPTY, DMUMPS_EXTRACT_POOL INTEGER :: MYTHREAD_ID, ITH INTEGER :: THREAD_ID_P DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 INTEGER INODE, LEAF INTEGER TYPEF INTEGER NBFIN INTEGER TYPE INTEGER NBROOT_PROCESSED INTEGER MAXFRW, NPVW, NMAXNPIVW, NOFFNEGW, NULLNEGW, NELVAW, COMP INTEGER :: NB22T1W, NBTINYW, DET_EXPW, DET_SIGNW DOUBLE PRECISION :: DET_MANTW DOUBLE PRECISION FLOP_ESTIM_ACC INTEGER :: LPOOL_P INTEGER, DIMENSION(:), ALLOCATABLE :: IPOOL_P INTEGER(8) :: TO_ALLOCATE INTEGER, DIMENSION(:), ALLOCATABLE :: ID INTEGER(8), DIMENSION(:), ALLOCATABLE :: VAL INTEGER(8), ALLOCATABLE, DIMENSION(:) :: STATE, SIZE_COPIED INTEGER :: NbWaitMem, NbFinished, NbOnGoingCopies, NbUnderL0 INTEGER(8) :: KEEP8_77_SAVE DOUBLE PRECISION :: GTIME INTEGER(8) :: MEMDISPO_UNDERL0, MEMDISPO_PERTHREAD INTEGER :: BLR_STRAT INTEGER :: VIRTUAL_TASK, PHYSICAL_TASK INTEGER :: IFATH INTEGER :: I, INFO_P(2), allocok INTEGER(8) :: I8 !$ INTEGER(8) :: CHUNK8 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP_SAVE, NOMP_TOTAL !$ INTEGER :: NOMP_INNER !$ LOGICAL :: SAVE_NESTED CALL MUMPS_LOAD_DISABLE() GTIME = MPI_WTIME() L0_OMP_MAPPING = 0 NBROOT_PROCESSED = 0 NSTEPSW = 0 OPASSW = DZERO OPELIW = DZERO NELVAW = 0 COMP = 0 MAXFRW = 0 NMAXNPIVW = 0 NOFFNEGW = 0 NULLNEGW = 0 FLOP_ESTIM_ACC = DZERO NPVW = 0 NB22T1W = 0 NBTINYW = 0 DET_EXPW = 0 DET_MANTW = cmplx(1.0D0,0.0D0, kind=kind(1.0D0)) DET_SIGNW = 1 DO ITH = 1, KEEP(400) NULLIFY(MUMPS_TPS_ARR(ITH)%IW) NULLIFY(MUMPS_TPS_ARR(ITH)%ITLOC) NULLIFY(DMUMPS_TPS_ARR(ITH)%A) CALL DMUMPS_SET_MAXS_MAXIS_THREAD( & MUMPS_TPS_ARR(ITH)%LA, & MUMPS_TPS_ARR(ITH)%LIW, BLR_STRAT, & KEEP, & I4_L0_OMP(1,ITH), NBSTATS_I4, & I8_L0_OMP(1,ITH), NBSTATS_I8) ENDDO IF (KEEP8(4) .NE. 0_8) THEN CALL DMUMPS_MA_EFF_MEM_DISPO ( & MUMPS_TPS_ARR, KEEP(400),KEEP8, KEEP, & N, BLR_STRAT, LPOOL_B_L0_OMP, & I8_L0_OMP, NBSTATS_I8, & MEMDISPO_UNDERL0 & ) IF (KEEP(486).EQ.2) THEN MEMDISPO_UNDERL0 = max(MEMDISPO_UNDERL0/20_8,0_8) ELSE MEMDISPO_UNDERL0 = max(MEMDISPO_UNDERL0/4_8,0_8) ENDIF KEEP8(77) = KEEP8(77) + MEMDISPO_UNDERL0 MEMDISPO_PERTHREAD = 0_8 IF (MEMDISPO_UNDERL0.GT.0) THEN MEMDISPO_PERTHREAD = MEMDISPO_UNDERL0/(int(KEEP(400),8)) ENDIF DO ITH = 1, KEEP(400) MUMPS_TPS_ARR(ITH)%LA = MUMPS_TPS_ARR(ITH)%LA + & MEMDISPO_PERTHREAD ENDDO ENDIF DO ITH = 1, KEEP(400) MUMPS_TPS_ARR(ITH)%LRLU = MUMPS_TPS_ARR(ITH)%LA MUMPS_TPS_ARR(ITH)%LRLUS = MUMPS_TPS_ARR(ITH)%LA MUMPS_TPS_ARR(ITH)%LRLUSM = MUMPS_TPS_ARR(ITH)%LA MUMPS_TPS_ARR(ITH)%IPTRLU = MUMPS_TPS_ARR(ITH)%LA MUMPS_TPS_ARR(ITH)%POSFAC = 1_8 MUMPS_TPS_ARR(ITH)%IWPOS = 1 MUMPS_TPS_ARR(ITH)%IWPOSCB = MUMPS_TPS_ARR(ITH)%LIW ENDDO IF (KEEP(406) .EQ. 2 ) THEN ALLOCATE(STATE(KEEP(400)), SIZE_COPIED(KEEP(400)), stat=allocok) IF (allocok .GT. 0 ) THEN WRITE(*,*) "Problem allocating STATE/SIZE_COPIED", KEEP(400) CALL MUMPS_ABORT() ENDIF CALL DMUMPS_PERFORM_COPIES_INIT( STATE, KEEP8_77_SAVE, & NbWaitMem, NbFinished, NbOnGoingCopies, NbUnderL0, & KEEP, KEEP8 ) ENDIF !$ NOMP_INNER = 1 !$ IF (KEEP(369).GT.0) THEN !$ NOMP_TOTAL = omp_get_max_threads() !$ IF ( NOMP_TOTAL .NE. KEEP(400) ) THEN !$ IF ( KEEP(439) .GT. 1 ) THEN !$ NOMP_INNER = KEEP(439) !$ ELSE IF ( KEEP(439) .EQ. -1 !$ & ) THEN !$ NOMP_INNER = NOMP_TOTAL / KEEP(400) !$ ENDIF !$ IF (NOMP_INNER .GT. 1) THEN !$ SAVE_NESTED = omp_get_nested() !$ CALL OMP_SET_NESTED(.TRUE.) !$ ENDIF !$ ENDIF #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(KEEP(400),4)) #else !$ CALL omp_set_num_threads(KEEP(400)) #endif !$ ENDIF !$OMP PARALLEL !$OMP& SHARED ( IPOOL_B_L0_OMP, LPOOL_B_L0_OMP ) !$OMP& PRIVATE ( VIRTUAL_TASK, PHYSICAL_TASK, !$OMP& IPOOL_P, LPOOL_P, LEAF, INODE, IFATH, INFO_P, I, I8, !$OMP& TO_ALLOCATE, THREAD_ID_P, !$OMP& TYPE, TYPEF, NOMP_SAVE, allocok ) !$OMP& REDUCTION ( + : NPVW, OPASSW, OPELIW, NOFFNEGW, NELVAW, COMP, !$OMP& NB22T1W, NBTINYW, DET_EXPW, NULLNEGW, !$OMP& FLOP_ESTIM_ACC, NBROOT_PROCESSED, NSTEPSW ) !$OMP& REDUCTION ( * : DET_MANTW, DET_SIGNW ) !$OMP& REDUCTION ( max : MAXFRW, NMAXNPIVW ) THREAD_ID_P = 1 !$ THREAD_ID_P = OMP_GET_THREAD_NUM () + 1 !$OMP BARRIER !$ NOMP_SAVE = omp_get_max_threads() #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_INNER,4)) #else !$ CALL omp_set_num_threads(NOMP_INNER) #endif LPOOL_P = LPOOL_B_L0_OMP LEAF = 1 INFO_P = 0 VIRTUAL_TASK = 0 !$ IF ( omp_get_num_threads() .NE. KEEP(400) ) THEN !$ INFO_P(1)=-58 !$ INFO_P(2)=-100-omp_get_num_threads() !$ GOTO 700 !$ ENDIF CALL DMUMPS_DM_FAC_ALLOC_ALLOWED( MUMPS_TPS_ARR(THREAD_ID_P)%LA, & KEEP8, & INFO_P(1), INFO_P(2) ) IF (INFO_P(1) .LT. 0) GOTO 700 CALL DMUMPS_DM_ALLOC_S_WK( DMUMPS_TPS_ARR(THREAD_ID_P)%A, & max(1_8,MUMPS_TPS_ARR(THREAD_ID_P)%LA), allocok, KEEP(430), & KEEP(35) ) IF (allocok.GT.0) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4( MUMPS_TPS_ARR(THREAD_ID_P)%LA, & INFO_P(2)) GOTO 700 ELSE CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & MUMPS_TPS_ARR(THREAD_ID_P)%LA, & KEEP(405).EQ.1, & KEEP8, INFO_P(1), INFO_P(2), & .FALSE., .FALSE. ) IF (INFO_P(1) .LT. 0) THEN GOTO 700 ENDIF ENDIF TO_ALLOCATE = & ((int(MUMPS_TPS_ARR(THREAD_ID_P)%LIW,8) * int(KEEP(34),8 )) / & int(KEEP(35),8 ))+ & ((int(LPOOL_P,8) * int(KEEP(34),8 )) / int(KEEP(35),8 ))+ & ((int(N+KEEP(253),8) * int(KEEP(34),8 )) / int(KEEP(35),8 )) CALL DMUMPS_DM_FAC_ALLOC_ALLOWED( TO_ALLOCATE, & KEEP8, INFO_P(1), INFO_P(2) ) IF ( INFO_P(1) .LT. 0 ) GOTO 700 ALLOCATE ( MUMPS_TPS_ARR(THREAD_ID_P)%IW( & MUMPS_TPS_ARR(THREAD_ID_P)%LIW ), & IPOOL_P ( LPOOL_P ), & MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC ( N + KEEP(253) ), & stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO_P(1) = -13 INFO_P(2) = MUMPS_TPS_ARR(THREAD_ID_P)%LIW + & LPOOL_P + N+KEEP(253) GOTO 700 ELSE CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( TO_ALLOCATE, & KEEP(405).EQ.1, KEEP8, & INFO_P(1), INFO_P(2), .TRUE., .FALSE. ) IF (INFO_P(1) .LT. 0) THEN GOTO 700 ENDIF ENDIF CALL DMUMPS_ALLOC_CB( .FALSE., 0_8, & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, DKEEP, & MUMPS_TPS_ARR(THREAD_ID_P)%IW(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LIW, & DMUMPS_TPS_ARR(THREAD_ID_P)%A(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LA, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%IPTRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOS, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUSM, & INFO_P(1), INFO_P(2) & ) CALL DMUMPS_INIT_POOL_LAST3( IPOOL_P(1), LPOOL_P, & LEAF ) MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC = 0 600 CONTINUE VIRTUAL_TASK = VIRTUAL_TASK + 1 IF ( VIRTUAL_TASK .LT. L_VIRT_L0_OMP ) THEN IF ( VIRT_L0_OMP_MAPPING( VIRTUAL_TASK ) .EQ. THREAD_ID_P ) THEN DO PHYSICAL_TASK = & VIRT_L0_OMP ( VIRTUAL_TASK ), & VIRT_L0_OMP ( VIRTUAL_TASK + 1 ) - 1 DO I = PTR_LEAFS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK )+1 ) + 1, & PTR_LEAFS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK ) ) IF (IPOOL_B_L0_OMP(I) .GT. 0) THEN CALL DMUMPS_INSERT_POOL_N( N, IPOOL_P(1), & LPOOL_P, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), 3, 0, 1, STEP, & IPOOL_B_L0_OMP(I) ) END IF END DO DO WHILE ( & .NOT. DMUMPS_POOL_EMPTY( IPOOL_P(1), LPOOL_P ) & .AND. INFO_P(1) .GE. 0 ) CALL DMUMPS_EXTRACT_POOL( N, IPOOL_P(1), LPOOL_P, & PROCNODE_STEPS, SLAVEF, STEP, INODE, KEEP, KEEP8, MYID_NODES, & ND, .FALSE. ) 10 CONTINUE L0_OMP_MAPPING ( STEP ( INODE ) ) = THREAD_ID_P IFATH = DAD ( STEP ( INODE ) ) TYPE = 1 IF ( IFATH .NE. 0 ) THEN TYPEF = 1 ELSE TYPEF = -9999 ENDIF CALL MUMPS_STOP_ON_USER_REQUEST(KEEP, KEEP8, ICNTL, & INFO_P, MYID) IF (INFO_P(1) .LT. 0) THEN GOTO 700 ENDIF IF (THREAD_ID_P .EQ. KEEP(400)-1) THEN CALL DMUMPS_UPDATE_PROGRESS( OPELIW*KEEP(400), KEEP8 ) ENDIF CALL DMUMPS_PROCESS_FRONT_NIV1(COMM_LOAD, ASS_IRECV, N, INODE, & TYPE, TYPEF, MUMPS_TPS_ARR(THREAD_ID_P)%LA, MUMPS_TPS_ARR(THREAD & _ID_P)%IW(1), MUMPS_TPS_ARR(THREAD_ID_P)%LIW, DMUMPS_TPS_ARR( & THREAD_ID_P)%A(1), MAXFRW, NOFFNEGW, NULLNEGW, NPVW, & NB22T1W, NBTINYW, DET_EXPW, DET_MANTW, DET_SIGNW, INFO_P, UU, & SEUIL, SEUIL_LDLT_NIV2, OPELIW, NELVAW, NMAXNPIVW, NSTEPSW, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & NE, MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS, MUMPS_TPS_ARR(THREAD_ID_P)% % LRLUSM, MUMPS_TPS_ARR(THREAD_ID_P)%IPTRLU, ICNTL, KEEP, KEEP8, & DKEEP, PIVNUL_LIST_STRUCT, COMP, MUMPS_TPS_ARR(THREAD_ID_P)% & IWPOS, MUMPS_TPS_ARR(THREAD_ID_P)%IWPOSCB, PROCNODE_STEPS, & SLAVEF, IFATH, COMM_NODES, MYID_NODES, IPOOL_P, LPOOL_P, LEAF, & PERM, NSTK_STEPS, BUFR, LBUFR, LBUFR_BYTES, & NBFIN, root, roota, OPASSW, MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC(1), & RHS_MUMPS, FILS, PTRARW, PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, & PTRDEBARR, INTARR, DBLARR, ND, FRERE, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS, FLOP_ESTIM_ACC ) IF (INFO_P(1) .LT. 0) THEN GOTO 700 ENDIF IF ( IFATH .NE. 0 ) THEN IF ( PHYS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK ) ) & .NE. INODE ) THEN NSTK_STEPS ( STEP ( IFATH ) ) = & NSTK_STEPS ( STEP ( IFATH ) ) - 1 IF ( NSTK_STEPS ( STEP ( IFATH ) ) .EQ. 0 ) THEN INODE = IFATH GOTO 10 ENDIF ELSE !$OMP ATOMIC UPDATE NSTK_STEPS ( STEP ( IFATH ) ) = & NSTK_STEPS ( STEP ( IFATH ) ) - 1 !$OMP END ATOMIC END IF ELSE NBROOT_PROCESSED = NBROOT_PROCESSED + 1 END IF END DO END DO ENDIF GOTO 600 ENDIF 700 CONTINUE IF (associated(MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC)) THEN DEALLOCATE(MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC) NULLIFY(MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -(int(N+KEEP(253),8) * int(KEEP(34),8 )) / int(KEEP(35),8), & KEEP(405).EQ.1, KEEP8, & INFO_P(1), INFO_P(2), .TRUE., .FALSE. ) ENDIF IF (allocated(IPOOL_P)) THEN DEALLOCATE(IPOOL_P); CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -(int(LPOOL_P,8) * int(KEEP(34),8 )) / int(KEEP(35),8), & KEEP(405).EQ.1, KEEP8, & INFO_P(1), INFO_P(2), .TRUE., .FALSE. ) ENDIF IF ( KEEP(406) .EQ. 2) THEN CALL DMUMPS_PERFORM_COPIES( THREAD_ID_P, & MUMPS_TPS_ARR, DMUMPS_TPS_ARR, & L0_OMP_FACTORS, LL0_OMP_FACTORS, & STATE, SIZE_COPIED, & NbWaitMem, NbFinished, NbOngoingCopies, NbUnderL0, & MYID_NODES, N, SLAVEF, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & KEEP, KEEP8, INFO_P & ) ELSE IF ((KEEP(407) .EQ. 1) .OR. (KEEP(406) .EQ.1) ) THEN IF (INFO_P(1) .GE. 0) THEN CALL DMUMPS_DM_CBSTATIC2DYNAMIC_I & (2, & 0_8, & .FALSE., & MYID_NODES, N, SLAVEF, KEEP, KEEP8, & MUMPS_TPS_ARR(THREAD_ID_P)%IW(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LIW, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOSCB, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOS, & DMUMPS_TPS_ARR(THREAD_ID_P)%A(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LA, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%IPTRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & INFO_P(1), INFO_P(2) ) ENDIF ENDIF IF (KEEP(406) .EQ.1) THEN IF (INFO_P(1) .GE.0 )THEN TO_ALLOCATE = max(MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1,1_8) CALL DMUMPS_DM_FAC_ALLOC_ALLOWED( TO_ALLOCATE, & KEEP8, INFO_P(1), INFO_P(2) ) ENDIF IF (INFO_P(1) .GE.0 )THEN ALLOCATE(L0_OMP_FACTORS(THREAD_ID_P)%A(TO_ALLOCATE), & stat=allocok) IF (allocok .GT. 0) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4(TO_ALLOCATE, INFO_P(2)) L0_OMP_FACTORS(THREAD_ID_P)%LA = 0_8 ELSE L0_OMP_FACTORS(THREAD_ID_P)%LA = & MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8 CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & L0_OMP_FACTORS(THREAD_ID_P)%LA, KEEP(405).EQ.1, KEEP8, & INFO_P(1), INFO_P(2), .TRUE., .FALSE. ) ENDIF ENDIF IF (INFO_P(1) .GE.0 ) THEN DO I8 = 1_8, MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8 L0_OMP_FACTORS(THREAD_ID_P)%A(I8) = & DMUMPS_TPS_ARR(THREAD_ID_P)%A(I8) ENDDO ENDIF IF ( associated(DMUMPS_TPS_ARR(THREAD_ID_P)%A)) THEN CALL DMUMPS_DM_FREE_S_WK( DMUMPS_TPS_ARR(THREAD_ID_P)%A, & KEEP(430) ) NULLIFY(DMUMPS_TPS_ARR(THREAD_ID_P)%A) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -MUMPS_TPS_ARR(THREAD_ID_P)%LA, & KEEP(405).EQ.1, & KEEP8, & INFO_P(1), INFO_P(2), & .FALSE., .FALSE. ) IF (INFO_P(1) .GE. 0) THEN !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - L0_OMP_FACTORS(THREAD_ID_P)%LA !$OMP END ATOMIC ENDIF ENDIF ENDIF ENDIF IF (INFO_P(1) .LT.0) THEN !$OMP CRITICAL(critical_info) INFO(1) = INFO_P(1) INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ELSE IF (INFO_P(1) .GE. 0) THEN !$OMP CRITICAL(critical_info) IF (INFO(1) .EQ. 0) THEN INFO(1) = INFO_P(1) INFO(2) = INFO_P(2) ENDIF !$OMP END CRITICAL(critical_info) ENDIF #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_SAVE,4)) #else !$ CALL omp_set_num_threads(NOMP_SAVE) #endif !$OMP END PARALLEL !$ IF (KEEP(369).GT.0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_TOTAL),4)) #else !$ CALL omp_set_num_threads(NOMP_TOTAL) #endif !$ IF (NOMP_INNER .GT. 1) THEN !$ CALL OMP_SET_NESTED(SAVE_NESTED) !$ ENDIF !$ ENDIF IF (INFO(1) .LT. 0) THEN IF (ICNTL(1) .GT. 0 .AND. ICNTL(4) .GE.1 ) THEN WRITE(ICNTL(1),'(A,I6,I16,A,I5,A)') & "** ERROR DURING L0_OMP: INFO(1:2)=", & INFO(1), INFO(2), " (MPI worker ", MYID_NODES,")" ENDIF ENDIF IF ( KEEP(406) .EQ. 0 ) THEN ALLOCATE(ID(KEEP(400)), VAL(KEEP(400)), & stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = KEEP(400) GOTO 800 ENDIF DO MYTHREAD_ID = 1, KEEP(400) VAL (MYTHREAD_ID) = MUMPS_TPS_ARR( MYTHREAD_ID )%POSFAC-1_8 ID (MYTHREAD_ID) = MYTHREAD_ID ENDDO CALL MUMPS_SORT_INT8(KEEP(400), VAL, ID) DO ITH=1, KEEP(400) MYTHREAD_ID = ID(ITH) IF ((KEEP(407).NE.1) .AND. (KEEP(406).EQ.0)) THEN IF (INFO(1) .GE. 0) THEN CALL DMUMPS_DM_CBSTATIC2DYNAMIC_I & (2, & 0_8, & .FALSE., & MYID_NODES, N, SLAVEF, KEEP, KEEP8, & MUMPS_TPS_ARR(MYTHREAD_ID)%IW(1), & MUMPS_TPS_ARR(MYTHREAD_ID)%LIW, & MUMPS_TPS_ARR(MYTHREAD_ID)%IWPOSCB, & MUMPS_TPS_ARR(MYTHREAD_ID)%IWPOS, & DMUMPS_TPS_ARR(MYTHREAD_ID)%A(1), & MUMPS_TPS_ARR(MYTHREAD_ID)%LA, & MUMPS_TPS_ARR(MYTHREAD_ID)%LRLU, & MUMPS_TPS_ARR(MYTHREAD_ID)%IPTRLU, & MUMPS_TPS_ARR(MYTHREAD_ID)%LRLUS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & INFO(1), INFO(2) ) ENDIF ENDIF IF (KEEP(406).EQ.0) THEN IF (INFO(1) .GE. 0 )THEN TO_ALLOCATE = max(MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC-1,1_8) CALL DMUMPS_DM_FAC_ALLOC_ALLOWED( TO_ALLOCATE, & KEEP8, INFO(1), INFO(2) ) ENDIF IF (INFO(1) .GE.0 ) THEN ALLOCATE(L0_OMP_FACTORS(MYTHREAD_ID)%A(TO_ALLOCATE), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1) = -13 CALL MUMPS_SETI8TOI4(TO_ALLOCATE, INFO(2)) L0_OMP_FACTORS(MYTHREAD_ID)%LA = 0_8 ELSE L0_OMP_FACTORS(MYTHREAD_ID)%LA = & MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC-1_8 CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & L0_OMP_FACTORS(MYTHREAD_ID)%LA, & KEEP(405).EQ.1, KEEP8, & INFO(1), INFO(2), .TRUE., .FALSE. ) ENDIF ENDIF IF (INFO(1) .GE. 0) THEN !$ CHUNK8 = max( int(KEEP(361),8), !$ & (MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC+KEEP(400)-2_8) / !$ & KEEP(400) ) !$ OMP_FLAG = ( (MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC-1_8 > !$ & int(KEEP(361),8)) !$ & .AND. (KEEP(400).GT.1) !$ & ) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (OMP_FLAG) DO I8 = 1_8, MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC-1_8 L0_OMP_FACTORS(MYTHREAD_ID)%A(I8) = & DMUMPS_TPS_ARR(MYTHREAD_ID)%A(I8) ENDDO !$OMP END PARALLEL DO ENDIF IF ( associated(DMUMPS_TPS_ARR(MYTHREAD_ID)%A)) THEN CALL DMUMPS_DM_FREE_S_WK( DMUMPS_TPS_ARR(THREAD_ID_P)%A, & KEEP(430) ) NULLIFY(DMUMPS_TPS_ARR(MYTHREAD_ID)%A) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -MUMPS_TPS_ARR(MYTHREAD_ID)%LA, & KEEP(405).EQ.1, KEEP8, & INFO(1), INFO(2), & .FALSE., .FALSE. ) IF (INFO(1).GE.0) THEN KEEP8(69) = KEEP8(69) - L0_OMP_FACTORS(MYTHREAD_ID)%LA ENDIF ENDIF ENDIF ENDDO IF (ALLOCATED(ID)) DEALLOCATE(ID) IF (ALLOCATED(VAL)) DEALLOCATE(VAL) ENDIF 800 CONTINUE DO ITH = 1, KEEP(400) IF ( associated(DMUMPS_TPS_ARR(ITH)%A)) THEN CALL DMUMPS_DM_FREE_S_WK( DMUMPS_TPS_ARR(ITH)%A, & KEEP(430) ) NULLIFY(DMUMPS_TPS_ARR(ITH)%A) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -MUMPS_TPS_ARR(ITH)%LA, & KEEP(405).EQ.1, KEEP8, & INFO(1), INFO(2), & .FALSE., .FALSE. ) IF (INFO(1).GE.0) THEN KEEP8(69) = KEEP8(69) - L0_OMP_FACTORS(ITH)%LA ENDIF ENDIF ENDDO KEEP8(64) = 0_8 DO I = 1, KEEP(400) KEEP8(64) = KEEP8(64) + MUMPS_TPS_ARR(I)%POSFAC - 1_8 ENDDO KEEP8(62) = 0_8 DO I = 1, KEEP(400) KEEP8(62) = KEEP8(62) + MUMPS_TPS_ARR(I)%LRLUSM ENDDO NBROOT_UNDER_L0 = NBROOT_PROCESSED DKEEP(95) = MPI_WTIME() - GTIME IF (KEEP(486) .NE. 0) THEN TIME_UPDATE = TIME_UPDATE/dble(KEEP(400)) TIME_COMPRESS = TIME_COMPRESS/dble(KEEP(400)) TIME_FRSWAP_COMPRESS = TIME_FRSWAP_COMPRESS/dble(KEEP(400)) TIME_CB_COMPRESS = TIME_CB_COMPRESS/dble(KEEP(400)) TIME_PANEL = TIME_PANEL/dble(KEEP(400)) TIME_FAC_I = TIME_FAC_I/dble(KEEP(400)) TIME_FAC_MQ = TIME_FAC_MQ/dble(KEEP(400)) TIME_FAC_SQ = TIME_FAC_SQ/dble(KEEP(400)) TIME_FRFRONTS = TIME_FRFRONTS/dble(KEEP(400)) TIME_LRTRSM = TIME_LRTRSM/dble(KEEP(400)) TIME_FRTRSM = TIME_FRTRSM/dble(KEEP(400)) TIME_LR_MODULE = TIME_LR_MODULE/dble(KEEP(400)) TIME_DECOMP = TIME_DECOMP/dble(KEEP(400)) TIME_DIAGCOPY = TIME_DIAGCOPY/dble(KEEP(400)) TIME_DECOMP_UCFS = TIME_DECOMP_UCFS/dble(KEEP(400)) TIME_LRASM_NIV1 = TIME_LRASM_NIV1/dble(KEEP(400)) TIME_LRASM_LOCASM2 = TIME_LRASM_LOCASM2/dble(KEEP(400)) TIME_LRASM_MAPLIG1 = TIME_LRASM_MAPLIG1/dble(KEEP(400)) TIME_LRASM_CONTRIB2 = TIME_LRASM_CONTRIB2/dble(KEEP(400)) TIME_FRASM_LOCASM2 = TIME_FRASM_LOCASM2/dble(KEEP(400)) TIME_FRASM_MAPLIG1 = TIME_FRASM_MAPLIG1/dble(KEEP(400)) TIME_FRASM_CONTRIB2 = TIME_FRASM_CONTRIB2/dble(KEEP(400)) ENDIF DKEEP(97) = DKEEP(97) / dble(KEEP(400)) CALL MUMPS_LOAD_ENABLE() CALL MUMPS_LOAD_UPDATE(0,.FALSE., FLOP_ESTIM_ACC,KEEP,KEEP8) RETURN END SUBROUTINE DMUMPS_FAC_L0_OMP SUBROUTINE DMUMPS_SET_MAXS_MAXIS_THREAD(MAXS_BASE_RELAXED8TH, & MAXIS_BASE_RELAXEDTH, BLR_STRAT, & KEEP, & I4_L0_OMPTH, NBSTATS_I4, & I8_L0_OMPTH, NBSTATS_I8) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP(500), NBSTATS_I4, NBSTATS_I8 INTEGER, INTENT(IN) :: I4_L0_OMPTH(NBSTATS_I4) INTEGER(8), INTENT(IN) :: I8_L0_OMPTH(NBSTATS_I8) INTEGER(8), INTENT(OUT) :: MAXS_BASE_RELAXED8TH INTEGER, INTENT(OUT) :: MAXIS_BASE_RELAXEDTH INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER :: PERLU INTEGER(8) :: MAXS_BASE8TH INTEGER(8) :: MAXIS_BASE_RELAXEDTH8 PERLU = KEEP(12) CALL DMUMPS_SET_BLRSTRAT_AND_MAXS ( MAXS_BASE8TH, & MAXS_BASE_RELAXED8TH, BLR_STRAT, KEEP(1), & I8_L0_OMPTH(2), I8_L0_OMPTH(3), I8_L0_OMPTH(5), & I8_L0_OMPTH(6), I8_L0_OMPTH(7), I8_L0_OMPTH(8) ) IF ( KEEP(201) .EQ. 0 ) THEN MAXIS_BASE_RELAXEDTH8 = int(I4_L0_OMPTH(2),8) ELSE MAXIS_BASE_RELAXEDTH8 = int(I4_L0_OMPTH(4),8) ENDIF MAXIS_BASE_RELAXEDTH8 = max( 1_8, & MAXIS_BASE_RELAXEDTH8 + 3 * max(PERLU,10) * & ( MAXIS_BASE_RELAXEDTH8 / 100 + 1 ) & ) MAXIS_BASE_RELAXEDTH8 = min(MAXIS_BASE_RELAXEDTH8, & int( huge( MAXIS_BASE_RELAXEDTH ) ,8) & ) MAXIS_BASE_RELAXEDTH = int( MAXIS_BASE_RELAXEDTH8 ) RETURN END SUBROUTINE DMUMPS_SET_MAXS_MAXIS_THREAD SUBROUTINE DMUMPS_MA_EFF_MEM_DISPO( & MUMPS_TPS_ARR, NBTHREADS, KEEP8, KEEP, & N, BLR_STRAT, LPOOL_P, & I8_L0_OMP, NBSTATS_I8, & MEMDISPO_UNDERL0) USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T IMPLICIT NONE INTEGER, INTENT(IN) :: N, BLR_STRAT, KEEP(500) INTEGER, INTENT(IN) :: NBSTATS_I8, NBTHREADS, LPOOL_P INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER(8), INTENT(IN) :: I8_L0_OMP(NBSTATS_I8,NBTHREADS) INTEGER(8), INTENT(OUT) :: MEMDISPO_UNDERL0 TYPE (MUMPS_TPS_T), INTENT(IN) :: MUMPS_TPS_ARR(:) INTEGER :: PERLU, ITH, ITHMIN, ITHMIN_if_LRLU, OOC_STRAT INTEGER(8) :: TO_ALLOCATE, BLR_RELATED, COPY_RELATED INTEGER(8) :: MIN_NRLADU_underL0, MIN_NRLADU_if_LR_LU_underL0 PERLU = KEEP(12) OOC_STRAT = KEEP(201) TO_ALLOCATE = 0_8 DO ITH = 1, NBTHREADS TO_ALLOCATE = TO_ALLOCATE + & ((int(MUMPS_TPS_ARR(ITH)%LIW,8) * int(KEEP(34),8 )) / & int(KEEP(35),8 )) & + MUMPS_TPS_ARR(ITH)%LA ENDDO TO_ALLOCATE = TO_ALLOCATE + int(NBTHREADS,8)* ( & ((int(LPOOL_P,8) * int(KEEP(34),8 )) / int(KEEP(35),8 )) + & ((int(N+KEEP(253),8) * int(KEEP(34),8 )) / int(KEEP(35),8 )) & ) BLR_RELATED = 0_8 DO ITH = 1, NBTHREADS IF (BLR_STRAT.EQ.1) THEN BLR_RELATED = BLR_RELATED + & I8_L0_OMP(10,ITH) + & int(PERLU,8) * ( I8_L0_OMP(10,ITH) / 100_8 + 1_8) ELSE IF (BLR_STRAT.EQ.2) THEN BLR_RELATED = BLR_RELATED + & I8_L0_OMP(13,ITH) + & int(PERLU,8) * ( I8_L0_OMP(13,ITH) / 100_8 + 1_8) ELSE IF (BLR_STRAT.EQ.3) THEN BLR_RELATED = BLR_RELATED + & I8_L0_OMP(8,ITH) + & int(PERLU,8) * ( I8_L0_OMP(8,ITH) / 100_8 + 1_8) ENDIF ENDDO COPY_RELATED = 0_8 ITHMIN = 1 ITHMIN_if_LRLU = 1 MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,1) MIN_NRLADU_underL0 = I8_L0_OMP(1,1) DO ITH = 1, NBTHREADS IF (I8_L0_OMP(1,ITH).LT.MIN_NRLADU_underL0) & THEN MIN_NRLADU_underL0 = I8_L0_OMP(1,ITH) ITHMIN = ITH ENDIF IF (I8_L0_OMP(4,ITH).LT.MIN_NRLADU_if_LR_LU_underL0) & THEN MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,ITH) ITHMIN_if_LRLU = ITH ENDIF ENDDO IF (BLR_STRAT.EQ.0) THEN IF (OOC_STRAT .LE. 0 .AND. OOC_STRAT .NE. -1 ) THEN COPY_RELATED = COPY_RELATED + & I8_L0_OMP(1,ITHMIN) + & I8_L0_OMP(23, ITHMIN) ELSE COPY_RELATED = COPY_RELATED + & I8_L0_OMP(23, ITHMIN) ENDIF ELSE IF (OOC_STRAT .LE. 0 .AND. OOC_STRAT .NE. -1 ) THEN COPY_RELATED = COPY_RELATED + & I8_L0_OMP(4,ITHMIN_if_LRLU) + & I8_L0_OMP(23,ITHMIN_if_LRLU ) ELSE COPY_RELATED = COPY_RELATED + & I8_L0_OMP(23, ITHMIN_if_LRLU) ENDIF ENDIF COPY_RELATED = COPY_RELATED + & int(PERLU,8)*(COPY_RELATED / 100_8 + 1_8 ) TO_ALLOCATE = TO_ALLOCATE + COPY_RELATED + BLR_RELATED MEMDISPO_UNDERL0 = KEEP8(75) - TO_ALLOCATE RETURN END SUBROUTINE DMUMPS_MA_EFF_MEM_DISPO SUBROUTINE DMUMPS_L0OMP_COPY_IW( IW, LIW, IWPOS, & MUMPS_TPS_ARR, KEEP, & PTLUST, ICNTL, INFO ) USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T IMPLICIT NONE INTEGER :: KEEP(500) INTEGER, INTENT( IN ) :: LIW INTEGER, INTENT( INOUT ) :: IW(:) INTEGER, INTENT( INOUT ) :: IWPOS INTEGER, INTENT( INOUT ) :: PTLUST(KEEP(28)) INTEGER, INTENT( IN ) :: ICNTL(60) INTEGER, INTENT( INOUT ) :: INFO(80) TYPE (MUMPS_TPS_T), TARGET :: MUMPS_TPS_ARR(:) INTEGER :: ITHREAD, JTHREAD INTEGER :: REQUESTED_SIZE INTEGER :: IWPOS_TO_COPY INTEGER :: LOC_IPOS INTEGER :: LOC_SIZE, LOC_ISTEP TYPE (MUMPS_TPS_T), POINTER :: MUMPS_TPS INCLUDE 'mumps_headers.h' REQUESTED_SIZE = 0 DO ITHREAD = 1, size(MUMPS_TPS_ARR) MUMPS_TPS => MUMPS_TPS_ARR(ITHREAD) REQUESTED_SIZE = REQUESTED_SIZE + MUMPS_TPS%IWPOS - 1 ENDDO IF ( LIW - IWPOS + 1 .LT. REQUESTED_SIZE ) THEN WRITE(*,*) " LIW too small in DMUMPS_L0OMP_COPY_IW !!", LIW, & REQUESTED_SIZE INFO(1) = -8 INFO(2) = REQUESTED_SIZE-LIW+IWPOS-1 IF ( ICNTL(1) .GT. 0 .AND. ICNTL(4).GE.1) THEN WRITE(ICNTL(1),*) " ** ERROR IN DMUMPS_L0OMP_COPY_IW: ", & "LIW TOO SMALL TO COPY LOCAL FACTOR INFORMATION", & INFO(2) ENDIF GOTO 500 ENDIF DO ITHREAD = 1, size(MUMPS_TPS_ARR) MUMPS_TPS => MUMPS_TPS_ARR(ITHREAD) IWPOS_TO_COPY = IWPOS DO JTHREAD=1, ITHREAD - 1 IWPOS_TO_COPY = IWPOS_TO_COPY+MUMPS_TPS_ARR(JTHREAD)%IWPOS-1 ENDDO IW(IWPOS_TO_COPY: IWPOS_TO_COPY+MUMPS_TPS%IWPOS - 2) = & MUMPS_TPS%IW(1:MUMPS_TPS%IWPOS-1) LOC_IPOS = 1 DO WHILE ( LOC_IPOS .NE. MUMPS_TPS%IWPOS ) LOC_SIZE = MUMPS_TPS%IW(LOC_IPOS+XXI) LOC_ISTEP = MUMPS_TPS%IW(LOC_IPOS+KEEP(IXSZ)+4) PTLUST(LOC_ISTEP) = IWPOS_TO_COPY+LOC_IPOS-1 LOC_IPOS = LOC_IPOS + LOC_SIZE ENDDO ENDDO IWPOS = IWPOS + REQUESTED_SIZE 500 CONTINUE RETURN END SUBROUTINE DMUMPS_L0OMP_COPY_IW SUBROUTINE DMUMPS_PERFORM_COPIES_INIT( STATE, KEEP8_77_SAVE, & NbWaitMem, NbFinished, NbOnGoingCopies, NbUnderL0, & KEEP, KEEP8 ) INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(OUT) :: NbWaitMem, & NbFinished, & NbOnGoingCopies, & NbUnderL0 INTEGER(8), INTENT(OUT) :: STATE(KEEP(400)), KEEP8_77_SAVE INTEGER :: ITH NbWaitMem = 0 NbFinished = 0 NbOnGoingCopies = 0 NbUnderL0 = KEEP(400) DO ITH=1, KEEP(400) STATE(ITH) = UnderL0 ENDDO KEEP8_77_SAVE = KEEP8(77) RETURN END SUBROUTINE DMUMPS_PERFORM_COPIES_INIT SUBROUTINE DMUMPS_PERFORM_COPIES( THREAD_ID_P, & MUMPS_TPS_ARR, DMUMPS_TPS_ARR, & L0_OMP_FACTORS, LL0_OMP_FACTORS, & STATE, SIZE_COPIED, & NbWaitMem, NbFinished, NbOngoingCopies, NbUnderL0, & MYID_NODES, N, SLAVEF, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & KEEP, KEEP8, INFO_P & ) USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T USE DMUMPS_TPS_M, ONLY : DMUMPS_TPS_T USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_L0OMPFAC_T USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_FREE_S_WK INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: THREAD_ID_P INTEGER, INTENT(INOUT) :: INFO_P(2) INTEGER, INTENT(IN) :: MYID_NODES, N, SLAVEF INTEGER, INTENT(IN) :: STEP(N), DAD(KEEP(28)) INTEGER(8), INTENT(IN) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT(INOUT) :: NbWaitMem, & NbFinished, & NbOnGoingCopies, & NbUnderL0 INTEGER(8), INTENT(INOUT) :: STATE( KEEP(400) ) INTEGER(8), INTENT(INOUT) :: SIZE_COPIED(KEEP(400) ) TYPE (MUMPS_TPS_T), DIMENSION(:) :: MUMPS_TPS_ARR TYPE (DMUMPS_TPS_T), DIMENSION(:) :: DMUMPS_TPS_ARR INTEGER, INTENT ( IN ) :: LL0_OMP_FACTORS TYPE (DMUMPS_L0OMPFAC_T), INTENT(INOUT) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER :: NbFinishedPrivateCopy INTEGER :: LOCAL_ACTION INTEGER, PARAMETER :: NOTHING = 0 INTEGER, PARAMETER :: FREE_WORK_MYID = 1 INTEGER, PARAMETER :: COPY_FACTORS = 2 INTEGER, PARAMETER :: AllocateViderCB = 3 INTEGER, PARAMETER :: DORMIR = 4 INTEGER(8) :: COPY_START, CHUNK8, I8, TO_ALLOCATE INTEGER :: ITH, K INTEGER :: allocok INTEGER(8) :: PeakAuthorized_P INTEGER(8) :: MemNeeded_P, MemNeededForCB_P, MemDispo_P, & CBCopiedToDynamic_P, LRLUS_SAVE_P INTEGER(8) :: KEEP8_71, KEEP8_73 !$OMP CRITICAL(L0_COPIES) STATE(THREAD_ID_P) = CopyNotStarted IF ( INFO_P(1) .LT. 0 ) THEN NbFinished = NbFinished + 1 STATE(THREAD_ID_P) = Finished ENDIF DO ITH = 1, KEEP(400) IF ( STATE(ITH) .EQ. WaitMem ) THEN STATE(ITH)=CopyNotStarted ENDIF ENDDO NbWaitMem = 0 NbFinishedPrivateCopy = NbFinished !$OMP END CRITICAL(L0_COPIES) DO WHILE ( NbFinishedPrivateCopy .NE. KEEP(400) ) LOCAL_ACTION = DORMIR !$OMP CRITICAL(L0_COPIES) NbFinishedPrivateCopy = NbFinished IF ( NbFinished.EQ. KEEP(400)) THEN LOCAL_ACTION = NOTHING ELSE IF ( (NbFinished+NbWaitMem) .EQ. KEEP(400) ) THEN !$OMP ATOMIC READ KEEP8_73 = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC READ KEEP8_71 = KEEP8(71) !$OMP END ATOMIC MemDispo_P = KEEP8(77) - (KEEP8_73 -KEEP8_71) MemDispo_P = min(MemDispo_P, KEEP8(75)-KEEP8_73) MemNeeded_P = huge(MemNeeded_P) DO ITH = 1, KEEP(400) IF (STATE(ITH).EQ.WaitMem) THEN MemNeeded_P = min( MemNeeded_P, & MUMPS_TPS_ARR(ITH)%LA - & MUMPS_TPS_ARR(ITH)%LRLUS ) ENDIF ENDDO IF ((KEEP8(75)-KEEP8_73).LT.MemNeeded_P) THEN INFO_P(1) = -19 CALL MUMPS_SET_IERROR ( & MemNeeded_P-(KEEP8(75)-KEEP8_73), INFO_P(2)) DO ITH = 1, KEEP(400) STATE(ITH) = Finished ENDDO NbFinished = KEEP(400) ELSE KEEP8(77) = MemNeeded_P + (KEEP8_73 -KEEP8_71) DO ITH = 1, KEEP(400) IF ( STATE(ITH) .EQ. WaitMem ) THEN STATE(ITH)=CopyNotStarted ENDIF ENDDO NbWaitMem = 0 ENDIF LOCAL_ACTION = NOTHING ELSE SELECT CASE (STATE(THREAD_ID_P)) CASE ( CopyFactorsFinished ) LOCAL_ACTION = FREE_WORK_MYID CASE ( CopyNotStarted ) !$OMP ATOMIC READ KEEP8_73 = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC READ KEEP8_71 = KEEP8(71) !$OMP END ATOMIC PeakAuthorized_P = KEEP8(77) MemDispo_P = PeakAuthorized_P - (KEEP8_73 -KEEP8_71) MemDispo_P = min(MemDispo_P, KEEP8(75)-KEEP8_73) MemNeeded_P = MUMPS_TPS_ARR(THREAD_ID_P)%LA - & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS MemNeededForCB_P = MemNeeded_P - & ( MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC - 1_8 ) IF ( MemDispo_P .GE. MemNeeded_P ) THEN !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + MemNeeded_P KEEP8_73 = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC READ KEEP8_71 = KEEP8(71) !$OMP END ATOMIC MemDispo_P = PeakAuthorized_P - (KEEP8_73 -KEEP8_71) MemDispo_P = min(MemDispo_P, KEEP8(75)-KEEP8_73) IF ( MemDispo_P .LT. 0 ) THEN !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - MemNeeded_P !$OMP END ATOMIC IF ( STATE(THREAD_ID_P) .NE. WaitMem ) THEN STATE( THREAD_ID_P ) = WaitMem NbWaitMem = NbWaitMem + 1 ENDIF ELSE !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP8_73 ) !$OMP END ATOMIC IF ( STATE( THREAD_ID_P ) .EQ. WaitMem ) THEN NbWaitMem = NbWaitMem - 1 ENDIF STATE( THREAD_ID_P ) = AllocateViderCBEnCours LOCAL_ACTION = AllocateViderCB NbOngoingCopies = NbOnGoingCopies + 1 ENDIF ELSE IF ( STATE(THREAD_ID_P) .NE. WaitMem ) THEN STATE( THREAD_ID_P ) = WaitMem NbWaitMem = NbWaitMem + 1 ENDIF ENDIF CASE DEFAULT ITH = -1 DO K = THREAD_ID_P, THREAD_ID_P + KEEP(400) - 1 IF ( K > KEEP(400) ) THEN ITH = K - KEEP(400) ELSE ITH = K ENDIF IF ( STATE(ITH) .GE. 0 .AND. & STATE(ITH) .LT. MUMPS_TPS_ARR(ITH)%POSFAC - 1_8 ) THEN EXIT ELSE ITH = -1 ENDIF ENDDO IF ( ITH .GT. 0 ) THEN LOCAL_ACTION = COPY_FACTORS COPY_START = STATE(ITH) + 1 CHUNK8 = max( & & int(KEEP(361),8), & & (MUMPS_TPS_ARR(ITH)%POSFAC+KEEP(400)-2_8) / & (int(KEEP(400)*2,8)) & & ) IF (KEEP(72) .EQ. 1) THEN CHUNK8 = 4_8 ENDIF CHUNK8 = min( CHUNK8, & MUMPS_TPS_ARR(ITH)%POSFAC - 1_8 - COPY_START + 1_8 & ) STATE(ITH) = STATE(ITH) + CHUNK8 ENDIF END SELECT ENDIF !$OMP END CRITICAL(L0_COPIES) SELECT CASE ( LOCAL_ACTION ) CASE ( FREE_WORK_MYID ) IF ( associated(DMUMPS_TPS_ARR(THREAD_ID_P)%A) ) THEN CALL DMUMPS_DM_FREE_S_WK( & DMUMPS_TPS_ARR(THREAD_ID_P)%A, & KEEP(430) ) NULLIFY(DMUMPS_TPS_ARR(THREAD_ID_P)%A) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -MUMPS_TPS_ARR(THREAD_ID_P)%LA, & KEEP(405).EQ.1, & KEEP8, & INFO_P(1), INFO_P(2), & .FALSE., .FALSE. ) IF (INFO_P(1) .GE. 0) THEN !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - L0_OMP_FACTORS(THREAD_ID_P)%LA !$OMP END ATOMIC !$OMP CRITICAL(L0_COPIES) DO ITH = 1, KEEP(400) IF ( STATE(ITH) .EQ. WaitMem ) THEN STATE(ITH)=CopyNotStarted ENDIF ENDDO NbWaitMem = 0 NbFinished = NbFinished + 1 STATE( THREAD_ID_P ) = Finished NbOnGoingCopies = NbOnGoingCopies -1 !$OMP END CRITICAL(L0_COPIES) ENDIF ENDIF CASE ( AllocateViderCB ) TO_ALLOCATE = max(MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8,1_8) ALLOCATE( L0_OMP_FACTORS(THREAD_ID_P)%A(TO_ALLOCATE), & stat=allocok ) IF ( allocok .GT. 0 ) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4(TO_ALLOCATE, INFO_P(2)) L0_OMP_FACTORS(THREAD_ID_P)%LA = 0_8 !$OMP CRITICAL(L0_COPIES) !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - MemNeeded_P !$OMP END ATOMIC STATE(THREAD_ID_P) = Finished NbFinished = NbFinished + 1 !$OMP END CRITICAL(L0_COPIES) ELSE L0_OMP_FACTORS(THREAD_ID_P)%LA = & MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8 !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) + L0_OMP_FACTORS(THREAD_ID_P)%LA !$OMP END ATOMIC !$OMP CRITICAL(L0_COPIES) IF ( MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8 == 0_8 ) THEN STATE(THREAD_ID_P) = CopyFactorsFinished ELSE STATE ( THREAD_ID_P ) = 0 SIZE_COPIED( THREAD_ID_P ) = 0 ENDIF !$OMP END CRITICAL(L0_COPIES) LRLUS_SAVE_P = MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS CALL DMUMPS_DM_CBSTATIC2DYNAMIC_I & (3, & 0_8, & .FALSE., & MYID_NODES, N, SLAVEF, KEEP, KEEP8, & MUMPS_TPS_ARR(THREAD_ID_P)%IW(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LIW, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOSCB, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOS, & DMUMPS_TPS_ARR(THREAD_ID_P)%A(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LA, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%IPTRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & INFO_P(1), INFO_P(2) ) CBCopiedToDynamic_P = & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS - LRLUS_SAVE_P IF (INFO_P(1) .LT. 0 ) THEN !$OMP CRITICAL(L0_COPIES) !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - & ( MemNeededForCB_P - CBCopiedToDynamic_P ) !$OMP END ATOMIC STATE(THREAD_ID_P) = Finished NbFinished = NbFinished+1 !$OMP END CRITICAL(L0_COPIES) ELSE ENDIF ENDIF CASE ( COPY_FACTORS ) DO I8 = COPY_START, COPY_START + CHUNK8 - 1 L0_OMP_FACTORS(ITH)%A(I8) = DMUMPS_TPS_ARR(ITH)%A(I8) ENDDO !$OMP CRITICAL(L0_COPIES) SIZE_COPIED(ITH) = SIZE_COPIED(ITH) + CHUNK8 IF ( SIZE_COPIED(ITH) .EQ. L0_OMP_FACTORS(ITH)%LA ) THEN STATE(ITH) = CopyFactorsFinished ENDIF !$OMP END CRITICAL(L0_COPIES) CASE ( NOTHING ) CASE ( DORMIR ) CALL MUMPS_USLEEP(1000) CASE DEFAULT WRITE(*,*) " Internal error in DMUMPS_PERFORM_COPIES", & LOCAL_ACTION END SELECT ENDDO RETURN END SUBROUTINE DMUMPS_PERFORM_COPIES END MODULE DMUMPS_FAC_OMP_M RECURSIVE SUBROUTINE DMUMPS_PROCESS_FRONT_NIV1( COMM_LOAD, & ASS_IRECV, N, INODE, TYPE, TYPEF, LA, IW, LIW, A, & MAXFRW, NOFFNEGW, NULLNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INFO_P, UU, SEUIL, SEUIL_LDLT_NIV2, & OPELIW, NELVAW, NMAXNPIVW, NSTEPSW, PTRIST, PTLUST_S, & PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, NE, POSFAC, & LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP, KEEP8, DKEEP, & PIVNUL_LIST_STRUCT, COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, & SLAVEF, IFATH, COMM_NODES, MYID_NODES, IPOOL_P, & LPOOL_P, LEAF, PERM, NSTK_STEPS, BUFR, LBUFR, & LBUFR_BYTES, NBFIN, root, roota, OPASSW, ITLOC, RHS_MUMPS, FILS, & PTRARW, PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, DAD, LPTRAR, NELT, & FRTPTR, FRTELT, ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS, & FLOP_ESTIM_ACC ) USE DMUMPS_FAC_ASM_MASTER_M USE DMUMPS_FAC_ASM_MASTER_ELT_M USE DMUMPS_FAC1_LU_M USE DMUMPS_FAC1_LDLT_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER COMM_NODES, MYID_NODES, TYPE, TYPEF INTEGER N, LIW, INODE,INFO_P(2) INTEGER ICNTL(60), KEEP(500) DOUBLE PRECISION DKEEP(230) DOUBLE PRECISION UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER(8) KEEP8(150) INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU INTEGER IWPOSCB, IWPOS, & IFATH, SLAVEF, NELVAW, NMAXNPIVW, NSTEPSW INTEGER IW(LIW),PROCNODE_STEPS(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NE(KEEP(28)) DOUBLE PRECISION A(LA) INTEGER :: MAXFRW, NOFFNEGW, NULLNEGW, NPVW, NBTINYW INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER LEAF, COMP INTEGER :: NB22T1W, DET_EXPW, DET_SIGNW DOUBLE PRECISION :: DET_MANTW INTEGER PERM( N ) INTEGER NSTK_STEPS( KEEP(28) ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER NBFIN TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION FLOP_ESTIM_ACC INTEGER, INTENT(IN) :: LPOOL_P INTEGER, INTENT(IN) :: IPOOL_P(LPOOL_P) INTEGER :: IOLDPS, JOBASS, ETATASS INTEGER(8) :: POSELT LOGICAL :: AVOID_DELAYED, SON_LEVEL2 JOBASS = 0 ETATASS = 0 IF ( KEEP(55) .EQ. 0 ) THEN JOBASS = 0 CALL DMUMPS_FAC_ASM_NIV1( COMM_LOAD, ASS_IRECV, UU, & N, INODE, & IW, LIW, A, LA, INFO_P, ND, FILS, FRERE, DAD, MAXFRW, & root, roota, OPASSW, OPELIW, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & PTRARW, PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSW, & SON_LEVEL2,COMP, LRLU, IPTRLU, & IWPOS, IWPOSCB, POSFAC, & LRLUS, LRLUSM, ICNTL, KEEP, KEEP8, DKEEP, & INTARR, KEEP8(27), DBLARR, KEEP8(26), & NSTK_STEPS, PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL_P, & LPOOL_P, LEAF, PERM, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & JOBASS, ETATASS & , LRGROUPS & ) ELSE CALL DMUMPS_FAC_ASM_NIV1_ELT(COMM_LOAD,ASS_IRECV,UU, & NELT,FRTPTR, & FRTELT, N, INODE, IW, LIW, A, & LA, INFO_P, ND, FILS, FRERE, DAD, MAXFRW, & root, roota, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSW, SON_LEVEL2, COMP, LRLU, & IPTRLU, IWPOS, IWPOSCB, & POSFAC, LRLUS, LRLUSM, ICNTL, KEEP, KEEP8, DKEEP, & INTARR, KEEP8(27), DBLARR, KEEP8(26), & NSTK_STEPS, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, NBFIN, & IPOOL_P, LPOOL_P, LEAF, PERM, ISTEP_TO_INIV2, & TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF IF (INFO_P(1) .LT. 0) THEN RETURN ENDIF AVOID_DELAYED = ( ( IFATH .EQ. KEEP(20) & .OR. & IFATH .EQ. KEEP(38) ) & .AND. & ( KEEP(60) .NE. 0 ) ) POSELT = PTRAST(STEP(INODE)) IOLDPS = PTLUST_S(STEP(INODE)) IF ( KEEP(50) .EQ. 0 ) THEN CALL DMUMPS_FAC1_LU( N, INODE, & IW, LIW, & A, LA, IOLDPS, & POSELT, & INFO_P(1), INFO_P(2), UU, NOFFNEGW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) ELSE IW( IOLDPS + 4 + KEEP(IXSZ) ) = 1 CALL DMUMPS_FAC1_LDLT( N, INODE, & IW, LIW, A, & LA, & IOLDPS, POSELT, & INFO_P(1), INFO_P(2), UU, NOFFNEGW, NULLNEGW, NPVW, & NB22T1W, NBTINYW, DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, MYID_NODES, SEUIL, & AVOID_DELAYED, & ETATASS, & DKEEP(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IW(IOLDPS + 4 + KEEP(IXSZ)) = STEP(INODE) ENDIF IF (INFO_P(1) .LT. 0) THEN RETURN ENDIF CALL DMUMPS_FAC_STACK( COMM_LOAD, ASS_IRECV, N, INODE, TYPE, &TYPEF, LA, IW, LIW, A, &INFO_P(1), INFO_P(2), OPELIW, NELVAW, NMAXNPIVW, PTRIST, PTLUST_S, &PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, NE, POSFAC, &LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP, &KEEP8, DKEEP, &COMP,IWPOS, IWPOSCB, PROCNODE_STEPS, &SLAVEF, IFATH, COMM_NODES, MYID_NODES, IPOOL_P, &LPOOL_P, LEAF, NSTK_STEPS, PERM, BUFR, LBUFR, &LBUFR_BYTES, NBFIN, root, roota, OPASSW, ITLOC, RHS_MUMPS, &FILS, DAD, PTRARW, PTRAIW, &PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, &INTARR, DBLARR, ND, FRERE, &LPTRAR, NELT, FRTPTR, FRTELT, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS, & FLOP_ESTIM_ACC &) RETURN END SUBROUTINE DMUMPS_PROCESS_FRONT_NIV1 MUMPS_5.8.1/src/dfac_asm_master_m.F0000664000175000017500000022555115042446440016775 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_ASM_MASTER_M CONTAINS SUBROUTINE DMUMPS_FAC_ASM_NIV1( COMM_LOAD, ASS_IRECV, & UU, N, INODE, IW, LIW, A, LA, INFO, ND, & FILS, FRERE, DAD, MAXFRW, root, roota, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, LRLUSM, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, JOBASS, ETATASS & , LRGROUPS & , MUMPS_TPS_ARR, DMUMPS_TPS_ARR, L0_OMP_MAPPING & ) !$ USE OMP_LIB USE MUMPS_TPS_M USE DMUMPS_TPS_M USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_PTR, & DMUMPS_DM_FREE_BLOCK USE MUMPS_BUILD_SORT_INDEX_M USE MUMPS_BUF_COMMON, ONLY: MUMPS_BUF_SEND_MAPLIG USE MUMPS_LOAD USE DMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE, & DMUMPS_BLR_ASM_NIV1 USE DMUMPS_LR_DATA_M, ONLY : DMUMPS_BLR_INIT_FRONT, & DMUMPS_BLR_SAVE_NFS4FATHER USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N, NSTEPS INTEGER(8) LA, LRLU, LRLUS, LRLUSM, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) DOUBLE PRECISION UU INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS, LIW TYPE (MUMPS_TPS_T), TARGET, OPTIONAL :: MUMPS_TPS_ARR(:) TYPE (DMUMPS_TPS_T), TARGET, OPTIONAL :: DMUMPS_TPS_ARR(:) INTEGER, INTENT(IN), OPTIONAL :: L0_OMP_MAPPING(:) INTEGER IDUMMY(1) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER, TARGET :: IW(LIW) INTEGER(8), INTENT(IN) :: PTRARW(1), PTRAIW(1) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ITLOC(N+KEEP(253)), & ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)), & PAMASTER(KEEP(28)) INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER JOBASS,ETATASS LOGICAL SON_LEVEL2 DOUBLE PRECISION, TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR DOUBLE PRECISION DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) LOGICAL PACKED_CB, IS_CB_LR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF LOGICAL LPOK INTEGER NBPANELS_L, NBPANELS_U INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER(8) NFRONT8, LAELL8, LAELL_REQ8, ITMP8, KEEP8TMPCOPY INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER LREQ_OOC INTEGER :: SON_XXS, SON_XXLR, SON_XXG INTEGER(8) LSTK8, SIZFR8 LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM, IORG, IBROT INTEGER IARR1 #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER JPOS,ICT11 INTEGER IJROW,NBCOL,NUMORG,IOLDPS INTEGER(8) IACHK, POSELT, LAPOS2, IACHK_ini INTEGER(8) APOS, APOS2, APOS3, POSEL1, ICT12 INTEGER(8) :: JJ2, ICT13 INTEGER(8) :: J18, J28, J38, J48, JJ8 INTEGER(8) :: AINPUT8 INTEGER :: K1, K2, K3, KK, KK1 INTEGER :: J253 INTEGER NSLAVES, NSLSON, NPIVS,NPIV_ANA,NPIV INTEGER PTRCOL, ISLAVE, PDEST,LEVEL INTEGER ISON_IN_PLACE LOGICAL SKIP_TOP_STACK INTEGER ISON_TOP INTEGER(8) SIZE_ISON_TOP8, DYN_SIZE_ISON_TOP8 LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE !$ LOGICAL OMP_PARALLEL_FLAG LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE INTEGER INDX, FIRST_INDEX, SHIFT_INDEX INTEGER PARPIV_T1 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: ITHREAD INTEGER, POINTER :: SON_IWPOS, SON_LIW INTEGER, POINTER, DIMENSION(:) :: SON_IW DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTEGER PIVOT_OPTION DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER NELT, LPTRAR EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR LOGICAL SSARBR DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR !$ NOMP = OMP_GET_MAX_THREADS() LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) NELT = 1 LPTRAR = 1 NFS4FATHER = -1 PACKED_CB = .FALSE. IS_CB_LR = .FALSE. IN = INODE LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (LEVEL.NE.1) THEN WRITE(*,*) 'INTERNAL ERROR 1 in DMUMPS_FAC_ASM_NIV1 ' CALL MUMPS_ABORT() END IF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) IF (JOBASS.EQ.0) THEN ETATASS= 0 ELSE ETATASS= 2 IOLDPS = PTLUST(STEP(INODE)) NFRONT = IW(IOLDPS + KEEP(IXSZ)) NASS1 = abs(IW(IOLDPS + 2 + KEEP(IXSZ))) ICT11 = IOLDPS + HF - 1 + NFRONT SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 ISON = FRERE(STEP(ISON)) ENDDO ENDIF GOTO 123 ENDIF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) END DO NPIV_ANA=NUMORG NSTEPS = NSTEPS + 1 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 SON_IW => IW IF (KEEP(400).GT.0) THEN IF (present(L0_OMP_MAPPING)) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .NE.0) THEN SON_IW=>MUMPS_TPS_ARR(ITHREAD)%IW ENDIF ENDIF ENDIF NASS = NASS + SON_IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG CALL IS_FRONT_BLR_CANDIDATE(INODE, 1, ND(STEP(INODE)), & NUMORG, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, KEEP(280), LRGROUPS) IF (DAD(STEP(INODE)).NE.0) THEN IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199) ) & .NE. MYID & .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199)) & .EQ.1 & ) THEN IF (LRSTATUS.EQ.1 .OR. LRSTATUS.EQ.3) THEN LRSTATUS = LRSTATUS-1 ENDIF ENDIF ENDIF COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_OOC_GET_PP_SIZES(KEEP(50), NFRONT, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL DMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, SLAVEF, & PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'INTERNAL ERROR 2 after compress ' WRITE(LP, * ) 'IN DMUMPS_FAC_ASM_NIV1 ' WRITE(LP, * ) 'LRLU,LRLUS=', LRLU,LRLUS ENDIF GOTO 270 END IF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 END IF IOLDPS = IWPOS IWPOS = IWPOS + LREQ ISON_TOP = -9999 ISON_IN_PLACE = -9999 SIZE_ISON_TOP8 = 0_8 IF (KEEP(234).NE.0) THEN IF ( IWPOSCB .NE. LIW ) THEN IF ( IWPOSCB+IW(IWPOSCB+1+XXI).NE.LIW) THEN ISON = IW( IWPOSCB + 1 + XXN ) IF ( DAD( STEP( ISON ) ) .EQ. INODE .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)),KEEP(199)) & .EQ. 1 ) & THEN ISON_TOP = ISON CALL MUMPS_GETI8(SIZE_ISON_TOP8,IW(IWPOSCB + 1 + XXR)) CALL MUMPS_GETI8(DYN_SIZE_ISON_TOP8, IW(IWPOSCB + 1 + XXD)) IF (DYN_SIZE_ISON_TOP8 .EQ. 0_8) THEN IF (LRLU .LT. int(NFRONT,8) * int(NFRONT,8)) THEN ISON_IN_PLACE = ISON ENDIF ENDIF END IF END IF END IF END IF NIV1 = .TRUE. IF (.NOT. present(MUMPS_TPS_ARR).AND. & .NOT. present(L0_OMP_MAPPING) ) THEN CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP, KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, IDUMMY, LIDUMMY ) ELSE CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP, KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, IDUMMY, LIDUMMY & , MUMPS_TPS_ARR, L0_OMP_MAPPING ) ENDIF IF (INFO(1).LT.0) GOTO 300 IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL MUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1-FLOP1_EFF, & KEEP,KEEP8) ENDIF IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) ' INTERNAL ERROR 3 ', & ' IN DMUMPS_FAC_ASM_NIV1 ', & ' NFRONT, NFRONT_EFF = ', & NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF NCB = NFRONT - NASS1 MAXFRW = max(MAXFRW, NFRONT) ICT11 = IOLDPS + HF - 1 + NFRONT CALL DMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) PIVOT_OPTION = KEEP(468) IF (UU.EQ.ZERO) THEN PIVOT_OPTION=0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF(PARPIV_T1.NE.0) THEN LAELL8 = LAELL8+int(NASS1,8) ENDIF LAELL_REQ8 = LAELL8 IF ( ISON_IN_PLACE > 0 ) THEN LAELL_REQ8 = LAELL8 - SIZE_ISON_TOP8 ENDIF SKIP_TOP_STACK = (ISON_IN_PLACE.GT.0) CALL DMUMPS_GET_SIZE_NEEDED & (0, LAELL_REQ8, SKIP_TOP_STACK, & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 LRLUSM = min( LRLUS, LRLUSM ) ITMP8 = LAELL8 - SIZE_ISON_TOP8 IF (KEEP(405).EQ.0) THEN KEEP8(69) = KEEP8(69) + ITMP8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + ITMP8 KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ENDIF POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8-SIZE_ISON_TOP8, & KEEP,KEEP8, & LRLUS) IF (KEEP(405).EQ.0) KEEP(429)= KEEP(429)+1 #if defined(ZERO_TRIANGLE) LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) !$ CHUNK8=int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (LAPOS2 - POSELT + 1_8 > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8), KEEP(218))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & NCB, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1,TOPDIAG) ENDIF IF (ETATASS.EQ.1) THEN IF (KEEP(234).NE.0) THEN WRITE(*,*) & "Internal error: ETATASS.EQ.1 and IN-PLACE ACTIVATED" CALL MUMPS_ABORT() ENDIF #if defined(__ve__) !NEC$ IVDEP #endif !$ CHUNK = max( KEEP(360)/2, (NFRONT+NOMP-1) / NOMP ) !$OMP PARALLEL DO PRIVATE(APOS, JJ3) SCHEDULE( STATIC, CHUNK ) !$OMP& IF (NFRONT8 - 1_8 > KEEP(360)) DO JJ8 = 0_8, NFRONT8 - 1_8 JJ3 = min(JJ8+TOPDIAG,int(NASS1-1,8)) APOS = POSELT + JJ8 * NFRONT8 A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO ELSE NUMROWS = min(NFRONT8, (IPTRLU-POSELT) / NFRONT8 ) !$ CHUNK = max(KEEP(360)/2, !$ & ( ((int(NUMROWS)+NOMP-1) / NOMP + 2) / 3) ) #if defined(__ve__) !NEC$ IVDEP #endif !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK ) !$OMP& IF (int(NUMROWS - 1) .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = POSELT + JJ8 * NFRONT8 JJ3 = min( NFRONT8 - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS + JJ3) = ZERO ENDDO !$OMP END PARALLEL DO IF( NUMROWS .LT. NFRONT8 ) THEN APOS = POSELT + NFRONT8*NUMROWS A(APOS : min(IPTRLU,APOS+NUMROWS)) = ZERO ENDIF ENDIF END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS IW(IOLDPS + KEEP(IXSZ)) = NFRONT IW(IOLDPS + KEEP(IXSZ)+ 1) = 0 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN CALL DMUMPS_BLR_INIT_FRONT (IW(IOLDPS+XXF), INFO, & MTK405=KEEP(405)) IF (INFO(1).LT.0) GOTO 500 ENDIF ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL DMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) CALL DMUMPS_BLR_SAVE_NFS4FATHER ( IW(IOLDPS+XXF), & ESTIM_NFS4FATHER_ATSON ) IF (INFO(1).LT.0) GOTO 500 ENDIF ENDIF ENDIF 123 CONTINUE IF (NUMSTK.NE.0) THEN IF (ISON_TOP > 0) THEN ISON = ISON_TOP ELSE ISON = IFSON ENDIF DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_LIW => LIW SON_IWPOS => IWPOS SON_A => A ITHREAD = 0 IF (KEEP(400).GT.0) THEN IF (present(L0_OMP_MAPPING)) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .NE.0) THEN SON_LIW => MUMPS_TPS_ARR(ITHREAD)%LIW SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW SON_IWPOS => MUMPS_TPS_ARR(ITHREAD)%IWPOS SON_A => DMUMPS_TPS_ARR(ITHREAD)%A ENDIF ENDIF ENDIF LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + KEEP(IXSZ) + 1) NPIVS = SON_IW(ISTCHK + KEEP(IXSZ) + 3) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = SON_IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.SON_IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT = PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT = ISTCHK ENDIF SON_XXS = SON_IW(ISTCHK_CB_RIGHT+XXS) SON_XXLR = SON_IW(ISTCHK_CB_RIGHT+XXLR) SON_XXG = SON_IW(ISTCHK_CB_RIGHT+XXG) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IS_CB_LR = ( SON_XXLR.EQ.1 .OR. SON_XXLR.EQ.3 ) & .AND. (KEEP(489).EQ.1.OR.KEEP(489).EQ.3) LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = SON_IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF K1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN K2 = K1 + LSTK - 1 IF (PACKED_CB) THEN SIZFR8 = (LSTK8*(LSTK8+1_8)/2_8) ELSE SIZFR8 = LSTK8*LSTK8 ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * LSTK8 ELSE IF (PACKED_CB) THEN SIZFR8 = int(NELIM,8) * int(NELIM+1,8)/2_8 ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) ENDIF END IF K2 = K1 + NELIM - 1 ENDIF IF (JOBASS.EQ.0) THEN IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + LSTK8*LSTK8 ELSE OPASSW = OPASSW + LSTK8*(LSTK8+1)/2_8 ENDIF ELSE IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + int(NELIM,8)*LSTK8 ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM,8)/2_8 ENDIF ENDIF ENDIF CALL MUMPS_GETI8(DYN_SIZE, SON_IW(ISTCHK_CB_RIGHT+XXD)) IS_DYNAMIC_CB = DYN_SIZE .GT. 0_8 IF ( IS_DYNAMIC_CB ) THEN CALL DMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) ENDIF IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (NFRONT .EQ. LSTK.AND. ISON.EQ.ISON_IN_PLACE & .AND.IACHK + SIZFR8 - 1_8 .EQ. POSFAC - 1_8 ) THEN GOTO 205 ENDIF IF (K2.GE.K1) THEN RESET_TO_ZERO = (IACHK .LT. POSFAC .AND. & ISON.EQ.ISON_IN_PLACE) RISK_OF_SAME_POS = IACHK + SIZFR8 - 1_8 .EQ. POSFAC - 1_8 & .AND. ISON.EQ.ISON_IN_PLACE RISK_OF_SAME_POS_THIS_LINE = .FALSE. IACHK_ini = IACHK !$ OMP_PARALLEL_FLAG = (RESET_TO_ZERO.EQV..FALSE.).AND. !$ & ((K2-K1).GT.KEEP(360)) !$OMP PARALLEL IF(OMP_PARALLEL_FLAG) PRIVATE(APOS, KK1, JJ2,IACHK) !$OMP& FIRSTPRIVATE(RISK_OF_SAME_POS_THIS_LINE,RESET_TO_ZERO) !$OMP DO DO 170 KK = K1, K2 APOS = POSEL1 + int(SON_IW(KK),8) * int(NFRONT,8) IACHK = IACHK_ini + int(KK-K1,8)*int(LSTK,8) IF (RESET_TO_ZERO) THEN IF (RISK_OF_SAME_POS) THEN IF (KK.EQ.K2) THEN RISK_OF_SAME_POS_THIS_LINE = & (ISON .EQ. ISON_IN_PLACE) & .AND. ( APOS + int(SON_IW(K1+LSTK-1)-1,8).EQ. & IACHK+int(LSTK-1,8) ) ENDIF ENDIF IF ((IACHK .GE. POSFAC).AND.(KK>K1))THEN RESET_TO_ZERO =.FALSE. ENDIF IF (RISK_OF_SAME_POS_THIS_LINE) THEN DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1 + KK1 - 1) - 1,8) IF ( IACHK+int(KK1-1,8) .NE. JJ2 ) THEN A(JJ2) = A(IACHK + int(KK1 - 1,8)) A(IACHK + int(KK1 -1,8)) = ZERO ENDIF ENDDO ELSE #if defined(__ve__) !NEC$ IVDEP #endif DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(IACHK + int(KK1 - 1,8)) A(IACHK + int(KK1 -1,8)) = ZERO ENDDO ENDIF ELSE #if defined(__ve__) !NEC$ IVDEP #endif DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) ENDDO ENDIF 170 CONTINUE !$OMP END DO !$OMP END PARALLEL END IF ELSE IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (ISON .EQ. ISON_IN_PLACE) THEN CALL DMUMPS_LDLT_ASM_NIV12_IP(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB) ELSE IF (SIZFR8 .GT. 0) THEN CALL DMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF ENDIF IF (IS_CB_LR .AND. LEVEL1) THEN POSEL1 = PTRAST(STEP(INODE)) CALL DMUMPS_BLR_ASM_NIV1 (A, LA, & POSEL1, NFRONT, NASS1, SON_IW(ISTCHK+XXF), & SON_IW, SON_LIW, & LSTK, NELIM, K1, K1+LSTK-1, KEEP(50), & KEEP, KEEP8, OPASSW) ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF ((SAME_PROC).AND.ETATASS.NE.1) THEN IF (KEEP(50).NE.0) THEN K2 = K1 + LSTK - 1 #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K1, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO ELSE K2 = K1 + LSTK - 1 K3 = K1 + NELIM #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K3, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO IF (NELIM .NE. 0) THEN K3 = K3 - 1 #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K1, K3 JPOS = SON_IW(KK) + ICT11 SON_IW(KK) = IW(JPOS) ENDDO ENDIF ENDIF ENDIF IF (ETATASS.NE.1) THEN IF ( SAME_PROC ) THEN PTRIST(STEP(ISON)) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF IF (ITHREAD .EQ. 0) THEN CALL DMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & (ISON .EQ. ISON_TOP) & ) ELSE CALL MUMPS_LOAD_DISABLE() CALL DMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & MUMPS_TPS_ARR(ITHREAD)%IW(1), & MUMPS_TPS_ARR(ITHREAD)%LIW, & MUMPS_TPS_ARR(ITHREAD)%LRLU, & MUMPS_TPS_ARR(ITHREAD)%LRLUS, & MUMPS_TPS_ARR(ITHREAD)%IPTRLU, & MUMPS_TPS_ARR(ITHREAD)%IWPOSCB, & MUMPS_TPS_ARR(ITHREAD)%LA, KEEP,KEEP8, .FALSE. & ) CALL MUMPS_LOAD_ENABLE() ENDIF IF (IS_DYNAMIC_CB) THEN CALL DMUMPS_DM_FREE_BLOCK(SON_XXG, & SON_A, SIZFR8, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF ELSE PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP, KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL DMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, IDUMMY, & NFRONT, NASS1, NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & IZERO, IDUMMY, IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP, KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE., LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) IF (ISON .LE. 0) THEN ISON = IFSON ENDIF 220 CONTINUE END IF IF (ETATASS.EQ.2) GOTO 500 POSELT = PTRAST(STEP(INODE)) IBROT = INODE IARR1 = PTRDEBARR(STEP(INODE)) DO 260 IORG = 1, NUMORG AINPUT8 = PTR8ARR(IARR1+IORG-1) J18 = AINPUT8 J28 = J18 + NINCOLARR(IARR1+IORG-1) J38 = J28 + 1 J48 = J28 + NINROWARR(IARR1+IORG-1) IJROW = INTARR(J18) ICT12 = POSELT + int(IJROW - NFRONT - 1,8) #if defined(__ve__) IF ( KEEP(265).NE. 0 ) THEN !NEC$ IVDEP #endif DO JJ8 = J18, J28 APOS2 = ICT12 + int(INTARR(JJ8),8) * NFRONT8 A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + 1_8 ENDDO #if defined(__ve__) ELSE DO JJ8 = J18, J28 APOS2 = ICT12 + int(INTARR(JJ8),8) * NFRONT8 A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + 1_8 ENDDO ENDIF #endif IF (J38 .LE. J48) THEN ICT13 = POSELT + int(IJROW - 1,8) * NFRONT8 NBCOL = int(J48 - J38 + 1_8) #if defined(__ve__) IF ( KEEP(265) .NE. 0 ) THEN !NEC$ IVDEP #endif DO JJ8 = 1_8, int(NBCOL,8) APOS3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8) - 1_8,8) A(APOS3) = A(APOS3) + DBLARR(AINPUT8 + JJ8 - 1_8) ENDDO #if defined(__ve__) ELSE DO JJ8 = 1_8, int(NBCOL,8) APOS3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8) - 1_8,8) A(APOS3) = A(APOS3) + DBLARR(AINPUT8 + JJ8 - 1_8) ENDDO ENDIF #endif ENDIF IF (KEEP(50).EQ.0) THEN DO J253=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ELSE DO J253=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+J253-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE IF (PARPIV_T1.NE.0.AND.(.NOT.SON_LEVEL2)) THEN IOLDPS = PTLUST(STEP(INODE)) CALL DMUMPS_PARPIVT1_SET_NVSCHUR_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1, NASS) ENDIF GOTO 500 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING DMUMPS_FAC_ASM' ENDIF GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING DMUMPS_FAC_ASM' ENDIF INFO(1) = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, RECV BUFFER TOO SMALL DURING DMUMPS_FAC_ASM' ENDIF INFO(1) = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF( INFO(1).EQ.-13 ) THEN IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING DMUMPS_FAC_ASM' ENDIF INFO(2) = NUMSTK + 1 ENDIF 490 CONTINUE IF ( KEEP(405) .EQ. 0 ) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_ASM_NIV1 SUBROUTINE DMUMPS_FAC_ASM_NIV2(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, INFO, & ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, roota, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, MEM_DISTRIB & , LRGROUPS & ) !$ USE OMP_LIB USE MUMPS_BUILD_SORT_INDEX_M USE MUMPS_BUF_COMMON, ONLY: MUMPS_BUF_SEND_MAPLIG, & MUMPS_BUF_SEND_DESC_BANDE USE MUMPS_LOAD USE DMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_PTR, & DMUMPS_DM_IS_DYNAMIC USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC, LA INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE, MAXFRW, LPOOL, LEAF, & IWPOS, IWPOSCB, COMP, SLAVEF DOUBLE PRECISION, TARGET :: A(LA) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(1), PTRAIW(1) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PROCNODE_STEPS(KEEP(28)), BUFR(LBUFR) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR DOUBLE PRECISION DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INTEGER LP, HS, HF, HF_OLD, NCBSON, NSLAVES_OLD LOGICAL LPOK INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL DOUBLE PRECISION, DIMENSION(:), POINTER :: SON_A INTEGER :: MAXWASTEDPROCS PARAMETER (MAXWASTEDPROCS=1) INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER I INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER :: SON_XXS INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL PACKED_CB, IS_CB_LR INTEGER(8) :: LCB LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER MP INTEGER :: K1, K2, KK, KK1 INTEGER :: J253 INTEGER(8) :: AINPUT8, J18, J28, J38, J48, JJ8 INTEGER(8) :: LAPOS2, JJ2, JJ3 INTEGER(8) :: ICT13 INTEGER(8) :: IACHK, APOS, APOS2, POSELT, ICT12, POSEL1 #if ! defined(ZERO_TRIANGLE) INTEGER :: TOPDIAG #endif !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM,NPIVS,NCOLS,NROWS, & IORG INTEGER LDAFS, LDA_SON, IJROW, IBROT INTEGER IARR1 INTEGER NBCOL,NUMORG,IOLDPS, NUMORG_SPLIT INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, PDEST INTEGER PDEST1(1) INTEGER :: ISLAVE INTEGER TYPESPLIT INTEGER ISON_IN_PLACE LOGICAL IS_ofType5or6, SPLIT_MAP_RESTART INTEGER NMB_OF_CAND, NMB_OF_CAND_ORIG LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER IZERO INTEGER IDUMMY(1) PARAMETER( IZERO = 0 ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT DOUBLE PRECISION ZERO DOUBLE PRECISION RZERO PARAMETER( RZERO = 0.0D0 ) PARAMETER( ZERO = 0.0D0 ) INTEGER NELT, LPTRAR logical :: force_cand INTEGER ETATASS INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX DOUBLE PRECISION MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER, ALLOCATABLE, DIMENSION(:) :: SONROWS_PER_ROW INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IS_ofType5or6 = .FALSE. PACKED_CB = .FALSE. ETATASS = 0 IN = INODE NSTEPS = NSTEPS + 1 KEEP(429) = KEEP(429)+1 NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON NCBSON_MAX = 0 NELT = 1 LPTRAR = 1 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 IF ( KEEP(48)==5 .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) ENDIF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 CALL IS_FRONT_BLR_CANDIDATE(INODE, 2, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, KEEP(280), LRGROUPS) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then force_cand=.FALSE. ELSE force_cand=(mod(KEEP(24),2).eq.0) end if TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) SPLIT_MAP_RESTART = .FALSE. IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) NMB_OF_CAND = CAND( SLAVEF+1, INIV2 ) NMB_OF_CAND_ORIG = NMB_OF_CAND SIZE_TMP_SLAVES_LIST = NMB_OF_CAND IF (IS_ofType5or6) THEN DO I=NMB_OF_CAND+1,SLAVEF IF ( CAND( I, INIV2 ).LT.0) EXIT NMB_OF_CAND = NMB_OF_CAND +1 ENDDO SIZE_TMP_SLAVES_LIST = NSLSON-1 IF (INODE.EQ.-999999) THEN SPLIT_MAP_RESTART = .TRUE. ENDIF ENDIF IF (IS_ofType5or6.AND.SPLIT_MAP_RESTART) THEN TYPESPLIT = 4 IS_ofType5or6 = .FALSE. SIZE_TMP_SLAVES_LIST = NMB_OF_CAND CAND (SLAVEF+1, INIV2) = SIZE_TMP_SLAVES_LIST ENDIF ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 NMB_OF_CAND = SLAVEF - 1 NMB_OF_CAND_ORIG = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF IF ( (TYPESPLIT.EQ.4) & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) & ) THEN IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) IF (SPLIT_MAP_RESTART) THEN IS_ofType5or6 = .TRUE. TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) CAND( SLAVEF+1, INIV2 ) = NMB_OF_CAND_ORIG ENDIF ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) IF (KEEP(376) .EQ. 1) THEN NFRONT = IW( PIMASTER(STEP(IFSON)) + KEEP(IXSZ)) ENDIF CALL MUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND(1,INIV2), NMB_OF_CAND_ORIG, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES, & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST & ) ENDIF ELSE CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_OOC_GET_PP_SIZES(KEEP(50), NASS1, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL DMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & LRLUS,KEEP(IXSZ), & COMP, DKEEP(97), MYID, SLAVEF, & PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress DMUMPS_FAC_ASM_NIV2 ', & 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. ALLOCATE(SONROWS_PER_ROW(NFRONT-NASS1), stat=allocok) IF (allocok > 0) THEN GOTO 275 ENDIF ISON_IN_PLACE = -9999 CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP,KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, SONROWS_PER_ROW, & NFRONT-NASS1 ) IF (INFO(1).LT.0) GOTO 250 IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN WRITE(*,*) ' Internal error 1 in fac_ass due to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF WRITE(*,*) ' SPLITTING NOT YET READY FOR THAT' CALL MUMPS_ABORT() ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN NCB = NFRONT_EFF - NASS1 NSLAVES_OLD = NSLAVES HF_OLD = HF IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP, KEEP8, ICNTL, & CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - & (NSLAVES_OLD - NSLAVES) IF (NSLAVES_OLD .NE. NSLAVES) THEN IF (NSLAVES_OLD > NSLAVES) THEN DO KK=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+KK)=IW(IOLDPS+HF_OLD+KK) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO KK=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+KK) = IW(IOLDPS+HF_OLD+KK) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) MYID,': INTERNAL ERROR 2 ', & ' IN DMUMPS_FAC_ASM_NIV2 , INODE=', & INODE, ' NFRONT, NFRONT_EFF=', NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max(MAXFRW, NFRONT) PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+KEEP(IXSZ)) = NFRONT IW(IOLDPS + 1+KEEP(IXSZ)) = 0 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+NSLAVES+KEEP(IXSZ))= & TMP_SLAVES_LIST(1:NSLAVES) ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL DMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) ENDIF ENDIF ENDIF CALL MUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM_LOAD, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP, KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) IF(KEEP(86).EQ.1)THEN IF(mod(KEEP(24),2).eq.0)THEN CALL MUMPS_LOAD_SEND_MD_INFO(SLAVEF, & CAND(SLAVEF+1,INIV2), & CAND(1,INIV2), & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN CALL MUMPS_LOAD_SEND_MD_INFO(SLAVEF, & SLAVEF-1, & TMP_SLAVES_LIST, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ENDIF ENDIF DEALLOCATE(TMP_SLAVES_LIST) IF (KEEP(50).EQ.0) THEN LAELL8 = int(NASS1,8) * int(NFRONT,8) LDAFS = NFRONT ELSE LAELL8 = int(NASS1,8)*int(NASS1,8) IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) & LAELL8 = LAELL8+int(NASS1,8) LDAFS = NASS1 ENDIF CALL DMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= LRSTATUS IW(IOLDPS+XXG) = MemNotPinned CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8,LRLUS) POSEL1 = POSELT - int(LDAFS,8) #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8 = int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (LAPOS2 - POSELT > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO JJ8 = POSELT, LAPOS2 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max(KEEP(360)/2, !$ & ( (( LDAFS + NOMP -1 ) / NOMP + 2) / 3) ) APOS = POSELT #if defined(__ve__) !NEC$ IVDEP #endif !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK) !$OMP& IF (LDAFS - 1 .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(LDAFS-1,8) APOS = POSELT + JJ8 * int(LDAFS,8) JJ3 = min( int(LDAFS,8) - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) A(APOSMAX:APOSMAX+int(LDAFS-1,8))=ZERO ENDIF END IF #endif IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) IF (NELIM.EQ.0) GOTO 210 LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT=PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT=ISTCHK ENDIF SON_XXS = IW(ISTCHK_CB_RIGHT + XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF IF (KEEP(50).EQ.0) THEN LDA_SON = LSTK LCB = int(NELIM,8)*int(LSTK,8) ELSE IF (NSLSON.EQ.0) THEN IF (SAME_PROC) THEN IS_CB_LR = IW(ISTCHK_CB_RIGHT+XXLR).EQ. 1 .OR. & IW(ISTCHK_CB_RIGHT+XXLR).EQ. 3 IF (IS_CB_LR) THEN LDA_SON = NELIM ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = NELIM ENDIF IF (PACKED_CB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN OPASSW = OPASSW + dble(LCB) ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM+1,8)/2_8 ENDIF IS_DYNAMIC_CB = & DMUMPS_DM_IS_DYNAMIC(IW(ISTCHK_CB_RIGHT+XXD: & ISTCHK_CB_RIGHT+XXD+1)) IF ( IS_DYNAMIC_CB ) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_CB_RIGHT+XXD)) CALL DMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) SON_A=>A ENDIF K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IF (KEEP(50).eq.0) THEN IF (IS_ofType5or6) THEN APOS = POSELT DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + SON_A(IACHK+JJ8-1_8) ENDDO ELSE DO 170 KK = K1, K2 APOS = POSEL1 + int(IW(KK),8) * int(LDAFS,8) DO 160 KK1 = 1, LSTK JJ2 = APOS + int(IW(K1 + KK1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (LCB .GT. 0) THEN CALL DMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF IBROT = INODE APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) IARR1 = PTRDEBARR(STEP(INODE)) DO 260 IORG = 1, NUMORG AINPUT8 = PTR8ARR(IARR1+IORG-1) J18 = AINPUT8 J28 = J18 + NINCOLARR(IARR1+IORG-1) J38 = J28 + 1_8 J48 = J28 + NINROWARR(IARR1+IORG-1) IJROW = INTARR(J18) ICT12 = POSELT + int(IJROW - 1 - LDAFS, 8) MAXARR = RZERO DO JJ8 = J18, J28 IF (KEEP(219).NE.0) THEN IF (INTARR(JJ8).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ8),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) ELSEIF (KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AINPUT8))) ENDIF ELSE IF (INTARR(JJ8).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ8),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) ENDIF ENDIF AINPUT8 = AINPUT8 + 1_8 ENDDO IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(IJROW-1,8)) = MAXARR ENDIF IF (J38 .GT. J48) GOTO 255 ICT13 = POSELT + int(IJROW - 1,8) * int(LDAFS,8) NBCOL = int(J48 - J38 + 1_8) DO JJ8 = 1_8, int(NBCOL,8) JJ3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8),8) - 1_8 A(JJ3) = A(JJ3) + DBLARR(AINPUT8 + JJ8 - 1_8) ENDDO 255 CONTINUE IF (KEEP(50).EQ.0) THEN DO J253 = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & NBLIG, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 IERR = -1 DO WHILE (IERR .EQ.-1) IF ( KEEP(50) .eq. 0 ) THEN NBCOL = NFRONT CALL MUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL MUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF ENDDO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 ENDDO DEALLOCATE(SONROWS_PER_ROW) IF (NUMSTK.EQ.0) GOTO 500 ISON = IFSON DO IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + 2 + KEEP(IXSZ) ) ELSE NROWS = NCOLS ENDIF PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN NFS4FATHER = NCBSON DO I=0,NCBSON-1 IF(IW(PTRCOL+I) .GT. NASS1) THEN NFS4FATHER = I EXIT ENDIF ENDDO NFS4FATHER = NFS4FATHER + NELIM ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) IF (PDEST1(1).EQ.MYID) THEN CALL DMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & NFRONT, NASS1, NFS4FATHER, NCBSON, IW( PTRCOL ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, roota, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, PDEST1, NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, & NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL DMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & NFRONT, NASS1,NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), INFO(2), & MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, LPTRAR, NELT, IW, & IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & DMUMPS_FAC_ASM_NIV2' ENDIF INFO(2) = NUMSTK + 1 ENDIF GOTO 490 245 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING COPY_CAND', & ' DURING DMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = SLAVEF+1 GOTO 490 265 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING DMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING DMUMPS_FAC_ASM_NIV2' ENDIF GOTO 490 275 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING SONROWS_PER_ROW', & ' DURING DMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = NFRONT-NASS1 GOTO 490 290 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (1) DURING DMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (1) DURING DMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (2)', &' DURING DMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (2)', &' DURING DMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -20 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 490 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_ASM_NIV2 END MODULE DMUMPS_FAC_ASM_MASTER_M MUMPS_5.8.1/src/csol_lr.F0000664000175000017500000010267015042446440015002 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_SOL_LR USE CMUMPS_LR_TYPE USE CMUMPS_LR_CORE USE MUMPS_LR_STATS USE CMUMPS_LR_DATA_M, only: BLR_ARRAY IMPLICIT NONE CONTAINS SUBROUTINE CMUMPS_SOL_FWD_LR_SU & (INODE, N, IWHDLR, NPIV_GLOBAL, NSLAVES, & IW, IPOS_INIT, LIW, & LIELL, WCB, LWCB, & LD_WCBPIV, LD_WCBCB, & PPIV_INIT, PCB_INIT, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, KEEP8, OOCWRITE_COMPATIBLE_WITH_BLR, & IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, N, IWHDLR, NPIV_GLOBAL, NSLAVES INTEGER, INTENT(IN) :: MTYPE, LIELL, KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: LIW, IPOS_INIT, LRHSINTR INTEGER, INTENT(IN) :: IW(LIW), POSINRHSINTR_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, PPIV_INIT, PCB_INIT INTEGER, INTENT(IN) :: LD_WCBPIV, LD_WCBCB, NRHS, JBDEB, JBFIN COMPLEX, INTENT(INOUT) :: WCB(LWCB) INTEGER, INTENT(INOUT) :: IFLAG, IERROR COMPLEX, INTENT(INOUT) :: RHSINTR(LRHSINTR, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: I, NPARTSASS, NB_BLR , NELIM, LDADIAG, & DIAGSIZ_DYN, DIAGSIZ_STA, IBEG_BLR, IEND_BLR, & LD_CB, NRHS_B, IPOS, KCB INTEGER(8) :: PPIV, PCB INTEGER :: LAST_BLR COMPLEX, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) NRHS_B = JBFIN-JBDEB+1 IF (MTYPE.EQ.1) THEN IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ELSE WRITE(6,*) " Internal error in CMUMPS_SOL_FWD_SU_MASTER" ENDIF ELSE IF (associated(BLR_ARRAY(IWHDLR)%PANELS_U)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_U) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ENDIF ENDIF IF (NSLAVES.EQ.0 .OR. (KEEP(50).eq.0 .and. MTYPE .NE.1)) THEN LAST_BLR = NB_BLR ELSE LAST_BLR = NPARTSASS ENDIF IPOS = IPOS_INIT PPIV = PPIV_INIT DO I=1, NPARTSASS IBEG_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I) IEND_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) -1 DIAGSIZ_DYN = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) - & IBEG_BLR DIAGSIZ_STA = BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(I+1) - & IBEG_BLR IF (KEEP(50).NE.0) THEN LDADIAG = DIAGSIZ_DYN ELSE LDADIAG = DIAGSIZ_STA ENDIF IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN PCB = PCB_INIT ELSE PCB = PPIV + int(DIAGSIZ_DYN,8) ENDIF IF ( DIAGSIZ_DYN.EQ.0) CYCLE NELIM = DIAGSIZ_STA - DIAGSIZ_DYN IF ( MTYPE .EQ. 1 ) THEN BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL ELSE BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_U(I)%LRB_PANEL END IF DIAG => BLR_ARRAY(IWHDLR)%DIAG_BLOCKS(I)%DIAG_BLOCK CALL CMUMPS_SOLVE_FWD_TRSOLVE (DIAG(1), & int(size(DIAG),8), 1_8, & DIAGSIZ_DYN , LDADIAG, NRHS_B, WCB, LWCB, NPIV_GLOBAL, & PPIV, MTYPE, KEEP) IF (NELIM.GT.0) THEN KCB = int(PCB-PPIV_INIT+1) IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN LD_CB = LD_WCBCB ELSE LD_CB = LD_WCBPIV ENDIF IF (MTYPE.EQ.1) THEN IF (KCB.LE.NPIV_GLOBAL .AND. & KCB+NELIM-1.GT.NPIV_GLOBAL) THEN CALL cgemm('T', 'N', NPIV_GLOBAL-KCB+1, NRHS_B, & DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) CALL cgemm('T', 'N', KCB+NELIM-NPIV_GLOBAL-1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG + & (NPIV_GLOBAL-KCB+1)*DIAGSIZ_DYN), & DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB_INIT), LD_WCBCB) ELSE CALL cgemm('T', 'N', NELIM, NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) ENDIF ELSE IF (KCB.LE.NPIV_GLOBAL .AND. & KCB+NELIM-1.GT.NPIV_GLOBAL) THEN CALL cgemm('N', 'N', NPIV_GLOBAL-KCB+1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) CALL cgemm('N', 'N', KCB+NELIM-NPIV_GLOBAL-1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN+NPIV_GLOBAL-KCB+1), & DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB_INIT), LD_WCBCB) ELSE CALL cgemm('N', 'N', NELIM, NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) ENDIF ENDIF ENDIF CALL CMUMPS_SOL_FWD_BLR_UPDATE ( & WCB, LWCB, 1, LD_WCBPIV, PPIV_INIT, 1, & WCB, LWCB, LD_WCBCB, PCB_INIT, & PPIV, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, LAST_BLR, I, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC, & KEEP8, KEEP(34), & KEEP(448), KEEP(450), KEEP(451), & .FALSE., & IFLAG, IERROR) IF (IFLAG.LT.0) RETURN CALL CMUMPS_SOL_LD_AND_RELOAD_PANEL ( & INODE, N, DIAGSIZ_DYN, LIELL, NELIM, NSLAVES, & PPIV, & IW, IPOS, LIW, & DIAG(1), int(size(DIAG),8), 1_8, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & .TRUE. & ) PPIV = PPIV + int(DIAGSIZ_DYN,8) IPOS = IPOS + DIAGSIZ_DYN ENDDO RETURN END SUBROUTINE CMUMPS_SOL_FWD_LR_SU SUBROUTINE CMUMPS_SOL_SLAVE_LR_U & (INODE, IWHDLR, NPIV_GLOBAL, & WCB, LWCB, & LDX, LDY, & PTRX_INIT, PTRY_INIT, & JBDEB, JBFIN, & MTYPE, KEEP, KEEP8, IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, IWHDLR, NPIV_GLOBAL INTEGER, INTENT(IN) :: MTYPE, KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER(8), INTENT(IN) :: LWCB, PTRX_INIT, PTRY_INIT INTEGER, INTENT(IN) :: LDX, LDY, JBDEB, JBFIN COMPLEX, INTENT(INOUT) :: WCB(LWCB) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, NPARTSASS, NB_BLR , NRHS_B INTEGER(8) :: PTRX, PTRY TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) NRHS_B = JBFIN-JBDEB+1 IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) NB_BLR = NB_BLR - 2 ELSE WRITE(6,*) " Internal error 1 in CMUMPS_SOL_SLAVE_LR_U" CALL MUMPS_ABORT() ENDIF PTRX = PTRX_INIT PTRY = PTRY_INIT DO I = 1, NPARTSASS BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL IF (associated(BLR_PANEL)) THEN IF (MTYPE.EQ.1) THEN CALL CMUMPS_SOL_FWD_BLR_UPDATE ( & WCB, LWCB, 1, LDX, -99999_8, 1, & WCB, LWCB, LDY, PTRY, & PTRX, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, NB_BLR, 0, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(2:NB_BLR+2), & KEEP8, KEEP(34), & KEEP(448), KEEP(450), KEEP(451), & .TRUE., IFLAG, IERROR ) ELSE CALL CMUMPS_SOL_BWD_BLR_UPDATE ( & WCB, LWCB, 1, LDY, -99999_8, 1, & WCB, LWCB, LDX, PTRX, & PTRY, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, NB_BLR, 0, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(2:NB_BLR+2), & KEEP8, KEEP(34), & KEEP(448), KEEP(450), KEEP(451), & .TRUE., & IFLAG, IERROR ) ENDIF IF (MTYPE .EQ. 1) THEN PTRX = PTRX + BLR_PANEL(1)%N ELSE PTRY = PTRY + BLR_PANEL(1)%N ENDIF IF (IFLAG.LT.0) RETURN ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_SOL_SLAVE_LR_U SUBROUTINE GEMM_Q_FWD(m, nrhs_b, k, npiv, & Q, TMP, ldT, & arraypiv, ldpiv, arraycb, lcb, ldcb, & ibeg_block, iend_block, is_t2_slave, & poscb, pospiv, pospivcol, ibeg_tmp) implicit none integer, intent(in) :: m, nrhs_b, k, npiv complex, dimension(:,:), intent(inout) :: Q complex, dimension(ldt, *), intent(inout) :: TMP integer(8), intent(in) :: lcb integer, intent(in) :: ldpiv complex, intent(inout) :: arraypiv(ldpiv,*) complex, intent(inout) :: arraycb(lcb) integer, intent(in) :: ldt, ldcb integer, intent(in) :: ibeg_block, iend_block logical, intent(in) :: is_t2_slave integer(8), intent(in) :: poscb, pospiv integer, intent(in) :: pospivcol integer, intent(in) :: ibeg_tmp integer :: posblock COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL cgemm('N', 'N', M, NRHS_B, K, MONE, & Q(1,1), M, TMP(ibeg_tmp,1), LDT, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND. & IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('N', 'N', NPIV-IBEG_BLOCK+1,NRHS_B, K, & MONE, Q(1,1), M, TMP(ibeg_tmp,1), LDT, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL cgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, & NRHS_B, K, & MONE, Q(NPIV-IBEG_BLOCK+2,1), M, & TMP(ibeg_tmp,1), LDT, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('N', 'N', M, NRHS_B, K, MONE, & Q(1,1), M, TMP(ibeg_tmp,1), LDT, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL cgemm('N', 'N', M, NRHS_B, K, MONE, & Q(1,1), M, TMP(ibeg_tmp,1), LDT, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF RETURN END SUBROUTINE GEMM_Q_FWD SUBROUTINE GEMM_Q_BWD(m, nrhs_b, k, npiv, & Q, TMP, ldT, & arraypiv, lpiv, ldpiv, arraycb, lcb, ldcb, & ibeg_block, iend_block, is_t2_slave, & poscb, pospiv, pospivcol, ibeg_tmp) implicit none integer, intent(in) :: m, nrhs_b, k, npiv complex, dimension(:, :), intent(inout) :: Q complex, dimension(ldt, *), intent(inout) :: TMP integer(8), intent(in) :: lcb, lpiv complex, intent(inout) :: arraypiv(lpiv,*) complex, intent(inout) :: arraycb(lcb) integer, intent(in) :: ldt, ldcb, ldpiv integer, intent(in) :: ibeg_block, iend_block logical, intent(in) :: is_t2_slave integer(8), intent(in) :: poscb, pospiv integer, intent(in) :: pospivcol integer, intent(in) :: ibeg_tmp integer(8) :: posblock COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB +int(IBEG_BLOCK-1,8) CALL cgemm('T', 'N', K, NRHS_B, M, ONE, & Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TMP(ibeg_tmp,1), ldt) ELSEIF (IBEG_BLOCK.LE.NPIV.AND. & IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('T', 'N', K, NRHS_B, & NPIV-IBEG_BLOCK+1, & ONE, Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TMP(ibeg_tmp, 1), ldt) CALL cgemm('T', 'N', & K, NRHS_B, IBEG_BLOCK+M-NPIV-1, & ONE, Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYCB(POSCB), LDCB, & ONE, & TMP(ibeg_tmp,1), ldt) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('T', 'N', K, NRHS_B, M, ONE, & Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TMP(ibeg_tmp, 1), ldt) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL cgemm('T', 'N', K, NRHS_B, M, ONE, & Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TMP(ibeg_tmp, 1), ldt) ENDIF RETURN END SUBROUTINE GEMM_Q_BWD SUBROUTINE CMUMPS_SOL_FWD_BLR_UPDATE ( & ARRAYPIV, LPIV, LPIVCOL, LDPIV, POSPIV, POSPIVCOL, & ARRAYCB, LCB, LDCB, POSCB, & POSDIAG, & NRHS_B, NPIV, & BLR_PANEL, LAST_BLR, & CURRENT_BLR, BEGS_BLR_STATIC, & KEEP8, K34, K448, K450, K451, IS_T2_SLAVE, IFLAG, IERROR ) !$ USE OMP_LIB INTEGER(8), INTENT(IN) :: LPIV, LCB, POSPIV, POSCB, POSDIAG INTEGER, INTENT(IN) :: LPIVCOL, POSPIVCOL COMPLEX, INTENT(INOUT) :: ARRAYPIV(LPIV,LPIVCOL) COMPLEX, INTENT(INOUT) :: ARRAYCB(LCB) INTEGER, INTENT(IN) :: LAST_BLR, NRHS_B, LDPIV, LDCB, & CURRENT_BLR, NPIV, K34, K448, K450, K451 TYPE(LRB_TYPE), TARGET,INTENT(IN) :: & BLR_PANEL(:) INTEGER :: BEGS_BLR_STATIC(:) LOGICAL, INTENT(IN) :: IS_T2_SLAVE INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, K, M, N, IBEG_BLOCK, IEND_BLOCK INTEGER :: KMAX INTEGER :: MMAX INTEGER(8) :: POSBLOCK INTEGER :: allocok TYPE(LRB_TYPE), POINTER :: LRB COMPLEX, ALLOCATABLE,DIMENSION(:) :: TEMP_BLOCK COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) KMAX = -1 MMAX = -1 DO I = CURRENT_BLR+1, LAST_BLR KMAX = max(KMAX, BLR_PANEL(I-CURRENT_BLR)%K) MMAX = max(MMAX, BLR_PANEL(I-CURRENT_BLR)%M) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(TEMP_BLOCK, allocok !$OMP& ) #endif IF (KMAX.GT.0) THEN allocate(TEMP_BLOCK(KMAX*NRHS_B), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NRHS_B * KMAX write(*,*) 'Allocation problem in BLR routine & CMUMPS_SOL_FWD_BLR_UPDATE for TEMP_BLOCK: ', & 'not enough memory? memory requested = ', IERROR ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif #if ! defined(BLR_NOOPENMP) !$OMP DO SCHEDULE(DYNAMIC,1) !$OMP& PRIVATE(IBEG_BLOCK, IEND_BLOCK, LRB, K, M, N, !$OMP& POSBLOCK) #endif DO I = CURRENT_BLR+1, LAST_BLR IF (IFLAG.LT.0) CYCLE IBEG_BLOCK = BEGS_BLR_STATIC(I) IEND_BLOCK = BEGS_BLR_STATIC(I+1)-1 IF (IBEG_BLOCK .EQ. IEND_BLOCK + 1) CYCLE LRB => BLR_PANEL(I-CURRENT_BLR) K = LRB%K M = LRB%M N = LRB%N IF (LRB%ISLR) THEN IF (K.GT.0) THEN CALL cgemm('N', 'N', K, NRHS_B, N, ONE, & LRB%R(1,1), K, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL cgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('N', 'N', NPIV-IBEG_BLOCK+1, NRHS_B, K, & MONE, LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL cgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, NRHS_B, K, & MONE, LRB%Q(NPIV-IBEG_BLOCK+2,1), M, TEMP_BLOCK(1), & K, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL cgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF ENDIF ELSE IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB + int(IBEG_BLOCK-1,8) CALL cgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('N', 'N', NPIV-IBEG_BLOCK+1, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL cgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, NRHS_B, N, MONE, & LRB%Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYPIV(POSDIAG,POSPIVCOL), & LDPIV, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB + int(IBEG_BLOCK-1-NPIV,8) CALL cgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF ENDIF ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif IF (KMAX.GT.0) THEN IF (allocated(TEMP_BLOCK)) deallocate(TEMP_BLOCK) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif RETURN END SUBROUTINE CMUMPS_SOL_FWD_BLR_UPDATE SUBROUTINE CMUMPS_SOL_BWD_LR_SU & ( INODE, IWHDLR, NPIV_GLOBAL, NSLAVES, & LIELL, WCB, LWCB, NRHS_B, PTWCB, & RHSINTR, LRHSINTR, NRHS, & IPOSINRHSINTR, JBDEB, & MTYPE, KEEP, KEEP8, & IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, IWHDLR, NPIV_GLOBAL, NSLAVES INTEGER, INTENT(IN) :: MTYPE, LIELL, KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IPOSINRHSINTR, JBDEB, LRHSINTR, NRHS INTEGER(8), INTENT(IN) :: LWCB, PTWCB INTEGER, INTENT(IN) :: NRHS_B INTEGER, INTENT(INOUT) :: IFLAG, IERROR COMPLEX, INTENT(INOUT) :: WCB(LWCB) COMPLEX RHSINTR(LRHSINTR,NRHS) INTEGER :: I, NPARTSASS, NB_BLR, LAST_BLR, & NELIM_PANEL, LD_WCB, & DIAGSIZ_DYN, DIAGSIZ_STA, LDADIAG, & IEND_BLR, IBEG_BLR INTEGER(8) :: PWCB INTEGER :: IPIV_PANEL COMPLEX, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) IF ((MTYPE.EQ.1).AND.(KEEP(50).EQ.0)) THEN IF (associated(BLR_ARRAY(IWHDLR)%PANELS_U)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_U) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ENDIF ELSE IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ELSE WRITE(6,*) " Internal error in CMUMPS_SOL_FWD_SU_MASTER" ENDIF ENDIF PWCB = PTWCB + int(NPIV_GLOBAL,8) LD_WCB = LIELL IF (KEEP(50).EQ.0 .AND. NSLAVES.GT.0 .AND. MTYPE.NE.1) THEN LAST_BLR = NPARTSASS ELSE LAST_BLR = NB_BLR ENDIF DO I=NPARTSASS,1,-1 IBEG_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I) IEND_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) -1 DIAGSIZ_DYN = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) - & IBEG_BLR DIAGSIZ_STA = BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(I+1) - & IBEG_BLR IF (KEEP(50).NE.0) THEN LDADIAG = DIAGSIZ_DYN ELSE LDADIAG = DIAGSIZ_STA ENDIF IF (DIAGSIZ_DYN.EQ.0) GOTO 1000 NELIM_PANEL = DIAGSIZ_STA - DIAGSIZ_DYN IPIV_PANEL = IPOSINRHSINTR + IBEG_BLR -1 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_U(I)%LRB_PANEL ELSE BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL END IF CALL CMUMPS_SOL_BWD_BLR_UPDATE ( & RHSINTR, int(LRHSINTR,8), NRHS, LRHSINTR, & int(IPOSINRHSINTR,8), JBDEB, & WCB, LWCB, LD_WCB, PWCB, & int(IPIV_PANEL,8), & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, LAST_BLR, & I, BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC, & KEEP8, KEEP(34), & KEEP(448), KEEP(450), KEEP(451), & .FALSE., & IFLAG, IERROR) IF (IFLAG.LT.0) RETURN DIAG => BLR_ARRAY(IWHDLR)%DIAG_BLOCKS(I)%DIAG_BLOCK IF (NELIM_PANEL.GT.0) THEN IF (MTYPE.EQ.1.AND.KEEP(50).EQ.0) THEN IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN CALL cgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, WCB(PWCB), & LD_WCB, ONE , RHSINTR(IPIV_PANEL,JBDEB),LRHSINTR) ELSE IF (IEND_BLR+1.LE.NPIV_GLOBAL .AND. & IEND_BLR+NELIM_PANEL.GT.NPIV_GLOBAL) THEN CALL cgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, & NPIV_GLOBAL-IEND_BLR, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & RHSINTR(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSINTR, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) CALL cgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, & IEND_BLR+NELIM_PANEL-NPIV_GLOBAL, & MONE, DIAG(1+DIAGSIZ_DYN+NPIV_GLOBAL-IEND_BLR), & DIAGSIZ_STA, & WCB(PWCB), LD_WCB, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ELSE CALL cgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & RHSINTR(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSINTR, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ENDIF ENDIF ELSE IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN CALL cgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PWCB), LD_WCB, ONE, & RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ELSE IF (IEND_BLR+1.LE.NPIV_GLOBAL .AND. & IEND_BLR+NELIM_PANEL.GT.NPIV_GLOBAL) THEN CALL cgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, & NPIV_GLOBAL-IEND_BLR, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & RHSINTR(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSINTR, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) CALL cgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, & IEND_BLR+NELIM_PANEL-NPIV_GLOBAL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG + & (NPIV_GLOBAL-IEND_BLR)*DIAGSIZ_DYN), & DIAGSIZ_DYN, & WCB(PWCB), LD_WCB, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ELSE CALL cgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & RHSINTR(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSINTR, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ENDIF ENDIF ENDIF ENDIF IF (IFLAG.LT.0) RETURN CALL CMUMPS_SOLVE_BWD_LR_TRSOLVE ( & DIAG(1), size(DIAG), DIAGSIZ_DYN, NELIM_PANEL, LIELL, & NRHS_B, WCB, LWCB, & RHSINTR, LRHSINTR, NRHS, & IPIV_PANEL, JBDEB, & MTYPE, KEEP ) 1000 CONTINUE ENDDO RETURN END SUBROUTINE CMUMPS_SOL_BWD_LR_SU SUBROUTINE CMUMPS_SOL_BWD_BLR_UPDATE ( & ARRAYPIV, LPIV, LPIVCOL, LDPIV, POSPIV, POSPIVCOL, & ARRAYCB, LCB, LDCB, POSCB, & POSDIAG, & NRHS_B, NPIV, & BLR_PANEL, LAST_BLR, CURRENT_BLR, & BEGS_BLR_STATIC, & KEEP8, K34, K448, K450, K451, IS_T2_SLAVE, & IFLAG, IERROR) !$ USE OMP_LIB INTEGER(8), INTENT(IN) :: LPIV, LCB, POSPIV, POSCB, POSDIAG INTEGER,INTENT(IN) :: LPIVCOL, POSPIVCOL COMPLEX, INTENT(INOUT) :: ARRAYPIV(LPIV,LPIVCOL) COMPLEX, INTENT(INOUT) :: ARRAYCB(LCB) INTEGER, INTENT(IN) :: LAST_BLR, NRHS_B, LDPIV, LDCB, & CURRENT_BLR, NPIV, K34, K448, K450, K451 TYPE(LRB_TYPE), TARGET,INTENT(IN) :: & BLR_PANEL(:) INTEGER(8), INTENT(IN) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_T2_SLAVE INTEGER :: BEGS_BLR_STATIC(:) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, K, M, N, IBEG_BLOCK, IEND_BLOCK INTEGER :: KMAX INTEGER(8) :: POSBLOCK TYPE(LRB_TYPE), POINTER :: LRB COMPLEX, ALLOCATABLE, DIMENSION(:) :: TEMP_BLOCK COMPLEX, ALLOCATABLE, DIMENSION(:) :: DEST_ARRAY INTEGER :: allocok COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) KMAX = -1 DO I = CURRENT_BLR+1, LAST_BLR KMAX = max(KMAX, BLR_PANEL(I-CURRENT_BLR)%K) ENDDO IF (CURRENT_BLR.LT.LAST_BLR) THEN N = BLR_PANEL(1)%N ELSE RETURN ENDIF allocate(DEST_ARRAY(N*NRHS_B),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = N * NRHS_B GOTO 100 ENDIF DEST_ARRAY = ZERO #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(TEMP_BLOCK, allocok !$OMP& ) #endif IF (KMAX.GT.0) THEN allocate(TEMP_BLOCK(KMAX*NRHS_B), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NRHS_B * KMAX write(*,*) 'Allocation problem in BLR routine & CMUMPS_SOL_BWD_BLR_UPDATE: ', & 'not enough memory? memory requested = ', IERROR ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP DO SCHEDULE(DYNAMIC,1) !$OMP& PRIVATE(IBEG_BLOCK, IEND_BLOCK, LRB, K, M, POSBLOCK) !$OMP& REDUCTION(+:DEST_ARRAY) #endif DO I = CURRENT_BLR+1, LAST_BLR IF (IFLAG.LT.0) CYCLE IBEG_BLOCK = BEGS_BLR_STATIC(I) IEND_BLOCK = BEGS_BLR_STATIC(I+1)-1 LRB => BLR_PANEL(I-CURRENT_BLR) K = LRB%K M = LRB%M IF (LRB%ISLR) THEN IF (K.GT.0) THEN IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB +int(IBEG_BLOCK-1,8) CALL cgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TEMP_BLOCK(1), K) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('T', 'N', K, NRHS_B, NPIV-IBEG_BLOCK+1, & ONE, LRB%Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) CALL cgemm('T', 'N', K, NRHS_B, IBEG_BLOCK+M-NPIV-1, & ONE, LRB%Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYCB(POSCB), LDCB, & ONE, & TEMP_BLOCK(1), K) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL cgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TEMP_BLOCK(1), K) ENDIF CALL cgemm('T', 'N', N, NRHS_B, K, MONE, & LRB%R(1,1), K, & TEMP_BLOCK(1), K, ONE, & DEST_ARRAY(1), N) ENDIF ELSE IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL cgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYCB(POSBLOCK), LDCB, & ONE, DEST_ARRAY(1), N) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('T', 'N', N, NRHS_B, NPIV-IBEG_BLOCK+1, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ONE, DEST_ARRAY(1), N) CALL cgemm('T', 'N', N, NRHS_B, IBEG_BLOCK+M-NPIV-1, MONE, & LRB%Q(NPIV-IBEG_BLOCK+2,1), M, ARRAYCB(POSCB), & LDCB, ONE, DEST_ARRAY(1), N) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ONE, DEST_ARRAY(1), N) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL cgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYCB(POSBLOCK), LDCB, & ONE, DEST_ARRAY(1), N) ENDIF ENDIF ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif IF (KMAX.GT.0) THEN IF (allocated(TEMP_BLOCK)) deallocate(TEMP_BLOCK) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IS_T2_SLAVE) THEN DO I=1,NRHS_B call caxpy(N, ONE, DEST_ARRAY((I-1)*N+1), 1, & ARRAYPIV(POSDIAG+(I-1)*LDPIV,POSPIVCOL), 1) ENDDO ELSE DO I=1,NRHS_B call caxpy(N, ONE, DEST_ARRAY((I-1)*N+1), 1, & ARRAYPIV(POSDIAG,POSPIVCOL+I-1), 1) ENDDO ENDIF 100 CONTINUE IF (allocated(DEST_ARRAY)) DEALLOCATE(DEST_ARRAY) RETURN END SUBROUTINE CMUMPS_SOL_BWD_BLR_UPDATE END MODULE CMUMPS_SOL_LR SUBROUTINE CMUMPS_SOLVE_BWD_LR_TRSOLVE ( & DIAG, LDIAG, NPIV, NELIM, LIELL, & NRHS_B, W, LWC, & RHSINTR, LRHSINTR, NRHS, & PPIVINRHSINTR, JBDEB, & MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LIELL, NPIV, NELIM, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDIAG INTEGER, INTENT(IN) :: PPIVINRHSINTR, JBDEB, LRHSINTR, NRHS INTEGER(8), INTENT(IN) :: LWC COMPLEX, INTENT(IN) :: DIAG(LDIAG) COMPLEX, INTENT(INOUT) :: W(LWC) COMPLEX RHSINTR(LRHSINTR,NRHS) INTEGER :: LDAJ COMPLEX ONE PARAMETER ( ONE=(1.0E0,0.0E0) ) IF ( MTYPE .eq. 1 ) THEN LDAJ = NPIV + NELIM CALL ctrsm('L','L','T','N', NPIV, NRHS_B, ONE, DIAG(1), & LDAJ, RHSINTR(PPIVINRHSINTR,JBDEB), & LRHSINTR) ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=NPIV+NELIM ELSE LDAJ=NPIV ENDIF CALL ctrsm('L','U','N','U', NPIV, NRHS_B, ONE, DIAG(1), & LDAJ, RHSINTR(PPIVINRHSINTR,JBDEB), LRHSINTR) END IF RETURN END SUBROUTINE CMUMPS_SOLVE_BWD_LR_TRSOLVE MUMPS_5.8.1/src/dfac_process_blfac_slave.F0000664000175000017500000005602215042446440020320 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE DMUMPS_PROCESS_BLFAC_SLAVE( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT USE MUMPS_LOAD USE DMUMPS_LR_CORE USE DMUMPS_LR_TYPE USE DMUMPS_FAC_LR USE DMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR USE DMUMPS_FAC_FRONT_AUX_M, ONLY : DMUMPS_GET_SIZE_SCHUR_IN_FRONT #if ! defined(BLR_NOOPENMP) !$ USE OMP_LIB #endif IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER PERM(N), STEP(N), PIMASTER(KEEP(28)) INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER NELT, LPTRAR INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)) INTEGER ITLOC( N + KEEP(253)), FILS( N ), DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER ND( KEEP(28) ), FRERE_STEPS( KEEP(28) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER INODE, IPOSK, JPOSK, NCOLU, NPIV, POSITION, IERR INTEGER(8) POSELT, POSBLOCFACTO INTEGER(8) LAELL INTEGER(8) :: LA_PTR DOUBLE PRECISION, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1 , HS, DEST, NSLAVES_FOLLOW INTEGER FPERE, TO_UPDATE_CPT_RECUR INTEGER(8) CPOS, LPOS LOGICAL DYNAMIC_ALLOC, COUNTER_WAS_HUGE LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL LASTBL_INPANEL INTEGER allocok INTEGER LR_ACTIVATED_INT LOGICAL LR_ACTIVATED, COMPRESS_CB INTEGER NB_BLR_U, CURRENT_BLR_U TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_U INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_U TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS, BEGS_BLR_COL INTEGER :: NB_BLR_LS, IPANEL, & MAXI_CLUSTER_LS, MAXI_CLUSTER, & NB_BLR_COL, MAXI_CLUSTER_COL, NPARTSASS_MASTER DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, LWORK INTEGER :: II,JJ INTEGER :: MSGSOU_BL INTEGER :: NFS4FATHER, NASS1, NELIM, INFO_TMP(2) INTEGER :: NVSCHUR_K253, NSLAVES_L, IROW_L INTEGER :: NBROWSinF DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: M_ARRAY DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: UDYNAMIC DOUBLE PRECISION ONE,ALPHA PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) DYNAMIC_ALLOC = .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 <=0 NPIV in BLFAC', NPIV 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 ) LASTBL_INPANEL = (NCOLU.LT.0) IF (LASTBL_INPANEL) NCOLU = -NCOLU CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LR_ACTIVATED_INT, 1, & MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IPANEL, 1, & MPI_INTEGER, COMM, IERR ) IF (LR_ACTIVATED) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_U, 1, MPI_INTEGER, & COMM, IERR ) CURRENT_BLR_U = 1 ALLOCATE(BLR_U(max(NB_BLR_U,1)), & BEGS_BLR_U(NB_BLR_U+2), stat=allocok) if (allocok .GT. 0) THEN IFLAG = -13 IERROR = max(NB_BLR_U,1) + NB_BLR_U+2 GOTO 700 endif CALL DMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, JPOSK-1, 0, 'V', & BLR_U, NB_BLR_U, & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE LAELL = int(NPIV,8) * int(NCOLU,8) CALL DMUMPS_GET_SIZE_NEEDED( & 0, LAELL, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID, SLAVEF, & PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8, LAELL,KEEP,KEEP8,LRLUS) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOLU, & MPI_DOUBLE_PRECISION, & COMM, IERR ) ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) DYNAMIC_ALLOC = .TRUE. IF ( (PTRIST(STEP( INODE )).NE.0) .AND. & (IPOSK + NPIV -1 .GT. & IW(PTRIST(STEP(INODE))+3+KEEP(IXSZ))) )THEN DYNAMIC_ALLOC = .TRUE. ENDIF IF (LR_ACTIVATED) THEN DYNAMIC_ALLOC = .FALSE. ENDIF IF (DYNAMIC_ALLOC) THEN ALLOCATE(UDYNAMIC(LAELL), stat=allocok) if (allocok .GT. 0) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(LAELL,IERROR) GOTO 700 endif UDYNAMIC(1_8:LAELL) = A(POSBLOCFACTO:POSBLOCFACTO+LAELL-1_8) LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(69) = KEEP8(69) - LAELL POSFAC = POSFAC - LAELL CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) THEN CALL DMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF DO WHILE ( IPOSK + NPIV -1 .GT. & IW( PTRIST(STEP( INODE )) + 3 +KEEP(IXSZ)) ) MSGSOU_BL = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IOLDPS = PTRIST(STEP(INODE)) NSLAVES_FOLLOW = IW( IOLDPS+5+KEEP(IXSZ))-XTRA_SLAVES_SYM NASS1 = abs(IW( IOLDPS + 1 + KEEP(IXSZ))) TO_UPDATE_CPT_RECUR = & ( SLAVEF - NSLAVES_FOLLOW - 1 ) * & (2*NASS1/KEEP(6)) IF ( IW(IOLDPS+6+KEEP(IXSZ)) .eq. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN COUNTER_WAS_HUGE=.TRUE. IW(IOLDPS+6+KEEP(IXSZ)) = 1 ELSE COUNTER_WAS_HUGE=.FALSE. ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) - TO_UPDATE_CPT_RECUR - 10 BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU_BL, BLOC_FACTO_SYM, STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + TO_UPDATE_CPT_RECUR + 10 IF ( COUNTER_WAS_HUGE .AND. & IW(IOLDPS+6+KEEP(IXSZ)).EQ.1 ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = huge(IW(IOLDPS+6+KEEP(IXSZ))) ENDIF IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP( INODE )) CALL DMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF (LR_ACTIVATED) THEN CALL DMUMPS_BLR_DEC_AND_RETRIEVE_L (IW(IOLDPS+XXF), IPANEL, & BEGS_BLR_LS, BLR_LS, NCOLU) NB_BLR_LS = size(BEGS_BLR_LS)-2 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL DMUMPS_BLR_UPDATE_TRAILING_I ( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_U(1), size(BEGS_BLR_U), & CURRENT_BLR_U, & BLR_LS(1), NB_BLR_LS+1, & BLR_U(1), NB_BLR_U+1, & 0, & .TRUE., & 0, & 2, & 1, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif CALL DEALLOC_BLR_PANEL(BLR_U, NB_BLR_U, KEEP8, KEEP(34)) IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) IF (IFLAG.LT.0) GOTO 700 IF (KEEP(486).EQ.3) THEN CALL DMUMPS_BLR_TRY_FREE_PANEL(IW(IOLDPS+XXF), IPANEL, & KEEP8, KEEP(34)) ENDIF ELSE CPOS = POSELT + int(JPOSK - 1,8) LPOS = POSELT + int(IPOSK - 1,8) IF ( NPIV .GT. 0 ) THEN IF (DYNAMIC_ALLOC) THEN CALL dgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & UDYNAMIC(1), NPIV, & A_PTR( LPOS ), NCOL1, ONE, & A_PTR( CPOS ), NCOL1 ) ELSE CALL dgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & A( POSBLOCFACTO ), NPIV, & A_PTR( LPOS ), NCOL1, ONE, & A_PTR( CPOS ), NCOL1 ) ENDIF ENDIF ENDIF IF (NPIV .GT. 0) THEN FLOP1 = dble(NCOLU*NPIV)*dble(2*NROW1) FLOP1 = -FLOP1 CALL MUMPS_LOAD_UPDATE(1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IF (LASTBL_INPANEL) THEN IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + 1 ENDIF IF (.NOT.LR_ACTIVATED) THEN IF (DYNAMIC_ALLOC) THEN DEALLOCATE(UDYNAMIC) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(69) = KEEP8(69) - LAELL POSFAC = POSFAC - LAELL CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF ENDIF NSLAVES_FOLLOW = IW( IOLDPS + 5 +KEEP(IXSZ) ) - XTRA_SLAVES_SYM IF ( IW( IOLDPS + 6 +KEEP(IXSZ)) .eq. 0 .and. & KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 ) & THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) CALL MUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_BLFAC_SLAVE.' IFLAG = -99 GOTO 700 END IF END IF IF (IW(PTRIST(STEP(INODE)) + 6+KEEP(IXSZ) ) .eq. 0) THEN NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 4 + KEEP(IXSZ)) NELIM = NASS1 - NPIV1 COMPRESS_CB= .FALSE. IF (LR_ACTIVATED) THEN COMPRESS_CB = ((IW(PTRIST(STEP(INODE))+XXLR).EQ.1).OR. & (IW(PTRIST(STEP(INODE))+XXLR).EQ.3)) IF (NPIV.EQ.0) CALL MUMPS_ABORT() IF (COMPRESS_CB) THEN CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) NB_BLR_COL = size(BEGS_BLR_COL) - 1 allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_MASTER), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_MASTER) GOTO 700 ENDIF DO II=1,NB_BLR_LS DO JJ=1,NB_BLR_COL-NPARTSASS_MASTER CB_LRB(II,JJ)%M=0 CB_LRB(II,JJ)%N=0 NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL DMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) CALL MAX_CLUSTER(BEGS_BLR_COL( max(NPARTSASS_MASTER,1)+1: & NB_BLR_COL+1), & NB_BLR_COL-max(NPARTSASS_MASTER,1), MAXI_CLUSTER_COL ) MAXI_CLUSTER = max(MAXI_CLUSTER_LS, & MAXI_CLUSTER_COL+NELIM,NPIV) LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL DMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) NFS4FATHER = max(NFS4FATHER,0) + NELIM ENDIF ALLOCATE(M_ARRAY(max(NFS4FATHER,1)), stat=allocok) IF (allocok.gt.0) THEN IFLAG = -13 IERROR = max(NFS4FATHER,1) GOTO 700 ENDIF BEGS_BLR_COL(1+NPARTSASS_MASTER) = & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM NBROWSinF = 0 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN CALL DMUMPS_COMPUTE_NBROWSinF ( & N, INODE, FPERE, KEEP, & IOLDPS, HS, & IW, LIW, & NROW1, NCOL1, NPIV1, & NELIM, NFS4FATHER, & NBROWSinF & ) ENDIF IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) & .AND. (KEEP(50).EQ.2) & ) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL DMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR_K253 ) ELSE NVSCHUR_K253 = 0 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL DMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_LS, NB_BLR_COL-NPARTSASS_MASTER, & NPARTSASS_MASTER, & NROW1, NCOL1-NPIV1, INODE, & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV1, NVSCHUR_K253, KEEP(1), & M_ARRAY, & NELIM, NBROWSinF ) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 650 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL DMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF 650 CONTINUE IF (allocated(M_ARRAY)) DEALLOCATE(M_ARRAY) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF CALL DMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, roota, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF RETURN 700 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (COMPRESS_CB) THEN IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) ENDIF IF (allocated(M_ARRAY)) DEALLOCATE(M_ARRAY) IF (DYNAMIC_ALLOC) THEN IF (allocated(UDYNAMIC)) DEALLOCATE(UDYNAMIC) ENDIF RETURN END SUBROUTINE DMUMPS_PROCESS_BLFAC_SLAVE MUMPS_5.8.1/src/mumps_io_basic.h0000664000175000017500000001371615042446422016402 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_IO_BASIC_H #define MUMPS_IO_BASIC_H #include "mumps_compat.h" #include "mumps_c_types.h" #if ! defined(WITHOUT_PTHREAD) && defined(MUMPS_WIN32) # define WITHOUT_PTHREAD 1 #endif #if defined(_AIX) # if ! defined(_ALL_SOURCE) /* Macro needed for direct I/O on IBM AIX */ # define _ALL_SOURCE 1 # endif #endif #if ! defined (MUMPS_WIN32) # if ! defined(_XOPEN_SOURCE) /* Setting this macro avoids the warnings ("missing * prototype") related to the use of pread /pwrite */ # define _XOPEN_SOURCE 500 # endif #endif #include #include #include #include #if ! defined (MUMPS_WIN32) # include # include # include # include # include # include #endif #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 UNINITIALIZED "NAME_NOT_INITIALIZED" #define MUMPS_OOC_DEFAULT_DIR "/tmp" #if defined(MUMPS_WIN32) # define SEPARATOR "\\" #else # define SEPARATOR "/" #endif /* #define NB_FILE_TYPE_FACTO 1 */ /* #define NB_FILE_TYPE_SOLVE 1 */ #define my_max(x,y) ( (x) > (y) ? (x) : (y) ) #define my_ceil(x) ( (MUMPS_INT8)(x) >= (x) ? (MUMPS_INT8)(x) : ( (MUMPS_INT8)(x) + 1 ) ) typedef struct __mumps_file_struct{ MUMPS_OFF_T write_pos; MUMPS_OFF_T current_pos; MUMPS_INT is_opened; #if ! defined (MUMPS_WIN32) MUMPS_INT file; #else FILE* file; #endif char name[1300]; /* Larger than prefix(255)+tmpdir(1023)+base_name (20)+\0 (1) */ }mumps_file_struct; typedef struct __mumps_file_type{ #if ! defined (MUMPS_WIN32) MUMPS_INT mumps_flag_open; #else char mumps_flag_open[6]; #endif MUMPS_INT mumps_io_current_file_number; MUMPS_INT mumps_io_last_file_opened; MUMPS_INT mumps_io_nb_file_opened; MUMPS_INT mumps_io_nb_file; mumps_file_struct* mumps_io_pfile_pointer_array; mumps_file_struct* mumps_io_current_file; }mumps_file_type; /* Exported global variables */ #if ! defined (MUMPS_WIN32) # if defined (WITH_PFUNC) && ! defined (WITHOUT_PTHREAD) # include extern pthread_mutex_t mumps_io_pwrite_mutex; # endif #endif /* MUMPS_WIN32 */ extern mumps_file_type* mumps_files; extern char* mumps_ooc_file_prefix; extern MUMPS_INT mumps_elementary_data_size; extern MUMPS_INT mumps_io_is_init_called; extern MUMPS_INT mumps_io_myid; extern MUMPS_OFF_T mumps_io_max_file_size; extern MUMPS_INT mumps_io_flag_async; extern MUMPS_INT mumps_io_k211; extern MUMPS_INT mumps_io_nb_file_type; /* Exported functions */ MUMPS_INT mumps_set_file(MUMPS_INT type,MUMPS_INT file_number_arg); void mumps_update_current_file_position(mumps_file_struct* file_arg); MUMPS_INT mumps_compute_where_to_write(const double to_be_written,const MUMPS_INT type,long long vaddr,size_t already_written); MUMPS_INT mumps_prepare_pointers_for_write(double to_be_written,MUMPS_OFF_T * pos_in_file, MUMPS_INT * file_number,const MUMPS_INT type,long long vaddr,size_t already_written); MUMPS_INT mumps_io_do_write_block(void * address_block,long long block_size,MUMPS_INT * type,long long vaddr,MUMPS_INT * ierr); MUMPS_INT mumps_io_do_read_block(void * address_block,long long block_size,MUMPS_INT * type,long long vaddr,MUMPS_INT * ierr); MUMPS_INT mumps_compute_nb_concerned_files(long long block_size,MUMPS_INT * nb_concerned_files,long long vaddr); MUMPS_INT mumps_free_file_pointers(MUMPS_INT* step); MUMPS_INT mumps_init_file_structure(MUMPS_INT *_myid, long long *total_size_io,MUMPS_INT *size_element,MUMPS_INT *nb_file_type,MUMPS_INT *flag_tab, MUMPS_INT keep255); MUMPS_INT mumps_init_file_name(char* mumps_dir,char* mumps_file,MUMPS_INT* mumps_dim_dir,MUMPS_INT* mumps_dim_file,MUMPS_INT* _myid); void mumps_io_init_file_struct(MUMPS_INT* nb,MUMPS_INT which); MUMPS_INT mumps_io_alloc_file_struct(MUMPS_INT* nb,MUMPS_INT which); MUMPS_INT mumps_io_get_nb_files(MUMPS_INT* nb_files, const MUMPS_INT* type); MUMPS_INT mumps_io_get_file_name(MUMPS_INT* indice,char* name,MUMPS_INT* length,MUMPS_INT* type); MUMPS_INT mumps_io_alloc_pointers(MUMPS_INT * nb_file_type, MUMPS_INT * dim); MUMPS_INT mumps_io_init_vars(MUMPS_INT* myid_arg,MUMPS_INT* size_element,MUMPS_INT* async_arg,MUMPS_INT keep255); MUMPS_INT mumps_io_set_file_name(MUMPS_INT* indice,char* name,MUMPS_INT* length,MUMPS_INT* type); MUMPS_INT mumps_io_open_files_for_read(); MUMPS_INT mumps_io_set_last_file(MUMPS_INT* dim,MUMPS_INT* type); MUMPS_INT mumps_io_write__(void *file, void *loc_add, size_t write_size, MUMPS_OFF_T where,MUMPS_INT type); #if ! defined (MUMPS_WIN32) MUMPS_INT mumps_io_write_os_buff__(void *file, void *loc_add, size_t write_size, MUMPS_OFF_T where); MUMPS_INT mumps_io_flush_write__(MUMPS_INT type); #else MUMPS_INT mumps_io_write_win32__(void *file, void *loc_add, size_t write_size, MUMPS_OFF_T where); #endif MUMPS_OFF_T mumps_io_read__(void * file,void * loc_addr,size_t size, MUMPS_OFF_T local_offset,MUMPS_INT type); #if ! defined (MUMPS_WIN32) MUMPS_OFF_T mumps_io_read_os_buff__(void * file,void * loc_addr,size_t size, MUMPS_OFF_T local_offset); #else MUMPS_OFF_T mumps_io_read_win32__(void * file,void * loc_addr,size_t size, MUMPS_OFF_T local_offset); #endif #if ! defined (MUMPS_WIN32) && ! defined (WITHOUT_PTHREAD) # if defined (WITH_PFUNC) MUMPS_INT mumps_io_protect_pointers(); MUMPS_INT mumps_io_unprotect_pointers(); MUMPS_INT mumps_io_init_pointers_lock(); MUMPS_INT mumps_io_destroy_pointers_lock(); # endif /* WITH_PFUNC */ #endif /* MUMPS_WIN32 */ #endif /* MUMPS_IO_BASIC_H */ MUMPS_5.8.1/src/ssol_fwd_aux.F0000664000175000017500000012644415042446437016055 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE SMUMPS_TRAITER_MESSAGE_SOLVE & ( BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, & PTRFAC, IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, & INFO, KEEP, KEEP8, DKEEP, STEP, PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) USE SMUMPS_OOC USE SMUMPS_SOL_LR, ONLY: SMUMPS_SOL_SLAVE_LR_U USE SMUMPS_BUF IMPLICIT NONE INTEGER LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER N, NRHS, LPOOL, LEAF, NBFIN, LRHSINTR INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S( N ) INTEGER IWCB( LIWCB ) INTEGER IW( LIW ) INTEGER PTRICB(KEEP(28)),PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)) REAL WCB( LWCB ), A( LA ) REAL RHSINTR( LRHSINTR, NRHS ) INTEGER, intent(in) :: POSINRHSINTR_FWD(N) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER(8) :: PTRX, PTRY, IFR8 INTEGER IERR, K, JJ, JBDEB, JBFIN, NRHS_B INTEGER :: IWHDLR, LDA_SLAVE INTEGER :: MTYPE_SLAVE INTEGER FINODE, FPERE, LONG, NCB, POSITION, NCV, NPIV INTEGER PDEST, I, IPOSINRHSINTR INTEGER J1 INTEGER(8) :: APOS LOGICAL DUMMY LOGICAL FLAG LOGICAL :: OMP_FLAG EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR REAL ALPHA, ONE PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) INCLUDE 'mumps_headers.h' IF ( MSGTAG .EQ. RACINE_SOLVE ) THEN NBFIN = NBFIN - 1 IF ( NBFIN .eq. 0 ) GOTO 270 ELSE IF (MSGTAG .EQ. ContVec ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LONG, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 IF ( NCB .eq. 0 ) THEN PTRICB(STEP(FINODE)) = -1 ELSE IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN PTRICB(STEP(FINODE)) = NCB + 1 END IF IF ( ( POSIWCB - LONG ) .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = LONG GOTO 260 END IF IF ( POSWCB - PLEFTWCB + 1_8 .LT. & int(LONG,8) * int(NRHS_B,8)) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8+ & int(LONG,8) * int(NRHS_B,8), & INFO(2)) GOTO 260 END IF IF (LONG .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IWCB( 1 ), & LONG, MPI_INTEGER, COMM, IERR ) DO K = 1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PLEFTWCB ), & LONG, MPI_REAL, COMM, IERR ) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1, LONG IPOSINRHSINTR= abs(POSINRHSINTR_FWD(IWCB(I))) RHSINTR(IPOSINRHSINTR,JBDEB+K-1) = & RHSINTR(IPOSINRHSINTR,JBDEB+K-1) + & WCB(PLEFTWCB+I-1) ENDDO END DO PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - LONG ENDIF END IF IF ( PTRICB(STEP(FINODE)) == 1 .OR. & PTRICB(STEP(FINODE)) == -1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 PTRICB(STEP(FINODE)) = 0 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) & 'Internal error 1 SMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() END IF ENDIF ELSEIF ( MSGTAG .EQ. Master2Slave ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPIV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 PTRY = PLEFTWCB PTRX = PLEFTWCB + int(NCV,8) * int(NRHS_B,8) PLEFTWCB = PLEFTWCB + int(NPIV + NCV,8) * int(NRHS_B,8) IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(-POSWCB+PLEFTWCB-1_8,INFO(2)) GO TO 260 END IF DO K=1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PTRY + (K-1) * NCV ), NCV, & MPI_REAL, COMM, IERR ) ENDDO IF ( NPIV .GT. 0 ) THEN DO K=1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PTRX + (K-1)*NPIV ), NPIV, & MPI_REAL, COMM, IERR ) END DO END IF LR_ACTIVATED = (IW(PTRIST(STEP(FINODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(FINODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_SOLVE_GET_OOC_NODE( & FINODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,DUMMY,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF IF ( IW(PTRIST(STEP(FINODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(FINODE))+XXF) MTYPE_SLAVE = 1 CALL SMUMPS_SOL_SLAVE_LR_U( FINODE, IWHDLR, & -9999, & WCB, LWCB, & NPIV, NCV, & PTRX, PTRY, & JBDEB, JBFIN, & MTYPE_SLAVE, KEEP, KEEP8, & INFO(1), INFO(2) ) ELSE APOS = PTRFAC(STEP(FINODE)) IF (KEEP(201) .EQ. 1) THEN MTYPE_SLAVE = 0 LDA_SLAVE = NCV ELSE MTYPE_SLAVE = 1 LDA_SLAVE = NPIV ENDIF CALL SMUMPS_SOLVE_GEMM_UPDATE & ( A, LA, APOS, NPIV, & LDA_SLAVE, & NCV, & NRHS_B, WCB, LWCB, & PTRX, NPIV, & PTRY, NCV, & MTYPE_SLAVE, KEEP, ONE ) ENDIF IF ((KEEP(201).GT.0).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_FREE_FACTORS_FOR_SOLVE(FINODE,PTRFAC, & KEEP(28),A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF PLEFTWCB = PLEFTWCB - int(NPIV,8) * int(NRHS_B,8) PDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & KEEP(199) ) IF ( PDEST .EQ. MYID ) THEN IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN NCB = IW( PTRIST(STEP(FINODE)) + 2 + KEEP(IXSZ) ) PTRICB(STEP(FINODE)) = NCB + 1 END IF J1 = PTRIST(STEP(FINODE))+3+KEEP(IXSZ) OMP_FLAG = .FALSE. !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (NCV*(JBFIN-JBDEB+1) .GE. KEEP(363) ) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(I,JJ,IFR8,IPOSINRHSINTR) DO K=1, NRHS_B IFR8 = PTRY+int(K-1,8)*int(NCV,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1,NCV JJ = IW(J1+I) IPOSINRHSINTR= abs(POSINRHSINTR_FWD(JJ)) RHSINTR(IPOSINRHSINTR,JBDEB+K-1)= & RHSINTR(IPOSINRHSINTR,JBDEB+K-1) & + WCB(IFR8+int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K=1, NRHS_B IFR8 = PTRY+int(K-1,8)*int(NCV,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1,NCV JJ = IW(J1+I) IPOSINRHSINTR= abs(POSINRHSINTR_FWD(JJ)) RHSINTR(IPOSINRHSINTR,JBDEB+K-1)= & RHSINTR(IPOSINRHSINTR,JBDEB+K-1) & + WCB(IFR8+int(I-1,8)) ENDDO ENDDO ENDIF PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - NCV IF ( PTRICB( STEP( FINODE ) ) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 PTRICB(STEP(FINODE)) = 0 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) & 'INTERNAL Error in SMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() END IF ENDIF ELSE 210 CONTINUE CALL SMUMPS_BUF_SEND_VCB( NRHS_B, FINODE, FPERE, & IW(PTRIST(STEP( FINODE )) + 2 + KEEP(IXSZ) ), NCV,NCV, & IW(PTRIST(STEP(FINODE))+4+ KEEP(IXSZ) ), & WCB( PTRY ), JBDEB, JBFIN, & RHSINTR, 1, 1, -9999, -9999, & KEEP, PDEST, ContVec, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 210 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + & NCV * KEEP( 35 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + & NCV * KEEP( 35 ) END IF END IF PLEFTWCB = PLEFTWCB - int(NCV,8) * int(NRHS_B,8) ELSEIF ( MSGTAG .EQ. TERREUR ) THEN INFO(1) = -001 INFO(2) = MSGSOU GOTO 270 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. & (MSGTAG.EQ.TAG_DUMMY) ) THEN GO TO 270 ELSE INFO(1)=-100 INFO(2)=MSGTAG GO TO 260 ENDIF GO TO 270 260 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 270 CONTINUE RETURN END SUBROUTINE SMUMPS_TRAITER_MESSAGE_SOLVE SUBROUTINE SMUMPS_SOLVE_NODE_FWD( INODE, & LASTFSL0STA, LASTFSL0DYN, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, & IWCB, LIWCB, & WCB, LWCB, A, LA, IW, LIW, & NRHS, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & ) USE SMUMPS_SOL_LR !$ USE MUMPS_SOL_L0OMP_M, ONLY: LOCK_FOR_SCATTER USE MUMPS_SOL_L0OMP_M, ONLY: NB_LOCK_MAX USE SMUMPS_OOC USE SMUMPS_BUF IMPLICIT NONE INTEGER MTYPE INTEGER, INTENT( IN ) :: INODE, LASTFSL0STA, LASTFSL0DYN INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER LIWCB, LIW, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB, LWCB INTEGER(8) :: LA INTEGER N, LPOOL, LEAF, NBFIN INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S(KEEP(28)) INTEGER IWCB( LIWCB ), IW( LIW ) INTEGER NRHS REAL WCB( LWCB ) REAL :: A( LA ) INTEGER(8) :: LRHS_ROOT REAL RHS_ROOT( LRHS_ROOT ) INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER FILS( N ), STEP( N ), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSINRHSINTR_FWD(N), LRHSINTR REAL RHSINTR(LRHSINTR, NRHS) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP LOGICAL, intent(out) :: ERROR_WAS_BROADCASTED EXTERNAL sgemv, strsv, sgemm, strsm, MUMPS_PROCNODE INTEGER MUMPS_PROCNODE REAL ALPHA,ONE,ZERO PARAMETER (ZERO=0.0E0, ONE = 1.0E0, ALPHA=-1.0E0) INTEGER :: IWHDLR INTEGER JBDEB, JBFIN, NRHS_B INTEGER LDADIAG INTEGER(8) :: APOS, APOS1, IFR8, IFR_ini8 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, FPERE_MAPPING, & NPIV, NCB, LIELL, JJ, NELIM, IERR INTEGER(8) :: PCB_COURANT, PPIV_COURANT, PPIV_PANEL, PCB_PANEL INTEGER IPOSINRHSINTR_TMP INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex LOGICAL FLAG INTEGER :: NUPDATE_NONCRITICAL, IPOSINRHSINTRLASTFSDYN LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSDEB INTEGER TempNROW, TempNCOL, PANEL_SIZE, & JFIN, NBJ, NUPDATE_PANEL, & TYPEF INTEGER LD_WCBPIV INTEGER LD_WCBCB LOGICAL :: LDEQLIELLPANEL LOGICAL :: CBINITZERO INTEGER LDAJ, LDAJ_FIRST_PANEL INTEGER LDAtemp LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPANEL LOGICAL MUST_BE_PERMUTED INTEGER :: SIZEBLOCK, NB, JCourant, NB_LOCK INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' ERROR_WAS_BROADCASTED = .FALSE. LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IF (DO_NBSPARSE) THEN JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) JBFIN= RHS_BOUNDS(2*STEP(INODE)) ELSE JBDEB = 1 JBFIN = NRHS ENDIF NRHS_B = JBFIN-JBDEB+1 IF (DO_NBSPARSE) THEN if (JBDEB.GT.JBFIN) then write(6,*) " Internal error 1 in nbsparse :", & JBDEB, JBFIN CALL MUMPS_ABORT() endif IF (JBDEB.LT.1 .OR. JBDEB.GT.NRHS .or. & JBFIN.LT.1 .OR. JBFIN.GT.NRHS ) THEN write(6,*) " Internal error 2 in nbsparse :", & JBDEB, JBFIN CALL MUMPS_ABORT() endif ENDIF IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq.KEEP( 20 ) ) THEN LIELL = IW( PTRIST( STEP(INODE)) + 3 + KEEP(IXSZ)) NPIV = LIELL NELIM = 0 NSLAVES = 0 IPOS = PTRIST( STEP(INODE)) + 5 + KEEP(IXSZ) ELSE IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 NPIV = IW(IPOS) IPOS = IPOS + 1 IF ((KEEP(201).GT.0).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL SMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL+1+NSLAVES), & MUST_BE_PERMUTED ) ENDIF ENDIF NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IPOS = IPOS + 1 + NSLAVES END IF IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J2 = IPOS + LIELL J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J2 = IPOS + 2 * LIELL J3 = IPOS + LIELL + NPIV END IF NCB = LIELL-NPIV IF (KEEP(50).NE.0) THEN IF ( KEEP(459) .GT. 1 ) THEN LDADIAG = -99999 ELSE LDADIAG = NPIV ENDIF ELSE LDADIAG = LIELL ENDIF IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq. KEEP(20) ) THEN IFR8 = 0_8 IPOSINRHSINTR_TMP = POSINRHSINTR_FWD(IW(J1)) IFR_ini8 = IFR8 OMP_FLAG = .FALSE. !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(IFR8,JJ) DO K=1,NRHS IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 RHS_ROOT(IFR8+int(JJ-J1+1,8)) = & RHSINTR(IPOSINRHSINTR_TMP+JJ-J1,K) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K=1,NRHS IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 RHS_ROOT(IFR8+int(JJ-J1+1,8)) = & RHSINTR(IPOSINRHSINTR_TMP+JJ-J1,K) ENDDO ENDDO ENDIF IF ( NPIV .LT. LIELL ) THEN WRITE(*,*) ' Internal error 1 in SMUMPS_SOLVE_NODE_FWD', & NPIV, LIELL CALL MUMPS_ABORT() END IF GO TO 270 END IF APOS = PTRFAC(STEP(INODE)) IF ( (KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR ) THEN IF (MTYPE.EQ.1) THEN IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN TempNROW= NPIV+NELIM TempNCOL= NPIV LDAJ_FIRST_PANEL=TempNROW ELSE TempNROW= LIELL TempNCOL= NPIV LDAJ_FIRST_PANEL=TempNROW ENDIF TYPEF=TYPEF_L ELSE TempNCOL= LIELL TempNROW= NPIV LDAJ_FIRST_PANEL=TempNCOL TYPEF= TYPEF_U ENDIF PANEL_SIZE = SMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) ENDIF PPIV_COURANT = PLEFTWCB PLEFTWCB = PLEFTWCB + int(LIELL,8) * int(NRHS_B,8) IF ( POSWCB - PLEFTWCB + 1_8 .LT. 0 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8, INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF IF (KEEP(201) .EQ. 1 .AND. OOCWRITE_COMPATIBLE_WITH_BLR) THEN LDEQLIELLPANEL = .TRUE. LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV ELSE LDEQLIELLPANEL = .FALSE. LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + int(NPIV,8)*int(NRHS_B,8) ENDIF FPERE = DAD(STEP(INODE)) IF ( FPERE .NE. 0 ) THEN FPERE_MAPPING = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & KEEP(199) ) ELSE FPERE_MAPPING = -1 ENDIF IF ( LASTFSL0DYN .LE. N ) THEN CBINITZERO = .TRUE. ELSE IF ( FPERE_MAPPING .EQ. MYID ) THEN CBINITZERO = .TRUE. ELSE CBINITZERO = .FALSE. ENDIF CALL SMUMPS_RHSINTR_TO_WCB( & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL, & RHSINTR(1, JBDEB), LRHSINTR, NRHS_B, & POSINRHSINTR_FWD, N, & WCB(PPIV_COURANT), & IW, LIW, J1, J3, J2, KEEP, DKEEP) IF ( NPIV .NE. 0 ) THEN IF ((KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN APOSDEB = APOS J = 1 IPANEL = 0 10 CONTINUE IPANEL = IPANEL + 1 JFIN = min(J+PANEL_SIZE-1, NPIV) IF (IW(IPOS+ LIELL + JFIN) < 0) THEN JFIN=JFIN+1 ENDIF NBJ = JFIN-J+1 LDAJ = LDAJ_FIRST_PANEL-J+1 IF ( (KEEP(50).NE.1).AND. MUST_BE_PERMUTED ) THEN CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS+1+2*LIELL, IW, LIW) IF (NPIV.EQ.(IW(I_PIVRPTR+IPANEL-1)-1)) THEN MUST_BE_PERMUTED=.FALSE. ELSE CALL SMUMPS_PERMUTE_PANEL( & IW( I_PIVR+ IW(I_PIVRPTR+IPANEL-1)- & IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, J-1 ) ENDIF ENDIF NUPDATE_PANEL = LDAJ - NBJ PPIV_PANEL = PPIV_COURANT+int(J-1,8) PCB_PANEL = PPIV_PANEL+int(NBJ,8) APOS1 = APOSDEB+int(NBJ,8) IF (MTYPE.EQ.1) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL strsv( 'L', 'N', 'U', NBJ, A(APOSDEB), LDAJ, & WCB(PPIV_PANEL), 1 ) IF (NUPDATE_PANEL.GT.0) THEN CALL sgemv('N', NUPDATE_PANEL,NBJ,ALPHA, A(APOS1), & LDAJ, WCB(PPIV_PANEL), 1, ONE, & WCB(PCB_PANEL), 1) ENDIF ELSE #endif CALL strsm( 'L','L','N','U', NBJ, NRHS_B, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL ) IF (NUPDATE_PANEL.GT.0) THEN CALL sgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF (NRHS_B == 1) THEN CALL strsv( 'L', 'N', 'N', NBJ, A(APOSDEB), LDAJ, & WCB(PPIV_PANEL), 1 ) IF (NUPDATE_PANEL.GT.0) THEN CALL sgemv('N',NUPDATE_PANEL, NBJ, ALPHA, A(APOS1), & LDAJ, WCB(PPIV_PANEL), 1, & ONE, WCB(PCB_PANEL), 1 ) ENDIF ELSE #endif CALL strsm('L','L','N','N',NBJ, NRHS_B, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL) IF (NUPDATE_PANEL.GT.0) THEN CALL sgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF APOSDEB = APOSDEB+int(LDAJ,8)*int(NBJ,8) J=JFIN+1 IF ( J .LE. NPIV ) GOTO 10 ELSE IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL SMUMPS_SOL_FWD_LR_SU ( & INODE, N, IWHDLR, NPIV, NSLAVES, & IW, IPOS, LIW, & LIELL, WCB, LWCB, & LD_WCBPIV, LD_WCBCB, & PPIV_COURANT, PCB_COURANT, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, KEEP8, OOCWRITE_COMPATIBLE_WITH_BLR, & INFO(1), INFO(2) ) IF (INFO(1).LT.0) THEN ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF ELSE IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 ) THEN CALL SMUMPS_SOLVE_FWD_PANELS( & A, LA, APOS, & NPIV, IW(IPOS+LIELL+1), & NRHS_B, WCB, LWCB, LD_WCBPIV, & PPIV_COURANT, MTYPE, KEEP) ELSE CALL SMUMPS_SOLVE_FWD_TRSOLVE ( & A, LA, APOS, & NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LD_WCBPIV, & PPIV_COURANT, MTYPE, KEEP) ENDIF END IF END IF NCB = LIELL - NPIV IF ( MTYPE .EQ. 1 ) THEN IF ( NSLAVES .EQ. 0 .OR. NPIV .eq. 0 ) THEN NUPDATE = NCB ELSE NUPDATE = NELIM END IF IF (KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0) THEN CALL MUMPS_GETI8(APOS1, IW(PTRIST(STEP(INODE))+XXR)) APOS1 = APOS + APOS1 - int(NPIV,8)*int(NUPDATE,8) ELSE APOS1 = APOS + int(NPIV,8) * int(LDADIAG,8) ENDIF ELSE APOS1 = APOS + int(NPIV,8) NUPDATE = NCB END IF IF (KEEP(201).NE.1) THEN IF ( IW(PTRIST(STEP(INODE))+XXLR) .LT. 2 .OR. & KEEP(485).EQ.0) THEN IF (MTYPE .EQ. 1) THEN LDAtemp = NPIV ELSE LDAtemp = LIELL ENDIF CALL SMUMPS_SOLVE_GEMM_UPDATE & (A, LA, APOS1, & NPIV, LDAtemp, NUPDATE, & NRHS_B, WCB, LWCB, PPIV_COURANT, LD_WCBPIV, & PCB_COURANT, LD_WCBCB, & MTYPE, KEEP, ONE) ENDIF END IF IF ( IW(PTRIST(STEP(INODE))+XXLR) .LT. 2 .OR. & KEEP(485).EQ.0) THEN IF (KEEP(201) .GT. 0 .AND. OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_SOL_LD_AND_RELOAD( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & .FALSE. & ) ELSE CALL SMUMPS_SOL_LD_AND_RELOAD_PANEL ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & .FALSE. & ) ENDIF ENDIF IF ((KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR) &THEN CALL SMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF END IF IF ( FPERE .EQ. 0 ) THEN PLEFTWCB = PLEFTWCB - int(LIELL,8) *int(NRHS_B,8) GOTO 270 ENDIF IF ( NUPDATE .NE. 0 .OR. NCB.EQ.0 ) THEN IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID) THEN IF ( NCB .ne. 0 ) THEN PTRICB(STEP(INODE)) = NCB + 1 NUPDATE_NONCRITICAL = NUPDATE IF (LASTFSL0DYN .LE. N) THEN IF ( LASTFSL0DYN .EQ. 0 ) THEN IPOSINRHSINTRLASTFSDYN = 0 ELSE IPOSINRHSINTRLASTFSDYN = & abs(POSINRHSINTR_FWD(LASTFSL0DYN)) ENDIF DO I = 1, NUPDATE IF ( abs(POSINRHSINTR_FWD( IW(J3+I) )) .GT. & IPOSINRHSINTRLASTFSDYN ) THEN IF (abs(STEP(IW(J3+I))) .GT. & abs(STEP( LASTFSL0STA)) & .OR. KEEP(261) .NE. 1) THEN NUPDATE_NONCRITICAL = I - 1 EXIT ENDIF ENDIF ENDDO ENDIF OMP_FLAG = .FALSE. !$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND. !$ & (NUPDATE*NRHS_B .GE. KEEP(363)) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(I,IFR8,IPOSINRHSINTR_TMP) DO K = JBDEB, JBFIN IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1, NUPDATE_NONCRITICAL IPOSINRHSINTR_TMP = & abs(POSINRHSINTR_FWD(IW(J3 + I))) RHSINTR( IPOSINRHSINTR_TMP, K ) = & RHSINTR( IPOSINRHSINTR_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K = JBDEB, JBFIN IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1, NUPDATE_NONCRITICAL IPOSINRHSINTR_TMP = & abs(POSINRHSINTR_FWD(IW(J3 + I))) RHSINTR( IPOSINRHSINTR_TMP, K ) = & RHSINTR( IPOSINRHSINTR_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO ENDIF IF ( CBINITZERO ) THEN IF ( NUPDATE .NE. NUPDATE_NONCRITICAL) THEN NB_LOCK = 1 IF ( KEEP(400) .GT. 1 ) THEN NB_LOCK = min(KEEP(400),NB_LOCK_MAX) ENDIF SIZEBLOCK = (NRHS+NB_LOCK-1) / NB_LOCK DO NB = 1 + (JBDEB-1)/SIZEBLOCK, NB_LOCK JCourant = 1+SIZEBLOCK*(NB-1) IF ( JCourant .GT. JBFIN ) EXIT !$ CALL OMP_SET_LOCK(LOCK_FOR_SCATTER(NB)) DO K = max(Jcourant,JBDEB), & min(JBFIN,Jcourant+SIZEBLOCK-1) IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = NUPDATE_NONCRITICAL+1, NUPDATE IPOSINRHSINTR_TMP = & abs(POSINRHSINTR_FWD(IW(J3 + I))) RHSINTR( IPOSINRHSINTR_TMP, K ) = & RHSINTR( IPOSINRHSINTR_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO !$ CALL OMP_UNSET_LOCK(LOCK_FOR_SCATTER(NB)) ENDDO ENDIF ENDIF PTRICB(STEP( INODE )) = PTRICB(STEP( INODE )) - NUPDATE ELSE PTRICB(STEP( INODE )) = -1 ENDIF ELSE 210 CONTINUE CALL SMUMPS_BUF_SEND_VCB( NRHS_B, INODE, FPERE, & NCB, LD_WCBCB, & NUPDATE, & IW( J3 + 1 ), WCB( PCB_COURANT ), JBDEB, JBFIN, & RHSINTR, 1, 1, -9999, -9999, & KEEP, & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), KEEP(199)), & ContVec, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. GOTO 270 ENDIF GOTO 210 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF ENDIF END IF IF ( NSLAVES .NE. 0 .AND. MTYPE .eq. 1 & .and. NPIV .NE. 0 ) THEN DO ISLAVE = 1, NSLAVES PDEST = IW( PTRIST(STEP(INODE)) + 5 + ISLAVE +KEEP(IXSZ)) CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB - NELIM, & NSLAVES, & Effective_CB_Size, FirstIndex ) 222 CONTINUE CALL SMUMPS_BUF_SEND_MASTER2SLAVE( NRHS_B, & INODE, FPERE, & Effective_CB_Size, LD_WCBCB, LD_WCBPIV, NPIV, & JBDEB, JBFIN, & WCB( PCB_COURANT + NELIM + FirstIndex - 1 ), & WCB( PPIV_COURANT ), & PDEST, COMM, KEEP, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. GOTO 270 ENDIF GOTO 222 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF END DO END IF PLEFTWCB = PLEFTWCB - int(LIELL,8)*int(NRHS_B,8) 270 CONTINUE RETURN END SUBROUTINE SMUMPS_SOLVE_NODE_FWD RECURSIVE SUBROUTINE SMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) IMPLICIT NONE LOGICAL BLOQ INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER N, NRHS, LPOOL, LEAF, NBFIN INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ), IPOOL(LPOOL) INTEGER NSTK_S( KEEP(28) ) INTEGER IWCB( LIWCB ) INTEGER IW( LIW ) REAL WCB( LWCB ), A( LA ) INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)) LOGICAL FLAG INTEGER LRHSINTR, POSINRHSINTR_FWD(N) REAL RHSINTR(LRHSINTR,NRHS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGSOU, MSGTAG, MSGLEN FLAG = .FALSE. IF ( BLOQ ) THEN FLAG = .FALSE. CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF ( FLAG ) THEN KEEP(266) = KEEP(266) -1 MSGSOU = STATUS( MPI_SOURCE ) MSGTAG = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN INFO(1) = -20 INFO(2) = MSGLEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ELSE CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, & MSGSOU, MSGTAG, COMM, STATUS, IERR ) CALL SMUMPS_TRAITER_MESSAGE_SOLVE( BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) END IF END IF RETURN END SUBROUTINE SMUMPS_SOLVE_RECV_AND_TREAT SUBROUTINE SMUMPS_RHSINTR_TO_WCB( & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL, & RHSINTR, LRHSINTR, NRHS_B, & POSINRHSINTR_FWD, N, & WCB, & IW, LIW, J1, J3, J2, KEEP, DKEEP) IMPLICIT NONE INTEGER, INTENT( IN ) :: NPIV, NCB, LIELL, N, & LRHSINTR, NRHS_B, & LIW, J1, J2, J3 LOGICAL, INTENT( IN ) :: LDEQLIELLPANEL LOGICAL, INTENT( IN ) :: CBINITZERO INTEGER, INTENT( IN ) :: POSINRHSINTR_FWD( N ), IW( LIW ) REAL, INTENT( INOUT ) :: RHSINTR( LRHSINTR, NRHS_B ) REAL, INTENT( OUT ) :: WCB( int(LIELL,8)* & int(NRHS_B,8) ) INTEGER :: KEEP(500) REAL :: DKEEP(150) INTEGER, PARAMETER :: ZERO = 0.0E0 INTEGER(8), PARAMETER :: PPIV_COURANT = 1_8 INTEGER(8) :: PCB_COURANT INTEGER :: LD_WCBCB, LD_WCBPIV, J, JJ, K, IPOSINRHSINTR INTEGER(8) :: IFR8, IFR_ini8 INCLUDE 'mpif.h' LOGICAL :: OMP_FLAG IF ( LDEQLIELLPANEL ) THEN LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV ELSE LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + NPIV * NRHS_B ENDIF IF ( LDEQLIELLPANEL ) THEN DO K=1, NRHS_B IFR8 = PPIV_COURANT+int(K-1,8)*int(LD_WCBPIV,8)-1_8 IPOSINRHSINTR = POSINRHSINTR_FWD(IW(J1)) DO JJ = J1, J3 IFR8 = IFR8 + 1_8 WCB(IFR8) = RHSINTR(IPOSINRHSINTR,K) IPOSINRHSINTR = IPOSINRHSINTR + 1 ENDDO IF (NCB.GT.0 .AND. .NOT. CBINITZERO) THEN #if defined(__ve__) !NEC$ IVDEP #endif DO JJ = J3+1, J2 J = IW(JJ) IFR8 = IFR8 + 1_8 IPOSINRHSINTR = abs(POSINRHSINTR_FWD(J)) WCB(IFR8) = RHSINTR(IPOSINRHSINTR,K) RHSINTR (IPOSINRHSINTR,K) = ZERO ENDDO ENDIF ENDDO ELSE PCB_COURANT = PPIV_COURANT + LD_WCBPIV*NRHS_B IFR8 = PPIV_COURANT - 1_8 IFR_ini8 = IFR8 IPOSINRHSINTR = POSINRHSINTR_FWD(IW(J1)) OMP_FLAG = .FALSE. !$ OMP_FLAG = ( NRHS_B .GE. KEEP(362) .AND. !$ & int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(JJ,IFR8) DO K=1, NRHS_B IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 WCB(IFR8+int(JJ-J1+1,8)) = & RHSINTR(IPOSINRHSINTR+JJ-J1,K) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K=1, NRHS_B IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 WCB(IFR8+int(JJ-J1+1,8)) = & RHSINTR(IPOSINRHSINTR+JJ-J1,K) ENDDO ENDDO ENDIF IFR8 = PCB_COURANT - 1_8 IF (NCB.GT.0 .AND. .NOT. CBINITZERO) THEN IFR_ini8 = IFR8 OMP_FLAG = .FALSE. !$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND. !$ & NCB*NRHS_B .GE. KEEP(363) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE (IFR8, JJ, J, IPOSINRHSINTR) DO K=1, NRHS_B IFR8 = IFR_ini8+(K-1)*NCB #if defined(__ve__) !NEC$ IVDEP #endif DO JJ = J3 + 1, J2 J = IW(JJ) IPOSINRHSINTR = abs(POSINRHSINTR_FWD(J)) WCB(IFR8+int(JJ-J3,8)) = RHSINTR(IPOSINRHSINTR,K) RHSINTR(IPOSINRHSINTR,K)=ZERO ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K=1, NRHS_B IFR8 = IFR_ini8+(K-1)*NCB #if defined(__ve__) !NEC$ IVDEP #endif DO JJ = J3 + 1, J2 J = IW(JJ) IPOSINRHSINTR = abs(POSINRHSINTR_FWD(J)) WCB(IFR8+int(JJ-J3,8)) = RHSINTR(IPOSINRHSINTR,K) RHSINTR(IPOSINRHSINTR,K)=ZERO ENDDO ENDDO ENDIF ENDIF ENDIF IF ( CBINITZERO ) THEN OMP_FLAG = .FALSE. !$ OMP_FLAG = int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) IF (OMP_FLAG) THEN !$OMP PARALLEL DO COLLAPSE(2) DO K = 1, NRHS_B DO JJ = 1, NCB WCB(PCB_COURANT+int(K-1,8)*int(LD_WCBCB,8)+JJ-1_8) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K = 1, NRHS_B DO JJ = 1, NCB WCB(PCB_COURANT+int(K-1,8)*int(LD_WCBCB,8)+JJ-1_8) = ZERO ENDDO ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_RHSINTR_TO_WCB MUMPS_5.8.1/src/cana_mtrans.F0000664000175000017500000007732215042446441015641 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C History: C ------- C This maximum transversal set of routines are C based on the work done by Jacko Koster at CERFACS for C his PhD thesis from Institut National Polytechnique de Toulouse C at CERFACS (1995-1997) and includes modifications provided C by the author as well as work done by Stephane Pralet C first at CERFACS during his PhD thesis (2003-2004) then C at INPT-IRIT (2004-2005) during his post-doctoral position. C C The main research publication references for this work are: C [1] I. S. Duff, (1981), C "Algorithm 575. Permutations for a zero-free diagonal", C ACM Trans. Math. Software 7(3), 387-390. C [2] I. S. Duff and J. Koster, (1998), C "The design and use of algorithms for permuting large C entries to the diagonal of sparse matrices", C SIAM J. Matrix Anal. Appl., vol. 20, no. 4, pp. 889-901. C [3] I. S. Duff and J. Koster, (2001), C "On algorithms for permuting large entries to the diagonal C of sparse matrices", C SIAM J. Matrix Anal. Appl., vol. 22, no. 4, pp. 973-996. C SUBROUTINE CMUMPS_MTRANSI(ICNTL,CNTL) IMPLICIT NONE INTEGER NICNTL, NCNTL PARAMETER (NICNTL=10, NCNTL=10) INTEGER ICNTL(NICNTL) REAL CNTL(NCNTL) INTEGER I ICNTL(1) = 6 ICNTL(2) = 6 ICNTL(3) = -1 ICNTL(4) = -1 ICNTL(5) = 0 DO 10 I = 6,NICNTL ICNTL(I) = 0 10 CONTINUE CNTL(1) = 0.0E0 CNTL(2) = 0.0E0 DO 20 I = 3,NCNTL CNTL(I) = 0.0E0 20 CONTINUE RETURN END SUBROUTINE CMUMPS_MTRANSI SUBROUTINE CMUMPS_MTRANSB & (M,N,NE,IP,IRN,A,IPERM,NUM,JPERM,PR,Q,L,D,RINF) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: NE INTEGER :: IRN(NE),IPERM(M),JPERM(N),Q(M),L(M) INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER(8), INTENT(OUT) :: PR(N) REAL :: A(NE) REAL :: D(M), RINF INTEGER :: I,II,J,JJ,JORD,Q0,QLEN,IDUM,JDUM,ISP,JSP, & I0,UP,LOW, IK INTEGER(8) :: K,KK,KK1,KK2 REAL CSP,DI,DNEW,DQ0,AI,A0,BV,TBV,RLX REAL ZERO,MINONE,ONE PARAMETER (ZERO=0.0E0,MINONE=-1.0E0,ONE=1.0E0) INTRINSIC abs,min EXTERNAL CMUMPS_MTRANSD, CMUMPS_MTRANSE, & CMUMPS_MTRANSF, CMUMPS_MTRANSX RLX = D(1) NUM = 0 BV = RINF DO 10 I = 1,N JPERM(I) = 0 PR(I) = IP(I) 10 CONTINUE DO 12 I = 1,M IPERM(I) = 0 D(I) = ZERO 12 CONTINUE DO 30 J = 1,N A0 = MINONE DO 20 K = IP(J),IP(J+1)-1_8 I = IRN(K) AI = abs(A(K)) IF (AI.GT.D(I)) D(I) = AI IF (JPERM(J).NE.0) GO TO 20 IF (AI.GE.BV) THEN A0 = BV IF (IPERM(I).NE.0) GO TO 20 JPERM(J) = I IPERM(I) = J NUM = NUM + 1 ELSE IF (AI.LE.A0) GO TO 20 A0 = AI I0 = I ENDIF 20 CONTINUE IF (A0.NE.MINONE .AND. A0.LT.BV) THEN BV = A0 IF (IPERM(I0).NE.0) GO TO 30 IPERM(I0) = J JPERM(J) = I0 NUM = NUM + 1 ENDIF 30 CONTINUE IF (M.EQ.N) THEN DO 35 I = 1,M BV = min(BV,D(I)) 35 CONTINUE ENDIF IF (NUM.EQ.N) GO TO 1000 DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 DO 50 K = IP(J),IP(J+1)-1_8 I = IRN(K) AI = abs(A(K)) IF (AI.LT.BV) GO TO 50 IF (IPERM(I).EQ.0) GO TO 90 JJ = IPERM(I) KK1 = PR(JJ) KK2 = IP(JJ+1) - 1_8 IF (KK1.GT.KK2) GO TO 50 DO 70 KK = KK1,KK2 II = IRN(KK) IF (IPERM(II).NE.0) GO TO 70 IF (abs(A(KK)).GE.BV) GO TO 80 70 CONTINUE PR(JJ) = KK2 + 1_8 50 CONTINUE GO TO 95 80 JPERM(JJ) = II IPERM(II) = JJ PR(JJ) = KK + 1_8 90 NUM = NUM + 1 JPERM(J) = I IPERM(I) = J PR(J) = K + 1_8 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = MINONE L(I) = 0 99 CONTINUE TBV = BV * (ONE-RLX) DO 100 JORD = 1,N IF (JPERM(JORD).NE.0) GO TO 100 QLEN = 0 LOW = M + 1 UP = M + 1 CSP = MINONE J = JORD PR(J) = -1_8 DO 115 K = IP(J),IP(J+1)-1_8 I = IRN(K) DNEW = abs(A(K)) IF (CSP.GE.DNEW) GO TO 115 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = I JSP = J IF (CSP.GE.TBV) GO TO 160 ELSE D(I) = DNEW IF (DNEW.GE.TBV) THEN LOW = LOW - 1 Q(LOW) = I ELSE QLEN = QLEN + 1 L(I) = QLEN CALL CMUMPS_MTRANSD(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = int(J,8) ENDIF 115 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = Q(1) IF (CSP.GE.D(I)) GO TO 160 BV = D(I) TBV = BV * (ONE-RLX) DO 152 IDUM = 1,M CALL CMUMPS_MTRANSE(QLEN,M,Q,D,L,1) L(I) = 0 LOW = LOW - 1 Q(LOW) = I IF (QLEN.EQ.0) GO TO 153 I = Q(1) IF (D(I).LT.TBV) GO TO 153 152 CONTINUE ENDIF 153 UP = UP - 1 Q0 = Q(UP) DQ0 = D(Q0) L(Q0) = UP J = IPERM(Q0) DO 155 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (L(I).GE.UP) GO TO 155 DNEW = min(DQ0,abs(A(K))) IF (CSP.GE.DNEW) GO TO 155 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = I JSP = J IF (CSP.GE.TBV) GO TO 160 ELSE DI = D(I) IF (DI.GE.TBV .OR. DI.GE.DNEW) GO TO 155 D(I) = DNEW IF (DNEW.GE.TBV) THEN IF (DI.NE.MINONE) THEN CALL CMUMPS_MTRANSF(L(I),QLEN,M,Q,D,L,1) ENDIF L(I) = 0 LOW = LOW - 1 Q(LOW) = I ELSE IF (DI.EQ.MINONE) THEN QLEN = QLEN + 1 L(I) = QLEN ENDIF CALL CMUMPS_MTRANSD(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = int(J,8) ENDIF 155 CONTINUE 150 CONTINUE 160 IF (CSP.EQ.MINONE) GO TO 190 BV = min(BV,CSP) TBV = BV * (ONE-RLX) NUM = NUM + 1 I = ISP J = JSP DO 170 JDUM = 1,NUM+1 I0 = JPERM(J) JPERM(J) = I IPERM(I) = J J = int(PR(J)) IF (J.EQ.-1) GO TO 190 I = I0 170 CONTINUE 190 DO 191 IK = UP,M I = Q(IK) D(I) = MINONE L(I) = 0 191 CONTINUE DO 192 IK = LOW,UP-1 I = Q(IK) D(I) = MINONE 192 CONTINUE DO 193 IK = 1,QLEN I = Q(IK) D(I) = MINONE L(I) = 0 193 CONTINUE 100 CONTINUE 1000 IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL CMUMPS_MTRANSX(M,N,IPERM,L,JPERM) 2000 RETURN END SUBROUTINE CMUMPS_MTRANSB SUBROUTINE CMUMPS_MTRANSD(I,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER I,N,IWAY INTEGER Q(N),L(N) REAL D(N) INTEGER IDUM,K,POS,POSK,QK PARAMETER (K=2) REAL DI POS = L(I) IF (POS.LE.1) GO TO 20 DI = D(I) IF (IWAY.EQ.1) THEN DO 10 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.LE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 10 CONTINUE ELSE DO 15 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.GE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 15 CONTINUE ENDIF 20 Q(POS) = I L(I) = POS RETURN END SUBROUTINE CMUMPS_MTRANSD SUBROUTINE CMUMPS_MTRANSE(QLEN,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER QLEN,N,IWAY INTEGER Q(N),L(N) REAL D(N) INTEGER I,IDUM,K,POS,POSK PARAMETER (K=2) REAL DK,DR,DI I = Q(QLEN) DI = D(I) QLEN = QLEN - 1 POS = 1 IF (IWAY.EQ.1) THEN DO 10 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 20 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.LT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.GE.DK) GO TO 20 Q(POS) = Q(POSK) L(Q(POS)) = POS POS = POSK 10 CONTINUE ELSE DO 15 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 20 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.GT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.LE.DK) GO TO 20 Q(POS) = Q(POSK) L(Q(POS)) = POS POS = POSK 15 CONTINUE ENDIF 20 Q(POS) = I L(I) = POS RETURN END SUBROUTINE CMUMPS_MTRANSE SUBROUTINE CMUMPS_MTRANSF(POS0,QLEN,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER POS0,QLEN,N,IWAY INTEGER Q(N),L(N) REAL D(N) INTEGER I,IDUM,K,POS,POSK,QK PARAMETER (K=2) REAL DK,DR,DI IF (QLEN.EQ.POS0) THEN QLEN = QLEN - 1 RETURN ENDIF I = Q(QLEN) DI = D(I) QLEN = QLEN - 1 POS = POS0 IF (IWAY.EQ.1) THEN IF (POS.LE.1) GO TO 20 DO 10 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.LE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 10 CONTINUE 20 Q(POS) = I L(I) = POS IF (POS.NE.POS0) RETURN DO 30 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 40 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.LT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.GE.DK) GO TO 40 QK = Q(POSK) Q(POS) = QK L(QK) = POS POS = POSK 30 CONTINUE ELSE IF (POS.LE.1) GO TO 34 DO 32 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.GE.D(QK)) GO TO 34 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 34 32 CONTINUE 34 Q(POS) = I L(I) = POS IF (POS.NE.POS0) RETURN DO 36 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 40 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.GT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.LE.DK) GO TO 40 QK = Q(POSK) Q(POS) = QK L(QK) = POS POS = POSK 36 CONTINUE ENDIF 40 Q(POS) = I L(I) = POS RETURN END SUBROUTINE CMUMPS_MTRANSF SUBROUTINE CMUMPS_MTRANSQ(IP,LENL,LENH,W,WLEN,A,NVAL,VAL) IMPLICIT NONE INTEGER ::WLEN,NVAL INTEGER :: LENL(*),LENH(*),W(*) INTEGER(8) :: IP(*) REAL :: A(*),VAL INTEGER XX,J,K,S,POS INTEGER(8) :: II PARAMETER (XX=10) REAL SPLIT(XX),HA NVAL = 0 DO 10 K = 1,WLEN J = W(K) DO 15 II = IP(J)+int(LENL(J),8),IP(J)+int(LENH(J)-1,8) HA = A(II) IF (NVAL.EQ.0) THEN SPLIT(1) = HA NVAL = 1 ELSE DO 20 S = NVAL,1,-1 IF (SPLIT(S).EQ.HA) GO TO 15 IF (SPLIT(S).GT.HA) THEN POS = S + 1 GO TO 21 ENDIF 20 CONTINUE POS = 1 21 DO 22 S = NVAL,POS,-1 SPLIT(S+1) = SPLIT(S) 22 CONTINUE SPLIT(POS) = HA NVAL = NVAL + 1 ENDIF IF (NVAL.EQ.XX) GO TO 11 15 CONTINUE 10 CONTINUE 11 IF (NVAL.GT.0) VAL = SPLIT((NVAL+1)/2) RETURN END SUBROUTINE CMUMPS_MTRANSQ SUBROUTINE CMUMPS_MTRANSR(N,NE,IP,IRN,A) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NE INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NE) REAL, INTENT(INOUT) :: A(NE) INTEGER :: THRESH,TDLEN PARAMETER (THRESH=15,TDLEN=50) INTEGER :: J, LEN, HI INTEGER(8) :: K, IPJ, TD, FIRST, LAST, MID, R, S REAL :: HA, KEY INTEGER(8) :: TODO(TDLEN) DO 100 J = 1,N LEN = int(IP(J+1) - IP(J)) IF (LEN.LE.1) GO TO 100 IPJ = IP(J) IF (LEN.LT.THRESH) GO TO 400 TODO(1) = IPJ TODO(2) = IPJ +int(LEN,8) TD = 2_8 500 CONTINUE FIRST = TODO(TD-1) LAST = TODO(TD) KEY = A((FIRST+LAST)/2) DO 475 K = FIRST,LAST-1 HA = A(K) IF (HA.EQ.KEY) GO TO 475 IF (HA.GT.KEY) GO TO 470 KEY = HA GO TO 470 475 CONTINUE TD = TD - 2_8 GO TO 425 470 MID = FIRST DO 450 K = FIRST,LAST-1 IF (A(K).LE.KEY) GO TO 450 HA = A(MID) A(MID) = A(K) A(K) = HA HI = IRN(MID) IRN(MID) = IRN(K) IRN(K) = HI MID = MID + 1 450 CONTINUE IF (MID-FIRST.GE.LAST-MID) THEN TODO(TD+2) = LAST TODO(TD+1) = MID TODO(TD) = MID ELSE TODO(TD+2) = MID TODO(TD+1) = FIRST TODO(TD) = LAST TODO(TD-1) = MID ENDIF TD = TD + 2_8 425 CONTINUE IF (TD.EQ.0_8) GO TO 400 IF (TODO(TD)-TODO(TD-1).GE.int(THRESH,8)) GO TO 500 TD = TD - 2_8 GO TO 425 400 DO 200 R = IPJ+1_8,IPJ+int(LEN-1,8) IF (A(R-1) .LT. A(R)) THEN HA = A(R) HI = IRN(R) A(R) = A(R-1_8) IRN(R) = IRN(R-1_8) DO 300 S = R-1,IPJ+1_8,-1_8 IF (A(S-1) .LT. HA) THEN A(S) = A(S-1) IRN(S) = IRN(S-1) ELSE A(S) = HA IRN(S) = HI GO TO 200 END IF 300 CONTINUE A(IPJ) = HA IRN(IPJ) = HI END IF 200 CONTINUE 100 CONTINUE RETURN END SUBROUTINE CMUMPS_MTRANSR SUBROUTINE CMUMPS_MTRANSS(M,N,NE,IP,IRN,A,IPERM,NUMX, & W,LEN,LENL,LENH,FC,IW,IW4,RLX,RINF) IMPLICIT NONE INTEGER, INTENT(IN) :: M,N INTEGER(8), INTENT(IN) :: NE INTEGER, INTENT(OUT) :: NUMX INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER :: IRN(NE),IPERM(N), & W(N),LEN(N),LENL(N),LENH(N),FC(N),IW(M),IW4(3*N+M) REAL A(NE),RLX,RINF INTEGER :: NUM,NVAL,WLEN,I,J,L,CNT,MOD, IDUM INTEGER(8) :: K, II, KDUM1, KDUM2 REAL :: BVAL,BMIN,BMAX EXTERNAL CMUMPS_MTRANSQ,CMUMPS_MTRANSU,CMUMPS_MTRANSX DO 20 J = 1,N FC(J) = J LEN(J) = int(IP(J+1) - IP(J)) 20 CONTINUE DO 21 I = 1,M IW(I) = 0 21 CONTINUE CNT = 1 MOD = 1 NUMX = 0 CALL CMUMPS_MTRANSU(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW, & NUMX,N, & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) NUM = NUMX IF (NUM.NE.N) THEN BMAX = RINF ELSE BMAX = RINF DO 30 J = 1,N BVAL = 0.0E0 DO 25 K = IP(J),IP(J+1)-1_8 IF (A(K).GT.BVAL) BVAL = A(K) 25 CONTINUE IF (BVAL.LT.BMAX) BMAX = BVAL 30 CONTINUE BMAX = 1.001E0 * BMAX ENDIF BVAL = 0.0E0 BMIN = 0.0E0 WLEN = 0 DO 48 J = 1,N L = int(IP(J+1) - IP(J)) LENH(J) = L LEN(J) = L DO 45 K = IP(J),IP(J+1)-1_8 IF (A(K).LT.BMAX) GO TO 46 45 CONTINUE K = IP(J+1) 46 LENL(J) = int(K - IP(J)) IF (LENL(J).EQ.L) GO TO 48 WLEN = WLEN + 1 W(WLEN) = J 48 CONTINUE DO 90 KDUM1 = 1_8,NE IF (NUM.EQ.NUMX) THEN DO 50 I = 1,M IPERM(I) = IW(I) 50 CONTINUE DO 80 KDUM2 = 1_8,NE BMIN = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL CMUMPS_MTRANSQ(IP,LENL,LEN,W,WLEN,A,NVAL,BVAL) IF (NVAL.LE.1) GO TO 1000 K = 1 DO 70 IDUM = 1,N IF (K.GT.WLEN) GO TO 71 J = W(K) DO 55 II = IP(J)+int(LEN(J)-1,8), & IP(J)+int(LENL(J),8),-1_8 IF (A(II).GE.BVAL) GO TO 60 I = IRN(II) IF (IW(I).NE.J) GO TO 55 IW(I) = 0 NUM = NUM - 1 FC(N-NUM) = J 55 CONTINUE 60 LENH(J) = LEN(J) LEN(J) = int(II - IP(J) + 1) IF (LENL(J).EQ.LENH(J)) THEN W(K) = W(WLEN) WLEN = WLEN - 1 ELSE K = K + 1 ENDIF 70 CONTINUE 71 IF (NUM.LT.NUMX) GO TO 81 80 CONTINUE 81 MOD = 1 ELSE BMAX = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL CMUMPS_MTRANSQ(IP,LEN,LENH,W,WLEN,A,NVAL,BVAL) IF (NVAL.EQ.0. OR. BVAL.EQ.BMIN) GO TO 1000 K = 1 DO 87 IDUM = 1,N IF (K.GT.WLEN) GO TO 88 J = W(K) DO 85 II = IP(J)+int(LEN(J),8),IP(J)+int(LENH(J)-1,8) IF (A(II).LT.BVAL) GO TO 86 85 CONTINUE 86 LENL(J) = LEN(J) LEN(J) = int(II - IP(J)) IF (LENL(J).EQ.LENH(J)) THEN W(K) = W(WLEN) WLEN = WLEN - 1 ELSE K = K + 1 ENDIF 87 CONTINUE 88 MOD = 0 ENDIF CNT = CNT + 1 CALL CMUMPS_MTRANSU(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW, & NUM,NUMX, & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) 90 CONTINUE 1000 IF (M.EQ.N .and. NUMX.EQ.N) GO TO 2000 CALL CMUMPS_MTRANSX(M,N,IPERM,IW,W) 2000 RETURN END SUBROUTINE CMUMPS_MTRANSS C SUBROUTINE CMUMPS_MTRANSU & (ID,MOD,M,N,IRN,LIRN,IP,LENC,FC,IPERM,NUM,NUMX, & PR,ARP,CV,OUT) IMPLICIT NONE INTEGER :: ID,MOD,M,N,NUM,NUMX INTEGER(8), INTENT(IN) :: LIRN INTEGER :: ARP(N),CV(M),IRN(LIRN), & FC(N),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER(8), INTENT(IN) :: IP(N) INTEGER I,J,J1,JORD,NFC,K,KK, & NUM0,NUM1,NUM2,ID0,ID1,LAST INTEGER(8) :: IN1, IN2, II IF (ID.EQ.1) THEN DO 5 I = 1,M CV(I) = 0 5 CONTINUE DO 6 J = 1,N ARP(J) = 0 6 CONTINUE NUM1 = N NUM2 = N ELSE IF (MOD.EQ.1) THEN DO 8 J = 1,N ARP(J) = 0 8 CONTINUE ENDIF NUM1 = NUMX NUM2 = N - NUMX ENDIF NUM0 = NUM NFC = 0 ID0 = (ID-1)*N DO 100 JORD = NUM0+1,N ID1 = ID0 + JORD J = FC(JORD-NUM0) PR(J) = -1 DO 70 K = 1,JORD IF (ARP(J).GE.LENC(J)) GO TO 30 IN1 = IP(J) + int(ARP(J),8) IN2 = IP(J) + int(LENC(J) - 1,8) DO 20 II = IN1,IN2 I = IRN(II) IF (IPERM(I).EQ.0) GO TO 80 20 CONTINUE ARP(J) = LENC(J) 30 OUT(J) = LENC(J) - 1 DO 60 KK = 1,JORD IN1 = int(OUT(J),8) IF (IN1.LT.0) GO TO 50 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 40 II = IN1,IN2 I = IRN(II) IF (CV(I).EQ.ID1) GO TO 40 J1 = J J = IPERM(I) CV(I) = ID1 PR(J) = J1 OUT(J1) = int(IN2 - II) - 1 GO TO 70 40 CONTINUE 50 J1 = PR(J) IF (J1.EQ.-1) THEN NFC = NFC + 1 FC(NFC) = J IF (NFC.GT.NUM2) THEN LAST = JORD GO TO 101 ENDIF GO TO 100 ENDIF J = J1 60 CONTINUE 70 CONTINUE 80 IPERM(I) = J ARP(J) = int(II - IP(J)) + 1 NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 95 II = IP(J) + int(LENC(J) - OUT(J) - 2,8) I = IRN(II) IPERM(I) = J 90 CONTINUE 95 IF (NUM.EQ.NUM1) THEN LAST = JORD GO TO 101 ENDIF 100 CONTINUE LAST = N 101 DO 110 JORD = LAST+1,N NFC = NFC + 1 FC(NFC) = FC(JORD-NUM0) 110 CONTINUE RETURN END SUBROUTINE CMUMPS_MTRANSU C SUBROUTINE CMUMPS_MTRANSW(M,N,NE,IP,IRN,A,IPERM,NUM, & JPERM,L32,OUT,PR,Q,L,U,D,RINF) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: NE INTEGER :: IRN(NE),IPERM(M),Q(M),L32(max(M,N)) INTEGER(8) :: IP(N+1), PR(N), L(M), JPERM(N), OUT(N) REAL A(NE),U(M),D(M),RINF,RINF3 INTEGER :: I,I0,II,J,JJ,JORD,Q0,QLEN,JDUM,JSP, & UP,LOW,IK INTEGER(8) :: K, KK, KK1, KK2, K0, K1, K2, ISP REAL :: CSP,DI,DMIN,DNEW,DQ0,VJ,RLX LOGICAL :: LORD REAL :: ZERO, ONE PARAMETER (ZERO=0.0E0,ONE=1.0E0) EXTERNAL CMUMPS_MTRANSD, CMUMPS_MTRANSE, & CMUMPS_MTRANSF, CMUMPS_MTRANSX RLX = U(1) RINF3 = U(2) LORD = (JPERM(1).EQ.6) NUM = 0 DO 10 I = 1,N JPERM(I) = 0_8 PR(I) = IP(I) D(I) = RINF 10 CONTINUE DO 15 I = 1,M U(I) = RINF3 IPERM(I) = 0 L(I) = 0_8 15 CONTINUE DO 30 J = 1,N IF (int(IP(J+1)-IP(J)) .GT. N/10 .AND. N.GT.50) GO TO 30 DO 20 K = IP(J),IP(J+1)-1 I = IRN(K) IF (A(K).GT.U(I)) GO TO 20 U(I) = A(K) IPERM(I) = J L(I) = K 20 CONTINUE 30 CONTINUE DO 40 I = 1,M J = IPERM(I) IF (J.EQ.0) GO TO 40 IF (JPERM(J).EQ.0_8) THEN JPERM(J) = L(I) D(J) = U(I) NUM = NUM + 1 ELSEIF (D(J).GT.U(I)) THEN K = JPERM(J) II = IRN(K) IPERM(II) = 0 JPERM(J) = L(I) D(J) = U(I) ELSE IPERM(I) = 0 ENDIF 40 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 45 I = 1,M D(I) = ZERO 45 CONTINUE DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 K1 = IP(J) K2 = IP(J+1) - 1_8 IF (K1.GT.K2) GO TO 95 VJ = RINF DO 50 K = K1,K2 I = IRN(K) DI = A(K) - U(I) IF (DI.GT.VJ) GO TO 50 IF (DI.LT.VJ .OR. DI.EQ.RINF) GO TO 55 IF (IPERM(I).NE.0 .OR. IPERM(I0).EQ.0) GO TO 50 55 VJ = DI I0 = I K0 = K 50 CONTINUE D(J) = VJ K = K0 I = I0 IF (IPERM(I).EQ.0) GO TO 90 DO 60 K = K0,K2 I = IRN(K) IF (A(K)-U(I).GT.VJ) GO TO 60 JJ = IPERM(I) KK1 = PR(JJ) KK2 = IP(JJ+1) - 1_8 IF (KK1.GT.KK2) GO TO 60 DO 70 KK = KK1,KK2 II = IRN(KK) IF (IPERM(II).GT.0) GO TO 70 IF (A(KK)-U(II).LE.D(JJ)) GO TO 80 70 CONTINUE PR(JJ) = KK2 + 1_8 60 CONTINUE GO TO 95 80 JPERM(JJ) = KK IPERM(II) = JJ PR(JJ) = KK + 1_8 90 NUM = NUM + 1 JPERM(J) = K IPERM(I) = J PR(J) = K + 1_8 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = RINF Q(I) = 0 99 CONTINUE DO 100 JORD = 1,N IF (JPERM(JORD).NE.0) GO TO 100 DMIN = RINF QLEN = 0 LOW = M + 1 UP = M + 1 CSP = RINF J = JORD PR(J) = -1_8 DO 115 K = IP(J),IP(J+1)-1_8 I = IRN(K) DNEW = A(K) - U(I) IF (DNEW.GE.CSP) GO TO 115 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = K JSP = J ELSE IF (DNEW.LT.DMIN) DMIN = DNEW D(I) = DNEW QLEN = QLEN + 1 L(QLEN) = K ENDIF 115 CONTINUE Q0 = QLEN QLEN = 0 DO 120 IK = 1,Q0 K = L(IK) I = IRN(K) IF (CSP.LE.D(I)) THEN D(I) = RINF GO TO 120 ENDIF IF (D(I).LE.DMIN) THEN LOW = LOW - 1 L32(LOW) = I Q(I) = LOW ELSE QLEN = QLEN + 1 Q(I) = QLEN CALL CMUMPS_MTRANSD(I,M,L32,D,Q,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = int(J,8) 120 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = L32(1) IF (D(I).LT.RINF) DMIN = D(I)*(ONE+RLX) IF (DMIN.GE.CSP) GO TO 160 152 CALL CMUMPS_MTRANSE(QLEN,M,L32,D,Q,2) LOW = LOW - 1 L32(LOW) = I Q(I) = LOW IF (QLEN.EQ.0) GO TO 153 I = L32(1) IF (D(I).GT.DMIN) GO TO 153 GO TO 152 ENDIF 153 Q0 = L32(UP-1) DQ0 = D(Q0) IF (DQ0.GE.CSP) GO TO 160 IF (DMIN.GE.CSP) GO TO 160 UP = UP - 1 J = IPERM(Q0) VJ = DQ0 - A(JPERM(J)) + U(Q0) K1 = IP(J+1)-1_8 IF (LORD) THEN IF (CSP.NE.RINF) THEN DI = CSP - VJ IF (A(K1).GE.DI) THEN K0 = JPERM(J) IF (K0.GE.K1-6) GO TO 178 177 CONTINUE K = (K0+K1)/2 IF (A(K).GE.DI) THEN K1 = K ELSE K0 = K ENDIF IF (K0.GE.K1-6) GO TO 178 GO TO 177 178 DO 179 K = K0+1,K1 IF (A(K).LT.DI) GO TO 179 K1 = K - 1 GO TO 181 179 CONTINUE ENDIF ENDIF 181 IF (K1.EQ.JPERM(J)) K1 = K1 - 1 ENDIF K0 = IP(J) DI = CSP - VJ DO 155 K = K0,K1 I = IRN(K) IF (Q(I).GE.LOW) GO TO 155 DNEW = A(K) - U(I) IF (DNEW.GE.DI) GO TO 155 DNEW = DNEW + VJ IF (DNEW.GT.D(I)) GO TO 155 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = K JSP = J DI = CSP - VJ ELSE IF (DNEW.GE.D(I)) GO TO 155 D(I) = DNEW IF (DNEW.LE.DMIN) THEN IF (Q(I).NE.0) THEN CALL CMUMPS_MTRANSF(Q(I),QLEN,M,L32,D,Q,2) ENDIF LOW = LOW - 1 L32(LOW) = I Q(I) = LOW ELSE IF (Q(I).EQ.0) THEN QLEN = QLEN + 1 Q(I) = QLEN ENDIF CALL CMUMPS_MTRANSD(I,M,L32,D,Q,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = int(J,8) ENDIF 155 CONTINUE 150 CONTINUE 160 IF (CSP.EQ.RINF) GO TO 190 NUM = NUM + 1 I = IRN(ISP) J = JSP IPERM(I) = J JPERM(J) = ISP DO 170 JDUM = 1,NUM JJ = int(PR(J)) IF (JJ.EQ.-1) GO TO 180 K = OUT(J) I = IRN(K) IPERM(I) = JJ JPERM(JJ) = K J = JJ 170 CONTINUE 180 DO 182 JJ = UP,M I = L32(JJ) U(I) = U(I) + D(I) - CSP 182 CONTINUE 190 DO 191 JJ = UP,M I = L32(JJ) D(I) = RINF Q(I) = 0 191 CONTINUE DO 192 JJ = LOW,UP-1 I = L32(JJ) D(I) = RINF Q(I) = 0 192 CONTINUE DO 193 JJ = 1,QLEN I = L32(JJ) D(I) = RINF Q(I) = 0 193 CONTINUE 100 CONTINUE 1000 CONTINUE DO 1200 J = 1,N K = JPERM(J) IF (K.NE.0) THEN D(J) = A(K) - U(IRN(K)) ELSE D(J) = ZERO ENDIF 1200 CONTINUE DO 1201 I = 1,M IF (IPERM(I).EQ.0) U(I) = ZERO 1201 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL CMUMPS_MTRANSX(M,N,IPERM,Q,L32) 2000 RETURN END SUBROUTINE CMUMPS_MTRANSW SUBROUTINE CMUMPS_MTRANSZ & (M,N,IRN,LIRN,IP,LENC,IPERM,NUM,PR,ARP,CV,OUT) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: LIRN INTEGER :: ARP(N),CV(M),IRN(LIRN),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER(8), INTENT(IN) :: IP(N) C Local variables INTEGER :: I,J,J1,JORD,K,KK INTEGER(8) :: II, IN1, IN2 INTEGER, PARAMETER :: KXX = 100 ! default REAL :: R INTEGER :: MAXNUM EXTERNAL CMUMPS_MTRANSX R = REAL(KXX)/REAL(100) MAXNUM = min(N, INT(N*R)) DO 10 I = 1,M CV(I) = 0 IPERM(I) = 0 10 CONTINUE DO 12 J = 1,N ARP(J) = LENC(J) - 1 12 CONTINUE NUM = 0 DO 1000 JORD = 1,N J = JORD PR(J) = -1 DO 70 K = 1,JORD IN1 = int(ARP(J),8) IF (IN1.LT.0_8) GO TO 30 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 20 II = IN1,IN2 I = IRN(II) IF (IPERM(I).EQ.0) GO TO 80 20 CONTINUE ARP(J) = -1 30 CONTINUE OUT(J) = LENC(J) - 1 DO 60 KK = 1,JORD IN1 = int(OUT(J),8) IF (IN1.LT.0_8) GO TO 50 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 40 II = IN1,IN2 I = IRN(II) IF (CV(I).EQ.JORD) GO TO 40 J1 = J J = IPERM(I) CV(I) = JORD PR(J) = J1 OUT(J1) = int(IN2 - II - 1_8) GO TO 70 40 CONTINUE 50 CONTINUE J = PR(J) IF (J.EQ.-1) GO TO 999 60 CONTINUE 70 CONTINUE 80 CONTINUE IPERM(I) = J ARP(J) = int(IN2 - II - 1_8) NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 999 II = IP(J) + int(LENC(J) - OUT(J) - 2,8) I = IRN(II) IPERM(I) = J 90 CONTINUE 999 CONTINUE IF (KXX.GE.100) GOTO 1000 C we may stop if NUM large enough IF (NUM.GE.MAXNUM) EXIT 1000 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL CMUMPS_MTRANSX(M,N,IPERM,CV,ARP) 2000 RETURN END SUBROUTINE CMUMPS_MTRANSZ SUBROUTINE CMUMPS_MTRANSX(M,N,IPERM,RW,CW) IMPLICIT NONE INTEGER M,N INTEGER RW(M),CW(N),IPERM(M) INTEGER I,J,K INTEGER, PARAMETER :: KXX = 100 INTEGER SIG SIG = -1 IF (KXX.LT.100) SIG = 1 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*SIG 30 CONTINUE DO 40 J = N+1,M K = K + 1 I = RW(K) IPERM(I) = J*SIG 40 CONTINUE RETURN END SUBROUTINE CMUMPS_MTRANSX MUMPS_5.8.1/src/ssol_lr.F0000664000175000017500000010226315042446437015026 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_SOL_LR USE SMUMPS_LR_TYPE USE SMUMPS_LR_CORE USE MUMPS_LR_STATS USE SMUMPS_LR_DATA_M, only: BLR_ARRAY IMPLICIT NONE CONTAINS SUBROUTINE SMUMPS_SOL_FWD_LR_SU & (INODE, N, IWHDLR, NPIV_GLOBAL, NSLAVES, & IW, IPOS_INIT, LIW, & LIELL, WCB, LWCB, & LD_WCBPIV, LD_WCBCB, & PPIV_INIT, PCB_INIT, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, KEEP8, OOCWRITE_COMPATIBLE_WITH_BLR, & IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, N, IWHDLR, NPIV_GLOBAL, NSLAVES INTEGER, INTENT(IN) :: MTYPE, LIELL, KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: LIW, IPOS_INIT, LRHSINTR INTEGER, INTENT(IN) :: IW(LIW), POSINRHSINTR_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, PPIV_INIT, PCB_INIT INTEGER, INTENT(IN) :: LD_WCBPIV, LD_WCBCB, NRHS, JBDEB, JBFIN REAL, INTENT(INOUT) :: WCB(LWCB) INTEGER, INTENT(INOUT) :: IFLAG, IERROR REAL, INTENT(INOUT) :: RHSINTR(LRHSINTR, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: I, NPARTSASS, NB_BLR , NELIM, LDADIAG, & DIAGSIZ_DYN, DIAGSIZ_STA, IBEG_BLR, IEND_BLR, & LD_CB, NRHS_B, IPOS, KCB INTEGER(8) :: PPIV, PCB INTEGER :: LAST_BLR REAL, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) NRHS_B = JBFIN-JBDEB+1 IF (MTYPE.EQ.1) THEN IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ELSE WRITE(6,*) " Internal error in SMUMPS_SOL_FWD_SU_MASTER" ENDIF ELSE IF (associated(BLR_ARRAY(IWHDLR)%PANELS_U)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_U) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ENDIF ENDIF IF (NSLAVES.EQ.0 .OR. (KEEP(50).eq.0 .and. MTYPE .NE.1)) THEN LAST_BLR = NB_BLR ELSE LAST_BLR = NPARTSASS ENDIF IPOS = IPOS_INIT PPIV = PPIV_INIT DO I=1, NPARTSASS IBEG_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I) IEND_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) -1 DIAGSIZ_DYN = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) - & IBEG_BLR DIAGSIZ_STA = BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(I+1) - & IBEG_BLR IF (KEEP(50).NE.0) THEN LDADIAG = DIAGSIZ_DYN ELSE LDADIAG = DIAGSIZ_STA ENDIF IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN PCB = PCB_INIT ELSE PCB = PPIV + int(DIAGSIZ_DYN,8) ENDIF IF ( DIAGSIZ_DYN.EQ.0) CYCLE NELIM = DIAGSIZ_STA - DIAGSIZ_DYN IF ( MTYPE .EQ. 1 ) THEN BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL ELSE BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_U(I)%LRB_PANEL END IF DIAG => BLR_ARRAY(IWHDLR)%DIAG_BLOCKS(I)%DIAG_BLOCK CALL SMUMPS_SOLVE_FWD_TRSOLVE (DIAG(1), & int(size(DIAG),8), 1_8, & DIAGSIZ_DYN , LDADIAG, NRHS_B, WCB, LWCB, NPIV_GLOBAL, & PPIV, MTYPE, KEEP) IF (NELIM.GT.0) THEN KCB = int(PCB-PPIV_INIT+1) IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN LD_CB = LD_WCBCB ELSE LD_CB = LD_WCBPIV ENDIF IF (MTYPE.EQ.1) THEN IF (KCB.LE.NPIV_GLOBAL .AND. & KCB+NELIM-1.GT.NPIV_GLOBAL) THEN CALL sgemm('T', 'N', NPIV_GLOBAL-KCB+1, NRHS_B, & DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) CALL sgemm('T', 'N', KCB+NELIM-NPIV_GLOBAL-1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG + & (NPIV_GLOBAL-KCB+1)*DIAGSIZ_DYN), & DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB_INIT), LD_WCBCB) ELSE CALL sgemm('T', 'N', NELIM, NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) ENDIF ELSE IF (KCB.LE.NPIV_GLOBAL .AND. & KCB+NELIM-1.GT.NPIV_GLOBAL) THEN CALL sgemm('N', 'N', NPIV_GLOBAL-KCB+1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) CALL sgemm('N', 'N', KCB+NELIM-NPIV_GLOBAL-1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN+NPIV_GLOBAL-KCB+1), & DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB_INIT), LD_WCBCB) ELSE CALL sgemm('N', 'N', NELIM, NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) ENDIF ENDIF ENDIF CALL SMUMPS_SOL_FWD_BLR_UPDATE ( & WCB, LWCB, 1, LD_WCBPIV, PPIV_INIT, 1, & WCB, LWCB, LD_WCBCB, PCB_INIT, & PPIV, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, LAST_BLR, I, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC, & KEEP8, KEEP(34), & KEEP(448), KEEP(450), KEEP(451), & .FALSE., & IFLAG, IERROR) IF (IFLAG.LT.0) RETURN CALL SMUMPS_SOL_LD_AND_RELOAD_PANEL ( & INODE, N, DIAGSIZ_DYN, LIELL, NELIM, NSLAVES, & PPIV, & IW, IPOS, LIW, & DIAG(1), int(size(DIAG),8), 1_8, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & .TRUE. & ) PPIV = PPIV + int(DIAGSIZ_DYN,8) IPOS = IPOS + DIAGSIZ_DYN ENDDO RETURN END SUBROUTINE SMUMPS_SOL_FWD_LR_SU SUBROUTINE SMUMPS_SOL_SLAVE_LR_U & (INODE, IWHDLR, NPIV_GLOBAL, & WCB, LWCB, & LDX, LDY, & PTRX_INIT, PTRY_INIT, & JBDEB, JBFIN, & MTYPE, KEEP, KEEP8, IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, IWHDLR, NPIV_GLOBAL INTEGER, INTENT(IN) :: MTYPE, KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER(8), INTENT(IN) :: LWCB, PTRX_INIT, PTRY_INIT INTEGER, INTENT(IN) :: LDX, LDY, JBDEB, JBFIN REAL, INTENT(INOUT) :: WCB(LWCB) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, NPARTSASS, NB_BLR , NRHS_B INTEGER(8) :: PTRX, PTRY TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) NRHS_B = JBFIN-JBDEB+1 IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) NB_BLR = NB_BLR - 2 ELSE WRITE(6,*) " Internal error 1 in SMUMPS_SOL_SLAVE_LR_U" CALL MUMPS_ABORT() ENDIF PTRX = PTRX_INIT PTRY = PTRY_INIT DO I = 1, NPARTSASS BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL IF (associated(BLR_PANEL)) THEN IF (MTYPE.EQ.1) THEN CALL SMUMPS_SOL_FWD_BLR_UPDATE ( & WCB, LWCB, 1, LDX, -99999_8, 1, & WCB, LWCB, LDY, PTRY, & PTRX, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, NB_BLR, 0, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(2:NB_BLR+2), & KEEP8, KEEP(34), & KEEP(448), KEEP(450), KEEP(451), & .TRUE., IFLAG, IERROR ) ELSE CALL SMUMPS_SOL_BWD_BLR_UPDATE ( & WCB, LWCB, 1, LDY, -99999_8, 1, & WCB, LWCB, LDX, PTRX, & PTRY, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, NB_BLR, 0, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(2:NB_BLR+2), & KEEP8, KEEP(34), & KEEP(448), KEEP(450), KEEP(451), & .TRUE., & IFLAG, IERROR ) ENDIF IF (MTYPE .EQ. 1) THEN PTRX = PTRX + BLR_PANEL(1)%N ELSE PTRY = PTRY + BLR_PANEL(1)%N ENDIF IF (IFLAG.LT.0) RETURN ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_SOL_SLAVE_LR_U SUBROUTINE GEMM_Q_FWD(m, nrhs_b, k, npiv, & Q, TMP, ldT, & arraypiv, ldpiv, arraycb, lcb, ldcb, & ibeg_block, iend_block, is_t2_slave, & poscb, pospiv, pospivcol, ibeg_tmp) implicit none integer, intent(in) :: m, nrhs_b, k, npiv REAL, dimension(:,:), intent(inout) :: Q REAL, dimension(ldt, *), intent(inout) :: TMP integer(8), intent(in) :: lcb integer, intent(in) :: ldpiv REAL, intent(inout) :: arraypiv(ldpiv,*) REAL, intent(inout) :: arraycb(lcb) integer, intent(in) :: ldt, ldcb integer, intent(in) :: ibeg_block, iend_block logical, intent(in) :: is_t2_slave integer(8), intent(in) :: poscb, pospiv integer, intent(in) :: pospivcol integer, intent(in) :: ibeg_tmp integer :: posblock REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL sgemm('N', 'N', M, NRHS_B, K, MONE, & Q(1,1), M, TMP(ibeg_tmp,1), LDT, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND. & IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('N', 'N', NPIV-IBEG_BLOCK+1,NRHS_B, K, & MONE, Q(1,1), M, TMP(ibeg_tmp,1), LDT, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL sgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, & NRHS_B, K, & MONE, Q(NPIV-IBEG_BLOCK+2,1), M, & TMP(ibeg_tmp,1), LDT, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('N', 'N', M, NRHS_B, K, MONE, & Q(1,1), M, TMP(ibeg_tmp,1), LDT, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL sgemm('N', 'N', M, NRHS_B, K, MONE, & Q(1,1), M, TMP(ibeg_tmp,1), LDT, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF RETURN END SUBROUTINE GEMM_Q_FWD SUBROUTINE GEMM_Q_BWD(m, nrhs_b, k, npiv, & Q, TMP, ldT, & arraypiv, lpiv, ldpiv, arraycb, lcb, ldcb, & ibeg_block, iend_block, is_t2_slave, & poscb, pospiv, pospivcol, ibeg_tmp) implicit none integer, intent(in) :: m, nrhs_b, k, npiv REAL, dimension(:, :), intent(inout) :: Q REAL, dimension(ldt, *), intent(inout) :: TMP integer(8), intent(in) :: lcb, lpiv REAL, intent(inout) :: arraypiv(lpiv,*) REAL, intent(inout) :: arraycb(lcb) integer, intent(in) :: ldt, ldcb, ldpiv integer, intent(in) :: ibeg_block, iend_block logical, intent(in) :: is_t2_slave integer(8), intent(in) :: poscb, pospiv integer, intent(in) :: pospivcol integer, intent(in) :: ibeg_tmp integer(8) :: posblock REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB +int(IBEG_BLOCK-1,8) CALL sgemm('T', 'N', K, NRHS_B, M, ONE, & Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TMP(ibeg_tmp,1), ldt) ELSEIF (IBEG_BLOCK.LE.NPIV.AND. & IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('T', 'N', K, NRHS_B, & NPIV-IBEG_BLOCK+1, & ONE, Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TMP(ibeg_tmp, 1), ldt) CALL sgemm('T', 'N', & K, NRHS_B, IBEG_BLOCK+M-NPIV-1, & ONE, Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYCB(POSCB), LDCB, & ONE, & TMP(ibeg_tmp,1), ldt) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('T', 'N', K, NRHS_B, M, ONE, & Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TMP(ibeg_tmp, 1), ldt) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL sgemm('T', 'N', K, NRHS_B, M, ONE, & Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TMP(ibeg_tmp, 1), ldt) ENDIF RETURN END SUBROUTINE GEMM_Q_BWD SUBROUTINE SMUMPS_SOL_FWD_BLR_UPDATE ( & ARRAYPIV, LPIV, LPIVCOL, LDPIV, POSPIV, POSPIVCOL, & ARRAYCB, LCB, LDCB, POSCB, & POSDIAG, & NRHS_B, NPIV, & BLR_PANEL, LAST_BLR, & CURRENT_BLR, BEGS_BLR_STATIC, & KEEP8, K34, K448, K450, K451, IS_T2_SLAVE, IFLAG, IERROR ) !$ USE OMP_LIB INTEGER(8), INTENT(IN) :: LPIV, LCB, POSPIV, POSCB, POSDIAG INTEGER, INTENT(IN) :: LPIVCOL, POSPIVCOL REAL, INTENT(INOUT) :: ARRAYPIV(LPIV,LPIVCOL) REAL, INTENT(INOUT) :: ARRAYCB(LCB) INTEGER, INTENT(IN) :: LAST_BLR, NRHS_B, LDPIV, LDCB, & CURRENT_BLR, NPIV, K34, K448, K450, K451 TYPE(LRB_TYPE), TARGET,INTENT(IN) :: & BLR_PANEL(:) INTEGER :: BEGS_BLR_STATIC(:) LOGICAL, INTENT(IN) :: IS_T2_SLAVE INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, K, M, N, IBEG_BLOCK, IEND_BLOCK INTEGER :: KMAX INTEGER :: MMAX INTEGER(8) :: POSBLOCK INTEGER :: allocok TYPE(LRB_TYPE), POINTER :: LRB REAL, ALLOCATABLE,DIMENSION(:) :: TEMP_BLOCK REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) KMAX = -1 MMAX = -1 DO I = CURRENT_BLR+1, LAST_BLR KMAX = max(KMAX, BLR_PANEL(I-CURRENT_BLR)%K) MMAX = max(MMAX, BLR_PANEL(I-CURRENT_BLR)%M) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(TEMP_BLOCK, allocok !$OMP& ) #endif IF (KMAX.GT.0) THEN allocate(TEMP_BLOCK(KMAX*NRHS_B), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NRHS_B * KMAX write(*,*) 'Allocation problem in BLR routine & SMUMPS_SOL_FWD_BLR_UPDATE for TEMP_BLOCK: ', & 'not enough memory? memory requested = ', IERROR ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif #if ! defined(BLR_NOOPENMP) !$OMP DO SCHEDULE(DYNAMIC,1) !$OMP& PRIVATE(IBEG_BLOCK, IEND_BLOCK, LRB, K, M, N, !$OMP& POSBLOCK) #endif DO I = CURRENT_BLR+1, LAST_BLR IF (IFLAG.LT.0) CYCLE IBEG_BLOCK = BEGS_BLR_STATIC(I) IEND_BLOCK = BEGS_BLR_STATIC(I+1)-1 IF (IBEG_BLOCK .EQ. IEND_BLOCK + 1) CYCLE LRB => BLR_PANEL(I-CURRENT_BLR) K = LRB%K M = LRB%M N = LRB%N IF (LRB%ISLR) THEN IF (K.GT.0) THEN CALL sgemm('N', 'N', K, NRHS_B, N, ONE, & LRB%R(1,1), K, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL sgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('N', 'N', NPIV-IBEG_BLOCK+1, NRHS_B, K, & MONE, LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL sgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, NRHS_B, K, & MONE, LRB%Q(NPIV-IBEG_BLOCK+2,1), M, TEMP_BLOCK(1), & K, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL sgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF ENDIF ELSE IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB + int(IBEG_BLOCK-1,8) CALL sgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('N', 'N', NPIV-IBEG_BLOCK+1, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL sgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, NRHS_B, N, MONE, & LRB%Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYPIV(POSDIAG,POSPIVCOL), & LDPIV, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB + int(IBEG_BLOCK-1-NPIV,8) CALL sgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF ENDIF ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif IF (KMAX.GT.0) THEN IF (allocated(TEMP_BLOCK)) deallocate(TEMP_BLOCK) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif RETURN END SUBROUTINE SMUMPS_SOL_FWD_BLR_UPDATE SUBROUTINE SMUMPS_SOL_BWD_LR_SU & ( INODE, IWHDLR, NPIV_GLOBAL, NSLAVES, & LIELL, WCB, LWCB, NRHS_B, PTWCB, & RHSINTR, LRHSINTR, NRHS, & IPOSINRHSINTR, JBDEB, & MTYPE, KEEP, KEEP8, & IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, IWHDLR, NPIV_GLOBAL, NSLAVES INTEGER, INTENT(IN) :: MTYPE, LIELL, KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IPOSINRHSINTR, JBDEB, LRHSINTR, NRHS INTEGER(8), INTENT(IN) :: LWCB, PTWCB INTEGER, INTENT(IN) :: NRHS_B INTEGER, INTENT(INOUT) :: IFLAG, IERROR REAL, INTENT(INOUT) :: WCB(LWCB) REAL RHSINTR(LRHSINTR,NRHS) INTEGER :: I, NPARTSASS, NB_BLR, LAST_BLR, & NELIM_PANEL, LD_WCB, & DIAGSIZ_DYN, DIAGSIZ_STA, LDADIAG, & IEND_BLR, IBEG_BLR INTEGER(8) :: PWCB INTEGER :: IPIV_PANEL REAL, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) IF ((MTYPE.EQ.1).AND.(KEEP(50).EQ.0)) THEN IF (associated(BLR_ARRAY(IWHDLR)%PANELS_U)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_U) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ENDIF ELSE IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ELSE WRITE(6,*) " Internal error in SMUMPS_SOL_FWD_SU_MASTER" ENDIF ENDIF PWCB = PTWCB + int(NPIV_GLOBAL,8) LD_WCB = LIELL IF (KEEP(50).EQ.0 .AND. NSLAVES.GT.0 .AND. MTYPE.NE.1) THEN LAST_BLR = NPARTSASS ELSE LAST_BLR = NB_BLR ENDIF DO I=NPARTSASS,1,-1 IBEG_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I) IEND_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) -1 DIAGSIZ_DYN = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) - & IBEG_BLR DIAGSIZ_STA = BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(I+1) - & IBEG_BLR IF (KEEP(50).NE.0) THEN LDADIAG = DIAGSIZ_DYN ELSE LDADIAG = DIAGSIZ_STA ENDIF IF (DIAGSIZ_DYN.EQ.0) GOTO 1000 NELIM_PANEL = DIAGSIZ_STA - DIAGSIZ_DYN IPIV_PANEL = IPOSINRHSINTR + IBEG_BLR -1 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_U(I)%LRB_PANEL ELSE BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL END IF CALL SMUMPS_SOL_BWD_BLR_UPDATE ( & RHSINTR, int(LRHSINTR,8), NRHS, LRHSINTR, & int(IPOSINRHSINTR,8), JBDEB, & WCB, LWCB, LD_WCB, PWCB, & int(IPIV_PANEL,8), & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, LAST_BLR, & I, BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC, & KEEP8, KEEP(34), & KEEP(448), KEEP(450), KEEP(451), & .FALSE., & IFLAG, IERROR) IF (IFLAG.LT.0) RETURN DIAG => BLR_ARRAY(IWHDLR)%DIAG_BLOCKS(I)%DIAG_BLOCK IF (NELIM_PANEL.GT.0) THEN IF (MTYPE.EQ.1.AND.KEEP(50).EQ.0) THEN IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN CALL sgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, WCB(PWCB), & LD_WCB, ONE , RHSINTR(IPIV_PANEL,JBDEB),LRHSINTR) ELSE IF (IEND_BLR+1.LE.NPIV_GLOBAL .AND. & IEND_BLR+NELIM_PANEL.GT.NPIV_GLOBAL) THEN CALL sgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, & NPIV_GLOBAL-IEND_BLR, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & RHSINTR(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSINTR, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) CALL sgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, & IEND_BLR+NELIM_PANEL-NPIV_GLOBAL, & MONE, DIAG(1+DIAGSIZ_DYN+NPIV_GLOBAL-IEND_BLR), & DIAGSIZ_STA, & WCB(PWCB), LD_WCB, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ELSE CALL sgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & RHSINTR(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSINTR, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ENDIF ENDIF ELSE IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN CALL sgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PWCB), LD_WCB, ONE, & RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ELSE IF (IEND_BLR+1.LE.NPIV_GLOBAL .AND. & IEND_BLR+NELIM_PANEL.GT.NPIV_GLOBAL) THEN CALL sgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, & NPIV_GLOBAL-IEND_BLR, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & RHSINTR(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSINTR, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) CALL sgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, & IEND_BLR+NELIM_PANEL-NPIV_GLOBAL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG + & (NPIV_GLOBAL-IEND_BLR)*DIAGSIZ_DYN), & DIAGSIZ_DYN, & WCB(PWCB), LD_WCB, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ELSE CALL sgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & RHSINTR(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSINTR, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ENDIF ENDIF ENDIF ENDIF IF (IFLAG.LT.0) RETURN CALL SMUMPS_SOLVE_BWD_LR_TRSOLVE ( & DIAG(1), size(DIAG), DIAGSIZ_DYN, NELIM_PANEL, LIELL, & NRHS_B, WCB, LWCB, & RHSINTR, LRHSINTR, NRHS, & IPIV_PANEL, JBDEB, & MTYPE, KEEP ) 1000 CONTINUE ENDDO RETURN END SUBROUTINE SMUMPS_SOL_BWD_LR_SU SUBROUTINE SMUMPS_SOL_BWD_BLR_UPDATE ( & ARRAYPIV, LPIV, LPIVCOL, LDPIV, POSPIV, POSPIVCOL, & ARRAYCB, LCB, LDCB, POSCB, & POSDIAG, & NRHS_B, NPIV, & BLR_PANEL, LAST_BLR, CURRENT_BLR, & BEGS_BLR_STATIC, & KEEP8, K34, K448, K450, K451, IS_T2_SLAVE, & IFLAG, IERROR) !$ USE OMP_LIB INTEGER(8), INTENT(IN) :: LPIV, LCB, POSPIV, POSCB, POSDIAG INTEGER,INTENT(IN) :: LPIVCOL, POSPIVCOL REAL, INTENT(INOUT) :: ARRAYPIV(LPIV,LPIVCOL) REAL, INTENT(INOUT) :: ARRAYCB(LCB) INTEGER, INTENT(IN) :: LAST_BLR, NRHS_B, LDPIV, LDCB, & CURRENT_BLR, NPIV, K34, K448, K450, K451 TYPE(LRB_TYPE), TARGET,INTENT(IN) :: & BLR_PANEL(:) INTEGER(8), INTENT(IN) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_T2_SLAVE INTEGER :: BEGS_BLR_STATIC(:) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, K, M, N, IBEG_BLOCK, IEND_BLOCK INTEGER :: KMAX INTEGER(8) :: POSBLOCK TYPE(LRB_TYPE), POINTER :: LRB REAL, ALLOCATABLE, DIMENSION(:) :: TEMP_BLOCK REAL, ALLOCATABLE, DIMENSION(:) :: DEST_ARRAY INTEGER :: allocok REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) KMAX = -1 DO I = CURRENT_BLR+1, LAST_BLR KMAX = max(KMAX, BLR_PANEL(I-CURRENT_BLR)%K) ENDDO IF (CURRENT_BLR.LT.LAST_BLR) THEN N = BLR_PANEL(1)%N ELSE RETURN ENDIF allocate(DEST_ARRAY(N*NRHS_B),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = N * NRHS_B GOTO 100 ENDIF DEST_ARRAY = ZERO #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(TEMP_BLOCK, allocok !$OMP& ) #endif IF (KMAX.GT.0) THEN allocate(TEMP_BLOCK(KMAX*NRHS_B), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NRHS_B * KMAX write(*,*) 'Allocation problem in BLR routine & SMUMPS_SOL_BWD_BLR_UPDATE: ', & 'not enough memory? memory requested = ', IERROR ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP DO SCHEDULE(DYNAMIC,1) !$OMP& PRIVATE(IBEG_BLOCK, IEND_BLOCK, LRB, K, M, POSBLOCK) !$OMP& REDUCTION(+:DEST_ARRAY) #endif DO I = CURRENT_BLR+1, LAST_BLR IF (IFLAG.LT.0) CYCLE IBEG_BLOCK = BEGS_BLR_STATIC(I) IEND_BLOCK = BEGS_BLR_STATIC(I+1)-1 LRB => BLR_PANEL(I-CURRENT_BLR) K = LRB%K M = LRB%M IF (LRB%ISLR) THEN IF (K.GT.0) THEN IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB +int(IBEG_BLOCK-1,8) CALL sgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TEMP_BLOCK(1), K) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('T', 'N', K, NRHS_B, NPIV-IBEG_BLOCK+1, & ONE, LRB%Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) CALL sgemm('T', 'N', K, NRHS_B, IBEG_BLOCK+M-NPIV-1, & ONE, LRB%Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYCB(POSCB), LDCB, & ONE, & TEMP_BLOCK(1), K) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL sgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TEMP_BLOCK(1), K) ENDIF CALL sgemm('T', 'N', N, NRHS_B, K, MONE, & LRB%R(1,1), K, & TEMP_BLOCK(1), K, ONE, & DEST_ARRAY(1), N) ENDIF ELSE IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL sgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYCB(POSBLOCK), LDCB, & ONE, DEST_ARRAY(1), N) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('T', 'N', N, NRHS_B, NPIV-IBEG_BLOCK+1, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ONE, DEST_ARRAY(1), N) CALL sgemm('T', 'N', N, NRHS_B, IBEG_BLOCK+M-NPIV-1, MONE, & LRB%Q(NPIV-IBEG_BLOCK+2,1), M, ARRAYCB(POSCB), & LDCB, ONE, DEST_ARRAY(1), N) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ONE, DEST_ARRAY(1), N) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL sgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYCB(POSBLOCK), LDCB, & ONE, DEST_ARRAY(1), N) ENDIF ENDIF ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif IF (KMAX.GT.0) THEN IF (allocated(TEMP_BLOCK)) deallocate(TEMP_BLOCK) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IS_T2_SLAVE) THEN DO I=1,NRHS_B call saxpy(N, ONE, DEST_ARRAY((I-1)*N+1), 1, & ARRAYPIV(POSDIAG+(I-1)*LDPIV,POSPIVCOL), 1) ENDDO ELSE DO I=1,NRHS_B call saxpy(N, ONE, DEST_ARRAY((I-1)*N+1), 1, & ARRAYPIV(POSDIAG,POSPIVCOL+I-1), 1) ENDDO ENDIF 100 CONTINUE IF (allocated(DEST_ARRAY)) DEALLOCATE(DEST_ARRAY) RETURN END SUBROUTINE SMUMPS_SOL_BWD_BLR_UPDATE END MODULE SMUMPS_SOL_LR SUBROUTINE SMUMPS_SOLVE_BWD_LR_TRSOLVE ( & DIAG, LDIAG, NPIV, NELIM, LIELL, & NRHS_B, W, LWC, & RHSINTR, LRHSINTR, NRHS, & PPIVINRHSINTR, JBDEB, & MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LIELL, NPIV, NELIM, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDIAG INTEGER, INTENT(IN) :: PPIVINRHSINTR, JBDEB, LRHSINTR, NRHS INTEGER(8), INTENT(IN) :: LWC REAL, INTENT(IN) :: DIAG(LDIAG) REAL, INTENT(INOUT) :: W(LWC) REAL RHSINTR(LRHSINTR,NRHS) INTEGER :: LDAJ REAL ONE PARAMETER (ONE = 1.0E0) IF ( MTYPE .eq. 1 ) THEN LDAJ = NPIV + NELIM CALL strsm('L','L','T','N', NPIV, NRHS_B, ONE, DIAG(1), & LDAJ, RHSINTR(PPIVINRHSINTR,JBDEB), & LRHSINTR) ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=NPIV+NELIM ELSE LDAJ=NPIV ENDIF CALL strsm('L','U','N','U', NPIV, NRHS_B, ONE, DIAG(1), & LDAJ, RHSINTR(PPIVINRHSINTR,JBDEB), LRHSINTR) END IF RETURN END SUBROUTINE SMUMPS_SOLVE_BWD_LR_TRSOLVE MUMPS_5.8.1/src/drank_revealing.F0000664000175000017500000005470215042446437016510 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_GET_NS_OPTIONS_FACTO(N,KEEP,ICNTL,MPG) IMPLICIT NONE INTEGER N, KEEP(500), ICNTL(60), MPG KEEP(19)=0 KEEP(19)=ICNTL(56) IF ((KEEP(19).LT.1).OR.(KEEP(19).GE.2)) KEEP(19)=0 IF ( KEEP(53) .LE. 0 .and. & KEEP(19) .NE. 0 ) THEN KEEP(19) = 0 IF ( MPG .GT. 0 ) THEN WRITE( MPG,'(A)') '** Warning: ICNTL(56) null space option' WRITE( MPG,'(A)') '** disabled (incompatibility with analysis)' END IF END IF KEEP(21) = min(ICNTL(57),N) KEEP(22) = max(ICNTL(55),0) IF ( KEEP(19) .ne. 0 .and. KEEP(60) .ne. 0 ) THEN IF ( MPG .GT. 0 ) THEN WRITE( MPG,'(A)') '** Warning: ICNTL(56) null space option' WRITE( MPG,'(A)') '** disabled (incompatibility with Schur)' END IF KEEP(19) = 0 END IF RETURN END SUBROUTINE DMUMPS_GET_NS_OPTIONS_FACTO SUBROUTINE DMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL, KEEP, & NRHS, MPG, INFO) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500), NRHS, MPG, ICNTL(60) INTEGER, intent(inout):: INFO(80) IF (KEEP(19).EQ.0.AND.KEEP(110).EQ.0) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 56 IF (KEEP(110).EQ.0) INFO(2) = 24 IF(MPG.GT.0) THEN WRITE( MPG,'(A)') &'** ERROR : Null space computation requirement' WRITE( MPG,'(A)') &'** not consistent with factorization options' ENDIF GOTO 333 ENDIF ENDIF IF (ICNTL(9).NE.1) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 9 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') &'** ERROR ICNTL(25) incompatible with ' WRITE( MPG,'(A)') &'** option transposed system (ICNTL(9).ne.1) ' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(19).EQ.2) THEN IF ((KEEP(111).NE.0).AND.(KEEP(50).EQ.0)) THEN INFO(1) = -37 INFO(2) = 0 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') &'** ERROR ICNTL(25) incompatible with ' WRITE( MPG,'(A)') &'** option RRQR (ICNLT(56)=2) and unsym. matrices ' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(111).eq.-1.AND.NRHS.NE.KEEP(112)+KEEP(17))THEN INFO(1)=-32 INFO(2)=NRHS GOTO 333 ENDIF IF (KEEP(111).gt.0 .AND. NRHS .NE. 1) THEN INFO(1)=-32 INFO(2)=NRHS GOTO 333 ENDIF IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) and ICNTL(30) functionalities ', & ' incompatible with null space' ENDIF INFO(1) = -37 IF (KEEP(237).NE.0) THEN INFO(2) = 30 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(30) functionality ', & ' incompatible with null space' ENDIF ELSE IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) functionality ', & ' incompatible with null space' ENDIF INFO(2) = 20 ENDIF GOTO 333 ENDIF IF (( KEEP(111) .LT. -1 ) .OR. & (KEEP(111).GT.KEEP(112)+KEEP(17)) .OR. & (KEEP(111) .EQ.-1 .AND. KEEP(112)+KEEP(17).EQ.0)) & THEN INFO(1)=-36 INFO(2)=KEEP(111) GOTO 333 ENDIF IF (KEEP(221).NE.0.AND.KEEP(111).NE.0) THEN INFO(1)=-37 INFO(2)=26 GOTO 333 ENDIF 333 CONTINUE RETURN END SUBROUTINE DMUMPS_GET_NS_OPTIONS_SOLVE SUBROUTINE DMUMPS_RR_INIT_POINTERS(roota) USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: roota NULLIFY(roota%QR_TAU) NULLIFY(roota%SVD_U) NULLIFY(roota%SVD_VT) NULLIFY(roota%SINGULAR_VALUES) RETURN END SUBROUTINE DMUMPS_RR_INIT_POINTERS SUBROUTINE DMUMPS_RR_FREE_POINTERS(roota) USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: roota IF (associated(roota%QR_TAU)) THEN DEALLOCATE(roota%QR_TAU) NULLIFY(roota%QR_TAU) ENDIF IF (associated(roota%SVD_U)) THEN DEALLOCATE(roota%SVD_U) NULLIFY(roota%SVD_U) ENDIF IF (associated(roota%SVD_VT)) THEN DEALLOCATE(roota%SVD_VT) NULLIFY(roota%SVD_VT) ENDIF IF (associated(roota%SINGULAR_VALUES)) THEN DEALLOCATE(roota%SINGULAR_VALUES) NULLIFY(roota%SINGULAR_VALUES) ENDIF RETURN END SUBROUTINE DMUMPS_RR_FREE_POINTERS SUBROUTINE DMUMPS_SEQ_SYMMETRIZE(N,A) INTEGER N DOUBLE PRECISION A( N, N ) INTEGER I,J DO I = 2, N DO J = 1, I - 1 A( I, J ) = A( J, I ) END DO END DO RETURN END SUBROUTINE DMUMPS_SEQ_SYMMETRIZE SUBROUTINE DMUMPS_UXVSBP(N,PERM,X,RN01) INTEGER N,PERM(N),I DOUBLE PRECISION RN01(N),X(N) DO I=1,N RN01(PERM(I))=X(I) ENDDO DO I=1,N X(I)=RN01(I) ENDDO RETURN END SUBROUTINE DMUMPS_UXVSBP SUBROUTINE DMUMPS_UXVSFP(N,PERM,X,RN01) INTEGER N,PERM(N),I DOUBLE PRECISION RN01(N),X(N) DO I=1,N RN01(I)=X(PERM(I)) ENDDO DO I=1,N X(I)=RN01(I) ENDDO RETURN END SUBROUTINE DMUMPS_UXVSFP SUBROUTINE DMUMPS_SVD_QR_ESTIM_WK( PHASE, MBLOCK, NBLOCK, & SIZE_ROOT_ARG, & LOCAL_M, LOCAL_N, ROOT_OWNER, KEEP,KEEP8, & LIWK_RR, LWK_RR ) IMPLICIT NONE INTEGER, INTENT(IN) :: PHASE, SIZE_ROOT_ARG INTEGER, INTENT(IN) :: MBLOCK, NBLOCK, LOCAL_M, LOCAL_N LOGICAL, INTENT(IN) :: ROOT_OWNER INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(OUT):: LIWK_RR INTEGER(8), INTENT(OUT):: LWK_RR INTEGER SIZE_ROOT INTEGER NBPOSPONED_ESTIM PARAMETER (NBPOSPONED_ESTIM=2000) INTEGER SVD_QR,PAR_ROOT SVD_QR = KEEP(19) PAR_ROOT = KEEP(38) LIWK_RR = 0 LWK_RR = 0_8 IF (PAR_ROOT.EQ.0) THEN IF(ROOT_OWNER) THEN IF (PHASE.EQ.0) THEN SIZE_ROOT=SIZE_ROOT_ARG+NBPOSPONED_ESTIM ELSE SIZE_ROOT=SIZE_ROOT_ARG ENDIF IF(SVD_QR.EQ.1) THEN LWK_RR=int(5*SIZE_ROOT+1,8) ELSEIF(SVD_QR.EQ.2) THEN LWK_RR=int(3*SIZE_ROOT+1,8) END IF END IF ENDIF RETURN END SUBROUTINE DMUMPS_SVD_QR_ESTIM_WK SUBROUTINE DMUMPS_SEQ_FACTO_ROOT_SVD_QR &(NN,A,root,roota,WR03,LWR03,KEEP,KEEP8,INFO,LP,DKEEP, & GLOBK109,OPELIW,PIVNUL_LIST,LPIVNUL_LIST, & ROW_INDICES) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE ( MUMPS_ROOT_STRUC ) :: root TYPE ( DMUMPS_ROOT_STRUC ) :: roota INTEGER :: NN,LP,LWR03,LWR03_MINSIZE DOUBLE PRECISION :: A(NN*NN) INTEGER :: INFO(2),KEEP(500) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: DKEEP(230) DOUBLE PRECISION :: OPELIW INTEGER :: GLOBK109 INTEGER :: LPIVNUL_LIST INTEGER :: PIVNUL_LIST(LPIVNUL_LIST) INTEGER :: ROW_INDICES(NN) DOUBLE PRECISION :: WR03(LWR03) INTEGER LDLT,DEFICIENCY DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: RWORK INTEGER :: I,LDA,LDU,LDVT,J INTEGER :: IERR, LAST_BEFORE_GAP_IND INTEGER :: LAST_BEFORE_GAPLIMIT_IND, FIRST_AFTER_MinPiv, & FIRST_AFTER_GAPLIMIT, START_POINT, END_POINT INTEGER :: ALLOCOK,MAXDEF,MINDEF DOUBLE PRECISION :: EPS, ZERO, GAPLIMIT, MaxGap, MaxGap1, & MinPiv, Tol_MaxGap PARAMETER(ZERO=0.0D0) EPS = epsilon(ZERO) LDLT=KEEP(50) IF ((KEEP(19) .NE. 1).AND.(KEEP(19) .NE. 2)) THEN INFO(1)=-107 INFO(2)= KEEP(19) IF ( LP .GT. 0 ) THEN WRITE(LP,*) " *** Option ",KEEP(19), & " for null space no more available." ENDIF GOTO 100 ENDIF IF(KEEP(19).EQ.1) THEN LWR03_MINSIZE=5*NN+1 ELSEIF(KEEP(19).EQ.2) THEN LWR03_MINSIZE=3*NN+1 END IF MAXDEF=KEEP(21) IF ( MAXDEF .LE. 0 ) THEN MAXDEF = NN ELSE MAXDEF = max(MAXDEF - GLOBK109,0) ENDIF MINDEF = max(KEEP(22) - GLOBK109,0) MINDEF = min(MINDEF,NN) MAXDEF = min(MAXDEF,NN) IF(KEEP(19).EQ.1) THEN OPELIW = OPELIW + dble(26)*dble(NN)*dble(NN)*dble(NN) ELSEIF(KEEP(19).EQ.2) THEN OPELIW = OPELIW + dble(4)*dble(NN)*dble(NN)*dble(NN)/dble(3) ENDIF IF (associated(roota%SINGULAR_VALUES)) & DEALLOCATE(roota%SINGULAR_VALUES) NULLIFY(roota%SINGULAR_VALUES) root%NB_SINGULAR_VALUES=NN ALLOCATE(roota%SINGULAR_VALUES(NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN IF ( LP .GT. 0 ) & WRITE(LP,*) 'DMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating SINGULAR_VALUES' GOTO 100 END IF IF(KEEP(19).EQ.1) THEN IF(associated(roota%SVD_U)) DEALLOCATE(roota%SVD_U) NULLIFY(roota%SVD_U) ALLOCATE(roota%SVD_U(NN,NN),stat=ALLOCOK ) IF(ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NN IF ( LP .GT. 0 ) & WRITE(LP,*) 'DMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating SVD_U' GOTO 100 END IF IF (associated(roota%SVD_VT)) DEALLOCATE(roota%SVD_VT) NULLIFY(roota%SVD_VT) ALLOCATE(roota%SVD_VT(NN,NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NN IF ( LP .GT. 0 ) & WRITE(LP,*) 'DMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating SVD_VT' GOTO 100 END IF IF (allocated(RWORK)) DEALLOCATE(RWORK) ALLOCATE(RWORK(1), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=1 IF ( LP .GT. 0 ) & WRITE(LP,*) & 'DMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating RWORK' GOTO 100 END IF ELSEIF(KEEP(19).EQ.2) THEN IF (associated(roota%QR_TAU)) DEALLOCATE(roota%QR_TAU) NULLIFY(roota%QR_TAU) ALLOCATE(roota%QR_TAU(NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN IF ( LP .GT. 0 ) & WRITE(LP,*) & 'DMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating QR_TAU' GOTO 100 END IF IF (associated(ROOT%IPIV)) DEALLOCATE(ROOT%IPIV) NULLIFY(ROOT%IPIV) ALLOCATE(ROOT%IPIV(NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN IF ( LP .GT. 0 ) & WRITE(LP,*) & 'DMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating IPIV' GOTO 100 END IF IF (allocated(RWORK)) DEALLOCATE(RWORK) ALLOCATE(RWORK(1), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=1 IF ( LP .GT. 0 ) & WRITE(LP,*) & 'DMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating RWORK' GOTO 100 END IF ENDIF IF (LDLT.NE.0) THEN CALL DMUMPS_SEQ_SYMMETRIZE(NN,A) END IF LDA=NN LDU=NN LDVT=NN IERR = 0 IF(KEEP(19).EQ.1) THEN CALL dgesvd('A','A',NN,NN,A,LDA,roota%SINGULAR_VALUES(1) & ,roota%SVD_U(1,1) & ,LDU,roota%SVD_VT(1,1),LDVT,WR03,LWR03,IERR) ENDIF IF(IERR.NE.0) THEN INFO(1)=-107 INFO(2)=IERR IF (LP.GT.0) THEN IF(KEEP(19).EQ.1) THEN WRITE(LP,*) ' Problem in dgesvd : IERR = ', IERR ELSEIF(KEEP(19).EQ.2) THEN WRITE(LP,*) ' Problem in dgeqpf : IERR = ', IERR ENDIF GOTO 100 END IF ENDIF IF(KEEP(19).EQ.2) THEN DO I=1,NN roota%SINGULAR_VALUES(I)=abs(A(I+NN*(I-1))) ENDDO ENDIF DEFICIENCY=0 MinPiv = DKEEP(20) GAPLIMIT = DKEEP(9) IF (roota%SINGULAR_VALUES(NN).GT.MinPiv) THEN DEFICIENCY = 0 GOTO 170 ENDIF IF (roota%SINGULAR_VALUES(1).LE.GAPLIMIT) THEN DEFICIENCY = NN GOTO 170 ENDIF LAST_BEFORE_GAPLIMIT_IND = 0 LAST_BEFORE_GAP_IND = 0 FIRST_AFTER_MinPiv = 0 FIRST_AFTER_GAPLIMIT = 0 MaxGap = 0 MaxGap1 = 0 Tol_MaxGap = DKEEP(24) DO I=NN,1,-1 IF (FIRST_AFTER_MinPiv.GT.0) exit IF(roota%SINGULAR_VALUES(I).LE.GAPLIMIT) THEN LAST_BEFORE_GAPLIMIT_IND = I ELSE IF ((FIRST_AFTER_GAPLIMIT.EQ.0).AND. & (roota%SINGULAR_VALUES(I).LE.MinPiv)) THEN FIRST_AFTER_GAPLIMIT = I ELSE IF (roota%SINGULAR_VALUES(I).GT.MinPiv) THEN FIRST_AFTER_MinPiv = I IF (FIRST_AFTER_GAPLIMIT.EQ.0) FIRST_AFTER_GAPLIMIT = I ENDIF ENDDO START_POINT = LAST_BEFORE_GAPLIMIT_IND IF ((LAST_BEFORE_GAPLIMIT_IND.EQ.0).AND. & (FIRST_AFTER_GAPLIMIT.GT. FIRST_AFTER_MinPiv)) & START_POINT = FIRST_AFTER_GAPLIMIT END_POINT = FIRST_AFTER_MinPiv IF (FIRST_AFTER_MinPiv.EQ.0) END_POINT = 1 DO I=START_POINT,END_POINT+1,-1 IF (roota%SINGULAR_VALUES(I).EQ.0) THEN LAST_BEFORE_GAP_IND = I ELSE MaxGap1 = roota%SINGULAR_VALUES(I-1)* & (1/roota%SINGULAR_VALUES(I)) IF (MaxGap1.GE. Tol_MaxGap) THEN IF (MaxGap1.GE. DKEEP(25)*MaxGap ) THEN LAST_BEFORE_GAP_IND = I MaxGap = MaxGap1 ENDIF ENDIF ENDIF ENDDO IF (MaxGap.EQ.ZERO) THEN IF (LAST_BEFORE_GAPLIMIT_IND.EQ.0) THEN DEFICIENCY = 0 ELSE DEFICIENCY = NN - LAST_BEFORE_GAPLIMIT_IND +1 ENDIF ELSE DEFICIENCY = NN - LAST_BEFORE_GAP_IND +1 ENDIF 170 CONTINUE DEFICIENCY=min(DEFICIENCY,MAXDEF) DEFICIENCY=max(DEFICIENCY,MINDEF) KEEP(17)=DEFICIENCY IF(KEEP(19).EQ.2) THEN IF(DEFICIENCY.GT.0) THEN CALL dtrtrs('U','N','N',NN-DEFICIENCY,DEFICIENCY, & A,LDA,A(LDA*(NN-DEFICIENCY)+1),LDA,IERR) IF ( IERR .NE. 0 ) THEN IF (LP.GT.0) & WRITE(LP,*) ' Internal error in dtrtrs: IERR = ',IERR CALL MUMPS_ABORT() END IF END IF ENDIF DO J=NN-DEFICIENCY+1, NN IF(KEEP(19).EQ.1) THEN PIVNUL_LIST(J-NN+DEFICIENCY) = ROW_INDICES(J) ELSEIF(KEEP(19).EQ.2) THEN PIVNUL_LIST(J-NN+DEFICIENCY) = ROW_INDICES(root%IPIV(J)) ENDIF ENDDO 100 CONTINUE IF (allocated(RWORK)) DEALLOCATE(RWORK) RETURN END SUBROUTINE DMUMPS_SEQ_FACTO_ROOT_SVD_QR SUBROUTINE DMUMPS_SEQ_SOLVE_ROOT_SVD_QR & (NRHS,NN,A,root, roota, & IBEG_ROOT_DEF, IEND_ROOT_DEF, & RHS,KEEP,KEEP8,MTYPE,INFO,LWK8,WK, LP) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER NN, NRHS INTEGER(8), INTENT(IN) :: LWK8 TYPE ( MUMPS_ROOT_STRUC ) :: root TYPE ( DMUMPS_ROOT_STRUC ) :: roota DOUBLE PRECISION A(NN*NN) INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, MTYPE INTEGER INFO(2),KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION RHS(NN,NRHS), WK(LWK8) INTEGER LP INTEGER :: LWK DOUBLE PRECISION,DIMENSION(:,:), allocatable :: TEMP_RHS INTEGER :: I,IERR,K INTEGER :: LDLT,RRSTRAT,DEFICIENCY,LDA,LDRHS INTEGER :: ALLOCOK DOUBLE PRECISION, PARAMETER :: RONE=1.0D+0 DOUBLE PRECISION ZERO, ONE, MINUSONE PARAMETER( ZERO = 0.0D0, ONE = 1.0D0, MINUSONE=-1.0D0 ) LDLT = KEEP(50) RRSTRAT = KEEP(19) DEFICIENCY = KEEP(17) LDA = NN LDRHS = NN LWK = int(min(int(huge(LWK),8),LWK8)) IERR = 0 IF ((RRSTRAT .NE. 1).AND.(RRSTRAT .NE. 2)) THEN WRITE(*,*) " *** Internal error ption ",RRSTRAT, & " for null space no more available." CALL MUMPS_ABORT() ENDIF IF (KEEP(111).EQ.0) THEN IF(KEEP(19).EQ.1) THEN IF ((MTYPE.EQ.0).OR.(LDLT.GT.0)) THEN allocate(TEMP_RHS(NN,NRHS), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NRHS IF ( LP .GT. 0 ) & WRITE(LP,*) & 'DMUMPS_SEQ_SOLVE_ROOT_SVD_QR: Problem ' & //'allocating TEMP_RHS' RETURN END IF CALL dgemm('Transpose','N',NN,NRHS,NN,ONE, & roota%SVD_U(1,1),NN,RHS, & NN,ZERO,TEMP_RHS,NN) DO I=1,NN-DEFICIENCY TEMP_RHS( I, 1:NRHS ) = (ONE/roota%SINGULAR_VALUES(I))* & TEMP_RHS( I, 1:NRHS ) ENDDO DO I=NN-DEFICIENCY +1, NN TEMP_RHS(I, 1:NRHS) = ZERO ENDDO CALL dgemm('Transpose','N',NN,NRHS,NN,ONE, & roota%SVD_VT(1,1),NN, & TEMP_RHS, NN,ZERO,RHS,NN) DEALLOCATE(TEMP_RHS) ELSEIF(MTYPE.EQ.1) THEN allocate(TEMP_RHS(NN,NRHS), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NRHS IF ( LP .GT. 0 ) & WRITE(LP,*) & 'DMUMPS_SEQ_SOLVE_ROOT_SVD_QR: Problem ' & //'allocating TEMP_RHS' RETURN END IF CALL dgemm('N','N',NN,NRHS,NN,ONE,roota%SVD_VT(1,1),NN, & RHS, NN,ZERO,TEMP_RHS,NN) DO I=1,NN-DEFICIENCY TEMP_RHS( I, 1:NRHS ) = (ONE/roota%SINGULAR_VALUES(I))* & TEMP_RHS( I, 1:NRHS ) ENDDO DO I=NN-DEFICIENCY +1, NN TEMP_RHS(I, 1:NRHS) = ZERO ENDDO CALL dgemm('N','N',NN,NRHS,NN,ONE,roota%SVD_U(1,1),NN, & TEMP_RHS,NN,ZERO,RHS,NN) DEALLOCATE(TEMP_RHS) ENDIF ELSEIF(KEEP(19).EQ.2) THEN IF ((MTYPE.EQ.0).OR.(LDLT.GT.0)) THEN CALL dormqr('L','Transpose',NN,NRHS,NN, & A,LDA,roota%QR_TAU(1), & RHS,LDRHS,WK(1),LWK,IERR) IF(IERR.LT.0) THEN WRITE(*,*) & 'Error return from dormqr in root solve: IERR=', IERR RETURN END IF CALL dtrtrs('U','N','N',NN-DEFICIENCY,NRHS,A,LDA, & RHS,LDRHS,IERR) IF ( IERR .LT. 0 ) THEN WRITE(*,*) & 'Error return from dtrtrs in roor solve: IERR =',IERR RETURN END IF DO I=1,NRHS RHS( NN - DEFICIENCY + 1: NN, I ) = ZERO ENDDO DO I=1,NRHS CALL DMUMPS_UXVSBP(NN,root%IPIV(1),RHS(1,I),WK) ENDDO ELSEIF(MTYPE.EQ.1) THEN DO I=1,NRHS CALL DMUMPS_UXVSFP(NN,root%IPIV(1),RHS(1,I),WK) ENDDO CALL dtrtrs('U','T','N',NN-DEFICIENCY,NRHS, & A,LDA,RHS,LDRHS,IERR) IF(IERR.NE.0) THEN WRITE(*,*) 'Error return from trtrs: IERR=', IERR STOP END IF DO I=1,NRHS RHS( NN - DEFICIENCY + 1: NN, I ) = ZERO ENDDO CALL dormqr( 'L','N',NN,NRHS,NN,A,LDA,roota%QR_TAU(1), & RHS,LDRHS,WK,LWK,IERR) IF(IERR.LT.0) THEN WRITE(*,*) 'Error return from dormqr: IERR=', IERR RETURN END IF ENDIF ENDIF ELSE IF(KEEP(19).EQ.1) THEN IF ((MTYPE.EQ.0).OR.(LDLT.GT.0)) THEN DO I=IBEG_ROOT_DEF,IEND_ROOT_DEF RHS(:,I+1-IBEG_ROOT_DEF) = & roota%SVD_VT(NN-DEFICIENCY+I,:) ENDDO ELSEIF(MTYPE.EQ.1) THEN DO I=IBEG_ROOT_DEF,IEND_ROOT_DEF RHS(:,I+1-IBEG_ROOT_DEF) = & roota%SVD_U(:,NN-DEFICIENCY+I) ENDDO ENDIF ELSEIF(KEEP(19).EQ.2) THEN IF((MTYPE.EQ.0).OR.(LDLT.GT.0)) THEN DO I=IBEG_ROOT_DEF,IEND_ROOT_DEF RHS(NN-DEFICIENCY+I,I-IBEG_ROOT_DEF+1) = MINUSONE DO K=1,NN-DEFICIENCY RHS(K,I-IBEG_ROOT_DEF+1)= & A(K + LDA*(NN-DEFICIENCY+I-1)) ENDDO ENDDO DO I=1,IEND_ROOT_DEF-IBEG_ROOT_DEF+1 CALL DMUMPS_UXVSBP(NN,root%IPIV(1),RHS(1,I),WK) ENDDO ELSEIF(MTYPE.EQ.1) THEN WRITE(*,*) 'Computation of a null space basis' & // ' of A is unavailable for unsymetric matrices' DO I=IBEG_ROOT_DEF,IEND_ROOT_DEF RHS(NN-DEFICIENCY+I,I-IBEG_ROOT_DEF+1) = ONE ENDDO CALL dormqr('L','N',NN,NRHS,NN, A,LDA,roota%QR_TAU(1), & RHS,LDRHS,WK(1),LWK,IERR) ENDIF ENDIf ENDIF RETURN END SUBROUTINE DMUMPS_SEQ_SOLVE_ROOT_SVD_QR MUMPS_5.8.1/src/sfac_process_root2son.F0000664000175000017500000003240015042446437017663 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE & SMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & INODE, NELIM_ROOT, root, roota, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER KEEP(500), ICNTL( 60 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER INODE, NELIM_ROOT INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28)) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER INTARR(KEEP8(27)) REAL DBLARR(KEEP8(26)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER LCONT, NCOL_TO_SEND, LDA INTEGER(8) :: SHIFT_VAL_SON, POSELT INTEGER FPERE, IOLDPS, NFRONT, NPIV, NASS, NSLAVES, & H_INODE, NELIM, NBCOL, TYPE_SON, & NROW, NCOL, NBROW, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, LDAFS, IERR, & ISON, PDEST_MASTER_ISON INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG LOGICAL TRANSPOSE_ASM INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE FPERE = KEEP(38) TYPE_SON = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ).EQ.MYID) THEN IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NASS = abs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) H_INODE = 6 + NSLAVES + KEEP(IXSZ) NELIM = NASS - NPIV NBCOL = NFRONT - NPIV IF (NELIM.LE.0) THEN write(6,*) ' ERROR 1 in SMUMPS_PROCESS_ROOT2SON ', NELIM write(6,*) MYID,':Process root2son: INODE=',INODE, & 'Header=',IW(PTLUST_S(STEP(INODE)):PTLUST_S(STEP(INODE)) & +5+KEEP(IXSZ)) CALL MUMPS_ABORT() ENDIF NBROW = NFRONT - NPIV NROW = NELIM IF ( KEEP( 50 ) .eq. 0 ) THEN NCOL = NFRONT - NPIV ELSE NCOL = NELIM END IF SHIFT_LIST_ROW_SON = H_INODE + NPIV SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV IF ( KEEP(50).eq.0 .OR. TYPE_SON .eq. 1 ) THEN LDAFS = NFRONT ELSE LDAFS = NASS END IF SHIFT_VAL_SON = int(NPIV,8) * int(LDAFS,8) + int(NPIV,8) CALL SMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, & ASS_IRECV, & N, INODE, FPERE, & PTLUST_S(1), PTRAST(1), & root, roota, NROW, NCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDAFS, & ROOT_NON_ELIM_CB, MYID, COMM, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S(1), PTRFAC(1), PTRAST(1), & STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE.,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS, NELIM_ROOT, NELIM, NELIM & ) IF (IFLAG.LT.0 ) RETURN IF (TYPE_SON.EQ.1) THEN NROW = NFRONT - NASS NCOL = NELIM SHIFT_LIST_ROW_SON = H_INODE + NASS SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV SHIFT_VAL_SON = int(NASS,8) * int(NFRONT,8) + int(NPIV,8) IF ( KEEP( 50 ) .eq. 0 ) THEN TRANSPOSE_ASM = .FALSE. ELSE TRANSPOSE_ASM = .TRUE. END IF CALL SMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTLUST_S, PTRAST, & root, roota, NROW, NCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, & ROOT_NON_ELIM_CB, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP, & TRANSPOSE_ASM,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS, & NELIM_ROOT, 0, NELIM ) 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 IF (KEEP(50).NE.0) THEN CALL SMUMPS_COMPACT_FACTORS_SYM(A(POSELT), LDA, & NPIV, NBROW, KEEP, & int(LDA,8)*int(NBROW+NPIV,8), IW(IOLDPS+H_INODE+NFRONT)) ELSE CALL SMUMPS_COMPACT_FACTORS_UNSYM( & A(POSELT+int(NPIV,8)*int(LDA,8)), LDA, & NPIV, NBROW, KEEP, & int(LDA,8)*int(NBROW+NPIV,8) ) ENDIF IW(IOLDPS + KEEP(IXSZ)) = NBCOL IW(IOLDPS + 1 +KEEP(IXSZ)) = NASS - NPIV IF (TYPE_SON.EQ.2) THEN IW(IOLDPS + 2 +KEEP(IXSZ)) = NASS ELSE IW(IOLDPS + 2 +KEEP(IXSZ)) = NFRONT ENDIF IW(IOLDPS + 3 +KEEP(IXSZ)) = NPIV CALL SMUMPS_COMPRESS_LU(0_8,MYID,N,IOLDPS,TYPE_SON,IW,LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST,PTRFAC,STEP, KEEP,KEEP8, .FALSE.,INODE,IERR & , LRGROUPS, NASS & ) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 RETURN ENDIF ELSE ISON = INODE PDEST_MASTER_ISON = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(ISON)), KEEP(199) ) IF ( PTRIST(STEP(ISON)) .EQ. 0) THEN CALL SMUMPS_TREAT_DESCBAND( ISON, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE,LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 +KEEP(IXSZ)) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN END DO IOLDPS = PTRIST(STEP(INODE)) LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV IF (NELIM.LE.0) THEN write(6,*) MYID,': INODE,LCONT, NROW, NPIV, NASS, NELIM=', & INODE,LCONT, NROW, NPIV, NASS, NELIM write(6,*) MYID,': IOLDPS=',IOLDPS write(6,*) MYID,': ERROR 2 in SMUMPS_PROCESS_ROOT2SON ' CALL MUMPS_ABORT() ENDIF NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) H_INODE = 6 + NSLAVES + KEEP(IXSZ) SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NPIV NCOL_TO_SEND = NELIM LDA = -9999 SHIFT_VAL_SON = -9999_8 IF ( KEEP( 50 ) .eq. 0 ) THEN TRANSPOSE_ASM = .FALSE. ELSE TRANSPOSE_ASM = .TRUE. END IF CALL SMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTRIST, PTRAST, & root, roota, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, & ROOT_NON_ELIM_CB, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,TRANSPOSE_ASM, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS, & NELIM_ROOT, 0, NCOL_TO_SEND ) IF (IFLAG.LT.0 ) RETURN IF (KEEP(214).EQ.2) THEN CALL SMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP, KEEP8, DKEEP,TYPE_SON & ) ENDIF IF (IFLAG.LT.0) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_PROCESS_ROOT2SON MUMPS_5.8.1/src/zmumps_f77.F0000664000175000017500000004410515042446441015362 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, NBLK, ICNTL, & CNTL, KEEP, DKEEP, KEEP8, NZ, NNZ, IRN, IRNhere, JCN, & JCNhere, A, Ahere, NZ_loc, NNZ_loc, IRN_loc, IRN_lochere, & JCN_loc, JCN_lochere, A_loc, A_lochere, NELT, ELTPTR, & ELTPTRhere, ELTVAR, ELTVARhere, A_ELT, A_ELThere, & BLKPTR, BLKPTRhere, BLKVAR, BLKVARhere, PERM_IN, PERM_INhere, & ROWIND, ROWINDhere, COLIND, COLINDhere, PIVOTS, PIVOTShere, & RHS, RHShere, REDRHS, REDRHShere, & INFO, RINFO, INFOG, RINFOG, DEFICIENCY, LWK_USER, & SIZE_SCHUR, LISTVAR_SCHUR, LISTVAR_SCHURhere, SCHUR, & SCHURhere, WK_USER, WK_USERhere, COLSCA, COLSCAhere, & ROWSCA, ROWSCAhere, INSTANCE_NUMBER, NRHS, LRHS, LREDRHS, & RHS_SPARSE, RHS_SPARSEhere, SOL_loc, SOL_lochere, & RHS_loc, RHS_lochere, & IRHS_SPARSE, IRHS_SPARSEhere, IRHS_PTR, IRHS_PTRhere, & ISOL_loc, ISOL_lochere, IRHS_loc, IRHS_lochere, NZ_RHS, & LSOL_loc, LRHS_loc, NSOL_loc, Nloc_RHS, & SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD, & MBLOCK, NBLOCK, NPROW, NPCOL, LD_RHSINTR, & OOC_TMPDIR, OOC_PREFIX, WRITE_PROBLEM, #if ! defined(NO_SAVE_RESTORE) & SAVE_DIR, SAVE_PREFIX, #endif & TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN, #if ! defined(NO_SAVE_RESTORE) & SAVE_DIRLEN, SAVE_PREFIXLEN, #endif & METIS_OPTIONS & ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INTEGER OOC_PREFIX_MAX_LENGTH, OOC_TMPDIR_MAX_LENGTH INTEGER PB_MAX_LENGTH PARAMETER(OOC_PREFIX_MAX_LENGTH=255, OOC_TMPDIR_MAX_LENGTH=1023) PARAMETER(PB_MAX_LENGTH=1023) #if ! defined(NO_SAVE_RESTORE) INTEGER, PARAMETER :: SAVE_DIR_MAX_LENGTH = 1023 INTEGER, PARAMETER :: SAVE_PREFIX_MAX_LENGTH = 255 #endif INTEGER JOB, SYM, PAR, COMM_F77, N, NBLK, NZ, NZ_loc, NELT, & DEFICIENCY, LWK_USER, SIZE_SCHUR, INSTANCE_NUMBER, & NRHS, LRHS, & NZ_RHS, LSOL_loc,Nloc_RHS, LRHS_loc, NSOL_loc, LREDRHS INTEGER(8) :: NNZ, NNZ_loc INTEGER ICNTL(60), INFO(80), INFOG(80), KEEP(500) INTEGER SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER MBLOCK, NBLOCK, NPROW, NPCOL INTEGER LD_RHSINTR INTEGER TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN DOUBLE PRECISION CNTL(15), RINFO(40), RINFOG(40), DKEEP(230) INTEGER(8) KEEP8(150) INTEGER, TARGET :: IRN(*), JCN(*), ELTPTR(*), ELTVAR(*) INTEGER, TARGET :: PERM_IN(*), IRN_loc(*), JCN_loc(*) INTEGER, TARGET :: LISTVAR_SCHUR(*) INTEGER, TARGET :: IRHS_PTR(*), IRHS_SPARSE(*) INTEGER, TARGET :: ISOL_loc(*), IRHS_loc(*) INTEGER, TARGET :: BLKPTR(*), BLKVAR(*) COMPLEX(kind=8), TARGET :: A(*), A_ELT(*), A_loc(*), RHS(*) INTEGER, TARGET :: ROWIND(*), COLIND(*) COMPLEX(kind=8), TARGET :: PIVOTS(*) COMPLEX(kind=8), TARGET :: WK_USER(*) COMPLEX(kind=8), TARGET :: REDRHS(*) DOUBLE PRECISION, TARGET :: ROWSCA(*), COLSCA(*) COMPLEX(kind=8), TARGET :: SCHUR(*) COMPLEX(kind=8), TARGET :: RHS_SPARSE(*), SOL_loc(*), RHS_loc(*) INTEGER, INTENT(inout) :: OOC_TMPDIR(OOC_TMPDIR_MAX_LENGTH) INTEGER, INTENT(inout) :: OOC_PREFIX(OOC_PREFIX_MAX_LENGTH) INTEGER, INTENT(in) :: WRITE_PROBLEM(PB_MAX_LENGTH) #if ! defined(NO_SAVE_RESTORE) INTEGER SAVE_DIRLEN, SAVE_PREFIXLEN INTEGER, INTENT(in) :: SAVE_DIR(SAVE_DIR_MAX_LENGTH) INTEGER, INTENT(in) :: SAVE_PREFIX(SAVE_PREFIX_MAX_LENGTH) #endif INTEGER METIS_OPTIONS(40) INTEGER IRNhere, JCNhere, Ahere, ELTPTRhere, ELTVARhere, & A_ELThere, BLKPTRhere, BLKVARhere, PERM_INhere, & WK_USERhere, ROWINDhere, COLINDhere, PIVOTShere, & RHShere, REDRHShere, IRN_lochere, & JCN_lochere, A_lochere, LISTVAR_SCHURhere, & SCHURhere, COLSCAhere, ROWSCAhere, RHS_SPARSEhere, & SOL_lochere, RHS_lochere, IRHS_PTRhere, IRHS_SPARSEhere, & ISOL_lochere, IRHS_lochere INCLUDE 'mpif.h' TYPE ZMUMPS_STRUC_PTR TYPE (ZMUMPS_STRUC), POINTER :: PTR END TYPE ZMUMPS_STRUC_PTR TYPE (ZMUMPS_STRUC), POINTER :: mumps_par TYPE (ZMUMPS_STRUC_PTR), DIMENSION (:), POINTER, SAVE :: & mumps_par_array TYPE (ZMUMPS_STRUC_PTR), DIMENSION (:), POINTER :: & mumps_par_array_bis INTEGER, SAVE :: ZMUMPS_STRUC_ARRAY_SIZE = 0 INTEGER, SAVE :: N_INSTANCES = 0 INTEGER I, Np, IERR INTEGER(8) :: A_ELT_SIZE, NNZ_i INTEGER ZMUMPS_STRUC_ARRAY_SIZE_INIT PARAMETER (ZMUMPS_STRUC_ARRAY_SIZE_INIT=10) EXTERNAL MUMPS_ASSIGN_MAPPING, & MUMPS_ASSIGN_PIVNUL_LIST, & MUMPS_ASSIGN_SYM_PERM, & MUMPS_ASSIGN_UNS_PERM, & MUMPS_ASSIGN_GLOB2LOC_RHS, & MUMPS_ASSIGN_GLOB2LOC_SOL EXTERNAL MUMPS_NULLIFY_C_MAPPING, & MUMPS_NULLIFY_C_PIVNUL_LIST, & MUMPS_NULLIFY_C_SYM_PERM, & MUMPS_NULLIFY_C_UNS_PERM, & MUMPS_NULLIFY_C_GLOB2LOC_RHS, & MUMPS_NULLIFY_C_GLOB2LOC_SOL EXTERNAL ZMUMPS_ASSIGN_COLSCA, & ZMUMPS_ASSIGN_ROWSCA, & ZMUMPS_ASSIGN_ROWSCA_LOC, & ZMUMPS_ASSIGN_COLSCA_LOC, & ZMUMPS_ASSIGN_RHSINTR, & ZMUMPS_ASSIGN_SINGULAR_VALUES EXTERNAL ZMUMPS_NULLIFY_C_COLSCA, & ZMUMPS_NULLIFY_C_ROWSCA, & ZMUMPS_NULLIFY_C_ROWSCA_LOC, & ZMUMPS_NULLIFY_C_COLSCA_LOC, & ZMUMPS_NULLIFY_C_RHSINTR, & ZMUMPS_NULLIFY_C_SING_VALUES IF (JOB == -1) THEN DO I = 1, ZMUMPS_STRUC_ARRAY_SIZE IF ( .NOT. associated(mumps_par_array(I)%PTR) ) GOTO 10 END DO ALLOCATE( mumps_par_array_bis(ZMUMPS_STRUC_ARRAY_SIZE + & ZMUMPS_STRUC_ARRAY_SIZE_INIT), stat=IERR) IF (IERR /= 0) THEN WRITE(*,*) ' ** Allocation Error 1 in ZMUMPS_F77.' CALL MUMPS_ABORT() END IF DO I = 1, ZMUMPS_STRUC_ARRAY_SIZE mumps_par_array_bis(I)%PTR=>mumps_par_array(I)%PTR ENDDO IF (associated(mumps_par_array)) DEALLOCATE(mumps_par_array) mumps_par_array=>mumps_par_array_bis NULLIFY(mumps_par_array_bis) DO I = ZMUMPS_STRUC_ARRAY_SIZE+1, ZMUMPS_STRUC_ARRAY_SIZE + & ZMUMPS_STRUC_ARRAY_SIZE_INIT NULLIFY(mumps_par_array(I)%PTR) ENDDO I = ZMUMPS_STRUC_ARRAY_SIZE+1 ZMUMPS_STRUC_ARRAY_SIZE = ZMUMPS_STRUC_ARRAY_SIZE + & ZMUMPS_STRUC_ARRAY_SIZE_INIT 10 CONTINUE INSTANCE_NUMBER = I N_INSTANCES = N_INSTANCES+1 ALLOCATE( mumps_par_array(INSTANCE_NUMBER)%PTR,stat=IERR ) IF (IERR /= 0) THEN WRITE(*,*) '** Allocation Error 2 in ZMUMPS_F77.' CALL MUMPS_ABORT() ENDIF ICNTL(1:60) = 0 CNTL(1:15) = 0.0D0 KEEP(1:500) = 0 DKEEP(1:230) = 0.0D0 KEEP8(1:150) = 0_8 METIS_OPTIONS(1:40) = 0 mumps_par_array(INSTANCE_NUMBER)%PTR%INSTANCE_NUMBER = & INSTANCE_NUMBER END IF IF ( INSTANCE_NUMBER .LE. 0 .OR. INSTANCE_NUMBER .GT. & ZMUMPS_STRUC_ARRAY_SIZE ) THEN WRITE(*,*) ' ** Instance Error 1 in ZMUMPS_F77', & INSTANCE_NUMBER CALL MUMPS_ABORT() END IF IF ( .NOT. associated ( mumps_par_array(INSTANCE_NUMBER)%PTR ) ) & THEN WRITE(*,*) ' Instance Error 2 in ZMUMPS_F77', & INSTANCE_NUMBER CALL MUMPS_ABORT() END IF mumps_par => mumps_par_array(INSTANCE_NUMBER)%PTR mumps_par%SYM = SYM mumps_par%PAR = PAR mumps_par%JOB = JOB mumps_par%N = N mumps_par%NBLK = NBLK mumps_par%NZ = NZ mumps_par%NNZ = NNZ mumps_par%NZ_loc = NZ_loc mumps_par%NNZ_loc = NNZ_loc mumps_par%LWK_USER = LWK_USER mumps_par%SIZE_SCHUR = SIZE_SCHUR mumps_par%NELT= NELT mumps_par%ICNTL(1:60)=ICNTL(1:60) mumps_par%CNTL(1:15)=CNTL(1:15) mumps_par%KEEP(1:500)=KEEP(1:500) mumps_par%DKEEP(1:230)=DKEEP(1:230) mumps_par%KEEP8(1:150)=KEEP8(1:150) CALL MUMPS_ADDR_C( ICNTL(50), mumps_par%KEEP8(83) ) CALL MUMPS_ADDR_C( RINFO(3), mumps_par%KEEP8(84) ) mumps_par%METIS_OPTIONS(1:40)=METIS_OPTIONS(1:40) mumps_par%NRHS = NRHS mumps_par%LRHS = LRHS mumps_par%LREDRHS = LREDRHS mumps_par%NZ_RHS = NZ_RHS mumps_par%LSOL_loc = LSOL_loc mumps_par%Nloc_RHS = Nloc_RHS mumps_par%LRHS_loc = LRHS_loc mumps_par%NSOL_loc = NSOL_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 mumps_par%LD_RHSINTR = LD_RHSINTR IF ( COMM_F77 .NE. -987654 ) THEN mumps_par%COMM = COMM_F77 ELSE mumps_par%COMM = MPI_COMM_WORLD ENDIF CALL MPI_BCAST(NRHS,1,MPI_INTEGER,0,mumps_par%COMM,IERR) CALL MUMPS_GET_NNZ_INTERNAL(NNZ,NZ,NNZ_i) IF ( IRNhere /= 0 ) mumps_par%IRN => IRN(1:NNZ_i) IF ( JCNhere /= 0 ) mumps_par%JCN => JCN(1:NNZ_i) IF ( Ahere /= 0 ) mumps_par%A => A(1:NNZ_i) CALL MUMPS_GET_NNZ_INTERNAL(NNZ_loc,NZ_loc,NNZ_i) IF ( IRN_lochere /= 0 ) mumps_par%IRN_loc => IRN_loc(1:NNZ_i) IF ( JCN_lochere /= 0 ) mumps_par%JCN_loc => JCN_loc(1:NNZ_i) IF ( A_lochere /= 0 ) mumps_par%A_loc => A_loc(1:NNZ_i) IF ( ELTPTRhere /= 0 ) mumps_par%ELTPTR => ELTPTR(1:NELT+1) IF ( ELTVARhere /= 0 ) mumps_par%ELTVAR => & ELTVAR(1:ELTPTR(NELT+1)-1) IF ( A_ELThere /= 0 ) THEN A_ELT_SIZE = 0_8 DO I = 1, NELT Np = ELTPTR(I+1) -ELTPTR(I) IF (SYM == 0) THEN A_ELT_SIZE = A_ELT_SIZE + Np * Np ELSE A_ELT_SIZE = A_ELT_SIZE + Np * ( Np + 1 ) / 2 END IF END DO mumps_par%A_ELT => A_ELT(1_8:A_ELT_SIZE) END IF IF ( BLKPTRhere /= 0 ) mumps_par%BLKPTR => BLKPTR(1:NBLK+1) IF ( BLKVARhere /= 0 ) mumps_par%BLKVAR => BLKVAR(1:N) IF ( PERM_INhere /= 0) mumps_par%PERM_IN => PERM_IN(1:N) IF ( LISTVAR_SCHURhere /= 0) & mumps_par%LISTVAR_SCHUR =>LISTVAR_SCHUR(1:SIZE_SCHUR) IF ( SCHURhere /= 0 ) THEN mumps_par%SCHUR_CINTERFACE=>SCHUR(1:1) ENDIF IF (ROWINDhere /= 0) THEN mumps_par%ROWIND => ROWIND(1:KEEP(89)) ENDIF IF (COLINDhere /= 0) THEN mumps_par%COLIND => COLIND(1:KEEP(89)) ENDIF IF (PIVOTShere /= 0) THEN IF (KEEP(50) .EQ.0 .OR.KEEP(50).EQ.1) THEN mumps_par%PIVOTS => PIVOTS(1:KEEP(89)) ELSE mumps_par%PIVOTS => PIVOTS(1_8: & int(KEEP(89),8)+int(KEEP(89),8)) ENDIF ENDIF IF (NRHS .NE. 1) THEN IF ( RHShere /= 0 ) mumps_par%RHS => & RHS(1_8:int(NRHS,8)*int(LRHS,8)) IF (REDRHShere /= 0)mumps_par%REDRHS=> & REDRHS(1_8:int(NRHS,8)*int(LREDRHS,8)) ELSE IF ( RHShere /= 0 ) mumps_par%RHS => RHS(1:N) IF (REDRHShere /= 0)mumps_par%REDRHS=>REDRHS(1:SIZE_SCHUR) ENDIF IF ( WK_USERhere /=0 ) THEN IF (LWK_USER > 0 ) THEN mumps_par%WK_USER => WK_USER(1:LWK_USER) ELSE mumps_par%WK_USER => WK_USER(1_8:-int(LWK_USER,8)*1000000_8) ENDIF ENDIF IF ( COLSCAhere /= 0) mumps_par%COLSCA => COLSCA(1:N) IF ( ROWSCAhere /= 0) mumps_par%ROWSCA => ROWSCA(1:N) IF ( RHS_SPARSEhere /=0 ) mumps_par%RHS_SPARSE=> & RHS_SPARSE(1:NZ_RHS) IF ( IRHS_SPARSEhere /=0 ) mumps_par%IRHS_SPARSE=> & IRHS_SPARSE(1:NZ_RHS) IF ( SOL_lochere /=0 ) mumps_par%SOL_loc=> & SOL_loc(1_8:int(LSOL_loc,8)*int(NRHS,8)) IF ( RHS_lochere /=0 ) mumps_par%RHS_loc=> & RHS_loc(1_8:int(LRHS_loc,8)*int(NRHS,8)) IF ( ISOL_lochere /=0 ) mumps_par%ISOL_loc=> & ISOL_loc(1:LSOL_loc) IF ( IRHS_lochere /=0 ) mumps_par%IRHS_loc=> & IRHS_loc(1:LRHS_loc) IF ( IRHS_PTRhere /=0 ) mumps_par%IRHS_PTR=> & IRHS_PTR(1:NRHS+1) DO I=1,TMPDIRLEN mumps_par%OOC_TMPDIR(I:I)=char(OOC_TMPDIR(I)) ENDDO DO I=TMPDIRLEN+1,OOC_TMPDIR_MAX_LENGTH mumps_par%OOC_TMPDIR(I:I)=' ' ENDDO DO I=1,PREFIXLEN mumps_par%OOC_PREFIX(I:I)=char(OOC_PREFIX(I)) ENDDO DO I=PREFIXLEN+1,OOC_PREFIX_MAX_LENGTH mumps_par%OOC_PREFIX(I:I)=' ' ENDDO DO I=1,WRITE_PROBLEMLEN mumps_par%WRITE_PROBLEM(I:I)=char(WRITE_PROBLEM(I)) ENDDO DO I=WRITE_PROBLEMLEN+1,PB_MAX_LENGTH mumps_par%WRITE_PROBLEM(I:I)=' ' ENDDO #if ! defined(NO_SAVE_RESTORE) DO I=1,SAVE_DIRLEN mumps_par%SAVE_DIR(I:I)=char(SAVE_DIR(I)) ENDDO DO I=SAVE_DIRLEN+1,SAVE_DIR_MAX_LENGTH mumps_par%SAVE_DIR(I:I)=' ' ENDDO DO I=1,SAVE_PREFIXLEN mumps_par%SAVE_PREFIX(I:I)=char(SAVE_PREFIX(I)) ENDDO DO I=SAVE_PREFIXLEN+1,SAVE_PREFIX_MAX_LENGTH mumps_par%SAVE_PREFIX(I:I)=' ' ENDDO #endif CALL ZMUMPS( mumps_par ) INFO(1:80)=mumps_par%INFO(1:80) INFOG(1:80)=mumps_par%INFOG(1:80) RINFO(1:40)=mumps_par%RINFO(1:40) RINFOG(1:40)=mumps_par%RINFOG(1:40) ICNTL(1:60) = mumps_par%ICNTL(1:60) CNTL(1:15) = mumps_par%CNTL(1:15) KEEP(1:500) = mumps_par%KEEP(1:500) DKEEP(1:230) = mumps_par%DKEEP(1:230) KEEP8(1:150) = mumps_par%KEEP8(1:150) METIS_OPTIONS(1:40) = mumps_par%METIS_OPTIONS(1:40) SYM = mumps_par%SYM PAR = mumps_par%PAR JOB = mumps_par%JOB N = mumps_par%N NBLK = mumps_par%NBLK NZ = mumps_par%NZ NNZ = mumps_par%NNZ NRHS = mumps_par%NRHS LRHS = mumps_par%LRHS LREDRHS = mumps_par%LREDRHS NZ_loc = mumps_par%NZ_loc NNZ_loc = mumps_par%NNZ_loc NZ_RHS = mumps_par%NZ_RHS LSOL_loc = mumps_par%LSOL_loc Nloc_RHS = mumps_par%Nloc_RHS LRHS_loc = mumps_par%LRHS_loc NSOL_loc = mumps_par%NSOL_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 LD_RHSINTR = mumps_par%LD_RHSINTR IF ( associated (mumps_par%MAPPING) ) THEN CALL MUMPS_ASSIGN_MAPPING(mumps_par%MAPPING(1)) ELSE CALL MUMPS_NULLIFY_C_MAPPING() ENDIF IF ( associated (mumps_par%PIVNUL_LIST) ) THEN CALL MUMPS_ASSIGN_PIVNUL_LIST(mumps_par%PIVNUL_LIST(1)) ELSE CALL MUMPS_NULLIFY_C_PIVNUL_LIST() ENDIF IF ( associated (mumps_par%SINGULAR_VALUES) ) THEN CALL ZMUMPS_ASSIGN_SINGULAR_VALUES( & mumps_par%SINGULAR_VALUES(1)) ELSE CALL ZMUMPS_NULLIFY_C_SING_VALUES() ENDIF IF ( associated (mumps_par%SYM_PERM) ) THEN CALL MUMPS_ASSIGN_SYM_PERM(mumps_par%SYM_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_SYM_PERM() ENDIF IF ( associated (mumps_par%UNS_PERM) ) THEN CALL MUMPS_ASSIGN_UNS_PERM(mumps_par%UNS_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_UNS_PERM() ENDIF IF ( associated (mumps_par%COLSCA_loc) ) THEN CALL ZMUMPS_ASSIGN_COLSCA_LOC(1) ELSE CALL ZMUMPS_NULLIFY_C_COLSCA_LOC() ENDIF IF ( associated (mumps_par%ROWSCA_loc) ) THEN CALL ZMUMPS_ASSIGN_ROWSCA_LOC(1) ELSE CALL ZMUMPS_NULLIFY_C_ROWSCA_LOC() ENDIF IF (associated( mumps_par%COLSCA )) THEN CALL ZMUMPS_ASSIGN_COLSCA(mumps_par%COLSCA(1)) ELSE CALL ZMUMPS_NULLIFY_C_COLSCA() ENDIF IF (associated( mumps_par%ROWSCA )) THEN CALL ZMUMPS_ASSIGN_ROWSCA(mumps_par%ROWSCA(1)) ELSE CALL ZMUMPS_NULLIFY_C_ROWSCA() ENDIF IF (associated( mumps_par%RHSINTR )) THEN CALL ZMUMPS_ASSIGN_RHSINTR(mumps_par%RHSINTR(1)) ELSE CALL ZMUMPS_NULLIFY_C_RHSINTR() ENDIF IF (associated(mumps_par%GLOB2LOC_RHS)) THEN CALL MUMPS_ASSIGN_GLOB2LOC_RHS(mumps_par%GLOB2LOC_RHS(1)) ELSE CALL MUMPS_NULLIFY_C_GLOB2LOC_RHS() ENDIF IF (associated(mumps_par%GLOB2LOC_SOL)) THEN CALL MUMPS_ASSIGN_GLOB2LOC_SOL(mumps_par%GLOB2LOC_SOL(1)) ELSE CALL MUMPS_NULLIFY_C_GLOB2LOC_SOL() ENDIF TMPDIRLEN=len_trim(mumps_par%OOC_TMPDIR) DO I=1,TMPDIRLEN OOC_TMPDIR(I)=ichar(mumps_par%OOC_TMPDIR(I:I)) ENDDO PREFIXLEN=len_trim(mumps_par%OOC_PREFIX) DO I=1,PREFIXLEN OOC_PREFIX(I)=ichar(mumps_par%OOC_PREFIX(I:I)) ENDDO IF ( JOB == -2 ) THEN IF (associated(mumps_par_array(INSTANCE_NUMBER)%PTR))THEN DEALLOCATE(mumps_par_array(INSTANCE_NUMBER)%PTR) NULLIFY (mumps_par_array(INSTANCE_NUMBER)%PTR) N_INSTANCES = N_INSTANCES - 1 IF ( N_INSTANCES == 0 ) THEN DEALLOCATE(mumps_par_array) ZMUMPS_STRUC_ARRAY_SIZE = 0 END IF ELSE WRITE(*,*) "** Warning: instance already freed" WRITE(*,*) " this should normally not happen." ENDIF END IF RETURN END SUBROUTINE ZMUMPS_F77 MUMPS_5.8.1/src/ssol_root_parallel.F0000664000175000017500000000743715042446437017257 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ROOT_SOLVE( NRHS, DESCA_PAR, & CNTXT_PAR,LOCAL_M,LOCAL_N,MBLOCK,NBLOCK, & IPIV,LPIV,MASTER_ROOT,MYID,COMM, & RHS_SEQ,SIZE_ROOT,A,INFO,MTYPE,LDLT ) IMPLICIT NONE INTEGER NRHS, MTYPE INTEGER DESCA_PAR( 9 ) INTEGER LOCAL_M, LOCAL_N, MBLOCK, NBLOCK INTEGER CNTXT_PAR, MASTER_ROOT, SIZE_ROOT INTEGER MYID, COMM INTEGER LPIV, IPIV( LPIV ) INTEGER INFO(80), LDLT REAL RHS_SEQ( SIZE_ROOT *NRHS) REAL A( LOCAL_M, LOCAL_N ) #if ! defined(NOSCALAPACK) INTEGER IERR, NPROW, NPCOL, MYROW, MYCOL INTEGER LOCAL_N_RHS REAL, ALLOCATABLE, DIMENSION( :,: ) ::RHS_PAR INTEGER, EXTERNAL :: MUMPS_NUMROC INTEGER allocok CALL blacs_gridinfo( CNTXT_PAR, NPROW, NPCOL, MYROW, MYCOL ) LOCAL_N_RHS = MUMPS_NUMROC(NRHS, NBLOCK, MYCOL, 0, NPCOL) LOCAL_N_RHS = max(1,LOCAL_N_RHS) ALLOCATE(RHS_PAR(LOCAL_M, LOCAL_N_RHS),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) ' Problem during solve of the root.' WRITE(*,*) ' Reduce number of right hand sides.' CALL MUMPS_ABORT() ENDIF CALL SMUMPS_SCATTER_ROOT( MYID, SIZE_ROOT, NRHS, RHS_SEQ, & LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) CALL SMUMPS_SOLVE_2D_BCYCLIC (SIZE_ROOT, NRHS, MTYPE, & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, & IPIV, LPIV, RHS_PAR, LDLT, & MBLOCK, NBLOCK, CNTXT_PAR, & IERR) CALL SMUMPS_GATHER_ROOT( MYID, SIZE_ROOT, NRHS, & RHS_SEQ, LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) DEALLOCATE(RHS_PAR) #endif RETURN END SUBROUTINE SMUMPS_ROOT_SOLVE #if ! defined(NOSCALAPACK) SUBROUTINE SMUMPS_SOLVE_2D_BCYCLIC (SIZE_ROOT, NRHS, MTYPE, & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, & IPIV, LPIV, RHS_PAR, LDLT, & MBLOCK, NBLOCK, CNTXT_PAR, & IERR) IMPLICIT NONE INTEGER, intent (in) :: SIZE_ROOT, NRHS, LDLT, LOCAL_M, & LOCAL_N, LOCAL_N_RHS, & MBLOCK, NBLOCK, CNTXT_PAR, MTYPE INTEGER, intent (in) :: DESCA_PAR( 9 ) INTEGER, intent (in) :: LPIV, IPIV( LPIV ) REAL, intent (in) :: A( LOCAL_M, LOCAL_N ) REAL, intent (inout) :: RHS_PAR(LOCAL_M, LOCAL_N_RHS) INTEGER, intent (out) :: IERR INTEGER :: DESCB_PAR( 9 ) IERR = 0 CALL DESCINIT( DESCB_PAR, SIZE_ROOT, & NRHS, MBLOCK, NBLOCK, 0, 0, & CNTXT_PAR, LOCAL_M, IERR ) IF (IERR.NE.0) THEN WRITE(*,*) 'After DESCINIT, IERR = ', IERR CALL MUMPS_ABORT() END IF IF ( LDLT .eq. 0 .OR. LDLT .eq. 2 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL psgetrs('N',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, & RHS_PAR,1,1,DESCB_PAR,IERR) ELSE CALL psgetrs('T',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, & RHS_PAR, 1, 1, DESCB_PAR,IERR) END IF ELSE CALL pspotrs( 'L', SIZE_ROOT, NRHS, A, 1, 1, DESCA_PAR, & RHS_PAR, 1, 1, DESCB_PAR, IERR ) END IF IF ( IERR .LT. 0 ) THEN WRITE(*,*) ' Problem during solve of the root' CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE SMUMPS_SOLVE_2D_BCYCLIC #endif MUMPS_5.8.1/src/dmumps_comm_buffer.F0000664000175000017500000032431415042446440017217 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_BUF USE MUMPS_BUF_COMMON, ONLY: BUF_CB, SIZE_RBUF_BYTES, & SIZEofINT, SIZEofREAL, OVHSIZE, BUF_ADJUST, BUF_LOOK, & MUMPS_BUF_SIZE_AVAILABLE PRIVATE INTEGER, SAVE :: BUF_LMAX_ARRAY DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE & , SAVE, TARGET :: BUF_MAX_ARRAY PUBLIC :: BUF_LMAX_ARRAY, BUF_MAX_ARRAY PUBLIC :: DMUMPS_BUF_DEALL_MAX_ARRAY, & DMUMPS_BUF_MAX_ARRAY_MINSIZE PUBLIC :: DMUMPS_BUF_SEND_CB, & DMUMPS_BUF_SEND_MASTER2SLAVE, & DMUMPS_BUF_SEND_VCB, & DMUMPS_BUF_SEND_MAITRE2, & DMUMPS_BUF_SEND_CONTRIB_TYPE2, & DMUMPS_BUF_SEND_BLOCFACTO, & DMUMPS_BUF_SEND_BLFAC_SLAVE, & DMUMPS_BUF_SEND_CONTRIB_TYPE3, & DMUMPS_BUF_SEND_BACKVEC, & DMUMPS_MPI_UNPACK_LRB CONTAINS SUBROUTINE DMUMPS_BUF_DEALL_MAX_ARRAY() IMPLICIT NONE IF (allocated( BUF_MAX_ARRAY)) DEALLOCATE( BUF_MAX_ARRAY ) RETURN END SUBROUTINE DMUMPS_BUF_DEALL_MAX_ARRAY SUBROUTINE DMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IMPLICIT NONE INTEGER IERR, NFS4FATHER IERR = 0 IF (allocated( BUF_MAX_ARRAY)) THEN IF (BUF_LMAX_ARRAY .GE. NFS4FATHER) RETURN DEALLOCATE( BUF_MAX_ARRAY ) ENDIF BUF_LMAX_ARRAY=max(1,NFS4FATHER) ALLOCATE(BUF_MAX_ARRAY(BUF_LMAX_ARRAY),stat=IERR) IF ( IERR .GT. 0 ) THEN IERR = -1 RETURN END IF RETURN END SUBROUTINE DMUMPS_BUF_MAX_ARRAY_MINSIZE SUBROUTINE DMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, LCONT, & NASS, NPIV, & IWROW, IWCOL, A, PACKED_CB, & DEST, TAG, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER DEST, TAG, COMM, IERR INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER INODE, FPERE, NFRONT, LCONT, NASS, NPIV INTEGER IWROW( LCONT ), IWCOL( LCONT ) DOUBLE PRECISION A( * ) LOGICAL PACKED_CB INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER NBROWS_PACKET INTEGER POSITION, IREQ, IPOS, I, J1 INTEGER SIZE1, SIZE2, SIZE_PACK, SIZE_AV, SIZE_AV_REALS INTEGER IZERO, IONE INTEGER SIZECB INTEGER LCONT_SENT INTEGER DEST2(1) PARAMETER( IZERO = 0, IONE = 1 ) LOGICAL RECV_BUF_SMALLER_THAN_SEND DOUBLE PRECISION TMP DEST2(1) = DEST IERR = 0 IF (NBROWS_ALREADY_SENT .EQ. 0) THEN CALL MPI_PACK_SIZE( 11 + LCONT + LCONT, MPI_INTEGER, & COMM, SIZE1, IERR_MPI) ELSE CALL MPI_PACK_SIZE( 5, MPI_INTEGER, COMM, SIZE1, IERR_MPI) ENDIF CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE SIZE_AV = SIZE_RBUF_BYTES RECV_BUF_SMALLER_THAN_SEND = .TRUE. ENDIF SIZE_AV_REALS = ( SIZE_AV - SIZE1 ) / SIZEofREAL IF (SIZE_AV_REALS < 0 ) THEN NBROWS_PACKET = 0 ELSE IF (PACKED_CB) THEN TMP=2.0D0*dble(NBROWS_ALREADY_SENT)+1.0D0 NBROWS_PACKET = int( & ( sqrt( TMP * TMP & + 8.0D0 * dble(SIZE_AV_REALS)) - TMP ) & / 2.0D0 ) ELSE IF (LCONT.EQ.0) THEN NBROWS_PACKET = 0 ELSE NBROWS_PACKET = SIZE_AV_REALS / LCONT ENDIF ENDIF ENDIF 10 CONTINUE NBROWS_PACKET = max(0, & min(NBROWS_PACKET, LCONT - NBROWS_ALREADY_SENT)) IF (NBROWS_PACKET .EQ. 0 .AND. LCONT .NE. 0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (PACKED_CB) THEN SIZECB = (NBROWS_ALREADY_SENT*NBROWS_PACKET)+(NBROWS_PACKET & *(NBROWS_PACKET+1))/2 ELSE SIZECB = NBROWS_PACKET * LCONT ENDIF CALL MPI_PACK_SIZE( SIZECB, MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV ) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF (NBROWS_PACKET > 0) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.LCONT .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 10 & .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , DEST2) IF (IERR .EQ. -1 .OR. IERR .EQ. -2) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF ( NBROWS_PACKET > 0 ) GOTO 10 ENDIF IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (PACKED_CB) THEN LCONT_SENT=-LCONT ELSE LCONT_SENT=LCONT ENDIF CALL MPI_PACK( LCONT_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NBROWS_ALREADY_SENT == 0) THEN CALL MPI_PACK( LCONT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NASS-NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LCONT , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IONE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IWROW, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IWCOL, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF IF ( LCONT .NE. 0 ) THEN J1 = 1 + NBROWS_ALREADY_SENT * NFRONT IF (PACKED_CB) THEN DO I = NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( A( J1 ), I, MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) J1 = J1 + NFRONT END DO ELSE DO I = NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( A( J1 ), LCONT, MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) J1 = J1 + NFRONT END DO ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN WRITE(*,*) 'Error Try_send_cb: SIZE, POSITION=',SIZE_PACK, & POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET IF (NBROWS_ALREADY_SENT .NE. LCONT ) THEN IERR = -1 RETURN ENDIF 100 CONTINUE RETURN END SUBROUTINE DMUMPS_BUF_SEND_CB SUBROUTINE DMUMPS_BUF_SEND_MASTER2SLAVE( NRHS, INODE, IFATH, & EFF_CB_SIZE, LD_CB, LD_PIV, NPIV, & JBDEB, JBFIN, & CB, SOL, & DEST, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER NRHS, INODE, IFATH, EFF_CB_SIZE, LD_CB, LD_PIV, NPIV INTEGER DEST, COMM, IERR, JBDEB, JBFIN DOUBLE PRECISION CB( LD_CB*(NRHS-1)+EFF_CB_SIZE ) DOUBLE PRECISION SOL( max(1, LD_PIV*(NRHS-1)+NPIV) ) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE, SIZE1, SIZE2, K INTEGER POSITION, IREQ, IPOS INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 CALL MPI_PACK_SIZE( 6, MPI_INTEGER, COMM, SIZE1, IERR ) CALL MPI_PACK_SIZE( NRHS * (EFF_CB_SIZE + NPIV), & MPI_DOUBLE_PRECISION, COMM, & SIZE2, IERR_MPI ) SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IFATH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( EFF_CB_SIZE , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPIV , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBDEB , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBFIN , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) DO K = 1, NRHS CALL MPI_PACK( CB ( 1 + LD_CB * (K-1) ), & EFF_CB_SIZE, MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) END DO IF ( NPIV .GT. 0 ) THEN DO K=1, NRHS CALL MPI_PACK( SOL(1+LD_PIV*(K-1)), & NPIV, MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDDO END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, Master2Slave, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) 'Try_send_master2slave: SIZE, POSITION = ', & SIZE, POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE DMUMPS_BUF_SEND_MASTER2SLAVE SUBROUTINE DMUMPS_BUF_SEND_VCB( NRHS_B, NODE1, NODE2, NCB, LDW, & LONG, & IW, W, JBDEB, JBFIN, & RHSINTR, NRHS, LRHSINTR, IPOSINRHSINTR, NPIV, & KEEP, & DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER LDW, DEST, TAG, COMM, IERR INTEGER NRHS_B, NODE1, NODE2, NCB, LONG, JBDEB, JBFIN INTEGER IW( max( 1, LONG ) ) INTEGER, INTENT(IN) :: LRHSINTR, NRHS, IPOSINRHSINTR, NPIV DOUBLE PRECISION W( max( 1, LDW * NRHS_B ) ) DOUBLE PRECISION RHSINTR(LRHSINTR,NRHS) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS INTEGER SIZE1, SIZE2, SIZE, K INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1)=DEST IERR = 0 IF ( NODE2 .EQ. 0 ) THEN CALL MPI_PACK_SIZE( 4+LONG, MPI_INTEGER, COMM, SIZE1, & IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 6+LONG, MPI_INTEGER, COMM, SIZE1, & IERR_MPI ) END IF SIZE2 = 0 IF ( LONG .GT. 0 ) THEN CALL MPI_PACK_SIZE( NRHS_B*LONG, MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR_MPI ) END IF SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = 0 CALL MPI_PACK( NODE1, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF ( NODE2 .NE. 0 ) THEN CALL MPI_PACK( NODE2, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( JBDEB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBFIN, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LONG, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF ( LONG .GT. 0 ) THEN CALL MPI_PACK( IW, LONG, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF (NODE2.EQ.0) THEN DO K=1, NRHS_B IF (NPIV.GT.0) THEN CALL MPI_PACK( RHSINTR(IPOSINRHSINTR,JBDEB+K-1), NPIV, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF IF (LONG-NPIV .NE.0) THEN CALL MPI_PACK( W(NPIV+1+(K-1)*LDW), LONG-NPIV, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF END DO ELSE DO K=1, NRHS_B CALL MPI_PACK( W(1+(K-1)*LDW), LONG, MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) END DO ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE DMUMPS_BUF_SEND_VCB SUBROUTINE DMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, & IPERE, ISON, NROW, & IROW, NCOL, ICOL, VAL, LDA, NELIM, TYPE_SON, & NSLAVES, SLAVES, DEST, COMM, IERR, & & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER LDA, NELIM, TYPE_SON INTEGER IPERE, ISON, NROW, NCOL, NSLAVES INTEGER IROW( NROW ) INTEGER ICOL( NCOL ) INTEGER SLAVES( NSLAVES ) DOUBLE PRECISION VAL(LDA, *) INTEGER IPOS, IREQ, DEST, COMM, IERR INTEGER SLAVEF, KEEP(500), INIV2 INTEGER(8) KEEP8(150) INTEGER TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE1, SIZE2, SIZE3, SIZE_PACK, POSITION, I INTEGER NBROWS_PACKET, NCOL_SEND INTEGER SIZE_AV LOGICAL RECV_BUF_SMALLER_THAN_SEND INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 IF ( NELIM .NE. NROW ) THEN WRITE(*,*) 'Error in TRY_SEND_MAITRE2:',NELIM, NROW CALL MUMPS_ABORT() END IF IF (NBROWS_ALREADY_SENT .EQ. 0) THEN CALL MPI_PACK_SIZE( NROW+NCOL+7+NSLAVES, MPI_INTEGER, & COMM, SIZE1, IERR_MPI ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK_SIZE( NSLAVES+1, MPI_INTEGER, & COMM, SIZE3, IERR_MPI ) ELSE SIZE3 = 0 ENDIF SIZE1=SIZE1+SIZE3 ELSE CALL MPI_PACK_SIZE(7, MPI_INTEGER,COMM,SIZE1,IERR_MPI) ENDIF IF ( KEEP(50).ne.0 .AND. TYPE_SON .eq. 2 ) THEN NCOL_SEND = NROW ELSE NCOL_SEND = NCOL ENDIF CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF IF (NROW .GT. 0 ) THEN NBROWS_PACKET = (SIZE_AV - SIZE1) / NCOL_SEND / SIZEofREAL NBROWS_PACKET = min(NBROWS_PACKET, NROW - NBROWS_ALREADY_SENT) NBROWS_PACKET = max(NBROWS_PACKET, 0) ELSE NBROWS_PACKET =0 ENDIF IF (NBROWS_PACKET .EQ. 0 .AND. NROW .NE. 0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR=-1 GOTO 100 ENDIF ENDIF 10 CONTINUE CALL MPI_PACK_SIZE( NBROWS_PACKET * NCOL_SEND, & MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF ( NBROWS_PACKET .GT. 0 ) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NROW .AND. & SIZE_PACK - SIZE1 .LT. ( SIZE_RBUF_BYTES - SIZE1 ) / 10 & .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN GOTO 100 ENDIF POSITION = 0 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSLAVES, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NBROWS_ALREADY_SENT .EQ. 0) THEN IF (NSLAVES.GT.0) THEN CALL MPI_PACK( SLAVES, NSLAVES, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( IROW, NROW, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ICOL, NCOL, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK( TAB_POS_IN_PERE(1,INIV2), NSLAVES+1, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF IF (NBROWS_PACKET.GE.1) THEN DO I=NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( VAL(1,I), NCOL_SEND, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO ENDIF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, MAITRE2, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN write(*,*) 'Try_send_maitre2, SIZE,POSITION=', & SIZE_PACK,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET IF ( NBROWS_ALREADY_SENT .NE. NROW ) THEN IERR = -1 ENDIF 100 CONTINUE RETURN END SUBROUTINE DMUMPS_BUF_SEND_MAITRE2 SUBROUTINE DMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESC_IN_LU, & IPERE, NFRONT_PERE, NASS_PERE, NFS4FATHER, NSLAVES_PERE, & ISON, NBROW, LMAP, MAPROW, POS_FIRST_ROW_TO_PDEST, & IW_CBSON, A_CBSON, LA_CBSON, & ISLAVE, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP253_LOC, NVSCHUR, & SON_NIV, MYID ) USE DMUMPS_LR_TYPE USE DMUMPS_LR_DATA_M USE MUMPS_BUF_COMMON IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT(inout):: NBCOLS_ALREADY_SENT, & NBLRB_ALREADY_SENT INTEGER, INTENT (in) :: KEEP253_LOC, NVSCHUR INTEGER, INTENT (in) :: SON_NIV INTEGER, INTENT(in) :: POS_FIRST_ROW_TO_PDEST INTEGER IPERE, ISON, NBROW, MYID INTEGER PDEST, ISLAVE, COMM, IERR INTEGER PDEST_MASTER, NASS_PERE, NSLAVES_PERE, & NFRONT_PERE, LMAP INTEGER MAPROW( LMAP ) INTEGER IW_CBSON( * ) DOUBLE PRECISION A_CBSON( : ) INTEGER(8) :: LA_CBSON LOGICAL DESC_IN_LU, PACKED_CB INTEGER KEEP(500), N , SLAVEF INTEGER(8) KEEP8(150) INTEGER STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER NFS4FATHER,SIZE3,PS1,NCA,LROW1 INTEGER(8) :: ASIZE LOGICAL COMPUTE_MAX DOUBLE PRECISION, POINTER, DIMENSION(:) :: M_ARRAY INTEGER NBROWS_PACKET INTEGER NBLRB_TOTAL INTEGER NBLRB_PACKET INTEGER MAX_ROW_LENGTH INTEGER LROW, NELIM INTEGER(8) :: ITMP8 INTEGER NPIV, NFRONT, HS INTEGER SIZE_PACK, SIZE0, SIZE1, SIZE2, POSITION,I INTEGER SIZE_INTEGERS, B, SIZE_REALS, TMPSIZE, ONEorTWO, SIZE_AV INTEGER SIZE_NEXT_BLOCK 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 LOGICAL AVOID_TOO_SMALL_GRANULARITY INTEGER PDEST2(1) LOGICAL CB_IS_LR TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL, & BEGS_BLR_STA INTEGER :: NB_ROW_SHIFT, NB_COL_SHIFT, NASS_SHIFT, PANEL2SEND, & CURRENT_PANEL_SIZE, NB_BLR_ROWS, NB_BLR_COLS, & CB_IS_LR_INT, NCOL_SHIFT, NROW_SHIFT, & PANEL_BEG_OFFSET INTEGER :: NPIV_LR, LNEXT DOUBLE PRECISION :: K170PER1000 PARAMETER ( IONE=1 ) INCLUDE 'mumps_headers.h' DOUBLE PRECISION ZERO PARAMETER (ZERO = 0.0D0) CB_IS_LR = (IW_CBSON(1+XXLR).EQ.1 & .OR. IW_CBSON(1+XXLR).EQ.3) NBLRB_PACKET = 0 NBLRB_TOTAL = 0 IF (CB_IS_LR) THEN CB_IS_LR_INT = 1 ELSE CB_IS_LR_INT = 0 ENDIF AVOID_TOO_SMALL_GRANULARITY = .TRUE. IF (KEEP(173).EQ.1) AVOID_TOO_SMALL_GRANULARITY = .FALSE. COMPUTE_MAX = (KEEP(219) .NE. 0) .AND. & (KEEP(50) .EQ. 2) .AND. & (PDEST.EQ.PDEST_MASTER) & .AND. (NBCOLS_ALREADY_SENT.EQ.0) & .AND. (NBROWS_ALREADY_SENT.EQ.0) IF (COMPUTE_MAX) THEN CALL DMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERR = -4 RETURN ENDIF ENDIF PDEST2(1) = PDEST IERR = 0 LROW = IW_CBSON( 1 + KEEP(IXSZ)) NELIM = IW_CBSON( 2 + KEEP(IXSZ)) NPIV = IW_CBSON( 4 + KEEP(IXSZ)) IF ( NPIV .LT. 0 ) THEN NPIV = 0 END IF NROW = IW_CBSON( 3 + KEEP(IXSZ)) NFRONT = LROW + NPIV HS = 6 + IW_CBSON( 6 + KEEP(IXSZ)) + KEEP(IXSZ) IF (CB_IS_LR.AND.NBROW.GT.0) THEN CALL DMUMPS_BLR_RETRIEVE_CB_LRB(IW_CBSON(1+XXF), CB_LRB) IF (SON_NIV.EQ.1) THEN CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW_CBSON(1+XXF), & BEGS_BLR_ROW) CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_DYN(IW_CBSON(1+XXF), & BEGS_BLR_COL) NB_BLR_ROWS = size(BEGS_BLR_ROW) - 1 CALL DMUMPS_BLR_RETRIEVE_NB_PANELS(IW_CBSON(1+XXF), & NB_COL_SHIFT) NB_ROW_SHIFT = NB_COL_SHIFT NASS_SHIFT = BEGS_BLR_ROW(NB_ROW_SHIFT+1)-1 NPIV_LR = BEGS_BLR_COL(NB_COL_SHIFT+1)-1 ELSE NPIV_LR=NPIV CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW_CBSON(1+XXF), & BEGS_BLR_STA) NB_BLR_ROWS = size(BEGS_BLR_STA) - 2 BEGS_BLR_ROW => BEGS_BLR_STA(2:NB_BLR_ROWS+2) CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_C(IW_CBSON(1+XXF), & BEGS_BLR_COL, NB_COL_SHIFT) NASS_SHIFT = 0 NB_ROW_SHIFT = 0 ENDIF PANEL2SEND = -1 DO I=NB_ROW_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR_ROW(I+1)-1-NASS_SHIFT & .GT.NBROWS_ALREADY_SENT+POS_FIRST_ROW_TO_PDEST-1) THEN PANEL2SEND = I EXIT ENDIF ENDDO IF (PANEL2SEND.EQ.-1) THEN write(*,*) 'Internal error: PANEL2SEND not found' CALL MUMPS_ABORT() ENDIF CURRENT_PANEL_SIZE = BEGS_BLR_ROW(PANEL2SEND+1) & - BEGS_BLR_ROW(PANEL2SEND) PANEL_BEG_OFFSET = POS_FIRST_ROW_TO_PDEST + & NBROWS_ALREADY_SENT - & BEGS_BLR_ROW(PANEL2SEND) + NASS_SHIFT IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR_COL) - 1 ELSEIF (SON_NIV.EQ.1) THEN NB_BLR_COLS = PANEL2SEND ELSE NB_BLR_COLS = -1 NCOL_SHIFT = NPIV_LR NROW_SHIFT = LROW - NROW DO I=NB_COL_SHIFT+1,size(BEGS_BLR_COL)-1 IF (BEGS_BLR_COL(I+1)-NCOL_SHIFT.GT. & ( min ( & BEGS_BLR_ROW(PANEL2SEND+1)-POS_FIRST_ROW_TO_PDEST, & NBROW & ) & + NROW_SHIFT + POS_FIRST_ROW_TO_PDEST-1 ) & ) THEN NB_BLR_COLS = I EXIT ENDIF ENDDO IF (NB_BLR_COLS.EQ.-1) THEN write(*,*) 'Internal error: NB_BLR_COLS not found' CALL MUMPS_ABORT() ENDIF MAX_ROW_LENGTH = BEGS_BLR_ROW(PANEL2SEND)-1+NROW_SHIFT & + min(NBROW-NBROWS_ALREADY_SENT + PANEL_BEG_OFFSET, & CURRENT_PANEL_SIZE) ENDIF NBLRB_TOTAL = NB_BLR_COLS - NB_COL_SHIFT ENDIF STATE_SON = IW_CBSON(1+XXS) IF (STATE_SON .EQ. S_NOLCBCONTIG) THEN LDA_SON8 = int(LROW,8) SHIFTCB_SON = int(NPIV,8)*int(NROW,8) ELSE IF (STATE_SON .EQ. S_NOLCLEANED) THEN LDA_SON8 = int(LROW,8) SHIFTCB_SON = 0_8 ELSE LDA_SON8 = int(NFRONT,8) SHIFTCB_SON = int(NPIV,8) ENDIF CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (PDEST .EQ. PDEST_MASTER) THEN SIZE_DESC_BANDE=0 ELSE SIZE_DESC_BANDE=(11+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, & 11+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(COMPUTE_MAX) THEN CALL MPI_PACK_SIZE(1, MPI_INTEGER, & COMM, SIZE0, IERR_MPI ) IF(NFS4FATHER .GT. 0) THEN CALL MPI_PACK_SIZE( NFS4FATHER, MPI_DOUBLE_PRECISION, & COMM, SIZE1, IERR_MPI ) ENDIF SIZE1 = SIZE1+SIZE0 ENDIF ONEorTWO = 1 IF (PDEST .EQ.PDEST_MASTER) THEN L = 0 ELSE IF (KEEP(50) .EQ. 0) THEN L = LROW ELSE L = LROW + POS_FIRST_ROW_TO_PDEST-LMAP+NBROWS_ALREADY_SENT-1 ONEorTWO=ONEorTWO+1 ENDIF NBINT = 6 + L + 1 IF (CB_IS_LR.AND.NBROW.GT.0) THEN NBINT = NBINT + 4*(NB_BLR_COLS-NB_COL_SHIFT) + 3 ENDIF CALL MPI_PACK_SIZE( NBINT, MPI_INTEGER, & COMM, TMPSIZE, IERR_MPI ) SIZE1 = SIZE1 + TMPSIZE SIZE_AV = SIZE_AV - SIZE1 NOT_ENOUGH_SPACE=.FALSE. IF (SIZE_AV .LT.0 ) THEN NBROWS_PACKET = 0 NOT_ENOUGH_SPACE=.TRUE. ELSE IF ( KEEP(50) .EQ. 0 ) THEN NBROWS_PACKET = & SIZE_AV / ( ONEorTWO*SIZEofINT+LROW*SIZEofREAL) ELSE B = 2 * ONEorTWO + & ( -1 + 2 * LROW + 2 * POS_FIRST_ROW_TO_PDEST -2*LMAP & + 2 * NBROWS_ALREADY_SENT ) & * SIZEofREAL / SIZEofINT NBROWS_PACKET=int((dble(-B)+sqrt((dble(B)*dble(B))+ & dble(4)*dble(2)*dble(SIZE_AV)/dble(SIZEofINT) * & dble(SIZEofREAL/SIZEofINT)))* & dble(SIZEofINT) / dble(2) / dble(SIZEofREAL)) ENDIF ENDIF 10 CONTINUE SIZE_NEXT_BLOCK = 0 IF (CB_IS_LR) THEN IF ( NBROW .GT. 0) THEN NBROWS_PACKET = CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET ELSE NBROWS_PACKET = 0 ENDIF ENDIF NBROWS_PACKET = max( 0, NBROWS_PACKET) NBROWS_PACKET = min(NBROW-NBROWS_ALREADY_SENT, NBROWS_PACKET) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE .OR. & (NBROWS_PACKET .EQ.0.AND. NBROW.NE.0) IF (CB_IS_LR.AND.NBROW.GT.0.AND..NOT.NOT_ENOUGH_SPACE) THEN CALL MPI_PACK_SIZE( ONEorTWO* NBROWS_PACKET, MPI_INTEGER, & COMM, TMPSIZE, IERR_MPI ) CALL DMUMPS_BLR_GET_SIZEREALS_CB_LRB( & SIZE_AV-TMPSIZE, CB_LRB, & NB_ROW_SHIFT, PANEL2SEND, & NBLRB_ALREADY_SENT, NBLRB_TOTAL, & NBLRB_PACKET, SIZE_REALS, SIZE_NEXT_BLOCK & , KEEP(173) & ) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE.OR.(NBLRB_PACKET.EQ.0) ENDIF IF ( (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NBROW) .AND. & .NOT.CB_IS_LR & ) THEN IF (KEEP(50).EQ.0) THEN LNEXT = LROW + 1 ELSE MAX_ROW_LENGTH = LROW + POS_FIRST_ROW_TO_PDEST - LMAP & + NBROWS_ALREADY_SENT & + NBROWS_PACKET-1 LNEXT = MAX_ROW_LENGTH + 1 ENDIF LNEXT = LNEXT + ONEorTWO CALL MPI_PACK_SIZE( LNEXT, & MPI_DOUBLE_PRECISION, & COMM, SIZE_NEXT_BLOCK, IERR_MPI ) ENDIF IF (SIZE_NEXT_BLOCK.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF IF (NOT_ENOUGH_SPACE) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (CB_IS_LR.AND.NBROW.GT.0) THEN IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 ELSEIF (SON_NIV.EQ.1) THEN MAX_ROW_LENGTH = LROW+POS_FIRST_ROW_TO_PDEST -LMAP & + NBROWS_ALREADY_SENT & + NBROWS_PACKET-1 ENDIF ELSE IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 SIZE_REALS = NBROWS_PACKET * LROW ELSE SIZE_REALS = ( LROW + POS_FIRST_ROW_TO_PDEST - LMAP & + NBROWS_ALREADY_SENT ) * & NBROWS_PACKET + ( NBROWS_PACKET * & ( NBROWS_PACKET - 1) ) / 2 MAX_ROW_LENGTH = LROW + POS_FIRST_ROW_TO_PDEST - LMAP & + NBROWS_ALREADY_SENT & + NBROWS_PACKET-1 ENDIF ENDIF SIZE_INTEGERS = ONEorTWO* NBROWS_PACKET CALL MPI_PACK_SIZE( SIZE_REALS, MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR_MPI ) CALL MPI_PACK_SIZE( SIZE_INTEGERS, MPI_INTEGER, & COMM, SIZE3, IERR_MPI ) IF (SIZE2 + SIZE3 .GT. SIZE_AV .AND. .NOT.CB_IS_LR) THEN NBROWS_PACKET = NBROWS_PACKET -1 IF (NBROWS_PACKET .GT. 0 .AND..NOT.CB_IS_LR) THEN GOTO 10 ENDIF IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF SIZE_PACK = SIZE1 + SIZE2 + SIZE3 K170PER1000 = dble(min(KEEP(170),500))/dble(1000) IF ( .NOT.CB_IS_LR & .AND. (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NBROW) & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND & .AND. ( SIZE_PACK .LT. & int(dble(SIZE_RBUF_BYTES)*K170PER1000) ) & .AND. & ( int(SIZE_PACK,8) + int(SIZE_NEXT_BLOCK,8) .LE. & int(SIZE_RBUF_BYTES,8) ) & ) THEN IERR = -1 GOTO 100 ENDIF IF ( CB_IS_LR.AND. & ( NBROWS_PACKET.NE.0 ).AND. & ( NBLRB_ALREADY_SENT+NBLRB_PACKET.NE. NBLRB_TOTAL ) & .AND. ( SIZE_PACK .LT. & int(dble(SIZE_RBUF_BYTES)*K170PER1000) ) & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND & .AND. AVOID_TOO_SMALL_GRANULARITY & .AND. ( & int(SIZE_PACK,8) + int(SIZE_NEXT_BLOCK,8) .LE. & int(SIZE_RBUF_BYTES,8) ) & ) THEN IERR = -1 GOTO 100 ENDIF IF (SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , PDEST2) IF (IERR .EQ. -1 .OR. IERR.EQ. -2) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF (NBROWS_PACKET > 0 ) GOTO 10 ENDIF IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (KEEP(50)==0) THEN CALL MPI_PACK( LROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE IF (CB_IS_LR.AND. & NBLRB_ALREADY_SENT+NBLRB_PACKET .EQ. NBLRB_TOTAL) THEN CALL MPI_PACK( -MAX_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE CALL MPI_PACK( MAX_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( CB_IS_LR_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF ( PDEST .NE. PDEST_MASTER ) THEN IF (KEEP(50)==0) THEN CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), LROW, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE IF (MAX_ROW_LENGTH > 0) THEN CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), & MAX_ROW_LENGTH, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF END IF DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = POS_FIRST_ROW_TO_PDEST + J -1 INDICE_PERE=MAPROW(I) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IPERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE CALL MPI_PACK( INDICE_PERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO IF (CB_IS_LR.AND.(NBROW.GT.0)) THEN CALL DMUMPS_BLR_PACK_CB_LRB( & CB_LRB, NB_ROW_SHIFT, & NBCOLS_ALREADY_SENT, & NBLRB_ALREADY_SENT, NBLRB_PACKET, & PANEL2SEND, & PANEL_BEG_OFFSET+1, PANEL_BEG_OFFSET+NBROWS_PACKET, & BUF_CB%CONTENT(IPOS:), & SIZE_PACK, POSITION, COMM, IERR & ) GOTO 200 ENDIF DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = POS_FIRST_ROW_TO_PDEST + J -1 IF (KEEP(50).ne.0) THEN THIS_ROW_LENGTH = LROW + I - LMAP ELSE THIS_ROW_LENGTH = LROW ENDIF IF (DESC_IN_LU) THEN IF ( PACKED_CB ) THEN IF (NELIM.EQ.0) THEN ITMP8 = int(I,8) ELSE ITMP8 = int(NELIM+I,8) ENDIF APOS = ITMP8 * (ITMP8-1_8) / 2_8 + 1_8 ELSE APOS = int(I+NELIM-1, 8) * int(LROW,8) + 1_8 ENDIF ELSE IF ( PACKED_CB ) THEN IF ( LROW .EQ. NROW ) THEN ITMP8 = int(I,8) APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 ELSE ITMP8 = int(I + LROW - NROW,8) APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 - & int(LROW - NROW, 8) * int(LROW-NROW+1,8) / 2_8 ENDIF ELSE APOS = int( I - 1, 8 ) * LDA_SON8 + SHIFTCB_SON + 1_8 ENDIF ENDIF CALL MPI_PACK( A_CBSON( APOS ), THIS_ROW_LENGTH, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO 200 CONTINUE IF (COMPUTE_MAX) THEN CALL MPI_PACK(NFS4FATHER,1, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NFS4FATHER .GT. 0) THEN IF (CB_IS_LR) THEN CALL DMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW_CBSON(1+XXF), M_ARRAY) CALL MPI_PACK(M_ARRAY(1), NFS4FATHER, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL DMUMPS_BLR_FREE_M_ARRAY ( IW_CBSON(1+XXF) ) ELSE BUF_MAX_ARRAY(1:NFS4FATHER) = ZERO IF(MAPROW(NROW) .GT. NASS_PERE) THEN DO PS1=1,NROW IF(MAPROW(PS1).GT.NASS_PERE) EXIT ENDDO IF (DESC_IN_LU) THEN IF (PACKED_CB) THEN APOS = int(NELIM+PS1,8) * int(NELIM+PS1-1,8) / & 2_8 + 1_8 NCA = -44444 ASIZE = int(NROW,8) * int(NROW+1,8)/2_8 - & int(NELIM+PS1,8) * int(NELIM+PS1-1,8)/2_8 LROW1 = PS1 + NELIM ELSE APOS = int(PS1+NELIM-1,8) * int(LROW,8) + 1_8 NCA = LROW ASIZE = int(NCA,8) * int(NROW-PS1+1,8) LROW1 = LROW ENDIF ELSE IF (PACKED_CB) THEN IF (NPIV.NE.0) THEN WRITE(*,*) "Error in PARPIV/DMUMPS_BUF_SEND_CONTRIB_TYPE2" CALL MUMPS_ABORT() ENDIF LROW1=LROW-NROW+PS1 ITMP8 = int(PS1 + LROW - NROW,8) APOS = ITMP8 * (ITMP8 - 1_8) / 2_8 + 1_8 - & int(LROW-NROW,8)*int(LROW-NROW+1,8)/2_8 ASIZE = int(LROW,8)*int(LROW+1,8)/2_8 - & ITMP8*(ITMP8-1_8)/2_8 NCA = -555555 ELSE APOS = int(PS1-1,8) * LDA_SON8 + 1_8 + SHIFTCB_SON NCA = int(LDA_SON8) ASIZE = LA_CBSON - APOS + 1_8 LROW1=-666666 ENDIF ENDIF IF ( NROW-PS1+1-KEEP253_LOC-NVSCHUR .GT. 0 ) THEN CALL DMUMPS_COMPUTE_MAXPERCOL( & A_CBSON(APOS),ASIZE,NCA, & NROW-PS1+1-KEEP253_LOC-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB,LROW1) ENDIF ENDIF CALL MPI_PACK(BUF_MAX_ARRAY, NFS4FATHER, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF ENDIF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & PDEST, CONTRIB_TYPE2, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE_PACK.LT. POSITION ) THEN WRITE(*,*) ' contniv2: SIZE, POSITION =',SIZE_PACK, POSITION WRITE(*,*) ' NBROW, LROW = ', NBROW, LROW CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) IF (CB_IS_LR) THEN IF (NBLRB_ALREADY_SENT+NBLRB_PACKET.EQ.NBLRB_TOTAL) THEN NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ELSE NBLRB_ALREADY_SENT = NBLRB_ALREADY_SENT + NBLRB_PACKET ENDIF ELSE NBROWS_ALREADY_SENT=NBROWS_ALREADY_SENT + NBROWS_PACKET ENDIF IF (NBROWS_ALREADY_SENT .NE. NBROW ) THEN IERR = -1 ENDIF 100 CONTINUE RETURN END SUBROUTINE DMUMPS_BUF_SEND_CONTRIB_TYPE2 SUBROUTINE DMUMPS_BUF_SEND_BLOCFACTO( INODE, NFRONT, & NCOL, NPIV, FPERE, LASTPANEL, IPIV, VAL, & PDEST, NDEST, KEEP, NB_BLOC_FAC, & NSLAVES_TOT, WIDTH, COMM, & NELIM, NPARTSASS, CURRENT_BLR_PANEL, & LR_ACTIVATED, BLR_LorU, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & IBEG_PANEL, COMPRESS_CB, & ICNTL, IERR ) USE DMUMPS_LR_TYPE IMPLICIT NONE INTEGER, intent(in) :: INODE, NCOL, NPIV, & FPERE, NFRONT, NDEST INTEGER, intent(in) :: IPIV( NPIV ) DOUBLE PRECISION, intent(in) :: VAL( NFRONT, * ) INTEGER, intent(in) :: PDEST( NDEST ) INTEGER, intent(inout) :: KEEP(500) INTEGER, intent(in) :: NB_BLOC_FAC, & NSLAVES_TOT, COMM, WIDTH LOGICAL, intent(in) :: LASTPANEL LOGICAL, intent(in) :: COMPRESS_CB LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(in) :: NELIM, NPARTSASS, CURRENT_BLR_PANEL, & IBEG_PANEL TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(inout) :: IERR INTEGER, INTENT(inout):: NBCOLS_ALREADY_SENT, & NBLRB_ALREADY_SENT INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE3, SIZET, & IDEST, IPOSMSG, I, SIZE_MSG_BYTES LOGICAL OVERFLOW INTEGER(8) :: SIZE2_8, SIZE3_8, SIZET_8, SIZE_OVERFLOW INTEGER NPIVSENT INTEGER :: LP LOGICAL :: LPOK LOGICAL :: RECV_BUF_SMALLER_THAN_SEND, NOT_ENOUGH_SPACE INTEGER :: DEST_BLOCFACTO, TAG_BLOCFACTO INTEGER :: LR_ACTIVATED_INT INTEGER :: NBINT, SIZE_AV, SIZE_AV_ADJUSTED INTEGER :: JBEG_BLOCK, NCOL_SEND, NCOL_MAX, & SIZE_BLR_LorU_SENT, NCOL_DIAG, NEWCOL_SENT INTEGER :: NBLRB_PACKET, SIZE_NEXT_BLOCK LOGICAL :: AVOID_TOO_SMALL_GRANULARITY INTEGER, PARAMETER :: kmaxcol=3 DOUBLE PRECISION :: K170PER1000 LP = ICNTL( 1 ) LPOK = ( LP.GT.0 .AND. ICNTL(4).GE.1 ) IERR = 0 OVERFLOW = .FALSE. NOT_ENOUGH_SPACE = .FALSE. NBLRB_PACKET = -9988 NCOL_DIAG = -9988 AVOID_TOO_SMALL_GRANULARITY = .TRUE. IF (KEEP(173).EQ.1) AVOID_TOO_SMALL_GRANULARITY = .FALSE. SIZE_OVERFLOW = 0_8 JBEG_BLOCK = NBCOLS_ALREADY_SENT + 1 NCOL_SEND = NCOL - JBEG_BLOCK + 1 NEWCOL_SENT = NCOL_SEND CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF IF ( & (KEEP(50).NE.0) .OR. & (KEEP(50).EQ.0.AND.JBEG_BLOCK.EQ.1) & ) THEN NBINT = NPIV ELSE NBINT = 0 ENDIF IF ( LASTPANEL ) THEN IF ( KEEP(50) .eq. 0 ) THEN NBINT = 9 + NBINT ELSE NBINT = 11 + NBINT END IF ELSE IF ( KEEP(50) .eq. 0 ) THEN NBINT = 8 + NBINT ELSE NBINT = 10 + NBINT END IF END IF IF (LR_ACTIVATED.AND.KEEP(50).EQ.0) THEN IF ( COMPRESS_CB .AND.(NPIV.GT.0) & .AND. IBEG_PANEL.EQ.1 .AND. (JBEG_BLOCK.EQ.1) & ) THEN NBINT = NBINT + size(BLR_LorU) + 1 ELSE NBINT = NBINT + 1 ENDIF ENDIF CALL MPI_PACK_SIZE( NBINT + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE2_8 = 0_8 SIZE_AV_ADJUSTED = SIZE_AV SIZE_NEXT_BLOCK = 0 IF ( (NPIV.GT.0) & ) THEN SIZE_AV_ADJUSTED = SIZE_AV_ADJUSTED - int(SIZE2_8) - SIZE1 NOT_ENOUGH_SPACE = (SIZE_AV_ADJUSTED.LE.0) IF (.NOT. LR_ACTIVATED) THEN NCOL_MAX = (SIZE_AV_ADJUSTED) / (NPIV*SIZEofREAL) NCOL_MAX = max(NCOL_MAX,0) NCOL_SEND = min( NCOL_SEND, NCOL_MAX) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE.OR. & (NCOL_SEND.EQ.0) .OR. & ((JBEG_BLOCK.EQ.1).AND.(NCOL_MAX.LT.NPIV)) IF (JBEG_BLOCK.EQ.1) NCOL_SEND = max(NCOL_SEND, NPIV) IF (KEEP(173).EQ.1) THEN IF (JBEG_BLOCK.EQ.1) THEN NCOL_SEND = min(NCOL_SEND, kmaxcol+NPIV) ELSE NCOL_SEND = min(NCOL_SEND, kmaxcol) ENDIF ENDIF NOT_ENOUGH_SPACE= NOT_ENOUGH_SPACE.OR. & (NCOL_SEND .GT. NCOL_MAX) SIZE3_8 = int(NPIV,8)*int(NCOL_SEND,8)*int(KEEP(35),8) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ELSE CALL MPI_PACK_SIZE( NPIV*NCOL_SEND, & MPI_DOUBLE_PRECISION, & COMM, SIZE3, IERR_MPI ) SIZE2_8 = SIZE2_8 + int(SIZE3,8) ENDIF NEWCOL_SENT = NCOL_SEND IF (NBCOLS_ALREADY_SENT+NEWCOL_SENT.LT.NCOL) THEN CALL MPI_PACK_SIZE( NPIV, & MPI_DOUBLE_PRECISION, & COMM, SIZE_NEXT_BLOCK, IERR_MPI ) ENDIF ELSE NCOL_DIAG = -9995 IF ((KEEP(50).NE.0).OR.(JBEG_BLOCK.EQ.1)) THEN SIZE3_8 = int(NPIV,8)*int(NPIV+NELIM,8)*int(KEEP(35),8) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ELSE CALL MPI_PACK_SIZE( NPIV*(NPIV+NELIM), & MPI_DOUBLE_PRECISION, & COMM, SIZE3, IERR_MPI ) SIZE2_8 = SIZE2_8+int(SIZE3,8) NCOL_SEND = NPIV+NELIM SIZE_AV_ADJUSTED = SIZE_AV_ADJUSTED - int(SIZE2_8) ENDIF ELSE NCOL_SEND = 0 ENDIF NCOL_DIAG = NCOL_SEND IF (JBEG_BLOCK.EQ.1) THEN NEWCOL_SENT = NCOL_DIAG ELSE NEWCOL_SENT = 0 ENDIF NOT_ENOUGH_SPACE = ( NOT_ENOUGH_SPACE.OR. & (SIZE_AV_ADJUSTED.LE.0) ) CALL DMUMPS_MPI_PACK_SIZE_LR_PARTIAL ( 0, & BLR_LorU, NBLRB_ALREADY_SENT, & SIZE_AV_ADJUSTED, KEEP(173), & NBLRB_PACKET, NCOL_SEND, SIZE3_8, & SIZE_NEXT_BLOCK, & COMM, IERR & ) NEWCOL_SENT = NEWCOL_SENT + (NCOL_SEND-NCOL_DIAG) NOT_ENOUGH_SPACE= ( NOT_ENOUGH_SPACE.OR. & (NEWCOL_SENT.EQ.0).OR. & (SIZE3_8.GT.int(SIZE_AV_ADJUSTED,8)) ) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ENDIF SIZE2_8 = SIZE2_8+SIZE3_8 ENDIF ENDIF IF (SIZE_NEXT_BLOCK.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF IF (NOT_ENOUGH_SPACE & ) THEN IF (RECV_BUF_SMALLER_THAN_SEND & ) THEN IERR = -3 RETURN ELSE IERR = -1 RETURN ENDIF ENDIF SIZET_8 = int(SIZE1,8) + SIZE2_8 IF (SIZET_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZET_8 ENDIF IF (OVERFLOW) THEN IERR=-3 IF (LPOK) WRITE(LP,*) & "Integer overflow message inDMUMPS_BUF_SEND_BLOCFACTO", & "SIZE_OVERFLOW,NPIV,NFRONT,NELIM=", & SIZE_OVERFLOW, NPIV, NFRONT, NELIM RETURN ENDIF SIZET = int(SIZET_8) IF (SIZET.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF K170PER1000 = dble(min(KEEP(170),500))/dble(1000) IF ( (NBCOLS_ALREADY_SENT+NEWCOL_SENT.LT.NCOL) & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND & .AND. ( SIZET .LT. & int(dble(SIZE_RBUF_BYTES)*K170PER1000) ) & .AND. ( & int(SIZET,8) + int(SIZE_NEXT_BLOCK,8) .LE. & int(SIZE_RBUF_BYTES,8) ) & .AND. AVOID_TOO_SMALL_GRANULARITY & ) THEN IERR = -1 RETURN ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NDEST , PDEST) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_CB%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST SIZE_MSG_BYTES = SIZET - OVHSIZE * (NDEST-1) * KEEP(34) POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) NPIVSENT = NPIV IF (LASTPANEL) NPIVSENT = -NPIV CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF ( LASTPANEL .OR. KEEP(50).ne.0 ) THEN CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) END IF IF ( LASTPANEL .AND. KEEP(50) .NE. 0 ) THEN CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) END IF CALL MPI_PACK( NEWCOL_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBEG_BLOCK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NELIM, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPARTSASS, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( CURRENT_BLR_PANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN LR_ACTIVATED_INT = 1 ELSE LR_ACTIVATED_INT = 0 ENDIF CALL MPI_PACK( LR_ACTIVATED_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF ( KEEP(50) .ne. 0 ) THEN CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDIF IF (LR_ACTIVATED.AND.KEEP(50).EQ.0) THEN SIZE_BLR_LorU_SENT = 0 IF ( COMPRESS_CB .AND.(NPIV.GT.0) & .AND. IBEG_PANEL.EQ.1 .AND. (JBEG_BLOCK.EQ.1) & ) THEN SIZE_BLR_LorU_SENT = size(BLR_LorU) ENDIF CALL MPI_PACK( SIZE_BLR_LorU_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), & SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF (SIZE_BLR_LorU_SENT.GT.0) THEN DO I=1, size(BLR_LorU) CALL MPI_PACK( BLR_LorU(I)%M, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), & SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDDO ENDIF ENDIF IF ( (NPIV.GT.0) & ) THEN IF ( & (KEEP(50).NE.0) .OR. & (KEEP(50).EQ.0.AND.JBEG_BLOCK.EQ.1) & ) THEN CALL MPI_PACK( IPIV, NPIV, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(50).NE.0.OR.JBEG_BLOCK.EQ.1) THEN DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NPIV+NELIM, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) END DO ENDIF CALL DMUMPS_MPI_PACK_LR_PARTIAL( & BLR_LorU, NBLRB_ALREADY_SENT, NBLRB_PACKET, & BUF_CB%CONTENT(IPOSMSG: & IPOSMSG+(SIZE_MSG_BYTES+KEEP(34)-1)/KEEP(34)-1), & SIZE_MSG_BYTES, POSITION, COMM, IERR,KEEP(34) ) ELSE DO I = 1, NPIV CALL MPI_PACK( VAL(JBEG_BLOCK,I), NCOL_SEND, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) END DO ENDIF ENDIF DO IDEST = NDEST, 1, -1 DEST_BLOCFACTO = PDEST(IDEST) IF ( KEEP(50) .EQ. 0) THEN TAG_BLOCFACTO = BLOC_FACTO KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, & MPI_PACKED, & DEST_BLOCFACTO, TAG_BLOCFACTO, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) ELSE KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, & MPI_PACKED, & DEST_BLOCFACTO, BLOC_FACTO_SYM, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) END IF END DO IF (NBCOLS_ALREADY_SENT+NEWCOL_SENT.EQ.NCOL & ) THEN NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ELSE NBCOLS_ALREADY_SENT = NBCOLS_ALREADY_SENT + NEWCOL_SENT IF (LR_ACTIVATED) THEN NBLRB_ALREADY_SENT = NBLRB_ALREADY_SENT + NBLRB_PACKET ENDIF IERR = -1 ENDIF IF ( SIZE_MSG_BYTES .LT. POSITION ) THEN WRITE(*,*) ' Error sending blocfacto : size < position' WRITE(*,*) ' INODE= ', INODE, & ' Size,position= ',SIZE_MSG_BYTES,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_MSG_BYTES .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE DMUMPS_BUF_SEND_BLOCFACTO SUBROUTINE DMUMPS_BUF_SEND_BLFAC_SLAVE( INODE, & NPIV, FPERE, IPOSK, JPOSK, UIP21K, LUIP21K, NCOLU, & NDEST, PDEST, COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & NOTHING_WAS_SENT, & A , LA, POSBLOCFACTO, LD_BLOCFACTO, & IPIV, MAXI_CLUSTER, IERR, IERROR ) USE DMUMPS_LR_TYPE IMPLICIT NONE INTEGER INODE, NCOLU, IPOSK, JPOSK, NPIV, NDEST, FPERE INTEGER(8) :: LUIP21K DOUBLE PRECISION UIP21K( : ) INTEGER PDEST( NDEST ) INTEGER COMM, IERR, IERROR INTEGER, INTENT(INOUT) :: KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: NBCOLS_ALREADY_SENT, & NBLRB_ALREADY_SENT LOGICAL, intent(out) :: NOTHING_WAS_SENT TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS INTEGER(8), intent(in) :: LA, POSBLOCFACTO INTEGER, intent(in) :: LD_BLOCFACTO, IPIV(NPIV), & MAXI_CLUSTER, IPANEL DOUBLE PRECISION, intent(inout) :: A(LA) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER LR_ACTIVATED_INT INTEGER POSITION, IREQ, IPOS, SIZE1, SIZET, & IDEST, IPOSMSG, SSS, SIZE3, SIZE_MSG_BYTES INTEGER(8) :: SIZE2_8, SIZE3_8, SIZET_8, SIZE_OVERFLOW LOGICAL :: OVERFLOW, LASTBL_INPANEL INTEGER :: JBEG_BLOCK, NCOL_SEND, NCOL_MAX INTEGER :: SIZE_AV, SIZE_AV_ADJUSTED LOGICAL :: RECV_BUF_SMALLER_THAN_SEND, NOT_ENOUGH_SPACE INTEGER :: NBLRB_PACKET, SIZE_NEXT_BLOCK LOGICAL :: AVOID_TOO_SMALL_GRANULARITY INTEGER, PARAMETER :: kmaxcol=3 DOUBLE PRECISION :: K170PER1000 IERR = 0 OVERFLOW = .FALSE. SIZE_OVERFLOW = 0_8 JBEG_BLOCK = NBCOLS_ALREADY_SENT + 1 NCOL_SEND = NCOLU - JBEG_BLOCK + 1 NBLRB_PACKET = -9977 NOTHING_WAS_SENT = .TRUE. AVOID_TOO_SMALL_GRANULARITY = .TRUE. IF (KEEP(173).EQ.1) AVOID_TOO_SMALL_GRANULARITY = .FALSE. CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF CALL MPI_PACK_SIZE( 8 + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE2_8 = 0_8 SIZE_AV_ADJUSTED = SIZE_AV - SIZE1 SIZE_NEXT_BLOCK = 0 NOT_ENOUGH_SPACE = (SIZE_AV_ADJUSTED.LE.0) IF (.NOT. LR_ACTIVATED) THEN NCOL_MAX = (SIZE_AV_ADJUSTED) / (NPIV*SIZEofREAL) NCOL_MAX = max(NCOL_MAX,0) NCOL_SEND = min( NCOL_SEND, NCOL_MAX) IF (KEEP(173).EQ.1) THEN NCOL_SEND = min(NCOL_SEND, kmaxcol) ENDIF NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE.OR.(NCOL_SEND.EQ.0) SIZE3_8 = int(NPIV,8)*int(NCOL_SEND,8) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ELSE CALL MPI_PACK_SIZE( abs(NPIV)*NCOL_SEND, & MPI_DOUBLE_PRECISION, & COMM, SIZE3, IERR_MPI ) SIZE2_8=SIZE2_8 + int(SIZE3,8) ENDIF IF (NBCOLS_ALREADY_SENT+NCOL_SEND.LT.NCOLU) THEN CALL MPI_PACK_SIZE( NPIV, & MPI_DOUBLE_PRECISION, & COMM, SIZE_NEXT_BLOCK, IERR_MPI ) ENDIF ELSE NCOL_SEND = 0 NOT_ENOUGH_SPACE = ( NOT_ENOUGH_SPACE.OR. & (SIZE_AV_ADJUSTED.LE.0) ) CALL DMUMPS_MPI_PACK_SIZE_LR_PARTIAL ( 1, & BLR_LS, NBLRB_ALREADY_SENT, & SIZE_AV_ADJUSTED, KEEP(173), & NBLRB_PACKET, NCOL_SEND, SIZE3_8, & SIZE_NEXT_BLOCK, & COMM, IERR & ) NOT_ENOUGH_SPACE= ( NOT_ENOUGH_SPACE.OR. & (NCOL_SEND.EQ.0).OR. & (SIZE3_8.GT.int(SIZE_AV_ADJUSTED,8)) ) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ENDIF SIZE2_8 = SIZE2_8+SIZE3_8 ENDIF IF (SIZE_NEXT_BLOCK.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF IF (NOT_ENOUGH_SPACE) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 RETURN ELSE IERR = -1 RETURN ENDIF ENDIF SIZET_8 = int(SIZE1,8) + SIZE2_8 IF (SIZET_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZET_8 ENDIF IF (OVERFLOW) THEN IERR=-3 RETURN ENDIF SIZET = int(SIZET_8) IF (SIZET.GT.SIZE_RBUF_BYTES) THEN CALL MPI_PACK_SIZE( 6 , & MPI_INTEGER, COMM, SSS, IERR_MPI ) SIZE2_8 = int(SSS,8)+SIZE2_8 IF (int(SIZE2_8).GT.SIZE_RBUF_BYTES) THEN IERR = -2 RETURN ENDIF END IF K170PER1000 = dble(min(KEEP(170),500))/dble(1000) IF ((NBCOLS_ALREADY_SENT+NCOL_SEND.LT.NCOLU) & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND & .AND. ( SIZET .LT. & int(dble(SIZE_RBUF_BYTES)*K170PER1000) ) & .AND. ( & int(SIZET,8) + int(SIZE_NEXT_BLOCK,8) .LE. & int(SIZE_RBUF_BYTES,8) ) & .AND. AVOID_TOO_SMALL_GRANULARITY & ) THEN IERR = -1 RETURN ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NDEST, PDEST) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_CB%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST SIZE_MSG_BYTES = SIZET - OVHSIZE * (NDEST-1) * KEEP(34) POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JPOSK+JBEG_BLOCK-1, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) LASTBL_INPANEL = (NBCOLS_ALREADY_SENT+NCOL_SEND.EQ.NCOLU) IF (LASTBL_INPANEL) THEN CALL MPI_PACK( -NCOL_SEND, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ELSE CALL MPI_PACK( NCOL_SEND, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDIF IF (LR_ACTIVATED) THEN LR_ACTIVATED_INT = 1 ELSE LR_ACTIVATED_INT = 0 ENDIF CALL MPI_PACK( LR_ACTIVATED_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IPANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN CALL DMUMPS_MPI_PACKSCALE_LR_PARTIAL( BLR_LS, & NBLRB_ALREADY_SENT, NBLRB_PACKET, & BUF_CB%CONTENT( IPOSMSG: & IPOSMSG+(SIZE_MSG_BYTES+KEEP(34)-1)/KEEP(34)-1 ), & SIZE_MSG_BYTES, POSITION, COMM, & A, LA, POSBLOCFACTO, LD_BLOCFACTO, & IPIV, NPIV, MAXI_CLUSTER, IERR, IERROR ) IF (IERR.LT.0) RETURN ELSE CALL MPI_PACK( UIP21K(1_8+int(JBEG_BLOCK-1,8)*int(NPIV,8)), & NPIV * NCOL_SEND, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDIF NOTHING_WAS_SENT = .FALSE. DO IDEST = 1, NDEST KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, & PDEST(IDEST), BLOC_FACTO_SYM_SLAVE, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) END DO IF ( LASTBL_INPANEL ) THEN NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ELSE NBCOLS_ALREADY_SENT = NBCOLS_ALREADY_SENT + NCOL_SEND IF (LR_ACTIVATED) THEN NBLRB_ALREADY_SENT = NBLRB_ALREADY_SENT + NBLRB_PACKET ENDIF IERR = -1 ENDIF IF ( SIZE_MSG_BYTES .LT. POSITION ) THEN WRITE(*,*) ' Error sending blfac slave : size < position' WRITE(*,*) ' Size,position=',SIZE_MSG_BYTES,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_MSG_BYTES .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE DMUMPS_BUF_SEND_BLFAC_SLAVE SUBROUTINE DMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) 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, INTENT(IN) :: RG2L(N) INTEGER NSUPROW, NSUPCOL INTEGER(8), INTENT(IN) :: TABSIZE INTEGER SIZE_PACK INTEGER KEEP(500) DOUBLE PRECISION VAL_SON( LD_SON, * ), TAB(*) LOGICAL TRANSP INTEGER N_ALREADY_SENT INTEGER :: NELIM_ROOT, NELIM_ROW, NELIM_COL INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER SIZE1, SIZE2, SIZE_AV, POSITION INTEGER SIZE_CBP, SIZE_TMP INTEGER IREQ, IPOS, ITAB INTEGER ISUB, JSUB, I, J INTEGER ILOC_ROOT, JLOC_ROOT INTEGER IPOS_ROOT, JPOS_ROOT INTEGER IONE LOGICAL RECV_BUF_SMALLER_THAN_SEND INTEGER PDEST2(1) PARAMETER ( IONE=1 ) INTEGER N_PACKET INTEGER NSUBSET_ROW_EFF, NSUBSET_COL_EFF, NSUPCOL_EFF PDEST2(1) = PDEST IERR = 0 IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF SIZE_AV = min(SIZE_AV, SIZE_RBUF_BYTES) CALL MPI_PACK_SIZE(8 + NSUBSET_COL, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE_CBP = 0 IF (N_ALREADY_SENT .EQ. 0 .AND. & min(NSUPROW,NSUPCOL) .GT.0) THEN CALL MPI_PACK_SIZE(NSUPROW, MPI_INTEGER, COMM, & SIZE_CBP, IERR_MPI ) CALL MPI_PACK_SIZE(NSUPCOL, MPI_INTEGER, COMM, & SIZE_TMP, IERR_MPI ) SIZE_CBP = SIZE_CBP + SIZE_TMP CALL MPI_PACK_SIZE(NSUPROW*NSUPCOL, & MPI_DOUBLE_PRECISION, COMM, & SIZE_TMP, IERR_MPI ) SIZE_CBP = SIZE_CBP + SIZE_TMP SIZE1 = SIZE1 + SIZE_CBP ENDIF IF (BBPCBP.EQ.1) THEN NSUBSET_COL_EFF = NSUBSET_COL - NSUPCOL NSUPCOL_EFF = 0 ELSE NSUBSET_COL_EFF = NSUBSET_COL NSUPCOL_EFF = NSUPCOL ENDIF NSUBSET_ROW_EFF = NSUBSET_ROW - NSUPROW N_PACKET = & (SIZE_AV - SIZE1) / (SIZEofINT + NSUBSET_COL_EFF * SIZEofREAL) 10 CONTINUE N_PACKET = min( N_PACKET, & NSUBSET_ROW_EFF-N_ALREADY_SENT ) IF (N_PACKET .LE. 0 .AND. & NSUBSET_ROW_EFF-N_ALREADY_SENT.GT.0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF CALL MPI_PACK_SIZE( 8 + NSUBSET_COL_EFF + N_PACKET, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE1 = SIZE1 + SIZE_CBP CALL MPI_PACK_SIZE( N_PACKET * NSUBSET_COL_EFF, & MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV) THEN N_PACKET = N_PACKET - 1 IF ( N_PACKET > 0 ) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (N_PACKET + N_ALREADY_SENT .NE. NSUBSET_ROW - NSUPROW & .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 10 & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF ELSE N_PACKET = 0 CALL MPI_PACK_SIZE(8,MPI_INTEGER, COMM, SIZE_PACK, IERR_MPI ) END IF IF ( SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE, PDEST2 & ) IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUBSET_ROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUPROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUBSET_COL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUPCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( N_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( N_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( BBPCBP, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN IF (N_ALREADY_SENT .EQ. 0 .AND. & min(NSUPROW, NSUPCOL) .GT. 0) THEN DO ISUB = NSUBSET_ROW-NSUPROW+1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IF ( I .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L(INDCOL_SON( I )) ENDIF ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO DO ISUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( ISUB ) JPOS_ROOT = INDROW_SON( J ) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO IF ( TABSIZE.GE.int(NSUPROW,8)*int(NSUPCOL,8) ) THEN ITAB = 1 DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW J = SUBSET_ROW(JSUB) DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL I = SUBSET_COL(ISUB) TAB(ITAB) = VAL_SON(J, I) ITAB = ITAB + 1 ENDDO ENDDO CALL MPI_PACK(TAB(1), NSUPROW*NSUPCOL, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ELSE DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW J = SUBSET_ROW(JSUB) DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL I = SUBSET_COL(ISUB) CALL MPI_PACK(VAL_SON(J,I), 1, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO ENDDO ENDIF ENDIF IF ( .NOT. TRANSP ) THEN DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) IF ( I .LE. NELIM_ROW ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L( INDROW_SON( I ) ) ENDIF ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO JSUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF J = SUBSET_COL( JSUB ) IF ( J .LE. NELIM_COL ) THEN JPOS_ROOT = NELIM_ROOT + J - 1 ELSE JPOS_ROOT = RG2L( INDCOL_SON( J ) ) ENDIF JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO JSUB = NSUBSET_COL_EFF-NSUPCOL_EFF+1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) JPOS_ROOT = INDCOL_SON( J ) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO ELSE DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) IF ( J .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + J - 1 ELSE IPOS_ROOT = RG2L( INDCOL_SON( J ) ) ENDIF ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO ISUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF I = SUBSET_COL( ISUB ) IF ( I .LE. NELIM_ROW ) THEN JPOS_ROOT = NELIM_ROOT + I - 1 ELSE JPOS_ROOT = RG2L( INDROW_SON( I ) ) ENDIF JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO ISUB = NSUBSET_COL_EFF - NSUPCOL_EFF + 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) JPOS_ROOT = INDROW_SON(I) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO END IF IF ( TABSIZE.GE.int(N_PACKET,8)*int(NSUBSET_COL_EFF,8) ) THEN IF ( .NOT. TRANSP ) THEN ITAB = 1 DO ISUB = N_ALREADY_SENT+1, & N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) DO JSUB = 1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) TAB( ITAB ) = VAL_SON(J,I) ITAB = ITAB + 1 END DO END DO CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ELSE ITAB = 1 DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) DO ISUB = 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) TAB( ITAB ) = VAL_SON( J, I ) ITAB = ITAB + 1 END DO END DO CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END IF ELSE IF ( .NOT. TRANSP ) THEN DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) DO JSUB = 1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) CALL MPI_PACK( VAL_SON( J, I ), 1, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO END DO ELSE DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) DO ISUB = 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) CALL MPI_PACK( VAL_SON( J, I ), 1, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO END DO END IF ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & PDEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN WRITE(*,*) ' Error sending contribution to root:Size 0) THEN SCALED(1:BLR(I)%K,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * BLR(I)%R(1:BLR(I)%K,J) J = J+1 CALL MPI_PACK( SCALED(1,1), BLR(I)%K, & MPI_DOUBLE_PRECISION, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) ELSE PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) PIV2 = A(POSELTD+LD_DIAG*J+J) OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) BLOCK(1:BLR(I)%K) = BLR(I)%R(1:BLR(I)%K,J) SCALED(1:BLR(I)%K,1) = PIV1 * BLR(I)%R(1:BLR(I)%K,J) & + OFFDIAG * BLR(I)%R(1:BLR(I)%K,J+1) CALL MPI_PACK( SCALED(1,1), BLR(I)%K, & MPI_DOUBLE_PRECISION, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) SCALED(1:BLR(I)%K,2) = OFFDIAG * BLOCK(1:BLR(I)%K) & + PIV2 * BLR(I)%R(1:BLR(I)%K,J+1) J =J+2 CALL MPI_PACK( SCALED(1,2), BLR(I)%K, & MPI_DOUBLE_PRECISION, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) ENDIF END DO ENDIF ELSE J = 1 DO WHILE (J <= BLR(I)%N) IF (IPIV(J) > 0) THEN SCALED(1:BLR(I)%M,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * BLR(I)%Q(1:BLR(I)%M,J) CALL MPI_PACK( SCALED(1,1), BLR(I)%M, & MPI_DOUBLE_PRECISION, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) J = J+1 ELSE PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) PIV2 = A(POSELTD+LD_DIAG*J+J) OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) BLOCK(1:BLR(I)%M) = BLR(I)%Q(1:BLR(I)%M,J) SCALED(1:BLR(I)%M,1) = PIV1 * BLR(I)%Q(1:BLR(I)%M,J) & + OFFDIAG * BLR(I)%Q(1:BLR(I)%M,J+1) CALL MPI_PACK( SCALED(1,1), BLR(I)%M, & MPI_DOUBLE_PRECISION, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) SCALED(1:BLR(I)%M,2) = OFFDIAG * BLOCK(1:BLR(I)%M) & + PIV2 * BLR(I)%Q(1:BLR(I)%M,J+1) CALL MPI_PACK( SCALED(1,2), BLR(I)%M, & MPI_DOUBLE_PRECISION, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) J=J+2 ENDIF END DO ENDIF ENDDO 500 CONTINUE IF (allocated(BLOCK)) deallocate(BLOCK) IF (allocated(SCALED)) deallocate(SCALED) 600 CONTINUE RETURN END SUBROUTINE DMUMPS_MPI_PACKSCALE_LR_PARTIAL END MODULE DMUMPS_BUF MUMPS_5.8.1/src/zlr_type.F0000664000175000017500000000467215042446441015221 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_LR_TYPE IMPLICIT NONE TYPE LRB_TYPE COMPLEX(kind=8),POINTER,DIMENSION(:,:) :: Q => null() COMPLEX(kind=8),POINTER,DIMENSION(:,:) :: R => null() INTEGER :: K,M,N LOGICAL :: ISLR END TYPE LRB_TYPE CONTAINS SUBROUTINE DEALLOC_LRB(LRB_OUT, KEEP8, K34 & ) TYPE(LRB_TYPE), INTENT(INOUT) :: LRB_OUT INTEGER(8) :: KEEP8(150) INTEGER :: K34 INTEGER :: MEM, IDUMMY, JDUMMY IF (LRB_OUT%M.EQ.0) RETURN IF (LRB_OUT%N.EQ.0) RETURN MEM = 0 IF (LRB_OUT%ISLR) THEN IF (associated(LRB_OUT%Q)) THEN MEM = MEM + size(LRB_OUT%Q) DEALLOCATE (LRB_OUT%Q) NULLIFY(LRB_OUT%Q) ENDIF IF (associated(LRB_OUT%R)) THEN MEM = MEM + size(LRB_OUT%R) DEALLOCATE (LRB_OUT%R) NULLIFY(LRB_OUT%R) ENDIF ELSE IF (associated(LRB_OUT%Q)) THEN MEM = MEM + size(LRB_OUT%Q) DEALLOCATE (LRB_OUT%Q) NULLIFY(LRB_OUT%Q) ENDIF ENDIF CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-int(MEM,8), & .TRUE., KEEP8, & IDUMMY, JDUMMY, & .TRUE., .TRUE.) END SUBROUTINE DEALLOC_LRB SUBROUTINE DEALLOC_BLR_PANEL(BLR_PANEL, IEND, KEEP8, K34, IBEG_IN) INTEGER, INTENT(IN) :: IEND TYPE(LRB_TYPE), INTENT(INOUT) :: BLR_PANEL(:) INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: K34 INTEGER, INTENT(IN), OPTIONAL :: IBEG_IN INTEGER :: I, IBEG IF (present(IBEG_IN)) THEN IBEG = IBEG_IN ELSE IBEG = 1 ENDIF IF (IEND.GE.IBEG) THEN IF (BLR_PANEL(1)%M.NE.0) THEN DO I=IBEG, IEND CALL DEALLOC_LRB(BLR_PANEL(I), KEEP8, K34) ENDDO ENDIF ENDIF END SUBROUTINE DEALLOC_BLR_PANEL END MODULE ZMUMPS_LR_TYPE MUMPS_5.8.1/src/dsol_bwd.F0000664000175000017500000001662115042446437015150 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SOL_S(N, A, LA, IW, LIW, W, LWC, & NRHS, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, & MYLEAF, MYROOT, ICNTL, INFO, & PROCNODE_STEPS, & SLAVEF, COMM,MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS & , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) USE DMUMPS_STATIC_PTR_M, ONLY : DMUMPS_SET_STATIC_PTR, & DMUMPS_GET_TMP_PTR USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_L0OMPFAC_T IMPLICIT NONE INTEGER MTYPE INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: LWC INTEGER, intent(in) :: N,LIW,LIWW,LPOOL INTEGER, intent(in) :: SLAVEF,MYLEAF,MYROOT,COMM,MYID INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER NE_STEPS(KEEP(28)) INTEGER IPOOL(LPOOL) INTEGER LPANEL_POS INTEGER PANEL_POS(LPANEL_POS) INTEGER ICNTL(60), INFO(80) INTEGER PTRIST(KEEP(28)), & PTRICB(KEEP(28)) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER NRHS DOUBLE PRECISION A(LA), W(LWC) DOUBLE PRECISION W2(KEEP(133)) INTEGER IW(LIW),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)),DAD(KEEP(28)),FILS(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LRHSINTR, POSINRHSINTR_BWD(N) DOUBLE PRECISION RHSINTR(LRHSINTR,NRHS) INTEGER(8), intent(in) :: LRHS_ROOT DOUBLE PRECISION RHS_ROOT( LRHS_ROOT ) LOGICAL, INTENT(in) :: PRUN_BELOW INTEGER, intent(in) :: SIZE_TO_PROCESS LOGICAL, intent(in) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP INTEGER, INTENT( in ) :: LL0_OMP_MAPPING, LL0_OMP_FACTORS INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) TYPE (DMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' LOGICAL FLAG DOUBLE PRECISION, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER :: UNDERL0MAP INTEGER(8) :: POSWCB, PLEFTW INTEGER POSIWCB INTEGER NBFINF INTEGER INODE INTEGER III,IIPOOL,MYLEAF_LEFT LOGICAL BLOQ INTEGER DUMMY(1) LOGICAL :: ERROR_WAS_BROADCASTED, DO_MCAST2_TERMBWD LOGICAL :: ALLOW_OTHERS_TO_LEAVE LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: allocok DUMMY(1)=0 KEEP(266)=0 ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of DEJA_SEND in ' & //'routine DMUMPS_SOL_S ' INFO(1)=-13 INFO(2)=SLAVEF endif CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT.0 ) GOTO 340 PLEFTW = 1_8 POSIWCB = LIWW POSWCB = LWC III = 1 IIPOOL = MYROOT + 1 MYLEAF_LEFT = MYLEAF NBFINF = SLAVEF ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) ALLOW_OTHERS_TO_LEAVE = ALLOW_OTHERS_TO_LEAVE .OR. & KEEP(31) .EQ. 1 IF (ALLOW_OTHERS_TO_LEAVE) THEN CALL DMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERMBWD, & SLAVEF, KEEP) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0 .AND. MYLEAF_LEFT .EQ. 0) THEN GOTO 340 ENDIF ENDIF ERROR_WAS_BROADCASTED = .FALSE. DO_MCAST2_TERMBWD = .FALSE. DO WHILE ( NBFINF .NE. 0 .OR. MYLEAF_LEFT .NE. 0 ) IF ( SLAVEF.EQ.1 ) THEN FLAG = .FALSE. ELSE BLOQ = ( III .EQ. IIPOOL ) CALL DMUMPS_BACKSLV_RECV_AND_TREAT( BLOQ, FLAG, BUFR, LBUFR, & LBUFR_BYTES, MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD & , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO(1) .LT. 0 ) GOTO 340 ENDIF IF ( .NOT. FLAG ) THEN IF (III .NE. IIPOOL) THEN INODE = IPOOL(IIPOOL-1) IIPOOL = IIPOOL - 1 IF (KEEP(400) .GT. 0 ) THEN UNDERL0MAP = L0_OMP_MAPPING(STEP(INODE)) ELSE UNDERL0MAP = 0 ENDIF IF (UNDERL0MAP .EQ. 0 .OR. KEEP(201).GT.0) THEN CALL DMUMPS_SET_STATIC_PTR(A) CALL DMUMPS_GET_TMP_PTR(A_PTR) LA_PTR = LA ELSE A_PTR => L0_OMP_FACTORS(UNDERL0MAP)%A LA_PTR = L0_OMP_FACTORS(UNDERL0MAP)%LA ENDIF CALL DMUMPS_SOLVE_NODE_BWD( INODE, & N, IPOOL, LPOOL, IIPOOL, NBFINF, & A_PTR(1), LA_PTR, IW, LIW, W, LWC, NRHS, & POSWCB, PLEFTW, POSIWCB, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, & MYLEAF_LEFT, INFO, & PROCNODE_STEPS, DEJA_SEND, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & , DO_MCAST2_TERMBWD & ) IF ( INFO(1) .LT. 0 ) THEN IF (.NOT. ERROR_WAS_BROADCASTED) THEN IF (NBFINF .NE. 0 ) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ENDIF ENDIF IF (DO_MCAST2_TERMBWD) THEN CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & TERMBWD, SLAVEF, KEEP ) ENDIF ENDIF END IF ENDDO 340 CONTINUE IF (ALLOCATED(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE DMUMPS_SOL_S MUMPS_5.8.1/src/mumps_tags.h0000664000175000017500000001307115042446423015563 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C ----------------------------------------- C This file contains the definition C of all tags. C ----------------------------------------- C C --------------- C Tags for L0OMP C --------------- INTEGER F_IPOOLAFTER, F_PHYS_L0 PARAMETER ( F_IPOOLAFTER = 60, F_PHYS_L0 = 61 ) C ----------------- C Tag for grouping C ----------------- INTEGER GROUPING PARAMETER ( GROUPING = 50 ) C ---------------------------------------------- C Tag for LMAT distribution (analysis by block) C and for gathering graph C ---------------------------------------------- INTEGER LMATDIST, GATHERG_NZG, GATHERG_NB, & GATHERG_FIRST, GATHERG_IPE, GATHERG_ADJ, & CENT_AFTER_PARAORD PARAMETER ( LMATDIST = 43, GATHERG_NZG=44, GATHERG_NB=45, & GATHERG_FIRST=46, GATHERG_IPE=47, GATHERG_ADJ= 48, & CENT_AFTER_PARAORD=49) C ----------------------------------------- C Tag for arrowheads distribution C ----------------------------------------- INTEGER ARROWHEAD, ARR_INT, ARR_REAL, ELT_INT, ELT_REAL PARAMETER ( ARROWHEAD = 20, & ARR_INT = 29, & ARR_REAL = 30, & ELT_INT = 31, & ELT_REAL = 32 ) C ---------------------------------------------------- C Tags for collecting distributed integer info C for analysis in case of initial distributed matrix C ---------------------------------------------------- INTEGER COLLECT_NZ, COLLECT_IRN, COLLECT_JCN PARAMETER( COLLECT_NZ = 35, & COLLECT_IRN = 36, & COLLECT_JCN = 37 ) C ----------------------------------------- C Tags for factorization C ----------------------------------------- INTEGER RACINE, & NOEUD, & TERREUR, & MAITRE_DESC_BANDE, & MAITRE2, & BLOC_FACTO_RELAY, & CONTRIB_TYPE2, & MAPLIG, & FACTOR, & BLOC_FACTO PARAMETER ( RACINE = 2, & NOEUD = 3, & MAITRE_DESC_BANDE = 4, & MAITRE2 = 5, & BLOC_FACTO_RELAY = 6, & CONTRIB_TYPE2 = 7, & MAPLIG = 8, & FACTOR = 9, & BLOC_FACTO = 10, & TERREUR = 99 ) C ----------------------------------------- C Tags for assembly of root (in facto) C ----------------------------------------- INTEGER ROOT_NELIM_INDICES, & ROOT_CONT_STATIC, & ROOT_NON_ELIM_CB, & ROOT_2SLAVE, & ROOT_2SON PARAMETER( ROOT_NELIM_INDICES = 15, & ROOT_CONT_STATIC = 16, & ROOT_NON_ELIM_CB = 17, & ROOT_2SLAVE = 18, & ROOT_2SON = 19 ) C ----------------------------------------- C Tags for solve C ----------------------------------------- INTEGER RACINE_SOLVE, & ContVec, & Master2Slave, & GatherSol, & ScatterRhsI, & ScatterRhsR, & DistRhsI, & DistRhsR, & DistSolR PARAMETER( RACINE_SOLVE = 14, & ContVec = 11, & Master2Slave = 12, & GatherSol = 13, & ScatterRhsI = 54, & ScatterRhsR = 55, & DistRhsI = 51, & DistRhsR = 52, & DistSolR = 58) INTEGER, PARAMETER :: TAG_WAKEUP = 53 INTEGER, PARAMETER :: DIST_RHS_INT = 56 INTEGER, PARAMETER :: DIST_RHS_SCALAR = 57 C ----------------------------------------- C Tags for backsolve C ----------------------------------------- INTEGER TERMBWD, & BACKSLV_UPDATERHS, & BACKSLV_MASTER2SLAVE PARAMETER( TERMBWD = 21, & BACKSLV_UPDATERHS = 22, & BACKSLV_MASTER2SLAVE = 23 ) C ------------------------ C Tag for symmetrization C ------------------------ INTEGER SYMMETRIZE PARAMETER ( SYMMETRIZE = 24 ) C ---------------------------- C Tags specific to symmetric C ---------------------------- INTEGER BLOC_FACTO_SYM, & BLOC_FACTO_SYM_SLAVE, END_NIV2_LDLT, & END_NIV2 PARAMETER ( BLOC_FACTO_SYM = 25, & BLOC_FACTO_SYM_SLAVE = 26, & END_NIV2_LDLT = 33, & END_NIV2 = 34 ) C ------------------------------------- C Tags specific to dynamic scheduling C ------------------------------------- INTEGER UPDATE_LOAD PARAMETER ( UPDATE_LOAD = 27 ) C To send deficientcy INTEGER DEFIC_TAG PARAMETER( DEFIC_TAG = 28 ) C To send Schur INTEGER TAG_SCHUR PARAMETER( TAG_SCHUR = 38 ) C To clean up IRECV INTEGER TAG_DUMMY PARAMETER( TAG_DUMMY = 39 ) C To send zero pivot indices INTEGER ZERO_PIV PARAMETER( ZERO_PIV = 40 ) C To send Singular values (if defined(try_null_space)) INTEGER TAG_ROOT1, TAG_ROOT2 PARAMETER( TAG_ROOT1 = 41 ) PARAMETER( TAG_ROOT2 = 42 ) C C Note: tags 100-160 are reserved for C the parallel scaling routine C MUMPS_5.8.1/src/zsol_bwd_aux.F0000664000175000017500000021051615042446441016045 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SOLVE_NODE_BWD( INODE, & N, IPOOL, LPOOL, IIPOOL, NBFINF, & A, LA, IW, LIW, W, LWC, NRHS, & POSWCB, PLEFTW, POSIWCB, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, & MYLEAF_LEFT, INFO, & PROCNODE_STEPS, DEJA_SEND, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & , DO_MCAST2_TERMBWD & ) USE ZMUMPS_OOC USE ZMUMPS_BUF USE ZMUMPS_SOL_LR, only : ZMUMPS_SOL_BWD_LR_SU IMPLICIT NONE INTEGER :: KEEP( 500 ) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER :: INFO(80) INTEGER, INTENT( IN ) :: INODE, N, NRHS, MTYPE, LIW, LIWW INTEGER, INTENT( IN ) :: SLAVEF, COMM, MYID INTEGER, INTENT (IN ) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT( IN ) :: NE_STEPS(KEEP(28)) INTEGER(8), INTENT( IN ) :: LA, LWC INTEGER(8), INTENT( INOUT ) :: POSWCB, PLEFTW INTEGER, INTENT( INOUT ) :: POSIWCB INTEGER, INTENT( IN ) :: LPANEL_POS INTEGER :: PANEL_POS(LPANEL_POS) LOGICAL, INTENT(INOUT) :: DEJA_SEND(0:SLAVEF-1) INTEGER, INTENT(IN) :: LPOOL INTEGER, INTENT(INOUT) :: IPOOL(LPOOL), IIPOOL INTEGER, INTENT(INOUT) :: NBFINF, MYLEAF_LEFT INTEGER :: PTRIST(KEEP(28)), PTRICB(KEEP(28)) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX(kind=8) :: A( LA ) COMPLEX(kind=8) :: W(LWC) COMPLEX(kind=8) :: W2(KEEP(133)) INTEGER :: IW(LIW),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)),FILS(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LRHSINTR, POSINRHSINTR_BWD(N) COMPLEX(kind=8) RHSINTR(LRHSINTR,NRHS) INTEGER(8), intent(in) :: LRHS_ROOT COMPLEX(kind=8) RHS_ROOT( LRHS_ROOT ) LOGICAL, INTENT( IN ) :: PRUN_BELOW INTEGER, INTENT(IN) :: SIZE_TO_PROCESS LOGICAL, INTENT(IN) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, INTENT(IN) :: DO_NBSPARSE INTEGER, INTENT(IN) :: LRHS_BOUNDS INTEGER, INTENT(IN) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, INTENT(IN) :: FROM_PP LOGICAL, INTENT( OUT ) :: ERROR_WAS_BROADCASTED LOGICAL, INTENT( OUT ) :: DO_MCAST2_TERMBWD INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR LOGICAL FLAG INCLUDE 'mumps_headers.h' LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL LTLEVEL2, IN_SUBTREE INTEGER TYPENODE INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL NO_CHILDREN LOGICAL :: ALLOW_OTHERS_TO_LEAVE INTEGER :: K, JBDEB, JBFIN, NRHS_B INTEGER IWHDLR INTEGER NPIV INTEGER IPOS,LIELL,NELIM,JJ,I INTEGER J1,J2,J,NCB INTEGER NSLAVES INTEGER IN,IF,LONG,POOL_FIRST_POS,TMP INTEGER :: NBFILS INTEGER :: PROCDEST, DEST INTEGER(8) :: PTWCB, PPIV_COURANT INTEGER :: Offset, EffectiveSize, ISLAVE, FirstIndex INTEGER :: POSINDICES, IPOSINRHSINTR, IPOSINRHSINTR_PANEL INTEGER(8) :: APOS, IST INTEGER(8) :: IFR8 INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER LDAJ, NBJ, & NBJLAST, NPIV_LAST, PANEL_SIZE, & NCB_PANEL, TYPEF INTEGER BEG_PANEL LOGICAL TWOBYTWO INTEGER NPANELS, IPANEL COMPLEX(kind=8) ALPHA,ONE,ZERO PARAMETER (ZERO=(0.0D0,0.0D0), & ONE=(1.0D0,0.0D0), & ALPHA=(-1.0D0,0.0D0)) LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE ERROR_WAS_BROADCASTED = .FALSE. DO_MCAST2_TERMBWD = .FALSE. NO_CHILDREN = .FALSE. IF (DO_NBSPARSE) THEN JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) JBFIN= RHS_BOUNDS(2*STEP(INODE)) NRHS_B = JBFIN-JBDEB+1 ELSE JBDEB = 1 JBFIN = NRHS NRHS_B = NRHS ENDIF IF ( INODE .EQ. KEEP( 38 ) .OR. INODE .EQ. KEEP( 20 ) ) THEN IPOS = PTRIST(STEP(INODE))+KEEP(IXSZ) NPIV = IW(IPOS+3) LIELL = IW(IPOS) + NPIV IPOS = PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) IF ( MTYPE .EQ. 1 .AND. KEEP(50) .EQ. 0) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + LIELL + NPIV ELSE J1 = IPOS + 1 J2 = IPOS + NPIV END IF IFR8 = 0_8 IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) CALL ZMUMPS_SOL_CPY_FS2RHSINTR(JBDEB, JBFIN, J2-J1+1, & KEEP, RHSINTR, NRHS, LRHSINTR, IPOSINRHSINTR, & RHS_ROOT(1+NPIV*(JBDEB-1)), NPIV, 1) IN = INODE 270 IN = FILS(IN) IF (IN .GT. 0) GOTO 270 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF (KEEP(31) .NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF RETURN ENDIF IF = -IN LONG = NPIV NBFILS = NE_STEPS(STEP(INODE)) IF ( PRUN_BELOW ) THEN I = NBFILS NBFILS = 0 DO WHILE (I.GT.0) IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 IF = FRERE(STEP(IF)) I = I -1 ENDDO IF (NBFILS.EQ.0) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF IF = -IN ENDIF DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1030 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1030 ENDIF NO_CHILDREN = .FALSE. ENDIF IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)),KEEP(199)) & .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) IF (.NOT. DEJA_SEND( PROCDEST )) THEN 600 CONTINUE CALL ZMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, & LONG, LONG, IW( J1 ), & RHS_ROOT( 1+NPIV*(JBDEB-1) ), & JBDEB, JBFIN, & RHSINTR(1, 1), NRHS, LRHSINTR, & IPOSINRHSINTR, NPIV, & KEEP, PROCDEST, & NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, & MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 600 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal error 2 ZMUMPS_SOLVE_NODE_BWD", & IERR CALL MUMPS_ABORT() END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF ENDIF IF = FRERE(STEP(IF)) ENDDO ALLOW_OTHERS_TO_LEAVE = .FALSE. IF ( PRUN_BELOW .AND. NO_CHILDREN ) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) ENDIF IF ( KEEP(31). NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF IF (IIPOOL.NE.POOL_FIRST_POS) THEN DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP = IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1) = IPOOL(IIPOOL-I) IPOOL(IIPOOL-I) = TMP ENDDO ENDIF RETURN END IF IN_SUBTREE = MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) TYPENODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) LTLEVEL2= ( & (TYPENODE .eq.2 ) .AND. & (MTYPE.NE.1) ) NPIV = IW(PTRIST(STEP(INODE))+2+KEEP(IXSZ)+1) IF ((NPIV.NE.0).AND.(LTLEVEL2)) THEN IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) NCB = LIELL - NPIV - NELIM IPOS = IPOS + 2 NSLAVES = IW( IPOS ) Offset = 0 IPOS = IPOS + NSLAVES IW(PTRIST(STEP(INODE))+XXS)= C_FINI+NSLAVES IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL ZMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR(NCB * NRHS_B - POSWCB-PLEFTW+1_8, & INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - int(NCB,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = NCB*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF IF ( NCB.EQ.0 ) THEN write(6,*) ' Internal Error type 2 node with no CB ' CALL MUMPS_ABORT() ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + NELIM +1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + NELIM +1 J2 = IPOS + LIELL END IF IFR8 = PTRACB(STEP( INODE )) - 1_8 CALL ZMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSINTR, NRHS, LRHSINTR, & W(PTRACB(STEP(INODE))), NCB, 1, & IW, LIW, KEEP, N, POSINRHSINTR_BWD ) IFR8 = IFR8 + int(J2-KEEP(253)-J1+1,8) IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR8 = IFR8 + 1_8 DO K=JBDEB, JBFIN IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR8+int(K-JBDEB,8)*int(NCB,8)) = ALPHA ELSE W(IFR8+int(K-JBDEB,8)*int(NCB,8)) = ZERO ENDIF ENDDO ENDDO ENDIF DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & EffectiveSize, & FirstIndex ) 500 CONTINUE DEST = IW( PTRIST(STEP(INODE))+5+ISLAVE+KEEP(IXSZ)) CALL ZMUMPS_BUF_SEND_BACKVEC(NRHS_B, INODE, & W(Offset+PTRACB(STEP(INODE))), & EffectiveSize, & NCB, DEST, & BACKSLV_MASTER2SLAVE, JBDEB, JBFIN, & KEEP, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, & PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 500 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF Offset = Offset + EffectiveSize END DO IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL ZMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) RETURN ENDIF LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) NCB = LIELL - NPIV IPOS = IPOS + 1 IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ENDIF APOS = PTRFAC( STEP(INODE)) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 + NSLAVES IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN IF (MTYPE.NE.1) THEN TYPEF = TYPEF_L ELSE TYPEF = TYPEF_U ENDIF PANEL_SIZE = ZMUMPS_OOC_PANEL_SIZE( LIELL ) IF (KEEP(50).NE.1) THEN CALL ZMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF LONG = 0 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL ELSE J1 = IPOS + 1 J2 = IPOS + NPIV ENDIF IF (IN_SUBTREE) THEN PTWCB = PLEFTW IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN CALL ZMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(int(LIELL,8)*int(NRHS_B,8)-POSWCB, & INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF ELSE IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL ZMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB ) IF ( POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR( int(LIELL,8)*int(NRHS_B,8)- & POSWCB-PLEFTW+1_8, & INFO(2) ) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - int(LIELL,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF PTWCB = PTRACB(STEP( INODE )) ENDIF IF (J2.GE.J1) THEN IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) ELSE IPOSINRHSINTR = -99999 ENDIF IF (J2.GE.J1) THEN DO K=JBDEB, JBFIN IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = ZERO ENDDO ENDIF END DO ENDIF IFR8 = PTWCB + int(NPIV - 1,8) IF ( LIELL .GT. NPIV ) THEN IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + 1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + 1 J2 = IPOS + LIELL END IF CALL ZMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSINTR, NRHS, LRHSINTR, & W(PTWCB), LIELL, NPIV+1, & IW, LIW, KEEP, N, POSINRHSINTR_BWD ) IFR8 = IFR8 + int(J2-KEEP(253)-J1+1,8) IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR8 = IFR8 + 1_8 DO K=JBDEB, JBFIN IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR8+int(K-JBDEB,8)*int(LIELL,8)) = ALPHA ELSE W(IFR8+int(K-JBDEB,8)*int(LIELL,8)) = ZERO ENDIF ENDDO ENDDO ENDIF NCB = LIELL - NPIV IF (NPIV .EQ. 0) GOTO 160 ENDIF IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN J = NPIV / PANEL_SIZE TWOBYTWO = KEEP(50).EQ.2 .AND. & ((TYPENODE.EQ.1.AND.KEEP(103).GT.0) .OR. & (TYPENODE.EQ.2.AND.KEEP(105).GT.0)) IF (TWOBYTWO) THEN CALL ZMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, LPANEL_POS, & IW(IPOS+1+LIELL), NPIV, NPANELS, LIELL, & NBENTRIES_ALLPANELS) ELSE IF (NPIV.EQ.J*PANEL_SIZE) THEN NPIV_LAST = NPIV NBJLAST = PANEL_SIZE NPANELS = J ELSE NPIV_LAST = (J+1)* PANEL_SIZE NBJLAST = NPIV-J*PANEL_SIZE NPANELS = J+1 ENDIF NBENTRIES_ALLPANELS = & int(LIELL,8) * int(NPIV,8) & - int( ( J * ( J - 1 ) ) /2,8 ) & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) & - int(J,8) & * int(mod(NPIV, PANEL_SIZE),8) & * int(PANEL_SIZE,8) JJ=NPIV_LAST ENDIF APOSDEB = APOS + NBENTRIES_ALLPANELS DO IPANEL = NPANELS, 1, -1 IF (TWOBYTWO) THEN NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) BEG_PANEL = PANEL_POS(IPANEL) ELSE IF (JJ.EQ.NPIV_LAST) THEN NBJ = NBJLAST ELSE NBJ = PANEL_SIZE ENDIF BEG_PANEL = JJ- PANEL_SIZE+1 ENDIF LDAJ = LIELL-BEG_PANEL+1 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) IPOSINRHSINTR_PANEL = IPOSINRHSINTR + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ IF (KEEP(50).NE.1.AND.MUST_BE_PERMUTED) THEN CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) IF (NPIV.EQ.(IW(I_PIVRPTR)-1)) THEN MUST_BE_PERMUTED=.FALSE. ELSE CALL ZMUMPS_PERMUTE_PANEL( & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, BEG_PANEL-1) ENDIF ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB.NE. 0) THEN CALL zgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL+NBJ,JBDEB), & 1, ONE, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1 ) ENDIF IF (NCB .NE. 0) THEN CALL zgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1 ) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL ztrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1) ELSE CALL ztrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1) ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB .NE. 0) THEN CALL zgemm( 'T', 'N', NBJ, NRHS_B, & NCB_PANEL-NCB, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL+NBJ,JBDEB), LRHSINTR, & ONE, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ENDIF IF (NCB .NE. 0) THEN CALL zgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, & W( PTWCB+int(NPIV,8) ), LIELL, & ONE, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB),LRHSINTR) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL ztrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ELSE CALL ztrsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO ELSE IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 & .AND. KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL ZMUMPS_SOL_BWD_LR_SU ( & INODE, IWHDLR, NPIV, NSLAVES, & LIELL, W, LWC, NRHS_B, PTWCB, & RHSINTR, LRHSINTR, NRHS, & IPOSINRHSINTR, JBDEB, & MTYPE, KEEP, KEEP8, & INFO(1), INFO(2) ) IF (INFO(1).LT.0) THEN ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ELSE IF ( LIELL .GT. NPIV ) THEN IF ( MTYPE .eq. 1 ) THEN IST = APOS + int(NPIV,8) #if defined(MUMPS_USE_BLAS2) IF (NRHS_B == 1) THEN CALL zgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(PTWCB+int(NPIV,8)), 1, & ONE, & RHSINTR(IPOSINRHSINTR,JBDEB), 1 ) ELSE #endif CALL zgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), & LIELL, W(PTWCB+int(NPIV,8)), LIELL, ONE, & RHSINTR(IPOSINRHSINTR,JBDEB), LRHSINTR) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE IF ( KEEP(50) .eq. 0 ) THEN IST = APOS + int(NPIV,8) * int(LIELL,8) ELSE IF( KEEP(459) .GT. 1) THEN CALL MUMPS_GETI8(IST, IW(PTRIST(STEP(INODE))+XXR)) IST = APOS + IST - int(NPIV,8) * int(LIELL-NPIV,8) ELSE IST = APOS + int(NPIV,8) * int(NPIV,8) ENDIF END IF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL zgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSINTR(IPOSINRHSINTR,JBDEB), 1 ) ELSE #endif CALL zgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), & NPIV, W(PTWCB+int(NPIV,8)), LIELL, & ONE, RHSINTR(IPOSINRHSINTR,JBDEB), LRHSINTR) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF ENDIF IF ( MTYPE .eq. 1 ) THEN LDAJ = LIELL ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=LIELL ELSE IF (KEEP(459).GT.1) THEN LDAJ=-999799 ELSE LDAJ=NPIV ENDIF ENDIF END IF PPIV_COURANT = int(JBDEB-1,8)*int(LRHSINTR,8) & + int(IPOSINRHSINTR,8) IF (KEEP(459).GT.1 .AND. KEEP(50).NE.0) THEN CALL ZMUMPS_SOLVE_BWD_PANELS( A, LA, APOS, & NPIV, IW(IPOS+1+LIELL), & NRHS_B, RHSINTR(1,1), KEEP8(25), LRHSINTR, PPIV_COURANT, & MTYPE, KEEP ) ELSE CALL ZMUMPS_SOLVE_BWD_TRSOLVE( A, LA, APOS, & NPIV, LDAJ, & NRHS_B, RHSINTR(1,1), KEEP8(25), LRHSINTR, PPIV_COURANT, & MTYPE, KEEP ) ENDIF ENDIF ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN J1 = IPOS + LIELL + 1 ELSE J1 = IPOS + 1 END IF IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) 160 CONTINUE IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ENDIF IN = INODE 170 IN = FILS(IN) IF (IN .GT. 0) GOTO 170 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 IF (.NOT. IN_SUBTREE ) THEN IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 CALL ZMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF ( KEEP(31) .NE. 0 .AND. & .NOT. IN_SUBTREE ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31).EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF RETURN ENDIF IF = -IN NBFILS = NE_STEPS(STEP(INODE)) IF ( PRUN_BELOW ) THEN I = NBFILS NBFILS = 0 DO WHILE (I.GT.0) IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 IF = FRERE(STEP(IF)) I = I -1 ENDDO IF (NBFILS.EQ.0) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF IF = -IN ENDIF IF (IN_SUBTREE) THEN DO I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1010 CONTINUE IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1010 ENDIF NO_CHILDREN = .FALSE. ENDIF IPOOL((IIPOOL-I+1)+NBFILS-I) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ENDDO IF (PRUN_BELOW .AND. NO_CHILDREN) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF (ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 RETURN ENDIF ENDIF ELSE DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO 190 I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1020 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1020 ENDIF NO_CHILDREN = .FALSE. ENDIF IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) IF (.not. DEJA_SEND( PROCDEST )) THEN 400 CONTINUE CALL ZMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, & LIELL, LIELL - KEEP(253), & IW( POSINDICES ), & W( PTRACB(STEP(INODE)) ), JBDEB, JBFIN, & RHSINTR(1, 1), NRHS, LRHSINTR, & IPOSINRHSINTR, NPIV, & KEEP, PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF IF = FRERE(STEP(IF)) ENDIF 190 CONTINUE IF ( PRUN_BELOW .AND. NO_CHILDREN ) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF ( ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 RETURN ENDIF ENDIF DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO IF ( KEEP(31) .NE. 0 ) & THEN KEEP(31) = KEEP(31) - 1 ALLOW_OTHERS_TO_LEAVE = (KEEP(31) .EQ. 1) IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF ENDIF IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 CALL ZMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF RETURN END SUBROUTINE ZMUMPS_SOLVE_NODE_BWD RECURSIVE SUBROUTINE ZMUMPS_BACKSLV_RECV_AND_TREAT( & BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IMPLICIT NONE LOGICAL BLOQ, FLAG INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER(8), intent(in) :: LWC COMPLEX(kind=8) W( LWC ) INTEGER POSIWCB INTEGER IIPOOL, LPOOL INTEGER IPOOL( LPOOL ) INTEGER LPANEL_POS INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(80), KEEP(500) INTEGER(8) :: POSWCB, PLEFTW INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER LIW INTEGER(8) :: LA INTEGER PTRIST(KEEP(28)), IW( LIW ) INTEGER (8) :: PTRFAC(KEEP(28)) COMPLEX(kind=8) A( LA ), W2( KEEP(133) ) INTEGER NRHS INTEGER MYLEAF_LEFT, MTYPE INTEGER LRHSINTR, POSINRHSINTR_BWD(N) COMPLEX(kind=8) RHSINTR(LRHSINTR,NRHS) LOGICAL, INTENT(IN) :: PRUN_BELOW INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR FLAG = .FALSE. IF ( BLOQ ) THEN CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF (FLAG) THEN KEEP(266)=KEEP(266)-1 MSGSOU=STATUS(MPI_SOURCE) MSGTAG=STATUS(MPI_TAG) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN INFO(1) = -20 INFO(2) = MSGLEN IF (NBFINF .NE. 0) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ELSE CALL MPI_RECV(BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, COMM, STATUS, IERR) CALL ZMUMPS_BACKSLV_TRAITER_MESSAGE( MSGTAG, MSGSOU, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) END IF END IF RETURN END SUBROUTINE ZMUMPS_BACKSLV_RECV_AND_TREAT RECURSIVE SUBROUTINE ZMUMPS_BACKSLV_TRAITER_MESSAGE( & MSGTAG, MSGSOU, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) USE ZMUMPS_OOC USE ZMUMPS_SOL_LR, ONLY: ZMUMPS_SOL_SLAVE_LR_U, & ZMUMPS_SOL_BWD_LR_SU USE ZMUMPS_BUF IMPLICIT NONE INTEGER MSGTAG, MSGSOU INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER(8), intent(in) :: LWC COMPLEX(kind=8) W( LWC ) INTEGER POSIWCB INTEGER IIPOOL, LPOOL, LPANEL_POS INTEGER IPOOL( LPOOL ) INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(80), KEEP(500) INTEGER(8) :: POSWCB, PLEFTW INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER FRERE(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER LIW INTEGER(8) :: LA INTEGER IW( LIW ), PTRIST( KEEP(28) ) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX(kind=8) A( LA ), W2( KEEP(133) ) INTEGER NRHS INTEGER MYLEAF_LEFT, MTYPE INTEGER LRHSINTR, POSINRHSINTR_BWD(N) COMPLEX(kind=8) RHSINTR(LRHSINTR,NRHS) LOGICAL, INTENT(IN) :: PRUN_BELOW INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS), NO_CHILDREN LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IF, INODE, IERR, LONG, DUMMY(1) INTEGER :: LIELL, K INTEGER(8) :: APOS, IST INTEGER NPIV, NROW_L, IPOS, NROW_RECU INTEGER(8) :: IFR8 INTEGER I, JJ, IN, PROCDEST, J1, J2, LDA INTEGER NSLAVES, NELIM, J, POSINDICES, INODEPOS, & IPOSINRHSINTR, IPOSINRHSINTR_PANEL INTEGER JBDEB, JBFIN, NRHS_B, allocok INTEGER(8) :: P_UPDATE, P_SOL_MAS INTEGER :: IWHDLR, MTYPE_SLAVE, LDA_SLAVE LOGICAL FLAG COMPLEX(kind=8) ZERO, ALPHA, ONE PARAMETER (ZERO=(0.0D0,0.0D0), & ONE=(1.0D0,0.0D0), & ALPHA=(-1.0D0,0.0D0)) INCLUDE 'mumps_headers.h' INTEGER POOL_FIRST_POS, TMP LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: NCB INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER(8) :: PTWCB, PPIV_COURANT INTEGER LDAJ, NBJ, & NBJLAST, NPIV_LAST, PANEL_SIZE, & NCB_PANEL, TYPEF LOGICAL TWOBYTWO INTEGER BEG_PANEL INTEGER IPANEL, NPANELS INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL :: ALLOW_OTHERS_TO_LEAVE LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_PROCNODE ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then INFO(1)=-13 INFO(2)=SLAVEF WRITE(6,*) MYID,' Allocation error of DEJA_SEND ' & //'in bwd solve COMPSO' GOTO 260 END IF DUMMY(1)=0 IF (MSGTAG .EQ. TERMBWD) THEN NBFINF = NBFINF - 1 ELSE IF (MSGTAG .EQ. NOEUD) THEN POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & LONG, 1, MPI_INTEGER, & COMM, IERR) NRHS_B = JBFIN-JBDEB+1 IF ( POSIWCB - LONG .LT. 0 & .OR. POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN CALL ZMUMPS_COMPSO(N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF (POSIWCB - LONG .LT. 0) THEN INFO(1)=-14 INFO(2)=-POSIWCB + LONG WRITE(6,*) MYID,' Internal error 1 in bwd solve COMPSO' GOTO 260 END IF IF ( POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(LONG + PLEFTW - POSWCB - 1_8, & INFO(2)) WRITE(6,*) MYID,' Internal error 2 in bwd solve COMPSO' GOTO 260 END IF ENDIF POSIWCB = POSIWCB - LONG POSWCB = POSWCB - LONG IF (LONG .GT. 0) THEN CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IWCB(POSIWCB + 1), & LONG, MPI_INTEGER, COMM, IERR) DO K=JBDEB,JBFIN CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & W(POSWCB + 1), LONG, & MPI_DOUBLE_COMPLEX, COMM, IERR) DO JJ=0, LONG-1 IPOSINRHSINTR = abs( POSINRHSINTR_BWD( IWCB( & POSIWCB+1+JJ ) ) ) IF (IPOSINRHSINTR.EQ.0) CYCLE RHSINTR(IPOSINRHSINTR,K) = W(POSWCB+1+JJ) ENDDO ENDDO POSIWCB = POSIWCB + LONG POSWCB = POSWCB + LONG ENDIF POOL_FIRST_POS = IIPOOL IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(INODE))) & GOTO 1010 ENDIF IPOOL( IIPOOL ) = INODE IIPOOL = IIPOOL + 1 1010 CONTINUE IF = FRERE( STEP(INODE) ) DO WHILE ( IF .GT. 0 ) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) .eq. MYID ) THEN IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(IF))) THEN IF = FRERE(STEP(IF)) CYCLE ENDIF ENDIF IPOOL( IIPOOL ) = IF IIPOOL = IIPOOL + 1 END IF IF = FRERE( STEP( IF ) ) END DO DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO ELSE IF ( MSGTAG .EQ. BACKSLV_MASTER2SLAVE ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NROW_RECU, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) NPIV = - IW( IPOS ) NROW_L = IW( IPOS + 1 ) IF ( NROW_L .NE. NROW_RECU ) THEN WRITE(*,*) 'Error1 : NROW L/RECU=',NROW_L, NROW_RECU CALL MUMPS_ABORT() END IF LONG = NROW_L + NPIV IF ( POSWCB - int(LONG,8)*int(NRHS_B,8) .LT. PLEFTW - 1_8 ) THEN CALL ZMUMPS_COMPSO( N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LONG*NRHS_B .LT. PLEFTW - 1_8 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(LONG * NRHS_B- POSWCB,INFO(2)) WRITE(6,*) MYID,' Internal error 3 in bwd solve COMPSO' GOTO 260 END IF END IF P_UPDATE = PLEFTW P_SOL_MAS = PLEFTW + int(NPIV,8) * int(NRHS_B,8) PLEFTW = P_SOL_MAS + int(NROW_L,8) * int(NRHS_B,8) DO K=JBDEB, JBFIN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W( P_SOL_MAS+(K-JBDEB)*NROW_L),NROW_L, & MPI_DOUBLE_COMPLEX, & COMM, IERR ) ENDDO IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF APOS = PTRFAC( STEP(INODE)) IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) MTYPE_SLAVE = 0 W(P_UPDATE:P_UPDATE+NPIV*NRHS_B-1)=ZERO CALL ZMUMPS_SOL_SLAVE_LR_U(INODE, IWHDLR, -9999, & W, LWC, & NROW_L, NPIV, & P_SOL_MAS, P_UPDATE, & JBDEB, JBFIN, & MTYPE_SLAVE, KEEP, KEEP8, & INFO(1), INFO(2) ) ELSE IF (KEEP(201) .EQ. 1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN MTYPE_SLAVE = 1 LDA_SLAVE = NROW_L ELSE MTYPE_SLAVE = 0 LDA_SLAVE = NPIV ENDIF CALL ZMUMPS_SOLVE_GEMM_UPDATE( & A, LA, APOS, NROW_L, & LDA_SLAVE, & NPIV, & NRHS_B, W, LWC, & P_SOL_MAS, NROW_L, & P_UPDATE, NPIV, & MTYPE_SLAVE, KEEP, ZERO) ENDIF IF (KEEP(201) .EQ. 1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF PLEFTW = PLEFTW - int(NROW_L,8) * int(NRHS_B,8) 100 CONTINUE CALL ZMUMPS_BUF_SEND_BACKVEC( NRHS_B, INODE, & W(P_UPDATE), & NPIV, NPIV, & MSGSOU, & BACKSLV_UPDATERHS, & JBDEB, JBFIN, & KEEP, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 100 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) GOTO 260 END IF PLEFTW = PLEFTW - NPIV * NRHS_B ELSE IF ( MSGTAG .EQ. BACKSLV_UPDATERHS ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPIV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) IPOS = IPOS + 1 NSLAVES = IW( IPOS + 1 ) IPOS = IPOS + 1 + NSLAVES INODEPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 4 IF ( KEEP(50) .eq. 0 ) THEN LDA = LIELL ELSE LDA = NPIV ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL ELSE J1 = IPOS + 1 J2 = IPOS + NPIV ENDIF IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) DO K=JBDEB, JBFIN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W2, NPIV, MPI_DOUBLE_COMPLEX, & COMM, IERR ) I = 1 IF ( (KEEP(253).NE.0) .AND. & (IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI+NSLAVES) & ) THEN DO JJ = J1,J2 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = W2(I) I = I+1 ENDDO ELSE DO JJ = J1,J2 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = & RHSINTR(IPOSINRHSINTR+JJ-J1,K) + W2(I) I = I+1 ENDDO ENDIF ENDDO IW(PTRIST(STEP(INODE))+XXS) = & IW(PTRIST(STEP(INODE))+XXS) - 1 IF ( IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI ) THEN IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN CALL ZMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL ZMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF APOS = PTRFAC(IW(INODEPOS)) IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN TYPEF = TYPEF_L NROW_L = NPIV+NELIM PANEL_SIZE = ZMUMPS_OOC_PANEL_SIZE(NROW_L) IF (PANEL_SIZE.LT.0) THEN WRITE(6,*) ' Internal error in bwd solve PANEL_SIZE=', & PANEL_SIZE CALL MUMPS_ABORT() ENDIF ENDIF IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL ZMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB ) IF ( POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR( int(LIELL,8)*int(NRHS_B,8)- & POSWCB-PLEFTW+1_8, & INFO(2) ) GOTO 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 - int(LIELL,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 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 PTWCB = PTRACB(STEP( INODE )) IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) IFR8 = PTRACB(STEP( INODE )) IFR8 = PTWCB + int(NPIV - 1,8) IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + 1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + 1 J2 = IPOS + LIELL END IF CALL ZMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSINTR, NRHS, LRHSINTR, & W(PTWCB), LIELL, NPIV+1, & IW, LIW, KEEP, N, POSINRHSINTR_BWD ) IFR8 = IFR8 + int(J2-KEEP(253)-J1+1,8) IF ( KEEP(201).EQ.1 .AND. OOCWRITE_COMPATIBLE_WITH_BLR .AND. & (( NELIM .GT. 0 ).OR. (MTYPE.NE.1 ))) THEN J = NPIV / PANEL_SIZE TWOBYTWO = KEEP(50).EQ.2 .AND. KEEP(105).GT.0 IF (TWOBYTWO) THEN CALL ZMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, LPANEL_POS, & IW(IPOS+1+LIELL), NPIV, NPANELS, NROW_L, & NBENTRIES_ALLPANELS) ELSE IF (NPIV.EQ.J*PANEL_SIZE) THEN NPIV_LAST = NPIV NBJLAST = PANEL_SIZE NPANELS = J ELSE NPIV_LAST = (J+1)* PANEL_SIZE NBJLAST = NPIV-J*PANEL_SIZE NPANELS = J+1 ENDIF NBENTRIES_ALLPANELS = & int(NROW_L,8) * int(NPIV,8) & - int( ( J * ( J - 1 ) ) /2,8 ) & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) & - int(J,8) & * int(mod(NPIV, PANEL_SIZE),8) & * int(PANEL_SIZE,8) JJ=NPIV_LAST ENDIF APOSDEB = APOS + NBENTRIES_ALLPANELS DO IPANEL = NPANELS, 1, -1 IF (TWOBYTWO) THEN NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) BEG_PANEL = PANEL_POS(IPANEL) ELSE IF (JJ.EQ.NPIV_LAST) THEN NBJ = NBJLAST ELSE NBJ = PANEL_SIZE ENDIF BEG_PANEL = JJ- PANEL_SIZE+1 ENDIF LDAJ = NROW_L-BEG_PANEL+1 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) PTWCB = PTRACB(STEP(INODE)) IPOSINRHSINTR_PANEL = IPOSINRHSINTR + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ NCB = NROW_L - NPIV IF (KEEP(50).NE.1 .AND.MUST_BE_PERMUTED) THEN CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) CALL ZMUMPS_PERMUTE_PANEL( & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, BEG_PANEL-1) ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB.NE. 0) THEN CALL zgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL+NBJ,JBDEB), & 1, ONE, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1 ) ENDIF IF (NCB .NE. 0) THEN CALL zgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1 ) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL ztrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1) ELSE CALL ztrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1) ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB .NE. 0) THEN CALL zgemm( 'T', 'N', NBJ, NRHS_B, & NCB_PANEL-NCB, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL+NBJ,JBDEB), LRHSINTR, & ONE, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ENDIF IF (NCB .NE. 0) THEN CALL zgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, & W( PTWCB+int(NPIV,8) ), LIELL, & ONE, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB),LRHSINTR) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL ztrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ELSE CALL ztrsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO GOTO 1234 ENDIF IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 & .AND. KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL ZMUMPS_SOL_BWD_LR_SU ( & INODE, IWHDLR, NPIV, NSLAVES, & LIELL, W, LWC, NRHS_B, PTRACB(STEP(INODE)), & RHSINTR, LRHSINTR, NRHS, & IPOSINRHSINTR, JBDEB, & MTYPE, KEEP, KEEP8, & INFO(1), INFO(2) ) ELSE IF (NELIM .GT.0) THEN IF ( KEEP(50) .eq. 0 ) THEN IST = APOS + int(NPIV,8) * int(LIELL,8) ELSE IF( KEEP(459) .GT. 1) THEN CALL MUMPS_GETI8(IST, IW(PTRIST(STEP(INODE))+XXR)) IST = APOS + IST - int(NPIV,8) * int(NELIM,8) ELSE IST = APOS + int(NPIV,8) * int(NPIV,8) ENDIF END IF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL zgemv( 'N', NPIV, NELIM, ALPHA, A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, & RHSINTR(IPOSINRHSINTR,JBDEB), 1 ) ELSE #endif CALL zgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))), LIELL, & ONE, RHSINTR(IPOSINRHSINTR,JBDEB), LRHSINTR) #if defined(MUMPS_USE_BLAS2) END IF #endif ENDIF PPIV_COURANT = int(JBDEB-1,8)*int(LRHSINTR,8) & + int(IPOSINRHSINTR,8) IF (KEEP(459).GT.1 .AND. KEEP(50).NE.0) THEN CALL ZMUMPS_SOLVE_BWD_PANELS( A, LA, APOS, & NPIV, IW(IPOS+1+LIELL), & NRHS_B, RHSINTR(1,1), KEEP8(25), LRHSINTR, PPIV_COURANT, & MTYPE, KEEP ) ELSE CALL ZMUMPS_SOLVE_BWD_TRSOLVE( A, LA, APOS, & NPIV, LDA, & NRHS_B, RHSINTR(1,1), KEEP8(25), LRHSINTR, PPIV_COURANT, & MTYPE, KEEP ) ENDIF ENDIF 1234 CONTINUE IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 6 + NSLAVES IPOSINRHSINTR = POSINRHSINTR_BWD(IW(IPOS)) IN = INODE 170 IN = FILS(IN) IF (IN .GT. 0) GOTO 170 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) IF (KEEP(31) .NE. 0) THEN IF (.NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN CALL ZMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & TERMBWD, SLAVEF, KEEP ) NBFINF = NBFINF - 1 ENDIF IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 CALL ZMUMPS_FREETOPSO(N, KEEP(28), & IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) GOTO 270 ENDIF DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO IN = -IN IF ( PRUN_BELOW ) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF DO WHILE (IN.GT.0) IF ( PRUN_BELOW ) THEN IF ( .NOT.TO_PROCESS(STEP(IN)) ) THEN IN = FRERE(STEP(IN)) CYCLE ELSE NO_CHILDREN = .FALSE. ENDIF ENDIF POOL_FIRST_POS = IIPOOL IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)), & KEEP(199)) .EQ. MYID) THEN IPOOL(IIPOOL ) = IN IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IN)), & KEEP(199) ) IF ( .NOT. DEJA_SEND( PROCDEST ) ) THEN 400 CONTINUE CALL ZMUMPS_BUF_SEND_VCB( NRHS_B, IN, 0, 0, & LIELL, LIELL - KEEP(253), & IW( POSINDICES ), & W( PTRACB(STEP(INODE)) ), JBDEB, JBFIN, & RHSINTR(1, 1), NRHS, LRHSINTR, & IPOSINRHSINTR, NPIV, & KEEP, PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN GOTO 270 ENDIF GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) GOTO 260 END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF END IF IN = FRERE( STEP( IN ) ) END DO ALLOW_OTHERS_TO_LEAVE = .FALSE. IF (NO_CHILDREN) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) ENDIF IF (KEEP(31) .NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN CALL ZMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERMBWD, SLAVEF, KEEP ) NBFINF = NBFINF - 1 ENDIF IF ( .NOT. NO_CHILDREN ) THEN DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO ENDIF IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL ZMUMPS_FREETOPSO( N, KEEP(28), & IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) END IF ELSE IF (MSGTAG.EQ.TERREUR) THEN INFO(1) = -001 INFO(2) = MSGSOU GO TO 270 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. & (MSGTAG.EQ.TAG_DUMMY) ) THEN GO TO 270 ELSE INFO(1) = -100 INFO(2) = MSGTAG GOTO 260 ENDIF GO TO 270 260 CONTINUE IF (NBFINF .NE. 0) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 270 CONTINUE IF (allocated(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE ZMUMPS_BACKSLV_TRAITER_MESSAGE SUBROUTINE ZMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, & LEN_PANEL_POS, INDICES, NPIV, & NPANELS, NFRONT_OR_NASS, & NBENTRIES_ALLPANELS) IMPLICIT NONE INTEGER, intent (in) :: PANEL_SIZE, NPIV INTEGER, intent (in) :: INDICES(NPIV) INTEGER, intent (in) :: LEN_PANEL_POS INTEGER, intent (out) :: NPANELS INTEGER, intent (out) :: PANEL_POS(LEN_PANEL_POS) INTEGER, intent (in) :: NFRONT_OR_NASS INTEGER(8), intent(out):: NBENTRIES_ALLPANELS INTEGER NPANELS_MAX, I, NBeff INTEGER(8) :: NBENTRIES_THISPANEL NBENTRIES_ALLPANELS = 0_8 NPANELS_MAX = (NPIV+PANEL_SIZE-1)/PANEL_SIZE IF (LEN_PANEL_POS .LT. NPANELS_MAX + 1) THEN WRITE(*,*) "Error 1 in ZMUMPS_BUILD_PANEL_POS", & LEN_PANEL_POS,NPANELS_MAX CALL MUMPS_ABORT() ENDIF I = 1 NPANELS = 0 IF (I .GT. NPIV) RETURN 10 CONTINUE NPANELS = NPANELS + 1 PANEL_POS(NPANELS) = I NBeff = min(PANEL_SIZE, NPIV-I+1) IF ( INDICES(I+NBeff-1) < 0) THEN NBeff=NBeff+1 ENDIF NBENTRIES_THISPANEL = int(NFRONT_OR_NASS-I+1,8) * int(NBeff,8) NBENTRIES_ALLPANELS = NBENTRIES_ALLPANELS + NBENTRIES_THISPANEL I=I+NBeff IF ( I .LE. NPIV ) GOTO 10 PANEL_POS(NPANELS+1)=NPIV+1 RETURN END SUBROUTINE ZMUMPS_BUILD_PANEL_POS MUMPS_5.8.1/src/dfac_sispointers_m.F0000664000175000017500000000154115042446441017214 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_S_IS_POINTERS_M C ---------------------------------- C This module defines a type used in C DMUMPS_FAC_DRIVER and DMUMPS_FAC_B C ---------------------------------- TYPE DMUMPS_S_IS_POINTERS_T DOUBLE PRECISION, POINTER, DIMENSION(:) :: A INTEGER, POINTER, DIMENSION(:) :: IW END TYPE DMUMPS_S_IS_POINTERS_T END MODULE DMUMPS_FAC_S_IS_POINTERS_M MUMPS_5.8.1/src/dfac_scalings.F0000664000175000017500000003054515042446440016126 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_FAC_A(N, NZ8, NSCA, & ASPK, IRN, ICN, COLSCA, ROWSCA, WK, LWK8, WK_REAL, & LWK_REAL, ICNTL, INFO) IMPLICIT NONE INTEGER N, NSCA INTEGER(8), INTENT(IN) :: NZ8 INTEGER IRN(NZ8), ICN(NZ8) INTEGER ICNTL(60), INFO(80) DOUBLE PRECISION, INTENT(IN) :: ASPK(NZ8) DOUBLE PRECISION COLSCA(*), ROWSCA(*) INTEGER(8), INTENT(IN) :: LWK8 INTEGER(8), INTENT(IN) :: LWK_REAL DOUBLE PRECISION WK(LWK8) DOUBLE PRECISION WK_REAL(LWK_REAL) INTEGER MPG,LP INTEGER I LOGICAL PROKG DOUBLE PRECISION ONE PARAMETER( ONE = 1.0D0 ) LP = ICNTL(1) MPG = ICNTL(2) MPG = ICNTL(3) PROKG = ((MPG.GT.0).AND.(ICNTL(4).GE.2)) IF (PROKG) THEN WRITE(MPG,101) ELSE MPG = 0 ENDIF 101 FORMAT(/' ****** SCALING OF ORIGINAL MATRIX '/) IF (NSCA.EQ.1) THEN IF (PROKG) WRITE (MPG,*) ' DIAGONAL SCALING ' ELSEIF (NSCA.EQ.3) THEN IF (PROKG) & WRITE (MPG,*) ' COLUMN SCALING' ELSEIF (NSCA.EQ.4) THEN IF (PROKG) & WRITE (MPG,*) ' ROW AND COLUMN SCALING (1 Pass)' ENDIF DO 10 I=1,N COLSCA(I) = ONE ROWSCA(I) = ONE 10 CONTINUE IF (NSCA.EQ.1) THEN CALL DMUMPS_FAC_V(N,NZ8,ASPK,IRN,ICN, & COLSCA,ROWSCA,MPG) ELSEIF (NSCA.EQ.3) THEN IF ( LWK_REAL .LT. int(N,8) ) THEN GOTO 420 ENDIF CALL DMUMPS_FAC_Y(N,NZ8,ASPK,IRN,ICN,WK_REAL(1), & COLSCA, MPG) ELSEIF (NSCA.EQ.4) THEN IF ( LWK_REAL .LT. 2_8*int(N,8) ) THEN GOTO 430 ENDIF CALL DMUMPS_ROWCOL(N,NZ8,IRN,ICN,ASPK, & WK_REAL(1),WK_REAL(1+N),COLSCA,ROWSCA,MPG) ENDIF GOTO 500 420 INFO(1) = -5 CALL MUMPS_SET_IERROR(int(N,8)-LWK_REAL, INFO(2)) IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix' GOTO 500 430 INFO(1) = -5 CALL MUMPS_SET_IERROR(2_8*int(N,8)-LWK_REAL, INFO(2)) IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix' GOTO 500 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_A SUBROUTINE DMUMPS_ROWCOL(N,NZ8,IRN,ICN,VAL, & RNOR,CNOR,COLSCA,ROWSCA,MPRINT) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 DOUBLE PRECISION VAL(NZ8) DOUBLE PRECISION RNOR(N),CNOR(N) DOUBLE PRECISION COLSCA(N),ROWSCA(N) DOUBLE PRECISION CMIN,CMAX,RMIN,ARNOR,ACNOR INTEGER IRN(NZ8), ICN(NZ8) DOUBLE PRECISION VDIAG INTEGER MPRINT INTEGER I,J INTEGER(8) :: K8 DOUBLE PRECISION ZERO, ONE PARAMETER(ZERO=0.0D0, ONE=1.0D0) DO 50 J=1,N CNOR(J) = ZERO RNOR(J) = ZERO 50 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.CNOR(J)) THEN CNOR(J) = VDIAG ENDIF IF (VDIAG.GT.RNOR(I)) THEN RNOR(I) = VDIAG ENDIF 100 CONTINUE IF (MPRINT.GT.0) THEN CMIN = CNOR(1) CMAX = CNOR(1) RMIN = RNOR(1) DO 111 I=1,N ARNOR = RNOR(I) ACNOR = CNOR(I) IF (ACNOR.GT.CMAX) CMAX=ACNOR IF (ACNOR.LT.CMIN) CMIN=ACNOR IF (ARNOR.LT.RMIN) RMIN=ARNOR 111 CONTINUE WRITE(MPRINT,*) '**** STAT. OF MATRIX PRIOR ROW&COL SCALING' WRITE(MPRINT,*) ' MAXIMUM NORM-MAX OF COLUMNS:',CMAX WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF COLUMNS:',CMIN WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF ROWS :',RMIN ENDIF DO 120 J=1,N IF (CNOR(J).LE.ZERO) THEN CNOR(J) = ONE ELSE CNOR(J) = ONE / CNOR(J) ENDIF 120 CONTINUE DO 130 J=1,N IF (RNOR(J).LE.ZERO) THEN RNOR(J) = ONE ELSE RNOR(J) = ONE / RNOR(J) ENDIF 130 CONTINUE DO 110 I=1,N ROWSCA(I) = ROWSCA(I) * RNOR(I) COLSCA(I) = COLSCA(I) * CNOR(I) 110 CONTINUE IF (MPRINT.GT.0) & WRITE(MPRINT,*) ' END OF SCALING BY MAX IN ROW AND COL' RETURN END SUBROUTINE DMUMPS_ROWCOL SUBROUTINE DMUMPS_FAC_Y(N,NZ8,VAL,IRN,ICN, & CNOR,COLSCA,MPRINT) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 DOUBLE PRECISION, INTENT(IN) :: VAL(NZ8) DOUBLE PRECISION, INTENT(OUT) :: CNOR(N) DOUBLE PRECISION, INTENT(INOUT) :: COLSCA(N) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) INTEGER, INTENT(IN) :: MPRINT DOUBLE PRECISION VDIAG INTEGER I,J INTEGER(8) :: K8 DOUBLE PRECISION ZERO, ONE PARAMETER (ZERO=0.0D0,ONE=1.0D0) DO 10 J=1,N CNOR(J) = ZERO 10 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.CNOR(J)) THEN CNOR(J) = VDIAG ENDIF 100 CONTINUE DO 110 J=1,N IF (CNOR(J).LE.ZERO) THEN CNOR(J) = ONE ELSE CNOR(J) = ONE/CNOR(J) ENDIF 110 CONTINUE DO 215 I=1,N COLSCA(I) = COLSCA(I) * CNOR(I) 215 CONTINUE IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF COLUMN SCALING' RETURN END SUBROUTINE DMUMPS_FAC_Y SUBROUTINE DMUMPS_FAC_V(N,NZ8,VAL,IRN,ICN, & COLSCA,ROWSCA,MPRINT) INTEGER , INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 DOUBLE PRECISION , INTENT(IN) :: VAL(NZ8) DOUBLE PRECISION , INTENT(OUT) :: ROWSCA(N),COLSCA(N) INTEGER , INTENT(IN) :: IRN(NZ8),ICN(NZ8) INTEGER , INTENT(IN) :: MPRINT DOUBLE PRECISION :: VDIAG INTEGER :: I,J INTEGER(8) :: K8 INTRINSIC sqrt DOUBLE PRECISION ZERO, ONE PARAMETER(ZERO=0.0D0, ONE=1.0D0) DO 10 I=1,N ROWSCA(I) = ONE 10 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) IF ((I.GT.N).OR.(I.LE.0)) GOTO 100 J = ICN(K8) IF (I.EQ.J) THEN VDIAG = abs(VAL(K8)) IF (VDIAG.GT.ZERO) THEN ROWSCA(J) = ONE/(sqrt(VDIAG)) ENDIF ENDIF 100 CONTINUE DO 110 I=1,N COLSCA(I) = ROWSCA(I) 110 CONTINUE IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF DIAGONAL SCALING' RETURN END SUBROUTINE DMUMPS_FAC_V SUBROUTINE DMUMPS_FAC_X(NSCA,N,NZ8,IRN,ICN,VAL, & RNOR,ROWSCA,MPRINT) INTEGER, INTENT(IN) :: N, NSCA INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) DOUBLE PRECISION VAL(NZ8) DOUBLE PRECISION RNOR(N) DOUBLE PRECISION ROWSCA(N) INTEGER MPRINT DOUBLE PRECISION VDIAG INTEGER I,J INTEGER(8) :: K8 DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: ONE = 1.0D0 DO 50 J=1,N RNOR(J) = ZERO 50 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.RNOR(I)) THEN RNOR(I) = VDIAG ENDIF 100 CONTINUE DO 130 J=1,N IF (RNOR(J).LE.ZERO) THEN RNOR(J) = ONE ELSE RNOR(J) = ONE/RNOR(J) ENDIF 130 CONTINUE DO 110 I=1,N ROWSCA(I) = ROWSCA(I)* RNOR(I) 110 CONTINUE IF ( (NSCA.EQ.4) .OR. (NSCA.EQ.6) ) THEN DO 150 K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 150 VAL(K8) = VAL(K8) * RNOR(I) 150 CONTINUE ENDIF IF (MPRINT.GT.0) & WRITE(MPRINT,'(A)') ' END OF ROW SCALING' RETURN END SUBROUTINE DMUMPS_FAC_X SUBROUTINE DMUMPS_ANORMINF( id, ANORMINF, LSCAL, & EFF_SIZE_SCHUR ) 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, INTENT(IN) :: LSCAL INTEGER, INTENT(IN) :: EFF_SIZE_SCHUR 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 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%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 ( id%KEEP(54) .eq. 0 ) THEN IF (id%MYID .EQ. MASTER) THEN IF (id%KEEP(55).EQ.0) THEN IF (.NOT.LSCAL) THEN CALL DMUMPS_SOL_X(id%A(1), & id%KEEP8(28), id%N, & id%IRN(1), id%JCN(1), & SUMR, id%KEEP(1),id%KEEP8(1), & EFF_SIZE_SCHUR, id%SYM_PERM(1) ) ELSE CALL DMUMPS_SCAL_X(id%A(1), & id%KEEP8(28), id%N, & id%IRN(1), id%JCN(1), & SUMR, id%KEEP(1), id%KEEP8(1), & id%COLSCA(1), & EFF_SIZE_SCHUR, id%SYM_PERM(1) ) ENDIF ELSE MTYPE = 1 IF (.NOT.LSCAL) THEN CALL DMUMPS_SOL_X_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), & id%A_ELT(1), SUMR, id%KEEP(1),id%KEEP8(1) ) ELSE CALL DMUMPS_SOL_SCALX_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), & id%A_ELT(1), & SUMR, id%KEEP(1), id%KEEP8(1), id%COLSCA(1)) ENDIF ENDIF ENDIF ELSE ALLOCATE( SUMR_LOC( id%N ), stat =allocok ) IF (allocok .GT.0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N RETURN ENDIF IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0 ) THEN IF (.NOT.LSCAL) THEN CALL DMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1), & EFF_SIZE_SCHUR, id%SYM_PERM(1) ) ELSE CALL DMUMPS_SCAL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1), & id%COLSCA(1), & EFF_SIZE_SCHUR, id%SYM_PERM(1) ) ENDIF ELSE SUMR_LOC = ZERO ENDIF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( SUMR_LOC, SUMR, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( SUMR_LOC, DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) END IF DEALLOCATE (SUMR_LOC) ENDIF IF ( id%MYID .eq. MASTER ) THEN ANORMINF = dble(ZERO) IF (LSCAL) THEN DO I = 1, id%N ANORMINF = max(abs(id%ROWSCA(I) * SUMR(I)), & ANORMINF) ENDDO ELSE DO I = 1, id%N ANORMINF = max(abs(SUMR(I)), & ANORMINF) ENDDO ENDIF ENDIF CALL MPI_BCAST(ANORMINF, 1, & MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) IF (id%MYID .eq. MASTER) DEALLOCATE (SUMR) RETURN END SUBROUTINE DMUMPS_ANORMINF MUMPS_5.8.1/src/cooc_panel_piv.F0000664000175000017500000002770315042446441016331 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C This file contains routines related to OOC, C panels, and pivoting. They are used to store C permutation information of what is already on C disk to be able to permute things back at the C solve stage. C They do not need to be in the MUMPS_OOC C module (most of them do not use any variable C from the module, or are called from routines C where we do not necessarily want to do a C USE CMUMPS_OOC). INTEGER FUNCTION CMUMPS_OOC_GET_PANEL_SIZE & ( HBUF_SIZE, NNMAX, K227, K50 ) IMPLICIT NONE C C Arguments: C ========= C INTEGER, INTENT(IN) :: NNMAX, K227, K50 INTEGER(8), INTENT(IN) :: HBUF_SIZE C C Purpose: C ======= C C - Compute the effective size (maximum number of pivots in a panel) C for a front with NNMAX entries in its row (for U) / C column (for L). C - Be able to adapt the fixed number of columns in panel C depending on NNMAX, and size of IO buffer HBUF_SIZE C C Local variables C =============== C INTEGER K227_LOC INTEGER NBCOL_MAX INTEGER EFFECTIVE_SIZE NBCOL_MAX=int(HBUF_SIZE / int(NNMAX,8)) C KEEP(227): Maximum size (nb of col/row) of a panel K227_LOC = abs(K227) IF (K50.EQ.2) THEN C for 2x2 pivots we may end-up having the first part C of a 2x2 pivot in the last col of the panel; the C adopted solution consists in adding the next column C to the panel; therefore we need be able to C dynamically increase the panel size by one. C note that we also maintain property: C KEEP(227): Maximum size (nb of col/row) of a panel K227_LOC=max(K227_LOC,2) EFFECTIVE_SIZE = min(NBCOL_MAX-1, K227_LOC-1) cN - during bwd the effective size is useless ELSE C complete buffer space can be used for a panel EFFECTIVE_SIZE = min(NBCOL_MAX, K227_LOC) ENDIF IF (EFFECTIVE_SIZE.LE.0) THEN write(6,*) 'Internal buffers too small to store ', & ' ONE col/row of size', NNMAX CALL MUMPS_ABORT() ENDIF CMUMPS_OOC_GET_PANEL_SIZE = EFFECTIVE_SIZE RETURN END FUNCTION CMUMPS_OOC_GET_PANEL_SIZE C SUBROUTINE CMUMPS_PERMUTE_PANEL( IPIV, LPIV, ISHIFT, & THE_PANEL, NBROW, NBCOL, KbeforePanel ) IMPLICIT NONE C C Purpose: C ======= C C Permute rows of a panel, stored by columns, according C to permutation array IPIV. C IPIV is such that, for I = 1 to LPIV, row ISHIFT + I C in the front must be permuted with row IPIV( I ) C C Since the panel is not necessary at the beginning of C the front, let KbeforePanel be the number of pivots in the C front before the first pivot of the panel. C C In the panel, row ISHIFT+I-KbeforePanel is permuted with C row IPIV(I)-KbeforePanel C C Note: C ==== C C This routine can also be used to permute the columns of C a matrix (U) stored by rows. In that case, the argument C NBROW represents the number of columns, and NBCOL represents C the number of rows. C C C Arguments: C ========= C INTEGER LPIV, ISHIFT, NBROW, NBCOL, KbeforePanel INTEGER IPIV(LPIV) COMPLEX THE_PANEL(NBROW, NBCOL) C C Local variables: C =============== C INTEGER I, IPERM C C Executable statements C ===================== C DO I = 1, LPIV C Swap rows ISHIFT + I and PIV(I) IPERM=IPIV(I) IF ( I+ISHIFT.NE.IPERM) THEN CALL cswap(NBCOL, & THE_PANEL(I+ISHIFT-KbeforePanel,1), NBROW, & THE_PANEL(IPERM-KbeforePanel,1), NBROW) ENDIF END DO RETURN END SUBROUTINE CMUMPS_PERMUTE_PANEL SUBROUTINE CMUMPS_GET_OOC_PERM_PTR(TYPEF, & NBPANELS, & I_PIVPTR, I_PIV, IPOS, IW, LIW) USE MUMPS_OOC_COMMON ! To access TYPEF_L and TYPEF_U IMPLICIT NONE INCLUDE 'mumps_headers.h' C C Purpose: C ======= C C Get the pointers in IW on pivoting information to be stored C during factorization and used during the solve phase. This C routine is both for the symmetric (TYPEF=TYPEF_L) and unsymmetric C cases (TYPEF=TYPEF_L or TYPEF_U). C The total size of this space is estimated during C fac_ass.F / fac_ass_ELT.F and must be: C * Symmetric case: 1 for NASS + 1 for NBPANELS_L + NBPANELS_L + NASS C * Unsymmetric case: 1 + (1+NBPANELS_L+NASS) + (1+NBPANELS_U+NASS) C Size computation is in routine CMUMPS_OOC_GET_PP_SIZES. C C At the end of the standard description of the structure of a node C (header, nb slaves, , row indices, col indices), we C add, when panel version with pivoting is used: C C NASS (nb of fully summed variables) C NBPANELS_L C PIVRPTR(1:NBPANELS_L) C PIV_L (1:NASS) NASS (=IW(IPOS)(or NASS-PIVRPTR(1) in C the future, after compression) C NBPANELS_U C PIVRPTR(1:NBPANELS_U) C PIV_U (1:NASS) NASS (=IW(IPOS)(or NASS-PIVRPTR(1) in C the future, after compression) C C C Output parameters: C ================= C NBPANELS : nb of panels as estimated during assembly C I_PIVPTR : position in IW of the starting of the pointer list C (of size NBPANELS) of the pointers to the list of pivots C I_PIV : position in IW of the starting of the pivot permutation list C INTEGER, intent(out) :: NBPANELS, I_PIVPTR, I_PIV INTEGER, intent(in) :: TYPEF ! TYPEF_L or TYPEF_U INTEGER, intent(in) :: LIW, IPOS INTEGER IW(LIW) C Locals INTEGER I_NBPANELS, I_NASS C I_NASS = IPOS I_NBPANELS = I_NASS + 1 ! L NBPANELS = IW(I_NBPANELS) ! L I_PIVPTR = I_NBPANELS + 1 ! L I_PIV = I_PIVPTR + NBPANELS ! L C ... of size NASS = IW(I_NASS) IF (TYPEF==TYPEF_U) THEN I_NBPANELS = I_PIV+IW(I_NASS) ! U NBPANELS = IW(I_NBPANELS) ! U I_PIVPTR = I_NBPANELS + 1 ! U I_PIV = I_PIVPTR + NBPANELS ! U ENDIF RETURN END SUBROUTINE CMUMPS_GET_OOC_PERM_PTR SUBROUTINE CMUMPS_OOC_PP_SET_PTR(K50,NBPANELS_L,NBPANELS_U, & NASS, IPOS, IW, LIW ) IMPLICIT NONE C C Purpose: C ======= C C Initialize the contents of PIV/PIVPTR/etc. that will store C pivoting information during the factorization. C NASS and NBPANELS are recorded. PIVPTR(1:NBPANELS) C is initialized to NASS+1. This will be modified during C the factorization in cases where permutations have to C be performed during the solve phase. C C Arguments: C ========= C INTEGER K50 INTEGER IPOS, NASS, NBPANELS_L, NBPANELS_U, LIW INTEGER IW(LIW) C C Local variables: C =============== C INTEGER IPOS_U C Executable statements IF (K50.EQ.1) THEN WRITE(*,*) "Internal error: CMUMPS_OOC_PP_SET_PTR called" ENDIF IW(IPOS)=NASS IW(IPOS+1)=NBPANELS_L IW(IPOS+2:IPOS+1+NBPANELS_L)=NASS+1 IF (K50 == 0) THEN IPOS_U=IPOS+2+NASS+NBPANELS_L IW(IPOS_U)=NBPANELS_U IW(IPOS_U+1:IPOS_U+NBPANELS_U)=NASS+1 ENDIF RETURN END SUBROUTINE CMUMPS_OOC_PP_SET_PTR SUBROUTINE CMUMPS_OOC_PP_TRYRELEASE_SPACE ( & IWPOS, IOLDPS, IW, LIW, MonBloc, NFRONT, KEEP & ) USE CMUMPS_OOC IMPLICIT NONE INCLUDE 'mumps_headers.h' C C Purpose: C ======= C If space used was at the top of the stack then C try to free space by detecting that C no permutation needs to be applied during C solve on panels. C One position is left (I_NASS) and set to -1 C to indicate that permutation not needed at solve. C C Arguments: C ========= C INTEGER, INTENT(IN) :: IOLDPS, LIW, NFRONT, & KEEP(500) INTEGER, INTENT(INOUT) :: IWPOS, IW(LIW) TYPE(IO_BLOCK), INTENT(IN):: MonBloc C C Local variables: C =============== C INTEGER :: NBPANELS_L,I_PIVRPTR_L, I_PIVR_L, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, XSIZE, IBEGOOC LOGICAL FREESPACE ! set to true when permutation not needed C Executable statements IF (KEEP(50).EQ.1) RETURN ! no pivoting C -------------------------------- C quick return if record is not at C the top of stack of L factors IF ((IOLDPS+IW(IOLDPS+XXI)).NE.IWPOS) RETURN C --------------------------------------------- C Panel+pivoting: get pointers on each subarray C --------------------------------------------- XSIZE = KEEP(IXSZ) IBEGOOC = IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE C -- get L related data CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IBEGOOC, IW, LIW) FREESPACE = & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_L)-1)) IF (KEEP(50).EQ.0) THEN C -- get U related dataA CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IBEGOOC, IW, LIW) FREESPACE = FREESPACE .AND. & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_U)-1)) ENDIF C --------------------------------- C Check if permutations eed be C performed on panels during solve C -------------------------------- IF (FREESPACE) THEN C -- compress memory for that node: keep one entry set to -7777 IW(IBEGOOC) = -7777 ! will be tested during solve IW(IOLDPS+XXI) = IBEGOOC & - IOLDPS + 1 ! new size of inode's record IWPOS = IBEGOOC+1 ! move back to top of stack ENDIF RETURN END SUBROUTINE CMUMPS_OOC_PP_TRYRELEASE_SPACE C SUBROUTINE CMUMPS_OOC_GET_PP_SIZES(K50, NBROW_L, NBCOL_U, NASS, & NBPANELS_L, NBPANELS_U, LREQ) USE CMUMPS_OOC ! To call CMUMPS_OOC_PANEL_SIZE IMPLICIT NONE C C Purpose C ======= C C Compute the size of the workspace required to store the permutation C information during factorization, so that solve can permute back C what has to be permuted (this could not be done during factorization C because it was already on disk). C C Arguments C ========= C INTEGER, intent(IN) :: K50, NBROW_L, NBCOL_U, NASS INTEGER, intent(OUT) :: NBPANELS_L, NBPANELS_U, LREQ NBPANELS_L=-99999 NBPANELS_U=-99999 C C Quick return in SPD case (no pivoting) C IF (K50.EQ.1) THEN LREQ = 0 RETURN ENDIF C C L information is always computed C NBPANELS_L = (NASS / CMUMPS_OOC_PANEL_SIZE(NBROW_L))+1 LREQ = 1 ! Store NASS & + 1 ! Store NBPANELS_L & + NASS ! Store permutations & + NBPANELS_L ! Store pointers on permutations IF (K50.eq.0) THEN C C Also take U information into account C NBPANELS_U = (NASS / CMUMPS_OOC_PANEL_SIZE(NBCOL_U) ) +1 LREQ = LREQ + 1 ! Store NBPANELS_U & + NASS ! Store permutations & + NBPANELS_U ! Store pointers on permutations ENDIF RETURN END SUBROUTINE CMUMPS_OOC_GET_PP_SIZES SUBROUTINE CMUMPS_OOC_PP_CHECK_PERM_FREED & (IW_LOCATION, MUST_BE_PERMUTED) IMPLICIT NONE INTEGER, INTENT(IN) :: IW_LOCATION LOGICAL, INTENT(INOUT) :: MUST_BE_PERMUTED C C Purpose C ======= C C Reset MUST_BE_PERMUTED to .FALSE. when we detect C that the CMUMPS_OOC_PP_TRY_RELEASE_SPACE has freed C the permutation information (see that routine). C IF (IW_LOCATION .EQ. -7777) THEN MUST_BE_PERMUTED = .FALSE. ENDIF RETURN END SUBROUTINE CMUMPS_OOC_PP_CHECK_PERM_FREED MUMPS_5.8.1/src/cfac_lastrtnelind.F0000664000175000017500000002071315042446440017021 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, & root, roota, FRERE, IROOT, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_ROOT2SLAVE, & MUMPS_BUF_SEND_ROOT2SON USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER IROOT INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC,IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER(8) :: LA INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND(KEEP(28)), FRERE(KEEP(28)) COMPLEX DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER I, NELIM, NB_CONTRI_GLOBAL, NUMORG, & NFRONT, IROW, JCOL, PDEST, HF, IOLDPS, & IN, DEB_ROW, ILOC_ROW, IFSON, ILOC_COL, & IPOS_SON, NELIM_SON, NSLAVES_SON, HS, & IROW_SON, ICOL_SON, ISLAVE, IERR, & NELIM_SENT, IPOS_STATREC, TYPE_SON INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' NB_CONTRI_GLOBAL = KEEP(41) NUMORG = root%ROOT_SIZE NELIM = KEEP(42) NFRONT = NUMORG + KEEP(42) DO IROW = 0, root%NPROW - 1 DO JCOL = 0, root%NPCOL - 1 PDEST = IROW * root%NPCOL + JCOL IF ( PDEST .NE. MYID ) THEN CALL MUMPS_BUF_SEND_ROOT2SLAVE(NFRONT, & NB_CONTRI_GLOBAL, PDEST, COMM, KEEP, IERR) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'MUMPS_BUF_SEND_ROOT2SLAVE' CALL MUMPS_ABORT() endif ENDIF END DO END DO CALL CMUMPS_PROCESS_ROOT2SLAVE( NFRONT, & NB_CONTRI_GLOBAL, root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND ) IF (IFLAG < 0 ) RETURN HF = 6 + KEEP(IXSZ) IOLDPS = PTLUST_S(STEP(IROOT)) IN = IROOT DEB_ROW = IOLDPS + HF ILOC_ROW = DEB_ROW DO WHILE (IN.GT.0) IW(ILOC_ROW) = IN IW(ILOC_ROW+NFRONT) = IN ILOC_ROW = ILOC_ROW + 1 IN = FILS(IN) END DO IFSON = -IN ILOC_ROW = IOLDPS + HF + NUMORG ILOC_COL = ILOC_ROW + NFRONT IF ( NELIM.GT.0 ) THEN IN = IFSON DO WHILE (IN.GT.0) IPOS_SON = PIMASTER(STEP(IN)) IF (IPOS_SON .EQ. 0) GOTO 100 NELIM_SON = IW(IPOS_SON+1+KEEP(IXSZ)) if (NELIM_SON.eq.0) then write(6,*) ' error 1 in process_last_rtnelind' CALL MUMPS_ABORT() endif NSLAVES_SON = IW(IPOS_SON+5+KEEP(IXSZ)) HS = 6 + NSLAVES_SON + KEEP(IXSZ) IROW_SON = IPOS_SON + HS ICOL_SON = IROW_SON + NELIM_SON DO I = 1, NELIM_SON IW( ILOC_ROW+I-1 ) = IW( IROW_SON+I-1 ) ENDDO DO I = 1, NELIM_SON IW( ILOC_COL+I-1 ) = IW( ICOL_SON+I-1 ) ENDDO NELIM_SENT = ILOC_ROW - IOLDPS - HF + 1 DO ISLAVE = 0,NSLAVES_SON IF (ISLAVE.EQ.0) THEN PDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)),KEEP(199)) ELSE PDEST = IW(IPOS_SON + 5 + ISLAVE+KEEP(IXSZ)) ENDIF IF (PDEST.NE.MYID) THEN CALL MUMPS_BUF_SEND_ROOT2SON(IN, NELIM_SENT, & PDEST, COMM, KEEP, IERR ) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'MUMPS_BUF_SEND_ROOT2SON' CALL MUMPS_ABORT() endif ELSE CALL CMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & IN, NELIM_SENT, root, roota, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( ISLAVE .NE. 0 ) THEN IF (KEEP(50) .EQ. 0) THEN IPOS_STATREC = PTRIST(STEP(IN))+6+KEEP(IXSZ) ELSE IPOS_STATREC = PTRIST(STEP(IN))+8+KEEP(IXSZ) ENDIF IF (IW(IPOS_STATREC).EQ. S_REC_CONTSTATIC) THEN IW(IPOS_STATREC) = S_ROOT2SON_CALLED ELSE IF (NSLAVES_SON .EQ. 0) THEN TYPE_SON = 1 ELSE TYPE_SON = 2 ENDIF CALL CMUMPS_FREE_BAND( N, IN, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON & ) ENDIF ENDIF IPOS_SON = PIMASTER(STEP(IN)) ENDIF END DO CALL CMUMPS_FREE_BLOCK_CB_STATIC( & .FALSE., MYID, N, IPOS_SON, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) ILOC_ROW = ILOC_ROW + NELIM_SON ILOC_COL = ILOC_COL + NELIM_SON 100 CONTINUE IN = FRERE(STEP(IN)) ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_LAST_RTNELIND MUMPS_5.8.1/src/ana_AMDMF.F0000664000175000017500000010660315042446423015011 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_SYMQAMD_NEW & ( JOB, THRESH, NDENSE, & N, TOTEL, & IWLEN, PE, PFREE, LEN, IW, NV, & ELEN, LAST, NCMPA, DEGREE, HEAD, NEXT, W, & PERM, COMPLEM_LIST, SIZE_COMPLEM_LIST, & AGG6 ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_COMPLEM_LIST INTEGER, INTENT(IN) :: TOTEL INTEGER(8), INTENT(IN) :: IWLEN INTEGER, INTENT(IN) :: THRESH LOGICAL, INTENT(IN) :: AGG6 INTEGER, INTENT (IN) :: COMPLEM_LIST(max(1,SIZE_COMPLEM_LIST)) INTEGER, INTENT(INOUT) :: JOB INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(N) INTEGER, INTENT(INOUT) :: PERM(N) INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(INOUT) :: NV(N) INTEGER, INTENT(OUT) :: LAST(N) INTEGER, INTENT(INOUT) :: ELEN(N) INTEGER, INTENT(OUT) :: NDENSE(N), DEGREE(N), & HEAD(N), NEXT(N), W(N) INTEGER THRESM, NDME, PERMeqN INTEGER NBD,NBED, NBDM, LASTD, NELME LOGICAL IDENSE INTEGER :: FDEG, ThresMin, ThresPrev, IBEGSchur, & ThresMinINIT LOGICAL :: AGG6_loc INTEGER :: THD_AGG LOGICAL :: SchurON, COMPRESS INTEGER :: DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, ME, MINDEG, NEL, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X INTEGER KNT1_UPDATED, KNT2_UPDATED INTEGER(8) MAXMEM, MEM, NEWMEM INTEGER :: MAXINT_N INTEGER(8) :: HASH, HMOD INTEGER(8) :: P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, & PN, PSRC, PLN, PELN INTRINSIC max, min, mod IF (N.EQ.1) THEN ELEN(1) = 1 LAST(1) = 1 PE(1) = 0_8 IF (NV(1).LT.0) NV(1) = 1 RETURN ENDIF AGG6_loc = AGG6 THD_AGG = max(128, min(TOTEL/2048, 1024)) IF ( SIZE_COMPLEM_LIST < 0 .OR. SIZE_COMPLEM_LIST > N ) THEN WRITE(*,*) "Internal MUMPS_SYMQAMD_NEW", SIZE_COMPLEM_LIST,N CALL MUMPS_ABORT() ENDIF IF (JOB.EQ.2) THEN SchurON = .FALSE. ENDIF THRESM = THRESH IF (JOB.NE.2) THEN SchurON = (SIZE_COMPLEM_LIST > 0) IF ((JOB.EQ.1) .AND. (.NOT.SchurON) .AND. (N .GT. 0)) THEN ENDIF IBEGSchur = N-SIZE_COMPLEM_LIST+1 IF (THRESM.GT.N) THRESM = N IF (THRESM.LT.0) THRESM = 0 IF ( SchurON ) THEN DO I= 1, N IF ( PERM(I) .GE. IBEGSchur) THEN PERM(I) = N + 1 IF (LEN(I) .EQ.0) THEN PE(I) = 0_8 ENDIF ENDIF ENDDO ENDIF ENDIF IF (SchurON) THEN THRESM = N ThresMin = N ThresPrev = N ELSE THRESM = max(int(31*N/32),THRESM) THRESM = max(THRESM,1) ThresMin = max( 3*THRESM / 4, 1) ThresPrev = THRESM ENDIF ThresMinINIT = ThresMin/4 IF (THRESM.GT.0) THEN IF ((THRESM.GT.N).OR.(THRESM.LT.2)) THEN THRESM = N ENDIF ENDIF IF (JOB.EQ.2) THEN ENDIF PERMeqN = 0 LASTD = 0 NBD = 0 NBED = 0 NBDM = 0 NEL = 0 WFLG = 2 MAXINT_N=huge(WFLG)-TOTEL MINDEG = 1 NCMPA = 0 HMOD = int(max (1, N-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM DO I = 1, N NDENSE(I)= 0 LAST (I) = 0 HEAD (I) = 0 NEXT (I) = 0 W (I) = 1 ENDDO IF(NV(1) .LT. 0) THEN COMPRESS = .FALSE. ELSE COMPRESS = .TRUE. ENDIF IF (.NOT.COMPRESS) THEN IF (JOB.EQ.2) THEN DO I = 1,SIZE_COMPLEM_LIST X = COMPLEM_LIST(I) ELEN(X) = -I NV(X) = LEN(X)+1 DEGREE(X) = LEN(X) DMAX = max(DMAX, LEN(X)) ENDDO NEL = NEL + SIZE_COMPLEM_LIST DO I=1, N IF (ELEN(I).LT.0) CYCLE DEGREE (I) = LEN (I) NV(I) = 1 ENDDO ELSE DO I=1, N ELEN(I) = 0 DEGREE (I) = LEN (I) NV(I) = 1 ENDDO ENDIF ELSE IF (JOB.EQ.2) THEN DO I = 1,SIZE_COMPLEM_LIST X = COMPLEM_LIST(I) ELEN(X) = -I NV(X)=1 DO P=PE(X), PE(X)+int(LEN(X)-1,8) NV(X) = NV(X) + NV(IW(P)) ENDDO DEGREE(X) = NV(X)-1 DMAX = max(DMAX,DEGREE(X)) ENDDO NEL = NEL + SIZE_COMPLEM_LIST DO I=1,N IF (ELEN(I).LT.0) CYCLE DEGREE (I) = LEN (I) ENDDO ELSE DO I=1, N ELEN (I) = 0 DEGREE(I) = 0 DO P= PE(I) , PE(I)+int(LEN(I)-1,8) DEGREE(I) = DEGREE(I) + NV(IW(P)) ENDDO ENDDO ENDIF 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+NV(I) IF (FDEG.NE.N+1) THEN DEGREE(I) = DEGREE(I)+TOTEL+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+NV(I) DEGREE(I) = TOTEL+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 + NV(I) ELEN (I) = -NEL PE (I) = 0_8 W (I) = 0 ENDIF 20 CONTINUE IF ((NBD.EQ.0).AND.(THRESM.GT.0)) THRESM = N 30 IF (NEL .LT. TOTEL) 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.TOTEL) 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.TOTEL+1) THEN IF (WFLG .GT. MAXINT_N) THEN DO 52 X = 1, N IF (W (X) .NE. 0) W (X) = 1 52 CONTINUE WFLG = 2 ENDIF WFLG = WFLG + 1 51 CONTINUE INEXT = NEXT (ME) IF (INEXT .NE. 0) THEN LAST (INEXT) = 0 ELSE LASTD = 0 ENDIF NDENSE(ME) = 0 W(ME) = WFLG P1 = PE(ME) P2 = P1 + int(LEN(ME) -1,8) PLN = P1 PELN = P1 DO 55 P=P1,P2 E= IW(P) IF (W(E).EQ.WFLG) GOTO 55 W(E) = WFLG IF (PE(E).LT.0_8) THEN X = E 53 X = int(-PE(X)) IF (W(X) .EQ.WFLG) GOTO 55 W(X) = WFLG IF ( PE(X) .LT. 0 ) GOTO 53 E = X ENDIF IF (ELEN(E).LT.0) THEN NDENSE(E) = NDENSE(E) - NV(ME) IW(PLN) = IW(PELN) IW(PELN) = E PLN = PLN + 1_8 PELN = PELN + 1_8 PME1 = PE(E) DO 54 PME = PME1, PME1+LEN(E)-1 X = IW(PME) IF ((ELEN(X).GE.0).AND.(W(X).NE.WFLG)) THEN NDENSE(ME) = NDENSE(ME) + NV(X) W(X) = WFLG ENDIF 54 CONTINUE ELSE NDENSE(ME) = NDENSE(ME) + NV(E) IW(PLN)=E PLN = PLN+1_8 ENDIF 55 CONTINUE WFLG = WFLG + 1 LEN(ME) = int(PLN-P1) ELEN(ME) = int(PELN-P1) NDME = NDENSE(ME)+NV(ME) IF (NDENSE(ME).EQ.0) NDENSE(ME) =1 DEGREE(ME) = NDENSE(ME) DEG = PERM(ME) MINDEG = min(DEG,MINDEG) JNEXT = HEAD(DEG) IF (JNEXT.NE. 0) LAST (JNEXT) = ME NEXT(ME) = JNEXT HEAD(DEG) = ME ME = INEXT IF (ME.NE.0) THEN IF (DEGREE(ME).GT.(TOTEL+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.TOTEL+1) THEN IF (NBD.NE.NBED) THEN write(6,*) ' ERROR in MUMPS_SYMQAMD_NEW ', & ' quasi dense rows remains' CALL MUMPS_ABORT() ENDIF IF (JOB.EQ.1) THEN DO I = 1,SIZE_COMPLEM_LIST X = COMPLEM_LIST(I) ELEN(X) = -(N-SIZE_COMPLEM_LIST+I) NV(X) = 1 PE(X) = 0_8 ENDDO GOTO 265 ENDIF NELME = -(NEL+1) DO 59 X=1,N IF ((PE(X).GT.0_8) .AND. (ELEN(X).LT.0)) THEN PE(X) = int(-COMPLEM_LIST(1),8) ELSEIF (DEGREE(X).EQ.TOTEL+1) THEN NEL = NEL + NV(X) PE(X) = int(-ME,8) ELEN(X) = 0 NV(X) = 0 ENDIF 59 CONTINUE ELEN(ME) = NELME NV(ME) = NBD PE(ME) = 0_8 IF (NEL.NE.N) THEN write(6,*) 'Internal error 3 detected in MUMPS_SYMQAMD_NEW:' write(6,*) ' NEL not equal to N: N, NEL =',N,NEL CALL MUMPS_ABORT() ENDIF IF (ME.NE. COMPLEM_LIST(1)) THEN DO I=1, SIZE_COMPLEM_LIST PE(COMPLEM_LIST(I)) = int(-COMPLEM_LIST(1),8) ENDDO PE(COMPLEM_LIST(1)) = 0_8 NV( COMPLEM_LIST(1))= NV(ME) NV(ME) = 0 ELEN( COMPLEM_LIST(1)) = ELEN(ME) ELEN(ME) = 0 ENDIF GOTO 265 ENDIF ENDIF ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV NDENSE(ME) = 0 NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN PME1 = PE (ME) PME2 = PME1 - 1 DO 60 P = PME1, PME1 + int(LEN (ME) - 1,8) I = IW (P) NVI = NV (I) IF (NVI .GT. 0) THEN DEGME = DEGME + NVI NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I IF (DEGREE(I).LE.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 (PERM(I)) = INEXT ENDIF ELSE NDENSE(ME) = NDENSE(ME) + NVI ENDIF ENDIF 60 CONTINUE NEWMEM = 0 ELSE P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME KNT1_UPDATED = 0 DO 120 KNT1 = 1, ELENME + 1 KNT1_UPDATED = KNT1_UPDATED +1 IF (KNT1 .GT. ELENME) THEN E = ME PJ = P LN = SLENME ELSE E = IW (P) P = P + 1 PJ = PE (E) LN = LEN (E) ENDIF KNT2_UPDATED = 0 DO 110 KNT2 = 1, LN KNT2_UPDATED = KNT2_UPDATED+1 I = IW (PJ) PJ = PJ + 1 NVI = NV (I) IF (NVI .GT. 0) THEN IF (PFREE .GT. IWLEN) THEN PE (ME) = P LEN (ME) = LEN (ME) - KNT1_UPDATED KNT1_UPDATED = 0 IF (LEN (ME) .EQ. 0) PE (ME) = 0_8 PE (E) = PJ LEN (E) = LN - KNT2_UPDATED KNT2_UPDATED = 0 IF (LEN (E) .EQ. 0) PE (E) = 0_8 NCMPA = NCMPA + 1 DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = int(IW (PN),8) IW (PN) = -J ENDIF 70 CONTINUE PDST = 1 PSRC = 1 PEND = PME1 - 1 80 CONTINUE IF (PSRC .LE. PEND) THEN J = -IW (PSRC) PSRC = PSRC + 1 IF (J .GT. 0) THEN IW (PDST) = int(PE (J)) PE (J) = PDST PDST = PDST + 1_8 LENJ = LEN (J) DO 90 KNT3 = 0, LENJ - 2 IW (PDST + KNT3) = IW (PSRC + KNT3) 90 CONTINUE PDST = PDST + int(LENJ - 1,8) PSRC = PSRC + int(LENJ - 1,8) ENDIF GO TO 80 ENDIF P1 = PDST DO 100 PSRC = PME1, PFREE - 1 IW (PDST) = IW (PSRC) PDST = PDST + 1 100 CONTINUE PME1 = P1 PFREE = PDST PJ = PE (E) P = PE (ME) ENDIF DEGME = DEGME + NVI NV (I) = -NVI IW (PFREE) = I PFREE = PFREE + 1 IF (DEGREE(I).LE.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 (PERM(I)) = INEXT ENDIF ELSE NDENSE(ME) = NDENSE(ME) + NVI ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN PE (E) = int(-ME,8) W (E) = 0 ENDIF 120 CONTINUE PME2 = PFREE - 1 NEWMEM = PFREE - PME1 MEM = MEM + NEWMEM MAXMEM = max (MAXMEM, MEM) ENDIF DEGREE (ME) = DEGME PE (ME) = PME1 LEN (ME) = int(PME2 - PME1 + 1_8) IF (WFLG .GT. MAXINT_N) THEN DO 130 X = 1, N IF (W (X) .NE. 0) W (X) = 1 130 CONTINUE WFLG = 2 ENDIF DO 150 PME = PME1, PME2 I = IW (PME) IF (DEGREE(I).GT.TOTEL) GOTO 150 ELN = ELEN (I) IF (ELN .GT. 0) THEN NVI = -NV (I) WNVI = WFLG - NVI DO 140 P = PE (I), PE (I) + int(ELN - 1,8) E = IW (P) WE = W (E) IF (WE .GE. WFLG) THEN WE = WE - NVI ELSE IF (WE .NE. 0) THEN WE = DEGREE (E) + WNVI - NDENSE(E) ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE AGG6_loc = (AGG6 .OR. (DEGREE(ME) .LT. THD_AGG)) DO 180 PME = PME1, PME2 I = IW (PME) IF (DEGREE(I).GT.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) ELSE IF (.NOT. AGG6_loc .AND. DEXT .EQ. 0) THEN IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) ELSE IF (AGG6_loc .AND. (DEXT .EQ. 0) .AND. & ((NDENSE(ME).EQ.NBD).OR.(NDENSE(E).EQ.0))) THEN PE (E) = int(-ME,8) W (E) = 0 ELSE IF (AGG6_loc .AND. DEXT.EQ.0) THEN IW(PN) = E PN = PN+1 HASH = HASH + int(E,kind=8) ENDIF 160 CONTINUE ELEN (I) = int(PN - P1 + 1_8) P3 = PN DO 170 P = P2 + 1, P1 + LEN (I) - 1 J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN IF (DEGREE(J).LE.TOTEL) DEG=DEG+NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE IF (((ELEN(I).EQ.1).AND.(P3.EQ.PN)) & .OR. & (AGG6_loc.AND.(DEG .EQ. 0).AND.(NDENSE(ME).EQ.NBD)) & ) & THEN PE (I) = int(-ME, 8) NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE DEGREE(I) = min (DEG+NBD-NDENSE(ME), & DEGREE(I)) IW (PN) = IW (P3) IW (P3) = IW (P1) IW (P1) = ME LEN (I) = int(PN - P1 + 1) HASH = mod (HASH, HMOD) + 1_8 J = HEAD (HASH) IF (J .LE. 0) THEN NEXT (I) = -J HEAD (HASH) = -I ELSE NEXT (I) = LAST (J) LAST (J) = I ENDIF LAST (I) = int(HASH,kind=kind(LAST)) ENDIF 180 CONTINUE DEGREE (ME) = DEGME DMAX = max (DMAX, DEGME) WFLG = WFLG + DMAX IF (WFLG .GT. MAXINT_N) THEN DO 190 X = 1, N IF (W (X) .NE. 0) W (X) = 1 190 CONTINUE WFLG = 2 ENDIF DO 250 PME = PME1, PME2 I = IW (PME) IF ( (NV(I).LT.0) .AND. (DEGREE(I).LE.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 X = I LN = LEN (I) ELN = ELEN (I) DO 210 P = PE (I) + 1, PE (I) + int(LN - 1,8) W (IW (P)) = WFLG 210 CONTINUE JLAST = I J = NEXT (I) 220 CONTINUE IF (J .NE. 0) THEN IF (LEN (J) .NE. LN) GO TO 240 IF (ELEN (J) .NE. ELN) GO TO 240 DO 230 P = PE (J) + 1, PE (J) + int(LN - 1,8) IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE IF (PERM(J).GT.PERM(X)) THEN PE (J) = int(-X,8) NV (X) = NV (X) + NV (J) NV (J) = 0 ELEN (J) = 0 ELSE PE (X) = int(-J,8) NV (J) = NV (X) + NV (J) NV (X) = 0 ELEN (X) = 0 X = J ENDIF J = NEXT (J) NEXT (JLAST) = J GO TO 220 240 CONTINUE JLAST = J J = NEXT (J) GO TO 220 ENDIF WFLG = WFLG + 1 I = NEXT (I) IF (I .NE. 0) GO TO 200 ENDIF ENDIF 250 CONTINUE IF ( (THRESM .GT. 0).AND.(THRESM.LT.N) ) THEN THRESM = max(ThresMin, THRESM-NVPIV) ENDIF P = PME1 NLEFT = 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 (THRESM.GT.0) THEN IF (PERM(I) .GT. THRESM) THEN IDENSE = .TRUE. DEGREE(I) = DEGREE(I)+TOTEL+2 ENDIF IF (IDENSE) THEN P1 = PE(I) P2 = P1 + int(ELEN(I) - 1, 8) IF (P2.GE.P1) THEN DO 264 PJ=P1,P2 E= IW(PJ) NDENSE (E) = NDENSE(E) + NVI 264 CONTINUE ENDIF NBD = NBD+NVI FDEG = N DEG = N INEXT = HEAD(DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I LAST(I) = 0 IF (LASTD.EQ.0) LASTD=I ENDIF ENDIF IF (.NOT.IDENSE) THEN FDEG = PERM(I) INEXT = HEAD (FDEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (FDEG) = I ENDIF MINDEG = min (MINDEG, FDEG) ENDIF IW (P) = I P = P + 1 ENDIF 260 CONTINUE NV (ME) = NVPIV + DEGME LEN (ME) = int(P - PME1) IF (LEN (ME) .EQ. 0) THEN PE (ME) = 0_8 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN PFREE = P MEM = MEM - NEWMEM + int(LEN (ME),8) ENDIF GO TO 30 ENDIF 265 CONTINUE DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN J = int(-PE (I)) 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = int(-PE (J)) GO TO 270 ENDIF E = J K = -ELEN (E) J = I 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = int(-PE (J)) PE (J)= int(-E,8) IF (ELEN (J) .EQ. 0) THEN ELEN (J) = K K = K + 1 ENDIF J = JNEXT GO TO 280 ENDIF ELEN (E) = -K ENDIF 290 CONTINUE DO 300 I = 1, N K = abs (ELEN (I)) ELEN (I) = K 300 CONTINUE IF (.NOT.SchurON) THEN IF (PERMeqN.GT.0) PERM(PERMeqN) = N ENDIF PFREE = MAXMEM RETURN END SUBROUTINE MUMPS_SYMQAMD_NEW SUBROUTINE MUMPS_WRAP_GINP94 & ( N, IPE, IW, LIW8, & PERM, SizeOfBlocks, & KEEP60, LISTVAR_SCHUR, SIZE_SCHUR, KEEP378, & COLCOUNT, PARENT, & PORDER, IWTMP1, IWTMP2, IWTMP3, IWTMP4, & IWTMP5, & INFO ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: LIW8 INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: SizeOfBlocks(N) INTEGER, INTENT(INOUT) :: PERM(N) INTEGER, INTENT(IN) :: IW(LIW8) INTEGER, INTENT(OUT) :: COLCOUNT(N) INTEGER, INTENT(OUT) :: PARENT(N) INTEGER, INTENT(IN) :: KEEP60, SIZE_SCHUR INTEGER, INTENT(IN) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: KEEP378 INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(OUT):: PORDER(N), IWTMP1(N), IWTMP2(N) INTEGER, INTENT(OUT):: IWTMP3(N), IWTMP4(N), IWTMP5(N) INTEGER :: I, KEEP378_loc, SIZE_SCHUR_EFF LOGICAL :: SizeOfBlocks_provided SizeOfBlocks_provided = (SizeOfBlocks(1).NE.-1) IF (KEEP378.NE.0) KEEP378_loc=1 DO I=1, N IWTMP1(PERM(I)) = I END DO CALL MUMPS_GINP94_ELIM_TREE ( & N, IPE, IW, LIW8, IWTMP1, PERM, PARENT, & IWTMP2, INFO) IF (INFO(1).LT.0) RETURN CALL MUMPS_GINP94_POSTORDER(PARENT, N, PORDER, & IWTMP1, IWTMP2, IWTMP3, & INFO) IF (INFO(1).LT.0) RETURN IF (KEEP60.NE.0) THEN SIZE_SCHUR_EFF = SIZE_SCHUR ELSE SIZE_SCHUR_EFF = 0 ENDIF CALL MUMPS_GINP94_COLCOUNTS( & N, LIW8, IPE, IW, PARENT, PORDER, COLCOUNT, & SizeOfBlocks_provided, SizeOfBlocks, KEEP378_loc, & SIZE_SCHUR_EFF, PERM, & IWTMP1, IWTMP2, IWTMP3, IWTMP4, IWTMP5, & INFO) IF (INFO(1).LT.0) RETURN IF (KEEP60.NE.0) THEN CALL MUMPS_GINP94_POSTPROCESS_SCHUR ( & N, PARENT, COLCOUNT, PERM, & LISTVAR_SCHUR, SIZE_SCHUR ) ENDIF RETURN END SUBROUTINE MUMPS_WRAP_GINP94 SUBROUTINE MUMPS_GINP94_ELIM_TREE ( & n, iptr, jcn, ljcn, invperm, perm, parent, & ancestor, info) IMPLICIT NONE INTEGER(8), INTENT(IN) :: ljcn integer :: n INTEGER(8), INTENT(IN) :: iptr(n+1) integer, INTENT(IN) :: jcn(ljcn), invperm(n), perm(n) integer, INTENT(OUT) :: parent(n) integer, INTENT(INOUT) :: INFO(2) integer, INTENT(OUT) :: ancestor(n) integer :: jpos, i, j, k integer(8) :: iidx8 ancestor=0 parent =0 do jpos = 1, n j = invperm(jpos) do iidx8 = iptr(j), iptr(j+1)-1 i = jcn(iidx8) if (perm(i).ge.jpos) cycle k = i call add_node(n, ancestor, parent, j, k) end do end do return contains subroutine add_node(n, ancestor, parent, j, i) implicit none integer, intent(in):: n integer :: parent(n) integer :: ancestor(n) integer :: i, j integer :: r, k if(i.eq.0) return k = i do r = ancestor(k) if (r .eq. j) then return end if ancestor(k) = j if(r .eq. 0) then parent(k) = j return end if k = r end do end subroutine add_node END SUBROUTINE MUMPS_GINP94_ELIM_TREE SUBROUTINE MUMPS_GINP94_POSTORDER(parent, n, porder, & son, brother, stack, & INFO & ) IMPLICIT NONE integer, intent(in) :: n integer, intent(in) :: parent(n) integer, intent(out) :: porder(n) integer, intent(inout):: INFO(2) integer, intent(out) :: son(n), brother(n), stack(n) integer :: i, father, br, head, hp, pp, t son = 0 do i=n, 1, -1 father = parent(i) if (father .ne. 0) then br = son(father) brother(i) = br son(father) = i end if end do head = 0 hp = 0 pp = 1 do t=1, n if (parent(t) .ne. 0) cycle hp = hp+1 stack(hp) = t head = t do if(son(head) .eq. 0) then porder(pp) = head pp = pp+1 hp = hp-1 if (parent(head) .ne. 0) then son(parent(head)) = brother(head) end if if (hp .eq. 0) then exit end if head = stack(hp) else hp = hp+1 stack(hp) = son(head) head = son(head) end if end do end do RETURN END SUBROUTINE MUMPS_GINP94_POSTORDER SUBROUTINE MUMPS_GINP94_COLCOUNTS( & n, ljcn, iptr, jcn, parent, porder, cc, & SizeOfBlocks_provided, SizeOfBlocks, KEEP378, & SIZE_SCHUR_EFF, PERM, & fst_desc, iporder, prev_p, prev_nbr, setpath, & INFO) IMPLICIT NONE integer, intent(in) :: n integer(8), intent(in) :: ljcn integer(8), intent(in) :: iptr(n+1) integer, intent(in) :: jcn(ljcn) integer, intent(inout) :: parent(n), porder(n) integer, intent(in) :: SizeOfBlocks(n) logical, intent(in) :: SizeOfBlocks_provided integer, intent(in) :: KEEP378, SIZE_SCHUR_EFF, PERM(n) integer, intent(out) :: cc(n) integer, intent(inout):: INFO(2) integer, intent(out) :: fst_desc(n), iporder(n), prev_p(n) integer, intent(out) :: prev_nbr(n), setpath(n) integer :: i, curr, fd, j, jidx, k integer(8) :: iidx8 integer :: f, ref, p_leaf, q, jj integer :: FIRSTinSchur, pi, pj logical :: SCHUR_ON do j=1, n iporder(porder(j)) = j end do SCHUR_ON = (SIZE_SCHUR_EFF.GT.0) FIRSTinSchur = N-SIZE_SCHUR_EFF+1 cc = 0 fst_desc=-1 do i=1, n curr = porder(i) fd = curr if(fst_desc(curr) .eq. -1) then if (SizeOfBlocks_provided) then cc(curr) = SizeOfBlocks(curr) else cc(curr) = 1 endif end if do if (fst_desc(curr) .gt. 0) exit fst_desc(curr) = fd if (parent(curr) .eq. 0) exit curr = parent(curr) end do end do do j=1, n setpath(j)=j end do prev_p = 0 prev_nbr = 0 do jidx=1, n j = abs(porder(jidx)) if(parent(j) .ne. 0) then if (KEEP378.eq.1) then if (cc(parent(j)) .lt. 0) then porder(iporder(parent(j)))= -parent(j) endif endif if (SizeOfBlocks_provided) then cc(parent(j)) = cc(parent(j)) - SizeOfBlocks(j) else cc(parent(j)) = cc(parent(j))-1 endif endif do iidx8=iptr(j), iptr(j+1)-1 i = jcn(iidx8) if (iporder(i).le.jidx) cycle if(prev_nbr(i) .eq. 0) then ref = 0 else ref = iporder(prev_nbr(i)) end if if(iporder(fst_desc(j)) .gt. ref) then if (KEEP378.eq.1) then porder(iporder(j))= -j endif if (SizeOfBlocks_provided) then cc(j) = cc(j) + SizeOfBlocks(i) else cc(j) = cc(j) + 1 endif p_leaf = prev_p(i) if (p_leaf .ne. 0) then q = setfind(setpath, p_leaf) if (SizeOfBlocks_provided) then cc(q) = cc(q) - SizeOfBlocks(i) else cc(q) = cc(q) - 1 endif end if prev_p(i) = j end if prev_nbr(i) = j end do if (parent(j).ne.0) setpath(j)=parent(j) end do do jj=1, n-1 j=abs(porder(jj)) if(parent(j) .ne. 0) cc(parent(j)) = cc(parent(j)) + cc(j) end do if (KEEP378.eq.1) then i=1 do while (i .lt. n) porder(i) = abs(porder(i)) pi = porder(i) if (SCHUR_ON) then if (PERM(pi).GE.FIRSTinSchur) THEN i= i+1 cycle endif endif j = i+1 pj= porder(j) if (SCHUR_ON) then if (PERM(abs(pj)).GE.FIRSTinSchur) THEN i= j + 1 cycle endif endif if (parent(pi).ne.0) then do while (pj.gt.0) j = j+1 if (parent(abs(porder(j-1))).eq.0) exit if (j.gt.n) exit pj = porder(j) if (SCHUR_ON) then if (PERM(abs(pj)).GE.FIRSTinSchur) exit endif end do endif parent(porder(i)) = parent(porder(j-1)) do k=i+1, j-1 parent(porder(k)) = -porder(i) cc(porder(k)) = 0 end do i = j end do porder(n) = abs(porder(n)) do i=1,n-1 f = abs(parent(i)) if (f.eq.0) cycle if (cc(f).eq.0) then parent(i) = parent(f) endif end do endif do i=1,n f = parent(i) if (parent(i).gt.0) then parent(i) = -parent(i) endif end do return contains function setfind(setpath, p_leaf) implicit none integer :: setpath(:), p_leaf, setfind integer :: q, c, tmp q=p_leaf do while (setpath(q) .ne.q) q = setpath(q) end do c = p_leaf do while (c .ne.q) tmp = setpath(c) setpath(c) = q c = tmp end do setfind = q return end function setfind END SUBROUTINE MUMPS_GINP94_COLCOUNTS SUBROUTINE MUMPS_GINP94_POSTPROCESS_SCHUR ( & N, PARENT, COLCOUNT, PERM, & LISTVAR_SCHUR, SIZE_SCHUR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR INTEGER, INTENT(IN) :: PERM(N), LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(INOUT) :: PARENT(N), COLCOUNT(N) INTEGER I, FIRSTinSchur, PrincipalVarSchur FIRSTinSchur = N-SIZE_SCHUR+1 PrincipalVarSchur = LISTVAR_SCHUR(1) DO I=1, N IF (I.EQ.PrincipalVarSchur) THEN IF ( PARENT(I) .NE. 0 ) THEN PARENT(I) = 0 ENDIF COLCOUNT(I) = SIZE_SCHUR ELSE IF (PERM(I).GE.FIRSTinSchur) THEN PARENT(I) = -PrincipalVarSchur COLCOUNT (I) = 0 ELSE IF (PARENT(I) .NE. 0) THEN IF (PERM(-PARENT(I)).GE.FIRSTinSchur) THEN PARENT(I) = -PrincipalVarSchur ENDIF ENDIF ENDDO RETURN END SUBROUTINE MUMPS_GINP94_POSTPROCESS_SCHUR MUMPS_5.8.1/src/cmumps_sol_es.F0000664000175000017500000010727015042446440016216 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_SOL_ES PRIVATE PUBLIC:: CMUMPS_CHAIN_PRUN_NODES PUBLIC:: CMUMPS_CHAIN_PRUN_NODES_STATS PUBLIC:: CMUMPS_INITIALIZE_RHS_BOUNDS PUBLIC:: CMUMPS_PROPAGATE_RHS_BOUNDS PUBLIC:: CMUMPS_TREE_PRUN_NODES PUBLIC:: CMUMPS_SOL_ES_INIT # if defined(STAT_ES_SOLVE) PUBLIC:: CMUMPS_SOL_ES_PRINT_STATS # endif PUBLIC:: CMUMPS_ES_GET_SUM_Nloc PUBLIC:: CMUMPS_ES_NODES_SIZE_AND_FILL INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK # if defined(STAT_ES_SOLVE) DOUBLE PRECISION :: nb_flops, & nb_sparse_flops, & total_efficiency INTEGER :: total_procs, total_blocks #endif INCLUDE 'mumps_headers.h' CONTAINS SUBROUTINE CMUMPS_SOL_ES_INIT(SIZE_OF_BLOCK_ARG, KEEP201) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP201 INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK_ARG IF (KEEP201 > 0) THEN SIZE_OF_BLOCK => SIZE_OF_BLOCK_ARG ELSE NULLIFY(SIZE_OF_BLOCK) ENDIF #if defined(STAT_ES_SOLVE) nb_flops=0.0d0 nb_sparse_flops=0.0d0 total_efficiency=0.0d0 total_procs=0 total_blocks=0 #endif RETURN END SUBROUTINE CMUMPS_SOL_ES_INIT SUBROUTINE CMUMPS_TREE_PRUN_NODES( & fill, & DAD, NE_STEPS, FRERE, KEEP28, & FILS, STEP, N, & nodes_RHS, nb_nodes_RHS, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N, KEEP28 INTEGER, INTENT(IN) :: DAD(KEEP28),NE_STEPS(KEEP28),FRERE(KEEP28) INTEGER, INTENT(IN) :: FILS(N), STEP(N) INTEGER, INTENT(IN) :: nodes_RHS(:), nb_nodes_RHS INTEGER :: nb_prun_nodes INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_List(nb_prun_nodes) INTEGER :: nb_prun_roots INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Roots(nb_prun_roots) INTEGER :: nb_prun_leaves INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Leaves(nb_prun_leaves) LOGICAL :: TO_PROCESS(KEEP28) INTEGER :: IN, I, ISTEP, TMP, TMPsave LOGICAL :: FILS_VISITED nb_prun_nodes = 0 nb_prun_leaves = 0 TO_PROCESS(:) = .FALSE. DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) TMPsave = TMP ISTEP = STEP(TMP) DO WHILE(.NOT.TO_PROCESS(ISTEP)) TO_PROCESS(ISTEP) = .TRUE. nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = TMP END IF IN = FILS(TMP) DO WHILE(IN.GT.0) IN = FILS(IN) END DO FILS_VISITED = .FALSE. IF (IN.LT.0) THEN FILS_VISITED = TO_PROCESS(STEP(-IN)) ENDIF IF ( IN.LT.0.and..NOT.FILS_VISITED) & THEN TMP = -IN ISTEP = STEP(TMP) ELSE IF (IN.EQ.0) THEN nb_prun_leaves = nb_prun_leaves + 1 IF (fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF ELSE TMP = -IN ISTEP = STEP(TMP) ENDIF DO WHILE (TMP.NE.TMPsave) TMP = abs(FRERE(ISTEP)) IF(TMP.NE.0) THEN ISTEP = STEP(TMP) ELSE exit END IF IF (.NOT.TO_PROCESS(ISTEP)) exit END DO END IF END DO END DO nb_prun_roots = 0 DO I=1,nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) IF(DAD(ISTEP).NE.0) THEN IF(.NOT.TO_PROCESS(STEP(DAD(ISTEP)))) THEN nb_prun_roots = nb_prun_roots + 1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF END IF ELSE nb_prun_roots = nb_prun_roots + 1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF END IF END DO RETURN END SUBROUTINE CMUMPS_TREE_PRUN_NODES SUBROUTINE CMUMPS_CHAIN_PRUN_NODES( & fill, & DAD, KEEP28, & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes,nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: KEEP28 INTEGER, INTENT(IN) :: DAD(KEEP28) INTEGER, INTENT(IN) :: nb_nodes_RHS INTEGER, INTENT(IN) :: nodes_RHS(max(nb_nodes_RHS,1)) INTEGER, INTENT(INOUT) :: nb_prun_nodes INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_List(nb_prun_nodes) INTEGER, INTENT(INOUT) :: nb_prun_roots INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Roots(nb_prun_roots) INTEGER, INTENT(INOUT) :: nb_prun_leaves INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Leaves(nb_prun_leaves) INTEGER, INTENT(OUT) :: Pruned_SONS(KEEP28) LOGICAL, INTENT(OUT) :: TO_PROCESS(KEEP28) INTEGER :: IN, I, ISTEP, TMP nb_prun_nodes = 0 nb_prun_roots = 0 TO_PROCESS(:) = .FALSE. Pruned_SONS(:) = -1 DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) TO_PROCESS(ISTEP) = .TRUE. IF (Pruned_SONS(ISTEP) .eq. -1) THEN Pruned_SONS(ISTEP) = 0 nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = nodes_RHS(I) END IF IN = nodes_RHS(I) IN = DAD(STEP(IN)) DO WHILE (IN.NE.0) TO_PROCESS(STEP(IN)) = .TRUE. IF (Pruned_SONS(STEP(IN)).eq.-1) THEN nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = IN END IF Pruned_SONS(STEP(IN)) = 1 TMP = IN IN = DAD(STEP(IN)) ELSE Pruned_SONS(STEP(IN)) = Pruned_SONS(STEP(IN)) + 1 GOTO 201 ENDIF ENDDO nb_prun_roots = nb_prun_roots +1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF ENDIF 201 CONTINUE ENDDO nb_prun_leaves = 0 DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) IF (Pruned_SONS(ISTEP).EQ.0) THEN nb_prun_leaves = nb_prun_leaves +1 IF(fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF END IF ENDDO RETURN END SUBROUTINE CMUMPS_CHAIN_PRUN_NODES SUBROUTINE CMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, K242, K243, & UNS_PERM_INV, SIZE_UNS_PERM_INV, K23, & RHS_BOUNDS, NSTEPS, & nb_sparse, MYID, & mode) IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, N, NSTEPS, K242, K243, K23 INTEGER, INTENT(IN) :: JBEG_RHS, SIZE_PERM_RHS, nb_sparse INTEGER, INTENT(IN) :: NBCOL, NZ_RHS, SIZE_UNS_PERM_INV INTEGER, INTENT(IN) :: STEP(N), PERM_RHS(SIZE_PERM_RHS) INTEGER, INTENT(IN) :: IRHS_PTR(NBCOL+1),IRHS_SPARSE(NZ_RHS) INTEGER, INTENT(IN) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, INTENT(INOUT):: RHS_BOUNDS(2*NSTEPS) INTEGER, INTENT(IN) :: mode INTEGER :: I, ICOL, JPTR, J, JAM1, node, bound RHS_BOUNDS = 0 ICOL = 0 DO I = 1, NBCOL IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE ICOL = ICOL + 1 bound = ICOL - mod(ICOL, nb_sparse) + 1 IF(mod(ICOL, nb_sparse).EQ.0) bound = bound - nb_sparse IF(mode.EQ.0) THEN IF ((K242.NE.0).OR.(K243.NE.0)) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 ENDIF node = abs(STEP(JAM1)) IF(RHS_BOUNDS(2*node - 1).EQ.0) THEN RHS_BOUNDS(2*node - 1) = bound RHS_BOUNDS(2*node) = bound + nb_sparse - 1 ELSE RHS_BOUNDS(2*node) = bound + nb_sparse - 1 END IF ELSE DO JPTR = IRHS_PTR(I), IRHS_PTR(I+1)-1 J = IRHS_SPARSE(JPTR) IF ( mode .EQ. 1 ) THEN IF (K23.NE.0) J = UNS_PERM_INV(J) ENDIF node = abs(STEP(J)) IF(RHS_BOUNDS(2*node - 1).EQ.0) THEN RHS_BOUNDS(2*node - 1) = bound RHS_BOUNDS(2*node) = bound + nb_sparse - 1 ELSE RHS_BOUNDS(2*node) = bound + nb_sparse - 1 END IF END DO END IF END DO RETURN END SUBROUTINE CMUMPS_INITIALIZE_RHS_BOUNDS SUBROUTINE CMUMPS_PROPAGATE_RHS_BOUNDS( & pruned_leaves, nb_pruned_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, NSTEPS, & MYID, COMM, KEEP485, #if defined(STAT_ES_SOLVE) & KEEP46, & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, #endif & IW, LIW, PTRIST, KIXSZ,OOC_FCT_LOC, PHASE, LDLT, K38) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' INTEGER, INTENT(IN) :: nb_pruned_leaves, N, NSTEPS INTEGER, INTENT(IN) :: STEP(N), DAD(NSTEPS), Pruned_SONS(NSTEPS) INTEGER, INTENT(IN) :: MYID, COMM, KEEP485 INTEGER, INTENT(IN) :: pruned_leaves(nb_pruned_leaves) INTEGER, INTENT(IN) :: LIW, IW(LIW), PTRIST(NSTEPS) INTEGER, INTENT(IN) :: KIXSZ, OOC_FCT_LOC, PHASE, LDLT, K38 # if defined(STAT_ES_SOLVE) INTEGER, INTENT(IN) :: KEEP46 INTEGER, INTENT(IN) :: SIZE_IPTR_WORKING, SIZE_WORKING, & IPTR_WORKING(SIZE_IPTR_WORKING), & WORKING(SIZE_WORKING) #endif INTEGER, INTENT(INOUT):: RHS_BOUNDS(2*NSTEPS) INTEGER :: I, node, father, size_pool, next_size_pool INTEGER :: IERR INTEGER, ALLOCATABLE, DIMENSION(:) :: POOL, NBSONS #if defined(STAT_ES_SOLVE) LOGICAL, ALLOCATABLE, DIMENSION(:) :: isleaf INTEGER :: J, NPROCS, proc, allocok LOGICAL :: found DOUBLE PRECISION :: avg_load, efficiency, max_load, effmax DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: proc_flops_buf DOUBLE PRECISION :: proc_block_flops, block_flops INTEGER :: SK38 INTEGER, PARAMETER :: MASTER = 0 #endif ALLOCATE(POOL(nb_pruned_leaves), & NBSONS(NSTEPS), & STAT=IERR) IF (IERR.NE.0) THEN WRITE(6,*)'Allocation problem in CMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() END IF size_pool = nb_pruned_leaves POOL = pruned_leaves NBSONS = Pruned_SONS # if defined(STAT_ES_SOLVE) NPROCS = SIZE_IPTR_WORKING-1 IF((MYID.EQ.MASTER).AND.(KEEP46.EQ.1)) THEN ALLOCATE(isleaf(NSTEPS), STAT=IERR) IF (IERR.NE.0) THEN WRITE(6,*)'Allocation problem in CMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() END IF isleaf = .FALSE. DO I=1,nb_pruned_leaves isleaf(abs(STEP(pruned_leaves(I)))) = .true. END DO proc = 0 DO I=1,NPROCS found = .FALSE. J = IPTR_WORKING(I) DO WHILE((J.LE.IPTR_WORKING(I+1)-1).AND.(.NOT.found)) IF (isleaf(WORKING(J)))THEN found = .TRUE. END IF J = J + 1 END DO IF(found) THEN proc = proc + 1 END IF END DO total_procs = total_procs + proc total_blocks = total_blocks + 1 DEALLOCATE(isleaf) END IF # endif DO WHILE (size_pool.ne.0) next_size_pool =0 DO I=1, size_pool node = STEP(POOL(I)) IF (DAD(node).NE.0) THEN father = STEP(DAD(node)) NBSONS(father) = NBSONS(father)-1 IF (RHS_BOUNDS(2*father-1).EQ.0) THEN RHS_BOUNDS(2*father-1) = RHS_BOUNDS(2*node-1) RHS_BOUNDS(2*father) = RHS_BOUNDS(2*node) ELSE RHS_BOUNDS(2*father-1) = min(RHS_BOUNDS(2*father-1), & RHS_BOUNDS(2*node-1)) RHS_BOUNDS(2*father) = max(RHS_BOUNDS(2*father), & RHS_BOUNDS(2*node)) END IF IF(NBSONS(father).EQ.0) THEN next_size_pool = next_size_pool+1 POOL(next_size_pool) = DAD(node) END IF END IF END DO size_pool = next_size_pool END DO DEALLOCATE(POOL, NBSONS) # if defined(STAT_ES_SOLVE) IF (KEEP46.EQ.1) THEN IF(MYID.EQ.MASTER) THEN block_flops = 0D0 END IF proc_block_flops = 0D0 IF (K38 .GT. 0) THEN SK38 = STEP(K38) ELSE SK38 = 0 END IF DO I=1,NSTEPS IF (RHS_BOUNDS(2*I).NE.0) THEN IF(PTRIST(I).GT.0) THEN proc_block_flops = proc_block_flops & + dble(2*(RHS_BOUNDS(2*I) - RHS_BOUNDS(2*I-1) +1)) & * dble(CMUMPS_LOCAL_FACTOR_SIZE(IW, LIW, & PTRIST(I)+KIXSZ, & PHASE,LDLT,I.EQ.SK38)) END IF END IF END DO IF(MYID.EQ.MASTER) THEN ALLOCATE(proc_flops_buf(SIZE_IPTR_WORKING-1),stat=allocok) IF(allocok.GT.0) THEN WRITE(6,*)'Allocation problem of proc_flops_buf' & ,' in CMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() ENDIF proc_flops_buf=0.0d0 ELSE ALLOCATE(proc_flops_buf(1),stat=allocok) IF(allocok.GT.0) THEN WRITE(6,*)'Allocation problem of proc_flops_buf' & ,' in CMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() ENDIF proc_flops_buf=0.0d0 END IF CALL MPI_GATHER(proc_block_flops, 1, MPI_DOUBLE_PRECISION, & proc_flops_buf, 1, MPI_DOUBLE_PRECISION, & 0, COMM, IERR) CALL MPI_REDUCE(proc_block_flops, block_flops, 1, & MPI_DOUBLE_PRECISION, MPI_SUM, 0, COMM, IERR) IF(MYID.EQ.MASTER) THEN nb_sparse_flops = nb_sparse_flops+block_flops avg_load = sum(proc_flops_buf)/dble(NPROCS) max_load = maxval(proc_flops_buf) efficiency = 0D0 effmax = 0D0 DO I=1,NPROCS efficiency= efficiency + (proc_flops_buf(I)-avg_load)**2 IF (proc_flops_buf(I)-avg_load.GT.0.0D0) THEN effmax = effmax + (max_load-avg_load)**2 ELSE IF (proc_flops_buf(I)-avg_load.LT.0.0D0) THEN effmax = effmax + avg_load**2 END IF END DO efficiency = sqrt(efficiency/dble(NPROCS)) effmax = sqrt(effmax/dble(NPROCS)) IF(effmax.ne.0.0d0) efficiency = efficiency / effmax efficiency = 1.0d0 - efficiency efficiency = efficiency * block_flops total_efficiency = total_efficiency + efficiency DEALLOCATE(proc_flops_buf) ELSE DEALLOCATE(proc_flops_buf) END IF END IF #endif RETURN END SUBROUTINE CMUMPS_PROPAGATE_RHS_BOUNDS INTEGER(8) FUNCTION CMUMPS_LOCAL_FACTOR_SIZE(IW,LIW,PTR, & PHASE, LDLT, IS_ROOT) INTEGER, INTENT(IN) :: LIW, PTR, PHASE, LDLT INTEGER, INTENT(IN) :: IW(LIW) LOGICAL, INTENT(IN) :: IS_ROOT INTEGER(8) :: NCB, NELIM, LIELL, NPIV, NROW NCB = int(IW(PTR),8) NELIM = int(IW(PTR+1),8) NROW = int(IW(PTR+2),8) NPIV = int(IW(PTR+3),8) LIELL = NPIV + NCB IF (IS_ROOT) THEN CMUMPS_LOCAL_FACTOR_SIZE = int(IW(PTR+1),8) * & int(IW(PTR+2),8) / 2_8 RETURN ENDIF IF (NCB.GE.0_8) THEN IF (PHASE.EQ.0 & .OR. (PHASE.EQ.1.AND.LDLT.NE.0) & ) THEN CMUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV-1_8)/2_8 + (NROW-NPIV)*NPIV ELSE CMUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV-1_8)/2_8 + (LIELL-NPIV)*NPIV ENDIF ELSE CMUMPS_LOCAL_FACTOR_SIZE = & -NCB*NELIM END IF RETURN END FUNCTION CMUMPS_LOCAL_FACTOR_SIZE SUBROUTINE CMUMPS_CHAIN_PRUN_NODES_STATS & (MYID, N, KEEP28, KEEP201, KEEP485, FR_FACT, & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_LOC # if defined(STAT_ES_SOLVE) & , NRHS, COMM, IW, LIW, PTRIST, KIXSZ, PHASE, & LDLT, K38 #endif & ) IMPLICIT NONE INTEGER, intent(in) :: KEEP28, KEEP201, OOC_FCT_TYPE_LOC, N, & KEEP485 INTEGER(8), intent(in) :: FR_FACT INTEGER, intent(in) :: nb_prun_nodes, MYID INTEGER, intent(in) :: Pruned_List(nb_prun_nodes) INTEGER, intent(in) :: STEP(N) #if defined(STAT_ES_SOLVE) INTEGER, INTENT(IN):: LIW, COMM, NRHS, LDLT, K38 INTEGER, INTENT(IN):: IW(LIW), PTRIST(KEEP28), KIXSZ, PHASE DOUBLE PRECISION :: proc_block_flops, block_flops INTEGER(8) :: Pruned_Size_ic INTEGER :: IERR INTEGER :: SK38 #endif INCLUDE 'mpif.h' INTEGER I, ISTEP INTEGER(8) :: Pruned_Size #if defined(STAT_ES_SOLVE) Pruned_Size_ic = 0_8 #endif Pruned_Size = 0_8 #if defined(STAT_ES_SOLVE) IF (K38 .GT. 0) THEN SK38 = STEP(K38) ELSE SK38 = 0 END IF #endif 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 #if defined(STAT_ES_SOLVE) IF (PTRIST(ISTEP) .GT. 0) THEN Pruned_Size_ic = Pruned_Size_ic + & CMUMPS_LOCAL_FACTOR_SIZE(IW, LIW, & PTRIST(ISTEP)+KIXSZ, & PHASE, LDLT, & ISTEP.EQ.SK38) ENDIF # endif ENDDO #if defined(STAT_ES_SOLVE) proc_block_flops = dble(2_8*Pruned_Size_ic)*dble(NRHS) CALL MPI_REDUCE(proc_block_flops, block_flops, 1, & MPI_DOUBLE_PRECISION, MPI_SUM, 0, COMM, IERR) IF(MYID.EQ.0) nb_flops = nb_flops + block_flops #endif RETURN END SUBROUTINE CMUMPS_CHAIN_PRUN_NODES_STATS #if defined(STAT_ES_SOLVE) SUBROUTINE CMUMPS_SOL_ES_PRINT_STATS( & K212, K235, K237, K485, K497, NZLU8, & NRHS, ICNTL27, N, K50, DKEEPS, RINFOGS, MPG) IMPLICIT NONE INTEGER, intent(in) :: K212, K235, K237, K485, K497, & NRHS, MPG, ICNTL27, N, K50 INTEGER(8), intent(in) :: NZLU8 REAL, intent(out) :: DKEEPS(5), RINFOGS(5) LOGICAL :: AM1, ES_FWD, ES_BWD, DO_NBSPARSE IF (MPG.LE.0) RETURN AM1 = (K237 .NE. 0) ES_FWD = (K235 .NE. 0) .AND. (.NOT. AM1) ES_BWD = (K212 .NE. 0) .AND. (.NOT. AM1) DO_NBSPARSE = (K497.NE.0).AND.(NRHS.GT.1).AND.(ICNTL27.GT.1) IF (AM1) & WRITE(MPG,'(/A)') ' ** FLOPS SUMMARY during SOLVE AM1 ** ' IF ((ES_FWD).AND. (.NOT.ES_BWD)) & WRITE(MPG,'(/A,A)') ' ** FLOPS SUMMARY during fwd step', & ' (exploit RHS sparsity) ** ' IF ((.NOT.ES_FWD).AND. (ES_BWD)) & WRITE(MPG,'(/A,A)') ' ** FLOPS SUMMARY during bwd step', & ' (selected entries in solution) ** ' IF ((ES_FWD).AND. (ES_BWD)) & WRITE(MPG,'(/A,/A)') & ' ** FLOPS SUMMARY during SOLVE (fwd+bwd steps)', & ' (sparse RHS and selected entries in solution) **' IF ( & (ES_FWD) .AND. (.NOT.ES_BWD) & .OR. & (.NOT.ES_FWD) .AND. (ES_BWD) & ) THEN IF (K50.NE.0) THEN DKEEPS(1)=(real(NZLU8)-real(N))*real(2*NRHS) ELSE DKEEPS(1)=(real(NZLU8)-real(N))*real(NRHS) ENDIF ELSE IF ((ES_FWD).AND.(ES_BWD)) THEN IF (K50.NE.0) THEN DKEEPS(1) = (real(NZLU8)-real(N))*real(4*NRHS) ELSE DKEEPS(1)=(real(NZLU8)-real(N))*real(2*NRHS) ENDIF ENDIF RINFOGS(1) = DKEEPS(1) IF (.NOT.AM1) THEN WRITE(MPG,'(A,F25.1)') & ' RINFOG(24) FLOPS with dense full rank format =', DKEEPS(1) ENDIF DKEEPS(2)=real(nb_flops) IF (DO_NBSPARSE) DKEEPS(4)=real(nb_sparse_flops) IF (DO_NBSPARSE) THEN RINFOGS(2)= DKEEPS(4) ELSE RINFOGS(2)= DKEEPS(2) ENDIF WRITE(MPG,'(A,F25.1)') & ' RINFOG(25) FLOPS with exploit sparsity (ES) =', RINFOGS(2) RETURN END SUBROUTINE CMUMPS_SOL_ES_PRINT_STATS #endif SUBROUTINE CMUMPS_ES_GET_SUM_Nloc ( & N, Nloc_ITAB, ITAB_loc, COMM, & SUM_idNloc_8 ) IMPLICIT NONE INTEGER, INTENT(IN) :: N #if defined(MUMPS_NOF2003) INTEGER, POINTER :: ITAB_loc (:) #else INTEGER, INTENT( IN ), POINTER :: ITAB_loc (:) #endif INTEGER, INTENT(IN) :: Nloc_ITAB INTEGER, INTENT(IN) :: COMM INTEGER(8) :: SUM_idNloc_8 INCLUDE 'mpif.h' INTEGER I, II, IERR_MPI INTEGER(8) :: idNloc_8 idNloc_8 = 0_8 DO I= 1, Nloc_ITAB II = ITAB_loc(I) IF (II.GE.1 .and. II.LE.N) & idNloc_8 = idNloc_8 + 1_8 ENDDO CALL MPI_ALLREDUCE (idNloc_8, SUM_idNloc_8, 1, & MPI_INTEGER8, & MPI_SUM, COMM, IERR_MPI ) RETURN END SUBROUTINE CMUMPS_ES_GET_SUM_Nloc SUBROUTINE CMUMPS_ES_NODES_SIZE_AND_FILL ( & fill, & N, NSTEPS, KEEP, STEP, Step2node, & ITAB_loc, Nloc_ITAB, & MYID, COMM, & Pruned_Sons, Lnodes_ITAB #if defined(AVOID_MPI_IN_PLACE) & , TMP_INT_ARRAY #endif & , nodes_ITAB & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N, NSTEPS, KEEP(500) INTEGER, INTENT(IN) :: Nloc_ITAB INTEGER, INTENT(IN) :: STEP(N), Step2node(NSTEPS), & ITAB_loc(max(1,Nloc_ITAB)) INTEGER, INTENT(IN) :: MYID, COMM #if defined(AVOID_MPI_IN_PLACE) INTEGER :: TMP_INT_ARRAY(NSTEPS) #endif INTEGER, INTENT(INOUT) :: Pruned_Sons(NSTEPS), Lnodes_ITAB INTEGER, OPTIONAL, INTENT(OUT) :: nodes_ITAB(max(1,Lnodes_ITAB)) INCLUDE 'mpif.h' INTEGER I, II, ISTEP, IERR_MPI, Lnodes_ITAB_loc, INODE_PRINC IF (.NOT.fill) THEN Pruned_SONS = 0 DO I= 1, Nloc_ITAB II = ITAB_loc(I) IF (II.GE.1 .and. II.LE.N) THEN ISTEP = abs(STEP(II)) IF ( Pruned_SONS(ISTEP) .eq. 0 ) THEN Pruned_SONS(ISTEP) = 1 ENDIF ENDIF ENDDO #if defined(AVOID_MPI_IN_PLACE) TMP_INT_ARRAY = Pruned_Sons #endif CALL MPI_ALLREDUCE( #if defined(AVOID_MPI_IN_PLACE) & TMP_INT_ARRAY, #else & MPI_IN_PLACE, #endif & Pruned_Sons, NSTEPS, & MPI_INTEGER, MPI_SUM, COMM, IERR_MPI) Lnodes_ITAB = 0 DO ISTEP=1,NSTEPS if (Pruned_SONS(ISTEP) .NE.0) Lnodes_ITAB=Lnodes_ITAB+1 ENDDO ELSE IF (Lnodes_ITAB.GT.0) THEN Lnodes_ITAB_loc = 0 DO ISTEP=1,NSTEPS if (Pruned_SONS(ISTEP) .GT. 0) then Lnodes_ITAB_loc=Lnodes_ITAB_loc+1 INODE_PRINC = Step2node( ISTEP ) nodes_ITAB(Lnodes_ITAB_loc) = INODE_PRINC endif ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_ES_NODES_SIZE_AND_FILL END MODULE CMUMPS_SOL_ES SUBROUTINE CMUMPS_PERMUTE_RHS_GS & (LP, LPOK, PROKG, MPG, PERM_STRAT, & SYM_PERM, N, NRHS, & IRHS_PTR, SIZE_IRHS_PTR, & IRHS_SPARSE, NZRHS, & PERM_RHS, IERR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: LP, MPG, PERM_STRAT, N, NRHS, & SIZE_IRHS_PTR, & NZRHS LOGICAL, INTENT(IN) :: LPOK, PROKG INTEGER, INTENT(IN) :: SYM_PERM(N) INTEGER, INTENT(IN) :: IRHS_PTR(SIZE_IRHS_PTR) INTEGER, INTENT(IN) :: IRHS_SPARSE(NZRHS) INTEGER, INTENT(OUT) :: PERM_RHS(NRHS) INTEGER, INTENT(OUT) :: IERR INTEGER :: I,J,K, POSINPERMRHS, JJ, & KPOS INTEGER, ALLOCATABLE :: ROW_REFINDEX(:) IERR = 0 IF ((PERM_STRAT.NE.-1).AND.(PERM_STRAT.NE.1)) THEN IERR=-1 IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -1 in ", & " CMUMPS_PERMUTE_RHS_GS, PERM_STRAT =", PERM_STRAT, & " is out of range " RETURN ENDIF IF (PERM_STRAT.EQ.-1) THEN DO I=1,NRHS PERM_RHS(I) = I END DO GOTO 490 ENDIF ALLOCATE(ROW_REFINDEX(NRHS), STAT=IERR) IF (IERR.GT.0) THEN IERR=-1 IF (LPOK) THEN WRITE(LP,*) " ERROR -2 : ", & " ALLOCATE IN CMUMPS_PERMUTE_RHS_GS OF SIZE :", & NRHS ENDIF RETURN ENDIF DO I=1,NRHS IF (IRHS_PTR(I+1)-IRHS_PTR(I).LE.0) THEN IERR = 1 IF (I.EQ.1) THEN ROW_REFINDEX(I) = IRHS_SPARSE(IRHS_PTR(I)) ELSE ROW_REFINDEX(I) = ROW_REFINDEX(I-1) ENDIF ELSE ROW_REFINDEX(I) = IRHS_SPARSE(IRHS_PTR(I)) ENDIF END DO POSINPERMRHS = 0 DO I=1,NRHS KPOS = N+1 JJ = 0 DO J=1,NRHS K = ROW_REFINDEX(J) IF (K.LE.0) CYCLE IF (SYM_PERM(K).LT.KPOS) THEN KPOS = SYM_PERM(K) JJ = J ENDIF END DO IF (JJ.EQ.0) THEN IERR = -3 IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -3 in ", & " CMUMPS_PERMUTE_RHS_GS " GOTO 500 ENDIF POSINPERMRHS = POSINPERMRHS + 1 PERM_RHS(POSINPERMRHS) = JJ ROW_REFINDEX(JJ) = -ROW_REFINDEX(JJ) END DO IF (POSINPERMRHS.NE.NRHS) THEN IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -4 in ", & " CMUMPS_PERMUTE_RHS_GS ", maxval(ROW_REFINDEX) IERR = -4 GOTO 500 ENDIF 490 CONTINUE 500 CONTINUE IF (allocated(ROW_REFINDEX)) DEALLOCATE(ROW_REFINDEX) END SUBROUTINE CMUMPS_PERMUTE_RHS_GS SUBROUTINE CMUMPS_PERMUTE_RHS_AM1 & (PERM_STRAT, SYM_PERM, & IRHS_PTR, NHRS, & PERM_RHS, SIZEPERM, IERR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: PERM_STRAT, NHRS, SIZEPERM INTEGER, INTENT(IN) :: SYM_PERM(SIZEPERM) INTEGER, INTENT(IN) :: IRHS_PTR(NHRS) INTEGER, INTENT(OUT):: IERR INTEGER, INTENT(OUT):: PERM_RHS(SIZEPERM) DOUBLE PRECISION :: RAND_NUM INTEGER I, J, STRAT IERR = 0 STRAT = PERM_STRAT IF( (STRAT.NE.-3).AND. & (STRAT.NE.-2).AND. & (STRAT.NE.-1).AND. & (STRAT.NE. 1).AND. & (STRAT.NE. 2).AND. & (STRAT.NE. 6) ) THEN WRITE(*,*)"Warning: incorrect value for the RHS permutation; ", & "defaulting to post-order" STRAT = 1 END IF IF (STRAT .EQ. -3) THEN PERM_RHS(1:SIZEPERM)=0 DO I=1, SIZEPERM CALL random_number(RAND_NUM) RAND_NUM = RAND_NUM*dble(SIZEPERM) J = ceiling(RAND_NUM) DO WHILE (PERM_RHS(J).NE.0) CALL random_number(RAND_NUM) RAND_NUM = RAND_NUM*dble(SIZEPERM) J = ceiling(RAND_NUM) ENDDO PERM_RHS(J)=I ENDDO ELSEIF (STRAT .EQ. -2) THEN DO I=1, SIZEPERM PERM_RHS(SIZEPERM -I +1) = I ENDDO ELSEIF (STRAT .EQ. -1) THEN DO I=1, SIZEPERM PERM_RHS(I) = I ENDDO ELSEIF (STRAT .EQ. 1) THEN DO I=1, SIZEPERM PERM_RHS(SYM_PERM(I)) = I ENDDO ELSEIF (STRAT .EQ. 2) THEN DO I=1, SIZEPERM PERM_RHS(SIZEPERM-SYM_PERM(I)+1) = I ENDDO ENDIF END SUBROUTINE CMUMPS_PERMUTE_RHS_AM1 SUBROUTINE CMUMPS_INTERLEAVE_RHS_AM1( & PERM_RHS, SIZE_PERM, & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, & IRHS_PTR, & STEP, SYM_PERM, N, NBRHS, & PROCNODE, NSTEPS, SLAVEF, KEEP199, & behaviour_L0, reorder, n_select, PROKG, MPG & ) IMPLICIT NONE INTEGER, INTENT(IN) :: SIZE_PERM, & SIZE_IPTR_WORKING, & IPTR_WORKING(SIZE_IPTR_WORKING), & SIZE_WORKING, & WORKING(SIZE_WORKING), & N, & IRHS_PTR(N+1), & STEP(N), & SYM_PERM(N), & NBRHS, & NSTEPS, & PROCNODE(NSTEPS), & SLAVEF, KEEP199, & n_select, MPG LOGICAL, INTENT(IN) :: behaviour_L0, & reorder, PROKG INTEGER, INTENT(INOUT) :: PERM_RHS(SIZE_PERM) INTEGER :: I, J, K, IVAR, IBLOCK, & entry, & node, & SIZE_PERM_WORKING, & NB_NON_EMPTY, & to_be_found, & posintmprhs, & selected, & local_selected, & current_proc, & NPROCS, & n_pass, & pass, & nblocks, & n_select_loc, & IERR INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_RHS, & PTR_PROCS, & IPTR_PERM_WORKING, & PERM_WORKING, & MYTYPENODE INTEGER, ALLOCATABLE, DIMENSION(:) :: & PERM_PO, & ISTEP2BLOCK, & NEXTINBLOCK LOGICAL, ALLOCATABLE, DIMENSION(:) :: USED LOGICAL :: allow_above_L0 INTEGER, EXTERNAL :: MUMPS_TYPENODE_ROUGH NPROCS = SIZE_IPTR_WORKING - 1 ALLOCATE(TMP_RHS(SIZE_PERM), & PTR_PROCS(NPROCS), & USED(SIZE_PERM), & IPTR_PERM_WORKING(NPROCS+1), & MYTYPENODE(NSTEPS), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in CMUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF DO I=1, NSTEPS MYTYPENODE(I) = MUMPS_TYPENODE_ROUGH( PROCNODE(I), KEEP199 ) ENDDO NB_NON_EMPTY = 0 DO I=1,SIZE_PERM IF(IRHS_PTR(I+1)-IRHS_PTR(I).NE.0) THEN NB_NON_EMPTY = NB_NON_EMPTY + 1 END IF END DO K = 0 IPTR_PERM_WORKING(1)=1 DO I=1,NPROCS USED = .FALSE. DO J=IPTR_WORKING(I),IPTR_WORKING(I+1)-1 USED(WORKING(J)) = .TRUE. END DO DO J=1,N IF (USED(abs(STEP(PERM_RHS(J)))).AND. & ((IRHS_PTR(PERM_RHS(J)+1)-IRHS_PTR(PERM_RHS(J))).NE.0)) & THEN K = K + 1 END IF END DO IPTR_PERM_WORKING(I+1) = K+1 END DO SIZE_PERM_WORKING = K ALLOCATE(PERM_WORKING(SIZE_PERM_WORKING), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in CMUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF K = 0 DO I=1,NPROCS USED = .FALSE. DO J=IPTR_WORKING(I),IPTR_WORKING(I+1)-1 USED(WORKING(J)) = .TRUE. END DO DO J=1,N IF (USED(abs(STEP(PERM_RHS(J)))).AND. & ((IRHS_PTR(PERM_RHS(J)+1)-IRHS_PTR(PERM_RHS(J))).NE.0)) & THEN K = K + 1 PERM_WORKING(K) = PERM_RHS(J) END IF END DO END DO IF(behaviour_L0) THEN n_pass = 2 allow_above_L0 = .false. to_be_found = 0 DO I=1,SIZE_PERM IF((MYTYPENODE(abs(STEP(I))).LE.1).AND. & (IRHS_PTR(I+1)-IRHS_PTR(I).NE.0)) & THEN to_be_found = to_be_found + 1 END IF END DO ELSE n_pass = 1 allow_above_L0 = .true. to_be_found = NB_NON_EMPTY END IF PTR_PROCS(1:NPROCS) = IPTR_PERM_WORKING(1:NPROCS) USED = .FALSE. current_proc = 1 n_select_loc = n_select IF (n_select_loc.LE.0) THEN n_select_loc = 1 ENDIF posintmprhs = 0 DO pass=1,n_pass selected = 0 DO WHILE(selected.LT.to_be_found) local_selected = 0 DO WHILE(local_selected.LT.n_select_loc) IF(PTR_PROCS(current_proc).EQ. & IPTR_PERM_WORKING(current_proc+1)) & THEN EXIT ELSE entry = PERM_WORKING(PTR_PROCS(current_proc)) node = abs(STEP(entry)) IF(.NOT.USED(entry)) THEN IF(allow_above_L0.OR.(MYTYPENODE(node).LE.1)) THEN USED(entry) = .TRUE. selected = selected + 1 local_selected = local_selected + 1 posintmprhs = posintmprhs + 1 TMP_RHS(posintmprhs) = entry IF(selected.EQ.to_be_found) EXIT END IF END IF PTR_PROCS(current_proc) = PTR_PROCS(current_proc) + 1 END IF END DO current_proc = mod(current_proc,NPROCS)+1 END DO to_be_found = NB_NON_EMPTY - to_be_found allow_above_L0 = .true. PTR_PROCS(1:NPROCS) = IPTR_PERM_WORKING(1:NPROCS) END DO DO I=1,SIZE_PERM IF(IRHS_PTR(PERM_RHS(I)+1)-IRHS_PTR(PERM_RHS(I)).EQ.0) THEN posintmprhs = posintmprhs+1 TMP_RHS(posintmprhs) = PERM_RHS(I) IF(posintmprhs.EQ.SIZE_PERM) EXIT END IF END DO DEALLOCATE(PTR_PROCS, USED, & IPTR_PERM_WORKING, & PERM_WORKING, MYTYPENODE) IF(reorder) THEN nblocks = (N+NBRHS-1)/NBRHS ALLOCATE(PERM_PO(N), ISTEP2BLOCK(N), NEXTINBLOCK(nblocks), & stat=IERR) IF(IERR.GT.0) THEN IF (PROKG ) WRITE(MPG,*) & 'Warning: reorder not done in CMUMPS_INTERLEAVE_RHS_AM1' PERM_RHS = TMP_RHS GOTO 500 ENDIF DO IVAR = 1, N K = SYM_PERM( IVAR ) PERM_PO( K ) = IVAR END DO DO I = 1, N IBLOCK = 1 + ( I - 1 ) / NBRHS IVAR = TMP_RHS( I ) K = SYM_PERM( IVAR ) ISTEP2BLOCK( K ) = IBLOCK END DO DO IBLOCK = 1, NBLOCKS NEXTINBLOCK(IBLOCK) = 1 + (IBLOCK-1)*NBRHS ENDDO DO K = 1, N IBLOCK = ISTEP2BLOCK(K) IVAR = PERM_PO(K) PERM_RHS(NEXTINBLOCK(IBLOCK)) = IVAR NEXTINBLOCK(IBLOCK) = NEXTINBLOCK(IBLOCK) + 1 ENDDO ELSE PERM_RHS = TMP_RHS END IF 500 CONTINUE DEALLOCATE(TMP_RHS) IF (allocated(PERM_PO )) DEALLOCATE(PERM_PO ) IF (allocated(ISTEP2BLOCK)) DEALLOCATE(ISTEP2BLOCK) IF (allocated(NEXTINBLOCK)) DEALLOCATE(NEXTINBLOCK) RETURN END SUBROUTINE CMUMPS_INTERLEAVE_RHS_AM1 MUMPS_5.8.1/src/sbcast_int.F0000664000175000017500000000314015042446436015473 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_MCAST2(DATA, LDATA, MPITYPE, ROOT, COMMW, TAG, &SLAVEF, KEEP) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER LDATA, ROOT, COMMW, TAG, MPITYPE, SLAVEF INTEGER DEST INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER DATA(LDATA) DO 10 DEST = 0, SLAVEF - 1 IF (DEST .NE. ROOT) THEN IF ( LDATA .EQ. 1 .and. MPITYPE .EQ. MPI_INTEGER ) THEN CALL MUMPS_BUF_SEND_1INT( DATA(1), DEST, TAG, & COMMW, KEEP, IERR ) ELSE WRITE(*,*) 'Error : bad argument to SMUMPS_MCAST2' CALL MUMPS_ABORT() END IF ENDIF 10 CONTINUE RETURN END SUBROUTINE SMUMPS_MCAST2 SUBROUTINE SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) INTEGER MYID, SLAVEF, COMM INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY (1) DUMMY(1) = -98765 CALL SMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERREUR, SLAVEF, KEEP ) RETURN END SUBROUTINE SMUMPS_BDC_ERROR MUMPS_5.8.1/src/mumps_metis.c0000664000175000017500000001656715042446422015755 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include /* For NULL constant (stddef.h) and debug printings */ #include "mumps_metis.h" #if defined(parmetis) || defined(parmetis3) /*PARMETIS*/ #if defined(parmetis3) /* Provide prototype by hand. This is because we are not sure * at compilation/preprocessing time whether we use a 32-bit * or a 64-bit metis */ void ParMETIS_V3_NodeND(MUMPS_INT *first, MUMPS_INT *vertloctab, MUMPS_INT *edgeloctab, MUMPS_INT *numflag, MUMPS_INT *options, MUMPS_INT *order, MUMPS_INT *sizes, MPI_Comm *Ccomm); #else #include "metis.h" #include "parmetis.h" /* Prototypes from parmetis.h will be used */ #endif void MUMPS_CALL MUMPS_PARMETIS(MUMPS_INT *first, MUMPS_INT *vertloctab, MUMPS_INT *edgeloctab, MUMPS_INT *numflag, MUMPS_INT *options, MUMPS_INT *order, MUMPS_INT *sizes, MUMPS_INT *comm, MUMPS_INT *ierr) { /* FIXME: ANA_BLK, to provide weights one should use ParMETIS_V32_NodeND and not ParMETIS_V3_NodeND which is a wrapper to ParMETIS_V32_NodeND */ MPI_Comm int_comm; int iierr; int_comm = MPI_Comm_f2c(*comm); #if defined(parmetis3) ParMETIS_V3_NodeND(first, vertloctab, edgeloctab, numflag, options, order, sizes, &int_comm); #elif defined(parmetis) # if (IDXTYPEWIDTH == 32) *ierr=0; iierr=ParMETIS_V3_NodeND(first, vertloctab, edgeloctab, numflag, options, order, sizes, &int_comm); if(iierr != METIS_OK) *ierr=1; # else /* SHOULD NEVER BE CALLED */ printf("** Error: ParMETIS version >= 4, IDXTYPE WIDTH =64, but MUMPS_PARMETIS was called\n"); *ierr=1; # endif #endif return; } void MUMPS_CALL MUMPS_PARMETIS_VWGT(MUMPS_INT *first, MUMPS_INT *vertloctab, MUMPS_INT *edgeloctab, MUMPS_INT *numflag, MUMPS_INT *options, MUMPS_INT *order, MUMPS_INT *sizes, MUMPS_INT *comm, MUMPS_INT *vwgt, MUMPS_INT *ierr) { /* with weights one should use ParMETIS_V32_NodeND and not ParMETIS_V3_NodeND which is a wrapper to ParMETIS_V32_NodeND */ MPI_Comm int_comm; int iierr; int_comm = MPI_Comm_f2c(*comm); #if defined(parmetis3) /* vwgt not used */ ParMETIS_V3_NodeND(first, vertloctab, edgeloctab, numflag, options, order, sizes, &int_comm); #elif defined(parmetis) # if (IDXTYPEWIDTH == 32) *ierr=0; /* int ParMETIS V32 NodeND ( idx t *vtxdist, idx t *xadj, idx t *adjncy, idx t *vwgt, idx t *numflag, idx t *mtype, idx t *rtype, idx t *p nseps, int *s nseps, real t *ubfrac, idx t *seed, idx t *dbglvl, idx t *order, idx t *sizes, MPI Comm *comm ) */ iierr=ParMETIS_V32_NodeND(first, vertloctab, edgeloctab, vwgt, numflag, NULL, NULL, NULL, NULL, NULL, NULL, NULL, order, sizes, &int_comm); if(iierr != METIS_OK) *ierr=1; # else /* SHOULD NEVER BE CALLED */ printf("** Error: ParMETIS version >= 4, IDXTYPE WIDTH =64, but MUMPS_PARMETIS_VWGT was called\n"); *ierr=1; # endif #endif return; } #endif #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) #if defined(metis4) || defined(parmetis3) /* parmetis3 comes with metis4 */ /* Provide prototype by hand. This is because we are not sure * at compilation/preprocessing time whether we use a 32-bit * or a 64-bit metis */ void METIS_PartGraphKway(int *, MUMPS_INT *, MUMPS_INT *, MUMPS_INT *, MUMPS_INT *, int *, int *, int *, int *, int *, MUMPS_INT *); #else /* Prototype properly defined in metis.h * One can rely on IDXTYPEWIDTH to know at compilation/preprocessing * time whether we use a 32-bit or a 64-bit metis */ #include "metis.h" #endif /* Interface for metis k-way partitioning with standard ints */ void MUMPS_CALL MUMPS_METIS_KWAY(MUMPS_INT *n, MUMPS_INT *iptr, MUMPS_INT *jcn, MUMPS_INT *k, MUMPS_INT *part) /* n -- the size of the graph to be partitioned iptr -- pointer to the beginning of each node's adjacency list jcn -- jcn[iptr[i]:iptr[i+1]-1] contains the list of neighbors of node i k -- the number of parts part -- part[i] is the part node i belongs to */ { #if defined(metis4) || defined(parmetis3) MUMPS_INT numflag, edgecut, wgtflag, options[8]; options[0] = 0; /* unweighted partitioning */ wgtflag = 0; /* Use 1-based fortran numbering */ numflag = 1; /* void METIS_PartGraphKway(int *, idxtype *, idxtype *, idxtype *, idxtype *, int *, int *, int *, int *, int *, idxtype *); */ METIS_PartGraphKway(n, iptr, jcn, NULL, NULL, &wgtflag, &numflag, k, options, &edgecut, part); #else /* METIS >= 5 */ int ierr; # if (IDXTYPEWIDTH == 32) MUMPS_INT ncon, edgecut, options[METIS_NOPTIONS]; ierr=METIS_SetDefaultOptions(options); /* Use 1-based fortran numbering */ options[METIS_OPTION_NUMBERING] = 1; ncon = 1; ierr = METIS_PartGraphKway(n, &ncon, iptr, jcn, NULL, NULL, NULL, k, NULL, NULL, options, &edgecut, part); # else /* SHOULD NEVER BE REACHED */ printf("** Error: METIS version >= 4, IDXTYPE WIDTH !=32, but MUMPS_METIS_KWAY was called\n"); ierr=1; # endif #endif return; } /* Interface for metis k-way partitioning with standard ints and weights on vertices*/ void MUMPS_CALL MUMPS_METIS_KWAY_AB(MUMPS_INT *n, MUMPS_INT *iptr, MUMPS_INT *jcn, MUMPS_INT *k, MUMPS_INT *part, MUMPS_INT *vwgt) /* n -- the size of the graph to be partitioned iptr -- pointer to the beginning of each node's adjacency list jcn -- jcn[iptr[i]:iptr[i+1]-1] contains the list of neighbors of node i k -- the number of parts part -- part[i] is the part node i belongs to vwgt -- weights of the vertices */ { #if defined(metis4) || defined(parmetis3) MUMPS_INT numflag, edgecut, wgtflag, options[8]; options[0] = 0; /* unweighted partitioning */ wgtflag = 0; /* Use 1-based fortran numbering */ numflag = 1; /* void METIS_PartGraphKway(int *, idxtype *, idxtype *, idxtype *, idxtype *, int *, int *, int *, int *, int *, idxtype *); */ METIS_PartGraphKway(n, iptr, jcn, vwgt, NULL, &wgtflag, &numflag, k, options, &edgecut, part); #else /* METIS >= 5 */ int ierr; # if (IDXTYPEWIDTH == 32) MUMPS_INT ncon, edgecut, options[METIS_NOPTIONS]; ierr=METIS_SetDefaultOptions(options); /* Use 1-based fortran numbering */ options[METIS_OPTION_NUMBERING] = 1; ncon = 1; ierr = METIS_PartGraphKway(n, &ncon, iptr, jcn, vwgt, NULL, NULL, k, NULL, NULL, options, &edgecut, part); # else /* SHOULD NEVER BE REACHED */ printf("** Error: METIS version >= 4, IDXTYPE WIDTH !=32, but MUMPS_METIS_KWAY_AB was called\n"); ierr=1; # endif #endif return; } #endif MUMPS_5.8.1/src/cmumps_intr_types.F0000664000175000017500000001067415042446441017134 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_INTR_TYPES USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC PRIVATE PUBLIC :: CMUMPS_ROOT_STRUC, & CMUMPS_L0OMPFAC_T, & CMUMPS_INTR_STRUC, & CMUMPS_INIT_INTR_ENCODING, & CMUMPS_FREE_INTR_ENCODING, & CMUMPS_ENCODE_INTR, & CMUMPS_DECODE_INTR C CMUMPS_ROOT_STRUC no longer contains INTEGERS TYPE CMUMPS_ROOT_STRUC ! 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 ! Fwd in facto: ! case of scalapack root: to store RHS in 2D block cyclic ! format compatible with root distribution COMPLEX, DIMENSION(:,:), POINTER :: RHS_ROOT ! for SVD on root (#define try_null_space) COMPLEX, DIMENSION(:,:), POINTER :: SVD_U, SVD_VT ! for RR on root (#define try_null_space) REAL, DIMENSION(:), POINTER :: SINGULAR_VALUES ! END TYPE CMUMPS_ROOT_STRUC ! multicore TYPE CMUMPS_L0OMPFAC_T COMPLEX, POINTER, DIMENSION(:) :: A INTEGER(8) :: LA END TYPE CMUMPS_L0OMPFAC_T C C All MUMPS internal datatypes are in an internal structure: TYPE CMUMPS_INTR_STRUC TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota TYPE (CMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & L0_OMP_FACTORS END TYPE CMUMPS_INTR_STRUC C ================================================================= CONTAINS C ================================================================= SUBROUTINE CMUMPS_INIT_INTR_ENCODING(id_intr_ENCODING) IMPLICIT NONE CHARACTER, DIMENSION(:), POINTER :: id_intr_ENCODING C To be called only before JOB=-1 NULLIFY(id_intr_ENCODING) END SUBROUTINE CMUMPS_INIT_INTR_ENCODING C ================================================================= SUBROUTINE CMUMPS_FREE_INTR_ENCODING(id_intr_ENCODING) IMPLICIT NONE CHARACTER, DIMENSION(:), POINTER :: id_intr_ENCODING C To be called only after JOB=-2 DEALLOCATE(id_intr_ENCODING) NULLIFY(id_intr_ENCODING) RETURN END SUBROUTINE CMUMPS_FREE_INTR_ENCODING C ================================================================= SUBROUTINE CMUMPS_ENCODE_INTR(id_intr_ENCODING, id_intr) IMPLICIT NONE C C Arguments: C ========= CHARACTER, DIMENSION(:), POINTER :: id_intr_ENCODING TYPE (CMUMPS_INTR_STRUC) :: id_intr C C Local variables: C =============== CHARACTER :: CHAR_ARRAY(1) INTEGER :: CHAR_LENGTH, IERR C IF (associated(id_intr_ENCODING)) THEN C Should be unassociated on entry WRITE(*,*) "Internal error in CMUMPS_ENCODE_INTR:", & " id_intr_ENCODING already allocated" CALL MUMPS_ABORT() ENDIF CHAR_LENGTH=size(transfer(id_intr,CHAR_ARRAY)) ALLOCATE(id_intr_ENCODING(CHAR_LENGTH), stat=IERR) IF (IERR > 0 ) THEN WRITE(*,*) "Allocation error in MUMPS_ENCODE_INTR" CALL MUMPS_ABORT() ENDIF C Fill with derived datatype id_intr_ENCODING=transfer(id_intr,CHAR_ARRAY) RETURN END SUBROUTINE CMUMPS_ENCODE_INTR C ================================================================= SUBROUTINE CMUMPS_DECODE_INTR(id_intr_ENCODING, id_intr) IMPLICIT NONE CHARACTER(len=1), DIMENSION(:), POINTER :: id_intr_ENCODING TYPE (CMUMPS_INTR_STRUC) :: id_intr IF (.NOT.associated(id_intr_ENCODING)) THEN WRITE(*,*) "Internal error 1 in CMUMPS_DECODE_INTR" CALL MUMPS_ABORT() ENDIf id_intr=transfer(id_intr_ENCODING,id_intr) DEALLOCATE(id_intr_ENCODING) NULLIFY(id_intr_ENCODING) RETURN END SUBROUTINE CMUMPS_DECODE_INTR END MODULE CMUMPS_INTR_TYPES MUMPS_5.8.1/src/dsol_driver.F0000664000175000017500000100777615042446441015676 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SOLVE_DRIVER(id,idintr) USE DMUMPS_STRUC_DEF USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_INTR_STRUC USE DMUMPS_SOL_ES C Lock Initialization (_LI) and Desruction (_LD) USE MUMPS_SOL_L0OMP_M, ONLY: MUMPS_SOL_L0OMP_LI, & MUMPS_SOL_L0OMP_LD C C Purpose C ======= C C Performs solution phase (solve), Iterative Refinements C and Error analysis. C C c C USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_ALLOC_SMALL_BUF, & MUMPS_BUF_ALLOC_CB, MUMPS_BUF_INIT, & MUMPS_BUF_DEALL_CB, & MUMPS_BUF_DEALL_SMALL_BUF USE DMUMPS_OOC USE MUMPS_MEMORY_MOD USE DMUMPS_LR_DATA_M, only : DMUMPS_BLR_STRUC_TO_MOD & , DMUMPS_BLR_MOD_TO_STRUC USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_MOD_TO_STRUC #if ! defined(NO_SAVE_RESTORE) USE DMUMPS_SAVE_RESTORE #endif !$ USE OMP_LIB IMPLICIT NONE C ------------------- C Explicit interfaces C ------------------- INTERFACE SUBROUTINE DMUMPS_SIZE_IN_STRUCT( id, idintr, & NB_INT,NB_CMPLX,NB_CHAR ) USE DMUMPS_STRUC_DEF, ONLY: DMUMPS_STRUC USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_INTR_STRUC TYPE (DMUMPS_STRUC) :: id TYPE (DMUMPS_INTR_STRUC) :: idintr INTEGER(8) :: NB_INT,NB_CMPLX,NB_CHAR END SUBROUTINE DMUMPS_SIZE_IN_STRUCT SUBROUTINE DMUMPS_CHECK_DENSE_RHS &(idRHS, idINFO, idN, idNRHS, idLRHS) DOUBLE PRECISION, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE DMUMPS_CHECK_DENSE_RHS END INTERFACE C INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' #if defined(V_T) INCLUDE 'VT.inc' #endif INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 C C Parameters C ========== C TYPE (DMUMPS_STRUC), TARGET :: id TYPE (DMUMPS_INTR_STRUC) :: idintr C C Local variables C =============== C INTEGER MP,LP, MPG LOGICAL PROK, PROKG, LPOK INTEGER MTYPE, ICNTL21 LOGICAL LSCAL, POSTPros, GIVSOL INTEGER ICNTL10, ICNTL11, ICNTL48_EFF INTEGER I,K,JPERM, J, II, IZ2 #if defined(USE_OLD_SCALING) INTEGER IPERM #endif INTEGER IZ, NZ_THIS_BLOCK, PJ C pointers in IS INTEGER LIW C pointers in id%S INTEGER(8) :: LA, LA_PASSED INTEGER LIW_PASSED INTEGER(8) :: LWCB8_MIN, LWCB8 C buffer sizes INTEGER DMUMPS_LBUF, DMUMPS_LBUF_INT INTEGER(8) :: DMUMPS_LBUF_8 INTEGER :: LBUFR, LBUFR_BYTES INTEGER :: MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL INTEGER(8) :: MSG_MAX_BYTES_SOLVE8 C reception buffer INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFR C null space INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, & IBEG_GLOB_DEF, IEND_GLOB_DEF, & IROOT_DEF_RHS_COL1 C INTEGER NITREF, NOITER, SOLVET, KASE C Meaningful only with tree pruning and sparse RHS LOGICAL INTERLEAVE_PAR, DO_PERMUTE_RHS LOGICAL CALL_NODES_FWD_BWD, FIRST_CALL_NODES_FWD_BWD C true if DMUMPS_SOL_C called during postprocessing LOGICAL FROM_PP LOGICAL ALLOCATE_S C C TIMINGS DOUBLE PRECISION TIMEIT, TIMEEA, TIMEEA1, TIMELCOND DOUBLE PRECISION TIME3 DOUBLE PRECISION TIMEC1,TIMEC2 DOUBLE PRECISION TIMEGATHER1,TIMEGATHER2 DOUBLE PRECISION TIMESCATTER1,TIMESCATTER2 DOUBLE PRECISION TIMECOPYSCALE1,TIMECOPYSCALE2 C ------------------------------------------ C Declarations related to exploit sparsity C ------------------------------------------ INTEGER :: NRHS_NONEMPTY INTEGER :: STRAT_PERMAM1 LOGICAL :: DO_NULL_PIV INTEGER, DIMENSION(:), POINTER :: IRHS_PTR_COPY INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE_COPY DOUBLE PRECISION, DIMENSION(:), POINTER :: RHS_SPARSE_COPY LOGICAL IRHS_SPARSE_COPY_ALLOCATED, IRHS_PTR_COPY_ALLOCATED, & RHS_SPARSE_COPY_ALLOCATED C INTEGER, DIMENSION(:), ALLOCATABLE :: MAP_RHS_loc INTEGER, DIMENSION(:), POINTER :: IRHS_loc_PTR LOGICAL :: IRHS_loc_PTR_ALLOCATED INTEGER(8) :: SUM_idNloc_RHS_8 DOUBLE PRECISION, DIMENSION(:), POINTER :: idRHS_loc INTEGER(8) :: DIFF_SOL_loc_RHS_loc INTEGER(8) :: RHS_loc_size, RHS_loc_shift INTEGER(8) :: NBT INTEGER :: NBCOL, COLSIZE, JBEG_RHS, JEND_RHS, JBEG_NEW, & NBCOL_INBLOC, IPOS, IPOSRHSINTR C Nb of pruned NE_STEPS, useful for FWD step; and list of root nodes LOGICAL :: fill INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_Sons_FWD, & Pruned_Sons_BWD INTEGER, DIMENSION(:), ALLOCATABLE :: PERM_RHS INTEGER, DIMENSION(:), POINTER :: PTR_POSINRHSINTR_FWD, & PTR_POSINRHSINTR_BWD DOUBLE PRECISION, DIMENSION(:), POINTER :: PTR_RHS INTEGER, DIMENSION(:), POINTER :: idIPTR_WORKING, idWORKING INTEGER :: SIZE_IPTR_WORKING, SIZE_WORKING C NRHS_NONEMPTY: holds C either the original number of RHS (id%NRHS defined on host) C or, when the RHS is sparse, it holds the C number of non empty columns. C it is computed on master and is C then broadcasted on all processes. C IRHS_PTR_COPY holds a compressed local copy of IRHS_PTR (or points C on the master to id%IRHS_PTR if no permutation requested) C IRHS_SPARSE_COPY might be allocated or might also point to C id%IRHS_SPARSE. To test if we can deallocate it we trace C with IRHS_SPARSE_COPY_ALLOCATED when it was effectively C allocated. C NBCOL_INBLOC total nb columns to process in this block C JBEG_RHS global ptr for starting column requested for this block C JEND_RHS global ptr for end column_number requested for this block C PERM_RHS -- Permutation of RHS computed on master and broadcasted C on all procs (of size id%NRHS orginal) C PERM_RHS(k) = i means that i is the kth column to be processed C Note that PERM_RHS will be used also in case of interleaving C ------------------------------------ INTEGER :: NOMP DOUBLE PRECISION ONE DOUBLE PRECISION ZERO PARAMETER( ONE = 1.0D0 ) PARAMETER( ZERO = 0.0D0 ) DOUBLE PRECISION RZERO, RONE PARAMETER( RZERO = 0.0D0, RONE = 1.0D0 ) C C RHS_IR is internal to DMUMPS and used for iterative refinement C or the error analysis section. It either points to the user's C RHS (on the host when the solution is centralized or the RHS C is dense), or is a workarray allocated inside this routine C of size N. DOUBLE PRECISION, DIMENSION(:), POINTER :: RHS_IR DOUBLE PRECISION, DIMENSION(:), POINTER :: WORK_WCB DOUBLE PRECISION, DIMENSION(:), POINTER :: PTR_RHS_ROOT INTEGER(8) :: LPTR_RHS_ROOT C C Local workarrays that will be dynamically allocated C DOUBLE PRECISION, ALLOCATABLE :: SAVERHS(:), C_RW1(:), & C_RW2(:), & SRW3(:), C_Y(:), & C_W(:) INTEGER :: LCWORK DOUBLE PRECISION, ALLOCATABLE :: CWORK(:) INTEGER, ALLOCATABLE :: MAP_RHS(:) DOUBLE PRECISION, ALLOCATABLE :: R_Y(:), D(:) DOUBLE PRECISION, ALLOCATABLE :: R_W(:) C The 2 following workarrays are temporary local C arrays only used for distributed matrix input C (KEEP(54) .NE. 0). DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: R_LOCWK54 DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: C_LOCWK54 INTEGER :: NBENT_RHSINTR, NB_FS_RHSINTR_F, & NB_FS_RHSINTR_TOT INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV LOGICAL :: UNS_PERM_INV_NEEDED_INMAINLOOP, & UNS_PERM_INV_NEEDED_BEFMAINLOOP, & UNS_PERM_INV_NEEDED_ONSLAVES INTEGER LIWK_SOLVE, LIWCB INTEGER, ALLOCATABLE :: IW1(:), IWK_SOLVE(:), IWCB(:) INTEGER :: LIWK_PTRACB INTEGER(8), ALLOCATABLE :: PTRACB(:) C C Parameters arising from the structure C INTEGER(8) :: MAXS DOUBLE PRECISION, DIMENSION(:), POINTER :: CNTL INTEGER, DIMENSION (:), POINTER :: KEEP,ICNTL,INFO INTEGER(8), DIMENSION (:), POINTER :: KEEP8 INTEGER, DIMENSION (:), POINTER :: IS DOUBLE PRECISION, DIMENSION(:),POINTER:: RINFOG C =============================================================== C SCALING issues: C When scaling was performed C RHS holds the solution of the scaled system C The unscaled second member (b0) was given C then we have to scale both rhs and solution: C A(sca) = LU = D1*A*D2 , with D2 = COLSCA C D1 = ROWSCA C -------------- C CASE OF A X =B C -------------- C (ICNTL(9)=1 or MTYPE=1) C A*x0 = b0 C b(sca) = D1 * b0 = ROWSCA*b0 C A(sca) [(D2) **(-1)] x0 = b(sca) C so the computed solution of LU * x(sca) = b(sca) C is : x(sca) =[(D2) **(-1)] x0 and so x0= D2*x(sca) C -------------- C CASE OF AT X =B C -------------- C (ICNTL(9).NE.1 or MTYPE=0) C A(sca) = LU = D1*A*D2 C AT*x0 = b0 => D2*AT*D1 * D1-1 x0 = D2 * b0 C b(sca) = D2 * b0 = COLSCA*b0 C A(sca)T [(D1) **(-1)] x0 = b(sca) C so the computed solution of (LU)^T * x(sca) = b(sca) C is : x(sca) =[(D1) **(-1)] x0 and so x0= D1*y0 is modified C C In case of distributed RHS or distributed solution we need C scaling information on each processor and this information has C been stored in ROWSCA_loc(1:INFO(23)) and COLSCA_loc(1:INFO(23)) C such that: C C ---------------- C CASE OF A X = B C ---------------- C C - the scaling factor of row i of A is stored on the C processor for which GLOB2LOC_RHS(i) > 0 at position C ROWSCA_loc(GLOB2LOC_RHS(i)) C C - the scaling factor of column j of A is stored on the C processor for which GLOB2LOC_SOL(j) > 0 at position C COLSCA_loc(GLOB2LOC_SOL(j)) C C ------------------ C CASE OF A^T X = B C ------------------ C C - the scaling factor of row i of A^T is stored on the C processor for which GLOB2LOC_RHS(i) > 0 at position C COLSCA_loc(GLOB2LOC_RHS(i)) C C - the scaling factor of column j of A^T is stored on the C processor for which GLOB2LOC_SOL(j) > 0 at position C ROWSCA_loc(GLOB2LOC_SOL(j)) C #if defined(USE_OLD_SCALING) type scaling_data_t SEQUENCE DOUBLE PRECISION , dimension(:), pointer :: SCALING DOUBLE PRECISION , dimension(:), pointer :: SCALING_LOC INTEGER, dimension(:), pointer :: SCALING_IND end type scaling_data_t type (scaling_data_t) :: scaling_data_dr type (scaling_data_t) :: scaling_data_sol C To scale on the fly during GATHER SOLUTION: DOUBLE PRECISION, DIMENSION(:), POINTER :: PT_SCALING DOUBLE PRECISION, TARGET :: Dummy_SCAL(1) #else INTEGER :: ROWORCOL #endif C C ==================== END OF SCALING related data ================ C C Local variables C C Interval associated to the subblocks of RHS a node has to process INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: RHS_BOUNDS INTEGER :: LPTR_RHS_BOUNDS INTEGER, DIMENSION(:), POINTER :: PTR_RHS_BOUNDS LOGICAL :: DO_NBSPARSE, NBSPARSE_LOC LOGICAL :: PRINT_MAXAVG DOUBLE PRECISION ARRET DOUBLE PRECISION C_DUMMY(1) DOUBLE PRECISION R_DUMMY(1) INTEGER IDUMMY(1), JDUMMY(1), KDUMMY(1), LDUMMY(1), MDUMMY(1) INTEGER, TARGET :: IDUMMY_TARGET(1) DOUBLE PRECISION, TARGET :: CDUMMY_TARGET(1) INTEGER JJ INTEGER allocok INTEGER NBRHS, NBRHS_EFF, BEG_RHS, NB_RHSSKIPPED, & LD_RHS, & MASTER_ROOT, MASTER_ROOT_IN_COMM C NRHS_COLS_SOL_C is used to estimate NRHS_EFF C before the loop on RHS column blocks INTEGER NRHS_COLS_SOL_C INTEGER SIZE_ROOT, LD_REDRHS INTEGER(8) :: IBEG, IBEG_RHSINTR, KDEC, IBEG_loc, IBEG_REDRHS INTEGER NCOL_RHS_loc INTEGER LD_RHS_loc, JBEG_RHS_loc INTEGER NB_K133, IRANK, TSIZE INTEGER KMAX_246_247 INTEGER IFLAG_IR, IRStep LOGICAL TESTConv LOGICAL WORKSPACE_MINIMAL_PREFERRED, WK_USER_PROVIDED INTEGER(8) NB_BYTES !size of data allocated during solve INTEGER(8) NB_BYTES_MAX !MAX size of data allocated during solve INTEGER(8) NB_BYTES_EXTRA !For Step2Node, which may be freed later INTEGER(8) NB_BYTES_LOC !For temp. computations INTEGER(8) NB_INT, NB_CMPLX, NB_CHAR, K34_8, K35_8, K149_8, K151_8 INTEGER(8) K16_8, ITMP8, SUM_ITMP8, NB_BYTES_ON_ENTRY #if defined(V_T) C Vampir INTEGER soln_drive_class, glob_comm_ini, perm_scal_ini, soln_dist, & soln_assem, perm_scal_post #endif LOGICAL I_AM_SLAVE, BUILD_POSINRHSINTR LOGICAL :: BUILD_RHSMAPINFO DOUBLE PRECISION, TARGET :: RDUMMY_TARGET(1) LOGICAL :: ES_RHSINTR INTEGER, DIMENSION(:), POINTER :: nodes_FWD, nodes_BWD C to manage sparsity: compute target nodes for starting chains C Lnodes_FWD/Lnodes_BWD = -1 => all nodes to be processed INTEGER, DIMENSION(:), POINTER :: nodes_FWD_PTR, nodes_BWD_PTR INTEGER :: Lnodes_FWD, Lnodes_BWD, Lnodes_FWD_PTR, Lnodes_BWD_PTR DOUBLE PRECISION, POINTER, DIMENSION(:) :: SCALING_loc_FWD DOUBLE PRECISION, POINTER, DIMENSION(:) :: SCALING_loc_BWD DOUBLE PRECISION, POINTER, DIMENSION(:) :: SCALING_RHSINTR_BWD DOUBLE PRECISION, POINTER, DIMENSION(:) :: SCALING_RHSINTR_FWD INTEGER :: LSCALING_RHSINTR_BWD, LSCALING_RHSINTR_FWD LOGICAL :: SCALING_RHSINTR_BWD_ALLOCATED, & SCALING_RHSINTR_FWD_ALLOCATED, & BUILD_SCALING_RHSINTR C NSOL_loc will be equal to KEEP(89) in case ICNTL(21)=1 INTEGER :: NSOL_loc LOGICAL WORK_WCB_ALLOCATED, IS_INIT_OOC_DONE LOGICAL PTR_RHS_ROOT_ALLOCATED LOGICAL :: IS_LR_MOD_TO_STRUC_DONE INTEGER :: KEEP350_SAVE, KEEP20_SAVE LOGICAL STOP_AT_NEXT_EMPTY_COL INTEGER MTYPE_LOC INTEGER(4) :: I4 INTEGER MAT_ALLOC_LOC, MAT_ALLOC INTEGER :: NZ_THIS_BLOCK_ARG, NBCOL_INBLOC_ARG, LStep2node_ARG INTEGER, POINTER :: Step2node_ARG(:), IRHS_PTR_COPY_ARG(:), & IRHS_SPARSE_COPY_ARG(:) INTEGER :: NB_FS_RHSINTR_F_ARG, NB_FS_RHSINTR_TOT_ARG INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE C C First executable statement C #if defined(V_T) CALL VTCLASSDEF( 'Soln driver',soln_drive_class,IERR) CALL VTFUNCDEF( 'glob_comm_ini',soln_drive_class, & glob_comm_ini,IERR) CALL VTFUNCDEF( 'perm_scal_ini',soln_drive_class, & perm_scal_ini,IERR) CALL VTFUNCDEF( 'soln_dist',soln_drive_class,soln_dist,IERR) CALL VTFUNCDEF( 'soln_assem',soln_drive_class,soln_assem,IERR) CALL VTFUNCDEF( 'perm_scal_post',soln_drive_class, & perm_scal_post,IERR) #endif C Depending on the type of parallelism, C the master can have the role of a slave I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) C -- The following pointers xxCOPY might be allocated but then C -- the associated xxCOPY_ALLOCATED will be set to C -- enable deallocation SCALING_RHSINTR_FWD_ALLOCATED = .FALSE. SCALING_RHSINTR_BWD_ALLOCATED = .FALSE. C Initialize scalings to possilby pass them as arguments C (e.g. to DMUMPS_DS_ALL2ALL) even on non working host C and/or when LSCAL is false SCALING_RHSINTR_FWD => RDUMMY_TARGET SCALING_RHSINTR_BWD => RDUMMY_TARGET LSCALING_RHSINTR_FWD = 1 LSCALING_RHSINTR_BWD = 1 SCALING_LOC_FWD => RDUMMY_TARGET SCALING_LOC_BWD => RDUMMY_TARGET 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. C ALLOCATE_S will be set to true if S needs be allocated. C It is then tested to free S befgore returning ALLOCATE_S = .FALSE. NULLIFY(RHS_IR) NULLIFY(WORK_WCB) #if defined(USE_OLD_SCALING) NULLIFY(scaling_data_dr%SCALING) NULLIFY(scaling_data_dr%SCALING_LOC) NULLIFY(scaling_data_dr%SCALING_IND) NULLIFY(scaling_data_sol%SCALING) NULLIFY(scaling_data_sol%SCALING_LOC) NULLIFY(scaling_data_sol%SCALING_IND) #endif NULLIFY(nodes_FWD) NULLIFY(nodes_BWD) IRHS_loc_PTR_allocated = .FALSE. IS_INIT_OOC_DONE = .FALSE. IS_LR_MOD_TO_STRUC_DONE = .FALSE. WK_USER_PROVIDED = .FALSE. WORK_WCB_ALLOCATED = .FALSE. PTR_RHS_ROOT_ALLOCATED = .FALSE. CNTL =>id%CNTL KEEP =>id%KEEP KEEP8=>id%KEEP8 IS =>id%IS ICNTL=>id%ICNTL INFO =>id%INFO RINFOG =>id%RINFOG LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) IF (.not.PROK) MP =0 IF (.not.PROKG) MPG=0 IF ( PROK ) WRITE(MP,100) IF ( PROKG ) WRITE(MPG,100) NB_BYTES = 0_8 NB_BYTES_MAX = 0_8 NB_BYTES_EXTRA = 0_8 K34_8 = int(KEEP(34), 8) K35_8 = int(KEEP(35), 8) ! complex factor K16_8 = int(KEEP(16), 8) K149_8 = int(KEEP(149),8) ! complex in instance K151_8 = int(KEEP(151),8) ! complex in instance C RR KEEP20_SAVE = KEEP(20) IF (KEEP(19).EQ.0.AND.KEEP(53).NE.0) THEN C ICNTL(56)>0 at analysis and =0 at facto C save special root index KEEP20_SAVE = KEEP(20) C suppress special RR treatment KEEP(20) = 0 ENDIF NBENT_RHSINTR = 0 C Used by DISTRIBUTED_SOLUTION to skip empty columns C that are skipped (case of sparse RHS) NB_RHSSKIPPED = 0 C next 4 initialisations needed in case of error C to free space allocated LSCAL = .FALSE. C ICNTL21 = -99998 ! will be bcasted later to slaves IBEG_RHSINTR =-152525_8 ! Should not be used BUILD_POSINRHSINTR = .TRUE. C NSOL_loc, KEEP(212) will be set if ICNTL(21).EQ.2 NSOL_loc = 0 KEEP(212)= 0 C SCALING_RHSINTR was initialized to a dummy array of size 1 C on the non working host, no need to reset it at each block BUILD_SCALING_RHSINTR = I_AM_SLAVE IBEG_GLOB_DEF = -9888 ! unitialized state IEND_GLOB_DEF = -9888 ! unitialized state IBEG_ROOT_DEF = -9777 ! unitialized state IEND_ROOT_DEF = -9777 ! unitialized state IROOT_DEF_RHS_COL1 = -9666 ! unitialized state C ------------------------------ C id%LD_RHSINTR will be set each C time RHSINTR is allocated C ------------------------------ NB_FS_RHSINTR_TOT = KEEP(89) ! number of FS var of the pruned tree ! mapped on this proc NB_FS_RHSINTR_F = NB_FS_RHSINTR_TOT C Save value of KEEP(350), in case of LR solve C KEEP(350) may be overwritten and restored C Old unoptimized version before 5.0.2 not available anymore IF (KEEP(350).LE.0) KEEP(350)=1 IF (KEEP(350).GT.2) KEEP(350)=1 KEEP350_SAVE = KEEP(350) C C Compute the number of integers and nb of reals in the structure CALL DMUMPS_SIZE_IN_STRUCT (id, idintr, NB_INT, NB_CMPLX, NB_CHAR) NB_BYTES = NB_BYTES + NB_INT * K34_8 + NB_CMPLX * K149_8 + NB_CHAR ! KE15: size of a cmplx in current MUMPS instance NB_BYTES_ON_ENTRY = NB_BYTES !used to check alloc/dealloc count ok NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ====================================== C BEGIN CHECK KEEP ENTRIES AND INTERFACE C ====================================== IF (id%MYID .EQ. MASTER) THEN C { C Set ICNTL(26) -> KEEP(221) (called at facto and solve) C (might be called at facto in case of fwd in facto C with Schur+reduced RHS requested) CALL DMUMPS_SET_K221(id, .TRUE.) id%KEEP(111) = id%ICNTL(25) C For the case of ICNTL(20)=1 one could C switch off exploit sparsity when RHS is too dense. IF (id%ICNTL(20) .EQ. 1) id%KEEP(235) = -1 !automatic IF (id%ICNTL(20) .EQ. 2) id%KEEP(235) = 0 !off IF (id%ICNTL(20) .EQ. 3) id%KEEP(235) = 1 !on IF (id%ICNTL(20).EQ.1 .or. id%ICNTL(20).EQ.2 .or. & id%ICNTL(20).EQ.3) THEN id%KEEP(248) = 1 !sparse RHS ELSE IF (id%ICNTL(20).EQ.10 .OR. id%ICNTL(20).EQ.11) THEN id%KEEP(248) = -1 ! dist. RHS ELSE id%KEEP(248) = 0 !dense RHS ENDIF C C set ICNTL21 and test for out-of range entries ICNTL21 = id%ICNTL(21) IF ( ICNTL21.NE.0 .AND. ICNTL21.NE.1 & ) ICNTL21 = 0 C IF ( id%ICNTL(30) .NE.0 ) THEN C A-1 is on id%KEEP(237) = 1 ELSE C A-1 is off id%KEEP(237) = 0 ENDIF IF (id%KEEP(248) .eq.0.and. id%KEEP(237).ne.0) THEN C For A-1 we have a sparse RHS in the API. C Force KEEP(248) accordingly. id%KEEP(248)=1 ENDIF IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(248).NE.0) ) THEN IF (KEEP(60).NE.0) THEN C -- input RHS is stored in REDRHS and RHSINTR id%KEEP(248) = 0 ENDIF ENDIF C} ENDIF C ============================================================= C KEEP(248) and KEEP(221): need be broadcasted C before continuing other checking/settings CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(248), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) IF (KEEP(248).EQ.-1 & ) THEN C{ CALL DMUMPS_CHECK_DISTRHS( & id%Nloc_RHS, & id%LRHS_loc, & id%NRHS, & id%IRHS_loc, & id%RHS_loc, & I_AM_SLAVE, & id%INFO) CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 C Compute sum of id%Nloc_RHS (without out-of-range) C and store it in SUM_idNloc_RHS_8 C (to be used to decide whether exploit sparsity C is exploited) CALL DMUMPS_ES_GET_SUM_Nloc ( & id%N, id%Nloc_RHS, id%IRHS_loc, id%COMM, & SUM_idNloc_RHS_8 ) C} ENDIF C =========================================================== IF (id%MYID .EQ. MASTER) THEN C { IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(235).NE.0) ) THEN C -- input RHS is in fact effectively C -- stored in REDRHS and/or RHSINTR C (for both Schur and bwd only) id%KEEP(235) = 0 ENDIF IF ( (id%KEEP(248).EQ.0).AND.(id%KEEP(111).EQ.0) ) THEN C RHS is not sparse and thus exploit sparsity is reset to 0 id%KEEP(235) = 0 ENDIF IF (id%KEEP(248) .EQ. -1 & ) THEN IF (id%KEEP(126).EQ.0) THEN id%KEEP(235) = 0 ELSE IF (id%KEEP(126).EQ.-1) THEN id%KEEP(235) = 1 ELSE IF (id%KEEP(126).GT.0) THEN IF ( SUM_idNloc_RHS_8 .LE. & int( & (dble(id%KEEP(126))/dble(1000))*dble(id%N) & , 8) & ) THEN id%KEEP(235) = 1 ELSE id%KEEP(235) = 0 ENDIF ELSE id%KEEP(235) = 0 ENDIF ENDIF C Case of Automatic setting of exploit sparsity (KEEP(235)=-1) C (in MUMPS_DRIVER original value of KEEP(235) is reset) IF(id%KEEP(111).NE.0) id%KEEP(235)=0 IF(id%KEEP(111).NE.0) id%KEEP(212)=0 C IF (id%KEEP(235).EQ.-1) THEN IF (id%KEEP(237).NE.0) THEN C for A-1 id%KEEP(235)=1 ELSE id%KEEP(235)=1 ENDIF ELSE IF (id%KEEP(235).NE.0) THEN id%KEEP(235)=1 ENDIF C Setting of KEEP(242) (permute RHS) IF ((KEEP(111).NE.0).OR.(KEEP(248) .EQ. -1)) THEN C In the context of C - distributed RHS, all columns share the same structure C - null space, the null pivots C are by default permuted to post-order C However for null space there is in this case no need to C permute null pivots since they are already in correct order. C Setting KEEP(242)=1 would just force to go through C part of the code permuting to identity. C Apart for validation purposes this is not interesting C costly (and more risky). KEEP(242) = 0 ENDIF IF (KEEP(248).EQ.0.AND.KEEP(111).EQ.0) THEN C Permutation possible if sparse RHS C (KEEP(248).NE.0: A-1 or General Sparse) C or null space (even if in current version C it is deactived) KEEP(242) = 0 ENDIF IF ((KEEP(242).NE.0).AND.KEEP(237).EQ.0) THEN IF ((KEEP(242).NE.-9).AND.KEEP(242).NE.1.AND. & KEEP(242).NE.-1) THEN C Reset it to 0 KEEP(242) = 0 ENDIF ENDIF IF (KEEP(242).EQ.-9) THEN C { C Automatic setting of permute RHS IF (id%KEEP(237).NE.0) THEN KEEP(242) = 1 ! postorder for A-1 ELSE ! dense or general sparse or distributed RHS KEEP(242) = 0 ! no permutation in most general case IF (KEEP(248) .EQ. 1) THEN ! sparse RHS IF (id%KEEP(235) .EQ. 1) THEN ! Tree pruning IF (id%NRHS .GT. 1) THEN IF (KEEP(497).EQ.-1 .OR. KEEP(497).GE.1) THEN KEEP(242)=1 ENDIF ENDIF ENDIF ENDIF ENDIF C } ENDIF IF ( id%KEEP(221).NE.0 ) THEN C -- Do not permute RHS with REDRHS/RHSINTR id%KEEP(242) = 0 ENDIF IF (KEEP(242).EQ.0) KEEP(243)=0 ! interleave off IF ((KEEP(237).EQ.0).OR.(KEEP(242).EQ.0)) THEN C Interleave (243) possible only C when permute RHS (242) is on and with A-1 KEEP(243) = 0 ENDIF IF (id%KEEP(237).EQ.1) THEN ! A-1 entries C Case of automatic setting of KEEP(243), KEEP(493-498) C (exploit sparsity parameters) IF (id%NSLAVES.EQ.1) THEN IF (id%KEEP(243).EQ.-1) id%KEEP(243)=0 IF (id%KEEP(495).EQ.-1) id%KEEP(495)=1 IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ELSE IF (id%KEEP(243).EQ.-1) id%KEEP(243)=1 IF (id%KEEP(495).EQ.-1) id%KEEP(495)=1 IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ENDIF ELSE ! dense or general sparse or distributed RHS id%KEEP(243)=0 id%KEEP(495)=0 IF (KEEP(248) .EQ. 1) THEN ! sparse RHS IF (id%KEEP(235) .EQ. 1) THEN ! Tree pruning IF (id%NRHS .GT. 1) THEN IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ENDIF ENDIF ELSE C nbsparse meaningless for distributed or dense RHS C Force it to 0 whatever was the initial value id%KEEP(497)=0 ENDIF ENDIF MTYPE = id%ICNTL( 9 ) IF (MTYPE.NE.1) MTYPE=0 ! see interface IF ((MTYPE.EQ.0).AND.KEEP(50).NE.0) MTYPE =1 ! suppress option Atx=b for A-1 IF (id%KEEP(237).NE.0) MTYPE = 1 C C ICNTL(35) was defined at analysis and C consistently reset at factorization C It was stored in KEEP(486) after factorization C Set KEEP(485) accordingly. C IF (KEEP(486) .EQ. 2) THEN KEEP(485) = 1 ! BLR solve ELSE KEEP(485) = 0 ! FR solve ENDIF C } ENDIF id%KEEP(401) = 0 IF (id%ICNTL(48).EQ.1) id%KEEP(401)=1 C Bcast id%KEEP(401) strategy (which C may be switched off or on during solve) CALL MPI_BCAST( id%KEEP(401), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) C define ICNTL48_EFF on master IF (id%MYID.EQ.MASTER) THEN IF ( (id%KEEP(401).EQ.1). AND. (id%KEEP(400).GT.0) ) THEN ICNTL48_EFF = 1 ELSE ICNTL48_EFF = 0 ENDIF ENDIF CALL MPI_BCAST(MTYPE,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST( id%KEEP(111), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(235), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(237), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(242), 2, MPI_INTEGER, MASTER, id%COMM, & IERR ) C Allready done CALL MPI_BCAST( id%KEEP(248), ...) CALL MPI_BCAST( id%KEEP(350), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(485), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(495), 3, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( ICNTL21, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C Broadcast original id%NRHS (used at least for checks on SOL_loc C and to allocate PERM_RHS in case of exploit sparsity) CALL MPI_BCAST( id%NRHS,1, MPI_INTEGER, MASTER, id%COMM,IERR) C C TIMINGS: reset to 0 TIMEC2=0.0D0 TIMECOPYSCALE2=0.0D0 TIMEGATHER2=0.0D0 TIMESCATTER2=0.0D0 id%DKEEP(112)=0.0D0 id%DKEEP(113)=0.0D0 C id%DKEEP(114) time for the iterative refinement C id%DKEEP(120) time for the error analysis C id%DKEEP(121) time for condition number C id%DKEEP(122) time for matrix redistribution (copy+scale solution) id%DKEEP(114)=0.0D0 id%DKEEP(120)=0.0D0 id%DKEEP(121)=0.0D0 id%DKEEP(115)=0.0D0 id%DKEEP(116)=0.0D0 id%DKEEP(122)=0.0D0 C Time for fwd, bwd and scalapack is C accumulated in DKEEP(117-119) within SOL_C C If requested time for each call to FWD/BWD C might be print but on output to solve C phase DKEEP will hold on each proc the accumulated time id%DKEEP(117)=0.0D0 id%DKEEP(118)=0.0D0 id%DKEEP(119)=0.0D0 id%DKEEP(123)=0.0D0 id%DKEEP(124)=0.0D0 id%DKEEP(125)=0.0D0 id%DKEEP(126)=0.0D0 id%DKEEP(127)=0.0D0 id%DKEEP(128:134)=0.0D0 id%DKEEP(140:153)=0.0D0 C CALL MUMPS_SECDEB(TIME3) C ------------------------------ C Check parameters on the master C ------------------------------ IF ( id%MYID .EQ. MASTER ) THEN IF ((KEEP(23).NE.0).AND.KEEP(50).NE.0) THEN C Maximum transversal permutation C has not been saved (KEEP(23)>0 and UNS_PERM allocated) C when matrix is symmetric. IF (PROKG) WRITE(MPG,'(A)') & ' Internal Error 1 in solution driver ' id%INFO(1)=-444 id%INFO(2)=KEEP(23) ENDIF C ------------------------------------ C Check that factors are available C either in-core or on disk, case C where factors were discarded during C factorization (e.g. useful to simulate C an OOC factorization or just get nb of C negative pivots or determinant) C ------------------------------------ IF (KEEP(201) .EQ. -1) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: Solve impossible because factors not kept' ENDIF id%INFO(1)=-44 id%INFO(2)=KEEP(251) GOTO 333 ELSE IF (KEEP(221).EQ.0 .AND. KEEP(251) .EQ. 2 & .AND. KEEP(252).EQ.0) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: Solve impossible because factors not kept' ENDIF id%INFO(1)=-44 id%INFO(2)=KEEP(251) GOTO 333 ENDIF C ------------------ IF (KEEP(252).NE.0 .AND. id%NRHS .NE. id%KEEP(253)) THEN C Fwd in facto C KEEP(252-253) available on all procs since analysis phase C Error: id%NRHS is not allowed to change since analysis C because fwd has been performed during facto with C KEEP(253) RHS IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: id%NRHS not allowed to change when', & ' ICNTL(32)=1' ENDIF id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) GOTO 333 ENDIF C Testing MTYPE instead of ICNTL(9) IF (KEEP(252).NE.0 .AND. MTYPE.NE.1) THEN C Fwd in facto is not compatible with transpose system INFO(1) = -43 INFO(2) = 9 IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.1) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' ENDIF GOTO 333 ENDIF IF (KEEP(248) .NE. 0.AND.KEEP(252).NE.0) THEN C Fwd during facto incompatible with sparse RHS C Forbid sparse RHS when Fwd performed during facto C Sparse RHS may be due to A-1 (ICNTL(30) INFO(1) = -43 IF (KEEP(237).NE.0) THEN INFO(2) = 30 ! ICNTL(30) IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: A-1 functionality incompatible with', & ' forward performed during factorization', & ' (ICNTL(32)=1)' ENDIF ELSE INFO(2) = 20 ! ICNTL(20) IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: sparse or dist. RHS incompatible with forward', & ' elimination during factorization (ICNTL(32)=1)' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. ICNTL21.NE.0) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with distributed solution.' ENDIF INFO(1)=-48 INFO(2)=21 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(60) .NE.0) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with Schur.' ENDIF INFO(1)=-48 INFO(2)=19 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(111) .NE.0) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with null space.' ENDIF INFO(1)=-48 INFO(2)=25 GOTO 333 ENDIF IF (id%NRHS .LE. 0) THEN id%INFO(1)=-45 id%INFO(2)=id%NRHS IF ((id%KEEP(111).NE.0).AND.(id%INFOG(28).EQ.0)) THEN IF (LPOK) THEN WRITE(LP,'(A)') & 'ICNTL(25) NE 0 but INFOG(28)=0', & ' the matrix is not deficient' ENDIF ENDIF GOTO 333 ENDIF C Entries of A-1 are stored in place of the input sparse RHS C thus no need for RHS to be allocated. IF (id%KEEP(237).EQ.0) THEN IF ((id%KEEP(248) == 0 .AND.KEEP(221).NE.2) & .OR. & (ICNTL21==0.AND.(KEEP(221).NE.1)) & )THEN C RHS must be of size N*NRHS on the master either to C store the dense centralized RHS, either to store C the dense centralized solution. CALL DMUMPS_CHECK_DENSE_RHS & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) IF (id%INFO(1) .LT. 0) GOTO 333 ENDIF ELSE C AM1: check that the constraint NRHS=N is respected C Check for valid sparse RHS structure done IF (id%NRHS .NE. id%N) THEN id%INFO(1)= -47 id%INFO(2)=id%NRHS GOTO 333 ENDIF ENDIF IF (id%KEEP(248) == 1 & ) THEN C{ ------------------------------------ C RHS_SPARSE, IRHS_SPARSE and IRHS_PTR C must be allocated of adequate size C ------------------------------------ IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(237).NE.0)) THEN C At least one entry of A-1 must be requested id%INFO(1)=-46 id%INFO(2)=id%NZ_RHS GOTO 333 ENDIF IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(221).EQ.1)) THEN C At least one entry of RHS must be nonzero with c Schur reduced RHS option id%INFO(1)=-46 id%INFO(2)=id%NZ_RHS GOTO 333 ENDIF IF ( id%NZ_RHS .GT. 0 ) THEN IF ( .not. associated(id%RHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 ENDIF ENDIF IF (id%NZ_RHS .GT. 0) THEN IF ( .not. associated(id%IRHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 ENDIF ENDIF IF ( .not. associated(id%IRHS_PTR) )THEN id%INFO(1)=-22 id%INFO(2)=12 GOTO 333 ENDIF C IF (size(id%IRHS_PTR) < id%NRHS + 1) THEN id%INFO(1)=-22 id%INFO(2)=12 GOTO 333 END IF IF (id%IRHS_PTR(id%NRHS + 1).ne.id%NZ_RHS+1) THEN id%INFO(1)=-27 id%INFO(2)=id%IRHS_PTR(id%NRHS+1) GOTO 333 END IF C compare with dble to prevent overflow IF (dble(id%N)*dble(id%NRHS).LT.dble(id%NZ_RHS)) THEN C Possible in case of dupplicate entries in Sparse RHS IF (PROKG) THEN write(MPG,*) & " WARNING: many dupplicate entries in ", & " sparse RHS provided by the user ", & " id%NZ_RHS,id%N,id%NRHS =", & id%NZ_RHS,id%N,id%NRHS ENDIF END IF IF (id%IRHS_PTR(1).ne.1) THEN id%INFO(1)=-28 id%INFO(2)=id%IRHS_PTR(1) GOTO 333 END IF IF (size(id%IRHS_SPARSE) < id%NZ_RHS) THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 END IF IF (size(id%RHS_SPARSE) < id%NZ_RHS) THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 END IF C} ENDIF C -------------------------------- C Set null space options for solve C -------------------------------- CALL DMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL(1),KEEP(1), & id%NRHS, & MPG,INFO(1)) IF (INFO(1) .LT. 0) GOTO 333 C END IF ! MASTER C -------------------------------------- C Check distributed solution vectors C -------------------------------------- IF (ICNTL21 .NE. 0 ) THEN IF (I_AM_SLAVE) THEN NSOL_loc = id%KEEP(89) ELSE NSOL_loc = 0 ENDIF C (I)SOL_loc should be allocated to hold the C distributed solution on exit IF ( id%LSOL_loc .LT. NSOL_loc ) THEN id%INFO(1)= -29 id%INFO(2)= id%LSOL_loc GOTO 333 ENDIF IF ( NSOL_loc .GT. 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) < NSOL_loc ) THEN id%INFO(1)=-22 id%INFO(2)=13 GOTO 333 END IF # if defined(MUMPS_NOF2003) C Warning: size returns a standard INTEGER and could C overflow if id%SOL_loc was allocated of size > 2^31-1; C still we prefer to perform this test since only (1) very C large problems with large NRHS and small numbers of MPI C can result in such a situation; (2) the test could be C suppressed if needed but might be still be ok in case C the right-hand side overflows too. IF (size(id%SOL_loc) < & (id%NRHS-1)*id%LSOL_loc+NSOL_loc) THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 END IF # else IF (size(id%SOL_loc,kind=8) < & int(id%NRHS-1,8)*int(id%LSOL_loc,8)+ & int(NSOL_loc,8)) THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 END IF # endif ENDIF ! NSOL_loc > 0 ENDIF ! ICNTL21 .NE. 0 IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(248) == 1 & ) THEN C RHS should NOT be associated C if I am not master since it is C not even used to store the solution IF ( associated( id%RHS ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 7 GOTO 333 END IF IF ( associated( id%RHS_SPARSE ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 10 GOTO 333 END IF IF ( associated( id%IRHS_SPARSE ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 11 GOTO 333 END IF IF ( associated( id%IRHS_PTR ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 12 GOTO 333 END IF END IF ENDIF C Prepare pointers to pass POINTERS(1) to C routines with implicit interfaces which C will then assume contiguous information C without needing to copy pointer arrays C in and out. Do this even if KEEP(248) C is different from -1 because of the C call to DMUMPS_DISTSOL_INDICES IF (associated(id%IRHS_loc)) THEN IF (size(id%IRHS_loc) .NE. 0) THEN IRHS_loc_PTR=>id%IRHS_loc ELSE C so that IRHS_loc_PTR(1) is ok IRHS_loc_PTR=>IDUMMY_TARGET ENDIF ELSE IRHS_loc_PTR=>IDUMMY_TARGET ENDIF IF (associated(id%RHS_loc)) THEN IF (size(id%RHS_loc) .NE. 0) THEN idRHS_loc=>id%RHS_loc ELSE idRHS_loc=>CDUMMY_TARGET ENDIF ELSE idRHS_loc=>CDUMMY_TARGET ENDIF C C C Check as soon as solution is distributed IF (I_AM_SLAVE .AND. ICNTL21.NE.0 .AND. & KEEP(248) .EQ. -1 & ) THEN ! Dist RHS and dist solution C IF (associated(id%RHS_loc) .AND. & associated(id%SOL_loc)) THEN C NSOL_loc was defined earlier IF (NSOL_loc.GT.0) THEN C ---------------------------------------------------- C Check if RHS_loc and SOL_loc point to same object... C id%SOL_loc(1) ok otherwise an error -22/14 C would have been raised earlier. C idRHS_loc(1) may point to CDUMMY but is ok C ---------------------------------------------------- CALL MUMPS_SIZE_C(idRHS_loc(1),id%SOL_loc(1), & DIFF_SOL_loc_RHS_loc) C ---------------------------------------- C Check for compatible dimensions in case C SOL_loc and RHS_loc point to same memory C ---------------------------------------- IF (DIFF_SOL_loc_RHS_loc .EQ. 0_8 .AND. & id%LSOL_loc .GT. id%LRHS_loc) THEN C Note that, depending on the block size, C if all columns are processed in one C shot, this could still work. However, C and since this was forbidden in the UG, C we raise the error systematically id%INFO(1)=-56 id%INFO(2)=id%LRHS_loc IF (LPOK) THEN WRITE(LP,'(A,I9,A,I9)') &" ** Error RHS_loc and SOL_loc pointers match but LRHS_loc=" &,id%LRHS_loc, " and LSOL_loc=", id%LSOL_loc ENDIF GOTO 333 ENDIF ENDIF ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN C Do some checks on KEEP(221) and REDRHS (in case of Schur) CALL DMUMPS_CHECK_K221andREDRHS(id) END IF ! MYID.EQ.MASTER IF (id%INFO(1) .LT. 0) GOTO 333 C ------------------------- C Propagate possible errors C ------------------------- 333 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 C ==================================== C END CHECK INTERFACE AND KEEP ENTRIES C ==================================== C ----------------------------------- 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) ENDIF C C ======================================================= C BEGIN Test for empty RHS : C sparse RHS and General Sparse (NOT A-1) and NZ_RHS = 0 C OR C Distributed RHS and sum of id%Nloc_RHS C (without off out-of-range) equal to 0 C ======================================================= IF & ( & ( (id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0) & .AND. (id%NZ_RHS.EQ.0) ) & .OR. & ( (id%KEEP(248).EQ.-1).AND. (SUM_idNloc_RHS_8.EQ.0_8) & ) & ) THEN C{ C We reset solution to zero and we return C (first freeing working space at label 90) IF ((ICNTL21.EQ.1).AND.(I_AM_SLAVE)) THEN C ---------------------- C SOL_loc reset to zero C ---------------------- C ---------------------- C Prepare ISOL_loc array C ---------------------- LIW_PASSED=max(1,KEEP(32)) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF (KEEP(89) .GT. 0) THEN CALL DMUMPS_DISTSOL_INDICES( MTYPE, id%ISOL_loc(1), & id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%IS(1), LIW_PASSED,id%MYID_NODES, & id%N, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES, #if defined(USE_OLD_SCALING) & scaling_data_sol, .FALSE., ! empty RHS, no scaling #endif C For checking only & .FALSE., IDUMMY(1), 1 & ) ENDIF ENDIF C Solution is null IF (ICNTL21.NE.0) THEN ! distributed solution DO J=1, id%NRHS C (NSOL_loc=KEEP(89) or id%NSOL_loc, and in case C ICNTL21=1, NSOL_loc is 0 on non-working host) DO I=1, NSOL_loc id%SOL_loc(int(J-1,8)*id%LSOL_loc + I) =ZERO ENDDO ENDDO ENDIF IF (ICNTL21.EQ.0) THEN ! centralized solution C ---------------------------- C RHS reset to zero on master C ---------------------------- IF (id%MYID.EQ.MASTER) THEN DO J=1, id%NRHS DO I=1, id%N id%RHS(int(J-1,8)*int(id%LRHS,8) + int(I,8)) =ZERO ENDDO ENDDO ENDIF ENDIF C C print solve phase stats if requested IF ( PROKG ) THEN WRITE( MPG, 150 ) C ICNTL(35) should not been accessed during SOLVE thus C print KEEP(486) value set during factorization & id%NRHS, ICNTL(27), ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30), KEEP(486), & ICNTL48_EFF IF (KEEP(221).NE.0) THEN WRITE (MPG, 152) KEEP(221) ENDIF IF (KEEP(252).GT.0) THEN ! Fwd during facto WRITE (MPG, 153) KEEP(252) ENDIF ENDIF C C -------- GOTO 90 ! end of solve deallocate what is needed C} ENDIF ! test empty RHS (general sparse or Distributed) C ======================================================= C END of Test for empty RHS : C ======================================================= C ==================================== C END CHECK INTERFACE AND KEEP ENTRIES C ==================================== INTERLEAVE_PAR =.FALSE. DO_PERMUTE_RHS =.FALSE. CALL_NODES_FWD_BWD = .FALSE. FIRST_CALL_NODES_FWD_BWD = .FALSE. C Default is no sparsity exploited nodes_FWD_PTR => IDUMMY_TARGET nodes_BWD_PTR => IDUMMY_TARGET Lnodes_FWD = -1 Lnodes_BWD = -1 C IF ((id%KEEP(235).NE.0).or.(id%KEEP(237).NE.0) & ) THEN CALL_NODES_FWD_BWD = .TRUE. FIRST_CALL_NODES_FWD_BWD = .TRUE. C Case of pruned elimination tree or selected entries in A-1 IF (id%KEEP(237).NE.0.AND. & id%KEEP(248).EQ.0) THEN C When A-1 is requested (keep(237).ne.0) C sparse RHS has been forced to be on. IF (LPOK) THEN WRITE(LP,'(A,I4,I4)') & ' Internal Error 2 in solution driver (A-1) ', & id%KEEP(237), id%KEEP(248) ENDIF CALL MUMPS_ABORT() ENDIF C NBT (in Bytes) is inout in MUMPS_REALLOC and C should be initialized. NBT = 0 C -- Allocate Step2node on each proc CALL MUMPS_REALLOC(id%Step2node, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%Step2node (Solve)', MEMCNT=NBT, ERRCODE=-13) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C -- build Step2node on each proc; C -- this is usefull to have at each step a unique C -- representative node (associated with principal variable of C -- that node. IF (NBT.NE.0) THEN ! Step2node was reallocated and needs be recomputed DO I=1, id%N IF (id%STEP(I).LE.0) CYCLE ! nonprincipal variables id%Step2node(id%STEP(I)) = I ENDDO C ELSE C we reuse Step2node computed in a previous solve phase C Step2node is deallocated each time a new analysis is C performed or when job=-2 is called ENDIF C --- NBT is the nb of extra bytes allocated NB_BYTES = NB_BYTES + NBT NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) NB_BYTES_EXTRA = NB_BYTES_EXTRA + NBT C Mapping information used during solve. In case of several C facto+solve it has to be recomputed. C In case of several solves with the same C facto, it is not recomputed. C It is used to compute the interleaving C for A-1, and, in dev_version, passed to sol_c to compute C some stats IF((KEEP(235).NE.0).OR.(KEEP(237).NE.0)) THEN IF(.NOT.associated(id%IPTR_WORKING)) THEN C Not computed at a previous solve: C recompute id%IPTR_WORKING and id%WORKING CALL DMUMPS_BUILD_MAPPING_INFO(id) END IF idIPTR_WORKING => id%IPTR_WORKING idWORKING => id%WORKING ELSE C case of selected entries in solution C with no ES during fwd SIZE_WORKING = 1 SIZE_IPTR_WORKING = 1 idIPTR_WORKING => IDUMMY_TARGET idWORKING => IDUMMY_TARGET END IF ENDIF C C Initialize SIZE_OF_BLOCK from MUMPS_SOL_ES module IF ( I_AM_SLAVE ) THEN CALL DMUMPS_SOL_ES_INIT(id%OOC_SIZE_OF_BLOCK, id%KEEP(201)) ENDIF DO_NULL_PIV = .TRUE. NBCOL_INBLOC = -9998 NZ_THIS_BLOCK= -9998 JBEG_RHS = -9998 c IF (id%MYID.EQ.MASTER) THEN ! Compute NRHS_NONEMPTY C C -- Sparse RHS (general, centralized) IF ( KEEP(111)==0 .AND. KEEP(248)==1 & ) THEN C -- Note that KEEP(111).NE.0 (null space on) C -- and KEEP(248).NE.0 will be made incompatible C -- When computing entries of A-1 (or SparseRHS only) NRHS_NONEMPTY = 0 DO I=1, id%NRHS IF (id%IRHS_PTR(I).LT.id%IRHS_PTR(I+1)) THEN NRHS_NONEMPTY = NRHS_NONEMPTY+1 !ith col in non empty ENDIF ENDDO IF (NRHS_NONEMPTY.LE.0) THEN C Internal error: tested before in mumps_driver IF (LPOK) & WRITE(LP,*) " Internal Error 3 in solution driver ", & " NRHS_NONEMPTY= ", & NRHS_NONEMPTY CALL MUMPS_ABORT() ENDIF ELSE NRHS_NONEMPTY = id%NRHS ENDIF ENDIF C ------------------------------------ C If there is a special root node, C precompute mapping of root's master C ------------------------------------ SIZE_ROOT = -33333 IF ( KEEP( 38 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP( KEEP(38))), & KEEP(199) ) IF (id%MYID_NODES .eq. MASTER_ROOT) THEN SIZE_ROOT = idintr%root%TOT_ROOT_SIZE ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN C SIZE_ROOT also used for KEEP(221).NE.0 SIZE_ROOT=id%KEEP(116) ENDIF ELSE IF (KEEP( 20 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(KEEP(20))), & KEEP(199) ) IF (id%MYID_NODES .eq. MASTER_ROOT) THEN SIZE_ROOT = id%IS( & id%PTLUST_S(id%STEP(KEEP(20)))+KEEP(IXSZ) + 3) ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN C SIZE_ROOT also used for KEEP(221).NE.0 SIZE_ROOT=id%KEEP(116) ENDIF ELSE MASTER_ROOT = -44444 END IF C -------------- C Get block size C -------------- C We work on a maximum of NBRHS at a time. C The leading dimension of RHS is id%LRHS on the host process C and it is set to N on slave processes. IF (id%MYID .eq. MASTER) THEN C{ KEEP(84) = ICNTL(27) C Treating ICNTL(27)=0 as if ICNTL(27)=1 IF(ICNTL(27).EQ.0) KEEP(84)=1 IF (KEEP(252).NE.0) THEN ! Fwd in facto: all rhs (KEEP(253) need be processed in one pass NBRHS = KEEP(253) ELSE IF (KEEP(201) .EQ. 0 .OR. KEEP(84) .GT. 0) THEN NBRHS = abs(KEEP(84)) ELSE NBRHS = -2*KEEP(84) END IF IF (NBRHS .GT. NRHS_NONEMPTY ) NBRHS = NRHS_NONEMPTY C ENDIF C} ENDIF #if defined(V_T) CALL VTBEGIN(glob_comm_ini,IERR) #endif C NRHS_NONEMPTY needed on all procs to allocate RHSINTR on slaves CALL MPI_BCAST(NRHS_NONEMPTY,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(NBRHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) C IF (KEEP(201).GT.0) THEN C --- id%KEEP(201) indicates if OOC is on (=1) of not (=0) C -- 107: number of buffers C Define number of types of files (L, possibly U) WORKSPACE_MINIMAL_PREFERRED = .FALSE. IF (id%MYID .eq. MASTER) THEN KEEP(107) = max(0,KEEP(107)) IF ((KEEP(107).EQ.0).AND. & (KEEP(204).EQ.0).AND.(KEEP(211).NE.1) ) THEN C -- default setting for release 4.8 ! Case of ! -Emmergency buffer only and ! -Synchronous mode ! -NO_O_DIRECT (because of synchronous choice) ! THEN ! "Basic system-based version" ! We can force to allocate S to a minimal ! value. WORKSPACE_MINIMAL_PREFERRED=.TRUE. ENDIF ENDIF CALL MPI_BCAST( KEEP(107), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(204), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(208), 2, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( WORKSPACE_MINIMAL_PREFERRED, 1, & MPI_LOGICAL, & MASTER, id%COMM, IERR ) C --- end of OOC case ENDIF IF ( I_AM_SLAVE ) THEN C C NB_K133: Max number of simultaneously processed C active fronts. C Why more than one active node ? C 1/ In parallel when we start a level 2 node C then we do not know exactly when we will C have received all contributions from the C slaves. C This is very critical in OOC since the C size provided to the solve phase is C much smaller and since we need C to determine the size fo the buffers for IO. C We pospone the allocation of the block NFRONT*NB_NRHS C and solve the problem. C C C 2/ While processing a node and sending information C if we have not enough memory in send buffer C then we must receive. C We feel that this is not so critical. C NB_K133 = 3 C To this we must add one time KEEP(133) to store C the RHS of the root node if the root is local. C Furthermore this quantity has to be multiplied by the C blocking size in case of multiple RHS. IF ( KEEP( 38 ) .NE. 0 .OR. KEEP( 20 ) .NE. 0 ) THEN IF ( MASTER_ROOT .eq. id%MYID_NODES ) THEN IF ( & .NOT. associated(idintr%roota%RHS_CNTR_MASTER_ROOT) & ) THEN NB_K133 = NB_K133 + 1 ENDIF END IF ENDIF C -------------------------------------- C NRHS_COLS_SOL_C is the maximum number C of colums for the call to DMUMPS_SOL_C C -------------------------------------- NRHS_COLS_SOL_C = min(NRHS_NONEMPTY,NBRHS) C C LWCB8_MIN = int(NB_K133,8)*int(KEEP(133),8)* & int(NRHS_COLS_SOL_C,8) C ENDIF C --------------------------------------------------------------- C Set WK_USER_PROVIDED to true when workspace WK_USER is provided C We can accept WK_USER to be provided on only some process and C different values of WK_USER per process. WK_USER_PROVIDED = (id%LWK_USER.NE.0 .AND.I_AM_SLAVE) IF (WK_USER_PROVIDED) THEN IF (id%LWK_USER.GT.0) THEN ITMP8= int(id%LWK_USER,8) ELSE ITMP8 = -int(id%LWK_USER,8)* 1000000_8 ENDIF ELSE ITMP8 = 0_8 ENDIF CALL MPI_REDUCE ( ITMP8, SUM_ITMP8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) C Incore: Check if the provided size is equal to that used during C facto (case of ITMP8/=0 and KEEP8(24)/=ITMP8) C But also check case of space not provided during solve C but was provided during facto C (case of ITMP8=0 and KEEP8(24)/=0) IF (KEEP(201).EQ.0) THEN ! incore C Compare provided size with previous size IF (ITMP8.NE.KEEP8(24)) THEN C -- error when reusing space allocated INFO(1) = -41 INFO(2) = id%LWK_USER ENDIF ELSE KEEP8(24)=ITMP8 ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 IF (.NOT. I_AM_SLAVE) KEEP8(124)=SUM_ITMP8 C all procs: KEEP8(24) holds the size of WK_USER provided by user. C master only: KEEP8(124) indicates if WK_USER provided on some proc MAXS = 0_8 IF (I_AM_SLAVE) THEN IF (WK_USER_PROVIDED) THEN MAXS = KEEP8(24) IF (MAXS.LT. KEEP8(20)) THEN INFO(1)= -11 ! MAXS should be increased by at least ITMP8 ITMP8 = KEEP8(20)+1_8-MAXS CALL MUMPS_SET_IERROR(ITMP8, INFO(2)) ENDIF IF (INFO(1) .GE. 0 ) id%S => id%WK_USER(1:KEEP8(24)) ALLOCATE_S = .FALSE. ELSE IF (KEEP8(23) .GT. 0) THEN MAXS = KEEP8(23) C S is already allocated, of size KEEP8(23) ALLOCATE_S = .FALSE. ELSE IF (KEEP(201).EQ.0) THEN ! incore C id%S might have been freed during factorization and C reallocated of size KEEP8(31) ( if KEEP8(31)>0 ) IF (KEEP8(31).EQ.0) THEN MAXS = 1 ALLOCATE_S = .TRUE. ENDIF ELSE C -- OOC and WK_USER not provided: C define size (S) and allocate it C ---- modify size of MAXS: in a simple C ---- system-based version, we want to C ---- use a small size for MAXS, to C ---- avoid the system pagecache to be C ---- polluted by 'our memory' ALLOCATE_S = .TRUE. IF ( KEEP(209).EQ.-1 .AND. WORKSPACE_MINIMAL_PREFERRED) & THEN C We need space to load at least the largest factor MAXS = KEEP8(20) + 1_8 ELSE IF ( KEEP(209) .GE.0 ) THEN C Use suggested value of MAXS provided in KEEP(209) MAXS = max(int(KEEP(209),8), KEEP8(20) + 1_8) ELSE MAXS = id%KEEP8(14) ! initial value: do not use more than ! minimum (non relaxed) size of OOC facto ENDIF C MAXS = max(MAXS, id%KEEP8(20)+1_8) C --- end of OOC case ENDIF IF ( ALLOCATE_S ) THEN ALLOCATE (id%S(MAXS), stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID,': problem allocation of S ', & 'at solve' ENDIF INFO(1) = -13 CALL MUMPS_SET_IERROR(MAXS, INFO(2)) KEEP8(23)=0_8 ALLOCATE_S = .FALSE. ELSE KEEP8(23)=MAXS ENDIF NB_BYTES = NB_BYTES + KEEP8(23) * K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C IF (KEEP(201).EQ.0) THEN C On the slaves, S is divided as follows: C S(1..LA) holds the factors, C S(LA+1..MAXS) is free workspace LA = KEEP8(31) ELSE C MAXS has normally been dimensionned to store only factors. LA = MAXS IF(MAXS.GT.KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8))THEN C If we have a very large MAXS, the size reserved for C loading the factors into memory does not need to exceed the C total size of factors. The (KEEP8(20)*(KEEP(107)+1)) term C is here in order to ensure that even with round-off C problems (linked to the number of solve zones) factors can C all be stored in-core LA=KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8) ENDIF ENDIF C C We need to allocate a workspace of size LWCB8 for the solve phase. C Either it is available at the end of MAXS, or we perform a C dynamic allocation. IF ( MAXS-LA .GT. LWCB8_MIN & ) THEN LWCB8 = MAXS - LA WORK_WCB => id%S(LA+1_8:LA+LWCB8) WORK_WCB_ALLOCATED=.FALSE. ELSE LWCB8 = LWCB8_MIN ALLOCATE(WORK_WCB(LWCB8), stat=allocok) IF (allocok < 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(LWCB8,INFO(2)) ELSE WORK_WCB_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + LWCB8*K151_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C --------------------------------- C Space for the RHS of special root C --------------------------------- IF ( id%MYID_NODES .EQ. MASTER_ROOT ) THEN C This is a special root (otherwise MASTER_ROOT < 0) IF ( associated(idintr%roota%RHS_CNTR_MASTER_ROOT) ) THEN C RHS_CNTR_MASTER_ROOT may have been allocated C during the factorization phase. PTR_RHS_ROOT => idintr%roota%RHS_CNTR_MASTER_ROOT # if defined(MUMPS_NOF2003) LPTR_RHS_ROOT = & int(size(idintr%roota%RHS_CNTR_MASTER_ROOT),8) # else LPTR_RHS_ROOT = & size(idintr%roota%RHS_CNTR_MASTER_ROOT,kind=8) # endif ELSE C In this case, the space for RHS_CNTR_MASTER_ROOT C is always part of WORKWCB, which can itself be C part of id%S or not. LPTR_RHS_ROOT = NRHS_COLS_SOL_C * int(SIZE_ROOT,8) PTR_RHS_ROOT => WORK_WCB(LWCB8-LPTR_RHS_ROOT+1_8:LWCB8) C Reduce size of WORK_WCB LWCB8=LWCB8-LPTR_RHS_ROOT ENDIF ELSE LPTR_RHS_ROOT = 1_8 PTR_RHS_ROOT => CDUMMY_TARGET ENDIF ENDIF ! I_AM_SLAVE C ----------------------------------- 99 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 C ----------------------------------- IF ( I_AM_SLAVE ) THEN IF (KEEP(201).GT.0) THEN CALL DMUMPS_INIT_FACT_AREA_SIZE_S(LA) C -- This includes thread creation C -- for asynchronous strategies CALL DMUMPS_OOC_INIT_SOLVE(id%ICNTL(1), id%ICNTL(4), id%N, & id%NSLAVES, id%MYID, id%OOC_NB_FILE_TYPE, id%KEEP, id%KEEP8, & id%INFO, id%STEP, id%PROCNODE_STEPS, id%OOC_SIZE_OF_BLOCK, & id%OOC_INODE_SEQUENCE, id%OOC_VADDR, & id%OOC_MAX_NB_NODES_FOR_ZONE, id%OOC_TOTAL_NB_NODES, & id%OOC_NB_FILES, id%OOC_FILE_NAME_LENGTH, id%OOC_FILE_NAMES, & id%COMM_NODES, idintr%root%yes) IS_INIT_OOC_DONE = .TRUE. ENDIF ! KEEP(201).GT.0 ENDIF C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 C IF (I_AM_SLAVE) THEN IF (KEEP(485).EQ.1) THEN IF (.NOT. (associated(id%FDM_F_ENCODING))) THEN WRITE(*,*) "Internal error 18 in DMUMPS_SOL_DRIVER" CALL MUMPS_ABORT() ENDIF IF (.NOT. (associated(id%BLRARRAY_ENCODING))) THEN WRITE(*,*) "Internal error 19 in DMUMPS_SOL_DRIVER" CALL MUMPS_ABORT() ENDIF C Access to OOC data in module during solve CALL MUMPS_FDM_STRUC_TO_MOD('F',id%FDM_F_ENCODING) CALL DMUMPS_BLR_STRUC_TO_MOD(id%BLRARRAY_ENCODING) IS_LR_MOD_TO_STRUC_DONE = .TRUE. ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN C{ IF ( PROKG ) THEN WRITE( MPG, 150 ) C ICNTL(35) should not been accessed during SOLVE thus C print KEEP(486) value set during factorization & id%NRHS, NBRHS, ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30), KEEP(486), & ICNTL48_EFF IF (KEEP(111).NE.0) THEN WRITE (MPG, 151) KEEP(111) ENDIF IF (KEEP(221).NE.0) THEN WRITE (MPG, 152) KEEP(221) ENDIF IF (KEEP(252).GT.0) THEN ! Fwd during facto WRITE (MPG, 153) KEEP(252) ENDIF ENDIF C ==================================== C Define LSCAL, ICNTL10 and ICNTL11 C ==================================== LSCAL = (((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) .OR. ( & KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) ICNTL10 = ICNTL(10) ICNTL11 = ICNTL(11) C Values of ICNTL(11) out of range IF ((ICNTL11 .LT. 0).OR.(ICNTL11 .GE. 3)) THEN ICNTL11 = 0 IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) out of range' ENDIF CALL DMUMPS_SET_POSTPros ( & KEEP(1), ICNTL(1), NBRHS, MPG, PROKG, & ICNTL10, ICNTL11, POSTPros) C} -- end of test master END IF CALL MPI_BCAST(POSTPros,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) C We need the original matrix only in the case of C we want to perform IR or Error Analysis, i.e. if C POSTPros = TRUE MAT_ALLOC_LOC = 0 IF ( POSTPros ) THEN MAT_ALLOC_LOC = 1 C Check if the original matrix has been allocated. IF ( KEEP(54) .EQ. 0 ) THEN C The original matrix is centralized IF ( id%MYID .eq. MASTER ) THEN IF (KEEP(55).eq.0) THEN C Case of matrix assembled centralized IF (.NOT.associated(id%A) .OR. & (.NOT.associated(id%IRN)) .OR. & ( .NOT.associated(id%JCN))) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original centralized assembled', & ' matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ELSE C Case of matrix in elemental format IF (.NOT.associated(id%A_ELT).OR. & .NOT.associated(id%ELTPTR).OR. & .NOT.associated(id%ELTVAR)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original elemental matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ENDIF ENDIF !end master, centralized matrix ELSE C The original matrix is assembled distributed IF ( I_AM_SLAVE .AND. (id%KEEP8(29) .GT. 0_8) ) THEN C If MAT_ALLOC_LOC = 1 the local distributed matrix is C allocated, otherwise MAT_ALLOC_LOC = 0 IF ((.NOT.associated(id%A_loc)) .OR. & (.NOT.associated(id%IRN_loc)) .OR. & (.NOT.associated(id%JCN_loc))) THEN IF (PROK) WRITE(MP,'(A/,A,I5,I12)') & ' WARNING: original distributed matrix not allocated', & ' MPI rank, local nonzeros=', & id%MYID, id%KEEP8(29) MAT_ALLOC_LOC = 0 ENDIF ENDIF ENDIF ! end test allocation matrix (keep(54)) ENDIF ! POSTPros CALL MPI_REDUCE( MAT_ALLOC_LOC, MAT_ALLOC, 1, & MPI_INTEGER, & MPI_MIN, MASTER, id%COMM, IERR) IF ( POSTPros.and.(id%MYID .eq. MASTER) ) THEN C if postprocessing requested matrix must be allocated IF (MAT_ALLOC.EQ.0) THEN IF (KEEP(54).NE.0) THEN C Write on MPG this time (we wrote on MP before in C case of distributed matrix and wrote on MPG already C in case of centralized matrix) IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original distributed matrix is not allocated' ENDIF POSTPros = .FALSE. ICNTL11 = 0 ICNTL10 = 0 C Write a warning. IF ((ICNTL(10) .NE. 0) .AND. (ICNTL10 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0' ENDIF IF ((ICNTL(11) .EQ. 1).OR.(ICNTL(11) .EQ. 2) & .AND.(ICNTL11 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF ENDIF IF (POSTPros) THEN ALLOCATE(SAVERHS(id%N*NBRHS),stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Problem in solve: error allocating SAVERHS' ENDIF INFO(1) = -13 INFO(2) = id%N*NBRHS END IF NB_BYTES = NB_BYTES + int(size(SAVERHS),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C C Forbid entries in a-1, in case of null space computations c IF (KEEP(237).NE.0 .AND.KEEP(111).NE.0) THEN C Ignore ENTRIES IN A-1 in case we compute C vectors of the null space (KEEP(111)).NE.0.) C We should still allocate IRHS_SPARSE IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: KEEP(237) treated as if set to 0 (null space)' KEEP(237)=0 ENDIF C -- end of test master END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C -------------------------------------------------- C Broadcast information to have all processes do the C same thing (error analysis/iterative refinements/ C scaling/distribution of solution) C -------------------------------------------------- CALL MPI_BCAST(ICNTL10,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(ICNTL11,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(POSTPros,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) CALL MPI_BCAST(LSCAL,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) CALL MPI_BCAST(KEEP(237),1,MPI_INTEGER,MASTER, & id%COMM,IERR) #if ! defined(USE_OLD_SCALING) C ---------------------------------------------- C Initialize SCALING_LOC_FWD and SCALING_LOC_BWD C They corespond to all pivots factorized on a C given MPI process and point to a dummy array C of size 1 on the host of if no pivot was C factorized (KEEP(89))=0 C ---------------------------------------------- IF (LSCAL .AND. id%KEEP(89) .GT. 0) THEN IF (MTYPE .EQ. 1) THEN SCALING_LOC_FWD => id%ROWSCA_loc SCALING_LOC_BWD => id%COLSCA_loc ELSE SCALING_LOC_FWD => id%COLSCA_loc SCALING_LOC_BWD => id%ROWSCA_loc ENDIF ELSE ! includes non working master on which KEEP(89)=0 SCALING_LOC_FWD => RDUMMY_TARGET SCALING_LOC_BWD => RDUMMY_TARGET ENDIF C Remarks related to scalings: C * During postprocessing, one performs solves C with alternatively A and A^T, meaning that C SCALING_LOC_FWD and SCALING_LOC_BWD will C be redefined. C * In case of exploit sparsity, RHSINTR may C have less rows than ROWSCA_loc/COLSCA_loc. C SCALING_RHSINTR_FWD and SCALING_RHSINTR_BWD C will then be extracted from C SCALING_LOC_FWD and SCALING_LOC_BWD thanks C to the subroutine DMUMPS_SCALINGRHSINTR #endif C KEEP(248)==1 if not_NullSpace (KEEP(111)=0) C and sparse RHS on input (id%ICNTL(20)/KEEP(248)==1) C (KEEP(248)==1 implies KEEP(111) = 0, otherwise error was raised) C We cant thus isolate the case of C sparse RHS associated to Null space computation because C in this case preparation is different since C -we skip the forward step and C -the pattern of the RHS C of the bwd is related to null pivot indices found and not C to information contained in the sparse rhs input format. DO_PERMUTE_RHS = (KEEP(242).NE.0) C apply interleaving in parallel (FOR A-1 or Null space only) IF ( (id%NSLAVES.GT.1) .AND. (KEEP(243).NE.0) & ) THEN C -- Option to interleave RHS only makes sense when C -- A-1 option is on or Null space compution are on C (note also that KEEP(243).NE.0 only when PERMUTE_RHS is on) IF ((KEEP(237).NE.0).or.(KEEP(111).GT.0)) THEN INTERLEAVE_PAR= .TRUE. IF (KEEP(237).EQ.1) THEN IF (NRHS_NONEMPTY.LT.2*NBRHS) THEN INTERLEAVE_PAR= .FALSE. ENDIF ENDIF ELSE IF (PROKG) THEN write(MPG,*) ' Warning incompatible options ', & ' interleave RHS reset to false ' ENDIF ENDIF ENDIF CALL MUMPS_BUF_INIT( id%KEEP( 34 ), id%KEEP(151) ) C -------------------------------------- C Compute an upperbound of message size C for forward and backward solutions: C -------------------------------------- MSG_MAX_BYTES_SOLVE8 = int(( 4 + KEEP(133) ) * KEEP(34),8) + & int(KEEP(133)*KEEP(151),8) * int(NBRHS,8) & + int(16*KEEP(34),8) ! for request id, pointer to next + safety IF ( MSG_MAX_BYTES_SOLVE8 .GT. & int(huge(I4),8)) THEN INFO(1) = -18 C Max NBRHS to avoid overflow: INFO(2) = ( huge(I4) - & ( 16 + 4 + KEEP(133) ) * KEEP(34) ) / & ( KEEP(133) * KEEP(151) ) ENDIF IF (INFO(1) .LT.0 ) GOTO 111 MSG_MAX_BYTES_SOLVE = int(MSG_MAX_BYTES_SOLVE8) C ------------------------------------------ C Compute an upperbound of message size C for DMUMPS_GATHER_SOLUTION. Except C possibly on the non working host, it C should be smaller than MSG_MAX_BYTES_SOLVE C ------------------------------------------ IF (KEEP(237).EQ.0) THEN C Note that for DMUMPS_GATHER_SOLUTION LBUFR buffer should C be larger that MAX_inode(NPIV))*NBRHS + NPIV C which is covered by next formula since KMAX_246_247 is larger C than MAX_inode(NPIV)) C 2 integers packed (npiv and termination) C Note that MSG_MAX_BYTES_GTHRSOL < MSG_MAX_BYTES_SOLVE C so that it should not overflow KMAX_246_247 = max(KEEP(246),KEEP(247)) MSG_MAX_BYTES_GTHRSOL = ( 2 + KMAX_246_247 ) * KEEP(34) + & KMAX_246_247 * NBRHS * KEEP(149) ELSE IF (ICNTL21.EQ.0) THEN C Each message from a slave is of size max 4: C 2 integers : I,J C 1 complex : (Aij)-1 C 1 terminaison MSG_MAX_BYTES_GTHRSOL = ( 3 * KEEP(34) + KEEP(149) ) ELSE C Not needed in case of distributed solution and A-1 C because the entries of A −1 are C returned in RHS SPARSE on the host. MSG_MAX_BYTES_GTHRSOL = 0 ENDIF C The buffer is used both for solve and for DMUMPS_GATHER_SOLUTION LBUFR_BYTES = max(MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL) TSIZE = int(min(100_8*int(MSG_MAX_BYTES_GTHRSOL,8), & 10000000_8)) LBUFR_BYTES = max(LBUFR_BYTES,TSIZE) LBUFR = ( LBUFR_BYTES + KEEP(34) - 1 ) / KEEP(34) ALLOCATE (BUFR(LBUFR),stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ' Problem in solve: error allocating BUFR' ENDIF INFO(1) = -13 INFO(2) = LBUFR GOTO 111 ENDIF NB_BYTES = NB_BYTES + int(size(BUFR),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( I_AM_SLAVE .AND. id%NSLAVES .GT. 1 ) THEN C ------------------------------------------------------ C Dimension send buffer for small integers, e.g. TRACINE C ------------------------------------------------------ DMUMPS_LBUF_INT = ( 20 + id%NSLAVES * id%NSLAVES * 4 ) & * KEEP(34) CALL MUMPS_BUF_ALLOC_SMALL_BUF( DMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = DMUMPS_LBUF_INT IF ( LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating small Send buffer:IERR=',IERR END IF GOTO 111 END IF C C --------------------------------------- C Dimension cyclic send buffer for normal C messages, based on largest message C size during forward and backward solves C --------------------------------------- C Compute buffer size in BYTES (DMUMPS_LBUF) C using integer8 in DMUMPS_LBUF_8 C then convert it in integer4 and bound it to largest integer value C DMUMPS_LBUF_8 = & (int(MSG_MAX_BYTES_SOLVE,8)+2_8*int(KEEP(34),8))* & int(id%NSLAVES,8) C Avoid buffers larger than 100 Mbytes ... DMUMPS_LBUF_8 = min(DMUMPS_LBUF_8, 100000000_8) C ... as long as we can send messages to at least 3 C destinations simultaneously DMUMPS_LBUF_8 = max(DMUMPS_LBUF_8, & int((MSG_MAX_BYTES_SOLVE+2*KEEP(34)),8) * & int(min(id%NSLAVES,3),8) ) DMUMPS_LBUF_8 = DMUMPS_LBUF_8 + 2_8*int(KEEP(34),8) C Convert to integer and bound it to largest 32-bit integer C and suppress 10 integers (one should be enough!) C to enable computation of integer size. DMUMPS_LBUF_8 = min(DMUMPS_LBUF_8, & int(huge(I4),8) & - 10_8*int(KEEP(34),8) & ) DMUMPS_LBUF = int(DMUMPS_LBUF_8, kind(DMUMPS_LBUF)) CALL MUMPS_BUF_ALLOC_CB( DMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = DMUMPS_LBUF/KEEP(34) + 1 IF ( LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating Send buffer:IERR=', IERR END IF GOTO 111 END IF C C C -- end of I am slave ENDIF C IF ( POSTPros ) THEN C When Iterative refinement of error analysis requested C Allocate RHS_IR on slave processors C (note that on MASTER RHS_IR points to RHS) IF ( id%MYID .NE. MASTER ) THEN C ALLOCATE(RHS_IR(id%N),stat=IERR) NB_BYTES = NB_BYTES + int(size(RHS_IR),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( IERR .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) THEN WRITE(LP,*) 'ERROR while allocating RHS on a slave' ENDIF GOTO 111 END IF ELSE RHS_IR=>id%RHS ENDIF ENDIF C C Parallel A-1 or General sparse and C exploit sparsity between columns DO_NBSPARSE = ( ( (KEEP(237).NE.0).OR.(KEEP(235).NE.0) ) & .AND. & ( KEEP(497).NE.0 ) & ) IF ( I_AM_SLAVE ) THEN IF(DO_NBSPARSE) THEN c --- ALLOCATE outside loop RHS_BOUNDS is needed LPTR_RHS_BOUNDS = 2*KEEP(28) ALLOCATE(RHS_BOUNDS(LPTR_RHS_BOUNDS), STAT=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=LPTR_RHS_BOUNDS IF (LPOK) THEN WRITE(LP,*) 'ERROR while allocating RHS_BOUNDS on', & ' a slave' ENDIF GOTO 111 END IF NB_BYTES = NB_BYTES + & int(size(RHS_BOUNDS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) PTR_RHS_BOUNDS => RHS_BOUNDS ELSE LPTR_RHS_BOUNDS = 1 PTR_RHS_BOUNDS => IDUMMY_TARGET ENDIF ENDIF C -------------------------------------------------- IF ( I_AM_SLAVE ) THEN IF ((KEEP(221).EQ.2 .AND. KEEP(252).EQ.0)) THEN C -- RHSINTR must have been allocated in C -- previous solve step (with option KEEP(221)=1) IF (.NOT.associated(id%RHSINTR)) THEN INFO(1) = -35 INFO(2) = 1 GOTO 111 ENDIF C IF ((KEEP(248).EQ.0) .OR. (id%NRHS.EQ.1)) THEN C GLOB2LOC_RHS/SOL are meaningful and could even be reused IF (.NOT.associated(id%GLOB2LOC_RHS) ) ! .OR. ! & .NOT.(id%GLOB2LOC_SOL_ALLOC)) & THEN INFO(1) = -35 INFO(2) = 2 GOTO 111 ENDIF IF (.not.id%GLOB2LOC_SOL_ALLOC) THEN C GLOB2LOC_SOL that is kept from C previous call to solve must then (already) C point to id%GLOB2LOC_RHS id%GLOB2LOC_SOL => id%GLOB2LOC_RHS ENDIF ELSE C ---------------------- C Allocate GLOB2LOC_RHS/SOL C ---------------------- C The size of POSINRHSINTR arrays C does not depend on the block of RHS C GLOB2LOC_RHS/SOL are initialized in the loop of RHS IF (associated(id%GLOB2LOC_RHS)) THEN NB_BYTES = NB_BYTES - & int(size(id%GLOB2LOC_RHS),8)*K34_8 DEALLOCATE(id%GLOB2LOC_RHS) ENDIF ALLOCATE (id%GLOB2LOC_RHS(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 END IF NB_BYTES = NB_BYTES + & int(size(id%GLOB2LOC_RHS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%GLOB2LOC_SOL_ALLOC) THEN NB_BYTES = NB_BYTES - & int(size(id%GLOB2LOC_SOL),8)*K34_8 DEALLOCATE(id%GLOB2LOC_SOL) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF C IF ( (KEEP(50).EQ.0).OR.(KEEP(237).NE.0).OR. & (KEEP(212).NE.0) & ) THEN ALLOCATE (id%GLOB2LOC_SOL(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 END IF id%GLOB2LOC_SOL_ALLOC = .TRUE. NB_BYTES = NB_BYTES + & int(size(id%GLOB2LOC_SOL),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE C Do no allocate GLOB2LOC_SOL id%GLOB2LOC_SOL => id%GLOB2LOC_RHS id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF IF (KEEP(221).NE.2) THEN C -- only in the case of bwd after C -- fwd only (with or without Schur) C -- we have to keep "old" RHSINTR IF (associated(id%RHSINTR)) THEN NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25) = 0_8 id%LD_RHSINTR = 0 ENDIF ENDIF ENDIF C --------------------------- C Allocate local workspace C for the solve (DMUMPS_SOL_C) C --------------------------- LIWK_SOLVE = 2 * KEEP(28) + id%NA(1)+1 LIWK_PTRACB= KEEP(28) C KEEP(228)+1 temporary integer positions C will be needed in DMUMPS_SOL_S IF (KEEP(201).EQ.1) THEN LIWK_SOLVE = LIWK_SOLVE + KEEP(228) + 1 ELSE C Reserve 1 position to pass array of size 1 in routines LIWK_SOLVE = LIWK_SOLVE + 1 ENDIF ALLOCATE ( IWK_SOLVE(LIWK_SOLVE), & PTRACB(LIWK_PTRACB), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWK_SOLVE + LIWK_PTRACB*KEEP(10) GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWK_SOLVE,8)*K34_8 + & int(LIWK_PTRACB,8)*K34_8 *int(KEEP(10),8) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C array IWCB used temporarily to hold C indices of a front unpacked from a message C and to stack (potentially in a recursive call) C headers of size 2 positions of CB blocks. LIWCB = 20*NB_K133*2 + KEEP(133) ALLOCATE ( IWCB( LIWCB), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWCB GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWCB,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C C -- Code for a slave C ----------- C Subdivision C of array IS C ----------- LIW = KEEP(32) C Define a work array of size maximum global frontal C size (KEEP(133)) for the call to DMUMPS_SOL_C C This used to be of size id%N. ALLOCATE(SRW3(KEEP(133)), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=KEEP(133) GOTO 111 END IF NB_BYTES = NB_BYTES + int(KEEP(133),8)*K151_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ----------------- C End of slave code C ----------------- ELSE C I am the master with host not working C C LIW is used on master when calling C the routine DMUMPS_GATHER_SOLUTION. LIW=0 END IF C C Precompute inverse of UNS_PERM outside loop IF (allocated(UNS_PERM_INV)) DEALLOCATE(UNS_PERM_INV) UNS_PERM_INV_NEEDED_INMAINLOOP = .FALSE. IF ( ( id%MYID .eq. MASTER.AND.(KEEP(23).GT.0) .AND. & (MTYPE .NE. 1).AND.(KEEP(248).NE.0) & ) C Permute UNS_PERM on master only with C sparse RHS (KEEP(248).NE.0 ) when AT x = b is solved & .OR. ( KEEP(237).NE.0 .AND. KEEP(23).NE.0 ) C When A-1 is active and when the matrix is unsymmetric C and a column permutation has been applied (Max transversal) C then we have performed a C factorization of a column permuted matrix AQ = LU. C In this case, C the permuted entry must be used to select the target C entries for the BWD (note that a diagonal entry of A-1 C is not anymore a diagonal of AQ. Thus a diagonal C of A-1 does not correspond to the same path C in the tree during FWD and BWD steps when MAXTRANS is on C and permutation is not identity.) C Note that the inverse permutation C UNS_PERM_INV needs to be allocated on each proc C since it is used in DMUMPS_SOL_C routine for pruning. C It is allocated only once and its allocation has been C migrated outside the blocking on the right hand sides. & ) THEN UNS_PERM_INV_NEEDED_INMAINLOOP = .TRUE. ENDIF UNS_PERM_INV_NEEDED_BEFMAINLOOP = .FALSE. IF (KEEP(23) .GT. 0 .AND. MTYPE.EQ.1 .AND. ICNTL21.EQ.2) THEN UNS_PERM_INV_NEEDED_INMAINLOOP = .TRUE. ENDIF IF ( KEEP(23) .GT.0 .AND. & MTYPE .NE. 1 .AND. KEEP(248).EQ.-1 ) THEN C Similar to sparse RHS case, we need to modify IRHS_loc C indices in the distributed RHS case. However, we need C UNS_PERM_INV on all processors. But only before the C main loop on the RHS blocks. UNS_PERM_INV_NEEDED_BEFMAINLOOP = .TRUE. ENDIF C UNS_PERM_INV_NEEDED_ONSLAVES = .FALSE. IF ( UNS_PERM_INV_NEEDED_INMAINLOOP .OR. & UNS_PERM_INV_NEEDED_BEFMAINLOOP ) THEN C We need UNS_PERM_INV ALLOCATE(UNS_PERM_INV(id%N),stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 endif NB_BYTES = NB_BYTES + int(id%N,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.EQ.MASTER) THEN C Build inverse permutation DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I ENDDO ENDIF C ELSE ALLOCATE(UNS_PERM_INV(1), stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=1 GOTO 111 endif NB_BYTES = NB_BYTES + 1_8*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C 111 CONTINUE #if defined(V_T) CALL VTEND(glob_comm_ini,IERR) #endif C C Synchro point + Broadcast of errors C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C C UNS_PERM_INV needed on slaves: IF ( KEEP(23).NE.0 .AND. & ( KEEP(237).NE.0 .OR. & ( MTYPE.NE.1 .AND. KEEP(248).EQ.-1 ) .OR. & ( MTYPE.EQ.1 .AND. ICNTL21.EQ.2) & ) & ) THEN UNS_PERM_INV_NEEDED_ONSLAVES = .TRUE. ENDIF IF (UNS_PERM_INV_NEEDED_ONSLAVES) THEN C Broadcast UNS_PERM_INV CALL MPI_BCAST( UNS_PERM_INV,id%N,MPI_INTEGER,MASTER, & id%COMM,IERR ) ENDIF C ------------------------------- C BEGIN C Preparation for distributed RHS C ------------------------------- IF (I_AM_SLAVE .AND. KEEP(248).EQ.-1 & ) THEN C Distributed RHS case ALLOCATE(MAP_RHS_loc(max(id%Nloc_RHS,1)), stat=allocok) IF (allocok .GT. 0) THEN id%INFO(1)=-13 id%INFO(2)=max(id%Nloc_RHS,1) GOTO 20 ENDIF NB_BYTES = NB_BYTES + max(int(id%Nloc_RHS,8),1_8)*K34_8 ENDIF C MAP_RHS_loc will be built in the main C loop, when processing the first block. C It requires POSINRHSINTR to be built. BUILD_RHSMAPINFO = .TRUE. 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT.0 ) GOTO 90 C In case of Unsymmetric column permutation and C transpose system, use MUMPS internal indices C for IRHS_loc_PTR. Done before scaling since C scaling is on permuted matrix IF ( I_AM_SLAVE .AND. KEEP(23).GT.0 .AND. KEEP(248).EQ.-1 & .AND. MTYPE.NE.1 & ) THEN IF (id%Nloc_RHS .GT. 0) THEN ALLOCATE(IRHS_loc_PTR(id%Nloc_RHS),stat=allocok) IF (allocok.GT.0) THEN INFO(1)=-13 INFO(2)=id%Nloc_RHS GOTO 25 ENDIF IRHS_loc_PTR_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + max(int(id%Nloc_RHS,8),1_8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) DO I=1, id%Nloc_RHS IF (id%IRHS_loc(I).GE.1 .AND. id%IRHS_loc(I).LE.id%N) & THEN IRHS_loc_PTR(I)=UNS_PERM_INV(id%IRHS_loc(I)) ELSE C Keep track of out-of range entries IRHS_loc_PTR(I)=id%IRHS_loc(I) ENDIF ENDDO ENDIF ENDIF C Check if UNS_PERM_INV still needed C to free memory IF (UNS_PERM_INV_NEEDED_BEFMAINLOOP .AND. & .NOT. UNS_PERM_INV_NEEDED_INMAINLOOP) THEN NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 DEALLOCATE(UNS_PERM_INV) ALLOCATE(UNS_PERM_INV(1)) ! to posibly pass it as an argument NB_BYTES = NB_BYTES + K34_8 ENDIF #if defined(USE_OLD_SCALING) IF (LSCAL .AND. id%KEEP(248).EQ.-1 & ) THEN C Scaling done based on original indices C provided by user IF (MTYPE == 1) THEN C No transpose scaling_data_dr%SCALING=>id%ROWSCA ELSE C Transpose scaling_data_dr%SCALING=>id%COLSCA ENDIF CALL DMUMPS_SET_SCALING_LOC( scaling_data_dr, id%N, & IRHS_loc_PTR(1), id%Nloc_RHS, & id%COMM, id%MYID, I_AM_SLAVE, MASTER, & NB_BYTES, NB_BYTES_MAX, K16_8, LP, LPOK, & ICNTL(1), INFO(1) ) ENDIF #endif C ------------------------------- C END C Preparation for distributed RHS C ------------------------------- 25 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT.0 ) GOTO 90 C ------------------------------------- C BEGIN C Preparation for distributed solution C ------------------------------------- IF ( ICNTL21 .NE. 0 ) THEN C{ #if defined(USE_OLD_SCALING) IF (LSCAL) THEN C{ In case of scaling we will need to scale C back the sol. Put the values of the scaling C arrays needed to do that on each processor. IF (id%MYID.NE.MASTER) THEN IF (MTYPE == 1) THEN ALLOCATE(id%COLSCA(id%N),stat=allocok) ELSE ALLOCATE(id%ROWSCA(id%N),stat=allocok) ENDIF IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating temporary scaling array' ENDIF INFO(1)=-13 INFO(2)=id%N GOTO 37 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ! MYID .NE. MASTER 37 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data_sol%SCALING_LOC(max(1,id%KEEP(89))), & stat=allocok) IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating local scaling array' ENDIF INFO(1)=-13 INFO(2)=max(1,id%KEEP(89)) GOTO 38 ENDIF IF (ICNTL21.NE.0) THEN C Real entries for scaling NB_BYTES = NB_BYTES + int(max(1,id%KEEP(89)),8)*K16_8 ENDIF NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ! I_AM_SLAVE 38 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) THEN GOTO 90 ENDIF IF (MTYPE == 1) THEN CALL MPI_BCAST(id%COLSCA(1),id%N, & MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) scaling_data_sol%SCALING=>id%COLSCA ELSE CALL MPI_BCAST(id%ROWSCA(1),id%N, & MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) scaling_data_sol%SCALING=>id%ROWSCA ENDIF C} ENDIF ! LSCAL #endif IF ( ICNTL21.EQ.1 .AND. I_AM_SLAVE & ) THEN C -------------------------------- C Prepare ISOL_loc array #if defined(USE_OLD_SCALING) C and on the fly, scaling_data_sol #endif C -------------------------------- LIW_PASSED=max(1,LIW) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF (KEEP(89) .GT. 0) THEN CALL DMUMPS_DISTSOL_INDICES( MTYPE, id%ISOL_loc(1), & id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%IS(1), LIW_PASSED,id%MYID_NODES, & id%N, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES, #if defined(USE_OLD_SCALING) & scaling_data_sol, LSCAL, #endif C For checking only & (KEEP(248).EQ.-1), IRHS_loc_PTR(1), id%Nloc_RHS & ) ENDIF ENDIF ! I_AM_SLAVE #if defined(USE_OLD_SCALING) #endif #if defined(USE_OLD_SCALING) IF (id%MYID.NE.MASTER .AND. LSCAL) THEN C --------------------------------- C Local (small) scaling arrays have C been built, free temporary copies C --------------------------------- IF (MTYPE == 1) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ELSE DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF NB_BYTES = NB_BYTES - int(id%N,8)*K16_8 ENDIF #endif C} ENDIF ! ICNTL21 .NE. 0 IF (ICNTL21 .EQ.1) THEN C --------------------------------------------------- C Take into account unsymmetric permutation to modify C ISOL_loc, in case ISOL_loc is provided by MUMPS C --------------------------------------------------- IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN C Broadcast the unsymmetric permutation and C permute the indices in ISOL_loc IF (id%MYID.NE.MASTER) THEN ALLOCATE(id%UNS_PERM(id%N),stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=id%N GOTO 40 ENDIF ENDIF ENDIF C C ===================== ERROR handling and propagation ================ 40 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN CALL MPI_BCAST(id%UNS_PERM(1),id%N,MPI_INTEGER,MASTER, & id%COMM,IERR) IF (I_AM_SLAVE) THEN DO I=1, KEEP(89) id%ISOL_loc(I) = id%UNS_PERM(id%ISOL_loc(I)) ENDDO ENDIF IF (id%MYID.NE.MASTER) THEN DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF ENDIF ENDIF ! ICNTL(21)=1 C -------------------------------------- C Preparation for distributed solution C END C -------------------------------------- C --------------------------------------------- C In case of Schur, preparation for reduced RHS C --------------------------------------------- IF ( (KEEP(60).NE.0) .AND. & ( & ( KEEP(221) .EQ. 1 ) .OR. & ( KEEP(221) .EQ. 2 ) & ) & ) THEN C -- First compute MASTER_ROOT_IN_COMM proc number in C COMM_NODES on which is mapped the master of the root. IF (KEEP(46).EQ.1) THEN MASTER_ROOT_IN_COMM=MASTER_ROOT ELSE MASTER_ROOT_IN_COMM =MASTER_ROOT+1 ENDIF IF ( id%MYID .EQ. MASTER ) THEN C -------------------------------- C Avoid using LREDRHS when id%NRHS is C equal to 1, as was done for RHS C -------------------------------- IF (id%NRHS.EQ.1) THEN LD_REDRHS = id%KEEP(116) ELSE LD_REDRHS = id%LREDRHS ENDIF ENDIF IF (MASTER.NE.MASTER_ROOT_IN_COMM) THEN C -- Make available LD_REDRHS on MASTER_ROOT_IN_COMM C This will then be used to test if a single C message can be sent C (this is possible if LD_REDRHS=SIZE_SCHUR) IF ( id%MYID .EQ. MASTER ) THEN C -- send LD_REDRHS to MASTER_ROOT_IN_COMM C using COMM communicator CALL MPI_SEND(LD_REDRHS,1,MPI_INTEGER, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSEIF ( id%MYID.EQ.MASTER_ROOT_IN_COMM) THEN C -- recv LD_REDRHS CALL MPI_RECV(LD_REDRHS,1,MPI_INTEGER, & MASTER, 0, id%COMM,STATUS,IERR) ENDIF C -- other procs not concerned ENDIF ENDIF C IF ( KEEP(248)==1 & ) THEN ! Sparse RHS (A-1 or general sparse) ! JBEG_RHS - current starting column within A-1 or sparse rhs ! set in the loop below and used to obtain the ! global index of the column of the sparse RHS ! Also used to get index in global permutation. ! It also allows to skip empty columns; JEND_RHS = 0 ! last column in current blockin A-1 C C Compute and apply permutations IF (DO_PERMUTE_RHS) THEN C Allocate PERM_RHS ALLOCATE(PERM_RHS(id%NRHS),stat=allocok) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = id%NRHS GOTO 109 ENDIF NB_BYTES = NB_BYTES + int(id%NRHS,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.EQ.MASTER) THEN C PERM_RHS is computed on MASTER, it might be modified C in case of interleaving and will thus be distributed C (BCAST) to all slaves only later. C Compute PERM_RHS C on output: PERM_RHS(k) = i means that i is the kth column C to be processed IF (KEEP(237).EQ.0) THEN C Permute RHS : case of GS (General Sparse) RHS C IRHS_SPARSE is of size at least NZ_RHS > 0 C since all this is skipped when NZ_RHS=0. So C accessing IRHS_SPARSE(1) is ok. CALL DMUMPS_PERMUTE_RHS_GS( & LP, LPOK, PROKG, MPG, KEEP(242), & id%SYM_PERM(1), id%N, id%NRHS, & id%IRHS_PTR(1), id%NRHS+1, & id%IRHS_SPARSE(1), id%NZ_RHS, & PERM_RHS, IERR) IF (IERR.LT.0) THEN INFO(1) = -9999 INFO(2) = IERR GOTO 109 ! propagate error ENDIF ELSE C Case of A-1 : C We compute the permutation of the RHS (sparse matrix) C (to compute all inverse entries) C We apply permutation to IRHS_SPARSE ONLY. C Note NRHS_NONEMPTY holds the nb of non empty columns C in A-1. STRAT_PERMAM1 = KEEP(242) CALL DMUMPS_PERMUTE_RHS_AM1 & (STRAT_PERMAM1, id%SYM_PERM(1), & id%IRHS_PTR(1), id%NRHS+1, & PERM_RHS, id%NRHS, & IERR & ) ENDIF ENDIF ENDIF ENDIF C C Note that within DMUMPS_SOL_C, PERM_RHS could be used C for A-1 case (with DO_PERMUTE_RHS OR INTERLEAVE_RHS C being tested) to get the column index for the C original matrix of RHS (column index in A-1) C of the permuted columns that have been selected. C PERM_RHS is also used in DMUMPS_GATHER_SOLUTION C in case of sparse RHS awith DO_PERMUTE_RHS. C C Allocate PERM_RHS of size 1 if not allocated IF (.NOT. allocated(PERM_RHS)) THEN ALLOCATE(PERM_RHS(1),stat=allocok) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = 1 GOTO 109 ENDIF NB_BYTES = NB_BYTES + int(size(PERM_RHS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C Propagate errors 109 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 c -------------------------- c -------------------------- IF (id%NSLAVES .EQ. 1) THEN C{ - In case of NS/A-1 we may want to permute RHS C - for NS thus is to apply permutation to PIVNUL_LIST C - before starting loop of NBRHS IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN C NOTE: C when host not working both master and slaves have C in this case the complete list WRITE(*,*) id%MYID, ':INTERNAL ERROR 1 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF ! End Permute_RHS C} ELSE IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 2 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() C ENDIF ! End DO_PERMUTE_RHS IF (INTERLEAVE_PAR.AND. (KEEP(111).NE.0)) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 3 : ', & ' INTERLEAVE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF IF (INTERLEAVE_PAR.AND.KEEP(111).EQ.0 & ) THEN C - A-1 + Interleave: C permute RHS on master IF (id%MYID.EQ.MASTER) THEN C -- PERM_RHS must have been already set or initialized C -- it is then modified in next routine SIZE_WORKING = id%IPTR_WORKING(id%NPROCS+1)-1 SIZE_IPTR_WORKING = id%NPROCS+1 CALL DMUMPS_INTERLEAVE_RHS_AM1( & PERM_RHS, id%NRHS, & id%IPTR_WORKING(1), SIZE_IPTR_WORKING, & id%WORKING(1), SIZE_WORKING, & id%IRHS_PTR(1), & id%STEP(1), id%SYM_PERM(1), id%N, NBRHS, & id%PROCNODE_STEPS(1), KEEP(28), id%NSLAVES, & KEEP(199), & KEEP(493).NE.0, & KEEP(495).NE.0, KEEP(496), PROKG, MPG & ) ENDIF ! End Master ENDIF ! End A-1 and INTERLEAVE_PAR C ------------- ENDIF ! End Parallel Case c -------------------------- c IF (DO_PERMUTE_RHS.AND.(KEEP(111).EQ.0)) THEN C --- Distribute PERM_RHS before loop of RHS C --- (with null space option PERM_RHS is not allocated / needed C to permute the null column pivot list) CALL MPI_BCAST(PERM_RHS(1), & id%NRHS, & MPI_INTEGER, & MASTER, id%COMM,IERR) ENDIF C L0-threads to be activated iff KEEP(401)=1 and KEEP(400)>0 IF (KEEP(401) .EQ. 1) THEN C L0-threads was requested for solve phase C and will be effective only if KEEP(400) >0 C which indicates that L0-threads was C performed during analysis+factorization IF ( KEEP(400) .GT. 0 .AND. KEEP(369).EQ.0 ) THEN C{ Check if number of threads is consistent with C the one used during factorization for all procs C Note that if KEEP(369)>0 C KEEP(400) was set based on C KEEP(369) and KEEP(381) so that C omp_set_num_threads(KEEP(400)) will be called C explicitly before L0_OMP section C and KEEP(400) cannot be check here in this way C NOMP = 1 !$ NOMP=omp_get_max_threads() IF (KEEP(400).NE.NOMP) THEN C NOMP should be the one from analysis id%INFO(1) = -58 id%INFO(2) = KEEP(400) IF (LPOK) WRITE(LP,'(A,A,I5,A,I5)') &" FAILURE DETECTED IN SOLVE: #threads for multithreaded", &" tree parallelism changed from",KEEP(400)," at analysis to", & NOMP ENDIF C} ENDIF C error check CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 C} ENDIF IF (KEEP(400) .GT. 0) THEN CALL MUMPS_SOL_L0OMP_LI(KEEP(400)) ENDIF C ============================== C MAIN LOOP: C BLOCKING ON the number of RHS C We work on a maximum of NBRHS at a time. C the leading dimension of RHS is id%LRHS on master C and is set to N on slaves C ============================== C We may want to allow to have NBRHS that varies C this is typically the case when a partitionning of C the right hand side is performed and leads to C irregular partitions. C We only have to be sure that the size of each partition C is smaller than NBRHS. BEG_RHS=1 DO WHILE (BEG_RHS.LE.NRHS_NONEMPTY) C { CALL MUMPS_STOP_ON_USER_REQUEST( id%KEEP, id%KEEP8, id%ICNTL, & id%INFO, id%MYID ) CALL MUMPS_PROPINFO( id%ICNTL, id%INFO, id%COMM, id%MYID ) IF (id%INFO(1). LT. 0) GOTO 90 C ========================== C -- NBRHS : Original block size C -- BEG_RHS : Column index of the first RHS in the list of C non empty RHS (RHS_loc) to C be processed during this iteration C -- NBRHS_EFF : Effective block size at current iteration C that will be set to nb of contiguous non empty C columns C In case of sparse RHS (KEEP(248)==1) NBRHS_EFF only refers to C non-empty columns and is used to compute NBCOL_INBLOC C -- NBCOL_INBLOC : the number of columns of sparse RHS needed C to get NBRHS_EFF non empty columns columns of C sparse RHS processed at each step C NBRHS_EFF = min(NRHS_NONEMPTY-BEG_RHS+1, NBRHS) C C Sparse RHS C Free space and reset pointers if needed IF (IRHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_SPARSE_COPY),8)*K34_8 DEALLOCATE(IRHS_SPARSE_COPY) IRHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_SPARSE_COPY) ENDIF IF (IRHS_PTR_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_PTR_COPY),8)*K34_8 DEALLOCATE(IRHS_PTR_COPY) IRHS_PTR_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_PTR_COPY) ENDIF IF (RHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(RHS_SPARSE_COPY),8)*K35_8 DEALLOCATE(RHS_SPARSE_COPY) RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_SPARSE_COPY) ENDIF C C =========================================================== C Set LD_RHS and IBEG for the accesses to id%RHS (in cases C id%RHS is accessed). Remark that IBEG might still be C overwritten later, in case of general sparse right-hand side C and centralized solution to skip empty columns C =========================================================== IF ( C slave procs & ( id%MYID .NE. MASTER ) C even on master when RHS not allocated & .or. C Case of Master working but with distributed sol and C ( sparse RHS or null space ) C -- Allocate not needed on host not working & ( I_AM_SLAVE .AND. id%MYID .EQ. MASTER .AND. & ICNTL21 .NE.0 .AND. & ( KEEP(248).ne.0 .OR. KEEP(221).EQ.2 & .OR. KEEP(111).NE.0 ) & ) & .or. C Case of Master and C (compute entries of INV(A)) C Even when I am a master with host not working I C am in charge of gathering solution to scale it C and to copy it back in the sparse RHS format & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) C & ) THEN LD_RHS = id%N IBEG = 1 ELSE ! (id%MYID .eq. MASTER) IF ( associated(id%RHS) ) THEN C Leading dimension of RHS on master is id%LRHS LD_RHS = max(id%LRHS, id%N) ELSE C --- LRHS might not be defined (dont use it) LD_RHS = id%N ENDIF IBEG = int(BEG_RHS-1,8) * int(LD_RHS,8) + 1_8 ENDIF C JBEG_RHS might also be used in DISTRIBUTED_SOLUTION C even when RHS is not sparse on input. In this case, C there are no empty columns. (If RHS is sparse JBEG_RHS C is overwritten). JBEG_RHS = BEG_RHS C ========================================== C Shift empty columns in case of sparse RHS C ========================================== IF ( (id%MYID.EQ.MASTER) .AND. & KEEP(248)==1 & ) THEN C update position of JBEG_RHS on first non-empty C column of this block JBEG_RHS = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( id%IRHS_PTR(PERM_RHS(JBEG_RHS)) .EQ. & id%IRHS_PTR(PERM_RHS(JBEG_RHS)+1) ) C Empty column IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) & ) THEN C General sparse RHS (NOT A-1) and centralized solution C Set to zero part of the C solution corresponding to empty columns DO I=1, id%N id%RHS(int(PERM_RHS(JBEG_RHS) -1,8)*int(LD_RHS,8)+ & int(I,8)) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ELSE DO WHILE( id%IRHS_PTR(JBEG_RHS) .EQ. & id%IRHS_PTR(JBEG_RHS+1) ) IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) & ) THEN C Case of general sparse RHS (NOT A-1) and C centralized solution: set to zero part of C the solution corresponding to empty columns DO I=1, id%N id%RHS(int(JBEG_RHS -1,8)*int(LD_RHS,8) + & int(I,8)) = ZERO ENDDO ENDIF IF (KEEP(221).EQ.1) THEN IF (KEEP(60).NE.0) THEN C Fwd with Schur: reduced RHS set to ZERO DO I = 1, id%SIZE_SCHUR id%REDRHS(int(JBEG_RHS-1,8)*int(LD_REDRHS,8) + & int(I,8)) = ZERO ENDDO ENDIF ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR C Count nb of RHS columns skipped: useful for C * DMUMPS_DISTRIBUTED_SOLUTION to reset those C columns to zero. C * in case of reduced right-hand side, to set C corresponding entries of RHSINTR to 0 after C forward phase. NB_RHSSKIPPED = JBEG_RHS - (JEND_RHS + 1) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0) & .AND. (ICNTL21.EQ.0)) & THEN ! case of general sparse rhs with centralized solution, !set IBEG to shifted columns ! (after empty columns have been skipped) IBEG = int(JBEG_RHS-1,8) * int(LD_RHS,8) + 1_8 ENDIF ENDIF ! of if (id%MYID.EQ.MASTER) .AND. KEEP(248)==1 CALL MPI_BCAST( JBEG_RHS, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C C Shift on REDRHS in reduced RHS functionality C IF (id%MYID.EQ.MASTER .AND. KEEP(221).NE.0 & .AND. KEEP(60).NE.0 ) THEN C Initialize IBEG_REDRHS C Note that REDRHS always has id%NRHS Colmuns IBEG_REDRHS= int(JBEG_RHS-1,8)*int(LD_REDRHS,8) + 1_8 ELSE IBEG_REDRHS=-142424_8 ! Should not be used ENDIF C C ===================== C BEGIN C Prepare RHS on master C #if defined(V_T) CALL VTBEGIN(perm_scal_ini,IERR) #endif IF (id%MYID .eq. MASTER) THEN C{ ====================== IF (KEEP(248)==1 & ) THEN C{ ====================== C C Sparse RHS format ( A-1 or sparse centralized input format) C is provided as input by the user (IRHS_SPARSE ...) C -------------------------------------------------- C Compute NZ_THIS_BLOCK and NBCOL_INBLOC C where C NZ_THIS_BLOCK is defined C as the number of entries in the next NBRHS_EFF C non empty columns (note that since they might be permuted C then the following formula is not always valid: C NZ_THIS_BLOCK=id%IRHS_PTR(BEG_RHS+NBRHS_EFF)- C & id%IRHS_PTR(BEG_RHS) C anyway NBCOL_INBLOC also need be computed so going through C columns one at a time is needed. C NBCOL = 0 NBCOL_INBLOC = 0 NZ_THIS_BLOCK = 0 C With exploit sparsity we skip empty columns up to reaching C the first non empty column; then we process a block of C maximum size NBRHS_EFF except if we reach another empty C column. (We are not sure to have a copy allocated C and thus cannot compress on the fly, as done naturally C for A-1) C For A-1 we process NBRHS_EFF non empty columns C in the bloc that contains NBCOL_INBLOC columns C (empty+non empty) STOP_AT_NEXT_EMPTY_COL = .FALSE. DO I=JBEG_RHS, id%NRHS NBCOL_INBLOC = NBCOL_INBLOC +1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN C PERM_RHS(k) = i means that i is the kth C column to be processed C PERM_RHS should also be defined for C empty columns i in A-1 (PERM_RHS(K) = i) COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) ELSE COLSIZE = id%IRHS_PTR(I+1) - id%IRHS_PTR(I) ENDIF IF ((.NOT.STOP_AT_NEXT_EMPTY_COL).AND.(COLSIZE.GT.0).AND. & (KEEP(237).EQ.0)) THEN C -- set STOP_NEXT_EMPTY_COL only for general C -- sparse case (not AM-1) STOP_AT_NEXT_EMPTY_COL =.TRUE. ENDIF IF (COLSIZE.GT.0 C{ & ) THEN NBCOL = NBCOL+1 NZ_THIS_BLOCK = NZ_THIS_BLOCK + COLSIZE C} ELSE IF (STOP_AT_NEXT_EMPTY_COL) THEN C{ We have reached an empty column with already selected non empty C columns: reduce block size to non empty columns reached so far. NBCOL_INBLOC = NBCOL_INBLOC -1 C Note that NBRHS_EFF is udated only on master NBRHS_EFF = NBCOL EXIT C} ENDIF IF (NBCOL.EQ.NBRHS_EFF) EXIT ENDDO IF (NZ_THIS_BLOCK.EQ.0) THEN WRITE(*,*) " Internal Error 16 in sol driver NZ_THIS_BLOCK=", & NZ_THIS_BLOCK CALL MUMPS_ABORT() ENDIF C IF (NBCOL.NE.NBRHS_EFF.AND. (KEEP(237).NE.0) & .AND.KEEP(221).NE.1) THEN C With exploit sparsity for general sparse RHS (Not A-1) C we skip empty rows up to reaching C the first non empty column; then we process a block of C maximum size NBRHS_EFF except if we reach another empty C column. (We are not sure to have a copy allocated C and thus cannot compress on the fly, as done naturally C for A-1). Thus NBCOL might be smaller than NBRHS_EFF WRITE(6,*) ' Internal Error 8 in solution driver ', & NBCOL, NBRHS_EFF call MUMPS_ABORT() ENDIF C ------------------------------------------------------------- C IF (NZ_THIS_BLOCK .NE. 0) THEN C ----------------------------------------------------------- C We recall that C NBCOL_INBLOC is the number of columns of sparse RHS needed C to get NBRHS_EFF non empty columns: ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NBCOL_INBLOC+1 GOTO 30 endif IRHS_PTR_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 C ----------------------------------------------------------- C Initialize IRHS_PTR_COPY C compute local copy (compressed) of id%IRHS_PTR on Master IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 IRHS_PTR_COPY(J) = IPOS COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) IPOS = IPOS + COLSIZE ENDDO ELSE IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 IRHS_PTR_COPY(J) = IPOS COLSIZE = id%IRHS_PTR(I+1) & - id%IRHS_PTR(I) IPOS = IPOS + COLSIZE ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR IRHS_PTR_COPY(NBCOL_INBLOC+1)= IPOS IF ( IPOS-1 .NE. NZ_THIS_BLOCK ) THEN WRITE(*,*) "Error in compressed copy of IRHS_PTR" IERR = 99 call MUMPS_ABORT() ENDIF C ----------------------------------------------------------- C IRHS_SPARSE : do a copy or point to the original indices C C Check whether IRHS_SPARSE_COPY need be allocated IF (KEEP(23) .NE. 0 .and. MTYPE .NE. 1) THEN C AP = LU and At x = b ==> b need be permuted ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK) & ,stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 30 endif IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN C Columns are not contiguous and need be copied one by one C IRHS_SPARSE_COPY will hold a copy of contiguous permuted C columns so an explicit copy is needed. C IRHS_SPARSE_COPY is also allways allocated with A-1, C to enable receiving during mumps_gather_solution C . on the master in any order. ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) IF (allocok .GT.0 ) THEN IERR = 99 GOTO 30 ENDIF IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ENDIF C C Initialize IRHS_SPARSE_COPY IF (IRHS_SPARSE_COPY_ALLOCATED) THEN IF ( DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ) THEN IPOS = 1 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) DO K=0,COLSIZE-1 IRHS_SPARSE_COPY(IPOS+K) = & id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K) ENDDO IPOS = IPOS + COLSIZE ENDDO ELSE DO K=1,NZ_THIS_BLOCK IRHS_SPARSE_COPY(K) = id%IRHS_SPARSE( & id%IRHS_PTR(JBEG_RHS)+K-1) ENDDO ENDIF ELSE IRHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => & id%IRHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ENDIF #if defined(USE_OLD_SCALING) C Centralized scaling: perform scaling on master C in RHS_SPARSE_COPY IF (LSCAL.OR.DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN #else IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN #endif C if columns of the RHS are C permuted then a copy of RHS_SPARSE is needed. C Also always allocated with A-1, c to enable receiving during mumps_gather_solution C on the master in any order. C ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 30 ENDIF RHS_SPARSE_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE IF ( KEEP(248)==1 ) THEN RHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => id%RHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ELSE RHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => id%RHS_SPARSE(id%IRHS_PTR(BEG_RHS): & id%IRHS_PTR(BEG_RHS)+NZ_THIS_BLOCK-1) ENDIF ENDIF IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) THEN IF (id%KEEP(237).NE.0) THEN C --initialized to one #if defined(USE_OLD_SCALING) C it might be modified if scaling is on (one first entry C in each col is scaled) RHS_SPARSE_COPY = ONE #else C Local scalings are used: RHSINTR is initialized C directly on the workers and RHS_SPARSE_COPY will C only be used during DMUMPS_GATHER_SOLUTION_AM1. #endif ELSE C -- Columns are not contiguous and need be copied one by one #if defined(USE_OLD_SCALING) C -- This need not be done if scaling is on because it C -- will done and scaled later. IF (.NOT. LSCAL) THEN #endif 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 DO K=0, COLSIZE-1 RHS_SPARSE_COPY(IPOS+K) = & id%RHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K) ENDDO IPOS = IPOS + COLSIZE ENDDO #if defined(USE_OLD_SCALING) ENDIF #endif ENDIF ENDIF C ========================= IF (KEEP(23) .NE. 0) THEN C ========================= * maximum transversal was performed IF (MTYPE .NE. 1) THEN * At x = b is asked while * we have AP = LU where P is the column permutation * due to max trans. * Therefore we need to modify rhs: * b' = P-1 b (P-1=Pt) * Apply column permutation to the right hand side RHS * Column J of the permuted matrix corresponds to * column PERMW(J) of the original matrix. * C ========== C SPARSE RHS : permute indices rather than values C ========== C Solve with At X = B should never occur for A-1 IPOS = 1 DO I=1, NBCOL_INBLOC C Note that: (i) IRHS_PTR_COPY is compressed; C (ii) columns might have been permuted COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) DO K = 1, COLSIZE JPERM = UNS_PERM_INV(IRHS_SPARSE_COPY(IPOS+K-1)) IRHS_SPARSE_COPY(IPOS+K-1) = JPERM ENDDO IPOS = IPOS + COLSIZE ENDDO ENDIF ! MTYPE.NE.1 ENDIF ! KEEP(23).NE.0 ENDIF ! NZ_THIS_BLOCK .NE. 0 C} ----- ENDIF ! ============ KEEP(248)==1 C} ----- ENDIF ! (id%MYID .eq. MASTER) C C ===================== ERROR handling and propagation ================ 30 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C C NBCOL_INBLOC depends on loop IF (KEEP(248)==1 & ) THEN CALL MPI_BCAST( NBCOL_INBLOC,1, MPI_INTEGER, & MASTER, id%COMM,IERR) ELSE NBCOL_INBLOC = NBRHS_EFF ENDIF JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN C Only case (in previous block) for which C NBRHS_EFF has been modified only on master ! case of general sparse: in case of empty columns ! modifed version of ! NBRHS_EFF need be broadcasted since it is used ! to update BEG_RHS at the end of the DO WHILE CALL MPI_BCAST( NBRHS_EFF,1, MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(NB_RHSSKIPPED,1,MPI_INTEGER,MASTER, & id%COMM,IERR) ENDIF IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0) & .AND.(KEEP(221).NE.2 ).AND.(KEEP(248).EQ.1) ) THEN C{ ---------------------------- C -- SPARSE RIGHT-HAND-SIDE C ---------------------------- CALL MPI_BCAST( NZ_THIS_BLOCK,1, MPI_INTEGER, & MASTER, id%COMM,IERR) IF (id%MYID.NE.MASTER .and. NZ_THIS_BLOCK.NE.0) THEN ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 45 endif IRHS_SPARSE_COPY_ALLOCATED=.TRUE. C RHS_SPARSE_COPY is broadcasted C for A-1 even if on the slaves the initialisation of the RHS C could be only based on the pattern. Doing so we C broadcast the scaled version of the RHS (scaling arrays C that are not available on slaves). ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 45 endif RHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*(K34_8+K35_8) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NBCOL_INBLOC+1 GOTO 45 endif IRHS_PTR_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C C ===================== ERROR handling and propagation ================ 45 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== IF (NZ_THIS_BLOCK > 0) THEN CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(IRHS_PTR_COPY(1), & NBCOL_INBLOC+1, & MPI_INTEGER, & MASTER, id%COMM,IERR) ENDIF C} ENDIF C C ========================================================= C INITIALIZE C - nodes_FWD and nodes_BWD C ========================================================= IF (FIRST_CALL_NODES_FWD_BWD) THEN C{ First time DMUMPS_NODES_FWD_BWD_SIZE_FILL C is called allocated Pruned_Sons_FWD IF (allocated(Pruned_Sons_FWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_FWD) * K34_8 DEALLOCATE(Pruned_Sons_FWD) ENDIF IF (allocated(Pruned_Sons_BWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_BWD) * K34_8 DEALLOCATE(Pruned_Sons_BWD) ENDIF ALLOCATE (Pruned_Sons_FWD(KEEP(28)), & Pruned_Sons_BWD(KEEP(28)), & stat=allocok) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)= 2*KEEP(28) ELSE NB_BYTES = NB_BYTES + & int(size(Pruned_Sons_FWD),8)*K34_8 + & int(size(Pruned_Sons_BWD),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C} ENDIF C ===================== ERROR handling and propagation ============== CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C===================================================================== C Reset FIRST_CALL_NODES_FWD_BWD for not allocating C (Pruned_Sons_FWD/BWD within loop) FIRST_CALL_NODES_FWD_BWD = .FALSE. C IF (CALL_NODES_FWD_BWD) THEN C{ fill = .FALSE. nodes_FWD_PTR => IDUMMY_TARGET Lnodes_FWD_PTR = 1 nodes_BWD_PTR => IDUMMY_TARGET Lnodes_BWD_PTR = 1 CALL DMUMPS_NODES_FWD_BWD_SIZE_FILL ( & fill, id%ICNTL(1), & id%N, id%KEEP(28), id%KEEP(1), & id%STEP(1), id%Step2node(1), & IRHS_loc_PTR(1), id%Nloc_RHS, & IRHS_PTR_COPY(1), NBCOL_INBLOC, IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, PERM_RHS, size(PERM_RHS), JBEG_RHS, & UNS_PERM_INV, size(UNS_PERM_INV), ! size 1 if not used & ICNTL21, & id%MYID, id%COMM, & id%INFO, & Pruned_Sons_FWD, Pruned_Sons_BWD, & Lnodes_FWD, Lnodes_BWD & , nodes_FWD_PTR(1), nodes_BWD_PTR(1) & , Lnodes_FWD_PTR, Lnodes_BWD_PTR & ) C C ALLOCATE nodes_FWD and nodes_BWD if needed C IF (Lnodes_FWD.GT.0) THEN C NBT is inout in MUMPS_REALLOC and should be initialized. NBT = 0 CALL MUMPS_REALLOC(nodes_FWD, Lnodes_FWD, id%INFO, LP, & FORCE=.FALSE., & STRING='nodes_FWD', MEMCNT=NBT, ERRCODE=-13) IF (INFO(1).LT.0) GOTO 46 C nodes_FWD_PTR => nodes_FWD Lnodes_FWD_PTR = Lnodes_FWD NB_BYTES = NB_BYTES + NBT NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE nodes_FWD_PTR => IDUMMY_TARGET Lnodes_FWD_PTR = 1 ENDIF IF (Lnodes_BWD.GT.0) THEN C NBT is inout in MUMPS_REALLOC and should be initialized. NBT = 0 CALL MUMPS_REALLOC(nodes_BWD, Lnodes_BWD, id%INFO, LP, & FORCE=.FALSE., & STRING='nodes_BWD', MEMCNT=NBT, ERRCODE=-13) IF (INFO(1).LT.0) GOTO 46 C nodes_BWD_PTR => nodes_BWD Lnodes_BWD_PTR = Lnodes_BWD NB_BYTES = NB_BYTES + NBT NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE nodes_BWD_PTR => IDUMMY_TARGET Lnodes_BWD_PTR = 1 ENDIF C C ===================== ERROR handling and propagation ============== 46 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C===================================================================== IF (Lnodes_FWD.GT.0 .OR. Lnodes_BWD.GT.0) THEN C{ C we build nodes_FWD_PTR and/or nodes_BWD_PTR C that will be used to prune flops C and even if one of the steps FWD/BWD does not C lead to pruning (in this case C POSTINRHS_COMP will not benefit from pruning). fill = .TRUE. CALL DMUMPS_NODES_FWD_BWD_SIZE_FILL ( & fill, id%ICNTL(1), & id%N, id%KEEP(28), id%KEEP(1), & id%STEP(1), id%Step2node(1), & IRHS_loc_PTR(1), id%Nloc_RHS, & IRHS_PTR_COPY(1), NBCOL_INBLOC, IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, PERM_RHS, size(PERM_RHS), JBEG_RHS, & UNS_PERM_INV, size(UNS_PERM_INV), ! size 1 if not used & ICNTL21, & id%MYID, id%COMM, & id%INFO, & Pruned_Sons_FWD, Pruned_Sons_BWD, & Lnodes_FWD, Lnodes_BWD & , nodes_FWD_PTR(1), nodes_BWD_PTR(1) & , Lnodes_FWD_PTR, Lnodes_BWD_PTR & ) C} ENDIF C ------------------------------------------------ C Update CALL_NODES_FWD_BWD and free workspace if C not used again in loop of RHS C ------------------------------------------------ IF ( & (KEEP(237) .NE. 0).OR. ! AM1 & ((KEEP(235) .NE. 0).AND.KEEP(248).NE.-1) ! GS & ) THEN C target nodes for chain pruning C need be updated in case of AM1 or General Sparse CALL_NODES_FWD_BWD = .TRUE. ELSE C all other cases including C distributed RHS and distributed solution CALL_NODES_FWD_BWD = .FALSE. ENDIF IF (.NOT. CALL_NODES_FWD_BWD & ) THEN C Not needed anymore in the loop of RHS IF (allocated(Pruned_Sons_FWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_FWD) * K34_8 DEALLOCATE(Pruned_Sons_FWD) ENDIF IF (allocated(Pruned_Sons_BWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_BWD) * K34_8 DEALLOCATE(Pruned_Sons_BWD) ENDIF C ELSE C deallocate later ENDIF C} ENDIF C ========================================================= C INITIALIZE C - GLOB2LOC_RHS/SOL, RHSINTR and related data C - For distributed RHS, initialize RHSMAPINFO (at 1st block) C ========================================================= C C Fwd in facto: in this case only POSINRHSINTR need be computed C C (GLOB2LOC_RHS/SOL indirection arrays should C have been allocated once outside loop) C Compute size of RHSINTR since it might depend C on the process index and of the sparsity of the RHS C if it is exploited. C Initialize GLOB2LOC_RHS/SOL C C Note that id%LD_RHSINTR and id%KEEP8(25) C are not set on the host in this routine in C the case of a non-working host. C Note that POSINRHSINTR is now always computed in SOL_DRIVER C at least during the first block of RHS when sparsity of RHS C is not exploited. C ------------------------------- C INITTIALZE GLOB2LOC_RHS/SOL C ------------------------------- C C next block ok for Schur only IF ( KEEP(221).EQ.2 .AND. KEEP(252).EQ.0 & .AND. (KEEP(248).NE.1 .OR. (id%NRHS.EQ.1)) & ) THEN C Reduced RHS (Schur feature) was already computed during C a previous forward step AND is valid. C By valid we mean: C -no forward in facto (KEEP(252)==0) during which C POSINRHSINTR was not computed C AND C -no exploit sparsity with multiple RHS C because in this case POSINRHSINTR would C be valid only for the last block processed during fwd. C In those cases since we only perform the backward step, c we do not need to compute POSINRHSINTR BUILD_POSINRHSINTR = .FALSE. ENDIF C ------------------------ C INITIALIZE POSINRHSINTR C ------------------------ IF (BUILD_POSINRHSINTR) THEN C{ -- we first set MTYPE_LOC and C -- reset BUILD_POSINRHSINTR for next iteration in loop C C general case only POSINRHSINTR is computed BUILD_POSINRHSINTR = .FALSE. ! POSINRHSINTR does not change between blocks MTYPE_LOC = MTYPE C IF ( (KEEP(111).NE.0) .OR. (KEEP(237).NE.0) .OR. & (KEEP(252).NE.0) ) THEN C IF (KEEP(111).NE.0) THEN C -- in the context of null space, we need to C -- build RHSINTR to skip SOL_R. Therefore C -- we need to know for each concerned C -- row index its position in C -- RHSINTR C We use row indices, as these are the ones that C were used to detect zero pivots during factorization. C GLOB2LOC_RHS will allow to find the (row) index of a C zero in RHSINTR before calling DMUMPS_SOL_S. Then C DMUMPS_SOL_S uses column indices to build the solution C (corresponding to null space vectors) MTYPE_LOC = 1 ELSE IF (KEEP(252).NE.0) THEN C -- Fwd in facto: since fwd is skipped we need to build POSINRHSINTR MTYPE_LOC = 1 ! (no transpose) ELSE C -- A-1 only MTYPE_LOC = MTYPE BUILD_POSINRHSINTR = .TRUE. ENDIF ENDIF C -- compute POSINRHSINTR LIW_PASSED=max(1,LIW) IF ( C no sparsity at fwd or bwd: & (Lnodes_FWD.EQ.-1).OR.(Lnodes_BWD.EQ.-1) C & ) THEN C C RHSINTR is not sparse (in the sense that it has N rows C distributed on the MPI procs) and thus POSINRHSINTR C does not change with loop. C Remarks: C 1/ sparsity might still be exploited during C fwd or bwd to reduce the number of operations. C 2/ BUILD_POSINRHSINTR = .FALSE. C IF ( I_AM_SLAVE ) THEN C{ CALL DMUMPS_BUILD_GLOB2LOC( & 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%GLOB2LOC_RHS(1), id%GLOB2LOC_SOL(1), & id%GLOB2LOC_SOL_ALLOC, & MTYPE_LOC, & NBENT_RHSINTR, NB_FS_RHSINTR_TOT ) NB_FS_RHSINTR_F = NB_FS_RHSINTR_TOT C} ENDIF C ELSE C C Note that POSINRHSINTR* need not be recomputed before IR : C because distributed solution => NO IR. C C Exploit sparsity in solution and RHS C (AM1 or (Sparse RHS and solution) ) C Since sparsity is exploited during C both fwd and bwd then we need to recompute C POSINRHSINTR only when CALL_NODES_FWD_BWD will C be performed at next iteration. IF (CALL_NODES_FWD_BWD) BUILD_POSINRHSINTR = .TRUE. C IF ( I_AM_SLAVE ) THEN C{ CALL DMUMPS_BUILD_GLOB2LOC_NODES_ES( & id%NSLAVES,id%N, & id%MYID_NODES, id%PTLUST_S(1), id%DAD_STEPS(1), & id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), id%IS(1), LIW, & id%STEP(1), C & Lnodes_FWD, Lnodes_BWD, & nodes_FWD_PTR(1), nodes_BWD_PTR(1), C & id%GLOB2LOC_RHS(1), id%GLOB2LOC_SOL(1), & id%GLOB2LOC_SOL_ALLOC, & MTYPE_LOC, & NBENT_RHSINTR, & NB_FS_RHSINTR_F, NB_FS_RHSINTR_TOT & ) C} ENDIF ENDIF C} ENDIF ! BUILD_POSINRHSINTR=.TRUE. IF (BUILD_RHSMAPINFO .AND. KEEP(248).EQ.-1 & ) THEN C C Prepare symbolic data for sends. C For the moment: only MAP_RHS_loc C C id%GLOB2LOC_RHS is always associated to the C forward step (with or without transposed system) IF ( I_AM_SLAVE ) THEN C{ CALL MUMPS_SOL_RHSMAPINFO( id%N, id%Nloc_RHS, id%KEEP(89), & IRHS_loc_PTR(1), MAP_RHS_loc, id%GLOB2LOC_RHS(1), & id%NSLAVES, id%MYID_NODES, & id%COMM_NODES, id%ICNTL(1), id%INFO(1) ) BUILD_RHSMAPINFO = .FALSE. C MUMPS_SOL_RHSMAPINFO does not propagate errors C} ENDIF ! I_AM_SLAVE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF ( BUILD_SCALING_RHSINTR ) THEN C{ IF (SCALING_RHSINTR_BWD_ALLOCATED) THEN NB_BYTES = NB_BYTES - LSCALING_RHSINTR_BWD * K16_8 DEALLOCATE(SCALING_RHSINTR_BWD) ENDIF IF (SCALING_RHSINTR_FWD_ALLOCATED) THEN NB_BYTES = NB_BYTES - LSCALING_RHSINTR_FWD * K16_8 DEALLOCATE(SCALING_RHSINTR_FWD) ENDIF NULLIFY(SCALING_RHSINTR_BWD) NULLIFY(SCALING_RHSINTR_FWD) SCALING_RHSINTR_BWD_ALLOCATED = .FALSE. SCALING_RHSINTR_FWD_ALLOCATED = .FALSE. SCALING_RHSINTR_BWD => RDUMMY_TARGET SCALING_RHSINTR_FWD => RDUMMY_TARGET LSCALING_RHSINTR_BWD = 1 LSCALING_RHSINTR_FWD = 1 C Define or allocate SCALING_RHSINTR if needed: IF (LSCAL .AND. I_AM_SLAVE ) THEN IF (KEEP(221).EQ.2) THEN C In case of sparsity during bwd, we cannot C rely on the value of Lnodes_FWD to know C whether the scaling will match SCALING_LOC C and should thus consider that (Lnodes_FWD.NE.-1) ES_RHSINTR = (Lnodes_BWD.NE.-1) ELSE C sparsity at fwd and at bwd: ES_RHSINTR = (Lnodes_FWD.NE.-1).AND.(Lnodes_BWD.NE.-1) ENDIF C Scaling allocations performed only if needed C Forward or normal solve: IF ( ES_RHSINTR ) THEN LSCALING_RHSINTR_FWD = max(1, NB_FS_RHSINTR_F ) ALLOCATE(SCALING_RHSINTR_FWD(LSCALING_RHSINTR_FWD), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=LSCALING_RHSINTR_FWD ELSE SCALING_RHSINTR_FWD_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + LSCALING_RHSINTR_FWD * K16_8 ENDIF ELSE C RHSINTR matches SCALING_loc, no need to C allocate and compute a different scaling LSCALING_RHSINTR_FWD = max(1,KEEP(89)) #if defined(USE_OLD_SCALING) #else SCALING_RHSINTR_FWD => SCALING_LOC_FWD #endif ENDIF IF (ES_RHSINTR) THEN LSCALING_RHSINTR_BWD = max(1, NB_FS_RHSINTR_TOT ) ALLOCATE(SCALING_RHSINTR_BWD(LSCALING_RHSINTR_BWD), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=LSCALING_RHSINTR_BWD ELSE SCALING_RHSINTR_BWD_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + LSCALING_RHSINTR_BWD * K16_8 ENDIF ELSE C RHSINTR matches SCALING_loc, no need to C allocate and compute a different scaling LSCALING_RHSINTR_BWD = max(1,KEEP(89)) #if defined(USE_OLD_SCALING) SCALING_RHSINTR_BWD => scaling_data_sol%SCALING_LOC #else SCALING_RHSINTR_BWD => SCALING_LOC_BWD SCALING_RHSINTR_FWD => SCALING_LOC_FWD #endif ENDIF ENDIF C} ENDIF CALL MUMPS_PROPINFO( id%ICNTL, id%INFO, id%COMM,id%MYID) IF (id%INFO(1) .LT.0 ) GOTO 90 IF (BUILD_SCALING_RHSINTR) THEN C{ IF ( LSCAL .AND. I_AM_SLAVE. AND. ES_RHSINTR ) THEN #if ! defined(USE_OLD_SCALING) C SCALING_RHSINTR_FWD has been allocated and should C now be filled. It is a compressed version of the C local scaling array SCALING_LOC_FWD: IF (MTYPE.eq.0 .AND. KEEP(50).EQ.0) THEN ! tranpose ROWORCOL = 2 ! access 2nd list -- col indices ELSE ROWORCOL = 1 ! access 1st list -- row indices ENDIF CALL DMUMPS_SCALINGRHSINTR(LSCAL, id%N, & SCALING_LOC_FWD(1), & SCALING_RHSINTR_FWD(1), & LSCALING_RHSINTR_FWD, id%GLOB2LOC_RHS(1), & id%KEEP, ROWORCOL, id%PTLUST_S(1), & id%IS(1), max(1,LIW), & id%MYID_NODES, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES) C SCALING_RHSINTR_BWD has been allocated and should C now be filled. It is a compressed version of the C local scaling array SCALING_LOC_BWD: IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN ! no tranpose C access 2nd list corresponding to col indices ROWORCOL = 2 ELSE C access 1st list corresponding to row indices ROWORCOL = 1 ENDIF CALL DMUMPS_SCALINGRHSINTR(LSCAL, id%N, & SCALING_LOC_BWD(1), & SCALING_RHSINTR_BWD(1), & LSCALING_RHSINTR_BWD, id%GLOB2LOC_SOL(1), & id%KEEP, ROWORCOL, id%PTLUST_S(1), & id%IS(1), max(1,LIW), & id%MYID_NODES, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES) #endif #if defined(USE_OLD_SCALING) #endif ENDIF C Rebuild SCALING_RHSINTR* next time C only if POSINRHSINTR has to be built C again next time: BUILD_SCALING_RHSINTR= BUILD_POSINRHSINTR C} ENDIF IF (I_AM_SLAVE) THEN IF ((KEEP(221).EQ.1).OR.KEEP(221).EQ.-1) THEN C For the following cases: C -[Schur] we need to save the reduced RHS for all RHS C to perform later the backward phase with an C updated reduced RHS C -[Fwd only] return RHSINTR to user C -KEEP(221)=-1, allocate RHSINTR to enable bwd only step C We need to allocate NRHS_NONEMPTY columns in one shot. C Note that C -RHSINTR might have been allocated in previous block C -RHSINTR has been deallocated previous to entering C loop on RHS IF (.not. associated(id%RHSINTR)) THEN C So far we cannot combine this to exploit sparsity C so that NBENT_RHSINTR will not change in the loop C and can be used to dimension RHSINTR C C Furthermore, during bwd phase the REDRHS provided C by the user might also have a different non empty C column pattern than the sparse RHS provided on input to C this phase: thus we need to allocate id%NRHS columns too. id%LD_RHSINTR = max(NBENT_RHSINTR,1) id%KEEP8(25) = int(id%LD_RHSINTR,8)*int(id%NRHS,8) ALLOCATE (id%RHSINTR(id%KEEP8(25)), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(25),INFO(2)) id%KEEP8(25)=0_8 GOTO 41 END IF NB_BYTES = NB_BYTES + id%KEEP8(25)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C C IF ((KEEP(221).NE.1).AND. & ((KEEP(221).NE.2).OR.(KEEP(252).NE.0)) & ) THEN C ------------------ C Allocate RHSINTR C (case of RHSINTR allocated at each block of RHS) C ------------------ C RHSINTR allocated per block of maximum size NBRHS C NBRHS_EFF could be used instead on NBRHS IF (associated(id%RHSINTR)) THEN C RHSINTR already associated for previous C block, check if we can reuse it. id%LD_RHSINTR = max(NBENT_RHSINTR, 1) IF (id%KEEP8(25).LT.int(id%LD_RHSINTR,8)*int(NBRHS,8)) & THEN ! deallocate and reallocate since larger array is needed NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25) = 0_8 id%LD_RHSINTR = 0 ENDIF ENDIF IF (.not. associated(id%RHSINTR)) THEN id%LD_RHSINTR = max(NBENT_RHSINTR, 1) id%KEEP8(25) = int(id%LD_RHSINTR,8)*int(NBRHS,8) ALLOCATE (id%RHSINTR(id%KEEP8(25)), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(25),INFO(2)) GOTO 41 END IF NB_BYTES = NB_BYTES + id%KEEP8(25)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C C Shift on RHSINTR C IF ( KEEP(221).EQ.0 ) THEN C -- RHSINTR reused in the loop IBEG_RHSINTR= 1_8 ELSE C Initialize IBEG_RHSINTR C IBEG_RHSINTR= int(JBEG_RHS-1,8)*int(id%LD_RHSINTR,8)+1_8 ENDIF ENDIF ! I_AM_SLAVE C ===================== ERROR handling and propagation ================ 41 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C C --------------------------- C Prepare RHS on master (case C of dense and sparse RHS) C --------------------------- IF (id%MYID .eq. MASTER & ) THEN C ========================= IF (KEEP(23) .NE. 0) THEN C ========================= * maximum transversal was performed IF (MTYPE .NE. 1) THEN * At x = b is asked while * we have AP = LU where P is the column permutation * due to max trans. * Therefore we need to modify rhs: * b' = P-1 b (P-1=Pt) * Apply column permutation to the right hand side RHS * Column J of the permuted matrix corresponds to * column PERMW(J) of the original matrix. * IF (KEEP(248)==0) THEN C ========= C DENSE RHS : permute values in RHS C ========= ALLOCATE( C_RW2( id%N ),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating C_RW2 in DMUMPS_SOLVE_DRIVE' END IF GOTO 30 END IF C We directly permute in id%RHS. DO K = 1, NBRHS_EFF KDEC = IBEG+int(K-1,8)*int(LD_RHS,8) DO I = 1, id%N C_RW2(I)=id%RHS(I-1+KDEC) END DO DO I = 1, id%N JPERM = id%UNS_PERM(I) id%RHS(I-1+KDEC) = C_RW2(JPERM) END DO END DO DEALLOCATE(C_RW2) ENDIF ENDIF ENDIF C IF (POSTPros) THEN IF ( KEEP(248) == 0 ) THEN DO K = 1, NBRHS_EFF KDEC = IBEG+int(K-1,8)*int(LD_RHS,8) DO I = 1, id%N SAVERHS(I+(K-1)*id%N) = id%RHS(KDEC+I-1) END DO ENDDO ELSE IF (KEEP(248)==1) THEN SAVERHS(:) = ZERO DO K = 1, NBRHS DO J = id%IRHS_PTR(K), id%IRHS_PTR(K+1)-1 I = id%IRHS_SPARSE(J) SAVERHS(I+(K-1)*id%N) = id%RHS_SPARSE(J) ENDDO ENDDO ENDIF ENDIF #if defined(USE_OLD_SCALING) C C RHS is set to scaled right hand side C (case of centralized scaling only) C IF (LSCAL) THEN C scaling was performed IF (KEEP(248)==0) THEN C dense RHS IF (MTYPE .EQ. 1) THEN C we solve Ax=b, use ROWSCA to scale the RHS DO K =1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHS,8) + int(IBEG-1,8) DO I = 1, id%N id%RHS(KDEC+I) = id%RHS(KDEC+I) * & id%ROWSCA(I) ENDDO ENDDO ELSE C we solve Atx=b, use COLSCA to scale the RHS DO K =1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHS,8) + int(IBEG-1,8) DO I = 1, id%N id%RHS(KDEC+I) = id%RHS(KDEC+I) * & id%COLSCA(I) ENDDO ENDDO ENDIF ELSE IF (KEEP(248)==1) THEN C ------------------------- C KEEP(248)==1 (and MASTER) C ------------------------- KDEC=int(id%IRHS_PTR(JBEG_RHS),8) C Compute IF ((KEEP(248)==1) .AND. & (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) & ) THEN C -- copy from RHS_SPARSE need be done per C column following PERM_RHS C Columns are not contiguous and need be copied one by one IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN IPERM = PERM_RHS(I) ENDIF J = J+1 C Note that we work here on compressed IRHS_PTR_COPY COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) C -- skip empty column IF (COLSIZE .EQ. 0) CYCLE IF (id%KEEP(237).NE.0) THEN IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN C if A-1 only, then, for each non empty target C column PERM_RHS(I), scale in first position C in column the diagonal entry C build the scaled rhs ej on each slave. RHS_SPARSE_COPY(IPOS) = id%ROWSCA(IPERM) * & ONE ELSE RHS_SPARSE_COPY(IPOS) = id%ROWSCA(I) * ONE ENDIF ELSE C Loop over nonzeros in column DO K = 1, COLSIZE C Formula for II below is ok, except in case C of maximum transversal (KEEP(23).NE.0) and C transpose system (MTYPE .NE. 1): C II = id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K-1) C In case of maximum transversal + transpose, one C should then apply II=UNS_PERM_INV(II) after the C above definition of II. C C Instead, we rely on IRHS_SPARSE_COPY, whose row C indices have already been permuted in case of C maximum transversal. II = IRHS_SPARSE_COPY( & IRHS_PTR_COPY(I-JBEG_RHS+1) & +K-1) C PERM_RHS(I) corresponds to column in original RHS. C Original IRHS_PTR must be used to access id%RHS_SPARSE IF (MTYPE.EQ.1) THEN RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(IPERM)+K-1)* & id%ROWSCA(II) ELSE RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(IPERM)+K-1)* & id%COLSCA(II) ENDIF ENDDO ENDIF IPOS = IPOS + COLSIZE ENDDO ELSE ! general sparse RHS ! without permutation IF (MTYPE .eq. 1) THEN DO IZ=1,NZ_THIS_BLOCK I=IRHS_SPARSE_COPY(IZ) RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* & id%ROWSCA(I) ENDDO ELSE DO IZ=1,NZ_THIS_BLOCK I=IRHS_SPARSE_COPY(IZ) RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* & id%COLSCA(I) ENDDO ENDIF ENDIF ENDIF ! KEEP(248)==1 ENDIF ! LSCAL #endif ENDIF ! id%MYID.EQ.MASTER #if defined(V_T) CALL VTEND(perm_scal_ini,IERR) #endif C C Prepare RHS on master C END C ===================== C ----------------------------------- C Two main cases depending on option C for null space computation: C C KEEP(111)=0 : use RHS from user C (sparse or dense) C KEEP(111)!=0: build an RHS on each C proc for null space C computations C ----------------------------------- #if defined(V_T) CALL VTBEGIN(soln_dist,IERR) #endif TIMESCATTER1=MPI_WTIME() IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0) & .AND.(KEEP(221).NE.2 )) THEN C{ ------------------------ C Use RHS provided by user C when not null space and not Fwd in facto C ------------------------ IF (KEEP(248) == 0) THEN C ---------------------------- C -- DENSE RIGHT-HAND-SIDE C ---------------------------- IF ( .NOT.I_AM_SLAVE ) THEN C -- Master not working CALL DMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, LSCAL, SCALING_LOC_FWD(1), & MTYPE, id%RHS(IBEG), LD_RHS, NBRHS_EFF, & NBRHS_EFF, & C_DUMMY, 1, 1, & IDUMMY, 0, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ELSE IF (id%MYID .eq. MASTER) THEN PTR_RHS => id%RHS LD_RHS_loc = LD_RHS NCOL_RHS_loc = NBRHS_EFF IBEG_loc = IBEG ELSE PTR_RHS => CDUMMY_TARGET LD_RHS_loc = 1 NCOL_RHS_loc = 1 IBEG_loc = 1_8 ENDIF LIW_PASSED = max( LIW, 1 ) CALL DMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, LSCAL, SCALING_LOC_FWD(1), & MTYPE, PTR_RHS(IBEG_loc),LD_RHS_loc,NCOL_RHS_loc, & NBRHS_EFF, & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, NBRHS_EFF, & id%GLOB2LOC_RHS(1), NB_FS_RHSINTR_F, C & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).LT.0) GOTO 90 ELSE IF (KEEP(248) .EQ. -1) THEN IF (I_AM_SLAVE) THEN IF (id%Nloc_RHS .NE. 0) THEN RHS_loc_size=int(id%LRHS_loc,8)*int(NBRHS_EFF-1,8)+ & int(id%Nloc_RHS,8) RHS_loc_shift=1_8+int(BEG_RHS-1,8)*id%LRHS_loc ELSE RHS_loc_size=1_8 RHS_loc_shift=1_8 ENDIF CALL DMUMPS_SCATTER_DIST_RHS(id%NSLAVES, id%N, & id%MYID_NODES, id%COMM_NODES, & NBRHS_EFF, id%Nloc_RHS, id%LRHS_loc, & MAP_RHS_loc, & IRHS_loc_PTR(1), & idRHS_loc(RHS_loc_shift), & RHS_loc_size, & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, & id%GLOB2LOC_RHS(1), NB_FS_RHSINTR_F, & LSCAL, #if defined(USE_OLD_SCALING) & scaling_data_dr, #else & SCALING_RHSINTR_FWD(1), LSCALING_RHSINTR_FWD, #endif & LP, LPOK, KEEP(1), NB_BYTES_LOC, INFO(1)) C NB_BYTES_LOC were allocated and freed above NB_BYTES_MAX = max(NB_BYTES_MAX, & NB_BYTES_MAX+NB_BYTES_LOC) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).LT.0) GOTO 90 ELSE C === KEEP(248)==1 ========= C -- SPARSE RIGHT-HAND-SIDE C ---------------------------- IF (NZ_THIS_BLOCK > 0 #if ! defined(USE_OLD_SCALING) C For AM1, no need to broadcast RHS_SPARSE C when using local scalings. RHSINTR will C be initialized directly and RHS_SPARSE C is used during DMUMPS_GATHER_SOLUTION_AM1 & .AND. id%KEEP(237) .EQ.0 #endif & ) THEN CALL MPI_BCAST(RHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) ENDIF C IF (KEEP(237).NE.0) THEN IF ( I_AM_SLAVE ) THEN C ----- C case of A-1 C ----- C - Take columns with non-zero entry, say j, C - to build Ej and store it in RHSINTR K=1 ! Column index in RHSINTR id%RHSINTR(1_8:int(NBRHS_EFF,8)*int(id%LD_RHSINTR,8)) & = ZERO IPOS = 1 DO I = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) IF (COLSIZE.GT.0) THEN ! Find global column index J and set ! column K of RHSINTR to ej (here IBEG is one) J = I - 1 + JBEG_RHS IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN J = PERM_RHS(J) ENDIF IPOSRHSINTR = id%GLOB2LOC_RHS(J) C IF ( (IPOSRHSINTR.LE.NB_FS_RHSINTR_F) C & .AND.(IPOSRHSINTR.GT.0) ) THEN IF (IPOSRHSINTR.GT.0) THEN C Columns J corresponds to ej and thus to variable j C that is on my proc. C We know that only one entry is needed, C the diagonal entry (for the forward with A-1). C #if defined(USE_OLD_SCALING) id%RHSINTR(int(K-1,8)*int(id%LD_RHSINTR,8)+ & int(IPOSRHSINTR,8)) = & RHS_SPARSE_COPY(IPOS) #else IF (LSCAL) THEN id%RHSINTR(int(K-1,8)*int(id%LD_RHSINTR,8)+ & int(IPOSRHSINTR,8)) = & SCALING_RHSINTR_FWD(IPOSRHSINTR) ELSE id%RHSINTR(int(K-1,8)*int(id%LD_RHSINTR,8)+ & int(IPOSRHSINTR,8)) = ONE ENDIF #endif ENDIF ! End of J on my proc K = K + 1 IPOS = IPOS + COLSIZE ! go to next column ENDIF ENDDO IF (K.NE.NBRHS_EFF+1) THEN WRITE(6,*) 'Internal Error 9 in solution driver ', & K,NBRHS_EFF call MUMPS_ABORT() ENDIF ENDIF ! I_AM_SLAVE C ------- c END A-1 C ------- ELSE C -------------- C General sparse C -------------- C -- At this point each process has a copy of the C -- sparse RHS. We need to store it into RHSINTR. C -- reset to zero RHSINTR for skipped columns (if any) IF ((KEEP(221).EQ.1).AND.(NB_RHSSKIPPED.GT.0) & .AND.I_AM_SLAVE) THEN DO K = JBEG_RHS-NB_RHSSKIPPED, JBEG_RHS-1 DO I = 1, id%LD_RHSINTR id%RHSINTR(int(K-1,8)*int(id%LD_RHSINTR,8) & + int(I,8)) = ZERO ENDDO ENDDO ENDIF IF (I_AM_SLAVE) THEN DO K = 1, NBCOL_INBLOC ! it is equal to NBRHS_EFF in this case KDEC = int(K-1,8) * int(id%LD_RHSINTR,8) + & IBEG_RHSINTR - 1_8 id%RHSINTR(KDEC+1_8:KDEC+NBENT_RHSINTR) = ZERO #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 I=IRHS_SPARSE_COPY(IZ) IPOSRHSINTR = id%GLOB2LOC_RHS(I) C Since all fully summed variables mapped C on each proc are stored at the beginning C of RHSINTR, we can compare to KEEP(89) C to know if RHSINTR should be initialized C So far the tree has not been pruned to exploit C sparsity to compress RHSINTR so we compare to C NB_FS_RHSINTR_TOT IF ( (IPOSRHSINTR.LE.NB_FS_RHSINTR_TOT) & .AND.(IPOSRHSINTR.GT.0) ) THEN C ! I is fully summed var mapped on my proc id%RHSINTR(KDEC+IPOSRHSINTR)= & id%RHSINTR(KDEC+IPOSRHSINTR) + & RHS_SPARSE_COPY(IZ) & * SCALING_RHSINTR_FWD(IPOSRHSINTR) ENDIF ENDDO ELSE #endif DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 I=IRHS_SPARSE_COPY(IZ) IPOSRHSINTR = id%GLOB2LOC_RHS(I) C Since all fully summed variables mapped C on each proc are stored at the beginning C of RHSINTR, we can compare to KEEP(89) C to know if RHSINTR should be initialized C So far the tree has not been pruned to exploit C sparsity to compress RHSINTR so we compare to C NB_FS_RHSINTR_TOT IF ( (IPOSRHSINTR.LE.NB_FS_RHSINTR_TOT) & .AND.(IPOSRHSINTR.GT.0) ) THEN C ! I is fully summed var mapped on my proc id%RHSINTR(KDEC+IPOSRHSINTR)= & id%RHSINTR(KDEC+IPOSRHSINTR) + & RHS_SPARSE_COPY(IZ) ENDIF ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif ENDDO END IF ! I_AM_SLAVE ENDIF ! KEEP(237) ENDIF ! ==== KEEP(248)==1 ===== C} ELSE IF (I_AM_SLAVE) THEN ! I_AM_SLAVE AND (null space or Fwd in facto) IF (KEEP(111).NE.0) THEN C{ ----------------------- C Null space computations C ----------------------- C C We are working on columns BEG_RHS:BEG_RHS+NBRHS_EFF-1 C of RHS. C Columns in 1..KEEP(112): C Put a one in corresponding C position of the right-hand-side, C and zeros in other places. C Columns in KEEP(112)+1: KEEP(112)+KEEP(17): C root node => set C 0 everywhere and compute the local range C corresponding to IBEG/IEND in root C that will be passed to DMUMPS_SEQ_SOLVE_ROOT_RR C Also keep track of which part of C DMUMPS_RHS must be passed to C DMUMPS_SEQ_SOLVE_ROOT_RR. C IF (KEEP(111).GT.0) THEN IBEG_GLOB_DEF = KEEP(111) IEND_GLOB_DEF = KEEP(111) ELSE IBEG_GLOB_DEF = BEG_RHS IEND_GLOB_DEF = BEG_RHS+NBRHS_EFF-1 ENDIF IF ( id%KEEP(112) .GT. 0 .AND. DO_NULL_PIV) THEN IF (IBEG_GLOB_DEF .GT.id%KEEP(112)) THEN id%KEEP(235) = 0 DO_NULL_PIV = .FALSE. ENDIF IF (IBEG_GLOB_DEF .LT.id%KEEP(112) & .AND. IEND_GLOB_DEF .GT.id%KEEP(112) & .AND. DO_NULL_PIV ) THEN C IEND_GLOB_DEF = id%KEEP(112) C forcing exploit sparsity C - cannot be done at this point C - and is not what the user would have expected the C code to to do anyway !!!! C suppress: id%KEEP(235) = 1 ! End Block of sparsity ON DO_NULL_PIV = .FALSE. ENDIF ENDIF IF (id%KEEP(235).NE.0) THEN C Exploit Sparsity in null space computations C We build /allocate the sparse RHS on MASTER C based on pivnul_list. Then we broadcast it C on the slaves C In this case we have ONLY ONE ENTRY per RHS C NZ_THIS_BLOCK=IEND_GLOB_DEF-IBEG_GLOB_DEF+1 ALLOCATE(IRHS_PTR_COPY(NZ_THIS_BLOCK+1),stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 50 ENDIF IRHS_PTR_COPY_ALLOCATED = .TRUE. ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK),stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 50 ENDIF IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + & int(NZ_THIS_BLOCK,8)*(K34_8+K34_8) & + K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.eq.MASTER) THEN ! compute IRHS_PTR and IRHS_SPARSE_COPY II = 1 DO I = IBEG_GLOB_DEF, IEND_GLOB_DEF IRHS_PTR_COPY(I-IBEG_GLOB_DEF+1) = I IRHS_SPARSE_COPY(II) = id%PIVNUL_LIST(I) II = II +1 ENDDO IRHS_PTR_COPY(NZ_THIS_BLOCK+1) = NZ_THIS_BLOCK+1 ENDIF C C ===================== ERROR handling and propagation ================ 50 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(IRHS_PTR_COPY(1), & NZ_THIS_BLOCK+1, & MPI_INTEGER, & MASTER, id%COMM,IERR) C End IF Exploit Sparsity ENDIF c C Initialize RHSINTR to 0 ! to be suppressed DO K=1, NBRHS_EFF KDEC = int(K-1,8) * int(id%LD_RHSINTR,8) id%RHSINTR(KDEC+1_8:KDEC+int(id%LD_RHSINTR,8))=ZERO END DO C Loop over the columns. C Note that if ( KEEP(220)+KEEP(109)-1 < IBEG_GLOB_DEF C .OR. KEEP(220) > IEND_GLOB_DEF ) then we do not enter C the loop. C Note that local processor has indices C KEEP(220):KEEP(220)+KEEP(109)-1 C C Computation of null space and computation of backward C step incompatible, do one or the other. DO I=max(IBEG_GLOB_DEF,KEEP(220)), & min(IEND_GLOB_DEF,KEEP(220)+KEEP(109)-1) C Local processor is concerned by I-th column of C global right-hand side. JJ= id%GLOB2LOC_RHS(id%PIVNUL_LIST(I-KEEP(220)+1)) IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN ! unsymmetric : always set to fixation id%RHSINTR( IBEG_RHSINTR+ & int(I-IBEG_GLOB_DEF,8)*int(id%LD_RHSINTR,8)+ & int(JJ-1,8) ) = & id%DKEEP(2) ELSE ! Symmetric: always set to one id%RHSINTR( IBEG_RHSINTR+ & int(I-IBEG_GLOB_DEF,8)*int(id%LD_RHSINTR,8)+ & int(JJ-1,8) )= & ONE ENDIF ENDIF ENDDO IF ( KEEP(17).NE.0 .AND. & id%MYID_NODES.EQ.MASTER_ROOT) THEN C --------------------------- C Deficiency of the root node C Find range relative to root C --------------------------- C Among IBEG_GLOB_DEF:IEND_GLOB_DEF, find C intersection with KEEP(112)+1:KEEP(112)+KEEP(17) IBEG_ROOT_DEF = max(IBEG_GLOB_DEF,KEEP(112)+1) IEND_ROOT_DEF = min(IEND_GLOB_DEF,KEEP(112)+KEEP(17)) C First column of right-hand side that must C be passed to DMUMPS_SEQ_SOLVE_ROOT_RR is: IROOT_DEF_RHS_COL1 = IBEG_ROOT_DEF-IBEG_GLOB_DEF + 1 C We look for indices relatively to the root node, C substract number of null pivots outside root node IBEG_ROOT_DEF = IBEG_ROOT_DEF-KEEP(112) IEND_ROOT_DEF = IEND_ROOT_DEF-KEEP(112) C Note that if IBEG_ROOT_DEF > IEND_ROOT_DEF, then this C means that nothing must be done on the root node C for this set of right-hand sides. ELSE IBEG_ROOT_DEF = -90999 IEND_ROOT_DEF = -95999 IROOT_DEF_RHS_COL1= 1 ENDIF C} ELSE ! End of null space (test on KEEP(111)) C case of Fwd in facto C id%RHSINTR need not be initialized. It will be set on the fly C to zero for normal fully summed variables of the fronts and C to -1 on the roots for the id%N+KEEP(253) variables added C to the roots. ENDIF ! End of null space (test on KEEP(111)) ENDIF ! I am slave TIMESCATTER2=MPI_WTIME()-TIMESCATTER1+TIMESCATTER2 IF (KEEP(221) .EQ. 2 .AND. KEEP(60).NE.0 ) THEN C Copy/send REDRHS in PTR_RHS_ROOT C (column by column if leading dimension LD_REDRHS C of REDRHS is not equal to SIZE_ROOT). C REDRHS was provided on the host IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN C -- Same proc : copy is possible: II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8)-1_8 DO I = 1, SIZE_ROOT PTR_RHS_ROOT(II+I) = id%REDRHS(KDEC+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE C -- send REDRHS IF ( id%MYID .EQ. MASTER) THEN C -- send to MASTER_ROOT_IN_COMM using COMM communicator C assert: id%KEEP(116).EQ.SIZE_ROOT IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- One send KDEC = IBEG_REDRHS CALL MPI_SEND(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_DOUBLE_PRECISION, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSE C -- NBRHS_EFF sends DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) CALL MPI_SEND(id%REDRHS(KDEC),SIZE_ROOT, & MPI_DOUBLE_PRECISION, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ENDDO ENDIF ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN C -- receive from MASTER II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- receive all in on shot CALL MPI_RECV(PTR_RHS_ROOT(II), & SIZE_ROOT*NBRHS_EFF, & MPI_DOUBLE_PRECISION, & MASTER, 0, id%COMM,STATUS,IERR) ELSE DO K=1, NBRHS_EFF CALL MPI_RECV(PTR_RHS_ROOT(II),SIZE_ROOT, & MPI_DOUBLE_PRECISION, & MASTER, 0, id%COMM,STATUS,IERR) II = II + SIZE_ROOT ENDDO ENDIF ENDIF C -- other procs are not concerned ENDIF ENDIF TIMEC1=MPI_WTIME() IF ( I_AM_SLAVE ) THEN C { LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) C FROM_PP = .FALSE. NBSPARSE_LOC = (DO_NBSPARSE.AND.NBRHS_EFF.GT.1) C ----------------------------------------- C Define arguments to have a single call to C SOL_C with and without exploit sparsity. C ----------------------------------------- IF (Lnodes_FWD.EQ.-1 .AND. Lnodes_BWD.EQ.-1) THEN NZ_THIS_BLOCK_ARG = 1 NBCOL_INBLOC_ARG = 1 Step2node_ARG => IDUMMY_TARGET LStep2node_ARG = 1 IRHS_SPARSE_COPY_ARG => IDUMMY_TARGET IRHS_PTR_COPY_ARG => IDUMMY_TARGET NB_FS_RHSINTR_F_ARG = 1 NB_FS_RHSINTR_TOT_ARG = 1 #if defined(STAT_ES_SOLVE) SIZE_WORKING = 1 SIZE_IPTR_WORKING = 1 idIPTR_WORKING => IDUMMY_TARGET idWORKING => IDUMMY_TARGET #endif ELSE NZ_THIS_BLOCK_ARG = NZ_THIS_BLOCK NBCOL_INBLOC_ARG = NBCOL_INBLOC Step2node_ARG => id%Step2node LStep2node_ARG = KEEP(28) IRHS_SPARSE_COPY_ARG => IRHS_SPARSE_COPY IRHS_PTR_COPY_ARG => IRHS_PTR_COPY NB_FS_RHSINTR_F_ARG = NB_FS_RHSINTR_F NB_FS_RHSINTR_TOT_ARG = NB_FS_RHSINTR_TOT #if defined(STAT_ES_SOLVE) SIZE_WORKING = 1 SIZE_IPTR_WORKING = 1 IF((KEEP(235).NE.0).OR.(KEEP(237).NE.0)) THEN IF(id%MYID.EQ.MASTER) THEN SIZE_WORKING = id%IPTR_WORKING(id%NPROCS+1)-1 SIZE_IPTR_WORKING = id%NPROCS+1 END IF ENDIF #endif ENDIF CALL DMUMPS_SOL_C(idintr%root,idintr%roota,id%N,id%S(1), &LA_PASSED,IS(1),LIW_PASSED,WORK_WCB(1),LWCB8,IWCB,LIWCB, &NBRHS_EFF,id%NA(1),id%LNA,id%NE_STEPS(1),SRW3, MTYPE, ICNTL(1), &FROM_PP,id%STEP(1),id%FRERE_STEPS(1),id%DAD_STEPS(1),id%FILS(1), &id%PTLUST_S(1),id%PTRFAC(1),IWK_SOLVE,LIWK_SOLVE,PTRACB, &LIWK_PTRACB,id%PROCNODE_STEPS(1),id%NSLAVES,INFO(1),KEEP(1), &KEEP8(1),id%DKEEP(1),id%COMM_NODES,id%MYID,id%MYID_NODES,BUFR(1), &LBUFR,LBUFR_BYTES,id%ISTEP_TO_INIV2(1),id%TAB_POS_IN_PERE(1,1), &IBEG_ROOT_DEF,IEND_ROOT_DEF,IROOT_DEF_RHS_COL1, PTR_RHS_ROOT(1), &LPTR_RHS_ROOT,SIZE_ROOT,MASTER_ROOT,id%RHSINTR(IBEG_RHSINTR), &id%LD_RHSINTR,id%GLOB2LOC_RHS(1),id%GLOB2LOC_SOL(1), &Lnodes_FWD, Lnodes_BWD, nodes_FWD_PTR(1), nodes_BWD_PTR(1), &NZ_THIS_BLOCK_ARG, NBCOL_INBLOC_ARG, JBEG_RHS, Step2node_ARG(1), &LStep2node_ARG, IRHS_SPARSE_COPY_ARG(1), IRHS_PTR_COPY_ARG(1), &size(PERM_RHS), PERM_RHS, size(UNS_PERM_INV), UNS_PERM_INV, &NB_FS_RHSINTR_F, NB_FS_RHSINTR_TOT, NBSPARSE_LOC, &PTR_RHS_BOUNDS(1), LPTR_RHS_BOUNDS #if defined(STAT_ES_SOLVE) &,idIPTR_WORKING(1),SIZE_IPTR_WORKING,idWORKING(1),SIZE_WORKING #endif & , id%IPOOL_B_L0_OMP(1), id%LPOOL_B_L0_OMP, id%IPOOL_A_L0_OMP(1), & id%LPOOL_A_L0_OMP, id%L_VIRT_L0_OMP, id%VIRT_L0_OMP(1), & id%L_PHYS_L0_OMP, id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1), & id%PTR_LEAFS_L0_OMP(1), id%L0_OMP_MAPPING(1), id%LL0_OMP_MAPPING, & idintr%L0_OMP_FACTORS(1), id%LL0_OMP_FACTORS & ) C C ================================================================ C C } END IF ! I_AM_SLAVE C ----------------- C End of slave code C ----------------- C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) TIMEC2=MPI_WTIME()-TIMEC1+TIMEC2 C C Change error code. IF (INFO(1).eq.-2) then INFO(1)=-11 IF (LPOK) & write(LP,*) & ' WARNING : -11 error code obtained in solve' END IF IF (INFO(1).eq.-3) then INFO(1)=-14 IF (LPOK) & write(LP,*) & ' WARNING : -14 error code obtained in solve' END IF C C Return in case of error. IF (INFO(1).LT.0) GO TO 90 C C ====================================================== C ONLY FORWARD was performed (case of reduced RHS with Schur C option during factorisation) C ====================================================== IF ( (KEEP(60).NE.0) .AND. & KEEP(221) .EQ. 1 ) THEN ! === Begin OF REDUCED RHS ====== C -------------------------------------- C Send (or copy) reduced RHS from PTR_RHS_ROOT located on C MASTER_ROOT_IN_COMM to REDRHS located on MASTER (host node). C (column by column if leading dimension LD_REDRHS C of REDRHS is not equal to SIZE_ROOT) C -------------------------------------- IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN C -- same proc --> copy II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) - 1_8 DO I = 1, SIZE_ROOT id%REDRHS(KDEC+I) = PTR_RHS_ROOT(II+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE C -- recv in REDRHS IF ( id%MYID .EQ. MASTER ) THEN C -- recv from MASTER_ROOT_IN_COMM IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- One message to receive KDEC = IBEG_REDRHS CALL MPI_RECV(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_DOUBLE_PRECISION, & MASTER_ROOT_IN_COMM, 0, id%COMM, & STATUS,IERR) ELSE C -- NBRHS_EFF receives DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) CALL MPI_RECV(id%REDRHS(KDEC),SIZE_ROOT, & MPI_DOUBLE_PRECISION, & MASTER_ROOT_IN_COMM, 0, id%COMM, & STATUS,IERR) ENDDO ENDIF ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN C -- send to MASTER II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- send all in on shot CALL MPI_SEND(PTR_RHS_ROOT(II), & SIZE_ROOT*NBRHS_EFF, & MPI_DOUBLE_PRECISION, & MASTER, 0, id%COMM,IERR) ELSE DO K=1, NBRHS_EFF CALL MPI_SEND(PTR_RHS_ROOT(II),SIZE_ROOT, & MPI_DOUBLE_PRECISION, & MASTER, 0, id%COMM,IERR) II = II + SIZE_ROOT ENDDO ENDIF ENDIF C -- other procs are not concerned ENDIF ENDIF ! ===== END OF REDUCED RHS (Schur+Fwd only performed) == C ======================================================= C BACKWARD was PERFORMED C Postprocess solution that is distributed IF ( KEEP(221) .NE. 1 ) THEN ! BACKWARD was PERFORMED C -- KEEP(221).NE.1 => we are sure that backward has been performed IF (ICNTL21 == 0) THEN ! CENTRALIZED SOLUTION C{ ======================================================== C GATHER SOLUTION computed during bwd C Each proc holds the pieces of solution corresponding C to all fully summed variables mapped on that processor C (i.e. corresponding to master nodes mapped on that proc) C In case of A-1 we gather directly in RHS_SPARSE C the distributed solution. C Scaling is done in all case on the fly of the reception C Note that when only FORWARD has been performed C RSH_MUMPS holds the solution computed during forward step C (DMUMPS_SOL_R) C there is no need to copy back in RSH_MUMPS the solution C ======================================================== C centralized solution IF (KEEP(237).EQ.0) THEN C CWORK not needed for AM1 LCWORK = max(max(KEEP(247),KEEP(246)),1) ALLOCATE( CWORK(LCWORK), stat=allocok ) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) ENDIF ENDIF IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & .AND. (id%NSLAVES.NE.1)) THEN C Precompute map of indices in current column C (no need to reset it between columns ALLOCATE (MAP_RHS(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) ' Problem allocation of MAP_RHS at solve' ENDIF INFO(1) = -13 INFO(2) = id%N ELSE NB_BYTES = NB_BYTES + int(id%N,8) * K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) C Return in case of error. IF (INFO(1).LT.0) GO TO 90 #if defined(USE_OLD_SCALING) 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 #endif LIW_PASSED = max( LIW, 1 ) TIMEGATHER1=MPI_WTIME() IF ( .NOT.I_AM_SLAVE ) THEN C I did not participate to computing part of the solution C (id%RHSINTR not set/allocate) : receive solution, store C it and scale it. IF (KEEP(237).EQ.0) THEN C We need a workspace of minimal size KEEP(247) C in order to unpack pieces of the solution. CALL DMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & MTYPE, id%RHS(1), LD_RHS, id%NRHS, JBEG_RHS, & JDUMMY, id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), IDUMMY, 1, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), LCWORK, LSCAL, #if defined(USE_OLD_SCALING) & PT_SCALING(1), size(PT_SCALING), #else & SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), #endif & C_DUMMY, 1 , 1, IDUMMY, 1, & PERM_RHS, size(PERM_RHS) ! for sparse permuted RHS & ) ELSE C only gather target entries of A-1 CALL DMUMPS_GATHER_SOLUTION_AM1(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & C_DUMMY, 1, 1, & id%KEEP(1), BUFR(1), LBUFR, LBUFR_BYTES, #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING) #else & LSCAL, SCALING_RHSINTR_BWD(1), & size(SCALING_RHSINTR_BWD) #endif C --- A-1 related entries & ,IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), & UNS_PERM_INV, size(UNS_PERM_INV), & IDUMMY, 1, 0 & ) ENDIF ELSE C Avoid temporary copy (IS(1)) that some old C compilers would do otherwise IF (KEEP(237).EQ.0) THEN IF (id%MYID.EQ.MASTER) THEN PTR_RHS => id%RHS NCOL_RHS_loc = id%NRHS LD_RHS_loc = LD_RHS JBEG_RHS_loc = JBEG_RHS ELSE PTR_RHS => CDUMMY_TARGET NCOL_RHS_loc = 1 LD_RHS_loc = 1 JBEG_RHS_loc = 1 ENDIF CALL DMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, MTYPE, & PTR_RHS(1), LD_RHS_loc, NCOL_RHS_loc, JBEG_RHS_loc, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), IS(1), LIW_PASSED, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), LCWORK, #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING), #else & LSCAL, SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), #endif & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, NBRHS_EFF, & id%GLOB2LOC_SOL(1), id%N, & PERM_RHS, size(PERM_RHS) ! For sparse permuted RHS & ) ELSE ! only gather target entries of A-1 CALL DMUMPS_GATHER_SOLUTION_AM1(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, NBRHS_EFF, & id%KEEP(1), BUFR(1), LBUFR, LBUFR_BYTES, #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING) #else & LSCAL, SCALING_RHSINTR_BWD(1), size(SCALING_RHSINTR_BWD) #endif C --- A-1 related entries & , IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), & UNS_PERM_INV, size(UNS_PERM_INV), & id%GLOB2LOC_SOL(1), id%N, NB_FS_RHSINTR_TOT & ) ENDIF ENDIF TIMEGATHER2=MPI_WTIME()-TIMEGATHER1+TIMEGATHER2 IF (KEEP(237).EQ.0) DEALLOCATE( CWORK ) IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & ) THEN C Copy back solution from RHS_SPARSE_COPY TO RHS_SPARSE DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN PJ = PERM_RHS(J) ELSE PJ =J ENDIF COLSIZE = id%IRHS_PTR(PJ+1) - & id%IRHS_PTR(PJ) IF (COLSIZE.EQ.0) CYCLE JJ = J-JBEG_RHS+1 C Precompute map of indices in current column C (no need to reset it between columns IF (id%NSLAVES.NE.1) THEN DO II=1, COLSIZE MAP_RHS(id%IRHS_SPARSE( & id%IRHS_PTR(PJ) + II - 1)) = II ENDDO DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 II = IRHS_SPARSE_COPY(IZ2) id%RHS_SPARSE(id%IRHS_PTR(PJ)+MAP_RHS(II)-1)= & RHS_SPARSE_COPY(IZ2) ENDDO ELSE C Entries within a column are in order C IZ - Column index in Sparse RHS DO IZ= id%IRHS_PTR(PJ), id%IRHS_PTR(PJ+1)-1 IZ2 = IRHS_PTR_COPY(JJ) + & IZ - id%IRHS_PTR(PJ) id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDIF ENDDO IF (id%NSLAVES.NE.1) THEN NB_BYTES = NB_BYTES - int(size(MAP_RHS),8) * K34_8 DEALLOCATE ( MAP_RHS ) ENDIF ENDIF ! end A-1 on master C C} -- END of backward was performed with centralized solution ELSE ! (KEEP(221).NE.1) .AND.(ICNTL21.NE.0)) C C BEGIN of backward performed with distributed solution C time local copy + scaling TIMECOPYSCALE1=MPI_WTIME() C The non working host should not do this: IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF ( KEEP(89) .GT. 0 ) THEN IF ( LSCAL .AND. id%KEEP(89).GT.0) THEN #if defined(USE_OLD_SCALING) SCALING_LOC_BWD => scaling_data_sol%SCALING_LOC #else IF (MTYPE.EQ.1) THEN SCALING_LOC_BWD => id%COLSCA_loc ELSE SCALING_LOC_BWD => id%ROWSCA_loc ENDIF #endif ELSE SCALING_LOC_BWD => RDUMMY_TARGET ENDIF CALL DMUMPS_DISTRIBUTED_SOLUTION(id%NSLAVES, & id%N,id%MYID_NODES, & MTYPE, id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, & NBRHS_EFF, id%GLOB2LOC_SOL(1), & id%ISOL_loc(1), id%SOL_loc(1), id%NRHS, & JBEG_RHS-NB_RHSSKIPPED, id%LSOL_loc, & id%PTLUST_S(1), id%PROCNODE_STEPS(1), & id%KEEP(1),id%KEEP8(1), & IS(1), LIW_PASSED, id%STEP(1), & SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), & LSCAL, NB_RHSSKIPPED, & PERM_RHS, size(PERM_RHS) ) ! For permuted sparse RHS ENDIF ENDIF TIMECOPYSCALE2=MPI_WTIME()-TIMECOPYSCALE1+TIMECOPYSCALE2 ENDIF C === BACKWARD was PERFORMED WITH DISTRIBUTED SOLUTION === C ======================================================== ENDIF ! ==== END of BACKWARD was PERFORMED (KEEP(221).NE.1) C note that the main DO-loop on blocks is not ended yet C C ============================================ C BEGIN C C ITERATIVE REFINEMENT AND/OR ERROR ANALYSIS C C ============================================ IF ( ICNTL10 > 0 .AND. NBRHS_EFF > 1 ) THEN C C ---------------------------------- C Multiple RHS: apply a fixed number C of iterative refinement steps C ---------------------------------- C DO I = 1, ICNTL10 write(6,*) ' Internal error 15 in sol_driver ' C Compute residual: Y <- SAVERHS - A * RHS C Solve RHS <- A^-1 Y, Y modified C Assemble in RHS(REDUCE) C RHS <- RHS + Y C END DO END IF IF (POSTPros) THEN C{ C SAVERHS holds the original right hand side C Sparse rhs are saved in SAVERHS as dense rhs C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C Start iterative refinements. The master is managing the C organisation of work, but slaves are used to solve systems of C equations and, in case of distributed matrix, perform C matrix-vector products. It is more complicated to do this with C the SPMD version than it was with the master/slave approach. C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * c IF ( PROK .AND. ICNTL10 .NE. 0 ) WRITE( MP, 270 ) IF ( PROKG .AND. ICNTL10 .NE. 0 ) WRITE( MPG, 270 ) C Initializations and allocations NITREF = abs(ICNTL10) ALLOCATE(R_Y(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 ALLOCATE(C_Y(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 IF ( id%MYID .EQ. MASTER ) THEN ALLOCATE( IW1( 2 * id%N ),stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=2 * id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(2*id%N,8)*K34_8 ALLOCATE( C_W(id%N), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 ALLOCATE( R_W(2*id%N), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(2*id%N,8)*K16_8 C end allocations on Master END IF ALLOCATE(C_LOCWK54(id%N),stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 ALLOCATE(R_LOCWK54(id%N),stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 KASE = 0 C Synchro point with broadcast of errors 777 CONTINUE NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 C TIMEEA needed if EA and IR with stopping criterium C and IR with fixed n.of steps. TIMEEA = 0.0D0 C TIMEEA1 needed if EA and IR with fixed n.of steps TIMEEA1 = 0.0D0 CALL MUMPS_SECDEB(TIMEIT) C ------------------------- C C RHSOL holds the initial guess for the solution C We start the loop on the Iterative refinement procedure C C C C |- IRefin. L O O P -| C V V C C ========================================================= C Computation of the infinity norm of A C ========================================================= IF ((ICNTL11.GT.0).OR.(ICNTL10.GT.0)) THEN C We don't get through these lines if ICNTL10<=0 AND ICNTL11<=0 IF ( KEEP(54) .eq. 0 ) THEN C ------------------ C Centralized matrix C ------------------ IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------------- C Call DMUMPS_SOL_X outside, if needed, C in order to compute w(i,2)=sum|Aij|,j=1:n C in vector R_W(id%N+i) C ----------------------------------------- IF (KEEP(55).NE.0) THEN C unassembled matrix and norm of row required CALL DMUMPS_SOL_X_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), id%A_ELT(1), & R_W(id%N+1), KEEP(1),KEEP8(1) ) ELSE C assembled matrix IF ( MTYPE .eq. 1 ) THEN CALL DMUMPS_SOL_X & ( id%A(1), id%KEEP8(28), id%N, id%IRN(1), id%JCN(1), & R_W(id%N+1), KEEP(1),KEEP8(1), & 0, id%SYM_PERM(1) ) ELSE CALL DMUMPS_SOL_X & ( id%A(1), id%KEEP8(28), id%N, id%JCN(1), id%IRN(1), & R_W(id%N+1), KEEP(1),KEEP8(1), & 0, id%SYM_PERM(1) ) END IF ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL DMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1), & 0, id%SYM_PERM(1) ) ELSE CALL DMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%JCN_loc(1), id%IRN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1), & 0, id%SYM_PERM(1) ) END IF ELSE R_LOCWK54 = RZERO END IF C ------------------------- C Assemble result on master C ------------------------- IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_W( id%N + 1 ), & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) END IF C End if KEEP(54) END IF C IF ( id%MYID .eq. MASTER ) THEN C R_W is available on the master process only RINFOG(4) = dble(ZERO) DO I = 1, id%N RINFOG(4) = max(R_W( id%N +I), RINFOG(4)) ENDDO ENDIF C end ICNTL11 =/0 v ICNTL10>0 ENDIF C ========================================================= C END norm of A C ========================================================= C Initializations for the IR NOITER = 0 IFLAG_IR = 0 TESTConv = .FALSE. IF ( id%MYID .eq. MASTER ) THEN IF (ICNTL10.GT.0) THEN C Test of convergence should be made TESTConv = .TRUE. ARRET = CNTL(2) IF (ARRET .LT. 0.0D0) THEN ARRET = sqrt(epsilon(0.0D0)) END IF IF ( PROKG ) THEN WRITE( MPG, 240) NITREF, ARRET,id%DKEEP(22) ENDIF ELSE IF ( PROKG ) THEN WRITE( MPG, 245) NITREF ENDIF ENDIF C ========================================================= C Starting IR DO 22 IRStep = 1, NITREF +1 C ========================================================= C C ========================================================= C Refine the solution starting from the second step of do loop C ========================================================= IF (( id%MYID .eq. MASTER ).AND.(IRStep.GT.1)) THEN NOITER = NOITER + 1 DO I = 1, id%N id%RHS(IBEG+I-1) = id%RHS(IBEG+I-1) + C_Y(I) ENDDO ENDIF C =========================================== C Computation of the RESIDUAL and of |A||x| C =========================================== IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN IF (KEEP(55).NE.0) THEN C input matrix by element CALL DMUMPS_ELTYD( MTYPE, id%N, & id%NELT, id%ELTPTR(1), id%LELTVAR, & id%ELTVAR(1), id%KEEP8(30), id%A_ELT(1), & SAVERHS, id%RHS(IBEG), & C_Y, R_W, KEEP(50)) ELSE IF ( MTYPE .eq. 1 ) THEN CALL DMUMPS_SOL_Y(id%A(1), id%KEEP8(28), & id%N, id%IRN(1), & id%JCN(1), SAVERHS, & id%RHS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ELSE CALL DMUMPS_SOL_Y(id%A(1), id%KEEP8(28), & id%N, id%JCN(1), & id%IRN(1), SAVERHS, & id%RHS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ENDIF ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- CALL MPI_BCAST( RHS_IR(IBEG), id%N, & MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) C -------------------------------------- C Compute Y = SAVERHS - A * RHS C Y, SAVERHS defined only on master C -------------------------------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN CALL DMUMPS_LOC_MV8( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_Y, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) C =========================== C_Y = SAVERHS - C_Y C =========================== ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) END IF C -------------------------------------- C Compute C * If MTYPE = 1 C W(i) = Sum | Aij | | RHSj | C j C * If MTYPE = 0 C W(j) = Sum | Aij | | RHSi | C i C R_LOCWK54 used as local array for W C RHS has been broadcasted C -------------------------------------- IF ( I_AM_SLAVE .and. id%KEEP8(29) .NE. 0_8 ) THEN CALL DMUMPS_LOC_OMEGA1( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), R_LOCWK54, KEEP(50), MTYPE ) ELSE R_LOCWK54 = RZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_W, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) ENDIF ENDIF C ===================================== C END computation RESIDUAL and |A||x| C ===================================== IF ( id%MYID .eq. MASTER ) THEN C IF ((ICNTL11.GT.0).OR.(ICNTL10.GT.0)) THEN C -------------- C Error analysis and test of convergence, C Compute the sparse componentwise backward error: C - at each step if test of convergence of IR is C requested (ICNTL(10)>0) C - at step 1 and NITREF+1 if error analysis C to be computed (ICNTL(11)>0) and if ICNTL(10)< 0 IF (((ICNTL11.GT.0).OR.((ICNTL10.LT.0).AND. & ((IRStep.EQ.1).OR.(IRStep.EQ.NITREF+1))) & .OR.((ICNTL10.EQ.0).AND.(IRStep.EQ.1))) & .OR.(ICNTL10.GT.0)) THEN C Compute w1 and w2 C always if ICNTL10>0 in the other case if ICNTL11>0 C ----------------- IF (ICNTL10.LT.0) CALL MUMPS_SECDEB(TIMEEA1) CALL DMUMPS_SOL_OMEGA(id%N,SAVERHS, & id%RHS(IBEG), C_Y, R_W, C_W, IW1, IFLAG_IR, & RINFOG(7), NOITER, TESTConv, & MP, ARRET, KEEP(361), id%DKEEP(22) ) IF (ICNTL10.LT.0) THEN CALL MUMPS_SECFIN(TIMEEA1) id%DKEEP(120)=id%DKEEP(120)+TIMEEA1 ENDIF ENDIF IF ((ICNTL11.GT.0).AND.( & (ICNTL10.LT.0.AND.(IRStep.EQ.1.OR.IRStep.EQ.NITREF+1)) & .OR.((ICNTL10.GE.0).AND.(IRStep.EQ.1)) & )) THEN C Error analysis before iterative refinement C or for last if icntl10<0 C ------------------------------------------ CALL MUMPS_SECDEB(TIMEEA) IF (ICNTL10.EQ.0) THEN C No IR : there will be only the EA of the 1st sol. IF ( MPG .GT. 0 ) WRITE( MPG, 170 ) ELSEIF (IRStep.EQ.1) THEN C IR : we print the EA of the 1st sol. IF ( MPG .GT. 0 ) WRITE( MPG, 55 ) ELSEIF ((ICNTL10.LT.0).AND.(IRStep.EQ.NITREF+1)) THEN C IR with fixed n. of steps: we print the EA C of the last sol. IF ( MPG .GT. 0 ) THEN WRITE( MPG, 81 ) WRITE( MPG, * ) WRITE( MPG, 141 ) & 'NUMBER OF STEPS OF ITERATIVE REFINEMENT REQUESTED =', & NOITER ENDIF ENDIF GIVSOL = .TRUE. CALL DMUMPS_SOL_Q(MTYPE,INFO(1),id%N, & id%RHS(IBEG), & SAVERHS,R_W(id%N+1),C_Y,GIVSOL, & RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) IF ( MPG .GT. 0 ) THEN C Error analysis before iterative refinement WRITE( MPG, 115 ) & 'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', & RINFOG(7) WRITE( MPG, 115 ) & '------(8):---------------------------- (W2)=', & RINFOG(8) END IF CALL MUMPS_SECFIN(TIMEEA) id%DKEEP(120)=id%DKEEP(120)+TIMEEA C end EA of the first solution END IF END IF C -------------- IF (IRStep.EQ.NITREF +1) THEN C If we are at the NITREF+1 step , we have refined the C solution NITREF times so we have to stop. KASE = 0 C If we test the convergence (ICNTL10.GT.0) and C IFLAG_IR = 0 we set a warning : more than NITREF steps C needed IF ((ICNTL10.GT.0).AND.(IFLAG_IR.EQ.0)) & id%INFO(1) = id%INFO(1) + 8 ELSE IF (ICNTL10.GT.0) THEN C ------------------- C Results of the test of convergence. C IFLAG_IR = 0 we should try to improve the solution C = 1 the stopping criterium is satisfied C = 2 the method is diverging, we go back C to the previous iterate C = 3 the convergence is too slow IF (IFLAG_IR.GT.0) THEN C If the convergence criterion is satisfied C or the convergence too slow C we set KASE=0 (end of the Iterative refinement) KASE = 0 C If the convergence is not improved, C we go back to the previous iterate. C IFLAG_IR can be equal to 2 only if IRStep >= 2 IF (IFLAG_IR.EQ.2) NOITER = NOITER - 1 ELSE C IFLAG_IR=0, try to improve the solution KASE = 2 ENDIF ELSEIF (ICNTL10.LT.0) THEN C ------------------- KASE = 2 ELSE C ICNTL10 = 0, we want to perform only EA and not IR. C ----------------- KASE = 0 END IF ENDIF C End Master ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C If Kase= 0 we quit the IR process IF (KASE.LE.0) GOTO 666 IF (KASE.LT.0) THEN WRITE(*,*) "Internal error 17 in DMUMPS_SOL_DRIVER" ENDIF C ========================================================= C COMPUTE the solution of Ay = r C ========================================================= C Call internal routine to avoid code duplication CALL DMUMPS_PP_SOLVE() IF (INFO(1) .LT. 0) GOTO 90 C ----------------------- C Go back to beginning of C loop to apply next step C of iterative refinement C ----------------------- 22 CONTINUE 666 CONTINUE C ************************************************ C C End of the iterative refinement procedure C C ************************************************ CALL MUMPS_SECFIN(TIMEIT) IF ( id%MYID .EQ. MASTER ) THEN IF ( NITREF .GT. 0 ) THEN id%INFOG(15) = NOITER END IF C id%DKEEP(114) time for the iterative refinement C id%DKEEP(120) time for the error analysis C id%DKEEP(121) time for condition number C these values are meaningful only on the host. IF (ICNTL10.EQ.0) THEN C No IR has been requested. All the time is needed C for computing EA id%DKEEP(120)=TIMEIT ELSE C IR has been requested id%DKEEP(114)=TIMEIT - id%DKEEP(120) ENDIF END IF IF ( PROKG ) THEN IF (ICNTL10.GT.0) THEN WRITE( MPG, 81 ) WRITE( MPG, * ) WRITE( MPG, 141 ) & 'NUMBER OF STEPS OF ITERATIVE REFINEMENTS PERFORMED =', & NOITER ENDIF ENDIF C C ================================================== C BEGIN C Perform error analysis after iterative refinement C ================================================== IF ((ICNTL11 .GT. 0).AND.(ICNTL10.GT.0)) THEN C If IR is requested with test of convergence, C the EA of the last step of IR is done here, C otherwise EA of the last step is done at the C end of IR CALL MUMPS_SECDEB(TIMEEA) KASE = 0 IF (id%MYID .eq. MASTER ) THEN C Test if IFLAG_IR = 2, that is if the the IR was diverging, C we went back to the previous iterate C We have to do EA on the last computed solution. IF (IFLAG_IR.EQ.2) KASE = 2 ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KASE.EQ.2) THEN C We went back to the previous iterate C We have to do EA on the last computed solution. C Compute the residual in C_Y using IRN, JCN, ASPK C and the solution RHS(IBEG) C The norm of the ith row in R_Y(I). IF ( KEEP(54) .eq. 0 ) THEN C --------------------- C Matrix is centralized C --------------------- IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN CALL DMUMPS_QD2( MTYPE, id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), & id%RHS(IBEG), SAVERHS, R_Y, C_Y, KEEP(1),KEEP8(1)) ELSE CALL DMUMPS_ELTQD2( MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), id%A_ELT(1), & id%RHS(IBEG), SAVERHS, R_Y, C_Y, KEEP(1),KEEP8(1)) ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- CALL MPI_BCAST( RHS_IR(IBEG), id%N, & MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) C ---------------- C Compute residual C ---------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN CALL DMUMPS_LOC_MV8( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_Y, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) C_Y = SAVERHS - C_Y ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) END IF ENDIF ENDIF ! KASE.EQ.2 IF (id%MYID .EQ. MASTER) THEN C Compute which equations are associated to w1 and which C ones are associated to w2 in case of IFLAG_IR=2. C If IFLAG_IR = 0 or 1 IW1 should be correct IF (IFLAG_IR.EQ.2) THEN TESTConv = .FALSE. CALL DMUMPS_SOL_OMEGA(id%N,SAVERHS, & id%RHS(IBEG), C_Y, R_W, C_W, IW1, IFLAG_IR, & RINFOG(7), 0, TESTConv, & MP, ARRET, KEEP(361), id%DKEEP(22) ) ENDIF ! (IFLAG_IR.EQ.2) c Compute some statistics for GIVSOL = .TRUE. CALL DMUMPS_SOL_Q(MTYPE,INFO(1),id%N, & id%RHS(IBEG), & SAVERHS,R_W(id%N+1),C_Y,GIVSOL, & RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) ENDIF ! Master CALL MUMPS_SECFIN(TIMEEA) id%DKEEP(120)=id%DKEEP(120)+TIMEEA ENDIF ! ICNTL11>0 and ICNTL10>0 C ========================================================= C Compute the Condition number associated if requested. C ========================================================= CALL MUMPS_SECDEB(TIMELCOND) IF (ICNTL11 .EQ. 1) THEN IF ( id%MYID .eq. MASTER ) THEN C Notice that D is always the identity ALLOCATE( D(id%N),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 DO I = 1, id%N D( I ) = RONE END DO ENDIF KASE = 0 222 CONTINUE IF ( id%MYID .EQ. MASTER ) THEN CALL DMUMPS_SOL_LCOND(id%N, SAVERHS, & id%RHS(IBEG), C_Y, D, R_W, C_W, IW1, KASE, & RINFOG(7), RINFOG(9), RINFOG(10), & MP, KEEP(1),KEEP8(1)) ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C KASE <= 0 C We reach the end of iterative method to compute C LCOND1 and LCOND2 IF (KASE.LE.0) GOTO 224 CALL DMUMPS_PP_SOLVE() IF (INFO(1) .LT. 0) GOTO 90 C --------------------------- C Go back to beginning of C loop to apply next step C of iterative method C ----------------------- GO TO 222 C End ICNTL11 = 1 ENDIF 224 CONTINUE CALL MUMPS_SECFIN(TIMELCOND) id%DKEEP(121)=id%DKEEP(121)+TIMELCOND IF ((id%MYID .EQ. MASTER).AND.(ICNTL11.GT.0)) THEN IF (ICNTL10.GT.0) THEN C If ICNTL10<0 these stats have been printed before IR IF ( MPG .GT. 0 ) THEN WRITE( MPG, 115 ) & 'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', & RINFOG(7) WRITE( MPG, 115 ) & '------(8):---------------------------- (W2)=', & RINFOG(8) ENDIF END IF IF (ICNTL11.EQ.1) THEN C If ICNTL11/=1 these stats haven't been computed IF (MPG.GT.0) THEN WRITE( MPG, 115 ) & '------(9):Upper bound ERROR ...............=', & RINFOG(9) WRITE( MPG, 115 ) & '-----(10):CONDITION NUMBER (1) ............=', & RINFOG(10) WRITE( MPG, 115 ) & '-----(11):CONDITION NUMBER (2) ............=', & RINFOG(11) END IF END IF END IF ! MASTER && ICNTL11.GT.0 IF ( PROKG ) THEN WRITE( MPG, * ) IF (abs(ICNTL10) .GT.0 ) WRITE( MPG, 101 ) id%DKEEP(114) IF (ICNTL11 .GT.0 ) WRITE( MPG, 102 ) id%DKEEP(120) IF (ICNTL11 .EQ.1 ) WRITE( MPG, 103 ) id%DKEEP(121) WRITE( MPG, * ) ENDIF IF ( PROKG .AND. abs(ICNTL10) .GT.0 ) WRITE( MPG, 131 ) C=================================================== C Perform error analysis after iterative refinements C END C=================================================== C IF (id%MYID == MASTER) THEN NB_BYTES = NB_BYTES - int(size(C_W),8)*K35_8 DEALLOCATE(C_W) NB_BYTES = NB_BYTES - int(size(R_W),8)*K16_8 & - int(size(IW1),8)*K34_8 DEALLOCATE(R_W) DEALLOCATE(IW1) IF (ICNTL11 .EQ. 1) THEN C We have used D only for LCOND1,2 NB_BYTES = NB_BYTES - int(size(D ),8)*K16_8 DEALLOCATE(D) ENDIF ENDIF NB_BYTES = NB_BYTES - & (int(size(R_Y),8)+int(size(R_LOCWK54),8))*K16_8 NB_BYTES = NB_BYTES - & (int(size(C_Y),8)+int(size(C_LOCWK54),8))*K35_8 DEALLOCATE(R_Y) DEALLOCATE(C_Y) DEALLOCATE(R_LOCWK54) DEALLOCATE(C_LOCWK54) C} End POSTPros END IF C============================================ C C ITERATIVE REFINEMENT AND/OR ERROR ANALYSIS C C END C C============================================ C ========================== C Begin reordering on master C corresponding to maximum transversal permutation C in case of centralized solution C (ICNTL21==0) C IF ( id%MYID .EQ. MASTER .AND. ICNTL21==0 & .AND. KEEP(23) .NE. 0.AND.KEEP(237).EQ.0) THEN C ((No transpose and backward performed and NO A-1) C or null space computation): permutation C must be done on solution. IF ((KEEP(221).NE.1 .AND. MTYPE .EQ. 1) & .OR. KEEP(111) .NE.0 .OR. KEEP(252).NE.0 ) THEN C Permute the solution RHS according to the column C permutation held in UNS_PERM C Column J of the permuted matrix corresponds to C column UNS_PERM(J) of the original matrix. C RHS holds the permuted solution C Note that id%N>1 since KEEP(23)=0 when id%N=1 C ALLOCATE( C_RW1( id%N ),stat =allocok ) ! temporary not in NB_BYTES IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) & WRITE(LP,*) 'could not allocate ', id%N, 'integers.' CALL MUMPS_ABORT() END IF DO K = 1, NBRHS_EFF IF (KEEP(242).EQ.0) THEN KDEC = (K-1)*LD_RHS+IBEG-1 ELSE C ------------------------------- C Columns just computed might not C be contiguous in original RHS C ------------------------------- KDEC = int(PERM_RHS(K-1+JBEG_RHS)-1,8)*int(LD_RHS,8) ENDIF DO I = 1, id%N C_RW1(I) = id%RHS(KDEC+I) ENDDO DO I = 1, id%N JPERM = id%UNS_PERM(I) id%RHS( KDEC+JPERM ) = C_RW1( I ) ENDDO ENDDO DEALLOCATE( C_RW1 ) !temporary not in NB_BYTES END IF END IF C C End reordering on master C ======================== IF (id%MYID.EQ.MASTER .and.ICNTL21==0.and.KEEP(221).NE.1.AND. & (KEEP(237).EQ.0) ) THEN * print out the solution IF ( INFO(1) .GE. 0 .AND. ICNTL(4).GE.3 .AND. ICNTL(3).GT.0) & THEN K = min(10, id%N) IF (ICNTL(4) .eq. 4 ) K = id%N J = min(10,NBRHS_EFF) IF (ICNTL(4) .eq. 4 ) J = NBRHS_EFF DO II=1, J WRITE(ICNTL(3),110) BEG_RHS+II-1 WRITE(ICNTL(3),160) & (id%RHS(IBEG+(II-1)*LD_RHS+I-1),I=1,K) ENDDO END IF END IF C ========================== C blocking for multiple RHS (END OF DO WHILE (BEG_RHS.LE.NBRHS) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN ! case of general sparse: in case of empty columns ! NBRHS_EFF might has been updated and broadcasted ! and holds the effective size of a contiguous block of ! non empty columns BEG_RHS = BEG_RHS + NBRHS_EFF ! nb of nonempty columns ELSE BEG_RHS = BEG_RHS + NBRHS ENDIF C } ENDDO C END DO WHILE (BEG_RHS.LE.id%NRHS) C ================================= C C ======================================================== C Reset RHS to zero for all remaining columns that C have not been processed because they were emtpy C ======================================================== IF ( (id%MYID.EQ.MASTER) & .AND. ( KEEP(248).NE.0 ) ! sparse RHS on input & .AND. ( KEEP(237).EQ.0 ) ! No A-1 & .AND. ( ICNTL21.EQ.0 ) ! Centralized solution & .AND. ( KEEP(221) .NE.1 ) ! Not Reduced RHS step of Schur & .AND. ( JEND_RHS .LT. id%NRHS ) & ) & THEN JBEG_NEW = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%N id%RHS(int(PERM_RHS(JBEG_NEW) -1,8)*int(LD_RHS,8)+I) & = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ELSE DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%N id%RHS(int(JBEG_NEW -1,8)*int(LD_RHS,8) + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ENDIF C ======================================================== C Reset id%SOL_loc to zero for all remaining columns that C have not been processed because they were empty C ======================================================== IF ( I_AM_SLAVE .AND. (ICNTL21.NE.0) .AND. & ( JEND_RHS .LT. id%NRHS ) .AND. KEEP(221).NE.1 ) THEN JBEG_NEW = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, NSOL_loc id%SOL_loc(int(PERM_RHS(JBEG_NEW) -1,8)* & int(id%LSOL_loc,8)+int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ELSE C DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, NSOL_loc id%SOL_loc((JBEG_NEW -1)*id%LSOL_loc + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF C C ================================================================ C Reset id%RHSINTR and id%REDRHS to zero for all remaining columns C that have not been processed because they were emtpy C ================================================================ IF ((KEEP(221).EQ.1) .AND. & ( JEND_RHS .LT. id%NRHS ) ) THEN IF (id%MYID .EQ. MASTER) THEN JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%SIZE_SCHUR id%REDRHS(int(JBEG_NEW -1,8)*int(LD_REDRHS,8) + & int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF IF (I_AM_SLAVE) THEN JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1,NBENT_RHSINTR id%RHSINTR(int(JBEG_NEW -1,8)*int(id%LD_RHSINTR,8) + & int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF C C C ! maximum size used on that proc id%INFO(26) = int(NB_BYTES_MAX / 1000000_8) C Centralize memory statistics on the host C C INFOG(30) = size of mem in bytes for solve C for the processor using largest memory C INFOG(31) = size of mem in bytes for solve C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(26), id%INFOG(30), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I10) ') & ' ** Rank of processor needing largest memory in solve :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used by this processor for solve :', & id%INFOG(30) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during solve :', & ( id%INFOG(31)-id%INFO(26) ) / id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during solve :', & id%INFOG(31) / id%NSLAVES END IF ELSE WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used for solve :', & id%INFOG(30) ENDIF END IF *=============================== *End of Solve Phase *=============================== C Store and print timings CALL MUMPS_SECFIN(TIME3) id%DKEEP(112)=TIME3 id%DKEEP(113)=TIMEC2 id%DKEEP(115)=TIMESCATTER2 id%DKEEP(116)=TIMEGATHER2 id%DKEEP(122)=TIMECOPYSCALE2 C Reductions of DKEEP(115,116,117,118,119,122): CALL MPI_REDUCE( id%DKEEP(115), id%DKEEP(160),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(116), id%DKEEP(161),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(117), id%DKEEP(162),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(118), id%DKEEP(163),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(119), id%DKEEP(164),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(122), id%DKEEP(165),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) C IF (PROKG) THEN WRITE ( MPG, *) WRITE ( MPG, *) "Leaving solve with ..." WRITE( MPG, 434 ) id%DKEEP(160) ! max id%DKEEP(115) WRITE( MPG, 432 ) id%DKEEP(113) ! ok without reduction WRITE( MPG, 435 ) id%DKEEP(162) ! max id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MPG, 437 ) id%DKEEP(164) ! id%DKEEP(119) WRITE( MPG, 436 ) id%DKEEP(163) ! id%DKEEP(118) WRITE( MPG, 433 ) id%DKEEP(161) ! max(DKEEP(116)) -- Gather WRITE( MPG, 431 ) id%DKEEP(165) ! max(DKEEP(122)) -- Dist. sol. ENDIF IF ( PROK ) THEN WRITE ( MP, *) WRITE ( MP, *) "Local statistics" WRITE( MP, 434 ) id%DKEEP(115) WRITE( MP, 432 ) id%DKEEP(113) WRITE( MP, 435 ) id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MP, 437 ) id%DKEEP(119) WRITE( MP, 436 ) id%DKEEP(118) WRITE( MP, 433 ) id%DKEEP(116) WRITE( MP, 431 ) id%DKEEP(122) END IF 90 CONTINUE IF (KEEP(400) .GT. 0) THEN CALL MUMPS_SOL_L0OMP_LD(KEEP(400)) ENDIF IF (INFO(1) .LT.0 ) THEN IF (INFO(1) .EQ. -80) INFO(1) = -81 ENDIF C -- related to exploit sparsity IF (associated(nodes_FWD)) THEN NB_BYTES = NB_BYTES - size(nodes_FWD) * K34_8 DEALLOCATE(nodes_FWD) NULLIFY(nodes_FWD) ENDIF IF (associated(nodes_BWD)) THEN NB_BYTES = NB_BYTES - size(nodes_BWD) * K34_8 DEALLOCATE(nodes_BWD) NULLIFY(nodes_BWD) ENDIF IF (allocated(Pruned_Sons_FWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_FWD) * K34_8 DEALLOCATE(Pruned_Sons_FWD) ENDIF IF (allocated(Pruned_Sons_BWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_BWD) * K34_8 DEALLOCATE(Pruned_Sons_BWD) ENDIF IF (SCALING_RHSINTR_FWD_ALLOCATED) THEN NB_BYTES = NB_BYTES - LSCALING_RHSINTR_FWD * K16_8 DEALLOCATE(SCALING_RHSINTR_FWD) ENDIF SCALING_RHSINTR_FWD_ALLOCATED = .FALSE. NULLIFY(SCALING_RHSINTR_FWD) IF (SCALING_RHSINTR_BWD_ALLOCATED) THEN NB_BYTES = NB_BYTES - LSCALING_RHSINTR_BWD * K16_8 DEALLOCATE(SCALING_RHSINTR_BWD) ENDIF SCALING_RHSINTR_BWD_ALLOCATED = .FALSE. NULLIFY(SCALING_RHSINTR_BWD) IF (KEEP(485) .EQ. 1) THEN KEEP(350) = KEEP350_SAVE IF (IS_LR_MOD_TO_STRUC_DONE) THEN CALL DMUMPS_BLR_MOD_TO_STRUC(id%BLRARRAY_ENCODING) CALL MUMPS_FDM_MOD_TO_STRUC('F',id%FDM_F_ENCODING, & id%INFO(1)) ENDIF ENDIF IF (KEEP(19).EQ.0.AND.KEEP(53).NE.0) THEN C restore KEEP(20) KEEP(20) = KEEP20_SAVE ENDIF IF (KEEP(201).GT.0)THEN IF (IS_INIT_OOC_DONE) THEN CALL DMUMPS_OOC_END_SOLVE(IERR) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) ENDIF C ------------------------ C Check allocation before C to deallocate (cases of C errors that could happen C before or after allocate C statement) C C Sparse RHS C Free space and reset pointers if needed IF (IRHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_SPARSE_COPY),8)*K34_8 DEALLOCATE(IRHS_SPARSE_COPY) IRHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_SPARSE_COPY) ENDIF IF (IRHS_PTR_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_PTR_COPY),8)*K34_8 DEALLOCATE(IRHS_PTR_COPY) IRHS_PTR_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_PTR_COPY) ENDIF IF (RHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(RHS_SPARSE_COPY),8)*K35_8 DEALLOCATE(RHS_SPARSE_COPY) RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_SPARSE_COPY) ENDIF IF (allocated(MAP_RHS_loc)) THEN NB_BYTES = NB_BYTES - int(size(MAP_RHS_loc),8)*K34_8 DEALLOCATE(MAP_RHS_loc) ENDIF IF (IRHS_loc_PTR_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(IRHS_loc_PTR),8)*K34_8 DEALLOCATE(IRHS_loc_PTR) NULLIFY(IRHS_loc_PTR) IRHS_loc_PTR_ALLOCATED = .FALSE. ENDIF #if defined(USE_OLD_SCALING) IF (I_AM_SLAVE.AND.LSCAL.AND.KEEP(248).EQ.-1) THEN IF (associated(scaling_data_dr%SCALING_LOC)) THEN NB_BYTES = NB_BYTES - & int(size(scaling_data_dr%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data_dr%SCALING_LOC) NULLIFY (scaling_data_dr%SCALING_LOC) ENDIF ENDIF #endif IF (allocated(PERM_RHS)) THEN NB_BYTES = NB_BYTES - int(size(PERM_RHS),8)*K34_8 DEALLOCATE(PERM_RHS) ENDIF C END A-1 IF (allocated(UNS_PERM_INV)) THEN NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 DEALLOCATE(UNS_PERM_INV) ENDIF IF (allocated(BUFR)) THEN NB_BYTES = NB_BYTES - int(size(BUFR),8)*K34_8 DEALLOCATE(BUFR) ENDIF IF ( I_AM_SLAVE ) THEN IF (allocated(RHS_BOUNDS)) THEN NB_BYTES = NB_BYTES - & int(size(RHS_BOUNDS),8)*K34_8 DEALLOCATE(RHS_BOUNDS) ENDIF IF (allocated(IWK_SOLVE)) THEN NB_BYTES = NB_BYTES - int(size(IWK_SOLVE),8)*K34_8 DEALLOCATE( IWK_SOLVE ) ENDIF IF (allocated(PTRACB)) THEN NB_BYTES = NB_BYTES - int(size(PTRACB),8)*K34_8* & int(KEEP(10),8) DEALLOCATE( PTRACB ) ENDIF IF (allocated(IWCB)) THEN NB_BYTES = NB_BYTES - int(size(IWCB),8)*K34_8 DEALLOCATE( IWCB ) ENDIF C ------------------------ C SLAVE CODE C ----------------------- C Deallocate send buffers C ----------------------- IF (id%NSLAVES .GT. 1) THEN CALL MUMPS_BUF_DEALL_CB( IERR ) CALL MUMPS_BUF_DEALL_SMALL_BUF( IERR ) ENDIF END IF C IF ( id%MYID .eq. MASTER ) THEN C ------------------------ C SAVERHS may have been C allocated only on master C ------------------------ IF (allocated(SAVERHS)) THEN NB_BYTES = NB_BYTES - int(size(SAVERHS),8)*K35_8 DEALLOCATE( SAVERHS) ENDIF C Nullify RHS_IR might have been pointing to id%RHS NULLIFY(RHS_IR) ELSE C -------------------- C Free right-hand-side C on slave processors C -------------------- IF (associated(RHS_IR)) THEN NB_BYTES = NB_BYTES - int(size(RHS_IR),8)*K35_8 DEALLOCATE(RHS_IR) NULLIFY(RHS_IR) END IF END IF IF (I_AM_SLAVE) THEN C Deallocate temporary workspace SRW3 IF (allocated(SRW3)) THEN NB_BYTES = NB_BYTES - int(size(SRW3),8)*K151_8 DEALLOCATE(SRW3) ENDIF #if defined(USE_OLD_SCALING) C Free local scaling arrays IF (LSCAL .AND. ICNTL21 .NE. 0) THEN IF (associated(scaling_data_sol%SCALING_LOC)) THEN NB_BYTES = NB_BYTES - & int(size(scaling_data_sol%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data_sol%SCALING_LOC) NULLIFY(scaling_data_sol%SCALING_LOC) ENDIF ENDIF #endif #if defined(USE_OLD_SCALING) #endif C Free memory until next call to DMUMPS IF (WK_USER_PROVIDED) THEN C S points to WK_USER provided by user C KEEP8(24) holds size of WK_USER C it should be kept on exit because it will be used C at a future solve to check that size provided is consistent C (see error -41) NULLIFY(id%S) ELSE IF (ALLOCATE_S) THEN C S was allocated, free it NB_BYTES = NB_BYTES - KEEP8(23)*K35_8 id%KEEP8(23)=0_8 DEALLOCATE(id%S) NULLIFY(id%S) NB_BYTES = NB_BYTES - KEEP8(23) * K35_8 KEEP8(23) = 0_8 ENDIF IF (KEEP(221).NE.1 & ) THEN C -- After reduction of RHS to Schur variables C -- keep compressed RHS generated during FWD step C -- to be used for future expansion IF (associated(id%RHSINTR)) THEN NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25) = 0_8 id%LD_RHSINTR = 0 ENDIF IF (associated(id%GLOB2LOC_RHS)) THEN NB_BYTES = NB_BYTES - & int(size(id%GLOB2LOC_RHS),8)*K34_8 DEALLOCATE(id%GLOB2LOC_RHS) NULLIFY(id%GLOB2LOC_RHS) ENDIF IF (id%GLOB2LOC_SOL_ALLOC) THEN NB_BYTES = NB_BYTES - & int(size(id%GLOB2LOC_SOL),8)*K34_8 DEALLOCATE(id%GLOB2LOC_SOL) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF ENDIF IF ( WORK_WCB_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(WORK_WCB),8)*K151_8 DEALLOCATE( WORK_WCB ) NULLIFY ( WORK_WCB ) ELSE C Otherwise, WORK_WCB may point to some C position inside id%S, nullify it NULLIFY( WORK_WCB ) ENDIF IF ( PTR_RHS_ROOT_ALLOCATED ) THEN DEALLOCATE(PTR_RHS_ROOT) NB_BYTES = NB_BYTES - LPTR_RHS_ROOT * K151_8 ENDIF NULLIFY(PTR_RHS_ROOT) ENDIF #if defined(STAT_ES_SOLVE) IF ( & (id%MYID.EQ.MASTER).AND. & ( (id%KEEP(235).NE.0).OR.(id%KEEP(212).NE.0) ) & ) & THEN C If exploit sparsity then C stats saved in DKEEP(200:204) and C set RINFOG(24), RINFOG(25), RINFOG(26) CALL DMUMPS_SOL_ES_PRINT_STATS( & id%KEEP(212), id%KEEP(235), id%KEEP(237), & id%KEEP(485), id%KEEP(497), & id%KEEP8(110),id%NRHS, id%ICNTL(27), id%N, & id%KEEP(50), id%DKEEP(200:204), & id%RINFOG(24:28), MPG) END IF #endif 500 CONTINUE RETURN 55 FORMAT (//' ERROR ANALYSIS BEFORE ITERATIVE REFINEMENT') 100 FORMAT(//' ****** SOLVE & CHECK STEP ********'/) 110 FORMAT (//' Vector solution for column ',I12) 115 FORMAT(1X, A44,1P,D9.2) 434 FORMAT(' Time to build/scatter RHS =',F15.6) 432 FORMAT(' Time in solution step (fwd/bwd) =',F15.6) 435 FORMAT(' .. Time in forward (fwd) step = ',F15.6) 437 FORMAT(' .. Time in ScaLAPACK root = ',F15.6) 436 FORMAT(' .. Time in backward (bwd) step = ',F15.6) 433 FORMAT(' Time to gather solution(cent.sol)=',F15.6) 431 FORMAT(' Time for distributed solution =',F15.6) 150 FORMAT(' GLOBAL STATISTICS PRIOR SOLVE PHASE ...........'/ & ' Number of right-hand-sides =',I12/ & ' Blocking factor for multiple rhs =',I12/ & ' ICNTL (9) =',I12/ & ' --- (10) =',I12/ & ' --- (11) =',I12/ & ' --- (20) =',I12/ & ' --- (21) =',I12/ & ' --- (30) =',I12/ & ' --- (35) =',I12/ & ' --- (48) (effective) =',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 ( & 2X, "Maximum number of steps = ",I4/, & 2X, "Effective stopping criterion (based on CNTL(2)) = ",E14.6/ & 2x, "Slow convergence threshold (W1+W2 ratio) = ",E14.6) 245 FORMAT ( & 2X, "Number of steps is fixed = ",I4) 270 FORMAT (/' BEGIN ITERATIVE REFINEMENT' ) 81 FORMAT (/' STATISTICS AFTER ITERATIVE REFINEMENT ') 101 FORMAT(' Time for Iterative Refinement =',F12.4) 102 FORMAT(' Time for Error Analysis =',F12.4) 103 FORMAT(' Time for Condition Number =',F12.4) 131 FORMAT (' END ITERATIVE REFINEMENT '/) 141 FORMAT(1X, A52,I4) ! Number of steps performed CONTAINS SUBROUTINE DMUMPS_CHECK_DISTRHS( & idNloc_RHS, & idLRHS_loc, & NRHS, & idIRHS_loc, & idRHS_loc, & I_AM_SLAVE, & INFO) C C Purpose: C ======= C C Check distributed RHS format. We assume that C the user has indicated that he/she provided C a distributed RHS (KEEP(248)=-1). We also C assume that the nb of RHS columns NRHS has C been broadcasted to all processes. This C routine should then be called on the workers. C C Arguments: C ========= C INTEGER, INTENT( IN ) :: idNloc_RHS INTEGER, INTENT( IN ) :: idLRHS_loc INTEGER, INTENT( IN ) :: NRHS LOGICAL, INTENT( IN ) :: I_AM_SLAVE #if defined(MUMPS_NOF2003) INTEGER, POINTER :: idIRHS_loc (:) DOUBLE PRECISION, POINTER :: idRHS_loc (:) #else INTEGER, INTENT( IN ), POINTER :: idIRHS_loc (:) DOUBLE PRECISION, INTENT( IN ), POINTER :: idRHS_loc (:) #endif INTEGER, INTENT( INOUT ) :: INFO(80) C C Local declarations: C ================== C INTEGER(8) :: REQSIZE8 C C Executable statements: C ===================== C C Quick return if nothing on this proc IF (idNloc_RHS .LE. 0) RETURN IF (idNloc_RHS .GT. 0 .AND. .NOT. I_AM_SLAVE) THEN C Nloc_RHS should not be greater than 0 C on a non working host because the distribution C of the RHS does not include the non working host. INFO(1)=-55 INFO(2)=-idLRHS_loc RETURN ENDIF C Check for leading dimension IF (NRHS.NE.1) THEN IF ( idLRHS_loc .LT. idNloc_RHS) THEN INFO(1)=-55 INFO(2)=idLRHS_loc RETURN ENDIF ENDIF IF (idNloc_RHS .GT. 0) THEN C Check association and size of index array idIRHS_loc IF (.NOT. associated(idIRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=17 RETURN ELSE IF (size(idIRHS_loc) .LT. idNloc_RHS) THEN INFO(1)=-22 INFO(2)= 17 RETURN ENDIF C Check association and size of value array idRHS_loc IF (.NOT. associated(idRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=18 RETURN ELSE C Check size of array of values idRHS_loc REQSIZE8 = int(idLRHS_loc,8)*int(NRHS,8) & + int(-idLRHS_loc+idNloc_RHS,8) #if defined(MUMPS_NOF2003) IF ( REQSIZE8 .LE. int(huge(idNloc_RHS),8) .AND. & size(idRHS_loc) .LT. int(REQSIZE8) ) THEN #else IF (size(idRHS_loc,kind=8) .LT. REQSIZE8) THEN #endif INFO(1)=-22 INFO(2)=18 RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_CHECK_DISTRHS SUBROUTINE DMUMPS_PP_SOLVE() IMPLICIT NONE C C Purpose: C ======= C Scatter right-hand side, solve the system, C and gather the solution on the host during C post-processing. C We use an internal subroutine to avoid code C duplication without the complication of adding C new parameters or local variables. All variables C in this routine have the scope of DMUMPS_SOL_DRIVER. C C IF (KASE .NE. 1 .AND. KASE .NE. 2) THEN WRITE(*,*) "Internal error 1 in DMUMPS_PP_SOLVE" CALL MUMPS_ABORT() ENDIF IF ( id%MYID .eq. MASTER ) THEN C Define matrix B as follows: C MTYPE=1 => B=A other values B=At C The user asked to solve the system Bx=b C C THEN C KASE = 1........ RW1 = INV(TRANSPOSE(B)) * RW1 C KASE = 2........ RW1 = INV(B) * RW1 IF ( MTYPE .EQ. 1 ) THEN SOLVET = KASE - 1 ELSE SOLVET = KASE END IF C SOLVET= 1 -> solve A x = B, other values solve Atx=b C We force SOLVET to have value either 0 or 1, in order C to be able to test both values, and also, be able to C test whether SOLVET = MTYPE or not. IF ( SOLVET.EQ.2 ) SOLVET = 0 #if defined(USE_OLD_SCALING) IF ( LSCAL ) THEN IF ( SOLVET .EQ. 1 ) THEN C Apply rowscaling DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%ROWSCA( K ) END DO ELSE C Apply column scaling DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%COLSCA( K ) END DO END IF END IF #endif END IF ! MYID.EQ.MASTER C ------------------------------ C Broadcast SOLVET to the slaves C ------------------------------ CALL MPI_BCAST( SOLVET, 1, MPI_INTEGER, MASTER, & id%COMM, IERR) #if ! defined(USE_OLD_SCALING) IF (LSCAL .AND. id%KEEP(89) .GT. 0) THEN IF (SOLVET .EQ. 1) THEN SCALING_LOC_FWD => id%ROWSCA_LOC ELSE SCALING_LOC_FWD => id%COLSCA_LOC ENDIF ELSE SCALING_LOC_FWD => RDUMMY_TARGET ENDIF #endif C -------------------------------------------- C Scatter the right hand side C_Y on all procs C -------------------------------------------- IF ( .NOT.I_AM_SLAVE ) THEN C -- Master not working CALL DMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, LSCAL, SCALING_LOC_FWD(1), & SOLVET, C_Y(1), id%N, 1, & 1, & C_DUMMY, 1, 1, & IDUMMY, 0, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ELSE IF (SOLVET.EQ.MTYPE) THEN C GLOB2LOC_RHS is with respect to the C original linear system (transposed or not) PTR_POSINRHSINTR_FWD => id%GLOB2LOC_RHS ELSE C Transposed, use column indices of original C system (ie, col indices of A or A^T) PTR_POSINRHSINTR_FWD => id%GLOB2LOC_SOL ENDIF LIW_PASSED = max( LIW, 1 ) CALL DMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, LSCAL, SCALING_LOC_FWD(1), & SOLVET, C_Y(1), id%N, 1, & 1, & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, 1, & PTR_POSINRHSINTR_FWD(1), NB_FS_RHSINTR_F, C & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ENDIF IF (INFO(1).LT.0) GOTO 89 C C Solve the system C IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) IF (SOLVET.EQ.MTYPE) THEN PTR_POSINRHSINTR_FWD => id%GLOB2LOC_RHS PTR_POSINRHSINTR_BWD => id%GLOB2LOC_SOL ELSE PTR_POSINRHSINTR_FWD => id%GLOB2LOC_SOL PTR_POSINRHSINTR_BWD => id%GLOB2LOC_RHS ENDIF FROM_PP=.TRUE. NBSPARSE_LOC = .FALSE. CALL DMUMPS_SOL_C(idintr%root,idintr%roota, & id%N,id%S(1),LA_PASSED,id%IS(1), & LIW_PASSED,WORK_WCB(1),LWCB8,IWCB,LIWCB,NBRHS_EFF,id%NA(1), & id%LNA,id%NE_STEPS(1),SRW3,SOLVET,ICNTL(1),FROM_PP,id%STEP(1), & id%FRERE_STEPS(1),id%DAD_STEPS(1),id%FILS(1),id%PTLUST_S(1), & id%PTRFAC(1), IWK_SOLVE(1), LIWK_SOLVE, PTRACB, LIWK_PTRACB, & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1), KEEP(1), KEEP8(1), & id%DKEEP(1),id%COMM_NODES,id%MYID,id%MYID_NODES, BUFR(1), LBUFR, & LBUFR_BYTES, id%ISTEP_TO_INIV2(1), id%TAB_POS_IN_PERE(1,1), C Next 3 arguments are not used in this call & IBEG_ROOT_DEF,IEND_ROOT_DEF,IROOT_DEF_RHS_COL1, PTR_RHS_ROOT(1), & LPTR_RHS_ROOT, SIZE_ROOT, MASTER_ROOT, id%RHSINTR(IBEG_RHSINTR), & id%LD_RHSINTR,PTR_POSINRHSINTR_FWD(1),PTR_POSINRHSINTR_BWD(1), & -1, -1, & IDUMMY(1), IDUMMY(1), & 1,1,1, IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY, 1,1, & NBSPARSE_LOC, PTR_RHS_BOUNDS(1), LPTR_RHS_BOUNDS #if defined(STAT_ES_SOLVE) & , IDUMMY, 1, JDUMMY, 1 #endif & , id%IPOOL_B_L0_OMP(1), id%LPOOL_B_L0_OMP, id%IPOOL_A_L0_OMP(1), & id%LPOOL_A_L0_OMP, id%L_VIRT_L0_OMP, id%VIRT_L0_OMP(1), & id%L_PHYS_L0_OMP, id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1), & id%PTR_LEAFS_L0_OMP(1), id%L0_OMP_MAPPING(1), id%LL0_OMP_MAPPING, & idintr%L0_OMP_FACTORS(1), id%LL0_OMP_FACTORS & ) END IF C ------------------ C Change error codes C ------------------ IF (INFO(1).eq.-2) INFO(1)=-12 IF (INFO(1).eq.-3) INFO(1)=-15 C IF (INFO(1) .GE. 0) THEN C We need a workspace of minimal size KEEP(247) C in order to unpack pieces of the solution during C DMUMPS_GATHER_SOLUTION below C - Avoid allocation if error already occurred. C - DEALLOCATE called after GATHER_SOLUTION C CWORK not needed for AM1 ALLOCATE( CWORK(max(max(KEEP(247),KEEP(246)),1)), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- 89 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) C C Return in case of error. IF (INFO(1).LT.0) RETURN C ------------------------------- C Assemble the solution on master C ------------------------------- C (Note: currently, if this part of code is executed, C then necessarily NBRHS_EFF = 1) C C === GATHER and SCALE solution ============== C #if defined(USE_OLD_SCALING) 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 #else IF (id%KEEP(89) .EQ. 0 .OR. .NOT. LSCAL) THEN SCALING_LOC_BWD => RDUMMY_TARGET ELSE IF (SOLVET.EQ.1) THEN SCALING_LOC_BWD => id%COLSCA_loc ELSE SCALING_LOC_BWD => id%ROWSCA_loc ENDIF ENDIF #endif LIW_PASSED = max( LIW, 1 ) C Solution computed during DMUMPS_SOL_C has been stored C in id%RHSINTR and is gathered on the master in C_Y IF ( .NOT. I_AM_SLAVE ) THEN C I did not participate to computing part of the solution C (id%RHSINTR not set/allocate) : receive solution, store C it and scale it. CALL DMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & SOLVET, C_Y, id%N, NBRHS_EFF, 1, & JDUMMY, id%KEEP(1),id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), size(CWORK), #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING), #else & LSCAL, SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), #endif ! RHSINTR not on non-working master & C_DUMMY, 1 , 1, IDUMMY, 1, ! for sparse permuted RHS on host & PERM_RHS, size(PERM_RHS) & ) ELSE CALL DMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & SOLVET, C_Y, id%N, NBRHS_EFF, 1, & id%PTLUST_S(1), id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), size(CWORK), #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING), #else & LSCAL, SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), #endif & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, NBRHS_EFF, & PTR_POSINRHSINTR_BWD(1), id%N, & PERM_RHS, size(PERM_RHS)) ! for sparse permuted RHS on host ENDIF DEALLOCATE( CWORK ) END SUBROUTINE DMUMPS_PP_SOLVE END SUBROUTINE DMUMPS_SOLVE_DRIVER MUMPS_5.8.1/src/zfac_process_blocfacto.F0000664000175000017500000011116215042446441020037 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE ZMUMPS_PROCESS_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL, KEEP,KEEP8, DKEEP, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_OOC, ONLY : IO_BLOCK USE MUMPS_OOC_COMMON, ONLY : TYPEF_L, STRAT_TRY_WRITE USE MUMPS_LOAD USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT USE ZMUMPS_LR_CORE USE ZMUMPS_LR_TYPE USE MUMPS_LR_STATS USE ZMUMPS_FAC_LR USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER(8) :: POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PERM(N), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER COMM, MYID INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)), ND(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER INODE, POSITION, NPIV, IERR, LP INTEGER NCOL_RECV, JBEG_BLOCK, NCOL_GEMM, SHIFT_LPOS, SHIFT_UPOS INTEGER SHIFT_BEGS_BLR_U INTEGER :: IFLAG_OOC INTEGER(8) :: POSBLOCFACTO INTEGER :: LD_BLOCFACTO INTEGER(8) :: LA_BLOCFACTO INTEGER(8) :: LA_PTR INTEGER(8) :: POSELT COMPLEX(kind=8), DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW INTEGER (8) :: LPOS, UPOS, LPOS2, IPOS, KPOS INTEGER ICT11 INTEGER I, IPIV, FPERE LOGICAL LASTPANEL, KEEP_BEGS_BLR_L, KEEP_BEGS_BLR_COL LOGICAL LASTBL_INPANEL, LASTBL_INLASTPANEL LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED COMPLEX(kind=8) ONE,ALPHA PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER :: INFO_TMP(2) INTEGER :: IDUMMY(1) INTEGER :: NELIM, NPARTSASS_MASTER, NPARTSASS_MASTER_AUX, & IPANEL, & CURRENT_BLR, & NB_BLR_L, NB_BLR_U, NB_BLR_COL INTEGER :: NBCOL_in_LRB, SIZE_BEGS_BLR_COL TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_U, BLR_L LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: LR_ACTIVATED_INT INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U, & BEGS_BLR_COL COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: BLOCK INTEGER :: OMP_NUM INTEGER NPARTSASS, NPARTSCB, MAXI_CLUSTER, LWORK, & MAXI_CLUSTER_L, MAXI_CLUSTER_U, MAXI_CLUSTER_COL INTEGER :: allocok KEEP_BEGS_BLR_COL = .FALSE. KEEP_BEGS_BLR_L = .FALSE. nullify(BEGS_BLR_L) NB_BLR_U = -7654321 SHIFT_BEGS_BLR_U = 0 NULLIFY(BEGS_BLR_U) NULLIFY(BEGS_BLR_COL) MAXI_CLUSTER = 0 CURRENT_BLR = 1 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 ) LASTPANEL = (NPIV.LE.0) IF (LASTPANEL) 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_RECV, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, JBEG_BLOCK, 1, & MPI_INTEGER, COMM, IERR ) IF (JBEG_BLOCK.EQ.1) THEN NCOL_GEMM = NCOL_RECV - NPIV SHIFT_LPOS = NPIV SHIFT_UPOS = NPIV ELSE NCOL_GEMM = NCOL_RECV SHIFT_LPOS = JBEG_BLOCK-1 SHIFT_UPOS = 0 ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER , 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT, & 1, MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) IF ( LR_ACTIVATED ) THEN IF (JBEG_BLOCK.NE.1) THEN LA_BLOCFACTO = 0_8 ELSE LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8) ENDIF ELSE LA_BLOCFACTO = int(NPIV,8) * int(NCOL_RECV,8) ENDIF CALL ZMUMPS_GET_SIZE_NEEDED( & NPIV, LA_BLOCFACTO, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID,SLAVEF, PROCNODE_STEPS, & DAD, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LA_BLOCFACTO LRLUS = LRLUS - LA_BLOCFACTO KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LA_BLOCFACTO KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LA_BLOCFACTO CALL MUMPS_LOAD_MEM_UPDATE(.FALSE., .FALSE., & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS) IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SIZE_BEGS_BLR_COL, 1, & MPI_INTEGER, COMM, IERR ) IF (SIZE_BEGS_BLR_COL.GT.0) THEN ALLOCATE(BEGS_BLR_COL(SIZE_BEGS_BLR_COL+2+IPANEL-1), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = SIZE_BEGS_BLR_COL+2 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF IF (IPANEL.GT.1) THEN BEGS_BLR_COL(1:IPANEL-1) = 1 ENDIF BEGS_BLR_COL(IPANEL) = 1 BEGS_BLR_COL(IPANEL+1) = NPIV+NELIM+1 DO I = 1, SIZE_BEGS_BLR_COL CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBCOL_in_LRB, 1, & MPI_INTEGER, COMM, IERR ) BEGS_BLR_COL(I+IPANEL+1) = & BEGS_BLR_COL(I+IPANEL) + NBCOL_in_LRB ENDDO ENDIF ENDIF IF ((NPIV .EQ. 0) & ) THEN IPIV=1 ELSE IPIV = IWPOS IWPOS = IWPOS + NPIV IF (NPIV .GT. 0.AND.JBEG_BLOCK.EQ.1) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) ENDIF IF ( LR_ACTIVATED .AND. JBEG_BLOCK.EQ.1) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*(NPIV+NELIM), & MPI_DOUBLE_COMPLEX, & COMM, IERR ) LD_BLOCFACTO = NPIV+NELIM ENDIF IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_U, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_U(max(NB_BLR_U,1)), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = max(NB_BLR_U,1) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF ALLOCATE(BEGS_BLR_U(NB_BLR_U+2), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_U+2 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF CALL ZMUMPS_MPI_UNPACK_LR_PARTIAL & (BUFR, LBUFR, LBUFR_BYTES, & POSITION, NPIV, NELIM, 'H', & BLR_U(1), NB_BLR_U, & JBEG_BLOCK, & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (JBEG_BLOCK.NE.1) SHIFT_BEGS_BLR_U = 1 IF (IFLAG.LT.0) GOTO 700 ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL_RECV, & MPI_DOUBLE_COMPLEX, & COMM, IERR ) LD_BLOCFACTO = NCOL_RECV ENDIF ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) THEN CALL ZMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 550 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 +KEEP(IXSZ)) .EQ. 0 ) THEN DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 550 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) CALL ZMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LASTBL_INPANEL = JBEG_BLOCK+NCOL_RECV.GT.LCONT1 LASTBL_INLASTPANEL = LASTPANEL .AND. LASTBL_INPANEL IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL ZMUMPS_ASM_SLAVE_ARROWHEADS(INODE, STEP(INODE), & N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, & LRGROUPS) ELSE CALL ZMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 +KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) COMPRESS_CB = .FALSE. IF (LR_ACTIVATED) THEN COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) IF (COMPRESS_CB.AND.NPIV.EQ.0) THEN COMPRESS_CB = .FALSE. IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 ENDIF ENDIF NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF (NPIV.GT.0) THEN IF (JBEG_BLOCK.EQ.1) 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_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO ENDIF LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(SHIFT_LPOS,8) IF ( (JBEG_BLOCK.EQ.1) .AND. & ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) & ) THEN CALL ztrsm('L','L','N','N', NPIV, NROW1, ONE, & A(POSBLOCFACTO), LD_BLOCFACTO, & A_PTR(LPOS2), NCOL1) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (NPIV.NE.0) THEN IF ( (NPIV1.EQ.0).AND.(JBEG_BLOCK.EQ.1) & ) THEN IOLDPS = PTRIST(STEP(INODE)) CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_L) CALL REGROUPING2(BEGS_BLR_L, NPARTSASS, NASS1, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472), & NCOL1, KEEP(1)) NB_BLR_L = NPARTSCB IF (IFLAG.LT.0) GOTO 700 CALL ZMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .TRUE., & .TRUE., & NPARTSASS_MASTER, & BEGS_BLR_L, & BEGS_BLR_COL, & huge(NPARTSASS_MASTER), & INFO_TMP) IF (associated(BEGS_BLR_COL)) DEALLOCATE(BEGS_BLR_COL) IF (IFLAG.LT.0) GOTO 700 ELSE CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_L) KEEP_BEGS_BLR_L = .TRUE. NB_BLR_L = size(BEGS_BLR_L) - 2 NPARTSASS = 1 NPARTSCB = NB_BLR_L ENDIF ENDIF ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (LR_ACTIVATED) THEN IF ( (JBEG_BLOCK.EQ.1) & ) THEN call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) call MAX_CLUSTER(BEGS_BLR_U(1+SHIFT_BEGS_BLR_U:NB_BLR_U+2), & NB_BLR_U+1-SHIFT_BEGS_BLR_U, & MAXI_CLUSTER_U) IF (SHIFT_BEGS_BLR_U.EQ.1) & MAXI_CLUSTER_U = max(MAXI_CLUSTER_U,NPIV+NELIM) IF (LASTBL_INLASTPANEL.AND.COMPRESS_CB) THEN MAXI_CLUSTER=max(MAXI_CLUSTER_U+NELIM,MAXI_CLUSTER_L) ELSE MAXI_CLUSTER=max(MAXI_CLUSTER_U,MAXI_CLUSTER_L) ENDIF LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER & + 2*MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + LWORK*OMP_NUM LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF CURRENT_BLR=1 ALLOCATE(BLR_L(NB_BLR_L), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_L LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL ZMUMPS_COMPRESS_PANEL_I_NOOPT & (A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), NB_BLR_L+1, & DKEEP(8), KEEP(466), 0, & KEEP(473), BLR_L(1), & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP8, & OMP_NUM ) #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_L, 0) #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 300 IF ((KEEP(475).GE.1).AND.(JBEG_BLOCK.EQ.1)) THEN CALL ZMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, & LD_BLOCFACTO, -6666, & NB_BLR_L+1, & BLR_L, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_L+1, & 2, 0, 0, & .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (KEEP(486).NE.2) THEN CALL ZMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A_PTR(POSELT), LA_PTR, 1_8, & NCOL1, NCOL1, & .TRUE., & NPIV1+1, & 1, & NB_BLR_L+1, BLR_L(1), CURRENT_BLR, 'V', 1) ENDIF ENDIF 300 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ELSE CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_L) CURRENT_BLR=1 ENDIF ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & (OOCWRITE_COMPATIBLE_WITH_BLR .OR. NPIV.EQ.0) & .AND. (JBEG_BLOCK.EQ.1) & ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTPANEL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) LAST_CALL = .FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L, & A_PTR(POSELT), & LA_PTR, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG_OOC, LAST_CALL) IF ( IFLAG_OOC .LT. 0 )THEN IFLAG = IFLAG_OOC GOTO 700 ENDIF ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (LR_ACTIVATED) THEN IF (NELIM.GT.0.AND.JBEG_BLOCK.EQ.1) THEN UPOS = 1_8+int(SHIFT_UPOS,8) CALL ZMUMPS_BLR_UPD_NELIM_VAR_L_I( & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & CURRENT_BLR, BLR_L(1), NB_BLR_L+1, & CURRENT_BLR+1, NELIM, 'N') ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL ZMUMPS_BLR_UPDATE_TRAILING_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & BEGS_BLR_U(1), size(BEGS_BLR_U), CURRENT_BLR, & BLR_L(1), NB_BLR_L+1, & BLR_U(1), NB_BLR_U+1, & 0, & .TRUE., & NPIV1, & 2, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ELSE UPOS = POSBLOCFACTO+int(SHIFT_UPOS,8) CALL zgemm('N','N', NCOL_GEMM, NROW1, NPIV, & ALPHA,A(UPOS), NCOL_RECV, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ENDIF ENDIF IF (LASTBL_INPANEL) THEN IW(IOLDPS + KEEP(IXSZ)) = IW(IOLDPS + KEEP(IXSZ)) - NPIV IW(IOLDPS + 3 + KEEP(IXSZ))= IW(IOLDPS + 3 + KEEP(IXSZ)) + NPIV IF (LASTPANEL) THEN IW(IOLDPS+1+KEEP(IXSZ) ) = IW(IOLDPS+3+KEEP(IXSZ) ) ENDIF ENDIF IF ( .not. LASTBL_INLASTPANEL .AND. & (IW(IOLDPS+1+KEEP(IXSZ)) .EQ. IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN write(*,*) 'Internal ERROR 1 **** IN BLACFACTO ' CALL MUMPS_ABORT() ENDIF IF (LR_ACTIVATED) THEN IF ((NPIV.GT.0) & ) THEN CALL DEALLOC_BLR_PANEL( BLR_U, NB_BLR_U, KEEP8, KEEP(34)) DEALLOCATE(BLR_U) IF (KEEP(486).NE.3) THEN CALL UPD_MRY_LU_LRGAIN(BLR_L, NPARTSCB & ) ENDIF ENDIF ENDIF LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) IWPOS = IWPOS - NPIV IF (LASTBL_INPANEL) THEN 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 MUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IF (LR_ACTIVATED.AND.LASTBL_INPANEL.AND. & (KEEP(486).EQ.3) & ) THEN IF (NPIV.NE.0) THEN CALL ZMUMPS_BLR_FORCE_FREE_PANEL_L(IW(IOLDPS+XXF), IPANEL, & KEEP8, KEEP(34)) nullify(BLR_L) ENDIF ENDIF IF (LASTBL_INLASTPANEL) THEN IF (KEEP(486).NE.0) THEN IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (COMPRESS_CB) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER_AUX) KEEP_BEGS_BLR_COL = .TRUE. BEGS_BLR_COL(1+NPARTSASS_MASTER) = & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM NB_BLR_COL = size(BEGS_BLR_COL) - 1 call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) call MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER_COL=MAXI_CLUSTER_COL+NELIM IF ( (MAXI_CLUSTER.LT.MAXI_CLUSTER_COL).OR. & (MAXI_CLUSTER.LT.MAXI_CLUSTER_L) ) THEN MAXI_CLUSTER = max(MAXI_CLUSTER_COL,MAXI_CLUSTER_L) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER & + 2*MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + LWORK*OMP_NUM LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF ENDIF allocate(CB_LRB(NB_BLR_L,NB_BLR_COL-NPARTSASS_MASTER), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_L*(NB_BLR_COL-NPARTSASS_MASTER) GOTO 700 ENDIF CALL ZMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif IF (COMPRESS_CB) THEN CALL ZMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_L, NB_BLR_COL-NPARTSASS_MASTER, & NPARTSASS_MASTER, & NROW1, NCOL1-NPIV1-NPIV, INODE, & IW(IOLDPS+XXF), 0, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, OMP_NUM, & -9999, -9999, -9999, KEEP(1), & IDUMMY, 0, -9999 ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 IF ( KEEP(251).EQ.2 .AND. KEEP(486).EQ.2 ) THEN CALL ZMUMPS_BLR_FREE_ALL_PANELS( IW(IOLDPS+XXF), & 0, & KEEP8, KEEP(34) ) ENDIF ENDIF CALL ZMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, roota, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF GOTO 550 700 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 550 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(BEGS_BLR_COL)) THEN IF (.NOT. KEEP_BEGS_BLR_COL) DEALLOCATE(BEGS_BLR_COL) ENDIF IF (associated(BEGS_BLR_L)) THEN IF (.NOT. KEEP_BEGS_BLR_L) DEALLOCATE(BEGS_BLR_L) ENDIF IF ((NPIV.GT.0) & ) THEN IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_PROCESS_BLOCFACTO SUBROUTINE ZMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, & NPIV, NELIM, DIR, & BLR_U, NB_BLOCK_U, & BEGS_BLR_U, KEEP8, & COMM, IERR, IFLAG, IERROR) USE ZMUMPS_LR_CORE, ONLY : LRB_TYPE, ALLOC_LRB USE ZMUMPS_LR_TYPE IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR INTEGER, INTENT(IN) :: LBUFR_BYTES INTEGER, INTENT(IN) :: BUFR(LBUFR) INTEGER, INTENT(INOUT) :: POSITION INTEGER, INTENT(IN) :: NB_BLOCK_U, NELIM, NPIV CHARACTER(len=1) :: DIR INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(OUT) :: IERR TYPE (LRB_TYPE), INTENT(OUT), & DIMENSION(max(NB_BLOCK_U,1)):: BLR_U INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2) :: BEGS_BLR_U INTEGER(8) :: KEEP8(150) LOGICAL :: ISLR INTEGER :: ISLR_INT, I INTEGER :: K, M, N INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IERR = 0 IF (size(BLR_U) .NE. & MAX(NB_BLOCK_U,1) ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_MPI_UNPACK", & NB_BLOCK_U,size(BLR_U) CALL MUMPS_ABORT() ENDIF BEGS_BLR_U(1) = 1 BEGS_BLR_U(2) = NPIV+NELIM+1 DO I = 1, NB_BLOCK_U CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ISLR_INT, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & K, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & M, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & N, 1, & MPI_INTEGER, COMM, IERR ) BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M IF (ISLR_INT .eq. 1) THEN ISLR = .TRUE. ELSE ISLR = .FALSE. ENDIF CALL ALLOC_LRB( BLR_U(I), K, M, N, ISLR, & IFLAG, IERROR, KEEP8 ) IF (IFLAG.LT.0) RETURN IF (ISLR) THEN IF (K .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*K, MPI_DOUBLE_COMPLEX, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%R(1,1), N*K, MPI_DOUBLE_COMPLEX, & COMM, IERR) ENDIF ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*N, MPI_DOUBLE_COMPLEX, & COMM, IERR) ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_MPI_UNPACK_LR SUBROUTINE ZMUMPS_MPI_UNPACK_LR_PARTIAL( & BUFR, LBUFR, LBUFR_BYTES, POSITION, & NPIV, NELIM, DIR, & BLR_U, NB_BLOCK_U, & JBEG_BLOCK, & BEGS_BLR_U, KEEP8, & COMM, IERR, IFLAG, IERROR) USE ZMUMPS_LR_CORE, ONLY : LRB_TYPE, ALLOC_LRB USE ZMUMPS_LR_TYPE IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR INTEGER, INTENT(IN) :: LBUFR_BYTES INTEGER, INTENT(IN) :: BUFR(LBUFR) INTEGER, INTENT(INOUT) :: POSITION INTEGER, INTENT(IN) :: NB_BLOCK_U, NELIM, NPIV, JBEG_BLOCK CHARACTER(len=1) :: DIR INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(OUT) :: IERR TYPE (LRB_TYPE), INTENT(OUT), & DIMENSION(max(NB_BLOCK_U,1)):: BLR_U INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2) :: BEGS_BLR_U INTEGER(8) :: KEEP8(150) LOGICAL :: ISLR INTEGER :: ISLR_INT, I INTEGER :: K, M, N INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IERR = 0 IF (size(BLR_U) .NE. & MAX(NB_BLOCK_U,1) ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_MPI_UNPACK", & NB_BLOCK_U,size(BLR_U) CALL MUMPS_ABORT() ENDIF BEGS_BLR_U(1) = 1 BEGS_BLR_U(2) = NPIV+NELIM+1 IF (JBEG_BLOCK.NE.1) THEN BEGS_BLR_U(2) = JBEG_BLOCK ENDIF DO I = 1, NB_BLOCK_U CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ISLR_INT, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & K, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & M, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & N, 1, & MPI_INTEGER, COMM, IERR ) BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M IF (ISLR_INT .eq. 1) THEN ISLR = .TRUE. ELSE ISLR = .FALSE. ENDIF CALL ALLOC_LRB( BLR_U(I), K, M, N, ISLR, & IFLAG, IERROR, KEEP8 ) IF (IFLAG.LT.0) RETURN IF (ISLR) THEN IF (K .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*K, MPI_DOUBLE_COMPLEX, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%R(1,1), N*K, MPI_DOUBLE_COMPLEX, & COMM, IERR) ENDIF ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*N, MPI_DOUBLE_COMPLEX, & COMM, IERR) ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_MPI_UNPACK_LR_PARTIAL MUMPS_5.8.1/src/zfac_front_LDLT_type1.F0000664000175000017500000011537115042446441017444 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC1_LDLT_M CONTAINS SUBROUTINE ZMUMPS_FAC1_LDLT( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, IERROR, & UU, NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) USE ZMUMPS_FAC_FRONT_AUX_M USE ZMUMPS_OOC USE ZMUMPS_FAC_LR USE ZMUMPS_LR_TYPE USE MUMPS_LR_STATS USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_DATA_M USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T #if ! defined(BLR_NOOPENMP) #endif !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, intent(inout) :: NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW INTEGER MYID, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION UU, SEUIL COMPLEX(kind=8) A( LA ) INTEGER, TARGET :: IW( LIW ) INTEGER, intent(in) :: PERM(N) LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER :: LDA DOUBLE PRECISION UUTEMP LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC LOGICAL IS_MAXFROMM_AVAIL INTEGER PIVOT_OPTION INTEGER LRTRSM_OPTION INTEGER LAST_ROW, FIRST_ROW DOUBLE PRECISION MAXFROMM INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPiv2beWritten, IFLAG_OOC, & IDUMMY, PP_FIRST2SWAP_L, PP_LastPIVRPTRFilled TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PARPIV_T1, OFFSET INTEGER NFS4FATHER DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: M_ARRAY LOGICAL LASTPANEL INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER K473_LOC INTEGER INFO_TMP(2), MAXI_RANK INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM, NELIM_LOC TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L COMPLEX(kind=8), POINTER, DIMENSION(:) :: DIAG INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DIAGPOS, I, IP, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG COMPLEX(kind=8), ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) COMPLEX(kind=8), ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok,J INTEGER :: OMP_NUM INTEGER :: II,JJ INTEGER(8) :: UPOS, LPOS, DPOS COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) LOGICAL :: SWAP_OCCURRED INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC INTEGER :: NVSCHUR, NVSCHUR_K253, IROW_L INCLUDE 'mumps_headers.h' INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER PIVSIZ,IWPOSP2 IS_MAXFROMM_AVAIL = .FALSE. IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF SWAP_OCCURRED = .FALSE. INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF UUTEMP=UU IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC = SEUIL ENDIF LAFAC = -9999_8 XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) LDA = NFRONT NASS = abs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. COMPRESS_PANEL = .FALSE. COMPRESS_CB = .FALSE. NULLIFY(PTDummy) NULLIFY(BEGS_BLR) NULLIFY(CB_LRB) NULLIFY(ACC_LUA) NULLIFY(BLR_L) NULLIFY(BEGS_BLR_TMP) NULLIFY(BLR_PANEL) NULLIFY(DIAG) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. K473_LOC = 1 ELSE K473_LOC = KEEP(473) ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL ZMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS, KEEP, & LR_ACTIVATED, PARPIV_T1) LRTRSM_OPTION = KEEP(475) PIVOT_OPTION = KEEP(468) IF (UUTEMP.EQ.ZERO) THEN PIVOT_OPTION = 0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF IF (LR_ACTIVATED) THEN IF (LRTRSM_OPTION.EQ.3) THEN PIVOT_OPTION = MIN(PIVOT_OPTION,1) ELSEIF (LRTRSM_OPTION.EQ.2) THEN PIVOT_OPTION = MIN(PIVOT_OPTION, 2) ENDIF ENDIF IF (PIVOT_OPTION.LE.1) THEN PARPIV_T1 = 0 ENDIF CALL ZMUMPS_SET_INNERBLOCKSIZE( NBKJIB_ORIG, NASS, KEEP) IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = IOLDPS+6+XSIZE+NASS CALL ZMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 LASTPANEL = .FALSE. CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF (OOC_EFFECTIVE_ON_FRONT) THEN IDUMMY = -8765 NextPiv2beWritten = 1 PP_FIRST2SWAP_L = NextPiv2beWritten MonBloc%LastPanelWritten_L = 0 PP_LastPIVRPTRFilled = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 1 MonBloc%NROW = NFRONT MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -77777 MonBloc%INDICES => & IW(IOLDPS+6+NFRONT+XSIZE: & IOLDPS+5+NFRONT+XSIZE+NFRONT) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(405) .EQ. 1) THEN !$OMP ATOMIC UPDATE CNT_NODES = CNT_NODES + 1 !$OMP END ATOMIC ELSE CNT_NODES = CNT_NODES + 1 ENDIF ELSE IF (KEEP(486).NE.0) THEN ENDIF OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472), & NFRONT, KEEP(1)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 500 CALL ZMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .FALSE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF IF (COMPRESS_CB) THEN IF (NPARTSCB.GT.0) THEN allocate(CB_LRB(NPARTSCB,NPARTSCB),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSCB*NPARTSCB GOTO 490 ENDIF DO II=1,NPARTSCB DO JJ=1,NPARTSCB CB_LRB(II,JJ)%M=0 CB_LRB(II,JJ)%N=0 NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL ZMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF ENDIF DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = BEGS_BLR(CURRENT_BLR+1)-1 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (KEEP(480).GE.5) THEN IF (CURRENT_BLR.EQ.1) THEN ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR) THEN BLR_L(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ELSE IF (NB_BLR.GT.CURRENT_BLR) THEN CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF IF (CURRENT_BLR.LT.NPARTSASS) THEN ALLOCATE(NEXT_BLR_L(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR+1) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR+1, NEXT_BLR_L, 0) ENDIF ENDIF ELSE ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ENDIF ENDIF IF (LR_ACTIVATED) THEN ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE CALL ZMUMPS_FAC_I_LDLT(NFRONT,NASS,N,INODE, & IBEG_BLOCK, IEND_BLOCK, & IW,LIW,A,LA, & INOPV, NNEGW, NNULLNEGW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UUTEMP, & SEUIL_LOC,KEEP,KEEP8,PIVSIZ, & DKEEP(1), PIVNUL_LIST_STRUCT, SWAP_OCCURRED, XSIZE, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, MAXFROMM, IS_MAXFROMM_AVAIL, & PIVOT_OPTION, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, LR_ACTIVATED & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTPANEL = .TRUE. ELSE IF ( INOPV.LE.0 ) THEN INOPV = 0 NPVW = NPVW + PIVSIZ NVSCHUR_K253 = 0 IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT NVSCHUR_K253 = NVSCHUR + KEEP(253) ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL ZMUMPS_FAC_MQ_LDLT(IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & INODE,A,LA, & LDA, & POSELT,IFINB, & PIVSIZ, MAXFROMM, & IS_MAXFROMM_AVAIL, (UUTEMP.NE.0.0D0), & PARPIV_T1, & LAST_ROW, IEND_BLR, NVSCHUR_K253, & LR_ACTIVATED & ) IF(PIVSIZ .EQ. 2) THEN IWPOSP2 = IOLDPS+IW(IOLDPS+1+XSIZE)+6 IW(IWPOSP2+NFRONT+XSIZE) = & -IW(IWPOSP2+NFRONT+XSIZE) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB.EQ.-1) THEN LASTPANEL = .TRUE. ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = LASTPANEL MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK, & NPIV, NFRONT,NASS,INODE,A,LA, & LDA, POSELT, & KEEP, KEEP8, & -6666, -6666, & IEND_BLR, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NFRONT,NASS,INODE,A,LA, & LDA, POSELT, & KEEP, KEEP8, & IEND_BLR, NASS, & NASS, LAST_ROW, & (PIVOT_OPTION.LE.1), .TRUE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ELSE NELIM = IEND_BLOCK - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) NULLIFY(BLR_L) IF (KEEP(480).GE.2 .AND. IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS-CURRENT_BLR ELSE FIRST_BLOCK = 1 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8, FIRST_BLOCK=FIRST_BLOCK) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF ENDIF GOTO 100 ENDIF IF (PIVOT_OPTION.GE.3) THEN FIRST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN FIRST_ROW = NASS ELSE FIRST_ROW = IEND_BLR ENDIF IF (LRTRSM_OPTION.EQ.3) THEN LAST_ROW = IEND_BLR ELSEIF (LRTRSM_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = NFRONT ENDIF IF ((IEND_BLR.LT.NFRONT) .AND. (LAST_ROW-FIRST_ROW.GT.0)) THEN CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & INODE, A, LA, LDA, POSELT, & KEEP, KEEP8, & FIRST_ROW, LAST_ROW, & -6666, -6666, & .TRUE., .FALSE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ENDIF #if ! defined(BLR_NOOPENMP) #endif #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(UPOS,LPOS,DPOS,OFFSET) !$OMP& FIRSTPRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), KEEP(458), & K473_LOC, BLR_L, & CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (PIVOT_OPTION.LT.3) THEN IF (LRTRSM_OPTION.GE.2) THEN IF (PIVOT_OPTION.LE.1.AND.LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF CALL ZMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, NB_BLR, BLR_L, & CURRENT_BLR, FIRST_BLOCK, NB_BLR, & 1, 1, 0, & .FALSE., & IW, OFFSET_IW=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF IF (NELIM.GT.0) THEN IF (PIVOT_OPTION.LE.1) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF LPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR)-1,8) DPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR)-1,8) OFFSET=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1 UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8) #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL ZMUMPS_FAC_LDLT_COPYSCALE_U( NELIM, 1, & KEEP(424), NFRONT, NPIV-IBEG_BLR+1, & LIW, IW, OFFSET, LA, A, POSELT, LPOS, UPOS, DPOS) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif LPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8) CALL ZMUMPS_BLR_UPD_NELIM_VAR_L( & A, LA, UPOS, A, LA, LPOS, & IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & FIRST_BLOCK, NELIM, 'N') ENDIF ENDIF IF (IFLAG.LT.0) GOTO 400 #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS-CURRENT_BLR ELSE FIRST_BLOCK = 1 ENDIF CALL ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8, FIRST_BLOCK=FIRST_BLOCK) ENDIF ELSE CALL ZMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, & MAXI_CLUSTER, NPIV, & 1, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (LRTRSM_OPTION.GE.2) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF IF (KEEP(486).NE.2) THEN LAST_BLOCK = NB_BLR ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, NFRONT, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL(BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & KEEP(34)) DEALLOCATE(BLR_L) ELSE NULLIFY(NEXT_BLR_L) ENDIF ENDIF NULLIFY(BLR_L) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = LASTPANEL MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO J=1,NB_BLR+1 BEGS_BLR_TMP(J) = BEGS_BLR_STATIC(J) ENDDO ENDIF ENDIF MEM_TOT = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP& PRIVATE(IP, NELIM_LOC, BLR_PANEL) #endif IF ( & (KEEP(486).EQ.2) & ) THEN #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DIAGPOS, POSELT_DIAG, !$OMP& MEM, allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*DIAGSIZ_STA MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DIAGPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA DIAG(DIAGPOS:DIAGPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DIAGPOS = DIAGPOS + DIAGSIZ_DYN POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL ZMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG, KEEP(34)) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO !$OMP SINGLE #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM_TOT,8), & (KEEP(405).NE.0), KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 447 IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN DO IP=1,NPARTSASS NELIM_LOC = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8, & KEEP(34)) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(458), K473_LOC, & BLR_PANEL, IP, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM_LOC, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif 445 CONTINUE ENDIF 447 CONTINUE ENDIF IF (IFLAG .LT. 0) GOTO 450 IF (KEEP(480) .GE. 2) THEN #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif CALL ZMUMPS_BLR_UPD_CB_LEFT_LDLT(A, LA, POSELT, NFRONT, & BEGS_BLR_STATIC, BEGS_BLR, NPARTSCB, NPARTSASS, NASS, & IW(IOLDPS+XXF), & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(484), KEEP8) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF IF (IFLAG.LT.0) GOTO 450 #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF (COMPRESS_CB & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL ZMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (COMPRESS_CB) THEN IEND_BLR = BEGS_BLR(CURRENT_BLR+2) IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) ENDIF ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (COMPRESS_CB) THEN #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL ZMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) IF (NFS4FATHER.GE.0) NFS4FATHER = NFS4FATHER + NELIM ENDIF ALLOCATE(M_ARRAY(max(NFS4FATHER,1)), stat=allocok) IF ( allocok.GT.0 ) THEN IFLAG = -13 IERROR = max(NFS4FATHER,1) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 448 CALL ZMUMPS_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR, NPARTSCB, NPARTSCB, NPARTSASS, & NFRONT-NASS, NFRONT-NASS, INODE, & IW(IOLDPS+XXF), 2, 1, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR+KEEP(253), KEEP(1), & M_ARRAY=M_ARRAY, & NELIM=NELIM ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 448 #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL ZMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF DEALLOCATE(M_ARRAY) #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif 448 CONTINUE ENDIF 450 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF ( & ( & (KEEP(486).EQ.2) & ) & .AND.UU.GT.0 .AND. SWAP_OCCURRED & ) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 1, NASS-NPIV) DO IP=1,NPARTSASS CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NB_BLR-IP & ) ENDDO CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NPIV, 2, 1) ENDIF IF (.NOT. COMPRESS_PANEL) THEN CALL ZMUMPS_FAC_T_LDLT(NFRONT,NASS,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, KEEP,KEEP8, & (PIVOT_OPTION.NE.3), ETATASS, & TYPEF_L, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG, IOLDPS+6+XSIZE+NFRONT, INODE ) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 1, 1) ENDIF ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_L, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF CALL ZMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 490 CONTINUE 500 CONTINUE 600 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) deallocate(TAU) IF (allocated(JPVT)) deallocate(JPVT) IF (allocated(BLOCK)) deallocate(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) ENDDO ENDIF DEALLOCATE(ACC_LUA) NULLIFY(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL ZMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8, KEEP(34)) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND. .NOT.COMPRESS_CB) THEN CALL ZMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34), MTK405=KEEP(405)) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_FAC1_LDLT END MODULE ZMUMPS_FAC1_LDLT_M SUBROUTINE ZMUMPS_FAC1_LDLT_I( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, IERROR, & UU, NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T USE ZMUMPS_FAC1_LDLT_M, ONLY: ZMUMPS_FAC1_LDLT IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, intent(inout) :: NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW INTEGER MYID, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION UU, SEUIL COMPLEX(kind=8) A( LA ) INTEGER IW( LIW ) INTEGER, intent(in) :: PERM(N) LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)) CALL ZMUMPS_FAC1_LDLT( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, IERROR, & UU, NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) RETURN END SUBROUTINE ZMUMPS_FAC1_LDLT_I MUMPS_5.8.1/src/csol_bwd.F0000664000175000017500000001653015042446440015140 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SOL_S(N, A, LA, IW, LIW, W, LWC, & NRHS, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, & MYLEAF, MYROOT, ICNTL, INFO, & PROCNODE_STEPS, & SLAVEF, COMM,MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS & , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) USE CMUMPS_STATIC_PTR_M, ONLY : CMUMPS_SET_STATIC_PTR, & CMUMPS_GET_TMP_PTR USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_L0OMPFAC_T IMPLICIT NONE INTEGER MTYPE INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: LWC INTEGER, intent(in) :: N,LIW,LIWW,LPOOL INTEGER, intent(in) :: SLAVEF,MYLEAF,MYROOT,COMM,MYID INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER NE_STEPS(KEEP(28)) INTEGER IPOOL(LPOOL) INTEGER LPANEL_POS INTEGER PANEL_POS(LPANEL_POS) INTEGER ICNTL(60), INFO(80) INTEGER PTRIST(KEEP(28)), & PTRICB(KEEP(28)) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER NRHS COMPLEX A(LA), W(LWC) COMPLEX W2(KEEP(133)) INTEGER IW(LIW),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)),DAD(KEEP(28)),FILS(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LRHSINTR, POSINRHSINTR_BWD(N) COMPLEX RHSINTR(LRHSINTR,NRHS) INTEGER(8), intent(in) :: LRHS_ROOT COMPLEX RHS_ROOT( LRHS_ROOT ) LOGICAL, INTENT(in) :: PRUN_BELOW INTEGER, intent(in) :: SIZE_TO_PROCESS LOGICAL, intent(in) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP INTEGER, INTENT( in ) :: LL0_OMP_MAPPING, LL0_OMP_FACTORS INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) TYPE (CMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' LOGICAL FLAG COMPLEX, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER :: UNDERL0MAP INTEGER(8) :: POSWCB, PLEFTW INTEGER POSIWCB INTEGER NBFINF INTEGER INODE INTEGER III,IIPOOL,MYLEAF_LEFT LOGICAL BLOQ INTEGER DUMMY(1) LOGICAL :: ERROR_WAS_BROADCASTED, DO_MCAST2_TERMBWD LOGICAL :: ALLOW_OTHERS_TO_LEAVE LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: allocok DUMMY(1)=0 KEEP(266)=0 ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of DEJA_SEND in ' & //'routine CMUMPS_SOL_S ' INFO(1)=-13 INFO(2)=SLAVEF endif CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT.0 ) GOTO 340 PLEFTW = 1_8 POSIWCB = LIWW POSWCB = LWC III = 1 IIPOOL = MYROOT + 1 MYLEAF_LEFT = MYLEAF NBFINF = SLAVEF ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) ALLOW_OTHERS_TO_LEAVE = ALLOW_OTHERS_TO_LEAVE .OR. & KEEP(31) .EQ. 1 IF (ALLOW_OTHERS_TO_LEAVE) THEN CALL CMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERMBWD, & SLAVEF, KEEP) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0 .AND. MYLEAF_LEFT .EQ. 0) THEN GOTO 340 ENDIF ENDIF ERROR_WAS_BROADCASTED = .FALSE. DO_MCAST2_TERMBWD = .FALSE. DO WHILE ( NBFINF .NE. 0 .OR. MYLEAF_LEFT .NE. 0 ) IF ( SLAVEF.EQ.1 ) THEN FLAG = .FALSE. ELSE BLOQ = ( III .EQ. IIPOOL ) CALL CMUMPS_BACKSLV_RECV_AND_TREAT( BLOQ, FLAG, BUFR, LBUFR, & LBUFR_BYTES, MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD & , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO(1) .LT. 0 ) GOTO 340 ENDIF IF ( .NOT. FLAG ) THEN IF (III .NE. IIPOOL) THEN INODE = IPOOL(IIPOOL-1) IIPOOL = IIPOOL - 1 IF (KEEP(400) .GT. 0 ) THEN UNDERL0MAP = L0_OMP_MAPPING(STEP(INODE)) ELSE UNDERL0MAP = 0 ENDIF IF (UNDERL0MAP .EQ. 0 .OR. KEEP(201).GT.0) THEN CALL CMUMPS_SET_STATIC_PTR(A) CALL CMUMPS_GET_TMP_PTR(A_PTR) LA_PTR = LA ELSE A_PTR => L0_OMP_FACTORS(UNDERL0MAP)%A LA_PTR = L0_OMP_FACTORS(UNDERL0MAP)%LA ENDIF CALL CMUMPS_SOLVE_NODE_BWD( INODE, & N, IPOOL, LPOOL, IIPOOL, NBFINF, & A_PTR(1), LA_PTR, IW, LIW, W, LWC, NRHS, & POSWCB, PLEFTW, POSIWCB, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, & MYLEAF_LEFT, INFO, & PROCNODE_STEPS, DEJA_SEND, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & , DO_MCAST2_TERMBWD & ) IF ( INFO(1) .LT. 0 ) THEN IF (.NOT. ERROR_WAS_BROADCASTED) THEN IF (NBFINF .NE. 0 ) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ENDIF ENDIF IF (DO_MCAST2_TERMBWD) THEN CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & TERMBWD, SLAVEF, KEEP ) ENDIF ENDIF END IF ENDDO 340 CONTINUE IF (ALLOCATED(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE CMUMPS_SOL_S MUMPS_5.8.1/src/dfac_front_aux.F0000664000175000017500000026623015042446437016340 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_FRONT_AUX_M CONTAINS SUBROUTINE DMUMPS_FAC_H(NFRONT,NASS,IW,LIW,A,LA, & INOPV,NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IOLDPS,POSELT,UU,SEUIL,KEEP, KEEP8, DKEEP, & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U,MAXFROMN,IS_MAXFROMN_AVAIL, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, NVSCHUR &) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,LIW,INOPV INTEGER(8) :: LA INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: DKEEP(230) DOUBLE PRECISION UU, SEUIL DOUBLE PRECISION A(LA) INTEGER IW(LIW) DOUBLE PRECISION, intent(in) :: MAXFROMN LOGICAL, intent(inout) :: IS_MAXFROMN_AVAIL INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER, intent(in) :: NVSCHUR DOUBLE PRECISION AMROW DOUBLE PRECISION RMAX, SEUIL_LOC DOUBLE PRECISION SWOP INTEGER(8) :: APOS, POSELT INTEGER(8) :: J1, J2, J3_8, JJ, IDIAG INTEGER(8) :: J1_ini INTEGER(8) :: NFRONT8 INTEGER IOLDPS INTEGER NPIV,IPIV,IPIV_SHIFT INTEGER, intent(inout) :: NOFFW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW INTEGER J, J3 INTEGER NPIVP1,JMAX,ISW,ISWPS1 INTEGER ISWPS2,KSW,XSIZE INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INTEGER ISHIFT, K206 INTEGER DMUMPS_IXAMAX INCLUDE 'mumps_headers.h' INTRINSIC max DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 #if defined(_OPENMP) INTEGER :: NOMP, CHUNK NOMP = OMP_GET_MAX_THREADS() #endif SEUIL_LOC = max(DKEEP(1), SEUIL) NFRONT8 = int(NFRONT,8) INOPV = 0 XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 K206 = KEEP(206) IF ((KEEP(50).NE.1).AND.OOC_EFFECTIVE_ON_FRONT) THEN CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE) & +KEEP(IXSZ), & IW, LIW) CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF ISHIFT = 0 IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.NASS) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF (ISHIFT.GT.0.AND.IS_MAXFROMN_AVAIL) THEN IPIV = NPIVP1 APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)) .GE. UU*MAXFROMN .AND. & abs(A(IDIAG)) .GT. max(SEUIL_LOC,tiny(RMAX)) & ) THEN ISHIFT = 0 ENDIF ENDIF IF ( ISHIFT .GT. 0) THEN IS_MAXFROMN_AVAIL = .FALSE. ENDIF ENDIF DO 460 IPIV_SHIFT=NPIVP1+ISHIFT,NASS+ISHIFT IF (IPIV_SHIFT .LE. NASS) THEN IPIV=IPIV_SHIFT ELSE IPIV=IPIV_SHIFT-NASS-1+NPIVP1 ENDIF APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) JMAX = 1 AMROW = RZERO J1 = APOS J3 = NASS -NPIV JMAX = DMUMPS_IXAMAX(J3,A(J1),NFRONT,KEEP(360)) JJ = J1 + int(JMAX-1,8)*NFRONT8 AMROW = abs(A(JJ)) RMAX = AMROW J1 = APOS + int(NASS-NPIV,8) * NFRONT8 J3 = NFRONT - NASS - KEEP(253)-NVSCHUR IF (IS_MAXFROMN_AVAIL) THEN RMAX = max(MAXFROMN,RMAX) IS_MAXFROMN_AVAIL = .FALSE. ELSE IF (J3.EQ.0) GOTO 370 #if defined(_OPENMP) IF (J3.GE.KEEP(360)) THEN J1_ini = J1 CHUNK = max(KEEP(360)/2,(J3+NOMP-1)/NOMP) !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& FIRSTPRIVATE(J1_ini,NFRONT8,J3) !$OMP& REDUCTION(max:RMAX) DO J=1,J3 RMAX = max(abs(A(J1_ini + int(J-1,8) * NFRONT8)), & RMAX) END DO !$OMP END PARALLEL DO ELSE #endif DO J=1,J3 RMAX = max(abs(A(J1)), RMAX) J1 = J1 + NFRONT8 END DO #if defined(_OPENMP) ENDIF #endif END IF 370 IF (RMAX.LE.tiny(RMAX)) GO TO 460 IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)) .GE. UU*RMAX .AND. & abs(A(IDIAG)) .GT. max(SEUIL_LOC,tiny(RMAX)) ) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF ( .NOT. ( AMROW .GE. UU*RMAX .AND. & AMROW .GT. max(SEUIL_LOC,tiny(RMAX)) & ) & ) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS + int(JMAX - 1,8) * NFRONT8 )), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER( & A(APOS + int(JMAX - 1,8) * NFRONT8 ), & DET_MANTW, DET_EXPW ) ENDIF IF ( IPIV .NE. NPIVP1 .OR. JMAX .NE. 1) THEN IF (KEEP(405) .EQ.0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF ENDIF IF (IPIV.EQ.NPIVP1) GO TO 400 DET_SIGNW = - DET_SIGNW J1 = POSELT + int(NPIV,8) J3_8 = POSELT + int(IPIV-1,8) DO J= 1,NFRONT SWOP = A(J1) A(J1) = A(J3_8) A(J3_8) = SWOP J1 = J1 + NFRONT8 J3_8 = J3_8 + NFRONT8 END DO ISWPS1 = IOLDPS + 5 + NPIVP1 + NFRONT + XSIZE ISWPS2 = IOLDPS + 5 + IPIV + NFRONT + XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW 400 IF (JMAX.EQ.1) GO TO 420 DET_SIGNW = -DET_SIGNW J1 = POSELT + int(NPIV,8) * NFRONT8 J2 = POSELT + int(NPIV + JMAX - 1,8) * NFRONT8 DO KSW=1,NFRONT SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + 1_8 J2 = J2 + 1_8 END DO ISWPS1 = IOLDPS + 5 + NPIV + 1 + XSIZE ISWPS2 = IOLDPS + 5 + NPIV + JMAX + XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE INOPV = 1 GOTO 430 420 CONTINUE IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE IS_MAXFROMN_AVAIL = .FALSE. RETURN END SUBROUTINE DMUMPS_FAC_H SUBROUTINE DMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP,MAXFROMN,IS_MAXFROMN_AVAIL,NVSCHUR) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER NFRONT,NASS,LIW,IFINB INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER IW(LIW) DOUBLE PRECISION ALPHA,VALPIV INTEGER(8) :: APOS, POSELT, UUPOS, LPOS, IRWPOS INTEGER(8) :: NFRONT8 INTEGER IOLDPS,NPIV,XSIZE INTEGER, intent(in) :: KEEP(500) DOUBLE PRECISION, intent(inout) :: MAXFROMN LOGICAL, intent(inout) :: IS_MAXFROMN_AVAIL INTEGER, intent(in) :: NVSCHUR INTEGER NEL,IROW,NEL2,JCOL,NELMAXM INTEGER NPIVP1 DOUBLE PRECISION, PARAMETER :: ONE = 1.0D0 #if defined(_OPENMP) LOGICAL:: OMP_FLAG INTEGER:: NOMP, CHUNK NOMP = OMP_GET_MAX_THREADS() #endif NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 NELMAXM= NEL -KEEP(253)-NVSCHUR NEL2 = NASS - NPIVP1 IFINB = 0 IF (NPIVP1.EQ.NASS) IFINB = 1 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) #if defined(_OPENMP) OMP_FLAG = .FALSE. CHUNK = max(NEL,1) IF (NOMP.GT.1) THEN IF (NEL.LT.KEEP(360)) THEN IF (NEL*NEL2.GE.KEEP(361)) THEN OMP_FLAG = .TRUE. CHUNK = max(20, (NEL+NOMP-1)/NOMP) ENDIF ELSE OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2, (NEL+NOMP-1)/NOMP) ENDIF ENDIF #endif IF (KEEP(351).EQ.1) THEN MAXFROMN = 0.0D0 IF (NEL2 > 0) THEN IS_MAXFROMN_AVAIL = .TRUE. ENDIF !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& PRIVATE(LPOS, UUPOS, IRWPOS, ALPHA, JCOL) !$OMP& FIRSTPRIVATE(APOS,NFRONT8,VALPIV,NEL,NEL2) !$OMP& REDUCTION(max:MAXFROMN) IF(OMP_FLAG) DO IROW = 1, NEL LPOS = APOS + NFRONT8*int(IROW,8) A(LPOS) = A(LPOS)*VALPIV ALPHA = -A(LPOS) IRWPOS = LPOS + 1_8 UUPOS = APOS + 1_8 IF (NEL2 > 0) THEN A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IF (IROW.LE.NELMAXM) & MAXFROMN=max(MAXFROMN, abs(A(IRWPOS))) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 DO JCOL = 2, NEL2 A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 ENDDO ENDIF END DO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& FIRSTPRIVATE(APOS,NFRONT8,VALPIV,NEL,NEL2) !$OMP& PRIVATE(LPOS, UUPOS, IRWPOS, ALPHA, JCOL) IF(OMP_FLAG) DO IROW = 1, NEL LPOS = APOS + NFRONT8*int(IROW,8) A(LPOS) = A(LPOS)*VALPIV ALPHA = -A(LPOS) IRWPOS = LPOS + 1_8 UUPOS = APOS + 1_8 DO JCOL = 1, NEL2 A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE DMUMPS_FAC_N SUBROUTINE DMUMPS_FAC_PT_SETLOCK427( K427_OUT, K427, & K405, K222, NEL1, NASS ) INTEGER, INTENT(IN) :: K427, K405, K222, NEL1, NASS INTEGER, INTENT(OUT) :: K427_OUT K427_OUT = K427 IF ( K427_OUT .GT. 0 ) K427_OUT = 0 IF ( K427_OUT .LT. 0 ) K427_OUT = -1 RETURN END SUBROUTINE DMUMPS_FAC_PT_SETLOCK427 SUBROUTINE DMUMPS_FAC_P(A,LA,NFRONT, & NPIV,NASS,POSELT,CALL_UTRSM, KEEP, INODE, & CALL_OOC, IWFAC, LIWFAC, LAFAC, MonBloc, MYID, KEEP8, & LNextPiv2beWritten, UNextPiv2beWritten, & IFLAG ) USE DMUMPS_OOC, ONLY : IO_BLOCK, TYPEF_BOTH_LU, & DMUMPS_OOC_IO_LU_PANEL USE MUMPS_OOC_COMMON, ONLY : STRAT_TRY_WRITE IMPLICIT NONE INTEGER(8) :: LA,POSELT,LAFAC DOUBLE PRECISION A(LA) INTEGER NFRONT, NPIV, NASS LOGICAL, INTENT(IN) :: CALL_UTRSM INTEGER, INTENT(INOUT) :: IFLAG LOGICAL, INTENT(IN) :: CALL_OOC INTEGER LIWFAC, MYID, & LNextPiv2beWritten, UNextPiv2beWritten INTEGER IWFAC(LIWFAC) TYPE(IO_BLOCK) :: MonBloc INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS INTEGER NEL1, NEL11, IFLAG_OOC INTEGER :: INODE DOUBLE PRECISION ALPHA, ONE PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) INCLUDE 'mumps_headers.h' NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV LPOS2 = POSELT + int(NASS,8)*int(NFRONT,8) LPOS = LPOS2 + int(NPIV,8) LPOS1 = POSELT + int(NPIV,8) UPOS = POSELT + int(NASS,8) IF ( CALL_UTRSM ) THEN CALL dtrsm('R', 'U', 'N', 'U', NEL1, NPIV, ONE, & A(POSELT), NFRONT, A(UPOS), NFRONT) ENDIF CALL dtrsm('L','L','N','N',NPIV,NEL1,ONE,A(POSELT),NFRONT, & A(LPOS2),NFRONT) IF (CALL_OOC) THEN CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT_TRY_WRITE, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IWFAC, LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, & .FALSE. ) IF (IFLAG_OOC .LT. 0) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF CALL dgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) IF ((CALL_UTRSM).AND.(NASS-NPIV.GT.0)) THEN LPOS2 = POSELT + int(NPIV,8)*int(NFRONT,8) LPOS = LPOS2 + int(NASS,8) CALL dgemm('N','N',NEL1,NASS-NPIV,NPIV,ALPHA,A(UPOS), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_P SUBROUTINE DMUMPS_FAC_T(A,LA,NPIVB,NFRONT, & NPIV,NASS,POSELT) IMPLICIT NONE INTEGER NPIVB,NASS INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER(8) :: APOS, POSELT INTEGER NFRONT, NPIV, NASSL INTEGER(8) :: LPOS, LPOS1, LPOS2 INTEGER NEL1, NEL11, NPIVE DOUBLE PRECISION ALPHA, ONE PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV NPIVE = NPIV - NPIVB NASSL = NASS - NPIVB APOS = POSELT + int(NPIVB,8)*int(NFRONT,8) & + int(NPIVB,8) LPOS2 = APOS + int(NASSL,8) CALL dtrsm('R','U','N','U',NEL1,NPIVE,ONE,A(APOS),NFRONT, & A(LPOS2),NFRONT) LPOS = LPOS2 + int(NFRONT,8)*int(NPIVE,8) LPOS1 = APOS + int(NFRONT,8)*int(NPIVE,8) CALL dgemm('N','N',NEL1,NEL11,NPIVE,ALPHA,A(LPOS2), & NFRONT,A(LPOS1),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE DMUMPS_FAC_T SUBROUTINE DMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, NPIV, & NFRONT, LAST_ROW, LAST_COL, A, LA, POSELT, & FIRST_COL, CALL_LTRSM, CALL_UTRSM, CALL_GEMM, & WITH_COMM_THREAD, LR_ACTIVATED & ) !$ USE OMP_LIB #if defined(_OPENMP) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_TEST #endif IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: NPIV, NFRONT, LAST_ROW, LAST_COL INTEGER, intent(in) :: FIRST_COL INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: CALL_LTRSM, CALL_UTRSM, CALL_GEMM LOGICAL, intent(in) :: WITH_COMM_THREAD, LR_ACTIVATED INTEGER(8) :: NFRONT8, LPOSN, LPOS2N INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS, POSELT_LOCAL INTEGER :: NELIM, LKJIW, NEL1, NEL11, UTRSM_NCOLS DOUBLE PRECISION ALPHA, ONE PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) !$ INTEGER :: NOMP !$ LOGICAL :: TRSM_GEMM_FINISHED !$ LOGICAL :: SAVE_NESTED, SAVE_DYNAMIC NFRONT8= int(NFRONT,8) NELIM = IEND_BLOCK - NPIV NEL1 = LAST_ROW - IEND_BLOCK IF ( NEL1 < 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_FAC_SQ,IEND_BLOCK>LAST_ROW", & IEND_BLOCK, LAST_ROW CALL MUMPS_ABORT() ENDIF LKJIW = NPIV - IBEG_BLOCK + 1 NEL11 = LAST_COL - NPIV LPOS2 = POSELT + int(IEND_BLOCK,8)*NFRONT8 + int(IBEG_BLOCK-1,8) UTRSM_NCOLS = LAST_COL - FIRST_COL UPOS = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 + int(FIRST_COL,8) POSELT_LOCAL = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 & + int(IBEG_BLOCK-1,8) IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN IF (WITH_COMM_THREAD .EQV. .FALSE.) THEN IF (CALL_LTRSM) THEN CALL dtrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) ENDIF IF (CALL_UTRSM) THEN CALL dtrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL dgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF IF (CALL_GEMM) THEN LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSELT_LOCAL + int(LKJIW,8) CALL dgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF ELSE !$ NOMP = OMP_GET_MAX_THREADS() !$ CALL OMP_SET_NUM_THREADS(2) !$ SAVE_NESTED = OMP_GET_NESTED() !$ SAVE_DYNAMIC = OMP_GET_DYNAMIC() !$ CALL OMP_SET_NESTED(.TRUE.) !$ CALL OMP_SET_DYNAMIC(.FALSE.) !$ TRSM_GEMM_FINISHED = .FALSE. !$OMP PARALLEL SHARED(TRSM_GEMM_FINISHED) !$ IF (OMP_GET_THREAD_NUM() .EQ. 1) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL OMP_SET_NUM_THREADS(int(NOMP,4)) #else !$ CALL OMP_SET_NUM_THREADS(NOMP) #endif IF (CALL_LTRSM) THEN CALL dtrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) ENDIF IF (CALL_UTRSM) THEN CALL dtrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL dgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF IF (CALL_GEMM) THEN LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSELT_LOCAL + int(LKJIW,8) CALL dgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) END IF !$ TRSM_GEMM_FINISHED = .TRUE. !$ ELSE !$ DO WHILE (.NOT. TRSM_GEMM_FINISHED) !$ CALL MUMPS_BUF_TEST() !$ CALL MUMPS_USLEEP(10000) !$ END DO !$ END IF !$OMP END PARALLEL !$ CALL OMP_SET_NESTED(SAVE_NESTED) !$ CALL OMP_SET_DYNAMIC(SAVE_DYNAMIC) #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL OMP_SET_NUM_THREADS(int(NOMP,4)) #else !$ CALL OMP_SET_NUM_THREADS(NOMP) #endif ENDIF ELSE IF (CALL_UTRSM.AND.UTRSM_NCOLS.NE.0) THEN CALL dtrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL dgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_FAC_SQ SUBROUTINE DMUMPS_FAC_MQ(IBEG_BLOCK,IEND_BLOCK, & NFRONT, NASS, NPIV, LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED & ) IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK, NFRONT, & NASS, NPIV, LAST_COL INTEGER, intent(out) :: IFINB INTEGER(8), intent(in) :: LA, POSELT DOUBLE PRECISION, intent(inout) :: A(LA) LOGICAL, intent(in) :: LR_ACTIVATED DOUBLE PRECISION :: VALPIV INTEGER(8) :: APOS, UUPOS, LPOS INTEGER(8) :: NFRONT8 DOUBLE PRECISION :: ONE, ALPHA INTEGER :: NEL2,NPIVP1,KROW,NEL PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) NFRONT8= int(NFRONT,8) NPIVP1 = NPIV + 1 NEL = LAST_COL - NPIVP1 IFINB = 0 NEL2 = IEND_BLOCK - NPIVP1 IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ELSE APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 541 KROW = 1,NEL2 A(LPOS) = A(LPOS)*VALPIV LPOS = LPOS + NFRONT8 541 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS + 1_8 #if defined(MUMPS_USE_BLAS2) CALL dger(NEL,NEL2,ALPHA,A(UUPOS),1,A(LPOS),NFRONT, & A(LPOS+1_8),NFRONT) #else CALL dgemm('N','N',NEL,NEL2,1,ALPHA,A(UUPOS),NEL, & A(LPOS),NFRONT,ONE,A(LPOS+1_8),NFRONT) #endif ENDIF RETURN END SUBROUTINE DMUMPS_FAC_MQ SUBROUTINE DMUMPS_FAC_FR_UPDATE_CBROWS( INODE, NFRONT, NASS, & CALL_UTRSM, A, LA, LAFAC, POSELT, IW, LIW, IOLDPS, & MonBloc, MYID, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR) USE DMUMPS_OOC, ONLY: IO_BLOCK IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS, & LIW, MYID, XSIZE, IOLDPS, LIWFAC INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(inout) :: NOFFW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW INTEGER, intent(inout) :: PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & IFLAG LOGICAL, intent(in) :: CALL_UTRSM INTEGER, intent(inout) :: IW(LIW) DOUBLE PRECISION, intent(inout) :: A(LA) DOUBLE PRECISION, intent(in) :: SEUIL, UU, DKEEP(230) INTEGER, intent(in) :: KEEP( 500 ) INTEGER(8), intent(inout) :: LAFAC INTEGER(8) :: KEEP8(150) INTEGER, intent(in) :: NVSCHUR TYPE(IO_BLOCK), intent(inout) :: MonBloc LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER :: NPIV, NEL1, IBEG_BLOCK, IFINB, INOPV INTEGER Inextpiv DOUBLE PRECISION :: MAXFROMN LOGICAL :: IS_MAXFROMN_AVAIL NPIV = IW(IOLDPS+1+XSIZE) NEL1 = NFRONT - NASS IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF IF ((NPIV.GT.0).AND.(NEL1.GT.0)) THEN IF (OOC_EFFECTIVE_ON_FRONT) THEN MonBloc%LastPiv = NPIV ENDIF CALL DMUMPS_FAC_P(A,LA,NFRONT, NPIV, NASS, POSELT, & CALL_UTRSM, KEEP, INODE, & OOC_EFFECTIVE_ON_FRONT, IW(IOLDPS), & LIWFAC, LAFAC, & MonBloc, MYID, KEEP8, & LNextPiv2beWritten, UNextPiv2beWritten, & IFLAG) ENDIF NPIV = IW(IOLDPS+1+XSIZE) IBEG_BLOCK = NPIV IF (NASS.EQ.NPIV) GOTO 500 IF (KEEP(19).GT.0) THEN GOTO 500 ENDIF IS_MAXFROMN_AVAIL = .FALSE. 120 CALL DMUMPS_FAC_H(NFRONT,NASS,IW,LIW,A,LA, & INOPV, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IOLDPS,POSELT,UU,SEUIL, & KEEP, KEEP8, DKEEP, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, MAXFROMN, IS_MAXFROMN_AVAIL, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, NVSCHUR & ) IF (INOPV.NE.1) THEN CALL DMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP, MAXFROMN, IS_MAXFROMN_AVAIL, & NVSCHUR) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) GOTO 120 ENDIF NPIV = IW(IOLDPS+1+XSIZE) NEL1 = NFRONT - NASS IF ((NPIV.LE.IBEG_BLOCK).OR.(NEL1.EQ.0)) GO TO 500 CALL DMUMPS_FAC_T(A,LA,IBEG_BLOCK, & NFRONT,NPIV,NASS,POSELT) 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_FR_UPDATE_CBROWS SUBROUTINE DMUMPS_FAC_I(NFRONT,NASS,LAST_ROW, & IBEG_BLOCK, IEND_BLOCK, & N,INODE,IW,LIW,A,LA, & INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UU,SEUIL,KEEP,KEEP8, & DKEEP,PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR, PARPIV_T1, & TIPIV & ) !$ USE OMP_LIB USE MUMPS_OOC_COMMON USE MUMPS_PIVNUL_MOD IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(inout), OPTIONAL :: TIPIV(:) INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER, intent(in) :: NFRONT,NASS,N,LIW,INODE,LAST_ROW INTEGER, intent(inout) :: IFLAG,IERROR, INOPV,NOFFW, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW DOUBLE PRECISION, intent(in) :: UU, SEUIL INTEGER, intent(inout) :: IW(LIW) INTEGER, intent(in) :: IOLDPS INTEGER(8), intent(in) :: POSELT INTEGER KEEP(500) INTEGER(8) KEEP8(150) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT LOGICAL, intent(inout) :: SWAP_OCCURRED DOUBLE PRECISION DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER, intent(in) :: NVSCHUR INTEGER, intent(in) :: PARPIV_T1 INCLUDE 'mumps_headers.h' DOUBLE PRECISION SWOP INTEGER XSIZE INTEGER(8) :: APOS, IDIAG INTEGER(8) :: J1, J2, JJ, J3 INTEGER(8) :: NFRONT8 INTEGER ILOC DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) DOUBLE PRECISION RZERO, RMAX, AMROW, MAX_PREV_in_PARPIV DOUBLE PRECISION RCMAX INTEGER(8) :: APOSMAX, APOSROW DOUBLE PRECISION :: RMAX_NORELAX DOUBLE PRECISION PIVNUL, ABS_PIVOT DOUBLE PRECISION FIXA, CSEUIL, PIVOT INTEGER NPIV,IPIV, LRLOC INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 INTEGER ISWPS2,KSW, HF, IPIVNUL INTEGER DMUMPS_IXAMAX INTEGER :: ISHIFT, K206 INTEGER :: IPIV_SHIFT,IPIV_END INTRINSIC max DATA RZERO /0.0D0/ #if defined(_OPENMP) INTEGER :: NOMP,CHUNK #endif INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U #if defined(_OPENMP) NOMP = OMP_GET_MAX_THREADS() #endif PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL NFRONT8 = int(NFRONT,8) K206 = KEEP(206) XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE NPIVP1 = NPIV + 1 APOSMAX = POSELT+NFRONT8*NFRONT8-1_8 IF (OOC_EFFECTIVE_ON_FRONT) THEN CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF IF ( present(TIPIV) ) THEN ILOC = NPIVP1 - IBEG_BLOCK + 1 TIPIV(ILOC) = ILOC ENDIF IF (INOPV .EQ. -1) THEN JMAX=1 APOS = POSELT + NFRONT8*int(NPIVP1-1,8) + int(NPIV,8) PIVOT = A(APOS) ABS_PIVOT = abs(PIVOT) IDIAG = APOS CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .TRUE.) IF(ABS_PIVOT.LT.SEUIL) THEN IF (dble(PIVOT) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF GO TO 430 ENDIF INOPV = 0 ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) JMAX = 1 IF ((PIVOT_OPTION.EQ.0).OR.(UU.EQ.RZERO)) THEN ABS_PIVOT = abs(A(APOS)) IF(ABS_PIVOT.LT.SEUIL) THEN CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .TRUE.) IF (dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 GO TO 420 ELSE IF (ABS_PIVOT.EQ.RZERO) THEN GO TO 630 ENDIF GO TO 380 ENDIF AMROW = RZERO J1 = APOS IF (PIVOT_OPTION.EQ.1 .OR. (LR_ACTIVATED .AND. & (KEEP(480).GE.2 & ))) THEN J = IEND_BLR - NPIV ELSE J = NASS - NPIV ENDIF J2 = J1 + J - 1_8 JMAX = DMUMPS_IXAMAX(J,A(J1),1,KEEP(361)) JJ = J1 + int(JMAX - 1,8) AMROW = abs(A(JJ)) RMAX = AMROW IF (PIVOT_OPTION.GE.2) THEN J1 = J2 + 1_8 IF (PIVOT_OPTION.GE.3 & ) THEN J2 = APOS + & int(- NPIV + NFRONT - 1 - KEEP(253) - NVSCHUR,8) ELSE J2 = APOS +int(- NPIV + NASS - 1 ,8) ENDIF IF (J2.LT.J1) GO TO 370 IF (KEEP(351).EQ.1 .AND. J2-J1.GT.KEEP(361)) THEN !$ CHUNK = max(KEEP(361)/2,(int(J2-J1)+NOMP-1)/NOMP) !$OMP PARALLEL DO schedule(static, CHUNK) PRIVATE(JJ) !$OMP& FIRSTPRIVATE(J1,J2) !$OMP& REDUCTION(max:RMAX) DO JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) ENDDO !$OMP END PARALLEL DO ELSE DO 360 JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) 360 CONTINUE ENDIF 370 CONTINUE ENDIF IDIAG = APOS + int(IPIV - NPIVP1,8) ABS_PIVOT = abs(A(IDIAG)) IF (PARPIV_T1.NE.0) THEN RMAX_NORELAX = dble(A(APOSMAX+int(IPIV,8))) ELSE RMAX_NORELAX = RZERO ENDIF RMAX = max(RMAX,RMAX_NORELAX) IF ( RMAX .LE. PIVNUL ) THEN IF (LAST_ROW.EQ.NFRONT) THEN LRLOC = LAST_ROW -KEEP(253)-NVSCHUR ELSE LRLOC = LAST_ROW ENDIF IF (NFRONT - KEEP(253) .EQ. NASS) THEN IF (IEND_BLOCK.NE.NASS ) THEN GOTO 460 ENDIF J1=POSELT+int(IPIV-1,8)+int(NPIV,8)*NFRONT8 J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 ELSE J1=POSELT+int(IPIV-1,8) J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 ENDIF DO JJ=J1, J2, NFRONT8 IF ( abs(A(JJ)) .GT. PIVNUL ) THEN GOTO 460 END IF ENDDO IF ((PARPIV_T1.NE.0) & .AND.(PARPIV_T1.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & dble(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + NFRONT8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) GOTO 460 ENDDO ENDIF ENDIF CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .TRUE.) !$OMP ATOMIC CAPTURE KEEP(109) = KEEP(109)+1 IPIVNUL = KEEP(109) !$OMP END ATOMIC IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST.LT.KEEP(109)) & THEN CALL MUMPS_RESIZE_PIVNUL(KEEP, N, PIVNUL_LIST_STRUCT, & IPIVNUL, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 430 ENDIF IF (KEEP(405).EQ.1) THEN !$OMP CRITICAL(critical_pivnul) PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) !$OMP END CRITICAL(critical_pivnul) ELSE PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) ENDIF IF(dble(FIXA).GT.RZERO) THEN IF(dble(A(IDIAG)) .GE. RZERO) THEN A(IDIAG) = FIXA ELSE A(IDIAG) = -FIXA ENDIF ELSE J1 = APOS J2 = APOS + & int(- NPIV + NFRONT - 1 - KEEP(253),8) DO JJ=J1,J2 A(JJ) = ZERO ENDDO A(IDIAG) = -FIXA ENDIF JMAX = IPIV - NPIV GOTO 385 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF (ABS_PIVOT .GE. UU*RMAX .AND. & ABS_PIVOT .GT. max(SEUIL,tiny(RMAX))) THEN IF (KEEP(19).GT.0) THEN IF (LAST_ROW.EQ.NFRONT) THEN LRLOC = LAST_ROW -KEEP(253)-NVSCHUR ELSE LRLOC = LAST_ROW ENDIF J1=POSELT+int(IPIV-1,8)+int(NPIV,8)*NFRONT8 J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 RCMAX = RZERO DO JJ=J1, J2, NFRONT8 RCMAX = max(abs(A(JJ)),RCMAX) ENDDO IF (ABS_PIVOT .GE. UU*RCMAX) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF ELSE JMAX = IPIV - NPIV GO TO 380 ENDIF ENDIF IF ( .NOT. (AMROW .GE. UU*RMAX .AND. & AMROW .GT. max(SEUIL,tiny(RMAX))) ) GO TO 460 IF (KEEP(19).GT.0) THEN IF (LAST_ROW.EQ.NFRONT) THEN LRLOC = LAST_ROW -KEEP(253)-NVSCHUR ELSE LRLOC = LAST_ROW ENDIF J1=POSELT+int(NPIV+JMAX-1,8)+int(NPIV,8)*NFRONT8 J2=POSELT+int(NPIV+JMAX-1,8)+int(LRLOC-1,8)*NFRONT8 RCMAX = RZERO DO JJ=J1, J2, NFRONT8 RCMAX = max(abs(A(JJ)),RCMAX) ENDDO IF (.NOT.(AMROW .GE. UU*RCMAX) ) THEN GO TO 460 ENDIF ENDIF NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS+int(JMAX-1,8))), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER( A(APOS+int(JMAX-1,8)), & DET_MANTW, & DET_EXPW ) ENDIF 385 CONTINUE IF ( IPIV .NE. NPIVP1 .OR. JMAX .NE. 1 ) THEN SWAP_OCCURRED = .TRUE. IF (KEEP(405) .EQ. 0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF ENDIF IF (IPIV.EQ.NPIVP1) GO TO 400 IF (PARPIV_T1.NE.0) THEN SWOP = A(APOSMAX+int(NPIVP1,8)) A(APOSMAX+int(NPIVP1,8)) = A(APOSMAX+int(IPIV,8)) A(APOSMAX+int(IPIV,8)) = SWOP ENDIF DET_SIGNW = - DET_SIGNW J1 = POSELT + int(NPIV,8)*NFRONT8 J2 = J1 + NFRONT8 - 1_8 J3 = POSELT + int(IPIV-1,8)*NFRONT8 DO 390 JJ=J1,J2 SWOP = A(JJ) A(JJ) = A(J3) A(J3) = SWOP J3 = J3 + 1_8 390 CONTINUE ISWPS1 = IOLDPS + HF - 1 + NPIVP1 ISWPS2 = IOLDPS + HF - 1 + IPIV ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW 400 IF (JMAX.EQ.1) GO TO 420 DET_SIGNW = - DET_SIGNW IF ( present(TIPIV) ) THEN TIPIV(ILOC) = ILOC + JMAX - 1 ENDIF J1 = POSELT + int(NPIV,8) J2 = POSELT + int(NPIV + JMAX - 1,8) DO 410 KSW=1,LAST_ROW SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + NFRONT8 J2 = J2 + NFRONT8 410 CONTINUE ISWPS1 = IOLDPS + HF - 1 + NFRONT + NPIV + 1 ISWPS2 = IOLDPS + HF - 1 + NFRONT + NPIV + JMAX ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 430 630 CONTINUE IFLAG = -10 GOTO 430 420 CONTINUE IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_I SUBROUTINE DMUMPS_FAC_I_LDLT & ( NFRONT,NASS,N,INODE,IBEG_BLOCK,IEND_BLOCK, & IW,LIW, A,LA, INOPV, & NNEGW, NNULLNEGW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UU, SEUIL,KEEP,KEEP8,PIVSIZ, & DKEEP, PIVNUL_LIST_STRUCT, SWAP_OCCURRED, XSIZE, & PP_FIRST2SWAP_L, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled,MAXFROMM,IS_MAXFROMM_AVAIL, & PIVOT_OPTION, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, LR_ACTIVATED & ) !$ USE OMP_LIB USE MUMPS_OOC_COMMON USE MUMPS_PIVNUL_MOD IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER NFRONT,NASS,LIW,N,INODE,IFLAG,IERROR,INOPV, & IOLDPS INTEGER, intent(inout) :: NNEGW, NNULLNEGW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: PIVOT_OPTION,IEND_BLR INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER PIVSIZ,LPIV, XSIZE DOUBLE PRECISION A(LA) DOUBLE PRECISION UU, UULOC, SEUIL INTEGER IW(LIW) INTEGER KEEP(500) INTEGER(8) KEEP8(150) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT LOGICAL, intent(inout) :: SWAP_OCCURRED DOUBLE PRECISION DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled DOUBLE PRECISION, intent(in) :: MAXFROMM LOGICAL, intent(inout) :: IS_MAXFROMM_AVAIL INTEGER, intent(in) :: NVSCHUR INTEGER, intent(in) :: PARPIV_T1 LOGICAL, intent(in) :: LR_ACTIVATED include 'mpif.h' INTEGER (8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX, LIM, LIM_SWAP DOUBLE PRECISION RMAX,AMAX,TMAX, MAX_PREV_in_PARPIV, ABS_PIVOT DOUBLE PRECISION RMAX_NORELAX, TMAX_NORELAX, UULOCM1 INTEGER(8) :: APOSMAX, APOSROW DOUBLE PRECISION MAXPIV DOUBLE PRECISION PIVNUL DOUBLE PRECISION MAXFROMM_UPDATED DOUBLE PRECISION FIXA, CSEUIL DOUBLE PRECISION PIVOT,DETPIV DOUBLE PRECISION ABSDETPIV INCLUDE 'mumps_headers.h' INTEGER :: HF, IPIVNUL INTEGER :: J INTEGER(8) :: APOS, J1, J2, JJ, NFRONT8, KK, J1_ini, JJ_ini INTEGER :: LDA INTEGER(8) :: LDA8 INTEGER NPIV,IPIV INTEGER NPIVP1,K INTEGER :: ISHIFT, K206, IPIV_SHIFT, IPIV_END INTRINSIC max DOUBLE PRECISION ZERO, ONE PARAMETER( ZERO = 0.0D0 ) PARAMETER( ONE = 1.0D0 ) DOUBLE PRECISION RZERO,RONE PARAMETER(RZERO=0.0D0, RONE=1.0D0) #if defined(_OPENMP) LOGICAL :: OMP_FLAG INTEGER :: NOMP, CHUNK, J1_end #endif INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L !$ NOMP = OMP_GET_MAX_THREADS() PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL LDA = NFRONT LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) K206 = KEEP(206) UULOC = UU IF (UULOC.GT.RZERO) THEN UULOCM1 = RONE/UULOC ELSE UULOCM1 = RONE ENDIF HF = 6 + XSIZE IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, IOLDPS+2*NFRONT+6+KEEP(IXSZ), & IW, LIW) ENDIF PIVSIZ = 1 NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 APOSMAX = POSELT+LDA8*LDA8-1_8 IF(INOPV .EQ. -1) THEN APOS = POSELT + (LDA8+1_8) * int(NPIV,8) POSPV1 = APOS CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), DKEEP, KEEP, .TRUE.) IF(abs(A(APOS)).LT.SEUIL) THEN IF(dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL NNEGW = NNEGW+1 ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER( A(APOS), DET_MANTW, DET_EXPW ) ENDIF ENDIF IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF IF (ISHIFT.GT.0.AND.IS_MAXFROMM_AVAIL) THEN IPIV = NPIVP1 APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF ( MAXFROMM .GT. PIVNUL ) THEN IF (PARPIV_T1.NE.0) THEN MAXFROMM_UPDATED = max & ( MAXFROMM, & abs(dble(A(APOSMAX+int(IPIV,8)))) & ) ELSE MAXFROMM_UPDATED = MAXFROMM ENDIF IF ( (abs(PIVOT) .GE. UULOC*MAXFROMM_UPDATED).AND. & abs(PIVOT) .GT. max(SEUIL,tiny(MAXFROMM_UPDATED)) & ) THEN ISHIFT = 0 ENDIF ENDIF ENDIF IF ( ISHIFT .GT. 0) THEN IS_MAXFROMM_AVAIL = .FALSE. ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN IF(ABS_PIVOT.LT.SEUIL) THEN CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .TRUE.) IF(dble(PIVOT) .GE. RZERO) THEN A(POSPV1) = CSEUIL ELSE A(POSPV1) = -CSEUIL NNEGW = NNEGW+1 ENDIF NBTINYW = NBTINYW + 1 ELSE IF (ABS_PIVOT.EQ.RZERO) THEN GO TO 630 ELSE IF (PIVOT.LT.RZERO) NNEGW = NNEGW+1 CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF ENDIF GO TO 420 ENDIF IF ( IS_MAXFROMM_AVAIL ) THEN IF ( MAXFROMM .GT. PIVNUL ) THEN IF (PARPIV_T1.NE.0) THEN MAXFROMM_UPDATED = max & ( MAXFROMM, & abs(dble(A(APOSMAX+int(IPIV,8)))) & ) ELSE MAXFROMM_UPDATED = MAXFROMM ENDIF IF ( (ABS_PIVOT .GE. UULOC*MAXFROMM_UPDATED).AND. & (ABS_PIVOT .GT. max(SEUIL,tiny(MAXFROMM_UPDATED))) & ) THEN IF (PIVOT .LT. RZERO) NNEGW = NNEGW+1 CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GOTO 415 ENDIF ENDIF IS_MAXFROMM_AVAIL = .FALSE. ENDIF AMAX = -RONE JMAX = 0 IF (PIVOT_OPTION.EQ.3 & ) THEN LIM = NFRONT - KEEP(253)-NVSCHUR ELSEIF (PIVOT_OPTION.GE.2 & ) THEN LIM = NASS ELSEIF (PIVOT_OPTION.GE.1) THEN LIM = IEND_BLR ELSE write(*,*) 'Internal error in FAC_I_LDLT 1x1:', & PIVOT_OPTION CALL MUMPS_ABORT() ENDIF J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1, IEND_BLOCK - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDA8 ENDDO RMAX = RZERO J1_ini = J1 #if defined(_OPENMP) J1_end = LIM - IEND_BLOCK CHUNK = max(J1_end,1) IF ( J1_end.GE.KEEP(360)) THEN OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2,(J1_end+NOMP-1)/NOMP) ELSE OMP_FLAG = .FALSE. ENDIF #endif !$OMP PARALLEL DO SCHEDULE(static, CHUNK) PRIVATE(J1) !$OMP& REDUCTION(max:RMAX) IF(OMP_FLAG) DO J=1, LIM - IEND_BLOCK J1 = J1_ini + int(J-1,8) * LDA8 RMAX = max(abs(A(J1)),RMAX) ENDDO !$OMP END PARALLEL DO IF (PARPIV_T1.NE.0) THEN RMAX_NORELAX = dble(A(APOSMAX+int(IPIV,8))) ELSE RMAX_NORELAX = RZERO ENDIF RMAX = max(RMAX,RMAX_NORELAX) IF (max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL) THEN IF ((PARPIV_T1.NE.0) & .AND.(PARPIV_T1.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & dble(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + NFRONT8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) THEN GOTO 460 ENDIF ENDDO ENDIF ENDIF CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(POSPV1)), DKEEP, KEEP, .TRUE.) IF ( A(POSPV1) .LT. RZERO ) NNULLNEGW=NNULLNEGW+1 !$OMP ATOMIC CAPTURE KEEP(109) = KEEP(109) + 1 IPIVNUL = KEEP(109) !$OMP END ATOMIC IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST.LT.KEEP(109)) & THEN CALL MUMPS_RESIZE_PIVNUL(KEEP, N, & PIVNUL_LIST_STRUCT, & IPIVNUL, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 420 ENDIF IF (KEEP(405).EQ.1) THEN !$OMP CRITICAL(critical_pivnul) PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) !$OMP END CRITICAL(critical_pivnul) ELSE PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) ENDIF IF(dble(FIXA).GT.RZERO) THEN IF(dble(PIVOT) .GE. RZERO) THEN A(POSPV1) = FIXA ELSE A(POSPV1) = -FIXA ENDIF ELSE J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 A(JJ) = ZERO ENDDO J1 = POSPV1 + LDA8 DO J=1, IEND_BLOCK - IPIV A(J1) = ZERO J1 = J1 + LDA8 ENDDO DO J=1,LIM - IEND_BLOCK A(J1) = ZERO J1 = J1 + LDA8 ENDDO A(POSPV1) = ONE ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF ( abs(PIVOT).GE.UULOC*max(RMAX,AMAX) & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(RMAX)) ) THEN IF (PIVOT .LT. ZERO) NNEGW = NNEGW+1 CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(PIVOT), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL DMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) THEN GOTO 460 ELSE IF (JMAX.EQ.0) THEN GOTO 460 ENDIF IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN GOTO 460 ENDIF IF ( & (KEEP(19).NE.0).AND.(max(AMAX,RMAX,abs(PIVOT)).LE.SEUIL) & ) & THEN GO TO 460 ENDIF IF (RMAX.LT.AMAX) THEN J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN RMAX = max(RMAX,abs(A(JJ))) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1,IEND_BLOCK-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX = max(abs(A(J1)),RMAX) ENDIF J1 = J1 + LDA8 ENDDO ENDIF APOSJ = POSELT + int(JMAX-1,8)*LDA8 + int(NPIV,8) POSPV2 = APOSJ + int(JMAX - NPIVP1,8) IF (IPIV.LT.JMAX) THEN OFFDAG = APOSJ + int(IPIV - NPIVP1,8) ELSE OFFDAG = APOS + int(JMAX - NPIVP1,8) END IF TMAX = RZERO #if defined(_OPENMP) J1_end = LIM-JMAX CHUNK = max(J1_end,1) IF (J1_end.GE.KEEP(360)) THEN OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2,(J1_end+NOMP-1)/NOMP) ELSE OMP_FLAG = .FALSE. ENDIF #endif IF (JMAX .LT. IPIV) THEN JJ_ini = POSPV2 !$OMP PARALLEL DO SCHEDULE(static, CHUNK) IF (OMP_FLAG) !$OMP& PRIVATE(JJ) REDUCTION(max:TMAX) DO K = 1, LIM - JMAX JJ = JJ_ini+ int(K,8)*NFRONT8 IF (JMAX+K.NE.IPIV) THEN TMAX=max(TMAX,abs(A(JJ))) ENDIF ENDDO !$OMP END PARALLEL DO DO KK = APOSJ, POSPV2-1_8 TMAX = max(TMAX,abs(A(KK))) ENDDO ELSE JJ_ini = POSPV2 !$OMP PARALLEL DO SCHEDULE(static, CHUNK) PRIVATE(JJ) !$OMP& REDUCTION(max:TMAX) IF(OMP_FLAG) DO K = 1, LIM-JMAX JJ = JJ_ini + int(K,8)*NFRONT8 TMAX=max(TMAX,abs(A(JJ))) ENDDO !$OMP END PARALLEL DO DO KK = APOSJ, POSPV2 - 1_8 IF (KK.NE.OFFDAG) THEN TMAX = max(TMAX,abs(A(KK))) ENDIF ENDDO ENDIF IF (PARPIV_T1.NE.0) THEN TMAX_NORELAX = max(SEUIL*UULOCM1, & abs(dble(A(APOSMAX+int(JMAX,8)))) & ) ELSE TMAX_NORELAX = SEUIL*UULOCM1 ENDIF TMAX = max (TMAX,TMAX_NORELAX) DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)**2 ABSDETPIV = abs(DETPIV) IF (SEUIL.GT.RZERO) THEN IF (sqrt(ABSDETPIV) .LE. SEUIL ) THEN GOTO 460 ENDIF ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & ABSDETPIV .OR. (ABSDETPIV .EQ. RZERO) ) THEN GO TO 460 ENDIF IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & ABSDETPIV .OR. (ABSDETPIV.EQ. RZERO) ) THEN GO TO 460 ENDIF CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( sqrt(ABSDETPIV), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL DMUMPS_UPDATEDETER(DETPIV, DET_MANTW, DET_EXPW ) ENDIF PIVSIZ = 2 NB22T1W = NB22T1W + 1 IF(DETPIV .LT. RZERO) THEN NNEGW = NNEGW+1 ELSE IF(A(POSPV2) .LT. RZERO) THEN NNEGW = NNEGW+2 ENDIF 415 CONTINUE IF (K206.GE.1) THEN Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) ENDIF DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2) THEN IF (K==1) THEN LPIV = min(IPIV,JMAX) ELSE LPIV = max(IPIV,JMAX) ENDIF ELSE LPIV = IPIV ENDIF IF (LPIV.EQ.NPIVP1) GOTO 416 IF (KEEP(405) .EQ. 0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF LIM_SWAP = NFRONT CALL DMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, LIM_SWAP, & LDA, NFRONT, 1, PARPIV_T1, KEEP(50), & KEEP(IXSZ), -9999) SWAP_OCCURRED = .TRUE. 416 CONTINUE IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF NPIVP1 = NPIVP1 + 1 ENDDO IF(PIVSIZ .EQ. 2) THEN A(POSELT+(LDA8+1_8)*int(NPIV,8)+1_8) = DETPIV ENDIF GOTO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE PIVSIZ = 0 IFLAG = -10 420 CONTINUE IS_MAXFROMM_AVAIL = .FALSE. RETURN END SUBROUTINE DMUMPS_FAC_I_LDLT SUBROUTINE DMUMPS_FAC_MQ_LDLT(IEND_BLOCK, & NFRONT,NASS,NPIV,INODE, & A,LA,LDA, & POSELT,IFINB,PIVSIZ, & MAXFROMM, IS_MAXFROMM_AVAIL, IS_MAX_USEFUL, & PARPIV_T1, LAST_ROW, IEND_BLR, NVSCHUR_K253, & LR_ACTIVATED & ) IMPLICIT NONE INTEGER, intent(out):: IFINB INTEGER, intent(in) :: INODE, NFRONT, NASS, NPIV INTEGER, intent(in) :: IEND_BLOCK INTEGER, intent(in) :: LDA INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER, intent(in) :: LAST_ROW INTEGER, intent(in) :: IEND_BLR INTEGER(8) :: POSELT DOUBLE PRECISION, intent(out) :: MAXFROMM LOGICAL, intent(out) :: IS_MAXFROMM_AVAIL LOGICAL, intent(in) :: IS_MAX_USEFUL INTEGER, intent(in) :: PARPIV_T1 INTEGER, INTENT(in) :: NVSCHUR_K253 LOGICAL, intent(in) :: LR_ACTIVATED DOUBLE PRECISION VALPIV DOUBLE PRECISION :: MAXFROMMTMP INTEGER NCB1 INTEGER(8) :: NFRONT8 INTEGER(8) :: LDA8 INTEGER(8) :: K1POS INTEGER NEL2 DOUBLE PRECISION ONE, ZERO DOUBLE PRECISION A11,A22,A12 INTEGER(8) :: APOS, LPOS, LPOS1, LPOS2 INTEGER(8) :: POSPV1, POSPV2 INTEGER :: PIVSIZ,NPIV_NEW,J2,I INTEGER(8) :: OFFDAG, OFFDAG_OLD, K1, K2, IROW #if defined(__ve__) INTEGER(8) :: J2_8, KU1, KU2 #else INTEGER(8) :: IBEG, IEND, JJ_LOC, JJ, ROW_SHIFT INTEGER(8) :: IBEG_LOC, IEND_LOC #endif DOUBLE PRECISION SWOP,DETPIV,MULT1,MULT2 INTEGER(8) :: APOSMAX !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' PARAMETER(ONE = 1.0D0, & ZERO = 0.0D0) LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) NPIV_NEW = NPIV + PIVSIZ IFINB = 0 IS_MAXFROMM_AVAIL = .FALSE. NCB1 = LAST_ROW - IEND_BLOCK NEL2 = IEND_BLOCK - NPIV_NEW IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ENDIF MAXFROMM = 0.0D0 IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDA8 #if defined(__ve__) IF (NEL2+NCB1.GT.0) THEN !$ OMP_FLAG = (NCB1 + NEL2> 300) !$OMP PARALLEL DO PRIVATE(I,K1POS) IF (OMP_FLAG) !NEC$ IVDEP DO I=1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) ENDDO !$OMP END PARALLEL DO !$OMP PARALLEL DO PRIVATE(I,K1POS) IF (OMP_FLAG) !NEC$ IVDEP DO I=1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS) = A(K1POS) * VALPIV ENDDO !$OMP END PARALLEL DO IF (.NOT. IS_MAX_USEFUL) THEN !$ OMP_FLAG = (NCB1 > 300).AND.(NEL2.GE.2) !$OMP PARALLEL DO PRIVATE(I,J2,J2_8,K1POS) IF (OMP_FLAG) !NEC$ IVDEP DO J2 = 1, NEL2 J2_8 = int(J2,8) !NEC$ IVDEP DO I=J2, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS+J2_8)=A(K1POS+J2_8)-(A(K1POS)*A(APOS+J2_8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE IF (NEL2.GT.0) THEN MAXFROMMTMP=0.0D0 !$ OMP_FLAG = (NCB1+NEL2 > 300) !$OMP PARALLEL DO PRIVATE(I,K1POS) IF (OMP_FLAG) !$OMP& REDUCTION(max:MAXFROMMTMP) !NEC$ IVDEP DO I=1, NEL2 + NCB1 - NVSCHUR_K253 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS+1_8)=A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) MAXFROMMTMP=max(MAXFROMMTMP, abs(A(K1POS+1_8))) ENDDO !$OMP END PARALLEL DO IS_MAXFROMM_AVAIL = .TRUE. MAXFROMM=max(MAXFROMM, MAXFROMMTMP) IF (NVSCHUR_K253.GT.0) THEN DO I= NEL2 + NCB1- NVSCHUR_K253 +1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS+1_8)=A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) ENDDO ENDIF ENDIF IF (NEL2.GT.1) THEN !$ OMP_FLAG = (NCB1+NEL2 > 300).AND.(NEL2.GE.3) !$OMP PARALLEL DO PRIVATE(I,J2,J2_8,K1POS) IF (OMP_FLAG) !NEC$ IVDEP DO J2 = 2, NEL2 J2_8 = int(J2,8) !NEC$ IVDEP DO I=J2, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS+J2_8)=A(K1POS+J2_8)-(A(K1POS)*A(APOS+J2_8)) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF ENDIF ENDIF #else 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 (NCB1.GT.0) THEN IF (.NOT. IS_MAX_USEFUL) THEN !$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) DO I=NEL2+1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE MAXFROMMTMP=0.0D0 !$ OMP_FLAG = (NCB1-NVSCHUR_K253>300) !$OMP PARALLEL DO PRIVATE(JJ,K1POS) !$OMP& REDUCTION(max:MAXFROMMTMP) IF (OMP_FLAG) DO I=NEL2+1, NEL2 + NCB1 - NVSCHUR_K253 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV IF (NEL2 > 0) THEN A(K1POS+1_8) = A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) MAXFROMMTMP=max(MAXFROMMTMP, abs(A(K1POS+1_8))) DO JJ = 2_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDIF ENDDO !$OMP END PARALLEL DO DO I = NEL2 + NCB1 - NVSCHUR_K253 + 1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO MAXFROMM=max(MAXFROMM, MAXFROMMTMP) ENDIF ENDIF #endif ELSE POSPV1 = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) POSPV2 = POSPV1 + NFRONT8 + 1_8 OFFDAG_OLD = POSPV2 - 1_8 OFFDAG = POSPV1 + 1_8 SWOP = A(POSPV2) DETPIV = A(OFFDAG) A22 = A(POSPV1)/DETPIV A11 = SWOP/DETPIV A12 = -A(OFFDAG_OLD)/DETPIV A(OFFDAG) = A(OFFDAG_OLD) A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDA8 - 1_8 LPOS2 = LPOS1 + 1_8 #if defined(__ve__) CALL dcopy(LAST_ROW-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) CALL dcopy(LAST_ROW-NPIV_NEW, A(LPOS2), LDA, A(POSPV2+1_8), 1) !$ OMP_FLAG = (NEL2+NCB1 > 300) !$OMP PARALLEL DO PRIVATE(J2,J2_8,I,K1,K2,KU1,KU2) !$OMP& IF (OMP_FLAG) !NEC$ IVDEP DO J2=1, NEL2 + NCB1 J2_8 = int(J2,8) KU1 = POSPV1 + 2_8 + (J2_8-1_8) KU2 = POSPV2 + 1_8 + (J2_8-1_8) K1 = LPOS1 + (J2_8-1_8)*NFRONT8 K2 = K1 + 1_8 A(K1) = A11*A(KU1)+A12*A(KU2) A(K2) = A12*A(KU1)+A22*A(KU2) ENDDO IF (NEL2.GT.0) THEN !$ OMP_FLAG = (NCB1+NEL2 > 300).AND.(NEL2.GE.2) !$OMP PARALLEL DO PRIVATE(I,J2,J2_8,K1,K2,MULT1,MULT2,IROW) !$OMP& IF (OMP_FLAG) !NEC$ IVDEP DO J2 = 1,NEL2 J2_8 = int(J2,8) MULT1 = -A(POSPV1 + 2_8 + J2_8-1_8) MULT2 = -A(POSPV2 + 1_8 + J2_8-1_8) !NEC$ IVDEP DO I= J2, NEL2 + NCB1 K1 = LPOS1 + (int(I,8)-1_8)*NFRONT8 K2 = K1 + 1_8 IROW = K2 + J2_8 A(IROW) = A(IROW) + MULT1*A(K1) + & MULT2*A(K2) ENDDO ENDDO ENDIF #else JJ = POSPV2 + NFRONT8-1_8 IBEG = JJ + 2_8 IEND = IBEG DO J2 = 1,NEL2 K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) A(POSPV1 + 2_8 + (int(J2,8)-1_8)) = A(K1) A(POSPV2 + 1_8 + (int(J2,8)-1_8)) = A(K2) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 DO IROW = IBEG, IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A( JJ ) = -MULT1 A( JJ + 1_8 ) = -MULT2 IBEG = IBEG + NFRONT8 IEND = IEND + NFRONT8 + 1_8 JJ = JJ+NFRONT8 ENDDO IEND = IEND-1_8 !$OMP PARALLEL DO PRIVATE(J2, K1, K2, MULT1, MULT2, IROW, JJ_LOC, !$OMP& ROW_SHIFT, IBEG_LOC, IEND_LOC) IF (LAST_ROW-IEND_BLOCK>300) DO J2 = 1,LAST_ROW-IEND_BLOCK ROW_SHIFT = (J2-1_8)*NFRONT8 JJ_LOC = JJ + ROW_SHIFT IBEG_LOC = IBEG + ROW_SHIFT IEND_LOC = IEND + ROW_SHIFT K1 = JJ_LOC K2 = JJ_LOC+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) A(POSPV1 + 2_8 + NEL2 + (J2-1_8)) = A(K1) A(POSPV2 + 1_8 + NEL2 + (J2-1_8)) = A(K2) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 DO IROW = IBEG_LOC, IEND_LOC A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A( JJ_LOC ) = -MULT1 A( JJ_LOC + 1_8 ) = -MULT2 ENDDO !$OMP END PARALLEL DO #endif ENDIF IF ((IS_MAXFROMM_AVAIL).AND.(NEL2.GT.0)) THEN IF (PARPIV_T1.NE.0) THEN APOSMAX = POSELT+LDA8*LDA8-1_8 + int(NPIV_NEW+1,8) MAXFROMM = max(MAXFROMM, & dble(A(APOSMAX)) & ) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_FAC_MQ_LDLT SUBROUTINE DMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NFRONT,NASS,INODE,A,LA, & LDA, & POSELT, & KEEP,KEEP8, & FIRST_ROW_TRSM, LAST_ROW_TRSM, & LAST_COL_GEMM, LAST_ROW_GEMM, & CALL_TRSM, CALL_GEMM, LR_ACTIVATED, & IW, LIW, OFFSET_IW & ) IMPLICIT NONE INTEGER, intent(in) :: NPIV INTEGER, intent(in) :: NFRONT, NASS, IBEG_BLOCK, IEND_BLOCK INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER, intent(in) :: INODE INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA INTEGER, intent(in) :: LAST_COL_GEMM INTEGER, intent(in) :: LAST_ROW_GEMM, LAST_ROW_TRSM, & FIRST_ROW_TRSM LOGICAL, intent(in) :: CALL_TRSM, CALL_GEMM, LR_ACTIVATED INTEGER :: OFFSET_IW, LIW INTEGER :: IW(LIW) INTEGER(8) :: LDA8 INTEGER NPIV_BLOCK, NEL1 INTEGER NRHS_TRSM INTEGER(8) :: LPOS, UPOS, APOS INTEGER IROW INTEGER Block INTEGER BLSIZE DOUBLE PRECISION ONE, ALPHA INCLUDE 'mumps_headers.h' PARAMETER (ONE=1.0D0, ALPHA=-1.0D0) LDA8 = int(LDA,8) NEL1 = LAST_COL_GEMM - IEND_BLOCK NRHS_TRSM = LAST_ROW_TRSM-FIRST_ROW_TRSM NPIV_BLOCK = NPIV - IBEG_BLOCK + 1 IF (NPIV_BLOCK.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF (CALL_TRSM) THEN APOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IBEG_BLOCK-1,8) LPOS = POSELT + LDA8*int(FIRST_ROW_TRSM,8)+int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8)+int(FIRST_ROW_TRSM,8) CALL dtrsm('L', 'U', 'T', 'U', NPIV_BLOCK, NRHS_TRSM, & ONE, A(APOS), LDA, A(LPOS), LDA) CALL DMUMPS_FAC_LDLT_COPY2U_SCALEL(NRHS_TRSM, 1, KEEP(424), & NFRONT, NPIV_BLOCK, LIW, IW, OFFSET_IW, LA, A, & POSELT, LPOS, UPOS, APOS, .NOT.LR_ACTIVATED) ENDIF IF (CALL_GEMM) THEN #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1 .OR. & ( KEEP(421) > 0 .AND. NEL1 > KEEP(421) ) ) THEN LPOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IEND_BLOCK,8) APOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IEND_BLOCK,8) CALL dgemmt( 'U','N','N', NEL1, & NPIV_BLOCK, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) ELSE #endif IF ( LAST_COL_GEMM - IEND_BLOCK > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = LAST_COL_GEMM - IEND_BLOCK END IF IF ( LAST_COL_GEMM - IEND_BLOCK .GT. 0 ) THEN DO IROW = IEND_BLOCK+1, LAST_COL_GEMM, BLSIZE Block = min( BLSIZE, LAST_COL_GEMM - IROW + 1 ) LPOS = POSELT + int( IROW - 1,8) * LDA8 + & int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK - 1,8) * LDA8 + & int( IROW - 1,8) APOS = POSELT + int( IROW - 1,8) * LDA8 + int( IROW - 1,8) CALL dgemm( 'N','N', Block, LAST_COL_GEMM - IROW + 1, & NPIV_BLOCK, ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) END DO END IF #if defined(GEMMT_AVAILABLE) END IF #endif LPOS = POSELT + int(LAST_COL_GEMM,8)*LDA8 + int(IBEG_BLOCK-1,8) UPOS = POSELT + int(IBEG_BLOCK-1,8) * LDA8 + & int(IEND_BLOCK,8) APOS = POSELT + int(LAST_COL_GEMM,8)*LDA8 + int(IEND_BLOCK,8) IF (LAST_ROW_GEMM .GT. LAST_COL_GEMM) THEN CALL dgemm('N', 'N', NEL1, LAST_ROW_GEMM-LAST_COL_GEMM, & NPIV_BLOCK, ALPHA, A(UPOS), LDA, A(LPOS), LDA, & ONE, A(APOS), LDA) ENDIF ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_SQ_LDLT SUBROUTINE DMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, IPIV, POSELT, LASTROW2SWAP, & LDA, NFRONT, LEVEL, PARPIV, K50, XSIZE, & IBEG_BLOCK_TO_SEND ) IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER LIW, IOLDPS, NPIVP1, IPIV INTEGER LDA, NFRONT, LEVEL, PARPIV, K50, XSIZE INTEGER LASTROW2SWAP DOUBLE PRECISION A( LA ) INTEGER IW( LIW ) INTEGER, INTENT(IN) :: IBEG_BLOCK_TO_SEND INCLUDE 'mumps_headers.h' INTEGER :: IBEG INTEGER ISW, ISWPS1, ISWPS2, HF INTEGER(8) :: IDIAG, APOS INTEGER(8) :: LDA8 DOUBLE PRECISION SWOP LDA8 = int(LDA,8) APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIVP1-1,8) IDIAG = APOS + int(IPIV - NPIVP1,8) HF = 6 + IW( IOLDPS + 5 + XSIZE) + XSIZE ISWPS1 = IOLDPS + HF + NPIVP1 - 1 ISWPS2 = IOLDPS + HF + IPIV - 1 ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW ISW = IW(ISWPS1+NFRONT) IW(ISWPS1+NFRONT) = IW(ISWPS2+NFRONT) IW(ISWPS2+NFRONT) = ISW IF ( LEVEL .eq. 2 ) THEN IBEG = IBEG_BLOCK_TO_SEND CALL dswap( NPIVP1 - 1 - IBEG + 1, & A( POSELT + int(NPIVP1-1,8) + & int(IBEG-1,8) * LDA8), LDA, & A( POSELT + int(IPIV-1,8) + & int(IBEG-1,8) * LDA8), LDA ) END IF CALL dswap( NPIVP1-1, & A( POSELT+int(NPIVP1-1,8) * LDA8 ), 1, & A( POSELT + int(IPIV-1,8) * LDA8 ), 1 ) CALL dswap( IPIV - NPIVP1 - 1, & A( POSELT+int(NPIVP1,8) * LDA8 + int(NPIVP1-1,8) ), & LDA, A( APOS + 1_8 ), 1 ) SWOP = A(IDIAG) A(IDIAG) = A( POSELT+int(NPIVP1-1,8)*LDA8+int(NPIVP1-1,8) ) A( POSELT + int(NPIVP1-1,8)*LDA8 + int(NPIVP1-1,8) ) = SWOP IF (LASTROW2SWAP - IPIV.GT.0) THEN CALL dswap( LASTROW2SWAP - IPIV, & A( APOS + LDA8 ), LDA, & A( IDIAG + LDA8 ), LDA ) ENDIF IF (PARPIV.NE.0 .AND.K50.EQ.2) THEN IF ( LEVEL .eq. 2 .OR. LEVEL.eq.1) THEN APOS = POSELT+LDA8*LDA8-1_8 SWOP = A(APOS+int(NPIVP1,8)) A(APOS+int(NPIVP1,8))= A(APOS+int(IPIV,8)) A(APOS+int(IPIV,8)) = SWOP ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SWAP_LDLT SUBROUTINE DMUMPS_FAC_LDLT_COPY2U_SCALEL( IROWMAX, IROWMIN, & SIZECOPY, LDA, NCOLS, LIW, IW, OFFSET_IW, & LA, A, POSELT, A_LPOS, A_UPOS, A_DPOS, & COPY_NEEDED ) !$ USE OMP_LIB INTEGER, INTENT(IN) :: IROWMAX, IROWMIN INTEGER, INTENT(IN) :: SIZECOPY INTEGER, INTENT(IN) :: LDA, NCOLS INTEGER, INTENT(IN) :: LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: OFFSET_IW INTEGER(8), INTENT(IN) :: LA DOUBLE PRECISION, INTENT(INOUT) :: A(LA) INTEGER(8), INTENT(IN) :: POSELT, A_LPOS, A_UPOS, A_DPOS LOGICAL, INTENT(IN) :: COPY_NEEDED INTEGER(8) :: LPOS, UPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER :: IROWEND, IROW, Block2 INTEGER :: I, J DOUBLE PRECISION :: MULT1, MULT2, A11, DETPIV, A22, A12 INTEGER :: BLSIZECOPY DOUBLE PRECISION :: ONE PARAMETER (ONE = 1.0D0) INTEGER(8) :: LPOSI, UPOSI LOGICAL :: PIVOT_2X2 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP, CHUNK LDA8 = int(LDA,8) IF (SIZECOPY.NE.0) THEN BLSIZECOPY = SIZECOPY ELSE BLSIZECOPY = 250 ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = (64/4) !$ IF (NOMP .GT. 1 .AND. NCOLS .GE. 4*CHUNK) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max(2*CHUNK, NCOLS/NOMP) !$ ENDIF DO IROWEND = IROWMAX, IROWMIN, -BLSIZECOPY Block2 = min(BLSIZECOPY, IROWEND) IROW = IROWEND - Block2 + 1 LPOS = A_LPOS + int(IROW-1,8)*LDA8 UPOS = A_UPOS + int(IROW-1,8) !$OMP PARALLEL DO PRIVATE(PIVOT_2X2, A11, DPOS, !$OMP& POSPV1, POSPV2, OFFDAG, A22, A12, DETPIV, J, MULT1, MULT2 !$OMP& , LPOSI, UPOSI !$OMP& ) FIRSTPRIVATE(Block2, LDA, LDA8, LPOS, UPOS, A_DPOS) !$OMP& SCHEDULE(STATIC,CHUNK) IF(OMP_FLAG) DO I=1, NCOLS PIVOT_2X2 = .FALSE. IF(IW(OFFSET_IW+I-1) .LE. 0) THEN PIVOT_2X2 = .TRUE. ELSE IF (I .GT. 1) THEN IF (IW(OFFSET_IW+I-2) .LE. 0) THEN cycle ENDIF ENDIF ENDIF DPOS = A_DPOS + LDA8*int(I-1,8) + int(I-1,8) IF(.not. PIVOT_2X2) THEN A11 = ONE/A(DPOS) LPOSI = LPOS+int(I-1,8) IF (COPY_NEEDED) THEN UPOSI = UPOS+int(I-1,8)*LDA8 #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, Block2 A(UPOSI+int(J-1,8)) = A(LPOSI+int(J-1,8)*LDA8) END DO ENDIF #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, Block2 A(LPOSI+int(J-1,8)*LDA8) = A(LPOSI+int(J-1,8)*LDA8)*A11 END DO ELSE IF (COPY_NEEDED) THEN CALL dcopy(Block2, A(LPOS+int(I-1,8)), & LDA, A(UPOS+int(I-1,8)*LDA8), 1) CALL dcopy(Block2, A(LPOS+int(I,8)), & LDA, A(UPOS+int(I,8)*LDA8), 1) ENDIF POSPV1 = DPOS POSPV2 = DPOS + int(LDA+1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1,Block2 MULT1 = A11*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A12*A(LPOS+int(J-1,8)*LDA8+int(I,8)) MULT2 = A12*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A22*A(LPOS+int(J-1,8)*LDA8+int(I,8)) A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) = MULT1 A(LPOS+int(J-1,8)*LDA8+int(I,8)) = MULT2 ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDDO END SUBROUTINE DMUMPS_FAC_LDLT_COPY2U_SCALEL SUBROUTINE DMUMPS_FAC_LDLT_COPYSCALE_U( IROWMAX, IROWMIN, & SIZECOPY, LDA, NCOLS, LIW, IW, OFFSET_IW, & LA, A, POSELT, A_LPOS, A_UPOS, A_DPOS ) !$ USE OMP_LIB INTEGER, INTENT(IN) :: IROWMAX, IROWMIN INTEGER, INTENT(IN) :: SIZECOPY INTEGER, INTENT(IN) :: LDA, NCOLS INTEGER, INTENT(IN) :: LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: OFFSET_IW INTEGER(8), INTENT(IN) :: LA DOUBLE PRECISION, INTENT(INOUT) :: A(LA) INTEGER(8), INTENT(IN) :: POSELT, A_LPOS, A_UPOS, A_DPOS INTEGER(8) :: LPOS, UPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER :: IROWEND, IROW, Block2 INTEGER :: I, J DOUBLE PRECISION :: MULT1, MULT2, A11, A22, A12 INTEGER :: BLSIZECOPY DOUBLE PRECISION :: ONE PARAMETER (ONE = 1.0D0) INTEGER(8) :: LPOSI, UPOSI LOGICAL :: PIVOT_2X2 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP, CHUNK LDA8 = int(LDA,8) IF (SIZECOPY.NE.0) THEN BLSIZECOPY = SIZECOPY ELSE BLSIZECOPY = 250 ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = (64/4) !$ IF (NOMP .GT. 1 .AND. NCOLS .GE. 4*CHUNK) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max(2*CHUNK, NCOLS/NOMP) !$ ENDIF DO IROWEND = IROWMAX, IROWMIN, -BLSIZECOPY Block2 = min(BLSIZECOPY, IROWEND) IROW = IROWEND - Block2 + 1 LPOS = A_LPOS + int(IROW-1,8)*LDA8 UPOS = A_UPOS + int(IROW-1,8) !$OMP PARALLEL DO PRIVATE(PIVOT_2X2, A11, DPOS, !$OMP& POSPV1, POSPV2, OFFDAG, A22, A12, J, MULT1, MULT2 !$OMP& , LPOSI, UPOSI !$OMP& ) FIRSTPRIVATE(Block2, LDA, LDA8, LPOS, UPOS, POSELT) !$OMP& SCHEDULE(STATIC,CHUNK) IF(OMP_FLAG) DO I=1, NCOLS PIVOT_2X2 = .FALSE. IF(IW(OFFSET_IW+I-1) .LE. 0) THEN PIVOT_2X2 = .TRUE. ELSE IF (I .GT. 1) THEN IF (IW(OFFSET_IW+I-2) .LE. 0) THEN cycle ENDIF ENDIF ENDIF DPOS = A_DPOS + LDA8*int(I-1,8) + int(I-1,8) IF(.not. PIVOT_2X2) THEN A11 = A(DPOS) LPOSI = LPOS+int(I-1,8) UPOSI = UPOS+int(I-1,8)*LDA8 #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, Block2 A(UPOSI+int(J-1,8)) = A(LPOSI+int(J-1,8)*LDA8)*A11 END DO ELSE POSPV1 = DPOS POSPV2 = DPOS + int(LDA+1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1,Block2 MULT1 = A11*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A12*A(LPOS+int(J-1,8)*LDA8+int(I,8)) MULT2 = A12*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A22*A(LPOS+int(J-1,8)*LDA8+int(I,8)) A(UPOS+int(I-1,8)*LDA8+int(J-1,8)) = MULT1 A(UPOS+int(I,8)*LDA8+int(J-1,8)) = MULT2 ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDDO RETURN END SUBROUTINE DMUMPS_FAC_LDLT_COPYSCALE_U SUBROUTINE DMUMPS_FAC_T_LDLT(NFRONT,NASS, & IW,LIW,A,LA, & LDA, & IOLDPS,POSELT,KEEP,KEEP8, & POSTPONE_COL_UPDATE, ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG, OFFSET_IW, INODE ) USE DMUMPS_OOC IMPLICIT NONE INTEGER NFRONT, NASS,LIW INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER IW(LIW) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: POSELT INTEGER LDA INTEGER IOLDPS, ETATASS LOGICAL POSTPONE_COL_UPDATE INTEGER(8) :: LAFAC INTEGER TYPEFile, NextPiv2beWritten INTEGER LIWFAC, MYID, IFLAG TYPE(IO_BLOCK):: MonBloc INTEGER IDUMMY LOGICAL LAST_CALL INTEGER :: OFFSET_IW INTEGER, intent(in):: INODE INCLUDE 'mumps_headers.h' INTEGER(8) :: UPOS, APOS, LPOS INTEGER(8) :: LDA8 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, IROWEND INTEGER I2, I2END, Block2, IFLAG_OOC DOUBLE PRECISION ONE, ALPHA, BETA, ZERO PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) PARAMETER (ZERO=0.0D0) LDA8 = int(LDA,8) IF (ETATASS.EQ.1) THEN BETA = ZERO ELSE BETA = ONE ENDIF IF ( NFRONT - NASS > KEEP(58) ) THEN IF ( NFRONT - NASS > KEEP(57) ) THEN BLSIZE = KEEP(58) ELSE BLSIZE = (NFRONT - NASS)/2 END IF ELSE BLSIZE = NFRONT - NASS END IF BLSIZE2 = KEEP(218) NPIV = IW( IOLDPS + 1 + KEEP(IXSZ)) IF ( NFRONT - NASS .GT. 0 ) THEN IF ( POSTPONE_COL_UPDATE ) THEN LPOS = POSELT + LDA8 * int(NASS,8) CALL dtrsm( 'L', 'U', 'T', 'U', & NPIV, NFRONT-NASS, ONE, & A( POSELT ), LDA, & A( LPOS ), LDA ) ENDIF #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1 .OR. & ( KEEP(421) > 0 .AND. NFRONT-NASS > KEEP(421) ) ) THEN LPOS = POSELT + int(NASS,8)*LDA8 UPOS = POSELT + int(NASS,8) APOS = POSELT + int(NASS,8)*LDA8 + int(NASS,8) IF (POSTPONE_COL_UPDATE) THEN CALL DMUMPS_FAC_LDLT_COPY2U_SCALEL( NFRONT - NASS, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, & POSELT, .TRUE. ) ENDIF CALL dgemmt('U', 'N', 'N', NFRONT-NASS, NPIV, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, & BETA, & A( APOS ), LDA ) ELSE #endif DO IROWEND = NFRONT - NASS, 1, -BLSIZE Block = min( BLSIZE, IROWEND ) IROW = IROWEND - Block + 1 LPOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 APOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 + & int(NASS + IROW - 1,8) UPOS = POSELT + int(NASS,8) IF (.NOT. POSTPONE_COL_UPDATE) THEN UPOS = POSELT + int(NASS + IROW - 1,8) ENDIF IF (POSTPONE_COL_UPDATE) THEN CALL DMUMPS_FAC_LDLT_COPY2U_SCALEL( Block, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, & POSELT, .TRUE. ) ENDIF DO I2END = Block, 1, -BLSIZE2 Block2 = min(BLSIZE2, I2END) I2 = I2END - Block2+1 CALL dgemm('N', 'N', Block2, Block-I2+1, NPIV, ALPHA, & A(UPOS+int(I2-1,8)), LDA, & A(LPOS+int(I2-1,8)*LDA8), LDA, & BETA, & A(APOS + int(I2-1,8) + int(I2-1,8)*LDA8), LDA) IF (KEEP(201).EQ.1) THEN IF (NextPiv2beWritten.LE.NPIV) THEN LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, MYID, & KEEP8(31), & IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC RETURN ENDIF ENDIF ENDIF ENDDO IF ( NFRONT - NASS - IROW + 1 - Block > 0 ) THEN CALL dgemm( 'N', 'N', Block, NFRONT-NASS-Block-IROW+1, NPIV, & ALPHA, A( UPOS ), LDA, & A( LPOS + LDA8 * int(Block,8) ), LDA, & BETA, & A( APOS + LDA8 * int(Block,8) ), LDA ) ENDIF END DO #if defined(GEMMT_AVAILABLE) END IF #endif IF ( (POSTPONE_COL_UPDATE).AND.(NASS-NPIV.GT.0) ) THEN LPOS = POSELT + int(NPIV,8)*LDA8 UPOS = POSELT + int(NPIV,8) CALL DMUMPS_FAC_LDLT_COPYSCALE_U( NASS-NPIV, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, POSELT) LPOS = POSELT + LDA8 * int(NASS,8) CALL dgemm('N', 'N', NASS-NPIV, NFRONT-NASS, NPIV, ALPHA, & A( POSELT + int(NPIV,8)), LDA, & A( LPOS ), LDA, & BETA, & A( LPOS + int(NPIV,8) ), LDA) ENDIF END IF RETURN END SUBROUTINE DMUMPS_FAC_T_LDLT SUBROUTINE DMUMPS_STORE_PERMINFO( PIVRPTR, NBPANELS, PIVR, NASS, & K, P, LastPanelonDisk, & LastPIVRPTRIndexFilled ) IMPLICIT NONE INTEGER, intent(in) :: NBPANELS, NASS, K, P INTEGER, intent(inout) :: PIVRPTR(NBPANELS), PIVR(NASS) INTEGER LastPanelonDisk, LastPIVRPTRIndexFilled INTEGER I IF ( LastPanelonDisk+1 > NBPANELS ) THEN WRITE(*,*) "INTERNAL ERROR IN DMUMPS_STORE_PERMINFO!" WRITE(*,*) "NASS=",NASS,"PIVRPTR=",PIVRPTR(1:NBPANELS) WRITE(*,*) "K=",K, "P=",P, "LastPanelonDisk=",LastPanelonDisk WRITE(*,*) "LastPIVRPTRIndexFilled=", LastPIVRPTRIndexFilled CALL MUMPS_ABORT() ENDIF PIVRPTR(LastPanelonDisk+1) = K + 1 IF (LastPanelonDisk.NE.0) THEN PIVR(K - PIVRPTR(1) + 1) = P DO I = LastPIVRPTRIndexFilled + 1, LastPanelonDisk PIVRPTR(I)=PIVRPTR(LastPIVRPTRIndexFilled) ENDDO ENDIF LastPIVRPTRIndexFilled = LastPanelonDisk + 1 RETURN END SUBROUTINE DMUMPS_STORE_PERMINFO SUBROUTINE DMUMPS_UPDATE_MINMAX_PIVOT & ( DIAG, DKEEP, KEEP, NULLPIVOT) !$ USE OMP_LIB IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: DIAG DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) LOGICAL, INTENT(IN) :: NULLPIVOT INTEGER, INTENT(IN) :: KEEP(500) IF (KEEP(405).EQ.0) THEN DKEEP(21) = max(DKEEP(21), DIAG) DKEEP(19) = min(DKEEP(19), DIAG) IF (.NOT.NULLPIVOT) THEN DKEEP(20) = min(DKEEP(20), DIAG) ENDIF ELSE !$OMP ATOMIC UPDATE DKEEP(21) = max(DKEEP(21), DIAG) !$OMP END ATOMIC !$OMP ATOMIC UPDATE DKEEP(19) = min(DKEEP(19), DIAG) !$OMP END ATOMIC IF (.NOT.NULLPIVOT) THEN !$OMP ATOMIC UPDATE DKEEP(20) = min(DKEEP(20), DIAG) !$OMP END ATOMIC ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_UPDATE_MINMAX_PIVOT SUBROUTINE DMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, NCB, SIZE_SCHUR, ROW_INDICES, PERM, & NVSCHUR & ) IMPLICIT NONE INTEGER, intent(in) :: N, NCB, SIZE_SCHUR INTEGER, intent(in) :: ROW_INDICES(NCB), PERM(N) INTEGER, intent(out):: NVSCHUR INTEGER :: I, IPOS, IBEG_SCHUR IBEG_SCHUR = N - SIZE_SCHUR +1 NVSCHUR = 0 IPOS = NCB DO I= NCB,1,-1 IF (abs(ROW_INDICES(I)).LE.N) THEN IF (PERM(ROW_INDICES(I)).LT.IBEG_SCHUR) EXIT ENDIF IPOS = IPOS -1 ENDDO NVSCHUR = NCB-IPOS RETURN END SUBROUTINE DMUMPS_GET_SIZE_SCHUR_IN_FRONT END MODULE DMUMPS_FAC_FRONT_AUX_M MUMPS_5.8.1/src/sstatic_ptr_m.F0000664000175000017500000000204315042446437016217 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_STATIC_PTR_M PUBLIC :: SMUMPS_TMP_PTR, SMUMPS_GET_TMP_PTR REAL, DIMENSION(:), POINTER, SAVE :: SMUMPS_TMP_PTR CONTAINS SUBROUTINE SMUMPS_SET_STATIC_PTR(ARRAY) REAL, DIMENSION(:), TARGET :: ARRAY SMUMPS_TMP_PTR => ARRAY RETURN END SUBROUTINE SMUMPS_SET_STATIC_PTR SUBROUTINE SMUMPS_GET_TMP_PTR(PTR) #if defined(MUMPS_NOF2003) REAL, DIMENSION(:), POINTER :: PTR #else REAL, DIMENSION(:), POINTER, INTENT(OUT) :: PTR #endif PTR => SMUMPS_TMP_PTR RETURN END SUBROUTINE SMUMPS_GET_TMP_PTR END MODULE SMUMPS_STATIC_PTR_M MUMPS_5.8.1/src/ssol_omp_m.F0000664000175000017500000004740115042446437015522 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_SOL_L0OMP_M CONTAINS SUBROUTINE SMUMPS_SOL_L0OMP_R(N, MTYPE, & NRHS, LIW, IW, PTRICB, RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & STEP, FRERE, DAD, FILS, NSTK, PTRIST, PTRFAC, INFO, & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF, & COMM, MYID, & BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, & FROM_PP, & NBROOT_UNDER_L0, LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS, & DO_PRUN, TO_PROCESS ) USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_L0OMPFAC_T !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT( in ) :: N, MTYPE, NRHS, SLAVEF, LIW INTEGER, INTENT( in ) :: IW(LIW) INTEGER :: INFO( 80 ), KEEP(500) INTEGER(8) :: KEEP8(150) REAL :: DKEEP(230) INTEGER, INTENT( in ) :: PROCNODE_STEPS( KEEP(28) ) INTEGER :: PTRICB( KEEP(28) ) INTEGER, INTENT( in ) :: POSINRHSINTR_FWD(N), LRHSINTR REAL, INTENT(inout):: RHSINTR(LRHSINTR,NRHS) INTEGER, INTENT( in ) :: STEP(N), FRERE( KEEP(28) ), FILS( N ), & DAD( KEEP(28) ) INTEGER, INTENT( inout ) :: NSTK(KEEP(28)) INTEGER, INTENT( in ) :: PTRIST(KEEP(28)) INTEGER(8), INTENT( in ) :: PTRFAC(KEEP(28)) INTEGER, INTENT( IN ) :: COMM, MYID INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES INTEGER :: BUFR(LBUFR) INTEGER(8), INTENT(IN) :: LRHS_ROOT REAL :: RHS_ROOT(LRHS_ROOT) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) LOGICAL, INTENT( in ) :: DO_NBSPARSE INTEGER, INTENT( in ) :: LRHS_BOUNDS INTEGER, INTENT( in ) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, INTENT( in ) :: FROM_PP INTEGER, INTENT( out ):: NBROOT_UNDER_L0 INTEGER, INTENT( in ) :: LPOOL_B_L0_OMP INTEGER, INTENT( in ) :: IPOOL_B_L0_OMP & ( LPOOL_B_L0_OMP ) INTEGER, INTENT( in ) :: L_PHYS_L0_OMP INTEGER, INTENT( in ) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT( in ) :: L_VIRT_L0_OMP INTEGER, INTENT( in ) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT( in ) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT( in ) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT( in ) :: LL0_OMP_MAPPING INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INTEGER, INTENT( in ) :: LL0_OMP_FACTORS LOGICAL, INTENT( in ) :: DO_PRUN LOGICAL, INTENT( in ) :: TO_PROCESS( KEEP(28) ) TYPE (SMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER :: LASTFSSBTRSTA_P, LASTFSSBTRDYN_P INTEGER :: THREAD_ID, IL0OMPFAC INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOOL_P INTEGER, ALLOCATABLE, DIMENSION(:) :: IWCB_P REAL, ALLOCATABLE, DIMENSION(:) :: WCB_P INTEGER :: LPOOL_P, LEAF_P, LIWCB_P INTEGER(8) :: LWCB_P INTEGER(8) :: POSWCB_P, PLEFTWCB_P INTEGER :: POSIWCB_P LOGICAL :: IS_INODE_PROCESSED_P LOGICAL :: ERROR_WAS_BROADCASTED_P INTEGER :: INFO_P(2), allocok INTEGER :: I, VIRTUAL_TASK, PHYSICAL_TASK INTEGER :: INODE, IFATH, IROOT_SBTR INTEGER :: NBROOT_PROCESSED INTEGER :: NEXT_TASK_DYN !$ INTEGER :: NOMP_SAVE INTEGER :: NBFIN_DUMMY !$ INTEGER :: NOMP_TOTAL !$ INTEGER :: NOMP_INNER !$ LOGICAL :: SAVE_NESTED NBFIN_DUMMY = huge(NBFIN_DUMMY) NBROOT_PROCESSED = 0 PTRICB = 0 !$ NOMP_INNER = 1 !$ IF (KEEP(369).GT.0) THEN !$ NOMP_TOTAL = omp_get_max_threads() !$ IF (NOMP_TOTAL .NE. KEEP(400)) THEN !$ IF (KEEP(439) .GT. 1) THEN !$ NOMP_INNER = KEEP(439) !$ ELSE IF ( KEEP(439) .EQ. -1 !$ & ) THEN !$ NOMP_INNER = NOMP_TOTAL / KEEP(400) !$ ENDIF !$ ENDIF !$ IF (NOMP_INNER .GT. 1) THEN !$ SAVE_NESTED = omp_get_nested() !$ CALL OMP_SET_NESTED(.TRUE.) !$ ENDIF #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(KEEP(400),4)) #else !$ CALL omp_set_num_threads(KEEP(400)) #endif !$ ENDIF NEXT_TASK_DYN = KEEP(400)+1 !$OMP PARALLEL !$OMP& SHARED ( NEXT_TASK_DYN, IPOOL_B_L0_OMP, !$OMP& LPOOL_B_L0_OMP, NBFIN_DUMMY ) !$OMP& PRIVATE ( THREAD_ID, IL0OMPFAC, VIRTUAL_TASK, PHYSICAL_TASK, !$OMP& IPOOL_P, LPOOL_P, LEAF_P, !$OMP& LIWCB_P, LWCB_P, IWCB_P, WCB_P, !$OMP& PLEFTWCB_P, POSWCB_P, POSIWCB_P, !$OMP& LASTFSSBTRSTA_P, LASTFSSBTRDYN_P, !$OMP& INODE, IROOT_SBTR, IFATH, !$OMP& IS_INODE_PROCESSED_P, !$OMP& INFO_P, ERROR_WAS_BROADCASTED_P, NOMP_SAVE, allocok ) !$OMP& REDUCTION( + : NBROOT_PROCESSED ) !$ NOMP_SAVE = omp_get_max_threads() THREAD_ID = 1 !$ THREAD_ID = OMP_GET_THREAD_NUM() + 1 !$OMP BARRIER !$ CALL omp_set_num_threads(NOMP_INNER) LPOOL_P = LPOOL_B_L0_OMP INFO_P(1:2) = 0 LWCB_P = int(KEEP(133),8)*int(NRHS,8) LIWCB_P = KEEP(133) PLEFTWCB_P = 1_8 POSWCB_P = LWCB_P POSIWCB_P = LIWCB_P ALLOCATE(IPOOL_P(LPOOL_P), IWCB_P(LIWCB_P), WCB_P( LWCB_P), & stat=allocok) IF ( allocok > 0 ) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4(LPOOL_P + LIWCB_P + LWCB_P, & INFO(2)) !$OMP CRITICAL(critical_info) INFO(1) = -13 INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ENDIF !$OMP BARRIER IF (INFO(1) .LT. 0) THEN GOTO 50 ENDIF VIRTUAL_TASK = THREAD_ID 600 CONTINUE IF (VIRTUAL_TASK .LT. L_VIRT_L0_OMP) THEN DO PHYSICAL_TASK = VIRT_L0_OMP( VIRTUAL_TASK ), & VIRT_L0_OMP ( VIRTUAL_TASK + 1 ) - 1 LEAF_P = 1 DO I = PTR_LEAFS_L0_OMP( PERM_L0_OMP( PHYSICAL_TASK )+1 )+1, & PTR_LEAFS_L0_OMP( PERM_L0_OMP( PHYSICAL_TASK ) ) IF ( IPOOL_B_L0_OMP(I) .GT. 0 ) THEN IPOOL_P(LEAF_P) = IPOOL_B_L0_OMP(I) LEAF_P = LEAF_P + 1 ENDIF ENDDO IF ( LEAF_P .EQ. 1 ) THEN WRITE(*,*) " Internal error 1 in SMUMPS_SOL_L0OMP_R", & LEAF_P ENDIF IROOT_SBTR = PHYS_L0_OMP( PERM_L0_OMP( PHYSICAL_TASK )) IF (DO_PRUN) THEN IF (.NOT. TO_PROCESS(STEP(IROOT_SBTR))) THEN CYCLE ENDIF ENDIF INODE = IROOT_SBTR DO WHILE (INODE .GT. 0) LASTFSSBTRSTA_P = INODE INODE=FILS(INODE) ENDDO CALL MUMPS_COMPUTE_LASTFS_DYN( IROOT_SBTR, LASTFSSBTRDYN_P, & MTYPE, KEEP, IW, LIW, N, STEP, PTRIST, FILS, FRERE ) DO WHILE (LEAF_P .NE.1 .AND. INFO_P(1) .GE. 0) LEAF_P = LEAF_P - 1 INODE = IPOOL_P(LEAF_P) IFATH = DAD(STEP(INODE) ) IL0OMPFAC = L0_OMP_MAPPING(STEP(INODE)) IF (IL0OMPFAC .NE. THREAD_ID) THEN ENDIF IF (DO_PRUN) THEN IS_INODE_PROCESSED_P = TO_PROCESS(STEP(INODE)) ELSE IS_INODE_PROCESSED_P = .TRUE. ENDIF IF ( IS_INODE_PROCESSED_P ) THEN CALL SMUMPS_SOLVE_NODE_FWD( INODE, & LASTFSSBTRSTA_P, LASTFSSBTRDYN_P, & BUFR, LBUFR, LBUFR_BYTES, MYID, SLAVEF, COMM, & N, IPOOL_P, LPOOL_P, LEAF_P, NBFIN_DUMMY, NSTK, & IWCB_P, LIWCB_P, WCB_P, LWCB_P, & L0_OMP_FACTORS(IL0OMPFAC)%A(1), & L0_OMP_FACTORS(IL0OMPFAC)%LA, & IW, LIW, & NRHS, POSWCB_P, PLEFTWCB_P, POSIWCB_P, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, INFO_P, KEEP, KEEP8, DKEEP, & RHS_ROOT, LRHS_ROOT, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED_P ) IF (INFO_P(1) .LT. 0) THEN !$OMP CRITICAL(critical_info) INFO(1) = INFO_P(1) INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 50 IF (ERROR_WAS_BROADCASTED_P) THEN WRITE(*,*) " Internal error 2 in SMUMPS_SOL_L0OMP_R", & ERROR_WAS_BROADCASTED_P ENDIF ENDIF IF ( IFATH .EQ. 0 ) THEN IF ( IS_INODE_PROCESSED_P ) THEN NBROOT_PROCESSED = NBROOT_PROCESSED + 1 ENDIF ELSE PTRICB(STEP(INODE)) = 0 IF (IFATH .NE. 0) THEN IF ( INODE .NE. IROOT_SBTR ) THEN IF ( IS_INODE_PROCESSED_P ) THEN NSTK(STEP(IFATH)) = NSTK(STEP(IFATH)) - 1 ENDIF IF (NSTK(STEP(IFATH)) .EQ. 0 .OR. & NSTK(STEP(IFATH)) .EQ. -1 ) THEN IPOOL_P( LEAF_P ) = IFATH LEAF_P = LEAF_P + 1 IF (DO_PRUN) THEN NSTK(STEP(IFATH)) = huge(NSTK(STEP(IFATH))) ENDIF ENDIF ELSE IF ( IS_INODE_PROCESSED_P ) THEN !$OMP ATOMIC UPDATE NSTK(STEP(IFATH)) = NSTK(STEP(IFATH)) - 1 !$OMP END ATOMIC ENDIF ENDIF ENDIF ENDIF ENDDO ENDDO !$OMP ATOMIC CAPTURE VIRTUAL_TASK = NEXT_TASK_DYN NEXT_TASK_DYN = NEXT_TASK_DYN + 1 !$OMP END ATOMIC GOTO 600 ENDIF 50 CONTINUE IF (allocated(IPOOL_P)) DEALLOCATE(IPOOL_P) IF (allocated(IWCB_P)) DEALLOCATE(IWCB_P) IF (allocated(WCB_P)) DEALLOCATE(WCB_P) #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_SAVE,4)) #else !$ CALL omp_set_num_threads(NOMP_SAVE) #endif !$OMP END PARALLEL !$ IF (KEEP(369).GT.0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_TOTAL),4)) #else !$ CALL omp_set_num_threads(NOMP_TOTAL) #endif !$ IF (NOMP_INNER .GT. 1) THEN !$ CALL OMP_SET_NESTED(SAVE_NESTED) !$ ENDIF !$ ENDIF NBROOT_UNDER_L0 = NBROOT_PROCESSED RETURN END SUBROUTINE SMUMPS_SOL_L0OMP_R SUBROUTINE SMUMPS_SOL_L0OMP_S(N, MTYPE, NRHS, LIW, IW, & PTRICB, PTRACB, RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & STEP, FRERE, FILS, NE_STEPS, PTRIST, PTRFAC, INFO, & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, RHS_ROOT, LRHS_ROOT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP, LPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS ) USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_L0OMPFAC_T USE OMP_LIB IMPLICIT NONE INTEGER, INTENT( in ) :: N, MTYPE, NRHS, SLAVEF, LIW INTEGER, INTENT( in ) :: IW(LIW) INTEGER :: INFO( 80 ), KEEP(500) INTEGER(8) :: KEEP8(150) REAL :: DKEEP(230) INTEGER, INTENT( in ) :: PROCNODE_STEPS( KEEP(28) ) INTEGER :: PTRICB( KEEP(28) ) INTEGER(8) :: PTRACB( KEEP(28) ) INTEGER, INTENT( in ) :: POSINRHSINTR_BWD(N), LRHSINTR REAL, INTENT(inout):: RHSINTR(LRHSINTR,NRHS) INTEGER, INTENT( in ) :: STEP(N), FRERE( KEEP(28) ), FILS( N ) INTEGER, INTENT( inout ) :: NE_STEPS(KEEP(28)) INTEGER, INTENT( in ) :: PTRIST(KEEP(28)) INTEGER(8), INTENT( in ) :: PTRFAC(KEEP(28)) INTEGER, INTENT( IN ) :: COMM, MYID INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES INTEGER :: BUFR(LBUFR) INTEGER(8), INTENT(IN) :: LRHS_ROOT REAL :: RHS_ROOT(LRHS_ROOT) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER :: LPANEL_POS INTEGER :: PANEL_POS(LPANEL_POS) LOGICAL, INTENT( in ) :: DO_NBSPARSE INTEGER, INTENT( in ) :: LRHS_BOUNDS INTEGER, INTENT( in ) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, INTENT( in ) :: PRUN_BELOW_BWD INTEGER, INTENT( in ) :: SIZE_TO_PROCESS LOGICAL, INTENT( in ) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, INTENT( in ) :: FROM_PP INTEGER, INTENT( in ) :: LPOOL_B_L0_OMP INTEGER, INTENT( in ) :: L_PHYS_L0_OMP INTEGER, INTENT( in ) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT( in ) :: L_VIRT_L0_OMP INTEGER, INTENT( in ) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT( in ) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT( in ) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT( in ) :: LL0_OMP_MAPPING INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INTEGER, INTENT( in ) :: LL0_OMP_FACTORS TYPE (SMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER :: THREAD_ID, IL0OMPFAC INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOOL_P INTEGER, ALLOCATABLE, DIMENSION(:) :: IWCB_P REAL, ALLOCATABLE, DIMENSION(:) :: WCB_P REAL, ALLOCATABLE, DIMENSION(:) :: W2_P INTEGER, ALLOCATABLE, DIMENSION(:) :: PANEL_POS_P INTEGER :: LPOOL_P, IIPOOL_P, LIWCB_P, LPANEL_POS_P INTEGER :: MYLEAF_LEFT_HUGE_P INTEGER(8) :: LWCB_P INTEGER(8) :: POSWCB_P, PLEFTWCB_P INTEGER :: POSIWCB_P LOGICAL :: DO_MCAST2_TERMBWD_P LOGICAL :: ERROR_WAS_BROADCASTED_P INTEGER :: INFO_P(2), allocok INTEGER :: VIRTUAL_TASK, PHYSICAL_TASK INTEGER :: INODE INTEGER :: NEXT_TASK_DYN !$ INTEGER :: NOMP_SAVE INTEGER :: NBFIN_DUMMY LOGICAL, ALLOCATABLE, DIMENSION(:) :: DEJA_SEND_DUMMY !$ INTEGER :: NOMP_TOTAL NBFIN_DUMMY = huge(NBFIN_DUMMY) ALLOCATE(DEJA_SEND_DUMMY( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of DEJA_SEND_DUMMY in ' & //'routine SMUMPS_SOL_S ' INFO(1)=-13 INFO(2)=SLAVEF GOTO 100 endif !$ IF (KEEP(369).GT.0) THEN !$ NOMP_TOTAL = omp_get_max_threads() #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(KEEP(400),4)) #else !$ CALL omp_set_num_threads(KEEP(400)) #endif !$ ENDIF PTRICB = 0 NEXT_TASK_DYN = KEEP(400)+1 !$OMP PARALLEL !$OMP& SHARED ( NEXT_TASK_DYN, LPOOL_B_L0_OMP, !$OMP& NBFIN_DUMMY, DEJA_SEND_DUMMY ) !$OMP& PRIVATE ( THREAD_ID, IL0OMPFAC, VIRTUAL_TASK, PHYSICAL_TASK, !$OMP& IPOOL_P, LPOOL_P, IIPOOL_P, MYLEAF_LEFT_HUGE_P, !$OMP& LIWCB_P, LWCB_P, IWCB_P, WCB_P, W2_P, LPANEL_POS_P, !$OMP& PANEL_POS_P, !$OMP& PLEFTWCB_P, POSWCB_P, POSIWCB_P, !$OMP& INODE, !$OMP& INFO_P, DO_MCAST2_TERMBWD_P, !$OMP& ERROR_WAS_BROADCASTED_P, NOMP_SAVE, allocok ) !$ NOMP_SAVE = omp_get_max_threads() THREAD_ID = 1 !$ THREAD_ID = OMP_GET_THREAD_NUM() + 1 !$OMP BARRIER !$ CALL omp_set_num_threads(1) LPOOL_P = LPOOL_B_L0_OMP INFO_P(1:2) = 0 LWCB_P = int(KEEP(133),8)*int(NRHS,8) LIWCB_P = KEEP(133) PLEFTWCB_P = 1_8 POSWCB_P = LWCB_P POSIWCB_P = LIWCB_P IF (KEEP(201).EQ.1) THEN LPANEL_POS_P = KEEP(228)+1 CALL MUMPS_ABORT() ELSE LPANEL_POS_P = 1 ENDIF ALLOCATE(IPOOL_P(LPOOL_P), IWCB_P(LIWCB_P), WCB_P( LWCB_P), & W2_P(KEEP(133)), PANEL_POS_P(LPANEL_POS_P), stat=allocok) IF ( allocok > 0 ) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4(LPOOL_P + LIWCB_P + LWCB_P + & KEEP(133)+LPANEL_POS_P, INFO(2)) !$OMP CRITICAL(critical_info) INFO(1) = -13 INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ENDIF !$OMP BARRIER IF (INFO(1) .LT. 0) THEN GOTO 50 ENDIF VIRTUAL_TASK = THREAD_ID 600 CONTINUE IF (VIRTUAL_TASK .LT. L_VIRT_L0_OMP) THEN DO PHYSICAL_TASK = VIRT_L0_OMP( VIRTUAL_TASK ), & VIRT_L0_OMP ( VIRTUAL_TASK + 1 ) - 1 INODE = PHYS_L0_OMP( PERM_L0_OMP( PHYSICAL_TASK ) ) IPOOL_P(1) = INODE IIPOOL_P = 2 MYLEAF_LEFT_HUGE_P = huge(MYLEAF_LEFT_HUGE_P) IF ( PRUN_BELOW_BWD ) THEN IF ( .NOT. TO_PROCESS(STEP(INODE)) ) THEN CYCLE ENDIF ENDIF DO WHILE (IIPOOL_P .NE.1 .AND. INFO_P(1) .GE. 0) IIPOOL_P = IIPOOL_P - 1 INODE = IPOOL_P(IIPOOL_P) IL0OMPFAC = L0_OMP_MAPPING(STEP(INODE)) IF (IL0OMPFAC .NE. THREAD_ID) THEN ENDIF CALL SMUMPS_SOLVE_NODE_BWD( INODE, N, IPOOL_P, LPOOL_P, & IIPOOL_P, NBFIN_DUMMY, L0_OMP_FACTORS(IL0OMPFAC)%A(1), & L0_OMP_FACTORS(IL0OMPFAC)%LA, IW, LIW, & WCB_P, LWCB_P, NRHS, POSWCB_P, PLEFTWCB_P, POSIWCB_P, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PTRICB, PTRACB, IWCB_P, LIWCB_P, W2_P, NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, MYLEAF_LEFT_HUGE_P, INFO_P, & PROCNODE_STEPS, & DEJA_SEND_DUMMY, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP, KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS_P, LPANEL_POS_P, & PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED_P & , DO_MCAST2_TERMBWD_P & ) IF (INFO_P(1) .LT. 0) THEN !$OMP CRITICAL(critical_info) INFO(1) = INFO_P(1) INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 50 IF (ERROR_WAS_BROADCASTED_P) THEN WRITE(*,*) " Internal error 1 in SMUMPS_SOL_L0OMP_R", & ERROR_WAS_BROADCASTED_P ENDIF IF (DO_MCAST2_TERMBWD_P) THEN WRITE(*,*) " Internal error 2 in SMUMPS_SOL_L0OMP_R", & DO_MCAST2_TERMBWD_P ENDIF ENDDO ENDDO !$OMP ATOMIC CAPTURE VIRTUAL_TASK = NEXT_TASK_DYN NEXT_TASK_DYN = NEXT_TASK_DYN + 1 !$OMP END ATOMIC GOTO 600 ENDIF 50 CONTINUE IF (allocated(IPOOL_P)) DEALLOCATE(IPOOL_P) IF (allocated(IWCB_P)) DEALLOCATE(IWCB_P) IF (allocated(WCB_P)) DEALLOCATE(WCB_P) IF (allocated(W2_P)) DEALLOCATE(W2_P) IF (allocated(PANEL_POS_P)) DEALLOCATE(PANEL_POS_P) #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_SAVE,4)) #else !$ CALL omp_set_num_threads(NOMP_SAVE) #endif !$OMP END PARALLEL !$ IF (KEEP(369).GT.0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_TOTAL),4)) #else !$ CALL omp_set_num_threads(NOMP_TOTAL) #endif !$ ENDIF 100 CONTINUE IF (allocated(DEJA_SEND_DUMMY)) DEALLOCATE(DEJA_SEND_DUMMY) RETURN END SUBROUTINE SMUMPS_SOL_L0OMP_S END MODULE SMUMPS_SOL_L0OMP_M MUMPS_5.8.1/src/dstatic_ptr_m.F0000664000175000017500000000212315042446437016177 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_STATIC_PTR_M PUBLIC :: DMUMPS_TMP_PTR, DMUMPS_GET_TMP_PTR DOUBLE PRECISION, DIMENSION(:), POINTER, SAVE :: DMUMPS_TMP_PTR CONTAINS SUBROUTINE DMUMPS_SET_STATIC_PTR(ARRAY) DOUBLE PRECISION, DIMENSION(:), TARGET :: ARRAY DMUMPS_TMP_PTR => ARRAY RETURN END SUBROUTINE DMUMPS_SET_STATIC_PTR SUBROUTINE DMUMPS_GET_TMP_PTR(PTR) #if defined(MUMPS_NOF2003) DOUBLE PRECISION, DIMENSION(:), POINTER :: PTR #else DOUBLE PRECISION, DIMENSION(:), POINTER, INTENT(OUT) :: PTR #endif PTR => DMUMPS_TMP_PTR RETURN END SUBROUTINE DMUMPS_GET_TMP_PTR END MODULE DMUMPS_STATIC_PTR_M MUMPS_5.8.1/src/ana_blk.F0000664000175000017500000016765715042446422014754 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_AB_FREE_LMAT ( LMAT, K147 ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE TYPE(LMATRIX_T) :: LMAT INTEGER, INTENT(IN) :: K147 INTEGER :: J IF (associated(LMAT%COL)) THEN IF (LMAT%NBCOL_LOC.GT.0) THEN DO J = 1,LMAT%NBCOL_LOC, K147 IF (associated(LMAT%COL(J)%IRN)) THEN DEALLOCATE(LMAT%COL(J)%IRN) NULLIFY(LMAT%COL(J)%IRN) ENDIF ENDDO ENDIF DEALLOCATE(LMAT%COL) NULLIFY(LMAT%COL) ENDIF RETURN END SUBROUTINE MUMPS_AB_FREE_LMAT SUBROUTINE MUMPS_AB_FREE_GCOMP ( GCOMP, MEMCNT ) USE MUMPS_ANA_BLK_M, ONLY : COMPACT_GRAPH_T IMPLICIT NONE TYPE(COMPACT_GRAPH_T) :: GCOMP INTEGER(8), INTENT(INOUT) :: MEMCNT IF (associated(GCOMP%IPE)) & MEMCNT = MEMCNT - int(size(GCOMP%IPE),8) IF (associated(GCOMP%ADJ)) & MEMCNT = MEMCNT - GCOMP%SIZEADJALLOCATED - 5 IF (associated(GCOMP%IPE)) THEN DEALLOCATE(GCOMP%IPE) NULLIFY(GCOMP%IPE) ENDIF IF (associated(GCOMP%ADJ)) THEN DEALLOCATE(GCOMP%ADJ) NULLIFY(GCOMP%ADJ) ENDIF RETURN END SUBROUTINE MUMPS_AB_FREE_GCOMP SUBROUTINE MUMPS_AB_COMPUTE_SIZEOFBLOCK ( & NBLK, NDOF, BLKPTR, BLKVAR, & SIZEOFBLOCKS, DOF2BLOCK ) IMPLICIT NONE INTEGER, INTENT(IN) :: NBLK, NDOF INTEGER, INTENT(IN) :: BLKPTR(NBLK+1), BLKVAR(NDOF) INTEGER, INTENT(OUT):: SIZEOFBLOCKS(NBLK), DOF2BLOCK(NDOF) INTEGER :: IB, I, IDOF DO IB=1, NBLK SIZEOFBLOCKS(IB)= BLKPTR(IB+1)-BLKPTR(IB) DO I=BLKPTR(IB), BLKPTR(IB+1)-1 IDOF = BLKVAR(I) DOF2BLOCK(IDOF) = IB ENDDO ENDDO RETURN END SUBROUTINE MUMPS_AB_COMPUTE_SIZEOFBLOCK SUBROUTINE MUMPS_AB_COORD_TO_LMAT ( MYID, & NBLK, NDOF, NNZ, IRN, JCN, & DOF2BLOCK, & IFLAG, IERROR, LP, LPOK, & LMAT, OFFDIAG, KEEP & ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, NBLK, NDOF INTEGER(8), INTENT(IN) :: NNZ INTEGER, INTENT(IN) :: IRN(max(1_8,NNZ)), JCN(max(1_8,NNZ)) INTEGER, INTENT(IN) :: DOF2BLOCK(NDOF) INTEGER :: LP, IFLAG, IERROR LOGICAL, INTENT(IN) :: LPOK INTEGER(8), INTENT(OUT) :: OFFDIAG INTEGER, INTENT(INOUT) :: KEEP(500) TYPE(LMATRIX_T) :: LMAT LOGICAL :: LU_WITH_SYM_STRUCT, NO_DUPPLICATES INTEGER, ALLOCATABLE, DIMENSION(:) :: FLAG INTEGER :: allocok, IERROR_LOC INTEGER :: I, J, JJ, JJB, IIB, IB, JB, PT INTEGER(8) :: I8, NB_8, PT_CUR, SIZE_TO_ALLOC_8 INTEGER, POINTER, DIMENSION(:) :: BLOCK_PTR LU_WITH_SYM_STRUCT = (KEEP(202).EQ.1) NO_DUPPLICATES = (KEEP(203).EQ.1) LMAT%NBCOL = NBLK LMAT%NZL = 0_8 LMAT%NBCOL_LOC = NBLK LMAT%FIRST = 1 ALLOCATE(LMAT%COL(NBLK), & FLAG(NBLK), STAT=allocok) IF (allocok.NE.0) THEN IFLAG = -7 IERROR = 2*NBLK IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate of LMAT%COL" END IF RETURN ENDIF DO IB=1,LMAT%NBCOL_LOC LMAT%COL(IB)%NBINCOL = 0 ENDDO DO IB=1,LMAT%NBCOL FLAG(IB) = 0 ENDDO IERROR_LOC = 0 OFFDIAG = 0 DO I8=1, NNZ I = IRN(I8) J = JCN(I8) IF ( (I.GT.NDOF).OR.(J.GT.NDOF).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR_LOC = IERROR_LOC + 1 ELSE IB = DOF2BLOCK(I) JB = DOF2BLOCK(J) JJB = min(IB,JB) IF (IB.NE.JB) THEN OFFDIAG = OFFDIAG + 1 IF (LU_WITH_SYM_STRUCT.AND.IB.LT.JB) CYCLE LMAT%NZL = LMAT%NZL+1_8 LMAT%COL(JJB)%NBINCOL = LMAT%COL(JJB)%NBINCOL + 1 ENDIF ENDIF ENDDO IF (IERROR_LOC.GE.1) THEN IF (mod(IFLAG,2) .EQ. 0) THEN IFLAG = IFLAG+1 IERROR = IERROR_LOC ENDIF ENDIF DO JB=1,LMAT%NBCOL_LOC, KEEP(147) SIZE_TO_ALLOC_8 = 0_8 DO JJ=JB, min(JB+KEEP(147)-1,LMAT%NBCOL_LOC) SIZE_TO_ALLOC_8 = SIZE_TO_ALLOC_8 + & int(LMAT%COL(JJ)%NBINCOL, 8) ENDDO ALLOCATE(LMAT%COL(JB)%IRN(SIZE_TO_ALLOC_8), STAT=allocok) IF (allocok.NE.0) THEN IFLAG = -7 CALL MUMPS_SET_IERROR(SIZE_TO_ALLOC_8, IERROR) IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate block of ", & KEEP(147), " columns in LMAT%COL", & " of size ", SIZE_TO_ALLOC_8 END IF RETURN ENDIF IF (KEEP(147).GT.1) THEN BLOCK_PTR => LMAT%COL(JB)%IRN NB_8 = int(LMAT%COL(JB)%NBINCOL, 8) PT_CUR = 1_8 + NB_8 DO JJ=JB+1, min(JB+KEEP(147)-1,LMAT%NBCOL_LOC) NB_8 = int(LMAT%COL(JJ)%NBINCOL,8) IF (NB_8.GT.0) THEN LMAT%COL(JJ)%IRN => BLOCK_PTR(PT_CUR: PT_CUR+NB_8-1_8) PT_CUR = PT_CUR + NB_8 ENDIF ENDDO ENDIF ENDDO DO I8=1, NNZ I = IRN(I8) J = JCN(I8) IF ( (I.LE.NDOF).AND.(J.LE.NDOF).AND.(I.GE.1) & .AND.(J.GE.1)) THEN IB = DOF2BLOCK(I) JB = DOF2BLOCK(J) IF (LU_WITH_SYM_STRUCT.AND.IB.LT.JB) CYCLE JJB = min(IB,JB) IIB = max(IB,JB) IF (IIB.NE.JJB) THEN PT = FLAG(JJB)+1 FLAG(JJB) = PT LMAT%COL(JJB)%IRN(PT) = IIB ENDIF ENDIF ENDDO IF ( ( NDOF.NE.NBLK ) & .OR. & ( KEEP(50).NE.0 .AND. .NOT.NO_DUPPLICATES ) & .OR. & ( KEEP(50).EQ.0.AND. & .NOT.(LU_WITH_SYM_STRUCT.AND.NO_DUPPLICATES) ) & ) & THEN CALL MUMPS_AB_LOCALCLEAN_LMAT ( MYID, & LMAT, KEEP(147), & FLAG(1), LMAT%NBCOL, IFLAG, IERROR, LP, LPOK & ) ENDIF DEALLOCATE(FLAG) RETURN END SUBROUTINE MUMPS_AB_COORD_TO_LMAT SUBROUTINE MUMPS_AB_LOCALCLEAN_LMAT ( MYID, & LMAT, K147, FLAG, NBCOL, IFLAG, IERROR, LP, LPOK & ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: NBCOL, K147 INTEGER, INTENT(OUT) :: FLAG(NBCOL) INTEGER, INTENT(INOUT) :: IFLAG, IERROR TYPE(LMATRIX_T), INTENT(INOUT) :: LMAT INTEGER, POINTER, DIMENSION(:) :: PTCLEAN INTEGER :: allocok, IB, JB, JJ, LMAT_FIRST, NBCOL_LOC INTEGER(8) :: NB_8, PT_CUR, SIZE_TO_ALLOC_8 LMAT_FIRST = LMAT%FIRST NBCOL_LOC = LMAT%NBCOL_LOC DO JB=1, NBCOL FLAG(JB) = 0 ENDDO LMAT%NZL = 0_8 DO JB=1, NBCOL_LOC, K147 SIZE_TO_ALLOC_8 = 0_8 DO JJ=JB, min(JB+K147-1,NBCOL_LOC) IF ( LMAT%COL(JJ)%NBINCOL.EQ.0) CYCLE DO IB=1, LMAT%COL(JJ)%NBINCOL IF (FLAG(LMAT%COL(JJ)%IRN(IB)).EQ.JJ+LMAT_FIRST-1) THEN LMAT%COL(JJ)%IRN(IB)=0 ELSE SIZE_TO_ALLOC_8 = SIZE_TO_ALLOC_8 + 1_8 LMAT%NZL = LMAT%NZL+1_8 FLAG(LMAT%COL(JJ)%IRN(IB)) = JJ+LMAT_FIRST-1 ENDIF ENDDO ENDDO IF (SIZE_TO_ALLOC_8.GT.0) THEN ALLOCATE(PTCLEAN(SIZE_TO_ALLOC_8), STAT=allocok) IF (allocok.NE.0) THEN IFLAG = -7 CALL MUMPS_SET_IERROR(SIZE_TO_ALLOC_8, IERROR) IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate PTCLEAN of size", & IERROR END IF RETURN ENDIF PT_CUR = 1_8 DO JJ=JB, min(JB+K147-1,NBCOL_LOC) NB_8 = 0_8 DO IB=1, LMAT%COL(JJ)%NBINCOL IF (LMAT%COL(JJ)%IRN(IB).NE.0) THEN PTCLEAN(PT_CUR+NB_8)=LMAT%COL(JJ)%IRN(IB) NB_8 = NB_8 + 1_8 ENDIF ENDDO LMAT%COL(JJ)%NBINCOL = int(NB_8) IF (JJ.GT.JB) & LMAT%COL(JJ)%IRN => PTCLEAN(PT_CUR: PT_CUR+NB_8-1_8) PT_CUR = PT_CUR + NB_8 ENDDO deallocate(LMAT%COL(JB)%IRN) LMAT%COL(JB)%IRN => PTCLEAN NULLIFY(PTCLEAN) ELSE if (associated(LMAT%COL(JB)%IRN)) & deallocate(LMAT%COL(JB)%IRN) NULLIFY(LMAT%COL(JB)%IRN) ENDIF ENDDO RETURN END SUBROUTINE MUMPS_AB_LOCALCLEAN_LMAT SUBROUTINE MUMPS_AB_CLEANLMAT_TO_LUMAT( & LMAT, LUMAT, K147, INFO, ICNTL ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE TYPE(LMATRIX_T) :: LMAT, LUMAT INTEGER, INTENT(IN) :: K147 INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: INFO(80) INTEGER :: IB, JJ, IIB, JB, allocok, LP, MPG, NB INTEGER(8) :: NB_8, PT_CUR, SIZE_TO_ALLOC_8 INTEGER, POINTER, DIMENSION(:) :: BLOCK_PTR LOGICAL LPOK, PROKG LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MPG = ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. (ICNTL(4).GE.2) ) LUMAT%NBCOL = LMAT%NBCOL LUMAT%NZL = 2_8*LMAT%NZL LUMAT%FIRST = LMAT%FIRST LUMAT%NBCOL_LOC = LMAT%NBCOL ALLOCATE( LUMAT%COL(LUMAT%NBCOL_LOC),STAT=allocok) IF (allocok.NE.0) THEN INFO( 1 ) = -7 INFO( 2 ) = LUMAT%NBCOL_LOC IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocating LUMAT%COL " END IF RETURN ENDIF DO JB=1, LMAT%NBCOL LUMAT%COL(JB)%NBINCOL = LMAT%COL(JB)%NBINCOL ENDDO DO JB=1, LMAT%NBCOL_LOC DO IB=1, LMAT%COL(JB)%NBINCOL IIB=LMAT%COL(JB)%IRN(IB) LUMAT%COL(IIB)%NBINCOL = LUMAT%COL(IIB)%NBINCOL + 1 ENDDO ENDDO DO JB=1, LMAT%NBCOL_LOC, K147 SIZE_TO_ALLOC_8 = 0_8 DO JJ=JB, min(JB+K147-1,LUMAT%NBCOL_LOC) SIZE_TO_ALLOC_8 = SIZE_TO_ALLOC_8 + & int(LUMAT%COL(JJ)%NBINCOL, 8) ENDDO ALLOCATE(LUMAT%COL(JB)%IRN(SIZE_TO_ALLOC_8), STAT=allocok) IF (allocok.NE.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(SIZE_TO_ALLOC_8, INFO(2)) IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate block of ", & K147, " columns in LUMAT%COL", & " of size ", SIZE_TO_ALLOC_8 END IF RETURN ENDIF IF (K147.GT.1) THEN BLOCK_PTR => LUMAT%COL(JB)%IRN NB_8 = int(LUMAT%COL(JB)%NBINCOL, 8) PT_CUR = 1_8 + NB_8 DO JJ=JB+1, min(JB+K147-1,LUMAT%NBCOL_LOC) NB_8 = int(LUMAT%COL(JJ)%NBINCOL,8) IF (NB_8.GT.0) THEN LUMAT%COL(JJ)%IRN => BLOCK_PTR(PT_CUR: PT_CUR+NB_8-1_8) PT_CUR = PT_CUR + NB_8 ENDIF ENDDO ENDIF ENDDO DO JB=1, LMAT%NBCOL_LOC LUMAT%COL(JB)%NBINCOL = 0 ENDDO DO JB=1, LMAT%NBCOL_LOC DO IB=1, LMAT%COL(JB)%NBINCOL IIB=LMAT%COL(JB)%IRN(IB) NB = LUMAT%COL(JB)%NBINCOL+1 LUMAT%COL(JB)%NBINCOL = NB LUMAT%COL(JB)%IRN(NB)= IIB NB = LUMAT%COL(IIB)%NBINCOL+1 LUMAT%COL(IIB)%NBINCOL = NB LUMAT%COL(IIB)%IRN(NB)= JB ENDDO ENDDO RETURN END SUBROUTINE MUMPS_AB_CLEANLMAT_TO_LUMAT SUBROUTINE MUMPS_AB_LMAT_TO_CLEAN_G( MYID, UNFOLD, & READY_FOR_ANA_F, & LMAT, GCOMP, INFO, ICNTL & , MEMCNT ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T, COMPACT_GRAPH_T #if defined(DETERMINISTIC_PARALLEL_GRAPH) USE MUMPS_TOOLS_COMMON_M, ONLY : MUMPS_MERGESORT, & MUMPS_MERGESWAP1 #endif IMPLICIT NONE INTEGER, INTENT(IN) :: MYID LOGICAL, INTENT(IN) :: UNFOLD, READY_FOR_ANA_F TYPE(LMATRIX_T) :: LMAT TYPE(COMPACT_GRAPH_T) :: GCOMP INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: INFO(80) INTEGER(8), INTENT(INOUT) :: MEMCNT INTEGER :: IB, IIB, JJB, allocok, LP, MPG INTEGER :: JFIRST, NG_LOCAL INTEGER(8) :: JPOS, SIZEGCOMPALLOCATED INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IQ #if defined(DETERMINISTIC_PARALLEL_GRAPH) INTEGER, ALLOCATABLE, DIMENSION(:) :: WORK INTEGER(8) :: IFIRST, ILAST INTEGER :: L #endif LOGICAL LPOK, PROKG LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MPG = ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. (ICNTL(4).GE.2) ) GCOMP%NG = LMAT%NBCOL GCOMP%FIRST = LMAT%FIRST GCOMP%LAST = LMAT%FIRST+LMAT%NBCOL_LOC-1 JFIRST = GCOMP%FIRST NG_LOCAL = LMAT%NBCOL_LOC IF (UNFOLD) THEN GCOMP%NZG = 2_8*LMAT%NZL SIZEGCOMPALLOCATED = GCOMP%NZG + int(GCOMP%NG,8)+1_8 ELSE IF (READY_FOR_ANA_F) THEN GCOMP%NZG = LMAT%NZL SIZEGCOMPALLOCATED = GCOMP%NZG + int(GCOMP%NG,8)+1_8 ELSE GCOMP%NZG = LMAT%NZL SIZEGCOMPALLOCATED = GCOMP%NZG ENDIF GCOMP%SIZEADJALLOCATED= SIZEGCOMPALLOCATED ALLOCATE( GCOMP%ADJ(SIZEGCOMPALLOCATED), & GCOMP%IPE(NG_LOCAL+1), & IQ(NG_LOCAL),STAT=allocok) IF (allocok.NE.0) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR( & GCOMP%NZG + 3_8*int(GCOMP%NG,8)+1_8, INFO(2)) IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocating graph in", & " MUMPS_AB_LMAT_TO_CLEAN_G" END IF RETURN ENDIF DO JJB=1, NG_LOCAL IQ(JJB)=0_8 ENDDO IF (UNFOLD) THEN DO JJB=1, NG_LOCAL DO IB=1, LMAT%COL(JJB)%NBINCOL IIB=LMAT%COL(JJB)%IRN(IB) IQ(JJB)=IQ(JJB)+1 IQ(IIB)=IQ(IIB)+1 ENDDO ENDDO ELSE DO JJB=1, NG_LOCAL IQ(JJB) = LMAT%COL(JJB)%NBINCOL ENDDO ENDIF GCOMP%IPE(1) = 1_8 DO JJB=1, NG_LOCAL GCOMP%IPE(JJB+1) = GCOMP%IPE(JJB)+IQ(JJB) ENDDO IF (UNFOLD) THEN DO JJB=1, GCOMP%NG IQ(JJB)= GCOMP%IPE(JJB) ENDDO DO JJB=1, NG_LOCAL DO IB=1, LMAT%COL(JJB)%NBINCOL IIB=LMAT%COL(JJB)%IRN(IB) GCOMP%ADJ(IQ(IIB))= JJB IQ(IIB) = IQ(IIB)+1_8 GCOMP%ADJ(IQ(JJB))= IIB IQ(JJB) = IQ(JJB)+1_8 ENDDO ENDDO ELSE DO JJB=1, NG_LOCAL JPOS = GCOMP%IPE(JJB) DO IB=1, LMAT%COL(JJB)%NBINCOL IIB=LMAT%COL(JJB)%IRN(IB) GCOMP%ADJ(JPOS)= IIB JPOS = JPOS+1_8 ENDDO ENDDO ENDIF DEALLOCATE(IQ) #if defined(DETERMINISTIC_PARALLEL_GRAPH) IF (.NOT.READY_FOR_ANA_F) THEN ALLOCATE(WORK(0:GCOMP%NG),stat=allocok) IF (allocok.NE.0) THEN INFO( 1 ) = -7 INFO( 2 ) = GCOMP%NG IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocating WORK in", & " MUMPS_AB_LMAT_TO_CLEAN_G" END IF RETURN ENDIF DO JJB=1, NG_LOCAL IFIRST = GCOMP%IPE(JJB) ILAST= GCOMP%IPE(JJB+1)-1 L = int(ILAST-IFIRST+1) IF ( L .GE. 2 ) THEN IF (L .GE. GCOMP%NG ) THEN WRITE(*,*) " Internal error in MUMPS_AB_LMAT_TO_CLEAN_G", & L, GCOMP%NG CALL MUMPS_ABORT() ENDIF CALL MUMPS_MERGESORT( L, & GCOMP%ADJ(IFIRST:ILAST), WORK(0:L+1) ) CALL MUMPS_MERGESWAP1( L, & WORK(0:L+1), GCOMP%ADJ(IFIRST:ILAST) ) ENDIF ENDDO DEALLOCATE(WORK) ENDIF #endif MEMCNT = MEMCNT + GCOMP%SIZEADJALLOCATED & + (GCOMP%LAST-GCOMP%FIRST+1)+1 & + 5 RETURN END SUBROUTINE MUMPS_AB_LMAT_TO_CLEAN_G SUBROUTINE MUMPS_AB_COL_DISTRIBUTION ( OPTION, & INFO, ICNTL, COMM, NBLK, MYID, NPROCS, & LMAT, MAPCOL, CONTIGUOUS_COL ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER, INTENT(IN) :: OPTION, NBLK INTEGER, INTENT(IN) :: ICNTL(60), COMM, MYID, NPROCS INTEGER :: INFO(80) TYPE(LMATRIX_T) :: LMAT INTEGER, INTENT(OUT):: MAPCOL(NBLK) LOGICAL, INTENT(OUT):: CONTIGUOUS_COL INTEGER :: LP, SIZE_NZROW, I LOGICAL :: LPOK INTEGER(8) :: NZL, NNZ INTEGER, DIMENSION(:), ALLOCATABLE :: NZ_ROW LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IF (OPTION.EQ.1) THEN NNZ = -9999 SIZE_NZROW = 1 ELSE NZL = LMAT%NZL SIZE_NZROW = NBLK ENDIF ALLOCATE(NZ_ROW(NBLK), STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = SIZE_NZROW IF ( LPOK ) THEN WRITE(LP, *) & " ERROR allocate in MUMPS_AB_COL_DISTRIBUTION ", INFO(2) END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF (INFO(1).LT.0) GOTO 500 IF (OPTION.NE.1) THEN DO I = 1, LMAT%NBCOL_LOC MAPCOL(I) = LMAT%COL(I)%NBINCOL ENDDO CALL MUMPS_BIGALLREDUCE(.FALSE., & MAPCOL(1), NZ_ROW(1), NBLK, & MPI_INTEGER, MPI_SUM, COMM, IERR) CALL MPI_ALLREDUCE(NZL, NNZ, 1, & MPI_INTEGER8, MPI_SUM, COMM, IERR) ENDIF CALL MUMPS_AB_COMPUTE_MAPCOL (OPTION, INFO, ICNTL, MYID, & NNZ, NZ_ROW(1), SIZE_NZROW, NBLK, NPROCS, MAPCOL(1), & CONTIGUOUS_COL) 500 CONTINUE IF (allocated(NZ_ROW)) DEALLOCATE(NZ_ROW) RETURN END SUBROUTINE MUMPS_AB_COL_DISTRIBUTION SUBROUTINE MUMPS_AB_COMPUTE_MAPCOL (OPTION, INFO, ICNTL, & MYID, NNZ, NZ_ROW, SIZE_NZROW, NBLK, NPROCS, MAPCOL, & CONTIGUOUS_COL ) INTEGER, INTENT(IN) :: OPTION, MYID, SIZE_NZROW, NBLK INTEGER, INTENT(IN) :: ICNTL(60), NPROCS INTEGER :: INFO(80) INTEGER(8) :: NNZ INTEGER, INTENT(IN) :: NZ_ROW(SIZE_NZROW) INTEGER, INTENT(OUT):: MAPCOL(NBLK) LOGICAL, INTENT(OUT) :: CONTIGUOUS_COL INTEGER :: I, J, P, F, LP, IERR LOGICAL :: LPOK INTEGER(8) :: SHARE, T INTEGER, DIMENSION(:), ALLOCATABLE :: FIRST LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) ALLOCATE(FIRST(NPROCS+1), STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = NPROCS+1 IF ( LPOK ) THEN WRITE(LP, *) & " ERROR allocate in MUMPS_AB_COL_DISTRIBUTION ", INFO(2) END IF GOTO 500 ENDIF DO I=1,NPROCS+1 FIRST(I) = 0 ENDDO CONTIGUOUS_COL = .TRUE. IF (OPTION.EQ.1) THEN SHARE = int(NBLK/NPROCS,8) DO I=1, NPROCS FIRST(I) = (I-1)*int(SHARE)+1 END DO FIRST(NPROCS+1)=NBLK+1 ELSE SHARE = (NNZ-1_8)/int(NPROCS,8) + 1_8 P = 0 T = 0_8 F = 1 DO I=1, NBLK T = T+int(NZ_ROW(I),8) IF ( & (T .GE. SHARE) .OR. & ((NBLK-I).EQ.(NPROCS-P-1)) .OR. & (I.EQ.NBLK) & ) THEN P = P+1 IF(P.EQ.NPROCS) THEN FIRST(P) = F EXIT ELSE FIRST(P) = F F = I+1 T = 0_8 END IF END IF IF ((I.EQ.NBLK).AND.(P.NE.NPROCS)) THEN DO J=P,NPROCS FIRST(J) = FIRST(P) ENDDO ENDIF END DO FIRST(NPROCS+1) = NBLK+1 ENDIF DO I=1,NPROCS DO J=FIRST(I), FIRST(I+1)-1 MAPCOL(J) = I-1 ENDDO ENDDO IF (allocated(FIRST)) DEALLOCATE(FIRST) 500 CONTINUE RETURN END SUBROUTINE MUMPS_AB_COMPUTE_MAPCOL SUBROUTINE MUMPS_AB_BUILD_DCLEAN_LUMATRIX ( & MAPCOLonLUMAT, MAPCOL_IN_NSTEPS, CONTIGUOUS_COL, & INFO, ICNTL, KEEP, COMM, MYID, NBLK, NPROCS, & LMAT, MAPCOL, SIZEMAPCOL, & STEP, SIZESTEP, & LUMAT) USE MUMPS_ANA_BLK_M IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' LOGICAL, INTENT(IN) :: MAPCOLonLUMAT, MAPCOL_IN_NSTEPS LOGICAL, INTENT(INOUT) :: CONTIGUOUS_COL INTEGER, INTENT(IN) :: MYID, NPROCS, NBLK, SIZEMAPCOL INTEGER, INTENT(IN) :: ICNTL(60), COMM, KEEP(500) INTEGER, INTENT(IN) :: SIZESTEP INTEGER, INTENT(IN) :: STEP(SIZESTEP) INTEGER, INTENT(INOUT) :: INFO(80) TYPE(LMATRIX_T), INTENT(INOUT) :: LMAT INTEGER, INTENT(INOUT) :: MAPCOL(SIZEMAPCOL) TYPE(LMATRIX_T), INTENT(OUT) :: LUMAT INTEGER :: NBLKloc, IERR, JB, IB, LP, NB, I, & NBRECORDS, JJ INTEGER(8) :: NNZ, NZ_locMAX8, NSEND8, NLOCAL8 INTEGER(8) :: NB_8, PT_CUR, SIZE_TO_ALLOC_8 INTEGER, POINTER, DIMENSION(:) :: BLOCK_PTR LOGICAL :: LPOK INTEGER, ALLOCATABLE, DIMENSION(:) :: WT, WNBINCOL INTEGER OPTION PARAMETER (OPTION=2) NBLKloc = LMAT%NBCOL IF (NBLKloc.NE.NBLK) THEN write(6,*) "Internal error in MUMPS_AB_BUILD_DCLEAN_LUMATRIX ", & "NBLKloc, NBLK=", NBLKloc, NBLK ENDIF LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) ALLOCATE(WT(NBLK),WNBINCOL(NBLK),STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = 2*LMAT%NBCOL_LOC IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate of LUMAT%COL; WT" END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 WT = 0 DO JB=1, LMAT%NBCOL_LOC WT(JB) = LMAT%COL(JB)%NBINCOL ENDDO DO JB=1,LMAT%NBCOL_LOC IF ( LMAT%COL(JB)%NBINCOL.EQ.0) CYCLE DO IB=1, LMAT%COL(JB)%NBINCOL I = LMAT%COL(JB)%IRN(IB) WT(I)= WT(I)+1 ENDDO ENDDO CALL MUMPS_BIGALLREDUCE(.FALSE., & WT(1), WNBINCOL(1), NBLK, & MPI_INTEGER, MPI_SUM, COMM, IERR) IF (allocated(WT)) DEALLOCATE(WT) IF (MAPCOLonLUMAT) THEN NNZ = 0_8 DO I=1, NBLK NNZ=NNZ+int(WNBINCOL(I),8) ENDDO CALL MUMPS_AB_COMPUTE_MAPCOL (OPTION, INFO, ICNTL, & MYID, NNZ, WNBINCOL(1), NBLK, & NBLK, NPROCS, MAPCOL(1), CONTIGUOUS_COL) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF LUMAT%NBCOL = NBLK LUMAT%NZL = 0_8 LUMAT%FIRST = 1 LUMAT%NBCOL_LOC = NBLK IF (CONTIGUOUS_COL) THEN LUMAT%NBCOL_LOC = 0 LUMAT%FIRST = -9991 DO JB=1,NBLK IF (MAPCOL(JB).EQ.MYID) THEN IF ( LUMAT%FIRST .LT.0 ) LUMAT%FIRST=JB LUMAT%NBCOL_LOC = LUMAT%NBCOL_LOC + 1 ENDIF ENDDO IF (LUMAT%FIRST.LT.0) THEN LUMAT%FIRST = 1 ENDIF ENDIF IF (LUMAT%NBCOL_LOC.GT.0) THEN ALLOCATE(LUMAT%COL(LUMAT%NBCOL_LOC), STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = LUMAT%NBCOL_LOC IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate of LUMAT%COL; WT" END IF ENDIF ENDIF IF ( INFO(1) .GE. 0 ) THEN DO JB=1,NBLK NB = WNBINCOL(JB) IF (MAPCOL_IN_NSTEPS) THEN IF (MAPCOL(abs(STEP(JB))).EQ.MYID) THEN LUMAT%NZL = LUMAT%NZL + int(NB,8) ELSE NB = 0 ENDIF LUMAT%COL(JB)%NBINCOL = NB ELSE IF (LUMAT%NBCOL.EQ.LUMAT%NBCOL_LOC) & LUMAT%COL(JB)%NBINCOL = 0 IF (MAPCOL(JB).EQ.MYID) THEN LUMAT%NZL = LUMAT%NZL + int(NB,8) LUMAT%COL(JB-LUMAT%FIRST+1)%NBINCOL = NB ELSE NB = 0 ENDIF ENDIF ENDDO DO JB=1,LUMAT%NBCOL_LOC, KEEP(147) SIZE_TO_ALLOC_8 = 0_8 DO JJ=JB, min(JB+KEEP(147)-1,LUMAT%NBCOL_LOC) SIZE_TO_ALLOC_8 = SIZE_TO_ALLOC_8 + LUMAT%COL(JJ)%NBINCOL ENDDO IF (SIZE_TO_ALLOC_8.GT.0) THEN ALLOCATE(LUMAT%COL(JB)%IRN(SIZE_TO_ALLOC_8), & STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(SIZE_TO_ALLOC_8, INFO(2)) IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate of LUMAT%COL" END IF EXIT ENDIF ENDIF IF (KEEP(147).GT.1.AND.SIZE_TO_ALLOC_8.GT.0) THEN BLOCK_PTR => LUMAT%COL(JB)%IRN NB_8 = int(LUMAT%COL(JB)%NBINCOL, 8) PT_CUR = 1_8 + NB_8 DO JJ=JB+1, min(JB+KEEP(147)-1,LUMAT%NBCOL_LOC) NB_8 = int(LUMAT%COL(JJ)%NBINCOL,8) IF (NB_8.GT.0) THEN LUMAT%COL(JJ)%IRN => & BLOCK_PTR(PT_CUR: PT_CUR+NB_8-1_8) PT_CUR = PT_CUR + NB_8 ENDIF ENDDO ENDIF ENDDO ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (allocated(WNBINCOL)) DEALLOCATE(WNBINCOL) CALL MPI_ALLREDUCE(LUMAT%NZL, NZ_locMAX8, 1, MPI_INTEGER8, & MPI_MAX, COMM, IERR) NBRECORDS = KEEP(39) IF (NZ_locMAX8 .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(NZ_locMAX8) ENDIF CALL MUMPS_AB_DIST_LMAT_TO_LUMAT ( & .TRUE., & MAPCOL_IN_NSTEPS, & INFO, ICNTL, COMM, MYID, NBLK, NPROCS, & LMAT, MAPCOL, SIZEMAPCOL, STEP, SIZESTEP, & LUMAT, NBRECORDS, NSEND8, NLOCAL8 & ) CALL MUMPS_AB_FREE_LMAT(LMAT, KEEP(147)) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ALLOCATE(WT(LUMAT%NBCOL), STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = 2*NBLK IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate of LUMAT%COL; WT" END IF GOTO 400 ENDIF CALL MUMPS_AB_LOCALCLEAN_LMAT ( MYID, & LUMAT, KEEP(147), & WT(1), LUMAT%NBCOL, INFO(1), INFO(2), LP, LPOK & ) DEALLOCATE(WT) 400 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 GOTO 600 500 CONTINUE IF (allocated(WT)) DEALLOCATE(WT) IF (allocated(WNBINCOL)) DEALLOCATE(WNBINCOL) 600 CONTINUE RETURN END SUBROUTINE MUMPS_AB_BUILD_DCLEAN_LUMATRIX SUBROUTINE MUMPS_INIALIZE_REDIST_LUMAT ( & INFO, ICNTL, KEEP, COMM, MYID, NBLK, & NPROCS, & LUMAT, PROCNODE_STEPS, NSTEPS, MAPCOL, & LUMAT_REMAP, NBRECORDS, STEP & ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR, MASTER PARAMETER (MASTER=0) INTEGER, INTENT(IN) :: MYID, NBLK, NSTEPS, KEEP(500) INTEGER, INTENT(IN) :: ICNTL(60), COMM, NPROCS INTEGER :: INFO(80) INTEGER, INTENT(IN) :: PROCNODE_STEPS(NSTEPS) TYPE(LMATRIX_T), INTENT(IN) :: LUMAT INTEGER, INTENT(IN) :: STEP(NBLK) TYPE(LMATRIX_T), INTENT(INOUT) :: LUMAT_REMAP INTEGER, INTENT(OUT) :: NBRECORDS INTEGER, INTENT(OUT) :: MAPCOL(NSTEPS) INTEGER :: LP, MP, ISTEP, JB, JJ INTEGER(8) :: NB_8, PT_CUR, SIZE_TO_ALLOC_8 INTEGER, POINTER, DIMENSION(:) :: BLOCK_PTR LOGICAL :: LPOK INTEGER, ALLOCATABLE, DIMENSION(:) :: WT, WNBINCOL INTEGER MUMPS_PROCNODE INTEGER(8) :: NZ_locMAX8 LP = ICNTL( 1 ) MP = ICNTL( 2 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) ALLOCATE(WT(NBLK), WNBINCOL(NBLK), STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = 2*NBLK IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate WT" END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 WT = 0 DO JB=1, LUMAT%NBCOL_LOC WT(JB+LUMAT%FIRST-1) = LUMAT%COL(JB)%NBINCOL ENDDO CALL MUMPS_BIGALLREDUCE(.FALSE., WT(1), WNBINCOL(1), & NBLK, MPI_INTEGER, MPI_SUM, COMM, IERR) IF (allocated(WT)) DEALLOCATE(WT) IF (MYID.EQ.MASTER) THEN IF (KEEP(381).GT.1) THEN DO ISTEP=1, NSTEPS MAPCOL(ISTEP) = mod(ISTEP,NPROCS) ENDDO ELSE DO ISTEP=1, NSTEPS MAPCOL(ISTEP) = & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199)) ENDDO ENDIF ENDIF CALL MPI_BCAST( MAPCOL(1), NSTEPS, MPI_INTEGER, & MASTER, COMM, IERR ) CALL MPI_BCAST( STEP(1), NBLK, MPI_INTEGER, & MASTER, COMM, IERR ) LUMAT_REMAP%NBCOL = NBLK LUMAT_REMAP%NBCOL_LOC = NBLK LUMAT_REMAP%FIRST = 1 ALLOCATE(LUMAT_REMAP%COL(LUMAT_REMAP%NBCOL_LOC), STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = LUMAT_REMAP%NBCOL_LOC IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate of LUMAT_REMAP%COL" END IF ENDIF IF ( INFO(1) .GE. 0 ) THEN LUMAT_REMAP%NZL = 0_8 DO JB=1,NBLK, KEEP(147) SIZE_TO_ALLOC_8 = 0_8 DO JJ=JB, min(JB+KEEP(147)-1,NBLK) NB_8 = WNBINCOL(JJ) IF (MAPCOL(abs(STEP(JJ))).EQ.MYID) THEN LUMAT_REMAP%NZL = LUMAT_REMAP%NZL + NB_8 ELSE NB_8 = 0_8 ENDIF SIZE_TO_ALLOC_8 = SIZE_TO_ALLOC_8 + NB_8 LUMAT_REMAP%COL(JJ)%NBINCOL = int(NB_8) ENDDO IF (SIZE_TO_ALLOC_8.GT.0) THEN ALLOCATE(LUMAT_REMAP%COL(JB)%IRN(SIZE_TO_ALLOC_8), & STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(SIZE_TO_ALLOC_8, INFO(2)) IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate of LUMAT_REMAP%COL" END IF EXIT ENDIF ENDIF IF (KEEP(147).GT.1) THEN BLOCK_PTR => LUMAT_REMAP%COL(JB)%IRN NB_8 = int(LUMAT_REMAP%COL(JB)%NBINCOL, 8) PT_CUR = 1_8 + NB_8 DO JJ=JB+1, min(JB+KEEP(147)-1,LUMAT_REMAP%NBCOL_LOC) NB_8 = int(LUMAT_REMAP%COL(JJ)%NBINCOL,8) IF (NB_8.GT.0) THEN LUMAT_REMAP%COL(JJ)%IRN => & BLOCK_PTR(PT_CUR: PT_CUR+NB_8-1_8) PT_CUR = PT_CUR + NB_8 ENDIF ENDDO ENDIF ENDDO ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (allocated(WNBINCOL)) DEALLOCATE(WNBINCOL) CALL MPI_ALLREDUCE(LUMAT_REMAP%NZL, NZ_locMAX8, 1, MPI_INTEGER8, & MPI_MAX, COMM, IERR) NBRECORDS = KEEP(39) IF (NZ_locMAX8 .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(NZ_locMAX8) ENDIF GOTO 600 500 CONTINUE IF (allocated(WT)) DEALLOCATE(WT) IF (allocated(WNBINCOL)) DEALLOCATE(WNBINCOL) 600 CONTINUE RETURN END SUBROUTINE MUMPS_INIALIZE_REDIST_LUMAT SUBROUTINE MUMPS_AB_DCOORD_TO_DCOMPG ( & MYID, NPROCS, COMM, & NBLK, NDOF, NNZ, & IRN, JCN, DOF2BLOCK, & ICNTL, INFO, KEEP, & LUMAT, LUMAT_AVAIL, GCOMP, READY_FOR_ANA_F) USE MUMPS_ANA_BLK_M, ONLY: LMATRIX_T, COMPACT_GRAPH_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INTEGER, INTENT(IN) :: MYID, NPROCS, NBLK, NDOF INTEGER(8), INTENT(IN) :: NNZ INTEGER, INTENT(IN) :: IRN(max(1_8,NNZ)), JCN(max(1_8,NNZ)) LOGICAL, INTENT(IN) :: READY_FOR_ANA_F INTEGER, INTENT(INOUT) :: DOF2BLOCK(NDOF) INTEGER, INTENT(IN) :: ICNTL(60), COMM INTEGER, INTENT(INOUT) :: KEEP(500), INFO(80) TYPE(COMPACT_GRAPH_T) :: GCOMP TYPE(LMATRIX_T) :: LUMAT LOGICAL, INTENT(OUT) :: LUMAT_AVAIL TYPE(LMATRIX_T) :: LMAT INTEGER :: IDUMMY_ARRAY(1) INTEGER :: allocok, LP, MPG LOGICAL :: LPOK, PROKG INTEGER, DIMENSION(:), ALLOCATABLE :: MAPCOL LOGICAL :: MAPCOLonLUMAT, MAPCOL_IN_NSTEPS, CONTIGUOUS_COL INTEGER(8) :: MEMCNT, IDUMMY8 INTEGER OPTION PARAMETER (OPTION=2) LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MPG = ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. MYID .eq. MASTER ) MEMCNT = 0_8 MAPCOLonLUMAT = .FALSE. MAPCOL_IN_NSTEPS = .FALSE. IF (KEEP(14).EQ.1) THEN CALL MUMPS_ABORT() ENDIF IF (KEEP(14).EQ.0) THEN CALL MPI_BCAST( DOF2BLOCK, NDOF, MPI_INTEGER, MASTER, & COMM, IERR ) ENDIF CALL MUMPS_AB_COORD_TO_LMAT ( MYID, & NBLK, NDOF, NNZ, IRN, JCN, & DOF2BLOCK, & INFO(1), INFO(2), LP, LPOK, & LMAT, IDUMMY8, KEEP ) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ALLOCATE(MAPCOL(NBLK), STAT=allocok) IF (allocok.NE.0) THEN INFO(1) = -7 INFO(2) = NBLK IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate MAPCOL of size", & INFO(2) END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (.NOT.MAPCOLonLUMAT) THEN CALL MUMPS_AB_COL_DISTRIBUTION (OPTION, & INFO, ICNTL, COMM, NBLK, MYID, NPROCS, & LMAT, MAPCOL, CONTIGUOUS_COL) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF CALL MUMPS_AB_BUILD_DCLEAN_LUMATRIX ( & MAPCOLonLUMAT, MAPCOL_IN_NSTEPS, CONTIGUOUS_COL, & INFO, ICNTL, KEEP, COMM, MYID, NBLK, NPROCS, & LMAT, MAPCOL, NBLK, & IDUMMY_ARRAY, 1, & LUMAT) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) CALL MUMPS_AB_LMAT_TO_CLEAN_G ( MYID, .FALSE., & READY_FOR_ANA_F, & LUMAT, GCOMP, INFO, ICNTL, MEMCNT & ) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (KEEP(494).EQ.0) THEN CALL MUMPS_AB_FREE_LMAT(LUMAT, KEEP(147)) LUMAT_AVAIL=.FALSE. ELSE LUMAT_AVAIL=.TRUE. ENDIF GOTO 600 500 CONTINUE IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) CALL MUMPS_AB_FREE_LMAT(LMAT, KEEP(147)) CALL MUMPS_AB_FREE_LMAT(LUMAT, KEEP(147)) LUMAT_AVAIL=.FALSE. 600 CONTINUE RETURN END SUBROUTINE MUMPS_AB_DCOORD_TO_DCOMPG SUBROUTINE MUMPS_AB_DCOORD_TO_DLUMAT ( & MYID, NPROCS, COMM, & NPROCS_PARAORD, PARAORD_to_idCOMM, & NBLK, NDOF, NNZ, & IRN, JCN, DOF2BLOCK, & ICNTL, INFO, KEEP, KEEP8, & LUMAT) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INTEGER, INTENT(IN) :: MYID, NPROCS, NBLK, NDOF INTEGER, INTENT(IN) :: NPROCS_PARAORD, & PARAORD_to_idCOMM(NPROCS_PARAORD) INTEGER(8), INTENT(IN) :: NNZ INTEGER, INTENT(IN) :: IRN(max(1_8,NNZ)), JCN(max(1_8,NNZ)) INTEGER, INTENT(INOUT) :: DOF2BLOCK(NDOF) INTEGER, INTENT(IN) :: ICNTL(60), COMM INTEGER, INTENT(INOUT) :: KEEP(500), INFO(80) INTEGER(8), INTENT(INOUT) :: KEEP8(150) TYPE(LMATRIX_T) :: LUMAT TYPE(LMATRIX_T) :: LMAT INTEGER :: IDUMMY_ARRAY(1) INTEGER :: allocok, LP, MPG, I LOGICAL :: LPOK, PROKG INTEGER(8) :: OFFDIAG INTEGER, DIMENSION(:), ALLOCATABLE :: MAPCOL LOGICAL :: MAPCOLonLUMAT, MAPCOL_IN_NSTEPS, CONTIGUOUS_COL INTEGER OPTION LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MPG = ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. MYID .eq. MASTER ) OPTION =2 IF (KEEP(72).EQ.1 .and. NBLK.LE.10) THEN OPTION =1 ENDIF IF (KEEP(72).NE.1 .AND. NDOF.LE.500) THEN OPTION =1 ENDIF MAPCOLonLUMAT = .FALSE. MAPCOL_IN_NSTEPS = .FALSE. IF (KEEP(14).EQ.1) THEN CALL MUMPS_ABORT() ENDIF IF (KEEP(14).EQ.0) THEN CALL MPI_BCAST( DOF2BLOCK, NDOF, MPI_INTEGER, MASTER, & COMM, IERR ) ENDIF CALL MUMPS_AB_COORD_TO_LMAT ( MYID, & NBLK, NDOF, NNZ, IRN, JCN, & DOF2BLOCK, & INFO(1), INFO(2), LP, LPOK, & LMAT, OFFDIAG, KEEP ) CALL MPI_ALLREDUCE (OFFDIAG, KEEP8(127), 1, MPI_INTEGER8, & MPI_SUM, COMM, IERR) KEEP8(127) = KEEP8(127)+3_8*int(NDOF,8) KEEP8(126) = KEEP8(127)-2_8*int(NDOF,8) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ALLOCATE(MAPCOL(NBLK), STAT=allocok) IF (allocok.NE.0) THEN INFO(1) = -7 INFO(2) = NBLK IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate MAPCOL of size", & INFO(2) END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (.NOT.MAPCOLonLUMAT) THEN CALL MUMPS_AB_COL_DISTRIBUTION (OPTION, & INFO, ICNTL, COMM, NBLK, MYID, NPROCS_PARAORD, & LMAT, MAPCOL, CONTIGUOUS_COL) IF (NPROCS_PARAORD.LE.NPROCS) THEN DO I=1, NBLK MAPCOL(I) = PARAORD_to_idCOMM(MAPCOL(I)+1) ENDDO ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF CALL MUMPS_AB_BUILD_DCLEAN_LUMATRIX ( & MAPCOLonLUMAT, MAPCOL_IN_NSTEPS, CONTIGUOUS_COL, & INFO, ICNTL, KEEP, COMM, MYID, NBLK, NPROCS, & LMAT, MAPCOL, NBLK, & IDUMMY_ARRAY, 1, & LUMAT) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) GOTO 600 500 CONTINUE IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) CALL MUMPS_AB_FREE_LMAT(LMAT, KEEP(147)) CALL MUMPS_AB_FREE_LMAT(LUMAT, KEEP(147)) 600 CONTINUE RETURN END SUBROUTINE MUMPS_AB_DCOORD_TO_DLUMAT SUBROUTINE MUMPS_AB_DCOORD_TO_DTREE_LUMAT ( & MYID, NPROCS, COMM, & NBLK, NDOF, NNZ, & IRN, JCN, & PROCNODE_STEPS, NSTEPS, STEP, & ICNTL, INFO, KEEP, & MAPCOL, LUMAT) USE MUMPS_ANA_BLK_M, ONLY: LMATRIX_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INTEGER, INTENT(IN) :: MYID, NPROCS, NBLK, NDOF, NSTEPS INTEGER(8), INTENT(IN) :: NNZ INTEGER, INTENT(IN) :: IRN(max(1_8,NNZ)), JCN(max(1_8,NNZ)) INTEGER, INTENT(IN) :: ICNTL(60), COMM INTEGER, INTENT(IN) :: PROCNODE_STEPS(NSTEPS) INTEGER, INTENT(IN) :: STEP(NBLK) INTEGER, INTENT(INOUT) :: KEEP(500), INFO(80) INTEGER, INTENT(OUT) :: MAPCOL(NSTEPS) TYPE(LMATRIX_T) :: LUMAT INTEGER, DIMENSION(:), allocatable:: DOF2BLOCK TYPE(LMATRIX_T) :: LMAT INTEGER :: allocok, LP LOGICAL :: LPOK INTEGER :: IDOF, ISTEP LOGICAL :: MAPCOL_IN_NSTEPS, MAPCOLonLUMAT, CONTIGUOUS_COL INTEGER(8) :: IDUMMY8 INTEGER OPTION PARAMETER (OPTION=2) INTEGER MUMPS_PROCNODE LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MAPCOLonLUMAT = .FALSE. MAPCOL_IN_NSTEPS = .TRUE. IF (KEEP(14).EQ.1) THEN CALL MUMPS_ABORT() ENDIF allocate(DOF2BLOCK(NDOF), STAT=allocok) IF (allocok.NE.0) THEN INFO( 1 ) = -7 INFO( 2 ) = NDOF IF ( LPOK ) WRITE(LP, 150) ' DOF2BLOCK' ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 DO IDOF=1, NDOF DOF2BLOCK(IDOF) = IDOF ENDDO CALL MUMPS_AB_COORD_TO_LMAT ( MYID, & NBLK, NDOF, NNZ, IRN, JCN, & DOF2BLOCK, & INFO(1), INFO(2), LP, LPOK, & LMAT, IDUMMY8, KEEP ) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) IF (MYID.EQ.MASTER) THEN DO ISTEP=1, NSTEPS MAPCOL(ISTEP) = & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199)) ENDDO ENDIF CALL MPI_BCAST( MAPCOL(1), NSTEPS, MPI_INTEGER, & MASTER, COMM, IERR ) CALL MPI_BCAST( STEP(1), NBLK, MPI_INTEGER, & MASTER, COMM, IERR ) CONTIGUOUS_COL = .FALSE. CALL MUMPS_AB_BUILD_DCLEAN_LUMATRIX( & MAPCOLonLUMAT, MAPCOL_IN_NSTEPS, CONTIGUOUS_COL, & INFO, ICNTL, KEEP, COMM, MYID, NBLK, NPROCS, & LMAT, MAPCOL, NSTEPS, & STEP, NBLK, LUMAT) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 GOTO 600 500 CONTINUE IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) CALL MUMPS_AB_FREE_LMAT(LMAT, KEEP(147)) CALL MUMPS_AB_FREE_LMAT(LUMAT, KEEP(147)) 600 CONTINUE RETURN 150 FORMAT( & /' ** FAILURE IN MUMPS_AB_DCOORD_TO_DTREE_LUMAT, ', & ' DYNAMIC ALLOCATION OF ', & A30) END SUBROUTINE MUMPS_AB_DCOORD_TO_DTREE_LUMAT SUBROUTINE MUMPS_AB_DIST_LMAT_TO_LUMAT ( & UNFOLD, & MAPCOL_IN_NSTEPS, & INFO, ICNTL, COMM, MYID, NBLK, SLAVEF, & LMAT, MAPCOL, SIZE_MAPCOL, STEP, SIZE_STEP, & LUMAT, NBRECORDS, NSEND8, NLOCAL8 & ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR, MASTER, MSGSOU PARAMETER (MASTER=0) INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL, INTENT(IN) :: UNFOLD, MAPCOL_IN_NSTEPS INTEGER, INTENT(IN) :: MYID, SLAVEF, NBLK INTEGER, INTENT(IN) :: SIZE_MAPCOL, SIZE_STEP INTEGER, INTENT(IN) :: ICNTL(60), COMM, NBRECORDS INTEGER :: INFO(80) TYPE(LMATRIX_T), INTENT(IN) :: LMAT INTEGER, INTENT(IN) :: MAPCOL(SIZE_MAPCOL) INTEGER, INTENT(IN) :: STEP(SIZE_STEP) TYPE(LMATRIX_T), INTENT(INOUT) :: LUMAT INTEGER(8), INTENT(OUT) :: NSEND8, NLOCAL8 INTEGER :: LP, MP, allocok INTEGER :: IB, JB, I, II, ISEND, JSEND, ITOSEND LOGICAL :: LPOK INTEGER :: NBTOSEND INTEGER :: LMAT_FIRST, LUMAT_FIRST INTEGER END_MSG_2_RECV INTEGER KPROBE, FREQPROBE INTEGER :: SIZE_PTLOC INTEGER, ALLOCATABLE, DIMENSION(:) :: PTLOC INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFI INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, IREQI LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE INTEGER :: DEST LOGICAL :: FLAG LP = ICNTL( 1 ) MP = ICNTL( 2 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IF (UNFOLD) THEN NBTOSEND = 2 ELSE NBTOSEND = 1 ENDIF NSEND8 = 0_8 NLOCAL8 = 0_8 END_MSG_2_RECV = SLAVEF-1 ALLOCATE( IACT(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IACT in matrix distribution' END IF INFO(1) = -7 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQI(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQI in matrix distribution' END IF INFO(1) = -7 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( SEND_ACTIVE(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating SEND_ACTIVE in matrix distribution' END IF INFO(1) = -7 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int buffer for matrix distribution' END IF INFO(1) = -7 INFO(2) = ( NBRECORDS * 2 + 1 ) * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFRECI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -7 INFO(2) = NBRECORDS * 2 + 1 GOTO 20 END IF SIZE_PTLOC = max(LUMAT%NBCOL_LOC,1) ALLOCATE( PTLOC( SIZE_PTLOC ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -7 INFO(2) = NBLK GOTO 20 END IF 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 100 DO I = 1, SLAVEF BUFI( 1, 1, I ) = 0 END DO DO I = 1, SLAVEF BUFI( 1, 2, I ) = 0 END DO DO I = 1, SLAVEF SEND_ACTIVE( I ) = .FALSE. IACT( I ) = 1 END DO DO I = 1, SIZE_PTLOC PTLOC(I) = 0 END DO KPROBE = 0 FREQPROBE = max(1,NBRECORDS/10) IF (SLAVEF .EQ. 1) FREQPROBE = huge(FREQPROBE) LUMAT_FIRST = LUMAT%FIRST LMAT_FIRST = LMAT%FIRST DO JB=1, LMAT%NBCOL_LOC IF ( LMAT%COL(JB)%NBINCOL.EQ.0) CYCLE DO II=1, LMAT%COL(JB)%NBINCOL KPROBE = KPROBE + 1 IF ( KPROBE .eq. FREQPROBE ) THEN KPROBE = 0 CALL MPI_IPROBE( MPI_ANY_SOURCE, LMATDIST, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, & MPI_INTEGER, & MSGSOU, LMATDIST, COMM, STATUS, IERR ) CALL MUMPS_AB_LMAT_TREAT_RECV_BUF( & MYID, BUFRECI(1), NBRECORDS, LUMAT, & PTLOC(1), SIZE_PTLOC, END_MSG_2_RECV & ) END IF END IF IB = LMAT%COL(JB)%IRN(II) DO ITOSEND=1,NBTOSEND IF (ITOSEND.EQ.1) THEN IF (MAPCOL_IN_NSTEPS) THEN DEST = MAPCOL(abs(STEP(JB+LMAT_FIRST-1))) ELSE DEST = MAPCOL(JB+LMAT_FIRST-1) ENDIF ISEND = IB JSEND = JB+LMAT_FIRST-1 ELSE IF (MAPCOL_IN_NSTEPS) THEN DEST = MAPCOL(abs(STEP(IB))) ELSE DEST = MAPCOL(IB) ENDIF ISEND = JB+LMAT_FIRST-1 JSEND = IB ENDIF IF (DEST.EQ.MYID) THEN LUMAT%COL(JSEND-LUMAT_FIRST+1) & %IRN(1+PTLOC(JSEND-LUMAT_FIRST+1))= ISEND PTLOC(JSEND-LUMAT_FIRST+1) = PTLOC(JSEND-LUMAT_FIRST+1) + 1 NLOCAL8 = NLOCAL8 + 1_8 ELSE NSEND8 = NSEND8 + 1_8 CALL MUMPS_AB_LMAT_FILL_BUFFER( & DEST, ISEND, JSEND, & BUFI, BUFRECI, PTLOC, SIZE_PTLOC, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, & SEND_ACTIVE, LMAT, LUMAT, END_MSG_2_RECV & ) ENDIF ENDDO ENDDO ENDDO DEST = -3 CALL MUMPS_AB_LMAT_FILL_BUFFER(DEST, ISEND, JSEND, & BUFI, BUFRECI, PTLOC, SIZE_PTLOC, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, & SEND_ACTIVE, LMAT, LUMAT, END_MSG_2_RECV & ) DO WHILE ( END_MSG_2_RECV .NE. 0 ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, MPI_INTEGER, & MPI_ANY_SOURCE, LMATDIST, COMM, STATUS, IERR ) CALL MUMPS_AB_LMAT_TREAT_RECV_BUF( & MYID, BUFRECI(1), NBRECORDS, LUMAT, & PTLOC(1), SIZE_PTLOC, END_MSG_2_RECV & ) END DO DO I = 1, SLAVEF IF ( SEND_ACTIVE( I ) ) THEN CALL MPI_WAIT( IREQI( I ), STATUS, IERR ) END IF END DO 100 CONTINUE IF (ALLOCATED(PTLOC)) DEALLOCATE( PTLOC ) IF (ALLOCATED(BUFI)) DEALLOCATE( BUFI ) IF (ALLOCATED(BUFRECI)) DEALLOCATE( BUFRECI ) IF (ALLOCATED(IACT)) DEALLOCATE( IACT ) IF (ALLOCATED(IREQI)) DEALLOCATE( IREQI ) IF (ALLOCATED(SEND_ACTIVE)) DEALLOCATE( SEND_ACTIVE ) RETURN END SUBROUTINE MUMPS_AB_DIST_LMAT_TO_LUMAT SUBROUTINE MUMPS_AB_LMAT_TREAT_RECV_BUF ( & MYID, BUFI, NBRECORDS, LUMAT, & PTLOC, SIZE_PTLOC, END_MSG_2_RECV & ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, INTENT(IN) :: MYID, NBRECORDS, SIZE_PTLOC INTEGER, INTENT(IN) :: BUFI( NBRECORDS * 2 + 1 ) INTEGER, INTENT(INOUT):: END_MSG_2_RECV, PTLOC(SIZE_PTLOC) TYPE(LMATRIX_T), INTENT(INOUT) :: LUMAT INTEGER :: IREC, NB_REC, IB, JB, LUMAT_FIRST NB_REC = BUFI( 1 ) IF ( NB_REC .LE. 0 ) THEN END_MSG_2_RECV = END_MSG_2_RECV - 1 NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) RETURN LUMAT_FIRST = LUMAT%FIRST DO IREC = 1, NB_REC IB = BUFI( IREC * 2 ) JB = BUFI( IREC * 2 + 1 ) JB = JB - LUMAT_FIRST + 1 LUMAT%COL(JB)%IRN(1+PTLOC(JB))= IB PTLOC(JB) = PTLOC(JB) + 1 ENDDO RETURN END SUBROUTINE MUMPS_AB_LMAT_TREAT_RECV_BUF SUBROUTINE MUMPS_AB_LMAT_FILL_BUFFER ( & DEST, ISEND, JSEND, & BUFI, BUFRECI, PTLOC, SIZE_PTLOC, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, & SEND_ACTIVE, LMAT, LUMAT, END_MSG_2_RECV & ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, INTENT(IN) :: DEST, ISEND, JSEND, SLAVEF, COMM, MYID, & NBRECORDS, SIZE_PTLOC INTEGER, INTENT(INOUT) :: END_MSG_2_RECV, PTLOC(SIZE_PTLOC) TYPE(LMATRIX_T), INTENT(IN) :: LMAT TYPE(LMATRIX_T), INTENT(INOUT) :: LUMAT LOGICAL, INTENT(INOUT) :: SEND_ACTIVE(SLAVEF) INTEGER, INTENT(INOUT) :: IREQI(SLAVEF), IACT(SLAVEF) INTEGER, INTENT(INOUT) :: BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ) INTEGER, INTENT(INOUT) :: BUFRECI( NBRECORDS * 2 + 1) INTEGER :: IBEG, IEND, ISLAVE, TAILLE_SEND_I, IREQ, MSGSOU, & NBREC, IERR LOGICAL :: FLAG IF ( DEST .eq. -3 ) THEN IBEG = 1 IEND = SLAVEF ELSE IBEG = DEST + 1 IEND = DEST + 1 END IF DO ISLAVE = IBEG, IEND NBREC = BUFI(1,IACT(ISLAVE),ISLAVE) IF ( DEST .eq. -3 ) THEN BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC END IF IF ( DEST .eq. -3 .or. NBREC + 1 > NBRECORDS ) THEN DO WHILE ( SEND_ACTIVE( ISLAVE ) ) CALL MPI_TEST( IREQI( ISLAVE ), FLAG, STATUS, IERR ) IF ( .NOT. FLAG ) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, LMATDIST, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS(MPI_SOURCE) CALL MPI_RECV( BUFRECI(1), 2*NBRECORDS+1, & MPI_INTEGER, MSGSOU, LMATDIST, COMM, & STATUS, IERR ) CALL MUMPS_AB_LMAT_TREAT_RECV_BUF( & MYID, BUFRECI, NBRECORDS, LUMAT, & PTLOC(1), SIZE_PTLOC, END_MSG_2_RECV & ) END IF ELSE SEND_ACTIVE( ISLAVE ) = .FALSE. END IF END DO IF ( ISLAVE - 1 .ne. MYID ) THEN TAILLE_SEND_I = NBREC * 2 + 1 CALL MPI_ISEND( BUFI(1, IACT(ISLAVE), ISLAVE ), & TAILLE_SEND_I, & MPI_INTEGER, ISLAVE - 1, LMATDIST, COMM, & IREQI( ISLAVE ), IERR ) SEND_ACTIVE( ISLAVE ) = .TRUE. ELSE IF (NBREC.NE.0) THEN write(*,*) " Internal error in ", & " MUMPS_AB_LMAT_FILL_BUFFER " CALL MUMPS_ABORT() ENDIF END IF IACT( ISLAVE ) = 3 - IACT( ISLAVE ) BUFI( 1, IACT( ISLAVE ), ISLAVE ) = 0 END IF IF ( DEST .ne. -3 ) THEN IREQ = BUFI(1,IACT(ISLAVE),ISLAVE) + 1 BUFI(1,IACT(ISLAVE),ISLAVE) = IREQ BUFI(IREQ*2,IACT(ISLAVE),ISLAVE) = ISEND BUFI(IREQ*2+1,IACT(ISLAVE),ISLAVE) = JSEND END IF ENDDO RETURN END SUBROUTINE MUMPS_AB_LMAT_FILL_BUFFER SUBROUTINE MUMPS_AB_GATHER_GRAPH ( & ICNTL, KEEP, COMM, MYID, NPROCS, INFO, & GCOMP_DIST, GCOMP) USE MUMPS_ANA_BLK_M, ONLY : COMPACT_GRAPH_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) TYPE(COMPACT_GRAPH_T), INTENT(IN) :: GCOMP_DIST INTEGER, INTENT(IN) :: MYID, NPROCS, ICNTL(60), COMM, & KEEP(500) INTEGER, INTENT(INOUT) :: INFO(80) TYPE(COMPACT_GRAPH_T) :: GCOMP INTEGER :: NG, allocok, LP, MPG, I, J, K, PI INTEGER :: INDX, NB_BLOCK_SENT, MAX_NBBLOCK_loc, NRECV, & BLOCKSIZE, SIZE_SENT, NB_BLOCKS, NBBLOCK_loc INTEGER :: JFIRST_GDIST, JLAST_GDIST, NG_LOCAL_GDIST, & NBNONEMPTY_PI INTEGER(4) :: IOVFLO INTEGER(8) :: NZG, NZG_CENT, I8, IBEG8, IEND8, & SIZEGCOMPALLOCATED LOGICAL :: LPOK, PROKG INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IQ INTEGER, ALLOCATABLE :: REQPTR(:) INTEGER(8), ALLOCATABLE :: GPTR(:), GPTR_cp(:) LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MPG = ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. MYID .eq. MASTER ) PROKG = (PROKG.AND.(ICNTL(4).GE.2)) IOVFLO = huge(IOVFLO) BLOCKSIZE = int(max(100000_8,int(IOVFLO,8)/200_8)) NZG = GCOMP_DIST%NZG NG = GCOMP_DIST%NG JFIRST_GDIST = GCOMP_DIST%FIRST JLAST_GDIST = GCOMP_DIST%LAST NG_LOCAL_GDIST = JLAST_GDIST - JFIRST_GDIST + 1 CALL MPI_REDUCE( NZG, NZG_CENT, 1, MPI_INTEGER8, & MPI_SUM, MASTER, COMM, IERR ) IF (MYID.EQ.MASTER) THEN GCOMP%NZG = NZG_CENT GCOMP%NG = NG GCOMP%FIRST = 1 GCOMP%LAST = NG SIZEGCOMPALLOCATED = NZG_CENT+int(NG,8)+1_8 GCOMP%SIZEADJALLOCATED = SIZEGCOMPALLOCATED ALLOCATE( GCOMP%ADJ(SIZEGCOMPALLOCATED), & GCOMP%IPE(NG+1), & GPTR( NPROCS ), & GPTR_cp( NPROCS ), & REQPTR( NPROCS-1 ), & IQ(NG+1),STAT=allocok) IF (allocok.NE.0) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR( & NZG_CENT + 3_8*int(NG,8)+3_8+3_8*int(NPROCS,8)-1_8, & INFO(2)) IF ( LPOK ) & WRITE(LP, *) " ERROR allocating graph in", & " MUMPS_AB_GATHER_GRAPH" ENDIF ELSE ALLOCATE( IQ(NG_LOCAL_GDIST), STAT=allocok) IF (allocok.NE.0) THEN INFO( 1 ) = -7 INFO( 2 ) = NG+1 IF ( LPOK ) & WRITE(LP, *) " ERROR allocating pointers", & " MUMPS_AB_GATHER_GRAPH" END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF (INFO(1).LT.0) GOTO 500 DO I=1,NG_LOCAL_GDIST IQ(I) = int(GCOMP_DIST%IPE(I+1)-GCOMP_DIST%IPE(I)) ENDDO IF (MYID.EQ.MASTER) THEN DO J=1, NG GCOMP%IPE(J) = 0 ENDDO IF (NG_LOCAL_GDIST.GT.0) THEN DO J=1, NG_LOCAL_GDIST GCOMP%IPE(J+JFIRST_GDIST-1) = IQ(J) ENDDO ENDIF DO PI = 1, NPROCS - 1 CALL MPI_RECV( NBNONEMPTY_PI, 1, & MPI_INTEGER, PI, & GATHERG_NB, COMM, STATUS, IERR ) IF (NBNONEMPTY_PI.GT.0) THEN CALL MPI_RECV( J, 1, & MPI_INTEGER, PI, & GATHERG_FIRST, COMM, STATUS, IERR ) CALL MPI_RECV( GCOMP%IPE(J), NBNONEMPTY_PI, & MPI_INTEGER8, PI, & GATHERG_IPE, COMM, STATUS, IERR ) ENDIF ENDDO ELSE CALL MPI_SEND( NG_LOCAL_GDIST, 1, MPI_INTEGER, MASTER, & GATHERG_NB, COMM, IERR ) IF (NG_LOCAL_GDIST.GT.0) THEN CALL MPI_SEND( JFIRST_GDIST, 1, MPI_INTEGER, MASTER, & GATHERG_FIRST, COMM, IERR ) CALL MPI_SEND( IQ(1), NG_LOCAL_GDIST, & MPI_INTEGER8, MASTER, & GATHERG_IPE, COMM, IERR ) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IQ(1) = 1_8 DO I=1,NG IQ(I+1) = IQ(I) + GCOMP%IPE(I) GCOMP%IPE(I) = IQ(I) ENDDO GCOMP%IPE(NG+1) = IQ(NG+1) DEALLOCATE(IQ) ELSE DEALLOCATE(IQ) ENDIF IF (MYID.EQ.MASTER) THEN NB_BLOCK_SENT = 0 MAX_NBBLOCK_loc = 0 DO I = 1, NPROCS - 1 CALL MPI_RECV( GPTR( I+1 ), 1, & MPI_INTEGER8, I, & GATHERG_NZG, COMM, STATUS, IERR ) NBBLOCK_loc = ceiling(dble(GPTR(I+1))/dble(BLOCKSIZE)) MAX_NBBLOCK_loc = max(MAX_NBBLOCK_loc, NBBLOCK_loc) NB_BLOCK_SENT = NB_BLOCK_SENT + NBBLOCK_loc ENDDO GPTR( 1 ) = NZG + 1_8 DO I = 2, NPROCS GPTR( I ) = GPTR( I ) + GPTR( I-1 ) END DO ELSE CALL MPI_SEND( NZG, 1, MPI_INTEGER8, MASTER, & GATHERG_NZG, COMM, IERR ) ENDIF IF (MYID.EQ.MASTER) THEN DO I=1, NPROCS GPTR_cp(I) = GPTR(I) ENDDO IF (NZG.GT.0_8) THEN DO I8=1, NZG GCOMP%ADJ(I8) = GCOMP_DIST%ADJ(I8) ENDDO ENDIF NB_BLOCKS = 0 DO K = 1, MAX_NBBLOCK_loc NRECV = 0 DO I = 1, NPROCS - 1 IBEG8 = GPTR_cp( I ) IF ( IBEG8 .LT. GPTR(I+1)) THEN NRECV = NRECV + 1 IEND8 = min(IBEG8+int(BLOCKSIZE,8)-1_8, & GPTR(I+1)-1_8) GPTR_cp( I ) = IEND8 + 1_8 SIZE_SENT = int(IEND8 - IBEG8 + 1_8) NB_BLOCKS = NB_BLOCKS + 1 CALL MPI_IRECV( GCOMP%ADJ(IBEG8), SIZE_SENT, & MPI_INTEGER, & I, GATHERG_ADJ, COMM, REQPTR(I), IERR ) ELSE REQPTR( I ) = MPI_REQUEST_NULL ENDIF END DO DO I = 1, NRECV CALL MPI_WAITANY & ( NPROCS-1, REQPTR, INDX, & STATUS, IERR ) ENDDO END DO DEALLOCATE( REQPTR ) DEALLOCATE( GPTR ) DEALLOCATE( GPTR_cp ) ELSE IF (NZG.EQ.0) GOTO 600 DO I8=1_8, NZG, int(BLOCKSIZE,8) SIZE_SENT = BLOCKSIZE IF (NZG-I8+1_8.LT.int(BLOCKSIZE,8)) THEN SIZE_SENT = int(NZG-I8+1_8) ENDIF CALL MPI_SEND( & GCOMP_DIST%ADJ(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & GATHERG_ADJ, COMM, IERR ) ENDDO ENDIF GOTO 600 500 CONTINUE IF (MYID.EQ.MASTER) THEN IF (associated(GCOMP%ADJ)) THEN DEALLOCATE(GCOMP%ADJ) nullify(GCOMP%ADJ) ENDIF IF (associated(GCOMP%IPE)) THEN DEALLOCATE(GCOMP%IPE) nullify(GCOMP%IPE) ENDIF ENDIF 600 CONTINUE IF (allocated(IQ)) DEALLOCATE(IQ) RETURN END SUBROUTINE MUMPS_AB_GATHER_GRAPH MUMPS_5.8.1/src/cfac_type3_symmetrize.F0000664000175000017500000001364215042446440017655 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SYMMETRIZE( BUF, BLOCK_SIZE, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, COMM ) IMPLICIT NONE INTEGER BLOCK_SIZE, NPROW, NPCOL, LOCAL_M, LOCAL_N, N, COMM INTEGER MYROW, MYCOL, MYID COMPLEX BUF( BLOCK_SIZE * BLOCK_SIZE ) COMPLEX A( LOCAL_M, LOCAL_N ) INTEGER NBLOCK, IBLOCK, JBLOCK, IBLOCK_SIZE, JBLOCK_SIZE INTEGER ROW_SOURCE, ROW_DEST, COL_SOURCE, COL_DEST INTEGER IGLOB, JGLOB INTEGER IROW_LOC_SOURCE, JCOL_LOC_SOURCE INTEGER IROW_LOC_DEST, JCOL_LOC_DEST INTEGER PROC_SOURCE, PROC_DEST NBLOCK = ( N - 1 ) / BLOCK_SIZE + 1 DO IBLOCK = 1, NBLOCK IF ( IBLOCK .NE. NBLOCK & ) THEN IBLOCK_SIZE = BLOCK_SIZE ELSE IBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE END IF ROW_SOURCE = mod( IBLOCK - 1, NPROW ) COL_DEST = mod( IBLOCK - 1, NPCOL ) IGLOB = ( IBLOCK - 1 ) * BLOCK_SIZE + 1 IROW_LOC_SOURCE = BLOCK_SIZE * & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 JCOL_LOC_DEST = BLOCK_SIZE * & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 DO JBLOCK = 1, IBLOCK IF ( JBLOCK .NE. NBLOCK & ) THEN JBLOCK_SIZE = BLOCK_SIZE ELSE JBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE END IF COL_SOURCE = mod( JBLOCK - 1, NPCOL ) ROW_DEST = mod( JBLOCK - 1, NPROW ) PROC_SOURCE = ROW_SOURCE * NPCOL + COL_SOURCE PROC_DEST = ROW_DEST * NPCOL + COL_DEST IF ( PROC_SOURCE .eq. PROC_DEST ) THEN IF ( MYID .eq. PROC_DEST ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 JCOL_LOC_SOURCE = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 IROW_LOC_DEST = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 IF ( IBLOCK .eq. JBLOCK ) THEN IF ( IBLOCK_SIZE .ne. JBLOCK_SIZE ) THEN WRITE(*,*) MYID,': Error in calling transdiag:unsym' CALL MUMPS_ABORT() END IF CALL CMUMPS_TRANS_DIAG( A( IROW_LOC_SOURCE, & JCOL_LOC_SOURCE), & IBLOCK_SIZE, LOCAL_M ) ELSE CALL CMUMPS_TRANSPO( & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), & A( IROW_LOC_DEST, JCOL_LOC_DEST ), & IBLOCK_SIZE, JBLOCK_SIZE, LOCAL_M ) END IF END IF ELSE IF ( MYROW .eq. ROW_SOURCE & .AND. MYCOL .eq. COL_SOURCE ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 JCOL_LOC_SOURCE = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 CALL CMUMPS_SEND_BLOCK( BUF, & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), LOCAL_M, & IBLOCK_SIZE, JBLOCK_SIZE, COMM, PROC_DEST ) ELSE IF ( MYROW .eq. ROW_DEST & .AND. MYCOL .eq. COL_DEST ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 IROW_LOC_DEST = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 CALL CMUMPS_RECV_BLOCK( BUF, & A( IROW_LOC_DEST, JCOL_LOC_DEST ), LOCAL_M, & JBLOCK_SIZE, IBLOCK_SIZE, COMM, PROC_SOURCE ) END IF END DO END DO RETURN END SUBROUTINE CMUMPS_SYMMETRIZE SUBROUTINE CMUMPS_SEND_BLOCK( BUF, A, LDA, M, N, COMM, DEST ) IMPLICIT NONE INTEGER M, N, LDA, DEST, COMM COMPLEX BUF(*), A(LDA,*) INTEGER I, IBUF, IERR INTEGER J INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IBUF = 1 DO J = 1, N BUF( IBUF: IBUF + M - 1 ) = A( 1 : M, J ) DO I = 1, M END DO IBUF = IBUF + M END DO CALL MPI_SEND( BUF, M * N, MPI_COMPLEX, & DEST, SYMMETRIZE, COMM, IERR ) RETURN END SUBROUTINE CMUMPS_SEND_BLOCK SUBROUTINE CMUMPS_RECV_BLOCK( BUF, A, LDA, M, N, COMM, SOURCE ) IMPLICIT NONE INTEGER LDA, M, N, COMM, SOURCE COMPLEX BUF(*), A( LDA, *) INTEGER I, IBUF, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) CALL MPI_RECV( BUF(1), M * N, MPI_COMPLEX, SOURCE, & SYMMETRIZE, COMM, STATUS, IERR ) IBUF = 1 DO I = 1, M CALL ccopy( N, BUF(IBUF), 1, A(I,1), LDA ) IBUF = IBUF + N END DO RETURN END SUBROUTINE CMUMPS_RECV_BLOCK SUBROUTINE CMUMPS_TRANS_DIAG( A, N, LDA ) IMPLICIT NONE INTEGER N,LDA COMPLEX A( LDA, * ) INTEGER I, J DO I = 2, N DO J = 1, I - 1 A( J, I ) = A( I, J ) END DO END DO RETURN END SUBROUTINE CMUMPS_TRANS_DIAG SUBROUTINE CMUMPS_TRANSPO( A1, A2, M, N, LD ) IMPLICIT NONE INTEGER M,N,LD COMPLEX A1( LD,* ), A2( LD, * ) INTEGER I, J DO J = 1, N DO I = 1, M A2( J, I ) = A1( I, J ) END DO END DO RETURN END SUBROUTINE CMUMPS_TRANSPO MUMPS_5.8.1/src/zmumps_save_restore.F0000664000175000017500000127251315042446441017467 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if ! defined(NO_SAVE_RESTORE) MODULE ZMUMPS_SAVE_RESTORE USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_INTR_STRUC USE ZMUMPS_SAVE_RESTORE_FILES USE MUMPS_FRONT_DATA_MGT_M IMPLICIT NONE INCLUDE 'mumps_save_restore_modes.h' CONTAINS SUBROUTINE ZMUMPS_REMOVE_SAVED(id) USE ZMUMPS_OOC IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MASTER PARAMETER ( MASTER = 0 ) TYPE (ZMUMPS_STRUC) :: id CHARACTER(len=LEN_SAVE_FILE) :: RESTOREFILE, INFOFILE INTEGER :: fileunit, ierr, SIZE_INT, SIZE_INT8 INTEGER(8) :: size_read, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE INTEGER :: READ_OOC_FILE_NAME_LENGTH,READ_SYM,READ_PAR,READ_NPROCS CHARACTER(len=LEN_SAVE_FILE) :: READ_OOC_FIRST_FILE_NAME CHARACTER :: READ_ARITH LOGICAL :: READ_INT_TYPE_64 CHARACTER(len=23) :: READ_HASH LOGICAL :: FORTRAN_VERSION_OK LOGICAL :: SAME_OOC INTEGER :: ICNTL34, MAX_LENGTH, FLAG_SAME, SUM_FLAG_SAME TYPE (ZMUMPS_STRUC) :: localid ierr = 0 call ZMUMPS_GET_SAVE_FILES(id,RESTOREFILE,INFOFILE) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(fileunit) IF ( fileunit .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=fileunit,FILE=RESTOREFILE #if ! defined(MUMPS_NOF2003) & ,ACCESS="stream" #endif & ,STATUS='old',FORM='unformatted',IOSTAT=ierr) IF ( ierr.ne.0 ) THEN id%INFO(1) = -76 id%INFO(2) = id%MYID endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_INT = id%KEEP(34) SIZE_INT8 = id%KEEP(34)*id%KEEP(10) size_read = 0_8 call MUMPS_READ_HEADER(fileunit,ierr,size_read,SIZE_INT, & SIZE_INT8, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE, & READ_ARITH, READ_INT_TYPE_64, & READ_OOC_FILE_NAME_LENGTH, READ_OOC_FIRST_FILE_NAME, & READ_HASH,READ_SYM,READ_PAR,READ_NPROCS, & FORTRAN_VERSION_OK) close(fileunit) if (ierr.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) elseif (.NOT.FORTRAN_VERSION_OK) THEN id%INFO(1) = -73 id%INFO(2) = 1 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL ZMUMPS_CHECK_HEADER(id,.TRUE.,READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) IF ( id%INFO(1) .LT. 0 ) RETURN ICNTL34 = -99998 IF (id%MYID.EQ.MASTER) THEN ICNTL34 = id%ICNTL(34) ENDIF CALL MPI_BCAST( ICNTL34, 1, MPI_INTEGER, MASTER, id%COMM, ierr ) CALL MPI_BCAST( READ_SYM, 1, MPI_INTEGER, MASTER, id%COMM, ierr ) CALL ZMUMPS_CHECK_FILE_NAME(id, READ_OOC_FILE_NAME_LENGTH, & READ_OOC_FIRST_FILE_NAME, SAME_OOC) CALL MPI_ALLREDUCE(READ_OOC_FILE_NAME_LENGTH,MAX_LENGTH,1, & MPI_INTEGER,MPI_MAX,id%COMM,ierr) IF (MAX_LENGTH.NE.-999) THEN FLAG_SAME = 0 IF (SAME_OOC) THEN FLAG_SAME = 1 ENDIF CALL MPI_ALLREDUCE(FLAG_SAME,SUM_FLAG_SAME,1, & MPI_INTEGER,MPI_SUM,id%COMM,ierr) IF (SUM_FLAG_SAME.NE.0) THEN IF (ICNTL34 .EQ. 1) THEN id%ASSOCIATED_OOC_FILES = .TRUE. ELSE id%ASSOCIATED_OOC_FILES = .FALSE. ENDIF ELSE IF (ICNTL34 .NE. 1) THEN localid%COMM = id%COMM localid%INFO(1) = 0 localid%ICNTL(1) = id%ICNTL(1) localid%MYID = id%MYID localid%NPROCS = id%NPROCS localid%KEEP(10) = id%KEEP(10) localid%SAVE_PREFIX = id%SAVE_PREFIX localid%SAVE_DIR = id%SAVE_DIR call ZMUMPS_RESTORE_OOC(localid) IF ( localid%INFO(1) .EQ. 0 ) THEN localid%ASSOCIATED_OOC_FILES = .FALSE. IF (READ_OOC_FILE_NAME_LENGTH.NE.-999) THEN call ZMUMPS_OOC_CLEAN_FILES(localid,ierr) IF ( ierr.ne.0 ) THEN id%INFO(1) = -90 id%INFO(2) = id%MYID ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN ENDIF ENDIF ENDIF call MUMPS_CLEAN_SAVED_DATA(id%MYID,ierr,RESTOREFILE,INFOFILE) IF (ierr.eq.-79) THEN id%INFO(1) = -79 id%INFO(2) = 2 ELSE IF (ierr.ne.0) THEN id%INFO(1) = -76 id%INFO(2) = id%MYID ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) RETURN END SUBROUTINE ZMUMPS_REMOVE_SAVED SUBROUTINE ZMUMPS_RESTORE_OOC(localid) IMPLICIT NONE INCLUDE 'mpif.h' TYPE (ZMUMPS_STRUC) :: localid INTEGER::ierr,IN,NBVARIABLES,NBVARIABLES_ROOTC CHARACTER(len=LEN_SAVE_FILE):: restore_file_ooc,INFO_FILE INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOTC INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOTC INTEGER:: INFO1,INFO2,INFOG1,INFOG2,allocok INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE TYPE (ZMUMPS_INTR_STRUC) :: localidintr NBVARIABLES=194 NBVARIABLES_ROOTC=20 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOTC(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOTC(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL ZMUMPS_GET_SAVE_FILES(localid,restore_file_ooc,INFO_FILE) IF ( localid%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(IN) IF ( IN .EQ. -1 ) THEN localid%INFO(1) = -79 localid%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN open(UNIT=IN,FILE=restore_file_ooc #if ! defined(MUMPS_NOF2003) & ,ACCESS="stream" #endif & ,STATUS='old',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN localid%INFO(1) = -74 localid%INFO(2) = localid%MYID endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN CALL ZMUMPS_SAVE_RESTORE_STRUCTURE(localid,localidintr,IN & ,restore_ooc_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) CLOSE(IN) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOTC) deallocate(SIZE_GEST,SIZE_GEST_ROOTC) RETURN END SUBROUTINE ZMUMPS_RESTORE_OOC SUBROUTINE ZMUMPS_COMPUTE_MEMORY_SAVE(id,idintr, & TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE) IMPLICIT NONE INCLUDE 'mpif.h' TYPE (ZMUMPS_STRUC) :: id TYPE (ZMUMPS_INTR_STRUC) :: idintr INTEGER::NBVARIABLES,NBVARIABLES_ROOTC INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOTC INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOTC INTEGER :: INFO1,INFO2,INFOG1,INFOG2,allocok INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE NBVARIABLES=194 NBVARIABLES_ROOTC=20 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOTC(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOTC(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL ZMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,0,memory_save_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOTC) deallocate(SIZE_GEST,SIZE_GEST_ROOTC) RETURN END SUBROUTINE ZMUMPS_COMPUTE_MEMORY_SAVE SUBROUTINE ZMUMPS_SAVE(id,idintr) IMPLICIT NONE INCLUDE 'mpif.h' TYPE (ZMUMPS_STRUC) :: id TYPE (ZMUMPS_INTR_STRUC) :: idintr INTEGER::ierr,OUT,NBVARIABLES,NBVARIABLES_ROOTC,OUTINFO CHARACTER(len=LEN_SAVE_FILE):: SAVE_FILE,INFO_FILE LOGICAL:: SAVE_FILE_exist,INFO_FILE_exist INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOTC INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOTC INTEGER:: INFO1,INFO2,INFOG1,INFOG2,MPG INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: PROKG INTEGER :: I,J,K,H,allocok CHARACTER(len=1) :: TMP_OOC_NAMES(350) INFO1 = id%INFO(1) INFO2 = id%INFO(2) INFOG1 = id%INFO(1) INFOG2 = id%INFO(1) id%INFO(1)=0 id%INFO(2)=0 id%INFOG(1)=0 id%INFOG(2)=0 MPG= id%ICNTL(3) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. 0 ) NBVARIABLES=194 NBVARIABLES_ROOTC=20 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOTC(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOTC(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 TMP_OOC_NAMES(:)="?" CALL ZMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,0,memory_save_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) CALL ZMUMPS_GET_SAVE_FILES(id,SAVE_FILE,INFO_FILE) IF ( id%INFO(1) .LT. 0 ) RETURN inquire(FILE=SAVE_FILE, EXIST=SAVE_FILE_exist) IF(SAVE_FILE_exist) THEN id%INFO(1) = -70 id%INFO(2) = 0 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(OUT) IF ( OUT .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=OUT,FILE=SAVE_FILE #if ! defined(MUMPS_NOF2003) & ,ACCESS="stream" #endif & ,STATUS='new',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -71 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN inquire(FILE=INFO_FILE, EXIST=INFO_FILE_exist) IF(INFO_FILE_exist) THEN id%INFO(1) = -70 id%INFO(2) = 0 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(OUTINFO) IF ( OUTINFO .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=OUTINFO,FILE=INFO_FILE,STATUS='new',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -71 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL ZMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,OUT,save_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) if (id%INFO(1).EQ.0) then id%INFO(1)=INFO1 id%INFO(2)=INFO2 id%INFOG(1)=INFOG1 id%INFOG(2)=INFOG2 CLOSE(OUT) if(id%INFOG(1).NE.0) then if (PROKG) THEN write(MPG,*) "Warning: " & ,"saved instance has negative INFO(1):" & , id%INFOG(1) endif endif IF(PROKG) THEN write(MPG,*) "Save done successfully" IF(id%KEEP(201).EQ.1) THEN K=1 write(MPG,*) "The corresponding OOC files are:" DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(MPG,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF ENDIF write(OUTINFO,*) "Save done by ZMUMPS ", & trim(adjustl(id%VERSION_NUMBER)), & " after JOB=",id%KEEP(40)+456789, & " With SYM, PAR =",id%KEEP(50),id%KEEP(46) write(OUTINFO,*) "On ",id%NPROCS," processes" if((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ.0)) then write(OUTINFO,*) "with N, NNZ ", id%N, id%NNZ elseif((id%ICNTL(18).EQ.1).AND.(id%ICNTL(5).EQ. 0)) then write(OUTINFO,*) "with N, NNZ_loc=", id%N, id%NNZ_loc elseif((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ. 1)) then write(OUTINFO,*) "with N, NELT=", id%N, id%NELT endif IF(id%KEEP(10).EQ.1) THEN write(OUTINFO,*) "With a default integer size of 64 bits" ELSE write(OUTINFO,*) "With a default integer size of 32 bits" ENDIF #if defined(MUMPS_NOF2003) write(OUTINFO,*) "Using MUMPS_NOF2003" #endif write(OUTINFO,*) '' write(OUTINFO,*) "The corresponding save file is:" write(OUTINFO,*) trim(adjustl(SAVE_FILE)) write(OUTINFO,*) "of size",TOTAL_FILE_SIZE, " Bytes" IF(id%KEEP(201).EQ.1) THEN write(OUTINFO,*) '' write(OUTINFO,*) "The corresponding OOC files are:" K=1 DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(OUTINFO,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF CLOSE(OUTINFO) else CLOSE(OUT,STATUS='delete') CLOSE(OUTINFO,STATUS='delete') endif deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOTC) deallocate(SIZE_GEST,SIZE_GEST_ROOTC) if (id%KEEP(201) .GT. 0) THEN id%ASSOCIATED_OOC_FILES=.TRUE. ENDIF RETURN END SUBROUTINE ZMUMPS_SAVE SUBROUTINE ZMUMPS_RESTORE(id,idintr) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER::ierr,IN,NBVARIABLES,NBVARIABLES_ROOTC CHARACTER(len=LEN_SAVE_FILE):: restore_file,INFO_FILE INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOTC INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOTC INTEGER:: INFO1,INFO2,INFOG1,INFOG2,MPG,MP,JOB INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: PROKG INTEGER :: I,J,K,H,allocok CHARACTER(len=1) :: TMP_OOC_NAMES(350) TYPE (ZMUMPS_STRUC) :: id TYPE (ZMUMPS_INTR_STRUC) :: idintr NBVARIABLES=194 NBVARIABLES_ROOTC=20 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOTC(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOTC(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 TMP_OOC_NAMES(:)="?" INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL ZMUMPS_GET_SAVE_FILES(id,restore_file,INFO_FILE) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(IN) IF ( IN .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=IN,FILE=restore_file #if ! defined(MUMPS_NOF2003) & ,ACCESS="stream" #endif & ,STATUS='old',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -74 id%INFO(2) = id%MYID endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN MP= id%ICNTL(2) MPG= id%ICNTL(3) CALL ZMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,IN,restore_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. 0 ) if(id%INFO(1).EQ.0) then id%INFO(1)=INFO1 id%INFO(2)=INFO2 id%INFOG(1)=INFOG1 id%INFOG(2)=INFOG2 if(id%INFOG(1).NE.0) then write(MPG,*) "Warning: " & ,"restored instance has negative INFOG(1):" & , id%INFOG(1) endif if(MP.GT.0) then JOB=id%KEEP(40)+456789 write(MP,*) "Restore done successfully" write(MP,*) "From file ",trim(adjustl(restore_file)) if((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ.0)) then write(MP,*) "with JOB, N, NNZ ",JOB, id%N,id%NNZ elseif((id%ICNTL(18).EQ.1).AND.(id%ICNTL(5).EQ. 0)) then write(MP,*) "with JOB, N, NNZ_loc=", JOB, id%N, & id%NNZ_loc elseif((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ. 1)) then write(MP,*) "with JOB, N, NELT=", JOB, id%N, id%NELT endif endif IF(PROKG) THEN IF(id%KEEP(201).EQ.1) THEN K=1 write(MPG,*) "The corresponding OOC files are:" DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(MPG,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF ENDIF else idintr%root%gridinit_done=.FALSE. id%KEEP(140)=1 endif CLOSE(IN) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOTC) deallocate(SIZE_GEST,SIZE_GEST_ROOTC) if (id%KEEP(201) .GT. 0) THEN id%ASSOCIATED_OOC_FILES=.TRUE. ENDIF RETURN END SUBROUTINE ZMUMPS_RESTORE SUBROUTINE ZMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,unit,mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) USE ZMUMPS_FACSOL_L0OMP_M, ONLY : ZMUMPS_SAVE_RESTORE_L0FACARRAY USE ZMUMPS_LR_DATA_M, ONLY: ZMUMPS_SAVE_RESTORE_BLR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER, intent(in) ::unit,NBVARIABLES,NBVARIABLES_ROOTC INTEGER, intent(in) :: mode INTEGER(8),dimension(NBVARIABLES)::SIZE_VARIABLES INTEGER(8),dimension(NBVARIABLES_ROOTC)::SIZE_VARIABLES_ROOTC INTEGER,dimension(NBVARIABLES)::SIZE_GEST INTEGER,dimension(NBVARIABLES_ROOTC)::SIZE_GEST_ROOTC INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER:: INFO1,INFO2,INFOG1,INFOG2 INTEGER:: j,i1,i2,err,ierr CHARACTER :: ARITH,READ_ARITH INTEGER(8) :: size_written,gest_size,WRITTEN_STRUC_SIZE INTEGER:: SIZE_INT, SIZE_INT8, SIZE_RL_OR_DBL, SIZE_ARITH_DEP INTEGER:: SIZE_DOUBLE_PRECISION, SIZE_LOGICAL, SIZE_CHARACTER INTEGER:: READ_NPROCS, READ_PAR, READ_SYM INTEGER,dimension(NBVARIABLES)::NbRecords INTEGER,dimension(NBVARIABLES_ROOTC)::NbRecords_ROOTC INTEGER:: size_array1,size_array2,dummy,allocok INTEGER(8):: size_array_INT8_1,size_array_INT8_2 LOGICAL:: INT_TYPE_64, READ_INT_TYPE_64, CALL_SAVE_RESTORE_BLR INTEGER:: tot_NbRecords,NbSubRecords INTEGER(8):: size_read,size_allocated INTEGER(8),dimension(NBVARIABLES)::DIFF_SIZE_ALLOC_READ INTEGER(8),dimension(NBVARIABLES_ROOTC):: & DIFF_SIZE_ALLOC_READ_ROOTC INTEGER::READ_OOC_FILE_NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE):: READ_OOC_FIRST_FILE_NAME INTEGER,dimension(4)::OOC_INDICES CHARACTER(len=8) :: date CHARACTER(len=10) :: time CHARACTER(len=5) :: zone INTEGER,dimension(8):: values CHARACTER(len=23) :: hash,READ_HASH LOGICAL:: BASIC_CHECK LOGICAL :: FORTRAN_VERSION_OK CHARACTER(len=1) :: TMP_OOC_NAMES(350) INTEGER(8)::SIZE_VARIABLES_BLR,SIZE_VARIABLES_FRONT_DATA, & SIZE_VARIABLES_L0FAC INTEGER :: SIZE_GEST_ROOTA INTEGER(8) :: SIZE_VARIABLES_ROOTA INTEGER::SIZE_GEST_BLR,SIZE_GEST_FRONT_DATA,SIZE_GEST_L0FAC INTEGER :: KEEP410_SAVE, KEEP411_SAVE INTEGER(8) :: KEEP883_SAVE, KEEP884_SAVE INTEGER(4) :: I4 LOGICAL :: IS_SYMMETRIC TYPE (ZMUMPS_STRUC) :: id TYPE (ZMUMPS_INTR_STRUC) :: idintr INTEGER, PARAMETER :: S_ASSOCIATED_OOC_FILES=194 INTEGER, PARAMETER :: S_pad16=193 INTEGER, PARAMETER :: S_Deficiency=192 INTEGER, PARAMETER :: S_NB_SINGULAR_VALUES=191 INTEGER, PARAMETER :: S_SINGULAR_VALUES=190 INTEGER, PARAMETER :: S_MTKO_PROCS_MAP=189 INTEGER, PARAMETER :: S_L0_OMP_MAPPING=188 INTEGER, PARAMETER :: S_PTR_LEAFS_L0_OMP=187 INTEGER, PARAMETER :: S_PERM_L0_OMP=186 INTEGER, PARAMETER :: S_VIRT_L0_OMP_MAPPING=185 INTEGER, PARAMETER :: S_VIRT_L0_OMP=184 INTEGER, PARAMETER :: S_PHYS_L0_OMP=183 INTEGER, PARAMETER :: S_IPOOL_A_L0_OMP=182 INTEGER, PARAMETER :: S_IPOOL_B_L0_OMP=181 INTEGER, PARAMETER :: S_I8_L0_OMP=180 INTEGER, PARAMETER :: S_I4_L0_OMP=179 INTEGER, PARAMETER :: S_THREAD_LA=178 INTEGER, PARAMETER :: S_LL0_OMP_FACTORS=177 INTEGER, PARAMETER :: S_LL0_OMP_MAPPING=176 INTEGER, PARAMETER :: S_L_VIRT_L0_OMP=175 INTEGER, PARAMETER :: S_L_PHYS_L0_OMP=174 INTEGER, PARAMETER :: S_LPOOL_B_L0_OMP=173 INTEGER, PARAMETER :: S_LPOOL_A_L0_OMP=172 INTEGER, PARAMETER :: S_BLRARRAY_ENCODING=171 INTEGER, PARAMETER :: S_FDM_F_ENCODING=170 INTEGER, PARAMETER :: S_pad13=169 INTEGER, PARAMETER :: S_NBGRP=168 INTEGER, PARAMETER :: S_LRGROUPS=167 INTEGER, PARAMETER :: S_INTR_ENCODING=166 INTEGER, PARAMETER :: S_WORKING=165 INTEGER, PARAMETER :: S_IPTR_WORKING=164 INTEGER, PARAMETER :: S_pad14=163 INTEGER, PARAMETER :: S_SUP_PROC=162 INTEGER, PARAMETER :: S_PIVNUL_LIST=161 INTEGER, PARAMETER :: S_OOC_FILE_NAMES=160 INTEGER, PARAMETER :: S_OOC_FILE_NAME_LENGTH=159 INTEGER, PARAMETER :: S_pad12=158 INTEGER, PARAMETER :: S_OOC_NB_FILE_TYPE=157 INTEGER, PARAMETER :: S_OOC_NB_FILES=156 INTEGER, PARAMETER :: S_OOC_TOTAL_NB_NODES=155 INTEGER, PARAMETER :: S_OOC_VADDR=154 INTEGER, PARAMETER :: S_OOC_SIZE_OF_BLOCK=153 INTEGER, PARAMETER :: S_OOC_INODE_SEQUENCE=152 INTEGER, PARAMETER :: S_OOC_MAX_NB_NODES_FOR_ZONE=151 INTEGER, PARAMETER :: S_INSTANCE_NUMBER=150 INTEGER, PARAMETER :: S_CB_SON_SIZE=149 INTEGER, PARAMETER :: S_DKEEP=148 INTEGER, PARAMETER :: S_LWK_USER=147 INTEGER, PARAMETER :: S_NBSA_LOCAL=146 INTEGER, PARAMETER :: S_WK_USER=145 INTEGER, PARAMETER :: S_CROIX_MANU=144 INTEGER, PARAMETER :: S_SCHED_SBTR=143 INTEGER, PARAMETER :: S_SCHED_GRP=142 INTEGER, PARAMETER :: S_SCHED_DEP=141 INTEGER, PARAMETER :: S_SBTR_ID=140 INTEGER, PARAMETER :: S_DEPTH_FIRST_SEQ=139 INTEGER, PARAMETER :: S_DEPTH_FIRST=138 INTEGER, PARAMETER :: S_MY_NB_LEAF=137 INTEGER, PARAMETER :: S_MY_FIRST_LEAF=136 INTEGER, PARAMETER :: S_MY_ROOT_SBTR=135 INTEGER, PARAMETER :: S_COST_TRAV=134 INTEGER, PARAMETER :: S_MEM_SUBTREE=133 INTEGER, PARAMETER :: S_RHSINTR=132 INTEGER, PARAMETER :: S_GLOB2LOC_SOL=131 INTEGER, PARAMETER :: S_pad11=130 INTEGER, PARAMETER :: S_GLOB2LOC_SOL_ALLOC=129 INTEGER, PARAMETER :: S_GLOB2LOC_RHS=128 INTEGER, PARAMETER :: S_MEM_DIST=127 INTEGER, PARAMETER :: S_I_AM_CAND=126 INTEGER, PARAMETER :: S_TAB_POS_IN_PERE=125 INTEGER, PARAMETER :: S_FUTURE_NIV2=124 INTEGER, PARAMETER :: S_ISTEP_TO_INIV2=123 INTEGER, PARAMETER :: S_CANDIDATES=122 INTEGER, PARAMETER :: S_ELTPROC=121 INTEGER, PARAMETER :: S_LELTVAR=120 INTEGER, PARAMETER :: S_NELT_loc=119 INTEGER, PARAMETER :: S_PROCNODE=118 INTEGER, PARAMETER :: S_LPS=117 INTEGER, PARAMETER :: S_S=116 INTEGER, PARAMETER :: S_PTRFAC=115 INTEGER, PARAMETER :: S_PTLUST_S=114 INTEGER, PARAMETER :: S_Step2node=113 INTEGER, PARAMETER :: S_PROCNODE_STEPS=112 INTEGER, PARAMETER :: S_NA=111 INTEGER, PARAMETER :: S_PTRDEBARR=110 INTEGER, PARAMETER :: S_NINROWARR=109 INTEGER, PARAMETER :: S_NINCOLARR=108 INTEGER, PARAMETER :: S_PTR8ARR=107 INTEGER, PARAMETER :: S_PTRAR=106 INTEGER, PARAMETER :: S_FRTELT=105 INTEGER, PARAMETER :: S_FRTPTR=104 INTEGER, PARAMETER :: S_FILS=103 INTEGER, PARAMETER :: S_DAD_STEPS=102 INTEGER, PARAMETER :: S_FRERE_STEPS=101 INTEGER, PARAMETER :: S_ND_STEPS=100 INTEGER, PARAMETER :: S_NE_STEPS=99 INTEGER, PARAMETER :: S_STEP=98 INTEGER, PARAMETER :: S_NBSA=97 INTEGER, PARAMETER :: S_LNA=96 INTEGER, PARAMETER :: S_KEEP=95 INTEGER, PARAMETER :: S_IS=94 INTEGER, PARAMETER :: S_ASS_IRECV=93 INTEGER, PARAMETER :: S_NSLAVES=92 INTEGER, PARAMETER :: S_NPROCS=91 INTEGER, PARAMETER :: S_MYID=90 INTEGER, PARAMETER :: S_COMM_LOAD=89 INTEGER, PARAMETER :: S_MYID_NODES=88 INTEGER, PARAMETER :: S_COMM_NODES=87 INTEGER, PARAMETER :: S_INST_Number=86 INTEGER, PARAMETER :: S_MAX_SURF_MASTER=85 INTEGER, PARAMETER :: S_KEEP8=84 INTEGER, PARAMETER :: S_pad7=83 INTEGER, PARAMETER :: S_SAVE_PREFIX=82 INTEGER, PARAMETER :: S_SAVE_DIR=81 INTEGER, PARAMETER :: S_WRITE_PROBLEM=80 INTEGER, PARAMETER :: S_OOC_PREFIX=79 INTEGER, PARAMETER :: S_OOC_TMPDIR=78 INTEGER, PARAMETER :: S_VERSION_NUMBER=77 INTEGER, PARAMETER :: S_MAPPING=76 INTEGER, PARAMETER :: S_LISTVAR_SCHUR=75 INTEGER, PARAMETER :: S_SCHUR_CINTERFACE=74 INTEGER, PARAMETER :: S_SCHUR=73 INTEGER, PARAMETER :: S_SIZE_SCHUR=72 INTEGER, PARAMETER :: S_SCHUR_LLD=71 INTEGER, PARAMETER :: S_SCHUR_NLOC=70 INTEGER, PARAMETER :: S_SCHUR_MLOC=69 INTEGER, PARAMETER :: S_NBLOCK=68 INTEGER, PARAMETER :: S_MBLOCK=67 INTEGER, PARAMETER :: S_NPCOL=66 INTEGER, PARAMETER :: S_NPROW=65 INTEGER, PARAMETER :: S_UNS_PERM=64 INTEGER, PARAMETER :: S_SYM_PERM=63 INTEGER, PARAMETER :: S_METIS_OPTIONS=62 INTEGER, PARAMETER :: S_RINFOG=61 INTEGER, PARAMETER :: S_RINFO=60 INTEGER, PARAMETER :: S_CNTL=59 INTEGER, PARAMETER :: S_COST_SUBTREES=58 INTEGER, PARAMETER :: S_INFOG=57 INTEGER, PARAMETER :: S_INFO=56 INTEGER, PARAMETER :: S_ICNTL=55 INTEGER, PARAMETER :: S_pad6=54 INTEGER, PARAMETER :: S_LD_RHSINTR=53 INTEGER, PARAMETER :: S_NSOL_loc=52 INTEGER, PARAMETER :: S_LSOL_loc=51 INTEGER, PARAMETER :: S_LREDRHS=50 INTEGER, PARAMETER :: S_LRHS_loc=49 INTEGER, PARAMETER :: S_Nloc_RHS=48 INTEGER, PARAMETER :: S_NZ_RHS=47 INTEGER, PARAMETER :: S_NRHS=46 INTEGER, PARAMETER :: S_LRHS=45 INTEGER, PARAMETER :: S_IRHS_loc=44 INTEGER, PARAMETER :: S_ISOL_loc=43 INTEGER, PARAMETER :: S_IRHS_PTR=42 INTEGER, PARAMETER :: S_IRHS_SPARSE=41 INTEGER, PARAMETER :: S_RHS_loc=40 INTEGER, PARAMETER :: S_SOL_loc=39 INTEGER, PARAMETER :: S_RHS_SPARSE=38 INTEGER, PARAMETER :: S_REDRHS=37 INTEGER, PARAMETER :: S_RHS=36 INTEGER, PARAMETER :: S_BLKVAR=35 INTEGER, PARAMETER :: S_BLKPTR=34 INTEGER, PARAMETER :: S_pad5=33 INTEGER, PARAMETER :: S_NBLK=32 INTEGER, PARAMETER :: S_PERM_IN=31 INTEGER, PARAMETER :: S_pad4=30 INTEGER, PARAMETER :: S_A_ELT=29 INTEGER, PARAMETER :: S_ELTVAR=28 INTEGER, PARAMETER :: S_ELTPTR=27 INTEGER, PARAMETER :: S_pad3=26 INTEGER, PARAMETER :: S_NELT=25 INTEGER, PARAMETER :: S_pad2=24 INTEGER, PARAMETER :: S_A_loc=23 INTEGER, PARAMETER :: S_JCN_loc=22 INTEGER, PARAMETER :: S_IRN_loc=21 INTEGER, PARAMETER :: S_NNZ_loc=20 INTEGER, PARAMETER :: S_pad1=19 INTEGER, PARAMETER :: S_NZ_loc=18 INTEGER, PARAMETER :: S_PIVOTS=17 INTEGER, PARAMETER :: S_COLIND=16 INTEGER, PARAMETER :: S_ROWIND=15 INTEGER, PARAMETER :: S_ROWSCA_loc=14 INTEGER, PARAMETER :: S_COLSCA_loc=13 INTEGER, PARAMETER :: S_ROWSCA=12 INTEGER, PARAMETER :: S_COLSCA=11 INTEGER, PARAMETER :: S_JCN=10 INTEGER, PARAMETER :: S_IRN=9 INTEGER, PARAMETER :: S_A=8 INTEGER, PARAMETER :: S_NNZ=7 INTEGER, PARAMETER :: S_NZ=6 INTEGER, PARAMETER :: S_N=5 INTEGER, PARAMETER :: S_JOB=4 INTEGER, PARAMETER :: S_PAR=3 INTEGER, PARAMETER :: S_SYM=2 INTEGER, PARAMETER :: S_COMM=1 INTEGER, PARAMETER :: R_gridinit_done=20 INTEGER, PARAMETER :: R_yes=19 INTEGER, PARAMETER :: R_RG2L=18 INTEGER, PARAMETER :: R_IPIV=17 INTEGER, PARAMETER :: R_NB_SINGULAR_VALUES=16 INTEGER, PARAMETER :: R_LPIV=15 INTEGER, PARAMETER :: R_CNTXT_BLACS=14 INTEGER, PARAMETER :: R_DESCRIPTOR=13 INTEGER, PARAMETER :: R_TOT_ROOT_SIZE=12 INTEGER, PARAMETER :: R_ROOT_SIZE=11 INTEGER, PARAMETER :: R_RHS_NLOC=10 INTEGER, PARAMETER :: R_SCHUR_LLD=9 INTEGER, PARAMETER :: R_SCHUR_NLOC=8 INTEGER, PARAMETER :: R_SCHUR_MLOC=7 INTEGER, PARAMETER :: R_MYCOL=6 INTEGER, PARAMETER :: R_MYROW=5 INTEGER, PARAMETER :: R_NPCOL=4 INTEGER, PARAMETER :: R_NPROW=3 INTEGER, PARAMETER :: R_NBLOCK=2 INTEGER, PARAMETER :: R_MBLOCK=1 OOC_INDICES=(/156,157,159,160/) SIZE_INT = id%KEEP(34) SIZE_INT8 = id%KEEP(34)*id%KEEP(10) SIZE_RL_OR_DBL = id%KEEP(150) SIZE_ARITH_DEP = id%KEEP(149) SIZE_DOUBLE_PRECISION = 8 SIZE_LOGICAL = 4 SIZE_CHARACTER = 1 size_written=int(0,kind=8) tot_NbRecords=0 NbRecords(:)=0 NbRecords_ROOTC(:)=0 size_read=int(0,kind=8) size_allocated=int(0,kind=8) DIFF_SIZE_ALLOC_READ(:)=0 DIFF_SIZE_ALLOC_READ_ROOTC(:)=0 WRITTEN_STRUC_SIZE=int(0,kind=8) TMP_OOC_NAMES(:)="?" SIZE_VARIABLES_BLR=0_8 SIZE_GEST_BLR=0 SIZE_VARIABLES_FRONT_DATA=0_8 SIZE_GEST_FRONT_DATA=0 SIZE_VARIABLES_L0FAC=0 SIZE_GEST_L0FAC=0 if(mode.EQ.memory_save_mode) then elseif(mode.EQ.save_mode) then write(unit,iostat=err) "MUMPS" if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(5*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(id%MYID.EQ.0) THEN call date_and_time(date,time,zone,values) hash=trim(date)//trim(time)//trim(zone) ENDIF CALL MPI_BCAST( hash, 23, MPI_CHARACTER, 0, id%COMM, ierr ) write(unit,iostat=err) hash if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(23*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(2*SIZE_INT8,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ARITH="ZMUMPS"(1:1) write(unit,iostat=err) ARITH if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(1,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) id%SYM,id%PAR,id%NPROCS if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(3*SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(id%KEEP(10).EQ.1) THEN INT_TYPE_64=.TRUE. ELSE INT_TYPE_64=.FALSE. ENDIF write(unit,iostat=err) INT_TYPE_64 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_LOGICAL,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(associated(id%OOC_FILE_NAME_LENGTH).AND. & associated(id%OOC_FILE_NAMES)) THEN write(unit,iostat=err) id%OOC_FILE_NAME_LENGTH(1) if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(1))= & id%OOC_FILE_NAMES(1,1:id%OOC_FILE_NAME_LENGTH(1)) write(unit,iostat=err) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(1)) if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written & +int(id%OOC_FILE_NAME_LENGTH(1)*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ELSE write(unit,iostat=err) -999 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) -999 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ENDIF elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then CALL MUMPS_READ_HEADER(unit,err,size_read,SIZE_INT,SIZE_INT8, & TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE, READ_ARITH, & READ_INT_TYPE_64, READ_OOC_FILE_NAME_LENGTH, & READ_OOC_FIRST_FILE_NAME,READ_HASH, & READ_SYM,READ_PAR,READ_NPROCS,FORTRAN_VERSION_OK) if (err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) elseif (.NOT.FORTRAN_VERSION_OK) THEN id%INFO(1) = -73 id%INFO(2) = 1 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 BASIC_CHECK = .false. IF (mode.EQ.restore_ooc_mode) THEN BASIC_CHECK = .true. ENDIF CALL ZMUMPS_CHECK_HEADER(id,BASIC_CHECK,READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) IF (id%INFO(1) .LT. 0) GOTO 100 elseif(mode.EQ.fake_restore_mode) then read(unit,iostat=err) READ_HASH if(err.ne.0) GOTO 100 read(unit,iostat=err) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(err.ne.0) GOTO 100 IF ( id%INFO(1) .LT. 0 ) GOTO 100 GOTO 200 else CALL MUMPS_ABORT() endif DO j=1,size(OOC_INDICES) i1=OOC_INDICES(j) SELECT CASE(i1) CASE(S_OOC_NB_FILES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_NB_FILES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%OOC_NB_FILES,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_NB_FILES)) THEN write(unit,iostat=err) size(id%OOC_NB_FILES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_NB_FILES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then nullify(id%OOC_NB_FILES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_NB_FILES(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_NB_FILES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_NB_FILE_TYPE) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%OOC_NB_FILE_TYPE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%OOC_NB_FILE_TYPE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_FILE_NAMES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_FILE_NAMES)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_FILE_NAMES,1) & *size(id%OOC_FILE_NAMES,2)*SIZE_CHARACTER ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_FILE_NAMES)) THEN write(unit,iostat=err) size(id%OOC_FILE_NAMES,1) & ,size(id%OOC_FILE_NAMES,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_FILE_NAMES ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then nullify(id%OOC_FILE_NAMES) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2 & *SIZE_CHARACTER allocate(id%OOC_FILE_NAMES(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_FILE_NAMES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_FILE_NAME_LENGTH) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_FILE_NAME_LENGTH)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%OOC_FILE_NAME_LENGTH,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_FILE_NAME_LENGTH)) THEN write(unit,iostat=err) size(id%OOC_FILE_NAME_LENGTH,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_FILE_NAME_LENGTH ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then nullify(id%OOC_FILE_NAME_LENGTH) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_FILE_NAME_LENGTH(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_FILE_NAME_LENGTH endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE DEFAULT END SELECT ENDDO if(mode.EQ.restore_ooc_mode) then goto 200 endif DO i1=1,NBVARIABLES SELECT CASE(i1) CASE(S_COMM) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_SYM) CALL MUMPS_SAVE_INT(id%SYM) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_PAR) CALL MUMPS_SAVE_INT(id%PAR) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_JOB) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_N) CALL MUMPS_SAVE_INT(id%N) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ICNTL) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%ICNTL,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%ICNTL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%ICNTL,1) read(unit,iostat=err) id%ICNTL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_INFO) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFO,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) INFO1,INFO2 & ,id%INFO(3:size(id%INFO,1)) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFO,1) read(unit,iostat=err) INFO1,INFO2 & ,id%INFO(3:size(id%INFO,1)) if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_INFOG) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFOG,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) INFOG1,INFOG2 & ,id%INFOG(3:size(id%INFOG,1)) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFOG,1) read(unit,iostat=err) INFOG1,INFOG2 & ,id%INFOG(3:size(id%INFOG,1)) if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_COST_SUBTREES) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%COST_SUBTREES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL read(unit,iostat=err) id%COST_SUBTREES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_CNTL) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%CNTL,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%CNTL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%CNTL,1) read(unit,iostat=err) id%CNTL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_RINFO) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFO,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%RINFO if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFO,1) read(unit,iostat=err) id%RINFO if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_RINFOG) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFOG,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%RINFOG if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFOG,1) read(unit,iostat=err) id%RINFOG if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_KEEP8) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8*size(id%KEEP8,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%KEEP8 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8*size(id%KEEP8,1) KEEP883_SAVE=id%KEEP8(83) KEEP884_SAVE=id%KEEP8(84) read(unit,iostat=err) id%KEEP8 id%KEEP8(83)=KEEP883_SAVE id%KEEP8(84)=KEEP884_SAVE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_KEEP) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%KEEP,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%KEEP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%KEEP,1) KEEP410_SAVE = id%KEEP(410) KEEP411_SAVE = id%KEEP(411) read(unit,iostat=err) id%KEEP id%KEEP(410) = KEEP410_SAVE id%KEEP(411) = KEEP411_SAVE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_DKEEP) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%DKEEP,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%DKEEP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%DKEEP,1) read(unit,iostat=err) id%DKEEP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NZ) CALL MUMPS_SAVE_INT(id%NZ) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NNZ) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%NNZ if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%NNZ if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_A) CASE(S_IRN) CASE(S_JCN) CASE(S_COLSCA) IF(id%KEEP(52).NE.-1) THEN CALL MUMPS_SAVERSTR_REALARRAY(id%COLSCA) ELSE ENDIF IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ROWSCA) IF(id%KEEP(52).NE.-1) THEN CALL MUMPS_SAVERSTR_REALARRAY(id%ROWSCA) ELSE ENDIF IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_COLSCA_loc) CALL MUMPS_SAVERSTR_REALARRAY(id%COLSCA_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ROWSCA_loc) IS_SYMMETRIC = .FALSE. IF (mode.EQ.memory_save_mode .OR. & mode.EQ.save_mode) THEN IS_SYMMETRIC = id%KEEP(50).EQ.1 .OR. & id%KEEP(50).EQ.2 ELSEIF (mode.EQ.restore_mode) THEN IS_SYMMETRIC = READ_SYM.EQ.1 .OR. & READ_SYM.EQ.2 ENDIF IF ( IS_SYMMETRIC ) THEN IF ( mode.EQ.restore_mode ) THEN id%ROWSCA_loc => id%COLSCA_loc ENDIF ELSE CALL MUMPS_SAVERSTR_REALARRAY(id%ROWSCA_loc) ENDIF IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NZ_loc) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%NZ_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NZ_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NNZ_loc) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%NNZ_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%NNZ_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_IRN_loc) CASE(S_JCN_loc) CASE(S_A_loc) CASE(S_NELT) CALL MUMPS_SAVE_INT(id%NELT) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NBLK) CALL MUMPS_SAVE_INT(id%NBLK) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ELTPTR) CASE(S_ELTVAR) CASE(S_A_ELT) CASE(S_PERM_IN) CASE(S_BLKPTR) CASE(S_BLKVAR) CASE(S_COLIND) CASE(S_PIVOTS) CASE(S_RHS) CASE(S_REDRHS) CASE(S_ROWIND) CASE(S_RHS_SPARSE) CASE(S_SOL_loc) CASE(S_RHS_loc) CASE(S_IRHS_SPARSE) CASE(S_IRHS_PTR) CASE(S_ISOL_loc) CASE(S_IRHS_loc) CASE(S_LRHS) CALL MUMPS_SAVE_INT(id%LRHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NRHS) CALL MUMPS_SAVE_INT(id%NRHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NZ_RHS) CALL MUMPS_SAVE_INT(id%NZ_RHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LRHS_loc) CALL MUMPS_SAVE_INT(id%LRHS_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_Nloc_RHS) CALL MUMPS_SAVE_INT(id%Nloc_RHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LD_RHSINTR) CALL MUMPS_SAVE_INT(id%LD_RHSINTR) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NSOL_loc) CALL MUMPS_SAVE_INT(id%NSOL_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LSOL_loc) CALL MUMPS_SAVE_INT(id%LSOL_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LREDRHS) CALL MUMPS_SAVE_INT(id%LREDRHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SYM_PERM) CALL ZMUMPS_SAVE_INT_SHPTR_ARRAY(id%SYM_PERM & ) IF (id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_UNS_PERM) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%UNS_PERM)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%UNS_PERM,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%UNS_PERM)) THEN write(unit,iostat=err) size(id%UNS_PERM,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%UNS_PERM ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%UNS_PERM) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%UNS_PERM(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%UNS_PERM endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NPROW) CALL MUMPS_SAVE_INT(id%NPROW) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NPCOL) CALL MUMPS_SAVE_INT(id%NPCOL) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_MBLOCK) CALL MUMPS_SAVE_INT(id%MBLOCK) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NBLOCK) CALL MUMPS_SAVE_INT(id%NBLOCK) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SCHUR_MLOC) CALL MUMPS_SAVE_INT(id%SCHUR_MLOC) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SCHUR_NLOC) CALL MUMPS_SAVE_INT(id%SCHUR_NLOC) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SCHUR_LLD) CALL MUMPS_SAVE_INT(id%SCHUR_LLD) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SIZE_SCHUR) CALL MUMPS_SAVE_INT(id%SIZE_SCHUR) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SCHUR) CASE(S_SCHUR_CINTERFACE) CASE(S_LISTVAR_SCHUR) CASE(S_MAPPING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MAPPING)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(28)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MAPPING)) THEN write(unit,iostat=err) id%KEEP8(28) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MAPPING ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MAPPING) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT+SIZE_INT8 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_INT allocate(id%MAPPING(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MAPPING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_VERSION_NUMBER) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%VERSION_NUMBER) & *SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%VERSION_NUMBER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%VERSION_NUMBER) & *SIZE_CHARACTER read(unit,iostat=err) id%VERSION_NUMBER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_TMPDIR) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%OOC_TMPDIR) & *SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%OOC_TMPDIR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%OOC_TMPDIR) & *SIZE_CHARACTER read(unit,iostat=err) id%OOC_TMPDIR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_PREFIX) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%OOC_PREFIX) & *SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%OOC_PREFIX if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=1 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%OOC_PREFIX) & *SIZE_CHARACTER read(unit,iostat=err) id%OOC_PREFIX if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_WRITE_PROBLEM) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%WRITE_PROBLEM) & *SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%WRITE_PROBLEM if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%WRITE_PROBLEM) & *SIZE_CHARACTER read(unit,iostat=err) id%WRITE_PROBLEM if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MAX_SURF_MASTER) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%MAX_SURF_MASTER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%MAX_SURF_MASTER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_INST_Number) CALL MUMPS_SAVE_INT(id%INST_Number) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_COMM_NODES) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_MYID_NODES) CALL MUMPS_SAVE_INT(id%MYID_NODES) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_COMM_LOAD) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_MYID) CALL MUMPS_SAVE_INT(id%MYID) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NPROCS) CALL MUMPS_SAVE_INT(id%NPROCS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NSLAVES) CALL MUMPS_SAVE_INT(id%NSLAVES) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ASS_IRECV) CALL MUMPS_SAVE_INT(id%ASS_IRECV) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_IS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%IS)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=id%KEEP(32)*SIZE_INT DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size(id%IS,1)-id%KEEP(32)) ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%IS)) THEN write(unit,iostat=err) size(id%IS,1),id%KEEP(32) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IS(1:id%KEEP(32)) DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size(id%IS,1)-id%KEEP(32)) ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%IS) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array2*SIZE_INT DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size_array1-size_array2) allocate(id%IS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IS(1:size_array2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_Deficiency) CALL MUMPS_SAVE_INT(id%Deficiency) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LNA) CALL MUMPS_SAVE_INT(id%LNA) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NBSA) CALL MUMPS_SAVE_INT(id%NBSA) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_STEP) CALL ZMUMPS_SAVE_INT_SHPTR_ARRAY(id%STEP & ) IF (id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_NE_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%NE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%NE_STEPS)) THEN write(unit,iostat=err) size(id%NE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%NE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%NE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_ND_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%ND_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ND_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%ND_STEPS)) THEN write(unit,iostat=err) size(id%ND_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ND_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%ND_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ND_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ND_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_Step2node) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%Step2node)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%Step2node,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%Step2node)) THEN write(unit,iostat=err) size(id%Step2node,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%Step2node ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%Step2node) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%Step2node(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%Step2node endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FRERE_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%FRERE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRERE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FRERE_STEPS)) THEN write(unit,iostat=err) size(id%FRERE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FRERE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FRERE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRERE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRERE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_DAD_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%DAD_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DAD_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%DAD_STEPS)) THEN write(unit,iostat=err) size(id%DAD_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DAD_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%DAD_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DAD_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DAD_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FILS) CALL ZMUMPS_SAVE_INT_SHPTR_ARRAY(id%FILS & ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_PTR8ARR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTR8ARR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTR8ARR,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTR8ARR)) THEN write(unit,iostat=err) size(id%PTR8ARR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTR8ARR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=2 elseif(mode.EQ.restore_mode) then nullify(id%PTR8ARR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTR8ARR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTR8ARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NINCOLARR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then NbRecords(i1)=2 IF(associated(id%NINCOLARR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NINCOLARR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%NINCOLARR)) THEN write(unit,iostat=err) size(id%NINCOLARR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%NINCOLARR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%NINCOLARR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NINCOLARR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NINCOLARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NINROWARR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then NbRecords(i1)=2 IF(associated(id%NINROWARR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NINROWARR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%NINROWARR)) THEN write(unit,iostat=err) size(id%NINROWARR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%NINROWARR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%NINROWARR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NINROWARR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NINROWARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTRDEBARR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then NbRecords(i1)=2 IF(associated(id%PTRDEBARR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRDEBARR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTRDEBARR)) THEN write(unit,iostat=err) size(id%PTRDEBARR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTRDEBARR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PTRDEBARR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PTRDEBARR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRDEBARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTRAR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTRAR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRAR,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTRAR)) THEN write(unit,iostat=err) size(id%PTRAR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTRAR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=2 elseif(mode.EQ.restore_mode) then nullify(id%PTRAR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTRAR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRAR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FRTPTR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%FRTPTR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRTPTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FRTPTR)) THEN write(unit,iostat=err) size(id%FRTPTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FRTPTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FRTPTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRTPTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRTPTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FRTELT) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%FRTELT)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRTELT,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FRTELT)) THEN write(unit,iostat=err) size(id%FRTELT,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%FRTELT ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FRTELT) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRTELT(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRTELT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NA) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%NA)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NA,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%NA)) THEN write(unit,iostat=err) size(id%NA,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%NA ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%NA) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NA(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NA endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PROCNODE_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then NbRecords(i1)=2 IF(associated(id%PROCNODE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PROCNODE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PROCNODE_STEPS)) THEN write(unit,iostat=err) size(id%PROCNODE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PROCNODE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PROCNODE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PROCNODE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PROCNODE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTLUST_S) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTLUST_S)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTLUST_S,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTLUST_S)) THEN write(unit,iostat=err) size(id%PTLUST_S,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTLUST_S ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PTLUST_S) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PTLUST_S(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTLUST_S endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTRFAC) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTRFAC)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRFAC,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTRFAC)) THEN write(unit,iostat=err) size(id%PTRFAC,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) id%PTRFAC ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PTRFAC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTRFAC(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRFAC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_S) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%S)) THEN SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=id%KEEP8(31)*SIZE_ARITH_DEP DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP*(id%KEEP8(23)-id%KEEP8(31)) ELSE SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%S)) THEN write(unit,iostat=err) id%KEEP8(23),id%KEEP8(31) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%S(1:id%KEEP8(31)) DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP*(id%KEEP8(23)-id%KEEP8(31)) ELSE write(unit,iostat=err) int(-999,kind=8) & ,int(-998,kind=8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%S) read(unit,iostat=err) size_array_INT8_1,size_array_INT8_2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,kind=8)) then SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=size_array_INT8_2*SIZE_ARITH_DEP DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP* & (size_array_INT8_1-size_array_INT8_2) allocate(id%S(1:size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%S(1:size_array_INT8_2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_LPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%LPS)) THEN SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=id%KEEP8(31)*SIZE_ARITH_DEP/2 DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP/2*(id%KEEP8(23)-id%KEEP8(31)) ELSE SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%LPS)) THEN write(unit,iostat=err) id%KEEP8(23),id%KEEP8(31) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%LPS(1:id%KEEP8(31)) DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP/2*(id%KEEP8(23)-id%KEEP8(31)) ELSE write(unit,iostat=err) int(-999,kind=8) & ,int(-998,kind=8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%LPS) read(unit,iostat=err) size_array_INT8_1,size_array_INT8_2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,kind=8)) then SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=size_array_INT8_2*SIZE_ARITH_DEP/2 DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP/2* & (size_array_INT8_1-size_array_INT8_2) allocate(id%LPS(1:size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%LPS(1:size_array_INT8_2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PROCNODE) CASE(S_NELT_loc) CALL MUMPS_SAVE_INT(id%NELT_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LELTVAR) CALL MUMPS_SAVE_INT(id%LELTVAR) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ELTPROC) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%ELTPROC)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ELTPROC,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%ELTPROC)) THEN write(unit,iostat=err) size(id%ELTPROC,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ELTPROC ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%ELTPROC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ELTPROC(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ELTPROC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_I4_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%I4_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%I4_L0_OMP,1) & *size(id%I4_L0_OMP,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%I4_L0_OMP)) THEN write(unit,iostat=err) size(id%I4_L0_OMP,1) & ,size(id%I4_L0_OMP,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I4_L0_OMP ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%I4_L0_OMP) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%I4_L0_OMP(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%I4_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_I8_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%I8_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%I8_L0_OMP,1) & *size(id%I8_L0_OMP,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%I8_L0_OMP)) THEN write(unit,iostat=err) size(id%I8_L0_OMP,1) & ,size(id%I8_L0_OMP,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I8_L0_OMP ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%I8_L0_OMP) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%I8_L0_OMP(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%I8_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_CANDIDATES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%CANDIDATES)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%CANDIDATES,1) & *size(id%CANDIDATES,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%CANDIDATES)) THEN write(unit,iostat=err) size(id%CANDIDATES,1) & ,size(id%CANDIDATES,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%CANDIDATES ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%CANDIDATES) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%CANDIDATES(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%CANDIDATES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_ISTEP_TO_INIV2) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%ISTEP_TO_INIV2)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ISTEP_TO_INIV2,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%ISTEP_TO_INIV2)) THEN write(unit,iostat=err) size(id%ISTEP_TO_INIV2,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ISTEP_TO_INIV2 ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%ISTEP_TO_INIV2) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ISTEP_TO_INIV2(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ISTEP_TO_INIV2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FUTURE_NIV2) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%FUTURE_NIV2)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FUTURE_NIV2,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FUTURE_NIV2)) THEN write(unit,iostat=err) size(id%FUTURE_NIV2,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FUTURE_NIV2 ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FUTURE_NIV2) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FUTURE_NIV2(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FUTURE_NIV2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_TAB_POS_IN_PERE) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%TAB_POS_IN_PERE)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%TAB_POS_IN_PERE,1) & *size(id%TAB_POS_IN_PERE,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%TAB_POS_IN_PERE)) THEN write(unit,iostat=err) size(id%TAB_POS_IN_PERE,1) & ,size(id%TAB_POS_IN_PERE,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%TAB_POS_IN_PERE ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%TAB_POS_IN_PERE) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%TAB_POS_IN_PERE(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%TAB_POS_IN_PERE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_I_AM_CAND) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%I_AM_CAND)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%I_AM_CAND,1)*SIZE_LOGICAL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%I_AM_CAND)) THEN write(unit,iostat=err) size(id%I_AM_CAND,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I_AM_CAND ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%I_AM_CAND) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_LOGICAL allocate(id%I_AM_CAND(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%I_AM_CAND endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MEM_DIST) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MEM_DIST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MEM_DIST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MEM_DIST)) THEN write(unit,iostat=err) size(id%MEM_DIST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) id%MEM_DIST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MEM_DIST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MEM_DIST(0:size_array1-1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MEM_DIST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_GLOB2LOC_RHS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%GLOB2LOC_RHS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%GLOB2LOC_RHS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%GLOB2LOC_RHS)) THEN write(unit,iostat=err) size(id%GLOB2LOC_RHS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%GLOB2LOC_RHS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%GLOB2LOC_RHS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%GLOB2LOC_RHS(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%GLOB2LOC_RHS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_GLOB2LOC_SOL_ALLOC) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%GLOB2LOC_SOL_ALLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_LOGICAL read(unit,iostat=err) id%GLOB2LOC_SOL_ALLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_GLOB2LOC_SOL) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%GLOB2LOC_SOL)) THEN IF(id%GLOB2LOC_SOL_ALLOC) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%GLOB2LOC_SOL,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%GLOB2LOC_SOL)) THEN IF(id%GLOB2LOC_SOL_ALLOC) THEN write(unit,iostat=err) size(id%GLOB2LOC_SOL,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%GLOB2LOC_SOL ELSE write(unit,iostat=err) size(id%GLOB2LOC_SOL,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%GLOB2LOC_SOL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else if(id%GLOB2LOC_SOL_ALLOC) then SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%GLOB2LOC_SOL(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%GLOB2LOC_SOL else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy id%GLOB2LOC_SOL=>id%GLOB2LOC_RHS endif endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_RHSINTR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%RHSINTR)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(25)*SIZE_ARITH_DEP ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%RHSINTR)) THEN write(unit,iostat=err) id%KEEP8(25) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%RHSINTR ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%RHSINTR) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_ARITH_DEP allocate(id%RHSINTR(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%RHSINTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MEM_SUBTREE) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MEM_SUBTREE)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%MEM_SUBTREE,1)*SIZE_DOUBLE_PRECISION ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MEM_SUBTREE)) THEN write(unit,iostat=err) size(id%MEM_SUBTREE,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MEM_SUBTREE ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MEM_SUBTREE) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_DOUBLE_PRECISION allocate(id%MEM_SUBTREE(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MEM_SUBTREE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_COST_TRAV) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%COST_TRAV)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%COST_TRAV,1)*SIZE_DOUBLE_PRECISION ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%COST_TRAV)) THEN write(unit,iostat=err) size(id%COST_TRAV,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%COST_TRAV ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%COST_TRAV) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_DOUBLE_PRECISION allocate(id%COST_TRAV(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%COST_TRAV endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MY_ROOT_SBTR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MY_ROOT_SBTR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_ROOT_SBTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MY_ROOT_SBTR)) THEN write(unit,iostat=err) size(id%MY_ROOT_SBTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_ROOT_SBTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MY_ROOT_SBTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_ROOT_SBTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_ROOT_SBTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MY_FIRST_LEAF) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MY_FIRST_LEAF)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_FIRST_LEAF,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MY_FIRST_LEAF)) THEN write(unit,iostat=err) size(id%MY_FIRST_LEAF,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_FIRST_LEAF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MY_FIRST_LEAF) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_FIRST_LEAF(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_FIRST_LEAF endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MY_NB_LEAF) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MY_NB_LEAF)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_NB_LEAF,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MY_NB_LEAF)) THEN write(unit,iostat=err) size(id%MY_NB_LEAF,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_NB_LEAF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MY_NB_LEAF) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_NB_LEAF(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_NB_LEAF endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_DEPTH_FIRST) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%DEPTH_FIRST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DEPTH_FIRST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%DEPTH_FIRST)) THEN write(unit,iostat=err) size(id%DEPTH_FIRST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DEPTH_FIRST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%DEPTH_FIRST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DEPTH_FIRST(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DEPTH_FIRST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_DEPTH_FIRST_SEQ) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%DEPTH_FIRST_SEQ)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DEPTH_FIRST_SEQ,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%DEPTH_FIRST_SEQ)) THEN write(unit,iostat=err) size(id%DEPTH_FIRST_SEQ,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DEPTH_FIRST_SEQ ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%DEPTH_FIRST_SEQ) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DEPTH_FIRST_SEQ(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DEPTH_FIRST_SEQ endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SBTR_ID) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%SBTR_ID)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%SBTR_ID,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%SBTR_ID)) THEN write(unit,iostat=err) size(id%SBTR_ID,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%SBTR_ID ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%SBTR_ID) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%SBTR_ID(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%SBTR_ID endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SCHED_DEP) CASE(S_SCHED_GRP) CASE(S_CROIX_MANU) CASE(S_WK_USER) CASE(S_NBSA_LOCAL) CALL MUMPS_SAVE_INT(id%NBSA_LOCAL) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LWK_USER) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_CB_SON_SIZE) CASE(S_INSTANCE_NUMBER) CALL MUMPS_SAVE_INT(id%INSTANCE_NUMBER) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_OOC_MAX_NB_NODES_FOR_ZONE) CALL MUMPS_SAVE_INT(id%OOC_MAX_NB_NODES_FOR_ZONE) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_OOC_INODE_SEQUENCE) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_INODE_SEQUENCE)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_INODE_SEQUENCE,1) & *size(id%OOC_INODE_SEQUENCE,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_INODE_SEQUENCE)) THEN write(unit,iostat=err) size(id%OOC_INODE_SEQUENCE,1) & ,size(id%OOC_INODE_SEQUENCE,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_INODE_SEQUENCE ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%OOC_INODE_SEQUENCE) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%OOC_INODE_SEQUENCE(size_array1 & ,size_array2), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_INODE_SEQUENCE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_SIZE_OF_BLOCK) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_SIZE_OF_BLOCK)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_SIZE_OF_BLOCK,1) & *size(id%OOC_SIZE_OF_BLOCK,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_SIZE_OF_BLOCK)) THEN write(unit,iostat=err) size(id%OOC_SIZE_OF_BLOCK,1) & ,size(id%OOC_SIZE_OF_BLOCK,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_SIZE_OF_BLOCK ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%OOC_SIZE_OF_BLOCK) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%OOC_SIZE_OF_BLOCK(size_array1 & ,size_array2), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_SIZE_OF_BLOCK endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_VADDR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_VADDR)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_VADDR,1) & *size(id%OOC_VADDR,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_VADDR)) THEN write(unit,iostat=err) size(id%OOC_VADDR,1) & ,size(id%OOC_VADDR,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_VADDR ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%OOC_VADDR) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%OOC_VADDR(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_VADDR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_TOTAL_NB_NODES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_TOTAL_NB_NODES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%OOC_TOTAL_NB_NODES,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_TOTAL_NB_NODES)) THEN write(unit,iostat=err) size(id%OOC_TOTAL_NB_NODES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_TOTAL_NB_NODES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%OOC_TOTAL_NB_NODES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_TOTAL_NB_NODES(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_TOTAL_NB_NODES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_NB_FILES) CASE(S_OOC_NB_FILE_TYPE) CASE(S_OOC_FILE_NAMES) CASE(S_OOC_FILE_NAME_LENGTH) CASE(S_PIVNUL_LIST) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PIVNUL_LIST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PIVNUL_LIST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PIVNUL_LIST)) THEN write(unit,iostat=err) size(id%PIVNUL_LIST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PIVNUL_LIST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PIVNUL_LIST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PIVNUL_LIST(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PIVNUL_LIST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SUP_PROC) CASE(S_IPTR_WORKING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%IPTR_WORKING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%IPTR_WORKING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%IPTR_WORKING)) THEN write(unit,iostat=err) size(id%IPTR_WORKING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IPTR_WORKING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%IPTR_WORKING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%IPTR_WORKING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IPTR_WORKING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_WORKING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%WORKING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%WORKING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%WORKING)) THEN write(unit,iostat=err) size(id%WORKING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%WORKING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%WORKING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%WORKING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%WORKING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_INTR_ENCODING) NbRecords(i1) =0 SIZE_GEST(i1) =0 SIZE_VARIABLES(i1)=0_8 DO i2=1,NBVARIABLES_ROOTC SELECT CASE(i2) CASE(R_MBLOCK) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%MBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%MBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_NBLOCK) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%NBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%NBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_NPROW) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%NPROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%NPROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_NPCOL) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%NPCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%NPCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_MYROW) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then NbRecords_ROOTC(i2)=1 SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%MYROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%MYROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_MYCOL) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%MYCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%MYCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_SCHUR_MLOC) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%SCHUR_MLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%SCHUR_MLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_SCHUR_NLOC) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%SCHUR_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%SCHUR_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_SCHUR_LLD) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%SCHUR_LLD if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%SCHUR_LLD if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_RHS_NLOC) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%RHS_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%RHS_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_ROOT_SIZE) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%ROOT_SIZE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%ROOT_SIZE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_TOT_ROOT_SIZE) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%TOT_ROOT_SIZE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%TOT_ROOT_SIZE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_DESCRIPTOR) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)= & size(idintr%root%DESCRIPTOR,1) * SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%DESCRIPTOR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT* & size(idintr%root%DESCRIPTOR,1) read(unit,iostat=err) idintr%root%DESCRIPTOR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_CNTXT_BLACS) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%CNTXT_BLACS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%CNTXT_BLACS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_LPIV) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%LPIV if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%LPIV if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_RG2L) CASE(R_IPIV) NbRecords_ROOTC(i2)=2 if(mode.EQ.memory_save_mode) then IF(associated(idintr%root%IPIV)) THEN SIZE_GEST_ROOTC(i2)=SIZE_INT SIZE_VARIABLES_ROOTC(i2)= & size(idintr%root%IPIV,1)*SIZE_INT ELSE SIZE_GEST_ROOTC(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOTC(i2)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(idintr%root%IPIV)) THEN write(unit,iostat=err) size(idintr%root%IPIV,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) idintr%root%IPIV ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(idintr%root%IPIV) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_ROOTC(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOTC(i2)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_ROOTC(i2)=SIZE_INT SIZE_VARIABLES_ROOTC(i2)=size_array1*SIZE_INT allocate(idintr%root%IPIV(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) idintr%root%IPIV endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_yes) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%yes if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_LOGICAL read(unit,iostat=err) idintr%root%yes if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_gridinit_done) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%gridinit_done if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_LOGICAL read(unit,iostat=err) idintr%root%gridinit_done if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_NB_SINGULAR_VALUES) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%NB_SINGULAR_VALUES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%NB_SINGULAR_VALUES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_ROOTC(i2)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_ROOTC(i2)=NbRecords_ROOTC(i2)+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_ROOTC(i2) & +int(SIZE_GEST_ROOTC(i2),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*NbRecords_ROOTC(i2),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES_ROOTC(i2)+ & DIFF_SIZE_ALLOC_READ_ROOTC(i2) size_read=size_read+SIZE_VARIABLES_ROOTC(i2) & +int(SIZE_GEST_ROOTC(i2),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*id%KEEP(34)*NbRecords_ROOTC(i2),kind=8) #endif elseif(mode.EQ.fake_restore_mode) then endif ENDDO CALL ZMUMPS_SAVE_RESTORE_L0FACARRAY( & idintr%L0_OMP_FACTORS & ,unit,id%MYID,mode & ,SIZE_GEST_L0FAC,SIZE_VARIABLES_L0FAC & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) CALL ZMUMPS_SAVE_RESTORE_ROOTA( & idintr%roota & ,unit,id%MYID,mode & ,SIZE_GEST_ROOTA,SIZE_VARIABLES_ROOTA & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,SIZE_RL_OR_DBL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_NBGRP) CALL MUMPS_SAVE_INT(id%NBGRP) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LRGROUPS) CALL ZMUMPS_SAVE_INT_SHPTR_ARRAY(id%LRGROUPS & ) IF (id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_FDM_F_ENCODING) NbRecords(i1)=1 SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=0_8 if(mode.EQ.memory_save_mode) then IF(associated(id%FDM_F_ENCODING)) THEN CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,memory_save_mode & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FDM_F_ENCODING)) THEN write(unit,iostat=err) size(id%FDM_F_ENCODING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,save_mode & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FDM_F_ENCODING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.NE.-999) then CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,restore_mode & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_BLRARRAY_ENCODING) NbRecords(i1)=1 SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=0_8 CALL_SAVE_RESTORE_BLR = .FALSE. if(mode.EQ.memory_save_mode) then IF(associated(id%BLRARRAY_ENCODING)) THEN CALL_SAVE_RESTORE_BLR = .TRUE. ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%BLRARRAY_ENCODING)) THEN write(unit,iostat=err) size(id%BLRARRAY_ENCODING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CALL_SAVE_RESTORE_BLR = .TRUE. ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(id%BLRARRAY_ENCODING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.NE.-999) then CALL_SAVE_RESTORE_BLR = .TRUE. endif endif IF (CALL_SAVE_RESTORE_BLR) THEN CALL ZMUMPS_SAVE_RESTORE_BLR(id%BLRARRAY_ENCODING & ,unit,id%MYID,mode & ,SIZE_GEST_BLR,SIZE_VARIABLES_BLR & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_SCHED_SBTR) CASE(S_LPOOL_A_L0_OMP) CALL MUMPS_SAVE_INT(id%LPOOL_A_L0_OMP) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_LPOOL_B_L0_OMP) CALL MUMPS_SAVE_INT(id%LPOOL_B_L0_OMP) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_L_PHYS_L0_OMP) CALL MUMPS_SAVE_INT(id%L_PHYS_L0_OMP) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_L_VIRT_L0_OMP) CALL MUMPS_SAVE_INT(id%L_VIRT_L0_OMP) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_LL0_OMP_MAPPING) CALL MUMPS_SAVE_INT(id%LL0_OMP_MAPPING) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_LL0_OMP_FACTORS) CALL MUMPS_SAVE_INT(id%LL0_OMP_FACTORS) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_THREAD_LA) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%THREAD_LA if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%THREAD_LA if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_IPOOL_A_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%IPOOL_A_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%IPOOL_A_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%IPOOL_A_L0_OMP)) THEN write(unit,iostat=err) size(id%IPOOL_A_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IPOOL_A_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%IPOOL_A_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%IPOOL_A_L0_OMP(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IPOOL_A_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_IPOOL_B_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%IPOOL_B_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%IPOOL_B_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%IPOOL_B_L0_OMP)) THEN write(unit,iostat=err) size(id%IPOOL_B_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IPOOL_B_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%IPOOL_B_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%IPOOL_B_L0_OMP(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IPOOL_B_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PHYS_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PHYS_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%PHYS_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PHYS_L0_OMP)) THEN write(unit,iostat=err) size(id%PHYS_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PHYS_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PHYS_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PHYS_L0_OMP(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PHYS_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_VIRT_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%VIRT_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%VIRT_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%VIRT_L0_OMP)) THEN write(unit,iostat=err) size(id%VIRT_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%VIRT_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%VIRT_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%VIRT_L0_OMP(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%VIRT_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_VIRT_L0_OMP_MAPPING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%VIRT_L0_OMP_MAPPING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%VIRT_L0_OMP_MAPPING,1) & *SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%VIRT_L0_OMP_MAPPING)) THEN write(unit,iostat=err) size(id%VIRT_L0_OMP_MAPPING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%VIRT_L0_OMP_MAPPING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%VIRT_L0_OMP_MAPPING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%VIRT_L0_OMP_MAPPING(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%VIRT_L0_OMP_MAPPING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PERM_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PERM_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PERM_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PERM_L0_OMP)) THEN write(unit,iostat=err) size(id%PERM_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PERM_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PERM_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PERM_L0_OMP(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PERM_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTR_LEAFS_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTR_LEAFS_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%PTR_LEAFS_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTR_LEAFS_L0_OMP)) THEN write(unit,iostat=err) size(id%PTR_LEAFS_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTR_LEAFS_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PTR_LEAFS_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PTR_LEAFS_L0_OMP(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTR_LEAFS_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_L0_OMP_MAPPING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%L0_OMP_MAPPING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%L0_OMP_MAPPING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%L0_OMP_MAPPING)) THEN write(unit,iostat=err) size(id%L0_OMP_MAPPING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%L0_OMP_MAPPING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%L0_OMP_MAPPING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%L0_OMP_MAPPING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%L0_OMP_MAPPING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SINGULAR_VALUES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%SINGULAR_VALUES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%SINGULAR_VALUES,1)*SIZE_RL_OR_DBL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%SINGULAR_VALUES)) THEN write(unit,iostat=err) size(id%SINGULAR_VALUES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(size_written,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%SINGULAR_VALUES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(size_written,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(size_written,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%SINGULAR_VALUES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_RL_OR_DBL allocate(id%SINGULAR_VALUES(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%SINGULAR_VALUES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NB_SINGULAR_VALUES) CALL MUMPS_SAVE_INT(id%NB_SINGULAR_VALUES) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_ASSOCIATED_OOC_FILES) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL endif CASE(S_SAVE_DIR) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%SAVE_DIR)*SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%SAVE_DIR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%SAVE_DIR)*SIZE_CHARACTER read(unit,iostat=err) id%SAVE_DIR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SAVE_PREFIX) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%SAVE_PREFIX)*SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%SAVE_PREFIX if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%SAVE_PREFIX)*SIZE_CHARACTER read(unit,iostat=err) id%SAVE_PREFIX if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MTKO_PROCS_MAP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MTKO_PROCS_MAP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%MTKO_PROCS_MAP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MTKO_PROCS_MAP)) THEN write(unit,iostat=err) size(id%MTKO_PROCS_MAP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MTKO_PROCS_MAP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MTKO_PROCS_MAP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MTKO_PROCS_MAP(0:size_array1-1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MTKO_PROCS_MAP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_METIS_OPTIONS) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%METIS_OPTIONS,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%METIS_OPTIONS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%METIS_OPTIONS,1) read(unit,iostat=err) id%METIS_OPTIONS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_pad1,S_pad2,S_pad3,S_pad4,S_pad5,S_pad6,S_pad7, & S_pad11,S_pad12,S_pad13,S_pad14,S_pad16) CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords(i1)=NbRecords(i1)+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES(i1) & +int(SIZE_GEST(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*NbRecords(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES(i1)+ & DIFF_SIZE_ALLOC_READ(i1) size_read=size_read+SIZE_VARIABLES(i1) & +int(SIZE_GEST(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*id%KEEP(34)*NbRecords(i1),kind=8) #endif elseif(mode.EQ.fake_restore_mode) then endif ENDDO 200 continue if(mode.EQ.memory_save_mode) then WRITTEN_STRUC_SIZE=sum(SIZE_VARIABLES)+ & sum(SIZE_VARIABLES_ROOTC)+ & SIZE_VARIABLES_BLR+SIZE_VARIABLES_FRONT_DATA+ & SIZE_VARIABLES_L0FAC+ & SIZE_VARIABLES_ROOTA TOTAL_STRUC_SIZE=WRITTEN_STRUC_SIZE & +sum(DIFF_SIZE_ALLOC_READ) & +sum(DIFF_SIZE_ALLOC_READ_ROOTC) gest_size=sum(SIZE_GEST)+sum(SIZE_GEST_ROOTC) & +SIZE_GEST_BLR+SIZE_GEST_FRONT_DATA & +SIZE_GEST_L0FAC & +SIZE_GEST_ROOTA & +int(5*SIZE_CHARACTER,kind=8) & +int(23*SIZE_CHARACTER,kind=8) & +int(2*SIZE_INT8,kind=8)+int(1,kind=8) & +int(3*SIZE_INT,kind=8) & +int(SIZE_LOGICAL,kind=8) IF(associated(id%OOC_FILE_NAME_LENGTH).AND. & associated(id%OOC_FILE_NAMES)) THEN gest_size=gest_size+int(SIZE_INT,kind=8) & +int(id%OOC_FILE_NAME_LENGTH(1)*SIZE_CHARACTER,kind=8) ELSE gest_size=gest_size+int(2*SIZE_INT,kind=8) ENDIF #if defined(MUMPS_NOF2003) tot_NbRecords=sum(NbRecords)+sum(NbRecords_ROOTC)+8 gest_size=gest_size+int(2*id%KEEP(34)*tot_NbRecords,kind=8) #endif TOTAL_FILE_SIZE=WRITTEN_STRUC_SIZE+gest_size elseif(mode.EQ.save_mode) then elseif(mode.EQ.restore_mode) then #if ! defined(NOSCALAPACK) if(idintr%root%gridinit_done) then idintr%root%CNTXT_BLACS = id%COMM_NODES CALL blacs_gridinit( idintr%root%CNTXT_BLACS, 'R', & idintr%root%NPROW, idintr%root%NPCOL ) idintr%root%gridinit_done = .TRUE. idintr%root%DESCRIPTOR(2) = idintr%root%CNTXT_BLACS endif #endif elseif(mode.EQ.fake_restore_mode) then elseif(mode.EQ.restore_ooc_mode) then endif 100 continue RETURN CONTAINS SUBROUTINE MUMPS_SAVERSTR_REALARRAY(idREAL) IMPLICIT NONE DOUBLE PRECISION, DIMENSION(:), POINTER :: idREAL NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(idREAL)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(idREAL,1)*SIZE_RL_OR_DBL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(idREAL)) THEN write(unit,iostat=err) size(idreal,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) idREAL ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(idREAL) read(unit,iostat=err) size_array1 if (err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if (size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_RL_OR_DBL allocate(idREAL(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) idREAL endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if (err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif 100 CONTINUE RETURN END SUBROUTINE MUMPS_SAVERSTR_REALARRAY SUBROUTINE MUMPS_SAVE_INT(idINT) IMPLICIT NONE INTEGER, INTENT(INOUT) :: idINT NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idINT if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) idINT if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif 100 CONTINUE RETURN END SUBROUTINE MUMPS_SAVE_INT SUBROUTINE ZMUMPS_SAVE_INT_SHPTR_ARRAY(id_INTPTR & ) IMPLICIT NONE INTEGER, POINTER, DIMENSION(:) :: id_INTPTR NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id_INTPTR) & ) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id_INTPTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id_INTPTR) & ) THEN write(unit,iostat=err) size(id_INTPTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id_INTPTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id_INTPTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id_INTPTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) else read(unit,iostat=err) id_INTPTR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif endif endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_SAVE_INT_SHPTR_ARRAY END SUBROUTINE ZMUMPS_SAVE_RESTORE_STRUCTURE SUBROUTINE ZMUMPS_SAVE_RESTORE_ROOTA( & roota & ,unit,MYID,mode & ,SIZE_GEST_ROOTA,SIZE_VARIABLES_ROOTA & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,SIZE_RL_OR_DBL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST_ROOTA INTEGER(8),intent(OUT) :: SIZE_VARIABLES_ROOTA INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER,intent(IN):: SIZE_RL_OR_DBL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: SIZE_GEST, i3 INTEGER(8) :: SIZE_VARIABLE INTEGER, PARAMETER :: NBVARIABLES_ROOTA=7 INTEGER, PARAMETER :: RA_SINGULAR_VALUES=7 INTEGER, PARAMETER :: RA_SVD_VT=6 INTEGER, PARAMETER :: RA_SVD_U=5 INTEGER, PARAMETER :: RA_RHS_ROOT=4 INTEGER, PARAMETER :: RA_QR_TAU=3 INTEGER, PARAMETER :: RA_SCHUR_POINTER=2 INTEGER, PARAMETER :: RA_RHS_CNTR_MASTER_ROOT=1 SIZE_GEST_ROOTA = 0 SIZE_VARIABLES_ROOTA = 0_8 DO i3 = 1, NBVARIABLES_ROOTA SIZE_GEST = 0 SIZE_VARIABLE = 0_8 SELECT CASE(i3) CASE(RA_QR_TAU) CALL ZMUMPS_SAVE_RESTORE_ARRAY_C1D( & roota%QR_TAU ) CASE(RA_SVD_U) CALL ZMUMPS_SAVE_RESTORE_ARRAY_2D(roota%SVD_U) CASE(RA_SVD_VT) CASE(RA_SINGULAR_VALUES) CALL ZMUMPS_SAVE_RESTORE_ARRAY_R1D( & roota%SINGULAR_VALUES) CASE(RA_RHS_CNTR_MASTER_ROOT) CALL ZMUMPS_SAVE_RESTORE_ARRAY_C1D( & roota%RHS_CNTR_MASTER_ROOT) CASE(RA_RHS_ROOT) CASE(RA_SCHUR_POINTER) CASE DEFAULT END SELECT IF ( INFO(1) .LT. 0 ) GOTO 100 IF (mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTA = SIZE_VARIABLES_ROOTA + & SIZE_VARIABLE SIZE_GEST_ROOTA = SIZE_GEST_ROOTA + SIZE_GEST ENDIF END DO 100 CONTINUE RETURN CONTAINS SUBROUTINE ZMUMPS_SAVE_RESTORE_ARRAY_2D(PTRARRAY2D) IMPLICIT NONE COMPLEX(kind=8), DIMENSION(:,:), POINTER :: PTRARRAY2D INTEGER :: LocalNbRecords, err, allocok, dummy INTEGER :: size_array1, size_array2 INTEGER(8) :: sz LocalNbRecords = 2 if(mode.EQ.memory_save_mode) then IF(associated(PTRARRAY2D)) THEN SIZE_GEST = SIZE_INT*2 SIZE_VARIABLE = size(PTRARRAY2D,1) & *size(PTRARRAY2D,2)*SIZE_ARITH_DEP ELSE SIZE_GEST = SIZE_INT*3 SIZE_VARIABLE = 0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(PTRARRAY2D)) THEN write(unit,iostat=err) size(PTRARRAY2D,1) & ,size(PTRARRAY2D,2) ELSE write(unit,iostat=err) -999,-998 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+2*SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 IF(associated(PTRARRAY2D)) THEN write(unit,iostat=err) PTRARRAY2D sz= int(size(PTRARRAY2D,1),8) * & int(size(PTRARRAY2D,2),8) * & SIZE_ARITH_DEP ELSE write(unit,iostat=err) -999 sz=SIZE_INT ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(PTRARRAY2D) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) else size_read = size_read+2*SIZE_INT size_allocated = size_allocated + 2*SIZE_INT8 endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then read(unit,iostat=err) dummy sz = SIZE_INT else sz = int(size_array1,8)*int(size_array2,8) & * SIZE_ARITH_DEP allocate(PTRARRAY2D(size_array1, & size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) PTRARRAY2D endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & , INFO(2)) else size_read = size_read + sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif #if defined(MUMPS_NOF2003) IF (mode.EQ.memory_save_mode) THEN SIZE_GEST = SIZE_GEST+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.save_mode) THEN size_written = size_written+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.restore_mode) THEN size_read = size_read+2*SIZE_INT*LocalNbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_ARRAY_2D SUBROUTINE ZMUMPS_SAVE_RESTORE_ARRAY_C1D(PTRARRAY1D) IMPLICIT NONE COMPLEX(kind=8), DIMENSION(:), POINTER :: PTRARRAY1D INTEGER :: LocalNbRecords, err, allocok, dummy INTEGER :: size_array1 INTEGER(8) :: sz LocalNbRecords = 2 if(mode.EQ.memory_save_mode) then IF(associated(PTRARRAY1D)) THEN SIZE_GEST = SIZE_INT SIZE_VARIABLE = size(PTRARRAY1D)*SIZE_ARITH_DEP ELSE SIZE_GEST = SIZE_INT*2 SIZE_VARIABLE = 0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(PTRARRAY1D)) THEN write(unit,iostat=err) size(PTRARRAY1D) ELSE write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 IF(associated(PTRARRAY1D)) THEN write(unit,iostat=err) PTRARRAY1D sz= int(size(PTRARRAY1D),8)* & SIZE_ARITH_DEP ELSE write(unit,iostat=err) -999 sz=SIZE_INT ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(PTRARRAY1D) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) else size_read = size_read+SIZE_INT size_allocated = size_allocated + SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then read(unit,iostat=err) dummy sz = SIZE_INT else sz = int(size_array1,8) * SIZE_ARITH_DEP allocate(PTRARRAY1D(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) PTRARRAY1D endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & , INFO(2)) else size_read = size_read + sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif #if defined(MUMPS_NOF2003) IF (mode.EQ.memory_save_mode) THEN SIZE_GEST = SIZE_GEST+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.save_mode) THEN size_written = size_written+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.restore_mode) THEN size_read = size_read+2*SIZE_INT*LocalNbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_ARRAY_C1D SUBROUTINE ZMUMPS_SAVE_RESTORE_ARRAY_R1D(PTRARRAY1D) IMPLICIT NONE DOUBLE PRECISION, DIMENSION(:), POINTER :: PTRARRAY1D INTEGER :: LocalNbRecords, err, allocok, dummy INTEGER :: size_array1 INTEGER(8) :: sz LocalNbRecords = 2 if(mode.EQ.memory_save_mode) then IF(associated(PTRARRAY1D)) THEN SIZE_GEST = SIZE_INT SIZE_VARIABLE = size(PTRARRAY1D)*SIZE_RL_OR_DBL ELSE SIZE_GEST = SIZE_INT*2 SIZE_VARIABLE = 0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(PTRARRAY1D)) THEN write(unit,iostat=err) size(PTRARRAY1D) ELSE write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 IF(associated(PTRARRAY1D)) THEN write(unit,iostat=err) PTRARRAY1D sz= int(size(PTRARRAY1D),8)* & SIZE_RL_OR_DBL ELSE write(unit,iostat=err) -999 sz=SIZE_INT ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(PTRARRAY1D) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) else size_read = size_read+SIZE_INT size_allocated = size_allocated + SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then read(unit,iostat=err) dummy sz = SIZE_INT else sz = int(size_array1,8) * SIZE_RL_OR_DBL allocate(PTRARRAY1D(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) PTRARRAY1D endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & , INFO(2)) else size_read = size_read + sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif #if defined(MUMPS_NOF2003) IF (mode.EQ.memory_save_mode) THEN SIZE_GEST = SIZE_GEST+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.save_mode) THEN size_written = size_written+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.restore_mode) THEN size_read = size_read+2*SIZE_INT*LocalNbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_ARRAY_R1D END SUBROUTINE ZMUMPS_SAVE_RESTORE_ROOTA END MODULE ZMUMPS_SAVE_RESTORE #else SUBROUTINE ZMUMPS_SAVE_RESTORE_RETURN() RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_RETURN #endif MUMPS_5.8.1/src/mumps_io_thread.h0000664000175000017500000000634015042446422016563 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_IO_THREAD_H #define MUMPS_IO_THREAD_H #include "mumps_compat.h" #include "mumps_c_types.h" #if ! defined (MUMPS_WIN32) && ! defined (WITHOUT_PTHREAD) # include # include # include # include # include # define MAX_IO 20 # define MAX_FINISH_REQ 40 # define IO_FLAG_STOP 1 # define IO_FLAG_RUN 0 # define IO_READ 1 # define IO_WRITE 0 struct request_io{ MUMPS_INT inode; MUMPS_INT req_num; /*request number*/ void* addr; /*memory address (either source or dest)*/ long long size; /* size of the requested io (unit=size of elementary mumps data)*/ long long vaddr; /* virtual address for file management */ MUMPS_INT io_type; /*read or write*/ MUMPS_INT file_type; /* cb or lu or ... */ pthread_cond_t local_cond; MUMPS_INT int_local_cond; }; /* Exported global variables */ extern MUMPS_INT io_flag_stop,current_req_num; extern pthread_t io_thread,main_thread; extern pthread_mutex_t io_mutex; extern pthread_cond_t cond_io,cond_nb_free_finished_requests,cond_nb_free_active_requests,cond_stop; extern pthread_mutex_t io_mutex_cond; extern MUMPS_INT int_sem_io,int_sem_nb_free_finished_requests,int_sem_nb_free_active_requests,int_sem_stop; extern MUMPS_INT with_sem; extern struct request_io *io_queue; extern MUMPS_INT first_active,last_active,nb_active; extern MUMPS_INT *finished_requests_inode,*finished_requests_id,first_finished_requests, last_finished_requests,nb_finished_requests,smallest_request_id; extern MUMPS_INT mumps_owns_mutex; extern MUMPS_INT test_request_called_from_mumps; /* Exported functions */ void* mumps_async_thread_function_with_sem (void* arg); MUMPS_INT mumps_is_there_finished_request_th(MUMPS_INT* flag); MUMPS_INT mumps_clean_request_th(MUMPS_INT* request_id); MUMPS_INT mumps_wait_req_sem_th(MUMPS_INT *request_id); MUMPS_INT mumps_test_request_th(MUMPS_INT* request_id,MUMPS_INT *flag); MUMPS_INT mumps_wait_request_th(MUMPS_INT *request_id); MUMPS_INT mumps_low_level_init_ooc_c_th(MUMPS_INT* async, MUMPS_INT* ierr); MUMPS_INT mumps_async_write_th(const MUMPS_INT * strat_IO,void * address_block,long long block_size, MUMPS_INT * inode,MUMPS_INT * request_arg,MUMPS_INT * type,long long vaddr,MUMPS_INT * ierr); MUMPS_INT mumps_async_read_th(const MUMPS_INT * strat_IO,void * address_block,long long block_size,MUMPS_INT * inode,MUMPS_INT * request_arg, MUMPS_INT * type,long long vaddr,MUMPS_INT * ierr); MUMPS_INT mumps_clean_io_data_c_th(MUMPS_INT *myid); MUMPS_INT mumps_get_sem(void *arg,MUMPS_INT *value); MUMPS_INT mumps_wait_sem(void *arg,pthread_cond_t *cond); MUMPS_INT mumps_post_sem(void *arg,pthread_cond_t *cond); MUMPS_INT mumps_clean_finished_queue_th(); #endif /*_WIN32 && WITHOUT_PTHREAD*/ #endif /* MUMPS_IO_THREAD_H */ MUMPS_5.8.1/src/mumps_print_defined.F0000664000175000017500000001117015042446423017373 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_PRINT_IF_DEFINED(MPG) IMPLICIT NONE INTEGER, INTENT(IN) :: MPG IF (MPG.LE.0) RETURN write(MPG,*) "=================================================" #if defined(AFFINITY_VERBOSE) write(MPG, *) "MUMPS compiled with option -DAFFINITY_VERBOSE" #endif #if defined(AVOID_MPI_IN_PLACE) WRITE(MPG,*) & " MUMPS compiled with option -DAVOID_MPI_IN_PLACE" #endif #if defined(LARGEMATRICES) write(MPG,*) "MUMPS compiled with option -DLARGEMATRICES" #endif #if defined(GEMMT_AVAILABLE) write(MPG, *) "MUMPS compiled with option -DGEMMT_AVAILABLE" #endif #if defined(DETERMINISTIC_PARALLEL_GRAPH) write(MPG,*) "MUMPS compiled with option" & ," -DDETERMINISTIC_PARALLEL_GRAPH" #endif #if defined(metis) write(MPG,*) "MUMPS compiled with option -Dmetis" #endif #if defined(metis4) write(MPG,*) "MUMPS compiled with option -Dmetis4" #endif #if defined(MUMPS_ALLOC_FROM_C) WRITE(MPG,*) " MUMPS compiled with option -DMUMPS_ALLOC_FROM_C" #endif #if defined(MUMPS_NOF2003) write(MPG,*) "MUMPS compiled with option -DMUMPS_NOF2003" #endif #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) write(MPG,*) &"MUMPS compiled with option -DMUMPS_SCOTCHIMPORTTHREADS" #endif #if defined(MUMPS_WINLARGEFILES) write(MPG,*) "MUMPS compiled with option -DMUMPS_WINLARGEFILES" #endif #if defined(MUMPS_USE_BLAS2) write(MPG,*) "MUMPS compiled with option -DMUMPS_USE_BLAS2" #endif #if defined(NOSCALAPACK) write(MPG,*) "MUMPS compiled with option -DNOSCALAPACK" #endif #if defined(OLD_OOC_NOPANEL) write(MPG,*) "MUMPS compiled with option -DOLD_OOC_NOPANEL" #endif #if defined(parmetis) write(MPG,*) "MUMPS compiled with option -Dparmetis" #endif #if defined(parmetis3) write(MPG,*) "MUMPS compiled with option -Dparmetis3" #endif #if defined(pord) write(MPG,*) "MUMPS compiled with option -Dpord" #endif #if defined(PRINT_BACKTRACE_ON_ABORT) write(MPG, *) & "MUMPS compiled with option -DPRINT_BACKTRACE_ON_ABORT" #endif #if defined(ptscotch) write(MPG,*) "MUMPS compiled with option -Dptscotch" #endif #if defined(scotch) write(MPG,*) "MUMPS compiled with option -Dscotch" #endif #if defined(NOAGG1) write(MPG,*) "MUMPS compiled with option -DNOAGG1" #endif #if defined(NOAGG2) write(MPG,*) "MUMPS compiled with option -DNOAGG2" #endif #if defined(NOAGG3) write(MPG,*) "MUMPS compiled with option -DNOAGG3" #endif #if defined(NOAGG4) write(MPG,*) "MUMPS compiled with option -DNOAGG4" #endif #if defined(NOAGG5) write(MPG,*) "MUMPS compiled with option -DNOAGG5" #endif #if defined(NOAMALGTOFATHER) write(MPG,*) "MUMPS compiled with -DNOAMALGTOFATHER" #endif #if defined(NO_FDM_DESCBAND) write(MPG,*) "MUMPS compiled with -DNO_FDM_DESCBAND" #endif #if defined(NO_FDM_MAPROW) write(MPG,*) "MUMPS compiled with -DNO_FDM_MAPROW" #endif #if defined(NO_SAVE_RESTORE) write(MPG,*) "MUMPS compiled with -DNO_SAVE_RESTORE" #endif #if defined(NO_SPLIT_IN_BLRGROUPING) write(MPG,*) "MUMPS compiled with -DNO_SPLIT_IN_BLRGROUPING" #endif #if defined(NODYNAMICCB) write(MPG,*) "MUMPS compiled with option -DNODYNAMICCB" #endif #if defined(USE_OLD_SCALING) write(MPG,*) "MUMPS compiled with option -DUSE_OLD_SCALING" #endif #if defined(VHOFFLOAD) write(MPG,*) "MUMPS compiled with -DVHOFFLOAD" #endif #if defined(WORKAROUNDINTELILP64MPI2INTEGER) write(MPG,*) "MUMPS compiled with option" & ," -DWORKAROUNDINTELILP64MPI2INTEGER" #endif #if defined(WORKAROUNDILP64MPICUSTOMREDUCE) write(MPG,*) "MUMPS compiled with option" & ," -DWORKAROUNDILP64MPICUSTOMREDUCE" #endif #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) write(MPG,*) "MUMPS compiled with option" & ," -DWORKAROUNDINTELILP64OPENMPLIMITATION" #endif #if defined(ZERO_TRIANGLE) write(MPG,*) "MUMPS compiled with option -DZERO_TRIANGLE" #endif #if defined(BLR_NOOPENMP) write(MPG,*) "MUMPS compiled with option -DBLR_NOOPENMP" #endif #if defined(STAT_ES_SOLVE) write(MPG,*) "MUMPS compiled with option -DSTAT_ES_SOLVE" #endif write(MPG,*) "=================================================" RETURN END SUBROUTINE MUMPS_PRINT_IF_DEFINED MUMPS_5.8.1/src/cfac_process_blfac_slave.F0000664000175000017500000005565315042446440020330 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE CMUMPS_PROCESS_BLFAC_SLAVE( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT USE MUMPS_LOAD USE CMUMPS_LR_CORE USE CMUMPS_LR_TYPE USE CMUMPS_FAC_LR USE CMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR USE CMUMPS_FAC_FRONT_AUX_M, ONLY : CMUMPS_GET_SIZE_SCHUR_IN_FRONT #if ! defined(BLR_NOOPENMP) !$ USE OMP_LIB #endif IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER PERM(N), STEP(N), PIMASTER(KEEP(28)) INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER NELT, LPTRAR INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)) INTEGER ITLOC( N + KEEP(253)), FILS( N ), DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER ND( KEEP(28) ), FRERE_STEPS( KEEP(28) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 COMPLEX DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER INODE, IPOSK, JPOSK, NCOLU, NPIV, POSITION, IERR INTEGER(8) POSELT, POSBLOCFACTO INTEGER(8) LAELL INTEGER(8) :: LA_PTR COMPLEX, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1 , HS, DEST, NSLAVES_FOLLOW INTEGER FPERE, TO_UPDATE_CPT_RECUR INTEGER(8) CPOS, LPOS LOGICAL DYNAMIC_ALLOC, COUNTER_WAS_HUGE LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL LASTBL_INPANEL INTEGER allocok INTEGER LR_ACTIVATED_INT LOGICAL LR_ACTIVATED, COMPRESS_CB INTEGER NB_BLR_U, CURRENT_BLR_U TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_U INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_U TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS, BEGS_BLR_COL INTEGER :: NB_BLR_LS, IPANEL, & MAXI_CLUSTER_LS, MAXI_CLUSTER, & NB_BLR_COL, MAXI_CLUSTER_COL, NPARTSASS_MASTER COMPLEX, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR REAL,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, LWORK INTEGER :: II,JJ INTEGER :: MSGSOU_BL INTEGER :: NFS4FATHER, NASS1, NELIM, INFO_TMP(2) INTEGER :: NVSCHUR_K253, NSLAVES_L, IROW_L INTEGER :: NBROWSinF REAL, ALLOCATABLE, DIMENSION(:) :: M_ARRAY COMPLEX, ALLOCATABLE, DIMENSION(:) :: UDYNAMIC COMPLEX ONE,ALPHA PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) DYNAMIC_ALLOC = .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 <=0 NPIV in BLFAC', NPIV 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 ) LASTBL_INPANEL = (NCOLU.LT.0) IF (LASTBL_INPANEL) NCOLU = -NCOLU CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LR_ACTIVATED_INT, 1, & MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IPANEL, 1, & MPI_INTEGER, COMM, IERR ) IF (LR_ACTIVATED) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_U, 1, MPI_INTEGER, & COMM, IERR ) CURRENT_BLR_U = 1 ALLOCATE(BLR_U(max(NB_BLR_U,1)), & BEGS_BLR_U(NB_BLR_U+2), stat=allocok) if (allocok .GT. 0) THEN IFLAG = -13 IERROR = max(NB_BLR_U,1) + NB_BLR_U+2 GOTO 700 endif CALL CMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, JPOSK-1, 0, 'V', & BLR_U, NB_BLR_U, & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE LAELL = int(NPIV,8) * int(NCOLU,8) CALL CMUMPS_GET_SIZE_NEEDED( & 0, LAELL, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID, SLAVEF, & PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8, LAELL,KEEP,KEEP8,LRLUS) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOLU, & MPI_COMPLEX, & COMM, IERR ) ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) DYNAMIC_ALLOC = .TRUE. IF ( (PTRIST(STEP( INODE )).NE.0) .AND. & (IPOSK + NPIV -1 .GT. & IW(PTRIST(STEP(INODE))+3+KEEP(IXSZ))) )THEN DYNAMIC_ALLOC = .TRUE. ENDIF IF (LR_ACTIVATED) THEN DYNAMIC_ALLOC = .FALSE. ENDIF IF (DYNAMIC_ALLOC) THEN ALLOCATE(UDYNAMIC(LAELL), stat=allocok) if (allocok .GT. 0) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(LAELL,IERROR) GOTO 700 endif UDYNAMIC(1_8:LAELL) = A(POSBLOCFACTO:POSBLOCFACTO+LAELL-1_8) LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(69) = KEEP8(69) - LAELL POSFAC = POSFAC - LAELL CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) THEN CALL CMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF DO WHILE ( IPOSK + NPIV -1 .GT. & IW( PTRIST(STEP( INODE )) + 3 +KEEP(IXSZ)) ) MSGSOU_BL = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IOLDPS = PTRIST(STEP(INODE)) NSLAVES_FOLLOW = IW( IOLDPS+5+KEEP(IXSZ))-XTRA_SLAVES_SYM NASS1 = abs(IW( IOLDPS + 1 + KEEP(IXSZ))) TO_UPDATE_CPT_RECUR = & ( SLAVEF - NSLAVES_FOLLOW - 1 ) * & (2*NASS1/KEEP(6)) IF ( IW(IOLDPS+6+KEEP(IXSZ)) .eq. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN COUNTER_WAS_HUGE=.TRUE. IW(IOLDPS+6+KEEP(IXSZ)) = 1 ELSE COUNTER_WAS_HUGE=.FALSE. ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) - TO_UPDATE_CPT_RECUR - 10 BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU_BL, BLOC_FACTO_SYM, STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + TO_UPDATE_CPT_RECUR + 10 IF ( COUNTER_WAS_HUGE .AND. & IW(IOLDPS+6+KEEP(IXSZ)).EQ.1 ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = huge(IW(IOLDPS+6+KEEP(IXSZ))) ENDIF IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP( INODE )) CALL CMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF (LR_ACTIVATED) THEN CALL CMUMPS_BLR_DEC_AND_RETRIEVE_L (IW(IOLDPS+XXF), IPANEL, & BEGS_BLR_LS, BLR_LS, NCOLU) NB_BLR_LS = size(BEGS_BLR_LS)-2 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL CMUMPS_BLR_UPDATE_TRAILING_I ( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_U(1), size(BEGS_BLR_U), & CURRENT_BLR_U, & BLR_LS(1), NB_BLR_LS+1, & BLR_U(1), NB_BLR_U+1, & 0, & .TRUE., & 0, & 2, & 1, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif CALL DEALLOC_BLR_PANEL(BLR_U, NB_BLR_U, KEEP8, KEEP(34)) IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) IF (IFLAG.LT.0) GOTO 700 IF (KEEP(486).EQ.3) THEN CALL CMUMPS_BLR_TRY_FREE_PANEL(IW(IOLDPS+XXF), IPANEL, & KEEP8, KEEP(34)) ENDIF ELSE CPOS = POSELT + int(JPOSK - 1,8) LPOS = POSELT + int(IPOSK - 1,8) IF ( NPIV .GT. 0 ) THEN IF (DYNAMIC_ALLOC) THEN CALL cgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & UDYNAMIC(1), NPIV, & A_PTR( LPOS ), NCOL1, ONE, & A_PTR( CPOS ), NCOL1 ) ELSE CALL cgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & A( POSBLOCFACTO ), NPIV, & A_PTR( LPOS ), NCOL1, ONE, & A_PTR( CPOS ), NCOL1 ) ENDIF ENDIF ENDIF IF (NPIV .GT. 0) THEN FLOP1 = dble(NCOLU*NPIV)*dble(2*NROW1) FLOP1 = -FLOP1 CALL MUMPS_LOAD_UPDATE(1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IF (LASTBL_INPANEL) THEN IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + 1 ENDIF IF (.NOT.LR_ACTIVATED) THEN IF (DYNAMIC_ALLOC) THEN DEALLOCATE(UDYNAMIC) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(69) = KEEP8(69) - LAELL POSFAC = POSFAC - LAELL CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF ENDIF NSLAVES_FOLLOW = IW( IOLDPS + 5 +KEEP(IXSZ) ) - XTRA_SLAVES_SYM IF ( IW( IOLDPS + 6 +KEEP(IXSZ)) .eq. 0 .and. & KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 ) & THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) CALL MUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_BLFAC_SLAVE.' IFLAG = -99 GOTO 700 END IF END IF IF (IW(PTRIST(STEP(INODE)) + 6+KEEP(IXSZ) ) .eq. 0) THEN NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 4 + KEEP(IXSZ)) NELIM = NASS1 - NPIV1 COMPRESS_CB= .FALSE. IF (LR_ACTIVATED) THEN COMPRESS_CB = ((IW(PTRIST(STEP(INODE))+XXLR).EQ.1).OR. & (IW(PTRIST(STEP(INODE))+XXLR).EQ.3)) IF (NPIV.EQ.0) CALL MUMPS_ABORT() IF (COMPRESS_CB) THEN CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) NB_BLR_COL = size(BEGS_BLR_COL) - 1 allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_MASTER), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_MASTER) GOTO 700 ENDIF DO II=1,NB_BLR_LS DO JJ=1,NB_BLR_COL-NPARTSASS_MASTER CB_LRB(II,JJ)%M=0 CB_LRB(II,JJ)%N=0 NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL CMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) CALL MAX_CLUSTER(BEGS_BLR_COL( max(NPARTSASS_MASTER,1)+1: & NB_BLR_COL+1), & NB_BLR_COL-max(NPARTSASS_MASTER,1), MAXI_CLUSTER_COL ) MAXI_CLUSTER = max(MAXI_CLUSTER_LS, & MAXI_CLUSTER_COL+NELIM,NPIV) LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL CMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) NFS4FATHER = max(NFS4FATHER,0) + NELIM ENDIF ALLOCATE(M_ARRAY(max(NFS4FATHER,1)), stat=allocok) IF (allocok.gt.0) THEN IFLAG = -13 IERROR = max(NFS4FATHER,1) GOTO 700 ENDIF BEGS_BLR_COL(1+NPARTSASS_MASTER) = & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM NBROWSinF = 0 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN CALL CMUMPS_COMPUTE_NBROWSinF ( & N, INODE, FPERE, KEEP, & IOLDPS, HS, & IW, LIW, & NROW1, NCOL1, NPIV1, & NELIM, NFS4FATHER, & NBROWSinF & ) ENDIF IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) & .AND. (KEEP(50).EQ.2) & ) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL CMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR_K253 ) ELSE NVSCHUR_K253 = 0 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL CMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_LS, NB_BLR_COL-NPARTSASS_MASTER, & NPARTSASS_MASTER, & NROW1, NCOL1-NPIV1, INODE, & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV1, NVSCHUR_K253, KEEP(1), & M_ARRAY, & NELIM, NBROWSinF ) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 650 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL CMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF 650 CONTINUE IF (allocated(M_ARRAY)) DEALLOCATE(M_ARRAY) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF CALL CMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, roota, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF RETURN 700 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (COMPRESS_CB) THEN IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) ENDIF IF (allocated(M_ARRAY)) DEALLOCATE(M_ARRAY) IF (DYNAMIC_ALLOC) THEN IF (allocated(UDYNAMIC)) DEALLOCATE(UDYNAMIC) ENDIF RETURN END SUBROUTINE CMUMPS_PROCESS_BLFAC_SLAVE MUMPS_5.8.1/src/mumps_pivnul_mod.F0000664000175000017500000000516215042446423016741 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_PIVNUL_MOD TYPE PIVNUL_LIST_STRUCT_T INTEGER :: SIZE_PIVNUL_LIST INTEGER, POINTER :: PIVNUL_LIST(:) => null() END TYPE PIVNUL_LIST_STRUCT_T PUBLIC :: MUMPS_RESIZE_PIVNUL CONTAINS SUBROUTINE MUMPS_RESIZE_PIVNUL ( & KEEP, N, PIVNUL_LIST_STRUCT, POS_NEWENTRY, & IFLAG, IERROR & ) !$ USE OMP_LIB IMPLICIT NONE TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT INTEGER, INTENT(IN) :: N, POS_NEWENTRY, KEEP(500) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, POINTER, DIMENSION(:) :: TEMP_PTR INTEGER :: NEW_SIZE, IERR, I INTEGER, PARAMETER :: FI=10 IF (KEEP(405).EQ.1) THEN !$OMP CRITICAL(critical_pivnul) IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST.LT.POS_NEWENTRY) THEN NEW_SIZE = max (POS_NEWENTRY, & PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST*FI) NEW_SIZE = min(NEW_SIZE, N) ALLOCATE(TEMP_PTR(NEW_SIZE), stat=IERR) IF (IERR.GT.0) THEN IFLAG = -13 IERROR = NEW_SIZE ELSE DO I=1, PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST TEMP_PTR(I) = PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) ENDDO DEALLOCATE(PIVNUL_LIST_STRUCT%PIVNUL_LIST) PIVNUL_LIST_STRUCT%PIVNUL_LIST => TEMP_PTR PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST = NEW_SIZE ENDIF ENDIF !$OMP END CRITICAL(critical_pivnul) ELSE NEW_SIZE = max (POS_NEWENTRY, & PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST*FI) NEW_SIZE = min(NEW_SIZE, N) ALLOCATE(TEMP_PTR(NEW_SIZE), stat=IERR) IF (IERR.GT.0) THEN IFLAG = -13 IERROR = NEW_SIZE ELSE DO I=1, PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST TEMP_PTR(I) = PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) ENDDO DEALLOCATE(PIVNUL_LIST_STRUCT%PIVNUL_LIST) PIVNUL_LIST_STRUCT%PIVNUL_LIST => TEMP_PTR PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST = NEW_SIZE ENDIF ENDIF RETURN END SUBROUTINE MUMPS_RESIZE_PIVNUL END MODULE MUMPS_PIVNUL_MOD MUMPS_5.8.1/src/tools_common.F0000664000175000017500000023315515042446423016061 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_ADJUST_SIZE_LRGROUPS ( STEP, FILS, N, & ND_STEPS, NSTEPS, KEEP, & LRGROUPS, IFLAG, IERROR) !$ USE OMP_LIB USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS INTEGER, INTENT(IN) :: FILS(N), STEP(N), ND_STEPS(NSTEPS) INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER, INTENT(INOUT) :: LRGROUPS(KEEP(280)) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, NASS, NFRONT, IN, & GROUP_SIZE2, NBGROUPS_local, LRGROUPS_SIGN, IG, & NBGROUPS, MAXSIZE_GROUPS, & CurrentGroup, CurrentSize INTEGER :: OriginalSize, NBSPLIT, SZ_FINAL INTEGER, DIMENSION(:), ALLOCATABLE :: GROUP_SIZE INTEGER :: allocok IF (KEEP(494).EQ.0) RETURN IF (KEEP(280).NE.N) THEN WRITE(6,*) " Internal error in MUMPS_ADJUST_SIZE_LRGROUPS ", & "N, KEEP(280) =", N, KEEP(280) RETURN ENDIF NBGROUPS = 0 DO I=1, N IN = abs(LRGROUPS(I)) IF (IN.GT.NBGROUPS) NBGROUPS=IN END DO ALLOCATE( GROUP_SIZE(NBGROUPS), stat=allocok ) IF (allocok > 0) THEN IFLAG = -7 IERROR = NBGROUPS RETURN ENDIF GROUP_SIZE = 0 MAXSIZE_GROUPS = 0 !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) !$OMP& PRIVATE( I, NBGROUPS_local, NASS, IN, NFRONT, !$OMP& GROUP_SIZE2, CurrentGroup, LRGROUPS_SIGN, !$OMP& IG, CurrentSize, OriginalSize, NBSPLIT, !$OMP& SZ_FINAL !$OMP& ) !$OMP& REDUCTION(max:MAXSIZE_GROUPS !$OMP& ) DO I= 1, N IF (STEP(I).LE.0) CYCLE NASS = 0 IN = I DO WHILE (IN.GT.0) CurrentGroup = abs(LRGROUPS(IN)) GROUP_SIZE(CurrentGroup) = GROUP_SIZE(CurrentGroup) + 1 NASS = NASS + 1 IN = FILS(IN) ENDDO NFRONT = ND_STEPS(STEP(I)) CALL COMPUTE_BLR_VCS(KEEP(472), GROUP_SIZE2, KEEP(488) , & NASS, NFRONT, KEEP(35)) IN = I DO WHILE (IN.GT.0) CurrentGroup = LRGROUPS(IN) OriginalSize = GROUP_SIZE(abs(CurrentGroup)) NBSPLIT = (OriginalSize+GROUP_SIZE2-1)/ GROUP_SIZE2 SZ_FINAL = (OriginalSize+NBSPLIT-1)/NBSPLIT MAXSIZE_GROUPS = max(SZ_FINAL, MAXSIZE_GROUPS) IF (CurrentGroup.LT.0) THEN LRGROUPS_SIGN=-1 ELSE LRGROUPS_SIGN=1 ENDIF IG = CurrentGroup NBGROUPS_local = IG CurrentSize = 0 DO WHILE (IG .eq. CurrentGroup) LRGROUPS(IN) = NBGROUPS_local CurrentSize = CurrentSize + 1 IF ( CurrentSize .GT. SZ_FINAL ) THEN !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC NBGROUPS_local = NBGROUPS_local*LRGROUPS_SIGN CurrentSize = 0 ENDIF IN = FILS(IN) IF (IN.LE.0) EXIT IG = LRGROUPS(IN) END DO END DO END DO KEEP(142) = MAXSIZE_GROUPS DEALLOCATE(GROUP_SIZE) RETURN END SUBROUTINE MUMPS_ADJUST_SIZE_LRGROUPS SUBROUTINE MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, & MYID ) INTEGER :: INFO(80), KEEP(500), ICNTL(60), MYID INTEGER(8) :: KEEP8(150) INTEGER :: ICNTL50 CALL MUMPS_GETVAL_ADDR_C(ICNTL50, KEEP8(83)) IF (ICNTL50 .eq. 1) THEN INFO(1)=-80 INFO(2)=MYID ENDIF RETURN END SUBROUTINE MUMPS_STOP_ON_USER_REQUEST SUBROUTINE MUMPS_BUILD_COMM_PARA_ANA ( & OPTION, N, COMM, MYID, COMM_NODES, MYID_NODES, & NPROCS, NSLAVES, & KEEP, & COMM_PARAORD, NPROCS_PARAORD, & COMM_PARAORD_ALLOCATED, & COMM_PARASYMB, NPROCS_PARASYMB, & COMM_PARASYMB_ALLOCATED, & ICNTL, INFO & ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER, INTENT(IN) :: OPTION, N, COMM, COMM_NODES, & MYID, MYID_NODES, NPROCS, NSLAVES INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(OUT) :: COMM_PARAORD, NPROCS_PARAORD, & COMM_PARASYMB, NPROCS_PARASYMB LOGICAL, INTENT(OUT) :: COMM_PARAORD_ALLOCATED, & COMM_PARASYMB_ALLOCATED INTEGER :: IERR, BASE, I, COLOR INTEGER :: WORKERS, WTMP LOGICAL :: IDO INTEGER :: MINPROCSPERNODE, MAXPROCSPERNODE INTEGER :: MYNODEID, NNODES INTEGER :: WORKERSPERNODE, WORKERSLEFT, WORKERSONMYNODE INTEGER, PARAMETER :: MAXNODE_SCOTCH=16, MAXNODE_METIS=64, & ROOT=0 IF (KEEP(339).NE.0) THEN IF (NPROCS.EQ.1) GOTO 100 IF(N.LE.100) THEN WORKERS = 2 ELSE WORKERS = min(NPROCS,N/16) END IF I = 1 WTMP = 1 DO IF (I .GT. WORKERS) EXIT WTMP = I I = I*2 END DO WORKERS = WTMP IF (WORKERS.LE.1) GOTO 100 CALL MPI_ALLREDUCE( KEEP(412), MINPROCSPERNODE, 1, MPI_INTEGER, & MPI_MIN, COMM, IERR ) CALL MPI_ALLREDUCE( KEEP(412), MAXPROCSPERNODE, 1, MPI_INTEGER, & MPI_MAX, COMM, IERR ) IF (MINPROCSPERNODE .NE. MAXPROCSPERNODE ) THEN GOTO 100 ENDIF IF ( KEEP(410) .NE. MPI_COMM_NULL ) THEN CALL MPI_COMM_RANK(KEEP(410), MYNODEID, IERR) CALL MPI_COMM_SIZE(KEEP(410), NNODES, IERR) ENDIF CALL MPI_BCAST( MYNODEID, 1, MPI_INTEGER, & ROOT, KEEP(411), IERR ) CALL MPI_BCAST( NNODES, 1, MPI_INTEGER, & ROOT, KEEP(411), IERR ) IF (WORKERS .LT. NNODES ) THEN IF (MYNODEID .LT. WORKERS ) THEN WORKERSONMYNODE = 1 ELSE WORKERSONMYNODE = 0 ENDIF ELSE WORKERSPERNODE = WORKERS / NNODES WORKERSLEFT = WORKERS - WORKERSPERNODE*NNODES WORKERSONMYNODE = WORKERSPERNODE IF (NNODES - MYNODEID .LE. WORKERSLEFT ) THEN WORKERSONMYNODE = WORKERSONMYNODE+1 ENDIF ENDIF NPROCS_PARAORD = WORKERS IF ( KEEP(413) .LE. WORKERSONMYNODE - 1 ) THEN IDO = .TRUE. COLOR = 1 COMM_PARAORD_ALLOCATED = .TRUE. ELSE IDO = .FALSE. COLOR = MPI_UNDEFINED COMM_PARAORD_ALLOCATED = .FALSE. ENDIF CALL MPI_COMM_SPLIT( COMM, COLOR, 0, COMM_PARAORD, IERR) COMM_PARASYMB = COMM_PARAORD COMM_PARASYMB_ALLOCATED = .FALSE. NPROCS_PARASYMB = NPROCS_PARAORD GOTO 500 ENDIF 100 CONTINUE BASE = NPROCS-NSLAVES COMM_PARAORD = MPI_COMM_NULL NPROCS_PARAORD = 0 COMM_PARAORD_ALLOCATED = .FALSE. NPROCS_PARASYMB = NPROCS IF (OPTION.EQ.0) THEN IF (KEEP(245).EQ.1) THEN #if defined(ptscotch) COMM_PARAORD = COMM_NODES NPROCS_PARAORD = NSLAVES COMM_PARAORD_ALLOCATED = .FALSE. #else INFO(1)= -999 GOTO 600 #endif ELSE IF (KEEP(245) .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) IF(N.LE.100) THEN WORKERS = 2 ELSE WORKERS = min(NSLAVES,N/16) END IF I=1 DO IF (I .GT. WORKERS) EXIT NPROCS_PARAORD = I I = I*2 END DO IDO = (MYID .GE. BASE) .AND. & (MYID .LE. BASE+NPROCS_PARAORD-1) IF ( IDO ) THEN COLOR = 1 COMM_PARAORD_ALLOCATED = .TRUE. ELSE COLOR = MPI_UNDEFINED COMM_PARAORD_ALLOCATED = .FALSE. END IF CALL MPI_COMM_SPLIT( COMM, COLOR, 0, COMM_PARAORD, IERR ) COMM_PARASYMB = COMM_PARAORD COMM_PARASYMB_ALLOCATED = .FALSE. NPROCS_PARASYMB = NPROCS_PARAORD #else INFO(1)= -999 GOTO 600 #endif ENDIF ELSE call MUMPS_ABORT() GOTO 600 ENDIF NPROCS_PARASYMB = NPROCS_PARAORD+BASE IF (BASE.EQ.0) THEN COMM_PARASYMB = COMM_PARAORD COMM_PARASYMB_ALLOCATED = .FALSE. ELSE IF ((MYID.EQ.0).OR.COMM_PARAORD.NE.MPI_COMM_NULL) THEN COLOR = 1 COMM_PARASYMB_ALLOCATED = .TRUE. ELSE COLOR = MPI_UNDEFINED COMM_PARASYMB_ALLOCATED = .FALSE. ENDIF CALL MPI_COMM_SPLIT( COMM, COLOR, 0, COMM_PARASYMB, IERR ) ENDIF 500 CONTINUE 600 CONTINUE RETURN END SUBROUTINE MUMPS_BUILD_COMM_PARA_ANA SUBROUTINE MUMPS_BUILD_PARAORD_to_idCOMM ( & COMM, MYID, KEEP, & COMM_PARASYMB, NPROCS_PARASYMB, & COMM_PARAORD, & NPROCS_PARAORD, & PARAORD_to_idCOMM, #if defined(AVOID_MPI_IN_PLACE) & TMP, #endif & RKinSYMB_PROC0ORD, & RKinidCOMM_PROC0SYMB, NPROCS) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER, INTENT(IN) :: COMM, MYID INTEGER, INTENT(IN) :: COMM_PARAORD, NPROCS_PARAORD, & COMM_PARASYMB, NPROCS_PARASYMB INTEGER, INTENT(IN) :: KEEP(500) INTEGER, INTENT(OUT) :: PARAORD_to_idCOMM(NPROCS_PARAORD) #if defined(AVOID_MPI_IN_PLACE) INTEGER :: TMP(NPROCS_PARAORD) #endif INTEGER, INTENT(OUT) :: RKinSYMB_PROC0ORD, RKinidCOMM_PROC0SYMB INTEGER :: idPARAORD, idPARASYMB INTEGER :: IERR INTEGER :: NPROCS #if defined(AVOID_MPI_IN_PLACE) INTEGER :: TMP_INT #endif #if defined(AVOID_MPI_IN_PLACE) TMP(1:NPROCS_PARAORD)= -1 #else PARAORD_to_idCOMM(1:NPROCS_PARAORD) = -1 #endif IF (COMM_PARAORD.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_RANK (COMM_PARAORD, idPARAORD, IERR) #if defined(AVOID_MPI_IN_PLACE) TMP(idPARAORD+1) = MYID #else PARAORD_to_idCOMM(idPARAORD+1) = MYID #endif ENDIF CALL MPI_ALLREDUCE( #if defined(AVOID_MPI_IN_PLACE) & TMP, #else & MPI_IN_PLACE, #endif & PARAORD_to_idCOMM(1), & NPROCS_PARAORD, MPI_INTEGER, MPI_MAX, COMM, IERR) RKinSYMB_PROC0ORD = -1 IF (COMM_PARAORD.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_RANK (COMM_PARAORD, idPARAORD, IERR) CALL MPI_COMM_RANK (COMM_PARASYMB, idPARASYMB, IERR) IF (idPARAORD.EQ.0) RKinSYMB_PROC0ORD = idPARASYMB ENDIF #if defined(AVOID_MPI_IN_PLACE) TMP_INT = RKinSYMB_PROC0ORD CALL MPI_ALLREDUCE(TMP_INT, RKinSYMB_PROC0ORD, 1, & MPI_INTEGER, MPI_MAX, COMM, IERR) #else CALL MPI_ALLREDUCE(MPI_IN_PLACE, RKinSYMB_PROC0ORD, 1, & MPI_INTEGER, MPI_MAX, COMM, IERR) #endif RKinidCOMM_PROC0SYMB=-1 IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_RANK (COMM_PARASYMB, idPARASYMB, IERR) IF (idPARASYMB.EQ.0) RKinidCOMM_PROC0SYMB = MYID ENDIF #if defined(AVOID_MPI_IN_PLACE) TMP_INT = RKinidCOMM_PROC0SYMB CALL MPI_ALLREDUCE(TMP_INT, RKinidCOMM_PROC0SYMB, 1, & MPI_INTEGER, MPI_MAX, COMM, IERR) #else CALL MPI_ALLREDUCE(MPI_IN_PLACE, RKinidCOMM_PROC0SYMB, 1, & MPI_INTEGER, MPI_MAX, COMM, IERR) #endif RETURN END SUBROUTINE MUMPS_BUILD_PARAORD_to_idCOMM SUBROUTINE MUMPS_FIND_UNIT(IUNIT) IMPLICIT NONE INTEGER :: IUNIT INTEGER, PARAMETER :: UNIT_MIN = 10 INTEGER, PARAMETER :: UNIT_MAX = 500 INTEGER :: I LOGICAL :: BUSY IUNIT = -1 DO I = UNIT_MIN, UNIT_MAX INQUIRE(UNIT=I, OPENED=BUSY) IF ( .NOT. BUSY ) THEN IUNIT = I RETURN END IF ENDDO RETURN END SUBROUTINE MUMPS_FIND_UNIT SUBROUTINE MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, THEROOT ) IMPLICIT NONE INTEGER, intent( in ) :: N INTEGER, intent( in ) :: NFSIZ( N ) INTEGER, intent( inout ) :: FRERE( N ), FILS( N ) INTEGER, intent( out ) :: THEROOT INTEGER INODE, IROOT, IFILS, IN, IROOTLAST, SIZE IROOT = -9999 SIZE = 0 DO INODE = 1, N IF ( FRERE( INODE ) .EQ. 0 ) THEN IF ( NFSIZ( INODE ) .GT. SIZE ) THEN SIZE = NFSIZ( INODE ) IROOT = INODE END IF ENDIF END DO IN = IROOT DO WHILE ( FILS( IN ) .GT. 0 ) IN = FILS( IN ) END DO IROOTLAST = IN IFILS = - FILS ( IN ) DO INODE = 1, N IF ( FRERE( INODE ) .eq. 0 .and. INODE .ne. IROOT ) THEN IF ( IFILS .eq. 0 ) THEN FILS( IROOTLAST ) = - INODE FRERE( INODE ) = -IROOT IFILS = INODE ELSE FRERE( INODE ) = -FILS( IROOTLAST ) FILS( IROOTLAST ) = - INODE END IF END IF END DO THEROOT = IROOT RETURN END SUBROUTINE MUMPS_MAKE1ROOT INTEGER FUNCTION MUMPS_ENCODE_TPN_IPROC(TPN,IPROC,K199) INTEGER, INTENT(IN) :: TPN, IPROC, K199 IF (K199 < 0) THEN MUMPS_ENCODE_TPN_IPROC = IPROC + ISHFT(TPN+1, 24) ELSE MUMPS_ENCODE_TPN_IPROC = (TPN-1)*K199+IPROC+1 ENDIF RETURN END FUNCTION MUMPS_ENCODE_TPN_IPROC INTEGER FUNCTION MUMPS_TYPENODE_ROUGH(PROCINFO_INODE, K199) IMPLICIT NONE INTEGER K199 INTEGER PROCINFO_INODE IF (K199 < 0) THEN MUMPS_TYPENODE_ROUGH = ISHFT(PROCINFO_INODE,-24) - 1 ELSE MUMPS_TYPENODE_ROUGH = (PROCINFO_INODE-1+2*K199)/K199 - 1 ENDIF RETURN END FUNCTION MUMPS_TYPENODE_ROUGH INTEGER FUNCTION MUMPS_TYPENODE(PROCINFO_INODE, K199) IMPLICIT NONE INTEGER K199 INTEGER PROCINFO_INODE, TPN IF (K199 < 0) THEN TPN = ISHFT(PROCINFO_INODE,-24) - 1 IF (TPN < 1 ) THEN TPN = 1 ELSE IF (TPN.GE.4) THEN TPN = 2 ENDIF ELSE IF (PROCINFO_INODE <= K199 ) THEN TPN = 1 ELSE TPN = (PROCINFO_INODE-1+2*K199)/K199 - 1 IF ( TPN .LT. 1 ) TPN = 1 IF (TPN.EQ.4.OR.TPN.EQ.5.OR.TPN.EQ.6) TPN = 2 END IF END IF MUMPS_TYPENODE = TPN RETURN END FUNCTION MUMPS_TYPENODE SUBROUTINE MUMPS_TYPEANDPROCNODE( TPN, & MUMPS_PROCNODE, PROCINFO_INODE, K199 ) INTEGER, INTENT(IN) :: K199, PROCINFO_INODE INTEGER, intent(out) :: TPN, MUMPS_PROCNODE IF (K199 < 0 ) THEN MUMPS_PROCNODE=iand(PROCINFO_INODE, #if defined(MUMPS_NOF2003) & 16777215 #else & int(B"111111111111111111111111") #endif & ) TPN = ISHFT(PROCINFO_INODE,-24) - 1 IF (TPN < 1 ) THEN TPN = 1 ELSE IF (TPN.GE.4) THEN TPN = 2 ENDIF ELSE IF (K199 == 1) THEN MUMPS_PROCNODE = 0 IF (PROCINFO_INODE <= K199) THEN TPN = 1 ELSE TPN = 3 ENDIF ELSE TPN = (PROCINFO_INODE-1+2*K199)/K199-1 MUMPS_PROCNODE = (PROCINFO_INODE-1+2*K199)- & (TPN+1)*K199 IF (TPN .LT. 1) THEN TPN = 1 ELSE IF (TPN .ge. 4) THEN TPN = 2 ENDIF ENDIF ENDIF RETURN END SUBROUTINE MUMPS_TYPEANDPROCNODE INTEGER FUNCTION MUMPS_PROCNODE(PROCINFO_INODE, K199) IMPLICIT NONE INTEGER K199 INTEGER PROCINFO_INODE IF ( K199 < 0 ) THEN MUMPS_PROCNODE=iand(PROCINFO_INODE, #if defined(MUMPS_NOF2003) & 16777215 #else & int(B"111111111111111111111111") #endif & ) ELSE IF (K199 == 1) THEN MUMPS_PROCNODE = 0 ELSE MUMPS_PROCNODE=mod(2*K199+PROCINFO_INODE-1,K199) END IF ENDIF RETURN END FUNCTION MUMPS_PROCNODE INTEGER FUNCTION MUMPS_TYPESPLIT (PROCINFO_INODE, K199) IMPLICIT NONE INTEGER, intent(in) :: K199 INTEGER PROCINFO_INODE, TPN IF (K199 < 0) THEN TPN = ishft(PROCINFO_INODE,-24) - 1 IF (TPN < 1 ) TPN = 1 ELSE IF (PROCINFO_INODE <= K199 ) THEN TPN = 1 ELSE TPN = (PROCINFO_INODE-1+2*K199)/K199 - 1 IF ( TPN .LT. 1 ) TPN = 1 ENDIF ENDIF MUMPS_TYPESPLIT = TPN RETURN END FUNCTION MUMPS_TYPESPLIT LOGICAL FUNCTION MUMPS_ROOTSSARBR( PROCINFO_INODE, K199 ) IMPLICIT NONE INTEGER K199 INTEGER TPN, PROCINFO_INODE IF (K199 < 0) THEN TPN = ishft(PROCINFO_INODE,-24) - 1 ELSE TPN = (PROCINFO_INODE-1+2*K199)/K199 - 1 ENDIF MUMPS_ROOTSSARBR = ( TPN .eq. 0 ) RETURN END FUNCTION MUMPS_ROOTSSARBR LOGICAL FUNCTION MUMPS_INSSARBR( PROCINFO_INODE, K199 ) IMPLICIT NONE INTEGER K199 INTEGER TPN, PROCINFO_INODE IF (K199 < 0) THEN TPN = ishft(PROCINFO_INODE,-24) - 1 ELSE TPN = (PROCINFO_INODE-1+K199+K199)/K199 - 1 ENDIF MUMPS_INSSARBR = ( TPN .eq. -1 ) RETURN END FUNCTION MUMPS_INSSARBR LOGICAL FUNCTION MUMPS_IN_OR_ROOT_SSARBR & ( PROCINFO_INODE, K199 ) IMPLICIT NONE INTEGER K199 INTEGER TPN, PROCINFO_INODE IF (K199 < 0) THEN TPN = ishft(PROCINFO_INODE,-24) - 1 ELSE TPN = (PROCINFO_INODE-1+K199+K199)/K199 - 1 ENDIF MUMPS_IN_OR_ROOT_SSARBR = & ( TPN .eq. -1 .OR. TPN .eq. 0 ) RETURN END FUNCTION MUMPS_IN_OR_ROOT_SSARBR SUBROUTINE MUMPS_SET_SSARBR_DAD( & SSARBR, INODE, DAD, N, & KEEP28, & STEP, PROCNODE_STEPS, K199) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP28, K199, INODE INTEGER, INTENT(IN) :: DAD(KEEP28), PROCNODE_STEPS(KEEP28) INTEGER, INTENT(IN) :: STEP(N) LOGICAL, INTENT(OUT) :: SSARBR INTEGER :: DADINODE, TYPEDAD LOGICAL, EXTERNAL :: MUMPS_INSSARBR INTEGER, EXTERNAL :: MUMPS_TYPENODE SSARBR = .FALSE. DADINODE = DAD(STEP(INODE)) IF (DADINODE .NE. 0) THEN TYPEDAD = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DADINODE)), & K199) IF (TYPEDAD.EQ.1) THEN SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(DADINODE)), & K199) ENDIF ENDIF RETURN END SUBROUTINE MUMPS_SET_SSARBR_DAD LOGICAL FUNCTION MUMPS_I_AM_CANDIDATE( MYID, SLAVEF, INODE, & NMB_PAR2, ISTEP_TO_INIV2 , K71, STEP, N, & CANDIDATES, KEEP24 ) IMPLICIT NONE INTEGER MYID, SLAVEF, INODE, NMB_PAR2, KEEP24, I INTEGER K71, N INTEGER ISTEP_TO_INIV2 ( K71 ), STEP ( N ) INTEGER CANDIDATES(SLAVEF+1, max(NMB_PAR2,1)) INTEGER NCAND, POSINODE MUMPS_I_AM_CANDIDATE = .FALSE. IF (KEEP24 .eq. 0) RETURN POSINODE = ISTEP_TO_INIV2 ( STEP (INODE) ) NCAND = CANDIDATES( SLAVEF+1, POSINODE ) DO I = 1, NCAND IF (MYID .EQ. CANDIDATES( I, POSINODE )) & MUMPS_I_AM_CANDIDATE = .TRUE. END DO RETURN END FUNCTION MUMPS_I_AM_CANDIDATE SUBROUTINE MUMPS_SECDEB(T) DOUBLE PRECISION T DOUBLE PRECISION MPI_WTIME EXTERNAL MPI_WTIME T=MPI_WTIME() RETURN END SUBROUTINE MUMPS_SECDEB SUBROUTINE MUMPS_SECFIN(T) DOUBLE PRECISION T DOUBLE PRECISION MPI_WTIME EXTERNAL MPI_WTIME T=MPI_WTIME()-T RETURN END SUBROUTINE MUMPS_SECFIN SUBROUTINE MUMPS_SORT_DOUBLES( N, VAL, ID ) INTEGER N INTEGER ID( N ) DOUBLE PRECISION VAL( N ) INTEGER I, ISWAP DOUBLE PRECISION SWAP LOGICAL DONE DONE = .FALSE. DO WHILE ( .NOT. DONE ) DONE = .TRUE. DO I = 1, N - 1 IF ( VAL( I ) .GT. VAL( I + 1 ) ) THEN DONE = .FALSE. ISWAP = ID( I ) ID ( I ) = ID ( I + 1 ) ID ( I + 1 ) = ISWAP SWAP = VAL( I ) VAL( I ) = VAL( I + 1 ) VAL( I + 1 ) = SWAP END IF END DO END DO RETURN END SUBROUTINE MUMPS_SORT_DOUBLES SUBROUTINE MUMPS_SORT_DOUBLES_DEC( N, VAL, ID ) INTEGER N INTEGER ID( N ) DOUBLE PRECISION VAL( N ) INTEGER I, ISWAP DOUBLE PRECISION SWAP LOGICAL DONE DONE = .FALSE. DO WHILE ( .NOT. DONE ) DONE = .TRUE. DO I = 1, N - 1 IF ( VAL( I ) .LT. VAL( I + 1 ) ) THEN DONE = .FALSE. ISWAP = ID( I ) ID ( I ) = ID ( I + 1 ) ID ( I + 1 ) = ISWAP SWAP = VAL( I ) VAL( I ) = VAL( I + 1 ) VAL( I + 1 ) = SWAP END IF END DO END DO RETURN END SUBROUTINE MUMPS_SORT_DOUBLES_DEC SUBROUTINE MUMPS_MEM_CENTRALIZE(MYID, COMM, INFO, INFOG, IRANK) IMPLICIT NONE INTEGER MYID, COMM, IRANK, INFO, INFOG(2) INCLUDE 'mpif.h' INTEGER IERR_MPI, MASTER #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) :: TEMP1(2),TEMP2(2) #else INTEGER :: TEMP1(2),TEMP2(2) #endif PARAMETER( MASTER = 0 ) CALL MPI_REDUCE( INFO, INFOG(1), 1, MPI_INTEGER, & MPI_MAX, MASTER, COMM, IERR_MPI ) CALL MPI_REDUCE( INFO, INFOG(2), 1, MPI_INTEGER, & MPI_SUM, MASTER, COMM, IERR_MPI ) TEMP1(1) = INFO TEMP1(2) = MYID CALL MPI_REDUCE( TEMP1, TEMP2, 1, MPI_2INTEGER, & MPI_MAXLOC, MASTER, COMM, IERR_MPI ) IF ( MYID.eq. MASTER ) THEN IF ( INFOG(1) .ne. TEMP2(1) ) THEN write(*,*) 'Error in MUMPS_MEM_CENTRALIZE' CALL MUMPS_ABORT() END IF IRANK = TEMP2(2) ELSE IRANK = -1 END IF RETURN END SUBROUTINE MUMPS_MEM_CENTRALIZE INTEGER FUNCTION MUMPS_GET_POOL_LENGTH & (MAX_ACTIVE_NODES,KEEP,KEEP8) IMPLICIT NONE INTEGER MAX_ACTIVE_NODES INTEGER KEEP(500) INTEGER(8) KEEP8(150) MUMPS_GET_POOL_LENGTH = MAX_ACTIVE_NODES + 1 + 3 RETURN END FUNCTION MUMPS_GET_POOL_LENGTH SUBROUTINE MUMPS_INIT_POOL_DIST_BWD(N, & nb_prun_roots, Pruned_Roots, & MYROOT, MYID_NODES, & KEEP, KEEP8, STEP, PROCNODE_STEPS, & IPOOL, LPOOL ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, MYID_NODES, LPOOL, nb_prun_roots INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT(IN) :: Pruned_Roots(nb_prun_roots) INTEGER, INTENT(OUT) :: MYROOT INTEGER, INTENT(OUT) :: IPOOL(LPOOL) INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER :: I, INODE MYROOT = 0 DO I = nb_prun_roots, 1, -1 INODE = Pruned_Roots(I) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) .EQ. MYID_NODES) THEN MYROOT = MYROOT + 1 IPOOL(MYROOT) = INODE ENDIF END DO RETURN END SUBROUTINE MUMPS_INIT_POOL_DIST_BWD SUBROUTINE MUMPS_INIT_POOL_DIST_BWD_L0(N, & nb_prun_roots, Pruned_Roots, & MYROOT, MYID_NODES, & KEEP, KEEP8, STEP, PROCNODE_STEPS, & IPOOL, LPOOL, TO_PROCESS ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, MYID_NODES, LPOOL, nb_prun_roots INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) LOGICAL, INTENT(IN) :: TO_PROCESS(KEEP(28)) INTEGER, INTENT(IN) :: Pruned_Roots(nb_prun_roots) INTEGER, INTENT(OUT) :: MYROOT INTEGER, INTENT(OUT) :: IPOOL(LPOOL) INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER :: I, INODE MYROOT = 0 DO I = nb_prun_roots, 1, -1 INODE = Pruned_Roots(I) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) .EQ. MYID_NODES) THEN IF ( TO_PROCESS(STEP(INODE)) ) THEN MYROOT = MYROOT + 1 IPOOL(MYROOT) = INODE ENDIF ENDIF END DO RETURN END SUBROUTINE MUMPS_INIT_POOL_DIST_BWD_L0 SUBROUTINE MUMPS_INIT_POOL_DIST_NA_BWD(N, MYROOT, MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IPOOL, LPOOL ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, MYID_NODES, LPOOL, LNA INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), NA(LNA) INTEGER, INTENT(OUT) :: IPOOL(LPOOL) INTEGER, INTENT(OUT) :: MYROOT INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER :: NBLEAF, NBROOT, I, INODE NBLEAF = NA(1) NBROOT = NA(2) MYROOT = 0 DO I = NBROOT, 1, -1 INODE = NA(NBLEAF+I+2) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) .EQ. MYID_NODES) THEN MYROOT = MYROOT + 1 IPOOL(MYROOT) = INODE ENDIF END DO RETURN END SUBROUTINE MUMPS_INIT_POOL_DIST_NA_BWD SUBROUTINE MUMPS_INIT_POOL_DIST_NA_BWD_L0(N, MYROOT, MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IPOOL, LPOOL, L0_OMP_MAPPING ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, MYID_NODES, LPOOL, LNA INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), NA(LNA) INTEGER, INTENT(IN) :: L0_OMP_MAPPING(KEEP(28)) INTEGER, INTENT(OUT) :: IPOOL(LPOOL) INTEGER, INTENT(OUT) :: MYROOT INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER :: NBLEAF, NBROOT, I, INODE NBLEAF = NA(1) NBROOT = NA(2) MYROOT = 0 DO I = NBROOT, 1, -1 INODE = NA(NBLEAF+I+2) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) .EQ. MYID_NODES) THEN IF ( L0_OMP_MAPPING(STEP(INODE)).EQ.0 ) THEN MYROOT = MYROOT + 1 IPOOL(MYROOT) = INODE ENDIF ENDIF END DO RETURN END SUBROUTINE MUMPS_INIT_POOL_DIST_NA_BWD_L0 SUBROUTINE MUMPS_INIT_POOL_DIST_NA_BWDL0ES(N, MYROOT, & MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IPOOL, LPOOL, L0_OMP_MAPPING, TO_PROCESS ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, MYID_NODES, LPOOL, LNA INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), NA(LNA) INTEGER, INTENT(IN) :: L0_OMP_MAPPING(KEEP(28)) INTEGER, INTENT(OUT) :: IPOOL(LPOOL) INTEGER, INTENT(OUT) :: MYROOT LOGICAL, INTENT(IN) :: TO_PROCESS( KEEP(28) ) INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER :: NBLEAF, NBROOT, I, INODE NBLEAF = NA(1) NBROOT = NA(2) MYROOT = 0 DO I = NBROOT, 1, -1 INODE = NA(NBLEAF+I+2) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) .EQ. MYID_NODES) THEN IF ( L0_OMP_MAPPING(STEP(INODE)).EQ.0 ) THEN IF ( TO_PROCESS( STEP(INODE) ) ) THEN MYROOT = MYROOT + 1 IPOOL(MYROOT) = INODE ENDIF ENDIF ENDIF END DO RETURN END SUBROUTINE MUMPS_INIT_POOL_DIST_NA_BWDL0ES SUBROUTINE MUMPS_INIT_POOL_DIST(N, LEAF, & MYID_NODES, & K199, NA, LNA, KEEP,KEEP8, STEP, & PROCNODE_STEPS, IPOOL, LPOOL) IMPLICIT NONE INTEGER N, LEAF, MYID_NODES, & K199, LPOOL, LNA INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)), NA(LNA), & IPOOL(LPOOL) INTEGER NBLEAF, INODE, I INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE NBLEAF = NA(1) LEAF = 1 DO I = 1, NBLEAF INODE = NA(I+2) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) & .EQ.MYID_NODES) THEN IPOOL(LEAF) = INODE LEAF = LEAF + 1 ENDIF ENDDO RETURN END SUBROUTINE MUMPS_INIT_POOL_DIST SUBROUTINE MUMPS_INIT_POOL_DIST_NONA & (N, LEAF, MYID_NODES, & LLEAVES, LEAVES, KEEP,KEEP8, STEP, & PROCNODE_STEPS, IPOOL, LPOOL) IMPLICIT NONE INTEGER N, LEAF, MYID_NODES, & LPOOL, LLEAVES INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)), LEAVES(LLEAVES), & IPOOL(LPOOL) INTEGER I, INODE INTEGER, EXTERNAL :: MUMPS_PROCNODE LEAF = 1 DO I = 1, LLEAVES INODE = LEAVES(I) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) & .EQ.MYID_NODES ) THEN IPOOL( LEAF ) = INODE LEAF = LEAF + 1 ENDIF ENDDO RETURN END SUBROUTINE MUMPS_INIT_POOL_DIST_NONA SUBROUTINE MUMPS_INIT_NROOT_DIST(N, NBROOT, & NROOT_LOC, MYID_NODES, & SLAVEF, NA, LNA, KEEP, STEP, & PROCNODE_STEPS) IMPLICIT NONE INTEGER, INTENT( OUT ) :: NROOT_LOC INTEGER, INTENT( OUT ) :: NBROOT INTEGER, INTENT( IN ) :: KEEP( 500 ) INTEGER, INTENT( IN ) :: SLAVEF INTEGER, INTENT( IN ) :: N INTEGER, INTENT( IN ) :: STEP(N) INTEGER, INTENT( IN ) :: LNA INTEGER, INTENT( IN ) :: NA(LNA) INTEGER, INTENT( IN ) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT( IN ) :: MYID_NODES INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER :: INODE, I, NBLEAF NBLEAF = NA(1) NBROOT = NA(2) NROOT_LOC = 0 DO I = 1, NBROOT INODE = NA(I+2+NBLEAF) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)).EQ.MYID_NODES) THEN NROOT_LOC = NROOT_LOC + 1 END IF ENDDO RETURN END SUBROUTINE MUMPS_INIT_NROOT_DIST SUBROUTINE MUMPS_NBLOCAL_ROOTS_OR_LEAVES & (N, NBRORL, RORL_LIST, & NRORL_LOC, MYID_NODES, & SLAVEF, KEEP, STEP, & PROCNODE_STEPS) IMPLICIT NONE INTEGER, INTENT( OUT ) :: NRORL_LOC INTEGER, INTENT( IN ) :: NBRORL INTEGER, INTENT( IN ) :: RORL_LIST(NBRORL) INTEGER, INTENT( IN ) :: KEEP( 500 ) INTEGER, INTENT( IN ) :: SLAVEF INTEGER, INTENT( IN ) :: N INTEGER, INTENT( IN ) :: STEP(N) INTEGER, INTENT( IN ) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT( IN ) :: MYID_NODES INTEGER I, INODE INTEGER, EXTERNAL :: MUMPS_PROCNODE NRORL_LOC = 0 DO I = 1, NBRORL INODE = RORL_LIST(I) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)).EQ.MYID_NODES) THEN NRORL_LOC = NRORL_LOC + 1 END IF ENDDO RETURN END SUBROUTINE MUMPS_NBLOCAL_ROOTS_OR_LEAVES LOGICAL FUNCTION MUMPS_COMPARE_TAB(TAB1,TAB2,LEN1,LEN2) IMPLICIT NONE INTEGER LEN1 , LEN2 ,I INTEGER TAB1(LEN1) INTEGER TAB2(LEN2) MUMPS_COMPARE_TAB=.FALSE. IF(LEN1 .NE. LEN2) THEN RETURN ENDIF DO I=1 , LEN1 IF(TAB1(I) .NE. TAB2(I)) THEN RETURN ENDIF ENDDO MUMPS_COMPARE_TAB=.TRUE. RETURN END FUNCTION MUMPS_COMPARE_TAB SUBROUTINE MUMPS_SORT_INT( N, VAL, ID ) INTEGER N INTEGER ID( N ) INTEGER VAL( N ) INTEGER I, ISWAP INTEGER SWAP LOGICAL DONE DONE = .FALSE. DO WHILE ( .NOT. DONE ) DONE = .TRUE. DO I = 1, N - 1 IF ( VAL( I ) .GT. VAL( I + 1 ) ) THEN DONE = .FALSE. ISWAP = ID( I ) ID ( I ) = ID ( I + 1 ) ID ( I + 1 ) = ISWAP SWAP = VAL( I ) VAL( I ) = VAL( I + 1 ) VAL( I + 1 ) = SWAP END IF END DO END DO RETURN END SUBROUTINE MUMPS_SORT_INT SUBROUTINE MUMPS_SORT_INT_DEC( N, VAL, ID ) INTEGER N INTEGER ID( N ) INTEGER VAL( N ) INTEGER I, ISWAP INTEGER SWAP LOGICAL DONE DONE = .FALSE. DO WHILE ( .NOT. DONE ) DONE = .TRUE. DO I = 1, N - 1 IF ( VAL( I ) .LT. VAL( I + 1 ) ) THEN DONE = .FALSE. ISWAP = ID( I ) ID ( I ) = ID ( I + 1 ) ID ( I + 1 ) = ISWAP SWAP = VAL( I ) VAL( I ) = VAL( I + 1 ) VAL( I + 1 ) = SWAP END IF END DO END DO RETURN END SUBROUTINE MUMPS_SORT_INT_DEC SUBROUTINE MUMPS_SORT_INT8( N, VAL, ID ) INTEGER N INTEGER ID( N ) INTEGER(8) :: VAL( N ) INTEGER I, ISWAP INTEGER(8) SWAP LOGICAL DONE DONE = .FALSE. DO WHILE ( .NOT. DONE ) DONE = .TRUE. DO I = 1, N - 1 IF ( VAL( I ) .GT. VAL( I + 1 ) ) THEN DONE = .FALSE. ISWAP = ID( I ) ID ( I ) = ID ( I + 1 ) ID ( I + 1 ) = ISWAP SWAP = VAL( I ) VAL( I ) = VAL( I + 1 ) VAL( I + 1 ) = SWAP END IF END DO END DO RETURN END SUBROUTINE MUMPS_SORT_INT8 SUBROUTINE MUMPS_ABORT() #if defined(PRINT_BACKTRACE_ON_ABORT) #if defined(__INTEL_COMPILER) USE IFCORE #endif IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR, IERRCODE #if defined(__GFORTRAN__) CALL BACKTRACE() #endif #if defined(__INTEL_COMPILER) !$OMP CRITICAL(MUMPS_TRACEBACKQQ) CALL TRACEBACKQQ("MUMPS_ABORT calls TRACEBACKQQ:", & user_exit_code=-1) !$OMP END CRITICAL(MUMPS_TRACEBACKQQ) #endif #else IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR, IERRCODE #endif IERRCODE = -99 CALL MPI_ABORT(MPI_COMM_WORLD, IERRCODE, IERR) RETURN END SUBROUTINE MUMPS_ABORT SUBROUTINE MUMPS_GET_PERLU(KEEP12,ICNTL14, & KEEP50,KEEP54,ICNTL6,ICNTL8) IMPLICIT NONE INTEGER, intent(out)::KEEP12 INTEGER, intent(in)::ICNTL14,KEEP50,KEEP54,ICNTL6,ICNTL8 KEEP12 = ICNTL14 RETURN END SUBROUTINE MUMPS_GET_PERLU SUBROUTINE MUMPS_REDUCEI8( IN, OUT, MPI_OP, ROOT, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER ROOT, COMM, MPI_OP INTEGER(8) IN, OUT INTEGER IERR DOUBLE PRECISION DIN, DOUT DIN =dble(IN) DOUT=0.0D0 CALL MPI_REDUCE(DIN, DOUT, 1, MPI_DOUBLE_PRECISION, & MPI_OP, ROOT, COMM, IERR) OUT=int(DOUT,kind=8) RETURN END SUBROUTINE MUMPS_REDUCEI8 SUBROUTINE MUMPS_ALLREDUCEI8( IN, OUT, MPI_OP, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, MPI_OP INTEGER(8) IN, OUT INTEGER IERR DOUBLE PRECISION DIN, DOUT DIN =dble(IN) DOUT=0.0D0 CALL MPI_ALLREDUCE(DIN, DOUT, 1, MPI_DOUBLE_PRECISION, & MPI_OP, COMM, IERR) OUT=int(DOUT,kind=8) RETURN END SUBROUTINE MUMPS_ALLREDUCEI8 SUBROUTINE MUMPS_SETI8TOI4(I8, I) IMPLICIT NONE INTEGER , INTENT(OUT) :: I INTEGER(8), INTENT(IN) :: I8 IF ( I8 .GT. int(huge(I),8) ) THEN I = -int(I8/1000000_8,kind(I)) ELSE I = int(I8,kind(I)) ENDIF RETURN END SUBROUTINE MUMPS_SETI8TOI4 SUBROUTINE MUMPS_ABORT_ON_OVERFLOW(I8, STRING) IMPLICIT NONE INTEGER(8), INTENT(IN) :: I8 CHARACTER(*), INTENT(IN) :: STRING INTEGER I IF ( I8 .GT. int(huge(I),8)) THEN WRITE(*,*) STRING CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE MUMPS_ABORT_ON_OVERFLOW SUBROUTINE MUMPS_SET_IERROR( SIZE8, IERROR ) INTEGER(8), INTENT(IN) :: SIZE8 INTEGER, INTENT(OUT) :: IERROR CALL MUMPS_SETI8TOI4(SIZE8, IERROR) RETURN END SUBROUTINE MUMPS_SET_IERROR SUBROUTINE MUMPS_STOREI8(I8, INT_ARRAY) IMPLICIT NONE INTEGER(8), intent(in) :: I8 INTEGER, intent(out) :: INT_ARRAY(2) INTEGER(kind(0_4)) :: I32 INTEGER(8) :: IDIV, IPAR PARAMETER (IPAR=int(huge(I32),8)) PARAMETER (IDIV=IPAR+1_8) IF ( I8 .LT. IDIV ) THEN INT_ARRAY(1) = 0 INT_ARRAY(2) = int(I8) ELSE INT_ARRAY(1) = int(I8 / IDIV) INT_ARRAY(2) = int(mod(I8,IDIV)) ENDIF RETURN END SUBROUTINE MUMPS_STOREI8 SUBROUTINE MUMPS_GETI8(I8, INT_ARRAY) IMPLICIT NONE INTEGER(8), intent(out) :: I8 INTEGER, intent(in) :: INT_ARRAY(2) INTEGER(kind(0_4)) :: I32 INTEGER(8) :: IDIV, IPAR PARAMETER (IPAR=int(huge(I32),8)) PARAMETER (IDIV=IPAR+1_8) IF ( INT_ARRAY(1) .EQ. 0 ) THEN I8=int(INT_ARRAY(2),8) ELSE I8=int(INT_ARRAY(1),8)*IDIV+int(INT_ARRAY(2),8) ENDIF RETURN END SUBROUTINE MUMPS_GETI8 SUBROUTINE MUMPS_ADDI8TOARRAY( INT_ARRAY, I8 ) IMPLICIT NONE INTEGER(8), intent(in) :: I8 INTEGER, intent(inout) :: INT_ARRAY(2) INTEGER(8) :: I8TMP CALL MUMPS_GETI8(I8TMP, INT_ARRAY) I8TMP = I8TMP + I8 CALL MUMPS_STOREI8(I8TMP, INT_ARRAY) RETURN END SUBROUTINE MUMPS_ADDI8TOARRAY SUBROUTINE MUMPS_SUBTRI8TOARRAY( INT_ARRAY, I8 ) IMPLICIT NONE INTEGER(8), intent(in) :: I8 INTEGER, intent(inout) :: INT_ARRAY(2) INTEGER(8) :: I8TMP CALL MUMPS_GETI8(I8TMP, INT_ARRAY) I8TMP = I8TMP - I8 CALL MUMPS_STOREI8(I8TMP, INT_ARRAY) RETURN END SUBROUTINE MUMPS_SUBTRI8TOARRAY FUNCTION MUMPS_SEQANA_AVAIL(ICNTL7) LOGICAL :: MUMPS_SEQANA_AVAIL INTEGER, INTENT(IN) :: ICNTL7 LOGICAL :: SCOTCH=.FALSE. LOGICAL :: METIS =.FALSE. #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) METIS = .TRUE. #endif #if defined(scotch) || defined(ptscotch) SCOTCH = .TRUE. #endif IF ( ICNTL7 .LT. 0 .OR. ICNTL7 .GT. 7 ) THEN MUMPS_SEQANA_AVAIL = .FALSE. ELSE MUMPS_SEQANA_AVAIL = .TRUE. ENDIF IF ( ICNTL7 .EQ. 5 ) MUMPS_SEQANA_AVAIL = METIS IF ( ICNTL7 .EQ. 3 ) MUMPS_SEQANA_AVAIL = SCOTCH RETURN END FUNCTION MUMPS_SEQANA_AVAIL FUNCTION MUMPS_PARANA_AVAIL(WHICH) LOGICAL :: MUMPS_PARANA_AVAIL CHARACTER :: WHICH*(*) LOGICAL :: PTSCOTCH=.FALSE., PARMETIS=.FALSE. #if defined(ptscotch) PTSCOTCH = .TRUE. #endif #if defined(parmetis) || defined(parmetis3) PARMETIS = .TRUE. #endif SELECT CASE(WHICH) CASE('ptscotch','PTSCOTCH') MUMPS_PARANA_AVAIL = PTSCOTCH CASE('parmetis','PARMETIS') MUMPS_PARANA_AVAIL = PARMETIS CASE('both','BOTH') MUMPS_PARANA_AVAIL = PTSCOTCH .AND. PARMETIS CASE('any','ANY') MUMPS_PARANA_AVAIL = PTSCOTCH .OR. PARMETIS CASE default write(*,'("Invalid input in MUMPS_PARANA_AVAIL")') END SELECT RETURN END FUNCTION MUMPS_PARANA_AVAIL SUBROUTINE MUMPS_SORT_STEP(N,FRERE,STEP,FILS, & NA,LNA,NE,ND,DAD,LDAD,USE_DAD, & NSTEPS,INFO,LP, & PROCNODE,SLAVEF & ) IMPLICIT NONE INTEGER N, NSTEPS, LNA, LP,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) INTEGER POSTORDER,TMP_SWAP INTEGER, DIMENSION (:), ALLOCATABLE :: STEP_TO_NODE INTEGER, DIMENSION (:), ALLOCATABLE :: IPOOL,TNSTK INTEGER I,II,allocok INTEGER NBLEAF,NBROOT,LEAF,IN,INODE,IFATH POSTORDER=1 NBLEAF = NA(1) NBROOT = NA(2) ALLOCATE( IPOOL(NBLEAF), TNSTK(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in MUMPS_SORT_STEP' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DO I=1,NSTEPS TNSTK(I) = NE(I) ENDDO ALLOCATE(STEP_TO_NODE(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in &MUMPS_SORT_STEP' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DO I=1,N IF(STEP(I).GT.0)THEN STEP_TO_NODE(STEP(I))=I ENDIF ENDDO IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 91 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 96 CONTINUE IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 113 IN = FRERE(IN) IF (IN.GT.0) GO TO 113 IFATH = -IN ENDIF TMP_SWAP=FRERE(STEP(INODE)) FRERE(STEP(INODE))=FRERE(POSTORDER) FRERE(POSTORDER)=TMP_SWAP TMP_SWAP=ND(STEP(INODE)) ND(STEP(INODE))=ND(POSTORDER) ND(POSTORDER)=TMP_SWAP TMP_SWAP=NE(STEP(INODE)) NE(STEP(INODE))=NE(POSTORDER) NE(POSTORDER)=TMP_SWAP TMP_SWAP=PROCNODE(STEP(INODE)) PROCNODE(STEP(INODE))=PROCNODE(POSTORDER) PROCNODE(POSTORDER)=TMP_SWAP IF(USE_DAD)THEN TMP_SWAP=DAD(STEP(INODE)) DAD(STEP(INODE))=DAD(POSTORDER) DAD(POSTORDER)=TMP_SWAP ENDIF TMP_SWAP=TNSTK(STEP(INODE)) TNSTK(STEP(INODE))=TNSTK(POSTORDER) TNSTK(POSTORDER)=TMP_SWAP II=STEP_TO_NODE(POSTORDER) TMP_SWAP=STEP(INODE) STEP(STEP_TO_NODE(POSTORDER))=TMP_SWAP STEP(INODE)=POSTORDER STEP_TO_NODE(POSTORDER)=INODE STEP_TO_NODE(TMP_SWAP)=II IN=II 101 IN = FILS(IN) IF (IN .GT. 0 ) THEN STEP(IN)=-STEP(II) GOTO 101 ENDIF IN=INODE 102 IN = FILS(IN) IF (IN .GT. 0 ) THEN STEP(IN)=-STEP(INODE) GOTO 102 ENDIF POSTORDER = POSTORDER + 1 IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 116 GOTO 91 ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH GOTO 96 ELSE GOTO 91 ENDIF 116 CONTINUE DEALLOCATE(STEP_TO_NODE) DEALLOCATE(IPOOL,TNSTK) RETURN END SUBROUTINE MUMPS_SORT_STEP SUBROUTINE MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IMPLICIT NONE INTEGER, INTENT(IN) :: COMM_NODES LOGICAL, INTENT(OUT) :: EXIT_FLAG INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: STATUS(MPI_STATUS_SIZE), IERR CALL MPI_IPROBE( MPI_ANY_SOURCE, TERREUR, COMM_NODES, & EXIT_FLAG, STATUS, IERR) RETURN END SUBROUTINE MUMPS_CHECK_COMM_NODES SUBROUTINE MUMPS_GET_PROC_PER_NODE(K414, MyID, NbProcs, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER :: K414, MyID, NbProcs, COMM, ALLOCOK INTEGER :: ierr,MyNAME_length,MyNAME_length_RCV,i,j CHARACTER(len=MPI_MAX_PROCESSOR_NAME) :: MyNAME CHARACTER, dimension(:), allocatable :: MyNAME_TAB,MyNAME_TAB_RCV logical :: SAME_NAME call MPI_GET_PROCESSOR_NAME(MyNAME, MyNAME_length, ierr) allocate(MyNAME_TAB(MyNAME_length), STAT=ALLOCOK) IF(ALLOCOK.LT.0) THEN write(*,*) "Allocation error in MUMPS_GET_PROC_PER_NODE" call MUMPS_ABORT() ENDIF DO i=1, MyNAME_length MyNAME_TAB(i) = MyNAME(i:i) ENDDO K414=0 do i=0, NbProcs-1 if(MyID .eq. i) then MyNAME_length_RCV = MyNAME_length else MyNAME_length_RCV = 0 endif call MPI_BCAST(MyNAME_length_RCV,1,MPI_INTEGER, & i,COMM,ierr) allocate(MyNAME_TAB_RCV(MyNAME_length_RCV), STAT=ALLOCOK) IF(ALLOCOK.LT.0) THEN write(*,*) "Allocation error in MUMPS_GET_PROC_PER_NODE" call MUMPS_ABORT() ENDIF if(MyID .eq. i) then MyNAME_TAB_RCV = MyNAME_TAB endif call MPI_BCAST(MyNAME_TAB_RCV,MyNAME_length_RCV,MPI_CHARACTER, & i,COMM,ierr) SAME_NAME=.FALSE. IF(MyNAME_length .EQ. MyNAME_length_RCV) THEN DO j=1, MyNAME_length IF(MyNAME_TAB(j) .NE. MyNAME_TAB_RCV(j)) THEN goto 100 ENDIF ENDDO SAME_NAME=.TRUE. ENDIF 100 continue IF(SAME_NAME) K414=K414+1 deallocate(MyNAME_TAB_RCV) enddo deallocate(MyNAME_TAB) END SUBROUTINE MUMPS_GET_PROC_PER_NODE SUBROUTINE MUMPS_ICOPY_32TO64 (INTAB, SIZETAB, OUTTAB8) IMPLICIT NONE INTEGER, intent(in) :: SIZETAB INTEGER, intent(in) :: INTAB(SIZETAB) INTEGER(8), intent(out) :: OUTTAB8(SIZETAB) INTEGER :: I DO I=1,SIZETAB OUTTAB8(I) = int(INTAB(I),8) ENDDO RETURN END SUBROUTINE MUMPS_ICOPY_32TO64 SUBROUTINE MUMPS_ICOPY_32TO64_64C(INTAB, SIZETAB8, OUTTAB8) IMPLICIT NONE INTEGER(8), intent(in) :: SIZETAB8 INTEGER, intent(in) :: INTAB(SIZETAB8) INTEGER(8), intent(out) :: OUTTAB8(SIZETAB8) INTEGER(8) :: I8 LOGICAL :: OMP_FLAG OMP_FLAG = (SIZETAB8 .GE.500000_8 ) !$OMP PARALLEL DO PRIVATE(I8) !$OMP& IF(OMP_FLAG) DO I8=1_8, SIZETAB8 OUTTAB8(I8) = int(INTAB(I8),8) ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE MUMPS_ICOPY_32TO64_64C SUBROUTINE MUMPS_ICOPY_32TO64_64C_IP(IN_OUT_TAB48, SIZETAB, & SIZETABX2 ) IMPLICIT NONE INTEGER(8), intent(in) :: SIZETAB, SIZETABX2 INTEGER, intent(inout) :: IN_OUT_TAB48(SIZETABX2) CALL MUMPS_ICOPY_32TO64_64C_IP_REC(IN_OUT_TAB48, SIZETAB, & SIZETABX2) RETURN END SUBROUTINE MUMPS_ICOPY_32TO64_64C_IP RECURSIVE SUBROUTINE MUMPS_ICOPY_32TO64_64C_IP_REC( & IN_OUT_TAB48, SIZETAB, SIZETABX2) IMPLICIT NONE INTEGER(8), intent(in) :: SIZETAB, SIZETABX2 INTEGER :: IN_OUT_TAB48(SIZETABX2) INTEGER(8) :: IBEG24, IBEG28, SIZE1, SIZE2 IF (SIZETAB.LE. 1000_8) THEN CALL MUMPS_ICOPY_32TO64_64C_IP_C(IN_OUT_TAB48, & SIZETAB) ELSE SIZE2 = SIZETAB / 2 SIZE1 = SIZETAB - SIZE2 IBEG24 = SIZE1+1 IBEG28 = 2*SIZE1+1_8 CALL MUMPS_ICOPY_32TO64_64C(IN_OUT_TAB48(IBEG24), & SIZE2, IN_OUT_TAB48(IBEG28)) CALL MUMPS_ICOPY_32TO64_64C_IP_REC(IN_OUT_TAB48, & SIZE1, 2_8*SIZE1) ENDIF RETURN END SUBROUTINE MUMPS_ICOPY_32TO64_64C_IP_REC SUBROUTINE MUMPS_ICOPY_64TO32(INTAB8, SIZETAB, OUTTAB) IMPLICIT NONE INTEGER, intent(in) :: SIZETAB INTEGER(8), intent(in) :: INTAB8(SIZETAB) INTEGER, intent(out) :: OUTTAB(SIZETAB) INTEGER :: I DO I=1,SIZETAB OUTTAB(I) = int(INTAB8(I)) ENDDO RETURN END SUBROUTINE MUMPS_ICOPY_64TO32 SUBROUTINE MUMPS_ICOPY_64TO32_64C (INTAB8, SIZETAB, OUTTAB) IMPLICIT NONE INTEGER(8), intent(in) :: SIZETAB INTEGER(8), intent(in) :: INTAB8(SIZETAB) INTEGER, intent(out) :: OUTTAB(SIZETAB) INTEGER(8) :: I8 DO I8=1_8,SIZETAB OUTTAB(I8) = int(INTAB8(I8)) ENDDO RETURN END SUBROUTINE MUMPS_ICOPY_64TO32_64C SUBROUTINE MUMPS_ICOPY_64TO32_64C_IP(IN_OUT_TAB48, SIZETAB, & SIZETABX2) IMPLICIT NONE INTEGER(8), intent(in) :: SIZETAB, SIZETABX2 INTEGER, intent(inout) :: IN_OUT_TAB48(SIZETABX2) CALL MUMPS_ICOPY_64TO32_64C_IP_REC(IN_OUT_TAB48, SIZETAB, & SIZETABX2) RETURN END SUBROUTINE MUMPS_ICOPY_64TO32_64C_IP RECURSIVE SUBROUTINE MUMPS_ICOPY_64TO32_64C_IP_REC( & IN_OUT_TAB48, SIZETAB, SIZETABX2) IMPLICIT NONE INTEGER(8), intent(in) :: SIZETAB, SIZETABX2 INTEGER :: IN_OUT_TAB48(SIZETABX2) INTEGER(8) :: IBEG24, IBEG28, SIZE1, SIZE2 IF (SIZETAB.LE. 1000_8) THEN CALL MUMPS_ICOPY_64TO32_64C_IP_C(IN_OUT_TAB48, & SIZETAB) ELSE SIZE2 = SIZETAB / 2 SIZE1 = SIZETAB - SIZE2 IBEG24 = SIZE1 + 1 IBEG28 = SIZE1 + SIZE1 + 1_8 CALL MUMPS_ICOPY_64TO32_64C_IP_REC(IN_OUT_TAB48, & SIZE1, 2_8*SIZE1) CALL MUMPS_ICOPY_64TO32_64C(IN_OUT_TAB48(IBEG28), & SIZE2, IN_OUT_TAB48(IBEG24)) ENDIF RETURN END SUBROUTINE MUMPS_ICOPY_64TO32_64C_IP_REC SUBROUTINE MUMPS_GET_NNZ_INTERNAL( NNZ, NZ, NNZ_i ) INTEGER , INTENT(IN) :: NZ INTEGER(8), INTENT(IN) :: NNZ INTEGER(8), INTENT(OUT) :: NNZ_i IF (NNZ > 0_8) THEN NNZ_i = NNZ ELSE NNZ_i = int(NZ, 8) ENDIF END SUBROUTINE MUMPS_GET_NNZ_INTERNAL SUBROUTINE MUMPS_NPIV_CRITICAL_PATH( & N, NSTEPS, STEP, FRERE, FILS, & NA, LNA, NE, KEEP127, MAXNPIVTREE ) IMPLICIT NONE INTEGER, intent(in) :: N, NSTEPS, LNA, KEEP127 INTEGER, intent(in) :: FRERE(NSTEPS), FILS(N), STEP(N) INTEGER, intent(in) :: NA(LNA), NE(NSTEPS) INTEGER, intent(out) :: MAXNPIVTREE INTEGER :: IFATH,INODE,ISON INTEGER :: NPIV,ILEAF,NBLEAF INTEGER, DIMENSION(:) , ALLOCATABLE :: MAXNPIV INTEGER :: I, allocok IF ( (NA(2).EQ.1) .AND. (NA(1).GT. max(int(N/20),10000)) ) THEN NPIV = max(N-NA(1),2) MAXNPIVTREE = int(log(real(NPIV))/log(real(2)))+max(KEEP127,2) MAXNPIVTREE = max (MAXNPIVTREE, KEEP127+1) RETURN ENDIF MAXNPIVTREE = -9999 ALLOCATE ( MAXNPIV(NSTEPS), stat=allocok) IF (allocok .gt.0) THEN WRITE(*, *) 'Allocation error in MUMPS_NPIV_CRITICAL_PATH' & ,NSTEPS CALL MUMPS_ABORT() ENDIF MAXNPIV = 0 NBLEAF = NA(1) DO ILEAF = 1, NBLEAF INODE = NA(2+ILEAF) 95 CONTINUE NPIV = 0 ISON = INODE 100 NPIV = NPIV + 1 ISON = FILS(ISON) IF (ISON .GT. 0 ) GOTO 100 ISON = -ISON MAXNPIV( STEP(INODE) ) = NPIV DO I = 1, NE(STEP(INODE)) MAXNPIV(STEP(INODE)) = max( MAXNPIV(STEP(INODE)), & NPIV + MAXNPIV(STEP(ISON)) ) ISON = FRERE(STEP(ISON)) ENDDO IFATH = INODE DO WHILE (IFATH .GT. 0) IFATH = FRERE(STEP(IFATH)) ENDDO IFATH = -IFATH IF (IFATH.EQ.0) THEN MAXNPIVTREE = max(MAXNPIVTREE, MAXNPIV(STEP(INODE))) ELSE IF (FRERE(STEP(INODE)) .LT. 0) THEN INODE = IFATH GOTO 95 ENDIF ENDIF ENDDO DEALLOCATE( MAXNPIV ) RETURN END SUBROUTINE MUMPS_NPIV_CRITICAL_PATH SUBROUTINE MUMPS_LDLTPANEL_NBTARGET( NPIV, NB_TARGET, KEEP ) IMPLICIT NONE INTEGER, INTENT(IN) :: NPIV INTEGER, INTENT(IN) :: KEEP(500) INTEGER, INTENT(OUT) :: NB_TARGET INTEGER :: NBPANELS, NBCOLMIN, NBPANELSMAX IF (NPIV .EQ. 0) THEN NB_TARGET = 0 ELSE NBCOLMIN = KEEP(460) NBPANELSMAX = KEEP(459) NBPANELS = min( (NPIV+NBCOLMIN-1) / NBCOLMIN, NBPANELSMAX ) NB_TARGET = ( NPIV+NBPANELS-1 ) / NBPANELS ENDIF RETURN END SUBROUTINE MUMPS_LDLTPANEL_NBTARGET SUBROUTINE MUMPS_LDLTPANEL_STORAGE & ( NPIV, KEEP, IW, NB_ENTRIES ) IMPLICIT NONE INTEGER, INTENT(IN) :: NPIV INTEGER, INTENT(IN) :: KEEP(500), IW(*) INTEGER(8), INTENT(OUT) :: NB_ENTRIES INTEGER :: NB_TARGET, NBCOLS_PANEL, NBROWS_PANEL INTEGER :: ICOL_BEG, ICOL_END, NBPANELS CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, NB_TARGET, KEEP ) NB_ENTRIES = 0_8 NBROWS_PANEL = NPIV ICOL_BEG = 1 NBPANELS = 0 DO WHILE ( ICOL_BEG .LE. NPIV ) NBPANELS = NBPANELS + 1 ICOL_END = min(NB_TARGET * NBPANELS, NPIV) IF (IW(1) .NE. 0) THEN IF ( IW( ICOL_END ) < 0 ) THEN ICOL_END = ICOL_END + 1 ENDIF ENDIF NBCOLS_PANEL = ICOL_END - ICOL_BEG + 1 NB_ENTRIES = NB_ENTRIES + int(NBCOLS_PANEL,8) * & int(NBROWS_PANEL,8) NBROWS_PANEL = NBROWS_PANEL - NBCOLS_PANEL ICOL_BEG = ICOL_END + 1 ENDDO RETURN END SUBROUTINE MUMPS_LDLTPANEL_STORAGE SUBROUTINE MUMPS_LDLTPANEL_PANELINFOS( NPIV, KEEP, IW, & NB_TARGET, NBPANELS, PANEL_COL, PANEL_POS, PANEL_TABSIZE, & IGNORE_K459 ) IMPLICIT NONE INTEGER, INTENT(IN) :: NPIV INTEGER, INTENT(IN) :: IW( NPIV ) INTEGER, INTENT(IN) :: KEEP(500) INTEGER, INTENT(IN) :: PANEL_TABSIZE INTEGER, INTENT(OUT) :: NB_TARGET, NBPANELS INTEGER, INTENT(OUT) :: PANEL_COL( PANEL_TABSIZE ) INTEGER(8), INTENT(OUT) :: PANEL_POS( PANEL_TABSIZE ) LOGICAL, INTENT(IN) :: IGNORE_K459 INTEGER :: IPANEL, ICOL_END, NBROWS_PANEL, NBCOLS_PANEL IF ( IGNORE_K459 ) THEN NB_TARGET = NPIV ELSE CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, NB_TARGET, KEEP ) ENDIF PANEL_POS(1) = 1_8 PANEL_COL(1) = 1 NBROWS_PANEL = NPIV NBPANELS = 1 IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 .AND. & NB_TARGET.NE.NPIV ) THEN NBPANELS = ( NPIV + NB_TARGET -1 ) / NB_TARGET IF ( PANEL_TABSIZE .LT. NBPANELS + 1 ) THEN WRITE(*,*) " Internal error in MUMPS_LDLTPANEL_PANELINFOS", & PANEL_TABSIZE, NBPANELS CALL MUMPS_ABORT() ENDIF DO IPANEL=1, NBPANELS ICOL_END = min(IPANEL*NB_TARGET, NPIV) IF ( IW(ICOL_END) .LT. 0 ) THEN ICOL_END = ICOL_END + 1 ENDIF NBCOLS_PANEL = ICOL_END - PANEL_COL(IPANEL) + 1 PANEL_POS(IPANEL+1) = PANEL_POS(IPANEL) + & int(NBROWS_PANEL,8)*int(NBCOLS_PANEL,8) PANEL_COL(IPANEL+1) = PANEL_COL(IPANEL) + NBCOLS_PANEL NBROWS_PANEL = NBROWS_PANEL - NBCOLS_PANEL ENDDO ELSE PANEL_POS(2) = int(NPIV,8)*int(NPIV,8)+1_8 PANEL_COL(2) = NPIV+1 ENDIF END SUBROUTINE MUMPS_LDLTPANEL_PANELINFOS SUBROUTINE MUMPS_LDLTPANEL_SIZES & ( NPIV, KEEP, IW, PANEL_SIZES, NBPANELS ) IMPLICIT NONE INTEGER, INTENT(IN) :: NPIV INTEGER, INTENT(IN) :: KEEP(500), IW(NPIV) INTEGER(8), INTENT(OUT) :: PANEL_SIZES( KEEP(459) ) INTEGER, INTENT(OUT) :: NBPANELS INTEGER :: NB_TARGET INTEGER :: ICOL_BEG, ICOL_END NBPANELS = 0 CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, NB_TARGET, KEEP ) ICOL_BEG = 1 NBPANELS = 0 DO WHILE ( ICOL_BEG .LE. NPIV ) NBPANELS = NBPANELS + 1 ICOL_END = min(NB_TARGET * NBPANELS, NPIV) IF ( IW( ICOL_END ) < 0 ) THEN ICOL_END = ICOL_END + 1 ENDIF PANEL_SIZES(NBPANELS) = ICOL_END-ICOL_BEG+1 ICOL_BEG = ICOL_END + 1 ENDDO PANEL_SIZES(NBPANELS+1:KEEP(459))=0 RETURN END SUBROUTINE MUMPS_LDLTPANEL_SIZES SUBROUTINE MUMPS_BUILD_ARCH_NODE_COMM & ( COMM, NEWCOMM, NEWSIZE, NEWRANK, COMM0 ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(OUT) :: NEWCOMM, NEWSIZE, NEWRANK, COMM0 INTEGER :: SMALLEST_ID_ON_SAME_NODE, IPROC, MYID, IERR, NPROCS INTEGER :: TMPNAME_LENGTH, MYNAME_LENGTH CHARACTER(len=MPI_MAX_PROCESSOR_NAME) :: MYNAME, TMPNAME INTEGER :: COLOR SMALLEST_ID_ON_SAME_NODE = -1 CALL MPI_COMM_RANK( COMM, MYID, IERR ) CALL MPI_COMM_SIZE( COMM, NPROCS, IERR ) CALL MPI_GET_PROCESSOR_NAME(MYNAME, MYNAME_LENGTH, IERR ) DO IPROC = 0, NPROCS - 1 IF (MYID .EQ. IPROC) THEN TMPNAME = MYNAME TMPNAME_LENGTH = MYNAME_LENGTH ENDIF CALL MPI_BCAST( TMPNAME_LENGTH, 1, MPI_INTEGER, & IPROC, COMM, IERR ) CALL MPI_BCAST( TMPNAME, TMPNAME_LENGTH, MPI_CHARACTER, & IPROC, COMM, IERR) IF (SMALLEST_ID_ON_SAME_NODE .LT. 0) THEN IF ( TMPNAME_LENGTH .EQ. MYNAME_LENGTH ) THEN IF ( TMPNAME(1:TMPNAME_LENGTH) .EQ. MYNAME(1:MYNAME_LENGTH) ) & THEN SMALLEST_ID_ON_SAME_NODE = IPROC ENDIF ENDIF ENDIF ENDDO CALL MPI_COMM_SPLIT( COMM, SMALLEST_ID_ON_SAME_NODE, 0, & NEWCOMM, IERR ) CALL MPI_COMM_RANK( NEWCOMM, NEWRANK, IERR ) CALL MPI_COMM_SIZE( NEWCOMM, NEWSIZE, IERR ) IF (NEWRANK .EQ.0) THEN COLOR = 0 ELSE COLOR = MPI_UNDEFINED ENDIF CALL MPI_COMM_SPLIT( COMM, COLOR, 0, COMM0, IERR ) RETURN END SUBROUTINE MUMPS_BUILD_ARCH_NODE_COMM SUBROUTINE MUMPS_DESTROY_ARCH_NODE_COMM( ARCH_NODE_COMM, & COMM0, RK ) IMPLICIT NONE INTEGER :: ARCH_NODE_COMM, COMM0, RK, IERR INCLUDE 'mpif.h' CALL MPI_COMM_FREE( ARCH_NODE_COMM, IERR ) IF ( RK .EQ. 0 ) CALL MPI_COMM_FREE( COMM0, IERR ) RETURN END SUBROUTINE MUMPS_DESTROY_ARCH_NODE_COMM SUBROUTINE MUMPS_DM_FAC_UPD_DYN_MEMCNTS & ( MEM_COUNT_ALLOCATED, ATOMIC_UPDATES, KEEP8, & IFLAG, IERROR, K69UPD, K71UPD ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_COUNT_ALLOCATED INTEGER(8), INTENT(INOUT) :: KEEP8(150) LOGICAL, INTENT(IN) :: ATOMIC_UPDATES INTEGER, INTENT(INOUT) :: IFLAG, IERROR LOGICAL, INTENT(IN) :: K69UPD LOGICAL, INTENT(IN) :: K71UPD INTEGER(8) :: KEEP8TMPCOPY IF (MEM_COUNT_ALLOCATED.GT.0) THEN IF (ATOMIC_UPDATES ) THEN !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED KEEP8TMPCOPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP8TMPCOPY) !$OMP END ATOMIC ELSE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED KEEP8TMPCOPY = KEEP8(73) KEEP8(74) = max(KEEP8(74), KEEP8(73)) ENDIF IF ( KEEP8TMPCOPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP8TMPCOPY-KEEP8(75)), IERROR) ENDIF IF ( K69UPD ) THEN IF ( ATOMIC_UPDATES ) THEN !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ELSE KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED KEEP8(68) = max(KEEP8(69), KEEP8(68)) ENDIF ENDIF IF ( K71UPD ) THEN IF ( ATOMIC_UPDATES ) THEN !$OMP ATOMIC CAPTURE KEEP8(71) = KEEP8(71) + MEM_COUNT_ALLOCATED KEEP8TMPCOPY = KEEP8(71) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(70) = max(KEEP8(70), KEEP8TMPCOPY) !$OMP END ATOMIC ELSE KEEP8(71) = KEEP8(71) + MEM_COUNT_ALLOCATED KEEP8(70) = max(KEEP8(71), KEEP8(70)) ENDIF ENDIF ELSE IF (ATOMIC_UPDATES) THEN !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED !$OMP END ATOMIC IF ( K69UPD ) THEN !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED !$OMP END ATOMIC ENDIF IF ( K71UPD ) THEN !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) + MEM_COUNT_ALLOCATED !$OMP END ATOMIC ENDIF ELSE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED IF ( K69UPD ) THEN KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED ENDIF IF ( K71UPD ) THEN KEEP8(71) = KEEP8(71) + MEM_COUNT_ALLOCATED ENDIF ENDIF ENDIF RETURN END SUBROUTINE MUMPS_DM_FAC_UPD_DYN_MEMCNTS SUBROUTINE MUMPS_SET_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & PROCS, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE, & TAB_MAXS_ARG,SUP_PROC_ARG,MAX_SURF,NB_ROW_MAX & ) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID INTEGER, intent(in) :: PROCS(SLAVEF+1) INTEGER(8), intent(in) :: TAB_MAXS_ARG(0:SLAVEF-1) INTEGER, intent(in) :: SUP_PROC_ARG(2) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE,NB_ROW_MAX INTEGER(8), intent(out):: MAX_SURF LOGICAL :: FORCE_LDLTRegular_NIV2 INTEGER NSLAVES,ACC INTEGER i,J,NELIM,NB_SUP,K50,NB_ROWS(PROCS(SLAVEF+1)) INTEGER TMP_NROW,X,K LOGICAL SUP,MEM_CSTR DOUBLE PRECISION MAX_LOAD,TOTAL_LOAD,VAR,TMP,A,B,C,DELTA, & LOAD_CORR INTEGER IDWLOAD(SLAVEF) INTEGER(8) MEM_CONSTRAINT(2) K50=KEEP(50) FORCE_LDLTRegular_NIV2 = .FALSE. MAX_SURF=0 NB_ROW_MAX=0 NELIM=NFRONT-NCB NB_SUP=0 TOTAL_LOAD=0.0D0 SUP=.FALSE. IF(SUP_PROC_ARG(1).NE. & 0)THEN MEM_CONSTRAINT(1)=TAB_MAXS_ARG(PROCS(1)) TOTAL_LOAD=TOTAL_LOAD+dble(SUP_PROC_ARG(1))/100.0D0 NB_SUP=NB_SUP+1 ENDIF IF(SUP_PROC_ARG(2).NE. & 0)THEN MEM_CONSTRAINT(2)=TAB_MAXS_ARG(PROCS(PROCS(SLAVEF+1))) TOTAL_LOAD=TOTAL_LOAD+dble(SUP_PROC_ARG(2))/100.0D0 NB_SUP=NB_SUP+1 ENDIF TOTAL_LOAD=TOTAL_LOAD+(PROCS(SLAVEF+1)-NB_SUP) IF(K50.EQ.0)THEN MAX_LOAD=dble( NELIM ) * dble ( NCB ) + * dble(NCB) * dble(NELIM)*dble(2*NFRONT-NELIM-1) ELSE MAX_LOAD=dble(NELIM) * dble ( NCB ) * * dble(NFRONT+1) ENDIF TMP=min(MAX_LOAD,MAX_LOAD/TOTAL_LOAD) J=1 DO i=1,PROCS(SLAVEF+1) IF((NB_SUP.GT.0).AND.(i.EQ.1))THEN CYCLE ELSEIF((NB_SUP.EQ.2).AND.(i.EQ.PROCS(SLAVEF+1)))THEN CYCLE ENDIF IDWLOAD(J)=PROCS(i) J=J+1 ENDDO DO i=1,NB_SUP IF(i.EQ.1)THEN IDWLOAD(J)=PROCS(1) ELSE IDWLOAD(J)=PROCS(PROCS(SLAVEF+1)) ENDIF J=J+1 ENDDO IF ((K50.EQ.0).OR.FORCE_LDLTRegular_NIV2) THEN ACC=0 J=PROCS(SLAVEF+1)-NB_SUP+1 DO i=1,NB_SUP VAR=dble(SUP_PROC_ARG(i))/100.0D0 TMP_NROW=int(dble(MEM_CONSTRAINT(i))/dble(NFRONT)) NB_ROWS(J)=int(max((VAR*dble(TMP))/ & (dble(NELIM)*dble(2*NFRONT-NELIM)), & dble(1))) IF(NB_ROWS(J).GT.TMP_NROW)THEN NB_ROWS(J)=TMP_NROW ENDIF IF(NCB-ACC.LT.NB_ROWS(J)) THEN NB_ROWS(J)=NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+NB_ROWS(J) J=J+1 ENDDO IF(ACC.EQ.NCB)THEN GOTO 777 ENDIF DO i=1,PROCS(SLAVEF+1)-NB_SUP VAR=1.0D0 TMP_NROW=int((dble(TAB_MAXS_ARG(IDWLOAD(i))))/dble(NFRONT)) NB_ROWS(i)=int((dble(VAR)*dble(TMP))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(NB_ROWS(i).GT.TMP_NROW)THEN NB_ROWS(i)=TMP_NROW ENDIF IF(NCB-ACC.LT.NB_ROWS(i)) THEN NB_ROWS(i)=NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+NB_ROWS(i) ENDDO IF(ACC.NE.NCB)THEN IF(PROCS(SLAVEF+1).EQ.NB_SUP)THEN TMP_NROW=(NCB-ACC)/PROCS(SLAVEF+1)+1 DO i=1,PROCS(SLAVEF+1) NB_ROWS(i)=NB_ROWS(i)+TMP_NROW IF(ACC+TMP_NROW.GT.NCB)THEN NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+TMP_NROW ENDDO ELSE TMP_NROW=(NCB-ACC)/(PROCS(SLAVEF+1)-NB_SUP)+1 DO i=1,PROCS(SLAVEF+1)-NB_SUP NB_ROWS(i)=NB_ROWS(i)+TMP_NROW ACC=ACC+TMP_NROW IF(ACC.GT.NCB) THEN NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+ & (NCB-(ACC-TMP_NROW)) EXIT ENDIF ENDDO ENDIF ENDIF ELSE ACC=0 i=PROCS(SLAVEF+1)-NB_SUP+1 X=NCB LOAD_CORR=0.0D0 MEM_CSTR=.FALSE. DO J=1,NB_SUP VAR=DBLE(SUP_PROC_ARG(J))/DBLE(100) A=1.0D0 B=dble(X+NELIM) C=-dble(max(MEM_CONSTRAINT(J),0_8)) DELTA=((B*B)-(4*A*C)) TMP_NROW=int((-B+sqrt(DELTA))/(2*A)) A=dble(-NELIM) B=dble(NELIM)*(dble(-NELIM)+dble(2*(X+NELIM)+1)) C=-(VAR*TMP) DELTA=(B*B-(4*A*C)) NB_ROWS(i)=int((-B+sqrt(DELTA))/(2*A)) IF(NB_ROWS(i).GT.TMP_NROW)THEN NB_ROWS(i)=TMP_NROW MEM_CSTR=.TRUE. ENDIF IF(ACC+NB_ROWS(i).GT.NCB)THEN NB_ROWS(i)=NCB-ACC ACC=NCB X=0 EXIT ENDIF X=X-NB_ROWS(i) ACC=ACC+NB_ROWS(i) LOAD_CORR=LOAD_CORR+(dble(NELIM) * dble (NB_ROWS(i)) * * dble(2*(X+NELIM) - NELIM - NB_ROWS(i) + 1)) i=i+1 ENDDO IF(ACC.EQ.NCB)THEN GOTO 777 ENDIF IF((PROCS(SLAVEF+1).NE.NB_SUP).AND.MEM_CSTR)THEN TMP=(MAX_LOAD-LOAD_CORR)/(PROCS(SLAVEF+1)-NB_SUP) ENDIF X=ACC ACC=0 DO i=1,PROCS(SLAVEF+1)-NB_SUP IF (KEEP(375) .EQ. 1) THEN VAR=1.0D0 A=dble(NELIM) B=dble(NELIM)*(dble(NELIM)+dble(2*ACC+1)) C=-(VAR*TMP) ELSE A=1.0D0 B=dble(ACC+NELIM) C=-TMP ENDIF DELTA=((B*B)-(4*A*C)) NB_ROWS(i)=int((-B+sqrt(DELTA))/(2*A)) IF(NCB-ACC-X.LT.NB_ROWS(i))THEN NB_ROWS(i)=NCB-ACC-X ACC=NCB-X EXIT ENDIF ACC=ACC+NB_ROWS(i) ENDDO ACC=ACC+X IF(ACC.NE.NCB)THEN IF(PROCS(SLAVEF+1).EQ.NB_SUP)THEN TMP_NROW=(NCB-ACC)/PROCS(SLAVEF+1)+1 DO i=1,PROCS(SLAVEF+1) NB_ROWS(i)=NB_ROWS(i)+TMP_NROW IF(ACC+TMP_NROW.GT.NCB)THEN NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+TMP_NROW ENDDO ELSE NB_ROWS(PROCS(SLAVEF+1)-NB_SUP)= & NB_ROWS(PROCS(SLAVEF+1) & -NB_SUP)+NCB-ACC ENDIF ENDIF ENDIF 777 CONTINUE NSLAVES=0 ACC=1 J=1 K=1 DO i=1,PROCS(SLAVEF+1) IF(NB_ROWS(i).NE.0)THEN SLAVES_LIST(J)=IDWLOAD(i) TAB_POS(J)=ACC ACC=ACC+NB_ROWS(i) NB_ROW_MAX=max(NB_ROW_MAX,NB_ROWS(i)) IF(K50.EQ.0)THEN MAX_SURF=max(int(NB_ROWS(i),8)*int(NCB,8),int(0,8)) ELSE MAX_SURF=max(int(NB_ROWS(i),8)*int(ACC,8),int(0,8)) ENDIF NSLAVES=NSLAVES+1 J=J+1 ELSE SLAVES_LIST(PROCS(SLAVEF+1)-K+1)=IDWLOAD(i) K=K+1 ENDIF ENDDO TAB_POS(SLAVEF+2) = NSLAVES TAB_POS(NSLAVES+1)= NCB+1 NSLAVES_NODE=NSLAVES END SUBROUTINE MUMPS_SET_PARTI_REGULAR SUBROUTINE MUMPS_BIGALLREDUCE(IS_IN_PLACE, & B1, B2, N, & MPI_TYPE, MPI_OP, COMM, IERR_MPI) IMPLICIT NONE LOGICAL :: IS_IN_PLACE INTEGER :: N, MPI_TYPE, MPI_OP, COMM, IERR_MPI INTEGER :: B1(*), B2(*) INTEGER, PARAMETER :: CHUNK = 250 000 000 INCLUDE 'mpif.h' INTEGER :: I, THISCHUNK INTEGER(8) :: IPOS IF ( MPI_TYPE .NE. MPI_INTEGER .AND. MPI_TYPE .NE. MPI_2INTEGER ) & THEN WRITE(*,*) "Internal error MUMPS_BIGALLREDUCE",MPI_TYPE ENDIF DO I = 1, N, CHUNK THISCHUNK=min(CHUNK, N-I+1) IF ( MPI_TYPE.EQ.MPI_INTEGER) THEN IPOS = int(I,8) ELSE IPOS =int(I,8)+int(I,8)-1_8 ENDIF IF ( IS_IN_PLACE ) THEN CALL MPI_ALLREDUCE( MPI_IN_PLACE, B2(IPOS), THISCHUNK, & MPI_TYPE, MPI_OP, COMM, IERR_MPI ) ELSE CALL MPI_ALLREDUCE( B1(IPOS), B2(IPOS), THISCHUNK, & MPI_TYPE, MPI_OP, COMM, IERR_MPI ) ENDIF ENDDO RETURN END SUBROUTINE MUMPS_BIGALLREDUCE INTEGER FUNCTION MUMPS_NUMROC(ROOT_SIZE, BLOCK_SIZE, & MYPROC_ROW, IPROC_ROW1, NPROCS_ROW) IMPLICIT NONE INTEGER :: ROOT_SIZE, BLOCK_SIZE, & MYPROC_ROW, IPROC_ROW1, NPROCS_ROW INTEGER :: NBLOCKS, EXTRA_FULL_BLOCKS, DIST_IPROC_ROW1, MYNBROWS NBLOCKS = ROOT_SIZE / BLOCK_SIZE MYNBROWS = (NBLOCKS/NPROCS_ROW)*BLOCK_SIZE EXTRA_FULL_BLOCKS = mod(NBLOCKS, NPROCS_ROW) IF (MYPROC_ROW .GE. IPROC_ROW1) THEN DIST_IPROC_ROW1 = MYPROC_ROW - IPROC_ROW1 ELSE DIST_IPROC_ROW1 = NPROCS_ROW + MYPROC_ROW - IPROC_ROW1 ENDIF IF ( DIST_IPROC_ROW1 .LT. EXTRA_FULL_BLOCKS ) THEN MYNBROWS = MYNBROWS + BLOCK_SIZE ELSE IF ( DIST_IPROC_ROW1 .EQ. EXTRA_FULL_BLOCKS ) THEN MYNBROWS = MYNBROWS + mod(ROOT_SIZE,BLOCK_SIZE) ENDIF MUMPS_NUMROC = MYNBROWS RETURN END FUNCTION MUMPS_NUMROC SUBROUTINE MUMPS_CLEAN_PENDING( & INFO1, KEEP, BUFR, LBUFR, LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, & CLEAN_COMM_NODES, CLEAN_COMM_LOAD ) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_ALL_EMPTY IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR, LBUFR_BYTES INTEGER, INTENT(OUT) :: BUFR( LBUFR ) INTEGER, INTENT(IN) :: COMM_NODES, COMM_LOAD, SLAVEF, INFO1 INTEGER, INTENT(INOUT) :: KEEP(500) LOGICAL, INTENT(IN) :: CLEAN_COMM_LOAD, CLEAN_COMM_NODES INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: FLAG, BUFFERS_EMPTY, BUFFERS_EMPTY_ON_ALL_PROCS INTEGER :: MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC INTEGER :: COMM_EFF INTEGER :: IERR INTEGER :: IBUF_EMPTY, IBUF_EMPTY_ON_ALL_PROCS INTEGER :: TOTAL_SEND_MINUS_RECV266 INTEGER :: TOTAL_SEND_MINUS_RECV267 IF (SLAVEF.EQ.1) RETURN IF (.NOT. CLEAN_COMM_NODES .AND. .NOT. CLEAN_COMM_LOAD) THEN RETURN ENDIF DO WHILE (.TRUE.) FLAG = .TRUE. DO WHILE ( FLAG ) FLAG = .FALSE. IF (CLEAN_COMM_NODES) THEN IF ( .NOT. FLAG ) THEN COMM_EFF = COMM_NODES CALL MPI_IPROBE(MPI_ANY_SOURCE,MPI_ANY_TAG, & COMM_NODES, FLAG, STATUS, IERR) END IF END IF IF (CLEAN_COMM_LOAD) THEN IF ( .NOT. FLAG ) THEN COMM_EFF = COMM_LOAD CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM_LOAD, FLAG, STATUS, IERR) END IF END IF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) IF (COMM_EFF .EQ. COMM_NODES) THEN KEEP(266) = KEEP(266) - 1 ELSE KEEP(267) = KEEP(267) - 1 ENDIF CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN_LOC, IERR ) IF (MSGLEN_LOC .LE. LBUFR_BYTES) THEN CALL MPI_RECV( BUFR, LBUFR_BYTES, & MPI_PACKED, MSGSOU_LOC, & MSGTAG_LOC, COMM_EFF, STATUS, IERR ) ENDIF ENDIF END DO CALL MUMPS_BUF_ALL_EMPTY( CLEAN_COMM_NODES, & CLEAN_COMM_LOAD, & BUFFERS_EMPTY ) IF ( BUFFERS_EMPTY ) THEN IBUF_EMPTY = 0 ELSE IBUF_EMPTY = 1 ENDIF IF (CLEAN_COMM_NODES) THEN COMM_EFF = COMM_NODES ELSE COMM_EFF = COMM_LOAD ENDIF CALL MPI_ALLREDUCE(IBUF_EMPTY, & IBUF_EMPTY_ON_ALL_PROCS, & 1, MPI_INTEGER, MPI_MAX, & COMM_EFF, IERR) IF ( IBUF_EMPTY_ON_ALL_PROCS == 0) THEN BUFFERS_EMPTY_ON_ALL_PROCS = .TRUE. ELSE BUFFERS_EMPTY_ON_ALL_PROCS = .FALSE. ENDIF IF (BUFFERS_EMPTY_ON_ALL_PROCS) THEN IF (CLEAN_COMM_NODES) THEN CALL MPI_ALLREDUCE(KEEP(266), & TOTAL_SEND_MINUS_RECV266, & 1, MPI_INTEGER, MPI_SUM, & COMM_EFF, IERR) ELSE TOTAL_SEND_MINUS_RECV266 = 0 ENDIF IF (CLEAN_COMM_LOAD) THEN CALL MPI_ALLREDUCE(KEEP(267), & TOTAL_SEND_MINUS_RECV267, & 1, MPI_INTEGER, MPI_SUM, & COMM_EFF, IERR) ELSE TOTAL_SEND_MINUS_RECV267 = 0 ENDIF IF (TOTAL_SEND_MINUS_RECV266 .EQ. 0 .AND. & TOTAL_SEND_MINUS_RECV267 .EQ. 0) THEN EXIT ENDIF ENDIF ENDDO RETURN END SUBROUTINE MUMPS_CLEAN_PENDING SUBROUTINE MUMPS_RCOPY_32TO64 (INTAB, SIZETAB, OUTTAB8) IMPLICIT NONE INTEGER, intent(in) :: SIZETAB REAL, intent(in) :: INTAB(SIZETAB) DOUBLE PRECISION, intent(out) :: OUTTAB8(SIZETAB) INTEGER :: I DO I=1,SIZETAB OUTTAB8(I) = dble(INTAB(I)) ENDDO RETURN END SUBROUTINE MUMPS_RCOPY_32TO64 SUBROUTINE MUMPS_RCOPY_32TO64_64C(INTAB, SIZETAB8, OUTTAB8) IMPLICIT NONE INTEGER(8), intent(in) :: SIZETAB8 REAL, intent(in) :: INTAB(SIZETAB8) DOUBLE PRECISION, intent(out) :: OUTTAB8(SIZETAB8) INTEGER(8) :: I8 LOGICAL :: OMP_FLAG OMP_FLAG = (SIZETAB8 .GE.500000_8 ) !$OMP PARALLEL DO PRIVATE(I8) !$OMP& IF(OMP_FLAG) DO I8=1_8, SIZETAB8 OUTTAB8(I8) = dble(INTAB(I8)) ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE MUMPS_RCOPY_32TO64_64C SUBROUTINE MUMPS_RCOPY_32TO64_64C_IP(IN_OUT_TAB48, SIZETAB) INTEGER(8), intent(in) :: SIZETAB REAL, intent(inout) :: IN_OUT_TAB48(2*SIZETAB) CALL MUMPS_RCOPY_32TO64_64C_IP_REC(IN_OUT_TAB48, SIZETAB) RETURN END SUBROUTINE MUMPS_RCOPY_32TO64_64C_IP RECURSIVE SUBROUTINE MUMPS_RCOPY_32TO64_64C_IP_REC( & IN_OUT_TAB48, SIZETAB) IMPLICIT NONE INTEGER(8), intent(in) :: SIZETAB REAL :: IN_OUT_TAB48(2*SIZETAB) INTEGER(8) :: IBEG24, IBEG28, SIZE1, SIZE2 IF (SIZETAB.LE. 1000_8) THEN CALL MUMPS_RCOPY_32TO64_64C_IP_C(IN_OUT_TAB48, & SIZETAB) ELSE SIZE2 = SIZETAB / 2 SIZE1 = SIZETAB - SIZE2 IBEG24 = SIZE1+1 IBEG28 = 2*SIZE1+1_8 CALL MUMPS_RCOPY_32TO64_64C(IN_OUT_TAB48(IBEG24), & SIZE2, IN_OUT_TAB48(IBEG28)) CALL MUMPS_RCOPY_32TO64_64C_IP_REC(IN_OUT_TAB48, & SIZE1) ENDIF RETURN END SUBROUTINE MUMPS_RCOPY_32TO64_64C_IP_REC SUBROUTINE MUMPS_RCOPY_64TO32(INTAB8, SIZETAB, OUTTAB) INTEGER, intent(in) :: SIZETAB DOUBLE PRECISION, intent(in) :: INTAB8(SIZETAB) REAL, intent(out) :: OUTTAB(SIZETAB) INTEGER :: I DO I=1,SIZETAB OUTTAB(I) = real(INTAB8(I)) ENDDO RETURN END SUBROUTINE MUMPS_RCOPY_64TO32 SUBROUTINE MUMPS_RCOPY_64TO32_64C (INTAB8, SIZETAB, OUTTAB) INTEGER(8), intent(in) :: SIZETAB DOUBLE PRECISION, intent(in) :: INTAB8(SIZETAB) REAL, intent(out) :: OUTTAB(SIZETAB) INTEGER(8) :: I8 DO I8=1_8,SIZETAB OUTTAB(I8) = real(INTAB8(I8)) ENDDO RETURN END SUBROUTINE MUMPS_RCOPY_64TO32_64C SUBROUTINE MUMPS_RCOPY_64TO32_64C_IP(IN_OUT_TAB48, SIZETAB) IMPLICIT NONE INTEGER(8), intent(in) :: SIZETAB REAL, intent(inout) :: IN_OUT_TAB48(2*SIZETAB) CALL MUMPS_RCOPY_64TO32_64C_IP_REC(IN_OUT_TAB48, SIZETAB) RETURN END SUBROUTINE MUMPS_RCOPY_64TO32_64C_IP RECURSIVE SUBROUTINE MUMPS_RCOPY_64TO32_64C_IP_REC( & IN_OUT_TAB48, SIZETAB) IMPLICIT NONE INTEGER(8), intent(in) :: SIZETAB INTEGER :: IN_OUT_TAB48(2*SIZETAB) INTEGER(8) :: IBEG24, IBEG28, SIZE1, SIZE2 IF (SIZETAB.LE. 1000_8) THEN CALL MUMPS_RCOPY_64TO32_64C_IP_C(IN_OUT_TAB48, & SIZETAB) ELSE SIZE2 = SIZETAB / 2 SIZE1 = SIZETAB - SIZE2 IBEG24 = SIZE1 + 1 IBEG28 = SIZE1 + SIZE1 + 1_8 CALL MUMPS_RCOPY_64TO32_64C_IP_REC(IN_OUT_TAB48, & SIZE1) CALL MUMPS_RCOPY_64TO32_64C(IN_OUT_TAB48(IBEG28), & SIZE2, IN_OUT_TAB48(IBEG24)) ENDIF RETURN END SUBROUTINE MUMPS_RCOPY_64TO32_64C_IP_REC MUMPS_5.8.1/src/dfac_asm.F0000664000175000017500000010711315042446440015077 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, NBROWS, NBCOLS, ROWLIST, & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, & OPASSW, IWPOSCB, MYID, KEEP,KEEP8, IS_ofType5or6, & LDA_VALSON, ICOL_BEG ) 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, INTENT(IN) :: ICOL_BEG INTEGER(8) :: POSELT, POSEL1, APOS, JJ2 INTEGER 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 IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS1 = abs(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 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+(ICOL_BEG-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 + ICOL_BEG-1 + 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 = ICOL_BEG, min(DIAG,ICOL_BEG+NBCOLS-1) JJ2 = APOS+int(JJ1-1,8) A(JJ2) = A(JJ2) + VALSON(JJ1-ICOL_BEG+1,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 = ICOL_BEG, min(NELIM, ICOL_BEG+NBCOLS-1) JJ2 = APOS + int(IW(J1+JJ1-1),8)*int(LDAFS_PERE,8) A(JJ2) = A(JJ2) + VALSON(JJ1-ICOL_BEG+1,JJ) ENDDO IBEG = max(NELIM+1,ICOL_BEG) ELSE IBEG = ICOL_BEG ENDIF APOS = POSEL1 + int(ROWLIST(JJ),8) * int(LDAFS_PERE,8) DO JJ1 = IBEG, ICOL_BEG + NBCOLS - 1 IF (ROWLIST(JJ).LT.IW(J1 + JJ1 - 1)) EXIT JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) A(JJ2) = A(JJ2) + VALSON(JJ1-ICOL_BEG+1,JJ) ENDDO ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_ASM_SLAVE_MASTER SUBROUTINE DMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, INTARR, DBLARR, & ICNTL, KEEP,KEEP8, MYID, LRGROUPS) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID INTEGER NBROWS, NBCOLS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) DOUBLE PRECISION :: A(LA) INTEGER :: INTARR(KEEP8(27)) DOUBLE PRECISION :: DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) INTEGER(8) :: POSELT DOUBLE PRECISION, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL DMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) IF (NASS.LT.0) THEN NASS = -NASS IW(IOLDPS+1+KEEP(IXSZ)) = NASS CALL DMUMPS_ASM_SLAVE_ARROWHEADS(INODE, STEP(INODE), & N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, & ITLOC, FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, KEEP8(27), KEEP8(26), & RHS_MUMPS, LRGROUPS) ENDIF IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_ASM_SLAVE_TO_SLAVE_INIT SUBROUTINE DMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, NBROWS, STEP, PTRIST, & ITLOC, RHS_MUMPS, KEEP,KEEP8) IMPLICIT NONE INTEGER N, LIW INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER INODE INTEGER NBROWS INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INCLUDE 'mumps_headers.h' INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J IOLDPS = PTRIST(STEP(INODE)) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_ASM_SLAVE_TO_SLAVE_END SUBROUTINE DMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, ROWLIST, COLLIST, VALSON, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, FILS, & ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, LDA_VALSON) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY: DMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID LOGICAL, intent(in) :: IS_ofType5or6 INTEGER NBROWS, NBCOLS, LDA_VALSON INTEGER ROWLIST(NBROWS), COLLIST(NBCOLS) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRAST(KEEP(28)) DOUBLE PRECISION A(LA), VALSON(LDA_VALSON,NBROWS) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8) :: POSEL1, POSELT, APOS, K8 INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & I,J,NASS,IDIAG DOUBLE PRECISION, POINTER, DIMENSION(:) :: A_PTR INTEGER(8) :: LA_PTR INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL DMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) IF ( NBROWS .GT. NBROWF ) THEN WRITE(*,*) ' ERR: ERROR : NBROWS > NBROWF' WRITE(*,*) ' ERR: INODE =', INODE WRITE(*,*) ' ERR: NBROW=',NBROWS,'NBROWF=',NBROWF WRITE(*,*) ' ERR: ROW_LIST=', ROWLIST WRITE(*,*) ' ERR: NBCOLF/NASS=', NBCOLF, NASS CALL MUMPS_ABORT() END IF NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) IF (NBROWS.GT.0) THEN POSEL1 = POSELT - int(NBCOLF,8) IF (KEEP(50).EQ.0) THEN IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) DO I=1, NBROWS DO J = 1, NBCOLS A_PTR(APOS+int(J-1,8)) = A_PTR( APOS+int(J-1,8)) + & VALSON(J,I) ENDDO APOS = APOS + int(NBCOLF,8) END DO ELSE DO I=1,NBROWS APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) DO J=1,NBCOLS K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO ENDDO ENDIF ELSE IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) & + int((NBROWS-1),8)*int(NBCOLF,8) IDIAG = 0 DO I=NBROWS,1,-1 DO J=1,NBCOLS-IDIAG K8 = APOS+int(J-1,8) A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO APOS = APOS - int(NBCOLF,8) IDIAG = IDIAG + 1 ENDDO ELSE DO I=1,NBROWS APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) DO J=1,NBCOLS IF (ITLOC(COLLIST(J)) .EQ. 0) THEN EXIT ENDIF K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO ENDDO ENDIF ENDIF OPASSW = OPASSW + dble(NBROWS*NBCOLS) ENDIF RETURN END SUBROUTINE DMUMPS_ASM_SLAVE_TO_SLAVE SUBROUTINE DMUMPS_LDLT_ASM_NIV12_IP( A, LA, & IAFATH, NFRONT, NASS1, & IACB, NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED ) IMPLICIT NONE INTEGER NFRONT, NASS1 INTEGER(8) :: LA INTEGER NCOLS, NROWS, NELIM INTEGER(8) :: LCB DOUBLE PRECISION A( LA ) INTEGER(8) :: IAFATH, IACB INTEGER IW( NCOLS ) INTEGER ETATASS LOGICAL CB_IS_COMPRESSED DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB, IBEGCBROW, IENDFRONT LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE IENDFRONT = IAFATH+int(NFRONT,8)*int(NFRONT,8)-1_8 IPOSCB=1_8 RESET_TO_ZERO = IACB .LT. IENDFRONT + 1_8 RISK_OF_SAME_POS = IACB + LCB .EQ. IENDFRONT + 1_8 RISK_OF_SAME_POS_THIS_LINE = .FALSE. DO I=1, NROWS POSELT = int(IW(I)-1,8) * int(NFRONT,8) IF (.NOT. CB_IS_COMPRESSED ) THEN IPOSCB = 1_8 + int(I - 1,8) * int(NCOLS,8) IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN RESET_TO_ZERO = .FALSE. ENDIF ENDIF IF ( RISK_OF_SAME_POS ) THEN IF (I.EQ.NROWS .OR. .NOT. CB_IS_COMPRESSED) THEN IF ( IAFATH + POSELT + int(IW(I)-1,8) .EQ. & IACB+IPOSCB+int(I-1-1,8)) THEN RISK_OF_SAME_POS_THIS_LINE = .TRUE. ENDIF ENDIF ENDIF IF (RESET_TO_ZERO) THEN IF ( RISK_OF_SAME_POS_THIS_LINE ) THEN DO J=1, I APOS = POSELT + int(IW( J ),8) IF (IAFATH + APOS - 1_8.NE. IACB+IPOSCB-1_8) THEN A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) A(IACB+IPOSCB-1_8) = ZERO ENDIF IPOSCB = IPOSCB + 1_8 ENDDO ELSE #if defined(__ve__) !NEC$ IVDEP #endif 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 #if defined(__ve__) !NEC$ IVDEP #endif DO J=1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB + 1_8 ENDDO ENDIF IF (.NOT. CB_IS_COMPRESSED ) THEN IBEGCBROW = IACB+IPOSCB-1_8 IF ( IBEGCBROW .LE. IENDFRONT ) THEN A(IBEGCBROW:IBEGCBROW+int(NCOLS-I,8)-1_8)=ZERO ENDIF ENDIF IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN RESET_TO_ZERO = .FALSE. ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_LDLT_ASM_NIV12_IP SUBROUTINE DMUMPS_LDLT_ASM_NIV12( A, LA, SON_A, & IAFATH, NFRONT, NASS1, & NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED !$ & , K360 & ) IMPLICIT NONE INTEGER NFRONT, NASS1 INTEGER(8) :: LA INTEGER NCOLS, NROWS, NELIM INTEGER(8) :: LCB DOUBLE PRECISION A( LA ) DOUBLE PRECISION SON_A( LCB ) INTEGER(8) :: IAFATH INTEGER IW( NCOLS ) INTEGER ETATASS LOGICAL CB_IS_COMPRESSED !$ INTEGER, INTENT(in):: K360 DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB !$ LOGICAL :: OMP_FLAG IF ((ETATASS.EQ.0) .OR. (ETATASS.EQ.1)) THEN IPOSCB = 1_8 #if defined(__ve__) !NEC$ IVDEP #endif 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 #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IAFATH+ APOS -1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO END DO ENDIF IF ((ETATASS.EQ.0).OR.(ETATASS.EQ.1)) THEN !$ OMP_FLAG = (NROWS-NELIM).GE.K360 !$OMP PARALLEL DO PRIVATE(IPOSCB, POSELT, J, APOS) IF (OMP_FLAG) DO I = NELIM + 1, NROWS IF (CB_IS_COMPRESSED) THEN IPOSCB = (int(I,8) * int(I-1,8)) / 2_8 + 1_8 ELSE IPOSCB = int(I-1,8) * int(NCOLS,8) + 1_8 ENDIF POSELT = int(IW( I ),8) IF (POSELT.LE. int(NASS1,8)) THEN #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, NELIM APOS = POSELT + int( IW( J ) - 1, 8 ) * int(NFRONT,8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) + & SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ELSE POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, NELIM APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ENDIF IF (ETATASS.EQ.1) THEN POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J = NELIM + 1, I IF (IW(J).GT.NASS1) EXIT APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB +1_8 END DO ELSE POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) #if defined(__ve__) !NEC$ IVDEP #endif DO J = NELIM + 1, I APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ENDIF END DO !$OMP END PARALLEL DO ELSE DO I= NROWS, NELIM+1, -1 IF (CB_IS_COMPRESSED) THEN IPOSCB = (int(I,8)*int(I+1,8))/2_8 ELSE IPOSCB = int(I-1,8) * int(NCOLS,8) + int(I,8) ENDIF POSELT = int(IW( I ),8) IF (POSELT.LE.int(NASS1,8)) EXIT POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J=I,NELIM+1, -1 IF (IW(J).LE.NASS1) EXIT APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB - 1_8 ENDDO ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_LDLT_ASM_NIV12 SUBROUTINE DMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST_S, IW, LIW, STEP, KEEP,KEEP8) IMPLICIT NONE INTEGER N, ISON, INODE, IWPOSCB INTEGER KEEP(500), STEP(N) INTEGER(8) KEEP8(150) INTEGER PIMASTER(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER LIW INTEGER IW(LIW) INTEGER ISTCHK, LSTK, NSLSON, HS, NROWS, NCOLS, NPIVS, NELIM INTEGER IOLDPS, NFRONT, NSLAVES, ICT11, HF INTEGER J1, J2, J3, JJ, JPOS LOGICAL SAME_PROC INCLUDE 'mumps_headers.h' ISTCHK = PIMASTER(STEP(ISON)) LSTK = IW(ISTCHK+KEEP(IXSZ)) NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NELIM = IW(ISTCHK + 1+KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) NCOLS = NPIVS + LSTK IF ( NPIVS < 0 ) NPIVS = 0 SAME_PROC = ISTCHK < IWPOSCB IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2+KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS IF (KEEP(50).NE.0) THEN J2 = J1 + LSTK - 1 DO JJ = J1, J2 IW(JJ) = IW(JJ - NROWS) ENDDO ELSE J2 = J1 + LSTK - 1 J3 = J1 + NELIM DO JJ = J3, J2 IW(JJ) = IW(JJ - NROWS) ENDDO IF (NELIM .NE. 0) THEN IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) ICT11 = IOLDPS + HF - 1 + NFRONT J3 = J3 - 1 DO 190 JJ = J1, J3 JPOS = IW(JJ) + ICT11 IW(JJ) = IW(JPOS) 190 CONTINUE ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_RESTORE_INDICES SUBROUTINE DMUMPS_ASM_MAX( & N, INODE, IW, LIW, A, LA, & ISON, NBCOLS, & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, & OPASSW, IWPOSCB,MYID, KEEP,KEEP8 ) 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,NPIVS,NCOLS, J1, & JJ1,NROWS INTEGER(8) POSELT, APOS, JJ2 INCLUDE 'mumps_headers.h' LOGICAL SAME_PROC INTRINSIC dble IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) NASS1 = abs(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) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOSCB) IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2 + KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS APOS = POSELT + int(NASS1,8)*int(NASS1,8) - 1_8 DO JJ1 = 1, NBCOLS JJ2 = APOS+int(IW(J1 + JJ1 - 1),8) IF(dble(A(JJ2)) .LT. VALSON(JJ1)) THEN A(JJ2) = VALSON(JJ1) ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_ASM_MAX SUBROUTINE DMUMPS_ASM_SLAVE_ARROWHEADS(INODE, ISTEP, & N, IW, LIW, IOLDPS, & A, LA, POSELT, KEEP, KEEP8, & ITLOC, FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LINTARR, LDBLARR, RHS_MUMPS, LRGROUPS) !$ USE OMP_LIB USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, intent(in) :: N, LIW, IOLDPS, INODE, ISTEP INTEGER(8), intent(in) :: LA, POSELT INTEGER(8), intent(in) :: LINTARR, LDBLARR INTEGER, intent(in) :: IW(LIW) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(inout) :: ITLOC(N+KEEP(253)) DOUBLE PRECISION, intent(inout) :: A(LA) DOUBLE PRECISION, intent(in) :: RHS_MUMPS(KEEP8(85)) DOUBLE PRECISION, intent(in) :: DBLARR(LDBLARR) INTEGER, intent(in) :: INTARR(LINTARR) INTEGER, intent(in) :: FILS(N) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 !$ INTEGER :: CHUNK INCLUDE 'mumps_headers.h' INTEGER :: HF, NBROWF, NBCOLF, NASS, NSLAVES INTEGER :: ILOC, J, K, K1, K2, JPOS, IJROW INTEGER :: IN, IARR1, IORG INTEGER(8) :: J18, J28, JJ8 INTEGER(8) :: APOS, ICT12 INTEGER(8) :: AINPUT8 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE, TOPDIAG INTEGER(8) :: JJ3 INTEGER :: K1RHS, K2RHS, JFirstRHS DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) !$ NOMP = OMP_GET_MAX_THREADS() IF (KEEP(50) .EQ. 0 .OR. NBROWF .LT. KEEP(63)) THEN !$ CHUNK8 = int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8) !$OMP& .AND. NOMP .GT. 1) DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = 0 IF (IW(IOLDPS+XXLR).GE.1) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0, & NBROWF, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) NB_BLR_LS = NPARTSCB call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR_LS) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS, & NBCOLF, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max( KEEP(360)/2, !$ & ((NBROWF+NOMP-1)/NOMP +2) / 3 ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK) !$OMP& IF (NBROWF .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(NBROWF-1,8) APOS = POSELT+ JJ8*int(NBCOLF,8) JJ3 = min( int(NBCOLF,8) - 1_8, & JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG ) A(APOS: APOS+JJ3) = ZERO ENDDO !$OMP END PARALLEL DO ENDIF K1 = IOLDPS + HF + NBROWF K2 = K1 + NASS - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = -JPOS JPOS = JPOS + 1 ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF - 1 JPOS = 1 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN K1RHS = 0 K2RHS = -1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN K1RHS = K JFirstRHS=J-N ENDIF JPOS = JPOS + 1 ENDDO IF (K1RHS.GT.0) K2RHS=K2 IF ( K2RHS.GE.K1RHS ) THEN IN = INODE DO WHILE (IN.GT.0) IJROW = -ITLOC(IN) DO K = K1RHS, K2RHS J = IW(K) ILOC = ITLOC(J) APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+IN) ENDDO IN = FILS(IN) ENDDO ENDIF ELSE DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF IN = INODE IORG = 0 IARR1 = PTRDEBARR(ISTEP) DO WHILE (IN.GT.0) IORG = IORG + 1 AINPUT8 = PTR8ARR( IARR1 + IORG -1 ) J18 = AINPUT8 J28 = J18 + NINCOLARR(IARR1+IORG-1) IJROW = -ITLOC(INTARR(J18)) ICT12 = POSELT +int(- NBCOLF + IJROW - 1,8) DO JJ8= J18,J28 ILOC = ITLOC(INTARR(JJ8)) IF (ILOC.GT.0) THEN APOS = ICT12 + int(ILOC,8)*int(NBCOLF,8) A(APOS) = A(APOS) + DBLARR(AINPUT8) ENDIF AINPUT8 = AINPUT8 + 1_8 ENDDO IN = FILS(IN) ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF + NASS - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO RETURN END SUBROUTINE DMUMPS_ASM_SLAVE_ARROWHEADS SUBROUTINE DMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS1, KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(out) :: PARPIV_T1 INTEGER :: NCB LOGICAL, EXTERNAL :: DMUMPS_IS_TRSM_LARGE_ENOUGH, & DMUMPS_IS_GEMM_LARGE_ENOUGH PARPIV_T1 = KEEP(269) IF (PARPIV_T1.EQ.-3) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.77) THEN PARPIV_T1 = 0 ENDIF NCB = NFRONT-NASS1 IF (NCB.EQ.KEEP(253)) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.0) RETURN IF ( (PARPIV_T1.EQ.-2).AND.LR_ACTIVATED ) THEN PARPIV_T1 = 1 ENDIF IF (PARPIV_T1.EQ.-2) THEN IF ( & ( DMUMPS_IS_TRSM_LARGE_ENOUGH ( NASS1, NCB & ) & ) & .OR. & ( DMUMPS_IS_GEMM_LARGE_ENOUGH ( NCB, NCB, NASS1 & ) & ) & ) THEN PARPIV_T1 = 1 ELSE PARPIV_T1 = 0 ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SET_PARPIVT1 LOGICAL FUNCTION DMUMPS_IS_TRSM_LARGE_ENOUGH & ( M, N & ) IMPLICIT NONE INTEGER, INTENT(in) :: M, N DOUBLE PRECISION :: AI INTEGER, PARAMETER :: THRES_AI = 400 AI = ( dble(M)*dble(N) ) / & ( dble(M)/dble(2) + dble(2)*dble(N) ) DMUMPS_IS_TRSM_LARGE_ENOUGH = (AI.GE.dble(THRES_AI)) RETURN END FUNCTION DMUMPS_IS_TRSM_LARGE_ENOUGH LOGICAL FUNCTION DMUMPS_IS_GEMM_LARGE_ENOUGH & ( M, N, K & ) IMPLICIT NONE INTEGER, INTENT(in) :: M, N, K DOUBLE PRECISION :: AI INTEGER, PARAMETER :: THRES_AI = 400 AI = ( dble(2)*dble(M)*dble(N)*dble(K) ) / & ( dble(M)*dble(N) + dble(M)*dble(K) + dble(K)*dble(N) ) DMUMPS_IS_GEMM_LARGE_ENOUGH = (AI.GE.dble(THRES_AI)) RETURN END FUNCTION DMUMPS_IS_GEMM_LARGE_ENOUGH SUBROUTINE DMUMPS_PARPIVT1_SET_MAX ( INODE, & A, LAELL8, KEEP, NFRONT, & NASS1, NVSCHUR_K253, NB_POSTPONED) !$ USE OMP_LIB IMPLICIT NONE INTEGER(8), intent(in) :: LAELL8 INTEGER, intent(in) :: INODE INTEGER, intent(in) :: KEEP(500), NFRONT, NASS1, & NVSCHUR_K253 INTEGER, intent(in) :: NB_POSTPONED DOUBLE PRECISION, intent(inout) :: A(LAELL8) INTEGER(8) :: APOSMAX, APOS, NASS1_8, NFRONT_8 INTEGER :: I, J, NCB DOUBLE PRECISION :: ZERO DOUBLE PRECISION :: RMAX LOGICAL :: OMP_FLAG INTEGER :: JB, NB_BLOCKS, BLSIZE INTEGER(8) :: APOSSHIFT INTEGER :: NOMP PARAMETER( ZERO = 0.0D0 ) NASS1_8 = int(NASS1, 8) NFRONT_8 = int(NFRONT, 8) NCB = NFRONT-NASS1-NVSCHUR_K253 IF ((NCB.EQ.0).AND.(NVSCHUR_K253.EQ.0)) CALL MUMPS_ABORT() APOSMAX = LAELL8 - NASS1_8 + 1_8 A(APOSMAX:APOSMAX+NASS1_8-1_8)= ZERO IF (NCB.EQ.0) RETURN IF (KEEP(50).EQ.2) THEN IF ( NASS1 .LE. KEEP(366) ) THEN APOS = 1_8 + (NASS1_8*NFRONT_8) DO I = 1, NCB DO J = 1, NASS1 RMAX = dble(A(APOSMAX+int(J,8)-1_8)) RMAX = max(RMAX, abs(A(APOS+int(J,8)-1_8))) A(APOSMAX+int(J,8)-1_8) = RMAX ENDDO APOS = APOS+NFRONT_8 ENDDO ELSE NOMP = 1 !$ NOMP = OMP_GET_MAX_THREADS() OMP_FLAG = int(NCB,8)*int(NASS1,8) .GT. int(KEEP(361),8) & .AND. (NASS1 .GT. KEEP(366)) .AND. (NOMP.GT.1) BLSIZE = max(KEEP(366),1) NB_BLOCKS = NASS1 / BLSIZE BLSIZE = (NASS1 + NB_BLOCKS - 1)/ NB_BLOCKS APOSSHIFT=NASS1_8 * NFRONT_8 !$OMP PARALLEL DO PRIVATE(I,J,APOS,JB,RMAX) IF (OMP_FLAG) DO JB = 1, NASS1, BLSIZE DO I = 1, NCB DO J = JB, min(JB+BLSIZE-1,NASS1) APOS = APOSSHIFT + int(I-1,8) * int(NFRONT,8) + int(J,8) RMAX = dble( A(APOSMAX+int(J,8) - 1_8) ) RMAX = max( RMAX, abs(A(APOS+int(J,8)) ) ) A(APOSMAX+int(J,8)-1_8) = RMAX ENDDO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF ELSE OMP_FLAG = int(NCB,8)*int(NASS1,8) .GT. int(KEEP(361),8) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(I,J,APOS,RMAX) DO I = 1, NASS1 RMAX = 0.0D0 APOS = 1_8 + NASS1_8+int(I-1,8)*NFRONT_8 DO J = 1, NCB RMAX = max(RMAX, abs(A(APOS+int(J-1,8)))) ENDDO A(APOSMAX+int(I,8)-1_8) = RMAX ENDDO !$OMP END PARALLEL DO ELSE APOS = 1_8 + NASS1_8 DO I = 1, NASS1 RMAX = 0.0D0 DO J = 1, NCB RMAX = max(RMAX, abs(A(APOS+int(J,8)-1))) ENDDO A(APOSMAX+int(I,8)-1_8) = RMAX APOS = APOS+NFRONT_8 ENDDO ENDIF ENDIF CALL DMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, A(APOSMAX), NASS1, NB_POSTPONED) RETURN END SUBROUTINE DMUMPS_PARPIVT1_SET_MAX SUBROUTINE DMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, PARPIV, LPARPIV, & NB_POSTPONED) IMPLICIT NONE INTEGER, intent(in) :: INODE, LPARPIV, KEEP(500) DOUBLE PRECISION, intent(inout):: PARPIV(LPARPIV) INTEGER, intent(in) :: NB_POSTPONED INTEGER :: I DOUBLE PRECISION :: EPS, RMIN, RZERO, RTMP DOUBLE PRECISION :: RMAX LOGICAL :: UPDATE_PARPIV PARAMETER( RZERO = 0.0D0 ) UPDATE_PARPIV=.FALSE. RMIN = huge(RZERO) RMAX = RZERO EPS = sqrt(epsilon(RZERO))*0.01D0 DO I = 1, LPARPIV RTMP = dble(PARPIV(I)) IF (RTMP.GT.RZERO) THEN RMIN = min(RMIN, RTMP) ELSE UPDATE_PARPIV=.TRUE. ENDIF IF (RTMP.LE.EPS) UPDATE_PARPIV=.TRUE. RMAX= max(RMAX,dble(PARPIV(I))) ENDDO IF (UPDATE_PARPIV) THEN IF (RMIN.LT.huge(RMIN)) THEN RMAX= min (RMAX, EPS) DO I = 1, LPARPIV-NB_POSTPONED RTMP = dble(PARPIV(I)) IF (RTMP.LE.EPS) THEN PARPIV(I) = -RMAX ENDIF ENDDO IF (NB_POSTPONED.GT.0) THEN DO I=LPARPIV-NB_POSTPONED+1, LPARPIV RTMP = dble(PARPIV(I)) IF (RTMP.LE.EPS) THEN PARPIV(I) = -RMAX ENDIF ENDDO ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_UPDATE_PARPIV_ENTRIES SUBROUTINE DMUMPS_PARPIVT1_SET_NVSCHUR_MAX & (N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1, & NB_POSTPONED) USE DMUMPS_FAC_FRONT_AUX_M, ONLY: DMUMPS_GET_SIZE_SCHUR_IN_FRONT IMPLICIT NONE INTEGER, intent(in) :: N, INODE, LIW, IOLDPS, & NFRONT, NASS1, NB_POSTPONED INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: IW (LIW), PERM(N), KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER, intent(inout) :: PARPIV_T1 INTEGER :: NVSCHUR_K253, IROW_L INTEGER(8) :: LAELL8, NFRONT8 INCLUDE 'mumps_headers.h' IF (PARPIV_T1.EQ.-999) THEN CALL DMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) ELSE IF ((PARPIV_T1.NE.0.AND.PARPIV_T1.NE.1)) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.NE.0) THEN IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) ) THEN IROW_L = IOLDPS+6+KEEP(IXSZ)+NASS1 CALL DMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS1, & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR_K253 ) ELSE NVSCHUR_K253 = KEEP(253) ENDIF NFRONT8 = int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 + int(NASS1,8) CALL DMUMPS_PARPIVT1_SET_MAX ( INODE, & A(POSELT), LAELL8, KEEP, & NFRONT, NASS1, NVSCHUR_K253, & NB_POSTPONED ) ENDIF RETURN END SUBROUTINE DMUMPS_PARPIVT1_SET_NVSCHUR_MAX MUMPS_5.8.1/src/cfac_omp_m.F0000664000175000017500000015333215042446440015431 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC_OMP_M INTEGER(8), PARAMETER :: UnderL0 = -20_8 INTEGER(8), PARAMETER :: CopyNotStarted = -19_8 INTEGER(8), PARAMETER :: WaitMem = -18_8 INTEGER(8), PARAMETER :: CopyFactorsFinished = -17_8 INTEGER(8), PARAMETER :: AllocateViderCBEnCours = -16_8 INTEGER(8), PARAMETER :: Finished = -15_8 CONTAINS SUBROUTINE CMUMPS_FAC_L0_OMP(N,LIW, NSTK_STEPS, ND, & FILS,STEP, FRERE, DAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PTRIST, PTRAST, PIMASTER, PAMASTER, PTRARW, PTRAIW, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, & RHS_MUMPS, RINFO, NBROOT, NBRTOT, NBROOT_UNDER_L0, UU, ICNTL, & PTLUST_S, PTRFAC, INFO, KEEP, KEEP8, PROCNODE_STEPS,SLAVEF, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & INTARR, DBLARR, root, roota, PERM, NELT, FRTPTR, FRTELT, LPTRAR, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB, NE, DKEEP, PIVNUL_LIST_STRUCT, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP, PHYS_L0_OMP, PERM_L0_OMP, PTR_LEAFS_L0_OMP, & L0_OMP_MAPPING, LL0_OMP_MAPPING, THREAD_LA, & MUMPS_TPS_ARR, CMUMPS_TPS_ARR, & NSTEPSW, OPASSW, OPELIW, NELVAW, COMP, & MAXFRW, NMAXNPIVW, NPVW, NOFFNEGW, NULLNEGW, & NB22T1W, NBTINYW, DET_EXPW, DET_MANTW, DET_SIGNW, & LRGROUPS, L0_OMP_FACTORS, LL0_OMP_FACTORS, & I4_L0_OMP, NBSTATS_I4, NBCOLS_I4, & I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 ) USE MUMPS_LOAD !$ USE OMP_LIB USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T USE CMUMPS_TPS_M, ONLY : CMUMPS_TPS_T USE MUMPS_LR_STATS USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC, & CMUMPS_L0OMPFAC_T USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : & CMUMPS_DM_FAC_ALLOC_ALLOWED, & CMUMPS_DM_ALLOC_S_WK, & CMUMPS_DM_FREE_S_WK USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER N,LIW, LPTRAR, & NSTEPSW, INFO(80) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER(8), INTENT(IN) :: THREAD_LA INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST_S(KEEP(28)), PERM(N) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NE(KEEP(28)) REAL RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER NBROOT INTEGER NBRTOT INTEGER, intent(out) :: NBROOT_UNDER_L0 INTEGER COMM_LOAD, ASS_IRECV REAL UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) COMPLEX DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) DOUBLE PRECISION :: OPASSW, OPELIW INTEGER LRGROUPS(KEEP(280)) INTEGER, INTENT ( IN ) :: LPOOL_B_L0_OMP INTEGER, INTENT ( IN ) :: IPOOL_B_L0_OMP & ( LPOOL_B_L0_OMP ) INTEGER, INTENT ( IN ) :: L_PHYS_L0_OMP INTEGER, INTENT ( IN ) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT ( IN ) :: L_VIRT_L0_OMP INTEGER, INTENT ( IN ) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT ( IN ) :: VIRT_L0_OMP_MAPPING( L_VIRT_L0_OMP ) INTEGER, INTENT ( IN ) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT ( IN ) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT ( IN ) :: LL0_OMP_MAPPING INTEGER, INTENT ( OUT ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) TYPE (MUMPS_TPS_T), DIMENSION(:) :: MUMPS_TPS_ARR TYPE (CMUMPS_TPS_T), DIMENSION(:) :: CMUMPS_TPS_ARR INTEGER, INTENT ( IN ) :: LL0_OMP_FACTORS TYPE (CMUMPS_L0OMPFAC_T), INTENT(INOUT) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER, INTENT (IN) :: NBSTATS_I4, NBSTATS_I8 INTEGER, INTENT (IN) :: NBCOLS_I4, NBCOLS_I8 INTEGER, INTENT (IN) :: I4_L0_OMP(NBSTATS_I4, NBCOLS_I4) INTEGER(8), INTENT (IN) :: I8_L0_OMP(NBSTATS_I8, NBCOLS_I8) LOGICAL CMUMPS_POOL_EMPTY EXTERNAL CMUMPS_POOL_EMPTY, CMUMPS_EXTRACT_POOL INTEGER :: MYTHREAD_ID, ITH INTEGER :: THREAD_ID_P DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 INTEGER INODE, LEAF INTEGER TYPEF INTEGER NBFIN INTEGER TYPE INTEGER NBROOT_PROCESSED INTEGER MAXFRW, NPVW, NMAXNPIVW, NOFFNEGW, NULLNEGW, NELVAW, COMP INTEGER :: NB22T1W, NBTINYW, DET_EXPW, DET_SIGNW COMPLEX :: DET_MANTW DOUBLE PRECISION FLOP_ESTIM_ACC INTEGER :: LPOOL_P INTEGER, DIMENSION(:), ALLOCATABLE :: IPOOL_P INTEGER(8) :: TO_ALLOCATE INTEGER, DIMENSION(:), ALLOCATABLE :: ID INTEGER(8), DIMENSION(:), ALLOCATABLE :: VAL INTEGER(8), ALLOCATABLE, DIMENSION(:) :: STATE, SIZE_COPIED INTEGER :: NbWaitMem, NbFinished, NbOnGoingCopies, NbUnderL0 INTEGER(8) :: KEEP8_77_SAVE DOUBLE PRECISION :: GTIME INTEGER(8) :: MEMDISPO_UNDERL0, MEMDISPO_PERTHREAD INTEGER :: BLR_STRAT INTEGER :: VIRTUAL_TASK, PHYSICAL_TASK INTEGER :: IFATH INTEGER :: I, INFO_P(2), allocok INTEGER(8) :: I8 !$ INTEGER(8) :: CHUNK8 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP_SAVE, NOMP_TOTAL !$ INTEGER :: NOMP_INNER !$ LOGICAL :: SAVE_NESTED CALL MUMPS_LOAD_DISABLE() GTIME = MPI_WTIME() L0_OMP_MAPPING = 0 NBROOT_PROCESSED = 0 NSTEPSW = 0 OPASSW = DZERO OPELIW = DZERO NELVAW = 0 COMP = 0 MAXFRW = 0 NMAXNPIVW = 0 NOFFNEGW = 0 NULLNEGW = 0 FLOP_ESTIM_ACC = DZERO NPVW = 0 NB22T1W = 0 NBTINYW = 0 DET_EXPW = 0 DET_MANTW = cmplx(1.0E0,0.0E0, kind=kind(1.0E0)) DET_SIGNW = 1 DO ITH = 1, KEEP(400) NULLIFY(MUMPS_TPS_ARR(ITH)%IW) NULLIFY(MUMPS_TPS_ARR(ITH)%ITLOC) NULLIFY(CMUMPS_TPS_ARR(ITH)%A) CALL CMUMPS_SET_MAXS_MAXIS_THREAD( & MUMPS_TPS_ARR(ITH)%LA, & MUMPS_TPS_ARR(ITH)%LIW, BLR_STRAT, & KEEP, & I4_L0_OMP(1,ITH), NBSTATS_I4, & I8_L0_OMP(1,ITH), NBSTATS_I8) ENDDO IF (KEEP8(4) .NE. 0_8) THEN CALL CMUMPS_MA_EFF_MEM_DISPO ( & MUMPS_TPS_ARR, KEEP(400),KEEP8, KEEP, & N, BLR_STRAT, LPOOL_B_L0_OMP, & I8_L0_OMP, NBSTATS_I8, & MEMDISPO_UNDERL0 & ) IF (KEEP(486).EQ.2) THEN MEMDISPO_UNDERL0 = max(MEMDISPO_UNDERL0/20_8,0_8) ELSE MEMDISPO_UNDERL0 = max(MEMDISPO_UNDERL0/4_8,0_8) ENDIF KEEP8(77) = KEEP8(77) + MEMDISPO_UNDERL0 MEMDISPO_PERTHREAD = 0_8 IF (MEMDISPO_UNDERL0.GT.0) THEN MEMDISPO_PERTHREAD = MEMDISPO_UNDERL0/(int(KEEP(400),8)) ENDIF DO ITH = 1, KEEP(400) MUMPS_TPS_ARR(ITH)%LA = MUMPS_TPS_ARR(ITH)%LA + & MEMDISPO_PERTHREAD ENDDO ENDIF DO ITH = 1, KEEP(400) MUMPS_TPS_ARR(ITH)%LRLU = MUMPS_TPS_ARR(ITH)%LA MUMPS_TPS_ARR(ITH)%LRLUS = MUMPS_TPS_ARR(ITH)%LA MUMPS_TPS_ARR(ITH)%LRLUSM = MUMPS_TPS_ARR(ITH)%LA MUMPS_TPS_ARR(ITH)%IPTRLU = MUMPS_TPS_ARR(ITH)%LA MUMPS_TPS_ARR(ITH)%POSFAC = 1_8 MUMPS_TPS_ARR(ITH)%IWPOS = 1 MUMPS_TPS_ARR(ITH)%IWPOSCB = MUMPS_TPS_ARR(ITH)%LIW ENDDO IF (KEEP(406) .EQ. 2 ) THEN ALLOCATE(STATE(KEEP(400)), SIZE_COPIED(KEEP(400)), stat=allocok) IF (allocok .GT. 0 ) THEN WRITE(*,*) "Problem allocating STATE/SIZE_COPIED", KEEP(400) CALL MUMPS_ABORT() ENDIF CALL CMUMPS_PERFORM_COPIES_INIT( STATE, KEEP8_77_SAVE, & NbWaitMem, NbFinished, NbOnGoingCopies, NbUnderL0, & KEEP, KEEP8 ) ENDIF !$ NOMP_INNER = 1 !$ IF (KEEP(369).GT.0) THEN !$ NOMP_TOTAL = omp_get_max_threads() !$ IF ( NOMP_TOTAL .NE. KEEP(400) ) THEN !$ IF ( KEEP(439) .GT. 1 ) THEN !$ NOMP_INNER = KEEP(439) !$ ELSE IF ( KEEP(439) .EQ. -1 !$ & ) THEN !$ NOMP_INNER = NOMP_TOTAL / KEEP(400) !$ ENDIF !$ IF (NOMP_INNER .GT. 1) THEN !$ SAVE_NESTED = omp_get_nested() !$ CALL OMP_SET_NESTED(.TRUE.) !$ ENDIF !$ ENDIF #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(KEEP(400),4)) #else !$ CALL omp_set_num_threads(KEEP(400)) #endif !$ ENDIF !$OMP PARALLEL !$OMP& SHARED ( IPOOL_B_L0_OMP, LPOOL_B_L0_OMP ) !$OMP& PRIVATE ( VIRTUAL_TASK, PHYSICAL_TASK, !$OMP& IPOOL_P, LPOOL_P, LEAF, INODE, IFATH, INFO_P, I, I8, !$OMP& TO_ALLOCATE, THREAD_ID_P, !$OMP& TYPE, TYPEF, NOMP_SAVE, allocok ) !$OMP& REDUCTION ( + : NPVW, OPASSW, OPELIW, NOFFNEGW, NELVAW, COMP, !$OMP& NB22T1W, NBTINYW, DET_EXPW, NULLNEGW, !$OMP& FLOP_ESTIM_ACC, NBROOT_PROCESSED, NSTEPSW ) !$OMP& REDUCTION ( * : DET_MANTW, DET_SIGNW ) !$OMP& REDUCTION ( max : MAXFRW, NMAXNPIVW ) THREAD_ID_P = 1 !$ THREAD_ID_P = OMP_GET_THREAD_NUM () + 1 !$OMP BARRIER !$ NOMP_SAVE = omp_get_max_threads() #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_INNER,4)) #else !$ CALL omp_set_num_threads(NOMP_INNER) #endif LPOOL_P = LPOOL_B_L0_OMP LEAF = 1 INFO_P = 0 VIRTUAL_TASK = 0 !$ IF ( omp_get_num_threads() .NE. KEEP(400) ) THEN !$ INFO_P(1)=-58 !$ INFO_P(2)=-100-omp_get_num_threads() !$ GOTO 700 !$ ENDIF CALL CMUMPS_DM_FAC_ALLOC_ALLOWED( MUMPS_TPS_ARR(THREAD_ID_P)%LA, & KEEP8, & INFO_P(1), INFO_P(2) ) IF (INFO_P(1) .LT. 0) GOTO 700 CALL CMUMPS_DM_ALLOC_S_WK( CMUMPS_TPS_ARR(THREAD_ID_P)%A, & max(1_8,MUMPS_TPS_ARR(THREAD_ID_P)%LA), allocok, KEEP(430), & KEEP(35) ) IF (allocok.GT.0) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4( MUMPS_TPS_ARR(THREAD_ID_P)%LA, & INFO_P(2)) GOTO 700 ELSE CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & MUMPS_TPS_ARR(THREAD_ID_P)%LA, & KEEP(405).EQ.1, & KEEP8, INFO_P(1), INFO_P(2), & .FALSE., .FALSE. ) IF (INFO_P(1) .LT. 0) THEN GOTO 700 ENDIF ENDIF TO_ALLOCATE = & ((int(MUMPS_TPS_ARR(THREAD_ID_P)%LIW,8) * int(KEEP(34),8 )) / & int(KEEP(35),8 ))+ & ((int(LPOOL_P,8) * int(KEEP(34),8 )) / int(KEEP(35),8 ))+ & ((int(N+KEEP(253),8) * int(KEEP(34),8 )) / int(KEEP(35),8 )) CALL CMUMPS_DM_FAC_ALLOC_ALLOWED( TO_ALLOCATE, & KEEP8, INFO_P(1), INFO_P(2) ) IF ( INFO_P(1) .LT. 0 ) GOTO 700 ALLOCATE ( MUMPS_TPS_ARR(THREAD_ID_P)%IW( & MUMPS_TPS_ARR(THREAD_ID_P)%LIW ), & IPOOL_P ( LPOOL_P ), & MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC ( N + KEEP(253) ), & stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO_P(1) = -13 INFO_P(2) = MUMPS_TPS_ARR(THREAD_ID_P)%LIW + & LPOOL_P + N+KEEP(253) GOTO 700 ELSE CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( TO_ALLOCATE, & KEEP(405).EQ.1, KEEP8, & INFO_P(1), INFO_P(2), .TRUE., .FALSE. ) IF (INFO_P(1) .LT. 0) THEN GOTO 700 ENDIF ENDIF CALL CMUMPS_ALLOC_CB( .FALSE., 0_8, & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, DKEEP, & MUMPS_TPS_ARR(THREAD_ID_P)%IW(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LIW, & CMUMPS_TPS_ARR(THREAD_ID_P)%A(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LA, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%IPTRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOS, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUSM, & INFO_P(1), INFO_P(2) & ) CALL CMUMPS_INIT_POOL_LAST3( IPOOL_P(1), LPOOL_P, & LEAF ) MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC = 0 600 CONTINUE VIRTUAL_TASK = VIRTUAL_TASK + 1 IF ( VIRTUAL_TASK .LT. L_VIRT_L0_OMP ) THEN IF ( VIRT_L0_OMP_MAPPING( VIRTUAL_TASK ) .EQ. THREAD_ID_P ) THEN DO PHYSICAL_TASK = & VIRT_L0_OMP ( VIRTUAL_TASK ), & VIRT_L0_OMP ( VIRTUAL_TASK + 1 ) - 1 DO I = PTR_LEAFS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK )+1 ) + 1, & PTR_LEAFS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK ) ) IF (IPOOL_B_L0_OMP(I) .GT. 0) THEN CALL CMUMPS_INSERT_POOL_N( N, IPOOL_P(1), & LPOOL_P, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), 3, 0, 1, STEP, & IPOOL_B_L0_OMP(I) ) END IF END DO DO WHILE ( & .NOT. CMUMPS_POOL_EMPTY( IPOOL_P(1), LPOOL_P ) & .AND. INFO_P(1) .GE. 0 ) CALL CMUMPS_EXTRACT_POOL( N, IPOOL_P(1), LPOOL_P, & PROCNODE_STEPS, SLAVEF, STEP, INODE, KEEP, KEEP8, MYID_NODES, & ND, .FALSE. ) 10 CONTINUE L0_OMP_MAPPING ( STEP ( INODE ) ) = THREAD_ID_P IFATH = DAD ( STEP ( INODE ) ) TYPE = 1 IF ( IFATH .NE. 0 ) THEN TYPEF = 1 ELSE TYPEF = -9999 ENDIF CALL MUMPS_STOP_ON_USER_REQUEST(KEEP, KEEP8, ICNTL, & INFO_P, MYID) IF (INFO_P(1) .LT. 0) THEN GOTO 700 ENDIF IF (THREAD_ID_P .EQ. KEEP(400)-1) THEN CALL CMUMPS_UPDATE_PROGRESS( OPELIW*KEEP(400), KEEP8 ) ENDIF CALL CMUMPS_PROCESS_FRONT_NIV1(COMM_LOAD, ASS_IRECV, N, INODE, & TYPE, TYPEF, MUMPS_TPS_ARR(THREAD_ID_P)%LA, MUMPS_TPS_ARR(THREAD & _ID_P)%IW(1), MUMPS_TPS_ARR(THREAD_ID_P)%LIW, CMUMPS_TPS_ARR( & THREAD_ID_P)%A(1), MAXFRW, NOFFNEGW, NULLNEGW, NPVW, & NB22T1W, NBTINYW, DET_EXPW, DET_MANTW, DET_SIGNW, INFO_P, UU, & SEUIL, SEUIL_LDLT_NIV2, OPELIW, NELVAW, NMAXNPIVW, NSTEPSW, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & NE, MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS, MUMPS_TPS_ARR(THREAD_ID_P)% % LRLUSM, MUMPS_TPS_ARR(THREAD_ID_P)%IPTRLU, ICNTL, KEEP, KEEP8, & DKEEP, PIVNUL_LIST_STRUCT, COMP, MUMPS_TPS_ARR(THREAD_ID_P)% & IWPOS, MUMPS_TPS_ARR(THREAD_ID_P)%IWPOSCB, PROCNODE_STEPS, & SLAVEF, IFATH, COMM_NODES, MYID_NODES, IPOOL_P, LPOOL_P, LEAF, & PERM, NSTK_STEPS, BUFR, LBUFR, LBUFR_BYTES, & NBFIN, root, roota, OPASSW, MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC(1), & RHS_MUMPS, FILS, PTRARW, PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, & PTRDEBARR, INTARR, DBLARR, ND, FRERE, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS, FLOP_ESTIM_ACC ) IF (INFO_P(1) .LT. 0) THEN GOTO 700 ENDIF IF ( IFATH .NE. 0 ) THEN IF ( PHYS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK ) ) & .NE. INODE ) THEN NSTK_STEPS ( STEP ( IFATH ) ) = & NSTK_STEPS ( STEP ( IFATH ) ) - 1 IF ( NSTK_STEPS ( STEP ( IFATH ) ) .EQ. 0 ) THEN INODE = IFATH GOTO 10 ENDIF ELSE !$OMP ATOMIC UPDATE NSTK_STEPS ( STEP ( IFATH ) ) = & NSTK_STEPS ( STEP ( IFATH ) ) - 1 !$OMP END ATOMIC END IF ELSE NBROOT_PROCESSED = NBROOT_PROCESSED + 1 END IF END DO END DO ENDIF GOTO 600 ENDIF 700 CONTINUE IF (associated(MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC)) THEN DEALLOCATE(MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC) NULLIFY(MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -(int(N+KEEP(253),8) * int(KEEP(34),8 )) / int(KEEP(35),8), & KEEP(405).EQ.1, KEEP8, & INFO_P(1), INFO_P(2), .TRUE., .FALSE. ) ENDIF IF (allocated(IPOOL_P)) THEN DEALLOCATE(IPOOL_P); CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -(int(LPOOL_P,8) * int(KEEP(34),8 )) / int(KEEP(35),8), & KEEP(405).EQ.1, KEEP8, & INFO_P(1), INFO_P(2), .TRUE., .FALSE. ) ENDIF IF ( KEEP(406) .EQ. 2) THEN CALL CMUMPS_PERFORM_COPIES( THREAD_ID_P, & MUMPS_TPS_ARR, CMUMPS_TPS_ARR, & L0_OMP_FACTORS, LL0_OMP_FACTORS, & STATE, SIZE_COPIED, & NbWaitMem, NbFinished, NbOngoingCopies, NbUnderL0, & MYID_NODES, N, SLAVEF, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & KEEP, KEEP8, INFO_P & ) ELSE IF ((KEEP(407) .EQ. 1) .OR. (KEEP(406) .EQ.1) ) THEN IF (INFO_P(1) .GE. 0) THEN CALL CMUMPS_DM_CBSTATIC2DYNAMIC_I & (2, & 0_8, & .FALSE., & MYID_NODES, N, SLAVEF, KEEP, KEEP8, & MUMPS_TPS_ARR(THREAD_ID_P)%IW(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LIW, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOSCB, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOS, & CMUMPS_TPS_ARR(THREAD_ID_P)%A(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LA, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%IPTRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & INFO_P(1), INFO_P(2) ) ENDIF ENDIF IF (KEEP(406) .EQ.1) THEN IF (INFO_P(1) .GE.0 )THEN TO_ALLOCATE = max(MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1,1_8) CALL CMUMPS_DM_FAC_ALLOC_ALLOWED( TO_ALLOCATE, & KEEP8, INFO_P(1), INFO_P(2) ) ENDIF IF (INFO_P(1) .GE.0 )THEN ALLOCATE(L0_OMP_FACTORS(THREAD_ID_P)%A(TO_ALLOCATE), & stat=allocok) IF (allocok .GT. 0) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4(TO_ALLOCATE, INFO_P(2)) L0_OMP_FACTORS(THREAD_ID_P)%LA = 0_8 ELSE L0_OMP_FACTORS(THREAD_ID_P)%LA = & MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8 CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & L0_OMP_FACTORS(THREAD_ID_P)%LA, KEEP(405).EQ.1, KEEP8, & INFO_P(1), INFO_P(2), .TRUE., .FALSE. ) ENDIF ENDIF IF (INFO_P(1) .GE.0 ) THEN DO I8 = 1_8, MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8 L0_OMP_FACTORS(THREAD_ID_P)%A(I8) = & CMUMPS_TPS_ARR(THREAD_ID_P)%A(I8) ENDDO ENDIF IF ( associated(CMUMPS_TPS_ARR(THREAD_ID_P)%A)) THEN CALL CMUMPS_DM_FREE_S_WK( CMUMPS_TPS_ARR(THREAD_ID_P)%A, & KEEP(430) ) NULLIFY(CMUMPS_TPS_ARR(THREAD_ID_P)%A) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -MUMPS_TPS_ARR(THREAD_ID_P)%LA, & KEEP(405).EQ.1, & KEEP8, & INFO_P(1), INFO_P(2), & .FALSE., .FALSE. ) IF (INFO_P(1) .GE. 0) THEN !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - L0_OMP_FACTORS(THREAD_ID_P)%LA !$OMP END ATOMIC ENDIF ENDIF ENDIF ENDIF IF (INFO_P(1) .LT.0) THEN !$OMP CRITICAL(critical_info) INFO(1) = INFO_P(1) INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ELSE IF (INFO_P(1) .GE. 0) THEN !$OMP CRITICAL(critical_info) IF (INFO(1) .EQ. 0) THEN INFO(1) = INFO_P(1) INFO(2) = INFO_P(2) ENDIF !$OMP END CRITICAL(critical_info) ENDIF #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_SAVE,4)) #else !$ CALL omp_set_num_threads(NOMP_SAVE) #endif !$OMP END PARALLEL !$ IF (KEEP(369).GT.0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_TOTAL),4)) #else !$ CALL omp_set_num_threads(NOMP_TOTAL) #endif !$ IF (NOMP_INNER .GT. 1) THEN !$ CALL OMP_SET_NESTED(SAVE_NESTED) !$ ENDIF !$ ENDIF IF (INFO(1) .LT. 0) THEN IF (ICNTL(1) .GT. 0 .AND. ICNTL(4) .GE.1 ) THEN WRITE(ICNTL(1),'(A,I6,I16,A,I5,A)') & "** ERROR DURING L0_OMP: INFO(1:2)=", & INFO(1), INFO(2), " (MPI worker ", MYID_NODES,")" ENDIF ENDIF IF ( KEEP(406) .EQ. 0 ) THEN ALLOCATE(ID(KEEP(400)), VAL(KEEP(400)), & stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = KEEP(400) GOTO 800 ENDIF DO MYTHREAD_ID = 1, KEEP(400) VAL (MYTHREAD_ID) = MUMPS_TPS_ARR( MYTHREAD_ID )%POSFAC-1_8 ID (MYTHREAD_ID) = MYTHREAD_ID ENDDO CALL MUMPS_SORT_INT8(KEEP(400), VAL, ID) DO ITH=1, KEEP(400) MYTHREAD_ID = ID(ITH) IF ((KEEP(407).NE.1) .AND. (KEEP(406).EQ.0)) THEN IF (INFO(1) .GE. 0) THEN CALL CMUMPS_DM_CBSTATIC2DYNAMIC_I & (2, & 0_8, & .FALSE., & MYID_NODES, N, SLAVEF, KEEP, KEEP8, & MUMPS_TPS_ARR(MYTHREAD_ID)%IW(1), & MUMPS_TPS_ARR(MYTHREAD_ID)%LIW, & MUMPS_TPS_ARR(MYTHREAD_ID)%IWPOSCB, & MUMPS_TPS_ARR(MYTHREAD_ID)%IWPOS, & CMUMPS_TPS_ARR(MYTHREAD_ID)%A(1), & MUMPS_TPS_ARR(MYTHREAD_ID)%LA, & MUMPS_TPS_ARR(MYTHREAD_ID)%LRLU, & MUMPS_TPS_ARR(MYTHREAD_ID)%IPTRLU, & MUMPS_TPS_ARR(MYTHREAD_ID)%LRLUS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & INFO(1), INFO(2) ) ENDIF ENDIF IF (KEEP(406).EQ.0) THEN IF (INFO(1) .GE. 0 )THEN TO_ALLOCATE = max(MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC-1,1_8) CALL CMUMPS_DM_FAC_ALLOC_ALLOWED( TO_ALLOCATE, & KEEP8, INFO(1), INFO(2) ) ENDIF IF (INFO(1) .GE.0 ) THEN ALLOCATE(L0_OMP_FACTORS(MYTHREAD_ID)%A(TO_ALLOCATE), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1) = -13 CALL MUMPS_SETI8TOI4(TO_ALLOCATE, INFO(2)) L0_OMP_FACTORS(MYTHREAD_ID)%LA = 0_8 ELSE L0_OMP_FACTORS(MYTHREAD_ID)%LA = & MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC-1_8 CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & L0_OMP_FACTORS(MYTHREAD_ID)%LA, & KEEP(405).EQ.1, KEEP8, & INFO(1), INFO(2), .TRUE., .FALSE. ) ENDIF ENDIF IF (INFO(1) .GE. 0) THEN !$ CHUNK8 = max( int(KEEP(361),8), !$ & (MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC+KEEP(400)-2_8) / !$ & KEEP(400) ) !$ OMP_FLAG = ( (MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC-1_8 > !$ & int(KEEP(361),8)) !$ & .AND. (KEEP(400).GT.1) !$ & ) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (OMP_FLAG) DO I8 = 1_8, MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC-1_8 L0_OMP_FACTORS(MYTHREAD_ID)%A(I8) = & CMUMPS_TPS_ARR(MYTHREAD_ID)%A(I8) ENDDO !$OMP END PARALLEL DO ENDIF IF ( associated(CMUMPS_TPS_ARR(MYTHREAD_ID)%A)) THEN CALL CMUMPS_DM_FREE_S_WK( CMUMPS_TPS_ARR(THREAD_ID_P)%A, & KEEP(430) ) NULLIFY(CMUMPS_TPS_ARR(MYTHREAD_ID)%A) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -MUMPS_TPS_ARR(MYTHREAD_ID)%LA, & KEEP(405).EQ.1, KEEP8, & INFO(1), INFO(2), & .FALSE., .FALSE. ) IF (INFO(1).GE.0) THEN KEEP8(69) = KEEP8(69) - L0_OMP_FACTORS(MYTHREAD_ID)%LA ENDIF ENDIF ENDIF ENDDO IF (ALLOCATED(ID)) DEALLOCATE(ID) IF (ALLOCATED(VAL)) DEALLOCATE(VAL) ENDIF 800 CONTINUE DO ITH = 1, KEEP(400) IF ( associated(CMUMPS_TPS_ARR(ITH)%A)) THEN CALL CMUMPS_DM_FREE_S_WK( CMUMPS_TPS_ARR(ITH)%A, & KEEP(430) ) NULLIFY(CMUMPS_TPS_ARR(ITH)%A) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -MUMPS_TPS_ARR(ITH)%LA, & KEEP(405).EQ.1, KEEP8, & INFO(1), INFO(2), & .FALSE., .FALSE. ) IF (INFO(1).GE.0) THEN KEEP8(69) = KEEP8(69) - L0_OMP_FACTORS(ITH)%LA ENDIF ENDIF ENDDO KEEP8(64) = 0_8 DO I = 1, KEEP(400) KEEP8(64) = KEEP8(64) + MUMPS_TPS_ARR(I)%POSFAC - 1_8 ENDDO KEEP8(62) = 0_8 DO I = 1, KEEP(400) KEEP8(62) = KEEP8(62) + MUMPS_TPS_ARR(I)%LRLUSM ENDDO NBROOT_UNDER_L0 = NBROOT_PROCESSED DKEEP(95) = real(MPI_WTIME() - GTIME) IF (KEEP(486) .NE. 0) THEN TIME_UPDATE = TIME_UPDATE/dble(KEEP(400)) TIME_COMPRESS = TIME_COMPRESS/dble(KEEP(400)) TIME_FRSWAP_COMPRESS = TIME_FRSWAP_COMPRESS/dble(KEEP(400)) TIME_CB_COMPRESS = TIME_CB_COMPRESS/dble(KEEP(400)) TIME_PANEL = TIME_PANEL/dble(KEEP(400)) TIME_FAC_I = TIME_FAC_I/dble(KEEP(400)) TIME_FAC_MQ = TIME_FAC_MQ/dble(KEEP(400)) TIME_FAC_SQ = TIME_FAC_SQ/dble(KEEP(400)) TIME_FRFRONTS = TIME_FRFRONTS/dble(KEEP(400)) TIME_LRTRSM = TIME_LRTRSM/dble(KEEP(400)) TIME_FRTRSM = TIME_FRTRSM/dble(KEEP(400)) TIME_LR_MODULE = TIME_LR_MODULE/dble(KEEP(400)) TIME_DECOMP = TIME_DECOMP/dble(KEEP(400)) TIME_DIAGCOPY = TIME_DIAGCOPY/dble(KEEP(400)) TIME_DECOMP_UCFS = TIME_DECOMP_UCFS/dble(KEEP(400)) TIME_LRASM_NIV1 = TIME_LRASM_NIV1/dble(KEEP(400)) TIME_LRASM_LOCASM2 = TIME_LRASM_LOCASM2/dble(KEEP(400)) TIME_LRASM_MAPLIG1 = TIME_LRASM_MAPLIG1/dble(KEEP(400)) TIME_LRASM_CONTRIB2 = TIME_LRASM_CONTRIB2/dble(KEEP(400)) TIME_FRASM_LOCASM2 = TIME_FRASM_LOCASM2/dble(KEEP(400)) TIME_FRASM_MAPLIG1 = TIME_FRASM_MAPLIG1/dble(KEEP(400)) TIME_FRASM_CONTRIB2 = TIME_FRASM_CONTRIB2/dble(KEEP(400)) ENDIF DKEEP(97) = DKEEP(97) / real(KEEP(400)) CALL MUMPS_LOAD_ENABLE() CALL MUMPS_LOAD_UPDATE(0,.FALSE., FLOP_ESTIM_ACC,KEEP,KEEP8) RETURN END SUBROUTINE CMUMPS_FAC_L0_OMP SUBROUTINE CMUMPS_SET_MAXS_MAXIS_THREAD(MAXS_BASE_RELAXED8TH, & MAXIS_BASE_RELAXEDTH, BLR_STRAT, & KEEP, & I4_L0_OMPTH, NBSTATS_I4, & I8_L0_OMPTH, NBSTATS_I8) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP(500), NBSTATS_I4, NBSTATS_I8 INTEGER, INTENT(IN) :: I4_L0_OMPTH(NBSTATS_I4) INTEGER(8), INTENT(IN) :: I8_L0_OMPTH(NBSTATS_I8) INTEGER(8), INTENT(OUT) :: MAXS_BASE_RELAXED8TH INTEGER, INTENT(OUT) :: MAXIS_BASE_RELAXEDTH INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER :: PERLU INTEGER(8) :: MAXS_BASE8TH INTEGER(8) :: MAXIS_BASE_RELAXEDTH8 PERLU = KEEP(12) CALL CMUMPS_SET_BLRSTRAT_AND_MAXS ( MAXS_BASE8TH, & MAXS_BASE_RELAXED8TH, BLR_STRAT, KEEP(1), & I8_L0_OMPTH(2), I8_L0_OMPTH(3), I8_L0_OMPTH(5), & I8_L0_OMPTH(6), I8_L0_OMPTH(7), I8_L0_OMPTH(8) ) IF ( KEEP(201) .EQ. 0 ) THEN MAXIS_BASE_RELAXEDTH8 = int(I4_L0_OMPTH(2),8) ELSE MAXIS_BASE_RELAXEDTH8 = int(I4_L0_OMPTH(4),8) ENDIF MAXIS_BASE_RELAXEDTH8 = max( 1_8, & MAXIS_BASE_RELAXEDTH8 + 3 * max(PERLU,10) * & ( MAXIS_BASE_RELAXEDTH8 / 100 + 1 ) & ) MAXIS_BASE_RELAXEDTH8 = min(MAXIS_BASE_RELAXEDTH8, & int( huge( MAXIS_BASE_RELAXEDTH ) ,8) & ) MAXIS_BASE_RELAXEDTH = int( MAXIS_BASE_RELAXEDTH8 ) RETURN END SUBROUTINE CMUMPS_SET_MAXS_MAXIS_THREAD SUBROUTINE CMUMPS_MA_EFF_MEM_DISPO( & MUMPS_TPS_ARR, NBTHREADS, KEEP8, KEEP, & N, BLR_STRAT, LPOOL_P, & I8_L0_OMP, NBSTATS_I8, & MEMDISPO_UNDERL0) USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T IMPLICIT NONE INTEGER, INTENT(IN) :: N, BLR_STRAT, KEEP(500) INTEGER, INTENT(IN) :: NBSTATS_I8, NBTHREADS, LPOOL_P INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER(8), INTENT(IN) :: I8_L0_OMP(NBSTATS_I8,NBTHREADS) INTEGER(8), INTENT(OUT) :: MEMDISPO_UNDERL0 TYPE (MUMPS_TPS_T), INTENT(IN) :: MUMPS_TPS_ARR(:) INTEGER :: PERLU, ITH, ITHMIN, ITHMIN_if_LRLU, OOC_STRAT INTEGER(8) :: TO_ALLOCATE, BLR_RELATED, COPY_RELATED INTEGER(8) :: MIN_NRLADU_underL0, MIN_NRLADU_if_LR_LU_underL0 PERLU = KEEP(12) OOC_STRAT = KEEP(201) TO_ALLOCATE = 0_8 DO ITH = 1, NBTHREADS TO_ALLOCATE = TO_ALLOCATE + & ((int(MUMPS_TPS_ARR(ITH)%LIW,8) * int(KEEP(34),8 )) / & int(KEEP(35),8 )) & + MUMPS_TPS_ARR(ITH)%LA ENDDO TO_ALLOCATE = TO_ALLOCATE + int(NBTHREADS,8)* ( & ((int(LPOOL_P,8) * int(KEEP(34),8 )) / int(KEEP(35),8 )) + & ((int(N+KEEP(253),8) * int(KEEP(34),8 )) / int(KEEP(35),8 )) & ) BLR_RELATED = 0_8 DO ITH = 1, NBTHREADS IF (BLR_STRAT.EQ.1) THEN BLR_RELATED = BLR_RELATED + & I8_L0_OMP(10,ITH) + & int(PERLU,8) * ( I8_L0_OMP(10,ITH) / 100_8 + 1_8) ELSE IF (BLR_STRAT.EQ.2) THEN BLR_RELATED = BLR_RELATED + & I8_L0_OMP(13,ITH) + & int(PERLU,8) * ( I8_L0_OMP(13,ITH) / 100_8 + 1_8) ELSE IF (BLR_STRAT.EQ.3) THEN BLR_RELATED = BLR_RELATED + & I8_L0_OMP(8,ITH) + & int(PERLU,8) * ( I8_L0_OMP(8,ITH) / 100_8 + 1_8) ENDIF ENDDO COPY_RELATED = 0_8 ITHMIN = 1 ITHMIN_if_LRLU = 1 MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,1) MIN_NRLADU_underL0 = I8_L0_OMP(1,1) DO ITH = 1, NBTHREADS IF (I8_L0_OMP(1,ITH).LT.MIN_NRLADU_underL0) & THEN MIN_NRLADU_underL0 = I8_L0_OMP(1,ITH) ITHMIN = ITH ENDIF IF (I8_L0_OMP(4,ITH).LT.MIN_NRLADU_if_LR_LU_underL0) & THEN MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,ITH) ITHMIN_if_LRLU = ITH ENDIF ENDDO IF (BLR_STRAT.EQ.0) THEN IF (OOC_STRAT .LE. 0 .AND. OOC_STRAT .NE. -1 ) THEN COPY_RELATED = COPY_RELATED + & I8_L0_OMP(1,ITHMIN) + & I8_L0_OMP(23, ITHMIN) ELSE COPY_RELATED = COPY_RELATED + & I8_L0_OMP(23, ITHMIN) ENDIF ELSE IF (OOC_STRAT .LE. 0 .AND. OOC_STRAT .NE. -1 ) THEN COPY_RELATED = COPY_RELATED + & I8_L0_OMP(4,ITHMIN_if_LRLU) + & I8_L0_OMP(23,ITHMIN_if_LRLU ) ELSE COPY_RELATED = COPY_RELATED + & I8_L0_OMP(23, ITHMIN_if_LRLU) ENDIF ENDIF COPY_RELATED = COPY_RELATED + & int(PERLU,8)*(COPY_RELATED / 100_8 + 1_8 ) TO_ALLOCATE = TO_ALLOCATE + COPY_RELATED + BLR_RELATED MEMDISPO_UNDERL0 = KEEP8(75) - TO_ALLOCATE RETURN END SUBROUTINE CMUMPS_MA_EFF_MEM_DISPO SUBROUTINE CMUMPS_L0OMP_COPY_IW( IW, LIW, IWPOS, & MUMPS_TPS_ARR, KEEP, & PTLUST, ICNTL, INFO ) USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T IMPLICIT NONE INTEGER :: KEEP(500) INTEGER, INTENT( IN ) :: LIW INTEGER, INTENT( INOUT ) :: IW(:) INTEGER, INTENT( INOUT ) :: IWPOS INTEGER, INTENT( INOUT ) :: PTLUST(KEEP(28)) INTEGER, INTENT( IN ) :: ICNTL(60) INTEGER, INTENT( INOUT ) :: INFO(80) TYPE (MUMPS_TPS_T), TARGET :: MUMPS_TPS_ARR(:) INTEGER :: ITHREAD, JTHREAD INTEGER :: REQUESTED_SIZE INTEGER :: IWPOS_TO_COPY INTEGER :: LOC_IPOS INTEGER :: LOC_SIZE, LOC_ISTEP TYPE (MUMPS_TPS_T), POINTER :: MUMPS_TPS INCLUDE 'mumps_headers.h' REQUESTED_SIZE = 0 DO ITHREAD = 1, size(MUMPS_TPS_ARR) MUMPS_TPS => MUMPS_TPS_ARR(ITHREAD) REQUESTED_SIZE = REQUESTED_SIZE + MUMPS_TPS%IWPOS - 1 ENDDO IF ( LIW - IWPOS + 1 .LT. REQUESTED_SIZE ) THEN WRITE(*,*) " LIW too small in CMUMPS_L0OMP_COPY_IW !!", LIW, & REQUESTED_SIZE INFO(1) = -8 INFO(2) = REQUESTED_SIZE-LIW+IWPOS-1 IF ( ICNTL(1) .GT. 0 .AND. ICNTL(4).GE.1) THEN WRITE(ICNTL(1),*) " ** ERROR IN CMUMPS_L0OMP_COPY_IW: ", & "LIW TOO SMALL TO COPY LOCAL FACTOR INFORMATION", & INFO(2) ENDIF GOTO 500 ENDIF DO ITHREAD = 1, size(MUMPS_TPS_ARR) MUMPS_TPS => MUMPS_TPS_ARR(ITHREAD) IWPOS_TO_COPY = IWPOS DO JTHREAD=1, ITHREAD - 1 IWPOS_TO_COPY = IWPOS_TO_COPY+MUMPS_TPS_ARR(JTHREAD)%IWPOS-1 ENDDO IW(IWPOS_TO_COPY: IWPOS_TO_COPY+MUMPS_TPS%IWPOS - 2) = & MUMPS_TPS%IW(1:MUMPS_TPS%IWPOS-1) LOC_IPOS = 1 DO WHILE ( LOC_IPOS .NE. MUMPS_TPS%IWPOS ) LOC_SIZE = MUMPS_TPS%IW(LOC_IPOS+XXI) LOC_ISTEP = MUMPS_TPS%IW(LOC_IPOS+KEEP(IXSZ)+4) PTLUST(LOC_ISTEP) = IWPOS_TO_COPY+LOC_IPOS-1 LOC_IPOS = LOC_IPOS + LOC_SIZE ENDDO ENDDO IWPOS = IWPOS + REQUESTED_SIZE 500 CONTINUE RETURN END SUBROUTINE CMUMPS_L0OMP_COPY_IW SUBROUTINE CMUMPS_PERFORM_COPIES_INIT( STATE, KEEP8_77_SAVE, & NbWaitMem, NbFinished, NbOnGoingCopies, NbUnderL0, & KEEP, KEEP8 ) INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(OUT) :: NbWaitMem, & NbFinished, & NbOnGoingCopies, & NbUnderL0 INTEGER(8), INTENT(OUT) :: STATE(KEEP(400)), KEEP8_77_SAVE INTEGER :: ITH NbWaitMem = 0 NbFinished = 0 NbOnGoingCopies = 0 NbUnderL0 = KEEP(400) DO ITH=1, KEEP(400) STATE(ITH) = UnderL0 ENDDO KEEP8_77_SAVE = KEEP8(77) RETURN END SUBROUTINE CMUMPS_PERFORM_COPIES_INIT SUBROUTINE CMUMPS_PERFORM_COPIES( THREAD_ID_P, & MUMPS_TPS_ARR, CMUMPS_TPS_ARR, & L0_OMP_FACTORS, LL0_OMP_FACTORS, & STATE, SIZE_COPIED, & NbWaitMem, NbFinished, NbOngoingCopies, NbUnderL0, & MYID_NODES, N, SLAVEF, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & KEEP, KEEP8, INFO_P & ) USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T USE CMUMPS_TPS_M, ONLY : CMUMPS_TPS_T USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_L0OMPFAC_T USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_FREE_S_WK INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: THREAD_ID_P INTEGER, INTENT(INOUT) :: INFO_P(2) INTEGER, INTENT(IN) :: MYID_NODES, N, SLAVEF INTEGER, INTENT(IN) :: STEP(N), DAD(KEEP(28)) INTEGER(8), INTENT(IN) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT(INOUT) :: NbWaitMem, & NbFinished, & NbOnGoingCopies, & NbUnderL0 INTEGER(8), INTENT(INOUT) :: STATE( KEEP(400) ) INTEGER(8), INTENT(INOUT) :: SIZE_COPIED(KEEP(400) ) TYPE (MUMPS_TPS_T), DIMENSION(:) :: MUMPS_TPS_ARR TYPE (CMUMPS_TPS_T), DIMENSION(:) :: CMUMPS_TPS_ARR INTEGER, INTENT ( IN ) :: LL0_OMP_FACTORS TYPE (CMUMPS_L0OMPFAC_T), INTENT(INOUT) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER :: NbFinishedPrivateCopy INTEGER :: LOCAL_ACTION INTEGER, PARAMETER :: NOTHING = 0 INTEGER, PARAMETER :: FREE_WORK_MYID = 1 INTEGER, PARAMETER :: COPY_FACTORS = 2 INTEGER, PARAMETER :: AllocateViderCB = 3 INTEGER, PARAMETER :: DORMIR = 4 INTEGER(8) :: COPY_START, CHUNK8, I8, TO_ALLOCATE INTEGER :: ITH, K INTEGER :: allocok INTEGER(8) :: PeakAuthorized_P INTEGER(8) :: MemNeeded_P, MemNeededForCB_P, MemDispo_P, & CBCopiedToDynamic_P, LRLUS_SAVE_P INTEGER(8) :: KEEP8_71, KEEP8_73 !$OMP CRITICAL(L0_COPIES) STATE(THREAD_ID_P) = CopyNotStarted IF ( INFO_P(1) .LT. 0 ) THEN NbFinished = NbFinished + 1 STATE(THREAD_ID_P) = Finished ENDIF DO ITH = 1, KEEP(400) IF ( STATE(ITH) .EQ. WaitMem ) THEN STATE(ITH)=CopyNotStarted ENDIF ENDDO NbWaitMem = 0 NbFinishedPrivateCopy = NbFinished !$OMP END CRITICAL(L0_COPIES) DO WHILE ( NbFinishedPrivateCopy .NE. KEEP(400) ) LOCAL_ACTION = DORMIR !$OMP CRITICAL(L0_COPIES) NbFinishedPrivateCopy = NbFinished IF ( NbFinished.EQ. KEEP(400)) THEN LOCAL_ACTION = NOTHING ELSE IF ( (NbFinished+NbWaitMem) .EQ. KEEP(400) ) THEN !$OMP ATOMIC READ KEEP8_73 = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC READ KEEP8_71 = KEEP8(71) !$OMP END ATOMIC MemDispo_P = KEEP8(77) - (KEEP8_73 -KEEP8_71) MemDispo_P = min(MemDispo_P, KEEP8(75)-KEEP8_73) MemNeeded_P = huge(MemNeeded_P) DO ITH = 1, KEEP(400) IF (STATE(ITH).EQ.WaitMem) THEN MemNeeded_P = min( MemNeeded_P, & MUMPS_TPS_ARR(ITH)%LA - & MUMPS_TPS_ARR(ITH)%LRLUS ) ENDIF ENDDO IF ((KEEP8(75)-KEEP8_73).LT.MemNeeded_P) THEN INFO_P(1) = -19 CALL MUMPS_SET_IERROR ( & MemNeeded_P-(KEEP8(75)-KEEP8_73), INFO_P(2)) DO ITH = 1, KEEP(400) STATE(ITH) = Finished ENDDO NbFinished = KEEP(400) ELSE KEEP8(77) = MemNeeded_P + (KEEP8_73 -KEEP8_71) DO ITH = 1, KEEP(400) IF ( STATE(ITH) .EQ. WaitMem ) THEN STATE(ITH)=CopyNotStarted ENDIF ENDDO NbWaitMem = 0 ENDIF LOCAL_ACTION = NOTHING ELSE SELECT CASE (STATE(THREAD_ID_P)) CASE ( CopyFactorsFinished ) LOCAL_ACTION = FREE_WORK_MYID CASE ( CopyNotStarted ) !$OMP ATOMIC READ KEEP8_73 = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC READ KEEP8_71 = KEEP8(71) !$OMP END ATOMIC PeakAuthorized_P = KEEP8(77) MemDispo_P = PeakAuthorized_P - (KEEP8_73 -KEEP8_71) MemDispo_P = min(MemDispo_P, KEEP8(75)-KEEP8_73) MemNeeded_P = MUMPS_TPS_ARR(THREAD_ID_P)%LA - & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS MemNeededForCB_P = MemNeeded_P - & ( MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC - 1_8 ) IF ( MemDispo_P .GE. MemNeeded_P ) THEN !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + MemNeeded_P KEEP8_73 = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC READ KEEP8_71 = KEEP8(71) !$OMP END ATOMIC MemDispo_P = PeakAuthorized_P - (KEEP8_73 -KEEP8_71) MemDispo_P = min(MemDispo_P, KEEP8(75)-KEEP8_73) IF ( MemDispo_P .LT. 0 ) THEN !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - MemNeeded_P !$OMP END ATOMIC IF ( STATE(THREAD_ID_P) .NE. WaitMem ) THEN STATE( THREAD_ID_P ) = WaitMem NbWaitMem = NbWaitMem + 1 ENDIF ELSE !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP8_73 ) !$OMP END ATOMIC IF ( STATE( THREAD_ID_P ) .EQ. WaitMem ) THEN NbWaitMem = NbWaitMem - 1 ENDIF STATE( THREAD_ID_P ) = AllocateViderCBEnCours LOCAL_ACTION = AllocateViderCB NbOngoingCopies = NbOnGoingCopies + 1 ENDIF ELSE IF ( STATE(THREAD_ID_P) .NE. WaitMem ) THEN STATE( THREAD_ID_P ) = WaitMem NbWaitMem = NbWaitMem + 1 ENDIF ENDIF CASE DEFAULT ITH = -1 DO K = THREAD_ID_P, THREAD_ID_P + KEEP(400) - 1 IF ( K > KEEP(400) ) THEN ITH = K - KEEP(400) ELSE ITH = K ENDIF IF ( STATE(ITH) .GE. 0 .AND. & STATE(ITH) .LT. MUMPS_TPS_ARR(ITH)%POSFAC - 1_8 ) THEN EXIT ELSE ITH = -1 ENDIF ENDDO IF ( ITH .GT. 0 ) THEN LOCAL_ACTION = COPY_FACTORS COPY_START = STATE(ITH) + 1 CHUNK8 = max( & & int(KEEP(361),8), & & (MUMPS_TPS_ARR(ITH)%POSFAC+KEEP(400)-2_8) / & (int(KEEP(400)*2,8)) & & ) IF (KEEP(72) .EQ. 1) THEN CHUNK8 = 4_8 ENDIF CHUNK8 = min( CHUNK8, & MUMPS_TPS_ARR(ITH)%POSFAC - 1_8 - COPY_START + 1_8 & ) STATE(ITH) = STATE(ITH) + CHUNK8 ENDIF END SELECT ENDIF !$OMP END CRITICAL(L0_COPIES) SELECT CASE ( LOCAL_ACTION ) CASE ( FREE_WORK_MYID ) IF ( associated(CMUMPS_TPS_ARR(THREAD_ID_P)%A) ) THEN CALL CMUMPS_DM_FREE_S_WK( & CMUMPS_TPS_ARR(THREAD_ID_P)%A, & KEEP(430) ) NULLIFY(CMUMPS_TPS_ARR(THREAD_ID_P)%A) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -MUMPS_TPS_ARR(THREAD_ID_P)%LA, & KEEP(405).EQ.1, & KEEP8, & INFO_P(1), INFO_P(2), & .FALSE., .FALSE. ) IF (INFO_P(1) .GE. 0) THEN !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - L0_OMP_FACTORS(THREAD_ID_P)%LA !$OMP END ATOMIC !$OMP CRITICAL(L0_COPIES) DO ITH = 1, KEEP(400) IF ( STATE(ITH) .EQ. WaitMem ) THEN STATE(ITH)=CopyNotStarted ENDIF ENDDO NbWaitMem = 0 NbFinished = NbFinished + 1 STATE( THREAD_ID_P ) = Finished NbOnGoingCopies = NbOnGoingCopies -1 !$OMP END CRITICAL(L0_COPIES) ENDIF ENDIF CASE ( AllocateViderCB ) TO_ALLOCATE = max(MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8,1_8) ALLOCATE( L0_OMP_FACTORS(THREAD_ID_P)%A(TO_ALLOCATE), & stat=allocok ) IF ( allocok .GT. 0 ) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4(TO_ALLOCATE, INFO_P(2)) L0_OMP_FACTORS(THREAD_ID_P)%LA = 0_8 !$OMP CRITICAL(L0_COPIES) !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - MemNeeded_P !$OMP END ATOMIC STATE(THREAD_ID_P) = Finished NbFinished = NbFinished + 1 !$OMP END CRITICAL(L0_COPIES) ELSE L0_OMP_FACTORS(THREAD_ID_P)%LA = & MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8 !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) + L0_OMP_FACTORS(THREAD_ID_P)%LA !$OMP END ATOMIC !$OMP CRITICAL(L0_COPIES) IF ( MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8 == 0_8 ) THEN STATE(THREAD_ID_P) = CopyFactorsFinished ELSE STATE ( THREAD_ID_P ) = 0 SIZE_COPIED( THREAD_ID_P ) = 0 ENDIF !$OMP END CRITICAL(L0_COPIES) LRLUS_SAVE_P = MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS CALL CMUMPS_DM_CBSTATIC2DYNAMIC_I & (3, & 0_8, & .FALSE., & MYID_NODES, N, SLAVEF, KEEP, KEEP8, & MUMPS_TPS_ARR(THREAD_ID_P)%IW(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LIW, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOSCB, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOS, & CMUMPS_TPS_ARR(THREAD_ID_P)%A(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LA, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%IPTRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & INFO_P(1), INFO_P(2) ) CBCopiedToDynamic_P = & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS - LRLUS_SAVE_P IF (INFO_P(1) .LT. 0 ) THEN !$OMP CRITICAL(L0_COPIES) !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - & ( MemNeededForCB_P - CBCopiedToDynamic_P ) !$OMP END ATOMIC STATE(THREAD_ID_P) = Finished NbFinished = NbFinished+1 !$OMP END CRITICAL(L0_COPIES) ELSE ENDIF ENDIF CASE ( COPY_FACTORS ) DO I8 = COPY_START, COPY_START + CHUNK8 - 1 L0_OMP_FACTORS(ITH)%A(I8) = CMUMPS_TPS_ARR(ITH)%A(I8) ENDDO !$OMP CRITICAL(L0_COPIES) SIZE_COPIED(ITH) = SIZE_COPIED(ITH) + CHUNK8 IF ( SIZE_COPIED(ITH) .EQ. L0_OMP_FACTORS(ITH)%LA ) THEN STATE(ITH) = CopyFactorsFinished ENDIF !$OMP END CRITICAL(L0_COPIES) CASE ( NOTHING ) CASE ( DORMIR ) CALL MUMPS_USLEEP(1000) CASE DEFAULT WRITE(*,*) " Internal error in CMUMPS_PERFORM_COPIES", & LOCAL_ACTION END SELECT ENDDO RETURN END SUBROUTINE CMUMPS_PERFORM_COPIES END MODULE CMUMPS_FAC_OMP_M RECURSIVE SUBROUTINE CMUMPS_PROCESS_FRONT_NIV1( COMM_LOAD, & ASS_IRECV, N, INODE, TYPE, TYPEF, LA, IW, LIW, A, & MAXFRW, NOFFNEGW, NULLNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INFO_P, UU, SEUIL, SEUIL_LDLT_NIV2, & OPELIW, NELVAW, NMAXNPIVW, NSTEPSW, PTRIST, PTLUST_S, & PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, NE, POSFAC, & LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP, KEEP8, DKEEP, & PIVNUL_LIST_STRUCT, COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, & SLAVEF, IFATH, COMM_NODES, MYID_NODES, IPOOL_P, & LPOOL_P, LEAF, PERM, NSTK_STEPS, BUFR, LBUFR, & LBUFR_BYTES, NBFIN, root, roota, OPASSW, ITLOC, RHS_MUMPS, FILS, & PTRARW, PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, DAD, LPTRAR, NELT, & FRTPTR, FRTELT, ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS, & FLOP_ESTIM_ACC ) USE CMUMPS_FAC_ASM_MASTER_M USE CMUMPS_FAC_ASM_MASTER_ELT_M USE CMUMPS_FAC1_LU_M USE CMUMPS_FAC1_LDLT_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER COMM_NODES, MYID_NODES, TYPE, TYPEF INTEGER N, LIW, INODE,INFO_P(2) INTEGER ICNTL(60), KEEP(500) REAL DKEEP(230) REAL UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER(8) KEEP8(150) INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU INTEGER IWPOSCB, IWPOS, & IFATH, SLAVEF, NELVAW, NMAXNPIVW, NSTEPSW INTEGER IW(LIW),PROCNODE_STEPS(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NE(KEEP(28)) COMPLEX A(LA) INTEGER :: MAXFRW, NOFFNEGW, NULLNEGW, NPVW, NBTINYW INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW COMPLEX DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER LEAF, COMP INTEGER :: NB22T1W, DET_EXPW, DET_SIGNW COMPLEX :: DET_MANTW INTEGER PERM( N ) INTEGER NSTK_STEPS( KEEP(28) ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER NBFIN TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION FLOP_ESTIM_ACC INTEGER, INTENT(IN) :: LPOOL_P INTEGER, INTENT(IN) :: IPOOL_P(LPOOL_P) INTEGER :: IOLDPS, JOBASS, ETATASS INTEGER(8) :: POSELT LOGICAL :: AVOID_DELAYED, SON_LEVEL2 JOBASS = 0 ETATASS = 0 IF ( KEEP(55) .EQ. 0 ) THEN JOBASS = 0 CALL CMUMPS_FAC_ASM_NIV1( COMM_LOAD, ASS_IRECV, UU, & N, INODE, & IW, LIW, A, LA, INFO_P, ND, FILS, FRERE, DAD, MAXFRW, & root, roota, OPASSW, OPELIW, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & PTRARW, PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSW, & SON_LEVEL2,COMP, LRLU, IPTRLU, & IWPOS, IWPOSCB, POSFAC, & LRLUS, LRLUSM, ICNTL, KEEP, KEEP8, DKEEP, & INTARR, KEEP8(27), DBLARR, KEEP8(26), & NSTK_STEPS, PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL_P, & LPOOL_P, LEAF, PERM, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & JOBASS, ETATASS & , LRGROUPS & ) ELSE CALL CMUMPS_FAC_ASM_NIV1_ELT(COMM_LOAD,ASS_IRECV,UU, & NELT,FRTPTR, & FRTELT, N, INODE, IW, LIW, A, & LA, INFO_P, ND, FILS, FRERE, DAD, MAXFRW, & root, roota, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSW, SON_LEVEL2, COMP, LRLU, & IPTRLU, IWPOS, IWPOSCB, & POSFAC, LRLUS, LRLUSM, ICNTL, KEEP, KEEP8, DKEEP, & INTARR, KEEP8(27), DBLARR, KEEP8(26), & NSTK_STEPS, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, NBFIN, & IPOOL_P, LPOOL_P, LEAF, PERM, ISTEP_TO_INIV2, & TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF IF (INFO_P(1) .LT. 0) THEN RETURN ENDIF AVOID_DELAYED = ( ( IFATH .EQ. KEEP(20) & .OR. & IFATH .EQ. KEEP(38) ) & .AND. & ( KEEP(60) .NE. 0 ) ) POSELT = PTRAST(STEP(INODE)) IOLDPS = PTLUST_S(STEP(INODE)) IF ( KEEP(50) .EQ. 0 ) THEN CALL CMUMPS_FAC1_LU( N, INODE, & IW, LIW, & A, LA, IOLDPS, & POSELT, & INFO_P(1), INFO_P(2), UU, NOFFNEGW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) ELSE IW( IOLDPS + 4 + KEEP(IXSZ) ) = 1 CALL CMUMPS_FAC1_LDLT( N, INODE, & IW, LIW, A, & LA, & IOLDPS, POSELT, & INFO_P(1), INFO_P(2), UU, NOFFNEGW, NULLNEGW, NPVW, & NB22T1W, NBTINYW, DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, MYID_NODES, SEUIL, & AVOID_DELAYED, & ETATASS, & DKEEP(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IW(IOLDPS + 4 + KEEP(IXSZ)) = STEP(INODE) ENDIF IF (INFO_P(1) .LT. 0) THEN RETURN ENDIF CALL CMUMPS_FAC_STACK( COMM_LOAD, ASS_IRECV, N, INODE, TYPE, &TYPEF, LA, IW, LIW, A, &INFO_P(1), INFO_P(2), OPELIW, NELVAW, NMAXNPIVW, PTRIST, PTLUST_S, &PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, NE, POSFAC, &LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP, &KEEP8, DKEEP, &COMP,IWPOS, IWPOSCB, PROCNODE_STEPS, &SLAVEF, IFATH, COMM_NODES, MYID_NODES, IPOOL_P, &LPOOL_P, LEAF, NSTK_STEPS, PERM, BUFR, LBUFR, &LBUFR_BYTES, NBFIN, root, roota, OPASSW, ITLOC, RHS_MUMPS, &FILS, DAD, PTRARW, PTRAIW, &PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, &INTARR, DBLARR, ND, FRERE, &LPTRAR, NELT, FRTPTR, FRTELT, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS, & FLOP_ESTIM_ACC &) RETURN END SUBROUTINE CMUMPS_PROCESS_FRONT_NIV1 MUMPS_5.8.1/src/sfac_asm_master_ELT_m.F0000664000175000017500000021443315042446437017523 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_ASM_MASTER_ELT_M CONTAINS SUBROUTINE SMUMPS_FAC_ASM_NIV1_ELT( COMM_LOAD, ASS_IRECV, & UU, NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, INFO, ND, & FILS, FRERE, DAD, MAXFRW, root, roota, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, LRLUSM, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & , MUMPS_TPS_ARR, SMUMPS_TPS_ARR, L0_OMP_MAPPING & ) !$ USE OMP_LIB USE MUMPS_TPS_M USE SMUMPS_TPS_M USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_PTR, & SMUMPS_DM_FREE_BLOCK USE MUMPS_BUILD_SORT_INDEX_ELT_M USE MUMPS_BUF_COMMON, ONLY: MUMPS_BUF_SEND_MAPLIG USE MUMPS_LOAD USE SMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE, & SMUMPS_BLR_ASM_NIV1 USE SMUMPS_LR_DATA_M, ONLY : SMUMPS_BLR_INIT_FRONT, & SMUMPS_BLR_SAVE_NFS4FATHER USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N, NSTEPS INTEGER NELT INTEGER(8) LA, LRLU, LRLUS, LRLUSM, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) REAL UU INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS, LIW TYPE (MUMPS_TPS_T), TARGET, OPTIONAL :: MUMPS_TPS_ARR(:) TYPE (SMUMPS_TPS_T), TARGET, OPTIONAL :: SMUMPS_TPS_ARR(:) INTEGER, INTENT(IN), OPTIONAL :: L0_OMP_MAPPING(:) INTEGER IDUMMY(1) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER, TARGET :: IW(LIW) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ITLOC(N+KEEP(253)), & ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)), & PAMASTER(KEEP(28)) INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER ETATASS LOGICAL SON_LEVEL2 REAL, TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR REAL DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) LOGICAL PACKED_CB, IS_CB_LR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF LOGICAL LPOK INTEGER NBPANELS_L, NBPANELS_U INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER PARPIV_T1 INTEGER(8) NFRONT8, LAELL8, KEEP8TMPCOPY INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER LREQ_OOC INTEGER :: SON_XXS, SON_XXLR, SON_XXG INTEGER(8) LSTK8, SIZFR8 LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM, IORG, IBROT INTEGER :: J253 #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER(8) APOS, APOS2, LAPOS2 INTEGER(8) POSELT, POSEL1, ICT12, ICT21 INTEGER(8) IACHK INTEGER(8) JJ2 INTEGER(8) :: JJ8, J18, J28 INTEGER(8) :: AINPUT8, AII8 INTEGER :: K1, K2, K3, KK, KK1 INTEGER JPOS,ICT11, IJROW INTEGER Pos_First_NUMORG,NUMORG,IOLDPS, & NUMELT, ELBEG INTEGER :: J INTEGER NSLAVES, NSLSON, NPIVS, NPIV_ANA, NPIV INTEGER PTRCOL, ISLAVE, PDEST,LEVEL LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER ELTI INTEGER(8) :: SIZE_ELTI8 INTEGER(8) :: II8 INTEGER :: I LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: ITHREAD INTEGER, POINTER :: SON_IWPOS, SON_LIW INTEGER, POINTER, DIMENSION(:) :: SON_IW REAL, POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTEGER PIVOT_OPTION REAL ZERO PARAMETER( ZERO = 0.0E0 ) LOGICAL MUMPS_INSSARBR, SSARBR EXTERNAL MUMPS_INSSARBR DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR !$ NOMP = OMP_GET_MAX_THREADS() LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) NFS4FATHER = -1 ETATASS = 0 PACKED_CB = .FALSE. IS_CB_LR = .FALSE. IN = INODE LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (LEVEL.NE.1) THEN WRITE(*,*) 'INTERNAL ERROR 1 in SMUMPS_FAC_ASM_NIV1_ELT ' CALL MUMPS_ABORT() END IF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) NUMELT = FRT_PTR(INODE+1) - FRT_PTR(INODE) IF ( NUMELT .ne. 0 ) THEN ELBEG = FRT_PTR(INODE) ELSE ELBEG = 1 END IF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) END DO NPIV_ANA=NUMORG NSTEPS = NSTEPS + 1 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 SON_IW => IW IF (KEEP(400).GT.0) THEN IF (present(L0_OMP_MAPPING)) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .NE.0) THEN SON_IW=>MUMPS_TPS_ARR(ITHREAD)%IW ENDIF ENDIF ENDIF NASS = NASS + SON_IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG CALL IS_FRONT_BLR_CANDIDATE(INODE, 1, ND(STEP(INODE)), & NUMORG, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, KEEP(280), LRGROUPS) IF (DAD(STEP(INODE)).NE.0) THEN IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199) ) & .NE. MYID & .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199)) & .EQ.1 & ) THEN IF (LRSTATUS.EQ.1 .OR. LRSTATUS.EQ.3) THEN LRSTATUS = LRSTATUS-1 ENDIF ENDIF ENDIF COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_OOC_GET_PP_SIZES(KEEP(50), NFRONT, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL SMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, SLAVEF, & PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress SMUMPS_FAC_ASM_NIV1_ELT' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 END IF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 END IF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .TRUE. IF (.NOT. present(MUMPS_TPS_ARR).AND. & .NOT. present(L0_OMP_MAPPING) ) THEN CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & IDUMMY, LIDUMMY ) ELSE CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & IDUMMY, LIDUMMY & , MUMPS_TPS_ARR, L0_OMP_MAPPING ) ENDIF IF (INFO(1).LT.0) GOTO 300 IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL MUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1-FLOP1_EFF, & KEEP,KEEP8) ENDIF IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) & ' ERROR 1 during ass_niv1_ELT', NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF NCB = NFRONT - NASS1 MAXFRW = max(MAXFRW, NFRONT) ICT11 = IOLDPS + HF - 1 + NFRONT CALL SMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) PIVOT_OPTION = KEEP(468) IF (UU.EQ.ZERO) THEN PIVOT_OPTION=0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF(PARPIV_T1.NE.0) THEN LAELL8 = LAELL8+int(NASS1,8) ENDIF CALL SMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 LRLUSM = min( LRLUS, LRLUSM ) IF (KEEP(405).EQ.0) THEN KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + LAELL8 KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ENDIF POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8, & KEEP,KEEP8, & LRLUS) IF (KEEP(405).EQ.0) KEEP(429)= KEEP(429)+1 #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8=int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (LAPOS2 - POSELT + 1_8 > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8), KEEP(218))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & NCB, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1,TOPDIAG) ENDIF NUMROWS = NFRONT8 !$ CHUNK = max(KEEP(360)/2, !$ & ( ((int(NUMROWS)+NOMP-1) / NOMP + 2) / 3) ) #if defined(__ve__) !NEC$ IVDEP #endif !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK ) !$OMP& IF (int(NUMROWS - 1) .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = POSELT + JJ8 * NFRONT8 JJ3 = min( NFRONT8 - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS + JJ3) = ZERO ENDDO !$OMP END PARALLEL DO END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS IW(IOLDPS + KEEP(IXSZ)) = NFRONT IW(IOLDPS + KEEP(IXSZ)+ 1) = 0 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN CALL SMUMPS_BLR_INIT_FRONT (IW(IOLDPS+XXF), INFO, & MTK405=KEEP(405)) IF (INFO(1).LT.0) GOTO 500 ENDIF ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL SMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) CALL SMUMPS_BLR_SAVE_NFS4FATHER ( IW(IOLDPS+XXF), & ESTIM_NFS4FATHER_ATSON ) ENDIF ENDIF ENDIF IF (NUMSTK.NE.0) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_LIW => LIW SON_IWPOS => IWPOS SON_A => A ITHREAD = 0 IF (KEEP(400).GT.0) THEN IF (present(L0_OMP_MAPPING)) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .NE.0) THEN SON_LIW => MUMPS_TPS_ARR(ITHREAD)%LIW SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW SON_IWPOS => MUMPS_TPS_ARR(ITHREAD)%IWPOS SON_A => SMUMPS_TPS_ARR(ITHREAD)%A ENDIF ENDIF ENDIF LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + KEEP(IXSZ) + 1) NPIVS = SON_IW(ISTCHK + KEEP(IXSZ) + 3) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = SON_IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.SON_IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT = PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT = ISTCHK ENDIF SON_XXS = SON_IW(ISTCHK_CB_RIGHT+XXS) SON_XXLR = SON_IW(ISTCHK_CB_RIGHT+XXLR) SON_XXG = SON_IW(ISTCHK_CB_RIGHT+XXG) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IS_CB_LR = ( SON_XXLR.EQ.1 .OR. SON_XXLR.EQ.3 ) & .AND. (KEEP(489).EQ.1.OR.KEEP(489).EQ.3) LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = SON_IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF K1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN K2 = K1 + LSTK - 1 IF (PACKED_CB) THEN SIZFR8 = (LSTK8*(LSTK8+1_8)/2_8) ELSE SIZFR8 = LSTK8*LSTK8 ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * LSTK8 ELSE IF (PACKED_CB) THEN SIZFR8 = int(NELIM,8) * int(NELIM+1,8)/2_8 ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) ENDIF END IF K2 = K1 + NELIM - 1 ENDIF IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + LSTK8*LSTK8 ELSE OPASSW = OPASSW + LSTK8*(LSTK8+1)/2_8 ENDIF ELSE IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + int(NELIM,8)*LSTK8 ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM,8)/2_8 ENDIF ENDIF CALL MUMPS_GETI8(DYN_SIZE, SON_IW(ISTCHK_CB_RIGHT+XXD)) IS_DYNAMIC_CB = DYN_SIZE .GT. 0_8 IF ( IS_DYNAMIC_CB ) THEN CALL SMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) ENDIF IF (IS_CB_LR .AND. LEVEL1) THEN POSEL1 = PTRAST(STEP(INODE)) CALL SMUMPS_BLR_ASM_NIV1 (A, LA, & POSEL1, NFRONT, NASS1, SON_IW(ISTCHK+XXF), & SON_IW, SON_LIW, & LSTK, NELIM, K1, K1+LSTK-1, KEEP(50), & KEEP, KEEP8, OPASSW) ENDIF IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (K2.GE.K1) THEN #if defined(__ve__) !NEC$ IVDEP #endif DO 170 KK = K1, K2 APOS = POSEL1 + int(SON_IW(KK),8) * NFRONT8 #if defined(__ve__) !NEC$ IVDEP #endif DO 160 KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1 + KK1 - 1) - 1,8) A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + LSTK8 170 CONTINUE END IF ELSE IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (SIZFR8 .GT. 0) THEN CALL SMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF (SAME_PROC) THEN IF (KEEP(50).NE.0) THEN K2 = K1 + LSTK - 1 #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K1, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO ELSE K2 = K1 + LSTK - 1 K3 = K1 + NELIM #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K3, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO IF (NELIM .NE. 0) THEN K3 = K3 - 1 #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K1, K3 JPOS = SON_IW(KK) + ICT11 SON_IW(KK) = IW(JPOS) ENDDO ENDIF ENDIF ENDIF IF ( SAME_PROC ) THEN PTRIST(STEP(ISON)) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF IF (ITHREAD .EQ. 0) THEN CALL SMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & .FALSE. & ) ELSE CALL MUMPS_LOAD_DISABLE() CALL SMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & MUMPS_TPS_ARR(ITHREAD)%IW(1), & MUMPS_TPS_ARR(ITHREAD)%LIW, & MUMPS_TPS_ARR(ITHREAD)%LRLU, & MUMPS_TPS_ARR(ITHREAD)%LRLUS, & MUMPS_TPS_ARR(ITHREAD)%IPTRLU, & MUMPS_TPS_ARR(ITHREAD)%IWPOSCB, & MUMPS_TPS_ARR(ITHREAD)%LA, KEEP,KEEP8, .FALSE. & ) CALL MUMPS_LOAD_ENABLE() ENDIF IF (IS_DYNAMIC_CB) THEN CALL SMUMPS_DM_FREE_BLOCK(SON_XXG, & SON_A, SIZFR8, & KEEP(405).EQ.1, KEEP8 ) ENDIF ELSE PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP, KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL SMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, IDUMMY, & NFRONT, NASS1, NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & IZERO, IDUMMY, IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP, KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE., LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF END DO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) 220 CONTINUE END IF DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = INTARR(II8) IF (KEEP(50).EQ.0) THEN AINPUT8 = AII8 + II8 - J18 ICT12 = POSELT + int(I-1,8) * NFRONT8 DO JJ8=J18,J28 APOS2 = ICT12 + int(INTARR(JJ8) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ELSE ICT12 = POSELT + int(- NFRONT + I - 1,8) ICT21 = POSELT + int(I-1,8)*NFRONT8 - 1_8 DO JJ8=II8,J28 J = INTARR(JJ8) IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*NFRONT8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII8) AII8 = AII8 + 1_8 END DO END IF END DO END DO IF (KEEP(253).GT.0) THEN POSELT = PTRAST(STEP(INODE)) IBROT = INODE IJROW = Pos_First_NUMORG DO IORG = 1, NUMORG IF (KEEP(50).EQ.0) THEN DO J253=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ELSE DO J253=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+J253-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF IF (PARPIV_T1.NE.0.AND.(.NOT.SON_LEVEL2)) THEN IOLDPS = PTLUST(STEP(INODE)) CALL SMUMPS_PARPIVT1_SET_NVSCHUR_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1, NASS) ENDIF GOTO 500 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING SMUMPS_ASM_NIV1_ELT' ENDIF GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING SMUMPS_ASM_NIV1_ELT' ENDIF INFO(1) = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, RECV BUFFER TOO SMALL DURING SMUMPS_ASM_NIV1_ELT' ENDIF INFO(1) = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) ' FAILURE IN INTEGER', & ' DYNAMIC ALLOCATION DURING SMUMPS_ASM_NIV1_ELT' ENDIF INFO(2) = NUMSTK ENDIF 490 CONTINUE IF ( KEEP(405) .EQ. 0 ) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_ASM_NIV1_ELT SUBROUTINE SMUMPS_FAC_ASM_NIV2_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, INFO, & ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, roota, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, MEM_DISTRIB & , LRGROUPS & ) !$ USE OMP_LIB USE MUMPS_BUILD_SORT_INDEX_ELT_M USE MUMPS_BUF_COMMON, ONLY: MUMPS_BUF_SEND_MAPLIG, & MUMPS_BUF_SEND_DESC_BANDE USE MUMPS_LOAD USE SMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_PTR, & SMUMPS_DM_IS_DYNAMIC USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER NELT INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC, LA INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE, MAXFRW, LPOOL, LEAF, & IWPOS, IWPOSCB, COMP, SLAVEF REAL, TARGET :: A(LA) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR REAL DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER MYID, COMM INTEGER IFATH INTEGER LBUFR, LBUFR_BYTES INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INTEGER LP, HS, HF, HF_OLD, NCBSON, NSLAVES_OLD LOGICAL LPOK INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL REAL, DIMENSION(:), POINTER :: SON_A INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER :: SON_XXS INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL PACKED_CB, IS_CB_LR INTEGER(8) :: LCB LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER MP INTEGER :: K1, K2, KK, KK1 INTEGER :: J253 INTEGER(8) :: AII8, AINPUT8, II8 INTEGER(8) :: J18,J28,JJ8 INTEGER(8) :: LAPOS2, JJ2, JJ3 INTEGER(8) :: NFRONT8, POSELT, POSEL1, LDAFS8, & IACHK, ICT12, ICT21 INTEGER(8) APOS, APOS2 #if ! defined(ZERO_TRIANGLE) INTEGER :: TOPDIAG #endif !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM,NPIVS,NCOLS,NROWS, & IORG INTEGER LDAFS, LDA_SON, IJROW, IBROT INTEGER Pos_First_NUMORG,NBCOL,NUMORG,IOLDPS INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, PDEST INTEGER PDEST1(1) INTEGER :: ISLAVE INTEGER ELTI INTEGER(8) :: SIZE_ELTI8 INTEGER :: I, J INTEGER :: ELBEG, NUMELT LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER IZERO INTEGER IDUMMY(1) PARAMETER( IZERO = 0 ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT REAL ZERO REAL RZERO PARAMETER( RZERO = 0.0E0 ) PARAMETER( ZERO = 0.0E0 ) logical :: force_cand INTEGER ETATASS INTEGER(8) :: APOSMAX REAL MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT, & NUMORG_SPLIT, TYPESPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER, ALLOCATABLE, DIMENSION(:) :: SONROWS_PER_ROW INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTEGER :: NMB_OF_CAND, NMB_OF_CAND_ORIG LOGICAL :: IS_ofType5or6, SPLIT_MAP_RESTART !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IS_ofType5or6 = .FALSE. PACKED_CB = .FALSE. ETATASS = 0 IN = INODE NSTEPS = NSTEPS + 1 KEEP(429) = KEEP(429)+1 NUMELT = FRT_PTR(INODE+1) - FRT_PTR(INODE) IF ( NUMELT .NE. 0 ) THEN ELBEG = FRT_PTR(INODE) ELSE ELBEG = 1 END IF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON NCBSON_MAX = 0 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 IF ( KEEP(48)==5 .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) ENDIF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 CALL IS_FRONT_BLR_CANDIDATE(INODE, 2, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, KEEP(280), LRGROUPS) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then force_cand=.FALSE. ELSE force_cand=(mod(KEEP(24),2).eq.0) end if TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) SPLIT_MAP_RESTART = .FALSE. IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) NMB_OF_CAND = CAND( SLAVEF+1, INIV2 ) NMB_OF_CAND_ORIG = NMB_OF_CAND SIZE_TMP_SLAVES_LIST = NMB_OF_CAND IF (IS_ofType5or6) THEN DO I=NMB_OF_CAND+1,SLAVEF IF ( CAND( I, INIV2 ).LT.0) EXIT NMB_OF_CAND = NMB_OF_CAND +1 ENDDO SIZE_TMP_SLAVES_LIST = NSLSON-1 WRITE(6,*) "NMB_OF_CAND, SIZE_TMP_SLAVES_LIST ", & NMB_OF_CAND, SIZE_TMP_SLAVES_LIST IF (INODE.EQ.-999999) THEN SPLIT_MAP_RESTART = .TRUE. ENDIF ENDIF IF (IS_ofType5or6.AND.SPLIT_MAP_RESTART) THEN TYPESPLIT = 4 IS_ofType5or6 = .FALSE. SIZE_TMP_SLAVES_LIST = NMB_OF_CAND CAND (SLAVEF+1, INIV2) = SIZE_TMP_SLAVES_LIST ENDIF ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 NMB_OF_CAND = SLAVEF - 1 NMB_OF_CAND_ORIG = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IF ( (TYPESPLIT.EQ.4) & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) & ) THEN IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) IF (SPLIT_MAP_RESTART) THEN IS_ofType5or6 = .TRUE. TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) CAND( SLAVEF+1, INIV2 ) = NMB_OF_CAND_ORIG ENDIF ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) IF (KEEP(376) .EQ. 1) THEN NFRONT = IW( PIMASTER(STEP(IFSON)) + KEEP(IXSZ)) ENDIF CALL MUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND(1,INIV2), NMB_OF_CAND_ORIG, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES, & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST & ) ENDIF ELSE CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_OOC_GET_PP_SIZES(KEEP(50), NASS1, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL SMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & LRLUS,KEEP(IXSZ), & COMP, DKEEP(97), MYID, SLAVEF, & PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress SMUMPS_FAC_ASM_NIV2_ELT', & 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. ALLOCATE(SONROWS_PER_ROW(NFRONT-NASS1), stat=allocok) IF (allocok > 0) THEN GOTO 275 ENDIF CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & SONROWS_PER_ROW, NFRONT - NASS1) IF (INFO(1).LT.0) GOTO 250 IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN WRITE(6,*) ' Internal error 1 in fac_ass due to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF WRITE(6,*) ' SPLITTING NOT YET READY FOR THAT' CALL MUMPS_ABORT() ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN NCB = NFRONT_EFF - NASS1 NSLAVES_OLD = NSLAVES HF_OLD = HF IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP, KEEP8, ICNTL, & CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - & (NSLAVES_OLD - NSLAVES) IF (NSLAVES_OLD .NE. NSLAVES) THEN IF (NSLAVES_OLD > NSLAVES) THEN DO KK=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+KK)=IW(IOLDPS+HF_OLD+KK) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO KK=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+KK) = IW(IOLDPS+HF_OLD+KK) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) ' INTERNAL ERROR 2 during ass_niv2' ENDIF GOTO 270 ENDIF ENDIF NFRONT8=int(NFRONT,8) IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max(MAXFRW, NFRONT) PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+KEEP(IXSZ)) = NFRONT IW(IOLDPS + 1+KEEP(IXSZ)) = 0 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+NSLAVES+KEEP(IXSZ))= & TMP_SLAVES_LIST(1:NSLAVES) ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL SMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) ENDIF ENDIF ENDIF CALL MUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM_LOAD, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP, KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) IF(KEEP(86).EQ.1)THEN IF(mod(KEEP(24),2).eq.0)THEN CALL MUMPS_LOAD_SEND_MD_INFO(SLAVEF, & CAND(SLAVEF+1,INIV2), & CAND(1,INIV2), & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN CALL MUMPS_LOAD_SEND_MD_INFO(SLAVEF, & SLAVEF-1, & TMP_SLAVES_LIST, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ENDIF ENDIF DEALLOCATE(TMP_SLAVES_LIST) IF (KEEP(50).EQ.0) THEN LAELL8 = int(NASS1,8) * NFRONT8 LDAFS = NFRONT LDAFS8 = NFRONT8 ELSE LAELL8 = int(NASS1,8)*int(NASS1,8) IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) & LAELL8 = LAELL8+int(NASS1,8) LDAFS = NASS1 LDAFS8 = int(NASS1,8) ENDIF CALL SMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= LRSTATUS IW(IOLDPS+XXG) = MemNotPinned CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8,LRLUS) POSEL1 = POSELT - LDAFS8 #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8 = int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (LAPOS2 - POSELT > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO JJ8 = POSELT, LAPOS2 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max(KEEP(360)/2, !$ & ( (( LDAFS + NOMP -1 ) / NOMP + 2) / 3) ) APOS = POSELT #if defined(__ve__) !NEC$ IVDEP #endif !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK) !$OMP& IF (LDAFS - 1 .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(LDAFS-1,8) APOS = POSELT + JJ8 * int(LDAFS,8) JJ3 = min( int(LDAFS,8) - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) A(APOSMAX:APOSMAX+int(LDAFS-1,8))=ZERO ENDIF END IF #endif IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) IF (NELIM.EQ.0) GOTO 210 LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT=PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT=ISTCHK ENDIF SON_XXS = IW(ISTCHK_CB_RIGHT + XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF IF (KEEP(50).EQ.0) THEN LDA_SON = LSTK LCB = int(NELIM,8)*int(LSTK,8) ELSE IF (NSLSON.EQ.0) THEN IF (SAME_PROC) THEN IS_CB_LR = IW(ISTCHK_CB_RIGHT+XXLR).EQ. 1 .OR. & IW(ISTCHK_CB_RIGHT+XXLR).EQ. 3 IF (IS_CB_LR) THEN LDA_SON = NELIM ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = NELIM ENDIF IF (PACKED_CB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN OPASSW = OPASSW + dble(LCB) ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM+1,8)/2_8 ENDIF IS_DYNAMIC_CB = & SMUMPS_DM_IS_DYNAMIC(IW(ISTCHK_CB_RIGHT+XXD: & ISTCHK_CB_RIGHT+XXD+1)) IF ( IS_DYNAMIC_CB ) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_CB_RIGHT+XXD)) CALL SMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) SON_A=>A ENDIF K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IF (KEEP(50).eq.0) THEN IF (IS_ofType5or6) THEN APOS = POSELT DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + SON_A(IACHK+JJ8-1_8) ENDDO ELSE DO 170 KK = K1, K2 APOS = POSEL1 + int(IW(KK),8) * LDAFS8 DO 160 KK1 = 1, LSTK JJ2 = APOS + int(IW(K1 + KK1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (LCB .GT. 0) THEN CALL SMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) IF (KEEP(219).NE.0) THEN IF (KEEP(50).EQ.2) THEN A( APOSMAX: APOSMAX+int(NASS1-1,8))=ZERO ENDIF ENDIF DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1) - 1_8 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = INTARR(II8) IF (KEEP(50).EQ.0) THEN IF (I.LE.NASS1) THEN AINPUT8 = AII8 + II8 - J18 ICT12 = POSELT + int(I-1,8) * LDAFS8 DO JJ8=J18,J28 APOS2 = ICT12 + int(INTARR(JJ8) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ENDIF ELSE ICT12 = POSELT - LDAFS8 + int(I,8) - 1_8 ICT21 = POSELT + int(I-1,8)*LDAFS8 - 1_8 IF ( I .GT. NASS1 ) THEN IF (KEEP(219).NE.0 .AND. KEEP(50).EQ.2) THEN AINPUT8=AII8 DO JJ8=II8,J28 J=INTARR(JJ8) IF (J.LE.NASS1) THEN A(APOSMAX+int(J-1,8))= & max(real(A(APOSMAX+int(J-1,8))), & abs(DBLARR(AINPUT8))) ENDIF AINPUT8=AINPUT8+1_8 ENDDO ENDIF AII8 = AII8 + J28 - II8 + 1_8 CYCLE ELSE IF (KEEP(219).NE.0) THEN MAXARR = RZERO ENDIF DO JJ8=II8,J28 J = INTARR(JJ8) IF ( J .LE. NASS1) THEN IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*LDAFS8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII8) ELSE IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AII8))) ENDIF AII8 = AII8 + 1_8 END DO IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(I-1,8)) = & max( MAXARR, real(A(APOSMAX+int(I-1,8)))) ENDIF ENDIF END IF END DO END DO IF (KEEP(253).GT.0) THEN POSELT = PTRAST(STEP(INODE)) IBROT = INODE IJROW = Pos_First_NUMORG DO IORG = 1, NUMORG IF (KEEP(50).EQ.0) THEN DO J253 = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & NBLIG, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 IERR = -1 DO WHILE (IERR .EQ.-1) IF ( KEEP(50) .eq. 0 ) THEN NBCOL = NFRONT CALL MUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL MUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF ENDDO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 ENDDO DEALLOCATE(SONROWS_PER_ROW) IF (NUMSTK.EQ.0) GOTO 500 ISON = IFSON DO IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + 2 + KEEP(IXSZ) ) ELSE NROWS = NCOLS ENDIF PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN NFS4FATHER = NCBSON DO I=0,NCBSON-1 IF(IW(PTRCOL+I) .GT. NASS1) THEN NFS4FATHER = I EXIT ENDIF ENDDO NFS4FATHER = NFS4FATHER + NELIM ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) IF (PDEST1(1).EQ.MYID) THEN CALL SMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & NFRONT, NASS1, NFS4FATHER, NCBSON, IW( PTRCOL ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, roota, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, NELT+1, NELT, & FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, PDEST1, NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL SMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & NFRONT, NASS1,NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), INFO(2), & MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & SMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(2) = NUMSTK + 1 ENDIF GOTO 490 245 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING COPY_CAND', & ' DURING SMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = SLAVEF+1 GOTO 490 265 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING SMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING SMUMPS_ASM_NIV2_ELT' ENDIF GOTO 490 275 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING SONROWS_PER_ROW', & ' DURING SMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = NFRONT-NASS1 GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (1) DURING SMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (1) DURING SMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (2)', &' DURING SMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (2)', &' DURING SMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -20 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 490 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_ASM_NIV2_ELT END MODULE SMUMPS_FAC_ASM_MASTER_ELT_M MUMPS_5.8.1/src/dfac_asm_master_ELT_m.F0000664000175000017500000021471715042446440017503 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_ASM_MASTER_ELT_M CONTAINS SUBROUTINE DMUMPS_FAC_ASM_NIV1_ELT( COMM_LOAD, ASS_IRECV, & UU, NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, INFO, ND, & FILS, FRERE, DAD, MAXFRW, root, roota, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, LRLUSM, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & , MUMPS_TPS_ARR, DMUMPS_TPS_ARR, L0_OMP_MAPPING & ) !$ USE OMP_LIB USE MUMPS_TPS_M USE DMUMPS_TPS_M USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_PTR, & DMUMPS_DM_FREE_BLOCK USE MUMPS_BUILD_SORT_INDEX_ELT_M USE MUMPS_BUF_COMMON, ONLY: MUMPS_BUF_SEND_MAPLIG USE MUMPS_LOAD USE DMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE, & DMUMPS_BLR_ASM_NIV1 USE DMUMPS_LR_DATA_M, ONLY : DMUMPS_BLR_INIT_FRONT, & DMUMPS_BLR_SAVE_NFS4FATHER USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N, NSTEPS INTEGER NELT INTEGER(8) LA, LRLU, LRLUS, LRLUSM, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) DOUBLE PRECISION UU INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS, LIW TYPE (MUMPS_TPS_T), TARGET, OPTIONAL :: MUMPS_TPS_ARR(:) TYPE (DMUMPS_TPS_T), TARGET, OPTIONAL :: DMUMPS_TPS_ARR(:) INTEGER, INTENT(IN), OPTIONAL :: L0_OMP_MAPPING(:) INTEGER IDUMMY(1) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER, TARGET :: IW(LIW) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ITLOC(N+KEEP(253)), & ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)), & PAMASTER(KEEP(28)) INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER ETATASS LOGICAL SON_LEVEL2 DOUBLE PRECISION, TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR DOUBLE PRECISION DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) LOGICAL PACKED_CB, IS_CB_LR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF LOGICAL LPOK INTEGER NBPANELS_L, NBPANELS_U INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER PARPIV_T1 INTEGER(8) NFRONT8, LAELL8, KEEP8TMPCOPY INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER LREQ_OOC INTEGER :: SON_XXS, SON_XXLR, SON_XXG INTEGER(8) LSTK8, SIZFR8 LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM, IORG, IBROT INTEGER :: J253 #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER(8) APOS, APOS2, LAPOS2 INTEGER(8) POSELT, POSEL1, ICT12, ICT21 INTEGER(8) IACHK INTEGER(8) JJ2 INTEGER(8) :: JJ8, J18, J28 INTEGER(8) :: AINPUT8, AII8 INTEGER :: K1, K2, K3, KK, KK1 INTEGER JPOS,ICT11, IJROW INTEGER Pos_First_NUMORG,NUMORG,IOLDPS, & NUMELT, ELBEG INTEGER :: J INTEGER NSLAVES, NSLSON, NPIVS, NPIV_ANA, NPIV INTEGER PTRCOL, ISLAVE, PDEST,LEVEL LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER ELTI INTEGER(8) :: SIZE_ELTI8 INTEGER(8) :: II8 INTEGER :: I LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: ITHREAD INTEGER, POINTER :: SON_IWPOS, SON_LIW INTEGER, POINTER, DIMENSION(:) :: SON_IW DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTEGER PIVOT_OPTION DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) LOGICAL MUMPS_INSSARBR, SSARBR EXTERNAL MUMPS_INSSARBR DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR !$ NOMP = OMP_GET_MAX_THREADS() LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) NFS4FATHER = -1 ETATASS = 0 PACKED_CB = .FALSE. IS_CB_LR = .FALSE. IN = INODE LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (LEVEL.NE.1) THEN WRITE(*,*) 'INTERNAL ERROR 1 in DMUMPS_FAC_ASM_NIV1_ELT ' CALL MUMPS_ABORT() END IF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) NUMELT = FRT_PTR(INODE+1) - FRT_PTR(INODE) IF ( NUMELT .ne. 0 ) THEN ELBEG = FRT_PTR(INODE) ELSE ELBEG = 1 END IF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) END DO NPIV_ANA=NUMORG NSTEPS = NSTEPS + 1 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 SON_IW => IW IF (KEEP(400).GT.0) THEN IF (present(L0_OMP_MAPPING)) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .NE.0) THEN SON_IW=>MUMPS_TPS_ARR(ITHREAD)%IW ENDIF ENDIF ENDIF NASS = NASS + SON_IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG CALL IS_FRONT_BLR_CANDIDATE(INODE, 1, ND(STEP(INODE)), & NUMORG, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, KEEP(280), LRGROUPS) IF (DAD(STEP(INODE)).NE.0) THEN IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199) ) & .NE. MYID & .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199)) & .EQ.1 & ) THEN IF (LRSTATUS.EQ.1 .OR. LRSTATUS.EQ.3) THEN LRSTATUS = LRSTATUS-1 ENDIF ENDIF ENDIF COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_OOC_GET_PP_SIZES(KEEP(50), NFRONT, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL DMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, SLAVEF, & PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress DMUMPS_FAC_ASM_NIV1_ELT' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 END IF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 END IF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .TRUE. IF (.NOT. present(MUMPS_TPS_ARR).AND. & .NOT. present(L0_OMP_MAPPING) ) THEN CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & IDUMMY, LIDUMMY ) ELSE CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & IDUMMY, LIDUMMY & , MUMPS_TPS_ARR, L0_OMP_MAPPING ) ENDIF IF (INFO(1).LT.0) GOTO 300 IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL MUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1-FLOP1_EFF, & KEEP,KEEP8) ENDIF IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) & ' ERROR 1 during ass_niv1_ELT', NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF NCB = NFRONT - NASS1 MAXFRW = max(MAXFRW, NFRONT) ICT11 = IOLDPS + HF - 1 + NFRONT CALL DMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) PIVOT_OPTION = KEEP(468) IF (UU.EQ.ZERO) THEN PIVOT_OPTION=0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF(PARPIV_T1.NE.0) THEN LAELL8 = LAELL8+int(NASS1,8) ENDIF CALL DMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 LRLUSM = min( LRLUS, LRLUSM ) IF (KEEP(405).EQ.0) THEN KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + LAELL8 KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ENDIF POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8, & KEEP,KEEP8, & LRLUS) IF (KEEP(405).EQ.0) KEEP(429)= KEEP(429)+1 #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8=int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (LAPOS2 - POSELT + 1_8 > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8), KEEP(218))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & NCB, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1,TOPDIAG) ENDIF NUMROWS = NFRONT8 !$ CHUNK = max(KEEP(360)/2, !$ & ( ((int(NUMROWS)+NOMP-1) / NOMP + 2) / 3) ) #if defined(__ve__) !NEC$ IVDEP #endif !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK ) !$OMP& IF (int(NUMROWS - 1) .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = POSELT + JJ8 * NFRONT8 JJ3 = min( NFRONT8 - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS + JJ3) = ZERO ENDDO !$OMP END PARALLEL DO END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS IW(IOLDPS + KEEP(IXSZ)) = NFRONT IW(IOLDPS + KEEP(IXSZ)+ 1) = 0 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN CALL DMUMPS_BLR_INIT_FRONT (IW(IOLDPS+XXF), INFO, & MTK405=KEEP(405)) IF (INFO(1).LT.0) GOTO 500 ENDIF ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL DMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) CALL DMUMPS_BLR_SAVE_NFS4FATHER ( IW(IOLDPS+XXF), & ESTIM_NFS4FATHER_ATSON ) ENDIF ENDIF ENDIF IF (NUMSTK.NE.0) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_LIW => LIW SON_IWPOS => IWPOS SON_A => A ITHREAD = 0 IF (KEEP(400).GT.0) THEN IF (present(L0_OMP_MAPPING)) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .NE.0) THEN SON_LIW => MUMPS_TPS_ARR(ITHREAD)%LIW SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW SON_IWPOS => MUMPS_TPS_ARR(ITHREAD)%IWPOS SON_A => DMUMPS_TPS_ARR(ITHREAD)%A ENDIF ENDIF ENDIF LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + KEEP(IXSZ) + 1) NPIVS = SON_IW(ISTCHK + KEEP(IXSZ) + 3) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = SON_IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.SON_IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT = PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT = ISTCHK ENDIF SON_XXS = SON_IW(ISTCHK_CB_RIGHT+XXS) SON_XXLR = SON_IW(ISTCHK_CB_RIGHT+XXLR) SON_XXG = SON_IW(ISTCHK_CB_RIGHT+XXG) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IS_CB_LR = ( SON_XXLR.EQ.1 .OR. SON_XXLR.EQ.3 ) & .AND. (KEEP(489).EQ.1.OR.KEEP(489).EQ.3) LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = SON_IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF K1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN K2 = K1 + LSTK - 1 IF (PACKED_CB) THEN SIZFR8 = (LSTK8*(LSTK8+1_8)/2_8) ELSE SIZFR8 = LSTK8*LSTK8 ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * LSTK8 ELSE IF (PACKED_CB) THEN SIZFR8 = int(NELIM,8) * int(NELIM+1,8)/2_8 ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) ENDIF END IF K2 = K1 + NELIM - 1 ENDIF IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + LSTK8*LSTK8 ELSE OPASSW = OPASSW + LSTK8*(LSTK8+1)/2_8 ENDIF ELSE IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + int(NELIM,8)*LSTK8 ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM,8)/2_8 ENDIF ENDIF CALL MUMPS_GETI8(DYN_SIZE, SON_IW(ISTCHK_CB_RIGHT+XXD)) IS_DYNAMIC_CB = DYN_SIZE .GT. 0_8 IF ( IS_DYNAMIC_CB ) THEN CALL DMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) ENDIF IF (IS_CB_LR .AND. LEVEL1) THEN POSEL1 = PTRAST(STEP(INODE)) CALL DMUMPS_BLR_ASM_NIV1 (A, LA, & POSEL1, NFRONT, NASS1, SON_IW(ISTCHK+XXF), & SON_IW, SON_LIW, & LSTK, NELIM, K1, K1+LSTK-1, KEEP(50), & KEEP, KEEP8, OPASSW) ENDIF IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (K2.GE.K1) THEN #if defined(__ve__) !NEC$ IVDEP #endif DO 170 KK = K1, K2 APOS = POSEL1 + int(SON_IW(KK),8) * NFRONT8 #if defined(__ve__) !NEC$ IVDEP #endif DO 160 KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1 + KK1 - 1) - 1,8) A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + LSTK8 170 CONTINUE END IF ELSE IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (SIZFR8 .GT. 0) THEN CALL DMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF (SAME_PROC) THEN IF (KEEP(50).NE.0) THEN K2 = K1 + LSTK - 1 #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K1, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO ELSE K2 = K1 + LSTK - 1 K3 = K1 + NELIM #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K3, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO IF (NELIM .NE. 0) THEN K3 = K3 - 1 #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K1, K3 JPOS = SON_IW(KK) + ICT11 SON_IW(KK) = IW(JPOS) ENDDO ENDIF ENDIF ENDIF IF ( SAME_PROC ) THEN PTRIST(STEP(ISON)) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF IF (ITHREAD .EQ. 0) THEN CALL DMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & .FALSE. & ) ELSE CALL MUMPS_LOAD_DISABLE() CALL DMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & MUMPS_TPS_ARR(ITHREAD)%IW(1), & MUMPS_TPS_ARR(ITHREAD)%LIW, & MUMPS_TPS_ARR(ITHREAD)%LRLU, & MUMPS_TPS_ARR(ITHREAD)%LRLUS, & MUMPS_TPS_ARR(ITHREAD)%IPTRLU, & MUMPS_TPS_ARR(ITHREAD)%IWPOSCB, & MUMPS_TPS_ARR(ITHREAD)%LA, KEEP,KEEP8, .FALSE. & ) CALL MUMPS_LOAD_ENABLE() ENDIF IF (IS_DYNAMIC_CB) THEN CALL DMUMPS_DM_FREE_BLOCK(SON_XXG, & SON_A, SIZFR8, & KEEP(405).EQ.1, KEEP8 ) ENDIF ELSE PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP, KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL DMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, IDUMMY, & NFRONT, NASS1, NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & IZERO, IDUMMY, IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP, KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE., LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF END DO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) 220 CONTINUE END IF DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = INTARR(II8) IF (KEEP(50).EQ.0) THEN AINPUT8 = AII8 + II8 - J18 ICT12 = POSELT + int(I-1,8) * NFRONT8 DO JJ8=J18,J28 APOS2 = ICT12 + int(INTARR(JJ8) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ELSE ICT12 = POSELT + int(- NFRONT + I - 1,8) ICT21 = POSELT + int(I-1,8)*NFRONT8 - 1_8 DO JJ8=II8,J28 J = INTARR(JJ8) IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*NFRONT8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII8) AII8 = AII8 + 1_8 END DO END IF END DO END DO IF (KEEP(253).GT.0) THEN POSELT = PTRAST(STEP(INODE)) IBROT = INODE IJROW = Pos_First_NUMORG DO IORG = 1, NUMORG IF (KEEP(50).EQ.0) THEN DO J253=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ELSE DO J253=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+J253-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF IF (PARPIV_T1.NE.0.AND.(.NOT.SON_LEVEL2)) THEN IOLDPS = PTLUST(STEP(INODE)) CALL DMUMPS_PARPIVT1_SET_NVSCHUR_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1, NASS) ENDIF GOTO 500 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING DMUMPS_ASM_NIV1_ELT' ENDIF GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING DMUMPS_ASM_NIV1_ELT' ENDIF INFO(1) = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, RECV BUFFER TOO SMALL DURING DMUMPS_ASM_NIV1_ELT' ENDIF INFO(1) = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) ' FAILURE IN INTEGER', & ' DYNAMIC ALLOCATION DURING DMUMPS_ASM_NIV1_ELT' ENDIF INFO(2) = NUMSTK ENDIF 490 CONTINUE IF ( KEEP(405) .EQ. 0 ) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_ASM_NIV1_ELT SUBROUTINE DMUMPS_FAC_ASM_NIV2_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, INFO, & ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, roota, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, MEM_DISTRIB & , LRGROUPS & ) !$ USE OMP_LIB USE MUMPS_BUILD_SORT_INDEX_ELT_M USE MUMPS_BUF_COMMON, ONLY: MUMPS_BUF_SEND_MAPLIG, & MUMPS_BUF_SEND_DESC_BANDE USE MUMPS_LOAD USE DMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_PTR, & DMUMPS_DM_IS_DYNAMIC USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER NELT INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC, LA INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE, MAXFRW, LPOOL, LEAF, & IWPOS, IWPOSCB, COMP, SLAVEF DOUBLE PRECISION, TARGET :: A(LA) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR DOUBLE PRECISION DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER MYID, COMM INTEGER IFATH INTEGER LBUFR, LBUFR_BYTES INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INTEGER LP, HS, HF, HF_OLD, NCBSON, NSLAVES_OLD LOGICAL LPOK INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL DOUBLE PRECISION, DIMENSION(:), POINTER :: SON_A INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER :: SON_XXS INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL PACKED_CB, IS_CB_LR INTEGER(8) :: LCB LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER MP INTEGER :: K1, K2, KK, KK1 INTEGER :: J253 INTEGER(8) :: AII8, AINPUT8, II8 INTEGER(8) :: J18,J28,JJ8 INTEGER(8) :: LAPOS2, JJ2, JJ3 INTEGER(8) :: NFRONT8, POSELT, POSEL1, LDAFS8, & IACHK, ICT12, ICT21 INTEGER(8) APOS, APOS2 #if ! defined(ZERO_TRIANGLE) INTEGER :: TOPDIAG #endif !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM,NPIVS,NCOLS,NROWS, & IORG INTEGER LDAFS, LDA_SON, IJROW, IBROT INTEGER Pos_First_NUMORG,NBCOL,NUMORG,IOLDPS INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, PDEST INTEGER PDEST1(1) INTEGER :: ISLAVE INTEGER ELTI INTEGER(8) :: SIZE_ELTI8 INTEGER :: I, J INTEGER :: ELBEG, NUMELT LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER IZERO INTEGER IDUMMY(1) PARAMETER( IZERO = 0 ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT DOUBLE PRECISION ZERO DOUBLE PRECISION RZERO PARAMETER( RZERO = 0.0D0 ) PARAMETER( ZERO = 0.0D0 ) logical :: force_cand INTEGER ETATASS INTEGER(8) :: APOSMAX DOUBLE PRECISION MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT, & NUMORG_SPLIT, TYPESPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER, ALLOCATABLE, DIMENSION(:) :: SONROWS_PER_ROW INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTEGER :: NMB_OF_CAND, NMB_OF_CAND_ORIG LOGICAL :: IS_ofType5or6, SPLIT_MAP_RESTART !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IS_ofType5or6 = .FALSE. PACKED_CB = .FALSE. ETATASS = 0 IN = INODE NSTEPS = NSTEPS + 1 KEEP(429) = KEEP(429)+1 NUMELT = FRT_PTR(INODE+1) - FRT_PTR(INODE) IF ( NUMELT .NE. 0 ) THEN ELBEG = FRT_PTR(INODE) ELSE ELBEG = 1 END IF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON NCBSON_MAX = 0 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 IF ( KEEP(48)==5 .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) ENDIF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 CALL IS_FRONT_BLR_CANDIDATE(INODE, 2, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, KEEP(280), LRGROUPS) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then force_cand=.FALSE. ELSE force_cand=(mod(KEEP(24),2).eq.0) end if TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) SPLIT_MAP_RESTART = .FALSE. IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) NMB_OF_CAND = CAND( SLAVEF+1, INIV2 ) NMB_OF_CAND_ORIG = NMB_OF_CAND SIZE_TMP_SLAVES_LIST = NMB_OF_CAND IF (IS_ofType5or6) THEN DO I=NMB_OF_CAND+1,SLAVEF IF ( CAND( I, INIV2 ).LT.0) EXIT NMB_OF_CAND = NMB_OF_CAND +1 ENDDO SIZE_TMP_SLAVES_LIST = NSLSON-1 WRITE(6,*) "NMB_OF_CAND, SIZE_TMP_SLAVES_LIST ", & NMB_OF_CAND, SIZE_TMP_SLAVES_LIST IF (INODE.EQ.-999999) THEN SPLIT_MAP_RESTART = .TRUE. ENDIF ENDIF IF (IS_ofType5or6.AND.SPLIT_MAP_RESTART) THEN TYPESPLIT = 4 IS_ofType5or6 = .FALSE. SIZE_TMP_SLAVES_LIST = NMB_OF_CAND CAND (SLAVEF+1, INIV2) = SIZE_TMP_SLAVES_LIST ENDIF ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 NMB_OF_CAND = SLAVEF - 1 NMB_OF_CAND_ORIG = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IF ( (TYPESPLIT.EQ.4) & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) & ) THEN IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) IF (SPLIT_MAP_RESTART) THEN IS_ofType5or6 = .TRUE. TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) CAND( SLAVEF+1, INIV2 ) = NMB_OF_CAND_ORIG ENDIF ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) IF (KEEP(376) .EQ. 1) THEN NFRONT = IW( PIMASTER(STEP(IFSON)) + KEEP(IXSZ)) ENDIF CALL MUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND(1,INIV2), NMB_OF_CAND_ORIG, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES, & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST & ) ENDIF ELSE CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_OOC_GET_PP_SIZES(KEEP(50), NASS1, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL DMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & LRLUS,KEEP(IXSZ), & COMP, DKEEP(97), MYID, SLAVEF, & PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress DMUMPS_FAC_ASM_NIV2_ELT', & 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. ALLOCATE(SONROWS_PER_ROW(NFRONT-NASS1), stat=allocok) IF (allocok > 0) THEN GOTO 275 ENDIF CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & SONROWS_PER_ROW, NFRONT - NASS1) IF (INFO(1).LT.0) GOTO 250 IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN WRITE(6,*) ' Internal error 1 in fac_ass due to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF WRITE(6,*) ' SPLITTING NOT YET READY FOR THAT' CALL MUMPS_ABORT() ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN NCB = NFRONT_EFF - NASS1 NSLAVES_OLD = NSLAVES HF_OLD = HF IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP, KEEP8, ICNTL, & CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - & (NSLAVES_OLD - NSLAVES) IF (NSLAVES_OLD .NE. NSLAVES) THEN IF (NSLAVES_OLD > NSLAVES) THEN DO KK=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+KK)=IW(IOLDPS+HF_OLD+KK) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO KK=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+KK) = IW(IOLDPS+HF_OLD+KK) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) ' INTERNAL ERROR 2 during ass_niv2' ENDIF GOTO 270 ENDIF ENDIF NFRONT8=int(NFRONT,8) IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max(MAXFRW, NFRONT) PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+KEEP(IXSZ)) = NFRONT IW(IOLDPS + 1+KEEP(IXSZ)) = 0 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+NSLAVES+KEEP(IXSZ))= & TMP_SLAVES_LIST(1:NSLAVES) ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL DMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) ENDIF ENDIF ENDIF CALL MUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM_LOAD, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP, KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) IF(KEEP(86).EQ.1)THEN IF(mod(KEEP(24),2).eq.0)THEN CALL MUMPS_LOAD_SEND_MD_INFO(SLAVEF, & CAND(SLAVEF+1,INIV2), & CAND(1,INIV2), & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN CALL MUMPS_LOAD_SEND_MD_INFO(SLAVEF, & SLAVEF-1, & TMP_SLAVES_LIST, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ENDIF ENDIF DEALLOCATE(TMP_SLAVES_LIST) IF (KEEP(50).EQ.0) THEN LAELL8 = int(NASS1,8) * NFRONT8 LDAFS = NFRONT LDAFS8 = NFRONT8 ELSE LAELL8 = int(NASS1,8)*int(NASS1,8) IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) & LAELL8 = LAELL8+int(NASS1,8) LDAFS = NASS1 LDAFS8 = int(NASS1,8) ENDIF CALL DMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= LRSTATUS IW(IOLDPS+XXG) = MemNotPinned CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8,LRLUS) POSEL1 = POSELT - LDAFS8 #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8 = int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (LAPOS2 - POSELT > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO JJ8 = POSELT, LAPOS2 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max(KEEP(360)/2, !$ & ( (( LDAFS + NOMP -1 ) / NOMP + 2) / 3) ) APOS = POSELT #if defined(__ve__) !NEC$ IVDEP #endif !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK) !$OMP& IF (LDAFS - 1 .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(LDAFS-1,8) APOS = POSELT + JJ8 * int(LDAFS,8) JJ3 = min( int(LDAFS,8) - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) A(APOSMAX:APOSMAX+int(LDAFS-1,8))=ZERO ENDIF END IF #endif IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) IF (NELIM.EQ.0) GOTO 210 LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT=PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT=ISTCHK ENDIF SON_XXS = IW(ISTCHK_CB_RIGHT + XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF IF (KEEP(50).EQ.0) THEN LDA_SON = LSTK LCB = int(NELIM,8)*int(LSTK,8) ELSE IF (NSLSON.EQ.0) THEN IF (SAME_PROC) THEN IS_CB_LR = IW(ISTCHK_CB_RIGHT+XXLR).EQ. 1 .OR. & IW(ISTCHK_CB_RIGHT+XXLR).EQ. 3 IF (IS_CB_LR) THEN LDA_SON = NELIM ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = NELIM ENDIF IF (PACKED_CB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN OPASSW = OPASSW + dble(LCB) ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM+1,8)/2_8 ENDIF IS_DYNAMIC_CB = & DMUMPS_DM_IS_DYNAMIC(IW(ISTCHK_CB_RIGHT+XXD: & ISTCHK_CB_RIGHT+XXD+1)) IF ( IS_DYNAMIC_CB ) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_CB_RIGHT+XXD)) CALL DMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) SON_A=>A ENDIF K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IF (KEEP(50).eq.0) THEN IF (IS_ofType5or6) THEN APOS = POSELT DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + SON_A(IACHK+JJ8-1_8) ENDDO ELSE DO 170 KK = K1, K2 APOS = POSEL1 + int(IW(KK),8) * LDAFS8 DO 160 KK1 = 1, LSTK JJ2 = APOS + int(IW(K1 + KK1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (LCB .GT. 0) THEN CALL DMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) IF (KEEP(219).NE.0) THEN IF (KEEP(50).EQ.2) THEN A( APOSMAX: APOSMAX+int(NASS1-1,8))=ZERO ENDIF ENDIF DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1) - 1_8 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = INTARR(II8) IF (KEEP(50).EQ.0) THEN IF (I.LE.NASS1) THEN AINPUT8 = AII8 + II8 - J18 ICT12 = POSELT + int(I-1,8) * LDAFS8 DO JJ8=J18,J28 APOS2 = ICT12 + int(INTARR(JJ8) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ENDIF ELSE ICT12 = POSELT - LDAFS8 + int(I,8) - 1_8 ICT21 = POSELT + int(I-1,8)*LDAFS8 - 1_8 IF ( I .GT. NASS1 ) THEN IF (KEEP(219).NE.0 .AND. KEEP(50).EQ.2) THEN AINPUT8=AII8 DO JJ8=II8,J28 J=INTARR(JJ8) IF (J.LE.NASS1) THEN A(APOSMAX+int(J-1,8))= & max(dble(A(APOSMAX+int(J-1,8))), & abs(DBLARR(AINPUT8))) ENDIF AINPUT8=AINPUT8+1_8 ENDDO ENDIF AII8 = AII8 + J28 - II8 + 1_8 CYCLE ELSE IF (KEEP(219).NE.0) THEN MAXARR = RZERO ENDIF DO JJ8=II8,J28 J = INTARR(JJ8) IF ( J .LE. NASS1) THEN IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*LDAFS8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII8) ELSE IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AII8))) ENDIF AII8 = AII8 + 1_8 END DO IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(I-1,8)) = & max( MAXARR, dble(A(APOSMAX+int(I-1,8)))) ENDIF ENDIF END IF END DO END DO IF (KEEP(253).GT.0) THEN POSELT = PTRAST(STEP(INODE)) IBROT = INODE IJROW = Pos_First_NUMORG DO IORG = 1, NUMORG IF (KEEP(50).EQ.0) THEN DO J253 = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & NBLIG, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 IERR = -1 DO WHILE (IERR .EQ.-1) IF ( KEEP(50) .eq. 0 ) THEN NBCOL = NFRONT CALL MUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL MUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF ENDDO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 ENDDO DEALLOCATE(SONROWS_PER_ROW) IF (NUMSTK.EQ.0) GOTO 500 ISON = IFSON DO IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + 2 + KEEP(IXSZ) ) ELSE NROWS = NCOLS ENDIF PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN NFS4FATHER = NCBSON DO I=0,NCBSON-1 IF(IW(PTRCOL+I) .GT. NASS1) THEN NFS4FATHER = I EXIT ENDIF ENDDO NFS4FATHER = NFS4FATHER + NELIM ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) IF (PDEST1(1).EQ.MYID) THEN CALL DMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & NFRONT, NASS1, NFS4FATHER, NCBSON, IW( PTRCOL ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, roota, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, NELT+1, NELT, & FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, PDEST1, NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL DMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & NFRONT, NASS1,NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), INFO(2), & MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & DMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(2) = NUMSTK + 1 ENDIF GOTO 490 245 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING COPY_CAND', & ' DURING DMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = SLAVEF+1 GOTO 490 265 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING DMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING DMUMPS_ASM_NIV2_ELT' ENDIF GOTO 490 275 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING SONROWS_PER_ROW', & ' DURING DMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = NFRONT-NASS1 GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (1) DURING DMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (1) DURING DMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (2)', &' DURING DMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (2)', &' DURING DMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -20 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 490 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_ASM_NIV2_ELT END MODULE DMUMPS_FAC_ASM_MASTER_ELT_M MUMPS_5.8.1/src/zfac_sol_l0omp_m.F0000664000175000017500000003360015042446441016565 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FACSOL_L0OMP_M PRIVATE PUBLIC :: ZMUMPS_INIT_L0_OMP_FACTORS & , ZMUMPS_FREE_L0_OMP_FACTORS #if ! defined(NO_SAVE_RESTORE) & , ZMUMPS_SAVE_RESTORE_L0FACARRAY #endif #if ! defined(NO_SAVE_RESTORE) #endif #if ! defined(NO_SAVE_RESTORE) INCLUDE 'mumps_save_restore_modes.h' #endif CONTAINS SUBROUTINE ZMUMPS_INIT_L0_OMP_FACTORS(id_L0_OMP_FACTORS) USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (ZMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & id_L0_OMP_FACTORS INTEGER I IF (associated(id_L0_OMP_FACTORS)) THEN DO I=1, size(id_L0_OMP_FACTORS) NULLIFY(id_L0_OMP_FACTORS(I)%A) ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_INIT_L0_OMP_FACTORS SUBROUTINE ZMUMPS_FREE_L0_OMP_FACTORS(id_L0_OMP_FACTORS) USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (ZMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & id_L0_OMP_FACTORS INTEGER I IF (associated(id_L0_OMP_FACTORS)) THEN DO I=1, size(id_L0_OMP_FACTORS) IF (associated(id_L0_OMP_FACTORS(I)%A)) THEN DEALLOCATE(id_L0_OMP_FACTORS(I)%A) NULLIFY(id_L0_OMP_FACTORS(I)%A) ENDIF ENDDO DEALLOCATE(id_L0_OMP_FACTORS) NULLIFY(id_L0_OMP_FACTORS) ENDIF RETURN END SUBROUTINE ZMUMPS_FREE_L0_OMP_FACTORS #if ! defined(NO_SAVE_RESTORE) SUBROUTINE ZMUMPS_SAVE_RESTORE_L0FACARRAY(L0_OMP_FACTORS & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (ZMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: L0_OMP_FACTORS INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: j1,NbRecords,NbSubRecords,size_array1,dummy,allocok,err INTEGER:: SIZE_GEST_L0FAC_ARRAY, & SIZE_GEST_L0FAC_ARRAY_j1 INTEGER(4) :: I4 INTEGER(8):: SIZE_VARIABLES_L0FAC_ARRAY, & SIZE_VARIABLES_L0FAC_ARRAY_j1 SIZE_GEST = 0 SIZE_VARIABLES = 0_8 SIZE_GEST_L0FAC_ARRAY=0 SIZE_VARIABLES_L0FAC_ARRAY=0 SIZE_GEST_L0FAC_ARRAY_j1=0 SIZE_VARIABLES_L0FAC_ARRAY_j1=0 NbRecords = 0 IF (mode.EQ.memory_save_mode) THEN IF (associated(L0_OMP_FACTORS)) THEN NbRecords = 1 SIZE_GEST = SIZE_INT SIZE_VARIABLES = 0 DO j1=1,size(L0_OMP_FACTORS) CALL ZMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_L0FAC_ARRAY_j1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_L0FAC_ARRAY=SIZE_GEST_L0FAC_ARRAY+ & SIZE_GEST_L0FAC_ARRAY_j1 SIZE_VARIABLES_L0FAC_ARRAY=SIZE_VARIABLES_L0FAC_ARRAY+ & SIZE_VARIABLES_L0FAC_ARRAY_j1 IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords = 2 SIZE_GEST = 2*SIZE_INT SIZE_VARIABLES = 0 ENDIF ELSEIF (mode.EQ.save_mode) THEN IF (associated(L0_OMP_FACTORS)) THEN NbRecords = 1 SIZE_GEST = SIZE_INT SIZE_VARIABLES = 0 write(unit,iostat=err) size(L0_OMP_FACTORS) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 DO j1=1,size(L0_OMP_FACTORS) CALL ZMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_L0FAC_ARRAY_J1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF ELSE IF (mode.EQ.restore_mode) THEN NULLIFY(L0_OMP_FACTORS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 allocate(L0_OMP_FACTORS(size_array1), stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size(L0_OMP_FACTORS) CALL ZMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_L0FAC_ARRAY_J1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_L0FAC_ARRAY=SIZE_GEST_L0FAC_ARRAY+ & SIZE_GEST_L0FAC_ARRAY_j1 SIZE_VARIABLES_L0FAC_ARRAY=SIZE_VARIABLES_L0FAC_ARRAY+ & SIZE_VARIABLES_L0FAC_ARRAY_j1 IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO endif ENDIF if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(mode.EQ.memory_save_mode) then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_L0FAC_ARRAY SIZE_GEST=SIZE_GEST+SIZE_GEST_L0FAC_ARRAY #if defined(MUMPS_NOF2003) SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif 100 continue RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_L0FACARRAY SUBROUTINE ZMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS_1THREAD & ,unit,MYID,mode & ,Local_SIZE_GEST, Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (ZMUMPS_L0OMPFAC_T) :: L0_OMP_FACTORS_1THREAD INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: Local_NbRecords, allocok, err INTEGER(8) :: itmp Local_NbRecords = 0 Local_SIZE_GEST = 0 Local_SIZE_VARIABLES = 0_8 Local_NbRecords = Local_NbRecords+1 IF (mode .EQ. memory_save_mode) THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 ELSE IF (mode .EQ. save_mode) THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 WRITE(unit,iostat=err) L0_OMP_FACTORS_1THREAD%LA IF (err .NE. 0) THEN INFO(1)=-72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 ENDIF size_written=size_written+SIZE_INT8 ELSE IF (mode .EQ. restore_mode) THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 READ(unit,iostat=err) L0_OMP_FACTORS_1THREAD%LA IF (err .NE. 0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & INFO(2)) GOTO 100 ENDIF size_read=size_read+SIZE_INT8 ENDIF IF (mode.EQ.memory_save_mode) THEN IF (associated(L0_OMP_FACTORS_1THREAD%A)) THEN Local_NbRecords = Local_NbRecords + 2 Local_SIZE_GEST = Local_SIZE_GEST + SIZE_INT8 Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP ELSE Local_NbRecords = Local_NbRecords + 1 Local_SIZE_GEST = Local_SIZE_GEST + SIZE_INT8 Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + 0 ENDIF ELSEIF (mode.EQ.save_mode) THEN IF (associated(L0_OMP_FACTORS_1THREAD%A)) THEN Local_NbRecords = Local_NbRecords + 2 write(unit,iostat=err) int(0,8) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written=size_written+SIZE_INT8 write(unit,iostat=err) L0_OMP_FACTORS_1THREAD%A if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written = size_written + & max(L0_OMP_FACTORS_1THREAD%LA,1_8)*SIZE_ARITH_DEP ELSE Local_NbRecords = Local_NbRecords + 1 write(unit,iostat=err) int(-999,8) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written=size_written+SIZE_INT8 ENDIF ELSEIF (mode.EQ.restore_mode) THEN NULLIFY(L0_OMP_FACTORS_1THREAD%A) READ(unit,iostat=err) itmp if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 100 endif size_read = size_read + SIZE_INT8 size_allocated = size_allocated + SIZE_INT8 IF (itmp .eq. -999) THEN Local_NbRecords = Local_NbRecords + 1 ELSE Local_NbRecords = Local_NbRecords + 2 ALLOCATE(L0_OMP_FACTORS_1THREAD%A( & max(L0_OMP_FACTORS_1THREAD%LA,1_8)), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) GOTO 100 ENDIF READ(unit,iostat=err) L0_OMP_FACTORS_1THREAD%A if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 100 endif size_read = size_read + & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP size_allocated = size_allocated+ & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP ENDIF ENDIF #if defined(MUMPS_NOF2003) IF (mode.EQ.memory_save_mode) THEN Local_SIZE_GEST = Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords ELSE IF (mode.EQ.save_mode) THEN size_written = size_written+2*SIZE_INT*Local_NbRecords ELSE IF (mode.EQ.restore_mode) THEN size_read = size_read+2*SIZE_INT*Local_NbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_L0FAC #endif END MODULE ZMUMPS_FACSOL_L0OMP_M MUMPS_5.8.1/src/mumps_metis.h0000664000175000017500000000367215042446422015753 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_METIS_H #define MUMPS_METIS_H /* Interfacing with 32-bit (par)metis, for METIS 4 or METIS 5 */ #include "mumps_common.h" /* includes mumps_compat.h and mumps_c_types.h */ #if defined(parmetis) || defined(parmetis3) #include "mpi.h" #define MUMPS_PARMETIS \ F_SYMBOL(parmetis,PARMETIS) void MUMPS_CALL MUMPS_PARMETIS(MUMPS_INT *first, MUMPS_INT *vertloctab, MUMPS_INT *edgeloctab, MUMPS_INT *numflag, MUMPS_INT *options, MUMPS_INT *order, MUMPS_INT *sizes, MUMPS_INT *comm, MUMPS_INT *ierr); #define MUMPS_PARMETIS_VWGT \ F_SYMBOL(parmetis_vwgt,PARMETIS_VWGT) void MUMPS_CALL MUMPS_PARMETIS_VWGT(MUMPS_INT *first, MUMPS_INT *vertloctab, MUMPS_INT *edgeloctab, MUMPS_INT *numflag, MUMPS_INT *options, MUMPS_INT *order, MUMPS_INT *sizes, MUMPS_INT *comm, MUMPS_INT *vwgt, MUMPS_INT *ierr); #endif #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) #define MUMPS_METIS_KWAY \ F_SYMBOL(metis_kway,METIS_KWAY) void MUMPS_CALL MUMPS_METIS_KWAY(MUMPS_INT *n, MUMPS_INT *iptr, MUMPS_INT *jcn, MUMPS_INT *k, MUMPS_INT *part); #define MUMPS_METIS_KWAY_AB \ F_SYMBOL(metis_kway_ab,METIS_KWAY_AB) void MUMPS_CALL MUMPS_METIS_KWAY_AB(MUMPS_INT *n, MUMPS_INT *iptr, MUMPS_INT *jcn, MUMPS_INT *k, MUMPS_INT *part, MUMPS_INT *vwgt); #endif #endif MUMPS_5.8.1/src/zsol_fwd_aux.F0000664000175000017500000012710415042446441016051 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE ZMUMPS_TRAITER_MESSAGE_SOLVE & ( BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, & PTRFAC, IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, & INFO, KEEP, KEEP8, DKEEP, STEP, PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) USE ZMUMPS_OOC USE ZMUMPS_SOL_LR, ONLY: ZMUMPS_SOL_SLAVE_LR_U USE ZMUMPS_BUF IMPLICIT NONE INTEGER LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER N, NRHS, LPOOL, LEAF, NBFIN, LRHSINTR INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S( N ) INTEGER IWCB( LIWCB ) INTEGER IW( LIW ) INTEGER PTRICB(KEEP(28)),PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)) COMPLEX(kind=8) WCB( LWCB ), A( LA ) COMPLEX(kind=8) RHSINTR( LRHSINTR, NRHS ) INTEGER, intent(in) :: POSINRHSINTR_FWD(N) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER(8) :: PTRX, PTRY, IFR8 INTEGER IERR, K, JJ, JBDEB, JBFIN, NRHS_B INTEGER :: IWHDLR, LDA_SLAVE INTEGER :: MTYPE_SLAVE INTEGER FINODE, FPERE, LONG, NCB, POSITION, NCV, NPIV INTEGER PDEST, I, IPOSINRHSINTR INTEGER J1 INTEGER(8) :: APOS LOGICAL DUMMY LOGICAL FLAG LOGICAL :: OMP_FLAG EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR COMPLEX(kind=8) ALPHA, ONE PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) INCLUDE 'mumps_headers.h' IF ( MSGTAG .EQ. RACINE_SOLVE ) THEN NBFIN = NBFIN - 1 IF ( NBFIN .eq. 0 ) GOTO 270 ELSE IF (MSGTAG .EQ. ContVec ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LONG, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 IF ( NCB .eq. 0 ) THEN PTRICB(STEP(FINODE)) = -1 ELSE IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN PTRICB(STEP(FINODE)) = NCB + 1 END IF IF ( ( POSIWCB - LONG ) .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = LONG GOTO 260 END IF IF ( POSWCB - PLEFTWCB + 1_8 .LT. & int(LONG,8) * int(NRHS_B,8)) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8+ & int(LONG,8) * int(NRHS_B,8), & INFO(2)) GOTO 260 END IF IF (LONG .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IWCB( 1 ), & LONG, MPI_INTEGER, COMM, IERR ) DO K = 1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PLEFTWCB ), & LONG, MPI_DOUBLE_COMPLEX, COMM, IERR ) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1, LONG IPOSINRHSINTR= abs(POSINRHSINTR_FWD(IWCB(I))) RHSINTR(IPOSINRHSINTR,JBDEB+K-1) = & RHSINTR(IPOSINRHSINTR,JBDEB+K-1) + & WCB(PLEFTWCB+I-1) ENDDO END DO PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - LONG ENDIF END IF IF ( PTRICB(STEP(FINODE)) == 1 .OR. & PTRICB(STEP(FINODE)) == -1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 PTRICB(STEP(FINODE)) = 0 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) & 'Internal error 1 ZMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() END IF ENDIF ELSEIF ( MSGTAG .EQ. Master2Slave ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPIV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 PTRY = PLEFTWCB PTRX = PLEFTWCB + int(NCV,8) * int(NRHS_B,8) PLEFTWCB = PLEFTWCB + int(NPIV + NCV,8) * int(NRHS_B,8) IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(-POSWCB+PLEFTWCB-1_8,INFO(2)) GO TO 260 END IF DO K=1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PTRY + (K-1) * NCV ), NCV, & MPI_DOUBLE_COMPLEX, COMM, IERR ) ENDDO IF ( NPIV .GT. 0 ) THEN DO K=1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PTRX + (K-1)*NPIV ), NPIV, & MPI_DOUBLE_COMPLEX, COMM, IERR ) END DO END IF LR_ACTIVATED = (IW(PTRIST(STEP(FINODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(FINODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_SOLVE_GET_OOC_NODE( & FINODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,DUMMY,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF IF ( IW(PTRIST(STEP(FINODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(FINODE))+XXF) MTYPE_SLAVE = 1 CALL ZMUMPS_SOL_SLAVE_LR_U( FINODE, IWHDLR, & -9999, & WCB, LWCB, & NPIV, NCV, & PTRX, PTRY, & JBDEB, JBFIN, & MTYPE_SLAVE, KEEP, KEEP8, & INFO(1), INFO(2) ) ELSE APOS = PTRFAC(STEP(FINODE)) IF (KEEP(201) .EQ. 1) THEN MTYPE_SLAVE = 0 LDA_SLAVE = NCV ELSE MTYPE_SLAVE = 1 LDA_SLAVE = NPIV ENDIF CALL ZMUMPS_SOLVE_GEMM_UPDATE & ( A, LA, APOS, NPIV, & LDA_SLAVE, & NCV, & NRHS_B, WCB, LWCB, & PTRX, NPIV, & PTRY, NCV, & MTYPE_SLAVE, KEEP, ONE ) ENDIF IF ((KEEP(201).GT.0).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE(FINODE,PTRFAC, & KEEP(28),A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF PLEFTWCB = PLEFTWCB - int(NPIV,8) * int(NRHS_B,8) PDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & KEEP(199) ) IF ( PDEST .EQ. MYID ) THEN IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN NCB = IW( PTRIST(STEP(FINODE)) + 2 + KEEP(IXSZ) ) PTRICB(STEP(FINODE)) = NCB + 1 END IF J1 = PTRIST(STEP(FINODE))+3+KEEP(IXSZ) OMP_FLAG = .FALSE. !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (NCV*(JBFIN-JBDEB+1) .GE. KEEP(363) ) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(I,JJ,IFR8,IPOSINRHSINTR) DO K=1, NRHS_B IFR8 = PTRY+int(K-1,8)*int(NCV,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1,NCV JJ = IW(J1+I) IPOSINRHSINTR= abs(POSINRHSINTR_FWD(JJ)) RHSINTR(IPOSINRHSINTR,JBDEB+K-1)= & RHSINTR(IPOSINRHSINTR,JBDEB+K-1) & + WCB(IFR8+int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K=1, NRHS_B IFR8 = PTRY+int(K-1,8)*int(NCV,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1,NCV JJ = IW(J1+I) IPOSINRHSINTR= abs(POSINRHSINTR_FWD(JJ)) RHSINTR(IPOSINRHSINTR,JBDEB+K-1)= & RHSINTR(IPOSINRHSINTR,JBDEB+K-1) & + WCB(IFR8+int(I-1,8)) ENDDO ENDDO ENDIF PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - NCV IF ( PTRICB( STEP( FINODE ) ) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 PTRICB(STEP(FINODE)) = 0 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) & 'INTERNAL Error in ZMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() END IF ENDIF ELSE 210 CONTINUE CALL ZMUMPS_BUF_SEND_VCB( NRHS_B, FINODE, FPERE, & IW(PTRIST(STEP( FINODE )) + 2 + KEEP(IXSZ) ), NCV,NCV, & IW(PTRIST(STEP(FINODE))+4+ KEEP(IXSZ) ), & WCB( PTRY ), JBDEB, JBFIN, & RHSINTR, 1, 1, -9999, -9999, & KEEP, PDEST, ContVec, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 210 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + & NCV * KEEP( 35 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + & NCV * KEEP( 35 ) END IF END IF PLEFTWCB = PLEFTWCB - int(NCV,8) * int(NRHS_B,8) ELSEIF ( MSGTAG .EQ. TERREUR ) THEN INFO(1) = -001 INFO(2) = MSGSOU GOTO 270 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. & (MSGTAG.EQ.TAG_DUMMY) ) THEN GO TO 270 ELSE INFO(1)=-100 INFO(2)=MSGTAG GO TO 260 ENDIF GO TO 270 260 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 270 CONTINUE RETURN END SUBROUTINE ZMUMPS_TRAITER_MESSAGE_SOLVE SUBROUTINE ZMUMPS_SOLVE_NODE_FWD( INODE, & LASTFSL0STA, LASTFSL0DYN, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, & IWCB, LIWCB, & WCB, LWCB, A, LA, IW, LIW, & NRHS, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & ) USE ZMUMPS_SOL_LR !$ USE MUMPS_SOL_L0OMP_M, ONLY: LOCK_FOR_SCATTER USE MUMPS_SOL_L0OMP_M, ONLY: NB_LOCK_MAX USE ZMUMPS_OOC USE ZMUMPS_BUF IMPLICIT NONE INTEGER MTYPE INTEGER, INTENT( IN ) :: INODE, LASTFSL0STA, LASTFSL0DYN INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER LIWCB, LIW, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB, LWCB INTEGER(8) :: LA INTEGER N, LPOOL, LEAF, NBFIN INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S(KEEP(28)) INTEGER IWCB( LIWCB ), IW( LIW ) INTEGER NRHS COMPLEX(kind=8) WCB( LWCB ) COMPLEX(kind=8) :: A( LA ) INTEGER(8) :: LRHS_ROOT COMPLEX(kind=8) RHS_ROOT( LRHS_ROOT ) INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER FILS( N ), STEP( N ), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSINRHSINTR_FWD(N), LRHSINTR COMPLEX(kind=8) RHSINTR(LRHSINTR, NRHS) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP LOGICAL, intent(out) :: ERROR_WAS_BROADCASTED EXTERNAL zgemv, ztrsv, zgemm, ztrsm, MUMPS_PROCNODE INTEGER MUMPS_PROCNODE COMPLEX(kind=8) ALPHA,ONE,ZERO PARAMETER (ZERO=(0.0D0,0.0D0), & ONE=(1.0D0,0.0D0), & ALPHA=(-1.0D0,0.0D0)) INTEGER :: IWHDLR INTEGER JBDEB, JBFIN, NRHS_B INTEGER LDADIAG INTEGER(8) :: APOS, APOS1, IFR8, IFR_ini8 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, FPERE_MAPPING, & NPIV, NCB, LIELL, JJ, NELIM, IERR INTEGER(8) :: PCB_COURANT, PPIV_COURANT, PPIV_PANEL, PCB_PANEL INTEGER IPOSINRHSINTR_TMP INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex LOGICAL FLAG INTEGER :: NUPDATE_NONCRITICAL, IPOSINRHSINTRLASTFSDYN LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSDEB INTEGER TempNROW, TempNCOL, PANEL_SIZE, & JFIN, NBJ, NUPDATE_PANEL, & TYPEF INTEGER LD_WCBPIV INTEGER LD_WCBCB LOGICAL :: LDEQLIELLPANEL LOGICAL :: CBINITZERO INTEGER LDAJ, LDAJ_FIRST_PANEL INTEGER LDAtemp LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPANEL LOGICAL MUST_BE_PERMUTED INTEGER :: SIZEBLOCK, NB, JCourant, NB_LOCK INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' ERROR_WAS_BROADCASTED = .FALSE. LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IF (DO_NBSPARSE) THEN JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) JBFIN= RHS_BOUNDS(2*STEP(INODE)) ELSE JBDEB = 1 JBFIN = NRHS ENDIF NRHS_B = JBFIN-JBDEB+1 IF (DO_NBSPARSE) THEN if (JBDEB.GT.JBFIN) then write(6,*) " Internal error 1 in nbsparse :", & JBDEB, JBFIN CALL MUMPS_ABORT() endif IF (JBDEB.LT.1 .OR. JBDEB.GT.NRHS .or. & JBFIN.LT.1 .OR. JBFIN.GT.NRHS ) THEN write(6,*) " Internal error 2 in nbsparse :", & JBDEB, JBFIN CALL MUMPS_ABORT() endif ENDIF IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq.KEEP( 20 ) ) THEN LIELL = IW( PTRIST( STEP(INODE)) + 3 + KEEP(IXSZ)) NPIV = LIELL NELIM = 0 NSLAVES = 0 IPOS = PTRIST( STEP(INODE)) + 5 + KEEP(IXSZ) ELSE IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 NPIV = IW(IPOS) IPOS = IPOS + 1 IF ((KEEP(201).GT.0).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL ZMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL+1+NSLAVES), & MUST_BE_PERMUTED ) ENDIF ENDIF NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IPOS = IPOS + 1 + NSLAVES END IF IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J2 = IPOS + LIELL J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J2 = IPOS + 2 * LIELL J3 = IPOS + LIELL + NPIV END IF NCB = LIELL-NPIV IF (KEEP(50).NE.0) THEN IF ( KEEP(459) .GT. 1 ) THEN LDADIAG = -99999 ELSE LDADIAG = NPIV ENDIF ELSE LDADIAG = LIELL ENDIF IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq. KEEP(20) ) THEN IFR8 = 0_8 IPOSINRHSINTR_TMP = POSINRHSINTR_FWD(IW(J1)) IFR_ini8 = IFR8 OMP_FLAG = .FALSE. !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(IFR8,JJ) DO K=1,NRHS IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 RHS_ROOT(IFR8+int(JJ-J1+1,8)) = & RHSINTR(IPOSINRHSINTR_TMP+JJ-J1,K) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K=1,NRHS IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 RHS_ROOT(IFR8+int(JJ-J1+1,8)) = & RHSINTR(IPOSINRHSINTR_TMP+JJ-J1,K) ENDDO ENDDO ENDIF IF ( NPIV .LT. LIELL ) THEN WRITE(*,*) ' Internal error 1 in ZMUMPS_SOLVE_NODE_FWD', & NPIV, LIELL CALL MUMPS_ABORT() END IF GO TO 270 END IF APOS = PTRFAC(STEP(INODE)) IF ( (KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR ) THEN IF (MTYPE.EQ.1) THEN IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN TempNROW= NPIV+NELIM TempNCOL= NPIV LDAJ_FIRST_PANEL=TempNROW ELSE TempNROW= LIELL TempNCOL= NPIV LDAJ_FIRST_PANEL=TempNROW ENDIF TYPEF=TYPEF_L ELSE TempNCOL= LIELL TempNROW= NPIV LDAJ_FIRST_PANEL=TempNCOL TYPEF= TYPEF_U ENDIF PANEL_SIZE = ZMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) ENDIF PPIV_COURANT = PLEFTWCB PLEFTWCB = PLEFTWCB + int(LIELL,8) * int(NRHS_B,8) IF ( POSWCB - PLEFTWCB + 1_8 .LT. 0 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8, INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF IF (KEEP(201) .EQ. 1 .AND. OOCWRITE_COMPATIBLE_WITH_BLR) THEN LDEQLIELLPANEL = .TRUE. LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV ELSE LDEQLIELLPANEL = .FALSE. LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + int(NPIV,8)*int(NRHS_B,8) ENDIF FPERE = DAD(STEP(INODE)) IF ( FPERE .NE. 0 ) THEN FPERE_MAPPING = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & KEEP(199) ) ELSE FPERE_MAPPING = -1 ENDIF IF ( LASTFSL0DYN .LE. N ) THEN CBINITZERO = .TRUE. ELSE IF ( FPERE_MAPPING .EQ. MYID ) THEN CBINITZERO = .TRUE. ELSE CBINITZERO = .FALSE. ENDIF CALL ZMUMPS_RHSINTR_TO_WCB( & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL, & RHSINTR(1, JBDEB), LRHSINTR, NRHS_B, & POSINRHSINTR_FWD, N, & WCB(PPIV_COURANT), & IW, LIW, J1, J3, J2, KEEP, DKEEP) IF ( NPIV .NE. 0 ) THEN IF ((KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN APOSDEB = APOS J = 1 IPANEL = 0 10 CONTINUE IPANEL = IPANEL + 1 JFIN = min(J+PANEL_SIZE-1, NPIV) IF (IW(IPOS+ LIELL + JFIN) < 0) THEN JFIN=JFIN+1 ENDIF NBJ = JFIN-J+1 LDAJ = LDAJ_FIRST_PANEL-J+1 IF ( (KEEP(50).NE.1).AND. MUST_BE_PERMUTED ) THEN CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS+1+2*LIELL, IW, LIW) IF (NPIV.EQ.(IW(I_PIVRPTR+IPANEL-1)-1)) THEN MUST_BE_PERMUTED=.FALSE. ELSE CALL ZMUMPS_PERMUTE_PANEL( & IW( I_PIVR+ IW(I_PIVRPTR+IPANEL-1)- & IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, J-1 ) ENDIF ENDIF NUPDATE_PANEL = LDAJ - NBJ PPIV_PANEL = PPIV_COURANT+int(J-1,8) PCB_PANEL = PPIV_PANEL+int(NBJ,8) APOS1 = APOSDEB+int(NBJ,8) IF (MTYPE.EQ.1) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ztrsv( 'L', 'N', 'U', NBJ, A(APOSDEB), LDAJ, & WCB(PPIV_PANEL), 1 ) IF (NUPDATE_PANEL.GT.0) THEN CALL zgemv('N', NUPDATE_PANEL,NBJ,ALPHA, A(APOS1), & LDAJ, WCB(PPIV_PANEL), 1, ONE, & WCB(PCB_PANEL), 1) ENDIF ELSE #endif CALL ztrsm( 'L','L','N','U', NBJ, NRHS_B, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL ) IF (NUPDATE_PANEL.GT.0) THEN CALL zgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF (NRHS_B == 1) THEN CALL ztrsv( 'L', 'N', 'N', NBJ, A(APOSDEB), LDAJ, & WCB(PPIV_PANEL), 1 ) IF (NUPDATE_PANEL.GT.0) THEN CALL zgemv('N',NUPDATE_PANEL, NBJ, ALPHA, A(APOS1), & LDAJ, WCB(PPIV_PANEL), 1, & ONE, WCB(PCB_PANEL), 1 ) ENDIF ELSE #endif CALL ztrsm('L','L','N','N',NBJ, NRHS_B, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL) IF (NUPDATE_PANEL.GT.0) THEN CALL zgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF APOSDEB = APOSDEB+int(LDAJ,8)*int(NBJ,8) J=JFIN+1 IF ( J .LE. NPIV ) GOTO 10 ELSE IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL ZMUMPS_SOL_FWD_LR_SU ( & INODE, N, IWHDLR, NPIV, NSLAVES, & IW, IPOS, LIW, & LIELL, WCB, LWCB, & LD_WCBPIV, LD_WCBCB, & PPIV_COURANT, PCB_COURANT, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, KEEP8, OOCWRITE_COMPATIBLE_WITH_BLR, & INFO(1), INFO(2) ) IF (INFO(1).LT.0) THEN ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF ELSE IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 ) THEN CALL ZMUMPS_SOLVE_FWD_PANELS( & A, LA, APOS, & NPIV, IW(IPOS+LIELL+1), & NRHS_B, WCB, LWCB, LD_WCBPIV, & PPIV_COURANT, MTYPE, KEEP) ELSE CALL ZMUMPS_SOLVE_FWD_TRSOLVE ( & A, LA, APOS, & NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LD_WCBPIV, & PPIV_COURANT, MTYPE, KEEP) ENDIF END IF END IF NCB = LIELL - NPIV IF ( MTYPE .EQ. 1 ) THEN IF ( NSLAVES .EQ. 0 .OR. NPIV .eq. 0 ) THEN NUPDATE = NCB ELSE NUPDATE = NELIM END IF IF (KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0) THEN CALL MUMPS_GETI8(APOS1, IW(PTRIST(STEP(INODE))+XXR)) APOS1 = APOS + APOS1 - int(NPIV,8)*int(NUPDATE,8) ELSE APOS1 = APOS + int(NPIV,8) * int(LDADIAG,8) ENDIF ELSE APOS1 = APOS + int(NPIV,8) NUPDATE = NCB END IF IF (KEEP(201).NE.1) THEN IF ( IW(PTRIST(STEP(INODE))+XXLR) .LT. 2 .OR. & KEEP(485).EQ.0) THEN IF (MTYPE .EQ. 1) THEN LDAtemp = NPIV ELSE LDAtemp = LIELL ENDIF CALL ZMUMPS_SOLVE_GEMM_UPDATE & (A, LA, APOS1, & NPIV, LDAtemp, NUPDATE, & NRHS_B, WCB, LWCB, PPIV_COURANT, LD_WCBPIV, & PCB_COURANT, LD_WCBCB, & MTYPE, KEEP, ONE) ENDIF END IF IF ( IW(PTRIST(STEP(INODE))+XXLR) .LT. 2 .OR. & KEEP(485).EQ.0) THEN IF (KEEP(201) .GT. 0 .AND. OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_SOL_LD_AND_RELOAD( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & .FALSE. & ) ELSE CALL ZMUMPS_SOL_LD_AND_RELOAD_PANEL ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & .FALSE. & ) ENDIF ENDIF IF ((KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR) &THEN CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF END IF IF ( FPERE .EQ. 0 ) THEN PLEFTWCB = PLEFTWCB - int(LIELL,8) *int(NRHS_B,8) GOTO 270 ENDIF IF ( NUPDATE .NE. 0 .OR. NCB.EQ.0 ) THEN IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID) THEN IF ( NCB .ne. 0 ) THEN PTRICB(STEP(INODE)) = NCB + 1 NUPDATE_NONCRITICAL = NUPDATE IF (LASTFSL0DYN .LE. N) THEN IF ( LASTFSL0DYN .EQ. 0 ) THEN IPOSINRHSINTRLASTFSDYN = 0 ELSE IPOSINRHSINTRLASTFSDYN = & abs(POSINRHSINTR_FWD(LASTFSL0DYN)) ENDIF DO I = 1, NUPDATE IF ( abs(POSINRHSINTR_FWD( IW(J3+I) )) .GT. & IPOSINRHSINTRLASTFSDYN ) THEN IF (abs(STEP(IW(J3+I))) .GT. & abs(STEP( LASTFSL0STA)) & .OR. KEEP(261) .NE. 1) THEN NUPDATE_NONCRITICAL = I - 1 EXIT ENDIF ENDIF ENDDO ENDIF OMP_FLAG = .FALSE. !$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND. !$ & (NUPDATE*NRHS_B .GE. KEEP(363)) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(I,IFR8,IPOSINRHSINTR_TMP) DO K = JBDEB, JBFIN IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1, NUPDATE_NONCRITICAL IPOSINRHSINTR_TMP = & abs(POSINRHSINTR_FWD(IW(J3 + I))) RHSINTR( IPOSINRHSINTR_TMP, K ) = & RHSINTR( IPOSINRHSINTR_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K = JBDEB, JBFIN IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1, NUPDATE_NONCRITICAL IPOSINRHSINTR_TMP = & abs(POSINRHSINTR_FWD(IW(J3 + I))) RHSINTR( IPOSINRHSINTR_TMP, K ) = & RHSINTR( IPOSINRHSINTR_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO ENDIF IF ( CBINITZERO ) THEN IF ( NUPDATE .NE. NUPDATE_NONCRITICAL) THEN NB_LOCK = 1 IF ( KEEP(400) .GT. 1 ) THEN NB_LOCK = min(KEEP(400),NB_LOCK_MAX) ENDIF SIZEBLOCK = (NRHS+NB_LOCK-1) / NB_LOCK DO NB = 1 + (JBDEB-1)/SIZEBLOCK, NB_LOCK JCourant = 1+SIZEBLOCK*(NB-1) IF ( JCourant .GT. JBFIN ) EXIT !$ CALL OMP_SET_LOCK(LOCK_FOR_SCATTER(NB)) DO K = max(Jcourant,JBDEB), & min(JBFIN,Jcourant+SIZEBLOCK-1) IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = NUPDATE_NONCRITICAL+1, NUPDATE IPOSINRHSINTR_TMP = & abs(POSINRHSINTR_FWD(IW(J3 + I))) RHSINTR( IPOSINRHSINTR_TMP, K ) = & RHSINTR( IPOSINRHSINTR_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO !$ CALL OMP_UNSET_LOCK(LOCK_FOR_SCATTER(NB)) ENDDO ENDIF ENDIF PTRICB(STEP( INODE )) = PTRICB(STEP( INODE )) - NUPDATE ELSE PTRICB(STEP( INODE )) = -1 ENDIF ELSE 210 CONTINUE CALL ZMUMPS_BUF_SEND_VCB( NRHS_B, INODE, FPERE, & NCB, LD_WCBCB, & NUPDATE, & IW( J3 + 1 ), WCB( PCB_COURANT ), JBDEB, JBFIN, & RHSINTR, 1, 1, -9999, -9999, & KEEP, & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), KEEP(199)), & ContVec, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. GOTO 270 ENDIF GOTO 210 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF ENDIF END IF IF ( NSLAVES .NE. 0 .AND. MTYPE .eq. 1 & .and. NPIV .NE. 0 ) THEN DO ISLAVE = 1, NSLAVES PDEST = IW( PTRIST(STEP(INODE)) + 5 + ISLAVE +KEEP(IXSZ)) CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB - NELIM, & NSLAVES, & Effective_CB_Size, FirstIndex ) 222 CONTINUE CALL ZMUMPS_BUF_SEND_MASTER2SLAVE( NRHS_B, & INODE, FPERE, & Effective_CB_Size, LD_WCBCB, LD_WCBPIV, NPIV, & JBDEB, JBFIN, & WCB( PCB_COURANT + NELIM + FirstIndex - 1 ), & WCB( PPIV_COURANT ), & PDEST, COMM, KEEP, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. GOTO 270 ENDIF GOTO 222 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF END DO END IF PLEFTWCB = PLEFTWCB - int(LIELL,8)*int(NRHS_B,8) 270 CONTINUE RETURN END SUBROUTINE ZMUMPS_SOLVE_NODE_FWD RECURSIVE SUBROUTINE ZMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) IMPLICIT NONE LOGICAL BLOQ INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER N, NRHS, LPOOL, LEAF, NBFIN INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ), IPOOL(LPOOL) INTEGER NSTK_S( KEEP(28) ) INTEGER IWCB( LIWCB ) INTEGER IW( LIW ) COMPLEX(kind=8) WCB( LWCB ), A( LA ) INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)) LOGICAL FLAG INTEGER LRHSINTR, POSINRHSINTR_FWD(N) COMPLEX(kind=8) RHSINTR(LRHSINTR,NRHS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGSOU, MSGTAG, MSGLEN FLAG = .FALSE. IF ( BLOQ ) THEN FLAG = .FALSE. CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF ( FLAG ) THEN KEEP(266) = KEEP(266) -1 MSGSOU = STATUS( MPI_SOURCE ) MSGTAG = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN INFO(1) = -20 INFO(2) = MSGLEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ELSE CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, & MSGSOU, MSGTAG, COMM, STATUS, IERR ) CALL ZMUMPS_TRAITER_MESSAGE_SOLVE( BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) END IF END IF RETURN END SUBROUTINE ZMUMPS_SOLVE_RECV_AND_TREAT SUBROUTINE ZMUMPS_RHSINTR_TO_WCB( & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL, & RHSINTR, LRHSINTR, NRHS_B, & POSINRHSINTR_FWD, N, & WCB, & IW, LIW, J1, J3, J2, KEEP, DKEEP) IMPLICIT NONE INTEGER, INTENT( IN ) :: NPIV, NCB, LIELL, N, & LRHSINTR, NRHS_B, & LIW, J1, J2, J3 LOGICAL, INTENT( IN ) :: LDEQLIELLPANEL LOGICAL, INTENT( IN ) :: CBINITZERO INTEGER, INTENT( IN ) :: POSINRHSINTR_FWD( N ), IW( LIW ) COMPLEX(kind=8), INTENT( INOUT ) :: RHSINTR( LRHSINTR, NRHS_B ) COMPLEX(kind=8), INTENT( OUT ) :: WCB( int(LIELL,8)* & int(NRHS_B,8) ) INTEGER :: KEEP(500) DOUBLE PRECISION :: DKEEP(150) INTEGER, PARAMETER :: ZERO = (0.0D0,0.0D0) INTEGER(8), PARAMETER :: PPIV_COURANT = 1_8 INTEGER(8) :: PCB_COURANT INTEGER :: LD_WCBCB, LD_WCBPIV, J, JJ, K, IPOSINRHSINTR INTEGER(8) :: IFR8, IFR_ini8 INCLUDE 'mpif.h' LOGICAL :: OMP_FLAG IF ( LDEQLIELLPANEL ) THEN LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV ELSE LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + NPIV * NRHS_B ENDIF IF ( LDEQLIELLPANEL ) THEN DO K=1, NRHS_B IFR8 = PPIV_COURANT+int(K-1,8)*int(LD_WCBPIV,8)-1_8 IPOSINRHSINTR = POSINRHSINTR_FWD(IW(J1)) DO JJ = J1, J3 IFR8 = IFR8 + 1_8 WCB(IFR8) = RHSINTR(IPOSINRHSINTR,K) IPOSINRHSINTR = IPOSINRHSINTR + 1 ENDDO IF (NCB.GT.0 .AND. .NOT. CBINITZERO) THEN #if defined(__ve__) !NEC$ IVDEP #endif DO JJ = J3+1, J2 J = IW(JJ) IFR8 = IFR8 + 1_8 IPOSINRHSINTR = abs(POSINRHSINTR_FWD(J)) WCB(IFR8) = RHSINTR(IPOSINRHSINTR,K) RHSINTR (IPOSINRHSINTR,K) = ZERO ENDDO ENDIF ENDDO ELSE PCB_COURANT = PPIV_COURANT + LD_WCBPIV*NRHS_B IFR8 = PPIV_COURANT - 1_8 IFR_ini8 = IFR8 IPOSINRHSINTR = POSINRHSINTR_FWD(IW(J1)) OMP_FLAG = .FALSE. !$ OMP_FLAG = ( NRHS_B .GE. KEEP(362) .AND. !$ & int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(JJ,IFR8) DO K=1, NRHS_B IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 WCB(IFR8+int(JJ-J1+1,8)) = & RHSINTR(IPOSINRHSINTR+JJ-J1,K) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K=1, NRHS_B IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 WCB(IFR8+int(JJ-J1+1,8)) = & RHSINTR(IPOSINRHSINTR+JJ-J1,K) ENDDO ENDDO ENDIF IFR8 = PCB_COURANT - 1_8 IF (NCB.GT.0 .AND. .NOT. CBINITZERO) THEN IFR_ini8 = IFR8 OMP_FLAG = .FALSE. !$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND. !$ & NCB*NRHS_B .GE. KEEP(363) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE (IFR8, JJ, J, IPOSINRHSINTR) DO K=1, NRHS_B IFR8 = IFR_ini8+(K-1)*NCB #if defined(__ve__) !NEC$ IVDEP #endif DO JJ = J3 + 1, J2 J = IW(JJ) IPOSINRHSINTR = abs(POSINRHSINTR_FWD(J)) WCB(IFR8+int(JJ-J3,8)) = RHSINTR(IPOSINRHSINTR,K) RHSINTR(IPOSINRHSINTR,K)=ZERO ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K=1, NRHS_B IFR8 = IFR_ini8+(K-1)*NCB #if defined(__ve__) !NEC$ IVDEP #endif DO JJ = J3 + 1, J2 J = IW(JJ) IPOSINRHSINTR = abs(POSINRHSINTR_FWD(J)) WCB(IFR8+int(JJ-J3,8)) = RHSINTR(IPOSINRHSINTR,K) RHSINTR(IPOSINRHSINTR,K)=ZERO ENDDO ENDDO ENDIF ENDIF ENDIF IF ( CBINITZERO ) THEN OMP_FLAG = .FALSE. !$ OMP_FLAG = int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) IF (OMP_FLAG) THEN !$OMP PARALLEL DO COLLAPSE(2) DO K = 1, NRHS_B DO JJ = 1, NCB WCB(PCB_COURANT+int(K-1,8)*int(LD_WCBCB,8)+JJ-1_8) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K = 1, NRHS_B DO JJ = 1, NCB WCB(PCB_COURANT+int(K-1,8)*int(LD_WCBCB,8)+JJ-1_8) = ZERO ENDDO ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_RHSINTR_TO_WCB MUMPS_5.8.1/src/sfac_process_root2slave.F0000664000175000017500000003262415042446437020206 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, & TOT_CONT_TO_RECV, root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND) USE MUMPS_LOAD USE SMUMPS_OOC USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER TOT_ROOT_SIZE, TOT_CONT_TO_RECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER ND( KEEP(28) ) INTEGER IFLAG, IERROR, COMM, COMM_LOAD INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER INTARR(KEEP8(27)) REAL DBLARR(KEEP8(26)) INTEGER :: allocok REAL, DIMENSION(:,:), POINTER :: TMP INTEGER NEW_LOCAL_M, NEW_LOCAL_N INTEGER OLD_LOCAL_M, OLD_LOCAL_N INTEGER I, J INTEGER LREQI, IROOT INTEGER(8) :: LREQA INTEGER POSHEAD, IPOS_SON,IERR LOGICAL MASTER_OF_ROOT, NO_OLD_ROOT REAL ZERO PARAMETER( ZERO = 0.0E0 ) INCLUDE 'mumps_headers.h' INTEGER MUMPS_NUMROC, MUMPS_PROCNODE EXTERNAL MUMPS_NUMROC, MUMPS_PROCNODE IROOT = KEEP( 38 ) root%TOT_ROOT_SIZE = TOT_ROOT_SIZE MASTER_OF_ROOT = ( MYID .EQ. & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), & KEEP(199) ) ) NEW_LOCAL_M = MUMPS_NUMROC( TOT_ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) NEW_LOCAL_M = max( 1, NEW_LOCAL_M ) NEW_LOCAL_N = MUMPS_NUMROC( TOT_ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) IF ( PTRIST(STEP( IROOT )).GT.0) THEN OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) ELSE OLD_LOCAL_N = 0 OLD_LOCAL_M = NEW_LOCAL_M ENDIF IF (PTRIST(STEP(IROOT)) .EQ.0) THEN NO_OLD_ROOT = .TRUE. ELSE NO_OLD_ROOT =.FALSE. ENDIF IF (KEEP(60) .NE. 0) THEN IF ( MASTER_OF_ROOT ) THEN LREQI=6+2*TOT_ROOT_SIZE+KEEP(IXSZ) LREQA=0_8 IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN CALL SMUMPS_COMPRE_NEW( N, KEEP, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ),COMP,DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA-LRLUS, IERROR) GOTO 700 END IF ENDIF IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB GOTO 700 ENDIF PTLUST(STEP(IROOT))= IWPOS IWPOS = IWPOS + LREQI POSHEAD = PTLUST( STEP(IROOT)) IW( POSHEAD + XXI )=LREQI CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR) ) CALL MUMPS_STOREI8( 0_8, IW(POSHEAD + XXD) ) IW( POSHEAD + XXS )=-9999 IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 IW( POSHEAD +KEEP(IXSZ)) = 0 IW( POSHEAD + 1 +KEEP(IXSZ)) = -1 IW( POSHEAD + 2 +KEEP(IXSZ)) = -1 IW( POSHEAD + 4 +KEEP(IXSZ)) = STEP(IROOT) IW( POSHEAD + 5 +KEEP(IXSZ)) = 0 IW( POSHEAD + 3 +KEEP(IXSZ)) = TOT_ROOT_SIZE ELSE PTLUST(STEP(IROOT)) = -4444 ENDIF PTRIST(STEP(IROOT)) = 0 PTRFAC(STEP(IROOT)) = -4445_8 IF (root%yes .and. NO_OLD_ROOT) THEN IF (NEW_LOCAL_N .GT. 0) THEN CALL SMUMPS_SET_TO_ZERO(roota%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC, & KEEP) IF (KEEP(55).EQ.0) THEN CALL SMUMPS_ASM_ARR_ROOT( N, root, roota, & IROOT, STEP(IROOT), & roota%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC, & root%SCHUR_NLOC, FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL SMUMPS_ASM_ELT_ROOT(N, root, roota, & roota%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC, & root%SCHUR_NLOC, LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF ENDIF ENDIF ELSE IF ( MASTER_OF_ROOT ) THEN LREQI = 6 + 2 * TOT_ROOT_SIZE+KEEP(IXSZ) ELSE LREQI = 6+KEEP(IXSZ) END IF LREQA = int(NEW_LOCAL_M, 8) * int(NEW_LOCAL_N, 8) CALL SMUMPS_GET_SIZE_NEEDED( & LREQI , LREQA, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 700 PTLUST(STEP( IROOT )) = IWPOS IWPOS = IWPOS + LREQI IF (LREQA.EQ.0_8) THEN PTRAST (STEP(IROOT)) = POSFAC PTRFAC (STEP(IROOT)) = POSFAC ELSE PTRAST (STEP(IROOT)) = POSFAC PTRFAC (STEP(IROOT)) = POSFAC ENDIF POSFAC = POSFAC + LREQA LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA KEEP8(67) = min(KEEP8(67), LRLUS) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) POSHEAD = PTLUST( STEP(IROOT)) IW( POSHEAD + XXI ) = LREQI CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR)) CALL MUMPS_STOREI8( 0_8, IW(POSHEAD + XXD)) IW( POSHEAD + XXS ) = S_NOTFREE IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 IW( POSHEAD + KEEP(IXSZ) ) = 0 IW( POSHEAD + 1 + KEEP(IXSZ) ) = NEW_LOCAL_N IW( POSHEAD + 2 + KEEP(IXSZ) ) = NEW_LOCAL_M IW( POSHEAD + 4 + KEEP(IXSZ) ) = STEP(IROOT) IW( POSHEAD + 5 + KEEP(IXSZ) ) = 0 IF ( MASTER_OF_ROOT ) THEN IW( POSHEAD + 3 + KEEP(IXSZ) ) = TOT_ROOT_SIZE ELSE IW( POSHEAD + 3 + KEEP(IXSZ) ) = 0 ENDIF IF ( PTRIST(STEP(IROOT)) .EQ. 0) THEN CALL SMUMPS_SET_TO_ZERO(A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, KEEP) IF (KEEP(55) .EQ.0 ) THEN CALL SMUMPS_ASM_ARR_ROOT( N, root, roota, & IROOT, STEP(IROOT), & A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, & FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL SMUMPS_ASM_ELT_ROOT( N, root, roota, & A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF PAMASTER(STEP(IROOT)) = 0_8 ELSE IF ( PTRIST(STEP(IROOT)) .LT. 0 ) THEN CALL SMUMPS_SET_TO_ZERO(A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, KEEP) ELSE OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) IF ( TOT_ROOT_SIZE .eq. root%ROOT_SIZE ) THEN IF ( LREQA .NE. int(OLD_LOCAL_M,8) * int(OLD_LOCAL_N,8) ) & THEN write(*,*) 'error 1 in PROCESS_ROOT2SLAVE', & OLD_LOCAL_M, OLD_LOCAL_N CALL MUMPS_ABORT() END IF CALL SMUMPS_COPYI8SIZE(LREQA, & A( PAMASTER(STEP(IROOT)) ), & A( PTRAST (STEP(IROOT)) ) ) ELSE CALL SMUMPS_COPY_ROOT( A( PTRAST(STEP(IROOT))), & NEW_LOCAL_M, & NEW_LOCAL_N, A( PAMASTER( STEP(IROOT)) ), OLD_LOCAL_M, & OLD_LOCAL_N ) END IF IF ( PTRIST( STEP( IROOT ) ) .GT. 0 ) THEN IPOS_SON= PTRIST( STEP(IROOT)) CALL SMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., & MYID, N, IPOS_SON, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) END IF ENDIF PTRIST(STEP( IROOT )) = 0 PAMASTER(STEP( IROOT )) = 0_8 ENDIF IF ( NO_OLD_ROOT ) THEN IF (KEEP(253) .GT.0) THEN root%RHS_NLOC = MUMPS_NUMROC( KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) root%RHS_NLOC = max( root%RHS_NLOC, 1 ) ELSE root%RHS_NLOC = 1 ENDIF IF (associated(roota%RHS_ROOT)) DEALLOCATE(roota%RHS_ROOT) ALLOCATE(roota%RHS_ROOT(NEW_LOCAL_M, root%RHS_NLOC), & stat=allocok) IF ( allocok.GT.0 ) THEN IFLAG = -13 IERROR = NEW_LOCAL_N * root%RHS_NLOC GOTO 700 ENDIF IF (KEEP(253) .NE. 0) THEN roota%RHS_ROOT=ZERO CALL SMUMPS_ASM_RHS_ROOT( N, FILS, root, roota, KEEP, KEEP8, & RHS_MUMPS, IFLAG, IERROR ) ENDIF ELSE IF (NEW_LOCAL_M.GT.OLD_LOCAL_M .AND. KEEP(253) .GT.0) THEN TMP => roota%RHS_ROOT NULLIFY(roota%RHS_ROOT) ALLOCATE (roota%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 roota%RHS_ROOT(I,J)=TMP(I,J) ENDDO DO I = OLD_LOCAL_M+1, NEW_LOCAL_M roota%RHS_ROOT(I,J) = ZERO ENDDO ENDDO DEALLOCATE(TMP) NULLIFY(TMP) ENDIF KEEP(121) = KEEP(121) + TOT_CONT_TO_RECV IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL SMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL SMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL SMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT + N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN 700 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE SMUMPS_PROCESS_ROOT2SLAVE SUBROUTINE SMUMPS_COPY_ROOT &( NEW, M_NEW, N_NEW,OLD, M_OLD, N_OLD ) INTEGER M_NEW, N_NEW, M_OLD, N_OLD REAL NEW( M_NEW, N_NEW ), OLD( M_OLD, N_OLD ) INTEGER J REAL ZERO PARAMETER( ZERO = 0.0E0 ) DO J = 1, N_OLD NEW( 1: M_OLD, J ) = OLD( 1: M_OLD, J ) NEW( M_OLD + 1: M_NEW, J ) = ZERO END DO NEW( 1: M_NEW,N_OLD + 1: N_NEW ) = ZERO RETURN END SUBROUTINE SMUMPS_COPY_ROOT MUMPS_5.8.1/src/mumps_addr.h0000664000175000017500000000273615042446422015544 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_ADDR_H #define MUMPS_ADDR_H #include "mumps_common.h" #include "mumps_c_types.h" #define MUMPS_INT_SIZE_C \ F_SYMBOL(int_size_c, INT_SIZE_C) void MUMPS_CALL MUMPS_INT_SIZE_C(MUMPS_INT8 *i); #define MUMPS_SIZE_C \ F_SYMBOL(size_c, SIZE_C) void MUMPS_CALL MUMPS_SIZE_C(char *a, char *b, MUMPS_INT8 *diff); #define MUMPS_ADDR_C \ F_SYMBOL(addr_c, ADDR_C) void MUMPS_CALL MUMPS_ADDR_C(char *a, MUMPS_INT8 *addr); #define MUMPS_GETVAL_ADDR_C \ F_SYMBOL(getval_addr_c, GETVAL_ADDR_C) void MUMPS_CALL MUMPS_GETVAL_AT_ADDR_C(volatile MUMPS_INT *val, MUMPS_INT8 *addr); #define MUMPS_SETRVAL_ADDR_C \ F_SYMBOL(setrval_addr_c, SETRVAL_ADDR_C) void MUMPS_CALL MUMPS_SETRVAL_ADDR_C(SMUMPS_REAL *val, MUMPS_INT8 *addr); #define MUMPS_SETDVAL_ADDR_C \ F_SYMBOL(setdval_addr_c, SETDVAL_ADDR_C) void MUMPS_CALL MUMPS_SETDVAL_ADDR_C(DMUMPS_REAL *val, MUMPS_INT8 *addr); #define MUMPS_CLANGAOCC_C \ F_SYMBOL(clangaocc_c, CLANGAOCC_C) void MUMPS_CALL MUMPS_CLANGAOCC_C(MUMPS_INT8 *i8); #endif MUMPS_5.8.1/src/cana_driver.F0000664000175000017500000057116715042446441015636 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C SUBROUTINE CMUMPS_ANA_DRIVER(id,idintr) USE MUMPS_STATIC_MAPPING USE CMUMPS_STRUC_DEF USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_INTR_STRUC USE MUMPS_MEMORY_MOD USE CMUMPS_PARALLEL_ANALYSIS USE CMUMPS_ANA_LR USE CMUMPS_LR_CORE USE MUMPS_LR_STATS USE MUMPS_LR_COMMON USE CMUMPS_ANA_AUX_M USE MUMPS_ANA_BLK_M, ONLY: COMPACT_GRAPH_T, LMATRIX_T IMPLICIT NONE INTERFACE C Explicit interfaces when id has the TARGET attribute SUBROUTINE CMUMPS_ANA_ARROWHEADS_WRAPPER & (id, GATHER_MATRIX_ALLOCATED) USE CMUMPS_STRUC_DEF TYPE (CMUMPS_STRUC), TARGET :: id LOGICAL, INTENT(INOUT) :: GATHER_MATRIX_ALLOCATED END SUBROUTINE CMUMPS_ANA_ARROWHEADS_WRAPPER SUBROUTINE CMUMPS_ANA_COMPUTE_ESTIMATES (id, idintr) USE CMUMPS_STRUC_DEF USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_INTR_STRUC TYPE (CMUMPS_STRUC), TARGET :: id TYPE (CMUMPS_INTR_STRUC) :: idintr END SUBROUTINE CMUMPS_ANA_COMPUTE_ESTIMATES END INTERFACE C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) C C Purpose C ======= C C Performs analysis and (if required) Max-trans on the master, then C broadcasts information to the slaves. Also includes mapping. C C C Parameters C ========== C TYPE(CMUMPS_STRUC), TARGET :: id TYPE(CMUMPS_INTR_STRUC) :: idintr C C Local variables C =============== C C C Pointers inside integer array IKEEPALLOC, various data INTEGER(8) IKEEP, NE, NA INTEGER I, allocok C Other locals INTEGER NB_NIV2, IDEST INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MP, LP, MPG LOGICAL PROK, PROKG, LISTVAR_SCHUR_2BE_FREED, LPOK INTEGER SIZE_SCHUR_PASSED INTEGER LEAF, INODE, ISTEP, INN, LPTRAR INTEGER NBLEAF, NBROOT, MYROW_CHECK, INIV2 DOUBLE PRECISION TIMEG REAL :: PEAK C C Related to commuicators for parallel analysis: C COMM_PARAORD: communicator on which Parmetis/PTscotch C is performed C COMM_PARASYMB: communicator on which parallel symbolic C facto is performed C PARAORD_to_idCOMM (1:NPROCS_PARAORD) is such that C PARAORD_to_idCOMM(idPARAORD+1)=idCOMM, C where idPARAORD \in [0:NPROCS_PARAORD] C RKinSYMB_PROC0ORD: Rank in COMM_PARASYMB of proc 0 in C COMM_PARAORD C RKinidCOMM_PROC0SYMB: Rank in id%COMM of proc 0 in C COMM_PARASYMB C INTEGER :: COMM_PARAORD, NPROCS_PARAORD, RKinSYMB_PROC0ORD, & OPTION_COMM_PARAORD INTEGER :: COMM_PARASYMB, NPROCS_PARASYMB, & RKinidCOMM_PROC0SYMB LOGICAL :: COMM_PARAORD_ALLOCATED, COMM_PARASYMB_ALLOCATED INTEGER, ALLOCATABLE, DIMENSION(:) :: PARAORD_to_idCOMM #if defined(AVOID_MPI_IN_PLACE) INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP #endif C C INTEGER WORKSPACE C INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: PAR2_NODES INTEGER, DIMENSION(:), POINTER :: PAR2_NODESPTR INTEGER, ALLOCATABLE, DIMENSION(:) :: PROCNODE INTEGER, DIMENSION(:), ALLOCATABLE :: IWtemp INTEGER, DIMENSION(:), ALLOCATABLE :: XNODEL, NODEL INTEGER, DIMENSION(:), POINTER :: SSARBR C Element matrix entry INTEGER, POINTER :: NELT, LELTVAR INTEGER, DIMENSION(:), POINTER :: KEEP, INFO, INFOG INTEGER(8), DIMENSION(:), POINTER :: KEEP8 REAL, DIMENSION(:), POINTER :: RINFO REAL, DIMENSION(:), POINTER :: RINFOG INTEGER, DIMENSION(:), POINTER :: ICNTL LOGICAL :: I_AM_SLAVE, COND INTEGER, TARGET :: IDUMMY_ARRAY(1) INTEGER(8) :: NNZ_loc, NNZ_TMP INTEGER, POINTER, DIMENSION(:) :: IRN_loc_PTR INTEGER, POINTER, DIMENSION(:) :: JCN_loc_PTR INTEGER, POINTER, DIMENSION(:) :: IRN_PTR INTEGER, POINTER, DIMENSION(:) :: JCN_PTR INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR INTEGER, POINTER, DIMENSION(:) :: UNS_PERM_PTR !$ INTEGER :: NOMPMAX INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER, EXTERNAL :: MUMPS_ENCODE_TPN_IPROC INTEGER :: PROCNODE_VALUE INTEGER K,J, IFS INTEGER SIZE_TEMP_MEM,SIZE_DEPTH_FIRST,SIZE_COST_TRAV LOGICAL IS_BUILD_LOAD_MEM_CALLED LOGICAL PRINT_MAXAVG LOGICAL :: PRINT_NODEINFO 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 :: SIZE_PAR2_NODESPTR INTEGER :: LSIZEOFBLOCKS_PTR LOGICAL :: READY_FOR_ANA_F INTEGER, ALLOCATABLE, DIMENSION(:) :: MAPCOL LOGICAL :: BLKPTR_ALLOCATED, BLKVAR_ALLOCATED INTEGER, POINTER, DIMENSION(:) :: BLKPTR_PTRLOC, BLKVAR_PTRLOC INTEGER :: IB, BLKSIZE INTEGER :: IBcurrent, IPOS, IPOSB, II C Internal work arrays: C DOF2BLOCK(idof)=inode, idof in [1,N], inode in [1,NBLK] C SIZEBLOCK(1:NBLK) (for node valuation) INTEGER, TARGET, DIMENSION(:), allocatable:: SIZEOFBLOCKS INTEGER, DIMENSION(:), allocatable:: DOF2BLOCK INTEGER :: NBRECORDS INTEGER(8) :: NSEND8, NLOCAL8, IDUMMY8 C LMAT_BLOCK: in case of centralized matrix, C to store on MASTER the cleaned Lmatrix C used to compute GCOMP C LMAT_BLOCK might also be saved to C be used during grouping C LUMAT : in case of distributed matrix C to store distributed the cleaned LU matrix C LUMAT might also be saved to C be used for MPI based grouping C LUMAT_REMAP : in case of distributed matrix C it is used to remap LUMAT C C GCOMP : Graph "ready" to be called by orderings C INTEGER(8) :: MEMCNT TYPE(LMATRIX_T) :: LMAT_BLOCK, LUMAT, LUMAT_REMAP INTEGER :: LMAT_BLOCK_AVAIL_I LOGICAL :: GCOMP_PROVIDED, & LUMAT_AVAIL, LMAT_BLOCK_AVAIL LOGICAL :: LUMAT_REMAP_DIST_AVAIL, & LUMAT_REMAP_CENT_AVAIL TYPE(COMPACT_GRAPH_T) :: GCOMP TYPE(COMPACT_GRAPH_T) :: GCOMP_DIST INTEGER(4) :: I4 INTEGER, POINTER, DIMENSION(:) :: & NFSIZPTR, & FREREPTR, & IKEEP1, IKEEP2, IKEEP3 #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: FILS_TMPPTR #endif INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: FILS_TMP INTEGER, ALLOCATABLE, DIMENSION(:) :: STEP_TMP, & LRGROUPS_TMP INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: IKEEPALLOC INTEGER, ALLOCATABLE, DIMENSION(:) :: WORK2ALLOC INTEGER :: SIZELRGROUPS_TMP INTEGER(8) :: SIZEIKEEPALLOC, SIZEWORK2ALLOC INTEGER(kind=8) :: NZ8, LIW8 C NBLK : id%N or order of blocked matrix INTEGER :: NBLK, idNBLKSAVE INTEGER(8) :: LIW8_ELT C GATHER_MATRIX_ALLOCATED: C To be sure that id%IRN and id%JCN are C deallocated only when CMUMPS_GATHER_MATRIX was called LOGICAL :: GATHER_MATRIX_ALLOCATED C C Beginning of executable statements C C CMUMPS_FREE_DATA_ANAFACSOL was called in CMUMPS_DRIVER C to reduce the memory peak during analysis, especially C when computing the graph associated to the input matrix. IS_BUILD_LOAD_MEM_CALLED=.FALSE. KEEP => id%KEEP KEEP8 => id%KEEP8 INFO => id%INFO RINFO => id%RINFO INFOG => id%INFOG RINFOG => id%RINFOG ICNTL => id%ICNTL NELT => id%NELT LELTVAR => id%LELTVAR KEEP(264) = 0 ! reinitialise out-of-range status (0=yes) KEEP(265) = 0 ! reinitialise dupplicates (0=yes) KEEP(280) = 0 ! size of id%LRGROUPS PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) C FIXME: count memory used during analysis MEMCNT = 0_8 C Print per node information only in case there are several C compute nodes (id%KEEP(412): #MPI procs on compute node) PRINT_NODEINFO = PRINT_MAXAVG .AND. id%NPROCS .NE. id%KEEP(412) GATHER_MATRIX_ALLOCATED = .FALSE. COMM_PARAORD = MPI_COMM_NULL COMM_PARASYMB = id%COMM COMM_PARAORD_ALLOCATED = .FALSE. COMM_PARASYMB_ALLOCATED = .FALSE. RKinidCOMM_PROC0SYMB = MASTER NULLIFY ( NFSIZPTR, FREREPTR, & IKEEP1, IKEEP2, IKEEP3, & SSARBR, SIZEOFBLOCKS_PTR, IRN_loc_PTR, JCN_loc_PTR, & IRN_PTR, JCN_PTR, & PAR2_NODESPTR, BLKPTR_PTRLOC, BLKVAR_PTRLOC) IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM) nullify(id%UNS_PERM) C Set default value that witl be reset in C case of blocked format matrices NBLK = id%N GCOMP_PROVIDED = .FALSE. BLKPTR_ALLOCATED = .FALSE. BLKVAR_ALLOCATED = .FALSE. LUMAT_AVAIL = .FALSE. LMAT_BLOCK_AVAIL = .FALSE. C ------------------------------------- C Depending on the type of parallelism, C the master can now (soon) potentially C have the role of a slave C ------------------------------------- I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(ICNTL(4).GE.2)) IF ( PROK ) THEN IF ( KEEP(50) .eq. 0 ) THEN WRITE(MP, '(A)') 'L U Solver for unsymmetric matrices' ELSE IF ( KEEP(50) .eq. 1 ) THEN WRITE(MP, '(A)') & 'L D L^T Solver for symmetric positive definite matrices' ELSE WRITE(MP, '(A)') & 'L D L^T Solver for general symmetric matrices' END IF IF ( KEEP(46) .eq. 1 ) THEN WRITE(MP, '(A)') 'Type of parallelism: Working host' ELSE WRITE(MP, '(A)') 'Type of parallelism: Host not working' END IF END IF IF ( PROKG .AND. (MP.NE.MPG)) THEN IF ( KEEP(50) .eq. 0 ) THEN WRITE(MPG, '(A)') 'L U Solver for unsymmetric matrices' ELSE IF ( KEEP(50) .eq. 1 ) THEN WRITE(MPG, '(A)') & 'L D L^T Solver for symmetric positive definite matrices' ELSE WRITE(MPG, '(A)') & 'L D L^T Solver for general symmetric matrices' END IF IF ( KEEP(46) .eq. 1 ) THEN WRITE(MPG, '(A)') 'Type of parallelism: Working host' ELSE WRITE(MPG, '(A)') 'Type of parallelism: Host not working' END IF END IF IF (PROK) WRITE( MP, 110 ) IF (PROKG .AND. (MPG.NE.MP)) WRITE( MPG, 110 ) C Reinitialize last used size of WK_USER C --------------------------------------- KEEP8(24) = 0_8 C C C C Decode API (ICNTL parameters, mainly) C and check consistency of the KEEP array. C Note: CMUMPS_ANA_CHECK_KEEP also sets C some INFOG parameters CALL CMUMPS_ANA_CHECK_KEEP(id, I_AM_SLAVE) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C ------------------------------------------- C Broadcast KEEP(60) since we need to broadcast C related information C ------------------------------------------ CALL MPI_BCAST( KEEP(60), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C broadcast also size of schur IF (id%KEEP(60) .NE. 0 ) THEN CALL MPI_BCAST( KEEP(116), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF IF (id%KEEP(60) .EQ. 2 .or. id%KEEP(60). EQ. 3) THEN CALL MPI_BCAST( id%NPROW, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NPCOL, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%MBLOCK, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NBLOCK, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) C Note that CMUMPS_INIT_ROOT_ANA will C then use that information. ENDIF C ---------------------------------------------- C Broadcast KEEP(54) now to know if the C structure of the graph is intially distributed C and should be assembled on the master C Broadcast KEEP(55) now to know if the C matrix is in assembled or elemental format C ---------------------------------------------- CALL MPI_BCAST( KEEP(54), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast KEEP(69) now to know if C we will need to communicate during analysis C ---------------------------------------------- CALL MPI_BCAST( KEEP(69), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast Out of core strategy (used only on master so far) C Boradcast KEEP(201), KEEP(202) and KEEP(203) C ---------------------------------------------- CALL MPI_BCAST( KEEP(201), 3, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast analysis strategy (used only on master so far) C ---------------------------------------------- CALL MPI_BCAST( KEEP(244), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) IF (KEEP(244).NE.1) THEN C broadcast parallel ordering strategy used CALL MPI_BCAST( KEEP(245), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF C --------------------------- C Fwd in facto C Broadcast KEEP(251,252,253) defined on master so far CALL MPI_BCAST( KEEP(251), 3, MPI_INTEGER,MASTER,id%COMM,IERR) C CALL MPI_BCAST( KEEP(401), 1, MPI_INTEGER,MASTER,id%COMM,IERR) id%KEEP(400) = 0 id%KEEP(369) = id%KEEP(368) !$ IF (id%KEEP(401).GT.0) THEN !$ id%KEEP(400) = omp_get_max_threads() C => id%KEEP(400)>=1 C C IF KEEP(400)<=1 on all procs switch off L0 thread: !$ CALL MPI_ALLREDUCE(id%KEEP(400),NOMPMAX,1,MPI_INTEGER, !$ & MPI_MAX,id%COMM,IERR) !$ IF (NOMPMAX.LE.1) THEN !$ id%KEEP(400) = 0 !$ id%KEEP(401) = 0 !$ ENDIF !$ ENDIF !$ IF (id%KEEP(400).GT.0 .AND. id%KEEP(401).GT.0 !$ & .AND. id%KEEP(369).GT.0) THEN C reset id%KEEP(400) to value provided by user !$ id%KEEP(400) = min(id%KEEP(400),id%KEEP(369)) !$ ENDIF CALL MPI_BCAST( id%KEEP(490), 5, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( KEEP(123),1,MPI_INTEGER,MASTER,id%COMM,IERR) C ---------------------------------------------- C Broadcast N C ---------------------------------------------- CALL MPI_BCAST( id%N, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast NZ for assembled entry C ---------------------------------------------- IF ( KEEP(55) .EQ. 0) THEN IF ( KEEP(54) .eq. 3 ) THEN C Reset to 0 id%KEEP8(29) for host not working, since C value provided by user might be undefined IF (.NOT.I_AM_SLAVE) id%KEEP8(29)= 0_8 C Compute total number of non-zeros CALL MPI_ALLREDUCE( id%KEEP8(29), id%KEEP8(28), 1, & MPI_INTEGER8, & MPI_SUM, id%COMM, IERR ) C Local number of non-zeros cannot be negative IF (id%KEEP8(29) .LT. 0_8) THEN id%INFO(1) = -2 CALL MUMPS_SET_IERROR(id%KEEP8(29), id%INFO(2)) ENDIF ELSE C Broadcast NZ from the master node CALL MPI_BCAST( id%KEEP8(28), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) END IF C Total number of non zeros must be positive strictly IF (id%KEEP8(28) .LE. 0_8) THEN id%INFO(1) = -2 CALL MUMPS_SET_IERROR(id%KEEP8(28), id%INFO(2)) ENDIF ELSE C Broadcast NA_ELT <=> KEEP8(30) for elemental entry CALL MPI_BCAST( id%KEEP8(30), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) ENDIF IF( id%KEEP(54).EQ.3) THEN C test IRN_loc and JCN_loc allocated on working procs IF (I_AM_SLAVE .AND. id%KEEP8(29).GT.0 .AND. & ( (.NOT. associated(id%IRN_loc)) .OR. & (.NOT. associated(id%JCN_loc)) ) & ) THEN id%INFO(1) = -22 id%INFO(2) = 16 ENDIF ENDIF IF ( associated(id%MEM_DIST) ) THEN DEALLOCATE( id%MEM_DIST ) ENDIF allocate( id%MEM_DIST( 0:id%NSLAVES-1 ), STAT=IERR ) IF ( IERR .GT. 0 ) THEN INFO(1) = -7 INFO(2) = id%NSLAVES IF ( LPOK ) THEN WRITE(LP, 150) 'MEM_DIST' END IF END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 id%MEM_DIST(0:id%NSLAVES-1) = 0 CALL MUMPS_INIT_ARCH_PARAMETERS( & id%COMM,id%COMM_NODES,KEEP(69),KEEP(46), & id%NSLAVES,id%MEM_DIST,INFO ) C ======================== C Write problem to a file, C if requested by the user C ======================== CALL CMUMPS_DUMP_PROBLEM(id) IF ( id%INFO(1) .LT. 0 ) GOTO 500 C ================= C ANALYSIS BY BLOCK C ================= IF ( id%MYID .EQ. MASTER ) THEN IF (KEEP(13).EQ.1) THEN NBLK=id%NBLK ELSE IF (KEEP(13).LT.0) THEN C regular blocks in BLKVAR of size -KEEP(13) C mod(id%N,-KEEP(13)) has already been checked NBLK = id%N/(-KEEP(13)) ENDIF C end of id%MYID .EQ. MASTER ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 500 C C Broadcast KEEP(13-14), NBLK CALL MPI_BCAST( KEEP(13), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( NBLK, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C C =========================== IF (KEEP(13).NE.0) THEN C { BEGIN preparation ANA_BLK C =========================== IF ( & ( KEEP(244).NE.1) & .OR. ( (KEEP(54).NE.3).AND.(id%MYID.EQ.MASTER) ) & .OR. (KEEP(54).EQ.3) ) THEN C{ C ---------------------------------------- C Allocate SIZEOFBLOCKS, DOF2BLOCK C ---------------------------------------- IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) allocate(SIZEOFBLOCKS(NBLK), DOF2BLOCK(id%N), & STAT=allocok) C IF (allocok.NE.0) THEN id%INFO( 1 ) = -7 id%INFO( 2 ) = id%N+NBLK IF ( LPOK ) WRITE(LP, 150) ' SIZEOFBLOCKS, DOF2BLOCK' ENDIF C IF ( (allocok.EQ.0) .AND. (id%MYID.EQ.MASTER)) THEN C{ BLKPTR and BLKVAR needed for CMUMPS_EXPAND_TREE C allocate then if not associated IF (.NOT.associated(id%BLKPTR).OR.KEEP(13).LT.0) THEN BLKPTR_ALLOCATED = .TRUE. C allocate(id%BLKPTR(NBLK+1), STAT=allocok) allocate(BLKPTR_PTRLOC(NBLK+1), STAT=allocok) IF (allocok.NE.0) THEN BLKPTR_ALLOCATED = .FALSE. id%INFO( 1 ) = -7 id%INFO( 2 ) = NBLK+1 IF ( LPOK ) WRITE(LP, 150) ' id%BLKPTR ' ENDIF ELSE BLKPTR_PTRLOC=>id%BLKPTR ENDIF IF (allocok.EQ.0) THEN IF (.NOT.associated(id%BLKVAR).OR.KEEP(13).LT.0) THEN allocate(BLKVAR_PTRLOC(id%N), STAT=allocok) BLKVAR_ALLOCATED = .TRUE. IF (allocok.NE.0) THEN BLKVAR_ALLOCATED = .FALSE. id%INFO( 1 ) = -7 id%INFO( 2 ) = id%N IF ( LPOK ) WRITE(LP, 150) ' id%BLKVAR ' ENDIF ELSE BLKVAR_PTRLOC => id%BLKVAR ENDIF ENDIF C} ENDIF C} ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 500 IF ( id%MYID .EQ. MASTER ) THEN C{ ----------------------------------------- C Compute SIZEOFBLOCKS, DOF2BLOCK on MASTER C based on id%BLKPTR and id%BLKVAR C and compute id%BLKPTR and id%BLKVAR if not C provided by user C ----------------------------------------- IF (BLKVAR_ALLOCATED) THEN C implicitly id%BLKVAR(I)=I DO I=1, id%N BLKVAR_PTRLOC(I)=I ENDDO ENDIF IF (BLKPTR_ALLOCATED) THEN IB=0 BLKSIZE=-KEEP(13) DO I=1, id%N, BLKSIZE IB=IB+1 BLKPTR_PTRLOC(IB) = I ENDDO BLKPTR_PTRLOC(NBLK+1) = id%N+1 ENDIF C CALL MUMPS_AB_COMPUTE_SIZEOFBLOCK ( & NBLK, id%N, BLKPTR_PTRLOC(1), BLKVAR_PTRLOC(1), & SIZEOFBLOCKS, DOF2BLOCK) C} ENDIF C ======================== IF (KEEP(244).NE.1) THEN C{ Parallel analysis C ======================== C KEEP(13).ne.0 only if KEEP(339).NE.0 : IF (KEEP(339).EQ.0) THEN INFO(1) = -901 INFO(2) = KEEP(13) IF ( LPOK ) WRITE(LP, 150) ' Internal error K339' ENDIF NNZ_loc = 0_8 C ----------------------------------------- C Build distributed clean LUMAT matrix C even when matrix is provided centralised C ----------------------------------------- IF (KEEP(54).EQ.3) THEN IF (.NOT. I_AM_SLAVE .OR. ! non-working master & KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc NNZ_loc = KEEP8(29) ENDIF ELSE C Matrix on host IF (id%MYID.EQ.MASTER) THEN C Store input matrix (IRN/JCN) as a cleaned blocked Lmatrix C of nodes (indices \in [1,NBLK]) IF (id%KEEP8(28) .EQ. 0_8) THEN IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ELSE IRN_loc_PTR => id%IRN JCN_loc_PTR => id%JCN NNZ_loc = id%KEEP8(28) ENDIF ELSE IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ENDIF ENDIF C build communicator for parallel ordering C used to distribute LUMAT OPTION_COMM_PARAORD = 0 CALL MUMPS_BUILD_COMM_PARA_ANA ( & OPTION_COMM_PARAORD, id%N, & id%COMM, id%MYID, id%COMM_NODES, id%MYID_NODES, & id%NPROCS, id%NSLAVES, & id%KEEP(1), & COMM_PARAORD, NPROCS_PARAORD, & COMM_PARAORD_ALLOCATED, & COMM_PARASYMB, NPROCS_PARASYMB, & COMM_PARASYMB_ALLOCATED, & id%ICNTL(1), id%INFO(1)) C allocate and initialize PARAORD_to_idCOMM if (allocated(PARAORD_to_idCOMM)) & DEALLOCATE(PARAORD_to_idCOMM) allocate(PARAORD_to_idCOMM(NPROCS_PARAORD), #if defined(AVOID_MPI_IN_PLACE) & TMP(NPROCS_PARAORD), #endif & STAT=allocok) IF (allocok.NE.0) THEN id%INFO( 1 ) = -7 id%INFO( 2 ) = NPROCS_PARAORD #if defined(AVOID_MPI_IN_PLACE) & + NPROCS_PARAORD #endif IF ( LPOK ) WRITE(LP, 150) ' PARAORD_to_idCOMM' ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 500 CALL MUMPS_BUILD_PARAORD_to_idCOMM ( & id%COMM, id%MYID, id%KEEP(1), & COMM_PARASYMB, NPROCS_PARASYMB, & COMM_PARAORD, NPROCS_PARAORD, & PARAORD_to_idCOMM, #if defined(AVOID_MPI_IN_PLACE) & TMP, #endif & RKinSYMB_PROC0ORD, & RKinidCOMM_PROC0SYMB, id%NPROCS ) #if defined(AVOID_MPI_IN_PLACE) DEALLOCATE(TMP) #endif C C C build LUMAT such that col of LUMAT are distributed C only procs in COMM_PARAORD C CALL MUMPS_AB_DCOORD_TO_DLUMAT ( & id%MYID, id%NPROCS, id%COMM, & NPROCS_PARAORD, PARAORD_to_idCOMM, & NBLK, id%N, & NNZ_loc, & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), id%KEEP8(1), & LUMAT) IF (allocated(PARAORD_to_idCOMM)) THEN DEALLOCATE(PARAORD_to_idCOMM) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 LUMAT_AVAIL = .TRUE. C SIZEOFBLOCKS needed on all procs during // analysis CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, & id%COMM, IERR ) C C} End of Parallel analysis ELSE C =================== C{ Sequential analysis C =================== C ======================= IF (KEEP(54).NE.3.OR.id%NPROCS.EQ.1) THEN C ======================= C{ Matrix structure available on host C also case of distributed input matrix format C with one mpi proc C --------------------- KEEP(14) = 0 IF (id%MYID.EQ.MASTER) THEN C Store input matrix (IRN/JCN) as a cleaned blocked Lmatrix C of nodes (indices \in [1,NBLK]) IF (KEEP(54).NE.3) THEN IF (id%KEEP8(28) .EQ. 0_8) THEN IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY ELSE IRN_PTR => id%IRN JCN_PTR => id%JCN ENDIF NNZ_TMP = id%KEEP8(28) ELSE IF (id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY id%KEEP8(29) = 0_8 ELSE IRN_PTR => id%IRN_loc JCN_PTR => id%JCN_loc ENDIF NNZ_TMP = id%KEEP8(29) ENDIF CALL MUMPS_AB_COORD_TO_LMAT ( id%MYID, & NBLK, id%N, NNZ_TMP, IRN_PTR(1), JCN_PTR(1), & DOF2BLOCK, & INFO(1), INFO(2), LP, LPOK, & LMAT_BLOCK, IDUMMY8, KEEP(1) ) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C IF (id%MYID.EQ.MASTER) THEN C From LMAT_BLOCK build GCOMP format wich requires C symmetrizing the Lmatrix CALL MUMPS_AB_LMAT_TO_CLEAN_G ( id%MYID, .TRUE., & .TRUE., ! not relevant because unfold is true & LMAT_BLOCK, GCOMP, & INFO(1), ICNTL(1), MEMCNT) GCOMP_PROVIDED = .TRUE. IF (KEEP(494).EQ.0.OR.KEEP(487).NE.1) THEN CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK, KEEP(147)) LMAT_BLOCK_AVAIL_I = 0 ELSE LMAT_BLOCK_AVAIL_I = 1 ENDIF ENDIF CALL MPI_BCAST( LMAT_BLOCK_AVAIL_I, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) LMAT_BLOCK_AVAIL = (LMAT_BLOCK_AVAIL_I.EQ.1) C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C} C ==== ELSE C ==== C ---------------------- C{ matrix is distributed C ---------------------- IF (.NOT. I_AM_SLAVE .OR. ! non-working master & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY id%KEEP8(29) = 0_8 ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc ENDIF C C Given distributed matrix IRN_loc_PTR, JCN_loc_PTR C build distributed cleaned graph GCOMP and C save distributed LUMAT in case of grouping C IF (id%NPROCS.EQ.1) THEN C Build GCOMP, the centralized final cleaned graph READY_FOR_ANA_F = .TRUE. CALL MUMPS_AB_DCOORD_TO_DCOMPG ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & LUMAT, LUMAT_AVAIL, GCOMP, READY_FOR_ANA_F) GCOMP_PROVIDED = .TRUE. ELSE READY_FOR_ANA_F = .FALSE. CALL MUMPS_AB_DCOORD_TO_DCOMPG ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & LUMAT, LUMAT_AVAIL, GCOMP_DIST, READY_FOR_ANA_F) ENDIF IF (LUMAT_AVAIL.AND.KEEP(487).NE.1) THEN CALL MUMPS_AB_FREE_LMAT(LUMAT, KEEP(147)) LUMAT_AVAIL = .FALSE. ENDIF C C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C C} end matrix structure is distributed C ===== ENDIF C ===== C} end of sequential analysis C ===== ENDIF C ===== IF (allocated(DOF2BLOCK)) THEN C DOF2BLOCK reused on master if pivot order given by user IF ( (id%MYID.NE.MASTER) .OR. & (id%MYID.EQ.MASTER).AND. (KEEP(256) .NE. 1)) THEN DEALLOCATE(DOF2BLOCK) ENDIF ENDIF C ======================== ENDIF C } END preparation ANA_BLK C ========================= C ==================================================== C TEST FOR SEQUENTIAL OR PARALLEL ANALYSIS (KEEP(244)) C ==================================================== IF ( (KEEP(244).EQ.1) .AND. (KEEP(54) .eq. 3) ) THEN C ----------------------------------------------- C Sequential analysis: C Collect on the host -- if matrix is distributed C at analysis -- all integer information needed C to perform ordering C ----------------------------------------------- C FIXME: one should test instead if GCOMP_DIST available C instead of retestinf KEEP(13) and NPROCS.NE.1 IF (KEEP(13).NE.0) THEN IF (id%NPROCS.NE.1) THEN CALL MUMPS_AB_GATHER_GRAPH( & id%ICNTL(1), KEEP(1), id%COMM, id%MYID, id%NPROCS, & id%INFO(1), & GCOMP_DIST, GCOMP) GCOMP_PROVIDED = .TRUE. C CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST, MEMCNT) ENDIF ELSE CALL CMUMPS_GATHER_MATRIX(id) GATHER_MATRIX_ALLOCATED = .TRUE. CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF 1234 CONTINUE IF (KEEP(244) .EQ. 1) THEN C Sequential analysis : Schur IF ( id%MYID .eq. MASTER ) THEN C Prepare arguments for call to CMUMPS_ANA_F and C CMUMPS_ANA_F_ELT in case id%SCHUR was not allocated C by user. The objective is to avoid passing a null C pointer. C FIXME Block fomat for Schur IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN SIZE_SCHUR_PASSED = 1 LISTVAR_SCHUR_2BE_FREED=.TRUE. allocate( id%LISTVAR_SCHUR( 1 ), STAT=allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) & 'PB allocating an array of size 1 for Schur!! ' INFO(1)=-7 INFO(2)=1 END IF ELSE SIZE_SCHUR_PASSED=id%SIZE_SCHUR LISTVAR_SCHUR_2BE_FREED = .FALSE. END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF C IF ((id%MYID.EQ.MASTER).AND.(KEEP(244) .EQ. 1) & .AND. (id%N.EQ.NBLK) & ) THEN C Sequential analysis : maximum transversal on master IF ((KEEP(50).NE.1).AND. & .NOT.((KEEP(23).EQ.7).AND.KEEP(50).EQ.0) & ) THEN C (KEEP(23).EQ.7).AND.KEEP(50).EQ.0) : C For unsymmetric matrix, if automatic setting is requested C default setting of Maximum Transversal is decided during C CMUMPS_ANA_F and is based on matrix unsymmetry. C Thus in this case we skip CMUMPS_ANA_O IF ( ( KEEP(23) .NE. 0 ) .OR. C Automatic choice for scaling does not force Maxtrans C Only when scaling is explicitly asked during analysis C (KEEP(52)=-2) CMUMPS_ANA_O is called & KEEP(52) .EQ. -2 ) THEN C C Maximum Trans. algorithm called on original matrix. C We compute a permutation of the original matrix to C have a zero free diagonal C KEEP(23)=7 means that automatic choice C of max trans value will be done during analysis C Permutation is held in UNS_PERM(1, ...,N). C Maximum transversal is not available for element C entry format C UNS_PERM that might be set to C to permutation computed during Max transversal ALLOCATE(id%UNS_PERM(id%N),IKEEPALLOC(3_8*int(id%N,8)), & WORK2ALLOC(id%N), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( 5_8 * int(id%N,8), INFO(2) ) ELSE CALL CMUMPS_ANA_O(id%N, id%KEEP8(28), KEEP(23), & id%UNS_PERM, IKEEPALLOC, 3_8*int(id%N,8), & id%IRN, id%JCN, id%A, & id%ROWSCA, id%COLSCA, & WORK2ALLOC, id%KEEP, id%ICNTL, id%INFO, id%INFOG) IF (allocated(WORK2ALLOC)) DEALLOCATE(WORK2ALLOC) IF (KEEP(23).EQ.0) THEN C Maximum tranversal did not produce a permutation IF (associated( id%UNS_PERM )) & DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF C Check if IKEEPALLOC needed for ANA_F IF (KEEP(23).EQ.0.AND.(KEEP(95).EQ.1)) THEN IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) ENDIF ENDIF IF (INFO(1) .LT. 0) THEN C Fatal error C Permutation was not computed; reset keep(23) KEEP(23) = 0 ELSE ENDIF ELSE KEEP(23) = 0 C Switch off C compressed/contrained ordering id%KEEP(95) = 1 END IF ENDIF C END OF MAX-TRANS ON THE MASTER ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C IF ( KEEP(244) .EQ. 1) THEN C Sequential analysis: allocate data for ordering on MASTER IF (id%MYID.EQ.MASTER) THEN C allocate IKEEPALLOC and TREE related pointers C IKEEPALLOC might have been allocated in CMUMPS_ANA_O C and IKEEPALLOC(1:N) might hold information to C be given to ANA_F. IF (allocated(IKEEPALLOC)) THEN ALLOCATE( FILS_TMP(NBLK), FREREPTR(NBLK), & NFSIZPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(int(NBLK,8)*3_8, INFO(2)) ENDIF ELSE ALLOCATE(IKEEPALLOC(int(NBLK,8)+2_8*int(id%N,8)), & FILS_TMP(NBLK), FREREPTR(NBLK), & NFSIZPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(int(NBLK,8)*4_8+2_8*int(id%N,8), & INFO(2)) ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF C IF (KEEP(244) .EQ. 1) THEN C Sequential analysis IF ( id%MYID .eq. MASTER ) THEN C BEGINNING OF ANALYSIS ON THE MASTER C ------------------------------------------------------ C For element entry (KEEP(55).ne.0), we do not know NZ, C and so the whole allocation of IW cannot be done at this C point and more workspace is declared/allocated/used C inside CMUMPS_ANA_F_ELT. C ------------------------------------------------------ C IF (KEEP(55) .EQ. 0) THEN C ---------------- C Assembled format C ---------------- NZ8=id%KEEP8(28) C Compute LIW8: C For local orderings a contiguous space IW C of size LIW8 must be provided. C IW must hold the graph (with double adjacency C list) and and extra space of size the number of C nodes in the graph: C ==> LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8 C In case of analysis by block and C However, when GCOMP is provided directly then C IW is not allocated C ==> LIW8 = 0 C In this case C size(LCOMP%ADJ)>= 2_8*NZ8+int(NBLK,8)+1_8 C should hold IF (KEEP(13).NE.0) THEN C Compact graph is provided on entry to CMUMPS_ANA_F NZ8=0_8 ! GCOMP is provided on entry ENDIF IF (NZ8.EQ.0_8) THEN LIW8 = 0_8 ELSE LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8 ENDIF C ELSE C ---------------- C Elemental format C ---------------- C Only available for AMD, METIS, and given ordering #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) COND = (KEEP(60) .NE. 0) .OR. (KEEP(256) .EQ. 5) #else COND = (KEEP(60) .NE. 0) #endif IF( COND ) THEN C C C we suppress supervariable detection when Schur C is active or when METIS is applied C Workspaces for FLAG(N), and either LEN(N) or some pointers(N+1) LIW8_ELT = int(id%N,8) + int(id%N,8) + 1_8 ELSE C Spaces FLAG(N), LEN(N), N+3, SVAR(0:N), LIW8_ELT = int(id%N,8) + int(id%N,8) + & int(id%N,8)+3_8 + int(id%N,8)+1_8 ENDIF C ENDIF C We must ensure that an array of order C 3*N is available for CMUMPS_ANA_LNEW IF (KEEP(55) .EQ. 0) THEN IF (LIW8.LT.3_8*int(NBLK,8)) LIW8=3_8*int(NBLK,8) ELSE IF (LIW8_ELT.LT.3_8*int(id%N,8)) LIW8_ELT=3_8*int(id%N,8) ENDIF C IF ( KEEP(256) .EQ. 1 ) THEN C It has been checked that id%PERM_IN is associated but C values of pivot order will be checked later and C should be checked here too C PERM_IN( I ) = position of I in the pivot order IKEEP2 => IKEEPALLOC(int(NBLK+1,8):int(NBLK,8)+int(id%N,8)) C Build inverse permutation and check PERM_IN DO I = 1, id%N IKEEP2(I) = 0 ENDDO DO I = 1, id%N IF ( id%PERM_IN(I) .LT.1 .OR. & id%PERM_IN(I) .GT. id%N ) THEN C PERM_IN entry is out-of-range INFO(1) = -4 INFO(2) = I GOTO 10 ELSE IF ( IKEEP2(id%PERM_IN(I)) .NE. 0 ) THEN C Duplicate entry in PERM_IN was found INFO(1) = -4 INFO(2) = I GOTO 10 ELSE C Store entry in inverse permutation IKEEP2(id%PERM_IN( I )) = I ENDIF ENDDO IF ((KEEP(55) .EQ. 0).AND.(KEEP(13).NE.0) & .AND.(KEEP(13).NE.-1) & ) THEN C Build blocked permutation: C IKEEPALLOC(IB)= IBPos where IB, IBPos \in [1:NBLK] C IKEEP2 holds inverse permutation IPOSB = 0 IPOS = 1 DO WHILE (IPOS.LE.id%N) IPOSB = IPOSB+1 I = IKEEP2(IPOS) IBcurrent = DOF2BLOCK(I) BLKSIZE = SIZEOFBLOCKS(IBcurrent) IKEEPALLOC(IBcurrent) = IPOSB IF (BLKSIZE.GT.1) THEN DO II = 1, BLKSIZE-1 IPOS = IPOS+1 I = IKEEP2(IPOS) IB = DOF2BLOCK(I) IF (IB.NE.IBcurrent) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & " ERROR: given permutation (ICNTL(7)=1)", & " incompatible with block format" ENDIF INFO(1)= -4 INFO(2)= I GOTO 10 ENDIF ENDDO ENDIF IPOS = IPOS+1 ENDDO C IF PERM_IN is correct then C on exit last position should be NBLK IF (IPOSB.NE.NBLK) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & " ERROR: given permutation (ICNTL(7)=1)", & " incompatible with block format" ENDIF INFO(1)= -4 C N+1 to indicate "global" error INFO(2)= id%N+1 GOTO 10 ENDIF ELSE DO I = 1, id%N IKEEPALLOC( I ) = id%PERM_IN( I ) END DO ENDIF IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) END IF INFOG(1) = 0 INFOG(2) = 0 C Initialize structural symmetry value to not yet computed. INFOG(8) = -1 IF (KEEP(55) .EQ. 0) THEN IKEEP1 => IKEEPALLOC(1:NBLK) IKEEP2 => IKEEPALLOC(int(NBLK+1,8): & int(NBLK,8)+int(id%N,8)) IKEEP3 => IKEEPALLOC(int(NBLK,8)+int(id%N+1,8): & int(NBLK,8)+2_8*int(id%N,8)) C id%UNS_PERM corresponds to argument PIV C in CMUMPS_ANA_F, it should be an assumed-shape C array rather than a possibly null pointer: IF (associated(id%UNS_PERM)) THEN UNS_PERM_PTR => id%UNS_PERM ELSE UNS_PERM_PTR => IDUMMY_ARRAY ENDIF IF (KEEP(13).EQ.0) THEN CALL CMUMPS_ANA_F(id%N, NZ8, & id%IRN, id%JCN, & LIW8, IKEEP1, IKEEP2, IKEEP3, & KEEP(256), NFSIZPTR, & FILS_TMP, & FREREPTR, & id%LISTVAR_SCHUR, SIZE_SCHUR_PASSED, & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, & UNS_PERM_PTR, & id%CNTL(4), id%COLSCA, id%ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & ) ELSE IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY CALL CMUMPS_ANA_F(NBLK, NZ8, & IRN_loc_PTR, JCN_loc_PTR, & LIW8, IKEEP1, IKEEP2, IKEEP3, & KEEP(256), NFSIZPTR, & FILS_TMP, FREREPTR, & id%LISTVAR_SCHUR, SIZE_SCHUR_PASSED, & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, & UNS_PERM_PTR, & id%CNTL(4), id%COLSCA, id%ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & , id%N, SIZEOFBLOCKS, GCOMP_PROVIDED, GCOMP & ) IF (GCOMP_PROVIDED) & CALL MUMPS_AB_FREE_GCOMP(GCOMP, MEMCNT) C ENDIF INFOG(7) = KEEP(256) C UNS_PERM_PTR was only used locally C for the call to CMUMPS_ANA_F NULLIFY(UNS_PERM_PTR) ELSE allocate( XNODEL ( id%N+1 ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = id%N + 1 IF ( LPOK ) THEN WRITE(LP, 150) 'XNODEL' END IF GOTO 10 ENDIF IF (LELTVAR.ne.id%ELTPTR(NELT+1)-1) THEN C -- internal error INFO(1) = -2002 INFO(2) = id%ELTPTR(NELT+1)-1 GOTO 10 ENDIF allocate( NODEL ( LELTVAR ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LELTVAR IF ( LPOK ) THEN WRITE(LP, 150) 'NODEL' END IF GOTO 10 ENDIF CALL CMUMPS_ANA_F_ELT(id%N, NELT, & id%ELTPTR(1), id%ELTVAR(1), LIW8_ELT, & IKEEPALLOC(1), & KEEP(256), NFSIZPTR(1), FILS_TMP(1), & FREREPTR(1), id%LISTVAR_SCHUR(1), & SIZE_SCHUR_PASSED, & ICNTL(1), INFOG(1), KEEP(1),KEEP8(1), & id%NSLAVES, & XNODEL(1), NODEL(1) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & ) INFOG(7)=KEEP(256) C C XNODEL and NODEL as output to CMUMPS_ANA_F_ELT C be used in CMUMPS_FRTELT and thus C cannot be deallocated at this point C ENDIF IF ( LISTVAR_SCHUR_2BE_FREED ) THEN C We do not want to have LISTVAR_SCHUR C allocated of size 1 if Schur is off. DEALLOCATE( id%LISTVAR_SCHUR ) NULLIFY ( id%LISTVAR_SCHUR ) LISTVAR_SCHUR_2BE_FREED = .TRUE. ENDIF C ------------------------------ C Significant error codes should C always be in INFO(1/2) C ------------------------------ INFO(1)=INFOG(1) INFO(2)=INFOG(2) C save statistics in KEEP array. KEEP(28) = INFOG(6) IKEEP = 1_8 NA = IKEEP + int(id%N,8) NE = IKEEP + 2_8 * int(id%N,8) C -- if (id%myid.eq.master) ENDIF C -- if sequential analysis ENDIF C 10 CONTINUE IF (KEEP(244).EQ.1) THEN CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF IF ((KEEP(244).EQ.1).AND.(KEEP(55).EQ.0)) THEN C Sequential analysis on assembled matrix C check if max transversal should be called CALL MPI_BCAST(KEEP(23),1,MPI_INTEGER,MASTER,id%COMM,IERR) IF ( (KEEP(23).LE.-1).AND.(KEEP(23).GE.-6) ) THEN C -- Perform max transversal KEEP(23) = -KEEP(23) IF (id%MYID.EQ.MASTER) THEN IF (.NOT. associated(id%A)) KEEP(23) = 1 IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (allocated(FILS_TMP) ) THEN DEALLOCATE(FILS_TMP) ENDIF IF (associated(FREREPTR) ) THEN DEALLOCATE(FREREPTR) NULLIFY(FREREPTR) ENDIF IF (associated(NFSIZPTR) ) THEN DEALLOCATE(NFSIZPTR) NULLIFY(NFSIZPTR) ENDIF ENDIF GOTO 1234 ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(244).EQ.1).AND. (KEEP(55).EQ.0)) THEN C Sequential ordering on assembled matrix IF ((KEEP(54).EQ.3).AND.KEEP(494).EQ.0) THEN IF (GATHER_MATRIX_ALLOCATED) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF GATHER_MATRIX_ALLOCATED= .FALSE. ENDIF ENDIF ENDIF ENDIF IF (KEEP(244).NE.1) THEN C{ Parallel analysis IF (id%MYID .EQ. MASTER) THEN C KEEPALLOC reuse later C FIXME allocate of size 2*NBLK and C allocate of size 3*id%N after call ana_aux_par SIZEIKEEPALLOC = 3_8*int(id%N,8) SIZEWORK2ALLOC = max(4_8*int(NBLK,8), int(id%NPROCS+1,8)) ALLOCATE( IKEEPALLOC(SIZEIKEEPALLOC), & WORK2ALLOC(SIZEWORK2ALLOC), & FILS_TMP(NBLK), FREREPTR(NBLK), NFSIZPTR(NBLK), & stat=IERR) ELSE IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN C Allocate only on procs concerned by parallel analysis SIZEIKEEPALLOC = 3_8*int(NBLK,8) SIZEWORK2ALLOC = 4_8*int(NBLK,8) ALLOCATE(IKEEPALLOC(SIZEIKEEPALLOC), & WORK2ALLOC(SIZEWORK2ALLOC), stat=IERR ) ELSE C Not concerned by CMUMPS_ANA_F_PAR IERR = 0 SIZEIKEEPALLOC = 0_8 SIZEWORK2ALLOC = 0_8 ENDIF IF (IERR.GT.0) THEN INFO(1) = -7 IF (id%MYID .EQ. MASTER) THEN CALL MUMPS_SET_IERROR( & SIZEIKEEPALLOC+SIZEWORK2ALLOC+3_8*int(NBLK,8), & INFO(2) ) ELSE CALL MUMPS_SET_IERROR( & SIZEIKEEPALLOC+SIZEWORK2ALLOC, & INFO(2) ) ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C save value provided by user idNBLKSAVE= id%NBLK C #if defined(MUMPS_NOF2003) C Allocatable not allowed in CMUMPS_ANA_F_PAR, C use a pointer instead. FILS_TMP is typically C allocated only on MPI rank 0. IF (allocated(FILS_TMP)) THEN FILS_TMPPTR => FILS_TMP ELSE FILS_TMPPTR => IDUMMY_ARRAY ENDIF #endif IF (LUMAT_AVAIL) THEN C{ C id%NBLK = NBLK IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN IF (RKinidCOMM_PROC0SYMB.NE.MASTER) CALL MUMPS_ABORT() CALL CMUMPS_ANA_F_PAR(id, & IKEEPALLOC, & WORK2ALLOC, & SIZEIKEEPALLOC, & SIZEWORK2ALLOC, & NFSIZPTR, #if defined(MUMPS_NOF2003) & FILS_TMPPTR, #else & FILS_TMP, #endif & FREREPTR, & COMM_PARASYMB ! optional: & , LUMAT, SIZEOFBLOCKS & , COMM_PARAORD, NPROCS_PARAORD & , RKinSYMB_PROC0ORD & ) ENDIF IF (KEEP(494).EQ.0.OR.KEEP(487).NE.1) THEN CALL MUMPS_AB_FREE_LMAT(LUMAT,KEEP(147)) LUMAT_AVAIL = .FALSE. ELSE LUMAT_AVAIL = .TRUE. ENDIF C C} ELSE C{ LUMAT not available and COMM_PARASYMB=id%COMM id%NBLK = id%N CALL CMUMPS_ANA_F_PAR(id, & IKEEPALLOC, & WORK2ALLOC, & SIZEIKEEPALLOC, & SIZEWORK2ALLOC, & NFSIZPTR, #if defined(MUMPS_NOF2003) & FILS_TMPPTR, #else & FILS_TMP, #endif & FREREPTR, & id%COMM & ) C} ENDIF id%NBLK = idNBLKSAVE IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN DEALLOCATE(WORK2ALLOC) IF(id%MYID .NE. MASTER) THEN DEALLOCATE(IKEEPALLOC) ENDIF ENDIF KEEP(28) = INFOG(6) IF (COMM_PARAORD_ALLOCATED) THEN IF (COMM_PARAORD.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_FREE( COMM_PARAORD, IERR ) COMM_PARAORD_ALLOCATED = .FALSE. ENDIF ENDIF IF (COMM_PARASYMB_ALLOCATED) THEN IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_FREE( COMM_PARASYMB, IERR ) COMM_PARASYMB_ALLOCATED = .FALSE. ENDIF ENDIF C Check error after freeing communicators CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C IF (id%MYID.EQ.MASTER) THEN IKEEP = 1_8 NA = IKEEP + int(id%N,8) NE = IKEEP + 2_8 * int(id%N,8) ENDIF C --------------------------------------------------------- C Check whether FILS_TMP, FREREPTR, NFSIZPTR C computed on master of COMM_PARSYMB (RKinidCOMM_PROC0SYMB) C should be send on MASTER C --------------------------------------------------------- IF (RKinidCOMM_PROC0SYMB.NE.MASTER) THEN C allocate data on MASTER of id%COMM IF (id%MYID.EQ.MASTER) THEN C FILS_TMP allocate to size NBLK since it will be C allways copied back in structure ALLOCATE( FILS_TMP(NBLK), FREREPTR(id%N), NFSIZPTR(id%N), & stat=IERR) ENDIF ENDIF IF (IERR.GT.0) THEN INFO(1) = -7 IF (id%MYID .EQ. MASTER) THEN CALL MUMPS_SET_IERROR(3_8*int(id%N,8), INFO(2)) ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF (RKinidCOMM_PROC0SYMB.NE.MASTER) THEN C data computed on master of COMM_PARASYMB to be C sent on MASTER of id%COMM C FIXME to be authorized INFOG data should also C be sent to MASTER of id%COMM CALL MUMPS_ABORT() IF (id%MYID.EQ.RKinidCOMM_PROC0SYMB) THEN CALL MPI_SEND (FILS_TMP(1), NBLK, MPI_INTEGER, & MASTER, CENT_AFTER_PARAORD, id%COMM, IERR) CALL MPI_SEND (FREREPTR(1), NBLK, MPI_INTEGER, & MASTER, CENT_AFTER_PARAORD, id%COMM, IERR) CALL MPI_SEND (NFSIZPTR(1), NBLK, MPI_INTEGER, & MASTER, CENT_AFTER_PARAORD, id%COMM, IERR) C C deallocate data sent to MASTER DEALLOCATE(FILS_TMP, FREREPTR, NFSIZPTR) C FILS_TMP is an allocatable array nullify(FREREPTR, NFSIZPTR) C ENDIF IF (id%MYID.EQ.MASTER) THEN CALL MPI_RECV (FILS_TMP(1), NBLK, MPI_INTEGER, & RKinidCOMM_PROC0SYMB, CENT_AFTER_PARAORD, & id%COMM, STATUS, IERR) CALL MPI_RECV (FREREPTR(1), NBLK, MPI_INTEGER, & RKinidCOMM_PROC0SYMB, CENT_AFTER_PARAORD, & id%COMM, STATUS, IERR) CALL MPI_RECV (NFSIZPTR(1), NBLK, MPI_INTEGER, & RKinidCOMM_PROC0SYMB, CENT_AFTER_PARAORD, & id%COMM, STATUS, IERR) ENDIF C ENDIF C} END IF C Allocated PROCNODE on MASTER IF (id%MYID.EQ.MASTER) THEN allocok = 0 allocate(PROCNODE(NBLK), STAT=allocok) IF (allocok .ne. 0) THEN INFO(1) = -7 INFO(2) = NBLK ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF ( I_AM_SLAVE) THEN KEEP(144)=1 ! MPI process is working ELSE KEEP(144)=0 ENDIF IF(id%MYID .EQ. MASTER) THEN C Save ICNTL(14) value into KEEP(12) CALL MUMPS_GET_PERLU(KEEP(12),ICNTL(14), & KEEP(50),KEEP(54),ICNTL(6),KEEP(52)) CALL CMUMPS_ANA_R(NBLK, FILS_TMP(1), FREREPTR(1), & IKEEPALLOC(NE), IKEEPALLOC(NA)) C ********************************************************** C Continue with CALL to MAPPING routine C ********************* C BEGIN SEQUENTIAL CODE C No mapping computed C ********************* C C In sequential, if no special root C reset KEEP(20) and KEEP(38) to 0 C IF (id%NSLAVES .EQ. 1 & ) THEN id%NBSA = 0 IF ( (id%KEEP(60).EQ.0). & AND.(id%KEEP(53).EQ.0)) THEN C If Schur is on (keep(60).ne.0) C or if RR is on (keep (53) > 0 C then we keep root numbers C root node number in seq id%KEEP(20)=0 C root node number in paral id%KEEP(38)=0 ENDIF C No type 2 nodes: id%KEEP(56)=0 C All mapped on MPI process 0, and of type TPN=0 C (treated as if they were all root of subtree) PROCNODE_VALUE = MUMPS_ENCODE_TPN_IPROC(0, 0, KEEP(199)) DO I = 1, NBLK PROCNODE(I) = PROCNODE_VALUE END DO C It may also happen that KEEP(38) has already been set, C in the case of a distributed Schur complement (KEEP(60)=2 or 3). C In that case, PROCNODE should be set accordingly and KEEP(38) is C not modified. IF (id%KEEP(60) .EQ. 2 .OR. id%KEEP(60).EQ.3) THEN PROCNODE_VALUE = MUMPS_ENCODE_TPN_IPROC(3, 0, KEEP(199)) CALL CMUMPS_SET_PROCNODE(id%KEEP(38), PROCNODE(1), & PROCNODE_VALUE, FILS_TMP(1), NBLK) ENDIF C ******************* C END SEQUENTIAL CODE C ******************* ELSE C ***************************** C BEGIN MAPPING WITH CANDIDATES C (NSLAVES > 1) C ***************************** C C C peak is set by default to 1 largest front + One largest CB PEAK = real(id%INFOG(5))*real(id%INFOG(5)) + ! front matrix & real(id%KEEP(2))*real(id%KEEP(2)) ! cb bloc C IKEEP(1:N,1) can be used as a work space since it is set C to its final state by the SORT_PERM subroutine below. SSARBR => IKEEPALLOC(IKEEP:IKEEP+int(NBLK-1,8)) C ====================================================== C Map nodes and assign candidates for dynamic scheduling C ====================================================== IF ((KEEP(13).NE.0).AND.(NBLK.NE.id%N)) THEN SIZEOFBLOCKS_PTR => SIZEOFBLOCKS(1:NBLK) LSIZEOFBLOCKS_PTR = NBLK ELSE SIZEOFBLOCKS_PTR => IDUMMY_ARRAY LSIZEOFBLOCKS_PTR = 1 IDUMMY_ARRAY(1) = -1 ENDIF CALL CMUMPS_DIST_AVOID_COPIES( & NBLK,id%NSLAVES,ICNTL(1), & INFOG(1), & IKEEPALLOC(NE), & NFSIZPTR(1), & FREREPTR(1), & FILS_TMP(1), & KEEP(1),KEEP8(1),PROCNODE(1), & SSARBR(1),id%NBSA,PEAK,IERR & , SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR & ) NULLIFY(SSARBR) if(IERR.eq.-999) then write(6,*) ' Internal error during static mapping ' INFO(1) = IERR GOTO 11 ENDIF IF(IERR.NE.0) THEN INFO(1) = -135 INFO(2) = IERR GOTO 11 ENDIF CALL CMUMPS_ANA_R(NBLK, FILS_TMP(1), & FREREPTR(1), IKEEPALLOC(NE), & IKEEPALLOC(NA)) ENDIF 11 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C The following part is done in parallel CALL MPI_BCAST( id%NELT, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KEEP(55) .EQ. 0) THEN C Assembled matrix format. Fill up the id%PTRAR array C Broadcast id%SYM_PERM needed to fill up id%PTRAR C postpone to after computation of id%SYM_PERM C computed after id%DAD_STEPS if (associated(id%FRTPTR)) DEALLOCATE(id%FRTPTR) if (associated(id%FRTELT)) DEALLOCATE(id%FRTELT) allocate( id%FRTPTR(1), id%FRTELT(1) ,STAT=allocok) IF (allocok .GT. 0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'FRTPTR,FRTELT' END IF INFO(1)= -7 INFO(2)= 2 END IF ELSE C Element Entry: C ------------------------------- C COMPUTE THE LIST OF ELEMENTS THAT WILL BE ASSEMBLED C AT EACH NODE OF THE ELIMINATION TREE. ALSO COMPUTE C FOR EACH ELEMENT THE TREE NODE TO WHICH IT IS ASSIGNED. C C FRTPTR is an INTEGER array of length N+1 which need not be set by C the user. On output, FRTPTR(I) points in FRTELT to first element C in the list of elements assigned to node I in the elimination tree. C C FRTELT is an INTEGER array of length NELT which need not be set by C the user. On output, positions FRTELT(FRTPTR(I)) to C FRTELT(FRTPTR(I+1)-1) contain the list of elements assigned to C node I in the elimination tree. C LPTRAR = id%NELT+id%NELT+2 CALL MUMPS_I8REALLOC(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%FRTPTR, id%N+1, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTPTR (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%ELTPROC, id%NELT, id%INFO, LP, & FORCE=.TRUE., STRING='id%ELTPROC (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%FRTELT, id%NELT, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTELT (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF(id%MYID .EQ. MASTER) THEN C In the elemental format case, PTRAR&friends are still C computed sequentially and then broadcasted CALL CMUMPS_FRTELT( & id%N, NELT, id%ELTPTR(NELT+1)-1, FREREPTR(1), & FILS_TMP(1), & IKEEPALLOC(NA), IKEEPALLOC(NE), XNODEL, & NODEL, id%FRTPTR(1), id%FRTELT(1), id%ELTPROC(1)) DO I=1, id%NELT+1 C PTRAR declared 64-bit id%PTRAR(id%NELT+I+1)=int(id%ELTPTR(I),8) ENDDO DEALLOCATE(XNODEL) DEALLOCATE(NODEL) END IF CALL MPI_BCAST( id%PTRAR(id%NELT+2), id%NELT+1, MPI_INTEGER8, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRTPTR(1), id%N+1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRTELT(1), id%NELT, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C We switch again to sequential computations on the master node IF(id%MYID .EQ. MASTER) THEN IF ( INFO( 1 ) .LT. 0 ) GOTO 12 IF ( KEEP(55) .ne. 0 ) THEN C --------------------------------------- C Build ELTPROC: correspondance between elements and slave ranks C in COMM_NODES with special values -1 (all procs) and -2 and -3 C (no procs). This is used later to distribute the elements on C the processes at the beginning of the factorisation phase C --------------------------------------- CALL CMUMPS_ELTPROC(NBLK, NELT, id%ELTPROC(1),id%NSLAVES, & PROCNODE(1), id%KEEP(1)) END IF NB_NIV2 = KEEP(56) IF ( NB_NIV2.GT.0 ) THEN C allocate(PAR2_NODES(NB_NIV2), & STAT=allocok) IF (allocok .GT.0) then INFO(1)= -7 INFO(2)= NB_NIV2 IF ( LPOK ) THEN WRITE(LP, 150) 'PAR2_NODES' END IF GOTO 12 END IF ENDIF IF ((NB_NIV2.GT.0) .AND. (KEEP(24).EQ.0)) THEN INIV2 = 0 DO 777 INODE = 1, NBLK IF ( ( FREREPTR(INODE) .NE. NBLK ) .AND. & ( MUMPS_TYPENODE(PROCNODE(INODE),id%KEEP(199)) & .eq. 2) ) THEN INIV2 = INIV2 + 1 PAR2_NODES(INIV2) = INODE END IF 777 CONTINUE IF ( INIV2 .NE. NB_NIV2 ) THEN WRITE(*,*) "Internal Error 2 in CMUMPS_ANA_DRIVER", & INIV2, NB_NIV2 CALL MUMPS_ABORT() ENDIF ENDIF IF ( (KEEP(24) .NE. 0) .AND. (NB_NIV2.GT.0) ) THEN C allocate array to store cadidates stategy C for each level two nodes IF ( associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES) allocate( id%CANDIDATES(id%NSLAVES+1,NB_NIV2), & stat=allocok) if (allocok .gt.0) then INFO(1)= -7 INFO(2)= NB_NIV2*(id%NSLAVES+1) IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 END IF CALL MUMPS_RETURN_CANDIDATES & (PAR2_NODES,id%CANDIDATES, & IERR) IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF C deallocation of variables of module mumps_static_mapping CALL MUMPS_END_ARCH_CV() IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF ELSE IF (associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES) allocate(id%CANDIDATES(1,1), stat=allocok) IF (allocok .NE. 0) THEN INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 ENDIF ENDIF C******************************************************************* C --------------- 12 CONTINUE C --------------- * * =============================== * End of analysis phase on master * =============================== * END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C C We now allocate and compute arrays in NSTEPS C on the master, as this makes more sense. C C Broadcast KEEP8(101) to be used in MUMPS_ANA_L0_OMP CALL MPI_BCAST( id%KEEP8(101), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) C C ============================== C PREPARE DATA FOR FACTORIZATION C ============================== C ------------------ CALL MPI_BCAST( id%KEEP(1), 110, MPI_INTEGER, MASTER, & id%COMM, IERR ) C We also need to broadcast KEEP8(21) CALL MPI_BCAST( id%KEEP8(21), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) C -------------------------------------------------- C Broadcast KEEP(205) which is outside the first 110 C KEEP entries but is needed for factorization. C -------------------------------------------------- CALL MPI_BCAST( id%KEEP(205), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C -------------- C Broadcast NBSA CALL MPI_BCAST( id%NBSA, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- C Global MAXFRT (computed in CMUMPS_ANA_M) C is needed on all the procs during CMUMPS_ANA_DISTM C to evaluate workspace for solve. C We could also recompute it in CMUMPS_ANA_DISTM IF (id%MYID==MASTER) KEEP(127)=INFOG(5) CALL MPI_BCAST( id%KEEP(127), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- C Global max panel size KEEP(226) CALL MPI_BCAST( id%KEEP(226), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- CALL MPI_BCAST( id%KEEP(464), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(471), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(475), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(482), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(487), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) C Number of leaves not belonging to L0 KEEP(262) C and KEEP(263) : inner or outer sends for blocked facto CALL MPI_BCAST( id%KEEP(262), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ---------------------------------------- C Allocate new workspace on all processors C ---------------------------------------- C STEP_TMP is of size NBLK because it C is computed on compressed graph and C broadcasted when needed. C It is then extended in id%STEP on master C and broadcasted on all procs ALLOCATE(STEP_TMP(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NBLK ENDIF IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%PROCNODE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%PROCNODE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%NE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%NE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%ND_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%ND_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%FRERE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%FRERE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%DAD_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%DAD_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 IF (KEEP(55) .EQ. 0) THEN LPTRAR = 2 CALL MUMPS_I8REALLOC(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 ENDIF IF (id%KEEP(494).NE.0) THEN C of size NBLK that will be extended and copies later C on master SIZELRGROUPS_TMP = NBLK ELSE C needed as argument for CMUMPS_EXPAND_TREE_STEPS SIZELRGROUPS_TMP = 1 ENDIF ALLOCATE(LRGROUPS_TMP(SIZELRGROUPS_TMP), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NBLK ENDIF C IF(INFO(1).LT.0) GOTO 94 C Copy data for factorization and/or solve. C ================================ C COMPUTE ON THE MASTER, BROADCAST C TO OTHER PROCESSES C ================================ IF ( id%MYID .NE. MASTER .OR. id%KEEP(23) .EQ. 0 ) THEN IF ( associated( id%UNS_PERM ) ) THEN DEALLOCATE(id%UNS_PERM) ENDIF ENDIF 94 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( id%MYID .EQ. MASTER ) THEN C NA -> compressed NA containing only list C of leaves of the elimination tree and list of roots C (the two useful informations for factorization/solve). IF (NBLK.eq.1) THEN NBROOT = 1 NBLEAF = 1 ELSE IF (IKEEPALLOC(NA+int(NBLK-1,8)) .LT.0) THEN NBLEAF= NBLK NBROOT= NBLK ELSE IF (IKEEPALLOC(NA+int(NBLK-2,8)) .LT.0) THEN NBLEAF = NBLK-1 NBROOT = IKEEPALLOC(NA+int(NBLK-1,8)) ELSE NBLEAF = IKEEPALLOC(NA+int(NBLK-2,8)) NBROOT = IKEEPALLOC(NA+int(NBLK-1,8)) ENDIF id%LNA = 2+NBLEAF+NBROOT ENDIF CALL MPI_BCAST( id%LNA, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MUMPS_REALLOC(id%NA, id%LNA, id%INFO, LP, FORCE=.TRUE., & STRING='id%NA (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF (id%MYID .EQ.MASTER ) THEN C{ The structure of NA is the following: C NA(1) is the number of leaves. C NA(2) is the number of roots. C NA(3:2+NA(1)) are the leaves. C NA(3+NA(1):2+NA(1)+NA(2)) are the roots. id%NA(1) = NBLEAF id%NA(2) = NBROOT C C Initialize NA with the leaves and roots LEAF = 3 IF ( NBLK == 1 ) THEN id%NA(LEAF) = 1 LEAF = LEAF + 1 ELSE IF (IKEEPALLOC(NA+int(NBLK-1,8)) < 0) THEN id%NA(LEAF) = - IKEEPALLOC(NA+int(NBLK-1,8))-1 LEAF = LEAF + 1 DO I = 1, NBLEAF - 1 id%NA(LEAF) = IKEEPALLOC(NA+int(I-1,8)) LEAF = LEAF + 1 ENDDO ELSE IF (IKEEPALLOC(NA+int(NBLK-2,8)) < 0 ) THEN INODE = - IKEEPALLOC(NA+int(NBLK-2,8)) - 1 id%NA(LEAF) = INODE LEAF =LEAF + 1 IF ( NBLEAF > 1 ) THEN DO I = 1, NBLEAF - 1 id%NA(LEAF) = IKEEPALLOC(NA+int(I-1,8)) LEAF = LEAF + 1 ENDDO ENDIF ELSE DO I = 1, NBLEAF id%NA(LEAF) = IKEEPALLOC(NA+int(I-1,8)) LEAF = LEAF + 1 ENDDO END IF C C Build array STEP_TMP(1:NBLK) to hold step numbers in C range 1..id%KEEP(28), allowing compression of C other arrays from id%N to id%KEEP(28) C (the number of nodes/steps in the assembly tree) ISTEP = 0 DO I = 1, NBLK IF ( FREREPTR(I) .ne. NBLK + 1 ) THEN C New node in the tree. c (Set step( inode_n ) = inode_nsteps for principal C variables and -inode_nsteps for internal variables C of the node) ISTEP = ISTEP + 1 STEP_TMP(I)=ISTEP INN = FILS_TMP(I) DO WHILE ( INN .GT. 0 ) STEP_TMP(INN) = - ISTEP INN = FILS_TMP(INN) END DO IF (FREREPTR(I) .eq. 0) THEN C Keep root nodes list in NA id%NA(LEAF) = I LEAF = LEAF + 1 ENDIF ENDIF END DO IF ( LEAF - 1 .NE. 2+NBROOT + NBLEAF ) THEN WRITE(*,*) 'Internal error 2 in CMUMPS_ANA_DRIVER' CALL MUMPS_ABORT() ENDIF IF ( ISTEP .NE. id%KEEP(28) ) THEN write(*,*) 'Internal error 3 in CMUMPS_ANA_DRIVER', & ISTEP, id%KEEP(28) CALL MUMPS_ABORT() ENDIF C ============ C SET PROCNODE, FRERE, NE C ============ C copies to NSTEP array should be ok DO I = 1, NBLK IF (FREREPTR(I) .NE. NBLK+1) THEN id%PROCNODE_STEPS(STEP_TMP(I)) = PROCNODE( I ) id%FRERE_STEPS(STEP_TMP(I)) = FREREPTR(I) id%NE_STEPS(STEP_TMP(I)) = IKEEPALLOC(NE+int(I-1,8)) id%ND_STEPS(STEP_TMP(I)) = NFSIZPTR(I) ENDIF ENDDO C =============================== C Algorithm to compute array DAD_STEPS: C ---- C For each node set dad for all of its sons C plus, for root nodes set dad to zero. C C =============================== DO I = 1, NBLK C -- skip non principal nodes IF ( STEP_TMP(I) .LE. 0) CYCLE C -- (I) is a principal node IF (FREREPTR(I) .eq. 0) THEN C -- I is a root node and has no father id%DAD_STEPS(STEP_TMP(I)) = 0 ENDIF C -- Find first son node (IFS) IFS = FILS_TMP(I) DO WHILE ( IFS .GT. 0 ) IFS= FILS_TMP(IFS) END DO C -- IFS > 0 if I is not a leave node C -- Go through list of brothers of IFS if any IFS = -IFS DO WHILE (IFS.GT.0) C -- I is not a leave node and has a son node IFS id%DAD_STEPS(STEP_TMP(IFS)) = I IFS = FREREPTR(IFS) ENDDO END DO C C C Following arrays (PROCNODE and IKEEPALLOC) not used anymore C during analysis IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (associated(FREREPTR)) DEALLOCATE(FREREPTR) NULLIFY(FREREPTR) IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR) NULLIFY(NFSIZPTR) ENDIF IF (KEEP(494).NE.0) THEN C{ IF (id%MYID.EQ.MASTER) THEN IF (PROKG) THEN CALL MUMPS_SECDEB(TIMEG) END IF ENDIF C ======================================================= C Compute a grouping of variables for LR approximations. C Grouping may be performed on a distributed matrix C ======================================================= C C ======================================= C I/ Prepare data before call to grouping C ======================================= LUMAT_REMAP_DIST_AVAIL = .FALSE. LUMAT_REMAP_CENT_AVAIL = .FALSE. C IF (LUMAT_AVAIL) THEN C Use clean symmetrized LUMAT matrix available ALLOCATE(MAPCOL(id%KEEP(28)), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C CALL MUMPS_INIALIZE_REDIST_LUMAT ( & id%INFO, id%ICNTL, id%KEEP, id%COMM, id%MYID, NBLK, & id%NPROCS, & LUMAT, id%PROCNODE_STEPS(1), id%KEEP(28), MAPCOL, & LUMAT_REMAP, NBRECORDS, STEP_TMP(1)) C INFO(1) has been broadcasted already in routine IF ( id%INFO(1).LT.0 ) GOTO 500 C C -- Redistribute LUMAT into LU_REMAP relying on procnode CALL MUMPS_AB_DIST_LMAT_TO_LUMAT ( & .FALSE., ! do not UNFOLD & .TRUE., ! MAPCOL in NSTEPS=> STEP array needed & id%INFO, id%ICNTL, id%COMM, id%MYID, NBLK, id%NPROCS, & LUMAT, MAPCOL, id%KEEP(28), STEP_TMP(1), NBLK, & LUMAT_REMAP, NBRECORDS, NSEND8, NLOCAL8 & ) LUMAT_REMAP_DIST_AVAIL = .TRUE. CALL MUMPS_AB_FREE_LMAT(LUMAT,KEEP(147)) C Distribute SIZEOFBLOCKS that was defined only on master CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, & id%COMM, IERR ) C} ELSE IF ( LMAT_BLOCK_AVAIL ) THEN C{ Centralized matrix and clean LMAT_BLOCK available C IF (id%MYID.EQ.MASTER) THEN C CALL MUMPS_AB_CLEANLMAT_TO_LUMAT ( & LMAT_BLOCK, LUMAT_REMAP, KEEP(147), & INFO(1), ICNTL(1)) LUMAT_REMAP_CENT_AVAIL=.TRUE. C --- LMAT_BLOCK not needed anymore CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK,KEEP(147)) C ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C} ELSE IF ((KEEP(54).EQ.3).AND.(KEEP(13).EQ.0) & .AND. KEEP(487).EQ.1) THEN C{ C Matrix is distributed on entry and compression not requested C (this will be the case when ICNTL(15).EQ.0 and C // analysis, or Schur, etc...) C note that with distributed matrix and centralized ordering C compression is forced to limit memory peak) C Free centralized matrix before grouping to C limit memory peak IF (GATHER_MATRIX_ALLOCATED) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF GATHER_MATRIX_ALLOCATED= .FALSE. ENDIF IF (.NOT. I_AM_SLAVE .OR. ! non-working master & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc ENDIF ALLOCATE(MAPCOL(id%KEEP(28)), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C C Build MAPCOL and LUMAT_REMAP mapped according C to MAPCOL (outputs available on all MPI procs). CALL MUMPS_AB_DCOORD_TO_DTREE_LUMAT ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & id%PROCNODE_STEPS(1), id%KEEP(28), STEP_TMP(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & MAPCOL, LUMAT_REMAP ) LUMAT_REMAP_DIST_AVAIL = .TRUE. IF (INFO(1).GE.0) THEN C SIZEOFBLOCKS needed on all procs during MPI grouping ALLOCATE(SIZEOFBLOCKS(NBLK), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= NBLK ENDIF DO I=1, NBLK SIZEOFBLOCKS(I) = 1 ENDDO ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C} ELSE IF ((KEEP(54).EQ.3) .AND. (KEEP(487).NE.1) & ) THEN C{ C Grouping preparation on slaves: C If the input matrix is distributed C the graph is centralized to compute the C clustering. C CALL CMUMPS_GATHER_MATRIX(id) GATHER_MATRIX_ALLOCATED = .TRUE. C} ENDIF C ============ C ============ C II/ GROUPING C ============ IF (LUMAT_REMAP_DIST_AVAIL) THEN C{ Distributed memory based grouping is used IF (id%MYID.NE.MASTER) THEN ALLOCATE(FILS_TMP(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NBLK ENDIF ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL MPI_BCAST( id%ND_STEPS(1), KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL CMUMPS_AB_LR_MPI_GROUPING(NBLK, & MAPCOL, id%KEEP(28), & id%KEEP(28), LUMAT_REMAP, FILS_TMP(1), & id%FRERE_STEPS, & id%DAD_STEPS, STEP_TMP(1), id%NA, & id%LNA, LRGROUPS_TMP(1), SIZEOFBLOCKS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), id%KEEP(142), & LPOK, LP, id%COMM, id%MYID, id%NPROCS, & id%KEEP(1), id%ND_STEPS) IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) IF (id%MYID.NE.MASTER) DEALLOCATE(FILS_TMP) C} ELSE IF (id%MYID.EQ.MASTER) THEN C{ IF (LUMAT_REMAP_CENT_AVAIL) THEN C{ C IDUMMY_ARRAY(1) = -1 CALL CMUMPS_AB_LR_MPI_GROUPING(NBLK, & IDUMMY_ARRAY, 1, & id%KEEP(28), LUMAT_REMAP, FILS_TMP, & id%FRERE_STEPS, & id%DAD_STEPS, STEP_TMP, id%NA, & id%LNA, LRGROUPS_TMP, SIZEOFBLOCKS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), id%KEEP(142), & LPOK, LP, id%COMM, id%MYID, id%NPROCS, & id%KEEP(1), id%ND_STEPS) C} ELSE C{ grouping based on centralized matrix IF (KEEP(469).EQ.0) THEN CALL CMUMPS_LR_GROUPING(id%N, id%KEEP8(28), id%KEEP(28), & id%IRN, & id%JCN, FILS_TMP, id%FRERE_STEPS, & id%DAD_STEPS, id%NE_STEPS, STEP_TMP, id%NA, & id%LNA, LRGROUPS_TMP, & id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(10), & id%KEEP(54), id%KEEP(142), & LPOK, LP, GATHER_MATRIX_ALLOCATED, & id%KEEP(1), id%ND_STEPS) ELSE CALL CMUMPS_LR_GROUPING_NEW(id%N, id%KEEP8(28), & id%KEEP(28), id%IRN, & id%JCN, FILS_TMP, id%FRERE_STEPS, & id%DAD_STEPS, STEP_TMP, id%NA, & id%LNA, LRGROUPS_TMP, id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), id%KEEP(142), & LPOK, LP, GATHER_MATRIX_ALLOCATED, & id%KEEP(1), id%ND_STEPS) ENDIF C} ENDIF C} ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C update KEEP(142): maximum group size CALL MPI_BCAST( KEEP(142), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ============ C III/ CLEANUP C ============ C Free LUMAT_REMAP if allocated IF (LUMAT_REMAP_DIST_AVAIL.OR.LUMAT_REMAP_CENT_AVAIL) & CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP,KEEP(147)) IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF ( (KEEP(54).EQ.3) .AND. (KEEP(244).EQ.2).AND. & (KEEP(487).NE.1) ) THEN C Cleanup the irn and jcn arrays filled up by the C cmumps_gather_matrix above. It might have been done C during grouping IF (GATHER_MATRIX_ALLOCATED) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF GATHER_MATRIX_ALLOCATED= .FALSE. ENDIF END IF IF (PROKG) THEN CALL MUMPS_SECFIN(TIMEG) WRITE(MPG,145) TIMEG END IF C} Grouping: KEEP(494) .NE. 0 ENDIF C ALLOCATE id%FILS(id%N)on all procs possibly using mpi3 CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 C C ALLOCATE id%STEP(id%N)on all procs possibly using mpi3 CALL MUMPS_REALLOC(id%STEP, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 C C ALLOCATE id%LRGROUPS on all procs possibly using mpi3 C compute size of id%LRGROUPS in KEEP(280) IF (id%KEEP(494).EQ.0) THEN C not used id%KEEP(280) = 1 ELSE id%KEEP(280) = id%N ENDIF CALL MUMPS_REALLOC(id%LRGROUPS, id%KEEP(280), id%INFO, LP, & FORCE=.TRUE., & STRING='id%LRGROUPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 IF (id%MYID.EQ.MASTER) THEN C{ IF (KEEP(13).NE.0) THEN C{ =========== C Expand tree C =========== C Current tree is relative to the analysis by block. C Expand the tree on the master if compression is effective C (in all cases, grouping done or not) IF (NBLK.LT.id%N.OR.(.NOT.BLKVAR_ALLOCATED)) THEN C { C even if NBLK.EQ.N BLKVAR provided by user might hold C a permutation of the variables and this expand_tree_steps C should also be called C Expand FILS_TMP, STEP_TMP into id%FILS, id%STEP C and update arrays of size NSTEPS IF (NB_NIV2.EQ.0) THEN IDUMMY_ARRAY(1) = -9999 PAR2_NODESPTR => IDUMMY_ARRAY(1:1) SIZE_PAR2_NODESPTR=1 ELSE PAR2_NODESPTR => PAR2_NODES(1:NB_NIV2) SIZE_PAR2_NODESPTR=NB_NIV2 ENDIF CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 CALL CMUMPS_EXPAND_TREE_STEPS (id%ICNTL, & id%N, NBLK, BLKPTR_PTRLOC(1), BLKVAR_PTRLOC(1), & FILS_TMP(1), id%FILS(1), id%KEEP(28), & STEP_TMP(1), id%STEP(1), & PAR2_NODESPTR(1), SIZE_PAR2_NODESPTR, & id%DAD_STEPS(1), id%FRERE_STEPS(1), & id%NA(1), id%LNA, & LRGROUPS_TMP(1), SIZELRGROUPS_TMP, & id%LRGROUPS(1), KEEP(280), & id%KEEP(20), id%KEEP(38), KEEP(494) & ) NULLIFY(PAR2_NODESPTR) C C } ELSE C{ NBLK=N C perform local copies DO I=1, NBLK id%STEP(I) = STEP_TMP(I) id%FILS(I) = FILS_TMP(I) ENDDO IF (id%KEEP(494).NE.0) THEN DO I=1, id%KEEP(280) id%LRGROUPS(I) = LRGROUPS_TMP(I) ENDDO ENDIF C} ENDIF C} ELSE C{ NBLK=N C perform local copies DO I=1, NBLK id%STEP(I) = STEP_TMP(I) id%FILS(I) = FILS_TMP(I) ENDDO IF (id%KEEP(494).NE.0) THEN C we copy only in case of BLR since C LRGROUPS_TMP is otherwise allocated C and not used/initialized DO I=1, id%KEEP(280) id%LRGROUPS(I) = LRGROUPS_TMP(I) ENDDO ENDIF C} ENDIF C C ------------------------------------------- C Adjust LR_GROUPING to bound size of groups C and update KEEP(142): maximum group size C that should then be broadcasted again C ------------------------------------------- IF (id%N.GT.NBLK.AND.KEEP(494).NE.0) THEN CALL MUMPS_ADJUST_SIZE_LRGROUPS ( & id%STEP(1), id%FILS(1), id%N, & id%ND_STEPS(1), id%KEEP(28), id%KEEP(1), & id%LRGROUPS(1), INFO(1), INFO(2)) ENDIF C} ENDIF C update KEEP(142): maximum group size that might have been C updated in MUMPS_ADJUST_SIZE_LRGROUPS CALL MPI_BCAST( KEEP(142), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C 97 CONTINUE C IF (allocated(STEP_TMP)) DEALLOCATE(STEP_TMP) IF (allocated(LRGROUPS_TMP)) DEALLOCATE(LRGROUPS_TMP) IF (allocated(FILS_TMP)) DEALLOCATE(FILS_TMP) C C CALL MUMPS_REALLOC(id%SYM_PERM, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF (id%MYID.EQ.MASTER) THEN C ================================================================= C Reorder the tree using a variant of Liu's algorithm. Note that C REORDER_TREE MUST always be called since it sorts NA (the list of C leaves) in a valid order in the sense of a depth-first traversal. C ================================================================= CALL CMUMPS_REORDER_TREE(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%KEEP(70), & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(215), & id%KEEP(234), id%KEEP(55), id%KEEP(199), & id%PROCNODE_STEPS(1),id%NSLAVES,PEAK,id%KEEP(90) & ) IF(id%KEEP(261).EQ.1)THEN CALL MUMPS_SORT_STEP(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%INFO(1), & id%ICNTL(1),id%PROCNODE_STEPS(1),id%NSLAVES & ) ENDIF C Compute and export some global information on the tree needed by C dynamic schedulers during the factorization. The type of C information depends on the selected strategy. IF ((id%KEEP(76).GE.4).OR.(id%KEEP(76).GE.6).OR. & (id%KEEP(47).EQ.4).OR.((id%KEEP(81).GT.0) & .AND.(id%KEEP(47).GE.2)))THEN IS_BUILD_LOAD_MEM_CALLED=.TRUE. IF ((id%KEEP(47) .EQ. 4).OR. & (( id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN IF(id%NSLAVES.GT.1) THEN C NBSA is the total number of subtrees and C is an upperbound of the local number of C subtrees SIZE_TEMP_MEM = id%NBSA ELSE C Only one processor, NA(2) is the number of leaves SIZE_TEMP_MEM = id%NA(2) ENDIF ELSE SIZE_TEMP_MEM = 1 ENDIF IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN SIZE_DEPTH_FIRST=id%KEEP(28) ELSE SIZE_DEPTH_FIRST=1 ENDIF allocate(TEMP_MEM(SIZE_TEMP_MEM,id%NSLAVES),STAT=allocok) IF (allocok .NE.0) THEN INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_MEM' END IF GOTO 80 !! FIXME propagate error END IF allocate(TEMP_LEAF(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_LEAF' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 !! FIXME propagate error end if allocate(TEMP_SIZE(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_SIZE' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 end if allocate(TEMP_ROOT(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_ROOT' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 end if allocate(DEPTH_FIRST(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'DEPTH_FIRST' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if ALLOCATE(DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'DEPTH_FIRST_SEQ' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if ALLOCATE(SBTR_ID(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'SBTR_ID' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if IF(id%KEEP(76).EQ.5)THEN C We reuse the same variable as before SIZE_COST_TRAV=id%KEEP(28) ELSE SIZE_COST_TRAV=1 ENDIF allocate(COST_TRAV_TMP(SIZE_COST_TRAV),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'COST_TRAV_TMP' END IF INFO(1)= -7 INFO(2)= SIZE_COST_TRAV GOTO 80 END IF IF(id%KEEP(76).EQ.5)THEN IF(id%KEEP(70).EQ.0)THEN id%KEEP(70)=5 ENDIF IF(id%KEEP(70).EQ.1)THEN id%KEEP(70)=6 ENDIF ENDIF IF(id%KEEP(76).EQ.4)THEN IF(id%KEEP(70).EQ.0)THEN id%KEEP(70)=3 ENDIF IF(id%KEEP(70).EQ.1)THEN id%KEEP(70)=4 ENDIF ENDIF CALL CMUMPS_BUILD_LOAD_MEM_INFO(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%KEEP(70), & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(47), & id%KEEP(81),id%KEEP(76),id%KEEP(215), & id%KEEP(234), id%KEEP(55), id%KEEP(199), & id%PROCNODE_STEPS(1),TEMP_MEM,id%NSLAVES, & SIZE_TEMP_MEM, PEAK,id%KEEP(90),SIZE_DEPTH_FIRST, & SIZE_COST_TRAV,DEPTH_FIRST(1),DEPTH_FIRST_SEQ(1), & COST_TRAV_TMP(1), & TEMP_LEAF,TEMP_SIZE,TEMP_ROOT,SBTR_ID(1) & ) END IF ENDIF IF (id%MYID.EQ.MASTER) THEN CALL CMUMPS_SORT_PERM(id%N, id%NA(1), id%LNA, & id%NE_STEPS(1), id%SYM_PERM(1), & id%FILS(1), id%DAD_STEPS(1), & id%STEP(1), id%KEEP(28), & id%KEEP(60), id%KEEP(20), id%KEEP(38), & id%INFO(1) ) ENDIF C Root principal variable C for scalapack (KEEP(38)) or special serial root (KEEP(20)) C might have been updated C since root variables might have been permuted C and/or expanded (MUMPS_EXPAND_TREE) in case of compressed graph C It should thus be redistributed to all procs IF ( KEEP(494).NE.0 .OR. KEEP(13).NE.0 ) THEN C Value of KEEP(20) and KEEP(38) on master is always correct C + non-zero status is identical on all procs since 110 first C KEEP entries have been broadcasted IF (KEEP(38) .NE. 0) THEN CALL MPI_BCAST( id%KEEP(38), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF IF (KEEP(20) .NE. 0) THEN CALL MPI_BCAST( id%KEEP(20), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF ENDIF 80 CONTINUE C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C --------------------------------------------------- C Broadcast information computed on the master to C the slaves. C The matrix itself with numerical values and C integer data for the arrowhead/element description C will be received at the beginning of FACTO. C --------------------------------------------------- CALL MPI_BCAST( id%NA(1), id%LNA, 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%FILS(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%SYM_PERM(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%STEP(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF(KEEP(494).NE.0) THEN CALL MPI_BCAST( id%LRGROUPS(1), id%KEEP(280), MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF C C Store size of the stack memory for each C of the sequential subtree. IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN IF(associated(id%DEPTH_FIRST)) THEN DEALLOCATE(id%DEPTH_FIRST) ENDIF allocate(id%DEPTH_FIRST(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST' END IF GOTO 87 END IF IF(associated(id%DEPTH_FIRST_SEQ)) THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) ENDIF ALLOCATE(id%DEPTH_FIRST_SEQ(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(associated(id%SBTR_ID)) THEN DEALLOCATE(id%SBTR_ID) ENDIF ALLOCATE(id%SBTR_ID(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(id%MYID.EQ.MASTER)THEN id%DEPTH_FIRST(1:id%KEEP(28))=DEPTH_FIRST(1:id%KEEP(28)) id%DEPTH_FIRST_SEQ(1:id%KEEP(28))= & DEPTH_FIRST_SEQ(1:id%KEEP(28)) id%SBTR_ID(1:KEEP(28))=SBTR_ID(1:KEEP(28)) ENDIF CALL MPI_BCAST( id%DEPTH_FIRST(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%DEPTH_FIRST_SEQ(1), id%KEEP(28), & MPI_INTEGER,MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%SBTR_ID(1), id%KEEP(28), & MPI_INTEGER,MASTER, id%COMM, IERR ) ELSE IF(associated(id%DEPTH_FIRST)) THEN DEALLOCATE(id%DEPTH_FIRST) ENDIF allocate(id%DEPTH_FIRST(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST' END IF GOTO 87 END IF IF(associated(id%DEPTH_FIRST_SEQ)) THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) ENDIF ALLOCATE(id%DEPTH_FIRST_SEQ(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(associated(id%SBTR_ID)) THEN DEALLOCATE(id%SBTR_ID) ENDIF ALLOCATE(id%SBTR_ID(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF id%SBTR_ID(1)=0 id%DEPTH_FIRST(1)=0 id%DEPTH_FIRST_SEQ(1)=0 ENDIF IF(id%KEEP(76).EQ.5)THEN IF(associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) ENDIF allocate(id%COST_TRAV(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%COST_TRAV' END IF INFO(1)= -7 INFO(2)= id%KEEP(28) GOTO 87 END IF IF(id%MYID.EQ.MASTER)THEN id%COST_TRAV(1:id%KEEP(28))= & dble(COST_TRAV_TMP(1:id%KEEP(28))) ENDIF CALL MPI_BCAST( id%COST_TRAV(1), id%KEEP(28), & MPI_DOUBLE_PRECISION,MASTER, id%COMM, IERR ) ELSE IF(associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) ENDIF allocate(id%COST_TRAV(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%COST_TRAV(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF id%COST_TRAV(1)=0.0d0 ENDIF IF (id%KEEP(47) .EQ. 4 .OR. & ((id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN IF(id%MYID .EQ. MASTER)THEN DO K=1,id%NSLAVES DO J=1,SIZE_TEMP_MEM IF(TEMP_MEM(J,K) < 0.0D0) GOTO 666 ENDDO 666 CONTINUE J=J-1 IF (id%KEEP(46) == 1) THEN IDEST = K - 1 ELSE IDEST = K ENDIF IF (IDEST .NE. MASTER) THEN CALL MPI_SEND(J,1,MPI_INTEGER,IDEST,0, & id%COMM,IERR) CALL MPI_SEND(TEMP_MEM(1,K),J,MPI_DOUBLE_PRECISION, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_LEAF(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_SIZE(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_ROOT(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) ELSE IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%NBSA_LOCAL = J id%MEM_SUBTREE(1:J)=TEMP_MEM(1:J,1) IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_ROOT_SBTR(1:J)=TEMP_ROOT(1:J,1) IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_FIRST_LEAF' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_FIRST_LEAF(1:J)=TEMP_LEAF(1:J,1) IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_NB_LEAF' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_NB_LEAF(1:J)=TEMP_SIZE(1:J,1) ENDIF ENDDO ELSE CALL MPI_RECV(id%NBSA_LOCAL,1,MPI_INTEGER, & MASTER,0,id%COMM,STATUS, IERR) IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'MY_FIRST_LEAF' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'MY_NB_LEAF' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF CALL MPI_RECV(id%MEM_SUBTREE(1),id%NBSA_LOCAL, & MPI_DOUBLE_PRECISION,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_FIRST_LEAF(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_NB_LEAF(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_ROOT_SBTR(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) ENDIF ELSE id%NBSA_LOCAL = -999999 IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_FIRST_LEAF(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_NB_LEAF(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF ENDIF IF(id%MYID.EQ.MASTER)THEN IF(IS_BUILD_LOAD_MEM_CALLED)THEN DEALLOCATE(TEMP_MEM) DEALLOCATE(TEMP_SIZE) DEALLOCATE(TEMP_ROOT) DEALLOCATE(TEMP_LEAF) DEALLOCATE(COST_TRAV_TMP) DEALLOCATE(DEPTH_FIRST) DEALLOCATE(DEPTH_FIRST_SEQ) DEALLOCATE(SBTR_ID) ENDIF ENDIF 87 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C NB_NIV2 = KEEP(56) ! KEEP(1:110) was broadcast earlier C NB_NIV2 is now available on all processors. IF ( NB_NIV2.GT.0 ) THEN C Allocate arrays on slaves if (id%MYID.ne.MASTER) then IF (associated(id%CANDIDATES)) THEN DEALLOCATE(id%CANDIDATES) ENDIF allocate(PAR2_NODES(NB_NIV2), & id%CANDIDATES(id%NSLAVES+1,NB_NIV2), & STAT=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= NB_NIV2*(id%NSLAVES+1) IF ( LPOK ) THEN WRITE(LP, 150) 'PAR2_NODES/id%CANDIDATES' END IF end if end if CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL MPI_BCAST(PAR2_NODES(1),NB_NIV2, & MPI_INTEGER, MASTER, id%COMM, IERR ) IF (KEEP(24) .NE.0 ) THEN CALL MPI_BCAST(id%CANDIDATES(1,1), & (NB_NIV2*(id%NSLAVES+1)), & MPI_INTEGER, MASTER, id%COMM, IERR ) ENDIF ENDIF IF ( associated(id%ISTEP_TO_INIV2)) THEN DEALLOCATE(id%ISTEP_TO_INIV2) NULLIFY(id%ISTEP_TO_INIV2) ENDIF IF ( associated(id%I_AM_CAND)) THEN DEALLOCATE(id%I_AM_CAND) NULLIFY(id%I_AM_CAND) ENDIF IF (NB_NIV2.EQ.0) THEN C allocate dummy arrays C ISTEP_TO_INIV2 will never be used C Add a parameter SIZE_ISTEP_TO_INIV2 and make C it always available in a keep(71) id%KEEP(71) = 1 ELSE id%KEEP(71) = id%KEEP(28) ENDIF allocate(id%ISTEP_TO_INIV2(id%KEEP(71)), & id%I_AM_CAND(max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'id%ISTEP_TO_INIV2' WRITE(LP, 150) 'id%TAB_POS_IN_PERE' END IF INFO(1)= -7 IF (NB_NIV2.EQ.0) THEN INFO(2)= 2 ELSE INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2) END IF GOTO 321 ENDIF IF ( NB_NIV2 .GT.0 ) THEN C If BLR grouping was performed then PAR2_NODES(INIV2) C might then point to a non principal variable C for which STEP might be negative C id%ISTEP_TO_INIV2 = -9999 DO INIV2 = 1, NB_NIV2 INN = PAR2_NODES(INIV2) id%ISTEP_TO_INIV2(abs(id%STEP(INN))) = INIV2 END DO CALL CMUMPS_BUILD_I_AM_CAND( id%NSLAVES, KEEP(79), & NB_NIV2, id%MYID_NODES, & id%CANDIDATES(1,1), id%I_AM_CAND(1) ) ENDIF IF ( I_AM_SLAVE ) THEN IF (associated(id%FUTURE_NIV2)) THEN DEALLOCATE(id%FUTURE_NIV2) NULLIFY(id%FUTURE_NIV2) ENDIF allocate(id%FUTURE_NIV2(id%NSLAVES), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'FUTURE_NIV2' END IF INFO(1)= -7 INFO(2)= id%NSLAVES GOTO 321 ENDIF id%FUTURE_NIV2=0 DO INIV2 = 1, NB_NIV2 IDEST = MUMPS_PROCNODE( & id%PROCNODE_STEPS(abs(id%STEP(PAR2_NODES(INIV2)))), & id%KEEP(199)) id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1 ENDDO C Allocate id%TAB_POS_IN_PERE, C TAB_POS_IN_PERE is an array of size (id%NSLAVES+2,NB_NIV2) C where NB_NIV2 is the number of type 2 nodes in the tree. IF ( associated(id%TAB_POS_IN_PERE)) THEN DEALLOCATE(id%TAB_POS_IN_PERE) NULLIFY(id%TAB_POS_IN_PERE) ENDIF allocate(id%TAB_POS_IN_PERE(id%NSLAVES+2,max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'id%ISTEP_TO_INIV2' WRITE(LP, 150) 'id%TAB_POS_IN_PERE' END IF INFO(1)= -7 IF (NB_NIV2.EQ.0) THEN INFO(2)= 2 ELSE INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2) END IF GOTO 321 ENDIF END IF C deallocate PAR2_NODES that was computed C on master and broadcasted on all slaves IF (NB_NIV2.GT.0) DEALLOCATE (PAR2_NODES) 321 CONTINUE C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C IF ( KEEP(38) .NE. 0 ) THEN C ------------------------- C Initialize root structure C ------------------------- CALL CMUMPS_INIT_ROOT_ANA( id%MYID, & id%NSLAVES, id%N, idintr%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 idintr%root%yes = .FALSE. END IF IF ( KEEP(38) .NE. 0 .and. I_AM_SLAVE ) THEN C ----------------------------------------------- C Check if at least one processor belongs to the C root. In the case where all of them have MYROW C equal to -1, this could be a problem due to the C BLACS. (mpxlf90_r and IBM BLACS). C ----------------------------------------------- CALL MPI_ALLREDUCE(idintr%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 ( idintr%root%MYROW .LT. -1 .OR. & idintr%root%MYCOL .LT. -1 ) THEN INFO(1) = -25 INFO(2) = 0 END IF IF ( LPOK .AND. INFO(1) == -25 ) THEN WRITE(LP, '(A)') & 'Problem with your version of the BLACS.' WRITE(LP, '(A)') 'Try using a BLACS version from netlib.' ENDIF END IF C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C C C CALL CMUMPS_ANA_ARROWHEADS_WRAPPER ( id, & GATHER_MATRIX_ALLOCATED ) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL CMUMPS_ANA_COMPUTE_ESTIMATES (id,idintr) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C ------------------------- C Define a specific mapping C for the user C ------------------------- IF ( id%MYID. eq. MASTER .AND. KEEP(54) .eq. 1 ) THEN IF (associated( id%MAPPING)) THEN DEALLOCATE( id%MAPPING) ENDIF allocate( id%MAPPING(id%KEEP8(28)), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28), INFO(2)) IF ( LPOK ) THEN WRITE(LP, 150) 'id%MAPPING' END IF GOTO 92 END IF allocate(IWtemp( id%N ), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-7 INFO(2)=id%N IF ( LPOK ) THEN WRITE(LP, 150) 'IWtemp(N)' END IF GOTO 92 END IF IF ( id%KEEP8(28) .EQ. 0_8 ) THEN IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY ELSE IRN_PTR => id%IRN JCN_PTR => id%JCN ENDIF CALL CMUMPS_BUILD_MAPPING( & id%N, id%MAPPING(1), id%KEEP8(28), & IRN_PTR(1),JCN_PTR(1), id%PROCNODE_STEPS(1), & id%STEP(1), & id%NSLAVES, id%SYM_PERM(1), & id%FILS(1), IWtemp, id%KEEP(1),id%KEEP8(1), & idintr%root%MBLOCK, idintr%root%NBLOCK, & idintr%root%NPROW, idintr%root%NPCOL ) DEALLOCATE( IWtemp ) 92 CONTINUE END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C 500 CONTINUE C Deallocate allocated working space IF (allocated(FILS_TMP)) DEALLOCATE(FILS_TMP) IF (allocated(STEP_TMP)) DEALLOCATE(STEP_TMP) IF (allocated(LRGROUPS_TMP)) DEALLOCATE(LRGROUPS_TMP) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (allocated(WORK2ALLOC)) DEALLOCATE(WORK2ALLOC) IF (KEEP(244).NE.1) THEN IF (allocated(PARAORD_to_idCOMM)) & DEALLOCATE(PARAORD_to_idCOMM) IF (COMM_PARAORD_ALLOCATED) THEN IF (COMM_PARAORD.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_FREE( COMM_PARAORD, IERR ) COMM_PARAORD_ALLOCATED = .FALSE. ENDIF ENDIF IF (COMM_PARASYMB_ALLOCATED) THEN IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_FREE( COMM_PARASYMB, IERR ) COMM_PARASYMB_ALLOCATED = .FALSE. ENDIF ENDIF ENDIF IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE) IF (allocated(XNODEL)) DEALLOCATE(XNODEL) IF (allocated(NODEL)) DEALLOCATE(NODEL) IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK,KEEP(147)) CALL MUMPS_AB_FREE_LMAT(LUMAT,KEEP(147)) CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP,KEEP(147)) CALL MUMPS_AB_FREE_GCOMP(GCOMP, MEMCNT) CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST, MEMCNT) C Standard deallocations (error or not) IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR) IF (associated(FREREPTR)) DEALLOCATE(FREREPTR) nullify(FREREPTR, NFSIZPTR) IF (associated(BLKPTR_PTRLOC).AND.BLKPTR_ALLOCATED) THEN DEALLOCATE(BLKPTR_PTRLOC) nullify(BLKPTR_PTRLOC) ENDIF IF (associated(BLKVAR_PTRLOC).AND.BLKVAR_ALLOCATED) THEN DEALLOCATE(BLKVAR_PTRLOC) nullify(BLKVAR_PTRLOC) ENDIF KEEP8(26)=max(1_8,KEEP8(26)) KEEP8(27)=max(1_8,KEEP8(27)) RETURN 110 FORMAT(/' ****** ANALYSIS STEP ********'/) 145 FORMAT(' ELAPSED TIME SPENT IN BLR CLUSTERING =',F12.4) 150 FORMAT( & /' ** FAILURE DURING CMUMPS_ANA_DRIVER, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE CMUMPS_ANA_DRIVER SUBROUTINE CMUMPS_ANA_CHECK_KEEP(id, I_AM_SLAVE) !$ USE OMP_LIB, ONLY : omp_get_max_threads C C Purpose C ======= C This subroutine decodes the control parameters, C stores them in the KEEP array, and performs a C consistency check on the KEEP array. USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id LOGICAL :: I_AM_SLAVE C internal variables INTEGER :: LP, MP, MPG, I INTEGER :: MASTER LOGICAL :: PROK, PROKG, LPOK PARAMETER( MASTER = 0 ) C LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) C Re-intialize few KEEPs entries corresponding C to stat that are incremented such C the number of split nodes: id%KEEP(61)=0 IF (id%MYID.eq.MASTER) THEN id%KEEP(38) = 0 id%KEEP(20) = 0 CALL CMUMPS_ANA_CHECK_ICNTL48 ( id ) id%KEEP(256) = id%ICNTL(7) ! copy ordering option id%KEEP(252) = id%ICNTL(32) IF (id%KEEP(252) < 0 .OR. id%KEEP(252) > 1 ) THEN id%KEEP(252) = 0 ENDIF C Which factors to store id%KEEP(251) = id%ICNTL(31) IF (id%KEEP(251) < 0 .OR. id%KEEP(251) > 2 ) THEN id%KEEP(251)=0 ENDIF C For unsymmetric matrices, if forward solve C performed during facto, C no reason to store L factors at all. Reset C KEEP(251) accordingly... except if the user C tells that no solve is needed. IF (id%KEEP(50) .EQ. 0 .AND. id%KEEP(252).EQ.1) THEN IF (id%KEEP(251) .NE. 1) id%KEEP(251) = 2 ENDIF C Symmetric case, even if no backward needed, C store all factors IF (id%KEEP(50) .NE.0 .AND. id%KEEP(251) .EQ. 2) THEN id%KEEP(251) = 0 ENDIF C Case of solve not needed: IF (id%KEEP(251) .EQ. 1) THEN id%KEEP(201) = -1 C In that case, id%ICNTL(22) will C be ignored in future phases ELSE C Reset id%KEEP(201) -- typically for the case C of a previous analysis with KEEP(201)=-1 id%KEEP(201) = 0 ENDIF IF (id%KEEP(252).EQ.1) THEN id%KEEP(253) = id%NRHS IF (id%KEEP(253) .LE. 0) THEN id%INFO(1)=-42 id%INFO(2)=id%NRHS RETURN ENDIF ELSE id%KEEP(253) = 0 ENDIF ENDIF IF ( (id%KEEP(24).NE.0) .AND. & id%NSLAVES.eq.1 ) THEN id%KEEP(24) = 0 END IF IF ( (id%KEEP(24).EQ.0) .AND. & id%NSLAVES.GT.1 ) THEN id%KEEP(24) = 8 ENDIF IF ( (id%KEEP(24).NE.0) .AND. (id%KEEP(24).NE.1) .AND. & (id%KEEP(24).NE.8) .AND. (id%KEEP(24).NE.10) .AND. & (id%KEEP(24).NE.12) .AND. (id%KEEP(24).NE.14) .AND. & (id%KEEP(24).NE.16) .AND. (id%KEEP(24).NE.18)) THEN id%KEEP(24) = 8 END IF C**************************************************** C C The master is doing most of the work C C NOTE: Treatment of the errors on the master= C Go to the next SPMD part of the code in which C the first statement must be a call to PROPINFO C C**************************************************** C ========================================= C Check (raise error or modify) some input C parameters or KEEP values on the master. C ========================================= id%KEEP8(21) = int(id%KEEP(85),8) IF ( id%MYID .EQ. MASTER ) THEN C ---------------------------- C Save id%ICNTL(18) (distributed C matrix on entry) in id%KEEP(54) C ---------------------------- id%KEEP(54) = id%ICNTL(18) IF ( id%KEEP(54) .LT. 0 .or. id%KEEP(54).GT.3 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Out-of-range value for id%ICNTL(18).' WRITE(MPG, *) ' Used 0 ie matrix not distributed' END IF id%KEEP(54) = 0 END IF IF ( id%KEEP(54) .EQ. 1 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Option id%ICNTL(18)=1 is obsolete.' WRITE(MPG, *) ' We recommend not to use it.' WRITE(MPG, *) ' It will disappear in a future release' END IF END IF C ----------------------------------------- C Save id%ICNTL(5) (matrix format) in id%KEEP(55) C ----------------------------------------- id%KEEP(55) = id%ICNTL(5) IF ( id%KEEP(55) .LT. 0 .OR. id%KEEP(55) .GT. 1 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Out-of-range value for id%ICNTL(5).' WRITE(MPG, *) ' Used 0 ie matrix is assembled' END IF id%KEEP(55) = 0 END IF id%KEEP(60) = id%ICNTL(19) IF ( id%KEEP( 60 ) .LE. 0 ) id%KEEP( 60 ) = 0 IF ( id%KEEP( 60 ) .GT. 3 ) id%KEEP( 60 ) = 0 IF (id%KEEP(60) .NE. 0 .AND. id%SIZE_SCHUR == 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Schur option ignored because SIZE_SCHUR=0' ENDIF id%KEEP(60)=0 END IF C --------------------------------------- C Save SIZE_SCHUR in a KEEP, for possible C check at factorization and solve phases C --------------------------------------- IF ( id%KEEP(60) .NE.0 ) THEN id%KEEP(116) = id%SIZE_SCHUR IF (id%SIZE_SCHUR .LT. 0 .OR. id%SIZE_SCHUR .GE. id%N) THEN id%INFO(1)=-49 id%INFO(2)=id%SIZE_SCHUR RETURN ENDIF C List of Schur variables provided by user. IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 8 RETURN ELSE IF (size(id%LISTVAR_SCHUR) 0 .AND. id%NBLOCK > 0 .AND. & id%NPROW > 0 .AND. id%NPCOL > 0 ) THEN IF (id%NPROW *id%NPCOL .LE. id%NSLAVES) THEN C We will eventually have to "symmetrize the C Schur complement. For that NBLOCK and MBLOCK C must be equal. IF (id%MBLOCK .NE. id%NBLOCK ) THEN id%INFO(1)=-31 id%INFO(2)=id%MBLOCK - id%NBLOCK RETURN ENDIF ENDIF ENDIF ENDIF C Check the ordering strategy and compatibility with C other control parameters id%KEEP(244) = id%ICNTL(28) IF ((id%KEEP(244) .LT. 0) .OR. (id%KEEP(244) .GT. 2)) THEN id%KEEP(244) = 0 ENDIF IF(id%KEEP(244) .EQ. 0) THEN ! Automatic C One could check for availability of parallel ordering C tools, or for possible options incompatible with // C analysis to decide (e.g. avoid returning an error if C // analysis not compatible with some option but user C lets MUMPS decide to choose sequential or paralllel C analysis) C Current strategy for automatic is sequential analysis id%KEEP(244) = 1 ENDIF #if ! defined (ptscotch) && ! defined(parmetis) && ! defined(parmetis3) IF (id%KEEP(244) .EQ. 2) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("ParMETIS and PT-SCOTCH not available.")') END IF RETURN END IF #endif id%KEEP(245) = id%ICNTL(29) IF ((id%KEEP(245) .LT. 0) .OR. (id%KEEP(245) .GT. 2)) THEN id%KEEP(245) = 0 END IF IF (id%KEEP(244) .EQ. 2) THEN IF ( id%KEEP(245).EQ.0 ) THEN #if defined(parmetis) || defined(parmetis3) id%KEEP(245) = 2 #elif defined(ptscotch) id%KEEP(245) = 1 #endif ENDIF ENDIF C #if ! defined(parmetis) && ! defined(parmetis3) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 2)) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("ParMETIS not available.")') END IF RETURN END IF #endif #if ! defined(ptscotch) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 1)) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("PT-SCOTCH not available.")') END IF RETURN END IF #endif IF (id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(55) .NE. 0) THEN id%INFO(1) = -39 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(5), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if the")') WRITE(LP, & '("matrix is not assembled")') ENDIF RETURN ELSE IF(id%KEEP(60) .NE. 0) THEN id%INFO(1) = -39 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(19), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if SCHUR")') WRITE(LP, & '("complement must be returned")') ENDIF RETURN END IF C In the case where there are too few processes to do C the parallel analysis we simply revert to sequential version IF(id%NSLAVES .LT. 2) THEN id%KEEP(244) = 1 IF(PROKG) WRITE(MPG, & '("Too few processes. & Reverting to sequential analysis")',advance='no') IF(id%KEEP(245) .EQ. 1) THEN C Scotch necessarily available because pt-scotch C is, otherwise an error would have occurred IF(PROKG) WRITE(MPG, '(" with SCOTCH.")') id%KEEP(256) = 3 ELSE IF(id%KEEP(245) .EQ. 2) THEN C Metis necessarily available because parmetis C is, otherwise an error would have occurred IF(PROKG) WRITE(MPG, '(" with Metis.")') id%KEEP(256) = 5 ELSE IF(PROKG) WRITE(MPG, '(".")') id%KEEP(256) = 7 END IF END IF C In the case where there the input matrix is too small to do C the parallel analysis we simply revert to sequential version IF(id%N .LE. 50) THEN id%KEEP(244) = 1 IF(PROKG) WRITE(MPG, & '("Input matrix is too small for the parallel & analysis. Reverting to sequential analysis")',advance='no') IF(id%KEEP(245) .EQ. 1) THEN IF(PROKG) WRITE(MPG, '(" with SCOTCH.")') id%KEEP(256) = 3 ELSE IF(id%KEEP(245) .EQ. 2) THEN IF(PROKG) WRITE(MPG, '(" with Metis.")') id%KEEP(256) = 5 ELSE IF(PROKG) WRITE(MPG, '(".")') id%KEEP(256) = 7 END IF END IF END IF id%INFOG(32) = id%KEEP(244) IF ( (id%KEEP(244) .EQ. 1) .AND. & (id%KEEP(256) .EQ. 1) ) THEN C ordering given, PERM_IN must be of size N IF ( .NOT. associated( id%PERM_IN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 3 RETURN ELSE IF ( size( id%PERM_IN ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 3 RETURN END IF ENDIF C Check KEEP(9-10) for level 2 IF (id%KEEP(9) .LE. 1 ) id%KEEP(9) = 500 IF ( id%KEEP8(21) .GT. 0_8 ) THEN IF ((id%KEEP8(21).LE.1_8) .OR. & (id%KEEP8(21).GT.int(id%KEEP(9),8))) & id%KEEP8(21) = int(min(id%KEEP(9),100),8) ENDIF C IF (id%KEEP(48). EQ. 1 ) id%KEEP(48) = -12345 C IF ( (id%KEEP(48).LT.0) .OR. (id%KEEP(48).GT.5) ) THEN id%KEEP(48)=5 ENDIF C Schur C Given ordering must be compatible with Schur variables. IF ( (id%KEEP(60) .NE. 0) .AND. (id%KEEP(256) .EQ. 1) ) THEN DO I = 1, id%SIZE_SCHUR IF (id%PERM_IN(id%LISTVAR_SCHUR(I)) & .EQ. id%N-id%SIZE_SCHUR+I) & CYCLE C ------------------------------- C Problem with PERM_IN: -22/3 C Above constrained explained in C doc of PERM_IN in user guide. C ------------------------------- id%INFO(1) = -4 id%INFO(2) = id%LISTVAR_SCHUR(I) RETURN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Ignoring user-ordering, because incompatible with Schur.' WRITE(MPG,'(A)') ' ** id%ICNTL(7) treated as 0.' END IF EXIT ENDDO END IF C C Note that schur is not compatible with C C 1/Max-trans DONE C 2/Null space C 3/Ordering given DONE C 4/Scaling C 5/Iterative Refinement C 6/Error analysis C 7/Parallel Analysis C C Graph modification prior to ordering (id%ICNTL(12) option) C id%KEEP (95) will hold the eventually modified value of id%ICNTL(12) C id%KEEP(95) = id%ICNTL(12) C reset to usual ordering (KEEP(95)=1) C - when matrix is not general symmetric C - for out-of-range values IF (id%KEEP(50).NE.2) id%KEEP(95) = 1 IF ((id%KEEP(95).GT.3).OR.(id%KEEP(95).LT.0)) id%KEEP(95) = 1 C MAX-TRANS C C id%KEEP (23) will hold the eventually modified value of id%ICNTL(6) C (maximum transversal if >= 1) C id%KEEP(23) = id%ICNTL(6) C C C -------------------------------------------- C Avoid max-trans unsymmetric permutation in case of C matrix is symmetric with SYM=1 or C ordering is given, C or matrix is in element form, or Schur is asked C or initial matrix is distributed C -------------------------------------------- IF (id%KEEP(23).LT.0.OR.id%KEEP(23).GT.7) id%KEEP(23) = 0 C still forbid max trans for SYM=1 case IF ( id%KEEP(50) .EQ. 1 ) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not needed with SYM=1 factorization' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(95) .GT. 1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) ignored: not needed with SYM=1 factorization' END IF ENDIF id%KEEP(95) = 1 END IF C IF (id%KEEP(60) .GT. 0) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not allowed because of Schur' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Scaling during analysis not allowed because of Schur' ENDIF id%KEEP(52) = 0 ENDIF C also forbid compressed/constrained ordering... IF (id%KEEP(95) .GT. 1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) option not allowed because of Schur' END IF ENDIF id%KEEP(95) = 1 END IF IF ( (id%KEEP(23) .NE. 0) .AND. (id%KEEP(256).EQ.1)) THEN id%KEEP(23) = 0 IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'because ordering is given' END IF END IF IF ( id%KEEP(256) .EQ. 1 ) THEN IF (id%KEEP(95) > 1 .AND. PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) option incompatible with given ordering' END IF id%KEEP(95) = 1 END IF IF (id%KEEP(54) .NE. 0) THEN IF( id%KEEP(23) .NE. 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'because matrix is distributed' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Scaling (ICNTL(8)) during analysis not ', & 'allowed because matrix is distributed)' ENDIF ENDIF id%KEEP(52) = 0 IF (id%KEEP(95) .GT. 1 .AND. MPG.GT.0) THEN WRITE(MPG,'(A,A)') & ' ** ICNTL(12) option not allowed because matrix is ', & 'distributed' ENDIF id%KEEP(95) = 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN IF( id%KEEP(23) .NE. 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'for matrices in elemental format' END IF id%KEEP(23) = 0 ENDIF IF (PROKG .AND. id%KEEP(52).EQ.-2) THEN WRITE(MPG,'(A)') & ' ** Scaling (ICNTL(8)) not allowed ', & 'for matrices in elemental format' ENDIF id%KEEP(52) = 0 id%KEEP(95) = 1 ENDIF C In the case where parallel analysis is done, column permutation C is not allowed IF(id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(23) .EQ. 7) THEN C Automatic hoice: set it to 0 id%KEEP(23) = 0 ELSE IF (id%KEEP(23) .GT. 0) THEN id%INFO(1) = -39 id%KEEP(23) = 0 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(6), ICNTL(28)")') WRITE(LP, & '("Maximum transversal not allowed & in parallel analysis")') ENDIF RETURN END IF END IF C -------------------------------------------- C Avoid distributed entry for element matrix. C -------------------------------------------- IF ( id%KEEP(54) .NE. 0 .AND. id%KEEP(55) .NE. 0 ) THEN id%KEEP(54) = 0 IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Distributed entry not available for element matrix' END IF ENDIF C ---------------------------------- C Choice of symbolic analysis option C ---------------------------------- IF (id%ICNTL(58).NE.1 .and. id%ICNTL(58).NE.2 & .and. id%ICNTL(58).NE.3 .and. id%ICNTL(58).NE.4 ) THEN C out of range values leads to default id%KEEP(106)=2 ELSE id%KEEP(106)=id%ICNTL(58) C Options 3 and 4 not available, reset to default IF (id%KEEP(106).EQ.4) id%KEEP(106)=2 IF (id%KEEP(106).EQ.3) id%KEEP(106)=2 ENDIF C modify input parameters to avoid incompatible C input data between ordering, scaling and maxtrans C note that if id%ICNTL(12)/id%KEEP(95) = 0 then C the automatic choice will be done in ANA_O IF(id%KEEP(50) .EQ. 2) THEN C LDLT case IF( .NOT. associated(id%A) ) THEN C constraint ordering can be computed only if values are C given to analysis IF(id%KEEP(95) .EQ. 3) THEN id%KEEP(95) = 2 ENDIF ENDIF IF(id%KEEP(95) .EQ. 3 .AND. id%KEEP(256) .NE. 2) THEN C if constraint and ordering is not AMF then use compress IF (PROK) WRITE(MP,*) & 'WARNING: CMUMPS_ANA_O constrained ordering not ', & 'available with selected ordering' id%KEEP(95) = 2 ENDIF IF(id%KEEP(95) .EQ. 3) THEN C if constraint ordering required then we need to compute scaling C and max trans C NOTE that if we enter this condition then C id%A is associated because of the test above: C (IF( .NOT. associated(id%A) ) THEN) id%KEEP(23) = 5 id%KEEP(52) = -2 ELSE IF(id%KEEP(95) .EQ. 2 .AND. & (id%KEEP(23) .EQ. 0 .OR. id%KEEP(23) .EQ. 7) ) THEN C compressed ordering requires max trans but not necessary scaling IF( associated(id%A) ) THEN id%KEEP(23) = 5 ELSE C we can do compressed ordering without C information on the numerical values: C a maximum transversal already provides C information on the location of off-diagonal C nonzeros which can be candidates for 2x2 C pivots id%KEEP(23) = 1 ENDIF ELSE IF(id%KEEP(95) .EQ. 1) THEN id%KEEP(23) = 0 ELSE IF(id%KEEP(95) .EQ. 0 .AND. id%KEEP(23) .EQ. 0) THEN C if max trans desactivated then the automatic choice for type of ord C is set to 1, which means that we will use usual ordering C (no constraints or compression) id%KEEP(95) = 1 ENDIF ELSE id%KEEP(95) = 1 ENDIF C -------------------------------- C Save ICNTL(56) (QR) in KEEP(53) C Will be broadcasted to all other C nodes in routine CMUMPS_BDCAST C -------------------------------- id%KEEP(53) = id%ICNTL(56) C --------------------------- C Possible values are 0..2 C Other values are treated as 0 C ------------------------------ IF ( id%KEEP(53) .LT. 0 .OR. & id%KEEP(53) .GE. 2 & ) THEN id%KEEP(53) = 0 IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(56) treated as if set to 0 ' END IF IF(id%KEEP(86).EQ.1)THEN C Force the exchange of both the memory and flops information during C the factorization IF(id%KEEP(47).LT.2) id%KEEP(47)=2 ENDIF IF(id%KEEP(48).EQ.5)THEN IF(id%KEEP(50).EQ.0)THEN id%KEEP(87)=50 id%KEEP(88)=50 ELSE id%KEEP(87)=70 id%KEEP(88)=70 ENDIF ENDIF IF((id%NSLAVES.EQ.1).AND.(id%KEEP(76).GT.3))THEN id%KEEP(76)=2 ENDIF IF(id%KEEP(81).GT.0)THEN IF(id%KEEP(47).LT.2) id%KEEP(47)=2 ENDIF C C -- Save Block Low Rank input parameter id%KEEP(494) = id%ICNTL(35) IF (id%KEEP(494).EQ.1) THEN C -- Automatic BLR option setting id%KEEP(494)= 2 ENDIF IF ( id%KEEP(494).EQ.4) id%KEEP(494)=0 IF ((id%KEEP(494).LT.0).OR.(id%KEEP(494).GT.4)) THEN C Out of range values treated as 0 id%KEEP(494) = 0 ENDIF IF(id%KEEP(494).NE.0) THEN C test BLR incompatibilities C id%KEEP(464) = id%ICNTL(38) IF (id%KEEP(464).LT.0.OR.(id%KEEP(464).GT.1000)) THEN C Out of range values treated as 0 id%KEEP(464) = 0 ENDIF id%KEEP(465) = id%ICNTL(39) IF (id%KEEP(465).LT.0.OR.(id%KEEP(465).GT.1000)) THEN C Out of range values treated as 0 id%KEEP(465) = 0 ENDIF C LR is incompatible with elemental matrices, forbid it at analysis IF (id%KEEP(55).NE.0) THEN IF (LPOK) WRITE(LP,*) & " *** BLR feature currently incompatible " & ,"with elemental matrices" C BLR for elt entry might be developed in the future id%INFO(1)=-800 id%INFO(2)=5 RETURN ENDIF C C LR incompatible with forward in facto IF (id%KEEP(252).NE.0) THEN IF (LPOK) WRITE(LP,*) & " *** BLR feature currently incompatible" & ," with forward during factorization" id%INFO(1) = -43 id%INFO(2) = 35 RETURN ENDIF C ENDIF C IF(id%KEEP(494).NE.0) THEN C id%KEEP(469)=0,1,2,3,4 IF ((id%KEEP(469).GT.4).OR.(id%KEEP(469).LT.0)) THEN id%KEEP(469)=0 ENDIF C Not implemented yet IF (id%KEEP(469).EQ.4) id%KEEP(469)=0 C id%KEEP(471)=-1,0,1 IF ((id%KEEP(471).LT.-1).AND.(id%KEEP(471).GT.1)) THEN id%KEEP(471)=-1 ENDIF C id%KEEP(472)=0 or 1 IF ((id%KEEP(472).NE.0).AND.(id%KEEP(472).NE.1)) THEN id%KEEP(472)=1 ENDIF C id%KEEP(475)=0,1,2,3 IF ((id%KEEP(475).GT.3).OR.(id%KEEP(475).LT.0)) THEN id%KEEP(475)=0 ENDIF C id%KEEP(482)=0,1,2,3 IF ((id%KEEP(482).GT.3).OR.(id%KEEP(482).LT.0)) THEN id%KEEP(482)=0 ENDIF IF((id%KEEP(487).LT.0)) THEN id%KEEP(487)= 2 ! default value ENDIF C id%KEEP(488)>0 IF((id%KEEP(488).LE.0)) THEN id%KEEP(488)= 8*id%KEEP(6) ENDIF C id%KEEP(490)>0 IF((id%KEEP(490).LE.0)) THEN id%KEEP(490) = 128 ENDIF C KEEP(491)>0 IF((id%KEEP(491).LE.0)) THEN id%KEEP(491) = 1000 ENDIF ENDIF C id%KEEP(13) = 0 id%KEEP(14) = 0 C Analysis by Blocks id%KEEP(13) = id%ICNTL(15) IF (id%KEEP(13).GT.1) THEN CV0 out-of range values id%KEEP(13) = 0 ENDIF IF (id%KEEP(13).EQ.1) THEN C{ Analysis by block with block data provided by user C check input data IF ( .NOT.associated(id%BLKPTR)) THEN C BLKPTR provided by user IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " id%BLKPTR should be provided by user on host " ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ELSE IF ( (id%NBLK.LE.0).OR.(id%NBLK.GT.id%N) & .OR. (id%NBLK+1.NE.size(id%BLKPTR)) & ) THEN C id%NBLK out of range IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ERROR incorrect value of id%NBLK:", id%NBLK ENDIF id%INFO(1) = -57 id%INFO(2) = 1 ELSE IF (id%BLKPTR(id%NBLK+1)-1.NE.id%N) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR id%BLKPTR(id%NBLK+1)-1 ", & "should be equal to id%N instead of ", & id%BLKPTR(id%NBLK+1)-1 ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ELSE IF (id%BLKPTR(1).NE.1) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR id%BLKPTR(1)", & "should be equal to 1 instead of ", & id%BLKPTR(1) ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ELSE IF (associated(id%BLKVAR)) THEN C id%BLKVAR IF (size(id%BLKVAR).NE.id%N) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR with centralized matrix. Size of id%BLKVAR ", & "should be equal to id%N instead of ", & size(id%BLKVAR) ENDIF id%INFO(1) = -57 id%INFO(2) = 3 ENDIF ENDIF C} ENDIF IF (id%KEEP(13).LT.0) THEN C note that id%BLKPTR might still be associated C but will not be used IF (mod(id%N,-id%KEEP(13)) .NE.0) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ICNTL(15)=", id%ICNTL(15), & " is incompatible with N=", id%N ENDIF id%INFO(1) = -57 id%INFO(2) = 1 ENDIF ENDIF IF (id%KEEP(13).EQ.0) THEN IF ( & ((id%KEEP(54).EQ.3).AND.(id%KEEP(244).EQ.1)) & .OR. & ((id%KEEP(244).EQ.2).AND.(id%KEEP(339).NE.0)) & ) THEN id%KEEP(13)=-1 ENDIF C unsymmetric assembled matrices with or without BLR, C also in case of centralized matrix (if C matrix is distributed, then KEEP(13) has C been set to -1 in the block above) IF (id%KEEP(50).EQ.0.AND. id%KEEP(55).EQ.0) THEN C Respect decision taken for Maxtrans C since it will be switch off C if one activates the analysis by block IF ( (id%KEEP(23).LE.0) .OR. (id%KEEP(23).GT.7) & ) THEN id%KEEP(13)=-1 ENDIF ENDIF ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(55).NE.0) & ) THEN IF (PROKG.AND.(id%KEEP(13).NE.-1)) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with elemental matrices" C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(106).NE.1).AND. (id%KEEP(106).NE.2) & ) THEN IF (PROKG.AND.(id%KEEP(13).NE.-1)) WRITE(MPG,'(A,A,I4)') & " ** Analysis by block not compatible ", & "with symbolic factorization option ", & id%KEEP(106) C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. (id%KEEP(244) .EQ. 2) .AND. & (id%KEEP(339).EQ.0) & ) THEN IF (PROKG.AND.(id%KEEP(13).NE.-1)) WRITE(MPG,'(A)') & " ** Analysis by block switched off " C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(60).NE.0) & ) THEN IF (PROKG.AND.(id%KEEP(13).NE.-1)) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with Schur " C switch off analysis by block id%KEEP(13)= 0 ENDIF IF (id%KEEP(13).NE.0) THEN C Maximum transversal not compatible with analysis by block IF (id%KEEP(23).NE.0) THEN C in case of automatic choice (id%KEEP(27).EQ.7) C do not print message IF (PROKG.AND.id%KEEP(23).NE.7) WRITE(MPG,'(A,A)') & " ** Maximum transversal (ICNTL(6)) ", & "not compatible with analysis by block" C switch off max transversal id%KEEP(23)= 0 ENDIF C - compression for LDLT IF (id%KEEP(95).NE.1) THEN C in case of automatic choice (id%KEEP(95).EQ.0) C do not print message IF (PROKG.AND.id%KEEP(95).NE.0) WRITE(MPG,'(A,A)') & " ** ICNTL(12) not compatible with ", & " analysis by block" C switch off 2x2 preprocessing for symmetric matrices id%KEEP(95) = 1 ENDIF ENDIF C C end id%MYID.EQ.MASTER END IF RETURN END SUBROUTINE CMUMPS_ANA_CHECK_KEEP C ======================================== SUBROUTINE CMUMPS_ANA_CHECK_ICNTL48 (id ) !$ USE OMP_LIB, ONLY : omp_get_max_threads USE CMUMPS_STRUC_DEF C IMPLICIT NONE C C Purpose C ======= C This subroutine performed part of CMUMPS_ANA_CHECK_KEEP concerned by ICNTL(48) C and is called by CMUMPS_ANA_CHECK_KEEP and CMUMPS_ANA_REDO_STAT C C Parameters C TYPE(CMUMPS_STRUC) :: id C C Local variables C INTEGER :: LP, MP, MPG, NOMP INTEGER :: MASTER LOGICAL :: PROK, PROKG, LPOK LOGICAL :: I_AM_SLAVE PARAMETER( MASTER = 0 ) C LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (id%MYID.eq.MASTER) THEN C C L0-OMP settings of KEEP(400) C id%KEEP(401) = 0 NOMP = 0 IF (id%ICNTL(48).EQ.1) id%KEEP(401)=1 IF (id%KEEP(401) .GT. 0) THEN !$ NOMP=omp_get_max_threads() IF ( NOMP .EQ. 0 ) THEN C Compilation without OMP! id%KEEP(400) = 0 id%INFO(1)=-58 id%INFO(2)=0 IF (LPOK) WRITE(LP,'(A)') & " FAILURE DETECTED IN ANALYSIS: ICNTL(48) requires OpenMP" RETURN ENDIF ENDIF C ENDIF RETURN END SUBROUTINE CMUMPS_ANA_CHECK_ICNTL48 C SUBROUTINE CMUMPS_GATHER_MATRIX(id) C This subroutine gathers a distributed matrix C on the host node USE CMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) TYPE(CMUMPS_STRUC) :: id C local variables INTEGER, ALLOCATABLE :: REQPTR(:,:) INTEGER(8), ALLOCATABLE :: MATPTR(:) INTEGER(8), ALLOCATABLE :: MATPTR_cp(:) INTEGER(8) :: IBEG8, IEND8 INTEGER :: INDX INTEGER :: LP, MP, MPG, I, K INTEGER(8) :: I8 LOGICAL :: PROKG C C messages are split into blocks of size BLOCKSIZE C (smaller than IOVFLO (=2^31-1)) C on all processors INTEGER(4) :: IOVFLO INTEGER :: BLOCKSIZE INTEGER :: MAX_NBBLOCK_loc, NBBLOCK_loc INTEGER :: SIZE_SENT, NRECV LOGICAL :: OMP_FLAG INTEGER(8) :: NZ_loc8 C for validation only: INTEGER :: NB_BLOCKS, NB_BLOCK_SENT LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) C iovflo = huge(INTEGER, kind=4) IOVFLO = huge(IOVFLO) C we do not want too large messages BLOCKSIZE = int(max(100000_8,int(IOVFLO,8)/200_8)) IF ( id%KEEP(46) .EQ. 0 .AND. id%MYID .EQ. MASTER ) THEN C host-node mode: master has no entries. id%KEEP8(29) = 0_8 END IF IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------- C Allocate small arrays for pointers C into arrays IRN/JCN C ----------------------------------- ALLOCATE( MATPTR( id%NPROCS ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) ' array MATPTR' END IF GOTO 13 END IF ALLOCATE( MATPTR_cp( id%NPROCS ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) ' array MATPTR' END IF GOTO 13 END IF C ----------------------------------- C Allocate a small array for requests C ----------------------------------- ALLOCATE( REQPTR( id%NPROCS-1, 2 ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = 2 * (id%NPROCS-1) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array REQPTR' END IF GOTO 13 END IF C -------------------- C Allocate now IRN/JCN C -------------------- ALLOCATE( id%IRN( id%KEEP8(28) ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2)) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array IRN' END IF GOTO 13 END IF ALLOCATE( id%JCN( id%KEEP8(28) ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2)) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array JCN' END IF GOTO 13 END IF END IF 13 CONTINUE C Propagate errors CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) < 0 ) RETURN C ------------------------------------- C Get numbers of non-zeros for everyone C and count total and maximum C nb of blocks of size BLOCKSIZE C that slaves will sent C ------------------------------------- IF ( id%MYID .EQ. MASTER ) THEN C each block will correspond to 2 messages (IRN_LOC,JCN_LOC) NB_BLOCK_SENT = 0 MAX_NBBLOCK_loc = 0 DO I = 1, id%NPROCS - 1 CALL MPI_RECV( MATPTR( I+1 ), 1, & MPI_INTEGER8, I, & COLLECT_NZ, id%COMM, STATUS, IERR ) NBBLOCK_loc = ceiling(dble(MATPTR(I+1))/dble(BLOCKSIZE)) MAX_NBBLOCK_loc = max(MAX_NBBLOCK_loc, NBBLOCK_loc) NB_BLOCK_SENT = NB_BLOCK_SENT + NBBLOCK_loc END DO IF ( id%KEEP(46) .eq. 0 ) THEN MATPTR( 1 ) = 1_8 ELSE NZ_loc8=id%KEEP8(29) MATPTR( 1 ) = NZ_loc8 + 1_8 END IF C -------------- C Build pointers C -------------- DO I = 2, id%NPROCS MATPTR( I ) = MATPTR( I ) + MATPTR( I-1 ) END DO ELSE NZ_loc8=id%KEEP8(29) CALL MPI_SEND( NZ_loc8, 1, MPI_INTEGER8, MASTER, & COLLECT_NZ, id%COMM, IERR ) END IF IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------------------- C Bottleneck is here master; use synchronous send C for slaves, but asynchronous receives on master C Then while master receives indices do the local C copies for better overlap. C (If master has other things to do, he could try C to do them here.) C ------------------------------------ C copy pointers to position in IRN/JCN MATPTR_cp = MATPTR IF ( id%KEEP8(29) .NE. 0_8 ) THEN OMP_FLAG = ( id%KEEP8(29).GE.50000_8 ) !$OMP PARALLEL DO PRIVATE(I8) !$OMP& IF(OMP_FLAG) DO I8=1,id%KEEP8(29) id%IRN(I8) = id%IRN_loc(I8) id%JCN(I8) = id%JCN_loc(I8) ENDDO !$OMP END PARALLEL DO ENDIF C C Compute position for each block to be received C and store it. NB_BLOCKS = 0 C at least one slave will send MAX_NBBLOCK_loc C couple of messages (IRN_loc/JCN_loc) DO K = 1, MAX_NBBLOCK_loc C Post irecv for all messages from proc I C that have been sent NRECV = 0 DO I = 1, id%NPROCS - 1 C Check if message was sent IBEG8 = MATPTR_cp( I ) IF ( IBEG8 .LT. MATPTR(I+1)) THEN C Count number of request in NRECV NRECV = NRECV + 2 IEND8 = min(IBEG8+int(BLOCKSIZE,8)-1_8, & MATPTR(I+1)-1_8) C update pointer for receiving messages C from proc I in MATPTR_cp: MATPTR_cp( I ) = IEND8 + 1_8 SIZE_SENT = int(IEND8 - IBEG8 + 1_8) NB_BLOCKS = NB_BLOCKS + 1 C CALL MPI_IRECV( id%IRN(IBEG8), SIZE_SENT, MPI_INTEGER, & I, COLLECT_IRN, id%COMM, REQPTR(I,1), IERR ) C CALL MPI_IRECV( id%JCN(IBEG8), SIZE_SENT, MPI_INTEGER, & I, COLLECT_JCN, id%COMM, REQPTR(I,2), IERR ) ELSE REQPTR( I,1 ) = MPI_REQUEST_NULL REQPTR( I,2 ) = MPI_REQUEST_NULL ENDIF END DO C Wait set of messages corresponding to current block C ( we dont exploit the fact that C messages are not overtaking C (if sent by one source to the same destination) ) C C Loop on only non MPI_REQUEST_NULL requests DO I = 1, NRECV CALL MPI_WAITANY & ( 2 * (id%NPROCS-1), REQPTR( 1, 1 ), INDX, & STATUS, IERR ) ENDDO C C process next block END DO DEALLOCATE( REQPTR ) DEALLOCATE( MATPTR ) DEALLOCATE( MATPTR_cp ) C end of reception by master ELSE C ----------------------------- C Send only if size is not zero C ----------------------------- IF ( id%KEEP8(29) .NE. 0_8 ) THEN NZ_loc8=id%KEEP8(29) C send by blocks of size BLOCKSIZE DO I8=1_8, NZ_loc8, int(BLOCKSIZE,8) SIZE_SENT = BLOCKSIZE IF (NZ_loc8-I8+1_8.LT.int(BLOCKSIZE,8)) THEN SIZE_SENT = int(NZ_loc8-I8+1_8) ENDIF CALL MPI_SEND( id%IRN_loc(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & COLLECT_IRN, id%COMM, IERR ) CALL MPI_SEND( id%JCN_loc(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & COLLECT_JCN, id%COMM, IERR ) END DO END IF END IF RETURN 150 FORMAT( &/' ** FAILURE DURING CMUMPS_GATHER_MATRIX, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE CMUMPS_GATHER_MATRIX SUBROUTINE CMUMPS_DUMP_PROBLEM(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C If id%WRITE_PROBLEM has been set by the user, C possibly on all processors in case of distributed C matrix, open a file and dumps the matrix and/or C the right hand side. In case the last characters C of id.WRITE_PROBLEM are "bin" (uppercase letters C are also accepted), then the matrix is written C in binary stream format (a C routine is called to C avoid depending on the access='stream' mode that C is only available since Fortran 2003). In that case, C a small header file is also written. C Otherwise, this subroutine calls C CMUMPS_DUMP_MATRIX (to write the matrix in C matrix-market format) and CMUMPS_DUMP_RHS. C The routine should be called on all MPI processes. C C Examples: C 1/ WRITE_PROBLEM='mymatrix.txt', centralized matrix C mymatrix.txt contains the matrix in matrix-market format C 2/ WRITE_PROBLEM='mymatrix.txt', distributed matrix C mymatrix.txt contains the portion of the matrix C on process , in matrix-market format C 3/ WRITE_PROBLEM='mymatrix.bin', centralized matrix C mymatrix.bin contains the matrix in binary format C mymatrix.header contains a short description in text format, C with the first line identical to the one of C a matrix-market format C 4/ WRITE_PROBLEM='mymatrix.bin', distributed matrix C mymatrix.bin contains the portion of the matrix C on process , in binary format C C mymatrix.header contains a short description in text format, C with the first line identical to matrix-market format C C If a centralized, dense, RHS is available, it is also written, C either in matrix-market or binary format (if WRITE_PROBLEM C has a .bin extension). In that case the filename for the RHS C is WRITE_PROBLEM//".rhs". If written in binary form, information C on the RHS is also provided in the header file. C INCLUDE 'mpif.h' C C Arguments C ========= C TYPE(CMUMPS_STRUC) :: id C C Local variables C =============== C INTEGER :: MASTER, IERR, I INTEGER :: IUNIT LOGICAL :: IS_ELEMENTAL LOGICAL :: IS_DISTRIBUTED LOGICAL :: NAME_INITIALIZED INTEGER :: DO_WRITE, DO_WRITE_CHECK CHARACTER(LEN=20) :: IDSTR LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: L LOGICAL :: BINARY_FORMAT, DUMP_RHS, & DUMP_BLKPTR, DUMP_BLKVAR INTEGER :: IS_A_PROVIDED, IS_A_PROVIDED_GLOB COMPLEX, TARGET :: A_DUMMY(1) INTEGER, TARGET :: IRN_DUMMY(1), JCN_DUMMY(1) INTEGER, POINTER, DIMENSION(:) :: IRN_PASSED, JCN_PASSED COMPLEX, POINTER, DIMENSION(:) :: A_PASSED INTEGER :: MPG LOGICAL :: PROKG PARAMETER( MASTER = 0 ) 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) MPG = id%ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) NAME_INITIALIZED = id%WRITE_PROBLEM(1:20) & .NE. "NAME_NOT_INITIALIZED" BINARY_FORMAT = .FALSE. L=len_trim(id%WRITE_PROBLEM) IF (L.GT.4) THEN IF ( id%WRITE_PROBLEM(L-3:L-3) .EQ. '.' .AND. & ( id%WRITE_PROBLEM(L-2:L-2) .EQ. 'b' .OR. & id%WRITE_PROBLEM(L-2:L-2) .EQ. 'B' ) .AND. & ( id%WRITE_PROBLEM(L-1:L-1) .EQ. 'i' .OR. & id%WRITE_PROBLEM(L-1:L-1) .EQ. 'I' ) .AND. & ( id%WRITE_PROBLEM(L:L) .EQ. 'n' .OR. & id%WRITE_PROBLEM(L:L) .EQ. 'N' ) ) THEN BINARY_FORMAT = .TRUE. ENDIF ENDIF IF (NAME_INITIALIZED.AND.PROKG) THEN WRITE(MPG,'(/A,A/)') & " Write input matrix to file, WRITE_PROBLEM= ", & id%WRITE_PROBLEM(1:L) ENDIF C Check if RHS should also be dumped DUMP_RHS = id%MYID.EQ.MASTER .AND. & associated(id%RHS) .AND. NAME_INITIALIZED DUMP_RHS = DUMP_RHS .AND. id%NRHS .GE. 1 DUMP_RHS = DUMP_RHS .AND. id%N .GE. 1 DUMP_RHS = DUMP_RHS .AND. id%ICNTL(20) .EQ. 0 C Check if BLKPTR and/or BLKVAR should also be dumped DUMP_BLKPTR = .FALSE. DUMP_BLKVAR = .FALSE. IF ( id%MYID.EQ.MASTER .AND. NAME_INITIALIZED ) THEN IF ( id%ICNTL(15) .EQ. 1 & .AND. id%NBLK .GT. 0 ) THEN IF (associated(id%BLKPTR)) THEN DUMP_BLKPTR = .TRUE. IF (associated(id%BLKVAR)) THEN C Dump also BLKVAR, except if allocated by MUMPS DUMP_BLKVAR = .TRUE. ENDIF ENDIF ELSE IF ( id%ICNTL(15) .LT. 0 ) THEN IF (associated(id%BLKVAR)) THEN C Dump also BLKVAR, except if allocated by MUMPS DUMP_BLKVAR = .TRUE. ENDIF ENDIF ENDIF C Remark: if id%KEEP(54) = 1 or 2, the structure C is centralized at analysis. Since CMUMPS_DUMP_PROBLEM C is called at analysis phase, we define IS_DISTRIBUTED C as below, which implies that the structure of the problem C is distributed in IRN_loc/JCN_loc at analysis. IS_DISTRIBUTED = (id%KEEP(54) .EQ. 3) IS_ELEMENTAL = (id%KEEP(55) .NE. 0) IF (NAME_INITIALIZED) THEN IF (I_AM_MASTER .OR. IS_DISTRIBUTED) THEN C Try to find a free Fortran unit CALL MUMPS_FIND_UNIT(IUNIT) IF ( IUNIT .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 1 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) GOTO 500 IF (I_AM_MASTER .AND. .NOT. IS_DISTRIBUTED) THEN C ==================== C Matrix is assembled C and centralized C ==================== IF (NAME_INITIALIZED) THEN IF ( BINARY_FORMAT ) THEN IF (id%KEEP8(28) .EQ. 0_8) THEN C Special case of empty matrix A_PASSED => A_DUMMY IRN_PASSED => IRN_DUMMY JCN_PASSED => JCN_DUMMY IS_A_PROVIDED = 1 ELSE IF (associated(id%A)) THEN A_PASSED=>id%A IRN_PASSED => id%IRN JCN_PASSED => id%JCN IS_A_PROVIDED = 1 ELSE A_PASSED => A_DUMMY IRN_PASSED => id%IRN JCN_PASSED => id%JCN IS_A_PROVIDED = 0 ENDIF OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' ) CALL CMUMPS_DUMP_HEADER( IUNIT, id%N, & IS_A_PROVIDED, id%KEEP(50), IS_DISTRIBUTED, & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) ) CLOSE( IUNIT ) CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(28), & id%KEEP(35), & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1), & IS_A_PROVIDED, & trim(id%WRITE_PROBLEM)//char(0) ) ELSE OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)) CALL CMUMPS_DUMP_MATRIX( id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! = .FALSE., centralized & IS_ELEMENTAL, ! Elemental or not & .FALSE.) CLOSE(IUNIT) ENDIF ENDIF ELSE IF ( IS_DISTRIBUTED ) THEN C ===================== C Matrix is distributed C ===================== IF ( .NOT.NAME_INITIALIZED & .OR. .NOT. I_AM_SLAVE )THEN DO_WRITE = 0 ELSE DO_WRITE = 1 ENDIF CALL MPI_ALLREDUCE(DO_WRITE, DO_WRITE_CHECK, 1, & MPI_INTEGER, MPI_SUM, id%COMM, IERR) C ----------------------------------------- C If yes, each processor writes its share C of the matrix in a file in matrix market C format (otherwise nothing written). We C append the process id to the filename. C Safer in case all filenames are the C same if all processors share the same C file system. C ----------------------------------------- IF (DO_WRITE_CHECK.EQ.id%NSLAVES .AND. I_AM_SLAVE) THEN WRITE(IDSTR,'(I9)') id%MYID_NODES IF (BINARY_FORMAT) THEN IF (id%KEEP8(29) .EQ. 0_8) THEN C Special case of empty matrix A_PASSED => A_DUMMY IRN_PASSED => IRN_DUMMY JCN_PASSED => JCN_DUMMY C (consider that A is provided when NNZ_loc=0) IS_A_PROVIDED = 1 ELSE IF (associated(id%A_loc)) THEN A_PASSED=>id%A_loc IRN_PASSED => id%IRN_loc JCN_PASSED => id%JCN_loc IS_A_PROVIDED = 1 ELSE A_PASSED => A_DUMMY IRN_PASSED => id%IRN_loc JCN_PASSED => id%JCN_loc IS_A_PROVIDED = 0 ENDIF CALL MPI_ALLREDUCE( IS_A_PROVIDED, & IS_A_PROVIDED_GLOB, 1, & MPI_INTEGER, MPI_PROD, id%COMM_NODES, IERR ) C IS_A_PROVIDED_GLOB = 1 => dump numerical values C IS_A_PROVIDED_GLOB = 0 => some processes did not provide C numerical values, dump only pattern, C and indicate this in the header IF ( id%MYID_NODES.EQ.0) THEN C Print header on first MPI worker (only one global header C file in case of distributed matrix), replacing the .bin C extension by a .header extension OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' ) CALL CMUMPS_DUMP_HEADER( IUNIT, id%N, & IS_A_PROVIDED_GLOB, id%KEEP(50), IS_DISTRIBUTED, & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) ) CLOSE( IUNIT ) ENDIF CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(29), & id%KEEP(35), & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1), & IS_A_PROVIDED_GLOB, & trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))//char(0) ) ELSE OPEN(IUNIT, & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))) CALL CMUMPS_DUMP_MATRIX(id, & IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! =.TRUE., distributed & IS_ELEMENTAL, ! Elemental or not & .FALSE.) CLOSE(IUNIT) ENDIF ENDIF C ELSE ... C Nothing written in other cases. ENDIF C =============== C Right-hand side C =============== IF ( DUMP_RHS ) THEN IF (BINARY_FORMAT) THEN C dump RHS in binary format CALL MUMPS_DUMPRHSBINARY_C( id%N, id%NRHS, id%LRHS, id%RHS(1), & id%KEEP(35), & trim(id%WRITE_PROBLEM)//'.rhs'//char(0) ) ELSE C dump RHS in matrix-market format OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM) //".rhs") CALL CMUMPS_DUMP_RHS(IUNIT, id) CLOSE(IUNIT) ENDIF ENDIF IF ( DUMP_BLKPTR ) THEN IF (BINARY_FORMAT) THEN ! suppress trailing '.bin' and use '.blkptr' OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkptr' ) ELSE ! just append '.blkptr' OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkptr") ENDIF WRITE(IUNIT,'(I9)') id%NBLK DO I=1,id%NBLK+1 WRITE(IUNIT,'(I9)') id%BLKPTR(I) ENDDO CLOSE(IUNIT) ENDIF IF ( DUMP_BLKVAR ) THEN IF (BINARY_FORMAT) THEN ! suppress trailing '.bin' and use '.blkvar' OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkvar' ) ELSE ! just append '.blkvar' OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkvar") ENDIF DO I=1,id%N WRITE(IUNIT,'(I9)') id%BLKVAR(I) ENDDO CLOSE(IUNIT) ENDIF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_DUMP_PROBLEM SUBROUTINE CMUMPS_DUMP_HEADER( IUNIT, N, IS_A_PROVIDED_GLOB, & SYM, IS_DISTRIBUTED, NSLAVES, NNZTOT, DUMP_RHS, NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, NBLK, ICNTL15 ) C C Purpose: C ======= C C Write a small header file, similar to matrix-market headers, C to accompany a matrix written in binary format. C INTEGER, INTENT(IN) :: IUNIT, N, IS_A_PROVIDED_GLOB , SYM, NSLAVES INTEGER(8), INTENT(IN) :: NNZTOT LOGICAL, INTENT(IN) :: IS_DISTRIBUTED, DUMP_RHS INTEGER, INTENT(IN) :: NRHS LOGICAL, INTENT(IN) :: DUMP_BLKPTR, DUMP_BLKVAR INTEGER, INTENT(IN) :: NBLK INTEGER, INTENT(IN) :: ICNTL15 C C Local declarations: C ================== C CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH C 1/ write a line identical to first line of matrix-market header IF ( IS_A_PROVIDED_GLOB .EQ. 1 ) THEN ARITH='complex' ELSE ARITH='pattern' ENDIF IF (SYM .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) C 2/ indicate if matrix is distributed or centralized, C then describe binary file content and format IF ( IS_DISTRIBUTED ) THEN WRITE(IUNIT,FMT='(A,I5,A)') & '% Matrix is distributed (MPI ranks=',NSLAVES,')' ELSE WRITE(IUNIT,FMT='(A)') & '% Matrix is centralized' ENDIF WRITE(IUNIT,FMT='(A)') & '% Unformatted stream IO (no record boundaries):' IF (ARITH(1:7).EQ.'pattern') THEN IF (IS_DISTRIBUTED) THEN WRITE(IUNIT,'(A)') & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc)' ELSE WRITE(IUNIT,'(A)') & '% N,NNZ,IRN(1:NNZ),JCN(1:NNZ)' ENDIF WRITE(IUNIT,'(A)') '% (numerical values not provided)' ELSE IF (IS_DISTRIBUTED) THEN WRITE(IUNIT,'(A)') & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc),'// & 'A_loc(1:NNZ_loc)' ELSE WRITE(IUNIT,'(A)') '% N/NNZ/IRN(1:NNZ),JCN(1:NNZ),A(1:NNZ)' ENDIF WRITE(IUNIT,'(A)') '% Single complex storage' ENDIF IF ( IS_DISTRIBUTED ) THEN WRITE(IUNIT,'(A,/,A)') & '% N,IRN_loc(i),JCN_loc(i): 32 bits', & '% NNZ_loc: 64 bits' ELSE WRITE(IUNIT,'(A,/,A)') & '% N,IRN(i),JCN(i): 32 bits', & '% NNZ: 64 bits' ENDIF WRITE(IUNIT,FMT='(A,I16)') '% Matrix order: N=',N WRITE(IUNIT,FMT='(A,I16)') '% Matrix nonzeros: NNZ=',NNZTOT IF (DUMP_RHS) THEN WRITE(IUNIT,FMT='(A)') '%' WRITE(IUNIT,FMT='(A,/,A,I10,A,I5)') & '% A RHS was also written to disk by columns in binary form.', & '% Size: N rows x NRHS columns with N=',N,' NRHS=',NRHS WRITE(IUNIT,FMT='(A,I16,A)') & '% Total:',int(N,8)*int(NRHS,8),' scalar values.' WRITE(IUNIT,'(A)') '% Single complex storage' ENDIF IF (DUMP_BLKPTR) THEN WRITE(IUNIT,FMT='(A)') '%' WRITE(IUNIT,'(A,I9,A)') '% Matrix has a block format with', & NBLK,' blocks' WRITE(IUNIT,'(A)') & '% File .blkptr contains NBLK and BLKPTR(1:NBLK+1)' ELSE IF (ICNTL15 .LT. 0) THEN WRITE(IUNIT,FMT='(A)') '%' WRITE(IUNIT,'(A,I9,A)') & '% Matrix has a block format with ICNTL15=',ICNTL15 ENDIF IF (DUMP_BLKVAR) THEN WRITE(IUNIT,'(A)') & '% File .blkvar contains BLKVAR (N integers)' ELSE IF (ICNTL15 .NE. 0) THEN WRITE(IUNIT,'(A)') & '% (BLKVAR considered to be identity is not written)' ENDIF RETURN END SUBROUTINE CMUMPS_DUMP_HEADER SUBROUTINE CMUMPS_DUMP_MATRIX & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, IS_ELEMENTAL, PATTERN_ONLY ) USE CMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C This subroutine dumps a routine in matrix-market format C if the matrix is assembled, and in "MUMPS" format (see C example in the MUMPS users'guide, if the matrix is C centralized and elemental). C The routine can be called on all processors. In case of C distributed assembled matrix, each processor writes its C share as a matrix market file on IUNIT (IUNIT may have C different values on different processors). C C C C Arguments (input parameters) C ============================ C C IUNIT: should be set to the Fortran unit where C data should be written. C I_AM_SLAVE: .TRUE. except on a non working master C IS_DISTRIBUTED: .TRUE. if matrix is distributed, C i.e., if IRN_loc/JCN_loc are provided. C IS_ELEMENTAL : .TRUE. if matrix is elemental C id : main MUMPS structure C LOGICAL, intent(in) :: I_AM_SLAVE, & I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL, & PATTERN_ONLY INTEGER, intent(in) :: IUNIT TYPE(CMUMPS_STRUC), intent(in) :: id C C Local variables: C =============== C CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH INTEGER(8) :: I8, NNZ_i C C Executable statements: C ===================== IF (I_AM_MASTER .AND. .NOT. IS_DISTRIBUTED .AND. & .NOT. IS_ELEMENTAL) THEN C ================== C CENTRALIZED MATRIX C ================== IF (id%KEEP8(28) .EQ. 0_8) THEN CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ, id%NZ, NNZ_i) ELSE NNZ_i=id%KEEP8(28) ENDIF IF ((associated(id%A)).AND.(.NOT.PATTERN_ONLY)) THEN C Write header line: ARITH='complex' ELSE ARITH='pattern ' ENDIF IF (id%KEEP(50) .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) WRITE(IUNIT,*) id%N, id%N, NNZ_i IF ((associated(id%A)).AND.(.NOT.PATTERN_ONLY)) THEN DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. id%IRN(I8).LT.id%JCN(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8), & real(id%A(I8)), aimag(id%A(I8)) ELSE WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8), & real(id%A(I8)), aimag(id%A(I8)) ENDIF ENDDO ELSE C pattern only DO I8=1_8,id%KEEP8(28) IF (id%KEEP(50).NE.0 .AND. id%IRN(I8).LT.id%JCN(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8) ELSE WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8) ENDIF ENDDO ENDIF ELSE IF ( IS_DISTRIBUTED .AND. I_AM_SLAVE ) THEN C ================== C DISTRIBUTED MATRIX C ================== IF (id%KEEP8(29) .EQ. 0_8) THEN CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ_loc, id%NZ_loc, NNZ_i) ELSE NNZ_i=id%KEEP8(29) ENDIF IF ((associated(id%A_loc)).AND.(.NOT.PATTERN_ONLY)) THEN ARITH='complex' ELSE ARITH='pattern ' ENDIF IF (id%KEEP(50) .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) WRITE(IUNIT,*) id%N, id%N, NNZ_i IF ((associated(id%A_loc)).AND.(.NOT.PATTERN_ONLY)) THEN DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I8).LT.id%JCN_loc(I8)) THEN WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8), & real(id%A_loc(I8)), aimag(id%A_loc(I8)) ELSE WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8), & real(id%A_loc(I8)), aimag(id%A_loc(I8)) ENDIF ENDDO ELSE DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I8).LT.id%JCN_loc(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8) ELSE WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8) ENDIF ENDDO ENDIF ELSE IF (IS_ELEMENTAL .AND. I_AM_MASTER) THEN C ================== C ELEMENTAL MATRIX C ================== WRITE(IUNIT,*) id%N," :: N" WRITE(IUNIT,*) id%NELT," :: NELT" WRITE(IUNIT,*) size(id%ELTVAR)," :: NELTVAR" WRITE(IUNIT,*) size(id%A_ELT)," :: NELTVL" WRITE(IUNIT,*) id%ELTPTR(:)," ::ELTPTR" WRITE(IUNIT,*) id%ELTVAR(:)," ::ELTVAR" IF(.NOT.PATTERN_ONLY) THEN WRITE(IUNIT,*) id%A_ELT(:) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_DUMP_MATRIX SUBROUTINE CMUMPS_DUMP_RHS(IUNIT, id) C C Purpose: C ======= C Dumps a dense, centralized, C right-hand side in matrix market format on unit C IUNIT. Should be called on the host only. C USE CMUMPS_STRUC_DEF IMPLICIT NONE C Arguments C ========= TYPE(CMUMPS_STRUC), intent(in) :: id INTEGER, intent(in) :: IUNIT C C Local variables C =============== C CHARACTER (LEN=8) :: ARITH INTEGER :: I, J INTEGER(8) :: LD_RHS8, K8 C C Executable statements C ===================== C IF (associated(id%RHS)) THEN ARITH='complex' WRITE(IUNIT,'(A,A,A)') '%%MatrixMarket matrix array ', & trim(ARITH), & ' general' WRITE(IUNIT,*) id%N, id%NRHS IF ( id%NRHS .EQ. 1 ) THEN LD_RHS8 = int(id%N,8) ELSE LD_RHS8 = int(id%LRHS,8) ENDIF DO J = 1, id%NRHS DO I = 1, id%N K8=int(J-1,8)*LD_RHS8+int(I,8) WRITE(IUNIT,*) real(id%RHS(K8)), aimag(id%RHS(K8)) ENDDO ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_DUMP_RHS SUBROUTINE CMUMPS_BUILD_I_AM_CAND( NSLAVES, K79, & NB_NIV2, MYID_NODES, & CANDIDATES, I_AM_CAND ) IMPLICIT NONE C C Purpose: C ======= C Given a list of candidate processors per node, C returns an array of booleans telling whether the C processor is candidate or not for a given node. C C K79 holds splitting strategy (KEEP(79)). If K79>1 then C TPYE4,5,6 nodes might have been introduced and C in this case "hidden" slaves should be taken C into account to enable dynamic redistribution C of the hidden slaves while climbing the chain of C split nodes. The master of the first node in the C chain requires a special treatment and is thus here C not considered as a slave. C INTEGER, intent(in) :: NSLAVES, NB_NIV2, MYID_NODES, K79 INTEGER, intent(in) :: CANDIDATES( NSLAVES+1, NB_NIV2 ) LOGICAL, intent(out):: I_AM_CAND( NB_NIV2 ) INTEGER I, INIV2, NCAND IF (K79.GT.0) THEN C Because of potential restarting the number of C candidates that will be used to distribute C arrowheads have to include all possible candidates. DO INIV2=1, NB_NIV2 I_AM_CAND(INIV2)=.FALSE. NCAND = CANDIDATES(NSLAVES+1,INIV2) C check if some hidden slaves are there C Note that if hidden candidates exists (type 5 or 6 nodes) then C in position CANDIDATES (NCAND+1,INIV2) must be the master C of the first node in the chain (type 4) that we skip here because C a special treatment (it has to be "considered as a master" for all C nodes in the list) is needed. DO I=1, NSLAVES IF (CANDIDATES(I,INIV2).LT.0) EXIT ! end of extra slaves IF (I.EQ.NCAND+1) CYCLE ! skip master of associated TYPE 4 node IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN I_AM_CAND(INIV2)=.TRUE. EXIT ENDIF ENDDO END DO ELSE DO INIV2=1, NB_NIV2 I_AM_CAND(INIV2)=.FALSE. NCAND = CANDIDATES(NSLAVES+1,INIV2) DO I=1, NCAND IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN I_AM_CAND(INIV2)=.TRUE. EXIT ENDIF ENDDO END DO ENDIF RETURN END SUBROUTINE CMUMPS_BUILD_I_AM_CAND MUMPS_5.8.1/src/comp_tps_m.F0000664000175000017500000000125115042446440015476 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_TPS_M TYPE CMUMPS_TPS_T COMPLEX, DIMENSION(:), POINTER :: A END TYPE CMUMPS_TPS_T END MODULE CMUMPS_TPS_M SUBROUTINE CMUMPS_TPS_M_RETURN() RETURN END SUBROUTINE CMUMPS_TPS_M_RETURN MUMPS_5.8.1/src/sfac_distrib_distentry.F0000664000175000017500000007436515042446437020125 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_BUILD_MAPPING & ( N, MAPPING, NNZ, IRN, JCN, PROCNODE, STEP, & SLAVEF, PERM, FILS, & RG2L, KEEP,KEEP8, MBLOCK, NBLOCK, NPROW, NPCOL ) USE SMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, SLAVEF, MBLOCK, NBLOCK, NPROW, NPCOL iNTEGER(8) :: NNZ INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN( NNZ ), JCN( NNZ ) INTEGER MAPPING( NNZ ), STEP( N ) INTEGER PROCNODE( KEEP(28) ), PERM( N ), FILS( N ), RG2L( N ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE INTEGER K4, IOLD, JOLD, INEW, JNEW, ISEND, JSEND, IARR, INODE INTEGER(8) :: K8 INTEGER TYPE_NODE, DEST INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INODE = KEEP(38) K4 = 1 DO WHILE ( INODE .GT. 0 ) RG2L( INODE ) = K4 INODE = FILS( INODE ) K4 = K4 + 1 END DO DO K8 = 1_8, NNZ IOLD = IRN( K8 ) JOLD = JCN( K8 ) IF ( IOLD .GT. N .OR. IOLD .LT. 1 .OR. & JOLD .GT. N .OR. JOLD .LT. 1 ) THEN MAPPING( K8 ) = -1 CYCLE END IF IF ( IOLD .eq. JOLD ) THEN ISEND = IOLD JSEND = JOLD ELSE INEW = PERM( IOLD ) JNEW = PERM( JOLD ) IF ( INEW .LT. JNEW ) THEN ISEND = IOLD IF ( KEEP(50) .ne. 0 ) ISEND = -IOLD JSEND = JOLD ELSE ISEND = -JOLD JSEND = IOLD END IF END IF IARR = abs( ISEND ) TYPE_NODE = MUMPS_TYPENODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) + 1 ELSE DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) END IF ELSE IF ( ISEND .LT. 0 ) THEN IPOSROOT = RG2L( JSEND ) JPOSROOT = RG2L( IARR ) ELSE IPOSROOT = RG2L( IARR ) JPOSROOT = RG2L( JSEND ) END IF IROW_GRID = mod( ( IPOSROOT - 1 )/MBLOCK, NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/NBLOCK, NPCOL ) IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = IROW_GRID * NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * NPCOL + JCOL_GRID END IF END IF MAPPING( K8 ) = DEST END DO RETURN END SUBROUTINE SMUMPS_BUILD_MAPPING SUBROUTINE SMUMPS_REDISTRIBUTION( & N, NZ_loc8, id, & DBLARR, LDBLARR, INTARR, LINTARR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & FILS, KEEP,KEEP8, MYID, COMM, NBRECORDS, & & A, LA, root, roota, PROCNODE_STEPS, SLAVEF, PERM, STEP, & ICNTL, INFO, NSEND8, NLOCAL8, & ISTEP_TO_INIV2, CANDIDATES & ) !$ USE OMP_LIB USE SMUMPS_STRUC_DEF, ONLY: SMUMPS_STRUC USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N INTEGER(8) :: NZ_loc8 TYPE (SMUMPS_STRUC) :: id INTEGER(8) :: LDBLARR, LINTARR REAL DBLARR( LDBLARR ) INTEGER INTARR( LINTARR ) INTEGER KEEP(500) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER(8) KEEP8(150) INTEGER, INTENT(IN) :: FILS( N ) 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 (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER PROCNODE_STEPS(KEEP(28)), PERM( N ), STEP( N ) INTEGER INFO( 80 ), ICNTL(60) INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: IERR, MSGSOU INTEGER :: STATUS(MPI_STATUS_SIZE) REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: PTRAW INTEGER END_MSG_2_RECV INTEGER I, J INTEGER(8) :: IS8 INTEGER(8) :: K8 INTEGER :: IARR1, IORG INTEGER TYPE_NODE, DEST, DEST_SHR INTEGER IOLD, JOLD, IARR, ISEND, JSEND INTEGER ISEND_SHR, JSEND_SHR INTEGER allocok, TYPESPLIT, T4MASTER, INIV2, NCAND LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS REAL VAL, VAL_SHR INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, ARROW_ROOT INTEGER IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT, & ILOCROOT, JLOCROOT INTEGER MP,LP INTEGER KPROBE, FREQPROBE INTEGER TAILLE INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFI REAL, ALLOCATABLE, DIMENSION(:,:,:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI REAL, ALLOCATABLE, DIMENSION(:) :: BUFRECR INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, IREQI, IREQR LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE LOGICAL :: FLAG INTEGER(8), INTENT(OUT) :: NSEND8, NLOCAL8 INTEGER MASTER_NODE, ISTEP LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P INTEGER NOMP, NOMP_P, IOMP, P2 NSEND8 = 0_8 NLOCAL8 = 0_8 LP = ICNTL(1) MP = ICNTL(2) END_MSG_2_RECV = SLAVEF ALLOCATE( IACT(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IACT in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQI(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQI in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQR(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQR in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( SEND_ACTIVE(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating SEND_ACTIVE in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = ( NBRECORDS * 2 + 1 ) * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFR( NBRECORDS, 2, SLAVEF), stat = allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating real buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFRECI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS * 2 + 1 GOTO 20 END IF ALLOCATE( BUFRECR( NBRECORDS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS GOTO 20 END IF ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8) * 2_8, INFO(2) ) GOTO 20 END IF ALLOCATE( PTRAW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8) * KEEP(10), INFO(2) ) GOTO 20 END IF 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 100 ARROW_ROOT = 0 DO J = 1, N ISTEP=STEP(J) IF (ISTEP .GT. 0) THEN IARR1 = PTRDEBARR( ISTEP ) IF ( IARR1 .GT. 0 ) THEN I = J IORG = 0 DO WHILE ( I .GT. 0 ) IORG = IORG + 1 IW4(I, 1) = NINCOLARR( IARR1 + IORG - 1 ) IW4(I, 2) = NINROWARR( IARR1 + IORG - 1 ) + & NINCOLARR( IARR1 + IORG - 1 ) IS8 = PTR8ARR( IARR1 + IORG - 1 ) PTRAW( I ) = IS8 INTARR( IS8 ) = I DBLARR( IS8 ) = ZERO I = FILS(I) ENDDO ENDIF ENDIF ENDDO EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL SMUMPS_GET_ROOT_INFO(root,LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL SMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF DO I = 1, SLAVEF BUFI( 1, 1, I ) = 0 END DO DO I = 1, SLAVEF BUFI( 1, 2, I ) = 0 END DO DO I = 1, SLAVEF SEND_ACTIVE( I ) = .FALSE. IACT( I ) = 1 END DO KPROBE = 0 FREQPROBE = max(1,NBRECORDS/10) IF (SLAVEF .EQ. 1) FREQPROBE = huge(FREQPROBE) NOMP = 1 !$ NOMP=omp_get_max_threads() OMP_FLAG = KEEP(399).EQ.1 .AND. NOMP .GE.2 .AND. SLAVEF.EQ.1 !$OMP PARALLEL PRIVATE( K8, I, DEST, TAILLE, !$OMP& T4MASTER, T4_MASTER_CONCERNED, !$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT, !$OMP& ILOCROOT, JLOCROOT, !$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE, !$OMP& IS8, VAL, !$OMP& IARR, ISTEP, ISEND, JSEND, !$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P ) !$OMP& REDUCTION(+:NSEND8, NLOCAL8, ARROW_ROOT) IF (OMP_FLAG) IOMP=0 !$ IOMP=omp_get_thread_num() NOMP_P=1 !$ NOMP_P=omp_get_num_threads() OMP_FLAG_P = .FALSE. !$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1 IF (OMP_FLAG_P) THEN IF ( NOMP_P .GE. 16 ) THEN NOMP_P=16 P2 = 4 ELSE IF (NOMP_P.GE.8) THEN NOMP_P=8 P2 = 3 ELSE IF (NOMP_P.GE.4) THEN NOMP_P=4 P2 = 2 ELSE IF (NOMP_P.GE.2) THEN NOMP_P=2 P2 = 1 ENDIF ELSE NOMP_P = 1 P2 = 0 ENDIF IF ( IOMP .LT. NOMP_P ) THEN DO K8 = 1_8, NZ_loc8 IF ( SLAVEF .GT. 1 ) THEN !$OMP MASTER KPROBE = KPROBE + 1 IF ( KPROBE .eq. FREQPROBE ) THEN KPROBE = 0 CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, & MPI_INTEGER, & MSGSOU, ARR_INT, COMM, STATUS, IERR ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, & MPI_REAL, & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) CALL SMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, & root, roota, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF END IF !$OMP END MASTER ENDIF IOLD = id%IRN_loc(K8) JOLD = id%JCN_loc(K8) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE ENDIF IF (OMP_FLAG_P) THEN IF (IOLD.EQ.JOLD) THEN IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD ELSE IARR = JOLD ENDIF DOIT = ( IOMP .EQ. ibits(IARR, P2-1, P2)) ELSE DOIT = .TRUE. ENDIF IF (DOIT) THEN IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = IOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF ISTEP = abs(STEP(IARR)) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP), KEEP(199) ) T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 VAL = id%A_loc(K8) IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN VAL = VAL * id%ROWSCA(IOLD)*id%COLSCA(JOLD) ENDIF IF ( TYPE_NODE .eq. 1 ) THEN DEST = MASTER_NODE IF (DEST.EQ.MYID) THEN NLOCAL8 = NLOCAL8 + 1_8 IF (ISEND.EQ.JSEND) THEN IS8 = PTRAW(ISEND) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IF (ISEND.GE.0) THEN IS8 = PTRAW(IARR) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL ELSE IS8 = PTRAW(IARR) + IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL SMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF ENDIF CYCLE ENDIF ELSE IF ( TYPE_NODE .eq. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE DEST = MASTER_NODE END IF INIV2 = ISTEP_TO_INIV2(ISTEP) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND < 0 ) THEN IPOSROOT = root%RG2L(JSEND) JPOSROOT = root%RG2L(IARR ) ELSE IPOSROOT = root%RG2L(IARR ) JPOSROOT = root%RG2L(JSEND) END IF IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL ) DEST = IROW_GRID * root%NPCOL + JCOL_GRID ELSE DEST = -2 ENDIF IF ( OMP_FLAG_P ) THEN IF ( EARLYT3ROOTINS ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE IF (ISEND.EQ.JSEND) THEN IS8 = PTRAW(ISEND) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IF (ISEND.GE.0) THEN IS8 = PTRAW(IARR)+IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL ELSE IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JSEND DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL SMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF ENDIF ENDIF CYCLE ENDIF END IF IF (DEST .eq. -1) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .EQ. -2) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .eq.MYID ) THEN NLOCAL8 = NLOCAL8 + 1_8 ELSE NSEND8 = NSEND8 + 1_8 ENDIF ENDIF IF ( DEST.EQ.-1) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79) .GT. 0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) IF (DEST.LT.0) EXIT IF (I.EQ.NCAND+1) CYCLE DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL SMUMPS_DIST_FILL_BUFFER() ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL SMUMPS_DIST_FILL_BUFFER() ENDDO ENDIF DEST=MASTER_NODE DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL SMUMPS_DIST_FILL_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL SMUMPS_DIST_FILL_BUFFER() ENDIF ELSE IF (DEST .GE. 0) THEN DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL SMUMPS_DIST_FILL_BUFFER() IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL SMUMPS_DIST_FILL_BUFFER() ENDIF ELSE IF (DEST .EQ. -2) THEN DO I = 0, SLAVEF-1 DEST=I DEST_SHR=DEST;ISEND_SHR=ISEND JSEND_SHR=JSEND;VAL_SHR=VAL CALL SMUMPS_DIST_FILL_BUFFER() ENDDO ENDIF ENDIF END DO ENDIF !$OMP END PARALLEL DEST_SHR = -3 CALL SMUMPS_DIST_FILL_BUFFER() DO WHILE ( END_MSG_2_RECV .NE. 0 ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, MPI_INTEGER, & MPI_ANY_SOURCE, ARR_INT, COMM, STATUS, IERR ) MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, MPI_REAL, & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) CALL SMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END DO DO I = 1, SLAVEF IF ( SEND_ACTIVE( I ) ) THEN CALL MPI_WAIT( IREQI( I ), STATUS, IERR ) CALL MPI_WAIT( IREQR( I ), STATUS, IERR ) END IF END DO KEEP(49) = ARROW_ROOT 100 CONTINUE IF (ALLOCATED(IW4)) DEALLOCATE( IW4 ) IF (ALLOCATED(PTRAW)) DEALLOCATE( PTRAW ) IF (ALLOCATED(BUFI)) DEALLOCATE( BUFI ) IF (ALLOCATED(BUFR)) DEALLOCATE( BUFR ) IF (ALLOCATED(BUFRECI)) DEALLOCATE( BUFRECI ) IF (ALLOCATED(BUFRECR)) DEALLOCATE( BUFRECR ) IF (ALLOCATED(IACT)) DEALLOCATE( IACT ) IF (ALLOCATED(IREQI)) DEALLOCATE( IREQI ) IF (ALLOCATED(IREQR)) DEALLOCATE( IREQR ) IF (ALLOCATED(SEND_ACTIVE)) DEALLOCATE( SEND_ACTIVE ) RETURN CONTAINS SUBROUTINE SMUMPS_DIST_FILL_BUFFER() IMPLICIT NONE INTEGER ISLAVE, IBEG, IEND, NBREC, IREQ INTEGER TAILLE_SEND_I, TAILLE_SEND_R LOGICAL SEND_LOCAL IF ( DEST_SHR .eq. -3 ) THEN IBEG = 1 IEND = SLAVEF ELSE IBEG = DEST_SHR + 1 IEND = DEST_SHR + 1 END IF SEND_LOCAL = .FALSE. DO ISLAVE = IBEG, IEND NBREC = BUFI(1,IACT(ISLAVE),ISLAVE) IF ( DEST_SHR .eq. -3 ) THEN BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC END IF IF ( DEST_SHR .eq. -3 .or. NBREC + 1 > NBRECORDS ) THEN DO WHILE ( SEND_ACTIVE( ISLAVE ) ) CALL MPI_TEST( IREQR( ISLAVE ), FLAG, STATUS, IERR ) IF ( .NOT. FLAG ) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS(MPI_SOURCE) CALL MPI_RECV( BUFRECI(1), 2*NBRECORDS+1, & MPI_INTEGER, MSGSOU, ARR_INT, COMM, & STATUS, IERR ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, & MPI_REAL, MSGSOU, & ARR_REAL, COMM, STATUS, IERR ) CALL SMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & 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_SHR .ne. -3 ) THEN IREQ = BUFI(1,IACT(ISLAVE),ISLAVE) + 1 BUFI(1,IACT(ISLAVE),ISLAVE) = IREQ BUFI(IREQ*2,IACT(ISLAVE),ISLAVE) = ISEND_SHR BUFI(IREQ*2+1,IACT(ISLAVE),ISLAVE) = JSEND_SHR BUFR(IREQ,IACT(ISLAVE),ISLAVE ) = VAL_SHR END IF END DO IF ( SEND_LOCAL ) THEN ISLAVE = MYID + 1 CALL SMUMPS_DIST_TREAT_RECV_BUF( & BUFI(1,3-IACT(ISLAVE),ISLAVE), & BUFR(1,3-IACT(ISLAVE),ISLAVE), & NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, roota, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF RETURN END SUBROUTINE SMUMPS_DIST_FILL_BUFFER END SUBROUTINE SMUMPS_REDISTRIBUTION SUBROUTINE SMUMPS_DIST_TREAT_RECV_BUF & ( BUFI, BUFR, NBRECORDS, N, IW4, & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, roota, & PTR_ROOT, A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER NBRECORDS, N, MYID, SLAVEF INTEGER BUFI( NBRECORDS * 2 + 1 ) REAL BUFR( NBRECORDS ) INTEGER IW4( N, 2 ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER END_MSG_2_RECV INTEGER(8), INTENT(IN) :: PTRAW( N ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER :: PERM( N ), STEP( N ) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER INTARR( LINTARR ) INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT, LA REAL A( LA ), DBLARR( LDBLARR ) INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER IREC, NB_REC, NODE_TYPE, IPROC INTEGER IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER(8) :: IS8 INTEGER IARR, JARR INTEGER TAILLE LOGICAL :: EARLYT3ROOTINS REAL VAL EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) NB_REC = BUFI( 1 ) IF ( NB_REC .LE. 0 ) THEN END_MSG_2_RECV = END_MSG_2_RECV - 1 NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) GOTO 100 DO IREC = 1, NB_REC IARR = BUFI( IREC * 2 ) JARR = BUFI( IREC * 2 + 1 ) VAL = BUFR( IREC ) NODE_TYPE = MUMPS_TYPENODE( & PROCNODE_STEPS(abs(STEP(abs( IARR )))), & KEEP(199) ) IF ( NODE_TYPE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JARR ) ELSE IPOSROOT = root%RG2L( JARR ) JPOSROOT = root%RG2L( -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 roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%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 IS8 = PTRAW(IARR) DBLARR(IS8) = DBLARR(IS8) + VAL ELSE IS8 = PTRAW(IARR)+IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)), & KEEP(199) ) IF ( IPROC .EQ. MYID ) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL SMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) ENDIF END IF ENDIF ENDDO 100 CONTINUE RETURN END SUBROUTINE SMUMPS_DIST_TREAT_RECV_BUF MUMPS_5.8.1/src/zfac_process_root2son.F0000664000175000017500000003245515042446441017677 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE & ZMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & INODE, NELIM_ROOT, root, roota, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER KEEP(500), ICNTL( 60 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER INODE, NELIM_ROOT INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER INTARR(KEEP8(27)) COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER LCONT, NCOL_TO_SEND, LDA INTEGER(8) :: SHIFT_VAL_SON, POSELT INTEGER FPERE, IOLDPS, NFRONT, NPIV, NASS, NSLAVES, & H_INODE, NELIM, NBCOL, TYPE_SON, & NROW, NCOL, NBROW, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, LDAFS, IERR, & ISON, PDEST_MASTER_ISON INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG LOGICAL TRANSPOSE_ASM INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE FPERE = KEEP(38) TYPE_SON = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ).EQ.MYID) THEN IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NASS = abs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) H_INODE = 6 + NSLAVES + KEEP(IXSZ) NELIM = NASS - NPIV NBCOL = NFRONT - NPIV IF (NELIM.LE.0) THEN write(6,*) ' ERROR 1 in ZMUMPS_PROCESS_ROOT2SON ', NELIM write(6,*) MYID,':Process root2son: INODE=',INODE, & 'Header=',IW(PTLUST_S(STEP(INODE)):PTLUST_S(STEP(INODE)) & +5+KEEP(IXSZ)) CALL MUMPS_ABORT() ENDIF NBROW = NFRONT - NPIV NROW = NELIM IF ( KEEP( 50 ) .eq. 0 ) THEN NCOL = NFRONT - NPIV ELSE NCOL = NELIM END IF SHIFT_LIST_ROW_SON = H_INODE + NPIV SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV IF ( KEEP(50).eq.0 .OR. TYPE_SON .eq. 1 ) THEN LDAFS = NFRONT ELSE LDAFS = NASS END IF SHIFT_VAL_SON = int(NPIV,8) * int(LDAFS,8) + int(NPIV,8) CALL ZMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, & ASS_IRECV, & N, INODE, FPERE, & PTLUST_S(1), PTRAST(1), & root, roota, NROW, NCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDAFS, & ROOT_NON_ELIM_CB, MYID, COMM, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S(1), PTRFAC(1), PTRAST(1), & STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE.,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS, NELIM_ROOT, NELIM, NELIM & ) IF (IFLAG.LT.0 ) RETURN IF (TYPE_SON.EQ.1) THEN NROW = NFRONT - NASS NCOL = NELIM SHIFT_LIST_ROW_SON = H_INODE + NASS SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV SHIFT_VAL_SON = int(NASS,8) * int(NFRONT,8) + int(NPIV,8) IF ( KEEP( 50 ) .eq. 0 ) THEN TRANSPOSE_ASM = .FALSE. ELSE TRANSPOSE_ASM = .TRUE. END IF CALL ZMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTLUST_S, PTRAST, & root, roota, NROW, NCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, & ROOT_NON_ELIM_CB, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP, & TRANSPOSE_ASM,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS, & NELIM_ROOT, 0, NELIM ) 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 IF (KEEP(50).NE.0) THEN CALL ZMUMPS_COMPACT_FACTORS_SYM(A(POSELT), LDA, & NPIV, NBROW, KEEP, & int(LDA,8)*int(NBROW+NPIV,8), IW(IOLDPS+H_INODE+NFRONT)) ELSE CALL ZMUMPS_COMPACT_FACTORS_UNSYM( & A(POSELT+int(NPIV,8)*int(LDA,8)), LDA, & NPIV, NBROW, KEEP, & int(LDA,8)*int(NBROW+NPIV,8) ) ENDIF IW(IOLDPS + KEEP(IXSZ)) = NBCOL IW(IOLDPS + 1 +KEEP(IXSZ)) = NASS - NPIV IF (TYPE_SON.EQ.2) THEN IW(IOLDPS + 2 +KEEP(IXSZ)) = NASS ELSE IW(IOLDPS + 2 +KEEP(IXSZ)) = NFRONT ENDIF IW(IOLDPS + 3 +KEEP(IXSZ)) = NPIV CALL ZMUMPS_COMPRESS_LU(0_8,MYID,N,IOLDPS,TYPE_SON,IW,LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST,PTRFAC,STEP, KEEP,KEEP8, .FALSE.,INODE,IERR & , LRGROUPS, NASS & ) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 RETURN ENDIF ELSE ISON = INODE PDEST_MASTER_ISON = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(ISON)), KEEP(199) ) IF ( PTRIST(STEP(ISON)) .EQ. 0) THEN CALL ZMUMPS_TREAT_DESCBAND( ISON, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE,LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 +KEEP(IXSZ)) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN END DO IOLDPS = PTRIST(STEP(INODE)) LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV IF (NELIM.LE.0) THEN write(6,*) MYID,': INODE,LCONT, NROW, NPIV, NASS, NELIM=', & INODE,LCONT, NROW, NPIV, NASS, NELIM write(6,*) MYID,': IOLDPS=',IOLDPS write(6,*) MYID,': ERROR 2 in ZMUMPS_PROCESS_ROOT2SON ' CALL MUMPS_ABORT() ENDIF NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) H_INODE = 6 + NSLAVES + KEEP(IXSZ) SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NPIV NCOL_TO_SEND = NELIM LDA = -9999 SHIFT_VAL_SON = -9999_8 IF ( KEEP( 50 ) .eq. 0 ) THEN TRANSPOSE_ASM = .FALSE. ELSE TRANSPOSE_ASM = .TRUE. END IF CALL ZMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTRIST, PTRAST, & root, roota, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, & ROOT_NON_ELIM_CB, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,TRANSPOSE_ASM, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS, & NELIM_ROOT, 0, NCOL_TO_SEND ) IF (IFLAG.LT.0 ) RETURN IF (KEEP(214).EQ.2) THEN CALL ZMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP, KEEP8, DKEEP,TYPE_SON & ) ENDIF IF (IFLAG.LT.0) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_PROCESS_ROOT2SON MUMPS_5.8.1/src/csol_bwd_aux.F0000664000175000017500000021025515042446440016015 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SOLVE_NODE_BWD( INODE, & N, IPOOL, LPOOL, IIPOOL, NBFINF, & A, LA, IW, LIW, W, LWC, NRHS, & POSWCB, PLEFTW, POSIWCB, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, & MYLEAF_LEFT, INFO, & PROCNODE_STEPS, DEJA_SEND, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & , DO_MCAST2_TERMBWD & ) USE CMUMPS_OOC USE CMUMPS_BUF USE CMUMPS_SOL_LR, only : CMUMPS_SOL_BWD_LR_SU IMPLICIT NONE INTEGER :: KEEP( 500 ) INTEGER(8) :: KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER :: INFO(80) INTEGER, INTENT( IN ) :: INODE, N, NRHS, MTYPE, LIW, LIWW INTEGER, INTENT( IN ) :: SLAVEF, COMM, MYID INTEGER, INTENT (IN ) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT( IN ) :: NE_STEPS(KEEP(28)) INTEGER(8), INTENT( IN ) :: LA, LWC INTEGER(8), INTENT( INOUT ) :: POSWCB, PLEFTW INTEGER, INTENT( INOUT ) :: POSIWCB INTEGER, INTENT( IN ) :: LPANEL_POS INTEGER :: PANEL_POS(LPANEL_POS) LOGICAL, INTENT(INOUT) :: DEJA_SEND(0:SLAVEF-1) INTEGER, INTENT(IN) :: LPOOL INTEGER, INTENT(INOUT) :: IPOOL(LPOOL), IIPOOL INTEGER, INTENT(INOUT) :: NBFINF, MYLEAF_LEFT INTEGER :: PTRIST(KEEP(28)), PTRICB(KEEP(28)) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX :: A( LA ) COMPLEX :: W(LWC) COMPLEX :: W2(KEEP(133)) INTEGER :: IW(LIW),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)),FILS(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LRHSINTR, POSINRHSINTR_BWD(N) COMPLEX RHSINTR(LRHSINTR,NRHS) INTEGER(8), intent(in) :: LRHS_ROOT COMPLEX RHS_ROOT( LRHS_ROOT ) LOGICAL, INTENT( IN ) :: PRUN_BELOW INTEGER, INTENT(IN) :: SIZE_TO_PROCESS LOGICAL, INTENT(IN) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, INTENT(IN) :: DO_NBSPARSE INTEGER, INTENT(IN) :: LRHS_BOUNDS INTEGER, INTENT(IN) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, INTENT(IN) :: FROM_PP LOGICAL, INTENT( OUT ) :: ERROR_WAS_BROADCASTED LOGICAL, INTENT( OUT ) :: DO_MCAST2_TERMBWD INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR LOGICAL FLAG INCLUDE 'mumps_headers.h' LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL LTLEVEL2, IN_SUBTREE INTEGER TYPENODE INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL NO_CHILDREN LOGICAL :: ALLOW_OTHERS_TO_LEAVE INTEGER :: K, JBDEB, JBFIN, NRHS_B INTEGER IWHDLR INTEGER NPIV INTEGER IPOS,LIELL,NELIM,JJ,I INTEGER J1,J2,J,NCB INTEGER NSLAVES INTEGER IN,IF,LONG,POOL_FIRST_POS,TMP INTEGER :: NBFILS INTEGER :: PROCDEST, DEST INTEGER(8) :: PTWCB, PPIV_COURANT INTEGER :: Offset, EffectiveSize, ISLAVE, FirstIndex INTEGER :: POSINDICES, IPOSINRHSINTR, IPOSINRHSINTR_PANEL INTEGER(8) :: APOS, IST INTEGER(8) :: IFR8 INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER LDAJ, NBJ, & NBJLAST, NPIV_LAST, PANEL_SIZE, & NCB_PANEL, TYPEF INTEGER BEG_PANEL LOGICAL TWOBYTWO INTEGER NPANELS, IPANEL COMPLEX ALPHA,ONE,ZERO PARAMETER (ZERO=(0.0E0,0.0E0), & ONE=(1.0E0,0.0E0), & ALPHA=(-1.0E0,0.0E0)) LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE ERROR_WAS_BROADCASTED = .FALSE. DO_MCAST2_TERMBWD = .FALSE. NO_CHILDREN = .FALSE. IF (DO_NBSPARSE) THEN JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) JBFIN= RHS_BOUNDS(2*STEP(INODE)) NRHS_B = JBFIN-JBDEB+1 ELSE JBDEB = 1 JBFIN = NRHS NRHS_B = NRHS ENDIF IF ( INODE .EQ. KEEP( 38 ) .OR. INODE .EQ. KEEP( 20 ) ) THEN IPOS = PTRIST(STEP(INODE))+KEEP(IXSZ) NPIV = IW(IPOS+3) LIELL = IW(IPOS) + NPIV IPOS = PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) IF ( MTYPE .EQ. 1 .AND. KEEP(50) .EQ. 0) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + LIELL + NPIV ELSE J1 = IPOS + 1 J2 = IPOS + NPIV END IF IFR8 = 0_8 IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) CALL CMUMPS_SOL_CPY_FS2RHSINTR(JBDEB, JBFIN, J2-J1+1, & KEEP, RHSINTR, NRHS, LRHSINTR, IPOSINRHSINTR, & RHS_ROOT(1+NPIV*(JBDEB-1)), NPIV, 1) IN = INODE 270 IN = FILS(IN) IF (IN .GT. 0) GOTO 270 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF (KEEP(31) .NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF RETURN ENDIF IF = -IN LONG = NPIV NBFILS = NE_STEPS(STEP(INODE)) IF ( PRUN_BELOW ) THEN I = NBFILS NBFILS = 0 DO WHILE (I.GT.0) IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 IF = FRERE(STEP(IF)) I = I -1 ENDDO IF (NBFILS.EQ.0) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF IF = -IN ENDIF DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1030 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1030 ENDIF NO_CHILDREN = .FALSE. ENDIF IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)),KEEP(199)) & .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) IF (.NOT. DEJA_SEND( PROCDEST )) THEN 600 CONTINUE CALL CMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, & LONG, LONG, IW( J1 ), & RHS_ROOT( 1+NPIV*(JBDEB-1) ), & JBDEB, JBFIN, & RHSINTR(1, 1), NRHS, LRHSINTR, & IPOSINRHSINTR, NPIV, & KEEP, PROCDEST, & NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, & MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 600 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal error 2 CMUMPS_SOLVE_NODE_BWD", & IERR CALL MUMPS_ABORT() END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF ENDIF IF = FRERE(STEP(IF)) ENDDO ALLOW_OTHERS_TO_LEAVE = .FALSE. IF ( PRUN_BELOW .AND. NO_CHILDREN ) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) ENDIF IF ( KEEP(31). NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF IF (IIPOOL.NE.POOL_FIRST_POS) THEN DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP = IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1) = IPOOL(IIPOOL-I) IPOOL(IIPOOL-I) = TMP ENDDO ENDIF RETURN END IF IN_SUBTREE = MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) TYPENODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) LTLEVEL2= ( & (TYPENODE .eq.2 ) .AND. & (MTYPE.NE.1) ) NPIV = IW(PTRIST(STEP(INODE))+2+KEEP(IXSZ)+1) IF ((NPIV.NE.0).AND.(LTLEVEL2)) THEN IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) NCB = LIELL - NPIV - NELIM IPOS = IPOS + 2 NSLAVES = IW( IPOS ) Offset = 0 IPOS = IPOS + NSLAVES IW(PTRIST(STEP(INODE))+XXS)= C_FINI+NSLAVES IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL CMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR(NCB * NRHS_B - POSWCB-PLEFTW+1_8, & INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - int(NCB,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = NCB*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF IF ( NCB.EQ.0 ) THEN write(6,*) ' Internal Error type 2 node with no CB ' CALL MUMPS_ABORT() ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + NELIM +1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + NELIM +1 J2 = IPOS + LIELL END IF IFR8 = PTRACB(STEP( INODE )) - 1_8 CALL CMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSINTR, NRHS, LRHSINTR, & W(PTRACB(STEP(INODE))), NCB, 1, & IW, LIW, KEEP, N, POSINRHSINTR_BWD ) IFR8 = IFR8 + int(J2-KEEP(253)-J1+1,8) IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR8 = IFR8 + 1_8 DO K=JBDEB, JBFIN IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR8+int(K-JBDEB,8)*int(NCB,8)) = ALPHA ELSE W(IFR8+int(K-JBDEB,8)*int(NCB,8)) = ZERO ENDIF ENDDO ENDDO ENDIF DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & EffectiveSize, & FirstIndex ) 500 CONTINUE DEST = IW( PTRIST(STEP(INODE))+5+ISLAVE+KEEP(IXSZ)) CALL CMUMPS_BUF_SEND_BACKVEC(NRHS_B, INODE, & W(Offset+PTRACB(STEP(INODE))), & EffectiveSize, & NCB, DEST, & BACKSLV_MASTER2SLAVE, JBDEB, JBFIN, & KEEP, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, & PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 500 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF Offset = Offset + EffectiveSize END DO IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL CMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) RETURN ENDIF LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) NCB = LIELL - NPIV IPOS = IPOS + 1 IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ENDIF APOS = PTRFAC( STEP(INODE)) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 + NSLAVES IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN IF (MTYPE.NE.1) THEN TYPEF = TYPEF_L ELSE TYPEF = TYPEF_U ENDIF PANEL_SIZE = CMUMPS_OOC_PANEL_SIZE( LIELL ) IF (KEEP(50).NE.1) THEN CALL CMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF LONG = 0 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL ELSE J1 = IPOS + 1 J2 = IPOS + NPIV ENDIF IF (IN_SUBTREE) THEN PTWCB = PLEFTW IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN CALL CMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(int(LIELL,8)*int(NRHS_B,8)-POSWCB, & INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF ELSE IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL CMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB ) IF ( POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR( int(LIELL,8)*int(NRHS_B,8)- & POSWCB-PLEFTW+1_8, & INFO(2) ) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - int(LIELL,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF PTWCB = PTRACB(STEP( INODE )) ENDIF IF (J2.GE.J1) THEN IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) ELSE IPOSINRHSINTR = -99999 ENDIF IF (J2.GE.J1) THEN DO K=JBDEB, JBFIN IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = ZERO ENDDO ENDIF END DO ENDIF IFR8 = PTWCB + int(NPIV - 1,8) IF ( LIELL .GT. NPIV ) THEN IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + 1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + 1 J2 = IPOS + LIELL END IF CALL CMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSINTR, NRHS, LRHSINTR, & W(PTWCB), LIELL, NPIV+1, & IW, LIW, KEEP, N, POSINRHSINTR_BWD ) IFR8 = IFR8 + int(J2-KEEP(253)-J1+1,8) IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR8 = IFR8 + 1_8 DO K=JBDEB, JBFIN IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR8+int(K-JBDEB,8)*int(LIELL,8)) = ALPHA ELSE W(IFR8+int(K-JBDEB,8)*int(LIELL,8)) = ZERO ENDIF ENDDO ENDDO ENDIF NCB = LIELL - NPIV IF (NPIV .EQ. 0) GOTO 160 ENDIF IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN J = NPIV / PANEL_SIZE TWOBYTWO = KEEP(50).EQ.2 .AND. & ((TYPENODE.EQ.1.AND.KEEP(103).GT.0) .OR. & (TYPENODE.EQ.2.AND.KEEP(105).GT.0)) IF (TWOBYTWO) THEN CALL CMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, LPANEL_POS, & IW(IPOS+1+LIELL), NPIV, NPANELS, LIELL, & NBENTRIES_ALLPANELS) ELSE IF (NPIV.EQ.J*PANEL_SIZE) THEN NPIV_LAST = NPIV NBJLAST = PANEL_SIZE NPANELS = J ELSE NPIV_LAST = (J+1)* PANEL_SIZE NBJLAST = NPIV-J*PANEL_SIZE NPANELS = J+1 ENDIF NBENTRIES_ALLPANELS = & int(LIELL,8) * int(NPIV,8) & - int( ( J * ( J - 1 ) ) /2,8 ) & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) & - int(J,8) & * int(mod(NPIV, PANEL_SIZE),8) & * int(PANEL_SIZE,8) JJ=NPIV_LAST ENDIF APOSDEB = APOS + NBENTRIES_ALLPANELS DO IPANEL = NPANELS, 1, -1 IF (TWOBYTWO) THEN NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) BEG_PANEL = PANEL_POS(IPANEL) ELSE IF (JJ.EQ.NPIV_LAST) THEN NBJ = NBJLAST ELSE NBJ = PANEL_SIZE ENDIF BEG_PANEL = JJ- PANEL_SIZE+1 ENDIF LDAJ = LIELL-BEG_PANEL+1 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) IPOSINRHSINTR_PANEL = IPOSINRHSINTR + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ IF (KEEP(50).NE.1.AND.MUST_BE_PERMUTED) THEN CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) IF (NPIV.EQ.(IW(I_PIVRPTR)-1)) THEN MUST_BE_PERMUTED=.FALSE. ELSE CALL CMUMPS_PERMUTE_PANEL( & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, BEG_PANEL-1) ENDIF ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB.NE. 0) THEN CALL cgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL+NBJ,JBDEB), & 1, ONE, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1 ) ENDIF IF (NCB .NE. 0) THEN CALL cgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1 ) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL ctrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1) ELSE CALL ctrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1) ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB .NE. 0) THEN CALL cgemm( 'T', 'N', NBJ, NRHS_B, & NCB_PANEL-NCB, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL+NBJ,JBDEB), LRHSINTR, & ONE, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ENDIF IF (NCB .NE. 0) THEN CALL cgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, & W( PTWCB+int(NPIV,8) ), LIELL, & ONE, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB),LRHSINTR) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL ctrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ELSE CALL ctrsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO ELSE IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 & .AND. KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL CMUMPS_SOL_BWD_LR_SU ( & INODE, IWHDLR, NPIV, NSLAVES, & LIELL, W, LWC, NRHS_B, PTWCB, & RHSINTR, LRHSINTR, NRHS, & IPOSINRHSINTR, JBDEB, & MTYPE, KEEP, KEEP8, & INFO(1), INFO(2) ) IF (INFO(1).LT.0) THEN ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ELSE IF ( LIELL .GT. NPIV ) THEN IF ( MTYPE .eq. 1 ) THEN IST = APOS + int(NPIV,8) #if defined(MUMPS_USE_BLAS2) IF (NRHS_B == 1) THEN CALL cgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(PTWCB+int(NPIV,8)), 1, & ONE, & RHSINTR(IPOSINRHSINTR,JBDEB), 1 ) ELSE #endif CALL cgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), & LIELL, W(PTWCB+int(NPIV,8)), LIELL, ONE, & RHSINTR(IPOSINRHSINTR,JBDEB), LRHSINTR) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE IF ( KEEP(50) .eq. 0 ) THEN IST = APOS + int(NPIV,8) * int(LIELL,8) ELSE IF( KEEP(459) .GT. 1) THEN CALL MUMPS_GETI8(IST, IW(PTRIST(STEP(INODE))+XXR)) IST = APOS + IST - int(NPIV,8) * int(LIELL-NPIV,8) ELSE IST = APOS + int(NPIV,8) * int(NPIV,8) ENDIF END IF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL cgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSINTR(IPOSINRHSINTR,JBDEB), 1 ) ELSE #endif CALL cgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), & NPIV, W(PTWCB+int(NPIV,8)), LIELL, & ONE, RHSINTR(IPOSINRHSINTR,JBDEB), LRHSINTR) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF ENDIF IF ( MTYPE .eq. 1 ) THEN LDAJ = LIELL ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=LIELL ELSE IF (KEEP(459).GT.1) THEN LDAJ=-999799 ELSE LDAJ=NPIV ENDIF ENDIF END IF PPIV_COURANT = int(JBDEB-1,8)*int(LRHSINTR,8) & + int(IPOSINRHSINTR,8) IF (KEEP(459).GT.1 .AND. KEEP(50).NE.0) THEN CALL CMUMPS_SOLVE_BWD_PANELS( A, LA, APOS, & NPIV, IW(IPOS+1+LIELL), & NRHS_B, RHSINTR(1,1), KEEP8(25), LRHSINTR, PPIV_COURANT, & MTYPE, KEEP ) ELSE CALL CMUMPS_SOLVE_BWD_TRSOLVE( A, LA, APOS, & NPIV, LDAJ, & NRHS_B, RHSINTR(1,1), KEEP8(25), LRHSINTR, PPIV_COURANT, & MTYPE, KEEP ) ENDIF ENDIF ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN J1 = IPOS + LIELL + 1 ELSE J1 = IPOS + 1 END IF IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) 160 CONTINUE IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ENDIF IN = INODE 170 IN = FILS(IN) IF (IN .GT. 0) GOTO 170 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 IF (.NOT. IN_SUBTREE ) THEN IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 CALL CMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF ( KEEP(31) .NE. 0 .AND. & .NOT. IN_SUBTREE ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31).EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF RETURN ENDIF IF = -IN NBFILS = NE_STEPS(STEP(INODE)) IF ( PRUN_BELOW ) THEN I = NBFILS NBFILS = 0 DO WHILE (I.GT.0) IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 IF = FRERE(STEP(IF)) I = I -1 ENDDO IF (NBFILS.EQ.0) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF IF = -IN ENDIF IF (IN_SUBTREE) THEN DO I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1010 CONTINUE IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1010 ENDIF NO_CHILDREN = .FALSE. ENDIF IPOOL((IIPOOL-I+1)+NBFILS-I) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ENDDO IF (PRUN_BELOW .AND. NO_CHILDREN) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF (ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 RETURN ENDIF ENDIF ELSE DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO 190 I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1020 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1020 ENDIF NO_CHILDREN = .FALSE. ENDIF IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) IF (.not. DEJA_SEND( PROCDEST )) THEN 400 CONTINUE CALL CMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, & LIELL, LIELL - KEEP(253), & IW( POSINDICES ), & W( PTRACB(STEP(INODE)) ), JBDEB, JBFIN, & RHSINTR(1, 1), NRHS, LRHSINTR, & IPOSINRHSINTR, NPIV, & KEEP, PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF IF = FRERE(STEP(IF)) ENDIF 190 CONTINUE IF ( PRUN_BELOW .AND. NO_CHILDREN ) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF ( ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 RETURN ENDIF ENDIF DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO IF ( KEEP(31) .NE. 0 ) & THEN KEEP(31) = KEEP(31) - 1 ALLOW_OTHERS_TO_LEAVE = (KEEP(31) .EQ. 1) IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF ENDIF IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 CALL CMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF RETURN END SUBROUTINE CMUMPS_SOLVE_NODE_BWD RECURSIVE SUBROUTINE CMUMPS_BACKSLV_RECV_AND_TREAT( & BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IMPLICIT NONE LOGICAL BLOQ, FLAG INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER(8), intent(in) :: LWC COMPLEX W( LWC ) INTEGER POSIWCB INTEGER IIPOOL, LPOOL INTEGER IPOOL( LPOOL ) INTEGER LPANEL_POS INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(80), KEEP(500) INTEGER(8) :: POSWCB, PLEFTW INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER LIW INTEGER(8) :: LA INTEGER PTRIST(KEEP(28)), IW( LIW ) INTEGER (8) :: PTRFAC(KEEP(28)) COMPLEX A( LA ), W2( KEEP(133) ) INTEGER NRHS INTEGER MYLEAF_LEFT, MTYPE INTEGER LRHSINTR, POSINRHSINTR_BWD(N) COMPLEX RHSINTR(LRHSINTR,NRHS) LOGICAL, INTENT(IN) :: PRUN_BELOW INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR FLAG = .FALSE. IF ( BLOQ ) THEN CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF (FLAG) THEN KEEP(266)=KEEP(266)-1 MSGSOU=STATUS(MPI_SOURCE) MSGTAG=STATUS(MPI_TAG) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN INFO(1) = -20 INFO(2) = MSGLEN IF (NBFINF .NE. 0) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ELSE CALL MPI_RECV(BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, COMM, STATUS, IERR) CALL CMUMPS_BACKSLV_TRAITER_MESSAGE( MSGTAG, MSGSOU, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) END IF END IF RETURN END SUBROUTINE CMUMPS_BACKSLV_RECV_AND_TREAT RECURSIVE SUBROUTINE CMUMPS_BACKSLV_TRAITER_MESSAGE( & MSGTAG, MSGSOU, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) USE CMUMPS_OOC USE CMUMPS_SOL_LR, ONLY: CMUMPS_SOL_SLAVE_LR_U, & CMUMPS_SOL_BWD_LR_SU USE CMUMPS_BUF IMPLICIT NONE INTEGER MSGTAG, MSGSOU INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER(8), intent(in) :: LWC COMPLEX W( LWC ) INTEGER POSIWCB INTEGER IIPOOL, LPOOL, LPANEL_POS INTEGER IPOOL( LPOOL ) INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(80), KEEP(500) INTEGER(8) :: POSWCB, PLEFTW INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER FRERE(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER LIW INTEGER(8) :: LA INTEGER IW( LIW ), PTRIST( KEEP(28) ) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX A( LA ), W2( KEEP(133) ) INTEGER NRHS INTEGER MYLEAF_LEFT, MTYPE INTEGER LRHSINTR, POSINRHSINTR_BWD(N) COMPLEX RHSINTR(LRHSINTR,NRHS) LOGICAL, INTENT(IN) :: PRUN_BELOW INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS), NO_CHILDREN LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IF, INODE, IERR, LONG, DUMMY(1) INTEGER :: LIELL, K INTEGER(8) :: APOS, IST INTEGER NPIV, NROW_L, IPOS, NROW_RECU INTEGER(8) :: IFR8 INTEGER I, JJ, IN, PROCDEST, J1, J2, LDA INTEGER NSLAVES, NELIM, J, POSINDICES, INODEPOS, & IPOSINRHSINTR, IPOSINRHSINTR_PANEL INTEGER JBDEB, JBFIN, NRHS_B, allocok INTEGER(8) :: P_UPDATE, P_SOL_MAS INTEGER :: IWHDLR, MTYPE_SLAVE, LDA_SLAVE LOGICAL FLAG COMPLEX ZERO, ALPHA, ONE PARAMETER (ZERO=(0.0E0,0.0E0), & ONE=(1.0E0,0.0E0), & ALPHA=(-1.0E0,0.0E0)) INCLUDE 'mumps_headers.h' INTEGER POOL_FIRST_POS, TMP LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: NCB INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER(8) :: PTWCB, PPIV_COURANT INTEGER LDAJ, NBJ, & NBJLAST, NPIV_LAST, PANEL_SIZE, & NCB_PANEL, TYPEF LOGICAL TWOBYTWO INTEGER BEG_PANEL INTEGER IPANEL, NPANELS INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL :: ALLOW_OTHERS_TO_LEAVE LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_PROCNODE ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then INFO(1)=-13 INFO(2)=SLAVEF WRITE(6,*) MYID,' Allocation error of DEJA_SEND ' & //'in bwd solve COMPSO' GOTO 260 END IF DUMMY(1)=0 IF (MSGTAG .EQ. TERMBWD) THEN NBFINF = NBFINF - 1 ELSE IF (MSGTAG .EQ. NOEUD) THEN POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & LONG, 1, MPI_INTEGER, & COMM, IERR) NRHS_B = JBFIN-JBDEB+1 IF ( POSIWCB - LONG .LT. 0 & .OR. POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN CALL CMUMPS_COMPSO(N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF (POSIWCB - LONG .LT. 0) THEN INFO(1)=-14 INFO(2)=-POSIWCB + LONG WRITE(6,*) MYID,' Internal error 1 in bwd solve COMPSO' GOTO 260 END IF IF ( POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(LONG + PLEFTW - POSWCB - 1_8, & INFO(2)) WRITE(6,*) MYID,' Internal error 2 in bwd solve COMPSO' GOTO 260 END IF ENDIF POSIWCB = POSIWCB - LONG POSWCB = POSWCB - LONG IF (LONG .GT. 0) THEN CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IWCB(POSIWCB + 1), & LONG, MPI_INTEGER, COMM, IERR) DO K=JBDEB,JBFIN CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & W(POSWCB + 1), LONG, & MPI_COMPLEX, COMM, IERR) DO JJ=0, LONG-1 IPOSINRHSINTR = abs( POSINRHSINTR_BWD( IWCB( & POSIWCB+1+JJ ) ) ) IF (IPOSINRHSINTR.EQ.0) CYCLE RHSINTR(IPOSINRHSINTR,K) = W(POSWCB+1+JJ) ENDDO ENDDO POSIWCB = POSIWCB + LONG POSWCB = POSWCB + LONG ENDIF POOL_FIRST_POS = IIPOOL IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(INODE))) & GOTO 1010 ENDIF IPOOL( IIPOOL ) = INODE IIPOOL = IIPOOL + 1 1010 CONTINUE IF = FRERE( STEP(INODE) ) DO WHILE ( IF .GT. 0 ) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) .eq. MYID ) THEN IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(IF))) THEN IF = FRERE(STEP(IF)) CYCLE ENDIF ENDIF IPOOL( IIPOOL ) = IF IIPOOL = IIPOOL + 1 END IF IF = FRERE( STEP( IF ) ) END DO DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO ELSE IF ( MSGTAG .EQ. BACKSLV_MASTER2SLAVE ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NROW_RECU, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) NPIV = - IW( IPOS ) NROW_L = IW( IPOS + 1 ) IF ( NROW_L .NE. NROW_RECU ) THEN WRITE(*,*) 'Error1 : NROW L/RECU=',NROW_L, NROW_RECU CALL MUMPS_ABORT() END IF LONG = NROW_L + NPIV IF ( POSWCB - int(LONG,8)*int(NRHS_B,8) .LT. PLEFTW - 1_8 ) THEN CALL CMUMPS_COMPSO( N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LONG*NRHS_B .LT. PLEFTW - 1_8 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(LONG * NRHS_B- POSWCB,INFO(2)) WRITE(6,*) MYID,' Internal error 3 in bwd solve COMPSO' GOTO 260 END IF END IF P_UPDATE = PLEFTW P_SOL_MAS = PLEFTW + int(NPIV,8) * int(NRHS_B,8) PLEFTW = P_SOL_MAS + int(NROW_L,8) * int(NRHS_B,8) DO K=JBDEB, JBFIN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W( P_SOL_MAS+(K-JBDEB)*NROW_L),NROW_L, & MPI_COMPLEX, & COMM, IERR ) ENDDO IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF APOS = PTRFAC( STEP(INODE)) IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) MTYPE_SLAVE = 0 W(P_UPDATE:P_UPDATE+NPIV*NRHS_B-1)=ZERO CALL CMUMPS_SOL_SLAVE_LR_U(INODE, IWHDLR, -9999, & W, LWC, & NROW_L, NPIV, & P_SOL_MAS, P_UPDATE, & JBDEB, JBFIN, & MTYPE_SLAVE, KEEP, KEEP8, & INFO(1), INFO(2) ) ELSE IF (KEEP(201) .EQ. 1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN MTYPE_SLAVE = 1 LDA_SLAVE = NROW_L ELSE MTYPE_SLAVE = 0 LDA_SLAVE = NPIV ENDIF CALL CMUMPS_SOLVE_GEMM_UPDATE( & A, LA, APOS, NROW_L, & LDA_SLAVE, & NPIV, & NRHS_B, W, LWC, & P_SOL_MAS, NROW_L, & P_UPDATE, NPIV, & MTYPE_SLAVE, KEEP, ZERO) ENDIF IF (KEEP(201) .EQ. 1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN CALL CMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF PLEFTW = PLEFTW - int(NROW_L,8) * int(NRHS_B,8) 100 CONTINUE CALL CMUMPS_BUF_SEND_BACKVEC( NRHS_B, INODE, & W(P_UPDATE), & NPIV, NPIV, & MSGSOU, & BACKSLV_UPDATERHS, & JBDEB, JBFIN, & KEEP, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 100 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) GOTO 260 END IF PLEFTW = PLEFTW - NPIV * NRHS_B ELSE IF ( MSGTAG .EQ. BACKSLV_UPDATERHS ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPIV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) IPOS = IPOS + 1 NSLAVES = IW( IPOS + 1 ) IPOS = IPOS + 1 + NSLAVES INODEPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 4 IF ( KEEP(50) .eq. 0 ) THEN LDA = LIELL ELSE LDA = NPIV ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL ELSE J1 = IPOS + 1 J2 = IPOS + NPIV ENDIF IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) DO K=JBDEB, JBFIN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W2, NPIV, MPI_COMPLEX, & COMM, IERR ) I = 1 IF ( (KEEP(253).NE.0) .AND. & (IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI+NSLAVES) & ) THEN DO JJ = J1,J2 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = W2(I) I = I+1 ENDDO ELSE DO JJ = J1,J2 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = & RHSINTR(IPOSINRHSINTR+JJ-J1,K) + W2(I) I = I+1 ENDDO ENDIF ENDDO IW(PTRIST(STEP(INODE))+XXS) = & IW(PTRIST(STEP(INODE))+XXS) - 1 IF ( IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI ) THEN IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN CALL CMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL CMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF APOS = PTRFAC(IW(INODEPOS)) IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN TYPEF = TYPEF_L NROW_L = NPIV+NELIM PANEL_SIZE = CMUMPS_OOC_PANEL_SIZE(NROW_L) IF (PANEL_SIZE.LT.0) THEN WRITE(6,*) ' Internal error in bwd solve PANEL_SIZE=', & PANEL_SIZE CALL MUMPS_ABORT() ENDIF ENDIF IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL CMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB ) IF ( POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR( int(LIELL,8)*int(NRHS_B,8)- & POSWCB-PLEFTW+1_8, & INFO(2) ) GOTO 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 - int(LIELL,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 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 PTWCB = PTRACB(STEP( INODE )) IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) IFR8 = PTRACB(STEP( INODE )) IFR8 = PTWCB + int(NPIV - 1,8) IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + 1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + 1 J2 = IPOS + LIELL END IF CALL CMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSINTR, NRHS, LRHSINTR, & W(PTWCB), LIELL, NPIV+1, & IW, LIW, KEEP, N, POSINRHSINTR_BWD ) IFR8 = IFR8 + int(J2-KEEP(253)-J1+1,8) IF ( KEEP(201).EQ.1 .AND. OOCWRITE_COMPATIBLE_WITH_BLR .AND. & (( NELIM .GT. 0 ).OR. (MTYPE.NE.1 ))) THEN J = NPIV / PANEL_SIZE TWOBYTWO = KEEP(50).EQ.2 .AND. KEEP(105).GT.0 IF (TWOBYTWO) THEN CALL CMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, LPANEL_POS, & IW(IPOS+1+LIELL), NPIV, NPANELS, NROW_L, & NBENTRIES_ALLPANELS) ELSE IF (NPIV.EQ.J*PANEL_SIZE) THEN NPIV_LAST = NPIV NBJLAST = PANEL_SIZE NPANELS = J ELSE NPIV_LAST = (J+1)* PANEL_SIZE NBJLAST = NPIV-J*PANEL_SIZE NPANELS = J+1 ENDIF NBENTRIES_ALLPANELS = & int(NROW_L,8) * int(NPIV,8) & - int( ( J * ( J - 1 ) ) /2,8 ) & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) & - int(J,8) & * int(mod(NPIV, PANEL_SIZE),8) & * int(PANEL_SIZE,8) JJ=NPIV_LAST ENDIF APOSDEB = APOS + NBENTRIES_ALLPANELS DO IPANEL = NPANELS, 1, -1 IF (TWOBYTWO) THEN NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) BEG_PANEL = PANEL_POS(IPANEL) ELSE IF (JJ.EQ.NPIV_LAST) THEN NBJ = NBJLAST ELSE NBJ = PANEL_SIZE ENDIF BEG_PANEL = JJ- PANEL_SIZE+1 ENDIF LDAJ = NROW_L-BEG_PANEL+1 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) PTWCB = PTRACB(STEP(INODE)) IPOSINRHSINTR_PANEL = IPOSINRHSINTR + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ NCB = NROW_L - NPIV IF (KEEP(50).NE.1 .AND.MUST_BE_PERMUTED) THEN CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) CALL CMUMPS_PERMUTE_PANEL( & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, BEG_PANEL-1) ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB.NE. 0) THEN CALL cgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL+NBJ,JBDEB), & 1, ONE, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1 ) ENDIF IF (NCB .NE. 0) THEN CALL cgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1 ) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL ctrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1) ELSE CALL ctrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1) ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB .NE. 0) THEN CALL cgemm( 'T', 'N', NBJ, NRHS_B, & NCB_PANEL-NCB, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL+NBJ,JBDEB), LRHSINTR, & ONE, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ENDIF IF (NCB .NE. 0) THEN CALL cgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, & W( PTWCB+int(NPIV,8) ), LIELL, & ONE, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB),LRHSINTR) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL ctrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ELSE CALL ctrsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO GOTO 1234 ENDIF IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 & .AND. KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL CMUMPS_SOL_BWD_LR_SU ( & INODE, IWHDLR, NPIV, NSLAVES, & LIELL, W, LWC, NRHS_B, PTRACB(STEP(INODE)), & RHSINTR, LRHSINTR, NRHS, & IPOSINRHSINTR, JBDEB, & MTYPE, KEEP, KEEP8, & INFO(1), INFO(2) ) ELSE IF (NELIM .GT.0) THEN IF ( KEEP(50) .eq. 0 ) THEN IST = APOS + int(NPIV,8) * int(LIELL,8) ELSE IF( KEEP(459) .GT. 1) THEN CALL MUMPS_GETI8(IST, IW(PTRIST(STEP(INODE))+XXR)) IST = APOS + IST - int(NPIV,8) * int(NELIM,8) ELSE IST = APOS + int(NPIV,8) * int(NPIV,8) ENDIF END IF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL cgemv( 'N', NPIV, NELIM, ALPHA, A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, & RHSINTR(IPOSINRHSINTR,JBDEB), 1 ) ELSE #endif CALL cgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))), LIELL, & ONE, RHSINTR(IPOSINRHSINTR,JBDEB), LRHSINTR) #if defined(MUMPS_USE_BLAS2) END IF #endif ENDIF PPIV_COURANT = int(JBDEB-1,8)*int(LRHSINTR,8) & + int(IPOSINRHSINTR,8) IF (KEEP(459).GT.1 .AND. KEEP(50).NE.0) THEN CALL CMUMPS_SOLVE_BWD_PANELS( A, LA, APOS, & NPIV, IW(IPOS+1+LIELL), & NRHS_B, RHSINTR(1,1), KEEP8(25), LRHSINTR, PPIV_COURANT, & MTYPE, KEEP ) ELSE CALL CMUMPS_SOLVE_BWD_TRSOLVE( A, LA, APOS, & NPIV, LDA, & NRHS_B, RHSINTR(1,1), KEEP8(25), LRHSINTR, PPIV_COURANT, & MTYPE, KEEP ) ENDIF ENDIF 1234 CONTINUE IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 6 + NSLAVES IPOSINRHSINTR = POSINRHSINTR_BWD(IW(IPOS)) IN = INODE 170 IN = FILS(IN) IF (IN .GT. 0) GOTO 170 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) IF (KEEP(31) .NE. 0) THEN IF (.NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & TERMBWD, SLAVEF, KEEP ) NBFINF = NBFINF - 1 ENDIF IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 CALL CMUMPS_FREETOPSO(N, KEEP(28), & IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) GOTO 270 ENDIF DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO IN = -IN IF ( PRUN_BELOW ) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF DO WHILE (IN.GT.0) IF ( PRUN_BELOW ) THEN IF ( .NOT.TO_PROCESS(STEP(IN)) ) THEN IN = FRERE(STEP(IN)) CYCLE ELSE NO_CHILDREN = .FALSE. ENDIF ENDIF POOL_FIRST_POS = IIPOOL IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)), & KEEP(199)) .EQ. MYID) THEN IPOOL(IIPOOL ) = IN IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IN)), & KEEP(199) ) IF ( .NOT. DEJA_SEND( PROCDEST ) ) THEN 400 CONTINUE CALL CMUMPS_BUF_SEND_VCB( NRHS_B, IN, 0, 0, & LIELL, LIELL - KEEP(253), & IW( POSINDICES ), & W( PTRACB(STEP(INODE)) ), JBDEB, JBFIN, & RHSINTR(1, 1), NRHS, LRHSINTR, & IPOSINRHSINTR, NPIV, & KEEP, PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN GOTO 270 ENDIF GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) GOTO 260 END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF END IF IN = FRERE( STEP( IN ) ) END DO ALLOW_OTHERS_TO_LEAVE = .FALSE. IF (NO_CHILDREN) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) ENDIF IF (KEEP(31) .NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERMBWD, SLAVEF, KEEP ) NBFINF = NBFINF - 1 ENDIF IF ( .NOT. NO_CHILDREN ) THEN DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO ENDIF IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL CMUMPS_FREETOPSO( N, KEEP(28), & IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) END IF ELSE IF (MSGTAG.EQ.TERREUR) THEN INFO(1) = -001 INFO(2) = MSGSOU GO TO 270 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. & (MSGTAG.EQ.TAG_DUMMY) ) THEN GO TO 270 ELSE INFO(1) = -100 INFO(2) = MSGTAG GOTO 260 ENDIF GO TO 270 260 CONTINUE IF (NBFINF .NE. 0) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 270 CONTINUE IF (allocated(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE CMUMPS_BACKSLV_TRAITER_MESSAGE SUBROUTINE CMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, & LEN_PANEL_POS, INDICES, NPIV, & NPANELS, NFRONT_OR_NASS, & NBENTRIES_ALLPANELS) IMPLICIT NONE INTEGER, intent (in) :: PANEL_SIZE, NPIV INTEGER, intent (in) :: INDICES(NPIV) INTEGER, intent (in) :: LEN_PANEL_POS INTEGER, intent (out) :: NPANELS INTEGER, intent (out) :: PANEL_POS(LEN_PANEL_POS) INTEGER, intent (in) :: NFRONT_OR_NASS INTEGER(8), intent(out):: NBENTRIES_ALLPANELS INTEGER NPANELS_MAX, I, NBeff INTEGER(8) :: NBENTRIES_THISPANEL NBENTRIES_ALLPANELS = 0_8 NPANELS_MAX = (NPIV+PANEL_SIZE-1)/PANEL_SIZE IF (LEN_PANEL_POS .LT. NPANELS_MAX + 1) THEN WRITE(*,*) "Error 1 in CMUMPS_BUILD_PANEL_POS", & LEN_PANEL_POS,NPANELS_MAX CALL MUMPS_ABORT() ENDIF I = 1 NPANELS = 0 IF (I .GT. NPIV) RETURN 10 CONTINUE NPANELS = NPANELS + 1 PANEL_POS(NPANELS) = I NBeff = min(PANEL_SIZE, NPIV-I+1) IF ( INDICES(I+NBeff-1) < 0) THEN NBeff=NBeff+1 ENDIF NBENTRIES_THISPANEL = int(NFRONT_OR_NASS-I+1,8) * int(NBeff,8) NBENTRIES_ALLPANELS = NBENTRIES_ALLPANELS + NBENTRIES_THISPANEL I=I+NBeff IF ( I .LE. NPIV ) GOTO 10 PANEL_POS(NPANELS+1)=NPIV+1 RETURN END SUBROUTINE CMUMPS_BUILD_PANEL_POS MUMPS_5.8.1/src/dfac_front_LU_type2.F0000664000175000017500000011633015042446437017201 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC2_LU_M CONTAINS SUBROUTINE DMUMPS_FAC2_LU( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP,PIVNUL_LIST_STRUCT & , LRGROUPS & ) !$ USE OMP_LIB USE DMUMPS_FAC_FRONT_AUX_M USE DMUMPS_FAC_FRONT_TYPE2_AUX_M USE DMUMPS_OOC USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_TEST USE DMUMPS_FAC_LR USE DMUMPS_LR_CORE USE DMUMPS_LR_TYPE USE MUMPS_LR_STATS USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_DATA_M !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW INTEGER, intent(inout) :: NOFFW, NPVW, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW INTEGER(8) :: LA INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) DOUBLE PRECISION UU, SEUIL TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) INTEGER NBFIN, SLAVEF, & IFLAG, IERROR, LEAF, LPOOL INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N), & PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL AVOID_DELAYED TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER :: IBEG_BLOCK_FOR_IPIV INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv LOGICAL LASTPANEL INTEGER(8) :: POSELT INTEGER IOLDPS, allocok, K263,J INTEGER idummy DOUBLE PRECISION UUTEMP LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER CURRENT_BLR, NELIM LOGICAL LR_ACTIVATED, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER :: IROW_L, NVSCHUR, NSLAVES INTEGER :: PIVOT_OPTION, LAST_COL, FIRST_COL INTEGER :: PARPIV_T1 INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER :: INFO_TMP(2) INTEGER :: MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR, END_I INTEGER MAXI_CLUSTER, LWORK TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_U, BLR_SEND DOUBLE PRECISION, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP, BEGS_BLR_STATIC INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, LorU, I, IP, MEM, & MEM_TOT INTEGER(8) :: POSELT_DIAG CHARACTER(len=1) :: DIR DOUBLE PRECISION, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) DOUBLE PRECISION, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER(8) :: UPOS, LPOS INTEGER :: MY_NUM LOGICAL :: SWAP_OCCURRED INCLUDE 'mumps_headers.h' NULLIFY(BLR_L,BLR_U) NULLIFY(PTDummy) NULLIFY(ACC_LUA) NULLIFY(BEGS_BLR) NULLIFY(BLR_L, BLR_U, BLR_SEND) NULLIFY(DIAG) NULLIFY(BLR_PANEL) NULLIFY( BEGS_BLR_TMP, BEGS_BLR_STATIC) IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF SWAP_OCCURRED = .FALSE. idummy = 0 IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) NASS = abs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) PARPIV_T1 = 0 INOPV = 0 SEUIL_LOC = SEUIL IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE UUTEMP=UU ENDIF CALL DMUMPS_SET_INNERBLOCKSIZE( NBKJIB_ORIG, NASS, KEEP) IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN NSLAVES = IW(IOLDPS+5+XSIZE) IROW_L = IOLDPS+6+XSIZE+NSLAVES+NASS CALL DMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IF (LR_ACTIVATED) THEN K263 = 1 ELSE K263 = KEEP(263) IF (K263 .NE. 0 .AND. NASS/NBLR_ORIG < 4) THEN IF ( NBLR_ORIG .GT. NBKJIB_ORIG * 4 ) THEN NBLR_ORIG = max(NBKJIB_ORIG, (NASS+3)/4) ELSE K263 = 0 ENDIF ENDIF ENDIF PIVOT_OPTION = KEEP(468) IF ( UUTEMP == 0.0D0 .AND. & .NOT.( & OOC_EFFECTIVE_ON_FRONT & ) & ) THEN IF (K263.EQ.1.AND.(.NOT.LR_ACTIVATED)) THEN PIVOT_OPTION = 0 ENDIF ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID,' : DMUMPS_FAC2_LU :failed to allocate ', & NASS, ' integers' IFLAG = -13 IERROR =NASS GO TO 500 END IF CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF ( OOC_EFFECTIVE_ON_FRONT ) THEN LNextPiv2beWritten = 1 UNextPiv2beWritten = 1 PP_FIRST2SWAP_L = LNextPiv2beWritten PP_FIRST2SWAP_U = UNextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%LastPanelWritten_U = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 2 MonBloc%NROW = NASS MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -68877 NULLIFY(MonBloc%INDICES) ENDIF IF (LR_ACTIVATED) THEN PIVOT_OPTION = 4 IF (KEEP(475).EQ.1) THEN PIVOT_OPTION = 3 ELSEIF (KEEP(475).EQ.2) THEN PIVOT_OPTION = 3 ELSEIF (KEEP(475).EQ.3) THEN IF (UUTEMP == 0.0D0) THEN PIVOT_OPTION = 0 ELSE PIVOT_OPTION = 1 ENDIF ENDIF CNT_NODES = CNT_NODES + 1 ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472), & NFRONT, KEEP(1)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) & ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL DMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 CALL DMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .TRUE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF LASTPANEL = .FALSE. DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = BEGS_BLR(CURRENT_BLR+1)-1 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 500 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (K263.EQ.0) THEN IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK ELSE IBEG_BLOCK_FOR_IPIV = IBEG_BLR ENDIF CALL DMUMPS_FAC_I(NFRONT,NASS,NASS, & IBEG_BLOCK_FOR_IPIV,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, & DKEEP(1), PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, & TIPIV=IPIV & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTPANEL = .TRUE. ELSE IF (INOPV .LE. 0) THEN INOPV = 0 IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL DMUMPS_FAC_MQ(IBEG_BLOCK, IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 NPVW = NPVW + 1 IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB .EQ. -1) THEN LASTPANEL = .TRUE. ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF (K263.EQ.0) THEN NELIM = IEND_BLR - NPIV CALL DMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, & NFRONT, IBEG_BLOCK, NPIV, IPIV,NASS,LASTPANEL,idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR, ICNTL,KEEP,KEEP8, & DKEEP,ND,FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, .FALSE. & , NPARTSASS, CURRENT_BLR & , BLR_DUMMY, LRGROUPS & ) END IF IF ( IFLAG .LT. 0 ) GOTO 500 IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_U, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN CALL MUMPS_BUF_TEST() IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL DMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, & NPIV, NFRONT, IEND_BLR, LAST_COL, & A, LA, POSELT, & -77777, & .TRUE., .FALSE., .TRUE., & .FALSE., & LR_ACTIVATED) ENDIF CALL MUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 500 ENDIF ALLOCATE(BLR_L(NPARTSASS-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSASS-CURRENT_BLR GOTO 500 ENDIF NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_U(J)%M=0 BLR_U(J)%N=0 BLR_U(J)%K=0 BLR_U(J)%ISLR=.FALSE. NULLIFY(BLR_U(J)%Q) NULLIFY(BLR_U(J)%R) ENDDO CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) DO J=1,NPARTSASS-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF GOTO 101 ENDIF END_I=NB_BLR #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), & KEEP(458), KEEP(473), BLR_U, & CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, 2, KEEP(483), KEEP8, & END_I_IN=END_I & ) IF (IFLAG.LT.0) GOTO 300 IF ((KEEP(480).NE.0.AND.NB_BLR.GT.CURRENT_BLR) & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (PIVOT_OPTION.LT.3) THEN IF (PIVOT_OPTION.LT.2) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF LAST_BLOCK=NB_BLR CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_U, CURRENT_BLR, & FIRST_BLOCK, LAST_BLOCK, 2, 0, 1, & .FALSE.) ENDIF 300 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif ENDIF 101 CONTINUE IF (LR_ACTIVATED .OR. (K263.NE.0.AND.PIVOT_OPTION.GE.3)) THEN NELIM = IEND_BLR - NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_U)) THEN BLR_SEND=>BLR_U ENDIF CALL DMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, NFRONT, & IBEG_BLR, NPIV, IPIV, NASS,LASTPANEL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR & , BLR_SEND, LRGROUPS & ) ENDIF IF (.NOT. LR_ACTIVATED) THEN LAST_COL = NFRONT IF (PIVOT_OPTION.EQ.2) THEN FIRST_COL = NASS ELSE FIRST_COL = NPIV ENDIF IF (IEND_BLR.LT.NASS .OR. PIVOT_OPTION.LT.3) THEN CALL DMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, LAST_COL, & A, LA, POSELT, FIRST_COL, .TRUE., (PIVOT_OPTION.LT.3), & .TRUE., (KEEP(377).EQ.1), & LR_ACTIVATED) ENDIF IF (K263.NE.0 .AND. PIVOT_OPTION.LT.3) THEN NELIM = IEND_BLR - NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_U)) THEN BLR_SEND=>BLR_U ENDIF CALL DMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, & NFRONT, IBEG_BLR, NPIV, IPIV, NASS,LASTPANEL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR & , BLR_SEND, LRGROUPS & ) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL DMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8 & ) IF (IFLAG.LT.0) GOTO 600 CALL DMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8, & END_I_IN=END_I & ) 600 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF ENDIF GOTO 100 ENDIF IF (KEEP(475).EQ.0) THEN IF (IEND_BLR.LT.NFRONT) THEN CALL DMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & -77777, & A, LA, POSELT, & -77777, & .TRUE., .FALSE., .FALSE., & .FALSE., & LR_ACTIVATED) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(UPOS,LPOS,FIRST_BLOCK,LAST_BLOCK) #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NPARTSASS, DKEEP(8), KEEP(466), & KEEP(458), KEEP(473), & BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8 & ) #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF ((KEEP(480).NE.0.AND.NB_BLR.GT.CURRENT_BLR) & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(475).GT.0) THEN CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NPARTSASS, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NPARTSASS, 2, 0, 0, .FALSE.) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF IF (KEEP(480).GE.2) THEN UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) LPOS = POSELT+int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) CALL DMUMPS_BLR_UPD_NELIM_VAR_L(A, LA, UPOS, A, LA, LPOS, & IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NPARTSASS, & CURRENT_BLR+1, NELIM, 'N') IF (IFLAG.LT.0) GOTO 444 IF (IEND_BLR.LT.NASS) THEN CALL DMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8 & ) IF (IFLAG.LT.0) GOTO 442 CALL DMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8, & END_I_IN=END_I & ) 442 CONTINUE ENDIF 444 CONTINUE ELSE CALL DMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, BLR_L, NPARTSASS, & BLR_U, NB_BLR, NELIM, .FALSE., 0, & 2, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(475).GT.0) THEN FIRST_BLOCK = CURRENT_BLR+1 IF (KEEP(486).EQ.2.AND.UU.EQ.0) THEN LAST_BLOCK = CURRENT_BLR ELSE LAST_BLOCK = NPARTSASS ENDIF CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NPARTSASS, BLR_L, CURRENT_BLR, 'V', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) #if ! defined(BLR_NOOPENMP) #endif ENDIF IF (KEEP(475).GE.2) THEN IF (KEEP(475).EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF IF (KEEP(486).NE.2) THEN LAST_BLOCK = END_I ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_U, CURRENT_BLR, 'H', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0.OR.NB_BLR.EQ.CURRENT_BLR) THEN CALL DEALLOC_BLR_PANEL(BLR_U, NB_BLR-CURRENT_BLR, & KEEP8, KEEP(34)) CALL DEALLOC_BLR_PANEL(BLR_L, NPARTSASS-CURRENT_BLR, & KEEP8, KEEP(34)) DEALLOCATE(BLR_U,BLR_L) ENDIF ENDIF NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_TRY_WRITE MonBloc%LastPiv = NPIV LAST_CALL= .FALSE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO IP=1,NB_BLR+1 BEGS_BLR_TMP(IP) = BEGS_BLR_STATIC(IP) ENDDO ENDIF ENDIF IF ( & (KEEP(486).EQ.2) & ) THEN MEM_TOT = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP& PRIVATE(IP, LorU, DIR, NELIM) #endif #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*(2*DIAGSIZ_STA-DIAGSIZ_DYN) MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA IF (I.LE.DIAGSIZ_DYN) THEN DIAG(DPOS:DPOS+DIAGSIZ_STA-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_STA-1,8)) DPOS = DPOS + DIAGSIZ_STA ELSE DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN ENDIF POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL DMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG, KEEP(34)) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO !$OMP SINGLE #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM_TOT,8), & .FALSE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 460 IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN DO IP=1,NPARTSASS NELIM = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) DO LorU=0,1 #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8, & KEEP(34)) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (LorU.EQ.0) THEN DIR = 'V' ELSE DIR = 'H' ENDIF CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(458), KEEP(473), & BLR_PANEL, IP, & DIR, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 440 ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif 440 CONTINUE ENDIF 460 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN deallocate(BEGS_BLR_TMP) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 500 IF ( & (KEEP(486).EQ.2) & ) THEN CALL DMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (IFLAG.GE.0) THEN CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 0, NELIM) DO IP=1,NPARTSASS CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NPARTSASS-IP & ) CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 1, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NB_BLR-IP & ) ENDDO CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NASS-NELIM, 0, 2) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 0, 2) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 500 IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF CALL DMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 700 480 CONTINUE 500 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 700 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL DMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 2, & KEEP8, KEEP(34)) ENDIF ENDIF IF ( LR_ACTIVATED .AND. KEEP(486).EQ. 2 .AND. & KEEP(251) .EQ. 2) THEN CALL DMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8, KEEP(34)) ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL DMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34)) ENDIF ENDIF DEALLOCATE( IPIV ) RETURN END SUBROUTINE DMUMPS_FAC2_LU END MODULE DMUMPS_FAC2_LU_M MUMPS_5.8.1/src/cana_reordertree.F0000664000175000017500000012227715042446440016656 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_REORDER_TREE(N,FRERE, STEP, FILS, & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, & NSTEPS,PERM,SYM,INFO,LP,K215,K234,K55,K199, & PROCNODE,SLAVEF, PEAK,SBTR_WHICH_M & ) IMPLICIT NONE INTEGER N,PERM,SYM, NSTEPS, LNA, LP,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER K215,K234,K55,K199 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) INTEGER :: SBTR_WHICH_M REAL PEAK REAL, DIMENSION(:), ALLOCATABLE :: COST_TRAV INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH INTEGER IFATH,IN,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 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 EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR DOUBLE PRECISION COST_NODE INCLUDE 'mumps_headers.h' TOTAL_MEM_SIZE=0_8 ROOT_OF_CUR_SBTR=0 IF((PERM.EQ.0).OR.(PERM.EQ.1).OR. & (PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4).OR. & (PERM.EQ.5).OR.(PERM.EQ.6))THEN LOCAL_PERM=0 ENDIF SBTR_M=.FALSE. MEM_SIZE=0_8 FACT_SIZE=0_8 IF ((PERM.LT.0 .OR. PERM.GT.7)) THEN WRITE(*,*) "Internal Error in CMUMPS_REORDER_TREE",PERM CALL MUMPS_ABORT() END IF NBLEAF = NA(1) NBROOT = NA(2) IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) RETURN IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ENDIF IF(PERM.NE.7)THEN ALLOCATE(M(NSTEPS),stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error &in CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ALLOCATE( IPOOL(NBLEAF), fact(NSTEPS),TNSTK(NSTEPS), & stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF II=0 DO I=1,NSTEPS TNSTK(I) = NE(I) IF(NE(I).GE.II) II=NE(I) ENDDO SIZE_TAB=max(II,NBROOT) ALLOCATE(SON(II), TEMP(II), & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), & RESULT(SIZE_TAB),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SIZE_TAB RETURN ENDIF IF(PERM.EQ.7) THEN GOTO 001 ENDIF IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN ALLOCATE(COST_TRAV(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error & in CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF COST_TRAV=0.0E0 COST_NODE=0.0d0 ENDIF IF(NBROOT.EQ.NBLEAF)THEN IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN WRITE(*,*)'Internal Error in reordertree:' WRITE(*,*)' problem with perm parameter in reordertree' CALL MUMPS_ABORT() ENDIF DO I=1,NBROOT TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) IPOOL(I)=NA(I+2+NBLEAF) M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) ENDDO CALL CMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) GOTO 789 ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN ALLOCATE(DEPTH(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DEPTH=0 NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) 499 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 4602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 4602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) SON(I)=IN IN=FRERE(STEP(IN)) ENDDO DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN LEAF=LEAF-1 ELSE fin=fin-1 GOTO 499 ENDIF fin=fin-1 IF(fin.EQ.0) GOTO 489 GOTO 499 489 CONTINUE ENDIF DO I=1,NSTEPS M(I)=0_8 IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN M_TOTAL(I)=0_8 ENDIF ENDIF ENDDO DO I=1,NSTEPS fact(I)=0_8 ENDDO IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 91 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 96 CONTINUE NFR = int(ND(STEP(INODE)),8) NELIM4 = 0 IN = INODE 101 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 101 NELIM=int(NELIM4,8) IF(NE(STEP(INODE)).EQ.0) THEN M(STEP(INODE))=NFR*NFR IF (SBTR_M.OR.(PERM.EQ.2)) THEN M_TOTAL(STEP(INODE))=NFR*NFR ENDIF ENDIF IF((PERM.EQ.4).OR.(PERM.EQ.3))THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN DEPTH(STEP(INODE))=0 ENDIF ENDIF IF ( SYM .eq. 0 ) THEN fact(STEP(INODE))=fact(STEP(INODE))+ & (2_8*NFR*NELIM)-(NELIM*NELIM) ELSE fact(STEP(INODE))=fact(STEP(INODE))+NFR*NELIM ENDIF IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 113 IN = FRERE(IN) IF (IN.GT.0) GO TO 113 IFATH = -IN ENDIF IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 116 GOTO 91 ELSE fact(STEP(IFATH))=fact(STEP(IFATH))+fact(STEP(INODE)) IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEPTH(STEP(IFATH))=max(DEPTH(STEP(INODE)), & DEPTH(STEP(IFATH))) ENDIF ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH IN=INODE dernier=IN I=1 5700 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN I=I+1 GOTO 5700 ENDIF NCB=int(ND(STEP(INODE))-I,8) IN=-IN IF(PERM.NE.7)THEN DO I=1,NE(STEP(INODE)) SON(I)=IN TEMP(I)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) ENDDO ELSE DO I=NE(STEP(INODE)),1,-1 SON(I)=IN TEMP(I)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) ENDDO ENDIF NFR = int(ND(STEP(INODE)),8) DO II=1,NE(STEP(INODE)) TAB1(II)=0_8 TAB2(II)=0_8 cour=SON(II) NELIM4=1 151 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 151 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0)) THEN SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) & *(int(ND(STEP(SON(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) & *(int(ND(STEP(SON(II))),8)- & NELIM+1_8)/2_8 ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.5))THEN IF (K234 .NE. 0 .AND. K55.EQ.0 ) THEN TMP8=NFR TMP8=TMP8*TMP8 TAB1(II)=max(TMP8, M(STEP(SON(II)))) - SIZECB TAB2(II)=SIZECB ELSE TAB1(II)=M(STEP(SON(II)))- SIZECB TAB2(II)=SIZECB ENDIF ENDIF IF((PERM.EQ.1).OR.(PERM.EQ.6)) THEN TAB1(II)=M(STEP(SON(II)))-SIZECB TAB1(II)=TAB1(II)-fact(STEP(SON(II))) TAB2(II)=SIZECB+fact(STEP(SON(II))) ENDIF IF(PERM.EQ.2)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M_TOTAL(STEP(SON(II)))-SIZECB & -fact(STEP(SON(II))) TAB2(II)=SIZECB ELSE TAB1(II)=M(STEP(SON(II)))-SIZECB TAB2(II)=SIZECB ENDIF ENDIF IF(PERM.EQ.3)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M(STEP(SON(II)))-SIZECB TAB2(II)=SIZECB ELSE TAB1(II)=int(DEPTH(STEP(SON(II))),8) TAB2(II)=M(STEP(SON(II))) ENDIF ENDIF IF(PERM.EQ.4)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M(STEP(SON(II)))- & SIZECB-fact(STEP(SON(II))) TAB2(II)=SIZECB ELSE TAB1(II)=int(DEPTH(STEP(SON(II))),8) TAB2(II)=M(STEP(SON(II))) ENDIF ENDIF ENDDO CALL CMUMPS_FUSION_SORT(SON,NE(STEP(INODE)),TAB1,TAB2, & LOCAL_PERM & ,RESULT,T1,T2) IF(PERM.EQ.0) THEN DO II=1,NE(STEP(INODE)) cour=TEMP(II) NELIM4=1 153 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 153 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 ENDIF TAB1(II)=SIZECB ENDDO CALL CMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, & RESULT,T1,T2) ENDIF IF(PERM.EQ.1) THEN DO II=1,NE(STEP(INODE)) cour=TEMP(II) NELIM4=1 187 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 187 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 ENDIF TAB1(II)=SIZECB+fact(STEP(TEMP(II))) ENDDO CALL CMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, & RESULT,T1,T2) ENDIF 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 TMP_SUM=0_8 IF(II.EQ.1) TAB=>SON IF(II.EQ.2) TAB=>TEMP DO I=1,NE(STEP(INODE)) cour=TAB(I) NELIM4=1 149 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 149 ENDIF NELIM=int(NELIM4, 8) NFR=int(ND(STEP(TAB(I))),8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF MEM_SIZE=max(MEM_SIZE,(M(STEP(TAB(I)))+SUM+FACT_SIZE)) IF (SBTR_M.OR.(PERM.EQ.2)) THEN MEM_SIZE_T=max(MEM_SIZE_T,(M_TOTAL(STEP(TAB(I)))+ & SUM+ & FACT_SIZE_T)) FACT_SIZE_T=FACT_SIZE_T+fact(STEP(TAB(I))) ENDIF TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & (M(STEP(TAB(I)))+SUM+FACT_SIZE)) TMP_SUM=TMP_SUM+fact(STEP(TAB(I))) SUM=SUM+SIZECB SIZECB_LASTSON = SIZECB IF((PERM.EQ.1).OR.(PERM.EQ.4))THEN FACT_SIZE=FACT_SIZE+fact(STEP(TAB(I))) ENDIF ENDDO IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=NCB*NCB ELSE SIZECB=(NCB*(NCB+1_8))/2_8 ENDIF IF (K234.NE.0 .AND. K55.EQ.0) THEN TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8) ) & + SUM-SIZECB_LASTSON+TMP_SUM ) & ) ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8) ) & + SUM + TMP_SUM ) & ) ELSE TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8)) & + max(SUM,SIZECB) + TMP_SUM ) & ) ENDIF IF(II.EQ.1)THEN TMP_TOTAL_MEM_SIZE=TOTAL_MEM_SIZE ENDIF IF(II.EQ.1)THEN IF (K234.NE.0 .AND. K55.EQ.0) THEN M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+SUM-SIZECB_LASTSON+ & FACT_SIZE)) ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+SUM+FACT_SIZE)) ELSE M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN M_TOTAL(STEP(IFATH))=max(MEM_SIZE_T, & ((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+ & FACT_SIZE_T)) ENDIF ENDIF IF((II.EQ.2).AND.(PERM.EQ.1).OR.(PERM.EQ.0).OR. & (PERM.EQ.5).OR.(PERM.EQ.6).OR. & (.NOT.SBTR_M.OR.(SBTR_WHICH_M.NE.1)))THEN MEM_SEC_PERM=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) ENDIF IF((PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4))THEN MEM_SEC_PERM=huge(MEM_SEC_PERM) ENDIF ENDDO IF(MEM_SEC_PERM.EQ.M(STEP(IFATH))) THEN TAB=>TEMP ELSE IF (MEM_SEC_PERM.LT.M(STEP(IFATH))) THEN WRITE(*,*)'Internal error 1 in CMUMPS_REORDER_TREE', & MEM_SEC_PERM, M(STEP(IFATH)) CALL MUMPS_ABORT() ELSE TOTAL_MEM_SIZE=TMP_TOTAL_MEM_SIZE TAB=>SON ENDIF DO I=NE(STEP(INODE)),1,-1 IF(I.EQ.NE(STEP(INODE))) THEN FILS(dernier)=-TAB(I) dernier=TAB(I) GOTO 222 ENDIF IF(I.EQ.1) THEN FRERE(STEP(dernier))=TAB(I) FRERE(STEP(TAB(I)))=-INODE GOTO 222 ENDIF IF(I.GT.1) THEN FRERE(STEP(dernier))=TAB(I) dernier=TAB(I) GOTO 222 ENDIF 222 CONTINUE ENDDO GOTO 96 ELSE GOTO 91 ENDIF 116 CONTINUE NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) IF (PERM.eq.1) THEN DO I=1,NBROOT TAB1(I)=M(STEP(NA(I+2+NBLEAF)))-fact(STEP(NA(I+2+NBLEAF))) TAB1(I)=-TAB1(I) ENDDO CALL CMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) ENDIF 001 CONTINUE fin=NBROOT LEAF=NA(1) 999 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 5602 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN GOTO 5602 ENDIF IN=-IN IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF(SLAVEF.NE.1)THEN IF (USE_DAD) THEN IFATH=DAD(INODE) ELSE IN = INODE 395 IN = FRERE(IN) IF (IN.GT.0) GO TO 395 IFATH = -IN ENDIF NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 IN = INODE 396 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 396 NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),K199))THEN COST_TRAV(STEP(INODE))=COST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE COST_TRAV(STEP(INODE))=real(COST_NODE)+ & COST_TRAV(STEP(IFATH))+ & real(SIZECB*18_8) ENDIF ELSE COST_TRAV(STEP(INODE))=real(COST_NODE) ENDIF ENDIF ENDIF DO I=1,NE(STEP(INODE)) TEMP(I)=IN IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)),K199)))THEN NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 II = TEMP(I) 845 NELIM4 = NELIM4 + 1 II = FILS(II) IF (II .GT. 0 ) GOTO 845 NELIM=int(NELIM4,8) CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) TAB1(I)=int(real(COST_NODE)+ & COST_TRAV(STEP(INODE)),8) TAB2(I)=0_8 ELSE SON(I)=IN ENDIF ELSE SON(I)=IN ENDIF IN=FRERE(STEP(IN)) ENDDO IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)),K199)))THEN CALL CMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2, & LOCAL_PERM & ,RESULT,T1,T2) TAB=>TEMP DO I=NE(STEP(INODE)),1,-1 IF(I.EQ.NE(STEP(INODE))) THEN FILS(dernier)=-TAB(I) dernier=TAB(I) GOTO 221 ENDIF IF(I.EQ.1) THEN FRERE(STEP(dernier))=TAB(I) FRERE(STEP(TAB(I)))=-INODE GOTO 221 ENDIF IF(I.GT.1) THEN FRERE(STEP(dernier))=TAB(I) dernier=TAB(I) GOTO 221 ENDIF 221 CONTINUE SON(NE(STEP(INODE))-I+1)=TAB(I) ENDDO ENDIF ENDIF DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN IF(PERM.NE.7)THEN NA(LEAF+2)=INODE ENDIF LEAF=LEAF-1 ELSE fin=fin-1 GOTO 999 ENDIF fin=fin-1 IF(fin.EQ.0) THEN GOTO 789 ENDIF GOTO 999 789 CONTINUE IF(PERM.EQ.7) GOTO 5483 NBROOT=NA(2) NBLEAF=NA(1) PEAK=0.0E0 FACT_SIZE=0_8 DO I=1,NBROOT PEAK=max(PEAK,real(M(STEP(NA(2+NBLEAF+I))))) FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) ENDDO 5483 CONTINUE DEALLOCATE(IPOOL) DEALLOCATE(fact) DEALLOCATE(TNSTK) DEALLOCATE(SON) DEALLOCATE(TAB2) DEALLOCATE(TAB1) DEALLOCATE(T1) DEALLOCATE(T2) DEALLOCATE(RESULT) DEALLOCATE(TEMP) IF(PERM.NE.7)THEN DEALLOCATE(M) ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEALLOCATE(DEPTH) ENDIF IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN DEALLOCATE(COST_TRAV) ENDIF IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN DEALLOCATE(M_TOTAL) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_REORDER_TREE SUBROUTINE CMUMPS_BUILD_LOAD_MEM_INFO(N,FRERE, STEP, FILS, & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, & NSTEPS,PERM,SYM,INFO,LP,K47,K81,K76,K215,K234,K55,KEEP199, & PROCNODE,MEM_SUBTREE,SLAVEF, SIZE_MEM_SBTR, PEAK & ,SBTR_WHICH_M,SIZE_DEPTH_FIRST,SIZE_COST_TRAV, & DEPTH_FIRST_TRAV,DEPTH_FIRST_SEQ,COST_TRAV,MY_FIRST_LEAF, & MY_NB_LEAF,MY_ROOT_SBTR,SBTR_ID & ) IMPLICIT NONE INTEGER N,PERM,SYM, NSTEPS, LNA, LP, SIZE_MEM_SBTR,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER K47,K81,K76,K215,K234,K55,KEEP199 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) DOUBLE PRECISION, intent(out) :: MEM_SUBTREE(SIZE_MEM_SBTR,SLAVEF) INTEGER :: SBTR_WHICH_M INTEGER MY_FIRST_LEAF(SIZE_MEM_SBTR,SLAVEF), & MY_ROOT_SBTR(SIZE_MEM_SBTR,SLAVEF), & MY_NB_LEAF(SIZE_MEM_SBTR,SLAVEF) EXTERNAL MUMPS_ROOTSSARBR,MUMPS_PROCNODE LOGICAL MUMPS_ROOTSSARBR INTEGER MUMPS_PROCNODE REAL PEAK INTEGER SIZE_DEPTH_FIRST,DEPTH_FIRST_TRAV(SIZE_DEPTH_FIRST), & DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST) INTEGER SIZE_COST_TRAV INTEGER SBTR_ID(SIZE_DEPTH_FIRST),OOC_CUR_SBTR REAL COST_TRAV(SIZE_COST_TRAV) INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH INTEGER IFATH,IN,INODE,I,allocok 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,fin,RANK_TRAV INTEGER II INTEGER ROOT_OF_CUR_SBTR INTEGER(8), DIMENSION (:), ALLOCATABLE :: T1,T2 INTEGER, DIMENSION (:), ALLOCATABLE :: RESULT INTEGER(8) FACT_SIZE, & SIZECB LOGICAL SBTR_M INTEGER,DIMENSION(:),ALLOCATABLE :: INDICE INTEGER ID,FIRST_LEAF,SIZE_SBTR EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR DOUBLE PRECISION COST_NODE INTEGER CUR_DEPTH_FIRST_RANK INCLUDE 'mumps_headers.h' ROOT_OF_CUR_SBTR=0 ALLOCATE(INDICE( SLAVEF ), stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in &CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SLAVEF RETURN ENDIF IF (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)))) FACT_SIZE=0_8 IF ((PERM.GT.7).AND. & (.NOT.(K47 == 4 .OR. ((K47.GE.2).AND.(K81 .GE. 1))))) THEN WRITE(*,*) "Internal Error in CMUMPS_REORDER_TREE",PERM CALL MUMPS_ABORT() END IF NBLEAF = NA(1) NBROOT = NA(2) CUR_DEPTH_FIRST_RANK=1 IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) THEN DEALLOCATE(INDICE) RETURN ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ENDIF ALLOCATE( IPOOL(NBLEAF), M(NSTEPS), fact(NSTEPS), & TNSTK(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF II=0 DO I=1,NSTEPS TNSTK(I) = NE(I) IF(NE(I).GE.II) II=NE(I) ENDDO SIZE_TAB=max(II,NBROOT) ALLOCATE(SON(II), TEMP(II), & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), & RESULT(SIZE_TAB),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SIZE_TAB RETURN ENDIF IF(NBROOT.EQ.NBLEAF)THEN IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN WRITE(*,*)'Internal Error in reordertree:' WRITE(*,*)' problem with perm parameter in reordertree' CALL MUMPS_ABORT() ENDIF DO I=1,NBROOT TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) IPOOL(I)=NA(I+2+NBLEAF) M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) ENDDO CALL CMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) GOTO 789 ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN ALLOCATE(DEPTH(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DEPTH=0 NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) 499 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 4602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 4602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) SON(I)=IN IN=FRERE(STEP(IN)) ENDDO DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN LEAF=LEAF-1 ELSE fin=fin-1 GOTO 499 ENDIF fin=fin-1 IF(fin.EQ.0) GOTO 489 GOTO 499 489 CONTINUE ENDIF IF(K76.EQ.4.OR.(K76.EQ.6))THEN RANK_TRAV=NSTEPS DEPTH_FIRST_TRAV=0 DEPTH_FIRST_SEQ=0 ENDIF IF((K76.EQ.5).OR.(PERM.EQ.5).OR.(PERM.EQ.6))THEN COST_TRAV=0.0E0 COST_NODE=0.0d0 ENDIF DO I=1,NSTEPS M(I)=0_8 IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN M_TOTAL(I)=0_8 ENDIF ENDIF ENDDO DO I=1,NSTEPS fact(I)=0_8 ENDDO NBROOT = NA(2) NBLEAF = NA(1) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) FIRST_LEAF=-9999 SIZE_SBTR=0 999 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IF(SIZE_SBTR.NE.0)THEN IF(.NOT.MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1))THEN MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR FIRST_LEAF=-9999 SIZE_SBTR=0 ENDIF ENDIF ENDIF ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN ROOT_OF_CUR_SBTR=INODE ENDIF IF (K76.EQ.4)THEN IF(SLAVEF.NE.1)THEN WRITE(*,*)'INODE=',INODE,'RANK',RANK_TRAV IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN DEPTH_FIRST_TRAV(STEP(INODE))=DEPTH_FIRST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE DEPTH_FIRST_TRAV(STEP(INODE))=RANK_TRAV ENDIF RANK_TRAV=RANK_TRAV-1 ENDIF ENDIF IF (K76.EQ.5)THEN IF(SLAVEF.NE.1)THEN IF (USE_DAD) THEN IFATH=DAD(INODE) ELSE IN = INODE 395 IN = FRERE(IN) IF (IN.GT.0) GO TO 395 IFATH = -IN ENDIF NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 IN = INODE 396 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 396 NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN COST_TRAV(STEP(INODE))=COST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE COST_TRAV(STEP(INODE))=real(COST_NODE)+ & COST_TRAV(STEP(IFATH))+ & real(SIZECB*18_8) ENDIF ELSE COST_TRAV(STEP(INODE))=real(COST_NODE) ENDIF IF(K76.EQ.5)THEN WRITE(*,*)'INODE=',INODE,'COST=',COST_TRAV(STEP(INODE)) ENDIF ENDIF ENDIF IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1).AND. & MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF (NE(STEP(INODE)).NE.0) THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M_TOTAL(STEP(INODE))) ELSE MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M(STEP(INODE))) ENDIF MY_ROOT_SBTR(INDICE(ID+1),ID+1)=INODE INDICE(ID+1)=INDICE(ID+1)+1 ENDIF ENDIF IF((SLAVEF.EQ.1).AND.FRERE(STEP(INODE)).EQ.0)THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M_TOTAL(STEP(INODE))) ELSE MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M(STEP(INODE))) ENDIF INDICE(ID+1)=INDICE(ID+1)+1 ENDIF ENDIF IN=INODE 5602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 5602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) IPOOL(fin)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF(SLAVEF.NE.1)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF(FIRST_LEAF.EQ.-9999)THEN FIRST_LEAF=INODE ENDIF SIZE_SBTR=SIZE_SBTR+1 ENDIF ENDIF ENDIF IF(PERM.NE.7)THEN NA(LEAF+2)=INODE ENDIF LEAF=LEAF-1 ELSE fin=fin-1 GOTO 999 ENDIF fin=fin-1 IF(fin.EQ.0) THEN IF(SIZE_SBTR.NE.0)THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1))THEN MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR FIRST_LEAF=-9999 SIZE_SBTR=0 ENDIF ENDIF ENDIF GOTO 789 ENDIF GOTO 999 789 CONTINUE IF(K76.EQ.6)THEN OOC_CUR_SBTR=1 DO I=1,NSTEPS TNSTK(I) = NE(I) ENDDO NBROOT=NA(2) NBLEAF=NA(1) IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 9100 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 9600 CONTINUE IF(SLAVEF.NE.1)THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) DEPTH_FIRST_TRAV(STEP(INODE))=CUR_DEPTH_FIRST_RANK DEPTH_FIRST_SEQ(CUR_DEPTH_FIRST_RANK)=INODE CUR_DEPTH_FIRST_RANK=CUR_DEPTH_FIRST_RANK+1 IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP199))THEN SBTR_ID(STEP(INODE))=OOC_CUR_SBTR ELSE SBTR_ID(STEP(INODE))=-9999 ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)), & KEEP199))THEN OOC_CUR_SBTR=OOC_CUR_SBTR+1 ENDIF ENDIF IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 1133 IN = FRERE(IN) IF (IN.GT.0) GO TO 1133 IFATH = -IN ENDIF IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 1163 GOTO 9100 ENDIF TNSTK(STEP(IFATH))=TNSTK(STEP(IFATH))-1 IF(TNSTK(STEP(IFATH)).EQ.0) THEN INODE=IFATH GOTO 9600 ELSE GOTO 9100 ENDIF 1163 CONTINUE ENDIF PEAK=0.0E0 FACT_SIZE=0_8 DO I=1,NBROOT PEAK=max(PEAK,real(M(STEP(NA(2+NBLEAF+I))))) FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) ENDDO DEALLOCATE(IPOOL) DEALLOCATE(M) DEALLOCATE(fact) DEALLOCATE(TNSTK) DEALLOCATE(SON) DEALLOCATE(TAB2) DEALLOCATE(TAB1) DEALLOCATE(T1) DEALLOCATE(T2) DEALLOCATE(RESULT) DEALLOCATE(TEMP) DEALLOCATE(INDICE) IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEALLOCATE(DEPTH) ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN DEALLOCATE(M_TOTAL) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_BUILD_LOAD_MEM_INFO RECURSIVE SUBROUTINE CMUMPS_FUSION_SORT(TAB,DIM,TAB1,TAB2,PERM, & RESULT,TEMP1,TEMP2) IMPLICIT NONE INTEGER DIM INTEGER(8) TAB1(DIM),TAB2(DIM) INTEGER(8) TEMP1(DIM),TEMP2(DIM) INTEGER TAB(DIM), PERM,RESULT(DIM) INTEGER I,J,I1,I2 IF(DIM.EQ.1) THEN RESULT(1)=TAB(1) TEMP1(1)=TAB1(1) TEMP2(1)=TAB2(1) RETURN ENDIF I=DIM/2 CALL CMUMPS_FUSION_SORT(TAB(1),I,TAB1(1),TAB2(1),PERM, & RESULT(1),TEMP1(1),TEMP2(1)) CALL CMUMPS_FUSION_SORT(TAB(I+1),DIM-I,TAB1(I+1),TAB2(I+1), & PERM,RESULT(I+1),TEMP1(I+1),TEMP2(I+1)) I1=1 I2=I+1 J=1 DO WHILE ((I1.LE.I).AND.(I2.LE.DIM)) IF((PERM.EQ.3))THEN IF(TEMP1(I1).LE.TEMP1(I2))THEN TAB(J)=RESULT(I1) TAB1(J)=TEMP1(I1) J=J+1 I1=I1+1 ELSE TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) J=J+1 I2=I2+1 ENDIF GOTO 3 ENDIF IF((PERM.EQ.4).OR.(PERM.EQ.5))THEN IF (TEMP1(I1).GE.TEMP1(I2))THEN TAB(J)=RESULT(I1) TAB1(J)=TEMP1(I1) J=J+1 I1=I1+1 ELSE TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) J=J+1 I2=I2+1 ENDIF GOTO 3 ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.1).OR.(PERM.EQ.2)) THEN IF(TEMP1(I1).GT.TEMP1(I2))THEN TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 GOTO 3 ENDIF IF(TEMP1(I1).LT.TEMP1(I2))THEN TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) TAB(J)=RESULT(I2) J=J+1 I2=I2+1 GOTO 3 ENDIF IF((TEMP1(I1).EQ.TEMP1(I2)))THEN IF(TEMP2(I1).LE.TEMP2(I2))THEN TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 ELSE TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) TAB(J)=RESULT(I2) J=J+1 I2=I2+1 ENDIF ENDIF ENDIF 3 CONTINUE ENDDO IF(I1.GT.I)THEN DO WHILE(I2.LE.DIM) TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) J=J+1 I2=I2+1 ENDDO ELSE IF(I2.GT.DIM)THEN DO WHILE(I1.LE.I) TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 ENDDO ENDIF ENDIF DO I=1,DIM TEMP1(I)=TAB1(I) TEMP2(I)=TAB2(I) RESULT(I)=TAB(I) ENDDO RETURN END SUBROUTINE CMUMPS_FUSION_SORT MUMPS_5.8.1/src/cmumps_save_restore.F0000664000175000017500000127244315042446441017442 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if ! defined(NO_SAVE_RESTORE) MODULE CMUMPS_SAVE_RESTORE USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_INTR_STRUC USE CMUMPS_SAVE_RESTORE_FILES USE MUMPS_FRONT_DATA_MGT_M IMPLICIT NONE INCLUDE 'mumps_save_restore_modes.h' CONTAINS SUBROUTINE CMUMPS_REMOVE_SAVED(id) USE CMUMPS_OOC IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MASTER PARAMETER ( MASTER = 0 ) TYPE (CMUMPS_STRUC) :: id CHARACTER(len=LEN_SAVE_FILE) :: RESTOREFILE, INFOFILE INTEGER :: fileunit, ierr, SIZE_INT, SIZE_INT8 INTEGER(8) :: size_read, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE INTEGER :: READ_OOC_FILE_NAME_LENGTH,READ_SYM,READ_PAR,READ_NPROCS CHARACTER(len=LEN_SAVE_FILE) :: READ_OOC_FIRST_FILE_NAME CHARACTER :: READ_ARITH LOGICAL :: READ_INT_TYPE_64 CHARACTER(len=23) :: READ_HASH LOGICAL :: FORTRAN_VERSION_OK LOGICAL :: SAME_OOC INTEGER :: ICNTL34, MAX_LENGTH, FLAG_SAME, SUM_FLAG_SAME TYPE (CMUMPS_STRUC) :: localid ierr = 0 call CMUMPS_GET_SAVE_FILES(id,RESTOREFILE,INFOFILE) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(fileunit) IF ( fileunit .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=fileunit,FILE=RESTOREFILE #if ! defined(MUMPS_NOF2003) & ,ACCESS="stream" #endif & ,STATUS='old',FORM='unformatted',IOSTAT=ierr) IF ( ierr.ne.0 ) THEN id%INFO(1) = -76 id%INFO(2) = id%MYID endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_INT = id%KEEP(34) SIZE_INT8 = id%KEEP(34)*id%KEEP(10) size_read = 0_8 call MUMPS_READ_HEADER(fileunit,ierr,size_read,SIZE_INT, & SIZE_INT8, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE, & READ_ARITH, READ_INT_TYPE_64, & READ_OOC_FILE_NAME_LENGTH, READ_OOC_FIRST_FILE_NAME, & READ_HASH,READ_SYM,READ_PAR,READ_NPROCS, & FORTRAN_VERSION_OK) close(fileunit) if (ierr.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) elseif (.NOT.FORTRAN_VERSION_OK) THEN id%INFO(1) = -73 id%INFO(2) = 1 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL CMUMPS_CHECK_HEADER(id,.TRUE.,READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) IF ( id%INFO(1) .LT. 0 ) RETURN ICNTL34 = -99998 IF (id%MYID.EQ.MASTER) THEN ICNTL34 = id%ICNTL(34) ENDIF CALL MPI_BCAST( ICNTL34, 1, MPI_INTEGER, MASTER, id%COMM, ierr ) CALL MPI_BCAST( READ_SYM, 1, MPI_INTEGER, MASTER, id%COMM, ierr ) CALL CMUMPS_CHECK_FILE_NAME(id, READ_OOC_FILE_NAME_LENGTH, & READ_OOC_FIRST_FILE_NAME, SAME_OOC) CALL MPI_ALLREDUCE(READ_OOC_FILE_NAME_LENGTH,MAX_LENGTH,1, & MPI_INTEGER,MPI_MAX,id%COMM,ierr) IF (MAX_LENGTH.NE.-999) THEN FLAG_SAME = 0 IF (SAME_OOC) THEN FLAG_SAME = 1 ENDIF CALL MPI_ALLREDUCE(FLAG_SAME,SUM_FLAG_SAME,1, & MPI_INTEGER,MPI_SUM,id%COMM,ierr) IF (SUM_FLAG_SAME.NE.0) THEN IF (ICNTL34 .EQ. 1) THEN id%ASSOCIATED_OOC_FILES = .TRUE. ELSE id%ASSOCIATED_OOC_FILES = .FALSE. ENDIF ELSE IF (ICNTL34 .NE. 1) THEN localid%COMM = id%COMM localid%INFO(1) = 0 localid%ICNTL(1) = id%ICNTL(1) localid%MYID = id%MYID localid%NPROCS = id%NPROCS localid%KEEP(10) = id%KEEP(10) localid%SAVE_PREFIX = id%SAVE_PREFIX localid%SAVE_DIR = id%SAVE_DIR call CMUMPS_RESTORE_OOC(localid) IF ( localid%INFO(1) .EQ. 0 ) THEN localid%ASSOCIATED_OOC_FILES = .FALSE. IF (READ_OOC_FILE_NAME_LENGTH.NE.-999) THEN call CMUMPS_OOC_CLEAN_FILES(localid,ierr) IF ( ierr.ne.0 ) THEN id%INFO(1) = -90 id%INFO(2) = id%MYID ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN ENDIF ENDIF ENDIF call MUMPS_CLEAN_SAVED_DATA(id%MYID,ierr,RESTOREFILE,INFOFILE) IF (ierr.eq.-79) THEN id%INFO(1) = -79 id%INFO(2) = 2 ELSE IF (ierr.ne.0) THEN id%INFO(1) = -76 id%INFO(2) = id%MYID ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) RETURN END SUBROUTINE CMUMPS_REMOVE_SAVED SUBROUTINE CMUMPS_RESTORE_OOC(localid) IMPLICIT NONE INCLUDE 'mpif.h' TYPE (CMUMPS_STRUC) :: localid INTEGER::ierr,IN,NBVARIABLES,NBVARIABLES_ROOTC CHARACTER(len=LEN_SAVE_FILE):: restore_file_ooc,INFO_FILE INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOTC INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOTC INTEGER:: INFO1,INFO2,INFOG1,INFOG2,allocok INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE TYPE (CMUMPS_INTR_STRUC) :: localidintr NBVARIABLES=194 NBVARIABLES_ROOTC=20 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOTC(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOTC(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL CMUMPS_GET_SAVE_FILES(localid,restore_file_ooc,INFO_FILE) IF ( localid%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(IN) IF ( IN .EQ. -1 ) THEN localid%INFO(1) = -79 localid%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN open(UNIT=IN,FILE=restore_file_ooc #if ! defined(MUMPS_NOF2003) & ,ACCESS="stream" #endif & ,STATUS='old',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN localid%INFO(1) = -74 localid%INFO(2) = localid%MYID endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN CALL CMUMPS_SAVE_RESTORE_STRUCTURE(localid,localidintr,IN & ,restore_ooc_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) CLOSE(IN) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOTC) deallocate(SIZE_GEST,SIZE_GEST_ROOTC) RETURN END SUBROUTINE CMUMPS_RESTORE_OOC SUBROUTINE CMUMPS_COMPUTE_MEMORY_SAVE(id,idintr, & TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE) IMPLICIT NONE INCLUDE 'mpif.h' TYPE (CMUMPS_STRUC) :: id TYPE (CMUMPS_INTR_STRUC) :: idintr INTEGER::NBVARIABLES,NBVARIABLES_ROOTC INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOTC INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOTC INTEGER :: INFO1,INFO2,INFOG1,INFOG2,allocok INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE NBVARIABLES=194 NBVARIABLES_ROOTC=20 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOTC(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOTC(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL CMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,0,memory_save_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOTC) deallocate(SIZE_GEST,SIZE_GEST_ROOTC) RETURN END SUBROUTINE CMUMPS_COMPUTE_MEMORY_SAVE SUBROUTINE CMUMPS_SAVE(id,idintr) IMPLICIT NONE INCLUDE 'mpif.h' TYPE (CMUMPS_STRUC) :: id TYPE (CMUMPS_INTR_STRUC) :: idintr INTEGER::ierr,OUT,NBVARIABLES,NBVARIABLES_ROOTC,OUTINFO CHARACTER(len=LEN_SAVE_FILE):: SAVE_FILE,INFO_FILE LOGICAL:: SAVE_FILE_exist,INFO_FILE_exist INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOTC INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOTC INTEGER:: INFO1,INFO2,INFOG1,INFOG2,MPG INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: PROKG INTEGER :: I,J,K,H,allocok CHARACTER(len=1) :: TMP_OOC_NAMES(350) INFO1 = id%INFO(1) INFO2 = id%INFO(2) INFOG1 = id%INFO(1) INFOG2 = id%INFO(1) id%INFO(1)=0 id%INFO(2)=0 id%INFOG(1)=0 id%INFOG(2)=0 MPG= id%ICNTL(3) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. 0 ) NBVARIABLES=194 NBVARIABLES_ROOTC=20 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOTC(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOTC(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 TMP_OOC_NAMES(:)="?" CALL CMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,0,memory_save_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) CALL CMUMPS_GET_SAVE_FILES(id,SAVE_FILE,INFO_FILE) IF ( id%INFO(1) .LT. 0 ) RETURN inquire(FILE=SAVE_FILE, EXIST=SAVE_FILE_exist) IF(SAVE_FILE_exist) THEN id%INFO(1) = -70 id%INFO(2) = 0 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(OUT) IF ( OUT .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=OUT,FILE=SAVE_FILE #if ! defined(MUMPS_NOF2003) & ,ACCESS="stream" #endif & ,STATUS='new',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -71 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN inquire(FILE=INFO_FILE, EXIST=INFO_FILE_exist) IF(INFO_FILE_exist) THEN id%INFO(1) = -70 id%INFO(2) = 0 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(OUTINFO) IF ( OUTINFO .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=OUTINFO,FILE=INFO_FILE,STATUS='new',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -71 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL CMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,OUT,save_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) if (id%INFO(1).EQ.0) then id%INFO(1)=INFO1 id%INFO(2)=INFO2 id%INFOG(1)=INFOG1 id%INFOG(2)=INFOG2 CLOSE(OUT) if(id%INFOG(1).NE.0) then if (PROKG) THEN write(MPG,*) "Warning: " & ,"saved instance has negative INFO(1):" & , id%INFOG(1) endif endif IF(PROKG) THEN write(MPG,*) "Save done successfully" IF(id%KEEP(201).EQ.1) THEN K=1 write(MPG,*) "The corresponding OOC files are:" DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(MPG,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF ENDIF write(OUTINFO,*) "Save done by CMUMPS ", & trim(adjustl(id%VERSION_NUMBER)), & " after JOB=",id%KEEP(40)+456789, & " With SYM, PAR =",id%KEEP(50),id%KEEP(46) write(OUTINFO,*) "On ",id%NPROCS," processes" if((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ.0)) then write(OUTINFO,*) "with N, NNZ ", id%N, id%NNZ elseif((id%ICNTL(18).EQ.1).AND.(id%ICNTL(5).EQ. 0)) then write(OUTINFO,*) "with N, NNZ_loc=", id%N, id%NNZ_loc elseif((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ. 1)) then write(OUTINFO,*) "with N, NELT=", id%N, id%NELT endif IF(id%KEEP(10).EQ.1) THEN write(OUTINFO,*) "With a default integer size of 64 bits" ELSE write(OUTINFO,*) "With a default integer size of 32 bits" ENDIF #if defined(MUMPS_NOF2003) write(OUTINFO,*) "Using MUMPS_NOF2003" #endif write(OUTINFO,*) '' write(OUTINFO,*) "The corresponding save file is:" write(OUTINFO,*) trim(adjustl(SAVE_FILE)) write(OUTINFO,*) "of size",TOTAL_FILE_SIZE, " Bytes" IF(id%KEEP(201).EQ.1) THEN write(OUTINFO,*) '' write(OUTINFO,*) "The corresponding OOC files are:" K=1 DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(OUTINFO,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF CLOSE(OUTINFO) else CLOSE(OUT,STATUS='delete') CLOSE(OUTINFO,STATUS='delete') endif deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOTC) deallocate(SIZE_GEST,SIZE_GEST_ROOTC) if (id%KEEP(201) .GT. 0) THEN id%ASSOCIATED_OOC_FILES=.TRUE. ENDIF RETURN END SUBROUTINE CMUMPS_SAVE SUBROUTINE CMUMPS_RESTORE(id,idintr) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER::ierr,IN,NBVARIABLES,NBVARIABLES_ROOTC CHARACTER(len=LEN_SAVE_FILE):: restore_file,INFO_FILE INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOTC INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOTC INTEGER:: INFO1,INFO2,INFOG1,INFOG2,MPG,MP,JOB INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: PROKG INTEGER :: I,J,K,H,allocok CHARACTER(len=1) :: TMP_OOC_NAMES(350) TYPE (CMUMPS_STRUC) :: id TYPE (CMUMPS_INTR_STRUC) :: idintr NBVARIABLES=194 NBVARIABLES_ROOTC=20 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOTC(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOTC(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 TMP_OOC_NAMES(:)="?" INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL CMUMPS_GET_SAVE_FILES(id,restore_file,INFO_FILE) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(IN) IF ( IN .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=IN,FILE=restore_file #if ! defined(MUMPS_NOF2003) & ,ACCESS="stream" #endif & ,STATUS='old',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -74 id%INFO(2) = id%MYID endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN MP= id%ICNTL(2) MPG= id%ICNTL(3) CALL CMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,IN,restore_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. 0 ) if(id%INFO(1).EQ.0) then id%INFO(1)=INFO1 id%INFO(2)=INFO2 id%INFOG(1)=INFOG1 id%INFOG(2)=INFOG2 if(id%INFOG(1).NE.0) then write(MPG,*) "Warning: " & ,"restored instance has negative INFOG(1):" & , id%INFOG(1) endif if(MP.GT.0) then JOB=id%KEEP(40)+456789 write(MP,*) "Restore done successfully" write(MP,*) "From file ",trim(adjustl(restore_file)) if((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ.0)) then write(MP,*) "with JOB, N, NNZ ",JOB, id%N,id%NNZ elseif((id%ICNTL(18).EQ.1).AND.(id%ICNTL(5).EQ. 0)) then write(MP,*) "with JOB, N, NNZ_loc=", JOB, id%N, & id%NNZ_loc elseif((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ. 1)) then write(MP,*) "with JOB, N, NELT=", JOB, id%N, id%NELT endif endif IF(PROKG) THEN IF(id%KEEP(201).EQ.1) THEN K=1 write(MPG,*) "The corresponding OOC files are:" DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(MPG,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF ENDIF else idintr%root%gridinit_done=.FALSE. id%KEEP(140)=1 endif CLOSE(IN) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOTC) deallocate(SIZE_GEST,SIZE_GEST_ROOTC) if (id%KEEP(201) .GT. 0) THEN id%ASSOCIATED_OOC_FILES=.TRUE. ENDIF RETURN END SUBROUTINE CMUMPS_RESTORE SUBROUTINE CMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,unit,mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) USE CMUMPS_FACSOL_L0OMP_M, ONLY : CMUMPS_SAVE_RESTORE_L0FACARRAY USE CMUMPS_LR_DATA_M, ONLY: CMUMPS_SAVE_RESTORE_BLR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER, intent(in) ::unit,NBVARIABLES,NBVARIABLES_ROOTC INTEGER, intent(in) :: mode INTEGER(8),dimension(NBVARIABLES)::SIZE_VARIABLES INTEGER(8),dimension(NBVARIABLES_ROOTC)::SIZE_VARIABLES_ROOTC INTEGER,dimension(NBVARIABLES)::SIZE_GEST INTEGER,dimension(NBVARIABLES_ROOTC)::SIZE_GEST_ROOTC INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER:: INFO1,INFO2,INFOG1,INFOG2 INTEGER:: j,i1,i2,err,ierr CHARACTER :: ARITH,READ_ARITH INTEGER(8) :: size_written,gest_size,WRITTEN_STRUC_SIZE INTEGER:: SIZE_INT, SIZE_INT8, SIZE_RL_OR_DBL, SIZE_ARITH_DEP INTEGER:: SIZE_DOUBLE_PRECISION, SIZE_LOGICAL, SIZE_CHARACTER INTEGER:: READ_NPROCS, READ_PAR, READ_SYM INTEGER,dimension(NBVARIABLES)::NbRecords INTEGER,dimension(NBVARIABLES_ROOTC)::NbRecords_ROOTC INTEGER:: size_array1,size_array2,dummy,allocok INTEGER(8):: size_array_INT8_1,size_array_INT8_2 LOGICAL:: INT_TYPE_64, READ_INT_TYPE_64, CALL_SAVE_RESTORE_BLR INTEGER:: tot_NbRecords,NbSubRecords INTEGER(8):: size_read,size_allocated INTEGER(8),dimension(NBVARIABLES)::DIFF_SIZE_ALLOC_READ INTEGER(8),dimension(NBVARIABLES_ROOTC):: & DIFF_SIZE_ALLOC_READ_ROOTC INTEGER::READ_OOC_FILE_NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE):: READ_OOC_FIRST_FILE_NAME INTEGER,dimension(4)::OOC_INDICES CHARACTER(len=8) :: date CHARACTER(len=10) :: time CHARACTER(len=5) :: zone INTEGER,dimension(8):: values CHARACTER(len=23) :: hash,READ_HASH LOGICAL:: BASIC_CHECK LOGICAL :: FORTRAN_VERSION_OK CHARACTER(len=1) :: TMP_OOC_NAMES(350) INTEGER(8)::SIZE_VARIABLES_BLR,SIZE_VARIABLES_FRONT_DATA, & SIZE_VARIABLES_L0FAC INTEGER :: SIZE_GEST_ROOTA INTEGER(8) :: SIZE_VARIABLES_ROOTA INTEGER::SIZE_GEST_BLR,SIZE_GEST_FRONT_DATA,SIZE_GEST_L0FAC INTEGER :: KEEP410_SAVE, KEEP411_SAVE INTEGER(8) :: KEEP883_SAVE, KEEP884_SAVE INTEGER(4) :: I4 LOGICAL :: IS_SYMMETRIC TYPE (CMUMPS_STRUC) :: id TYPE (CMUMPS_INTR_STRUC) :: idintr INTEGER, PARAMETER :: S_ASSOCIATED_OOC_FILES=194 INTEGER, PARAMETER :: S_pad16=193 INTEGER, PARAMETER :: S_Deficiency=192 INTEGER, PARAMETER :: S_NB_SINGULAR_VALUES=191 INTEGER, PARAMETER :: S_SINGULAR_VALUES=190 INTEGER, PARAMETER :: S_MTKO_PROCS_MAP=189 INTEGER, PARAMETER :: S_L0_OMP_MAPPING=188 INTEGER, PARAMETER :: S_PTR_LEAFS_L0_OMP=187 INTEGER, PARAMETER :: S_PERM_L0_OMP=186 INTEGER, PARAMETER :: S_VIRT_L0_OMP_MAPPING=185 INTEGER, PARAMETER :: S_VIRT_L0_OMP=184 INTEGER, PARAMETER :: S_PHYS_L0_OMP=183 INTEGER, PARAMETER :: S_IPOOL_A_L0_OMP=182 INTEGER, PARAMETER :: S_IPOOL_B_L0_OMP=181 INTEGER, PARAMETER :: S_I8_L0_OMP=180 INTEGER, PARAMETER :: S_I4_L0_OMP=179 INTEGER, PARAMETER :: S_THREAD_LA=178 INTEGER, PARAMETER :: S_LL0_OMP_FACTORS=177 INTEGER, PARAMETER :: S_LL0_OMP_MAPPING=176 INTEGER, PARAMETER :: S_L_VIRT_L0_OMP=175 INTEGER, PARAMETER :: S_L_PHYS_L0_OMP=174 INTEGER, PARAMETER :: S_LPOOL_B_L0_OMP=173 INTEGER, PARAMETER :: S_LPOOL_A_L0_OMP=172 INTEGER, PARAMETER :: S_BLRARRAY_ENCODING=171 INTEGER, PARAMETER :: S_FDM_F_ENCODING=170 INTEGER, PARAMETER :: S_pad13=169 INTEGER, PARAMETER :: S_NBGRP=168 INTEGER, PARAMETER :: S_LRGROUPS=167 INTEGER, PARAMETER :: S_INTR_ENCODING=166 INTEGER, PARAMETER :: S_WORKING=165 INTEGER, PARAMETER :: S_IPTR_WORKING=164 INTEGER, PARAMETER :: S_pad14=163 INTEGER, PARAMETER :: S_SUP_PROC=162 INTEGER, PARAMETER :: S_PIVNUL_LIST=161 INTEGER, PARAMETER :: S_OOC_FILE_NAMES=160 INTEGER, PARAMETER :: S_OOC_FILE_NAME_LENGTH=159 INTEGER, PARAMETER :: S_pad12=158 INTEGER, PARAMETER :: S_OOC_NB_FILE_TYPE=157 INTEGER, PARAMETER :: S_OOC_NB_FILES=156 INTEGER, PARAMETER :: S_OOC_TOTAL_NB_NODES=155 INTEGER, PARAMETER :: S_OOC_VADDR=154 INTEGER, PARAMETER :: S_OOC_SIZE_OF_BLOCK=153 INTEGER, PARAMETER :: S_OOC_INODE_SEQUENCE=152 INTEGER, PARAMETER :: S_OOC_MAX_NB_NODES_FOR_ZONE=151 INTEGER, PARAMETER :: S_INSTANCE_NUMBER=150 INTEGER, PARAMETER :: S_CB_SON_SIZE=149 INTEGER, PARAMETER :: S_DKEEP=148 INTEGER, PARAMETER :: S_LWK_USER=147 INTEGER, PARAMETER :: S_NBSA_LOCAL=146 INTEGER, PARAMETER :: S_WK_USER=145 INTEGER, PARAMETER :: S_CROIX_MANU=144 INTEGER, PARAMETER :: S_SCHED_SBTR=143 INTEGER, PARAMETER :: S_SCHED_GRP=142 INTEGER, PARAMETER :: S_SCHED_DEP=141 INTEGER, PARAMETER :: S_SBTR_ID=140 INTEGER, PARAMETER :: S_DEPTH_FIRST_SEQ=139 INTEGER, PARAMETER :: S_DEPTH_FIRST=138 INTEGER, PARAMETER :: S_MY_NB_LEAF=137 INTEGER, PARAMETER :: S_MY_FIRST_LEAF=136 INTEGER, PARAMETER :: S_MY_ROOT_SBTR=135 INTEGER, PARAMETER :: S_COST_TRAV=134 INTEGER, PARAMETER :: S_MEM_SUBTREE=133 INTEGER, PARAMETER :: S_RHSINTR=132 INTEGER, PARAMETER :: S_GLOB2LOC_SOL=131 INTEGER, PARAMETER :: S_pad11=130 INTEGER, PARAMETER :: S_GLOB2LOC_SOL_ALLOC=129 INTEGER, PARAMETER :: S_GLOB2LOC_RHS=128 INTEGER, PARAMETER :: S_MEM_DIST=127 INTEGER, PARAMETER :: S_I_AM_CAND=126 INTEGER, PARAMETER :: S_TAB_POS_IN_PERE=125 INTEGER, PARAMETER :: S_FUTURE_NIV2=124 INTEGER, PARAMETER :: S_ISTEP_TO_INIV2=123 INTEGER, PARAMETER :: S_CANDIDATES=122 INTEGER, PARAMETER :: S_ELTPROC=121 INTEGER, PARAMETER :: S_LELTVAR=120 INTEGER, PARAMETER :: S_NELT_loc=119 INTEGER, PARAMETER :: S_PROCNODE=118 INTEGER, PARAMETER :: S_LPS=117 INTEGER, PARAMETER :: S_S=116 INTEGER, PARAMETER :: S_PTRFAC=115 INTEGER, PARAMETER :: S_PTLUST_S=114 INTEGER, PARAMETER :: S_Step2node=113 INTEGER, PARAMETER :: S_PROCNODE_STEPS=112 INTEGER, PARAMETER :: S_NA=111 INTEGER, PARAMETER :: S_PTRDEBARR=110 INTEGER, PARAMETER :: S_NINROWARR=109 INTEGER, PARAMETER :: S_NINCOLARR=108 INTEGER, PARAMETER :: S_PTR8ARR=107 INTEGER, PARAMETER :: S_PTRAR=106 INTEGER, PARAMETER :: S_FRTELT=105 INTEGER, PARAMETER :: S_FRTPTR=104 INTEGER, PARAMETER :: S_FILS=103 INTEGER, PARAMETER :: S_DAD_STEPS=102 INTEGER, PARAMETER :: S_FRERE_STEPS=101 INTEGER, PARAMETER :: S_ND_STEPS=100 INTEGER, PARAMETER :: S_NE_STEPS=99 INTEGER, PARAMETER :: S_STEP=98 INTEGER, PARAMETER :: S_NBSA=97 INTEGER, PARAMETER :: S_LNA=96 INTEGER, PARAMETER :: S_KEEP=95 INTEGER, PARAMETER :: S_IS=94 INTEGER, PARAMETER :: S_ASS_IRECV=93 INTEGER, PARAMETER :: S_NSLAVES=92 INTEGER, PARAMETER :: S_NPROCS=91 INTEGER, PARAMETER :: S_MYID=90 INTEGER, PARAMETER :: S_COMM_LOAD=89 INTEGER, PARAMETER :: S_MYID_NODES=88 INTEGER, PARAMETER :: S_COMM_NODES=87 INTEGER, PARAMETER :: S_INST_Number=86 INTEGER, PARAMETER :: S_MAX_SURF_MASTER=85 INTEGER, PARAMETER :: S_KEEP8=84 INTEGER, PARAMETER :: S_pad7=83 INTEGER, PARAMETER :: S_SAVE_PREFIX=82 INTEGER, PARAMETER :: S_SAVE_DIR=81 INTEGER, PARAMETER :: S_WRITE_PROBLEM=80 INTEGER, PARAMETER :: S_OOC_PREFIX=79 INTEGER, PARAMETER :: S_OOC_TMPDIR=78 INTEGER, PARAMETER :: S_VERSION_NUMBER=77 INTEGER, PARAMETER :: S_MAPPING=76 INTEGER, PARAMETER :: S_LISTVAR_SCHUR=75 INTEGER, PARAMETER :: S_SCHUR_CINTERFACE=74 INTEGER, PARAMETER :: S_SCHUR=73 INTEGER, PARAMETER :: S_SIZE_SCHUR=72 INTEGER, PARAMETER :: S_SCHUR_LLD=71 INTEGER, PARAMETER :: S_SCHUR_NLOC=70 INTEGER, PARAMETER :: S_SCHUR_MLOC=69 INTEGER, PARAMETER :: S_NBLOCK=68 INTEGER, PARAMETER :: S_MBLOCK=67 INTEGER, PARAMETER :: S_NPCOL=66 INTEGER, PARAMETER :: S_NPROW=65 INTEGER, PARAMETER :: S_UNS_PERM=64 INTEGER, PARAMETER :: S_SYM_PERM=63 INTEGER, PARAMETER :: S_METIS_OPTIONS=62 INTEGER, PARAMETER :: S_RINFOG=61 INTEGER, PARAMETER :: S_RINFO=60 INTEGER, PARAMETER :: S_CNTL=59 INTEGER, PARAMETER :: S_COST_SUBTREES=58 INTEGER, PARAMETER :: S_INFOG=57 INTEGER, PARAMETER :: S_INFO=56 INTEGER, PARAMETER :: S_ICNTL=55 INTEGER, PARAMETER :: S_pad6=54 INTEGER, PARAMETER :: S_LD_RHSINTR=53 INTEGER, PARAMETER :: S_NSOL_loc=52 INTEGER, PARAMETER :: S_LSOL_loc=51 INTEGER, PARAMETER :: S_LREDRHS=50 INTEGER, PARAMETER :: S_LRHS_loc=49 INTEGER, PARAMETER :: S_Nloc_RHS=48 INTEGER, PARAMETER :: S_NZ_RHS=47 INTEGER, PARAMETER :: S_NRHS=46 INTEGER, PARAMETER :: S_LRHS=45 INTEGER, PARAMETER :: S_IRHS_loc=44 INTEGER, PARAMETER :: S_ISOL_loc=43 INTEGER, PARAMETER :: S_IRHS_PTR=42 INTEGER, PARAMETER :: S_IRHS_SPARSE=41 INTEGER, PARAMETER :: S_RHS_loc=40 INTEGER, PARAMETER :: S_SOL_loc=39 INTEGER, PARAMETER :: S_RHS_SPARSE=38 INTEGER, PARAMETER :: S_REDRHS=37 INTEGER, PARAMETER :: S_RHS=36 INTEGER, PARAMETER :: S_BLKVAR=35 INTEGER, PARAMETER :: S_BLKPTR=34 INTEGER, PARAMETER :: S_pad5=33 INTEGER, PARAMETER :: S_NBLK=32 INTEGER, PARAMETER :: S_PERM_IN=31 INTEGER, PARAMETER :: S_pad4=30 INTEGER, PARAMETER :: S_A_ELT=29 INTEGER, PARAMETER :: S_ELTVAR=28 INTEGER, PARAMETER :: S_ELTPTR=27 INTEGER, PARAMETER :: S_pad3=26 INTEGER, PARAMETER :: S_NELT=25 INTEGER, PARAMETER :: S_pad2=24 INTEGER, PARAMETER :: S_A_loc=23 INTEGER, PARAMETER :: S_JCN_loc=22 INTEGER, PARAMETER :: S_IRN_loc=21 INTEGER, PARAMETER :: S_NNZ_loc=20 INTEGER, PARAMETER :: S_pad1=19 INTEGER, PARAMETER :: S_NZ_loc=18 INTEGER, PARAMETER :: S_PIVOTS=17 INTEGER, PARAMETER :: S_COLIND=16 INTEGER, PARAMETER :: S_ROWIND=15 INTEGER, PARAMETER :: S_ROWSCA_loc=14 INTEGER, PARAMETER :: S_COLSCA_loc=13 INTEGER, PARAMETER :: S_ROWSCA=12 INTEGER, PARAMETER :: S_COLSCA=11 INTEGER, PARAMETER :: S_JCN=10 INTEGER, PARAMETER :: S_IRN=9 INTEGER, PARAMETER :: S_A=8 INTEGER, PARAMETER :: S_NNZ=7 INTEGER, PARAMETER :: S_NZ=6 INTEGER, PARAMETER :: S_N=5 INTEGER, PARAMETER :: S_JOB=4 INTEGER, PARAMETER :: S_PAR=3 INTEGER, PARAMETER :: S_SYM=2 INTEGER, PARAMETER :: S_COMM=1 INTEGER, PARAMETER :: R_gridinit_done=20 INTEGER, PARAMETER :: R_yes=19 INTEGER, PARAMETER :: R_RG2L=18 INTEGER, PARAMETER :: R_IPIV=17 INTEGER, PARAMETER :: R_NB_SINGULAR_VALUES=16 INTEGER, PARAMETER :: R_LPIV=15 INTEGER, PARAMETER :: R_CNTXT_BLACS=14 INTEGER, PARAMETER :: R_DESCRIPTOR=13 INTEGER, PARAMETER :: R_TOT_ROOT_SIZE=12 INTEGER, PARAMETER :: R_ROOT_SIZE=11 INTEGER, PARAMETER :: R_RHS_NLOC=10 INTEGER, PARAMETER :: R_SCHUR_LLD=9 INTEGER, PARAMETER :: R_SCHUR_NLOC=8 INTEGER, PARAMETER :: R_SCHUR_MLOC=7 INTEGER, PARAMETER :: R_MYCOL=6 INTEGER, PARAMETER :: R_MYROW=5 INTEGER, PARAMETER :: R_NPCOL=4 INTEGER, PARAMETER :: R_NPROW=3 INTEGER, PARAMETER :: R_NBLOCK=2 INTEGER, PARAMETER :: R_MBLOCK=1 OOC_INDICES=(/156,157,159,160/) SIZE_INT = id%KEEP(34) SIZE_INT8 = id%KEEP(34)*id%KEEP(10) SIZE_RL_OR_DBL = id%KEEP(150) SIZE_ARITH_DEP = id%KEEP(149) SIZE_DOUBLE_PRECISION = 8 SIZE_LOGICAL = 4 SIZE_CHARACTER = 1 size_written=int(0,kind=8) tot_NbRecords=0 NbRecords(:)=0 NbRecords_ROOTC(:)=0 size_read=int(0,kind=8) size_allocated=int(0,kind=8) DIFF_SIZE_ALLOC_READ(:)=0 DIFF_SIZE_ALLOC_READ_ROOTC(:)=0 WRITTEN_STRUC_SIZE=int(0,kind=8) TMP_OOC_NAMES(:)="?" SIZE_VARIABLES_BLR=0_8 SIZE_GEST_BLR=0 SIZE_VARIABLES_FRONT_DATA=0_8 SIZE_GEST_FRONT_DATA=0 SIZE_VARIABLES_L0FAC=0 SIZE_GEST_L0FAC=0 if(mode.EQ.memory_save_mode) then elseif(mode.EQ.save_mode) then write(unit,iostat=err) "MUMPS" if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(5*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(id%MYID.EQ.0) THEN call date_and_time(date,time,zone,values) hash=trim(date)//trim(time)//trim(zone) ENDIF CALL MPI_BCAST( hash, 23, MPI_CHARACTER, 0, id%COMM, ierr ) write(unit,iostat=err) hash if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(23*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(2*SIZE_INT8,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ARITH="CMUMPS"(1:1) write(unit,iostat=err) ARITH if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(1,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) id%SYM,id%PAR,id%NPROCS if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(3*SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(id%KEEP(10).EQ.1) THEN INT_TYPE_64=.TRUE. ELSE INT_TYPE_64=.FALSE. ENDIF write(unit,iostat=err) INT_TYPE_64 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_LOGICAL,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(associated(id%OOC_FILE_NAME_LENGTH).AND. & associated(id%OOC_FILE_NAMES)) THEN write(unit,iostat=err) id%OOC_FILE_NAME_LENGTH(1) if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(1))= & id%OOC_FILE_NAMES(1,1:id%OOC_FILE_NAME_LENGTH(1)) write(unit,iostat=err) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(1)) if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written & +int(id%OOC_FILE_NAME_LENGTH(1)*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ELSE write(unit,iostat=err) -999 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) -999 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ENDIF elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then CALL MUMPS_READ_HEADER(unit,err,size_read,SIZE_INT,SIZE_INT8, & TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE, READ_ARITH, & READ_INT_TYPE_64, READ_OOC_FILE_NAME_LENGTH, & READ_OOC_FIRST_FILE_NAME,READ_HASH, & READ_SYM,READ_PAR,READ_NPROCS,FORTRAN_VERSION_OK) if (err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) elseif (.NOT.FORTRAN_VERSION_OK) THEN id%INFO(1) = -73 id%INFO(2) = 1 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 BASIC_CHECK = .false. IF (mode.EQ.restore_ooc_mode) THEN BASIC_CHECK = .true. ENDIF CALL CMUMPS_CHECK_HEADER(id,BASIC_CHECK,READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) IF (id%INFO(1) .LT. 0) GOTO 100 elseif(mode.EQ.fake_restore_mode) then read(unit,iostat=err) READ_HASH if(err.ne.0) GOTO 100 read(unit,iostat=err) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(err.ne.0) GOTO 100 IF ( id%INFO(1) .LT. 0 ) GOTO 100 GOTO 200 else CALL MUMPS_ABORT() endif DO j=1,size(OOC_INDICES) i1=OOC_INDICES(j) SELECT CASE(i1) CASE(S_OOC_NB_FILES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_NB_FILES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%OOC_NB_FILES,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_NB_FILES)) THEN write(unit,iostat=err) size(id%OOC_NB_FILES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_NB_FILES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then nullify(id%OOC_NB_FILES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_NB_FILES(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_NB_FILES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_NB_FILE_TYPE) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%OOC_NB_FILE_TYPE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%OOC_NB_FILE_TYPE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_FILE_NAMES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_FILE_NAMES)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_FILE_NAMES,1) & *size(id%OOC_FILE_NAMES,2)*SIZE_CHARACTER ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_FILE_NAMES)) THEN write(unit,iostat=err) size(id%OOC_FILE_NAMES,1) & ,size(id%OOC_FILE_NAMES,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_FILE_NAMES ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then nullify(id%OOC_FILE_NAMES) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2 & *SIZE_CHARACTER allocate(id%OOC_FILE_NAMES(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_FILE_NAMES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_FILE_NAME_LENGTH) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_FILE_NAME_LENGTH)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%OOC_FILE_NAME_LENGTH,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_FILE_NAME_LENGTH)) THEN write(unit,iostat=err) size(id%OOC_FILE_NAME_LENGTH,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_FILE_NAME_LENGTH ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then nullify(id%OOC_FILE_NAME_LENGTH) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_FILE_NAME_LENGTH(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_FILE_NAME_LENGTH endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE DEFAULT END SELECT ENDDO if(mode.EQ.restore_ooc_mode) then goto 200 endif DO i1=1,NBVARIABLES SELECT CASE(i1) CASE(S_COMM) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_SYM) CALL MUMPS_SAVE_INT(id%SYM) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_PAR) CALL MUMPS_SAVE_INT(id%PAR) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_JOB) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_N) CALL MUMPS_SAVE_INT(id%N) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ICNTL) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%ICNTL,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%ICNTL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%ICNTL,1) read(unit,iostat=err) id%ICNTL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_INFO) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFO,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) INFO1,INFO2 & ,id%INFO(3:size(id%INFO,1)) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFO,1) read(unit,iostat=err) INFO1,INFO2 & ,id%INFO(3:size(id%INFO,1)) if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_INFOG) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFOG,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) INFOG1,INFOG2 & ,id%INFOG(3:size(id%INFOG,1)) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFOG,1) read(unit,iostat=err) INFOG1,INFOG2 & ,id%INFOG(3:size(id%INFOG,1)) if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_COST_SUBTREES) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%COST_SUBTREES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL read(unit,iostat=err) id%COST_SUBTREES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_CNTL) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%CNTL,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%CNTL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%CNTL,1) read(unit,iostat=err) id%CNTL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_RINFO) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFO,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%RINFO if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFO,1) read(unit,iostat=err) id%RINFO if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_RINFOG) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFOG,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%RINFOG if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFOG,1) read(unit,iostat=err) id%RINFOG if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_KEEP8) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8*size(id%KEEP8,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%KEEP8 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8*size(id%KEEP8,1) KEEP883_SAVE=id%KEEP8(83) KEEP884_SAVE=id%KEEP8(84) read(unit,iostat=err) id%KEEP8 id%KEEP8(83)=KEEP883_SAVE id%KEEP8(84)=KEEP884_SAVE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_KEEP) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%KEEP,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%KEEP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%KEEP,1) KEEP410_SAVE = id%KEEP(410) KEEP411_SAVE = id%KEEP(411) read(unit,iostat=err) id%KEEP id%KEEP(410) = KEEP410_SAVE id%KEEP(411) = KEEP411_SAVE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_DKEEP) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%DKEEP,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%DKEEP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%DKEEP,1) read(unit,iostat=err) id%DKEEP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NZ) CALL MUMPS_SAVE_INT(id%NZ) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NNZ) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%NNZ if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%NNZ if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_A) CASE(S_IRN) CASE(S_JCN) CASE(S_COLSCA) IF(id%KEEP(52).NE.-1) THEN CALL MUMPS_SAVERSTR_REALARRAY(id%COLSCA) ELSE ENDIF IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ROWSCA) IF(id%KEEP(52).NE.-1) THEN CALL MUMPS_SAVERSTR_REALARRAY(id%ROWSCA) ELSE ENDIF IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_COLSCA_loc) CALL MUMPS_SAVERSTR_REALARRAY(id%COLSCA_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ROWSCA_loc) IS_SYMMETRIC = .FALSE. IF (mode.EQ.memory_save_mode .OR. & mode.EQ.save_mode) THEN IS_SYMMETRIC = id%KEEP(50).EQ.1 .OR. & id%KEEP(50).EQ.2 ELSEIF (mode.EQ.restore_mode) THEN IS_SYMMETRIC = READ_SYM.EQ.1 .OR. & READ_SYM.EQ.2 ENDIF IF ( IS_SYMMETRIC ) THEN IF ( mode.EQ.restore_mode ) THEN id%ROWSCA_loc => id%COLSCA_loc ENDIF ELSE CALL MUMPS_SAVERSTR_REALARRAY(id%ROWSCA_loc) ENDIF IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NZ_loc) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%NZ_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NZ_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NNZ_loc) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%NNZ_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%NNZ_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_IRN_loc) CASE(S_JCN_loc) CASE(S_A_loc) CASE(S_NELT) CALL MUMPS_SAVE_INT(id%NELT) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NBLK) CALL MUMPS_SAVE_INT(id%NBLK) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ELTPTR) CASE(S_ELTVAR) CASE(S_A_ELT) CASE(S_PERM_IN) CASE(S_BLKPTR) CASE(S_BLKVAR) CASE(S_COLIND) CASE(S_PIVOTS) CASE(S_RHS) CASE(S_REDRHS) CASE(S_ROWIND) CASE(S_RHS_SPARSE) CASE(S_SOL_loc) CASE(S_RHS_loc) CASE(S_IRHS_SPARSE) CASE(S_IRHS_PTR) CASE(S_ISOL_loc) CASE(S_IRHS_loc) CASE(S_LRHS) CALL MUMPS_SAVE_INT(id%LRHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NRHS) CALL MUMPS_SAVE_INT(id%NRHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NZ_RHS) CALL MUMPS_SAVE_INT(id%NZ_RHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LRHS_loc) CALL MUMPS_SAVE_INT(id%LRHS_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_Nloc_RHS) CALL MUMPS_SAVE_INT(id%Nloc_RHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LD_RHSINTR) CALL MUMPS_SAVE_INT(id%LD_RHSINTR) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NSOL_loc) CALL MUMPS_SAVE_INT(id%NSOL_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LSOL_loc) CALL MUMPS_SAVE_INT(id%LSOL_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LREDRHS) CALL MUMPS_SAVE_INT(id%LREDRHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SYM_PERM) CALL CMUMPS_SAVE_INT_SHPTR_ARRAY(id%SYM_PERM & ) IF (id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_UNS_PERM) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%UNS_PERM)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%UNS_PERM,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%UNS_PERM)) THEN write(unit,iostat=err) size(id%UNS_PERM,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%UNS_PERM ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%UNS_PERM) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%UNS_PERM(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%UNS_PERM endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NPROW) CALL MUMPS_SAVE_INT(id%NPROW) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NPCOL) CALL MUMPS_SAVE_INT(id%NPCOL) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_MBLOCK) CALL MUMPS_SAVE_INT(id%MBLOCK) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NBLOCK) CALL MUMPS_SAVE_INT(id%NBLOCK) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SCHUR_MLOC) CALL MUMPS_SAVE_INT(id%SCHUR_MLOC) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SCHUR_NLOC) CALL MUMPS_SAVE_INT(id%SCHUR_NLOC) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SCHUR_LLD) CALL MUMPS_SAVE_INT(id%SCHUR_LLD) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SIZE_SCHUR) CALL MUMPS_SAVE_INT(id%SIZE_SCHUR) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SCHUR) CASE(S_SCHUR_CINTERFACE) CASE(S_LISTVAR_SCHUR) CASE(S_MAPPING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MAPPING)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(28)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MAPPING)) THEN write(unit,iostat=err) id%KEEP8(28) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MAPPING ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MAPPING) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT+SIZE_INT8 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_INT allocate(id%MAPPING(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MAPPING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_VERSION_NUMBER) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%VERSION_NUMBER) & *SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%VERSION_NUMBER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%VERSION_NUMBER) & *SIZE_CHARACTER read(unit,iostat=err) id%VERSION_NUMBER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_TMPDIR) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%OOC_TMPDIR) & *SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%OOC_TMPDIR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%OOC_TMPDIR) & *SIZE_CHARACTER read(unit,iostat=err) id%OOC_TMPDIR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_PREFIX) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%OOC_PREFIX) & *SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%OOC_PREFIX if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=1 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%OOC_PREFIX) & *SIZE_CHARACTER read(unit,iostat=err) id%OOC_PREFIX if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_WRITE_PROBLEM) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%WRITE_PROBLEM) & *SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%WRITE_PROBLEM if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%WRITE_PROBLEM) & *SIZE_CHARACTER read(unit,iostat=err) id%WRITE_PROBLEM if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MAX_SURF_MASTER) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%MAX_SURF_MASTER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%MAX_SURF_MASTER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_INST_Number) CALL MUMPS_SAVE_INT(id%INST_Number) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_COMM_NODES) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_MYID_NODES) CALL MUMPS_SAVE_INT(id%MYID_NODES) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_COMM_LOAD) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_MYID) CALL MUMPS_SAVE_INT(id%MYID) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NPROCS) CALL MUMPS_SAVE_INT(id%NPROCS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NSLAVES) CALL MUMPS_SAVE_INT(id%NSLAVES) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ASS_IRECV) CALL MUMPS_SAVE_INT(id%ASS_IRECV) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_IS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%IS)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=id%KEEP(32)*SIZE_INT DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size(id%IS,1)-id%KEEP(32)) ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%IS)) THEN write(unit,iostat=err) size(id%IS,1),id%KEEP(32) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IS(1:id%KEEP(32)) DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size(id%IS,1)-id%KEEP(32)) ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%IS) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array2*SIZE_INT DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size_array1-size_array2) allocate(id%IS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IS(1:size_array2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_Deficiency) CALL MUMPS_SAVE_INT(id%Deficiency) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LNA) CALL MUMPS_SAVE_INT(id%LNA) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NBSA) CALL MUMPS_SAVE_INT(id%NBSA) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_STEP) CALL CMUMPS_SAVE_INT_SHPTR_ARRAY(id%STEP & ) IF (id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_NE_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%NE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%NE_STEPS)) THEN write(unit,iostat=err) size(id%NE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%NE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%NE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_ND_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%ND_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ND_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%ND_STEPS)) THEN write(unit,iostat=err) size(id%ND_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ND_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%ND_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ND_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ND_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_Step2node) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%Step2node)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%Step2node,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%Step2node)) THEN write(unit,iostat=err) size(id%Step2node,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%Step2node ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%Step2node) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%Step2node(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%Step2node endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FRERE_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%FRERE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRERE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FRERE_STEPS)) THEN write(unit,iostat=err) size(id%FRERE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FRERE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FRERE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRERE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRERE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_DAD_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%DAD_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DAD_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%DAD_STEPS)) THEN write(unit,iostat=err) size(id%DAD_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DAD_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%DAD_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DAD_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DAD_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FILS) CALL CMUMPS_SAVE_INT_SHPTR_ARRAY(id%FILS & ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_PTR8ARR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTR8ARR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTR8ARR,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTR8ARR)) THEN write(unit,iostat=err) size(id%PTR8ARR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTR8ARR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=2 elseif(mode.EQ.restore_mode) then nullify(id%PTR8ARR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTR8ARR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTR8ARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NINCOLARR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then NbRecords(i1)=2 IF(associated(id%NINCOLARR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NINCOLARR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%NINCOLARR)) THEN write(unit,iostat=err) size(id%NINCOLARR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%NINCOLARR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%NINCOLARR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NINCOLARR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NINCOLARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NINROWARR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then NbRecords(i1)=2 IF(associated(id%NINROWARR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NINROWARR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%NINROWARR)) THEN write(unit,iostat=err) size(id%NINROWARR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%NINROWARR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%NINROWARR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NINROWARR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NINROWARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTRDEBARR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then NbRecords(i1)=2 IF(associated(id%PTRDEBARR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRDEBARR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTRDEBARR)) THEN write(unit,iostat=err) size(id%PTRDEBARR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTRDEBARR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PTRDEBARR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PTRDEBARR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRDEBARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTRAR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTRAR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRAR,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTRAR)) THEN write(unit,iostat=err) size(id%PTRAR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTRAR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=2 elseif(mode.EQ.restore_mode) then nullify(id%PTRAR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTRAR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRAR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FRTPTR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%FRTPTR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRTPTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FRTPTR)) THEN write(unit,iostat=err) size(id%FRTPTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FRTPTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FRTPTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRTPTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRTPTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FRTELT) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%FRTELT)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRTELT,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FRTELT)) THEN write(unit,iostat=err) size(id%FRTELT,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%FRTELT ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FRTELT) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRTELT(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRTELT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NA) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%NA)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NA,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%NA)) THEN write(unit,iostat=err) size(id%NA,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%NA ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%NA) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NA(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NA endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PROCNODE_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then NbRecords(i1)=2 IF(associated(id%PROCNODE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PROCNODE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PROCNODE_STEPS)) THEN write(unit,iostat=err) size(id%PROCNODE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PROCNODE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PROCNODE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PROCNODE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PROCNODE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTLUST_S) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTLUST_S)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTLUST_S,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTLUST_S)) THEN write(unit,iostat=err) size(id%PTLUST_S,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTLUST_S ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PTLUST_S) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PTLUST_S(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTLUST_S endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTRFAC) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTRFAC)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRFAC,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTRFAC)) THEN write(unit,iostat=err) size(id%PTRFAC,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) id%PTRFAC ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PTRFAC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTRFAC(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRFAC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_S) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%S)) THEN SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=id%KEEP8(31)*SIZE_ARITH_DEP DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP*(id%KEEP8(23)-id%KEEP8(31)) ELSE SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%S)) THEN write(unit,iostat=err) id%KEEP8(23),id%KEEP8(31) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%S(1:id%KEEP8(31)) DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP*(id%KEEP8(23)-id%KEEP8(31)) ELSE write(unit,iostat=err) int(-999,kind=8) & ,int(-998,kind=8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%S) read(unit,iostat=err) size_array_INT8_1,size_array_INT8_2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,kind=8)) then SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=size_array_INT8_2*SIZE_ARITH_DEP DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP* & (size_array_INT8_1-size_array_INT8_2) allocate(id%S(1:size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%S(1:size_array_INT8_2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_LPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%LPS)) THEN SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=id%KEEP8(31)*SIZE_ARITH_DEP/2 DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP/2*(id%KEEP8(23)-id%KEEP8(31)) ELSE SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%LPS)) THEN write(unit,iostat=err) id%KEEP8(23),id%KEEP8(31) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%LPS(1:id%KEEP8(31)) DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP/2*(id%KEEP8(23)-id%KEEP8(31)) ELSE write(unit,iostat=err) int(-999,kind=8) & ,int(-998,kind=8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%LPS) read(unit,iostat=err) size_array_INT8_1,size_array_INT8_2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,kind=8)) then SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=size_array_INT8_2*SIZE_ARITH_DEP/2 DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP/2* & (size_array_INT8_1-size_array_INT8_2) allocate(id%LPS(1:size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%LPS(1:size_array_INT8_2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PROCNODE) CASE(S_NELT_loc) CALL MUMPS_SAVE_INT(id%NELT_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LELTVAR) CALL MUMPS_SAVE_INT(id%LELTVAR) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ELTPROC) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%ELTPROC)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ELTPROC,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%ELTPROC)) THEN write(unit,iostat=err) size(id%ELTPROC,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ELTPROC ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%ELTPROC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ELTPROC(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ELTPROC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_I4_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%I4_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%I4_L0_OMP,1) & *size(id%I4_L0_OMP,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%I4_L0_OMP)) THEN write(unit,iostat=err) size(id%I4_L0_OMP,1) & ,size(id%I4_L0_OMP,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I4_L0_OMP ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%I4_L0_OMP) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%I4_L0_OMP(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%I4_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_I8_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%I8_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%I8_L0_OMP,1) & *size(id%I8_L0_OMP,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%I8_L0_OMP)) THEN write(unit,iostat=err) size(id%I8_L0_OMP,1) & ,size(id%I8_L0_OMP,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I8_L0_OMP ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%I8_L0_OMP) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%I8_L0_OMP(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%I8_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_CANDIDATES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%CANDIDATES)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%CANDIDATES,1) & *size(id%CANDIDATES,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%CANDIDATES)) THEN write(unit,iostat=err) size(id%CANDIDATES,1) & ,size(id%CANDIDATES,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%CANDIDATES ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%CANDIDATES) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%CANDIDATES(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%CANDIDATES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_ISTEP_TO_INIV2) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%ISTEP_TO_INIV2)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ISTEP_TO_INIV2,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%ISTEP_TO_INIV2)) THEN write(unit,iostat=err) size(id%ISTEP_TO_INIV2,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ISTEP_TO_INIV2 ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%ISTEP_TO_INIV2) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ISTEP_TO_INIV2(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ISTEP_TO_INIV2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FUTURE_NIV2) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%FUTURE_NIV2)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FUTURE_NIV2,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FUTURE_NIV2)) THEN write(unit,iostat=err) size(id%FUTURE_NIV2,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FUTURE_NIV2 ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FUTURE_NIV2) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FUTURE_NIV2(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FUTURE_NIV2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_TAB_POS_IN_PERE) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%TAB_POS_IN_PERE)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%TAB_POS_IN_PERE,1) & *size(id%TAB_POS_IN_PERE,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%TAB_POS_IN_PERE)) THEN write(unit,iostat=err) size(id%TAB_POS_IN_PERE,1) & ,size(id%TAB_POS_IN_PERE,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%TAB_POS_IN_PERE ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%TAB_POS_IN_PERE) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%TAB_POS_IN_PERE(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%TAB_POS_IN_PERE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_I_AM_CAND) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%I_AM_CAND)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%I_AM_CAND,1)*SIZE_LOGICAL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%I_AM_CAND)) THEN write(unit,iostat=err) size(id%I_AM_CAND,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I_AM_CAND ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%I_AM_CAND) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_LOGICAL allocate(id%I_AM_CAND(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%I_AM_CAND endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MEM_DIST) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MEM_DIST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MEM_DIST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MEM_DIST)) THEN write(unit,iostat=err) size(id%MEM_DIST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) id%MEM_DIST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MEM_DIST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MEM_DIST(0:size_array1-1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MEM_DIST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_GLOB2LOC_RHS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%GLOB2LOC_RHS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%GLOB2LOC_RHS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%GLOB2LOC_RHS)) THEN write(unit,iostat=err) size(id%GLOB2LOC_RHS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%GLOB2LOC_RHS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%GLOB2LOC_RHS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%GLOB2LOC_RHS(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%GLOB2LOC_RHS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_GLOB2LOC_SOL_ALLOC) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%GLOB2LOC_SOL_ALLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_LOGICAL read(unit,iostat=err) id%GLOB2LOC_SOL_ALLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_GLOB2LOC_SOL) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%GLOB2LOC_SOL)) THEN IF(id%GLOB2LOC_SOL_ALLOC) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%GLOB2LOC_SOL,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%GLOB2LOC_SOL)) THEN IF(id%GLOB2LOC_SOL_ALLOC) THEN write(unit,iostat=err) size(id%GLOB2LOC_SOL,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%GLOB2LOC_SOL ELSE write(unit,iostat=err) size(id%GLOB2LOC_SOL,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%GLOB2LOC_SOL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else if(id%GLOB2LOC_SOL_ALLOC) then SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%GLOB2LOC_SOL(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%GLOB2LOC_SOL else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy id%GLOB2LOC_SOL=>id%GLOB2LOC_RHS endif endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_RHSINTR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%RHSINTR)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(25)*SIZE_ARITH_DEP ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%RHSINTR)) THEN write(unit,iostat=err) id%KEEP8(25) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%RHSINTR ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%RHSINTR) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_ARITH_DEP allocate(id%RHSINTR(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%RHSINTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MEM_SUBTREE) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MEM_SUBTREE)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%MEM_SUBTREE,1)*SIZE_DOUBLE_PRECISION ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MEM_SUBTREE)) THEN write(unit,iostat=err) size(id%MEM_SUBTREE,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MEM_SUBTREE ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MEM_SUBTREE) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_DOUBLE_PRECISION allocate(id%MEM_SUBTREE(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MEM_SUBTREE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_COST_TRAV) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%COST_TRAV)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%COST_TRAV,1)*SIZE_DOUBLE_PRECISION ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%COST_TRAV)) THEN write(unit,iostat=err) size(id%COST_TRAV,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%COST_TRAV ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%COST_TRAV) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_DOUBLE_PRECISION allocate(id%COST_TRAV(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%COST_TRAV endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MY_ROOT_SBTR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MY_ROOT_SBTR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_ROOT_SBTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MY_ROOT_SBTR)) THEN write(unit,iostat=err) size(id%MY_ROOT_SBTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_ROOT_SBTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MY_ROOT_SBTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_ROOT_SBTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_ROOT_SBTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MY_FIRST_LEAF) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MY_FIRST_LEAF)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_FIRST_LEAF,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MY_FIRST_LEAF)) THEN write(unit,iostat=err) size(id%MY_FIRST_LEAF,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_FIRST_LEAF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MY_FIRST_LEAF) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_FIRST_LEAF(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_FIRST_LEAF endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MY_NB_LEAF) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MY_NB_LEAF)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_NB_LEAF,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MY_NB_LEAF)) THEN write(unit,iostat=err) size(id%MY_NB_LEAF,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_NB_LEAF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MY_NB_LEAF) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_NB_LEAF(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_NB_LEAF endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_DEPTH_FIRST) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%DEPTH_FIRST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DEPTH_FIRST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%DEPTH_FIRST)) THEN write(unit,iostat=err) size(id%DEPTH_FIRST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DEPTH_FIRST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%DEPTH_FIRST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DEPTH_FIRST(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DEPTH_FIRST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_DEPTH_FIRST_SEQ) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%DEPTH_FIRST_SEQ)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DEPTH_FIRST_SEQ,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%DEPTH_FIRST_SEQ)) THEN write(unit,iostat=err) size(id%DEPTH_FIRST_SEQ,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DEPTH_FIRST_SEQ ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%DEPTH_FIRST_SEQ) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DEPTH_FIRST_SEQ(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DEPTH_FIRST_SEQ endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SBTR_ID) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%SBTR_ID)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%SBTR_ID,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%SBTR_ID)) THEN write(unit,iostat=err) size(id%SBTR_ID,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%SBTR_ID ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%SBTR_ID) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%SBTR_ID(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%SBTR_ID endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SCHED_DEP) CASE(S_SCHED_GRP) CASE(S_CROIX_MANU) CASE(S_WK_USER) CASE(S_NBSA_LOCAL) CALL MUMPS_SAVE_INT(id%NBSA_LOCAL) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LWK_USER) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_CB_SON_SIZE) CASE(S_INSTANCE_NUMBER) CALL MUMPS_SAVE_INT(id%INSTANCE_NUMBER) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_OOC_MAX_NB_NODES_FOR_ZONE) CALL MUMPS_SAVE_INT(id%OOC_MAX_NB_NODES_FOR_ZONE) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_OOC_INODE_SEQUENCE) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_INODE_SEQUENCE)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_INODE_SEQUENCE,1) & *size(id%OOC_INODE_SEQUENCE,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_INODE_SEQUENCE)) THEN write(unit,iostat=err) size(id%OOC_INODE_SEQUENCE,1) & ,size(id%OOC_INODE_SEQUENCE,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_INODE_SEQUENCE ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%OOC_INODE_SEQUENCE) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%OOC_INODE_SEQUENCE(size_array1 & ,size_array2), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_INODE_SEQUENCE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_SIZE_OF_BLOCK) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_SIZE_OF_BLOCK)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_SIZE_OF_BLOCK,1) & *size(id%OOC_SIZE_OF_BLOCK,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_SIZE_OF_BLOCK)) THEN write(unit,iostat=err) size(id%OOC_SIZE_OF_BLOCK,1) & ,size(id%OOC_SIZE_OF_BLOCK,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_SIZE_OF_BLOCK ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%OOC_SIZE_OF_BLOCK) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%OOC_SIZE_OF_BLOCK(size_array1 & ,size_array2), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_SIZE_OF_BLOCK endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_VADDR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_VADDR)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_VADDR,1) & *size(id%OOC_VADDR,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_VADDR)) THEN write(unit,iostat=err) size(id%OOC_VADDR,1) & ,size(id%OOC_VADDR,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_VADDR ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%OOC_VADDR) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%OOC_VADDR(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_VADDR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_TOTAL_NB_NODES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_TOTAL_NB_NODES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%OOC_TOTAL_NB_NODES,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_TOTAL_NB_NODES)) THEN write(unit,iostat=err) size(id%OOC_TOTAL_NB_NODES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_TOTAL_NB_NODES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%OOC_TOTAL_NB_NODES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_TOTAL_NB_NODES(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_TOTAL_NB_NODES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_NB_FILES) CASE(S_OOC_NB_FILE_TYPE) CASE(S_OOC_FILE_NAMES) CASE(S_OOC_FILE_NAME_LENGTH) CASE(S_PIVNUL_LIST) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PIVNUL_LIST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PIVNUL_LIST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PIVNUL_LIST)) THEN write(unit,iostat=err) size(id%PIVNUL_LIST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PIVNUL_LIST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PIVNUL_LIST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PIVNUL_LIST(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PIVNUL_LIST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SUP_PROC) CASE(S_IPTR_WORKING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%IPTR_WORKING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%IPTR_WORKING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%IPTR_WORKING)) THEN write(unit,iostat=err) size(id%IPTR_WORKING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IPTR_WORKING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%IPTR_WORKING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%IPTR_WORKING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IPTR_WORKING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_WORKING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%WORKING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%WORKING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%WORKING)) THEN write(unit,iostat=err) size(id%WORKING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%WORKING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%WORKING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%WORKING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%WORKING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_INTR_ENCODING) NbRecords(i1) =0 SIZE_GEST(i1) =0 SIZE_VARIABLES(i1)=0_8 DO i2=1,NBVARIABLES_ROOTC SELECT CASE(i2) CASE(R_MBLOCK) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%MBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%MBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_NBLOCK) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%NBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%NBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_NPROW) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%NPROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%NPROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_NPCOL) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%NPCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%NPCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_MYROW) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then NbRecords_ROOTC(i2)=1 SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%MYROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%MYROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_MYCOL) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%MYCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%MYCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_SCHUR_MLOC) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%SCHUR_MLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%SCHUR_MLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_SCHUR_NLOC) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%SCHUR_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%SCHUR_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_SCHUR_LLD) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%SCHUR_LLD if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%SCHUR_LLD if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_RHS_NLOC) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%RHS_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%RHS_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_ROOT_SIZE) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%ROOT_SIZE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%ROOT_SIZE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_TOT_ROOT_SIZE) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%TOT_ROOT_SIZE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%TOT_ROOT_SIZE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_DESCRIPTOR) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)= & size(idintr%root%DESCRIPTOR,1) * SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%DESCRIPTOR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT* & size(idintr%root%DESCRIPTOR,1) read(unit,iostat=err) idintr%root%DESCRIPTOR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_CNTXT_BLACS) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%CNTXT_BLACS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%CNTXT_BLACS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_LPIV) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%LPIV if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%LPIV if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_RG2L) CASE(R_IPIV) NbRecords_ROOTC(i2)=2 if(mode.EQ.memory_save_mode) then IF(associated(idintr%root%IPIV)) THEN SIZE_GEST_ROOTC(i2)=SIZE_INT SIZE_VARIABLES_ROOTC(i2)= & size(idintr%root%IPIV,1)*SIZE_INT ELSE SIZE_GEST_ROOTC(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOTC(i2)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(idintr%root%IPIV)) THEN write(unit,iostat=err) size(idintr%root%IPIV,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) idintr%root%IPIV ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(idintr%root%IPIV) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_ROOTC(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOTC(i2)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_ROOTC(i2)=SIZE_INT SIZE_VARIABLES_ROOTC(i2)=size_array1*SIZE_INT allocate(idintr%root%IPIV(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) idintr%root%IPIV endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_yes) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%yes if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_LOGICAL read(unit,iostat=err) idintr%root%yes if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_gridinit_done) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%gridinit_done if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_LOGICAL read(unit,iostat=err) idintr%root%gridinit_done if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_NB_SINGULAR_VALUES) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%NB_SINGULAR_VALUES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%NB_SINGULAR_VALUES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_ROOTC(i2)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_ROOTC(i2)=NbRecords_ROOTC(i2)+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_ROOTC(i2) & +int(SIZE_GEST_ROOTC(i2),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*NbRecords_ROOTC(i2),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES_ROOTC(i2)+ & DIFF_SIZE_ALLOC_READ_ROOTC(i2) size_read=size_read+SIZE_VARIABLES_ROOTC(i2) & +int(SIZE_GEST_ROOTC(i2),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*id%KEEP(34)*NbRecords_ROOTC(i2),kind=8) #endif elseif(mode.EQ.fake_restore_mode) then endif ENDDO CALL CMUMPS_SAVE_RESTORE_L0FACARRAY( & idintr%L0_OMP_FACTORS & ,unit,id%MYID,mode & ,SIZE_GEST_L0FAC,SIZE_VARIABLES_L0FAC & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) CALL CMUMPS_SAVE_RESTORE_ROOTA( & idintr%roota & ,unit,id%MYID,mode & ,SIZE_GEST_ROOTA,SIZE_VARIABLES_ROOTA & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,SIZE_RL_OR_DBL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_NBGRP) CALL MUMPS_SAVE_INT(id%NBGRP) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LRGROUPS) CALL CMUMPS_SAVE_INT_SHPTR_ARRAY(id%LRGROUPS & ) IF (id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_FDM_F_ENCODING) NbRecords(i1)=1 SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=0_8 if(mode.EQ.memory_save_mode) then IF(associated(id%FDM_F_ENCODING)) THEN CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,memory_save_mode & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FDM_F_ENCODING)) THEN write(unit,iostat=err) size(id%FDM_F_ENCODING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,save_mode & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FDM_F_ENCODING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.NE.-999) then CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,restore_mode & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_BLRARRAY_ENCODING) NbRecords(i1)=1 SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=0_8 CALL_SAVE_RESTORE_BLR = .FALSE. if(mode.EQ.memory_save_mode) then IF(associated(id%BLRARRAY_ENCODING)) THEN CALL_SAVE_RESTORE_BLR = .TRUE. ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%BLRARRAY_ENCODING)) THEN write(unit,iostat=err) size(id%BLRARRAY_ENCODING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CALL_SAVE_RESTORE_BLR = .TRUE. ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(id%BLRARRAY_ENCODING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.NE.-999) then CALL_SAVE_RESTORE_BLR = .TRUE. endif endif IF (CALL_SAVE_RESTORE_BLR) THEN CALL CMUMPS_SAVE_RESTORE_BLR(id%BLRARRAY_ENCODING & ,unit,id%MYID,mode & ,SIZE_GEST_BLR,SIZE_VARIABLES_BLR & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_SCHED_SBTR) CASE(S_LPOOL_A_L0_OMP) CALL MUMPS_SAVE_INT(id%LPOOL_A_L0_OMP) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_LPOOL_B_L0_OMP) CALL MUMPS_SAVE_INT(id%LPOOL_B_L0_OMP) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_L_PHYS_L0_OMP) CALL MUMPS_SAVE_INT(id%L_PHYS_L0_OMP) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_L_VIRT_L0_OMP) CALL MUMPS_SAVE_INT(id%L_VIRT_L0_OMP) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_LL0_OMP_MAPPING) CALL MUMPS_SAVE_INT(id%LL0_OMP_MAPPING) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_LL0_OMP_FACTORS) CALL MUMPS_SAVE_INT(id%LL0_OMP_FACTORS) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_THREAD_LA) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%THREAD_LA if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%THREAD_LA if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_IPOOL_A_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%IPOOL_A_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%IPOOL_A_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%IPOOL_A_L0_OMP)) THEN write(unit,iostat=err) size(id%IPOOL_A_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IPOOL_A_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%IPOOL_A_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%IPOOL_A_L0_OMP(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IPOOL_A_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_IPOOL_B_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%IPOOL_B_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%IPOOL_B_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%IPOOL_B_L0_OMP)) THEN write(unit,iostat=err) size(id%IPOOL_B_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IPOOL_B_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%IPOOL_B_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%IPOOL_B_L0_OMP(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IPOOL_B_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PHYS_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PHYS_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%PHYS_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PHYS_L0_OMP)) THEN write(unit,iostat=err) size(id%PHYS_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PHYS_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PHYS_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PHYS_L0_OMP(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PHYS_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_VIRT_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%VIRT_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%VIRT_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%VIRT_L0_OMP)) THEN write(unit,iostat=err) size(id%VIRT_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%VIRT_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%VIRT_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%VIRT_L0_OMP(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%VIRT_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_VIRT_L0_OMP_MAPPING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%VIRT_L0_OMP_MAPPING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%VIRT_L0_OMP_MAPPING,1) & *SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%VIRT_L0_OMP_MAPPING)) THEN write(unit,iostat=err) size(id%VIRT_L0_OMP_MAPPING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%VIRT_L0_OMP_MAPPING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%VIRT_L0_OMP_MAPPING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%VIRT_L0_OMP_MAPPING(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%VIRT_L0_OMP_MAPPING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PERM_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PERM_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PERM_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PERM_L0_OMP)) THEN write(unit,iostat=err) size(id%PERM_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PERM_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PERM_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PERM_L0_OMP(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PERM_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTR_LEAFS_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTR_LEAFS_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%PTR_LEAFS_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTR_LEAFS_L0_OMP)) THEN write(unit,iostat=err) size(id%PTR_LEAFS_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTR_LEAFS_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PTR_LEAFS_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PTR_LEAFS_L0_OMP(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTR_LEAFS_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_L0_OMP_MAPPING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%L0_OMP_MAPPING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%L0_OMP_MAPPING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%L0_OMP_MAPPING)) THEN write(unit,iostat=err) size(id%L0_OMP_MAPPING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%L0_OMP_MAPPING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%L0_OMP_MAPPING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%L0_OMP_MAPPING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%L0_OMP_MAPPING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SINGULAR_VALUES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%SINGULAR_VALUES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%SINGULAR_VALUES,1)*SIZE_RL_OR_DBL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%SINGULAR_VALUES)) THEN write(unit,iostat=err) size(id%SINGULAR_VALUES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(size_written,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%SINGULAR_VALUES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(size_written,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(size_written,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%SINGULAR_VALUES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_RL_OR_DBL allocate(id%SINGULAR_VALUES(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%SINGULAR_VALUES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NB_SINGULAR_VALUES) CALL MUMPS_SAVE_INT(id%NB_SINGULAR_VALUES) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_ASSOCIATED_OOC_FILES) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL endif CASE(S_SAVE_DIR) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%SAVE_DIR)*SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%SAVE_DIR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%SAVE_DIR)*SIZE_CHARACTER read(unit,iostat=err) id%SAVE_DIR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SAVE_PREFIX) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%SAVE_PREFIX)*SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%SAVE_PREFIX if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%SAVE_PREFIX)*SIZE_CHARACTER read(unit,iostat=err) id%SAVE_PREFIX if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MTKO_PROCS_MAP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MTKO_PROCS_MAP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%MTKO_PROCS_MAP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MTKO_PROCS_MAP)) THEN write(unit,iostat=err) size(id%MTKO_PROCS_MAP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MTKO_PROCS_MAP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MTKO_PROCS_MAP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MTKO_PROCS_MAP(0:size_array1-1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MTKO_PROCS_MAP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_METIS_OPTIONS) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%METIS_OPTIONS,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%METIS_OPTIONS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%METIS_OPTIONS,1) read(unit,iostat=err) id%METIS_OPTIONS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_pad1,S_pad2,S_pad3,S_pad4,S_pad5,S_pad6,S_pad7, & S_pad11,S_pad12,S_pad13,S_pad14,S_pad16) CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords(i1)=NbRecords(i1)+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES(i1) & +int(SIZE_GEST(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*NbRecords(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES(i1)+ & DIFF_SIZE_ALLOC_READ(i1) size_read=size_read+SIZE_VARIABLES(i1) & +int(SIZE_GEST(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*id%KEEP(34)*NbRecords(i1),kind=8) #endif elseif(mode.EQ.fake_restore_mode) then endif ENDDO 200 continue if(mode.EQ.memory_save_mode) then WRITTEN_STRUC_SIZE=sum(SIZE_VARIABLES)+ & sum(SIZE_VARIABLES_ROOTC)+ & SIZE_VARIABLES_BLR+SIZE_VARIABLES_FRONT_DATA+ & SIZE_VARIABLES_L0FAC+ & SIZE_VARIABLES_ROOTA TOTAL_STRUC_SIZE=WRITTEN_STRUC_SIZE & +sum(DIFF_SIZE_ALLOC_READ) & +sum(DIFF_SIZE_ALLOC_READ_ROOTC) gest_size=sum(SIZE_GEST)+sum(SIZE_GEST_ROOTC) & +SIZE_GEST_BLR+SIZE_GEST_FRONT_DATA & +SIZE_GEST_L0FAC & +SIZE_GEST_ROOTA & +int(5*SIZE_CHARACTER,kind=8) & +int(23*SIZE_CHARACTER,kind=8) & +int(2*SIZE_INT8,kind=8)+int(1,kind=8) & +int(3*SIZE_INT,kind=8) & +int(SIZE_LOGICAL,kind=8) IF(associated(id%OOC_FILE_NAME_LENGTH).AND. & associated(id%OOC_FILE_NAMES)) THEN gest_size=gest_size+int(SIZE_INT,kind=8) & +int(id%OOC_FILE_NAME_LENGTH(1)*SIZE_CHARACTER,kind=8) ELSE gest_size=gest_size+int(2*SIZE_INT,kind=8) ENDIF #if defined(MUMPS_NOF2003) tot_NbRecords=sum(NbRecords)+sum(NbRecords_ROOTC)+8 gest_size=gest_size+int(2*id%KEEP(34)*tot_NbRecords,kind=8) #endif TOTAL_FILE_SIZE=WRITTEN_STRUC_SIZE+gest_size elseif(mode.EQ.save_mode) then elseif(mode.EQ.restore_mode) then #if ! defined(NOSCALAPACK) if(idintr%root%gridinit_done) then idintr%root%CNTXT_BLACS = id%COMM_NODES CALL blacs_gridinit( idintr%root%CNTXT_BLACS, 'R', & idintr%root%NPROW, idintr%root%NPCOL ) idintr%root%gridinit_done = .TRUE. idintr%root%DESCRIPTOR(2) = idintr%root%CNTXT_BLACS endif #endif elseif(mode.EQ.fake_restore_mode) then elseif(mode.EQ.restore_ooc_mode) then endif 100 continue RETURN CONTAINS SUBROUTINE MUMPS_SAVERSTR_REALARRAY(idREAL) IMPLICIT NONE REAL, DIMENSION(:), POINTER :: idREAL NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(idREAL)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(idREAL,1)*SIZE_RL_OR_DBL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(idREAL)) THEN write(unit,iostat=err) size(idreal,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) idREAL ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(idREAL) read(unit,iostat=err) size_array1 if (err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if (size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_RL_OR_DBL allocate(idREAL(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) idREAL endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if (err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif 100 CONTINUE RETURN END SUBROUTINE MUMPS_SAVERSTR_REALARRAY SUBROUTINE MUMPS_SAVE_INT(idINT) IMPLICIT NONE INTEGER, INTENT(INOUT) :: idINT NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idINT if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) idINT if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif 100 CONTINUE RETURN END SUBROUTINE MUMPS_SAVE_INT SUBROUTINE CMUMPS_SAVE_INT_SHPTR_ARRAY(id_INTPTR & ) IMPLICIT NONE INTEGER, POINTER, DIMENSION(:) :: id_INTPTR NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id_INTPTR) & ) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id_INTPTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id_INTPTR) & ) THEN write(unit,iostat=err) size(id_INTPTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id_INTPTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id_INTPTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id_INTPTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) else read(unit,iostat=err) id_INTPTR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif endif endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif 100 CONTINUE RETURN END SUBROUTINE CMUMPS_SAVE_INT_SHPTR_ARRAY END SUBROUTINE CMUMPS_SAVE_RESTORE_STRUCTURE SUBROUTINE CMUMPS_SAVE_RESTORE_ROOTA( & roota & ,unit,MYID,mode & ,SIZE_GEST_ROOTA,SIZE_VARIABLES_ROOTA & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,SIZE_RL_OR_DBL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST_ROOTA INTEGER(8),intent(OUT) :: SIZE_VARIABLES_ROOTA INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER,intent(IN):: SIZE_RL_OR_DBL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: SIZE_GEST, i3 INTEGER(8) :: SIZE_VARIABLE INTEGER, PARAMETER :: NBVARIABLES_ROOTA=7 INTEGER, PARAMETER :: RA_SINGULAR_VALUES=7 INTEGER, PARAMETER :: RA_SVD_VT=6 INTEGER, PARAMETER :: RA_SVD_U=5 INTEGER, PARAMETER :: RA_RHS_ROOT=4 INTEGER, PARAMETER :: RA_QR_TAU=3 INTEGER, PARAMETER :: RA_SCHUR_POINTER=2 INTEGER, PARAMETER :: RA_RHS_CNTR_MASTER_ROOT=1 SIZE_GEST_ROOTA = 0 SIZE_VARIABLES_ROOTA = 0_8 DO i3 = 1, NBVARIABLES_ROOTA SIZE_GEST = 0 SIZE_VARIABLE = 0_8 SELECT CASE(i3) CASE(RA_QR_TAU) CALL CMUMPS_SAVE_RESTORE_ARRAY_C1D( & roota%QR_TAU ) CASE(RA_SVD_U) CALL CMUMPS_SAVE_RESTORE_ARRAY_2D(roota%SVD_U) CASE(RA_SVD_VT) CASE(RA_SINGULAR_VALUES) CALL CMUMPS_SAVE_RESTORE_ARRAY_R1D( & roota%SINGULAR_VALUES) CASE(RA_RHS_CNTR_MASTER_ROOT) CALL CMUMPS_SAVE_RESTORE_ARRAY_C1D( & roota%RHS_CNTR_MASTER_ROOT) CASE(RA_RHS_ROOT) CASE(RA_SCHUR_POINTER) CASE DEFAULT END SELECT IF ( INFO(1) .LT. 0 ) GOTO 100 IF (mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTA = SIZE_VARIABLES_ROOTA + & SIZE_VARIABLE SIZE_GEST_ROOTA = SIZE_GEST_ROOTA + SIZE_GEST ENDIF END DO 100 CONTINUE RETURN CONTAINS SUBROUTINE CMUMPS_SAVE_RESTORE_ARRAY_2D(PTRARRAY2D) IMPLICIT NONE COMPLEX, DIMENSION(:,:), POINTER :: PTRARRAY2D INTEGER :: LocalNbRecords, err, allocok, dummy INTEGER :: size_array1, size_array2 INTEGER(8) :: sz LocalNbRecords = 2 if(mode.EQ.memory_save_mode) then IF(associated(PTRARRAY2D)) THEN SIZE_GEST = SIZE_INT*2 SIZE_VARIABLE = size(PTRARRAY2D,1) & *size(PTRARRAY2D,2)*SIZE_ARITH_DEP ELSE SIZE_GEST = SIZE_INT*3 SIZE_VARIABLE = 0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(PTRARRAY2D)) THEN write(unit,iostat=err) size(PTRARRAY2D,1) & ,size(PTRARRAY2D,2) ELSE write(unit,iostat=err) -999,-998 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+2*SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 IF(associated(PTRARRAY2D)) THEN write(unit,iostat=err) PTRARRAY2D sz= int(size(PTRARRAY2D,1),8) * & int(size(PTRARRAY2D,2),8) * & SIZE_ARITH_DEP ELSE write(unit,iostat=err) -999 sz=SIZE_INT ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(PTRARRAY2D) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) else size_read = size_read+2*SIZE_INT size_allocated = size_allocated + 2*SIZE_INT8 endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then read(unit,iostat=err) dummy sz = SIZE_INT else sz = int(size_array1,8)*int(size_array2,8) & * SIZE_ARITH_DEP allocate(PTRARRAY2D(size_array1, & size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) PTRARRAY2D endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & , INFO(2)) else size_read = size_read + sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif #if defined(MUMPS_NOF2003) IF (mode.EQ.memory_save_mode) THEN SIZE_GEST = SIZE_GEST+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.save_mode) THEN size_written = size_written+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.restore_mode) THEN size_read = size_read+2*SIZE_INT*LocalNbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_ARRAY_2D SUBROUTINE CMUMPS_SAVE_RESTORE_ARRAY_C1D(PTRARRAY1D) IMPLICIT NONE COMPLEX, DIMENSION(:), POINTER :: PTRARRAY1D INTEGER :: LocalNbRecords, err, allocok, dummy INTEGER :: size_array1 INTEGER(8) :: sz LocalNbRecords = 2 if(mode.EQ.memory_save_mode) then IF(associated(PTRARRAY1D)) THEN SIZE_GEST = SIZE_INT SIZE_VARIABLE = size(PTRARRAY1D)*SIZE_ARITH_DEP ELSE SIZE_GEST = SIZE_INT*2 SIZE_VARIABLE = 0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(PTRARRAY1D)) THEN write(unit,iostat=err) size(PTRARRAY1D) ELSE write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 IF(associated(PTRARRAY1D)) THEN write(unit,iostat=err) PTRARRAY1D sz= int(size(PTRARRAY1D),8)* & SIZE_ARITH_DEP ELSE write(unit,iostat=err) -999 sz=SIZE_INT ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(PTRARRAY1D) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) else size_read = size_read+SIZE_INT size_allocated = size_allocated + SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then read(unit,iostat=err) dummy sz = SIZE_INT else sz = int(size_array1,8) * SIZE_ARITH_DEP allocate(PTRARRAY1D(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) PTRARRAY1D endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & , INFO(2)) else size_read = size_read + sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif #if defined(MUMPS_NOF2003) IF (mode.EQ.memory_save_mode) THEN SIZE_GEST = SIZE_GEST+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.save_mode) THEN size_written = size_written+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.restore_mode) THEN size_read = size_read+2*SIZE_INT*LocalNbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_ARRAY_C1D SUBROUTINE CMUMPS_SAVE_RESTORE_ARRAY_R1D(PTRARRAY1D) IMPLICIT NONE REAL, DIMENSION(:), POINTER :: PTRARRAY1D INTEGER :: LocalNbRecords, err, allocok, dummy INTEGER :: size_array1 INTEGER(8) :: sz LocalNbRecords = 2 if(mode.EQ.memory_save_mode) then IF(associated(PTRARRAY1D)) THEN SIZE_GEST = SIZE_INT SIZE_VARIABLE = size(PTRARRAY1D)*SIZE_RL_OR_DBL ELSE SIZE_GEST = SIZE_INT*2 SIZE_VARIABLE = 0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(PTRARRAY1D)) THEN write(unit,iostat=err) size(PTRARRAY1D) ELSE write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 IF(associated(PTRARRAY1D)) THEN write(unit,iostat=err) PTRARRAY1D sz= int(size(PTRARRAY1D),8)* & SIZE_RL_OR_DBL ELSE write(unit,iostat=err) -999 sz=SIZE_INT ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(PTRARRAY1D) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) else size_read = size_read+SIZE_INT size_allocated = size_allocated + SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then read(unit,iostat=err) dummy sz = SIZE_INT else sz = int(size_array1,8) * SIZE_RL_OR_DBL allocate(PTRARRAY1D(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) PTRARRAY1D endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & , INFO(2)) else size_read = size_read + sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif #if defined(MUMPS_NOF2003) IF (mode.EQ.memory_save_mode) THEN SIZE_GEST = SIZE_GEST+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.save_mode) THEN size_written = size_written+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.restore_mode) THEN size_read = size_read+2*SIZE_INT*LocalNbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_ARRAY_R1D END SUBROUTINE CMUMPS_SAVE_RESTORE_ROOTA END MODULE CMUMPS_SAVE_RESTORE #else SUBROUTINE CMUMPS_SAVE_RESTORE_RETURN() RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_RETURN #endif MUMPS_5.8.1/src/dsol_matvec.F0000664000175000017500000002411615042446441015644 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_MV_ELT( N, NELT, ELTPTR, ELTVAR, A_ELT, & X, Y, K50, MTYPE ) IMPLICIT NONE C C Purpose C ======= C C To perform the matrix vector product C A_ELT X = Y if MTYPE = 1 C A_ELT^T X = Y if MTYPE = 0 C C If K50 is different from 0, then the elements are C supposed to be in symmetric packed storage; the C lower part is stored by columns. C Otherwise, the element is square, stored by columns. C C Note C ==== C C A_ELT is processed entry by entry and this code is not C optimized. In particular, one could gather/scatter C X / Y for each element to improve performance. C C Arguments C ========= C INTEGER N, NELT, K50, MTYPE INTEGER ELTPTR( NELT + 1 ), ELTVAR( * ) DOUBLE PRECISION A_ELT( * ), X( N ), Y( N ) C C Local variables C =============== C INTEGER IEL, I , J, SIZEI, IELPTR INTEGER(8) :: K8 DOUBLE PRECISION TEMP DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) C C C Executable statements C ===================== C Y = ZERO K8 = 1_8 C -------------------- C Process the elements C -------------------- DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( K50 .eq. 0 ) THEN C ------------------- C Unsymmetric element C stored by columns C ------------------- IF ( MTYPE .eq. 1 ) THEN C ----------------- C Compute A_ELT x X C ----------------- DO J = 1, SIZEI TEMP = X( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) + & A_ELT( K8 ) * TEMP K8 = K8 + 1 END DO END DO ELSE C ------------------- C Compute A_ELT^T x X C ------------------- DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + & A_ELT( K8 ) * X( ELTVAR( IELPTR + I ) ) K8 = K8 + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP END DO END IF ELSE C ----------------- C Symmetric element C L stored by cols C ----------------- DO J = 1, SIZEI C Diagonal counted once Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + J ) ) K8 = K8 + 1 DO I = J+1, SIZEI C Off diagonal + transpose Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + J ) ) Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + I ) ) K8 = K8 + 1 END DO END DO END IF END DO RETURN END SUBROUTINE DMUMPS_MV_ELT SUBROUTINE DMUMPS_LOC_MV8 &( N, NZ_loc8, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE C C Purpose: C ======= C C Perform a distributed matrix vector product. C Y_loc <- A X if MTYPE = 1 C Y_loc <- A^T X if MTYPE = 0 C C Notes: C ===== C C 1) assembly of all Y_loc still has to be done on exit. C 2) X should be available on all processors. C C Arguments: C ========= C INTEGER N INTEGER(8) :: NZ_loc8 INTEGER IRN_loc( NZ_loc8 ), JCN_loc( NZ_loc8 ) DOUBLE PRECISION A_loc( NZ_loc8 ), X( N ), Y_loc( N ) INTEGER LDLT, MTYPE C C Locals variables: C ================ C INTEGER I, J INTEGER(8) :: K8 DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) Y_loc = ZERO IF ( LDLT .eq. 0 ) THEN C Unsymmetric IF ( MTYPE .eq. 1 ) THEN C No transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + A_loc(K8) * X(J) ENDDO ELSE C Transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) & .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(J) = Y_loc(J) + A_loc(K8) * X(I) ENDDO END IF ELSE C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + A_loc(K8) * X(J) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + A_loc(K8) * X(I) ENDIF ENDDO END IF RETURN END SUBROUTINE DMUMPS_LOC_MV8 SUBROUTINE DMUMPS_MV8( N, NZ8, IRN, ICN, ASPK, X, Y, & LDLT, MTYPE, MAXTRANS, PERM, & IFLAG, IERROR ) C C Purpose: C ======= C C Perform matrix-vector product C Y <- A X if MTYPE = 1 C Y <- A^T X if MTYPE = 0 C C C Note: C ==== C C MAXTRANS should be set to 1 if a column permutation C was applied on A and we still want the matrix vector C product wrt the original matrix. C C Arguments: C ========= C INTEGER N, LDLT, MTYPE, MAXTRANS INTEGER(8) :: NZ8 INTEGER IRN( NZ8 ), ICN( NZ8 ) INTEGER PERM( N ) DOUBLE PRECISION ASPK( NZ8 ), X( N ), Y( N ) INTEGER, intent(inout) :: IFLAG, IERROR C C Local variables C =============== C INTEGER I, J INTEGER(8) :: K8 DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: PX DOUBLE PRECISION ZERO INTEGER :: allocok PARAMETER( ZERO = 0.0D0 ) Y = ZERO ALLOCATE(PX(N), stat=allocok) IF (allocok < 0) THEN IFLAG = -13 IERROR = N RETURN ENDIF C C -------------------------------------- C Permute X if A has been permuted C with some max-trans column permutation C -------------------------------------- IF ( MAXTRANS .eq. 1 .and. MTYPE .eq. 1) THEN DO I = 1, N PX(I) = X( PERM( I ) ) END DO ELSE PX = X END IF IF ( LDLT .eq. 0 ) THEN C C Complete unsymmetric matrix was provided (LU facto) IF (MTYPE .EQ. 1) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K8) * PX(J) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(J) = Y(J) + ASPK(K8) * PX(I) ENDDO ENDIF C ELSE C C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K8) * PX(J) IF (J.NE.I) THEN Y(J) = Y(J) + ASPK(K8) * PX(I) ENDIF ENDDO END IF IF ( MAXTRANS .EQ. 1 .AND. MTYPE .eq. 0 ) THEN PX = Y DO I = 1, N Y( PERM( I ) ) = PX( I ) END DO END IF DEALLOCATE(PX) RETURN END SUBROUTINE DMUMPS_MV8 C C SUBROUTINE DMUMPS_LOC_OMEGA1 &( N, NZ_loc8, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE C C Purpose: C ======= C Compute C * If MTYPE = 1 C Y_loc(i) = Sum | Aij | | Xj | C j C * If MTYPE = 0 C Y_loc(j) = Sum | Aij | | Xi | C C C Notes: C ===== C C 1) assembly of all Y_loc still has to be done. C 2) X should be available on all processors. C C Arguments: C ========= C INTEGER N INTEGER(8) :: NZ_loc8 INTEGER IRN_loc( NZ_loc8 ), JCN_loc( NZ_loc8 ) DOUBLE PRECISION A_loc( NZ_loc8 ), X( N ) DOUBLE PRECISION Y_loc( N ) INTEGER LDLT, MTYPE C C Local variables: C =============== C INTEGER I, J INTEGER(8) :: K8 DOUBLE PRECISION, PARAMETER :: RZERO=0.0D0 C Y_loc = RZERO IF ( LDLT .eq. 0 ) THEN C Unsymmetric IF ( MTYPE .eq. 1 ) THEN C No transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + abs( A_loc(K8) * X(J) ) ENDDO ELSE C Transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) & .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(J) = Y_loc(J) + abs( A_loc(K8) * X(I) ) ENDDO END IF ELSE C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + abs( A_loc(K8) * X(J) ) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + abs( A_loc(K8) * X(I) ) ENDIF ENDDO END IF RETURN END SUBROUTINE DMUMPS_LOC_OMEGA1 MUMPS_5.8.1/src/smumps_ooc_buffer.F0000664000175000017500000004327315042446437017073 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_OOC_BUFFER USE MUMPS_OOC_COMMON IMPLICIT NONE PUBLIC INTEGER FIRST_HBUF,SECOND_HBUF PARAMETER (FIRST_HBUF=0, SECOND_HBUF=1) INTEGER,SAVE :: OOC_FCT_TYPE_LOC REAL, DIMENSION(:),ALLOCATABLE :: BUF_IO LOGICAL,SAVE :: PANEL_FLAG INTEGER,SAVE :: EARLIEST_WRITE_MIN_SIZE INTEGER(8),SAVE,DIMENSION(:), ALLOCATABLE :: & I_SHIFT_FIRST_HBUF, I_SHIFT_SECOND_HBUF, & I_SHIFT_CUR_HBUF, I_REL_POS_CUR_HBUF INTEGER, SAVE, DIMENSION(:), ALLOCATABLE :: & LAST_IOREQUEST, CUR_HBUF INTEGER, DIMENSION(:),ALLOCATABLE :: I_CUR_HBUF_NEXTPOS INTEGER,SAVE :: I_CUR_HBUF_FSTPOS, & I_SUB_HBUF_FSTPOS INTEGER(8) :: BufferEmpty PARAMETER (BufferEmpty=-1_8) INTEGER(8), DIMENSION(:),ALLOCATABLE :: NextAddVirtBuffer INTEGER(8), DIMENSION(:),ALLOCATABLE :: FIRST_VADDR_IN_BUF CONTAINS SUBROUTINE SMUMPS_OOC_NEXT_HBUF(TYPEF_ARG) IMPLICIT NONE INTEGER TYPEF_ARG SELECT CASE(CUR_HBUF(TYPEF_ARG)) CASE (FIRST_HBUF) CUR_HBUF(TYPEF_ARG) = SECOND_HBUF I_SHIFT_CUR_HBUF(TYPEF_ARG) = & I_SHIFT_SECOND_HBUF(TYPEF_ARG) CASE (SECOND_HBUF) CUR_HBUF(TYPEF_ARG) = FIRST_HBUF I_SHIFT_CUR_HBUF(TYPEF_ARG) = & I_SHIFT_FIRST_HBUF(TYPEF_ARG) END SELECT IF(.NOT.PANEL_FLAG)THEN I_SUB_HBUF_FSTPOS =I_CUR_HBUF_FSTPOS I_CUR_HBUF_FSTPOS =I_CUR_HBUF_NEXTPOS(TYPEF_ARG) ENDIF I_REL_POS_CUR_HBUF(TYPEF_ARG) = 1_8 RETURN END SUBROUTINE SMUMPS_OOC_NEXT_HBUF SUBROUTINE SMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_ARG,IERR) IMPLICIT NONE INTEGER TYPEF_ARG INTEGER NEW_IOREQUEST INTEGER IERR IERR=0 CALL SMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF_ARG,NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL MUMPS_WAIT_REQUEST(LAST_IOREQUEST(TYPEF_ARG),IERR) IF(IERR.LT.0)THEN IF (ICNTL1>0) & WRITE(ICNTL1,*) MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF LAST_IOREQUEST(TYPEF_ARG) = NEW_IOREQUEST CALL SMUMPS_OOC_NEXT_HBUF(TYPEF_ARG) IF(PANEL_FLAG)THEN NextAddVirtBuffer(TYPEF_ARG)=BufferEmpty ENDIF RETURN END SUBROUTINE SMUMPS_OOC_DO_IO_AND_CHBUF SUBROUTINE SMUMPS_OOC_BUF_CLEAN_PENDING(IERR) IMPLICIT NONE INTEGER, intent(out) :: IERR INTEGER TYPEF_LAST INTEGER TYPEF_LOC IERR = 0 TYPEF_LAST = OOC_NB_FILE_TYPE DO TYPEF_LOC = 1, TYPEF_LAST IERR=0 CALL SMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL SMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_OOC_BUF_CLEAN_PENDING SUBROUTINE SMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF_ARG,IOREQUEST, & IERR) IMPLICIT NONE INTEGER IOREQUEST,IERR INTEGER TYPEF_ARG INTEGER FIRST_INODE INTEGER(8) :: FROM_BUFIO_POS, SIZE INTEGER TYPE INTEGER ADDR_INT1,ADDR_INT2 INTEGER(8) TMP_VADDR INTEGER SIZE_INT1,SIZE_INT2 IERR=0 IF (I_REL_POS_CUR_HBUF(TYPEF_ARG) == 1_8) THEN IOREQUEST=-1 RETURN END IF IF(PANEL_FLAG)THEN TYPE=TYPEF_ARG-1 FIRST_INODE=-9999 TMP_VADDR=FIRST_VADDR_IN_BUF(TYPEF_ARG) ELSE TYPE=FCT FIRST_INODE = & OOC_INODE_SEQUENCE(I_CUR_HBUF_FSTPOS,TYPEF_ARG) TMP_VADDR=OOC_VADDR(STEP_OOC(FIRST_INODE),TYPEF_ARG) ENDIF FROM_BUFIO_POS=I_SHIFT_CUR_HBUF(TYPEF_ARG)+1_8 SIZE = I_REL_POS_CUR_HBUF(TYPEF_ARG)-1_8 CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & TMP_VADDR) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & BUF_IO(FROM_BUFIO_POS),SIZE_INT1,SIZE_INT2, & FIRST_INODE,IOREQUEST, & TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1>0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF RETURN END SUBROUTINE SMUMPS_OOC_WRT_CUR_BUF2DISK SUBROUTINE SMUMPS_INIT_OOC_BUF(I1,I2,IERR) IMPLICIT NONE INTEGER I1,I2,IERR INTEGER allocok IERR=0 PANEL_FLAG=.FALSE. IF(allocated(I_SHIFT_FIRST_HBUF))THEN DEALLOCATE(I_SHIFT_FIRST_HBUF) ENDIF IF(allocated(I_SHIFT_SECOND_HBUF))THEN DEALLOCATE(I_SHIFT_SECOND_HBUF) ENDIF IF(allocated(I_SHIFT_CUR_HBUF))THEN DEALLOCATE(I_SHIFT_CUR_HBUF) ENDIF IF(allocated(I_REL_POS_CUR_HBUF))THEN DEALLOCATE(I_REL_POS_CUR_HBUF) ENDIF IF(allocated(LAST_IOREQUEST))THEN DEALLOCATE(LAST_IOREQUEST) ENDIF IF(allocated(CUR_HBUF))THEN DEALLOCATE(CUR_HBUF) ENDIF DIM_BUF_IO = int(KEEP_OOC(100),8) ALLOCATE(I_SHIFT_FIRST_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_SHIFT_SECOND_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_SHIFT_CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_REL_POS_CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(LAST_IOREQUEST(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF OOC_FCT_TYPE_LOC=OOC_NB_FILE_TYPE ALLOCATE(BUF_IO(DIM_BUF_IO), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF I1 = -13 CALL MUMPS_SET_IERROR(DIM_BUF_IO, I2) RETURN ENDIF PANEL_FLAG=(KEEP_OOC(201).EQ.1) IF (PANEL_FLAG) THEN IERR=0 KEEP_OOC(228)=0 IF(allocated(AddVirtLibre))THEN DEALLOCATE(AddVirtLibre) ENDIF ALLOCATE(AddVirtLibre(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'SMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF AddVirtLibre(1:OOC_NB_FILE_TYPE)=0_8 IF(allocated(NextAddVirtBuffer))THEN DEALLOCATE(NextAddVirtBuffer) ENDIF ALLOCATE(NextAddVirtBuffer(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'SMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF NextAddVirtBuffer (1:OOC_NB_FILE_TYPE) = BufferEmpty IF(allocated(FIRST_VADDR_IN_BUF))THEN DEALLOCATE(FIRST_VADDR_IN_BUF) ENDIF ALLOCATE(FIRST_VADDR_IN_BUF(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'SMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF CALL SMUMPS_OOC_INIT_DB_BUFFER_PANEL() ELSE CALL SMUMPS_OOC_INIT_DB_BUFFER() ENDIF KEEP_OOC(223)=int(HBUF_SIZE) RETURN END SUBROUTINE SMUMPS_INIT_OOC_BUF SUBROUTINE SMUMPS_END_OOC_BUF() IMPLICIT NONE IF(allocated(BUF_IO))THEN DEALLOCATE(BUF_IO) ENDIF IF(allocated(I_SHIFT_FIRST_HBUF))THEN DEALLOCATE(I_SHIFT_FIRST_HBUF) ENDIF IF(allocated(I_SHIFT_SECOND_HBUF))THEN DEALLOCATE(I_SHIFT_SECOND_HBUF) ENDIF IF(allocated(I_SHIFT_CUR_HBUF))THEN DEALLOCATE(I_SHIFT_CUR_HBUF) ENDIF IF(allocated(I_REL_POS_CUR_HBUF))THEN DEALLOCATE(I_REL_POS_CUR_HBUF) ENDIF IF(allocated(LAST_IOREQUEST))THEN DEALLOCATE(LAST_IOREQUEST) ENDIF IF(allocated(CUR_HBUF))THEN DEALLOCATE(CUR_HBUF) ENDIF IF(PANEL_FLAG)THEN IF(allocated(NextAddVirtBuffer))THEN DEALLOCATE(NextAddVirtBuffer) ENDIF IF(allocated(AddVirtLibre))THEN DEALLOCATE(AddVirtLibre) ENDIF IF(allocated(FIRST_VADDR_IN_BUF))THEN DEALLOCATE(FIRST_VADDR_IN_BUF) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_END_OOC_BUF SUBROUTINE SMUMPS_OOC_INIT_DB_BUFFER() IMPLICIT NONE OOC_FCT_TYPE_LOC=1 HBUF_SIZE = DIM_BUF_IO / int(2,kind=kind(DIM_BUF_IO)) EARLIEST_WRITE_MIN_SIZE = 0 I_SHIFT_FIRST_HBUF(OOC_FCT_TYPE_LOC) = 0_8 I_SHIFT_SECOND_HBUF(OOC_FCT_TYPE_LOC) = HBUF_SIZE LAST_IOREQUEST(OOC_FCT_TYPE_LOC) = -1 I_CUR_HBUF_NEXTPOS = 1 I_CUR_HBUF_FSTPOS = 1 I_SUB_HBUF_FSTPOS = 1 CUR_HBUF(OOC_FCT_TYPE_LOC) = SECOND_HBUF CALL SMUMPS_OOC_NEXT_HBUF(OOC_FCT_TYPE_LOC) END SUBROUTINE SMUMPS_OOC_INIT_DB_BUFFER SUBROUTINE SMUMPS_OOC_COPY_DATA_TO_BUFFER(BLOCK,SIZE_OF_BLOCK, & IERR) IMPLICIT NONE INTEGER(8) :: SIZE_OF_BLOCK REAL BLOCK(SIZE_OF_BLOCK) INTEGER, intent(out) :: IERR INTEGER(8) :: I IERR=0 IF (I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + & SIZE_OF_BLOCK <= HBUF_SIZE + 1_8) THEN ELSE CALL SMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF DO I = 1_8, SIZE_OF_BLOCK BUF_IO(I_SHIFT_CUR_HBUF(OOC_FCT_TYPE_LOC) + & I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + I - 1_8) = & BLOCK(I) END DO I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) = & I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + SIZE_OF_BLOCK RETURN END SUBROUTINE SMUMPS_OOC_COPY_DATA_TO_BUFFER SUBROUTINE SMUMPS_OOC_INIT_DB_BUFFER_PANEL() IMPLICIT NONE INTEGER(8) :: DIM_BUF_IO_L_OR_U INTEGER TYPEF, TYPEF_LAST INTEGER NB_DOUBLE_BUFFERS TYPEF_LAST = OOC_NB_FILE_TYPE NB_DOUBLE_BUFFERS = OOC_NB_FILE_TYPE DIM_BUF_IO_L_OR_U = DIM_BUF_IO / & int(NB_DOUBLE_BUFFERS,kind=kind(DIM_BUF_IO_L_OR_U)) IF(.NOT.STRAT_IO_ASYNC)THEN HBUF_SIZE = DIM_BUF_IO_L_OR_U ELSE HBUF_SIZE = DIM_BUF_IO_L_OR_U / 2_8 ENDIF DO TYPEF = 1, TYPEF_LAST LAST_IOREQUEST(TYPEF) = -1 IF (TYPEF == 1 ) THEN I_SHIFT_FIRST_HBUF(TYPEF) = 0_8 ELSE I_SHIFT_FIRST_HBUF(TYPEF) = DIM_BUF_IO_L_OR_U ENDIF IF(.NOT.STRAT_IO_ASYNC)THEN I_SHIFT_SECOND_HBUF(TYPEF) = I_SHIFT_FIRST_HBUF(TYPEF) ELSE I_SHIFT_SECOND_HBUF(TYPEF) = I_SHIFT_FIRST_HBUF(TYPEF) + & HBUF_SIZE ENDIF CUR_HBUF(TYPEF) = SECOND_HBUF CALL SMUMPS_OOC_NEXT_HBUF(TYPEF) ENDDO I_CUR_HBUF_NEXTPOS = 1 RETURN END SUBROUTINE SMUMPS_OOC_INIT_DB_BUFFER_PANEL SUBROUTINE SMUMPS_OOC_TRYIO_CHBUF_PANEL(TYPEF,IERR) IMPLICIT NONE INTEGER, INTENT(in) :: TYPEF INTEGER, INTENT(out) :: IERR INTEGER IFLAG INTEGER NEW_IOREQUEST IERR=0 CALL MUMPS_TEST_REQUEST_C(LAST_IOREQUEST(TYPEF),IFLAG, & IERR) IF (IFLAG.EQ.1) THEN IERR = 0 CALL SMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF, & NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF LAST_IOREQUEST(TYPEF) = NEW_IOREQUEST CALL SMUMPS_OOC_NEXT_HBUF(TYPEF) NextAddVirtBuffer(TYPEF)=BufferEmpty RETURN ELSE IF(IFLAG.LT.0)THEN WRITE(*,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ELSE IERR = 1 RETURN ENDIF END SUBROUTINE SMUMPS_OOC_TRYIO_CHBUF_PANEL SUBROUTINE SMUMPS_OOC_UPD_VADDR_CUR_BUF (TYPEF,VADDR) IMPLICIT NONE INTEGER(8), INTENT(in) :: VADDR INTEGER, INTENT(in) :: TYPEF IF(I_REL_POS_CUR_HBUF(TYPEF).EQ.1_8)THEN FIRST_VADDR_IN_BUF(TYPEF)=VADDR ENDIF RETURN END SUBROUTINE SMUMPS_OOC_UPD_VADDR_CUR_BUF SUBROUTINE SMUMPS_COPY_LU_TO_BUFFER( STRAT, TYPEF, MonBloc, & AFAC, LAFAC, & AddVirtCour, IPIVBEG, IPIVEND, LPANELeff, & IERR) IMPLICIT NONE INTEGER, INTENT(IN) :: TYPEF, IPIVBEG, IPIVEND, STRAT INTEGER(8), INTENT(IN) :: LAFAC REAL, INTENT(IN) :: AFAC(LAFAC) INTEGER(8), INTENT(IN) :: AddVirtCour TYPE(IO_BLOCK), INTENT(IN) :: MonBloc INTEGER, INTENT(OUT):: LPANELeff INTEGER, INTENT(OUT):: IERR INTEGER :: II, NBPIVeff INTEGER(8) :: IPOS, IDIAG, IDEST INTEGER(8) :: DeltaIPOS INTEGER :: StrideIPOS IERR=0 IF (STRAT.NE.STRAT_WRITE_MAX.AND.STRAT.NE.STRAT_TRY_WRITE) THEN write(6,*) ' SMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented ' CALL MUMPS_ABORT() ENDIF NBPIVeff = IPIVEND - IPIVBEG + 1 IF (MonBloc%MASTER .AND. MonBloc%Typenode .NE. 3) THEN IF (TYPEF.EQ.TYPEF_L) THEN LPANELeff = (MonBloc%NROW-IPIVBEG+1)*NBPIVeff ELSE LPANELeff = (MonBloc%NCOL-IPIVBEG+1)*NBPIVeff ENDIF ELSE LPANELeff = MonBloc%NROW*NBPIVeff ENDIF IF ( ( I_REL_POS_CUR_HBUF(TYPEF) + int(LPANELeff - 1,8) & > & HBUF_SIZE ) & .OR. & ( (AddVirtCour.NE.NextAddVirtBuffer(TYPEF)) .AND. & (NextAddVirtBuffer(TYPEF).NE.BufferEmpty) ) & ) THEN IF (STRAT.EQ.STRAT_WRITE_MAX) THEN CALL SMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF,IERR) ELSE IF (STRAT.EQ.STRAT_TRY_WRITE) THEN CALL SMUMPS_OOC_TRYIO_CHBUF_PANEL(TYPEF,IERR) IF (IERR.EQ.1) RETURN ELSE write(6,*) 'SMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented' ENDIF ENDIF IF (IERR < 0 ) THEN RETURN ENDIF IF (NextAddVirtBuffer(TYPEF).EQ. BufferEmpty) THEN CALL SMUMPS_OOC_UPD_VADDR_CUR_BUF (TYPEF,AddVirtCour) NextAddVirtBuffer(TYPEF) = AddVirtCour ENDIF IF (MonBloc%MASTER .AND. MonBloc%Typenode .NE. 3) THEN IDIAG = int(IPIVBEG-1,8)*int(MonBloc%NCOL,8) + int(IPIVBEG,8) IPOS = IDIAG IDEST = I_SHIFT_CUR_HBUF(TYPEF) + & I_REL_POS_CUR_HBUF(TYPEF) IF (TYPEF.EQ.TYPEF_L) THEN DO II = IPIVBEG, IPIVEND CALL scopy(MonBloc%NROW-IPIVBEG+1, & AFAC(IPOS), MonBloc%NCOL, & BUF_IO(IDEST), 1) IDEST = IDEST + int(MonBloc%NROW-IPIVBEG+1,8) IPOS = IPOS + 1_8 ENDDO ELSE DO II = IPIVBEG, IPIVEND CALL scopy(MonBloc%NCOL-IPIVBEG+1, & AFAC(IPOS), 1, & BUF_IO(IDEST), 1) IDEST = IDEST + int(MonBloc%NCOL-IPIVBEG+1,8) IPOS = IPOS + int(MonBloc%NCOL,8) ENDDO ENDIF ELSE IDEST = I_SHIFT_CUR_HBUF(TYPEF) + & I_REL_POS_CUR_HBUF(TYPEF) IF (MonBloc%Typenode.EQ.3) THEN DeltaIPOS = int(MonBloc%NROW,8) StrideIPOS = 1 ELSE DeltaIPOS = 1_8 StrideIPOS = MonBloc%NCOL ENDIF IPOS = 1_8 + int(IPIVBEG - 1,8) * DeltaIPOS DO II = IPIVBEG, IPIVEND CALL scopy(MonBloc%NROW, & AFAC(IPOS), StrideIPOS, & BUF_IO(IDEST), 1) IDEST = IDEST+int(MonBloc%NROW,8) IPOS = IPOS + DeltaIPOS ENDDO ENDIF I_REL_POS_CUR_HBUF(TYPEF) = & I_REL_POS_CUR_HBUF(TYPEF) + int(LPANELeff,8) NextAddVirtBuffer(TYPEF) = NextAddVirtBuffer(TYPEF) & + int(LPANELeff,8) RETURN END SUBROUTINE SMUMPS_COPY_LU_TO_BUFFER END MODULE SMUMPS_OOC_BUFFER MUMPS_5.8.1/src/sfac_scalings.F0000664000175000017500000002773115042446437016156 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_FAC_A(N, NZ8, NSCA, & ASPK, IRN, ICN, COLSCA, ROWSCA, WK, LWK8, WK_REAL, & LWK_REAL, ICNTL, INFO) IMPLICIT NONE INTEGER N, NSCA INTEGER(8), INTENT(IN) :: NZ8 INTEGER IRN(NZ8), ICN(NZ8) INTEGER ICNTL(60), INFO(80) REAL, INTENT(IN) :: ASPK(NZ8) REAL COLSCA(*), ROWSCA(*) INTEGER(8), INTENT(IN) :: LWK8 INTEGER(8), INTENT(IN) :: LWK_REAL REAL WK(LWK8) REAL WK_REAL(LWK_REAL) INTEGER MPG,LP INTEGER I LOGICAL PROKG REAL ONE PARAMETER( ONE = 1.0E0 ) LP = ICNTL(1) MPG = ICNTL(2) MPG = ICNTL(3) PROKG = ((MPG.GT.0).AND.(ICNTL(4).GE.2)) IF (PROKG) THEN WRITE(MPG,101) ELSE MPG = 0 ENDIF 101 FORMAT(/' ****** SCALING OF ORIGINAL MATRIX '/) IF (NSCA.EQ.1) THEN IF (PROKG) WRITE (MPG,*) ' DIAGONAL SCALING ' ELSEIF (NSCA.EQ.3) THEN IF (PROKG) & WRITE (MPG,*) ' COLUMN SCALING' ELSEIF (NSCA.EQ.4) THEN IF (PROKG) & WRITE (MPG,*) ' ROW AND COLUMN SCALING (1 Pass)' ENDIF DO 10 I=1,N COLSCA(I) = ONE ROWSCA(I) = ONE 10 CONTINUE IF (NSCA.EQ.1) THEN CALL SMUMPS_FAC_V(N,NZ8,ASPK,IRN,ICN, & COLSCA,ROWSCA,MPG) ELSEIF (NSCA.EQ.3) THEN IF ( LWK_REAL .LT. int(N,8) ) THEN GOTO 420 ENDIF CALL SMUMPS_FAC_Y(N,NZ8,ASPK,IRN,ICN,WK_REAL(1), & COLSCA, MPG) ELSEIF (NSCA.EQ.4) THEN IF ( LWK_REAL .LT. 2_8*int(N,8) ) THEN GOTO 430 ENDIF CALL SMUMPS_ROWCOL(N,NZ8,IRN,ICN,ASPK, & WK_REAL(1),WK_REAL(1+N),COLSCA,ROWSCA,MPG) ENDIF GOTO 500 420 INFO(1) = -5 CALL MUMPS_SET_IERROR(int(N,8)-LWK_REAL, INFO(2)) IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix' GOTO 500 430 INFO(1) = -5 CALL MUMPS_SET_IERROR(2_8*int(N,8)-LWK_REAL, INFO(2)) IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix' GOTO 500 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_A SUBROUTINE SMUMPS_ROWCOL(N,NZ8,IRN,ICN,VAL, & RNOR,CNOR,COLSCA,ROWSCA,MPRINT) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 REAL VAL(NZ8) REAL RNOR(N),CNOR(N) REAL COLSCA(N),ROWSCA(N) REAL CMIN,CMAX,RMIN,ARNOR,ACNOR INTEGER IRN(NZ8), ICN(NZ8) REAL VDIAG INTEGER MPRINT INTEGER I,J INTEGER(8) :: K8 REAL ZERO, ONE PARAMETER(ZERO=0.0E0, ONE=1.0E0) DO 50 J=1,N CNOR(J) = ZERO RNOR(J) = ZERO 50 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.CNOR(J)) THEN CNOR(J) = VDIAG ENDIF IF (VDIAG.GT.RNOR(I)) THEN RNOR(I) = VDIAG ENDIF 100 CONTINUE IF (MPRINT.GT.0) THEN CMIN = CNOR(1) CMAX = CNOR(1) RMIN = RNOR(1) DO 111 I=1,N ARNOR = RNOR(I) ACNOR = CNOR(I) IF (ACNOR.GT.CMAX) CMAX=ACNOR IF (ACNOR.LT.CMIN) CMIN=ACNOR IF (ARNOR.LT.RMIN) RMIN=ARNOR 111 CONTINUE WRITE(MPRINT,*) '**** STAT. OF MATRIX PRIOR ROW&COL SCALING' WRITE(MPRINT,*) ' MAXIMUM NORM-MAX OF COLUMNS:',CMAX WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF COLUMNS:',CMIN WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF ROWS :',RMIN ENDIF DO 120 J=1,N IF (CNOR(J).LE.ZERO) THEN CNOR(J) = ONE ELSE CNOR(J) = ONE / CNOR(J) ENDIF 120 CONTINUE DO 130 J=1,N IF (RNOR(J).LE.ZERO) THEN RNOR(J) = ONE ELSE RNOR(J) = ONE / RNOR(J) ENDIF 130 CONTINUE DO 110 I=1,N ROWSCA(I) = ROWSCA(I) * RNOR(I) COLSCA(I) = COLSCA(I) * CNOR(I) 110 CONTINUE IF (MPRINT.GT.0) & WRITE(MPRINT,*) ' END OF SCALING BY MAX IN ROW AND COL' RETURN END SUBROUTINE SMUMPS_ROWCOL SUBROUTINE SMUMPS_FAC_Y(N,NZ8,VAL,IRN,ICN, & CNOR,COLSCA,MPRINT) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 REAL, INTENT(IN) :: VAL(NZ8) REAL, INTENT(OUT) :: CNOR(N) REAL, INTENT(INOUT) :: COLSCA(N) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) INTEGER, INTENT(IN) :: MPRINT REAL VDIAG INTEGER I,J INTEGER(8) :: K8 REAL ZERO, ONE PARAMETER (ZERO=0.0E0,ONE=1.0E0) DO 10 J=1,N CNOR(J) = ZERO 10 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.CNOR(J)) THEN CNOR(J) = VDIAG ENDIF 100 CONTINUE DO 110 J=1,N IF (CNOR(J).LE.ZERO) THEN CNOR(J) = ONE ELSE CNOR(J) = ONE/CNOR(J) ENDIF 110 CONTINUE DO 215 I=1,N COLSCA(I) = COLSCA(I) * CNOR(I) 215 CONTINUE IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF COLUMN SCALING' RETURN END SUBROUTINE SMUMPS_FAC_Y SUBROUTINE SMUMPS_FAC_V(N,NZ8,VAL,IRN,ICN, & COLSCA,ROWSCA,MPRINT) INTEGER , INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 REAL , INTENT(IN) :: VAL(NZ8) REAL , INTENT(OUT) :: ROWSCA(N),COLSCA(N) INTEGER , INTENT(IN) :: IRN(NZ8),ICN(NZ8) INTEGER , INTENT(IN) :: MPRINT REAL :: VDIAG INTEGER :: I,J INTEGER(8) :: K8 INTRINSIC sqrt REAL ZERO, ONE PARAMETER(ZERO=0.0E0, ONE=1.0E0) DO 10 I=1,N ROWSCA(I) = ONE 10 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) IF ((I.GT.N).OR.(I.LE.0)) GOTO 100 J = ICN(K8) IF (I.EQ.J) THEN VDIAG = abs(VAL(K8)) IF (VDIAG.GT.ZERO) THEN ROWSCA(J) = ONE/(sqrt(VDIAG)) ENDIF ENDIF 100 CONTINUE DO 110 I=1,N COLSCA(I) = ROWSCA(I) 110 CONTINUE IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF DIAGONAL SCALING' RETURN END SUBROUTINE SMUMPS_FAC_V SUBROUTINE SMUMPS_FAC_X(NSCA,N,NZ8,IRN,ICN,VAL, & RNOR,ROWSCA,MPRINT) INTEGER, INTENT(IN) :: N, NSCA INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) REAL VAL(NZ8) REAL RNOR(N) REAL ROWSCA(N) INTEGER MPRINT REAL VDIAG INTEGER I,J INTEGER(8) :: K8 REAL, PARAMETER :: ZERO = 0.0E0 REAL, PARAMETER :: ONE = 1.0E0 DO 50 J=1,N RNOR(J) = ZERO 50 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.RNOR(I)) THEN RNOR(I) = VDIAG ENDIF 100 CONTINUE DO 130 J=1,N IF (RNOR(J).LE.ZERO) THEN RNOR(J) = ONE ELSE RNOR(J) = ONE/RNOR(J) ENDIF 130 CONTINUE DO 110 I=1,N ROWSCA(I) = ROWSCA(I)* RNOR(I) 110 CONTINUE IF ( (NSCA.EQ.4) .OR. (NSCA.EQ.6) ) THEN DO 150 K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 150 VAL(K8) = VAL(K8) * RNOR(I) 150 CONTINUE ENDIF IF (MPRINT.GT.0) & WRITE(MPRINT,'(A)') ' END OF ROW SCALING' RETURN END SUBROUTINE SMUMPS_FAC_X SUBROUTINE SMUMPS_ANORMINF( id, ANORMINF, LSCAL, & EFF_SIZE_SCHUR ) 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, INTENT(IN) :: LSCAL INTEGER, INTENT(IN) :: EFF_SIZE_SCHUR LOGICAL :: I_AM_SLAVE REAL DUMMY(1) REAL ZERO PARAMETER( ZERO = 0.0E0) REAL, ALLOCATABLE :: SUMR(:), SUMR_LOC(:) INTEGER :: allocok, MTYPE, I I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%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 ( id%KEEP(54) .eq. 0 ) THEN IF (id%MYID .EQ. MASTER) THEN IF (id%KEEP(55).EQ.0) THEN IF (.NOT.LSCAL) THEN CALL SMUMPS_SOL_X(id%A(1), & id%KEEP8(28), id%N, & id%IRN(1), id%JCN(1), & SUMR, id%KEEP(1),id%KEEP8(1), & EFF_SIZE_SCHUR, id%SYM_PERM(1) ) ELSE CALL SMUMPS_SCAL_X(id%A(1), & id%KEEP8(28), id%N, & id%IRN(1), id%JCN(1), & SUMR, id%KEEP(1), id%KEEP8(1), & id%COLSCA(1), & EFF_SIZE_SCHUR, id%SYM_PERM(1) ) ENDIF ELSE MTYPE = 1 IF (.NOT.LSCAL) THEN CALL SMUMPS_SOL_X_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), & id%A_ELT(1), SUMR, id%KEEP(1),id%KEEP8(1) ) ELSE CALL SMUMPS_SOL_SCALX_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), & id%A_ELT(1), & SUMR, id%KEEP(1), id%KEEP8(1), id%COLSCA(1)) ENDIF ENDIF ENDIF ELSE ALLOCATE( SUMR_LOC( id%N ), stat =allocok ) IF (allocok .GT.0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N RETURN ENDIF IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0 ) THEN IF (.NOT.LSCAL) THEN CALL SMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1), & EFF_SIZE_SCHUR, id%SYM_PERM(1) ) ELSE CALL SMUMPS_SCAL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1), & id%COLSCA(1), & EFF_SIZE_SCHUR, id%SYM_PERM(1) ) ENDIF ELSE SUMR_LOC = ZERO ENDIF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( SUMR_LOC, SUMR, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( SUMR_LOC, DUMMY, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) END IF DEALLOCATE (SUMR_LOC) ENDIF IF ( id%MYID .eq. MASTER ) THEN ANORMINF = real(ZERO) IF (LSCAL) THEN DO I = 1, id%N ANORMINF = max(abs(id%ROWSCA(I) * SUMR(I)), & ANORMINF) ENDDO ELSE DO I = 1, id%N ANORMINF = max(abs(SUMR(I)), & ANORMINF) ENDDO ENDIF ENDIF CALL MPI_BCAST(ANORMINF, 1, & MPI_REAL, MASTER, & id%COMM, IERR ) IF (id%MYID .eq. MASTER) DEALLOCATE (SUMR) RETURN END SUBROUTINE SMUMPS_ANORMINF MUMPS_5.8.1/src/dfac_sol_pool.F0000664000175000017500000004376715042446440016163 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_INIT_POOL_LAST3(IPOOL, LPOOL, LEAF) USE MUMPS_LOAD IMPLICIT NONE INTEGER LPOOL, LEAF INTEGER IPOOL(LPOOL) IPOOL(LPOOL-2) = 0 IPOOL(LPOOL-1) = 0 IPOOL(LPOOL) = LEAF-1 RETURN END SUBROUTINE DMUMPS_INIT_POOL_LAST3 SUBROUTINE DMUMPS_INSERT_POOL_N & (N, POOL, LPOOL, PROCNODE, SLAVEF, KEEP199, & K28, K76, K80, K47, STEP, INODE) USE MUMPS_LOAD IMPLICIT NONE INTEGER N, INODE, LPOOL, K28, SLAVEF, K76, K80, K47, KEEP199 INTEGER STEP(N), POOL(LPOOL), PROCNODE(K28) EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR, ATM_CURRENT_NODE INTEGER NBINSUBTREE, NBTOP, INODE_EFF,POS_TO_INSERT INTEGER IPOS1, IPOS2, ISWAP INTEGER NODE,J,I ATM_CURRENT_NODE = ( K76 == 2 .OR. K76 ==3 .OR. & K76==4 .OR. K76==5) NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF (INODE > N ) THEN INODE_EFF = INODE - N ELSE IF (INODE < 0) THEN INODE_EFF = - INODE ELSE INODE_EFF = INODE ENDIF IF(((INODE.GT.0).AND.(INODE.LE.N)).AND.(.NOT. & MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE_EFF)), & KEEP199)) & ) THEN IF ((K80 == 1 .AND. K47 .GE. 1) .OR. & (( K80 == 2 .OR. K80==3 ) .AND. & ( K47 == 4 ))) THEN CALL MUMPS_REMOVE_NODE(INODE,1) ENDIF ENDIF IF ( MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE_EFF)), & KEEP199) ) THEN POOL(NBINSUBTREE + 1 ) = INODE NBINSUBTREE = NBINSUBTREE + 1 ELSE POS_TO_INSERT=NBTOP+1 IF((K76.EQ.4).OR.(K76.EQ.5).OR.(K76.EQ.6))THEN IF((INODE.GT.N).OR.(INODE.LE.0))THEN DO J=NBTOP,1,-1 IF((POOL(LPOOL-2-J).GT.0) & .AND.(POOL(LPOOL-2-J).LE.N))THEN GOTO 333 ENDIF IF ( POOL(LPOOL-2-J) < 0 ) THEN NODE=-POOL(LPOOL-2-J) ELSE IF ( POOL(LPOOL-2-J) > N ) THEN NODE = POOL(LPOOL-2-J) - N ELSE NODE = POOL(LPOOL-2-J) ENDIF IF((K76.EQ.4).OR.(K76.EQ.6))THEN IF(DEPTH_FIRST_LOAD(STEP(NODE)).GE. & DEPTH_FIRST_LOAD(STEP(INODE_EFF)))THEN GOTO 333 ENDIF ENDIF IF(K76.EQ.5)THEN IF(COST_TRAV(STEP(NODE)).LE. & COST_TRAV(STEP(INODE_EFF)))THEN GOTO 333 ENDIF ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO IF(J.EQ.0) J=1 333 CONTINUE DO I=NBTOP,POS_TO_INSERT,-1 POOL(LPOOL-2-I-1)=POOL(LPOOL-2-I) ENDDO POOL(LPOOL-2-POS_TO_INSERT)=INODE NBTOP = NBTOP + 1 GOTO 20 ENDIF DO J=NBTOP,1,-1 IF((POOL(LPOOL-2-J).GT.0).AND.(POOL(LPOOL-2-J).LE.N))THEN GOTO 888 ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO 888 CONTINUE DO I=J,1,-1 NODE=POOL(LPOOL-2-I) IF((K76.EQ.4).OR.(K76.EQ.6))THEN IF(DEPTH_FIRST_LOAD(STEP(NODE)).GE. & DEPTH_FIRST_LOAD(STEP(INODE_EFF)))THEN GOTO 999 ENDIF ENDIF IF(K76.EQ.5)THEN IF(COST_TRAV(STEP(NODE)).LE. & COST_TRAV(STEP(INODE_EFF)))THEN GOTO 999 ENDIF ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO IF(I.EQ.0) I=1 999 CONTINUE DO J=NBTOP,POS_TO_INSERT,-1 POOL(LPOOL-2-J-1)=POOL(LPOOL-2-J) ENDDO POOL(LPOOL-2-POS_TO_INSERT)=INODE NBTOP = NBTOP + 1 GOTO 20 ENDIF POOL( LPOOL - 2 - ( NBTOP + 1 ) ) = INODE NBTOP = NBTOP + 1 IPOS1 = LPOOL - 2 - NBTOP IPOS2 = LPOOL - 2 - NBTOP + 1 10 CONTINUE IF ( IPOS2 == LPOOL - 2 ) GOTO 20 IF ( POOL(IPOS1) < 0 ) GOTO 20 IF ( POOL(IPOS2) < 0 ) GOTO 30 IF ( ATM_CURRENT_NODE ) THEN IF ( POOL(IPOS1) > N ) GOTO 20 IF ( POOL(IPOS2) > N ) GOTO 30 END IF GOTO 20 30 CONTINUE ISWAP = POOL(IPOS1) POOL(IPOS1) = POOL(IPOS2) POOL(IPOS2) = ISWAP IPOS1 = IPOS1 + 1 IPOS2 = IPOS2 + 1 GOTO 10 20 CONTINUE ENDIF POOL(LPOOL) = NBINSUBTREE POOL(LPOOL - 1) = NBTOP RETURN END SUBROUTINE DMUMPS_INSERT_POOL_N LOGICAL FUNCTION DMUMPS_POOL_EMPTY(POOL, LPOOL) IMPLICIT NONE INTEGER LPOOL INTEGER POOL(LPOOL) INTEGER NBINSUBTREE, NBTOP NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) DMUMPS_POOL_EMPTY = (NBINSUBTREE + NBTOP == 0) RETURN END FUNCTION DMUMPS_POOL_EMPTY SUBROUTINE DMUMPS_EXTRACT_POOL( N, POOL, LPOOL, PROCNODE, SLAVEF, & STEP, INODE, KEEP,KEEP8, MYID, ND, & FORCE_EXTRACT_TOP_SBTR ) USE MUMPS_LOAD IMPLICIT NONE INTEGER INODE, LPOOL, SLAVEF, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(N), POOL(LPOOL), PROCNODE(KEEP(28)), & ND(KEEP(28)) EXTERNAL MUMPS_INSSARBR, MUMPS_ROOTSSARBR, DMUMPS_POOL_EMPTY LOGICAL MUMPS_INSSARBR, MUMPS_ROOTSSARBR, DMUMPS_POOL_EMPTY INTEGER NBINSUBTREE, NBTOP, INSUBTREE, INODE_EFF, MYID LOGICAL LEFT, ATOMIC_SUBTREE,UPPER,FLAG_MEM,SBTR_FLAG,PROC_FLAG LOGICAL FORCE_EXTRACT_TOP_SBTR INTEGER NODE_TO_EXTRACT,I,J,MIN_PROC NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF ( KEEP(76) > 6 .OR. KEEP(76) < 0 ) THEN WRITE(*,*) "Error 2 in DMUMPS_EXTRACT_POOL: unknown strategy" CALL MUMPS_ABORT() ENDIF ATOMIC_SUBTREE = ( KEEP(76) == 1 .OR. KEEP(76) == 3) IF ( DMUMPS_POOL_EMPTY(POOL, LPOOL) ) THEN WRITE(*,*) "Error 1 in DMUMPS_EXTRACT_POOL" CALL MUMPS_ABORT() ENDIF IF ( .NOT. ATOMIC_SUBTREE ) THEN LEFT = (NBTOP == 0) IF(.NOT.LEFT)THEN IF((KEEP(76).EQ.4).OR.(KEEP(76).EQ.5))THEN IF(NBINSUBTREE.EQ.0)THEN LEFT=.FALSE. ELSE IF ( POOL(NBINSUBTREE) < 0 ) THEN I = -POOL(NBINSUBTREE) ELSE IF ( POOL(NBINSUBTREE) > N ) THEN I = POOL(NBINSUBTREE) - N ELSE I = POOL(NBINSUBTREE) ENDIF IF ( POOL(LPOOL-2-NBTOP) < 0 ) THEN J = -POOL(LPOOL-2-NBTOP) ELSE IF ( POOL(LPOOL-2-NBTOP) > N ) THEN J = POOL(LPOOL-2-NBTOP) - N ELSE J = POOL(LPOOL-2-NBTOP) ENDIF IF(KEEP(76).EQ.4)THEN IF(DEPTH_FIRST_LOAD(STEP(J)).GE. & DEPTH_FIRST_LOAD(STEP(I)))THEN LEFT=.TRUE. ELSE LEFT=.FALSE. ENDIF ENDIF IF(KEEP(76).EQ.5)THEN IF(COST_TRAV(STEP(J)).LE. & COST_TRAV(STEP(I)))THEN LEFT=.TRUE. ELSE LEFT=.FALSE. ENDIF ENDIF ENDIF ENDIF ENDIF ELSE IF ( INSUBTREE == 1 ) THEN IF (NBINSUBTREE == 0) THEN WRITE(*,*) "Error 3 in DMUMPS_EXTRACT_POOL" CALL MUMPS_ABORT() ENDIF LEFT = .TRUE. ELSE LEFT = ( NBTOP == 0) ENDIF ENDIF 222 CONTINUE IF ( LEFT ) THEN INODE = POOL( NBINSUBTREE ) IF(KEEP(81).EQ.2)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN CALL DMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8,PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(.NOT.SBTR_FLAG)THEN WRITE(*,*)MYID,': ca a change pour moi' LEFT=.FALSE. GOTO 222 ENDIF ENDIF ELSEIF(KEEP(81).EQ.3)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN NODE_TO_EXTRACT=INODE FLAG_MEM=.FALSE. CALL MUMPS_LOAD_CHK_MEMCST_POOL(FLAG_MEM) IF(FLAG_MEM)THEN CALL DMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(.NOT.SBTR_FLAG)THEN LEFT=.FALSE. WRITE(*,*)MYID,': ca a change pour moi (2)' GOTO 222 ENDIF ENDIF ENDIF ENDIF NBINSUBTREE = NBINSUBTREE - 1 IF ( INODE < 0 ) THEN INODE_EFF = -INODE ELSE IF ( INODE > N ) THEN INODE_EFF = INODE - N ELSE INODE_EFF = INODE ENDIF IF ( MUMPS_INSSARBR( PROCNODE(STEP(INODE_EFF)), & KEEP(199)) ) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.0))THEN CALL MUMPS_LOAD_SET_SBTR_MEM(.TRUE.) ENDIF INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE_EFF)), & KEEP(199))) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.1))THEN CALL MUMPS_LOAD_SET_SBTR_MEM(.FALSE.) ENDIF INSUBTREE = 0 END IF ELSE IF (NBTOP < 1 ) THEN WRITE(*,*) "Error 5 in DMUMPS_EXTRACT_POOL", NBTOP CALL MUMPS_ABORT() ENDIF INODE = POOL( LPOOL - 2 - NBTOP ) IF(KEEP(81).EQ.1)THEN CALL MUMPS_LOAD_POOL_CHECK_MEM & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IF(UPPER)THEN GOTO 666 ELSE NBINSUBTREE=NBINSUBTREE-1 IF ( MUMPS_INSSARBR( PROCNODE(STEP(INODE)), & KEEP(199)) ) THEN INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE)), & KEEP(199))) THEN INSUBTREE = 0 ENDIF GOTO 777 ENDIF ENDIF IF(KEEP(81).EQ.2)THEN CALL DMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN LEFT=.TRUE. WRITE(*,*)MYID,': ca a change pour moi (3)' GOTO 222 ENDIF ELSE IF(KEEP(81).EQ.3)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN NODE_TO_EXTRACT=INODE FLAG_MEM=.FALSE. CALL MUMPS_LOAD_CHK_MEMCST_POOL(FLAG_MEM) IF(FLAG_MEM)THEN CALL DMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN LEFT=.TRUE. WRITE(*,*)MYID,': ca a change pour moi (4)' GOTO 222 ENDIF ELSE CALL MUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ENDIF ENDIF ENDIF ENDIF 666 CONTINUE NBTOP = NBTOP - 1 IF((INODE.GT.0).AND.(INODE.LE.N))THEN IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. & ( KEEP(47) == 4 ))) THEN CALL MUMPS_REMOVE_NODE(INODE,2) ENDIF ENDIF IF ( INODE < 0 ) THEN INODE_EFF = -INODE ELSE IF ( INODE > N ) THEN INODE_EFF = INODE - N ELSE INODE_EFF = INODE ENDIF END IF 777 CONTINUE POOL(LPOOL) = NBINSUBTREE POOL(LPOOL - 1) = NBTOP POOL(LPOOL - 2) = INSUBTREE RETURN END SUBROUTINE DMUMPS_EXTRACT_POOL SUBROUTINE DMUMPS_MEM_CONS_MNG(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR,FLAG_SAME_PROC,MIN_PROC) USE MUMPS_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) LOGICAL SBTR,FLAG_SAME_PROC INTEGER POS_TO_EXTRACT,NODE_TO_EXTRACT,NBTOP,I,INSUBTREE, & NBINSUBTREE DOUBLE PRECISION MIN_COST, TMP_COST NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) MIN_COST=huge(MIN_COST) TMP_COST=huge(TMP_COST) FLAG_SAME_PROC=.FALSE. SBTR=.FALSE. MIN_PROC=-9999 IF((INODE.GT.0).AND.(INODE.LE.N))THEN POS_TO_EXTRACT=-1 NODE_TO_EXTRACT=-1 DO I=NBTOP,1,-1 IF(NODE_TO_EXTRACT.LT.0)THEN POS_TO_EXTRACT=I NODE_TO_EXTRACT=POOL(LPOOL-2-I) CALL MUMPS_LOAD_COMP_MAXMEM_POOL(NODE_TO_EXTRACT, & TMP_COST,PROC) MIN_COST=TMP_COST MIN_PROC=PROC ELSE CALL MUMPS_LOAD_COMP_MAXMEM_POOL(POOL(LPOOL-2-I), & TMP_COST,PROC) IF((PROC.NE.MIN_PROC).OR.(TMP_COST.NE.MIN_COST))THEN FLAG_SAME_PROC=.TRUE. ENDIF IF(TMP_COST.GT.MIN_COST)THEN POS_TO_EXTRACT=I NODE_TO_EXTRACT=POOL(LPOOL-2-I) MIN_COST=TMP_COST MIN_PROC=PROC ENDIF ENDIF ENDDO IF((KEEP(47).EQ.4).AND.(NBINSUBTREE.NE.0))THEN CALL MUMPS_CHECK_SBTR_COST(NBINSUBTREE,INSUBTREE,NBTOP, & MIN_COST,SBTR) IF(SBTR)THEN WRITE(*,*)MYID,': selecting from subtree' RETURN ENDIF ENDIF IF((.NOT.SBTR).AND.(.NOT.FLAG_SAME_PROC))THEN WRITE(*,*)MYID,': I must search for a task & to save My friend' RETURN ENDIF INODE = NODE_TO_EXTRACT DO I=POS_TO_EXTRACT,NBTOP IF(I.NE.NBTOP)THEN POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDIF ENDDO POOL(LPOOL-2-NBTOP)=INODE CALL MUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ELSE ENDIF END SUBROUTINE DMUMPS_MEM_CONS_MNG SUBROUTINE DMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) USE MUMPS_LOAD IMPLICIT NONE INTEGER INODE,LPOOL,N,SLAVEF,MYID,MIN_PROC INTEGER POOL(LPOOL),KEEP(500),PROCNODE(KEEP(28)),STEP(N) INTEGER(8) KEEP8(150) LOGICAL SBTR_FLAG,PROC_FLAG EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR INTEGER NODE_TO_EXTRACT,I,POS_TO_EXTRACT,NBTOP,NBINSUBTREE NBTOP= POOL(LPOOL - 1) NBINSUBTREE = POOL(LPOOL) IF(NBTOP.GT.0)THEN WRITE(*,*)MYID,': NBTOP=',NBTOP ENDIF SBTR_FLAG=.FALSE. PROC_FLAG=.FALSE. CALL DMUMPS_MEM_CONS_MNG(INODE,POOL,LPOOL,N,STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN RETURN ENDIF IF(MIN_PROC.EQ.-9999)THEN IF((INODE.GT.0).AND.(INODE.LT.N))THEN SBTR_FLAG=(NBINSUBTREE.NE.0) ENDIF RETURN ENDIF IF(.NOT.PROC_FLAG)THEN NODE_TO_EXTRACT=INODE IF((INODE.GE.0).AND.(INODE.LE.N))THEN CALL MUMPS_FIND_BEST_NODE_FOR_MEM(MIN_PROC,POOL, & LPOOL,INODE) IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)), & KEEP(199)))THEN WRITE(*,*)MYID,': Extracting from a subtree & for helping',MIN_PROC SBTR_FLAG=.TRUE. RETURN ELSE IF(NODE_TO_EXTRACT.NE.INODE)THEN WRITE(*,*)MYID,': Extracting from top & inode=',INODE,'for helping',MIN_PROC ENDIF CALL MUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ENDIF ENDIF DO I=1,NBTOP IF (POOL(LPOOL-2-I).EQ.INODE)THEN GOTO 452 ENDIF ENDDO 452 CONTINUE POS_TO_EXTRACT=I DO I=POS_TO_EXTRACT,NBTOP-1 POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDDO POOL(LPOOL-2-NBTOP)=INODE ENDIF END SUBROUTINE DMUMPS_MEM_NODE_SELECT SUBROUTINE DMUMPS_GET_INODE_FROM_POOL & ( IPOOL, LPOOL, III, LEAF, & INODE, STRATEGIE ) IMPLICIT NONE INTEGER, INTENT(IN) :: STRATEGIE, LPOOL INTEGER IPOOL (LPOOL) INTEGER III,LEAF INTEGER, INTENT(OUT) :: INODE LEAF = LEAF - 1 INODE = IPOOL( LEAF ) RETURN END SUBROUTINE DMUMPS_GET_INODE_FROM_POOL MUMPS_5.8.1/src/dsol_distrhs.F0000664000175000017500000006051715042446437016057 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SCATTER_DIST_RHS( & NSLAVES, N, & MYID_NODES, COMM_NODES, & NRHS_COL, NRHS_loc, LRHS_loc, & MAP_RHS_loc, & IRHS_loc, RHS_loc, RHS_loc_size, & RHSINTR, LD_RHSINTR, & POSINRHSINTR_FWD, NB_FS_IN_RHSINTR, & LSCAL, #if defined(USE_OLD_SCALING) & scaling_data_dr, #else & SCALING_RHSINTR_FWD, LSCALING_RHSINTR_FWD, #endif & LP, LPOK, KEEP, NB_BYTES_LOC, INFO ) USE DMUMPS_STRUC_DEF !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN) :: NSLAVES, N, MYID_NODES INTEGER, INTENT(IN) :: NRHS_loc, LRHS_loc INTEGER, INTENT(IN) :: NRHS_COL INTEGER, INTENT(IN) :: COMM_NODES INTEGER, INTENT(IN) :: MAP_RHS_loc(max(1,NRHS_loc)) INTEGER, INTENT(IN) :: IRHS_loc(NRHS_loc) INTEGER(8), INTENT(IN) :: RHS_loc_size DOUBLE PRECISION, INTENT(IN) :: RHS_loc(RHS_loc_size) INTEGER, INTENT(IN) :: NB_FS_IN_RHSINTR, LD_RHSINTR INTEGER, INTENT(IN) :: POSINRHSINTR_FWD(N) DOUBLE PRECISION, INTENT(OUT) :: RHSINTR(LD_RHSINTR, NRHS_COL) INTEGER :: KEEP(500) LOGICAL, INTENT(IN) :: LSCAL #if defined(USE_OLD_SCALING) type scaling_data_t SEQUENCE DOUBLE PRECISION, dimension(:), pointer :: SCALING DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC INTEGER, dimension(:), pointer :: SCALING_IND end type scaling_data_t type(scaling_data_t), INTENT(IN) :: scaling_data_dr #else INTEGER :: LSCALING_RHSINTR_FWD DOUBLE PRECISION :: SCALING_RHSINTR_FWD( LSCALING_RHSINTR_FWD ) #endif LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: LP INTEGER, INTENT(INOUT) :: INFO(2) INTEGER(8), INTENT(OUT):: NB_BYTES_LOC INCLUDE 'mpif.h' INTEGER :: IERR_MPI LOGICAL :: OMP_FLAG !$ INTEGER :: CHUNK, NOMP !$ INTEGER(8) :: CHUNK8 INTEGER :: allocok INTEGER :: MAXRECORDS INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROWSTOSEND INTEGER, ALLOCATABLE, DIMENSION(:) :: NEXTROWTOSEND DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: BUFRECR LOGICAL, ALLOCATABLE, DIMENSION(:) :: IS_SEND_ACTIVE, TOUCHED INTEGER, ALLOCATABLE, DIMENSION(:) :: MPI_REQI, MPI_REQR INTEGER, ALLOCATABLE, DIMENSION(:) :: IRHS_loc_sorted INTEGER :: Iloc INTEGER :: Iloc_sorted INTEGER :: IREQ INTEGER :: IMAP, IPROC_MAX INTEGER :: IFS INTEGER :: MAX_ACTIVE_SENDS INTEGER :: NB_ACTIVE_SENDS INTEGER :: NB_FS_TOUCHED INTEGER :: NBROWSTORECV DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 #if defined(AVOID_MPI_IN_PLACE) INTEGER :: allocoktmp #endif !$ NOMP = OMP_GET_MAX_THREADS() NB_BYTES_LOC = 0_8 ALLOCATE( NBROWSTOSEND (NSLAVES), & NEXTROWTOSEND (NSLAVES), & IRHS_loc_sorted (NRHS_loc), & stat=allocok ) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = NSLAVES+NSLAVES+NRHS_loc ELSE NB_BYTES_LOC = int(2*NSLAVES+NRHS_loc,8)*KEEP(34) ENDIF #if defined(AVOID_MPI_IN_PLACE) allocoktmp=allocok CALL MPI_ALLREDUCE( allocoktmp, allocok, 1, #else CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1, #endif & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI ) IF (allocok .GT. 0) RETURN NBROWSTOSEND(1:NSLAVES) = 0 DO Iloc = 1, NRHS_loc IF (IRHS_loc(Iloc) .GE. 1 .AND. & IRHS_loc(Iloc) .LE. N) THEN IMAP = MAP_RHS_loc(Iloc) NBROWSTOSEND(IMAP+1) = NBROWSTOSEND(IMAP+1)+1 ENDIF ENDDO NEXTROWTOSEND(1)=1 DO IMAP=1, NSLAVES-1 NEXTROWTOSEND(IMAP+1)=NEXTROWTOSEND(IMAP)+NBROWSTOSEND(IMAP) ENDDO NBROWSTOSEND=0 DO Iloc = 1, NRHS_loc IF (IRHS_loc(Iloc) .GE. 1 .AND. & IRHS_loc(Iloc) .LE. N) THEN IMAP = MAP_RHS_loc(Iloc) Iloc_sorted = NEXTROWTOSEND(IMAP+1)+NBROWSTOSEND(IMAP+1) IRHS_loc_sorted(Iloc_sorted) = Iloc NBROWSTOSEND(IMAP+1)=NBROWSTOSEND(IMAP+1)+1 ENDIF ENDDO CALL DMUMPS_DR_BUILD_NBROWSTORECV() MAX_ACTIVE_SENDS = min(10, NSLAVES) IF (KEEP(72) .EQ.1 ) THEN MAXRECORDS = 15 ELSE MAXRECORDS = min(200000,2000000/NRHS_COL) MAXRECORDS = min(MAXRECORDS, & 50000000 / MAX_ACTIVE_SENDS / NRHS_COL) MAXRECORDS = max(MAXRECORDS, 50) ENDIF ALLOCATE(BUFR(MAXRECORDS*NRHS_COL, & MAX_ACTIVE_SENDS), & MPI_REQI(MAX_ACTIVE_SENDS), & MPI_REQR(MAX_ACTIVE_SENDS), & IS_SEND_ACTIVE(MAX_ACTIVE_SENDS), & BUFRECI(MAXRECORDS), & BUFRECR(MAXRECORDS*NRHS_COL), & TOUCHED(NB_FS_IN_RHSINTR), & stat=allocok) IF (allocok .GT. 0) THEN IF (LP .GT. 0) WRITE(LP, '(A)') & 'Error: Allocation problem in DMUMPS_SCATTER_DIST_RHS' INFO(1)=-13 INFO(2)=NRHS_COL*MAXRECORDS*MAX_ACTIVE_SENDS+ & 3*MAX_ACTIVE_SENDS+MAXRECORDS*(1+NRHS_COL) & + NB_FS_IN_RHSINTR ENDIF NB_BYTES_LOC=NB_BYTES_LOC + & KEEP(34) * ( int(2*MAX_ACTIVE_SENDS,8) + int(MAXRECORDS,8) ) + & KEEP(34) * (int(MAX_ACTIVE_SENDS,8) + int(NB_FS_IN_RHSINTR,8)) + & KEEP(35) * ( & int( MAXRECORDS,8)*int(NRHS_COL,8)*int(MAX_ACTIVE_SENDS,8) & + int(MAXRECORDS,8) * int(NRHS_COL,8) ) CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1, & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI ) IF (allocok .NE. 0) RETURN NB_ACTIVE_SENDS = 0 DO IREQ = 1, MAX_ACTIVE_SENDS IS_SEND_ACTIVE(IREQ) = .FALSE. ENDDO NB_FS_TOUCHED = 0 DO IFS = 1, NB_FS_IN_RHSINTR TOUCHED(IFS) = .FALSE. ENDDO IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1 DO WHILE (NBROWSTOSEND(IPROC_MAX+1) .NE. 0) IF (IPROC_MAX .EQ. MYID_NODES) THEN CALL DMUMPS_DR_ASSEMBLE_LOCAL() ELSE CALL DMUMPS_DR_TRY_SEND(IPROC_MAX) ENDIF CALL DMUMPS_DR_TRY_RECV() CALL DMUMPS_DR_TRY_FREE_SEND() IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1 ENDDO DO WHILE ( NBROWSTORECV .NE. 0) CALL DMUMPS_DR_TRY_RECV() CALL DMUMPS_DR_TRY_FREE_SEND() ENDDO DO WHILE (NB_ACTIVE_SENDS .NE. 0) CALL DMUMPS_DR_TRY_FREE_SEND() ENDDO CALL DMUMPS_DR_EMPTY_ROWS() RETURN CONTAINS SUBROUTINE DMUMPS_DR_BUILD_NBROWSTORECV() INTEGER :: IPROC DO IPROC = 0, NSLAVES-1 CALL MPI_REDUCE( NBROWSTOSEND(IPROC+1), NBROWSTORECV, & 1, MPI_INTEGER, & MPI_SUM, IPROC, COMM_NODES, IERR_MPI ) ENDDO END SUBROUTINE DMUMPS_DR_BUILD_NBROWSTORECV SUBROUTINE DMUMPS_DR_TRY_RECV() IMPLICIT NONE INCLUDE 'mumps_tags.h' INTEGER :: MPI_STATUS(MPI_STATUS_SIZE), MSGSOU INTEGER :: NBRECORDS LOGICAL :: FLAG CALL MPI_IPROBE( MPI_ANY_SOURCE, DistRhsI, COMM_NODES, & FLAG, MPI_STATUS, IERR_MPI ) IF (FLAG) THEN MSGSOU = MPI_STATUS( MPI_SOURCE ) CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER, & NBRECORDS, IERR_MPI) CALL MPI_RECV(BUFRECI(1), NBRECORDS, MPI_INTEGER, & MSGSOU, DistRhsI, & COMM_NODES, MPI_STATUS, IERR_MPI) CALL MPI_RECV(BUFRECR(1), NBRECORDS*NRHS_COL, & MPI_DOUBLE_PRECISION, & MSGSOU, DistRhsR, & COMM_NODES, MPI_STATUS, IERR_MPI) CALL DMUMPS_DR_ASSEMBLE_FROM_BUFREC(NBRECORDS, & BUFRECI, BUFRECR) ENDIF RETURN END SUBROUTINE DMUMPS_DR_TRY_RECV SUBROUTINE DMUMPS_DR_ASSEMBLE_FROM_BUFREC & (NBRECORDS, BUFRECI_ARG, BUFRECR_ARG) IMPLICIT NONE INTEGER, INTENT(IN) :: NBRECORDS INTEGER, INTENT(INOUT) :: BUFRECI_ARG(NBRECORDS) DOUBLE PRECISION, INTENT(IN) :: BUFRECR_ARG(NBRECORDS, & NRHS_COL) INTEGER :: I, K, IRHSINTR, IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IFIRSTNOTTOUCHED = NBRECORDS+1 ILASTNOTTOUCHED = 0 DO I = 1, NBRECORDS IF (BUFRECI(I) .LE. 0) THEN WRITE(*,*) "Internal error 1 in DMUMPS_DR_TRY_RECV", & I, BUFRECI(I), BUFRECI(1) CALL MUMPS_ABORT() ENDIF IRHSINTR=POSINRHSINTR_FWD(BUFRECI(I)) BUFRECI_ARG(I)=IRHSINTR IF ( .NOT. TOUCHED(IRHSINTR) ) THEN IFIRSTNOTTOUCHED=min(IFIRSTNOTTOUCHED,I) ILASTNOTTOUCHED=max(ILASTNOTTOUCHED,I) ENDIF ENDDO OMP_FLAG = .FALSE. !$ OMP_FLAG = ( NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(I,IRHSINTR) DO K = 1, NRHS_COL DO I = IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IRHSINTR=BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSINTR)) THEN RHSINTR(IRHSINTR,K)=ZERO ENDIF ENDDO #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO I = 1, NBRECORDS IRHSINTR=BUFRECI_ARG(I) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & SCALING_RHSINTR_FWD(IRHSINTR) * & BUFRECR_ARG(I,K) ENDDO ELSE #endif DO I = 1, NBRECORDS IRHSINTR=BUFRECI_ARG(I) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & BUFRECR_ARG(I,K) ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif ENDDO !$OMP END PARALLEL DO ELSE DO K = 1, NRHS_COL DO I = IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IRHSINTR=BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSINTR)) THEN RHSINTR(IRHSINTR,K)=ZERO ENDIF ENDDO #if ! defined(USE_OLD_SCALING) IF ( LSCAL ) THEN DO I = 1, NBRECORDS IRHSINTR=BUFRECI_ARG(I) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & SCALING_RHSINTR_FWD(IRHSINTR) * & BUFRECR_ARG(I,K) ENDDO ELSE #endif DO I = 1, NBRECORDS IRHSINTR=BUFRECI_ARG(I) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & BUFRECR_ARG(I,K) ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif ENDDO ENDIF DO I = 1, NBRECORDS IRHSINTR = BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSINTR)) THEN NB_FS_TOUCHED = NB_FS_TOUCHED + 1 TOUCHED(IRHSINTR) = .TRUE. ENDIF ENDDO NBROWSTORECV = NBROWSTORECV - NBRECORDS RETURN END SUBROUTINE DMUMPS_DR_ASSEMBLE_FROM_BUFREC SUBROUTINE DMUMPS_DR_ASSEMBLE_LOCAL() INTEGER :: NBRECORDS, I, K, IFIRSTNOTTOUCHED INTEGER :: Iloc INTEGER :: Iglob INTEGER :: IRHSINTR INTEGER(8) :: ISHIFT IF ( NBROWSTOSEND(MYID_NODES+1) .EQ. 0) THEN WRITE(*,*) "Internal error in DMUMPS_DR_ASSEMBLE_LOCAL" CALL MUMPS_ABORT() ENDIF NBRECORDS=min(MAXRECORDS, NBROWSTOSEND(MYID_NODES+1)) IFIRSTNOTTOUCHED=NBRECORDS+1 DO I = 1, NBRECORDS IRHSINTR = POSINRHSINTR_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSINTR)) THEN IFIRSTNOTTOUCHED=I EXIT ENDIF ENDDO IF (LSCAL) THEN !$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSINTR, Iloc, Iglob) !$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG) DO K = 1, NRHS_COL ISHIFT = int(K-1,8) * int(LRHS_loc,8) DO I = IFIRSTNOTTOUCHED, NBRECORDS IRHSINTR = POSINRHSINTR_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSINTR)) THEN RHSINTR(IRHSINTR,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1) Iglob = IRHS_loc(Iloc) IRHSINTR = POSINRHSINTR_FWD(Iglob) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K)+ & RHS_loc(Iloc+ISHIFT)* #if defined(USE_OLD_SCALING) & scaling_data_dr%SCALING_LOC(Iloc) #else & SCALING_RHSINTR_FWD(IRHSINTR) #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSINTR, Iloc, Iglob) !$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG) DO K = 1, NRHS_COL ISHIFT = int(K-1,8) * int(LRHS_loc,8) DO I = IFIRSTNOTTOUCHED, NBRECORDS IRHSINTR = POSINRHSINTR_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSINTR)) THEN RHSINTR(IRHSINTR,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1) Iglob = IRHS_loc(Iloc) IRHSINTR = POSINRHSINTR_FWD(Iglob) RHSINTR(IRHSINTR,K) = RHSINTR(IRHSINTR,K) + & RHS_loc(Iloc+ISHIFT) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF DO I = 1, NBRECORDS IRHSINTR = POSINRHSINTR_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSINTR)) THEN NB_FS_TOUCHED = NB_FS_TOUCHED + 1 TOUCHED(IRHSINTR) = .TRUE. ENDIF ENDDO NEXTROWTOSEND(MYID_NODES+1)=NEXTROWTOSEND(MYID_NODES+1)+ & NBRECORDS NBROWSTOSEND(MYID_NODES+1)=NBROWSTOSEND(MYID_NODES+1)- & NBRECORDS NBROWSTORECV = NBROWSTORECV - NBRECORDS RETURN END SUBROUTINE DMUMPS_DR_ASSEMBLE_LOCAL SUBROUTINE DMUMPS_DR_GET_NEW_BUF( IBUF ) INTEGER, INTENT(OUT) :: IBUF INTEGER :: I IBUF = -1 IF (NB_ACTIVE_SENDS .NE. MAX_ACTIVE_SENDS) THEN DO I=1, MAX_ACTIVE_SENDS IF (.NOT. IS_SEND_ACTIVE(I)) THEN IBUF = I EXIT ENDIF ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_DR_GET_NEW_BUF SUBROUTINE DMUMPS_DR_TRY_FREE_SEND() INTEGER :: MPI_STATUS(MPI_STATUS_SIZE) INTEGER :: I LOGICAL :: FLAG IF (NB_ACTIVE_SENDS .GT. 0) THEN DO I=1, MAX_ACTIVE_SENDS IF (IS_SEND_ACTIVE(I)) THEN CALL MPI_TEST( MPI_REQR(I), FLAG, MPI_STATUS, IERR_MPI ) IF (FLAG) THEN CALL MPI_WAIT(MPI_REQI(I), MPI_STATUS, IERR_MPI) NB_ACTIVE_SENDS = NB_ACTIVE_SENDS - 1 IS_SEND_ACTIVE(I)=.FALSE. IF (NB_ACTIVE_SENDS .EQ. 0) THEN RETURN ENDIF ENDIF ENDIF ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_DR_TRY_FREE_SEND SUBROUTINE DMUMPS_DR_TRY_SEND(IPROC_ARG) IMPLICIT NONE INTEGER, INTENT(IN) :: IPROC_ARG INCLUDE 'mumps_tags.h' INTEGER :: NBRECORDS, IBUF, I, K INTEGER(8) :: IPOSRHS INTEGER :: IPOSBUF IF (IPROC_ARG .EQ. MYID_NODES) THEN WRITE(*,*) "Internal error 1 in DMUMPS_DR_TRY_SEND" CALL MUMPS_ABORT() ENDIF IF (NBROWSTOSEND(IPROC_ARG+1) .EQ. 0) THEN WRITE(*,*) "Internal error 2 in DMUMPS_DR_TRY_SEND" CALL MUMPS_ABORT() ENDIF CALL DMUMPS_DR_GET_NEW_BUF(IBUF) IF (IBUF .GT. 0) THEN NBRECORDS = min(MAXRECORDS,NBROWSTOSEND(IPROC_ARG+1)) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS_COL*NBRECORDS !$ IF (CHUNK .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((CHUNK+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF IF (LSCAL) THEN !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) !$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG) DO K=1, NRHS_COL DO I = 1, NBRECORDS IPOSBUF = (K-1)*NBRECORDS IPOSRHS = int(K-1,8)*int(LRHS_loc,8) Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) BUFR( IPOSBUF + I, IBUF ) & = RHS_loc( IPOSRHS + Iloc ) #if defined(USE_OLD_SCALING) & * scaling_data_dr%SCALING_LOC(Iloc) #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) !$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG) DO K=1, NRHS_COL DO I = 1, NBRECORDS IPOSBUF = (K-1)*NBRECORDS IPOSRHS = int(K-1,8)*int(LRHS_loc,8) Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) BUFR( IPOSBUF + I, IBUF ) & = RHS_loc( IPOSRHS + Iloc ) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) & = IRHS_loc(Iloc) ENDDO CALL MPI_ISEND( IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)), & NBRECORDS, MPI_INTEGER, IPROC_ARG, DistRhsI, & COMM_NODES, MPI_REQI(IBUF), IERR_MPI ) CALL MPI_ISEND( BUFR(1,IBUF), NBRECORDS*NRHS_COL, & MPI_DOUBLE_PRECISION, & IPROC_ARG, DistRhsR, & COMM_NODES, MPI_REQR(IBUF), IERR_MPI ) NEXTROWTOSEND(IPROC_ARG+1)=NEXTROWTOSEND(IPROC_ARG+1)+ & NBRECORDS NBROWSTOSEND(IPROC_ARG+1)=NBROWSTOSEND(IPROC_ARG+1)-NBRECORDS NB_ACTIVE_SENDS = NB_ACTIVE_SENDS + 1 IS_SEND_ACTIVE(IBUF)=.TRUE. ENDIF RETURN END SUBROUTINE DMUMPS_DR_TRY_SEND SUBROUTINE DMUMPS_DR_EMPTY_ROWS() INTEGER :: K, IFS IF ( NB_FS_TOUCHED .NE. NB_FS_IN_RHSINTR ) THEN !$ OMP_FLAG = (NRHS_COL .GE. KEEP(362)) .AND. !$ & (NRHS_COL*NB_FS_IN_RHSINTR > KEEP(363)/2) !$OMP PARALLEL DO FIRSTPRIVATE(NB_FS_IN_RHSINTR) !$OMP& PRIVATE(IFS) IF (OMP_FLAG) DO K = 1, NRHS_COL DO IFS = 1, NB_FS_IN_RHSINTR IF ( .NOT. TOUCHED(IFS) ) THEN RHSINTR( IFS, K) = ZERO ENDIF ENDDO DO IFS = NB_FS_IN_RHSINTR +1, LD_RHSINTR RHSINTR (IFS, K) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$ OMP_FLAG = .FALSE. !$ CHUNK8 = int(NRHS_COL,8)*int(LD_RHSINTR-NB_FS_IN_RHSINTR,8) !$ CHUNK8 = max(CHUNK8,1_8) !$ IF (CHUNK8 .GE. int(KEEP(363),8)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK8 = max((CHUNK8+NOMP-1)/NOMP,int(KEEP(363)/2,8)) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK8) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS_COL DO IFS = NB_FS_IN_RHSINTR +1, LD_RHSINTR RHSINTR (IFS, K) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE DMUMPS_DR_EMPTY_ROWS END SUBROUTINE DMUMPS_SCATTER_DIST_RHS SUBROUTINE DMUMPS_SOL_INIT_IRHS_loc(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE (DMUMPS_STRUC) :: id INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ROW_OR_COL_INDICES INTEGER :: IERR_MPI LOGICAL :: I_AM_SLAVE INTEGER, POINTER :: idIRHS_loc(:) INTEGER, POINTER :: UNS_PERM(:) INTEGER :: UNS_PERM_TO_BE_DONE, I, allocok INTEGER, TARGET :: IDUMMY(1) INCLUDE 'mpif.h' NULLIFY(UNS_PERM) IF (id%JOB .NE. 9) THEN WRITE(*,*) "Internal error 1 in DMUMPS_SOL_INIT_IRHS_loc" CALL MUMPS_ABORT() ENDIF I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (id%MYID .EQ. MASTER) THEN IF (id%KEEP(50).NE.0) THEN ROW_OR_COL_INDICES = 0 ELSE IF (id%ICNTL(20).EQ.10 .OR. id%KEEP(50).EQ.0) THEN ROW_OR_COL_INDICES = 0 ELSE IF (id%ICNTL(20).EQ.11) THEN ROW_OR_COL_INDICES = 1 ELSE ROW_OR_COL_INDICES = 0 ENDIF IF (id%ICNTL(9) .NE. 1) THEN ROW_OR_COL_INDICES = 1 - ROW_OR_COL_INDICES ENDIF ENDIF IF (id%KEEP(23).NE.0 .AND. id%ICNTL(9) .NE.1) THEN UNS_PERM_TO_BE_DONE = 1 ELSE UNS_PERM_TO_BE_DONE = 0 ENDIF ENDIF CALL MPI_BCAST(ROW_OR_COL_INDICES,1,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) CALL MPI_BCAST(UNS_PERM_TO_BE_DONE,1,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) IF ( I_AM_SLAVE ) THEN IF (id%KEEP(89) .GT. 0) THEN IF (.NOT. associated(id%IRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=17 ELSE IF (size(id%IRHS_loc) < id%KEEP(89) ) THEN id%INFO(1)=-22 id%INFO(2)=17 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) goto 500 IF (I_AM_SLAVE) THEN IF (associated(id%IRHS_loc)) THEN IF (size(id%IRHS_loc) .GT. 0) THEN idIRHS_loc => id%IRHS_loc ELSE idIRHS_loc => IDUMMY ENDIF ELSE idIRHS_loc => IDUMMY ENDIF CALL MUMPS_GET_INDICES & (id%MYID_NODES, id%NSLAVES, id%N, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), id%IS(1), & max(1, id%KEEP(32)), & id%STEP(1), id%PROCNODE_STEPS(1), idIRHS_loc(1), & ROW_OR_COL_INDICES) ENDIF IF (UNS_PERM_TO_BE_DONE .EQ. 1) THEN IF (id%MYID.NE.MASTER) THEN ALLOCATE(UNS_PERM(id%N),stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=id%N GOTO 100 ENDIF ENDIF 100 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) GOTO 500 IF ( id%MYID .EQ. MASTER ) THEN UNS_PERM => id%UNS_PERM ENDIF CALL MPI_BCAST(UNS_PERM(1),id%N,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) IF (I_AM_SLAVE .AND. id%KEEP(89) .NE.0) THEN DO I=1, id%KEEP(89) id%IRHS_loc(I)=UNS_PERM(id%IRHS_loc(I)) ENDDO ENDIF ENDIF 500 CONTINUE IF (id%MYID.NE.MASTER) THEN IF (associated(UNS_PERM)) DEALLOCATE(UNS_PERM) ENDIF NULLIFY(UNS_PERM) RETURN END SUBROUTINE DMUMPS_SOL_INIT_IRHS_loc MUMPS_5.8.1/src/smumps_save_restore.F0000664000175000017500000127243515042446437017470 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if ! defined(NO_SAVE_RESTORE) MODULE SMUMPS_SAVE_RESTORE USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_INTR_STRUC USE SMUMPS_SAVE_RESTORE_FILES USE MUMPS_FRONT_DATA_MGT_M IMPLICIT NONE INCLUDE 'mumps_save_restore_modes.h' CONTAINS SUBROUTINE SMUMPS_REMOVE_SAVED(id) USE SMUMPS_OOC IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MASTER PARAMETER ( MASTER = 0 ) TYPE (SMUMPS_STRUC) :: id CHARACTER(len=LEN_SAVE_FILE) :: RESTOREFILE, INFOFILE INTEGER :: fileunit, ierr, SIZE_INT, SIZE_INT8 INTEGER(8) :: size_read, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE INTEGER :: READ_OOC_FILE_NAME_LENGTH,READ_SYM,READ_PAR,READ_NPROCS CHARACTER(len=LEN_SAVE_FILE) :: READ_OOC_FIRST_FILE_NAME CHARACTER :: READ_ARITH LOGICAL :: READ_INT_TYPE_64 CHARACTER(len=23) :: READ_HASH LOGICAL :: FORTRAN_VERSION_OK LOGICAL :: SAME_OOC INTEGER :: ICNTL34, MAX_LENGTH, FLAG_SAME, SUM_FLAG_SAME TYPE (SMUMPS_STRUC) :: localid ierr = 0 call SMUMPS_GET_SAVE_FILES(id,RESTOREFILE,INFOFILE) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(fileunit) IF ( fileunit .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=fileunit,FILE=RESTOREFILE #if ! defined(MUMPS_NOF2003) & ,ACCESS="stream" #endif & ,STATUS='old',FORM='unformatted',IOSTAT=ierr) IF ( ierr.ne.0 ) THEN id%INFO(1) = -76 id%INFO(2) = id%MYID endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_INT = id%KEEP(34) SIZE_INT8 = id%KEEP(34)*id%KEEP(10) size_read = 0_8 call MUMPS_READ_HEADER(fileunit,ierr,size_read,SIZE_INT, & SIZE_INT8, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE, & READ_ARITH, READ_INT_TYPE_64, & READ_OOC_FILE_NAME_LENGTH, READ_OOC_FIRST_FILE_NAME, & READ_HASH,READ_SYM,READ_PAR,READ_NPROCS, & FORTRAN_VERSION_OK) close(fileunit) if (ierr.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) elseif (.NOT.FORTRAN_VERSION_OK) THEN id%INFO(1) = -73 id%INFO(2) = 1 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL SMUMPS_CHECK_HEADER(id,.TRUE.,READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) IF ( id%INFO(1) .LT. 0 ) RETURN ICNTL34 = -99998 IF (id%MYID.EQ.MASTER) THEN ICNTL34 = id%ICNTL(34) ENDIF CALL MPI_BCAST( ICNTL34, 1, MPI_INTEGER, MASTER, id%COMM, ierr ) CALL MPI_BCAST( READ_SYM, 1, MPI_INTEGER, MASTER, id%COMM, ierr ) CALL SMUMPS_CHECK_FILE_NAME(id, READ_OOC_FILE_NAME_LENGTH, & READ_OOC_FIRST_FILE_NAME, SAME_OOC) CALL MPI_ALLREDUCE(READ_OOC_FILE_NAME_LENGTH,MAX_LENGTH,1, & MPI_INTEGER,MPI_MAX,id%COMM,ierr) IF (MAX_LENGTH.NE.-999) THEN FLAG_SAME = 0 IF (SAME_OOC) THEN FLAG_SAME = 1 ENDIF CALL MPI_ALLREDUCE(FLAG_SAME,SUM_FLAG_SAME,1, & MPI_INTEGER,MPI_SUM,id%COMM,ierr) IF (SUM_FLAG_SAME.NE.0) THEN IF (ICNTL34 .EQ. 1) THEN id%ASSOCIATED_OOC_FILES = .TRUE. ELSE id%ASSOCIATED_OOC_FILES = .FALSE. ENDIF ELSE IF (ICNTL34 .NE. 1) THEN localid%COMM = id%COMM localid%INFO(1) = 0 localid%ICNTL(1) = id%ICNTL(1) localid%MYID = id%MYID localid%NPROCS = id%NPROCS localid%KEEP(10) = id%KEEP(10) localid%SAVE_PREFIX = id%SAVE_PREFIX localid%SAVE_DIR = id%SAVE_DIR call SMUMPS_RESTORE_OOC(localid) IF ( localid%INFO(1) .EQ. 0 ) THEN localid%ASSOCIATED_OOC_FILES = .FALSE. IF (READ_OOC_FILE_NAME_LENGTH.NE.-999) THEN call SMUMPS_OOC_CLEAN_FILES(localid,ierr) IF ( ierr.ne.0 ) THEN id%INFO(1) = -90 id%INFO(2) = id%MYID ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN ENDIF ENDIF ENDIF call MUMPS_CLEAN_SAVED_DATA(id%MYID,ierr,RESTOREFILE,INFOFILE) IF (ierr.eq.-79) THEN id%INFO(1) = -79 id%INFO(2) = 2 ELSE IF (ierr.ne.0) THEN id%INFO(1) = -76 id%INFO(2) = id%MYID ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) RETURN END SUBROUTINE SMUMPS_REMOVE_SAVED SUBROUTINE SMUMPS_RESTORE_OOC(localid) IMPLICIT NONE INCLUDE 'mpif.h' TYPE (SMUMPS_STRUC) :: localid INTEGER::ierr,IN,NBVARIABLES,NBVARIABLES_ROOTC CHARACTER(len=LEN_SAVE_FILE):: restore_file_ooc,INFO_FILE INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOTC INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOTC INTEGER:: INFO1,INFO2,INFOG1,INFOG2,allocok INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE TYPE (SMUMPS_INTR_STRUC) :: localidintr NBVARIABLES=194 NBVARIABLES_ROOTC=20 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOTC(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOTC(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL SMUMPS_GET_SAVE_FILES(localid,restore_file_ooc,INFO_FILE) IF ( localid%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(IN) IF ( IN .EQ. -1 ) THEN localid%INFO(1) = -79 localid%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN open(UNIT=IN,FILE=restore_file_ooc #if ! defined(MUMPS_NOF2003) & ,ACCESS="stream" #endif & ,STATUS='old',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN localid%INFO(1) = -74 localid%INFO(2) = localid%MYID endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN CALL SMUMPS_SAVE_RESTORE_STRUCTURE(localid,localidintr,IN & ,restore_ooc_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) CLOSE(IN) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOTC) deallocate(SIZE_GEST,SIZE_GEST_ROOTC) RETURN END SUBROUTINE SMUMPS_RESTORE_OOC SUBROUTINE SMUMPS_COMPUTE_MEMORY_SAVE(id,idintr, & TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE) IMPLICIT NONE INCLUDE 'mpif.h' TYPE (SMUMPS_STRUC) :: id TYPE (SMUMPS_INTR_STRUC) :: idintr INTEGER::NBVARIABLES,NBVARIABLES_ROOTC INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOTC INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOTC INTEGER :: INFO1,INFO2,INFOG1,INFOG2,allocok INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE NBVARIABLES=194 NBVARIABLES_ROOTC=20 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOTC(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOTC(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL SMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,0,memory_save_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOTC) deallocate(SIZE_GEST,SIZE_GEST_ROOTC) RETURN END SUBROUTINE SMUMPS_COMPUTE_MEMORY_SAVE SUBROUTINE SMUMPS_SAVE(id,idintr) IMPLICIT NONE INCLUDE 'mpif.h' TYPE (SMUMPS_STRUC) :: id TYPE (SMUMPS_INTR_STRUC) :: idintr INTEGER::ierr,OUT,NBVARIABLES,NBVARIABLES_ROOTC,OUTINFO CHARACTER(len=LEN_SAVE_FILE):: SAVE_FILE,INFO_FILE LOGICAL:: SAVE_FILE_exist,INFO_FILE_exist INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOTC INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOTC INTEGER:: INFO1,INFO2,INFOG1,INFOG2,MPG INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: PROKG INTEGER :: I,J,K,H,allocok CHARACTER(len=1) :: TMP_OOC_NAMES(350) INFO1 = id%INFO(1) INFO2 = id%INFO(2) INFOG1 = id%INFO(1) INFOG2 = id%INFO(1) id%INFO(1)=0 id%INFO(2)=0 id%INFOG(1)=0 id%INFOG(2)=0 MPG= id%ICNTL(3) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. 0 ) NBVARIABLES=194 NBVARIABLES_ROOTC=20 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOTC(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOTC(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 TMP_OOC_NAMES(:)="?" CALL SMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,0,memory_save_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) CALL SMUMPS_GET_SAVE_FILES(id,SAVE_FILE,INFO_FILE) IF ( id%INFO(1) .LT. 0 ) RETURN inquire(FILE=SAVE_FILE, EXIST=SAVE_FILE_exist) IF(SAVE_FILE_exist) THEN id%INFO(1) = -70 id%INFO(2) = 0 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(OUT) IF ( OUT .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=OUT,FILE=SAVE_FILE #if ! defined(MUMPS_NOF2003) & ,ACCESS="stream" #endif & ,STATUS='new',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -71 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN inquire(FILE=INFO_FILE, EXIST=INFO_FILE_exist) IF(INFO_FILE_exist) THEN id%INFO(1) = -70 id%INFO(2) = 0 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(OUTINFO) IF ( OUTINFO .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=OUTINFO,FILE=INFO_FILE,STATUS='new',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -71 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL SMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,OUT,save_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) if (id%INFO(1).EQ.0) then id%INFO(1)=INFO1 id%INFO(2)=INFO2 id%INFOG(1)=INFOG1 id%INFOG(2)=INFOG2 CLOSE(OUT) if(id%INFOG(1).NE.0) then if (PROKG) THEN write(MPG,*) "Warning: " & ,"saved instance has negative INFO(1):" & , id%INFOG(1) endif endif IF(PROKG) THEN write(MPG,*) "Save done successfully" IF(id%KEEP(201).EQ.1) THEN K=1 write(MPG,*) "The corresponding OOC files are:" DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(MPG,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF ENDIF write(OUTINFO,*) "Save done by SMUMPS ", & trim(adjustl(id%VERSION_NUMBER)), & " after JOB=",id%KEEP(40)+456789, & " With SYM, PAR =",id%KEEP(50),id%KEEP(46) write(OUTINFO,*) "On ",id%NPROCS," processes" if((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ.0)) then write(OUTINFO,*) "with N, NNZ ", id%N, id%NNZ elseif((id%ICNTL(18).EQ.1).AND.(id%ICNTL(5).EQ. 0)) then write(OUTINFO,*) "with N, NNZ_loc=", id%N, id%NNZ_loc elseif((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ. 1)) then write(OUTINFO,*) "with N, NELT=", id%N, id%NELT endif IF(id%KEEP(10).EQ.1) THEN write(OUTINFO,*) "With a default integer size of 64 bits" ELSE write(OUTINFO,*) "With a default integer size of 32 bits" ENDIF #if defined(MUMPS_NOF2003) write(OUTINFO,*) "Using MUMPS_NOF2003" #endif write(OUTINFO,*) '' write(OUTINFO,*) "The corresponding save file is:" write(OUTINFO,*) trim(adjustl(SAVE_FILE)) write(OUTINFO,*) "of size",TOTAL_FILE_SIZE, " Bytes" IF(id%KEEP(201).EQ.1) THEN write(OUTINFO,*) '' write(OUTINFO,*) "The corresponding OOC files are:" K=1 DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(OUTINFO,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF CLOSE(OUTINFO) else CLOSE(OUT,STATUS='delete') CLOSE(OUTINFO,STATUS='delete') endif deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOTC) deallocate(SIZE_GEST,SIZE_GEST_ROOTC) if (id%KEEP(201) .GT. 0) THEN id%ASSOCIATED_OOC_FILES=.TRUE. ENDIF RETURN END SUBROUTINE SMUMPS_SAVE SUBROUTINE SMUMPS_RESTORE(id,idintr) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER::ierr,IN,NBVARIABLES,NBVARIABLES_ROOTC CHARACTER(len=LEN_SAVE_FILE):: restore_file,INFO_FILE INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOTC INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOTC INTEGER:: INFO1,INFO2,INFOG1,INFOG2,MPG,MP,JOB INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: PROKG INTEGER :: I,J,K,H,allocok CHARACTER(len=1) :: TMP_OOC_NAMES(350) TYPE (SMUMPS_STRUC) :: id TYPE (SMUMPS_INTR_STRUC) :: idintr NBVARIABLES=194 NBVARIABLES_ROOTC=20 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOTC(NBVARIABLES_ROOTC), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOTC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOTC(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOTC(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 TMP_OOC_NAMES(:)="?" INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL SMUMPS_GET_SAVE_FILES(id,restore_file,INFO_FILE) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_FIND_UNIT(IN) IF ( IN .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=IN,FILE=restore_file #if ! defined(MUMPS_NOF2003) & ,ACCESS="stream" #endif & ,STATUS='old',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -74 id%INFO(2) = id%MYID endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN MP= id%ICNTL(2) MPG= id%ICNTL(3) CALL SMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,IN,restore_mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. 0 ) if(id%INFO(1).EQ.0) then id%INFO(1)=INFO1 id%INFO(2)=INFO2 id%INFOG(1)=INFOG1 id%INFOG(2)=INFOG2 if(id%INFOG(1).NE.0) then write(MPG,*) "Warning: " & ,"restored instance has negative INFOG(1):" & , id%INFOG(1) endif if(MP.GT.0) then JOB=id%KEEP(40)+456789 write(MP,*) "Restore done successfully" write(MP,*) "From file ",trim(adjustl(restore_file)) if((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ.0)) then write(MP,*) "with JOB, N, NNZ ",JOB, id%N,id%NNZ elseif((id%ICNTL(18).EQ.1).AND.(id%ICNTL(5).EQ. 0)) then write(MP,*) "with JOB, N, NNZ_loc=", JOB, id%N, & id%NNZ_loc elseif((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ. 1)) then write(MP,*) "with JOB, N, NELT=", JOB, id%N, id%NELT endif endif IF(PROKG) THEN IF(id%KEEP(201).EQ.1) THEN K=1 write(MPG,*) "The corresponding OOC files are:" DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(MPG,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF ENDIF else idintr%root%gridinit_done=.FALSE. id%KEEP(140)=1 endif CLOSE(IN) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOTC) deallocate(SIZE_GEST,SIZE_GEST_ROOTC) if (id%KEEP(201) .GT. 0) THEN id%ASSOCIATED_OOC_FILES=.TRUE. ENDIF RETURN END SUBROUTINE SMUMPS_RESTORE SUBROUTINE SMUMPS_SAVE_RESTORE_STRUCTURE(id,idintr,unit,mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOTC,SIZE_VARIABLES_ROOTC,SIZE_GEST_ROOTC & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) USE SMUMPS_FACSOL_L0OMP_M, ONLY : SMUMPS_SAVE_RESTORE_L0FACARRAY USE SMUMPS_LR_DATA_M, ONLY: SMUMPS_SAVE_RESTORE_BLR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER, intent(in) ::unit,NBVARIABLES,NBVARIABLES_ROOTC INTEGER, intent(in) :: mode INTEGER(8),dimension(NBVARIABLES)::SIZE_VARIABLES INTEGER(8),dimension(NBVARIABLES_ROOTC)::SIZE_VARIABLES_ROOTC INTEGER,dimension(NBVARIABLES)::SIZE_GEST INTEGER,dimension(NBVARIABLES_ROOTC)::SIZE_GEST_ROOTC INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER:: INFO1,INFO2,INFOG1,INFOG2 INTEGER:: j,i1,i2,err,ierr CHARACTER :: ARITH,READ_ARITH INTEGER(8) :: size_written,gest_size,WRITTEN_STRUC_SIZE INTEGER:: SIZE_INT, SIZE_INT8, SIZE_RL_OR_DBL, SIZE_ARITH_DEP INTEGER:: SIZE_DOUBLE_PRECISION, SIZE_LOGICAL, SIZE_CHARACTER INTEGER:: READ_NPROCS, READ_PAR, READ_SYM INTEGER,dimension(NBVARIABLES)::NbRecords INTEGER,dimension(NBVARIABLES_ROOTC)::NbRecords_ROOTC INTEGER:: size_array1,size_array2,dummy,allocok INTEGER(8):: size_array_INT8_1,size_array_INT8_2 LOGICAL:: INT_TYPE_64, READ_INT_TYPE_64, CALL_SAVE_RESTORE_BLR INTEGER:: tot_NbRecords,NbSubRecords INTEGER(8):: size_read,size_allocated INTEGER(8),dimension(NBVARIABLES)::DIFF_SIZE_ALLOC_READ INTEGER(8),dimension(NBVARIABLES_ROOTC):: & DIFF_SIZE_ALLOC_READ_ROOTC INTEGER::READ_OOC_FILE_NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE):: READ_OOC_FIRST_FILE_NAME INTEGER,dimension(4)::OOC_INDICES CHARACTER(len=8) :: date CHARACTER(len=10) :: time CHARACTER(len=5) :: zone INTEGER,dimension(8):: values CHARACTER(len=23) :: hash,READ_HASH LOGICAL:: BASIC_CHECK LOGICAL :: FORTRAN_VERSION_OK CHARACTER(len=1) :: TMP_OOC_NAMES(350) INTEGER(8)::SIZE_VARIABLES_BLR,SIZE_VARIABLES_FRONT_DATA, & SIZE_VARIABLES_L0FAC INTEGER :: SIZE_GEST_ROOTA INTEGER(8) :: SIZE_VARIABLES_ROOTA INTEGER::SIZE_GEST_BLR,SIZE_GEST_FRONT_DATA,SIZE_GEST_L0FAC INTEGER :: KEEP410_SAVE, KEEP411_SAVE INTEGER(8) :: KEEP883_SAVE, KEEP884_SAVE INTEGER(4) :: I4 LOGICAL :: IS_SYMMETRIC TYPE (SMUMPS_STRUC) :: id TYPE (SMUMPS_INTR_STRUC) :: idintr INTEGER, PARAMETER :: S_ASSOCIATED_OOC_FILES=194 INTEGER, PARAMETER :: S_pad16=193 INTEGER, PARAMETER :: S_Deficiency=192 INTEGER, PARAMETER :: S_NB_SINGULAR_VALUES=191 INTEGER, PARAMETER :: S_SINGULAR_VALUES=190 INTEGER, PARAMETER :: S_MTKO_PROCS_MAP=189 INTEGER, PARAMETER :: S_L0_OMP_MAPPING=188 INTEGER, PARAMETER :: S_PTR_LEAFS_L0_OMP=187 INTEGER, PARAMETER :: S_PERM_L0_OMP=186 INTEGER, PARAMETER :: S_VIRT_L0_OMP_MAPPING=185 INTEGER, PARAMETER :: S_VIRT_L0_OMP=184 INTEGER, PARAMETER :: S_PHYS_L0_OMP=183 INTEGER, PARAMETER :: S_IPOOL_A_L0_OMP=182 INTEGER, PARAMETER :: S_IPOOL_B_L0_OMP=181 INTEGER, PARAMETER :: S_I8_L0_OMP=180 INTEGER, PARAMETER :: S_I4_L0_OMP=179 INTEGER, PARAMETER :: S_THREAD_LA=178 INTEGER, PARAMETER :: S_LL0_OMP_FACTORS=177 INTEGER, PARAMETER :: S_LL0_OMP_MAPPING=176 INTEGER, PARAMETER :: S_L_VIRT_L0_OMP=175 INTEGER, PARAMETER :: S_L_PHYS_L0_OMP=174 INTEGER, PARAMETER :: S_LPOOL_B_L0_OMP=173 INTEGER, PARAMETER :: S_LPOOL_A_L0_OMP=172 INTEGER, PARAMETER :: S_BLRARRAY_ENCODING=171 INTEGER, PARAMETER :: S_FDM_F_ENCODING=170 INTEGER, PARAMETER :: S_pad13=169 INTEGER, PARAMETER :: S_NBGRP=168 INTEGER, PARAMETER :: S_LRGROUPS=167 INTEGER, PARAMETER :: S_INTR_ENCODING=166 INTEGER, PARAMETER :: S_WORKING=165 INTEGER, PARAMETER :: S_IPTR_WORKING=164 INTEGER, PARAMETER :: S_pad14=163 INTEGER, PARAMETER :: S_SUP_PROC=162 INTEGER, PARAMETER :: S_PIVNUL_LIST=161 INTEGER, PARAMETER :: S_OOC_FILE_NAMES=160 INTEGER, PARAMETER :: S_OOC_FILE_NAME_LENGTH=159 INTEGER, PARAMETER :: S_pad12=158 INTEGER, PARAMETER :: S_OOC_NB_FILE_TYPE=157 INTEGER, PARAMETER :: S_OOC_NB_FILES=156 INTEGER, PARAMETER :: S_OOC_TOTAL_NB_NODES=155 INTEGER, PARAMETER :: S_OOC_VADDR=154 INTEGER, PARAMETER :: S_OOC_SIZE_OF_BLOCK=153 INTEGER, PARAMETER :: S_OOC_INODE_SEQUENCE=152 INTEGER, PARAMETER :: S_OOC_MAX_NB_NODES_FOR_ZONE=151 INTEGER, PARAMETER :: S_INSTANCE_NUMBER=150 INTEGER, PARAMETER :: S_CB_SON_SIZE=149 INTEGER, PARAMETER :: S_DKEEP=148 INTEGER, PARAMETER :: S_LWK_USER=147 INTEGER, PARAMETER :: S_NBSA_LOCAL=146 INTEGER, PARAMETER :: S_WK_USER=145 INTEGER, PARAMETER :: S_CROIX_MANU=144 INTEGER, PARAMETER :: S_SCHED_SBTR=143 INTEGER, PARAMETER :: S_SCHED_GRP=142 INTEGER, PARAMETER :: S_SCHED_DEP=141 INTEGER, PARAMETER :: S_SBTR_ID=140 INTEGER, PARAMETER :: S_DEPTH_FIRST_SEQ=139 INTEGER, PARAMETER :: S_DEPTH_FIRST=138 INTEGER, PARAMETER :: S_MY_NB_LEAF=137 INTEGER, PARAMETER :: S_MY_FIRST_LEAF=136 INTEGER, PARAMETER :: S_MY_ROOT_SBTR=135 INTEGER, PARAMETER :: S_COST_TRAV=134 INTEGER, PARAMETER :: S_MEM_SUBTREE=133 INTEGER, PARAMETER :: S_RHSINTR=132 INTEGER, PARAMETER :: S_GLOB2LOC_SOL=131 INTEGER, PARAMETER :: S_pad11=130 INTEGER, PARAMETER :: S_GLOB2LOC_SOL_ALLOC=129 INTEGER, PARAMETER :: S_GLOB2LOC_RHS=128 INTEGER, PARAMETER :: S_MEM_DIST=127 INTEGER, PARAMETER :: S_I_AM_CAND=126 INTEGER, PARAMETER :: S_TAB_POS_IN_PERE=125 INTEGER, PARAMETER :: S_FUTURE_NIV2=124 INTEGER, PARAMETER :: S_ISTEP_TO_INIV2=123 INTEGER, PARAMETER :: S_CANDIDATES=122 INTEGER, PARAMETER :: S_ELTPROC=121 INTEGER, PARAMETER :: S_LELTVAR=120 INTEGER, PARAMETER :: S_NELT_loc=119 INTEGER, PARAMETER :: S_PROCNODE=118 INTEGER, PARAMETER :: S_LPS=117 INTEGER, PARAMETER :: S_S=116 INTEGER, PARAMETER :: S_PTRFAC=115 INTEGER, PARAMETER :: S_PTLUST_S=114 INTEGER, PARAMETER :: S_Step2node=113 INTEGER, PARAMETER :: S_PROCNODE_STEPS=112 INTEGER, PARAMETER :: S_NA=111 INTEGER, PARAMETER :: S_PTRDEBARR=110 INTEGER, PARAMETER :: S_NINROWARR=109 INTEGER, PARAMETER :: S_NINCOLARR=108 INTEGER, PARAMETER :: S_PTR8ARR=107 INTEGER, PARAMETER :: S_PTRAR=106 INTEGER, PARAMETER :: S_FRTELT=105 INTEGER, PARAMETER :: S_FRTPTR=104 INTEGER, PARAMETER :: S_FILS=103 INTEGER, PARAMETER :: S_DAD_STEPS=102 INTEGER, PARAMETER :: S_FRERE_STEPS=101 INTEGER, PARAMETER :: S_ND_STEPS=100 INTEGER, PARAMETER :: S_NE_STEPS=99 INTEGER, PARAMETER :: S_STEP=98 INTEGER, PARAMETER :: S_NBSA=97 INTEGER, PARAMETER :: S_LNA=96 INTEGER, PARAMETER :: S_KEEP=95 INTEGER, PARAMETER :: S_IS=94 INTEGER, PARAMETER :: S_ASS_IRECV=93 INTEGER, PARAMETER :: S_NSLAVES=92 INTEGER, PARAMETER :: S_NPROCS=91 INTEGER, PARAMETER :: S_MYID=90 INTEGER, PARAMETER :: S_COMM_LOAD=89 INTEGER, PARAMETER :: S_MYID_NODES=88 INTEGER, PARAMETER :: S_COMM_NODES=87 INTEGER, PARAMETER :: S_INST_Number=86 INTEGER, PARAMETER :: S_MAX_SURF_MASTER=85 INTEGER, PARAMETER :: S_KEEP8=84 INTEGER, PARAMETER :: S_pad7=83 INTEGER, PARAMETER :: S_SAVE_PREFIX=82 INTEGER, PARAMETER :: S_SAVE_DIR=81 INTEGER, PARAMETER :: S_WRITE_PROBLEM=80 INTEGER, PARAMETER :: S_OOC_PREFIX=79 INTEGER, PARAMETER :: S_OOC_TMPDIR=78 INTEGER, PARAMETER :: S_VERSION_NUMBER=77 INTEGER, PARAMETER :: S_MAPPING=76 INTEGER, PARAMETER :: S_LISTVAR_SCHUR=75 INTEGER, PARAMETER :: S_SCHUR_CINTERFACE=74 INTEGER, PARAMETER :: S_SCHUR=73 INTEGER, PARAMETER :: S_SIZE_SCHUR=72 INTEGER, PARAMETER :: S_SCHUR_LLD=71 INTEGER, PARAMETER :: S_SCHUR_NLOC=70 INTEGER, PARAMETER :: S_SCHUR_MLOC=69 INTEGER, PARAMETER :: S_NBLOCK=68 INTEGER, PARAMETER :: S_MBLOCK=67 INTEGER, PARAMETER :: S_NPCOL=66 INTEGER, PARAMETER :: S_NPROW=65 INTEGER, PARAMETER :: S_UNS_PERM=64 INTEGER, PARAMETER :: S_SYM_PERM=63 INTEGER, PARAMETER :: S_METIS_OPTIONS=62 INTEGER, PARAMETER :: S_RINFOG=61 INTEGER, PARAMETER :: S_RINFO=60 INTEGER, PARAMETER :: S_CNTL=59 INTEGER, PARAMETER :: S_COST_SUBTREES=58 INTEGER, PARAMETER :: S_INFOG=57 INTEGER, PARAMETER :: S_INFO=56 INTEGER, PARAMETER :: S_ICNTL=55 INTEGER, PARAMETER :: S_pad6=54 INTEGER, PARAMETER :: S_LD_RHSINTR=53 INTEGER, PARAMETER :: S_NSOL_loc=52 INTEGER, PARAMETER :: S_LSOL_loc=51 INTEGER, PARAMETER :: S_LREDRHS=50 INTEGER, PARAMETER :: S_LRHS_loc=49 INTEGER, PARAMETER :: S_Nloc_RHS=48 INTEGER, PARAMETER :: S_NZ_RHS=47 INTEGER, PARAMETER :: S_NRHS=46 INTEGER, PARAMETER :: S_LRHS=45 INTEGER, PARAMETER :: S_IRHS_loc=44 INTEGER, PARAMETER :: S_ISOL_loc=43 INTEGER, PARAMETER :: S_IRHS_PTR=42 INTEGER, PARAMETER :: S_IRHS_SPARSE=41 INTEGER, PARAMETER :: S_RHS_loc=40 INTEGER, PARAMETER :: S_SOL_loc=39 INTEGER, PARAMETER :: S_RHS_SPARSE=38 INTEGER, PARAMETER :: S_REDRHS=37 INTEGER, PARAMETER :: S_RHS=36 INTEGER, PARAMETER :: S_BLKVAR=35 INTEGER, PARAMETER :: S_BLKPTR=34 INTEGER, PARAMETER :: S_pad5=33 INTEGER, PARAMETER :: S_NBLK=32 INTEGER, PARAMETER :: S_PERM_IN=31 INTEGER, PARAMETER :: S_pad4=30 INTEGER, PARAMETER :: S_A_ELT=29 INTEGER, PARAMETER :: S_ELTVAR=28 INTEGER, PARAMETER :: S_ELTPTR=27 INTEGER, PARAMETER :: S_pad3=26 INTEGER, PARAMETER :: S_NELT=25 INTEGER, PARAMETER :: S_pad2=24 INTEGER, PARAMETER :: S_A_loc=23 INTEGER, PARAMETER :: S_JCN_loc=22 INTEGER, PARAMETER :: S_IRN_loc=21 INTEGER, PARAMETER :: S_NNZ_loc=20 INTEGER, PARAMETER :: S_pad1=19 INTEGER, PARAMETER :: S_NZ_loc=18 INTEGER, PARAMETER :: S_PIVOTS=17 INTEGER, PARAMETER :: S_COLIND=16 INTEGER, PARAMETER :: S_ROWIND=15 INTEGER, PARAMETER :: S_ROWSCA_loc=14 INTEGER, PARAMETER :: S_COLSCA_loc=13 INTEGER, PARAMETER :: S_ROWSCA=12 INTEGER, PARAMETER :: S_COLSCA=11 INTEGER, PARAMETER :: S_JCN=10 INTEGER, PARAMETER :: S_IRN=9 INTEGER, PARAMETER :: S_A=8 INTEGER, PARAMETER :: S_NNZ=7 INTEGER, PARAMETER :: S_NZ=6 INTEGER, PARAMETER :: S_N=5 INTEGER, PARAMETER :: S_JOB=4 INTEGER, PARAMETER :: S_PAR=3 INTEGER, PARAMETER :: S_SYM=2 INTEGER, PARAMETER :: S_COMM=1 INTEGER, PARAMETER :: R_gridinit_done=20 INTEGER, PARAMETER :: R_yes=19 INTEGER, PARAMETER :: R_RG2L=18 INTEGER, PARAMETER :: R_IPIV=17 INTEGER, PARAMETER :: R_NB_SINGULAR_VALUES=16 INTEGER, PARAMETER :: R_LPIV=15 INTEGER, PARAMETER :: R_CNTXT_BLACS=14 INTEGER, PARAMETER :: R_DESCRIPTOR=13 INTEGER, PARAMETER :: R_TOT_ROOT_SIZE=12 INTEGER, PARAMETER :: R_ROOT_SIZE=11 INTEGER, PARAMETER :: R_RHS_NLOC=10 INTEGER, PARAMETER :: R_SCHUR_LLD=9 INTEGER, PARAMETER :: R_SCHUR_NLOC=8 INTEGER, PARAMETER :: R_SCHUR_MLOC=7 INTEGER, PARAMETER :: R_MYCOL=6 INTEGER, PARAMETER :: R_MYROW=5 INTEGER, PARAMETER :: R_NPCOL=4 INTEGER, PARAMETER :: R_NPROW=3 INTEGER, PARAMETER :: R_NBLOCK=2 INTEGER, PARAMETER :: R_MBLOCK=1 OOC_INDICES=(/156,157,159,160/) SIZE_INT = id%KEEP(34) SIZE_INT8 = id%KEEP(34)*id%KEEP(10) SIZE_RL_OR_DBL = id%KEEP(150) SIZE_ARITH_DEP = id%KEEP(149) SIZE_DOUBLE_PRECISION = 8 SIZE_LOGICAL = 4 SIZE_CHARACTER = 1 size_written=int(0,kind=8) tot_NbRecords=0 NbRecords(:)=0 NbRecords_ROOTC(:)=0 size_read=int(0,kind=8) size_allocated=int(0,kind=8) DIFF_SIZE_ALLOC_READ(:)=0 DIFF_SIZE_ALLOC_READ_ROOTC(:)=0 WRITTEN_STRUC_SIZE=int(0,kind=8) TMP_OOC_NAMES(:)="?" SIZE_VARIABLES_BLR=0_8 SIZE_GEST_BLR=0 SIZE_VARIABLES_FRONT_DATA=0_8 SIZE_GEST_FRONT_DATA=0 SIZE_VARIABLES_L0FAC=0 SIZE_GEST_L0FAC=0 if(mode.EQ.memory_save_mode) then elseif(mode.EQ.save_mode) then write(unit,iostat=err) "MUMPS" if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(5*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(id%MYID.EQ.0) THEN call date_and_time(date,time,zone,values) hash=trim(date)//trim(time)//trim(zone) ENDIF CALL MPI_BCAST( hash, 23, MPI_CHARACTER, 0, id%COMM, ierr ) write(unit,iostat=err) hash if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(23*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(2*SIZE_INT8,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ARITH="SMUMPS"(1:1) write(unit,iostat=err) ARITH if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(1,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) id%SYM,id%PAR,id%NPROCS if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(3*SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(id%KEEP(10).EQ.1) THEN INT_TYPE_64=.TRUE. ELSE INT_TYPE_64=.FALSE. ENDIF write(unit,iostat=err) INT_TYPE_64 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_LOGICAL,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(associated(id%OOC_FILE_NAME_LENGTH).AND. & associated(id%OOC_FILE_NAMES)) THEN write(unit,iostat=err) id%OOC_FILE_NAME_LENGTH(1) if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(1))= & id%OOC_FILE_NAMES(1,1:id%OOC_FILE_NAME_LENGTH(1)) write(unit,iostat=err) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(1)) if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written & +int(id%OOC_FILE_NAME_LENGTH(1)*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ELSE write(unit,iostat=err) -999 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) -999 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ENDIF elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then CALL MUMPS_READ_HEADER(unit,err,size_read,SIZE_INT,SIZE_INT8, & TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE, READ_ARITH, & READ_INT_TYPE_64, READ_OOC_FILE_NAME_LENGTH, & READ_OOC_FIRST_FILE_NAME,READ_HASH, & READ_SYM,READ_PAR,READ_NPROCS,FORTRAN_VERSION_OK) if (err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) elseif (.NOT.FORTRAN_VERSION_OK) THEN id%INFO(1) = -73 id%INFO(2) = 1 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 BASIC_CHECK = .false. IF (mode.EQ.restore_ooc_mode) THEN BASIC_CHECK = .true. ENDIF CALL SMUMPS_CHECK_HEADER(id,BASIC_CHECK,READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) IF (id%INFO(1) .LT. 0) GOTO 100 elseif(mode.EQ.fake_restore_mode) then read(unit,iostat=err) READ_HASH if(err.ne.0) GOTO 100 read(unit,iostat=err) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(err.ne.0) GOTO 100 IF ( id%INFO(1) .LT. 0 ) GOTO 100 GOTO 200 else CALL MUMPS_ABORT() endif DO j=1,size(OOC_INDICES) i1=OOC_INDICES(j) SELECT CASE(i1) CASE(S_OOC_NB_FILES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_NB_FILES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%OOC_NB_FILES,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_NB_FILES)) THEN write(unit,iostat=err) size(id%OOC_NB_FILES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_NB_FILES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then nullify(id%OOC_NB_FILES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_NB_FILES(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_NB_FILES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_NB_FILE_TYPE) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%OOC_NB_FILE_TYPE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%OOC_NB_FILE_TYPE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_FILE_NAMES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_FILE_NAMES)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_FILE_NAMES,1) & *size(id%OOC_FILE_NAMES,2)*SIZE_CHARACTER ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_FILE_NAMES)) THEN write(unit,iostat=err) size(id%OOC_FILE_NAMES,1) & ,size(id%OOC_FILE_NAMES,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_FILE_NAMES ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then nullify(id%OOC_FILE_NAMES) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2 & *SIZE_CHARACTER allocate(id%OOC_FILE_NAMES(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_FILE_NAMES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_FILE_NAME_LENGTH) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_FILE_NAME_LENGTH)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%OOC_FILE_NAME_LENGTH,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_FILE_NAME_LENGTH)) THEN write(unit,iostat=err) size(id%OOC_FILE_NAME_LENGTH,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_FILE_NAME_LENGTH ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((mode.EQ.restore_mode).OR. & (mode.EQ.restore_ooc_mode)) then nullify(id%OOC_FILE_NAME_LENGTH) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_FILE_NAME_LENGTH(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_FILE_NAME_LENGTH endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE DEFAULT END SELECT ENDDO if(mode.EQ.restore_ooc_mode) then goto 200 endif DO i1=1,NBVARIABLES SELECT CASE(i1) CASE(S_COMM) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_SYM) CALL MUMPS_SAVE_INT(id%SYM) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_PAR) CALL MUMPS_SAVE_INT(id%PAR) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_JOB) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_N) CALL MUMPS_SAVE_INT(id%N) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ICNTL) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%ICNTL,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%ICNTL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%ICNTL,1) read(unit,iostat=err) id%ICNTL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_INFO) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFO,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) INFO1,INFO2 & ,id%INFO(3:size(id%INFO,1)) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFO,1) read(unit,iostat=err) INFO1,INFO2 & ,id%INFO(3:size(id%INFO,1)) if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_INFOG) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFOG,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) INFOG1,INFOG2 & ,id%INFOG(3:size(id%INFOG,1)) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFOG,1) read(unit,iostat=err) INFOG1,INFOG2 & ,id%INFOG(3:size(id%INFOG,1)) if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_COST_SUBTREES) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%COST_SUBTREES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL read(unit,iostat=err) id%COST_SUBTREES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_CNTL) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%CNTL,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%CNTL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%CNTL,1) read(unit,iostat=err) id%CNTL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_RINFO) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFO,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%RINFO if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFO,1) read(unit,iostat=err) id%RINFO if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_RINFOG) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFOG,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%RINFOG if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFOG,1) read(unit,iostat=err) id%RINFOG if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_KEEP8) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8*size(id%KEEP8,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%KEEP8 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8*size(id%KEEP8,1) KEEP883_SAVE=id%KEEP8(83) KEEP884_SAVE=id%KEEP8(84) read(unit,iostat=err) id%KEEP8 id%KEEP8(83)=KEEP883_SAVE id%KEEP8(84)=KEEP884_SAVE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_KEEP) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%KEEP,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%KEEP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%KEEP,1) KEEP410_SAVE = id%KEEP(410) KEEP411_SAVE = id%KEEP(411) read(unit,iostat=err) id%KEEP id%KEEP(410) = KEEP410_SAVE id%KEEP(411) = KEEP411_SAVE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_DKEEP) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%DKEEP,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%DKEEP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%DKEEP,1) read(unit,iostat=err) id%DKEEP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NZ) CALL MUMPS_SAVE_INT(id%NZ) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NNZ) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%NNZ if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%NNZ if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_A) CASE(S_IRN) CASE(S_JCN) CASE(S_COLSCA) IF(id%KEEP(52).NE.-1) THEN CALL MUMPS_SAVERSTR_REALARRAY(id%COLSCA) ELSE ENDIF IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ROWSCA) IF(id%KEEP(52).NE.-1) THEN CALL MUMPS_SAVERSTR_REALARRAY(id%ROWSCA) ELSE ENDIF IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_COLSCA_loc) CALL MUMPS_SAVERSTR_REALARRAY(id%COLSCA_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ROWSCA_loc) IS_SYMMETRIC = .FALSE. IF (mode.EQ.memory_save_mode .OR. & mode.EQ.save_mode) THEN IS_SYMMETRIC = id%KEEP(50).EQ.1 .OR. & id%KEEP(50).EQ.2 ELSEIF (mode.EQ.restore_mode) THEN IS_SYMMETRIC = READ_SYM.EQ.1 .OR. & READ_SYM.EQ.2 ENDIF IF ( IS_SYMMETRIC ) THEN IF ( mode.EQ.restore_mode ) THEN id%ROWSCA_loc => id%COLSCA_loc ENDIF ELSE CALL MUMPS_SAVERSTR_REALARRAY(id%ROWSCA_loc) ENDIF IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NZ_loc) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%NZ_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NZ_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NNZ_loc) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%NNZ_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%NNZ_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_IRN_loc) CASE(S_JCN_loc) CASE(S_A_loc) CASE(S_NELT) CALL MUMPS_SAVE_INT(id%NELT) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NBLK) CALL MUMPS_SAVE_INT(id%NBLK) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ELTPTR) CASE(S_ELTVAR) CASE(S_A_ELT) CASE(S_PERM_IN) CASE(S_BLKPTR) CASE(S_BLKVAR) CASE(S_COLIND) CASE(S_PIVOTS) CASE(S_RHS) CASE(S_REDRHS) CASE(S_ROWIND) CASE(S_RHS_SPARSE) CASE(S_SOL_loc) CASE(S_RHS_loc) CASE(S_IRHS_SPARSE) CASE(S_IRHS_PTR) CASE(S_ISOL_loc) CASE(S_IRHS_loc) CASE(S_LRHS) CALL MUMPS_SAVE_INT(id%LRHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NRHS) CALL MUMPS_SAVE_INT(id%NRHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NZ_RHS) CALL MUMPS_SAVE_INT(id%NZ_RHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LRHS_loc) CALL MUMPS_SAVE_INT(id%LRHS_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_Nloc_RHS) CALL MUMPS_SAVE_INT(id%Nloc_RHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LD_RHSINTR) CALL MUMPS_SAVE_INT(id%LD_RHSINTR) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NSOL_loc) CALL MUMPS_SAVE_INT(id%NSOL_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LSOL_loc) CALL MUMPS_SAVE_INT(id%LSOL_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LREDRHS) CALL MUMPS_SAVE_INT(id%LREDRHS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SYM_PERM) CALL SMUMPS_SAVE_INT_SHPTR_ARRAY(id%SYM_PERM & ) IF (id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_UNS_PERM) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%UNS_PERM)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%UNS_PERM,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%UNS_PERM)) THEN write(unit,iostat=err) size(id%UNS_PERM,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%UNS_PERM ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%UNS_PERM) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%UNS_PERM(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%UNS_PERM endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NPROW) CALL MUMPS_SAVE_INT(id%NPROW) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NPCOL) CALL MUMPS_SAVE_INT(id%NPCOL) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_MBLOCK) CALL MUMPS_SAVE_INT(id%MBLOCK) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NBLOCK) CALL MUMPS_SAVE_INT(id%NBLOCK) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SCHUR_MLOC) CALL MUMPS_SAVE_INT(id%SCHUR_MLOC) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SCHUR_NLOC) CALL MUMPS_SAVE_INT(id%SCHUR_NLOC) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SCHUR_LLD) CALL MUMPS_SAVE_INT(id%SCHUR_LLD) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SIZE_SCHUR) CALL MUMPS_SAVE_INT(id%SIZE_SCHUR) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_SCHUR) CASE(S_SCHUR_CINTERFACE) CASE(S_LISTVAR_SCHUR) CASE(S_MAPPING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MAPPING)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(28)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MAPPING)) THEN write(unit,iostat=err) id%KEEP8(28) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MAPPING ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MAPPING) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT+SIZE_INT8 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_INT allocate(id%MAPPING(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MAPPING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_VERSION_NUMBER) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%VERSION_NUMBER) & *SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%VERSION_NUMBER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%VERSION_NUMBER) & *SIZE_CHARACTER read(unit,iostat=err) id%VERSION_NUMBER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_TMPDIR) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%OOC_TMPDIR) & *SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%OOC_TMPDIR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%OOC_TMPDIR) & *SIZE_CHARACTER read(unit,iostat=err) id%OOC_TMPDIR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_PREFIX) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%OOC_PREFIX) & *SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%OOC_PREFIX if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=1 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%OOC_PREFIX) & *SIZE_CHARACTER read(unit,iostat=err) id%OOC_PREFIX if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_WRITE_PROBLEM) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%WRITE_PROBLEM) & *SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%WRITE_PROBLEM if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%WRITE_PROBLEM) & *SIZE_CHARACTER read(unit,iostat=err) id%WRITE_PROBLEM if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MAX_SURF_MASTER) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%MAX_SURF_MASTER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%MAX_SURF_MASTER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_INST_Number) CALL MUMPS_SAVE_INT(id%INST_Number) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_COMM_NODES) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_MYID_NODES) CALL MUMPS_SAVE_INT(id%MYID_NODES) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_COMM_LOAD) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_MYID) CALL MUMPS_SAVE_INT(id%MYID) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NPROCS) CALL MUMPS_SAVE_INT(id%NPROCS) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NSLAVES) CALL MUMPS_SAVE_INT(id%NSLAVES) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ASS_IRECV) CALL MUMPS_SAVE_INT(id%ASS_IRECV) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_IS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%IS)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=id%KEEP(32)*SIZE_INT DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size(id%IS,1)-id%KEEP(32)) ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%IS)) THEN write(unit,iostat=err) size(id%IS,1),id%KEEP(32) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IS(1:id%KEEP(32)) DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size(id%IS,1)-id%KEEP(32)) ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%IS) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array2*SIZE_INT DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size_array1-size_array2) allocate(id%IS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IS(1:size_array2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_Deficiency) CALL MUMPS_SAVE_INT(id%Deficiency) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LNA) CALL MUMPS_SAVE_INT(id%LNA) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_NBSA) CALL MUMPS_SAVE_INT(id%NBSA) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_STEP) CALL SMUMPS_SAVE_INT_SHPTR_ARRAY(id%STEP & ) IF (id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_NE_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%NE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%NE_STEPS)) THEN write(unit,iostat=err) size(id%NE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%NE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%NE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_ND_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%ND_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ND_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%ND_STEPS)) THEN write(unit,iostat=err) size(id%ND_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ND_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%ND_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ND_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ND_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_Step2node) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%Step2node)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%Step2node,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%Step2node)) THEN write(unit,iostat=err) size(id%Step2node,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%Step2node ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%Step2node) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%Step2node(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%Step2node endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FRERE_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%FRERE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRERE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FRERE_STEPS)) THEN write(unit,iostat=err) size(id%FRERE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FRERE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FRERE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRERE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRERE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_DAD_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%DAD_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DAD_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%DAD_STEPS)) THEN write(unit,iostat=err) size(id%DAD_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DAD_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%DAD_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DAD_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DAD_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FILS) CALL SMUMPS_SAVE_INT_SHPTR_ARRAY(id%FILS & ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_PTR8ARR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTR8ARR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTR8ARR,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTR8ARR)) THEN write(unit,iostat=err) size(id%PTR8ARR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTR8ARR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=2 elseif(mode.EQ.restore_mode) then nullify(id%PTR8ARR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTR8ARR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTR8ARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NINCOLARR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then NbRecords(i1)=2 IF(associated(id%NINCOLARR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NINCOLARR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%NINCOLARR)) THEN write(unit,iostat=err) size(id%NINCOLARR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%NINCOLARR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%NINCOLARR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NINCOLARR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NINCOLARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NINROWARR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then NbRecords(i1)=2 IF(associated(id%NINROWARR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NINROWARR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%NINROWARR)) THEN write(unit,iostat=err) size(id%NINROWARR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%NINROWARR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%NINROWARR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NINROWARR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NINROWARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTRDEBARR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then NbRecords(i1)=2 IF(associated(id%PTRDEBARR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRDEBARR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTRDEBARR)) THEN write(unit,iostat=err) size(id%PTRDEBARR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTRDEBARR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PTRDEBARR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PTRDEBARR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRDEBARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTRAR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTRAR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRAR,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTRAR)) THEN write(unit,iostat=err) size(id%PTRAR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTRAR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=2 elseif(mode.EQ.restore_mode) then nullify(id%PTRAR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTRAR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRAR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FRTPTR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%FRTPTR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRTPTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FRTPTR)) THEN write(unit,iostat=err) size(id%FRTPTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FRTPTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FRTPTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRTPTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRTPTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FRTELT) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%FRTELT)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRTELT,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FRTELT)) THEN write(unit,iostat=err) size(id%FRTELT,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%FRTELT ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FRTELT) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRTELT(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRTELT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NA) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%NA)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NA,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%NA)) THEN write(unit,iostat=err) size(id%NA,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%NA ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%NA) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NA(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NA endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PROCNODE_STEPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then NbRecords(i1)=2 IF(associated(id%PROCNODE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PROCNODE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PROCNODE_STEPS)) THEN write(unit,iostat=err) size(id%PROCNODE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PROCNODE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PROCNODE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PROCNODE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PROCNODE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTLUST_S) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTLUST_S)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTLUST_S,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTLUST_S)) THEN write(unit,iostat=err) size(id%PTLUST_S,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTLUST_S ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PTLUST_S) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PTLUST_S(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTLUST_S endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTRFAC) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTRFAC)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRFAC,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTRFAC)) THEN write(unit,iostat=err) size(id%PTRFAC,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) id%PTRFAC ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PTRFAC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTRFAC(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRFAC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_S) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%S)) THEN SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=id%KEEP8(31)*SIZE_ARITH_DEP DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP*(id%KEEP8(23)-id%KEEP8(31)) ELSE SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%S)) THEN write(unit,iostat=err) id%KEEP8(23),id%KEEP8(31) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%S(1:id%KEEP8(31)) DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP*(id%KEEP8(23)-id%KEEP8(31)) ELSE write(unit,iostat=err) int(-999,kind=8) & ,int(-998,kind=8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%S) read(unit,iostat=err) size_array_INT8_1,size_array_INT8_2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,kind=8)) then SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=size_array_INT8_2*SIZE_ARITH_DEP DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP* & (size_array_INT8_1-size_array_INT8_2) allocate(id%S(1:size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%S(1:size_array_INT8_2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_LPS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%LPS)) THEN SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=id%KEEP8(31)*SIZE_ARITH_DEP/2 DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP/2*(id%KEEP8(23)-id%KEEP8(31)) ELSE SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%LPS)) THEN write(unit,iostat=err) id%KEEP8(23),id%KEEP8(31) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%LPS(1:id%KEEP8(31)) DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP/2*(id%KEEP8(23)-id%KEEP8(31)) ELSE write(unit,iostat=err) int(-999,kind=8) & ,int(-998,kind=8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%LPS) read(unit,iostat=err) size_array_INT8_1,size_array_INT8_2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,kind=8)) then SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=size_array_INT8_2*SIZE_ARITH_DEP/2 DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP/2* & (size_array_INT8_1-size_array_INT8_2) allocate(id%LPS(1:size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%LPS(1:size_array_INT8_2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PROCNODE) CASE(S_NELT_loc) CALL MUMPS_SAVE_INT(id%NELT_loc) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LELTVAR) CALL MUMPS_SAVE_INT(id%LELTVAR) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_ELTPROC) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%ELTPROC)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ELTPROC,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%ELTPROC)) THEN write(unit,iostat=err) size(id%ELTPROC,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ELTPROC ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%ELTPROC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ELTPROC(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ELTPROC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_I4_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%I4_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%I4_L0_OMP,1) & *size(id%I4_L0_OMP,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%I4_L0_OMP)) THEN write(unit,iostat=err) size(id%I4_L0_OMP,1) & ,size(id%I4_L0_OMP,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I4_L0_OMP ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%I4_L0_OMP) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%I4_L0_OMP(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%I4_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_I8_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%I8_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%I8_L0_OMP,1) & *size(id%I8_L0_OMP,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%I8_L0_OMP)) THEN write(unit,iostat=err) size(id%I8_L0_OMP,1) & ,size(id%I8_L0_OMP,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I8_L0_OMP ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%I8_L0_OMP) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%I8_L0_OMP(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%I8_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_CANDIDATES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%CANDIDATES)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%CANDIDATES,1) & *size(id%CANDIDATES,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%CANDIDATES)) THEN write(unit,iostat=err) size(id%CANDIDATES,1) & ,size(id%CANDIDATES,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%CANDIDATES ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%CANDIDATES) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%CANDIDATES(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%CANDIDATES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_ISTEP_TO_INIV2) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%ISTEP_TO_INIV2)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ISTEP_TO_INIV2,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%ISTEP_TO_INIV2)) THEN write(unit,iostat=err) size(id%ISTEP_TO_INIV2,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ISTEP_TO_INIV2 ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%ISTEP_TO_INIV2) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ISTEP_TO_INIV2(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ISTEP_TO_INIV2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_FUTURE_NIV2) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%FUTURE_NIV2)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FUTURE_NIV2,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FUTURE_NIV2)) THEN write(unit,iostat=err) size(id%FUTURE_NIV2,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FUTURE_NIV2 ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FUTURE_NIV2) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FUTURE_NIV2(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FUTURE_NIV2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_TAB_POS_IN_PERE) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%TAB_POS_IN_PERE)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%TAB_POS_IN_PERE,1) & *size(id%TAB_POS_IN_PERE,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%TAB_POS_IN_PERE)) THEN write(unit,iostat=err) size(id%TAB_POS_IN_PERE,1) & ,size(id%TAB_POS_IN_PERE,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%TAB_POS_IN_PERE ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%TAB_POS_IN_PERE) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%TAB_POS_IN_PERE(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%TAB_POS_IN_PERE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_I_AM_CAND) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%I_AM_CAND)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%I_AM_CAND,1)*SIZE_LOGICAL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%I_AM_CAND)) THEN write(unit,iostat=err) size(id%I_AM_CAND,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I_AM_CAND ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%I_AM_CAND) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_LOGICAL allocate(id%I_AM_CAND(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%I_AM_CAND endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MEM_DIST) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MEM_DIST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MEM_DIST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MEM_DIST)) THEN write(unit,iostat=err) size(id%MEM_DIST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) id%MEM_DIST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MEM_DIST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MEM_DIST(0:size_array1-1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MEM_DIST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_GLOB2LOC_RHS) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%GLOB2LOC_RHS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%GLOB2LOC_RHS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%GLOB2LOC_RHS)) THEN write(unit,iostat=err) size(id%GLOB2LOC_RHS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%GLOB2LOC_RHS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%GLOB2LOC_RHS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%GLOB2LOC_RHS(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%GLOB2LOC_RHS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_GLOB2LOC_SOL_ALLOC) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%GLOB2LOC_SOL_ALLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_LOGICAL read(unit,iostat=err) id%GLOB2LOC_SOL_ALLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_GLOB2LOC_SOL) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%GLOB2LOC_SOL)) THEN IF(id%GLOB2LOC_SOL_ALLOC) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%GLOB2LOC_SOL,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%GLOB2LOC_SOL)) THEN IF(id%GLOB2LOC_SOL_ALLOC) THEN write(unit,iostat=err) size(id%GLOB2LOC_SOL,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%GLOB2LOC_SOL ELSE write(unit,iostat=err) size(id%GLOB2LOC_SOL,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%GLOB2LOC_SOL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else if(id%GLOB2LOC_SOL_ALLOC) then SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%GLOB2LOC_SOL(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%GLOB2LOC_SOL else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy id%GLOB2LOC_SOL=>id%GLOB2LOC_RHS endif endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_RHSINTR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%RHSINTR)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(25)*SIZE_ARITH_DEP ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%RHSINTR)) THEN write(unit,iostat=err) id%KEEP8(25) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%RHSINTR ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%RHSINTR) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_ARITH_DEP allocate(id%RHSINTR(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%RHSINTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MEM_SUBTREE) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MEM_SUBTREE)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%MEM_SUBTREE,1)*SIZE_DOUBLE_PRECISION ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MEM_SUBTREE)) THEN write(unit,iostat=err) size(id%MEM_SUBTREE,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MEM_SUBTREE ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MEM_SUBTREE) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_DOUBLE_PRECISION allocate(id%MEM_SUBTREE(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MEM_SUBTREE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_COST_TRAV) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%COST_TRAV)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%COST_TRAV,1)*SIZE_DOUBLE_PRECISION ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%COST_TRAV)) THEN write(unit,iostat=err) size(id%COST_TRAV,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%COST_TRAV ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%COST_TRAV) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_DOUBLE_PRECISION allocate(id%COST_TRAV(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%COST_TRAV endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MY_ROOT_SBTR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MY_ROOT_SBTR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_ROOT_SBTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MY_ROOT_SBTR)) THEN write(unit,iostat=err) size(id%MY_ROOT_SBTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_ROOT_SBTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MY_ROOT_SBTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_ROOT_SBTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_ROOT_SBTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MY_FIRST_LEAF) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MY_FIRST_LEAF)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_FIRST_LEAF,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MY_FIRST_LEAF)) THEN write(unit,iostat=err) size(id%MY_FIRST_LEAF,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_FIRST_LEAF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MY_FIRST_LEAF) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_FIRST_LEAF(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_FIRST_LEAF endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MY_NB_LEAF) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MY_NB_LEAF)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_NB_LEAF,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MY_NB_LEAF)) THEN write(unit,iostat=err) size(id%MY_NB_LEAF,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_NB_LEAF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MY_NB_LEAF) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_NB_LEAF(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_NB_LEAF endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_DEPTH_FIRST) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%DEPTH_FIRST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DEPTH_FIRST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%DEPTH_FIRST)) THEN write(unit,iostat=err) size(id%DEPTH_FIRST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DEPTH_FIRST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%DEPTH_FIRST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DEPTH_FIRST(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DEPTH_FIRST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_DEPTH_FIRST_SEQ) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%DEPTH_FIRST_SEQ)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DEPTH_FIRST_SEQ,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%DEPTH_FIRST_SEQ)) THEN write(unit,iostat=err) size(id%DEPTH_FIRST_SEQ,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DEPTH_FIRST_SEQ ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%DEPTH_FIRST_SEQ) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DEPTH_FIRST_SEQ(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DEPTH_FIRST_SEQ endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SBTR_ID) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%SBTR_ID)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%SBTR_ID,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%SBTR_ID)) THEN write(unit,iostat=err) size(id%SBTR_ID,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%SBTR_ID ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%SBTR_ID) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%SBTR_ID(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%SBTR_ID endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SCHED_DEP) CASE(S_SCHED_GRP) CASE(S_CROIX_MANU) CASE(S_WK_USER) CASE(S_NBSA_LOCAL) CALL MUMPS_SAVE_INT(id%NBSA_LOCAL) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LWK_USER) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE(S_CB_SON_SIZE) CASE(S_INSTANCE_NUMBER) CALL MUMPS_SAVE_INT(id%INSTANCE_NUMBER) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_OOC_MAX_NB_NODES_FOR_ZONE) CALL MUMPS_SAVE_INT(id%OOC_MAX_NB_NODES_FOR_ZONE) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_OOC_INODE_SEQUENCE) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_INODE_SEQUENCE)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_INODE_SEQUENCE,1) & *size(id%OOC_INODE_SEQUENCE,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_INODE_SEQUENCE)) THEN write(unit,iostat=err) size(id%OOC_INODE_SEQUENCE,1) & ,size(id%OOC_INODE_SEQUENCE,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_INODE_SEQUENCE ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%OOC_INODE_SEQUENCE) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%OOC_INODE_SEQUENCE(size_array1 & ,size_array2), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_INODE_SEQUENCE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_SIZE_OF_BLOCK) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_SIZE_OF_BLOCK)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_SIZE_OF_BLOCK,1) & *size(id%OOC_SIZE_OF_BLOCK,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_SIZE_OF_BLOCK)) THEN write(unit,iostat=err) size(id%OOC_SIZE_OF_BLOCK,1) & ,size(id%OOC_SIZE_OF_BLOCK,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_SIZE_OF_BLOCK ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%OOC_SIZE_OF_BLOCK) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%OOC_SIZE_OF_BLOCK(size_array1 & ,size_array2), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_SIZE_OF_BLOCK endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_VADDR) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_VADDR)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_VADDR,1) & *size(id%OOC_VADDR,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_VADDR)) THEN write(unit,iostat=err) size(id%OOC_VADDR,1) & ,size(id%OOC_VADDR,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_VADDR ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%OOC_VADDR) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%OOC_VADDR(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_VADDR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_TOTAL_NB_NODES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%OOC_TOTAL_NB_NODES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%OOC_TOTAL_NB_NODES,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%OOC_TOTAL_NB_NODES)) THEN write(unit,iostat=err) size(id%OOC_TOTAL_NB_NODES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_TOTAL_NB_NODES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%OOC_TOTAL_NB_NODES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_TOTAL_NB_NODES(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_TOTAL_NB_NODES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_OOC_NB_FILES) CASE(S_OOC_NB_FILE_TYPE) CASE(S_OOC_FILE_NAMES) CASE(S_OOC_FILE_NAME_LENGTH) CASE(S_PIVNUL_LIST) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PIVNUL_LIST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PIVNUL_LIST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PIVNUL_LIST)) THEN write(unit,iostat=err) size(id%PIVNUL_LIST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PIVNUL_LIST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PIVNUL_LIST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PIVNUL_LIST(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PIVNUL_LIST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SUP_PROC) CASE(S_IPTR_WORKING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%IPTR_WORKING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%IPTR_WORKING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%IPTR_WORKING)) THEN write(unit,iostat=err) size(id%IPTR_WORKING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IPTR_WORKING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%IPTR_WORKING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%IPTR_WORKING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IPTR_WORKING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_WORKING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%WORKING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%WORKING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%WORKING)) THEN write(unit,iostat=err) size(id%WORKING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%WORKING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%WORKING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%WORKING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%WORKING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_INTR_ENCODING) NbRecords(i1) =0 SIZE_GEST(i1) =0 SIZE_VARIABLES(i1)=0_8 DO i2=1,NBVARIABLES_ROOTC SELECT CASE(i2) CASE(R_MBLOCK) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%MBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%MBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_NBLOCK) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%NBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%NBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_NPROW) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%NPROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%NPROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_NPCOL) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%NPCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%NPCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_MYROW) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then NbRecords_ROOTC(i2)=1 SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%MYROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%MYROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_MYCOL) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%MYCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%MYCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_SCHUR_MLOC) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%SCHUR_MLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%SCHUR_MLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_SCHUR_NLOC) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%SCHUR_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%SCHUR_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_SCHUR_LLD) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%SCHUR_LLD if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%SCHUR_LLD if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_RHS_NLOC) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%RHS_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%RHS_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_ROOT_SIZE) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%ROOT_SIZE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%ROOT_SIZE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_TOT_ROOT_SIZE) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%TOT_ROOT_SIZE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%TOT_ROOT_SIZE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_DESCRIPTOR) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)= & size(idintr%root%DESCRIPTOR,1) * SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%DESCRIPTOR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT* & size(idintr%root%DESCRIPTOR,1) read(unit,iostat=err) idintr%root%DESCRIPTOR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_CNTXT_BLACS) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%CNTXT_BLACS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%CNTXT_BLACS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_LPIV) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%LPIV if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%LPIV if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_RG2L) CASE(R_IPIV) NbRecords_ROOTC(i2)=2 if(mode.EQ.memory_save_mode) then IF(associated(idintr%root%IPIV)) THEN SIZE_GEST_ROOTC(i2)=SIZE_INT SIZE_VARIABLES_ROOTC(i2)= & size(idintr%root%IPIV,1)*SIZE_INT ELSE SIZE_GEST_ROOTC(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOTC(i2)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(idintr%root%IPIV)) THEN write(unit,iostat=err) size(idintr%root%IPIV,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) idintr%root%IPIV ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(idintr%root%IPIV) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_ROOTC(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOTC(i2)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_ROOTC(i2)=SIZE_INT SIZE_VARIABLES_ROOTC(i2)=size_array1*SIZE_INT allocate(idintr%root%IPIV(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) idintr%root%IPIV endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOTC(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_yes) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%yes if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_LOGICAL read(unit,iostat=err) idintr%root%yes if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_gridinit_done) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%gridinit_done if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_LOGICAL read(unit,iostat=err) idintr%root%gridinit_done if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(R_NB_SINGULAR_VALUES) NbRecords_ROOTC(i2)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idintr%root%NB_SINGULAR_VALUES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_ROOTC(i2)=SIZE_INT read(unit,iostat=err) idintr%root%NB_SINGULAR_VALUES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_ROOTC(i2)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_ROOTC(i2)=NbRecords_ROOTC(i2)+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_ROOTC(i2) & +int(SIZE_GEST_ROOTC(i2),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*NbRecords_ROOTC(i2),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES_ROOTC(i2)+ & DIFF_SIZE_ALLOC_READ_ROOTC(i2) size_read=size_read+SIZE_VARIABLES_ROOTC(i2) & +int(SIZE_GEST_ROOTC(i2),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*id%KEEP(34)*NbRecords_ROOTC(i2),kind=8) #endif elseif(mode.EQ.fake_restore_mode) then endif ENDDO CALL SMUMPS_SAVE_RESTORE_L0FACARRAY( & idintr%L0_OMP_FACTORS & ,unit,id%MYID,mode & ,SIZE_GEST_L0FAC,SIZE_VARIABLES_L0FAC & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) CALL SMUMPS_SAVE_RESTORE_ROOTA( & idintr%roota & ,unit,id%MYID,mode & ,SIZE_GEST_ROOTA,SIZE_VARIABLES_ROOTA & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,SIZE_RL_OR_DBL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_NBGRP) CALL MUMPS_SAVE_INT(id%NBGRP) IF (id%INFO(1) .LT. 0) GOTO 100 CASE(S_LRGROUPS) CALL SMUMPS_SAVE_INT_SHPTR_ARRAY(id%LRGROUPS & ) IF (id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_FDM_F_ENCODING) NbRecords(i1)=1 SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=0_8 if(mode.EQ.memory_save_mode) then IF(associated(id%FDM_F_ENCODING)) THEN CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,memory_save_mode & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%FDM_F_ENCODING)) THEN write(unit,iostat=err) size(id%FDM_F_ENCODING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,save_mode & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%FDM_F_ENCODING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.NE.-999) then CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,restore_mode & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_BLRARRAY_ENCODING) NbRecords(i1)=1 SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=0_8 CALL_SAVE_RESTORE_BLR = .FALSE. if(mode.EQ.memory_save_mode) then IF(associated(id%BLRARRAY_ENCODING)) THEN CALL_SAVE_RESTORE_BLR = .TRUE. ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%BLRARRAY_ENCODING)) THEN write(unit,iostat=err) size(id%BLRARRAY_ENCODING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CALL_SAVE_RESTORE_BLR = .TRUE. ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(id%BLRARRAY_ENCODING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.NE.-999) then CALL_SAVE_RESTORE_BLR = .TRUE. endif endif IF (CALL_SAVE_RESTORE_BLR) THEN CALL SMUMPS_SAVE_RESTORE_BLR(id%BLRARRAY_ENCODING & ,unit,id%MYID,mode & ,SIZE_GEST_BLR,SIZE_VARIABLES_BLR & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_SCHED_SBTR) CASE(S_LPOOL_A_L0_OMP) CALL MUMPS_SAVE_INT(id%LPOOL_A_L0_OMP) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_LPOOL_B_L0_OMP) CALL MUMPS_SAVE_INT(id%LPOOL_B_L0_OMP) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_L_PHYS_L0_OMP) CALL MUMPS_SAVE_INT(id%L_PHYS_L0_OMP) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_L_VIRT_L0_OMP) CALL MUMPS_SAVE_INT(id%L_VIRT_L0_OMP) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_LL0_OMP_MAPPING) CALL MUMPS_SAVE_INT(id%LL0_OMP_MAPPING) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_LL0_OMP_FACTORS) CALL MUMPS_SAVE_INT(id%LL0_OMP_FACTORS) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_THREAD_LA) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%THREAD_LA if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%THREAD_LA if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_IPOOL_A_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%IPOOL_A_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%IPOOL_A_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%IPOOL_A_L0_OMP)) THEN write(unit,iostat=err) size(id%IPOOL_A_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IPOOL_A_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%IPOOL_A_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%IPOOL_A_L0_OMP(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IPOOL_A_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_IPOOL_B_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%IPOOL_B_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%IPOOL_B_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%IPOOL_B_L0_OMP)) THEN write(unit,iostat=err) size(id%IPOOL_B_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IPOOL_B_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%IPOOL_B_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%IPOOL_B_L0_OMP(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IPOOL_B_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PHYS_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PHYS_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%PHYS_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PHYS_L0_OMP)) THEN write(unit,iostat=err) size(id%PHYS_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PHYS_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PHYS_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PHYS_L0_OMP(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PHYS_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_VIRT_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%VIRT_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%VIRT_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%VIRT_L0_OMP)) THEN write(unit,iostat=err) size(id%VIRT_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%VIRT_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%VIRT_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%VIRT_L0_OMP(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%VIRT_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_VIRT_L0_OMP_MAPPING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%VIRT_L0_OMP_MAPPING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%VIRT_L0_OMP_MAPPING,1) & *SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%VIRT_L0_OMP_MAPPING)) THEN write(unit,iostat=err) size(id%VIRT_L0_OMP_MAPPING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%VIRT_L0_OMP_MAPPING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%VIRT_L0_OMP_MAPPING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%VIRT_L0_OMP_MAPPING(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%VIRT_L0_OMP_MAPPING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PERM_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PERM_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PERM_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PERM_L0_OMP)) THEN write(unit,iostat=err) size(id%PERM_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PERM_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PERM_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PERM_L0_OMP(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PERM_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_PTR_LEAFS_L0_OMP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%PTR_LEAFS_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%PTR_LEAFS_L0_OMP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%PTR_LEAFS_L0_OMP)) THEN write(unit,iostat=err) size(id%PTR_LEAFS_L0_OMP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTR_LEAFS_L0_OMP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%PTR_LEAFS_L0_OMP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PTR_LEAFS_L0_OMP(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTR_LEAFS_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_L0_OMP_MAPPING) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%L0_OMP_MAPPING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%L0_OMP_MAPPING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%L0_OMP_MAPPING)) THEN write(unit,iostat=err) size(id%L0_OMP_MAPPING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%L0_OMP_MAPPING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%L0_OMP_MAPPING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%L0_OMP_MAPPING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%L0_OMP_MAPPING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SINGULAR_VALUES) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%SINGULAR_VALUES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%SINGULAR_VALUES,1)*SIZE_RL_OR_DBL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%SINGULAR_VALUES)) THEN write(unit,iostat=err) size(id%SINGULAR_VALUES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(size_written,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%SINGULAR_VALUES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(size_written,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(size_written,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%SINGULAR_VALUES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_RL_OR_DBL allocate(id%SINGULAR_VALUES(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%SINGULAR_VALUES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_NB_SINGULAR_VALUES) CALL MUMPS_SAVE_INT(id%NB_SINGULAR_VALUES) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CASE(S_ASSOCIATED_OOC_FILES) if(mode.EQ.memory_save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL elseif(mode.EQ.restore_mode) then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL endif CASE(S_SAVE_DIR) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%SAVE_DIR)*SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%SAVE_DIR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%SAVE_DIR)*SIZE_CHARACTER read(unit,iostat=err) id%SAVE_DIR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_SAVE_PREFIX) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=len(id%SAVE_PREFIX)*SIZE_CHARACTER elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%SAVE_PREFIX if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=len(id%SAVE_PREFIX)*SIZE_CHARACTER read(unit,iostat=err) id%SAVE_PREFIX if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_MTKO_PROCS_MAP) NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id%MTKO_PROCS_MAP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%MTKO_PROCS_MAP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id%MTKO_PROCS_MAP)) THEN write(unit,iostat=err) size(id%MTKO_PROCS_MAP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MTKO_PROCS_MAP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id%MTKO_PROCS_MAP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MTKO_PROCS_MAP(0:size_array1-1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MTKO_PROCS_MAP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_METIS_OPTIONS) NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%METIS_OPTIONS,1) elseif(mode.EQ.save_mode) then write(unit,iostat=err) id%METIS_OPTIONS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT*size(id%METIS_OPTIONS,1) read(unit,iostat=err) id%METIS_OPTIONS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_pad1,S_pad2,S_pad3,S_pad4,S_pad5,S_pad6,S_pad7, & S_pad11,S_pad12,S_pad13,S_pad14,S_pad16) CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords(i1)=NbRecords(i1)+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES(i1) & +int(SIZE_GEST(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*id%KEEP(34)*NbRecords(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES(i1)+ & DIFF_SIZE_ALLOC_READ(i1) size_read=size_read+SIZE_VARIABLES(i1) & +int(SIZE_GEST(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*id%KEEP(34)*NbRecords(i1),kind=8) #endif elseif(mode.EQ.fake_restore_mode) then endif ENDDO 200 continue if(mode.EQ.memory_save_mode) then WRITTEN_STRUC_SIZE=sum(SIZE_VARIABLES)+ & sum(SIZE_VARIABLES_ROOTC)+ & SIZE_VARIABLES_BLR+SIZE_VARIABLES_FRONT_DATA+ & SIZE_VARIABLES_L0FAC+ & SIZE_VARIABLES_ROOTA TOTAL_STRUC_SIZE=WRITTEN_STRUC_SIZE & +sum(DIFF_SIZE_ALLOC_READ) & +sum(DIFF_SIZE_ALLOC_READ_ROOTC) gest_size=sum(SIZE_GEST)+sum(SIZE_GEST_ROOTC) & +SIZE_GEST_BLR+SIZE_GEST_FRONT_DATA & +SIZE_GEST_L0FAC & +SIZE_GEST_ROOTA & +int(5*SIZE_CHARACTER,kind=8) & +int(23*SIZE_CHARACTER,kind=8) & +int(2*SIZE_INT8,kind=8)+int(1,kind=8) & +int(3*SIZE_INT,kind=8) & +int(SIZE_LOGICAL,kind=8) IF(associated(id%OOC_FILE_NAME_LENGTH).AND. & associated(id%OOC_FILE_NAMES)) THEN gest_size=gest_size+int(SIZE_INT,kind=8) & +int(id%OOC_FILE_NAME_LENGTH(1)*SIZE_CHARACTER,kind=8) ELSE gest_size=gest_size+int(2*SIZE_INT,kind=8) ENDIF #if defined(MUMPS_NOF2003) tot_NbRecords=sum(NbRecords)+sum(NbRecords_ROOTC)+8 gest_size=gest_size+int(2*id%KEEP(34)*tot_NbRecords,kind=8) #endif TOTAL_FILE_SIZE=WRITTEN_STRUC_SIZE+gest_size elseif(mode.EQ.save_mode) then elseif(mode.EQ.restore_mode) then #if ! defined(NOSCALAPACK) if(idintr%root%gridinit_done) then idintr%root%CNTXT_BLACS = id%COMM_NODES CALL blacs_gridinit( idintr%root%CNTXT_BLACS, 'R', & idintr%root%NPROW, idintr%root%NPCOL ) idintr%root%gridinit_done = .TRUE. idintr%root%DESCRIPTOR(2) = idintr%root%CNTXT_BLACS endif #endif elseif(mode.EQ.fake_restore_mode) then elseif(mode.EQ.restore_ooc_mode) then endif 100 continue RETURN CONTAINS SUBROUTINE MUMPS_SAVERSTR_REALARRAY(idREAL) IMPLICIT NONE REAL, DIMENSION(:), POINTER :: idREAL NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(idREAL)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(idREAL,1)*SIZE_RL_OR_DBL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(idREAL)) THEN write(unit,iostat=err) size(idreal,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) idREAL ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(idREAL) read(unit,iostat=err) size_array1 if (err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if (size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_RL_OR_DBL allocate(idREAL(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) idREAL endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if (err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif 100 CONTINUE RETURN END SUBROUTINE MUMPS_SAVERSTR_REALARRAY SUBROUTINE MUMPS_SAVE_INT(idINT) IMPLICIT NONE INTEGER, INTENT(INOUT) :: idINT NbRecords(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES(i1)=SIZE_INT elseif(mode.EQ.save_mode) then write(unit,iostat=err) idINT if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) idINT if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif 100 CONTINUE RETURN END SUBROUTINE MUMPS_SAVE_INT SUBROUTINE SMUMPS_SAVE_INT_SHPTR_ARRAY(id_INTPTR & ) IMPLICIT NONE INTEGER, POINTER, DIMENSION(:) :: id_INTPTR NbRecords(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(id_INTPTR) & ) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id_INTPTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(id_INTPTR) & ) THEN write(unit,iostat=err) size(id_INTPTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id_INTPTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(id_INTPTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id_INTPTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) else read(unit,iostat=err) id_INTPTR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif endif endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif 100 CONTINUE RETURN END SUBROUTINE SMUMPS_SAVE_INT_SHPTR_ARRAY END SUBROUTINE SMUMPS_SAVE_RESTORE_STRUCTURE SUBROUTINE SMUMPS_SAVE_RESTORE_ROOTA( & roota & ,unit,MYID,mode & ,SIZE_GEST_ROOTA,SIZE_VARIABLES_ROOTA & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,SIZE_RL_OR_DBL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST_ROOTA INTEGER(8),intent(OUT) :: SIZE_VARIABLES_ROOTA INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER,intent(IN):: SIZE_RL_OR_DBL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: SIZE_GEST, i3 INTEGER(8) :: SIZE_VARIABLE INTEGER, PARAMETER :: NBVARIABLES_ROOTA=7 INTEGER, PARAMETER :: RA_SINGULAR_VALUES=7 INTEGER, PARAMETER :: RA_SVD_VT=6 INTEGER, PARAMETER :: RA_SVD_U=5 INTEGER, PARAMETER :: RA_RHS_ROOT=4 INTEGER, PARAMETER :: RA_QR_TAU=3 INTEGER, PARAMETER :: RA_SCHUR_POINTER=2 INTEGER, PARAMETER :: RA_RHS_CNTR_MASTER_ROOT=1 SIZE_GEST_ROOTA = 0 SIZE_VARIABLES_ROOTA = 0_8 DO i3 = 1, NBVARIABLES_ROOTA SIZE_GEST = 0 SIZE_VARIABLE = 0_8 SELECT CASE(i3) CASE(RA_QR_TAU) CALL SMUMPS_SAVE_RESTORE_ARRAY_C1D( & roota%QR_TAU ) CASE(RA_SVD_U) CALL SMUMPS_SAVE_RESTORE_ARRAY_2D(roota%SVD_U) CASE(RA_SVD_VT) CASE(RA_SINGULAR_VALUES) CALL SMUMPS_SAVE_RESTORE_ARRAY_R1D( & roota%SINGULAR_VALUES) CASE(RA_RHS_CNTR_MASTER_ROOT) CALL SMUMPS_SAVE_RESTORE_ARRAY_C1D( & roota%RHS_CNTR_MASTER_ROOT) CASE(RA_RHS_ROOT) CASE(RA_SCHUR_POINTER) CASE DEFAULT END SELECT IF ( INFO(1) .LT. 0 ) GOTO 100 IF (mode.EQ.memory_save_mode) then SIZE_VARIABLES_ROOTA = SIZE_VARIABLES_ROOTA + & SIZE_VARIABLE SIZE_GEST_ROOTA = SIZE_GEST_ROOTA + SIZE_GEST ENDIF END DO 100 CONTINUE RETURN CONTAINS SUBROUTINE SMUMPS_SAVE_RESTORE_ARRAY_2D(PTRARRAY2D) IMPLICIT NONE REAL, DIMENSION(:,:), POINTER :: PTRARRAY2D INTEGER :: LocalNbRecords, err, allocok, dummy INTEGER :: size_array1, size_array2 INTEGER(8) :: sz LocalNbRecords = 2 if(mode.EQ.memory_save_mode) then IF(associated(PTRARRAY2D)) THEN SIZE_GEST = SIZE_INT*2 SIZE_VARIABLE = size(PTRARRAY2D,1) & *size(PTRARRAY2D,2)*SIZE_ARITH_DEP ELSE SIZE_GEST = SIZE_INT*3 SIZE_VARIABLE = 0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(PTRARRAY2D)) THEN write(unit,iostat=err) size(PTRARRAY2D,1) & ,size(PTRARRAY2D,2) ELSE write(unit,iostat=err) -999,-998 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+2*SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 IF(associated(PTRARRAY2D)) THEN write(unit,iostat=err) PTRARRAY2D sz= int(size(PTRARRAY2D,1),8) * & int(size(PTRARRAY2D,2),8) * & SIZE_ARITH_DEP ELSE write(unit,iostat=err) -999 sz=SIZE_INT ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(PTRARRAY2D) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) else size_read = size_read+2*SIZE_INT size_allocated = size_allocated + 2*SIZE_INT8 endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then read(unit,iostat=err) dummy sz = SIZE_INT else sz = int(size_array1,8)*int(size_array2,8) & * SIZE_ARITH_DEP allocate(PTRARRAY2D(size_array1, & size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) PTRARRAY2D endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & , INFO(2)) else size_read = size_read + sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif #if defined(MUMPS_NOF2003) IF (mode.EQ.memory_save_mode) THEN SIZE_GEST = SIZE_GEST+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.save_mode) THEN size_written = size_written+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.restore_mode) THEN size_read = size_read+2*SIZE_INT*LocalNbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_ARRAY_2D SUBROUTINE SMUMPS_SAVE_RESTORE_ARRAY_C1D(PTRARRAY1D) IMPLICIT NONE REAL, DIMENSION(:), POINTER :: PTRARRAY1D INTEGER :: LocalNbRecords, err, allocok, dummy INTEGER :: size_array1 INTEGER(8) :: sz LocalNbRecords = 2 if(mode.EQ.memory_save_mode) then IF(associated(PTRARRAY1D)) THEN SIZE_GEST = SIZE_INT SIZE_VARIABLE = size(PTRARRAY1D)*SIZE_ARITH_DEP ELSE SIZE_GEST = SIZE_INT*2 SIZE_VARIABLE = 0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(PTRARRAY1D)) THEN write(unit,iostat=err) size(PTRARRAY1D) ELSE write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 IF(associated(PTRARRAY1D)) THEN write(unit,iostat=err) PTRARRAY1D sz= int(size(PTRARRAY1D),8)* & SIZE_ARITH_DEP ELSE write(unit,iostat=err) -999 sz=SIZE_INT ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(PTRARRAY1D) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) else size_read = size_read+SIZE_INT size_allocated = size_allocated + SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then read(unit,iostat=err) dummy sz = SIZE_INT else sz = int(size_array1,8) * SIZE_ARITH_DEP allocate(PTRARRAY1D(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) PTRARRAY1D endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & , INFO(2)) else size_read = size_read + sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif #if defined(MUMPS_NOF2003) IF (mode.EQ.memory_save_mode) THEN SIZE_GEST = SIZE_GEST+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.save_mode) THEN size_written = size_written+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.restore_mode) THEN size_read = size_read+2*SIZE_INT*LocalNbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_ARRAY_C1D SUBROUTINE SMUMPS_SAVE_RESTORE_ARRAY_R1D(PTRARRAY1D) IMPLICIT NONE REAL, DIMENSION(:), POINTER :: PTRARRAY1D INTEGER :: LocalNbRecords, err, allocok, dummy INTEGER :: size_array1 INTEGER(8) :: sz LocalNbRecords = 2 if(mode.EQ.memory_save_mode) then IF(associated(PTRARRAY1D)) THEN SIZE_GEST = SIZE_INT SIZE_VARIABLE = size(PTRARRAY1D)*SIZE_RL_OR_DBL ELSE SIZE_GEST = SIZE_INT*2 SIZE_VARIABLE = 0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(PTRARRAY1D)) THEN write(unit,iostat=err) size(PTRARRAY1D) ELSE write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 IF(associated(PTRARRAY1D)) THEN write(unit,iostat=err) PTRARRAY1D sz= int(size(PTRARRAY1D),8)* & SIZE_RL_OR_DBL ELSE write(unit,iostat=err) -999 sz=SIZE_INT ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,INFO(2)) else size_written=size_written+sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(PTRARRAY1D) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) else size_read = size_read+SIZE_INT size_allocated = size_allocated + SIZE_INT endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then read(unit,iostat=err) dummy sz = SIZE_INT else sz = int(size_array1,8) * SIZE_RL_OR_DBL allocate(PTRARRAY1D(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) PTRARRAY1D endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & , INFO(2)) else size_read = size_read + sz endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif #if defined(MUMPS_NOF2003) IF (mode.EQ.memory_save_mode) THEN SIZE_GEST = SIZE_GEST+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.save_mode) THEN size_written = size_written+2*SIZE_INT*LocalNbRecords ELSE IF (mode.EQ.restore_mode) THEN size_read = size_read+2*SIZE_INT*LocalNbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_ARRAY_R1D END SUBROUTINE SMUMPS_SAVE_RESTORE_ROOTA END MODULE SMUMPS_SAVE_RESTORE #else SUBROUTINE SMUMPS_SAVE_RESTORE_RETURN() RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_RETURN #endif MUMPS_5.8.1/src/double_linked_list.F0000664000175000017500000010354215042446423017200 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_IDLL IMPLICIT NONE TYPE IDLL_NODE_T TYPE ( IDLL_NODE_T ), POINTER :: NEXT, PREV INTEGER ELMT END TYPE IDLL_NODE_T TYPE IDLL_T TYPE ( IDLL_NODE_T ), POINTER :: FRONT, BACK END TYPE IDLL_T CONTAINS FUNCTION IDLL_CREATE(DLL) INTEGER :: IDLL_CREATE #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL #else TYPE ( IDLL_T ), POINTER, INTENT ( OUT ) :: DLL #endif INTEGER IERR ALLOCATE ( DLL, STAT=IERR ) IF ( IERR .NE. 0 ) THEN IDLL_CREATE = -2 RETURN END IF NULLIFY ( DLL%FRONT ) NULLIFY ( DLL%BACK ) IDLL_CREATE = 0 RETURN END FUNCTION IDLL_CREATE FUNCTION IDLL_DESTROY(DLL) INTEGER :: IDLL_DESTROY #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL #else TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif TYPE ( IDLL_NODE_T ), POINTER :: AUX IF ( .NOT. associated ( DLL ) ) THEN IDLL_DESTROY = -1 RETURN END IF DO WHILE ( associated ( DLL%FRONT ) ) AUX => DLL%FRONT DLL%FRONT => DLL%FRONT%NEXT DEALLOCATE( AUX ) END DO DEALLOCATE( DLL ) IDLL_DESTROY = 0 END FUNCTION IDLL_DESTROY FUNCTION IDLL_PUSH_FRONT(DLL, ELMT) INTEGER :: IDLL_PUSH_FRONT #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL #else TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif INTEGER, INTENT ( IN ) :: ELMT TYPE ( IDLL_NODE_T ), POINTER :: NODE INTEGER IERR IF ( .NOT. associated ( DLL ) ) THEN IDLL_PUSH_FRONT = -1 RETURN END IF ALLOCATE( NODE, STAT=IERR ) IF ( IERR .NE. 0 ) THEN IDLL_PUSH_FRONT = -2 RETURN END IF NODE%ELMT = ELMT NODE%NEXT => DLL%FRONT NULLIFY ( NODE%PREV ) IF ( associated ( DLL%FRONT ) ) THEN DLL%FRONT%PREV => NODE END IF DLL%FRONT => NODE IF ( .NOT. associated ( DLL%BACK ) ) THEN DLL%BACK => NODE END IF IDLL_PUSH_FRONT = 0 END FUNCTION IDLL_PUSH_FRONT FUNCTION IDLL_POP_FRONT(DLL, ELMT) INTEGER :: IDLL_POP_FRONT #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL #else TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif INTEGER, INTENT ( OUT ) :: ELMT TYPE ( IDLL_NODE_T ), POINTER :: AUX IF ( .NOT. associated ( DLL ) ) THEN IDLL_POP_FRONT = -1 RETURN END IF IF ( .NOT. associated ( DLL%FRONT ) ) THEN IDLL_POP_FRONT = -3 RETURN END IF ELMT = DLL%FRONT%ELMT AUX => DLL%FRONT DLL%FRONT => DLL%FRONT%NEXT IF ( associated ( DLL%FRONT ) ) THEN NULLIFY ( DLL%FRONT%PREV ) END IF IF ( associated ( DLL%BACK, AUX ) ) THEN NULLIFY ( DLL%BACK ) END IF DEALLOCATE ( AUX ) IDLL_POP_FRONT = 0 END FUNCTION IDLL_POP_FRONT FUNCTION IDLL_PUSH_BACK(DLL, ELMT) INTEGER :: IDLL_PUSH_BACK #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL #else TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif INTEGER, INTENT ( IN ) :: ELMT TYPE ( IDLL_NODE_T ), POINTER :: NODE INTEGER IERR IF ( .NOT. associated ( DLL ) ) THEN IDLL_PUSH_BACK = -1 RETURN END IF ALLOCATE( NODE, STAT=IERR ) IF ( IERR .NE. 0 ) THEN IDLL_PUSH_BACK = -2 RETURN END IF NODE%ELMT = ELMT NULLIFY ( NODE%NEXT ) NODE%PREV => DLL%BACK IF ( associated ( DLL%BACK ) ) THEN DLL%BACK%NEXT => NODE END IF DLL%BACK => NODE IF ( .NOT. associated ( DLL%FRONT ) ) THEN DLL%FRONT => NODE END IF IDLL_PUSH_BACK = 0 END FUNCTION IDLL_PUSH_BACK FUNCTION IDLL_POP_BACK(DLL, ELMT) INTEGER :: IDLL_POP_BACK #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL #else TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif INTEGER, INTENT ( OUT ) :: ELMT TYPE ( IDLL_NODE_T ), POINTER :: AUX IF ( .NOT. associated ( DLL ) ) THEN IDLL_POP_BACK = -1 RETURN END IF IF ( .NOT. associated ( DLL%BACK ) ) THEN IDLL_POP_BACK = -3 RETURN END IF ELMT = DLL%BACK%ELMT AUX => DLL%BACK DLL%BACK => DLL%BACK%PREV IF ( associated ( DLL%BACK ) ) THEN NULLIFY ( DLL%BACK%NEXT ) END IF IF ( associated ( DLL%FRONT, AUX ) ) THEN NULLIFY ( DLL%FRONT ) END IF DEALLOCATE ( AUX ) IDLL_POP_BACK = 0 END FUNCTION IDLL_POP_BACK FUNCTION IDLL_INSERT(DLL, POS, ELMT) INTEGER :: IDLL_INSERT #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL #else TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif INTEGER, INTENT ( IN ) :: POS, ELMT TYPE ( IDLL_NODE_T ), POINTER :: NODE TYPE ( IDLL_NODE_T ), POINTER :: NEW_PTR, OLD_PTR INTEGER :: IERR, CPT IF ( .NOT. associated ( DLL ) ) THEN IDLL_INSERT = -1 RETURN END IF IF ( POS .LE. 0 ) THEN IDLL_INSERT = -4 RETURN END IF CPT = 1 NEW_PTR => DLL%FRONT NULLIFY ( OLD_PTR ) DO WHILE ( ( CPT .LT. POS ) .AND. & ( associated ( NEW_PTR ) ) ) OLD_PTR => NEW_PTR NEW_PTR => NEW_PTR%NEXT CPT = CPT + 1 END DO ALLOCATE ( NODE, STAT=IERR ) IF ( IERR .NE. 0 ) THEN IDLL_INSERT = -2 RETURN END IF NODE%ELMT = ELMT IF ( .NOT. associated ( OLD_PTR ) ) THEN IF ( .NOT. associated ( NEW_PTR ) ) THEN NULLIFY ( NODE%PREV ) NULLIFY ( NODE%NEXT ) DLL%FRONT => NODE DLL%BACK => NODE ELSE NULLIFY ( NODE%PREV ) NODE%NEXT => NEW_PTR NEW_PTR%PREV => NODE DLL%FRONT => NODE END IF ELSE IF ( .NOT. associated ( NEW_PTR ) ) THEN NODE%PREV => OLD_PTR NULLIFY ( NODE%NEXT ) OLD_PTR%NEXT => NODE DLL%BACK => NODE ELSE NODE%PREV => OLD_PTR NODE%NEXT => NEW_PTR OLD_PTR%NEXT => NODE NEW_PTR%PREV => NODE END IF END IF IDLL_INSERT = 0 END FUNCTION IDLL_INSERT FUNCTION IDLL_INSERT_BEFORE(DLL, NODE_AFTER, ELMT) INTEGER :: IDLL_INSERT_BEFORE #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL TYPE ( IDLL_NODE_T ), POINTER :: NODE_AFTER #else TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL TYPE ( IDLL_NODE_T ), POINTER, INTENT ( IN ) :: NODE_AFTER #endif INTEGER, INTENT ( IN ) :: ELMT TYPE ( IDLL_NODE_T ), POINTER :: NODE_BEFORE INTEGER :: IERR ALLOCATE ( NODE_BEFORE, STAT=IERR ) IF ( IERR .NE. 0 ) THEN IDLL_INSERT_BEFORE = -2 RETURN END IF NODE_BEFORE%ELMT = ELMT IF ( .NOT. associated ( NODE_AFTER%PREV ) ) THEN NODE_AFTER%PREV => NODE_BEFORE NODE_BEFORE%NEXT => NODE_AFTER NULLIFY ( NODE_BEFORE%PREV ) DLL%FRONT => NODE_BEFORE ELSE NODE_BEFORE%NEXT => NODE_AFTER NODE_BEFORE%PREV => NODE_AFTER%PREV NODE_AFTER%PREV => NODE_BEFORE NODE_BEFORE%PREV%NEXT => NODE_BEFORE END IF IDLL_INSERT_BEFORE = 0 END FUNCTION IDLL_INSERT_BEFORE FUNCTION IDLL_INSERT_AFTER(DLL, NODE_BEFORE, ELMT) INTEGER :: IDLL_INSERT_AFTER #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL TYPE ( IDLL_NODE_T ), POINTER :: NODE_BEFORE #else TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL TYPE ( IDLL_NODE_T ), POINTER, INTENT ( IN ) :: NODE_BEFORE #endif INTEGER, INTENT ( IN ) :: ELMT TYPE ( IDLL_NODE_T ), POINTER :: NODE_AFTER INTEGER :: IERR ALLOCATE ( NODE_AFTER, STAT=IERR ) IF ( IERR .NE. 0 ) THEN IDLL_INSERT_AFTER = -2 RETURN END IF NODE_AFTER%ELMT = ELMT IF ( .NOT. associated ( NODE_BEFORE%NEXT ) ) THEN NODE_BEFORE%NEXT => NODE_AFTER NODE_AFTER%PREV => NODE_BEFORE NULLIFY ( NODE_AFTER%NEXT ) DLL%BACK => NODE_AFTER ELSE NODE_AFTER%PREV => NODE_BEFORE NODE_AFTER%NEXT => NODE_BEFORE%NEXT NODE_BEFORE%NEXT => NODE_AFTER NODE_AFTER%NEXT%PREV => NODE_AFTER END IF IDLL_INSERT_AFTER = 0 END FUNCTION IDLL_INSERT_AFTER FUNCTION IDLL_LOOKUP (DLL, POS, ELMT) INTEGER :: IDLL_LOOKUP #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL #else TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif INTEGER, INTENT ( IN ) :: POS INTEGER, INTENT ( OUT ) :: ELMT TYPE ( IDLL_NODE_T ), POINTER :: AUX INTEGER :: CPT IF ( .NOT. associated ( DLL ) ) THEN IDLL_LOOKUP = -1 RETURN END IF IF ( POS .LE. 0 ) THEN IDLL_LOOKUP = -4 RETURN END IF CPT = 1 AUX => DLL%FRONT DO WHILE ( ( CPT .LT. POS ) .AND. ( associated ( AUX ) ) ) CPT = CPT + 1 AUX => AUX%NEXT END DO IF ( .NOT. associated ( AUX ) ) THEN IDLL_LOOKUP = -3 RETURN END IF ELMT = AUX%ELMT IDLL_LOOKUP = 0 END FUNCTION IDLL_LOOKUP FUNCTION IDLL_REMOVE_POS(DLL, POS, ELMT) INTEGER :: IDLL_REMOVE_POS #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL #else TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif INTEGER, INTENT ( IN ) :: POS INTEGER, INTENT ( OUT ) :: ELMT TYPE ( IDLL_NODE_T ), POINTER :: AUX INTEGER :: CPT IF ( .NOT. associated ( DLL ) ) THEN IDLL_REMOVE_POS = -1 RETURN END IF CPT = 1 AUX => DLL%FRONT DO WHILE ( ( associated ( AUX ) ) .AND. & ( CPT .LT. POS ) ) CPT = CPT + 1 AUX => AUX%NEXT END DO IF ( associated ( AUX ) ) THEN IF ( .NOT. associated ( AUX%PREV ) ) THEN IF ( .NOT. associated ( AUX%NEXT ) ) THEN NULLIFY ( DLL%FRONT ) NULLIFY ( DLL%BACK ) ELSE NULLIFY ( AUX%NEXT%PREV ) DLL%FRONT => AUX%NEXT END IF ELSE IF ( .NOT. associated ( AUX%NEXT ) ) THEN NULLIFY ( AUX%PREV%NEXT ) DLL%BACK => AUX%PREV ELSE AUX%PREV%NEXT => AUX%NEXT AUX%NEXT%PREV => AUX%PREV END IF END IF ELMT = AUX%ELMT DEALLOCATE ( AUX ) ELSE IDLL_REMOVE_POS = -3 RETURN END IF IDLL_REMOVE_POS = 0 END FUNCTION IDLL_REMOVE_POS FUNCTION IDLL_REMOVE_ELMT(DLL, ELMT, POS) INTEGER :: IDLL_REMOVE_ELMT #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL #else TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif INTEGER, INTENT ( IN ) :: ELMT INTEGER, INTENT ( OUT ) :: POS TYPE ( IDLL_NODE_T ), POINTER :: AUX INTEGER :: CPT IF ( .NOT. associated ( DLL ) ) THEN IDLL_REMOVE_ELMT = -1 RETURN END IF CPT = 1 AUX => DLL%FRONT DO WHILE ( ( associated ( AUX ) ) .AND. & ( AUX%ELMT .NE. ELMT ) ) CPT = CPT + 1 AUX => AUX%NEXT END DO IF ( associated ( AUX ) ) THEN IF ( .NOT. associated ( AUX%PREV ) ) THEN IF ( .NOT. associated ( AUX%NEXT ) ) THEN NULLIFY ( DLL%FRONT ) NULLIFY ( DLL%BACK ) ELSE NULLIFY ( AUX%NEXT%PREV ) DLL%FRONT => AUX%NEXT END IF ELSE IF ( .NOT. associated ( AUX%NEXT ) ) THEN NULLIFY ( AUX%PREV%NEXT ) DLL%BACK => AUX%PREV ELSE AUX%PREV%NEXT => AUX%NEXT AUX%NEXT%PREV => AUX%PREV END IF END IF POS = CPT DEALLOCATE ( AUX ) ELSE IDLL_REMOVE_ELMT = -3 RETURN END IF IDLL_REMOVE_ELMT = 0 END FUNCTION IDLL_REMOVE_ELMT FUNCTION IDLL_LENGTH(DLL) INTEGER :: IDLL_LENGTH #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL #else TYPE ( IDLL_T ), POINTER, INTENT ( IN ) :: DLL #endif INTEGER :: LENGTH TYPE ( IDLL_NODE_T ), POINTER :: AUX LENGTH = 0 IF ( .NOT. associated ( DLL ) ) THEN IDLL_LENGTH = -1 RETURN END IF AUX => DLL%FRONT DO WHILE ( associated ( AUX ) ) LENGTH = LENGTH + 1 AUX => AUX%NEXT END DO IDLL_LENGTH = LENGTH END FUNCTION IDLL_LENGTH FUNCTION IDLL_ITERATOR_BEGIN(DLL, PTR) INTEGER :: IDLL_ITERATOR_BEGIN #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL TYPE ( IDLL_NODE_T ), POINTER :: PTR #else TYPE ( IDLL_T ), POINTER, INTENT ( IN ) :: DLL TYPE ( IDLL_NODE_T ), POINTER, INTENT ( OUT ) :: PTR #endif IF ( .NOT. associated ( DLL ) ) THEN IDLL_ITERATOR_BEGIN = -1 RETURN END IF PTR => DLL%FRONT IDLL_ITERATOR_BEGIN = 0 END FUNCTION IDLL_ITERATOR_BEGIN FUNCTION IDLL_ITERATOR_END(DLL, PTR) INTEGER :: IDLL_ITERATOR_END #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL TYPE ( IDLL_NODE_T ), POINTER :: PTR #else TYPE ( IDLL_T ), POINTER, INTENT ( IN ) :: DLL TYPE ( IDLL_NODE_T ), POINTER, INTENT ( OUT ) :: PTR #endif IF ( .NOT. associated ( DLL ) ) THEN IDLL_ITERATOR_END = -1 RETURN END IF PTR => DLL%BACK IDLL_ITERATOR_END = 0 END FUNCTION IDLL_ITERATOR_END FUNCTION IDLL_IS_EMPTY(DLL) LOGICAL :: IDLL_IS_EMPTY #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL #else TYPE ( IDLL_T ), POINTER, INTENT ( IN ) :: DLL #endif IDLL_IS_EMPTY = ( associated ( DLL%FRONT ) ) END FUNCTION IDLL_IS_EMPTY FUNCTION IDLL_2_ARRAY(DLL, ARRAY, LENGTH) INTEGER :: IDLL_2_ARRAY #if defined(MUMPS_NOF2003) TYPE ( IDLL_T ), POINTER :: DLL INTEGER, POINTER, DIMENSION (:) :: ARRAY #else TYPE ( IDLL_T ), POINTER, INTENT ( IN ) :: DLL INTEGER, POINTER, DIMENSION (:), INTENT ( OUT ) :: ARRAY #endif INTEGER, INTENT ( OUT ) :: LENGTH TYPE ( IDLL_NODE_T ), POINTER :: AUX INTEGER :: I, IERR IF ( .NOT. associated ( DLL ) ) THEN IDLL_2_ARRAY = -1 RETURN END IF LENGTH = IDLL_LENGTH(DLL) ALLOCATE ( ARRAY ( max(1,LENGTH) ), STAT=IERR ) IF ( IERR .NE. 0 ) THEN IDLL_2_ARRAY = -2 RETURN END IF I = 1 AUX => DLL%FRONT DO WHILE ( associated ( AUX ) ) ARRAY ( I ) = AUX%ELMT I = I + 1 AUX => AUX%NEXT END DO IDLL_2_ARRAY = 0 END FUNCTION IDLL_2_ARRAY END MODULE MUMPS_IDLL MODULE MUMPS_DDLL IMPLICIT NONE TYPE DDLL_NODE_T TYPE ( DDLL_NODE_T ), POINTER :: NEXT, PREV DOUBLE PRECISION :: ELMT END TYPE DDLL_NODE_T TYPE DDLL_T TYPE ( DDLL_NODE_T ), POINTER :: FRONT, BACK END TYPE DDLL_T CONTAINS FUNCTION DDLL_CREATE(DLL) INTEGER :: DDLL_CREATE #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL #else TYPE ( DDLL_T ), POINTER, INTENT ( OUT ) :: DLL #endif INTEGER IERR ALLOCATE ( DLL, STAT=IERR ) IF ( IERR .NE. 0 ) THEN DDLL_CREATE = -2 RETURN END IF NULLIFY ( DLL%FRONT ) NULLIFY ( DLL%BACK ) DDLL_CREATE = 0 RETURN END FUNCTION DDLL_CREATE FUNCTION DDLL_DESTROY(DLL) INTEGER :: DDLL_DESTROY #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL #else TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif TYPE ( DDLL_NODE_T ), POINTER :: AUX IF ( .NOT. associated ( DLL ) ) THEN DDLL_DESTROY = -1 RETURN END IF DO WHILE ( associated ( DLL%FRONT ) ) AUX => DLL%FRONT DLL%FRONT => DLL%FRONT%NEXT DEALLOCATE( AUX ) END DO DEALLOCATE( DLL ) DDLL_DESTROY = 0 END FUNCTION DDLL_DESTROY FUNCTION DDLL_PUSH_FRONT(DLL, ELMT) INTEGER :: DDLL_PUSH_FRONT #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL #else TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif DOUBLE PRECISION, INTENT ( IN ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: NODE INTEGER IERR IF ( .NOT. associated ( DLL ) ) THEN DDLL_PUSH_FRONT = -1 RETURN END IF ALLOCATE( NODE, STAT=IERR ) IF ( IERR .NE. 0 ) THEN DDLL_PUSH_FRONT = -2 RETURN END IF NODE%ELMT = ELMT NODE%NEXT => DLL%FRONT NULLIFY ( NODE%PREV ) IF ( associated ( DLL%FRONT ) ) THEN DLL%FRONT%PREV => NODE END IF DLL%FRONT => NODE IF ( .NOT. associated ( DLL%BACK ) ) THEN DLL%BACK => NODE END IF DDLL_PUSH_FRONT = 0 END FUNCTION DDLL_PUSH_FRONT FUNCTION DDLL_POP_FRONT(DLL, ELMT) INTEGER :: DDLL_POP_FRONT #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL #else TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif DOUBLE PRECISION, INTENT ( OUT ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: AUX IF ( .NOT. associated ( DLL ) ) THEN DDLL_POP_FRONT = -1 RETURN END IF IF ( .NOT. associated ( DLL%FRONT ) ) THEN DDLL_POP_FRONT = -3 RETURN END IF ELMT = DLL%FRONT%ELMT AUX => DLL%FRONT DLL%FRONT => DLL%FRONT%NEXT IF ( associated ( DLL%FRONT ) ) THEN NULLIFY ( DLL%FRONT%PREV ) END IF IF ( associated ( DLL%BACK, AUX ) ) THEN NULLIFY ( DLL%BACK ) END IF DEALLOCATE ( AUX ) DDLL_POP_FRONT = 0 END FUNCTION DDLL_POP_FRONT FUNCTION DDLL_PUSH_BACK(DLL, ELMT) INTEGER :: DDLL_PUSH_BACK #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL #else TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif DOUBLE PRECISION, INTENT ( IN ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: NODE INTEGER IERR IF ( .NOT. associated ( DLL ) ) THEN DDLL_PUSH_BACK = -1 RETURN END IF ALLOCATE( NODE, STAT=IERR ) IF ( IERR .NE. 0 ) THEN DDLL_PUSH_BACK = -2 RETURN END IF NODE%ELMT = ELMT NULLIFY ( NODE%NEXT ) NODE%PREV => DLL%BACK IF ( associated ( DLL%BACK ) ) THEN DLL%BACK%NEXT => NODE END IF DLL%BACK => NODE IF ( .NOT. associated ( DLL%FRONT ) ) THEN DLL%FRONT => NODE END IF DDLL_PUSH_BACK = 0 END FUNCTION DDLL_PUSH_BACK FUNCTION DDLL_POP_BACK(DLL, ELMT) INTEGER :: DDLL_POP_BACK #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL #else TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif DOUBLE PRECISION, INTENT ( OUT ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: AUX IF ( .NOT. associated ( DLL ) ) THEN DDLL_POP_BACK = -1 RETURN END IF IF ( .NOT. associated ( DLL%BACK ) ) THEN DDLL_POP_BACK = -3 RETURN END IF ELMT = DLL%BACK%ELMT AUX => DLL%BACK DLL%BACK => DLL%BACK%PREV IF ( associated ( DLL%BACK ) ) THEN NULLIFY ( DLL%BACK%NEXT ) END IF IF ( associated ( DLL%FRONT, AUX ) ) THEN NULLIFY ( DLL%FRONT ) END IF DEALLOCATE ( AUX ) DDLL_POP_BACK = 0 END FUNCTION DDLL_POP_BACK FUNCTION DDLL_INSERT(DLL, POS, ELMT) INTEGER :: DDLL_INSERT #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL #else TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif INTEGER, INTENT ( IN ) :: POS DOUBLE PRECISION , INTENT ( IN ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: NODE TYPE ( DDLL_NODE_T ), POINTER :: NEW_PTR, OLD_PTR INTEGER :: IERR, CPT IF ( .NOT. associated ( DLL ) ) THEN DDLL_INSERT = -1 RETURN END IF IF ( POS .LE. 0 ) THEN DDLL_INSERT = -4 RETURN END IF CPT = 1 NEW_PTR => DLL%FRONT NULLIFY ( OLD_PTR ) DO WHILE ( ( CPT .LT. POS ) .AND. & ( associated ( NEW_PTR ) ) ) OLD_PTR => NEW_PTR NEW_PTR => NEW_PTR%NEXT CPT = CPT + 1 END DO ALLOCATE ( NODE, STAT=IERR ) IF ( IERR .NE. 0 ) THEN DDLL_INSERT = -2 RETURN END IF NODE%ELMT = ELMT IF ( .NOT. associated ( OLD_PTR ) ) THEN IF ( .NOT. associated ( NEW_PTR ) ) THEN NULLIFY ( NODE%PREV ) NULLIFY ( NODE%NEXT ) DLL%FRONT => NODE DLL%BACK => NODE ELSE NULLIFY ( NODE%PREV ) NODE%NEXT => NEW_PTR NEW_PTR%PREV => NODE DLL%FRONT => NODE END IF ELSE IF ( .NOT. associated ( NEW_PTR ) ) THEN NODE%PREV => OLD_PTR NULLIFY ( NODE%NEXT ) OLD_PTR%NEXT => NODE DLL%BACK => NODE ELSE NODE%PREV => OLD_PTR NODE%NEXT => NEW_PTR OLD_PTR%NEXT => NODE NEW_PTR%PREV => NODE END IF END IF DDLL_INSERT = 0 END FUNCTION DDLL_INSERT FUNCTION DDLL_INSERT_BEFORE(DLL, NODE_AFTER, ELMT) INTEGER :: DDLL_INSERT_BEFORE #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL TYPE ( DDLL_NODE_T ), POINTER :: NODE_AFTER #else TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL TYPE ( DDLL_NODE_T ), POINTER, INTENT ( IN ) :: NODE_AFTER #endif DOUBLE PRECISION, INTENT ( IN ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: NODE_BEFORE INTEGER :: IERR ALLOCATE ( NODE_BEFORE, STAT=IERR ) IF ( IERR .NE. 0 ) THEN DDLL_INSERT_BEFORE = -2 RETURN END IF NODE_BEFORE%ELMT = ELMT IF ( .NOT. associated ( NODE_AFTER%PREV ) ) THEN NODE_AFTER%PREV => NODE_BEFORE NODE_BEFORE%NEXT => NODE_AFTER NULLIFY ( NODE_BEFORE%PREV ) DLL%FRONT => NODE_BEFORE ELSE NODE_BEFORE%NEXT => NODE_AFTER NODE_BEFORE%PREV => NODE_AFTER%PREV NODE_AFTER%PREV => NODE_BEFORE NODE_BEFORE%PREV%NEXT => NODE_BEFORE END IF DDLL_INSERT_BEFORE = 0 END FUNCTION DDLL_INSERT_BEFORE FUNCTION DDLL_INSERT_AFTER(DLL, NODE_BEFORE, ELMT) INTEGER :: DDLL_INSERT_AFTER #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL TYPE ( DDLL_NODE_T ), POINTER :: NODE_BEFORE #else TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL TYPE ( DDLL_NODE_T ), POINTER, INTENT ( IN ) :: NODE_BEFORE #endif DOUBLE PRECISION, INTENT ( IN ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: NODE_AFTER INTEGER :: IERR ALLOCATE ( NODE_AFTER, STAT=IERR ) IF ( IERR .NE. 0 ) THEN DDLL_INSERT_AFTER = -2 RETURN END IF NODE_AFTER%ELMT = ELMT IF ( .NOT. associated ( NODE_BEFORE%NEXT ) ) THEN NODE_BEFORE%NEXT => NODE_AFTER NODE_AFTER%PREV => NODE_BEFORE NULLIFY ( NODE_AFTER%NEXT ) DLL%BACK => NODE_AFTER ELSE NODE_AFTER%PREV => NODE_BEFORE NODE_AFTER%NEXT => NODE_BEFORE%NEXT NODE_BEFORE%NEXT => NODE_AFTER NODE_AFTER%NEXT%PREV => NODE_AFTER END IF DDLL_INSERT_AFTER = 0 END FUNCTION DDLL_INSERT_AFTER FUNCTION DDLL_LOOKUP (DLL, POS, ELMT) INTEGER :: DDLL_LOOKUP #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL #else TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif INTEGER, INTENT ( IN ) :: POS DOUBLE PRECISION, INTENT ( OUT ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: AUX INTEGER :: CPT IF ( .NOT. associated ( DLL ) ) THEN DDLL_LOOKUP = -1 RETURN END IF IF ( POS .LE. 0 ) THEN DDLL_LOOKUP = -4 RETURN END IF CPT = 1 AUX => DLL%FRONT DO WHILE ( ( CPT .LT. POS ) .AND. ( associated ( AUX ) ) ) CPT = CPT + 1 AUX => AUX%NEXT END DO IF ( .NOT. associated ( AUX ) ) THEN DDLL_LOOKUP = -3 RETURN END IF ELMT = AUX%ELMT DDLL_LOOKUP = 0 END FUNCTION DDLL_LOOKUP FUNCTION DDLL_REMOVE_POS(DLL, POS, ELMT) INTEGER :: DDLL_REMOVE_POS #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL #else TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif INTEGER, INTENT ( IN ) :: POS DOUBLE PRECISION, INTENT ( OUT ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: AUX INTEGER :: CPT IF ( .NOT. associated ( DLL ) ) THEN DDLL_REMOVE_POS = -1 RETURN END IF CPT = 1 AUX => DLL%FRONT DO WHILE ( ( associated ( AUX ) ) .AND. & ( CPT .LT. POS ) ) CPT = CPT + 1 AUX => AUX%NEXT END DO IF ( associated ( AUX ) ) THEN IF ( .NOT. associated ( AUX%PREV ) ) THEN IF ( .NOT. associated ( AUX%NEXT ) ) THEN NULLIFY ( DLL%FRONT ) NULLIFY ( DLL%BACK ) ELSE NULLIFY ( AUX%NEXT%PREV ) DLL%FRONT => AUX%NEXT END IF ELSE IF ( .NOT. associated ( AUX%NEXT ) ) THEN NULLIFY ( AUX%PREV%NEXT ) DLL%BACK => AUX%PREV ELSE AUX%PREV%NEXT => AUX%NEXT AUX%NEXT%PREV => AUX%PREV END IF END IF ELMT = AUX%ELMT DEALLOCATE ( AUX ) ELSE DDLL_REMOVE_POS = -3 RETURN END IF DDLL_REMOVE_POS = 0 END FUNCTION DDLL_REMOVE_POS FUNCTION DDLL_REMOVE_ELMT(DLL, ELMT, POS) INTEGER :: DDLL_REMOVE_ELMT #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL #else TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #endif DOUBLE PRECISION, INTENT ( IN ) :: ELMT INTEGER, INTENT ( OUT ) :: POS TYPE ( DDLL_NODE_T ), POINTER :: AUX INTEGER :: CPT IF ( .NOT. associated ( DLL ) ) THEN DDLL_REMOVE_ELMT = -1 RETURN END IF CPT = 1 AUX => DLL%FRONT DO WHILE ( ( associated ( AUX ) ) .AND. & ( AUX%ELMT .NE. ELMT ) ) CPT = CPT + 1 AUX => AUX%NEXT END DO IF ( associated ( AUX ) ) THEN IF ( .NOT. associated ( AUX%PREV ) ) THEN IF ( .NOT. associated ( AUX%NEXT ) ) THEN NULLIFY ( DLL%FRONT ) NULLIFY ( DLL%BACK ) ELSE NULLIFY ( AUX%NEXT%PREV ) DLL%FRONT => AUX%NEXT END IF ELSE IF ( .NOT. associated ( AUX%NEXT ) ) THEN NULLIFY ( AUX%PREV%NEXT ) DLL%BACK => AUX%PREV ELSE AUX%PREV%NEXT => AUX%NEXT AUX%NEXT%PREV => AUX%PREV END IF END IF POS = CPT DEALLOCATE ( AUX ) ELSE DDLL_REMOVE_ELMT = -3 RETURN END IF DDLL_REMOVE_ELMT = 0 END FUNCTION DDLL_REMOVE_ELMT FUNCTION DDLL_LENGTH(DLL) INTEGER :: DDLL_LENGTH #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL #else TYPE ( DDLL_T ), POINTER, INTENT ( IN ) :: DLL #endif INTEGER :: LENGTH TYPE ( DDLL_NODE_T ), POINTER :: AUX IF ( .NOT. associated ( DLL ) ) THEN DDLL_LENGTH = -1 RETURN END IF LENGTH = 0 AUX => DLL%FRONT DO WHILE ( associated ( AUX ) ) LENGTH = LENGTH + 1 AUX => AUX%NEXT END DO DDLL_LENGTH = LENGTH END FUNCTION DDLL_LENGTH FUNCTION DDLL_ITERATOR_BEGIN(DLL, PTR) INTEGER :: DDLL_ITERATOR_BEGIN #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL TYPE ( DDLL_NODE_T ), POINTER :: PTR #else TYPE ( DDLL_T ), POINTER, INTENT ( IN ) :: DLL TYPE ( DDLL_NODE_T ), POINTER, INTENT ( OUT ) :: PTR #endif IF ( .NOT. associated ( DLL ) ) THEN DDLL_ITERATOR_BEGIN = -1 RETURN END IF PTR => DLL%FRONT DDLL_ITERATOR_BEGIN = 0 END FUNCTION DDLL_ITERATOR_BEGIN FUNCTION DDLL_ITERATOR_END(DLL, PTR) INTEGER :: DDLL_ITERATOR_END #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL TYPE ( DDLL_NODE_T ), POINTER :: PTR #else TYPE ( DDLL_T ), POINTER, INTENT ( IN ) :: DLL TYPE ( DDLL_NODE_T ), POINTER, INTENT ( OUT ) :: PTR #endif IF ( .NOT. associated ( DLL ) ) THEN DDLL_ITERATOR_END = -1 RETURN END IF PTR => DLL%BACK DDLL_ITERATOR_END = 0 END FUNCTION DDLL_ITERATOR_END FUNCTION DDLL_IS_EMPTY(DLL) LOGICAL :: DDLL_IS_EMPTY #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL #else TYPE ( DDLL_T ), POINTER, INTENT ( IN ) :: DLL #endif DDLL_IS_EMPTY = ( associated ( DLL%FRONT ) ) END FUNCTION DDLL_IS_EMPTY FUNCTION DDLL_2_ARRAY(DLL, ARRAY, LENGTH) INTEGER :: DDLL_2_ARRAY #if defined(MUMPS_NOF2003) TYPE ( DDLL_T ), POINTER :: DLL DOUBLE PRECISION, POINTER, DIMENSION(:) :: ARRAY #else TYPE ( DDLL_T ), POINTER, INTENT ( IN ) :: DLL DOUBLE PRECISION, POINTER, DIMENSION(:), INTENT(OUT) :: ARRAY #endif INTEGER, INTENT ( OUT ) :: LENGTH TYPE ( DDLL_NODE_T ), POINTER :: AUX INTEGER :: I, IERR IF ( .NOT. associated ( DLL ) ) THEN DDLL_2_ARRAY = -1 RETURN END IF LENGTH = DDLL_LENGTH(DLL) ALLOCATE ( ARRAY ( max(1,LENGTH) ), STAT=IERR ) IF ( IERR .NE. 0 ) THEN DDLL_2_ARRAY = -2 RETURN END IF I = 1 AUX => DLL%FRONT DO WHILE ( associated ( AUX ) ) ARRAY ( I ) = AUX%ELMT I = I + 1 AUX => AUX%NEXT END DO DDLL_2_ARRAY = 0 END FUNCTION DDLL_2_ARRAY END MODULE MUMPS_DDLL MUMPS_5.8.1/src/cfac_mem_compress_cb.F0000664000175000017500000005040615042446440017455 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SIZEFREEINREC(IW,LREC,SIZE_FREE,XSIZE) IMPLICIT NONE INTEGER, intent(in) :: LREC, XSIZE INTEGER, intent(in) :: IW(LREC) INTEGER(8), intent(out):: SIZE_FREE INTEGER(8) :: SIZE_STA, SIZE_DYN INCLUDE 'mumps_headers.h' CALL MUMPS_GETI8( SIZE_STA,IW(1+XXR) ) CALL MUMPS_GETI8( SIZE_DYN,IW(1+XXD) ) IF ( SIZE_DYN .GT. 0) THEN SIZE_FREE = SIZE_STA ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG .OR. & IW(1+XXS).EQ.S_NOLCBNOCONTIG) THEN SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE+3),8) ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG38 .OR. & IW(1+XXS).EQ.S_NOLCBNOCONTIG38) THEN SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE)+ & IW(1+XSIZE + 3) - & ( IW(1+XSIZE + 4) & - IW(1+XSIZE + 3) ), 8) ELSE IF (IW(1+XXS).EQ.S_NOLNOCB) THEN SIZE_FREE = SIZE_STA ELSE SIZE_FREE=0_8 ENDIF RETURN END SUBROUTINE CMUMPS_SIZEFREEINREC SUBROUTINE CMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, IW, XSIZE, KEEP216) IMPLICIT NONE LOGICAL, INTENT(out) :: RECORD_CAN_BE_COMPRESSED INTEGER, INTENT(in) :: XSIZE, KEEP216 INTEGER, INTENT(in) :: IW(XSIZE) INCLUDE 'mumps_headers.h' INTEGER(8) :: SIZE_DYN, SIZE_STA CALL MUMPS_GETI8( SIZE_STA, IW(1+XXR)) CALL MUMPS_GETI8( SIZE_DYN, IW(1+XXD)) IF (IW(1+XXS) .EQ. S_FREE) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE IF ( SIZE_DYN .GT. 0_8 .AND. SIZE_STA .GT. 0_8) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE IF ( IW(1+XXS) .EQ. S_NOLNOCB) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE RECORD_CAN_BE_COMPRESSED = & ( IW(1+XXS) .EQ. S_NOLCBNOCONTIG .OR. & IW(1+XXS) .EQ. S_NOLCBCONTIG .OR. & IW(1+XXS) .EQ. S_NOLCBNOCONTIG38 .OR. & IW(1+XXS) .EQ. S_NOLCBCONTIG38 ) & .AND. KEEP216.NE.3 ENDIF RETURN END SUBROUTINE CMUMPS_CAN_RECORD_BE_COMPRESSED SUBROUTINE CMUMPS_MOVETONEXTRECORD &(IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER(8) :: RCURRENT INTEGER LIW,IXXP,ICURRENT,NEXT,ISIZE2SHIFT INTEGER IW(LIW) INTEGER(8) :: RSIZE ICURRENT=NEXT CALL MUMPS_GETI8( RSIZE, IW(ICURRENT + XXR) ) RCURRENT = RCURRENT - RSIZE NEXT=IW(ICURRENT+XXP) IW(IXXP)=ICURRENT+ISIZE2SHIFT IXXP=ICURRENT+XXP RETURN END SUBROUTINE CMUMPS_MOVETONEXTRECORD SUBROUTINE CMUMPS_ISHIFT(IW,LIW,BEG2SHIFT,END2SHIFT,ISIZE2SHIFT) IMPLICIT NONE INTEGER LIW, BEG2SHIFT, END2SHIFT, ISIZE2SHIFT INTEGER IW(LIW) INTEGER I IF (ISIZE2SHIFT.GT.0) THEN DO I=END2SHIFT,BEG2SHIFT,-1 IW(I+ISIZE2SHIFT)=IW(I) ENDDO ELSE IF (ISIZE2SHIFT.LT.0) THEN DO I=BEG2SHIFT,END2SHIFT IW(I+ISIZE2SHIFT)=IW(I) ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_ISHIFT SUBROUTINE CMUMPS_RSHIFT(A, LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT) IMPLICIT NONE INTEGER(8) :: LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT COMPLEX A(LA) INTEGER(8) :: I IF (RSIZE2SHIFT.GT.0_8) THEN DO I=END2SHIFT,BEG2SHIFT,-1_8 A(I+RSIZE2SHIFT)=A(I) ENDDO ELSE IF (RSIZE2SHIFT.LT.0_8) THEN DO I=BEG2SHIFT,END2SHIFT A(I+RSIZE2SHIFT)=A(I) ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_RSHIFT SUBROUTINE CMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY: CMUMPS_DM_PAMASTERORPTRAST IMPLICIT NONE INTEGER, INTENT(in) :: N, LIW, XSIZE INTEGER, INTENT(in) :: KEEP(500) INTEGER(8), INTENT(in) :: LA INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS INTEGER, INTENT(inout) :: IWPOSCB INTEGER :: IWPOS INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP(28)), & PIMASTER(KEEP(28)) INTEGER, INTENT(in) :: STEP(N), SLAVEF INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) COMPLEX, INTENT(inout) :: A(LA) INTEGER, INTENT(inout) :: COMP REAL, INTENT(inout) :: ACC_TIME INTEGER, INTENT(in) :: MYID INCLUDE 'mumps_headers.h' INTEGER ICURRENT, NEXT, STATE_NEXT INTEGER(8) :: RCURRENT INTEGER ISIZE2SHIFT INTEGER(8) :: RSIZE2SHIFT INTEGER IBEGCONTIG INTEGER(8) :: RBEGCONTIG INTEGER(8) :: RBEG2SHIFT, REND2SHIFT INTEGER INODE LOGICAL :: IS_PAMASTER, IS_PTRAST INTEGER(8) :: FREE_IN_REC INTEGER(8) :: RCURRENT_SIZE, DYN_SIZE LOGICAL :: RECORD_CAN_BE_COMPRESSED INTEGER IXXP EXTERNAL MPI_WTIME DOUBLE PRECISION MPI_WTIME DOUBLE PRECISION TIME_STRT REAL TIME_COMP TIME_STRT = MPI_WTIME() ISIZE2SHIFT=0 RSIZE2SHIFT=0_8 ICURRENT = LIW-XSIZE+1 RCURRENT = LA+1_8 IBEGCONTIG = -999999 RBEGCONTIG = -999999_8 NEXT = IW(ICURRENT+XXP) IF (NEXT.EQ.TOP_OF_STACK) GOTO 120 COMP=COMP+1 STATE_NEXT = IW(NEXT+XXS) IXXP = ICURRENT+XXP 10 CONTINUE CALL CMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, & IW(NEXT), XSIZE, KEEP(216)) IF ( .NOT. RECORD_CAN_BE_COMPRESSED ) THEN CALL CMUMPS_MOVETONEXTRECORD(IW,LIW, & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) CALL MUMPS_GETI8(DYN_SIZE, IW(ICURRENT+XXD)) CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) IF (IBEGCONTIG < 0) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF IF (RBEGCONTIG < 0_8) THEN RBEGCONTIG=RCURRENT+RCURRENT_SIZE-1_8 ENDIF INODE=IW(ICURRENT+XXN) IF ( DYN_SIZE .EQ. 0_8 ) THEN IF (RSIZE2SHIFT .NE. 0_8) THEN CALL CMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, & KEEP(28), KEEP(199), & INODE, IW(ICURRENT+XXS), & IW(ICURRENT+XXD:ICURRENT+XXD+1), STEP, & DAD, PROCNODE_STEPS, RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF (IS_PTRAST) THEN PTRAST(STEP(INODE))= & PTRAST(STEP(INODE))+RSIZE2SHIFT ELSE IF (IS_PAMASTER) THEN PAMASTER(STEP(INODE))= & PAMASTER(STEP(INODE))+RSIZE2SHIFT ENDIF ENDIF ENDIF IF (ISIZE2SHIFT .NE. 0) THEN IF (PTRIST(STEP(INODE)).EQ.ICURRENT) & PTRIST(STEP(INODE))= & PTRIST(STEP(INODE))+ISIZE2SHIFT IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) & PIMASTER(STEP(INODE))= & PIMASTER(STEP(INODE))+ISIZE2SHIFT ENDIF IF (NEXT .NE. TOP_OF_STACK) THEN STATE_NEXT=IW(NEXT+XXS) GOTO 10 ENDIF ENDIF 20 CONTINUE IF (IBEGCONTIG.NE.0 .AND. ISIZE2SHIFT .NE. 0) THEN CALL CMUMPS_ISHIFT(IW,LIW,ICURRENT,IBEGCONTIG,ISIZE2SHIFT) IF (IXXP .LE.IBEGCONTIG) THEN IXXP=IXXP+ISIZE2SHIFT ENDIF ENDIF IBEGCONTIG=-9999 25 CONTINUE IF (RBEGCONTIG .GT.0_8 .AND. RSIZE2SHIFT .NE. 0_8) THEN CALL CMUMPS_RSHIFT(A,LA,RCURRENT,RBEGCONTIG,RSIZE2SHIFT) ENDIF RBEGCONTIG=-99999_8 30 CONTINUE IF (NEXT.EQ. TOP_OF_STACK) GOTO 100 CALL CMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, IW(NEXT), XSIZE, KEEP(216)) IF ( STATE_NEXT .NE. S_FREE .AND. & RECORD_CAN_BE_COMPRESSED ) THEN IF (RBEGCONTIG > 0_8) GOTO 25 CALL CMUMPS_MOVETONEXTRECORD & (IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IF (IBEGCONTIG < 0 ) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF CALL CMUMPS_SIZEFREEINREC(IW(ICURRENT), & LIW-ICURRENT+1, & FREE_IN_REC, & XSIZE) CALL MUMPS_GETI8(DYN_SIZE, IW(ICURRENT+XXD)) IF (DYN_SIZE .GT. 0_8) THEN ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG) THEN CALL CMUMPS_MAKECBCONTIG(A,LA,RCURRENT, & IW(ICURRENT+XSIZE+2), & IW(ICURRENT+XSIZE), & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), 0, & IW(ICURRENT+XXS),RSIZE2SHIFT) IW(ICURRENT+XXS) = S_NOLCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN CALL CMUMPS_MAKECBCONTIG(A,LA,RCURRENT, & IW(ICURRENT+XSIZE+2), & IW(ICURRENT+XSIZE), & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), & IW(ICURRENT+XSIZE+4)-IW(ICURRENT+XSIZE+3), & IW(ICURRENT+XXS),RSIZE2SHIFT) IW(ICURRENT+XXS) = S_NOLCLEANED38 ELSE IF (STATE_NEXT.EQ.S_NOLNOCB) THEN IW(ICURRENT+XXS) = S_NOLNOCBCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38) THEN IF (STATE_NEXT .EQ. S_NOLCBCONTIG) THEN IW(ICURRENT+XXS) = S_NOLCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG38) THEN IW(ICURRENT+XXS) = S_NOLCLEANED38 ENDIF IF (RSIZE2SHIFT .GT.0_8) THEN RBEG2SHIFT = RCURRENT + FREE_IN_REC CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) REND2SHIFT = RCURRENT + RCURRENT_SIZE - 1_8 CALL CMUMPS_RSHIFT(A, LA, & RBEG2SHIFT, REND2SHIFT, & RSIZE2SHIFT) ENDIF ELSE WRITE(*,*) "Internal error 3 in CMUMPS_COMPRE_NEW", & STATE_NEXT, DYN_SIZE, FREE_IN_REC CALL MUMPS_ABORT() ENDIF INODE = IW(ICURRENT+XXN) IF ( DYN_SIZE .GT. 0_8 ) THEN IF (PTRIST(STEP(INODE)).EQ.ICURRENT) & PTRIST(STEP(INODE))= & PTRIST(STEP(INODE))+ISIZE2SHIFT IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) & PIMASTER(STEP(INODE))= & PIMASTER(STEP(INODE))+ISIZE2SHIFT ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLNOCB ) THEN IF (ISIZE2SHIFT.NE.0) THEN PTRIST(STEP(INODE))=PTRIST(STEP(INODE))+ISIZE2SHIFT ENDIF PTRAST(STEP(INODE))=PTRAST(STEP(INODE))+RSIZE2SHIFT+ & FREE_IN_REC ELSE WRITE(*,*) "Internal error 4 in CMUMPS_COMPRE_NEW", & STATE_NEXT CALL MUMPS_ABORT() ENDIF CALL MUMPS_SUBTRI8TOARRAY(IW(ICURRENT+XXR),FREE_IN_REC) RSIZE2SHIFT=RSIZE2SHIFT+FREE_IN_REC RBEGCONTIG=-9999_8 IF (NEXT.EQ.TOP_OF_STACK) THEN GOTO 20 ELSE STATE_NEXT=IW(NEXT+XXS) ENDIF GOTO 30 ENDIF IF (IBEGCONTIG.GT.0) THEN GOTO 20 ENDIF 40 CONTINUE IF (STATE_NEXT == S_FREE) THEN ICURRENT = NEXT CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT + XXR) ) ISIZE2SHIFT = ISIZE2SHIFT + IW(ICURRENT+XXI) RSIZE2SHIFT = RSIZE2SHIFT + RCURRENT_SIZE RCURRENT = RCURRENT - RCURRENT_SIZE NEXT=IW(ICURRENT+XXP) IF (NEXT.EQ.TOP_OF_STACK) THEN WRITE(*,*) "Internal error 1 in CMUMPS_COMPRE_NEW" CALL MUMPS_ABORT() ENDIF STATE_NEXT = IW(NEXT+XXS) GOTO 40 ENDIF GOTO 10 100 CONTINUE IWPOSCB = IWPOSCB + ISIZE2SHIFT LRLU = LRLU + RSIZE2SHIFT IPTRLU = IPTRLU + RSIZE2SHIFT 120 CONTINUE TIME_COMP = real(MPI_WTIME() - TIME_STRT) IF (KEEP(405).EQ.0) THEN ACC_TIME = ACC_TIME + TIME_COMP ELSE !$OMP ATOMIC UPDATE ACC_TIME = ACC_TIME + TIME_COMP !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE CMUMPS_COMPRE_NEW SUBROUTINE CMUMPS_GET_SIZEHOLE(IREC, IW, LIW, & ISIZEHOLE, RSIZEHOLE) IMPLICIT NONE INTEGER, intent(in) :: IREC, LIW INTEGER, intent(in) :: IW(LIW) INTEGER, intent(out):: ISIZEHOLE INTEGER(8), intent(out) :: RSIZEHOLE INTEGER IRECLOC INTEGER(8) :: RECLOC_SIZE INCLUDE 'mumps_headers.h' ISIZEHOLE=0 RSIZEHOLE=0_8 IRECLOC = IREC + IW( IREC+XXI ) 10 CONTINUE CALL MUMPS_GETI8(RECLOC_SIZE, IW(IRECLOC+XXR)) IF (IW(IRECLOC+XXS).EQ.S_FREE) THEN ISIZEHOLE=ISIZEHOLE+IW(IRECLOC+XXI) RSIZEHOLE=RSIZEHOLE+RECLOC_SIZE IRECLOC=IRECLOC+IW(IRECLOC+XXI) GOTO 10 ENDIF RETURN END SUBROUTINE CMUMPS_GET_SIZEHOLE SUBROUTINE CMUMPS_MAKECBCONTIG(A, LA, RCURRENT, & NROW, NCB, LD, NELIM, NODESTATE, ISHIFT) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER LD, NROW, NCB, NELIM, NODESTATE INTEGER(8) :: ISHIFT INTEGER(8) :: LA, RCURRENT COMPLEX A(LA) INTEGER I,J INTEGER(8) :: IOLD,INEW LOGICAL NELIM_ROOT NELIM_ROOT=.TRUE. IF (NODESTATE.EQ. S_NOLCBNOCONTIG) THEN NELIM_ROOT=.FALSE. IF (NELIM.NE.0) THEN WRITE(*,*) "Internal error 1 IN CMUMPS_MAKECBCONTIG" CALL MUMPS_ABORT() ENDIF ELSE IF (NODESTATE .NE. S_NOLCBNOCONTIG38) THEN WRITE(*,*) "Internal error 2 in CMUMPS_MAKECBCONTIG" & ,NODESTATE CALL MUMPS_ABORT() ENDIF IF (ISHIFT .LT.0_8) THEN WRITE(*,*) "Internal error 3 in CMUMPS_MAKECBCONTIG",ISHIFT CALL MUMPS_ABORT() ENDIF IF (NELIM_ROOT) THEN IOLD=RCURRENT+int(LD,8)*int(NROW,8)+int(NELIM-1-NCB,8) ELSE IOLD = RCURRENT+int(LD,8)*int(NROW,8)-1_8 ENDIF INEW = RCURRENT+int(LD,8)*int(NROW,8)+ISHIFT-1_8 DO I = NROW, 1, -1 IF (I.EQ.NROW .AND. ISHIFT.EQ.0_8.AND. & .NOT. NELIM_ROOT) THEN IOLD=IOLD-int(LD,8) INEW=INEW-int(NCB,8) CYCLE ENDIF IF (NELIM_ROOT) THEN DO J=1,NELIM A( INEW ) = A( IOLD + int(- J + 1,8)) INEW = INEW - 1_8 ENDDO ELSE DO J=1, NCB A( INEW ) = A( IOLD + int(- J + 1, 8)) INEW = INEW - 1_8 ENDDO ENDIF IOLD = IOLD - int(LD,8) ENDDO IF (NELIM_ROOT) THEN NODESTATE=S_NOLCBCONTIG38 ELSE NODESTATE=S_NOLCBCONTIG ENDIF RETURN END SUBROUTINE CMUMPS_MAKECBCONTIG SUBROUTINE CMUMPS_GET_SIZE_NEEDED( & SIZEI_NEEDED, SIZER_NEEDED, SKIP_TOP_STACK, & KEEP, KEEP8, & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR & ) #if ! defined(NODYNAMICCB) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY: CMUMPS_DM_CBSTATIC2DYNAMIC #endif IMPLICIT NONE INTEGER, INTENT(in) :: SIZEI_NEEDED INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: KEEP(500) INTEGER(8), INTENT(inout):: KEEP8(150) INTEGER, INTENT(in) :: N, LIW, XSIZE INTEGER(8), INTENT(in) :: LA INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS INTEGER, INTENT(inout) :: IWPOSCB INTEGER, INTENT(inout) :: IWPOS INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP(28)), & PIMASTER(KEEP(28)) INTEGER, INTENT(in) :: STEP(N), SLAVEF INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) COMPLEX, INTENT(inout) :: A(LA) INTEGER, INTENT(inout) :: COMP REAL, INTENT(inout) :: ACC_TIME INTEGER, INTENT(iN) :: MYID INTEGER, INTENT(inout) :: IFLAG, IERROR LOGICAL CMUMPS_COMPRE_NEW_CALLED CMUMPS_COMPRE_NEW_CALLED = .FALSE. IF (IWPOSCB-IWPOS+1 .LT. SIZEI_NEEDED) THEN CALL CMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 1 in CMUMPS_GET_SIZE_NEEDED ', & 'PB compress... CMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF CMUMPS_COMPRE_NEW_CALLED = .TRUE. IF (IWPOSCB-IWPOS+1 .LT. SIZEI_NEEDED) THEN IFLAG = -8 IERROR = SIZEI_NEEDED GOTO 500 ENDIF ENDIF IF ( .NOT.CMUMPS_COMPRE_NEW_CALLED.AND. & (LRLU.LT.SIZER_NEEDED).AND. & (LRLUS.GE.SIZER_NEEDED).AND. & (LRLU.NE.LRLUS) & ) THEN CALL CMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) CMUMPS_COMPRE_NEW_CALLED = .TRUE. IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 2 ', & 'in CMUMPS_GET_SIZE_NEEDED ', & 'PB compress... CMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF IF (LRLUS.LT.SIZER_NEEDED) THEN #if ! defined(NODYNAMICCB) IF (.NOT. CMUMPS_COMPRE_NEW_CALLED) THEN CALL CMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 2 ', & 'in CMUMPS_GET_SIZE_NEEDED ', & 'PB compress... CMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF CALL CMUMPS_DM_CBSTATIC2DYNAMIC(KEEP(141), & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 500 IF (LRLU.LT.SIZER_NEEDED) THEN CALL CMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 4 ', & 'in CMUMPS_GET_SIZE_NEEDED ', & 'PB compress... CMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF #else IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) GOTO 500 #endif ENDIF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_GET_SIZE_NEEDED MUMPS_5.8.1/src/smumps_driver.F0000664000175000017500000030714415042446441016250 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C =========================== C FORTRAN 90 Driver for SMUMPS C (MPI based code) C =========================== C SUBROUTINE SMUMPS( id ) USE MUMPS_MEMORY_MOD USE SMUMPS_STRUC_DEF USE SMUMPS_STATIC_PTR_M ! For Schur pointer #if ! defined(NO_SAVE_RESTORE) USE SMUMPS_SAVE_RESTORE #endif USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_INTR_STRUC, & SMUMPS_ENCODE_INTR, & SMUMPS_DECODE_INTR, & SMUMPS_INIT_INTR_ENCODING, & SMUMPS_FREE_INTR_ENCODING C !$ USE OMP_LIB C IMPLICIT NONE C C ======= C Purpose C ======= C C TO SOLVE a SPARSE SYSTEM OF LINEAR EQUATIONS. C GIVEN AN UNSYMMETRIC, SYMMETRIC, OR SYMMETRIC POSITIVE DEFINITE C SPARSE MATRIX A AND AN N-VECTOR B, THIS SUBROUTINE SOLVES THE C SYSTEM A x = b or ATRANSPOSE x = b. C C List of main functionalities provided by the package: C ---------------------------------------------------- C -Unsymmetric solver with partial pivoting (LU factorization) C -Symmetric positive definite solver (LDLT factorization) C -General symmetric solver with pivoting C -Either elemental or assembled matrix input C -Analysis/Factorization/Solve callable separately C -Deficient matrices (symmetric or unsymmetric) C -Rank revealing C -Null space basis computation C -Solution C -Return the Schur complement matrix while C also providing solution of interior problem C -Distributed input matrix and analysis phase C -Sequential or parallel MPI version (any number of processors) C -Error analysis and iterative refinement C -Out-of-Core factorization and solution C -Solution phase: C -Multiple Right-Hand-sides (RHS) C -Sparse RHS C -Distributed RHS C -Computation of selected entries of the inverse of C original matrix. C - Block Low-Rank (BLR) approximation based factorization C C Method C ------ C The method used is a parallel direct method C based on a sparse multifrontal variant C of Gaussian elimination with partial numerical pivoting. C An initial ordering for the pivotal sequence C is chosen using the pattern of the matrix A + A^T and is C later modified for reasons of numerical stability. Thus this code C performs best on matrices whose pattern is symmetric, or nearly so. C For symmetric sparse matrices or for very unsymmetric and C very sparse matrices, other software might be more appropriate. C C C References : C ----------- C Please see https://mumps-solver.org/index.php?page=doc C C============================================ C Argument lists and calling sequences C============================================ C C There is only one entry: * * A Fortran 90 driver subroutine SMUMPS has been designed as a user * friendly interface to the multifrontal code. * This driver, in addition to providing the * normal functionality of a sparse solver, incorporates some * pre- and post-processing. * This driver enables the user to preprocess the matrix to obtain a * maximum * transversal so that the permuted matrix has a zero-free diagonal, * to perform prescaling * of the original matrix (a choice of scaling strategies is provided), * to use iterative refinement to improve the solution, * and finally to perform error analysis. * * The driver routine SMUMPS offers similar functionalities to other * sparse direct solvers, depending on the value of one of * its parameters (JOB). The main ones are: * * (i) JOB = -1 C initializes an instance of the package. This must be C called before any other call to the package concerning that instance. C It sets default values for other C components of SMUMPS_STRUC, which may then be altered before C subsequent calls to SMUMPS. C Note that three components of the structure must always be set by the C user (on all processors) before a call with JOB=-1. These are C id%COMM, C id%SYM, and C id%PAR. C CNTL, ICNTL can then be modified (see documentation) by the user. C * A value of JOB = -1 cannot be combined with other values for JOB * * (ii) JOB = 1 accepts the pattern of matrix A and chooses pivots * from the diagonal using a selection criterion to * preserve sparsity. It uses the pattern of A + A^T * but ignores numerical values. It subsequently constructs subsidiary * information for the actual factorization by a call with JOB_=_2. * An option exists for the user to * input the pivot sequence, in which case only the necessary * information for a JOB = 2 entry will be generated. We call the JOB=1 * entry, the analysis phase. C The following components of the structure define the centralized matrix C pattern and must be set by the user (on the host only) C before a call with JOB=1: C --- id%N, id%NZ (32-bit int) or id%NNZ (64-bit int), C id%IRN, and id%JCN C if the user wishes to input the structure of the C matrix in assembled format (ICNTL(5)=0, and ICNTL(18) $\neq$ 3), C --- id%ELTPTR, and id%ELTVAR C if the user wishes to input the matrix in elemental C format (ICNTL(5)=1). C A distributed matrix format is also available (see documentation) C * (iii) JOB = 2 factorizes a matrix A using the information * from a previous call with JOB = 1. The actual pivot sequence * used may differ slightly from that of this earlier call if A is not * diagonally dominant. * * (iv) JOB = 3 uses the factors generated by a JOB = 2 call to solve * a system of equations A X = B or A^T X =B, where X and B are matrices * that can be either dense or sparse. * The sparsity of B is exploited to limit the number of operations * performed during solution. When only part of the solution is * also needed (such as when computing selected entries of A^1) then * further reduction of the number of operations is performed. * This is particularly beneficial in the context of an * out-of-core factorization. * * (v) JOB = -2 frees all internal data allocated by the package. * * A call with JOB=3 must be preceded by a call with JOB=2, * which in turn must be preceded by a call with JOB=1, which * in turn must be preceded by a call with JOB=-1. Since the * information passed from one call to the next is not * corrupted by the second, several calls with JOB=2 for matrices * with the same sparsity pattern but different values may follow * a single call with JOB=1, and similarly several calls with JOB=3 * can be used for different right-hand sides. * Values 4, 5, 6 for the parameter JOB can invoke combinations * of the three basic operations corresponding to JOB=1, 2 or 3. * * JOB = -4 : frees all data structures from the factorization * while keeping data structures from the analysis. Can be * followed by a JOB = 2 call. * #if ! defined(NO_SAVE_RESTORE) * JOB = -3, 7, 8 : save and restore feature, see userguide #endif * JOB = 9 : provide suggested data distribution for IRHS_LOC C ********* C -------------------------------------- C Explicit interface needed for routines C using a target argument if they appear C in the same compilation unit. C -------------------------------------- INTERFACE SUBROUTINE SMUMPS_CHECK_DENSE_RHS &(idRHS, idINFO, idN, idNRHS, idLRHS) REAL, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE SMUMPS_CHECK_DENSE_RHS SUBROUTINE SMUMPS_ANA_DRIVER( id, idintr ) USE SMUMPS_STRUC_DEF USE SMUMPS_INTR_TYPES TYPE (SMUMPS_STRUC), TARGET :: id TYPE (SMUMPS_INTR_STRUC) :: idintr END SUBROUTINE SMUMPS_ANA_DRIVER SUBROUTINE SMUMPS_FAC_DRIVER( id, idintr ) USE SMUMPS_STRUC_DEF USE SMUMPS_INTR_TYPES TYPE (SMUMPS_STRUC), TARGET :: id TYPE (SMUMPS_INTR_STRUC) :: idintr END SUBROUTINE SMUMPS_FAC_DRIVER SUBROUTINE SMUMPS_SOLVE_DRIVER( id, idintr ) USE SMUMPS_STRUC_DEF USE SMUMPS_INTR_TYPES TYPE (SMUMPS_STRUC), TARGET :: id TYPE (SMUMPS_INTR_STRUC) :: idintr END SUBROUTINE SMUMPS_SOLVE_DRIVER SUBROUTINE SMUMPS_PRINT_ICNTL(id, LP) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP END SUBROUTINE SMUMPS_PRINT_ICNTL END INTERFACE * MPI * === INCLUDE 'mpif.h' INTEGER MASTER PARAMETER ( MASTER = 0 ) INTEGER IERR * * ========== * Parameters * ========== TYPE (SMUMPS_STRUC) :: id C C Main components of the structure are: C ------------------------------------ C C (see documentation for a complete description) C C JOB is an INTEGER variable which must be set by the user to C characterize the factorization step. Possible values of JOB C are given below C C 1 Analysis: Ordering and symbolic factorization steps. C 2 Scaling and Numerical Factorization C 3 Solve and Error analysis C 4 Analysis followed by numerical factorization C 5 Numerical factorization followed by Solving step C 6 Analysis, Numerical factorization and Solve C C N is an INTEGER variable which must be set by the user to the C order n of the matrix A. It is not altered by the C subroutine. C C NZ / NNZ are INTEGER / INTEGER(8) variables which must be set by the user C to the number of entries being input, in case of centralized assembled C entry. It is not altered by the subroutine. Only used if C ICNTL(5).eq.0 and ICNTL(18) .ne. 3 (assembled matrix entry, C or, at least, centralized matrix graph during analysis). C C Restriction: NZ > 0 or NNZ > 0. C If NNZ is different from 0, NNZ is used. Otherwise, NZ is used. C C NELT is an INTEGER variable which must be set by the user to the C number of elements being input. It is not altered by the C subroutine. Only used if ICNTL(5).eq.1 (elemental matrix entry). C Restriction: NELT > 0. C C IRN and JCN are INTEGER arrays of length [N]NZ. C IRN(k) and JCN(k), k=1..[N]NZ must be set on entry to hold C the row and column indices respectively. C They are not altered by the subroutine except when ICNTL(6) = 1. C (in which case only the column indices are modified). C The arrays are only used if ICNTL(5).eq.0 (assembled entry) C or out-of-range. C C ELTPTR is an INTEGER array of length NELT+1. C ELTVAR is an INTEGER array of length ELTPTR(NELT+1)-1. C ELTPTR(I) points in ELTVAR to the first variable in the list of C variables that correspond to element I. ELTPTR(NELT+1) points C to the first unused location in ELTVAR. C The positions ELTVAR(I) .. ELTPTR(I+1)-1 contain the variables C for element I. No free space is allowed between variable lists. C ELTPTR/ELTVAR are not altered by the subroutine. C The arrays are only used if ICNTL(5).ne.0 (element entry). C C A is a REAL array of length [N]NZ. C The user must set A(k) to the value C of the entry in row IRN(k) and column JCN(k) of the matrix. C It is not altered by the subroutine. C (Note that the matrix can also be provided in a distributed C assembled input format) C C RHS is a REAL array of length N that is only accessed when C JOB = 3, 5, or 6. On entry, RHS(i) C must hold the i th component of the right-hand side of the C equations being solved. C On exit, RHS(i) will hold the i th component of the C solution vector. For other values of JOB, RHS is not accessed and C can be declared to have size one. C RHS should only be available on the host processor. If C it is associated on other processors, an error is raised. C (Note that the right-hand sides can also be provided in a C sparse format). C C COLSCA, ROWSCA are REAL C arrays of length N that are used to hold C the values used to scale the columns and the rows C of the original matrix, respectively. C These arrays need to be set by the user C only if ICNTL(8) is set to -1. If ICNTL(8)=0, C COLSCA and ROWSCA are not accessed and C so can be declared to have size one. C For any other values of ICNTL(8), C the scaling arrays are computed before C numerical factorization. The factors of the scaled matrix C diag(ROWSCA(i)) automatic choice IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ( id%KEEP(52) .EQ. 2 .OR. id%KEEP(52).EQ.5 & .OR. id%KEEP(52) .EQ. 6 ) & id%KEEP(52) = 77 IF ((id%KEEP(52).EQ.77).AND.(id%KEEP(50).EQ.1)) THEN ! for SPD matrices default is no scaling id%KEEP(52) = 0 ENDIF IF ( id%KEEP(52).EQ.77 .OR. id%KEEP(52).LE.-2) THEN C -- suppress scaling computed during analysis C -- if centralized matrix is not associated IF (.not.associated(id%A)) id%KEEP(52) = 0 ENDIF C deactivate analysis scaling if scaling given IF(id%KEEP(52) .EQ. -1) id%KEEP(52) = 0 C C deactivate analysis scaling if C permutation to zero-free diagonal not requested IF (id%ICNTL(6).EQ.0) id%KEEP(52) = 0 C deactivate analysis scaling for SPD matrices IF (id%KEEP(50).EQ.1) id%KEEP(52) = 0 C IF (id%KEEP(52).EQ.-2) THEN C deallocate scalings in case of ordering allocated/computed C during analysis. This is needed because in case of C KEEP(52)=-2 then one cannot be sure that C scaling will be effectivly computed during analysis C Thus to test if scaling was effectively allocated/computed C during analysis after SMUMPS_ANA_DRIVER one must C be sure that scaling arrays are nullified. IF ( associated(id%COLSCA)) THEN DEALLOCATE( id%COLSCA ) NULLIFY(id%COLSCA) ENDIF IF ( associated(id%ROWSCA)) THEN DEALLOCATE( id%ROWSCA ) NULLIFY(id%ROWSCA) ENDIF ENDIF C C} ENDIF C C ANALYSIS PHASE: CALL SMUMPS_ANA_DRIVER( id, idintr ) C restore values id%KEEP(77) = KEEP77SAVE id%KEEP(78) = KEEP78SAVE id%KEEP(83) = KEEP83SAVE id%KEEP(91) = KEEP91SAVE id%KEEP(172) = KEEP172SAVE id%KEEP(178) = KEEP178SAVE #if ! defined(LARGEMATRICES) IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0) THEN IF (.not.associated(id%UNS_PERM)) THEN C I may happen C (for ex in case of error -7 during analysis: C UNS_PERM can be not associated, C KEEP(23) was set to to automatic choice(=7) and C an error of memory allocation occurs during analysis C before having decided value of KEEP(23)) C UNS_PERM not associated and KEEP(23).NE.0 C Permuting JCN back does not make sense and KEEP(23) C should be reset to zero id%KEEP(23) = 0 ELSE UNS_PERM_DONE = .TRUE. ENDIF ENDIF #endif C C Check and save scaling option in INFOG(33) IF (id%MYID .eq. MASTER) THEN C{ IF (id%KEEP(52).EQ.0) id%INFOG(33)=id%ICNTL(8) IF (id%KEEP(52).EQ.-2) THEN C Scaling should have been computed during analysis IF (.not.associated(id%COLSCA).OR. & .not.associated(id%ROWSCA) & ) THEN C scaling was not computed reset KEEP(52) C the user can then decide during factorization C to activate scaling id%KEEP(52) =0 id%INFOG(33)=0 IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') & ' Warning; scaling was not computed during analysis' ENDIF IF ( associated(id%COLSCA)) THEN DEALLOCATE( id%COLSCA ) NULLIFY(id%COLSCA) ENDIF IF ( associated(id%ROWSCA)) THEN DEALLOCATE( id%ROWSCA ) NULLIFY(id%ROWSCA) ENDIF ENDIF ENDIF IF (id%KEEP(52) .NE. 0) THEN id%INFOG(33)=id%KEEP(52) ENDIF C} ENDIF C return value of ICNTL(12) effectively used C that was saved on the master in KEEP(95) IF (id%MYID .eq. MASTER) id%INFOG(24)=id%KEEP(95) C TIMINGS: IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(71) = real(TIMEG) ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in analysis driver= ', TIMEG END IF C ----------------------- C Return in case of error C ----------------------- IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 id%KEEP(40) = 1 -456789 END IF C C------------------------------------------------------- C- C C BEGIN FACTORIZATION PHASE C C- C------------------------------------------------------- IF ( LFACTO ) THEN C{ IF (id%MYID .eq. MASTER) THEN id%DKEEP(91)=0.0E0 CALL MUMPS_SECDEB(TIMEG) END IF C ---------------------- C Reset KEEP(40) to 1 in C case of error in facto C ---------------------- id%KEEP(40) = 1 - 456789 C C------------------------------------------------------- C- C- CHECKS, SCALING, ARROWHEAD + FACTORIZATION PHASE C- C------------------------------------------------------- C C Broadcast the value of KEEP(125) to decide if performing C the scaling with the Schur complement feature. CALL MPI_BCAST( id%KEEP(125), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) IF ( id%MYID .EQ. MASTER ) THEN C ------------------------- C Check if Schur complement C is allocated. C ------------------------- IF (id%KEEP(60).EQ.1) THEN IF ( associated( id%SCHUR_CINTERFACE)) THEN C Called from C interface... C Since id%SCHUR_CINTERFACE is of size 1, C instruction below which causes bound check C errors should be avoided. We cheat by first C setting a static pointer with a routine with C implicit interface, and then copying this pointer C into id%SCHUR. CALL SMUMPS_SET_TMP_PTR(id%SCHUR_CINTERFACE(1), & int(id%SIZE_SCHUR,8)*int(id%SIZE_SCHUR,8)) CALL SMUMPS_GET_TMP_PTR(id%SCHUR) NULLIFY(id%SCHUR_CINTERFACE) ENDIF IF ( .NOT. associated (id%SCHUR)) THEN IF (LP.GT.0) & write(LP,'(A)') & ' SCHUR not associated' id%INFO(1)=-22 id%INFO(2)=9 ELSE IF ( size(id%SCHUR) .LT. & id%SIZE_SCHUR * id%SIZE_SCHUR ) THEN IF (LP.GT.0) & write(LP,'(A)') & ' SCHUR allocated but too small' id%INFO(1)=-22 id%INFO(2)=9 END IF END IF C ------------------------------------------------------------ C Assembled entry: check input parameterd IRN,JCN,A C Element entry: check input parameters ELTPTR,ELTVAR,A_ELT C ------------------------------------------------------------ IF ( id%KEEP(54) .EQ. 0 ) THEN IF ( id%KEEP(55).eq.0 ) THEN C Assembled entry IF ( .not. associated( id%IRN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 #if defined(MUMPS_NOF2003) C size with kind=8 output not available. One can still C check that if NZ can be stored in a 32-bit integer, C the 32-bit size(id%IRN) (which we then assume not C to overflow...) is large enough ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%IRN) < int(id%KEEP8(28)) ) THEN #else ELSE IF ( size( id%IRN, KIND=8 ) < id%KEEP8(28) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%JCN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 #if defined(MUMPS_NOF2003) C Same as for IRN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%JCN) < int(id%KEEP8(28)) ) THEN #else ELSE IF ( size( id%JCN, KIND=8 ) < id%KEEP8(28) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( .not. associated( id%A ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 #if defined(MUMPS_NOF2003) C Same as for IRN/JCN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size( id%A ) < int(id%KEEP8(28)) ) THEN #else ELSE IF ( size( id%A, KIND=8 ) < id%KEEP8(28) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 END IF ELSE C Element entry IF ( .not. associated( id%ELTPTR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( size( id%ELTPTR ) < id%NELT+1 ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%ELTVAR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( size( id%ELTVAR ) < id%LELTVAR ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( .not. associated( id%A_ELT ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ELSE #if defined(MUMPS_NOF2003) IF ( id%KEEP8(30) < int(huge(id%NZ),8) .AND. & size( id%A_ELT ) < int(id%KEEP8(30)) ) THEN #else IF ( size( id%A_ELT, KIND=8 ) < id%KEEP8(30) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ENDIF END IF ENDIF ENDIF C ---------------------- C Get the value of PERLU C ---------------------- CALL MUMPS_GET_PERLU(id%KEEP(12),id%ICNTL(14), & id%KEEP(50),id%KEEP(54),id%ICNTL(6),id%ICNTL(8)) C C ---------------------- C Get null space options C Note that nullspace is forbidden in case of Schur complement C ---------------------- CALL SMUMPS_GET_NS_OPTIONS_FACTO(id%N,id%KEEP(1), & id%ICNTL(1),MPG) C ======================================== C Decode and set scaling options for facto C ======================================== IF (.NOT. ((id%KEEP(52).EQ.-2).AND.(id%ICNTL(8).EQ.77)) ) & THEN C if scaling was computed during analysis and automatic C choice of scaling then we do not recompute scaling id%KEEP(52)=id%ICNTL(8) ENDIF IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ( id%KEEP(52) .EQ. 2 .OR. id%KEEP(52).EQ.5 & .OR. id%KEEP(52) .EQ. 6 ) & id%KEEP(52) = 77 IF (id%KEEP(52).EQ.77) THEN IF (id%KEEP(50).EQ.1) THEN ! for SPD matrices the default is "no scaling" id%KEEP(52) = 0 ELSE ! SYM .ne. 1 the default is cheap SIMSCA id%KEEP(52) = 7 ENDIF ENDIF IF (id%KEEP(23) .NE. 0 .AND. id%ICNTL(8) .EQ. -1) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** WARNING : SCALING' WRITE(MPG,'(A)') & ' ** column permutation applied:' WRITE(MPG,'(A)') & ' ** column scaling has to be permuted' ENDIF ENDIF C ----------------------------------- C If Schur has been asked for C choose to disable or enable scaling C ---------------------------------- IF (id%KEEP(125).EQ.0) THEN C ------------------------ C scaling is disabled C ------------------------ IF ( id%KEEP(60) .ne. 0 .and. id%KEEP(52) .ne. 0 ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 .AND. id%ICNTL(8) .NE. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: scaling not applied.' WRITE(MPG,'(A)') ' ** (disabled with Schur)' END IF END IF END IF C ------------------------------- C If matrix is distributed on C entry, only options 7 and 8 C of scaling are allowed. C ------------------------------- IF (id%KEEP(54) .NE. 0 .AND. & id%KEEP(52).NE.7 .AND. id%KEEP(52).NE.8 .AND. & id%KEEP(52) .NE. 0 ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 .and. id%ICNTL(8) .ne. 0 ) THEN WRITE(MPG,'(A)') & ' ** Warning: requested scaling option not available' WRITE(MPG,'(A)') ' ** for distributed matrix entry' END IF END IF C ------------------------------------ C If matrix is symmetric, only scaling C options -1 (given scaling), 1 C (diagonal scaling), 7 and 8 (SIMSCALING) C are allowed. C ------------------------------------ IF ( id%KEEP(50) .NE. 0 ) THEN IF ( id%KEEP(52).ne. 1 .and. & id%KEEP(52).ne. -1 .and. & id%KEEP(52).ne. 0 .and. & id%KEEP(52).ne. 7 .and. & id%KEEP(52).ne. 8 .and. & id%KEEP(52).ne. -2 .and. & id%KEEP(52).ne. 77) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') & ' ** Warning: scaling option n.a. for symmetric matrix' END IF id%KEEP(52) = 0 END IF END IF C ---------------------------------- C If matrix is elemental on entry, C automatic scaling is now forbidden C ---------------------------------- IF (id%KEEP(55) .NE. 0 .AND. & ( id%KEEP(52) .gt. 0 ) ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: scaling not applied.' WRITE(MPG,'(A)') & ' ** (only user scaling av. for elt. entry)' END IF END IF C -------------------------------------- C Check input parameters ROWSCA / COLSCA C -------------------------------------- IF ( id%KEEP(52) .eq. -1 ) THEN IF ( .not. associated( id%ROWSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( .not. associated( id%COLSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 6 ELSE IF ( size( id%COLSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 6 END IF END IF C C Allocate -- if required, C ROWSCA and COLSCA on the master C C Allocation of scaling arrays. C IF (KEEP(52)==-2 then scaling should have been allocated C and computed during analysis C C If ICNTL(8) == -1, ROWSCA and COLSCA must have been associated and C filled by the user. If ICNTL(8) is >0 and <= 8, the scaling is C computed at the beginning of SMUMPS_FAC_DRIVER and is allocated now. C IF (id%KEEP(52).GT.0 .AND. & id%KEEP(52) .LE.8) THEN IF ( associated(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(id%N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=id%N ENDIF ALLOCATE( id%ROWSCA(id%N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=id%N ENDIF END IF C C Allocate scaling arrays of size 1 if C they are not used to avoid problems C when passing them in arguments C IF (.NOT. associated(id%COLSCA)) THEN ALLOCATE( id%COLSCA(1), stat=IERR) END IF IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 ENDIF IF (.NOT. associated(id%ROWSCA)) & ALLOCATE( id%ROWSCA(1), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF ( LPOK ) WRITE(LP,'(A)') & 'Problems in allocations before facto' GOTO 200 END IF IF (id%KEEP(252) .EQ. 1) THEN CALL SMUMPS_CHECK_DENSE_RHS & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) C Sets KEEP(221) and do some checks C in case of Schur check if reduced RHS C requested CALL SMUMPS_SET_K221(id,.FALSE.) CALL SMUMPS_CHECK_K221andREDRHS(id) ENDIF 200 CONTINUE END IF ! End of IF (MYID .eq. MASTER) C KEEP(221) was set in SMUMPS_SET_K221 but not broadcast CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) C broadcast RR option CALL MPI_BCAST( id%KEEP(19), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) C C Check distributed matrices on all processors. I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (I_AM_SLAVE .AND. & id%KEEP(54).NE.0 .AND. id%KEEP8(29).GT.0_8) THEN IF ( .not. associated( id%IRN_loc ) ) THEN id%INFO(1) = -22 id%INFO(2) = 16 #if defined(MUMPS_NOF2003) C size with kind=8 output not available. One can still C check that if NZ_loc can be stored in a 32-bit integer, C the 32-bit size(id%IRN_loc) (which we then assume not C to overflow...) is large enough ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size(id%IRN_loc) < int(id%KEEP8(29)) ) THEN #else ELSE IF ( size( id%IRN_loc, KIND=8 ) < id%KEEP8(29) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 16 ELSE IF ( .not. associated( id%JCN_loc ) ) THEN id%INFO(1) = -22 id%INFO(2) = 16 #if defined(MUMPS_NOF2003) C Same as for IRN_loc above ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size(id%JCN_loc) < int(id%KEEP8(29)) ) THEN #else ELSE IF ( size( id%JCN_loc, KIND=8 ) < id%KEEP8(29) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 16 ELSEIF ( .not. associated( id%A_loc ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 16 #if defined(MUMPS_NOF2003) C Same as for IRN_loc/JCN_loc above ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size( id%A_loc ) < int(id%KEEP8(29)) ) THEN #else ELSE IF ( size( id%A_loc, KIND=8 ) < id%KEEP8(29) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 16 END IF ENDIF C C Check Schur complement on all processors. C SMUMPS_PROPINFO will be called right after those checks. C IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF ( idintr%root%yes ) THEN IF ( associated( id%SCHUR_CINTERFACE )) THEN C Called from C interface... C The next instruction may cause C bound check errors at runtime C id%SCHUR=>id%SCHUR_CINTERFACE C & (1:id%SCHUR_LLD*(idintr%root%SCHUR_NLOC-1)+ C & idintr%root%SCHUR_MLOC) C Instead, we set a temporary C pointer and then retrieve it CALL SMUMPS_SET_TMP_PTR(id%SCHUR_CINTERFACE(1), & int(id%SCHUR_LLD,8)*int(idintr%root%SCHUR_NLOC-1,8)+ & int(idintr%root%SCHUR_MLOC,8)) CALL SMUMPS_GET_TMP_PTR(id%SCHUR) NULLIFY(id%SCHUR_CINTERFACE) ENDIF C Check that SCHUR_LLD is large enough IF (id%SCHUR_LLD < idintr%root%SCHUR_MLOC) THEN IF (LP.GT.0) write(LP,*) & ' SCHUR leading dimension SCHUR_LLD ', & id%SCHUR_LLD, 'too small with respect to', & idintr%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*(idintr%root%SCHUR_NLOC-1)+ & idintr%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=', idintr%root%SCHUR_NLOC, & ' SCHUR_NLOC=', idintr%root%SCHUR_NLOC ENDIF id%INFO(1)=-22 id%INFO(2)= 9 ELSE C We initialize the pointer that C we will use within SMUMPS here. idintr%root%SCHUR_LLD=id%SCHUR_LLD IF (idintr%root%SCHUR_NLOC==0) THEN ALLOCATE(idintr%roota%SCHUR_POINTER(1), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF ( LPOK ) THEN WRITE(LP,'(A)') & 'Problems in allocations before facto' ENDIF END IF ELSE idintr%roota%SCHUR_POINTER=>id%SCHUR ENDIF ENDIF ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 C ----------------------------------------------- C Call factorization procedure SMUMPS_FAC_DRIVER C ----------------------------------------------- CALL SMUMPS_FAC_DRIVER(id,idintr) C Save scaling in INFOG(33) IF (id%MYID .eq. MASTER) id%INFOG(33)=id%KEEP(52) C C In the case of Schur, free or not associated C idintr%roota%SCHUR_POINTER now rather than in end_driver.F C (Case of repeated factorizations). IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF (idintr%root%yes) THEN IF (idintr%root%SCHUR_NLOC==0) THEN DEALLOCATE(idintr%roota%SCHUR_POINTER) NULLIFY(idintr%roota%SCHUR_POINTER) ELSE NULLIFY(idintr%roota%SCHUR_POINTER) ENDIF ENDIF ENDIF IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(91) = real(TIMEG) ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in factorization driver =', & TIMEG END IF C C Check for errors after FACTO C (it was propagated inside) IF(id%INFO(1).LT.0) THEN C ------------------------------------------------------- C Free data from this factorization. Since factorization C fails, factors, etc. can not be used to perform a solve C ------------------------------------------------------- CALL SMUMPS_FREE_DATA_FACTO(id,idintr) GO TO 499 ENDIF C C Update last successful step C id%KEEP(40) = 2 - 456789 C} END IF C------------------------------------------------------- C- C C BEGIN SOLVE PHASE C C- C------------------------------------------------------- IF (LSOLVE) THEN IF (id%MYID .eq. MASTER) THEN id%DKEEP(111)=0.0E0 CALL MUMPS_SECDEB(TIMEG) END IF C --------------------- C Reset KEEP(40) to 2. C (last successful step C was facto) C --------------------- id%KEEP(40) = 2 -456789 C ------------------------------------------ C Call solution procedure SMUMPS_SOLVE_DRIVER C ------------------------------------------ IF (id%MYID .eq. MASTER) THEN KEEP235SAVE = id%KEEP(235) KEEP242SAVE = id%KEEP(242) KEEP243SAVE = id%KEEP(243) KEEP495SAVE = id%KEEP(495) KEEP497SAVE = id%KEEP(497) ! if no permutation of RHS asked then suppress request ! to interleave the RHS ! to interleave the RHS on ordering given then ! using option to set permutation to identity should be ! used (note though that ! they # with A-1/sparseRHS and Null Space) IF (id%KEEP(242).EQ.0) id%KEEP(243)=0 C -------------------------------------- C Check input parameters ROWSCA / COLSCA C Only if KEEP(52).NE.0 because C only 0 means that no colsca/rowsca are needed C -------------------------------------- IF ( id%KEEP(52) .ne. 0) THEN IF ( .not. associated( id%ROWSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( .not. associated( id%COLSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 6 ELSE IF ( size( id%COLSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 6 END IF ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 CALL SMUMPS_SOLVE_DRIVER(id,idintr) IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(111) = real(TIMEG) ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in solve driver= ', TIMEG END IF IF (id%MYID .eq. MASTER) THEN id%KEEP(235) = KEEP235SAVE id%KEEP(242) = KEEP242SAVE id%KEEP(243) = KEEP243SAVE id%KEEP(495) = KEEP495SAVE id%KEEP(497) = KEEP497SAVE ENDIF IF (id%INFO(1).LT.0) GOTO 499 C --------------------------- C Update last successful step C --------------------------- id%KEEP(40) = 3 -456789 ENDIF C C What was actually done is saved in KEEP(40) C IF (PROK) CALL SMUMPS_PRINT_ICNTL(id, MP) GOTO 500 * *================= * ERROR section *================= 499 CONTINUE * Print error message if PROK IF (LPOK) WRITE (LP,99995) id%INFO(1) IF (LPOK) WRITE (LP,99994) id%INFO(2) * 500 CONTINUE #if ! defined(LARGEMATRICES) C --------------------------------- C Permute JCN on output to SMUMPS if C KEEP(23) is different from 0. C --------------------------------- IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0 & .AND. NOERRORBEFOREPERM) THEN C ------------------------------- C IF JOB=3 and PERM was not C done (no iterative refinement/ C error analysis), then we do not C permute JCN back. C ------------------------------- IF (UNS_PERM_DONE) THEN DO I8 = 1_8, id%KEEP8(28) J=id%JCN(I8) C -- skip out-of range (that are ignored in ANA_O) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I8)=id%UNS_PERM(J) END DO END IF END IF #endif 510 CONTINUE C ------------------------------------ C Set INFOG(1:2): same value on all C processors + broadcast other entries C ------------------------------------ CALL SMUMPS_SET_INFOG(id%INFO(1), id%INFOG(1), id%COMM, id%MYID) C C -------------------------------- C Broadcast RINFOG entries to make C them available on all procs. C -------------------------------- CALL MPI_BCAST( id%RINFOG(1), 40, MPI_REAL, MASTER, & id%COMM, IERR ) IF (id%INFOG(1).GE.0 .AND. JOB.NE.-1 & .AND. JOB.NE.-2 ) THEN IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMETOTAL) id%DKEEP(70) = real(TIMETOTAL) ENDIF ENDIF C ------------------------------------------------------------ C SCHUR_CINTERFACE is no longer needed. It will be set again C the next time MUMPS is entered through its C interface. C ------------------------------------------------------------ NULLIFY(id%SCHUR_CINTERFACE) C #if ! defined(NO_SAVE_RESTORE) *======================= * Compute space for save *======================= IF (id%INFOG(1).GE.0) THEN IF ( IDINTR_MEANINGFUL_ON_EXIT ) THEN C Only do this if idintr is meaningful on exit. This includes C the case of JOB -2 that needs to update statistics. This excludes C the cases of JOBs that did not decode idintr, for which the save C restore statistics have not changed. CALL SMUMPS_COMPUTE_MEMORY_SAVE(id,idintr,FILE_SIZE,STRUC_SIZE) id%KEEP8(55)=FILE_SIZE call MPI_ALLREDUCE(id%KEEP8(55),id%KEEP8(57),1, & MPI_INTEGER8, MPI_SUM,id%COMM,IERR) id%KEEP8(56)=STRUC_SIZE call MPI_ALLREDUCE(id%KEEP8(56),id%KEEP8(58),1, & MPI_INTEGER8, MPI_SUM,id%COMM,IERR) id%RINFO(7)=REAL(id%KEEP8(55))/1E6 id%RINFO(8)=REAL(id%KEEP8(56))/1E6 id%RINFOG(17)=REAL(id%KEEP8(57))/1E6 id%RINFOG(18)=REAL(id%KEEP8(58))/1E6 ENDIF ENDIF #endif !$ IF (ICNTL16_LOC .GT. 0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(PREVIOUS_OMP_THREADS_NUM,4)) #else !$ CALL omp_set_num_threads(PREVIOUS_OMP_THREADS_NUM) #endif !$ ICNTL16_LOC = 0 !$ ENDIF *=============== * ERRORG section *=============== IF (id%MYID.EQ.MASTER.and.MPG.GT.0.and. & id%INFOG(1).lt.0) THEN WRITE(MPG,'(A,I16)') ' On return from SMUMPS, INFOG(1)=', & id%INFOG(1) WRITE(MPG,'(A,I16)') ' On return from SMUMPS, INFOG(2)=', & id%INFOG(2) END IF C ------------------------- C Restore user communicator C ------------------------- CALL MPI_COMM_FREE( id%COMM, IERR ) id%COMM = COMM_SAVE C ------------------------------------ C Set id%INTR_ENCODING from idintr C ------------------------------------ IF (MUST_ENCODE_IDINTR_ON_EXIT) THEN CALL SMUMPS_ENCODE_INTR(id%INTR_ENCODING, idintr) ENDIF RETURN * 99995 FORMAT (' ** ERROR RETURN ** FROM SMUMPS INFO(1)=', I5) 99994 FORMAT (' ** INFO(2)=', I16) 99993 FORMAT (' ** Allocation error: could not permute JCN.') END SUBROUTINE SMUMPS * SUBROUTINE SMUMPS_SET_INFOG( INFO, INFOG, COMM, MYID ) IMPLICIT NONE INCLUDE 'mpif.h' C C Purpose: C ======= C C If one proc has INFO(1).lt.0 and INFO(1) .ne. -1, C puts INFO(1:2) of this proc on all procs in INFOG C C Arguments: C ========= C INTEGER, PARAMETER :: SIZE_INFOG = 80 INTEGER :: INFO(80) INTEGER :: INFOG(SIZE_INFOG) ! INFOG(80) INTEGER :: COMM, MYID C C Local variables C =============== C #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) :: TMP1(2),TMP(2) #else INTEGER :: TMP1(2),TMP(2) #endif INTEGER ROOT, IERR INTEGER MASTER, WARNING_COUNT PARAMETER (MASTER=0) C C IF ( INFO(1) .ge. 0 ) THEN C C This can only happen if the phase was successful C on all procs. If one proc failed, then all other C procs would have INFO(1)=-1. C IF (INFO(1) .GT.0) THEN WARNING_COUNT=1 ELSE WARNING_COUNT=0 ENDIF INFOG(1) = INFO(1) INFOG(2) = INFO(2) CALL MPI_ALLREDUCE(WARNING_COUNT, INFOG(2), 1,MPI_INTEGER, & MPI_SUM, COMM, IERR) CALL MPI_ALLREDUCE(INFO(1),INFOG(1),1, MPI_INTEGER, & MPI_BOR, COMM, IERR) ELSE C --------------------- C Find who has smallest C error code INFO(1) C --------------------- INFOG(1) = INFO(1) C INFOG(2) = MYID TMP1(1) = INFO(1) TMP1(2) = MYID CALL MPI_ALLREDUCE(TMP1,TMP,1,MPI_2INTEGER, & MPI_MINLOC,COMM,IERR ) INFOG(2) = INFO(2) ROOT = TMP(2) CALL MPI_BCAST( INFOG(1), 1, MPI_INTEGER, ROOT, COMM, IERR ) CALL MPI_BCAST( INFOG(2), 1, MPI_INTEGER, ROOT, COMM, IERR ) END IF C C Make INFOG available on all procs: C CALL MPI_BCAST(INFOG(3), SIZE_INFOG-2, MPI_INTEGER, & MASTER, COMM, IERR ) RETURN END SUBROUTINE SMUMPS_SET_INFOG C-------------------------------------------------------------------- SUBROUTINE SMUMPS_PRINT_ICNTL (id, LP) USE SMUMPS_STRUC_DEF * * Purpose: * Print main control parameters CNTL and ICNTL * * ========== * Parameters * ========== TYPE (SMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP ** Local Variables INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL REAL, DIMENSION(:),POINTER::CNTL INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL CNTL=>id%CNTL IF (id%MYID.EQ.MASTER) THEN SELECT CASE (JOB) CASE(1); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ENDIF IF ((ICNTL(6).EQ.5).OR.(ICNTL(6).EQ.6).OR. & (ICNTL(12).NE.1) ) THEN WRITE (LP,992) ICNTL(8) ENDIF IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) WRITE (LP,996) ICNTL(56) CASE(2); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36), ICNTL(49) WRITE (LP,996) ICNTL(56) 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),ICNTL(26) CASE(4); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ENDIF WRITE (LP,992) ICNTL(8) IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36), ICNTL(49) WRITE (LP,996) ICNTL(56) CASE(5); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ENDIF WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21),ICNTL(26) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36), ICNTL(49) WRITE (LP,996) ICNTL(56) CASE(6); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ENDIF IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,992) ICNTL(8) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21), ICNTL(26) WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36), ICNTL(49) WRITE (LP,996) ICNTL(56) END SELECT ENDIF 980 FORMAT (/'***********CONTROL PARAMETERS (ICNTL)**************'/) 981 FORMAT ( & ' CNTL(1) Threshold for numerical pivoting =',D16.4/ & ' CNTL(3) Threshold to detect singularities =',D16.4/ & ' CNTL(4) Threshold for static pivoting =',D16.4/ & ' CNTL(5) Fixation for null pivots =',D16.4/ & ' CNTL(7) Dropping threshold for BLR compression =',D16.4) 990 FORMAT ( & 'ICNTL(1) Output stream for error messages =',I10/ & 'ICNTL(2) Output stream for diagnostic messages =',I10/ & 'ICNTL(3) Output stream for global information =',I10/ & 'ICNTL(4) Level of printing =',I10) 991 FORMAT ( & 'ICNTL(5) Matrix format =',I10/ & 'ICNTL(6) Maximum transversal =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(12) LDLT ordering strat =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(15) Analysis by block =',I10/ & 'ICNTL(18) Distributed matrix =',I10/ & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-of-core option (1=on, off otherwise)=',I10/ & 'ICNTL(48) Tree based multithreading =',I10/ & 'ICNTL(58) Symbolic factorization option =',I10) 891 FORMAT ( & 'ICNTL(5) Matrix format =',I10/ & 'ICNTL(6) Maximum transversal =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(15) Analysis by block =',I10/ & 'ICNTL(18) Distributed matrix =',I10/ & 'ICNTL(19) Schur option ( 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-of-core option (1=on, off otherwise)=',I10/ & 'ICNTL(48) Tree based multithreading =',I10/ & 'ICNTL(58) Symbolic factorization option =',I10) 992 FORMAT ( & 'ICNTL(8) Scaling strategy =',I10) 923 FORMAT ( & 'ICNTL(24) Null pivot detection (0=off) =',I10/ & 'ICNTL(31) Discard factors (0=off, else=on) =',I10/ & 'ICNTL(32) Forward elimination during facto (0=off)=',I10/ & 'ICNTL(33) Compute determinant (0=off) =',I10/ & 'ICNTL(35) Block Low Rank (BLR, 0=off >0=on) =',I10/ & 'ICNTL(36) BLR variant =',I10/ & 'ICNTL(49) Compact workarray S (end of facto.) =',I10) 993 FORMAT ( & 'ICNTL(14) Percent of memory increase =',I10) 996 FORMAT ( & 'ICNTL(56) Null space functionality =',I10) 995 FORMAT ( & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ & 'ICNTL(10) Max steps iterative refinement =',I10/ & 'ICNTL(11) Error analysis (1=all,2=some,else=off) =',I10/ & 'ICNTL(20) Den.(0)/sparse(1,2,3)/dist.(10,11) RHS =',I10/ & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10/ & 'ICNTL(26) Solution step =',I10) 998 FORMAT ( & ' Size of SCHUR matrix (SIZE_SCHUR) =',I10) END SUBROUTINE SMUMPS_PRINT_ICNTL C-------------------------------------------------------------------- SUBROUTINE SMUMPS_PRINT_KEEP(id, LP) USE SMUMPS_STRUC_DEF * * ========== * Parameters * ========== TYPE (SMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER ::LP ** Local Variables INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL, KEEP INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL KEEP=>id%KEEP IF (id%MYID.EQ.MASTER) THEN SELECT CASE (JOB) CASE(1); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6))THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) CASE(2); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (KEEP(23).EQ.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) WRITE (LP,996) KEEP(19), KEEP(118) WRITE (LP,994) KEEP(21) 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), ICNTL(26) 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), ICNTL(26) WRITE (LP,993) KEEP(12) WRITE (LP,997) KEEP(53) WRITE (LP,996) KEEP(19), KEEP(118) WRITE (LP,994) KEEP(21) 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) WRITE (LP,996) KEEP(19), KEEP(118) WRITE (LP,994) KEEP(21) 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), ICNTL(26) WRITE (LP,993) KEEP(12) WRITE (LP,997) KEEP(53) WRITE (LP,996) KEEP(19), KEEP(118) WRITE (LP,994) KEEP(21) 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-of-core option (1=on, off otherwise)=',I10) 992 FORMAT ( & 'ICNTL(8) Scaling strategy ( keep(52) ) =',I10) 993 FORMAT ( & 'ICNTL(14) Percent of memory increase ( keep(12) ) =',I10) 995 FORMAT ( & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ & 'ICNTL(10) Max steps iterative refinement =',I10/ & 'ICNTL(11) Error analysis ( 0= off, else=on) =',I10/ & 'ICNTL(20) Den.(0)/sparse(1,2,3)/dist.(10,11) RHS =',I10/ & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10/ & 'ICNTL(26) Solution step =',I10) 997 FORMAT ( & 'ICNTL(56) Null space-analysis ( keep(53) ) =',I10) 996 FORMAT ( & 'ICNTL(56) Null space-factorisation ( keep(19) ) =',I10/ & 'KEEP(118) Algorithm used for null space =',I10) 994 FORMAT ( & 'ICNTL(57) Estimate of null space size ( keep(21) )=',I10) END SUBROUTINE SMUMPS_PRINT_KEEP SUBROUTINE SMUMPS_CHECK_DENSE_RHS & (idRHS, idINFO, idN, idNRHS, idLRHS) IMPLICIT NONE C C Purpose: C ======= C C Check that the dense RHS is associated and of C correct size. Called on master only, when dense C RHS is supposed to be allocated. This can be used C either at the beginning of the solve phase or C at the beginning of the factorization phase C if forward solve is done during factorization C (see ICNTL(32)) ; idINFO(1), idINFO(2) may be C modified. C C C Arguments: C ========= C C id* : see corresponding components of the main C MUMPS structure. C REAL, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) IF ( .not. associated( idRHS ) ) THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 ELSE IF (idNRHS.EQ.1) THEN IF ( size( idRHS ) < idN ) THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 ENDIF ELSE IF (idLRHS < idN) & THEN idINFO( 1 ) = -26 idINFO( 2 ) = idLRHS ELSE IF #if defined(MUMPS_NOF2003) C size with kind=8 not available. One can still C perform the check if minimal size small enough. & (int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN & .LE. int(huge(idN),8) & .and. & size(idRHS) < int(int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN)) #else & (size(idRHS,kind=8) < & int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN) #endif & THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 END IF RETURN END SUBROUTINE SMUMPS_CHECK_DENSE_RHS C SUBROUTINE SMUMPS_SET_K221(id,ATSOLVE) USE SMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C Sets KEEP(221) on master. C [Schur only] must be called before SMUMPS_CHECK_REDRHS C C Can be called at factorization C (in case of fwd in facto) or at solve phase C ATSOLVE=.TRUE. if called during solve phase C TYPE (SMUMPS_STRUC) :: id LOGICAL, INTENT(IN) :: ATSOLVE LOGICAL :: PROKG INTEGER :: MPG INTEGER MASTER PARAMETER( MASTER = 0 ) MPG = id%ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) IF (id%MYID.EQ.MASTER) THEN id%KEEP(221)=id%ICNTL(26) IF (id%KEEP(221).NE.0 .AND. id%KEEP(221) .NE.1 & .AND.id%KEEP(221).NE.2) id%KEEP(221)=0 ENDIF RETURN END SUBROUTINE SMUMPS_SET_K221 C SUBROUTINE SMUMPS_CHECK_K221andREDRHS(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C * Decode API related to REDRHS and check REDRHS C * Can be called at factorization or solve phase C * Constraints: C - Must be called after solve phase. C - KEEP(60) must have been set (ok to check C since KEEP(60) was set during analysis phase) C * Remark that during solve phase, ICNTL(26)#0 is C forbidden in case of fwd in facto. C TYPE (SMUMPS_STRUC) :: id INTEGER MASTER PARAMETER( MASTER = 0 ) C write(6,*) " Entering SMUMPS_CHECK_K221andREDRHS with : ", C & " id%JOB, id%KEEP(221), id%KEEP(60), id%SIZE_SCHUR= ", C & id%JOB, id%KEEP(221), id%KEEP(60), id%SIZE_SCHUR 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 .NE.3 ) & ) THEN id%INFO(1)=-33 id%INFO(2)=id%JOB 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) C write(6,*) " id%KEEP(60), id%SIZE_SCHUR=", C & id%KEEP(60), id%SIZE_SCHUR GOTO 333 ENDIF IF ( id%KEEP(60).NE.0 ) THEN C Schur feature IF ( 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 ENDIF 333 CONTINUE C Error is not propagated. It should be propagated outside. C The reason to propagate it outside is that there can be C one call to PROPINFO instead of several ones. RETURN END SUBROUTINE SMUMPS_CHECK_K221andREDRHS MUMPS_5.8.1/src/zfac_front_aux.F0000664000175000017500000026565315042446441016371 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_FRONT_AUX_M CONTAINS SUBROUTINE ZMUMPS_FAC_H(NFRONT,NASS,IW,LIW,A,LA, & INOPV,NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IOLDPS,POSELT,UU,SEUIL,KEEP, KEEP8, DKEEP, & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U,MAXFROMN,IS_MAXFROMN_AVAIL, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, NVSCHUR &) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,LIW,INOPV INTEGER(8) :: LA INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: DKEEP(230) DOUBLE PRECISION UU, SEUIL COMPLEX(kind=8) A(LA) INTEGER IW(LIW) DOUBLE PRECISION, intent(in) :: MAXFROMN LOGICAL, intent(inout) :: IS_MAXFROMN_AVAIL INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER, intent(in) :: NVSCHUR DOUBLE PRECISION AMROW DOUBLE PRECISION RMAX, SEUIL_LOC COMPLEX(kind=8) SWOP INTEGER(8) :: APOS, POSELT INTEGER(8) :: J1, J2, J3_8, JJ, IDIAG INTEGER(8) :: J1_ini INTEGER(8) :: NFRONT8 INTEGER IOLDPS INTEGER NPIV,IPIV,IPIV_SHIFT INTEGER, intent(inout) :: NOFFW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW INTEGER J, J3 INTEGER NPIVP1,JMAX,ISW,ISWPS1 INTEGER ISWPS2,KSW,XSIZE INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INTEGER ISHIFT, K206 INTEGER ZMUMPS_IXAMAX INCLUDE 'mumps_headers.h' INTRINSIC max DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 #if defined(_OPENMP) INTEGER :: NOMP, CHUNK NOMP = OMP_GET_MAX_THREADS() #endif SEUIL_LOC = max(DKEEP(1), SEUIL) NFRONT8 = int(NFRONT,8) INOPV = 0 XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 K206 = KEEP(206) IF ((KEEP(50).NE.1).AND.OOC_EFFECTIVE_ON_FRONT) THEN CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE) & +KEEP(IXSZ), & IW, LIW) CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF ISHIFT = 0 IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.NASS) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF (ISHIFT.GT.0.AND.IS_MAXFROMN_AVAIL) THEN IPIV = NPIVP1 APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)) .GE. UU*MAXFROMN .AND. & abs(A(IDIAG)) .GT. max(SEUIL_LOC,tiny(RMAX)) & ) THEN ISHIFT = 0 ENDIF ENDIF IF ( ISHIFT .GT. 0) THEN IS_MAXFROMN_AVAIL = .FALSE. ENDIF ENDIF DO 460 IPIV_SHIFT=NPIVP1+ISHIFT,NASS+ISHIFT IF (IPIV_SHIFT .LE. NASS) THEN IPIV=IPIV_SHIFT ELSE IPIV=IPIV_SHIFT-NASS-1+NPIVP1 ENDIF APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) JMAX = 1 AMROW = RZERO J1 = APOS J3 = NASS -NPIV JMAX = ZMUMPS_IXAMAX(J3,A(J1),NFRONT,KEEP(360)) JJ = J1 + int(JMAX-1,8)*NFRONT8 AMROW = abs(A(JJ)) RMAX = AMROW J1 = APOS + int(NASS-NPIV,8) * NFRONT8 J3 = NFRONT - NASS - KEEP(253)-NVSCHUR IF (IS_MAXFROMN_AVAIL) THEN RMAX = max(MAXFROMN,RMAX) IS_MAXFROMN_AVAIL = .FALSE. ELSE IF (J3.EQ.0) GOTO 370 #if defined(_OPENMP) IF (J3.GE.KEEP(360)) THEN J1_ini = J1 CHUNK = max(KEEP(360)/2,(J3+NOMP-1)/NOMP) !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& FIRSTPRIVATE(J1_ini,NFRONT8,J3) !$OMP& REDUCTION(max:RMAX) DO J=1,J3 RMAX = max(abs(A(J1_ini + int(J-1,8) * NFRONT8)), & RMAX) END DO !$OMP END PARALLEL DO ELSE #endif DO J=1,J3 RMAX = max(abs(A(J1)), RMAX) J1 = J1 + NFRONT8 END DO #if defined(_OPENMP) ENDIF #endif END IF 370 IF (RMAX.LE.tiny(RMAX)) GO TO 460 IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)) .GE. UU*RMAX .AND. & abs(A(IDIAG)) .GT. max(SEUIL_LOC,tiny(RMAX)) ) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF ( .NOT. ( AMROW .GE. UU*RMAX .AND. & AMROW .GT. max(SEUIL_LOC,tiny(RMAX)) & ) & ) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS + int(JMAX - 1,8) * NFRONT8 )), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER( & A(APOS + int(JMAX - 1,8) * NFRONT8 ), & DET_MANTW, DET_EXPW ) ENDIF IF ( IPIV .NE. NPIVP1 .OR. JMAX .NE. 1) THEN IF (KEEP(405) .EQ.0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF ENDIF IF (IPIV.EQ.NPIVP1) GO TO 400 DET_SIGNW = - DET_SIGNW J1 = POSELT + int(NPIV,8) J3_8 = POSELT + int(IPIV-1,8) DO J= 1,NFRONT SWOP = A(J1) A(J1) = A(J3_8) A(J3_8) = SWOP J1 = J1 + NFRONT8 J3_8 = J3_8 + NFRONT8 END DO ISWPS1 = IOLDPS + 5 + NPIVP1 + NFRONT + XSIZE ISWPS2 = IOLDPS + 5 + IPIV + NFRONT + XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW 400 IF (JMAX.EQ.1) GO TO 420 DET_SIGNW = -DET_SIGNW J1 = POSELT + int(NPIV,8) * NFRONT8 J2 = POSELT + int(NPIV + JMAX - 1,8) * NFRONT8 DO KSW=1,NFRONT SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + 1_8 J2 = J2 + 1_8 END DO ISWPS1 = IOLDPS + 5 + NPIV + 1 + XSIZE ISWPS2 = IOLDPS + 5 + NPIV + JMAX + XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE INOPV = 1 GOTO 430 420 CONTINUE IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE IS_MAXFROMN_AVAIL = .FALSE. RETURN END SUBROUTINE ZMUMPS_FAC_H SUBROUTINE ZMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP,MAXFROMN,IS_MAXFROMN_AVAIL,NVSCHUR) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER NFRONT,NASS,LIW,IFINB INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER IW(LIW) COMPLEX(kind=8) ALPHA,VALPIV INTEGER(8) :: APOS, POSELT, UUPOS, LPOS, IRWPOS INTEGER(8) :: NFRONT8 INTEGER IOLDPS,NPIV,XSIZE INTEGER, intent(in) :: KEEP(500) DOUBLE PRECISION, intent(inout) :: MAXFROMN LOGICAL, intent(inout) :: IS_MAXFROMN_AVAIL INTEGER, intent(in) :: NVSCHUR INTEGER NEL,IROW,NEL2,JCOL,NELMAXM INTEGER NPIVP1 COMPLEX(kind=8), PARAMETER :: ONE=(1.0D0,0.0D0) #if defined(_OPENMP) LOGICAL:: OMP_FLAG INTEGER:: NOMP, CHUNK NOMP = OMP_GET_MAX_THREADS() #endif NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 NELMAXM= NEL -KEEP(253)-NVSCHUR NEL2 = NASS - NPIVP1 IFINB = 0 IF (NPIVP1.EQ.NASS) IFINB = 1 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) #if defined(_OPENMP) OMP_FLAG = .FALSE. CHUNK = max(NEL,1) IF (NOMP.GT.1) THEN IF (NEL.LT.KEEP(360)) THEN IF (NEL*NEL2.GE.KEEP(361)) THEN OMP_FLAG = .TRUE. CHUNK = max(20, (NEL+NOMP-1)/NOMP) ENDIF ELSE OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2, (NEL+NOMP-1)/NOMP) ENDIF ENDIF #endif IF (KEEP(351).EQ.1) THEN MAXFROMN = 0.0D0 IF (NEL2 > 0) THEN IS_MAXFROMN_AVAIL = .TRUE. ENDIF !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& PRIVATE(LPOS, UUPOS, IRWPOS, ALPHA, JCOL) !$OMP& FIRSTPRIVATE(APOS,NFRONT8,VALPIV,NEL,NEL2) !$OMP& REDUCTION(max:MAXFROMN) IF(OMP_FLAG) DO IROW = 1, NEL LPOS = APOS + NFRONT8*int(IROW,8) A(LPOS) = A(LPOS)*VALPIV ALPHA = -A(LPOS) IRWPOS = LPOS + 1_8 UUPOS = APOS + 1_8 IF (NEL2 > 0) THEN A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IF (IROW.LE.NELMAXM) & MAXFROMN=max(MAXFROMN, abs(A(IRWPOS))) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 DO JCOL = 2, NEL2 A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 ENDDO ENDIF END DO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& FIRSTPRIVATE(APOS,NFRONT8,VALPIV,NEL,NEL2) !$OMP& PRIVATE(LPOS, UUPOS, IRWPOS, ALPHA, JCOL) IF(OMP_FLAG) DO IROW = 1, NEL LPOS = APOS + NFRONT8*int(IROW,8) A(LPOS) = A(LPOS)*VALPIV ALPHA = -A(LPOS) IRWPOS = LPOS + 1_8 UUPOS = APOS + 1_8 DO JCOL = 1, NEL2 A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_N SUBROUTINE ZMUMPS_FAC_PT_SETLOCK427( K427_OUT, K427, & K405, K222, NEL1, NASS ) INTEGER, INTENT(IN) :: K427, K405, K222, NEL1, NASS INTEGER, INTENT(OUT) :: K427_OUT K427_OUT = K427 IF ( K427_OUT .GT. 0 ) K427_OUT = 0 IF ( K427_OUT .LT. 0 ) K427_OUT = -1 RETURN END SUBROUTINE ZMUMPS_FAC_PT_SETLOCK427 SUBROUTINE ZMUMPS_FAC_P(A,LA,NFRONT, & NPIV,NASS,POSELT,CALL_UTRSM, KEEP, INODE, & CALL_OOC, IWFAC, LIWFAC, LAFAC, MonBloc, MYID, KEEP8, & LNextPiv2beWritten, UNextPiv2beWritten, & IFLAG ) USE ZMUMPS_OOC, ONLY : IO_BLOCK, TYPEF_BOTH_LU, & ZMUMPS_OOC_IO_LU_PANEL USE MUMPS_OOC_COMMON, ONLY : STRAT_TRY_WRITE IMPLICIT NONE INTEGER(8) :: LA,POSELT,LAFAC COMPLEX(kind=8) A(LA) INTEGER NFRONT, NPIV, NASS LOGICAL, INTENT(IN) :: CALL_UTRSM INTEGER, INTENT(INOUT) :: IFLAG LOGICAL, INTENT(IN) :: CALL_OOC INTEGER LIWFAC, MYID, & LNextPiv2beWritten, UNextPiv2beWritten INTEGER IWFAC(LIWFAC) TYPE(IO_BLOCK) :: MonBloc INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS INTEGER NEL1, NEL11, IFLAG_OOC INTEGER :: INODE COMPLEX(kind=8) ALPHA, ONE PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) INCLUDE 'mumps_headers.h' NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV LPOS2 = POSELT + int(NASS,8)*int(NFRONT,8) LPOS = LPOS2 + int(NPIV,8) LPOS1 = POSELT + int(NPIV,8) UPOS = POSELT + int(NASS,8) IF ( CALL_UTRSM ) THEN CALL ztrsm('R', 'U', 'N', 'U', NEL1, NPIV, ONE, & A(POSELT), NFRONT, A(UPOS), NFRONT) ENDIF CALL ztrsm('L','L','N','N',NPIV,NEL1,ONE,A(POSELT),NFRONT, & A(LPOS2),NFRONT) IF (CALL_OOC) THEN CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT_TRY_WRITE, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IWFAC, LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, & .FALSE. ) IF (IFLAG_OOC .LT. 0) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF CALL zgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) IF ((CALL_UTRSM).AND.(NASS-NPIV.GT.0)) THEN LPOS2 = POSELT + int(NPIV,8)*int(NFRONT,8) LPOS = LPOS2 + int(NASS,8) CALL zgemm('N','N',NEL1,NASS-NPIV,NPIV,ALPHA,A(UPOS), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_P SUBROUTINE ZMUMPS_FAC_T(A,LA,NPIVB,NFRONT, & NPIV,NASS,POSELT) IMPLICIT NONE INTEGER NPIVB,NASS INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER(8) :: APOS, POSELT INTEGER NFRONT, NPIV, NASSL INTEGER(8) :: LPOS, LPOS1, LPOS2 INTEGER NEL1, NEL11, NPIVE COMPLEX(kind=8) ALPHA, ONE PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV NPIVE = NPIV - NPIVB NASSL = NASS - NPIVB APOS = POSELT + int(NPIVB,8)*int(NFRONT,8) & + int(NPIVB,8) LPOS2 = APOS + int(NASSL,8) CALL ztrsm('R','U','N','U',NEL1,NPIVE,ONE,A(APOS),NFRONT, & A(LPOS2),NFRONT) LPOS = LPOS2 + int(NFRONT,8)*int(NPIVE,8) LPOS1 = APOS + int(NFRONT,8)*int(NPIVE,8) CALL zgemm('N','N',NEL1,NEL11,NPIVE,ALPHA,A(LPOS2), & NFRONT,A(LPOS1),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE ZMUMPS_FAC_T SUBROUTINE ZMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, NPIV, & NFRONT, LAST_ROW, LAST_COL, A, LA, POSELT, & FIRST_COL, CALL_LTRSM, CALL_UTRSM, CALL_GEMM, & WITH_COMM_THREAD, LR_ACTIVATED & ) !$ USE OMP_LIB #if defined(_OPENMP) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_TEST #endif IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: NPIV, NFRONT, LAST_ROW, LAST_COL INTEGER, intent(in) :: FIRST_COL INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: CALL_LTRSM, CALL_UTRSM, CALL_GEMM LOGICAL, intent(in) :: WITH_COMM_THREAD, LR_ACTIVATED INTEGER(8) :: NFRONT8, LPOSN, LPOS2N INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS, POSELT_LOCAL INTEGER :: NELIM, LKJIW, NEL1, NEL11, UTRSM_NCOLS COMPLEX(kind=8) ALPHA, ONE PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) !$ INTEGER :: NOMP !$ LOGICAL :: TRSM_GEMM_FINISHED !$ LOGICAL :: SAVE_NESTED, SAVE_DYNAMIC NFRONT8= int(NFRONT,8) NELIM = IEND_BLOCK - NPIV NEL1 = LAST_ROW - IEND_BLOCK IF ( NEL1 < 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_FAC_SQ,IEND_BLOCK>LAST_ROW", & IEND_BLOCK, LAST_ROW CALL MUMPS_ABORT() ENDIF LKJIW = NPIV - IBEG_BLOCK + 1 NEL11 = LAST_COL - NPIV LPOS2 = POSELT + int(IEND_BLOCK,8)*NFRONT8 + int(IBEG_BLOCK-1,8) UTRSM_NCOLS = LAST_COL - FIRST_COL UPOS = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 + int(FIRST_COL,8) POSELT_LOCAL = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 & + int(IBEG_BLOCK-1,8) IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN IF (WITH_COMM_THREAD .EQV. .FALSE.) THEN IF (CALL_LTRSM) THEN CALL ztrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) ENDIF IF (CALL_UTRSM) THEN CALL ztrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL zgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF IF (CALL_GEMM) THEN LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSELT_LOCAL + int(LKJIW,8) CALL zgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF ELSE !$ NOMP = OMP_GET_MAX_THREADS() !$ CALL OMP_SET_NUM_THREADS(2) !$ SAVE_NESTED = OMP_GET_NESTED() !$ SAVE_DYNAMIC = OMP_GET_DYNAMIC() !$ CALL OMP_SET_NESTED(.TRUE.) !$ CALL OMP_SET_DYNAMIC(.FALSE.) !$ TRSM_GEMM_FINISHED = .FALSE. !$OMP PARALLEL SHARED(TRSM_GEMM_FINISHED) !$ IF (OMP_GET_THREAD_NUM() .EQ. 1) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL OMP_SET_NUM_THREADS(int(NOMP,4)) #else !$ CALL OMP_SET_NUM_THREADS(NOMP) #endif IF (CALL_LTRSM) THEN CALL ztrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) ENDIF IF (CALL_UTRSM) THEN CALL ztrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL zgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF IF (CALL_GEMM) THEN LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSELT_LOCAL + int(LKJIW,8) CALL zgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) END IF !$ TRSM_GEMM_FINISHED = .TRUE. !$ ELSE !$ DO WHILE (.NOT. TRSM_GEMM_FINISHED) !$ CALL MUMPS_BUF_TEST() !$ CALL MUMPS_USLEEP(10000) !$ END DO !$ END IF !$OMP END PARALLEL !$ CALL OMP_SET_NESTED(SAVE_NESTED) !$ CALL OMP_SET_DYNAMIC(SAVE_DYNAMIC) #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL OMP_SET_NUM_THREADS(int(NOMP,4)) #else !$ CALL OMP_SET_NUM_THREADS(NOMP) #endif ENDIF ELSE IF (CALL_UTRSM.AND.UTRSM_NCOLS.NE.0) THEN CALL ztrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL zgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_SQ SUBROUTINE ZMUMPS_FAC_MQ(IBEG_BLOCK,IEND_BLOCK, & NFRONT, NASS, NPIV, LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED & ) IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK, NFRONT, & NASS, NPIV, LAST_COL INTEGER, intent(out) :: IFINB INTEGER(8), intent(in) :: LA, POSELT COMPLEX(kind=8), intent(inout) :: A(LA) LOGICAL, intent(in) :: LR_ACTIVATED COMPLEX(kind=8) :: VALPIV INTEGER(8) :: APOS, UUPOS, LPOS INTEGER(8) :: NFRONT8 COMPLEX(kind=8) :: ONE, ALPHA INTEGER :: NEL2,NPIVP1,KROW,NEL PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) NFRONT8= int(NFRONT,8) NPIVP1 = NPIV + 1 NEL = LAST_COL - NPIVP1 IFINB = 0 NEL2 = IEND_BLOCK - NPIVP1 IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ELSE APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 541 KROW = 1,NEL2 A(LPOS) = A(LPOS)*VALPIV LPOS = LPOS + NFRONT8 541 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS + 1_8 #if defined(MUMPS_USE_BLAS2) CALL zgeru(NEL,NEL2,ALPHA,A(UUPOS),1,A(LPOS),NFRONT, & A(LPOS+1_8),NFRONT) #else CALL zgemm('N','N',NEL,NEL2,1,ALPHA,A(UUPOS),NEL, & A(LPOS),NFRONT,ONE,A(LPOS+1_8),NFRONT) #endif ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_MQ SUBROUTINE ZMUMPS_FAC_FR_UPDATE_CBROWS( INODE, NFRONT, NASS, & CALL_UTRSM, A, LA, LAFAC, POSELT, IW, LIW, IOLDPS, & MonBloc, MYID, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR) USE ZMUMPS_OOC, ONLY: IO_BLOCK IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS, & LIW, MYID, XSIZE, IOLDPS, LIWFAC INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(inout) :: NOFFW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW INTEGER, intent(inout) :: PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & IFLAG LOGICAL, intent(in) :: CALL_UTRSM INTEGER, intent(inout) :: IW(LIW) COMPLEX(kind=8), intent(inout) :: A(LA) DOUBLE PRECISION, intent(in) :: SEUIL, UU, DKEEP(230) INTEGER, intent(in) :: KEEP( 500 ) INTEGER(8), intent(inout) :: LAFAC INTEGER(8) :: KEEP8(150) INTEGER, intent(in) :: NVSCHUR TYPE(IO_BLOCK), intent(inout) :: MonBloc LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER :: NPIV, NEL1, IBEG_BLOCK, IFINB, INOPV INTEGER Inextpiv DOUBLE PRECISION :: MAXFROMN LOGICAL :: IS_MAXFROMN_AVAIL NPIV = IW(IOLDPS+1+XSIZE) NEL1 = NFRONT - NASS IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF IF ((NPIV.GT.0).AND.(NEL1.GT.0)) THEN IF (OOC_EFFECTIVE_ON_FRONT) THEN MonBloc%LastPiv = NPIV ENDIF CALL ZMUMPS_FAC_P(A,LA,NFRONT, NPIV, NASS, POSELT, & CALL_UTRSM, KEEP, INODE, & OOC_EFFECTIVE_ON_FRONT, IW(IOLDPS), & LIWFAC, LAFAC, & MonBloc, MYID, KEEP8, & LNextPiv2beWritten, UNextPiv2beWritten, & IFLAG) ENDIF NPIV = IW(IOLDPS+1+XSIZE) IBEG_BLOCK = NPIV IF (NASS.EQ.NPIV) GOTO 500 IF (KEEP(19).GT.0) THEN GOTO 500 ENDIF IS_MAXFROMN_AVAIL = .FALSE. 120 CALL ZMUMPS_FAC_H(NFRONT,NASS,IW,LIW,A,LA, & INOPV, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IOLDPS,POSELT,UU,SEUIL, & KEEP, KEEP8, DKEEP, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, MAXFROMN, IS_MAXFROMN_AVAIL, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, NVSCHUR & ) IF (INOPV.NE.1) THEN CALL ZMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP, MAXFROMN, IS_MAXFROMN_AVAIL, & NVSCHUR) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) GOTO 120 ENDIF NPIV = IW(IOLDPS+1+XSIZE) NEL1 = NFRONT - NASS IF ((NPIV.LE.IBEG_BLOCK).OR.(NEL1.EQ.0)) GO TO 500 CALL ZMUMPS_FAC_T(A,LA,IBEG_BLOCK, & NFRONT,NPIV,NASS,POSELT) 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_FR_UPDATE_CBROWS SUBROUTINE ZMUMPS_FAC_I(NFRONT,NASS,LAST_ROW, & IBEG_BLOCK, IEND_BLOCK, & N,INODE,IW,LIW,A,LA, & INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UU,SEUIL,KEEP,KEEP8, & DKEEP,PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR, PARPIV_T1, & TIPIV & ) !$ USE OMP_LIB USE MUMPS_OOC_COMMON USE MUMPS_PIVNUL_MOD IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(inout), OPTIONAL :: TIPIV(:) INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER, intent(in) :: NFRONT,NASS,N,LIW,INODE,LAST_ROW INTEGER, intent(inout) :: IFLAG,IERROR, INOPV,NOFFW, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW DOUBLE PRECISION, intent(in) :: UU, SEUIL INTEGER, intent(inout) :: IW(LIW) INTEGER, intent(in) :: IOLDPS INTEGER(8), intent(in) :: POSELT INTEGER KEEP(500) INTEGER(8) KEEP8(150) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT LOGICAL, intent(inout) :: SWAP_OCCURRED DOUBLE PRECISION DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER, intent(in) :: NVSCHUR INTEGER, intent(in) :: PARPIV_T1 INCLUDE 'mumps_headers.h' COMPLEX(kind=8) SWOP INTEGER XSIZE INTEGER(8) :: APOS, IDIAG INTEGER(8) :: J1, J2, JJ, J3 INTEGER(8) :: NFRONT8 INTEGER ILOC COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) DOUBLE PRECISION RZERO, RMAX, AMROW, MAX_PREV_in_PARPIV DOUBLE PRECISION RCMAX INTEGER(8) :: APOSMAX, APOSROW DOUBLE PRECISION :: RMAX_NORELAX DOUBLE PRECISION PIVNUL, ABS_PIVOT COMPLEX(kind=8) FIXA, CSEUIL, PIVOT INTEGER NPIV,IPIV, LRLOC INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 INTEGER ISWPS2,KSW, HF, IPIVNUL INTEGER ZMUMPS_IXAMAX INTEGER :: ISHIFT, K206 INTEGER :: IPIV_SHIFT,IPIV_END INTRINSIC max DATA RZERO /0.0D0/ #if defined(_OPENMP) INTEGER :: NOMP,CHUNK #endif INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U #if defined(_OPENMP) NOMP = OMP_GET_MAX_THREADS() #endif PIVNUL = DKEEP(1) FIXA = cmplx(DKEEP(2),kind=kind(FIXA)) CSEUIL = cmplx(SEUIL,kind=kind(CSEUIL)) NFRONT8 = int(NFRONT,8) K206 = KEEP(206) XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE NPIVP1 = NPIV + 1 APOSMAX = POSELT+NFRONT8*NFRONT8-1_8 IF (OOC_EFFECTIVE_ON_FRONT) THEN CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF IF ( present(TIPIV) ) THEN ILOC = NPIVP1 - IBEG_BLOCK + 1 TIPIV(ILOC) = ILOC ENDIF IF (INOPV .EQ. -1) THEN JMAX=1 APOS = POSELT + NFRONT8*int(NPIVP1-1,8) + int(NPIV,8) PIVOT = A(APOS) ABS_PIVOT = abs(PIVOT) IDIAG = APOS CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .TRUE.) IF(ABS_PIVOT.LT.SEUIL) THEN IF (dble(PIVOT) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF GO TO 430 ENDIF INOPV = 0 ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) JMAX = 1 IF ((PIVOT_OPTION.EQ.0).OR.(UU.EQ.RZERO)) THEN ABS_PIVOT = abs(A(APOS)) IF(ABS_PIVOT.LT.SEUIL) THEN CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .TRUE.) IF (dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 GO TO 420 ELSE IF (ABS_PIVOT.EQ.RZERO) THEN GO TO 630 ENDIF GO TO 380 ENDIF AMROW = RZERO J1 = APOS IF (PIVOT_OPTION.EQ.1 .OR. (LR_ACTIVATED .AND. & (KEEP(480).GE.2 & ))) THEN J = IEND_BLR - NPIV ELSE J = NASS - NPIV ENDIF J2 = J1 + J - 1_8 JMAX = ZMUMPS_IXAMAX(J,A(J1),1,KEEP(361)) JJ = J1 + int(JMAX - 1,8) AMROW = abs(A(JJ)) RMAX = AMROW IF (PIVOT_OPTION.GE.2) THEN J1 = J2 + 1_8 IF (PIVOT_OPTION.GE.3 & ) THEN J2 = APOS + & int(- NPIV + NFRONT - 1 - KEEP(253) - NVSCHUR,8) ELSE J2 = APOS +int(- NPIV + NASS - 1 ,8) ENDIF IF (J2.LT.J1) GO TO 370 IF (KEEP(351).EQ.1 .AND. J2-J1.GT.KEEP(361)) THEN !$ CHUNK = max(KEEP(361)/2,(int(J2-J1)+NOMP-1)/NOMP) !$OMP PARALLEL DO schedule(static, CHUNK) PRIVATE(JJ) !$OMP& FIRSTPRIVATE(J1,J2) !$OMP& REDUCTION(max:RMAX) DO JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) ENDDO !$OMP END PARALLEL DO ELSE DO 360 JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) 360 CONTINUE ENDIF 370 CONTINUE ENDIF IDIAG = APOS + int(IPIV - NPIVP1,8) ABS_PIVOT = abs(A(IDIAG)) IF (PARPIV_T1.NE.0) THEN RMAX_NORELAX = dble(A(APOSMAX+int(IPIV,8))) ELSE RMAX_NORELAX = RZERO ENDIF RMAX = max(RMAX,RMAX_NORELAX) IF ( RMAX .LE. PIVNUL ) THEN IF (LAST_ROW.EQ.NFRONT) THEN LRLOC = LAST_ROW -KEEP(253)-NVSCHUR ELSE LRLOC = LAST_ROW ENDIF IF (NFRONT - KEEP(253) .EQ. NASS) THEN IF (IEND_BLOCK.NE.NASS ) THEN GOTO 460 ENDIF J1=POSELT+int(IPIV-1,8)+int(NPIV,8)*NFRONT8 J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 ELSE J1=POSELT+int(IPIV-1,8) J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 ENDIF DO JJ=J1, J2, NFRONT8 IF ( abs(A(JJ)) .GT. PIVNUL ) THEN GOTO 460 END IF ENDDO IF ((PARPIV_T1.NE.0) & .AND.(PARPIV_T1.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & dble(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + NFRONT8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) GOTO 460 ENDDO ENDIF ENDIF CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .TRUE.) !$OMP ATOMIC CAPTURE KEEP(109) = KEEP(109)+1 IPIVNUL = KEEP(109) !$OMP END ATOMIC IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST.LT.KEEP(109)) & THEN CALL MUMPS_RESIZE_PIVNUL(KEEP, N, PIVNUL_LIST_STRUCT, & IPIVNUL, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 430 ENDIF IF (KEEP(405).EQ.1) THEN !$OMP CRITICAL(critical_pivnul) PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) !$OMP END CRITICAL(critical_pivnul) ELSE PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) ENDIF IF(dble(FIXA).GT.RZERO) THEN IF(dble(A(IDIAG)) .GE. RZERO) THEN A(IDIAG) = FIXA ELSE A(IDIAG) = -FIXA ENDIF ELSE J1 = APOS J2 = APOS + & int(- NPIV + NFRONT - 1 - KEEP(253),8) DO JJ=J1,J2 A(JJ) = ZERO ENDDO A(IDIAG) = -FIXA ENDIF JMAX = IPIV - NPIV GOTO 385 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF (ABS_PIVOT .GE. UU*RMAX .AND. & ABS_PIVOT .GT. max(SEUIL,tiny(RMAX))) THEN IF (KEEP(19).GT.0) THEN IF (LAST_ROW.EQ.NFRONT) THEN LRLOC = LAST_ROW -KEEP(253)-NVSCHUR ELSE LRLOC = LAST_ROW ENDIF J1=POSELT+int(IPIV-1,8)+int(NPIV,8)*NFRONT8 J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 RCMAX = RZERO DO JJ=J1, J2, NFRONT8 RCMAX = max(abs(A(JJ)),RCMAX) ENDDO IF (ABS_PIVOT .GE. UU*RCMAX) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF ELSE JMAX = IPIV - NPIV GO TO 380 ENDIF ENDIF IF ( .NOT. (AMROW .GE. UU*RMAX .AND. & AMROW .GT. max(SEUIL,tiny(RMAX))) ) GO TO 460 IF (KEEP(19).GT.0) THEN IF (LAST_ROW.EQ.NFRONT) THEN LRLOC = LAST_ROW -KEEP(253)-NVSCHUR ELSE LRLOC = LAST_ROW ENDIF J1=POSELT+int(NPIV+JMAX-1,8)+int(NPIV,8)*NFRONT8 J2=POSELT+int(NPIV+JMAX-1,8)+int(LRLOC-1,8)*NFRONT8 RCMAX = RZERO DO JJ=J1, J2, NFRONT8 RCMAX = max(abs(A(JJ)),RCMAX) ENDDO IF (.NOT.(AMROW .GE. UU*RCMAX) ) THEN GO TO 460 ENDIF ENDIF NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS+int(JMAX-1,8))), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER( A(APOS+int(JMAX-1,8)), & DET_MANTW, & DET_EXPW ) ENDIF 385 CONTINUE IF ( IPIV .NE. NPIVP1 .OR. JMAX .NE. 1 ) THEN SWAP_OCCURRED = .TRUE. IF (KEEP(405) .EQ. 0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF ENDIF IF (IPIV.EQ.NPIVP1) GO TO 400 IF (PARPIV_T1.NE.0) THEN SWOP = A(APOSMAX+int(NPIVP1,8)) A(APOSMAX+int(NPIVP1,8)) = A(APOSMAX+int(IPIV,8)) A(APOSMAX+int(IPIV,8)) = SWOP ENDIF DET_SIGNW = - DET_SIGNW J1 = POSELT + int(NPIV,8)*NFRONT8 J2 = J1 + NFRONT8 - 1_8 J3 = POSELT + int(IPIV-1,8)*NFRONT8 DO 390 JJ=J1,J2 SWOP = A(JJ) A(JJ) = A(J3) A(J3) = SWOP J3 = J3 + 1_8 390 CONTINUE ISWPS1 = IOLDPS + HF - 1 + NPIVP1 ISWPS2 = IOLDPS + HF - 1 + IPIV ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW 400 IF (JMAX.EQ.1) GO TO 420 DET_SIGNW = - DET_SIGNW IF ( present(TIPIV) ) THEN TIPIV(ILOC) = ILOC + JMAX - 1 ENDIF J1 = POSELT + int(NPIV,8) J2 = POSELT + int(NPIV + JMAX - 1,8) DO 410 KSW=1,LAST_ROW SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + NFRONT8 J2 = J2 + NFRONT8 410 CONTINUE ISWPS1 = IOLDPS + HF - 1 + NFRONT + NPIV + 1 ISWPS2 = IOLDPS + HF - 1 + NFRONT + NPIV + JMAX ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 430 630 CONTINUE IFLAG = -10 GOTO 430 420 CONTINUE IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_I SUBROUTINE ZMUMPS_FAC_I_LDLT & ( NFRONT,NASS,N,INODE,IBEG_BLOCK,IEND_BLOCK, & IW,LIW, A,LA, INOPV, & NNEGW, NNULLNEGW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UU, SEUIL,KEEP,KEEP8,PIVSIZ, & DKEEP, PIVNUL_LIST_STRUCT, SWAP_OCCURRED, XSIZE, & PP_FIRST2SWAP_L, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled,MAXFROMM,IS_MAXFROMM_AVAIL, & PIVOT_OPTION, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, LR_ACTIVATED & ) !$ USE OMP_LIB USE MUMPS_OOC_COMMON USE MUMPS_PIVNUL_MOD IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER NFRONT,NASS,LIW,N,INODE,IFLAG,IERROR,INOPV, & IOLDPS INTEGER, intent(inout) :: NNEGW, NNULLNEGW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: PIVOT_OPTION,IEND_BLR INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER PIVSIZ,LPIV, XSIZE COMPLEX(kind=8) A(LA) DOUBLE PRECISION UU, UULOC, SEUIL INTEGER IW(LIW) INTEGER KEEP(500) INTEGER(8) KEEP8(150) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT LOGICAL, intent(inout) :: SWAP_OCCURRED DOUBLE PRECISION DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled DOUBLE PRECISION, intent(in) :: MAXFROMM LOGICAL, intent(inout) :: IS_MAXFROMM_AVAIL INTEGER, intent(in) :: NVSCHUR INTEGER, intent(in) :: PARPIV_T1 LOGICAL, intent(in) :: LR_ACTIVATED include 'mpif.h' INTEGER (8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX, LIM, LIM_SWAP DOUBLE PRECISION RMAX,AMAX,TMAX, MAX_PREV_in_PARPIV, ABS_PIVOT DOUBLE PRECISION RMAX_NORELAX, TMAX_NORELAX, UULOCM1 INTEGER(8) :: APOSMAX, APOSROW DOUBLE PRECISION MAXPIV DOUBLE PRECISION PIVNUL DOUBLE PRECISION MAXFROMM_UPDATED COMPLEX(kind=8) FIXA, CSEUIL COMPLEX(kind=8) PIVOT,DETPIV DOUBLE PRECISION ABSDETPIV INCLUDE 'mumps_headers.h' INTEGER :: HF, IPIVNUL INTEGER :: J INTEGER(8) :: APOS, J1, J2, JJ, NFRONT8, KK, J1_ini, JJ_ini INTEGER :: LDA INTEGER(8) :: LDA8 INTEGER NPIV,IPIV INTEGER NPIVP1,K INTEGER :: ISHIFT, K206, IPIV_SHIFT, IPIV_END INTRINSIC max COMPLEX(kind=8) ZERO, ONE PARAMETER( ZERO = (0.0D0,0.0D0) ) PARAMETER( ONE = (1.0D0,1.0D0) ) DOUBLE PRECISION RZERO,RONE PARAMETER(RZERO=0.0D0, RONE=1.0D0) #if defined(_OPENMP) LOGICAL :: OMP_FLAG INTEGER :: NOMP, CHUNK, J1_end #endif INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L !$ NOMP = OMP_GET_MAX_THREADS() PIVNUL = DKEEP(1) FIXA = cmplx(DKEEP(2),kind=kind(FIXA)) CSEUIL = cmplx(SEUIL,kind=kind(CSEUIL)) LDA = NFRONT LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) K206 = KEEP(206) UULOC = UU IF (UULOC.GT.RZERO) THEN UULOCM1 = RONE/UULOC ELSE UULOCM1 = RONE ENDIF HF = 6 + XSIZE IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, IOLDPS+2*NFRONT+6+KEEP(IXSZ), & IW, LIW) ENDIF PIVSIZ = 1 NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 APOSMAX = POSELT+LDA8*LDA8-1_8 IF(INOPV .EQ. -1) THEN APOS = POSELT + (LDA8+1_8) * int(NPIV,8) POSPV1 = APOS CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), DKEEP, KEEP, .TRUE.) IF(abs(A(APOS)).LT.SEUIL) THEN IF(dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER( A(APOS), DET_MANTW, DET_EXPW ) ENDIF ENDIF IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF IF (ISHIFT.GT.0.AND.IS_MAXFROMM_AVAIL) THEN IPIV = NPIVP1 APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF ( MAXFROMM .GT. PIVNUL ) THEN IF (PARPIV_T1.NE.0) THEN MAXFROMM_UPDATED = max & ( MAXFROMM, & abs(dble(A(APOSMAX+int(IPIV,8)))) & ) ELSE MAXFROMM_UPDATED = MAXFROMM ENDIF IF ( (abs(PIVOT) .GE. UULOC*MAXFROMM_UPDATED).AND. & abs(PIVOT) .GT. max(SEUIL,tiny(MAXFROMM_UPDATED)) & ) THEN ISHIFT = 0 ENDIF ENDIF ENDIF IF ( ISHIFT .GT. 0) THEN IS_MAXFROMM_AVAIL = .FALSE. ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN IF(ABS_PIVOT.LT.SEUIL) THEN CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .TRUE.) IF(dble(PIVOT) .GE. RZERO) THEN A(POSPV1) = CSEUIL ELSE A(POSPV1) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (ABS_PIVOT.EQ.RZERO) THEN GO TO 630 ELSE CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF ENDIF GO TO 420 ENDIF IF ( IS_MAXFROMM_AVAIL ) THEN IF ( MAXFROMM .GT. PIVNUL ) THEN IF (PARPIV_T1.NE.0) THEN MAXFROMM_UPDATED = max & ( MAXFROMM, & abs(dble(A(APOSMAX+int(IPIV,8)))) & ) ELSE MAXFROMM_UPDATED = MAXFROMM ENDIF IF ( (ABS_PIVOT .GE. UULOC*MAXFROMM_UPDATED).AND. & (ABS_PIVOT .GT. max(SEUIL,tiny(MAXFROMM_UPDATED))) & ) THEN CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GOTO 415 ENDIF ENDIF IS_MAXFROMM_AVAIL = .FALSE. ENDIF AMAX = -RONE JMAX = 0 IF (PIVOT_OPTION.EQ.3 & ) THEN LIM = NFRONT - KEEP(253)-NVSCHUR ELSEIF (PIVOT_OPTION.GE.2 & ) THEN LIM = NASS ELSEIF (PIVOT_OPTION.GE.1) THEN LIM = IEND_BLR ELSE write(*,*) 'Internal error in FAC_I_LDLT 1x1:', & PIVOT_OPTION CALL MUMPS_ABORT() ENDIF J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1, IEND_BLOCK - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDA8 ENDDO RMAX = RZERO J1_ini = J1 #if defined(_OPENMP) J1_end = LIM - IEND_BLOCK CHUNK = max(J1_end,1) IF ( J1_end.GE.KEEP(360)) THEN OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2,(J1_end+NOMP-1)/NOMP) ELSE OMP_FLAG = .FALSE. ENDIF #endif !$OMP PARALLEL DO SCHEDULE(static, CHUNK) PRIVATE(J1) !$OMP& REDUCTION(max:RMAX) IF(OMP_FLAG) DO J=1, LIM - IEND_BLOCK J1 = J1_ini + int(J-1,8) * LDA8 RMAX = max(abs(A(J1)),RMAX) ENDDO !$OMP END PARALLEL DO IF (PARPIV_T1.NE.0) THEN RMAX_NORELAX = dble(A(APOSMAX+int(IPIV,8))) ELSE RMAX_NORELAX = RZERO ENDIF RMAX = max(RMAX,RMAX_NORELAX) IF (max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL) THEN IF ((PARPIV_T1.NE.0) & .AND.(PARPIV_T1.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & dble(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + NFRONT8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) THEN GOTO 460 ENDIF ENDDO ENDIF ENDIF CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(POSPV1)), DKEEP, KEEP, .TRUE.) !$OMP ATOMIC CAPTURE KEEP(109) = KEEP(109) + 1 IPIVNUL = KEEP(109) !$OMP END ATOMIC IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST.LT.KEEP(109)) & THEN CALL MUMPS_RESIZE_PIVNUL(KEEP, N, & PIVNUL_LIST_STRUCT, & IPIVNUL, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 420 ENDIF IF (KEEP(405).EQ.1) THEN !$OMP CRITICAL(critical_pivnul) PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) !$OMP END CRITICAL(critical_pivnul) ELSE PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) ENDIF IF(dble(FIXA).GT.RZERO) THEN IF(dble(PIVOT) .GE. RZERO) THEN A(POSPV1) = FIXA ELSE A(POSPV1) = -FIXA ENDIF ELSE J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 A(JJ) = ZERO ENDDO J1 = POSPV1 + LDA8 DO J=1, IEND_BLOCK - IPIV A(J1) = ZERO J1 = J1 + LDA8 ENDDO DO J=1,LIM - IEND_BLOCK A(J1) = ZERO J1 = J1 + LDA8 ENDDO A(POSPV1) = ONE ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF ( abs(PIVOT).GE.UULOC*max(RMAX,AMAX) & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(RMAX)) ) THEN CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(PIVOT), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL ZMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) THEN GOTO 460 ELSE IF (JMAX.EQ.0) THEN GOTO 460 ENDIF IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN GOTO 460 ENDIF IF ( & (KEEP(19).NE.0).AND.(max(AMAX,RMAX,abs(PIVOT)).LE.SEUIL) & ) & THEN GO TO 460 ENDIF IF (RMAX.LT.AMAX) THEN J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN RMAX = max(RMAX,abs(A(JJ))) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1,IEND_BLOCK-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX = max(abs(A(J1)),RMAX) ENDIF J1 = J1 + LDA8 ENDDO ENDIF APOSJ = POSELT + int(JMAX-1,8)*LDA8 + int(NPIV,8) POSPV2 = APOSJ + int(JMAX - NPIVP1,8) IF (IPIV.LT.JMAX) THEN OFFDAG = APOSJ + int(IPIV - NPIVP1,8) ELSE OFFDAG = APOS + int(JMAX - NPIVP1,8) END IF TMAX = RZERO #if defined(_OPENMP) J1_end = LIM-JMAX CHUNK = max(J1_end,1) IF (J1_end.GE.KEEP(360)) THEN OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2,(J1_end+NOMP-1)/NOMP) ELSE OMP_FLAG = .FALSE. ENDIF #endif IF (JMAX .LT. IPIV) THEN JJ_ini = POSPV2 !$OMP PARALLEL DO SCHEDULE(static, CHUNK) IF (OMP_FLAG) !$OMP& PRIVATE(JJ) REDUCTION(max:TMAX) DO K = 1, LIM - JMAX JJ = JJ_ini+ int(K,8)*NFRONT8 IF (JMAX+K.NE.IPIV) THEN TMAX=max(TMAX,abs(A(JJ))) ENDIF ENDDO !$OMP END PARALLEL DO DO KK = APOSJ, POSPV2-1_8 TMAX = max(TMAX,abs(A(KK))) ENDDO ELSE JJ_ini = POSPV2 !$OMP PARALLEL DO SCHEDULE(static, CHUNK) PRIVATE(JJ) !$OMP& REDUCTION(max:TMAX) IF(OMP_FLAG) DO K = 1, LIM-JMAX JJ = JJ_ini + int(K,8)*NFRONT8 TMAX=max(TMAX,abs(A(JJ))) ENDDO !$OMP END PARALLEL DO DO KK = APOSJ, POSPV2 - 1_8 IF (KK.NE.OFFDAG) THEN TMAX = max(TMAX,abs(A(KK))) ENDIF ENDDO ENDIF IF (PARPIV_T1.NE.0) THEN TMAX_NORELAX = max(SEUIL*UULOCM1, & abs(dble(A(APOSMAX+int(JMAX,8)))) & ) ELSE TMAX_NORELAX = SEUIL*UULOCM1 ENDIF TMAX = max (TMAX,TMAX_NORELAX) DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)**2 ABSDETPIV = abs(DETPIV) IF (SEUIL.GT.RZERO) THEN IF (sqrt(ABSDETPIV) .LE. SEUIL ) THEN GOTO 460 ENDIF ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & ABSDETPIV .OR. (ABSDETPIV .EQ. RZERO) ) THEN GO TO 460 ENDIF IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & ABSDETPIV .OR. (ABSDETPIV.EQ. RZERO) ) THEN GO TO 460 ENDIF CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( sqrt(ABSDETPIV), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL ZMUMPS_UPDATEDETER(DETPIV, DET_MANTW, DET_EXPW ) ENDIF PIVSIZ = 2 NB22T1W = NB22T1W + 1 415 CONTINUE IF (K206.GE.1) THEN Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) ENDIF DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2) THEN IF (K==1) THEN LPIV = min(IPIV,JMAX) ELSE LPIV = max(IPIV,JMAX) ENDIF ELSE LPIV = IPIV ENDIF IF (LPIV.EQ.NPIVP1) GOTO 416 IF (KEEP(405) .EQ. 0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF LIM_SWAP = NFRONT CALL ZMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, LIM_SWAP, & LDA, NFRONT, 1, PARPIV_T1, KEEP(50), & KEEP(IXSZ), -9999) SWAP_OCCURRED = .TRUE. 416 CONTINUE IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF NPIVP1 = NPIVP1 + 1 ENDDO IF(PIVSIZ .EQ. 2) THEN A(POSELT+(LDA8+1_8)*int(NPIV,8)+1_8) = DETPIV ENDIF GOTO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE PIVSIZ = 0 IFLAG = -10 420 CONTINUE IS_MAXFROMM_AVAIL = .FALSE. RETURN END SUBROUTINE ZMUMPS_FAC_I_LDLT SUBROUTINE ZMUMPS_FAC_MQ_LDLT(IEND_BLOCK, & NFRONT,NASS,NPIV,INODE, & A,LA,LDA, & POSELT,IFINB,PIVSIZ, & MAXFROMM, IS_MAXFROMM_AVAIL, IS_MAX_USEFUL, & PARPIV_T1, LAST_ROW, IEND_BLR, NVSCHUR_K253, & LR_ACTIVATED & ) IMPLICIT NONE INTEGER, intent(out):: IFINB INTEGER, intent(in) :: INODE, NFRONT, NASS, NPIV INTEGER, intent(in) :: IEND_BLOCK INTEGER, intent(in) :: LDA INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER, intent(in) :: LAST_ROW INTEGER, intent(in) :: IEND_BLR INTEGER(8) :: POSELT DOUBLE PRECISION, intent(out) :: MAXFROMM LOGICAL, intent(out) :: IS_MAXFROMM_AVAIL LOGICAL, intent(in) :: IS_MAX_USEFUL INTEGER, intent(in) :: PARPIV_T1 INTEGER, INTENT(in) :: NVSCHUR_K253 LOGICAL, intent(in) :: LR_ACTIVATED COMPLEX(kind=8) VALPIV DOUBLE PRECISION :: MAXFROMMTMP INTEGER NCB1 INTEGER(8) :: NFRONT8 INTEGER(8) :: LDA8 INTEGER(8) :: K1POS INTEGER NEL2 COMPLEX(kind=8) ONE, ZERO COMPLEX(kind=8) A11,A22,A12 INTEGER(8) :: APOS, LPOS, LPOS1, LPOS2 INTEGER(8) :: POSPV1, POSPV2 INTEGER :: PIVSIZ,NPIV_NEW,J2,I INTEGER(8) :: OFFDAG, OFFDAG_OLD, K1, K2, IROW #if defined(__ve__) INTEGER(8) :: J2_8, KU1, KU2 #else INTEGER(8) :: IBEG, IEND, JJ_LOC, JJ, ROW_SHIFT INTEGER(8) :: IBEG_LOC, IEND_LOC #endif COMPLEX(kind=8) SWOP,DETPIV,MULT1,MULT2 INTEGER(8) :: APOSMAX !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' PARAMETER(ONE = (1.0D0,0.0D0), & ZERO = (0.0D0,0.0D0)) LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) NPIV_NEW = NPIV + PIVSIZ IFINB = 0 IS_MAXFROMM_AVAIL = .FALSE. NCB1 = LAST_ROW - IEND_BLOCK NEL2 = IEND_BLOCK - NPIV_NEW IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ENDIF MAXFROMM = 0.0D0 IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDA8 #if defined(__ve__) IF (NEL2+NCB1.GT.0) THEN !$ OMP_FLAG = (NCB1 + NEL2> 300) !$OMP PARALLEL DO PRIVATE(I,K1POS) IF (OMP_FLAG) !NEC$ IVDEP DO I=1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) ENDDO !$OMP END PARALLEL DO !$OMP PARALLEL DO PRIVATE(I,K1POS) IF (OMP_FLAG) !NEC$ IVDEP DO I=1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS) = A(K1POS) * VALPIV ENDDO !$OMP END PARALLEL DO IF (.NOT. IS_MAX_USEFUL) THEN !$ OMP_FLAG = (NCB1 > 300).AND.(NEL2.GE.2) !$OMP PARALLEL DO PRIVATE(I,J2,J2_8,K1POS) IF (OMP_FLAG) !NEC$ IVDEP DO J2 = 1, NEL2 J2_8 = int(J2,8) !NEC$ IVDEP DO I=J2, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS+J2_8)=A(K1POS+J2_8)-(A(K1POS)*A(APOS+J2_8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE IF (NEL2.GT.0) THEN MAXFROMMTMP=0.0D0 !$ OMP_FLAG = (NCB1+NEL2 > 300) !$OMP PARALLEL DO PRIVATE(I,K1POS) IF (OMP_FLAG) !$OMP& REDUCTION(max:MAXFROMMTMP) !NEC$ IVDEP DO I=1, NEL2 + NCB1 - NVSCHUR_K253 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS+1_8)=A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) MAXFROMMTMP=max(MAXFROMMTMP, abs(A(K1POS+1_8))) ENDDO !$OMP END PARALLEL DO IS_MAXFROMM_AVAIL = .TRUE. MAXFROMM=max(MAXFROMM, MAXFROMMTMP) IF (NVSCHUR_K253.GT.0) THEN DO I= NEL2 + NCB1- NVSCHUR_K253 +1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS+1_8)=A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) ENDDO ENDIF ENDIF IF (NEL2.GT.1) THEN !$ OMP_FLAG = (NCB1+NEL2 > 300).AND.(NEL2.GE.3) !$OMP PARALLEL DO PRIVATE(I,J2,J2_8,K1POS) IF (OMP_FLAG) !NEC$ IVDEP DO J2 = 2, NEL2 J2_8 = int(J2,8) !NEC$ IVDEP DO I=J2, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS+J2_8)=A(K1POS+J2_8)-(A(K1POS)*A(APOS+J2_8)) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF ENDIF ENDIF #else 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 (NCB1.GT.0) THEN IF (.NOT. IS_MAX_USEFUL) THEN !$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) DO I=NEL2+1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE MAXFROMMTMP=0.0D0 !$ OMP_FLAG = (NCB1-NVSCHUR_K253>300) !$OMP PARALLEL DO PRIVATE(JJ,K1POS) !$OMP& REDUCTION(max:MAXFROMMTMP) IF (OMP_FLAG) DO I=NEL2+1, NEL2 + NCB1 - NVSCHUR_K253 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV IF (NEL2 > 0) THEN A(K1POS+1_8) = A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) MAXFROMMTMP=max(MAXFROMMTMP, abs(A(K1POS+1_8))) DO JJ = 2_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDIF ENDDO !$OMP END PARALLEL DO DO I = NEL2 + NCB1 - NVSCHUR_K253 + 1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO MAXFROMM=max(MAXFROMM, MAXFROMMTMP) ENDIF ENDIF #endif ELSE POSPV1 = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) POSPV2 = POSPV1 + NFRONT8 + 1_8 OFFDAG_OLD = POSPV2 - 1_8 OFFDAG = POSPV1 + 1_8 SWOP = A(POSPV2) DETPIV = A(OFFDAG) A22 = A(POSPV1)/DETPIV A11 = SWOP/DETPIV A12 = -A(OFFDAG_OLD)/DETPIV A(OFFDAG) = A(OFFDAG_OLD) A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDA8 - 1_8 LPOS2 = LPOS1 + 1_8 #if defined(__ve__) CALL zcopy(LAST_ROW-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) CALL zcopy(LAST_ROW-NPIV_NEW, A(LPOS2), LDA, A(POSPV2+1_8), 1) !$ OMP_FLAG = (NEL2+NCB1 > 300) !$OMP PARALLEL DO PRIVATE(J2,J2_8,I,K1,K2,KU1,KU2) !$OMP& IF (OMP_FLAG) !NEC$ IVDEP DO J2=1, NEL2 + NCB1 J2_8 = int(J2,8) KU1 = POSPV1 + 2_8 + (J2_8-1_8) KU2 = POSPV2 + 1_8 + (J2_8-1_8) K1 = LPOS1 + (J2_8-1_8)*NFRONT8 K2 = K1 + 1_8 A(K1) = A11*A(KU1)+A12*A(KU2) A(K2) = A12*A(KU1)+A22*A(KU2) ENDDO IF (NEL2.GT.0) THEN !$ OMP_FLAG = (NCB1+NEL2 > 300).AND.(NEL2.GE.2) !$OMP PARALLEL DO PRIVATE(I,J2,J2_8,K1,K2,MULT1,MULT2,IROW) !$OMP& IF (OMP_FLAG) !NEC$ IVDEP DO J2 = 1,NEL2 J2_8 = int(J2,8) MULT1 = -A(POSPV1 + 2_8 + J2_8-1_8) MULT2 = -A(POSPV2 + 1_8 + J2_8-1_8) !NEC$ IVDEP DO I= J2, NEL2 + NCB1 K1 = LPOS1 + (int(I,8)-1_8)*NFRONT8 K2 = K1 + 1_8 IROW = K2 + J2_8 A(IROW) = A(IROW) + MULT1*A(K1) + & MULT2*A(K2) ENDDO ENDDO ENDIF #else JJ = POSPV2 + NFRONT8-1_8 IBEG = JJ + 2_8 IEND = IBEG DO J2 = 1,NEL2 K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) A(POSPV1 + 2_8 + (int(J2,8)-1_8)) = A(K1) A(POSPV2 + 1_8 + (int(J2,8)-1_8)) = A(K2) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 DO IROW = IBEG, IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A( JJ ) = -MULT1 A( JJ + 1_8 ) = -MULT2 IBEG = IBEG + NFRONT8 IEND = IEND + NFRONT8 + 1_8 JJ = JJ+NFRONT8 ENDDO IEND = IEND-1_8 !$OMP PARALLEL DO PRIVATE(J2, K1, K2, MULT1, MULT2, IROW, JJ_LOC, !$OMP& ROW_SHIFT, IBEG_LOC, IEND_LOC) IF (LAST_ROW-IEND_BLOCK>300) DO J2 = 1,LAST_ROW-IEND_BLOCK ROW_SHIFT = (J2-1_8)*NFRONT8 JJ_LOC = JJ + ROW_SHIFT IBEG_LOC = IBEG + ROW_SHIFT IEND_LOC = IEND + ROW_SHIFT K1 = JJ_LOC K2 = JJ_LOC+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) A(POSPV1 + 2_8 + NEL2 + (J2-1_8)) = A(K1) A(POSPV2 + 1_8 + NEL2 + (J2-1_8)) = A(K2) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 DO IROW = IBEG_LOC, IEND_LOC A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A( JJ_LOC ) = -MULT1 A( JJ_LOC + 1_8 ) = -MULT2 ENDDO !$OMP END PARALLEL DO #endif ENDIF IF ((IS_MAXFROMM_AVAIL).AND.(NEL2.GT.0)) THEN IF (PARPIV_T1.NE.0) THEN APOSMAX = POSELT+LDA8*LDA8-1_8 + int(NPIV_NEW+1,8) MAXFROMM = max(MAXFROMM, & dble(A(APOSMAX)) & ) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_MQ_LDLT SUBROUTINE ZMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NFRONT,NASS,INODE,A,LA, & LDA, & POSELT, & KEEP,KEEP8, & FIRST_ROW_TRSM, LAST_ROW_TRSM, & LAST_COL_GEMM, LAST_ROW_GEMM, & CALL_TRSM, CALL_GEMM, LR_ACTIVATED, & IW, LIW, OFFSET_IW & ) IMPLICIT NONE INTEGER, intent(in) :: NPIV INTEGER, intent(in) :: NFRONT, NASS, IBEG_BLOCK, IEND_BLOCK INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER, intent(in) :: INODE INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA INTEGER, intent(in) :: LAST_COL_GEMM INTEGER, intent(in) :: LAST_ROW_GEMM, LAST_ROW_TRSM, & FIRST_ROW_TRSM LOGICAL, intent(in) :: CALL_TRSM, CALL_GEMM, LR_ACTIVATED INTEGER :: OFFSET_IW, LIW INTEGER :: IW(LIW) INTEGER(8) :: LDA8 INTEGER NPIV_BLOCK, NEL1 INTEGER NRHS_TRSM INTEGER(8) :: LPOS, UPOS, APOS INTEGER IROW INTEGER Block INTEGER BLSIZE COMPLEX(kind=8) ONE, ALPHA INCLUDE 'mumps_headers.h' PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) LDA8 = int(LDA,8) NEL1 = LAST_COL_GEMM - IEND_BLOCK NRHS_TRSM = LAST_ROW_TRSM-FIRST_ROW_TRSM NPIV_BLOCK = NPIV - IBEG_BLOCK + 1 IF (NPIV_BLOCK.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF (CALL_TRSM) THEN APOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IBEG_BLOCK-1,8) LPOS = POSELT + LDA8*int(FIRST_ROW_TRSM,8)+int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8)+int(FIRST_ROW_TRSM,8) CALL ztrsm('L', 'U', 'T', 'U', NPIV_BLOCK, NRHS_TRSM, & ONE, A(APOS), LDA, A(LPOS), LDA) CALL ZMUMPS_FAC_LDLT_COPY2U_SCALEL(NRHS_TRSM, 1, KEEP(424), & NFRONT, NPIV_BLOCK, LIW, IW, OFFSET_IW, LA, A, & POSELT, LPOS, UPOS, APOS, .NOT.LR_ACTIVATED) ENDIF IF (CALL_GEMM) THEN #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1 .OR. & ( KEEP(421) > 0 .AND. NEL1 > KEEP(421) ) ) THEN LPOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IEND_BLOCK,8) APOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IEND_BLOCK,8) CALL zgemmt( 'U','N','N', NEL1, & NPIV_BLOCK, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) ELSE #endif IF ( LAST_COL_GEMM - IEND_BLOCK > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = LAST_COL_GEMM - IEND_BLOCK END IF IF ( LAST_COL_GEMM - IEND_BLOCK .GT. 0 ) THEN DO IROW = IEND_BLOCK+1, LAST_COL_GEMM, BLSIZE Block = min( BLSIZE, LAST_COL_GEMM - IROW + 1 ) LPOS = POSELT + int( IROW - 1,8) * LDA8 + & int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK - 1,8) * LDA8 + & int( IROW - 1,8) APOS = POSELT + int( IROW - 1,8) * LDA8 + int( IROW - 1,8) CALL zgemm( 'N','N', Block, LAST_COL_GEMM - IROW + 1, & NPIV_BLOCK, ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) END DO END IF #if defined(GEMMT_AVAILABLE) END IF #endif LPOS = POSELT + int(LAST_COL_GEMM,8)*LDA8 + int(IBEG_BLOCK-1,8) UPOS = POSELT + int(IBEG_BLOCK-1,8) * LDA8 + & int(IEND_BLOCK,8) APOS = POSELT + int(LAST_COL_GEMM,8)*LDA8 + int(IEND_BLOCK,8) IF (LAST_ROW_GEMM .GT. LAST_COL_GEMM) THEN CALL zgemm('N', 'N', NEL1, LAST_ROW_GEMM-LAST_COL_GEMM, & NPIV_BLOCK, ALPHA, A(UPOS), LDA, A(LPOS), LDA, & ONE, A(APOS), LDA) ENDIF ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_SQ_LDLT SUBROUTINE ZMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, IPIV, POSELT, LASTROW2SWAP, & LDA, NFRONT, LEVEL, PARPIV, K50, XSIZE, & IBEG_BLOCK_TO_SEND ) IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER LIW, IOLDPS, NPIVP1, IPIV INTEGER LDA, NFRONT, LEVEL, PARPIV, K50, XSIZE INTEGER LASTROW2SWAP COMPLEX(kind=8) A( LA ) INTEGER IW( LIW ) INTEGER, INTENT(IN) :: IBEG_BLOCK_TO_SEND INCLUDE 'mumps_headers.h' INTEGER :: IBEG INTEGER ISW, ISWPS1, ISWPS2, HF INTEGER(8) :: IDIAG, APOS INTEGER(8) :: LDA8 COMPLEX(kind=8) SWOP LDA8 = int(LDA,8) APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIVP1-1,8) IDIAG = APOS + int(IPIV - NPIVP1,8) HF = 6 + IW( IOLDPS + 5 + XSIZE) + XSIZE ISWPS1 = IOLDPS + HF + NPIVP1 - 1 ISWPS2 = IOLDPS + HF + IPIV - 1 ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW ISW = IW(ISWPS1+NFRONT) IW(ISWPS1+NFRONT) = IW(ISWPS2+NFRONT) IW(ISWPS2+NFRONT) = ISW IF ( LEVEL .eq. 2 ) THEN IBEG = IBEG_BLOCK_TO_SEND CALL zswap( NPIVP1 - 1 - IBEG + 1, & A( POSELT + int(NPIVP1-1,8) + & int(IBEG-1,8) * LDA8), LDA, & A( POSELT + int(IPIV-1,8) + & int(IBEG-1,8) * LDA8), LDA ) END IF CALL zswap( NPIVP1-1, & A( POSELT+int(NPIVP1-1,8) * LDA8 ), 1, & A( POSELT + int(IPIV-1,8) * LDA8 ), 1 ) CALL zswap( IPIV - NPIVP1 - 1, & A( POSELT+int(NPIVP1,8) * LDA8 + int(NPIVP1-1,8) ), & LDA, A( APOS + 1_8 ), 1 ) SWOP = A(IDIAG) A(IDIAG) = A( POSELT+int(NPIVP1-1,8)*LDA8+int(NPIVP1-1,8) ) A( POSELT + int(NPIVP1-1,8)*LDA8 + int(NPIVP1-1,8) ) = SWOP IF (LASTROW2SWAP - IPIV.GT.0) THEN CALL zswap( LASTROW2SWAP - IPIV, & A( APOS + LDA8 ), LDA, & A( IDIAG + LDA8 ), LDA ) ENDIF IF (PARPIV.NE.0 .AND.K50.EQ.2) THEN IF ( LEVEL .eq. 2 .OR. LEVEL.eq.1) THEN APOS = POSELT+LDA8*LDA8-1_8 SWOP = A(APOS+int(NPIVP1,8)) A(APOS+int(NPIVP1,8))= A(APOS+int(IPIV,8)) A(APOS+int(IPIV,8)) = SWOP ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SWAP_LDLT SUBROUTINE ZMUMPS_FAC_LDLT_COPY2U_SCALEL( IROWMAX, IROWMIN, & SIZECOPY, LDA, NCOLS, LIW, IW, OFFSET_IW, & LA, A, POSELT, A_LPOS, A_UPOS, A_DPOS, & COPY_NEEDED ) !$ USE OMP_LIB INTEGER, INTENT(IN) :: IROWMAX, IROWMIN INTEGER, INTENT(IN) :: SIZECOPY INTEGER, INTENT(IN) :: LDA, NCOLS INTEGER, INTENT(IN) :: LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: OFFSET_IW INTEGER(8), INTENT(IN) :: LA COMPLEX(kind=8), INTENT(INOUT) :: A(LA) INTEGER(8), INTENT(IN) :: POSELT, A_LPOS, A_UPOS, A_DPOS LOGICAL, INTENT(IN) :: COPY_NEEDED INTEGER(8) :: LPOS, UPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER :: IROWEND, IROW, Block2 INTEGER :: I, J COMPLEX(kind=8) :: MULT1, MULT2, A11, DETPIV, A22, A12 INTEGER :: BLSIZECOPY COMPLEX(kind=8) :: ONE PARAMETER (ONE=(1.0D0,0.0D0)) INTEGER(8) :: LPOSI, UPOSI LOGICAL :: PIVOT_2X2 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP, CHUNK LDA8 = int(LDA,8) IF (SIZECOPY.NE.0) THEN BLSIZECOPY = SIZECOPY ELSE BLSIZECOPY = 250 ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = (64/4) !$ IF (NOMP .GT. 1 .AND. NCOLS .GE. 4*CHUNK) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max(2*CHUNK, NCOLS/NOMP) !$ ENDIF DO IROWEND = IROWMAX, IROWMIN, -BLSIZECOPY Block2 = min(BLSIZECOPY, IROWEND) IROW = IROWEND - Block2 + 1 LPOS = A_LPOS + int(IROW-1,8)*LDA8 UPOS = A_UPOS + int(IROW-1,8) !$OMP PARALLEL DO PRIVATE(PIVOT_2X2, A11, DPOS, !$OMP& POSPV1, POSPV2, OFFDAG, A22, A12, DETPIV, J, MULT1, MULT2 !$OMP& , LPOSI, UPOSI !$OMP& ) FIRSTPRIVATE(Block2, LDA, LDA8, LPOS, UPOS, A_DPOS) !$OMP& SCHEDULE(STATIC,CHUNK) IF(OMP_FLAG) DO I=1, NCOLS PIVOT_2X2 = .FALSE. IF(IW(OFFSET_IW+I-1) .LE. 0) THEN PIVOT_2X2 = .TRUE. ELSE IF (I .GT. 1) THEN IF (IW(OFFSET_IW+I-2) .LE. 0) THEN cycle ENDIF ENDIF ENDIF DPOS = A_DPOS + LDA8*int(I-1,8) + int(I-1,8) IF(.not. PIVOT_2X2) THEN A11 = ONE/A(DPOS) LPOSI = LPOS+int(I-1,8) IF (COPY_NEEDED) THEN UPOSI = UPOS+int(I-1,8)*LDA8 #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, Block2 A(UPOSI+int(J-1,8)) = A(LPOSI+int(J-1,8)*LDA8) END DO ENDIF #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, Block2 A(LPOSI+int(J-1,8)*LDA8) = A(LPOSI+int(J-1,8)*LDA8)*A11 END DO ELSE IF (COPY_NEEDED) THEN CALL zcopy(Block2, A(LPOS+int(I-1,8)), & LDA, A(UPOS+int(I-1,8)*LDA8), 1) CALL zcopy(Block2, A(LPOS+int(I,8)), & LDA, A(UPOS+int(I,8)*LDA8), 1) ENDIF POSPV1 = DPOS POSPV2 = DPOS + int(LDA+1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1,Block2 MULT1 = A11*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A12*A(LPOS+int(J-1,8)*LDA8+int(I,8)) MULT2 = A12*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A22*A(LPOS+int(J-1,8)*LDA8+int(I,8)) A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) = MULT1 A(LPOS+int(J-1,8)*LDA8+int(I,8)) = MULT2 ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDDO END SUBROUTINE ZMUMPS_FAC_LDLT_COPY2U_SCALEL SUBROUTINE ZMUMPS_FAC_LDLT_COPYSCALE_U( IROWMAX, IROWMIN, & SIZECOPY, LDA, NCOLS, LIW, IW, OFFSET_IW, & LA, A, POSELT, A_LPOS, A_UPOS, A_DPOS ) !$ USE OMP_LIB INTEGER, INTENT(IN) :: IROWMAX, IROWMIN INTEGER, INTENT(IN) :: SIZECOPY INTEGER, INTENT(IN) :: LDA, NCOLS INTEGER, INTENT(IN) :: LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: OFFSET_IW INTEGER(8), INTENT(IN) :: LA COMPLEX(kind=8), INTENT(INOUT) :: A(LA) INTEGER(8), INTENT(IN) :: POSELT, A_LPOS, A_UPOS, A_DPOS INTEGER(8) :: LPOS, UPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER :: IROWEND, IROW, Block2 INTEGER :: I, J COMPLEX(kind=8) :: MULT1, MULT2, A11, A22, A12 INTEGER :: BLSIZECOPY COMPLEX(kind=8) :: ONE PARAMETER (ONE=(1.0D0,0.0D0)) INTEGER(8) :: LPOSI, UPOSI LOGICAL :: PIVOT_2X2 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP, CHUNK LDA8 = int(LDA,8) IF (SIZECOPY.NE.0) THEN BLSIZECOPY = SIZECOPY ELSE BLSIZECOPY = 250 ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = (64/4) !$ IF (NOMP .GT. 1 .AND. NCOLS .GE. 4*CHUNK) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max(2*CHUNK, NCOLS/NOMP) !$ ENDIF DO IROWEND = IROWMAX, IROWMIN, -BLSIZECOPY Block2 = min(BLSIZECOPY, IROWEND) IROW = IROWEND - Block2 + 1 LPOS = A_LPOS + int(IROW-1,8)*LDA8 UPOS = A_UPOS + int(IROW-1,8) !$OMP PARALLEL DO PRIVATE(PIVOT_2X2, A11, DPOS, !$OMP& POSPV1, POSPV2, OFFDAG, A22, A12, J, MULT1, MULT2 !$OMP& , LPOSI, UPOSI !$OMP& ) FIRSTPRIVATE(Block2, LDA, LDA8, LPOS, UPOS, POSELT) !$OMP& SCHEDULE(STATIC,CHUNK) IF(OMP_FLAG) DO I=1, NCOLS PIVOT_2X2 = .FALSE. IF(IW(OFFSET_IW+I-1) .LE. 0) THEN PIVOT_2X2 = .TRUE. ELSE IF (I .GT. 1) THEN IF (IW(OFFSET_IW+I-2) .LE. 0) THEN cycle ENDIF ENDIF ENDIF DPOS = A_DPOS + LDA8*int(I-1,8) + int(I-1,8) IF(.not. PIVOT_2X2) THEN A11 = A(DPOS) LPOSI = LPOS+int(I-1,8) UPOSI = UPOS+int(I-1,8)*LDA8 #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, Block2 A(UPOSI+int(J-1,8)) = A(LPOSI+int(J-1,8)*LDA8)*A11 END DO ELSE POSPV1 = DPOS POSPV2 = DPOS + int(LDA+1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1,Block2 MULT1 = A11*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A12*A(LPOS+int(J-1,8)*LDA8+int(I,8)) MULT2 = A12*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A22*A(LPOS+int(J-1,8)*LDA8+int(I,8)) A(UPOS+int(I-1,8)*LDA8+int(J-1,8)) = MULT1 A(UPOS+int(I,8)*LDA8+int(J-1,8)) = MULT2 ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDDO RETURN END SUBROUTINE ZMUMPS_FAC_LDLT_COPYSCALE_U SUBROUTINE ZMUMPS_FAC_T_LDLT(NFRONT,NASS, & IW,LIW,A,LA, & LDA, & IOLDPS,POSELT,KEEP,KEEP8, & POSTPONE_COL_UPDATE, ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG, OFFSET_IW, INODE ) USE ZMUMPS_OOC IMPLICIT NONE INTEGER NFRONT, NASS,LIW INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER IW(LIW) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: POSELT INTEGER LDA INTEGER IOLDPS, ETATASS LOGICAL POSTPONE_COL_UPDATE INTEGER(8) :: LAFAC INTEGER TYPEFile, NextPiv2beWritten INTEGER LIWFAC, MYID, IFLAG TYPE(IO_BLOCK):: MonBloc INTEGER IDUMMY LOGICAL LAST_CALL INTEGER :: OFFSET_IW INTEGER, intent(in):: INODE INCLUDE 'mumps_headers.h' INTEGER(8) :: UPOS, APOS, LPOS INTEGER(8) :: LDA8 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, IROWEND INTEGER I2, I2END, Block2, IFLAG_OOC COMPLEX(kind=8) ONE, ALPHA, BETA, ZERO PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) LDA8 = int(LDA,8) IF (ETATASS.EQ.1) THEN BETA = ZERO ELSE BETA = ONE ENDIF IF ( NFRONT - NASS > KEEP(58) ) THEN IF ( NFRONT - NASS > KEEP(57) ) THEN BLSIZE = KEEP(58) ELSE BLSIZE = (NFRONT - NASS)/2 END IF ELSE BLSIZE = NFRONT - NASS END IF BLSIZE2 = KEEP(218) NPIV = IW( IOLDPS + 1 + KEEP(IXSZ)) IF ( NFRONT - NASS .GT. 0 ) THEN IF ( POSTPONE_COL_UPDATE ) THEN LPOS = POSELT + LDA8 * int(NASS,8) CALL ztrsm( 'L', 'U', 'T', 'U', & NPIV, NFRONT-NASS, ONE, & A( POSELT ), LDA, & A( LPOS ), LDA ) ENDIF #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1 .OR. & ( KEEP(421) > 0 .AND. NFRONT-NASS > KEEP(421) ) ) THEN LPOS = POSELT + int(NASS,8)*LDA8 UPOS = POSELT + int(NASS,8) APOS = POSELT + int(NASS,8)*LDA8 + int(NASS,8) IF (POSTPONE_COL_UPDATE) THEN CALL ZMUMPS_FAC_LDLT_COPY2U_SCALEL( NFRONT - NASS, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, & POSELT, .TRUE. ) ENDIF CALL zgemmt('U', 'N', 'N', NFRONT-NASS, NPIV, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, & BETA, & A( APOS ), LDA ) ELSE #endif DO IROWEND = NFRONT - NASS, 1, -BLSIZE Block = min( BLSIZE, IROWEND ) IROW = IROWEND - Block + 1 LPOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 APOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 + & int(NASS + IROW - 1,8) UPOS = POSELT + int(NASS,8) IF (.NOT. POSTPONE_COL_UPDATE) THEN UPOS = POSELT + int(NASS + IROW - 1,8) ENDIF IF (POSTPONE_COL_UPDATE) THEN CALL ZMUMPS_FAC_LDLT_COPY2U_SCALEL( Block, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, & POSELT, .TRUE. ) ENDIF DO I2END = Block, 1, -BLSIZE2 Block2 = min(BLSIZE2, I2END) I2 = I2END - Block2+1 CALL zgemm('N', 'N', Block2, Block-I2+1, NPIV, ALPHA, & A(UPOS+int(I2-1,8)), LDA, & A(LPOS+int(I2-1,8)*LDA8), LDA, & BETA, & A(APOS + int(I2-1,8) + int(I2-1,8)*LDA8), LDA) IF (KEEP(201).EQ.1) THEN IF (NextPiv2beWritten.LE.NPIV) THEN LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, MYID, & KEEP8(31), & IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC RETURN ENDIF ENDIF ENDIF ENDDO IF ( NFRONT - NASS - IROW + 1 - Block > 0 ) THEN CALL zgemm( 'N', 'N', Block, NFRONT-NASS-Block-IROW+1, NPIV, & ALPHA, A( UPOS ), LDA, & A( LPOS + LDA8 * int(Block,8) ), LDA, & BETA, & A( APOS + LDA8 * int(Block,8) ), LDA ) ENDIF END DO #if defined(GEMMT_AVAILABLE) END IF #endif IF ( (POSTPONE_COL_UPDATE).AND.(NASS-NPIV.GT.0) ) THEN LPOS = POSELT + int(NPIV,8)*LDA8 UPOS = POSELT + int(NPIV,8) CALL ZMUMPS_FAC_LDLT_COPYSCALE_U( NASS-NPIV, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, POSELT) LPOS = POSELT + LDA8 * int(NASS,8) CALL zgemm('N', 'N', NASS-NPIV, NFRONT-NASS, NPIV, ALPHA, & A( POSELT + int(NPIV,8)), LDA, & A( LPOS ), LDA, & BETA, & A( LPOS + int(NPIV,8) ), LDA) ENDIF END IF RETURN END SUBROUTINE ZMUMPS_FAC_T_LDLT SUBROUTINE ZMUMPS_STORE_PERMINFO( PIVRPTR, NBPANELS, PIVR, NASS, & K, P, LastPanelonDisk, & LastPIVRPTRIndexFilled ) IMPLICIT NONE INTEGER, intent(in) :: NBPANELS, NASS, K, P INTEGER, intent(inout) :: PIVRPTR(NBPANELS), PIVR(NASS) INTEGER LastPanelonDisk, LastPIVRPTRIndexFilled INTEGER I IF ( LastPanelonDisk+1 > NBPANELS ) THEN WRITE(*,*) "INTERNAL ERROR IN ZMUMPS_STORE_PERMINFO!" WRITE(*,*) "NASS=",NASS,"PIVRPTR=",PIVRPTR(1:NBPANELS) WRITE(*,*) "K=",K, "P=",P, "LastPanelonDisk=",LastPanelonDisk WRITE(*,*) "LastPIVRPTRIndexFilled=", LastPIVRPTRIndexFilled CALL MUMPS_ABORT() ENDIF PIVRPTR(LastPanelonDisk+1) = K + 1 IF (LastPanelonDisk.NE.0) THEN PIVR(K - PIVRPTR(1) + 1) = P DO I = LastPIVRPTRIndexFilled + 1, LastPanelonDisk PIVRPTR(I)=PIVRPTR(LastPIVRPTRIndexFilled) ENDDO ENDIF LastPIVRPTRIndexFilled = LastPanelonDisk + 1 RETURN END SUBROUTINE ZMUMPS_STORE_PERMINFO SUBROUTINE ZMUMPS_UPDATE_MINMAX_PIVOT & ( DIAG, DKEEP, KEEP, NULLPIVOT) !$ USE OMP_LIB IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: DIAG DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) LOGICAL, INTENT(IN) :: NULLPIVOT INTEGER, INTENT(IN) :: KEEP(500) IF (KEEP(405).EQ.0) THEN DKEEP(21) = max(DKEEP(21), DIAG) DKEEP(19) = min(DKEEP(19), DIAG) IF (.NOT.NULLPIVOT) THEN DKEEP(20) = min(DKEEP(20), DIAG) ENDIF ELSE !$OMP ATOMIC UPDATE DKEEP(21) = max(DKEEP(21), DIAG) !$OMP END ATOMIC !$OMP ATOMIC UPDATE DKEEP(19) = min(DKEEP(19), DIAG) !$OMP END ATOMIC IF (.NOT.NULLPIVOT) THEN !$OMP ATOMIC UPDATE DKEEP(20) = min(DKEEP(20), DIAG) !$OMP END ATOMIC ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_UPDATE_MINMAX_PIVOT SUBROUTINE ZMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, NCB, SIZE_SCHUR, ROW_INDICES, PERM, & NVSCHUR & ) IMPLICIT NONE INTEGER, intent(in) :: N, NCB, SIZE_SCHUR INTEGER, intent(in) :: ROW_INDICES(NCB), PERM(N) INTEGER, intent(out):: NVSCHUR INTEGER :: I, IPOS, IBEG_SCHUR IBEG_SCHUR = N - SIZE_SCHUR +1 NVSCHUR = 0 IPOS = NCB DO I= NCB,1,-1 IF (abs(ROW_INDICES(I)).LE.N) THEN IF (PERM(ROW_INDICES(I)).LT.IBEG_SCHUR) EXIT ENDIF IPOS = IPOS -1 ENDDO NVSCHUR = NCB-IPOS RETURN END SUBROUTINE ZMUMPS_GET_SIZE_SCHUR_IN_FRONT END MODULE ZMUMPS_FAC_FRONT_AUX_M MUMPS_5.8.1/src/sana_aux_ELT.F0000664000175000017500000011300215042446436015644 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ANA_F_ELT(N, NELT, ELTPTR, ELTVAR, LIW, & IKEEP, & IORD, NFSIZ, FILS, FRERE, & LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, & NSLAVES, & XNODEL, NODEL #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , METIS_OPTIONS #endif & ) USE MUMPS_ANA_ORD_WRAPPERS IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, SIZE_SCHUR, NSLAVES INTEGER(8), INTENT(IN) :: LIW INTEGER, INTENT(IN) :: ELTPTR(NELT+1) INTEGER, INTENT(IN) :: ELTVAR(ELTPTR(NELT+1)-1) INTEGER, INTENT(IN) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: IKEEP(N,3) INTEGER, INTENT(INOUT) :: INFO(80), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(OUT) :: NFSIZ(N), FILS(N), FRERE(N) INTEGER, INTENT(OUT) :: XNODEL(N+1), NODEL(ELTPTR(NELT+1)-1) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER, INTENT(IN) :: METIS_OPTIONS(40) #endif INTEGER K,I,NCMPA,IFSON,IN INTEGER(8) :: L1, L2 INTEGER NEMIN, MPRINT, LP, MP, LDIAG INTEGER(8) :: NZ8, LLIW8, IWFR8 INTEGER allocok, ITEMP LOGICAL PROK, NOSUPERVAR, LPOK INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) LOGICAL SPLITROOT INTEGER HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & NBSONS_Scalapack_CAND INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER :: IDUMMY(1) INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER, DIMENSION(:), ALLOCATABLE :: IW2 INTEGER, DIMENSION(:), ALLOCATABLE :: PARENT INTEGER, DIMENSION(:,:), ALLOCATABLE :: IWtemp INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE8 #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) INTEGER :: NUMFLAG #else INTEGER, DIMENSION(:), ALLOCATABLE :: NUMFLAG #endif INTEGER :: OPT_METIS_SIZE, METIS_IDX_SIZE INTEGER :: IERR #endif INTEGER IDUM EXTERNAL SMUMPS_ANA_G11_ELT, SMUMPS_ANA_G12_ELT, & SMUMPS_ANA_G1_ELT, SMUMPS_ANA_G2_ELT, & SMUMPS_ANA_G2_ELTNEW, & SMUMPS_ANA_J1_ELT, SMUMPS_ANA_J2_ELT, & SMUMPS_ANA_K, & SMUMPS_ANA_LNEW, SMUMPS_ANA_M, & MUMPS_AMD_ELT ALLOCATE( IW ( LIW ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(LIW, INFO( 2 )) GOTO 90 ENDIF ALLOCATE( IPE8 ( N + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (N+1)*KEEP(10) GOTO 90 ENDIF ALLOCATE( PARENT(N), IWtemp ( N, 3 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(4_8*int(N,8), INFO( 2 )) GOTO 90 ENDIF MPRINT= ICNTL(3) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MP = ICNTL(3) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) LDIAG = ICNTL(4) IF (KEEP(60).NE.0) THEN NOSUPERVAR=.TRUE. IF (IORD.GT.1) IORD = 0 ELSE NOSUPERVAR=.FALSE. ENDIF IF (IORD == 7) THEN IF ( N < 10000 ) THEN IORD = 0 ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IORD = 5 #else IORD = 0 #endif ENDIF END IF #if ! defined(metis) && ! defined(parmetis) && ! defined(metis4) && ! defined(parmetis3) IF (IORD == 5) IORD = 0 #endif IF (KEEP(1).LT.1) KEEP(1) = 1 NEMIN = KEEP(1) IF (LDIAG.LE.2 .OR. MP.LE.0) GO TO 10 WRITE (MP,99999) N, NELT, LIW, INFO(1) K = min(10,NELT+1) IF (LDIAG.EQ.4) K = NELT+1 IF (K.GT.0) WRITE (MP,99998) (ELTPTR(I),I=1,K) K = min(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 = min(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_8 L2 = L1 + int(N,8) IF (LIW .LT. 3_8*int(N,8)) THEN INFO(1) = -2002 CALL MUMPS_SET_IERROR( LIW, INFO(2) ) ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF ( IORD == 5 ) THEN IF (LIW .LT. int(N,8)+int(N,8)+1_8) THEN INFO(1)= -2002 CALL MUMPS_SET_IERROR( LIW, INFO(2) ) GOTO 90 ENDIF ELSE #endif IF (NOSUPERVAR) THEN IF ( LIW .LT. 2_8*int(N,8) ) THEN INFO(1)= -2002 CALL MUMPS_SET_IERROR( LIW, INFO(2) ) GOTO 90 END IF ELSE IF ( LIW .LT. 4_8*int(N,8)+4_8 ) THEN INFO(1)= -2002 CALL MUMPS_SET_IERROR( LIW, INFO(2) ) GOTO 90 END IF ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif IDUM=0 CALL SMUMPS_NODEL(NELT, N, ELTPTR(NELT+1)-1, ELTPTR, ELTVAR, & XNODEL, NODEL, IW(L1), IDUM, ICNTL) IF (IORD.NE.1 .AND. IORD .NE. 5) THEN IORD = 0 IF (NOSUPERVAR) THEN CALL SMUMPS_ANA_G1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), IW(L1)) ELSE CALL SMUMPS_ANA_G11_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), 4_8*int(N,8)+4_8, IW(L1)) ENDIF LLIW8 = max(NZ8,int(N,8)) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8, INFO(2)) GOTO 90 ENDIF IF (NOSUPERVAR) THEN CALL SMUMPS_ANA_G2_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) ELSE CALL SMUMPS_ANA_G12_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) ENDIF IF (NOSUPERVAR) THEN CALL MUMPS_HAMD(N, LLIW8, IPE8, IWFR8, IWtemp(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), IWtemp(1,3), & IWtemp, & LISTVAR_SCHUR, SIZE_SCHUR) IF (KEEP(60) == 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSEIF (KEEP(60) == 2 .OR. KEEP(60) == 3 ) THEN KEEP(38) = LISTVAR_SCHUR(1) ELSE WRITE(*,*) "Internal error in SMUMPS_ANA_F_ELT",KEEP(60) CALL MUMPS_ABORT() ENDIF ELSE CALL MUMPS_AMD_ELT(N, LLIW8, IPE8, IWFR8, IWtemp(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), IWtemp(1,3), & IWtemp) ENDIF ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MPRINT,'(A)') ' Ordering based on METIS' ENDIF CALL SMUMPS_ANA_G1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), IW(L1)) LLIW8 = max(NZ8,int(N,8)) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8, INFO(2)) GOTO 90 ENDIF CALL SMUMPS_ANA_G2_ELTNEW(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) #if defined(metis4) || defined(parmetis3) NUMFLAG = 1 OPT_METIS_SIZE = 8 #else ALLOCATE( NUMFLAG ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF DO I=1,N NUMFLAG(I) = 1 ENDDO OPT_METIS_SIZE = 40 #endif CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN INFO(1) = -52 INFO(2) = 1 GOTO 90 ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32(N, IPE8, IW2, #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG, #endif & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP(1:N,2), IKEEP(1:N,1), INFO(1), LP, LPOK) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64(N, IPE8, IW2, #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG, #endif & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP(1:N,2), IKEEP(1:N,1), INFO(1), & LP, LPOK, KEEP(10), & LLIW8, .FALSE., .TRUE. ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF IF (INFO(1) .LT. 0) GOTO 90 DEALLOCATE(IW2) ELSE IF (IORD.NE.1) THEN WRITE(*,*) IORD WRITE(*,*) 'bad option for ordering' CALL MUMPS_ABORT() ENDIF #endif DO K=1,N IW(L1+int(K,8)) = 0 ENDDO DO K=1,N IF ((IKEEP(K,1).LE.0).OR.(IKEEP(K,1).GT.N)) & GO TO 40 IF (IW(L1+int(IKEEP(K,1),8)).EQ.1) THEN GOTO 40 ELSE IW(L1+int(IKEEP(K,1),8)) = 1 ENDIF ENDDO CALL SMUMPS_ANA_J1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IWtemp(1,2), IW(L1)) LLIW8 = NZ8+int(N,8) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8,INFO(2)) GOTO 90 ENDIF CALL SMUMPS_ANA_J2_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) IF (KEEP(60) == 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR IF (KEEP(60) == 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSEIF (KEEP(60) == 2 .OR. KEEP(60) == 3 ) THEN KEEP(38) = LISTVAR_SCHUR(1) ELSE WRITE(*,*) "Internal error in SMUMPS_ANA_F_ELT",KEEP(60) CALL MUMPS_ABORT() ENDIF ENDIF CALL SMUMPS_ANA_K(N, IPE8, IW2, LLIW8, IWFR8, IKEEP, & IKEEP(1,2), IW(L1), & IW(L2), NCMPA, ITEMP, IWtemp) ENDIF CALL SMUMPS_ANA_LNEW(N, IWtemp, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, IWtemp(1,2), & INFO(6), FILS, FRERE, IWtemp(1,3), NEMIN, & IW(L2), KEEP(60), KEEP(20), KEEP(38), & IW2,KEEP(104),IW(L2+int(N,8)),KEEP(50), & ICNTL(13), KEEP(37), KEEP(197), NSLAVES, KEEP(250).EQ.1, & .FALSE., IDUMMY, LIDUMMY, & INODE_Scalapack_CAND, NBSONS_Scalapack_CAND, & KEEP(11), KEEP(191), KEEP(192), KEEP(193) ) DEALLOCATE(IW2) IF (KEEP(60).NE.0) THEN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO WHILE (IN.GT.0) IN = FILS (IN) END DO IFSON = -IN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO I=2,SIZE_SCHUR FILS(IN) = LISTVAR_SCHUR (I) IN = FILS(IN) FRERE (IN) = N+1 ENDDO FILS(IN) = -IFSON ENDIF CALL SMUMPS_ANA_M(IKEEP(1,2), & IWtemp(1,3), INFO(6), & INFO(5), KEEP(2),KEEP(50), & KEEP8(101), KEEP(108),KEEP(5), & KEEP(6), KEEP(226), KEEP(253)) IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, KEEP(20) ) INODE_Scalapack_CAND = KEEP(20) NBSONS_Scalapack_CAND = 1 END IF IF ( KEEP(48) == 4 .OR. & ( (KEEP(24).NE.0).AND.(KEEP8(21).GT.0_8) ) ) THEN CALL SMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2), & KEEP(48), KEEP(50), NSLAVES) END IF IF (KEEP(210).LT.1.OR.KEEP(210).GT.2) KEEP(210)=2 IF (KEEP(210).EQ.2) KEEP8(79)=huge(KEEP8(79)) IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF IF (KEEP(11).EQ.0) THEN IF (KEEP(79).EQ.0) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN IDUMMY(1)= -1 CALL SMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ, & IDUMMY, LIDUMMY, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF (PROK) THEN WRITE(MP,*) " Number of split nodes in pre-splitting=", & KEEP(61) ENDIF ENDIF ENDIF ENDIF ENDIF HOW_TO_SPLIT_ROOT = 0 SPLITROOT = ICNTL(13) .EQ. -1 #if defined(NOSCALAPACK) SPLITROOT = SPLITROOT .OR. NSLAVES.GT.0 #else SPLITROOT = SPLITROOT .OR. & (ICNTL(13).GT.0 .AND. NSLAVES .GT. ICNTL(13)) #endif HOW_TO_SPLIT_ROOT = 0 IF (SPLITROOT.AND.KEEP(11).GT.0) HOW_TO_SPLIT_ROOT =1 IF (KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. IF (KEEP(11).GT.0) HOW_TO_SPLIT_ROOT = 2 ENDIF SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) )) #if defined(NOSCALAPACK) #else IF ( KEEP(11).GT.0) THEN IF (.NOT.SPLITROOT .AND. & (KEEP(60).EQ.0).AND. & ( (NFSIZ(INODE_Scalapack_CAND).GT.KEEP(37)) & .AND.(ICNTL(13).LE.0) ) & .AND. & (NBSONS_Scalapack_CAND.GT.KEEP(11)) & ) THEN HOW_TO_SPLIT_ROOT = 3 SPLITROOT=.TRUE. ENDIF ENDIF #endif IF (SPLITROOT) THEN IDUMMY(1) = -1 IF (KEEP(11).EQ.0) THEN CALL SMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & IDUMMY, LIDUMMY, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) ENDIF ELSE CALL SMUMPS_SPLIT_ROOT( NSLAVES, & HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & N, FRERE(1), FILS(1), NFSIZ(1), & KEEP, KEEP8, & IDUMMY, LIDUMMY, INFO(6)) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN K = min(10,N) IF (LDIAG.EQ.4) K = N IF (K.GT.0) WRITE (MP,99997) (IKEEP(I,1),I=1,K) IF (K.GT.0) WRITE (MP,99991) (IKEEP(I,2),I=1,K) IF (K.GT.0) WRITE (MP,99990) (IKEEP(I,3),I=1,K) IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) ENDIF GO TO 90 40 INFO(1) = -4 INFO(2) = K 90 CONTINUE IF (INFO(1) .LT.0) THEN IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99996) INFO(1) IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99982) INFO(2) ENDIF IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(IPE8)) DEALLOCATE(IPE8) IF (allocated(IW2)) DEALLOCATE(IW2) IF (allocated(IWtemp)) DEALLOCATE(IWtemp) RETURN 99999 FORMAT (/'Entering analysis phase with ...'/ & ' N NELT LIW INFO(1)'/, & 9X, I10, I11, I12, I14) 99998 FORMAT ('Element pointers: ELTPTR() '/(9X, 7I10)) 99995 FORMAT ('Element variables: ELTVAR() '/(9X, 7I10)) 99997 FORMAT ('IKEEP(.,1)=', 10I6/(12X, 10I6)) 99996 FORMAT (/'** Error return ** from Analysis * INFO(1)=', I3) 99991 FORMAT ('IKEEP(.,2)=', 10I6/(12X, 10I6)) 99990 FORMAT ('IKEEP(.,3)=', 10I6/(12X, 10I6)) 99989 FORMAT ('FILS (.) =', 10I6/(12X, 10I6)) 99988 FORMAT ('FRERE(.) =', 10I6/(12X, 10I6)) 99987 FORMAT ('NFSIZ(.) =', 10I6/(12X, 10I6)) 99982 FORMAT ('Error in permutation array KEEP INFO(2)=', I3) END SUBROUTINE SMUMPS_ANA_F_ELT SUBROUTINE SMUMPS_NODEL( NELT, N, NELNOD, XELNOD, ELNOD, & XNODEL, NODEL, FLAG, IERROR, ICNTL ) IMPLICIT NONE INTEGER NELT, N, NELNOD, IERROR, ICNTL(60) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & FLAG(N) INTEGER I, J, K, MP, NBERR MP = ICNTL(2) FLAG(1:N) = 0 XNODEL(1:N) = 0 IERROR = 0 DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF ( J.LT.1 .OR. J.GT.N ) THEN IERROR = IERROR + 1 ELSE IF ( FLAG(J).NE.I ) THEN XNODEL(J) = XNODEL(J) + 1 FLAG(J) = I ENDIF ENDIF ENDDO ENDDO IF ( IERROR.GT.0 .AND. MP.GT.0 .AND. ICNTL(4).GE.2 ) THEN NBERR = 0 WRITE(MP,99999) DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF ( J.LT.1 .OR. J.GT.N ) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN WRITE(MP,'(A,I8,A,I8,A)') & 'Element ',I,' variable ',J,' ignored.' ELSE GO TO 100 ENDIF ENDIF ENDDO ENDDO ENDIF 100 CONTINUE K = 1 DO I = 1, N K = K + XNODEL(I) XNODEL(I) = K ENDDO XNODEL(N+1) = XNODEL(N) FLAG(1:N) = 0 DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF (FLAG(J).NE.I) THEN XNODEL(J) = XNODEL(J) - 1 NODEL(XNODEL(J)) = I FLAG(J) = I ENDIF ENDDO ENDDO RETURN 99999 FORMAT (/'*** Warning message from subroutine SMUMPS_NODEL ***') END SUBROUTINE SMUMPS_NODEL SUBROUTINE SMUMPS_ANA_G1_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, FLAG) IMPLICIT NONE INTEGER N, NELT, NELNOD INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & FLAG(N) INTEGER I,J,K1,K2,K3 FLAG(1:N) = 0 LEN(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN LEN(I) = LEN(I) + 1 LEN(J) = LEN(J) + 1 FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO NZ = 0_8 DO I = 1,N NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE SMUMPS_ANA_G1_ELT SUBROUTINE SMUMPS_ANA_G2_ELTNEW(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N+1) INTEGER LEN(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IWFR = IWFR + int(LEN(I),8) IPE(I) = IWFR ENDDO IPE(N+1)=IPE(N) FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1 IW(IPE(I)) = J IPE(J) = IPE(J) - 1 IW(IPE(J)) = I FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE SMUMPS_ANA_G2_ELTNEW SUBROUTINE SMUMPS_ANA_G2_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER LEN(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IWFR = IWFR + int(LEN(I),8) IF (LEN(I).GT.0) THEN IPE(I) = IWFR ELSE IPE(I) = 0_8 ENDIF ENDDO FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1_8 IW(IPE(I)) = J IPE(J) = IPE(J) - 1_8 IW(IPE(J)) = I FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE SMUMPS_ANA_G2_ELT SUBROUTINE SMUMPS_ANA_J1_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, LEN, FLAG) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), FLAG(N) INTEGER I,J,K1,K2,K3 FLAG(1:N) = 0 LEN(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IF (PERM(J).GT.PERM(I)) THEN LEN(I) = LEN(I) + 1 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO NZ = 0_8 DO I = 1,N NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE SMUMPS_ANA_J1_ELT SUBROUTINE SMUMPS_ANA_J2_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), IW(LW), & FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 0_8 DO I = 1,N IWFR = IWFR + int(LEN(I) + 1,8) IPE(I) = IWFR ENDDO IWFR = IWFR + 1_8 FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IF (PERM(J).GT.PERM(I)) THEN IW(IPE(I)) = J IPE(I) = IPE(I) - 1_8 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO DO I = 1,N J = int(IPE(I)) IW(J) = LEN(I) IF (LEN(I).EQ.0) IPE(I) = 0_8 ENDDO RETURN END SUBROUTINE SMUMPS_ANA_J2_ELT SUBROUTINE SMUMPS_ANA_DIST_ELEMENTS( MYID, SLAVEF, N, & PROCNODE, STEP, PTRAIW, PTRARW, & NELT, FRTPTR, FRTELT, & KEEP,KEEP8, ICNTL, SYM ) IMPLICIT NONE INTEGER MYID, SLAVEF, N, NELT, SYM INTEGER KEEP( 500 ), ICNTL( 60 ) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAIW( NELT+1 ), PTRARW( NELT+1 ) INTEGER STEP( N ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PROCNODE( KEEP(28) ) INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER(8) :: IPTRI8, IPTRR8, NVAR8 INTEGER ELT, I, K INTEGER TYPE_PARALL, ITYPE, IRANK LOGICAL :: EARLYT3ROOTINS TYPE_PARALL = KEEP(46) PTRAIW( 1:NELT ) = 0_8 EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) DO I = 1, N IF (STEP(I).LT.0) CYCLE ITYPE = MUMPS_TYPENODE( PROCNODE(abs(STEP(I))), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(abs(STEP(I))), KEEP(199) ) IF ( TYPE_PARALL .eq. 0 ) THEN IRANK = IRANK + 1 END IF IF ( (ITYPE .EQ. 2) .OR. & (ITYPE .EQ. 3 .AND. .NOT. EARLYT3ROOTINS ) .OR. & (ITYPE .EQ. 1 .AND. IRANK .EQ. MYID) ) THEN DO K = FRTPTR(I),FRTPTR(I+1)-1 ELT = FRTELT(K) PTRAIW( ELT ) = PTRARW(ELT+1) - PTRARW(ELT) ENDDO ELSE END IF END DO IPTRI8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT ) PTRAIW( ELT ) = IPTRI8 IPTRI8 = IPTRI8 + NVAR8 ENDDO PTRAIW( NELT+1 ) = IPTRI8 KEEP8(27) = IPTRI8 - 1 IF ( .TRUE. ) THEN IF (SYM .EQ. 0) THEN IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + NVAR8*NVAR8 ENDDO PTRARW( NELT+1 ) = IPTRR8 ELSE IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + (NVAR8*(NVAR8+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR8 ENDIF ELSE IF (SYM .EQ. 0) THEN IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + NVAR8*NVAR8 ENDDO PTRARW( NELT+1 ) = IPTRR8 ELSE IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + (NVAR8*(NVAR8+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR8 ENDIF ENDIF KEEP8(26) = IPTRR8 - 1_8 RETURN END SUBROUTINE SMUMPS_ANA_DIST_ELEMENTS SUBROUTINE SMUMPS_ELTPROC( N, NELT, ELTPROC, SLAVEF, PROCNODE, & KEEP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, SLAVEF INTEGER, INTENT(IN) :: PROCNODE( N ) INTEGER, INTENT(INOUT) :: ELTPROC( NELT ) INTEGER :: KEEP(500) INTEGER ELT, I, ITYPE LOGICAL :: EARLYT3ROOTINS INTEGER, EXTERNAL :: MUMPS_TYPENODE, MUMPS_PROCNODE EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) DO ELT = 1, NELT I = ELTPROC(ELT) IF ( I .NE. 0) THEN ITYPE = MUMPS_TYPENODE(PROCNODE(I),KEEP(199)) IF (ITYPE.EQ.1) THEN ELTPROC(ELT) = MUMPS_PROCNODE(PROCNODE(I),KEEP(199)) ELSE IF ( ITYPE.EQ.2 .OR. .NOT. EARLYT3ROOTINS ) THEN ELTPROC(ELT) = -1 ELSE ELTPROC(ELT) = -2 ENDIF ELSE ELTPROC(ELT) = -3 ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_ELTPROC SUBROUTINE SMUMPS_FRTELT(N, NELT, NELNOD, FRERE, FILS, NA, NE, & XNODEL, NODEL, FRTPTR, FRTELT, ELTNOD) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, NELNOD INTEGER, INTENT(IN) :: FRERE(N), FILS(N), NA(N), NE(N) INTEGER, INTENT(OUT):: FRTPTR(N+1), FRTELT(NELT), ELTNOD(NELT) INTEGER, INTENT(IN) :: XNODEL(N+1), NODEL(NELNOD) INTEGER, DIMENSION(:), ALLOCATABLE :: TNSTK, IPOOL INTEGER I, K, IFATH, allocok INTEGER INODE, LEAF, NBLEAF, NBROOT, III, IN ALLOCATE(TNSTK( N ), stat=allocok) IF (allocok.ne.0) THEN WRITE(6,*) ' Allocation error of TNSTK in ' & // 'routine SMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF ALLOCATE(IPOOL( N ), stat=allocok) IF (allocok.ne.0) THEN WRITE(6,*) ' Allocation error of IPOOL in ' & // 'routine SMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF TNSTK = NE LEAF = 1 IF (N.EQ.1) THEN NBROOT = 1 NBLEAF = 1 IPOOL(1) = 1 LEAF = LEAF + 1 ELSEIF (NA(N).LT.0) THEN NBLEAF = N NBROOT = N DO 20 I=1,NBLEAF-1 INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 20 CONTINUE INODE = -NA(N)-1 IPOOL(LEAF) = INODE LEAF = LEAF + 1 ELSEIF (NA(N-1).LT.0) THEN NBLEAF = N-1 NBROOT = NA(N) IF (NBLEAF-1.GT.0) THEN DO 30 I=1,NBLEAF-1 INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 30 CONTINUE ENDIF INODE = -NA(N-1)-1 IPOOL(LEAF) = INODE LEAF = LEAF + 1 ELSE NBLEAF = NA(N-1) NBROOT = NA(N) DO 40 I = 1,NBLEAF INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 40 CONTINUE ENDIF ELTNOD(1:NELT) = 0 III = 1 90 CONTINUE IF (III.NE.LEAF) THEN INODE=IPOOL(III) III = III + 1 ELSE WRITE(6,*) ' ERROR 1 in subroutine SMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF 95 CONTINUE IN = INODE 100 CONTINUE DO K = XNODEL(IN),XNODEL(IN+1)-1 I = NODEL(K) IF (ELTNOD(I).EQ.0) ELTNOD(I) = INODE ENDDO IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IN = INODE 110 IN = FRERE(IN) IF (IN.GT.0) GO TO 110 IF (IN.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 115 GOTO 90 ELSE IFATH = -IN ENDIF TNSTK(IFATH) = TNSTK(IFATH) - 1 IF ( TNSTK(IFATH) .EQ. 0 ) THEN INODE = IFATH GOTO 95 ELSE GOTO 90 ENDIF 115 CONTINUE FRTPTR(1:N) = 0 DO I = 1,NELT IF (ELTNOD(I) .NE. 0) THEN FRTPTR(ELTNOD(I)) = FRTPTR(ELTNOD(I)) + 1 ENDIF ENDDO K = 1 DO I = 1,N K = K + FRTPTR(I) FRTPTR(I) = K ENDDO FRTPTR(N+1) = FRTPTR(N) DO K = 1,NELT INODE = ELTNOD(K) IF (INODE .NE. 0) THEN FRTPTR(INODE) = FRTPTR(INODE) - 1 FRTELT(FRTPTR(INODE)) = K ENDIF ENDDO DEALLOCATE(TNSTK, IPOOL) RETURN END SUBROUTINE SMUMPS_FRTELT SUBROUTINE SMUMPS_ANA_G11_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, LW, IW) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8) :: LW INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW) INTEGER I,J,K1,K2,K3,LP,NSUP,SUPVAR INTEGER INFO44(6) EXTERNAL SMUMPS_SUPVAR LP = 6 CALL SMUMPS_SUPVAR(N,NELT,XELNOD(NELT+1)-1,ELNOD,XELNOD, & NSUP,IW(3_8*int(N,8)+3_8+1_8), & 3_8*int(N,8)+3_8,IW,LP,INFO44) IF (INFO44(1) .LT. 0) THEN IF (LP.GE.0) WRITE(LP,*) & 'Error return from SMUMPS_SUPVAR. INFO(1) = ',INFO44(1) ENDIF IW(1:NSUP) = 0 LEN(1:N) = 0 DO I = 1,N SUPVAR = IW(3_8*int(N,8)+3_8+1_8+int(I,8)) IF (SUPVAR .EQ. 0) CYCLE IF (IW(SUPVAR).NE.0) THEN LEN(I) = -IW(SUPVAR) ELSE IW(SUPVAR) = I ENDIF ENDDO IW(int(N+1,8):2_8*int(N,8)) = 0 NZ = 0_8 DO SUPVAR = 1,NSUP I = IW(SUPVAR) DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF (LEN(J).GE.0) THEN IF ((I.NE.J) .AND. (IW(int(N,8)+int(J,8)).NE.I)) THEN IW(int(N,8)+int(J,8)) = I LEN(I) = LEN(I) + 1 ENDIF ENDIF ENDIF ENDDO ENDDO NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE SMUMPS_ANA_G11_ELT SUBROUTINE SMUMPS_ANA_G12_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IF (LEN(I).GT.0) THEN IWFR = IWFR + int(LEN(I),8) IPE(I) = IWFR ELSE IPE(I) = 0_8 ENDIF ENDDO FLAG(1:N) = 0 DO I = 1,N IF (LEN(I).LE.0) CYCLE DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF (LEN(J) .GT. 0) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1 IW(IPE(I)) = J FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE SMUMPS_ANA_G12_ELT SUBROUTINE SMUMPS_SUPVAR(N,NELT,NZ,ELTVAR,ELTPTR,NSUP,SVAR, & LIW,IW,LP,INFO) INTEGER LP,N,NELT,NSUP,NZ INTEGER(8)::LIW INTEGER INFO(6) INTEGER ELTPTR(NELT+1),ELTVAR(NZ) INTEGER IW(LIW),SVAR(0:N) INTEGER(8) :: FLAG,NEW,VARS 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) = N + 1 GO TO 40 END IF NEW = 1_8 VARS = NEW + LIW/3_8 FLAG = VARS + LIW/3_8 CALL SMUMPS_SUPVARB(N,NELT,ELTPTR,NZ,ELTVAR,SVAR,NSUP, & int(min(int(huge(NSUP)-1,8),LIW/3_8-1_8)), & IW(NEW),IW(VARS),IW(FLAG),INFO) IF (INFO(1).EQ.-4) THEN INFO(4) = N + 1 GO TO 40 ELSE INFO(4) = NSUP + 1 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) 3_8*int(INFO(4),8) END IF 50 RETURN 9000 FORMAT (/3X,'Error message from SMUMPS_SUPVAR: INFO(1) = ',I2) 9010 FORMAT (3X,'LIW is insufficient. Upper bound on required work', & 'space is ',I12) END SUBROUTINE SMUMPS_SUPVAR SUBROUTINE SMUMPS_SUPVARB( N, NELT, ELTPTR, NZ, ELTVAR, & SVAR, NSUP, MAXSUP, NEW, VARS, FLAG, INFO ) INTEGER MAXSUP,N,NELT,NSUP,NZ INTEGER ELTPTR(NELT+1),ELTVAR(NZ) INTEGER INFO(6) INTEGER FLAG(0:MAXSUP), NEW(0:MAXSUP),SVAR(0:N), & VARS(0:MAXSUP) INTEGER I,IS,J,JS,K,K1,K2 DO 10 I = 0,N SVAR(I) = 0 10 CONTINUE VARS(0) = N + 1 NEW(0) = -1 FLAG(0) = 0 NSUP = 0 DO 40 J = 1,NELT K1 = ELTPTR(J) K2 = ELTPTR(J+1) - 1 DO 20 K = K1,K2 I = ELTVAR(K) IF (I.LT.1 .OR. I.GT.N) THEN INFO(2) = INFO(2) + 1 GO TO 20 END IF IS = SVAR(I) IF (IS.LT.0) THEN ELTVAR(K) = 0 INFO(3) = INFO(3) + 1 GO TO 20 END IF SVAR(I) = SVAR(I) - N - 2 VARS(IS) = VARS(IS) - 1 20 CONTINUE DO 30 K = K1,K2 I = ELTVAR(K) IF (I.LT.1 .OR. I.GT.N) GO TO 30 IS = SVAR(I) + N + 2 IF (FLAG(IS).LT.J) THEN FLAG(IS) = J IF (VARS(IS).GT.0) THEN NSUP = NSUP + 1 IF (NSUP.GT.MAXSUP) THEN INFO(1) = -4 RETURN END IF VARS(NSUP) = 1 FLAG(NSUP) = J NEW(IS) = NSUP SVAR(I) = NSUP ELSE VARS(IS) = 1 NEW(IS) = IS SVAR(I) = IS END IF ELSE JS = NEW(IS) VARS(JS) = VARS(JS) + 1 SVAR(I) = JS END IF 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE SMUMPS_SUPVARB MUMPS_5.8.1/src/sfac_lr.F0000664000175000017500000027753415042446437015000 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_LR USE SMUMPS_LR_TYPE USE SMUMPS_LR_CORE IMPLICIT NONE CONTAINS SUBROUTINE SMUMPS_BLR_UPDATE_TRAILING_LDLT( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, & NELIM, IW2, BLOCK, & MAXI_CLUSTER, NPIV, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & NELIM, MAXI_CLUSTER, NPIV, NIV, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR REAL, intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_L(:) REAL, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, intent(in) :: IW2(*) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL, J, MID_RANK LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER(8) :: POSELTT, POSELTD REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(CURRENT_BLR)-1,8) & + int(BEGS_BLR(CURRENT_BLR) - 1,8) OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC, CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, !$OMP& MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL*(NB_BLOCKS_PANEL+1)/2) IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT + int(NFRONT,8) * & int(BEGS_BLR(CURRENT_BLR+I)-1,8) & + int(BEGS_BLR(CURRENT_BLR+J) - 1, 8) CALL SMUMPS_LRGEMM4(MONE, & BLR_L(J), BLR_L(I), ONE, A, LA, & POSELTT, NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_L(J)%M, BLR_L(J)%N, BLR_L(J)%K, & BLR_L(J)%ISLR, BLR_L(I)%M, BLR_L(I)%N, BLR_L(I)%K, & BLR_L(I)%ISLR, MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), .FALSE.) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif END SUBROUTINE SMUMPS_BLR_UPDATE_TRAILING_LDLT SUBROUTINE SMUMPS_BLR_SLV_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, JBEG_BLOCK, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA, LA_BLOCFACTO REAL, intent(inout) :: A(LA) REAL, intent(in) :: A_BLOCFACTO(LA_BLOCFACTO) INTEGER(8), intent(in) :: POSELT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), TOL_OPT, & MAXI_CLUSTER, LD_BLOCFACTO, & JBEG_BLOCK INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS, & ISHIFT_LM, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS REAL, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM), & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_LM, NB_BLOCKS_PANEL_LS, J, MID_RANK LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER(8) :: POSELTT REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) NB_BLOCKS_PANEL_LM = NB_BLR_LM-CURRENT_BLR_LM NB_BLOCKS_PANEL_LS = NB_BLR_LS-CURRENT_BLR_LS OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_LS*NB_BLOCKS_PANEL_LM) IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_BLOCKS_PANEL_LM+1 J = IBIS - (I-1)*NB_BLOCKS_PANEL_LM #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT & + int(NCOL,8) * & int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8) & + int((BEGS_BLR_LM(CURRENT_BLR_LM+J)+ISHIFT_LM-1),8) CALL SMUMPS_LRGEMM4(MONE, & BLR_LM(J), BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A_BLOCFACTO, LD_DIAG=LD_BLOCFACTO, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_LM(J)%M, BLR_LM(J)%N, BLR_LM(J)%K, & BLR_LM(J)%ISLR, BLR_LS(I)%M, BLR_LS(I)%N, BLR_LS(I)%K, & BLR_LS(I)%ISLR, MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., .FALSE.) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO IF (IFLAG.LT.0) RETURN IF (JBEG_BLOCK.NE.1) RETURN !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, MID_RANK, OMP_NUM, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_LS*(NB_BLOCKS_PANEL_LS+1)/2) IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT & + int(NCOL,8) * & int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8) & + int((NCOL-NROW+(BEGS_BLR_LS(CURRENT_BLR_LS+J)-1)),8) CALL SMUMPS_LRGEMM4(MONE, & BLR_LS(J),BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A_BLOCFACTO, LD_DIAG=LD_BLOCFACTO, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_LS(J)%M, BLR_LS(J)%N, BLR_LS(J)%K, & BLR_LS(J)%ISLR, BLR_LS(I)%M, BLR_LS(I)%N, BLR_LS(I)%K, & BLR_LS(I)%ISLR, MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), .FALSE.) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif RETURN END SUBROUTINE SMUMPS_BLR_SLV_UPD_TRAIL_LDLT SUBROUTINE SMUMPS_BLR_UPD_NELIM_VAR_U( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_U, NB_BLR, & FIRST_BLOCK, IBEG_BLR, NPIV, NELIM) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & IBEG_BLR, NPIV, NELIM, FIRST_BLOCK INTEGER, intent(inout) :: IFLAG, IERROR REAL, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(:) INTEGER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: IP INTEGER :: allocok INTEGER(8) :: LPOS, UPOS REAL, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) IF (NELIM.NE.0) THEN LPOS = POSELT + int(NFRONT,8)*int(NPIV,8) + int(IBEG_BLR-1,8) #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(LRB, UPOS) #endif DO IP = FIRST_BLOCK, NB_BLR IF (IFLAG.LT.0) CYCLE LRB => BLR_U(IP-CURRENT_BLR) UPOS = POSELT + int(NFRONT,8)*int(NPIV,8) & + int(BEGS_BLR(IP)-1,8) IF (LRB%ISLR) THEN IF (LRB%K.GT.0) THEN allocate(TEMP_BLOCK( LRB%K, NELIM ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * LRB%K GOTO 100 ENDIF CALL sgemm('N', 'N', LRB%K, NELIM, LRB%N, ONE, & LRB%R(1,1), LRB%K, A(LPOS), NFRONT, & ZERO, TEMP_BLOCK, LRB%K) CALL sgemm('N', 'N', LRB%M, NELIM, LRB%K, MONE, & LRB%Q(1,1), LRB%M, TEMP_BLOCK, LRB%K, & ONE, A(UPOS), NFRONT) deallocate(TEMP_BLOCK) ENDIF ELSE CALL sgemm('N', 'N', LRB%M, NELIM, LRB%N, MONE, & LRB%Q(1,1), LRB%M, A(LPOS), NFRONT, & ONE, A(UPOS), NFRONT) ENDIF 100 CONTINUE ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO #endif ENDIF END SUBROUTINE SMUMPS_BLR_UPD_NELIM_VAR_U SUBROUTINE SMUMPS_BLR_UPD_NELIM_VAR_L( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA_U, LA_L INTEGER(8), intent(in) :: UPOS, LPOS INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR, & NELIM, FIRST_BLOCK CHARACTER(len=1),INTENT(IN) :: UTRANS INTEGER, intent(inout) :: IFLAG, IERROR REAL, TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U) TYPE(LRB_TYPE),intent(in) :: BLR_L(:) INTEGER :: BEGS_BLR_L(:) INTEGER :: I, NB_BLOCKS_PANEL_L, KL, ML, NL INTEGER :: allocok INTEGER(8) :: IPOS REAL, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR IF (NELIM.NE.0) THEN #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(KL, ML, NL, IPOS) #endif DO I = FIRST_BLOCK-CURRENT_BLR, NB_BLOCKS_PANEL_L IF (IFLAG.LT.0) CYCLE KL = BLR_L(I)%K ML = BLR_L(I)%M NL = BLR_L(I)%N IPOS = LPOS + int(LDL,8) * & int(BEGS_BLR_L(CURRENT_BLR+I)-BEGS_BLR_L(CURRENT_BLR+1),8) IF (BLR_L(I)%ISLR) THEN IF (KL.GT.0) THEN allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * KL write(*,*) 'Allocation problem in BLR routine & SMUMPS_BLR_UPD_NELIM_VAR_L: ', & 'not enough memory? memory requested = ', IERROR GOTO 100 ENDIF CALL sgemm(UTRANS , 'T' , NELIM, KL, NL , ONE , & A_U(UPOS) , LDU , BLR_L(I)%R(1,1) , KL , & ZERO , TEMP_BLOCK , NELIM) CALL sgemm('N' , 'T' , NELIM , ML , KL , MONE , & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , & ONE , A_L(IPOS) , LDL) deallocate(TEMP_BLOCK) ENDIF ELSE CALL sgemm(UTRANS , 'T' , NELIM, ML, NL , MONE , & A_U(UPOS) , LDU , BLR_L(I)%Q(1,1) , ML , & ONE , A_L(IPOS) , LDL) ENDIF 100 CONTINUE ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO #endif ENDIF END SUBROUTINE SMUMPS_BLR_UPD_NELIM_VAR_L SUBROUTINE SMUMPS_BLR_UPDATE_TRAILING( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, & CURRENT_BLR, & NELIM, NIV, SYM, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT REAL, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(:) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(:) INTEGER :: BEGS_BLR_L(:), BEGS_BLR_U(:) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_L, NB_BLOCKS_PANEL_U, & KL, ML, NL, J, IS, MID_RANK INTEGER :: allocok LOGICAL :: BUILDQ INTEGER :: IBIS #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB, POSELT_TOP REAL, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR NB_BLOCKS_PANEL_U = NB_BLR_U-CURRENT_BLR IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS = 0 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif IF (NELIM.NE.0) THEN DO I = 1, NB_BLOCKS_PANEL_L KL = BLR_L(I)%K ML = BLR_L(I)%M NL = BLR_L(I)%N IF (BLR_L(I)%ISLR) THEN IF (KL.GT.0) THEN allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * KL GOTO 100 ENDIF POSELT_TOP = POSELT & + int(NFRONT,8) * int((BEGS_BLR_U(CURRENT_BLR)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1,8) POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) CALL sgemm('N' , 'T' , NELIM, KL, NL , ONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%R(1,1) , KL , & ZERO , TEMP_BLOCK , NELIM) CALL sgemm('N' , 'T' , NELIM , ML , KL , MONE , & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) deallocate(TEMP_BLOCK) ENDIF ELSE POSELT_TOP = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1, 8) CALL sgemm('N' , 'T' , NELIM, ML, NL , MONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) ENDIF ENDDO ENDIF 100 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 200 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELT_INCB, MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_L*NB_BLOCKS_PANEL_U) IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_BLOCKS_PANEL_U+1 J = IBIS - (I-1)*NB_BLOCKS_PANEL_U POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+J) +IS - 1,8) CALL SMUMPS_LRGEMM4(MONE, BLR_U(J), & BLR_L(I), ONE, A, LA, POSELT_INCB, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT, MID_RANK, BUILDQ, .FALSE.) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_U(J)%M, BLR_U(J)%N, BLR_U(J)%K, & BLR_U(J)%ISLR, BLR_L(I)%M, BLR_L(I)%N, BLR_L(I)%K, & BLR_L(I)%ISLR, MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., .FALSE.) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif 200 CONTINUE END SUBROUTINE SMUMPS_BLR_UPDATE_TRAILING SUBROUTINE SMUMPS_BLR_UPD_PANEL_LEFT_LDLT( & A, LA, POSELT, NFRONT, IWHANDLER, & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, IW2, BLOCK, ACC_LUA, & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, & KEEP8, & FIRST_BLOCK & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS, & CURRENT_BLR, IWHANDLER, TOL_OPT, & NELIM, NIV, K480, K479, K478, & MAXI_CLUSTER, MAXI_RANK, & KPERCENT_LUA, KPERCENT REAL, intent(inout) :: A(LA) INTEGER, intent(in) :: IW2(*) REAL :: BLOCK(MAXI_CLUSTER,*) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:) INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB REAL,intent(in) :: TOLEPS INTEGER,intent(inout) :: IFLAG, IERROR INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK TYPE(LRB_TYPE), POINTER :: BLR_L(:), NEXT_BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES, & I, II, J, JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX, & MAXRANK, NB_DEC, FR_RANK INTEGER :: MID_RANK, allocok INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) LOGICAL :: BUILDQ, COMPRESSED_FR INTEGER :: OFFSET_IW INTEGER :: OMP_NUM #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB, POSELTD REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR ACC_LRB => ACC_LUA(1) IF (K480.GE.5) THEN IF (NB_BLOCKS_PANEL.GT.1) THEN CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & CURRENT_BLR+1, NEXT_BLR_L) ENDIF IF (.not.(present(FIRST_BLOCK))) THEN write(*,*) "Internal error in & SMUMPS_BLR_UPD_PANEL_LEFT_LDLT: KEEP(480)=",K480, & ">= 5, but FIRST_BLOCK argument is missing" CALL MUMPS_ABORT() ENDIF ENDIF OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ, K_MAX, !$OMP& BLR_L, OMP_NUM, J_ORDER, J_RANK, !$OMP& IND_U, IND_L, ACC_LRB, POSELTD, NB_DEC, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, COMPRESSED_FR, FR_RANK, II, OFFSET_IW) #endif DO I = 1, NB_BLOCKS_PANEL #if ! defined(BLR_NOOPENMP) IF (IFLAG.LT.0) CYCLE OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR(CURRENT_BLR+1)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+I+1)-BEGS_BLR(CURRENT_BLR+I) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 COMPRESSED_FR = .FALSE. IF (K480.EQ.2) THEN DO J = 1, CURRENT_BLR J_ORDER(J) = J ENDDO ELSE CALL SMUMPS_GET_LUA_ORDER(CURRENT_BLR, J_ORDER, J_RANK, & IWHANDLER, & 1, 0, I, 0, & FRFR_UPDATES) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL SMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF ENDIF NB_DEC = FRFR_UPDATES DO JJ = 1, CURRENT_BLR J = J_ORDER(JJ) K_MAX = J_RANK(JJ) POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(J)-1,8) & + int(BEGS_BLR(J) - 1,8) OFFSET_IW = BEGS_BLR(J) IND_L = CURRENT_BLR+I-J IND_U = CURRENT_BLR+1-J CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & J, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = JJ-1 CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL SMUMPS_LRGEMM4(MONE, & BLR_L(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_INCB, & NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=0, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, & IW2=IW2(OFFSET_IW), & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_L(IND_U)%M, BLR_L(IND_U)%N, & BLR_L(IND_U)%K, BLR_L(IND_U)%ISLR, BLR_L(IND_L)%M, & BLR_L(IND_L)%N, BLR_L(IND_L)%K, BLR_L(IND_L)%ISLR, & MIDBLK_COMPRESS, MID_RANK, BUILDQ, (I.EQ.1), (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN J_RANK(JJ) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN IF (ACC_LRB%K.GT.0) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (JJ.EQ.FRFR_UPDATES) THEN CALL SMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K IF (COMPRESSED_FR) THEN J_RANK(JJ) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) ELSE allocate(POS_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,CURRENT_BLR POS_LIST(II+1)=POS_LIST(II)+J_RANK(II-1) ENDDO allocate(RANK_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,CURRENT_BLR+1 RANK_LIST(II) = J_RANK(II-1) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & CURRENT_BLR+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = floor(real(ACC_LRB%M*ACC_LRB%N)/real(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ALLOC_LRB_FROM_ACC(ACC_LRB, NEXT_BLR_L(I-1), & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, 0, & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE ACC_LRB%K = 0 ELSE IF (I.NE.1) NEXT_BLR_L(I-1)%ISLR=.FALSE. CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) ENDIF ENDIF 100 CONTINUE ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif END SUBROUTINE SMUMPS_BLR_UPD_PANEL_LEFT_LDLT SUBROUTINE SMUMPS_BLR_UPD_PANEL_LEFT( & A, LA, POSELT, NFRONT, IWHANDLER, LorU, & BEGS_BLR, BEGS_BLR_U, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, NIV, SYM, & LBANDSLAVE, IFLAG, IERROR, ISHIFT, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, & MAXI_CLUSTER, MAXI_RANK, & K474, FSorCB, BLR_U_COL, KEEP8, & FIRST_BLOCK, BEG_I_IN, END_I_IN) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS, & CURRENT_BLR, IWHANDLER, LorU, & NELIM, NIV, SYM, K480, K479, K478, & MAXI_CLUSTER, MAXI_RANK, & KPERCENT_LUA, KPERCENT, ISHIFT, & K474, FSorCB LOGICAL, intent(in) :: LBANDSLAVE REAL, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:) INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT REAL,intent(in) :: TOLEPS INTEGER,intent(inout) :: IFLAG, IERROR INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:), NEXT_BLR(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES, & NB_DEC, FR_RANK, MAXRANK, BEG_I, END_I INTEGER :: I,II,J,JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX INTEGER :: MID_RANK, allocok INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) LOGICAL :: BUILDQ, COMPRESSED_FR #if ! defined(BLR_NOOPENMP) INTEGER :: OMP_NUM INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) IF (NIV.EQ.2.AND.LorU.EQ.0) THEN IF (LBANDSLAVE) THEN NB_BLOCKS_PANEL = NB_BLR ELSE NB_BLOCKS_PANEL = NPARTSASS-CURRENT_BLR ENDIF ELSE NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR ENDIF ACC_LRB => ACC_LUA(1) IF (K480.GE.5) THEN IF (NB_BLOCKS_PANEL.GT.1) THEN CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & LorU, & CURRENT_BLR+1, NEXT_BLR) ENDIF IF (.not.(present(FIRST_BLOCK))) THEN write(*,*) "Internal error in & SMUMPS_BLR_UPD_PANEL_LEFT: KEEP(480)=",K480, & ">=5, but FIRST_BLOCK argument is missing" CALL MUMPS_ABORT() ENDIF ENDIF IF (LorU.EQ.0) THEN BEG_I = 1 ELSE BEG_I = 2 ENDIF END_I = NB_BLOCKS_PANEL IF (K474.EQ.3) THEN IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN - CURRENT_BLR ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN - CURRENT_BLR ENDIF ENDIF #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ, !$OMP& BLR_U, BLR_L, J_ORDER, J_RANK, K_MAX, !$OMP& IND_U, IND_L, OMP_NUM, ACC_LRB, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, FR_RANK, COMPRESSED_FR) #endif DO I = BEG_I, END_I IF (IFLAG.LT.0) CYCLE #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif IF (LorU.EQ.0) THEN IF (LBANDSLAVE) THEN POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(I+1)-1),8) & + int(BEGS_BLR_U(2)+ISHIFT-1,8) ACC_LRB%N = BEGS_BLR(I+2)-BEGS_BLR(I+1) ACC_LRB%M = BEGS_BLR_U(3)-BEGS_BLR_U(2) IF (K474.GE.2) THEN BLR_U => BLR_U_COL ENDIF ELSE POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR(CURRENT_BLR+1)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+I+1) & -BEGS_BLR(CURRENT_BLR+I) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) ENDIF ELSE POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+1)-1),8) & + int(BEGS_BLR(CURRENT_BLR+I)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+I+1)-BEGS_BLR(CURRENT_BLR+I) ENDIF MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 COMPRESSED_FR = .FALSE. IF (K480.EQ.2) THEN DO J = 1, CURRENT_BLR J_ORDER(J) = J ENDDO ELSE CALL SMUMPS_GET_LUA_ORDER(CURRENT_BLR, J_ORDER, J_RANK, & IWHANDLER, & 0, 0, I, LorU, & FRFR_UPDATES, & LBANDSLAVE, K474, BLR_U_COL) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL SMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, LorU, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF ENDIF NB_DEC = FRFR_UPDATES DO JJ = 1, CURRENT_BLR J = J_ORDER(JJ) K_MAX = J_RANK(JJ) IF (LorU.EQ.0) THEN IF (LBANDSLAVE) THEN IND_L = I IF (K474.LT.2) THEN IND_U = CURRENT_BLR+1-J ELSE IND_U = J ENDIF ELSE IND_L = CURRENT_BLR+I-J IND_U = CURRENT_BLR+1-J ENDIF ELSE IND_L = CURRENT_BLR+1-J IND_U = CURRENT_BLR+I-J ENDIF CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & J, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (.NOT.LBANDSLAVE.OR.K474.LT.2) THEN CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, & J, BLR_U) ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = JJ-1 CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL SMUMPS_LRGEMM4(MONE, & BLR_U(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_INCB, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=LorU, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER & ) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_U(IND_U)%M, BLR_U(IND_U)%N, & BLR_U(IND_U)%K, BLR_U(IND_U)%ISLR, BLR_L(IND_L)%M, & BLR_L(IND_L)%N, BLR_L(IND_L)%K, BLR_L(IND_L)%ISLR, & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN J_RANK(JJ) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (JJ.EQ.FRFR_UPDATES) THEN CALL SMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, LorU, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K IF (COMPRESSED_FR) THEN J_RANK(JJ) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF ENDIF ENDIF ENDIF ENDDO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) ELSE allocate(POS_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,CURRENT_BLR POS_LIST(II+1)=POS_LIST(II)+J_RANK(II-1) ENDDO allocate(RANK_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,CURRENT_BLR+1 RANK_LIST(II) = J_RANK(II-1) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & CURRENT_BLR+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(REAL(ACC_LRB%M*ACC_LRB%N)/REAL(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ALLOC_LRB_FROM_ACC(ACC_LRB, NEXT_BLR(I-1), & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, LorU, & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE ACC_LRB%K = 0 ELSE IF (I.NE.1) NEXT_BLR(I-1)%ISLR=.FALSE. CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) ENDIF ENDIF 100 CONTINUE ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO NOWAIT #endif END SUBROUTINE SMUMPS_BLR_UPD_PANEL_LEFT SUBROUTINE SMUMPS_BLR_UPD_CB_LEFT_LDLT(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR_DYN, NB_INCB, NB_INASM, NASS, & IWHANDLER, & IW2, BLOCK, ACC_LUA, & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, KEEP8) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_INCB, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & MAXI_RANK, K480, K479, K478, NASS, & KPERCENT_LUA, KPERCENT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER, DIMENSION(:) :: BEGS_BLR_DYN REAL, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, intent(in) :: IW2(*) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT REAL,intent(in) :: TOLEPS INTEGER :: M, N, allocok INTEGER :: I, II, J, K, KK, IND_L, IND_U, K_MAX, IBIS, & K_ORDER(NB_INASM), K_RANK(NB_INASM), NB_DEC INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) INTEGER(8) :: POSELT_BLOCK, POSELTD INTEGER :: MID_RANK, FRFR_UPDATES, MAXRANK, FR_RANK LOGICAL :: BUILDQ, COMPRESSED_FR TYPE(LRB_TYPE), POINTER :: BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK INTEGER :: OFFSET_IW INTEGER :: OMP_NUM #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) ACC_LRB => ACC_LUA(1) OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ, !$OMP& BLR_L, IND_U, IND_L, M, N, K_ORDER, K_RANK, !$OMP& K_MAX, OMP_NUM, ACC_LRB, POSELTD, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, FR_RANK, NB_DEC, II) #endif DO IBIS = 1,NB_INCB*(NB_INCB+1)/2 IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 I = I+NB_INASM J = J+NB_INASM #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 M = BEGS_BLR(I+1)-BEGS_BLR(I) N = BEGS_BLR(J+1)-BEGS_BLR(J) POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR(J)-1,8) ACC_LRB%M = N ACC_LRB%N = M IF (K480.EQ.2) THEN DO K = 1, NB_INASM K_ORDER(K) = K ENDDO ELSE CALL SMUMPS_GET_LUA_ORDER(NB_INASM, K_ORDER, K_RANK, & IWHANDLER, & 1, 1, I, J, & FRFR_UPDATES) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.J)) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL SMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) FR_RANK = ACC_LRB%K MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K ENDIF ENDIF NB_DEC = FRFR_UPDATES DO KK = 1, NB_INASM K = K_ORDER(KK) K_MAX = K_RANK(KK) POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR_DYN(K)-1,8) & + int(BEGS_BLR_DYN(K) - 1,8) OFFSET_IW = BEGS_BLR_DYN(K) IND_L = I-K IND_U = J-K CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & K, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = KK-1 CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, 2) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL SMUMPS_LRGEMM4(MONE, & BLR_L(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_BLOCK, & NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=2, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, & IW2=IW2(OFFSET_IW), & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_L(IND_U)%M, BLR_L(IND_U)%N, & BLR_L(IND_U)%K, BLR_L(IND_U)%ISLR, BLR_L(IND_L)%M, & BLR_L(IND_L)%N, BLR_L(IND_L)%K, BLR_L(IND_L)%ISLR, & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN K_RANK(KK) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN IF (ACC_LRB%K.GT.0) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.J)) THEN IF (KK.EQ.FRFR_UPDATES) THEN CALL SMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) IF (COMPRESSED_FR) THEN K_RANK(KK) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF END DO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) ELSE allocate(POS_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,NB_INASM POS_LIST(II+1)=POS_LIST(II)+K_RANK(II-1) ENDDO allocate(RANK_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,NB_INASM+1 RANK_LIST(II) = K_RANK(II-1) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & NB_INASM+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(REAL(ACC_LRB%M*ACC_LRB%N)/REAL(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2, & COUNT_FLOPS=.FALSE.) ELSE CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & KEEP8, NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ENDIF 100 CONTINUE END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif END SUBROUTINE SMUMPS_BLR_UPD_CB_LEFT_LDLT SUBROUTINE SMUMPS_BLR_UPD_CB_LEFT(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_INCB, NB_INASM, NASS, & IWHANDLER, NIV, LBANDSLAVE, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & ACC_LUA, K480, K479, K478, KPERCENT_LUA, & KPERCENT, & MAXI_CLUSTER, MAXI_RANK, & K474, FSorCB, BLR_U_COL, COMPRESS_CB, CB_LRB, KEEP8) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_ROWS, NB_INCB, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & MAXI_RANK, KPERCENT_LUA, KPERCENT INTEGER, INTENT(IN) :: K480, K479, K478, NASS, K474, & FSorCB INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U #if defined(MUMPS_NOF2003) TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) #else TYPE(LRB_TYPE), POINTER, intent(inout) :: CB_LRB(:,:) #endif TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:) INTEGER(8) :: KEEP8(150) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT REAL,intent(in) :: TOLEPS LOGICAL, intent(in) :: LBANDSLAVE, COMPRESS_CB INTEGER :: M, N, allocok INTEGER :: I, II, J, K, KK, IND_L, IND_U, IBIS, & K_ORDER(NB_INASM), K_RANK(NB_INASM) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) INTEGER(8) :: POSELT_BLOCK INTEGER :: MID_RANK, K_MAX, FRFR_UPDATES, NB_DEC LOGICAL :: BUILDQ, COMPRESSED_FR TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB, LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, MAXRANK, & FR_RANK #if ! defined(BLR_NOOPENMP) INTEGER :: OMP_NUM INTEGER :: CHUNK #endif REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) ACC_LRB => ACC_LUA(1) #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ, !$OMP& BLR_U, BLR_L, IND_U, IND_L, M, N, !$OMP& ACC_LRB, OMP_NUM, K_MAX, K_ORDER, K_RANK, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, LRB) #endif DO IBIS = 1,NB_ROWS*NB_INCB IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_INCB+1 J = IBIS - (I-1)*NB_INCB IF (.NOT.LBANDSLAVE) THEN I = I+NB_INASM ENDIF J = J+NB_INASM #if ! defined(BLR_NOOPENMP) OMP_NUM=0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 IF (LBANDSLAVE) THEN M = BEGS_BLR(I+2)-BEGS_BLR(I+1) IF (K474.EQ.1) THEN POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I+1)-1,8) & +int(NASS,8) + int(BEGS_BLR_U(J-NB_INASM+1)-1,8) N = BEGS_BLR_U(J-NB_INASM+2)-BEGS_BLR_U(J-NB_INASM+1) ELSEIF (K474.GE.2) THEN BLR_U => BLR_U_COL POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I+1)-1,8) & + int(NASS-1,8) N = BEGS_BLR_U(3)-BEGS_BLR_U(2) ELSE write(*,*) 'Internal error in SMUMPS_BLR_UPD_CB_LEFT', & LBANDSLAVE,K474 CALL MUMPS_ABORT() ENDIF ELSE M = BEGS_BLR(I+1)-BEGS_BLR(I) POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR_U(J)-1,8) N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ENDIF ACC_LRB%M = N ACC_LRB%N = M IF (K480.EQ.2) THEN DO K = 1, NB_INASM K_ORDER(K) = K ENDDO ELSE CALL SMUMPS_GET_LUA_ORDER(NB_INASM, K_ORDER, K_RANK, & IWHANDLER, & 0, 1, I, J, & FRFR_UPDATES, & LBANDSLAVE, K474, BLR_U_COL) ENDIF COMPRESSED_FR = .FALSE. FR_RANK = 0 DO KK = 1, NB_INASM IF ((K480.GE.5.OR.COMPRESS_CB).AND.I.NE.J) THEN IF (KK-1.EQ.FRFR_UPDATES) THEN CALL SMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) IF (COMPRESSED_FR) THEN K_RANK(KK) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF K = K_ORDER(KK) K_MAX = K_RANK(KK) IF (LBANDSLAVE) THEN IND_L = I IF (K474.LT.2) THEN IND_U = J-K ELSE IND_U = K ENDIF ELSE IND_L = I-K IND_U = J-K ENDIF CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & K, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (.NOT.LBANDSLAVE.OR.K474.LT.2) THEN CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, & K, BLR_U) ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN COMPRESSED_FR = .FALSE. NB_DEC = KK-1 CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, 2) MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL SMUMPS_LRGEMM4(MONE, & BLR_U(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_BLOCK, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=2, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_U(IND_U)%M, BLR_U(IND_U)%N, & BLR_U(IND_U)%K, BLR_U(IND_U)%ISLR, BLR_L(IND_L)%M, & BLR_L(IND_L)%N, BLR_L(IND_L)%K, BLR_L(IND_L)%ISLR, & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN K_RANK(KK) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF END DO IF (K480.GE.3) THEN IF (K480.GE.5.OR.COMPRESS_CB) THEN IF (K480.GE.5.AND.(COMPRESSED_FR.OR.K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) ELSE allocate(POS_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,NB_INASM POS_LIST(II+1)=POS_LIST(II)+K_RANK(II-1) ENDDO allocate(RANK_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,NB_INASM+1 RANK_LIST(II) = K_RANK(II-1) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & NB_INASM+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(REAL(ACC_LRB%M*ACC_LRB%N)/REAL(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN LRB => CB_LRB(I-NB_INASM,J-NB_INASM) CALL ALLOC_LRB_FROM_ACC(ACC_LRB, LRB, & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, 0, & IFLAG, IERROR, KEEP8) CALL UPD_MRY_CB_LRGAIN(LRB%M, LRB%N, LRB%K & ) ACC_LRB%K = 0 IF (IFLAG.LT.0) GOTO 100 ELSE CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) LRB => CB_LRB(I-NB_INASM,J-NB_INASM) CALL ALLOC_LRB(LRB, ACC_LRB%K, ACC_LRB%N, ACC_LRB%M, & .FALSE., IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 100 DO II=1,ACC_LRB%N LRB%Q(II,1:ACC_LRB%M) = & A( POSELT_BLOCK+int((II-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((II-1),8)*int(NFRONT,8) & +int(ACC_LRB%M-1,8) ) END DO ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & KEEP8,NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ENDIF 100 CONTINUE END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF (COMPRESS_CB) THEN CALL UPD_MRY_CB_FR(NFRONT-NASS, NFRONT-NASS, 0) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER #endif END SUBROUTINE SMUMPS_BLR_UPD_CB_LEFT SUBROUTINE SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, DECOMP_TIMER, & BEG_I_IN, END_I_IN, ONLY_NELIM_IN & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: COPY_DENSE_BLOCKS INTEGER, intent(in) :: NB_BLR, CURRENT_BLR INTEGER, intent(in) :: BEGS_BLR_DIAG, & BEGS_BLR_FIRST_OFFDIAG TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(:) CHARACTER(len=1) :: DIR INTEGER, intent(in) :: LDA11, LDA21 INTEGER, intent(in) :: DECOMP_TIMER INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN, ONLY_NELIM_IN INTEGER :: IP, M, N, BIP, BIP_START, BEG_I, END_I, ONLY_NELIM #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER :: K, I DOUBLE PRECISION :: PROMOTE_COST INTEGER(8) :: POSELT_BLOCK, LD_BLK_IN_FRONT REAL :: ONE, ALPHA, ZERO PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) PARAMETER (ZERO = 0.0E0) IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN ELSE BEG_I = CURRENT_BLR+1 ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN ELSE END_I = NB_BLR ENDIF IF(present(ONLY_NELIM_IN)) THEN ONLY_NELIM = ONLY_NELIM_IN ELSE ONLY_NELIM = 0 ENDIF LD_BLK_IN_FRONT = int(LDA11,8) BIP_START = BEGS_BLR_FIRST_OFFDIAG IF (BEG_I .NE. CURRENT_BLR+1) THEN DO I = 1, BEG_I - CURRENT_BLR - 1 BIP_START = BIP_START + BLR_PANEL(I)%M ENDDO ENDIF #if defined(BLR_NOOPENMP) BIP = BIP_START #endif #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC, CHUNK) #endif DO IP = BEG_I, END_I #if ! defined(BLR_NOOPENMP) BIP = BIP_START DO I = BEG_I, IP-1 BIP = BIP + BLR_PANEL(I-CURRENT_BLR)%M ENDDO #endif IF (DIR .eq. 'V') THEN IF (BIP .LE. LDA21) THEN POSELT_BLOCK = POSELT + int(LDA11,8)*int(BIP-1,8) + & int(BEGS_BLR_DIAG - 1,8) ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(LDA21,8)+ & int(BEGS_BLR_DIAG - 1,8) POSELT_BLOCK = POSELT_BLOCK + & int(LDA21,8)*int(BIP-1-LDA21,8) LD_BLK_IN_FRONT=int(LDA21,8) ENDIF ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(BEGS_BLR_DIAG-1,8) & + int(BIP-1,8) ENDIF M = BLR_PANEL(IP-CURRENT_BLR)%M N = BLR_PANEL(IP-CURRENT_BLR)%N IF(present(ONLY_NELIM_IN)) THEN ONLY_NELIM = ONLY_NELIM_IN ELSE ONLY_NELIM = N ENDIF K = BLR_PANEL(IP-CURRENT_BLR)%K IF (BLR_PANEL(IP-CURRENT_BLR)%ISLR) THEN IF (K.EQ.0) THEN IF (DIR .eq. 'V') THEN DO I = 1, M IF (BIP+I-1.GT.LDA21) THEN LD_BLK_IN_FRONT = int(LDA21,8) ENDIF A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT & + int(N-1,8)) = ZERO ENDDO ELSE DO I = N-ONLY_NELIM+1, N A(POSELT_BLOCK+int(I-1,8)*int(LDA11,8): & POSELT_BLOCK+int(I-1,8)*int(LDA11,8) + int(M-1,8)) & = ZERO ENDDO ENDIF GOTO 1800 ENDIF IF (DIR .eq. 'V') THEN IF (DIR .eq.'V' .AND. BIP .LE. LDA21 & .AND. BIP + M - 1 .GT. LDA21) THEN CALL sgemm('T', 'T', N, LDA21-BIP+1, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) CALL sgemm('T', 'T', N, BIP+M-LDA21-1, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(LDA21-BIP+2,1) , M, & ZERO, A(POSELT_BLOCK+int(LDA21-BIP,8)*int(LDA11,8)), & LDA21) ELSE CALL sgemm('T', 'T', N, M, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) ENDIF ELSE CALL sgemm('N', 'N', M, ONLY_NELIM, K, ONE, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1), M, & BLR_PANEL(IP-CURRENT_BLR)%R(1,N-ONLY_NELIM+1), K, ZERO, & A(POSELT_BLOCK+int(N-ONLY_NELIM,8)*int(LDA11,8)), LDA11) ENDIF PROMOTE_COST = 2.0D0*M*K*ONLY_NELIM IF(present(ONLY_NELIM_IN)) THEN CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .FALSE.) ENDIF ELSE IF (COPY_DENSE_BLOCKS) THEN IF (DIR .eq. 'V') THEN DO I = 1, M IF (BIP+I-1.GT.LDA21) THEN LD_BLK_IN_FRONT = int(LDA21,8) ENDIF A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT & + int(N-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N) ENDDO ELSE DO I = N-ONLY_NELIM+1, N A(POSELT_BLOCK+int(I-1,8)*int(LDA11,8): & POSELT_BLOCK+int(I-1,8)*int(LDA11,8) + int(M-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) ENDDO ENDIF ENDIF 1800 CONTINUE #if defined(BLR_NOOPENMP) BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif END SUBROUTINE SMUMPS_DECOMPRESS_PANEL SUBROUTINE SMUMPS_COMPRESS_CB(A, LA, POSELT, LDA, & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY, & NELIM, & NBROWSinF & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & KPERCENT, TOL_OPT, LWORK INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), TARGET, intent(inout) :: CB_LRB(:,:) INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U REAL, TARGET, DIMENSION(:) :: RWORK REAL, TARGET, DIMENSION(:,:) :: BLOCK REAL, TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER(8) :: KEEP8(150) REAL,intent(in) :: TOLEPS INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500) REAL, OPTIONAL :: M_ARRAY(max(NFS4FATHER,1)) INTEGER, intent(in), OPTIONAL :: NELIM INTEGER, intent(in), OPTIONAL :: NBROWSinF INTEGER :: M, N, INFO INTEGER :: I, J, IBIS, IBIS_END, RANK, MAXRANK, II, JJ INTEGER(8) :: POSELT_BLOCK LOGICAL :: ISLR TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: OMP_NUM INTEGER(8) :: POSA, ASIZE INTEGER :: NROWS_CM #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif REAL, POINTER, DIMENSION(:) :: RWORK_THR REAL, POINTER, DIMENSION(:,:) :: BLOCK_THR REAL, POINTER, DIMENSION(:) :: WORK_THR, TAU_THR INTEGER, POINTER, DIMENSION(:) :: JPVT_THR REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & (NFS4FATHER.GT.0) ) THEN IF (NIV.EQ.1) THEN NROWS_CM = NROWS - (NFS4FATHER-NELIM) ELSE NROWS_CM = NROWS - NBROWSinF ENDIF IF (NROWS_CM-NVSCHUR_K253.GT.0) THEN IF (NIV.EQ.1) THEN POSA = POSELT & + int(LDA,8)*int(NPIV+NFS4FATHER,8) & + int(NPIV,8) ASIZE = int(LDA,8)*int(LDA,8) & - int(LDA,8)*int(NPIV+NFS4FATHER,8) & - int(NPIV,8) ELSE POSA = POSELT & + int(LDA,8)*int(NBROWSinF,8) & + int(NPIV,8) ASIZE = int(NROWS,8)*int(LDA,8) & - int(LDA,8)*int(NBROWSinF,8) & - int(NPIV,8) ENDIF CALL SMUMPS_COMPUTE_MAXPERCOL ( & A(POSA), ASIZE, LDA, & NROWS_CM-NVSCHUR_K253, & M_ARRAY(1), NFS4FATHER, .FALSE., & -9999) ELSE DO I=1, NFS4FATHER M_ARRAY(I) = ZERO ENDDO ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (SYM.EQ.0.OR.NIV.EQ.2) THEN IBIS_END = NB_ROWS*NB_COLS ELSE IBIS_END = NB_ROWS*(NB_COLS+1)/2 ENDIF #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELT_BLOCK, M, N, OMP_NUM, INFO, RANK, !$OMP& MAXRANK, ISLR, II, JJ, LRB) #endif DO IBIS = 1,IBIS_END IF (IFLAG.LT.0) CYCLE OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) WORK_THR => WORK(OMP_NUM*LWORK+1: & (OMP_NUM+1)*LWORK) RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: & (OMP_NUM+1)*2*MAXI_CLUSTER) IF (SYM.EQ.0.OR.NIV.EQ.2) THEN I = (IBIS-1)/NB_COLS+1 J = IBIS - (I-1)*NB_COLS ELSE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 ENDIF IF (NIV.EQ.1) THEN I = I+NB_INASM J = J+NB_INASM ELSE J = J+NB_INASM IF (SYM.NE.0) THEN IF (BEGS_BLR_U(J).GE.BEGS_BLR(I+2)+NCOLS-NROWS-1+ & BEGS_BLR_U(NB_INASM+1)) THEN CYCLE ENDIF ENDIF ENDIF IF (NIV.EQ.1) THEN M = BEGS_BLR(I+1)-BEGS_BLR(I) POSELT_BLOCK = POSELT + int(LDA,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR_U(J)-1,8) IF (I .EQ. NB_INASM+1 .AND. present(NELIM)) THEN POSELT_BLOCK = POSELT_BLOCK + int(NELIM,8)*int(LDA,8) M = M - NELIM ENDIF N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ELSE M = BEGS_BLR(I+2)-BEGS_BLR(I+1) POSELT_BLOCK = POSELT + int(LDA,8)*int(BEGS_BLR(I+1)-1,8) & + int(BEGS_BLR_U(J)-1,8) IF (SYM.EQ.0) THEN N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ELSE N = min(BEGS_BLR_U(J+1), BEGS_BLR(I+2) + NCOLS - NROWS -1 & + BEGS_BLR_U(NB_INASM+1)) - BEGS_BLR_U(J) ENDIF ENDIF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (NIV.EQ.1) THEN LRB => CB_LRB(I-NB_INASM,J-NB_INASM) ELSE LRB => CB_LRB(I,J-NB_INASM) ENDIF IF (K489.EQ.3) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 ISLR = .FALSE. GOTO 3800 ENDIF DO II=1,M BLOCK_THR(II,1:N)= & A( POSELT_BLOCK+int(II-1,8)*int(LDA,8) : & POSELT_BLOCK+int(II-1,8)*int(LDA,8)+int(N-1,8) ) ENDDO MAXRANK = floor(real(M*N)/real(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL SMUMPS_TRUNCATED_RRQR( M, N, & BLOCK_THR(1,1), & MAXI_CLUSTER, JPVT_THR(1), & TAU_THR(1), & WORK_THR(1), N, & RWORK_THR(1), & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO, & ISLR) 3800 CONTINUE IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A CB BLOCK" CALL MUMPS_ABORT() END IF CALL ALLOC_LRB(LRB, RANK, M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF (ISLR) THEN IF (RANK .GT. 0) THEN DO JJ=1,N DO II=1,MIN(RANK,JJ) LRB%R(II,JPVT_THR(JJ)) = BLOCK_THR(II,JJ) ENDDO IF(JJ.LT.RANK) LRB%R(MIN(RANK,JJ)+1:RANK,JPVT_THR(JJ)) & = ZERO ENDDO CALL sorgqr & (M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & WORK_THR(1), LWORK, INFO ) DO II=1,RANK DO JJ= 1, M LRB%Q(JJ,II) = BLOCK_THR(JJ,II) ENDDO END DO IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNGQR WHILE COMPRESSING A CB BLOCK" CALL MUMPS_ABORT() END IF IF (K489.NE.3) THEN CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, & LRB%ISLR, CB_COMPRESS=.TRUE.) ENDIF END IF CALL UPD_MRY_CB_LRGAIN(LRB%M, LRB%N, LRB%K & ) ELSE DO II=1,M LRB%Q(II,1:N) = & A( POSELT_BLOCK+int((II-1),8)*int(LDA,8) : & POSELT_BLOCK+int((II-1),8)*int(LDA,8) & +int(N-1,8) ) END DO IF (K489.NE.3) THEN CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, & LRB%ISLR, CB_COMPRESS=.TRUE.) ENDIF LRB%K = -1 END IF END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif CALL UPD_MRY_CB_FR(NROWS, NCOLS, SYM) #if ! defined(BLR_NOOPENMP) !$OMP END MASTER #endif END SUBROUTINE SMUMPS_COMPRESS_CB SUBROUTINE SMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K458, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8, & K480, BEG_I_IN, END_I_IN, FRSWAP & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), TARGET, intent(inout) :: BLR_PANEL(:) REAL, TARGET, DIMENSION(:) :: RWORK REAL, TARGET, DIMENSION(:,:) :: BLOCK REAL, TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER :: BEGS_BLR(:) INTEGER(8) :: KEEP8(150) INTEGER, OPTIONAL, intent(in) :: K480 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN LOGICAL, OPTIONAL, intent(in) :: FRSWAP INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, & K458, K473, TOL_OPT LOGICAL, intent(in) :: LBANDSLAVE INTEGER :: MAXI_CLUSTER, LWORK, NELIM REAL,intent(in) :: TOLEPS CHARACTER(len=1) :: DIR INTEGER :: IP, NB_BLOCKS_PANEL, M, N, RANK, MAXRANK INTEGER :: INFO, I, J, K, IS, BEG_I, END_I INTEGER(8) :: POSELT_BLOCK LOGICAL :: ISLR REAL :: ONE, ALPHA, ZERO PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) PARAMETER (ZERO = 0.0D0) TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: OMP_NUM REAL, POINTER, DIMENSION(:) :: RWORK_THR REAL, POINTER, DIMENSION(:,:) :: BLOCK_THR REAL, POINTER, DIMENSION(:) :: WORK_THR, TAU_THR INTEGER, POINTER, DIMENSION(:) :: JPVT_THR #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN ELSE BEG_I = CURRENT_BLR+1 ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN ELSE END_I = NB_BLR ENDIF IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS=0 ENDIF IF (DIR .eq. 'V') THEN IF (LBANDSLAVE) THEN N = NPIV ELSE N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ENDIF ELSE IF (DIR .eq. 'H') THEN N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ELSE WRITE(*,*) " WRONG ARGUMENT IN SMUMPS_COMPRESS_PANEL " CALL MUMPS_ABORT() END IF NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO PRIVATE(INFO, POSELT_BLOCK, RANK, MAXRANK, I, J, OMP_NUM, LRB) !$OMP& SCHEDULE(DYNAMIC,CHUNK) #endif DO IP = BEG_I, END_I IF (IFLAG.LT.0) CYCLE #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) WORK_THR => WORK(OMP_NUM*LWORK+1: & (OMP_NUM+1)*LWORK) RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: & (OMP_NUM+1)*2*MAXI_CLUSTER) LRB => BLR_PANEL(IP-CURRENT_BLR) RANK = 0 M = BEGS_BLR(IP+1)-BEGS_BLR(IP) IF (DIR .eq. 'V') THEN POSELT_BLOCK = POSELT + & int(NFRONT,8) * int(BEGS_BLR(IP)-1,8) + & int(BEGS_BLR(CURRENT_BLR) + IS - 1,8) ELSE POSELT_BLOCK = POSELT + & int(NFRONT,8)*int(BEGS_BLR(CURRENT_BLR)-1,8) + & int( BEGS_BLR(IP) - 1,8) ENDIF IF (present(K480)) then IF (K480.GE.5) THEN IF (LRB%ISLR) THEN IF (M.NE.LRB%M) THEN write(*,*) 'Internal error in SMUMPS_COMPRESS_PANEL', & ' M size inconsistency',M, & LRB%M CALL MUMPS_ABORT() ENDIF IF (N.NE.LRB%N) THEN write(*,*) 'Internal error in SMUMPS_COMPRESS_PANEL', & ' N size inconsistency',N, & LRB%N CALL MUMPS_ABORT() ENDIF MAXRANK = floor(real(M*N)/real(M+N)) IF (LRB%K.GT.MAXRANK) THEN write(*,*) 'Internal error in SMUMPS_COMPRESS_PANEL', & ' MAXRANK inconsistency',MAXRANK, & LRB%K CALL MUMPS_ABORT() ENDIF GOTO 3000 ENDIF ENDIF ENDIF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (K473.EQ.1 .OR. IP .LT. BEG_I+K458) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 ISLR = .FALSE. GOTO 3800 ENDIF IF (DIR .eq. 'V') THEN DO I=1,M BLOCK_THR(I,1:N)= & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(N-1,8) ) END DO ELSE DO I=1,N BLOCK_THR(1:M,I)= & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) END DO END IF MAXRANK = floor(real(M*N)/real(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL SMUMPS_TRUNCATED_RRQR( M, N, & BLOCK_THR(1,1), & MAXI_CLUSTER, JPVT_THR(1), & TAU_THR(1), & WORK_THR(1), N, & RWORK_THR(1), & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO, & ISLR) 3800 CONTINUE IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF CALL ALLOC_LRB(LRB, RANK, & M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF ((M.EQ.0).OR.(N.EQ.0)) THEN GOTO 3000 ENDIF IF (ISLR) THEN IF (RANK .EQ. 0) THEN ELSE DO J=1,N DO K=1,min(RANK,J) LRB%R(K, JPVT_THR(J)) = BLOCK_THR(K,J) ENDDO IF(J.LT.RANK) THEN LRB%R(J+1:RANK,JPVT_THR(J)) = ZERO ENDIF ENDDO CALL sorgqr & (M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & WORK_THR(1), LWORK, INFO ) DO I=1,RANK DO K=1,M LRB%Q(K,I) = BLOCK_THR(K,I) ENDDO END DO IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNGQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF IF (present(FRSWAP)) THEN CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, LRB%ISLR, & FRSWAP=FRSWAP) ELSE CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, LRB%ISLR) ENDIF END IF ELSE IF (DIR .eq. 'V') THEN DO I=1,M LRB%Q(I,1:N) = & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) & +int(N-1,8) ) END DO ELSE DO I=1,N LRB%Q(1:M,I) = & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) & +int(M-1,8) ) END DO END IF IF (K473.EQ.0) THEN IF (present(FRSWAP)) THEN CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, LRB%ISLR, & FRSWAP=FRSWAP) ELSE CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, LRB%ISLR) ENDIF ENDIF LRB%K = -1 END IF 3000 CONTINUE END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO NOWAIT #endif RETURN END SUBROUTINE SMUMPS_COMPRESS_PANEL SUBROUTINE SMUMPS_BLR_PANEL_LRTRSM( & A, & LA, POSELT, NFRONT, & IBEG_BLOCK, NB_BLR, & BLR_LorU, & CURRENT_BLR, FIRST_BLOCK, LAST_BLOCK, & NIV, SYM, LorU, LBANDSLAVE, & IW, OFFSET_IW, NASS) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & NIV, SYM, LorU LOGICAL, intent(in) :: LBANDSLAVE INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: IBEG_BLOCK, FIRST_BLOCK, LAST_BLOCK INTEGER, OPTIONAL, intent(in) :: NASS REAL, intent(inout) :: A(LA) TYPE(LRB_TYPE), intent(inout) :: BLR_LorU(:) INTEGER, OPTIONAL :: OFFSET_IW INTEGER, OPTIONAL :: IW(*) INTEGER(8) :: POSELT_LOCAL INTEGER :: IP, LDA #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) LDA = NFRONT IF (LorU.EQ.0.AND.SYM.NE.0.AND.NIV.EQ.2 & .AND.(.NOT.LBANDSLAVE)) THEN IF (present(NASS)) THEN LDA = NASS ELSE write(*,*) 'Internal error in SMUMPS_BLR_PANEL_LRTRSM' CALL MUMPS_ABORT() ENDIF ENDIF IF (LBANDSLAVE) THEN POSELT_LOCAL = POSELT ELSE POSELT_LOCAL = POSELT + & int(IBEG_BLOCK-1,8)*int(LDA,8) + int(IBEG_BLOCK - 1,8) ENDIF #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO !$OMP& SCHEDULE(DYNAMIC,CHUNK) #endif DO IP = FIRST_BLOCK, LAST_BLOCK CALL SMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA, & BLR_LorU(IP-CURRENT_BLR), NIV, SYM, LorU, & IW, OFFSET_IW) END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO NOWAIT #endif END SUBROUTINE SMUMPS_BLR_PANEL_LRTRSM END MODULE SMUMPS_FAC_LR MUMPS_5.8.1/src/zbcast_int.F0000664000175000017500000000314015042446441015476 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_MCAST2(DATA, LDATA, MPITYPE, ROOT, COMMW, TAG, &SLAVEF, KEEP) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER LDATA, ROOT, COMMW, TAG, MPITYPE, SLAVEF INTEGER DEST INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER DATA(LDATA) DO 10 DEST = 0, SLAVEF - 1 IF (DEST .NE. ROOT) THEN IF ( LDATA .EQ. 1 .and. MPITYPE .EQ. MPI_INTEGER ) THEN CALL MUMPS_BUF_SEND_1INT( DATA(1), DEST, TAG, & COMMW, KEEP, IERR ) ELSE WRITE(*,*) 'Error : bad argument to ZMUMPS_MCAST2' CALL MUMPS_ABORT() END IF ENDIF 10 CONTINUE RETURN END SUBROUTINE ZMUMPS_MCAST2 SUBROUTINE ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) INTEGER MYID, SLAVEF, COMM INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY (1) DUMMY(1) = -98765 CALL ZMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERREUR, SLAVEF, KEEP ) RETURN END SUBROUTINE ZMUMPS_BDC_ERROR MUMPS_5.8.1/src/zfac_asm.F0000664000175000017500000010736315042446441015135 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, NBROWS, NBCOLS, ROWLIST, & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, & OPASSW, IWPOSCB, MYID, KEEP,KEEP8, IS_ofType5or6, & LDA_VALSON, ICOL_BEG ) 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, INTENT(IN) :: ICOL_BEG INTEGER(8) :: POSELT, POSEL1, APOS, JJ2 INTEGER 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 IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS1 = abs(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 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+(ICOL_BEG-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 + ICOL_BEG-1 + 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 = ICOL_BEG, min(DIAG,ICOL_BEG+NBCOLS-1) JJ2 = APOS+int(JJ1-1,8) A(JJ2) = A(JJ2) + VALSON(JJ1-ICOL_BEG+1,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 = ICOL_BEG, min(NELIM, ICOL_BEG+NBCOLS-1) JJ2 = APOS + int(IW(J1+JJ1-1),8)*int(LDAFS_PERE,8) A(JJ2) = A(JJ2) + VALSON(JJ1-ICOL_BEG+1,JJ) ENDDO IBEG = max(NELIM+1,ICOL_BEG) ELSE IBEG = ICOL_BEG ENDIF APOS = POSEL1 + int(ROWLIST(JJ),8) * int(LDAFS_PERE,8) DO JJ1 = IBEG, ICOL_BEG + NBCOLS - 1 IF (ROWLIST(JJ).LT.IW(J1 + JJ1 - 1)) EXIT JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) A(JJ2) = A(JJ2) + VALSON(JJ1-ICOL_BEG+1,JJ) ENDDO ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_ASM_SLAVE_MASTER SUBROUTINE ZMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, INTARR, DBLARR, & ICNTL, KEEP,KEEP8, MYID, LRGROUPS) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID INTEGER NBROWS, NBCOLS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) COMPLEX(kind=8) :: A(LA) INTEGER :: INTARR(KEEP8(27)) COMPLEX(kind=8) :: DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) INTEGER(8) :: POSELT COMPLEX(kind=8), DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL ZMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) IF (NASS.LT.0) THEN NASS = -NASS IW(IOLDPS+1+KEEP(IXSZ)) = NASS CALL ZMUMPS_ASM_SLAVE_ARROWHEADS(INODE, STEP(INODE), & N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, & ITLOC, FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, KEEP8(27), KEEP8(26), & RHS_MUMPS, LRGROUPS) ENDIF IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_ASM_SLAVE_TO_SLAVE_INIT SUBROUTINE ZMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, NBROWS, STEP, PTRIST, & ITLOC, RHS_MUMPS, KEEP,KEEP8) IMPLICIT NONE INTEGER N, LIW INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER INODE INTEGER NBROWS INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INCLUDE 'mumps_headers.h' INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J IOLDPS = PTRIST(STEP(INODE)) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_ASM_SLAVE_TO_SLAVE_END SUBROUTINE ZMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, ROWLIST, COLLIST, VALSON, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, FILS, & ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, LDA_VALSON) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY: ZMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID LOGICAL, intent(in) :: IS_ofType5or6 INTEGER NBROWS, NBCOLS, LDA_VALSON INTEGER ROWLIST(NBROWS), COLLIST(NBCOLS) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRAST(KEEP(28)) COMPLEX(kind=8) A(LA), VALSON(LDA_VALSON,NBROWS) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8) :: POSEL1, POSELT, APOS, K8 INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & I,J,NASS,IDIAG COMPLEX(kind=8), POINTER, DIMENSION(:) :: A_PTR INTEGER(8) :: LA_PTR INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL ZMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) IF ( NBROWS .GT. NBROWF ) THEN WRITE(*,*) ' ERR: ERROR : NBROWS > NBROWF' WRITE(*,*) ' ERR: INODE =', INODE WRITE(*,*) ' ERR: NBROW=',NBROWS,'NBROWF=',NBROWF WRITE(*,*) ' ERR: ROW_LIST=', ROWLIST WRITE(*,*) ' ERR: NBCOLF/NASS=', NBCOLF, NASS CALL MUMPS_ABORT() END IF NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) IF (NBROWS.GT.0) THEN POSEL1 = POSELT - int(NBCOLF,8) IF (KEEP(50).EQ.0) THEN IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) DO I=1, NBROWS DO J = 1, NBCOLS A_PTR(APOS+int(J-1,8)) = A_PTR( APOS+int(J-1,8)) + & VALSON(J,I) ENDDO APOS = APOS + int(NBCOLF,8) END DO ELSE DO I=1,NBROWS APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) DO J=1,NBCOLS K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO ENDDO ENDIF ELSE IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) & + int((NBROWS-1),8)*int(NBCOLF,8) IDIAG = 0 DO I=NBROWS,1,-1 DO J=1,NBCOLS-IDIAG K8 = APOS+int(J-1,8) A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO APOS = APOS - int(NBCOLF,8) IDIAG = IDIAG + 1 ENDDO ELSE DO I=1,NBROWS APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) DO J=1,NBCOLS IF (ITLOC(COLLIST(J)) .EQ. 0) THEN EXIT ENDIF K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO ENDDO ENDIF ENDIF OPASSW = OPASSW + dble(NBROWS*NBCOLS) ENDIF RETURN END SUBROUTINE ZMUMPS_ASM_SLAVE_TO_SLAVE SUBROUTINE ZMUMPS_LDLT_ASM_NIV12_IP( A, LA, & IAFATH, NFRONT, NASS1, & IACB, NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED ) IMPLICIT NONE INTEGER NFRONT, NASS1 INTEGER(8) :: LA INTEGER NCOLS, NROWS, NELIM INTEGER(8) :: LCB COMPLEX(kind=8) A( LA ) INTEGER(8) :: IAFATH, IACB INTEGER IW( NCOLS ) INTEGER ETATASS LOGICAL CB_IS_COMPRESSED COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB, IBEGCBROW, IENDFRONT LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE IENDFRONT = IAFATH+int(NFRONT,8)*int(NFRONT,8)-1_8 IPOSCB=1_8 RESET_TO_ZERO = IACB .LT. IENDFRONT + 1_8 RISK_OF_SAME_POS = IACB + LCB .EQ. IENDFRONT + 1_8 RISK_OF_SAME_POS_THIS_LINE = .FALSE. DO I=1, NROWS POSELT = int(IW(I)-1,8) * int(NFRONT,8) IF (.NOT. CB_IS_COMPRESSED ) THEN IPOSCB = 1_8 + int(I - 1,8) * int(NCOLS,8) IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN RESET_TO_ZERO = .FALSE. ENDIF ENDIF IF ( RISK_OF_SAME_POS ) THEN IF (I.EQ.NROWS .OR. .NOT. CB_IS_COMPRESSED) THEN IF ( IAFATH + POSELT + int(IW(I)-1,8) .EQ. & IACB+IPOSCB+int(I-1-1,8)) THEN RISK_OF_SAME_POS_THIS_LINE = .TRUE. ENDIF ENDIF ENDIF IF (RESET_TO_ZERO) THEN IF ( RISK_OF_SAME_POS_THIS_LINE ) THEN DO J=1, I APOS = POSELT + int(IW( J ),8) IF (IAFATH + APOS - 1_8.NE. IACB+IPOSCB-1_8) THEN A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) A(IACB+IPOSCB-1_8) = ZERO ENDIF IPOSCB = IPOSCB + 1_8 ENDDO ELSE #if defined(__ve__) !NEC$ IVDEP #endif 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 #if defined(__ve__) !NEC$ IVDEP #endif DO J=1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB + 1_8 ENDDO ENDIF IF (.NOT. CB_IS_COMPRESSED ) THEN IBEGCBROW = IACB+IPOSCB-1_8 IF ( IBEGCBROW .LE. IENDFRONT ) THEN A(IBEGCBROW:IBEGCBROW+int(NCOLS-I,8)-1_8)=ZERO ENDIF ENDIF IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN RESET_TO_ZERO = .FALSE. ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_LDLT_ASM_NIV12_IP SUBROUTINE ZMUMPS_LDLT_ASM_NIV12( A, LA, SON_A, & IAFATH, NFRONT, NASS1, & NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED !$ & , K360 & ) IMPLICIT NONE INTEGER NFRONT, NASS1 INTEGER(8) :: LA INTEGER NCOLS, NROWS, NELIM INTEGER(8) :: LCB COMPLEX(kind=8) A( LA ) COMPLEX(kind=8) SON_A( LCB ) INTEGER(8) :: IAFATH INTEGER IW( NCOLS ) INTEGER ETATASS LOGICAL CB_IS_COMPRESSED !$ INTEGER, INTENT(in):: K360 COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB !$ LOGICAL :: OMP_FLAG IF ((ETATASS.EQ.0) .OR. (ETATASS.EQ.1)) THEN IPOSCB = 1_8 #if defined(__ve__) !NEC$ IVDEP #endif 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 #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IAFATH+ APOS -1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO END DO ENDIF IF ((ETATASS.EQ.0).OR.(ETATASS.EQ.1)) THEN !$ OMP_FLAG = (NROWS-NELIM).GE.K360 !$OMP PARALLEL DO PRIVATE(IPOSCB, POSELT, J, APOS) IF (OMP_FLAG) DO I = NELIM + 1, NROWS IF (CB_IS_COMPRESSED) THEN IPOSCB = (int(I,8) * int(I-1,8)) / 2_8 + 1_8 ELSE IPOSCB = int(I-1,8) * int(NCOLS,8) + 1_8 ENDIF POSELT = int(IW( I ),8) IF (POSELT.LE. int(NASS1,8)) THEN #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, NELIM APOS = POSELT + int( IW( J ) - 1, 8 ) * int(NFRONT,8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) + & SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ELSE POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, NELIM APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ENDIF IF (ETATASS.EQ.1) THEN POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J = NELIM + 1, I IF (IW(J).GT.NASS1) EXIT APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB +1_8 END DO ELSE POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) #if defined(__ve__) !NEC$ IVDEP #endif DO J = NELIM + 1, I APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ENDIF END DO !$OMP END PARALLEL DO ELSE DO I= NROWS, NELIM+1, -1 IF (CB_IS_COMPRESSED) THEN IPOSCB = (int(I,8)*int(I+1,8))/2_8 ELSE IPOSCB = int(I-1,8) * int(NCOLS,8) + int(I,8) ENDIF POSELT = int(IW( I ),8) IF (POSELT.LE.int(NASS1,8)) EXIT POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J=I,NELIM+1, -1 IF (IW(J).LE.NASS1) EXIT APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB - 1_8 ENDDO ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_LDLT_ASM_NIV12 SUBROUTINE ZMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST_S, IW, LIW, STEP, KEEP,KEEP8) IMPLICIT NONE INTEGER N, ISON, INODE, IWPOSCB INTEGER KEEP(500), STEP(N) INTEGER(8) KEEP8(150) INTEGER PIMASTER(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER LIW INTEGER IW(LIW) INTEGER ISTCHK, LSTK, NSLSON, HS, NROWS, NCOLS, NPIVS, NELIM INTEGER IOLDPS, NFRONT, NSLAVES, ICT11, HF INTEGER J1, J2, J3, JJ, JPOS LOGICAL SAME_PROC INCLUDE 'mumps_headers.h' ISTCHK = PIMASTER(STEP(ISON)) LSTK = IW(ISTCHK+KEEP(IXSZ)) NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NELIM = IW(ISTCHK + 1+KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) NCOLS = NPIVS + LSTK IF ( NPIVS < 0 ) NPIVS = 0 SAME_PROC = ISTCHK < IWPOSCB IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2+KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS IF (KEEP(50).NE.0) THEN J2 = J1 + LSTK - 1 DO JJ = J1, J2 IW(JJ) = IW(JJ - NROWS) ENDDO ELSE J2 = J1 + LSTK - 1 J3 = J1 + NELIM DO JJ = J3, J2 IW(JJ) = IW(JJ - NROWS) ENDDO IF (NELIM .NE. 0) THEN IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) ICT11 = IOLDPS + HF - 1 + NFRONT J3 = J3 - 1 DO 190 JJ = J1, J3 JPOS = IW(JJ) + ICT11 IW(JJ) = IW(JPOS) 190 CONTINUE ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_RESTORE_INDICES SUBROUTINE ZMUMPS_ASM_MAX( & N, INODE, IW, LIW, A, LA, & ISON, NBCOLS, & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, & OPASSW, IWPOSCB,MYID, KEEP,KEEP8 ) 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,NPIVS,NCOLS, J1, & JJ1,NROWS INTEGER(8) POSELT, APOS, JJ2 INCLUDE 'mumps_headers.h' LOGICAL SAME_PROC INTRINSIC dble IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) NASS1 = abs(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) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOSCB) IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2 + KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS APOS = POSELT + int(NASS1,8)*int(NASS1,8) - 1_8 DO JJ1 = 1, NBCOLS JJ2 = APOS+int(IW(J1 + JJ1 - 1),8) IF(dble(A(JJ2)) .LT. VALSON(JJ1)) THEN A(JJ2) = cmplx(VALSON(JJ1),kind=kind(A)) ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_ASM_MAX SUBROUTINE ZMUMPS_ASM_SLAVE_ARROWHEADS(INODE, ISTEP, & N, IW, LIW, IOLDPS, & A, LA, POSELT, KEEP, KEEP8, & ITLOC, FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LINTARR, LDBLARR, RHS_MUMPS, LRGROUPS) !$ USE OMP_LIB USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, intent(in) :: N, LIW, IOLDPS, INODE, ISTEP INTEGER(8), intent(in) :: LA, POSELT INTEGER(8), intent(in) :: LINTARR, LDBLARR INTEGER, intent(in) :: IW(LIW) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(inout) :: ITLOC(N+KEEP(253)) COMPLEX(kind=8), intent(inout) :: A(LA) COMPLEX(kind=8), intent(in) :: RHS_MUMPS(KEEP8(85)) COMPLEX(kind=8), intent(in) :: DBLARR(LDBLARR) INTEGER, intent(in) :: INTARR(LINTARR) INTEGER, intent(in) :: FILS(N) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 !$ INTEGER :: CHUNK INCLUDE 'mumps_headers.h' INTEGER :: HF, NBROWF, NBCOLF, NASS, NSLAVES INTEGER :: ILOC, J, K, K1, K2, JPOS, IJROW INTEGER :: IN, IARR1, IORG INTEGER(8) :: J18, J28, JJ8 INTEGER(8) :: APOS, ICT12 INTEGER(8) :: AINPUT8 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE, TOPDIAG INTEGER(8) :: JJ3 INTEGER :: K1RHS, K2RHS, JFirstRHS COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) !$ NOMP = OMP_GET_MAX_THREADS() IF (KEEP(50) .EQ. 0 .OR. NBROWF .LT. KEEP(63)) THEN !$ CHUNK8 = int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8) !$OMP& .AND. NOMP .GT. 1) DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = 0 IF (IW(IOLDPS+XXLR).GE.1) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0, & NBROWF, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) NB_BLR_LS = NPARTSCB call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR_LS) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS, & NBCOLF, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max( KEEP(360)/2, !$ & ((NBROWF+NOMP-1)/NOMP +2) / 3 ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK) !$OMP& IF (NBROWF .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(NBROWF-1,8) APOS = POSELT+ JJ8*int(NBCOLF,8) JJ3 = min( int(NBCOLF,8) - 1_8, & JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG ) A(APOS: APOS+JJ3) = ZERO ENDDO !$OMP END PARALLEL DO ENDIF K1 = IOLDPS + HF + NBROWF K2 = K1 + NASS - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = -JPOS JPOS = JPOS + 1 ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF - 1 JPOS = 1 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN K1RHS = 0 K2RHS = -1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN K1RHS = K JFirstRHS=J-N ENDIF JPOS = JPOS + 1 ENDDO IF (K1RHS.GT.0) K2RHS=K2 IF ( K2RHS.GE.K1RHS ) THEN IN = INODE DO WHILE (IN.GT.0) IJROW = -ITLOC(IN) DO K = K1RHS, K2RHS J = IW(K) ILOC = ITLOC(J) APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+IN) ENDDO IN = FILS(IN) ENDDO ENDIF ELSE DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF IN = INODE IORG = 0 IARR1 = PTRDEBARR(ISTEP) DO WHILE (IN.GT.0) IORG = IORG + 1 AINPUT8 = PTR8ARR( IARR1 + IORG -1 ) J18 = AINPUT8 J28 = J18 + NINCOLARR(IARR1+IORG-1) IJROW = -ITLOC(INTARR(J18)) ICT12 = POSELT +int(- NBCOLF + IJROW - 1,8) DO JJ8= J18,J28 ILOC = ITLOC(INTARR(JJ8)) IF (ILOC.GT.0) THEN APOS = ICT12 + int(ILOC,8)*int(NBCOLF,8) A(APOS) = A(APOS) + DBLARR(AINPUT8) ENDIF AINPUT8 = AINPUT8 + 1_8 ENDDO IN = FILS(IN) ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF + NASS - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO RETURN END SUBROUTINE ZMUMPS_ASM_SLAVE_ARROWHEADS SUBROUTINE ZMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS1, KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(out) :: PARPIV_T1 INTEGER :: NCB LOGICAL, EXTERNAL :: ZMUMPS_IS_TRSM_LARGE_ENOUGH, & ZMUMPS_IS_GEMM_LARGE_ENOUGH PARPIV_T1 = KEEP(269) IF (PARPIV_T1.EQ.-3) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.77) THEN PARPIV_T1 = 0 ENDIF NCB = NFRONT-NASS1 IF (NCB.EQ.KEEP(253)) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.0) RETURN IF ( (PARPIV_T1.EQ.-2).AND.LR_ACTIVATED ) THEN PARPIV_T1 = 1 ENDIF IF (PARPIV_T1.EQ.-2) THEN IF ( & ( ZMUMPS_IS_TRSM_LARGE_ENOUGH ( NASS1, NCB & ) & ) & .OR. & ( ZMUMPS_IS_GEMM_LARGE_ENOUGH ( NCB, NCB, NASS1 & ) & ) & ) THEN PARPIV_T1 = 1 ELSE PARPIV_T1 = 0 ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SET_PARPIVT1 LOGICAL FUNCTION ZMUMPS_IS_TRSM_LARGE_ENOUGH & ( M, N & ) IMPLICIT NONE INTEGER, INTENT(in) :: M, N DOUBLE PRECISION :: AI INTEGER, PARAMETER :: THRES_AI = 400 AI = ( dble(M)*dble(N) ) / & ( dble(M)/dble(2) + dble(2)*dble(N) ) ZMUMPS_IS_TRSM_LARGE_ENOUGH = (AI.GE.dble(THRES_AI)) RETURN END FUNCTION ZMUMPS_IS_TRSM_LARGE_ENOUGH LOGICAL FUNCTION ZMUMPS_IS_GEMM_LARGE_ENOUGH & ( M, N, K & ) IMPLICIT NONE INTEGER, INTENT(in) :: M, N, K DOUBLE PRECISION :: AI INTEGER, PARAMETER :: THRES_AI = 400 AI = ( dble(2)*dble(M)*dble(N)*dble(K) ) / & ( dble(M)*dble(N) + dble(M)*dble(K) + dble(K)*dble(N) ) ZMUMPS_IS_GEMM_LARGE_ENOUGH = (AI.GE.dble(THRES_AI)) RETURN END FUNCTION ZMUMPS_IS_GEMM_LARGE_ENOUGH SUBROUTINE ZMUMPS_PARPIVT1_SET_MAX ( INODE, & A, LAELL8, KEEP, NFRONT, & NASS1, NVSCHUR_K253, NB_POSTPONED) !$ USE OMP_LIB IMPLICIT NONE INTEGER(8), intent(in) :: LAELL8 INTEGER, intent(in) :: INODE INTEGER, intent(in) :: KEEP(500), NFRONT, NASS1, & NVSCHUR_K253 INTEGER, intent(in) :: NB_POSTPONED COMPLEX(kind=8), intent(inout) :: A(LAELL8) INTEGER(8) :: APOSMAX, APOS, NASS1_8, NFRONT_8 INTEGER :: I, J, NCB COMPLEX(kind=8) :: ZERO DOUBLE PRECISION :: RMAX LOGICAL :: OMP_FLAG INTEGER :: JB, NB_BLOCKS, BLSIZE INTEGER(8) :: APOSSHIFT INTEGER :: NOMP PARAMETER( ZERO = (0.0D0,0.0D0) ) NASS1_8 = int(NASS1, 8) NFRONT_8 = int(NFRONT, 8) NCB = NFRONT-NASS1-NVSCHUR_K253 IF ((NCB.EQ.0).AND.(NVSCHUR_K253.EQ.0)) CALL MUMPS_ABORT() APOSMAX = LAELL8 - NASS1_8 + 1_8 A(APOSMAX:APOSMAX+NASS1_8-1_8)= ZERO IF (NCB.EQ.0) RETURN IF (KEEP(50).EQ.2) THEN IF ( NASS1 .LE. KEEP(366) ) THEN APOS = 1_8 + (NASS1_8*NFRONT_8) DO I = 1, NCB DO J = 1, NASS1 RMAX = dble(A(APOSMAX+int(J,8)-1_8)) RMAX = max(RMAX, abs(A(APOS+int(J,8)-1_8))) A(APOSMAX+int(J,8)-1_8) = cmplx(RMAX,kind=kind(A)) ENDDO APOS = APOS+NFRONT_8 ENDDO ELSE NOMP = 1 !$ NOMP = OMP_GET_MAX_THREADS() OMP_FLAG = int(NCB,8)*int(NASS1,8) .GT. int(KEEP(361),8) & .AND. (NASS1 .GT. KEEP(366)) .AND. (NOMP.GT.1) BLSIZE = max(KEEP(366),1) NB_BLOCKS = NASS1 / BLSIZE BLSIZE = (NASS1 + NB_BLOCKS - 1)/ NB_BLOCKS APOSSHIFT=NASS1_8 * NFRONT_8 !$OMP PARALLEL DO PRIVATE(I,J,APOS,JB,RMAX) IF (OMP_FLAG) DO JB = 1, NASS1, BLSIZE DO I = 1, NCB DO J = JB, min(JB+BLSIZE-1,NASS1) APOS = APOSSHIFT + int(I-1,8) * int(NFRONT,8) + int(J,8) RMAX = dble( A(APOSMAX+int(J,8) - 1_8) ) RMAX = max( RMAX, abs(A(APOS+int(J,8)) ) ) A(APOSMAX+int(J,8)-1_8) = cmplx(RMAX,kind=kind(A)) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF ELSE OMP_FLAG = int(NCB,8)*int(NASS1,8) .GT. int(KEEP(361),8) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(I,J,APOS,RMAX) DO I = 1, NASS1 RMAX = 0.0D0 APOS = 1_8 + NASS1_8+int(I-1,8)*NFRONT_8 DO J = 1, NCB RMAX = max(RMAX, abs(A(APOS+int(J-1,8)))) ENDDO A(APOSMAX+int(I,8)-1_8) = cmplx(RMAX,kind=kind(A)) ENDDO !$OMP END PARALLEL DO ELSE APOS = 1_8 + NASS1_8 DO I = 1, NASS1 RMAX = 0.0D0 DO J = 1, NCB RMAX = max(RMAX, abs(A(APOS+int(J,8)-1))) ENDDO A(APOSMAX+int(I,8)-1_8) = cmplx(RMAX,kind=kind(A)) APOS = APOS+NFRONT_8 ENDDO ENDIF ENDIF CALL ZMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, A(APOSMAX), NASS1, NB_POSTPONED) RETURN END SUBROUTINE ZMUMPS_PARPIVT1_SET_MAX SUBROUTINE ZMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, PARPIV, LPARPIV, & NB_POSTPONED) IMPLICIT NONE INTEGER, intent(in) :: INODE, LPARPIV, KEEP(500) COMPLEX(kind=8), intent(inout):: PARPIV(LPARPIV) INTEGER, intent(in) :: NB_POSTPONED INTEGER :: I DOUBLE PRECISION :: EPS, RMIN, RZERO, RTMP DOUBLE PRECISION :: RMAX LOGICAL :: UPDATE_PARPIV PARAMETER( RZERO = 0.0D0 ) UPDATE_PARPIV=.FALSE. RMIN = huge(RZERO) RMAX = RZERO EPS = sqrt(epsilon(RZERO))*0.01D0 DO I = 1, LPARPIV RTMP = dble(PARPIV(I)) IF (RTMP.GT.RZERO) THEN RMIN = min(RMIN, RTMP) ELSE UPDATE_PARPIV=.TRUE. ENDIF IF (RTMP.LE.EPS) UPDATE_PARPIV=.TRUE. RMAX= max(RMAX,dble(PARPIV(I))) ENDDO IF (UPDATE_PARPIV) THEN IF (RMIN.LT.huge(RMIN)) THEN RMAX= min (RMAX, EPS) DO I = 1, LPARPIV-NB_POSTPONED RTMP = dble(PARPIV(I)) IF (RTMP.LE.EPS) THEN PARPIV(I) = cmplx(-RMAX, kind=kind(PARPIV)) ENDIF ENDDO IF (NB_POSTPONED.GT.0) THEN DO I=LPARPIV-NB_POSTPONED+1, LPARPIV RTMP = dble(PARPIV(I)) IF (RTMP.LE.EPS) THEN PARPIV(I) = cmplx(-RMAX, kind=kind(PARPIV)) ENDIF ENDDO ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_UPDATE_PARPIV_ENTRIES SUBROUTINE ZMUMPS_PARPIVT1_SET_NVSCHUR_MAX & (N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1, & NB_POSTPONED) USE ZMUMPS_FAC_FRONT_AUX_M, ONLY: ZMUMPS_GET_SIZE_SCHUR_IN_FRONT IMPLICIT NONE INTEGER, intent(in) :: N, INODE, LIW, IOLDPS, & NFRONT, NASS1, NB_POSTPONED INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: IW (LIW), PERM(N), KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER, intent(inout) :: PARPIV_T1 INTEGER :: NVSCHUR_K253, IROW_L INTEGER(8) :: LAELL8, NFRONT8 INCLUDE 'mumps_headers.h' IF (PARPIV_T1.EQ.-999) THEN CALL ZMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) ELSE IF ((PARPIV_T1.NE.0.AND.PARPIV_T1.NE.1)) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.NE.0) THEN IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) ) THEN IROW_L = IOLDPS+6+KEEP(IXSZ)+NASS1 CALL ZMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS1, & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR_K253 ) ELSE NVSCHUR_K253 = KEEP(253) ENDIF NFRONT8 = int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 + int(NASS1,8) CALL ZMUMPS_PARPIVT1_SET_MAX ( INODE, & A(POSELT), LAELL8, KEEP, & NFRONT, NASS1, NVSCHUR_K253, & NB_POSTPONED ) ENDIF RETURN END SUBROUTINE ZMUMPS_PARPIVT1_SET_NVSCHUR_MAX MUMPS_5.8.1/src/zfac_sispointers_m.F0000664000175000017500000000154015042446442017242 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_S_IS_POINTERS_M C ---------------------------------- C This module defines a type used in C ZMUMPS_FAC_DRIVER and ZMUMPS_FAC_B C ---------------------------------- TYPE ZMUMPS_S_IS_POINTERS_T COMPLEX(kind=8), POINTER, DIMENSION(:) :: A INTEGER, POINTER, DIMENSION(:) :: IW END TYPE ZMUMPS_S_IS_POINTERS_T END MODULE ZMUMPS_FAC_S_IS_POINTERS_M MUMPS_5.8.1/src/mumps_intr_types_common.F0000664000175000017500000000220615042446423020331 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_INTR_TYPES PRIVATE PUBLIC :: MUMPS_ROOT_STRUC C Define arithmetic-independent MUMPS_ROOT_STRUC datatype TYPE MUMPS_ROOT_STRUC 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 INTEGER :: NB_SINGULAR_VALUES INTEGER, DIMENSION(:), POINTER :: IPIV INTEGER, DIMENSION(:), POINTER :: RG2L LOGICAL :: yes, gridinit_done END TYPE MUMPS_ROOT_STRUC END MODULE MUMPS_INTR_TYPES MUMPS_5.8.1/src/dfac_process_band.F0000664000175000017500000003233415042446440016763 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_PROCESS_DESC_BANDE( MYID, BUFR, LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP,KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, #if ! defined(NO_FDM_DESCBAND) & IWHANDLER_IN, #endif & IFLAG, IERROR ) USE MUMPS_LOAD USE DMUMPS_LR_DATA_M, ONLY: DMUMPS_BLR_INIT_FRONT, & DMUMPS_BLR_SAVE_NFS4FATHER #if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M #endif IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB, N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), & ITLOC( N + KEEP(253) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER :: ISTEP_TO_INIV2(KEEP(71)) #if ! defined(NO_FDM_DESCBAND) INTEGER IWHANDLER_IN #endif INTEGER COMP, IFLAG, IERROR INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES INTEGER NSLAVES_HDR, NFRONT INTEGER LREQ INTEGER :: IBUFR INTEGER(8) :: LREQCB #if ! defined(NO_FDM_DESCBAND) INTEGER :: IWHANDLER_LOC #endif DOUBLE PRECISION FLOP1 INCLUDE 'mumps_headers.h' #if ! defined(NO_FDM_DESCBAND) INTEGER :: INFO_TMP(2) #else #endif INTEGER :: LRSTATUS INTEGER :: ESTIM_NFS4FATHER_ATSON LOGICAL :: LR_ACTIVATED, COMPRESS_CB DOUBLE PRECISION, POINTER, DIMENSION(:) :: DYNAMIC_CB INTEGER(8) :: TMP_ADDRESS INTEGER :: allocok INODE = BUFR( 2 ) NBPROCFILS = BUFR( 3 ) NROW = BUFR( 4 ) NCOL = BUFR( 5 ) NASS = BUFR( 6 ) NFRONT = BUFR( 7 ) NSLAVES_HDR = BUFR( 8 ) NSLAVES = BUFR( 9 ) LRSTATUS = BUFR(10 ) ESTIM_NFS4FATHER_ATSON = BUFR(11) IBUFR = 12 #if ! defined(NO_FDM_DESCBAND) IWHANDLER_LOC = IWHANDLER_IN IF ((IWHANDLER_IN .LE. 0) .AND. & (INODE .NE. INODE_WAITED_FOR)) THEN INFO_TMP=0 CALL MUMPS_FDBD_SAVE_DESCBAND(INODE, BUFR(1), BUFR, & IWHANDLER_LOC, INFO_TMP) IF (INFO_TMP(1) < 0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) RETURN ENDIF GOTO 555 ENDIF #endif IF ( KEEP(50) .eq. 0 ) THEN FLOP1 = dble( NASS * NROW ) + & dble(NROW*NASS)*dble(2*NCOL-NASS-1) ELSE FLOP1 = dble( NASS ) * dble( NROW ) & * dble( 2 * NCOL - NROW - NASS + 1) END IF CALL MUMPS_LOAD_UPDATE(1,.TRUE.,FLOP1, KEEP,KEEP8) IF ( KEEP(50) .eq. 0 ) THEN NSLAVES = NSLAVES_HDR + XTRA_SLAVES_UNSYM ELSE NSLAVES = NSLAVES_HDR + XTRA_SLAVES_SYM END IF LREQ = NROW + NCOL + 6 + NSLAVES + KEEP(IXSZ) LREQCB = int(NCOL,8) * int(NROW,8) IF ( LREQCB .GT. LRLUS .AND. KEEP(101) .EQ. 0 .AND. & KEEP8(73) + LREQCB .LE. KEEP8(75) ) THEN CALL DMUMPS_ALLOC_CB(.FALSE., 0_8, .FALSE.,.TRUE., & MYID,N, KEEP, KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, & LREQ, 0_8, & INODE, S_ACTIVE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN #if defined(MUMPS_ALLOC_FROM_C) || defined(_CRAYFTN) CALL MUMPS_MALLOC_C( TMP_ADDRESS, & LREQCB * int(KEEP(35),8) ) IF (TMP_ADDRESS .EQ. 0_8) THEN allocok=1 ELSE allocok=0 ENDIF #else ALLOCATE(DYNAMIC_CB(LREQCB), stat=allocok) #endif IF (allocok .GT. 0) THEN CALL DMUMPS_FREE_BLOCK_CB_STATIC( .FALSE., MYID, N, & IWPOSCB + 1, IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP, KEEP8, .FALSE. ) ELSE CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( LREQCB, & KEEP(405).EQ.1, & KEEP8, IFLAG, IERROR, & .TRUE., & .FALSE. ) #if ! defined(MUMPS_ALLOC_FROM_C) && ! defined(_CRAYFTN) CALL MUMPS_ADDR_C( DYNAMIC_CB(1), TMP_ADDRESS ) #endif CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXD)) PTRIST(STEP(INODE)) = IWPOSCB + 1 PTRAST(STEP(INODE)) = TMP_ADDRESS ENDIF ENDIF IF ( PTRIST(STEP(INODE)) .EQ. 0 ) THEN CALL DMUMPS_ALLOC_CB(.FALSE., 0_8, .FALSE.,.TRUE., & MYID,N, KEEP, KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, & LREQ, LREQCB, INODE, S_ACTIVE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PTRIST(STEP(INODE)) = IWPOSCB + 1 PTRAST(STEP(INODE)) = IPTRLU + 1_8 ENDIF # if ! defined(NO_FDM_DESCBAND) 555 CONTINUE # endif # if ! defined(NO_FDM_DESCBAND) IF ((IWHANDLER_IN .LE. 0) .AND. & (INODE .NE. INODE_WAITED_FOR)) THEN RETURN ENDIF IW(IWPOSCB+1+XXA) = IWHANDLER_LOC # endif IW(IWPOSCB+1+XXF) = -9999 IW( IWPOSCB + 1+KEEP(IXSZ) ) = NCOL IW( IWPOSCB + 2+KEEP(IXSZ) ) = - NASS IW( IWPOSCB + 3+KEEP(IXSZ) ) = NROW IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 5+KEEP(IXSZ) ) = NASS IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES IW( IWPOSCB + 7+KEEP(IXSZ)+NSLAVES : & IWPOSCB + 6+KEEP(IXSZ)+NSLAVES + NROW + NCOL ) &= BUFR( IBUFR + NSLAVES_HDR : & IBUFR + NSLAVES_HDR + NROW + NCOL - 1 ) IF ( KEEP(50) .eq. 0 ) THEN IW( IWPOSCB + 7+KEEP(IXSZ) ) = S_ROOTBAND_INIT IF (NSLAVES_HDR.GT.0) THEN write(6,*) " Internal error in DMUMPS_PROCESS_DESC_BANDE " CALL MUMPS_ABORT() ENDIF ELSE IW( IWPOSCB+7+KEEP(IXSZ) ) = huge(IW(IWPOSCB+7+KEEP(IXSZ))) IW( IWPOSCB + 8+KEEP(IXSZ) ) = NFRONT IW( IWPOSCB + 9+KEEP(IXSZ) ) = S_ROOTBAND_INIT IW( IWPOSCB + 7+XTRA_SLAVES_SYM+KEEP(IXSZ): & IWPOSCB + 6+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_HDR ) = & BUFR( IBUFR: IBUFR - 1 + NSLAVES_HDR ) END IF IW(IWPOSCB+1+XXNBPR)=NBPROCFILS IW(IWPOSCB+1+XXLR)=LRSTATUS COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP=0 CALL DMUMPS_BLR_INIT_FRONT (IW(IWPOSCB+1+XXF), INFO_TMP) IF (INFO_TMP(1).LT.0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) RETURN ENDIF IF (COMPRESS_CB.AND. & (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & (ESTIM_NFS4FATHER_ATSON.GE.0) & ) THEN CALL DMUMPS_BLR_SAVE_NFS4FATHER ( IW(IWPOSCB+1+XXF), & ESTIM_NFS4FATHER_ATSON ) ENDIF ENDIF IF (NBPROCFILS .EQ. 0) THEN ENDIF RETURN END SUBROUTINE DMUMPS_PROCESS_DESC_BANDE RECURSIVE SUBROUTINE DMUMPS_TREAT_DESCBAND( INODE, & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED & , LRGROUPS & ) # if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M # endif USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER, INTENT(IN) :: INODE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST(KEEP(28)) INTEGER STEP(N), & PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' LOGICAL :: BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: SRC_DESCBAND #if ! defined(NO_FDM_DESCBAND) INTEGER :: IWHANDLER TYPE(DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC #endif INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE SRC_DESCBAND = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) # if ! defined(NO_FDM_DESCBAND) IF (MUMPS_FDBD_IS_DESCBAND_STORED( INODE, IWHANDLER )) THEN CALL MUMPS_FDBD_RETRIEVE_DESCBAND(IWHANDLER, DESCBAND_STRUC) CALL DMUMPS_PROCESS_DESC_BANDE( MYID, DESCBAND_STRUC%BUFR(1), & DESCBAND_STRUC%LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, & IWHANDLER, & IFLAG, IERROR ) IF (IFLAG .LT. 0) GOTO 500 CALL MUMPS_FDBD_FREE_DESCBAND_STRUC(IW(PTRIST(STEP(INODE))+XXA)) ELSE IF (INODE_WAITED_FOR.GT.0) THEN WRITE(*,*) " Internal error 1 in DMUMPS_TREAT_DESCBAND", & INODE, INODE_WAITED_FOR CALL MUMPS_ABORT() ENDIF INODE_WAITED_FOR = INODE # endif DO WHILE (PTRIST(STEP(INODE)) .EQ. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT(COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & SRC_DESCBAND, MAITRE_DESC_BANDE, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (IFLAG .LT. 0) THEN RETURN ENDIF ENDDO # if ! defined(NO_FDM_DESCBAND) INODE_WAITED_FOR = -1 ENDIF # endif RETURN 500 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE DMUMPS_TREAT_DESCBAND MUMPS_5.8.1/src/dana_LDLT_preprocess.F0000664000175000017500000007155615042446437017352 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SET_CONSTRAINTS( & N,PIV,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8, ROWSCA & ) USE DMUMPS_STRUC_DEF IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(OUT) :: NCST INTEGER :: PIV(N),FRERE(N),FILS(N),NFSIZ(N),IKEEP(N) INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: ROWSCA(N) INTEGER I,P11,P1,P2,K1,K2,NLOCKED LOGICAL V1,V2 NCST = 0 NLOCKED = 0 P11 = KEEP(93) DO I=KEEP(93)-1,1,-2 P1 = PIV(I) P2 = PIV(I+1) K1 = IKEEP(P1) IF (K1 .NE. 0) THEN V1 = (K1+2*exponent(ROWSCA(P1)) .GE. -3) ELSE V1 = .FALSE. ENDIF K2 = IKEEP(P2) IF (K2 .NE. 0) THEN V2 = (K2+exponent(ROWSCA(P2)**2) .GE. -3) ELSE V2 = .FALSE. ENDIF IF(V1 .AND. V2) THEN PIV(P11) = P1 P11 = P11 - 1 PIV(P11) = P2 P11 = P11 - 1 ELSE IF(V1) THEN NCST = NCST+1 FRERE(NCST) = P1 NCST = NCST+1 FRERE(NCST) = P2 ELSE IF(V2) THEN NCST = NCST+1 FRERE(NCST) = P2 NCST = NCST+1 FRERE(NCST) = P1 ELSE NLOCKED = NLOCKED + 1 FILS(NLOCKED) = P1 NLOCKED = NLOCKED + 1 FILS(NLOCKED) = P2 ENDIF ENDDO DO I=1,NLOCKED PIV(I) = FILS(I) ENDDO KEEP(94) = KEEP(94) + KEEP(93) - NLOCKED KEEP(93) = NLOCKED DO I=1,NCST NLOCKED = NLOCKED + 1 PIV(NLOCKED) = FRERE(I) ENDDO DO I=1,KEEP(93)/2 NFSIZ(I) = 0 ENDDO DO I=(KEEP(93)/2)+1,(KEEP(93)/2)+NCST,2 NFSIZ(I) = I+1 NFSIZ(I+1) = -1 ENDDO DO I=(KEEP(93)/2)+NCST+1,(KEEP(93)/2)+KEEP(94) NFSIZ(I) = 0 ENDDO END SUBROUTINE DMUMPS_SET_CONSTRAINTS SUBROUTINE DMUMPS_EXPAND_PERMUTATION(N,NCMP,N11,N22,PIV, & INVPERM,PERM) IMPLICIT NONE INTEGER N11,N22,N,NCMP INTEGER, intent(in) :: PIV(N),PERM(N) INTEGER, intent (out):: INVPERM(N) INTEGER CMP_POS,EXP_POS,I,J,N2,K N2 = N22/2 EXP_POS = 1 DO CMP_POS=1,NCMP J = PERM(CMP_POS) IF(J .LE. N2) THEN K = 2*J-1 I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 K = K+1 I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ELSE K = N2 + J I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ENDIF ENDDO DO K=N22+N11+1,N I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ENDDO RETURN END SUBROUTINE DMUMPS_EXPAND_PERMUTATION SUBROUTINE DMUMPS_LDLT_COMPRESS( & N,NZ, IRN, ICN, PIV, & NCMP, IW, LW, IPE, LEN, IQ, & FLAG, ICMP, IWFR, & IERROR, KEEP,KEEP8, ICNTL,INPLACE64_GRAPH_COPY) IMPLICIT NONE INTEGER, intent(in) :: N INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: IRN(NZ), ICN(NZ), PIV(N) INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(out) :: NCMP, IERROR INTEGER(8), intent(out) :: IWFR, IPE(N+1) INTEGER, intent(out) :: IW(LW) INTEGER, intent(out) :: LEN(N) INTEGER(8), intent(out) :: IQ(N) INTEGER, intent(out) :: FLAG(N), ICMP(N) LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: N11, N22 INTEGER :: I, J, N1, K INTEGER(8) :: NDUP, L, K8, K1, K2, LAST IERROR = 0 N22 = KEEP(93) N11 = KEEP(94) NCMP = N22/2 + N11 DO I=1,NCMP IPE(I) = 0 ENDDO K = 1 DO I=1,N22/2 J = PIV(K) ICMP(J) = I K = K + 1 J = PIV(K) ICMP(J) = I K = K + 1 ENDDO K = N22/2 + 1 DO I=N22+1,N22+N11 J = PIV(I) ICMP(J) = K K = K + 1 ENDDO DO I=N11+N22+1,N J = PIV(I) ICMP(J) = 0 ENDDO DO K8=1,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ICMP(I) J = ICMP(J) IF ((I.NE.0).AND.(J.NE.0).AND.(I.NE.J)) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 ENDIF ENDIF ENDDO IQ(1) = 1_8 N1 = NCMP - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(NCMP)+IQ(NCMP)-1_8,IQ(NCMP)) DO I = 1,NCMP FLAG(I) = 0 IPE(I) = IQ(I) ENDDO IW(1:LAST) = 0 IWFR = LAST + 1_8 DO K8=1,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ICMP(I) J = ICMP(J) IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1_8 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1_8 ENDIF ENDIF ENDIF ENDDO NDUP = 0_8 DO I=1,NCMP K1 = IPE(I) K2 = IQ(I) -1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) GO TO 250 L = IQ(J) IQ(J) = L + 1_8 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(L) = 0 IW(K8) = 0 ELSE IW(L) = I IW(K8) = J FLAG(J) = I ENDIF ENDDO 250 LEN(I) = int(IQ(I) - IPE(I)) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,NCMP K1 = IPE(I) IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF ENDDO LEN(I) = int(IWFR - L) ENDDO ENDIF IPE(NCMP+1) = IPE(NCMP) + int(LEN(NCMP),8) IWFR = IPE(NCMP+1) INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1_8)) RETURN END SUBROUTINE DMUMPS_LDLT_COMPRESS SUBROUTINE DMUMPS_SYM_MWM( & N, NE, IP, IRN, SCALING,LSC,CPERM, DIAG, & ICNTL, WEIGHT,MARKED,FLAG, & PIV_OUT, INFO) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NE INTEGER :: ICNTL(10), INFO(10),LSC INTEGER :: CPERM(N),PIV_OUT(N), IRN(NE), DIAG(N) INTEGER(8), INTENT(IN) :: IP(N+1) DOUBLE PRECISION :: SCALING(LSC),WEIGHT(N+2) INTEGER :: MARKED(N),FLAG(N) INTEGER :: NUM1,NUM2,NUMTOT,PATH_LENGTH,NLAST INTEGER :: I,BEST_BEG, CUR_EL,CUR_EL_PATH,CUR_EL_PATH_NEXT INTEGER :: L1,L2,TUP,T22 INTEGER(8) :: PTR_SET1,PTR_SET2 DOUBLE PRECISION :: BEST_SCORE,CUR_VAL,TMP,VAL DOUBLE PRECISION INITSCORE, DMUMPS_UPDATESCORE, & DMUMPS_UPDATE_INVERSE, DMUMPS_METRIC2x2 LOGICAL VRAI,FAUX,MAX_CARD_DIAG,USE_SCALING INTEGER SUM DOUBLE PRECISION ZERO,ONE PARAMETER (SUM = 1, VRAI = .TRUE., FAUX = .FALSE.) PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) MAX_CARD_DIAG = .TRUE. NUM1 = 0 NUM2 = 0 NUMTOT = 0 NLAST = N INFO = 0 MARKED = 1 FLAG = 0 VAL = ONE IF(LSC .GT. 1) THEN USE_SCALING = .TRUE. ELSE USE_SCALING = .FALSE. ENDIF TUP = ICNTL(2) IF(TUP .EQ. SUM) THEN INITSCORE = ZERO ELSE INITSCORE = ONE ENDIF IF(ICNTL(2) .GT. 2 .OR. ICNTL(2) .LE. 0) THEN WRITE(*,*) & 'ERROR: WRONG VALUE FOR ICNTL(2) = ',ICNTL(2) INFO(1) = -1 RETURN ENDIF T22 = ICNTL(1) IF(ICNTL(1) .LT. 0 .OR. ICNTL(1) .GT. 2) THEN WRITE(*,*) & 'ERROR: WRONG VALUE FOR ICNTL(1) = ',ICNTL(1) INFO(1) = -1 RETURN ENDIF DO CUR_EL=1,N IF(MARKED(CUR_EL) .LE. 0) THEN CYCLE ENDIF IF(CPERM(CUR_EL) .LT. 0) THEN MARKED(CUR_EL) = -1 CYCLE ENDIF PATH_LENGTH = 2 CUR_EL_PATH = CPERM(CUR_EL) IF(CUR_EL_PATH .EQ. CUR_EL) THEN MARKED(CUR_EL) = -1 CYCLE ENDIF MARKED(CUR_EL) = 0 WEIGHT(1) = INITSCORE WEIGHT(2) = INITSCORE L1 = int(IP(CUR_EL+1)-IP(CUR_EL)) L2 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH)) PTR_SET1 = IP(CUR_EL) PTR_SET2 = IP(CUR_EL_PATH) IF(USE_SCALING) THEN VAL = -SCALING(CUR_EL_PATH) - SCALING(CUR_EL+N) ENDIF CUR_VAL = DMUMPS_METRIC2x2( & CUR_EL,CUR_EL_PATH, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,FAUX,T22) WEIGHT(PATH_LENGTH+1) = & DMUMPS_UPDATESCORE(WEIGHT(1),CUR_VAL,TUP) DO IF(CUR_EL_PATH .EQ. CUR_EL) EXIT PATH_LENGTH = PATH_LENGTH+1 MARKED(CUR_EL_PATH) = 0 CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH) L1 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH)) L2 = int(IP(CUR_EL_PATH_NEXT+1)-IP(CUR_EL_PATH_NEXT)) PTR_SET1 = IP(CUR_EL_PATH) PTR_SET2 = IP(CUR_EL_PATH_NEXT) IF(USE_SCALING) THEN VAL = -SCALING(CUR_EL_PATH_NEXT) & - SCALING(CUR_EL_PATH+N) ENDIF CUR_VAL = DMUMPS_METRIC2x2( & CUR_EL_PATH,CUR_EL_PATH_NEXT, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,VRAI,T22) WEIGHT(PATH_LENGTH+1) = & DMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH-1),CUR_VAL,TUP) CUR_EL_PATH = CUR_EL_PATH_NEXT ENDDO IF(mod(PATH_LENGTH,2) .EQ. 1) THEN IF(WEIGHT(PATH_LENGTH+1) .GE. WEIGHT(PATH_LENGTH)) THEN CUR_EL_PATH = CPERM(CUR_EL) ELSE CUR_EL_PATH = CUR_EL ENDIF DO I=1,(PATH_LENGTH-1)/2 NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO NUMTOT = NUMTOT + PATH_LENGTH - 1 ELSE IF(MAX_CARD_DIAG) THEN CUR_EL_PATH = CPERM(CUR_EL) IF(DIAG(CUR_EL) .NE. 0) THEN BEST_BEG = CUR_EL_PATH GOTO 1000 ENDIF DO I=1,(PATH_LENGTH/2) CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH) IF(DIAG(CUR_EL_PATH) .NE. 0) THEN BEST_BEG = CUR_EL_PATH_NEXT GOTO 1000 ENDIF ENDDO ENDIF BEST_BEG = CUR_EL BEST_SCORE = WEIGHT(PATH_LENGTH-1) CUR_EL_PATH = CPERM(CUR_EL) DO I=1,(PATH_LENGTH/2)-1 TMP = DMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH), & WEIGHT(2*I-1),TUP) TMP = DMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I),TUP) IF(TMP .GT. BEST_SCORE) THEN BEST_SCORE = TMP BEST_BEG = CUR_EL_PATH ENDIF CUR_EL_PATH = CPERM(CUR_EL_PATH) TMP = DMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH+1), & WEIGHT(2*I),TUP) TMP = DMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I+1),TUP) IF(TMP .GT. BEST_SCORE) THEN BEST_SCORE = TMP BEST_BEG = CUR_EL_PATH ENDIF CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO 1000 CUR_EL_PATH = BEST_BEG DO I=1,(PATH_LENGTH/2)-1 NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO NUMTOT = NUMTOT + PATH_LENGTH - 2 MARKED(CUR_EL_PATH) = -1 ENDIF ENDDO DO I=1,N IF(MARKED(I) .LT. 0) THEN IF(DIAG(I) .EQ. 0) THEN PIV_OUT(NLAST) = I NLAST = NLAST - 1 ELSE NUM1 = NUM1 + 1 PIV_OUT(NUM2+NUM1) = I NUMTOT = NUMTOT + 1 ENDIF ENDIF ENDDO INFO(2) = NUMTOT INFO(3) = NUM1 INFO(4) = NUM2 RETURN END SUBROUTINE DMUMPS_SYM_MWM FUNCTION DMUMPS_UPDATESCORE(A,B,T) IMPLICIT NONE DOUBLE PRECISION DMUMPS_UPDATESCORE DOUBLE PRECISION A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN DMUMPS_UPDATESCORE = A+B ELSE DMUMPS_UPDATESCORE = A*B ENDIF END FUNCTION DMUMPS_UPDATESCORE FUNCTION DMUMPS_UPDATE_INVERSE(A,B,T) IMPLICIT NONE DOUBLE PRECISION DMUMPS_UPDATE_INVERSE DOUBLE PRECISION A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN DMUMPS_UPDATE_INVERSE = A-B ELSE DMUMPS_UPDATE_INVERSE = A/B ENDIF END FUNCTION DMUMPS_UPDATE_INVERSE FUNCTION DMUMPS_METRIC2x2(CUR_EL,CUR_EL_PATH, & SET1,SET2,L1,L2,VAL,DIAG,N,FLAG,FLAGON,T) IMPLICIT NONE DOUBLE PRECISION DMUMPS_METRIC2x2 INTEGER CUR_EL,CUR_EL_PATH,L1,L2,N INTEGER SET1(L1),SET2(L2),DIAG(N),FLAG(N) DOUBLE PRECISION VAL LOGICAL FLAGON INTEGER T INTEGER I,INTER,MERGE INTEGER STRUCT,MA47 PARAMETER(STRUCT=0,MA47=1) IF(T .EQ. STRUCT) THEN IF(.NOT. FLAGON) THEN DO I=1,L1 FLAG(SET1(I)) = CUR_EL ENDDO ENDIF INTER = 0 DO I=1,L2 IF(FLAG(SET2(I)) .EQ. CUR_EL) THEN INTER = INTER + 1 FLAG(SET2(I)) = CUR_EL_PATH ENDIF ENDDO MERGE = L1 + L2 - INTER DMUMPS_METRIC2x2 = dble(INTER) / dble(MERGE) ELSE IF (T .EQ. MA47) THEN MERGE = 3 IF(DIAG(CUR_EL) .NE. 0) MERGE = 2 IF(DIAG(CUR_EL_PATH) .NE. 0) MERGE = MERGE - 2 IF(MERGE .EQ. 0) THEN DMUMPS_METRIC2x2 = dble(L1+L2-2) DMUMPS_METRIC2x2 = -(DMUMPS_METRIC2x2**2)/2.0D0 ELSE IF(MERGE .EQ. 1) THEN DMUMPS_METRIC2x2 = - dble(L1+L2-4) * dble(L1-2) ELSE IF(MERGE .EQ. 2) THEN DMUMPS_METRIC2x2 = - dble(L1+L2-4) * dble(L2-2) ELSE DMUMPS_METRIC2x2 = - dble(L1-2) * dble(L2-2) ENDIF ELSE DMUMPS_METRIC2x2 = VAL ENDIF RETURN END FUNCTION SUBROUTINE DMUMPS_EXPAND_PERM_SCHUR(NA, NCMP, & INVPERM,PERM, & LISTVAR_SCHUR, SIZE_SCHUR, AOTOA) IMPLICIT NONE INTEGER, INTENT(IN):: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN):: NA, NCMP INTEGER, INTENT(IN):: AOTOA(NCMP), PERM(NCMP) INTEGER, INTENT(OUT):: INVPERM(NA) INTEGER CMP_POS, IO, I, K, IPOS DO CMP_POS=1, NCMP IO = PERM(CMP_POS) INVPERM(AOTOA(IO)) = CMP_POS ENDDO IPOS = NCMP DO K =1, SIZE_SCHUR I = LISTVAR_SCHUR(K) IPOS = IPOS+1 INVPERM(I) = IPOS ENDDO RETURN END SUBROUTINE DMUMPS_EXPAND_PERM_SCHUR SUBROUTINE DMUMPS_GNEW_SCHUR & (NA, N, NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, NBQD, AvgDens, & KEEP264, KEEP265, & LISTVAR_SCHUR, SIZE_SCHUR, ATOAO, AOTOA, & INPLACE64_GRAPH_COPY & ) IMPLICIT NONE INTEGER, intent(in) :: NA INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, intent(out) :: IERROR, symmetry INTEGER, intent(out) :: NBQD, AvgDens INTEGER, intent(out) :: LEN(N), IW(LW) INTEGER(8), intent(out):: IWFR INTEGER(8), intent(out):: NRORM, NIORM INTEGER(8), intent(out):: IPE(N+1) INTEGER, INTENT(OUT) :: AOTOA(N) INTEGER, INTENT(OUT) :: ATOAO(NA) INTEGER, intent(inout) :: IFLAG, KEEP264 INTEGER, intent(in) :: KEEP265 INTEGER(8), intent(out):: IQ(N) INTEGER, intent(out) :: FLAG(N) LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, MPG, I, J, N1 INTEGER :: NBERR, THRESH, IAO INTEGER(8) :: K8, K1, K2, LAST, NDUP INTEGER(8) :: NZOFFA, NDIAGA, L, N8 DOUBLE PRECISION :: RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) ATOAO(1:NA) = 0 DO I = 1, SIZE_SCHUR ATOAO(LISTVAR_SCHUR(I)) = -1 ENDDO IAO = 0 DO I= 1, NA IF (ATOAO(I).LT.0) CYCLE IAO = IAO +1 ATOAO(I) = IAO AOTOA(IAO) = I ENDDO NZOFFA = 0_8 NDIAGA = 0 IERROR = 0 N8 = int(N,8) DO I=1,N+1 IPE(I) = 0_8 ENDDO IF (KEEP264.EQ.0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ENDIF IF (IERROR.GE.1) THEN KEEP264 = 0 ELSE KEEP264 = 1 ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.EQ.J) THEN NDIAGA = NDIAGA + 1_8 ELSE IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDDO ENDIF ENDIF NIORM = NZOFFA + 3_8*N8 IF (IERROR.GE.1) THEN NBERR = 0 IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN WRITE (MP,99999) DO 70 K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR. & (10_8.LE.K8 .AND. K8.LE.20_8)) THEN WRITE (MP,'(I16,A,I10,A,I10,A)') & K8,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K8,10_8).EQ.1_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'st entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.2_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.3_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2_8*N8 IQ(1) = 1_8 N1 = N - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(N)+IQ(N)-1,IQ(N)) FLAG(1:N) = 0 IPE(1:N) = IQ(1:N) IW(1:LAST) = 0 IWFR = LAST + 1_8 IF (KEEP264 .EQ. 0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF (I.LT.J) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDDO ENDIF ENDIF IF (KEEP265.EQ.0) THEN NDUP = 0_8 DO I=1,N K1 = IPE(I) K2 = IQ(I) - 1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) EXIT IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE L = IQ(J) IQ(J) = L + 1 IW(L) = I IW(K8) = J FLAG(J) = I ENDIF END DO LEN(I) = int(IQ(I) - IPE(I)) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,N IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K1 = IPE(I) K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF 270 CONTINUE LEN(I) = int(IWFR - L) ENDDO ENDIF IPE(N+1) = IPE(N) + int(LEN(N),8) IWFR = IPE(N+1) ELSE IPE(1) = 1_8 DO I = 1, N LEN(I) = int(IQ(I) - IPE(I)) ENDDO DO I = 1, N IPE(I+1) = IPE(I) + int(LEN(I),8) ENDDO IWFR = IPE(N+1) ENDIF symmetry = 100 IF (SYM.EQ.0) THEN RSYM = dble(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/ & dble(NZOFFA+NDIAGA) IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) THEN ENDIF symmetry = nint (100.0D0*RSYM) IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) ) & write(MPG,'(A,A,I5)') & ' Case of Schur:', & ' structural symmetry (in percent) of interior block=', & symmetry IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) ) & write(MP,'(A,A,I5)') & ' Case of Schur:', & ' structural symmetry (in percent) of interior block=', & symmetry ELSE symmetry = 100 ENDIF INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1)) AvgDens = nint(dble(IWFR-1_8)/dble(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN DO I= 1, N J = max(LEN(I),1) IF (J.GT.THRESH) NBQD = NBQD+1 ENDDO ENDIF IF (MPG .GT. 0.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE DMUMPS_GNEW_SCHUR SUBROUTINE DMUMPS_GET_PERM_FROM_PE(N,PE,INVPERM,NFILS,WORK) IMPLICIT NONE INTEGER N INTEGER PE(N),INVPERM(N),NFILS(N),WORK(N) INTEGER I,FATHER,STKLEN,STKPOS,PERMPOS,CURVAR NFILS = 0 DO I=1,N FATHER = -PE(I) IF(FATHER .NE. 0) NFILS(FATHER) = NFILS(FATHER) + 1 ENDDO STKLEN = 0 PERMPOS = 1 DO I=1,N IF(NFILS(I) .EQ. 0) THEN STKLEN = STKLEN + 1 WORK(STKLEN) = I INVPERM(I) = PERMPOS PERMPOS = PERMPOS + 1 ENDIF ENDDO DO STKPOS = 1,STKLEN CURVAR = WORK(STKPOS) FATHER = -PE(CURVAR) DO IF(FATHER .EQ. 0) EXIT IF(NFILS(FATHER) .EQ. 1) THEN INVPERM(FATHER) = PERMPOS FATHER = -PE(FATHER) PERMPOS = PERMPOS + 1 ELSE NFILS(FATHER) = NFILS(FATHER) - 1 EXIT ENDIF ENDDO ENDDO RETURN END SUBROUTINE DMUMPS_GET_PERM_FROM_PE SUBROUTINE DMUMPS_GET_ELIM_TREE(N,PE,NV,WORK) IMPLICIT NONE INTEGER N INTEGER PE(N),NV(N),WORK(N) INTEGER I,FATHER,LEN,NEWSON,NEWFATHER DO I=1,N IF(NV(I) .GT. 0) CYCLE LEN = 1 WORK(LEN) = I FATHER = -PE(I) DO IF(NV(FATHER) .GT. 0) THEN NEWSON = FATHER EXIT ENDIF LEN = LEN + 1 WORK(LEN) = FATHER NV(FATHER) = 1 FATHER = -PE(FATHER) ENDDO NEWFATHER = -PE(FATHER) PE(WORK(LEN)) = -NEWFATHER PE(NEWSON) = -WORK(1) ENDDO END SUBROUTINE DMUMPS_GET_ELIM_TREE MUMPS_5.8.1/src/zsol_c.F0000664000175000017500000031745415042446441014647 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SOL_C(root, roota, N, A, LA, IW, LIW, W, LWC, & IWCB, LIWW, NRHS, NA, LNA, NE_STEPS, W2, MTYPE, ICNTL, FROM_PP, & STEP, FRERE, DAD, FILS, PTRIST, PTRFAC, IW1, LIW1, PTRACB, & LIWK_PTRACB, PROCNODE_STEPS, SLAVEF, INFO, KEEP,KEEP8, DKEEP, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IBEG_ROOT_DEF, IEND_ROOT_DEF, & IROOT_DEF_RHS_COL1, RHS_ROOT, LRHS_ROOT, SIZE_ROOT, MASTER_ROOT, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, POSINRHSINTR_BWD, & Lnodes_FWD, Lnodes_BWD, & nodes_FWD, nodes_BWD, & NZ_RHS, NBCOL_INBLOC, JBEG_RHS, Step2node, LStep2node, & IRHS_SPARSE, IRHS_PTR, SIZE_PERM_RHS, PERM_RHS, & SIZE_UNS_PERM_INV, UNS_PERM_INV, NB_FS_IN_RHSINTR_F, & NB_FS_IN_RHSINTR_TOT, DO_NBSPARSE , RHS_BOUNDS, LRHS_BOUNDS #if defined(STAT_ES_SOLVE) & , IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING #endif & ,IPOOL_B_L0_OMP, LPOOL_B_L0_OMP, IPOOL_A_L0_OMP, LPOOL_A_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) USE ZMUMPS_OOC USE ZMUMPS_SOL_ES USE ZMUMPS_SOL_L0OMP_M, ONLY : ZMUMPS_SOL_L0OMP_R, & ZMUMPS_SOL_L0OMP_S USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC & , ZMUMPS_L0OMPFAC_T IMPLICIT NONE #if defined(V_T) INCLUDE 'VT.inc' #endif TYPE ( MUMPS_ROOT_STRUC ) :: root TYPE ( ZMUMPS_ROOT_STRUC ) :: roota INTEGER(8) :: LA INTEGER(8) :: LWC INTEGER :: N,LIW,MTYPE,LIW1,LIWW,LNA INTEGER ICNTL(60),INFO(80), KEEP(500) DOUBLE PRECISION, intent(inout) :: DKEEP(230) INTEGER(8) KEEP8(150) INTEGER IW(LIW),IW1(LIW1),NA(LNA),NE_STEPS(KEEP(28)),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)), FILS(N), PTRIST(KEEP(28)), & DAD(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER :: LIWK_PTRACB INTEGER(8) :: PTRACB(LIWK_PTRACB) INTEGER NRHS, LRHSINTR, NB_FS_IN_RHSINTR_F, NB_FS_IN_RHSINTR_TOT COMPLEX(kind=8) A(LA), W(LWC), & W2(KEEP(133)) COMPLEX(kind=8) :: RHSINTR(LRHSINTR,NRHS) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER PROCNODE_STEPS(KEEP(28)), POSINRHSINTR_FWD(N), & POSINRHSINTR_BWD(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, IROOT_DEF_RHS_COL1 INTEGER NRHS_LOC INTEGER SIZE_ROOT, MASTER_ROOT INTEGER(8) :: LRHS_ROOT COMPLEX(kind=8) RHS_ROOT(LRHS_ROOT) LOGICAL, intent(in) :: FROM_PP INTEGER, intent(in) :: Lnodes_FWD, Lnodes_BWD INTEGER, intent(in) :: nodes_FWD(max(1,Lnodes_FWD)), & nodes_BWD(max(1,Lnodes_BWD)) INTEGER, intent(in) :: NZ_RHS, NBCOL_INBLOC INTEGER, intent(in) :: SIZE_UNS_PERM_INV INTEGER, intent(in) :: SIZE_PERM_RHS INTEGER, intent(in) :: JBEG_RHS INTEGER, intent(in) :: IRHS_SPARSE(NZ_RHS) INTEGER, intent(in) :: IRHS_PTR(NBCOL_INBLOC+1) INTEGER, intent(in) :: PERM_RHS(SIZE_PERM_RHS) INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, intent(in) :: LStep2node INTEGER, intent(in) :: Step2node(LStep2node) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(inout) :: RHS_BOUNDS (LRHS_BOUNDS) #if defined(STAT_ES_SOLVE) INTEGER, INTENT(IN) :: SIZE_WORKING, SIZE_IPTR_WORKING, & IPTR_WORKING(SIZE_IPTR_WORKING), & WORKING(SIZE_WORKING) #endif INTEGER, INTENT (IN) :: LPOOL_B_L0_OMP INTEGER, INTENT (IN) :: IPOOL_B_L0_OMP( LPOOL_B_L0_OMP ) INTEGER, INTENT (IN) :: LPOOL_A_L0_OMP INTEGER, INTENT (IN) :: IPOOL_A_L0_OMP( LPOOL_A_L0_OMP ) INTEGER, INTENT (IN) :: L_PHYS_L0_OMP INTEGER, INTENT (INOUT) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT (IN) :: L_VIRT_L0_OMP INTEGER, INTENT (IN) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT (IN) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT (IN) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT (IN) :: LL0_OMP_MAPPING INTEGER, INTENT (IN) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INTEGER, INTENT (IN) :: LL0_OMP_FACTORS TYPE (ZMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER MP, LP, LDIAG INTEGER K,I,II INTEGER allocok INTEGER LPOOL,MYLEAF,MYROOT,NBROOT,LPANEL_POS INTEGER MYLEAF_NOT_PRUNED INTEGER NSTK_S,IPOOL,IPANEL_POS,PTRICB INTEGER MTYPE_LOC INTEGER MODE_RHS_BOUNDS INTEGER IPT_RHS_ROOT_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 LOGICAL DOFORWARD, DOROOT, DOBACKWARD LOGICAL :: DO_L0OMP_FWD, DO_L0OMP_BWD LOGICAL I_WORKED_ON_ROOT, SPECIAL_ROOT_REACHED INTEGER IROOT LOGICAL DOROOT_FWD_OOC, DOROOT_BWD_PANEL LOGICAL DUMMY_BOOL INTEGER :: IDUMMY INTEGER :: NBROOT_UNDER_L0 COMPLEX(kind=8), PARAMETER :: ZERO = (0.0D0,0.0D0) INCLUDE 'mumps_headers.h' INTEGER, DIMENSION(:), POINTER :: nodes_BWD_PTR INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: Pruned_Roots_FWD INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: Pruned_Roots_NS INTEGER :: Lnodes_BWD_PTR, LPruned_Roots_NS INTEGER :: Lnodes_BWD_ROOTS INTEGER nb_prun_leaves INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_Leaves INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_List INTEGER nb_prun_nodes INTEGER INODE_PRINC, nb_prun_roots INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_SONS, Pruned_Roots INTEGER :: SIZE_TO_PROCESS LOGICAL, DIMENSION(:), ALLOCATABLE :: TO_PROCESS INTEGER ISTEP INTEGER :: INODE, ICHILD LOGICAL AM1, DO_PRUN_FWD, DO_PRUN_BWD LOGICAL Exploit_Sparsity_FWD, Exploit_Sparsity_BWD LOGICAL DO_NBSPARSE_BWD, PRUN_BELOW_BWD INTEGER :: OOC_FCT_TYPE_TMP INTEGER :: MUMPS_OOC_GET_FCT_TYPE EXTERNAL :: MUMPS_OOC_GET_FCT_TYPE DOUBLE PRECISION TIME_FWD,TIME_BWD,TIME_SpecialRoot INTEGER :: nb_sparse INTEGER, EXTERNAL :: MUMPS_PROCNODE LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR MYLEAF = -1 LP = ICNTL(1) MP = ICNTL(2) LDIAG = ICNTL(4) CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, MYID ) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 #if defined(V_T) CALL VTCLASSDEF( 'Soln_c',soln_c_class,ierr) CALL VTFUNCDEF( 'forw_soln',soln_c_class,forw_soln,ierr) CALL VTFUNCDEF( 'back_soln',soln_c_class,back_soln,ierr) CALL VTFUNCDEF( 'root_soln',soln_c_class,root_soln,ierr) #endif IF (.NOT. FROM_PP) THEN CALL MUMPS_SECDEB(TIME_FWD) ENDIF NSTK_S = 1 PTRICB = NSTK_S + KEEP(28) IPOOL = PTRICB + KEEP(28) LPOOL = NA(1) + 1 IPANEL_POS = IPOOL + LPOOL IF (KEEP(201).EQ.1) THEN LPANEL_POS = KEEP(228)+1 ELSE LPANEL_POS = 1 ENDIF IF (IPANEL_POS + LPANEL_POS -1 .ne. LIW1 ) THEN WRITE(*,*) MYID, ": Internal Error 1 in ZMUMPS_SOL_C", & IPANEL_POS, LPANEL_POS, LIW1 CALL MUMPS_ABORT() ENDIF KEEP(405)=0 DOFORWARD = .TRUE. DOBACKWARD= .TRUE. SPECIAL_ROOT_REACHED = .TRUE. 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_FWD = (KEEP(235) .NE. 0) .AND. (.NOT. AM1) Exploit_Sparsity_BWD = (KEEP(212) .NE. 0) .AND. (.NOT. AM1) Lnodes_BWD_ROOTS = NA(2) DO_PRUN_FWD = (Exploit_Sparsity_FWD.OR.AM1) DO_PRUN_BWD = (Exploit_Sparsity_BWD.OR.AM1) IF (FROM_PP) THEN Exploit_Sparsity_FWD = .FALSE. DO_PRUN_FWD = .FALSE. Exploit_Sparsity_BWD = .FALSE. DO_PRUN_BWD = .FALSE. IF ( AM1 ) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_SOL_C" CALL MUMPS_ABORT() ENDIF ENDIF DO_L0OMP_FWD= ( (KEEP(401).EQ.1).AND.(KEEP(400).GT.0) & .AND.DOFORWARD ) DO_L0OMP_FWD = DO_L0OMP_FWD .AND. KEEP(201).EQ.0 DO_L0OMP_BWD = ( (KEEP(401).EQ.1).AND.(KEEP(400).GT.0) & .AND.DOBACKWARD ) DO_L0OMP_BWD = DO_L0OMP_BWD .AND. KEEP(201).EQ.0 IF ( DO_PRUN_FWD.OR.DO_PRUN_BWD ) THEN ALLOCATE (Pruned_SONS(KEEP(28)), stat=I) IF(I.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ENDIF IF ( DO_PRUN_FWD.OR.DO_PRUN_BWD & .OR. DO_L0OMP_BWD & ) THEN SIZE_TO_PROCESS = KEEP(28) ELSE SIZE_TO_PROCESS = 1 ENDIF ALLOCATE (TO_PROCESS(SIZE_TO_PROCESS), stat=I) IF(I.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 IF ( DOFORWARD .AND. DO_PRUN_FWD ) THEN CALL ZMUMPS_CHAIN_PRUN_NODES( & .FALSE., & DAD, KEEP(28), & STEP, N, & nodes_FWD, Lnodes_FWD, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, & nb_prun_leaves ) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL ZMUMPS_CHAIN_PRUN_NODES( & .TRUE., & DAD, KEEP(28), & STEP, N, & nodes_FWD, Lnodes_FWD, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves ) CALL ZMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF ( KEEP(201) .GT. 0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('F',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL ZMUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), & KEEP8(31)+KEEP8(64), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP #if defined(STAT_ES_SOLVE) & , NRHS, COMM_NODES, IW, LIW, PTRIST,KEEP(IXSZ),0, & KEEP(50), KEEP(38) #endif & ) IF (DO_NBSPARSE) THEN nb_sparse = max(1,KEEP(497)) MODE_RHS_BOUNDS = 0 IF (Exploit_Sparsity_FWD) MODE_RHS_BOUNDS = 2 CALL ZMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243), & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23), & RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & MODE_RHS_BOUNDS) CALL ZMUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, KEEP(485), #if defined(STAT_ES_SOLVE) & KEEP(46), & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, #endif & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,0, & KEEP(50), KEEP(38)) END IF SPECIAL_ROOT_REACHED = .FALSE. DO I= 1, nb_prun_roots IF ( (Pruned_Roots(I).EQ.KEEP(38)).OR. & (Pruned_Roots(I).EQ.KEEP(20)) ) THEN SPECIAL_ROOT_REACHED = .TRUE. EXIT ENDIF ENDDO DEALLOCATE(Pruned_List) ENDIF IF (KEEP(201).GT.0) THEN IF (DOFORWARD .OR. DOROOT_FWD_OOC) THEN CALL ZMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,KEEP(28),MTYPE, & A,LA,DOFORWARD,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (DOFORWARD) THEN IF ( KEEP( 50 ) .eq. 0 ) THEN MTYPE_LOC = MTYPE ELSE MTYPE_LOC = 1 ENDIF #if defined(V_T) CALL VTBEGIN(forw_soln,ierr) #endif IF ( .NOT. DO_PRUN_FWD ) THEN CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, MYROOT, MYID_NODES, & SLAVEF, NA, LNA, KEEP, STEP, PROCNODE_STEPS) DO ISTEP =1, KEEP(28) IW1(NSTK_S+ISTEP-1) = NE_STEPS(ISTEP) ENDDO ELSE CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & nb_prun_roots, Pruned_Roots, & MYROOT, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) IF ((Exploit_Sparsity_FWD).AND.(nb_prun_roots.NE.NA(2))) THEN Lnodes_BWD_ROOTS = nb_prun_roots ALLOCATE(Pruned_Roots_FWD(Lnodes_BWD_ROOTS), STAT=allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of nodes_FWD' INFO(1) = -13 INFO(2) = Lnodes_BWD_ROOTS CALL MUMPS_ABORT() END IF Pruned_Roots_FWD(1:Lnodes_BWD_ROOTS)= & Pruned_Roots(1:Lnodes_BWD_ROOTS) DEALLOCATE(Pruned_Roots) ELSE DEALLOCATE(Pruned_Roots) ENDIF DO ISTEP = 1, KEEP(28) IW1(NSTK_S+ISTEP-1) = Pruned_SONS(ISTEP) ENDDO ENDIF IF ( DO_L0OMP_FWD ) THEN KEEP(405)=1 CALL ZMUMPS_SOL_L0OMP_R( N, MTYPE_LOC, NRHS, LIW, IW, & IW1(PTRICB), RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & STEP, FRERE, DAD, FILS, IW1(NSTK_S), & PTRIST, PTRFAC, INFO, & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, & FROM_PP, & NBROOT_UNDER_L0, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, & L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS, & DO_PRUN_FWD, TO_PROCESS & ) CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, & INFO, MYID ) IF (INFO(1).LT.0) THEN CALL ZMUMPS_BDC_ERROR(MYID_NODES, SLAVEF, COMM_NODES, KEEP) ENDIF KEEP(405)=0 MYROOT = MYROOT - NBROOT_UNDER_L0 ENDIF IF ( DO_L0OMP_FWD ) THEN IF ( DO_PRUN_FWD ) THEN MYLEAF_NOT_PRUNED = IPOOL_A_L0_OMP(LPOOL_A_L0_OMP) DO I=1, MYLEAF_NOT_PRUNED IF ( TO_PROCESS( STEP( IPOOL_A_L0_OMP(I) ))) THEN IW1(IPOOL+MYLEAF-1) = IPOOL_A_L0_OMP(I) IW1(NSTK_S+STEP(IPOOL_A_L0_OMP(I))-1) = -99 ENDIF ENDDO DO I = 1, nb_prun_leaves INODE = Pruned_Leaves(I) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) & .EQ. MYID_NODES ) THEN IF (L0_OMP_MAPPING( STEP(INODE) ) .EQ. 0) THEN IW1(NSTK_S+STEP(INODE)-1) = -99 ENDIF ENDIF ENDDO DO I = 1, L_PHYS_L0_OMP INODE = DAD(STEP(PHYS_L0_OMP(I))) IF (INODE .NE. 0) THEN IF ( TO_PROCESS( STEP( INODE ))) THEN IF ( IW1(NSTK_S+STEP(INODE)-1) .EQ. 0 ) THEN IW1(NSTK_S+STEP(INODE)-1) = -99 ENDIF ENDIF ENDIF ENDDO MYLEAF = 0 DO ISTEP = KEEP(28), 1, -1 INODE=Step2Node(ISTEP) IF (IW1(NSTK_S+STEP(INODE)-1).EQ.-99) THEN MYLEAF = MYLEAF + 1 IW1(IPOOL+MYLEAF-1) = INODE IW1(NSTK_S+STEP(INODE)-1) = 0 ENDIF ENDDO DEALLOCATE(Pruned_Leaves) ELSE MYLEAF = IPOOL_A_L0_OMP(LPOOL_A_L0_OMP) DO I=1, MYLEAF IW1(IPOOL+I-1) = IPOOL_A_L0_OMP(I) ENDDO ENDIF ELSE IF ( DO_PRUN_FWD ) THEN CALL MUMPS_INIT_POOL_DIST_NONA( N, MYLEAF, MYID_NODES, & nb_prun_leaves, Pruned_Leaves, KEEP, KEEP8, & STEP, PROCNODE_STEPS, IW1(IPOOL), LPOOL ) MYLEAF = MYLEAF - 1 DEALLOCATE(Pruned_Leaves) ELSE CALL MUMPS_INIT_POOL_DIST( N, MYLEAF, MYID_NODES, & SLAVEF, NA, LNA, KEEP, KEEP8, STEP, & PROCNODE_STEPS, IW1(IPOOL), LPOOL ) MYLEAF = MYLEAF - 1 ENDIF ENDIF CALL ZMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1), & LWC, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSINTR,LRHSINTR,POSINRHSINTR_FWD, & STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF, MYROOT, INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE_LOC, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) IF (DO_PRUN_FWD) THEN MYLEAF = -1 ENDIF #if defined(V_T) CALL VTEND(forw_soln,ierr) #endif ENDIF CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, MYID ) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) THEN IF ( LP .GT. 0 ) THEN WRITE(LP,*) MYID, & ': ** ERROR RETURN FROM ZMUMPS_SOL_R,INFO(1:2)=', & INFO(1:2) END IF GOTO 500 END IF CALL MPI_BARRIER( COMM_NODES, IERR ) IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_FWD) DKEEP(117)=TIME_FWD + DKEEP(117) ENDIF IF ( .NOT.( & DOBACKWARD.AND. & (DO_PRUN_BWD.OR.(Lnodes_BWD_ROOTS.NE.NA(2))) & ) & ) THEN IF (.NOT. DO_L0OMP_BWD ) THEN IF ( allocated(TO_PROCESS) .AND. SIZE_TO_PROCESS.NE.1 ) THEN DEALLOCATE (TO_PROCESS) SIZE_TO_PROCESS = 1 ALLOCATE(TO_PROCESS(SIZE_TO_PROCESS),stat=I) ENDIF ENDIF ENDIF IF ( (KEEP(111).NE.0).AND.DOBACKWARD.AND. & ( & DO_PRUN_BWD & ) & ) THEN nb_prun_leaves = 0 IF ( Lnodes_BWD_ROOTS.NE.NA(2) ) THEN nodes_BWD_PTR => Pruned_Roots_FWD Lnodes_BWD_PTR = Lnodes_BWD_ROOTS ELSE IF ( (Exploit_Sparsity_BWD.AND.KEEP(111).NE.0) & ) THEN LPruned_Roots_NS = 0 Pruned_SONS(:) = -1 DO II = 1, NZ_RHS I = IRHS_SPARSE(II) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) ISTEP = abs(STEP(I)) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN LPruned_Roots_NS = LPruned_Roots_NS +1 Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ALLOCATE(Pruned_Roots_NS(LPruned_Roots_NS), STAT = allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of nodes_BWD' INFO(1) = -13 INFO(2) = LPruned_Roots_NS CALL MUMPS_ABORT() END IF LPruned_Roots_NS = 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 LPruned_Roots_NS = LPruned_Roots_NS +1 Pruned_Roots_NS(LPruned_Roots_NS) = INODE_PRINC Pruned_SONS(ISTEP) = 0 ENDIF ENDDO nodes_BWD_PTR => Pruned_Roots_NS Lnodes_BWD_PTR = LPruned_Roots_NS ENDIF IF ( & (Exploit_Sparsity_BWD.AND.KEEP(111).NE.0) .OR. & (Lnodes_BWD_ROOTS.NE.NA(2)) & ) THEN CALL ZMUMPS_TREE_PRUN_NODES( & .FALSE., & DAD, NE_STEPS, FRERE, KEEP(28), & FILS, STEP, N, & nodes_BWD_PTR, Lnodes_BWD_PTR, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves & ) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL ZMUMPS_TREE_PRUN_NODES( & .TRUE., & DAD, NE_STEPS, FRERE, KEEP(28), & FILS, STEP, N, & nodes_BWD_PTR, Lnodes_BWD_PTR, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IF(allocated(Pruned_Roots_NS)) DEALLOCATE(Pruned_Roots_NS) IF(allocated(Pruned_Roots_FWD)) DEALLOCATE(Pruned_Roots_FWD) CALL ZMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF ENDIF ENDIF IF(KEEP(201).EQ.1.AND.DOROOT_BWD_PANEL) THEN I_WORKED_ON_ROOT = .FALSE. CALL ZMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE, & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) IF (IERR .LT. 0) THEN INFO(1) = -90 INFO(2) = IERR ENDIF ENDIF IF (KEEP(201).EQ.1) THEN CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF IF (KEEP(60).NE.0 .AND. KEEP(221).EQ.0 & .AND. MYID_NODES .EQ. MASTER_ROOT) THEN RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO ENDIF IF (.NOT. FROM_PP) THEN CALL MUMPS_SECDEB(TIME_SpecialRoot) ENDIF IF ( ( KEEP( 38 ) .NE. 0 ).AND. SPECIAL_ROOT_REACHED ) THEN IF ( KEEP(60) .EQ. 0 .AND. KEEP(252) .EQ. 0 ) THEN IF ( root%yes ) THEN IF (KEEP(201).GT.0) THEN IF ( (Exploit_Sparsity_FWD.AND.(KEEP(111).NE.0)) .and. & (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) ) THEN GOTO 1010 ENDIF ENDIF IOLDPS = PTRIST(STEP(KEEP(38))) LOCAL_M = IW( IOLDPS + 2 + KEEP(IXSZ)) LOCAL_N = IW( IOLDPS + 1 + KEEP(IXSZ)) IF (KEEP(201).GT.0) THEN CALL ZMUMPS_SOLVE_GET_OOC_NODE( & KEEP(38),PTRFAC,KEEP,A,LA, & STEP,KEEP8,N,DUMMY_BOOL,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) '** ERROR after ZMUMPS_SOLVE_GET_OOC_NODE', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF IAPOS = PTRFAC(IW( IOLDPS + 4 + KEEP(IXSZ))) IF (LOCAL_M * LOCAL_N .EQ. 0) THEN IAPOS = min(IAPOS, LA) ENDIF #if defined(V_T) CALL VTBEGIN(root_soln,ierr) #endif CALL ZMUMPS_ROOT_SOLVE( NRHS, root%DESCRIPTOR(1), & root%CNTXT_BLACS, LOCAL_M, LOCAL_N, & root%MBLOCK, root%NBLOCK, & root%IPIV(1), root%LPIV, MASTER_ROOT, MYID_NODES, & COMM_NODES, & RHS_ROOT(1), & root%TOT_ROOT_SIZE, A( IAPOS ), & INFO(1), MTYPE, KEEP(50), FROM_PP) IF(KEEP(201).GT.0)THEN CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE(KEEP(38), & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) & '** ERROR after ZMUMPS_FREE_FACTORS_FOR_SOLVE ', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF ENDIF ENDIF ELSE IF ( ( KEEP(20) .NE. 0) .AND. SPECIAL_ROOT_REACHED ) THEN IF ( MYID_NODES .eq. MASTER_ROOT ) THEN IF ( KEEP(60) .eq. 0 ) THEN IF (KEEP(201).GT.0) THEN CALL ZMUMPS_SOLVE_GET_OOC_NODE( & KEEP(20),PTRFAC,KEEP,A,LA, & STEP,KEEP8,N,DUMMY_BOOL,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) '** ERROR after ZMUMPS_SOLVE_GET_OOC_NODE', & INFO(1) call MUMPS_ABORT() ENDIF END IF NRHS_LOC = NRHS IPT_RHS_ROOT_LOC = 1 IF ( KEEP(111).NE.0 ) THEN RHS_ROOT( 1: NRHS*SIZE_ROOT) = ZERO NRHS_LOC = IEND_ROOT_DEF - IBEG_ROOT_DEF + 1 IPT_RHS_ROOT_LOC = IPT_RHS_ROOT_LOC + & (IROOT_DEF_RHS_COL1-1)*SIZE_ROOT ENDIF IF (NRHS_LOC .GT. 0) THEN CALL ZMUMPS_SEQ_SOLVE_ROOT_SVD_QR(NRHS_LOC, & SIZE_ROOT,A( PTRFAC( & IW( PTRIST(STEP(KEEP(20)))+4+KEEP(IXSZ)))), & root, roota, IBEG_ROOT_DEF, IEND_ROOT_DEF, & RHS_ROOT( IPT_RHS_ROOT_LOC ), & KEEP,KEEP8, & MTYPE,INFO,LWC,W(1), LP) ENDIF IF(KEEP(201).GT.0)THEN CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE(KEEP(20), & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) & '** ERROR after ZMUMPS_FREE_FACTORS_FOR_SOLVE ', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF ENDIF END IF END IF IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_SpecialRoot) DKEEP(119)=TIME_SpecialRoot + DKEEP(119) ENDIF #if defined(V_T) CALL VTEND(root_soln,ierr) #endif 1010 CONTINUE CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) RETURN IF (DOBACKWARD) THEN IF ( KEEP(201).GT.0 .AND. .NOT. DOROOT_BWD_PANEL ) & THEN I_WORKED_ON_ROOT = DOROOT IF (KEEP(38).gt.0 ) THEN IF ( ( Exploit_Sparsity_FWD.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_FWD.AND.(KEEP(111).NE.0)) THEN IF (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) THEN I_WORKED_ON_ROOT = .FALSE. ENDIF ENDIF ENDIF ENDIF IF (.NOT.AM1) THEN DO_NBSPARSE_BWD = .FALSE. ELSE DO_NBSPARSE_BWD = DO_NBSPARSE ENDIF PRUN_BELOW_BWD = DO_PRUN_BWD .AND. KEEP(111).EQ.0 PRUN_BELOW_BWD = PRUN_BELOW_BWD .OR. DO_L0OMP_BWD IF ( DO_PRUN_BWD ) THEN CALL ZMUMPS_CHAIN_PRUN_NODES( & .FALSE., & DAD, KEEP(28), & STEP, N, & nodes_BWD, Lnodes_BWD, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, & nb_prun_leaves) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL ZMUMPS_CHAIN_PRUN_NODES( & .TRUE., & DAD, KEEP(28), & STEP, N, & nodes_BWD, Lnodes_BWD, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves ) CALL ZMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL ZMUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP #if defined(STAT_ES_SOLVE) & , NRHS, COMM_NODES, IW, LIW, PTRIST,KEEP(IXSZ),1, & KEEP(50), KEEP(38) #endif & ) IF (DO_NBSPARSE_BWD) THEN nb_sparse = max(1,KEEP(497)) CALL ZMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243), & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23), & RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & 1) CALL ZMUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, KEEP(485), #if defined(STAT_ES_SOLVE) & KEEP(46), & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, #endif & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,1, & KEEP(50), KEEP(38)) END IF ENDIF IF ( KEEP(201).GT.0 ) THEN IROOT = max(KEEP(20),KEEP(38)) CALL ZMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE, & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) ENDIF IF ( KEEP( 50 ) .eq. 0 ) THEN MTYPE_LOC = MTYPE ELSE MTYPE_LOC = 0 ENDIF #if defined(V_T) CALL VTBEGIN(back_soln,ierr) #endif IF (.NOT.FROM_PP) THEN CALL MUMPS_SECDEB(TIME_BWD) ENDIF IF ( .NOT.SPECIAL_ROOT_REACHED ) THEN RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO ENDIF IF (AM1.AND.(NB_FS_IN_RHSINTR_F.NE.NB_FS_IN_RHSINTR_TOT)) THEN DO I =1, N II = POSINRHSINTR_BWD(I) IF ((II.GT.0).AND.(II.GT.NB_FS_IN_RHSINTR_F)) THEN DO K=1,NRHS RHSINTR(II, K) = ZERO ENDDO ENDIF ENDDO ENDIF IF ( .NOT. DO_PRUN_BWD ) THEN IF ( .NOT. DO_L0OMP_BWD ) THEN IF (DO_L0OMP_FWD) THEN MYLEAF = -1 ENDIF ENDIF IF ( DO_L0OMP_BWD ) THEN TO_PROCESS(:) = .TRUE. DO I=1, L_PHYS_L0_OMP TO_PROCESS( STEP(PHYS_L0_OMP( I ))) & = .FALSE. ENDDO IF (MYLEAF .EQ. -1) THEN MYLEAF = IPOOL_A_L0_OMP(LPOOL_A_L0_OMP) ENDIF CALL MUMPS_INIT_POOL_DIST_NA_BWD_L0( N, MYROOT, MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL, L0_OMP_MAPPING ) ELSE CALL MUMPS_INIT_POOL_DIST_NA_BWD( N, MYROOT, MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL ) IF (MYLEAF .EQ. -1) THEN CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & NA(1), & NA(3), & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) ENDIF ENDIF ELSE IF ( DO_L0OMP_BWD ) THEN DO I=1, L_PHYS_L0_OMP IF ( TO_PROCESS( STEP(PHYS_L0_OMP( I ))) ) THEN TO_PROCESS( STEP(PHYS_L0_OMP( I ))) = .FALSE. PHYS_L0_OMP( I ) = -PHYS_L0_OMP( I ) ENDIF ENDDO MYLEAF=0 DO ISTEP = 1, KEEP(28) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199)) & .NE. MYID_NODES ) THEN CYCLE ENDIF IF ( L0_OMP_MAPPING( ISTEP ) .NE. 0 ) THEN CYCLE ENDIF IF ( .NOT. TO_PROCESS( ISTEP ) ) THEN CYCLE ENDIF I = Step2Node( ISTEP ) ICHILD = FILS ( I ) DO WHILE ( ICHILD .GT. 0 ) ICHILD = FILS( ICHILD ) END DO IF ( ICHILD .LT. 0 ) THEN ICHILD = -ICHILD DO WHILE ( ICHILD .GT. 0 ) IF ( L0_OMP_MAPPING( STEP( ICHILD ) ) .EQ. 0 .AND. & TO_PROCESS(STEP( ICHILD )) ) THEN GOTO 10 ENDIF ICHILD = FRERE( STEP( ICHILD ) ) ENDDO ENDIF MYLEAF = MYLEAF + 1 10 CONTINUE ENDDO CALL MUMPS_INIT_POOL_DIST_NA_BWDL0ES( N, MYROOT, & MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL, L0_OMP_MAPPING, TO_PROCESS ) ELSE CALL MUMPS_INIT_POOL_DIST_BWD(N, nb_prun_roots, & Pruned_Roots, & MYROOT, MYID_NODES, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL) CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & nb_prun_leaves, Pruned_Leaves, & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) ENDIF ENDIF IF ( DO_L0OMP_BWD & ) THEN KEEP(31) = 1 ELSE KEEP(31) = 0 ENDIF IF (KEEP(31) .EQ. 1) THEN DO I = 1, KEEP(28) IF (MUMPS_PROCNODE(PROCNODE_STEPS(I),KEEP(199)) .EQ. & MYID_NODES) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(I), & KEEP(199)) ) THEN IF ( L0_OMP_MAPPING(I) .EQ. 0 ) THEN IF ( DO_PRUN_BWD & .OR. DO_L0OMP_BWD & ) THEN IF ( TO_PROCESS(I) ) THEN KEEP(31) = KEEP(31) + 1 ENDIF ELSE KEEP(31) = KEEP(31) + 1 ENDIF ENDIF ENDIF ENDIF ENDDO ENDIF CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, MYID ) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL ZMUMPS_SOL_S( N, A, LA, IW, LIW, W(1), LWC, & NRHS, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & IW1(PTRICB),PTRACB,IWCB,LIWW, W2, & NE_STEPS, & STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,MYROOT,ICNTL,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP, KEEP8, DKEEP, & RHS_ROOT, LRHS_ROOT, & MTYPE_LOC, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), & LPANEL_POS, PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE_BWD & , FROM_PP & , L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) IF ( DO_L0OMP_BWD .AND. DO_PRUN_BWD ) THEN DO I = 1, L_PHYS_L0_OMP IF ( PHYS_L0_OMP( I ) .LT. 0 ) THEN PHYS_L0_OMP( I ) = -PHYS_L0_OMP( I ) TO_PROCESS(STEP(PHYS_L0_OMP( I ) )) = .TRUE. ENDIF ENDDO ENDIF CALL MUMPS_STOP_ON_USER_REQUEST(KEEP, KEEP8, ICNTL, INFO, MYID) IF (DO_L0OMP_BWD .AND. INFO(1) .GE. 0) THEN KEEP(31) = 0 PRUN_BELOW_BWD = DO_PRUN_BWD .AND. KEEP(111).EQ.0 KEEP(405)=1 CALL ZMUMPS_SOL_L0OMP_S(N, MTYPE_LOC, NRHS, LIW, IW, & IW1(PTRICB), PTRACB, RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & STEP, FRERE, FILS, NE_STEPS, PTRIST, PTRFAC, INFO, & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & IW1(IPANEL_POS), LPANEL_POS, & PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE_BWD, & FROM_PP, & LPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, & L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS ) KEEP(405)=0 ENDIF CALL MUMPS_CLEAN_PENDING( INFO(1), KEEP, & BUFR, LBUFR,LBUFR_BYTES, & COMM_NODES, IDUMMY, & SLAVEF, .TRUE., .FALSE. ) CALL MUMPS_STOP_ON_USER_REQUEST(KEEP, KEEP8, ICNTL, INFO, MYID) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) #if defined(V_T) CALL VTEND(back_soln,ierr) #endif IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_BWD) DKEEP(118)=TIME_BWD+DKEEP(118) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (DOFORWARD) THEN K = min(10,size(RHSINTR,1)) IF (LDIAG.EQ.4) K = size(RHSINTR,1) IF ( .NOT. FROM_PP) THEN WRITE (MP,99992) IF (size(RHSINTR,1).GT.0) & WRITE (MP,99993) (RHSINTR(I,1),I=1,K) IF (size(RHSINTR,1).GT.0.and.NRHS>1) & WRITE (MP,99994) (RHSINTR(I,2),I=1,K) ENDIF ENDIF ENDIF 500 CONTINUE IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) IF (DO_PRUN_FWD.OR.DO_PRUN_BWD) THEN IF ( allocated(Pruned_Roots_FWD)) & DEALLOCATE (Pruned_Roots_FWD) IF ( allocated(Pruned_Roots_NS)) & DEALLOCATE (Pruned_Roots_NS) IF ( allocated(Pruned_SONS)) DEALLOCATE (Pruned_SONS) IF ( allocated(Pruned_Roots)) DEALLOCATE (Pruned_Roots) IF ( allocated(Pruned_List)) DEALLOCATE (Pruned_List) IF ( allocated(Pruned_Leaves)) DEALLOCATE (Pruned_Leaves) ENDIF RETURN 99993 FORMAT (' RHS (internal, first column)'/(1X,1P,5D14.6)) 99994 FORMAT (' RHS (internal, 2 nd column)'/(1X,1P,5D14.6)) 99992 FORMAT (//' LEAVING SOLVE (ZMUMPS_SOL_C) WITH') END SUBROUTINE ZMUMPS_SOL_C SUBROUTINE ZMUMPS_SET_POSTPros (KEEP, ICNTL, NBRHS, MPG, PROKG, & ICNTL10, ICNTL11, POSTPros) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP(500), ICNTL(60), NBRHS, MPG LOGICAL, INTENT(IN) :: PROKG INTEGER, INTENT(OUT) :: ICNTL10, ICNTL11 LOGICAL, INTENT(OUT) :: POSTPros POSTPros = .FALSE. IF (ICNTL11.NE.0 .OR. ICNTL10.NE.0) THEN POSTPros = .TRUE. IF (KEEP(111).NE.0) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: null space basis', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(237) .NE.0 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: AM1', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(252) .NE.0 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: Fwd in facto ', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF (KEEP(221).NE.0) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: reduced RHS', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF (NBRHS.GT. 1 .OR. ICNTL(21) .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: nrhs>1 or distrib sol', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(248) .EQ. -1 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: distrib rhs', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ENDIF IF (.NOT.POSTPros) THEN ICNTL11 = 0 ICNTL10 = 0 ENDIF ENDIF IF ((ICNTL(10) .NE. 0) .AND. (ICNTL10 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 ' ENDIF IF ((ICNTL(11) .NE. 0) & .AND.(ICNTL11 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF RETURN END SUBROUTINE ZMUMPS_SET_POSTPros SUBROUTINE ZMUMPS_GATHER_SOLUTION( NSLAVES, N, MYID, COMM, & NRHS, & MTYPE, RHS, LRHS, NCOL_RHS, JBEG_RHS, PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, CWORK, LCWORK, #if defined(USE_OLD_SCALING) & LSCAL, SCALING, LSCALING, #else & LSCAL, SCALING_LOC_BWD, LSCALING_LOC_BWD, #endif & RHSINTR, LRHSINTR, NCOL_RHSINTR, & POSINRHSINTR, LPOS_N, PERM_RHS, SIZE_PERM_RHS ) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE, NCOL_RHS INTEGER NRHS, LRHS, LCWORK, LPOS_N, NCOL_RHSINTR COMPLEX(kind=8) RHS (LRHS, NCOL_RHS) INTEGER, INTENT(in) :: JBEG_RHS INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX(kind=8) :: CWORK(LCWORK) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER SIZE_BUF, SIZE_BUF_BYTES INTEGER BUFFER(SIZE_BUF) INTEGER LRHSINTR, POSINRHSINTR(LPOS_N) #if defined(USE_OLD_SCALING) COMPLEX(kind=8), intent(in) :: RHSINTR(LRHSINTR, NCOL_RHSINTR) INTEGER, intent(in) :: LSCALING DOUBLE PRECISION, intent(in) :: SCALING(LSCALING) #else COMPLEX(kind=8), intent(inout) :: RHSINTR(LRHSINTR, NCOL_RHSINTR) INTEGER, intent(in) :: LSCALING_LOC_BWD DOUBLE PRECISION, intent(in) :: SCALING_LOC_BWD(LSCALING_LOC_BWD) #endif LOGICAL, intent(in) :: LSCAL INTEGER, INTENT(in) :: SIZE_PERM_RHS INTEGER, INTENT(in) :: PERM_RHS(SIZE_PERM_RHS) INTEGER I, II, J, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL, N2RECV INTEGER LIELL, IPOS, NPIV, MAXNPIV_estim, MAXSurf INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR, allocok PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND, IPOSINRHSINTR INTEGER :: JCOL_RHS INTEGER :: K242 LOGICAL :: OMP_FLAG !$ INTEGER :: CHUNK, NOMP INTEGER, PARAMETER :: FIN = -1 COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER, ALLOCATABLE, DIMENSION(:) :: IROWlist INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_PROCNODE TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 IF ( TYPE_PARAL == 1 ) THEN MYID_NODES = MYID ELSE MYID_NODES = MYID-1 ENDIF IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN IF (LSCAL) THEN OMP_FLAG = .FALSE. IF (KEEP(350).EQ.2) THEN K242 = KEEP(242) !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK = max(N/2,1) !$ IF (int(NRHS,8) * int(N,8) .GE. int(KEEP(363),8)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8)) !$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362)) !$ CHUNK = max(KEEP(363)/2,CHUNK) !$ ENDIF ENDIF IF (OMP_FLAG) THEN !$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242) !$OMP& PRIVATE(J,IPOSINRHSINTR,I,JCOL_RHS) DO J=1, NRHS IF (K242.EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF !$OMP DO SCHEDULE(DYNAMIC,CHUNK) DO I=1, N IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN RHS(I,JCOL_RHS) = RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ELSE DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO I=1, N IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN RHS(I,JCOL_RHS) = RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO ENDDO ENDIF ELSE OMP_FLAG = .FALSE. IF (KEEP(350).EQ.2) THEN K242 = KEEP(242) !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = max(N/2,1) !$ IF (NRHS * N .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8)) !$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362)) !$ CHUNK = max(KEEP(363)/2,CHUNK) !$ ENDIF ENDIF IF (OMP_FLAG) THEN !$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242) !$OMP& PRIVATE(IPOSINRHSINTR,I,JCOL_RHS) IF (OMP_FLAG) DO J=1, NRHS IF (K242.EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF !$OMP DO SCHEDULE(DYNAMIC,CHUNK) DO I=1, N IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN RHS(I,JCOL_RHS) = RHSINTR(IPOSINRHSINTR,J) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ELSE DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO I=1, N IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN RHS(I,JCOL_RHS) = RHSINTR(IPOSINRHSINTR,J) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO ENDDO ENDIF ENDIF RETURN ENDIF MAXNPIV_estim = max(KEEP(246), KEEP(247)) MAXSurf = MAXNPIV_estim*NRHS IF (LCWORK .LT. MAXNPIV_estim) THEN WRITE(*,*) MYID, & ": Internal error 2 in ZMUMPS_GATHER_SOLUTION:", & TYPE_PARAL, LCWORK, KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF IF (MYID.EQ.MASTER) THEN ALLOCATE(IROWlist(KEEP(247)),stat=allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of IROWlist' CALL MUMPS_ABORT() ENDIF ENDIF IF (NSLAVES .EQ. 1 .AND. TYPE_PARAL .EQ. 1) THEN CALL MUMPS_ABORT() ENDIF SIZE1=0 CALL MPI_PACK_SIZE(MAXNPIV_estim+2,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(MAXSurf,MPI_DOUBLE_COMPLEX, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in ZMUMPS_GATHER_SOLUTION ' write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', & RECORD_SIZE_P_1, SIZE_BUF_BYTES CALL MUMPS_ABORT() ENDIF N2SEND =0 N2RECV =N POS_BUF =0 IF (I_AM_SLAVE) THEN POS_BUF = 0 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N) IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-NPIV IF (NPIV.GT.0) & CALL ZMUMPS_NPIV_BLOCK_ADD ( .TRUE. ) ELSE IF (NPIV.GT.0) & CALL ZMUMPS_NPIV_BLOCK_ADD ( .FALSE.) ENDIF ENDIF ENDDO CALL ZMUMPS_NPIV_BLOCK_SEND() ENDIF IF ( MYID .EQ. MASTER ) THEN DO WHILE (N2RECV .NE. 0) CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, & MPI_ANY_SOURCE, & GatherSol, COMM, STATUS, IERR ) POS_BUF = 0 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & NPIV, 1, MPI_INTEGER, COMM, IERR) DO WHILE (NPIV.NE.FIN) CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & IROWlist, NPIV, MPI_INTEGER, COMM, IERR) DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS=J+JBEG_RHS-1 ELSE JCOL_RHS=PERM_RHS(J+JBEG_RHS-1) ENDIF CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & CWORK, NPIV, MPI_DOUBLE_COMPLEX, & COMM, IERR) #if defined(USE_OLD_SCALING) IF (LSCAL) THEN DO I=1,NPIV RHS(IROWlist(I),JCOL_RHS)=CWORK(I)*SCALING(IROWlist(I)) ENDDO ELSE #else #endif DO I=1,NPIV RHS(IROWlist(I),JCOL_RHS)=CWORK(I) ENDDO #if defined(USE_OLD_SCALING) ENDIF #endif ENDDO N2RECV=N2RECV-NPIV CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, & NPIV, 1, MPI_INTEGER, COMM, IERR) ENDDO ENDDO DEALLOCATE(IROWlist) ENDIF RETURN CONTAINS SUBROUTINE ZMUMPS_NPIV_BLOCK_ADD ( ON_MASTER ) LOGICAL, intent(in) :: ON_MASTER INTEGER :: JPOS, K242 LOGICAL :: PRIV_LSCAL IF (ON_MASTER) THEN IF (KEEP(350).EQ.2 & .AND. (NRHS.EQ.1.OR.((NPIV*NRHS*2*KEEP(16)).GE.KEEP(364)))) THEN PRIV_LSCAL = LSCAL K242 = KEEP(242) DO J=1, NRHS IF (K242.EQ.0) THEN JPOS = J+JBEG_RHS-1 ELSE JPOS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) IF (PRIV_LSCAL) THEN RHS(I,JPOS) = RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ELSE RHS(I,JPOS) = RHSINTR(IPOSINRHSINTR,J) ENDIF ENDDO ENDDO ELSE IF (KEEP(242).EQ.0) THEN IF (LSCAL) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ENDDO ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = RHSINTR(IPOSINRHSINTR,J) ENDDO ENDDO ENDIF ELSE IF (LSCAL) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) !DIR$ NOVECTOR DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ENDDO ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) !DIR$ NOVECTOR DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSINTR(IPOSINRHSINTR,J) ENDDO ENDDO ENDIF ENDIF ENDIF RETURN ENDIF CALL MPI_PACK(NPIV, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(IW(J1), NPIV, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) IPOSINRHSINTR= POSINRHSINTR(IW(J1)) DO J=1,NRHS #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO II=IPOSINRHSINTR, IPOSINRHSINTR+NPIV-1 RHSINTR(II,J)= & RHSINTR(II,J)*SCALING_LOC_BWD(II) ENDDO ENDIF #endif CALL MPI_PACK(RHSINTR(IPOSINRHSINTR,J), NPIV, & MPI_DOUBLE_COMPLEX, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ENDDO N2SEND=N2SEND+NPIV IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL ZMUMPS_NPIV_BLOCK_SEND() END IF RETURN END SUBROUTINE ZMUMPS_NPIV_BLOCK_ADD SUBROUTINE ZMUMPS_NPIV_BLOCK_SEND() IF (N2SEND .NE. 0) THEN CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, & GatherSol, COMM, IERR) ENDIF POS_BUF=0 N2SEND=0 RETURN END SUBROUTINE ZMUMPS_NPIV_BLOCK_SEND END SUBROUTINE ZMUMPS_GATHER_SOLUTION SUBROUTINE ZMUMPS_GATHER_SOLUTION_AM1(NSLAVES, N, MYID, COMM, & NRHS, RHSINTR, LRHSINTR, NRHSINTR_COL, & KEEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, #if defined(USE_OLD_SCALING) & LSCAL, SCALING, LSCALING, #else & LSCAL, SCALING_LOC_BWD, LSCALING_LOC_BWD, #endif & IRHS_PTR_COPY, LIRHS_PTR_COPY, & IRHS_SPARSE_COPY, LIRHS_SPARSE_COPY, & RHS_SPARSE_COPY, LRHS_SPARSE_COPY, & UNS_PERM_INV, LUNS_PERM_INV, & POSINRHSINTR, LPOS_ROW, NB_FS_IN_RHSINTR ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM INTEGER NRHS, LRHSINTR, NRHSINTR_COL COMPLEX(kind=8), intent(in) :: RHSINTR (LRHSINTR, NRHSINTR_COL) INTEGER KEEP(500) INTEGER SIZE_BUF, SIZE_BUF_BYTES, LPOS_ROW INTEGER BUFFER(SIZE_BUF) INTEGER, intent(in) :: LIRHS_PTR_COPY, LIRHS_SPARSE_COPY, & LRHS_SPARSE_COPY, LUNS_PERM_INV, & NB_FS_IN_RHSINTR INTEGER :: IRHS_SPARSE_COPY(LIRHS_SPARSE_COPY), & IRHS_PTR_COPY(LIRHS_PTR_COPY), & UNS_PERM_INV(LUNS_PERM_INV), & POSINRHSINTR(LPOS_ROW) COMPLEX(kind=8) :: RHS_SPARSE_COPY(LRHS_SPARSE_COPY) #if defined(USE_OLD_SCALING) INTEGER, intent(in) :: LSCALING DOUBLE PRECISION, intent(in) :: SCALING(LSCALING) #else INTEGER, intent(in) :: LSCALING_LOC_BWD DOUBLE PRECISION, intent(in) :: SCALING_LOC_BWD(LSCALING_LOC_BWD) #endif LOGICAL, intent(in) :: LSCAL INTEGER COLSIZE, K, IZ, IPREV, NBCOL_INBLOC INTEGER I, II, J, MASTER, & TYPE_PARAL, N2RECV, IPOSINRHSINTR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND INTEGER, PARAMETER :: FIN = -1 INCLUDE 'mumps_headers.h' TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 NBCOL_INBLOC = size(IRHS_PTR_COPY)-1 IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN K=1 DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.EQ.0) CYCLE DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)= & RHSINTR(IPOSINRHSINTR,K) #if defined(USE_OLD_SCALING) & * SCALING(I) #else & * SCALING_LOC_BWD(IPOSINRHSINTR) #endif ELSE RHS_SPARSE_COPY(IZ)=RHSINTR(IPOSINRHSINTR,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) IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)=RHSINTR(IPOSINRHSINTR,K) & * SCALING_LOC_BWD(IPOSINRHSINTR) ELSE #endif RHS_SPARSE_COPY(IZ)=RHSINTR(IPOSINRHSINTR,K) #if ! defined(USE_OLD_SCALING) ENDIF #endif ENDIF ENDDO K = K + 1 ENDDO ENDIF SIZE1=0 CALL MPI_PACK_SIZE(3,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(1,MPI_DOUBLE_COMPLEX, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in ZMUMPS_GATHER_SOLUTION_AM1 ' write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', & RECORD_SIZE_P_1, SIZE_BUF_BYTES CALL MUMPS_ABORT() ENDIF N2SEND =0 N2RECV =size(IRHS_SPARSE_COPY) POS_BUF =0 IF (I_AM_SLAVE) THEN DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.LE.0) CYCLE K = 0 DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) II = I IF (KEEP(23).NE.0) II = UNS_PERM_INV(I) IPOSINRHSINTR = POSINRHSINTR(II) IF (IPOSINRHSINTR.GT.0) THEN IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-1 #if defined(USE_OLD_SCALING) IF (LSCAL) & CALL ZMUMPS_AM1_BLOCK_ADD ( .TRUE. ) #endif 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 #if defined(USE_OLD_SCALING) CALL ZMUMPS_AM1_BLOCK_ADD ( .FALSE. ) #else CALL ZMUMPS_AM1_BLOCK_ADD () #endif ENDIF ENDIF ENDDO IF (MYID.EQ.MASTER) & IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + K ENDDO CALL ZMUMPS_AM1_BLOCK_SEND() ENDIF IF ( MYID .EQ. MASTER ) THEN DO WHILE (N2RECV .NE. 0) CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, & MPI_ANY_SOURCE, & GatherSol, COMM, STATUS, IERR ) POS_BUF = 0 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & J, 1, MPI_INTEGER, COMM, IERR) DO WHILE (J.NE.FIN) IZ = IRHS_PTR_COPY(J) CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & I, 1, MPI_INTEGER, COMM, IERR) IRHS_SPARSE_COPY(IZ) = I CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & RHS_SPARSE_COPY(IZ), 1, MPI_DOUBLE_COMPLEX, & COMM, IERR) #if defined(USE_OLD_SCALING) IF (LSCAL) THEN IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) RHS_SPARSE_COPY(IZ) = RHS_SPARSE_COPY(IZ)*SCALING(I) ENDIF #endif N2RECV=N2RECV-1 IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + 1 CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, & J, 1, MPI_INTEGER, COMM, IERR) ENDDO ENDDO IPREV = 1 DO J=1, size(IRHS_PTR_COPY)-1 I= IRHS_PTR_COPY(J) IRHS_PTR_COPY(J) = IPREV IPREV = I ENDDO ENDIF RETURN CONTAINS SUBROUTINE ZMUMPS_AM1_BLOCK_ADD ( #if defined(USE_OLD_SCALING) & SCALE_ONLY #endif & ) #if defined(USE_OLD_SCALING) LOGICAL, intent(in) :: SCALE_ONLY #endif #if defined(USE_OLD_SCALING) INTEGER III #endif #if defined(USE_OLD_SCALING) IF (SCALE_ONLY) THEN WRITE(*,*) "ZMUMPS_AM1_BLOCK_ADD(true) should not be called" CALL MUMPS_ABORT() 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 #endif CALL MPI_PACK(J, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(I, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(RHS_SPARSE_COPY(IZ), 1, MPI_DOUBLE_COMPLEX, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) N2SEND=N2SEND+1 IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL ZMUMPS_AM1_BLOCK_SEND() END IF RETURN END SUBROUTINE ZMUMPS_AM1_BLOCK_ADD SUBROUTINE ZMUMPS_AM1_BLOCK_SEND() IF (N2SEND .NE. 0) THEN CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, & GatherSol, COMM, IERR) ENDIF POS_BUF=0 N2SEND=0 RETURN END SUBROUTINE ZMUMPS_AM1_BLOCK_SEND END SUBROUTINE ZMUMPS_GATHER_SOLUTION_AM1 SUBROUTINE ZMUMPS_DISTSOL_INDICES(MTYPE, ISOL_LOC, & PTRIST, KEEP,KEEP8, & IW, LIW_PASSED, MYID_NODES, N, STEP, & PROCNODE, NSLAVES, #if defined(USE_OLD_SCALING) & scaling_data, LSCAL, #endif & IRHS_loc_MEANINGFUL, IRHS_loc, Nloc_RHS & ) IMPLICIT NONE INTEGER MTYPE, MYID_NODES, N, NSLAVES INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE(KEEP(28)) INTEGER ISOL_LOC(KEEP(89)) INTEGER LIW_PASSED INTEGER IW(LIW_PASSED) INTEGER STEP(N) #if defined(USE_OLD_SCALING) LOGICAL LSCAL #endif LOGICAL :: IRHS_loc_MEANINGFUL INTEGER :: Nloc_RHS INTEGER :: IRHS_loc(Nloc_RHS) #if defined(USE_OLD_SCALING) type scaling_data_t SEQUENCE DOUBLE PRECISION, dimension(:), pointer :: SCALING DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC INTEGER, dimension(:), pointer :: SCALING_IND end type scaling_data_t type (scaling_data_t) :: scaling_data #endif INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER ISTEP, K INTEGER J1, IPOS, LIELL, NPIV, JJ LOGICAL :: CHECK_IRHS_loc INTEGER(8) :: DIFF_ADDR INCLUDE 'mumps_headers.h' CHECK_IRHS_loc=.FALSE. IF ( IRHS_loc_MEANINGFUL ) THEN IF (Nloc_RHS .GT. 0) THEN CALL MUMPS_SIZE_C( IRHS_loc(1), ISOL_loc(1), & DIFF_ADDR ) IF (DIFF_ADDR .EQ. 0_8) THEN CHECK_IRHS_loc=.TRUE. ENDIF ENDIF ENDIF K=0 DO ISTEP=1, KEEP(28) IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW_PASSED, PTRIST, STEP, N) IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF DO JJ=J1,J1+NPIV-1 K=K+1 IF (CHECK_IRHS_loc) THEN IF (K.LE.Nloc_RHS) THEN IF ( IW(JJ) .NE.IRHS_LOC(K) ) THEN ENDIF ENDIF ENDIF ISOL_LOC(K)=IW(JJ) #if defined(USE_OLD_SCALING) IF (LSCAL) THEN scaling_data%SCALING_LOC(K)= & scaling_data%SCALING(IW(JJ)) ENDIF #endif ENDDO ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_DISTSOL_INDICES #if ! defined(USE_OLD_SCALING) SUBROUTINE ZMUMPS_SCALINGRHSINTR(LSCAL, N, & SCALING_LOC, SCALING_RHSINTR, & L, POSINRHSINTR, KEEP, ROWORCOL, PTRIST, & IW, LIW_PASSED, MYID_NODES, STEP, & PROCNODE, NSLAVES) IMPLICIT NONE INTEGER :: KEEP(500) LOGICAL, INTENT(IN) :: LSCAL INTEGER, INTENT(IN) :: N, L INTEGER, INTENT(IN) :: POSINRHSINTR(N) DOUBLE PRECISION , INTENT(IN) :: SCALING_LOC(max(KEEP(89),1)) DOUBLE PRECISION , INTENT(OUT) :: SCALING_RHSINTR(L) INTEGER, INTENT(IN) :: ROWORCOL, NSLAVES, LIW_PASSED, MYID_NODES INTEGER, INTENT(IN) :: STEP(KEEP(28)), & PROCNODE(KEEP(28)), & PTRIST(KEEP(28)), & IW(LIW_PASSED) INTEGER :: IPOSINRHSINTR INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER :: ISTEP INTEGER :: KLOC, J1, JJ, LIELL, IPOS, NPIV IF (.NOT. LSCAL) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_DS_SCALINGRHSINTR" CALL MUMPS_ABORT() ENDIF IF (ROWORCOL .NE. 1 .AND. ROWORCOL.NE.2) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_DS_SCALINGRHSINTR", & ROWORCOL ENDIF IF (KEEP(89).EQ.0) RETURN KLOC = 1 DO ISTEP=1, KEEP(28) IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW_PASSED, PTRIST, STEP, N) IF (ROWORCOL .EQ. 1) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IPOSINRHSINTR = POSINRHSINTR(IW(J1)) IF ( IPOSINRHSINTR .GT. 0 ) THEN DO JJ=1, NPIV SCALING_RHSINTR(IPOSINRHSINTR+JJ-1) = & SCALING_LOC(KLOC+JJ-1) ENDDO ENDIF KLOC = KLOC + NPIV ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_SCALINGRHSINTR #endif SUBROUTINE ZMUMPS_DISTRIBUTED_SOLUTION( & SLAVEF, N, MYID_NODES, & MTYPE, RHSINTR, LRHSINTR, NBRHS_EFF, & POSINRHSINTR, & ISOL_LOC, & SOL_LOC, NRHS, BEG_RHS, LSOL_LOC, & PTRIST, & PROCNODE_STEPS, KEEP,KEEP8, IW, LIW, STEP, & SCALING_LOC_BWD, LSCALING_LOC_BWD, & LSCAL, NB_RHSSKIPPED, & PERM_RHS, SIZE_PERM_RHS) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' LOGICAL, intent(in) :: LSCAL INTEGER, intent(in) :: LSCALING_LOC_BWD DOUBLE PRECISION, intent(in) :: SCALING_LOC_BWD(LSCALING_LOC_BWD) INTEGER SLAVEF, N, MYID_NODES, LIW, MTYPE, NBRHS_EFF, LRHSINTR INTEGER POSINRHSINTR(N), NB_RHSSKIPPED INTEGER LSOL_LOC, BEG_RHS INTEGER ISOL_LOC(LSOL_LOC) INTEGER, INTENT(in) :: NRHS COMPLEX(kind=8) SOL_LOC( LSOL_LOC, NRHS ) COMPLEX(kind=8) RHSINTR( LRHSINTR, NBRHS_EFF ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER, INTENT(in) :: SIZE_PERM_RHS INTEGER, INTENT(in) :: PERM_RHS( SIZE_PERM_RHS ) INTEGER :: JJ, J1, ISTEP, K, KLOC, IPOSINRHSINTR, JEMPTY INTEGER :: JCOL, JCOL_PERM INTEGER :: IPOS, LIELL, NPIV, JEND LOGICAL :: IS_ROOT !$ LOGICAL :: OMP_FLAG COMPLEX(kind=8), PARAMETER :: ZERO = (0.0D0,0.0D0) INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE K=0 JEMPTY = BEG_RHS+NB_RHSSKIPPED-1 JEND = BEG_RHS+NB_RHSSKIPPED+NBRHS_EFF-1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN IS_ROOT=.false. IF (KEEP(38).ne.0) IS_ROOT = STEP(KEEP(38))==ISTEP IF (KEEP(20).ne.0) IS_ROOT = STEP(KEEP(20))==ISTEP IF ( IS_ROOT ) THEN IPOS = PTRIST(ISTEP) + KEEP(IXSZ) LIELL = IW(IPOS+3) NPIV = LIELL IPOS= PTRIST(ISTEP)+5+KEEP(IXSZ) ELSE IPOS = PTRIST(ISTEP) + 2 +KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) IPOS= IPOS+1 NPIV = IW(IPOS) IPOS= IPOS+1 IPOS= IPOS+1+IW( PTRIST(ISTEP) + 5 +KEEP(IXSZ)) END IF IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF IF (NB_RHSSKIPPED.GT.0) THEN DO JCOL = BEG_RHS, JEMPTY IF (KEEP(242) .NE. 0) THEN JCOL_PERM = PERM_RHS(JCOL) ELSE JCOL_PERM = JCOL ENDIF KLOC=K DO JJ=J1,J1+NPIV-1 KLOC=KLOC+1 SOL_LOC(KLOC, JCOL_PERM) = ZERO ENDDO ENDDO ENDIF !$ OMP_FLAG = ( JEND-JEMPTY.GE.KEEP(362) .AND. !$ & (NPIV*(JEND-JEMPTY) .GE. KEEP(363)/2 ) ) !$OMP PARALLEL DO PRIVATE(JCOL,JCOL_PERM,KLOC,JJ,IPOSINRHSINTR) !$OMP& IF(OMP_FLAG) DO JCOL = JEMPTY+1, JEND IF (KEEP(242) .NE. 0) THEN JCOL_PERM = PERM_RHS(JCOL) ELSE JCOL_PERM = JCOL ENDIF DO JJ=J1,J1+NPIV-1 KLOC=K + JJ-J1 + 1 IF (LSCAL) THEN SOL_LOC(KLOC,JCOL_PERM) = & SCALING_LOC_BWD(KLOC)* & RHSINTR(KLOC,JCOL-JEMPTY) ELSE SOL_LOC(KLOC,JCOL_PERM) = & RHSINTR(KLOC,JCOL-JEMPTY) ENDIF ENDDO ENDDO !$OMP END PARALLEL DO K=K+NPIV ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_DISTRIBUTED_SOLUTION SUBROUTINE ZMUMPS_SCATTER_RHS & (NSLAVES, N, MYID, COMM, & LSCAL, SCALING_LOC_FWD, & MTYPE, RHS, LRHS, NCOL_RHS, NRHS, & RHSINTR, LRHSINTR, NCOL_RHSINTR, & POSINRHSINTR_FWD, NB_FS_IN_RHSINTR_F, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & ICNTL, INFO) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE INTEGER NRHS, LRHS, NCOL_RHS, LRHSINTR, NCOL_RHSINTR INTEGER ICNTL(60), INFO(80) COMPLEX(kind=8), intent(in) :: RHS (LRHS, NCOL_RHS) COMPLEX(kind=8), intent(out) :: RHSINTR(LRHSINTR, NCOL_RHSINTR) INTEGER, intent(in) :: POSINRHSINTR_FWD(N), NB_FS_IN_RHSINTR_F INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) LOGICAL, intent(in) :: LSCAL DOUBLE PRECISION, intent(in) :: SCALING_LOC_FWD(max(1,KEEP(89))) INTEGER BUF_MAXSIZE, BUF_MAXREF PARAMETER (BUF_MAXREF=200000) INTEGER, ALLOCATABLE, DIMENSION(:) :: BUF_INDX COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: BUF_RHS COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: BUF_RHS_2 INTEGER ENTRIES_2_PROCESS, PROC_WHO_ASKS, BUF_EFFSIZE INTEGER INDX INTEGER allocok COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER I, J, K, JJ, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL INTEGER LIELL, IPOS, NPIV INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE !$ INTEGER :: CHUNK, NOMP !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. 0 .OR. TYPE_PARAL .eq. 1 IF ( TYPE_PARAL == 1 ) THEN MYID_NODES = MYID ELSE MYID_NODES = MYID-1 ENDIF BUF_EFFSIZE = 0 BUF_MAXSIZE = max(min(BUF_MAXREF,int(2000000/NRHS)),2000) IF ( KEEP(350).EQ.2 ) THEN !$ NOMP = OMP_GET_MAX_THREADS() ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS_2(BUF_MAXSIZE*NRHS), & stat=allocok) ELSE ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS(NRHS,BUF_MAXSIZE), & stat=allocok) END IF IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=BUF_MAXSIZE*(NRHS+1) ENDIF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM, MYID ) IF (INFO(1).LT.0) RETURN IF (MYID.EQ.MASTER) THEN ENTRIES_2_PROCESS = N - KEEP(89) IF (TYPE_PARAL.EQ.1.AND.ENTRIES_2_PROCESS.NE.0) THEN IF (NB_FS_IN_RHSINTR_F.LT.LRHSINTR) THEN DO K=1, NCOL_RHSINTR DO I = NB_FS_IN_RHSINTR_F +1, LRHSINTR RHSINTR (I, K) = ZERO ENDDO ENDDO ENDIF ENDIF IF ( KEEP(350).EQ.2 ) THEN DO WHILE ( ENTRIES_2_PROCESS .NE. 0) CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, & ScatterRhsI, COMM, STATUS, IERR ) CALL MPI_GET_COUNT(STATUS,MPI_INTEGER,BUF_EFFSIZE,IERR) PROC_WHO_ASKS = STATUS(MPI_SOURCE) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = BUF_INDX( I ) BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) = RHS( INDX, K ) ENDDO ENDDO !$OMP END PARALLEL DO CALL MPI_SEND( BUF_RHS_2, & NRHS*BUF_EFFSIZE, & MPI_DOUBLE_COMPLEX, PROC_WHO_ASKS, & ScatterRhsR, COMM, IERR) ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE ENDDO BUF_EFFSIZE= 0 ELSE DO WHILE ( ENTRIES_2_PROCESS .NE. 0) CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, & ScatterRhsI, COMM, STATUS, IERR ) CALL MPI_GET_COUNT( STATUS, MPI_INTEGER,BUF_EFFSIZE,IERR) PROC_WHO_ASKS = STATUS(MPI_SOURCE) DO I = 1, BUF_EFFSIZE INDX = BUF_INDX( I ) DO K = 1, NRHS BUF_RHS( K, I ) = RHS( INDX, K ) ENDDO ENDDO CALL MPI_SEND( BUF_RHS, NRHS*BUF_EFFSIZE, & MPI_DOUBLE_COMPLEX, PROC_WHO_ASKS, & ScatterRhsR, COMM, IERR) ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE ENDDO BUF_EFFSIZE= 0 ENDIF ENDIF IF (I_AM_SLAVE) THEN IF (MYID.NE.MASTER) THEN IF (NB_FS_IN_RHSINTR_F.LT.LRHSINTR) THEN DO K=1, NCOL_RHSINTR DO I = NB_FS_IN_RHSINTR_F +1, LRHSINTR RHSINTR (I, K) = ZERO ENDDO ENDDO ENDIF ENDIF DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF (MYID.EQ.MASTER) THEN INDX = POSINRHSINTR_FWD(IW(J1)) IF (KEEP(350).EQ.2 .AND. & (NRHS.EQ.1.OR.((NPIV*NRHS*2*KEEP(16)).GE.KEEP(364)))) THEN !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (NPIV*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((NPIV*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(J,JJ) !$OMP& FIRSTPRIVATE(INDX) IF (OMP_FLAG) DO K = 1, NRHS DO JJ=J1,J1+NPIV-1 J=IW(JJ) RHSINTR( INDX+JJ-J1, K ) = RHS( J, K ) * & SCALING_LOC_FWD( INDX+JJ-J1 ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE #endif !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(J,JJ) !$OMP& FIRSTPRIVATE(INDX) IF (OMP_FLAG) DO K = 1, NRHS DO JJ=J1,J1+NPIV-1 J=IW(JJ) RHSINTR( INDX+JJ-J1, K ) = RHS( J, K ) ENDDO ENDDO !$OMP END PARALLEL DO #if ! defined(USE_OLD_SCALING) ENDIF #endif ELSE #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO JJ=J1,J1+NPIV-1 J=IW(JJ) DO K = 1, NRHS RHSINTR( INDX+JJ-J1, K ) = RHS( J, K ) & * SCALING_LOC_FWD( INDX + JJ - J1 ) ENDDO ENDDO ELSE #endif DO JJ=J1,J1+NPIV-1 J=IW(JJ) DO K = 1, NRHS RHSINTR( INDX+JJ-J1, K ) = RHS( J, K ) ENDDO ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif END IF ELSE DO JJ=J1,J1+NPIV-1 BUF_EFFSIZE = BUF_EFFSIZE + 1 BUF_INDX(BUF_EFFSIZE) = IW(JJ) IF (BUF_EFFSIZE + 1 .GT. BUF_MAXSIZE) THEN CALL ZMUMPS_GET_BUF_INDX_RHS() ENDIF ENDDO ENDIF ENDIF ENDDO IF ( BUF_EFFSIZE .NE. 0 .AND. MYID.NE.MASTER ) & CALL ZMUMPS_GET_BUF_INDX_RHS() ENDIF IF (KEEP(350).EQ.2) THEN DEALLOCATE (BUF_INDX, BUF_RHS_2) ELSE DEALLOCATE (BUF_INDX, BUF_RHS) ENDIF RETURN CONTAINS SUBROUTINE ZMUMPS_GET_BUF_INDX_RHS() CALL MPI_SEND(BUF_INDX, BUF_EFFSIZE, MPI_INTEGER, & MASTER, ScatterRhsI, COMM, IERR ) IF (KEEP(350).EQ.2) THEN CALL MPI_RECV(BUF_RHS_2, BUF_EFFSIZE*NRHS, & MPI_DOUBLE_COMPLEX, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = POSINRHSINTR_FWD(BUF_INDX(I)) RHSINTR( INDX, K ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) * & SCALING_LOC_FWD( INDX ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE #endif !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = POSINRHSINTR_FWD(BUF_INDX(I)) RHSINTR( INDX, K ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) ENDDO ENDDO !$OMP END PARALLEL DO #if ! defined(USE_OLD_SCALING) ENDIF #endif ELSE CALL MPI_RECV(BUF_RHS, BUF_EFFSIZE*NRHS, & MPI_DOUBLE_COMPLEX, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO I = 1, BUF_EFFSIZE INDX = POSINRHSINTR_FWD(BUF_INDX(I)) DO K = 1, NRHS RHSINTR( INDX, K ) = BUF_RHS( K, I ) & * SCALING_LOC_FWD( INDX ) ENDDO ENDDO ELSE #endif DO I = 1, BUF_EFFSIZE INDX = POSINRHSINTR_FWD(BUF_INDX(I)) DO K = 1, NRHS RHSINTR( INDX, K ) = BUF_RHS( K, I ) ENDDO ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif END IF BUF_EFFSIZE = 0 RETURN END SUBROUTINE ZMUMPS_GET_BUF_INDX_RHS END SUBROUTINE ZMUMPS_SCATTER_RHS SUBROUTINE ZMUMPS_BUILD_GLOB2LOC & (NSLAVES, N, MYID_NODES, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & GLOB2LOC_RHS, GLOB2LOC_SOL, & GLOB2LOC_SOL_ALLOC, & MTYPE, & NBENT_RHSINTR, NB_FS_IN_RHSINTR ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER, intent(in) :: IW(LIW), STEP(N) INTEGER, intent(in) :: MTYPE LOGICAL, intent(in) :: GLOB2LOC_SOL_ALLOC INTEGER, intent(out):: GLOB2LOC_RHS(N), GLOB2LOC_SOL(N) INTEGER, intent(out):: NBENT_RHSINTR, NB_FS_IN_RHSINTR INTEGER ISTEP INTEGER NPIV INTEGER IPOS, LIELL INTEGER JJ, J1, JCOL INTEGER IPOSINRHSINTR, IPOSINRHSINTR_SOL INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE GLOB2LOC_RHS = 0 IF (GLOB2LOC_SOL_ALLOC) GLOB2LOC_SOL = 0 IPOSINRHSINTR = 1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, NPIV, LIELL, & IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = J1, J1+NPIV-1 GLOB2LOC_RHS(IW(JJ)) = IPOSINRHSINTR+JJ-J1 ENDDO IF (GLOB2LOC_SOL_ALLOC) THEN DO JJ = JCOL, JCOL+NPIV-1 GLOB2LOC_SOL(IW(JJ)) = IPOSINRHSINTR+JJ-JCOL ENDDO ENDIF IPOSINRHSINTR = IPOSINRHSINTR + NPIV ENDIF ENDDO NB_FS_IN_RHSINTR = IPOSINRHSINTR -1 IF (GLOB2LOC_SOL_ALLOC) IPOSINRHSINTR_SOL=IPOSINRHSINTR IF (IPOSINRHSINTR.GT.N) GOTO 500 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF (GLOB2LOC_SOL_ALLOC) THEN DO JJ = NPIV, LIELL-1-KEEP(253) IF (GLOB2LOC_RHS(IW(J1+JJ)).EQ.0) THEN GLOB2LOC_RHS(IW(J1+JJ)) = - IPOSINRHSINTR IPOSINRHSINTR = IPOSINRHSINTR + 1 ENDIF IF (GLOB2LOC_SOL(IW(JCOL+JJ)).EQ.0) THEN GLOB2LOC_SOL(IW(JCOL+JJ)) = - IPOSINRHSINTR_SOL IPOSINRHSINTR_SOL = IPOSINRHSINTR_SOL + 1 ENDIF ENDDO ELSE DO JJ = J1+NPIV, J1+LIELL-1-KEEP(253) IF (GLOB2LOC_RHS(IW(JJ)).EQ.0) THEN GLOB2LOC_RHS(IW(JJ)) = - IPOSINRHSINTR IPOSINRHSINTR = IPOSINRHSINTR + 1 ENDIF ENDDO ENDIF ENDIF ENDDO 500 NBENT_RHSINTR = IPOSINRHSINTR - 1 IF (GLOB2LOC_SOL_ALLOC) & NBENT_RHSINTR = max(NBENT_RHSINTR, IPOSINRHSINTR_SOL-1) RETURN END SUBROUTINE ZMUMPS_BUILD_GLOB2LOC SUBROUTINE ZMUMPS_NODES_FWD_BWD_SIZE_FILL ( & fill, ICNTL, & N, NSTEPS, KEEP, STEP, Step2node, & IRHS_loc, Nloc_RHS, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & PERM_RHS, SIZE_PERM_RHS, JBEG_RHS, & UNS_PERM_INV, SIZE_UNS_PERM_INV, & ICNTL21, & MYID, COMM, & INFO, & Pruned_Sons_FWD, Pruned_Sons_BWD, & Lnodes_FWD, Lnodes_BWD & , nodes_FWD, nodes_BWD & , Lnodes_FWD_in, Lnodes_BWD_in & ) USE ZMUMPS_SOL_ES, ONLY : ZMUMPS_ES_NODES_SIZE_AND_FILL IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: ICNTL(60),N, NSTEPS, KEEP(500) INTEGER, INTENT(IN) :: STEP(N), Step2node(NSTEPS) INTEGER, INTENT(IN) :: Nloc_RHS, & IRHS_loc(max(1,Nloc_RHS)) INTEGER, intent(in) :: NBCOL_INBLOC, IRHS_PTR(NBCOL_INBLOC+1) INTEGER, intent(in) :: NZ_RHS, IRHS_SPARSE(NZ_RHS) INTEGER, intent(in) :: SIZE_PERM_RHS, PERM_RHS(SIZE_PERM_RHS) INTEGER, intent(in) :: JBEG_RHS, SIZE_UNS_PERM_INV INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, intent(IN) :: ICNTL21 INTEGER, intent(in) :: MYID, COMM INTEGER, intent(inout) :: INFO(80) INTEGER, intent(inout) :: Pruned_Sons_FWD(NSTEPS), & Pruned_Sons_BWD(NSTEPS) INTEGER, intent(inout) :: Lnodes_FWD, Lnodes_BWD INTEGER, intent(in) :: Lnodes_FWD_in, Lnodes_BWD_in INTEGER, intent(out) :: nodes_FWD(Lnodes_FWD_in), & nodes_BWD(Lnodes_BWD_in) INCLUDE 'mpif.h' LOGICAL :: DO_PRUN_FWD, AM1, Exploit_Sparsity_FWD, & Exploit_Sparsity_BWD INTEGER :: Lnodes_FWD_loc, Lnodes_BWD_loc, ISTEP, & INODE_PRINC, I, II, JAM1 #if defined(AVOID_MPI_IN_PLACE) INTEGER, DIMENSION(:), ALLOCATABLE :: TMP_INT_ARRAY INTEGER :: allocok #endif #if defined(AVOID_MPI_IN_PLACE) ALLOCATE(TMP_INT_ARRAY(KEEP(28)), STAT = allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM, MYID ) IF(INFO(1).LT.0) GOTO 500 #endif AM1 = (KEEP(237) .NE. 0) Exploit_Sparsity_FWD = (KEEP(235) .NE. 0) .AND. (.NOT. AM1) DO_PRUN_FWD = (Exploit_Sparsity_FWD.OR.AM1) Exploit_Sparsity_BWD = (KEEP(212) .NE. 0) .AND. (.NOT. AM1) IF (.NOT.fill) Lnodes_FWD=-1 IF (.NOT.fill) Lnodes_BWD=-1 IF (.NOT.fill.AND.KEEP(252).NE.0) THEN Lnodes_FWD = 0 ENDIF IF ( KEEP(252).NE.0 ) DO_PRUN_FWD = .FALSE. IF ( DO_PRUN_FWD ) THEN IF ( Exploit_Sparsity_FWD.AND.KEEP(248).EQ.-1 ) THEN IF (.NOT.fill) THEN CALL ZMUMPS_ES_NODES_SIZE_AND_FILL ( fill, & N, KEEP(28), KEEP, STEP, Step2node, & IRHS_loc, Nloc_RHS, MYID, COMM, & Pruned_Sons_FWD, Lnodes_FWD #if defined(AVOID_MPI_IN_PLACE) & , TMP_INT_ARRAY #endif & ) ELSE IF (Lnodes_FWD.GT.0) THEN CALL ZMUMPS_ES_NODES_SIZE_AND_FILL ( fill, & N, KEEP(28), KEEP, STEP, Step2node, & IRHS_loc, Nloc_RHS, MYID, COMM, & Pruned_Sons_FWD, Lnodes_FWD, #if defined(AVOID_MPI_IN_PLACE) & TMP_INT_ARRAY, #endif & nodes_FWD & ) ENDIF ELSE IF ( Exploit_Sparsity_FWD.AND.KEEP(248).NE.-1 ) THEN IF (.NOT.fill) THEN Lnodes_FWD = 0 Pruned_Sons_FWD(:) = -1 DO I = 1, NZ_RHS ISTEP = abs( STEP(IRHS_SPARSE(I)) ) IF ( Pruned_Sons_FWD(ISTEP) .eq. -1) THEN Lnodes_FWD = Lnodes_FWD +1 Pruned_Sons_FWD(ISTEP) = 0 ENDIF ENDDO ELSE IF (Lnodes_FWD.GT.0) THEN Lnodes_FWD_loc = 0 Pruned_Sons_FWD(:) = -1 DO I = 1, NZ_RHS ISTEP = abs( STEP(IRHS_SPARSE(I)) ) INODE_PRINC = Step2node( ISTEP ) IF ( Pruned_Sons_FWD(ISTEP) .eq. -1) THEN Lnodes_FWD_loc = Lnodes_FWD_loc +1 nodes_FWD(Lnodes_FWD_loc) = INODE_PRINC Pruned_Sons_FWD(ISTEP) = 0 ENDIF ENDDO ENDIF ELSE IF ( AM1 ) THEN IF (.NOT.fill) THEN Lnodes_FWD = 0 Pruned_Sons_FWD(:) = -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_FWD(ISTEP) .eq. -1) THEN Lnodes_FWD = Lnodes_FWD +1 Pruned_Sons_FWD(ISTEP) = 0 ENDIF ENDDO ELSE IF (Lnodes_FWD.GT.0) THEN Lnodes_FWD_loc = 0 Pruned_Sons_FWD = -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_FWD(ISTEP) .eq. -1) THEN Lnodes_FWD_loc = Lnodes_FWD_loc +1 nodes_FWD(Lnodes_FWD_loc) = INODE_PRINC Pruned_Sons_FWD(ISTEP) = 0 ENDIF ENDDO ENDIF ENDIF ENDIF IF (AM1) THEN IF (.NOT.fill) THEN Lnodes_BWD = 0 Pruned_Sons_BWD(:) = -1 DO II = 1, NZ_RHS I = IRHS_SPARSE(II) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) ISTEP = abs(STEP(I)) IF ( Pruned_Sons_BWD(ISTEP) .eq. -1) THEN Lnodes_BWD = Lnodes_BWD +1 Pruned_Sons_BWD(ISTEP) = 0 ENDIF ENDDO ELSE IF (Lnodes_BWD.GT.0) THEN Lnodes_BWD_loc = 0 Pruned_Sons_BWD(:) = -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_BWD(ISTEP) .eq. -1) THEN Lnodes_BWD_loc = Lnodes_BWD_loc +1 nodes_BWD(Lnodes_BWD_loc) = INODE_PRINC Pruned_Sons_BWD(ISTEP) = 0 ENDIF ENDDO ENDIF ENDIF #if defined(AVOID_MPI_IN_PLACE) GOTO 600 500 CONTINUE Lnodes_FWD = -1 Lnodes_BWD = -1 600 CONTINUE #endif #if defined(AVOID_MPI_IN_PLACE) IF ( allocated(TMP_INT_ARRAY)) DEALLOCATE(TMP_INT_ARRAY) #endif RETURN END SUBROUTINE ZMUMPS_NODES_FWD_BWD_SIZE_FILL SUBROUTINE ZMUMPS_BUILD_GLOB2LOC_NODES_ES ( & NSLAVES, N, MYID_NODES, & PTRIST, DAD, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & Lnodes_FWD, Lnodes_BWD, & nodes_FWD, nodes_BWD, & GLOB2LOC_RHS, GLOB2LOC_SOL, & GLOB2LOC_SOL_ALLOC, & MTYPE, & NBENT_RHSINTR, & NB_FS_IN_RHSINTR_FWD, NB_FS_IN_RHSINTR_TOT & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER, intent(in) :: Lnodes_FWD, Lnodes_BWD INTEGER, intent(in) :: nodes_FWD(max(1,Lnodes_FWD)), & nodes_BWD(max(1,Lnodes_BWD)) INTEGER, intent(inout) :: DAD(KEEP(28)) INTEGER, intent(in) :: IW(LIW), STEP(N) INTEGER, intent(in) :: MTYPE LOGICAL, intent(in) :: GLOB2LOC_SOL_ALLOC INTEGER, intent(out):: GLOB2LOC_RHS(N), GLOB2LOC_SOL(N) INTEGER, intent(out):: NBENT_RHSINTR INTEGER, intent(out):: NB_FS_IN_RHSINTR_FWD, NB_FS_IN_RHSINTR_TOT INTEGER I INTEGER ISTEP, OLDISTEP INTEGER NPIV INTEGER IPOS, LIELL INTEGER JJ, J1, JCOL, ABSJCOL INTEGER IPOSINRHSINTR_RHS, IPOSINRHSINTR_SOL INTEGER NBENT_RHSINTR_ROW, NBENT_RHSINTR_COL LOGICAL GO_UP INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE GLOB2LOC_RHS = 0 IF (GLOB2LOC_SOL_ALLOC) GLOB2LOC_SOL = 0 IPOSINRHSINTR_RHS = 0 IPOSINRHSINTR_SOL = 0 DO I = 1, Lnodes_FWD ISTEP = STEP(nodes_FWD(I)) GO_UP = .TRUE. DO WHILE(GO_UP) IF (DAD(ISTEP) .GE. 0) THEN OLDISTEP=ISTEP IF (DAD(ISTEP).EQ.0) THEN GO_UP=.FALSE. ELSE GO_UP=.TRUE. ISTEP = STEP(DAD(ISTEP)) ENDIF DAD(OLDISTEP)=-DAD(OLDISTEP)-1 ELSE GO_UP = .FALSE. ENDIF END DO END DO DO ISTEP=1, KEEP(28) IF (DAD(ISTEP) .LT. 0) THEN DAD(ISTEP) = -DAD(ISTEP) - 1 IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF(NPIV.GT.0) THEN DO JJ = J1, J1+NPIV-1 GLOB2LOC_RHS(IW(JJ)) & = IPOSINRHSINTR_RHS + JJ - J1 + 1 ENDDO IPOSINRHSINTR_RHS = IPOSINRHSINTR_RHS + NPIV IF (GLOB2LOC_SOL_ALLOC) THEN DO JJ = JCOL, JCOL+NPIV-1 GLOB2LOC_SOL(IW(JJ)) & = - ( IPOSINRHSINTR_SOL + JJ - JCOL + 1 ) ENDDO IPOSINRHSINTR_SOL = IPOSINRHSINTR_SOL + NPIV ENDIF END IF END IF ENDIF END DO NB_FS_IN_RHSINTR_FWD = IPOSINRHSINTR_RHS IF(GLOB2LOC_SOL_ALLOC) THEN DO I=1, Lnodes_BWD ISTEP = STEP(nodes_BWD(I)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF ABSJCOL = abs(IW(JCOL)) IF(NPIV.GT.0) THEN IF(GLOB2LOC_SOL(ABSJCOL).EQ.0) THEN DO JJ = JCOL, JCOL+NPIV-1 GLOB2LOC_SOL(abs(IW(JJ))) = & IPOSINRHSINTR_SOL+JJ-JCOL+1 END DO IPOSINRHSINTR_SOL = IPOSINRHSINTR_SOL + NPIV ELSE IF (GLOB2LOC_SOL(ABSJCOL).LT.0) THEN DO JJ = JCOL, JCOL+NPIV-1 GLOB2LOC_SOL(abs(IW(JJ)))= & -(GLOB2LOC_SOL(abs(IW(JJ)))) END DO ELSE GO_UP = .FALSE. END IF END IF END IF IF(DAD(ISTEP).NE.0) THEN ISTEP = STEP(DAD(ISTEP)) ELSE GO_UP = .FALSE. END IF END DO END DO END IF NB_FS_IN_RHSINTR_TOT = IPOSINRHSINTR_SOL IF (NSLAVES.NE.1) THEN DO I = 1, Lnodes_FWD ISTEP = STEP(nodes_FWD(I)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = NPIV, LIELL-1-KEEP(253) IF(GLOB2LOC_RHS(IW(J1+JJ)).EQ.0) THEN IPOSINRHSINTR_RHS = IPOSINRHSINTR_RHS + 1 GLOB2LOC_RHS(IW(JJ+J1)) = -IPOSINRHSINTR_RHS END IF END DO END IF IF(DAD(ISTEP).GT.0) THEN OLDISTEP=ISTEP ISTEP = STEP(DAD(ISTEP)) DAD(OLDISTEP)=-DAD(OLDISTEP) ELSE GO_UP = .FALSE. END IF END DO END DO DAD=ABS(DAD) IF(GLOB2LOC_SOL_ALLOC) THEN DO I=1, Lnodes_BWD ISTEP = STEP(nodes_BWD(I)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = NPIV, LIELL-1-KEEP(253) IF(GLOB2LOC_SOL(IW(JCOL+JJ)).EQ.0) THEN IPOSINRHSINTR_SOL = IPOSINRHSINTR_SOL + 1 GLOB2LOC_SOL(IW(JCOL+JJ)) = -IPOSINRHSINTR_SOL END IF END DO END IF IF(DAD(ISTEP).GT.0) THEN OLDISTEP=ISTEP ISTEP = STEP(DAD(ISTEP)) DAD(OLDISTEP)=-DAD(OLDISTEP) ELSE GO_UP = .FALSE. END IF END DO END DO DAD=ABS(DAD) END IF ENDIF NBENT_RHSINTR_ROW = IPOSINRHSINTR_RHS NBENT_RHSINTR_COL = IPOSINRHSINTR_SOL NBENT_RHSINTR = max(NBENT_RHSINTR_ROW,NBENT_RHSINTR_COL) RETURN END SUBROUTINE ZMUMPS_BUILD_GLOB2LOC_NODES_ES MUMPS_5.8.1/src/mumps_io.c0000664000175000017500000005253115042446422015232 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mumps_io.h" #include "mumps_io_basic.h" #include "mumps_io_err.h" #include "mumps_c_types.h" #if ! defined (MUMPS_WIN32) && ! defined (WITHOUT_PTHREAD) # include "mumps_io_thread.h" #endif #if ! defined(MUMPS_WIN32) double mumps_time_spent_in_sync; #endif double read_op_vol,write_op_vol,total_vol; void MUMPS_CALL MUMPS_DUMPRHSBINARY_C ( MUMPS_INT *N, MUMPS_INT *NRHS, MUMPS_INT *LRHS, float *RHS, MUMPS_INT *K35, char *filename, mumps_ftnlen l1 ) { float *RHSshift; /* float: arbitrary, we use binary content */ FILE *fd; int icol; #if defined(MUMPS_WIN32) /* "b" flag is necessary under windows */ fd=fopen(filename, "wb"); #else fd=fopen(filename, "w"); #endif RHSshift=RHS; for(icol=0;icol<*NRHS;icol++) { fwrite(RHSshift, (size_t)(*K35), (size_t)(*N), fd); RHSshift=RHSshift+(size_t)(*LRHS)*(size_t)(*K35/sizeof(float)); } fclose(fd); } void MUMPS_CALL MUMPS_DUMPMATBINARY_C ( MUMPS_INT *N, MUMPS_INT8 *NNZ, MUMPS_INT* K35, MUMPS_INT *irn, MUMPS_INT *jcn, void *A, MUMPS_INT *is_A_provided, char *filename, mumps_ftnlen l1 ) { int64_t i8; int32_t myN, tmpi; FILE *fd; #if defined(MUMPS_WIN32) /* "b" flag is necessary under windows */ fd=fopen(filename, "wb"); #else fd=fopen(filename, "w"); #endif /* cast to int32_t in case MUMPS_INT is 64-bits */ myN=(int32_t)(*N); fwrite( &myN, sizeof(int32_t), 1, fd); fwrite( NNZ, sizeof(int64_t), 1, fd); if (*NNZ > 0) { if ( sizeof(MUMPS_INT) == 4 ) { /* write irn and jcn contents directly */ fwrite( irn, sizeof(int32_t), (size_t)(*NNZ), fd); fwrite( jcn, sizeof(int32_t), (size_t)(*NNZ), fd); } else { for(i8=0;i8 < *NNZ;i8++) { tmpi=irn[i8]; fwrite(&tmpi, sizeof(int32_t), 1, fd); } for(i8=0;i8 < *NNZ;i8++) { tmpi=jcn[i8]; fwrite(&tmpi, sizeof(int32_t), 1, fd); } } if (*is_A_provided) { fwrite(A, (size_t)(*K35), (size_t)(*NNZ), fd); } } fclose(fd); } /* Tests if the request "request_id" has finished. It sets the flag */ /* argument to 1 if the request has finished (0 otherwise) */ void MUMPS_CALL MUMPS_TEST_REQUEST_C(MUMPS_INT *request_id,MUMPS_INT *flag,MUMPS_INT *ierr) { char buf[64]; /* for error message */ MUMPS_INT request_id_loc; #if ! defined(MUMPS_WIN32) && ! defined(WITHOUT_PTHREAD) MUMPS_INT flag_loc; #endif #if ! defined(MUMPS_WIN32) struct timeval start_time,end_time; gettimeofday(&start_time,NULL); #endif request_id_loc=(MUMPS_INT)*request_id; switch(mumps_io_flag_async){ case IO_SYNC: /* printf("mumps_test_request_c should not be called with strategy %d\n",mumps_io_flag_async);*/ /* JY+EA: Allow for this option, since it is similar to wait_request * and wait_request is allowed in synchronous mode. * We always return TRUE. */ *flag=1; break; #if ! defined(MUMPS_WIN32) && ! defined(WITHOUT_PTHREAD) case IO_ASYNC_TH: *ierr=(MUMPS_INT)mumps_test_request_th(&request_id_loc,&flag_loc); *flag=(MUMPS_INT)flag_loc; break; #endif default: *ierr=-92; sprintf(buf,"Error: unknown I/O strategy : %d\n",(int)mumps_io_flag_async); mumps_io_error((MUMPS_INT)*ierr,buf); return; } #if ! defined(MUMPS_WIN32) gettimeofday(&end_time,NULL); mumps_time_spent_in_sync=mumps_time_spent_in_sync+((double)end_time.tv_sec+((double)end_time.tv_usec/1000000))-((double)start_time.tv_sec+((double)start_time.tv_usec/1000000)); #endif return; } /* Waits for the termination of the request "request_id" */ void MUMPS_CALL MUMPS_WAIT_REQUEST(MUMPS_INT *request_id,MUMPS_INT *ierr) { char buf[64]; /* for error message */ MUMPS_INT request_id_loc; #if ! defined(MUMPS_WIN32) struct timeval start_time,end_time; gettimeofday(&start_time,NULL); #endif request_id_loc=(MUMPS_INT)*request_id; if(*request_id==-1) return; switch(mumps_io_flag_async){ case IO_SYNC: /* printf("mumps_wait_request should not be called with strategy %d\n",mumps_io_flag_async); */ break; #if ! defined(MUMPS_WIN32) && ! defined(WITHOUT_PTHREAD) case IO_ASYNC_TH: *ierr=(MUMPS_INT)mumps_wait_request_th(&request_id_loc); break; #endif default: *ierr=-92; sprintf(buf,"Error: unknown I/O strategy : %d\n",(int)mumps_io_flag_async); mumps_io_error((MUMPS_INT)*ierr,buf); return; /* printf("Error: unknown I/O strategy : %d\n",mumps_io_flag_async); exit (-3);*/ } #if ! defined(MUMPS_WIN32) gettimeofday(&end_time,NULL); mumps_time_spent_in_sync=mumps_time_spent_in_sync+((double)end_time.tv_sec+((double)end_time.tv_usec/1000000))-((double)start_time.tv_sec+((double)start_time.tv_usec/1000000)); #endif return; } /** * Inits the I/O OOC mechanism. * Because on some computers, file size is limited, the I/O * mechanism must be able to handle a multi-file access to data. * Hence, we compute mumps_io_nb_file, which is the the number of files * we estimate we need. * Because of not exact matching between data packets written and size * of files, the recoverment may be imperfect. Consequently, we must * be able to reallocate if necessary. */ void MUMPS_CALL MUMPS_LOW_LEVEL_INIT_PREFIX(MUMPS_INT *dim, char *str, mumps_ftnlen l1) { MUMPS_INT i; MUMPS_OOC_STORE_PREFIXLEN = *dim; if( *dim > MUMPS_OOC_PREFIX_MAX_LENGTH ) MUMPS_OOC_STORE_PREFIXLEN = MUMPS_OOC_PREFIX_MAX_LENGTH; for(i=0;i MUMPS_OOC_TMPDIR_MAX_LENGTH ) MUMPS_OOC_STORE_TMPDIRLEN = MUMPS_OOC_TMPDIR_MAX_LENGTH; for(i=0;i 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) & ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL CMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 CALL CMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .TRUE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF LASTPANEL = .FALSE. DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = BEGS_BLR(CURRENT_BLR+1)-1 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 500 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (K263.EQ.0) THEN IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK ELSE IBEG_BLOCK_FOR_IPIV = IBEG_BLR ENDIF CALL CMUMPS_FAC_I(NFRONT,NASS,NASS, & IBEG_BLOCK_FOR_IPIV,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, & DKEEP(1), PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, & TIPIV=IPIV & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTPANEL = .TRUE. ELSE IF (INOPV .LE. 0) THEN INOPV = 0 IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL CMUMPS_FAC_MQ(IBEG_BLOCK, IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 NPVW = NPVW + 1 IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB .EQ. -1) THEN LASTPANEL = .TRUE. ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF (K263.EQ.0) THEN NELIM = IEND_BLR - NPIV CALL CMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, & NFRONT, IBEG_BLOCK, NPIV, IPIV,NASS,LASTPANEL,idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR, ICNTL,KEEP,KEEP8, & DKEEP,ND,FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, .FALSE. & , NPARTSASS, CURRENT_BLR & , BLR_DUMMY, LRGROUPS & ) END IF IF ( IFLAG .LT. 0 ) GOTO 500 IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_U, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN CALL MUMPS_BUF_TEST() IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL CMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, & NPIV, NFRONT, IEND_BLR, LAST_COL, & A, LA, POSELT, & -77777, & .TRUE., .FALSE., .TRUE., & .FALSE., & LR_ACTIVATED) ENDIF CALL MUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 500 ENDIF ALLOCATE(BLR_L(NPARTSASS-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSASS-CURRENT_BLR GOTO 500 ENDIF NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_U(J)%M=0 BLR_U(J)%N=0 BLR_U(J)%K=0 BLR_U(J)%ISLR=.FALSE. NULLIFY(BLR_U(J)%Q) NULLIFY(BLR_U(J)%R) ENDDO CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) DO J=1,NPARTSASS-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF GOTO 101 ENDIF END_I=NB_BLR #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), & KEEP(458), KEEP(473), BLR_U, & CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, 2, KEEP(483), KEEP8, & END_I_IN=END_I & ) IF (IFLAG.LT.0) GOTO 300 IF ((KEEP(480).NE.0.AND.NB_BLR.GT.CURRENT_BLR) & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U, 0) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (PIVOT_OPTION.LT.3) THEN IF (PIVOT_OPTION.LT.2) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF LAST_BLOCK=NB_BLR CALL CMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_U, CURRENT_BLR, & FIRST_BLOCK, LAST_BLOCK, 2, 0, 1, & .FALSE.) ENDIF 300 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif ENDIF 101 CONTINUE IF (LR_ACTIVATED .OR. (K263.NE.0.AND.PIVOT_OPTION.GE.3)) THEN NELIM = IEND_BLR - NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_U)) THEN BLR_SEND=>BLR_U ENDIF CALL CMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, NFRONT, & IBEG_BLR, NPIV, IPIV, NASS,LASTPANEL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR & , BLR_SEND, LRGROUPS & ) ENDIF IF (.NOT. LR_ACTIVATED) THEN LAST_COL = NFRONT IF (PIVOT_OPTION.EQ.2) THEN FIRST_COL = NASS ELSE FIRST_COL = NPIV ENDIF IF (IEND_BLR.LT.NASS .OR. PIVOT_OPTION.LT.3) THEN CALL CMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, LAST_COL, & A, LA, POSELT, FIRST_COL, .TRUE., (PIVOT_OPTION.LT.3), & .TRUE., (KEEP(377).EQ.1), & LR_ACTIVATED) ENDIF IF (K263.NE.0 .AND. PIVOT_OPTION.LT.3) THEN NELIM = IEND_BLR - NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_U)) THEN BLR_SEND=>BLR_U ENDIF CALL CMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, & NFRONT, IBEG_BLR, NPIV, IPIV, NASS,LASTPANEL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR & , BLR_SEND, LRGROUPS & ) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL CMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8 & ) IF (IFLAG.LT.0) GOTO 600 CALL CMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8, & END_I_IN=END_I & ) 600 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF ENDIF GOTO 100 ENDIF IF (KEEP(475).EQ.0) THEN IF (IEND_BLR.LT.NFRONT) THEN CALL CMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & -77777, & A, LA, POSELT, & -77777, & .TRUE., .FALSE., .FALSE., & .FALSE., & LR_ACTIVATED) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(UPOS,LPOS,FIRST_BLOCK,LAST_BLOCK) #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NPARTSASS, DKEEP(8), KEEP(466), & KEEP(458), KEEP(473), & BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8 & ) #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF ((KEEP(480).NE.0.AND.NB_BLR.GT.CURRENT_BLR) & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(475).GT.0) THEN CALL CMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NPARTSASS, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NPARTSASS, 2, 0, 0, .FALSE.) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF IF (KEEP(480).GE.2) THEN UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) LPOS = POSELT+int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) CALL CMUMPS_BLR_UPD_NELIM_VAR_L(A, LA, UPOS, A, LA, LPOS, & IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NPARTSASS, & CURRENT_BLR+1, NELIM, 'N') IF (IFLAG.LT.0) GOTO 444 IF (IEND_BLR.LT.NASS) THEN CALL CMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8 & ) IF (IFLAG.LT.0) GOTO 442 CALL CMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8, & END_I_IN=END_I & ) 442 CONTINUE ENDIF 444 CONTINUE ELSE CALL CMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, BLR_L, NPARTSASS, & BLR_U, NB_BLR, NELIM, .FALSE., 0, & 2, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(475).GT.0) THEN FIRST_BLOCK = CURRENT_BLR+1 IF (KEEP(486).EQ.2.AND.UU.EQ.0) THEN LAST_BLOCK = CURRENT_BLR ELSE LAST_BLOCK = NPARTSASS ENDIF CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NPARTSASS, BLR_L, CURRENT_BLR, 'V', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) #if ! defined(BLR_NOOPENMP) #endif ENDIF IF (KEEP(475).GE.2) THEN IF (KEEP(475).EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF IF (KEEP(486).NE.2) THEN LAST_BLOCK = END_I ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_U, CURRENT_BLR, 'H', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0.OR.NB_BLR.EQ.CURRENT_BLR) THEN CALL DEALLOC_BLR_PANEL(BLR_U, NB_BLR-CURRENT_BLR, & KEEP8, KEEP(34)) CALL DEALLOC_BLR_PANEL(BLR_L, NPARTSASS-CURRENT_BLR, & KEEP8, KEEP(34)) DEALLOCATE(BLR_U,BLR_L) ENDIF ENDIF NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_TRY_WRITE MonBloc%LastPiv = NPIV LAST_CALL= .FALSE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO IP=1,NB_BLR+1 BEGS_BLR_TMP(IP) = BEGS_BLR_STATIC(IP) ENDDO ENDIF ENDIF IF ( & (KEEP(486).EQ.2) & ) THEN MEM_TOT = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP& PRIVATE(IP, LorU, DIR, NELIM) #endif #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*(2*DIAGSIZ_STA-DIAGSIZ_DYN) MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA IF (I.LE.DIAGSIZ_DYN) THEN DIAG(DPOS:DPOS+DIAGSIZ_STA-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_STA-1,8)) DPOS = DPOS + DIAGSIZ_STA ELSE DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN ENDIF POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL CMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG, KEEP(34)) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO !$OMP SINGLE #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM_TOT,8), & .FALSE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 460 IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN DO IP=1,NPARTSASS NELIM = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) DO LorU=0,1 #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8, & KEEP(34)) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (LorU.EQ.0) THEN DIR = 'V' ELSE DIR = 'H' ENDIF CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(458), KEEP(473), & BLR_PANEL, IP, & DIR, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 440 ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif 440 CONTINUE ENDIF 460 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN deallocate(BEGS_BLR_TMP) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 500 IF ( & (KEEP(486).EQ.2) & ) THEN CALL CMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (IFLAG.GE.0) THEN CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 0, NELIM) DO IP=1,NPARTSASS CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NPARTSASS-IP & ) CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 1, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NB_BLR-IP & ) ENDDO CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NASS-NELIM, 0, 2) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 0, 2) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 500 IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF CALL CMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 700 480 CONTINUE 500 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 700 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL CMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 2, & KEEP8, KEEP(34)) ENDIF ENDIF IF ( LR_ACTIVATED .AND. KEEP(486).EQ. 2 .AND. & KEEP(251) .EQ. 2) THEN CALL CMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8, KEEP(34)) ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL CMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34)) ENDIF ENDIF DEALLOCATE( IPIV ) RETURN END SUBROUTINE CMUMPS_FAC2_LU END MODULE CMUMPS_FAC2_LU_M MUMPS_5.8.1/src/sfac_diag.F0000664000175000017500000000120215042446441015233 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_GETSETDIAGRETURN() C C This file contain code to access/return the C diagonal of a factorized matrix in the future. C RETURN END SUBROUTINE SMUMPS_GETSETDIAGRETURN MUMPS_5.8.1/src/cfac_asm.F0000664000175000017500000010700315042446440015074 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, NBROWS, NBCOLS, ROWLIST, & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, & OPASSW, IWPOSCB, MYID, KEEP,KEEP8, IS_ofType5or6, & LDA_VALSON, ICOL_BEG ) 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, INTENT(IN) :: ICOL_BEG INTEGER(8) :: POSELT, POSEL1, APOS, JJ2 INTEGER 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 IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS1 = abs(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 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+(ICOL_BEG-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 + ICOL_BEG-1 + 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 = ICOL_BEG, min(DIAG,ICOL_BEG+NBCOLS-1) JJ2 = APOS+int(JJ1-1,8) A(JJ2) = A(JJ2) + VALSON(JJ1-ICOL_BEG+1,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 = ICOL_BEG, min(NELIM, ICOL_BEG+NBCOLS-1) JJ2 = APOS + int(IW(J1+JJ1-1),8)*int(LDAFS_PERE,8) A(JJ2) = A(JJ2) + VALSON(JJ1-ICOL_BEG+1,JJ) ENDDO IBEG = max(NELIM+1,ICOL_BEG) ELSE IBEG = ICOL_BEG ENDIF APOS = POSEL1 + int(ROWLIST(JJ),8) * int(LDAFS_PERE,8) DO JJ1 = IBEG, ICOL_BEG + NBCOLS - 1 IF (ROWLIST(JJ).LT.IW(J1 + JJ1 - 1)) EXIT JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) A(JJ2) = A(JJ2) + VALSON(JJ1-ICOL_BEG+1,JJ) ENDDO ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_ASM_SLAVE_MASTER SUBROUTINE CMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, INTARR, DBLARR, & ICNTL, KEEP,KEEP8, MYID, LRGROUPS) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID INTEGER NBROWS, NBCOLS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) COMPLEX :: RHS_MUMPS(KEEP8(85)) COMPLEX :: A(LA) INTEGER :: INTARR(KEEP8(27)) COMPLEX :: DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) INTEGER(8) :: POSELT COMPLEX, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL CMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) IF (NASS.LT.0) THEN NASS = -NASS IW(IOLDPS+1+KEEP(IXSZ)) = NASS CALL CMUMPS_ASM_SLAVE_ARROWHEADS(INODE, STEP(INODE), & N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, & ITLOC, FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, KEEP8(27), KEEP8(26), & RHS_MUMPS, LRGROUPS) ENDIF IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_ASM_SLAVE_TO_SLAVE_INIT SUBROUTINE CMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, NBROWS, STEP, PTRIST, & ITLOC, RHS_MUMPS, KEEP,KEEP8) IMPLICIT NONE INTEGER N, LIW INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER INODE INTEGER NBROWS INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP8(85)) INCLUDE 'mumps_headers.h' INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J IOLDPS = PTRIST(STEP(INODE)) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_ASM_SLAVE_TO_SLAVE_END SUBROUTINE CMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, ROWLIST, COLLIST, VALSON, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, FILS, & ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, LDA_VALSON) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY: CMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID LOGICAL, intent(in) :: IS_ofType5or6 INTEGER NBROWS, NBCOLS, LDA_VALSON INTEGER ROWLIST(NBROWS), COLLIST(NBCOLS) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRAST(KEEP(28)) COMPLEX A(LA), VALSON(LDA_VALSON,NBROWS) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8) :: POSEL1, POSELT, APOS, K8 INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & I,J,NASS,IDIAG COMPLEX, POINTER, DIMENSION(:) :: A_PTR INTEGER(8) :: LA_PTR INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL CMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) IF ( NBROWS .GT. NBROWF ) THEN WRITE(*,*) ' ERR: ERROR : NBROWS > NBROWF' WRITE(*,*) ' ERR: INODE =', INODE WRITE(*,*) ' ERR: NBROW=',NBROWS,'NBROWF=',NBROWF WRITE(*,*) ' ERR: ROW_LIST=', ROWLIST WRITE(*,*) ' ERR: NBCOLF/NASS=', NBCOLF, NASS CALL MUMPS_ABORT() END IF NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) IF (NBROWS.GT.0) THEN POSEL1 = POSELT - int(NBCOLF,8) IF (KEEP(50).EQ.0) THEN IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) DO I=1, NBROWS DO J = 1, NBCOLS A_PTR(APOS+int(J-1,8)) = A_PTR( APOS+int(J-1,8)) + & VALSON(J,I) ENDDO APOS = APOS + int(NBCOLF,8) END DO ELSE DO I=1,NBROWS APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) DO J=1,NBCOLS K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO ENDDO ENDIF ELSE IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) & + int((NBROWS-1),8)*int(NBCOLF,8) IDIAG = 0 DO I=NBROWS,1,-1 DO J=1,NBCOLS-IDIAG K8 = APOS+int(J-1,8) A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO APOS = APOS - int(NBCOLF,8) IDIAG = IDIAG + 1 ENDDO ELSE DO I=1,NBROWS APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) DO J=1,NBCOLS IF (ITLOC(COLLIST(J)) .EQ. 0) THEN EXIT ENDIF K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO ENDDO ENDIF ENDIF OPASSW = OPASSW + dble(NBROWS*NBCOLS) ENDIF RETURN END SUBROUTINE CMUMPS_ASM_SLAVE_TO_SLAVE SUBROUTINE CMUMPS_LDLT_ASM_NIV12_IP( A, LA, & IAFATH, NFRONT, NASS1, & IACB, NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED ) IMPLICIT NONE INTEGER NFRONT, NASS1 INTEGER(8) :: LA INTEGER NCOLS, NROWS, NELIM INTEGER(8) :: LCB COMPLEX A( LA ) INTEGER(8) :: IAFATH, IACB INTEGER IW( NCOLS ) INTEGER ETATASS LOGICAL CB_IS_COMPRESSED COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB, IBEGCBROW, IENDFRONT LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE IENDFRONT = IAFATH+int(NFRONT,8)*int(NFRONT,8)-1_8 IPOSCB=1_8 RESET_TO_ZERO = IACB .LT. IENDFRONT + 1_8 RISK_OF_SAME_POS = IACB + LCB .EQ. IENDFRONT + 1_8 RISK_OF_SAME_POS_THIS_LINE = .FALSE. DO I=1, NROWS POSELT = int(IW(I)-1,8) * int(NFRONT,8) IF (.NOT. CB_IS_COMPRESSED ) THEN IPOSCB = 1_8 + int(I - 1,8) * int(NCOLS,8) IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN RESET_TO_ZERO = .FALSE. ENDIF ENDIF IF ( RISK_OF_SAME_POS ) THEN IF (I.EQ.NROWS .OR. .NOT. CB_IS_COMPRESSED) THEN IF ( IAFATH + POSELT + int(IW(I)-1,8) .EQ. & IACB+IPOSCB+int(I-1-1,8)) THEN RISK_OF_SAME_POS_THIS_LINE = .TRUE. ENDIF ENDIF ENDIF IF (RESET_TO_ZERO) THEN IF ( RISK_OF_SAME_POS_THIS_LINE ) THEN DO J=1, I APOS = POSELT + int(IW( J ),8) IF (IAFATH + APOS - 1_8.NE. IACB+IPOSCB-1_8) THEN A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) A(IACB+IPOSCB-1_8) = ZERO ENDIF IPOSCB = IPOSCB + 1_8 ENDDO ELSE #if defined(__ve__) !NEC$ IVDEP #endif 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 #if defined(__ve__) !NEC$ IVDEP #endif DO J=1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB + 1_8 ENDDO ENDIF IF (.NOT. CB_IS_COMPRESSED ) THEN IBEGCBROW = IACB+IPOSCB-1_8 IF ( IBEGCBROW .LE. IENDFRONT ) THEN A(IBEGCBROW:IBEGCBROW+int(NCOLS-I,8)-1_8)=ZERO ENDIF ENDIF IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN RESET_TO_ZERO = .FALSE. ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_LDLT_ASM_NIV12_IP SUBROUTINE CMUMPS_LDLT_ASM_NIV12( A, LA, SON_A, & IAFATH, NFRONT, NASS1, & NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED !$ & , K360 & ) IMPLICIT NONE INTEGER NFRONT, NASS1 INTEGER(8) :: LA INTEGER NCOLS, NROWS, NELIM INTEGER(8) :: LCB COMPLEX A( LA ) COMPLEX SON_A( LCB ) INTEGER(8) :: IAFATH INTEGER IW( NCOLS ) INTEGER ETATASS LOGICAL CB_IS_COMPRESSED !$ INTEGER, INTENT(in):: K360 COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB !$ LOGICAL :: OMP_FLAG IF ((ETATASS.EQ.0) .OR. (ETATASS.EQ.1)) THEN IPOSCB = 1_8 #if defined(__ve__) !NEC$ IVDEP #endif 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 #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IAFATH+ APOS -1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO END DO ENDIF IF ((ETATASS.EQ.0).OR.(ETATASS.EQ.1)) THEN !$ OMP_FLAG = (NROWS-NELIM).GE.K360 !$OMP PARALLEL DO PRIVATE(IPOSCB, POSELT, J, APOS) IF (OMP_FLAG) DO I = NELIM + 1, NROWS IF (CB_IS_COMPRESSED) THEN IPOSCB = (int(I,8) * int(I-1,8)) / 2_8 + 1_8 ELSE IPOSCB = int(I-1,8) * int(NCOLS,8) + 1_8 ENDIF POSELT = int(IW( I ),8) IF (POSELT.LE. int(NASS1,8)) THEN #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, NELIM APOS = POSELT + int( IW( J ) - 1, 8 ) * int(NFRONT,8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) + & SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ELSE POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, NELIM APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ENDIF IF (ETATASS.EQ.1) THEN POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J = NELIM + 1, I IF (IW(J).GT.NASS1) EXIT APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB +1_8 END DO ELSE POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) #if defined(__ve__) !NEC$ IVDEP #endif DO J = NELIM + 1, I APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ENDIF END DO !$OMP END PARALLEL DO ELSE DO I= NROWS, NELIM+1, -1 IF (CB_IS_COMPRESSED) THEN IPOSCB = (int(I,8)*int(I+1,8))/2_8 ELSE IPOSCB = int(I-1,8) * int(NCOLS,8) + int(I,8) ENDIF POSELT = int(IW( I ),8) IF (POSELT.LE.int(NASS1,8)) EXIT POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J=I,NELIM+1, -1 IF (IW(J).LE.NASS1) EXIT APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB - 1_8 ENDDO ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_LDLT_ASM_NIV12 SUBROUTINE CMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST_S, IW, LIW, STEP, KEEP,KEEP8) IMPLICIT NONE INTEGER N, ISON, INODE, IWPOSCB INTEGER KEEP(500), STEP(N) INTEGER(8) KEEP8(150) INTEGER PIMASTER(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER LIW INTEGER IW(LIW) INTEGER ISTCHK, LSTK, NSLSON, HS, NROWS, NCOLS, NPIVS, NELIM INTEGER IOLDPS, NFRONT, NSLAVES, ICT11, HF INTEGER J1, J2, J3, JJ, JPOS LOGICAL SAME_PROC INCLUDE 'mumps_headers.h' ISTCHK = PIMASTER(STEP(ISON)) LSTK = IW(ISTCHK+KEEP(IXSZ)) NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NELIM = IW(ISTCHK + 1+KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) NCOLS = NPIVS + LSTK IF ( NPIVS < 0 ) NPIVS = 0 SAME_PROC = ISTCHK < IWPOSCB IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2+KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS IF (KEEP(50).NE.0) THEN J2 = J1 + LSTK - 1 DO JJ = J1, J2 IW(JJ) = IW(JJ - NROWS) ENDDO ELSE J2 = J1 + LSTK - 1 J3 = J1 + NELIM DO JJ = J3, J2 IW(JJ) = IW(JJ - NROWS) ENDDO IF (NELIM .NE. 0) THEN IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) ICT11 = IOLDPS + HF - 1 + NFRONT J3 = J3 - 1 DO 190 JJ = J1, J3 JPOS = IW(JJ) + ICT11 IW(JJ) = IW(JPOS) 190 CONTINUE ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_RESTORE_INDICES SUBROUTINE CMUMPS_ASM_MAX( & N, INODE, IW, LIW, A, LA, & ISON, NBCOLS, & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, & OPASSW, IWPOSCB,MYID, KEEP,KEEP8 ) 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,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 = abs(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) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOSCB) IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2 + KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS APOS = POSELT + int(NASS1,8)*int(NASS1,8) - 1_8 DO JJ1 = 1, NBCOLS JJ2 = APOS+int(IW(J1 + JJ1 - 1),8) IF(real(A(JJ2)) .LT. VALSON(JJ1)) THEN A(JJ2) = cmplx(VALSON(JJ1),kind=kind(A)) ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_ASM_MAX SUBROUTINE CMUMPS_ASM_SLAVE_ARROWHEADS(INODE, ISTEP, & N, IW, LIW, IOLDPS, & A, LA, POSELT, KEEP, KEEP8, & ITLOC, FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LINTARR, LDBLARR, RHS_MUMPS, LRGROUPS) !$ USE OMP_LIB USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, intent(in) :: N, LIW, IOLDPS, INODE, ISTEP INTEGER(8), intent(in) :: LA, POSELT INTEGER(8), intent(in) :: LINTARR, LDBLARR INTEGER, intent(in) :: IW(LIW) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(inout) :: ITLOC(N+KEEP(253)) COMPLEX, intent(inout) :: A(LA) COMPLEX, intent(in) :: RHS_MUMPS(KEEP8(85)) COMPLEX, intent(in) :: DBLARR(LDBLARR) INTEGER, intent(in) :: INTARR(LINTARR) INTEGER, intent(in) :: FILS(N) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 !$ INTEGER :: CHUNK INCLUDE 'mumps_headers.h' INTEGER :: HF, NBROWF, NBCOLF, NASS, NSLAVES INTEGER :: ILOC, J, K, K1, K2, JPOS, IJROW INTEGER :: IN, IARR1, IORG INTEGER(8) :: J18, J28, JJ8 INTEGER(8) :: APOS, ICT12 INTEGER(8) :: AINPUT8 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE, TOPDIAG INTEGER(8) :: JJ3 INTEGER :: K1RHS, K2RHS, JFirstRHS COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) !$ NOMP = OMP_GET_MAX_THREADS() IF (KEEP(50) .EQ. 0 .OR. NBROWF .LT. KEEP(63)) THEN !$ CHUNK8 = int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8) !$OMP& .AND. NOMP .GT. 1) DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = 0 IF (IW(IOLDPS+XXLR).GE.1) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0, & NBROWF, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) NB_BLR_LS = NPARTSCB call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR_LS) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS, & NBCOLF, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max( KEEP(360)/2, !$ & ((NBROWF+NOMP-1)/NOMP +2) / 3 ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK) !$OMP& IF (NBROWF .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(NBROWF-1,8) APOS = POSELT+ JJ8*int(NBCOLF,8) JJ3 = min( int(NBCOLF,8) - 1_8, & JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG ) A(APOS: APOS+JJ3) = ZERO ENDDO !$OMP END PARALLEL DO ENDIF K1 = IOLDPS + HF + NBROWF K2 = K1 + NASS - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = -JPOS JPOS = JPOS + 1 ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF - 1 JPOS = 1 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN K1RHS = 0 K2RHS = -1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN K1RHS = K JFirstRHS=J-N ENDIF JPOS = JPOS + 1 ENDDO IF (K1RHS.GT.0) K2RHS=K2 IF ( K2RHS.GE.K1RHS ) THEN IN = INODE DO WHILE (IN.GT.0) IJROW = -ITLOC(IN) DO K = K1RHS, K2RHS J = IW(K) ILOC = ITLOC(J) APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+IN) ENDDO IN = FILS(IN) ENDDO ENDIF ELSE DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF IN = INODE IORG = 0 IARR1 = PTRDEBARR(ISTEP) DO WHILE (IN.GT.0) IORG = IORG + 1 AINPUT8 = PTR8ARR( IARR1 + IORG -1 ) J18 = AINPUT8 J28 = J18 + NINCOLARR(IARR1+IORG-1) IJROW = -ITLOC(INTARR(J18)) ICT12 = POSELT +int(- NBCOLF + IJROW - 1,8) DO JJ8= J18,J28 ILOC = ITLOC(INTARR(JJ8)) IF (ILOC.GT.0) THEN APOS = ICT12 + int(ILOC,8)*int(NBCOLF,8) A(APOS) = A(APOS) + DBLARR(AINPUT8) ENDIF AINPUT8 = AINPUT8 + 1_8 ENDDO IN = FILS(IN) ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF + NASS - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO RETURN END SUBROUTINE CMUMPS_ASM_SLAVE_ARROWHEADS SUBROUTINE CMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS1, KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(out) :: PARPIV_T1 INTEGER :: NCB LOGICAL, EXTERNAL :: CMUMPS_IS_TRSM_LARGE_ENOUGH, & CMUMPS_IS_GEMM_LARGE_ENOUGH PARPIV_T1 = KEEP(269) IF (PARPIV_T1.EQ.-3) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.77) THEN PARPIV_T1 = 0 ENDIF NCB = NFRONT-NASS1 IF (NCB.EQ.KEEP(253)) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.0) RETURN IF ( (PARPIV_T1.EQ.-2).AND.LR_ACTIVATED ) THEN PARPIV_T1 = 1 ENDIF IF (PARPIV_T1.EQ.-2) THEN IF ( & ( CMUMPS_IS_TRSM_LARGE_ENOUGH ( NASS1, NCB & ) & ) & .OR. & ( CMUMPS_IS_GEMM_LARGE_ENOUGH ( NCB, NCB, NASS1 & ) & ) & ) THEN PARPIV_T1 = 1 ELSE PARPIV_T1 = 0 ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SET_PARPIVT1 LOGICAL FUNCTION CMUMPS_IS_TRSM_LARGE_ENOUGH & ( M, N & ) IMPLICIT NONE INTEGER, INTENT(in) :: M, N DOUBLE PRECISION :: AI INTEGER, PARAMETER :: THRES_AI = 400 AI = ( dble(M)*dble(N) ) / & ( dble(M)/dble(2) + dble(2)*dble(N) ) CMUMPS_IS_TRSM_LARGE_ENOUGH = (AI.GE.dble(THRES_AI)) RETURN END FUNCTION CMUMPS_IS_TRSM_LARGE_ENOUGH LOGICAL FUNCTION CMUMPS_IS_GEMM_LARGE_ENOUGH & ( M, N, K & ) IMPLICIT NONE INTEGER, INTENT(in) :: M, N, K DOUBLE PRECISION :: AI INTEGER, PARAMETER :: THRES_AI = 400 AI = ( dble(2)*dble(M)*dble(N)*dble(K) ) / & ( dble(M)*dble(N) + dble(M)*dble(K) + dble(K)*dble(N) ) CMUMPS_IS_GEMM_LARGE_ENOUGH = (AI.GE.dble(THRES_AI)) RETURN END FUNCTION CMUMPS_IS_GEMM_LARGE_ENOUGH SUBROUTINE CMUMPS_PARPIVT1_SET_MAX ( INODE, & A, LAELL8, KEEP, NFRONT, & NASS1, NVSCHUR_K253, NB_POSTPONED) !$ USE OMP_LIB IMPLICIT NONE INTEGER(8), intent(in) :: LAELL8 INTEGER, intent(in) :: INODE INTEGER, intent(in) :: KEEP(500), NFRONT, NASS1, & NVSCHUR_K253 INTEGER, intent(in) :: NB_POSTPONED COMPLEX, intent(inout) :: A(LAELL8) INTEGER(8) :: APOSMAX, APOS, NASS1_8, NFRONT_8 INTEGER :: I, J, NCB COMPLEX :: ZERO REAL :: RMAX LOGICAL :: OMP_FLAG INTEGER :: JB, NB_BLOCKS, BLSIZE INTEGER(8) :: APOSSHIFT INTEGER :: NOMP PARAMETER( ZERO = (0.0E0,0.0E0) ) NASS1_8 = int(NASS1, 8) NFRONT_8 = int(NFRONT, 8) NCB = NFRONT-NASS1-NVSCHUR_K253 IF ((NCB.EQ.0).AND.(NVSCHUR_K253.EQ.0)) CALL MUMPS_ABORT() APOSMAX = LAELL8 - NASS1_8 + 1_8 A(APOSMAX:APOSMAX+NASS1_8-1_8)= ZERO IF (NCB.EQ.0) RETURN IF (KEEP(50).EQ.2) THEN IF ( NASS1 .LE. KEEP(366) ) THEN APOS = 1_8 + (NASS1_8*NFRONT_8) DO I = 1, NCB DO J = 1, NASS1 RMAX = real(A(APOSMAX+int(J,8)-1_8)) RMAX = max(RMAX, abs(A(APOS+int(J,8)-1_8))) A(APOSMAX+int(J,8)-1_8) = cmplx(RMAX,kind=kind(A)) ENDDO APOS = APOS+NFRONT_8 ENDDO ELSE NOMP = 1 !$ NOMP = OMP_GET_MAX_THREADS() OMP_FLAG = int(NCB,8)*int(NASS1,8) .GT. int(KEEP(361),8) & .AND. (NASS1 .GT. KEEP(366)) .AND. (NOMP.GT.1) BLSIZE = max(KEEP(366),1) NB_BLOCKS = NASS1 / BLSIZE BLSIZE = (NASS1 + NB_BLOCKS - 1)/ NB_BLOCKS APOSSHIFT=NASS1_8 * NFRONT_8 !$OMP PARALLEL DO PRIVATE(I,J,APOS,JB,RMAX) IF (OMP_FLAG) DO JB = 1, NASS1, BLSIZE DO I = 1, NCB DO J = JB, min(JB+BLSIZE-1,NASS1) APOS = APOSSHIFT + int(I-1,8) * int(NFRONT,8) + int(J,8) RMAX = real( A(APOSMAX+int(J,8) - 1_8) ) RMAX = max( RMAX, abs(A(APOS+int(J,8)) ) ) A(APOSMAX+int(J,8)-1_8) = cmplx(RMAX,kind=kind(A)) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF ELSE OMP_FLAG = int(NCB,8)*int(NASS1,8) .GT. int(KEEP(361),8) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(I,J,APOS,RMAX) DO I = 1, NASS1 RMAX = 0.0E0 APOS = 1_8 + NASS1_8+int(I-1,8)*NFRONT_8 DO J = 1, NCB RMAX = max(RMAX, abs(A(APOS+int(J-1,8)))) ENDDO A(APOSMAX+int(I,8)-1_8) = cmplx(RMAX,kind=kind(A)) ENDDO !$OMP END PARALLEL DO ELSE APOS = 1_8 + NASS1_8 DO I = 1, NASS1 RMAX = 0.0E0 DO J = 1, NCB RMAX = max(RMAX, abs(A(APOS+int(J,8)-1))) ENDDO A(APOSMAX+int(I,8)-1_8) = cmplx(RMAX,kind=kind(A)) APOS = APOS+NFRONT_8 ENDDO ENDIF ENDIF CALL CMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, A(APOSMAX), NASS1, NB_POSTPONED) RETURN END SUBROUTINE CMUMPS_PARPIVT1_SET_MAX SUBROUTINE CMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, PARPIV, LPARPIV, & NB_POSTPONED) IMPLICIT NONE INTEGER, intent(in) :: INODE, LPARPIV, KEEP(500) COMPLEX, intent(inout):: PARPIV(LPARPIV) INTEGER, intent(in) :: NB_POSTPONED INTEGER :: I REAL :: EPS, RMIN, RZERO, RTMP REAL :: RMAX LOGICAL :: UPDATE_PARPIV PARAMETER( RZERO = 0.0E0 ) UPDATE_PARPIV=.FALSE. RMIN = huge(RZERO) RMAX = RZERO EPS = sqrt(epsilon(RZERO))*0.01E0 DO I = 1, LPARPIV RTMP = real(PARPIV(I)) IF (RTMP.GT.RZERO) THEN RMIN = min(RMIN, RTMP) ELSE UPDATE_PARPIV=.TRUE. ENDIF IF (RTMP.LE.EPS) UPDATE_PARPIV=.TRUE. RMAX= max(RMAX,real(PARPIV(I))) ENDDO IF (UPDATE_PARPIV) THEN IF (RMIN.LT.huge(RMIN)) THEN RMAX= min (RMAX, EPS) DO I = 1, LPARPIV-NB_POSTPONED RTMP = real(PARPIV(I)) IF (RTMP.LE.EPS) THEN PARPIV(I) = cmplx(-RMAX, kind=kind(PARPIV)) ENDIF ENDDO IF (NB_POSTPONED.GT.0) THEN DO I=LPARPIV-NB_POSTPONED+1, LPARPIV RTMP = real(PARPIV(I)) IF (RTMP.LE.EPS) THEN PARPIV(I) = cmplx(-RMAX, kind=kind(PARPIV)) ENDIF ENDDO ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_UPDATE_PARPIV_ENTRIES SUBROUTINE CMUMPS_PARPIVT1_SET_NVSCHUR_MAX & (N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1, & NB_POSTPONED) USE CMUMPS_FAC_FRONT_AUX_M, ONLY: CMUMPS_GET_SIZE_SCHUR_IN_FRONT IMPLICIT NONE INTEGER, intent(in) :: N, INODE, LIW, IOLDPS, & NFRONT, NASS1, NB_POSTPONED INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: IW (LIW), PERM(N), KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED COMPLEX, intent(inout) :: A(LA) INTEGER, intent(inout) :: PARPIV_T1 INTEGER :: NVSCHUR_K253, IROW_L INTEGER(8) :: LAELL8, NFRONT8 INCLUDE 'mumps_headers.h' IF (PARPIV_T1.EQ.-999) THEN CALL CMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) ELSE IF ((PARPIV_T1.NE.0.AND.PARPIV_T1.NE.1)) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.NE.0) THEN IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) ) THEN IROW_L = IOLDPS+6+KEEP(IXSZ)+NASS1 CALL CMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS1, & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR_K253 ) ELSE NVSCHUR_K253 = KEEP(253) ENDIF NFRONT8 = int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 + int(NASS1,8) CALL CMUMPS_PARPIVT1_SET_MAX ( INODE, & A(POSELT), LAELL8, KEEP, & NFRONT, NASS1, NVSCHUR_K253, & NB_POSTPONED ) ENDIF RETURN END SUBROUTINE CMUMPS_PARPIVT1_SET_NVSCHUR_MAX MUMPS_5.8.1/src/sfac_process_contrib_type3.F0000664000175000017500000002570315042446437020672 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_PROCESS_CONTRIB_TYPE3(BUFR,LBUFR, & LBUFR_BYTES, & root, roota, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND,PROCNODE_STEPS, SLAVEF, OPASSW ) USE MUMPS_LOAD USE SMUMPS_OOC USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC ) :: root TYPE (SMUMPS_ROOT_STRUC ) :: roota INTEGER :: KEEP( 500 ) INTEGER(8) :: KEEP8(150) REAL :: DKEEP(230) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER LBUFR, LBUFR_BYTES, N, LIW, & IWPOS, IWPOSCB, COMP, COMM, COMM_LOAD, IFLAG, & IERROR INTEGER LPOOL, LEAF INTEGER IPOOL( LEAF ) INTEGER PTRIST(KEEP(28)) INTEGER PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), ITLOC( N+KEEP(253) ) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER BUFR( LBUFR_BYTES ) INTEGER IW( LIW ) INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER SLAVEF REAL A( LA ) INTEGER MYID INTEGER FILS( N ), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER INTARR(KEEP8(27)) REAL DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW 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( STEP(IROOT)) .NE. 0 ) THEN IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NSUBSET_ROW & - NSUPROW .OR. NSUBSET_ROW - NSUPROW.EQ.0 .OR. & NSUBSET_COL_EFF .EQ. 0)THEN KEEP(121) = KEEP(121) - 1 IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL SMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSEIF (KEEP(201).EQ.2) THEN CALL SMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL SMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), & KEEP(28), KEEP(76), & KEEP(80), KEEP(47), & STEP, IROOT + N) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ENDIF ENDIF ELSE IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. & NSUBSET_ROW - NSUPROW .OR. & NSUBSET_ROW - NSUPROW.EQ.0 .OR. & NSUBSET_COL_EFF .EQ. 0)THEN KEEP(121)=-1 ENDIF CALL SMUMPS_ROOT_ALLOC_STATIC( root, roota, IROOT, N, & IW, LIW, A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) IF ( IFLAG .LT. 0 ) RETURN END IF IF (KEEP(60) .EQ.0) THEN IF ( PTRIST(STEP(IROOT)) .GE. 0 ) THEN IF ( PTRIST(STEP(IROOT)) .NE. 0 ) THEN LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) POS_ROOT = PAMASTER(STEP( IROOT )) ELSE LOCAL_N = IW( PTLUST(STEP( IROOT ) ) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST(STEP( IROOT ) ) + 2 + KEEP(IXSZ)) POS_ROOT = PTRFAC(IW(PTLUST(STEP(IROOT))+4+ & KEEP(IXSZ))) END IF ENDIF ELSE LOCAL_M = root%SCHUR_LLD LOCAL_N = root%SCHUR_NLOC ENDIF IF ( (BBPCBP.EQ.1).AND. (NBROWS_ALREADY_SENT.EQ.0).AND. & (min(NSUPROW, NSUPCOL) .GT. 0) & ) THEN LREQI = NSUPROW+NSUPCOL LREQA = int(NSUPROW,8) * int(NSUPCOL,8) IF ( (LREQA.NE.0_8) .AND. & (PTRIST(STEP(IROOT)).LT.0).AND. & KEEP(60)==0) THEN WRITE(*,*) ' Error in SMUMPS_PROCESS_CONTRIB_TYPE3' CALL MUMPS_ABORT() ENDIF CALL SMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 1 ), LREQI, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( IPTRLU + 1_8 ), int(LREQA), & MPI_REAL, COMM, IERR ) OPASSW = OPASSW + LREQA CALL SMUMPS_ASS_ROOT( root, roota, KEEP(50), NSUPROW, NSUPCOL, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NSUPROW + 1 ), NSUPCOL, & A( IPTRLU + 1_8 ), & A( 1 ), & LOCAL_M, LOCAL_N, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & 1) IWPOSCB = IWPOSCB + LREQI IPTRLU = IPTRLU + LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) ENDIF LREQI = NBROWS_PACKET + NSUBSET_COL_EFF LREQA = int(NBROWS_PACKET,8) * int(NSUBSET_COL_EFF,8) IF ( (LREQA.NE.0_8) .AND. & (PTRIST(STEP(IROOT)).LT.0).AND. & KEEP(60)==0) THEN WRITE(*,*) ' Error in SMUMPS_PROCESS_CONTRIB_TYPE3' CALL MUMPS_ABORT() ENDIF IF (LREQA.NE.0_8) THEN CALL SMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 1 ), LREQI, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( IPTRLU + 1_8 ), int(LREQA), & MPI_REAL, COMM, IERR ) OPASSW = OPASSW + LREQA IF (KEEP(60).EQ.0) THEN CALL SMUMPS_ASS_ROOT( root, roota, KEEP(50), & NBROWS_PACKET, NSUBSET_COL_EFF, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NBROWS_PACKET + 1 ), & NSUPCOL_EFF, & A( IPTRLU + 1_8 ), & A( POS_ROOT ), LOCAL_M, LOCAL_N, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & 0) ELSE CALL SMUMPS_ASS_ROOT( root, roota, KEEP(50), & NBROWS_PACKET, NSUBSET_COL_EFF, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NBROWS_PACKET + 1 ), & NSUPCOL_EFF, & A( IPTRLU + 1_8 ), & roota%SCHUR_POINTER(1), & root%SCHUR_LLD , root%SCHUR_NLOC, & roota%RHS_ROOT(1,1), root%RHS_NLOC, & 0) ENDIF IWPOSCB = IWPOSCB + LREQI IPTRLU = IPTRLU + LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) ENDIF RETURN END SUBROUTINE SMUMPS_PROCESS_CONTRIB_TYPE3 MUMPS_5.8.1/src/dfac_process_bf.F0000664000175000017500000000103115042446440016434 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_PROCESS_BF_RETURN() RETURN END SUBROUTINE DMUMPS_PROCESS_BF_RETURN MUMPS_5.8.1/src/cini_defaults.F0000664000175000017500000017006315042446441016160 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C********************************************************************** C SUBROUTINE CMUMPS_SET_TYPE_SIZES( K34, K149, K150, K10 ) IMPLICIT NONE C C Purpose: C ======= C C Set the size in bytes of an "INTEGER" in K34 C Set the size of the default arithmetic (REAL, DOUBLE PRECISION, C COMPLEX or DOUBLE COMPLEX) in K149 C Set the size of floating-point types that are real or double C precision even for complex versions of MUMPS (REAL for S and C C versions, DOUBLE PRECISION for D and Z versions) C Assuming that the size of an INTEGER(8) is 8, store the ratio C nb_bytes(INTEGER(8)) / nb_bytes(INTEGER) = 8 / K34 into K10. C C In practice, we have: C C K149: Arithmetic Value Value for T3E C S 4 8 C D 8 16 C C 8 16 C Z 16 32 C C K150 = K149 for S and D arithmetics C K150 = K149 / 2 for C and Z arithmetics C C K34= 4 and K10 = 2, except on CRAY machines or when compilation C flag -i8 is used, in which case, K34 = 8 and K10 = 1 C INTEGER, INTENT(OUT) :: K34, K149, K10, K150 INTEGER(8) :: SIZE_INT, SIZE_REAL_OR_DOUBLE ! matches MUMPS_INT8 INTEGER I(2) REAL R(2) ! Will be DOUBLE PRECISION if 0 CALL MUMPS_SIZE_C(I(1),I(2),SIZE_INT) CALL MUMPS_SIZE_C(R(1),R(2),SIZE_REAL_OR_DOUBLE) K34 = int(SIZE_INT) K10 = 8 / K34 K150 = int(SIZE_REAL_OR_DOUBLE) K149 = K150 K149 = K149 * 2 RETURN END SUBROUTINE CMUMPS_SET_TYPE_SIZES C C********************************************************************** C SUBROUTINE CMUMPSID( NSLAVES, LWK_USER, CNTL, ICNTL, & KEEP,KEEP8, & INFO, INFOG, RINFO, RINFOG, SYM, PAR, & DKEEP, MYID ) !$ USE OMP_LIB IMPLICIT NONE C C Purpose C ======= C C The elements of the arrays CNTL and ICNTL control the action of C CMUMPS, CMUMPS_ANA_DRIVER, CMUMPS_FAC_DRIVER, CMUMPS_SOLVE_DRIVER C Default values for the elements are set in this routine. C REAL DKEEP(230) REAL CNTL(15), RINFO(40), RINFOG(40) INTEGER ICNTL(60), KEEP(500), SYM, PAR, NSLAVES, MYID INTEGER INFO(80), INFOG(80) INTEGER(8) KEEP8(150) INTEGER LWK_USER C C Parameters C ========== C=========================================== C Arrays for control and information C=========================================== C C N Matrix order C C NELT Number of elements for matrix in ELt format C C C SYM = 0 ... initializes the defaults for unsymmetric code C = 1,2 ... initializes the defaults for symmetric code C C C C PAR = 0 ... instance where host is not working C = 1 ... instance where host is working as a normal node. C (host uses more memory than other processors in C the latter case) C C CNTL and the elements of the array ICNTL control the action of C CMUMPS Default values C are set by CMUMPSID. The elements of the arrays RINFO C and INFO provide information on the action of CMUMPS. C C CNTL(1) threshold for partial pivoting C has default -1.0 (automatic choice): C 0.1 in case of rank-revealing (ICNTL(56)=1,2) C otherwise 0.0 when SYM=1 and 0.01 otherwise. C Values greater than 1.0 are treated as 1.0 for C SYM=1 and as 0.5 for SYM=2 C In general, a larger value of CNTL(1) leads to C greater fill-in but a more accurate factorization. C If CNTL(1) is nonzero, numerical pivoting will be performed. C If CNTL(1) is zero, no pivoting will be performed and C the subroutine will fail if a zero pivot is encountered. C If the matrix A is diagonally dominant, then C setting CNTL(1) to zero will decrease the factorization C time while still providing a stable decomposition. C C CNTL(2) must be set to the tolerance for convergence of iterative C refinement. C Default value is sqrt(macheps). C Values less than zero are treated as sqrt(macheps). C C CNTL(3) is used with null pivot row detection (ICNTL(24) .eq. 1) C and/or with Rank-Revealing (RR) option (ICNTL(56)). C Default value is 0.0. C Let A_{preproc} be the preprocessed matrix to be factored (see C equation in the user's guide). C A pivot is considered to be null if the infinite norm of its C row/column is smaller than a threshold. Let MACHEPS be the C machine precision and ||.|| be the infinite norm. C The absolute value to detect a null pivot row (when ICNTL(24) .EQ.1) C is stored in DKEEP(1). C In case of RR, CNTL(3) will define the thresholds for : C C - Postponing pseudo singularities (SEUIL): C The computed threshold value for postponing pivots C is stored in "SEUIL" and then "SEUIL_LDLT_NIV2" C which are identical in current version. C C - Defining singularities on root (DKEEP(9)) C C - Defining null pivot rows if ICNTL(24).EQ.1 (DKEEP(1)) C in this case DKEEP(1) must be smaller than DKEEP(9) C C IF (ICNTL(56).NE.0) THEN C RR on root is active C IF (CNTL3 .LT. ZERO) THEN C DKEEP(9) = abs(CNTL(3)) C ELSE IF (CNTL3 .GT. ZERO) THEN C DKEEP(9) = CNTL3*||A_{preproc}|| C ELSE ! (CNTL(3) .EQ. ZERO) THEN C DKEEP(9) = sqrt(N_h)*MACHEPS*||A_{preproc}|| C where Nh is the number of pivots on the deepest branch C of the elimination tree. C ENDIF C IF (ICNTL(24).EQ.1) THEN C null pivot detection C DKEEP(1) = DKEEP(9)*DKEEP(10) C ENDIF C C ELSE (ONLY NULL PIVOT detection is active) C IF CNTL(3) > 0 THEN C DKEEP(1) = CNTL(3) ||A_{preproc}|| C ELSE IF CNTL(3) = 0.0 THEN C DKEEP(1) = MACHEPS sqrt(N_h)||A_{preproc}|| C ELSE IF CNTL(3) < 0 THEN C DKEEP(1) = abs(CNTL(3))! this was added for EDF C ! in the context of SOLSTICE project C ENDIF C ENDIF C C CNTL(4) must be set to value for static pivoting. C Default value is -1.0 C Note that static pivoting is enabled only when C Rank-Revealing and null pivot detection C are off (KEEP(19).EQ.0).AND.(KEEP(110).EQ.0). C If negative, static pivoting will be set OFF (KEEP(97)=0) C If positive, static pivoting is ON (KEEP(97=1) with C threshold CNTL(4) C If = 0, static pivoting is ON with threshold MACHEPS^1/2 || A || C C CNTL(5) fixation for null pivots C Default value is 0.0 C Only active if ICNTL(24) = 1 C If > 0 after finding a null pivot, it is set to CNTL(5) x ||A|| C (This value is stored in DKEEP(2)) C If <= 0 then C SYM=2: C the row/column (except the pivot) is set to zero C and the pivot is set to 1 C SYM=0: C the fixation is automatically C set to a large potitive value and the pivot row of the C U factors is set to zero. C Default is 0. C C CNTL(6) not used yet C C CNTL(7) tolerance for Low Rank approximation of the Blocks (BLR). C Dropping parameter expressed with a double precision, C real value, controlling C compression and used to truncate the RRQR algorithm C default value is 0.0. (i.e. no approximation). C The truncated RRQR operation is implemented as C as variant of the LAPACK GEQP3 and LAQPS routines. C 0.0 : full precision approximation. C > 0.0 : the dropping parameter is DKEEP(8). C C Warning: using negative values is an experimental and C non recommended setting. C < 0.0 : the dropping parameter is |DKEEP(8)|*|Apre|, Apre C as defined in user's guide C C C ----------------------------------------- C C ICNTL(1) has default value 6. C It is the output stream for error messages. C If it is set to zero, these C messages will be suppressed. C C ICNTL(2) has default value 0. C It is the output stream for diagnostic printing and C for warning messages that are local to each MPI process. C If it is set to zero, these messages are suppressed. C C ICNTL(3) -- Host only C It is the output stream for diagnostic printing C and for warning messages. Default value is 6. C If it is set to zero, these messages are suppressed. C C ICNTL(4) is used by CMUMPS to control printing of error, C warning, and diagnostic messages. It has default value 2. C Possible values are: C C <1 __No messages output. C 1 __Only error messages printed. C 2 __Errors and warnings printed. C 3 __Errors and warnings and terse diagnostics C (only first ten entries C of arrays printed). C 4 __Errors and warnings and all information C on input and output parameters printed. C C C ICNTL(5) is the format of the input matrix and rhs C 0: assembled matrix, assembled rhs C 1: elemental matrix, assembled rhs C Default value is 0. C C ICNTL(6) has default value 7 for unsymmetric and C general symmetric matrices, and 0 for SPD matrices. C It is only accessed and operational C on a call that includes an analysis phase C (JOB = 1, 4, or 6). C In these cases, if ICNTL(6)=1, 2, 3, 4, 5, 6 or 7, C a column permutation based on algorithms described in C Duff and Koster, 1997, *SIMAX <20>, 4, 889-901, C is applied to the original matrix. Column permutations are C then applied to the original matrix to get a zero-free diagonal. C Except for ICNTL(6)=1, the numerical values of the C original matrix, id%A(NE), need be provided by the user C during the analysis phase. C If ICNTL(6)=7, based on the structural symmetry of the C input matrix the value of ICNTL(6) is automatically chosen. C If the ordering is provided by the user C (ICNTL(7)=1) then the value of ICNTL(6) is ignored. C C ICNTL(7) has default value 7 and must be set by the user to C 1 if the pivot order in IS is to be used. C Effective value of ordering stored in KEEP(256). C Possible values are (depending on the softwares installed) C 0 AMD: Approximate minimum degree (included in CMUMPS package) C 1 Ordering provided by the user C 2 Approximate minimum fill (included in CMUMPS package) C 3 SCOTCH (see http://gforge.inria.fr/projects/scotch/) C should be downloaded/installed separately. C 4 PORD from Juergen Schulze (js@juergenschulze.de) C PORD package is extracted from the SPACE-1.0 package developed at the C University of Paderborn by Juergen Schulze C and is provided as a separate package. C 5 Metis ordering should be downloaded/installed separately. C 6 Approximate minimum degree with automatic quasi C dense row detection (included in CMUMPS package). C (to be used when ordering time with AMD is abnormally large) C 7 Automatic choice done during analysis phase C For any other C value of ICNTL(7), a suitable pivot order will be C chosen automatically. C C ICNTL(8) is used to describe the scaling strategy. C Default value is 77. C Note that scaling is performed only when the numerical C factorization step is performed (JOB = 2, 4>, 5>, or 6>). C If ICNTL(8) is not equal to C any of the values listed below then ICNTL(8) is treated C as if it had its default value of 0 (no scaling). C If the matrix is known to be very badly scaled, C our experience has been that option 6 is the most robust but C the best scaling is very problem dependent. C If ICNTL(8)=0, COLSCA and ROWSCA are dummy arguments C of the subroutine that are not accessed. C Possible values of ICNTL(8) are: C C -2 scaling computed during analysis (and applied during the C factorization) C C -1 the user must provide the scaling in arrays C COLSCA and ROWSCA C C 0 no scaling C C 1 Diagonal scaling C C 2 not defined C C 3 Column scaling C C 4 Row and column scaling C C 5,6 not defined C 7, 8 Scaling based on Daniel Ruiz and Bora Ucar's work done C during the ANR-SOLSTICE project. C Reference for this work are: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C This scaling can work on both centralized and distributed C assembled input matrix format. (it works for both symmetric C and unsymmetric matrices) C Option 8 is similar to 7 but more rigourous and expensive to compute. C 77 Automatic choice of scaling value done. Proposed algo: C if (sym=1) then C option = 0 C else C if distributed matrix entry then C option = 7 C else C if (maximum transversal is called C and makes use of numerical values) then C option=-2 and ordering is computed during analysis C else C option = 7 C endif C endif C endif C C ICNTL(9) has default value 1. If ICNTL(9)=1 C the system of equations A * x = b is solved. For other C values the system A^T * x = b is solved. C When ICNTL(30) (compute selected entries in A-1) is activated C ICNTL(9) is ignored. C C ICNTL(10) has default value 0. C If ICNTL(10)=0 : iterative refinement is not performed. C Values of ICNTL(10) < 0 : a fix number of steps equal C to ICNTL(10) of IR is done. C Values of ICNTL(10) > 0 : mean a maximum of ICNTL(10) number C of steps of IR is done, and a test of C convergence is used C C ICNTL(11) has default value 0. C A value equal to 1 will return a backward error estimate in C RINFO(4-11). C A value equal to 2 will return a backward error estimate in C RINFO(4-8). No LCOND 1, 2 and forward error are computed. C If ICNTL(11) is negative, zero or greater than 2 no estimate C is returned. C C C ICNTL(12) has default value 0 and defines the strategy for C LDLT orderings C 0 : automatic choice C 1 : usual ordering (nothing done) C 2 : ordering on the compressed graph, available with all orderings C except with AMD C 3 : constraint ordering, only available with AMF, C -> reset to 2 with other orderings C Other values are treated as 1 (nothing done). C On output KEEP(95) holds the internal value used and INFOG(24) gives C access to KEEP(95) to the user. C in LU facto it is always reset to 1 C C - ICNTL(12) = 3 has a lower priority than ICNTL(7) C thus if ICNTL(12) = 3 and the ordering required is not AMF C then ICNTL(12) is set to 2 C C - ICNTL(12) = 2 has a higher priority than ICNTL(7) C thus if ICNTL(12) = 2 and the ordering required is AMD C then the ordering used is QAMD C C - ICNTL(12) has a higher priority than ICNTL(6) and ICNTL(8) C thus if ICNTL(12) = 2 then ICNTL(6) is automatically C considered as if it was set to a value between 1-6 C if ICNTL(12) = 3 then ICNTL(6) is considered as if C set to 5 and ICNTL(8) as if set to -2 (we need the scaling C factors to define free and constrained variables) C C ICNTL(13) has default value 0 and allows for selecting Type 3 node. C IF ICNTL(13).GT. 0 scalapack is forbidden. Otherwise, C scalapack will be activated if the root is large enough. C Furthermore C IF ((ICNTL(13).GT.0) .AND. (NSLAVES.GT.ICNTL(13), C or ICNTL(13)=-1 THEN C extra splitting of the root will be activated C and is controlled by abs(KEEP(82)). C The order of the root node is divided by KEEP(82) C ENDIF C If ICNTL(13) .EQ. -1 then splitting of the root C is done whatever the nb of procs is. C Authorizing extra root spliting during analysis might be C interesting to further split the root node (combined for C example with null pivot detection option ICNTL(24)=1 OR ICNTL(56)) C C To summarize: C -1 : root splitting and scalapack on C 0 or < -1 : root splitting off and sclalapack on C > 0 : scalapack off C C ICNTL(14) has default value 20 (5 if NSLAVES=1 and SYM=1) C and is the value for memory relaxation C so called "PERLU" in the following. C C C ICNTL(15) : Describes the compression of the graph of the input matrix C The analysis step is then performed on the compressed C graph C Must be set during analysis on the master C 0 : OFF C 1 : Compression provided by the user: C BLKPTR(1:id%NBLK+1) and C BLKVAR(1:N or N_LOC if distributed format) C (BLKVAR(BLKPTR(iblk):BLKPTR(iblk+1)-1): C dof list for iblk) C - If BLKVAR is not provided then BLKVAR is C treated as the identity C (contiguous variables in blocks) C - Distributed format if on MASTER N_LOC#N C C ICNTL(16) : number of OpenMP threads asked by the user. C C ICNTL(17) not used in this version C C ICNTL(18) has default value 0 and is only accessed by the host during C the analysis phase if the matrix is assembled (ICNTL(5))= 0). C ICNTL(18) defines the strategy for the distributed input matrix. C Possible values are: C 0: input matrix is centralized on the host. This is the default C 1: user provides the structure of the matrix on the host at analysis, C CMUMPS returns C a mapping and user should provide the matrix distributed according C to the mapping C 2: user provides the structure of the matrix on the host at analysis, C and the C distributed matrix on all slave processors at factorization. C Any distribution is allowed C 3: user directly provides the distributed matrix input both C for analysis and factorization C C For flexibility and performance issues, option 3 is recommended. C C ICNTL(19) has default value 0 and is only accessed by the host C during the analysis phase. If ICNTL(19) \neq 0 then Schur matrix will C be returned to the user. C The user must set on entry on the host node (before analysis): C the integer variable SIZE\_SCHUR to the size fo the Schur matrix, C the integer array pointer LISTVAR\_SCHUR to the list of indices C of the schur matrix. C if = 0 : Schur is off and the root node gets factorized C if = 1 : Schur is on and the Schur complement is returned entirely C on a memory area provided by the user ONLY on the host node C if = 2 or 3 : Schur is on and the Schur complement is returned in a C distributed fashion according to a 2D block-cyclic C distribution. In the case where the matrix is symmetric C the lower part is returned if =2 or the complete C matrix if =3. C C ICNTL(20) has default value 0 and is only accessed by the host C during the solve phase. If ICNTL(20)=0, the right-hand side must given C in dense form in the structure component RHS. C If ICNTL(20)=1,2,3, then the right-hand side must be given in sparse form C using the structure components IRHS\_SPARSE, RHS\_SPARSE, IRHS\_PTR and C NZ\_RHS. C When the right-hand side is provided in sparse form then duplicate entries C are summed. C C 0 : dense RHS C 1,2,3 : Sparse RHS C 1 The decision of exploiting sparsity of the right-hand side to C accelerate the solution phase is done automatically. C 2 Sparsity of the right-hand sides is NOT exploited C to improve solution phase. C 3 Sparsity of the right-hand sides is exploited C to improve solution phase. C Values different from 0,1, 2,3 are treated as 0. C For sparse RHS recommended value is 1. C C ICNTL(21) has default value 0 and is only accessed by the host C during the solve phase. If ICNTL(21)=0, the solution vector will be assembled C and stored in the structure component RHS, that must have been allocated by C the user. If ICNTL(21)=1, the solution vector is kept distributed at the C end of the solve phase, and will be available on each slave processor C in the structure components ISOL_loc and SOL_loc. ISOL_loc and SOL_loc C must then have been allocated by the user and must be of size at least C INFO(23), where INFO(23) has been returned by CMUMPS at the end of the C factorization phase. C Values of ICNTL(21) different from 0 and 1 are currently treated as 0. C C ICNTL(22) (saved in KEEP(201) controls the OOC setting (0=incore, 1 =OOC) C It has default value 0 (incore).Out-of-range values are treated as 0. C If set before analysis then special setting and massage of the tree C might be done (so far only extra splitting CUTNODES) is performed. C It is then accessed by the host C during the factorization phase. If ICNTL(22)=0, then no attempt C to use the disks is made. If ICNTL(22)=1, then CMUMPS will store C the computed factors on disk for later use during the solution C phase. C C ICNTL(23) has default value 0 and is accessed by ALL processors C at the beginning of the factorization phase. If positive C it corresponds to the maximum size of the working memory C in MegaBytes that MUMPS can allocate per working processor. C If only the host C value is non zero, then other processors also use the value on C the host. Otherwise, each processor uses the local value C provided. C C ICNTL(24) default value is 0 C if = 0 no null pivot detection (CNTL(5) and CNTL(3) are inactive), C = 1 null pivot row detection; CNTL(3) and CNTL(5) are C then used to describe the action taken. C C C ICNTL(25) has default value 0 and is only accessed by the C host during the solution stage. It is only significant if C a null space basis was requested during the factorization C phase (INFOG(28) .GT. 0); otherwise a normal solution step C is performed. C If ICNTL(25)=0, then a normal solution step is performed, C on the internal problem (excluding the null space). C No special property on the solution (discussion with Serge) C If ICNTL(25)=i, 1 <= i <= INFOG(28), then the i-th vector C of the null space basis is computed. In that case, note C that NRHS should be set to 1. C If ICNTL(25)=-1, then all null space is computed. The C user should set NRHS=INFOG(28) in that case. C Note that centralized or distributed solutions are C applicable in that case, but that iterative refinement, C error analysis, etc... are excluded. Note also that the C option to solve the transpose system (ICNTL(9)) is ignored. C C C ICNTL(26) has default value 0 and is accessed on the host only C at the beginning of the solution step. C It is only effective if the Schur option is ON. C (copy in KEEP(221)) C C C During the solution step, a value of 0 will perform a normal C solution step on the reduced problem not involving the Schur C variables. C During the solution step, if ICNTL(26)=1 or 2, then REDRHS C should be allocated of size at least LREDRHS*(NRHS-1)+ C SIZE_SCHUR, where LREDRHS is the leading dimension of C LREDRHS (LREDRHS >= SIZE_SCHUR). C C If ICNTL(26)=1, then only a forward substitution is performed, C and a reduced RHS will be computed and made available in C REDRHS(i+(k-1)*LREDRHS), i=1, ..., SIZE_SCHUR, k=1, ..., NRHS. C If ICNTL(26)=2, then REDRHS(i+(k-1)*LREDRHS),i=1, SIZE_SCHUR, C k=1,NRHS is considered to be the solution corresponding to the C Schur variables. It is injected in CMUMPS, that computes the C solution on the "internal" problem during the backward C substitution. C C ICNTL(27) controls the blocking factor for multiple right-hand-sides C during the solution phase. C It influences both the memory used (see INFOG(30-31)) and C the solution time C (Larger values of ICNTL(27) leads to larger memory requirements). C Its tuning can be critical when C the factors are written on disk (out-of core, ICNTL(22)=1). C A negative value indicates that automatic setting is C performed by the solver. C C C ICNTL(28) decides whether parallel or sequential analysis should be used. Three C values are possible at the moment: C 0: automatic. This defaults to sequential analysis C 1: sequential. In this case the ordering strategy is defined by ICNTL(7) C 2: parallel. In this case the ordering strategy is defined by ICNTL(29) C C ICNTL(29) defines the ordering too to be used during the parallel analysis. Three C values are possible at the moment: C 0: automatic. This defaults to PT-SCOTCH C 1: PT-SCOTCH. C 2: ParMetis. C C C ICNTL(30) controls the activation of functionality A-1. C It has default value 0 and is only accessed by the master C during the solution phase. It enables the solver to C compute entries in the inverse of the original matrix. C Possible values are: C 0 normal solution C other values: compute entries in A-1 C When ICNTL(30).NE.0 then the user C must describe on entry to the solution phase, C in the sparse right-hand-side C (NZ_RHS, NRHS, RHS_SPARSE, IRHS_SPARSE, IRHS_PTR) C the target entries of A-1 that need be computed. C Note that RHS_SPARSE must be allocated but need not be C initialized. C On output RHS_SPARSE then holds the requested C computed values of A-1. C Note that when ICNTL(30).NE.0 then C - sparse right hand side interface is implicitly used C functionality (ICNTL(20)= 1) but RHS need not be C allocated since computed A-1 entries will be stored C in place. C - ICNTL(9) option (solve Ax=b or Atx=b) is ignored C In case of duplicate entries in the sparse rhs then C on output duplicate entries in the solution are provided C in the same place. C This need not be mentioned in the spec since it is a C "natural" extension. C C ----------- C Fwd in facto C ----------- C ICNTL(31) Must be set before analysis to control storage C of LU factors. Default value is 0. Out of range C values considered as 0. C (copied in KEEP(251) and broadcast, C when setting of ICNTL(31) C results in not factors to be stored then C KEEP(201) = -1, OOC is "suppressed") C 0 Keep factors needed for solution phase C (when option forward during facto is used then C on unsymmetric matrices L factors are not stored) C 1 Solve not needed (solve phase will never be called). C When the user is only interested in the inertia or the C determinant then C all factor matrices need not be stored. C This can also be useful for testing : C to experiment facto OOC without C effective storage of factors on disk. C 2 L factors not stored: meaningful when both C - matrix is unsymmetric and fwd performed during facto C - the user is only interested in the null-space basis C and thus only need the U factors to be stored. C Currently, L factors are always stored in IC. C C ----------- C Fwd in facto C ----------- C ICNTL(32) Must be set before analysis to indicate whether C forward is performed during factorization. C Default value is 0 (normal factorization without fwd) C (copied in KEEP(252) and broadcast) C 0 Normal factorization (default value) C 1 Forward performed during factorization C C C ICNTL(33) Must be set before the factorization phase to compute C the determinant. See also KEEP(258), KEEP(259), C DKEEP(6), DKEEP(7), INFOG(34), RINFOG(12) C C If ICNTL(33)=0 the determinant is not computed C For all other values, the determinant is computed. Note that C null pivots and static pivots are excluded from the C computation of the determinant. C #if ! defined(NO_SAVE_RESTORE) C ICNTL(34) Must be set before a call to MUMPS with JOB=-3 in case C the save/restore feature was used and user wants to clean C save/restore files (and possibly OOC files). C ICTNL(34)=0 => user wants to be able to restore instance later C ICTNL(34)=1 => user will not restore the instance again (clean C to be done) #endif C C ICNTL(35) : Block Low-Rank (BLR) functionality, C need be set before analysis C Default value is 0 C 0: FR factorization and FR solve C 1: Automatic BLR option setting (=> 2) C 2: BLR factorization + BLR Solve C => keep BLR factors only C 3: BLR factorization + FR Solve C Other values are treated as zero C Note that this functionality is currently incompatible C with elemental matrices (ICNTL(5) = 1) and with C forward elimination during factorization (ICNTL(32) = 1) C C ICNTL(36) : Block Low-Rank variant choice C Default value is 0 C 0: UFSC variant, no recompression: Compress step is C performed after the Solve; the low-rank updates are not C recompressed C 1: UFCS variant, no recompression: Factor (with pivoting) on full-rank blocks, C then Compress and finally Solve on low-rank blocks (those where pivoting is not needed, C which depends on the context) C C ICNTL(37) : Compress CB strategy need be set before factorization C 0 = DONT compress CB (default) C 1 = SYSTEMATIC compress CB: compress CB for all candidate fronts C C ICNTL(38): Compression rate of LU factors, can be set before C analysis/factorization C Between 0 and 1000; other values ares treated as 0; C ICNTL(38)/10 is a percentage representing the typical C compressed factors compression of the factor matrices C in BLR fronts: C ICNTL(38)/10= compressed/uncompressed factors × 100. C Default value: 600 C (when factors of BLR fronts are compressed, C their size is 60% of their full- rank size). C ICNTL(39) : Compression rate of Contribution Blocks (CBs) C can be set before analysis/factorization C Between 0 and 1000; other values ares treated as 0; C corresponds to an estimated compression rate of C ICNTL(39)/1000%. C Default value: 500 (50.0% compression rate). C ICNTL(48) : Controls L0_OMP feature. It must be set on the host C before the analysis phase to prepare datastructures C for factorization. C If ICNTL(48) was nonzero during analysis, C L0-OMP will be activated during factorization. C OMP_NUM_THREADS should not change between analysis C and factorization, as long as L0 task scheduling during C factorization is static. C ICNTL(48) can however change between factorization C and solve phases. If activated during analysis, the C number of threads for L0OMP (for both analysis and C factorization) is saved in KEEP(400) (see above). C For LO_OMP feature to be effective during solve C both KEEP(400)>0 and ICNTL(48)>0 are needed C Possible values at analysis: C 0 : off -- L0-OMP is not activated for analysis C and factorization C >0 : on -- L0-OMP is activated for analysis C and factorization C out-of-range values (<0) : off C Possible values at solve: C 0 : off --L0-OMP is not activated for solve. C Possible even if L0-OMP was activated during C analysis/factorization C >0 : on --L0-OMP activated for solve. C Possible only if L0-OMP was activated during C analysis/factorization C if (defined(_OPENMP)) then C default value is 1 (L0-thread ON) C else C default value is 0 (L0thread OFF) C endif C out of range values are treated as 0 C C C ICNTL(49): compact workarray id%S before solution phase C must be set before factorization C 0 : nothing is done. C 1 : compact workarray id%S(MAXS) at the end of the C factorization phase while satisfying the C memory contraint that might have been provided C with ICNTL(23) feature. C 2 : compact workarray id%S(MAXS) at the end of the C factorization phase. The memory C constraint that might have been provided with C ICNTL(23) feature does not apply to this process C Other values are treated as 0. C Default value: 0 C C C ICNTL(56) has default value 0 and is only accessed by the host. C During the analysis phase, a positive value prepares the data for C later use of null space functionalities (saved in KEEP(53)). C (the tree is modified to have only one root in analysis) C If ICNTL(56) is negative or zero, null space feature will C be forbidden during the factorization phase. C During the factorization phase, if ICNTL(56) was positive C (KEEP(53)>0) for analysis, then the values of ICNTL(56) (saved C in KEEP(19)) have the following meaning. C 0: No null space analysis, C 1: Null space analysis on last root node using SVD, C 2: Null space analysis on last root node using QR, C C The singular values (ICNTL(56)=1) or the diagonal entries of R C (ICNTL(56)=2) are available in root%SINGULAR_VALUES C C C C ICNTL(58): strategy for symbolic factorization used C with centralized ordering based on METIS (ICNTL(7)=5) C or with given given ordering (ICNTL(7)=1) C C Default value 2 C 1 => SYMBQAMD based symbolic factorization C 2 => Column count based symbolic factorization C Symbolic factorization based on C [GIMP94] "An efficient algorithm to compute row and column C counts for sparse cholesky factorization" C John R. Gilbert, Esmond G. Ng, and Barry W. Peyton C SIMAX 1994 C implementation of the algorithm described in figure 3 C of the [GINP94] article C C Other values are treated as 1 C C========================= C ARRAYS FOR INFORMATION C======================== C C----- C INFO is an INTEGER array of length 80 that need not be C set by the user. C----- C C INFO(1) is zero if the routine is successful, is negative if an C error occurred, and is positive for a warning (see CMUMPS for C a partial documentation and the userguide for a full documentation C of INFO(1)). C C INFO(2) holds additional information concerning the C error (see CMUMPS). C C ------------------------------------------ C Statistics produced after analysis phase C ------------------------------------------ C C INFO(3) Estimated real space needed for factors. C C INFO(4) Estimated integer space needed for factors. C C INFO(5) Estimated maximum frontal size. C C INFO(6) Number of nodes in the tree. C C INFO(7) Minimum value of integer working array IS (old MAXIS) C estimated by the analysis phase C to run the numerical factorization. C C INFO(8) Minimum value of real/complex array S (old MAXS) C estimated by the analysis phase C to run the numerical factorization. C C INFO(15) Estimated size in MBytes of all CMUMPS internal data C structures to run factorization C C INFO(17) provides an estimation (minimum in Megabytes) C of the total memory required to run C the numerical phases out-of-core. C This memory estimation corresponds to C the least memory consuming out-of-core strategy and it can be C used as a lower bound if the user wishes to provide ICNTL(23). C --------------------------------------- C Statistics produced after factorization C --------------------------------------- C INFO(9) Size of the real space used to store the LU factors possibly C including BLR compressed factors C C INFO(10) Size of the integer space used to store the LU factors C C INFO(11) Order of largest frontal matrix. C C INFO(12) Number of off-diagonal pivots in unsymmetric case / C number of negative pivots in symmetric case C C INFO(13) Number of uneliminated variables sent to the father. C C INFO(14) Number of memory compresses. C C INFO(18) On exit to factorization: C Local number of null pivots (ICNTL(24)=1) C on the local processor even on master. C (local size of array PIVNUL_LIST). C Note that it also includes null pivots C that might have been further detected on C the root if ICNTL(56).NE.0. and root C processed by MYID C C INFO(19) - after analysis: C Estimated size of the main internal integer workarray IS C (old MAXIS) to run the numerical factorization out-of-core. C C INFO(21) - after factorization: Effective space used in the main C real/complex workarray S -- or in the workarray WK_USER, C in the case where WK_USER is provided. C C INFO(22) - after factorization: C Size in millions of bytes of memory effectively used during C factorization. C This includes the memory effectively used in the workarray C WK_USER, in the case where WK_user is provided. C C INFO(23) - after factorization: total number of pivots eliminated C on the processor. In the case of a distributed solution (see C ICNTL(21)), this should be used by the user to allocate solution C vectors ISOL_loc and SOL_loc of appropriate dimensions C (ISOL_LOC of size INFO(23), SOL_LOC of size LSOL_LOC * NRHS C where LSOL_LOC >= INFO(23)) on that processor, between the C factorization and solve steps. C C INFO(24) - after analysis: estimated number of entries in factors on C the processor. If negative, then C the absolute value corresponds to {\it millions} of entries C in the factors. C Note that in the unsymmetric case, INFO(24)=INFO(3). C In the symmetric case, however, INFO(24) < INFO(3). C INFO(25) - after factorization: number of tiny pivots (number of C pivots modified by static pivoting) detected on the processor. C INFO(26) - after solution: C effective size in Megabytes of all working space C to run the solution phase. C (The maximum and sum over all processors are returned C respectively in INFOG(30) and INFOG(31)). C INFO(27) - after factorization: effective number of entries in factors C on the processor. If negative, then C the absolute value corresponds to {\it millions} of entries C in the factors. C Note that in the unsymmetric case, INFO(27)=INFO(9). C In the symmetric case, however, INFO(27) < INFO(9). C The total number of entries over all processors is C available in INFOG(29). C C C ------------------------------------------------------------- C ------------------------------------------------------------- C RINFO is a REAL/DOUBLE PRECISION array of length 40 that C need not be set by the user. This array supplies C local information on the execution of CMUMPS. C C C RINFOG is a REAL/DOUBLE PRECISION array of length 40 that C need not be set by the user. This array supplies C global information on the execution of CMUMPS. C RINFOG is only significant on processor 0 C C C RINFO(1) hold the estimated number of floating-point operations C for the elimination process on the local processor C C RINFOG(1) hold the estimated number of floating-point operations C for the elimination process on all processors C C RINFO(2) Number of floating-point operations C for the assembly process on local processor. C C RINFOG(2) Number of floating-point operations C for the assembly process. C C RINFO(3) Number of floating-point operations C for the elimination process on the local processor. C C RINFOG(3) Number of floating-point operations C for the elimination process on all processors. C C---------------------------------------------------- C Statistics produced after solve with error analysis C---------------------------------------------------- C C RINFOG(4) Infinite norm of the input matrix. C C RINFOG(5) Infinite norm of the computed solution, where C C RINFOG(6) Norm of scaled residuals C C RINFOG(7), `RINFOG(8) and `RINFOG(9) are used to hold information C on the backward error. C We calculate an estimate of the sparse backward error using the C theory and measure developed C by Arioli, Demmel, and Duff (1989). The scaled residual w1 C is calculated for all equations except those C for which numerator is nonzero and the denominator is small. C For the exceptional equations, w2, is used instead. C The largest scaled residual (w1) is returned in C RINFOG(7) and the largest scaled C residual (w2) is returned in `RINFOG(8)>. If all equations are C non exceptional then zero is returned in `RINFOG(8). C The upper bound error is returned in `RINFOG(9). C C RINFOG(14) Number of floating-point operations C for the elimination process (on all fronts, BLR or not) C performed when BLR option is activated on all processors. C (equal to zero if BLR option not used, ICNTL(35).EQ.1) C C RINFOG(15) - after analysis: if the user decides to perform an C out-of-core factorization (ICNTL(22)=1), then a rough C estimation of the total size of the disk space in MegaBytes of C the files written by all processors is provided in RINFOG(15). C C RINFOG(16) - after factorization: in the case of an out-of-core C execution (ICNTL(22)=1), the total C size in MegaBytes of the disk space used by the files written C by all processors is provided. C C RINFOG(17) - after each job: sum over all processors of the sizes C (in MegaBytes) of the files used to save the instance C C RINFOG(18) - after each job: sum over all processors of the sizes C (in MegaBytes) of the MUMPS structures. C C RINFOG(19) - after factorization: smallest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre and considering also C small pivots selected as null-pivots (see ICNTL(24)) C and pivots on which static pivoting was applied C C RINFOG(20) - after factorization: smallest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre and NOT considering C small pivots selected as null-pivots (see ICNTL(24)) C and pivots on which static pivoting was applied C C RINFOG(21) - after factorization: largest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre. C C RINFOG(22) - after factorization: C total number of floating-point operations offloaded to C the accelerator(s) by all MPI processes (see RINFO(9)) C C RINFOG(23) - after factorization: average (over all MPI processes) C time spent in operations offloaded to the accelerators C including communication (see RINFO(10)). C C Computed when solve involves exploit sparsity (fwd and/or bwd) C here we only report off diagonal flops) C #if defined(STAT_ES_SOLVE) C RINFOG(24) - FR FLOPS (off diagonal flops) C RINFOG(25) - FR FLOPS (off diag) with Exploit sparsity C (possibly with nb_sparse algo used) #endif C C C=========================== C DESCRIPTION OF KEEP8 ARRAY C=========================== C C KEEP8 is a 64-bit integer array of length 150 that need not C be set by the user C #if ! defined(NO_SAVE_RESTORE) #endif C=========================== C DESCRIPTION OF KEEP ARRAY C=========================== C C KEEP is an INTEGER array of length 500 that need not C be set by the user. C C C============================= C Description of DKEEP array C============================= C C DKEEP internal control array for REAL parameters C of size 30 C=================================== C Default values for control arrays C================================== C uninitialized values should be 0 LWK_USER = 0 KEEP(1:500) = 0 KEEP8(1:150)= 0_8 INFO(1:80) = 0 INFOG(1:80) = 0 ICNTL(1:60) = 0 RINFO(1:40) = 0.0E0 RINFOG(1:40)= 0.0E0 CNTL(1:15) = 0.0E0 DKEEP(1:230) = 0.0E0 C ---------------- C Symmetric code ? C ---------------- KEEP( 50 ) = SYM C Check value of SYM IF (SYM.EQ.1) THEN C C this option is not available with the complex C code on symmetric matrices. C We set KEEP(50) to 2 and will exploit symmetry C up to the root. KEEP(50) = 2 ENDIF C ------------------------------------- C Only options 0, 1, or 2 are available C ------------------------------------- IF ( KEEP(50).NE.1 .and. KEEP(50).NE.2 ) KEEP( 50 ) = 0 C threshold value for pivoting C Automatic choice depending on (SYM and ICNTL(56)) CNTL(1) = -1.0E0 CNTL(2) = sqrt(epsilon(0.0E0)) CNTL(3) = 0.0E0 CNTL(4) = -1.0E0 CNTL(5) = 0.0E0 C Working host ? KEEP(46) = PAR IF ( KEEP(46) .NE. 0 .AND. & KEEP(46) .NE. 1 ) THEN C ---------------------- C If out-of-range value, C use a working host C ---------------------- KEEP(46) = 1 END IF C control printing ICNTL(1) = 6 ICNTL(2) = 0 ICNTL(3) = 6 ICNTL(4) = 2 C format of input matrix ICNTL(5) = 0 C maximum transversal (0=NO, 7=automatic) IF (SYM.NE.1) THEN ICNTL(6) = 7 ELSE ICNTL(6) = 0 ENDIF C Ordering option (icntl(7)) C Default is automatic choice done during analysis ICNTL(7) = 7 C ask for scaling (0=NO, 4=Row and Column) C Default value is 77: automatic choice for analysis ICNTL(8) = 77 C solve Ax=b (1) or Atx=b (other values) ICNTL(9) = 1 C Naximum number of IR (0=NO) ICNTL(10) = 0 C Error analysis (0=NO) ICNTL(11) = 0 C Control ordering strategy C automatic choice IF(SYM .EQ. 2) THEN ICNTL(12) = 0 ELSE ICNTL(12) = 1 ENDIF C Control of the use of ScaLAPACK for root node C If null space options asked, ScaLAPACK is always ignored C and ICNTL(13) is not significant C ICNTL(13) = 0 : Root parallelism on (if size large enough) C ICNTL(13) = 1 : Root parallelism off #if defined(NOSCALAPACK) ICNTL(13) = 1 #else ICNTL(13) = 0 #endif C Default value for the memory relaxation IF (SYM.eq.1.AND.NSLAVES.EQ.1) THEN ICNTL(14) = 5 ! it should work with 0 ELSE ICNTL(14) = 20 END IF IF (NSLAVES.GT.4) ICNTL(14) = ICNTL(14) + 5 IF (NSLAVES.GT.8) ICNTL(14) = ICNTL(14) + 5 IF (NSLAVES.GT.16) ICNTL(14)= ICNTL(14) + 5 C Distributed matrix entry ICNTL(18) = 0 C Schur (default is not active) ICNTL(19) = 0 C dense RHS by default ICNTL(20) = 0 C solution vector centralized on host ICNTL(21) = 0 C out-of-core flag ICNTL(22) = 0 C MEM_ALLOWED (0: not provided) ICNTL(23) = 0 C null pivots ICNTL(24) = 0 C blocking factor for multiple RHS during solution phase ICNTL(27) = -32 C analysis strategy: 0=auto, 1=sequential, 2=parallel ICNTL(28) = 1 C tool used for parallel ordering computation : C 0 = auto, 1 = PT-SCOTCH, 2 = ParMETIS ICNTL(29) = 0 C Default BLR compression rate of factors (60%) ICNTL(38) = 600 C Default BLR compression rate of factors (50%) ICNTL(39) = 500 C L0-thread feature #if defined(_OPENMP) C Activate L0OMP ICNTL(48) = 1 #else C Do not activate L0OMP ICNTL(48) = 0 #endif ICNTL(55) = 0 ICNTL(56) = 0 ICNTL(57) = 0 ICNTL(58) = 2 C=================================== C Default values for some components C of KEEP array C=================================== KEEP(12) = 0 KEEP(24) = 18 KEEP(68) = 0 KEEP(30) = 2000 KEEP(36) = 1 KEEP(1) = 5 KEEP(7) = 150 KEEP(8) = 120 KEEP(57) = 2000 KEEP(58) = 1000 IF ( SYM .eq. 0 ) THEN KEEP(4) = 32 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 32 KEEP(9) = 700 KEEP(85) = 300 KEEP(62) = 10 ELSE KEEP(4) = 24 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 32 KEEP(9) = 400 KEEP(85) = 100 KEEP(62) = 10 END IF KEEP(11)=200 KEEP(63) = 60 KEEP(48) = 5 CALL CMUMPS_SET_TYPE_SIZES( KEEP(34), KEEP(149), & KEEP(150), KEEP(10) ) KEEP(35)=KEEP(149) KEEP(16)=KEEP(150) KEEP(151)=KEEP(35) KEEP(51) = 70 KEEP(37) = max(800, int(sqrt(real(NSLAVES+1))*real(KEEP(51)))) IF ( NSLAVES > 256 ) THEN KEEP(39) = 10000 ELSEIF ( NSLAVES > 128 ) THEN KEEP(39) = 20000 ELSEIF ( NSLAVES > 64 ) THEN KEEP(39) = 40000 ELSEIF ( NSLAVES > 16 ) THEN KEEP(39) = 80000 ELSE KEEP(39) = 160000 END IF KEEP(40) = -1 - 456789 KEEP(45) = 0 KEEP(47) = 2 KEEP(64) = 20 KEEP(69) = 4 C To disable SMP management when using new mapping strategy C KEEP(69) = 1 C Forcing proportional is ok with strategy 5 KEEP(75) = 1 KEEP(76) = 2 KEEP(77) = 0 KEEP(78)= 0 KEEP(79) = 0 ! old splitting KEEP(210) = 2 KEEP8(79) = -10_8 KEEP(80) = 1 KEEP(81) = 0 IF (SYM.EQ.0) THEN KEEP(82)= 15 ELSE KEEP(82) = 10 ENDIF KEEP(83) = -1 KEEP(86)=1 KEEP(87)=0 KEEP(88)=0 KEEP(90)=1 KEEP(91)= -1 KEEP(102)= -1 #if defined(OLD_OOC_NOPANEL) KEEP(99)=0 ! no panel -> synchronous / no buffer #else KEEP(99)=4 ! new OOC -> asynchronous + buffer #endif KEEP(100)=0 KEEP(114) = 1 C Threshold value for null pîvot detection during C LU factorization on root in case of RR KEEP(118)=41 C strategy for MUMPS_BLOC2_GET_NSLAVESMIN KEEP(119)=0 C Scaling is enabled by default with the Schur complement option KEEP(125)=1 C Columns of LMAT handled by block of size KEEP(147) KEEP(147)=20000 C Control buffer size estimation and minimum granularities: C Try to avoid messages smaller than KEEP(170)/1000 of recv buf C ... minimum number of blocks KEEP(171)=10 C ... buffer size reduction factor with respect to worst case IF (SYM.EQ.0) THEN KEEP(172)= 5 ELSE KEEP(172)= 3 ENDIF KEEP(173)= 0 ! 0 = normal IF (SYM.EQ.0) THEN KEEP(178)= 2 ELSE KEEP(178)= 3 ENDIF KEEP(179)= 10 ! default outer block size increase by factor K179 IF (SYM.EQ.0) THEN KEEP(180) = 80 ! % of KEEP(44) to bound MIN_BUF_SIZE_FR KEEP(181) = 50 ! % of KEEP(44) to bound MIN_BUF_SIZE_BLR ELSE KEEP(180) = 200 ! % of KEEP(44) to bound MIN_BUF_SIZE_FR KEEP(181) = 200 ! % of KEEP(44) to bound MIN_BUF_SIZE_BLR ENDIF C amalgamation: to define sons KEEP(191) larger than fathers KEEP(191)= 50 C amalgamation: to define tiny son nodes C (KEEP(192 smaller than father) KEEP(192)= 900 C to limit the amalgamation of tiny nodes KEEP(193)= 50 C More amalgamation of tiny fronts KEEP(197)=1 C KEEP(199) for MUMPS_PROCNODE, MUMPS_TYPENODE, etc C KEEP(199)=NSLAVES + 7 KEEP(199)=-1 KEEP(200)=0 ! root pre-assembled in id%S C Pre-assemble type 3 root in id%S if no L0-OMP, C allocate id%S later otherwise. KEEP(200) = -1 KEEP(204)=0 KEEP(205)=0 KEEP(209)=-1 KEEP(104) = 16 KEEP(107)=0 KEEP(121)=-999999 KEEP(122)=15 C Size of CB for which we want to force BLR compressCB C even if NASS is small. KEEP(123)=10000 KEEP(141)=1 ! min needed KEEP(206)=1 KEEP(207) = 1 KEEP(211)=2 IF (SYM.EQ.0) THEN KEEP(213) = 301 ELSE KEEP(213) = 401 ENDIF KEEP(217)=0 KEEP(215)=0 KEEP(216)=1 KEEP(218)=250 IF (SYM.EQ.2) THEN KEEP(219)=1 ELSE KEEP(219)=0 ENDIF IF (KEEP(50).EQ.2) THEN KEEP(227)= max(2,32) ELSE KEEP(227)= max(1,32) ENDIF KEEP(231) = 1 KEEP(232) = 3 KEEP(233) = 0 KEEP(239) = 1 KEEP(240) = 10 DKEEP(4) = -1.0E0 DKEEP(5) = -1.0E0 DKEEP(10) = -9E0 ! default value is 10E-1 set in fac_driver.F DKEEP(13) = -9E0 ! to define SEUIL for postponing with RR ! (default value is 10 set in fac_driver.F) DKEEP(24) = 1000.0E0 ! gap should be larger than dkeep(14) DKEEP(25) = 10.0E0 ! gap precision DKEEP(22) = 0.5E0 ! to check for slow convergence KEEP(238)=24 KEEP(234)= 1 KEEP(235)=-1 DKEEP(3) =-5.0E0 DKEEP(18)= 1.0E12 KEEP(242) = -9 KEEP(243) = -1 KEEP(255)=100 C Multithreading of norm1 loop during scaling KEEP(281)=8 KEEP(337) = 1 C Parallel analysis compatible with analysis by blocks C and detection out-of-range KEEP(339)= 1 KEEP(249)=1 !$ KEEP(249) = OMP_GET_MAX_THREADS() KEEP(250) = 1 KEEP(261) = 1 KEEP(262) = 0 KEEP(263) = 1 KEEP(266) = 0 KEEP(267) = 0 KEEP(268)=77 KEEP(350) = 2 KEEP(351) = 1 KEEP(360) = 256 KEEP(361) = 2048 KEEP(362) = 4 KEEP(363) = 512 KEEP(364) = 32768 ! 32KiB KEEP(365) = 1024*1024 ! 1MiB KEEP(366) = 450 KEEP(370) = 1 KEEP(375) = 1 KEEP(378) = 1 C OMP parallelization of arrowheads KEEP(399) = -1 KEEP(397) = -1 KEEP(402) = 1 KEEP(405) = 0 ! 1 under L0OMP KEEP(406) = 2 #if defined(__PGLLVM__) C With aocc version of Classic flang, we want to C avoid an OpenMP bug during L0thread copies by C switching to simpler copy algorithm. C Since we cannot test __aocc__ in Fortran, we rely on the C slower algorithm as soon as __PGLLVM__ is detected, even C if this is "too careful". KEEP(406)=0 #endif C 0.9 equilibration KEEP(408) = 90 KEEP(420) = 4*KEEP(6) ! if KEEP(6)=32 then 128 #if defined(GEMMT_AVAILABLE) KEEP(421) = -1 #if defined(__ve__) KEEP(421) = 1000 ! GEMMT only on large-enough matrices #endif #endif #if defined(ANA_BLKAUTO) C automatic graph compression effective C only if reduction of the number of nodes C in graph smaller than 75% KEEP(440) = 75 #endif C Default size of KEEP(424) is defined below. C It does not depend on arithmetic, C it is related to L1 cache size: 250 * 64 bytes C is about half of the cache size (32768 bytes). C This leaves space in cache for the destination, C of size 250*sizeof(arith). (4k bytes for z) C At each new block of size KEEP(424), there is C probably a cache miss on the pivot. KEEP(424) = 250 KEEP(448) = 0 KEEP(458)=0 #if defined(__ve__) KEEP(458)=1 #endif KEEP(459) = 10 ! max number of panels KEEP(460) = 63 ! min panel size KEEP(461) = 10 KEEP(462) = 100 KEEP(466) = 1 KEEP(468) = 3 KEEP(469) = 3 KEEP(471) = -1 KEEP(479) = 1 KEEP(480) = 3 KEEP(472) = 1 KEEP(476) = 50 KEEP(477) = 100 KEEP(483) = 80 KEEP(484) = 80 KEEP(487) = 1 IF (KEEP(472).EQ.1) THEN KEEP(488) = 768 ELSE KEEP(488) = 8*KEEP(6) ! if KEEP(6)=32 then 256 ENDIF KEEP(490) = 128 KEEP(491) = 1000 #if defined(__ve__) KEEP(490)=512 KEEP(491)=8000 #endif KEEP(492) = 1 KEEP(493) = 0 KEEP(496) = 1 KEEP(495) = -1 KEEP(497) = -1 C RETURN END SUBROUTINE CMUMPSID SUBROUTINE CMUMPS_SET_KEEP72(id, LP) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE (CMUMPS_STRUC) :: id INTEGER LP IF (id%KEEP(72)==1) THEN id%KEEP(37) = 2*id%NSLAVES id%KEEP(3)=3 id%KEEP(4)=2 id%KEEP(5)=1 id%KEEP(6)=2 id%KEEP(9)=3 C KEEP(11) not too small either id%KEEP(11)=3 id%KEEP(39)=300 id%KEEP(7) = 3 id%KEEP(8) = 2 id%KEEP(57)= 3 id%KEEP(58)= 2 id%KEEP(63)=3 id%CNTL(1)=0.1E0 id%KEEP(213) = 101 id%KEEP(85)=2 id%KEEP(85)=-4 id%KEEP(62) = 2 id%KEEP(1) = 1 id%KEEP(123) = 6 id%KEEP(147) = 3 id%KEEP(197) = 0 id%KEEP(51) = 2 !$ id%KEEP(360) = 2 !$ id%KEEP(361) = 2 !$ id%KEEP(362) = 1 !$ id%KEEP(363) = 2 id%KEEP(364) = 10 id%KEEP(366) = 2 id%KEEP(420) = 4 id%KEEP(488) = 4 id%KEEP(490) = 5 id%KEEP(491) = 5 id%ICNTL(27)=-3 id%KEEP(227)=3 id%KEEP(30) = 1000 C ... Try to avoid messages smaller than KEEP(170)/1000 of recv buf C large value to test deadlock C (no effect with KEEP(173)=1) id%KEEP(170) = 500 ! default is 100 C reduce buffer size estimated during analysis C with respect to message size without SMB mechanism C ... minimum nb of blocks is reduced to stress more buffers id%KEEP(171) = 3 ! default is 10 blocs C ... buffer size factor of reduction is increased C to stress more buffers id%KEEP(172) = 10 ! default is 3 C both values of KEEP(173) should be tested id%KEEP(173) = 1 ! 0=normal 1=force blocking id%KEEP(178) = 1 ! reduce it to one panel for FR LDLT CB buf C ... factor of reduction of CB messages is increased id%KEEP(238) = 36 ! default is 24 ELSE IF (id%KEEP(72)==2) THEN C{ id%KEEP(85)=2 ! default is id%KEEP(85)=-10000 ! default is 160 id%KEEP(210) = 1 ! defaults is 0 (automatic) id%KEEP8(79) = 160000_8 id%KEEP(1) = 2 ! default is 8 id%KEEP(102) = 110 ! defaults is 150 up to 48 procs C reduce buffer size estimated during analysis C with respect to message size without SMB mechanism C ... minimum nb of blocks is reduced to stress more buffers id%KEEP(171) = 3 ! default is 10 blocs C ... buffer size factor of reduction is increased C to stress more buffers id%KEEP(172) = 10 ! default is 3 id%KEEP(213) = 121 ! default is 201 C} END IF RETURN END SUBROUTINE CMUMPS_SET_KEEP72 MUMPS_5.8.1/src/zana_mtrans.F0000664000175000017500000007771615042446442015700 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C History: C ------- C This maximum transversal set of routines are C based on the work done by Jacko Koster at CERFACS for C his PhD thesis from Institut National Polytechnique de Toulouse C at CERFACS (1995-1997) and includes modifications provided C by the author as well as work done by Stephane Pralet C first at CERFACS during his PhD thesis (2003-2004) then C at INPT-IRIT (2004-2005) during his post-doctoral position. C C The main research publication references for this work are: C [1] I. S. Duff, (1981), C "Algorithm 575. Permutations for a zero-free diagonal", C ACM Trans. Math. Software 7(3), 387-390. C [2] I. S. Duff and J. Koster, (1998), C "The design and use of algorithms for permuting large C entries to the diagonal of sparse matrices", C SIAM J. Matrix Anal. Appl., vol. 20, no. 4, pp. 889-901. C [3] I. S. Duff and J. Koster, (2001), C "On algorithms for permuting large entries to the diagonal C of sparse matrices", C SIAM J. Matrix Anal. Appl., vol. 22, no. 4, pp. 973-996. C SUBROUTINE ZMUMPS_MTRANSI(ICNTL,CNTL) IMPLICIT NONE INTEGER NICNTL, NCNTL PARAMETER (NICNTL=10, NCNTL=10) INTEGER ICNTL(NICNTL) DOUBLE PRECISION CNTL(NCNTL) INTEGER I ICNTL(1) = 6 ICNTL(2) = 6 ICNTL(3) = -1 ICNTL(4) = -1 ICNTL(5) = 0 DO 10 I = 6,NICNTL ICNTL(I) = 0 10 CONTINUE CNTL(1) = 0.0D0 CNTL(2) = 0.0D0 DO 20 I = 3,NCNTL CNTL(I) = 0.0D0 20 CONTINUE RETURN END SUBROUTINE ZMUMPS_MTRANSI SUBROUTINE ZMUMPS_MTRANSB & (M,N,NE,IP,IRN,A,IPERM,NUM,JPERM,PR,Q,L,D,RINF) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: NE INTEGER :: IRN(NE),IPERM(M),JPERM(N),Q(M),L(M) INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER(8), INTENT(OUT) :: PR(N) DOUBLE PRECISION :: A(NE) DOUBLE PRECISION :: D(M), RINF INTEGER :: I,II,J,JJ,JORD,Q0,QLEN,IDUM,JDUM,ISP,JSP, & I0,UP,LOW, IK INTEGER(8) :: K,KK,KK1,KK2 DOUBLE PRECISION CSP,DI,DNEW,DQ0,AI,A0,BV,TBV,RLX DOUBLE PRECISION ZERO,MINONE,ONE PARAMETER (ZERO=0.0D0,MINONE=-1.0D0,ONE=1.0D0) INTRINSIC abs,min EXTERNAL ZMUMPS_MTRANSD, ZMUMPS_MTRANSE, & ZMUMPS_MTRANSF, ZMUMPS_MTRANSX RLX = D(1) NUM = 0 BV = RINF DO 10 I = 1,N JPERM(I) = 0 PR(I) = IP(I) 10 CONTINUE DO 12 I = 1,M IPERM(I) = 0 D(I) = ZERO 12 CONTINUE DO 30 J = 1,N A0 = MINONE DO 20 K = IP(J),IP(J+1)-1_8 I = IRN(K) AI = abs(A(K)) IF (AI.GT.D(I)) D(I) = AI IF (JPERM(J).NE.0) GO TO 20 IF (AI.GE.BV) THEN A0 = BV IF (IPERM(I).NE.0) GO TO 20 JPERM(J) = I IPERM(I) = J NUM = NUM + 1 ELSE IF (AI.LE.A0) GO TO 20 A0 = AI I0 = I ENDIF 20 CONTINUE IF (A0.NE.MINONE .AND. A0.LT.BV) THEN BV = A0 IF (IPERM(I0).NE.0) GO TO 30 IPERM(I0) = J JPERM(J) = I0 NUM = NUM + 1 ENDIF 30 CONTINUE IF (M.EQ.N) THEN DO 35 I = 1,M BV = min(BV,D(I)) 35 CONTINUE ENDIF IF (NUM.EQ.N) GO TO 1000 DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 DO 50 K = IP(J),IP(J+1)-1_8 I = IRN(K) AI = abs(A(K)) IF (AI.LT.BV) GO TO 50 IF (IPERM(I).EQ.0) GO TO 90 JJ = IPERM(I) KK1 = PR(JJ) KK2 = IP(JJ+1) - 1_8 IF (KK1.GT.KK2) GO TO 50 DO 70 KK = KK1,KK2 II = IRN(KK) IF (IPERM(II).NE.0) GO TO 70 IF (abs(A(KK)).GE.BV) GO TO 80 70 CONTINUE PR(JJ) = KK2 + 1_8 50 CONTINUE GO TO 95 80 JPERM(JJ) = II IPERM(II) = JJ PR(JJ) = KK + 1_8 90 NUM = NUM + 1 JPERM(J) = I IPERM(I) = J PR(J) = K + 1_8 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = MINONE L(I) = 0 99 CONTINUE TBV = BV * (ONE-RLX) DO 100 JORD = 1,N IF (JPERM(JORD).NE.0) GO TO 100 QLEN = 0 LOW = M + 1 UP = M + 1 CSP = MINONE J = JORD PR(J) = -1_8 DO 115 K = IP(J),IP(J+1)-1_8 I = IRN(K) DNEW = abs(A(K)) IF (CSP.GE.DNEW) GO TO 115 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = I JSP = J IF (CSP.GE.TBV) GO TO 160 ELSE D(I) = DNEW IF (DNEW.GE.TBV) THEN LOW = LOW - 1 Q(LOW) = I ELSE QLEN = QLEN + 1 L(I) = QLEN CALL ZMUMPS_MTRANSD(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = int(J,8) ENDIF 115 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = Q(1) IF (CSP.GE.D(I)) GO TO 160 BV = D(I) TBV = BV * (ONE-RLX) DO 152 IDUM = 1,M CALL ZMUMPS_MTRANSE(QLEN,M,Q,D,L,1) L(I) = 0 LOW = LOW - 1 Q(LOW) = I IF (QLEN.EQ.0) GO TO 153 I = Q(1) IF (D(I).LT.TBV) GO TO 153 152 CONTINUE ENDIF 153 UP = UP - 1 Q0 = Q(UP) DQ0 = D(Q0) L(Q0) = UP J = IPERM(Q0) DO 155 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (L(I).GE.UP) GO TO 155 DNEW = min(DQ0,abs(A(K))) IF (CSP.GE.DNEW) GO TO 155 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = I JSP = J IF (CSP.GE.TBV) GO TO 160 ELSE DI = D(I) IF (DI.GE.TBV .OR. DI.GE.DNEW) GO TO 155 D(I) = DNEW IF (DNEW.GE.TBV) THEN IF (DI.NE.MINONE) THEN CALL ZMUMPS_MTRANSF(L(I),QLEN,M,Q,D,L,1) ENDIF L(I) = 0 LOW = LOW - 1 Q(LOW) = I ELSE IF (DI.EQ.MINONE) THEN QLEN = QLEN + 1 L(I) = QLEN ENDIF CALL ZMUMPS_MTRANSD(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = int(J,8) ENDIF 155 CONTINUE 150 CONTINUE 160 IF (CSP.EQ.MINONE) GO TO 190 BV = min(BV,CSP) TBV = BV * (ONE-RLX) NUM = NUM + 1 I = ISP J = JSP DO 170 JDUM = 1,NUM+1 I0 = JPERM(J) JPERM(J) = I IPERM(I) = J J = int(PR(J)) IF (J.EQ.-1) GO TO 190 I = I0 170 CONTINUE 190 DO 191 IK = UP,M I = Q(IK) D(I) = MINONE L(I) = 0 191 CONTINUE DO 192 IK = LOW,UP-1 I = Q(IK) D(I) = MINONE 192 CONTINUE DO 193 IK = 1,QLEN I = Q(IK) D(I) = MINONE L(I) = 0 193 CONTINUE 100 CONTINUE 1000 IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL ZMUMPS_MTRANSX(M,N,IPERM,L,JPERM) 2000 RETURN END SUBROUTINE ZMUMPS_MTRANSB SUBROUTINE ZMUMPS_MTRANSD(I,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER I,N,IWAY INTEGER Q(N),L(N) DOUBLE PRECISION D(N) INTEGER IDUM,K,POS,POSK,QK PARAMETER (K=2) DOUBLE PRECISION DI POS = L(I) IF (POS.LE.1) GO TO 20 DI = D(I) IF (IWAY.EQ.1) THEN DO 10 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.LE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 10 CONTINUE ELSE DO 15 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.GE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 15 CONTINUE ENDIF 20 Q(POS) = I L(I) = POS RETURN END SUBROUTINE ZMUMPS_MTRANSD SUBROUTINE ZMUMPS_MTRANSE(QLEN,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER QLEN,N,IWAY INTEGER Q(N),L(N) DOUBLE PRECISION D(N) INTEGER I,IDUM,K,POS,POSK PARAMETER (K=2) DOUBLE PRECISION DK,DR,DI I = Q(QLEN) DI = D(I) QLEN = QLEN - 1 POS = 1 IF (IWAY.EQ.1) THEN DO 10 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 20 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.LT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.GE.DK) GO TO 20 Q(POS) = Q(POSK) L(Q(POS)) = POS POS = POSK 10 CONTINUE ELSE DO 15 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 20 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.GT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.LE.DK) GO TO 20 Q(POS) = Q(POSK) L(Q(POS)) = POS POS = POSK 15 CONTINUE ENDIF 20 Q(POS) = I L(I) = POS RETURN END SUBROUTINE ZMUMPS_MTRANSE SUBROUTINE ZMUMPS_MTRANSF(POS0,QLEN,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER POS0,QLEN,N,IWAY INTEGER Q(N),L(N) DOUBLE PRECISION D(N) INTEGER I,IDUM,K,POS,POSK,QK PARAMETER (K=2) DOUBLE PRECISION DK,DR,DI IF (QLEN.EQ.POS0) THEN QLEN = QLEN - 1 RETURN ENDIF I = Q(QLEN) DI = D(I) QLEN = QLEN - 1 POS = POS0 IF (IWAY.EQ.1) THEN IF (POS.LE.1) GO TO 20 DO 10 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.LE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 10 CONTINUE 20 Q(POS) = I L(I) = POS IF (POS.NE.POS0) RETURN DO 30 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 40 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.LT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.GE.DK) GO TO 40 QK = Q(POSK) Q(POS) = QK L(QK) = POS POS = POSK 30 CONTINUE ELSE IF (POS.LE.1) GO TO 34 DO 32 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.GE.D(QK)) GO TO 34 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 34 32 CONTINUE 34 Q(POS) = I L(I) = POS IF (POS.NE.POS0) RETURN DO 36 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 40 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.GT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.LE.DK) GO TO 40 QK = Q(POSK) Q(POS) = QK L(QK) = POS POS = POSK 36 CONTINUE ENDIF 40 Q(POS) = I L(I) = POS RETURN END SUBROUTINE ZMUMPS_MTRANSF SUBROUTINE ZMUMPS_MTRANSQ(IP,LENL,LENH,W,WLEN,A,NVAL,VAL) IMPLICIT NONE INTEGER ::WLEN,NVAL INTEGER :: LENL(*),LENH(*),W(*) INTEGER(8) :: IP(*) DOUBLE PRECISION :: A(*),VAL INTEGER XX,J,K,S,POS INTEGER(8) :: II PARAMETER (XX=10) DOUBLE PRECISION SPLIT(XX),HA NVAL = 0 DO 10 K = 1,WLEN J = W(K) DO 15 II = IP(J)+int(LENL(J),8),IP(J)+int(LENH(J)-1,8) HA = A(II) IF (NVAL.EQ.0) THEN SPLIT(1) = HA NVAL = 1 ELSE DO 20 S = NVAL,1,-1 IF (SPLIT(S).EQ.HA) GO TO 15 IF (SPLIT(S).GT.HA) THEN POS = S + 1 GO TO 21 ENDIF 20 CONTINUE POS = 1 21 DO 22 S = NVAL,POS,-1 SPLIT(S+1) = SPLIT(S) 22 CONTINUE SPLIT(POS) = HA NVAL = NVAL + 1 ENDIF IF (NVAL.EQ.XX) GO TO 11 15 CONTINUE 10 CONTINUE 11 IF (NVAL.GT.0) VAL = SPLIT((NVAL+1)/2) RETURN END SUBROUTINE ZMUMPS_MTRANSQ SUBROUTINE ZMUMPS_MTRANSR(N,NE,IP,IRN,A) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NE INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NE) DOUBLE PRECISION, INTENT(INOUT) :: A(NE) INTEGER :: THRESH,TDLEN PARAMETER (THRESH=15,TDLEN=50) INTEGER :: J, LEN, HI INTEGER(8) :: K, IPJ, TD, FIRST, LAST, MID, R, S DOUBLE PRECISION :: HA, KEY INTEGER(8) :: TODO(TDLEN) DO 100 J = 1,N LEN = int(IP(J+1) - IP(J)) IF (LEN.LE.1) GO TO 100 IPJ = IP(J) IF (LEN.LT.THRESH) GO TO 400 TODO(1) = IPJ TODO(2) = IPJ +int(LEN,8) TD = 2_8 500 CONTINUE FIRST = TODO(TD-1) LAST = TODO(TD) KEY = A((FIRST+LAST)/2) DO 475 K = FIRST,LAST-1 HA = A(K) IF (HA.EQ.KEY) GO TO 475 IF (HA.GT.KEY) GO TO 470 KEY = HA GO TO 470 475 CONTINUE TD = TD - 2_8 GO TO 425 470 MID = FIRST DO 450 K = FIRST,LAST-1 IF (A(K).LE.KEY) GO TO 450 HA = A(MID) A(MID) = A(K) A(K) = HA HI = IRN(MID) IRN(MID) = IRN(K) IRN(K) = HI MID = MID + 1 450 CONTINUE IF (MID-FIRST.GE.LAST-MID) THEN TODO(TD+2) = LAST TODO(TD+1) = MID TODO(TD) = MID ELSE TODO(TD+2) = MID TODO(TD+1) = FIRST TODO(TD) = LAST TODO(TD-1) = MID ENDIF TD = TD + 2_8 425 CONTINUE IF (TD.EQ.0_8) GO TO 400 IF (TODO(TD)-TODO(TD-1).GE.int(THRESH,8)) GO TO 500 TD = TD - 2_8 GO TO 425 400 DO 200 R = IPJ+1_8,IPJ+int(LEN-1,8) IF (A(R-1) .LT. A(R)) THEN HA = A(R) HI = IRN(R) A(R) = A(R-1_8) IRN(R) = IRN(R-1_8) DO 300 S = R-1,IPJ+1_8,-1_8 IF (A(S-1) .LT. HA) THEN A(S) = A(S-1) IRN(S) = IRN(S-1) ELSE A(S) = HA IRN(S) = HI GO TO 200 END IF 300 CONTINUE A(IPJ) = HA IRN(IPJ) = HI END IF 200 CONTINUE 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_MTRANSR SUBROUTINE ZMUMPS_MTRANSS(M,N,NE,IP,IRN,A,IPERM,NUMX, & W,LEN,LENL,LENH,FC,IW,IW4,RLX,RINF) IMPLICIT NONE INTEGER, INTENT(IN) :: M,N INTEGER(8), INTENT(IN) :: NE INTEGER, INTENT(OUT) :: NUMX INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER :: IRN(NE),IPERM(N), & W(N),LEN(N),LENL(N),LENH(N),FC(N),IW(M),IW4(3*N+M) DOUBLE PRECISION A(NE),RLX,RINF INTEGER :: NUM,NVAL,WLEN,I,J,L,CNT,MOD, IDUM INTEGER(8) :: K, II, KDUM1, KDUM2 DOUBLE PRECISION :: BVAL,BMIN,BMAX EXTERNAL ZMUMPS_MTRANSQ,ZMUMPS_MTRANSU,ZMUMPS_MTRANSX DO 20 J = 1,N FC(J) = J LEN(J) = int(IP(J+1) - IP(J)) 20 CONTINUE DO 21 I = 1,M IW(I) = 0 21 CONTINUE CNT = 1 MOD = 1 NUMX = 0 CALL ZMUMPS_MTRANSU(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW, & NUMX,N, & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) NUM = NUMX IF (NUM.NE.N) THEN BMAX = RINF ELSE BMAX = RINF DO 30 J = 1,N BVAL = 0.0D0 DO 25 K = IP(J),IP(J+1)-1_8 IF (A(K).GT.BVAL) BVAL = A(K) 25 CONTINUE IF (BVAL.LT.BMAX) BMAX = BVAL 30 CONTINUE BMAX = 1.001D0 * BMAX ENDIF BVAL = 0.0D0 BMIN = 0.0D0 WLEN = 0 DO 48 J = 1,N L = int(IP(J+1) - IP(J)) LENH(J) = L LEN(J) = L DO 45 K = IP(J),IP(J+1)-1_8 IF (A(K).LT.BMAX) GO TO 46 45 CONTINUE K = IP(J+1) 46 LENL(J) = int(K - IP(J)) IF (LENL(J).EQ.L) GO TO 48 WLEN = WLEN + 1 W(WLEN) = J 48 CONTINUE DO 90 KDUM1 = 1_8,NE IF (NUM.EQ.NUMX) THEN DO 50 I = 1,M IPERM(I) = IW(I) 50 CONTINUE DO 80 KDUM2 = 1_8,NE BMIN = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL ZMUMPS_MTRANSQ(IP,LENL,LEN,W,WLEN,A,NVAL,BVAL) IF (NVAL.LE.1) GO TO 1000 K = 1 DO 70 IDUM = 1,N IF (K.GT.WLEN) GO TO 71 J = W(K) DO 55 II = IP(J)+int(LEN(J)-1,8), & IP(J)+int(LENL(J),8),-1_8 IF (A(II).GE.BVAL) GO TO 60 I = IRN(II) IF (IW(I).NE.J) GO TO 55 IW(I) = 0 NUM = NUM - 1 FC(N-NUM) = J 55 CONTINUE 60 LENH(J) = LEN(J) LEN(J) = int(II - IP(J) + 1) IF (LENL(J).EQ.LENH(J)) THEN W(K) = W(WLEN) WLEN = WLEN - 1 ELSE K = K + 1 ENDIF 70 CONTINUE 71 IF (NUM.LT.NUMX) GO TO 81 80 CONTINUE 81 MOD = 1 ELSE BMAX = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL ZMUMPS_MTRANSQ(IP,LEN,LENH,W,WLEN,A,NVAL,BVAL) IF (NVAL.EQ.0. OR. BVAL.EQ.BMIN) GO TO 1000 K = 1 DO 87 IDUM = 1,N IF (K.GT.WLEN) GO TO 88 J = W(K) DO 85 II = IP(J)+int(LEN(J),8),IP(J)+int(LENH(J)-1,8) IF (A(II).LT.BVAL) GO TO 86 85 CONTINUE 86 LENL(J) = LEN(J) LEN(J) = int(II - IP(J)) IF (LENL(J).EQ.LENH(J)) THEN W(K) = W(WLEN) WLEN = WLEN - 1 ELSE K = K + 1 ENDIF 87 CONTINUE 88 MOD = 0 ENDIF CNT = CNT + 1 CALL ZMUMPS_MTRANSU(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW, & NUM,NUMX, & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) 90 CONTINUE 1000 IF (M.EQ.N .and. NUMX.EQ.N) GO TO 2000 CALL ZMUMPS_MTRANSX(M,N,IPERM,IW,W) 2000 RETURN END SUBROUTINE ZMUMPS_MTRANSS C SUBROUTINE ZMUMPS_MTRANSU & (ID,MOD,M,N,IRN,LIRN,IP,LENC,FC,IPERM,NUM,NUMX, & PR,ARP,CV,OUT) IMPLICIT NONE INTEGER :: ID,MOD,M,N,NUM,NUMX INTEGER(8), INTENT(IN) :: LIRN INTEGER :: ARP(N),CV(M),IRN(LIRN), & FC(N),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER(8), INTENT(IN) :: IP(N) INTEGER I,J,J1,JORD,NFC,K,KK, & NUM0,NUM1,NUM2,ID0,ID1,LAST INTEGER(8) :: IN1, IN2, II IF (ID.EQ.1) THEN DO 5 I = 1,M CV(I) = 0 5 CONTINUE DO 6 J = 1,N ARP(J) = 0 6 CONTINUE NUM1 = N NUM2 = N ELSE IF (MOD.EQ.1) THEN DO 8 J = 1,N ARP(J) = 0 8 CONTINUE ENDIF NUM1 = NUMX NUM2 = N - NUMX ENDIF NUM0 = NUM NFC = 0 ID0 = (ID-1)*N DO 100 JORD = NUM0+1,N ID1 = ID0 + JORD J = FC(JORD-NUM0) PR(J) = -1 DO 70 K = 1,JORD IF (ARP(J).GE.LENC(J)) GO TO 30 IN1 = IP(J) + int(ARP(J),8) IN2 = IP(J) + int(LENC(J) - 1,8) DO 20 II = IN1,IN2 I = IRN(II) IF (IPERM(I).EQ.0) GO TO 80 20 CONTINUE ARP(J) = LENC(J) 30 OUT(J) = LENC(J) - 1 DO 60 KK = 1,JORD IN1 = int(OUT(J),8) IF (IN1.LT.0) GO TO 50 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 40 II = IN1,IN2 I = IRN(II) IF (CV(I).EQ.ID1) GO TO 40 J1 = J J = IPERM(I) CV(I) = ID1 PR(J) = J1 OUT(J1) = int(IN2 - II) - 1 GO TO 70 40 CONTINUE 50 J1 = PR(J) IF (J1.EQ.-1) THEN NFC = NFC + 1 FC(NFC) = J IF (NFC.GT.NUM2) THEN LAST = JORD GO TO 101 ENDIF GO TO 100 ENDIF J = J1 60 CONTINUE 70 CONTINUE 80 IPERM(I) = J ARP(J) = int(II - IP(J)) + 1 NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 95 II = IP(J) + int(LENC(J) - OUT(J) - 2,8) I = IRN(II) IPERM(I) = J 90 CONTINUE 95 IF (NUM.EQ.NUM1) THEN LAST = JORD GO TO 101 ENDIF 100 CONTINUE LAST = N 101 DO 110 JORD = LAST+1,N NFC = NFC + 1 FC(NFC) = FC(JORD-NUM0) 110 CONTINUE RETURN END SUBROUTINE ZMUMPS_MTRANSU C SUBROUTINE ZMUMPS_MTRANSW(M,N,NE,IP,IRN,A,IPERM,NUM, & JPERM,L32,OUT,PR,Q,L,U,D,RINF) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: NE INTEGER :: IRN(NE),IPERM(M),Q(M),L32(max(M,N)) INTEGER(8) :: IP(N+1), PR(N), L(M), JPERM(N), OUT(N) DOUBLE PRECISION A(NE),U(M),D(M),RINF,RINF3 INTEGER :: I,I0,II,J,JJ,JORD,Q0,QLEN,JDUM,JSP, & UP,LOW,IK INTEGER(8) :: K, KK, KK1, KK2, K0, K1, K2, ISP DOUBLE PRECISION :: CSP,DI,DMIN,DNEW,DQ0,VJ,RLX LOGICAL :: LORD DOUBLE PRECISION :: ZERO, ONE PARAMETER (ZERO=0.0D0,ONE=1.0D0) EXTERNAL ZMUMPS_MTRANSD, ZMUMPS_MTRANSE, & ZMUMPS_MTRANSF, ZMUMPS_MTRANSX RLX = U(1) RINF3 = U(2) LORD = (JPERM(1).EQ.6) NUM = 0 DO 10 I = 1,N JPERM(I) = 0_8 PR(I) = IP(I) D(I) = RINF 10 CONTINUE DO 15 I = 1,M U(I) = RINF3 IPERM(I) = 0 L(I) = 0_8 15 CONTINUE DO 30 J = 1,N IF (int(IP(J+1)-IP(J)) .GT. N/10 .AND. N.GT.50) GO TO 30 DO 20 K = IP(J),IP(J+1)-1 I = IRN(K) IF (A(K).GT.U(I)) GO TO 20 U(I) = A(K) IPERM(I) = J L(I) = K 20 CONTINUE 30 CONTINUE DO 40 I = 1,M J = IPERM(I) IF (J.EQ.0) GO TO 40 IF (JPERM(J).EQ.0_8) THEN JPERM(J) = L(I) D(J) = U(I) NUM = NUM + 1 ELSEIF (D(J).GT.U(I)) THEN K = JPERM(J) II = IRN(K) IPERM(II) = 0 JPERM(J) = L(I) D(J) = U(I) ELSE IPERM(I) = 0 ENDIF 40 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 45 I = 1,M D(I) = ZERO 45 CONTINUE DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 K1 = IP(J) K2 = IP(J+1) - 1_8 IF (K1.GT.K2) GO TO 95 VJ = RINF DO 50 K = K1,K2 I = IRN(K) DI = A(K) - U(I) IF (DI.GT.VJ) GO TO 50 IF (DI.LT.VJ .OR. DI.EQ.RINF) GO TO 55 IF (IPERM(I).NE.0 .OR. IPERM(I0).EQ.0) GO TO 50 55 VJ = DI I0 = I K0 = K 50 CONTINUE D(J) = VJ K = K0 I = I0 IF (IPERM(I).EQ.0) GO TO 90 DO 60 K = K0,K2 I = IRN(K) IF (A(K)-U(I).GT.VJ) GO TO 60 JJ = IPERM(I) KK1 = PR(JJ) KK2 = IP(JJ+1) - 1_8 IF (KK1.GT.KK2) GO TO 60 DO 70 KK = KK1,KK2 II = IRN(KK) IF (IPERM(II).GT.0) GO TO 70 IF (A(KK)-U(II).LE.D(JJ)) GO TO 80 70 CONTINUE PR(JJ) = KK2 + 1_8 60 CONTINUE GO TO 95 80 JPERM(JJ) = KK IPERM(II) = JJ PR(JJ) = KK + 1_8 90 NUM = NUM + 1 JPERM(J) = K IPERM(I) = J PR(J) = K + 1_8 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = RINF Q(I) = 0 99 CONTINUE DO 100 JORD = 1,N IF (JPERM(JORD).NE.0) GO TO 100 DMIN = RINF QLEN = 0 LOW = M + 1 UP = M + 1 CSP = RINF J = JORD PR(J) = -1_8 DO 115 K = IP(J),IP(J+1)-1_8 I = IRN(K) DNEW = A(K) - U(I) IF (DNEW.GE.CSP) GO TO 115 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = K JSP = J ELSE IF (DNEW.LT.DMIN) DMIN = DNEW D(I) = DNEW QLEN = QLEN + 1 L(QLEN) = K ENDIF 115 CONTINUE Q0 = QLEN QLEN = 0 DO 120 IK = 1,Q0 K = L(IK) I = IRN(K) IF (CSP.LE.D(I)) THEN D(I) = RINF GO TO 120 ENDIF IF (D(I).LE.DMIN) THEN LOW = LOW - 1 L32(LOW) = I Q(I) = LOW ELSE QLEN = QLEN + 1 Q(I) = QLEN CALL ZMUMPS_MTRANSD(I,M,L32,D,Q,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = int(J,8) 120 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = L32(1) IF (D(I).LT.RINF) DMIN = D(I)*(ONE+RLX) IF (DMIN.GE.CSP) GO TO 160 152 CALL ZMUMPS_MTRANSE(QLEN,M,L32,D,Q,2) LOW = LOW - 1 L32(LOW) = I Q(I) = LOW IF (QLEN.EQ.0) GO TO 153 I = L32(1) IF (D(I).GT.DMIN) GO TO 153 GO TO 152 ENDIF 153 Q0 = L32(UP-1) DQ0 = D(Q0) IF (DQ0.GE.CSP) GO TO 160 IF (DMIN.GE.CSP) GO TO 160 UP = UP - 1 J = IPERM(Q0) VJ = DQ0 - A(JPERM(J)) + U(Q0) K1 = IP(J+1)-1_8 IF (LORD) THEN IF (CSP.NE.RINF) THEN DI = CSP - VJ IF (A(K1).GE.DI) THEN K0 = JPERM(J) IF (K0.GE.K1-6) GO TO 178 177 CONTINUE K = (K0+K1)/2 IF (A(K).GE.DI) THEN K1 = K ELSE K0 = K ENDIF IF (K0.GE.K1-6) GO TO 178 GO TO 177 178 DO 179 K = K0+1,K1 IF (A(K).LT.DI) GO TO 179 K1 = K - 1 GO TO 181 179 CONTINUE ENDIF ENDIF 181 IF (K1.EQ.JPERM(J)) K1 = K1 - 1 ENDIF K0 = IP(J) DI = CSP - VJ DO 155 K = K0,K1 I = IRN(K) IF (Q(I).GE.LOW) GO TO 155 DNEW = A(K) - U(I) IF (DNEW.GE.DI) GO TO 155 DNEW = DNEW + VJ IF (DNEW.GT.D(I)) GO TO 155 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = K JSP = J DI = CSP - VJ ELSE IF (DNEW.GE.D(I)) GO TO 155 D(I) = DNEW IF (DNEW.LE.DMIN) THEN IF (Q(I).NE.0) THEN CALL ZMUMPS_MTRANSF(Q(I),QLEN,M,L32,D,Q,2) ENDIF LOW = LOW - 1 L32(LOW) = I Q(I) = LOW ELSE IF (Q(I).EQ.0) THEN QLEN = QLEN + 1 Q(I) = QLEN ENDIF CALL ZMUMPS_MTRANSD(I,M,L32,D,Q,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = int(J,8) ENDIF 155 CONTINUE 150 CONTINUE 160 IF (CSP.EQ.RINF) GO TO 190 NUM = NUM + 1 I = IRN(ISP) J = JSP IPERM(I) = J JPERM(J) = ISP DO 170 JDUM = 1,NUM JJ = int(PR(J)) IF (JJ.EQ.-1) GO TO 180 K = OUT(J) I = IRN(K) IPERM(I) = JJ JPERM(JJ) = K J = JJ 170 CONTINUE 180 DO 182 JJ = UP,M I = L32(JJ) U(I) = U(I) + D(I) - CSP 182 CONTINUE 190 DO 191 JJ = UP,M I = L32(JJ) D(I) = RINF Q(I) = 0 191 CONTINUE DO 192 JJ = LOW,UP-1 I = L32(JJ) D(I) = RINF Q(I) = 0 192 CONTINUE DO 193 JJ = 1,QLEN I = L32(JJ) D(I) = RINF Q(I) = 0 193 CONTINUE 100 CONTINUE 1000 CONTINUE DO 1200 J = 1,N K = JPERM(J) IF (K.NE.0) THEN D(J) = A(K) - U(IRN(K)) ELSE D(J) = ZERO ENDIF 1200 CONTINUE DO 1201 I = 1,M IF (IPERM(I).EQ.0) U(I) = ZERO 1201 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL ZMUMPS_MTRANSX(M,N,IPERM,Q,L32) 2000 RETURN END SUBROUTINE ZMUMPS_MTRANSW SUBROUTINE ZMUMPS_MTRANSZ & (M,N,IRN,LIRN,IP,LENC,IPERM,NUM,PR,ARP,CV,OUT) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: LIRN INTEGER :: ARP(N),CV(M),IRN(LIRN),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER(8), INTENT(IN) :: IP(N) C Local variables INTEGER :: I,J,J1,JORD,K,KK INTEGER(8) :: II, IN1, IN2 INTEGER, PARAMETER :: KXX = 100 ! default DOUBLE PRECISION :: R INTEGER :: MAXNUM EXTERNAL ZMUMPS_MTRANSX R = dble(KXX)/dble(100) MAXNUM = min(N, INT(N*R)) DO 10 I = 1,M CV(I) = 0 IPERM(I) = 0 10 CONTINUE DO 12 J = 1,N ARP(J) = LENC(J) - 1 12 CONTINUE NUM = 0 DO 1000 JORD = 1,N J = JORD PR(J) = -1 DO 70 K = 1,JORD IN1 = int(ARP(J),8) IF (IN1.LT.0_8) GO TO 30 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 20 II = IN1,IN2 I = IRN(II) IF (IPERM(I).EQ.0) GO TO 80 20 CONTINUE ARP(J) = -1 30 CONTINUE OUT(J) = LENC(J) - 1 DO 60 KK = 1,JORD IN1 = int(OUT(J),8) IF (IN1.LT.0_8) GO TO 50 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 40 II = IN1,IN2 I = IRN(II) IF (CV(I).EQ.JORD) GO TO 40 J1 = J J = IPERM(I) CV(I) = JORD PR(J) = J1 OUT(J1) = int(IN2 - II - 1_8) GO TO 70 40 CONTINUE 50 CONTINUE J = PR(J) IF (J.EQ.-1) GO TO 999 60 CONTINUE 70 CONTINUE 80 CONTINUE IPERM(I) = J ARP(J) = int(IN2 - II - 1_8) NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 999 II = IP(J) + int(LENC(J) - OUT(J) - 2,8) I = IRN(II) IPERM(I) = J 90 CONTINUE 999 CONTINUE IF (KXX.GE.100) GOTO 1000 C we may stop if NUM large enough IF (NUM.GE.MAXNUM) EXIT 1000 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL ZMUMPS_MTRANSX(M,N,IPERM,CV,ARP) 2000 RETURN END SUBROUTINE ZMUMPS_MTRANSZ SUBROUTINE ZMUMPS_MTRANSX(M,N,IPERM,RW,CW) IMPLICIT NONE INTEGER M,N INTEGER RW(M),CW(N),IPERM(M) INTEGER I,J,K INTEGER, PARAMETER :: KXX = 100 INTEGER SIG SIG = -1 IF (KXX.LT.100) SIG = 1 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*SIG 30 CONTINUE DO 40 J = N+1,M K = K + 1 I = RW(K) IPERM(I) = J*SIG 40 CONTINUE RETURN END SUBROUTINE ZMUMPS_MTRANSX MUMPS_5.8.1/src/sini_driver.F0000664000175000017500000002444515042446441015666 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if defined(__ve__) #if defined(VHOFFLOAD) #include 've.h' #endif #endif SUBROUTINE SMUMPS_INI_DRIVER( id, idintr ) USE SMUMPS_STRUC_DEF USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_INTR_STRUC C C Purpose: C ======= C C Initialize an instance of the SMUMPS package. C IMPLICIT NONE INCLUDE 'mpif.h' TYPE (SMUMPS_STRUC) :: id TYPE (SMUMPS_INTR_STRUC) :: idintr INTEGER MASTER, IERR,PAR_loc,SYM_loc PARAMETER( MASTER = 0 ) INTEGER color #if defined(metis) || defined(parmetis) INTEGER I #endif INTEGER(8) :: I8 C ----------------------------- C Initialize MPI related data C ----------------------------- CALL MPI_COMM_SIZE(id%COMM, id%NPROCS, IERR ) C Now done in the main MUMPS driver: C CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR ) C PAR_loc=id%PAR SYM_loc=id%SYM C Broadcasting PAR/SYM (KEEP(46)/KEEP(50)) in order to C have only one value available: the one from the master CALL MPI_BCAST(PAR_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) CALL MPI_BCAST(SYM_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) C Initialize a subcommunicator C for slave nodes C IF ( PAR_loc .eq. 0 ) THEN C ------------------- C Host is not working C ------------------- IF ( id%MYID .eq. MASTER ) THEN color = MPI_UNDEFINED ELSE color = 0 END IF CALL MPI_COMM_SPLIT( id%COMM, color, 0, & id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS - 1 ELSE C ---------------- C Host is working C ---------------- CALL MPI_COMM_DUP( id%COMM, id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS END IF C --------------------------- C Use same slave communicator C for load information C --------------------------- IF (PAR_loc .ne. 0 .or. id%MYID .NE. MASTER) THEN CALL MPI_COMM_DUP( id%COMM_NODES, id%COMM_LOAD, IERR ) ENDIF C ---------------------------------------------- C Initialize default values for CNTL,ICNTL,KEEP,KEEP8 C potentially depending on id%SYM and id%NSLAVES C ---------------------------------------------- CALL SMUMPSID( id%NSLAVES, id%LWK_USER, & id%CNTL(1), id%ICNTL(1), & id%KEEP(1), id%KEEP8(1), id%INFO(1), id%INFOG(1), & id%RINFO(1), id%RINFOG(1), & SYM_loc, PAR_loc, id%DKEEP(1), id%MYID ) CALL MUMPS_BUILD_ARCH_NODE_COMM( id%COMM, id%KEEP(411), & id%KEEP(412), id%KEEP(413), id%KEEP(410) ) 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" #if ! defined(NO_SAVE_RESTORE) id%SAVE_DIR="NAME_NOT_INITIALIZED" id%SAVE_PREFIX="NAME_NOT_INITIALIZED" #endif C Default value for NRHS is 1 id%NRHS = 1 C Leading dimension will be reset to id%N is SMUMPS_SOL_DRIVER C if id%NRHS remains equal to 1. Otherwise id%LRHS must be C set by user. id%LRHS = 0 ! Value will be checked in SMUMPS_CHECK_DENSE_RHS ! Not accessed if id%NRHS=1 C Similar behaviour for LREDRHS (value will C be checked in SMUMPS_CHECK_REDRHS) id%LREDRHS = 0 C id%INST_Number = -1 C C Define the options for Metis C id%METIS_OPTIONS(:) = 0 #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) C Useful size is 8 C set to default options id%METIS_OPTIONS(1) = 0 #else C Useful size is 40 C This sets the default values CALL METIS_SETDEFAULTOPTIONS(id%METIS_OPTIONS) CALL MUMPS_METIS_OPTION_NUMBERING(I) C The value of I corresponds to "METIS_OPTION_NUMBERING", which tells C METIS to use Fortran numbering. METIS_OPTION_NUMBERING is defined C in metis.h and accessed through a C wrapper. id%METIS_OPTIONS(I+1) = 1 ! +1 for Fortran indexing #endif #endif C C Nullify a few pointers and integers C id%N = 0; id%NZ = 0; id%NNZ = 0_8 NULLIFY(id%IRN) NULLIFY(id%JCN) NULLIFY(id%A) id%NZ_loc = 0; id%NNZ_loc = 0_8 NULLIFY(id%IRN_loc) NULLIFY(id%JCN_loc) NULLIFY(id%A_loc) NULLIFY(id%MAPPING) NULLIFY(id%RHS) NULLIFY(id%REDRHS) id%NZ_RHS=0 NULLIFY(id%RHS_SPARSE) NULLIFY(id%IRHS_SPARSE) NULLIFY(id%IRHS_PTR) NULLIFY(id%ISOL_loc) NULLIFY(id%IRHS_loc) id%LSOL_loc=0 id%LRHS_loc=0 id%Nloc_RHS=0 NULLIFY(id%SOL_loc) NULLIFY(id%RHS_loc) NULLIFY(id%COLSCA) NULLIFY(id%ROWSCA) NULLIFY(id%ROWSCA_loc) NULLIFY(id%COLSCA_loc) NULLIFY(id%PERM_IN) NULLIFY(id%IS) NULLIFY(id%STEP) C Info for analysis by block id%NBLK = 0 NULLIFY(id%BLKPTR) NULLIFY(id%BLKVAR) C Info for pruning tree NULLIFY(id%Step2node) NULLIFY(id%DAD_STEPS) NULLIFY(id%NE_STEPS) NULLIFY(id%ND_STEPS) NULLIFY(id%FRERE_STEPS) NULLIFY(id%SYM_PERM) NULLIFY(id%UNS_PERM) NULLIFY(id%PIVNUL_LIST) NULLIFY(id%FILS) NULLIFY(id%PTRAR) NULLIFY(id%PTR8ARR) NULLIFY(id%NINCOLARR) NULLIFY(id%NINROWARR) NULLIFY(id%PTRDEBARR) NULLIFY(id%FRTPTR) NULLIFY(id%FRTELT) NULLIFY(id%NA) id%LNA=0 NULLIFY(id%PROCNODE_STEPS) NULLIFY(id%S) NULLIFY(id%LPS) NULLIFY(id%PTLUST_S) NULLIFY(id%PTRFAC) NULLIFY(id%DEPTH_FIRST) NULLIFY(id%DEPTH_FIRST_SEQ) NULLIFY(id%SBTR_ID) NULLIFY(id%SCHED_DEP) NULLIFY(id%SCHED_SBTR) NULLIFY(id%SCHED_GRP) NULLIFY(id%CROIX_MANU) NULLIFY(id%WK_USER) NULLIFY(id%MEM_SUBTREE) NULLIFY(id%MEM_SUBTREE) NULLIFY(id%MY_ROOT_SBTR) NULLIFY(id%MY_FIRST_LEAF) NULLIFY(id%MY_NB_LEAF) NULLIFY(id%COST_TRAV) NULLIFY(id%RHSINTR) id%LD_RHSINTR = 0 NULLIFY(id%GLOB2LOC_RHS) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. C C Out of Core management related data C NULLIFY(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAMES) NULLIFY(id%OOC_VADDR) NULLIFY(id%OOC_NB_FILES) NULLIFY(id%LRGROUPS) NULLIFY(id%FDM_F_ENCODING) NULLIFY(id%BLRARRAY_ENCODING) NULLIFY(id%MTKO_PROCS_MAP) C Must be nullified because of routine C SMUMPS_SIZE_IN_STRUCT NULLIFY(id%CB_SON_SIZE) C C Components of the arithmetic-dependent root C CALL SMUMPS_INI_ROOT(idintr%roota) NULLIFY(idintr%root%RG2L) NULLIFY(idintr%root%IPIV) NULLIFY(id%SCHUR_CINTERFACE) C C Element-entry C id%NELT=0 NULLIFY(id%ELTPTR) NULLIFY(id%ELTVAR) NULLIFY(id%A_ELT) NULLIFY(id%ELTPROC) C C Schur C id%SIZE_SCHUR = 0 NULLIFY( id%LISTVAR_SCHUR ) NULLIFY( id%SCHUR ) C -- Distributed Schur id%NPROW = 0 id%NPCOL = 0 id%MBLOCK = 0 id%NBLOCK = 0 id%SCHUR_MLOC = 0 ! Exit from analysis id%SCHUR_NLOC = 0 ! Exit from analysis id%SCHUR_LLD = 0 C C Candidates and node partitionning C NULLIFY(id%ISTEP_TO_INIV2) NULLIFY(id%I_AM_CAND) NULLIFY(id%FUTURE_NIV2) NULLIFY(id%TAB_POS_IN_PERE) NULLIFY(id%CANDIDATES) id%OOC_NB_FILE_TYPE=-123456 C C Initializations for L0_OMP mechanisms C NULLIFY(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) NULLIFY(id%PHYS_L0_OMP) NULLIFY(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%PERM_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) NULLIFY(id%L0_OMP_MAPPING) NULLIFY(idintr%L0_OMP_FACTORS) NULLIFY(id%I4_L0_OMP) NULLIFY(id%I8_L0_OMP) id%LPOOL_B_L0_OMP = 0 id%LPOOL_A_L0_OMP = 0 id%L_VIRT_L0_OMP = 0 id%L_PHYS_L0_OMP = 0 id%THREAD_LA = 0 C C Mapping information used during solve. C NULLIFY(id%IPTR_WORKING) NULLIFY(id%WORKING) C C Initializations for Rank detection/null space C NULLIFY(id%SINGULAR_VALUES) C Architecture data NULLIFY(id%MEM_DIST) C Must be nullified because of routine C SMUMPS_SIZE_IN_STRUCT NULLIFY(id%SUP_PROC) id%Deficiency = 0 idintr%root%LPIV = -1 idintr%root%yes = .FALSE. idintr%root%gridinit_done = .FALSE. C NOT IN SAVE/RESTORE id%ASSOCIATED_OOC_FILES=.FALSE. C C ---------------------------------------- C Find MYID_NODES relatively to COMM_NODES C If the calling processor is not inside C COMM_NODES, MYID_NODES will not be C significant / used anyway C ---------------------------------------- IF ( id%KEEP( 46 ) .ne. 0 .OR. & id%MYID .ne. MASTER ) THEN CALL MPI_COMM_RANK & (id%COMM_NODES, id%MYID_NODES, IERR ) ELSE id%MYID_NODES = -464646 ENDIF C C Check that KEEP(34), the size of a Fortran INTEGER, C as initialized above during SMUMPSID C matches the size of an integer in C. If not, C raise an error immediately. C CALL MUMPS_INT_SIZE_C(I8) IF (int(I8) .NE. id%KEEP(34)) THEN id%INFO(1)=-69 id%INFO(2)=int(I8) ! size of MUMPS_INT C Installation problem! C WRITE on unit 6 since ICNTL(1:4) are not set by the user yet IF (id%MYID .EQ. 0) WRITE(6,995) int(I8) 995 FORMAT(' Installation error -69: ', &' MUMPS_INT size (',I4,') incompatible with INTEGER size') ENDIF RETURN END SUBROUTINE SMUMPS_INI_DRIVER SUBROUTINE SMUMPS_INI_ROOT(roota) USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE(SMUMPS_ROOT_STRUC) :: roota NULLIFY(roota%RHS_CNTR_MASTER_ROOT) NULLIFY(roota%RHS_ROOT) NULLIFY(roota%SCHUR_POINTER) CALL SMUMPS_RR_INIT_POINTERS(roota) RETURN END SUBROUTINE SMUMPS_INI_ROOT MUMPS_5.8.1/src/csol_fwd_aux.F0000664000175000017500000012663715042446440016033 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE CMUMPS_TRAITER_MESSAGE_SOLVE & ( BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, & PTRFAC, IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, & INFO, KEEP, KEEP8, DKEEP, STEP, PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) USE CMUMPS_OOC USE CMUMPS_SOL_LR, ONLY: CMUMPS_SOL_SLAVE_LR_U USE CMUMPS_BUF IMPLICIT NONE INTEGER LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER N, NRHS, LPOOL, LEAF, NBFIN, LRHSINTR INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S( N ) INTEGER IWCB( LIWCB ) INTEGER IW( LIW ) INTEGER PTRICB(KEEP(28)),PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)) COMPLEX WCB( LWCB ), A( LA ) COMPLEX RHSINTR( LRHSINTR, NRHS ) INTEGER, intent(in) :: POSINRHSINTR_FWD(N) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER(8) :: PTRX, PTRY, IFR8 INTEGER IERR, K, JJ, JBDEB, JBFIN, NRHS_B INTEGER :: IWHDLR, LDA_SLAVE INTEGER :: MTYPE_SLAVE INTEGER FINODE, FPERE, LONG, NCB, POSITION, NCV, NPIV INTEGER PDEST, I, IPOSINRHSINTR INTEGER J1 INTEGER(8) :: APOS LOGICAL DUMMY LOGICAL FLAG LOGICAL :: OMP_FLAG EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR COMPLEX ALPHA, ONE PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) INCLUDE 'mumps_headers.h' IF ( MSGTAG .EQ. RACINE_SOLVE ) THEN NBFIN = NBFIN - 1 IF ( NBFIN .eq. 0 ) GOTO 270 ELSE IF (MSGTAG .EQ. ContVec ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LONG, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 IF ( NCB .eq. 0 ) THEN PTRICB(STEP(FINODE)) = -1 ELSE IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN PTRICB(STEP(FINODE)) = NCB + 1 END IF IF ( ( POSIWCB - LONG ) .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = LONG GOTO 260 END IF IF ( POSWCB - PLEFTWCB + 1_8 .LT. & int(LONG,8) * int(NRHS_B,8)) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8+ & int(LONG,8) * int(NRHS_B,8), & INFO(2)) GOTO 260 END IF IF (LONG .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IWCB( 1 ), & LONG, MPI_INTEGER, COMM, IERR ) DO K = 1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PLEFTWCB ), & LONG, MPI_COMPLEX, COMM, IERR ) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1, LONG IPOSINRHSINTR= abs(POSINRHSINTR_FWD(IWCB(I))) RHSINTR(IPOSINRHSINTR,JBDEB+K-1) = & RHSINTR(IPOSINRHSINTR,JBDEB+K-1) + & WCB(PLEFTWCB+I-1) ENDDO END DO PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - LONG ENDIF END IF IF ( PTRICB(STEP(FINODE)) == 1 .OR. & PTRICB(STEP(FINODE)) == -1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 PTRICB(STEP(FINODE)) = 0 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) & 'Internal error 1 CMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() END IF ENDIF ELSEIF ( MSGTAG .EQ. Master2Slave ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPIV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 PTRY = PLEFTWCB PTRX = PLEFTWCB + int(NCV,8) * int(NRHS_B,8) PLEFTWCB = PLEFTWCB + int(NPIV + NCV,8) * int(NRHS_B,8) IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(-POSWCB+PLEFTWCB-1_8,INFO(2)) GO TO 260 END IF DO K=1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PTRY + (K-1) * NCV ), NCV, & MPI_COMPLEX, COMM, IERR ) ENDDO IF ( NPIV .GT. 0 ) THEN DO K=1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PTRX + (K-1)*NPIV ), NPIV, & MPI_COMPLEX, COMM, IERR ) END DO END IF LR_ACTIVATED = (IW(PTRIST(STEP(FINODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(FINODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_SOLVE_GET_OOC_NODE( & FINODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,DUMMY,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF IF ( IW(PTRIST(STEP(FINODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(FINODE))+XXF) MTYPE_SLAVE = 1 CALL CMUMPS_SOL_SLAVE_LR_U( FINODE, IWHDLR, & -9999, & WCB, LWCB, & NPIV, NCV, & PTRX, PTRY, & JBDEB, JBFIN, & MTYPE_SLAVE, KEEP, KEEP8, & INFO(1), INFO(2) ) ELSE APOS = PTRFAC(STEP(FINODE)) IF (KEEP(201) .EQ. 1) THEN MTYPE_SLAVE = 0 LDA_SLAVE = NCV ELSE MTYPE_SLAVE = 1 LDA_SLAVE = NPIV ENDIF CALL CMUMPS_SOLVE_GEMM_UPDATE & ( A, LA, APOS, NPIV, & LDA_SLAVE, & NCV, & NRHS_B, WCB, LWCB, & PTRX, NPIV, & PTRY, NCV, & MTYPE_SLAVE, KEEP, ONE ) ENDIF IF ((KEEP(201).GT.0).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_FREE_FACTORS_FOR_SOLVE(FINODE,PTRFAC, & KEEP(28),A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF PLEFTWCB = PLEFTWCB - int(NPIV,8) * int(NRHS_B,8) PDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & KEEP(199) ) IF ( PDEST .EQ. MYID ) THEN IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN NCB = IW( PTRIST(STEP(FINODE)) + 2 + KEEP(IXSZ) ) PTRICB(STEP(FINODE)) = NCB + 1 END IF J1 = PTRIST(STEP(FINODE))+3+KEEP(IXSZ) OMP_FLAG = .FALSE. !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (NCV*(JBFIN-JBDEB+1) .GE. KEEP(363) ) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(I,JJ,IFR8,IPOSINRHSINTR) DO K=1, NRHS_B IFR8 = PTRY+int(K-1,8)*int(NCV,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1,NCV JJ = IW(J1+I) IPOSINRHSINTR= abs(POSINRHSINTR_FWD(JJ)) RHSINTR(IPOSINRHSINTR,JBDEB+K-1)= & RHSINTR(IPOSINRHSINTR,JBDEB+K-1) & + WCB(IFR8+int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K=1, NRHS_B IFR8 = PTRY+int(K-1,8)*int(NCV,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1,NCV JJ = IW(J1+I) IPOSINRHSINTR= abs(POSINRHSINTR_FWD(JJ)) RHSINTR(IPOSINRHSINTR,JBDEB+K-1)= & RHSINTR(IPOSINRHSINTR,JBDEB+K-1) & + WCB(IFR8+int(I-1,8)) ENDDO ENDDO ENDIF PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - NCV IF ( PTRICB( STEP( FINODE ) ) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 PTRICB(STEP(FINODE)) = 0 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) & 'INTERNAL Error in CMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() END IF ENDIF ELSE 210 CONTINUE CALL CMUMPS_BUF_SEND_VCB( NRHS_B, FINODE, FPERE, & IW(PTRIST(STEP( FINODE )) + 2 + KEEP(IXSZ) ), NCV,NCV, & IW(PTRIST(STEP(FINODE))+4+ KEEP(IXSZ) ), & WCB( PTRY ), JBDEB, JBFIN, & RHSINTR, 1, 1, -9999, -9999, & KEEP, PDEST, ContVec, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 210 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + & NCV * KEEP( 35 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + & NCV * KEEP( 35 ) END IF END IF PLEFTWCB = PLEFTWCB - int(NCV,8) * int(NRHS_B,8) ELSEIF ( MSGTAG .EQ. TERREUR ) THEN INFO(1) = -001 INFO(2) = MSGSOU GOTO 270 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. & (MSGTAG.EQ.TAG_DUMMY) ) THEN GO TO 270 ELSE INFO(1)=-100 INFO(2)=MSGTAG GO TO 260 ENDIF GO TO 270 260 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 270 CONTINUE RETURN END SUBROUTINE CMUMPS_TRAITER_MESSAGE_SOLVE SUBROUTINE CMUMPS_SOLVE_NODE_FWD( INODE, & LASTFSL0STA, LASTFSL0DYN, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, & IWCB, LIWCB, & WCB, LWCB, A, LA, IW, LIW, & NRHS, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & ) USE CMUMPS_SOL_LR !$ USE MUMPS_SOL_L0OMP_M, ONLY: LOCK_FOR_SCATTER USE MUMPS_SOL_L0OMP_M, ONLY: NB_LOCK_MAX USE CMUMPS_OOC USE CMUMPS_BUF IMPLICIT NONE INTEGER MTYPE INTEGER, INTENT( IN ) :: INODE, LASTFSL0STA, LASTFSL0DYN INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER LIWCB, LIW, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB, LWCB INTEGER(8) :: LA INTEGER N, LPOOL, LEAF, NBFIN INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S(KEEP(28)) INTEGER IWCB( LIWCB ), IW( LIW ) INTEGER NRHS COMPLEX WCB( LWCB ) COMPLEX :: A( LA ) INTEGER(8) :: LRHS_ROOT COMPLEX RHS_ROOT( LRHS_ROOT ) INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER FILS( N ), STEP( N ), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSINRHSINTR_FWD(N), LRHSINTR COMPLEX RHSINTR(LRHSINTR, NRHS) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP LOGICAL, intent(out) :: ERROR_WAS_BROADCASTED EXTERNAL cgemv, ctrsv, cgemm, ctrsm, MUMPS_PROCNODE INTEGER MUMPS_PROCNODE COMPLEX ALPHA,ONE,ZERO PARAMETER (ZERO=(0.0E0,0.0E0), & ONE=(1.0E0,0.0E0), & ALPHA=(-1.0E0,0.0E0)) INTEGER :: IWHDLR INTEGER JBDEB, JBFIN, NRHS_B INTEGER LDADIAG INTEGER(8) :: APOS, APOS1, IFR8, IFR_ini8 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, FPERE_MAPPING, & NPIV, NCB, LIELL, JJ, NELIM, IERR INTEGER(8) :: PCB_COURANT, PPIV_COURANT, PPIV_PANEL, PCB_PANEL INTEGER IPOSINRHSINTR_TMP INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex LOGICAL FLAG INTEGER :: NUPDATE_NONCRITICAL, IPOSINRHSINTRLASTFSDYN LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSDEB INTEGER TempNROW, TempNCOL, PANEL_SIZE, & JFIN, NBJ, NUPDATE_PANEL, & TYPEF INTEGER LD_WCBPIV INTEGER LD_WCBCB LOGICAL :: LDEQLIELLPANEL LOGICAL :: CBINITZERO INTEGER LDAJ, LDAJ_FIRST_PANEL INTEGER LDAtemp LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPANEL LOGICAL MUST_BE_PERMUTED INTEGER :: SIZEBLOCK, NB, JCourant, NB_LOCK INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' ERROR_WAS_BROADCASTED = .FALSE. LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IF (DO_NBSPARSE) THEN JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) JBFIN= RHS_BOUNDS(2*STEP(INODE)) ELSE JBDEB = 1 JBFIN = NRHS ENDIF NRHS_B = JBFIN-JBDEB+1 IF (DO_NBSPARSE) THEN if (JBDEB.GT.JBFIN) then write(6,*) " Internal error 1 in nbsparse :", & JBDEB, JBFIN CALL MUMPS_ABORT() endif IF (JBDEB.LT.1 .OR. JBDEB.GT.NRHS .or. & JBFIN.LT.1 .OR. JBFIN.GT.NRHS ) THEN write(6,*) " Internal error 2 in nbsparse :", & JBDEB, JBFIN CALL MUMPS_ABORT() endif ENDIF IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq.KEEP( 20 ) ) THEN LIELL = IW( PTRIST( STEP(INODE)) + 3 + KEEP(IXSZ)) NPIV = LIELL NELIM = 0 NSLAVES = 0 IPOS = PTRIST( STEP(INODE)) + 5 + KEEP(IXSZ) ELSE IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 NPIV = IW(IPOS) IPOS = IPOS + 1 IF ((KEEP(201).GT.0).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL CMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL+1+NSLAVES), & MUST_BE_PERMUTED ) ENDIF ENDIF NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IPOS = IPOS + 1 + NSLAVES END IF IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J2 = IPOS + LIELL J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J2 = IPOS + 2 * LIELL J3 = IPOS + LIELL + NPIV END IF NCB = LIELL-NPIV IF (KEEP(50).NE.0) THEN IF ( KEEP(459) .GT. 1 ) THEN LDADIAG = -99999 ELSE LDADIAG = NPIV ENDIF ELSE LDADIAG = LIELL ENDIF IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq. KEEP(20) ) THEN IFR8 = 0_8 IPOSINRHSINTR_TMP = POSINRHSINTR_FWD(IW(J1)) IFR_ini8 = IFR8 OMP_FLAG = .FALSE. !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(IFR8,JJ) DO K=1,NRHS IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 RHS_ROOT(IFR8+int(JJ-J1+1,8)) = & RHSINTR(IPOSINRHSINTR_TMP+JJ-J1,K) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K=1,NRHS IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 RHS_ROOT(IFR8+int(JJ-J1+1,8)) = & RHSINTR(IPOSINRHSINTR_TMP+JJ-J1,K) ENDDO ENDDO ENDIF IF ( NPIV .LT. LIELL ) THEN WRITE(*,*) ' Internal error 1 in CMUMPS_SOLVE_NODE_FWD', & NPIV, LIELL CALL MUMPS_ABORT() END IF GO TO 270 END IF APOS = PTRFAC(STEP(INODE)) IF ( (KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR ) THEN IF (MTYPE.EQ.1) THEN IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN TempNROW= NPIV+NELIM TempNCOL= NPIV LDAJ_FIRST_PANEL=TempNROW ELSE TempNROW= LIELL TempNCOL= NPIV LDAJ_FIRST_PANEL=TempNROW ENDIF TYPEF=TYPEF_L ELSE TempNCOL= LIELL TempNROW= NPIV LDAJ_FIRST_PANEL=TempNCOL TYPEF= TYPEF_U ENDIF PANEL_SIZE = CMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) ENDIF PPIV_COURANT = PLEFTWCB PLEFTWCB = PLEFTWCB + int(LIELL,8) * int(NRHS_B,8) IF ( POSWCB - PLEFTWCB + 1_8 .LT. 0 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8, INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF IF (KEEP(201) .EQ. 1 .AND. OOCWRITE_COMPATIBLE_WITH_BLR) THEN LDEQLIELLPANEL = .TRUE. LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV ELSE LDEQLIELLPANEL = .FALSE. LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + int(NPIV,8)*int(NRHS_B,8) ENDIF FPERE = DAD(STEP(INODE)) IF ( FPERE .NE. 0 ) THEN FPERE_MAPPING = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & KEEP(199) ) ELSE FPERE_MAPPING = -1 ENDIF IF ( LASTFSL0DYN .LE. N ) THEN CBINITZERO = .TRUE. ELSE IF ( FPERE_MAPPING .EQ. MYID ) THEN CBINITZERO = .TRUE. ELSE CBINITZERO = .FALSE. ENDIF CALL CMUMPS_RHSINTR_TO_WCB( & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL, & RHSINTR(1, JBDEB), LRHSINTR, NRHS_B, & POSINRHSINTR_FWD, N, & WCB(PPIV_COURANT), & IW, LIW, J1, J3, J2, KEEP, DKEEP) IF ( NPIV .NE. 0 ) THEN IF ((KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN APOSDEB = APOS J = 1 IPANEL = 0 10 CONTINUE IPANEL = IPANEL + 1 JFIN = min(J+PANEL_SIZE-1, NPIV) IF (IW(IPOS+ LIELL + JFIN) < 0) THEN JFIN=JFIN+1 ENDIF NBJ = JFIN-J+1 LDAJ = LDAJ_FIRST_PANEL-J+1 IF ( (KEEP(50).NE.1).AND. MUST_BE_PERMUTED ) THEN CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS+1+2*LIELL, IW, LIW) IF (NPIV.EQ.(IW(I_PIVRPTR+IPANEL-1)-1)) THEN MUST_BE_PERMUTED=.FALSE. ELSE CALL CMUMPS_PERMUTE_PANEL( & IW( I_PIVR+ IW(I_PIVRPTR+IPANEL-1)- & IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, J-1 ) ENDIF ENDIF NUPDATE_PANEL = LDAJ - NBJ PPIV_PANEL = PPIV_COURANT+int(J-1,8) PCB_PANEL = PPIV_PANEL+int(NBJ,8) APOS1 = APOSDEB+int(NBJ,8) IF (MTYPE.EQ.1) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ctrsv( 'L', 'N', 'U', NBJ, A(APOSDEB), LDAJ, & WCB(PPIV_PANEL), 1 ) IF (NUPDATE_PANEL.GT.0) THEN CALL cgemv('N', NUPDATE_PANEL,NBJ,ALPHA, A(APOS1), & LDAJ, WCB(PPIV_PANEL), 1, ONE, & WCB(PCB_PANEL), 1) ENDIF ELSE #endif CALL ctrsm( 'L','L','N','U', NBJ, NRHS_B, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL ) IF (NUPDATE_PANEL.GT.0) THEN CALL cgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF (NRHS_B == 1) THEN CALL ctrsv( 'L', 'N', 'N', NBJ, A(APOSDEB), LDAJ, & WCB(PPIV_PANEL), 1 ) IF (NUPDATE_PANEL.GT.0) THEN CALL cgemv('N',NUPDATE_PANEL, NBJ, ALPHA, A(APOS1), & LDAJ, WCB(PPIV_PANEL), 1, & ONE, WCB(PCB_PANEL), 1 ) ENDIF ELSE #endif CALL ctrsm('L','L','N','N',NBJ, NRHS_B, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL) IF (NUPDATE_PANEL.GT.0) THEN CALL cgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF APOSDEB = APOSDEB+int(LDAJ,8)*int(NBJ,8) J=JFIN+1 IF ( J .LE. NPIV ) GOTO 10 ELSE IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL CMUMPS_SOL_FWD_LR_SU ( & INODE, N, IWHDLR, NPIV, NSLAVES, & IW, IPOS, LIW, & LIELL, WCB, LWCB, & LD_WCBPIV, LD_WCBCB, & PPIV_COURANT, PCB_COURANT, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, KEEP8, OOCWRITE_COMPATIBLE_WITH_BLR, & INFO(1), INFO(2) ) IF (INFO(1).LT.0) THEN ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF ELSE IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 ) THEN CALL CMUMPS_SOLVE_FWD_PANELS( & A, LA, APOS, & NPIV, IW(IPOS+LIELL+1), & NRHS_B, WCB, LWCB, LD_WCBPIV, & PPIV_COURANT, MTYPE, KEEP) ELSE CALL CMUMPS_SOLVE_FWD_TRSOLVE ( & A, LA, APOS, & NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LD_WCBPIV, & PPIV_COURANT, MTYPE, KEEP) ENDIF END IF END IF NCB = LIELL - NPIV IF ( MTYPE .EQ. 1 ) THEN IF ( NSLAVES .EQ. 0 .OR. NPIV .eq. 0 ) THEN NUPDATE = NCB ELSE NUPDATE = NELIM END IF IF (KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0) THEN CALL MUMPS_GETI8(APOS1, IW(PTRIST(STEP(INODE))+XXR)) APOS1 = APOS + APOS1 - int(NPIV,8)*int(NUPDATE,8) ELSE APOS1 = APOS + int(NPIV,8) * int(LDADIAG,8) ENDIF ELSE APOS1 = APOS + int(NPIV,8) NUPDATE = NCB END IF IF (KEEP(201).NE.1) THEN IF ( IW(PTRIST(STEP(INODE))+XXLR) .LT. 2 .OR. & KEEP(485).EQ.0) THEN IF (MTYPE .EQ. 1) THEN LDAtemp = NPIV ELSE LDAtemp = LIELL ENDIF CALL CMUMPS_SOLVE_GEMM_UPDATE & (A, LA, APOS1, & NPIV, LDAtemp, NUPDATE, & NRHS_B, WCB, LWCB, PPIV_COURANT, LD_WCBPIV, & PCB_COURANT, LD_WCBCB, & MTYPE, KEEP, ONE) ENDIF END IF IF ( IW(PTRIST(STEP(INODE))+XXLR) .LT. 2 .OR. & KEEP(485).EQ.0) THEN IF (KEEP(201) .GT. 0 .AND. OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_SOL_LD_AND_RELOAD( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & .FALSE. & ) ELSE CALL CMUMPS_SOL_LD_AND_RELOAD_PANEL ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & .FALSE. & ) ENDIF ENDIF IF ((KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR) &THEN CALL CMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF END IF IF ( FPERE .EQ. 0 ) THEN PLEFTWCB = PLEFTWCB - int(LIELL,8) *int(NRHS_B,8) GOTO 270 ENDIF IF ( NUPDATE .NE. 0 .OR. NCB.EQ.0 ) THEN IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID) THEN IF ( NCB .ne. 0 ) THEN PTRICB(STEP(INODE)) = NCB + 1 NUPDATE_NONCRITICAL = NUPDATE IF (LASTFSL0DYN .LE. N) THEN IF ( LASTFSL0DYN .EQ. 0 ) THEN IPOSINRHSINTRLASTFSDYN = 0 ELSE IPOSINRHSINTRLASTFSDYN = & abs(POSINRHSINTR_FWD(LASTFSL0DYN)) ENDIF DO I = 1, NUPDATE IF ( abs(POSINRHSINTR_FWD( IW(J3+I) )) .GT. & IPOSINRHSINTRLASTFSDYN ) THEN IF (abs(STEP(IW(J3+I))) .GT. & abs(STEP( LASTFSL0STA)) & .OR. KEEP(261) .NE. 1) THEN NUPDATE_NONCRITICAL = I - 1 EXIT ENDIF ENDIF ENDDO ENDIF OMP_FLAG = .FALSE. !$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND. !$ & (NUPDATE*NRHS_B .GE. KEEP(363)) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(I,IFR8,IPOSINRHSINTR_TMP) DO K = JBDEB, JBFIN IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1, NUPDATE_NONCRITICAL IPOSINRHSINTR_TMP = & abs(POSINRHSINTR_FWD(IW(J3 + I))) RHSINTR( IPOSINRHSINTR_TMP, K ) = & RHSINTR( IPOSINRHSINTR_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K = JBDEB, JBFIN IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = 1, NUPDATE_NONCRITICAL IPOSINRHSINTR_TMP = & abs(POSINRHSINTR_FWD(IW(J3 + I))) RHSINTR( IPOSINRHSINTR_TMP, K ) = & RHSINTR( IPOSINRHSINTR_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO ENDIF IF ( CBINITZERO ) THEN IF ( NUPDATE .NE. NUPDATE_NONCRITICAL) THEN NB_LOCK = 1 IF ( KEEP(400) .GT. 1 ) THEN NB_LOCK = min(KEEP(400),NB_LOCK_MAX) ENDIF SIZEBLOCK = (NRHS+NB_LOCK-1) / NB_LOCK DO NB = 1 + (JBDEB-1)/SIZEBLOCK, NB_LOCK JCourant = 1+SIZEBLOCK*(NB-1) IF ( JCourant .GT. JBFIN ) EXIT !$ CALL OMP_SET_LOCK(LOCK_FOR_SCATTER(NB)) DO K = max(Jcourant,JBDEB), & min(JBFIN,Jcourant+SIZEBLOCK-1) IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) #if defined(__ve__) !NEC$ IVDEP #endif DO I = NUPDATE_NONCRITICAL+1, NUPDATE IPOSINRHSINTR_TMP = & abs(POSINRHSINTR_FWD(IW(J3 + I))) RHSINTR( IPOSINRHSINTR_TMP, K ) = & RHSINTR( IPOSINRHSINTR_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO !$ CALL OMP_UNSET_LOCK(LOCK_FOR_SCATTER(NB)) ENDDO ENDIF ENDIF PTRICB(STEP( INODE )) = PTRICB(STEP( INODE )) - NUPDATE ELSE PTRICB(STEP( INODE )) = -1 ENDIF ELSE 210 CONTINUE CALL CMUMPS_BUF_SEND_VCB( NRHS_B, INODE, FPERE, & NCB, LD_WCBCB, & NUPDATE, & IW( J3 + 1 ), WCB( PCB_COURANT ), JBDEB, JBFIN, & RHSINTR, 1, 1, -9999, -9999, & KEEP, & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), KEEP(199)), & ContVec, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. GOTO 270 ENDIF GOTO 210 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF ENDIF END IF IF ( NSLAVES .NE. 0 .AND. MTYPE .eq. 1 & .and. NPIV .NE. 0 ) THEN DO ISLAVE = 1, NSLAVES PDEST = IW( PTRIST(STEP(INODE)) + 5 + ISLAVE +KEEP(IXSZ)) CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB - NELIM, & NSLAVES, & Effective_CB_Size, FirstIndex ) 222 CONTINUE CALL CMUMPS_BUF_SEND_MASTER2SLAVE( NRHS_B, & INODE, FPERE, & Effective_CB_Size, LD_WCBCB, LD_WCBPIV, NPIV, & JBDEB, JBFIN, & WCB( PCB_COURANT + NELIM + FirstIndex - 1 ), & WCB( PPIV_COURANT ), & PDEST, COMM, KEEP, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. GOTO 270 ENDIF GOTO 222 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF END DO END IF PLEFTWCB = PLEFTWCB - int(LIELL,8)*int(NRHS_B,8) 270 CONTINUE RETURN END SUBROUTINE CMUMPS_SOLVE_NODE_FWD RECURSIVE SUBROUTINE CMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) IMPLICIT NONE LOGICAL BLOQ INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER N, NRHS, LPOOL, LEAF, NBFIN INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ), IPOOL(LPOOL) INTEGER NSTK_S( KEEP(28) ) INTEGER IWCB( LIWCB ) INTEGER IW( LIW ) COMPLEX WCB( LWCB ), A( LA ) INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)) LOGICAL FLAG INTEGER LRHSINTR, POSINRHSINTR_FWD(N) COMPLEX RHSINTR(LRHSINTR,NRHS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGSOU, MSGTAG, MSGLEN FLAG = .FALSE. IF ( BLOQ ) THEN FLAG = .FALSE. CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF ( FLAG ) THEN KEEP(266) = KEEP(266) -1 MSGSOU = STATUS( MPI_SOURCE ) MSGTAG = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN INFO(1) = -20 INFO(2) = MSGLEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ELSE CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, & MSGSOU, MSGTAG, COMM, STATUS, IERR ) CALL CMUMPS_TRAITER_MESSAGE_SOLVE( BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) END IF END IF RETURN END SUBROUTINE CMUMPS_SOLVE_RECV_AND_TREAT SUBROUTINE CMUMPS_RHSINTR_TO_WCB( & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL, & RHSINTR, LRHSINTR, NRHS_B, & POSINRHSINTR_FWD, N, & WCB, & IW, LIW, J1, J3, J2, KEEP, DKEEP) IMPLICIT NONE INTEGER, INTENT( IN ) :: NPIV, NCB, LIELL, N, & LRHSINTR, NRHS_B, & LIW, J1, J2, J3 LOGICAL, INTENT( IN ) :: LDEQLIELLPANEL LOGICAL, INTENT( IN ) :: CBINITZERO INTEGER, INTENT( IN ) :: POSINRHSINTR_FWD( N ), IW( LIW ) COMPLEX, INTENT( INOUT ) :: RHSINTR( LRHSINTR, NRHS_B ) COMPLEX, INTENT( OUT ) :: WCB( int(LIELL,8)* & int(NRHS_B,8) ) INTEGER :: KEEP(500) REAL :: DKEEP(150) INTEGER, PARAMETER :: ZERO = (0.0E0,0.0E0) INTEGER(8), PARAMETER :: PPIV_COURANT = 1_8 INTEGER(8) :: PCB_COURANT INTEGER :: LD_WCBCB, LD_WCBPIV, J, JJ, K, IPOSINRHSINTR INTEGER(8) :: IFR8, IFR_ini8 INCLUDE 'mpif.h' LOGICAL :: OMP_FLAG IF ( LDEQLIELLPANEL ) THEN LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV ELSE LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + NPIV * NRHS_B ENDIF IF ( LDEQLIELLPANEL ) THEN DO K=1, NRHS_B IFR8 = PPIV_COURANT+int(K-1,8)*int(LD_WCBPIV,8)-1_8 IPOSINRHSINTR = POSINRHSINTR_FWD(IW(J1)) DO JJ = J1, J3 IFR8 = IFR8 + 1_8 WCB(IFR8) = RHSINTR(IPOSINRHSINTR,K) IPOSINRHSINTR = IPOSINRHSINTR + 1 ENDDO IF (NCB.GT.0 .AND. .NOT. CBINITZERO) THEN #if defined(__ve__) !NEC$ IVDEP #endif DO JJ = J3+1, J2 J = IW(JJ) IFR8 = IFR8 + 1_8 IPOSINRHSINTR = abs(POSINRHSINTR_FWD(J)) WCB(IFR8) = RHSINTR(IPOSINRHSINTR,K) RHSINTR (IPOSINRHSINTR,K) = ZERO ENDDO ENDIF ENDDO ELSE PCB_COURANT = PPIV_COURANT + LD_WCBPIV*NRHS_B IFR8 = PPIV_COURANT - 1_8 IFR_ini8 = IFR8 IPOSINRHSINTR = POSINRHSINTR_FWD(IW(J1)) OMP_FLAG = .FALSE. !$ OMP_FLAG = ( NRHS_B .GE. KEEP(362) .AND. !$ & int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(JJ,IFR8) DO K=1, NRHS_B IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 WCB(IFR8+int(JJ-J1+1,8)) = & RHSINTR(IPOSINRHSINTR+JJ-J1,K) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K=1, NRHS_B IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 WCB(IFR8+int(JJ-J1+1,8)) = & RHSINTR(IPOSINRHSINTR+JJ-J1,K) ENDDO ENDDO ENDIF IFR8 = PCB_COURANT - 1_8 IF (NCB.GT.0 .AND. .NOT. CBINITZERO) THEN IFR_ini8 = IFR8 OMP_FLAG = .FALSE. !$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND. !$ & NCB*NRHS_B .GE. KEEP(363) ) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE (IFR8, JJ, J, IPOSINRHSINTR) DO K=1, NRHS_B IFR8 = IFR_ini8+(K-1)*NCB #if defined(__ve__) !NEC$ IVDEP #endif DO JJ = J3 + 1, J2 J = IW(JJ) IPOSINRHSINTR = abs(POSINRHSINTR_FWD(J)) WCB(IFR8+int(JJ-J3,8)) = RHSINTR(IPOSINRHSINTR,K) RHSINTR(IPOSINRHSINTR,K)=ZERO ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K=1, NRHS_B IFR8 = IFR_ini8+(K-1)*NCB #if defined(__ve__) !NEC$ IVDEP #endif DO JJ = J3 + 1, J2 J = IW(JJ) IPOSINRHSINTR = abs(POSINRHSINTR_FWD(J)) WCB(IFR8+int(JJ-J3,8)) = RHSINTR(IPOSINRHSINTR,K) RHSINTR(IPOSINRHSINTR,K)=ZERO ENDDO ENDDO ENDIF ENDIF ENDIF IF ( CBINITZERO ) THEN OMP_FLAG = .FALSE. !$ OMP_FLAG = int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) IF (OMP_FLAG) THEN !$OMP PARALLEL DO COLLAPSE(2) DO K = 1, NRHS_B DO JJ = 1, NCB WCB(PCB_COURANT+int(K-1,8)*int(LD_WCBCB,8)+JJ-1_8) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K = 1, NRHS_B DO JJ = 1, NCB WCB(PCB_COURANT+int(K-1,8)*int(LD_WCBCB,8)+JJ-1_8) = ZERO ENDDO ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_RHSINTR_TO_WCB MUMPS_5.8.1/src/ana_omp_m.F0000664000175000017500000011145215042446423015272 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_ANA_OMP_M CONTAINS SUBROUTINE MUMPS_ANA_L0_OMP( NB_THREADS, N, NSTEPS, SYM, SLAVEF, & DAD, FRERE, FILS, NSTK_STEPS, ND, STEP, PROCNODE_STEPS, KEEP, & KEEP8, MYID_NODES, NA, LNA, ARITH, LPOOL_B_L0_OMP, & IPOOL_B_L0_OMP, LPOOL_A_L0_OMP, IPOOL_A_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP, PHYS_L0_OMP, PERM_L0_OMP, PTR_LEAFS_L0_OMP, & INFO, ICNTL ) USE MUMPS_IDLL USE MUMPS_DDLL IMPLICIT NONE INCLUDE 'mpif.h' INTEGER, INTENT ( IN ) :: NB_THREADS, N, NSTEPS, SYM INTEGER, INTENT ( IN ) :: SLAVEF, MYID_NODES INTEGER, INTENT ( IN ) :: LNA INTEGER, INTENT ( IN ) :: DAD (:), FRERE (:) INTEGER, INTENT ( IN ) :: FILS (:) INTEGER, INTENT ( IN ) :: NSTK_STEPS (:) INTEGER, INTENT ( IN ) :: ND (:), STEP (:) INTEGER, INTENT ( IN ) :: PROCNODE_STEPS(:) INTEGER, INTENT ( IN ) :: KEEP ( : ) INTEGER(8), INTENT ( IN ) :: KEEP8(:) INTEGER, INTENT ( IN ) :: NA ( : ) CHARACTER(1), INTENT(IN) :: ARITH INTEGER, INTENT ( OUT ) :: LPOOL_B_L0_OMP INTEGER, INTENT ( OUT ) :: LPOOL_A_L0_OMP INTEGER, INTENT ( OUT ) :: L_PHYS_L0_OMP INTEGER, INTENT ( OUT ) :: L_VIRT_L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_B_L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_A_L0_OMP INTEGER, DIMENSION(:), POINTER :: PHYS_L0_OMP INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP, VIRT_L0_OMP_MAPPING INTEGER, DIMENSION(:), POINTER :: PERM_L0_OMP INTEGER, DIMENSION(:), POINTER :: PTR_LEAFS_L0_OMP INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(IN) :: ICNTL(60) LOGICAL :: LPOK INTEGER :: LP INTEGER :: NB_REPEAT_ACCEPTL0, NB_MAX_IN_L0_ACCEPTL0, & NB_IN_L0 DOUBLE PRECISION :: SMALL_COST INTEGER :: THRESH_MEM, SLAVEF_DURING_MAPPING REAL :: THRESH_EQUILIB DOUBLE PRECISION, DIMENSION(1,1,1) :: BENCH INTEGER :: INODE INTEGER :: NBLEAF_MYID DOUBLE PRECISION :: COST_UNDER, COST_ABOVE, COST_TOTAL_BEST DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: THREADS_CHARGE DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: COSTS_MONO_THREAD DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: COSTS_MULTI_THREAD INTEGER , DIMENSION(:), ALLOCATABLE :: IPOOL_B_INV INTEGER(8) :: FACTOR_SIZE_UNDER_L0, FACTOR_SIZE_PER_MPI INTEGER, DIMENSION(:), ALLOCATABLE :: CP_NSTK_STEPS TYPE ( IDLL_T ), POINTER :: L0_OMP_DLL TYPE ( IDLL_T ), POINTER :: LEAFS_ABOVE_L0_OMP_DLL INTEGER :: I THRESH_EQUILIB = real(KEEP(408))/real(100) IF ((THRESH_EQUILIB.GT..99).OR.(THRESH_EQUILIB.LT.0.01)) THEN THRESH_EQUILIB = 0.9 ENDIF THRESH_MEM = KEEP(397) IF ((THRESH_MEM.LT.-1).OR.(THRESH_MEM.GT.100)) THRESH_MEM=100 IF (THRESH_MEM.EQ.-1) THEN IF (NB_THREADS.EQ.2) THEN THRESH_MEM = 50 ELSEIF (NB_THREADS.LE.4) THEN THRESH_MEM = 60 ELSEIF (NB_THREADS.LE.8) THEN THRESH_MEM = 70 ELSEIF (NB_THREADS.LE.12) THEN THRESH_MEM = 80 ELSEIF (NB_THREADS.LE.20) THEN THRESH_MEM = 85 ELSEIF (NB_THREADS.LE.36) THEN THRESH_MEM = 90 ELSE THRESH_MEM = 95 ENDIF ENDIF SLAVEF_DURING_MAPPING = SLAVEF FACTOR_SIZE_PER_MPI = KEEP8(101) / SLAVEF_DURING_MAPPING IF ( KEEP(261) .EQ. 0) THEN WRITE(*,*)"KEEP(261) MUST BE SET TO 1 IN ORDER TO USE & MULTITHREADED TREE PARALLELISM" CALL MUMPS_ABORT() END IF LP = ICNTL(1) LPOK = ( LP .GT. 0 .AND. ICNTL(4) .GE.1 ) NB_REPEAT_ACCEPTL0 = -1 NB_MAX_IN_L0_ACCEPTL0 = -1 CALL MUMPS_ANA_INITIALIZE_L0_OMP () IF (INFO(1) .LT. 0) GOTO 500 DO WHILE ( .NOT. MUMPS_ANA_ACCEPT_L0_OMP () ) IF (INFO(1) .LT. 0) GOTO 500 CALL L0_REMOVE_NODE ( INODE ) IF (INODE .LT. 0) THEN IPOOL_B_L0_OMP(IPOOL_B_INV(STEP(-INODE))) = INODE ELSE CALL L0_INSERT_CHILDREN ( INODE ) END IF END DO CALL MUMPS_ANA_FINALIZE_L0_OMP () 500 CONTINUE CALL MUMPS_ANA_FREE_L0_WORKSPACE() RETURN CONTAINS SUBROUTINE MUMPS_ANA_INITIALIZE_L0_OMP ( ) IMPLICIT NONE INTEGER :: INODE, IFATH, IGRANDFATH, SPECIAL_ROOT, & NFRONT, NPIV, LEAF, VARNUM, IERR LOGICAL :: INODE_IS_A_LEAF INTEGER(8) :: NFRONT8, NPIV8 DOUBLE PRECISION :: COST_NODE, SMALL_COST_TMP LOGICAL :: IN_L0INIT, SKIP_ABOVE LOGICAL, EXTERNAL :: MUMPS_ROOTSSARBR, MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_GET_POOL_LENGTH, MUMPS_TYPENODE IF (associated(IPOOL_B_L0_OMP)) THEN WRITE(*,*) " Internal error 1 MUMPS_ANA_INITIALIZE_L0_OMP" CALL MUMPS_ABORT() ENDIF IF (associated(IPOOL_A_L0_OMP)) THEN WRITE(*,*) " Internal error 2 MUMPS_ANA_INITIALIZE_L0_OMP" CALL MUMPS_ABORT() ENDIF IF (associated(VIRT_L0_OMP)) THEN WRITE(*,*) " Internal error 3 MUMPS_ANA_INITIALIZE_L0_OMP" CALL MUMPS_ABORT() ENDIF IF (associated(VIRT_L0_OMP_MAPPING)) THEN WRITE(*,*) " Internal error 4 MUMPS_ANA_INITIALIZE_L0_OMP" CALL MUMPS_ABORT() ENDIF IF (associated(PERM_L0_OMP)) THEN WRITE(*,*) " Internal error 5 MUMPS_ANA_INITIALIZE_L0_OMP" CALL MUMPS_ABORT() ENDIF IF (associated(PTR_LEAFS_L0_OMP)) THEN WRITE(*,*) " Internal error 6 MUMPS_ANA_INITIALIZE_L0_OMP" CALL MUMPS_ABORT() ENDIF IERR = IDLL_CREATE ( L0_OMP_DLL ) NB_IN_L0 = 0 IF (KEEP(72).eq.1) THEN SMALL_COST = 2.0D0 ELSE SMALL_COST = 100.0D0 ENDIF SMALL_COST_TMP = 0.0D0 IERR = IDLL_CREATE ( LEAFS_ABOVE_L0_OMP_DLL ) ALLOCATE( THREADS_CHARGE( NB_THREADS ), stat=IERR ) IF (IERR .GT. 0) THEN INFO(1) = -7 INFO(2) = NB_THREADS IF (LPOK) WRITE(LP,150) 'THREADS_CHARGE' GOTO 500 ENDIF ALLOCATE( COSTS_MONO_THREAD ( NSTEPS ), stat=IERR ) IF(IERR.GT.0) THEN INFO(1) = -7 INFO(2) = NSTEPS IF (LPOK) WRITE(LP, 150) ' COSTS_MONO_THREAD' GOTO 500 ENDIF IF (KEEP(403) .NE. 0) THEN ALLOCATE( COSTS_MULTI_THREAD ( NSTEPS ), stat=IERR ) IF(IERR.GT.0) THEN INFO(1) = -7 INFO(2) = NSTEPS IF (LPOK) WRITE(LP, 150) ' COSTS_MULTI_THREAD' GOTO 500 ENDIF ENDIF ALLOCATE( IPOOL_B_INV ( NSTEPS ), stat=IERR ) IF(IERR.GT.0) THEN INFO(1) = -7 INFO(2) = NSTEPS IF (LPOK) WRITE(LP, 150) ' IPOOL_B_INV' GOTO 500 ENDIF ALLOCATE( CP_NSTK_STEPS ( NSTEPS ), stat=IERR ) IF(IERR.GT.0) THEN INFO(1) = -7 INFO(2) = NSTEPS IF (LPOK) WRITE(LP, 150) ' CP_NSTK_STEPS' GOTO 500 ENDIF LPOOL_B_L0_OMP=MUMPS_GET_POOL_LENGTH(NA(1),KEEP(1),KEEP8(1)) ALLOCATE( IPOOL_B_L0_OMP( LPOOL_B_L0_OMP) , stat=IERR ) IF(IERR.GT.0) THEN INFO(1) = -7 INFO(2) = NSTEPS IF (LPOK) WRITE(LP, 150) ' id%IPOOL_B_L0_OMP' GOTO 500 ENDIF COSTS_MONO_THREAD = 0.0D0 IF (KEEP(403) .NE. 0) THEN COSTS_MULTI_THREAD = 0.0D0 COST_UNDER = 0.0D0 COST_ABOVE = 0.0D0 COST_TOTAL_BEST = huge(COST_TOTAL_BEST) ENDIF FACTOR_SIZE_UNDER_L0 = 0_8 CP_NSTK_STEPS(:) = NSTK_STEPS(:) IF (KEEP(403).NE.0) THEN CALL READ_BENCH( ARITH, KEEP(50) ) ENDIF CALL MUMPS_INIT_POOL_DIST(N, LEAF, & MYID_NODES, & KEEP(199), NA(1), LNA, & KEEP(1), KEEP8(1), STEP(1), & PROCNODE_STEPS(1), & IPOOL_B_L0_OMP(1), LPOOL_B_L0_OMP) DO I = 1, LEAF - 1 IPOOL_B_INV(STEP(IPOOL_B_L0_OMP(I))) = I ENDDO LEAF = LEAF - 1 NBLEAF_MYID = LEAF IF (NBLEAF_MYID .EQ. 0) THEN RETURN ENDIF 90 CONTINUE INODE = IPOOL_B_L0_OMP ( LEAF ) LEAF = LEAF - 1 INODE_IS_A_LEAF=.TRUE. 95 CONTINUE NFRONT = ND ( STEP ( INODE ) ) NFRONT8= int(NFRONT,8) NPIV = 0 VARNUM = INODE DO WHILE (VARNUM .GT. 0 ) NPIV = NPIV + 1 VARNUM = FILS ( VARNUM ) END DO NPIV8=int(NPIV,8) VARNUM = - VARNUM IF (KEEP(403) .EQ. 0) THEN CALL MUMPS_GET_FLOPS_COST ( NFRONT, NPIV, NPIV, & SYM, 1, COST_NODE ) COSTS_MONO_THREAD ( STEP ( INODE ) ) = COST_NODE ELSE CALL COST_BENCH (NPIV, NFRONT-NPIV, 1, KEEP(50), COST_NODE) COSTS_MONO_THREAD ( STEP ( INODE ) ) = COST_NODE CALL COST_BENCH (NPIV,NFRONT-NPIV,NB_THREADS,KEEP(50),COST_NODE) COSTS_MULTI_THREAD ( STEP ( INODE ) ) = COST_NODE END IF DO WHILE (VARNUM .GT. 0 ) COSTS_MONO_THREAD ( STEP ( INODE ) ) = & COSTS_MONO_THREAD ( STEP ( INODE ) ) & + & COSTS_MONO_THREAD ( STEP ( VARNUM ) ) VARNUM = FRERE ( STEP ( VARNUM ) ) END DO IFATH = DAD ( STEP ( INODE ) ) IF (IFATH .NE. 0) THEN IGRANDFATH = DAD( STEP ( IFATH ) ) ELSE IGRANDFATH = 0 ENDIF SPECIAL_ROOT = max(KEEP(38), KEEP(20)) SKIP_ABOVE = .FALSE. IN_L0INIT = .FALSE. IF ( INODE .EQ. SPECIAL_ROOT ) THEN IN_L0INIT = .FALSE. IF (INODE_IS_A_LEAF) THEN SKIP_ABOVE = .TRUE. GOTO 80 ELSE WRITE(*,*) " Internal error 1 in MUMPS_ANA_INITIALIZE_L0_OMP", & INODE, SPECIAL_ROOT CALL MUMPS_ABORT() ENDIF ENDIF IF ( IFATH .NE. 0 .AND. IFATH .EQ. KEEP(38) ) THEN IN_L0INIT = .FALSE. IF (INODE_IS_A_LEAF) THEN SKIP_ABOVE = .TRUE. GOTO 80 ELSE WRITE(*,*) " Internal error 2 in MUMPS_ANA_INITIALIZE_L0_OMP", & INODE, IFATH, KEEP(38) CALL MUMPS_ABORT() ENDIF ENDIF IF ( SLAVEF_DURING_MAPPING > 1 ) THEN IF (MUMPS_ROOTSSARBR ( & PROCNODE_STEPS ( STEP ( INODE ) ), KEEP(199) ) & .OR. .NOT. MUMPS_IN_OR_ROOT_SSARBR ( & PROCNODE_STEPS ( STEP ( INODE ) ), KEEP(199) ) &) THEN IN_L0INIT = .FALSE. IF (INODE_IS_A_LEAF) THEN SKIP_ABOVE = .TRUE. GOTO 80 ELSE WRITE(*,*) & " Internal error 3 in MUMPS_ANA_INITIALIZE_L0_OMP", & INODE CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (IFATH.NE.0) THEN IF ( MUMPS_TYPENODE(STEP(IFATH),KEEP(199)).EQ.2) THEN IN_L0INIT = .FALSE. IF (INODE_IS_A_LEAF) THEN SKIP_ABOVE = .TRUE. GOTO 80 ELSE WRITE(*,*) & " Internal error 5 in MUMPS_ANA_INITIALIZE_L0_OMP", & INODE, IFATH CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF ( MUMPS_TYPENODE(STEP(INODE),KEEP(199)).EQ.2) THEN IN_L0INIT = .FALSE. IF (INODE_IS_A_LEAF) THEN SKIP_ABOVE = .TRUE. GOTO 80 ELSE WRITE(*,*) & " Internal error 6 in MUMPS_ANA_INITIALIZE_L0_OMP", & INODE CALL MUMPS_ABORT() ENDIF ENDIF IF ( IFATH .EQ. 0 ) THEN IN_L0INIT = .TRUE. GOTO 80 ELSE IF ( IFATH .EQ. KEEP(20) ) THEN IN_L0INIT = .TRUE. GOTO 80 ENDIF IF ( IGRANDFATH .EQ. KEEP(38) .AND. KEEP(38) .NE. 0 ) THEN IN_L0INIT = .TRUE. GOTO 80 ENDIF IF ( SLAVEF_DURING_MAPPING > 1 ) THEN IF (MUMPS_ROOTSSARBR ( & PROCNODE_STEPS ( STEP ( IFATH ) ), KEEP(199) )) THEN IN_L0INIT = .TRUE. GOTO 80 ENDIF ENDIF ENDIF 80 CONTINUE IF (.NOT. SKIP_ABOVE) THEN IF (KEEP(50).EQ.0) THEN FACTOR_SIZE_UNDER_L0 = FACTOR_SiZE_UNDER_L0 + & NPIV8 * ( NFRONT8 + NFRONT8 - NPIV8 ) ELSE FACTOR_SIZE_UNDER_L0 = FACTOR_SIZE_UNDER_L0 + & NFRONT8 * NPIV8 ENDIF ENDIF IF ( IN_L0INIT ) THEN SMALL_COST_TMP = max(SMALL_COST_TMP, & COSTS_MONO_THREAD ( STEP ( INODE ) ) ) CALL L0_INSERT_NODE ( L0_OMP_DLL, INODE ) NB_IN_L0 = NB_IN_L0 + 1 ELSE IF ( SKIP_ABOVE ) THEN IERR = IDLL_PUSH_BACK ( LEAFS_ABOVE_L0_OMP_DLL, INODE ) IF ( .NOT. INODE_IS_A_LEAF ) THEN WRITE(*,*) & " Internal error 7 in MUMPS_ANA_INITIALIZE_L0_OMP", & INODE CALL MUMPS_ABORT() ENDIF IPOOL_B_L0_OMP(LEAF+1) = -INODE ELSE CP_NSTK_STEPS ( STEP ( IFATH ) ) = & CP_NSTK_STEPS ( STEP ( IFATH ) ) - 1 IF ( CP_NSTK_STEPS ( STEP ( IFATH ) ) .EQ. 0 ) THEN INODE = IFATH INODE_IS_A_LEAF = .FALSE. GOTO 95 ENDIF END IF IF ( LEAF .GT. 0 ) THEN GOTO 90 END IF SMALL_COST = max(SMALL_COST_TMP / 100000d0, SMALL_COST) SMALL_COST = min(SMALL_COST, 1D6) 500 CONTINUE RETURN 150 FORMAT( & /' ** ALLOC FAILURE IN MUMPS_ANA_INITIALIZE_L0_OMP FOR ', & A30) END SUBROUTINE MUMPS_ANA_INITIALIZE_L0_OMP SUBROUTINE L0_INSERT_NODE ( DLL, INODE ) IMPLICIT NONE INTEGER, INTENT ( IN ) :: INODE TYPE ( IDLL_T ), POINTER :: DLL INTEGER :: IERR TYPE ( IDLL_NODE_T ), POINTER :: IDLL_NODE IF ( COSTS_MONO_THREAD ( STEP ( INODE ) ) .LT. SMALL_COST ) THEN IERR = IDLL_PUSH_BACK( DLL, INODE ) RETURN ENDIF IERR = IDLL_ITERATOR_BEGIN ( DLL, IDLL_NODE ) DO WHILE ( associated ( IDLL_NODE ) ) IF ( COSTS_MONO_THREAD ( STEP ( IDLL_NODE%ELMT ) ) & .GT. & COSTS_MONO_THREAD ( STEP ( INODE ) ) ) THEN IDLL_NODE => IDLL_NODE%NEXT ELSE EXIT END IF END DO IF ( .NOT. associated ( IDLL_NODE ) ) THEN IERR = IDLL_PUSH_BACK(DLL, INODE) ELSE IERR = IDLL_INSERT_BEFORE(DLL, IDLL_NODE, INODE) ENDIF RETURN END SUBROUTINE L0_INSERT_NODE SUBROUTINE L0_INSERT_CHILDREN ( I_FATHER ) IMPLICIT NONE INTEGER, INTENT ( IN ) :: I_FATHER INTEGER :: I_SON, IERR, NB_SONS TYPE ( IDLL_T ), POINTER :: SON_DLL TYPE ( IDLL_NODE_T ), POINTER :: IDLL_NODE I_SON = I_FATHER DO WHILE ( I_SON .GT. 0 ) I_SON = FILS ( I_SON ) END DO I_SON = - I_SON IF ( I_SON .EQ. 0 ) THEN RETURN END IF IERR = IDLL_CREATE ( SON_DLL ) NB_SONS = 0 DO WHILE ( I_SON .GT. 0 ) CALL L0_INSERT_NODE ( SON_DLL, I_SON ) I_SON = FRERE ( STEP ( I_SON ) ) NB_SONS = NB_SONS + 1 END DO NB_IN_L0 = NB_IN_L0 + NB_SONS IERR = IDLL_ITERATOR_BEGIN ( L0_OMP_DLL, IDLL_NODE ) IERR = IDLL_POP_FRONT ( SON_DLL, I_SON ) IF ( IERR .NE. 0 ) THEN GOTO 190 END IF IF ( .NOT. associated( IDLL_NODE ) ) THEN DO IERR = IDLL_PUSH_BACK ( L0_OMP_DLL, I_SON ) IERR = IDLL_POP_FRONT ( SON_DLL, I_SON ) IF ( IERR .NE. 0 ) THEN GOTO 190 END IF END DO ELSE DO IF ( COSTS_MONO_THREAD ( STEP ( I_SON ) ) .LT. & SMALL_COST ) THEN IERR = IDLL_PUSH_BACK(L0_OMP_DLL, I_SON) IF (associated(SON_DLL%FRONT)) THEN L0_OMP_DLL%BACK%NEXT => SON_DLL%FRONT SON_DLL%FRONT%PREV => L0_OMP_DLL%BACK L0_OMP_DLL%BACK => SON_DLL%BACK NULLIFY(SON_DLL%FRONT) NULLIFY(SON_DLL%BACK) ENDIF GOTO 190 ENDIF IF ( COSTS_MONO_THREAD ( STEP ( I_SON )) .LT. & COSTS_MONO_THREAD ( STEP ( IDLL_NODE%ELMT ) ) ) THEN IF ( associated ( IDLL_NODE%NEXT ) ) THEN IDLL_NODE => IDLL_NODE%NEXT ELSE IERR = IDLL_PUSH_BACK(L0_OMP_DLL, I_SON) IERR = IDLL_POP_FRONT ( SON_DLL, I_SON ) IF ( IERR .NE. 0 ) THEN GOTO 190 END IF END IF ELSE IERR = IDLL_INSERT_BEFORE(L0_OMP_DLL, IDLL_NODE,I_SON) IERR = IDLL_POP_FRONT ( SON_DLL, I_SON ) IF ( IERR .NE. 0 ) THEN GOTO 190 END IF END IF END DO END IF 190 CONTINUE IERR = IDLL_DESTROY ( SON_DLL ) RETURN END SUBROUTINE L0_INSERT_CHILDREN SUBROUTINE L0_REMOVE_NODE ( INODE ) IMPLICIT NONE INTEGER, INTENT ( OUT ) :: INODE INTEGER :: I_SON, IERR, NPIV IERR = IDLL_POP_FRONT ( L0_OMP_DLL, INODE ) NB_IN_L0 = NB_IN_L0 - 1 I_SON = INODE NPIV = 0 DO WHILE ( I_SON .GT. 0 ) NPIV = NPIV + 1 I_SON = FILS ( I_SON ) END DO I_SON = - I_SON IF (KEEP(50) .EQ. 0) THEN FACTOR_SIZE_UNDER_L0 = FACTOR_SIZE_UNDER_L0 - & int(NPIV, 8) * int(2 * ND(STEP(INODE)) - NPIV, 8) ELSE FACTOR_SIZE_UNDER_L0 = FACTOR_SIZE_UNDER_L0 - & int(NPIV, 8) * int(ND(STEP(INODE)), 8) ENDIF IF ( I_SON .EQ. 0 ) THEN IERR = IDLL_PUSH_BACK ( LEAFS_ABOVE_L0_OMP_DLL, INODE ) INODE = -INODE ELSE IF (INODE .GT. 0 .AND. KEEP(403) .NE. 0) THEN COST_ABOVE = COST_ABOVE + & COSTS_MULTI_THREAD(STEP ( abs(INODE) )) END IF RETURN END SUBROUTINE L0_REMOVE_NODE FUNCTION MUMPS_ANA_ACCEPT_L0_OMP () LOGICAL :: MUMPS_ANA_ACCEPT_L0_OMP INTEGER :: I, I_LESS_CHARGED, IERR DOUBLE PRECISION :: LIGHTEST_CHARGE, HEAVIEST_CHARGE TYPE ( IDLL_NODE_T ), POINTER :: IDLL_NODE LOGICAL :: DECISION_TAKEN NB_MAX_IN_L0_ACCEPTL0 = max(NB_MAX_IN_L0_ACCEPTL0, NB_IN_L0) LIGHTEST_CHARGE = -9999.0d0 HEAVIEST_CHARGE = -9999.0d0 IF ( KEEP(403) .EQ. 0) THEN IF (NB_IN_L0 .EQ. 0) THEN MUMPS_ANA_ACCEPT_L0_OMP = .TRUE. DECISION_TAKEN = .TRUE. ELSE IF ( NB_IN_L0 .LT. NB_MAX_IN_L0_ACCEPTL0 .AND. & NB_IN_L0 .LT. KEEP(400) ) THEN MUMPS_ANA_ACCEPT_L0_OMP = .TRUE. DECISION_TAKEN = .TRUE. ELSE IF ( FACTOR_SIZE_UNDER_L0 .GT. & FACTOR_SIZE_PER_MPI * int(THRESH_MEM,8) / 100_8 ) THEN MUMPS_ANA_ACCEPT_L0_OMP= .FALSE. DECISION_TAKEN = .TRUE. ELSE DECISION_TAKEN = .FALSE. ENDIF ELSE DECISION_TAKEN = .FALSE. ENDIF IF (.NOT. DECISION_TAKEN ) THEN THREADS_CHARGE = 0.0D0 IERR = IDLL_ITERATOR_BEGIN( L0_OMP_DLL, IDLL_NODE ) DO WHILE ( associated ( IDLL_NODE ) ) I_LESS_CHARGED = 1 LIGHTEST_CHARGE = THREADS_CHARGE ( 1 ) DO I = 2, NB_THREADS IF ( THREADS_CHARGE ( I ) .LT. LIGHTEST_CHARGE ) THEN I_LESS_CHARGED = I LIGHTEST_CHARGE = THREADS_CHARGE ( I ) END IF END DO THREADS_CHARGE ( I_LESS_CHARGED ) = & THREADS_CHARGE ( I_LESS_CHARGED ) & + & COSTS_MONO_THREAD ( STEP ( IDLL_NODE%ELMT ) ) IDLL_NODE => IDLL_NODE%NEXT END DO LIGHTEST_CHARGE = THREADS_CHARGE ( 1 ) HEAVIEST_CHARGE = THREADS_CHARGE ( 1 ) DO I = 2, NB_THREADS IF ( THREADS_CHARGE ( I ) .LT. LIGHTEST_CHARGE ) THEN LIGHTEST_CHARGE = THREADS_CHARGE ( I ) ELSEIF ( THREADS_CHARGE ( I ) .GT. HEAVIEST_CHARGE ) THEN HEAVIEST_CHARGE = THREADS_CHARGE ( I ) END IF END DO COST_UNDER = HEAVIEST_CHARGE ENDIF IF (KEEP(403) .EQ. 0) THEN IF ( .NOT. DECISION_TAKEN ) THEN MUMPS_ANA_ACCEPT_L0_OMP = & ( & dble(LIGHTEST_CHARGE)/(dble(HEAVIEST_CHARGE)+1.D-12) & .GT.THRESH_EQUILIB .AND. & & FACTOR_SIZE_UNDER_L0 .LE. & FACTOR_SIZE_PER_MPI * int(THRESH_MEM,8) / 100_8 & & ) & .OR. & ( NB_IN_L0 .LT. NB_MAX_IN_L0_ACCEPTL0 .AND. & LIGHTEST_CHARGE .EQ. 0.0D0 ) & .OR. ( NB_IN_L0 .EQ. 0 ) ENDIF IF (MUMPS_ANA_ACCEPT_L0_OMP) THEN IF (associated(PHYS_L0_OMP)) THEN DEALLOCATE(PHYS_L0_OMP) NULLIFY(PHYS_L0_OMP) ENDIF IERR = IDLL_2_ARRAY ( L0_OMP_DLL, PHYS_L0_OMP, L_PHYS_L0_OMP ) IF (IERR .EQ. -2) THEN INFO(1) = -7 INFO(2) = L_PHYS_L0_OMP RETURN ENDIF END IF ELSE IF (COST_UNDER + COST_ABOVE .LT. COST_TOTAL_BEST) THEN IF (associated(PHYS_L0_OMP)) THEN DEALLOCATE(PHYS_L0_OMP) NULLIFY(PHYS_L0_OMP) ENDIF IERR = IDLL_2_ARRAY ( L0_OMP_DLL, PHYS_L0_OMP, L_PHYS_L0_OMP ) COST_TOTAL_BEST = COST_UNDER + COST_ABOVE NB_REPEAT_ACCEPTL0 = 100 END IF NB_REPEAT_ACCEPTL0 = NB_REPEAT_ACCEPTL0- 1 MUMPS_ANA_ACCEPT_L0_OMP = (NB_REPEAT_ACCEPTL0 .EQ. 0) END IF RETURN END FUNCTION MUMPS_ANA_ACCEPT_L0_OMP SUBROUTINE MUMPS_ANA_FINALIZE_L0_OMP () IMPLICIT NONE INTEGER :: INODE, OLD_INODE, I, J, K, LEAF, IERR DOUBLE PRECISION :: LIGHTEST_CHARGE INTEGER :: I_LESS_CHARGED INTEGER :: MAX_TASK_PER_THREAD TYPE ( IDLL_NODE_T ), POINTER :: IDLL_NODE INTEGER, DIMENSION(:,:), ALLOCATABLE :: THREADS_TASKS INTEGER, DIMENSION(:), ALLOCATABLE :: NB_TASK_PER_THREAD INTEGER, DIMENSION(:), ALLOCATABLE :: INV_PERM_L0_OMP EXTERNAL :: MUMPS_GET_POOL_LENGTH INTEGER :: MUMPS_GET_POOL_LENGTH IF (KEEP(402) .EQ. 0) THEN L_VIRT_L0_OMP = NB_THREADS + 1 ELSE L_VIRT_L0_OMP = L_PHYS_L0_OMP + 1 END IF LPOOL_A_L0_OMP = MUMPS_GET_POOL_LENGTH(NA(1),KEEP(1),KEEP8(1)) ALLOCATE ( VIRT_L0_OMP ( max(L_VIRT_L0_OMP,1) ), & VIRT_L0_OMP_MAPPING( max(L_VIRT_L0_OMP,1) ), & STAT=IERR ) IF(IERR.GT.0) THEN INFO(1)=-7 INFO(2)=2*max(L_VIRT_L0_OMP,1) IF (LPOK) WRITE(LP,150) 'id%VIRT_L0_OMP[_MAPPING]' GOTO 300 ENDIF ALLOCATE ( PERM_L0_OMP ( max(L_PHYS_L0_OMP,1) ), STAT=IERR ) IF(IERR.GT.0) THEN INFO(1)=-7 INFO(2)=max(L_PHYS_L0_OMP,1) IF (LPOK) WRITE(LP,150) 'id%PERM_L0_OMP' GOTO 300 ENDIF ALLOCATE ( PTR_LEAFS_L0_OMP ( L_PHYS_L0_OMP + 1 ), STAT=IERR ) IF(IERR.GT.0) THEN INFO(1)=-7 INFO(2)=max(L_PHYS_L0_OMP,1) IF (LPOK) WRITE(LP,150) 'id%PTR_LEAFS_L0_OMP' GOTO 300 ENDIF ALLOCATE ( IPOOL_A_L0_OMP ( LPOOL_A_L0_OMP ), STAT=IERR ) IF(IERR.GT.0) THEN INFO(1)=-7 INFO(2)=LPOOL_A_L0_OMP IF (LPOK) WRITE(LP,150) 'id%IPOOL_A_L0_OMP' GOTO 300 ENDIF ALLOCATE ( NB_TASK_PER_THREAD ( NB_THREADS ), STAT=IERR ) IF(IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NB_THREADS IF (LPOK) WRITE(LP,150) 'NB_TASK_PER_THREAD' GOTO 300 ENDIF ALLOCATE ( INV_PERM_L0_OMP ( L_PHYS_L0_OMP ), STAT=IERR ) IF(IERR.GT.0) THEN WRITE(*,*) "Allocation Error in MUMPS_ANA_FINALIZE_L0_OMP" CALL MUMPS_ABORT() ENDIF NB_TASK_PER_THREAD = 0 THREADS_CHARGE = 0.0D0 DO I = 1, L_PHYS_L0_OMP I_LESS_CHARGED = 1 LIGHTEST_CHARGE = THREADS_CHARGE ( 1 ) DO J = 2, NB_THREADS IF ( THREADS_CHARGE ( J ) .LT. LIGHTEST_CHARGE ) THEN I_LESS_CHARGED = J LIGHTEST_CHARGE = THREADS_CHARGE ( J ) IF (THREADS_CHARGE( J ) .EQ. 0) THEN EXIT ENDIF END IF END DO NB_TASK_PER_THREAD ( I_LESS_CHARGED ) = & NB_TASK_PER_THREAD ( I_LESS_CHARGED ) + 1 IF (KEEP(402) .NE. 0) THEN VIRT_L0_OMP_MAPPING(I) = I_LESS_CHARGED ENDIF THREADS_CHARGE ( I_LESS_CHARGED ) = & THREADS_CHARGE ( I_LESS_CHARGED ) & + & COSTS_MONO_THREAD ( STEP ( PHYS_L0_OMP ( I ) ) ) END DO IF (KEEP(402) .EQ. 0) THEN DO I = 1, NB_THREADS VIRT_L0_OMP_MAPPING(I) = I ENDDO ENDIF VIRT_L0_OMP_MAPPING(L_VIRT_L0_OMP) = -999999 MAX_TASK_PER_THREAD = 0 DO I = 1, NB_THREADS MAX_TASK_PER_THREAD = max (MAX_TASK_PER_THREAD, & NB_TASK_PER_THREAD ( I ) ) END DO ALLOCATE ( THREADS_TASKS ( NB_THREADS, MAX_TASK_PER_THREAD ), & STAT=IERR ) IF(IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NB_THREADS*MAX_TASK_PER_THREAD IF (LPOK) WRITE(LP,150) 'THREADS_TASK' GOTO 300 ENDIF NB_TASK_PER_THREAD = 0 THREADS_CHARGE = 0.0D0 THREADS_TASKS = 0 DO I = 1, L_PHYS_L0_OMP I_LESS_CHARGED = 1 LIGHTEST_CHARGE = THREADS_CHARGE ( 1 ) DO J = 2, NB_THREADS IF ( THREADS_CHARGE ( J ) .LT. LIGHTEST_CHARGE ) THEN I_LESS_CHARGED = J LIGHTEST_CHARGE = THREADS_CHARGE ( J ) END IF END DO NB_TASK_PER_THREAD ( I_LESS_CHARGED ) = & NB_TASK_PER_THREAD ( I_LESS_CHARGED ) + 1 THREADS_TASKS ( I_LESS_CHARGED, NB_TASK_PER_THREAD & ( I_LESS_CHARGED ) ) = PHYS_L0_OMP( I ) THREADS_CHARGE ( I_LESS_CHARGED ) = & THREADS_CHARGE ( I_LESS_CHARGED ) & + & COSTS_MONO_THREAD ( STEP ( PHYS_L0_OMP ( I ) ) ) END DO IF (KEEP(402) .EQ. 0) THEN K = 1 DO I = 1, NB_THREADS VIRT_L0_OMP (I) = K DO J = 1, NB_TASK_PER_THREAD ( I ) PHYS_L0_OMP (K) = THREADS_TASKS (I,J) K = K + 1 END DO END DO VIRT_L0_OMP (NB_THREADS+1) = K ELSE DO I = 1, L_VIRT_L0_OMP VIRT_L0_OMP (I) = I END DO END IF DO I = 1, L_PHYS_L0_OMP INV_PERM_L0_OMP ( I ) = I END DO IF ( L_PHYS_L0_OMP .GT. 1 ) THEN CALL MUMPS_QUICK_SORT_PHYS_L0( N, STEP(1), PHYS_L0_OMP(1), & INV_PERM_L0_OMP, L_PHYS_L0_OMP, 1, L_PHYS_L0_OMP ) ENDIF DO I = 1, L_PHYS_L0_OMP PERM_L0_OMP( INV_PERM_L0_OMP ( I ) ) = I END DO J = NBLEAF_MYID PTR_LEAFS_L0_OMP ( 1 ) = J DO I = 1, L_PHYS_L0_OMP OLD_INODE = 0 INODE = PHYS_L0_OMP ( I ) DO WHILE ( INODE .NE. 0 ) OLD_INODE = INODE DO WHILE ( INODE .GT. 0 ) INODE = FILS ( INODE ) END DO INODE = - INODE END DO DO WHILE ( IPOOL_B_L0_OMP ( J ) .NE. OLD_INODE ) J = J - 1 END DO J = J - 1 PTR_LEAFS_L0_OMP ( I + 1 ) = J END DO CP_NSTK_STEPS(:) = NSTK_STEPS(:) IPOOL_A_L0_OMP = 0 LEAF = 1 IERR = IDLL_ITERATOR_BEGIN ( LEAFS_ABOVE_L0_OMP_DLL, IDLL_NODE ) DO WHILE ( associated( IDLL_NODE ) ) IPOOL_A_L0_OMP ( LEAF ) = IDLL_NODE%ELMT LEAF = LEAF + 1 IDLL_NODE => IDLL_NODE%NEXT END DO DO I = 1 , L_PHYS_L0_OMP IF ( DAD ( STEP ( PHYS_L0_OMP (I) ) ) .NE. 0 ) THEN CP_NSTK_STEPS ( STEP ( DAD ( STEP ( PHYS_L0_OMP (I) ) ) ) ) = & CP_NSTK_STEPS ( STEP ( DAD ( STEP ( PHYS_L0_OMP (I) ) ) ) )-1 IF (CP_NSTK_STEPS(STEP(DAD(STEP(PHYS_L0_OMP(I))))) .EQ. 0)THEN IPOOL_A_L0_OMP ( LEAF ) = DAD(STEP(PHYS_L0_OMP ( I ))) LEAF = LEAF + 1 END IF END IF END DO LEAF = LEAF - 1 IPOOL_A_L0_OMP(LPOOL_A_L0_OMP) = LEAF IPOOL_A_L0_OMP(LPOOL_A_L0_OMP-1) = 0 IPOOL_A_L0_OMP(LPOOL_A_L0_OMP-2) = 0 IF (LEAF .GT. 1) THEN CALL MUMPS_QUICK_SORT_IPOOL_PO( N, STEP(1), & IPOOL_A_L0_OMP(1), LEAF, 1, LEAF ) ENDIF 300 CONTINUE IF (allocated(NB_TASK_PER_THREAD)) DEALLOCATE (NB_TASK_PER_THREAD) IF (allocated(INV_PERM_L0_OMP )) DEALLOCATE ( INV_PERM_L0_OMP ) IF (allocated(THREADS_TASKS )) DEALLOCATE (THREADS_TASKS ) RETURN 150 FORMAT( & /' ** ALLOC FAILURE IN MUMPS_ANA_FINALIZE_L0_OMP FOR ', & A30) END SUBROUTINE MUMPS_ANA_FINALIZE_L0_OMP SUBROUTINE MUMPS_ANA_FREE_L0_WORKSPACE() INTEGER :: IERR IF (allocated(THREADS_CHARGE)) DEALLOCATE(THREADS_CHARGE ) IF (allocated(CP_NSTK_STEPS )) DEALLOCATE(CP_NSTK_STEPS ) IF (allocated(COSTS_MONO_THREAD)) DEALLOCATE(COSTS_MONO_THREAD ) IF (allocated(COSTS_MULTI_THREAD)) DEALLOCATE(COSTS_MULTI_THREAD) IF (allocated(IPOOL_B_INV)) DEALLOCATE(IPOOL_B_INV ) IERR = IDLL_DESTROY ( LEAFS_ABOVE_L0_OMP_DLL ) IERR = IDLL_DESTROY ( L0_OMP_DLL ) RETURN END SUBROUTINE MUMPS_ANA_FREE_L0_WORKSPACE SUBROUTINE READ_BENCH(ARITH, K50) IMPLICIT NONE INTEGER, INTENT(in) :: K50 CHARACTER(1), INTENT(in) :: ARITH INTEGER NLINES, INDEX_NPIV, INDEX_NSCHUR, NB_CORE INTEGER V, S, OLD_V, OLD_S, I PARAMETER(NLINES=2812) DOUBLE PRECISION :: AUX CHARACTER(1) :: K50_STR INDEX_NPIV = 0 INDEX_NSCHUR = 0 OLD_V = -1 OLD_S = -1 WRITE(K50_STR,'(I1)') K50 OPEN(1,FILE=ARITH//'benchmark_sym_'//K50_STR//'.csv') DO I=1,NLINES READ(1,*) V, S, NB_CORE, AUX IF (V .NE. OLD_V) THEN INDEX_NPIV = INDEX_NPIV + 1 OLD_V = V END IF IF (S .GT. OLD_S) THEN INDEX_NSCHUR = INDEX_NSCHUR + 1 OLD_S = S ELSEIF (S .LT. OLD_S) THEN INDEX_NSCHUR = 1 OLD_S = S END IF BENCH (INDEX_NPIV, INDEX_NSCHUR, NB_CORE) = AUX END DO CLOSE(1) RETURN END SUBROUTINE READ_BENCH SUBROUTINE COST_BENCH (NPIV, NSCHUR, NB_CORE, SYM, COST) IMPLICIT NONE INTEGER, INTENT(IN) :: NPIV, NSCHUR, NB_CORE, SYM DOUBLE PRECISION, INTENT(OUT) :: COST INTEGER V, VV, S, SS INTEGER LOW_INDEX_NPIV, LOW_INDEX_NSCHUR INTEGER HIGH_INDEX_NPIV, HIGH_INDEX_NSCHUR DOUBLE PRECISION :: APROX_COST_FLOPS, REAL_COST_FLOPS IF (NPIV .LE. 10) THEN LOW_INDEX_NPIV = NPIV V = NPIV VV = NPIV + 1 ELSEIF (NPIV .LE. 100) THEN LOW_INDEX_NPIV = 9 + NPIV/10 V = (NPIV/10)*10 VV = (NPIV/10+1)*10 ELSEIF (NPIV .LE. 1000) THEN LOW_INDEX_NPIV = 18 + NPIV/100 V = (NPIV/100)*100 VV = (NPIV/100+1)*100 ELSEIF (NPIV .LE. 10000) THEN LOW_INDEX_NPIV = 27 + NPIV/1000 V = (NPIV/1000)*1000 VV = (NPIV/1000+1)*1000 ELSE LOW_INDEX_NPIV = 37 V = (NPIV/10000)*10000 VV = (NPIV/10000+1)*10000 END IF IF (NSCHUR .LE. 10) THEN LOW_INDEX_NSCHUR = NSCHUR + 1 S = NSCHUR SS = NSCHUR + 1 ELSEIF (NSCHUR .LE. 100) THEN LOW_INDEX_NSCHUR = 10 + NSCHUR/10 S = (NSCHUR/10)*10 SS = (NSCHUR/10+1)*10 ELSEIF (NSCHUR .LE. 1000) THEN LOW_INDEX_NSCHUR = 19 + NSCHUR/100 S = (NSCHUR/100)*100 SS = (NSCHUR/100+1)*100 ELSEIF (NSCHUR .LE. 10000) THEN LOW_INDEX_NSCHUR = 28 + NSCHUR/1000 S = (NSCHUR/1000)*1000 SS = (NSCHUR/1000+1)*1000 ELSE LOW_INDEX_NSCHUR = 38 S = (NSCHUR/10000)*10000 SS = (NSCHUR/10000+1)*10000 END IF IF (V .LT. 10000) THEN IF (S .LT. 10000) THEN HIGH_INDEX_NPIV = LOW_INDEX_NPIV + 1 HIGH_INDEX_NSCHUR = LOW_INDEX_NSCHUR + 1 COST = (BENCH(LOW_INDEX_NPIV, LOW_INDEX_NSCHUR, NB_CORE) & *(VV - NPIV)*(SS - NSCHUR) & +BENCH(LOW_INDEX_NPIV, HIGH_INDEX_NSCHUR, NB_CORE) & *(VV - NPIV)*(NSCHUR - S) & +BENCH(HIGH_INDEX_NPIV, LOW_INDEX_NSCHUR, NB_CORE) & *(NPIV - V)*(SS - NSCHUR) & +BENCH(HIGH_INDEX_NPIV, HIGH_INDEX_NSCHUR, NB_CORE) & *(NPIV - V)*(NSCHUR - S)) & /((VV - V)*(SS - S)) ELSE HIGH_INDEX_NPIV = LOW_INDEX_NPIV + 1 HIGH_INDEX_NSCHUR = LOW_INDEX_NSCHUR COST = (BENCH(LOW_INDEX_NPIV, LOW_INDEX_NSCHUR, NB_CORE) & *(VV - NPIV) & +BENCH(HIGH_INDEX_NPIV, LOW_INDEX_NSCHUR, NB_CORE) & *(NPIV - V)) & /(VV - V) CALL MUMPS_GET_FLOPS_COST ( NPIV+NSCHUR, NPIV, NPIV, & SYM, 1, REAL_COST_FLOPS ) CALL MUMPS_GET_FLOPS_COST ( V+S, V, V, & SYM, 1, APROX_COST_FLOPS ) COST = COST * (REAL_COST_FLOPS/APROX_COST_FLOPS) END IF ELSE IF (NSCHUR < 10000) THEN HIGH_INDEX_NPIV = LOW_INDEX_NPIV HIGH_INDEX_NSCHUR = LOW_INDEX_NSCHUR + 1 COST = (BENCH(LOW_INDEX_NPIV, LOW_INDEX_NSCHUR, NB_CORE) & *(SS - NSCHUR) & +BENCH(LOW_INDEX_NPIV, HIGH_INDEX_NSCHUR, NB_CORE) & *(NSCHUR - S)) & /(SS - S) CALL MUMPS_GET_FLOPS_COST ( NPIV+NSCHUR, NPIV, NPIV, & SYM, 1, REAL_COST_FLOPS ) CALL MUMPS_GET_FLOPS_COST ( V+S, V, V, & SYM, 1, APROX_COST_FLOPS ) COST = COST * (REAL_COST_FLOPS/APROX_COST_FLOPS) ELSE HIGH_INDEX_NPIV = LOW_INDEX_NPIV HIGH_INDEX_NSCHUR = LOW_INDEX_NSCHUR COST = (BENCH(LOW_INDEX_NPIV, LOW_INDEX_NSCHUR, NB_CORE)) CALL MUMPS_GET_FLOPS_COST ( NPIV+NSCHUR, NPIV, NPIV, & SYM, 1, REAL_COST_FLOPS ) CALL MUMPS_GET_FLOPS_COST ( V+S, V, V, & SYM, 1, APROX_COST_FLOPS ) COST = COST * (REAL_COST_FLOPS/APROX_COST_FLOPS) END IF END IF END SUBROUTINE COST_BENCH END SUBROUTINE MUMPS_ANA_L0_OMP END MODULE MUMPS_ANA_OMP_M RECURSIVE SUBROUTINE MUMPS_QUICK_SORT_IPOOL_PO( N, STEP, & INTLIST, TAILLE, LO, HI ) IMPLICIT NONE INTEGER N, TAILLE INTEGER STEP( N ) INTEGER INTLIST( TAILLE ) INTEGER LO, HI INTEGER I,J INTEGER ISWAP, PIVOT I = LO J = HI PIVOT = STEP(INTLIST((I+J)/2)) 10 IF (STEP(INTLIST(I)) > PIVOT) THEN I=I+1 GOTO 10 ENDIF 20 IF (STEP(INTLIST(J)) < PIVOT) THEN J=J-1 GOTO 20 ENDIF IF (I < J) THEN ISWAP = INTLIST(I) INTLIST(I) = INTLIST(J) INTLIST(J)=ISWAP ENDIF IF ( I <= J) THEN I = I+1 J = J-1 ENDIF IF ( I <= J ) GOTO 10 IF ( LO < J ) CALL MUMPS_QUICK_SORT_IPOOL_PO(N, STEP, & INTLIST, TAILLE, LO, J) IF ( I < HI ) CALL MUMPS_QUICK_SORT_IPOOL_PO(N, STEP, & INTLIST, TAILLE, I, HI) RETURN END SUBROUTINE MUMPS_QUICK_SORT_IPOOL_PO RECURSIVE SUBROUTINE MUMPS_QUICK_SORT_PHYS_L0( N, STEP, & INTLIST, INVPERM, TAILLE, LO, HI ) IMPLICIT NONE INTEGER N, TAILLE INTEGER STEP( N ) INTEGER INTLIST( TAILLE ) INTEGER INVPERM( TAILLE ) INTEGER LO, HI INTEGER I,J INTEGER ISWAP, PIVOT INTEGER dswap I = LO J = HI PIVOT = STEP(INTLIST((I+J)/2)) 10 IF (STEP(INTLIST(I)) < PIVOT) THEN I=I+1 GOTO 10 ENDIF 20 IF (STEP(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 = INVPERM(I) INVPERM(I) = INVPERM(J) INVPERM(J) = dswap ENDIF IF ( I <= J) THEN I = I+1 J = J-1 ENDIF IF ( I <= J ) GOTO 10 IF ( LO < J ) CALL MUMPS_QUICK_SORT_PHYS_L0(N, STEP, & INTLIST, INVPERM, TAILLE, LO, J) IF ( I < HI ) CALL MUMPS_QUICK_SORT_PHYS_L0(N, STEP, & INTLIST, INVPERM, TAILLE, I, HI) RETURN END SUBROUTINE MUMPS_QUICK_SORT_PHYS_L0 SUBROUTINE MUMPS_ANA_OMP_RETURN() RETURN END SUBROUTINE MUMPS_ANA_OMP_RETURN MUMPS_5.8.1/src/zfac_scalings.F0000664000175000017500000003053615042446441016155 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_FAC_A(N, NZ8, NSCA, & ASPK, IRN, ICN, COLSCA, ROWSCA, WK, LWK8, WK_REAL, & LWK_REAL, ICNTL, INFO) IMPLICIT NONE INTEGER N, NSCA INTEGER(8), INTENT(IN) :: NZ8 INTEGER IRN(NZ8), ICN(NZ8) INTEGER ICNTL(60), INFO(80) COMPLEX(kind=8), INTENT(IN) :: ASPK(NZ8) DOUBLE PRECISION COLSCA(*), ROWSCA(*) INTEGER(8), INTENT(IN) :: LWK8 INTEGER(8), INTENT(IN) :: LWK_REAL COMPLEX(kind=8) WK(LWK8) DOUBLE PRECISION WK_REAL(LWK_REAL) INTEGER MPG,LP INTEGER I LOGICAL PROKG DOUBLE PRECISION ONE PARAMETER( ONE = 1.0D0 ) LP = ICNTL(1) MPG = ICNTL(2) MPG = ICNTL(3) PROKG = ((MPG.GT.0).AND.(ICNTL(4).GE.2)) IF (PROKG) THEN WRITE(MPG,101) ELSE MPG = 0 ENDIF 101 FORMAT(/' ****** SCALING OF ORIGINAL MATRIX '/) IF (NSCA.EQ.1) THEN IF (PROKG) WRITE (MPG,*) ' DIAGONAL SCALING ' ELSEIF (NSCA.EQ.3) THEN IF (PROKG) & WRITE (MPG,*) ' COLUMN SCALING' ELSEIF (NSCA.EQ.4) THEN IF (PROKG) & WRITE (MPG,*) ' ROW AND COLUMN SCALING (1 Pass)' ENDIF DO 10 I=1,N COLSCA(I) = ONE ROWSCA(I) = ONE 10 CONTINUE IF (NSCA.EQ.1) THEN CALL ZMUMPS_FAC_V(N,NZ8,ASPK,IRN,ICN, & COLSCA,ROWSCA,MPG) ELSEIF (NSCA.EQ.3) THEN IF ( LWK_REAL .LT. int(N,8) ) THEN GOTO 420 ENDIF CALL ZMUMPS_FAC_Y(N,NZ8,ASPK,IRN,ICN,WK_REAL(1), & COLSCA, MPG) ELSEIF (NSCA.EQ.4) THEN IF ( LWK_REAL .LT. 2_8*int(N,8) ) THEN GOTO 430 ENDIF CALL ZMUMPS_ROWCOL(N,NZ8,IRN,ICN,ASPK, & WK_REAL(1),WK_REAL(1+N),COLSCA,ROWSCA,MPG) ENDIF GOTO 500 420 INFO(1) = -5 CALL MUMPS_SET_IERROR(int(N,8)-LWK_REAL, INFO(2)) IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix' GOTO 500 430 INFO(1) = -5 CALL MUMPS_SET_IERROR(2_8*int(N,8)-LWK_REAL, INFO(2)) IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix' GOTO 500 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_A SUBROUTINE ZMUMPS_ROWCOL(N,NZ8,IRN,ICN,VAL, & RNOR,CNOR,COLSCA,ROWSCA,MPRINT) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 COMPLEX(kind=8) VAL(NZ8) DOUBLE PRECISION RNOR(N),CNOR(N) DOUBLE PRECISION COLSCA(N),ROWSCA(N) DOUBLE PRECISION CMIN,CMAX,RMIN,ARNOR,ACNOR INTEGER IRN(NZ8), ICN(NZ8) DOUBLE PRECISION VDIAG INTEGER MPRINT INTEGER I,J INTEGER(8) :: K8 DOUBLE PRECISION ZERO, ONE PARAMETER(ZERO=0.0D0, ONE=1.0D0) DO 50 J=1,N CNOR(J) = ZERO RNOR(J) = ZERO 50 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.CNOR(J)) THEN CNOR(J) = VDIAG ENDIF IF (VDIAG.GT.RNOR(I)) THEN RNOR(I) = VDIAG ENDIF 100 CONTINUE IF (MPRINT.GT.0) THEN CMIN = CNOR(1) CMAX = CNOR(1) RMIN = RNOR(1) DO 111 I=1,N ARNOR = RNOR(I) ACNOR = CNOR(I) IF (ACNOR.GT.CMAX) CMAX=ACNOR IF (ACNOR.LT.CMIN) CMIN=ACNOR IF (ARNOR.LT.RMIN) RMIN=ARNOR 111 CONTINUE WRITE(MPRINT,*) '**** STAT. OF MATRIX PRIOR ROW&COL SCALING' WRITE(MPRINT,*) ' MAXIMUM NORM-MAX OF COLUMNS:',CMAX WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF COLUMNS:',CMIN WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF ROWS :',RMIN ENDIF DO 120 J=1,N IF (CNOR(J).LE.ZERO) THEN CNOR(J) = ONE ELSE CNOR(J) = ONE / CNOR(J) ENDIF 120 CONTINUE DO 130 J=1,N IF (RNOR(J).LE.ZERO) THEN RNOR(J) = ONE ELSE RNOR(J) = ONE / RNOR(J) ENDIF 130 CONTINUE DO 110 I=1,N ROWSCA(I) = ROWSCA(I) * RNOR(I) COLSCA(I) = COLSCA(I) * CNOR(I) 110 CONTINUE IF (MPRINT.GT.0) & WRITE(MPRINT,*) ' END OF SCALING BY MAX IN ROW AND COL' RETURN END SUBROUTINE ZMUMPS_ROWCOL SUBROUTINE ZMUMPS_FAC_Y(N,NZ8,VAL,IRN,ICN, & CNOR,COLSCA,MPRINT) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 COMPLEX(kind=8), INTENT(IN) :: VAL(NZ8) DOUBLE PRECISION, INTENT(OUT) :: CNOR(N) DOUBLE PRECISION, INTENT(INOUT) :: COLSCA(N) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) INTEGER, INTENT(IN) :: MPRINT DOUBLE PRECISION VDIAG INTEGER I,J INTEGER(8) :: K8 DOUBLE PRECISION ZERO, ONE PARAMETER (ZERO=0.0D0,ONE=1.0D0) DO 10 J=1,N CNOR(J) = ZERO 10 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.CNOR(J)) THEN CNOR(J) = VDIAG ENDIF 100 CONTINUE DO 110 J=1,N IF (CNOR(J).LE.ZERO) THEN CNOR(J) = ONE ELSE CNOR(J) = ONE/CNOR(J) ENDIF 110 CONTINUE DO 215 I=1,N COLSCA(I) = COLSCA(I) * CNOR(I) 215 CONTINUE IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF COLUMN SCALING' RETURN END SUBROUTINE ZMUMPS_FAC_Y SUBROUTINE ZMUMPS_FAC_V(N,NZ8,VAL,IRN,ICN, & COLSCA,ROWSCA,MPRINT) INTEGER , INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 COMPLEX(kind=8) , INTENT(IN) :: VAL(NZ8) DOUBLE PRECISION , INTENT(OUT) :: ROWSCA(N),COLSCA(N) INTEGER , INTENT(IN) :: IRN(NZ8),ICN(NZ8) INTEGER , INTENT(IN) :: MPRINT DOUBLE PRECISION :: VDIAG INTEGER :: I,J INTEGER(8) :: K8 INTRINSIC sqrt DOUBLE PRECISION ZERO, ONE PARAMETER(ZERO=0.0D0, ONE=1.0D0) DO 10 I=1,N ROWSCA(I) = ONE 10 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) IF ((I.GT.N).OR.(I.LE.0)) GOTO 100 J = ICN(K8) IF (I.EQ.J) THEN VDIAG = abs(VAL(K8)) IF (VDIAG.GT.ZERO) THEN ROWSCA(J) = ONE/(sqrt(VDIAG)) ENDIF ENDIF 100 CONTINUE DO 110 I=1,N COLSCA(I) = ROWSCA(I) 110 CONTINUE IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF DIAGONAL SCALING' RETURN END SUBROUTINE ZMUMPS_FAC_V SUBROUTINE ZMUMPS_FAC_X(NSCA,N,NZ8,IRN,ICN,VAL, & RNOR,ROWSCA,MPRINT) INTEGER, INTENT(IN) :: N, NSCA INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) COMPLEX(kind=8) VAL(NZ8) DOUBLE PRECISION RNOR(N) DOUBLE PRECISION ROWSCA(N) INTEGER MPRINT DOUBLE PRECISION VDIAG INTEGER I,J INTEGER(8) :: K8 DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: ONE = 1.0D0 DO 50 J=1,N RNOR(J) = ZERO 50 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.RNOR(I)) THEN RNOR(I) = VDIAG ENDIF 100 CONTINUE DO 130 J=1,N IF (RNOR(J).LE.ZERO) THEN RNOR(J) = ONE ELSE RNOR(J) = ONE/RNOR(J) ENDIF 130 CONTINUE DO 110 I=1,N ROWSCA(I) = ROWSCA(I)* RNOR(I) 110 CONTINUE IF ( (NSCA.EQ.4) .OR. (NSCA.EQ.6) ) THEN DO 150 K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 150 VAL(K8) = VAL(K8) * RNOR(I) 150 CONTINUE ENDIF IF (MPRINT.GT.0) & WRITE(MPRINT,'(A)') ' END OF ROW SCALING' RETURN END SUBROUTINE ZMUMPS_FAC_X SUBROUTINE ZMUMPS_ANORMINF( id, ANORMINF, LSCAL, & EFF_SIZE_SCHUR ) 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, INTENT(IN) :: LSCAL INTEGER, INTENT(IN) :: EFF_SIZE_SCHUR 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 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%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 ( id%KEEP(54) .eq. 0 ) THEN IF (id%MYID .EQ. MASTER) THEN IF (id%KEEP(55).EQ.0) THEN IF (.NOT.LSCAL) THEN CALL ZMUMPS_SOL_X(id%A(1), & id%KEEP8(28), id%N, & id%IRN(1), id%JCN(1), & SUMR, id%KEEP(1),id%KEEP8(1), & EFF_SIZE_SCHUR, id%SYM_PERM(1) ) ELSE CALL ZMUMPS_SCAL_X(id%A(1), & id%KEEP8(28), id%N, & id%IRN(1), id%JCN(1), & SUMR, id%KEEP(1), id%KEEP8(1), & id%COLSCA(1), & EFF_SIZE_SCHUR, id%SYM_PERM(1) ) ENDIF ELSE MTYPE = 1 IF (.NOT.LSCAL) THEN CALL ZMUMPS_SOL_X_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), & id%A_ELT(1), SUMR, id%KEEP(1),id%KEEP8(1) ) ELSE CALL ZMUMPS_SOL_SCALX_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), & id%A_ELT(1), & SUMR, id%KEEP(1), id%KEEP8(1), id%COLSCA(1)) ENDIF ENDIF ENDIF ELSE ALLOCATE( SUMR_LOC( id%N ), stat =allocok ) IF (allocok .GT.0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N RETURN ENDIF IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0 ) THEN IF (.NOT.LSCAL) THEN CALL ZMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1), & EFF_SIZE_SCHUR, id%SYM_PERM(1) ) ELSE CALL ZMUMPS_SCAL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1), & id%COLSCA(1), & EFF_SIZE_SCHUR, id%SYM_PERM(1) ) ENDIF ELSE SUMR_LOC = ZERO ENDIF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( SUMR_LOC, SUMR, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( SUMR_LOC, DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) END IF DEALLOCATE (SUMR_LOC) ENDIF IF ( id%MYID .eq. MASTER ) THEN ANORMINF = dble(ZERO) IF (LSCAL) THEN DO I = 1, id%N ANORMINF = max(abs(id%ROWSCA(I) * SUMR(I)), & ANORMINF) ENDDO ELSE DO I = 1, id%N ANORMINF = max(abs(SUMR(I)), & ANORMINF) ENDDO ENDIF ENDIF CALL MPI_BCAST(ANORMINF, 1, & MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) IF (id%MYID .eq. MASTER) DEALLOCATE (SUMR) RETURN END SUBROUTINE ZMUMPS_ANORMINF MUMPS_5.8.1/src/mumps_c.c0000664000175000017500000006624115042446422015050 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Header used for debug purpose only #include */ #include #include "mumps_common.h" #if MUMPS_ARITH == MUMPS_ARITH_s # include "smumps_c.h" # define MUMPS_REAL SMUMPS_REAL # define MUMPS_COMPLEX SMUMPS_COMPLEX #elif MUMPS_ARITH == MUMPS_ARITH_d # include "dmumps_c.h" # define MUMPS_REAL DMUMPS_REAL # define MUMPS_COMPLEX DMUMPS_COMPLEX #elif MUMPS_ARITH == MUMPS_ARITH_c # include "cmumps_c.h" # define MUMPS_REAL CMUMPS_REAL # define MUMPS_COMPLEX CMUMPS_COMPLEX #elif MUMPS_ARITH == MUMPS_ARITH_z # include "zmumps_c.h" # define MUMPS_REAL ZMUMPS_REAL # define MUMPS_COMPLEX ZMUMPS_COMPLEX #endif /* * F_SYM_ARITH is the same as F_SYMBOL (see mumps_common.h) for the symbols * that depend on the arithmetic. * Example: For CMUMPS_XXX, first define * #define CMUMPS_XXX F_SYM_ARITH(xxx,XXX) and then use * CMUMPS_XXX in the code to get rid of any symbol convention annoyance. */ #if MUMPS_ARITH == MUMPS_ARITH_s # if defined(UPPER) || defined(MUMPS_WIN32) # define F_SYM_ARITH(lower_case,upper_case) SMUMPS_##upper_case # elif defined(Add_) # define F_SYM_ARITH(lower_case,upper_case) smumps_##lower_case##_ # elif defined(Add__) # define F_SYM_ARITH(lower_case,upper_case) smumps_##lower_case##__ # else # define F_SYM_ARITH(lower_case,upper_case) smumps_##lower_case # endif #elif MUMPS_ARITH == MUMPS_ARITH_d # if defined(UPPER) || defined(MUMPS_WIN32) # define F_SYM_ARITH(lower_case,upper_case) DMUMPS_##upper_case # elif defined(Add_) # define F_SYM_ARITH(lower_case,upper_case) dmumps_##lower_case##_ # elif defined(Add__) # define F_SYM_ARITH(lower_case,upper_case) dmumps_##lower_case##__ # else # define F_SYM_ARITH(lower_case,upper_case) dmumps_##lower_case # endif #elif MUMPS_ARITH == MUMPS_ARITH_c # if defined(UPPER) || defined(MUMPS_WIN32) # define F_SYM_ARITH(lower_case,upper_case) CMUMPS_##upper_case # elif defined(Add_) # define F_SYM_ARITH(lower_case,upper_case) cmumps_##lower_case##_ # elif defined(Add__) # define F_SYM_ARITH(lower_case,upper_case) cmumps_##lower_case##__ # else # define F_SYM_ARITH(lower_case,upper_case) cmumps_##lower_case # endif #elif MUMPS_ARITH == MUMPS_ARITH_z # if defined(UPPER) || defined(MUMPS_WIN32) # define F_SYM_ARITH(lower_case,upper_case) ZMUMPS_##upper_case # elif defined(Add_) # define F_SYM_ARITH(lower_case,upper_case) zmumps_##lower_case##_ # elif defined(Add__) # define F_SYM_ARITH(lower_case,upper_case) zmumps_##lower_case##__ # else # define F_SYM_ARITH(lower_case,upper_case) zmumps_##lower_case # endif #endif #define MUMPS_F77 \ F_SYM_ARITH(f77,F77) void MUMPS_CALL MUMPS_F77( MUMPS_INT *job, MUMPS_INT *sym, MUMPS_INT *par, MUMPS_INT *comm_fortran, MUMPS_INT *n, MUMPS_INT *nblk, MUMPS_INT *icntl, MUMPS_REAL *cntl, MUMPS_INT *keep, MUMPS_REAL *dkeep, MUMPS_INT8 *keep8, MUMPS_INT *nz, MUMPS_INT8 *nnz, MUMPS_INT *irn, MUMPS_INT *irn_avail, MUMPS_INT *jcn, MUMPS_INT *jcn_avail, MUMPS_COMPLEX *a, MUMPS_INT *a_avail, MUMPS_INT *nz_loc, MUMPS_INT8 *nnz_loc, MUMPS_INT *irn_loc, MUMPS_INT *irn_loc_avail, MUMPS_INT *jcn_loc, MUMPS_INT *jcn_loc_avail, MUMPS_COMPLEX *a_loc, MUMPS_INT *a_loc_avail, MUMPS_INT *nelt, MUMPS_INT *eltptr, MUMPS_INT *eltptr_avail, MUMPS_INT *eltvar, MUMPS_INT *eltvar_avail, MUMPS_COMPLEX *a_elt, MUMPS_INT *a_elt_avail, MUMPS_INT *blkptr, MUMPS_INT *blkptr_avail, MUMPS_INT *blkvar, MUMPS_INT *blkvar_avail, MUMPS_INT *perm_in, MUMPS_INT *perm_in_avail, MUMPS_INT *rowind, MUMPS_INT *rowind_avail, MUMPS_INT *colind, MUMPS_INT *colind_avail, MUMPS_COMPLEX *pivots, MUMPS_INT *pivots_avail, MUMPS_COMPLEX *rhs, MUMPS_INT *rhs_avail, MUMPS_COMPLEX *redrhs, MUMPS_INT *redrhs_avail, MUMPS_INT *info, MUMPS_REAL *rinfo, MUMPS_INT *infog, MUMPS_REAL *rinfog, MUMPS_INT *deficiency, MUMPS_INT *lwk_user, MUMPS_INT *size_schur, MUMPS_INT *listvar_schur, MUMPS_INT *listvar_schur_avail, MUMPS_COMPLEX *schur, MUMPS_INT *schur_avail, MUMPS_COMPLEX *wk_user, MUMPS_INT *wk_user_avail, MUMPS_REAL *colsca, MUMPS_INT *colsca_avail, MUMPS_REAL *rowsca, MUMPS_INT *rowsca_avail, MUMPS_INT *instance_number, MUMPS_INT *nrhs, MUMPS_INT *lrhs, MUMPS_INT *lredrhs, MUMPS_COMPLEX *rhs_sparse, MUMPS_INT *rhs_sparse_avail, MUMPS_COMPLEX *sol_loc, MUMPS_INT *sol_loc_avail, MUMPS_COMPLEX *rhs_loc, MUMPS_INT *rhs_loc_avail, MUMPS_INT *irhs_sparse, MUMPS_INT *irhs_sparse_avail, MUMPS_INT *irhs_ptr, MUMPS_INT *irhs_ptr_avail, MUMPS_INT *isol_loc, MUMPS_INT *isol_loc_avail, MUMPS_INT *irhs_loc, MUMPS_INT *irhs_loc_avail, MUMPS_INT *nz_rhs, MUMPS_INT *lsol_loc, MUMPS_INT *nloc_rhs, MUMPS_INT *lrhs_loc, MUMPS_INT *nsol_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 *ld_rhsintr, MUMPS_INT *ooc_tmpdir, MUMPS_INT *ooc_prefix, MUMPS_INT *write_problem, #if ! defined(NO_SAVE_RESTORE) MUMPS_INT *save_dir, MUMPS_INT *save_prefix, #endif MUMPS_INT *ooc_tmpdirlen, MUMPS_INT *ooc_prefixlen, MUMPS_INT *write_problemlen, #if ! defined(NO_SAVE_RESTORE) MUMPS_INT *save_dirlen, MUMPS_INT *save_prefixlen, #endif MUMPS_INT *metis_options ); /* * COLSCA and ROWSCA are static. They are passed inside cmumps_f77 but * might also be changed on return by MUMPS_ASSIGN_COLSCA/ROWSCA * NB: They are put here because they use MUMPS_REAL and need thus * one symbol per arithmetic. * COLSCA_LOC and ROWSCA_LOC are also static. However, they are built * at the end of the factorization and are always out arguments, they * cannot be input. * RHSINTR is the intermediate right-hand side. It is always allocated * by MUMPS, although its content can be set or modified by the user. * But the address of RHSINTR is out. */ #if MUMPS_ARITH == MUMPS_ARITH_s # define MUMPS_COLSCA_STATIC SMUMPS_COLSCA_STATIC # define MUMPS_ROWSCA_STATIC SMUMPS_ROWSCA_STATIC # define MUMPS_COLSCA_LOC_STATIC SMUMPS_COLSCA_LOC_STATIC # define MUMPS_ROWSCA_LOC_STATIC SMUMPS_ROWSCA_LOC_STATIC # define MUMPS_RHSINTR_STATIC SMUMPS_RHSINTR_STATIC # define MUMPS_SINGULAR_VALUES_STATIC SMUMPS_SINGULAR_VALUES_STATIC #elif MUMPS_ARITH == MUMPS_ARITH_d # define MUMPS_COLSCA_STATIC DMUMPS_COLSCA_STATIC # define MUMPS_ROWSCA_STATIC DMUMPS_ROWSCA_STATIC # define MUMPS_COLSCA_LOC_STATIC DMUMPS_COLSCA_LOC_STATIC # define MUMPS_ROWSCA_LOC_STATIC DMUMPS_ROWSCA_LOC_STATIC # define MUMPS_RHSINTR_STATIC DMUMPS_RHSINTR_STATIC # define MUMPS_SINGULAR_VALUES_STATIC DMUMPS_SINGULAR_VALUES_STATIC #elif MUMPS_ARITH == MUMPS_ARITH_c # define MUMPS_COLSCA_STATIC CMUMPS_COLSCA_STATIC # define MUMPS_ROWSCA_STATIC CMUMPS_ROWSCA_STATIC # define MUMPS_COLSCA_LOC_STATIC CMUMPS_COLSCA_LOC_STATIC # define MUMPS_ROWSCA_LOC_STATIC CMUMPS_ROWSCA_LOC_STATIC # define MUMPS_RHSINTR_STATIC CMUMPS_RHSINTR_STATIC # define MUMPS_SINGULAR_VALUES_STATIC CMUMPS_SINGULAR_VALUES_STATIC #elif MUMPS_ARITH == MUMPS_ARITH_z # define MUMPS_COLSCA_STATIC ZMUMPS_COLSCA_STATIC # define MUMPS_ROWSCA_STATIC ZMUMPS_ROWSCA_STATIC # define MUMPS_COLSCA_LOC_STATIC ZMUMPS_COLSCA_LOC_STATIC # define MUMPS_ROWSCA_LOC_STATIC ZMUMPS_ROWSCA_LOC_STATIC # define MUMPS_RHSINTR_STATIC ZMUMPS_RHSINTR_STATIC # define MUMPS_SINGULAR_VALUES_STATIC ZMUMPS_SINGULAR_VALUES_STATIC #endif static MUMPS_REAL * MUMPS_COLSCA_STATIC; static MUMPS_REAL * MUMPS_ROWSCA_STATIC; static MUMPS_REAL * MUMPS_COLSCA_LOC_STATIC; static MUMPS_REAL * MUMPS_ROWSCA_LOC_STATIC; static MUMPS_COMPLEX * MUMPS_RHSINTR_STATIC; static MUMPS_REAL * MUMPS_SINGULAR_VALUES_STATIC; #define MUMPS_ASSIGN_COLSCA \ F_SYM_ARITH(assign_colsca,ASSIGN_COLSCA) void MUMPS_CALL MUMPS_ASSIGN_COLSCA(MUMPS_REAL * f77colsca) { MUMPS_COLSCA_STATIC = f77colsca; } #define MUMPS_NULLIFY_C_COLSCA \ F_SYM_ARITH(nullify_c_colsca,NULLIFY_C_COLSCA) void MUMPS_CALL MUMPS_NULLIFY_C_COLSCA() { MUMPS_COLSCA_STATIC = 0; } #define MUMPS_ASSIGN_ROWSCA \ F_SYM_ARITH(assign_rowsca,ASSIGN_ROWSCA) void MUMPS_CALL MUMPS_ASSIGN_ROWSCA(MUMPS_REAL * f77rowsca) { MUMPS_ROWSCA_STATIC = f77rowsca; } #define MUMPS_NULLIFY_C_ROWSCA \ F_SYM_ARITH(nullify_c_rowsca,NULLIFY_C_ROWSCA) void MUMPS_CALL MUMPS_NULLIFY_C_ROWSCA() { MUMPS_ROWSCA_STATIC = 0; } #define MUMPS_ASSIGN_COLSCA_LOC \ F_SYM_ARITH(assign_colsca_loc,ASSIGN_COLSCA_LOC) void MUMPS_CALL MUMPS_ASSIGN_COLSCA_LOC(MUMPS_REAL * f77colsca_loc) { MUMPS_COLSCA_LOC_STATIC = f77colsca_loc; } #define MUMPS_NULLIFY_C_COLSCA_LOC \ F_SYM_ARITH(nullify_c_colsca_loc,NULLIFY_C_COLSCA_LOC) void MUMPS_CALL MUMPS_NULLIFY_C_COLSCA_LOC() { MUMPS_COLSCA_LOC_STATIC = 0; } #define MUMPS_ASSIGN_ROWSCA_LOC \ F_SYM_ARITH(assign_rowsca_loc,ASSIGN_ROWSCA_LOC) void MUMPS_CALL MUMPS_ASSIGN_ROWSCA_LOC(MUMPS_REAL * f77rowsca_loc) { MUMPS_ROWSCA_LOC_STATIC = f77rowsca_loc; } #define MUMPS_NULLIFY_C_ROWSCA_LOC \ F_SYM_ARITH(nullify_c_rowsca_loc,NULLIFY_C_ROWSCA_LOC) void MUMPS_CALL MUMPS_NULLIFY_C_ROWSCA_LOC() { MUMPS_ROWSCA_LOC_STATIC = 0; } #define MUMPS_ASSIGN_RHSINTR \ F_SYM_ARITH(assign_rhsintr,ASSIGN_RHSINTR) void MUMPS_CALL MUMPS_ASSIGN_RHSINTR(MUMPS_COMPLEX * f77rhsintr) { MUMPS_RHSINTR_STATIC = f77rhsintr; } #define MUMPS_NULLIFY_C_RHSINTR \ F_SYM_ARITH(nullify_c_rhsintr,NULLIFY_C_RHSINTR) void MUMPS_CALL MUMPS_NULLIFY_C_RHSINTR() { MUMPS_RHSINTR_STATIC = 0; } #define MUMPS_ASSIGN_SINGULAR_VALUES \ F_SYM_ARITH(assign_singular_values,ASSIGN_SINGULAR_VALUES) void MUMPS_CALL MUMPS_ASSIGN_SINGULAR_VALUES(MUMPS_REAL * f77singular_values) { MUMPS_SINGULAR_VALUES_STATIC = f77singular_values; } #define MUMPS_NULLIFY_C_SING_VALUES \ F_SYM_ARITH(nullify_c_sing_values,NULLIFY_C_SING_VALUES) void MUMPS_CALL MUMPS_NULLIFY_C_SING_VALUES() { MUMPS_SINGULAR_VALUES_STATIC = 0; } /* FIXME: move CMUMPS_SET_TMP_PTR to another file */ #define MUMPS_SET_TMP_PTR \ F_SYM_ARITH(set_tmp_ptr,SET_TMP_PTR) /* Fortran routine MUMPS_SET_TMP_PTR called from C */ #define MUMPS_SET_TMP_PTR_C \ F_SYM_ARITH(set_tmp_ptr_c,SET_TMP_PTR_C) /* C routine MUMPS_SET_TMP_PTR_C called from Fortran */ void MUMPS_SET_TMP_PTR(void *x, MUMPS_INT8 * size); void MUMPS_CALL MUMPS_SET_TMP_PTR_C(MUMPS_INT8 *addr_ptr, MUMPS_INT8 *size) /* called from Fortran */ { /* MUMPS_SET_TMP_PTR sets a static Fortran pointer from an address and a size: size is passed by address The address passed in *addr_ptr, however, *addr_ptr is a MUMPS_INT8 addr_ptr is the pointer to the address we want to pass We cast addr_ptr to a pointer to an address before taking the content *(void *)addr_ptr) */ MUMPS_SET_TMP_PTR(*(void**)addr_ptr, size); /* calls Fortran */ } #if MUMPS_ARITH == MUMPS_ARITH_s # define mumps_c smumps_c # define MUMPS_STRUC_C SMUMPS_STRUC_C #elif MUMPS_ARITH == MUMPS_ARITH_d # define mumps_c dmumps_c # define MUMPS_STRUC_C DMUMPS_STRUC_C #elif MUMPS_ARITH == MUMPS_ARITH_c # define mumps_c cmumps_c # define MUMPS_STRUC_C CMUMPS_STRUC_C #elif MUMPS_ARITH == MUMPS_ARITH_z # define mumps_c zmumps_c # define MUMPS_STRUC_C ZMUMPS_STRUC_C #endif void MUMPS_CALL mumps_c(MUMPS_STRUC_C * mumps_par) { /* * The following local variables will * be passed to the F77 interface. */ MUMPS_INT *icntl; MUMPS_REAL *cntl; MUMPS_INT *keep; MUMPS_REAL *dkeep; MUMPS_INT8 *keep8; MUMPS_INT *irn; MUMPS_INT *jcn; MUMPS_COMPLEX *a; MUMPS_INT *irn_loc; MUMPS_INT *jcn_loc; MUMPS_COMPLEX *a_loc; MUMPS_INT *eltptr, *eltvar; MUMPS_COMPLEX *a_elt; MUMPS_INT *blkptr; MUMPS_INT *blkvar; MUMPS_INT *perm_in; MUMPS_INT perm_in_avail; MUMPS_INT *listvar_schur; MUMPS_INT listvar_schur_avail; MUMPS_COMPLEX *schur; MUMPS_INT schur_avail; MUMPS_INT *rowind; MUMPS_INT *colind; MUMPS_COMPLEX *pivots; MUMPS_INT rowind_avail; MUMPS_INT colind_avail; MUMPS_INT pivots_avail; MUMPS_COMPLEX *rhs; MUMPS_COMPLEX *redrhs; MUMPS_COMPLEX *wk_user; MUMPS_INT wk_user_avail; MUMPS_REAL *colsca; MUMPS_REAL *rowsca; MUMPS_COMPLEX *rhs_sparse, *sol_loc, *rhs_loc; MUMPS_INT *irhs_sparse, *irhs_ptr, *isol_loc, *irhs_loc; MUMPS_INT irn_avail, jcn_avail, a_avail, rhs_avail, redrhs_avail; /* These are actually used * as booleans, but we stick * to simple types for the * C-F77 interface */ MUMPS_INT irn_loc_avail, jcn_loc_avail, a_loc_avail; MUMPS_INT eltptr_avail, eltvar_avail, a_elt_avail; MUMPS_INT blkptr_avail, blkvar_avail; MUMPS_INT colsca_avail, rowsca_avail; MUMPS_INT irhs_ptr_avail, rhs_sparse_avail, sol_loc_avail, rhs_loc_avail; MUMPS_INT irhs_sparse_avail, isol_loc_avail, irhs_loc_avail; MUMPS_INT *info; MUMPS_INT *infog; MUMPS_REAL *rinfo; MUMPS_REAL *rinfog; MUMPS_INT ooc_tmpdir[1023]; MUMPS_INT ooc_prefix[255]; MUMPS_INT write_problem[1023]; #if ! defined(NO_SAVE_RESTORE) MUMPS_INT save_dir[1023]; MUMPS_INT save_prefix[255]; #endif /* Other local variables */ MUMPS_INT idummy; MUMPS_INT *idummyp; MUMPS_REAL rdummy; MUMPS_REAL *rdummyp; MUMPS_COMPLEX cdummy; MUMPS_COMPLEX *cdummyp; /* String lengths to be passed to Fortran by address */ MUMPS_INT ooc_tmpdirlen; MUMPS_INT ooc_prefixlen; #if ! defined(NO_SAVE_RESTORE) MUMPS_INT save_dirlen; MUMPS_INT save_prefixlen; #endif MUMPS_INT write_problemlen; MUMPS_INT *metis_options; int i; static const MUMPS_INT no = 0; static const MUMPS_INT yes = 1; idummyp = &idummy; cdummyp = &cdummy; rdummyp = &rdummy; /* [SDCZ]MUMPS_F77 always calls either * MUMPS_NULLIFY_C_COLSCA or MUMPS_ASSIGN_C_COLSCA * (and ROWSCA). The next two lines are thus not * strictly necessary. */ MUMPS_COLSCA_STATIC=0; MUMPS_ROWSCA_STATIC=0; MUMPS_COLSCA_LOC_STATIC=0; MUMPS_ROWSCA_LOC_STATIC=0; MUMPS_SINGULAR_VALUES_STATIC=0; /* Initialize pointers to zero for job == -1 */ if ( mumps_par->job == -1 ) { /* job = -1: we just reset all pointers to 0 */ mumps_par->irn=0; mumps_par->jcn=0; mumps_par->a=0; mumps_par->rhs=0; mumps_par->wk_user=0; mumps_par->redrhs=0; mumps_par->rowind=0; mumps_par->colind=0; mumps_par->pivots=0; mumps_par->eltptr=0; mumps_par->eltvar=0; mumps_par->a_elt=0; mumps_par->blkptr=0; mumps_par->blkvar=0; mumps_par->perm_in=0; mumps_par->sym_perm=0; mumps_par->uns_perm=0; mumps_par->irn_loc=0;mumps_par->jcn_loc=0;mumps_par->a_loc=0; mumps_par->listvar_schur=0;mumps_par->schur=0;mumps_par->mapping=0;mumps_par->pivnul_list=0;mumps_par->colsca=0;mumps_par->colsca_from_mumps=0;mumps_par->rowsca=0;mumps_par->rowsca_from_mumps=0; mumps_par->colsca_loc=0; mumps_par->rowsca_loc=0; mumps_par->rhs_sparse=0; mumps_par->irhs_sparse=0; mumps_par->sol_loc=0; mumps_par->rhs_loc=0; mumps_par->irhs_ptr=0; mumps_par->isol_loc=0; mumps_par->irhs_loc=0; mumps_par->rhsintr=0; mumps_par->glob2loc_rhs=0; mumps_par->glob2loc_sol=0; mumps_par->singular_values=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"); #if ! defined(NO_SAVE_RESTORE) strcpy(mumps_par->save_dir,"NAME_NOT_INITIALIZED"); strcpy(mumps_par->save_prefix,"NAME_NOT_INITIALIZED"); #endif strncpy(mumps_par->version_number,MUMPS_VERSION,MUMPS_VERSION_MAX_LEN); mumps_par->version_number[MUMPS_VERSION_MAX_LEN+1] = '\0'; /* Next line initializes scalars to arbitrary values. * Some of those will anyway be overwritten during the * call to Fortran routine [SDCZ]MUMPS_INIT_PHASE */ mumps_par->n=0; mumps_par->nblk=0; mumps_par->nz=0; mumps_par->nnz=0; mumps_par->nz_loc=0; mumps_par->nnz_loc=0; mumps_par->nelt=0;mumps_par->instance_number=0;mumps_par->deficiency=0;mumps_par->lwk_user=0;mumps_par->size_schur=0;mumps_par->lrhs=0; mumps_par->lredrhs=0; mumps_par->nrhs=0; mumps_par->nz_rhs=0; mumps_par->lsol_loc=0; mumps_par->nloc_rhs=0; mumps_par->lrhs_loc=0; mumps_par->nsol_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; mumps_par->ld_rhsintr=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); #if ! defined(NO_SAVE_RESTORE) save_dirlen =(int)strlen(mumps_par->save_dir); save_prefixlen=(int)strlen(mumps_par->save_prefix); #endif /* 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 > 1023){ ooc_tmpdirlen=1023; } if(ooc_prefixlen > 255){ ooc_prefixlen=255; } if(write_problemlen > 1023){ write_problemlen=1023; } #if ! defined(NO_SAVE_RESTORE) if(save_dirlen > 1023){ save_dirlen=1023; } if(save_prefixlen > 255){ save_prefixlen=255; } #endif /* * 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(rowind,idummyp); EXTRACT_POINTERS(colind,idummyp); EXTRACT_POINTERS(pivots,cdummyp); EXTRACT_POINTERS(wk_user,cdummyp); EXTRACT_POINTERS(redrhs,cdummyp); EXTRACT_POINTERS(irn_loc,idummyp); EXTRACT_POINTERS(jcn_loc,idummyp); EXTRACT_POINTERS(a_loc,cdummyp); EXTRACT_POINTERS(a,cdummyp); EXTRACT_POINTERS(eltptr,idummyp); EXTRACT_POINTERS(eltvar,idummyp); EXTRACT_POINTERS(a_elt,cdummyp); EXTRACT_POINTERS(blkptr,idummyp); EXTRACT_POINTERS(blkvar,idummyp); EXTRACT_POINTERS(perm_in,idummyp); EXTRACT_POINTERS(listvar_schur,idummyp); EXTRACT_POINTERS(schur,cdummyp); /* EXTRACT_POINTERS not adapted to rowsca and colsca */ if ( mumps_par->rowsca != 0 && mumps_par->rowsca_from_mumps == 0 ) { /* has been set by user and was not allocated in mumps */ rowsca = mumps_par-> rowsca; rowsca_avail = yes; } else { /* Changing the rowsca pointer in C after an earlier call where rowsca was allocated by mumps is not possible. FIXME: check if the content of rowsca could still be modified by the user -- with ICNTL(8) set to -1 -- before calling the next factorization step again. */ rowsca = rdummyp; rowsca_avail = no; } if ( mumps_par->colsca != 0 && mumps_par->colsca_from_mumps == 0 ) /* has been changed by user and was not allocated in mumps */ { colsca = mumps_par-> colsca; colsca_avail = yes; } else { /* Changing the colsca pointer in C after an earlier call where colsca was allocated by mumps is not possible. FIXME: check if the content of colsca could still be modified by the user -- with ICNTL(8) set to -1 -- before calling the next factorization step again. */ colsca = rdummyp; colsca_avail = no; } EXTRACT_POINTERS(rhs_sparse,cdummyp); EXTRACT_POINTERS(sol_loc,cdummyp); EXTRACT_POINTERS(rhs_loc,cdummyp); EXTRACT_POINTERS(irhs_sparse,idummyp); EXTRACT_POINTERS(isol_loc,idummyp); EXTRACT_POINTERS(irhs_loc,idummyp); EXTRACT_POINTERS(irhs_ptr,idummyp); /* printf("irn_avail,jcn_avail, rhs_avail, a_avail, eltptr_avail, eltvar_avail,a_elt_avail,perm_in_avail= %d %d %d %d %d %d %d \n", irn_avail,jcn_avail, rhs_avail, a_avail, eltptr_avail, eltvar_avail, a_elt_avail, perm_in_avail); */ /* * Extract integers (input) or pointers that are * always allocated (such as ICNTL, INFO, ...) */ /* size_schur = mumps_par->size_schur; */ /* instance_number = mumps_par->instance_number; */ icntl = mumps_par->icntl; cntl = mumps_par->cntl; keep = mumps_par->keep; dkeep = mumps_par->dkeep; keep8 = mumps_par->keep8; info = mumps_par->info; infog = mumps_par->infog; rinfo = mumps_par->rinfo; rinfog = mumps_par->rinfog; for(i=0;iooc_tmpdir[i]; } for(i=0;iooc_prefix[i]; } for(i=0;iwrite_problem[i]; } #if ! defined(NO_SAVE_RESTORE) for(i=0;isave_dir[i]; } for(i=0;isave_prefix[i]; } #endif metis_options = mumps_par->metis_options; /* Call F77 interface */ MUMPS_F77(&(mumps_par->job), &(mumps_par->sym), &(mumps_par->par), &(mumps_par->comm_fortran), &(mumps_par->n), &(mumps_par->nblk), icntl, cntl, keep, dkeep, keep8, &(mumps_par->nz), &(mumps_par->nnz), irn, &irn_avail, jcn, &jcn_avail, a, &a_avail, &(mumps_par->nz_loc), &(mumps_par->nnz_loc), irn_loc, &irn_loc_avail, jcn_loc, &jcn_loc_avail, a_loc, &a_loc_avail, &(mumps_par->nelt), eltptr, &eltptr_avail, eltvar, &eltvar_avail, a_elt, &a_elt_avail, blkptr, &blkptr_avail, blkvar, &blkvar_avail, perm_in, &perm_in_avail, rowind, &rowind_avail, colind, &colind_avail, pivots, &pivots_avail, rhs, &rhs_avail, redrhs, &redrhs_avail, info, rinfo, infog, rinfog, &(mumps_par->deficiency), &(mumps_par->lwk_user), &(mumps_par->size_schur), listvar_schur, &listvar_schur_avail, schur, &schur_avail, wk_user, &wk_user_avail, colsca, &colsca_avail, rowsca, &rowsca_avail, &(mumps_par->instance_number), &(mumps_par->nrhs), &(mumps_par->lrhs), &(mumps_par->lredrhs), rhs_sparse, &rhs_sparse_avail, sol_loc, &sol_loc_avail, rhs_loc, &rhs_loc_avail, irhs_sparse, &irhs_sparse_avail, irhs_ptr, &irhs_ptr_avail, isol_loc, &isol_loc_avail, irhs_loc, &irhs_loc_avail, &(mumps_par->nz_rhs), &(mumps_par->lsol_loc), &(mumps_par->lrhs_loc), &(mumps_par->nsol_loc), &(mumps_par->nloc_rhs) , &(mumps_par->schur_mloc) , &(mumps_par->schur_nloc) , &(mumps_par->schur_lld) , &(mumps_par->mblock) , &(mumps_par->nblock) , &(mumps_par->nprow) , &(mumps_par->npcol) , &(mumps_par->ld_rhsintr) , ooc_tmpdir , ooc_prefix , write_problem #if ! defined(NO_SAVE_RESTORE) , save_dir , save_prefix #endif , &ooc_tmpdirlen , &ooc_prefixlen , &write_problemlen #if ! defined(NO_SAVE_RESTORE) , &save_dirlen , &save_prefixlen #endif , metis_options ); /* * Set interface to C (KEEP(500)=1) after job=-1 */ if ( mumps_par->job == -1 ) { mumps_par->keep[499]=1; } /* * mapping and pivnul_list are usually 0 except if * MUMPS_ASSIGN_MAPPING/MUMPS_ASSIGN_PIVNUL_LIST was called. */ mumps_par->mapping=mumps_get_mapping(); mumps_par->pivnul_list=mumps_get_pivnul_list(); /* to get permutations computed during analysis */ mumps_par->sym_perm=mumps_get_sym_perm(); mumps_par->uns_perm=mumps_get_uns_perm(); /* colsca_loc and rowsca_loc are always out */ mumps_par->colsca_loc=MUMPS_COLSCA_LOC_STATIC; mumps_par->rowsca_loc=MUMPS_ROWSCA_LOC_STATIC; /* singular_values is always out */ mumps_par->singular_values=MUMPS_SINGULAR_VALUES_STATIC; /* * colsca/rowsca can either be user data or have been modified * within mumps by calls to MUMPS_ASSIGN_COLSCA and/or * MUMPS_ASSIGN_ROWSCA. In all cases their address is contained * in MUMPS_COLSCA_STATIC and/or MUMPS_ROWSCA_STATIC. * * In case of a null pointer, we also reset mumps_par->rowsca/colsca * to 0 (case of JOB=-2, the Fortran pointer will be NULL but the * C pointer should also be null. */ if (rowsca_avail == no) { mumps_par->rowsca = MUMPS_ROWSCA_STATIC; if (MUMPS_ROWSCA_STATIC) { /* remember that row Scaling was computed by MUMPS */ mumps_par->rowsca_from_mumps=1; } } if (colsca_avail == no) { mumps_par->colsca = MUMPS_COLSCA_STATIC; if (MUMPS_COLSCA_STATIC) { /* remember that column Scaling was computed by MUMPS */ mumps_par->colsca_from_mumps=1; } } /* * Decode OOC_TMPDIR and OOC_PREFIX * This is because they may have been set internally during MUMPS_F77 #if ! defined(NO_SAVE_RESTORE) * (which is not the case for save_prefix and save_dir) #endif */ for(i=0;iooc_tmpdir[i]=(char)ooc_tmpdir[i]; } mumps_par->ooc_tmpdir[ooc_tmpdirlen]='\0'; for(i=0;iooc_prefix[i]=(char)ooc_prefix[i]; } mumps_par->ooc_prefix[ooc_prefixlen]='\0'; } MUMPS_5.8.1/src/sfac_process_contrib_type2.F0000664000175000017500000004712715042446437020675 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, & MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, & N, IW, LIW, A, LA, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, PERM, & COMP, root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, NBFIN, & MYID, COMM, ICNTL, KEEP,KEEP8,DKEEP, IFLAG, IERROR, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_LOAD USE SMUMPS_BUF USE SMUMPS_LR_TYPE USE MUMPS_LR_STATS USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR, & SMUMPS_DM_FREE_BLOCK IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV, MSGLEN INTEGER BUFR( LBUFR ) INTEGER(8) :: LRLU, IPTRLU, LRLUS, LA, POSFAC INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER NBFIN INTEGER COMP INTEGER NELT, LPTRAR INTEGER PROCNODE_STEPS( KEEP(28) ), PTRIST(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER PTLUST( KEEP(28) ) INTEGER PERM(N) INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER ITLOC( N + KEEP(253)), NSTK_S( KEEP(28) ) INTEGER :: FILS( N ), DAD(KEEP(28)) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER ND(KEEP(28)), FRERE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER INTARR( KEEP8(27) ) REAL DBLARR( KEEP8(26) ) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, MYID, IFLAG, IERROR INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER FRTPTR(N+1), FRTELT( NELT ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NFS4FATHER INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPESPLIT INTEGER IERR INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER I, INODE, ISON, POSITION, NBROW, LROW, IROW, INDCOL INTEGER LREQI INTEGER(8) :: LREQA, POSCONTRIB INTEGER ROW_LENGTH INTEGER MASTER INTEGER ISTCHK LOGICAL SAME_PROC LOGICAL SLAVE_NODE LOGICAL IS_ofType5or6 INTEGER ISHIFT_BUFR, LBUFR_LOC, LBUFR_BYTES_LOC INTEGER TYPESPLIT INTEGER DECR INTEGER :: INBPROCFILS_SON LOGICAL :: CB_IS_LR INTEGER :: CB_IS_LR_INT, NBLRB_PACKET, allocok INTEGER :: MAXI_CLUSTER INTEGER :: ICOL_BEG, ICOL_END, ICOL_SHARED INTEGER :: IROW_BEG, IROW_END INTEGER :: NB_BLOCKS_UNPACKED LOGICAL :: BLOCKS_LEFT_2_UNPACK DOUBLE PRECISION :: PROMOTE_COST INTEGER(8) :: LA_TEMP REAL, DIMENSION(:), POINTER :: A_TEMP TYPE (LRB_TYPE) :: LRB INTEGER(8) :: IACHK, SIZFR8, DYN_SIZE REAL, DIMENSION(:), POINTER :: DYNPTR INTEGER :: NSLAVES, NFRONT, NASS1, IOLDPS, PARPIV_T1 INTEGER :: NB_POSTPONED LOGICAL :: LR_ACTIVATED INTEGER(8) :: POSELT INTEGER :: XXG_STATUS INCLUDE 'mumps_headers.h' REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) INTEGER :: NBCOLS_ALREADY_SENT LOGICAL :: IS_PANEL_FINISHED, IS_LROW_NEGATIVE 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 ) IS_LROW_NEGATIVE = (LROW.LT.0) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & CB_IS_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) CB_IS_LR = (CB_IS_LR_INT.EQ.1) IF (CB_IS_LR.AND.LROW.LT.0) THEN LROW = -LROW ENDIF NBCOLS_ALREADY_SENT=0 ICOL_SHARED = -9999 MASTER = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) SLAVE_NODE = MASTER .NE. MYID TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) IF (SLAVE_NODE .AND. PTRIST(STEP(INODE)) ==0) THEN ISHIFT_BUFR = ( MSGLEN + KEEP(34) ) / KEEP(34) LBUFR_LOC = LBUFR - ISHIFT_BUFR + 1 LBUFR_BYTES_LOC = LBUFR_LOC * KEEP(34) CALL SMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR(ISHIFT_BUFR), LBUFR_LOC, LBUFR_BYTES_LOC, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (IFLAG.LT.0) RETURN ENDIF IF ( SLAVE_NODE ) THEN LREQI = LROW + NBROWS_PACKET ELSE LREQI = NBROWS_PACKET END IF LREQA = int(LROW,8) CALL SMUMPS_GET_SIZE_NEEDED( & LREQI, LREQA, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR ) IF (IFLAG.LT.0) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA POSCONTRIB = POSFAC POSFAC = POSFAC + LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) IF ( SLAVE_NODE ) THEN IROW = IWPOS INDCOL = IWPOS + NBROWS_PACKET ELSE IROW = IWPOS INDCOL = -1 END IF IWPOS = IWPOS + LREQI IF ( SLAVE_NODE ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( INDCOL ), LROW, MPI_INTEGER, & COMM, IERR ) END IF DO I = 1, NBROWS_PACKET CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IROW + I - 1 ), 1, MPI_INTEGER, & COMM, IERR ) END DO IF (CB_IS_LR.AND.(NBROWS_PACKET.GT.0)) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBLRB_PACKET, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBCOLS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR ) ICOL_SHARED = 1+NBCOLS_ALREADY_SENT ENDIF IF ( SLAVE_NODE ) THEN IF ( KEEP(55) .eq. 0 ) THEN CALL SMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, INODE, IW, LIW, A, LA, & NBROW, LROW, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ELSE CALL SMUMPS_ELT_ASM_S_2_S_INIT( & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, & NBROW, LROW, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ENDIF ENDIF IF (CB_IS_LR.AND.(NBROWS_PACKET.GT.0)) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & MAXI_CLUSTER, 1, & MPI_INTEGER, COMM, IERR ) IROW_BEG = 1 IROW_END = NBROWS_PACKET LA_TEMP = NBROWS_PACKET*MAXI_CLUSTER NB_BLOCKS_UNPACKED = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(A_TEMP, LRB, I, ICOL_BEG, !$OMP& ICOL_END, ROW_LENGTH, allocok, BLOCKS_LEFT_2_UNPACK, !$OMP& PROMOTE_COST) #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) nullify(A_TEMP) IF (LA_TEMP.GT.0) THEN allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 550 ENDIF ENDIF BLOCKS_LEFT_2_UNPACK = .TRUE. DO WHILE (BLOCKS_LEFT_2_UNPACK) #if ! defined(BLR_NOOPENMP) !$OMP CRITICAL(contrib_type2_lrcb) #endif IF (NB_BLOCKS_UNPACKED.LT.NBLRB_PACKET) THEN CALL SMUMPS_MPI_UNPACK_LRB(BUFR, LBUFR, & LBUFR_BYTES, POSITION, LRB, KEEP8, & COMM, IFLAG, IERROR & ) NB_BLOCKS_UNPACKED = NB_BLOCKS_UNPACKED + 1 ICOL_BEG = ICOL_SHARED ICOL_SHARED = ICOL_SHARED + LRB%N ELSE BLOCKS_LEFT_2_UNPACK = .FALSE. ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END CRITICAL(contrib_type2_lrcb) #endif IF (.NOT.BLOCKS_LEFT_2_UNPACK) CYCLE IF (LRB%ISLR .AND. LRB%K.EQ.0) CYCLE IF (LRB%ISLR) THEN CALL sgemm('T','T', LRB%N, NBROWS_PACKET, LRB%K, ONE, & LRB%R(1,1), LRB%K, LRB%Q(IROW_BEG,1), LRB%M, & ZERO, A_TEMP(1), LRB%N) PROMOTE_COST = 2.0D0*LRB%N*NBROWS_PACKET*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE DO I = IROW_BEG, IROW_END A_TEMP( 1+(I-IROW_BEG)*LRB%N : (I-IROW_BEG+1)*LRB%N ) & = LRB%Q(I,1:LRB%N) ENDDO ENDIF CALL DEALLOC_LRB(LRB, KEEP8, KEEP(34)) DO I=1,NBROWS_PACKET IF (KEEP(50).EQ.0) THEN ROW_LENGTH = LROW ELSE ROW_LENGTH = LROW - NBROWS_PACKET + I ENDIF ICOL_END = min(ICOL_BEG+LRB%N-1, ROW_LENGTH) IF (SLAVE_NODE) THEN CALL SMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & 1, ICOL_END-ICOL_BEG+1, IW( IROW+I-1 ), & IW(INDCOL+ICOL_BEG-1), & A_TEMP(1+(I-1)*LRB%N), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, & LROW) ELSE CALL SMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, 1, ICOL_END-ICOL_BEG+1, IW( IROW+I-1 ), & A_TEMP(1+(I-1)*LRB%N), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LROW, ICOL_BEG & ) ENDIF ENDDO ENDDO IF (associated(A_TEMP)) deallocate(A_TEMP) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) 550 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) RETURN ELSE DO I=1,NBROWS_PACKET IF (KEEP(50).NE.0) THEN ROW_LENGTH = LROW - NBROWS_PACKET + I ELSE ROW_LENGTH = LROW ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSCONTRIB), & ROW_LENGTH, & MPI_REAL, & COMM, IERR ) IF (SLAVE_NODE) THEN CALL SMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & 1, ROW_LENGTH, IW( IROW+I-1 ),IW(INDCOL), & A(POSCONTRIB), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, & ROW_LENGTH ) ELSE CALL SMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, 1, ROW_LENGTH, IW( IROW +I-1 ), & A(POSCONTRIB), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, ROW_LENGTH, 1 ) ENDIF ENDDO ENDIF IF (SLAVE_NODE) THEN IF (CB_IS_LR) THEN IF (NBROWS_PACKET.EQ.0) THEN IS_PANEL_FINISHED = .TRUE. ELSE IS_PANEL_FINISHED = ICOL_SHARED .GT. LROW ENDIF ELSE IS_PANEL_FINISHED = .TRUE. ENDIF IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW & .AND. IS_PANEL_FINISHED ) THEN IW(PTRIST(STEP(INODE))+XXNBPR) = & IW(PTRIST(STEP(INODE))+XXNBPR) - NBROW ENDIF CALL SMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, & NBROWS_PACKET, STEP, PTRIST, & ITLOC, RHS_MUMPS,KEEP,KEEP8) ENDIF IF ( .NOT. SLAVE_NODE ) THEN IF ( (NBROWS_ALREADY_SENT .EQ. 0) & .AND. (NBCOLS_ALREADY_SENT .EQ. 0) & ) THEN IF (KEEP(219).NE.0) THEN IF(KEEP(50) .EQ. 2) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NFS4FATHER, & 1, & MPI_INTEGER, & COMM, IERR ) IF(NFS4FATHER .GT. 0) THEN CALL SMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERROR = BUF_LMAX_ARRAY IFLAG = -13 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BUF_MAX_ARRAY, & NFS4FATHER, & MPI_REAL, & COMM, IERR ) CALL SMUMPS_ASM_MAX(N, INODE, IW, LIW, A, LA, & ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8) ENDIF ENDIF ENDIF ENDIF IF (CB_IS_LR) THEN IF (NBROWS_PACKET.EQ.0) THEN IS_PANEL_FINISHED = .TRUE. ELSE IS_PANEL_FINISHED = ICOL_SHARED .GT. LROW ENDIF ELSE IS_PANEL_FINISHED = .TRUE. ENDIF IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW & .AND. IS_PANEL_FINISHED ) THEN DECR = 1 ISTCHK = PIMASTER(STEP(ISON)) SAME_PROC = ISTCHK .LT. IWPOSCB IW(PTLUST(STEP(INODE))+XXNBPR) = & IW(PTLUST(STEP(INODE))+XXNBPR) - DECR IF (SAME_PROC) THEN INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR ELSE INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ENDIF IW(INBPROCFILS_SON) = IW(INBPROCFILS_SON) - DECR IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN IF (SAME_PROC) THEN CALL SMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST, IW, LIW, STEP, KEEP,KEEP8) ENDIF IF (SAME_PROC) THEN ISTCHK = PTRIST(STEP(ISON)) PTRIST(STEP( ISON) ) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL SMUMPS_DM_SET_DYNPTR( IW(ISTCHK+XXS), A, LA, & PAMASTER(STEP(ISON)), IW(ISTCHK+XXD), & IW(ISTCHK+XXR), DYNPTR, IACHK, SIZFR8) CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK+XXD)) XXG_STATUS = IW(ISTCHK+XXG) CALL SMUMPS_FREE_BLOCK_CB_STATIC( & .FALSE., MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) IF ( DYN_SIZE .GT. 0_8 ) THEN CALL SMUMPS_DM_FREE_BLOCK( XXG_STATUS, & DYNPTR, DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF IF (IW(PTLUST(STEP(INODE))+XXNBPR) .EQ. 0) THEN IOLDPS = PTLUST(STEP(INODE)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) IF (NSLAVES.EQ.0) THEN NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS1 = abs(IW(IOLDPS + 2+KEEP(IXSZ))) POSELT = PTRAST(STEP(INODE)) PARPIV_T1 = -999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) NB_POSTPONED = max(NFRONT - ND(STEP(INODE)),0) CALL SMUMPS_PARPIVT1_SET_NVSCHUR_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1, & NB_POSTPONED) ENDIF CALL SMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, INODE+N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ENDIF ENDIF END IF IWPOS = IWPOS - LREQI LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA POSFAC = POSFAC - LREQA CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) RETURN END SUBROUTINE SMUMPS_PROCESS_CONTRIB_TYPE2 MUMPS_5.8.1/src/cfac_sispointers_m.F0000664000175000017500000000153015042446441017211 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC_S_IS_POINTERS_M C ---------------------------------- C This module defines a type used in C CMUMPS_FAC_DRIVER and CMUMPS_FAC_B C ---------------------------------- TYPE CMUMPS_S_IS_POINTERS_T COMPLEX, POINTER, DIMENSION(:) :: A INTEGER, POINTER, DIMENSION(:) :: IW END TYPE CMUMPS_S_IS_POINTERS_T END MODULE CMUMPS_FAC_S_IS_POINTERS_M MUMPS_5.8.1/src/zfac_distrib_ELT.F0000664000175000017500000004563515042446441016524 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ELT_DISTRIB( & N, NELT, NA_ELT8, & COMM, MYID, SLAVEF, & IELPTR_LOC8, RELPTR_LOC8, & ELTVAR_LOC, ELTVAL_LOC, & LINTARR, LDBLARR, & KEEP,KEEP8, MAXELT_SIZE, & FRTPTR, FRTELT, A, LA, FILS, & id, root, roota ) USE ZMUMPS_STRUC_DEF USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, NELT INTEGER(8) :: NA_ELT8 INTEGER COMM, MYID, SLAVEF, MAXELT_SIZE, MSGLEN INTEGER(8), intent(IN) :: LA INTEGER FRTPTR( N+1 ) INTEGER FRTELT( NELT ), FILS ( N ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), INTENT(IN) :: IELPTR_LOC8( NELT + 1 ) INTEGER(8), INTENT(INOUT) :: RELPTR_LOC8( NELT + 1 ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER ELTVAR_LOC( LINTARR ) COMPLEX(kind=8) ELTVAL_LOC( LDBLARR ) COMPLEX(kind=8) A( LA ) TYPE(ZMUMPS_STRUC) :: id TYPE(MUMPS_ROOT_STRUC) :: root TYPE(ZMUMPS_ROOT_STRUC) :: roota INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGTAG INTEGER allocok INTEGER I, DEST, MAXELT_REAL_SIZE, MPG, IEL, SIZEI, SIZER INTEGER NBRECORDS, NBUF INTEGER(8) :: RECV_IELTPTR8 INTEGER(8) :: RECV_RELTPTR8 INTEGER(8) :: IELTPTR8, RELTPTR8 LOGICAL FINI, PROKG, I_AM_SLAVE, EARLYT3ROOTINS INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, LP, IBEG, IGLOB, JGLOB INTEGER ARROW_ROOT INTEGER IELT, J, NB_REC, IREC INTEGER(8) :: K8, IVALPTR8 INTEGER ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, IPTR INTEGER JCOL_GRID, IROW_GRID INTEGER NBELROOT INTEGER MASTER PARAMETER( MASTER = 0 ) COMPLEX(kind=8) VAL COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER, DIMENSION( :, : ), ALLOCATABLE :: BUFI COMPLEX(kind=8), DIMENSION( :, : ), ALLOCATABLE :: BUFR COMPLEX(kind=8), DIMENSION( : ), ALLOCATABLE :: TEMP_ELT_R INTEGER, DIMENSION( : ), ALLOCATABLE :: TEMP_ELT_I INTEGER(8), DIMENSION( : ), ALLOCATABLE :: ELROOTPOS8 MPG = id%ICNTL(3) LP = id%ICNTL(1) I_AM_SLAVE = ( KEEP(46) .eq. 1 .or. MYID .ne.MASTER ) PROKG = ( MPG > 0 .and. MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) KEEP(49) = 0 ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) IF ( MYID .eq. MASTER ) THEN IF ( KEEP(46) .eq. 0 ) THEN NBUF = SLAVEF ELSE NBUF = SLAVEF - 1 END IF NBRECORDS = KEEP(39) IF (NA_ELT8 < int(NBRECORDS,8)) THEN NBRECORDS = int(NA_ELT8) ENDIF IF ( KEEP(50) .eq. 0 ) THEN MAXELT_REAL_SIZE = MAXELT_SIZE * MAXELT_SIZE ELSE MAXELT_REAL_SIZE = MAXELT_SIZE * (MAXELT_SIZE+1)/2 END IF IF ( MAXELT_REAL_SIZE .GT. KEEP(39) ) THEN NBRECORDS = MAXELT_REAL_SIZE IF ( MPG .GT. 0 ) THEN WRITE(MPG,*) & ' ** Warning : For element distrib NBRECORDS set to ', & MAXELT_REAL_SIZE,' because one element is large' END IF END IF ALLOCATE( BUFI( 2*NBRECORDS+1, NBUF ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 2*NBRECORDS + 1 GOTO 100 END IF ALLOCATE( BUFR( NBRECORDS+1, NBUF ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS + 1 GOTO 100 END IF IF ( KEEP(52) .ne. 0 ) THEN ALLOCATE( TEMP_ELT_R( MAXELT_REAL_SIZE ), stat =allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXELT_REAL_SIZE GOTO 100 END IF END IF ALLOCATE( TEMP_ELT_I( MAXELT_SIZE ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXELT_SIZE GOTO 100 END IF IF ( KEEP(38) .ne. 0 ) THEN NBELROOT = FRTPTR(KEEP(38)+1)-FRTPTR(KEEP(38)) IF ( EARLYT3ROOTINS ) THEN ALLOCATE( ELROOTPOS8( max(NBELROOT,1) ), & stat = allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBELROOT GOTO 100 END IF ENDIF END IF DO I = 1, NBUF BUFI( 1, I ) = 0 BUFR( 1, I ) = ZERO END DO END IF 100 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MPI_BCAST( NBRECORDS, 1, MPI_INTEGER, MASTER, & COMM, IERR_MPI ) RECV_IELTPTR8 = 1_8 RECV_RELTPTR8 = 1_8 IF ( MYID .eq. MASTER ) THEN NBELROOT = 0 RELTPTR8 = 1_8 RELPTR_LOC8(1) = 1 DO IEL = 1, NELT IELTPTR8 = int(id%ELTPTR( IEL ),8) SIZEI = int(int(id%ELTPTR( IEL + 1 ),8) - IELTPTR8) IF ( KEEP( 50 ) .eq. 0 ) THEN SIZER = SIZEI * SIZEI ELSE SIZER = SIZEI * ( SIZEI + 1 ) / 2 END IF DEST = id%ELTPROC( IEL ) IF ( DEST .eq. -2 ) THEN NBELROOT = NBELROOT + 1 FRTELT( FRTPTR(KEEP(38)) + NBELROOT - 1 ) = IEL ELROOTPOS8( NBELROOT ) = RELTPTR8 GOTO 200 END IF IF ( DEST .ge. 0 .and. KEEP(46) .eq. 0 ) DEST = DEST + 1 IF ( KEEP(52) .ne. 0 ) THEN CALL ZMUMPS_SCALE_ELEMENT( N, SIZEI, SIZER, & id%ELTVAR( IELTPTR8 ), id%A_ELT( RELTPTR8 ), & TEMP_ELT_R(1), MAXELT_REAL_SIZE, & id%ROWSCA(1), id%COLSCA(1), KEEP(50) ) END IF IF ( DEST .eq. 0 .or. ( DEST .eq. -1 .and. KEEP(46) .ne. 0 ) ) & THEN ELTVAR_LOC( RECV_IELTPTR8: RECV_IELTPTR8 + SIZEI - 1 ) & = id%ELTVAR( IELTPTR8: IELTPTR8 + SIZEI - 1 ) RECV_IELTPTR8 = RECV_IELTPTR8 + SIZEI IF ( KEEP(52) .ne. 0 & ) THEN ELTVAL_LOC( RECV_RELTPTR8: RECV_RELTPTR8 + SIZER - 1) & = TEMP_ELT_R( 1: SIZER ) RECV_RELTPTR8 = RECV_RELTPTR8 + SIZER END IF END IF IF ( DEST .NE. 0 .AND. DEST. NE. -3 ) THEN IF ( KEEP(52) .eq. 0 ) THEN CALL ZMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & id%A_ELT (RELTPTR8), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) ELSE CALL ZMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & TEMP_ELT_R( 1 ), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) END IF END IF 200 CONTINUE RELTPTR8 = RELTPTR8 + SIZER IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN RELPTR_LOC8( IEL + 1 ) = RELTPTR8 ELSE RELPTR_LOC8( IEL + 1 ) = RECV_RELTPTR8 ENDIF END DO IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN KEEP8(26) = RELTPTR8 - 1_8 ELSE KEEP8(26) = RECV_RELTPTR8 - 1_8 ENDIF IF ( RELTPTR8 - 1_8 .NE. NA_ELT8 ) THEN WRITE(*,*) " ** Internal error in ZMUMPS_ELT_DISTRIB", & RELTPTR8 - 1_8, NA_ELT8 CALL MUMPS_ABORT() END IF DEST = -2 IELTPTR8 = 1_8 RELTPTR8 = 1_8 SIZEI = 1 SIZER = 1 CALL ZMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & id%A_ELT (RELTPTR8), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) IF ( KEEP(52) .NE. 0 ) DEALLOCATE( TEMP_ELT_R ) ELSE FINI = ( RECV_IELTPTR8 .eq. IELPTR_LOC8( NELT+1 ) & .and. RECV_RELTPTR8 .eq. RELPTR_LOC8( NELT+1 ) ) DO WHILE ( .not. FINI ) CALL MPI_PROBE( MASTER, MPI_ANY_TAG, & COMM, STATUS, IERR_MPI ) MSGTAG = STATUS( MPI_TAG ) SELECT CASE ( MSGTAG ) CASE( ELT_INT ) CALL MPI_GET_COUNT( STATUS, MPI_INTEGER, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAR_LOC( RECV_IELTPTR8 ), MSGLEN, & MPI_INTEGER, MASTER, ELT_INT, & COMM, STATUS, IERR_MPI ) RECV_IELTPTR8 = RECV_IELTPTR8 + MSGLEN CASE( ELT_REAL ) CALL MPI_GET_COUNT( STATUS, MPI_DOUBLE_COMPLEX, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAL_LOC( RECV_RELTPTR8 ), MSGLEN, & MPI_DOUBLE_COMPLEX, MASTER, ELT_REAL, & COMM, STATUS, IERR_MPI ) RECV_RELTPTR8 = RECV_RELTPTR8 + MSGLEN END SELECT FINI = ( RECV_IELTPTR8 .eq. IELPTR_LOC8( NELT+1 ) & .and. RECV_RELTPTR8 .eq. RELPTR_LOC8( NELT+1 ) ) END DO END IF IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN IF ( I_AM_SLAVE .and. root%yes ) THEN CALL ZMUMPS_GET_ROOT_INFO(root, & LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL ZMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) END IF IF ( MYID .NE. MASTER ) THEN ALLOCATE( BUFI( NBRECORDS * 2 + 1, 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS * 2 + 1 GOTO 250 END IF ALLOCATE( BUFR( NBRECORDS, 1 ) , stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS END IF END IF 250 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF ( MYID .eq. MASTER ) THEN DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1 IELT = FRTELT( IPTR ) SIZEI = id%ELTPTR( IELT + 1 ) - id%ELTPTR( IELT ) DO I = 1, SIZEI TEMP_ELT_I( I ) = root%RG2L & ( id%ELTVAR( id%ELTPTR(IELT) + I - 1 ) ) END DO IVALPTR8 = ELROOTPOS8( IPTR - FRTPTR(KEEP(38)) + 1 ) - 1 K8 = 1_8 DO J = 1, SIZEI JGLOB = id%ELTVAR( id%ELTPTR( IELT ) + J - 1 ) IF ( KEEP(50).eq. 0 ) THEN IBEG = 1 ELSE IBEG = J END IF DO I = IBEG, SIZEI IGLOB = id%ELTVAR( id%ELTPTR( IELT ) + I - 1 ) IF ( KEEP(52) .eq. 0 ) THEN VAL = id%A_ELT( IVALPTR8 + K8 ) ELSE VAL = id%A_ELT( IVALPTR8 + K8 ) * & id%ROWSCA( IGLOB ) * id%COLSCA( JGLOB ) END IF IF ( KEEP(50).eq.0 ) THEN IPOSROOT = TEMP_ELT_I( I ) JPOSROOT = TEMP_ELT_I( J ) ELSE IF ( TEMP_ELT_I(I) .GT. TEMP_ELT_I(J) ) THEN IPOSROOT = TEMP_ELT_I(I) JPOSROOT = TEMP_ELT_I(J) ELSE IPOSROOT = TEMP_ELT_I(J) JPOSROOT = TEMP_ELT_I(I) END IF END IF IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, & root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, & root%NPCOL ) IF ( KEEP(46) .eq. 0 ) THEN DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * root%NPCOL + JCOL_GRID END IF IF ( DEST .eq. MASTER ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 ARROW_ROOT = ARROW_ROOT + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & + VAL ENDIF ELSE CALL ZMUMPS_ARROW_FILL_SEND_BUF_ELT( & IPOSROOT, JPOSROOT, VAL, DEST, BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM ) END IF K8 = K8 + 1_8 END DO END DO END DO CALL ZMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM, KEEP(46) ) ELSE FINI = .FALSE. DO WHILE ( .not. FINI ) CALL MPI_RECV( BUFI(1,1), 2*NBRECORDS+1, & MPI_INTEGER, MASTER, & ARROWHEAD, & COMM, STATUS, IERR_MPI ) NB_REC = BUFI(1,1) ARROW_ROOT = ARROW_ROOT + NB_REC IF (NB_REC.LE.0) THEN FINI = .TRUE. NB_REC = -NB_REC ENDIF IF (NB_REC.EQ.0) EXIT CALL MPI_RECV( BUFR(1,1), NBRECORDS, MPI_DOUBLE_COMPLEX, & MASTER, ARROWHEAD, & COMM, STATUS, IERR_MPI ) DO IREC = 1, NB_REC IPOSROOT = BUFI( IREC * 2, 1 ) JPOSROOT = BUFI( IREC * 2 + 1, 1 ) VAL = BUFR( IREC, 1 ) ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60).eq.0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) & = A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) & + VAL ELSE roota%SCHUR_POINTER(int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF END DO END DO DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) END IF END IF IF ( MYID .eq. MASTER ) THEN DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) IF (allocated(ELROOTPOS8)) DEALLOCATE(ELROOTPOS8) DEALLOCATE( TEMP_ELT_I ) END IF KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE ZMUMPS_ELT_DISTRIB SUBROUTINE ZMUMPS_ELT_FILL_BUF( & ELNODES, ELVAL, SIZEI, SIZER, & DEST, NBUF, NBRECORDS, BUFI, BUFR, COMM ) IMPLICIT NONE INTEGER SIZEI, SIZER, DEST, NBUF, NBRECORDS, COMM INTEGER ELNODES( SIZEI ), BUFI( 2*NBRECORDS + 1, NBUF ) COMPLEX(kind=8) ELVAL( SIZER ), BUFR( NBRECORDS + 1, NBUF ) INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER I, IBEG, IEND, IERR_MPI, NBRECR INTEGER NBRECI COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) IF ( DEST .lt. 0 ) THEN IBEG = 1 IEND = NBUF ELSE IBEG = DEST IEND = DEST END IF DO I = IBEG, IEND NBRECI = BUFI(1,I) IF ( NBRECI .ne.0 .and. & ( DEST.eq.-2 .or. & NBRECI + SIZEI .GT. 2*NBRECORDS ) ) THEN CALL MPI_SEND( BUFI(2, I), NBRECI, MPI_INTEGER, & I, ELT_INT, COMM, IERR_MPI ) BUFI(1,I) = 0 NBRECI = 0 END IF NBRECR = int(dble(BUFR(1,I))+0.5D0) IF ( NBRECR .ne.0 .and. & ( DEST.eq.-2 .or. & NBRECR + SIZER .GT. NBRECORDS ) ) THEN CALL MPI_SEND( BUFR(2, I), NBRECR, MPI_DOUBLE_COMPLEX, & I, ELT_REAL, COMM, IERR_MPI ) BUFR(1,I) = ZERO NBRECR = 0 END IF IF ( DEST .ne. -2 ) THEN BUFI( 2 + NBRECI : 2 + NBRECI + SIZEI - 1, I ) = & ELNODES( 1: SIZEI ) BUFR( 2 + NBRECR : 2 + NBRECR + SIZER - 1, I ) = & ELVAL( 1: SIZER ) BUFI(1,I) = NBRECI + SIZEI BUFR(1,I) = cmplx( NBRECR + SIZER, kind=kind(BUFR) ) END IF END DO RETURN END SUBROUTINE ZMUMPS_ELT_FILL_BUF SUBROUTINE ZMUMPS_MAXELT_SIZE( ELTPTR, NELT, MAXELT_SIZE ) INTEGER NELT, MAXELT_SIZE INTEGER ELTPTR( NELT + 1 ) INTEGER I, S MAXELT_SIZE = 0 DO I = 1, NELT S = ELTPTR( I + 1 ) - ELTPTR( I ) MAXELT_SIZE = max( S, MAXELT_SIZE ) END DO RETURN END SUBROUTINE ZMUMPS_MAXELT_SIZE SUBROUTINE ZMUMPS_SCALE_ELEMENT( N, SIZEI, SIZER, & ELTVAR, ELTVAL, & SELTVAL, LSELTVAL, & ROWSCA, COLSCA, K50 ) INTEGER N, SIZEI, SIZER, LSELTVAL, K50 INTEGER ELTVAR( SIZEI ) COMPLEX(kind=8) ELTVAL( SIZER ) COMPLEX(kind=8) SELTVAL( LSELTVAL ) DOUBLE PRECISION ROWSCA( N ), COLSCA( N ) INTEGER I, J, K K = 1 IF ( K50 .eq. 0 ) THEN DO J = 1, SIZEI DO I = 1, SIZEI SELTVAL(K) = ELTVAL(K) * & ROWSCA(ELTVAR(I)) * & COLSCA(ELTVAR(J)) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI DO I = J, SIZEI SELTVAL(K) = ELTVAL(K) * & ROWSCA(ELTVAR(I)) * & COLSCA(ELTVAR(J)) K = K + 1 END DO END DO END IF RETURN END SUBROUTINE ZMUMPS_SCALE_ELEMENT MUMPS_5.8.1/src/ve/0000775000175000017500000000000015042446442013644 5ustar amestoyamestoyMUMPS_5.8.1/src/ve/include/0000775000175000017500000000000015042446442015267 5ustar amestoyamestoyMUMPS_5.8.1/src/ve/include/VE_Metis.h0000664000175000017500000000122315042446442017111 0ustar amestoyamestoy/* ----------------------------------------------------------------------- NEC Vector Host MUMPS Library Interface ----------------------------------------------------------------------- */ #if ! defined VE_METIS_H #define VE_METIS_H /* Includes */ #include #include #include #include #include #include #include /* Macros */ #define NECVH_MAX_LIBNAME 2048 #define mumps_abort mumps_abort_ void mumps_abort(void); /* Functions prototype */ int VE_Metis_setdefaultoptions( int * ); int VE_Metis_nodend( int * , int * , int * , int * , int * , int * , int * ); #endif MUMPS_5.8.1/src/ve/include/VE_Mumps.h0000664000175000017500000000371615042446442017142 0ustar amestoyamestoy/* ----------------------------------------------------------------------- NEC Vector Host MUMPS Library Interface ----------------------------------------------------------------------- */ #if ! defined VE_MUMPS_H #define VE_MUMPS_H /* Includes */ #include #include #include #include #include #include #include /* Macros */ #define NECVH_MAX_LIBNAME 2048 /* MUMPS functions called prototype */ #define mumps_abort mumps_abort_ void mumps_abort(void); /* Functions prototype */ void VE_Mumps_ana_h( int TOTEL , bool COMPUTE_PERM , int N , int64_t IWLEN , int64_t * PE , int64_t * PFREE , int * LEN , int * IW , int * NV , int * ELEN , int * LAST , int * NCMPA , int * DEGREE , int * HEAD , int * NEXT , int * W , int * PARENT ); void VE_Mumps_symqamd( int THRESH , int * NDENSE , int N , int TOTEL , int64_t IWLEN , int64_t * PE , int64_t * PFREE , int * LEN , int * IW , int * NV , int * ELEN , int * LAST , int * NCMPA , int * DEGREE , int * HEAD , int * NEXT , int * W , int * PERM , int * LISTVAR_SCHUR , int SIZE_SCHUR , int AGG6 , int * PARENT ); void VE_Mumps_wrap_ginp94( int N , int64_t * IPE , int * IW , int64_t LIW8 , int * PERM , int * SizeOfBlocks , int KEEP60 , int * LISTVAR_SCHUR , int SIZE_SCHUR , int KEEP378 , int * COLCOUNT , int * PARENT , int * PORDER , int * IWTMP1 , int * IWTMP2 , int * IWTMP3 , int * IWTMP4 , int * IWTMP5 , int * INFO ); #endif MUMPS_5.8.1/src/ve/include/ve.h0000664000175000017500000000043515042446442016054 0ustar amestoyamestoy#if defined ( __ve__ ) #if defined ( VHOFFLOAD ) #define METIS_NODEND VE_FMETIS_NODEND #define METIS_SETDEFAULTOPTIONS VE_FMETIS_SETDEFAULTOPTIONS #define MUMPS_ANA_H VE_FMUMPS_ANA_H #define MUMPS_SYMQAMD VE_FMUMPS_SYMQAMD #define MUMPS_WRAP_GINP94 VE_FMUMPS_WRAP_GINP94 #endif #endif MUMPS_5.8.1/src/ve/src/0000775000175000017500000000000015042446442014433 5ustar amestoyamestoyMUMPS_5.8.1/src/ve/src/VE_Mumps_ana_h.c0000664000175000017500000002320115042446442017416 0ustar amestoyamestoy/* * ----------------------------------------------------------------------- * NEC Vector Host MUMPS Library Interface * ----------------------------------------------------------------------- */ #include /* * --------------------------------------------------------------------------- * VE_Mumps_ana_h * --------------------------------------------------------------------------- */ void VE_Mumps_ana_h( int TOTEL , bool COMPUTE_PERM , int N , int64_t IWLEN , int64_t * PE , int64_t * PFREE , int * LEN , int * IW , int * NV , int * ELEN , int * LAST , int * NCMPA , int * DEGREE , int * HEAD , int * NEXT , int * W , int * PARENT ) { int ret=1; int64_t symid; vhcall_handle handle; vhcall_args *ca; uint64_t retval; char * env_metis_lib_name; char metis_lib_name[ NECVH_MAX_LIBNAME ]; /* * ----------------------------------------------------------------------- * Set the library name ( check environment ) * ----------------------------------------------------------------------- */ if ( env_metis_lib_name = getenv( "VH_MUMPS_LIBRARY" ) ) { size_t lenv = strlen( env_metis_lib_name ); if ( strlen( env_metis_lib_name ) > (size_t)NECVH_MAX_LIBNAME ) { fprintf( stdout , "%s @ %d failed : metis library name too long (%s)\n" , basename(__FILE__) , __LINE__ , env_metis_lib_name ); fflush( stdout ); (void) mumps_abort(); } else { memcpy( ( void * ) metis_lib_name , ( void * ) env_metis_lib_name , lenv * sizeof( char) ); metis_lib_name[ lenv ] = '\0'; fprintf( stdout , "%s @ %d input library %s\n" , basename(__FILE__) , __LINE__ , metis_lib_name ); fflush( stdout ); } } else { strcpy( metis_lib_name , "libvh.so" ); } /* * ----------------------------------------------------------------------- * Load VH C library * ----------------------------------------------------------------------- */ handle = vhcall_install( metis_lib_name ); if (handle == (vhcall_handle)-1) { perror("vhcall_install"); fprintf( stdout , "%s @ %d failed : can't install library %s\n" , basename(__FILE__) , __LINE__ , metis_lib_name ); fprintf( stdout , "Please check your LD_LIBRARY_PATH variable\n"); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Find VH C library function * ----------------------------------------------------------------------- */ symid = vhcall_find(handle, "mumps_ana_h_"); if ( symid == -1 ) { fprintf( stdout , "%s @ %d failed : can't find symbol MUMPS_ANA_H\n" , basename(__FILE__) , __LINE__ ); perror("vhcall_find"); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Allocate arguments object for VH library function * ----------------------------------------------------------------------- */ ca = vhcall_args_alloc(); if ( ! ca ) { perror("vhcall_args_alloc"); fprintf( stdout , "%s @ %d failed : unable to allocate function's argument list\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Set arguments * ----------------------------------------------------------------------- */ ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , 0 , &TOTEL , sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , 1 , &COMPUTE_PERM , sizeof( bool ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , 2 , &N , sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , 3 , &IWLEN , sizeof( int64_t ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT , 4 , PE , N * sizeof( int64_t ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT , 5 , PFREE , sizeof( int64_t ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT , 6 , LEN , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT , 7 , IW , IWLEN * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT , 8 , NV , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , 9 , ELEN , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT ,10 , LAST , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT ,11 , NCMPA , sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT ,12 , DEGREE , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT ,13 , HEAD , TOTEL * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT ,14 , NEXT , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT ,15 , W , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT ,16 , PARENT , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Invoke VH C library function * ----------------------------------------------------------------------- */ ret = vhcall_invoke_with_args( symid , ca , &retval ); if ( ret ) { perror("vhcall_invoke_with_args"); fprintf( stdout , "%s @ %d failed : unable to invoke the symbol from library\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Free args * ----------------------------------------------------------------------- */ vhcall_args_free( ca ); /* * ----------------------------------------------------------------------- * Uninstall the library * ----------------------------------------------------------------------- */ if ( vhcall_uninstall( handle ) ) { perror("vhcall_uninstall"); fprintf( stdout , "cvhmetis_nodend failed : unable to uninstall the library\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } } MUMPS_5.8.1/src/ve/src/VE_Mumps_wrap_ginp94.c0000664000175000017500000002472515042446442020527 0ustar amestoyamestoy/* * ----------------------------------------------------------------------- * NEC Vector Host MUMPS Library Interface * ----------------------------------------------------------------------- */ #include /* * --------------------------------------------------------------------------- * VE_Mumps_wrap_ginp94 * --------------------------------------------------------------------------- */ void VE_Mumps_wrap_ginp94( int N , int64_t * IPE , int * IW , int64_t LIW8 , int * PERM , int * SizeOfBlocks , int KEEP60 , int * LISTVAR_SCHUR , int SIZE_SCHUR , int KEEP378 , int * COLCOUNT , int * PARENT , int * PORDER , int * IWTMP1 , int * IWTMP2 , int * IWTMP3 , int * IWTMP4 , int * IWTMP5 , int * INFO ) { int ret=1,iarg; int64_t symid; vhcall_handle handle; vhcall_args *ca; uint64_t retval; char * env_metis_lib_name; char metis_lib_name[ NECVH_MAX_LIBNAME ]; /* * ----------------------------------------------------------------------- * Set the library name ( check environment ) * ----------------------------------------------------------------------- */ if ( env_metis_lib_name = getenv( "VH_MUMPS_LIBRARY" ) ) { size_t lenv = strlen( env_metis_lib_name ); if ( strlen( env_metis_lib_name ) > (size_t)NECVH_MAX_LIBNAME ) { fprintf( stdout , "%s @ %d failed : metis library name too long (%s)\n" , basename(__FILE__) , __LINE__ , env_metis_lib_name ); fflush( stdout ); (void) mumps_abort(); } else { memcpy( ( void * ) metis_lib_name , ( void * ) env_metis_lib_name , lenv * sizeof( char) ); metis_lib_name[ lenv ] = '\0'; fprintf( stdout , "%s @ %d input library %s\n" , basename(__FILE__) , __LINE__ , metis_lib_name ); fflush( stdout ); } } else { strcpy( metis_lib_name , "libvh.so" ); } /* * ----------------------------------------------------------------------- * Load VH C library * ----------------------------------------------------------------------- */ handle = vhcall_install( metis_lib_name ); if (handle == (vhcall_handle)-1) { perror("vhcall_install"); fprintf( stdout , "%s @ %d failed : can't install library %s\n" , basename(__FILE__) , __LINE__ , metis_lib_name ); fprintf( stdout , "Please check your LD_LIBRARY_PATH variable\n"); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Find VH C library function * ----------------------------------------------------------------------- */ symid = vhcall_find(handle, "mumps_wrap_ginp94_"); if ( symid == -1 ) { fprintf( stdout , "%s @ %d failed : can't find symbol MUMPS_WRAP_GINP94\n" , basename(__FILE__) , __LINE__ ); perror("vhcall_find"); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Allocate arguments object for VH library function * ----------------------------------------------------------------------- */ ca = vhcall_args_alloc(); if ( ! ca ) { perror("vhcall_args_alloc"); fprintf( stdout , "%s @ %d failed : unable to allocate function's argument list\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Set arguments * ----------------------------------------------------------------------- */ iarg = 0; ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , iarg++ , &N , sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , iarg++ , IPE , ( N + 1 ) * sizeof( int64_t ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , iarg++ , IW , LIW8 * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , iarg++ , &LIW8 , sizeof( int64_t ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT , iarg++ , PERM , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , iarg++ , SizeOfBlocks , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , iarg++ , &KEEP60 , sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , iarg++ , LISTVAR_SCHUR , SIZE_SCHUR * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , iarg++ , &SIZE_SCHUR , sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , iarg++ , &KEEP378 , sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , COLCOUNT , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , PARENT , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , PORDER , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , IWTMP1 , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , IWTMP2 , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , IWTMP3 , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , IWTMP4 , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , IWTMP5 , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT , iarg++ , INFO , 2 * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Invoke VH C library function * ----------------------------------------------------------------------- */ ret = vhcall_invoke_with_args( symid , ca , &retval ); if ( ret ) { perror("vhcall_invoke_with_args"); fprintf( stdout , "%s @ %d failed : unable to invoke the symbol from library\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Free args * ----------------------------------------------------------------------- */ vhcall_args_free( ca ); /* * ----------------------------------------------------------------------- * Uninstall the library * ----------------------------------------------------------------------- */ if ( vhcall_uninstall( handle ) ) { perror("vhcall_uninstall"); fprintf( stdout , "cvhmetis_nodend failed : unable to uninstall the library\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } } MUMPS_5.8.1/src/ve/src/VE_Metis_interface.f900000664000175000017500000000435615042446442020456 0ustar amestoyamestoy! ! ----------------------------------------------------------------------- ! ! NEC Vector Host MUMPS Library Interface ! ! ----------------------------------------------------------------------- ! ! ! ----------------------------------------------------------------------- ! Interface to C metis_setdefaultoptions ! ----------------------------------------------------------------------- ! INTEGER FUNCTION VE_FMETIS_SETDEFAULTOPTIONS( OPTIONS ) USE ISO_C_BINDING, ONLY : C_INT ! INTERFACE TO C ROUTINE INTEGER(KIND=C_INT) :: OPTIONS( * ), IERR(1) INTERFACE INTEGER(KIND=C_INT) FUNCTION VE_METIS_SETDEFAULTOPTIONS( OPTIONS ) & BIND(C, NAME='VE_Metis_setdefaultoptions') USE ISO_C_BINDING, ONLY : C_INT INTEGER(KIND=C_INT) :: OPTIONS( * ) END FUNCTION VE_METIS_SETDEFAULTOPTIONS END INTERFACE WRITE(6,'(A)')'-----------------> Performing VH call of METIS_SETDEFAULTOPTIONS' IERR(1) = VE_METIS_SETDEFAULTOPTIONS( OPTIONS ) VE_FMETIS_SETDEFAULTOPTIONS = IERR(1) END FUNCTION VE_FMETIS_SETDEFAULTOPTIONS ! ! ----------------------------------------------------------------------- ! Interface to C metis_nodend ! ----------------------------------------------------------------------- ! FUNCTION VE_FMETIS_NODEND( NVTXS , XADJ , ADJNCY , VWGT , OPTIONS , PERM , IPERM ) USE ISO_C_BINDING, ONLY : C_INT ! INTERFACE TO C ROUTINE INTEGER(KIND=C_INT) :: OPTIONS( * ), IERR(1) INTEGER(KIND=C_INT) :: NVTXS( 1 ) , XADJ( * ) INTEGER(KIND=C_INT) :: ADJNCY( * ), VWGT( * ) INTEGER(KIND=C_INT) :: PERM( * ) , IPERM( * ) INTERFACE INTEGER(KIND=C_INT) FUNCTION VE_METIS_NODEND( NVTXS , XADJ , ADJNCY , VWGT , OPTIONS , PERM , IPERM ) & BIND(C, NAME='VE_Metis_nodend') USE ISO_C_BINDING, ONLY : C_INT INTEGER(KIND=C_INT) :: OPTIONS( * ) INTEGER(KIND=C_INT) :: NVTXS( 1 ), XADJ( * ) INTEGER(KIND=C_INT) :: ADJNCY( * ), VWGT( * ) INTEGER(KIND=C_INT) :: PERM( * ), IPERM( * ) END FUNCTION VE_METIS_NODEND END INTERFACE WRITE(6,'(A)')'-----------------> Performing VH call of METIS_NODEND' IERR(1) = VE_METIS_NODEND( NVTXS , XADJ , ADJNCY , VWGT , OPTIONS , PERM , IPERM ) VE_FMETIS_NODEND = IERR(1) END FUNCTION VE_FMETIS_NODEND MUMPS_5.8.1/src/ve/src/VE_Metis_nodend.c0000664000175000017500000001507315042446442017607 0ustar amestoyamestoy/* * ----------------------------------------------------------------------- * NEC Vector Host MUMPS Library Interface * ----------------------------------------------------------------------- */ #include /* * ----------------------------------------------------------------------- * VE_Metis_nodend * ----------------------------------------------------------------------- */ int VE_Metis_nodend( int * nvtxs , int * xadj , int * adjncy , int * vwgt, int * options , int * perm , int * iperm ) { int ret=1; int64_t symid; vhcall_handle handle; vhcall_args *ca; uint64_t retval = -1; char * env_metis_lib_name; char metis_lib_name[ NECVH_MAX_LIBNAME ]; /* * ----------------------------------------------------------------------- * Set the library name ( check environment ) * ----------------------------------------------------------------------- */ if ( env_metis_lib_name = getenv( "VH_MUMPS_LIBRARY" ) ) { size_t lenv = strlen( env_metis_lib_name ); if ( strlen( env_metis_lib_name ) > (size_t)NECVH_MAX_LIBNAME ) { fprintf( stdout , "%s @ %d failed : metis library name too long (%s)\n" , basename(__FILE__) , __LINE__ , env_metis_lib_name ); fflush( stdout ); (void) mumps_abort(); } else { memcpy( ( void * ) metis_lib_name , ( void * ) env_metis_lib_name , lenv * sizeof( char) ); metis_lib_name[ lenv ] = '\0'; fprintf( stdout , "%s @ %d input library %s\n" , basename(__FILE__) , __LINE__ , metis_lib_name ); fflush( stdout ); } } else { strcpy( metis_lib_name , "libvh.so" ); } /* * ----------------------------------------------------------------------- * Load VH C library * ----------------------------------------------------------------------- */ handle = vhcall_install( metis_lib_name ); if (handle == (vhcall_handle)-1) { perror("vhcall_install"); fprintf( stdout , "%s @ %d failed : can't install library %s\n" , basename(__FILE__) , __LINE__ , metis_lib_name ); fprintf( stdout , "Please check your LD_LIBRARY_PATH variable\n"); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Find VH C library function * ----------------------------------------------------------------------- */ symid = vhcall_find(handle, "METIS_NodeND"); if ( symid == -1 ) { perror("vhcall_find"); fprintf( stdout , "%s @ %d failed : can't find symbol METIS_NodeND\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Allocate arguments object for VH library function * ----------------------------------------------------------------------- */ ca = vhcall_args_alloc(); if (! ca) { perror("vhcall_args_alloc"); fprintf( stdout , "%s @ %d failed : unable to allocate function's argument list\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Set arguments * ----------------------------------------------------------------------- */ ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , 0 , nvtxs , sizeof( idx_t ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , 1 , xadj , ( *nvtxs + 1 ) * sizeof( idx_t ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , 2 , adjncy , xadj[ *nvtxs ] * sizeof( idx_t ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } int len; if ( vwgt ) len = *nvtxs; else len = 0; ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , 3 , vwgt , len * sizeof( idx_t ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , 4 , options , METIS_NOPTIONS * sizeof( idx_t ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , 5 , perm , *nvtxs * sizeof( idx_t ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , 6 , iperm , *nvtxs * sizeof( idx_t ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Invoke VH C library function * ----------------------------------------------------------------------- */ ret = vhcall_invoke_with_args( symid , ca , &retval ); if ( ret ) { perror("vhcall_invoke_with_args"); fprintf( stdout , "%s @ %d failed : unable to invoke the symbol from library\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Free args * ----------------------------------------------------------------------- */ vhcall_args_free( ca ); /* * ----------------------------------------------------------------------- * Uninstall the library * ----------------------------------------------------------------------- */ if ( vhcall_uninstall( handle ) ) { perror("vhcall_uninstall"); fprintf( stdout , "%s @ %d failed : unable to uninstall the library\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } return( (int) retval ); } MUMPS_5.8.1/src/ve/src/VE_Metis_setdefaultoptions.c0000664000175000017500000001125615042446442022113 0ustar amestoyamestoy/* * ----------------------------------------------------------------------- * NEC Vector Host MUMPS Library Interface * ----------------------------------------------------------------------- */ #include /* * --------------------------------------------------------------------------- * VE_Metis_setdefaultoptions * --------------------------------------------------------------------------- */ int VE_Metis_setdefaultoptions( int * options ) { int ret=1; int64_t symid; vhcall_handle handle; vhcall_args *ca; uint64_t retval = -1; char * env_metis_lib_name; char metis_lib_name[ NECVH_MAX_LIBNAME ]; /* * ----------------------------------------------------------------------- * Set the library name ( check environment ) * ----------------------------------------------------------------------- */ if ( env_metis_lib_name = getenv( "VH_MUMPS_LIBRARY" ) ) { size_t lenv = strlen( env_metis_lib_name ); if ( strlen( env_metis_lib_name ) > (size_t)NECVH_MAX_LIBNAME ) { fprintf( stdout , "%s @ %d failed : metis library name too long (%s)\n" , basename(__FILE__) , __LINE__ , env_metis_lib_name ); fflush( stdout ); (void) mumps_abort(); } else { memcpy( ( void * ) metis_lib_name , ( void * ) env_metis_lib_name , lenv * sizeof( char) ); metis_lib_name[ lenv ] = '\0'; fprintf( stdout , "%s @ %d input library %s\n" , basename(__FILE__) , __LINE__ , metis_lib_name ); fflush( stdout ); } } else { strcpy( metis_lib_name , "libvh.so" ); } /* * ----------------------------------------------------------------------- * Load VH C library * ----------------------------------------------------------------------- */ handle = vhcall_install( metis_lib_name ); if (handle == (vhcall_handle)-1) { perror("vhcall_install"); fprintf( stdout , "%s @ %d failed : can't install library %s\n" , basename(__FILE__) , __LINE__ , metis_lib_name ); fprintf( stdout , "Please check your LD_LIBRARY_PATH variable\n"); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Find VH C library function * ----------------------------------------------------------------------- */ symid = vhcall_find(handle, "METIS_SetDefaultOptions"); if ( symid == -1 ) { fprintf( stdout , "%s @ %d failed : can't find symbol METIS_SetDefaultOptions\n" , basename(__FILE__) , __LINE__ ); perror("vhcall_find"); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Allocate arguments object for VH library function * ----------------------------------------------------------------------- */ ca = vhcall_args_alloc(); if ( ! ca ) { perror("vhcall_args_alloc"); fprintf( stdout , "%s @ %d failed : unable to allocate function's argument list\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Set argument * ----------------------------------------------------------------------- */ ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT , 0 , options , METIS_NOPTIONS * sizeof( idx_t ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Invoke VH C library function * ----------------------------------------------------------------------- */ ret = vhcall_invoke_with_args( symid , ca , &retval ); if ( ret ) { perror("vhcall_invoke_with_args"); fprintf( stdout , "%s @ %d failed : unable to invoke the symbol from library\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Free args * ----------------------------------------------------------------------- */ vhcall_args_free( ca ); /* * ----------------------------------------------------------------------- * Uninstall the library * ----------------------------------------------------------------------- */ if ( vhcall_uninstall( handle ) ) { perror("vhcall_uninstall"); fprintf( stdout , "cvhmetis_nodend failed : unable to uninstall the library\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } return( (int) retval ); } MUMPS_5.8.1/src/ve/src/VE_Mumps_symqamd.c0000664000175000017500000002667015042446442020040 0ustar amestoyamestoy/* * ----------------------------------------------------------------------- * NEC Vector Host MUMPS Library Interface * ----------------------------------------------------------------------- */ #include /* * --------------------------------------------------------------------------- * VE_Mumps_symqamd * --------------------------------------------------------------------------- */ void VE_Mumps_symqamd( int THRESH , int * NDENSE , int N , int TOTEL , int64_t IWLEN , int64_t * PE , int64_t * PFREE , int * LEN , int * IW , int * NV , int * ELEN , int * LAST , int * NCMPA , int * DEGREE , int * HEAD , int * NEXT , int * W , int * PERM , int * LISTVAR_SCHUR , int SIZE_SCHUR , int AGG6 , int * PARENT ) { int ret=1,iarg; int64_t symid; vhcall_handle handle; vhcall_args *ca; uint64_t retval; char * env_metis_lib_name; char metis_lib_name[ NECVH_MAX_LIBNAME ]; /* * ----------------------------------------------------------------------- * Set the library name ( check environment ) * ----------------------------------------------------------------------- */ if ( env_metis_lib_name = getenv( "VH_MUMPS_LIBRARY" ) ) { size_t lenv = strlen( env_metis_lib_name ); if ( strlen( env_metis_lib_name ) > (size_t)NECVH_MAX_LIBNAME ) { fprintf( stdout , "%s @ %d failed : metis library name too long (%s)\n" , basename(__FILE__) , __LINE__ , env_metis_lib_name ); fflush( stdout ); (void) mumps_abort(); } else { memcpy( ( void * ) metis_lib_name , ( void * ) env_metis_lib_name , lenv * sizeof( char) ); metis_lib_name[ lenv ] = '\0'; fprintf( stdout , "%s @ %d input library %s\n" , basename(__FILE__) , __LINE__ , metis_lib_name ); fflush( stdout ); } } else { strcpy( metis_lib_name , "libvh.so" ); } /* * ----------------------------------------------------------------------- * Load VH C library * ----------------------------------------------------------------------- */ handle = vhcall_install( metis_lib_name ); if (handle == (vhcall_handle)-1) { perror("vhcall_install"); fprintf( stdout , "%s @ %d failed : can't install library %s\n" , basename(__FILE__) , __LINE__ , metis_lib_name ); fprintf( stdout , "Please check your LD_LIBRARY_PATH variable\n"); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Find VH C library function * ----------------------------------------------------------------------- */ symid = vhcall_find(handle, "mumps_symqamd_"); if ( symid == -1 ) { fprintf( stdout , "%s @ %d failed : can't find symbol MUMPS_SYMQAMD\n" , basename(__FILE__) , __LINE__ ); perror("vhcall_find"); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Allocate arguments object for VH library function * ----------------------------------------------------------------------- */ ca = vhcall_args_alloc(); if ( ! ca ) { perror("vhcall_args_alloc"); fprintf( stdout , "%s @ %d failed : unable to allocate function's argument list\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Set arguments * ----------------------------------------------------------------------- */ iarg = 0; ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , iarg++ , &THRESH , sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , NDENSE , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , iarg++ , &N , sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , iarg++ , &TOTEL , sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , iarg++ , &IWLEN , sizeof( int64_t ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT , iarg++ , PE , N * sizeof( int64_t ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT , iarg++ , PFREE , sizeof( int64_t ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT , iarg++ , LEN , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT , iarg++ , IW , IWLEN * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT , iarg++ , NV , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , ELEN , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , LAST , TOTEL * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , NCMPA , sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , DEGREE , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , HEAD , TOTEL * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , NEXT , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , W , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT , iarg++ , PERM , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , LISTVAR_SCHUR , ( SIZE_SCHUR ? SIZE_SCHUR : 1 ) * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_INOUT , iarg++ , &SIZE_SCHUR , sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_IN , iarg++ , &AGG6 , sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } ret = vhcall_args_set_pointer( ca , VHCALL_INTENT_OUT , iarg++ , PARENT , N * sizeof( int ) ); if ( ret ) { perror("vhcall_args_set_pointer"); fprintf( stdout , "%s @ %d failed : unable to set argument.\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Invoke VH C library function * ----------------------------------------------------------------------- */ ret = vhcall_invoke_with_args( symid , ca , &retval ); if ( ret ) { perror("vhcall_invoke_with_args"); fprintf( stdout , "%s @ %d failed : unable to invoke the symbol from library\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } /* * ----------------------------------------------------------------------- * Free args * ----------------------------------------------------------------------- */ vhcall_args_free( ca ); /* * ----------------------------------------------------------------------- * Uninstall the library * ----------------------------------------------------------------------- */ if ( vhcall_uninstall( handle ) ) { perror("vhcall_uninstall"); fprintf( stdout , "cvhmetis_nodend failed : unable to uninstall the library\n" , basename(__FILE__) , __LINE__ ); fflush( stdout ); (void) mumps_abort(); } } MUMPS_5.8.1/src/ve/src/VE_Ana_orderings_interface.f900000664000175000017500000002471715042446442022153 0ustar amestoyamestoy! ! ----------------------------------------------------------------------- ! ! NEC Vector Host MUMPS Library Interface ! ! ----------------------------------------------------------------------- ! ! ! ----------------------------------------------------------------------- ! Interface to MUMPS_ANA_H ! ----------------------------------------------------------------------- ! SUBROUTINE VE_FMUMPS_ANA_H( & TOTEL , COMPUTE_PERM , N , IWLEN , PE , & PFREE , LEN , IW , NV , ELEN , & LAST , NCMPA , DEGREE , HEAD , NEXT , & W , PARENT ) USE ISO_C_BINDING, ONLY : C_INT,C_BOOL,C_INT64_T IMPLICIT NONE ! INTERFACE TO C ROUTINE ! Input not modified INTEGER(KIND=C_INT), INTENT(IN) :: TOTEL, N INTEGER(KIND=C_INT64_T), INTENT(IN) :: IWLEN LOGICAL(KIND=C_BOOL), INTENT(IN) :: COMPUTE_PERM ! Input undefined on output INTEGER(KIND=C_INT), INTENT(INOUT) :: LEN(N), IW(IWLEN) ! ! Output only INTEGER(KIND=C_INT), INTENT(OUT) :: NCMPA(1) INTEGER(KIND=C_INT), INTENT(OUT) :: ELEN(N), LAST(N), PARENT(N) ! ! Input/output INTEGER(KIND=C_INT64_T), INTENT(INOUT) :: PFREE(1) INTEGER(KIND=C_INT64_T), INTENT(INOUT) :: PE(N) ! NV also meaningful as input to encode compressed graphs INTEGER(KIND=C_INT), INTENT(INOUT) :: NV(N) ! ! Internal Workspace only INTEGER(KIND=C_INT) :: NEXT(N), DEGREE(N), HEAD(TOTEL), W(N) INTERFACE SUBROUTINE VE_MUMPS_ANA_H( & TOTEL , COMPUTE_PERM , N , IWLEN , PE , & PFREE , LEN , IW , NV , ELEN , & LAST , NCMPA , DEGREE , HEAD , NEXT , & W , PARENT ) & BIND(C, NAME='VE_Mumps_ana_h') USE ISO_C_BINDING, ONLY : C_INT,C_BOOL,C_INT64_T IMPLICIT NONE ! Input not modified INTEGER(KIND=C_INT) , VALUE, INTENT(IN) :: TOTEL, N INTEGER(KIND=C_INT64_T), VALUE, INTENT(IN) :: IWLEN LOGICAL(KIND=C_BOOL) , VALUE, INTENT(IN) :: COMPUTE_PERM ! Input undefined on output INTEGER(KIND=C_INT), INTENT(INOUT) :: LEN(N), IW(IWLEN) ! ! Output only INTEGER(KIND=C_INT), INTENT(OUT) :: NCMPA(1) INTEGER(KIND=C_INT), INTENT(OUT) :: ELEN(N), LAST(N), PARENT(N) ! ! Input/output INTEGER(KIND=C_INT64_T), INTENT(INOUT) :: PFREE(1) INTEGER(KIND=C_INT64_T), INTENT(INOUT) :: PE(N) ! NV also meaningful as input to encode compressed graphs INTEGER(KIND=C_INT), INTENT(INOUT) :: NV(N) ! ! Internal Workspace only INTEGER(KIND=C_INT) :: NEXT(N), DEGREE(N), HEAD(TOTEL), W(N) END SUBROUTINE VE_MUMPS_ANA_H END INTERFACE WRITE(6,'(A)')'-----------------> Performing VH call of MUMPS_ANA_H' CALL VE_MUMPS_ANA_H( & TOTEL , COMPUTE_PERM , N , IWLEN , PE , & PFREE , LEN , IW , NV , ELEN , & LAST , NCMPA , DEGREE , HEAD , NEXT , & W , PARENT ) END SUBROUTINE VE_FMUMPS_ANA_H ! ! ----------------------------------------------------------------------- ! Interface to MUMPS_SYMQAMD ! ----------------------------------------------------------------------- ! SUBROUTINE VE_FMUMPS_SYMQAMD( & THRESH , NDENSE , N , TOTEL , IWLEN , & PE , PFREE , LEN , IW , NV , & ELEN , LAST , NCMPA , DEGREE , HEAD , & NEXT , W , PERM , LISTVAR_SCHUR , SIZE_SCHUR , & AGG6 , PARENT ) USE ISO_C_BINDING, ONLY : C_INT,C_BOOL,C_INT64_T IMPLICIT NONE ! INTERFACE TO C ROUTINE ! Input not modified INTEGER(KIND=C_INT) , INTENT(IN) :: N, TOTEL, SIZE_SCHUR LOGICAL(KIND=C_BOOL) , INTENT(IN) :: AGG6 INTEGER(KIND=C_INT) , INTENT(IN) :: THRESH INTEGER(KIND=C_INT64_T), INTENT(IN) :: IWLEN INTEGER(KIND=C_INT) , INTENT(IN) :: LISTVAR_SCHUR(max(1,SIZE_SCHUR)) ! Input undefined on output INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) ! ! Output only INTEGER(KIND=C_INT), INTENT(OUT) :: NCMPA(1) INTEGER(KIND=C_INT), INTENT(OUT) :: ELEN(N), LAST(TOTEL), PARENT(N) ! ! Input/output INTEGER(KIND=C_INT), INTENT(INOUT) :: NV(N) INTEGER(KIND=C_INT64_T), INTENT(INOUT) :: PFREE(1) INTEGER(KIND=C_INT64_T), INTENT(INOUT) :: PE(N) INTEGER(KIND=C_INT), INTENT(INOUT) :: PERM(N) ! ! Internal Workspace only INTEGER(KIND=C_INT), INTENT(OUT) :: NDENSE(N), DEGREE(N) INTEGER(KIND=C_INT), INTENT(OUT) :: HEAD(TOTEL), NEXT(N), W(N) INTERFACE SUBROUTINE VE_MUMPS_SYMQAMD( & THRESH , NDENSE , N , TOTEL , IWLEN , & PE , PFREE , LEN , IW , NV , & ELEN , LAST , NCMPA , DEGREE , HEAD , & NEXT , W , PERM , LISTVAR_SCHUR , SIZE_SCHUR , & AGG6 , PARENT ) & BIND(C, NAME='VE_Mumps_symqamd') USE ISO_C_BINDING, ONLY : C_INT,C_BOOL,C_INT64_T IMPLICIT NONE ! Input not modified INTEGER(KIND=C_INT) , VALUE , INTENT(IN) :: N, TOTEL, SIZE_SCHUR LOGICAL(KIND=C_BOOL) , VALUE , INTENT(IN) :: AGG6 INTEGER(KIND=C_INT) , VALUE , INTENT(IN) :: THRESH INTEGER(KIND=C_INT64_T), VALUE , INTENT(IN) :: IWLEN INTEGER(KIND=C_INT) , INTENT(IN) :: LISTVAR_SCHUR(max(1,SIZE_SCHUR)) ! Input undefined on output INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) ! ! Output only INTEGER(KIND=C_INT), INTENT(OUT) :: NCMPA(1) INTEGER(KIND=C_INT), INTENT(OUT) :: ELEN(N), LAST(TOTEL), PARENT(N) ! ! Input/output INTEGER(KIND=C_INT), INTENT(INOUT) :: NV(N) INTEGER(KIND=C_INT64_T), INTENT(INOUT) :: PFREE(1) INTEGER(KIND=C_INT64_T), INTENT(INOUT) :: PE(N) INTEGER(KIND=C_INT), INTENT(INOUT) :: PERM(N) ! ! Internal Workspace only INTEGER(KIND=C_INT), INTENT(OUT) :: NDENSE(N), DEGREE(N) INTEGER(KIND=C_INT), INTENT(OUT) :: HEAD(TOTEL), NEXT(N), W(N) END SUBROUTINE VE_MUMPS_SYMQAMD END INTERFACE WRITE(6,'(A)')'-----------------> Performing VH call of MUMPS_SYMQAMD' CALL VE_MUMPS_SYMQAMD( & THRESH , NDENSE , N , TOTEL , IWLEN , & PE , PFREE , LEN , IW , NV , & ELEN , LAST , NCMPA , DEGREE , HEAD , & NEXT , W , PERM , LISTVAR_SCHUR , SIZE_SCHUR , & AGG6 , PARENT ) END SUBROUTINE VE_FMUMPS_SYMQAMD ! ! ----------------------------------------------------------------------- ! Interface to MUMPS_WRAP_GINP94 ! ----------------------------------------------------------------------- ! SUBROUTINE VE_FMUMPS_WRAP_GINP94( & N , IPE , IW , LIW8 , PERM , & SizeOfBlocks , KEEP60 , LISTVAR_SCHUR , SIZE_SCHUR , KEEP378 , & COLCOUNT , PARENT , PORDER , IWTMP1 , IWTMP2 , & IWTMP3 , IWTMP4 , IWTMP5 , INFO ) USE ISO_C_BINDING, ONLY : C_INT,C_INT64_T IMPLICIT NONE ! INTERFACE TO C ROUTINE ! Input not modified INTEGER(KIND=C_INT) , INTENT(IN) :: N, KEEP60, SIZE_SCHUR, KEEP378 INTEGER(KIND=C_INT) , INTENT(IN) :: SizeOfBlocks(N) INTEGER(KIND=C_INT) , INTENT(IN) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER(KIND=C_INT64_T), INTENT(IN) :: LIW8,IPE(N+1) INTEGER(KIND=C_INT) , INTENT(IN) :: IW(LIW8) ! ! Output only INTEGER(KIND=C_INT), INTENT(OUT) :: COLCOUNT(N),PARENT(N) INTEGER(KIND=C_INT), INTENT(OUT) :: PORDER(N), IWTMP1(N), IWTMP2(N) INTEGER(KIND=C_INT), INTENT(OUT) :: IWTMP3(N), IWTMP4(N), IWTMP5(N) ! ! Input/output INTEGER(KIND=C_INT), INTENT(INOUT) :: PERM(N) INTEGER(KIND=C_INT), INTENT(INOUT) :: INFO(2) INTERFACE SUBROUTINE VE_MUMPS_WRAP_GINP94( & N , IPE , IW , LIW8 , PERM , & SizeOfBlocks , KEEP60 , LISTVAR_SCHUR , SIZE_SCHUR , KEEP378 , & COLCOUNT , PARENT , PORDER , IWTMP1 , IWTMP2 , & IWTMP3 , IWTMP4 , IWTMP5 , INFO ) & BIND(C, NAME='VE_Mumps_wrap_ginp94') USE ISO_C_BINDING, ONLY : C_INT,C_INT64_T IMPLICIT NONE ! Input not modified INTEGER(KIND=C_INT) , VALUE , INTENT(IN) :: N, KEEP60, SIZE_SCHUR, KEEP378 INTEGER(KIND=C_INT64_T), VALUE , INTENT(IN) :: LIW8 INTEGER(KIND=C_INT) , INTENT(IN) :: SizeOfBlocks(N) INTEGER(KIND=C_INT) , INTENT(IN) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER(KIND=C_INT64_T) , INTENT(IN) :: IPE(N+1) INTEGER(KIND=C_INT) , INTENT(IN) :: IW(LIW8) ! ! Output only INTEGER(KIND=C_INT), INTENT(OUT) :: COLCOUNT(N),PARENT(N) INTEGER(KIND=C_INT), INTENT(OUT) :: PORDER(N), IWTMP1(N), IWTMP2(N) INTEGER(KIND=C_INT), INTENT(OUT) :: IWTMP3(N), IWTMP4(N), IWTMP5(N) ! ! Input/output INTEGER(KIND=C_INT), INTENT(INOUT) :: PERM(N) INTEGER(KIND=C_INT), INTENT(INOUT) :: INFO(2) END SUBROUTINE VE_MUMPS_WRAP_GINP94 END INTERFACE WRITE(6,'(A)')'-----------------> Performing VH call of MUMPS_WRAP_GINP94' CALL VE_MUMPS_WRAP_GINP94( & N , IPE , IW , LIW8 , PERM , & SizeOfBlocks , KEEP60 , LISTVAR_SCHUR , SIZE_SCHUR , KEEP378 , & COLCOUNT , PARENT , PORDER , IWTMP1 , IWTMP2 , & IWTMP3 , IWTMP4 , IWTMP5 , INFO ) END SUBROUTINE VE_FMUMPS_WRAP_GINP94 MUMPS_5.8.1/src/cmumps_save_restore_files.F0000664000175000017500000002740715042446440020620 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if ! defined(NO_SAVE_RESTORE) MODULE CMUMPS_SAVE_RESTORE_FILES USE CMUMPS_STRUC_DEF IMPLICIT NONE INTEGER, PARAMETER :: LEN_SAVE_FILE = 1318 CONTAINS SUBROUTINE MUMPS_READ_HEADER(fileunit, ierr, size_read, SIZE_INT & ,SIZE_INT8, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE & ,READ_ARITH, READ_INT_TYPE_64 & ,READ_OOC_FILE_NAME_LENGTH, READ_OOC_FIRST_FILE_NAME & ,READ_HASH,READ_SYM,READ_PAR,READ_NPROCS & ,FORTRAN_VERSION_OK) INTEGER,intent(in) :: fileunit INTEGER,intent(out) :: ierr INTEGER(8), intent(inout) :: size_read INTEGER,intent(in) :: SIZE_INT, SIZE_INT8 INTEGER(8), intent(out) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE CHARACTER, intent(out) :: READ_ARITH LOGICAL, intent(out) :: READ_INT_TYPE_64 INTEGER, intent(out) :: READ_OOC_FILE_NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE),intent(out)::READ_OOC_FIRST_FILE_NAME CHARACTER(len=23), intent(out) :: READ_HASH INTEGER, intent(out) :: READ_SYM,READ_PAR,READ_NPROCS LOGICAL, intent(out) :: FORTRAN_VERSION_OK CHARACTER(len=5) :: READ_FORTRAN_VERSION INTEGER :: SIZE_CHARACTER, SIZE_LOGICAL INTEGER :: dummy SIZE_CHARACTER = 1 SIZE_LOGICAL = 4 FORTRAN_VERSION_OK = .true. read(fileunit,iostat=ierr) READ_FORTRAN_VERSION if(ierr.ne.0) GOTO 100 if (READ_FORTRAN_VERSION.NE."MUMPS") THEN ierr = 0 FORTRAN_VERSION_OK = .false. GOTO 100 endif size_read=size_read+int(5*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_HASH if(ierr.ne.0) GOTO 100 size_read=size_read+int(23*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(ierr.ne.0) GOTO 100 size_read=size_read+int(2*SIZE_INT8,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_ARITH if(ierr.ne.0) GOTO 100 size_read=size_read+int(1,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_SYM,READ_PAR,READ_NPROCS if(ierr.ne.0) GOTO 100 size_read=size_read+int(3*SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_INT_TYPE_64 if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_LOGICAL,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_OOC_FILE_NAME_LENGTH if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif IF(READ_OOC_FILE_NAME_LENGTH.EQ.-999) THEN read(fileunit,iostat=ierr) dummy if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif ELSE read(fileunit,iostat=ierr) & READ_OOC_FIRST_FILE_NAME(1:READ_OOC_FILE_NAME_LENGTH) if(ierr.ne.0) GOTO 100 size_read=size_read+int( & READ_OOC_FILE_NAME_LENGTH*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif ENDIF 100 continue RETURN END SUBROUTINE MUMPS_READ_HEADER SUBROUTINE CMUMPS_CHECK_HEADER(id, BASIC_CHECK, READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) INCLUDE 'mpif.h' TYPE (CMUMPS_STRUC),intent(inout) :: id LOGICAL, intent(in) :: BASIC_CHECK LOGICAL, intent(in) :: READ_INT_TYPE_64 CHARACTER(len=23), intent(in) :: READ_HASH INTEGER, intent(in) :: READ_NPROCS CHARACTER, intent(in) :: READ_ARITH INTEGER, intent(in) :: READ_SYM,READ_PAR LOGICAL :: INT_TYPE_64 CHARACTER(len=23) :: HASH_MASTER CHARACTER :: ARITH INTEGER :: IERR IF(id%KEEP(10).EQ.1) THEN INT_TYPE_64=.TRUE. ELSE INT_TYPE_64=.FALSE. ENDIF if(INT_TYPE_64.neqv.READ_INT_TYPE_64) THEN id%INFO(1) = -73 id%INFO(2) = 2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(id%MYID.EQ.0) THEN HASH_MASTER=READ_HASH ENDIF call MPI_BCAST(HASH_MASTER,23,MPI_CHARACTER,0,id%COMM,IERR) if(HASH_MASTER.ne.READ_HASH) THEN id%INFO(1) = -73 id%INFO(2) = 3 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(id%NPROCS.ne.READ_NPROCS) THEN id%INFO(1) = -73 id%INFO(2) = 4 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 IF (.NOT.BASIC_CHECK) THEN ARITH="CMUMPS"(1:1) if(ARITH.ne.READ_ARITH) THEN id%INFO(1) = -73 id%INFO(2) = 5 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if((id%MYID.EQ.0).AND.(id%SYM.ne.READ_SYM)) THEN id%INFO(1) = -73 id%INFO(2) = 6 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if((id%MYID.EQ.0).AND.(id%PAR.ne.READ_PAR)) THEN write (*,*) id%MYID, 'PAR ',id%PAR, 'READ_PAR ', READ_PAR id%INFO(1) = -73 id%INFO(2) = 7 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF 100 continue RETURN END SUBROUTINE CMUMPS_CHECK_HEADER SUBROUTINE MUMPS_CLEAN_SAVED_DATA(MYID,ierr,SUPPFILE,INFOFILE) INCLUDE 'mpif.h' INTEGER,intent(in) :: MYID INTEGER,intent(out) :: ierr CHARACTER(len=LEN_SAVE_FILE),intent(in):: SUPPFILE,INFOFILE INTEGER::supp,tmp_err ierr = 0 tmp_err = 0 CALL MUMPS_FIND_UNIT(supp) IF ( supp .EQ. -1 ) THEN ierr=-79 RETURN ENDIF open(UNIT=supp,FILE=SUPPFILE,STATUS='old', & form='unformatted',iostat=tmp_err) if (tmp_err.eq.0) THEN close(UNIT=supp,STATUS='delete',iostat=tmp_err) if(tmp_err.ne.0) then ierr = 1 tmp_err = 0 endif endif if (ierr .eq. 0) then if (tmp_err.ne.0) then ierr = 1 tmp_err = 0 endif open(UNIT=supp,FILE=INFOFILE,STATUS='old',iostat=tmp_err) if (tmp_err.eq.0) THEN close(UNIT=supp,STATUS='delete',iostat=tmp_err) endif if (tmp_err.ne.0) THEN ierr = ierr + 2 tmp_err = 0 endif endif RETURN END SUBROUTINE MUMPS_CLEAN_SAVED_DATA SUBROUTINE CMUMPS_GET_SAVE_FILES(id,SAVE_FILE,INFO_FILE) INCLUDE 'mpif.h' TYPE (CMUMPS_STRUC),intent(inout) :: id CHARACTER(len=LEN_SAVE_FILE),intent(out):: SAVE_FILE, INFO_FILE INTEGER::len_save_dir,len_save_prefix INTEGER, PARAMETER :: SAVE_PREFIX_MAX_LENGTH = 255 INTEGER, PARAMETER :: SAVE_DIR_MAX_LENGTH = 1023 CHARACTER(len=SAVE_DIR_MAX_LENGTH) :: tmp_save_dir CHARACTER(len=SAVE_DIR_MAX_LENGTH) :: save_dir CHARACTER(len=SAVE_PREFIX_MAX_LENGTH) :: save_prefix CHARACTER(len=SAVE_PREFIX_MAX_LENGTH) :: tmp_save_prefix CHARACTER(len=10):: STRING_MYID CHARACTER:: LAST_CHAR_DIR INFO_FILE='' SAVE_FILE='' tmp_save_dir='' tmp_save_prefix='' IF(id%SAVE_DIR.EQ."NAME_NOT_INITIALIZED") THEN call MUMPS_GET_SAVE_DIR_C(len_save_dir,tmp_save_dir) if (len_save_dir > SAVE_DIR_MAX_LENGTH) then id%INFO(1) = -77 id%INFO(2) = SAVE_DIR_MAX_LENGTH else if(tmp_save_dir(1:len_save_dir).EQ."NAME_NOT_INITIALIZED") & then id%INFO(1) = -77 id%INFO(2) = 0 else save_dir=trim(adjustl(tmp_save_dir(1:len_save_dir))) len_save_dir=len_trim(save_dir(1:len_save_dir)) endif ELSE save_dir=trim(adjustl(id%SAVE_DIR)) len_save_dir=len_trim(save_dir) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 IF(id%SAVE_PREFIX.EQ."NAME_NOT_INITIALIZED") THEN call MUMPS_GET_SAVE_PREFIX_C(len_save_prefix,tmp_save_prefix) if(len_save_prefix.GT.SAVE_PREFIX_MAX_LENGTH) then id%INFO(1)=-77 id%INFO(2)=-SAVE_PREFIX_MAX_LENGTH else if(tmp_save_prefix(1:len_save_prefix).EQ. & "NAME_NOT_INITIALIZED") then save_prefix="save" len_save_prefix=len_trim(save_prefix) else save_prefix= & trim(adjustl(tmp_save_prefix(1:len_save_prefix))) len_save_prefix=len_trim(save_prefix(1:len_save_prefix)) endif ELSE save_prefix=trim(adjustl(id%SAVE_PREFIX)) len_save_prefix=len_trim(save_prefix) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(STRING_MYID,'(I10)') id%MYID LAST_CHAR_DIR=save_dir(len_save_dir:len_save_dir) if(LAST_CHAR_DIR.NE."/") then SAVE_FILE=trim(adjustl(save_dir))//"/" else SAVE_FILE=trim(adjustl(save_dir)) endif INFO_FILE=trim(adjustl(SAVE_FILE)) SAVE_FILE=trim(adjustl(SAVE_FILE)) & //trim(adjustl(save_prefix)) & //"_" & //trim(adjustl(STRING_MYID)) & //".mumps" INFO_FILE=trim(adjustl(INFO_FILE)) & //trim(adjustl(save_prefix)) & //"_" & //trim(adjustl(STRING_MYID)) & //".info" 100 continue RETURN END SUBROUTINE CMUMPS_GET_SAVE_FILES SUBROUTINE CMUMPS_CHECK_FILE_NAME(id,NAME_LENGTH,FILE_NAME,CHECK) TYPE (CMUMPS_STRUC),intent(in) :: id INTEGER,intent(in) :: NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE),intent(in) :: FILE_NAME LOGICAL,intent(out) :: CHECK INTEGER :: I CHECK = .false. IF (NAME_LENGTH.NE.-999) THEN IF (associated(id%OOC_FILE_NAME_LENGTH) .AND. & associated(id%OOC_FILE_NAMES)) THEN IF (NAME_LENGTH .EQ. id%OOC_FILE_NAME_LENGTH(1)) THEN CHECK = .true. I = 1 DO WHILE(I.LE.NAME_LENGTH) IF (FILE_NAME(I:I).NE.id%OOC_FILE_NAMES(1,I)) THEN CHECK = .false. I = NAME_LENGTH + 1 ELSE I = I + 1 ENDIF END DO ENDIF ENDIF ENDIF END SUBROUTINE CMUMPS_CHECK_FILE_NAME END MODULE CMUMPS_SAVE_RESTORE_FILES #else SUBROUTINE CMUMPS_SAVE_FILES_RETURN() RETURN END SUBROUTINE CMUMPS_SAVE_FILES_RETURN #endif MUMPS_5.8.1/src/dfac_process_blocfacto.F0000664000175000017500000011117315042446440020012 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE DMUMPS_PROCESS_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL, KEEP,KEEP8, DKEEP, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_OOC, ONLY : IO_BLOCK USE MUMPS_OOC_COMMON, ONLY : TYPEF_L, STRAT_TRY_WRITE USE MUMPS_LOAD USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT USE DMUMPS_LR_CORE USE DMUMPS_LR_TYPE USE MUMPS_LR_STATS USE DMUMPS_FAC_LR USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER(8) :: POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PERM(N), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER COMM, MYID INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)), ND(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER INODE, POSITION, NPIV, IERR, LP INTEGER NCOL_RECV, JBEG_BLOCK, NCOL_GEMM, SHIFT_LPOS, SHIFT_UPOS INTEGER SHIFT_BEGS_BLR_U INTEGER :: IFLAG_OOC INTEGER(8) :: POSBLOCFACTO INTEGER :: LD_BLOCFACTO INTEGER(8) :: LA_BLOCFACTO INTEGER(8) :: LA_PTR INTEGER(8) :: POSELT DOUBLE PRECISION, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW INTEGER (8) :: LPOS, UPOS, LPOS2, IPOS, KPOS INTEGER ICT11 INTEGER I, IPIV, FPERE LOGICAL LASTPANEL, KEEP_BEGS_BLR_L, KEEP_BEGS_BLR_COL LOGICAL LASTBL_INPANEL, LASTBL_INLASTPANEL LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED DOUBLE PRECISION ONE,ALPHA PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER :: INFO_TMP(2) INTEGER :: IDUMMY(1) INTEGER :: NELIM, NPARTSASS_MASTER, NPARTSASS_MASTER_AUX, & IPANEL, & CURRENT_BLR, & NB_BLR_L, NB_BLR_U, NB_BLR_COL INTEGER :: NBCOL_in_LRB, SIZE_BEGS_BLR_COL TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_U, BLR_L LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: LR_ACTIVATED_INT INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U, & BEGS_BLR_COL DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: BLOCK INTEGER :: OMP_NUM INTEGER NPARTSASS, NPARTSCB, MAXI_CLUSTER, LWORK, & MAXI_CLUSTER_L, MAXI_CLUSTER_U, MAXI_CLUSTER_COL INTEGER :: allocok KEEP_BEGS_BLR_COL = .FALSE. KEEP_BEGS_BLR_L = .FALSE. nullify(BEGS_BLR_L) NB_BLR_U = -7654321 SHIFT_BEGS_BLR_U = 0 NULLIFY(BEGS_BLR_U) NULLIFY(BEGS_BLR_COL) MAXI_CLUSTER = 0 CURRENT_BLR = 1 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 ) LASTPANEL = (NPIV.LE.0) IF (LASTPANEL) 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_RECV, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, JBEG_BLOCK, 1, & MPI_INTEGER, COMM, IERR ) IF (JBEG_BLOCK.EQ.1) THEN NCOL_GEMM = NCOL_RECV - NPIV SHIFT_LPOS = NPIV SHIFT_UPOS = NPIV ELSE NCOL_GEMM = NCOL_RECV SHIFT_LPOS = JBEG_BLOCK-1 SHIFT_UPOS = 0 ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER , 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT, & 1, MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) IF ( LR_ACTIVATED ) THEN IF (JBEG_BLOCK.NE.1) THEN LA_BLOCFACTO = 0_8 ELSE LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8) ENDIF ELSE LA_BLOCFACTO = int(NPIV,8) * int(NCOL_RECV,8) ENDIF CALL DMUMPS_GET_SIZE_NEEDED( & NPIV, LA_BLOCFACTO, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID,SLAVEF, PROCNODE_STEPS, & DAD, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LA_BLOCFACTO LRLUS = LRLUS - LA_BLOCFACTO KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LA_BLOCFACTO KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LA_BLOCFACTO CALL MUMPS_LOAD_MEM_UPDATE(.FALSE., .FALSE., & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS) IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SIZE_BEGS_BLR_COL, 1, & MPI_INTEGER, COMM, IERR ) IF (SIZE_BEGS_BLR_COL.GT.0) THEN ALLOCATE(BEGS_BLR_COL(SIZE_BEGS_BLR_COL+2+IPANEL-1), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = SIZE_BEGS_BLR_COL+2 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during DMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF IF (IPANEL.GT.1) THEN BEGS_BLR_COL(1:IPANEL-1) = 1 ENDIF BEGS_BLR_COL(IPANEL) = 1 BEGS_BLR_COL(IPANEL+1) = NPIV+NELIM+1 DO I = 1, SIZE_BEGS_BLR_COL CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBCOL_in_LRB, 1, & MPI_INTEGER, COMM, IERR ) BEGS_BLR_COL(I+IPANEL+1) = & BEGS_BLR_COL(I+IPANEL) + NBCOL_in_LRB ENDDO ENDIF ENDIF IF ((NPIV .EQ. 0) & ) THEN IPIV=1 ELSE IPIV = IWPOS IWPOS = IWPOS + NPIV IF (NPIV .GT. 0.AND.JBEG_BLOCK.EQ.1) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) ENDIF IF ( LR_ACTIVATED .AND. JBEG_BLOCK.EQ.1) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*(NPIV+NELIM), & MPI_DOUBLE_PRECISION, & COMM, IERR ) LD_BLOCFACTO = NPIV+NELIM ENDIF IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_U, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_U(max(NB_BLR_U,1)), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = max(NB_BLR_U,1) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during DMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF ALLOCATE(BEGS_BLR_U(NB_BLR_U+2), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_U+2 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during DMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF CALL DMUMPS_MPI_UNPACK_LR_PARTIAL & (BUFR, LBUFR, LBUFR_BYTES, & POSITION, NPIV, NELIM, 'H', & BLR_U(1), NB_BLR_U, & JBEG_BLOCK, & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (JBEG_BLOCK.NE.1) SHIFT_BEGS_BLR_U = 1 IF (IFLAG.LT.0) GOTO 700 ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL_RECV, & MPI_DOUBLE_PRECISION, & COMM, IERR ) LD_BLOCFACTO = NCOL_RECV ENDIF ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) THEN CALL DMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 550 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 +KEEP(IXSZ)) .EQ. 0 ) THEN DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 550 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) CALL DMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LASTBL_INPANEL = JBEG_BLOCK+NCOL_RECV.GT.LCONT1 LASTBL_INLASTPANEL = LASTPANEL .AND. LASTBL_INPANEL IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL DMUMPS_ASM_SLAVE_ARROWHEADS(INODE, STEP(INODE), & N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, & LRGROUPS) ELSE CALL DMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 +KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) COMPRESS_CB = .FALSE. IF (LR_ACTIVATED) THEN COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) IF (COMPRESS_CB.AND.NPIV.EQ.0) THEN COMPRESS_CB = .FALSE. IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 ENDIF ENDIF NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF (NPIV.GT.0) THEN IF (JBEG_BLOCK.EQ.1) 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_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO ENDIF LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(SHIFT_LPOS,8) IF ( (JBEG_BLOCK.EQ.1) .AND. & ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) & ) THEN CALL dtrsm('L','L','N','N', NPIV, NROW1, ONE, & A(POSBLOCFACTO), LD_BLOCFACTO, & A_PTR(LPOS2), NCOL1) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (NPIV.NE.0) THEN IF ( (NPIV1.EQ.0).AND.(JBEG_BLOCK.EQ.1) & ) THEN IOLDPS = PTRIST(STEP(INODE)) CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_L) CALL REGROUPING2(BEGS_BLR_L, NPARTSASS, NASS1, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472), & NCOL1, KEEP(1)) NB_BLR_L = NPARTSCB IF (IFLAG.LT.0) GOTO 700 CALL DMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .TRUE., & .TRUE., & NPARTSASS_MASTER, & BEGS_BLR_L, & BEGS_BLR_COL, & huge(NPARTSASS_MASTER), & INFO_TMP) IF (associated(BEGS_BLR_COL)) DEALLOCATE(BEGS_BLR_COL) IF (IFLAG.LT.0) GOTO 700 ELSE CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_L) KEEP_BEGS_BLR_L = .TRUE. NB_BLR_L = size(BEGS_BLR_L) - 2 NPARTSASS = 1 NPARTSCB = NB_BLR_L ENDIF ENDIF ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (LR_ACTIVATED) THEN IF ( (JBEG_BLOCK.EQ.1) & ) THEN call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) call MAX_CLUSTER(BEGS_BLR_U(1+SHIFT_BEGS_BLR_U:NB_BLR_U+2), & NB_BLR_U+1-SHIFT_BEGS_BLR_U, & MAXI_CLUSTER_U) IF (SHIFT_BEGS_BLR_U.EQ.1) & MAXI_CLUSTER_U = max(MAXI_CLUSTER_U,NPIV+NELIM) IF (LASTBL_INLASTPANEL.AND.COMPRESS_CB) THEN MAXI_CLUSTER=max(MAXI_CLUSTER_U+NELIM,MAXI_CLUSTER_L) ELSE MAXI_CLUSTER=max(MAXI_CLUSTER_U,MAXI_CLUSTER_L) ENDIF LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER & + 2*MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + LWORK*OMP_NUM LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during DMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF CURRENT_BLR=1 ALLOCATE(BLR_L(NB_BLR_L), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_L LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during DMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL DMUMPS_COMPRESS_PANEL_I_NOOPT & (A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), NB_BLR_L+1, & DKEEP(8), KEEP(466), 0, & KEEP(473), BLR_L(1), & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP8, & OMP_NUM ) #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_L, 0) #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 300 IF ((KEEP(475).GE.1).AND.(JBEG_BLOCK.EQ.1)) THEN CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, & LD_BLOCFACTO, -6666, & NB_BLR_L+1, & BLR_L, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_L+1, & 2, 0, 0, & .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (KEEP(486).NE.2) THEN CALL DMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A_PTR(POSELT), LA_PTR, 1_8, & NCOL1, NCOL1, & .TRUE., & NPIV1+1, & 1, & NB_BLR_L+1, BLR_L(1), CURRENT_BLR, 'V', 1) ENDIF ENDIF 300 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ELSE CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_L) CURRENT_BLR=1 ENDIF ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & (OOCWRITE_COMPATIBLE_WITH_BLR .OR. NPIV.EQ.0) & .AND. (JBEG_BLOCK.EQ.1) & ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTPANEL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) LAST_CALL = .FALSE. CALL DMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L, & A_PTR(POSELT), & LA_PTR, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG_OOC, LAST_CALL) IF ( IFLAG_OOC .LT. 0 )THEN IFLAG = IFLAG_OOC GOTO 700 ENDIF ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (LR_ACTIVATED) THEN IF (NELIM.GT.0.AND.JBEG_BLOCK.EQ.1) THEN UPOS = 1_8+int(SHIFT_UPOS,8) CALL DMUMPS_BLR_UPD_NELIM_VAR_L_I( & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & CURRENT_BLR, BLR_L(1), NB_BLR_L+1, & CURRENT_BLR+1, NELIM, 'N') ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL DMUMPS_BLR_UPDATE_TRAILING_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & BEGS_BLR_U(1), size(BEGS_BLR_U), CURRENT_BLR, & BLR_L(1), NB_BLR_L+1, & BLR_U(1), NB_BLR_U+1, & 0, & .TRUE., & NPIV1, & 2, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ELSE UPOS = POSBLOCFACTO+int(SHIFT_UPOS,8) CALL dgemm('N','N', NCOL_GEMM, NROW1, NPIV, & ALPHA,A(UPOS), NCOL_RECV, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ENDIF ENDIF IF (LASTBL_INPANEL) THEN IW(IOLDPS + KEEP(IXSZ)) = IW(IOLDPS + KEEP(IXSZ)) - NPIV IW(IOLDPS + 3 + KEEP(IXSZ))= IW(IOLDPS + 3 + KEEP(IXSZ)) + NPIV IF (LASTPANEL) THEN IW(IOLDPS+1+KEEP(IXSZ) ) = IW(IOLDPS+3+KEEP(IXSZ) ) ENDIF ENDIF IF ( .not. LASTBL_INLASTPANEL .AND. & (IW(IOLDPS+1+KEEP(IXSZ)) .EQ. IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN write(*,*) 'Internal ERROR 1 **** IN BLACFACTO ' CALL MUMPS_ABORT() ENDIF IF (LR_ACTIVATED) THEN IF ((NPIV.GT.0) & ) THEN CALL DEALLOC_BLR_PANEL( BLR_U, NB_BLR_U, KEEP8, KEEP(34)) DEALLOCATE(BLR_U) IF (KEEP(486).NE.3) THEN CALL UPD_MRY_LU_LRGAIN(BLR_L, NPARTSCB & ) ENDIF ENDIF ENDIF LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) IWPOS = IWPOS - NPIV IF (LASTBL_INPANEL) THEN 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 MUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IF (LR_ACTIVATED.AND.LASTBL_INPANEL.AND. & (KEEP(486).EQ.3) & ) THEN IF (NPIV.NE.0) THEN CALL DMUMPS_BLR_FORCE_FREE_PANEL_L(IW(IOLDPS+XXF), IPANEL, & KEEP8, KEEP(34)) nullify(BLR_L) ENDIF ENDIF IF (LASTBL_INLASTPANEL) THEN IF (KEEP(486).NE.0) THEN IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (COMPRESS_CB) THEN CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER_AUX) KEEP_BEGS_BLR_COL = .TRUE. BEGS_BLR_COL(1+NPARTSASS_MASTER) = & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM NB_BLR_COL = size(BEGS_BLR_COL) - 1 call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) call MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER_COL=MAXI_CLUSTER_COL+NELIM IF ( (MAXI_CLUSTER.LT.MAXI_CLUSTER_COL).OR. & (MAXI_CLUSTER.LT.MAXI_CLUSTER_L) ) THEN MAXI_CLUSTER = max(MAXI_CLUSTER_COL,MAXI_CLUSTER_L) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER & + 2*MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + LWORK*OMP_NUM LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during DMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF ENDIF allocate(CB_LRB(NB_BLR_L,NB_BLR_COL-NPARTSASS_MASTER), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_L*(NB_BLR_COL-NPARTSASS_MASTER) GOTO 700 ENDIF CALL DMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif IF (COMPRESS_CB) THEN CALL DMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_L, NB_BLR_COL-NPARTSASS_MASTER, & NPARTSASS_MASTER, & NROW1, NCOL1-NPIV1-NPIV, INODE, & IW(IOLDPS+XXF), 0, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, OMP_NUM, & -9999, -9999, -9999, KEEP(1), & IDUMMY, 0, -9999 ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 IF ( KEEP(251).EQ.2 .AND. KEEP(486).EQ.2 ) THEN CALL DMUMPS_BLR_FREE_ALL_PANELS( IW(IOLDPS+XXF), & 0, & KEEP8, KEEP(34) ) ENDIF ENDIF CALL DMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, roota, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF GOTO 550 700 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 550 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(BEGS_BLR_COL)) THEN IF (.NOT. KEEP_BEGS_BLR_COL) DEALLOCATE(BEGS_BLR_COL) ENDIF IF (associated(BEGS_BLR_L)) THEN IF (.NOT. KEEP_BEGS_BLR_L) DEALLOCATE(BEGS_BLR_L) ENDIF IF ((NPIV.GT.0) & ) THEN IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_PROCESS_BLOCFACTO SUBROUTINE DMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, & NPIV, NELIM, DIR, & BLR_U, NB_BLOCK_U, & BEGS_BLR_U, KEEP8, & COMM, IERR, IFLAG, IERROR) USE DMUMPS_LR_CORE, ONLY : LRB_TYPE, ALLOC_LRB USE DMUMPS_LR_TYPE IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR INTEGER, INTENT(IN) :: LBUFR_BYTES INTEGER, INTENT(IN) :: BUFR(LBUFR) INTEGER, INTENT(INOUT) :: POSITION INTEGER, INTENT(IN) :: NB_BLOCK_U, NELIM, NPIV CHARACTER(len=1) :: DIR INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(OUT) :: IERR TYPE (LRB_TYPE), INTENT(OUT), & DIMENSION(max(NB_BLOCK_U,1)):: BLR_U INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2) :: BEGS_BLR_U INTEGER(8) :: KEEP8(150) LOGICAL :: ISLR INTEGER :: ISLR_INT, I INTEGER :: K, M, N INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IERR = 0 IF (size(BLR_U) .NE. & MAX(NB_BLOCK_U,1) ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_MPI_UNPACK", & NB_BLOCK_U,size(BLR_U) CALL MUMPS_ABORT() ENDIF BEGS_BLR_U(1) = 1 BEGS_BLR_U(2) = NPIV+NELIM+1 DO I = 1, NB_BLOCK_U CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ISLR_INT, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & K, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & M, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & N, 1, & MPI_INTEGER, COMM, IERR ) BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M IF (ISLR_INT .eq. 1) THEN ISLR = .TRUE. ELSE ISLR = .FALSE. ENDIF CALL ALLOC_LRB( BLR_U(I), K, M, N, ISLR, & IFLAG, IERROR, KEEP8 ) IF (IFLAG.LT.0) RETURN IF (ISLR) THEN IF (K .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*K, MPI_DOUBLE_PRECISION, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%R(1,1), N*K, MPI_DOUBLE_PRECISION, & COMM, IERR) ENDIF ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*N, MPI_DOUBLE_PRECISION, & COMM, IERR) ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_MPI_UNPACK_LR SUBROUTINE DMUMPS_MPI_UNPACK_LR_PARTIAL( & BUFR, LBUFR, LBUFR_BYTES, POSITION, & NPIV, NELIM, DIR, & BLR_U, NB_BLOCK_U, & JBEG_BLOCK, & BEGS_BLR_U, KEEP8, & COMM, IERR, IFLAG, IERROR) USE DMUMPS_LR_CORE, ONLY : LRB_TYPE, ALLOC_LRB USE DMUMPS_LR_TYPE IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR INTEGER, INTENT(IN) :: LBUFR_BYTES INTEGER, INTENT(IN) :: BUFR(LBUFR) INTEGER, INTENT(INOUT) :: POSITION INTEGER, INTENT(IN) :: NB_BLOCK_U, NELIM, NPIV, JBEG_BLOCK CHARACTER(len=1) :: DIR INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(OUT) :: IERR TYPE (LRB_TYPE), INTENT(OUT), & DIMENSION(max(NB_BLOCK_U,1)):: BLR_U INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2) :: BEGS_BLR_U INTEGER(8) :: KEEP8(150) LOGICAL :: ISLR INTEGER :: ISLR_INT, I INTEGER :: K, M, N INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IERR = 0 IF (size(BLR_U) .NE. & MAX(NB_BLOCK_U,1) ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_MPI_UNPACK", & NB_BLOCK_U,size(BLR_U) CALL MUMPS_ABORT() ENDIF BEGS_BLR_U(1) = 1 BEGS_BLR_U(2) = NPIV+NELIM+1 IF (JBEG_BLOCK.NE.1) THEN BEGS_BLR_U(2) = JBEG_BLOCK ENDIF DO I = 1, NB_BLOCK_U CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ISLR_INT, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & K, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & M, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & N, 1, & MPI_INTEGER, COMM, IERR ) BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M IF (ISLR_INT .eq. 1) THEN ISLR = .TRUE. ELSE ISLR = .FALSE. ENDIF CALL ALLOC_LRB( BLR_U(I), K, M, N, ISLR, & IFLAG, IERROR, KEEP8 ) IF (IFLAG.LT.0) RETURN IF (ISLR) THEN IF (K .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*K, MPI_DOUBLE_PRECISION, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%R(1,1), N*K, MPI_DOUBLE_PRECISION, & COMM, IERR) ENDIF ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*N, MPI_DOUBLE_PRECISION, & COMM, IERR) ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_MPI_UNPACK_LR_PARTIAL MUMPS_5.8.1/src/zfac_compact_factors_m.F0000664000175000017500000001305215042446442020030 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_COMPACT_FACTORS_M PRIVATE PUBLIC :: ZMUMPS_TRY_COMPACT_FACTORS CONTAINS SUBROUTINE ZMUMPS_TRY_COMPACT_FACTORS(ICNTL49_LOC, & WK_USER_PROVIDED, S, KEEP, KEEP8, INFO, MYID, ICNTL, & PROK, MP, ZMUMPS_LBUFR_BYTES8, ZMUMPS_LBUF8, & LIWK, LIWK8 ) USE OMP_LIB USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_FREE_S_WK C C Purpose C ======= C If no factors stored in S and .NOT.WK_USER_PROVIDED deallocate(S) C If ICNTL49_LOC = 1, 2 try to compress S C Possible values : C 0 : nothing is done. C 1 : compact S while satisfying the C memory constraint that might have been provided C with ICNTL(23) feature. C 2 : compact S. The memory constraint that might have been C provided with ICNTL(23) feature does not apply C C Parameters C ========== INTEGER :: ICNTL49_LOC, MP, MYID COMPLEX(kind=8), POINTER, DIMENSION(:) :: S INTEGER :: KEEP(500), INFO(80), ICNTL(60) LOGICAL :: PROK, WK_USER_PROVIDED INTEGER(8) :: ZMUMPS_LBUFR_BYTES8, ZMUMPS_LBUF8 INTEGER(8) :: KEEP8(150) INTEGER(8), INTENT(IN) :: LIWK, LIWK8 C C Local declarations C ================== C LOGICAL :: Compact_S_Authorized INTEGER :: IERR, NOMP COMPLEX(kind=8), DIMENSION(:), POINTER :: TMPS INTEGER(8) :: TMPpeak, I8 !$ INTEGER(8) :: CHUNK8 IF (.NOT.WK_USER_PROVIDED) THEN C{ IF (KEEP8(31).EQ.0) THEN C{ C No factors stored in S IF (associated(S)) THEN CALL ZMUMPS_DM_FREE_S_WK(S, KEEP(430)) C Reset KEEP(430)=0 since next allocations of S C will be from Fotran KEEP(430)=0 NULLIFY(S) KEEP8(23) = 0 ENDIF C} ELSE IF (ICNTL49_LOC.NE.0) THEN C{ Factors stored in S, try to compact S TMPpeak = KEEP8(73) + KEEP8(31) & - (ZMUMPS_LBUFR_BYTES8+ZMUMPS_LBUF8)/int(KEEP(35),8) & - KEEP8(26) & - ((LIWK+LIWK8*KEEP(10)+KEEP8(27))*int(KEEP(34),8)) & /int(KEEP(35),8) Compact_S_Authorized = .FALSE. C Set Compact_S_Authorized IF (KEEP8(4).GT.0_8) THEN IF (TMPpeak.LT.KEEP8(75)) & Compact_S_Authorized=.TRUE. ELSE Compact_S_Authorized = .TRUE. ENDIF IF (ICNTL49_LOC.EQ.1.AND..NOT.Compact_S_Authorized) THEN C{ INFO(1) = INFO(1) + 4 C INFO(2) = C New value of ICNTL(23) (in MBytes: C ( KEEP8(4) + (TMPpeak- KEEP8(75))*KEEP(35) )/1000000 C + 1 for safety INFO(2) = int( & ( & KEEP8(4) + & (TMPpeak- KEEP8(75))*int(KEEP(35),8) & ) / 1000000_8 + 1_8 & ) C In fact increasing INFO(2) will not help C since increasing ICNTL(23) will also increase C MAXS and thus the peak of memory. C Thus setting ICNTL(23) to INFO(2) might not C enable user to Compact_S. C Simplest is to advice to set ICNTL(49)=2 C or to switch of ICNTL(23) feature. IF (PROK) THEN WRITE(MP,'(A,I4,A,I2,A,/A,/A,A)') & " ** WARNING ** on MPI proc= ", MYID, & " ICNTL(49)= ", ICNTL49_LOC, & ", but not enough memory to compact S due to ", & " memory limitation given by ICNTL(23).", & " ICNTL(23) should be reset to zero or", & " ICNTL(49) should be set to 2 " ENDIF C} ELSE IF ( & (ICNTL49_LOC.EQ.1.AND.Compact_S_Authorized) & .OR. & (ICNTL49_LOC.EQ.2) C{ & ) THEN C Try to compact S of size MAXS ALLOCATE(TMPS(KEEP8(31)), stat=IERR) IF (IERR .GT. 0 ) THEN IF (PROK) THEN WRITE(MP,'(A,I4,A,I3,A)') & " ** WARNING ** on MPI proc= ", MYID, & " ICNTL(49)= ", ICNTL49_LOC, & ", but not enough memory to compact S " ENDIF INFO(1) = INFO(1) + 4 GOTO 513 ENDIF C !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK8=int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF ( KEEP8(31) > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO I8=1_8, KEEP8(31) TMPS(I8) = S(I8) ENDDO !$OMP END PARALLEL DO CALL ZMUMPS_DM_FREE_S_WK(S, KEEP(430)) C Reset KEEP(430)=0 since TMPS is allocated C in Fortran and S=>TMPS should be deallocated C in Fortran. KEEP(430)=0 S => TMPS; NULLIFY(TMPS) KEEP8(23) = KEEP8(31) C} ENDIF C} ENDIF C} ENDIF 513 CONTINUE RETURN END SUBROUTINE ZMUMPS_TRY_COMPACT_FACTORS END MODULE ZMUMPS_FAC_COMPACT_FACTORS_M MUMPS_5.8.1/src/dana_lr.F0000664000175000017500000017736315042446437014766 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_ANA_LR USE DMUMPS_LR_CORE USE MUMPS_LR_STATS USE MUMPS_LR_COMMON USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY: LMATRIX_T !$ USE OMP_LIB, ONLY: omp_get_max_threads IMPLICIT NONE CONTAINS SUBROUTINE GET_CUT(IWR, NASS, NCB, LRGROUPS, NPARTSCB, & NPARTSASS, CUT) INTEGER, INTENT(IN) :: NASS, NCB INTEGER, INTENT(IN) :: IWR(*) INTEGER, INTENT(IN), DIMENSION(:) :: LRGROUPS INTEGER, INTENT(OUT) :: NPARTSCB, NPARTSASS INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: I, CURRENT_PART, CUTBUILDER,allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: BIG_CUT ALLOCATE(BIG_CUT(max(NASS,1)+NCB+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of BIG_CUT in GET_CUT" CALL MUMPS_ABORT() ENDIF CURRENT_PART = LRGROUPS(IWR(1)) BIG_CUT(1) = 1 BIG_CUT(2) = 2 CUTBUILDER = 2 NPARTSASS = 0 NPARTSCB = 0 DO I = 2,NASS + NCB IF (LRGROUPS(IWR(I)) == CURRENT_PART) THEN BIG_CUT(CUTBUILDER) = BIG_CUT(CUTBUILDER) + 1 ELSE CUTBUILDER = CUTBUILDER + 1 BIG_CUT(CUTBUILDER) = BIG_CUT(CUTBUILDER-1) + 1 CURRENT_PART = LRGROUPS(IWR(I)) END IF IF (I == NASS) NPARTSASS = CUTBUILDER - 1 END DO IF (NASS.EQ.1) NPARTSASS= 1 NPARTSCB = CUTBUILDER - 1 - NPARTSASS ALLOCATE(CUT(max(NPARTSASS,1)+NPARTSCB+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of CUT in GET_CUT" CALL MUMPS_ABORT() ENDIF IF (NPARTSASS.EQ.0) THEN CUT(1) = 1 CUT(2:2+NPARTSCB) = BIG_CUT(1:1+NPARTSCB) ELSE CUT = BIG_CUT(1:NPARTSASS+NPARTSCB+1) ENDIF if(allocated(BIG_CUT)) DEALLOCATE(BIG_CUT) END SUBROUTINE GET_CUT SUBROUTINE SEP_GROUPING( NFRONT, KEEP, & NV, VLIST, N, NZ, LRGROUPS, NBGROUPS, IW, & LW, IPE, LEN, GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, NODE, & GEN2HALO, K482, K472, K469, SEP_SIZE, MAXSIZE_PARTS, & KEEP10, LP, LPOK, IFLAG, IERROR) INTEGER, INTENT(IN) :: NFRONT, KEEP(500) INTEGER(8), INTENT(IN) :: NZ, LW INTEGER, INTENT(IN) :: NV, N, GROUP_SIZE, HALO_DEPTH INTEGER, INTENT(IN) :: IW(LW), LEN(N), NODE, K482 INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: K472, K469, SEP_SIZE, KEEP10, LP LOGICAL :: LPOK INTEGER, INTENT(INOUT) :: NBGROUPS, WORKH(N) INTEGER, INTENT(INOUT) :: VLIST(NV), TRACE(N) INTEGER :: LRGROUPS(:) INTEGER, INTENT(INOUT) :: GEN2HALO(N) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: MAXSIZE_PARTS INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IPTRHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: PARTS, JCNHALO INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBG_CAPT, & NBGROUPS_KWAY, I, GROUP_SIZE2, LRGROUPS_SIGN, IERR INTEGER :: MAXSIZE_PARTS_LOC #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) INTEGER :: METIS_IDX_SIZE #endif #if defined (scotch) || defined (ptscotch) INTEGER :: SCOTCH_IDX_SIZE #endif CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV, & NFRONT, KEEP(35)) NBGROUPS_KWAY = MAX( & INT(dble(NV+GROUP_SIZE2-1)/dble(GROUP_SIZE2)) & ,1) IF (NV .GE. SEP_SIZE) THEN LRGROUPS_SIGN = 1 ELSE LRGROUPS_SIGN = -1 ENDIF IF (NBGROUPS_KWAY > 1) THEN IF (K469.EQ.3) THEN !$OMP CRITICAL(gethalo_cri) CALL GETHALONODES(N, IW, LW, IPE, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, LEN, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(max(HALOEDGENBR,1)), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) ENDIF CALL GETHALOGRAPH(WORKH, NHALO, N, IW, LW, IPE, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO) !$OMP END CRITICAL(gethalo_cri) IF (IFLAG.LT.0) RETURN ELSE CALL GETHALONODES(N, IW, LW, IPE, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, LEN, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(max(HALOEDGENBR,1)), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) RETURN ENDIF CALL GETHALOGRAPH(WORKH, NHALO, N, IW, LW, IPE, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO) ENDIF IF (K482.EQ.1) THEN #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_KWAY_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ELSE IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 1 ELSE CALL MUMPS_METIS_KWAY_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ENDIF #endif ELSE IF (K482.EQ.2) THEN #if defined (scotch) || defined (ptscotch) CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_IDX_SIZE) IF (SCOTCH_IDX_SIZE .EQ. 32) THEN IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 2 ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto32( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto64( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) END IF IF ((IFLAG.LT.0).AND.LPOK) THEN WRITE(LP,*) " Internal error in SCOTCH during ", & " Kway partitioning, SCOTCHFGRAPHPART, " WRITE(LP,*) & " please also provide METIS package to MUMPS " ENDIF #endif ELSE WRITE(6,*) " Internal ERROR K482=", K482 CALL MUMPS_ABORT() END IF IF (IFLAG.LT.0) GOTO 500 CALL GET_GLOBAL_GROUPS(PARTS, VLIST, NV, & NBGROUPS_KWAY, LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN, & MAXSIZE_PARTS_LOC, .FALSE., GROUP_SIZE2) MAXSIZE_PARTS = max(MAXSIZE_PARTS, MAXSIZE_PARTS_LOC) ELSE MAXSIZE_PARTS = max(MAXSIZE_PARTS,NV) !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + 1 !$OMP END ATOMIC DO I=1,NV LRGROUPS(VLIST(I)) = LRGROUPS_SIGN*(NBG_CAPT + 1) END DO END IF 500 IF (allocated(IPTRHALO)) then DEALLOCATE(IPTRHALO) ENDIF IF (allocated(PARTS)) then DEALLOCATE(PARTS) ENDIF IF (allocated(JCNHALO)) then DEALLOCATE(JCNHALO ) ENDIF RETURN END SUBROUTINE SEP_GROUPING SUBROUTINE SEP_GROUPING_AB ( NFRONT, KEEP, & NV, NVEXPANDED, & VLIST, N, LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, NODE, & GEN2HALO, K482, K472, K469, SEP_SIZE, MAXSIZE_PARTS, & KEEP10, LP, LPOK, IFLAG, IERROR) INTEGER, INTENT(IN) :: NFRONT, KEEP(500) TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: NV, NVEXPANDED, & N, GROUP_SIZE, HALO_DEPTH INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: NODE, K482 INTEGER, INTENT(IN) :: K472, K469, SEP_SIZE, KEEP10, LP LOGICAL :: LPOK INTEGER, INTENT(INOUT) :: NBGROUPS, WORKH(N) INTEGER, INTENT(INOUT) :: VLIST(NV), TRACE(N) INTEGER :: LRGROUPS(:) INTEGER, INTENT(INOUT) :: GEN2HALO(N) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: MAXSIZE_PARTS INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IPTRHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: PARTS, JCNHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: VWGT INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBG_CAPT, & NBGROUPS_KWAY, I, GROUP_SIZE2, LRGROUPS_SIGN, IERR INTEGER :: MAXSIZE_PARTS_LOC DOUBLE PRECISION :: COMPRESS_RATIO LOGICAL :: AB_ACTIVE #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) INTEGER :: METIS_IDX_SIZE #endif #if defined (scotch) || defined (ptscotch) INTEGER :: SCOTCH_IDX_SIZE #endif AB_ACTIVE = (NVEXPANDED.GT.NV) CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED, & NFRONT, KEEP(35)) COMPRESS_RATIO= dble(NVEXPANDED)/dble(NV) NBGROUPS_KWAY = MAX( & INT(dble(NVEXPANDED+GROUP_SIZE2-1)/dble(GROUP_SIZE2)) & ,1) NBGROUPS_KWAY = min(NBGROUPS_KWAY, NV) IF (NVEXPANDED .GE. SEP_SIZE) THEN LRGROUPS_SIGN = 1 ELSE LRGROUPS_SIGN = -1 ENDIF IF (NBGROUPS_KWAY > 1) THEN IF (K469.EQ.3) THEN !$OMP CRITICAL(gethalo_cri) CALL GETHALONODES_AB(N, LUMAT, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(max(HALOEDGENBR,1)), VWGT(NHALO), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) ENDIF DO I=1, NHALO VWGT(I) = SIZEOFBLOCKS(WORKH(I)) ENDDO CALL GETHALOGRAPH_AB(WORKH, NV, & NHALO, N, LUMAT, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO, PARTS) !$OMP END CRITICAL(gethalo_cri) IF (IFLAG.LT.0) RETURN ELSE CALL GETHALONODES_AB(N, LUMAT, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(max(HALOEDGENBR,1)), VWGT(NHALO), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) RETURN ENDIF DO I=1, NHALO VWGT(I) = SIZEOFBLOCKS(WORKH(I)) ENDDO CALL GETHALOGRAPH_AB(WORKH, NV, & NHALO, N, LUMAT, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO, PARTS) ENDIF IF (K482.EQ.1) THEN #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_KWAY_AB_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) ELSE IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 1 ELSE CALL MUMPS_METIS_KWAY_AB_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ENDIF #endif ELSE IF (K482.EQ.2) THEN #if defined (scotch) || defined (ptscotch) CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_IDX_SIZE) IF (SCOTCH_IDX_SIZE .EQ. 32) THEN IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 2 ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto32( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto64( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) END IF IF ((IFLAG.LT.0).AND.LPOK) THEN WRITE(LP,*) " Internal error in SCOTCH during ", & " Kway partitioning, SCOTCHFGRAPHPART, " WRITE(LP,*) & " also provide METIS package to MUMPS " ENDIF #endif ELSE WRITE(6,*) " Internal ERROR K482=", K482 CALL MUMPS_ABORT() END IF IF (IFLAG.LT.0) GOTO 500 CALL GET_GLOBAL_GROUPS(PARTS,VLIST, NV, & NBGROUPS_KWAY, LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN, & MAXSIZE_PARTS_LOC, AB_ACTIVE, GROUP_SIZE2) MAXSIZE_PARTS = max( MAXSIZE_PARTS, & int(dble(MAXSIZE_PARTS_LOC*COMPRESS_RATIO)) ) ELSE MAXSIZE_PARTS = max(MAXSIZE_PARTS,NV) !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + 1 !$OMP END ATOMIC DO I=1,NV LRGROUPS(VLIST(I)) = LRGROUPS_SIGN*(NBG_CAPT + 1) END DO END IF 500 IF (allocated(IPTRHALO)) then DEALLOCATE(IPTRHALO) ENDIF IF (allocated(PARTS)) then DEALLOCATE(PARTS) ENDIF IF (allocated(JCNHALO)) then DEALLOCATE(JCNHALO ) ENDIF IF (allocated(VWGT)) then DEALLOCATE(VWGT) ENDIF RETURN END SUBROUTINE SEP_GROUPING_AB SUBROUTINE GETHALONODES_AB(N, LUMAT, IND, NIND, PMAX, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) TYPE(LMATRIX_T) :: LUMAT INTEGER,DIMENSION(:),INTENT(IN) :: IND INTEGER, INTENT(IN) :: N, NODE INTEGER, INTENT(IN) :: PMAX,NIND INTEGER, INTENT(OUT) :: NHALO INTEGER, INTENT(INOUT) :: TRACE(N), WORKH(N) INTEGER :: GEN2HALO(N) INTEGER(8), INTENT(OUT) :: HALOEDGENBR INTEGER :: I, J, II INTEGER :: HALOI, NB, NEWNHALO INTEGER(8) :: SEPEDGES_TOTAL, & SEPEDGES_INTERNAL WORKH(1:NIND) = IND NHALO = NIND NEWNHALO = 0 HALOEDGENBR = 0_8 SEPEDGES_TOTAL = 0_8 SEPEDGES_INTERNAL = 0_8 DO I=1,NIND HALOI = WORKH(I) GEN2HALO(HALOI) = I IF (TRACE(HALOI) .NE. NODE) THEN TRACE(HALOI) = NODE END IF ENDDO DO I=1,NIND HALOI = WORKH(I) NB = LUMAT%COL(HALOI)%NBINCOL SEPEDGES_TOTAL = SEPEDGES_TOTAL + int(NB,8) DO J=1, NB II = LUMAT%COL(HALOI)%IRN(J) IF (TRACE(II).NE.NODE) THEN NEWNHALO = NEWNHALO + 1 WORKH(NHALO+NEWNHALO) = II GEN2HALO(II) = NHALO+NEWNHALO TRACE(II) = NODE ELSE IF (GEN2HALO(II).LE.NHALO) THEN SEPEDGES_INTERNAL = SEPEDGES_INTERNAL + 1_8 ENDIF ENDIF ENDDO END DO HALOEDGENBR = SEPEDGES_TOTAL + & (SEPEDGES_TOTAL - SEPEDGES_INTERNAL) NHALO = NHALO + NEWNHALO END SUBROUTINE GETHALONODES_AB SUBROUTINE GETHALOGRAPH_AB(HALO,NSEP,NHALO, & N,LUMAT,IPTRHALO,JCNHALO, & HALOEDGENBR,TRACE,NODE, GEN2HALO, IQ) INTEGER, INTENT(IN) :: N TYPE(LMATRIX_T) :: LUMAT INTEGER,INTENT(IN):: NSEP, NHALO, NODE INTEGER,INTENT(IN):: GEN2HALO(N) INTEGER,DIMENSION(NHALO),INTENT(IN) :: HALO INTEGER, INTENT(IN) :: TRACE(N) INTEGER(8),INTENT(IN) :: HALOEDGENBR INTEGER(8), INTENT(OUT) :: IPTRHALO(NHALO+1) INTEGER, INTENT(OUT) :: JCNHALO(max(HALOEDGENBR,1)) INTEGER :: IQ(NHALO) INTEGER::I,J,NB,II,JJ,HALOI,HALOJ DO I=NSEP+1, NHALO IQ(I) = 0 ENDDO DO I=1,NSEP HALOI = HALO(I) NB = LUMAT%COL(HALOI)%NBINCOL IQ(I) = NB DO JJ=1, NB II = LUMAT%COL(HALOI)%IRN(JJ) J = GEN2HALO(II) IF (J.GT.NSEP) THEN IQ(J) = IQ(J) + 1 ENDIF ENDDO ENDDO IPTRHALO(1) = 1_8 DO I=1,NHALO IPTRHALO(I+1) = IPTRHALO(I)+int(IQ(I),8) ENDDO DO I=1,NSEP HALOI = HALO(I) NB = LUMAT%COL(HALOI)%NBINCOL DO JJ=1, NB HALOJ = LUMAT%COL(HALOI)%IRN(JJ) J = GEN2HALO(HALOJ) JCNHALO(IPTRHALO(I)) = J IPTRHALO(I) = IPTRHALO(I) + 1 IF (J.GT.NSEP) THEN JCNHALO(IPTRHALO(J)) = I IPTRHALO(J) = IPTRHALO(J) + 1 ENDIF ENDDO ENDDO IPTRHALO(1) = 1_8 DO I=1,NHALO IPTRHALO(I+1) = IPTRHALO(I)+int(IQ(I),8) ENDDO END SUBROUTINE GETHALOGRAPH_AB SUBROUTINE GET_GLOBAL_GROUPS(PARTS, SEP, NSEP, NPARTS, & LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN, & MAXSIZE_PARTS_LOC, AB_ACTIVE, GROUP_SIZE2) INTEGER,INTENT(IN) :: NSEP, N, LRGROUPS_SIGN, GROUP_SIZE2 INTEGER :: PARTS(:) LOGICAL :: AB_ACTIVE INTEGER,DIMENSION(:),INTENT(INOUT) :: SEP INTEGER, INTENT(INOUT) :: NPARTS INTEGER, INTENT(INOUT) :: NBGROUPS INTEGER :: LRGROUPS(:) INTEGER, INTENT(OUT) :: MAXSIZE_PARTS_LOC INTRINSIC maxval INTEGER:: I,CNT,NB_PARTS_WITHOUT_SEP_NODE,allocok INTEGER:: TARGET_SIZE_KWAY INTEGER:: MAXSIZE_PARTS_LOC_NEW, NBG_CAPT INTEGER,DIMENSION(:),ALLOCATABLE::SIZES, RIGHTPART INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR #if ! defined(NO_SPLIT_IN_BLRGROUPING) INTEGER :: NB_PARTS_WITH_SPLIT, IP, SZ_FINAL, II, NB_SPLIT INTEGER :: TARGET_SIZE_SPLIT #endif INTEGER,DIMENSION(:),ALLOCATABLE :: NEWSEP ALLOCATE( NEWSEP(NSEP), & SIZES(NPARTS), & RIGHTPART(NPARTS), & PARTPTR(NPARTS+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GLOBAL_GROUPS" CALL MUMPS_ABORT() ENDIF TARGET_SIZE_KWAY = GROUP_SIZE2 TARGET_SIZE_SPLIT = TARGET_SIZE_KWAY IF (AB_ACTIVE) TARGET_SIZE_SPLIT =huge(TARGET_SIZE_SPLIT) NB_PARTS_WITHOUT_SEP_NODE = 0 RIGHTPART = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = SIZES(PARTS(I)) + 1 END DO MAXSIZE_PARTS_LOC = maxval(SIZES) CNT = 0 PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) IF (SIZES(I-1)==0) THEN NB_PARTS_WITHOUT_SEP_NODE = NB_PARTS_WITHOUT_SEP_NODE + 1 ELSE CNT = CNT + 1 RIGHTPART(I-1) = CNT #if ! defined(NO_SPLIT_IN_BLRGROUPING) SIZES(CNT) = SIZES(I-1) #endif END IF END DO NPARTS = NPARTS - NB_PARTS_WITHOUT_SEP_NODE #if ! defined(NO_SPLIT_IN_BLRGROUPING) IF (MAXSIZE_PARTS_LOC.LT.TARGET_SIZE_SPLIT) THEN #endif !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + NPARTS !$OMP END ATOMIC DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) LRGROUPS(SEP(I)) = LRGROUPS_SIGN*(RIGHTPART(PARTS(I)) & + NBG_CAPT) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO SEP = NEWSEP #if ! defined(NO_SPLIT_IN_BLRGROUPING) ELSE DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO SEP = NEWSEP PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) ENDDO NB_PARTS_WITH_SPLIT = 0 MAXSIZE_PARTS_LOC_NEW = 0 DO IP =1, NPARTS NB_SPLIT = (SIZES(IP) + TARGET_SIZE_SPLIT-1) & / TARGET_SIZE_SPLIT SZ_FINAL = (SIZES(IP) + NB_SPLIT-1) / NB_SPLIT NB_PARTS_WITH_SPLIT = NB_PARTS_WITH_SPLIT + & ( & ( (PARTPTR(IP+1) - PARTPTR(IP))+ SZ_FINAL-1 ) / & SZ_FINAL & ) ENDDO !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + NB_PARTS_WITH_SPLIT !$OMP END ATOMIC NB_PARTS_WITH_SPLIT = 0 DO IP=1,NPARTS NB_SPLIT = (SIZES(IP) + TARGET_SIZE_SPLIT-1) & / TARGET_SIZE_SPLIT SZ_FINAL = (SIZES(IP) + NB_SPLIT-1) / NB_SPLIT MAXSIZE_PARTS_LOC_NEW = max(MAXSIZE_PARTS_LOC_NEW, & SZ_FINAL) DO I=PARTPTR(IP), PARTPTR(IP+1)-1, SZ_FINAL NB_PARTS_WITH_SPLIT = NB_PARTS_WITH_SPLIT +1 DO II=I, min(I+SZ_FINAL-1,PARTPTR(IP+1)-1) LRGROUPS(SEP(II)) = LRGROUPS_SIGN*(NB_PARTS_WITH_SPLIT & + NBG_CAPT) ENDDO ENDDO ENDDO NPARTS = NB_PARTS_WITH_SPLIT MAXSIZE_PARTS_LOC = MAXSIZE_PARTS_LOC_NEW ENDIF #endif DEALLOCATE(NEWSEP,SIZES,RIGHTPART,PARTPTR) END SUBROUTINE GET_GLOBAL_GROUPS SUBROUTINE GETHALONODES(N, IW, LW, IPE, IND, NIND, PMAX, & NHALO, TRACE, WORKH, NODE, LEN, CNT, & GEN2HALO) INTEGER,DIMENSION(:),INTENT(IN) :: IND INTEGER(8), INTENT(IN) :: LW INTEGER, INTENT(IN) :: N, NODE INTEGER, INTENT(IN) :: IW(LW), LEN(N) INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: PMAX,NIND INTEGER, INTENT(OUT) :: NHALO INTEGER, INTENT(INOUT) :: TRACE(N), WORKH(N) INTEGER :: GEN2HALO(N) INTEGER(8), INTENT(OUT) :: CNT INTEGER :: DEPTH, I, LAST_LVL_START INTEGER :: HALOI INTEGER(8) :: J WORKH(1:NIND) = IND LAST_LVL_START = 1 NHALO = NIND CNT = 0 DO I=1,NIND HALOI = WORKH(I) GEN2HALO(HALOI) = I IF (TRACE(HALOI) .NE. NODE) THEN TRACE(HALOI) = NODE END IF DO J=IPE(HALOI),IPE(HALOI+1)-1 IF (TRACE(IW(J)).EQ.NODE) THEN CNT = CNT + 2 END IF END DO END DO DO DEPTH=1,PMAX CALL NEIGHBORHOOD(WORKH, NHALO, N, IW, LW, IPE, & TRACE, NODE, LEN, CNT, LAST_LVL_START, & DEPTH, PMAX, GEN2HALO) END DO END SUBROUTINE GETHALONODES SUBROUTINE NEIGHBORHOOD(HALO, NHALO, N, IW, LW, IPE, & TRACE, NODE, LEN, CNT, LAST_LVL_START, & DEPTH, PMAX, GEN2HALO) INTEGER, INTENT(IN) :: N, NODE, DEPTH, PMAX INTEGER,INTENT(INOUT) :: NHALO, GEN2HALO(N) INTEGER, INTENT(INOUT) :: LAST_LVL_START INTEGER(8), INTENT(INOUT) :: CNT INTEGER,DIMENSION(:),INTENT(INOUT) :: HALO INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, TARGET, INTENT(IN) :: IW(LW) INTEGER, INTENT(IN) :: LEN(N) INTEGER,DIMENSION(:) :: TRACE INTEGER :: AvgDens, THRESH INTEGER :: I,INEI,NADJI,NEWNHALO, NEIGH INTEGER, DIMENSION(:), POINTER :: ADJI INTEGER(8) :: J NEWNHALO = 0 AvgDens = nint(dble(IPE(N+1)-1_8)/dble(N)) THRESH = AvgDens*10 DO I=LAST_LVL_START,NHALO NADJI = LEN(HALO(I)) IF (NADJI.GT.THRESH) CYCLE ADJI => IW(IPE(HALO(I)):IPE(HALO(I)+1)-1) DO INEI=1,NADJI IF (TRACE(ADJI(INEI)) .NE. NODE) THEN NEIGH = ADJI(INEI) IF (LEN(NEIGH).GT.THRESH) CYCLE TRACE(NEIGH) = NODE NEWNHALO = NEWNHALO + 1 HALO(NHALO+NEWNHALO) = NEIGH GEN2HALO(NEIGH) = NHALO + NEWNHALO DO J=IPE(NEIGH),IPE(NEIGH+1)-1 IF (TRACE(IW(J)).EQ.NODE) THEN CNT = CNT + 2 END IF END DO END IF END DO END DO LAST_LVL_START = NHALO + 1 NHALO = NHALO + NEWNHALO END SUBROUTINE NEIGHBORHOOD SUBROUTINE GETHALOGRAPH(HALO,NHALO,N,IW,LW,IPE,IPTRHALO,JCNHALO, & HALOEDGENBR,TRACE,NODE, GEN2HALO) INTEGER, INTENT(IN) :: N INTEGER,INTENT(IN):: NHALO, NODE INTEGER,INTENT(IN):: GEN2HALO(N) INTEGER,DIMENSION(NHALO),INTENT(IN) :: HALO INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: IW(LW), TRACE(N) INTEGER(8),INTENT(IN) :: HALOEDGENBR INTEGER(8), INTENT(OUT) :: IPTRHALO(NHALO+1) INTEGER, INTENT(OUT) :: JCNHALO(max(HALOEDGENBR,1)) INTEGER::I,IPTR_CNT,JCN_CNT,HALOI INTEGER(8) :: J, CNT CNT = 0 IPTR_CNT = 2 JCN_CNT = 1 IPTRHALO(1) = 1 DO I=1,NHALO HALOI = HALO(I) DO J=IPE(HALOI),IPE(HALOI+1)-1 IF (TRACE(IW(J))==NODE) THEN CNT = CNT + 1 JCNHALO(JCN_CNT) = GEN2HALO(IW(J)) JCN_CNT = JCN_CNT + 1 END IF END DO IPTRHALO(IPTR_CNT) = CNT + 1 IPTR_CNT = IPTR_CNT + 1 END DO END SUBROUTINE GETHALOGRAPH SUBROUTINE GET_GROUPS(NHALO,PARTS,SEP,NSEP,NPARTS, & CUT,NEWSEP,PERM,IPERM) INTEGER,INTENT(IN) :: NHALO,NSEP INTEGER,DIMENSION(:),INTENT(IN) :: SEP INTEGER,POINTER,DIMENSION(:)::PARTS INTEGER,POINTER,DIMENSION(:)::CUT,NEWSEP,PERM, & IPERM INTEGER,INTENT(INOUT) :: NPARTS INTEGER::I,CNT,NB_PARTS_WITHOUT_SEP_NODE,allocok INTEGER,DIMENSION(:),ALLOCATABLE::SIZES INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR ALLOCATE(NEWSEP(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(PERM(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(IPERM(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(SIZES(NPARTS),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(PARTPTR(NPARTS+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF NB_PARTS_WITHOUT_SEP_NODE = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = & SIZES(PARTS(I))+1 END DO PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) IF (SIZES(I-1)==0) THEN NB_PARTS_WITHOUT_SEP_NODE = NB_PARTS_WITHOUT_SEP_NODE + 1 END IF END DO ALLOCATE(CUT(NPARTS-NB_PARTS_WITHOUT_SEP_NODE+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF CUT(1) = 1 CNT = 2 DO I=2,NPARTS+1 IF (SIZES(I-1).NE.0) THEN CUT(CNT) = PARTPTR(I) CNT = CNT + 1 END IF END DO NPARTS = NPARTS - NB_PARTS_WITHOUT_SEP_NODE CUT(NPARTS+1) = NSEP+1 DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) PERM(PARTPTR(PARTS(I))) = I IPERM(I) = PARTPTR(PARTS(I)) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO DEALLOCATE(SIZES,PARTPTR) END SUBROUTINE GET_GROUPS SUBROUTINE DMUMPS_LR_GROUPING(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, NE_STEPS, STEP, NA, LNA, & LRGROUPS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, SEP_SIZE, & K38, K20, K60, & IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K10, & K54, K142, LPOK, LP, GATHER_MATRIX_ALLOCATED, & KEEP, ND_STEPS) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, K60, K54 INTEGER, INTENT(IN) :: LP INTEGER, INTENT(OUT) :: K142 LOGICAL, INTENT(IN) :: LPOK INTEGER, POINTER, DIMENSION(:) :: IRN, JCN INTEGER, INTENT(IN) :: NE_STEPS(:), ICNTL(60) INTEGER :: FRERE_STEPS(:), NA(:), DAD_STEPS(:) INTEGER :: FILS(N), STEP(N), LRGROUPS(N) INTEGER, INTENT(IN) :: K472, MAXFRONT LOGICAL, INTENT(INOUT) :: GATHER_MATRIX_ALLOCATED INTEGER, INTENT(IN) :: KEEP(500), ND_STEPS(:) INTEGER :: K482_LOC, K38ou20 INTEGER :: I, F, PV, NV, NLEAVES, NROOTS, PP, C, NF, NODE, & SYMTRY, NBQD, AD INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: LPTR, RPTR, NBGROUPS LOGICAL :: FIRST INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, GEN2HALO INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR LOGICAL :: INPLACE64_GRAPH_COPY K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF NBGROUPS = 0 IF (K265.EQ.-1) THEN LW = NZ8 ELSE LW = 2_8 * NZ8 ENDIF ALLOCATE(IW(LW), IPE(N+1), LEN(N), IQ(N), & POOL(NA(1)), PVS(NSTEPS), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * LW+int(N,8)+int(K10*(2*N+1),8) IFLAG = -7 CALL MUMPS_SET_IERROR(LW+int(N,8)+int(K10*(2*N+1),8),IERROR) GOTO 500 ENDIF CALL DMUMPS_ANA_GNEW(N, NZ8, IRN(1), JCN(1), IW(1), LW, IPE(1), & LEN(1), IQ(1), LRGROUPS(1), IWFR, NRORM, NIORM, & IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265,.FALSE., & INPLACE64_GRAPH_COPY) IF (K54.EQ.3) THEN deallocate(IRN) deallocate(JCN) NULLIFY(IRN) NULLIFY(JCN) GATHER_MATRIX_ALLOCATED = .FALSE. ENDIF IF (allocated(IQ)) DEALLOCATE(IQ) LRGROUPS = -1 NLEAVES = NA(1) NROOTS = NA(2) LPTR = 2+NLEAVES RPTR = 2+NLEAVES+NROOTS DO I = 1, NROOTS POOL(I) = NA(2+NLEAVES+I) END DO PP = NROOTS ALLOCATE(WORK(MAXFRONT), TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * 3*N+MAXFRONT IFLAG = -7 IERROR = 3*N+MAXFRONT RETURN ENDIF TRACE = 0 K142 = 0 DO WHILE(PP .GT. 0) PV = ABS(POOL(PP)) NODE = STEP(PV) FIRST = POOL(PP) .LT. 0 NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV, & ND_STEPS(NODE), KEEP(35)) IF (NV .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + ( (NV-1)/GROUP_SIZE2 + 1 ) K142 = max(K142, min(NV,GROUP_SIZE2)) ELSE CALL SEP_GROUPING( ND_STEPS(NODE), KEEP, & NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE(1), WORKH(1), NODE, & GEN2HALO(1), K482_LOC, K472, 0, SEP_SIZE, K142, & K10, LP, LPOK, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 500 END IF ELSE IF (NV .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = (NBGROUPS + 1) ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -(NBGROUPS + 1) ENDDO ENDIF NBGROUPS = NBGROUPS + 1 K142 = max (K142,NV) ENDIF CALL MUMPS_UPD_TREE(NV, NSTEPS, N, FIRST, LPTR, RPTR, F, & WORK(1), & FILS, FRERE_STEPS, STEP, DAD_STEPS, & NE_STEPS, NA, LNA, PVS(1), K38ou20, & STEP_SCALAPACK_ROOT) IF (STEP_SCALAPACK_ROOT.GT.0) THEN IF (K38.GT.0) THEN K38 = K38ou20 ELSE K20 = K38ou20 ENDIF ENDIF PP = PP-1 NF = NE_STEPS(NODE) IF(NF .GT. 0) THEN PP = PP+1 POOL(PP) = F C = STEP(-F) F = FRERE_STEPS(C) DO WHILE(F .GT. 0) PP = PP+1 POOL(PP) = F C = STEP(F) F = FRERE_STEPS(C) END DO END IF END DO 500 IF (allocated(POOL)) DEALLOCATE(POOL) IF (allocated(PVS)) DEALLOCATE(PVS) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(LEN)) DEALLOCATE(LEN) IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) RETURN END SUBROUTINE DMUMPS_LR_GROUPING SUBROUTINE DMUMPS_LR_GROUPING_NEW(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, K142, LPOK, LP, GATHER_MATRIX_ALLOCATED, & KEEP, ND_STEPS) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, POINTER, DIMENSION(:) :: IRN, JCN INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FRERE_STEPS(:), NA(:), DAD_STEPS(:) INTEGER :: FILS(N), STEP(N), LRGROUPS(N) INTEGER, INTENT(IN) :: K472, K469 LOGICAL, INTENT(INOUT) :: GATHER_MATRIX_ALLOCATED INTEGER, INTENT(OUT) :: K142 INTEGER, INTENT(IN) :: KEEP(500), ND_STEPS(:) INTEGER :: K482_LOC, K469_LOC, K38ou20 INTEGER :: I, F, PV, NV, NODE, & SYMTRY, NBQD, AD LOGICAL :: PVSCHANGED INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: NBGROUPS, NBGROUPS_local, NBG_CAPT INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: INPLACE64_GRAPH_COPY #if defined(ptscotch) || defined(scotch) INTEGER :: VSCOTCH LOGICAL :: SCOTCH_IS_THREAD_SAFE INTEGER :: PTHREAD_NUMBER, NOMP #endif K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF K469_LOC = K469 #if defined(ptscotch) || defined(scotch) SCOTCH_IS_THREAD_SAFE = .FALSE. IF (K482_LOC.EQ.2) THEN CALL MUMPS_SCOTCH_VERSION (VSCOTCH) IF (VSCOTCH.GE.7) SCOTCH_IS_THREAD_SAFE=.TRUE. ENDIF IF (K482_LOC.EQ.2.AND.(.NOT.SCOTCH_IS_THREAD_SAFE) ) THEN K469_LOC = 1 ENDIF #endif NBGROUPS = 0 LW = 2_8 * NZ8 ALLOCATE(IW(LW), IPE(N+1), LEN(N), IQ(N), & PVS(NSTEPS), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * LW+int(N,8)+int(K10*(2*N+1),8) IFLAG = -7 CALL MUMPS_SET_IERROR(LW+int(N,8)+int(K10*(2*N+1),8),IERROR) GOTO 501 ENDIF CALL DMUMPS_ANA_GNEW(N, NZ8, IRN(1), JCN(1), IW(1), LW, IPE(1), & LEN(1), IQ(1), LRGROUPS(1), IWFR, NRORM, NIORM, & IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265,.FALSE., & INPLACE64_GRAPH_COPY) IF (K54.EQ.3) THEN deallocate(IRN) deallocate(JCN) NULLIFY(IRN) NULLIFY(JCN) GATHER_MATRIX_ALLOCATED = .FALSE. ENDIF IF (allocated(IQ)) DEALLOCATE(IQ) LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 501 ENDIF ENDIF #if defined(ptscotch) || defined(scotch) IF (K482_LOC.EQ.2) THEN NOMP=0 !$ NOMP=omp_get_max_threads() IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (PTHREAD_NUMBER) NOMP =1 CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (NOMP) ENDIF ENDIF #endif K142 = 0 PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = omp_get_max_threads() OMP_NUM = min(OMP_NUM,5) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local !$OMP& ) !$OMP& REDUCTION( max : K142) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(MAXFRONT), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", MAXFRONT !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = MAXFRONT !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 3*N !$OMP END ATOMIC ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 500 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE PV = PVS(NODE) NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV, & ND_STEPS(NODE), KEEP(35)) IF (NV .GE. GROUP_SIZE2 & .AND. NV.GE.int(dble(SEP_SIZE)*dble(1.5)) & ) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + ( (NV-1)/GROUP_SIZE2 + 1 ) !$OMP END ATOMIC DO I=1,NV LRGROUPS(WORK(I))=NBG_CAPT+1+(I-1)/GROUP_SIZE2 END DO K142 = max(K142, min(NV,GROUP_SIZE2)) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING( ND_STEPS(NODE), KEEP, & NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K142, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING( ND_STEPS(NODE), KEEP, & NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K142, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NV .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF K142 = max (K142,NV) ENDIF ENDDO !$OMP END DO IF (IFLAG.LT.0) GOTO 500 IF (.NOT.PVSCHANGED) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL #if defined(ptscotch) || defined(scotch) IF (K482_LOC.EQ.2.AND.NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (PTHREAD_NUMBER) ENDIF #endif 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(LEN)) DEALLOCATE(LEN) RETURN END SUBROUTINE DMUMPS_LR_GROUPING_NEW SUBROUTINE DMUMPS_AB_LR_MPI_GROUPING( & N, MAPCOL, SIZEMAPCOL, & NSTEPS, LUMAT, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SIZEOFBLOCKS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, & SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, K142, LPOK, LP, & COMM, MYID, NPROCS_ARG, & KEEP, ND_STEPS & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, INTENT(IN) :: MYID, COMM, NPROCS_ARG TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER, INTENT(IN) :: SIZEMAPCOL INTEGER, INTENT(IN) :: MAPCOL(SIZEMAPCOL) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(OUT) :: K142 INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FRERE_STEPS(:), NA(:), DAD_STEPS(:) INTEGER :: FILS(N), STEP(N), LRGROUPS(N) INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: K472, K469 INTEGER, INTENT(IN) :: KEEP(500), ND_STEPS(:) INTEGER :: NPROCS INTEGER :: K482_LOC, K469_LOC, K38ou20, K142_GLOB INTEGER :: I, F, PV, NV, NVEXPANDED, NODE DOUBLE PRECISION :: COMPRESS_RATIO LOGICAL :: PVSCHANGED INTEGER :: PVSCHANGED_INT, PVSCHANGED_INT_GLOB, IPROC INTEGER :: NBGROUPS, NBGROUPS_local, NBG_CAPT INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER :: NBGROUPS_sent INTEGER :: NBNODES_LOC, SIZE_SENT, ISHIFT, & MSGSOU, ILOOP INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, GROUP_SIZE2_TMP, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: MAPCOL_PROVIDED #if defined(ptscotch) || defined(scotch) INTEGER :: VSCOTCH LOGICAL :: SCOTCH_IS_THREAD_SAFE INTEGER :: PTHREAD_NUMBER, NOMP #endif MAPCOL_PROVIDED = (MAPCOL(1).GE.0) NPROCS = NPROCS_ARG IF (.NOT.MAPCOL_PROVIDED) NPROCS=1 K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF (MAPCOL_PROVIDED) THEN CALL MPI_BCAST( FILS(1), N, MPI_INTEGER, & MASTER, COMM, IERR ) ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF K469_LOC = K469 #if defined(ptscotch) || defined(scotch) SCOTCH_IS_THREAD_SAFE = .FALSE. IF (K482_LOC.EQ.2) THEN CALL MUMPS_SCOTCH_VERSION (VSCOTCH) IF (VSCOTCH.GE.7) SCOTCH_IS_THREAD_SAFE=.TRUE. ENDIF IF (K482_LOC.EQ.2.AND.(.NOT.SCOTCH_IS_THREAD_SAFE) ) THEN K469_LOC = 1 ENDIF #endif NBGROUPS = 0 K142 = 0 ALLOCATE( PVS(NSTEPS), STAT=IERR) IF (IERR.GT.0) THEN IFLAG = -7 IERROR = NSTEPS IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", IERROR GOTO 491 ENDIF LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 491 ENDIF ENDIF 491 CONTINUE IF (NPROCS.GT.1) THEN CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) ENDIF IF (IFLAG.LT.0) GOTO 501 #if defined(ptscotch) || defined(scotch) NOMP=0 IF (K482_LOC.EQ.2) THEN !$ NOMP=omp_get_max_threads() IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (PTHREAD_NUMBER) NOMP =1 CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (NOMP) ENDIF ENDIF #endif K142 = 0 PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = omp_get_max_threads() OMP_NUM = min(OMP_NUM,5) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local, !$OMP& NVEXPANDED, COMPRESS_RATIO, IPROC, GROUP_SIZE2_TMP !$OMP& ) !$OMP& REDUCTION( max : K142) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(2*MAXFRONT+1), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 2*MAXFRONT+1 !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 2*MAXFRONT+1 !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 3*N !$OMP END ATOMIC ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 498 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE IF (MAPCOL_PROVIDED) THEN IPROC = MAPCOL(NODE) IF (IPROC.NE.MYID) THEN PVS(NODE) = -999 CYCLE ENDIF ENDIF PV = PVS(NODE) NV = 0 NVEXPANDED = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 NVEXPANDED = NVEXPANDED+SIZEOFBLOCKS(F) WORK(NV) = F F = FILS(F) END DO COMPRESS_RATIO = dble(NVEXPANDED)/dble(NV) CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED, & ND_STEPS(NODE), KEEP(35)) IF (NVEXPANDED .GE. GROUP_SIZE2 & .AND. NVEXPANDED.GE.int(dble(SEP_SIZE)*dble(1.5)) & ) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN GROUP_SIZE2_TMP = GROUP_SIZE2 GROUP_SIZE2_TMP = max( int(dble(GROUP_SIZE2_TMP) & /COMPRESS_RATIO), 1) !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + ( (NV-1)/GROUP_SIZE2_TMP + 1 ) !$OMP END ATOMIC DO I=1,NV LRGROUPS(WORK(I))=NBG_CAPT+1+(I-1)/GROUP_SIZE2_TMP END DO K142 = max(K142, min(NV,GROUP_SIZE2_TMP)) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING_AB( ND_STEPS(NODE), KEEP, & NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K142, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING_AB( ND_STEPS(NODE), KEEP, & NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K142, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NVEXPANDED .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF K142 = max (K142,NV) ENDIF ENDDO !$OMP END DO 498 CONTINUE IF (NPROCS.GT.1) THEN !$OMP MASTER CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) !$OMP END MASTER !$OMP BARRIER ENDIF IF (IFLAG.LT.0) GOTO 500 IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP MASTER IF (K469_LOC.NE.2) THEN IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF !$OMP END MASTER IF (.NOT.MAPCOL_PROVIDED) THEN !$OMP MASTER IF (PVSCHANGED) THEN PVSCHANGED_INT_GLOB = 1 ELSE PVSCHANGED_INT_GLOB = 0 ENDIF !$OMP END MASTER ELSE !$OMP MASTER IF (PVSCHANGED) THEN PVSCHANGED_INT = 1 ELSE PVSCHANGED_INT = 0 ENDIF CALL MPI_ALLREDUCE( PVSCHANGED_INT, PVSCHANGED_INT_GLOB, 1, & MPI_INTEGER, & MPI_MAX, COMM, IERR_MPI ) PVSCHANGED_INT_GLOB = 1 IF (PVSCHANGED_INT_GLOB.NE.0) THEN IF (NPROCS.GT.1) THEN ALLOCATE(WORKH(2*N+3*NSTEPS+1), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of ", & "size: ", 2*MAXFRONT+1 IFLAG = -7 IERROR = 2*N+3*NSTEPS+1 ENDIF CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) IF (IFLAG.LT.0) GOTO 499 IF (MYID.EQ.MASTER) THEN IPROC = 0 DO WHILE (IPROC.NE.NPROCS-1) IPROC = IPROC + 1 CALL MPI_RECV( NBNODES_LOC, 1, MPI_INTEGER, & MPI_ANY_SOURCE, & GROUPING, COMM, STATUS, IERR ) MSGSOU = STATUS( MPI_SOURCE ) IF (NBNODES_LOC.EQ.0) THEN CYCLE ENDIF CALL MPI_RECV( NBGROUPS_sent, 1, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) CALL MPI_RECV( SIZE_SENT, 1, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) CALL MPI_RECV( WORKH, SIZE_SENT, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) ISHIFT = 0 DO ILOOP=1, NBNODES_LOC ISHIFT = ISHIFT+1 NODE = WORKH (ISHIFT) ISHIFT = ISHIFT+1 NV = WORKH(ISHIFT) PVS(NODE) = WORKH(ISHIFT+1) STEP(WORKH(ISHIFT+1)) = NODE IF (STEP(WORKH(ISHIFT+1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORKH(ISHIFT+1) ELSE K20 = WORKH(ISHIFT+1) END IF END IF DO I=2, NV STEP(WORKH(I+ISHIFT)) = -NODE END DO DO I=1, NV FILS(WORKH(I+ISHIFT)) = WORKH(I+1+ISHIFT) IF (WORKH(NV+1+I+ISHIFT).LT.0) THEN LRGROUPS(WORKH(I+ISHIFT)) = & - NBGROUPS + WORKH(NV+1+I+ISHIFT) ELSE LRGROUPS(WORKH(I+ISHIFT)) = & NBGROUPS + WORKH(NV+1+I+ISHIFT) END IF END DO ISHIFT = ISHIFT + 2*NV +1 END DO NBGROUPS = NBGROUPS + NBGROUPS_sent ENDDO ELSE NBNODES_LOC = 0 SIZE_SENT = 0 ISHIFT = 0 DO NODE = 1,NSTEPS IPROC = MAPCOL(NODE) IF (IPROC.EQ.MYID) THEN NBNODES_LOC = NBNODES_LOC + 1 ISHIFT = ISHIFT +1 WORKH(ISHIFT) = NODE ISHIFT = ISHIFT +1 NV = 0 F = PVS(NODE) DO WHILE (F.GT.0) NV = NV + 1 WORKH(NV+ISHIFT) = F F = FILS(F) ENDDO WORKH(ISHIFT) = NV WORKH(NV+1+ISHIFT) = F DO I=1, NV WORKH(NV+1+I+ISHIFT) = LRGROUPS(WORKH(I+ISHIFT)) ENDDO ISHIFT = ISHIFT + 2*NV+1 ENDIF ENDDO SIZE_SENT = ISHIFT CALL MPI_SEND( NBNODES_LOC, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) IF (NBNODES_LOC.GT.0) THEN CALL MPI_SEND( NBGROUPS, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) CALL MPI_SEND( SIZE_SENT, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) CALL MPI_SEND( WORKH, SIZE_SENT, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) ENDIF ENDIF ENDIF ENDIF 499 CONTINUE !$OMP END MASTER ENDIF !$OMP BARRIER IF (IFLAG.LT.0) GOTO 500 IF (MYID.EQ.MASTER) THEN IF (PVSCHANGED_INT_GLOB.EQ.0) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO ENDIF 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL IF (NPROCS.GT.1) THEN K142_GLOB = 0 CALL MPI_REDUCE( K142, K142_GLOB, 1, & MPI_INTEGER, & MPI_MAX, MASTER, COMM, IERR_MPI ) K142 = K142_GLOB ENDIF #if defined(ptscotch) || defined(scotch) IF (K482_LOC.EQ.2.AND.NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (PTHREAD_NUMBER) ENDIF #endif 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) RETURN END SUBROUTINE DMUMPS_AB_LR_MPI_GROUPING END MODULE DMUMPS_ANA_LR MUMPS_5.8.1/src/cfac_front_LDLT_type1.F0000664000175000017500000011511515042446440017410 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC1_LDLT_M CONTAINS SUBROUTINE CMUMPS_FAC1_LDLT( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, IERROR, & UU, NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) USE CMUMPS_FAC_FRONT_AUX_M USE CMUMPS_OOC USE CMUMPS_FAC_LR USE CMUMPS_LR_TYPE USE MUMPS_LR_STATS USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_DATA_M USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T #if ! defined(BLR_NOOPENMP) #endif !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, intent(inout) :: NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX, intent(inout) :: DET_MANTW INTEGER MYID, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL UU, SEUIL COMPLEX A( LA ) INTEGER, TARGET :: IW( LIW ) INTEGER, intent(in) :: PERM(N) LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER :: LDA REAL UUTEMP LOGICAL STATICMODE REAL SEUIL_LOC LOGICAL IS_MAXFROMM_AVAIL INTEGER PIVOT_OPTION INTEGER LRTRSM_OPTION INTEGER LAST_ROW, FIRST_ROW REAL MAXFROMM INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPiv2beWritten, IFLAG_OOC, & IDUMMY, PP_FIRST2SWAP_L, PP_LastPIVRPTRFilled TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PARPIV_T1, OFFSET INTEGER NFS4FATHER REAL, ALLOCATABLE, DIMENSION(:) :: M_ARRAY LOGICAL LASTPANEL INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER K473_LOC INTEGER INFO_TMP(2), MAXI_RANK INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM, NELIM_LOC TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L COMPLEX, POINTER, DIMENSION(:) :: DIAG INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DIAGPOS, I, IP, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG COMPLEX, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) COMPLEX, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok,J INTEGER :: OMP_NUM INTEGER :: II,JJ INTEGER(8) :: UPOS, LPOS, DPOS COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) LOGICAL :: SWAP_OCCURRED INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC INTEGER :: NVSCHUR, NVSCHUR_K253, IROW_L INCLUDE 'mumps_headers.h' INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER PIVSIZ,IWPOSP2 IS_MAXFROMM_AVAIL = .FALSE. IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF SWAP_OCCURRED = .FALSE. INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF UUTEMP=UU IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC = SEUIL ENDIF LAFAC = -9999_8 XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) LDA = NFRONT NASS = abs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. COMPRESS_PANEL = .FALSE. COMPRESS_CB = .FALSE. NULLIFY(PTDummy) NULLIFY(BEGS_BLR) NULLIFY(CB_LRB) NULLIFY(ACC_LUA) NULLIFY(BLR_L) NULLIFY(BEGS_BLR_TMP) NULLIFY(BLR_PANEL) NULLIFY(DIAG) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. K473_LOC = 1 ELSE K473_LOC = KEEP(473) ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL CMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS, KEEP, & LR_ACTIVATED, PARPIV_T1) LRTRSM_OPTION = KEEP(475) PIVOT_OPTION = KEEP(468) IF (UUTEMP.EQ.ZERO) THEN PIVOT_OPTION = 0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF IF (LR_ACTIVATED) THEN IF (LRTRSM_OPTION.EQ.3) THEN PIVOT_OPTION = MIN(PIVOT_OPTION,1) ELSEIF (LRTRSM_OPTION.EQ.2) THEN PIVOT_OPTION = MIN(PIVOT_OPTION, 2) ENDIF ENDIF IF (PIVOT_OPTION.LE.1) THEN PARPIV_T1 = 0 ENDIF CALL CMUMPS_SET_INNERBLOCKSIZE( NBKJIB_ORIG, NASS, KEEP) IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = IOLDPS+6+XSIZE+NASS CALL CMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 LASTPANEL = .FALSE. CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF (OOC_EFFECTIVE_ON_FRONT) THEN IDUMMY = -8765 NextPiv2beWritten = 1 PP_FIRST2SWAP_L = NextPiv2beWritten MonBloc%LastPanelWritten_L = 0 PP_LastPIVRPTRFilled = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 1 MonBloc%NROW = NFRONT MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -77777 MonBloc%INDICES => & IW(IOLDPS+6+NFRONT+XSIZE: & IOLDPS+5+NFRONT+XSIZE+NFRONT) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(405) .EQ. 1) THEN !$OMP ATOMIC UPDATE CNT_NODES = CNT_NODES + 1 !$OMP END ATOMIC ELSE CNT_NODES = CNT_NODES + 1 ENDIF ELSE IF (KEEP(486).NE.0) THEN ENDIF OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472), & NFRONT, KEEP(1)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 500 CALL CMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .FALSE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF IF (COMPRESS_CB) THEN IF (NPARTSCB.GT.0) THEN allocate(CB_LRB(NPARTSCB,NPARTSCB),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSCB*NPARTSCB GOTO 490 ENDIF DO II=1,NPARTSCB DO JJ=1,NPARTSCB CB_LRB(II,JJ)%M=0 CB_LRB(II,JJ)%N=0 NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL CMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF ENDIF DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = BEGS_BLR(CURRENT_BLR+1)-1 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (KEEP(480).GE.5) THEN IF (CURRENT_BLR.EQ.1) THEN ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR) THEN BLR_L(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ELSE IF (NB_BLR.GT.CURRENT_BLR) THEN CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF IF (CURRENT_BLR.LT.NPARTSASS) THEN ALLOCATE(NEXT_BLR_L(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR+1) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR+1, NEXT_BLR_L, 0) ENDIF ENDIF ELSE ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ENDIF ENDIF IF (LR_ACTIVATED) THEN ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE CALL CMUMPS_FAC_I_LDLT(NFRONT,NASS,N,INODE, & IBEG_BLOCK, IEND_BLOCK, & IW,LIW,A,LA, & INOPV, NNEGW, NNULLNEGW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UUTEMP, & SEUIL_LOC,KEEP,KEEP8,PIVSIZ, & DKEEP(1), PIVNUL_LIST_STRUCT, SWAP_OCCURRED, XSIZE, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, MAXFROMM, IS_MAXFROMM_AVAIL, & PIVOT_OPTION, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, LR_ACTIVATED & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTPANEL = .TRUE. ELSE IF ( INOPV.LE.0 ) THEN INOPV = 0 NPVW = NPVW + PIVSIZ NVSCHUR_K253 = 0 IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT NVSCHUR_K253 = NVSCHUR + KEEP(253) ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL CMUMPS_FAC_MQ_LDLT(IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & INODE,A,LA, & LDA, & POSELT,IFINB, & PIVSIZ, MAXFROMM, & IS_MAXFROMM_AVAIL, (UUTEMP.NE.0.0E0), & PARPIV_T1, & LAST_ROW, IEND_BLR, NVSCHUR_K253, & LR_ACTIVATED & ) IF(PIVSIZ .EQ. 2) THEN IWPOSP2 = IOLDPS+IW(IOLDPS+1+XSIZE)+6 IW(IWPOSP2+NFRONT+XSIZE) = & -IW(IWPOSP2+NFRONT+XSIZE) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB.EQ.-1) THEN LASTPANEL = .TRUE. ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = LASTPANEL MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL CMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK, & NPIV, NFRONT,NASS,INODE,A,LA, & LDA, POSELT, & KEEP, KEEP8, & -6666, -6666, & IEND_BLR, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL CMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NFRONT,NASS,INODE,A,LA, & LDA, POSELT, & KEEP, KEEP8, & IEND_BLR, NASS, & NASS, LAST_ROW, & (PIVOT_OPTION.LE.1), .TRUE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ELSE NELIM = IEND_BLOCK - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) NULLIFY(BLR_L) IF (KEEP(480).GE.2 .AND. IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS-CURRENT_BLR ELSE FIRST_BLOCK = 1 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL CMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8, FIRST_BLOCK=FIRST_BLOCK) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF ENDIF GOTO 100 ENDIF IF (PIVOT_OPTION.GE.3) THEN FIRST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN FIRST_ROW = NASS ELSE FIRST_ROW = IEND_BLR ENDIF IF (LRTRSM_OPTION.EQ.3) THEN LAST_ROW = IEND_BLR ELSEIF (LRTRSM_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = NFRONT ENDIF IF ((IEND_BLR.LT.NFRONT) .AND. (LAST_ROW-FIRST_ROW.GT.0)) THEN CALL CMUMPS_FAC_SQ_LDLT(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & INODE, A, LA, LDA, POSELT, & KEEP, KEEP8, & FIRST_ROW, LAST_ROW, & -6666, -6666, & .TRUE., .FALSE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ENDIF #if ! defined(BLR_NOOPENMP) #endif #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(UPOS,LPOS,DPOS,OFFSET) !$OMP& FIRSTPRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), KEEP(458), & K473_LOC, BLR_L, & CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (PIVOT_OPTION.LT.3) THEN IF (LRTRSM_OPTION.GE.2) THEN IF (PIVOT_OPTION.LE.1.AND.LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF CALL CMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, NB_BLR, BLR_L, & CURRENT_BLR, FIRST_BLOCK, NB_BLR, & 1, 1, 0, & .FALSE., & IW, OFFSET_IW=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF IF (NELIM.GT.0) THEN IF (PIVOT_OPTION.LE.1) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF LPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR)-1,8) DPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR)-1,8) OFFSET=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1 UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8) #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL CMUMPS_FAC_LDLT_COPYSCALE_U( NELIM, 1, & KEEP(424), NFRONT, NPIV-IBEG_BLR+1, & LIW, IW, OFFSET, LA, A, POSELT, LPOS, UPOS, DPOS) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif LPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8) CALL CMUMPS_BLR_UPD_NELIM_VAR_L( & A, LA, UPOS, A, LA, LPOS, & IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & FIRST_BLOCK, NELIM, 'N') ENDIF ENDIF IF (IFLAG.LT.0) GOTO 400 #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS-CURRENT_BLR ELSE FIRST_BLOCK = 1 ENDIF CALL CMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8, FIRST_BLOCK=FIRST_BLOCK) ENDIF ELSE CALL CMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, & MAXI_CLUSTER, NPIV, & 1, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (LRTRSM_OPTION.GE.2) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF IF (KEEP(486).NE.2) THEN LAST_BLOCK = NB_BLR ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, NFRONT, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL(BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & KEEP(34)) DEALLOCATE(BLR_L) ELSE NULLIFY(NEXT_BLR_L) ENDIF ENDIF NULLIFY(BLR_L) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = LASTPANEL MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO J=1,NB_BLR+1 BEGS_BLR_TMP(J) = BEGS_BLR_STATIC(J) ENDDO ENDIF ENDIF MEM_TOT = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP& PRIVATE(IP, NELIM_LOC, BLR_PANEL) #endif IF ( & (KEEP(486).EQ.2) & ) THEN #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DIAGPOS, POSELT_DIAG, !$OMP& MEM, allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*DIAGSIZ_STA MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DIAGPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA DIAG(DIAGPOS:DIAGPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DIAGPOS = DIAGPOS + DIAGSIZ_DYN POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL CMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG, KEEP(34)) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO !$OMP SINGLE #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM_TOT,8), & (KEEP(405).NE.0), KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 447 IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN DO IP=1,NPARTSASS NELIM_LOC = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8, & KEEP(34)) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(458), K473_LOC, & BLR_PANEL, IP, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM_LOC, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif 445 CONTINUE ENDIF 447 CONTINUE ENDIF IF (IFLAG .LT. 0) GOTO 450 IF (KEEP(480) .GE. 2) THEN #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif CALL CMUMPS_BLR_UPD_CB_LEFT_LDLT(A, LA, POSELT, NFRONT, & BEGS_BLR_STATIC, BEGS_BLR, NPARTSCB, NPARTSASS, NASS, & IW(IOLDPS+XXF), & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(484), KEEP8) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF IF (IFLAG.LT.0) GOTO 450 #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF (COMPRESS_CB & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL CMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (COMPRESS_CB) THEN IEND_BLR = BEGS_BLR(CURRENT_BLR+2) IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) ENDIF ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (COMPRESS_CB) THEN #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL CMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) IF (NFS4FATHER.GE.0) NFS4FATHER = NFS4FATHER + NELIM ENDIF ALLOCATE(M_ARRAY(max(NFS4FATHER,1)), stat=allocok) IF ( allocok.GT.0 ) THEN IFLAG = -13 IERROR = max(NFS4FATHER,1) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 448 CALL CMUMPS_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR, NPARTSCB, NPARTSCB, NPARTSASS, & NFRONT-NASS, NFRONT-NASS, INODE, & IW(IOLDPS+XXF), 2, 1, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR+KEEP(253), KEEP(1), & M_ARRAY=M_ARRAY, & NELIM=NELIM ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 448 #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL CMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF DEALLOCATE(M_ARRAY) #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif 448 CONTINUE ENDIF 450 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF ( & ( & (KEEP(486).EQ.2) & ) & .AND.UU.GT.0 .AND. SWAP_OCCURRED & ) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 1, NASS-NPIV) DO IP=1,NPARTSASS CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NB_BLR-IP & ) ENDDO CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NPIV, 2, 1) ENDIF IF (.NOT. COMPRESS_PANEL) THEN CALL CMUMPS_FAC_T_LDLT(NFRONT,NASS,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, KEEP,KEEP8, & (PIVOT_OPTION.NE.3), ETATASS, & TYPEF_L, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG, IOLDPS+6+XSIZE+NFRONT, INODE ) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 1, 1) ENDIF ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_L, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF CALL CMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 490 CONTINUE 500 CONTINUE 600 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) deallocate(TAU) IF (allocated(JPVT)) deallocate(JPVT) IF (allocated(BLOCK)) deallocate(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) ENDDO ENDIF DEALLOCATE(ACC_LUA) NULLIFY(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL CMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8, KEEP(34)) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND. .NOT.COMPRESS_CB) THEN CALL CMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34), MTK405=KEEP(405)) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_FAC1_LDLT END MODULE CMUMPS_FAC1_LDLT_M SUBROUTINE CMUMPS_FAC1_LDLT_I( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, IERROR, & UU, NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T USE CMUMPS_FAC1_LDLT_M, ONLY: CMUMPS_FAC1_LDLT IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, intent(inout) :: NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX, intent(inout) :: DET_MANTW INTEGER MYID, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL UU, SEUIL COMPLEX A( LA ) INTEGER IW( LIW ) INTEGER, intent(in) :: PERM(N) LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)) CALL CMUMPS_FAC1_LDLT( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, IERROR, & UU, NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) RETURN END SUBROUTINE CMUMPS_FAC1_LDLT_I MUMPS_5.8.1/src/zana_aux_par.F0000664000175000017500000044367215042446441016030 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_PARALLEL_ANALYSIS USE ZMUMPS_STRUC_DEF USE MUMPS_MEMORY_MOD USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T, COMPACT_GRAPH_T INCLUDE 'mpif.h' PUBLIC ZMUMPS_ANA_F_PAR INTERFACE ZMUMPS_ANA_F_PAR MODULE PROCEDURE ZMUMPS_ANA_F_PAR END INTERFACE PRIVATE TYPE ORD_TYPE INTEGER :: CBLKNBR, N INTEGER, POINTER :: PERMTAB(:) => null() INTEGER, POINTER :: PERITAB(:) => null() INTEGER, POINTER :: RANGTAB(:) => null() INTEGER, POINTER :: TREETAB(:) => null() INTEGER, POINTER :: BROTHER(:) => null() INTEGER, POINTER :: SON(:) => null() INTEGER, POINTER :: NW(:) => null() INTEGER, POINTER :: FIRST(:) => null() INTEGER, POINTER :: LAST(:) => null() INTEGER, POINTER :: TOPNODES(:) => null() INTEGER :: COMM, NPROCS, MYID, & COMM_PARAORD, NPROCS_PARAORD, MYID_PARAORD, & RKinSYMB_PROC0ORD INTEGER :: TOPSTRAT, SUBSTRAT, ORDTOOL, TOPVARS LOGICAL :: IDO END TYPE ORD_TYPE TYPE GRAPH_TYPE INTEGER(8) :: NZ_LOC INTEGER, POINTER :: IRN_LOC(:) => null() INTEGER, POINTER :: JCN_LOC(:) => null() END TYPE GRAPH_TYPE TYPE ARRPNT INTEGER, POINTER :: BUF(:) => null() END TYPE ARRPNT INTEGER :: MP, MPG, LP, NRL, TOPROWS INTEGER(8) :: MEMCNT, MAXMEM LOGICAL :: PROK, PROKG, LPOK INTEGER N, NORIG CONTAINS SUBROUTINE ZMUMPS_ANA_F_PAR(id, WORK1, WORK2, LWORK1, LWORK2, & NFSIZ, FILS, & FRERE, COMM_PARASYMB, LUMAT, SIZEOFBLOCKS, & COMM_PARAORD, NPROCS_PARAORD, & RKinSYMB_PROC0ORD) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id INTEGER, TARGET :: WORK1(:), WORK2(:) INTEGER(8), INTENT(IN) :: LWORK1, LWORK2 #if defined(MUMPS_NOF2003) INTEGER, POINTER :: FILS(:) #else INTEGER, ALLOCATABLE :: FILS(:) #endif INTEGER, POINTER :: NFSIZ(:), FRERE(:) INTEGER, INTENT(IN) :: COMM_PARASYMB TYPE(LMATRIX_T), OPTIONAL :: LUMAT INTEGER, INTENT(IN), TARGET, OPTIONAL :: SIZEOFBLOCKS(id%NBLK) INTEGER, INTENT(IN), OPTIONAL :: COMM_PARAORD, & NPROCS_PARAORD, & RKinSYMB_PROC0ORD 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 DOUBLE PRECISION :: TIMEB INTEGER HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & NBSONS_Scalapack_CAND INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR INTEGER, TARGET :: IDUMMY_ARRAY(1) INTEGER :: LSIZEOFBLOCKS_PTR LOGICAL :: SIZEOFBLOCKS_AVAIL nullify(IPE, NV, NE, NA, NODE, ND, SUBORD, NAMALG, IPS, & CUMUL, SAVEIRN, SAVEJCN) CALL MPI_COMM_RANK (COMM_PARASYMB, MYID, IERR) CALL MPI_COMM_SIZE (COMM_PARASYMB, NPROCS, IERR) NORIG = id%N IF (id%KEEP(339).NE.0) THEN N = id%NBLK ELSE N = NORIG ENDIF ord%N = N LP = id%ICNTL(1) MP = id%ICNTL(2) MPG = id%ICNTL(3) PROK = (MP.GT.0) PROKG = (MPG.GT.0) .AND. (MYID .EQ. 0) LPOK = (LP.GT.0) .AND. (id%ICNTL(4).GE.1) LDIAG = id%ICNTL(4) IF (present(SIZEOFBLOCKS)) THEN SIZEOFBLOCKS_PTR => SIZEOFBLOCKS(1:N) LSIZEOFBLOCKS_PTR = N SIZEOFBLOCKS_AVAIL = .TRUE. ELSE SIZEOFBLOCKS_PTR => IDUMMY_ARRAY SIZEOFBLOCKS_AVAIL = .FALSE. LSIZEOFBLOCKS_PTR = 1 IDUMMY_ARRAY(1) = -1 ENDIF IF (PROKG) THEN WRITE(MPG,'(A,I10)') & " Parallel analysis, processing a graph of size:", N ENDIF IF (id%KEEP(339).GT.0) THEN IF (.NOT.present(LUMAT) .OR. .NOT. present(SIZEOFBLOCKS)) THEN IF (PROK) THEN WRITE(MP,*) MYID, " Internal error in ZMUMPS_ANA_F_PAR" ENDIF id%INFO(1) = -9991 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM_PARASYMB, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN ENDIF IF (id%KEEP(339).GT.0) THEN MEMCNT = MEMCNT + LUMAT%NZL + LUMAT%NBCOL_LOC + 3 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ENDIF CALL ZMUMPS_SET_PAR_ORD(id, COMM_PARASYMB, MYID, NPROCS, & ord, COMM_PARAORD, NPROCS_PARAORD, & RKinSYMB_PROC0ORD) IF ( LWORK1 .LT. 3_8 *int(N,8) ) THEN WRITE(LP,*) & 'Insufficient workspace in ZMUMPS_ANA_F_PAR' CALL MUMPS_ABORT() ENDIF IF ( ord%COMM .NE. MPI_COMM_NULL ) THEN ord%PERMTAB => WORK1( 1 : N) ord%PERITAB => WORK1( int(N,8)+1_8 : 2_8*int(N,8)) ord%TREETAB => WORK1(2_8*int(N,8)+1_8 : 3_8*int(N,8)) ENDIF IF ( id%KEEP(54) .NE. 3 ) THEN IF(MYID.EQ.0) THEN SAVEIRN => id%IRN_loc SAVEJCN => id%JCN_loc id%IRN_loc => id%IRN id%JCN_loc => id%JCN id%KEEP8(29) = id%KEEP8(28) ELSE id%KEEP8(29)=0_8 END IF END IF MAXMEM=0 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT id%INFOG(7) = id%KEEP(245) IF (PROKG) CALL MUMPS_SECDEB( TIMEB ) IF (id%KEEP(339).GT.0) THEN CALL ZMUMPS_DO_PAR_ORD(id, MYID, NPROCS, & ord, WORK2, LWORK2, LUMAT, SIZEOFBLOCKS) ELSE CALL ZMUMPS_DO_PAR_ORD(id, MYID, NPROCS, & ord, WORK2, LWORK2) ENDIF IF (PROKG) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE(MPG, & '(" ELAPSED time in parallel ordering =",F12.4)') & TIMEB ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF(ord%MYID .EQ. 0) THEN CALL MUMPS_REALLOC(IPE, N, id%INFO, LP, FORCE=.FALSE., & COPY=.FALSE., STRING='', & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, N, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT END IF ord%SUBSTRAT = 0 ord%TOPSTRAT = 0 IF (id%KEEP(339).NE.0) THEN CALL ZMUMPS_PARSYMFACT_LUMAT(id, ord, IPE, NV, & WORK2, LWORK2, LUMAT, & SIZEOFBLOCKS) ELSE CALL ZMUMPS_PARSYMFACT(id, ord, IPE, NV, WORK2, LWORK2) ENDIF IF(id%KEEP(54) .NE. 3) THEN IF(ord%MYID.EQ.0) THEN id%IRN_loc => SAVEIRN id%JCN_loc => SAVEJCN END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN NULLIFY(ord%PERMTAB) NULLIFY(ord%PERITAB) NULLIFY(ord%TREETAB) CALL MUMPS_IDEALLOC(ord%FIRST, ord%LAST, MEMCNT=MEMCNT) IF (MYID .EQ. 0) THEN IPS => WORK1(1:N) NE => WORK1( int(N,8)+1_8 : 2_8*int(N,8)) NA => WORK1(2_8*int(N,8)+1_8 : 3_8*int(N,8)) NODE => WORK2( 1 : N ) ND => WORK2( int(N,8)+1_8 : 2_8*int(N,8)) SUBORD => WORK2(2_8*int(N,8)+1_8 : 3_8*int(N,8)) NAMALG => WORK2(3_8*int(N,8)+1_8 : 4_8*int(N,8)) CALL MUMPS_REALLOC(CUMUL, N, id%INFO, LP, & STRING='CUMUL', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT NEMIN = id%KEEP(1) CALL ZMUMPS_ANA_LNEW(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%KEEP(197), & id%NSLAVES, id%KEEP(250).EQ.1, SIZEOFBLOCKS_AVAIL, & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, & INODE_Scalapack_CAND, NBSONS_Scalapack_CAND, & id%KEEP(11), id%KEEP(191), id%KEEP(192), id%KEEP(193)) CALL MUMPS_DEALLOC(CUMUL, NV, IPE, MEMCNT=MEMCNT) CALL ZMUMPS_ANA_M(NE(1), ND(1), id%INFOG(6), id%INFOG(5), & id%KEEP(2), id%KEEP(50), id%KEEP8(101), id%KEEP(108), & id%KEEP(5), id%KEEP(6), id%KEEP(226), id%KEEP(253)) IF ( id%KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT(N, FRERE(1), FILS(1), NFSIZ(1), & id%KEEP(20)) INODE_Scalapack_CAND = id%KEEP(20) NBSONS_Scalapack_CAND = 1 END IF IF ( (id%KEEP(48) == 4 .AND. id%KEEP8(21).GT.0_8) & .OR. & (id%KEEP (48)==5 .AND. id%KEEP8(21) .GT. 0_8 ) & .OR. & (id%KEEP(24).NE.0.AND.id%KEEP8(21).GT.0_8) ) THEN CALL ZMUMPS_SET_K821_SURFACE(id%KEEP8(21), id%KEEP(2), & id%KEEP(48), id%KEEP(50), id%NSLAVES) END IF IF (id%KEEP(210).LT.1.OR.id%KEEP(210).GT.2) id%KEEP(210)=2 IF (id%KEEP(210).EQ.2) id%KEEP8(79)=huge(id%KEEP8(79)) IF (id%KEEP(210).EQ.1.AND.id%KEEP8(79).LE.0_8) THEN id%KEEP8(79)=K79REF * int(id%NSLAVES,8) ENDIF IF (id%KEEP(11).EQ.0) THEN IF ( (id%KEEP(79).EQ.0).OR.(id%KEEP(79).EQ.2).OR. & (id%KEEP(79).EQ.3).OR.(id%KEEP(79).EQ.5).OR. & (id%KEEP(79).EQ.6) & ) THEN IF (id%KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( id%KEEP(62).GE.1) THEN CALL ZMUMPS_CUTNODES(N, FRERE(1), FILS(1), & NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, 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 ENDIF HOW_TO_SPLIT_ROOT = 0 SPLITROOT = id%ICNTL(13) .EQ. -1 #if defined(NOSCALAPACK) SPLITROOT = SPLITROOT .OR. id%NSLAVES.GT.0 #else SPLITROOT = SPLITROOT .OR. & (id%ICNTL(13).GT.0 .AND. id%NSLAVES.GT.id%ICNTL(13)) #endif IF (SPLITROOT.AND.id%KEEP(11).GT.0) HOW_TO_SPLIT_ROOT =1 IF (id%KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. IF (id%KEEP(11).GT.0) HOW_TO_SPLIT_ROOT = 2 ENDIF #if defined(NOSCALAPACK) #else IF ( id%KEEP(11).GT.0 .AND. (id%KEEP(339).NE.0) ) THEN IF (.NOT.SPLITROOT .AND. & (id%KEEP(60).EQ.0).AND. & ( (NFSIZ(INODE_Scalapack_CAND).GT.id%KEEP(37)) & .AND.(id%ICNTL(13).LE.0) ) & .AND. & (NBSONS_Scalapack_CAND.GT.id%KEEP(11)) & ) THEN HOW_TO_SPLIT_ROOT = 3 SPLITROOT=.TRUE. ENDIF ENDIF #endif SPLITROOT = (SPLITROOT.AND.( (id%KEEP(60).EQ.0) )) IF (SPLITROOT) THEN IF (id%KEEP(339).EQ.0) THEN CALL ZMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, id%INFOG(6), & id%NSLAVES, id%KEEP(1), id%KEEP8(1), & SPLITROOT, MP, LDIAG, id%INFOG(1), id%INFOG(2)) ELSE IF (id%KEEP(11).EQ.0) THEN CALL ZMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, 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 IF ( id%KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT(N, FRERE(1), FILS(1), NFSIZ(1), & id%KEEP(20)) END IF ELSE CALL ZMUMPS_SPLIT_ROOT( id%NSLAVES, & HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & N, FRERE(1), FILS(1), NFSIZ(1), & id%KEEP(1), id%KEEP8(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, & id%INFOG(6)) END IF END IF ENDIF END IF RETURN END SUBROUTINE ZMUMPS_ANA_F_PAR SUBROUTINE ZMUMPS_SET_PAR_ORD(id, COMM_PARASYMB, MYID, NPROCS, & ord, & COMM_PARAORD, NPROCS_PARAORD, RKinSYMB_PROC0ORD) TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, INTENT(IN) :: COMM_PARASYMB, MYID, NPROCS INTEGER, INTENT(IN), OPTIONAL :: COMM_PARAORD, NPROCS_PARAORD, & RKinSYMB_PROC0ORD INTEGER :: IERR #if defined(parmetis) || defined(parmetis3) INTEGER :: I INTEGER :: COLOR, BASE, WORKERS LOGICAL :: IDO #endif IF (id%KEEP(339).GT.0) THEN ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%COMM = COMM_PARASYMB ord%MYID = MYID ord%NPROCS = NPROCS ord%COMM_PARAORD = COMM_PARAORD ord%RKinSYMB_PROC0ORD = RKinSYMB_PROC0ORD ord%NPROCS_PARAORD = NPROCS_PARAORD ord%IDO = (COMM_PARAORD.NE.MPI_COMM_NULL) IF (ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ELSE ord%MYID_PARAORD = -1 ENDIF IF (id%KEEP(245) .EQ. 1) THEN #if defined(ptscotch) ord%ORDTOOL = 1 IF(PROKG) WRITE(MPG, & '(" Using PT-SCOTCH for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(ord%MYID .EQ.0 ) WRITE(LP, & '(" PT-SCOTCH not available")') RETURN #endif ELSE IF (id%KEEP(245) .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) ord%ORDTOOL = 2 IF(PROKG) WRITE(MPG, & '(" Using ParMETIS for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(ord%MYID .EQ.0 ) WRITE(LP, & '(" ParMETIS not available.")') RETURN #endif END IF ELSE ord%NPROCS = NPROCS ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%COMM = COMM_PARASYMB ord%MYID = MYID ord%RKinSYMB_PROC0ORD = NPROCS-id%NSLAVES 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%COMM_PARAORD = id%COMM_NODES ord%NPROCS_PARAORD = id%NSLAVES ord%IDO = (ord%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1) IF (ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ELSE ord%MYID_PARAORD = -1 ENDIF IF(PROKG) WRITE(MPG, & '(" Using PT-SCOTCH for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(ord%MYID .EQ.0 ) WRITE(LP, & '(" PT-SCOTCH not available")') RETURN #endif ELSE IF (id%KEEP(245) .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) BASE = ord%NPROCS-id%NSLAVES IF(N.LE.100) THEN WORKERS = 2 ELSE WORKERS = min(id%NSLAVES,N/16) END IF I=1 DO IF (I .GT. WORKERS) EXIT ord%NPROCS_PARAORD = I I = I*2 END DO IDO = (ord%MYID .GE. BASE) .AND. & (ord%MYID .LE. BASE+ord%NPROCS_PARAORD-1) ord%IDO = IDO IF ( IDO ) THEN COLOR = 1 ELSE COLOR = MPI_UNDEFINED END IF CALL MPI_COMM_SPLIT( COMM_PARASYMB, COLOR, 0, ord%COMM_PARAORD, & IERR ) IF (ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ELSE ord%MYID_PARAORD = -1 ENDIF ord%ORDTOOL = 2 IF(PROKG) WRITE(MPG, & '(" Using ParMETIS for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(ord%MYID .EQ.0 ) WRITE(LP, & '(" ParMETIS not available.")') RETURN #endif END IF ENDIF END SUBROUTINE ZMUMPS_SET_PAR_ORD SUBROUTINE ZMUMPS_DO_PAR_ORD(id, MYID, NPROCS, ord, & WORK, LWORK, LUMAT, & SIZEOFBLOCKS) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id INTEGER, INTENT(IN) :: MYID, NPROCS TYPE(ORD_TYPE) :: ord INTEGER :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK TYPE(LMATRIX_T), OPTIONAL :: LUMAT INTEGER, INTENT(IN), OPTIONAL :: SIZEOFBLOCKS(N) #if defined(parmetis) || defined(parmetis3) INTEGER :: IERR #endif TYPE(COMPACT_GRAPH_T) :: GCOMP_DIST IF (id%KEEP(339).NE.0) THEN CALL MUMPS_AB_LMAT_TO_CLEAN_G ( ord%MYID, & .FALSE., & .FALSE., & LUMAT, GCOMP_DIST, id%INFO, id%ICNTL & , MEMCNT & ) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ENDIF IF (ord%ORDTOOL .EQ. 1) THEN #if defined(ptscotch) IF (id%KEEP(339).NE.0) THEN CALL ZMUMPS_PTSCOTCH_ORD(id, ord, WORK, LWORK, & GCOMP_DIST, & SIZEOFBLOCKS ) ELSE CALL ZMUMPS_PTSCOTCH_ORD(id, ord, WORK, LWORK) ENDIF #else id%INFOG(1) = -38 id%INFO(1) = -38 WRITE(LP,*)'PT-SCOTCH not available. Aborting...' CALL MUMPS_ABORT() #endif ELSE IF (ord%ORDTOOL .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) IF (id%KEEP(339).GT.0) THEN CALL ZMUMPS_PARMETIS_ORD_LUMAT (id, ord, WORK, LWORK, & GCOMP_DIST, & SIZEOFBLOCKS) ELSE CALL ZMUMPS_PARMETIS_ORD(id, ord, WORK, LWORK) ENDIF IF (id%KEEP(339).EQ.0) THEN if(ord%IDO) CALL MPI_COMM_FREE(ord%COMM_PARAORD, IERR) ENDIF #else id%INFOG(1) = -38 id%INFO(1) = -38 WRITE(LP,*)'ParMETIS not available. Aborting...' CALL MUMPS_ABORT() #endif END IF IF (id%KEEP(339).NE.0) THEN CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST, MEMCNT) ENDIF RETURN END SUBROUTINE ZMUMPS_DO_PAR_ORD #if defined(parmetis) || defined(parmetis3) SUBROUTINE ZMUMPS_PARMETIS_ORD(id, ord, WORK, LWORK) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT (IN) :: LWORK INTEGER :: I, MYID, NPROCS, IERR, BASE, METIS_IDX_SIZE INTEGER, POINTER :: FIRST(:), LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & OPTIONS(10) INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:), RCVCNTS(:) INTEGER(8) :: EDGELOCNBR INTEGER, POINTER :: SIZES(:), ORDER(:) INTEGER, POINTER :: IDUMMY_PTR(:) INTEGER :: SIZE_IDUMMY_PTR nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB, RCVCNTS, & SIZES, ORDER, IDUMMY_PTR) MYID = ord%MYID NPROCS = ord%NPROCS IERR = 0 SIZE_IDUMMY_PTR = 0 IF( LWORK.LT. int(N,8)*3_8 .OR. LWORK .LT. int(NPROCS+1,8)) THEN WRITE(LP, & '("Insufficient workspace inside ZMUMPS_PARMETIS_ORD")') CALL MUMPS_ABORT() END IF BASEVAL = 1 CALL MUMPS_REALLOC(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT BASE = id%NPROCS-id%NSLAVES CALL ZMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK(1_8: 2_8*int(N,8)), & 2_8*int(N,8), TYPE=2) VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 CALL MUMPS_I8REALLOC(VERTLOCTAB, VERTLOCNBR+1, id%INFO, & LP, STRING='VERTLOCTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT SWORK => WORK(int(N+1,8):3_8*int(N,8)) CALL ZMUMPS_BUILD_DIST_GRAPH(id, ord, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK, 2_8 * int(N,8)) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF(id%INFO(1).LT.0) GOTO 20 EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1_8 OPTIONS(:) = 0 ORDER => WORK(1:N) CALL MUMPS_REALLOC(SIZES, 2*ord%NPROCS_PARAORD, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IF(ord%IDO) THEN CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 1 ELSE CALL MUMPS_PARMETIS_MIXEDto32(id, & BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & IDUMMY_PTR, SIZE_IDUMMY_PTR, & SIZES, ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ENDIF ELSE IF (METIS_IDX_SIZE.EQ.64) THEN CALL MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & IDUMMY_PTR, SIZE_IDUMMY_PTR, & SIZES, ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ELSE WRITE(*,*) & "Internal error in PARMETIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() END IF END IF IF (id%KEEP(339).NE.0) THEN nullify(VERTLOCTAB, EDGELOCTAB) ELSE CALL MUMPS_IDEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(VERTLOCTAB) ENDIF IF(IERR.GT.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 20 CALL MPI_BCAST(SIZES(1), 2*ord%NPROCS_PARAORD, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) ord%CBLKNBR = 2*ord%NPROCS_PARAORD-1 CALL MUMPS_REALLOC(RCVCNTS, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, id%NPROCS RCVCNTS(I) = max(LAST(I)-FIRST(I)+1,0) END DO FIRST = FIRST-1 IF(FIRST(1) .LT. 0) THEN FIRST(1) = 0 END IF CALL MPI_ALLGATHERV ( ORDER(1), VERTLOCNBR, MPI_INTEGER, & ord%PERMTAB(1), & RCVCNTS(1), FIRST(1), MPI_INTEGER, ord%COMM, IERR ) DO I=1, N ord%PERITAB(ord%PERMTAB(I)) = I END DO CALL MUMPS_REALLOC(ord%RANGTAB, 2*ord%NPROCS_PARAORD, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL ZMUMPS_BUILD_TREETAB(ord%TREETAB, ord%RANGTAB, & SIZES, ord%CBLKNBR) CALL MUMPS_DEALLOC(SIZES, FIRST, LAST, & RCVCNTS, MEMCNT=MEMCNT) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL ZMUMPS_BUILD_TREE(ord) RETURN 20 CONTINUE CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(SIZES , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) RETURN END SUBROUTINE ZMUMPS_PARMETIS_ORD SUBROUTINE ZMUMPS_PARMETIS_ORD_LUMAT (id, ord, WORK, LWORK, & GCOMP_DIST, & SIZEOFBLOCKS ) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK TYPE(COMPACT_GRAPH_T), OPTIONAL :: GCOMP_DIST INTEGER, INTENT(IN), OPTIONAL, TARGET :: SIZEOFBLOCKS(N) INTEGER :: I, MYID, NPROCS, IERR, BASE, METIS_IDX_SIZE INTEGER :: MASTER PARAMETER (MASTER=0) INTEGER, POINTER :: FIRST(:), LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & OPTIONS(10) INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:), RCVCNTS(:) INTEGER(8) :: EDGELOCNBR INTEGER, POINTER :: SIZES(:), ORDER(:) INTEGER, POINTER :: VELOLOCTAB(:) INTEGER :: SIZE_VELOLOCTAB INTEGER, TARGET :: IDUMMY(1) nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB, RCVCNTS, & SIZES, ORDER ) VELOLOCTAB => IDUMMY MYID = ord%MYID NPROCS = ord%NPROCS IERR = 0 SIZE_VELOLOCTAB = 0 IF( LWORK.LT. int(N,8)*3_8 .OR. LWORK .LT. int(NPROCS+1,8)) THEN WRITE(LP, & '("Insufficient workspace inside ZMUMPS_PARMETIS_ORD")') CALL MUMPS_ABORT() END IF IF(ord%IDO) THEN CALL MUMPS_REALLOC(FIRST, ord%NPROCS_PARAORD+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, ord%NPROCS_PARAORD+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_REALLOC(SIZES, 2*ord%NPROCS_PARAORD, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 20 IF(ord%IDO) THEN CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) VERTLOCNBR = GCOMP_DIST%LAST-GCOMP_DIST%FIRST+1 EDGELOCNBR = GCOMP_DIST%NZG VERTLOCTAB => GCOMP_DIST%IPE EDGELOCTAB => GCOMP_DIST%ADJ IF (id%KEEP(339).NE.0) THEN VELOLOCTAB=>SIZEOFBLOCKS(GCOMP_DIST%FIRST:GCOMP_DIST%LAST) SIZE_VELOLOCTAB = VERTLOCNBR ENDIF DO I=1,ord%NPROCS_PARAORD+1 FIRST(I) = -99 LAST(I) = -99 ENDDO BASE = 0 #if defined(AVOID_MPI_IN_PLACE) CALL MPI_ALLGATHER( GCOMP_DIST%FIRST, 1, MPI_INTEGER, & FIRST, 1, MPI_INTEGER, ord%COMM_PARAORD, IERR ) CALL MPI_ALLGATHER( GCOMP_DIST%LAST, 1, MPI_INTEGER, & LAST, 1, MPI_INTEGER, ord%COMM_PARAORD, IERR ) #else FIRST(ord%MYID_PARAORD + 1)= GCOMP_DIST%FIRST LAST (ord%MYID_PARAORD + 1)= GCOMP_DIST%LAST CALL MPI_ALLREDUCE(MPI_IN_PLACE, FIRST(1), & ord%NPROCS_PARAORD+1, & MPI_INTEGER, MPI_MAX, ord%COMM_PARAORD, IERR) CALL MPI_ALLREDUCE(MPI_IN_PLACE, LAST(1), & ord%NPROCS_PARAORD+1, & MPI_INTEGER, MPI_MAX, ord%COMM_PARAORD, IERR) #endif DO I=1, ord%NPROCS_PARAORD+1 IF (FIRST(I).EQ.-99) THEN FIRST(I) = GCOMP_DIST%NG+1 ENDIF IF (LAST(I).EQ.-99) THEN LAST (I) = GCOMP_DIST%NG ENDIF ENDDO OPTIONS(:) = 0 ORDER => WORK(1:N) BASEVAL = 1 IF (METIS_IDX_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 1 ELSE CALL MUMPS_PARMETIS_MIXEDto32(id, & BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & VELOLOCTAB, SIZE_VELOLOCTAB, & SIZES, ord%COMM_PARAORD, ord%MYID_PARAORD, & IERR) ENDIF ELSE IF (METIS_IDX_SIZE.EQ.64) THEN CALL MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & VELOLOCTAB, SIZE_VELOLOCTAB, & SIZES, ord%COMM_PARAORD, ord%MYID_PARAORD, & IERR) ELSE WRITE(*,*) & "Internal error in PARMETIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() END IF END IF nullify(VERTLOCTAB, EDGELOCTAB) IF(IERR.GT.0) THEN id%INFO(1:2) = -50 END IF ord%CBLKNBR = 2*ord%NPROCS_PARAORD-1 CALL MUMPS_REALLOC(ord%RANGTAB, ord%CBLKNBR+1, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_REALLOC(RCVCNTS, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 20 IF (ord%IDO) THEN DO I=1, ord%NPROCS_PARAORD 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_GATHERV ( ORDER(1), VERTLOCNBR, MPI_INTEGER, & ord%PERMTAB(1), & RCVCNTS(1), FIRST(1), MPI_INTEGER, MASTER, & ord%COMM_PARAORD, IERR ) END IF IF (ord%MYID_PARAORD.EQ.MASTER) THEN DO I=1, N ord%PERITAB(ord%PERMTAB(I)) = I END DO CALL MUMPS_REALLOC(ord%TREETAB, ord%CBLKNBR, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL ZMUMPS_BUILD_TREETAB(ord%TREETAB, ord%RANGTAB, & SIZES, ord%CBLKNBR) ENDIF CALL MUMPS_DEALLOC(SIZES, FIRST, LAST, & RCVCNTS, MEMCNT=MEMCNT) CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%PERMTAB(1), N, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%PERITAB(1), N, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%RANGTAB(1), ord%CBLKNBR+1, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%TREETAB(1), ord%CBLKNBR, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL ZMUMPS_BUILD_TREE(ord) RETURN 20 CONTINUE CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(SIZES , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) RETURN END SUBROUTINE ZMUMPS_PARMETIS_ORD_LUMAT #endif #if defined(ptscotch) SUBROUTINE ZMUMPS_PTSCOTCH_ORD(id, ord, WORK, LWORK, GCOMP_DIST, & SIZEOFBLOCKS) !$ USE OMP_LIB IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK TYPE(COMPACT_GRAPH_T), OPTIONAL :: GCOMP_DIST INTEGER, INTENT(IN), OPTIONAL, TARGET:: SIZEOFBLOCKS(N) INTEGER :: MYID, NPROCS, IERR INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & BASE, SCOTCH_INT_SIZE INTEGER(8) :: EDGELOCNBR INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:) INTEGER, POINTER :: VELOLOCTAB(:) INTEGER :: SIZE_VELOLOCTAB INTEGER, TARGET :: IDUMMY(1) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) INCLUDE 'scotchf.h' INTEGER :: IOMP, NOMP DOUBLE PRECISION :: CONTDAT(SCOTCH_CONTEXTDIM) INTEGER(4) :: IERR_SCOTCH #else INTEGER :: PTHREAD_NUMBER, NOMP #endif nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB) VELOLOCTAB => IDUMMY CALL MPI_BARRIER(ord%COMM, IERR) MYID = ord%MYID NPROCS = ord%NPROCS SIZE_VELOLOCTAB = 0 BASEVAL = 1 IF (id%KEEP(339).NE.0) THEN VERTLOCNBR = GCOMP_DIST%LAST-GCOMP_DIST%FIRST+1 EDGELOCNBR = GCOMP_DIST%NZG VERTLOCTAB => GCOMP_DIST%IPE EDGELOCTAB => GCOMP_DIST%ADJ IF (id%KEEP(339).NE.0) THEN VELOLOCTAB => SIZEOFBLOCKS(GCOMP_DIST%FIRST:GCOMP_DIST%LAST) SIZE_VELOLOCTAB = VERTLOCNBR ENDIF ELSE IF (LWORK .LT. int(N,8)*3_8) THEN WRITE(LP, & '("Insufficient workspace inside ZMUMPS_PTSCOTCH_ORD")') CALL MUMPS_ABORT() END IF BASE = id%NPROCS-id%NSLAVES CALL MUMPS_REALLOC(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL ZMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK(1: 2_8*int(N,8)), & 2_8*int(N,8), TYPE=2) VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 CALL MUMPS_I8REALLOC(VERTLOCTAB, VERTLOCNBR+1, id%INFO, & LP, STRING='VERTLOCTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT SWORK => WORK(int(N+1,8):3_8*int(N,8)) CALL ZMUMPS_BUILD_DIST_GRAPH(id, ord, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK, 2_8*int(N,8)) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 11 EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1_8 ENDIF CALL MUMPS_REALLOC(ord%PERMTAB, N, id%INFO, & LP, STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%PERITAB, N, id%INFO, & LP, STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%RANGTAB, N+1, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%TREETAB, N, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IF(ord%IDO) THEN CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) !$OMP PARALLEL PRIVATE(IOMP, IERR_SCOTCH) !$OMP SINGLE NOMP=omp_get_num_threads() !$OMP END SINGLE IOMP=omp_get_thread_num() IF (IOMP.EQ.0) THEN CALL SCOTCHFCONTEXTINIT(CONTDAT, IERR_SCOTCH) CALL SCOTCHFCONTEXTRANDOMCLONE(CONTDAT, IERR_SCOTCH) CALL SCOTCHFCONTEXTTHREADIMPORT1(CONTDAT, NOMP, IERR_SCOTCH) ENDIF !$OMP BARRIER CALL SCOTCHFCONTEXTTHREADIMPORT2(CONTDAT, IOMP, IERR_SCOTCH) #else NOMP=0 !$ NOMP=omp_get_max_threads() IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (PTHREAD_NUMBER) CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (NOMP) ENDIF #endif #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) IF (IOMP.EQ.0) THEN #endif IF(SCOTCH_INT_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 2 ELSE CALL MUMPS_PTSCOTCH_MIXEDto32(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & VELOLOCTAB, SIZE_VELOLOCTAB, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, SCOTCH_CONTEXTDIM, #endif & IERR) ENDIF ELSE CALL MUMPS_PTSCOTCH_MIXEDto64(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & VELOLOCTAB, SIZE_VELOLOCTAB, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, SCOTCH_CONTEXTDIM, #endif & IERR) END IF #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL SCOTCHFCONTEXTEXIT(CONTDAT) ENDIF !$OMP END PARALLEL #else IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (PTHREAD_NUMBER) ENDIF #endif END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 11 CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%PERMTAB(1), N, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%PERITAB(1), N, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%RANGTAB(1), ord%CBLKNBR+1, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%TREETAB(1), ord%CBLKNBR, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) CALL ZMUMPS_BUILD_TREE(ord) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ord%N = N IF (id%KEEP(339).NE.0) THEN nullify(VERTLOCTAB, EDGELOCTAB) ELSE CALL MUMPS_DEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(VERTLOCTAB, MEMCNT=MEMCNT) ENDIF RETURN 11 CONTINUE IF (id%KEEP(339).NE.0) THEN CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(VERTLOCTAB, MEMCNT=MEMCNT) ELSE CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) nullify(VERTLOCTAB, EDGELOCTAB) ENDIF RETURN END SUBROUTINE ZMUMPS_PTSCOTCH_ORD #endif FUNCTION ZMUMPS_STOP_DESCENT(id, ord, NACTIVE, ANODE, RPROC, & ALIST, LIST, PEAKMEM, NNODES, CHECKMEM) IMPLICIT NONE LOGICAL :: ZMUMPS_STOP_DESCENT INTEGER :: NACTIVE, RPROC, ANODE, PEAKMEM, NNODES INTEGER :: ALIST(NNODES), LIST(NNODES) TYPE(ORD_TYPE) :: ord TYPE(ZMUMPS_STRUC) :: id LOGICAL, OPTIONAL :: CHECKMEM INTEGER :: IPEAKMEM, BIG, MAX_NROWS, MIN_NROWS INTEGER :: TOPROWS, NRL, HOSTMEM, SUBMEM INTEGER :: I, NZ_ROW, WEIGHT LOGICAL :: ICHECKMEM INTEGER :: NZ4 IF(present(CHECKMEM)) THEN ICHECKMEM = CHECKMEM ELSE ICHECKMEM = .FALSE. END IF ZMUMPS_STOP_DESCENT = .FALSE. IF(NACTIVE .GE. RPROC) THEN ZMUMPS_STOP_DESCENT = .TRUE. RETURN END IF IF(NACTIVE .EQ. 0) THEN ZMUMPS_STOP_DESCENT = .TRUE. RETURN END IF IF(.NOT. ICHECKMEM) RETURN BIG = ALIST(NACTIVE) IF(NACTIVE .GT. 1) THEN MAX_NROWS = ord%NW(ALIST(NACTIVE-1)) MIN_NROWS = ord%NW(ALIST(1)) ELSE MAX_NROWS = 0 MIN_NROWS = 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 *N HOSTMEM = 12*N NZ4=int(id%KEEP8(28)) NZ_ROW = 2*(NZ4/N) IF (id%KEEP(339).NE.0) THEN NRL = 0 ELSE IF(id%KEEP(46) .EQ. 0) THEN NRL = 0 ELSE NRL = MIN_NROWS END IF ENDIF HOSTMEM = HOSTMEM + 2*TOPROWS*NZ_ROW HOSTMEM = HOSTMEM +NRL HOSTMEM = HOSTMEM + max(NRL,TOPROWS)*(NZ_ROW+2) HOSTMEM = HOSTMEM + 6*max(NRL,TOPROWS) HOSTMEM = HOSTMEM + 3*TOPROWS NRL = MAX_NROWS SUBMEM = SUBMEM +NRL SUBMEM = SUBMEM + NRL*(NZ_ROW+2) SUBMEM = SUBMEM + 6*NRL IPEAKMEM = max(HOSTMEM, SUBMEM) IF((IPEAKMEM .GT. PEAKMEM) .AND. & (PEAKMEM .NE. 0)) THEN ZMUMPS_STOP_DESCENT = .TRUE. RETURN ELSE ZMUMPS_STOP_DESCENT = .FALSE. PEAKMEM = IPEAKMEM RETURN END IF END FUNCTION ZMUMPS_STOP_DESCENT FUNCTION ZMUMPS_CNT_KIDS(NODE, ord) IMPLICIT NONE INTEGER :: ZMUMPS_CNT_KIDS INTEGER :: NODE TYPE(ORD_TYPE) :: ord INTEGER :: CURR ZMUMPS_CNT_KIDS = 0 IF(ord%SON(NODE) .EQ. -1) THEN RETURN ELSE ZMUMPS_CNT_KIDS = 1 CURR = ord%SON(NODE) DO IF(ord%BROTHER(CURR) .NE. -1) THEN ZMUMPS_CNT_KIDS = ZMUMPS_CNT_KIDS+1 CURR = ord%BROTHER(CURR) ELSE EXIT END IF END DO END IF RETURN END FUNCTION ZMUMPS_CNT_KIDS SUBROUTINE ZMUMPS_GET_SUBTREES(ord, id) USE MUMPS_TOOLS_COMMON_M, ONLY : MUMPS_MERGESORT, & MUMPS_MERGESWAP IMPLICIT NONE TYPE(ORD_TYPE) :: ord TYPE(ZMUMPS_STRUC) :: id INTEGER, ALLOCATABLE :: ALIST(:), AWEIGHTS(:), LIST(:), WORK(:) INTEGER :: NNODES, BIG, CURR, ND, NACTIVE, RPROC, ANODE, BASE, I, & NK, PEAKMEM, allocok, Iprocdeb LOGICAL :: SD NNODES = ord%NPROCS_PARAORD CALL MUMPS_REALLOC(ord%TOPNODES, 2*max(NNODES,2), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%FIRST, ord%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%LAST, ord%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(ALIST(NNODES), AWEIGHTS(NNODES), LIST(NNODES), & WORK(0:NNODES+1), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=4*NNODES+2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 NACTIVE = 0 DO I=1, ord%CBLKNBR IF (ord%TREETAB(I).EQ.-1) THEN NACTIVE = NACTIVE+1 IF(NACTIVE.LE.NNODES) THEN ALIST(NACTIVE) = I AWEIGHTS(NACTIVE) = ord%NW(I) END IF END IF END DO IF((ord%CBLKNBR .EQ. 1) .OR. & (NACTIVE.GT.NNODES) .OR. & ( NNODES .LT. ZMUMPS_CNT_KIDS(ord%CBLKNBR, ord) )) THEN ord%TOPNODES =0 ord%TOPNODES(1) = 1 ord%TOPNODES(2) = ord%RANGTAB(ord%CBLKNBR+1) - ord%RANGTAB(1) ord%TOPNODES(3) = ord%RANGTAB(1) ord%TOPNODES(4) = ord%RANGTAB(ord%CBLKNBR+1)-1 ord%FIRST = 0 ord%LAST = -1 RETURN END IF CALL MUMPS_MERGESORT(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL MUMPS_MERGESWAP(NACTIVE, WORK(0:NACTIVE+1), & AWEIGHTS(1:NACTIVE), & ALIST(1:NACTIVE)) RPROC = NNODES ANODE = 0 PEAKMEM = 0 ord%TOPNODES = 0 DO IF(NACTIVE .EQ. 0) EXIT BIG = ALIST(NACTIVE) NK = ZMUMPS_CNT_KIDS(BIG, ord) IF((NK .GT. (RPROC-NACTIVE+1)) .OR. (NK .EQ. 0)) THEN ANODE = ANODE+1 LIST(ANODE) = BIG NACTIVE = NACTIVE-1 RPROC = RPROC-1 CYCLE END IF SD = ZMUMPS_STOP_DESCENT(id, ord, NACTIVE, ANODE, & RPROC, ALIST, LIST, PEAKMEM, NNODES, CHECKMEM=.TRUE.) IF ( SD ) & THEN IF(NACTIVE.GT.0) THEN LIST(ANODE+1:ANODE+NACTIVE) = ALIST(1:NACTIVE) ANODE = ANODE+NACTIVE END IF EXIT END IF ord%TOPNODES(1) = ord%TOPNODES(1)+1 ord%TOPNODES(2) = ord%TOPNODES(2) + & ord%RANGTAB(BIG+1) - ord%RANGTAB(BIG) ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+1) = ord%RANGTAB(BIG) ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+2) = & ord%RANGTAB(BIG+1)-1 CURR = ord%SON(BIG) ALIST(NACTIVE) = CURR AWEIGHTS(NACTIVE) = ord%NW(CURR) DO IF(ord%BROTHER(CURR) .EQ. -1) EXIT NACTIVE = NACTIVE+1 CURR = ord%BROTHER(CURR) ALIST(NACTIVE) = CURR AWEIGHTS(NACTIVE) = ord%NW(CURR) END DO CALL MUMPS_MERGESORT(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL MUMPS_MERGESWAP(NACTIVE, WORK(0:NACTIVE+1), & AWEIGHTS(1:NACTIVE), & ALIST(1:NACTIVE)) END DO DO I=1, ANODE AWEIGHTS(I) = ord%NW(LIST(I)) END DO CALL MUMPS_MERGESORT(ANODE, AWEIGHTS(1:ANODE), WORK(0:ANODE+1)) CALL MUMPS_MERGESWAP(ANODE, WORK(0:ANODE+1), AWEIGHTS(1:ANODE), & ALIST(1:ANODE)) IF (id%KEEP(339).NE.0) THEN Iprocdeb = ord%NPROCS-ANODE+1 IF (Iprocdeb.GT.1) THEN DO I=1, Iprocdeb-1 ord%FIRST(I) = 0 ord%LAST(I) = -1 ENDDO ENDIF 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(Iprocdeb) = ord%RANGTAB(ND) ord%LAST(Iprocdeb) = ord%RANGTAB(CURR+1)-1 Iprocdeb = Iprocdeb +1 ENDDO ELSE 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) = N+1 ord%LAST(BASE+I) = N END DO ENDIF DEALLOCATE(LIST, ALIST, AWEIGHTS, WORK) 90 continue RETURN END SUBROUTINE ZMUMPS_GET_SUBTREES SUBROUTINE ZMUMPS_PARSYMFACT(id, ord, GPE, GNV, WORK, LWORK) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: GPE(:), GNV(:) INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:), IPET(:), & BUF_PE1(:), BUF_PE2(:), TMP1(:) INTEGER, POINTER :: PE(:), LENG(:), I_HALO_MAP(:) INTEGER, POINTER :: NDENSE(:), LAST(:), & DEGREE(:), W(:), PERM(:), & LISTVAR_SCHUR(:), NEXT(:), & HEAD(:), NV(:), ELEN(:), & LSTVAR(:) INTEGER, POINTER :: MYLIST(:), LPERM(:), LIPERM(:), & NVT(:), BUF_NV1(:), & BUF_NV2(:), ROOTPERM(:), & TMP2(:), BWORK(:), NCLIQUES(:) INTEGER :: MYNCLIQUES, MYMAXVARS, ICLIQUES, & TOTNCLIQUES INTEGER(8) :: MYNVARS, TOTNVARS INTEGER(8), POINTER :: LVARPT(:) INTEGER :: HIDX, TOTEL, & NCMPA, I, J, SIZE_SCHUR, MYID, & NPROCS, IERR, NROWS_LOC, GLOB_IDX, TMP, & NTVAR, TGSIZE, MAXS, RHANDPE, & RHANDNV, RIDX, PROC, JOB, K INTEGER(8) :: PFREES, PFS_SAVE, PELEN, PFREET, PFT_SAVE INTEGER :: STATUSPE(MPI_STATUS_SIZE) INTEGER :: STATUSNV(MPI_STATUS_SIZE) INTEGER :: STATUSCLIQUES(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30 LOGICAL :: AGG6 INTEGER :: THRESH nullify(PE, IPE, LENG, I_HALO_MAP, NCLIQUES) nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, & NEXT, HEAD, NV, ELEN, LSTVAR) nullify(MYLIST, LVARPT, & LPERM, LIPERM, IPET, NVT, BUF_PE1, BUF_PE2, & BUF_NV1, BUF_NV2, ROOTPERM, TMP1, TMP2, BWORK) MYID = ord%MYID NPROCS = ord%NPROCS IF(LWORK .LT. 4_8*int(N,8)) THEN WRITE(LP,*)'Insufficient workspace in ZMUMPS_PARSYMFACT' CALL MUMPS_ABORT() ELSE HEAD => WORK( 1 : N ) ELEN => WORK( int(N,8)+1 : 2_8*int(N,8) ) LENG => WORK( 2_8*int(N,8)+1 : 3_8*int(N,8) ) PERM => WORK( 3_8*int(N,8)+1 : 4_8*int(N,8) ) END IF CALL ZMUMPS_GET_SUBTREES(ord, id) CALL MUMPS_IDEALLOC(ord%SON, ord%BROTHER, ord%NW, & ord%RANGTAB, MEMCNT=MEMCNT) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 NRL = NROWS_LOC TOPROWS = ord%TOPNODES(2) BWORK => WORK(1_8 : 2_8*int(N,8)) CALL ZMUMPS_BUILD_LOC_GRAPH(id, ord, HIDX, IPE, PE, LENG, & I_HALO_MAP, top_graph, BWORK, 2_8*int(N,8)) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF(id%INFO(1).lt.0) RETURN TMP = N DO I=1, NPROCS TMP = TMP-(ord%LAST(I)-ord%FIRST(I)+1) END DO TMP = ceiling(dble(TMP)*1.10D0) IF(MYID .EQ. 0) THEN TMP = max(max(TMP, HIDX),1) ELSE TMP = max(HIDX,1) END IF SIZE_SCHUR = HIDX - NROWS_LOC CALL MUMPS_REALLOC(NDENSE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, SIZE_SCHUR LISTVAR_SCHUR(I) = NROWS_LOC+I END DO THRESH = -1 AGG6 = .FALSE. PFREES = IPE(NROWS_LOC+1) PFS_SAVE = PFREES PELEN = PFREES-1 + 2_8*int(NROWS_LOC+ord%TOPNODES(2),8) DO I=1, HIDX PERM(I) = I END DO IF(SIZE_SCHUR.EQ.0) THEN JOB = 0 ELSE JOB = 1 END IF IF(HIDX .GT.0) THEN TOTEL = HIDX NV(1) = -1 CALL MUMPS_SYMQAMD_NEW(JOB, THRESH, NDENSE(1), HIDX, & TOTEL, PELEN, IPE(1), PFREES, LENG(1), PE(1), NV(1), & ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), NEXT(1), & W(1), PERM(1), LISTVAR_SCHUR(1), SIZE_SCHUR, AGG6) ENDIF MYNCLIQUES = 0 MYNVARS = 0 MYMAXVARS = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN MYMAXVARS = MAX(MYMAXVARS,LENG(I)) MYNVARS = MYNVARS+LENG(I) MYNCLIQUES = MYNCLIQUES+1 END IF END DO CALL MPI_REDUCE(MYNVARS, TOTNVARS, 1, MPI_INTEGER8, & MPI_SUM, 0, ord%COMM, IERR) CALL MUMPS_REALLOC(NCLIQUES, NPROCS, id%INFO, & LP, STRING='NCLIQUES', MEMCNT=MEMCNT, ERRCODE=-7) CALL MPI_GATHER(MYNCLIQUES, 1, MPI_INTEGER, NCLIQUES(1), 1, & MPI_INTEGER, 0, ord%COMM, IERR) IF(ord%MYID.EQ.0) THEN TOTNCLIQUES = sum(NCLIQUES) CALL MUMPS_I8REALLOC(LVARPT, TOTNCLIQUES+1, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(LSTVAR, TOTNVARS, id%INFO, & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) LVARPT(1) = 1_8 ICLIQUES = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN ICLIQUES = ICLIQUES+1 LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+LENG(I) DO J=0, LENG(I)-1 LSTVAR(LVARPT(ICLIQUES)+J) = & I_HALO_MAP(PE(IPE(I)+J)-NROWS_LOC) END DO END IF END DO DO PROC=1, NPROCS-1 DO I=1, NCLIQUES(PROC+1) ICLIQUES = ICLIQUES+1 CALL MPI_RECV(K, 1, MPI_INTEGER, PROC, ITAG, ord%COMM, & STATUSCLIQUES, IERR) LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+K CALL MPI_RECV(LSTVAR(LVARPT(ICLIQUES)), K, MPI_INTEGER, & PROC, ITAG, ord%COMM, STATUSCLIQUES, IERR) END DO END DO LPERM => WORK(3_8*int(N,8)+1_8 : 4_8*int(N,8)) NTVAR = ord%TOPNODES(2) CALL ZMUMPS_MAKE_LOC_IDX(id, ord%TOPNODES, LPERM, LIPERM, ord) CALL ZMUMPS_ASSEMBLE_TOP_GRAPH(id, ord%TOPNODES(2), LPERM, & top_graph, TOTNCLIQUES, LSTVAR, LVARPT, IPET, PE, & LENG, ELEN) TGSIZE = ord%TOPNODES(2)+TOTNCLIQUES PFREET = IPET(TGSIZE+1) PFT_SAVE = PFREET nullify(LPERM) ELSE CALL MUMPS_REALLOC(MYLIST, MYMAXVARS, id%INFO, & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, HIDX IF(IPE(I) .GT. 0) THEN DO J=1, LENG(I) MYLIST(J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) END DO CALL MPI_SEND(LENG(I), 1, MPI_INTEGER, 0, ITAG, & ord%COMM, IERR) CALL MPI_SEND(MYLIST(1), LENG(I), MPI_INTEGER, 0, ITAG, & ord%COMM, IERR) END IF END DO END IF CALL MUMPS_IDEALLOC(top_graph%IRN_LOC, & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN CALL MUMPS_IREALLOC8(PE, max(PFREET+int(TGSIZE,8),1_8),id%INFO, & LP, COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, & ERRCODE=-7) CALL MUMPS_REALLOC(NDENSE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NVT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, max(TGSIZE,1), id%INFO, LP, & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, max(TGSIZE,1), id%INFO, LP, & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(TOTNCLIQUES,1), id%INFO, & LP, STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TOTNCLIQUES LISTVAR_SCHUR(I) = NTVAR+I END DO THRESH = -1 CALL MUMPS_REALLOC(HEAD, max(TGSIZE,1), id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(PERM, max(TGSIZE,1), id%INFO, & LP, COPY=.TRUE., STRING='J2:PERM', & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TGSIZE PERM(I) = I END DO PELEN = max(PFREET+int(TGSIZE,8),1_8) IF(TGSIZE.GT.0) THEN TOTEL = TGSIZE NVT(1) = -1 CALL MUMPS_SYMQAMD_NEW(2, -1, NDENSE(1), TGSIZE, & TOTEL, PELEN, IPET(1), PFREET, LENG(1), PE(1), & NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), & NEXT(1), W(1), PERM(1), LISTVAR_SCHUR(1), TOTNCLIQUES, & AGG6) ENDIF END IF CALL MPI_BARRIER(ord%COMM, IERR) CALL MPI_BARRIER(ord%COMM, IERR) CALL MUMPS_DEALLOC(LISTVAR_SCHUR, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN MAXS = NROWS_LOC DO I=2, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) & MAXS = (ord%LAST(I)-ord%FIRST(I)+1) END DO CALL MUMPS_I8REALLOC(BUF_PE1, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(BUF_PE2, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV1, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV2, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GPE, N, id%INFO, & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GNV, N, id%INFO, & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ROOTPERM, TOTNCLIQUES, id%INFO, & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RIDX = 0 TMP1 => BUF_PE1 TMP2 => BUF_NV1 NULLIFY(BUF_PE1, BUF_NV1) BUF_PE1 => IPE BUF_NV1 => NV DO PROC=0, NPROCS-2 CALL MPI_IRECV(BUF_PE2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER8, PROC+1, PROC+1, & ord%COMM, RHANDPE, IERR) CALL MPI_IRECV(BUF_NV2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER, PROC+1, PROC+1, & ord%COMM, RHANDNV, IERR) DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO CALL MPI_WAIT(RHANDPE, STATUSPE, IERR) CALL MPI_WAIT(RHANDNV, STATUSNV, IERR) IF(PROC .NE. 0) THEN TMP1 => BUF_PE1 TMP2 => BUF_NV1 END IF BUF_PE1 => BUF_PE2 BUF_NV1 => BUF_NV2 NULLIFY(BUF_PE2, BUF_NV2) BUF_PE2 => TMP1 BUF_NV2 => TMP2 NULLIFY(TMP1, TMP2) END DO DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO DO I=1, NTVAR GLOB_IDX = LIPERM(I) IF(IPET(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = NVT(I) ELSE GPE(GLOB_IDX) = -LIPERM(-IPET(I)) GNV(GLOB_IDX) = NVT(I) END IF END DO DO I=1, TOTNCLIQUES GLOB_IDX = ROOTPERM(I) GPE(GLOB_IDX) = -LIPERM(-IPET(NTVAR+I)) END DO ELSE CALL MPI_SEND(IPE(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER8, 0, MYID, ord%COMM, IERR) CALL MPI_SEND(NV(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER, 0, MYID, ord%COMM, IERR) END IF CALL MUMPS_DEALLOC(BUF_NV1, BUF_NV2, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(BUF_PE1, BUF_PE2, IPE, IPET, & TMP1, LVARPT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, I_HALO_MAP, NDENSE, & LAST, DEGREE, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(W, LISTVAR_SCHUR, NEXT, & NV, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LSTVAR, NCLIQUES, MYLIST, & MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LPERM, LIPERM, NVT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ROOTPERM, TMP2, MEMCNT=MEMCNT) NULLIFY(HEAD, ELEN, LENG, PERM) RETURN END SUBROUTINE ZMUMPS_PARSYMFACT SUBROUTINE ZMUMPS_PARSYMFACT_LUMAT(id, ord, GPE, GNV, WORK, LWORK, & LUMAT, SIZEOFBLOCKS) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: GPE(:), GNV(:) INTEGER, TARGET :: WORK(:) TYPE(LMATRIX_T), INTENT(IN) :: LUMAT INTEGER, INTENT(IN) :: SIZEOFBLOCKS(id%NBLK) TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:), IPET(:), & BUF_PE1(:), BUF_PE2(:), TMP1(:) INTEGER, POINTER :: PE(:), & LENG(:), I_HALO_MAP(:) INTEGER, POINTER :: NDENSE(:), LAST(:), & DEGREE(:), W(:), PERM(:), & LISTVAR_SCHUR(:), NEXT(:), & HEAD(:), NV(:), ELEN(:), & LSTVAR(:) INTEGER, POINTER :: MYLIST(:), & LPERM(:), & LIPERM(:), & NVT(:), BUF_NV1(:), & BUF_NV2(:), ROOTPERM(:), & TMP2(:), BWORK(:), NCLIQUES(:), MAPTAB(:) INTEGER :: MYNCLIQUES, MYMAXVARS, ICLIQUES, & TOTNCLIQUES INTEGER(8) :: MYNVARS, TOTNVARS, LWORK INTEGER(8), POINTER :: LVARPT(:) INTEGER :: HIDX, TOTEL, & NCMPA, I, J, SIZE_SCHUR, MYID, & NPROCS, IERR, NROWS_LOC, GLOB_IDX, TMP, & NTVAR, TGSIZE, MAXS, RHANDPE, & RHANDNV, RIDX, PROC, JOB, K INTEGER(8) :: PFREES, PFS_SAVE, PELEN, PFREET, PFT_SAVE INTEGER :: STATUSPE(MPI_STATUS_SIZE) INTEGER :: STATUSNV(MPI_STATUS_SIZE) INTEGER :: STATUSCLIQUES(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30 LOGICAL :: AGG6 INTEGER :: THRESH nullify(PE, IPE, LENG, I_HALO_MAP, NCLIQUES) nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, & NEXT, HEAD, NV, ELEN, LSTVAR) nullify(MYLIST, LVARPT, MAPTAB, & LPERM, LIPERM, IPET, NVT, BUF_PE1, BUF_PE2, & BUF_NV1, BUF_NV2, ROOTPERM, TMP1, TMP2, BWORK, MAPTAB) MYID = ord%MYID NPROCS = ord%NPROCS IF( LWORK .LT. 4_8*int(N,8) ) THEN WRITE(LP,*) & 'Insufficient workspace in ZMUMPS_PARSYMFACT_LUMAT' CALL MUMPS_ABORT() ENDIF HEAD => WORK( 1 : N ) ELEN => WORK( int(N,8)+1_8 : 2_8*int(N,8) ) LENG => WORK( 2_8*int(N,8)+1_8 : 3_8*int(N,8) ) PERM => WORK( 3_8*int(N,8)+1_8 : 4_8*int(N,8) ) CALL ZMUMPS_GET_SUBTREES(ord, id) CALL MUMPS_IDEALLOC(ord%SON, ord%BROTHER, ord%NW, & ord%RANGTAB, MEMCNT=MEMCNT) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 NRL = NROWS_LOC TOPROWS = ord%TOPNODES(2) BWORK => WORK(1_8 : 2_8*int(N,8)) CALL ZMUMPS_LUMAT_TO_LOC_GRAPH( & LUMAT, id, ord, HIDX, IPE, PE, LENG, & I_HALO_MAP, BWORK, 2_8*int(N,8)) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF(id%INFO(1).lt.0) RETURN TMP = N DO I=1, NPROCS TMP = TMP-(ord%LAST(I)-ord%FIRST(I)+1) END DO TMP = ceiling(dble(TMP)*1.10D0) IF(MYID .EQ. 0) THEN TMP = max(max(TMP, HIDX),1) ELSE TMP = max(HIDX,1) END IF SIZE_SCHUR = HIDX - NROWS_LOC CALL MUMPS_REALLOC(NDENSE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, SIZE_SCHUR LISTVAR_SCHUR(I) = NROWS_LOC+I END DO THRESH = -1 AGG6 = .FALSE. PFREES = IPE(NROWS_LOC+1) PFS_SAVE = PFREES PELEN = PFREES-1 + 2_8*int(NROWS_LOC+ord%TOPNODES(2),8) DO I=1, HIDX PERM(I) = I END DO IF(SIZE_SCHUR.EQ.0) THEN JOB = 0 ELSE JOB = 1 END IF IF(HIDX .GT.0) THEN NV(1) = -1 TOTEL = HIDX IF ((N.LT.NORIG).OR.(id%KEEP(339).NE.0)) THEN TOTEL = 0 DO I=1,NROWS_LOC NV(I) = SIZEOFBLOCKS ( & ord%PERITAB(ord%FIRST(MYID+1)+I-1) & ) TOTEL = TOTEL + NV(I) ENDDO DO I=NROWS_LOC+1, HIDX NV(I) = SIZEOFBLOCKS (I_HALO_MAP(I-NROWS_LOC)) TOTEL = TOTEL + NV(I) ENDDO ENDIF CALL MUMPS_SYMQAMD_NEW(JOB, THRESH, NDENSE(1), HIDX, & TOTEL, PELEN, IPE(1), PFREES, LENG(1), PE(1), NV(1), & ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), NEXT(1), & W(1), PERM(1), LISTVAR_SCHUR(1), SIZE_SCHUR, AGG6) ENDIF MYNCLIQUES = 0 MYNVARS = 0 MYMAXVARS = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN MYMAXVARS = MAX(MYMAXVARS,LENG(I)) MYNVARS = MYNVARS+LENG(I) MYNCLIQUES = MYNCLIQUES+1 END IF END DO CALL MPI_REDUCE(MYNVARS, TOTNVARS, 1, MPI_INTEGER8, & MPI_SUM, 0, ord%COMM, IERR) CALL MUMPS_REALLOC(NCLIQUES, NPROCS, id%INFO, & LP, STRING='NCLIQUES', MEMCNT=MEMCNT, ERRCODE=-7) CALL MPI_GATHER(MYNCLIQUES, 1, MPI_INTEGER, NCLIQUES(1), 1, & MPI_INTEGER, 0, ord%COMM, IERR) IF(ord%MYID.EQ.0) THEN TOTNCLIQUES = sum(NCLIQUES) CALL MUMPS_I8REALLOC(LVARPT, TOTNCLIQUES+1, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(LSTVAR, TOTNVARS, id%INFO, & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) LVARPT(1) = 1_8 ICLIQUES = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN ICLIQUES = ICLIQUES+1 LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+LENG(I) DO J=0, LENG(I)-1 LSTVAR(LVARPT(ICLIQUES)+J) = & I_HALO_MAP(PE(IPE(I)+J)-NROWS_LOC) END DO END IF END DO DO PROC=1, NPROCS-1 DO I=1, NCLIQUES(PROC+1) ICLIQUES = ICLIQUES+1 CALL MPI_RECV(K, 1, MPI_INTEGER, PROC, ITAG, ord%COMM, & STATUSCLIQUES, IERR) LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+K CALL MPI_RECV(LSTVAR(LVARPT(ICLIQUES)), K, MPI_INTEGER, & PROC, ITAG, ord%COMM, STATUSCLIQUES, IERR) END DO END DO ELSE CALL MUMPS_REALLOC(MYLIST, MYMAXVARS, id%INFO, & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, HIDX IF(IPE(I) .GT. 0) THEN DO J=1, LENG(I) MYLIST(J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) END DO CALL MPI_SEND(LENG(I), 1, MPI_INTEGER, 0, ITAG, & ord%COMM, IERR) CALL MPI_SEND(MYLIST(1), LENG(I), MPI_INTEGER, 0, ITAG, & ord%COMM, IERR) END IF END DO END IF CALL MUMPS_DEALLOC(PE, MEMCNT=MEMCNT) IF (id%KEEP(339).NE.0) THEN MAPTAB => WORK(1:N) CALL MUMPS_BUILD_TOP_GRAPH (LUMAT, id, ord, top_graph, MAPTAB) ENDIF IF (MYID.EQ.0) THEN LPERM => WORK( 3_8*int(N,8)+1_8 : 4_8*int(N,8) ) NTVAR = ord%TOPNODES(2) CALL ZMUMPS_MAKE_LOC_IDX(id, ord%TOPNODES, LPERM, LIPERM, ord) CALL ZMUMPS_ASSEMBLE_TOP_GRAPH(id, ord%TOPNODES(2), LPERM, & top_graph, TOTNCLIQUES, LSTVAR, LVARPT, IPET, PE, & LENG, ELEN) TGSIZE = ord%TOPNODES(2)+TOTNCLIQUES PFREET = IPET(TGSIZE+1) PFT_SAVE = PFREET nullify(LPERM) ENDIF CALL MUMPS_IDEALLOC(top_graph%IRN_LOC, & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN CALL MUMPS_IREALLOC8(PE, max(PFREET+int(TGSIZE,8),1_8),id%INFO, & LP, COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, & ERRCODE=-7) CALL MUMPS_REALLOC(NDENSE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NVT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, max(TGSIZE,1), id%INFO, LP, & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, max(TGSIZE,1), id%INFO, LP, & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(TOTNCLIQUES,1), id%INFO, & LP, STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TOTNCLIQUES LISTVAR_SCHUR(I) = NTVAR+I END DO THRESH = -1 CALL MUMPS_REALLOC(HEAD, max(TGSIZE,1), id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(PERM, max(TGSIZE,1), id%INFO, & LP, COPY=.TRUE., STRING='J2:PERM', & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TGSIZE PERM(I) = I END DO PELEN = max(PFREET+int(TGSIZE,8),1_8) IF(TGSIZE.GT.0) THEN NVT(1) = -1 TOTEL = TGSIZE IF ((N.LT.NORIG).OR.(id%KEEP(339).NE.0)) THEN TOTEL = TOTNCLIQUES DO I=1,NTVAR NVT(I) = SIZEOFBLOCKS( LIPERM(I) ) TOTEL = TOTEL + NVT(I) ENDDO ENDIF CALL MUMPS_SYMQAMD_NEW(2, -1, NDENSE(1), & TGSIZE, TOTEL, PELEN, IPET(1), PFREET, LENG(1), PE(1), & NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), & NEXT(1), W(1), PERM(1), LISTVAR_SCHUR(1), TOTNCLIQUES, & AGG6) ENDIF CALL MUMPS_DEALLOC(PE, MEMCNT=MEMCNT) END IF CALL MPI_BARRIER(ord%COMM, IERR) CALL MPI_BARRIER(ord%COMM, IERR) CALL MUMPS_DEALLOC(LISTVAR_SCHUR, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN MAXS = NROWS_LOC DO I=2, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) & MAXS = (ord%LAST(I)-ord%FIRST(I)+1) END DO CALL MUMPS_I8REALLOC(BUF_PE1, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(BUF_PE2, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV1, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV2, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GPE, N, id%INFO, & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GNV, N, id%INFO, & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ROOTPERM, TOTNCLIQUES, id%INFO, & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RIDX = 0 TMP1 => BUF_PE1 TMP2 => BUF_NV1 NULLIFY(BUF_PE1, BUF_NV1) BUF_PE1 => IPE BUF_NV1 => NV DO PROC=0, NPROCS-2 CALL MPI_IRECV(BUF_PE2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER8, PROC+1, PROC+1, & ord%COMM, RHANDPE, IERR) CALL MPI_IRECV(BUF_NV2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER, PROC+1, PROC+1, & ord%COMM, RHANDNV, IERR) DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO CALL MPI_WAIT(RHANDPE, STATUSPE, IERR) CALL MPI_WAIT(RHANDNV, STATUSNV, IERR) IF(PROC .NE. 0) THEN TMP1 => BUF_PE1 TMP2 => BUF_NV1 END IF BUF_PE1 => BUF_PE2 BUF_NV1 => BUF_NV2 NULLIFY(BUF_PE2, BUF_NV2) BUF_PE2 => TMP1 BUF_NV2 => TMP2 NULLIFY(TMP1, TMP2) END DO DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO DO I=1, NTVAR GLOB_IDX = LIPERM(I) IF(IPET(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = NVT(I) ELSE GPE(GLOB_IDX) = -LIPERM(-IPET(I)) GNV(GLOB_IDX) = NVT(I) END IF END DO DO I=1, TOTNCLIQUES GLOB_IDX = ROOTPERM(I) GPE(GLOB_IDX) = -LIPERM(-IPET(NTVAR+I)) END DO ELSE CALL MPI_SEND(IPE(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER8, 0, MYID, ord%COMM, IERR) CALL MPI_SEND(NV(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER, 0, MYID, ord%COMM, IERR) END IF CALL MUMPS_DEALLOC(BUF_NV1, BUF_NV2, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(BUF_PE1, BUF_PE2, IPE, IPET, & TMP1, LVARPT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, I_HALO_MAP, NDENSE, & LAST, DEGREE, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(W, LISTVAR_SCHUR, NEXT, & NV, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LSTVAR, NCLIQUES, MYLIST, & MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LPERM, LIPERM, NVT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ROOTPERM, TMP2, MEMCNT=MEMCNT) NULLIFY(HEAD, ELEN, LENG, PERM, BWORK, MAPTAB, LPERM) RETURN END SUBROUTINE ZMUMPS_PARSYMFACT_LUMAT SUBROUTINE ZMUMPS_MAKE_LOC_IDX(id, TOPNODES, LPERM, LIPERM, ord) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id INTEGER, POINTER :: TOPNODES(:), LPERM(:), LIPERM(:) TYPE(ORD_TYPE) :: ord INTEGER :: I, J, K, GIDX CALL MUMPS_REALLOC(LPERM , ord%N, id%INFO, & LP, STRING='LIDX:LPERM', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LIPERM, TOPNODES(2), id%INFO, & LP, STRING='LIDX:LIPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LPERM = 0 K = 1 DO I=TOPNODES(1), 1, -1 DO J=TOPNODES(2*I+1), TOPNODES(2*I+2) GIDX = ord%PERITAB(J) LPERM(GIDX) = K LIPERM(K) = GIDX K = K+1 END DO END DO RETURN END SUBROUTINE ZMUMPS_MAKE_LOC_IDX SUBROUTINE ZMUMPS_ASSEMBLE_TOP_GRAPH(id, NLOCVARS, LPERM, & top_graph, NCLIQUES, LSTVAR, LVARPT, IPE, PE, LENG, ELEN) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(GRAPH_TYPE) :: top_graph INTEGER, POINTER :: LPERM(:), LSTVAR(:), & PE(:), LENG(:), ELEN(:) INTEGER(8) :: LVARPT(:) INTEGER :: NCLIQUES INTEGER(8), POINTER :: IPE(:) INTEGER :: I, IDX, NLOCVARS INTEGER(8) :: INNZ, PNT, SAVEPNT CALL MUMPS_REALLOC(LENG, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:LENG', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ELEN, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:ELEN', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(IPE , NLOCVARS+NCLIQUES+1, id%INFO, & LP, STRING='ATG:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG = 0 ELEN = 0 DO INNZ=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(INNZ)) .NE. 0) .AND. & (top_graph%JCN_LOC(INNZ) .NE. top_graph%IRN_LOC(INNZ))) & THEN LENG(LPERM(top_graph%IRN_LOC(INNZ))) = & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1 END IF END DO DO I=1, NCLIQUES DO INNZ=LVARPT(I), LVARPT(I+1)-1 ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 END DO END DO IPE(1) = 1 DO I=1, NLOCVARS+NCLIQUES IPE(I+1) = IPE(I)+int(LENG(I),8)+int(ELEN(I),8) END DO CALL MUMPS_IREALLOC8(PE, IPE(NLOCVARS+NCLIQUES+1)+ & int(NLOCVARS,8)+int(NCLIQUES,8), & id%INFO, LP, STRING='ATG:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG = 0 ELEN = 0 DO I=1, NCLIQUES DO INNZ=LVARPT(I), LVARPT(I+1)-1 IDX = LPERM(LSTVAR(INNZ)) PE(IPE(IDX)+int(ELEN(IDX),8)) = NLOCVARS+I PE(IPE(NLOCVARS+I)+int(LENG(NLOCVARS+I),8)) = IDX ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 end do end do DO INNZ=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(INNZ)) .NE. 0) .AND. & (top_graph%JCN_LOC(INNZ) .NE. top_graph%IRN_LOC(INNZ))) & THEN PE(IPE(LPERM(top_graph%IRN_LOC(INNZ)))+ & ELEN(LPERM(top_graph%IRN_LOC(INNZ))) + & LENG(LPERM(top_graph%IRN_LOC(INNZ)))) = & LPERM(top_graph%JCN_LOC(INNZ)) LENG(LPERM(top_graph%IRN_LOC(INNZ))) = & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1 END IF END DO DO I=1, NLOCVARS+NCLIQUES LENG(I) = LENG(I)+ELEN(I) END DO SAVEPNT = 1 PNT = 0 LPERM(1:NLOCVARS+NCLIQUES) = 0 DO I=1, NLOCVARS+NCLIQUES DO INNZ=IPE(I), IPE(I+1)-1 IF(LPERM(PE(INNZ)) .EQ. I) THEN LENG(I) = LENG(I)-1 ELSE LPERM(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NLOCVARS+NCLIQUES+1) = SAVEPNT RETURN END SUBROUTINE ZMUMPS_ASSEMBLE_TOP_GRAPH #if defined(parmetis) || defined(parmetis3) SUBROUTINE ZMUMPS_BUILD_TREETAB(TREETAB, RANGTAB, SIZES, CBLKNBR) INTEGER, POINTER :: TREETAB(:), RANGTAB(:), SIZES(:) INTEGER :: CBLKNBR,allocok INTEGER :: LCHILD, RCHILD, K, I INTEGER, POINTER :: PERM(:) ALLOCATE(PERM(CBLKNBR),stat=allocok) if(allocok.GT.0) then write(*,*) "Allocation error of PERM in ZMUMPS_BUILD_TREETAB" return endif TREETAB(CBLKNBR) = -1 IF(CBLKNBR .EQ. 1) THEN DEALLOCATE(PERM) TREETAB(1) = -1 RANGTAB(1) = 1 RANGTAB(2)= SIZES(1)+1 RETURN END IF LCHILD = CBLKNBR - (CBLKNBR+1)/2 RCHILD = CBLKNBR-1 K = 1 PERM(CBLKNBR) = CBLKNBR PERM(LCHILD) = CBLKNBR+1 - (2*K+1) PERM(RCHILD) = CBLKNBR+1 - (2*K) TREETAB(RCHILD) = CBLKNBR TREETAB(LCHILD) = CBLKNBR IF(CBLKNBR .GT. 3) THEN CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, & LCHILD, CBLKNBR, 2*K+1) CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, & RCHILD, CBLKNBR, 2*K) END IF RANGTAB(1)=1 DO I=1, CBLKNBR RANGTAB(I+1) = RANGTAB(I)+SIZES(PERM(I)) END DO DEALLOCATE(PERM) RETURN CONTAINS RECURSIVE SUBROUTINE REC_TREETAB(TREETAB, PERM, SUBNODES, & ROOTN, CBLKNBR, K) INTEGER, POINTER :: TREETAB(:), PERM(:) INTEGER :: SUBNODES, ROOTN, K, CBLKNBR INTEGER :: LCHILD, RCHILD LCHILD = ROOTN - (SUBNODES+1)/2 RCHILD = ROOTN-1 PERM(LCHILD) = CBLKNBR+1 - (2*K+1) PERM(RCHILD) = CBLKNBR+1 - (2*K) TREETAB(RCHILD) = ROOTN TREETAB(LCHILD) = ROOTN IF(SUBNODES .GT. 3) THEN CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, LCHILD, & CBLKNBR, 2*K+1) CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, RCHILD, & CBLKNBR, 2*K) END IF END SUBROUTINE REC_TREETAB END SUBROUTINE ZMUMPS_BUILD_TREETAB #endif #if defined(ptscotch) || defined(parmetis) || defined(parmetis3) SUBROUTINE ZMUMPS_BUILD_DIST_GRAPH(id, ord, FIRST, LAST, IPE, & PE, WORK, LWORK) #if defined(DETERMINISTIC_PARALLEL_GRAPH) USE MUMPS_TOOLS_COMMON_M, ONLY : MUMPS_MERGESORT, & MUMPS_MERGESWAP1 #endif IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: FIRST(:), LAST(:), PE(:), & WORK(:) INTEGER(8), INTENT(IN) :: LWORK INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, OFFDIAG, & RCVPNT, PNT, SAVEPNT, DUPS, TOTDUPS INTEGER :: NROWS_LOC INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, POINTER :: MAPTAB(:) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: RDISPL(:), BUFLEVEL(:), & SIPES(:,:), LENG(:) INTEGER, POINTER :: TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER, PARAMETER :: ITAG=30 LOGICAL :: FLAG DOUBLE PRECISION :: SYMMETRY INTEGER(KIND=8) :: TLEN #if defined(DETERMINISTIC_PARALLEL_GRAPH) INTEGER :: L #endif nullify(MAPTAB, SNDCNT, RCVCNT) nullify(RDISPL, MSGCNT, SIPES, LENG, BUFLEVEL) nullify(TSENDI, TSENDJ, RCVBUF, APNT) MYID = ord%MYID NPROCS = ord%NPROCS IF(LWORK .LT. int(N,8)*2_8) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_SCOTCH_GRAPH")') CALL MUMPS_ABORT() END IF CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 BUFSIZE = 1000 BUFSIZE = id%KEEP(39) LOCNNZ = id%KEEP8(29) NROWS_LOC = LAST(MYID+1)-FIRST(MYID+1)+1 MAPTAB => WORK( 1 : N ) LENG => WORK( int(N+1,8) : 2_8*int(N,8) ) MAXS = 0 DO I=1, NPROCS IF((LAST(I)-FIRST(I)+1) .GT. MAXS) THEN MAXS = LAST(I)-FIRST(I)+1 END IF DO J=FIRST(I), LAST(I) MAPTAB(J) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 OFFDIAG=0 SIPES=0 DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN OFFDIAG = OFFDIAG+1 PROC = MAPTAB(id%IRN_loc(INNZ)) LOC_ROW = id%IRN_loc(INNZ)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 PROC = MAPTAB(id%JCN_loc(INNZ)) LOC_ROW = id%JCN_loc(INNZ)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF END DO CALL MPI_ALLREDUCE (OFFDIAG, id%KEEP8(127), 1, MPI_INTEGER8, & MPI_SUM, ord%COMM, IERR) id%KEEP8(127) = id%KEEP8(127)+3*N id%KEEP8(126) = id%KEEP8(127)-2*N CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, ord%COMM, IERR) CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, ord%COMM, IERR ) DEALLOCATE(SIPES) TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO CALL MUMPS_IREALLOC8(PE, max(IPE(NROWS_LOC+1)-1_8,1_8), id%INFO, & LP, STRING='PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL ZMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ+RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO RCVPNT = 1 BUFLEVEL = 0 DO INNZ=1, LOCNNZ IF(mod(INNZ,int(BUFSIZE,8)/10_8) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, ord%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, ord%COMM, STATUS, IERR) CALL ZMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%IRN_loc(INNZ)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%JCN_loc(INNZ) BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL ZMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF PROC = MAPTAB(id%JCN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%JCN_loc(INNZ)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%IRN_loc(INNZ) BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL ZMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF END IF END DO CALL ZMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(MAPTAB(PE(INNZ)) .EQ. I) THEN DUPS = DUPS+1 ELSE MAPTAB(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO CALL MPI_REDUCE( DUPS, TOTDUPS, 1, MPI_INTEGER8, MPI_SUM, & 0, ord%COMM, IERR ) IF(MYID .EQ. 0) THEN SYMMETRY = dble(TOTDUPS)/(dble(id%KEEP8(28))-dble(N)) SYMMETRY = min(SYMMETRY,1.0d0) IF(id%KEEP(50) .GE. 1) SYMMETRY = 1.d0 IF(PROKG) WRITE(MPG,'(" Structural symmetry is:",i3,"%")') & ceiling(SYMMETRY*100.d0) id%INFOG(8) = ceiling(SYMMETRY*100.0d0) END IF IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) #if defined(DETERMINISTIC_PARALLEL_GRAPH) DO I=1, LAST(MYID+1)-FIRST(MYID+1)+1 L = int(IPE(I+1)-IPE(I)) CALL MUMPS_MERGESORT(L, & PE(IPE(I):IPE(I+1)-1), & WORK(:)) CALL MUMPS_MERGESWAP1(L, WORK(:), & PE(IPE(I):IPE(I+1)-1)) END DO #endif 90 continue RETURN END SUBROUTINE ZMUMPS_BUILD_DIST_GRAPH #endif SUBROUTINE ZMUMPS_BUILD_LOC_GRAPH(id, ord, GSIZE, IPE, PE, LENG, & I_HALO_MAP, top_graph, WORK, LWORK) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: PE(:), LENG(:), & I_HALO_MAP(:), WORK(:) INTEGER(8), INTENT(in) :: LWORK INTEGER :: GSIZE INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, TOP_CNT, TIDX, & RCVPNT INTEGER :: IIDX,JJDX INTEGER :: HALO_SIZE, NROWS_LOC, DUPS INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: MAPTAB(:), & HALO_MAP(:), BUFLEVEL(:) INTEGER, POINTER :: RDISPL(:), & SIPES(:,:) INTEGER, POINTER :: TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER(8) :: PNT, SAVEPNT INTEGER, PARAMETER :: ITAG=30 INTEGER(KIND=8) :: TLEN LOGICAL :: FLAG nullify(MAPTAB, SNDCNT, RCVCNT, HALO_MAP) nullify(RDISPL, MSGCNT, SIPES, BUFLEVEL) nullify(TSENDI, TSENDJ, RCVBUF, APNT) MYID = ord%MYID NPROCS = ord%NPROCS IF( LWORK .LT. int(N,8)*2_8 ) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_LOC_GRAPH")') CALL MUMPS_ABORT() END IF MAPTAB => WORK( 1 : N ) HALO_MAP => WORK(int(N+1,8) : 2_8*int(N,8)) CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 TOP_CNT = 0 BUFSIZE = 10000 BUFSIZE = id%KEEP(39) LOCNNZ = id%KEEP8(29) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 MAPTAB = 0 MAXS = 0 DO I=1, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) THEN MAXS = ord%LAST(I)-ord%FIRST(I)+1 END IF DO J=ord%FIRST(I), ord%LAST(I) MAPTAB(ord%PERITAB(J)) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SIPES(:,:) = 0 TOP_CNT = 0 DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%IRN_loc(INNZ)) LOC_ROW = IIDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF PROC = MAPTAB(id%JCN_loc(INNZ)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%JCN_loc(INNZ)) LOC_ROW = IIDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF END IF END DO CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, ord%COMM, IERR) I = ceiling(dble(MAXS)*1.20D0) CALL MUMPS_REALLOC(LENG, max(I,1), id%INFO, & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, ord%COMM, IERR ) DEALLOCATE(SIPES) I = ceiling(dble(NROWS_LOC+1)*1.20D0) CALL MUMPS_I8REALLOC(IPE, max(I,1), id%INFO, & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO CALL MUMPS_IREALLOC8(TSENDI, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(TSENDJ, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL ZMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ + RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO CALL MUMPS_IREALLOC8(PE, max(NEW_LOCNNZ+ & 2_8*int(NROWS_LOC+ord%TOPNODES(2),8),1_8), & id%INFO, LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RCVPNT = 1 BUFLEVEL = 0 TIDX = 0 DO INNZ=1, LOCNNZ IF(mod(INNZ,int(BUFSIZE/10,8)) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, ord%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, ord%COMM, STATUS, IERR) CALL ZMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) IF((MAPTAB(id%JCN_loc(INNZ)).NE.PROC) .AND. & (MAPTAB(id%JCN_loc(INNZ)).NE.0) .AND. & (PROC.NE.0)) THEN IERR = -50 id%INFO(1) = IERR END IF IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%IRN_loc(INNZ) TSENDJ(TIDX) = id%JCN_loc(INNZ) ELSE IIDX = ord%PERMTAB(id%IRN_loc(INNZ)) JJDX = ord%PERMTAB(id%JCN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1)=IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%JCN_loc(INNZ) END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL ZMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF END IF PROC = MAPTAB(id%JCN_loc(INNZ)) IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%JCN_loc(INNZ) TSENDJ(TIDX) = id%IRN_loc(INNZ) ELSE IIDX = ord%PERMTAB(id%JCN_loc(INNZ)) JJDX = ord%PERMTAB(id%IRN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = & IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%IRN_loc(INNZ) END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL ZMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF END IF END IF END DO CALL ZMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB(:) = 0 HALO_MAP(:) = 0 HALO_SIZE = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(PE(INNZ) .LT. 0) THEN IF(HALO_MAP(-PE(INNZ)) .EQ. 0) THEN HALO_SIZE = HALO_SIZE+1 HALO_MAP(-PE(INNZ)) = NROWS_LOC+HALO_SIZE END IF PE(INNZ) = HALO_MAP(-PE(INNZ)) END IF IF(MAPTAB(PE(INNZ)) .EQ. I) THEN DUPS = DUPS+1 LENG(I) = LENG(I)-1 ELSE MAPTAB(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_REALLOC(I_HALO_MAP, HALO_SIZE, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT J=0 DO I=1, N IF(HALO_MAP(I) .GT. 0) THEN J = J+1 I_HALO_MAP(HALO_MAP(I)-NROWS_LOC) = I END IF IF(J .EQ. HALO_SIZE) EXIT END DO CALL MUMPS_REALLOC(LENG, max(NROWS_LOC+HALO_SIZE,1), id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:leng', MEMCNT=MEMCNT, ERRCODE=-7) LENG(NROWS_LOC+1:NROWS_LOC+HALO_SIZE) = 0 CALL MUMPS_I8REALLOC(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IPE(NROWS_LOC+2:NROWS_LOC+HALO_SIZE+1) = IPE(NROWS_LOC+1) GSIZE = NROWS_LOC + HALO_SIZE CALL MPI_GATHER(TOP_CNT, 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, 0, ord%COMM, IERR) IF(MYID.EQ.0) THEN NEW_LOCNNZ = sum(RCVCNT) top_graph%NZ_LOC = NEW_LOCNNZ CALL MUMPS_IREALLOC8(top_graph%IRN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(top_graph%JCN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1), & stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 END IF IF(MYID.EQ.0) THEN top_graph%IRN_LOC(1:TOP_CNT) = TSENDI(1:TOP_CNT) top_graph%JCN_LOC(1:TOP_CNT) = TSENDJ(1:TOP_CNT) DO PROC=2, NPROCS DO WHILE (RCVCNT(PROC) .GT. 0) I = int(min(int(BUFSIZE,8), RCVCNT(PROC))) CALL MPI_RECV(top_graph%IRN_LOC(TOP_CNT+1), I, & MPI_INTEGER, PROC-1, ITAG, ord%COMM, STATUS, IERR) CALL MPI_RECV(top_graph%JCN_LOC(TOP_CNT+1), I, & MPI_INTEGER, PROC-1, ITAG, ord%COMM, STATUS, IERR) RCVCNT(PROC) = RCVCNT(PROC)-I TOP_CNT = TOP_CNT+I END DO END DO ELSE DO WHILE (TOP_CNT .GT. 0) I = int(MIN(int(BUFSIZE,8), TOP_CNT)) CALL MPI_SEND(TSENDI(TOP_CNT-I+1), I, & MPI_INTEGER, 0, ITAG, ord%COMM, IERR) CALL MPI_SEND(TSENDJ(TOP_CNT-I+1), I, & MPI_INTEGER, 0, ITAG, ord%COMM, IERR) TOP_CNT = TOP_CNT-I END DO END IF CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, TSENDI, & TSENDJ, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) 90 continue RETURN END SUBROUTINE ZMUMPS_BUILD_LOC_GRAPH SUBROUTINE ZMUMPS_LUMAT_TO_LOC_GRAPH & (LUMAT, id, ord, GSIZE, IPE, PE, LENG, & I_HALO_MAP, WORK, LWORK) IMPLICIT NONE TYPE(LMATRIX_T), INTENT(IN) :: LUMAT TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: PE(:), LENG(:), & I_HALO_MAP(:), WORK(:) INTEGER(8), INTENT(IN) :: LWORK INTEGER :: GSIZE INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER :: ROWSIZE, IORIG, JORIG, PROCJ INTEGER(8) :: INNZ, NEW_LOCNNZ, RCVPNT INTEGER :: IIDX,JJDX INTEGER :: HALO_SIZE, NROWS_LOC INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: MAPTAB(:) INTEGER, POINTER :: HALO_MAP(:), BUFLEVEL(:) INTEGER, POINTER :: RDISPL(:), SIPES(:,:) INTEGER, POINTER :: RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER, PARAMETER :: ITAG=30 INTEGER(KIND=8) :: TLEN LOGICAL :: FLAG nullify(MAPTAB, SNDCNT, RCVCNT, HALO_MAP) nullify(RDISPL, MSGCNT, SIPES, BUFLEVEL) nullify( RCVBUF, APNT) MYID = ord%MYID NPROCS = ord%NPROCS IF ( LWORK .LT.2_8 * int(N,8) ) THEN WRITE(LP, & '("Insufficient workspace inside ZMUMPS_LUMAT_TO_LOC_GRAPH")') CALL MUMPS_ABORT() END IF MAPTAB => WORK( 1 : N ) HALO_MAP => WORK( int(N+1,8) : 2_8*int(N,8)) CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 BUFSIZE = 10000 BUFSIZE = id%KEEP(39) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 MAPTAB = 0 MAXS = 0 DO I=1, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) THEN MAXS = ord%LAST(I)-ord%FIRST(I)+1 END IF DO J=ord%FIRST(I), ord%LAST(I) MAPTAB(ord%PERITAB(J)) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SIPES = 0 DO J =1, LUMAT%NBCOL_LOC ROWSIZE = LUMAT%COL(J)%NBINCOL JORIG = J + LUMAT%FIRST -1 PROC = MAPTAB(JORIG) IF(PROC .EQ. 0) CYCLE JJDX = ord%PERMTAB(JORIG) LOC_ROW = JJDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+ROWSIZE SNDCNT(PROC) = SNDCNT(PROC)+ROWSIZE ENDDO CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, ord%COMM, IERR) I = ceiling(dble(MAXS)*1.20D0) CALL MUMPS_REALLOC(LENG, max(I,1), id%INFO, & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, ord%COMM, IERR ) DEALLOCATE(SIPES) I = ceiling(dble(NROWS_LOC+1)*1.20D0) CALL MUMPS_I8REALLOC(IPE, max(I,1), id%INFO, & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL ZMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ + RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO CALL MUMPS_IREALLOC8(PE, max(NEW_LOCNNZ+ & 2_8*int(NROWS_LOC+ord%TOPNODES(2),8),1_8), & id%INFO, LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RCVPNT = 1 BUFLEVEL = 0 INNZ = 1 DO I=1, LUMAT%NBCOL_LOC IF ( LUMAT%COL(I)%NBINCOL.EQ.0) CYCLE IORIG = I + LUMAT%FIRST -1 PROC = MAPTAB(IORIG) DO J=1, LUMAT%COL(I)%NBINCOL IF(mod(INNZ,int(BUFSIZE/10,8)) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, ord%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, ord%COMM, STATUS, IERR) CALL ZMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF INNZ = INNZ +1 JORIG = LUMAT%COL(I)%IRN(J) PROCJ = MAPTAB(JORIG) IF((PROCJ.NE.PROC) .AND. & (PROC.NE.0) .AND. & (PROCJ.NE.0)) THEN IERR = -50 id%INFO(1) = IERR END IF IF (PROC.NE.0) THEN IIDX = ord%PERMTAB(IORIG) JJDX = ord%PERMTAB(JORIG) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1)=IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -JORIG END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL ZMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF END IF ENDDO ENDDO CALL ZMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) HALO_MAP(:) = 0 HALO_SIZE = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(PE(INNZ) .LT. 0) THEN IF(HALO_MAP(-PE(INNZ)) .EQ. 0) THEN HALO_SIZE = HALO_SIZE+1 HALO_MAP(-PE(INNZ)) = NROWS_LOC+HALO_SIZE END IF PE(INNZ) = HALO_MAP(-PE(INNZ)) END IF END DO END DO CALL MUMPS_REALLOC(I_HALO_MAP, HALO_SIZE, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT J=0 DO I=1, N IF(HALO_MAP(I) .GT. 0) THEN J = J+1 I_HALO_MAP(HALO_MAP(I)-NROWS_LOC) = I END IF IF(J .EQ. HALO_SIZE) EXIT END DO CALL MUMPS_REALLOC(LENG, max(NROWS_LOC+HALO_SIZE,1), id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:leng', MEMCNT=MEMCNT, ERRCODE=-7) LENG(NROWS_LOC+1:NROWS_LOC+HALO_SIZE) = 0 CALL MUMPS_I8REALLOC(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IPE(NROWS_LOC+2:NROWS_LOC+HALO_SIZE+1) = IPE(NROWS_LOC+1) GSIZE = NROWS_LOC + HALO_SIZE CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) 90 continue RETURN END SUBROUTINE ZMUMPS_LUMAT_TO_LOC_GRAPH SUBROUTINE MUMPS_BUILD_TOP_GRAPH & (LUMAT, id, ord, top_graph, MAPTAB) IMPLICIT NONE TYPE(LMATRIX_T), INTENT(IN) :: LUMAT TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord TYPE(GRAPH_TYPE) :: top_graph INTEGER, POINTER :: MAPTAB(:) INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, PROCJ INTEGER :: ROWSIZE, IORIG, JORIG INTEGER(8) :: NEW_LOCNNZ, TOP_CNT, TIDX INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER(8), POINTER :: RCVCNT(:) INTEGER, POINTER :: TSENDI(:), TSENDJ(:) INTEGER :: BUFSIZE, allocok INTEGER, PARAMETER :: ITAG=30 nullify(RCVCNT,TSENDI,TSENDJ) MYID = ord%MYID NPROCS = ord%NPROCS MAPTAB = 0 DO I=1, NPROCS DO J=ord%FIRST(I), ord%LAST(I) MAPTAB(ord%PERITAB(J)) = I END DO END DO CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 TOP_CNT = 0 BUFSIZE = 10000 BUFSIZE = id%KEEP(39) TOP_CNT = 0 DO J =1, LUMAT%NBCOL_LOC JORIG = J + LUMAT%FIRST -1 PROC = MAPTAB(JORIG) IF(PROC .EQ. 0) THEN ROWSIZE = LUMAT%COL(J)%NBINCOL TOP_CNT = TOP_CNT+ROWSIZE ENDIF ENDDO CALL MUMPS_IREALLOC8(TSENDI, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(TSENDJ, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT TIDX = 0 DO I=1, LUMAT%NBCOL_LOC IF ( LUMAT%COL(I)%NBINCOL.EQ.0) CYCLE IORIG = I + LUMAT%FIRST -1 PROC = MAPTAB(IORIG) IF (PROC.NE.0) CYCLE DO J=1, LUMAT%COL(I)%NBINCOL JORIG = LUMAT%COL(I)%IRN(J) PROCJ = MAPTAB(JORIG) IF (PROCJ.EQ.0) THEN TIDX = TIDX+1 TSENDI(TIDX) = IORIG TSENDJ(TIDX) = JORIG ENDIF ENDDO ENDDO CALL MPI_GATHER(TIDX, 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, 0, ord%COMM, IERR) IF(MYID.EQ.0) THEN NEW_LOCNNZ = sum(RCVCNT) ELSE NEW_LOCNNZ = 0_8 ENDIF top_graph%NZ_LOC = NEW_LOCNNZ IF(MYID.EQ.0) THEN CALL MUMPS_IREALLOC8(top_graph%IRN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(top_graph%JCN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1), & stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=2 ENDIF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 IF(MYID.EQ.0) THEN top_graph%IRN_LOC(1:TIDX) = TSENDI(1:TIDX) top_graph%JCN_LOC(1:TIDX) = TSENDJ(1:TIDX) DO PROC=2, NPROCS DO WHILE (RCVCNT(PROC) .GT. 0) I = int(min(int(BUFSIZE,8), RCVCNT(PROC))) CALL MPI_RECV(top_graph%IRN_LOC(TIDX+1), I, & MPI_INTEGER, PROC-1, ITAG, ord%COMM, STATUS, IERR) CALL MPI_RECV(top_graph%JCN_LOC(TIDX+1), I, & MPI_INTEGER, PROC-1, ITAG, ord%COMM, STATUS, IERR) RCVCNT(PROC) = RCVCNT(PROC)-I TIDX = TIDX+I END DO END DO ELSE DO WHILE (TIDX .GT. 0) I = int(MIN(int(BUFSIZE,8), TIDX)) CALL MPI_SEND(TSENDI(TIDX-I+1), I, & MPI_INTEGER, 0, ITAG, ord%COMM, IERR) CALL MPI_SEND(TSENDJ(TIDX-I+1), I, & MPI_INTEGER, 0, ITAG, ord%COMM, IERR) TIDX = TIDX-I END DO END IF CALL MUMPS_DEALLOC( TSENDI, TSENDJ, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(RCVCNT, MEMCNT=MEMCNT) 90 continue RETURN END SUBROUTINE MUMPS_BUILD_TOP_GRAPH SUBROUTINE ZMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, COMM) IMPLICIT NONE INTEGER :: NPROCS, PROC, COMM, allocok TYPE(ARRPNT) :: APNT(:) INTEGER :: BUFSIZE INTEGER, POINTER :: RCVBUF(:), LENG(:), PE(:) INTEGER :: SNDCNT(:) INTEGER(8) :: MSGCNT(:), IPE(:) LOGICAL, SAVE :: INIT = .TRUE. INTEGER, POINTER, SAVE :: SPACE(:,:,:) LOGICAL, POINTER, SAVE :: PENDING(:) INTEGER, POINTER, SAVE :: REQ(:), CPNT(:) INTEGER :: IERR, MYID, I, SOURCE INTEGER(8) :: TOTMSG LOGICAL :: FLAG, TFLAG INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: TSTATUS(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30, FTAG=31 INTEGER, POINTER :: TMPI(:), RCVCNT(:) CALL MPI_COMM_RANK (COMM, MYID, IERR) CALL MPI_COMM_SIZE (COMM, NPROCS, IERR) IF(INIT) THEN ALLOCATE(SPACE(2*BUFSIZE, 2, NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of SPACE in ZMUMPS_SEND_BUF" return ENDIF ALLOCATE(RCVBUF(2*BUFSIZE), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of RCVBUF in ZMUMPS_SEND_BUF" return ENDIF ALLOCATE(PENDING(NPROCS), CPNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of PENDING/CPNT" & ," in ZMUMPS_SEND_BUF" return ENDIF ALLOCATE(REQ(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of REQ in ZMUMPS_SEND_BUF" return ENDIF PENDING = .FALSE. DO I=1, NPROCS APNT(I)%BUF => SPACE(:,1,I) CPNT(I) = 1 END DO INIT = .FALSE. RETURN END IF IF(PROC .EQ. -1) THEN TOTMSG = sum(MSGCNT) DO IF(TOTMSG .EQ. 0) EXIT CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, ITAG, COMM, STATUS, IERR) CALL ZMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) SOURCE = STATUS(MPI_SOURCE) TOTMSG = TOTMSG-1 MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 END DO DO I=1, NPROCS IF(PENDING(I)) THEN CALL MPI_WAIT(REQ(I), TSTATUS, IERR) END IF END DO ALLOCATE(RCVCNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of RCVCNT in ZMUMPS_SEND_BUF" return ENDIF CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, COMM, IERR) DO I=1, NPROCS IF(SNDCNT(I) .GT. 0) THEN TMPI => APNT(I)%BUF(:) CALL MPI_ISEND(TMPI(1), 2*SNDCNT(I), MPI_INTEGER, I-1, & FTAG, COMM, REQ(I), IERR) END IF END DO DO I=1, NPROCS IF(RCVCNT(I) .GT. 0) THEN CALL MPI_RECV(RCVBUF(1), 2*RCVCNT(I), MPI_INTEGER, I-1, & FTAG, COMM, STATUS, IERR) CALL ZMUMPS_ASSEMBLE_MSG(RCVCNT(I), RCVBUF, & IPE, PE, LENG) END IF END DO DO I=1, NPROCS IF(SNDCNT(I) .GT. 0) THEN CALL MPI_WAIT(REQ(I), TSTATUS, IERR) END IF END DO DEALLOCATE(SPACE) DEALLOCATE(PENDING, CPNT) DEALLOCATE(REQ) DEALLOCATE(RCVBUF, RCVCNT) nullify(SPACE, PENDING, CPNT, REQ, RCVBUF, RCVCNT) INIT = .TRUE. RETURN END IF IF(PENDING(PROC)) THEN DO CALL MPI_TEST(REQ(PROC), TFLAG, TSTATUS, IERR) IF(TFLAG) THEN PENDING(PROC) = .FALSE. EXIT ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, & SOURCE, ITAG, COMM, STATUS, IERR) CALL ZMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, & PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 END IF END IF END DO END IF TMPI => APNT(PROC)%BUF(:) CALL MPI_ISEND(TMPI(1), 2*BUFSIZE, MPI_INTEGER, PROC-1, & ITAG, COMM, REQ(PROC), IERR) PENDING(PROC) = .TRUE. CPNT(PROC) = mod(CPNT(PROC),2)+1 APNT(PROC)%BUF => SPACE(:,CPNT(PROC),PROC) SNDCNT(PROC) = 0 RETURN END SUBROUTINE ZMUMPS_SEND_BUF SUBROUTINE ZMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) IMPLICIT NONE INTEGER :: BUFSIZE INTEGER :: RCVBUF(:), PE(:), LENG(:) INTEGER(8) :: IPE(:) INTEGER :: I, ROW, COL DO I=1, 2*BUFSIZE, 2 ROW = RCVBUF(I) COL = RCVBUF(I+1) PE(IPE(ROW)+LENG(ROW)) = COL LENG(ROW) = LENG(ROW) + 1 END DO RETURN END SUBROUTINE ZMUMPS_ASSEMBLE_MSG #if defined(ptscotch) || defined(parmetis) || defined(parmetis3) SUBROUTINE ZMUMPS_BUILD_TREE(ord) TYPE(ORD_TYPE) :: ord INTEGER :: I ord%SON = -1 ord%BROTHER = -1 ord%NW = 0 DO I=1, ord%CBLKNBR ord%NW(I) = ord%NW(I)+ord%RANGTAB(I+1) - ord%RANGTAB(I) IF (ord%TREETAB(I) .NE. -1) THEN IF (ord%SON(ord%TREETAB(I)) .EQ. -1) THEN ord%SON(ord%TREETAB(I)) = I ELSE ord%BROTHER(I) = ord%SON(ord%TREETAB(I)) ord%SON(ord%TREETAB(I)) = I END IF ord%NW(ord%TREETAB(I)) = ord%NW(ord%TREETAB(I))+ ord%NW(I) END IF END DO RETURN END SUBROUTINE ZMUMPS_BUILD_TREE SUBROUTINE ZMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK, LWORK, TYPE) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: FIRST(:), LAST(:), BASE, NPROCS, TYPE INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK INTEGER, POINTER :: TMP(:), NZ_ROW(:) INTEGER :: I, IERR, P, F, J INTEGER(8) :: LOCNNZ, INNZ, LOCOFFDIAG, & OFFDIAG, T, SHARE DO I=0, BASE-1 FIRST(I+1) = 0 LAST(I+1) = -1 END DO IF(TYPE.EQ.1) THEN SHARE = int(N/ord%NPROCS_PARAORD,8) DO I=1, ord%NPROCS_PARAORD FIRST(BASE+I) = (I-1)*int(SHARE)+1 LAST (BASE+I) = (I)*int(SHARE) END DO LAST(BASE+ord%NPROCS_PARAORD) = & MAX(LAST(BASE+ord%NPROCS_PARAORD), N) DO I = ord%NPROCS_PARAORD+1, id%NSLAVES+1 FIRST(BASE+I) = N+1 LAST (BASE+I) = N END DO ELSE IF (TYPE.EQ.2) THEN IF (LWORK .LT. 2_8*int(N,8)) THEN WRITE(*,*) "Insufficient workspace in ZMUMPS_GRAPH_DIST" CALL MUMPS_ABORT() ENDIF TMP => WORK(1:N) NZ_ROW => WORK(int(N+1,8):2-8*int(N,8)) TMP = 0 LOCOFFDIAG = 0_8 LOCNNZ = id%KEEP8(29) DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN TMP(id%IRN_loc(INNZ)) = TMP(id%IRN_loc(INNZ))+1 LOCOFFDIAG = LOCOFFDIAG+1 IF(id%SYM.GT.0) THEN TMP(id%JCN_loc(INNZ)) = TMP(id%JCN_loc(INNZ))+1 LOCOFFDIAG = LOCOFFDIAG+1 END IF END IF END DO CALL MUMPS_BIGALLREDUCE(.FALSE., TMP(1), NZ_ROW(1), N, & MPI_INTEGER, MPI_SUM, ord%COMM, IERR) CALL MPI_ALLREDUCE(LOCOFFDIAG, OFFDIAG, 1, & MPI_INTEGER8, MPI_SUM, ord%COMM, IERR) nullify(TMP) SHARE = (OFFDIAG-1_8)/int(ord%NPROCS_PARAORD,8) + 1_8 P = 0 T = 0_8 F = 1 DO I=1, N T = T+int(NZ_ROW(I),8) IF ( & (T .GE. SHARE) .OR. & ((N-I).EQ.(ord%NPROCS_PARAORD-P-1)) .OR. & (I.EQ.N) & ) THEN P = P+1 IF(P.EQ.ord%NPROCS_PARAORD) THEN FIRST(BASE+P) = F LAST(BASE+P) = N EXIT ELSE FIRST(BASE+P) = F LAST(BASE+P) = I F = I+1 T = 0_8 END IF END IF END DO DO J=P+1, NPROCS+1-BASE FIRST(BASE+J) = N+1 LAST(BASE+J) = N END DO END IF RETURN END SUBROUTINE ZMUMPS_GRAPH_DIST #endif FUNCTION MUMPS_GETSIZE(A) INTEGER, POINTER :: A(:) INTEGER :: MUMPS_GETSIZE IF(associated(A)) THEN MUMPS_GETSIZE = size(A) ELSE MUMPS_GETSIZE = 0_8 END IF RETURN END FUNCTION MUMPS_GETSIZE #if defined(parmetis) || defined(parmetis3) SUBROUTINE MUMPS_PARMETIS_MIXEDto32(id, & BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & VELOLOCTAB, SIZE_VELOLOCTAB, & SIZES, COMM, MYID, IERR) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:) INTEGER :: SIZES(:), ORDER(:) INTEGER(8) :: VERTLOCTAB(:) INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, MYID, & BASE INTEGER :: VELOLOCTAB(:) INTEGER :: SIZE_VELOLOCTAB INTEGER, POINTER :: VERTLOCTAB_I4(:) IF( VERTLOCTAB(VERTLOCNBR+1).GT.huge(VERTLOCNBR)) THEN id%INFO(1) = -51 CALL MUMPS_SET_IERROR( & VERTLOCTAB(VERTLOCNBR+1), id%INFO(2)) RETURN END IF nullify(VERTLOCTAB_I4) CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1), & VERTLOCNBR+1, VERTLOCTAB_I4(1)) IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_PARMETIS_VWGT(FIRST(1+BASE), VERTLOCTAB_I4(1), & EDGELOCTAB(1), BASEVAL, OPTIONS(1), ORDER(1), & SIZES(1), COMM, VELOLOCTAB(1), IERR) ELSE CALL MUMPS_PARMETIS(FIRST(1+BASE), VERTLOCTAB_I4(1), & EDGELOCTAB(1), BASEVAL, OPTIONS(1), ORDER(1), & SIZES(1), COMM, IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT) RETURN END SUBROUTINE MUMPS_PARMETIS_MIXEDto32 SUBROUTINE MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & VELOLOCTAB, SIZE_VELOLOCTAB, & SIZES, COMM, MYID, IERR) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:) INTEGER :: SIZES(:), ORDER(:) INTEGER(8) :: VERTLOCTAB(:) INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, MYID, & BASE INTEGER :: VELOLOCTAB(:) INTEGER :: SIZE_VELOLOCTAB INTEGER(8), POINTER :: FIRST_I8(:), EDGELOCTAB_I8(:), & SIZES_I8(:), ORDER_I8(:), VELOLOCTAB_I8(:) INTEGER(8) :: VERTLOCNBR_I8 #if defined(parmetis) INTEGER(8), POINTER :: OPTIONS_I8(:) INTEGER(8) :: BASEVAL_I8 nullify(OPTIONS_I8) IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8REALLOC(OPTIONS_I8, size(OPTIONS), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64(OPTIONS(1), size(OPTIONS) & , OPTIONS_I8(1)) BASEVAL_I8 = int(BASEVAL,8) END IF #endif nullify(FIRST_I8, EDGELOCTAB_I8, SIZES_I8, ORDER_I8, & VELOLOCTAB_I8) IF (id%KEEP(10).EQ.1) THEN IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_PARMETIS_VWGT_64(FIRST(1+BASE), VERTLOCTAB(1), & EDGELOCTAB(1), & BASEVAL, OPTIONS(1), & ORDER(1), & SIZES(1), COMM, VELOLOCTAB(1), IERR) ELSE CALL MUMPS_PARMETIS_64(FIRST(1+BASE), VERTLOCTAB(1), & EDGELOCTAB(1), & BASEVAL, OPTIONS(1), & ORDER(1), & SIZES(1), COMM, IERR) ENDIF ELSE CALL MUMPS_I8REALLOC(FIRST_I8, size(FIRST), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_I8REALLOC(VELOLOCTAB_I8, VERTLOCNBR, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 ENDIF CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8, & VERTLOCTAB(VERTLOCNBR+1)-1_8, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(SIZES_I8, size(SIZES), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(ORDER_I8, size(ORDER), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 5 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64(FIRST(1), size(FIRST), FIRST_I8(1)) CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1), & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1)) IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN VERTLOCNBR_I8 = int(VERTLOCNBR,8) CALL MUMPS_ICOPY_32TO64_64C(VELOLOCTAB(1), & VERTLOCNBR_I8, VELOLOCTAB_I8(1)) ENDIF IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_PARMETIS_VWGT_64(FIRST_I8(1+BASE), VERTLOCTAB(1), & EDGELOCTAB_I8(1), #if defined(parmetis3) & BASEVAL, OPTIONS(1), #else & BASEVAL_I8, OPTIONS_I8(1), #endif & ORDER_I8(1), & SIZES_I8(1), COMM, VELOLOCTAB_I8(1), & IERR) ELSE CALL MUMPS_PARMETIS_64(FIRST_I8(1+BASE), VERTLOCTAB(1), & EDGELOCTAB_I8(1), #if defined(parmetis3) & BASEVAL, OPTIONS(1), #else & BASEVAL_I8, OPTIONS_I8(1), #endif & ORDER_I8(1), & SIZES_I8(1), COMM, IERR) ENDIF END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF ( id%KEEP(10) .NE. 1 ) THEN CALL MUMPS_ICOPY_64TO32(ORDER_I8(1), & size(ORDER), ORDER(1)) CALL MUMPS_ICOPY_64TO32(SIZES_I8(1), & size(SIZES), SIZES(1)) ENDIF 10 CONTINUE CALL MUMPS_I8DEALLOC(FIRST_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(SIZES_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(ORDER_I8, MEMCNT=MEMCNT) IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) & CALL MUMPS_I8DEALLOC(VELOLOCTAB_I8, MEMCNT=MEMCNT) #if defined(parmetis) CALL MUMPS_I8DEALLOC(OPTIONS_I8, MEMCNT=MEMCNT) #endif RETURN END SUBROUTINE MUMPS_PARMETIS_MIXEDto64 #endif #if defined(ptscotch) SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & VELOLOCTAB, SIZE_VELOLOCTAB, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, LCONTDAT, #endif & IERR) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: BASEVAL, VERTLOCNBR INTEGER(8) :: EDGELOCNBR INTEGER(8) :: VERTLOCTAB(:) INTEGER :: EDGELOCTAB(:) INTEGER :: VELOLOCTAB(:) INTEGER, INTENT(IN) :: SIZE_VELOLOCTAB INTEGER :: IERR INTEGER, POINTER :: VERTLOCTAB_I4(:) INTEGER :: EDGELOCNBR_I4, MYWORKID DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) INTEGER :: LCONTDAT DOUBLE PRECISION :: CONTDAT(LCONTDAT) DOUBLE PRECISION :: GRAPHDAT_BEFORE_CONTEXT(SCOTCH_DGRAPHDIM) #endif IF (.NOT.ord%IDO) RETURN nullify(VERTLOCTAB_I4) CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1), & VERTLOCNBR+1, VERTLOCTAB_I4(1)) EDGELOCNBR_I4 = int(EDGELOCNBR) IF(ord%SUBSTRAT .NE. 0) THEN STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// & 'proc=1,seq=q{strat=m{type=h,vert=100,'// & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' END IF IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, MYWORKID, IERR) ELSE MYWORKID = -1 END IF #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL MUMPS_DGRAPHINIT(GRAPHDAT_BEFORE_CONTEXT, ord%COMM_PARAORD, & IERR) CALL SCOTCHFCONTEXTBINDDGRAPH(CONTDAT, GRAPHDAT_BEFORE_CONTEXT, & GRAPHDAT, IERR) #else CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_PARAORD, IERR) #endif IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB_I4(1), VERTLOCTAB_I4(2), & VELOLOCTAB(1), VERTLOCTAB_I4(1), EDGELOCNBR_I4, & EDGELOCNBR_I4, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ELSE CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB_I4(1), VERTLOCTAB_I4(2), & VERTLOCTAB_I4(1), VERTLOCTAB_I4(1), EDGELOCNBR_I4, & EDGELOCNBR_I4, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(ord%SUBSTRAT .NE. 0) THEN CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR, & ord%RANGTAB(1), ord%TREETAB(1), IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT_BEFORE_CONTEXT) #endif 10 CONTINUE CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT) RETURN END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32 SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & VELOLOCTAB, SIZE_VELOLOCTAB, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, LCONTDAT, #endif & IERR) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: BASEVAL, VERTLOCNBR INTEGER(8) :: EDGELOCNBR INTEGER(8) :: VERTLOCTAB(:) INTEGER :: EDGELOCTAB(:) INTEGER :: VELOLOCTAB(:) INTEGER, INTENT(IN) :: SIZE_VELOLOCTAB INTEGER :: IERR INTEGER :: MYWORKID DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) INTEGER :: LCONTDAT DOUBLE PRECISION :: CONTDAT(LCONTDAT) DOUBLE PRECISION :: GRAPHDAT_BEFORE_CONTEXT(SCOTCH_DGRAPHDIM) #endif INTEGER(8), POINTER :: EDGELOCTAB_I8(:), PERMTAB_I8(:), & PERITAB_I8(:), RANGTAB_I8(:), TREETAB_I8(:), VELOLOCTAB_I8(:) INTEGER(8) :: CBLKNBR_I8, VERTLOCNBR_I8, BASEVAL_I8 IF(ord%SUBSTRAT .NE. 0) THEN STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// & 'proc=1,seq=q{strat=m{type=h,vert=100,'// & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' END IF IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, MYWORKID, IERR) ELSE MYWORKID = -1 END IF nullify(EDGELOCTAB_I8, PERMTAB_I8, PERITAB_I8, & RANGTAB_I8, TREETAB_I8, VELOLOCTAB_I8) IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8, & VERTLOCTAB(VERTLOCNBR+1)-1_8, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_I8REALLOC(VELOLOCTAB_I8, VERTLOCNBR, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 ENDIF IF (MYWORKID .EQ. 0) THEN CALL MUMPS_I8REALLOC(PERMTAB_I8, size(ord%PERMTAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(PERITAB_I8, size(ord%PERITAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(TREETAB_I8, size(ord%TREETAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(RANGTAB_I8, size(ord%RANGTAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) END IF 5 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1), & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1)) VERTLOCNBR_I8 = int(VERTLOCNBR,8) IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_ICOPY_32TO64_64C(VELOLOCTAB(1), & VERTLOCNBR_I8, VELOLOCTAB_I8(1)) ENDIF BASEVAL_I8 = int(BASEVAL,8) ENDIF #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL MUMPS_DGRAPHINIT(GRAPHDAT_BEFORE_CONTEXT, ord%COMM_PARAORD, & IERR) CALL SCOTCHFCONTEXTBINDDGRAPH(CONTDAT, GRAPHDAT_BEFORE_CONTEXT, & GRAPHDAT, IERR) #else CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_PARAORD, IERR) #endif IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL_I8, VERTLOCNBR_I8, & VERTLOCNBR_I8, VERTLOCTAB(1), VERTLOCTAB(2), & VELOLOCTAB_I8(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB_I8(1), EDGELOCTAB_I8(1), & EDGELOCTAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), & VELOLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ENDIF ELSE IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL_I8, VERTLOCNBR_I8, & VERTLOCNBR_I8, VERTLOCTAB(1), VERTLOCTAB(2), & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB_I8(1), EDGELOCTAB_I8(1), & EDGELOCTAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ENDIF ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(ord%SUBSTRAT .NE. 0) THEN CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & PERMTAB_I8(1), PERITAB_I8(1), CBLKNBR_I8, RANGTAB_I8(1), & TREETAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR, & ord%RANGTAB(1),ord%TREETAB(1), IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT_BEFORE_CONTEXT) #endif 10 CONTINUE IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT) IF (SIZE_VELOLOCTAB.GT.0) & CALL MUMPS_I8DEALLOC(VELOLOCTAB_I8, MEMCNT=MEMCNT) IF(MYWORKID .EQ. 0) THEN CALL MUMPS_ICOPY_64TO32(PERMTAB_I8(1), & size(ord%PERMTAB), ord%PERMTAB(1)) CALL MUMPS_ICOPY_64TO32(PERITAB_I8(1), & size(ord%PERITAB), ord%PERITAB(1)) CALL MUMPS_ICOPY_64TO32(TREETAB_I8(1), & size(ord%TREETAB), ord%TREETAB(1)) CALL MUMPS_ICOPY_64TO32(RANGTAB_I8(1), & size(ord%RANGTAB), ord%RANGTAB(1)) ord%CBLKNBR = int(CBLKNBR_I8) CALL MUMPS_I8DEALLOC(PERMTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(PERITAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(RANGTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(TREETAB_I8, MEMCNT=MEMCNT) END IF ENDIF RETURN END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64 #endif END MODULE MUMPS_5.8.1/src/dfac_b.F0000664000175000017500000006161015042446440014541 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_FAC_B( N, S_IS_POINTERS, LA, LIW, SYM_PERM, & NA, LNA, NE_STEPS, NFSIZ, FILS, STEP, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PTRAR, LDPTRAR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, PTRIST, & PTLUST_S, PTRFAC, IW1, IW2, ITLOC, RHS_MUMPS, POOL, LPOOL, & CNTL1, ICNTL, INFO, RINFO, KEEP, KEEP8, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & DMUMPS_LBUF, INTARR, DBLARR, root, roota, NELT, FRTPTR, FRTELT, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, & DKEEP, PIVNUL_LIST_STRUCT, LRGROUPS & ,IPOOL_B_L0_OMP, LPOOL_B_L0_OMP, IPOOL_A_L0_OMP, & LPOOL_A_L0_OMP, L_VIRT_L0_OMP, VIRT_L0_OMP, & VIRT_L0_OMP_MAPPING, L_PHYS_L0_OMP, PHYS_L0_OMP, PERM_L0_OMP, & PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, THREAD_LA, & L0_OMP_FACTORS, LL0_OMP_FACTORS, I4_L0_OMP, NBSTATS_I4, & NBCOLS_I4, I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) USE MUMPS_LOAD USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_ALLOC_CB, & MUMPS_BUF_DEALL_CB USE DMUMPS_BUF, ONLY : DMUMPS_BUF_MAX_ARRAY_MINSIZE & , DMUMPS_BUF_DEALL_MAX_ARRAY USE DMUMPS_FAC_S_IS_POINTERS_M, ONLY : DMUMPS_S_IS_POINTERS_T USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T USE OMP_LIB USE MUMPS_TPS_M USE DMUMPS_TPS_M USE DMUMPS_FAC_OMP_M USE DMUMPS_DYNAMIC_MEMORY_M, ONLY: DMUMPS_DM_ALLOC_S_WK, & DMUMPS_DM_FREE_S_WK USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC & , DMUMPS_L0OMPFAC_T IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER(8) :: LA INTEGER N,LIW,LPOOL,SLAVEF,COMM_NODES INTEGER MYID, MYID_NODES,LNA TYPE (DMUMPS_S_IS_POINTERS_T) :: S_IS_POINTERS DOUBLE PRECISION RINFO(40) INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES INTEGER :: BUFR( LBUFR ) INTEGER, INTENT( IN ) :: DMUMPS_LBUF INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER NELT, LDPTRAR INTEGER FRTPTR(*), FRTELT(*) DOUBLE PRECISION CNTL1 INTEGER ICNTL(60) INTEGER INFO(80), KEEP(500) INTEGER(8) KEEP8(150) INTEGER LRGROUPS(KEEP(280)) INTEGER SYM_PERM(N), NA(LNA), & NE_STEPS(KEEP(28)), FILS(N), & FRERE(KEEP(28)), NFSIZ(KEEP(28)), & DAD(KEEP(28)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER STEP(N) INTEGER(8), INTENT(IN) :: PTRAR(LDPTRAR,2) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IW1(2*KEEP(28)), ITLOC(N+KEEP(253)), POOL(LPOOL) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: IW2(2*KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER COMM_LOAD, ASS_IRECV INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) DOUBLE PRECISION SEUIL, SEUIL_LDLT_NIV2 TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER, INTENT (IN) :: LPOOL_B_L0_OMP INTEGER, INTENT (IN) :: IPOOL_B_L0_OMP( LPOOL_B_L0_OMP ) INTEGER, INTENT (IN) :: LPOOL_A_L0_OMP INTEGER, INTENT (IN) :: IPOOL_A_L0_OMP( LPOOL_A_L0_OMP ) INTEGER, INTENT (IN) :: L_PHYS_L0_OMP INTEGER, INTENT (IN) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT (IN) :: L_VIRT_L0_OMP INTEGER, INTENT (IN) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT (IN) :: VIRT_L0_OMP_MAPPING( L_VIRT_L0_OMP ) INTEGER, INTENT (IN) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT (IN) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT (IN) :: LL0_OMP_MAPPING INTEGER, INTENT (OUT):: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INTEGER, INTENT (IN) :: LL0_OMP_FACTORS TYPE(DMUMPS_L0OMPFAC_T), INTENT (INOUT) :: L0_OMP_FACTORS( & LL0_OMP_FACTORS ) INTEGER, INTENT (IN) :: NBSTATS_I4, NBSTATS_I8 INTEGER, INTENT (IN) :: NBCOLS_I4, NBCOLS_I8 INTEGER, INTENT (IN) :: I4_L0_OMP(NBSTATS_I4, NBCOLS_I4) INTEGER(8), INTENT (IN) :: I8_L0_OMP(NBSTATS_I8, NBCOLS_I8) INTEGER(8), INTENT ( IN ) :: THREAD_LA INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER allocok DOUBLE PRECISION UULOC INTEGER IERR INTEGER LP, MPRINT LOGICAL LPOK INTEGER NSTK,PTRAST INTEGER PIMASTER, PAMASTER LOGICAL PROK DOUBLE PRECISION,PARAMETER :: ZERO = 0.0D0 INTEGER I INTEGER LTPS_ARR TYPE (MUMPS_TPS_T), DIMENSION(:), ALLOCATABLE :: MUMPS_TPS_ARR TYPE (DMUMPS_TPS_T), DIMENSION(:), ALLOCATABLE :: DMUMPS_TPS_ARR INTEGER NBROOT_UNDER_L0 INTEGER :: NSTEPSDONE DOUBLE PRECISION :: OPASS, OPELI INTEGER :: NELVA, COMP INTEGER :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV, NULLNEGPV INTEGER :: NB22T1, NB22T2, NBTINY, DET_EXP, DET_SIGN DOUBLE PRECISION :: DET_MANT INTEGER :: NTOTPVTOT INTEGER(8) :: POSFAC, LRLU, IPTRLU, LRLUS INTEGER IWPOS, LEAF, NBROOT, NROOT INTEGER :: LIW_ARG_FAC_PAR INTEGER(8) :: LA_ARG_FAC_PAR DOUBLE PRECISION, TARGET:: CDUMMY(1) INTEGER, TARGET :: IDUMMY(1) LOGICAL :: IW_DUMMY, A_DUMMY, & IW_ALLOCATED_HERE, A_ALLOCATED_HERE KEEP(41)=0 KEEP(42)=0 LP = ICNTL(1) LPOK = (LP.GT.0) .AND. (ICNTL(4).GE.1) MPRINT = ICNTL(2) PROK = (MPRINT.GT.0) .AND. (ICNTL(4).GE.2) UULOC = CNTL1 PIMASTER = 1 NSTK = PIMASTER + KEEP(28) PTRAST = 1 PAMASTER = 1 + KEEP(28) IF (KEEP(4).LE.0) KEEP(4)=32 IF (KEEP(5).LE.0) KEEP(5)=16 IF (KEEP(5).GT.KEEP(4)) KEEP(5) = KEEP(4) IF (KEEP(6).LE.0) KEEP(6)=24 IF (KEEP(3).LE.KEEP(4)) KEEP(3)=KEEP(4)*2 IF (KEEP(6).GT.KEEP(3)) KEEP(6) = KEEP(3) POSFAC = 1_8 IWPOS = 1 LRLU = LA LRLUS = LRLU KEEP8(62) = 0_8 KEEP8(63) = 0_8 KEEP8(64) = 0_8 KEEP8(65) = 0_8 KEEP8(66) = 0_8 KEEP8(68) = 0_8 KEEP8(69) = 0_8 KEEP8(70) = 0_8 KEEP8(71) = 0_8 KEEP8(73) = 0_8 KEEP8(74) = 0_8 IPTRLU = LRLU DKEEP(19)=huge(0.0D0) DKEEP(20)=huge(0.0D0) DKEEP(21)=0.0D0 NSTEPSDONE = 0 OPASS = 0.0D0 OPELI = 0.0D0 NELVA = 0 COMP = 0 MAXFRT = 0 NMAXNPIV = 0 NTOTPV = 0 NOFFNEGPV = 0 NULLNEGPV = 0 NB22T1 = 0 NB22T2 = 0 NBTINY = 0 DET_EXP = 0 DET_SIGN = 1 DET_MANT = 1.0D0 IW1(NSTK:NSTK+KEEP(28)-1) = NE_STEPS(1:KEEP(28)) CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, NROOT, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP, STEP, & PROCNODE_STEPS) IF (KEEP(400) .GT. 0 & ) THEN IF (LPOOL .NE. LPOOL_A_L0_OMP) THEN WRITE(*,*) "Check LPOOL vs. LPOOL_A_L0_OMP", & LPOOL, LPOOL_A_L0_OMP, KEEP(28) CALL MUMPS_ABORT() ENDIF DO I = 1, LPOOL POOL(I) = IPOOL_A_L0_OMP(I) ENDDO ELSE CALL MUMPS_INIT_POOL_DIST(N, LEAF, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, & POOL, LPOOL) CALL DMUMPS_INIT_POOL_LAST3(POOL, LPOOL, LEAF) ENDIF CALL MUMPS_LOAD_INIT_SBTR_STRUCT(POOL, LPOOL,KEEP,KEEP8) IF ( KEEP( 38 ) .NE. 0 ) THEN NBROOT = NBROOT + root%NPROW * root%NPCOL - 1 END IF IF ( root%yes ) THEN IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(KEEP(38))), & KEEP(199) ) & .NE. MYID_NODES ) THEN NROOT = NROOT + 1 END IF END IF PTRIST(1:KEEP(28))=0 PTLUST_S(1:KEEP(28))=0 PTRFAC(1:KEEP(28))=-99999_8 IW2(PTRAST:PTRAST+KEEP(28)-1)=0_8 IW1(PIMASTER:PIMASTER+KEEP(28)-1)=-99999_8 KEEP(405) = 0 NBROOT_UNDER_L0 = 0 IF (KEEP(400).GT.0 & ) THEN KEEP(405)=1 ALLOCATE( MUMPS_TPS_ARR( KEEP(400) ), stat=allocok ) IF (allocok .GT. 0) THEN IF (LPOK) THEN WRITE(LP,*) "Problem allocating MUMPS_TPS_ARR", & KEEP(400) ENDIF CALL MUMPS_ABORT() ENDIF ALLOCATE( DMUMPS_TPS_ARR( KEEP(400) ), stat=allocok ) IF (allocok .GT. 0) THEN WRITE(*,*) "Problem allocating DMUMPS_TPS_ARR", KEEP(400) CALL MUMPS_ABORT() ENDIF CALL DMUMPS_FAC_L0_OMP(N,LIW, IW1(NSTK), NFSIZ, FILS,STEP,FRERE, & DAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, PTRIST, IW2(PTRAST), & IW1(PIMASTER), IW2(PAMASTER), PTRAR(1,2), PTRAR(1,1), & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, RINFO, NROOT, NBROOT, NBROOT_UNDER_L0, & UULOC, ICNTL, PTLUST_S, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS,SLAVEF, COMM_NODES, MYID, MYID_NODES, BUFR, & LBUFR,LBUFR_BYTES,INTARR,DBLARR,root,roota,SYM_PERM,NELT,FRTPTR, & FRTELT, LDPTRAR, COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB, NE_STEPS, DKEEP, PIVNUL_LIST_STRUCT, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, L_VIRT_L0_OMP, & VIRT_L0_OMP, VIRT_L0_OMP_MAPPING, L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, & THREAD_LA, MUMPS_TPS_ARR, DMUMPS_TPS_ARR, NSTEPSDONE, & OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, NOFFNEGPV, & NULLNEGPV, NB22T1, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & LRGROUPS(1), L0_OMP_FACTORS, LL0_OMP_FACTORS, & I4_L0_OMP, NBSTATS_I4, NBCOLS_I4, & I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 ) KEEP(405)=0 DKEEP(16) = OPELI KEEP8(75)=KEEP8(76) KEEP8(63)=KEEP8(74) KEEP8(62) = KEEP8(74)-KEEP8(62) IF (INFO(1) .LT. 0) THEN KEEP8(69) = KEEP8(73) ENDIF KEEP8(74) = KEEP8(73) IF ((INFO(1).GE.0).AND.(KEEP8(74).GT.KEEP8(75))) THEN INFO(1) = -19 CALL MUMPS_SET_IERROR ( & KEEP8(74)-KEEP8(75), INFO(2)) IF (LPOK) THEN WRITE(LP,'(/A/,A,I8,A,I10/,A/,A/)') & '** ERROR: memory allowed (ICNTL(23)) is not large enough:', & ' INFO(1)=', INFO(1), ' INFO(2)=', INFO(2), & ' memory used at the end of the treatment of L0 thread ', & ' does not enable processing nodes above L0 thread ' ENDIF ENDIF KEEP8(66) = KEEP8(68) KEEP8(65) = KEEP8(64) + KEEP8(71) ENDIF KEEP8(67) = LRLUS IW_ALLOCATED_HERE = .FALSE. A_ALLOCATED_HERE = .FALSE. IF (associated(S_IS_POINTERS%IW)) THEN WRITE(*,*) " Internal error DMUMPS_FAC_B IW" CALL MUMPS_ABORT() ENDIF IF (INFO(1) .GE. 0 ) THEN ALLOCATE(S_IS_POINTERS%IW(LIW), stat=allocok) IF (allocok .GT.0) THEN INFO(1) = -13 INFO(2) = LIW IF (LPOK) THEN WRITE(LP,*) & 'Allocation error for id%IS(',LIW,') on worker', & MYID_NODES ENDIF ELSE IW_ALLOCATED_HERE = .TRUE. ENDIF ENDIF IF (INFO(1) .GE. 0) THEN IF (.NOT. associated(S_IS_POINTERS%A)) THEN CALL DMUMPS_DM_ALLOC_S_WK(S_IS_POINTERS%A, & LA, allocok, KEEP(430), KEEP(35) ) IF (allocok .GT. 0) THEN INFO(1) = -13 CALL MUMPS_SETI8TOI4(LA, INFO(2)) DEALLOCATE(S_IS_POINTERS%IW); NULLIFY(S_IS_POINTERS%IW) IW_ALLOCATED_HERE = .FALSE. KEEP8(23)=0_8 ELSE A_ALLOCATED_HERE = .TRUE. KEEP8(23)=LA ENDIF ENDIF ENDIF IF (INFO(1) .GE. 0) THEN CALL MUMPS_BUF_ALLOC_CB( DMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1)= -13 INFO(2)= (DMUMPS_LBUF+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) & 'Allocation error in DMUMPS_BUF_ALLOC_CB' & ,INFO(2), ' on worker', MYID_NODES ENDIF ELSE IF ((KEEP(50).EQ.2).AND.(KEEP(219).NE.0)) THEN CALL DMUMPS_BUF_MAX_ARRAY_MINSIZE(max(KEEP(108),1),IERR) IF (IERR .NE. 0) THEN INFO(1) = -13 INFO(2) = max(KEEP(108),1) END IF ENDIF ENDIF ENDIF IF ( KEEP(400) .EQ. 0 & ) THEN LTPS_ARR = 1 ALLOCATE( MUMPS_TPS_ARR(1)) ALLOCATE(DMUMPS_TPS_ARR(1)) ELSE LTPS_ARR = KEEP(400) ENDIF IW_DUMMY = .FALSE.; A_DUMMY = .FALSE.; IF (INFO(1) .GE. 0) THEN LIW_ARG_FAC_PAR = LIW LA_ARG_FAC_PAR = LA ELSE IF (IW_ALLOCATED_HERE) THEN DEALLOCATE(S_IS_POINTERS%IW) NULLIFY(S_IS_POINTERS%IW) IW_ALLOCATED_HERE = .FALSE. ENDIF IF (A_ALLOCATED_HERE) THEN CALL DMUMPS_DM_FREE_S_WK(S_IS_POINTERS%A, KEEP(430)) NULLIFY(S_IS_POINTERS%A) A_ALLOCATED_HERE = .FALSE. ENDIF LIW_ARG_FAC_PAR = 1 LA_ARG_FAC_PAR = 1_8 IF (.NOT. associated(S_IS_POINTERS%IW)) THEN S_IS_POINTERS%IW => IDUMMY IW_DUMMY = .TRUE. ENDIF IF (.NOT. associated(S_IS_POINTERS%A)) THEN S_IS_POINTERS%A => CDUMMY A_DUMMY = .TRUE. ENDIF ENDIF IF ( INFO(1) .LT. 0 ) THEN CALL DMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP ) ENDIF KEEP(398)=NSTEPSDONE CALL DMUMPS_FAC_PAR_I(N,S_IS_POINTERS%IW(1),LIW_ARG_FAC_PAR, & S_IS_POINTERS%A(1),LA_ARG_FAC_PAR,IW1(NSTK), NFSIZ,FILS,STEP, & FRERE,DAD,CAND,ISTEP_TO_INIV2, TAB_POS_IN_PERE, NSTEPSDONE, & OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, NOFFNEGPV, & NULLNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & PTRIST, IW2(PTRAST), IW1(PIMASTER), IW2(PAMASTER), & PTRAR(1,2), PTRAR(1,1), PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, POOL, LPOOL, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & MUMPS_TPS_ARR, DMUMPS_TPS_ARR, LTPS_ARR, & RINFO, POSFAC, IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NROOT, NBROOT, & NBROOT_UNDER_L0, & UULOC, ICNTL, PTLUST_S, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS,SLAVEF,MYID,COMM_NODES, MYID_NODES, BUFR, LBUFR, & LBUFR_BYTES, INTARR, DBLARR, root, roota, SYM_PERM, NELT, FRTPTR, & FRTELT, LDPTRAR, COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB,NE_STEPS, DKEEP(1),PIVNUL_LIST_STRUCT, & LRGROUPS(1) ) IF (IW_DUMMY) THEN NULLIFY( S_IS_POINTERS%IW ) ENDIF IF (A_DUMMY) THEN NULLIFY( S_IS_POINTERS%A ) ENDIF IF ((KEEP(50).EQ.2).AND.(KEEP(219).NE.0)) THEN CALL DMUMPS_BUF_DEALL_MAX_ARRAY() ENDIF CALL MUMPS_BUF_DEALL_CB( IERR ) RINFO(2) = dble(OPASS) RINFO(3) = dble(OPELI) INFO(13) = NELVA INFO(14) = COMP KEEP(33) = MAXFRT; INFO(11) = MAXFRT KEEP(246) = NMAXNPIV KEEP(89) = NTOTPV; INFO(23) = NTOTPV INFO(12) = NOFFNEGPV INFO(40) = NULLNEGPV KEEP(103) = NB22T1 KEEP(105) = NB22T2 KEEP(98) = NBTINY IF (KEEP(258) .NE. 0) THEN KEEP(260) = KEEP(260) * DET_SIGN KEEP(259) = KEEP(259) + DET_EXP CALL DMUMPS_UPDATEDETER( DET_MANT, DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(400) .GT. 0 & ) THEN IF (LL0_OMP_FACTORS.NE.KEEP(400)) THEN WRITE(*,*) "Internal error in DMUMPS_FAC_B, KEEP(400), L..=", & KEEP(400), LL0_OMP_FACTORS CALL MUMPS_ABORT() ENDIF IF ( INFO(1) .GE. 0 ) THEN CALL DMUMPS_L0OMP_COPY_IW(S_IS_POINTERS%IW, & LIW, IWPOS, MUMPS_TPS_ARR, KEEP, PTLUST_S, & ICNTL, INFO) ENDIF !$OMP PARALLEL DO DO I=1, KEEP(400) IF (INFO(1) .LT. 0) THEN IF ( associated( L0_OMP_FACTORS(I)%A ) ) THEN DEALLOCATE( L0_OMP_FACTORS(I)%A ) NULLIFY ( L0_OMP_FACTORS(I)%A ) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -L0_OMP_FACTORS(I)%LA, .TRUE., & KEEP8, INFO(1), INFO(2), .TRUE., .FALSE. ) ENDIF L0_OMP_FACTORS(I)%LA = -99999_8 ENDIF IF (associated(MUMPS_TPS_ARR(I)%IW)) THEN DEALLOCATE(MUMPS_TPS_ARR(I)%IW) NULLIFY(MUMPS_TPS_ARR(I)%IW) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -((int(MUMPS_TPS_ARR(I)%LIW,8) * int(KEEP(34),8)) & / int(KEEP(35),8)), & .TRUE., & KEEP8, INFO(1), INFO(2), .TRUE., .FALSE. ) ENDIF ENDDO !$OMP END PARALLEL DO ENDIF IF (allocated(MUMPS_TPS_ARR)) THEN DEALLOCATE(MUMPS_TPS_ARR) ENDIF IF (allocated(DMUMPS_TPS_ARR)) THEN DEALLOCATE(DMUMPS_TPS_ARR) ENDIF POSFAC = POSFAC -1_8 IWPOS = IWPOS -1 IF (KEEP(201).LE.0) THEN IF (KEEP(201) .EQ. -1 .AND. INFO(1) .LT. 0) THEN POSFAC = 0_8 ENDIF KEEP8(31) = POSFAC RINFO(6) = ZERO ELSE RINFO(6) = dble(KEEP8(31)*int(KEEP(35),8))/1D6 ENDIF KEEP8(48) = KEEP8(31)+KEEP8(71)+KEEP8(64) KEEP(32) = IWPOS CALL MUMPS_SETI8TOI4(KEEP8(48), INFO(9)) INFO(10) = KEEP(32) KEEP8(67) = LA - KEEP8(67) CALL MPI_ALLREDUCE(NTOTPV, NTOTPVTOT, 1, MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR) IF ( ( (INFO(1).EQ.-10 .OR. INFO(1).EQ.-40) & .AND. (NTOTPVTOT.EQ.N) ) & .OR. ( NTOTPVTOT.GT.N ) ) THEN write(*,*) ' Error 1 NTOTPVTOT=', NTOTPVTOT,N CALL MUMPS_ABORT() ENDIF IF ( (KEEP(19).NE.0 ) .AND. (NTOTPVTOT.NE.N) .AND. & (INFO(1).GE.0) ) THEN write(*,*) ' Error 2 NTOTPVTOT=', NTOTPVTOT CALL MUMPS_ABORT() ENDIF IF ( (INFO(1) .GE. 0 ) & .AND. (NTOTPVTOT.NE.N) ) THEN INFO(1) = -10 ENDIF IF (INFO(1).EQ.-10) THEN INFO(2) = NTOTPVTOT ENDIF IF (PROK) THEN WRITE (MPRINT,99980) INFO(1), INFO(2), & KEEP(28), KEEP8(48), INFO(10), INFO(11) IF(KEEP(50) .EQ. 0) THEN WRITE(MPRINT,99982) INFO(12) ENDIF IF (KEEP(50) .NE. 0) THEN WRITE(MPRINT,99984) INFO(12) ENDIF WRITE (MPRINT, 99986) & INFO(13), INFO(14), RINFO(2), RINFO(3) IF (KEEP(97) .NE. 0) THEN WRITE (MPRINT, 99987) INFO(25) ENDIF ENDIF RETURN 99980 FORMAT (/' LEAVING FACTORIZATION PHASE WITH ...'/ & ' INFO (1) =',I15/ & ' --- (2) =',I15/ & ' Number of nodes in the tree =',I15/ & ' INFO (9) Real space for factors =',I15/ & ' --- (10) Integer space for factors =',I15/ & ' --- (11) Maximum size of frontal matrices =',I15) 99982 FORMAT (' --- (12) Number of off diagonal pivots =',I15) 99984 FORMAT (' --- (12) Number of negative pivots =',I15) 99986 FORMAT (' --- (13) Number of delayed pivots =',I15/ & ' --- (14) Number of memory compresses =',I15/ & ' RINFO(2) Operations during node assembly =',1PD10.3/ & ' -----(3) Operations during node elimination =',1PD10.3) 99987 FORMAT (' INFO (25) Number of tiny pivots(static) =',I15) END SUBROUTINE DMUMPS_FAC_B SUBROUTINE DMUMPS_FAC_PAR_I(N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NULLNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, & DET_SIGN,PTRIST,PTRAST,PIMASTER,PAMASTER,PTRARW,PTRAIW,PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & MUMPS_TPS_ARR, DMUMPS_TPS_ARR, LTPS_ARR, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & NBROOT_UNDER_L0, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS, SLAVEF, MYID, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, INTARR, DBLARR, root, roota, & PERM, NELT, FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV, & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP, & PIVNUL_LIST_STRUCT, LRGROUPS ) USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T USE DMUMPS_TPS_M, ONLY: DMUMPS_TPS_T USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_FAC_PAR_M, ONLY : DMUMPS_FAC_PAR USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80) DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI INTEGER, INTENT(INOUT) :: NELVA, COMP INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV INTEGER, INTENT(INOUT) :: NULLNEGPV INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP DOUBLE PRECISION, INTENT(INOUT) :: DET_MANT INTEGER(8) :: LA DOUBLE PRECISION :: A(LA) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER LPOOL INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER IW(LIW), NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST(KEEP(28)), PERM(N) INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IPOOL(LPOOL) INTEGER NE(KEEP(28)) DOUBLE PRECISION RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU INTEGER IWPOS, LEAF, NBROOT, NBRTOT INTEGER, INTENT(in) :: NBROOT_UNDER_L0 INTEGER COMM_LOAD, ASS_IRECV DOUBLE PRECISION UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER LRGROUPS(KEEP(280)) INTEGER, INTENT( IN ) :: LTPS_ARR, LL0_OMP_MAPPING TYPE (MUMPS_TPS_T) :: MUMPS_TPS_ARR(LTPS_ARR) TYPE (DMUMPS_TPS_T) :: DMUMPS_TPS_ARR(LTPS_ARR) INTEGER, INTENT( IN ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) CALL DMUMPS_FAC_PAR( N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NULLNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, & DET_SIGN,PTRIST,PTRAST,PIMASTER,PAMASTER,PTRARW,PTRAIW,PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & MUMPS_TPS_ARR, DMUMPS_TPS_ARR, LTPS_ARR, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & NBROOT_UNDER_L0, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8, & PROCNODE_STEPS,SLAVEF,MYID, COMM_NODES, MYID_NODES, & BUFR,LBUFR,LBUFR_BYTES,INTARR,DBLARR,root,roota,PERM, NELT, & FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV, & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP, & PIVNUL_LIST_STRUCT, LRGROUPS ) RETURN END SUBROUTINE DMUMPS_FAC_PAR_I MUMPS_5.8.1/src/zsol_distsol.F0000664000175000017500000000101115042446441016061 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_DS_RETURN() RETURN END SUBROUTINE ZMUMPS_DS_RETURN MUMPS_5.8.1/src/sana_LDLT_preprocess.F0000664000175000017500000007133615042446437017365 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SET_CONSTRAINTS( & N,PIV,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8, ROWSCA & ) USE SMUMPS_STRUC_DEF IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(OUT) :: NCST INTEGER :: PIV(N),FRERE(N),FILS(N),NFSIZ(N),IKEEP(N) INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) REAL :: ROWSCA(N) INTEGER I,P11,P1,P2,K1,K2,NLOCKED LOGICAL V1,V2 NCST = 0 NLOCKED = 0 P11 = KEEP(93) DO I=KEEP(93)-1,1,-2 P1 = PIV(I) P2 = PIV(I+1) K1 = IKEEP(P1) IF (K1 .NE. 0) THEN V1 = (K1+2*exponent(ROWSCA(P1)) .GE. -3) ELSE V1 = .FALSE. ENDIF K2 = IKEEP(P2) IF (K2 .NE. 0) THEN V2 = (K2+exponent(ROWSCA(P2)**2) .GE. -3) ELSE V2 = .FALSE. ENDIF IF(V1 .AND. V2) THEN PIV(P11) = P1 P11 = P11 - 1 PIV(P11) = P2 P11 = P11 - 1 ELSE IF(V1) THEN NCST = NCST+1 FRERE(NCST) = P1 NCST = NCST+1 FRERE(NCST) = P2 ELSE IF(V2) THEN NCST = NCST+1 FRERE(NCST) = P2 NCST = NCST+1 FRERE(NCST) = P1 ELSE NLOCKED = NLOCKED + 1 FILS(NLOCKED) = P1 NLOCKED = NLOCKED + 1 FILS(NLOCKED) = P2 ENDIF ENDDO DO I=1,NLOCKED PIV(I) = FILS(I) ENDDO KEEP(94) = KEEP(94) + KEEP(93) - NLOCKED KEEP(93) = NLOCKED DO I=1,NCST NLOCKED = NLOCKED + 1 PIV(NLOCKED) = FRERE(I) ENDDO DO I=1,KEEP(93)/2 NFSIZ(I) = 0 ENDDO DO I=(KEEP(93)/2)+1,(KEEP(93)/2)+NCST,2 NFSIZ(I) = I+1 NFSIZ(I+1) = -1 ENDDO DO I=(KEEP(93)/2)+NCST+1,(KEEP(93)/2)+KEEP(94) NFSIZ(I) = 0 ENDDO END SUBROUTINE SMUMPS_SET_CONSTRAINTS SUBROUTINE SMUMPS_EXPAND_PERMUTATION(N,NCMP,N11,N22,PIV, & INVPERM,PERM) IMPLICIT NONE INTEGER N11,N22,N,NCMP INTEGER, intent(in) :: PIV(N),PERM(N) INTEGER, intent (out):: INVPERM(N) INTEGER CMP_POS,EXP_POS,I,J,N2,K N2 = N22/2 EXP_POS = 1 DO CMP_POS=1,NCMP J = PERM(CMP_POS) IF(J .LE. N2) THEN K = 2*J-1 I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 K = K+1 I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ELSE K = N2 + J I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ENDIF ENDDO DO K=N22+N11+1,N I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ENDDO RETURN END SUBROUTINE SMUMPS_EXPAND_PERMUTATION SUBROUTINE SMUMPS_LDLT_COMPRESS( & N,NZ, IRN, ICN, PIV, & NCMP, IW, LW, IPE, LEN, IQ, & FLAG, ICMP, IWFR, & IERROR, KEEP,KEEP8, ICNTL,INPLACE64_GRAPH_COPY) IMPLICIT NONE INTEGER, intent(in) :: N INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: IRN(NZ), ICN(NZ), PIV(N) INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(out) :: NCMP, IERROR INTEGER(8), intent(out) :: IWFR, IPE(N+1) INTEGER, intent(out) :: IW(LW) INTEGER, intent(out) :: LEN(N) INTEGER(8), intent(out) :: IQ(N) INTEGER, intent(out) :: FLAG(N), ICMP(N) LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: N11, N22 INTEGER :: I, J, N1, K INTEGER(8) :: NDUP, L, K8, K1, K2, LAST IERROR = 0 N22 = KEEP(93) N11 = KEEP(94) NCMP = N22/2 + N11 DO I=1,NCMP IPE(I) = 0 ENDDO K = 1 DO I=1,N22/2 J = PIV(K) ICMP(J) = I K = K + 1 J = PIV(K) ICMP(J) = I K = K + 1 ENDDO K = N22/2 + 1 DO I=N22+1,N22+N11 J = PIV(I) ICMP(J) = K K = K + 1 ENDDO DO I=N11+N22+1,N J = PIV(I) ICMP(J) = 0 ENDDO DO K8=1,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ICMP(I) J = ICMP(J) IF ((I.NE.0).AND.(J.NE.0).AND.(I.NE.J)) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 ENDIF ENDIF ENDDO IQ(1) = 1_8 N1 = NCMP - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(NCMP)+IQ(NCMP)-1_8,IQ(NCMP)) DO I = 1,NCMP FLAG(I) = 0 IPE(I) = IQ(I) ENDDO IW(1:LAST) = 0 IWFR = LAST + 1_8 DO K8=1,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ICMP(I) J = ICMP(J) IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1_8 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1_8 ENDIF ENDIF ENDIF ENDDO NDUP = 0_8 DO I=1,NCMP K1 = IPE(I) K2 = IQ(I) -1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) GO TO 250 L = IQ(J) IQ(J) = L + 1_8 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(L) = 0 IW(K8) = 0 ELSE IW(L) = I IW(K8) = J FLAG(J) = I ENDIF ENDDO 250 LEN(I) = int(IQ(I) - IPE(I)) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,NCMP K1 = IPE(I) IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF ENDDO LEN(I) = int(IWFR - L) ENDDO ENDIF IPE(NCMP+1) = IPE(NCMP) + int(LEN(NCMP),8) IWFR = IPE(NCMP+1) INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1_8)) RETURN END SUBROUTINE SMUMPS_LDLT_COMPRESS SUBROUTINE SMUMPS_SYM_MWM( & N, NE, IP, IRN, SCALING,LSC,CPERM, DIAG, & ICNTL, WEIGHT,MARKED,FLAG, & PIV_OUT, INFO) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NE INTEGER :: ICNTL(10), INFO(10),LSC INTEGER :: CPERM(N),PIV_OUT(N), IRN(NE), DIAG(N) INTEGER(8), INTENT(IN) :: IP(N+1) REAL :: SCALING(LSC),WEIGHT(N+2) INTEGER :: MARKED(N),FLAG(N) INTEGER :: NUM1,NUM2,NUMTOT,PATH_LENGTH,NLAST INTEGER :: I,BEST_BEG, CUR_EL,CUR_EL_PATH,CUR_EL_PATH_NEXT INTEGER :: L1,L2,TUP,T22 INTEGER(8) :: PTR_SET1,PTR_SET2 REAL :: BEST_SCORE,CUR_VAL,TMP,VAL REAL INITSCORE, SMUMPS_UPDATESCORE, & SMUMPS_UPDATE_INVERSE, SMUMPS_METRIC2x2 LOGICAL VRAI,FAUX,MAX_CARD_DIAG,USE_SCALING INTEGER SUM REAL ZERO,ONE PARAMETER (SUM = 1, VRAI = .TRUE., FAUX = .FALSE.) PARAMETER(ZERO = 0.0E0, ONE = 1.0E0) MAX_CARD_DIAG = .TRUE. NUM1 = 0 NUM2 = 0 NUMTOT = 0 NLAST = N INFO = 0 MARKED = 1 FLAG = 0 VAL = ONE IF(LSC .GT. 1) THEN USE_SCALING = .TRUE. ELSE USE_SCALING = .FALSE. ENDIF TUP = ICNTL(2) IF(TUP .EQ. SUM) THEN INITSCORE = ZERO ELSE INITSCORE = ONE ENDIF IF(ICNTL(2) .GT. 2 .OR. ICNTL(2) .LE. 0) THEN WRITE(*,*) & 'ERROR: WRONG VALUE FOR ICNTL(2) = ',ICNTL(2) INFO(1) = -1 RETURN ENDIF T22 = ICNTL(1) IF(ICNTL(1) .LT. 0 .OR. ICNTL(1) .GT. 2) THEN WRITE(*,*) & 'ERROR: WRONG VALUE FOR ICNTL(1) = ',ICNTL(1) INFO(1) = -1 RETURN ENDIF DO CUR_EL=1,N IF(MARKED(CUR_EL) .LE. 0) THEN CYCLE ENDIF IF(CPERM(CUR_EL) .LT. 0) THEN MARKED(CUR_EL) = -1 CYCLE ENDIF PATH_LENGTH = 2 CUR_EL_PATH = CPERM(CUR_EL) IF(CUR_EL_PATH .EQ. CUR_EL) THEN MARKED(CUR_EL) = -1 CYCLE ENDIF MARKED(CUR_EL) = 0 WEIGHT(1) = INITSCORE WEIGHT(2) = INITSCORE L1 = int(IP(CUR_EL+1)-IP(CUR_EL)) L2 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH)) PTR_SET1 = IP(CUR_EL) PTR_SET2 = IP(CUR_EL_PATH) IF(USE_SCALING) THEN VAL = -SCALING(CUR_EL_PATH) - SCALING(CUR_EL+N) ENDIF CUR_VAL = SMUMPS_METRIC2x2( & CUR_EL,CUR_EL_PATH, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,FAUX,T22) WEIGHT(PATH_LENGTH+1) = & SMUMPS_UPDATESCORE(WEIGHT(1),CUR_VAL,TUP) DO IF(CUR_EL_PATH .EQ. CUR_EL) EXIT PATH_LENGTH = PATH_LENGTH+1 MARKED(CUR_EL_PATH) = 0 CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH) L1 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH)) L2 = int(IP(CUR_EL_PATH_NEXT+1)-IP(CUR_EL_PATH_NEXT)) PTR_SET1 = IP(CUR_EL_PATH) PTR_SET2 = IP(CUR_EL_PATH_NEXT) IF(USE_SCALING) THEN VAL = -SCALING(CUR_EL_PATH_NEXT) & - SCALING(CUR_EL_PATH+N) ENDIF CUR_VAL = SMUMPS_METRIC2x2( & CUR_EL_PATH,CUR_EL_PATH_NEXT, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,VRAI,T22) WEIGHT(PATH_LENGTH+1) = & SMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH-1),CUR_VAL,TUP) CUR_EL_PATH = CUR_EL_PATH_NEXT ENDDO IF(mod(PATH_LENGTH,2) .EQ. 1) THEN IF(WEIGHT(PATH_LENGTH+1) .GE. WEIGHT(PATH_LENGTH)) THEN CUR_EL_PATH = CPERM(CUR_EL) ELSE CUR_EL_PATH = CUR_EL ENDIF DO I=1,(PATH_LENGTH-1)/2 NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO NUMTOT = NUMTOT + PATH_LENGTH - 1 ELSE IF(MAX_CARD_DIAG) THEN CUR_EL_PATH = CPERM(CUR_EL) IF(DIAG(CUR_EL) .NE. 0) THEN BEST_BEG = CUR_EL_PATH GOTO 1000 ENDIF DO I=1,(PATH_LENGTH/2) CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH) IF(DIAG(CUR_EL_PATH) .NE. 0) THEN BEST_BEG = CUR_EL_PATH_NEXT GOTO 1000 ENDIF ENDDO ENDIF BEST_BEG = CUR_EL BEST_SCORE = WEIGHT(PATH_LENGTH-1) CUR_EL_PATH = CPERM(CUR_EL) DO I=1,(PATH_LENGTH/2)-1 TMP = SMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH), & WEIGHT(2*I-1),TUP) TMP = SMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I),TUP) IF(TMP .GT. BEST_SCORE) THEN BEST_SCORE = TMP BEST_BEG = CUR_EL_PATH ENDIF CUR_EL_PATH = CPERM(CUR_EL_PATH) TMP = SMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH+1), & WEIGHT(2*I),TUP) TMP = SMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I+1),TUP) IF(TMP .GT. BEST_SCORE) THEN BEST_SCORE = TMP BEST_BEG = CUR_EL_PATH ENDIF CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO 1000 CUR_EL_PATH = BEST_BEG DO I=1,(PATH_LENGTH/2)-1 NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO NUMTOT = NUMTOT + PATH_LENGTH - 2 MARKED(CUR_EL_PATH) = -1 ENDIF ENDDO DO I=1,N IF(MARKED(I) .LT. 0) THEN IF(DIAG(I) .EQ. 0) THEN PIV_OUT(NLAST) = I NLAST = NLAST - 1 ELSE NUM1 = NUM1 + 1 PIV_OUT(NUM2+NUM1) = I NUMTOT = NUMTOT + 1 ENDIF ENDIF ENDDO INFO(2) = NUMTOT INFO(3) = NUM1 INFO(4) = NUM2 RETURN END SUBROUTINE SMUMPS_SYM_MWM FUNCTION SMUMPS_UPDATESCORE(A,B,T) IMPLICIT NONE REAL SMUMPS_UPDATESCORE REAL A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN SMUMPS_UPDATESCORE = A+B ELSE SMUMPS_UPDATESCORE = A*B ENDIF END FUNCTION SMUMPS_UPDATESCORE FUNCTION SMUMPS_UPDATE_INVERSE(A,B,T) IMPLICIT NONE REAL SMUMPS_UPDATE_INVERSE REAL A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN SMUMPS_UPDATE_INVERSE = A-B ELSE SMUMPS_UPDATE_INVERSE = A/B ENDIF END FUNCTION SMUMPS_UPDATE_INVERSE FUNCTION SMUMPS_METRIC2x2(CUR_EL,CUR_EL_PATH, & SET1,SET2,L1,L2,VAL,DIAG,N,FLAG,FLAGON,T) IMPLICIT NONE REAL SMUMPS_METRIC2x2 INTEGER CUR_EL,CUR_EL_PATH,L1,L2,N INTEGER SET1(L1),SET2(L2),DIAG(N),FLAG(N) REAL VAL LOGICAL FLAGON INTEGER T INTEGER I,INTER,MERGE INTEGER STRUCT,MA47 PARAMETER(STRUCT=0,MA47=1) IF(T .EQ. STRUCT) THEN IF(.NOT. FLAGON) THEN DO I=1,L1 FLAG(SET1(I)) = CUR_EL ENDDO ENDIF INTER = 0 DO I=1,L2 IF(FLAG(SET2(I)) .EQ. CUR_EL) THEN INTER = INTER + 1 FLAG(SET2(I)) = CUR_EL_PATH ENDIF ENDDO MERGE = L1 + L2 - INTER SMUMPS_METRIC2x2 = real(INTER) / real(MERGE) ELSE IF (T .EQ. MA47) THEN MERGE = 3 IF(DIAG(CUR_EL) .NE. 0) MERGE = 2 IF(DIAG(CUR_EL_PATH) .NE. 0) MERGE = MERGE - 2 IF(MERGE .EQ. 0) THEN SMUMPS_METRIC2x2 = real(L1+L2-2) SMUMPS_METRIC2x2 = -(SMUMPS_METRIC2x2**2)/2.0E0 ELSE IF(MERGE .EQ. 1) THEN SMUMPS_METRIC2x2 = - real(L1+L2-4) * real(L1-2) ELSE IF(MERGE .EQ. 2) THEN SMUMPS_METRIC2x2 = - real(L1+L2-4) * real(L2-2) ELSE SMUMPS_METRIC2x2 = - real(L1-2) * real(L2-2) ENDIF ELSE SMUMPS_METRIC2x2 = VAL ENDIF RETURN END FUNCTION SUBROUTINE SMUMPS_EXPAND_PERM_SCHUR(NA, NCMP, & INVPERM,PERM, & LISTVAR_SCHUR, SIZE_SCHUR, AOTOA) IMPLICIT NONE INTEGER, INTENT(IN):: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN):: NA, NCMP INTEGER, INTENT(IN):: AOTOA(NCMP), PERM(NCMP) INTEGER, INTENT(OUT):: INVPERM(NA) INTEGER CMP_POS, IO, I, K, IPOS DO CMP_POS=1, NCMP IO = PERM(CMP_POS) INVPERM(AOTOA(IO)) = CMP_POS ENDDO IPOS = NCMP DO K =1, SIZE_SCHUR I = LISTVAR_SCHUR(K) IPOS = IPOS+1 INVPERM(I) = IPOS ENDDO RETURN END SUBROUTINE SMUMPS_EXPAND_PERM_SCHUR SUBROUTINE SMUMPS_GNEW_SCHUR & (NA, N, NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, NBQD, AvgDens, & KEEP264, KEEP265, & LISTVAR_SCHUR, SIZE_SCHUR, ATOAO, AOTOA, & INPLACE64_GRAPH_COPY & ) IMPLICIT NONE INTEGER, intent(in) :: NA INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, intent(out) :: IERROR, symmetry INTEGER, intent(out) :: NBQD, AvgDens INTEGER, intent(out) :: LEN(N), IW(LW) INTEGER(8), intent(out):: IWFR INTEGER(8), intent(out):: NRORM, NIORM INTEGER(8), intent(out):: IPE(N+1) INTEGER, INTENT(OUT) :: AOTOA(N) INTEGER, INTENT(OUT) :: ATOAO(NA) INTEGER, intent(inout) :: IFLAG, KEEP264 INTEGER, intent(in) :: KEEP265 INTEGER(8), intent(out):: IQ(N) INTEGER, intent(out) :: FLAG(N) LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, MPG, I, J, N1 INTEGER :: NBERR, THRESH, IAO INTEGER(8) :: K8, K1, K2, LAST, NDUP INTEGER(8) :: NZOFFA, NDIAGA, L, N8 REAL :: RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) ATOAO(1:NA) = 0 DO I = 1, SIZE_SCHUR ATOAO(LISTVAR_SCHUR(I)) = -1 ENDDO IAO = 0 DO I= 1, NA IF (ATOAO(I).LT.0) CYCLE IAO = IAO +1 ATOAO(I) = IAO AOTOA(IAO) = I ENDDO NZOFFA = 0_8 NDIAGA = 0 IERROR = 0 N8 = int(N,8) DO I=1,N+1 IPE(I) = 0_8 ENDDO IF (KEEP264.EQ.0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ENDIF IF (IERROR.GE.1) THEN KEEP264 = 0 ELSE KEEP264 = 1 ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.EQ.J) THEN NDIAGA = NDIAGA + 1_8 ELSE IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDDO ENDIF ENDIF NIORM = NZOFFA + 3_8*N8 IF (IERROR.GE.1) THEN NBERR = 0 IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN WRITE (MP,99999) DO 70 K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR. & (10_8.LE.K8 .AND. K8.LE.20_8)) THEN WRITE (MP,'(I16,A,I10,A,I10,A)') & K8,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K8,10_8).EQ.1_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'st entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.2_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.3_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2_8*N8 IQ(1) = 1_8 N1 = N - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(N)+IQ(N)-1,IQ(N)) FLAG(1:N) = 0 IPE(1:N) = IQ(1:N) IW(1:LAST) = 0 IWFR = LAST + 1_8 IF (KEEP264 .EQ. 0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF (I.LT.J) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDDO ENDIF ENDIF IF (KEEP265.EQ.0) THEN NDUP = 0_8 DO I=1,N K1 = IPE(I) K2 = IQ(I) - 1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) EXIT IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE L = IQ(J) IQ(J) = L + 1 IW(L) = I IW(K8) = J FLAG(J) = I ENDIF END DO LEN(I) = int(IQ(I) - IPE(I)) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,N IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K1 = IPE(I) K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF 270 CONTINUE LEN(I) = int(IWFR - L) ENDDO ENDIF IPE(N+1) = IPE(N) + int(LEN(N),8) IWFR = IPE(N+1) ELSE IPE(1) = 1_8 DO I = 1, N LEN(I) = int(IQ(I) - IPE(I)) ENDDO DO I = 1, N IPE(I+1) = IPE(I) + int(LEN(I),8) ENDDO IWFR = IPE(N+1) ENDIF symmetry = 100 IF (SYM.EQ.0) THEN RSYM = real(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/ & real(NZOFFA+NDIAGA) IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) THEN ENDIF symmetry = nint (100.0E0*RSYM) IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) ) & write(MPG,'(A,A,I5)') & ' Case of Schur:', & ' structural symmetry (in percent) of interior block=', & symmetry IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) ) & write(MP,'(A,A,I5)') & ' Case of Schur:', & ' structural symmetry (in percent) of interior block=', & symmetry ELSE symmetry = 100 ENDIF INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1)) AvgDens = nint(real(IWFR-1_8)/real(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN DO I= 1, N J = max(LEN(I),1) IF (J.GT.THRESH) NBQD = NBQD+1 ENDDO ENDIF IF (MPG .GT. 0.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE SMUMPS_GNEW_SCHUR SUBROUTINE SMUMPS_GET_PERM_FROM_PE(N,PE,INVPERM,NFILS,WORK) IMPLICIT NONE INTEGER N INTEGER PE(N),INVPERM(N),NFILS(N),WORK(N) INTEGER I,FATHER,STKLEN,STKPOS,PERMPOS,CURVAR NFILS = 0 DO I=1,N FATHER = -PE(I) IF(FATHER .NE. 0) NFILS(FATHER) = NFILS(FATHER) + 1 ENDDO STKLEN = 0 PERMPOS = 1 DO I=1,N IF(NFILS(I) .EQ. 0) THEN STKLEN = STKLEN + 1 WORK(STKLEN) = I INVPERM(I) = PERMPOS PERMPOS = PERMPOS + 1 ENDIF ENDDO DO STKPOS = 1,STKLEN CURVAR = WORK(STKPOS) FATHER = -PE(CURVAR) DO IF(FATHER .EQ. 0) EXIT IF(NFILS(FATHER) .EQ. 1) THEN INVPERM(FATHER) = PERMPOS FATHER = -PE(FATHER) PERMPOS = PERMPOS + 1 ELSE NFILS(FATHER) = NFILS(FATHER) - 1 EXIT ENDIF ENDDO ENDDO RETURN END SUBROUTINE SMUMPS_GET_PERM_FROM_PE SUBROUTINE SMUMPS_GET_ELIM_TREE(N,PE,NV,WORK) IMPLICIT NONE INTEGER N INTEGER PE(N),NV(N),WORK(N) INTEGER I,FATHER,LEN,NEWSON,NEWFATHER DO I=1,N IF(NV(I) .GT. 0) CYCLE LEN = 1 WORK(LEN) = I FATHER = -PE(I) DO IF(NV(FATHER) .GT. 0) THEN NEWSON = FATHER EXIT ENDIF LEN = LEN + 1 WORK(LEN) = FATHER NV(FATHER) = 1 FATHER = -PE(FATHER) ENDDO NEWFATHER = -PE(FATHER) PE(WORK(LEN)) = -NEWFATHER PE(NEWSON) = -WORK(1) ENDDO END SUBROUTINE SMUMPS_GET_ELIM_TREE MUMPS_5.8.1/src/sfac_sol_l0omp_m.F0000664000175000017500000003360015042446437016563 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FACSOL_L0OMP_M PRIVATE PUBLIC :: SMUMPS_INIT_L0_OMP_FACTORS & , SMUMPS_FREE_L0_OMP_FACTORS #if ! defined(NO_SAVE_RESTORE) & , SMUMPS_SAVE_RESTORE_L0FACARRAY #endif #if ! defined(NO_SAVE_RESTORE) #endif #if ! defined(NO_SAVE_RESTORE) INCLUDE 'mumps_save_restore_modes.h' #endif CONTAINS SUBROUTINE SMUMPS_INIT_L0_OMP_FACTORS(id_L0_OMP_FACTORS) USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (SMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & id_L0_OMP_FACTORS INTEGER I IF (associated(id_L0_OMP_FACTORS)) THEN DO I=1, size(id_L0_OMP_FACTORS) NULLIFY(id_L0_OMP_FACTORS(I)%A) ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_INIT_L0_OMP_FACTORS SUBROUTINE SMUMPS_FREE_L0_OMP_FACTORS(id_L0_OMP_FACTORS) USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (SMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & id_L0_OMP_FACTORS INTEGER I IF (associated(id_L0_OMP_FACTORS)) THEN DO I=1, size(id_L0_OMP_FACTORS) IF (associated(id_L0_OMP_FACTORS(I)%A)) THEN DEALLOCATE(id_L0_OMP_FACTORS(I)%A) NULLIFY(id_L0_OMP_FACTORS(I)%A) ENDIF ENDDO DEALLOCATE(id_L0_OMP_FACTORS) NULLIFY(id_L0_OMP_FACTORS) ENDIF RETURN END SUBROUTINE SMUMPS_FREE_L0_OMP_FACTORS #if ! defined(NO_SAVE_RESTORE) SUBROUTINE SMUMPS_SAVE_RESTORE_L0FACARRAY(L0_OMP_FACTORS & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (SMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: L0_OMP_FACTORS INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: j1,NbRecords,NbSubRecords,size_array1,dummy,allocok,err INTEGER:: SIZE_GEST_L0FAC_ARRAY, & SIZE_GEST_L0FAC_ARRAY_j1 INTEGER(4) :: I4 INTEGER(8):: SIZE_VARIABLES_L0FAC_ARRAY, & SIZE_VARIABLES_L0FAC_ARRAY_j1 SIZE_GEST = 0 SIZE_VARIABLES = 0_8 SIZE_GEST_L0FAC_ARRAY=0 SIZE_VARIABLES_L0FAC_ARRAY=0 SIZE_GEST_L0FAC_ARRAY_j1=0 SIZE_VARIABLES_L0FAC_ARRAY_j1=0 NbRecords = 0 IF (mode.EQ.memory_save_mode) THEN IF (associated(L0_OMP_FACTORS)) THEN NbRecords = 1 SIZE_GEST = SIZE_INT SIZE_VARIABLES = 0 DO j1=1,size(L0_OMP_FACTORS) CALL SMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_L0FAC_ARRAY_j1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_L0FAC_ARRAY=SIZE_GEST_L0FAC_ARRAY+ & SIZE_GEST_L0FAC_ARRAY_j1 SIZE_VARIABLES_L0FAC_ARRAY=SIZE_VARIABLES_L0FAC_ARRAY+ & SIZE_VARIABLES_L0FAC_ARRAY_j1 IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords = 2 SIZE_GEST = 2*SIZE_INT SIZE_VARIABLES = 0 ENDIF ELSEIF (mode.EQ.save_mode) THEN IF (associated(L0_OMP_FACTORS)) THEN NbRecords = 1 SIZE_GEST = SIZE_INT SIZE_VARIABLES = 0 write(unit,iostat=err) size(L0_OMP_FACTORS) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 DO j1=1,size(L0_OMP_FACTORS) CALL SMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_L0FAC_ARRAY_J1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF ELSE IF (mode.EQ.restore_mode) THEN NULLIFY(L0_OMP_FACTORS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 allocate(L0_OMP_FACTORS(size_array1), stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size(L0_OMP_FACTORS) CALL SMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_L0FAC_ARRAY_J1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_L0FAC_ARRAY=SIZE_GEST_L0FAC_ARRAY+ & SIZE_GEST_L0FAC_ARRAY_j1 SIZE_VARIABLES_L0FAC_ARRAY=SIZE_VARIABLES_L0FAC_ARRAY+ & SIZE_VARIABLES_L0FAC_ARRAY_j1 IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO endif ENDIF if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(mode.EQ.memory_save_mode) then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_L0FAC_ARRAY SIZE_GEST=SIZE_GEST+SIZE_GEST_L0FAC_ARRAY #if defined(MUMPS_NOF2003) SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif 100 continue RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_L0FACARRAY SUBROUTINE SMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS_1THREAD & ,unit,MYID,mode & ,Local_SIZE_GEST, Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (SMUMPS_L0OMPFAC_T) :: L0_OMP_FACTORS_1THREAD INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: Local_NbRecords, allocok, err INTEGER(8) :: itmp Local_NbRecords = 0 Local_SIZE_GEST = 0 Local_SIZE_VARIABLES = 0_8 Local_NbRecords = Local_NbRecords+1 IF (mode .EQ. memory_save_mode) THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 ELSE IF (mode .EQ. save_mode) THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 WRITE(unit,iostat=err) L0_OMP_FACTORS_1THREAD%LA IF (err .NE. 0) THEN INFO(1)=-72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 ENDIF size_written=size_written+SIZE_INT8 ELSE IF (mode .EQ. restore_mode) THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 READ(unit,iostat=err) L0_OMP_FACTORS_1THREAD%LA IF (err .NE. 0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & INFO(2)) GOTO 100 ENDIF size_read=size_read+SIZE_INT8 ENDIF IF (mode.EQ.memory_save_mode) THEN IF (associated(L0_OMP_FACTORS_1THREAD%A)) THEN Local_NbRecords = Local_NbRecords + 2 Local_SIZE_GEST = Local_SIZE_GEST + SIZE_INT8 Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP ELSE Local_NbRecords = Local_NbRecords + 1 Local_SIZE_GEST = Local_SIZE_GEST + SIZE_INT8 Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + 0 ENDIF ELSEIF (mode.EQ.save_mode) THEN IF (associated(L0_OMP_FACTORS_1THREAD%A)) THEN Local_NbRecords = Local_NbRecords + 2 write(unit,iostat=err) int(0,8) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written=size_written+SIZE_INT8 write(unit,iostat=err) L0_OMP_FACTORS_1THREAD%A if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written = size_written + & max(L0_OMP_FACTORS_1THREAD%LA,1_8)*SIZE_ARITH_DEP ELSE Local_NbRecords = Local_NbRecords + 1 write(unit,iostat=err) int(-999,8) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written=size_written+SIZE_INT8 ENDIF ELSEIF (mode.EQ.restore_mode) THEN NULLIFY(L0_OMP_FACTORS_1THREAD%A) READ(unit,iostat=err) itmp if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 100 endif size_read = size_read + SIZE_INT8 size_allocated = size_allocated + SIZE_INT8 IF (itmp .eq. -999) THEN Local_NbRecords = Local_NbRecords + 1 ELSE Local_NbRecords = Local_NbRecords + 2 ALLOCATE(L0_OMP_FACTORS_1THREAD%A( & max(L0_OMP_FACTORS_1THREAD%LA,1_8)), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) GOTO 100 ENDIF READ(unit,iostat=err) L0_OMP_FACTORS_1THREAD%A if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 100 endif size_read = size_read + & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP size_allocated = size_allocated+ & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP ENDIF ENDIF #if defined(MUMPS_NOF2003) IF (mode.EQ.memory_save_mode) THEN Local_SIZE_GEST = Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords ELSE IF (mode.EQ.save_mode) THEN size_written = size_written+2*SIZE_INT*Local_NbRecords ELSE IF (mode.EQ.restore_mode) THEN size_read = size_read+2*SIZE_INT*Local_NbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_L0FAC #endif END MODULE SMUMPS_FACSOL_L0OMP_M MUMPS_5.8.1/src/sfac_asm.F0000664000175000017500000010637315042446437015133 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, NBROWS, NBCOLS, ROWLIST, & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, & OPASSW, IWPOSCB, MYID, KEEP,KEEP8, IS_ofType5or6, & LDA_VALSON, ICOL_BEG ) 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, INTENT(IN) :: ICOL_BEG INTEGER(8) :: POSELT, POSEL1, APOS, JJ2 INTEGER 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 IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS1 = abs(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 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+(ICOL_BEG-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 + ICOL_BEG-1 + 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 = ICOL_BEG, min(DIAG,ICOL_BEG+NBCOLS-1) JJ2 = APOS+int(JJ1-1,8) A(JJ2) = A(JJ2) + VALSON(JJ1-ICOL_BEG+1,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 = ICOL_BEG, min(NELIM, ICOL_BEG+NBCOLS-1) JJ2 = APOS + int(IW(J1+JJ1-1),8)*int(LDAFS_PERE,8) A(JJ2) = A(JJ2) + VALSON(JJ1-ICOL_BEG+1,JJ) ENDDO IBEG = max(NELIM+1,ICOL_BEG) ELSE IBEG = ICOL_BEG ENDIF APOS = POSEL1 + int(ROWLIST(JJ),8) * int(LDAFS_PERE,8) DO JJ1 = IBEG, ICOL_BEG + NBCOLS - 1 IF (ROWLIST(JJ).LT.IW(J1 + JJ1 - 1)) EXIT JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) A(JJ2) = A(JJ2) + VALSON(JJ1-ICOL_BEG+1,JJ) ENDDO ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_ASM_SLAVE_MASTER SUBROUTINE SMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, INTARR, DBLARR, & ICNTL, KEEP,KEEP8, MYID, LRGROUPS) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID INTEGER NBROWS, NBCOLS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) REAL :: RHS_MUMPS(KEEP8(85)) REAL :: A(LA) INTEGER :: INTARR(KEEP8(27)) REAL :: DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) INTEGER(8) :: POSELT REAL, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS REAL ZERO PARAMETER( ZERO = 0.0E0 ) INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL SMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) IF (NASS.LT.0) THEN NASS = -NASS IW(IOLDPS+1+KEEP(IXSZ)) = NASS CALL SMUMPS_ASM_SLAVE_ARROWHEADS(INODE, STEP(INODE), & N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, & ITLOC, FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, KEEP8(27), KEEP8(26), & RHS_MUMPS, LRGROUPS) ENDIF IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_ASM_SLAVE_TO_SLAVE_INIT SUBROUTINE SMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, NBROWS, STEP, PTRIST, & ITLOC, RHS_MUMPS, KEEP,KEEP8) IMPLICIT NONE INTEGER N, LIW INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER INODE INTEGER NBROWS INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)) REAL :: RHS_MUMPS(KEEP8(85)) INCLUDE 'mumps_headers.h' INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J IOLDPS = PTRIST(STEP(INODE)) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_ASM_SLAVE_TO_SLAVE_END SUBROUTINE SMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, ROWLIST, COLLIST, VALSON, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, FILS, & ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, LDA_VALSON) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY: SMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID LOGICAL, intent(in) :: IS_ofType5or6 INTEGER NBROWS, NBCOLS, LDA_VALSON INTEGER ROWLIST(NBROWS), COLLIST(NBCOLS) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRAST(KEEP(28)) REAL A(LA), VALSON(LDA_VALSON,NBROWS) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8) :: POSEL1, POSELT, APOS, K8 INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & I,J,NASS,IDIAG REAL, POINTER, DIMENSION(:) :: A_PTR INTEGER(8) :: LA_PTR INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL SMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) IF ( NBROWS .GT. NBROWF ) THEN WRITE(*,*) ' ERR: ERROR : NBROWS > NBROWF' WRITE(*,*) ' ERR: INODE =', INODE WRITE(*,*) ' ERR: NBROW=',NBROWS,'NBROWF=',NBROWF WRITE(*,*) ' ERR: ROW_LIST=', ROWLIST WRITE(*,*) ' ERR: NBCOLF/NASS=', NBCOLF, NASS CALL MUMPS_ABORT() END IF NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) IF (NBROWS.GT.0) THEN POSEL1 = POSELT - int(NBCOLF,8) IF (KEEP(50).EQ.0) THEN IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) DO I=1, NBROWS DO J = 1, NBCOLS A_PTR(APOS+int(J-1,8)) = A_PTR( APOS+int(J-1,8)) + & VALSON(J,I) ENDDO APOS = APOS + int(NBCOLF,8) END DO ELSE DO I=1,NBROWS APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) DO J=1,NBCOLS K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO ENDDO ENDIF ELSE IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) & + int((NBROWS-1),8)*int(NBCOLF,8) IDIAG = 0 DO I=NBROWS,1,-1 DO J=1,NBCOLS-IDIAG K8 = APOS+int(J-1,8) A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO APOS = APOS - int(NBCOLF,8) IDIAG = IDIAG + 1 ENDDO ELSE DO I=1,NBROWS APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) DO J=1,NBCOLS IF (ITLOC(COLLIST(J)) .EQ. 0) THEN EXIT ENDIF K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO ENDDO ENDIF ENDIF OPASSW = OPASSW + dble(NBROWS*NBCOLS) ENDIF RETURN END SUBROUTINE SMUMPS_ASM_SLAVE_TO_SLAVE SUBROUTINE SMUMPS_LDLT_ASM_NIV12_IP( A, LA, & IAFATH, NFRONT, NASS1, & IACB, NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED ) IMPLICIT NONE INTEGER NFRONT, NASS1 INTEGER(8) :: LA INTEGER NCOLS, NROWS, NELIM INTEGER(8) :: LCB REAL A( LA ) INTEGER(8) :: IAFATH, IACB INTEGER IW( NCOLS ) INTEGER ETATASS LOGICAL CB_IS_COMPRESSED REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB, IBEGCBROW, IENDFRONT LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE IENDFRONT = IAFATH+int(NFRONT,8)*int(NFRONT,8)-1_8 IPOSCB=1_8 RESET_TO_ZERO = IACB .LT. IENDFRONT + 1_8 RISK_OF_SAME_POS = IACB + LCB .EQ. IENDFRONT + 1_8 RISK_OF_SAME_POS_THIS_LINE = .FALSE. DO I=1, NROWS POSELT = int(IW(I)-1,8) * int(NFRONT,8) IF (.NOT. CB_IS_COMPRESSED ) THEN IPOSCB = 1_8 + int(I - 1,8) * int(NCOLS,8) IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN RESET_TO_ZERO = .FALSE. ENDIF ENDIF IF ( RISK_OF_SAME_POS ) THEN IF (I.EQ.NROWS .OR. .NOT. CB_IS_COMPRESSED) THEN IF ( IAFATH + POSELT + int(IW(I)-1,8) .EQ. & IACB+IPOSCB+int(I-1-1,8)) THEN RISK_OF_SAME_POS_THIS_LINE = .TRUE. ENDIF ENDIF ENDIF IF (RESET_TO_ZERO) THEN IF ( RISK_OF_SAME_POS_THIS_LINE ) THEN DO J=1, I APOS = POSELT + int(IW( J ),8) IF (IAFATH + APOS - 1_8.NE. IACB+IPOSCB-1_8) THEN A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) A(IACB+IPOSCB-1_8) = ZERO ENDIF IPOSCB = IPOSCB + 1_8 ENDDO ELSE #if defined(__ve__) !NEC$ IVDEP #endif 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 #if defined(__ve__) !NEC$ IVDEP #endif DO J=1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB + 1_8 ENDDO ENDIF IF (.NOT. CB_IS_COMPRESSED ) THEN IBEGCBROW = IACB+IPOSCB-1_8 IF ( IBEGCBROW .LE. IENDFRONT ) THEN A(IBEGCBROW:IBEGCBROW+int(NCOLS-I,8)-1_8)=ZERO ENDIF ENDIF IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN RESET_TO_ZERO = .FALSE. ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_LDLT_ASM_NIV12_IP SUBROUTINE SMUMPS_LDLT_ASM_NIV12( A, LA, SON_A, & IAFATH, NFRONT, NASS1, & NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED !$ & , K360 & ) IMPLICIT NONE INTEGER NFRONT, NASS1 INTEGER(8) :: LA INTEGER NCOLS, NROWS, NELIM INTEGER(8) :: LCB REAL A( LA ) REAL SON_A( LCB ) INTEGER(8) :: IAFATH INTEGER IW( NCOLS ) INTEGER ETATASS LOGICAL CB_IS_COMPRESSED !$ INTEGER, INTENT(in):: K360 REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB !$ LOGICAL :: OMP_FLAG IF ((ETATASS.EQ.0) .OR. (ETATASS.EQ.1)) THEN IPOSCB = 1_8 #if defined(__ve__) !NEC$ IVDEP #endif 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 #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IAFATH+ APOS -1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO END DO ENDIF IF ((ETATASS.EQ.0).OR.(ETATASS.EQ.1)) THEN !$ OMP_FLAG = (NROWS-NELIM).GE.K360 !$OMP PARALLEL DO PRIVATE(IPOSCB, POSELT, J, APOS) IF (OMP_FLAG) DO I = NELIM + 1, NROWS IF (CB_IS_COMPRESSED) THEN IPOSCB = (int(I,8) * int(I-1,8)) / 2_8 + 1_8 ELSE IPOSCB = int(I-1,8) * int(NCOLS,8) + 1_8 ENDIF POSELT = int(IW( I ),8) IF (POSELT.LE. int(NASS1,8)) THEN #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, NELIM APOS = POSELT + int( IW( J ) - 1, 8 ) * int(NFRONT,8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) + & SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ELSE POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, NELIM APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ENDIF IF (ETATASS.EQ.1) THEN POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J = NELIM + 1, I IF (IW(J).GT.NASS1) EXIT APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB +1_8 END DO ELSE POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) #if defined(__ve__) !NEC$ IVDEP #endif DO J = NELIM + 1, I APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ENDIF END DO !$OMP END PARALLEL DO ELSE DO I= NROWS, NELIM+1, -1 IF (CB_IS_COMPRESSED) THEN IPOSCB = (int(I,8)*int(I+1,8))/2_8 ELSE IPOSCB = int(I-1,8) * int(NCOLS,8) + int(I,8) ENDIF POSELT = int(IW( I ),8) IF (POSELT.LE.int(NASS1,8)) EXIT POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J=I,NELIM+1, -1 IF (IW(J).LE.NASS1) EXIT APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB - 1_8 ENDDO ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_LDLT_ASM_NIV12 SUBROUTINE SMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST_S, IW, LIW, STEP, KEEP,KEEP8) IMPLICIT NONE INTEGER N, ISON, INODE, IWPOSCB INTEGER KEEP(500), STEP(N) INTEGER(8) KEEP8(150) INTEGER PIMASTER(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER LIW INTEGER IW(LIW) INTEGER ISTCHK, LSTK, NSLSON, HS, NROWS, NCOLS, NPIVS, NELIM INTEGER IOLDPS, NFRONT, NSLAVES, ICT11, HF INTEGER J1, J2, J3, JJ, JPOS LOGICAL SAME_PROC INCLUDE 'mumps_headers.h' ISTCHK = PIMASTER(STEP(ISON)) LSTK = IW(ISTCHK+KEEP(IXSZ)) NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NELIM = IW(ISTCHK + 1+KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) NCOLS = NPIVS + LSTK IF ( NPIVS < 0 ) NPIVS = 0 SAME_PROC = ISTCHK < IWPOSCB IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2+KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS IF (KEEP(50).NE.0) THEN J2 = J1 + LSTK - 1 DO JJ = J1, J2 IW(JJ) = IW(JJ - NROWS) ENDDO ELSE J2 = J1 + LSTK - 1 J3 = J1 + NELIM DO JJ = J3, J2 IW(JJ) = IW(JJ - NROWS) ENDDO IF (NELIM .NE. 0) THEN IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) ICT11 = IOLDPS + HF - 1 + NFRONT J3 = J3 - 1 DO 190 JJ = J1, J3 JPOS = IW(JJ) + ICT11 IW(JJ) = IW(JPOS) 190 CONTINUE ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_RESTORE_INDICES SUBROUTINE SMUMPS_ASM_MAX( & N, INODE, IW, LIW, A, LA, & ISON, NBCOLS, & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, & OPASSW, IWPOSCB,MYID, KEEP,KEEP8 ) 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,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 = abs(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) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOSCB) IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2 + KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS APOS = POSELT + int(NASS1,8)*int(NASS1,8) - 1_8 DO JJ1 = 1, NBCOLS JJ2 = APOS+int(IW(J1 + JJ1 - 1),8) IF(real(A(JJ2)) .LT. VALSON(JJ1)) THEN A(JJ2) = VALSON(JJ1) ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_ASM_MAX SUBROUTINE SMUMPS_ASM_SLAVE_ARROWHEADS(INODE, ISTEP, & N, IW, LIW, IOLDPS, & A, LA, POSELT, KEEP, KEEP8, & ITLOC, FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LINTARR, LDBLARR, RHS_MUMPS, LRGROUPS) !$ USE OMP_LIB USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, intent(in) :: N, LIW, IOLDPS, INODE, ISTEP INTEGER(8), intent(in) :: LA, POSELT INTEGER(8), intent(in) :: LINTARR, LDBLARR INTEGER, intent(in) :: IW(LIW) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(inout) :: ITLOC(N+KEEP(253)) REAL, intent(inout) :: A(LA) REAL, intent(in) :: RHS_MUMPS(KEEP8(85)) REAL, intent(in) :: DBLARR(LDBLARR) INTEGER, intent(in) :: INTARR(LINTARR) INTEGER, intent(in) :: FILS(N) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 !$ INTEGER :: CHUNK INCLUDE 'mumps_headers.h' INTEGER :: HF, NBROWF, NBCOLF, NASS, NSLAVES INTEGER :: ILOC, J, K, K1, K2, JPOS, IJROW INTEGER :: IN, IARR1, IORG INTEGER(8) :: J18, J28, JJ8 INTEGER(8) :: APOS, ICT12 INTEGER(8) :: AINPUT8 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE, TOPDIAG INTEGER(8) :: JJ3 INTEGER :: K1RHS, K2RHS, JFirstRHS REAL ZERO PARAMETER( ZERO = 0.0E0 ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) !$ NOMP = OMP_GET_MAX_THREADS() IF (KEEP(50) .EQ. 0 .OR. NBROWF .LT. KEEP(63)) THEN !$ CHUNK8 = int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8) !$OMP& .AND. NOMP .GT. 1) DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = 0 IF (IW(IOLDPS+XXLR).GE.1) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0, & NBROWF, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) NB_BLR_LS = NPARTSCB call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR_LS) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS, & NBCOLF, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max( KEEP(360)/2, !$ & ((NBROWF+NOMP-1)/NOMP +2) / 3 ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK) !$OMP& IF (NBROWF .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(NBROWF-1,8) APOS = POSELT+ JJ8*int(NBCOLF,8) JJ3 = min( int(NBCOLF,8) - 1_8, & JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG ) A(APOS: APOS+JJ3) = ZERO ENDDO !$OMP END PARALLEL DO ENDIF K1 = IOLDPS + HF + NBROWF K2 = K1 + NASS - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = -JPOS JPOS = JPOS + 1 ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF - 1 JPOS = 1 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN K1RHS = 0 K2RHS = -1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN K1RHS = K JFirstRHS=J-N ENDIF JPOS = JPOS + 1 ENDDO IF (K1RHS.GT.0) K2RHS=K2 IF ( K2RHS.GE.K1RHS ) THEN IN = INODE DO WHILE (IN.GT.0) IJROW = -ITLOC(IN) DO K = K1RHS, K2RHS J = IW(K) ILOC = ITLOC(J) APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+IN) ENDDO IN = FILS(IN) ENDDO ENDIF ELSE DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF IN = INODE IORG = 0 IARR1 = PTRDEBARR(ISTEP) DO WHILE (IN.GT.0) IORG = IORG + 1 AINPUT8 = PTR8ARR( IARR1 + IORG -1 ) J18 = AINPUT8 J28 = J18 + NINCOLARR(IARR1+IORG-1) IJROW = -ITLOC(INTARR(J18)) ICT12 = POSELT +int(- NBCOLF + IJROW - 1,8) DO JJ8= J18,J28 ILOC = ITLOC(INTARR(JJ8)) IF (ILOC.GT.0) THEN APOS = ICT12 + int(ILOC,8)*int(NBCOLF,8) A(APOS) = A(APOS) + DBLARR(AINPUT8) ENDIF AINPUT8 = AINPUT8 + 1_8 ENDDO IN = FILS(IN) ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF + NASS - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO RETURN END SUBROUTINE SMUMPS_ASM_SLAVE_ARROWHEADS SUBROUTINE SMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS1, KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(out) :: PARPIV_T1 INTEGER :: NCB LOGICAL, EXTERNAL :: SMUMPS_IS_TRSM_LARGE_ENOUGH, & SMUMPS_IS_GEMM_LARGE_ENOUGH PARPIV_T1 = KEEP(269) IF (PARPIV_T1.EQ.-3) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.77) THEN PARPIV_T1 = 0 ENDIF NCB = NFRONT-NASS1 IF (NCB.EQ.KEEP(253)) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.0) RETURN IF ( (PARPIV_T1.EQ.-2).AND.LR_ACTIVATED ) THEN PARPIV_T1 = 1 ENDIF IF (PARPIV_T1.EQ.-2) THEN IF ( & ( SMUMPS_IS_TRSM_LARGE_ENOUGH ( NASS1, NCB & ) & ) & .OR. & ( SMUMPS_IS_GEMM_LARGE_ENOUGH ( NCB, NCB, NASS1 & ) & ) & ) THEN PARPIV_T1 = 1 ELSE PARPIV_T1 = 0 ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SET_PARPIVT1 LOGICAL FUNCTION SMUMPS_IS_TRSM_LARGE_ENOUGH & ( M, N & ) IMPLICIT NONE INTEGER, INTENT(in) :: M, N DOUBLE PRECISION :: AI INTEGER, PARAMETER :: THRES_AI = 400 AI = ( dble(M)*dble(N) ) / & ( dble(M)/dble(2) + dble(2)*dble(N) ) SMUMPS_IS_TRSM_LARGE_ENOUGH = (AI.GE.dble(THRES_AI)) RETURN END FUNCTION SMUMPS_IS_TRSM_LARGE_ENOUGH LOGICAL FUNCTION SMUMPS_IS_GEMM_LARGE_ENOUGH & ( M, N, K & ) IMPLICIT NONE INTEGER, INTENT(in) :: M, N, K DOUBLE PRECISION :: AI INTEGER, PARAMETER :: THRES_AI = 400 AI = ( dble(2)*dble(M)*dble(N)*dble(K) ) / & ( dble(M)*dble(N) + dble(M)*dble(K) + dble(K)*dble(N) ) SMUMPS_IS_GEMM_LARGE_ENOUGH = (AI.GE.dble(THRES_AI)) RETURN END FUNCTION SMUMPS_IS_GEMM_LARGE_ENOUGH SUBROUTINE SMUMPS_PARPIVT1_SET_MAX ( INODE, & A, LAELL8, KEEP, NFRONT, & NASS1, NVSCHUR_K253, NB_POSTPONED) !$ USE OMP_LIB IMPLICIT NONE INTEGER(8), intent(in) :: LAELL8 INTEGER, intent(in) :: INODE INTEGER, intent(in) :: KEEP(500), NFRONT, NASS1, & NVSCHUR_K253 INTEGER, intent(in) :: NB_POSTPONED REAL, intent(inout) :: A(LAELL8) INTEGER(8) :: APOSMAX, APOS, NASS1_8, NFRONT_8 INTEGER :: I, J, NCB REAL :: ZERO REAL :: RMAX LOGICAL :: OMP_FLAG INTEGER :: JB, NB_BLOCKS, BLSIZE INTEGER(8) :: APOSSHIFT INTEGER :: NOMP PARAMETER( ZERO = 0.0E0 ) NASS1_8 = int(NASS1, 8) NFRONT_8 = int(NFRONT, 8) NCB = NFRONT-NASS1-NVSCHUR_K253 IF ((NCB.EQ.0).AND.(NVSCHUR_K253.EQ.0)) CALL MUMPS_ABORT() APOSMAX = LAELL8 - NASS1_8 + 1_8 A(APOSMAX:APOSMAX+NASS1_8-1_8)= ZERO IF (NCB.EQ.0) RETURN IF (KEEP(50).EQ.2) THEN IF ( NASS1 .LE. KEEP(366) ) THEN APOS = 1_8 + (NASS1_8*NFRONT_8) DO I = 1, NCB DO J = 1, NASS1 RMAX = real(A(APOSMAX+int(J,8)-1_8)) RMAX = max(RMAX, abs(A(APOS+int(J,8)-1_8))) A(APOSMAX+int(J,8)-1_8) = RMAX ENDDO APOS = APOS+NFRONT_8 ENDDO ELSE NOMP = 1 !$ NOMP = OMP_GET_MAX_THREADS() OMP_FLAG = int(NCB,8)*int(NASS1,8) .GT. int(KEEP(361),8) & .AND. (NASS1 .GT. KEEP(366)) .AND. (NOMP.GT.1) BLSIZE = max(KEEP(366),1) NB_BLOCKS = NASS1 / BLSIZE BLSIZE = (NASS1 + NB_BLOCKS - 1)/ NB_BLOCKS APOSSHIFT=NASS1_8 * NFRONT_8 !$OMP PARALLEL DO PRIVATE(I,J,APOS,JB,RMAX) IF (OMP_FLAG) DO JB = 1, NASS1, BLSIZE DO I = 1, NCB DO J = JB, min(JB+BLSIZE-1,NASS1) APOS = APOSSHIFT + int(I-1,8) * int(NFRONT,8) + int(J,8) RMAX = real( A(APOSMAX+int(J,8) - 1_8) ) RMAX = max( RMAX, abs(A(APOS+int(J,8)) ) ) A(APOSMAX+int(J,8)-1_8) = RMAX ENDDO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF ELSE OMP_FLAG = int(NCB,8)*int(NASS1,8) .GT. int(KEEP(361),8) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(I,J,APOS,RMAX) DO I = 1, NASS1 RMAX = 0.0E0 APOS = 1_8 + NASS1_8+int(I-1,8)*NFRONT_8 DO J = 1, NCB RMAX = max(RMAX, abs(A(APOS+int(J-1,8)))) ENDDO A(APOSMAX+int(I,8)-1_8) = RMAX ENDDO !$OMP END PARALLEL DO ELSE APOS = 1_8 + NASS1_8 DO I = 1, NASS1 RMAX = 0.0E0 DO J = 1, NCB RMAX = max(RMAX, abs(A(APOS+int(J,8)-1))) ENDDO A(APOSMAX+int(I,8)-1_8) = RMAX APOS = APOS+NFRONT_8 ENDDO ENDIF ENDIF CALL SMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, A(APOSMAX), NASS1, NB_POSTPONED) RETURN END SUBROUTINE SMUMPS_PARPIVT1_SET_MAX SUBROUTINE SMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, PARPIV, LPARPIV, & NB_POSTPONED) IMPLICIT NONE INTEGER, intent(in) :: INODE, LPARPIV, KEEP(500) REAL, intent(inout):: PARPIV(LPARPIV) INTEGER, intent(in) :: NB_POSTPONED INTEGER :: I REAL :: EPS, RMIN, RZERO, RTMP REAL :: RMAX LOGICAL :: UPDATE_PARPIV PARAMETER( RZERO = 0.0E0 ) UPDATE_PARPIV=.FALSE. RMIN = huge(RZERO) RMAX = RZERO EPS = sqrt(epsilon(RZERO))*0.01E0 DO I = 1, LPARPIV RTMP = real(PARPIV(I)) IF (RTMP.GT.RZERO) THEN RMIN = min(RMIN, RTMP) ELSE UPDATE_PARPIV=.TRUE. ENDIF IF (RTMP.LE.EPS) UPDATE_PARPIV=.TRUE. RMAX= max(RMAX,real(PARPIV(I))) ENDDO IF (UPDATE_PARPIV) THEN IF (RMIN.LT.huge(RMIN)) THEN RMAX= min (RMAX, EPS) DO I = 1, LPARPIV-NB_POSTPONED RTMP = real(PARPIV(I)) IF (RTMP.LE.EPS) THEN PARPIV(I) = -RMAX ENDIF ENDDO IF (NB_POSTPONED.GT.0) THEN DO I=LPARPIV-NB_POSTPONED+1, LPARPIV RTMP = real(PARPIV(I)) IF (RTMP.LE.EPS) THEN PARPIV(I) = -RMAX ENDIF ENDDO ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_UPDATE_PARPIV_ENTRIES SUBROUTINE SMUMPS_PARPIVT1_SET_NVSCHUR_MAX & (N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1, & NB_POSTPONED) USE SMUMPS_FAC_FRONT_AUX_M, ONLY: SMUMPS_GET_SIZE_SCHUR_IN_FRONT IMPLICIT NONE INTEGER, intent(in) :: N, INODE, LIW, IOLDPS, & NFRONT, NASS1, NB_POSTPONED INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: IW (LIW), PERM(N), KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED REAL, intent(inout) :: A(LA) INTEGER, intent(inout) :: PARPIV_T1 INTEGER :: NVSCHUR_K253, IROW_L INTEGER(8) :: LAELL8, NFRONT8 INCLUDE 'mumps_headers.h' IF (PARPIV_T1.EQ.-999) THEN CALL SMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) ELSE IF ((PARPIV_T1.NE.0.AND.PARPIV_T1.NE.1)) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.NE.0) THEN IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) ) THEN IROW_L = IOLDPS+6+KEEP(IXSZ)+NASS1 CALL SMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS1, & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR_K253 ) ELSE NVSCHUR_K253 = KEEP(253) ENDIF NFRONT8 = int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 + int(NASS1,8) CALL SMUMPS_PARPIVT1_SET_MAX ( INODE, & A(POSELT), LAELL8, KEEP, & NFRONT, NASS1, NVSCHUR_K253, & NB_POSTPONED ) ENDIF RETURN END SUBROUTINE SMUMPS_PARPIVT1_SET_NVSCHUR_MAX MUMPS_5.8.1/src/cfac_process_maprow.F0000664000175000017500000023103715042446440017364 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE CMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW, & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, & LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_BUF USE MUMPS_LOAD USE CMUMPS_LR_DATA_M USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR USE CMUMPS_FAC_FRONT_AUX_M, ONLY : CMUMPS_GET_SIZE_SCHUR_IN_FRONT #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE #if ! defined(NO_FDM_MAPROW) #endif TYPE (MUMPS_ROOT_STRUC ) :: root TYPE (CMUMPS_ROOT_STRUC ) :: roota INTEGER LBUFR, LBUFR_BYTES INTEGER ICNTL( 60 ), KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER COMP INTEGER NSTK( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM, MYID INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER INODE_PERE, ISON INTEGER :: NFS4FATHER INTEGER NBROWS_ALREADY_SENT INTEGER NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE( * ) INTEGER LMAP INTEGER TROW( LMAP ) DOUBLE PRECISION OPASSW, OPELIW COMPLEX DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER NOSLA, I INTEGER I_POSMYIDIN_PERE INTEGER INDICE_PERE INTEGER PDEST, PDEST_MASTER LOGICAL :: LOCAL_ASSEMBLY_TO_BE_DONE INTEGER NROWS_TO_SEND INTEGER PDEST_MASTER_ISON, IPOS_IN_SLAVE LOGICAL DESCLU, SLAVE_ISON LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG INTEGER LP LOGICAL PACKED_CB LOGICAL IS_ERROR_BROADCASTED, IS_ofType5or6 INTEGER ITYPE_SON, TYPESPLIT INTEGER :: KEEP253_LOC INTEGER :: NVSCHUR, NSLAVES_L, NROW_L, IROW_L, NASS_L, NELIM_L LOGICAL :: CB_IS_LR INTEGER :: IWXXF_HANDLER COMPLEX :: ADummy(1) COMPLEX, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: IACHK, RECSIZE #if ! defined(NO_FDM_MAPROW) INTEGER :: INFO_TMP(2) #endif INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM_LOC IS_ERROR_BROADCASTED = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) ITYPE_SON = MUMPS_TYPENODE( PROCNODE_STEPS(STEP(ISON)), & KEEP(199) ) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 #if ! defined(NO_FDM_MAPROW) #endif ALLOCATE(SLAVES_PERE(0:max(1,NSLAVES_PERE)), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) THEN write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in CMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 endif IF (NSLAVES_PERE.GT.0) &SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) THEN write(LP,*) MYID, & ' : PB allocation NBROW in CMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 670 endif LMAP_LOC = LMAP ALLOCATE(MAP(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) THEN write(LP,*) MYID, ' : PB allocation LMAP in CMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = LMAP GOTO 680 endif MAP( 1 : LMAP ) = TROW( 1 : LMAP ) PDEST_MASTER_ISON = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) SLAVE_ISON = PDEST_MASTER_ISON .NE. MYID IF (SLAVE_ISON) THEN IF ( PTRIST(STEP( ISON )) .EQ. 0 ) THEN CALL CMUMPS_TREAT_DESCBAND( ISON, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END IF #if ! defined(NO_FDM_MAPROW) IF ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) & THEN INFO_TMP=0 CALL MUMPS_FMRD_SAVE_MAPROW( & IW(PTRIST(STEP(ISON))+XXA), & INODE_PERE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER, & SLAVES_PERE(1:NSLAVES_PERE), & MAP, & INFO_TMP) IF (INFO_TMP(1) < 0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF GOTO 670 ELSE GOTO 10 ENDIF #endif DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END DO ENDIF #if ! defined(NO_FDM_MAPROW) 10 CONTINUE #endif IF ( NSLAVES_PERE .EQ. 0 ) THEN NBROW( 0 ) = LMAP_LOC ELSE DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) NBROW( NOSLA ) = NBROW( NOSLA ) + 1 END DO DO I = 1, NSLAVES_PERE NBROW(I)=NBROW(I)+NBROW(I-1) ENDDO ENDIF ALLOCATE(PERM_LOC(LMAP_LOC), stat=allocok) IF (allocok .GT. 0) THEN IF (LP.GT.0) THEN write(LP,*) MYID,': PB allocation PERM_LOC in CMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 670 ENDIF KEEP253_LOC = 0 DO I = LMAP_LOC, 1, -1 INDICE_PERE = MAP( I ) IF (INDICE_PERE > NFRONT_PERE - KEEP(253)) THEN KEEP253_LOC = KEEP253_LOC + 1 ENDIF CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) PERM_LOC( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO IF ((KEEP(114).EQ.1) .AND. (KEEP(50).EQ.2) .AND. & (KEEP(116).GT.0) .AND. ((LMAP_LOC-KEEP253_LOC).GT.0) & ) THEN IF (ITYPE_SON.EQ.1) THEN NELIM_L = IW(PTLUST(STEP(ISON))+1+KEEP(IXSZ)) NASS_L = NELIM_L + & IW(PTLUST(STEP(ISON))+3+KEEP(IXSZ)) IROW_L = PTLUST(STEP(ISON))+6+KEEP(IXSZ)+NASS_L NROW_L = LMAP_LOC ELSE NROW_L = LMAP_LOC NSLAVES_L = IW( PTRIST(STEP( ISON )) + 5 + KEEP(IXSZ) ) IROW_L = PTRIST(STEP(ISON)) + 6 + NSLAVES_L + KEEP(IXSZ) ENDIF CALL CMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NROW_L-KEEP253_LOC, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR ) ELSE NVSCHUR = 0 ENDIF PDEST_MASTER = SLAVES_PERE(0) I_POSMYIDIN_PERE = -99999 LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. DO I = 0, NSLAVES_PERE IF (SLAVES_PERE(I) .EQ. MYID) THEN I_POSMYIDIN_PERE = I LOCAL_ASSEMBLY_TO_BE_DONE = .TRUE. #if ! defined(NO_FDM_DESCBAND) IF (PTRIST(STEP(INODE_PERE)) .EQ. 0 & .AND. MYID .NE. PDEST_MASTER) THEN CALL CMUMPS_TREAT_DESCBAND( INODE_PERE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF #endif ENDIF END DO IF (KEEP(120).NE.0 .AND. LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL CMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, LPTRAR, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 CB_IS_LR = (IW(PTRIST(STEP(ISON))+XXLR).EQ.1 .OR. & IW(PTRIST(STEP(ISON))+XXLR).EQ.3) IWXXF_HANDLER = IW(PTRIST(STEP(ISON))+XXF) DO I = NSLAVES_PERE, 0, -1 PDEST = SLAVES_PERE( I ) IF ( PDEST .NE. MYID ) THEN DESCLU = .FALSE. NBROWS_ALREADY_SENT = 0 IF (CB_IS_LR) THEN NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ENDIF IF (I == NSLAVES_PERE) THEN NROWS_TO_SEND=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_SEND=NBROW(I+1)-NBROW(I) ENDIF PACKED_CB=(IW(PTRIST(STEP(ISON))+XXS).EQ.S_CB1COMP) IERR = -1 DO WHILE (IERR .EQ. -1) IF ( IW ( PTRIST(STEP(ISON) )+KEEP(IXSZ) ) & .GT. N + KEEP(253) ) THEN WRITE(*,*) MYID,': Internal error in Maplig' WRITE(*,*) MYID,': PTRIST(STEP(ISON))/N=', & PTRIST(STEP(ISON)), N WRITE(*,*) MYID,': I, NBROW(I)=',I, NBROW(I) WRITE(*,*) MYID,': NSLAVES_PERE=',NSLAVES_PERE WRITE(*,*) MYID,': ISON, INODE_PERE=',ISON,INODE_PERE WRITE(*,*) MYID,': Son header=', & IW(PTRIST(STEP(ISON)): PTRIST(STEP(ISON))+5+KEEP(IXSZ)) CALL MUMPS_ABORT() END IF IF (NROWS_TO_SEND .EQ. 0 .AND. PDEST.NE.PDEST_MASTER) THEN IERR = 0 CYCLE ENDIF IF (CB_IS_LR) THEN CALL CMUMPS_BUF_SEND_CONTRIB_TYPE2( NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, ISON, & NROWS_TO_SEND, LMAP_LOC, MAP, & min(LMAP_LOC,NBROW(I)), & IW( PTRIST(STEP(ISON))), & ADummy, 1_8, & I, PDEST, PDEST_MASTER, & COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PACKED_CB, & KEEP253_LOC, NVSCHUR, & ITYPE_SON, MYID ) ELSE CALL CMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) CALL CMUMPS_BUF_SEND_CONTRIB_TYPE2( NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, ISON, & NROWS_TO_SEND, LMAP_LOC, MAP, & min(LMAP_LOC,NBROW(I)), & IW( PTRIST(STEP(ISON))), & SON_A(IACHK:IACHK+RECSIZE-1_8), & RECSIZE, & I, PDEST, PDEST_MASTER, & COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PACKED_CB, & KEEP253_LOC, NVSCHUR, & ITYPE_SON, MYID) ENDIF IF ( IERR .EQ. -2 ) THEN IFLAG = -17 IF (LP .GT. 0) THEN WRITE(LP,*) & "FAILURE: SEND BUFFER TOO SMALL IN CMUMPS_MAPLIG" ENDIF IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * IW(PTRIST(STEP(ISON))+KEEP(IXSZ)) & * KEEP( 35 ) GO TO 600 END IF IF ( IERR .EQ. -3 ) THEN IF (LP .GT. 0) THEN WRITE(LP,*) & "FAILURE: RECV BUFFER TOO SMALL IN CMUMPS_MAPLIG" ENDIF IFLAG = -20 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * IW(PTRIST(STEP(ISON))+KEEP(IXSZ)) & * KEEP( 35 ) GOTO 600 ENDIF IF (KEEP(219).NE.0) THEN IF ( IERR .EQ. -4 ) THEN IFLAG = -13 IERROR = NFS4FATHER IF (LP .GT. 0) THEN WRITE(LP, *) & "FAILURE: MAX_ARRAY allocation failed IN CMUMPS_MAPLIG" ENDIF GO TO 600 END IF END IF IF ( IERR .EQ. -1 ) THEN IF (LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL CMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, & LPTRAR, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ELSE BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE,LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED=.TRUE. GOTO 600 ENDIF IF (.NOT. MESSAGE_RECEIVED) THEN CALL MUMPS_USLEEP(1000) ENDIF END IF END IF ENDDO ENDIF END DO IF (LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL CMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, LPTRAR, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF IF (CB_IS_LR) THEN IF (IWXXF_HANDLER.LE.0) CALL MUMPS_ABORT() CALL CMUMPS_BLR_FREE_CB_LRB(IWXXF_HANDLER, & .FALSE., KEEP8, KEEP(34)) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN CALL CMUMPS_BLR_END_FRONT(IWXXF_HANDLER, IFLAG, KEEP8, & KEEP(34)) ENDIF ENDIF IF (KEEP(214) .EQ. 2) THEN CALL CMUMPS_STACK_BAND( N, ISON, & PTRIST, PTRAST, PTLUST, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, & COMM, KEEP,KEEP8, DKEEP, ITYPE_SON ) IF (IFLAG .LT. 0) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF CALL CMUMPS_FREE_BAND( N, ISON, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, & STEP, MYID, KEEP, KEEP8, ITYPE_SON &) 600 CONTINUE DEALLOCATE(PERM_LOC) 670 CONTINUE DEALLOCATE(MAP) 680 CONTINUE DEALLOCATE(NBROW) DEALLOCATE(SLAVES_PERE) 700 CONTINUE IF (IFLAG .LT. 0 .AND. .NOT. IS_ERROR_BROADCASTED) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE CMUMPS_MAPLIG SUBROUTINE CMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW, & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, & LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_BUF USE MUMPS_LOAD USE CMUMPS_LR_TYPE USE MUMPS_LR_STATS USE CMUMPS_FAC_FRONT_AUX_M, ONLY : CMUMPS_GET_SIZE_SCHUR_IN_FRONT USE CMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR & , CMUMPS_DM_FREE_BLOCK IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER ICNTL( 60 ), KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER COMP INTEGER IFLAG, IERROR, COMM, MYID INTEGER LPOOL, LEAF INTEGER INODE_PERE, ISON INTEGER NFS4FATHER REAL, POINTER, DIMENSION(:) :: M_ARRAY LOGICAL :: M_ARRAY_RETRIEVED INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE(NSLAVES_PERE) INTEGER NELIM, LMAP, TROW( LMAP ), NASS DOUBLE PRECISION OPASSW, OPELIW COMPLEX DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPTRAR, NELT INTEGER IW( LIW ) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ) INTEGER NSTK( KEEP(28) ), ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PERM(N) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) 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 NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT INTEGER INDICE_PERE INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER PDEST, PDEST_MASTER, NFRONT LOGICAL SAME_PROC, DESCLU INTEGER(8) :: IACHK, POSROW, ASIZE, RECSIZE COMPLEX, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYNSIZE INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND, & NPIV, NROWS_TO_STACK, II, IROW_SON, & IPOS_IN_SLAVE, DECR, ITYPE_SON INTEGER NBCOLS_EFF LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL PACKED_CB LOGICAL :: CB_IS_LR INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR_COLS, NB_BLR_ROWS, & NB_BLR_SHIFT, PANEL2DECOMPRESS, & CURRENT_PANEL_SIZE, PANEL_BEG_OFFSET, & NROWS_ALREADY_STACKED, NROWS_TO_STACK_LOC INTEGER :: ICOL_BEG, ICOL_END INTEGER :: IROW_BEG, IROW_END INTEGER :: IBLOCK, MAXI_CLUSTER DOUBLE PRECISION :: PROMOTE_COST INTEGER :: NVSCHUR, IROW_L INTEGER(8) :: LA_TEMP COMPLEX :: ADummy(1) COMPLEX, ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: LRB TYPE (LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER :: XXG_STATUS INCLUDE 'mumps_headers.h' COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM_LOC LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 if (NSLAVES_PERE.le.0) then write(6,*) ' error 2 in maplig_fils_niv1 ', NSLAVES_PERE CALL MUMPS_ABORT() endif ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) IF (allocok .GT. 0) THEN IF (LP > 0) & write(LP,*) MYID, & ' : PB allocation NBROW in CMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF ALLOCATE(SLAVES_PERE(0:NSLAVES_PERE), stat =allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in CMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) LMAP_LOC = LMAP ALLOCATE(MAP(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation LMAP in CMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = LMAP_LOC GOTO 700 endif MAP( 1 : LMAP_LOC ) = TROW( 1 : LMAP_LOC ) DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO IF (NSLAVES_PERE == 0) THEN NBROW(0) = LMAP_LOC ELSE DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) NBROW( NOSLA ) = NBROW( NOSLA ) + 1 END DO DO I = 1, NSLAVES_PERE NBROW(I)=NBROW(I)+NBROW(I-1) ENDDO ENDIF ALLOCATE(PERM_LOC(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) THEN write(LP,*) MYID, & ': PB allocation PERM_LOC in CMUMPS_MAPLIG_FILS_NIV1' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 700 endif ISTCHK = PIMASTER(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) DO I = LMAP_LOC, 1, -1 INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) PERM_LOC( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO PDEST_MASTER = MYID IF ( SLAVES_PERE(0) .NE. MYID ) THEN WRITE(*,*) 'Error 1 in MAPLIG_FILS_NIV1:',MYID, SLAVES_PERE CALL MUMPS_ABORT() END IF PDEST = PDEST_MASTER I = 0 ISTCHK = PIMASTER(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) NELIM = IW(ISTCHK+1+KEEP(IXSZ)) NROW = IW(ISTCHK+2+KEEP(IXSZ)) NPIV = IW(ISTCHK+3+KEEP(IXSZ)) NASS = NPIV+NELIM IF (NPIV.LT.0) THEN write(6,*) ' Error 2 in CMUMPS_MAPLIG_FILS_NIV1 ', NPIV CALL MUMPS_ABORT() ENDIF NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) NFRONT = NPIV + NBCOLS PACKED_CB=(IW(PTRIST(STEP(ISON))+XXS) .eq. S_CB1COMP) IF (I == NSLAVES_PERE) THEN NROWS_TO_STACK=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_STACK=NBROW(I+1)-NBROW(I) ENDIF IF ((KEEP(114).EQ.1) .AND. (KEEP(50).EQ.2) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) + NASS CALL CMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR ) ELSE NVSCHUR = 0 ENDIF DECR=1 IW(PTLUST(STEP(INODE_PERE))+XXNBPR) = & IW(PTLUST(STEP(INODE_PERE))+XXNBPR) - DECR IW(PTRIST(STEP(ISON))+XXNBPR) = & IW(PTRIST(STEP(ISON))+XXNBPR) - DECR CB_IS_LR = (IW(ISTCHK+XXLR).EQ.1 .OR. & IW(ISTCHK+XXLR).EQ.3) NROWS_ALREADY_STACKED = 0 IF (CB_IS_LR) THEN 100 CONTINUE IF (NROWS_TO_STACK.GT.0) THEN PANEL_BEG_OFFSET = 0 CALL CMUMPS_BLR_RETRIEVE_CB_LRB( & IW(ISTCHK+XXF), CB_LRB) CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR) NB_BLR_ROWS = size(BEGS_BLR) - 1 CALL CMUMPS_BLR_RETRIEVE_NB_PANELS(IW(ISTCHK+XXF), & NB_BLR_SHIFT) PANEL2DECOMPRESS = -1 DO II=NB_BLR_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR(II+1)-1-NASS.GT. & NROWS_ALREADY_STACKED+NBROW(I)-1) THEN PANEL2DECOMPRESS = II EXIT ENDIF ENDDO IF (PANEL2DECOMPRESS.EQ.-1) THEN write(*,*) 'Internal error: PANEL2DECOMPRESS not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR) - 1 ELSE NB_BLR_COLS = PANEL2DECOMPRESS ENDIF CURRENT_PANEL_SIZE = BEGS_BLR(PANEL2DECOMPRESS+1) & - BEGS_BLR(PANEL2DECOMPRESS) PANEL_BEG_OFFSET = NBROW(I) + NROWS_ALREADY_STACKED & - BEGS_BLR(PANEL2DECOMPRESS) + NASS NROWS_TO_STACK_LOC = & min(NROWS_TO_STACK-NROWS_ALREADY_STACKED, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) MAXI_CLUSTER = 1 DO IBLOCK=1,NB_BLR_COLS-NB_BLR_SHIFT LRB => CB_LRB(PANEL2DECOMPRESS-NB_BLR_SHIFT,IBLOCK) MAXI_CLUSTER = max(MAXI_CLUSTER, LRB%N) ENDDO LA_TEMP = NROWS_TO_STACK_LOC*MAXI_CLUSTER #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(A_TEMP, LRB, II, IBLOCK, ICOL_BEG, ICOL_END, !$OMP& allocok, PROMOTE_COST, IROW_SON, INDICE_PERE, !$OMP& POSROW, NBCOLS_EFF, IROW_BEG, IROW_END, !$OMP& INDICE_PERE_ARRAY_ARG, NOSLA, IPOS_IN_SLAVE) #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 GOTO 550 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP DO SCHEDULE(dynamic,1) #endif DO IBLOCK=1,NB_BLR_COLS-NB_BLR_SHIFT IF (IFLAG.LT.0) CYCLE ICOL_BEG = 1 DO II = 1,IBLOCK-1 LRB => CB_LRB(PANEL2DECOMPRESS-NB_BLR_SHIFT,II) ICOL_BEG = ICOL_BEG + LRB%N ENDDO LRB => CB_LRB(PANEL2DECOMPRESS-NB_BLR_SHIFT,IBLOCK) IF (LRB%ISLR .AND. LRB%K.EQ.0) CYCLE IROW_BEG = PANEL_BEG_OFFSET+1 IROW_END = PANEL_BEG_OFFSET+NROWS_TO_STACK_LOC IF (LRB%ISLR) THEN CALL cgemm('T','T', LRB%N, NROWS_TO_STACK_LOC, LRB%K, & ONE, LRB%R(1,1), LRB%K, LRB%Q(IROW_BEG,1), & LRB%M, ZERO, A_TEMP(1), LRB%N) PROMOTE_COST = 2.0D0*LRB%N*NROWS_TO_STACK_LOC*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE DO II = IROW_BEG, IROW_END A_TEMP( 1+(II-IROW_BEG)*LRB%N : (II-IROW_BEG+1)*LRB%N ) & = LRB%Q(II,1:LRB%N) ENDDO ENDIF CALL CMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON=PERM_LOC(NBROW(I)+II-1) INDICE_PERE = MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF (PACKED_CB) THEN POSROW = IACHK + & int(NELIM+IROW_SON,8)*int(NELIM+IROW_SON-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+IROW_SON-1,8)*int(NBCOLS,8) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = NELIM + IROW_SON ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE ICOL_END = min(ICOL_BEG+LRB%N-1, NBCOLS_EFF) CALL CMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, ICOL_END-ICOL_BEG+1, & INDICE_PERE_ARRAY_ARG, & A_TEMP(1+(II-NROWS_ALREADY_STACKED-1)*LRB%N), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS,ICOL_BEG) ENDDO ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO #endif IF (IFLAG.LT.0) GOTO 550 deallocate(A_TEMP) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) 550 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 NROWS_ALREADY_STACKED = NROWS_ALREADY_STACKED & + NROWS_TO_STACK_LOC IF (NROWS_ALREADY_STACKED.LT.NROWS_TO_STACK) THEN GOTO 100 ENDIF ENDIF ELSE CALL CMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK IROW_SON=PERM_LOC(NBROW(I)+II-1) INDICE_PERE = MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF (PACKED_CB) THEN POSROW = IACHK + & int(NELIM+IROW_SON,8)*int(NELIM+IROW_SON-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+IROW_SON-1,8)*int(NBCOLS,8) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = NELIM + IROW_SON ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE CALL CMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS_EFF,1) ENDDO ENDIF IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2 & .AND. NFS4FATHER .GT. 0) THEN IF (CB_IS_LR) THEN CALL CMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW(ISTCHK+XXF), M_ARRAY) M_ARRAY_RETRIEVED = .TRUE. ELSE IF (PACKED_CB) THEN POSROW = IACHK & + int(NELIM+NBROW(1),8)*int(NELIM+NBROW(1)-1,8)/2_8 ASIZE = int(LMAP_LOC+NELIM,8)*int(NELIM+LMAP_LOC+1,8)/2_8 & - int(NELIM+NBROW(1),8)*int(NELIM+NBROW(1)-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+NBROW(1)-1,8)*int(NBCOLS,8) ASIZE = int(LMAP_LOC-NBROW(1)+1,8) * int(NBCOLS,8) ENDIF CALL CMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP > 0) WRITE(LP,*) MYID, & ": PB allocation MAX_ARRAY during CMUMPS_MAPLIG_FILS_NIV1" IFLAG=-13 IERROR=NFS4FATHER GOTO 700 ENDIF IF ( LMAP_LOC-NBROW(1)+1-KEEP(253)-NVSCHUR.GT. 0 ) THEN CALL CMUMPS_COMPUTE_MAXPERCOL( & SON_A(POSROW),ASIZE,NBCOLS, & LMAP_LOC-NBROW(1)+1-KEEP(253)-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB, & NELIM+NBROW(1)) ELSE CALL CMUMPS_SETMAXTOZERO(BUF_MAX_ARRAY, & NFS4FATHER) ENDIF M_ARRAY => BUF_MAX_ARRAY M_ARRAY_RETRIEVED = .FALSE. ENDIF CALL CMUMPS_ASM_MAX(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & M_ARRAY(1), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB,MYID, KEEP,KEEP8) IF ( M_ARRAY_RETRIEVED ) & CALL CMUMPS_BLR_FREE_M_ARRAY ( IW(ISTCHK+XXF) ) ENDIF ENDIF IF (IW(PTRIST(STEP(ISON))+XXNBPR) .EQ. 0 & ) THEN ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF (SAME_PROC) THEN CALL CMUMPS_RESTORE_INDICES(N, ISON, INODE_PERE, & IWPOSCB, PIMASTER, PTLUST, IW, LIW, STEP, & KEEP,KEEP8) ENDIF ENDIF IF ( IW(PTLUST(STEP(INODE_PERE))+XXNBPR) .EQ. 0 & ) THEN CALL CMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, INODE_PERE+N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 DO I = 0, NSLAVES_PERE PDEST = SLAVES_PERE( I ) IF ( PDEST .NE. MYID ) THEN NBROWS_ALREADY_SENT = 0 IF (CB_IS_LR) THEN NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ENDIF 95 CONTINUE NFRONT = IW(PIMASTER(STEP(ISON))+KEEP(IXSZ)) NELIM = IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) DESCLU = .TRUE. IF (I == NSLAVES_PERE) THEN NROWS_TO_SEND=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_SEND=NBROW(I+1)-NBROW(I) ENDIF IF ( NROWS_TO_SEND .EQ. 0) CYCLE ITYPE_SON = MUMPS_TYPENODE( PROCNODE_STEPS(STEP(ISON)), & KEEP(199) ) IF (CB_IS_LR) THEN CALL CMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NROWS_TO_SEND, LMAP_LOC, & MAP, min(LMAP_LOC,NBROW(I)), & IW(PIMASTER(STEP(ISON))), & ADummy, 1_8, & I, PDEST, PDEST_MASTER, COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP(253), NVSCHUR, & ITYPE_SON, MYID ) ELSE CALL CMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) CALL CMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NROWS_TO_SEND, LMAP_LOC, & MAP, min(LMAP_LOC,NBROW(I)), & IW(PIMASTER(STEP(ISON))), & SON_A(IACHK:IACHK+RECSIZE-1_8), & RECSIZE, & I, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP(253), NVSCHUR, & ITYPE_SON, MYID) ENDIF IF ( IERR .EQ. -2 ) THEN IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING CMUMPS_MAPLIG_FILS_NIV1" IFLAG = -17 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * KEEP( 35 ) GO TO 700 END IF IF ( IERR .EQ. -3 ) THEN IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING CMUMPS_MAPLIG_FILS_NIV1" IFLAG = -20 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * KEEP( 35 ) GO TO 700 ENDIF IF (KEEP(219).NE.0) THEN IF ( IERR .EQ. -4 ) THEN IFLAG = -13 IERROR = BUF_LMAX_ARRAY IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, MAX_ARRAY ALLOC FAILED DURING CMUMPS_MAPLIG_FILS_NIV1" GO TO 700 ENDIF ENDIF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 GO TO 95 END IF END IF END DO ISTCHK = PTRIST(STEP(ISON)) PTRIST(STEP( ISON )) = -77777777 IF ( IW(ISTCHK+KEEP(IXSZ)) .GE. 0 ) THEN WRITE(*,*) 'error 3 in CMUMPS_MAPLIG_FILS_NIV1' CALL MUMPS_ABORT() ENDIF CALL MUMPS_GETI8(DYNSIZE,IW(ISTCHK+XXD)) XXG_STATUS = IW(ISTCHK+XXG) CALL CMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) IF (DYNSIZE .GT. 0_8) THEN CALL CMUMPS_DM_FREE_BLOCK( XXG_STATUS, SON_A, DYNSIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF GOTO 600 700 CONTINUE CALL CMUMPS_BDC_ERROR(MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF (CB_IS_LR) THEN CALL CMUMPS_BLR_FREE_CB_LRB(IW(ISTCHK+XXF), & .FALSE., KEEP8, KEEP(34)) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN CALL CMUMPS_BLR_END_FRONT(IW(ISTCHK+XXF), IFLAG, KEEP8, & KEEP(34)) ENDIF ENDIF IF (allocated(NBROW)) DEALLOCATE(NBROW) IF (allocated(MAP)) DEALLOCATE(MAP) IF (allocated(PERM_LOC)) DEALLOCATE(PERM_LOC) IF (allocated(SLAVES_PERE)) DEALLOCATE(SLAVES_PERE) RETURN END SUBROUTINE CMUMPS_MAPLIG_FILS_NIV1 SUBROUTINE CMUMPS_LOCAL_ASSEMBLY_TYPE2(I, PDEST, MYID, & PDEST_MASTER, ISON, IFATH, NSLAVES_PERE, NASS_PERE, & NFRONT_PERE, NFS4FATHER, LMAP_LOC, MAP, & NBROW, PERM, IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, & IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, & LPTRAR, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & SON_NIV, LRGROUPS) USE CMUMPS_BUF, ONLY: CMUMPS_BUF_MAX_ARRAY_MINSIZE, & BUF_MAX_ARRAY USE CMUMPS_LR_TYPE USE MUMPS_LR_STATS USE CMUMPS_LR_DATA_M USE MUMPS_LOAD, ONLY : MUMPS_LOAD_POOL_UPD_NEW_POOL USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR & , CMUMPS_DM_SET_PTR, CMUMPS_DM_FREE_BLOCK IMPLICIT NONE INTEGER ICNTL(60) INTEGER, intent(in) :: I, PDEST, MYID, PDEST_MASTER, IFATH, ISON INTEGER, intent(in) :: N, SLAVEF INTEGER, intent(in) :: NSLAVES_PERE, NASS_PERE, NFRONT_PERE INTEGER, intent(in) :: NFS4FATHER INTEGER, intent(in) :: KEEP(500), STEP(N) INTEGER, intent(in) :: LMAP_LOC INTEGER, intent(in) :: NBROW(0:NSLAVES_PERE) INTEGER, intent(in) :: MAP(LMAP_LOC), PERM(LMAP_LOC) INTEGER, intent(inout) :: IFLAG, IERROR INTEGER(8), intent(inout) :: KEEP8(150) INTEGER, intent(in) :: LIW, NELT, LPTRAR INTEGER(8), intent(in) :: LA INTEGER(8), intent(inout) :: IPTRLU, LRLU, LRLUS INTEGER, intent(inout) :: IWPOSCB INTEGER, intent(inout) :: IW(LIW) COMPLEX, intent(inout) :: A( LA ) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER :: PTRIST(KEEP(28)), PIMASTER(KEEP(28)), ND(KEEP(28)) INTEGER :: PTLUST(KEEP(28)) INTEGER, intent(inout) :: ITLOC(N) INTEGER, intent(in) :: FRTPTR( N+1 ), FRTELT( NELT ) DOUBLE PRECISION, intent(inout) :: OPASSW, OPELIW COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER, intent(in) :: KEEP253_LOC, NVSCHUR INTEGER, intent(in) :: FILS(N), DAD( KEEP(28) ) INTEGER(8), intent(in) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER, intent(in) :: PROCNODE_STEPS( KEEP(28) ), COMM_LOAD INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) COMPLEX DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPOOL INTEGER IPOOL( LPOOL ) LOGICAL, intent(in) :: IS_ofType5or6 INTEGER, intent(in) :: SON_NIV INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INTEGER :: XXG_STATUS INTEGER :: ISTCHK, ISTCHK_LOC, NBCOLS, & NROW, NPIV, NSLSON, & NFRONT, LDA_SON, NROWS_TO_STACK, II, INDICE_PERE, & NOSLA, COLLIST, IPOS_IN_SLAVE, IROW_SON, ITMP, & NBCOLS_EFF, DECR, NELIM INTEGER :: NB_POSTPONED LOGICAL :: PACKED_CB, SAME_PROC INTEGER(8) :: SIZFR, POSROW, SHIFTCB_SON INTEGER(8) :: IACHK INTEGER :: SON_XXS COMPLEX, DIMENSION(:), POINTER :: SON_A COMPLEX, DIMENSION(:), POINTER :: SON_A_MASTER INTEGER(8) :: DYN_SIZE INTEGER :: IERR, LP INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER :: INBPROCFILS_SON LOGICAL :: CB_IS_LR REAL, POINTER, DIMENSION(:) :: M_ARRAY LOGICAL :: M_ARRAY_RETRIEVED INTEGER(8) :: POSELT INTEGER :: IOLDPS, PARPIV_T1 LOGICAL :: LR_ACTIVATED INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL, & BEGS_BLR_STA INTEGER :: NB_BLR_COLS, NB_BLR_ROWS, & NB_COL_SHIFT, PANEL2DECOMPRESS, & CURRENT_PANEL_SIZE, PANEL_BEG_OFFSET, & allocok, NROWS_ALREADY_STACKED, NROWS_TO_STACK_LOC, & NB_ROW_SHIFT, NASS_SHIFT, NCOL_SHIFT, NROW_SHIFT INTEGER :: ICOL_BEG, ICOL_END INTEGER :: IROW_BEG, IROW_END INTEGER :: IBLOCK, MAXI_CLUSTER DOUBLE PRECISION :: PROMOTE_COST INTEGER(8) :: LA_TEMP COMPLEX, ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: LRB TYPE (LRB_TYPE), POINTER :: CB_LRB(:,:) COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 IF (I == NSLAVES_PERE) THEN NROWS_TO_STACK = LMAP_LOC - NBROW(I) + 1 ELSE NROWS_TO_STACK = NBROW(I+1) - NBROW(I) ENDIF DECR = 1 IF ( MYID .EQ. PDEST_MASTER ) THEN IW(PTLUST(STEP(IFATH))+XXNBPR) = & IW(PTLUST(STEP(IFATH))+XXNBPR) - DECR IF ( PDEST .EQ. PDEST_MASTER .AND. DECR .NE. 0) THEN IW(PIMASTER(STEP(ISON))+XXNBPR) = & IW(PIMASTER(STEP(ISON))+XXNBPR) - DECR ENDIF ENDIF ISTCHK = PTRIST(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) NROW = IW(ISTCHK+2+KEEP(IXSZ)) NPIV = IW(ISTCHK+3+KEEP(IXSZ)) NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) NFRONT = NPIV + NBCOLS SON_XXS = IW(ISTCHK+XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) CALL CMUMPS_DM_SET_DYNPTR( & SON_XXS, & A, LA, & PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR) CB_IS_LR = (IW(ISTCHK+XXLR).EQ.1 .OR. & IW(ISTCHK+XXLR).EQ.3) IF (CB_IS_LR.AND.IS_ofType5or6) THEN write(*,*) 'Compress CB + Type5or6 fronts not coded yet!!' CALL MUMPS_ABORT() ENDIF NELIM = -9999 IF (CB_IS_LR.AND.(SON_NIV.EQ.1).AND. & KEEP(50).NE.0) THEN ISTCHK_LOC = PTLUST(STEP(ISON)) NELIM = IW(ISTCHK_LOC+1+KEEP(IXSZ)) NPIV = IW(ISTCHK_LOC+3+KEEP(IXSZ)) NFRONT = IW(ISTCHK_LOC+2+KEEP(IXSZ)) NROW = NFRONT - NPIV NFRONT = NBCOLS NPIV = 0 ENDIF IF (CB_IS_LR) THEN LDA_SON = NBCOLS SHIFTCB_SON = -9999 ELSE IF (SON_XXS.EQ.S_NOLCBCONTIG ) THEN LDA_SON = NBCOLS SHIFTCB_SON = int(NPIV,8)*int(NROW,8) ELSE IF (IW(ISTCHK+XXS).EQ.S_NOLCLEANED) THEN LDA_SON = NBCOLS SHIFTCB_SON = 0_8 ELSE LDA_SON = NFRONT SHIFTCB_SON = int(NPIV,8) ENDIF ENDIF IF (PDEST .NE. PDEST_MASTER) THEN IF ( KEEP(55) .eq. 0 ) THEN CALL CMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, IFATH, IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ELSE CALL CMUMPS_ELT_ASM_S_2_S_INIT(NELT, FRTPTR, FRTELT, & N, IFATH, IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP, KEEP8, MYID, LRGROUPS ) ENDIF ENDIF NROWS_ALREADY_STACKED = 0 100 CONTINUE NROWS_TO_STACK_LOC = NROWS_TO_STACK PANEL_BEG_OFFSET = 0 IF (CB_IS_LR) THEN IF (NROWS_TO_STACK.GT.0) THEN CALL CMUMPS_BLR_RETRIEVE_CB_LRB( & IW(ISTCHK+XXF), CB_LRB) IF (SON_NIV.EQ.1) THEN CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR_ROW) CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_DYN( & IW(ISTCHK+XXF), BEGS_BLR_COL) NB_BLR_ROWS = size(BEGS_BLR_ROW) - 1 CALL CMUMPS_BLR_RETRIEVE_NB_PANELS(IW(ISTCHK+XXF), & NB_COL_SHIFT) NB_ROW_SHIFT = NB_COL_SHIFT NASS_SHIFT = BEGS_BLR_ROW(NB_ROW_SHIFT+1)-1 ELSE CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR_STA) NB_BLR_ROWS = size(BEGS_BLR_STA) - 2 BEGS_BLR_ROW => BEGS_BLR_STA(2:NB_BLR_ROWS+2) CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_C( & IW(ISTCHK+XXF), BEGS_BLR_COL, & NB_COL_SHIFT) NB_ROW_SHIFT = 0 NASS_SHIFT = 0 ENDIF PANEL2DECOMPRESS = -1 DO II=NB_ROW_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR_ROW(II+1)-1-NASS_SHIFT.GT. & NROWS_ALREADY_STACKED+NBROW(I)-1) THEN PANEL2DECOMPRESS = II EXIT ENDIF ENDDO IF (PANEL2DECOMPRESS.EQ.-1) THEN write(*,*) 'Internal error: PANEL2DECOMPRESS not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR_COL) - 1 ELSEIF (SON_NIV.EQ.1) THEN NB_BLR_COLS = PANEL2DECOMPRESS ELSE NB_BLR_COLS = -1 NCOL_SHIFT = NPIV NROW_SHIFT = NBCOLS-NROW DO II=NB_COL_SHIFT+1,size(BEGS_BLR_COL)-1 IF (BEGS_BLR_COL(II+1)-NCOL_SHIFT.GT. & BEGS_BLR_ROW(PANEL2DECOMPRESS+1)-1+NROW_SHIFT) THEN NB_BLR_COLS = II EXIT ENDIF ENDDO IF (NB_BLR_COLS.EQ.-1) THEN write(*,*) 'Internal error: NB_BLR_COLS not found' CALL MUMPS_ABORT() ENDIF ENDIF CURRENT_PANEL_SIZE = BEGS_BLR_ROW(PANEL2DECOMPRESS+1) & - BEGS_BLR_ROW(PANEL2DECOMPRESS) PANEL_BEG_OFFSET = NBROW(I) + NROWS_ALREADY_STACKED & - BEGS_BLR_ROW(PANEL2DECOMPRESS) + NASS_SHIFT NROWS_TO_STACK_LOC = & min(NROWS_TO_STACK-NROWS_ALREADY_STACKED, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) MAXI_CLUSTER = 1 DO IBLOCK=1,NB_BLR_COLS-NB_COL_SHIFT LRB => CB_LRB(PANEL2DECOMPRESS-NB_ROW_SHIFT,IBLOCK) MAXI_CLUSTER = max(MAXI_CLUSTER, LRB%N) ENDDO LA_TEMP = NROWS_TO_STACK_LOC*MAXI_CLUSTER #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(A_TEMP, LRB, II, IBLOCK, ICOL_BEG, ICOL_END, !$OMP& allocok, PROMOTE_COST, IROW_BEG, IROW_END, IROW_SON, !$OMP& INDICE_PERE, ITMP, POSROW, NBCOLS_EFF, ISTCHK, !$OMP& ISTCHK_LOC, COLLIST, NOSLA, IPOS_IN_SLAVE, !$OMP& INDICE_PERE_ARRAY_ARG) #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 GOTO 550 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP DO SCHEDULE(dynamic,1) #endif DO IBLOCK=1,NB_BLR_COLS-NB_COL_SHIFT IF (IFLAG.LT.0) CYCLE ICOL_BEG = 1 DO II = 1,IBLOCK-1 LRB => CB_LRB(PANEL2DECOMPRESS-NB_ROW_SHIFT,II) ICOL_BEG = ICOL_BEG + LRB%N ENDDO LRB => CB_LRB(PANEL2DECOMPRESS-NB_ROW_SHIFT,IBLOCK) IF (LRB%ISLR .AND. LRB%K.EQ.0) CYCLE IROW_BEG = PANEL_BEG_OFFSET+1 IROW_END = PANEL_BEG_OFFSET+NROWS_TO_STACK_LOC IF (LRB%ISLR) THEN CALL cgemm('T','T', LRB%N, NROWS_TO_STACK_LOC, LRB%K, & ONE, LRB%R(1,1), LRB%K, LRB%Q(IROW_BEG,1), & LRB%M, ZERO, A_TEMP(1), LRB%N) PROMOTE_COST = 2.0D0*LRB%N*NROWS_TO_STACK_LOC*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE DO II = IROW_BEG, IROW_END A_TEMP( 1+(II-IROW_BEG)*LRB%N : & (II-IROW_BEG+1)*LRB%N ) = LRB%Q(II,1:LRB%N) ENDDO ENDIF DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON = PERM(NBROW(I)+II-1) INDICE_PERE=MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IFATH, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF ( PACKED_CB ) THEN ITMP = IROW_SON + NBCOLS - NROW POSROW = IACHK & + int(ITMP,8) * int(ITMP-1,8) / 2_8 & - int(NBCOLS-NROW,8) * int(NBCOLS-NROW+1,8)/2_8 ELSE POSROW = IACHK + SHIFTCB_SON & +int(IROW_SON-1,8)*int(LDA_SON,8) ENDIF IF (PDEST .EQ. 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 ICOL_END = min(ICOL_BEG+LRB%N-1, NBCOLS_EFF) CALL CMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, ICOL_END - ICOL_BEG + 1, & INDICE_PERE_ARRAY_ARG, & A_TEMP(1+(II-NROWS_ALREADY_STACKED-1)*LRB%N), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, NBCOLS, ICOL_BEG ) ELSE ISTCHK = PTRIST(STEP(ISON)) COLLIST = ISTCHK + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) + NROW + NPIV IF ((SON_NIV.EQ.1).AND. KEEP(50).NE.0) THEN ISTCHK_LOC = PTLUST(STEP(ISON)) COLLIST = ISTCHK_LOC + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) & + IW(ISTCHK_LOC+2+KEEP(IXSZ)) & + IW(ISTCHK_LOC+3+KEEP(IXSZ)) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = IROW_SON + NBCOLS - NROW IF (SON_NIV.EQ.1) THEN NBCOLS_EFF = IROW_SON + NBCOLS - (NROW-NELIM) ENDIF ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE ICOL_END = min(ICOL_BEG+LRB%N-1, NBCOLS_EFF) CALL CMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, ICOL_END-ICOL_BEG+1, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST + ICOL_BEG - 1 ), & A_TEMP(1+(II-NROWS_ALREADY_STACKED-1)*LRB%N), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, NBCOLS) ENDIF ENDDO ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO #endif IF (IFLAG.LT.0) GOTO 550 deallocate(A_TEMP) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) 550 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) RETURN IF (PDEST .NE. PDEST_MASTER) THEN IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - NROWS_TO_STACK_LOC ENDIF NROWS_ALREADY_STACKED = NROWS_ALREADY_STACKED & + NROWS_TO_STACK_LOC IF (NROWS_ALREADY_STACKED.LT.NROWS_TO_STACK) THEN GOTO 100 ENDIF ENDIF ELSE DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON = PERM(NBROW(I)+II-1) INDICE_PERE=MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IFATH, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF ( PACKED_CB ) THEN ITMP = IROW_SON + NBCOLS - NROW POSROW = IACHK & + int(ITMP,8) * int(ITMP-1,8) / 2_8 & - int(NBCOLS-NROW,8) * int(NBCOLS-NROW+1,8)/2_8 ELSE POSROW = IACHK + SHIFTCB_SON & +int(IROW_SON-1,8)*int(LDA_SON,8) ENDIF IF (PDEST == PDEST_MASTER) THEN IF (KEEP(50).NE.0) THEN NBCOLS_EFF = IROW_SON + NBCOLS - NROW ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE IF ((IS_ofType5or6).AND.(KEEP(50).EQ.0)) THEN CALL CMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON, 1 & ) EXIT ELSE IF ( (KEEP(50).NE.0) .AND. & (.NOT.PACKED_CB).AND.(IS_ofType5or6) ) THEN CALL CMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, & NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON, 1 & ) EXIT ELSE CALL CMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON, 1 ) 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.PACKED_CB) ) & ) & ) THEN CALL CMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), SON_A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - NROWS_TO_STACK EXIT ELSE CALL CMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), SON_A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - 1 ENDIF ENDIF ENDDO ENDIF IF (PDEST.EQ.PDEST_MASTER) THEN IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2 & .AND. NFS4FATHER .GT. 0) THEN IF (CB_IS_LR) THEN CALL CMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW(ISTCHK+XXF), M_ARRAY) M_ARRAY_RETRIEVED = .TRUE. ELSE IF (PACKED_CB) THEN WRITE(*,*) "Error 1 in PARPIV/CMUMPS_MAPLIG" CALL MUMPS_ABORT() ELSE POSROW = IACHK + SHIFTCB_SON+ & int(NBROW(1)-1,8)*int(LDA_SON,8) ENDIF CALL CMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP .GT. 0) THEN WRITE(LP, *) "MAX_ARRAY allocation failed" ENDIF IFLAG=-13 IERROR=NFS4FATHER RETURN ENDIF ITMP=-9999 IF (LMAP_LOC-NBROW(1)+1-KEEP253_LOC-NVSCHUR.NE.0) & THEN CALL CMUMPS_COMPUTE_MAXPERCOL( & SON_A(POSROW), & SIZFR-SHIFTCB_SON-int(NBROW(1)-1,8)*int(LDA_SON,8), & LDA_SON, & LMAP_LOC-NBROW(1)+1-KEEP253_LOC-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB,ITMP) ELSE CALL CMUMPS_SETMAXTOZERO( & BUF_MAX_ARRAY, NFS4FATHER) ENDIF M_ARRAY => BUF_MAX_ARRAY(1:size(BUF_MAX_ARRAY)) M_ARRAY_RETRIEVED = .FALSE. ENDIF CALL CMUMPS_ASM_MAX(N, IFATH, IW, LIW, & A, LA, ISON, NFS4FATHER, & M_ARRAY(1), PTLUST, PTRAST, & STEP, PIMASTER, & OPASSW,IWPOSCB,MYID, KEEP,KEEP8) IF ( M_ARRAY_RETRIEVED ) & CALL CMUMPS_BLR_FREE_M_ARRAY ( IW(ISTCHK+XXF) ) ENDIF ENDIF ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF ( SAME_PROC ) THEN INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR WRITE(*,*) & "Internal error 0 in CMUMPS_LOCAL_ASSEMBLY_TYPE2", & INBPROCFILS_SON, PIMASTER(STEP(ISON)) CALL MUMPS_ABORT() ELSE INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ENDIF IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN IF (SAME_PROC) THEN CALL CMUMPS_RESTORE_INDICES(N, ISON, IFATH, & IWPOSCB, PIMASTER, PTLUST, IW, LIW, STEP, & KEEP,KEEP8) ENDIF IF (SAME_PROC) THEN ISTCHK_LOC = PTRIST(STEP(ISON)) PTRIST(STEP( ISON) ) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_LOC+XXD)) XXG_STATUS = IW(ISTCHK_LOC+XXG) IF (DYN_SIZE .GT. 0_8) THEN CALL CMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), & DYN_SIZE, SON_A_MASTER ) ENDIF CALL CMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., MYID, N, & ISTCHK_LOC, & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) IF (DYN_SIZE .GT. 0_8) THEN CALL CMUMPS_DM_FREE_BLOCK( XXG_STATUS, SON_A_MASTER, & DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF IF ( IW(PTLUST(STEP(IFATH))+XXNBPR) .EQ. 0 & ) THEN IOLDPS = PTLUST(STEP(IFATH)) IF (NSLAVES_PERE.EQ.0) THEN POSELT = PTRAST(STEP(IFATH)) PARPIV_T1 = -999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) NB_POSTPONED = max(NFRONT - ND(STEP(IFATH)),0) CALL CMUMPS_PARPIVT1_SET_NVSCHUR_MAX ( & N, IFATH, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT_PERE, NASS_PERE, LR_ACTIVATED, PARPIV_T1, & NB_POSTPONED ) ENDIF CALL CMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, IFATH+N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF ELSE CALL CMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, IFATH, IW, LIW, & NBROW(I), STEP, PTRIST, ITLOC, RHS_MUMPS, & KEEP,KEEP8) END IF RETURN END SUBROUTINE CMUMPS_LOCAL_ASSEMBLY_TYPE2 MUMPS_5.8.1/src/lr_stats.F0000664000175000017500000005726615042446423015213 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_LR_STATS IMPLICIT NONE DOUBLE PRECISION :: MRY_CB_FR, & MRY_CB_LRGAIN, & MRY_LU_FR, & MRY_LU_LRGAIN, & GLOBAL_MRY_LPRO_COMPR, & GLOBAL_MRY_LTOT_COMPR INTEGER :: CNT_NODES DOUBLE PRECISION :: FLOP_LRGAIN, & FLOP_FACTO_FR, & FLOP_FACTO_LR, & FLOP_PANEL, & FLOP_TRSM, & FLOP_TRSM_FR, & FLOP_TRSM_LR, & FLOP_UPDATE_FR, & FLOP_UPDATE_LR, & FLOP_UPDATE_LRLR1, & FLOP_UPDATE_LRLR2, & FLOP_UPDATE_LRLR3, & FLOP_UPDATE_FRLR, & FLOP_UPDATE_FRFR DOUBLE PRECISION :: FLOP_COMPRESS, & FLOP_CB_COMPRESS, & FLOP_MIDBLK_COMPRESS, & FLOP_FRSWAP_COMPRESS, & FLOP_ACCUM_COMPRESS, & FLOP_DECOMPRESS, & FLOP_CB_DECOMPRESS, & FLOP_FRFRONTS DOUBLE PRECISION :: FACTOR_PROCESSED_FRACTION INTEGER(KIND=8) :: FACTOR_SIZE DOUBLE PRECISION :: TOTAL_FLOP DOUBLE PRECISION :: TIME_UPDATE DOUBLE PRECISION :: TIME_UPDATE_LRLR1 DOUBLE PRECISION :: TIME_UPDATE_LRLR2 DOUBLE PRECISION :: TIME_UPDATE_LRLR3 DOUBLE PRECISION :: TIME_UPDATE_FRLR DOUBLE PRECISION :: TIME_UPDATE_FRFR DOUBLE PRECISION :: TIME_COMPRESS DOUBLE PRECISION :: TIME_MIDBLK_COMPRESS DOUBLE PRECISION :: TIME_FRSWAP_COMPRESS DOUBLE PRECISION :: TIME_CB_COMPRESS DOUBLE PRECISION :: TIME_LR_MODULE DOUBLE PRECISION :: TIME_UPD_NELIM DOUBLE PRECISION :: TIME_LRTRSM DOUBLE PRECISION :: TIME_FRTRSM DOUBLE PRECISION :: TIME_PANEL DOUBLE PRECISION :: TIME_FAC_I DOUBLE PRECISION :: TIME_FAC_MQ DOUBLE PRECISION :: TIME_FAC_SQ DOUBLE PRECISION :: TIME_FRFRONTS DOUBLE PRECISION :: TIME_DIAGCOPY DOUBLE PRECISION :: TIME_DECOMP DOUBLE PRECISION :: TIME_DECOMP_UCFS DOUBLE PRECISION :: TIME_LRASM_NIV1 DOUBLE PRECISION :: TIME_LRASM_LOCASM2 DOUBLE PRECISION :: TIME_LRASM_MAPLIG1 DOUBLE PRECISION :: TIME_LRASM_CONTRIB2 DOUBLE PRECISION :: TIME_FRASM_LOCASM2 DOUBLE PRECISION :: TIME_FRASM_MAPLIG1 DOUBLE PRECISION :: TIME_FRASM_CONTRIB2 DOUBLE PRECISION :: TIME_LRANA_LRGROUPING DOUBLE PRECISION :: TIME_LRANA_SEPGROUPING DOUBLE PRECISION :: TIME_LRANA_GETHALO DOUBLE PRECISION :: TIME_LRANA_KWAY DOUBLE PRECISION :: TIME_LRANA_GNEW DOUBLE PRECISION :: AVG_FLOP_FACTO_LR DOUBLE PRECISION :: MIN_FLOP_FACTO_LR DOUBLE PRECISION :: MAX_FLOP_FACTO_LR INTEGER :: TOTAL_NBLOCKS_ASS, TOTAL_NBLOCKS_CB INTEGER :: MIN_BLOCKSIZE_ASS, MAX_BLOCKSIZE_ASS INTEGER :: MIN_BLOCKSIZE_CB, MAX_BLOCKSIZE_CB DOUBLE PRECISION :: AVG_BLOCKSIZE_ASS, AVG_BLOCKSIZE_CB CONTAINS SUBROUTINE COLLECT_BLOCKSIZES(CUT,NPARTSASS,NPARTSCB) INTEGER, INTENT(IN) :: NPARTSASS, NPARTSCB INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: LOC_MIN_ASS, LOC_MIN_CB, LOC_MAX_ASS, LOC_MAX_CB, & LOC_TOT_ASS, LOC_TOT_CB DOUBLE PRECISION :: LOC_AVG_ASS, LOC_AVG_CB INTEGER :: I LOC_TOT_ASS = 0 LOC_TOT_CB = 0 LOC_AVG_ASS = 0.D0 LOC_AVG_CB = 0.D0 LOC_MIN_ASS = 100000 LOC_MIN_CB = 100000 LOC_MAX_ASS = 0 LOC_MAX_CB = 0 DO I = 1,NPARTSASS LOC_AVG_ASS = ( LOC_TOT_ASS * LOC_AVG_ASS & + CUT(I+1) - CUT(I) ) & / (LOC_TOT_ASS + 1) LOC_TOT_ASS = LOC_TOT_ASS + 1 IF (CUT(I+1) - CUT(I) .LE. LOC_MIN_ASS) THEN LOC_MIN_ASS = CUT(I+1) - CUT(I) END IF IF (CUT(I+1) - CUT(I) .GE. LOC_MAX_ASS) THEN LOC_MAX_ASS = CUT(I+1) - CUT(I) END IF END DO DO I = NPARTSASS+1,NPARTSASS+NPARTSCB LOC_AVG_CB = ( LOC_TOT_CB * LOC_AVG_CB & + CUT(I+1) - CUT(I) ) & / (LOC_TOT_CB + 1) LOC_TOT_CB = LOC_TOT_CB + 1 IF (CUT(I+1) - CUT(I) .LE. LOC_MIN_CB) THEN LOC_MIN_CB = CUT(I+1) - CUT(I) END IF IF (CUT(I+1) - CUT(I) .GE. LOC_MAX_CB) THEN LOC_MAX_CB = CUT(I+1) - CUT(I) END IF END DO AVG_BLOCKSIZE_ASS = (TOTAL_NBLOCKS_ASS*AVG_BLOCKSIZE_ASS & + LOC_TOT_ASS*LOC_AVG_ASS) / (TOTAL_NBLOCKS_ASS+LOC_TOT_ASS) AVG_BLOCKSIZE_CB = (TOTAL_NBLOCKS_CB*AVG_BLOCKSIZE_CB & + LOC_TOT_CB*LOC_AVG_CB) / (TOTAL_NBLOCKS_CB+LOC_TOT_CB) TOTAL_NBLOCKS_ASS = TOTAL_NBLOCKS_ASS + LOC_TOT_ASS TOTAL_NBLOCKS_CB = TOTAL_NBLOCKS_CB + LOC_TOT_CB MIN_BLOCKSIZE_ASS = min(MIN_BLOCKSIZE_ASS,LOC_MIN_ASS) MIN_BLOCKSIZE_CB = min(MIN_BLOCKSIZE_CB,LOC_MIN_CB) MAX_BLOCKSIZE_ASS = max(MAX_BLOCKSIZE_ASS,LOC_MAX_ASS) MAX_BLOCKSIZE_CB = max(MAX_BLOCKSIZE_CB,LOC_MAX_CB) END SUBROUTINE COLLECT_BLOCKSIZES SUBROUTINE UPD_FLOP_DECOMPRESS(F, CB) DOUBLE PRECISION, INTENT(IN) :: F LOGICAL, INTENT(IN) :: CB !$OMP ATOMIC UPDATE FLOP_DECOMPRESS = FLOP_DECOMPRESS + F !$OMP END ATOMIC IF (CB) THEN !$OMP ATOMIC UPDATE FLOP_CB_DECOMPRESS = FLOP_CB_DECOMPRESS + F !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE UPD_FLOP_DECOMPRESS SUBROUTINE UPD_FLOP_COMPRESS(LRBM,LRBN,LRBK,ISLR, REC_ACC, & CB_COMPRESS, FRSWAP) INTEGER :: LRBM, LRBN, LRBK LOGICAL :: ISLR INTEGER(8) :: M,N,K DOUBLE PRECISION :: HR_COST,BUILDQ_COST, & HR_AND_BUILDQ_COST LOGICAL, OPTIONAL :: REC_ACC, CB_COMPRESS, FRSWAP M = int(LRBM,8) N = int(LRBN,8) K = int(LRBK,8) HR_COST = dble(K*K*K/3_8 + 4_8*K*M*N - (2_8*M+N)*K*K) IF (ISLR) THEN BUILDQ_COST = dble(2_8*K*K*M - K*K*K) ELSE BUILDQ_COST = 0.0d0 END IF HR_AND_BUILDQ_COST = HR_COST + BUILDQ_COST !$OMP ATOMIC UPDATE FLOP_COMPRESS = FLOP_COMPRESS + HR_AND_BUILDQ_COST !$OMP END ATOMIC IF (present(REC_ACC)) THEN IF (REC_ACC) THEN !$OMP ATOMIC UPDATE FLOP_ACCUM_COMPRESS = FLOP_ACCUM_COMPRESS + & HR_AND_BUILDQ_COST !$OMP END ATOMIC ENDIF ENDIF IF (present(CB_COMPRESS)) THEN IF (CB_COMPRESS) THEN !$OMP ATOMIC UPDATE FLOP_CB_COMPRESS = FLOP_CB_COMPRESS + & HR_AND_BUILDQ_COST !$OMP END ATOMIC ENDIF ENDIF IF (present(FRSWAP)) THEN IF (FRSWAP) THEN !$OMP ATOMIC UPDATE FLOP_FRSWAP_COMPRESS = FLOP_FRSWAP_COMPRESS + & HR_AND_BUILDQ_COST !$OMP END ATOMIC ENDIF ENDIF RETURN END SUBROUTINE UPD_FLOP_COMPRESS SUBROUTINE UPD_FLOP_TRSM(M, N, K, ISLR, LorU) INTEGER,INTENT(IN) :: M, N, K, LorU LOGICAL,INTENT(IN) :: ISLR DOUBLE PRECISION :: LR_COST, FR_COST, LR_GAIN IF (LorU.EQ.0) THEN FR_COST = dble(M*N*N) IF (ISLR) THEN LR_COST = dble(K*N*N) ELSE LR_COST = FR_COST ENDIF ELSE FR_COST = dble(M-1)*dble(N*N) IF (ISLR) THEN LR_COST = dble(N-1)*dble(N*K) ELSE LR_COST = FR_COST ENDIF ENDIF LR_GAIN = FR_COST - LR_COST !$OMP ATOMIC UPDATE FLOP_LRGAIN = FLOP_LRGAIN + LR_GAIN !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_TRSM SUBROUTINE UPD_FLOP_UPDATE(LRB1M, LRB1N, LRB1K, LRB1ISLR, & LRB2M, LRB2N, LRB2K, LRB2ISLR, & MIDBLK_COMPRESS, RANK_IN, BUILDQ, & IS_SYMDIAG, LUA_ACTIVATED, REC_ACC) INTEGER, INTENT(IN) :: LRB1M, LRB1N, LRB1K, LRB2M, LRB2N, LRB2K LOGICAL, INTENT(IN) :: LRB1ISLR, LRB2ISLR LOGICAL, INTENT(IN) :: BUILDQ, IS_SYMDIAG, LUA_ACTIVATED INTEGER, INTENT(IN) :: RANK_IN, MIDBLK_COMPRESS LOGICAL, INTENT(IN), OPTIONAL :: REC_ACC DOUBLE PRECISION :: COST_FR, COST_LR, COST_LRLR1, COST_LRLR2, & COST_LRLR3, COST_FRLR, COST_FRFR, & COST_COMPRESS, COST_LR_AND_COMPRESS, LR_GAIN DOUBLE PRECISION :: M1,N1,K1,M2,N2,K2,RANK LOGICAL :: REC_ACC_LOC M1 = dble(LRB1M) N1 = dble(LRB1N) K1 = dble(LRB1K) M2 = dble(LRB2M) N2 = dble(LRB2N) K2 = dble(LRB2K) RANK = dble(RANK_IN) COST_LRLR1 = 0.0D0 COST_LRLR2 = 0.0D0 COST_LRLR3 = 0.0D0 COST_FRLR = 0.0D0 COST_FRFR = 0.0D0 COST_COMPRESS = 0.0D0 IF (present(REC_ACC)) THEN REC_ACC_LOC = REC_ACC ELSE REC_ACC_LOC = .FALSE. ENDIF IF ((.NOT.LRB1ISLR).AND.(.NOT.LRB2ISLR)) THEN COST_FRFR = 2.0D0*M1*M2*N1 COST_LR = 2.0D0*M1*M2*N1 COST_FR = 2.0D0*M1*M2*N1 ELSEIF (LRB1ISLR.AND.(.NOT.LRB2ISLR)) THEN COST_FRLR = 2.0D0*K1*M2*N1 COST_LRLR3 = 2.0D0*M1*M2*K1 COST_LR = COST_FRLR + COST_LRLR3 COST_FR = 2.0D0*M1*M2*N1 ELSEIF ((.NOT.LRB1ISLR).AND.LRB2ISLR) THEN COST_FRLR = 2.0D0*M1*K2*N1 COST_LRLR3 = 2.0D0*M1*M2*K2 COST_LR = COST_FRLR + COST_LRLR3 COST_FR = 2.0D0*M1*M2*N1 ELSE IF (MIDBLK_COMPRESS.GE.1) THEN COST_COMPRESS = RANK*RANK*RANK/3.0D0 + & 4.0D0*RANK*K1*K2 - & (2.0D0*K1+K2)*RANK*RANK IF (BUILDQ) THEN COST_COMPRESS = COST_COMPRESS + 4.0D0*RANK*RANK*K1 & - RANK*RANK*RANK ENDIF ENDIF COST_LRLR1 = 2.0D0*K1*K2*N1 IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN COST_LRLR2 = 2.0D0*K1*M1*RANK + 2.0D0*K2*M2*RANK COST_LRLR3 = 2.0D0*M1*M2*RANK ELSE IF (K1 .GE. K2) THEN COST_LRLR2 = 2.0D0*K1*M1*K2 COST_LRLR3 = 2.0D0*M1*M2*K2 ELSE COST_LRLR2 = 2.0D0*K1*M2*K2 COST_LRLR3 = 2.0D0*M1*M2*K1 ENDIF ENDIF COST_LR = COST_LRLR1 + COST_LRLR2 + COST_LRLR3 COST_FR = 2.0D0*M1*M2*N1 ENDIF IF (IS_SYMDIAG) THEN COST_FR = COST_FR/2.0D0 COST_LRLR3 = COST_LRLR3/2.0D0 COST_FRFR = COST_FRFR/2.0D0 COST_LR = COST_LR - COST_LRLR3 - COST_FRFR ENDIF IF (LUA_ACTIVATED) THEN COST_LR = COST_LR - COST_LRLR3 COST_LRLR3 = 0.0D0 IF (REC_ACC_LOC) THEN COST_LR_AND_COMPRESS = COST_LR + COST_COMPRESS !$OMP ATOMIC UPDATE FLOP_COMPRESS = FLOP_COMPRESS + COST_LR_AND_COMPRESS !$OMP END ATOMIC ENDIF ENDIF IF (.NOT.REC_ACC_LOC) THEN !$OMP ATOMIC UPDATE FLOP_COMPRESS = FLOP_COMPRESS + COST_COMPRESS !$OMP END ATOMIC LR_GAIN = COST_FR - COST_LR !$OMP ATOMIC UPDATE FLOP_LRGAIN = FLOP_LRGAIN + LR_GAIN !$OMP END ATOMIC ENDIF END SUBROUTINE UPD_FLOP_UPDATE SUBROUTINE UPD_FLOP_UPDATE_LRLR3(M, N, K, NIV) INTEGER,INTENT(IN) :: M, N, K, NIV DOUBLE PRECISION :: FLOP_COST FLOP_COST = 2.0D0*dble(M)*dble(N)*dble(K) !$OMP ATOMIC UPDATE FLOP_LRGAIN = FLOP_LRGAIN - FLOP_COST !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_UPDATE_LRLR3 SUBROUTINE UPD_FLOP_ROOT(KEEP50, NFRONT, NPIV, & NPROW, NPCOL, MYID) INTEGER, intent(in) :: KEEP50, NFRONT, NPIV, & NPROW, NPCOL, MYID DOUBLE PRECISION :: COST, COST_PER_PROC INTEGER, PARAMETER :: LEVEL3 = 3 CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NFRONT, KEEP50, LEVEL3, & COST) COST_PER_PROC = dble(int( COST,8) / int(NPROW * NPCOL,8)) !$OMP ATOMIC UPDATE FLOP_FRFRONTS = FLOP_FRFRONTS + COST_PER_PROC !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_ROOT SUBROUTINE INIT_STATS_GLOBAL() MRY_LU_FR = 0.D0 MRY_LU_LRGAIN = 0.D0 MRY_CB_FR = 0.D0 MRY_CB_LRGAIN = 0.D0 FLOP_FACTO_FR = 0.D0 FLOP_FACTO_LR = 0.D0 FLOP_LRGAIN = 0.D0 FLOP_CB_COMPRESS = 0.D0 FLOP_CB_DECOMPRESS = 0.D0 FLOP_DECOMPRESS = 0.D0 FLOP_UPDATE_FR = 0.D0 FLOP_UPDATE_LR = 0.D0 FLOP_UPDATE_LRLR1 = 0.D0 FLOP_UPDATE_LRLR2 = 0.D0 FLOP_UPDATE_LRLR3 = 0.D0 FLOP_UPDATE_FRLR = 0.D0 FLOP_UPDATE_FRFR = 0.D0 FLOP_MIDBLK_COMPRESS = 0.D0 FLOP_TRSM_FR = 0.D0 FLOP_TRSM_LR = 0.D0 FLOP_COMPRESS = 0.D0 FLOP_ACCUM_COMPRESS = 0.D0 FLOP_FRSWAP_COMPRESS = 0.D0 FLOP_PANEL = 0.D0 FLOP_TRSM = 0.D0 FLOP_FRFRONTS = 0.D0 TOTAL_NBLOCKS_ASS = 0 TOTAL_NBLOCKS_CB = 0 AVG_BLOCKSIZE_ASS = 0.D0 AVG_BLOCKSIZE_CB = 0.D0 MIN_BLOCKSIZE_ASS = huge(1) MAX_BLOCKSIZE_ASS = 0 MIN_BLOCKSIZE_CB = huge(1) MAX_BLOCKSIZE_CB = 0 CNT_NODES = 0 TIME_UPDATE = 0.D0 TIME_MIDBLK_COMPRESS = 0.D0 TIME_UPDATE_LRLR1 = 0.D0 TIME_UPDATE_LRLR2 = 0.D0 TIME_UPDATE_LRLR3 = 0.D0 TIME_UPDATE_FRLR = 0.D0 TIME_UPDATE_FRFR = 0.D0 TIME_COMPRESS = 0.D0 TIME_CB_COMPRESS = 0.D0 TIME_LR_MODULE = 0.D0 TIME_UPD_NELIM = 0.D0 TIME_LRTRSM = 0.D0 TIME_FRTRSM = 0.D0 TIME_PANEL = 0.D0 TIME_FAC_I = 0.D0 TIME_FAC_MQ = 0.D0 TIME_FAC_SQ = 0.D0 TIME_FRFRONTS = 0.D0 TIME_DIAGCOPY = 0.D0 TIME_FRSWAP_COMPRESS = 0.D0 TIME_DECOMP = 0.D0 TIME_DECOMP_UCFS = 0.D0 TIME_LRASM_NIV1 = 0.D0 TIME_LRASM_LOCASM2 = 0.D0 TIME_LRASM_MAPLIG1 = 0.D0 TIME_LRASM_CONTRIB2 = 0.D0 TIME_FRASM_LOCASM2 = 0.D0 TIME_FRASM_MAPLIG1 = 0.D0 TIME_FRASM_CONTRIB2 = 0.D0 END SUBROUTINE INIT_STATS_GLOBAL SUBROUTINE UPD_MRY_LU_FR(NASS, NCB, SYM, NELIM) INTEGER,INTENT(IN) :: NASS, NCB, SYM, NELIM DOUBLE PRECISION :: MRY INTEGER :: NPIV NPIV = NASS - NELIM IF (SYM .GT. 0) THEN MRY = dble(NPIV)*(dble(NPIV)+1.D0)/2.D0 & + dble(NPIV)*dble(NCB+NELIM) ELSE MRY = dble(NPIV)*dble(NPIV) & + 2.0D0*dble(NPIV)*dble(NCB+NELIM) END IF !$OMP ATOMIC UPDATE MRY_LU_FR = MRY_LU_FR + MRY !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_LU_FR SUBROUTINE UPD_MRY_CB_FR(NROWS, NCOLS, SYM) INTEGER,INTENT(IN) :: NROWS, NCOLS, SYM DOUBLE PRECISION :: MRY IF (SYM.EQ.0) THEN MRY = dble(NCOLS)*dble(NROWS) ELSE MRY = dble(NCOLS-NROWS)*dble(NROWS) + & dble(NROWS)*dble(NROWS+1)/2.D0 ENDIF !$OMP ATOMIC UPDATE MRY_CB_FR = MRY_CB_FR + MRY !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_CB_FR SUBROUTINE UPD_MRY_CB_LRGAIN(M, N, K & ) INTEGER, INTENT(IN) :: M, N, K DOUBLE PRECISION :: LRGAIND LRGAIND = dble(M*N-(M+N)*K) !$OMP ATOMIC UPDATE MRY_CB_LRGAIN = MRY_CB_LRGAIN + LRGAIND !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_CB_LRGAIN SUBROUTINE UPD_FLOP_FACTO_FR( NFRONT, NASS, NPIV, SYM, NIV) INTEGER,INTENT(IN) :: NFRONT, SYM, NASS, NPIV, NIV DOUBLE PRECISION :: FLOP CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & SYM, NIV, FLOP) !$OMP ATOMIC UPDATE FLOP_FACTO_FR = FLOP_FACTO_FR + FLOP !$OMP END ATOMIC END SUBROUTINE UPD_FLOP_FACTO_FR SUBROUTINE STATS_COMPUTE_FLOP_SLAVE_TYPE2( NROW1, NCOL1, & NASS1, KEEP50, INODE) INTEGER,INTENT(IN) :: NROW1, NCOL1, KEEP50, NASS1, INODE DOUBLE PRECISION :: NROW2, NCOL2, NASS2 DOUBLE PRECISION :: FLOP NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF !$OMP ATOMIC UPDATE FLOP_FACTO_FR = FLOP_FACTO_FR + FLOP !$OMP END ATOMIC RETURN END SUBROUTINE STATS_COMPUTE_FLOP_SLAVE_TYPE2 SUBROUTINE UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, SYM, & NIV) INTEGER, INTENT(IN) :: NFRONT, NPIV, NASS, SYM, NIV DOUBLE PRECISION :: FLOP_FAC CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & SYM, NIV, FLOP_FAC) !$OMP ATOMIC UPDATE FLOP_FRFRONTS = FLOP_FRFRONTS + FLOP_FAC !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_FRFRONTS SUBROUTINE UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP50, INODE) INTEGER,INTENT(IN) :: NROW1, NCOL1, KEEP50, NASS1, INODE DOUBLE PRECISION :: NROW2, NCOL2, NASS2 DOUBLE PRECISION :: FLOP NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF !$OMP ATOMIC UPDATE FLOP_FRFRONTS = FLOP_FRFRONTS + FLOP !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_FRFRONT_SLAVE SUBROUTINE COMPUTE_GLOBAL_GAINS(NB_ENTRIES_FACTOR, & FLOP_NUMBER, NB_ENTRIES_FACTOR_withLR, & PROKG, MPG) INTEGER(8), INTENT(IN) :: NB_ENTRIES_FACTOR INTEGER, INTENT(IN) :: MPG LOGICAL, INTENT(IN) :: PROKG DOUBLE PRECISION, INTENT(IN) :: FLOP_NUMBER INTEGER(8), INTENT(OUT) :: & NB_ENTRIES_FACTOR_withLR IF (NB_ENTRIES_FACTOR < 0) THEN IF (PROKG.AND.MPG.GT.0) THEN WRITE(MPG,*) "NEGATIVE NUMBER OF ENTRIES IN FACTOR" WRITE(MPG,*) "===> OVERFLOW ?" END IF END IF IF (MRY_LU_FR .EQ. 0) THEN GLOBAL_MRY_LPRO_COMPR = 100.0D0 ELSE GLOBAL_MRY_LPRO_COMPR = 100.0D0 * & MRY_LU_LRGAIN/MRY_LU_FR ENDIF IF (MRY_CB_FR .EQ. 0) THEN MRY_CB_FR = 100.0D0 END IF NB_ENTRIES_FACTOR_withLR = NB_ENTRIES_FACTOR - & int(MRY_LU_LRGAIN,8) IF (NB_ENTRIES_FACTOR.EQ.0) THEN FACTOR_PROCESSED_FRACTION = 100.0D0 GLOBAL_MRY_LTOT_COMPR = 100.0D0 ELSE FACTOR_PROCESSED_FRACTION = 100.0D0 * & MRY_LU_FR/dble(NB_ENTRIES_FACTOR) GLOBAL_MRY_LTOT_COMPR = & 100.0D0*MRY_LU_LRGAIN/dble(NB_ENTRIES_FACTOR) ENDIF TOTAL_FLOP = FLOP_NUMBER FLOP_FACTO_LR = FLOP_FACTO_FR - FLOP_LRGAIN + FLOP_COMPRESS & + FLOP_DECOMPRESS RETURN END SUBROUTINE COMPUTE_GLOBAL_GAINS SUBROUTINE SAVEandWRITE_GAINS(LOCAL, K489, & LR_DKEEPSHIFT, LR_TABSIZE, LR_TAB, LR_EPSILON, & N, ICNTL36, & DEPTH, BCKSZ, NASSMIN, NFRONTMIN, SYM, K486, & NBTHREADS, K472, K475, K478, K480, K481, K483, K484, & K8110, K849, & NBTREENODES, NPROCS, MPG, PROKG) INTEGER, INTENT(IN) :: LOCAL,K489,DEPTH, N, & ICNTL36, BCKSZ,NASSMIN, & NFRONTMIN, K486, NBTREENODES, MPG, & NBTHREADS, K472, K475, K478, K480, K481, K483, K484, & SYM, NPROCS INTEGER, INTENT(IN) :: LR_TABSIZE, LR_DKEEPSHIFT DOUBLE PRECISION, INTENT(INOUT) :: LR_TAB(LR_TABSIZE) DOUBLE PRECISION, INTENT(IN) :: LR_EPSILON INTEGER(8), INTENT(IN) :: K8110, K849 LOGICAL, INTENT(IN) :: PROKG TIME_UPDATE_LRLR1 = TIME_UPDATE_LRLR1/dble(NBTHREADS) TIME_UPDATE_LRLR2 = TIME_UPDATE_LRLR2/dble(NBTHREADS) TIME_UPDATE_LRLR3 = TIME_UPDATE_LRLR3/dble(NBTHREADS) TIME_UPDATE_FRLR = TIME_UPDATE_FRLR/dble(NBTHREADS) TIME_UPDATE_FRFR = TIME_UPDATE_FRFR/dble(NBTHREADS) TIME_MIDBLK_COMPRESS = TIME_MIDBLK_COMPRESS/dble(NBTHREADS) IF (PROKG) THEN WRITE(MPG,'(/A,A)') & '-------------- Beginning of BLR statistics -------------------', & '--------------' WRITE(MPG,'(A,I2)') & ' ICNTL(36) BLR variant = ', ICNTL36 WRITE(MPG,'(A,ES8.1)') & ' CNTL(7) Dropping parameter controlling accuracy = ', & LR_EPSILON WRITE(MPG,'(A)') & ' Statistics after BLR factorization :' WRITE(MPG,'(A,I8)') & ' Number of BLR fronts = ', & CNT_NODES ENDIF IF (PROKG) WRITE(MPG,'(A,F8.1,A)') & ' Fraction of factors in BLR fronts =', & FACTOR_PROCESSED_FRACTION,'% ' IF (PROKG) THEN WRITE(MPG,'(A)') & ' Statistics on the number of entries in factors :' WRITE(MPG,'(A,I15,A)') & ' INFOG(29) Theoretical nb of entries in factors =' & ,K8110,' (100.0%)' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' INFOG(35) Effective nb of entries (% of INFOG(29)) =' & ,real(K849),' (' & ,real(100)*(real(K849)/real(max(K8110,1_8))) & ,'%)' ENDIF IF (PROKG) WRITE(MPG,'(A)') & ' Statistics on operation counts (OPC):' TOTAL_FLOP = max(TOTAL_FLOP,epsilon(1.0D0)) LR_TAB(55-LR_DKEEPSHIFT)=real(TOTAL_FLOP) LR_TAB(60-LR_DKEEPSHIFT)=100.0D0 LR_TAB(56-LR_DKEEPSHIFT)=FLOP_FACTO_LR+FLOP_FRFRONTS LR_TAB(61-LR_DKEEPSHIFT)=100.0D0*(FLOP_FACTO_LR+FLOP_FRFRONTS)/ & TOTAL_FLOP IF (PROKG) THEN WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' RINFOG(3) Total theoretical operations counts =' & ,TOTAL_FLOP,' (',100.0D0*TOTAL_FLOP/TOTAL_FLOP,'%)' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' RINFOG(14) Total effective OPC (% of RINFOG(3)) =' & ,FLOP_FACTO_LR+FLOP_FRFRONTS,' (' &,100.0D0*(FLOP_FACTO_LR+FLOP_FRFRONTS)/TOTAL_FLOP &,'%)' ENDIF IF (PROKG) WRITE(MPG,'(A,A)') & '-------------- End of BLR statistics -------------------------', & '--------------' RETURN END SUBROUTINE SAVEandWRITE_GAINS END MODULE MUMPS_LR_STATS MUMPS_5.8.1/src/sfac_root_parallel.F0000664000175000017500000001732615042446437017211 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_FACTO_ROOT( & MPA, MYID, MASTER_OF_ROOT, & root, roota, N, IROOT, & COMM, IW, LIW, IFREE, & A, LA, PTRAST, PTLUST_S, PTRFAC, & STEP, INFO, LDLT, QR, & WK, LWK, KEEP,KEEP8,DKEEP,OPELIW, & DET_EXP, DET_MANT, DET_SIGN & ) USE MUMPS_LR_STATS, ONLY: UPD_FLOP_ROOT USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE ( MUMPS_ROOT_STRUC ) :: root TYPE ( SMUMPS_ROOT_STRUC ) :: roota INTEGER, INTENT(IN) :: MPA INTEGER N, IROOT, COMM, LIW, MYID, IFREE, MASTER_OF_ROOT INTEGER(8) :: LA INTEGER(8) :: LWK REAL WK( LWK ) INTEGER KEEP(500) REAL DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTLUST_S(KEEP(28)), STEP(N), IW( LIW ) INTEGER INFO( 2 ), LDLT, QR REAL A( LA ) DOUBLE PRECISION, intent(inout) :: OPELIW INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP REAL, INTENT(INOUT) :: DET_MANT #if ! defined(NOSCALAPACK) INTEGER IOLDPS INTEGER(8) :: IAPOS INTEGER LOCAL_M, LOCAL_N, LPIV, IERR DOUBLE PRECISION :: FLOPS_ROOT INTEGER(8) :: ENTRIES_ROOT INTEGER allocok INTEGER FWD_LOCAL_N_RHS, FWD_MTYPE #endif INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_NUMROC IF ( .NOT. root%yes ) RETURN IF ( KEEP(60) .NE. 0 ) THEN IF ((LDLT == 1 .OR. LDLT == 2) .AND. KEEP(60) == 3 ) THEN CALL SMUMPS_SYMMETRIZE( WK, root%MBLOCK, & root%MYROW, root%MYCOL, root%NPROW, root%NPCOL, & roota%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_NLOC, & root%TOT_ROOT_SIZE, MYID, COMM ) ENDIF RETURN ENDIF #if ! defined(NOSCALAPACK) IF (MPA.GT.0) THEN IF (MYID.EQ.MASTER_OF_ROOT) THEN CALL MUMPS_GET_FLOPS_COST & (root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & LDLT, 3, FLOPS_ROOT) WRITE(MPA,'(A, A, 1PD10.3)') & " ... Start processing the root node with ScaLAPACK, ", & " remaining flops = ", FLOPS_ROOT ENDIF ENDIF IOLDPS = PTLUST_S(STEP(IROOT))+KEEP(IXSZ) IAPOS = PTRAST(STEP(IROOT)) LOCAL_M = IW( IOLDPS + 2 ) LOCAL_N = IW( IOLDPS + 1 ) IAPOS = PTRFAC(IW ( IOLDPS + 4 )) IF ( LDLT.EQ.0 .OR. LDLT.EQ.2 .OR. QR.ne.0 ) THEN LPIV = LOCAL_M + root%MBLOCK ELSE LPIV = 1 END IF IF (associated( root%IPIV )) DEALLOCATE(root%IPIV) root%LPIV = LPIV ALLOCATE( root%IPIV( LPIV ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LPIV WRITE(*,*) MYID,': problem allocating IPIV(',LPIV,') in root' CALL MUMPS_ABORT() END IF CALL DESCINIT( root%DESCRIPTOR(1), root%TOT_ROOT_SIZE, & root%TOT_ROOT_SIZE, root%MBLOCK, root%NBLOCK, & 0, 0, root%CNTXT_BLACS, LOCAL_M, IERR ) IF ( LDLT.EQ.2 ) THEN IF(root%MBLOCK.NE.root%NBLOCK) THEN WRITE(*,*) ' Error: symmetrization only works for' WRITE(*,*) ' square block sizes, MBLOCK/NBLOCK=', & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() END IF IF ( LWK .LT. min( & int(root%MBLOCK,8) * int(root%NBLOCK,8), & int(root%TOT_ROOT_SIZE,8)* int(root%TOT_ROOT_SIZE,8 ) & )) THEN WRITE(*,*) 'Not enough workspace for symmetrization.' CALL MUMPS_ABORT() END IF CALL SMUMPS_SYMMETRIZE( WK, root%MBLOCK, & root%MYROW, root%MYCOL, root%NPROW, root%NPCOL, & A( IAPOS ), LOCAL_M, LOCAL_N, & root%TOT_ROOT_SIZE, MYID, COMM ) END IF IF (LDLT.EQ.0.OR.LDLT.EQ.2) THEN CALL psgetrf( root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & A( IAPOS ), & 1, 1, root%DESCRIPTOR(1), root%IPIV(1), IERR ) IF ( IERR .GT. 0 ) THEN INFO(1)=-10 INFO(2)=IERR-1 END IF ELSE CALL pspotrf('L',root%TOT_ROOT_SIZE,A(IAPOS), & 1,1,root%DESCRIPTOR(1),IERR) IF ( IERR .GT. 0 ) THEN INFO(1)=-40 INFO(2)=IERR-1 END IF END IF IF (IERR .GT. 0) THEN CALL MUMPS_UPDATE_FLOPS_ROOT( OPELIW, LDLT, & root%TOT_ROOT_SIZE, INFO(2), & root%NPROW, root%NPCOL, MYID ) IF (KEEP(486) .GT. 0) THEN CALL UPD_FLOP_ROOT( LDLT, & root%TOT_ROOT_SIZE, INFO(2), & root%NPROW, root%NPCOL, MYID ) ENDIF ELSE CALL MUMPS_UPDATE_FLOPS_ROOT( OPELIW, LDLT, & root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & root%NPROW, root%NPCOL, MYID ) IF (KEEP(486) .GT. 0) THEN CALL UPD_FLOP_ROOT( LDLT, & root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & root%NPROW, root%NPCOL, MYID ) ENDIF ENDIF IF ( LDLT .EQ. 0 ) THEN ENTRIES_ROOT = int(root%TOT_ROOT_SIZE,8) & * int(root%TOT_ROOT_SIZE,8) ELSE ENTRIES_ROOT = int(root%TOT_ROOT_SIZE,8) & * int(root%TOT_ROOT_SIZE+1,8)/2_8 ENDIF KEEP8(10)=KEEP8(10) + ENTRIES_ROOT / & int(root%NPROW * root%NPCOL,8) IF (MYID .eq. MASTER_OF_ROOT) THEN KEEP8(10)=KEEP8(10) + & mod(ENTRIES_ROOT, int(root%NPROW*root%NPCOL,8)) ENDIF CALL SMUMPS_PAR_ROOT_MINMAX_PIV_UPD ( & root%MBLOCK, root%IPIV(1),root%MYROW, & root%MYCOL, root%NPROW, root%NPCOL, A(IAPOS), LOCAL_M, & LOCAL_N, root%TOT_ROOT_SIZE, MYID, DKEEP, KEEP, LDLT) IF (KEEP(258).NE.0) THEN IF (root%MBLOCK.NE.root%NBLOCK) THEN write(*,*) "Internal error in SMUMPS_FACTO_ROOT:", & "Block size different for rows and columns", & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() ENDIF CALL SMUMPS_GETDETER2D(root%MBLOCK, root%IPIV(1),root%MYROW, & root%MYCOL, root%NPROW, root%NPCOL, A(IAPOS), LOCAL_M, & LOCAL_N, root%TOT_ROOT_SIZE, MYID, DET_MANT, DET_EXP, & LDLT) ENDIF IF (KEEP(252) .NE. 0) THEN FWD_LOCAL_N_RHS = MUMPS_NUMROC(KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL) FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) FWD_MTYPE = 1 CALL SMUMPS_SOLVE_2D_BCYCLIC( & root%TOT_ROOT_SIZE, & KEEP(253), & FWD_MTYPE, & A(IAPOS), & root%DESCRIPTOR(1), & LOCAL_M, LOCAL_N, FWD_LOCAL_N_RHS, & root%IPIV(1), LPIV, & roota%RHS_ROOT(1,1), LDLT, & root%MBLOCK, root%NBLOCK, & root%CNTXT_BLACS, IERR) ENDIF #endif RETURN END SUBROUTINE SMUMPS_FACTO_ROOT MUMPS_5.8.1/src/cfac_sol_pool.F0000664000175000017500000004376715042446440016162 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_INIT_POOL_LAST3(IPOOL, LPOOL, LEAF) USE MUMPS_LOAD IMPLICIT NONE INTEGER LPOOL, LEAF INTEGER IPOOL(LPOOL) IPOOL(LPOOL-2) = 0 IPOOL(LPOOL-1) = 0 IPOOL(LPOOL) = LEAF-1 RETURN END SUBROUTINE CMUMPS_INIT_POOL_LAST3 SUBROUTINE CMUMPS_INSERT_POOL_N & (N, POOL, LPOOL, PROCNODE, SLAVEF, KEEP199, & K28, K76, K80, K47, STEP, INODE) USE MUMPS_LOAD IMPLICIT NONE INTEGER N, INODE, LPOOL, K28, SLAVEF, K76, K80, K47, KEEP199 INTEGER STEP(N), POOL(LPOOL), PROCNODE(K28) EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR, ATM_CURRENT_NODE INTEGER NBINSUBTREE, NBTOP, INODE_EFF,POS_TO_INSERT INTEGER IPOS1, IPOS2, ISWAP INTEGER NODE,J,I ATM_CURRENT_NODE = ( K76 == 2 .OR. K76 ==3 .OR. & K76==4 .OR. K76==5) NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF (INODE > N ) THEN INODE_EFF = INODE - N ELSE IF (INODE < 0) THEN INODE_EFF = - INODE ELSE INODE_EFF = INODE ENDIF IF(((INODE.GT.0).AND.(INODE.LE.N)).AND.(.NOT. & MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE_EFF)), & KEEP199)) & ) THEN IF ((K80 == 1 .AND. K47 .GE. 1) .OR. & (( K80 == 2 .OR. K80==3 ) .AND. & ( K47 == 4 ))) THEN CALL MUMPS_REMOVE_NODE(INODE,1) ENDIF ENDIF IF ( MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE_EFF)), & KEEP199) ) THEN POOL(NBINSUBTREE + 1 ) = INODE NBINSUBTREE = NBINSUBTREE + 1 ELSE POS_TO_INSERT=NBTOP+1 IF((K76.EQ.4).OR.(K76.EQ.5).OR.(K76.EQ.6))THEN IF((INODE.GT.N).OR.(INODE.LE.0))THEN DO J=NBTOP,1,-1 IF((POOL(LPOOL-2-J).GT.0) & .AND.(POOL(LPOOL-2-J).LE.N))THEN GOTO 333 ENDIF IF ( POOL(LPOOL-2-J) < 0 ) THEN NODE=-POOL(LPOOL-2-J) ELSE IF ( POOL(LPOOL-2-J) > N ) THEN NODE = POOL(LPOOL-2-J) - N ELSE NODE = POOL(LPOOL-2-J) ENDIF IF((K76.EQ.4).OR.(K76.EQ.6))THEN IF(DEPTH_FIRST_LOAD(STEP(NODE)).GE. & DEPTH_FIRST_LOAD(STEP(INODE_EFF)))THEN GOTO 333 ENDIF ENDIF IF(K76.EQ.5)THEN IF(COST_TRAV(STEP(NODE)).LE. & COST_TRAV(STEP(INODE_EFF)))THEN GOTO 333 ENDIF ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO IF(J.EQ.0) J=1 333 CONTINUE DO I=NBTOP,POS_TO_INSERT,-1 POOL(LPOOL-2-I-1)=POOL(LPOOL-2-I) ENDDO POOL(LPOOL-2-POS_TO_INSERT)=INODE NBTOP = NBTOP + 1 GOTO 20 ENDIF DO J=NBTOP,1,-1 IF((POOL(LPOOL-2-J).GT.0).AND.(POOL(LPOOL-2-J).LE.N))THEN GOTO 888 ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO 888 CONTINUE DO I=J,1,-1 NODE=POOL(LPOOL-2-I) IF((K76.EQ.4).OR.(K76.EQ.6))THEN IF(DEPTH_FIRST_LOAD(STEP(NODE)).GE. & DEPTH_FIRST_LOAD(STEP(INODE_EFF)))THEN GOTO 999 ENDIF ENDIF IF(K76.EQ.5)THEN IF(COST_TRAV(STEP(NODE)).LE. & COST_TRAV(STEP(INODE_EFF)))THEN GOTO 999 ENDIF ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO IF(I.EQ.0) I=1 999 CONTINUE DO J=NBTOP,POS_TO_INSERT,-1 POOL(LPOOL-2-J-1)=POOL(LPOOL-2-J) ENDDO POOL(LPOOL-2-POS_TO_INSERT)=INODE NBTOP = NBTOP + 1 GOTO 20 ENDIF POOL( LPOOL - 2 - ( NBTOP + 1 ) ) = INODE NBTOP = NBTOP + 1 IPOS1 = LPOOL - 2 - NBTOP IPOS2 = LPOOL - 2 - NBTOP + 1 10 CONTINUE IF ( IPOS2 == LPOOL - 2 ) GOTO 20 IF ( POOL(IPOS1) < 0 ) GOTO 20 IF ( POOL(IPOS2) < 0 ) GOTO 30 IF ( ATM_CURRENT_NODE ) THEN IF ( POOL(IPOS1) > N ) GOTO 20 IF ( POOL(IPOS2) > N ) GOTO 30 END IF GOTO 20 30 CONTINUE ISWAP = POOL(IPOS1) POOL(IPOS1) = POOL(IPOS2) POOL(IPOS2) = ISWAP IPOS1 = IPOS1 + 1 IPOS2 = IPOS2 + 1 GOTO 10 20 CONTINUE ENDIF POOL(LPOOL) = NBINSUBTREE POOL(LPOOL - 1) = NBTOP RETURN END SUBROUTINE CMUMPS_INSERT_POOL_N LOGICAL FUNCTION CMUMPS_POOL_EMPTY(POOL, LPOOL) IMPLICIT NONE INTEGER LPOOL INTEGER POOL(LPOOL) INTEGER NBINSUBTREE, NBTOP NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) CMUMPS_POOL_EMPTY = (NBINSUBTREE + NBTOP == 0) RETURN END FUNCTION CMUMPS_POOL_EMPTY SUBROUTINE CMUMPS_EXTRACT_POOL( N, POOL, LPOOL, PROCNODE, SLAVEF, & STEP, INODE, KEEP,KEEP8, MYID, ND, & FORCE_EXTRACT_TOP_SBTR ) USE MUMPS_LOAD IMPLICIT NONE INTEGER INODE, LPOOL, SLAVEF, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(N), POOL(LPOOL), PROCNODE(KEEP(28)), & ND(KEEP(28)) EXTERNAL MUMPS_INSSARBR, MUMPS_ROOTSSARBR, CMUMPS_POOL_EMPTY LOGICAL MUMPS_INSSARBR, MUMPS_ROOTSSARBR, CMUMPS_POOL_EMPTY INTEGER NBINSUBTREE, NBTOP, INSUBTREE, INODE_EFF, MYID LOGICAL LEFT, ATOMIC_SUBTREE,UPPER,FLAG_MEM,SBTR_FLAG,PROC_FLAG LOGICAL FORCE_EXTRACT_TOP_SBTR INTEGER NODE_TO_EXTRACT,I,J,MIN_PROC NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF ( KEEP(76) > 6 .OR. KEEP(76) < 0 ) THEN WRITE(*,*) "Error 2 in CMUMPS_EXTRACT_POOL: unknown strategy" CALL MUMPS_ABORT() ENDIF ATOMIC_SUBTREE = ( KEEP(76) == 1 .OR. KEEP(76) == 3) IF ( CMUMPS_POOL_EMPTY(POOL, LPOOL) ) THEN WRITE(*,*) "Error 1 in CMUMPS_EXTRACT_POOL" CALL MUMPS_ABORT() ENDIF IF ( .NOT. ATOMIC_SUBTREE ) THEN LEFT = (NBTOP == 0) IF(.NOT.LEFT)THEN IF((KEEP(76).EQ.4).OR.(KEEP(76).EQ.5))THEN IF(NBINSUBTREE.EQ.0)THEN LEFT=.FALSE. ELSE IF ( POOL(NBINSUBTREE) < 0 ) THEN I = -POOL(NBINSUBTREE) ELSE IF ( POOL(NBINSUBTREE) > N ) THEN I = POOL(NBINSUBTREE) - N ELSE I = POOL(NBINSUBTREE) ENDIF IF ( POOL(LPOOL-2-NBTOP) < 0 ) THEN J = -POOL(LPOOL-2-NBTOP) ELSE IF ( POOL(LPOOL-2-NBTOP) > N ) THEN J = POOL(LPOOL-2-NBTOP) - N ELSE J = POOL(LPOOL-2-NBTOP) ENDIF IF(KEEP(76).EQ.4)THEN IF(DEPTH_FIRST_LOAD(STEP(J)).GE. & DEPTH_FIRST_LOAD(STEP(I)))THEN LEFT=.TRUE. ELSE LEFT=.FALSE. ENDIF ENDIF IF(KEEP(76).EQ.5)THEN IF(COST_TRAV(STEP(J)).LE. & COST_TRAV(STEP(I)))THEN LEFT=.TRUE. ELSE LEFT=.FALSE. ENDIF ENDIF ENDIF ENDIF ENDIF ELSE IF ( INSUBTREE == 1 ) THEN IF (NBINSUBTREE == 0) THEN WRITE(*,*) "Error 3 in CMUMPS_EXTRACT_POOL" CALL MUMPS_ABORT() ENDIF LEFT = .TRUE. ELSE LEFT = ( NBTOP == 0) ENDIF ENDIF 222 CONTINUE IF ( LEFT ) THEN INODE = POOL( NBINSUBTREE ) IF(KEEP(81).EQ.2)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN CALL CMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8,PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(.NOT.SBTR_FLAG)THEN WRITE(*,*)MYID,': ca a change pour moi' LEFT=.FALSE. GOTO 222 ENDIF ENDIF ELSEIF(KEEP(81).EQ.3)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN NODE_TO_EXTRACT=INODE FLAG_MEM=.FALSE. CALL MUMPS_LOAD_CHK_MEMCST_POOL(FLAG_MEM) IF(FLAG_MEM)THEN CALL CMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(.NOT.SBTR_FLAG)THEN LEFT=.FALSE. WRITE(*,*)MYID,': ca a change pour moi (2)' GOTO 222 ENDIF ENDIF ENDIF ENDIF NBINSUBTREE = NBINSUBTREE - 1 IF ( INODE < 0 ) THEN INODE_EFF = -INODE ELSE IF ( INODE > N ) THEN INODE_EFF = INODE - N ELSE INODE_EFF = INODE ENDIF IF ( MUMPS_INSSARBR( PROCNODE(STEP(INODE_EFF)), & KEEP(199)) ) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.0))THEN CALL MUMPS_LOAD_SET_SBTR_MEM(.TRUE.) ENDIF INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE_EFF)), & KEEP(199))) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.1))THEN CALL MUMPS_LOAD_SET_SBTR_MEM(.FALSE.) ENDIF INSUBTREE = 0 END IF ELSE IF (NBTOP < 1 ) THEN WRITE(*,*) "Error 5 in CMUMPS_EXTRACT_POOL", NBTOP CALL MUMPS_ABORT() ENDIF INODE = POOL( LPOOL - 2 - NBTOP ) IF(KEEP(81).EQ.1)THEN CALL MUMPS_LOAD_POOL_CHECK_MEM & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IF(UPPER)THEN GOTO 666 ELSE NBINSUBTREE=NBINSUBTREE-1 IF ( MUMPS_INSSARBR( PROCNODE(STEP(INODE)), & KEEP(199)) ) THEN INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE)), & KEEP(199))) THEN INSUBTREE = 0 ENDIF GOTO 777 ENDIF ENDIF IF(KEEP(81).EQ.2)THEN CALL CMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN LEFT=.TRUE. WRITE(*,*)MYID,': ca a change pour moi (3)' GOTO 222 ENDIF ELSE IF(KEEP(81).EQ.3)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN NODE_TO_EXTRACT=INODE FLAG_MEM=.FALSE. CALL MUMPS_LOAD_CHK_MEMCST_POOL(FLAG_MEM) IF(FLAG_MEM)THEN CALL CMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN LEFT=.TRUE. WRITE(*,*)MYID,': ca a change pour moi (4)' GOTO 222 ENDIF ELSE CALL MUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ENDIF ENDIF ENDIF ENDIF 666 CONTINUE NBTOP = NBTOP - 1 IF((INODE.GT.0).AND.(INODE.LE.N))THEN IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. & ( KEEP(47) == 4 ))) THEN CALL MUMPS_REMOVE_NODE(INODE,2) ENDIF ENDIF IF ( INODE < 0 ) THEN INODE_EFF = -INODE ELSE IF ( INODE > N ) THEN INODE_EFF = INODE - N ELSE INODE_EFF = INODE ENDIF END IF 777 CONTINUE POOL(LPOOL) = NBINSUBTREE POOL(LPOOL - 1) = NBTOP POOL(LPOOL - 2) = INSUBTREE RETURN END SUBROUTINE CMUMPS_EXTRACT_POOL SUBROUTINE CMUMPS_MEM_CONS_MNG(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR,FLAG_SAME_PROC,MIN_PROC) USE MUMPS_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) LOGICAL SBTR,FLAG_SAME_PROC INTEGER POS_TO_EXTRACT,NODE_TO_EXTRACT,NBTOP,I,INSUBTREE, & NBINSUBTREE DOUBLE PRECISION MIN_COST, TMP_COST NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) MIN_COST=huge(MIN_COST) TMP_COST=huge(TMP_COST) FLAG_SAME_PROC=.FALSE. SBTR=.FALSE. MIN_PROC=-9999 IF((INODE.GT.0).AND.(INODE.LE.N))THEN POS_TO_EXTRACT=-1 NODE_TO_EXTRACT=-1 DO I=NBTOP,1,-1 IF(NODE_TO_EXTRACT.LT.0)THEN POS_TO_EXTRACT=I NODE_TO_EXTRACT=POOL(LPOOL-2-I) CALL MUMPS_LOAD_COMP_MAXMEM_POOL(NODE_TO_EXTRACT, & TMP_COST,PROC) MIN_COST=TMP_COST MIN_PROC=PROC ELSE CALL MUMPS_LOAD_COMP_MAXMEM_POOL(POOL(LPOOL-2-I), & TMP_COST,PROC) IF((PROC.NE.MIN_PROC).OR.(TMP_COST.NE.MIN_COST))THEN FLAG_SAME_PROC=.TRUE. ENDIF IF(TMP_COST.GT.MIN_COST)THEN POS_TO_EXTRACT=I NODE_TO_EXTRACT=POOL(LPOOL-2-I) MIN_COST=TMP_COST MIN_PROC=PROC ENDIF ENDIF ENDDO IF((KEEP(47).EQ.4).AND.(NBINSUBTREE.NE.0))THEN CALL MUMPS_CHECK_SBTR_COST(NBINSUBTREE,INSUBTREE,NBTOP, & MIN_COST,SBTR) IF(SBTR)THEN WRITE(*,*)MYID,': selecting from subtree' RETURN ENDIF ENDIF IF((.NOT.SBTR).AND.(.NOT.FLAG_SAME_PROC))THEN WRITE(*,*)MYID,': I must search for a task & to save My friend' RETURN ENDIF INODE = NODE_TO_EXTRACT DO I=POS_TO_EXTRACT,NBTOP IF(I.NE.NBTOP)THEN POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDIF ENDDO POOL(LPOOL-2-NBTOP)=INODE CALL MUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ELSE ENDIF END SUBROUTINE CMUMPS_MEM_CONS_MNG SUBROUTINE CMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) USE MUMPS_LOAD IMPLICIT NONE INTEGER INODE,LPOOL,N,SLAVEF,MYID,MIN_PROC INTEGER POOL(LPOOL),KEEP(500),PROCNODE(KEEP(28)),STEP(N) INTEGER(8) KEEP8(150) LOGICAL SBTR_FLAG,PROC_FLAG EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR INTEGER NODE_TO_EXTRACT,I,POS_TO_EXTRACT,NBTOP,NBINSUBTREE NBTOP= POOL(LPOOL - 1) NBINSUBTREE = POOL(LPOOL) IF(NBTOP.GT.0)THEN WRITE(*,*)MYID,': NBTOP=',NBTOP ENDIF SBTR_FLAG=.FALSE. PROC_FLAG=.FALSE. CALL CMUMPS_MEM_CONS_MNG(INODE,POOL,LPOOL,N,STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN RETURN ENDIF IF(MIN_PROC.EQ.-9999)THEN IF((INODE.GT.0).AND.(INODE.LT.N))THEN SBTR_FLAG=(NBINSUBTREE.NE.0) ENDIF RETURN ENDIF IF(.NOT.PROC_FLAG)THEN NODE_TO_EXTRACT=INODE IF((INODE.GE.0).AND.(INODE.LE.N))THEN CALL MUMPS_FIND_BEST_NODE_FOR_MEM(MIN_PROC,POOL, & LPOOL,INODE) IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)), & KEEP(199)))THEN WRITE(*,*)MYID,': Extracting from a subtree & for helping',MIN_PROC SBTR_FLAG=.TRUE. RETURN ELSE IF(NODE_TO_EXTRACT.NE.INODE)THEN WRITE(*,*)MYID,': Extracting from top & inode=',INODE,'for helping',MIN_PROC ENDIF CALL MUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ENDIF ENDIF DO I=1,NBTOP IF (POOL(LPOOL-2-I).EQ.INODE)THEN GOTO 452 ENDIF ENDDO 452 CONTINUE POS_TO_EXTRACT=I DO I=POS_TO_EXTRACT,NBTOP-1 POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDDO POOL(LPOOL-2-NBTOP)=INODE ENDIF END SUBROUTINE CMUMPS_MEM_NODE_SELECT SUBROUTINE CMUMPS_GET_INODE_FROM_POOL & ( IPOOL, LPOOL, III, LEAF, & INODE, STRATEGIE ) IMPLICIT NONE INTEGER, INTENT(IN) :: STRATEGIE, LPOOL INTEGER IPOOL (LPOOL) INTEGER III,LEAF INTEGER, INTENT(OUT) :: INODE LEAF = LEAF - 1 INODE = IPOOL( LEAF ) RETURN END SUBROUTINE CMUMPS_GET_INODE_FROM_POOL MUMPS_5.8.1/src/dfac_sol_l0omp_m.F0000664000175000017500000003360015042446440016536 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FACSOL_L0OMP_M PRIVATE PUBLIC :: DMUMPS_INIT_L0_OMP_FACTORS & , DMUMPS_FREE_L0_OMP_FACTORS #if ! defined(NO_SAVE_RESTORE) & , DMUMPS_SAVE_RESTORE_L0FACARRAY #endif #if ! defined(NO_SAVE_RESTORE) #endif #if ! defined(NO_SAVE_RESTORE) INCLUDE 'mumps_save_restore_modes.h' #endif CONTAINS SUBROUTINE DMUMPS_INIT_L0_OMP_FACTORS(id_L0_OMP_FACTORS) USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (DMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & id_L0_OMP_FACTORS INTEGER I IF (associated(id_L0_OMP_FACTORS)) THEN DO I=1, size(id_L0_OMP_FACTORS) NULLIFY(id_L0_OMP_FACTORS(I)%A) ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_INIT_L0_OMP_FACTORS SUBROUTINE DMUMPS_FREE_L0_OMP_FACTORS(id_L0_OMP_FACTORS) USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (DMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & id_L0_OMP_FACTORS INTEGER I IF (associated(id_L0_OMP_FACTORS)) THEN DO I=1, size(id_L0_OMP_FACTORS) IF (associated(id_L0_OMP_FACTORS(I)%A)) THEN DEALLOCATE(id_L0_OMP_FACTORS(I)%A) NULLIFY(id_L0_OMP_FACTORS(I)%A) ENDIF ENDDO DEALLOCATE(id_L0_OMP_FACTORS) NULLIFY(id_L0_OMP_FACTORS) ENDIF RETURN END SUBROUTINE DMUMPS_FREE_L0_OMP_FACTORS #if ! defined(NO_SAVE_RESTORE) SUBROUTINE DMUMPS_SAVE_RESTORE_L0FACARRAY(L0_OMP_FACTORS & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (DMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: L0_OMP_FACTORS INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: j1,NbRecords,NbSubRecords,size_array1,dummy,allocok,err INTEGER:: SIZE_GEST_L0FAC_ARRAY, & SIZE_GEST_L0FAC_ARRAY_j1 INTEGER(4) :: I4 INTEGER(8):: SIZE_VARIABLES_L0FAC_ARRAY, & SIZE_VARIABLES_L0FAC_ARRAY_j1 SIZE_GEST = 0 SIZE_VARIABLES = 0_8 SIZE_GEST_L0FAC_ARRAY=0 SIZE_VARIABLES_L0FAC_ARRAY=0 SIZE_GEST_L0FAC_ARRAY_j1=0 SIZE_VARIABLES_L0FAC_ARRAY_j1=0 NbRecords = 0 IF (mode.EQ.memory_save_mode) THEN IF (associated(L0_OMP_FACTORS)) THEN NbRecords = 1 SIZE_GEST = SIZE_INT SIZE_VARIABLES = 0 DO j1=1,size(L0_OMP_FACTORS) CALL DMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_L0FAC_ARRAY_j1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_L0FAC_ARRAY=SIZE_GEST_L0FAC_ARRAY+ & SIZE_GEST_L0FAC_ARRAY_j1 SIZE_VARIABLES_L0FAC_ARRAY=SIZE_VARIABLES_L0FAC_ARRAY+ & SIZE_VARIABLES_L0FAC_ARRAY_j1 IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords = 2 SIZE_GEST = 2*SIZE_INT SIZE_VARIABLES = 0 ENDIF ELSEIF (mode.EQ.save_mode) THEN IF (associated(L0_OMP_FACTORS)) THEN NbRecords = 1 SIZE_GEST = SIZE_INT SIZE_VARIABLES = 0 write(unit,iostat=err) size(L0_OMP_FACTORS) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 DO j1=1,size(L0_OMP_FACTORS) CALL DMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_L0FAC_ARRAY_J1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF ELSE IF (mode.EQ.restore_mode) THEN NULLIFY(L0_OMP_FACTORS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 allocate(L0_OMP_FACTORS(size_array1), stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size(L0_OMP_FACTORS) CALL DMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_L0FAC_ARRAY_J1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_L0FAC_ARRAY=SIZE_GEST_L0FAC_ARRAY+ & SIZE_GEST_L0FAC_ARRAY_j1 SIZE_VARIABLES_L0FAC_ARRAY=SIZE_VARIABLES_L0FAC_ARRAY+ & SIZE_VARIABLES_L0FAC_ARRAY_j1 IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO endif ENDIF if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(mode.EQ.memory_save_mode) then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_L0FAC_ARRAY SIZE_GEST=SIZE_GEST+SIZE_GEST_L0FAC_ARRAY #if defined(MUMPS_NOF2003) SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif 100 continue RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_L0FACARRAY SUBROUTINE DMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS_1THREAD & ,unit,MYID,mode & ,Local_SIZE_GEST, Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (DMUMPS_L0OMPFAC_T) :: L0_OMP_FACTORS_1THREAD INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: Local_NbRecords, allocok, err INTEGER(8) :: itmp Local_NbRecords = 0 Local_SIZE_GEST = 0 Local_SIZE_VARIABLES = 0_8 Local_NbRecords = Local_NbRecords+1 IF (mode .EQ. memory_save_mode) THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 ELSE IF (mode .EQ. save_mode) THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 WRITE(unit,iostat=err) L0_OMP_FACTORS_1THREAD%LA IF (err .NE. 0) THEN INFO(1)=-72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 ENDIF size_written=size_written+SIZE_INT8 ELSE IF (mode .EQ. restore_mode) THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 READ(unit,iostat=err) L0_OMP_FACTORS_1THREAD%LA IF (err .NE. 0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & INFO(2)) GOTO 100 ENDIF size_read=size_read+SIZE_INT8 ENDIF IF (mode.EQ.memory_save_mode) THEN IF (associated(L0_OMP_FACTORS_1THREAD%A)) THEN Local_NbRecords = Local_NbRecords + 2 Local_SIZE_GEST = Local_SIZE_GEST + SIZE_INT8 Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP ELSE Local_NbRecords = Local_NbRecords + 1 Local_SIZE_GEST = Local_SIZE_GEST + SIZE_INT8 Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + 0 ENDIF ELSEIF (mode.EQ.save_mode) THEN IF (associated(L0_OMP_FACTORS_1THREAD%A)) THEN Local_NbRecords = Local_NbRecords + 2 write(unit,iostat=err) int(0,8) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written=size_written+SIZE_INT8 write(unit,iostat=err) L0_OMP_FACTORS_1THREAD%A if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written = size_written + & max(L0_OMP_FACTORS_1THREAD%LA,1_8)*SIZE_ARITH_DEP ELSE Local_NbRecords = Local_NbRecords + 1 write(unit,iostat=err) int(-999,8) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written=size_written+SIZE_INT8 ENDIF ELSEIF (mode.EQ.restore_mode) THEN NULLIFY(L0_OMP_FACTORS_1THREAD%A) READ(unit,iostat=err) itmp if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 100 endif size_read = size_read + SIZE_INT8 size_allocated = size_allocated + SIZE_INT8 IF (itmp .eq. -999) THEN Local_NbRecords = Local_NbRecords + 1 ELSE Local_NbRecords = Local_NbRecords + 2 ALLOCATE(L0_OMP_FACTORS_1THREAD%A( & max(L0_OMP_FACTORS_1THREAD%LA,1_8)), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) GOTO 100 ENDIF READ(unit,iostat=err) L0_OMP_FACTORS_1THREAD%A if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 100 endif size_read = size_read + & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP size_allocated = size_allocated+ & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP ENDIF ENDIF #if defined(MUMPS_NOF2003) IF (mode.EQ.memory_save_mode) THEN Local_SIZE_GEST = Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords ELSE IF (mode.EQ.save_mode) THEN size_written = size_written+2*SIZE_INT*Local_NbRecords ELSE IF (mode.EQ.restore_mode) THEN size_read = size_read+2*SIZE_INT*Local_NbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_L0FAC #endif END MODULE DMUMPS_FACSOL_L0OMP_M MUMPS_5.8.1/src/mumps_thread.c0000664000175000017500000000167415042446422016074 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #define USLEEP F_SYMBOL(usleep,USLEEP) #include "mumps_common.h" #if defined(MUMPS_WIN32) # include void MUMPS_CALL USLEEP(MUMPS_INT* time) { /* int* time : in microseconds */ /* Sleep: milliseconds */ Sleep((unsigned long)(*time)/1000); } #else # include void MUMPS_CALL USLEEP(MUMPS_INT* time) { /* int* time : in microseconds */ /* usleep: microseconds */ usleep((unsigned int)*time); } #endif MUMPS_5.8.1/src/Makefile0000664000175000017500000004313615042446416014702 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # # topdir = .. libdir = $(topdir)/lib incdir = $(topdir)/include default: d .PHONY: default all s d c z clean libcommon allshared sshared dshared cshared zshared libcommonshared all: $(incdir)/mumps_int_def.h libcommon s d c z d: s z: c dshared: sshared zshared: cshared libcommon: $(incdir)/mumps_int_def.h $(MAKE) $(libdir)/libmumps_common$(PLAT)$(LIBEXT) s: $(incdir)/mumps_int_def.h libcommon $(MAKE) ARITH=s $(libdir)/libsmumps$(PLAT)$(LIBEXT) d: $(incdir)/mumps_int_def.h libcommon $(MAKE) ARITH=d $(libdir)/libdmumps$(PLAT)$(LIBEXT) c: $(incdir)/mumps_int_def.h libcommon $(MAKE) ARITH=c $(libdir)/libcmumps$(PLAT)$(LIBEXT) z: $(incdir)/mumps_int_def.h libcommon $(MAKE) ARITH=z $(libdir)/libzmumps$(PLAT)$(LIBEXT) # Rules for shared libraries allshared: $(incdir)/mumps_int_def.h libcommonshared sshared dshared cshared zshared libcommonshared: $(incdir)/mumps_int_def.h $(MAKE) FPIC=$(FPIC_OPT) $(libdir)/libmumps_common$(PLAT)$(LIBEXT_SHARED) sshared: $(incdir)/mumps_int_def.h libcommonshared $(MAKE) ARITH=s FPIC=$(FPIC_OPT) $(libdir)/libsmumps$(PLAT)$(LIBEXT_SHARED) dshared: $(incdir)/mumps_int_def.h libcommonshared $(MAKE) ARITH=d FPIC=$(FPIC_OPT) $(libdir)/libdmumps$(PLAT)$(LIBEXT_SHARED) cshared: $(incdir)/mumps_int_def.h libcommonshared $(MAKE) ARITH=c FPIC=$(FPIC_OPT) $(libdir)/libcmumps$(PLAT)$(LIBEXT_SHARED) zshared: $(incdir)/mumps_int_def.h libcommonshared $(MAKE) ARITH=z FPIC=$(FPIC_OPT) $(libdir)/libzmumps$(PLAT)$(LIBEXT_SHARED) OBJS_COMMON_MOD = \ ana_blk_m.o\ ana_omp_m.o\ ana_orderings_wrappers_m.o\ double_linked_list.o\ fac_asm_build_sort_index_ELT_m.o\ fac_asm_build_sort_index_m.o\ fac_descband_data_m.o\ fac_future_niv2_mod.o\ fac_maprow_data_m.o\ front_data_mgt_m.o\ lr_common.o \ lr_stats.o\ mumps_comm_buffer_common.o \ mumps_intr_types_common.o \ mumps_l0_omp_m.o\ mumps_load.o\ mumps_memory_mod.o\ mumps_mpitoomp_m.o\ mumps_ooc_common.o\ mumps_pivnul_mod.o \ mumps_static_mapping.o\ omp_tps_common_m.o\ sol_ds_common_m.o\ sol_omp_common_m.o\ tools_common_m.o # Object files for arithmetic-independent FORTRAN files. OBJS_COMMON_OTHER = \ ana_blk.o\ ana_orderings.o\ ana_set_ordering.o\ ana_AMDMF.o\ bcast_errors.o\ estim_flops.o\ mumps_type2_blocking.o\ mumps_version.o\ mumps_print_defined.o\ sol_common.o\ tools_common.o # Object files for arithmetic-independent C files. OBJS_C_COMMON = \ mumps_addr.o\ mumps_common.o\ mumps_config_file_C.o\ mumps_io.o\ mumps_io_basic.o\ mumps_io_err.o\ mumps_numa.o\ mumps_io_thread.o\ mumps_pord.o\ mumps_metis.o\ mumps_metis64.o\ mumps_metis_int.o\ mumps_scotch.o\ mumps_scotch64.o\ mumps_scotch_int.o\ mumps_register_thread.o\ mumps_thread.o\ mumps_thread_affinity.o\ mumps_flytes.o\ mumps_save_restore_C.o\ OBJS_MOD_ARITHDEP = \ $(ARITH)ana_aux.o\ $(ARITH)ana_aux_par.o\ $(ARITH)ana_lr.o\ $(ARITH)fac_asm_master_ELT_m.o\ $(ARITH)fac_asm_master_m.o\ $(ARITH)fac_compact_factors_m.o\ $(ARITH)fac_front_aux.o\ $(ARITH)fac_front_LU_type1.o\ $(ARITH)fac_front_LU_type2.o\ $(ARITH)fac_front_LDLT_type1.o\ $(ARITH)fac_front_LDLT_type2.o\ $(ARITH)fac_front_type2_aux.o\ $(ARITH)fac_sispointers_m.o\ $(ARITH)fac_lr.o\ $(ARITH)fac_mem_dynamic.o\ $(ARITH)fac_omp_m.o\ $(ARITH)fac_par_m.o\ $(ARITH)fac_sol_l0omp_m.o\ $(ARITH)lr_core.o\ $(ARITH)lr_type.o\ $(ARITH)mumps_comm_buffer.o\ $(ARITH)mumps_config_file.o\ $(ARITH)mumps_intr_types.o\ $(ARITH)mumps_lr_data_m.o\ $(ARITH)mumps_mpi3_mod.o\ $(ARITH)mumps_ooc_buffer.o\ $(ARITH)mumps_ooc.o\ $(ARITH)mumps_sol_es.o\ $(ARITH)mumps_save_restore_files.o\ $(ARITH)mumps_save_restore.o\ $(ARITH)mumps_struc_def.o\ $(ARITH)omp_tps_m.o\ $(ARITH)sol_lr.o\ $(ARITH)sol_omp_m.o\ $(ARITH)static_ptr_m.o OBJS_OTHER = \ $(ARITH)ana_aux_ELT.o\ $(ARITH)ana_dist_m.o\ $(ARITH)ana_driver.o\ $(ARITH)ana_LDLT_preprocess.o\ $(ARITH)ana_reordertree.o\ $(ARITH)arrowheads.o\ $(ARITH)bcast_int.o\ $(ARITH)end_driver.o\ $(ARITH)fac_asm_ELT.o\ $(ARITH)fac_asm.o\ $(ARITH)fac_b.o\ $(ARITH)fac_diag.o\ $(ARITH)fac_distrib_distentry.o\ $(ARITH)fac_dist_arrowheads_omp.o\ $(ARITH)fac_distrib_ELT.o\ $(ARITH)fac_driver.o\ $(ARITH)fac_lastrtnelind.o\ $(ARITH)fac_mem_alloc_cb.o\ $(ARITH)fac_mem_compress_cb.o\ $(ARITH)fac_mem_free_block_cb.o\ $(ARITH)fac_mem_stack_aux.o\ $(ARITH)fac_mem_stack.o\ $(ARITH)fac_process_band.o\ $(ARITH)fac_process_blfac_slave.o\ $(ARITH)fac_process_blocfacto_LDLT.o\ $(ARITH)fac_process_blocfacto.o\ $(ARITH)fac_process_bf.o\ $(ARITH)fac_process_end_facto_slave.o\ $(ARITH)fac_process_contrib_type1.o\ $(ARITH)fac_process_contrib_type2.o\ $(ARITH)fac_process_contrib_type3.o\ $(ARITH)fac_process_maprow.o\ $(ARITH)fac_process_master2.o\ $(ARITH)fac_process_message.o\ $(ARITH)fac_process_root2slave.o\ $(ARITH)fac_process_root2son.o\ $(ARITH)fac_process_rtnelind.o\ $(ARITH)fac_root_parallel.o\ $(ARITH)fac_scalings.o\ $(ARITH)fac_determinant.o\ $(ARITH)fac_scalings_simScaleAbs.o\ $(ARITH)fac_scalings_simScale_util.o\ $(ARITH)fac_sol_pool.o\ $(ARITH)fac_type3_symmetrize.o\ $(ARITH)ini_defaults.o\ $(ARITH)ini_driver.o\ $(ARITH)mumps_c.o\ $(ARITH)mumps_driver.o\ $(ARITH)mumps_f77.o\ $(ARITH)mumps_gpu.o\ $(ARITH)mumps_iXamax.o\ $(ARITH)ana_mtrans.o\ $(ARITH)ooc_panel_piv.o\ $(ARITH)rank_revealing.o\ $(ARITH)sol_aux.o\ $(ARITH)sol_bwd_aux.o\ $(ARITH)sol_bwd.o\ $(ARITH)sol_c.o\ $(ARITH)sol_distrhs.o\ $(ARITH)sol_distsol.o\ $(ARITH)sol_driver.o\ $(ARITH)sol_fwd_aux.o\ $(ARITH)sol_fwd.o\ $(ARITH)sol_matvec.o\ $(ARITH)sol_root_parallel.o\ $(ARITH)tools.o\ $(ARITH)type3_root.o include $(topdir)/Makefile.inc $(incdir)/mumps_int_def.h: mumps_int_def32_h.in mumps_int_def64_h.in if echo " $(OPTC) " | grep DINTSIZE64; then cat mumps_int_def64_h.in > $(incdir)/mumps_int_def.h; else cat mumps_int_def32_h.in > $(incdir)/mumps_int_def.h; fi $(libdir)/libmumps_common$(PLAT)$(LIBEXT): $(OBJS_COMMON_MOD) $(OBJS_COMMON_OTHER) $(OBJS_C_COMMON) $(AR)$@ $? $(RANLIB) $@ $(libdir)/libmumps_common$(PLAT)$(LIBEXT_SHARED): $(OBJS_COMMON_MOD) $(OBJS_COMMON_OTHER) $(OBJS_C_COMMON) $(FC) $(OPTL) $(SHARED_OPT) $^ -Wl,$(SONAME),libmumps_common$(PLAT)$(LIBEXT_SHARED) -L$(libdir) $(RPATH_OPT) $(LORDERINGS) $(LIBS) $(LIBOTHERS) -o $@ $(libdir)/lib$(ARITH)mumps$(PLAT)$(LIBEXT): $(OBJS_MOD_ARITHDEP) $(OBJS_OTHER) $(AR)$@ $? $(RANLIB) $@ $(libdir)/lib$(ARITH)mumps$(PLAT)$(LIBEXT_SHARED): $(OBJS_MOD_ARITHDEP) $(OBJS_OTHER) $(libdir)/libmumps_common$(PLAT)$(LIBEXT_SHARED) $(FC) $(OPTL) $(SHARED_OPT) $(OBJS_MOD_ARITHDEP) $(OBJS_OTHER) -L$(libdir) $(LORDERINGS) $(LIBS) $(LIBOTHERS) -lmumps_common$(PLAT) -o $@ $(RPATH_OPT) # Dependencies between modules: # i) arithmetic-dependent modules: $(ARITH)ana_aux.o: $(ARITH)mumps_struc_def.o \ mumps_static_mapping.o \ ana_orderings_wrappers_m.o \ ana_blk_m.o $(ARITH)ana_aux_par.o: $(ARITH)mumps_struc_def.o \ mumps_memory_mod.o \ ana_orderings_wrappers_m.o \ tools_common_m.o $(ARITH)ana_lr.o: $(ARITH)lr_core.o\ lr_stats.o\ lr_common.o\ ana_orderings_wrappers_m.o \ ana_blk_m.o $(ARITH)fac_asm_master_ELT_m.o: omp_tps_common_m.o \ fac_asm_build_sort_index_ELT_m.o \ lr_common.o \ $(ARITH)fac_mem_dynamic.o \ $(ARITH)lr_core.o \ $(ARITH)ana_lr.o \ $(ARITH)mumps_lr_data_m.o \ $(ARITH)mumps_intr_types.o \ $(ARITH)omp_tps_m.o \ mumps_comm_buffer_common.o \ mumps_load.o $(ARITH)fac_asm_master_m.o: omp_tps_common_m.o \ fac_asm_build_sort_index_m.o \ lr_common.o \ $(ARITH)fac_mem_dynamic.o \ $(ARITH)lr_core.o \ $(ARITH)ana_lr.o \ $(ARITH)mumps_lr_data_m.o \ $(ARITH)mumps_intr_types.o \ $(ARITH)omp_tps_m.o \ mumps_comm_buffer_common.o \ mumps_load.o $(ARITH)fac_compact_factors_m.o:$(ARITH)fac_mem_dynamic.o $(ARITH)fac_front_aux.o: $(ARITH)lr_type.o\ lr_stats.o\ mumps_comm_buffer_common.o \ mumps_load.o\ $(ARITH)mumps_ooc.o\ mumps_ooc_common.o\ mumps_l0_omp_m.o \ mumps_pivnul_mod.o $(ARITH)fac_front_LU_type1.o : $(ARITH)fac_front_aux.o\ $(ARITH)mumps_ooc.o\ $(ARITH)fac_lr.o\ $(ARITH)lr_type.o\ $(ARITH)mumps_intr_types.o\ lr_stats.o\ $(ARITH)ana_lr.o\ $(ARITH)mumps_lr_data_m.o\ mumps_l0_omp_m.o\ mumps_pivnul_mod.o $(ARITH)fac_front_LU_type2.o : $(ARITH)fac_front_aux.o\ $(ARITH)fac_front_type2_aux.o\ $(ARITH)mumps_ooc.o\ mumps_comm_buffer_common.o \ $(ARITH)fac_lr.o\ $(ARITH)lr_core.o\ $(ARITH)lr_type.o\ lr_stats.o\ $(ARITH)ana_lr.o\ $(ARITH)mumps_intr_types.o\ $(ARITH)mumps_lr_data_m.o\ mumps_pivnul_mod.o $(ARITH)fac_front_LDLT_type1.o : $(ARITH)fac_front_aux.o\ $(ARITH)mumps_ooc.o\ $(ARITH)fac_lr.o\ $(ARITH)lr_type.o\ lr_stats.o\ $(ARITH)ana_lr.o\ $(ARITH)mumps_lr_data_m.o\ mumps_l0_omp_m.o\ mumps_pivnul_mod.o $(ARITH)fac_front_LDLT_type2.o : $(ARITH)fac_front_aux.o\ $(ARITH)fac_front_type2_aux.o\ $(ARITH)mumps_ooc.o\ mumps_comm_buffer_common.o \ mumps_load.o\ $(ARITH)fac_lr.o\ $(ARITH)lr_type.o\ lr_stats.o\ $(ARITH)ana_lr.o\ $(ARITH)mumps_intr_types.o\ $(ARITH)mumps_lr_data_m.o\ mumps_pivnul_mod.o $(ARITH)fac_front_type2_aux.o : mumps_ooc_common.o\ $(ARITH)fac_front_aux.o\ $(ARITH)lr_type.o\ $(ARITH)mumps_comm_buffer.o\ $(ARITH)mumps_intr_types.o \ mumps_load.o\ mumps_pivnul_mod.o $(ARITH)fac_lr.o: $(ARITH)lr_core.o\ $(ARITH)lr_type.o\ $(ARITH)mumps_lr_data_m.o\ lr_stats.o $(ARITH)fac_mem_dynamic.o: mumps_load.o\ $(ARITH)static_ptr_m.o $(ARITH)fac_omp_m.o: $(ARITH)fac_asm_master_m.o\ $(ARITH)fac_asm_master_ELT_m.o\ $(ARITH)fac_front_LU_type1.o\ $(ARITH)fac_front_LDLT_type1.o\ $(ARITH)fac_mem_dynamic.o\ $(ARITH)mumps_intr_types.o\ mumps_load.o\ omp_tps_common_m.o\ $(ARITH)omp_tps_m.o\ lr_stats.o\ mumps_l0_omp_m.o \ mumps_pivnul_mod.o $(ARITH)fac_sol_l0omp_m.o: $(ARITH)mumps_intr_types.o $(ARITH)fac_omp_m.o: $(ARITH)mumps_struc_def.o \ $(ARITH)fac_mem_dynamic.o\ $(ARITH)omp_tps_m.o\ omp_tps_common_m.o\ mumps_pivnul_mod.o $(ARITH)fac_par_m.o: mumps_load.o\ $(ARITH)mumps_ooc.o\ $(ARITH)fac_asm_master_m.o\ $(ARITH)fac_asm_master_ELT_m.o\ $(ARITH)omp_tps_m.o\ $(ARITH)fac_front_LU_type1.o\ $(ARITH)fac_front_LU_type2.o\ $(ARITH)fac_front_LDLT_type1.o\ $(ARITH)fac_front_LDLT_type2.o\ $(ARITH)fac_mem_dynamic.o\ $(ARITH)mumps_intr_types.o\ lr_stats.o\ omp_tps_common_m.o\ mumps_l0_omp_m.o\ mumps_pivnul_mod.o $(ARITH)lr_core.o: $(ARITH)lr_type.o\ $(ARITH)mumps_lr_data_m.o\ lr_stats.o\ lr_common.o lr_stats.o: lr_common.o $(ARITH)lr_type.o: lr_common.o $(ARITH)mumps_comm_buffer.o: $(ARITH)lr_type.o \ $(ARITH)lr_core.o \ $(ARITH)mumps_lr_data_m.o \ mumps_comm_buffer_common.o $(ARITH)mumps_config_file.o: $(ARITH)mumps_struc_def.o mumps_load.o: mumps_comm_buffer_common.o \ fac_future_niv2_mod.o $(ARITH)mumps_intr_types.o: mumps_intr_types_common.o $(ARITH)mumps_lr_data_m.o: $(ARITH)lr_type.o\ front_data_mgt_m.o $(ARITH)mumps_ooc_buffer.o: mumps_ooc_common.o $(ARITH)mumps_ooc.o: $(ARITH)mumps_ooc_buffer.o \ mumps_ooc_common.o $(ARITH)mumps_sol_es.o: $(ARITH)lr_type.o \ $(ARITH)mumps_lr_data_m.o $(ARITH)mumps_save_restore.o: $(ARITH)mumps_struc_def.o \ $(ARITH)mumps_save_restore_files.o \ $(ARITH)mumps_lr_data_m.o \ $(ARITH)mumps_ooc.o \ $(ARITH)fac_sol_l0omp_m.o \ $(ARITH)mumps_mpi3_mod.o \ front_data_mgt_m.o $(ARITH)mumps_save_restore_files.o : $(ARITH)mumps_struc_def.o $(ARITH)sol_lr.o: $(ARITH)lr_type.o\ lr_stats.o\ $(ARITH)lr_core.o\ $(ARITH)mumps_lr_data_m.o $(ARITH)sol_omp_m.o: $(ARITH)mumps_intr_types.o # Dependencies between modules: # ii) arithmetic-independent modules: ana_omp_m.o: double_linked_list.o fac_asm_build_sort_index_ELT_m.o:omp_tps_common_m.o fac_asm_build_sort_index_m.o: omp_tps_common_m.o fac_descband_data_m.o: front_data_mgt_m.o fac_maprow_data_m.o: front_data_mgt_m.o mumps_static_mapping.o: lr_common.o # Compile modules before the rest $(OBJS_COMMON_OTHER):$(OBJS_COMMON_MOD) $(OBJS_OTHER):$(OBJS_COMMON_MOD) $(OBJS_MOD_ARITHDEP) .SUFFIXES: .c .F .o .F.o: $(FC) $(OPTF) $(FPIC) -I. -I../include $(INCS) $(IORDERINGSF) $(ORDERINGSF) -c $*.F $(OUTF)$*.o .c.o: $(CC) $(OPTC) $(FPIC) -I../include $(INCS) $(CDEFS) $(IORDERINGSC) $(ORDERINGSC) -c $*.c $(OUTC)$*.o $(ARITH)mumps_c.o: mumps_c.c $(CC) $(OPTC) $(FPIC) -I../include $(INCS) $(CDEFS) -DMUMPS_ARITH=MUMPS_ARITH_$(ARITH) \ $(IORDERINGSC) $(ORDERINGSC) -c mumps_c.c $(OUTC)$@ clean: $(RM) *.o *.mod $(incdir)/mumps_int_def.h MUMPS_5.8.1/src/dsol_root_parallel.F0000664000175000017500000000753315042446437017235 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ROOT_SOLVE( NRHS, DESCA_PAR, & CNTXT_PAR,LOCAL_M,LOCAL_N,MBLOCK,NBLOCK, & IPIV,LPIV,MASTER_ROOT,MYID,COMM, & RHS_SEQ,SIZE_ROOT,A,INFO,MTYPE,LDLT ) IMPLICIT NONE INTEGER NRHS, MTYPE INTEGER DESCA_PAR( 9 ) INTEGER LOCAL_M, LOCAL_N, MBLOCK, NBLOCK INTEGER CNTXT_PAR, MASTER_ROOT, SIZE_ROOT INTEGER MYID, COMM INTEGER LPIV, IPIV( LPIV ) INTEGER INFO(80), LDLT DOUBLE PRECISION RHS_SEQ( SIZE_ROOT *NRHS) DOUBLE PRECISION A( LOCAL_M, LOCAL_N ) #if ! defined(NOSCALAPACK) INTEGER IERR, NPROW, NPCOL, MYROW, MYCOL INTEGER LOCAL_N_RHS DOUBLE PRECISION, ALLOCATABLE, DIMENSION( :,: ) ::RHS_PAR INTEGER, EXTERNAL :: MUMPS_NUMROC INTEGER allocok CALL blacs_gridinfo( CNTXT_PAR, NPROW, NPCOL, MYROW, MYCOL ) LOCAL_N_RHS = MUMPS_NUMROC(NRHS, NBLOCK, MYCOL, 0, NPCOL) LOCAL_N_RHS = max(1,LOCAL_N_RHS) ALLOCATE(RHS_PAR(LOCAL_M, LOCAL_N_RHS),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) ' Problem during solve of the root.' WRITE(*,*) ' Reduce number of right hand sides.' CALL MUMPS_ABORT() ENDIF CALL DMUMPS_SCATTER_ROOT( MYID, SIZE_ROOT, NRHS, RHS_SEQ, & LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) CALL DMUMPS_SOLVE_2D_BCYCLIC (SIZE_ROOT, NRHS, MTYPE, & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, & IPIV, LPIV, RHS_PAR, LDLT, & MBLOCK, NBLOCK, CNTXT_PAR, & IERR) CALL DMUMPS_GATHER_ROOT( MYID, SIZE_ROOT, NRHS, & RHS_SEQ, LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) DEALLOCATE(RHS_PAR) #endif RETURN END SUBROUTINE DMUMPS_ROOT_SOLVE #if ! defined(NOSCALAPACK) SUBROUTINE DMUMPS_SOLVE_2D_BCYCLIC (SIZE_ROOT, NRHS, MTYPE, & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, & IPIV, LPIV, RHS_PAR, LDLT, & MBLOCK, NBLOCK, CNTXT_PAR, & IERR) IMPLICIT NONE INTEGER, intent (in) :: SIZE_ROOT, NRHS, LDLT, LOCAL_M, & LOCAL_N, LOCAL_N_RHS, & MBLOCK, NBLOCK, CNTXT_PAR, MTYPE INTEGER, intent (in) :: DESCA_PAR( 9 ) INTEGER, intent (in) :: LPIV, IPIV( LPIV ) DOUBLE PRECISION, intent (in) :: A( LOCAL_M, LOCAL_N ) DOUBLE PRECISION, intent (inout) :: RHS_PAR(LOCAL_M, LOCAL_N_RHS) INTEGER, intent (out) :: IERR INTEGER :: DESCB_PAR( 9 ) IERR = 0 CALL DESCINIT( DESCB_PAR, SIZE_ROOT, & NRHS, MBLOCK, NBLOCK, 0, 0, & CNTXT_PAR, LOCAL_M, IERR ) IF (IERR.NE.0) THEN WRITE(*,*) 'After DESCINIT, IERR = ', IERR CALL MUMPS_ABORT() END IF IF ( LDLT .eq. 0 .OR. LDLT .eq. 2 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL pdgetrs('N',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, & RHS_PAR,1,1,DESCB_PAR,IERR) ELSE CALL pdgetrs('T',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, & RHS_PAR, 1, 1, DESCB_PAR,IERR) END IF ELSE CALL pdpotrs( 'L', SIZE_ROOT, NRHS, A, 1, 1, DESCA_PAR, & RHS_PAR, 1, 1, DESCB_PAR, IERR ) END IF IF ( IERR .LT. 0 ) THEN WRITE(*,*) ' Problem during solve of the root' CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE DMUMPS_SOLVE_2D_BCYCLIC #endif MUMPS_5.8.1/src/sfac_front_LDLT_type1.F0000664000175000017500000011503715042446437017441 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC1_LDLT_M CONTAINS SUBROUTINE SMUMPS_FAC1_LDLT( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, IERROR, & UU, NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) USE SMUMPS_FAC_FRONT_AUX_M USE SMUMPS_OOC USE SMUMPS_FAC_LR USE SMUMPS_LR_TYPE USE MUMPS_LR_STATS USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_DATA_M USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T #if ! defined(BLR_NOOPENMP) #endif !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, intent(inout) :: NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW INTEGER MYID, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL UU, SEUIL REAL A( LA ) INTEGER, TARGET :: IW( LIW ) INTEGER, intent(in) :: PERM(N) LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER :: LDA REAL UUTEMP LOGICAL STATICMODE REAL SEUIL_LOC LOGICAL IS_MAXFROMM_AVAIL INTEGER PIVOT_OPTION INTEGER LRTRSM_OPTION INTEGER LAST_ROW, FIRST_ROW REAL MAXFROMM INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPiv2beWritten, IFLAG_OOC, & IDUMMY, PP_FIRST2SWAP_L, PP_LastPIVRPTRFilled TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PARPIV_T1, OFFSET INTEGER NFS4FATHER REAL, ALLOCATABLE, DIMENSION(:) :: M_ARRAY LOGICAL LASTPANEL INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER K473_LOC INTEGER INFO_TMP(2), MAXI_RANK INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM, NELIM_LOC TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L REAL, POINTER, DIMENSION(:) :: DIAG INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DIAGPOS, I, IP, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG REAL, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) REAL, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok,J INTEGER :: OMP_NUM INTEGER :: II,JJ INTEGER(8) :: UPOS, LPOS, DPOS REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) LOGICAL :: SWAP_OCCURRED INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC INTEGER :: NVSCHUR, NVSCHUR_K253, IROW_L INCLUDE 'mumps_headers.h' INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER PIVSIZ,IWPOSP2 IS_MAXFROMM_AVAIL = .FALSE. IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF SWAP_OCCURRED = .FALSE. INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF UUTEMP=UU IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC = SEUIL ENDIF LAFAC = -9999_8 XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) LDA = NFRONT NASS = abs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. COMPRESS_PANEL = .FALSE. COMPRESS_CB = .FALSE. NULLIFY(PTDummy) NULLIFY(BEGS_BLR) NULLIFY(CB_LRB) NULLIFY(ACC_LUA) NULLIFY(BLR_L) NULLIFY(BEGS_BLR_TMP) NULLIFY(BLR_PANEL) NULLIFY(DIAG) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. K473_LOC = 1 ELSE K473_LOC = KEEP(473) ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL SMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS, KEEP, & LR_ACTIVATED, PARPIV_T1) LRTRSM_OPTION = KEEP(475) PIVOT_OPTION = KEEP(468) IF (UUTEMP.EQ.ZERO) THEN PIVOT_OPTION = 0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF IF (LR_ACTIVATED) THEN IF (LRTRSM_OPTION.EQ.3) THEN PIVOT_OPTION = MIN(PIVOT_OPTION,1) ELSEIF (LRTRSM_OPTION.EQ.2) THEN PIVOT_OPTION = MIN(PIVOT_OPTION, 2) ENDIF ENDIF IF (PIVOT_OPTION.LE.1) THEN PARPIV_T1 = 0 ENDIF CALL SMUMPS_SET_INNERBLOCKSIZE( NBKJIB_ORIG, NASS, KEEP) IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = IOLDPS+6+XSIZE+NASS CALL SMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 LASTPANEL = .FALSE. CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF (OOC_EFFECTIVE_ON_FRONT) THEN IDUMMY = -8765 NextPiv2beWritten = 1 PP_FIRST2SWAP_L = NextPiv2beWritten MonBloc%LastPanelWritten_L = 0 PP_LastPIVRPTRFilled = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 1 MonBloc%NROW = NFRONT MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -77777 MonBloc%INDICES => & IW(IOLDPS+6+NFRONT+XSIZE: & IOLDPS+5+NFRONT+XSIZE+NFRONT) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(405) .EQ. 1) THEN !$OMP ATOMIC UPDATE CNT_NODES = CNT_NODES + 1 !$OMP END ATOMIC ELSE CNT_NODES = CNT_NODES + 1 ENDIF ELSE IF (KEEP(486).NE.0) THEN ENDIF OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472), & NFRONT, KEEP(1)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 500 CALL SMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .FALSE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF IF (COMPRESS_CB) THEN IF (NPARTSCB.GT.0) THEN allocate(CB_LRB(NPARTSCB,NPARTSCB),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSCB*NPARTSCB GOTO 490 ENDIF DO II=1,NPARTSCB DO JJ=1,NPARTSCB CB_LRB(II,JJ)%M=0 CB_LRB(II,JJ)%N=0 NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL SMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF ENDIF DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = BEGS_BLR(CURRENT_BLR+1)-1 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (KEEP(480).GE.5) THEN IF (CURRENT_BLR.EQ.1) THEN ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR) THEN BLR_L(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ELSE IF (NB_BLR.GT.CURRENT_BLR) THEN CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF IF (CURRENT_BLR.LT.NPARTSASS) THEN ALLOCATE(NEXT_BLR_L(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR+1) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR+1, NEXT_BLR_L, 0) ENDIF ENDIF ELSE ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ENDIF ENDIF IF (LR_ACTIVATED) THEN ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE CALL SMUMPS_FAC_I_LDLT(NFRONT,NASS,N,INODE, & IBEG_BLOCK, IEND_BLOCK, & IW,LIW,A,LA, & INOPV, NNEGW, NNULLNEGW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UUTEMP, & SEUIL_LOC,KEEP,KEEP8,PIVSIZ, & DKEEP(1), PIVNUL_LIST_STRUCT, SWAP_OCCURRED, XSIZE, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, MAXFROMM, IS_MAXFROMM_AVAIL, & PIVOT_OPTION, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, LR_ACTIVATED & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTPANEL = .TRUE. ELSE IF ( INOPV.LE.0 ) THEN INOPV = 0 NPVW = NPVW + PIVSIZ NVSCHUR_K253 = 0 IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT NVSCHUR_K253 = NVSCHUR + KEEP(253) ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL SMUMPS_FAC_MQ_LDLT(IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & INODE,A,LA, & LDA, & POSELT,IFINB, & PIVSIZ, MAXFROMM, & IS_MAXFROMM_AVAIL, (UUTEMP.NE.0.0E0), & PARPIV_T1, & LAST_ROW, IEND_BLR, NVSCHUR_K253, & LR_ACTIVATED & ) IF(PIVSIZ .EQ. 2) THEN IWPOSP2 = IOLDPS+IW(IOLDPS+1+XSIZE)+6 IW(IWPOSP2+NFRONT+XSIZE) = & -IW(IWPOSP2+NFRONT+XSIZE) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB.EQ.-1) THEN LASTPANEL = .TRUE. ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = LASTPANEL MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL SMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK, & NPIV, NFRONT,NASS,INODE,A,LA, & LDA, POSELT, & KEEP, KEEP8, & -6666, -6666, & IEND_BLR, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL SMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NFRONT,NASS,INODE,A,LA, & LDA, POSELT, & KEEP, KEEP8, & IEND_BLR, NASS, & NASS, LAST_ROW, & (PIVOT_OPTION.LE.1), .TRUE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ELSE NELIM = IEND_BLOCK - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) NULLIFY(BLR_L) IF (KEEP(480).GE.2 .AND. IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS-CURRENT_BLR ELSE FIRST_BLOCK = 1 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL SMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8, FIRST_BLOCK=FIRST_BLOCK) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF ENDIF GOTO 100 ENDIF IF (PIVOT_OPTION.GE.3) THEN FIRST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN FIRST_ROW = NASS ELSE FIRST_ROW = IEND_BLR ENDIF IF (LRTRSM_OPTION.EQ.3) THEN LAST_ROW = IEND_BLR ELSEIF (LRTRSM_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = NFRONT ENDIF IF ((IEND_BLR.LT.NFRONT) .AND. (LAST_ROW-FIRST_ROW.GT.0)) THEN CALL SMUMPS_FAC_SQ_LDLT(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & INODE, A, LA, LDA, POSELT, & KEEP, KEEP8, & FIRST_ROW, LAST_ROW, & -6666, -6666, & .TRUE., .FALSE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ENDIF #if ! defined(BLR_NOOPENMP) #endif #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(UPOS,LPOS,DPOS,OFFSET) !$OMP& FIRSTPRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), KEEP(458), & K473_LOC, BLR_L, & CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (PIVOT_OPTION.LT.3) THEN IF (LRTRSM_OPTION.GE.2) THEN IF (PIVOT_OPTION.LE.1.AND.LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, NB_BLR, BLR_L, & CURRENT_BLR, FIRST_BLOCK, NB_BLR, & 1, 1, 0, & .FALSE., & IW, OFFSET_IW=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF IF (NELIM.GT.0) THEN IF (PIVOT_OPTION.LE.1) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF LPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR)-1,8) DPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR)-1,8) OFFSET=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1 UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8) #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL SMUMPS_FAC_LDLT_COPYSCALE_U( NELIM, 1, & KEEP(424), NFRONT, NPIV-IBEG_BLR+1, & LIW, IW, OFFSET, LA, A, POSELT, LPOS, UPOS, DPOS) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif LPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8) CALL SMUMPS_BLR_UPD_NELIM_VAR_L( & A, LA, UPOS, A, LA, LPOS, & IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & FIRST_BLOCK, NELIM, 'N') ENDIF ENDIF IF (IFLAG.LT.0) GOTO 400 #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS-CURRENT_BLR ELSE FIRST_BLOCK = 1 ENDIF CALL SMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8, FIRST_BLOCK=FIRST_BLOCK) ENDIF ELSE CALL SMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, & MAXI_CLUSTER, NPIV, & 1, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (LRTRSM_OPTION.GE.2) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF IF (KEEP(486).NE.2) THEN LAST_BLOCK = NB_BLR ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, NFRONT, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL(BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & KEEP(34)) DEALLOCATE(BLR_L) ELSE NULLIFY(NEXT_BLR_L) ENDIF ENDIF NULLIFY(BLR_L) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = LASTPANEL MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO J=1,NB_BLR+1 BEGS_BLR_TMP(J) = BEGS_BLR_STATIC(J) ENDDO ENDIF ENDIF MEM_TOT = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP& PRIVATE(IP, NELIM_LOC, BLR_PANEL) #endif IF ( & (KEEP(486).EQ.2) & ) THEN #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DIAGPOS, POSELT_DIAG, !$OMP& MEM, allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*DIAGSIZ_STA MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DIAGPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA DIAG(DIAGPOS:DIAGPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DIAGPOS = DIAGPOS + DIAGSIZ_DYN POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL SMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG, KEEP(34)) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO !$OMP SINGLE #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM_TOT,8), & (KEEP(405).NE.0), KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 447 IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN DO IP=1,NPARTSASS NELIM_LOC = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8, & KEEP(34)) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(458), K473_LOC, & BLR_PANEL, IP, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM_LOC, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif 445 CONTINUE ENDIF 447 CONTINUE ENDIF IF (IFLAG .LT. 0) GOTO 450 IF (KEEP(480) .GE. 2) THEN #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif CALL SMUMPS_BLR_UPD_CB_LEFT_LDLT(A, LA, POSELT, NFRONT, & BEGS_BLR_STATIC, BEGS_BLR, NPARTSCB, NPARTSASS, NASS, & IW(IOLDPS+XXF), & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(484), KEEP8) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF IF (IFLAG.LT.0) GOTO 450 #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF (COMPRESS_CB & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL SMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (COMPRESS_CB) THEN IEND_BLR = BEGS_BLR(CURRENT_BLR+2) IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) ENDIF ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (COMPRESS_CB) THEN #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL SMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) IF (NFS4FATHER.GE.0) NFS4FATHER = NFS4FATHER + NELIM ENDIF ALLOCATE(M_ARRAY(max(NFS4FATHER,1)), stat=allocok) IF ( allocok.GT.0 ) THEN IFLAG = -13 IERROR = max(NFS4FATHER,1) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 448 CALL SMUMPS_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR, NPARTSCB, NPARTSCB, NPARTSASS, & NFRONT-NASS, NFRONT-NASS, INODE, & IW(IOLDPS+XXF), 2, 1, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR+KEEP(253), KEEP(1), & M_ARRAY=M_ARRAY, & NELIM=NELIM ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 448 #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL SMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF DEALLOCATE(M_ARRAY) #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif 448 CONTINUE ENDIF 450 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF ( & ( & (KEEP(486).EQ.2) & ) & .AND.UU.GT.0 .AND. SWAP_OCCURRED & ) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 1, NASS-NPIV) DO IP=1,NPARTSASS CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NB_BLR-IP & ) ENDDO CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NPIV, 2, 1) ENDIF IF (.NOT. COMPRESS_PANEL) THEN CALL SMUMPS_FAC_T_LDLT(NFRONT,NASS,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, KEEP,KEEP8, & (PIVOT_OPTION.NE.3), ETATASS, & TYPEF_L, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG, IOLDPS+6+XSIZE+NFRONT, INODE ) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 1, 1) ENDIF ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_L, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF CALL SMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 490 CONTINUE 500 CONTINUE 600 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) deallocate(TAU) IF (allocated(JPVT)) deallocate(JPVT) IF (allocated(BLOCK)) deallocate(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) ENDDO ENDIF DEALLOCATE(ACC_LUA) NULLIFY(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL SMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8, KEEP(34)) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND. .NOT.COMPRESS_CB) THEN CALL SMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34), MTK405=KEEP(405)) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_FAC1_LDLT END MODULE SMUMPS_FAC1_LDLT_M SUBROUTINE SMUMPS_FAC1_LDLT_I( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, IERROR, & UU, NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T USE SMUMPS_FAC1_LDLT_M, ONLY: SMUMPS_FAC1_LDLT IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, intent(inout) :: NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW INTEGER MYID, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL UU, SEUIL REAL A( LA ) INTEGER IW( LIW ) INTEGER, intent(in) :: PERM(N) LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)) CALL SMUMPS_FAC1_LDLT( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, IERROR, & UU, NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) RETURN END SUBROUTINE SMUMPS_FAC1_LDLT_I MUMPS_5.8.1/src/mumps_config_file_C.c0000664000175000017500000000124615042446422017326 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include #include #include #include "mumps_config_file_C.h" #include "mumps_common.h" void MUMPS_CALL MUMPS_CONFIG_FILE_RETURN_C() { /* This feature will be available in the future */ } MUMPS_5.8.1/src/mumps_addr.c0000664000175000017500000000320115042446422015523 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Utility to automatically get the sizes of Fortran types */ #include "mumps_addr.h" void MUMPS_CALL MUMPS_INT_SIZE_C( MUMPS_INT8 *i) { *i=sizeof(MUMPS_INT); } void MUMPS_CALL MUMPS_SIZE_C(char *a, char *b, MUMPS_INT8 *diff) { *diff = (MUMPS_INT8) (b - a); } void MUMPS_CALL MUMPS_ADDR_C(char *a, MUMPS_INT8 *addr) { *addr=*(MUMPS_INT8*)&a; /* With the form "*addr=(MUMPS_INT8)a", "(MUMPS_INT8)a" and "a" may have different binary representations for large addresses. In the above code, "(MUMPS_INT8*)&a" is a pointer to the address "a", considering that "a" is a MUMPS_INT8 rather than an address. Then the content of that pointer is the exact binary representation of the address a, but stored in a MUMPS_INT8 (signed 64-bit integer). */ } void MUMPS_CALL MUMPS_GETVAL_ADDR_C(volatile MUMPS_INT *val, MUMPS_INT8 *addr) { *val=*(MUMPS_INT*)*addr; } void MUMPS_CALL MUMPS_SETRVAL_ADDR_C(SMUMPS_REAL *val, MUMPS_INT8 *addr) { *(SMUMPS_REAL*)*addr=*val; } void MUMPS_CALL MUMPS_SETDVAL_ADDR_C(DMUMPS_REAL *val, MUMPS_INT8 *addr) { *(DMUMPS_REAL*)*addr=*val; } void MUMPS_CALL MUMPS_CLANGAOCC_C( MUMPS_INT8 *i8) { #if defined(__aocc__) *i8=1; #else *i8=0; #endif } MUMPS_5.8.1/src/dsol_fwd.F0000664000175000017500000001633315042446437015154 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SOL_R(N, A, LA, IW, LIW, WCB, LWCB, & NRHS, & PTRICB, IWCB, LIWCB, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & STEP, & FRERE, DAD, FILS, & NSTK, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, MYROOT, & INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) USE DMUMPS_STATIC_PTR_M, ONLY : DMUMPS_SET_STATIC_PTR, & DMUMPS_GET_TMP_PTR USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_L0OMPFAC_T IMPLICIT NONE INTEGER MTYPE INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER, INTENT(IN) :: N, LIW, LPOOL, LIWCB INTEGER, INTENT(IN) :: SLAVEF, MYLEAF, MYROOT, COMM, MYID INTEGER INFO( 80 ), KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER NRHS DOUBLE PRECISION A( LA ), WCB( LWCB ) INTEGER(8), intent(in) :: LRHS_ROOT DOUBLE PRECISION RHS_ROOT( LRHS_ROOT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER STEP( N ), FRERE( KEEP(28) ), FILS( N ), & DAD( KEEP(28) ) INTEGER NSTK(KEEP(28)), IPOOL( LPOOL ) INTEGER PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTRICB( KEEP(28) ) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) INTEGER IW( LIW ), IWCB( LIWCB ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, intent(in) :: POSINRHSINTR_FWD(N), LRHSINTR DOUBLE PRECISION, intent(inout) :: RHSINTR(LRHSINTR,NRHS) LOGICAL, intent(in) :: FROM_PP INTEGER, INTENT( in ) :: LL0_OMP_MAPPING, LL0_OMP_FACTORS INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) TYPE (DMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY(1) LOGICAL FLAG DOUBLE PRECISION, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER :: UNDERL0MAP INTEGER NBFIN, MYROOT_LEFT INTEGER POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INODE, IFATH INTEGER III, LEAF LOGICAL BLOQ EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE LOGICAL ERROR_WAS_BROADCASTED DUMMY(1) = 1 KEEP(266)=0 POSIWCB = LIWCB POSWCB = LWCB PLEFTWCB= 1_8 PTRICB = 0 LEAF = MYLEAF + 1 III = 1 NBFIN = SLAVEF MYROOT_LEFT = MYROOT IF ( MYROOT_LEFT .EQ. 0 ) THEN NBFIN = NBFIN - 1 CALL DMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, & RACINE_SOLVE, SLAVEF, KEEP) IF (NBFIN.EQ.0) GOTO 260 END IF IF ( INFO(1) .LT. 0 ) THEN GOTO 260 ENDIF 50 CONTINUE IF (SLAVEF .EQ. 1) THEN CALL DMUMPS_GET_INODE_FROM_POOL & ( IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF IF (SLAVEF .EQ. 1) THEN FLAG = .FALSE. ELSE BLOQ = ( ( III .EQ. LEAF ) & ) CALL DMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD & , FROM_PP & ) ENDIF IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 IF (.not. FLAG) THEN IF (III .NE. LEAF) THEN CALL DMUMPS_GET_INODE_FROM_POOL & (IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF ENDIF GOTO 50 60 CONTINUE IF (KEEP(400) .GT. 0 ) THEN UNDERL0MAP = L0_OMP_MAPPING(STEP(INODE)) ELSE UNDERL0MAP = 0 ENDIF IF (UNDERL0MAP .EQ. 0 .OR. KEEP(201).GT.0) THEN CALL DMUMPS_SET_STATIC_PTR(A) CALL DMUMPS_GET_TMP_PTR(A_PTR) LA_PTR = LA ELSE A_PTR => L0_OMP_FACTORS(UNDERL0MAP)%A LA_PTR = L0_OMP_FACTORS(UNDERL0MAP)%LA ENDIF CALL DMUMPS_SOLVE_NODE_FWD( INODE, & huge(INODE), huge(INODE), & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, N, & IPOOL, LPOOL, LEAF, NBFIN, NSTK, & IWCB, LIWCB, WCB, LWCB, A_PTR(1), LA_PTR, & IW, LIW, NRHS, & POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE & , FROM_PP & , ERROR_WAS_BROADCASTED & ) IF ( INFO(1) .LT. 0 ) THEN IF (.NOT. ERROR_WAS_BROADCASTED) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF GOTO 260 ENDIF IFATH = DAD(STEP(INODE)) IF ( IFATH .EQ. 0 ) THEN MYROOT_LEFT = MYROOT_LEFT - 1 IF (MYROOT_LEFT .EQ. 0) THEN NBFIN = NBFIN - 1 IF (SLAVEF .GT. 1) THEN CALL DMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, & COMM, RACINE_SOLVE, SLAVEF, KEEP) ENDIF END IF ELSE IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IFATH)), KEEP(199)) & .EQ. MYID ) THEN IF ( PTRICB(STEP(INODE)) .EQ. 1 .OR. & PTRICB(STEP(INODE)) .EQ. -1 ) THEN NSTK(STEP(IFATH)) = NSTK(STEP(IFATH)) - 1 IF (NSTK(STEP(IFATH)) .EQ. 0) THEN IPOOL(LEAF) = IFATH LEAF = LEAF + 1 IF (LEAF .GT. LPOOL) THEN WRITE(*,*) & 'Internal error DMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() ENDIF ENDIF PTRICB(STEP(INODE)) = 0 ENDIF ENDIF ENDIF IF ( NBFIN .EQ. 0 ) GOTO 260 GOTO 50 260 CONTINUE CALL MUMPS_CLEAN_PENDING(INFO(1), KEEP, BUFR, LBUFR,LBUFR_BYTES, & COMM, DUMMY(1), & SLAVEF, .TRUE., .FALSE.) RETURN END SUBROUTINE DMUMPS_SOL_R MUMPS_5.8.1/src/cfac_process_end_facto_slave.F0000664000175000017500000002736615042446440021203 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE CMUMPS_END_FACTO_SLAVE( & COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, roota, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_LOAD #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif USE CMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER INODE, FPERE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER COMM, MYID INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER N INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP, IFLAG, IERROR INTEGER PERM(N) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER ND( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER FRERE(KEEP(28)) INTEGER INTARR( KEEP8(27) ) COMPLEX DBLARR( KEEP8(26) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER MRS_INODE INTEGER MRS_ISON INTEGER MRS_NSLAVES_PERE INTEGER MRS_NASS_PERE INTEGER MRS_NFRONT_PERE INTEGER MRS_LMAP INTEGER MRS_NFS4FATHER INTEGER, POINTER, DIMENSION(:) :: MRS_SLAVES_PERE, MRS_TROW INTEGER ITYPE2 INTEGER IHDR_REC PARAMETER (ITYPE2=2) INTEGER IOLDPS, NROW, LDA INTEGER NPIV, LCONT, NELIM, NASS, NCOL_TO_SEND, & SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER(8) :: SHIFT_VAL_SON INTEGER(8) :: MEM_GAIN INTEGER(8) :: DYN_SIZE #if ! defined(NO_FDM_MAPROW) TYPE(MAPROW_STRUC_T), POINTER :: MRS #endif INTEGER :: IWHANDLER_SAVE INTEGER :: LRSTATUS LOGICAL :: CB_STORED_IN_BLRSTRUC, COMPRESS_CB IF (KEEP(50).EQ.0) THEN IHDR_REC=6 ELSE IHDR_REC=8 ENDIF IOLDPS = PTRIST(STEP(INODE)) IWHANDLER_SAVE = IW(IOLDPS+XXA) LRSTATUS = IW(IOLDPS+XXLR) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND..NOT.COMPRESS_CB) THEN CALL CMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34)) ENDIF IW(IOLDPS+XXS)=S_ALL IOLDPS = PTRIST(STEP(INODE)) LRSTATUS = IW(IOLDPS+XXLR) IF ( (KEEP(214).EQ.1) & ) THEN CALL CMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP,KEEP8, DKEEP, ITYPE2 & ) IOLDPS = PTRIST(STEP(INODE)) IF (KEEP(38).NE.FPERE) THEN CB_STORED_IN_BLRSTRUC = .FALSE. LRSTATUS = IW(IOLDPS+XXLR) IF ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) THEN CB_STORED_IN_BLRSTRUC = .TRUE. IW(IOLDPS+XXS) = S_NOLNOCB CALL MUMPS_GETI8(MEM_GAIN, IW(IOLDPS+XXR)) LRLUS = LRLUS + MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ELSE IW(IOLDPS+XXS)=S_NOLCBNOCONTIG CALL MUMPS_GETI8( DYN_SIZE, IW(IOLDPS+XXD)) IF (DYN_SIZE .GT.0) THEN ELSE IF (KEEP(216).NE.3) THEN MEM_GAIN=int(IW( IOLDPS + 2 + KEEP(IXSZ) ),8)* & int(IW( IOLDPS + 3 + KEEP(IXSZ) ),8) LRLUS = LRLUS+MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ENDIF ENDIF ENDIF CALL MUMPS_GETI8( DYN_SIZE, IW(IOLDPS+XXD)) IF (DYN_SIZE > 0_8) THEN ELSE IF (KEEP(216).EQ.2) THEN IF (FPERE.NE.KEEP(38)) THEN IF (.NOT. CB_STORED_IN_BLRSTRUC) THEN CALL CMUMPS_MAKECBCONTIG(A,LA,PTRAST(STEP(INODE)), & IW( IOLDPS + 2 + KEEP(IXSZ) ), & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 3 + KEEP(IXSZ) )+ & IW( IOLDPS + KEEP(IXSZ) ), 0, & IW( IOLDPS + XXS ), 0_8 ) IW(IOLDPS+XXS)=S_NOLCBCONTIG ENDIF ENDIF ENDIF ENDIF IF ( KEEP(38).EQ.FPERE) THEN LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV NCOL_TO_SEND = LCONT-NELIM SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NASS SHIFT_VAL_SON = int(NASS,8) LDA = LCONT + NPIV IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOTBAND_INIT) THEN IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_REC_CONTSTATIC ELSE ENDIF CALL CMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTRIST, PTRAST, & root, roota, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, & ROOT_CONT_STATIC, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE.,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS, 0, 0, 0 & ) IF ( IFLAG < 0 ) GOTO 600 IF (NELIM.EQ.0) THEN IF (KEEP(214).EQ.2) THEN CALL CMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, & COMM, KEEP,KEEP8,DKEEP, ITYPE2 & ) ENDIF CALL CMUMPS_FREE_BAND( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP, KEEP8, ITYPE2 & ) ELSE IOLDPS = PTRIST(STEP(INODE)) IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOT2SON_CALLED) THEN CALL CMUMPS_FREE_BAND( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP, KEEP8, ITYPE2 & ) ELSE IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_ROOTBAND_INIT IF (KEEP(214).EQ.1.AND.KEEP(216).NE.3) THEN IW(IOLDPS+XXS)=S_NOLCBNOCONTIG38 CALL CMUMPS_SIZEFREEINREC( IW(IOLDPS), & LIW-IOLDPS+1, & MEM_GAIN, KEEP(IXSZ) ) LRLUS = LRLUS + MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) IF (KEEP(216).EQ.2) THEN CALL CMUMPS_MAKECBCONTIG(A,LA,PTRAST(STEP(INODE)), & IW( IOLDPS + 2 + KEEP(IXSZ) ), & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 3 + KEEP(IXSZ) )+ & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 4 + KEEP(IXSZ) ) - & IW( IOLDPS + 3 + KEEP(IXSZ) ), & IW( IOLDPS + XXS ),0_8) IW(IOLDPS+XXS)=S_NOLCBCONTIG38 ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE #if ! defined(NO_FDM_MAPROW) IOLDPS = PTRIST(STEP(INODE)) IF (FPERE .NE. KEEP(38)) THEN IF (MUMPS_FMRD_IS_MAPROW_STORED( IW(IOLDPS+XXA) )) THEN CALL MUMPS_FMRD_RETRIEVE_MAPROW( IW(IOLDPS+XXA), MRS ) IF (FPERE .NE. MRS%INODE) THEN WRITE(*,*) " Internal error 1 in CMUMPS_END_FACTO_SLAVE", & INODE, MRS%INODE, FPERE CALL MUMPS_ABORT() ENDIF MRS_INODE = MRS%INODE MRS_ISON = MRS%ISON MRS_NSLAVES_PERE = MRS%NSLAVES_PERE MRS_NASS_PERE = MRS%NASS_PERE MRS_NFRONT_PERE = MRS%NFRONT_PERE MRS_LMAP = MRS%LMAP MRS_NFS4FATHER = MRS%NFS4FATHER MRS_SLAVES_PERE => MRS%SLAVES_PERE MRS_TROW => MRS%TROW CALL CMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & MRS_INODE, MRS_ISON, & MRS_NSLAVES_PERE, MRS_SLAVES_PERE(1), & MRS_NFRONT_PERE, MRS_NASS_PERE, MRS_NFS4FATHER, & MRS_LMAP, MRS_TROW(1), & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) CALL MUMPS_FMRD_FREE_MAPROW_STRUC( IWHANDLER_SAVE ) ENDIF ENDIF #endif RETURN END SUBROUTINE CMUMPS_END_FACTO_SLAVE MUMPS_5.8.1/src/dini_driver.F0000664000175000017500000002444515042446441015647 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if defined(__ve__) #if defined(VHOFFLOAD) #include 've.h' #endif #endif SUBROUTINE DMUMPS_INI_DRIVER( id, idintr ) USE DMUMPS_STRUC_DEF USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_INTR_STRUC C C Purpose: C ======= C C Initialize an instance of the DMUMPS package. C IMPLICIT NONE INCLUDE 'mpif.h' TYPE (DMUMPS_STRUC) :: id TYPE (DMUMPS_INTR_STRUC) :: idintr INTEGER MASTER, IERR,PAR_loc,SYM_loc PARAMETER( MASTER = 0 ) INTEGER color #if defined(metis) || defined(parmetis) INTEGER I #endif INTEGER(8) :: I8 C ----------------------------- C Initialize MPI related data C ----------------------------- CALL MPI_COMM_SIZE(id%COMM, id%NPROCS, IERR ) C Now done in the main MUMPS driver: C CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR ) C PAR_loc=id%PAR SYM_loc=id%SYM C Broadcasting PAR/SYM (KEEP(46)/KEEP(50)) in order to C have only one value available: the one from the master CALL MPI_BCAST(PAR_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) CALL MPI_BCAST(SYM_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) C Initialize a subcommunicator C for slave nodes C IF ( PAR_loc .eq. 0 ) THEN C ------------------- C Host is not working C ------------------- IF ( id%MYID .eq. MASTER ) THEN color = MPI_UNDEFINED ELSE color = 0 END IF CALL MPI_COMM_SPLIT( id%COMM, color, 0, & id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS - 1 ELSE C ---------------- C Host is working C ---------------- CALL MPI_COMM_DUP( id%COMM, id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS END IF C --------------------------- C Use same slave communicator C for load information C --------------------------- IF (PAR_loc .ne. 0 .or. id%MYID .NE. MASTER) THEN CALL MPI_COMM_DUP( id%COMM_NODES, id%COMM_LOAD, IERR ) ENDIF C ---------------------------------------------- C Initialize default values for CNTL,ICNTL,KEEP,KEEP8 C potentially depending on id%SYM and id%NSLAVES C ---------------------------------------------- CALL DMUMPSID( id%NSLAVES, id%LWK_USER, & id%CNTL(1), id%ICNTL(1), & id%KEEP(1), id%KEEP8(1), id%INFO(1), id%INFOG(1), & id%RINFO(1), id%RINFOG(1), & SYM_loc, PAR_loc, id%DKEEP(1), id%MYID ) CALL MUMPS_BUILD_ARCH_NODE_COMM( id%COMM, id%KEEP(411), & id%KEEP(412), id%KEEP(413), id%KEEP(410) ) 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" #if ! defined(NO_SAVE_RESTORE) id%SAVE_DIR="NAME_NOT_INITIALIZED" id%SAVE_PREFIX="NAME_NOT_INITIALIZED" #endif C Default value for NRHS is 1 id%NRHS = 1 C Leading dimension will be reset to id%N is DMUMPS_SOL_DRIVER C if id%NRHS remains equal to 1. Otherwise id%LRHS must be C set by user. id%LRHS = 0 ! Value will be checked in DMUMPS_CHECK_DENSE_RHS ! Not accessed if id%NRHS=1 C Similar behaviour for LREDRHS (value will C be checked in DMUMPS_CHECK_REDRHS) id%LREDRHS = 0 C id%INST_Number = -1 C C Define the options for Metis C id%METIS_OPTIONS(:) = 0 #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) C Useful size is 8 C set to default options id%METIS_OPTIONS(1) = 0 #else C Useful size is 40 C This sets the default values CALL METIS_SETDEFAULTOPTIONS(id%METIS_OPTIONS) CALL MUMPS_METIS_OPTION_NUMBERING(I) C The value of I corresponds to "METIS_OPTION_NUMBERING", which tells C METIS to use Fortran numbering. METIS_OPTION_NUMBERING is defined C in metis.h and accessed through a C wrapper. id%METIS_OPTIONS(I+1) = 1 ! +1 for Fortran indexing #endif #endif C C Nullify a few pointers and integers C id%N = 0; id%NZ = 0; id%NNZ = 0_8 NULLIFY(id%IRN) NULLIFY(id%JCN) NULLIFY(id%A) id%NZ_loc = 0; id%NNZ_loc = 0_8 NULLIFY(id%IRN_loc) NULLIFY(id%JCN_loc) NULLIFY(id%A_loc) NULLIFY(id%MAPPING) NULLIFY(id%RHS) NULLIFY(id%REDRHS) id%NZ_RHS=0 NULLIFY(id%RHS_SPARSE) NULLIFY(id%IRHS_SPARSE) NULLIFY(id%IRHS_PTR) NULLIFY(id%ISOL_loc) NULLIFY(id%IRHS_loc) id%LSOL_loc=0 id%LRHS_loc=0 id%Nloc_RHS=0 NULLIFY(id%SOL_loc) NULLIFY(id%RHS_loc) NULLIFY(id%COLSCA) NULLIFY(id%ROWSCA) NULLIFY(id%ROWSCA_loc) NULLIFY(id%COLSCA_loc) NULLIFY(id%PERM_IN) NULLIFY(id%IS) NULLIFY(id%STEP) C Info for analysis by block id%NBLK = 0 NULLIFY(id%BLKPTR) NULLIFY(id%BLKVAR) C Info for pruning tree NULLIFY(id%Step2node) NULLIFY(id%DAD_STEPS) NULLIFY(id%NE_STEPS) NULLIFY(id%ND_STEPS) NULLIFY(id%FRERE_STEPS) NULLIFY(id%SYM_PERM) NULLIFY(id%UNS_PERM) NULLIFY(id%PIVNUL_LIST) NULLIFY(id%FILS) NULLIFY(id%PTRAR) NULLIFY(id%PTR8ARR) NULLIFY(id%NINCOLARR) NULLIFY(id%NINROWARR) NULLIFY(id%PTRDEBARR) NULLIFY(id%FRTPTR) NULLIFY(id%FRTELT) NULLIFY(id%NA) id%LNA=0 NULLIFY(id%PROCNODE_STEPS) NULLIFY(id%S) NULLIFY(id%LPS) NULLIFY(id%PTLUST_S) NULLIFY(id%PTRFAC) NULLIFY(id%DEPTH_FIRST) NULLIFY(id%DEPTH_FIRST_SEQ) NULLIFY(id%SBTR_ID) NULLIFY(id%SCHED_DEP) NULLIFY(id%SCHED_SBTR) NULLIFY(id%SCHED_GRP) NULLIFY(id%CROIX_MANU) NULLIFY(id%WK_USER) NULLIFY(id%MEM_SUBTREE) NULLIFY(id%MEM_SUBTREE) NULLIFY(id%MY_ROOT_SBTR) NULLIFY(id%MY_FIRST_LEAF) NULLIFY(id%MY_NB_LEAF) NULLIFY(id%COST_TRAV) NULLIFY(id%RHSINTR) id%LD_RHSINTR = 0 NULLIFY(id%GLOB2LOC_RHS) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. C C Out of Core management related data C NULLIFY(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAMES) NULLIFY(id%OOC_VADDR) NULLIFY(id%OOC_NB_FILES) NULLIFY(id%LRGROUPS) NULLIFY(id%FDM_F_ENCODING) NULLIFY(id%BLRARRAY_ENCODING) NULLIFY(id%MTKO_PROCS_MAP) C Must be nullified because of routine C DMUMPS_SIZE_IN_STRUCT NULLIFY(id%CB_SON_SIZE) C C Components of the arithmetic-dependent root C CALL DMUMPS_INI_ROOT(idintr%roota) NULLIFY(idintr%root%RG2L) NULLIFY(idintr%root%IPIV) NULLIFY(id%SCHUR_CINTERFACE) C C Element-entry C id%NELT=0 NULLIFY(id%ELTPTR) NULLIFY(id%ELTVAR) NULLIFY(id%A_ELT) NULLIFY(id%ELTPROC) C C Schur C id%SIZE_SCHUR = 0 NULLIFY( id%LISTVAR_SCHUR ) NULLIFY( id%SCHUR ) C -- Distributed Schur id%NPROW = 0 id%NPCOL = 0 id%MBLOCK = 0 id%NBLOCK = 0 id%SCHUR_MLOC = 0 ! Exit from analysis id%SCHUR_NLOC = 0 ! Exit from analysis id%SCHUR_LLD = 0 C C Candidates and node partitionning C NULLIFY(id%ISTEP_TO_INIV2) NULLIFY(id%I_AM_CAND) NULLIFY(id%FUTURE_NIV2) NULLIFY(id%TAB_POS_IN_PERE) NULLIFY(id%CANDIDATES) id%OOC_NB_FILE_TYPE=-123456 C C Initializations for L0_OMP mechanisms C NULLIFY(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) NULLIFY(id%PHYS_L0_OMP) NULLIFY(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%PERM_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) NULLIFY(id%L0_OMP_MAPPING) NULLIFY(idintr%L0_OMP_FACTORS) NULLIFY(id%I4_L0_OMP) NULLIFY(id%I8_L0_OMP) id%LPOOL_B_L0_OMP = 0 id%LPOOL_A_L0_OMP = 0 id%L_VIRT_L0_OMP = 0 id%L_PHYS_L0_OMP = 0 id%THREAD_LA = 0 C C Mapping information used during solve. C NULLIFY(id%IPTR_WORKING) NULLIFY(id%WORKING) C C Initializations for Rank detection/null space C NULLIFY(id%SINGULAR_VALUES) C Architecture data NULLIFY(id%MEM_DIST) C Must be nullified because of routine C DMUMPS_SIZE_IN_STRUCT NULLIFY(id%SUP_PROC) id%Deficiency = 0 idintr%root%LPIV = -1 idintr%root%yes = .FALSE. idintr%root%gridinit_done = .FALSE. C NOT IN SAVE/RESTORE id%ASSOCIATED_OOC_FILES=.FALSE. C C ---------------------------------------- C Find MYID_NODES relatively to COMM_NODES C If the calling processor is not inside C COMM_NODES, MYID_NODES will not be C significant / used anyway C ---------------------------------------- IF ( id%KEEP( 46 ) .ne. 0 .OR. & id%MYID .ne. MASTER ) THEN CALL MPI_COMM_RANK & (id%COMM_NODES, id%MYID_NODES, IERR ) ELSE id%MYID_NODES = -464646 ENDIF C C Check that KEEP(34), the size of a Fortran INTEGER, C as initialized above during DMUMPSID C matches the size of an integer in C. If not, C raise an error immediately. C CALL MUMPS_INT_SIZE_C(I8) IF (int(I8) .NE. id%KEEP(34)) THEN id%INFO(1)=-69 id%INFO(2)=int(I8) ! size of MUMPS_INT C Installation problem! C WRITE on unit 6 since ICNTL(1:4) are not set by the user yet IF (id%MYID .EQ. 0) WRITE(6,995) int(I8) 995 FORMAT(' Installation error -69: ', &' MUMPS_INT size (',I4,') incompatible with INTEGER size') ENDIF RETURN END SUBROUTINE DMUMPS_INI_DRIVER SUBROUTINE DMUMPS_INI_ROOT(roota) USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE(DMUMPS_ROOT_STRUC) :: roota NULLIFY(roota%RHS_CNTR_MASTER_ROOT) NULLIFY(roota%RHS_ROOT) NULLIFY(roota%SCHUR_POINTER) CALL DMUMPS_RR_INIT_POINTERS(roota) RETURN END SUBROUTINE DMUMPS_INI_ROOT MUMPS_5.8.1/src/cini_driver.F0000664000175000017500000002444515042446441015646 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if defined(__ve__) #if defined(VHOFFLOAD) #include 've.h' #endif #endif SUBROUTINE CMUMPS_INI_DRIVER( id, idintr ) USE CMUMPS_STRUC_DEF USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_INTR_STRUC C C Purpose: C ======= C C Initialize an instance of the CMUMPS package. C IMPLICIT NONE INCLUDE 'mpif.h' TYPE (CMUMPS_STRUC) :: id TYPE (CMUMPS_INTR_STRUC) :: idintr INTEGER MASTER, IERR,PAR_loc,SYM_loc PARAMETER( MASTER = 0 ) INTEGER color #if defined(metis) || defined(parmetis) INTEGER I #endif INTEGER(8) :: I8 C ----------------------------- C Initialize MPI related data C ----------------------------- CALL MPI_COMM_SIZE(id%COMM, id%NPROCS, IERR ) C Now done in the main MUMPS driver: C CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR ) C PAR_loc=id%PAR SYM_loc=id%SYM C Broadcasting PAR/SYM (KEEP(46)/KEEP(50)) in order to C have only one value available: the one from the master CALL MPI_BCAST(PAR_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) CALL MPI_BCAST(SYM_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) C Initialize a subcommunicator C for slave nodes C IF ( PAR_loc .eq. 0 ) THEN C ------------------- C Host is not working C ------------------- IF ( id%MYID .eq. MASTER ) THEN color = MPI_UNDEFINED ELSE color = 0 END IF CALL MPI_COMM_SPLIT( id%COMM, color, 0, & id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS - 1 ELSE C ---------------- C Host is working C ---------------- CALL MPI_COMM_DUP( id%COMM, id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS END IF C --------------------------- C Use same slave communicator C for load information C --------------------------- IF (PAR_loc .ne. 0 .or. id%MYID .NE. MASTER) THEN CALL MPI_COMM_DUP( id%COMM_NODES, id%COMM_LOAD, IERR ) ENDIF C ---------------------------------------------- C Initialize default values for CNTL,ICNTL,KEEP,KEEP8 C potentially depending on id%SYM and id%NSLAVES C ---------------------------------------------- CALL CMUMPSID( id%NSLAVES, id%LWK_USER, & id%CNTL(1), id%ICNTL(1), & id%KEEP(1), id%KEEP8(1), id%INFO(1), id%INFOG(1), & id%RINFO(1), id%RINFOG(1), & SYM_loc, PAR_loc, id%DKEEP(1), id%MYID ) CALL MUMPS_BUILD_ARCH_NODE_COMM( id%COMM, id%KEEP(411), & id%KEEP(412), id%KEEP(413), id%KEEP(410) ) 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" #if ! defined(NO_SAVE_RESTORE) id%SAVE_DIR="NAME_NOT_INITIALIZED" id%SAVE_PREFIX="NAME_NOT_INITIALIZED" #endif C Default value for NRHS is 1 id%NRHS = 1 C Leading dimension will be reset to id%N is CMUMPS_SOL_DRIVER C if id%NRHS remains equal to 1. Otherwise id%LRHS must be C set by user. id%LRHS = 0 ! Value will be checked in CMUMPS_CHECK_DENSE_RHS ! Not accessed if id%NRHS=1 C Similar behaviour for LREDRHS (value will C be checked in CMUMPS_CHECK_REDRHS) id%LREDRHS = 0 C id%INST_Number = -1 C C Define the options for Metis C id%METIS_OPTIONS(:) = 0 #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) C Useful size is 8 C set to default options id%METIS_OPTIONS(1) = 0 #else C Useful size is 40 C This sets the default values CALL METIS_SETDEFAULTOPTIONS(id%METIS_OPTIONS) CALL MUMPS_METIS_OPTION_NUMBERING(I) C The value of I corresponds to "METIS_OPTION_NUMBERING", which tells C METIS to use Fortran numbering. METIS_OPTION_NUMBERING is defined C in metis.h and accessed through a C wrapper. id%METIS_OPTIONS(I+1) = 1 ! +1 for Fortran indexing #endif #endif C C Nullify a few pointers and integers C id%N = 0; id%NZ = 0; id%NNZ = 0_8 NULLIFY(id%IRN) NULLIFY(id%JCN) NULLIFY(id%A) id%NZ_loc = 0; id%NNZ_loc = 0_8 NULLIFY(id%IRN_loc) NULLIFY(id%JCN_loc) NULLIFY(id%A_loc) NULLIFY(id%MAPPING) NULLIFY(id%RHS) NULLIFY(id%REDRHS) id%NZ_RHS=0 NULLIFY(id%RHS_SPARSE) NULLIFY(id%IRHS_SPARSE) NULLIFY(id%IRHS_PTR) NULLIFY(id%ISOL_loc) NULLIFY(id%IRHS_loc) id%LSOL_loc=0 id%LRHS_loc=0 id%Nloc_RHS=0 NULLIFY(id%SOL_loc) NULLIFY(id%RHS_loc) NULLIFY(id%COLSCA) NULLIFY(id%ROWSCA) NULLIFY(id%ROWSCA_loc) NULLIFY(id%COLSCA_loc) NULLIFY(id%PERM_IN) NULLIFY(id%IS) NULLIFY(id%STEP) C Info for analysis by block id%NBLK = 0 NULLIFY(id%BLKPTR) NULLIFY(id%BLKVAR) C Info for pruning tree NULLIFY(id%Step2node) NULLIFY(id%DAD_STEPS) NULLIFY(id%NE_STEPS) NULLIFY(id%ND_STEPS) NULLIFY(id%FRERE_STEPS) NULLIFY(id%SYM_PERM) NULLIFY(id%UNS_PERM) NULLIFY(id%PIVNUL_LIST) NULLIFY(id%FILS) NULLIFY(id%PTRAR) NULLIFY(id%PTR8ARR) NULLIFY(id%NINCOLARR) NULLIFY(id%NINROWARR) NULLIFY(id%PTRDEBARR) NULLIFY(id%FRTPTR) NULLIFY(id%FRTELT) NULLIFY(id%NA) id%LNA=0 NULLIFY(id%PROCNODE_STEPS) NULLIFY(id%S) NULLIFY(id%LPS) NULLIFY(id%PTLUST_S) NULLIFY(id%PTRFAC) NULLIFY(id%DEPTH_FIRST) NULLIFY(id%DEPTH_FIRST_SEQ) NULLIFY(id%SBTR_ID) NULLIFY(id%SCHED_DEP) NULLIFY(id%SCHED_SBTR) NULLIFY(id%SCHED_GRP) NULLIFY(id%CROIX_MANU) NULLIFY(id%WK_USER) NULLIFY(id%MEM_SUBTREE) NULLIFY(id%MEM_SUBTREE) NULLIFY(id%MY_ROOT_SBTR) NULLIFY(id%MY_FIRST_LEAF) NULLIFY(id%MY_NB_LEAF) NULLIFY(id%COST_TRAV) NULLIFY(id%RHSINTR) id%LD_RHSINTR = 0 NULLIFY(id%GLOB2LOC_RHS) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. C C Out of Core management related data C NULLIFY(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAMES) NULLIFY(id%OOC_VADDR) NULLIFY(id%OOC_NB_FILES) NULLIFY(id%LRGROUPS) NULLIFY(id%FDM_F_ENCODING) NULLIFY(id%BLRARRAY_ENCODING) NULLIFY(id%MTKO_PROCS_MAP) C Must be nullified because of routine C CMUMPS_SIZE_IN_STRUCT NULLIFY(id%CB_SON_SIZE) C C Components of the arithmetic-dependent root C CALL CMUMPS_INI_ROOT(idintr%roota) NULLIFY(idintr%root%RG2L) NULLIFY(idintr%root%IPIV) NULLIFY(id%SCHUR_CINTERFACE) C C Element-entry C id%NELT=0 NULLIFY(id%ELTPTR) NULLIFY(id%ELTVAR) NULLIFY(id%A_ELT) NULLIFY(id%ELTPROC) C C Schur C id%SIZE_SCHUR = 0 NULLIFY( id%LISTVAR_SCHUR ) NULLIFY( id%SCHUR ) C -- Distributed Schur id%NPROW = 0 id%NPCOL = 0 id%MBLOCK = 0 id%NBLOCK = 0 id%SCHUR_MLOC = 0 ! Exit from analysis id%SCHUR_NLOC = 0 ! Exit from analysis id%SCHUR_LLD = 0 C C Candidates and node partitionning C NULLIFY(id%ISTEP_TO_INIV2) NULLIFY(id%I_AM_CAND) NULLIFY(id%FUTURE_NIV2) NULLIFY(id%TAB_POS_IN_PERE) NULLIFY(id%CANDIDATES) id%OOC_NB_FILE_TYPE=-123456 C C Initializations for L0_OMP mechanisms C NULLIFY(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) NULLIFY(id%PHYS_L0_OMP) NULLIFY(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%PERM_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) NULLIFY(id%L0_OMP_MAPPING) NULLIFY(idintr%L0_OMP_FACTORS) NULLIFY(id%I4_L0_OMP) NULLIFY(id%I8_L0_OMP) id%LPOOL_B_L0_OMP = 0 id%LPOOL_A_L0_OMP = 0 id%L_VIRT_L0_OMP = 0 id%L_PHYS_L0_OMP = 0 id%THREAD_LA = 0 C C Mapping information used during solve. C NULLIFY(id%IPTR_WORKING) NULLIFY(id%WORKING) C C Initializations for Rank detection/null space C NULLIFY(id%SINGULAR_VALUES) C Architecture data NULLIFY(id%MEM_DIST) C Must be nullified because of routine C CMUMPS_SIZE_IN_STRUCT NULLIFY(id%SUP_PROC) id%Deficiency = 0 idintr%root%LPIV = -1 idintr%root%yes = .FALSE. idintr%root%gridinit_done = .FALSE. C NOT IN SAVE/RESTORE id%ASSOCIATED_OOC_FILES=.FALSE. C C ---------------------------------------- C Find MYID_NODES relatively to COMM_NODES C If the calling processor is not inside C COMM_NODES, MYID_NODES will not be C significant / used anyway C ---------------------------------------- IF ( id%KEEP( 46 ) .ne. 0 .OR. & id%MYID .ne. MASTER ) THEN CALL MPI_COMM_RANK & (id%COMM_NODES, id%MYID_NODES, IERR ) ELSE id%MYID_NODES = -464646 ENDIF C C Check that KEEP(34), the size of a Fortran INTEGER, C as initialized above during CMUMPSID C matches the size of an integer in C. If not, C raise an error immediately. C CALL MUMPS_INT_SIZE_C(I8) IF (int(I8) .NE. id%KEEP(34)) THEN id%INFO(1)=-69 id%INFO(2)=int(I8) ! size of MUMPS_INT C Installation problem! C WRITE on unit 6 since ICNTL(1:4) are not set by the user yet IF (id%MYID .EQ. 0) WRITE(6,995) int(I8) 995 FORMAT(' Installation error -69: ', &' MUMPS_INT size (',I4,') incompatible with INTEGER size') ENDIF RETURN END SUBROUTINE CMUMPS_INI_DRIVER SUBROUTINE CMUMPS_INI_ROOT(roota) USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE(CMUMPS_ROOT_STRUC) :: roota NULLIFY(roota%RHS_CNTR_MASTER_ROOT) NULLIFY(roota%RHS_ROOT) NULLIFY(roota%SCHUR_POINTER) CALL CMUMPS_RR_INIT_POINTERS(roota) RETURN END SUBROUTINE CMUMPS_INI_ROOT MUMPS_5.8.1/src/zfac_mem_alloc_cb.F0000664000175000017500000001560715042446441016750 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, PROCESS_BANDE, & MYID,N, KEEP,KEEP8,DKEEP, & IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LREQ, LREQCB, NODE_ARG, STATE_ARG, SET_HEADER, & COMP, LRLUS, LRLUSM, IFLAG, IERROR ) !$ USE OMP_LIB USE MUMPS_LOAD IMPLICIT NONE INTEGER N,LIW, KEEP(500) INTEGER(8) LA, LRLU, IPTRLU, LRLUS, LRLUSM, LREQCB INTEGER(8) PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER IWPOS,IWPOSCB INTEGER(8) :: MIN_SPACE_IN_PLACE INTEGER NODE_ARG, STATE_ARG INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER IW(LIW),PTRIST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER MYID, IXXP COMPLEX(kind=8) A(LA) LOGICAL INPLACE, PROCESS_BANDE, SSARBR, SET_HEADER INTEGER COMP, LREQ, IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER INODE_LOC,NPIV,NASS,NROW,NCB INTEGER ISIZEHOLE INTEGER(8) :: MEM_GAIN, RSIZEHOLE, LREQCB_EFF, LREQCB_WISHED INTEGER(8) :: DYN_SIZE, KEEP8TMPCOPY IF ( INPLACE ) THEN LREQCB_EFF = MIN_SPACE_IN_PLACE IF ( MIN_SPACE_IN_PLACE > 0_8 ) THEN LREQCB_WISHED = LREQCB ELSE LREQCB_WISHED = 0_8 ENDIF ELSE LREQCB_EFF = LREQCB LREQCB_WISHED = LREQCB ENDIF IF (IWPOSCB.EQ.LIW) THEN IF (LREQ.NE.KEEP(IXSZ).OR.LREQCB.NE.0_8 & .OR. .NOT. SET_HEADER) THEN WRITE(*,*) "Internal error in ZMUMPS_ALLOC_CB ", & SET_HEADER, LREQ, LREQCB CALL MUMPS_ABORT() ENDIF IF (IWPOSCB-IWPOS+1 .LT. KEEP(IXSZ)) THEN WRITE(*,*) "Problem with integer stack size",IWPOSCB, & IWPOS, KEEP(IXSZ) IFLAG = -8 IERROR = LREQ RETURN ENDIF IWPOSCB=IWPOSCB-KEEP(IXSZ) IW(IWPOSCB+1+XXI)=KEEP(IXSZ) CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXR)) CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXD)) IW(IWPOSCB+1+XXN)=-919191 IW(IWPOSCB+1+XXS)=S_NOTFREE IW(IWPOSCB+1+XXP)=TOP_OF_STACK RETURN ENDIF CALL MUMPS_GETI8( DYN_SIZE, IW(IWPOSCB+1 + XXD)) IF (DYN_SIZE .EQ. 0_8 & .AND. KEEP(214).EQ.1.AND. & KEEP(216).EQ.1.AND. & IWPOSCB.NE.LIW) THEN IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG.OR. & IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN NCB = IW( IWPOSCB+1 + KEEP(IXSZ) ) NROW = IW( IWPOSCB+1 + KEEP(IXSZ) + 2) NPIV = IW( IWPOSCB+1 + KEEP(IXSZ) + 3) INODE_LOC= IW( IWPOSCB+1 + XXN) CALL ZMUMPS_GET_SIZEHOLE(IWPOSCB+1,IW,LIW, & ISIZEHOLE,RSIZEHOLE) IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG) THEN CALL ZMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, & NROW,NCB,NPIV+NCB,0, & IW(IWPOSCB+1 + XXS),RSIZEHOLE) IW(IWPOSCB+1 + XXS) =S_NOLCLEANED MEM_GAIN = int(NROW,8)*int(NPIV,8) ENDIF IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN NASS = IW( IWPOSCB+1 + KEEP(IXSZ) + 4) CALL ZMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, & NROW,NCB,NPIV+NCB,NASS-NPIV, & IW(IWPOSCB+1 + XXS),RSIZEHOLE) IW(IWPOSCB+1 + XXS) =S_NOLCLEANED38 MEM_GAIN = int(NROW,8)*int(NPIV+NCB-(NASS-NPIV),8) ENDIF IF (ISIZEHOLE.NE.0) THEN CALL ZMUMPS_ISHIFT( IW,LIW,IWPOSCB+1, & IWPOSCB+IW(IWPOSCB+1+XXI), & ISIZEHOLE ) IWPOSCB=IWPOSCB+ISIZEHOLE IW(IWPOSCB+1+XXP+IW(IWPOSCB+1+XXI))=IWPOSCB+1 PTRIST(STEP(INODE_LOC))=PTRIST(STEP(INODE_LOC))+ & ISIZEHOLE ENDIF CALL MUMPS_SUBTRI8TOARRAY(IW(IWPOSCB+1+XXR), MEM_GAIN) IPTRLU = IPTRLU+MEM_GAIN+RSIZEHOLE LRLU = LRLU+MEM_GAIN+RSIZEHOLE PTRAST(STEP(INODE_LOC))= & PTRAST(STEP(INODE_LOC))+MEM_GAIN+RSIZEHOLE ENDIF ENDIF IF (LRLU.LT.LREQCB_WISHED)THEN IF (LREQCB_EFF.LT.LREQCB_WISHED) THEN CALL ZMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD) ENDIF ENDIF CALL ZMUMPS_GET_SIZE_NEEDED & (LREQ, LREQCB_EFF, .FALSE., & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 650 IXXP=IWPOSCB+XXP+1 IF (IXXP.GT.LIW) THEN WRITE(*,*) "Internal error 3 in ZMUMPS_ALLOC_CB ",IXXP ENDIF IF (IW(IXXP).GT.0) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_ALLOC_CB ",IW(IXXP),IXXP ENDIF IWPOSCB = IWPOSCB - LREQ IF (SET_HEADER) THEN IW(IXXP)= IWPOSCB + 1 IW(IWPOSCB+1:IWPOSCB+1+KEEP(IXSZ))=-99999 IW(IWPOSCB+1+XXI)=LREQ CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXR)) CALL MUMPS_STOREI8(0_8, IW(IWPOSCB+1+XXD)) IW(IWPOSCB+1+XXS)=STATE_ARG IW(IWPOSCB+1+XXN)=NODE_ARG IW(IWPOSCB+1+XXP)=TOP_OF_STACK IW(IWPOSCB+1+XXNBPR)=0 ENDIF IPTRLU = IPTRLU - LREQCB LRLU = LRLU - LREQCB LRLUS = LRLUS - LREQCB_EFF LRLUSM = min(LRLUS, LRLUSM) IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) + LREQCB_EFF KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + LREQCB_EFF KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC ENDIF CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) 650 CONTINUE RETURN END SUBROUTINE ZMUMPS_ALLOC_CB MUMPS_5.8.1/src/dfac_root_parallel.F0000664000175000017500000001740615042446440017163 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_FACTO_ROOT( & MPA, MYID, MASTER_OF_ROOT, & root, roota, N, IROOT, & COMM, IW, LIW, IFREE, & A, LA, PTRAST, PTLUST_S, PTRFAC, & STEP, INFO, LDLT, QR, & WK, LWK, KEEP,KEEP8,DKEEP,OPELIW, & DET_EXP, DET_MANT, DET_SIGN & ) USE MUMPS_LR_STATS, ONLY: UPD_FLOP_ROOT USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE ( MUMPS_ROOT_STRUC ) :: root TYPE ( DMUMPS_ROOT_STRUC ) :: roota INTEGER, INTENT(IN) :: MPA INTEGER N, IROOT, COMM, LIW, MYID, IFREE, MASTER_OF_ROOT INTEGER(8) :: LA INTEGER(8) :: LWK DOUBLE PRECISION WK( LWK ) INTEGER KEEP(500) DOUBLE PRECISION DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTLUST_S(KEEP(28)), STEP(N), IW( LIW ) INTEGER INFO( 2 ), LDLT, QR DOUBLE PRECISION A( LA ) DOUBLE PRECISION, intent(inout) :: OPELIW INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP DOUBLE PRECISION, INTENT(INOUT) :: DET_MANT #if ! defined(NOSCALAPACK) INTEGER IOLDPS INTEGER(8) :: IAPOS INTEGER LOCAL_M, LOCAL_N, LPIV, IERR DOUBLE PRECISION :: FLOPS_ROOT INTEGER(8) :: ENTRIES_ROOT INTEGER allocok INTEGER FWD_LOCAL_N_RHS, FWD_MTYPE #endif INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_NUMROC IF ( .NOT. root%yes ) RETURN IF ( KEEP(60) .NE. 0 ) THEN IF ((LDLT == 1 .OR. LDLT == 2) .AND. KEEP(60) == 3 ) THEN CALL DMUMPS_SYMMETRIZE( WK, root%MBLOCK, & root%MYROW, root%MYCOL, root%NPROW, root%NPCOL, & roota%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_NLOC, & root%TOT_ROOT_SIZE, MYID, COMM ) ENDIF RETURN ENDIF #if ! defined(NOSCALAPACK) IF (MPA.GT.0) THEN IF (MYID.EQ.MASTER_OF_ROOT) THEN CALL MUMPS_GET_FLOPS_COST & (root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & LDLT, 3, FLOPS_ROOT) WRITE(MPA,'(A, A, 1PD10.3)') & " ... Start processing the root node with ScaLAPACK, ", & " remaining flops = ", FLOPS_ROOT ENDIF ENDIF IOLDPS = PTLUST_S(STEP(IROOT))+KEEP(IXSZ) IAPOS = PTRAST(STEP(IROOT)) LOCAL_M = IW( IOLDPS + 2 ) LOCAL_N = IW( IOLDPS + 1 ) IAPOS = PTRFAC(IW ( IOLDPS + 4 )) IF ( LDLT.EQ.0 .OR. LDLT.EQ.2 .OR. QR.ne.0 ) THEN LPIV = LOCAL_M + root%MBLOCK ELSE LPIV = 1 END IF IF (associated( root%IPIV )) DEALLOCATE(root%IPIV) root%LPIV = LPIV ALLOCATE( root%IPIV( LPIV ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LPIV WRITE(*,*) MYID,': problem allocating IPIV(',LPIV,') in root' CALL MUMPS_ABORT() END IF CALL DESCINIT( root%DESCRIPTOR(1), root%TOT_ROOT_SIZE, & root%TOT_ROOT_SIZE, root%MBLOCK, root%NBLOCK, & 0, 0, root%CNTXT_BLACS, LOCAL_M, IERR ) IF ( LDLT.EQ.2 ) THEN IF(root%MBLOCK.NE.root%NBLOCK) THEN WRITE(*,*) ' Error: symmetrization only works for' WRITE(*,*) ' square block sizes, MBLOCK/NBLOCK=', & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() END IF IF ( LWK .LT. min( & int(root%MBLOCK,8) * int(root%NBLOCK,8), & int(root%TOT_ROOT_SIZE,8)* int(root%TOT_ROOT_SIZE,8 ) & )) THEN WRITE(*,*) 'Not enough workspace for symmetrization.' CALL MUMPS_ABORT() END IF CALL DMUMPS_SYMMETRIZE( WK, root%MBLOCK, & root%MYROW, root%MYCOL, root%NPROW, root%NPCOL, & A( IAPOS ), LOCAL_M, LOCAL_N, & root%TOT_ROOT_SIZE, MYID, COMM ) END IF IF (LDLT.EQ.0.OR.LDLT.EQ.2) THEN CALL pdgetrf( root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & A( IAPOS ), & 1, 1, root%DESCRIPTOR(1), root%IPIV(1), IERR ) IF ( IERR .GT. 0 ) THEN INFO(1)=-10 INFO(2)=IERR-1 END IF ELSE CALL pdpotrf('L',root%TOT_ROOT_SIZE,A(IAPOS), & 1,1,root%DESCRIPTOR(1),IERR) IF ( IERR .GT. 0 ) THEN INFO(1)=-40 INFO(2)=IERR-1 END IF END IF IF (IERR .GT. 0) THEN CALL MUMPS_UPDATE_FLOPS_ROOT( OPELIW, LDLT, & root%TOT_ROOT_SIZE, INFO(2), & root%NPROW, root%NPCOL, MYID ) IF (KEEP(486) .GT. 0) THEN CALL UPD_FLOP_ROOT( LDLT, & root%TOT_ROOT_SIZE, INFO(2), & root%NPROW, root%NPCOL, MYID ) ENDIF ELSE CALL MUMPS_UPDATE_FLOPS_ROOT( OPELIW, LDLT, & root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & root%NPROW, root%NPCOL, MYID ) IF (KEEP(486) .GT. 0) THEN CALL UPD_FLOP_ROOT( LDLT, & root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & root%NPROW, root%NPCOL, MYID ) ENDIF ENDIF IF ( LDLT .EQ. 0 ) THEN ENTRIES_ROOT = int(root%TOT_ROOT_SIZE,8) & * int(root%TOT_ROOT_SIZE,8) ELSE ENTRIES_ROOT = int(root%TOT_ROOT_SIZE,8) & * int(root%TOT_ROOT_SIZE+1,8)/2_8 ENDIF KEEP8(10)=KEEP8(10) + ENTRIES_ROOT / & int(root%NPROW * root%NPCOL,8) IF (MYID .eq. MASTER_OF_ROOT) THEN KEEP8(10)=KEEP8(10) + & mod(ENTRIES_ROOT, int(root%NPROW*root%NPCOL,8)) ENDIF CALL DMUMPS_PAR_ROOT_MINMAX_PIV_UPD ( & root%MBLOCK, root%IPIV(1),root%MYROW, & root%MYCOL, root%NPROW, root%NPCOL, A(IAPOS), LOCAL_M, & LOCAL_N, root%TOT_ROOT_SIZE, MYID, DKEEP, KEEP, LDLT) IF (KEEP(258).NE.0) THEN IF (root%MBLOCK.NE.root%NBLOCK) THEN write(*,*) "Internal error in DMUMPS_FACTO_ROOT:", & "Block size different for rows and columns", & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() ENDIF CALL DMUMPS_GETDETER2D(root%MBLOCK, root%IPIV(1),root%MYROW, & root%MYCOL, root%NPROW, root%NPCOL, A(IAPOS), LOCAL_M, & LOCAL_N, root%TOT_ROOT_SIZE, MYID, DET_MANT, DET_EXP, & LDLT) ENDIF IF (KEEP(252) .NE. 0) THEN FWD_LOCAL_N_RHS = MUMPS_NUMROC(KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL) FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) FWD_MTYPE = 1 CALL DMUMPS_SOLVE_2D_BCYCLIC( & root%TOT_ROOT_SIZE, & KEEP(253), & FWD_MTYPE, & A(IAPOS), & root%DESCRIPTOR(1), & LOCAL_M, LOCAL_N, FWD_LOCAL_N_RHS, & root%IPIV(1), LPIV, & roota%RHS_ROOT(1,1), LDLT, & root%MBLOCK, root%NBLOCK, & root%CNTXT_BLACS, IERR) ENDIF #endif RETURN END SUBROUTINE DMUMPS_FACTO_ROOT MUMPS_5.8.1/src/zsol_driver.F0000664000175000017500000100777515042446442015724 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SOLVE_DRIVER(id,idintr) USE ZMUMPS_STRUC_DEF USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_INTR_STRUC USE ZMUMPS_SOL_ES C Lock Initialization (_LI) and Desruction (_LD) USE MUMPS_SOL_L0OMP_M, ONLY: MUMPS_SOL_L0OMP_LI, & MUMPS_SOL_L0OMP_LD C C Purpose C ======= C C Performs solution phase (solve), Iterative Refinements C and Error analysis. C C c C USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_ALLOC_SMALL_BUF, & MUMPS_BUF_ALLOC_CB, MUMPS_BUF_INIT, & MUMPS_BUF_DEALL_CB, & MUMPS_BUF_DEALL_SMALL_BUF USE ZMUMPS_OOC USE MUMPS_MEMORY_MOD USE ZMUMPS_LR_DATA_M, only : ZMUMPS_BLR_STRUC_TO_MOD & , ZMUMPS_BLR_MOD_TO_STRUC USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_MOD_TO_STRUC #if ! defined(NO_SAVE_RESTORE) USE ZMUMPS_SAVE_RESTORE #endif !$ USE OMP_LIB IMPLICIT NONE C ------------------- C Explicit interfaces C ------------------- INTERFACE SUBROUTINE ZMUMPS_SIZE_IN_STRUCT( id, idintr, & NB_INT,NB_CMPLX,NB_CHAR ) USE ZMUMPS_STRUC_DEF, ONLY: ZMUMPS_STRUC USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_INTR_STRUC TYPE (ZMUMPS_STRUC) :: id TYPE (ZMUMPS_INTR_STRUC) :: idintr INTEGER(8) :: NB_INT,NB_CMPLX,NB_CHAR END SUBROUTINE ZMUMPS_SIZE_IN_STRUCT SUBROUTINE ZMUMPS_CHECK_DENSE_RHS &(idRHS, idINFO, idN, idNRHS, idLRHS) COMPLEX(kind=8), DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE ZMUMPS_CHECK_DENSE_RHS END INTERFACE C INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' #if defined(V_T) INCLUDE 'VT.inc' #endif INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 C C Parameters C ========== C TYPE (ZMUMPS_STRUC), TARGET :: id TYPE (ZMUMPS_INTR_STRUC) :: idintr C C Local variables C =============== C INTEGER MP,LP, MPG LOGICAL PROK, PROKG, LPOK INTEGER MTYPE, ICNTL21 LOGICAL LSCAL, POSTPros, GIVSOL INTEGER ICNTL10, ICNTL11, ICNTL48_EFF INTEGER I,K,JPERM, J, II, IZ2 #if defined(USE_OLD_SCALING) INTEGER IPERM #endif INTEGER IZ, NZ_THIS_BLOCK, PJ C pointers in IS INTEGER LIW C pointers in id%S INTEGER(8) :: LA, LA_PASSED INTEGER LIW_PASSED INTEGER(8) :: LWCB8_MIN, LWCB8 C buffer sizes INTEGER ZMUMPS_LBUF, ZMUMPS_LBUF_INT INTEGER(8) :: ZMUMPS_LBUF_8 INTEGER :: LBUFR, LBUFR_BYTES INTEGER :: MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL INTEGER(8) :: MSG_MAX_BYTES_SOLVE8 C reception buffer INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFR C null space INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, & IBEG_GLOB_DEF, IEND_GLOB_DEF, & IROOT_DEF_RHS_COL1 C INTEGER NITREF, NOITER, SOLVET, KASE C Meaningful only with tree pruning and sparse RHS LOGICAL INTERLEAVE_PAR, DO_PERMUTE_RHS LOGICAL CALL_NODES_FWD_BWD, FIRST_CALL_NODES_FWD_BWD C true if ZMUMPS_SOL_C called during postprocessing LOGICAL FROM_PP LOGICAL ALLOCATE_S C C TIMINGS DOUBLE PRECISION TIMEIT, TIMEEA, TIMEEA1, TIMELCOND DOUBLE PRECISION TIME3 DOUBLE PRECISION TIMEC1,TIMEC2 DOUBLE PRECISION TIMEGATHER1,TIMEGATHER2 DOUBLE PRECISION TIMESCATTER1,TIMESCATTER2 DOUBLE PRECISION TIMECOPYSCALE1,TIMECOPYSCALE2 C ------------------------------------------ C Declarations related to exploit sparsity C ------------------------------------------ INTEGER :: NRHS_NONEMPTY INTEGER :: STRAT_PERMAM1 LOGICAL :: DO_NULL_PIV INTEGER, DIMENSION(:), POINTER :: IRHS_PTR_COPY INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE_COPY COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS_SPARSE_COPY LOGICAL IRHS_SPARSE_COPY_ALLOCATED, IRHS_PTR_COPY_ALLOCATED, & RHS_SPARSE_COPY_ALLOCATED C INTEGER, DIMENSION(:), ALLOCATABLE :: MAP_RHS_loc INTEGER, DIMENSION(:), POINTER :: IRHS_loc_PTR LOGICAL :: IRHS_loc_PTR_ALLOCATED INTEGER(8) :: SUM_idNloc_RHS_8 COMPLEX(kind=8), DIMENSION(:), POINTER :: idRHS_loc INTEGER(8) :: DIFF_SOL_loc_RHS_loc INTEGER(8) :: RHS_loc_size, RHS_loc_shift INTEGER(8) :: NBT INTEGER :: NBCOL, COLSIZE, JBEG_RHS, JEND_RHS, JBEG_NEW, & NBCOL_INBLOC, IPOS, IPOSRHSINTR C Nb of pruned NE_STEPS, useful for FWD step; and list of root nodes LOGICAL :: fill INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_Sons_FWD, & Pruned_Sons_BWD INTEGER, DIMENSION(:), ALLOCATABLE :: PERM_RHS INTEGER, DIMENSION(:), POINTER :: PTR_POSINRHSINTR_FWD, & PTR_POSINRHSINTR_BWD COMPLEX(kind=8), DIMENSION(:), POINTER :: PTR_RHS INTEGER, DIMENSION(:), POINTER :: idIPTR_WORKING, idWORKING INTEGER :: SIZE_IPTR_WORKING, SIZE_WORKING C NRHS_NONEMPTY: holds C either the original number of RHS (id%NRHS defined on host) C or, when the RHS is sparse, it holds the C number of non empty columns. C it is computed on master and is C then broadcasted on all processes. C IRHS_PTR_COPY holds a compressed local copy of IRHS_PTR (or points C on the master to id%IRHS_PTR if no permutation requested) C IRHS_SPARSE_COPY might be allocated or might also point to C id%IRHS_SPARSE. To test if we can deallocate it we trace C with IRHS_SPARSE_COPY_ALLOCATED when it was effectively C allocated. C NBCOL_INBLOC total nb columns to process in this block C JBEG_RHS global ptr for starting column requested for this block C JEND_RHS global ptr for end column_number requested for this block C PERM_RHS -- Permutation of RHS computed on master and broadcasted C on all procs (of size id%NRHS orginal) C PERM_RHS(k) = i means that i is the kth column to be processed C Note that PERM_RHS will be used also in case of interleaving C ------------------------------------ INTEGER :: NOMP COMPLEX(kind=8) ONE COMPLEX(kind=8) ZERO PARAMETER( ONE = (1.0D0,0.0D0) ) PARAMETER( ZERO = (0.0D0,0.0D0) ) DOUBLE PRECISION RZERO, RONE PARAMETER( RZERO = 0.0D0, RONE = 1.0D0 ) C C RHS_IR is internal to ZMUMPS and used for iterative refinement C or the error analysis section. It either points to the user's C RHS (on the host when the solution is centralized or the RHS C is dense), or is a workarray allocated inside this routine C of size N. COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS_IR COMPLEX(kind=8), DIMENSION(:), POINTER :: WORK_WCB COMPLEX(kind=8), DIMENSION(:), POINTER :: PTR_RHS_ROOT INTEGER(8) :: LPTR_RHS_ROOT C C Local workarrays that will be dynamically allocated C COMPLEX(kind=8), ALLOCATABLE :: SAVERHS(:), C_RW1(:), & C_RW2(:), & SRW3(:), C_Y(:), & C_W(:) INTEGER :: LCWORK COMPLEX(kind=8), ALLOCATABLE :: CWORK(:) INTEGER, ALLOCATABLE :: MAP_RHS(:) DOUBLE PRECISION, ALLOCATABLE :: R_Y(:), D(:) DOUBLE PRECISION, ALLOCATABLE :: R_W(:) C The 2 following workarrays are temporary local C arrays only used for distributed matrix input C (KEEP(54) .NE. 0). DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: R_LOCWK54 COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: C_LOCWK54 INTEGER :: NBENT_RHSINTR, NB_FS_RHSINTR_F, & NB_FS_RHSINTR_TOT INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV LOGICAL :: UNS_PERM_INV_NEEDED_INMAINLOOP, & UNS_PERM_INV_NEEDED_BEFMAINLOOP, & UNS_PERM_INV_NEEDED_ONSLAVES INTEGER LIWK_SOLVE, LIWCB INTEGER, ALLOCATABLE :: IW1(:), IWK_SOLVE(:), IWCB(:) INTEGER :: LIWK_PTRACB INTEGER(8), ALLOCATABLE :: PTRACB(:) C C Parameters arising from the structure C INTEGER(8) :: MAXS DOUBLE PRECISION, DIMENSION(:), POINTER :: CNTL INTEGER, DIMENSION (:), POINTER :: KEEP,ICNTL,INFO INTEGER(8), DIMENSION (:), POINTER :: KEEP8 INTEGER, DIMENSION (:), POINTER :: IS DOUBLE PRECISION, DIMENSION(:),POINTER:: RINFOG C =============================================================== C SCALING issues: C When scaling was performed C RHS holds the solution of the scaled system C The unscaled second member (b0) was given C then we have to scale both rhs and solution: C A(sca) = LU = D1*A*D2 , with D2 = COLSCA C D1 = ROWSCA C -------------- C CASE OF A X =B C -------------- C (ICNTL(9)=1 or MTYPE=1) C A*x0 = b0 C b(sca) = D1 * b0 = ROWSCA*b0 C A(sca) [(D2) **(-1)] x0 = b(sca) C so the computed solution of LU * x(sca) = b(sca) C is : x(sca) =[(D2) **(-1)] x0 and so x0= D2*x(sca) C -------------- C CASE OF AT X =B C -------------- C (ICNTL(9).NE.1 or MTYPE=0) C A(sca) = LU = D1*A*D2 C AT*x0 = b0 => D2*AT*D1 * D1-1 x0 = D2 * b0 C b(sca) = D2 * b0 = COLSCA*b0 C A(sca)T [(D1) **(-1)] x0 = b(sca) C so the computed solution of (LU)^T * x(sca) = b(sca) C is : x(sca) =[(D1) **(-1)] x0 and so x0= D1*y0 is modified C C In case of distributed RHS or distributed solution we need C scaling information on each processor and this information has C been stored in ROWSCA_loc(1:INFO(23)) and COLSCA_loc(1:INFO(23)) C such that: C C ---------------- C CASE OF A X = B C ---------------- C C - the scaling factor of row i of A is stored on the C processor for which GLOB2LOC_RHS(i) > 0 at position C ROWSCA_loc(GLOB2LOC_RHS(i)) C C - the scaling factor of column j of A is stored on the C processor for which GLOB2LOC_SOL(j) > 0 at position C COLSCA_loc(GLOB2LOC_SOL(j)) C C ------------------ C CASE OF A^T X = B C ------------------ C C - the scaling factor of row i of A^T is stored on the C processor for which GLOB2LOC_RHS(i) > 0 at position C COLSCA_loc(GLOB2LOC_RHS(i)) C C - the scaling factor of column j of A^T is stored on the C processor for which GLOB2LOC_SOL(j) > 0 at position C ROWSCA_loc(GLOB2LOC_SOL(j)) C #if defined(USE_OLD_SCALING) type scaling_data_t SEQUENCE DOUBLE PRECISION , dimension(:), pointer :: SCALING DOUBLE PRECISION , dimension(:), pointer :: SCALING_LOC INTEGER, dimension(:), pointer :: SCALING_IND end type scaling_data_t type (scaling_data_t) :: scaling_data_dr type (scaling_data_t) :: scaling_data_sol C To scale on the fly during GATHER SOLUTION: DOUBLE PRECISION, DIMENSION(:), POINTER :: PT_SCALING DOUBLE PRECISION, TARGET :: Dummy_SCAL(1) #else INTEGER :: ROWORCOL #endif C C ==================== END OF SCALING related data ================ C C Local variables C C Interval associated to the subblocks of RHS a node has to process INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: RHS_BOUNDS INTEGER :: LPTR_RHS_BOUNDS INTEGER, DIMENSION(:), POINTER :: PTR_RHS_BOUNDS LOGICAL :: DO_NBSPARSE, NBSPARSE_LOC LOGICAL :: PRINT_MAXAVG DOUBLE PRECISION ARRET COMPLEX(kind=8) C_DUMMY(1) DOUBLE PRECISION R_DUMMY(1) INTEGER IDUMMY(1), JDUMMY(1), KDUMMY(1), LDUMMY(1), MDUMMY(1) INTEGER, TARGET :: IDUMMY_TARGET(1) COMPLEX(kind=8), TARGET :: CDUMMY_TARGET(1) INTEGER JJ INTEGER allocok INTEGER NBRHS, NBRHS_EFF, BEG_RHS, NB_RHSSKIPPED, & LD_RHS, & MASTER_ROOT, MASTER_ROOT_IN_COMM C NRHS_COLS_SOL_C is used to estimate NRHS_EFF C before the loop on RHS column blocks INTEGER NRHS_COLS_SOL_C INTEGER SIZE_ROOT, LD_REDRHS INTEGER(8) :: IBEG, IBEG_RHSINTR, KDEC, IBEG_loc, IBEG_REDRHS INTEGER NCOL_RHS_loc INTEGER LD_RHS_loc, JBEG_RHS_loc INTEGER NB_K133, IRANK, TSIZE INTEGER KMAX_246_247 INTEGER IFLAG_IR, IRStep LOGICAL TESTConv LOGICAL WORKSPACE_MINIMAL_PREFERRED, WK_USER_PROVIDED INTEGER(8) NB_BYTES !size of data allocated during solve INTEGER(8) NB_BYTES_MAX !MAX size of data allocated during solve INTEGER(8) NB_BYTES_EXTRA !For Step2Node, which may be freed later INTEGER(8) NB_BYTES_LOC !For temp. computations INTEGER(8) NB_INT, NB_CMPLX, NB_CHAR, K34_8, K35_8, K149_8, K151_8 INTEGER(8) K16_8, ITMP8, SUM_ITMP8, NB_BYTES_ON_ENTRY #if defined(V_T) C Vampir INTEGER soln_drive_class, glob_comm_ini, perm_scal_ini, soln_dist, & soln_assem, perm_scal_post #endif LOGICAL I_AM_SLAVE, BUILD_POSINRHSINTR LOGICAL :: BUILD_RHSMAPINFO DOUBLE PRECISION, TARGET :: RDUMMY_TARGET(1) LOGICAL :: ES_RHSINTR INTEGER, DIMENSION(:), POINTER :: nodes_FWD, nodes_BWD C to manage sparsity: compute target nodes for starting chains C Lnodes_FWD/Lnodes_BWD = -1 => all nodes to be processed INTEGER, DIMENSION(:), POINTER :: nodes_FWD_PTR, nodes_BWD_PTR INTEGER :: Lnodes_FWD, Lnodes_BWD, Lnodes_FWD_PTR, Lnodes_BWD_PTR DOUBLE PRECISION, POINTER, DIMENSION(:) :: SCALING_loc_FWD DOUBLE PRECISION, POINTER, DIMENSION(:) :: SCALING_loc_BWD DOUBLE PRECISION, POINTER, DIMENSION(:) :: SCALING_RHSINTR_BWD DOUBLE PRECISION, POINTER, DIMENSION(:) :: SCALING_RHSINTR_FWD INTEGER :: LSCALING_RHSINTR_BWD, LSCALING_RHSINTR_FWD LOGICAL :: SCALING_RHSINTR_BWD_ALLOCATED, & SCALING_RHSINTR_FWD_ALLOCATED, & BUILD_SCALING_RHSINTR C NSOL_loc will be equal to KEEP(89) in case ICNTL(21)=1 INTEGER :: NSOL_loc LOGICAL WORK_WCB_ALLOCATED, IS_INIT_OOC_DONE LOGICAL PTR_RHS_ROOT_ALLOCATED LOGICAL :: IS_LR_MOD_TO_STRUC_DONE INTEGER :: KEEP350_SAVE, KEEP20_SAVE LOGICAL STOP_AT_NEXT_EMPTY_COL INTEGER MTYPE_LOC INTEGER(4) :: I4 INTEGER MAT_ALLOC_LOC, MAT_ALLOC INTEGER :: NZ_THIS_BLOCK_ARG, NBCOL_INBLOC_ARG, LStep2node_ARG INTEGER, POINTER :: Step2node_ARG(:), IRHS_PTR_COPY_ARG(:), & IRHS_SPARSE_COPY_ARG(:) INTEGER :: NB_FS_RHSINTR_F_ARG, NB_FS_RHSINTR_TOT_ARG INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE C C First executable statement C #if defined(V_T) CALL VTCLASSDEF( 'Soln driver',soln_drive_class,IERR) CALL VTFUNCDEF( 'glob_comm_ini',soln_drive_class, & glob_comm_ini,IERR) CALL VTFUNCDEF( 'perm_scal_ini',soln_drive_class, & perm_scal_ini,IERR) CALL VTFUNCDEF( 'soln_dist',soln_drive_class,soln_dist,IERR) CALL VTFUNCDEF( 'soln_assem',soln_drive_class,soln_assem,IERR) CALL VTFUNCDEF( 'perm_scal_post',soln_drive_class, & perm_scal_post,IERR) #endif C Depending on the type of parallelism, C the master can have the role of a slave I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) C -- The following pointers xxCOPY might be allocated but then C -- the associated xxCOPY_ALLOCATED will be set to C -- enable deallocation SCALING_RHSINTR_FWD_ALLOCATED = .FALSE. SCALING_RHSINTR_BWD_ALLOCATED = .FALSE. C Initialize scalings to possilby pass them as arguments C (e.g. to ZMUMPS_DS_ALL2ALL) even on non working host C and/or when LSCAL is false SCALING_RHSINTR_FWD => RDUMMY_TARGET SCALING_RHSINTR_BWD => RDUMMY_TARGET LSCALING_RHSINTR_FWD = 1 LSCALING_RHSINTR_BWD = 1 SCALING_LOC_FWD => RDUMMY_TARGET SCALING_LOC_BWD => RDUMMY_TARGET 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. C ALLOCATE_S will be set to true if S needs be allocated. C It is then tested to free S befgore returning ALLOCATE_S = .FALSE. NULLIFY(RHS_IR) NULLIFY(WORK_WCB) #if defined(USE_OLD_SCALING) NULLIFY(scaling_data_dr%SCALING) NULLIFY(scaling_data_dr%SCALING_LOC) NULLIFY(scaling_data_dr%SCALING_IND) NULLIFY(scaling_data_sol%SCALING) NULLIFY(scaling_data_sol%SCALING_LOC) NULLIFY(scaling_data_sol%SCALING_IND) #endif NULLIFY(nodes_FWD) NULLIFY(nodes_BWD) IRHS_loc_PTR_allocated = .FALSE. IS_INIT_OOC_DONE = .FALSE. IS_LR_MOD_TO_STRUC_DONE = .FALSE. WK_USER_PROVIDED = .FALSE. WORK_WCB_ALLOCATED = .FALSE. PTR_RHS_ROOT_ALLOCATED = .FALSE. CNTL =>id%CNTL KEEP =>id%KEEP KEEP8=>id%KEEP8 IS =>id%IS ICNTL=>id%ICNTL INFO =>id%INFO RINFOG =>id%RINFOG LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) IF (.not.PROK) MP =0 IF (.not.PROKG) MPG=0 IF ( PROK ) WRITE(MP,100) IF ( PROKG ) WRITE(MPG,100) NB_BYTES = 0_8 NB_BYTES_MAX = 0_8 NB_BYTES_EXTRA = 0_8 K34_8 = int(KEEP(34), 8) K35_8 = int(KEEP(35), 8) ! complex factor K16_8 = int(KEEP(16), 8) K149_8 = int(KEEP(149),8) ! complex in instance K151_8 = int(KEEP(151),8) ! complex in instance C RR KEEP20_SAVE = KEEP(20) IF (KEEP(19).EQ.0.AND.KEEP(53).NE.0) THEN C ICNTL(56)>0 at analysis and =0 at facto C save special root index KEEP20_SAVE = KEEP(20) C suppress special RR treatment KEEP(20) = 0 ENDIF NBENT_RHSINTR = 0 C Used by DISTRIBUTED_SOLUTION to skip empty columns C that are skipped (case of sparse RHS) NB_RHSSKIPPED = 0 C next 4 initialisations needed in case of error C to free space allocated LSCAL = .FALSE. C ICNTL21 = -99998 ! will be bcasted later to slaves IBEG_RHSINTR =-152525_8 ! Should not be used BUILD_POSINRHSINTR = .TRUE. C NSOL_loc, KEEP(212) will be set if ICNTL(21).EQ.2 NSOL_loc = 0 KEEP(212)= 0 C SCALING_RHSINTR was initialized to a dummy array of size 1 C on the non working host, no need to reset it at each block BUILD_SCALING_RHSINTR = I_AM_SLAVE IBEG_GLOB_DEF = -9888 ! unitialized state IEND_GLOB_DEF = -9888 ! unitialized state IBEG_ROOT_DEF = -9777 ! unitialized state IEND_ROOT_DEF = -9777 ! unitialized state IROOT_DEF_RHS_COL1 = -9666 ! unitialized state C ------------------------------ C id%LD_RHSINTR will be set each C time RHSINTR is allocated C ------------------------------ NB_FS_RHSINTR_TOT = KEEP(89) ! number of FS var of the pruned tree ! mapped on this proc NB_FS_RHSINTR_F = NB_FS_RHSINTR_TOT C Save value of KEEP(350), in case of LR solve C KEEP(350) may be overwritten and restored C Old unoptimized version before 5.0.2 not available anymore IF (KEEP(350).LE.0) KEEP(350)=1 IF (KEEP(350).GT.2) KEEP(350)=1 KEEP350_SAVE = KEEP(350) C C Compute the number of integers and nb of reals in the structure CALL ZMUMPS_SIZE_IN_STRUCT (id, idintr, NB_INT, NB_CMPLX, NB_CHAR) NB_BYTES = NB_BYTES + NB_INT * K34_8 + NB_CMPLX * K149_8 + NB_CHAR ! KE15: size of a cmplx in current MUMPS instance NB_BYTES_ON_ENTRY = NB_BYTES !used to check alloc/dealloc count ok NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ====================================== C BEGIN CHECK KEEP ENTRIES AND INTERFACE C ====================================== IF (id%MYID .EQ. MASTER) THEN C { C Set ICNTL(26) -> KEEP(221) (called at facto and solve) C (might be called at facto in case of fwd in facto C with Schur+reduced RHS requested) CALL ZMUMPS_SET_K221(id, .TRUE.) id%KEEP(111) = id%ICNTL(25) C For the case of ICNTL(20)=1 one could C switch off exploit sparsity when RHS is too dense. IF (id%ICNTL(20) .EQ. 1) id%KEEP(235) = -1 !automatic IF (id%ICNTL(20) .EQ. 2) id%KEEP(235) = 0 !off IF (id%ICNTL(20) .EQ. 3) id%KEEP(235) = 1 !on IF (id%ICNTL(20).EQ.1 .or. id%ICNTL(20).EQ.2 .or. & id%ICNTL(20).EQ.3) THEN id%KEEP(248) = 1 !sparse RHS ELSE IF (id%ICNTL(20).EQ.10 .OR. id%ICNTL(20).EQ.11) THEN id%KEEP(248) = -1 ! dist. RHS ELSE id%KEEP(248) = 0 !dense RHS ENDIF C C set ICNTL21 and test for out-of range entries ICNTL21 = id%ICNTL(21) IF ( ICNTL21.NE.0 .AND. ICNTL21.NE.1 & ) ICNTL21 = 0 C IF ( id%ICNTL(30) .NE.0 ) THEN C A-1 is on id%KEEP(237) = 1 ELSE C A-1 is off id%KEEP(237) = 0 ENDIF IF (id%KEEP(248) .eq.0.and. id%KEEP(237).ne.0) THEN C For A-1 we have a sparse RHS in the API. C Force KEEP(248) accordingly. id%KEEP(248)=1 ENDIF IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(248).NE.0) ) THEN IF (KEEP(60).NE.0) THEN C -- input RHS is stored in REDRHS and RHSINTR id%KEEP(248) = 0 ENDIF ENDIF C} ENDIF C ============================================================= C KEEP(248) and KEEP(221): need be broadcasted C before continuing other checking/settings CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(248), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) IF (KEEP(248).EQ.-1 & ) THEN C{ CALL ZMUMPS_CHECK_DISTRHS( & id%Nloc_RHS, & id%LRHS_loc, & id%NRHS, & id%IRHS_loc, & id%RHS_loc, & I_AM_SLAVE, & id%INFO) CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 C Compute sum of id%Nloc_RHS (without out-of-range) C and store it in SUM_idNloc_RHS_8 C (to be used to decide whether exploit sparsity C is exploited) CALL ZMUMPS_ES_GET_SUM_Nloc ( & id%N, id%Nloc_RHS, id%IRHS_loc, id%COMM, & SUM_idNloc_RHS_8 ) C} ENDIF C =========================================================== IF (id%MYID .EQ. MASTER) THEN C { IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(235).NE.0) ) THEN C -- input RHS is in fact effectively C -- stored in REDRHS and/or RHSINTR C (for both Schur and bwd only) id%KEEP(235) = 0 ENDIF IF ( (id%KEEP(248).EQ.0).AND.(id%KEEP(111).EQ.0) ) THEN C RHS is not sparse and thus exploit sparsity is reset to 0 id%KEEP(235) = 0 ENDIF IF (id%KEEP(248) .EQ. -1 & ) THEN IF (id%KEEP(126).EQ.0) THEN id%KEEP(235) = 0 ELSE IF (id%KEEP(126).EQ.-1) THEN id%KEEP(235) = 1 ELSE IF (id%KEEP(126).GT.0) THEN IF ( SUM_idNloc_RHS_8 .LE. & int( & (dble(id%KEEP(126))/dble(1000))*dble(id%N) & , 8) & ) THEN id%KEEP(235) = 1 ELSE id%KEEP(235) = 0 ENDIF ELSE id%KEEP(235) = 0 ENDIF ENDIF C Case of Automatic setting of exploit sparsity (KEEP(235)=-1) C (in MUMPS_DRIVER original value of KEEP(235) is reset) IF(id%KEEP(111).NE.0) id%KEEP(235)=0 IF(id%KEEP(111).NE.0) id%KEEP(212)=0 C IF (id%KEEP(235).EQ.-1) THEN IF (id%KEEP(237).NE.0) THEN C for A-1 id%KEEP(235)=1 ELSE id%KEEP(235)=1 ENDIF ELSE IF (id%KEEP(235).NE.0) THEN id%KEEP(235)=1 ENDIF C Setting of KEEP(242) (permute RHS) IF ((KEEP(111).NE.0).OR.(KEEP(248) .EQ. -1)) THEN C In the context of C - distributed RHS, all columns share the same structure C - null space, the null pivots C are by default permuted to post-order C However for null space there is in this case no need to C permute null pivots since they are already in correct order. C Setting KEEP(242)=1 would just force to go through C part of the code permuting to identity. C Apart for validation purposes this is not interesting C costly (and more risky). KEEP(242) = 0 ENDIF IF (KEEP(248).EQ.0.AND.KEEP(111).EQ.0) THEN C Permutation possible if sparse RHS C (KEEP(248).NE.0: A-1 or General Sparse) C or null space (even if in current version C it is deactived) KEEP(242) = 0 ENDIF IF ((KEEP(242).NE.0).AND.KEEP(237).EQ.0) THEN IF ((KEEP(242).NE.-9).AND.KEEP(242).NE.1.AND. & KEEP(242).NE.-1) THEN C Reset it to 0 KEEP(242) = 0 ENDIF ENDIF IF (KEEP(242).EQ.-9) THEN C { C Automatic setting of permute RHS IF (id%KEEP(237).NE.0) THEN KEEP(242) = 1 ! postorder for A-1 ELSE ! dense or general sparse or distributed RHS KEEP(242) = 0 ! no permutation in most general case IF (KEEP(248) .EQ. 1) THEN ! sparse RHS IF (id%KEEP(235) .EQ. 1) THEN ! Tree pruning IF (id%NRHS .GT. 1) THEN IF (KEEP(497).EQ.-1 .OR. KEEP(497).GE.1) THEN KEEP(242)=1 ENDIF ENDIF ENDIF ENDIF ENDIF C } ENDIF IF ( id%KEEP(221).NE.0 ) THEN C -- Do not permute RHS with REDRHS/RHSINTR id%KEEP(242) = 0 ENDIF IF (KEEP(242).EQ.0) KEEP(243)=0 ! interleave off IF ((KEEP(237).EQ.0).OR.(KEEP(242).EQ.0)) THEN C Interleave (243) possible only C when permute RHS (242) is on and with A-1 KEEP(243) = 0 ENDIF IF (id%KEEP(237).EQ.1) THEN ! A-1 entries C Case of automatic setting of KEEP(243), KEEP(493-498) C (exploit sparsity parameters) IF (id%NSLAVES.EQ.1) THEN IF (id%KEEP(243).EQ.-1) id%KEEP(243)=0 IF (id%KEEP(495).EQ.-1) id%KEEP(495)=1 IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ELSE IF (id%KEEP(243).EQ.-1) id%KEEP(243)=1 IF (id%KEEP(495).EQ.-1) id%KEEP(495)=1 IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ENDIF ELSE ! dense or general sparse or distributed RHS id%KEEP(243)=0 id%KEEP(495)=0 IF (KEEP(248) .EQ. 1) THEN ! sparse RHS IF (id%KEEP(235) .EQ. 1) THEN ! Tree pruning IF (id%NRHS .GT. 1) THEN IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ENDIF ENDIF ELSE C nbsparse meaningless for distributed or dense RHS C Force it to 0 whatever was the initial value id%KEEP(497)=0 ENDIF ENDIF MTYPE = id%ICNTL( 9 ) IF (MTYPE.NE.1) MTYPE=0 ! see interface IF ((MTYPE.EQ.0).AND.KEEP(50).NE.0) MTYPE =1 ! suppress option Atx=b for A-1 IF (id%KEEP(237).NE.0) MTYPE = 1 C C ICNTL(35) was defined at analysis and C consistently reset at factorization C It was stored in KEEP(486) after factorization C Set KEEP(485) accordingly. C IF (KEEP(486) .EQ. 2) THEN KEEP(485) = 1 ! BLR solve ELSE KEEP(485) = 0 ! FR solve ENDIF C } ENDIF id%KEEP(401) = 0 IF (id%ICNTL(48).EQ.1) id%KEEP(401)=1 C Bcast id%KEEP(401) strategy (which C may be switched off or on during solve) CALL MPI_BCAST( id%KEEP(401), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) C define ICNTL48_EFF on master IF (id%MYID.EQ.MASTER) THEN IF ( (id%KEEP(401).EQ.1). AND. (id%KEEP(400).GT.0) ) THEN ICNTL48_EFF = 1 ELSE ICNTL48_EFF = 0 ENDIF ENDIF CALL MPI_BCAST(MTYPE,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST( id%KEEP(111), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(235), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(237), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(242), 2, MPI_INTEGER, MASTER, id%COMM, & IERR ) C Allready done CALL MPI_BCAST( id%KEEP(248), ...) CALL MPI_BCAST( id%KEEP(350), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(485), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(495), 3, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( ICNTL21, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C Broadcast original id%NRHS (used at least for checks on SOL_loc C and to allocate PERM_RHS in case of exploit sparsity) CALL MPI_BCAST( id%NRHS,1, MPI_INTEGER, MASTER, id%COMM,IERR) C C TIMINGS: reset to 0 TIMEC2=0.0D0 TIMECOPYSCALE2=0.0D0 TIMEGATHER2=0.0D0 TIMESCATTER2=0.0D0 id%DKEEP(112)=0.0D0 id%DKEEP(113)=0.0D0 C id%DKEEP(114) time for the iterative refinement C id%DKEEP(120) time for the error analysis C id%DKEEP(121) time for condition number C id%DKEEP(122) time for matrix redistribution (copy+scale solution) id%DKEEP(114)=0.0D0 id%DKEEP(120)=0.0D0 id%DKEEP(121)=0.0D0 id%DKEEP(115)=0.0D0 id%DKEEP(116)=0.0D0 id%DKEEP(122)=0.0D0 C Time for fwd, bwd and scalapack is C accumulated in DKEEP(117-119) within SOL_C C If requested time for each call to FWD/BWD C might be print but on output to solve C phase DKEEP will hold on each proc the accumulated time id%DKEEP(117)=0.0D0 id%DKEEP(118)=0.0D0 id%DKEEP(119)=0.0D0 id%DKEEP(123)=0.0D0 id%DKEEP(124)=0.0D0 id%DKEEP(125)=0.0D0 id%DKEEP(126)=0.0D0 id%DKEEP(127)=0.0D0 id%DKEEP(128:134)=0.0D0 id%DKEEP(140:153)=0.0D0 C CALL MUMPS_SECDEB(TIME3) C ------------------------------ C Check parameters on the master C ------------------------------ IF ( id%MYID .EQ. MASTER ) THEN IF ((KEEP(23).NE.0).AND.KEEP(50).NE.0) THEN C Maximum transversal permutation C has not been saved (KEEP(23)>0 and UNS_PERM allocated) C when matrix is symmetric. IF (PROKG) WRITE(MPG,'(A)') & ' Internal Error 1 in solution driver ' id%INFO(1)=-444 id%INFO(2)=KEEP(23) ENDIF C ------------------------------------ C Check that factors are available C either in-core or on disk, case C where factors were discarded during C factorization (e.g. useful to simulate C an OOC factorization or just get nb of C negative pivots or determinant) C ------------------------------------ IF (KEEP(201) .EQ. -1) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: Solve impossible because factors not kept' ENDIF id%INFO(1)=-44 id%INFO(2)=KEEP(251) GOTO 333 ELSE IF (KEEP(221).EQ.0 .AND. KEEP(251) .EQ. 2 & .AND. KEEP(252).EQ.0) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: Solve impossible because factors not kept' ENDIF id%INFO(1)=-44 id%INFO(2)=KEEP(251) GOTO 333 ENDIF C ------------------ IF (KEEP(252).NE.0 .AND. id%NRHS .NE. id%KEEP(253)) THEN C Fwd in facto C KEEP(252-253) available on all procs since analysis phase C Error: id%NRHS is not allowed to change since analysis C because fwd has been performed during facto with C KEEP(253) RHS IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: id%NRHS not allowed to change when', & ' ICNTL(32)=1' ENDIF id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) GOTO 333 ENDIF C Testing MTYPE instead of ICNTL(9) IF (KEEP(252).NE.0 .AND. MTYPE.NE.1) THEN C Fwd in facto is not compatible with transpose system INFO(1) = -43 INFO(2) = 9 IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.1) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' ENDIF GOTO 333 ENDIF IF (KEEP(248) .NE. 0.AND.KEEP(252).NE.0) THEN C Fwd during facto incompatible with sparse RHS C Forbid sparse RHS when Fwd performed during facto C Sparse RHS may be due to A-1 (ICNTL(30) INFO(1) = -43 IF (KEEP(237).NE.0) THEN INFO(2) = 30 ! ICNTL(30) IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: A-1 functionality incompatible with', & ' forward performed during factorization', & ' (ICNTL(32)=1)' ENDIF ELSE INFO(2) = 20 ! ICNTL(20) IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: sparse or dist. RHS incompatible with forward', & ' elimination during factorization (ICNTL(32)=1)' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. ICNTL21.NE.0) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with distributed solution.' ENDIF INFO(1)=-48 INFO(2)=21 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(60) .NE.0) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with Schur.' ENDIF INFO(1)=-48 INFO(2)=19 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(111) .NE.0) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with null space.' ENDIF INFO(1)=-48 INFO(2)=25 GOTO 333 ENDIF IF (id%NRHS .LE. 0) THEN id%INFO(1)=-45 id%INFO(2)=id%NRHS IF ((id%KEEP(111).NE.0).AND.(id%INFOG(28).EQ.0)) THEN IF (LPOK) THEN WRITE(LP,'(A)') & 'ICNTL(25) NE 0 but INFOG(28)=0', & ' the matrix is not deficient' ENDIF ENDIF GOTO 333 ENDIF C Entries of A-1 are stored in place of the input sparse RHS C thus no need for RHS to be allocated. IF (id%KEEP(237).EQ.0) THEN IF ((id%KEEP(248) == 0 .AND.KEEP(221).NE.2) & .OR. & (ICNTL21==0.AND.(KEEP(221).NE.1)) & )THEN C RHS must be of size N*NRHS on the master either to C store the dense centralized RHS, either to store C the dense centralized solution. CALL ZMUMPS_CHECK_DENSE_RHS & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) IF (id%INFO(1) .LT. 0) GOTO 333 ENDIF ELSE C AM1: check that the constraint NRHS=N is respected C Check for valid sparse RHS structure done IF (id%NRHS .NE. id%N) THEN id%INFO(1)= -47 id%INFO(2)=id%NRHS GOTO 333 ENDIF ENDIF IF (id%KEEP(248) == 1 & ) THEN C{ ------------------------------------ C RHS_SPARSE, IRHS_SPARSE and IRHS_PTR C must be allocated of adequate size C ------------------------------------ IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(237).NE.0)) THEN C At least one entry of A-1 must be requested id%INFO(1)=-46 id%INFO(2)=id%NZ_RHS GOTO 333 ENDIF IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(221).EQ.1)) THEN C At least one entry of RHS must be nonzero with c Schur reduced RHS option id%INFO(1)=-46 id%INFO(2)=id%NZ_RHS GOTO 333 ENDIF IF ( id%NZ_RHS .GT. 0 ) THEN IF ( .not. associated(id%RHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 ENDIF ENDIF IF (id%NZ_RHS .GT. 0) THEN IF ( .not. associated(id%IRHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 ENDIF ENDIF IF ( .not. associated(id%IRHS_PTR) )THEN id%INFO(1)=-22 id%INFO(2)=12 GOTO 333 ENDIF C IF (size(id%IRHS_PTR) < id%NRHS + 1) THEN id%INFO(1)=-22 id%INFO(2)=12 GOTO 333 END IF IF (id%IRHS_PTR(id%NRHS + 1).ne.id%NZ_RHS+1) THEN id%INFO(1)=-27 id%INFO(2)=id%IRHS_PTR(id%NRHS+1) GOTO 333 END IF C compare with dble to prevent overflow IF (dble(id%N)*dble(id%NRHS).LT.dble(id%NZ_RHS)) THEN C Possible in case of dupplicate entries in Sparse RHS IF (PROKG) THEN write(MPG,*) & " WARNING: many dupplicate entries in ", & " sparse RHS provided by the user ", & " id%NZ_RHS,id%N,id%NRHS =", & id%NZ_RHS,id%N,id%NRHS ENDIF END IF IF (id%IRHS_PTR(1).ne.1) THEN id%INFO(1)=-28 id%INFO(2)=id%IRHS_PTR(1) GOTO 333 END IF IF (size(id%IRHS_SPARSE) < id%NZ_RHS) THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 END IF IF (size(id%RHS_SPARSE) < id%NZ_RHS) THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 END IF C} ENDIF C -------------------------------- C Set null space options for solve C -------------------------------- CALL ZMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL(1),KEEP(1), & id%NRHS, & MPG,INFO(1)) IF (INFO(1) .LT. 0) GOTO 333 C END IF ! MASTER C -------------------------------------- C Check distributed solution vectors C -------------------------------------- IF (ICNTL21 .NE. 0 ) THEN IF (I_AM_SLAVE) THEN NSOL_loc = id%KEEP(89) ELSE NSOL_loc = 0 ENDIF C (I)SOL_loc should be allocated to hold the C distributed solution on exit IF ( id%LSOL_loc .LT. NSOL_loc ) THEN id%INFO(1)= -29 id%INFO(2)= id%LSOL_loc GOTO 333 ENDIF IF ( NSOL_loc .GT. 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) < NSOL_loc ) THEN id%INFO(1)=-22 id%INFO(2)=13 GOTO 333 END IF # if defined(MUMPS_NOF2003) C Warning: size returns a standard INTEGER and could C overflow if id%SOL_loc was allocated of size > 2^31-1; C still we prefer to perform this test since only (1) very C large problems with large NRHS and small numbers of MPI C can result in such a situation; (2) the test could be C suppressed if needed but might be still be ok in case C the right-hand side overflows too. IF (size(id%SOL_loc) < & (id%NRHS-1)*id%LSOL_loc+NSOL_loc) THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 END IF # else IF (size(id%SOL_loc,kind=8) < & int(id%NRHS-1,8)*int(id%LSOL_loc,8)+ & int(NSOL_loc,8)) THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 END IF # endif ENDIF ! NSOL_loc > 0 ENDIF ! ICNTL21 .NE. 0 IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(248) == 1 & ) THEN C RHS should NOT be associated C if I am not master since it is C not even used to store the solution IF ( associated( id%RHS ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 7 GOTO 333 END IF IF ( associated( id%RHS_SPARSE ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 10 GOTO 333 END IF IF ( associated( id%IRHS_SPARSE ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 11 GOTO 333 END IF IF ( associated( id%IRHS_PTR ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 12 GOTO 333 END IF END IF ENDIF C Prepare pointers to pass POINTERS(1) to C routines with implicit interfaces which C will then assume contiguous information C without needing to copy pointer arrays C in and out. Do this even if KEEP(248) C is different from -1 because of the C call to ZMUMPS_DISTSOL_INDICES IF (associated(id%IRHS_loc)) THEN IF (size(id%IRHS_loc) .NE. 0) THEN IRHS_loc_PTR=>id%IRHS_loc ELSE C so that IRHS_loc_PTR(1) is ok IRHS_loc_PTR=>IDUMMY_TARGET ENDIF ELSE IRHS_loc_PTR=>IDUMMY_TARGET ENDIF IF (associated(id%RHS_loc)) THEN IF (size(id%RHS_loc) .NE. 0) THEN idRHS_loc=>id%RHS_loc ELSE idRHS_loc=>CDUMMY_TARGET ENDIF ELSE idRHS_loc=>CDUMMY_TARGET ENDIF C C C Check as soon as solution is distributed IF (I_AM_SLAVE .AND. ICNTL21.NE.0 .AND. & KEEP(248) .EQ. -1 & ) THEN ! Dist RHS and dist solution C IF (associated(id%RHS_loc) .AND. & associated(id%SOL_loc)) THEN C NSOL_loc was defined earlier IF (NSOL_loc.GT.0) THEN C ---------------------------------------------------- C Check if RHS_loc and SOL_loc point to same object... C id%SOL_loc(1) ok otherwise an error -22/14 C would have been raised earlier. C idRHS_loc(1) may point to CDUMMY but is ok C ---------------------------------------------------- CALL MUMPS_SIZE_C(idRHS_loc(1),id%SOL_loc(1), & DIFF_SOL_loc_RHS_loc) C ---------------------------------------- C Check for compatible dimensions in case C SOL_loc and RHS_loc point to same memory C ---------------------------------------- IF (DIFF_SOL_loc_RHS_loc .EQ. 0_8 .AND. & id%LSOL_loc .GT. id%LRHS_loc) THEN C Note that, depending on the block size, C if all columns are processed in one C shot, this could still work. However, C and since this was forbidden in the UG, C we raise the error systematically id%INFO(1)=-56 id%INFO(2)=id%LRHS_loc IF (LPOK) THEN WRITE(LP,'(A,I9,A,I9)') &" ** Error RHS_loc and SOL_loc pointers match but LRHS_loc=" &,id%LRHS_loc, " and LSOL_loc=", id%LSOL_loc ENDIF GOTO 333 ENDIF ENDIF ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN C Do some checks on KEEP(221) and REDRHS (in case of Schur) CALL ZMUMPS_CHECK_K221andREDRHS(id) END IF ! MYID.EQ.MASTER IF (id%INFO(1) .LT. 0) GOTO 333 C ------------------------- C Propagate possible errors C ------------------------- 333 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 C ==================================== C END CHECK INTERFACE AND KEEP ENTRIES C ==================================== C ----------------------------------- 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) ENDIF C C ======================================================= C BEGIN Test for empty RHS : C sparse RHS and General Sparse (NOT A-1) and NZ_RHS = 0 C OR C Distributed RHS and sum of id%Nloc_RHS C (without off out-of-range) equal to 0 C ======================================================= IF & ( & ( (id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0) & .AND. (id%NZ_RHS.EQ.0) ) & .OR. & ( (id%KEEP(248).EQ.-1).AND. (SUM_idNloc_RHS_8.EQ.0_8) & ) & ) THEN C{ C We reset solution to zero and we return C (first freeing working space at label 90) IF ((ICNTL21.EQ.1).AND.(I_AM_SLAVE)) THEN C ---------------------- C SOL_loc reset to zero C ---------------------- C ---------------------- C Prepare ISOL_loc array C ---------------------- LIW_PASSED=max(1,KEEP(32)) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF (KEEP(89) .GT. 0) THEN CALL ZMUMPS_DISTSOL_INDICES( MTYPE, id%ISOL_loc(1), & id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%IS(1), LIW_PASSED,id%MYID_NODES, & id%N, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES, #if defined(USE_OLD_SCALING) & scaling_data_sol, .FALSE., ! empty RHS, no scaling #endif C For checking only & .FALSE., IDUMMY(1), 1 & ) ENDIF ENDIF C Solution is null IF (ICNTL21.NE.0) THEN ! distributed solution DO J=1, id%NRHS C (NSOL_loc=KEEP(89) or id%NSOL_loc, and in case C ICNTL21=1, NSOL_loc is 0 on non-working host) DO I=1, NSOL_loc id%SOL_loc(int(J-1,8)*id%LSOL_loc + I) =ZERO ENDDO ENDDO ENDIF IF (ICNTL21.EQ.0) THEN ! centralized solution C ---------------------------- C RHS reset to zero on master C ---------------------------- IF (id%MYID.EQ.MASTER) THEN DO J=1, id%NRHS DO I=1, id%N id%RHS(int(J-1,8)*int(id%LRHS,8) + int(I,8)) =ZERO ENDDO ENDDO ENDIF ENDIF C C print solve phase stats if requested IF ( PROKG ) THEN WRITE( MPG, 150 ) C ICNTL(35) should not been accessed during SOLVE thus C print KEEP(486) value set during factorization & id%NRHS, ICNTL(27), ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30), KEEP(486), & ICNTL48_EFF IF (KEEP(221).NE.0) THEN WRITE (MPG, 152) KEEP(221) ENDIF IF (KEEP(252).GT.0) THEN ! Fwd during facto WRITE (MPG, 153) KEEP(252) ENDIF ENDIF C C -------- GOTO 90 ! end of solve deallocate what is needed C} ENDIF ! test empty RHS (general sparse or Distributed) C ======================================================= C END of Test for empty RHS : C ======================================================= C ==================================== C END CHECK INTERFACE AND KEEP ENTRIES C ==================================== INTERLEAVE_PAR =.FALSE. DO_PERMUTE_RHS =.FALSE. CALL_NODES_FWD_BWD = .FALSE. FIRST_CALL_NODES_FWD_BWD = .FALSE. C Default is no sparsity exploited nodes_FWD_PTR => IDUMMY_TARGET nodes_BWD_PTR => IDUMMY_TARGET Lnodes_FWD = -1 Lnodes_BWD = -1 C IF ((id%KEEP(235).NE.0).or.(id%KEEP(237).NE.0) & ) THEN CALL_NODES_FWD_BWD = .TRUE. FIRST_CALL_NODES_FWD_BWD = .TRUE. C Case of pruned elimination tree or selected entries in A-1 IF (id%KEEP(237).NE.0.AND. & id%KEEP(248).EQ.0) THEN C When A-1 is requested (keep(237).ne.0) C sparse RHS has been forced to be on. IF (LPOK) THEN WRITE(LP,'(A,I4,I4)') & ' Internal Error 2 in solution driver (A-1) ', & id%KEEP(237), id%KEEP(248) ENDIF CALL MUMPS_ABORT() ENDIF C NBT (in Bytes) is inout in MUMPS_REALLOC and C should be initialized. NBT = 0 C -- Allocate Step2node on each proc CALL MUMPS_REALLOC(id%Step2node, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%Step2node (Solve)', MEMCNT=NBT, ERRCODE=-13) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C -- build Step2node on each proc; C -- this is usefull to have at each step a unique C -- representative node (associated with principal variable of C -- that node. IF (NBT.NE.0) THEN ! Step2node was reallocated and needs be recomputed DO I=1, id%N IF (id%STEP(I).LE.0) CYCLE ! nonprincipal variables id%Step2node(id%STEP(I)) = I ENDDO C ELSE C we reuse Step2node computed in a previous solve phase C Step2node is deallocated each time a new analysis is C performed or when job=-2 is called ENDIF C --- NBT is the nb of extra bytes allocated NB_BYTES = NB_BYTES + NBT NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) NB_BYTES_EXTRA = NB_BYTES_EXTRA + NBT C Mapping information used during solve. In case of several C facto+solve it has to be recomputed. C In case of several solves with the same C facto, it is not recomputed. C It is used to compute the interleaving C for A-1, and, in dev_version, passed to sol_c to compute C some stats IF((KEEP(235).NE.0).OR.(KEEP(237).NE.0)) THEN IF(.NOT.associated(id%IPTR_WORKING)) THEN C Not computed at a previous solve: C recompute id%IPTR_WORKING and id%WORKING CALL ZMUMPS_BUILD_MAPPING_INFO(id) END IF idIPTR_WORKING => id%IPTR_WORKING idWORKING => id%WORKING ELSE C case of selected entries in solution C with no ES during fwd SIZE_WORKING = 1 SIZE_IPTR_WORKING = 1 idIPTR_WORKING => IDUMMY_TARGET idWORKING => IDUMMY_TARGET END IF ENDIF C C Initialize SIZE_OF_BLOCK from MUMPS_SOL_ES module IF ( I_AM_SLAVE ) THEN CALL ZMUMPS_SOL_ES_INIT(id%OOC_SIZE_OF_BLOCK, id%KEEP(201)) ENDIF DO_NULL_PIV = .TRUE. NBCOL_INBLOC = -9998 NZ_THIS_BLOCK= -9998 JBEG_RHS = -9998 c IF (id%MYID.EQ.MASTER) THEN ! Compute NRHS_NONEMPTY C C -- Sparse RHS (general, centralized) IF ( KEEP(111)==0 .AND. KEEP(248)==1 & ) THEN C -- Note that KEEP(111).NE.0 (null space on) C -- and KEEP(248).NE.0 will be made incompatible C -- When computing entries of A-1 (or SparseRHS only) NRHS_NONEMPTY = 0 DO I=1, id%NRHS IF (id%IRHS_PTR(I).LT.id%IRHS_PTR(I+1)) THEN NRHS_NONEMPTY = NRHS_NONEMPTY+1 !ith col in non empty ENDIF ENDDO IF (NRHS_NONEMPTY.LE.0) THEN C Internal error: tested before in mumps_driver IF (LPOK) & WRITE(LP,*) " Internal Error 3 in solution driver ", & " NRHS_NONEMPTY= ", & NRHS_NONEMPTY CALL MUMPS_ABORT() ENDIF ELSE NRHS_NONEMPTY = id%NRHS ENDIF ENDIF C ------------------------------------ C If there is a special root node, C precompute mapping of root's master C ------------------------------------ SIZE_ROOT = -33333 IF ( KEEP( 38 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP( KEEP(38))), & KEEP(199) ) IF (id%MYID_NODES .eq. MASTER_ROOT) THEN SIZE_ROOT = idintr%root%TOT_ROOT_SIZE ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN C SIZE_ROOT also used for KEEP(221).NE.0 SIZE_ROOT=id%KEEP(116) ENDIF ELSE IF (KEEP( 20 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(KEEP(20))), & KEEP(199) ) IF (id%MYID_NODES .eq. MASTER_ROOT) THEN SIZE_ROOT = id%IS( & id%PTLUST_S(id%STEP(KEEP(20)))+KEEP(IXSZ) + 3) ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN C SIZE_ROOT also used for KEEP(221).NE.0 SIZE_ROOT=id%KEEP(116) ENDIF ELSE MASTER_ROOT = -44444 END IF C -------------- C Get block size C -------------- C We work on a maximum of NBRHS at a time. C The leading dimension of RHS is id%LRHS on the host process C and it is set to N on slave processes. IF (id%MYID .eq. MASTER) THEN C{ KEEP(84) = ICNTL(27) C Treating ICNTL(27)=0 as if ICNTL(27)=1 IF(ICNTL(27).EQ.0) KEEP(84)=1 IF (KEEP(252).NE.0) THEN ! Fwd in facto: all rhs (KEEP(253) need be processed in one pass NBRHS = KEEP(253) ELSE IF (KEEP(201) .EQ. 0 .OR. KEEP(84) .GT. 0) THEN NBRHS = abs(KEEP(84)) ELSE NBRHS = -2*KEEP(84) END IF IF (NBRHS .GT. NRHS_NONEMPTY ) NBRHS = NRHS_NONEMPTY C ENDIF C} ENDIF #if defined(V_T) CALL VTBEGIN(glob_comm_ini,IERR) #endif C NRHS_NONEMPTY needed on all procs to allocate RHSINTR on slaves CALL MPI_BCAST(NRHS_NONEMPTY,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(NBRHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) C IF (KEEP(201).GT.0) THEN C --- id%KEEP(201) indicates if OOC is on (=1) of not (=0) C -- 107: number of buffers C Define number of types of files (L, possibly U) WORKSPACE_MINIMAL_PREFERRED = .FALSE. IF (id%MYID .eq. MASTER) THEN KEEP(107) = max(0,KEEP(107)) IF ((KEEP(107).EQ.0).AND. & (KEEP(204).EQ.0).AND.(KEEP(211).NE.1) ) THEN C -- default setting for release 4.8 ! Case of ! -Emmergency buffer only and ! -Synchronous mode ! -NO_O_DIRECT (because of synchronous choice) ! THEN ! "Basic system-based version" ! We can force to allocate S to a minimal ! value. WORKSPACE_MINIMAL_PREFERRED=.TRUE. ENDIF ENDIF CALL MPI_BCAST( KEEP(107), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(204), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(208), 2, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( WORKSPACE_MINIMAL_PREFERRED, 1, & MPI_LOGICAL, & MASTER, id%COMM, IERR ) C --- end of OOC case ENDIF IF ( I_AM_SLAVE ) THEN C C NB_K133: Max number of simultaneously processed C active fronts. C Why more than one active node ? C 1/ In parallel when we start a level 2 node C then we do not know exactly when we will C have received all contributions from the C slaves. C This is very critical in OOC since the C size provided to the solve phase is C much smaller and since we need C to determine the size fo the buffers for IO. C We pospone the allocation of the block NFRONT*NB_NRHS C and solve the problem. C C C 2/ While processing a node and sending information C if we have not enough memory in send buffer C then we must receive. C We feel that this is not so critical. C NB_K133 = 3 C To this we must add one time KEEP(133) to store C the RHS of the root node if the root is local. C Furthermore this quantity has to be multiplied by the C blocking size in case of multiple RHS. IF ( KEEP( 38 ) .NE. 0 .OR. KEEP( 20 ) .NE. 0 ) THEN IF ( MASTER_ROOT .eq. id%MYID_NODES ) THEN IF ( & .NOT. associated(idintr%roota%RHS_CNTR_MASTER_ROOT) & ) THEN NB_K133 = NB_K133 + 1 ENDIF END IF ENDIF C -------------------------------------- C NRHS_COLS_SOL_C is the maximum number C of colums for the call to ZMUMPS_SOL_C C -------------------------------------- NRHS_COLS_SOL_C = min(NRHS_NONEMPTY,NBRHS) C C LWCB8_MIN = int(NB_K133,8)*int(KEEP(133),8)* & int(NRHS_COLS_SOL_C,8) C ENDIF C --------------------------------------------------------------- C Set WK_USER_PROVIDED to true when workspace WK_USER is provided C We can accept WK_USER to be provided on only some process and C different values of WK_USER per process. WK_USER_PROVIDED = (id%LWK_USER.NE.0 .AND.I_AM_SLAVE) IF (WK_USER_PROVIDED) THEN IF (id%LWK_USER.GT.0) THEN ITMP8= int(id%LWK_USER,8) ELSE ITMP8 = -int(id%LWK_USER,8)* 1000000_8 ENDIF ELSE ITMP8 = 0_8 ENDIF CALL MPI_REDUCE ( ITMP8, SUM_ITMP8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) C Incore: Check if the provided size is equal to that used during C facto (case of ITMP8/=0 and KEEP8(24)/=ITMP8) C But also check case of space not provided during solve C but was provided during facto C (case of ITMP8=0 and KEEP8(24)/=0) IF (KEEP(201).EQ.0) THEN ! incore C Compare provided size with previous size IF (ITMP8.NE.KEEP8(24)) THEN C -- error when reusing space allocated INFO(1) = -41 INFO(2) = id%LWK_USER ENDIF ELSE KEEP8(24)=ITMP8 ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 IF (.NOT. I_AM_SLAVE) KEEP8(124)=SUM_ITMP8 C all procs: KEEP8(24) holds the size of WK_USER provided by user. C master only: KEEP8(124) indicates if WK_USER provided on some proc MAXS = 0_8 IF (I_AM_SLAVE) THEN IF (WK_USER_PROVIDED) THEN MAXS = KEEP8(24) IF (MAXS.LT. KEEP8(20)) THEN INFO(1)= -11 ! MAXS should be increased by at least ITMP8 ITMP8 = KEEP8(20)+1_8-MAXS CALL MUMPS_SET_IERROR(ITMP8, INFO(2)) ENDIF IF (INFO(1) .GE. 0 ) id%S => id%WK_USER(1:KEEP8(24)) ALLOCATE_S = .FALSE. ELSE IF (KEEP8(23) .GT. 0) THEN MAXS = KEEP8(23) C S is already allocated, of size KEEP8(23) ALLOCATE_S = .FALSE. ELSE IF (KEEP(201).EQ.0) THEN ! incore C id%S might have been freed during factorization and C reallocated of size KEEP8(31) ( if KEEP8(31)>0 ) IF (KEEP8(31).EQ.0) THEN MAXS = 1 ALLOCATE_S = .TRUE. ENDIF ELSE C -- OOC and WK_USER not provided: C define size (S) and allocate it C ---- modify size of MAXS: in a simple C ---- system-based version, we want to C ---- use a small size for MAXS, to C ---- avoid the system pagecache to be C ---- polluted by 'our memory' ALLOCATE_S = .TRUE. IF ( KEEP(209).EQ.-1 .AND. WORKSPACE_MINIMAL_PREFERRED) & THEN C We need space to load at least the largest factor MAXS = KEEP8(20) + 1_8 ELSE IF ( KEEP(209) .GE.0 ) THEN C Use suggested value of MAXS provided in KEEP(209) MAXS = max(int(KEEP(209),8), KEEP8(20) + 1_8) ELSE MAXS = id%KEEP8(14) ! initial value: do not use more than ! minimum (non relaxed) size of OOC facto ENDIF C MAXS = max(MAXS, id%KEEP8(20)+1_8) C --- end of OOC case ENDIF IF ( ALLOCATE_S ) THEN ALLOCATE (id%S(MAXS), stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID,': problem allocation of S ', & 'at solve' ENDIF INFO(1) = -13 CALL MUMPS_SET_IERROR(MAXS, INFO(2)) KEEP8(23)=0_8 ALLOCATE_S = .FALSE. ELSE KEEP8(23)=MAXS ENDIF NB_BYTES = NB_BYTES + KEEP8(23) * K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C IF (KEEP(201).EQ.0) THEN C On the slaves, S is divided as follows: C S(1..LA) holds the factors, C S(LA+1..MAXS) is free workspace LA = KEEP8(31) ELSE C MAXS has normally been dimensionned to store only factors. LA = MAXS IF(MAXS.GT.KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8))THEN C If we have a very large MAXS, the size reserved for C loading the factors into memory does not need to exceed the C total size of factors. The (KEEP8(20)*(KEEP(107)+1)) term C is here in order to ensure that even with round-off C problems (linked to the number of solve zones) factors can C all be stored in-core LA=KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8) ENDIF ENDIF C C We need to allocate a workspace of size LWCB8 for the solve phase. C Either it is available at the end of MAXS, or we perform a C dynamic allocation. IF ( MAXS-LA .GT. LWCB8_MIN & ) THEN LWCB8 = MAXS - LA WORK_WCB => id%S(LA+1_8:LA+LWCB8) WORK_WCB_ALLOCATED=.FALSE. ELSE LWCB8 = LWCB8_MIN ALLOCATE(WORK_WCB(LWCB8), stat=allocok) IF (allocok < 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(LWCB8,INFO(2)) ELSE WORK_WCB_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + LWCB8*K151_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C --------------------------------- C Space for the RHS of special root C --------------------------------- IF ( id%MYID_NODES .EQ. MASTER_ROOT ) THEN C This is a special root (otherwise MASTER_ROOT < 0) IF ( associated(idintr%roota%RHS_CNTR_MASTER_ROOT) ) THEN C RHS_CNTR_MASTER_ROOT may have been allocated C during the factorization phase. PTR_RHS_ROOT => idintr%roota%RHS_CNTR_MASTER_ROOT # if defined(MUMPS_NOF2003) LPTR_RHS_ROOT = & int(size(idintr%roota%RHS_CNTR_MASTER_ROOT),8) # else LPTR_RHS_ROOT = & size(idintr%roota%RHS_CNTR_MASTER_ROOT,kind=8) # endif ELSE C In this case, the space for RHS_CNTR_MASTER_ROOT C is always part of WORKWCB, which can itself be C part of id%S or not. LPTR_RHS_ROOT = NRHS_COLS_SOL_C * int(SIZE_ROOT,8) PTR_RHS_ROOT => WORK_WCB(LWCB8-LPTR_RHS_ROOT+1_8:LWCB8) C Reduce size of WORK_WCB LWCB8=LWCB8-LPTR_RHS_ROOT ENDIF ELSE LPTR_RHS_ROOT = 1_8 PTR_RHS_ROOT => CDUMMY_TARGET ENDIF ENDIF ! I_AM_SLAVE C ----------------------------------- 99 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 C ----------------------------------- IF ( I_AM_SLAVE ) THEN IF (KEEP(201).GT.0) THEN CALL ZMUMPS_INIT_FACT_AREA_SIZE_S(LA) C -- This includes thread creation C -- for asynchronous strategies CALL ZMUMPS_OOC_INIT_SOLVE(id%ICNTL(1), id%ICNTL(4), id%N, & id%NSLAVES, id%MYID, id%OOC_NB_FILE_TYPE, id%KEEP, id%KEEP8, & id%INFO, id%STEP, id%PROCNODE_STEPS, id%OOC_SIZE_OF_BLOCK, & id%OOC_INODE_SEQUENCE, id%OOC_VADDR, & id%OOC_MAX_NB_NODES_FOR_ZONE, id%OOC_TOTAL_NB_NODES, & id%OOC_NB_FILES, id%OOC_FILE_NAME_LENGTH, id%OOC_FILE_NAMES, & id%COMM_NODES, idintr%root%yes) IS_INIT_OOC_DONE = .TRUE. ENDIF ! KEEP(201).GT.0 ENDIF C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 C IF (I_AM_SLAVE) THEN IF (KEEP(485).EQ.1) THEN IF (.NOT. (associated(id%FDM_F_ENCODING))) THEN WRITE(*,*) "Internal error 18 in ZMUMPS_SOL_DRIVER" CALL MUMPS_ABORT() ENDIF IF (.NOT. (associated(id%BLRARRAY_ENCODING))) THEN WRITE(*,*) "Internal error 19 in ZMUMPS_SOL_DRIVER" CALL MUMPS_ABORT() ENDIF C Access to OOC data in module during solve CALL MUMPS_FDM_STRUC_TO_MOD('F',id%FDM_F_ENCODING) CALL ZMUMPS_BLR_STRUC_TO_MOD(id%BLRARRAY_ENCODING) IS_LR_MOD_TO_STRUC_DONE = .TRUE. ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN C{ IF ( PROKG ) THEN WRITE( MPG, 150 ) C ICNTL(35) should not been accessed during SOLVE thus C print KEEP(486) value set during factorization & id%NRHS, NBRHS, ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30), KEEP(486), & ICNTL48_EFF IF (KEEP(111).NE.0) THEN WRITE (MPG, 151) KEEP(111) ENDIF IF (KEEP(221).NE.0) THEN WRITE (MPG, 152) KEEP(221) ENDIF IF (KEEP(252).GT.0) THEN ! Fwd during facto WRITE (MPG, 153) KEEP(252) ENDIF ENDIF C ==================================== C Define LSCAL, ICNTL10 and ICNTL11 C ==================================== LSCAL = (((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) .OR. ( & KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) ICNTL10 = ICNTL(10) ICNTL11 = ICNTL(11) C Values of ICNTL(11) out of range IF ((ICNTL11 .LT. 0).OR.(ICNTL11 .GE. 3)) THEN ICNTL11 = 0 IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) out of range' ENDIF CALL ZMUMPS_SET_POSTPros ( & KEEP(1), ICNTL(1), NBRHS, MPG, PROKG, & ICNTL10, ICNTL11, POSTPros) C} -- end of test master END IF CALL MPI_BCAST(POSTPros,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) C We need the original matrix only in the case of C we want to perform IR or Error Analysis, i.e. if C POSTPros = TRUE MAT_ALLOC_LOC = 0 IF ( POSTPros ) THEN MAT_ALLOC_LOC = 1 C Check if the original matrix has been allocated. IF ( KEEP(54) .EQ. 0 ) THEN C The original matrix is centralized IF ( id%MYID .eq. MASTER ) THEN IF (KEEP(55).eq.0) THEN C Case of matrix assembled centralized IF (.NOT.associated(id%A) .OR. & (.NOT.associated(id%IRN)) .OR. & ( .NOT.associated(id%JCN))) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original centralized assembled', & ' matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ELSE C Case of matrix in elemental format IF (.NOT.associated(id%A_ELT).OR. & .NOT.associated(id%ELTPTR).OR. & .NOT.associated(id%ELTVAR)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original elemental matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ENDIF ENDIF !end master, centralized matrix ELSE C The original matrix is assembled distributed IF ( I_AM_SLAVE .AND. (id%KEEP8(29) .GT. 0_8) ) THEN C If MAT_ALLOC_LOC = 1 the local distributed matrix is C allocated, otherwise MAT_ALLOC_LOC = 0 IF ((.NOT.associated(id%A_loc)) .OR. & (.NOT.associated(id%IRN_loc)) .OR. & (.NOT.associated(id%JCN_loc))) THEN IF (PROK) WRITE(MP,'(A/,A,I5,I12)') & ' WARNING: original distributed matrix not allocated', & ' MPI rank, local nonzeros=', & id%MYID, id%KEEP8(29) MAT_ALLOC_LOC = 0 ENDIF ENDIF ENDIF ! end test allocation matrix (keep(54)) ENDIF ! POSTPros CALL MPI_REDUCE( MAT_ALLOC_LOC, MAT_ALLOC, 1, & MPI_INTEGER, & MPI_MIN, MASTER, id%COMM, IERR) IF ( POSTPros.and.(id%MYID .eq. MASTER) ) THEN C if postprocessing requested matrix must be allocated IF (MAT_ALLOC.EQ.0) THEN IF (KEEP(54).NE.0) THEN C Write on MPG this time (we wrote on MP before in C case of distributed matrix and wrote on MPG already C in case of centralized matrix) IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original distributed matrix is not allocated' ENDIF POSTPros = .FALSE. ICNTL11 = 0 ICNTL10 = 0 C Write a warning. IF ((ICNTL(10) .NE. 0) .AND. (ICNTL10 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0' ENDIF IF ((ICNTL(11) .EQ. 1).OR.(ICNTL(11) .EQ. 2) & .AND.(ICNTL11 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF ENDIF IF (POSTPros) THEN ALLOCATE(SAVERHS(id%N*NBRHS),stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Problem in solve: error allocating SAVERHS' ENDIF INFO(1) = -13 INFO(2) = id%N*NBRHS END IF NB_BYTES = NB_BYTES + int(size(SAVERHS),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C C Forbid entries in a-1, in case of null space computations c IF (KEEP(237).NE.0 .AND.KEEP(111).NE.0) THEN C Ignore ENTRIES IN A-1 in case we compute C vectors of the null space (KEEP(111)).NE.0.) C We should still allocate IRHS_SPARSE IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: KEEP(237) treated as if set to 0 (null space)' KEEP(237)=0 ENDIF C -- end of test master END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C -------------------------------------------------- C Broadcast information to have all processes do the C same thing (error analysis/iterative refinements/ C scaling/distribution of solution) C -------------------------------------------------- CALL MPI_BCAST(ICNTL10,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(ICNTL11,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(POSTPros,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) CALL MPI_BCAST(LSCAL,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) CALL MPI_BCAST(KEEP(237),1,MPI_INTEGER,MASTER, & id%COMM,IERR) #if ! defined(USE_OLD_SCALING) C ---------------------------------------------- C Initialize SCALING_LOC_FWD and SCALING_LOC_BWD C They corespond to all pivots factorized on a C given MPI process and point to a dummy array C of size 1 on the host of if no pivot was C factorized (KEEP(89))=0 C ---------------------------------------------- IF (LSCAL .AND. id%KEEP(89) .GT. 0) THEN IF (MTYPE .EQ. 1) THEN SCALING_LOC_FWD => id%ROWSCA_loc SCALING_LOC_BWD => id%COLSCA_loc ELSE SCALING_LOC_FWD => id%COLSCA_loc SCALING_LOC_BWD => id%ROWSCA_loc ENDIF ELSE ! includes non working master on which KEEP(89)=0 SCALING_LOC_FWD => RDUMMY_TARGET SCALING_LOC_BWD => RDUMMY_TARGET ENDIF C Remarks related to scalings: C * During postprocessing, one performs solves C with alternatively A and A^T, meaning that C SCALING_LOC_FWD and SCALING_LOC_BWD will C be redefined. C * In case of exploit sparsity, RHSINTR may C have less rows than ROWSCA_loc/COLSCA_loc. C SCALING_RHSINTR_FWD and SCALING_RHSINTR_BWD C will then be extracted from C SCALING_LOC_FWD and SCALING_LOC_BWD thanks C to the subroutine ZMUMPS_SCALINGRHSINTR #endif C KEEP(248)==1 if not_NullSpace (KEEP(111)=0) C and sparse RHS on input (id%ICNTL(20)/KEEP(248)==1) C (KEEP(248)==1 implies KEEP(111) = 0, otherwise error was raised) C We cant thus isolate the case of C sparse RHS associated to Null space computation because C in this case preparation is different since C -we skip the forward step and C -the pattern of the RHS C of the bwd is related to null pivot indices found and not C to information contained in the sparse rhs input format. DO_PERMUTE_RHS = (KEEP(242).NE.0) C apply interleaving in parallel (FOR A-1 or Null space only) IF ( (id%NSLAVES.GT.1) .AND. (KEEP(243).NE.0) & ) THEN C -- Option to interleave RHS only makes sense when C -- A-1 option is on or Null space compution are on C (note also that KEEP(243).NE.0 only when PERMUTE_RHS is on) IF ((KEEP(237).NE.0).or.(KEEP(111).GT.0)) THEN INTERLEAVE_PAR= .TRUE. IF (KEEP(237).EQ.1) THEN IF (NRHS_NONEMPTY.LT.2*NBRHS) THEN INTERLEAVE_PAR= .FALSE. ENDIF ENDIF ELSE IF (PROKG) THEN write(MPG,*) ' Warning incompatible options ', & ' interleave RHS reset to false ' ENDIF ENDIF ENDIF CALL MUMPS_BUF_INIT( id%KEEP( 34 ), id%KEEP(151) ) C -------------------------------------- C Compute an upperbound of message size C for forward and backward solutions: C -------------------------------------- MSG_MAX_BYTES_SOLVE8 = int(( 4 + KEEP(133) ) * KEEP(34),8) + & int(KEEP(133)*KEEP(151),8) * int(NBRHS,8) & + int(16*KEEP(34),8) ! for request id, pointer to next + safety IF ( MSG_MAX_BYTES_SOLVE8 .GT. & int(huge(I4),8)) THEN INFO(1) = -18 C Max NBRHS to avoid overflow: INFO(2) = ( huge(I4) - & ( 16 + 4 + KEEP(133) ) * KEEP(34) ) / & ( KEEP(133) * KEEP(151) ) ENDIF IF (INFO(1) .LT.0 ) GOTO 111 MSG_MAX_BYTES_SOLVE = int(MSG_MAX_BYTES_SOLVE8) C ------------------------------------------ C Compute an upperbound of message size C for ZMUMPS_GATHER_SOLUTION. Except C possibly on the non working host, it C should be smaller than MSG_MAX_BYTES_SOLVE C ------------------------------------------ IF (KEEP(237).EQ.0) THEN C Note that for ZMUMPS_GATHER_SOLUTION LBUFR buffer should C be larger that MAX_inode(NPIV))*NBRHS + NPIV C which is covered by next formula since KMAX_246_247 is larger C than MAX_inode(NPIV)) C 2 integers packed (npiv and termination) C Note that MSG_MAX_BYTES_GTHRSOL < MSG_MAX_BYTES_SOLVE C so that it should not overflow KMAX_246_247 = max(KEEP(246),KEEP(247)) MSG_MAX_BYTES_GTHRSOL = ( 2 + KMAX_246_247 ) * KEEP(34) + & KMAX_246_247 * NBRHS * KEEP(149) ELSE IF (ICNTL21.EQ.0) THEN C Each message from a slave is of size max 4: C 2 integers : I,J C 1 complex : (Aij)-1 C 1 terminaison MSG_MAX_BYTES_GTHRSOL = ( 3 * KEEP(34) + KEEP(149) ) ELSE C Not needed in case of distributed solution and A-1 C because the entries of A −1 are C returned in RHS SPARSE on the host. MSG_MAX_BYTES_GTHRSOL = 0 ENDIF C The buffer is used both for solve and for ZMUMPS_GATHER_SOLUTION LBUFR_BYTES = max(MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL) TSIZE = int(min(100_8*int(MSG_MAX_BYTES_GTHRSOL,8), & 10000000_8)) LBUFR_BYTES = max(LBUFR_BYTES,TSIZE) LBUFR = ( LBUFR_BYTES + KEEP(34) - 1 ) / KEEP(34) ALLOCATE (BUFR(LBUFR),stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ' Problem in solve: error allocating BUFR' ENDIF INFO(1) = -13 INFO(2) = LBUFR GOTO 111 ENDIF NB_BYTES = NB_BYTES + int(size(BUFR),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( I_AM_SLAVE .AND. id%NSLAVES .GT. 1 ) THEN C ------------------------------------------------------ C Dimension send buffer for small integers, e.g. TRACINE C ------------------------------------------------------ ZMUMPS_LBUF_INT = ( 20 + id%NSLAVES * id%NSLAVES * 4 ) & * KEEP(34) CALL MUMPS_BUF_ALLOC_SMALL_BUF( ZMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = ZMUMPS_LBUF_INT IF ( LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating small Send buffer:IERR=',IERR END IF GOTO 111 END IF C C --------------------------------------- C Dimension cyclic send buffer for normal C messages, based on largest message C size during forward and backward solves C --------------------------------------- C Compute buffer size in BYTES (ZMUMPS_LBUF) C using integer8 in ZMUMPS_LBUF_8 C then convert it in integer4 and bound it to largest integer value C ZMUMPS_LBUF_8 = & (int(MSG_MAX_BYTES_SOLVE,8)+2_8*int(KEEP(34),8))* & int(id%NSLAVES,8) C Avoid buffers larger than 100 Mbytes ... ZMUMPS_LBUF_8 = min(ZMUMPS_LBUF_8, 100000000_8) C ... as long as we can send messages to at least 3 C destinations simultaneously ZMUMPS_LBUF_8 = max(ZMUMPS_LBUF_8, & int((MSG_MAX_BYTES_SOLVE+2*KEEP(34)),8) * & int(min(id%NSLAVES,3),8) ) ZMUMPS_LBUF_8 = ZMUMPS_LBUF_8 + 2_8*int(KEEP(34),8) C Convert to integer and bound it to largest 32-bit integer C and suppress 10 integers (one should be enough!) C to enable computation of integer size. ZMUMPS_LBUF_8 = min(ZMUMPS_LBUF_8, & int(huge(I4),8) & - 10_8*int(KEEP(34),8) & ) ZMUMPS_LBUF = int(ZMUMPS_LBUF_8, kind(ZMUMPS_LBUF)) CALL MUMPS_BUF_ALLOC_CB( ZMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = ZMUMPS_LBUF/KEEP(34) + 1 IF ( LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating Send buffer:IERR=', IERR END IF GOTO 111 END IF C C C -- end of I am slave ENDIF C IF ( POSTPros ) THEN C When Iterative refinement of error analysis requested C Allocate RHS_IR on slave processors C (note that on MASTER RHS_IR points to RHS) IF ( id%MYID .NE. MASTER ) THEN C ALLOCATE(RHS_IR(id%N),stat=IERR) NB_BYTES = NB_BYTES + int(size(RHS_IR),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( IERR .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) THEN WRITE(LP,*) 'ERROR while allocating RHS on a slave' ENDIF GOTO 111 END IF ELSE RHS_IR=>id%RHS ENDIF ENDIF C C Parallel A-1 or General sparse and C exploit sparsity between columns DO_NBSPARSE = ( ( (KEEP(237).NE.0).OR.(KEEP(235).NE.0) ) & .AND. & ( KEEP(497).NE.0 ) & ) IF ( I_AM_SLAVE ) THEN IF(DO_NBSPARSE) THEN c --- ALLOCATE outside loop RHS_BOUNDS is needed LPTR_RHS_BOUNDS = 2*KEEP(28) ALLOCATE(RHS_BOUNDS(LPTR_RHS_BOUNDS), STAT=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=LPTR_RHS_BOUNDS IF (LPOK) THEN WRITE(LP,*) 'ERROR while allocating RHS_BOUNDS on', & ' a slave' ENDIF GOTO 111 END IF NB_BYTES = NB_BYTES + & int(size(RHS_BOUNDS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) PTR_RHS_BOUNDS => RHS_BOUNDS ELSE LPTR_RHS_BOUNDS = 1 PTR_RHS_BOUNDS => IDUMMY_TARGET ENDIF ENDIF C -------------------------------------------------- IF ( I_AM_SLAVE ) THEN IF ((KEEP(221).EQ.2 .AND. KEEP(252).EQ.0)) THEN C -- RHSINTR must have been allocated in C -- previous solve step (with option KEEP(221)=1) IF (.NOT.associated(id%RHSINTR)) THEN INFO(1) = -35 INFO(2) = 1 GOTO 111 ENDIF C IF ((KEEP(248).EQ.0) .OR. (id%NRHS.EQ.1)) THEN C GLOB2LOC_RHS/SOL are meaningful and could even be reused IF (.NOT.associated(id%GLOB2LOC_RHS) ) ! .OR. ! & .NOT.(id%GLOB2LOC_SOL_ALLOC)) & THEN INFO(1) = -35 INFO(2) = 2 GOTO 111 ENDIF IF (.not.id%GLOB2LOC_SOL_ALLOC) THEN C GLOB2LOC_SOL that is kept from C previous call to solve must then (already) C point to id%GLOB2LOC_RHS id%GLOB2LOC_SOL => id%GLOB2LOC_RHS ENDIF ELSE C ---------------------- C Allocate GLOB2LOC_RHS/SOL C ---------------------- C The size of POSINRHSINTR arrays C does not depend on the block of RHS C GLOB2LOC_RHS/SOL are initialized in the loop of RHS IF (associated(id%GLOB2LOC_RHS)) THEN NB_BYTES = NB_BYTES - & int(size(id%GLOB2LOC_RHS),8)*K34_8 DEALLOCATE(id%GLOB2LOC_RHS) ENDIF ALLOCATE (id%GLOB2LOC_RHS(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 END IF NB_BYTES = NB_BYTES + & int(size(id%GLOB2LOC_RHS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%GLOB2LOC_SOL_ALLOC) THEN NB_BYTES = NB_BYTES - & int(size(id%GLOB2LOC_SOL),8)*K34_8 DEALLOCATE(id%GLOB2LOC_SOL) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF C IF ( (KEEP(50).EQ.0).OR.(KEEP(237).NE.0).OR. & (KEEP(212).NE.0) & ) THEN ALLOCATE (id%GLOB2LOC_SOL(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 END IF id%GLOB2LOC_SOL_ALLOC = .TRUE. NB_BYTES = NB_BYTES + & int(size(id%GLOB2LOC_SOL),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE C Do no allocate GLOB2LOC_SOL id%GLOB2LOC_SOL => id%GLOB2LOC_RHS id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF IF (KEEP(221).NE.2) THEN C -- only in the case of bwd after C -- fwd only (with or without Schur) C -- we have to keep "old" RHSINTR IF (associated(id%RHSINTR)) THEN NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25) = 0_8 id%LD_RHSINTR = 0 ENDIF ENDIF ENDIF C --------------------------- C Allocate local workspace C for the solve (ZMUMPS_SOL_C) C --------------------------- LIWK_SOLVE = 2 * KEEP(28) + id%NA(1)+1 LIWK_PTRACB= KEEP(28) C KEEP(228)+1 temporary integer positions C will be needed in ZMUMPS_SOL_S IF (KEEP(201).EQ.1) THEN LIWK_SOLVE = LIWK_SOLVE + KEEP(228) + 1 ELSE C Reserve 1 position to pass array of size 1 in routines LIWK_SOLVE = LIWK_SOLVE + 1 ENDIF ALLOCATE ( IWK_SOLVE(LIWK_SOLVE), & PTRACB(LIWK_PTRACB), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWK_SOLVE + LIWK_PTRACB*KEEP(10) GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWK_SOLVE,8)*K34_8 + & int(LIWK_PTRACB,8)*K34_8 *int(KEEP(10),8) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C array IWCB used temporarily to hold C indices of a front unpacked from a message C and to stack (potentially in a recursive call) C headers of size 2 positions of CB blocks. LIWCB = 20*NB_K133*2 + KEEP(133) ALLOCATE ( IWCB( LIWCB), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWCB GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWCB,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C C -- Code for a slave C ----------- C Subdivision C of array IS C ----------- LIW = KEEP(32) C Define a work array of size maximum global frontal C size (KEEP(133)) for the call to ZMUMPS_SOL_C C This used to be of size id%N. ALLOCATE(SRW3(KEEP(133)), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=KEEP(133) GOTO 111 END IF NB_BYTES = NB_BYTES + int(KEEP(133),8)*K151_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ----------------- C End of slave code C ----------------- ELSE C I am the master with host not working C C LIW is used on master when calling C the routine ZMUMPS_GATHER_SOLUTION. LIW=0 END IF C C Precompute inverse of UNS_PERM outside loop IF (allocated(UNS_PERM_INV)) DEALLOCATE(UNS_PERM_INV) UNS_PERM_INV_NEEDED_INMAINLOOP = .FALSE. IF ( ( id%MYID .eq. MASTER.AND.(KEEP(23).GT.0) .AND. & (MTYPE .NE. 1).AND.(KEEP(248).NE.0) & ) C Permute UNS_PERM on master only with C sparse RHS (KEEP(248).NE.0 ) when AT x = b is solved & .OR. ( KEEP(237).NE.0 .AND. KEEP(23).NE.0 ) C When A-1 is active and when the matrix is unsymmetric C and a column permutation has been applied (Max transversal) C then we have performed a C factorization of a column permuted matrix AQ = LU. C In this case, C the permuted entry must be used to select the target C entries for the BWD (note that a diagonal entry of A-1 C is not anymore a diagonal of AQ. Thus a diagonal C of A-1 does not correspond to the same path C in the tree during FWD and BWD steps when MAXTRANS is on C and permutation is not identity.) C Note that the inverse permutation C UNS_PERM_INV needs to be allocated on each proc C since it is used in ZMUMPS_SOL_C routine for pruning. C It is allocated only once and its allocation has been C migrated outside the blocking on the right hand sides. & ) THEN UNS_PERM_INV_NEEDED_INMAINLOOP = .TRUE. ENDIF UNS_PERM_INV_NEEDED_BEFMAINLOOP = .FALSE. IF (KEEP(23) .GT. 0 .AND. MTYPE.EQ.1 .AND. ICNTL21.EQ.2) THEN UNS_PERM_INV_NEEDED_INMAINLOOP = .TRUE. ENDIF IF ( KEEP(23) .GT.0 .AND. & MTYPE .NE. 1 .AND. KEEP(248).EQ.-1 ) THEN C Similar to sparse RHS case, we need to modify IRHS_loc C indices in the distributed RHS case. However, we need C UNS_PERM_INV on all processors. But only before the C main loop on the RHS blocks. UNS_PERM_INV_NEEDED_BEFMAINLOOP = .TRUE. ENDIF C UNS_PERM_INV_NEEDED_ONSLAVES = .FALSE. IF ( UNS_PERM_INV_NEEDED_INMAINLOOP .OR. & UNS_PERM_INV_NEEDED_BEFMAINLOOP ) THEN C We need UNS_PERM_INV ALLOCATE(UNS_PERM_INV(id%N),stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 endif NB_BYTES = NB_BYTES + int(id%N,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.EQ.MASTER) THEN C Build inverse permutation DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I ENDDO ENDIF C ELSE ALLOCATE(UNS_PERM_INV(1), stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=1 GOTO 111 endif NB_BYTES = NB_BYTES + 1_8*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C 111 CONTINUE #if defined(V_T) CALL VTEND(glob_comm_ini,IERR) #endif C C Synchro point + Broadcast of errors C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C C UNS_PERM_INV needed on slaves: IF ( KEEP(23).NE.0 .AND. & ( KEEP(237).NE.0 .OR. & ( MTYPE.NE.1 .AND. KEEP(248).EQ.-1 ) .OR. & ( MTYPE.EQ.1 .AND. ICNTL21.EQ.2) & ) & ) THEN UNS_PERM_INV_NEEDED_ONSLAVES = .TRUE. ENDIF IF (UNS_PERM_INV_NEEDED_ONSLAVES) THEN C Broadcast UNS_PERM_INV CALL MPI_BCAST( UNS_PERM_INV,id%N,MPI_INTEGER,MASTER, & id%COMM,IERR ) ENDIF C ------------------------------- C BEGIN C Preparation for distributed RHS C ------------------------------- IF (I_AM_SLAVE .AND. KEEP(248).EQ.-1 & ) THEN C Distributed RHS case ALLOCATE(MAP_RHS_loc(max(id%Nloc_RHS,1)), stat=allocok) IF (allocok .GT. 0) THEN id%INFO(1)=-13 id%INFO(2)=max(id%Nloc_RHS,1) GOTO 20 ENDIF NB_BYTES = NB_BYTES + max(int(id%Nloc_RHS,8),1_8)*K34_8 ENDIF C MAP_RHS_loc will be built in the main C loop, when processing the first block. C It requires POSINRHSINTR to be built. BUILD_RHSMAPINFO = .TRUE. 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT.0 ) GOTO 90 C In case of Unsymmetric column permutation and C transpose system, use MUMPS internal indices C for IRHS_loc_PTR. Done before scaling since C scaling is on permuted matrix IF ( I_AM_SLAVE .AND. KEEP(23).GT.0 .AND. KEEP(248).EQ.-1 & .AND. MTYPE.NE.1 & ) THEN IF (id%Nloc_RHS .GT. 0) THEN ALLOCATE(IRHS_loc_PTR(id%Nloc_RHS),stat=allocok) IF (allocok.GT.0) THEN INFO(1)=-13 INFO(2)=id%Nloc_RHS GOTO 25 ENDIF IRHS_loc_PTR_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + max(int(id%Nloc_RHS,8),1_8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) DO I=1, id%Nloc_RHS IF (id%IRHS_loc(I).GE.1 .AND. id%IRHS_loc(I).LE.id%N) & THEN IRHS_loc_PTR(I)=UNS_PERM_INV(id%IRHS_loc(I)) ELSE C Keep track of out-of range entries IRHS_loc_PTR(I)=id%IRHS_loc(I) ENDIF ENDDO ENDIF ENDIF C Check if UNS_PERM_INV still needed C to free memory IF (UNS_PERM_INV_NEEDED_BEFMAINLOOP .AND. & .NOT. UNS_PERM_INV_NEEDED_INMAINLOOP) THEN NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 DEALLOCATE(UNS_PERM_INV) ALLOCATE(UNS_PERM_INV(1)) ! to posibly pass it as an argument NB_BYTES = NB_BYTES + K34_8 ENDIF #if defined(USE_OLD_SCALING) IF (LSCAL .AND. id%KEEP(248).EQ.-1 & ) THEN C Scaling done based on original indices C provided by user IF (MTYPE == 1) THEN C No transpose scaling_data_dr%SCALING=>id%ROWSCA ELSE C Transpose scaling_data_dr%SCALING=>id%COLSCA ENDIF CALL ZMUMPS_SET_SCALING_LOC( scaling_data_dr, id%N, & IRHS_loc_PTR(1), id%Nloc_RHS, & id%COMM, id%MYID, I_AM_SLAVE, MASTER, & NB_BYTES, NB_BYTES_MAX, K16_8, LP, LPOK, & ICNTL(1), INFO(1) ) ENDIF #endif C ------------------------------- C END C Preparation for distributed RHS C ------------------------------- 25 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT.0 ) GOTO 90 C ------------------------------------- C BEGIN C Preparation for distributed solution C ------------------------------------- IF ( ICNTL21 .NE. 0 ) THEN C{ #if defined(USE_OLD_SCALING) IF (LSCAL) THEN C{ In case of scaling we will need to scale C back the sol. Put the values of the scaling C arrays needed to do that on each processor. IF (id%MYID.NE.MASTER) THEN IF (MTYPE == 1) THEN ALLOCATE(id%COLSCA(id%N),stat=allocok) ELSE ALLOCATE(id%ROWSCA(id%N),stat=allocok) ENDIF IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating temporary scaling array' ENDIF INFO(1)=-13 INFO(2)=id%N GOTO 37 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ! MYID .NE. MASTER 37 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data_sol%SCALING_LOC(max(1,id%KEEP(89))), & stat=allocok) IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating local scaling array' ENDIF INFO(1)=-13 INFO(2)=max(1,id%KEEP(89)) GOTO 38 ENDIF IF (ICNTL21.NE.0) THEN C Real entries for scaling NB_BYTES = NB_BYTES + int(max(1,id%KEEP(89)),8)*K16_8 ENDIF NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ! I_AM_SLAVE 38 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) THEN GOTO 90 ENDIF IF (MTYPE == 1) THEN CALL MPI_BCAST(id%COLSCA(1),id%N, & MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) scaling_data_sol%SCALING=>id%COLSCA ELSE CALL MPI_BCAST(id%ROWSCA(1),id%N, & MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) scaling_data_sol%SCALING=>id%ROWSCA ENDIF C} ENDIF ! LSCAL #endif IF ( ICNTL21.EQ.1 .AND. I_AM_SLAVE & ) THEN C -------------------------------- C Prepare ISOL_loc array #if defined(USE_OLD_SCALING) C and on the fly, scaling_data_sol #endif C -------------------------------- LIW_PASSED=max(1,LIW) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF (KEEP(89) .GT. 0) THEN CALL ZMUMPS_DISTSOL_INDICES( MTYPE, id%ISOL_loc(1), & id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%IS(1), LIW_PASSED,id%MYID_NODES, & id%N, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES, #if defined(USE_OLD_SCALING) & scaling_data_sol, LSCAL, #endif C For checking only & (KEEP(248).EQ.-1), IRHS_loc_PTR(1), id%Nloc_RHS & ) ENDIF ENDIF ! I_AM_SLAVE #if defined(USE_OLD_SCALING) #endif #if defined(USE_OLD_SCALING) IF (id%MYID.NE.MASTER .AND. LSCAL) THEN C --------------------------------- C Local (small) scaling arrays have C been built, free temporary copies C --------------------------------- IF (MTYPE == 1) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ELSE DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF NB_BYTES = NB_BYTES - int(id%N,8)*K16_8 ENDIF #endif C} ENDIF ! ICNTL21 .NE. 0 IF (ICNTL21 .EQ.1) THEN C --------------------------------------------------- C Take into account unsymmetric permutation to modify C ISOL_loc, in case ISOL_loc is provided by MUMPS C --------------------------------------------------- IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN C Broadcast the unsymmetric permutation and C permute the indices in ISOL_loc IF (id%MYID.NE.MASTER) THEN ALLOCATE(id%UNS_PERM(id%N),stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=id%N GOTO 40 ENDIF ENDIF ENDIF C C ===================== ERROR handling and propagation ================ 40 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN CALL MPI_BCAST(id%UNS_PERM(1),id%N,MPI_INTEGER,MASTER, & id%COMM,IERR) IF (I_AM_SLAVE) THEN DO I=1, KEEP(89) id%ISOL_loc(I) = id%UNS_PERM(id%ISOL_loc(I)) ENDDO ENDIF IF (id%MYID.NE.MASTER) THEN DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF ENDIF ENDIF ! ICNTL(21)=1 C -------------------------------------- C Preparation for distributed solution C END C -------------------------------------- C --------------------------------------------- C In case of Schur, preparation for reduced RHS C --------------------------------------------- IF ( (KEEP(60).NE.0) .AND. & ( & ( KEEP(221) .EQ. 1 ) .OR. & ( KEEP(221) .EQ. 2 ) & ) & ) THEN C -- First compute MASTER_ROOT_IN_COMM proc number in C COMM_NODES on which is mapped the master of the root. IF (KEEP(46).EQ.1) THEN MASTER_ROOT_IN_COMM=MASTER_ROOT ELSE MASTER_ROOT_IN_COMM =MASTER_ROOT+1 ENDIF IF ( id%MYID .EQ. MASTER ) THEN C -------------------------------- C Avoid using LREDRHS when id%NRHS is C equal to 1, as was done for RHS C -------------------------------- IF (id%NRHS.EQ.1) THEN LD_REDRHS = id%KEEP(116) ELSE LD_REDRHS = id%LREDRHS ENDIF ENDIF IF (MASTER.NE.MASTER_ROOT_IN_COMM) THEN C -- Make available LD_REDRHS on MASTER_ROOT_IN_COMM C This will then be used to test if a single C message can be sent C (this is possible if LD_REDRHS=SIZE_SCHUR) IF ( id%MYID .EQ. MASTER ) THEN C -- send LD_REDRHS to MASTER_ROOT_IN_COMM C using COMM communicator CALL MPI_SEND(LD_REDRHS,1,MPI_INTEGER, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSEIF ( id%MYID.EQ.MASTER_ROOT_IN_COMM) THEN C -- recv LD_REDRHS CALL MPI_RECV(LD_REDRHS,1,MPI_INTEGER, & MASTER, 0, id%COMM,STATUS,IERR) ENDIF C -- other procs not concerned ENDIF ENDIF C IF ( KEEP(248)==1 & ) THEN ! Sparse RHS (A-1 or general sparse) ! JBEG_RHS - current starting column within A-1 or sparse rhs ! set in the loop below and used to obtain the ! global index of the column of the sparse RHS ! Also used to get index in global permutation. ! It also allows to skip empty columns; JEND_RHS = 0 ! last column in current blockin A-1 C C Compute and apply permutations IF (DO_PERMUTE_RHS) THEN C Allocate PERM_RHS ALLOCATE(PERM_RHS(id%NRHS),stat=allocok) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = id%NRHS GOTO 109 ENDIF NB_BYTES = NB_BYTES + int(id%NRHS,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.EQ.MASTER) THEN C PERM_RHS is computed on MASTER, it might be modified C in case of interleaving and will thus be distributed C (BCAST) to all slaves only later. C Compute PERM_RHS C on output: PERM_RHS(k) = i means that i is the kth column C to be processed IF (KEEP(237).EQ.0) THEN C Permute RHS : case of GS (General Sparse) RHS C IRHS_SPARSE is of size at least NZ_RHS > 0 C since all this is skipped when NZ_RHS=0. So C accessing IRHS_SPARSE(1) is ok. CALL ZMUMPS_PERMUTE_RHS_GS( & LP, LPOK, PROKG, MPG, KEEP(242), & id%SYM_PERM(1), id%N, id%NRHS, & id%IRHS_PTR(1), id%NRHS+1, & id%IRHS_SPARSE(1), id%NZ_RHS, & PERM_RHS, IERR) IF (IERR.LT.0) THEN INFO(1) = -9999 INFO(2) = IERR GOTO 109 ! propagate error ENDIF ELSE C Case of A-1 : C We compute the permutation of the RHS (sparse matrix) C (to compute all inverse entries) C We apply permutation to IRHS_SPARSE ONLY. C Note NRHS_NONEMPTY holds the nb of non empty columns C in A-1. STRAT_PERMAM1 = KEEP(242) CALL ZMUMPS_PERMUTE_RHS_AM1 & (STRAT_PERMAM1, id%SYM_PERM(1), & id%IRHS_PTR(1), id%NRHS+1, & PERM_RHS, id%NRHS, & IERR & ) ENDIF ENDIF ENDIF ENDIF C C Note that within ZMUMPS_SOL_C, PERM_RHS could be used C for A-1 case (with DO_PERMUTE_RHS OR INTERLEAVE_RHS C being tested) to get the column index for the C original matrix of RHS (column index in A-1) C of the permuted columns that have been selected. C PERM_RHS is also used in ZMUMPS_GATHER_SOLUTION C in case of sparse RHS awith DO_PERMUTE_RHS. C C Allocate PERM_RHS of size 1 if not allocated IF (.NOT. allocated(PERM_RHS)) THEN ALLOCATE(PERM_RHS(1),stat=allocok) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = 1 GOTO 109 ENDIF NB_BYTES = NB_BYTES + int(size(PERM_RHS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C Propagate errors 109 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 c -------------------------- c -------------------------- IF (id%NSLAVES .EQ. 1) THEN C{ - In case of NS/A-1 we may want to permute RHS C - for NS thus is to apply permutation to PIVNUL_LIST C - before starting loop of NBRHS IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN C NOTE: C when host not working both master and slaves have C in this case the complete list WRITE(*,*) id%MYID, ':INTERNAL ERROR 1 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF ! End Permute_RHS C} ELSE IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 2 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() C ENDIF ! End DO_PERMUTE_RHS IF (INTERLEAVE_PAR.AND. (KEEP(111).NE.0)) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 3 : ', & ' INTERLEAVE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF IF (INTERLEAVE_PAR.AND.KEEP(111).EQ.0 & ) THEN C - A-1 + Interleave: C permute RHS on master IF (id%MYID.EQ.MASTER) THEN C -- PERM_RHS must have been already set or initialized C -- it is then modified in next routine SIZE_WORKING = id%IPTR_WORKING(id%NPROCS+1)-1 SIZE_IPTR_WORKING = id%NPROCS+1 CALL ZMUMPS_INTERLEAVE_RHS_AM1( & PERM_RHS, id%NRHS, & id%IPTR_WORKING(1), SIZE_IPTR_WORKING, & id%WORKING(1), SIZE_WORKING, & id%IRHS_PTR(1), & id%STEP(1), id%SYM_PERM(1), id%N, NBRHS, & id%PROCNODE_STEPS(1), KEEP(28), id%NSLAVES, & KEEP(199), & KEEP(493).NE.0, & KEEP(495).NE.0, KEEP(496), PROKG, MPG & ) ENDIF ! End Master ENDIF ! End A-1 and INTERLEAVE_PAR C ------------- ENDIF ! End Parallel Case c -------------------------- c IF (DO_PERMUTE_RHS.AND.(KEEP(111).EQ.0)) THEN C --- Distribute PERM_RHS before loop of RHS C --- (with null space option PERM_RHS is not allocated / needed C to permute the null column pivot list) CALL MPI_BCAST(PERM_RHS(1), & id%NRHS, & MPI_INTEGER, & MASTER, id%COMM,IERR) ENDIF C L0-threads to be activated iff KEEP(401)=1 and KEEP(400)>0 IF (KEEP(401) .EQ. 1) THEN C L0-threads was requested for solve phase C and will be effective only if KEEP(400) >0 C which indicates that L0-threads was C performed during analysis+factorization IF ( KEEP(400) .GT. 0 .AND. KEEP(369).EQ.0 ) THEN C{ Check if number of threads is consistent with C the one used during factorization for all procs C Note that if KEEP(369)>0 C KEEP(400) was set based on C KEEP(369) and KEEP(381) so that C omp_set_num_threads(KEEP(400)) will be called C explicitly before L0_OMP section C and KEEP(400) cannot be check here in this way C NOMP = 1 !$ NOMP=omp_get_max_threads() IF (KEEP(400).NE.NOMP) THEN C NOMP should be the one from analysis id%INFO(1) = -58 id%INFO(2) = KEEP(400) IF (LPOK) WRITE(LP,'(A,A,I5,A,I5)') &" FAILURE DETECTED IN SOLVE: #threads for multithreaded", &" tree parallelism changed from",KEEP(400)," at analysis to", & NOMP ENDIF C} ENDIF C error check CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 C} ENDIF IF (KEEP(400) .GT. 0) THEN CALL MUMPS_SOL_L0OMP_LI(KEEP(400)) ENDIF C ============================== C MAIN LOOP: C BLOCKING ON the number of RHS C We work on a maximum of NBRHS at a time. C the leading dimension of RHS is id%LRHS on master C and is set to N on slaves C ============================== C We may want to allow to have NBRHS that varies C this is typically the case when a partitionning of C the right hand side is performed and leads to C irregular partitions. C We only have to be sure that the size of each partition C is smaller than NBRHS. BEG_RHS=1 DO WHILE (BEG_RHS.LE.NRHS_NONEMPTY) C { CALL MUMPS_STOP_ON_USER_REQUEST( id%KEEP, id%KEEP8, id%ICNTL, & id%INFO, id%MYID ) CALL MUMPS_PROPINFO( id%ICNTL, id%INFO, id%COMM, id%MYID ) IF (id%INFO(1). LT. 0) GOTO 90 C ========================== C -- NBRHS : Original block size C -- BEG_RHS : Column index of the first RHS in the list of C non empty RHS (RHS_loc) to C be processed during this iteration C -- NBRHS_EFF : Effective block size at current iteration C that will be set to nb of contiguous non empty C columns C In case of sparse RHS (KEEP(248)==1) NBRHS_EFF only refers to C non-empty columns and is used to compute NBCOL_INBLOC C -- NBCOL_INBLOC : the number of columns of sparse RHS needed C to get NBRHS_EFF non empty columns columns of C sparse RHS processed at each step C NBRHS_EFF = min(NRHS_NONEMPTY-BEG_RHS+1, NBRHS) C C Sparse RHS C Free space and reset pointers if needed IF (IRHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_SPARSE_COPY),8)*K34_8 DEALLOCATE(IRHS_SPARSE_COPY) IRHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_SPARSE_COPY) ENDIF IF (IRHS_PTR_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_PTR_COPY),8)*K34_8 DEALLOCATE(IRHS_PTR_COPY) IRHS_PTR_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_PTR_COPY) ENDIF IF (RHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(RHS_SPARSE_COPY),8)*K35_8 DEALLOCATE(RHS_SPARSE_COPY) RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_SPARSE_COPY) ENDIF C C =========================================================== C Set LD_RHS and IBEG for the accesses to id%RHS (in cases C id%RHS is accessed). Remark that IBEG might still be C overwritten later, in case of general sparse right-hand side C and centralized solution to skip empty columns C =========================================================== IF ( C slave procs & ( id%MYID .NE. MASTER ) C even on master when RHS not allocated & .or. C Case of Master working but with distributed sol and C ( sparse RHS or null space ) C -- Allocate not needed on host not working & ( I_AM_SLAVE .AND. id%MYID .EQ. MASTER .AND. & ICNTL21 .NE.0 .AND. & ( KEEP(248).ne.0 .OR. KEEP(221).EQ.2 & .OR. KEEP(111).NE.0 ) & ) & .or. C Case of Master and C (compute entries of INV(A)) C Even when I am a master with host not working I C am in charge of gathering solution to scale it C and to copy it back in the sparse RHS format & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) C & ) THEN LD_RHS = id%N IBEG = 1 ELSE ! (id%MYID .eq. MASTER) IF ( associated(id%RHS) ) THEN C Leading dimension of RHS on master is id%LRHS LD_RHS = max(id%LRHS, id%N) ELSE C --- LRHS might not be defined (dont use it) LD_RHS = id%N ENDIF IBEG = int(BEG_RHS-1,8) * int(LD_RHS,8) + 1_8 ENDIF C JBEG_RHS might also be used in DISTRIBUTED_SOLUTION C even when RHS is not sparse on input. In this case, C there are no empty columns. (If RHS is sparse JBEG_RHS C is overwritten). JBEG_RHS = BEG_RHS C ========================================== C Shift empty columns in case of sparse RHS C ========================================== IF ( (id%MYID.EQ.MASTER) .AND. & KEEP(248)==1 & ) THEN C update position of JBEG_RHS on first non-empty C column of this block JBEG_RHS = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( id%IRHS_PTR(PERM_RHS(JBEG_RHS)) .EQ. & id%IRHS_PTR(PERM_RHS(JBEG_RHS)+1) ) C Empty column IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) & ) THEN C General sparse RHS (NOT A-1) and centralized solution C Set to zero part of the C solution corresponding to empty columns DO I=1, id%N id%RHS(int(PERM_RHS(JBEG_RHS) -1,8)*int(LD_RHS,8)+ & int(I,8)) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ELSE DO WHILE( id%IRHS_PTR(JBEG_RHS) .EQ. & id%IRHS_PTR(JBEG_RHS+1) ) IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) & ) THEN C Case of general sparse RHS (NOT A-1) and C centralized solution: set to zero part of C the solution corresponding to empty columns DO I=1, id%N id%RHS(int(JBEG_RHS -1,8)*int(LD_RHS,8) + & int(I,8)) = ZERO ENDDO ENDIF IF (KEEP(221).EQ.1) THEN IF (KEEP(60).NE.0) THEN C Fwd with Schur: reduced RHS set to ZERO DO I = 1, id%SIZE_SCHUR id%REDRHS(int(JBEG_RHS-1,8)*int(LD_REDRHS,8) + & int(I,8)) = ZERO ENDDO ENDIF ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR C Count nb of RHS columns skipped: useful for C * ZMUMPS_DISTRIBUTED_SOLUTION to reset those C columns to zero. C * in case of reduced right-hand side, to set C corresponding entries of RHSINTR to 0 after C forward phase. NB_RHSSKIPPED = JBEG_RHS - (JEND_RHS + 1) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0) & .AND. (ICNTL21.EQ.0)) & THEN ! case of general sparse rhs with centralized solution, !set IBEG to shifted columns ! (after empty columns have been skipped) IBEG = int(JBEG_RHS-1,8) * int(LD_RHS,8) + 1_8 ENDIF ENDIF ! of if (id%MYID.EQ.MASTER) .AND. KEEP(248)==1 CALL MPI_BCAST( JBEG_RHS, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C C Shift on REDRHS in reduced RHS functionality C IF (id%MYID.EQ.MASTER .AND. KEEP(221).NE.0 & .AND. KEEP(60).NE.0 ) THEN C Initialize IBEG_REDRHS C Note that REDRHS always has id%NRHS Colmuns IBEG_REDRHS= int(JBEG_RHS-1,8)*int(LD_REDRHS,8) + 1_8 ELSE IBEG_REDRHS=-142424_8 ! Should not be used ENDIF C C ===================== C BEGIN C Prepare RHS on master C #if defined(V_T) CALL VTBEGIN(perm_scal_ini,IERR) #endif IF (id%MYID .eq. MASTER) THEN C{ ====================== IF (KEEP(248)==1 & ) THEN C{ ====================== C C Sparse RHS format ( A-1 or sparse centralized input format) C is provided as input by the user (IRHS_SPARSE ...) C -------------------------------------------------- C Compute NZ_THIS_BLOCK and NBCOL_INBLOC C where C NZ_THIS_BLOCK is defined C as the number of entries in the next NBRHS_EFF C non empty columns (note that since they might be permuted C then the following formula is not always valid: C NZ_THIS_BLOCK=id%IRHS_PTR(BEG_RHS+NBRHS_EFF)- C & id%IRHS_PTR(BEG_RHS) C anyway NBCOL_INBLOC also need be computed so going through C columns one at a time is needed. C NBCOL = 0 NBCOL_INBLOC = 0 NZ_THIS_BLOCK = 0 C With exploit sparsity we skip empty columns up to reaching C the first non empty column; then we process a block of C maximum size NBRHS_EFF except if we reach another empty C column. (We are not sure to have a copy allocated C and thus cannot compress on the fly, as done naturally C for A-1) C For A-1 we process NBRHS_EFF non empty columns C in the bloc that contains NBCOL_INBLOC columns C (empty+non empty) STOP_AT_NEXT_EMPTY_COL = .FALSE. DO I=JBEG_RHS, id%NRHS NBCOL_INBLOC = NBCOL_INBLOC +1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN C PERM_RHS(k) = i means that i is the kth C column to be processed C PERM_RHS should also be defined for C empty columns i in A-1 (PERM_RHS(K) = i) COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) ELSE COLSIZE = id%IRHS_PTR(I+1) - id%IRHS_PTR(I) ENDIF IF ((.NOT.STOP_AT_NEXT_EMPTY_COL).AND.(COLSIZE.GT.0).AND. & (KEEP(237).EQ.0)) THEN C -- set STOP_NEXT_EMPTY_COL only for general C -- sparse case (not AM-1) STOP_AT_NEXT_EMPTY_COL =.TRUE. ENDIF IF (COLSIZE.GT.0 C{ & ) THEN NBCOL = NBCOL+1 NZ_THIS_BLOCK = NZ_THIS_BLOCK + COLSIZE C} ELSE IF (STOP_AT_NEXT_EMPTY_COL) THEN C{ We have reached an empty column with already selected non empty C columns: reduce block size to non empty columns reached so far. NBCOL_INBLOC = NBCOL_INBLOC -1 C Note that NBRHS_EFF is udated only on master NBRHS_EFF = NBCOL EXIT C} ENDIF IF (NBCOL.EQ.NBRHS_EFF) EXIT ENDDO IF (NZ_THIS_BLOCK.EQ.0) THEN WRITE(*,*) " Internal Error 16 in sol driver NZ_THIS_BLOCK=", & NZ_THIS_BLOCK CALL MUMPS_ABORT() ENDIF C IF (NBCOL.NE.NBRHS_EFF.AND. (KEEP(237).NE.0) & .AND.KEEP(221).NE.1) THEN C With exploit sparsity for general sparse RHS (Not A-1) C we skip empty rows up to reaching C the first non empty column; then we process a block of C maximum size NBRHS_EFF except if we reach another empty C column. (We are not sure to have a copy allocated C and thus cannot compress on the fly, as done naturally C for A-1). Thus NBCOL might be smaller than NBRHS_EFF WRITE(6,*) ' Internal Error 8 in solution driver ', & NBCOL, NBRHS_EFF call MUMPS_ABORT() ENDIF C ------------------------------------------------------------- C IF (NZ_THIS_BLOCK .NE. 0) THEN C ----------------------------------------------------------- C We recall that C NBCOL_INBLOC is the number of columns of sparse RHS needed C to get NBRHS_EFF non empty columns: ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NBCOL_INBLOC+1 GOTO 30 endif IRHS_PTR_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 C ----------------------------------------------------------- C Initialize IRHS_PTR_COPY C compute local copy (compressed) of id%IRHS_PTR on Master IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 IRHS_PTR_COPY(J) = IPOS COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) IPOS = IPOS + COLSIZE ENDDO ELSE IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 IRHS_PTR_COPY(J) = IPOS COLSIZE = id%IRHS_PTR(I+1) & - id%IRHS_PTR(I) IPOS = IPOS + COLSIZE ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR IRHS_PTR_COPY(NBCOL_INBLOC+1)= IPOS IF ( IPOS-1 .NE. NZ_THIS_BLOCK ) THEN WRITE(*,*) "Error in compressed copy of IRHS_PTR" IERR = 99 call MUMPS_ABORT() ENDIF C ----------------------------------------------------------- C IRHS_SPARSE : do a copy or point to the original indices C C Check whether IRHS_SPARSE_COPY need be allocated IF (KEEP(23) .NE. 0 .and. MTYPE .NE. 1) THEN C AP = LU and At x = b ==> b need be permuted ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK) & ,stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 30 endif IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN C Columns are not contiguous and need be copied one by one C IRHS_SPARSE_COPY will hold a copy of contiguous permuted C columns so an explicit copy is needed. C IRHS_SPARSE_COPY is also allways allocated with A-1, C to enable receiving during mumps_gather_solution C . on the master in any order. ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) IF (allocok .GT.0 ) THEN IERR = 99 GOTO 30 ENDIF IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ENDIF C C Initialize IRHS_SPARSE_COPY IF (IRHS_SPARSE_COPY_ALLOCATED) THEN IF ( DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ) THEN IPOS = 1 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) DO K=0,COLSIZE-1 IRHS_SPARSE_COPY(IPOS+K) = & id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K) ENDDO IPOS = IPOS + COLSIZE ENDDO ELSE DO K=1,NZ_THIS_BLOCK IRHS_SPARSE_COPY(K) = id%IRHS_SPARSE( & id%IRHS_PTR(JBEG_RHS)+K-1) ENDDO ENDIF ELSE IRHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => & id%IRHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ENDIF #if defined(USE_OLD_SCALING) C Centralized scaling: perform scaling on master C in RHS_SPARSE_COPY IF (LSCAL.OR.DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN #else IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN #endif C if columns of the RHS are C permuted then a copy of RHS_SPARSE is needed. C Also always allocated with A-1, c to enable receiving during mumps_gather_solution C on the master in any order. C ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 30 ENDIF RHS_SPARSE_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE IF ( KEEP(248)==1 ) THEN RHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => id%RHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ELSE RHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => id%RHS_SPARSE(id%IRHS_PTR(BEG_RHS): & id%IRHS_PTR(BEG_RHS)+NZ_THIS_BLOCK-1) ENDIF ENDIF IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) THEN IF (id%KEEP(237).NE.0) THEN C --initialized to one #if defined(USE_OLD_SCALING) C it might be modified if scaling is on (one first entry C in each col is scaled) RHS_SPARSE_COPY = ONE #else C Local scalings are used: RHSINTR is initialized C directly on the workers and RHS_SPARSE_COPY will C only be used during ZMUMPS_GATHER_SOLUTION_AM1. #endif ELSE C -- Columns are not contiguous and need be copied one by one #if defined(USE_OLD_SCALING) C -- This need not be done if scaling is on because it C -- will done and scaled later. IF (.NOT. LSCAL) THEN #endif 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 DO K=0, COLSIZE-1 RHS_SPARSE_COPY(IPOS+K) = & id%RHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K) ENDDO IPOS = IPOS + COLSIZE ENDDO #if defined(USE_OLD_SCALING) ENDIF #endif ENDIF ENDIF C ========================= IF (KEEP(23) .NE. 0) THEN C ========================= * maximum transversal was performed IF (MTYPE .NE. 1) THEN * At x = b is asked while * we have AP = LU where P is the column permutation * due to max trans. * Therefore we need to modify rhs: * b' = P-1 b (P-1=Pt) * Apply column permutation to the right hand side RHS * Column J of the permuted matrix corresponds to * column PERMW(J) of the original matrix. * C ========== C SPARSE RHS : permute indices rather than values C ========== C Solve with At X = B should never occur for A-1 IPOS = 1 DO I=1, NBCOL_INBLOC C Note that: (i) IRHS_PTR_COPY is compressed; C (ii) columns might have been permuted COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) DO K = 1, COLSIZE JPERM = UNS_PERM_INV(IRHS_SPARSE_COPY(IPOS+K-1)) IRHS_SPARSE_COPY(IPOS+K-1) = JPERM ENDDO IPOS = IPOS + COLSIZE ENDDO ENDIF ! MTYPE.NE.1 ENDIF ! KEEP(23).NE.0 ENDIF ! NZ_THIS_BLOCK .NE. 0 C} ----- ENDIF ! ============ KEEP(248)==1 C} ----- ENDIF ! (id%MYID .eq. MASTER) C C ===================== ERROR handling and propagation ================ 30 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C C NBCOL_INBLOC depends on loop IF (KEEP(248)==1 & ) THEN CALL MPI_BCAST( NBCOL_INBLOC,1, MPI_INTEGER, & MASTER, id%COMM,IERR) ELSE NBCOL_INBLOC = NBRHS_EFF ENDIF JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN C Only case (in previous block) for which C NBRHS_EFF has been modified only on master ! case of general sparse: in case of empty columns ! modifed version of ! NBRHS_EFF need be broadcasted since it is used ! to update BEG_RHS at the end of the DO WHILE CALL MPI_BCAST( NBRHS_EFF,1, MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(NB_RHSSKIPPED,1,MPI_INTEGER,MASTER, & id%COMM,IERR) ENDIF IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0) & .AND.(KEEP(221).NE.2 ).AND.(KEEP(248).EQ.1) ) THEN C{ ---------------------------- C -- SPARSE RIGHT-HAND-SIDE C ---------------------------- CALL MPI_BCAST( NZ_THIS_BLOCK,1, MPI_INTEGER, & MASTER, id%COMM,IERR) IF (id%MYID.NE.MASTER .and. NZ_THIS_BLOCK.NE.0) THEN ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 45 endif IRHS_SPARSE_COPY_ALLOCATED=.TRUE. C RHS_SPARSE_COPY is broadcasted C for A-1 even if on the slaves the initialisation of the RHS C could be only based on the pattern. Doing so we C broadcast the scaled version of the RHS (scaling arrays C that are not available on slaves). ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 45 endif RHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*(K34_8+K35_8) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NBCOL_INBLOC+1 GOTO 45 endif IRHS_PTR_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C C ===================== ERROR handling and propagation ================ 45 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== IF (NZ_THIS_BLOCK > 0) THEN CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(IRHS_PTR_COPY(1), & NBCOL_INBLOC+1, & MPI_INTEGER, & MASTER, id%COMM,IERR) ENDIF C} ENDIF C C ========================================================= C INITIALIZE C - nodes_FWD and nodes_BWD C ========================================================= IF (FIRST_CALL_NODES_FWD_BWD) THEN C{ First time ZMUMPS_NODES_FWD_BWD_SIZE_FILL C is called allocated Pruned_Sons_FWD IF (allocated(Pruned_Sons_FWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_FWD) * K34_8 DEALLOCATE(Pruned_Sons_FWD) ENDIF IF (allocated(Pruned_Sons_BWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_BWD) * K34_8 DEALLOCATE(Pruned_Sons_BWD) ENDIF ALLOCATE (Pruned_Sons_FWD(KEEP(28)), & Pruned_Sons_BWD(KEEP(28)), & stat=allocok) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)= 2*KEEP(28) ELSE NB_BYTES = NB_BYTES + & int(size(Pruned_Sons_FWD),8)*K34_8 + & int(size(Pruned_Sons_BWD),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C} ENDIF C ===================== ERROR handling and propagation ============== CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C===================================================================== C Reset FIRST_CALL_NODES_FWD_BWD for not allocating C (Pruned_Sons_FWD/BWD within loop) FIRST_CALL_NODES_FWD_BWD = .FALSE. C IF (CALL_NODES_FWD_BWD) THEN C{ fill = .FALSE. nodes_FWD_PTR => IDUMMY_TARGET Lnodes_FWD_PTR = 1 nodes_BWD_PTR => IDUMMY_TARGET Lnodes_BWD_PTR = 1 CALL ZMUMPS_NODES_FWD_BWD_SIZE_FILL ( & fill, id%ICNTL(1), & id%N, id%KEEP(28), id%KEEP(1), & id%STEP(1), id%Step2node(1), & IRHS_loc_PTR(1), id%Nloc_RHS, & IRHS_PTR_COPY(1), NBCOL_INBLOC, IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, PERM_RHS, size(PERM_RHS), JBEG_RHS, & UNS_PERM_INV, size(UNS_PERM_INV), ! size 1 if not used & ICNTL21, & id%MYID, id%COMM, & id%INFO, & Pruned_Sons_FWD, Pruned_Sons_BWD, & Lnodes_FWD, Lnodes_BWD & , nodes_FWD_PTR(1), nodes_BWD_PTR(1) & , Lnodes_FWD_PTR, Lnodes_BWD_PTR & ) C C ALLOCATE nodes_FWD and nodes_BWD if needed C IF (Lnodes_FWD.GT.0) THEN C NBT is inout in MUMPS_REALLOC and should be initialized. NBT = 0 CALL MUMPS_REALLOC(nodes_FWD, Lnodes_FWD, id%INFO, LP, & FORCE=.FALSE., & STRING='nodes_FWD', MEMCNT=NBT, ERRCODE=-13) IF (INFO(1).LT.0) GOTO 46 C nodes_FWD_PTR => nodes_FWD Lnodes_FWD_PTR = Lnodes_FWD NB_BYTES = NB_BYTES + NBT NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE nodes_FWD_PTR => IDUMMY_TARGET Lnodes_FWD_PTR = 1 ENDIF IF (Lnodes_BWD.GT.0) THEN C NBT is inout in MUMPS_REALLOC and should be initialized. NBT = 0 CALL MUMPS_REALLOC(nodes_BWD, Lnodes_BWD, id%INFO, LP, & FORCE=.FALSE., & STRING='nodes_BWD', MEMCNT=NBT, ERRCODE=-13) IF (INFO(1).LT.0) GOTO 46 C nodes_BWD_PTR => nodes_BWD Lnodes_BWD_PTR = Lnodes_BWD NB_BYTES = NB_BYTES + NBT NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE nodes_BWD_PTR => IDUMMY_TARGET Lnodes_BWD_PTR = 1 ENDIF C C ===================== ERROR handling and propagation ============== 46 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C===================================================================== IF (Lnodes_FWD.GT.0 .OR. Lnodes_BWD.GT.0) THEN C{ C we build nodes_FWD_PTR and/or nodes_BWD_PTR C that will be used to prune flops C and even if one of the steps FWD/BWD does not C lead to pruning (in this case C POSTINRHS_COMP will not benefit from pruning). fill = .TRUE. CALL ZMUMPS_NODES_FWD_BWD_SIZE_FILL ( & fill, id%ICNTL(1), & id%N, id%KEEP(28), id%KEEP(1), & id%STEP(1), id%Step2node(1), & IRHS_loc_PTR(1), id%Nloc_RHS, & IRHS_PTR_COPY(1), NBCOL_INBLOC, IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, PERM_RHS, size(PERM_RHS), JBEG_RHS, & UNS_PERM_INV, size(UNS_PERM_INV), ! size 1 if not used & ICNTL21, & id%MYID, id%COMM, & id%INFO, & Pruned_Sons_FWD, Pruned_Sons_BWD, & Lnodes_FWD, Lnodes_BWD & , nodes_FWD_PTR(1), nodes_BWD_PTR(1) & , Lnodes_FWD_PTR, Lnodes_BWD_PTR & ) C} ENDIF C ------------------------------------------------ C Update CALL_NODES_FWD_BWD and free workspace if C not used again in loop of RHS C ------------------------------------------------ IF ( & (KEEP(237) .NE. 0).OR. ! AM1 & ((KEEP(235) .NE. 0).AND.KEEP(248).NE.-1) ! GS & ) THEN C target nodes for chain pruning C need be updated in case of AM1 or General Sparse CALL_NODES_FWD_BWD = .TRUE. ELSE C all other cases including C distributed RHS and distributed solution CALL_NODES_FWD_BWD = .FALSE. ENDIF IF (.NOT. CALL_NODES_FWD_BWD & ) THEN C Not needed anymore in the loop of RHS IF (allocated(Pruned_Sons_FWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_FWD) * K34_8 DEALLOCATE(Pruned_Sons_FWD) ENDIF IF (allocated(Pruned_Sons_BWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_BWD) * K34_8 DEALLOCATE(Pruned_Sons_BWD) ENDIF C ELSE C deallocate later ENDIF C} ENDIF C ========================================================= C INITIALIZE C - GLOB2LOC_RHS/SOL, RHSINTR and related data C - For distributed RHS, initialize RHSMAPINFO (at 1st block) C ========================================================= C C Fwd in facto: in this case only POSINRHSINTR need be computed C C (GLOB2LOC_RHS/SOL indirection arrays should C have been allocated once outside loop) C Compute size of RHSINTR since it might depend C on the process index and of the sparsity of the RHS C if it is exploited. C Initialize GLOB2LOC_RHS/SOL C C Note that id%LD_RHSINTR and id%KEEP8(25) C are not set on the host in this routine in C the case of a non-working host. C Note that POSINRHSINTR is now always computed in SOL_DRIVER C at least during the first block of RHS when sparsity of RHS C is not exploited. C ------------------------------- C INITTIALZE GLOB2LOC_RHS/SOL C ------------------------------- C C next block ok for Schur only IF ( KEEP(221).EQ.2 .AND. KEEP(252).EQ.0 & .AND. (KEEP(248).NE.1 .OR. (id%NRHS.EQ.1)) & ) THEN C Reduced RHS (Schur feature) was already computed during C a previous forward step AND is valid. C By valid we mean: C -no forward in facto (KEEP(252)==0) during which C POSINRHSINTR was not computed C AND C -no exploit sparsity with multiple RHS C because in this case POSINRHSINTR would C be valid only for the last block processed during fwd. C In those cases since we only perform the backward step, c we do not need to compute POSINRHSINTR BUILD_POSINRHSINTR = .FALSE. ENDIF C ------------------------ C INITIALIZE POSINRHSINTR C ------------------------ IF (BUILD_POSINRHSINTR) THEN C{ -- we first set MTYPE_LOC and C -- reset BUILD_POSINRHSINTR for next iteration in loop C C general case only POSINRHSINTR is computed BUILD_POSINRHSINTR = .FALSE. ! POSINRHSINTR does not change between blocks MTYPE_LOC = MTYPE C IF ( (KEEP(111).NE.0) .OR. (KEEP(237).NE.0) .OR. & (KEEP(252).NE.0) ) THEN C IF (KEEP(111).NE.0) THEN C -- in the context of null space, we need to C -- build RHSINTR to skip SOL_R. Therefore C -- we need to know for each concerned C -- row index its position in C -- RHSINTR C We use row indices, as these are the ones that C were used to detect zero pivots during factorization. C GLOB2LOC_RHS will allow to find the (row) index of a C zero in RHSINTR before calling ZMUMPS_SOL_S. Then C ZMUMPS_SOL_S uses column indices to build the solution C (corresponding to null space vectors) MTYPE_LOC = 1 ELSE IF (KEEP(252).NE.0) THEN C -- Fwd in facto: since fwd is skipped we need to build POSINRHSINTR MTYPE_LOC = 1 ! (no transpose) ELSE C -- A-1 only MTYPE_LOC = MTYPE BUILD_POSINRHSINTR = .TRUE. ENDIF ENDIF C -- compute POSINRHSINTR LIW_PASSED=max(1,LIW) IF ( C no sparsity at fwd or bwd: & (Lnodes_FWD.EQ.-1).OR.(Lnodes_BWD.EQ.-1) C & ) THEN C C RHSINTR is not sparse (in the sense that it has N rows C distributed on the MPI procs) and thus POSINRHSINTR C does not change with loop. C Remarks: C 1/ sparsity might still be exploited during C fwd or bwd to reduce the number of operations. C 2/ BUILD_POSINRHSINTR = .FALSE. C IF ( I_AM_SLAVE ) THEN C{ CALL ZMUMPS_BUILD_GLOB2LOC( & 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%GLOB2LOC_RHS(1), id%GLOB2LOC_SOL(1), & id%GLOB2LOC_SOL_ALLOC, & MTYPE_LOC, & NBENT_RHSINTR, NB_FS_RHSINTR_TOT ) NB_FS_RHSINTR_F = NB_FS_RHSINTR_TOT C} ENDIF C ELSE C C Note that POSINRHSINTR* need not be recomputed before IR : C because distributed solution => NO IR. C C Exploit sparsity in solution and RHS C (AM1 or (Sparse RHS and solution) ) C Since sparsity is exploited during C both fwd and bwd then we need to recompute C POSINRHSINTR only when CALL_NODES_FWD_BWD will C be performed at next iteration. IF (CALL_NODES_FWD_BWD) BUILD_POSINRHSINTR = .TRUE. C IF ( I_AM_SLAVE ) THEN C{ CALL ZMUMPS_BUILD_GLOB2LOC_NODES_ES( & id%NSLAVES,id%N, & id%MYID_NODES, id%PTLUST_S(1), id%DAD_STEPS(1), & id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), id%IS(1), LIW, & id%STEP(1), C & Lnodes_FWD, Lnodes_BWD, & nodes_FWD_PTR(1), nodes_BWD_PTR(1), C & id%GLOB2LOC_RHS(1), id%GLOB2LOC_SOL(1), & id%GLOB2LOC_SOL_ALLOC, & MTYPE_LOC, & NBENT_RHSINTR, & NB_FS_RHSINTR_F, NB_FS_RHSINTR_TOT & ) C} ENDIF ENDIF C} ENDIF ! BUILD_POSINRHSINTR=.TRUE. IF (BUILD_RHSMAPINFO .AND. KEEP(248).EQ.-1 & ) THEN C C Prepare symbolic data for sends. C For the moment: only MAP_RHS_loc C C id%GLOB2LOC_RHS is always associated to the C forward step (with or without transposed system) IF ( I_AM_SLAVE ) THEN C{ CALL MUMPS_SOL_RHSMAPINFO( id%N, id%Nloc_RHS, id%KEEP(89), & IRHS_loc_PTR(1), MAP_RHS_loc, id%GLOB2LOC_RHS(1), & id%NSLAVES, id%MYID_NODES, & id%COMM_NODES, id%ICNTL(1), id%INFO(1) ) BUILD_RHSMAPINFO = .FALSE. C MUMPS_SOL_RHSMAPINFO does not propagate errors C} ENDIF ! I_AM_SLAVE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF ( BUILD_SCALING_RHSINTR ) THEN C{ IF (SCALING_RHSINTR_BWD_ALLOCATED) THEN NB_BYTES = NB_BYTES - LSCALING_RHSINTR_BWD * K16_8 DEALLOCATE(SCALING_RHSINTR_BWD) ENDIF IF (SCALING_RHSINTR_FWD_ALLOCATED) THEN NB_BYTES = NB_BYTES - LSCALING_RHSINTR_FWD * K16_8 DEALLOCATE(SCALING_RHSINTR_FWD) ENDIF NULLIFY(SCALING_RHSINTR_BWD) NULLIFY(SCALING_RHSINTR_FWD) SCALING_RHSINTR_BWD_ALLOCATED = .FALSE. SCALING_RHSINTR_FWD_ALLOCATED = .FALSE. SCALING_RHSINTR_BWD => RDUMMY_TARGET SCALING_RHSINTR_FWD => RDUMMY_TARGET LSCALING_RHSINTR_BWD = 1 LSCALING_RHSINTR_FWD = 1 C Define or allocate SCALING_RHSINTR if needed: IF (LSCAL .AND. I_AM_SLAVE ) THEN IF (KEEP(221).EQ.2) THEN C In case of sparsity during bwd, we cannot C rely on the value of Lnodes_FWD to know C whether the scaling will match SCALING_LOC C and should thus consider that (Lnodes_FWD.NE.-1) ES_RHSINTR = (Lnodes_BWD.NE.-1) ELSE C sparsity at fwd and at bwd: ES_RHSINTR = (Lnodes_FWD.NE.-1).AND.(Lnodes_BWD.NE.-1) ENDIF C Scaling allocations performed only if needed C Forward or normal solve: IF ( ES_RHSINTR ) THEN LSCALING_RHSINTR_FWD = max(1, NB_FS_RHSINTR_F ) ALLOCATE(SCALING_RHSINTR_FWD(LSCALING_RHSINTR_FWD), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=LSCALING_RHSINTR_FWD ELSE SCALING_RHSINTR_FWD_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + LSCALING_RHSINTR_FWD * K16_8 ENDIF ELSE C RHSINTR matches SCALING_loc, no need to C allocate and compute a different scaling LSCALING_RHSINTR_FWD = max(1,KEEP(89)) #if defined(USE_OLD_SCALING) #else SCALING_RHSINTR_FWD => SCALING_LOC_FWD #endif ENDIF IF (ES_RHSINTR) THEN LSCALING_RHSINTR_BWD = max(1, NB_FS_RHSINTR_TOT ) ALLOCATE(SCALING_RHSINTR_BWD(LSCALING_RHSINTR_BWD), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=LSCALING_RHSINTR_BWD ELSE SCALING_RHSINTR_BWD_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + LSCALING_RHSINTR_BWD * K16_8 ENDIF ELSE C RHSINTR matches SCALING_loc, no need to C allocate and compute a different scaling LSCALING_RHSINTR_BWD = max(1,KEEP(89)) #if defined(USE_OLD_SCALING) SCALING_RHSINTR_BWD => scaling_data_sol%SCALING_LOC #else SCALING_RHSINTR_BWD => SCALING_LOC_BWD SCALING_RHSINTR_FWD => SCALING_LOC_FWD #endif ENDIF ENDIF C} ENDIF CALL MUMPS_PROPINFO( id%ICNTL, id%INFO, id%COMM,id%MYID) IF (id%INFO(1) .LT.0 ) GOTO 90 IF (BUILD_SCALING_RHSINTR) THEN C{ IF ( LSCAL .AND. I_AM_SLAVE. AND. ES_RHSINTR ) THEN #if ! defined(USE_OLD_SCALING) C SCALING_RHSINTR_FWD has been allocated and should C now be filled. It is a compressed version of the C local scaling array SCALING_LOC_FWD: IF (MTYPE.eq.0 .AND. KEEP(50).EQ.0) THEN ! tranpose ROWORCOL = 2 ! access 2nd list -- col indices ELSE ROWORCOL = 1 ! access 1st list -- row indices ENDIF CALL ZMUMPS_SCALINGRHSINTR(LSCAL, id%N, & SCALING_LOC_FWD(1), & SCALING_RHSINTR_FWD(1), & LSCALING_RHSINTR_FWD, id%GLOB2LOC_RHS(1), & id%KEEP, ROWORCOL, id%PTLUST_S(1), & id%IS(1), max(1,LIW), & id%MYID_NODES, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES) C SCALING_RHSINTR_BWD has been allocated and should C now be filled. It is a compressed version of the C local scaling array SCALING_LOC_BWD: IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN ! no tranpose C access 2nd list corresponding to col indices ROWORCOL = 2 ELSE C access 1st list corresponding to row indices ROWORCOL = 1 ENDIF CALL ZMUMPS_SCALINGRHSINTR(LSCAL, id%N, & SCALING_LOC_BWD(1), & SCALING_RHSINTR_BWD(1), & LSCALING_RHSINTR_BWD, id%GLOB2LOC_SOL(1), & id%KEEP, ROWORCOL, id%PTLUST_S(1), & id%IS(1), max(1,LIW), & id%MYID_NODES, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES) #endif #if defined(USE_OLD_SCALING) #endif ENDIF C Rebuild SCALING_RHSINTR* next time C only if POSINRHSINTR has to be built C again next time: BUILD_SCALING_RHSINTR= BUILD_POSINRHSINTR C} ENDIF IF (I_AM_SLAVE) THEN IF ((KEEP(221).EQ.1).OR.KEEP(221).EQ.-1) THEN C For the following cases: C -[Schur] we need to save the reduced RHS for all RHS C to perform later the backward phase with an C updated reduced RHS C -[Fwd only] return RHSINTR to user C -KEEP(221)=-1, allocate RHSINTR to enable bwd only step C We need to allocate NRHS_NONEMPTY columns in one shot. C Note that C -RHSINTR might have been allocated in previous block C -RHSINTR has been deallocated previous to entering C loop on RHS IF (.not. associated(id%RHSINTR)) THEN C So far we cannot combine this to exploit sparsity C so that NBENT_RHSINTR will not change in the loop C and can be used to dimension RHSINTR C C Furthermore, during bwd phase the REDRHS provided C by the user might also have a different non empty C column pattern than the sparse RHS provided on input to C this phase: thus we need to allocate id%NRHS columns too. id%LD_RHSINTR = max(NBENT_RHSINTR,1) id%KEEP8(25) = int(id%LD_RHSINTR,8)*int(id%NRHS,8) ALLOCATE (id%RHSINTR(id%KEEP8(25)), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(25),INFO(2)) id%KEEP8(25)=0_8 GOTO 41 END IF NB_BYTES = NB_BYTES + id%KEEP8(25)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C C IF ((KEEP(221).NE.1).AND. & ((KEEP(221).NE.2).OR.(KEEP(252).NE.0)) & ) THEN C ------------------ C Allocate RHSINTR C (case of RHSINTR allocated at each block of RHS) C ------------------ C RHSINTR allocated per block of maximum size NBRHS C NBRHS_EFF could be used instead on NBRHS IF (associated(id%RHSINTR)) THEN C RHSINTR already associated for previous C block, check if we can reuse it. id%LD_RHSINTR = max(NBENT_RHSINTR, 1) IF (id%KEEP8(25).LT.int(id%LD_RHSINTR,8)*int(NBRHS,8)) & THEN ! deallocate and reallocate since larger array is needed NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25) = 0_8 id%LD_RHSINTR = 0 ENDIF ENDIF IF (.not. associated(id%RHSINTR)) THEN id%LD_RHSINTR = max(NBENT_RHSINTR, 1) id%KEEP8(25) = int(id%LD_RHSINTR,8)*int(NBRHS,8) ALLOCATE (id%RHSINTR(id%KEEP8(25)), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(25),INFO(2)) GOTO 41 END IF NB_BYTES = NB_BYTES + id%KEEP8(25)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C C Shift on RHSINTR C IF ( KEEP(221).EQ.0 ) THEN C -- RHSINTR reused in the loop IBEG_RHSINTR= 1_8 ELSE C Initialize IBEG_RHSINTR C IBEG_RHSINTR= int(JBEG_RHS-1,8)*int(id%LD_RHSINTR,8)+1_8 ENDIF ENDIF ! I_AM_SLAVE C ===================== ERROR handling and propagation ================ 41 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C C --------------------------- C Prepare RHS on master (case C of dense and sparse RHS) C --------------------------- IF (id%MYID .eq. MASTER & ) THEN C ========================= IF (KEEP(23) .NE. 0) THEN C ========================= * maximum transversal was performed IF (MTYPE .NE. 1) THEN * At x = b is asked while * we have AP = LU where P is the column permutation * due to max trans. * Therefore we need to modify rhs: * b' = P-1 b (P-1=Pt) * Apply column permutation to the right hand side RHS * Column J of the permuted matrix corresponds to * column PERMW(J) of the original matrix. * IF (KEEP(248)==0) THEN C ========= C DENSE RHS : permute values in RHS C ========= ALLOCATE( C_RW2( id%N ),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating C_RW2 in ZMUMPS_SOLVE_DRIVE' END IF GOTO 30 END IF C We directly permute in id%RHS. DO K = 1, NBRHS_EFF KDEC = IBEG+int(K-1,8)*int(LD_RHS,8) DO I = 1, id%N C_RW2(I)=id%RHS(I-1+KDEC) END DO DO I = 1, id%N JPERM = id%UNS_PERM(I) id%RHS(I-1+KDEC) = C_RW2(JPERM) END DO END DO DEALLOCATE(C_RW2) ENDIF ENDIF ENDIF C IF (POSTPros) THEN IF ( KEEP(248) == 0 ) THEN DO K = 1, NBRHS_EFF KDEC = IBEG+int(K-1,8)*int(LD_RHS,8) DO I = 1, id%N SAVERHS(I+(K-1)*id%N) = id%RHS(KDEC+I-1) END DO ENDDO ELSE IF (KEEP(248)==1) THEN SAVERHS(:) = ZERO DO K = 1, NBRHS DO J = id%IRHS_PTR(K), id%IRHS_PTR(K+1)-1 I = id%IRHS_SPARSE(J) SAVERHS(I+(K-1)*id%N) = id%RHS_SPARSE(J) ENDDO ENDDO ENDIF ENDIF #if defined(USE_OLD_SCALING) C C RHS is set to scaled right hand side C (case of centralized scaling only) C IF (LSCAL) THEN C scaling was performed IF (KEEP(248)==0) THEN C dense RHS IF (MTYPE .EQ. 1) THEN C we solve Ax=b, use ROWSCA to scale the RHS DO K =1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHS,8) + int(IBEG-1,8) DO I = 1, id%N id%RHS(KDEC+I) = id%RHS(KDEC+I) * & id%ROWSCA(I) ENDDO ENDDO ELSE C we solve Atx=b, use COLSCA to scale the RHS DO K =1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHS,8) + int(IBEG-1,8) DO I = 1, id%N id%RHS(KDEC+I) = id%RHS(KDEC+I) * & id%COLSCA(I) ENDDO ENDDO ENDIF ELSE IF (KEEP(248)==1) THEN C ------------------------- C KEEP(248)==1 (and MASTER) C ------------------------- KDEC=int(id%IRHS_PTR(JBEG_RHS),8) C Compute IF ((KEEP(248)==1) .AND. & (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) & ) THEN C -- copy from RHS_SPARSE need be done per C column following PERM_RHS C Columns are not contiguous and need be copied one by one IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN IPERM = PERM_RHS(I) ENDIF J = J+1 C Note that we work here on compressed IRHS_PTR_COPY COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) C -- skip empty column IF (COLSIZE .EQ. 0) CYCLE IF (id%KEEP(237).NE.0) THEN IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN C if A-1 only, then, for each non empty target C column PERM_RHS(I), scale in first position C in column the diagonal entry C build the scaled rhs ej on each slave. RHS_SPARSE_COPY(IPOS) = id%ROWSCA(IPERM) * & ONE ELSE RHS_SPARSE_COPY(IPOS) = id%ROWSCA(I) * ONE ENDIF ELSE C Loop over nonzeros in column DO K = 1, COLSIZE C Formula for II below is ok, except in case C of maximum transversal (KEEP(23).NE.0) and C transpose system (MTYPE .NE. 1): C II = id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K-1) C In case of maximum transversal + transpose, one C should then apply II=UNS_PERM_INV(II) after the C above definition of II. C C Instead, we rely on IRHS_SPARSE_COPY, whose row C indices have already been permuted in case of C maximum transversal. II = IRHS_SPARSE_COPY( & IRHS_PTR_COPY(I-JBEG_RHS+1) & +K-1) C PERM_RHS(I) corresponds to column in original RHS. C Original IRHS_PTR must be used to access id%RHS_SPARSE IF (MTYPE.EQ.1) THEN RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(IPERM)+K-1)* & id%ROWSCA(II) ELSE RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(IPERM)+K-1)* & id%COLSCA(II) ENDIF ENDDO ENDIF IPOS = IPOS + COLSIZE ENDDO ELSE ! general sparse RHS ! without permutation IF (MTYPE .eq. 1) THEN DO IZ=1,NZ_THIS_BLOCK I=IRHS_SPARSE_COPY(IZ) RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* & id%ROWSCA(I) ENDDO ELSE DO IZ=1,NZ_THIS_BLOCK I=IRHS_SPARSE_COPY(IZ) RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* & id%COLSCA(I) ENDDO ENDIF ENDIF ENDIF ! KEEP(248)==1 ENDIF ! LSCAL #endif ENDIF ! id%MYID.EQ.MASTER #if defined(V_T) CALL VTEND(perm_scal_ini,IERR) #endif C C Prepare RHS on master C END C ===================== C ----------------------------------- C Two main cases depending on option C for null space computation: C C KEEP(111)=0 : use RHS from user C (sparse or dense) C KEEP(111)!=0: build an RHS on each C proc for null space C computations C ----------------------------------- #if defined(V_T) CALL VTBEGIN(soln_dist,IERR) #endif TIMESCATTER1=MPI_WTIME() IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0) & .AND.(KEEP(221).NE.2 )) THEN C{ ------------------------ C Use RHS provided by user C when not null space and not Fwd in facto C ------------------------ IF (KEEP(248) == 0) THEN C ---------------------------- C -- DENSE RIGHT-HAND-SIDE C ---------------------------- IF ( .NOT.I_AM_SLAVE ) THEN C -- Master not working CALL ZMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, LSCAL, SCALING_LOC_FWD(1), & MTYPE, id%RHS(IBEG), LD_RHS, NBRHS_EFF, & NBRHS_EFF, & C_DUMMY, 1, 1, & IDUMMY, 0, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ELSE IF (id%MYID .eq. MASTER) THEN PTR_RHS => id%RHS LD_RHS_loc = LD_RHS NCOL_RHS_loc = NBRHS_EFF IBEG_loc = IBEG ELSE PTR_RHS => CDUMMY_TARGET LD_RHS_loc = 1 NCOL_RHS_loc = 1 IBEG_loc = 1_8 ENDIF LIW_PASSED = max( LIW, 1 ) CALL ZMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, LSCAL, SCALING_LOC_FWD(1), & MTYPE, PTR_RHS(IBEG_loc),LD_RHS_loc,NCOL_RHS_loc, & NBRHS_EFF, & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, NBRHS_EFF, & id%GLOB2LOC_RHS(1), NB_FS_RHSINTR_F, C & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).LT.0) GOTO 90 ELSE IF (KEEP(248) .EQ. -1) THEN IF (I_AM_SLAVE) THEN IF (id%Nloc_RHS .NE. 0) THEN RHS_loc_size=int(id%LRHS_loc,8)*int(NBRHS_EFF-1,8)+ & int(id%Nloc_RHS,8) RHS_loc_shift=1_8+int(BEG_RHS-1,8)*id%LRHS_loc ELSE RHS_loc_size=1_8 RHS_loc_shift=1_8 ENDIF CALL ZMUMPS_SCATTER_DIST_RHS(id%NSLAVES, id%N, & id%MYID_NODES, id%COMM_NODES, & NBRHS_EFF, id%Nloc_RHS, id%LRHS_loc, & MAP_RHS_loc, & IRHS_loc_PTR(1), & idRHS_loc(RHS_loc_shift), & RHS_loc_size, & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, & id%GLOB2LOC_RHS(1), NB_FS_RHSINTR_F, & LSCAL, #if defined(USE_OLD_SCALING) & scaling_data_dr, #else & SCALING_RHSINTR_FWD(1), LSCALING_RHSINTR_FWD, #endif & LP, LPOK, KEEP(1), NB_BYTES_LOC, INFO(1)) C NB_BYTES_LOC were allocated and freed above NB_BYTES_MAX = max(NB_BYTES_MAX, & NB_BYTES_MAX+NB_BYTES_LOC) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).LT.0) GOTO 90 ELSE C === KEEP(248)==1 ========= C -- SPARSE RIGHT-HAND-SIDE C ---------------------------- IF (NZ_THIS_BLOCK > 0 #if ! defined(USE_OLD_SCALING) C For AM1, no need to broadcast RHS_SPARSE C when using local scalings. RHSINTR will C be initialized directly and RHS_SPARSE C is used during ZMUMPS_GATHER_SOLUTION_AM1 & .AND. id%KEEP(237) .EQ.0 #endif & ) THEN CALL MPI_BCAST(RHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_DOUBLE_COMPLEX, & MASTER, id%COMM, IERR) ENDIF C IF (KEEP(237).NE.0) THEN IF ( I_AM_SLAVE ) THEN C ----- C case of A-1 C ----- C - Take columns with non-zero entry, say j, C - to build Ej and store it in RHSINTR K=1 ! Column index in RHSINTR id%RHSINTR(1_8:int(NBRHS_EFF,8)*int(id%LD_RHSINTR,8)) & = ZERO IPOS = 1 DO I = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) IF (COLSIZE.GT.0) THEN ! Find global column index J and set ! column K of RHSINTR to ej (here IBEG is one) J = I - 1 + JBEG_RHS IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN J = PERM_RHS(J) ENDIF IPOSRHSINTR = id%GLOB2LOC_RHS(J) C IF ( (IPOSRHSINTR.LE.NB_FS_RHSINTR_F) C & .AND.(IPOSRHSINTR.GT.0) ) THEN IF (IPOSRHSINTR.GT.0) THEN C Columns J corresponds to ej and thus to variable j C that is on my proc. C We know that only one entry is needed, C the diagonal entry (for the forward with A-1). C #if defined(USE_OLD_SCALING) id%RHSINTR(int(K-1,8)*int(id%LD_RHSINTR,8)+ & int(IPOSRHSINTR,8)) = & RHS_SPARSE_COPY(IPOS) #else IF (LSCAL) THEN id%RHSINTR(int(K-1,8)*int(id%LD_RHSINTR,8)+ & int(IPOSRHSINTR,8)) = & SCALING_RHSINTR_FWD(IPOSRHSINTR) ELSE id%RHSINTR(int(K-1,8)*int(id%LD_RHSINTR,8)+ & int(IPOSRHSINTR,8)) = ONE ENDIF #endif ENDIF ! End of J on my proc K = K + 1 IPOS = IPOS + COLSIZE ! go to next column ENDIF ENDDO IF (K.NE.NBRHS_EFF+1) THEN WRITE(6,*) 'Internal Error 9 in solution driver ', & K,NBRHS_EFF call MUMPS_ABORT() ENDIF ENDIF ! I_AM_SLAVE C ------- c END A-1 C ------- ELSE C -------------- C General sparse C -------------- C -- At this point each process has a copy of the C -- sparse RHS. We need to store it into RHSINTR. C -- reset to zero RHSINTR for skipped columns (if any) IF ((KEEP(221).EQ.1).AND.(NB_RHSSKIPPED.GT.0) & .AND.I_AM_SLAVE) THEN DO K = JBEG_RHS-NB_RHSSKIPPED, JBEG_RHS-1 DO I = 1, id%LD_RHSINTR id%RHSINTR(int(K-1,8)*int(id%LD_RHSINTR,8) & + int(I,8)) = ZERO ENDDO ENDDO ENDIF IF (I_AM_SLAVE) THEN DO K = 1, NBCOL_INBLOC ! it is equal to NBRHS_EFF in this case KDEC = int(K-1,8) * int(id%LD_RHSINTR,8) + & IBEG_RHSINTR - 1_8 id%RHSINTR(KDEC+1_8:KDEC+NBENT_RHSINTR) = ZERO #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 I=IRHS_SPARSE_COPY(IZ) IPOSRHSINTR = id%GLOB2LOC_RHS(I) C Since all fully summed variables mapped C on each proc are stored at the beginning C of RHSINTR, we can compare to KEEP(89) C to know if RHSINTR should be initialized C So far the tree has not been pruned to exploit C sparsity to compress RHSINTR so we compare to C NB_FS_RHSINTR_TOT IF ( (IPOSRHSINTR.LE.NB_FS_RHSINTR_TOT) & .AND.(IPOSRHSINTR.GT.0) ) THEN C ! I is fully summed var mapped on my proc id%RHSINTR(KDEC+IPOSRHSINTR)= & id%RHSINTR(KDEC+IPOSRHSINTR) + & RHS_SPARSE_COPY(IZ) & * SCALING_RHSINTR_FWD(IPOSRHSINTR) ENDIF ENDDO ELSE #endif DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 I=IRHS_SPARSE_COPY(IZ) IPOSRHSINTR = id%GLOB2LOC_RHS(I) C Since all fully summed variables mapped C on each proc are stored at the beginning C of RHSINTR, we can compare to KEEP(89) C to know if RHSINTR should be initialized C So far the tree has not been pruned to exploit C sparsity to compress RHSINTR so we compare to C NB_FS_RHSINTR_TOT IF ( (IPOSRHSINTR.LE.NB_FS_RHSINTR_TOT) & .AND.(IPOSRHSINTR.GT.0) ) THEN C ! I is fully summed var mapped on my proc id%RHSINTR(KDEC+IPOSRHSINTR)= & id%RHSINTR(KDEC+IPOSRHSINTR) + & RHS_SPARSE_COPY(IZ) ENDIF ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif ENDDO END IF ! I_AM_SLAVE ENDIF ! KEEP(237) ENDIF ! ==== KEEP(248)==1 ===== C} ELSE IF (I_AM_SLAVE) THEN ! I_AM_SLAVE AND (null space or Fwd in facto) IF (KEEP(111).NE.0) THEN C{ ----------------------- C Null space computations C ----------------------- C C We are working on columns BEG_RHS:BEG_RHS+NBRHS_EFF-1 C of RHS. C Columns in 1..KEEP(112): C Put a one in corresponding C position of the right-hand-side, C and zeros in other places. C Columns in KEEP(112)+1: KEEP(112)+KEEP(17): C root node => set C 0 everywhere and compute the local range C corresponding to IBEG/IEND in root C that will be passed to ZMUMPS_SEQ_SOLVE_ROOT_RR C Also keep track of which part of C ZMUMPS_RHS must be passed to C ZMUMPS_SEQ_SOLVE_ROOT_RR. C IF (KEEP(111).GT.0) THEN IBEG_GLOB_DEF = KEEP(111) IEND_GLOB_DEF = KEEP(111) ELSE IBEG_GLOB_DEF = BEG_RHS IEND_GLOB_DEF = BEG_RHS+NBRHS_EFF-1 ENDIF IF ( id%KEEP(112) .GT. 0 .AND. DO_NULL_PIV) THEN IF (IBEG_GLOB_DEF .GT.id%KEEP(112)) THEN id%KEEP(235) = 0 DO_NULL_PIV = .FALSE. ENDIF IF (IBEG_GLOB_DEF .LT.id%KEEP(112) & .AND. IEND_GLOB_DEF .GT.id%KEEP(112) & .AND. DO_NULL_PIV ) THEN C IEND_GLOB_DEF = id%KEEP(112) C forcing exploit sparsity C - cannot be done at this point C - and is not what the user would have expected the C code to to do anyway !!!! C suppress: id%KEEP(235) = 1 ! End Block of sparsity ON DO_NULL_PIV = .FALSE. ENDIF ENDIF IF (id%KEEP(235).NE.0) THEN C Exploit Sparsity in null space computations C We build /allocate the sparse RHS on MASTER C based on pivnul_list. Then we broadcast it C on the slaves C In this case we have ONLY ONE ENTRY per RHS C NZ_THIS_BLOCK=IEND_GLOB_DEF-IBEG_GLOB_DEF+1 ALLOCATE(IRHS_PTR_COPY(NZ_THIS_BLOCK+1),stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 50 ENDIF IRHS_PTR_COPY_ALLOCATED = .TRUE. ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK),stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 50 ENDIF IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + & int(NZ_THIS_BLOCK,8)*(K34_8+K34_8) & + K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.eq.MASTER) THEN ! compute IRHS_PTR and IRHS_SPARSE_COPY II = 1 DO I = IBEG_GLOB_DEF, IEND_GLOB_DEF IRHS_PTR_COPY(I-IBEG_GLOB_DEF+1) = I IRHS_SPARSE_COPY(II) = id%PIVNUL_LIST(I) II = II +1 ENDDO IRHS_PTR_COPY(NZ_THIS_BLOCK+1) = NZ_THIS_BLOCK+1 ENDIF C C ===================== ERROR handling and propagation ================ 50 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(IRHS_PTR_COPY(1), & NZ_THIS_BLOCK+1, & MPI_INTEGER, & MASTER, id%COMM,IERR) C End IF Exploit Sparsity ENDIF c C Initialize RHSINTR to 0 ! to be suppressed DO K=1, NBRHS_EFF KDEC = int(K-1,8) * int(id%LD_RHSINTR,8) id%RHSINTR(KDEC+1_8:KDEC+int(id%LD_RHSINTR,8))=ZERO END DO C Loop over the columns. C Note that if ( KEEP(220)+KEEP(109)-1 < IBEG_GLOB_DEF C .OR. KEEP(220) > IEND_GLOB_DEF ) then we do not enter C the loop. C Note that local processor has indices C KEEP(220):KEEP(220)+KEEP(109)-1 C C Computation of null space and computation of backward C step incompatible, do one or the other. DO I=max(IBEG_GLOB_DEF,KEEP(220)), & min(IEND_GLOB_DEF,KEEP(220)+KEEP(109)-1) C Local processor is concerned by I-th column of C global right-hand side. JJ= id%GLOB2LOC_RHS(id%PIVNUL_LIST(I-KEEP(220)+1)) IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN ! unsymmetric : always set to fixation id%RHSINTR( IBEG_RHSINTR+ & int(I-IBEG_GLOB_DEF,8)*int(id%LD_RHSINTR,8)+ & int(JJ-1,8) ) = & cmplx(id%DKEEP(2),kind=kind(id%RHSINTR)) ELSE ! Symmetric: always set to one id%RHSINTR( IBEG_RHSINTR+ & int(I-IBEG_GLOB_DEF,8)*int(id%LD_RHSINTR,8)+ & int(JJ-1,8) )= & ONE ENDIF ENDIF ENDDO IF ( KEEP(17).NE.0 .AND. & id%MYID_NODES.EQ.MASTER_ROOT) THEN C --------------------------- C Deficiency of the root node C Find range relative to root C --------------------------- C Among IBEG_GLOB_DEF:IEND_GLOB_DEF, find C intersection with KEEP(112)+1:KEEP(112)+KEEP(17) IBEG_ROOT_DEF = max(IBEG_GLOB_DEF,KEEP(112)+1) IEND_ROOT_DEF = min(IEND_GLOB_DEF,KEEP(112)+KEEP(17)) C First column of right-hand side that must C be passed to ZMUMPS_SEQ_SOLVE_ROOT_RR is: IROOT_DEF_RHS_COL1 = IBEG_ROOT_DEF-IBEG_GLOB_DEF + 1 C We look for indices relatively to the root node, C substract number of null pivots outside root node IBEG_ROOT_DEF = IBEG_ROOT_DEF-KEEP(112) IEND_ROOT_DEF = IEND_ROOT_DEF-KEEP(112) C Note that if IBEG_ROOT_DEF > IEND_ROOT_DEF, then this C means that nothing must be done on the root node C for this set of right-hand sides. ELSE IBEG_ROOT_DEF = -90999 IEND_ROOT_DEF = -95999 IROOT_DEF_RHS_COL1= 1 ENDIF C} ELSE ! End of null space (test on KEEP(111)) C case of Fwd in facto C id%RHSINTR need not be initialized. It will be set on the fly C to zero for normal fully summed variables of the fronts and C to -1 on the roots for the id%N+KEEP(253) variables added C to the roots. ENDIF ! End of null space (test on KEEP(111)) ENDIF ! I am slave TIMESCATTER2=MPI_WTIME()-TIMESCATTER1+TIMESCATTER2 IF (KEEP(221) .EQ. 2 .AND. KEEP(60).NE.0 ) THEN C Copy/send REDRHS in PTR_RHS_ROOT C (column by column if leading dimension LD_REDRHS C of REDRHS is not equal to SIZE_ROOT). C REDRHS was provided on the host IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN C -- Same proc : copy is possible: II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8)-1_8 DO I = 1, SIZE_ROOT PTR_RHS_ROOT(II+I) = id%REDRHS(KDEC+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE C -- send REDRHS IF ( id%MYID .EQ. MASTER) THEN C -- send to MASTER_ROOT_IN_COMM using COMM communicator C assert: id%KEEP(116).EQ.SIZE_ROOT IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- One send KDEC = IBEG_REDRHS CALL MPI_SEND(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_DOUBLE_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSE C -- NBRHS_EFF sends DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) CALL MPI_SEND(id%REDRHS(KDEC),SIZE_ROOT, & MPI_DOUBLE_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ENDDO ENDIF ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN C -- receive from MASTER II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- receive all in on shot CALL MPI_RECV(PTR_RHS_ROOT(II), & SIZE_ROOT*NBRHS_EFF, & MPI_DOUBLE_COMPLEX, & MASTER, 0, id%COMM,STATUS,IERR) ELSE DO K=1, NBRHS_EFF CALL MPI_RECV(PTR_RHS_ROOT(II),SIZE_ROOT, & MPI_DOUBLE_COMPLEX, & MASTER, 0, id%COMM,STATUS,IERR) II = II + SIZE_ROOT ENDDO ENDIF ENDIF C -- other procs are not concerned ENDIF ENDIF TIMEC1=MPI_WTIME() IF ( I_AM_SLAVE ) THEN C { LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) C FROM_PP = .FALSE. NBSPARSE_LOC = (DO_NBSPARSE.AND.NBRHS_EFF.GT.1) C ----------------------------------------- C Define arguments to have a single call to C SOL_C with and without exploit sparsity. C ----------------------------------------- IF (Lnodes_FWD.EQ.-1 .AND. Lnodes_BWD.EQ.-1) THEN NZ_THIS_BLOCK_ARG = 1 NBCOL_INBLOC_ARG = 1 Step2node_ARG => IDUMMY_TARGET LStep2node_ARG = 1 IRHS_SPARSE_COPY_ARG => IDUMMY_TARGET IRHS_PTR_COPY_ARG => IDUMMY_TARGET NB_FS_RHSINTR_F_ARG = 1 NB_FS_RHSINTR_TOT_ARG = 1 #if defined(STAT_ES_SOLVE) SIZE_WORKING = 1 SIZE_IPTR_WORKING = 1 idIPTR_WORKING => IDUMMY_TARGET idWORKING => IDUMMY_TARGET #endif ELSE NZ_THIS_BLOCK_ARG = NZ_THIS_BLOCK NBCOL_INBLOC_ARG = NBCOL_INBLOC Step2node_ARG => id%Step2node LStep2node_ARG = KEEP(28) IRHS_SPARSE_COPY_ARG => IRHS_SPARSE_COPY IRHS_PTR_COPY_ARG => IRHS_PTR_COPY NB_FS_RHSINTR_F_ARG = NB_FS_RHSINTR_F NB_FS_RHSINTR_TOT_ARG = NB_FS_RHSINTR_TOT #if defined(STAT_ES_SOLVE) SIZE_WORKING = 1 SIZE_IPTR_WORKING = 1 IF((KEEP(235).NE.0).OR.(KEEP(237).NE.0)) THEN IF(id%MYID.EQ.MASTER) THEN SIZE_WORKING = id%IPTR_WORKING(id%NPROCS+1)-1 SIZE_IPTR_WORKING = id%NPROCS+1 END IF ENDIF #endif ENDIF CALL ZMUMPS_SOL_C(idintr%root,idintr%roota,id%N,id%S(1), &LA_PASSED,IS(1),LIW_PASSED,WORK_WCB(1),LWCB8,IWCB,LIWCB, &NBRHS_EFF,id%NA(1),id%LNA,id%NE_STEPS(1),SRW3, MTYPE, ICNTL(1), &FROM_PP,id%STEP(1),id%FRERE_STEPS(1),id%DAD_STEPS(1),id%FILS(1), &id%PTLUST_S(1),id%PTRFAC(1),IWK_SOLVE,LIWK_SOLVE,PTRACB, &LIWK_PTRACB,id%PROCNODE_STEPS(1),id%NSLAVES,INFO(1),KEEP(1), &KEEP8(1),id%DKEEP(1),id%COMM_NODES,id%MYID,id%MYID_NODES,BUFR(1), &LBUFR,LBUFR_BYTES,id%ISTEP_TO_INIV2(1),id%TAB_POS_IN_PERE(1,1), &IBEG_ROOT_DEF,IEND_ROOT_DEF,IROOT_DEF_RHS_COL1, PTR_RHS_ROOT(1), &LPTR_RHS_ROOT,SIZE_ROOT,MASTER_ROOT,id%RHSINTR(IBEG_RHSINTR), &id%LD_RHSINTR,id%GLOB2LOC_RHS(1),id%GLOB2LOC_SOL(1), &Lnodes_FWD, Lnodes_BWD, nodes_FWD_PTR(1), nodes_BWD_PTR(1), &NZ_THIS_BLOCK_ARG, NBCOL_INBLOC_ARG, JBEG_RHS, Step2node_ARG(1), &LStep2node_ARG, IRHS_SPARSE_COPY_ARG(1), IRHS_PTR_COPY_ARG(1), &size(PERM_RHS), PERM_RHS, size(UNS_PERM_INV), UNS_PERM_INV, &NB_FS_RHSINTR_F, NB_FS_RHSINTR_TOT, NBSPARSE_LOC, &PTR_RHS_BOUNDS(1), LPTR_RHS_BOUNDS #if defined(STAT_ES_SOLVE) &,idIPTR_WORKING(1),SIZE_IPTR_WORKING,idWORKING(1),SIZE_WORKING #endif & , id%IPOOL_B_L0_OMP(1), id%LPOOL_B_L0_OMP, id%IPOOL_A_L0_OMP(1), & id%LPOOL_A_L0_OMP, id%L_VIRT_L0_OMP, id%VIRT_L0_OMP(1), & id%L_PHYS_L0_OMP, id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1), & id%PTR_LEAFS_L0_OMP(1), id%L0_OMP_MAPPING(1), id%LL0_OMP_MAPPING, & idintr%L0_OMP_FACTORS(1), id%LL0_OMP_FACTORS & ) C C ================================================================ C C } END IF ! I_AM_SLAVE C ----------------- C End of slave code C ----------------- C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) TIMEC2=MPI_WTIME()-TIMEC1+TIMEC2 C C Change error code. IF (INFO(1).eq.-2) then INFO(1)=-11 IF (LPOK) & write(LP,*) & ' WARNING : -11 error code obtained in solve' END IF IF (INFO(1).eq.-3) then INFO(1)=-14 IF (LPOK) & write(LP,*) & ' WARNING : -14 error code obtained in solve' END IF C C Return in case of error. IF (INFO(1).LT.0) GO TO 90 C C ====================================================== C ONLY FORWARD was performed (case of reduced RHS with Schur C option during factorisation) C ====================================================== IF ( (KEEP(60).NE.0) .AND. & KEEP(221) .EQ. 1 ) THEN ! === Begin OF REDUCED RHS ====== C -------------------------------------- C Send (or copy) reduced RHS from PTR_RHS_ROOT located on C MASTER_ROOT_IN_COMM to REDRHS located on MASTER (host node). C (column by column if leading dimension LD_REDRHS C of REDRHS is not equal to SIZE_ROOT) C -------------------------------------- IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN C -- same proc --> copy II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) - 1_8 DO I = 1, SIZE_ROOT id%REDRHS(KDEC+I) = PTR_RHS_ROOT(II+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE C -- recv in REDRHS IF ( id%MYID .EQ. MASTER ) THEN C -- recv from MASTER_ROOT_IN_COMM IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- One message to receive KDEC = IBEG_REDRHS CALL MPI_RECV(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_DOUBLE_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM, & STATUS,IERR) ELSE C -- NBRHS_EFF receives DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) CALL MPI_RECV(id%REDRHS(KDEC),SIZE_ROOT, & MPI_DOUBLE_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM, & STATUS,IERR) ENDDO ENDIF ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN C -- send to MASTER II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- send all in on shot CALL MPI_SEND(PTR_RHS_ROOT(II), & SIZE_ROOT*NBRHS_EFF, & MPI_DOUBLE_COMPLEX, & MASTER, 0, id%COMM,IERR) ELSE DO K=1, NBRHS_EFF CALL MPI_SEND(PTR_RHS_ROOT(II),SIZE_ROOT, & MPI_DOUBLE_COMPLEX, & MASTER, 0, id%COMM,IERR) II = II + SIZE_ROOT ENDDO ENDIF ENDIF C -- other procs are not concerned ENDIF ENDIF ! ===== END OF REDUCED RHS (Schur+Fwd only performed) == C ======================================================= C BACKWARD was PERFORMED C Postprocess solution that is distributed IF ( KEEP(221) .NE. 1 ) THEN ! BACKWARD was PERFORMED C -- KEEP(221).NE.1 => we are sure that backward has been performed IF (ICNTL21 == 0) THEN ! CENTRALIZED SOLUTION C{ ======================================================== C GATHER SOLUTION computed during bwd C Each proc holds the pieces of solution corresponding C to all fully summed variables mapped on that processor C (i.e. corresponding to master nodes mapped on that proc) C In case of A-1 we gather directly in RHS_SPARSE C the distributed solution. C Scaling is done in all case on the fly of the reception C Note that when only FORWARD has been performed C RSH_MUMPS holds the solution computed during forward step C (ZMUMPS_SOL_R) C there is no need to copy back in RSH_MUMPS the solution C ======================================================== C centralized solution IF (KEEP(237).EQ.0) THEN C CWORK not needed for AM1 LCWORK = max(max(KEEP(247),KEEP(246)),1) ALLOCATE( CWORK(LCWORK), stat=allocok ) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) ENDIF ENDIF IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & .AND. (id%NSLAVES.NE.1)) THEN C Precompute map of indices in current column C (no need to reset it between columns ALLOCATE (MAP_RHS(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) ' Problem allocation of MAP_RHS at solve' ENDIF INFO(1) = -13 INFO(2) = id%N ELSE NB_BYTES = NB_BYTES + int(id%N,8) * K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) C Return in case of error. IF (INFO(1).LT.0) GO TO 90 #if defined(USE_OLD_SCALING) 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 #endif LIW_PASSED = max( LIW, 1 ) TIMEGATHER1=MPI_WTIME() IF ( .NOT.I_AM_SLAVE ) THEN C I did not participate to computing part of the solution C (id%RHSINTR not set/allocate) : receive solution, store C it and scale it. IF (KEEP(237).EQ.0) THEN C We need a workspace of minimal size KEEP(247) C in order to unpack pieces of the solution. CALL ZMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & MTYPE, id%RHS(1), LD_RHS, id%NRHS, JBEG_RHS, & JDUMMY, id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), IDUMMY, 1, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), LCWORK, LSCAL, #if defined(USE_OLD_SCALING) & PT_SCALING(1), size(PT_SCALING), #else & SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), #endif & C_DUMMY, 1 , 1, IDUMMY, 1, & PERM_RHS, size(PERM_RHS) ! for sparse permuted RHS & ) ELSE C only gather target entries of A-1 CALL ZMUMPS_GATHER_SOLUTION_AM1(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & C_DUMMY, 1, 1, & id%KEEP(1), BUFR(1), LBUFR, LBUFR_BYTES, #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING) #else & LSCAL, SCALING_RHSINTR_BWD(1), & size(SCALING_RHSINTR_BWD) #endif C --- A-1 related entries & ,IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), & UNS_PERM_INV, size(UNS_PERM_INV), & IDUMMY, 1, 0 & ) ENDIF ELSE C Avoid temporary copy (IS(1)) that some old C compilers would do otherwise IF (KEEP(237).EQ.0) THEN IF (id%MYID.EQ.MASTER) THEN PTR_RHS => id%RHS NCOL_RHS_loc = id%NRHS LD_RHS_loc = LD_RHS JBEG_RHS_loc = JBEG_RHS ELSE PTR_RHS => CDUMMY_TARGET NCOL_RHS_loc = 1 LD_RHS_loc = 1 JBEG_RHS_loc = 1 ENDIF CALL ZMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, MTYPE, & PTR_RHS(1), LD_RHS_loc, NCOL_RHS_loc, JBEG_RHS_loc, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), IS(1), LIW_PASSED, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), LCWORK, #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING), #else & LSCAL, SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), #endif & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, NBRHS_EFF, & id%GLOB2LOC_SOL(1), id%N, & PERM_RHS, size(PERM_RHS) ! For sparse permuted RHS & ) ELSE ! only gather target entries of A-1 CALL ZMUMPS_GATHER_SOLUTION_AM1(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, NBRHS_EFF, & id%KEEP(1), BUFR(1), LBUFR, LBUFR_BYTES, #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING) #else & LSCAL, SCALING_RHSINTR_BWD(1), size(SCALING_RHSINTR_BWD) #endif C --- A-1 related entries & , IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), & UNS_PERM_INV, size(UNS_PERM_INV), & id%GLOB2LOC_SOL(1), id%N, NB_FS_RHSINTR_TOT & ) ENDIF ENDIF TIMEGATHER2=MPI_WTIME()-TIMEGATHER1+TIMEGATHER2 IF (KEEP(237).EQ.0) DEALLOCATE( CWORK ) IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & ) THEN C Copy back solution from RHS_SPARSE_COPY TO RHS_SPARSE DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN PJ = PERM_RHS(J) ELSE PJ =J ENDIF COLSIZE = id%IRHS_PTR(PJ+1) - & id%IRHS_PTR(PJ) IF (COLSIZE.EQ.0) CYCLE JJ = J-JBEG_RHS+1 C Precompute map of indices in current column C (no need to reset it between columns IF (id%NSLAVES.NE.1) THEN DO II=1, COLSIZE MAP_RHS(id%IRHS_SPARSE( & id%IRHS_PTR(PJ) + II - 1)) = II ENDDO DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 II = IRHS_SPARSE_COPY(IZ2) id%RHS_SPARSE(id%IRHS_PTR(PJ)+MAP_RHS(II)-1)= & RHS_SPARSE_COPY(IZ2) ENDDO ELSE C Entries within a column are in order C IZ - Column index in Sparse RHS DO IZ= id%IRHS_PTR(PJ), id%IRHS_PTR(PJ+1)-1 IZ2 = IRHS_PTR_COPY(JJ) + & IZ - id%IRHS_PTR(PJ) id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDIF ENDDO IF (id%NSLAVES.NE.1) THEN NB_BYTES = NB_BYTES - int(size(MAP_RHS),8) * K34_8 DEALLOCATE ( MAP_RHS ) ENDIF ENDIF ! end A-1 on master C C} -- END of backward was performed with centralized solution ELSE ! (KEEP(221).NE.1) .AND.(ICNTL21.NE.0)) C C BEGIN of backward performed with distributed solution C time local copy + scaling TIMECOPYSCALE1=MPI_WTIME() C The non working host should not do this: IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF ( KEEP(89) .GT. 0 ) THEN IF ( LSCAL .AND. id%KEEP(89).GT.0) THEN #if defined(USE_OLD_SCALING) SCALING_LOC_BWD => scaling_data_sol%SCALING_LOC #else IF (MTYPE.EQ.1) THEN SCALING_LOC_BWD => id%COLSCA_loc ELSE SCALING_LOC_BWD => id%ROWSCA_loc ENDIF #endif ELSE SCALING_LOC_BWD => RDUMMY_TARGET ENDIF CALL ZMUMPS_DISTRIBUTED_SOLUTION(id%NSLAVES, & id%N,id%MYID_NODES, & MTYPE, id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, & NBRHS_EFF, id%GLOB2LOC_SOL(1), & id%ISOL_loc(1), id%SOL_loc(1), id%NRHS, & JBEG_RHS-NB_RHSSKIPPED, id%LSOL_loc, & id%PTLUST_S(1), id%PROCNODE_STEPS(1), & id%KEEP(1),id%KEEP8(1), & IS(1), LIW_PASSED, id%STEP(1), & SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), & LSCAL, NB_RHSSKIPPED, & PERM_RHS, size(PERM_RHS) ) ! For permuted sparse RHS ENDIF ENDIF TIMECOPYSCALE2=MPI_WTIME()-TIMECOPYSCALE1+TIMECOPYSCALE2 ENDIF C === BACKWARD was PERFORMED WITH DISTRIBUTED SOLUTION === C ======================================================== ENDIF ! ==== END of BACKWARD was PERFORMED (KEEP(221).NE.1) C note that the main DO-loop on blocks is not ended yet C C ============================================ C BEGIN C C ITERATIVE REFINEMENT AND/OR ERROR ANALYSIS C C ============================================ IF ( ICNTL10 > 0 .AND. NBRHS_EFF > 1 ) THEN C C ---------------------------------- C Multiple RHS: apply a fixed number C of iterative refinement steps C ---------------------------------- C DO I = 1, ICNTL10 write(6,*) ' Internal error 15 in sol_driver ' C Compute residual: Y <- SAVERHS - A * RHS C Solve RHS <- A^-1 Y, Y modified C Assemble in RHS(REDUCE) C RHS <- RHS + Y C END DO END IF IF (POSTPros) THEN C{ C SAVERHS holds the original right hand side C Sparse rhs are saved in SAVERHS as dense rhs C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C Start iterative refinements. The master is managing the C organisation of work, but slaves are used to solve systems of C equations and, in case of distributed matrix, perform C matrix-vector products. It is more complicated to do this with C the SPMD version than it was with the master/slave approach. C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * c IF ( PROK .AND. ICNTL10 .NE. 0 ) WRITE( MP, 270 ) IF ( PROKG .AND. ICNTL10 .NE. 0 ) WRITE( MPG, 270 ) C Initializations and allocations NITREF = abs(ICNTL10) ALLOCATE(R_Y(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 ALLOCATE(C_Y(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 IF ( id%MYID .EQ. MASTER ) THEN ALLOCATE( IW1( 2 * id%N ),stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=2 * id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(2*id%N,8)*K34_8 ALLOCATE( C_W(id%N), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 ALLOCATE( R_W(2*id%N), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(2*id%N,8)*K16_8 C end allocations on Master END IF ALLOCATE(C_LOCWK54(id%N),stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 ALLOCATE(R_LOCWK54(id%N),stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 KASE = 0 C Synchro point with broadcast of errors 777 CONTINUE NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 C TIMEEA needed if EA and IR with stopping criterium C and IR with fixed n.of steps. TIMEEA = 0.0D0 C TIMEEA1 needed if EA and IR with fixed n.of steps TIMEEA1 = 0.0D0 CALL MUMPS_SECDEB(TIMEIT) C ------------------------- C C RHSOL holds the initial guess for the solution C We start the loop on the Iterative refinement procedure C C C C |- IRefin. L O O P -| C V V C C ========================================================= C Computation of the infinity norm of A C ========================================================= IF ((ICNTL11.GT.0).OR.(ICNTL10.GT.0)) THEN C We don't get through these lines if ICNTL10<=0 AND ICNTL11<=0 IF ( KEEP(54) .eq. 0 ) THEN C ------------------ C Centralized matrix C ------------------ IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------------- C Call ZMUMPS_SOL_X outside, if needed, C in order to compute w(i,2)=sum|Aij|,j=1:n C in vector R_W(id%N+i) C ----------------------------------------- IF (KEEP(55).NE.0) THEN C unassembled matrix and norm of row required CALL ZMUMPS_SOL_X_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), id%A_ELT(1), & R_W(id%N+1), KEEP(1),KEEP8(1) ) ELSE C assembled matrix IF ( MTYPE .eq. 1 ) THEN CALL ZMUMPS_SOL_X & ( id%A(1), id%KEEP8(28), id%N, id%IRN(1), id%JCN(1), & R_W(id%N+1), KEEP(1),KEEP8(1), & 0, id%SYM_PERM(1) ) ELSE CALL ZMUMPS_SOL_X & ( id%A(1), id%KEEP8(28), id%N, id%JCN(1), id%IRN(1), & R_W(id%N+1), KEEP(1),KEEP8(1), & 0, id%SYM_PERM(1) ) END IF ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL ZMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1), & 0, id%SYM_PERM(1) ) ELSE CALL ZMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%JCN_loc(1), id%IRN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1), & 0, id%SYM_PERM(1) ) END IF ELSE R_LOCWK54 = RZERO END IF C ------------------------- C Assemble result on master C ------------------------- IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_W( id%N + 1 ), & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) END IF C End if KEEP(54) END IF C IF ( id%MYID .eq. MASTER ) THEN C R_W is available on the master process only RINFOG(4) = dble(ZERO) DO I = 1, id%N RINFOG(4) = max(R_W( id%N +I), RINFOG(4)) ENDDO ENDIF C end ICNTL11 =/0 v ICNTL10>0 ENDIF C ========================================================= C END norm of A C ========================================================= C Initializations for the IR NOITER = 0 IFLAG_IR = 0 TESTConv = .FALSE. IF ( id%MYID .eq. MASTER ) THEN IF (ICNTL10.GT.0) THEN C Test of convergence should be made TESTConv = .TRUE. ARRET = CNTL(2) IF (ARRET .LT. 0.0D0) THEN ARRET = sqrt(epsilon(0.0D0)) END IF IF ( PROKG ) THEN WRITE( MPG, 240) NITREF, ARRET,id%DKEEP(22) ENDIF ELSE IF ( PROKG ) THEN WRITE( MPG, 245) NITREF ENDIF ENDIF C ========================================================= C Starting IR DO 22 IRStep = 1, NITREF +1 C ========================================================= C C ========================================================= C Refine the solution starting from the second step of do loop C ========================================================= IF (( id%MYID .eq. MASTER ).AND.(IRStep.GT.1)) THEN NOITER = NOITER + 1 DO I = 1, id%N id%RHS(IBEG+I-1) = id%RHS(IBEG+I-1) + C_Y(I) ENDDO ENDIF C =========================================== C Computation of the RESIDUAL and of |A||x| C =========================================== IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN IF (KEEP(55).NE.0) THEN C input matrix by element CALL ZMUMPS_ELTYD( MTYPE, id%N, & id%NELT, id%ELTPTR(1), id%LELTVAR, & id%ELTVAR(1), id%KEEP8(30), id%A_ELT(1), & SAVERHS, id%RHS(IBEG), & C_Y, R_W, KEEP(50)) ELSE IF ( MTYPE .eq. 1 ) THEN CALL ZMUMPS_SOL_Y(id%A(1), id%KEEP8(28), & id%N, id%IRN(1), & id%JCN(1), SAVERHS, & id%RHS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ELSE CALL ZMUMPS_SOL_Y(id%A(1), id%KEEP8(28), & id%N, id%JCN(1), & id%IRN(1), SAVERHS, & id%RHS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ENDIF ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- CALL MPI_BCAST( RHS_IR(IBEG), id%N, & MPI_DOUBLE_COMPLEX, MASTER, & id%COMM, IERR ) C -------------------------------------- C Compute Y = SAVERHS - A * RHS C Y, SAVERHS defined only on master C -------------------------------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN CALL ZMUMPS_LOC_MV8( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_Y, & id%N, MPI_DOUBLE_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) C =========================== C_Y = SAVERHS - C_Y C =========================== ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_DOUBLE_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) END IF C -------------------------------------- C Compute C * If MTYPE = 1 C W(i) = Sum | Aij | | RHSj | C j C * If MTYPE = 0 C W(j) = Sum | Aij | | RHSi | C i C R_LOCWK54 used as local array for W C RHS has been broadcasted C -------------------------------------- IF ( I_AM_SLAVE .and. id%KEEP8(29) .NE. 0_8 ) THEN CALL ZMUMPS_LOC_OMEGA1( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), R_LOCWK54, KEEP(50), MTYPE ) ELSE R_LOCWK54 = RZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_W, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) ENDIF ENDIF C ===================================== C END computation RESIDUAL and |A||x| C ===================================== IF ( id%MYID .eq. MASTER ) THEN C IF ((ICNTL11.GT.0).OR.(ICNTL10.GT.0)) THEN C -------------- C Error analysis and test of convergence, C Compute the sparse componentwise backward error: C - at each step if test of convergence of IR is C requested (ICNTL(10)>0) C - at step 1 and NITREF+1 if error analysis C to be computed (ICNTL(11)>0) and if ICNTL(10)< 0 IF (((ICNTL11.GT.0).OR.((ICNTL10.LT.0).AND. & ((IRStep.EQ.1).OR.(IRStep.EQ.NITREF+1))) & .OR.((ICNTL10.EQ.0).AND.(IRStep.EQ.1))) & .OR.(ICNTL10.GT.0)) THEN C Compute w1 and w2 C always if ICNTL10>0 in the other case if ICNTL11>0 C ----------------- IF (ICNTL10.LT.0) CALL MUMPS_SECDEB(TIMEEA1) CALL ZMUMPS_SOL_OMEGA(id%N,SAVERHS, & id%RHS(IBEG), C_Y, R_W, C_W, IW1, IFLAG_IR, & RINFOG(7), NOITER, TESTConv, & MP, ARRET, KEEP(361), id%DKEEP(22) ) IF (ICNTL10.LT.0) THEN CALL MUMPS_SECFIN(TIMEEA1) id%DKEEP(120)=id%DKEEP(120)+TIMEEA1 ENDIF ENDIF IF ((ICNTL11.GT.0).AND.( & (ICNTL10.LT.0.AND.(IRStep.EQ.1.OR.IRStep.EQ.NITREF+1)) & .OR.((ICNTL10.GE.0).AND.(IRStep.EQ.1)) & )) THEN C Error analysis before iterative refinement C or for last if icntl10<0 C ------------------------------------------ CALL MUMPS_SECDEB(TIMEEA) IF (ICNTL10.EQ.0) THEN C No IR : there will be only the EA of the 1st sol. IF ( MPG .GT. 0 ) WRITE( MPG, 170 ) ELSEIF (IRStep.EQ.1) THEN C IR : we print the EA of the 1st sol. IF ( MPG .GT. 0 ) WRITE( MPG, 55 ) ELSEIF ((ICNTL10.LT.0).AND.(IRStep.EQ.NITREF+1)) THEN C IR with fixed n. of steps: we print the EA C of the last sol. IF ( MPG .GT. 0 ) THEN WRITE( MPG, 81 ) WRITE( MPG, * ) WRITE( MPG, 141 ) & 'NUMBER OF STEPS OF ITERATIVE REFINEMENT REQUESTED =', & NOITER ENDIF ENDIF GIVSOL = .TRUE. CALL ZMUMPS_SOL_Q(MTYPE,INFO(1),id%N, & id%RHS(IBEG), & SAVERHS,R_W(id%N+1),C_Y,GIVSOL, & RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) IF ( MPG .GT. 0 ) THEN C Error analysis before iterative refinement WRITE( MPG, 115 ) & 'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', & RINFOG(7) WRITE( MPG, 115 ) & '------(8):---------------------------- (W2)=', & RINFOG(8) END IF CALL MUMPS_SECFIN(TIMEEA) id%DKEEP(120)=id%DKEEP(120)+TIMEEA C end EA of the first solution END IF END IF C -------------- IF (IRStep.EQ.NITREF +1) THEN C If we are at the NITREF+1 step , we have refined the C solution NITREF times so we have to stop. KASE = 0 C If we test the convergence (ICNTL10.GT.0) and C IFLAG_IR = 0 we set a warning : more than NITREF steps C needed IF ((ICNTL10.GT.0).AND.(IFLAG_IR.EQ.0)) & id%INFO(1) = id%INFO(1) + 8 ELSE IF (ICNTL10.GT.0) THEN C ------------------- C Results of the test of convergence. C IFLAG_IR = 0 we should try to improve the solution C = 1 the stopping criterium is satisfied C = 2 the method is diverging, we go back C to the previous iterate C = 3 the convergence is too slow IF (IFLAG_IR.GT.0) THEN C If the convergence criterion is satisfied C or the convergence too slow C we set KASE=0 (end of the Iterative refinement) KASE = 0 C If the convergence is not improved, C we go back to the previous iterate. C IFLAG_IR can be equal to 2 only if IRStep >= 2 IF (IFLAG_IR.EQ.2) NOITER = NOITER - 1 ELSE C IFLAG_IR=0, try to improve the solution KASE = 2 ENDIF ELSEIF (ICNTL10.LT.0) THEN C ------------------- KASE = 2 ELSE C ICNTL10 = 0, we want to perform only EA and not IR. C ----------------- KASE = 0 END IF ENDIF C End Master ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C If Kase= 0 we quit the IR process IF (KASE.LE.0) GOTO 666 IF (KASE.LT.0) THEN WRITE(*,*) "Internal error 17 in ZMUMPS_SOL_DRIVER" ENDIF C ========================================================= C COMPUTE the solution of Ay = r C ========================================================= C Call internal routine to avoid code duplication CALL ZMUMPS_PP_SOLVE() IF (INFO(1) .LT. 0) GOTO 90 C ----------------------- C Go back to beginning of C loop to apply next step C of iterative refinement C ----------------------- 22 CONTINUE 666 CONTINUE C ************************************************ C C End of the iterative refinement procedure C C ************************************************ CALL MUMPS_SECFIN(TIMEIT) IF ( id%MYID .EQ. MASTER ) THEN IF ( NITREF .GT. 0 ) THEN id%INFOG(15) = NOITER END IF C id%DKEEP(114) time for the iterative refinement C id%DKEEP(120) time for the error analysis C id%DKEEP(121) time for condition number C these values are meaningful only on the host. IF (ICNTL10.EQ.0) THEN C No IR has been requested. All the time is needed C for computing EA id%DKEEP(120)=TIMEIT ELSE C IR has been requested id%DKEEP(114)=TIMEIT - id%DKEEP(120) ENDIF END IF IF ( PROKG ) THEN IF (ICNTL10.GT.0) THEN WRITE( MPG, 81 ) WRITE( MPG, * ) WRITE( MPG, 141 ) & 'NUMBER OF STEPS OF ITERATIVE REFINEMENTS PERFORMED =', & NOITER ENDIF ENDIF C C ================================================== C BEGIN C Perform error analysis after iterative refinement C ================================================== IF ((ICNTL11 .GT. 0).AND.(ICNTL10.GT.0)) THEN C If IR is requested with test of convergence, C the EA of the last step of IR is done here, C otherwise EA of the last step is done at the C end of IR CALL MUMPS_SECDEB(TIMEEA) KASE = 0 IF (id%MYID .eq. MASTER ) THEN C Test if IFLAG_IR = 2, that is if the the IR was diverging, C we went back to the previous iterate C We have to do EA on the last computed solution. IF (IFLAG_IR.EQ.2) KASE = 2 ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KASE.EQ.2) THEN C We went back to the previous iterate C We have to do EA on the last computed solution. C Compute the residual in C_Y using IRN, JCN, ASPK C and the solution RHS(IBEG) C The norm of the ith row in R_Y(I). IF ( KEEP(54) .eq. 0 ) THEN C --------------------- C Matrix is centralized C --------------------- IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN CALL ZMUMPS_QD2( MTYPE, id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), & id%RHS(IBEG), SAVERHS, R_Y, C_Y, KEEP(1),KEEP8(1)) ELSE CALL ZMUMPS_ELTQD2( MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), id%A_ELT(1), & id%RHS(IBEG), SAVERHS, R_Y, C_Y, KEEP(1),KEEP8(1)) ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- CALL MPI_BCAST( RHS_IR(IBEG), id%N, & MPI_DOUBLE_COMPLEX, MASTER, & id%COMM, IERR ) C ---------------- C Compute residual C ---------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN CALL ZMUMPS_LOC_MV8( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_Y, & id%N, MPI_DOUBLE_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) C_Y = SAVERHS - C_Y ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_DOUBLE_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) END IF ENDIF ENDIF ! KASE.EQ.2 IF (id%MYID .EQ. MASTER) THEN C Compute which equations are associated to w1 and which C ones are associated to w2 in case of IFLAG_IR=2. C If IFLAG_IR = 0 or 1 IW1 should be correct IF (IFLAG_IR.EQ.2) THEN TESTConv = .FALSE. CALL ZMUMPS_SOL_OMEGA(id%N,SAVERHS, & id%RHS(IBEG), C_Y, R_W, C_W, IW1, IFLAG_IR, & RINFOG(7), 0, TESTConv, & MP, ARRET, KEEP(361), id%DKEEP(22) ) ENDIF ! (IFLAG_IR.EQ.2) c Compute some statistics for GIVSOL = .TRUE. CALL ZMUMPS_SOL_Q(MTYPE,INFO(1),id%N, & id%RHS(IBEG), & SAVERHS,R_W(id%N+1),C_Y,GIVSOL, & RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) ENDIF ! Master CALL MUMPS_SECFIN(TIMEEA) id%DKEEP(120)=id%DKEEP(120)+TIMEEA ENDIF ! ICNTL11>0 and ICNTL10>0 C ========================================================= C Compute the Condition number associated if requested. C ========================================================= CALL MUMPS_SECDEB(TIMELCOND) IF (ICNTL11 .EQ. 1) THEN IF ( id%MYID .eq. MASTER ) THEN C Notice that D is always the identity ALLOCATE( D(id%N),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 DO I = 1, id%N D( I ) = RONE END DO ENDIF KASE = 0 222 CONTINUE IF ( id%MYID .EQ. MASTER ) THEN CALL ZMUMPS_SOL_LCOND(id%N, SAVERHS, & id%RHS(IBEG), C_Y, D, R_W, C_W, IW1, KASE, & RINFOG(7), RINFOG(9), RINFOG(10), & MP, KEEP(1),KEEP8(1)) ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C KASE <= 0 C We reach the end of iterative method to compute C LCOND1 and LCOND2 IF (KASE.LE.0) GOTO 224 CALL ZMUMPS_PP_SOLVE() IF (INFO(1) .LT. 0) GOTO 90 C --------------------------- C Go back to beginning of C loop to apply next step C of iterative method C ----------------------- GO TO 222 C End ICNTL11 = 1 ENDIF 224 CONTINUE CALL MUMPS_SECFIN(TIMELCOND) id%DKEEP(121)=id%DKEEP(121)+TIMELCOND IF ((id%MYID .EQ. MASTER).AND.(ICNTL11.GT.0)) THEN IF (ICNTL10.GT.0) THEN C If ICNTL10<0 these stats have been printed before IR IF ( MPG .GT. 0 ) THEN WRITE( MPG, 115 ) & 'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', & RINFOG(7) WRITE( MPG, 115 ) & '------(8):---------------------------- (W2)=', & RINFOG(8) ENDIF END IF IF (ICNTL11.EQ.1) THEN C If ICNTL11/=1 these stats haven't been computed IF (MPG.GT.0) THEN WRITE( MPG, 115 ) & '------(9):Upper bound ERROR ...............=', & RINFOG(9) WRITE( MPG, 115 ) & '-----(10):CONDITION NUMBER (1) ............=', & RINFOG(10) WRITE( MPG, 115 ) & '-----(11):CONDITION NUMBER (2) ............=', & RINFOG(11) END IF END IF END IF ! MASTER && ICNTL11.GT.0 IF ( PROKG ) THEN WRITE( MPG, * ) IF (abs(ICNTL10) .GT.0 ) WRITE( MPG, 101 ) id%DKEEP(114) IF (ICNTL11 .GT.0 ) WRITE( MPG, 102 ) id%DKEEP(120) IF (ICNTL11 .EQ.1 ) WRITE( MPG, 103 ) id%DKEEP(121) WRITE( MPG, * ) ENDIF IF ( PROKG .AND. abs(ICNTL10) .GT.0 ) WRITE( MPG, 131 ) C=================================================== C Perform error analysis after iterative refinements C END C=================================================== C IF (id%MYID == MASTER) THEN NB_BYTES = NB_BYTES - int(size(C_W),8)*K35_8 DEALLOCATE(C_W) NB_BYTES = NB_BYTES - int(size(R_W),8)*K16_8 & - int(size(IW1),8)*K34_8 DEALLOCATE(R_W) DEALLOCATE(IW1) IF (ICNTL11 .EQ. 1) THEN C We have used D only for LCOND1,2 NB_BYTES = NB_BYTES - int(size(D ),8)*K16_8 DEALLOCATE(D) ENDIF ENDIF NB_BYTES = NB_BYTES - & (int(size(R_Y),8)+int(size(R_LOCWK54),8))*K16_8 NB_BYTES = NB_BYTES - & (int(size(C_Y),8)+int(size(C_LOCWK54),8))*K35_8 DEALLOCATE(R_Y) DEALLOCATE(C_Y) DEALLOCATE(R_LOCWK54) DEALLOCATE(C_LOCWK54) C} End POSTPros END IF C============================================ C C ITERATIVE REFINEMENT AND/OR ERROR ANALYSIS C C END C C============================================ C ========================== C Begin reordering on master C corresponding to maximum transversal permutation C in case of centralized solution C (ICNTL21==0) C IF ( id%MYID .EQ. MASTER .AND. ICNTL21==0 & .AND. KEEP(23) .NE. 0.AND.KEEP(237).EQ.0) THEN C ((No transpose and backward performed and NO A-1) C or null space computation): permutation C must be done on solution. IF ((KEEP(221).NE.1 .AND. MTYPE .EQ. 1) & .OR. KEEP(111) .NE.0 .OR. KEEP(252).NE.0 ) THEN C Permute the solution RHS according to the column C permutation held in UNS_PERM C Column J of the permuted matrix corresponds to C column UNS_PERM(J) of the original matrix. C RHS holds the permuted solution C Note that id%N>1 since KEEP(23)=0 when id%N=1 C ALLOCATE( C_RW1( id%N ),stat =allocok ) ! temporary not in NB_BYTES IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) & WRITE(LP,*) 'could not allocate ', id%N, 'integers.' CALL MUMPS_ABORT() END IF DO K = 1, NBRHS_EFF IF (KEEP(242).EQ.0) THEN KDEC = (K-1)*LD_RHS+IBEG-1 ELSE C ------------------------------- C Columns just computed might not C be contiguous in original RHS C ------------------------------- KDEC = int(PERM_RHS(K-1+JBEG_RHS)-1,8)*int(LD_RHS,8) ENDIF DO I = 1, id%N C_RW1(I) = id%RHS(KDEC+I) ENDDO DO I = 1, id%N JPERM = id%UNS_PERM(I) id%RHS( KDEC+JPERM ) = C_RW1( I ) ENDDO ENDDO DEALLOCATE( C_RW1 ) !temporary not in NB_BYTES END IF END IF C C End reordering on master C ======================== IF (id%MYID.EQ.MASTER .and.ICNTL21==0.and.KEEP(221).NE.1.AND. & (KEEP(237).EQ.0) ) THEN * print out the solution IF ( INFO(1) .GE. 0 .AND. ICNTL(4).GE.3 .AND. ICNTL(3).GT.0) & THEN K = min(10, id%N) IF (ICNTL(4) .eq. 4 ) K = id%N J = min(10,NBRHS_EFF) IF (ICNTL(4) .eq. 4 ) J = NBRHS_EFF DO II=1, J WRITE(ICNTL(3),110) BEG_RHS+II-1 WRITE(ICNTL(3),160) & (id%RHS(IBEG+(II-1)*LD_RHS+I-1),I=1,K) ENDDO END IF END IF C ========================== C blocking for multiple RHS (END OF DO WHILE (BEG_RHS.LE.NBRHS) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN ! case of general sparse: in case of empty columns ! NBRHS_EFF might has been updated and broadcasted ! and holds the effective size of a contiguous block of ! non empty columns BEG_RHS = BEG_RHS + NBRHS_EFF ! nb of nonempty columns ELSE BEG_RHS = BEG_RHS + NBRHS ENDIF C } ENDDO C END DO WHILE (BEG_RHS.LE.id%NRHS) C ================================= C C ======================================================== C Reset RHS to zero for all remaining columns that C have not been processed because they were emtpy C ======================================================== IF ( (id%MYID.EQ.MASTER) & .AND. ( KEEP(248).NE.0 ) ! sparse RHS on input & .AND. ( KEEP(237).EQ.0 ) ! No A-1 & .AND. ( ICNTL21.EQ.0 ) ! Centralized solution & .AND. ( KEEP(221) .NE.1 ) ! Not Reduced RHS step of Schur & .AND. ( JEND_RHS .LT. id%NRHS ) & ) & THEN JBEG_NEW = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%N id%RHS(int(PERM_RHS(JBEG_NEW) -1,8)*int(LD_RHS,8)+I) & = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ELSE DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%N id%RHS(int(JBEG_NEW -1,8)*int(LD_RHS,8) + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ENDIF C ======================================================== C Reset id%SOL_loc to zero for all remaining columns that C have not been processed because they were empty C ======================================================== IF ( I_AM_SLAVE .AND. (ICNTL21.NE.0) .AND. & ( JEND_RHS .LT. id%NRHS ) .AND. KEEP(221).NE.1 ) THEN JBEG_NEW = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, NSOL_loc id%SOL_loc(int(PERM_RHS(JBEG_NEW) -1,8)* & int(id%LSOL_loc,8)+int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ELSE C DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, NSOL_loc id%SOL_loc((JBEG_NEW -1)*id%LSOL_loc + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF C C ================================================================ C Reset id%RHSINTR and id%REDRHS to zero for all remaining columns C that have not been processed because they were emtpy C ================================================================ IF ((KEEP(221).EQ.1) .AND. & ( JEND_RHS .LT. id%NRHS ) ) THEN IF (id%MYID .EQ. MASTER) THEN JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%SIZE_SCHUR id%REDRHS(int(JBEG_NEW -1,8)*int(LD_REDRHS,8) + & int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF IF (I_AM_SLAVE) THEN JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1,NBENT_RHSINTR id%RHSINTR(int(JBEG_NEW -1,8)*int(id%LD_RHSINTR,8) + & int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF C C C ! maximum size used on that proc id%INFO(26) = int(NB_BYTES_MAX / 1000000_8) C Centralize memory statistics on the host C C INFOG(30) = size of mem in bytes for solve C for the processor using largest memory C INFOG(31) = size of mem in bytes for solve C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(26), id%INFOG(30), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I10) ') & ' ** Rank of processor needing largest memory in solve :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used by this processor for solve :', & id%INFOG(30) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during solve :', & ( id%INFOG(31)-id%INFO(26) ) / id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during solve :', & id%INFOG(31) / id%NSLAVES END IF ELSE WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used for solve :', & id%INFOG(30) ENDIF END IF *=============================== *End of Solve Phase *=============================== C Store and print timings CALL MUMPS_SECFIN(TIME3) id%DKEEP(112)=TIME3 id%DKEEP(113)=TIMEC2 id%DKEEP(115)=TIMESCATTER2 id%DKEEP(116)=TIMEGATHER2 id%DKEEP(122)=TIMECOPYSCALE2 C Reductions of DKEEP(115,116,117,118,119,122): CALL MPI_REDUCE( id%DKEEP(115), id%DKEEP(160),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(116), id%DKEEP(161),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(117), id%DKEEP(162),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(118), id%DKEEP(163),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(119), id%DKEEP(164),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(122), id%DKEEP(165),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) C IF (PROKG) THEN WRITE ( MPG, *) WRITE ( MPG, *) "Leaving solve with ..." WRITE( MPG, 434 ) id%DKEEP(160) ! max id%DKEEP(115) WRITE( MPG, 432 ) id%DKEEP(113) ! ok without reduction WRITE( MPG, 435 ) id%DKEEP(162) ! max id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MPG, 437 ) id%DKEEP(164) ! id%DKEEP(119) WRITE( MPG, 436 ) id%DKEEP(163) ! id%DKEEP(118) WRITE( MPG, 433 ) id%DKEEP(161) ! max(DKEEP(116)) -- Gather WRITE( MPG, 431 ) id%DKEEP(165) ! max(DKEEP(122)) -- Dist. sol. ENDIF IF ( PROK ) THEN WRITE ( MP, *) WRITE ( MP, *) "Local statistics" WRITE( MP, 434 ) id%DKEEP(115) WRITE( MP, 432 ) id%DKEEP(113) WRITE( MP, 435 ) id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MP, 437 ) id%DKEEP(119) WRITE( MP, 436 ) id%DKEEP(118) WRITE( MP, 433 ) id%DKEEP(116) WRITE( MP, 431 ) id%DKEEP(122) END IF 90 CONTINUE IF (KEEP(400) .GT. 0) THEN CALL MUMPS_SOL_L0OMP_LD(KEEP(400)) ENDIF IF (INFO(1) .LT.0 ) THEN IF (INFO(1) .EQ. -80) INFO(1) = -81 ENDIF C -- related to exploit sparsity IF (associated(nodes_FWD)) THEN NB_BYTES = NB_BYTES - size(nodes_FWD) * K34_8 DEALLOCATE(nodes_FWD) NULLIFY(nodes_FWD) ENDIF IF (associated(nodes_BWD)) THEN NB_BYTES = NB_BYTES - size(nodes_BWD) * K34_8 DEALLOCATE(nodes_BWD) NULLIFY(nodes_BWD) ENDIF IF (allocated(Pruned_Sons_FWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_FWD) * K34_8 DEALLOCATE(Pruned_Sons_FWD) ENDIF IF (allocated(Pruned_Sons_BWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_BWD) * K34_8 DEALLOCATE(Pruned_Sons_BWD) ENDIF IF (SCALING_RHSINTR_FWD_ALLOCATED) THEN NB_BYTES = NB_BYTES - LSCALING_RHSINTR_FWD * K16_8 DEALLOCATE(SCALING_RHSINTR_FWD) ENDIF SCALING_RHSINTR_FWD_ALLOCATED = .FALSE. NULLIFY(SCALING_RHSINTR_FWD) IF (SCALING_RHSINTR_BWD_ALLOCATED) THEN NB_BYTES = NB_BYTES - LSCALING_RHSINTR_BWD * K16_8 DEALLOCATE(SCALING_RHSINTR_BWD) ENDIF SCALING_RHSINTR_BWD_ALLOCATED = .FALSE. NULLIFY(SCALING_RHSINTR_BWD) IF (KEEP(485) .EQ. 1) THEN KEEP(350) = KEEP350_SAVE IF (IS_LR_MOD_TO_STRUC_DONE) THEN CALL ZMUMPS_BLR_MOD_TO_STRUC(id%BLRARRAY_ENCODING) CALL MUMPS_FDM_MOD_TO_STRUC('F',id%FDM_F_ENCODING, & id%INFO(1)) ENDIF ENDIF IF (KEEP(19).EQ.0.AND.KEEP(53).NE.0) THEN C restore KEEP(20) KEEP(20) = KEEP20_SAVE ENDIF IF (KEEP(201).GT.0)THEN IF (IS_INIT_OOC_DONE) THEN CALL ZMUMPS_OOC_END_SOLVE(IERR) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) ENDIF C ------------------------ C Check allocation before C to deallocate (cases of C errors that could happen C before or after allocate C statement) C C Sparse RHS C Free space and reset pointers if needed IF (IRHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_SPARSE_COPY),8)*K34_8 DEALLOCATE(IRHS_SPARSE_COPY) IRHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_SPARSE_COPY) ENDIF IF (IRHS_PTR_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_PTR_COPY),8)*K34_8 DEALLOCATE(IRHS_PTR_COPY) IRHS_PTR_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_PTR_COPY) ENDIF IF (RHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(RHS_SPARSE_COPY),8)*K35_8 DEALLOCATE(RHS_SPARSE_COPY) RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_SPARSE_COPY) ENDIF IF (allocated(MAP_RHS_loc)) THEN NB_BYTES = NB_BYTES - int(size(MAP_RHS_loc),8)*K34_8 DEALLOCATE(MAP_RHS_loc) ENDIF IF (IRHS_loc_PTR_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(IRHS_loc_PTR),8)*K34_8 DEALLOCATE(IRHS_loc_PTR) NULLIFY(IRHS_loc_PTR) IRHS_loc_PTR_ALLOCATED = .FALSE. ENDIF #if defined(USE_OLD_SCALING) IF (I_AM_SLAVE.AND.LSCAL.AND.KEEP(248).EQ.-1) THEN IF (associated(scaling_data_dr%SCALING_LOC)) THEN NB_BYTES = NB_BYTES - & int(size(scaling_data_dr%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data_dr%SCALING_LOC) NULLIFY (scaling_data_dr%SCALING_LOC) ENDIF ENDIF #endif IF (allocated(PERM_RHS)) THEN NB_BYTES = NB_BYTES - int(size(PERM_RHS),8)*K34_8 DEALLOCATE(PERM_RHS) ENDIF C END A-1 IF (allocated(UNS_PERM_INV)) THEN NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 DEALLOCATE(UNS_PERM_INV) ENDIF IF (allocated(BUFR)) THEN NB_BYTES = NB_BYTES - int(size(BUFR),8)*K34_8 DEALLOCATE(BUFR) ENDIF IF ( I_AM_SLAVE ) THEN IF (allocated(RHS_BOUNDS)) THEN NB_BYTES = NB_BYTES - & int(size(RHS_BOUNDS),8)*K34_8 DEALLOCATE(RHS_BOUNDS) ENDIF IF (allocated(IWK_SOLVE)) THEN NB_BYTES = NB_BYTES - int(size(IWK_SOLVE),8)*K34_8 DEALLOCATE( IWK_SOLVE ) ENDIF IF (allocated(PTRACB)) THEN NB_BYTES = NB_BYTES - int(size(PTRACB),8)*K34_8* & int(KEEP(10),8) DEALLOCATE( PTRACB ) ENDIF IF (allocated(IWCB)) THEN NB_BYTES = NB_BYTES - int(size(IWCB),8)*K34_8 DEALLOCATE( IWCB ) ENDIF C ------------------------ C SLAVE CODE C ----------------------- C Deallocate send buffers C ----------------------- IF (id%NSLAVES .GT. 1) THEN CALL MUMPS_BUF_DEALL_CB( IERR ) CALL MUMPS_BUF_DEALL_SMALL_BUF( IERR ) ENDIF END IF C IF ( id%MYID .eq. MASTER ) THEN C ------------------------ C SAVERHS may have been C allocated only on master C ------------------------ IF (allocated(SAVERHS)) THEN NB_BYTES = NB_BYTES - int(size(SAVERHS),8)*K35_8 DEALLOCATE( SAVERHS) ENDIF C Nullify RHS_IR might have been pointing to id%RHS NULLIFY(RHS_IR) ELSE C -------------------- C Free right-hand-side C on slave processors C -------------------- IF (associated(RHS_IR)) THEN NB_BYTES = NB_BYTES - int(size(RHS_IR),8)*K35_8 DEALLOCATE(RHS_IR) NULLIFY(RHS_IR) END IF END IF IF (I_AM_SLAVE) THEN C Deallocate temporary workspace SRW3 IF (allocated(SRW3)) THEN NB_BYTES = NB_BYTES - int(size(SRW3),8)*K151_8 DEALLOCATE(SRW3) ENDIF #if defined(USE_OLD_SCALING) C Free local scaling arrays IF (LSCAL .AND. ICNTL21 .NE. 0) THEN IF (associated(scaling_data_sol%SCALING_LOC)) THEN NB_BYTES = NB_BYTES - & int(size(scaling_data_sol%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data_sol%SCALING_LOC) NULLIFY(scaling_data_sol%SCALING_LOC) ENDIF ENDIF #endif #if defined(USE_OLD_SCALING) #endif C Free memory until next call to ZMUMPS IF (WK_USER_PROVIDED) THEN C S points to WK_USER provided by user C KEEP8(24) holds size of WK_USER C it should be kept on exit because it will be used C at a future solve to check that size provided is consistent C (see error -41) NULLIFY(id%S) ELSE IF (ALLOCATE_S) THEN C S was allocated, free it NB_BYTES = NB_BYTES - KEEP8(23)*K35_8 id%KEEP8(23)=0_8 DEALLOCATE(id%S) NULLIFY(id%S) NB_BYTES = NB_BYTES - KEEP8(23) * K35_8 KEEP8(23) = 0_8 ENDIF IF (KEEP(221).NE.1 & ) THEN C -- After reduction of RHS to Schur variables C -- keep compressed RHS generated during FWD step C -- to be used for future expansion IF (associated(id%RHSINTR)) THEN NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25) = 0_8 id%LD_RHSINTR = 0 ENDIF IF (associated(id%GLOB2LOC_RHS)) THEN NB_BYTES = NB_BYTES - & int(size(id%GLOB2LOC_RHS),8)*K34_8 DEALLOCATE(id%GLOB2LOC_RHS) NULLIFY(id%GLOB2LOC_RHS) ENDIF IF (id%GLOB2LOC_SOL_ALLOC) THEN NB_BYTES = NB_BYTES - & int(size(id%GLOB2LOC_SOL),8)*K34_8 DEALLOCATE(id%GLOB2LOC_SOL) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF ENDIF IF ( WORK_WCB_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(WORK_WCB),8)*K151_8 DEALLOCATE( WORK_WCB ) NULLIFY ( WORK_WCB ) ELSE C Otherwise, WORK_WCB may point to some C position inside id%S, nullify it NULLIFY( WORK_WCB ) ENDIF IF ( PTR_RHS_ROOT_ALLOCATED ) THEN DEALLOCATE(PTR_RHS_ROOT) NB_BYTES = NB_BYTES - LPTR_RHS_ROOT * K151_8 ENDIF NULLIFY(PTR_RHS_ROOT) ENDIF #if defined(STAT_ES_SOLVE) IF ( & (id%MYID.EQ.MASTER).AND. & ( (id%KEEP(235).NE.0).OR.(id%KEEP(212).NE.0) ) & ) & THEN C If exploit sparsity then C stats saved in DKEEP(200:204) and C set RINFOG(24), RINFOG(25), RINFOG(26) CALL ZMUMPS_SOL_ES_PRINT_STATS( & id%KEEP(212), id%KEEP(235), id%KEEP(237), & id%KEEP(485), id%KEEP(497), & id%KEEP8(110),id%NRHS, id%ICNTL(27), id%N, & id%KEEP(50), id%DKEEP(200:204), & id%RINFOG(24:28), MPG) END IF #endif 500 CONTINUE RETURN 55 FORMAT (//' ERROR ANALYSIS BEFORE ITERATIVE REFINEMENT') 100 FORMAT(//' ****** SOLVE & CHECK STEP ********'/) 110 FORMAT (//' Vector solution for column ',I12) 115 FORMAT(1X, A44,1P,D9.2) 434 FORMAT(' Time to build/scatter RHS =',F15.6) 432 FORMAT(' Time in solution step (fwd/bwd) =',F15.6) 435 FORMAT(' .. Time in forward (fwd) step = ',F15.6) 437 FORMAT(' .. Time in ScaLAPACK root = ',F15.6) 436 FORMAT(' .. Time in backward (bwd) step = ',F15.6) 433 FORMAT(' Time to gather solution(cent.sol)=',F15.6) 431 FORMAT(' Time for distributed solution =',F15.6) 150 FORMAT(' GLOBAL STATISTICS PRIOR SOLVE PHASE ...........'/ & ' Number of right-hand-sides =',I12/ & ' Blocking factor for multiple rhs =',I12/ & ' ICNTL (9) =',I12/ & ' --- (10) =',I12/ & ' --- (11) =',I12/ & ' --- (20) =',I12/ & ' --- (21) =',I12/ & ' --- (30) =',I12/ & ' --- (35) =',I12/ & ' --- (48) (effective) =',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 ( & 2X, "Maximum number of steps = ",I4/, & 2X, "Effective stopping criterion (based on CNTL(2)) = ",E14.6/ & 2x, "Slow convergence threshold (W1+W2 ratio) = ",E14.6) 245 FORMAT ( & 2X, "Number of steps is fixed = ",I4) 270 FORMAT (/' BEGIN ITERATIVE REFINEMENT' ) 81 FORMAT (/' STATISTICS AFTER ITERATIVE REFINEMENT ') 101 FORMAT(' Time for Iterative Refinement =',F12.4) 102 FORMAT(' Time for Error Analysis =',F12.4) 103 FORMAT(' Time for Condition Number =',F12.4) 131 FORMAT (' END ITERATIVE REFINEMENT '/) 141 FORMAT(1X, A52,I4) ! Number of steps performed CONTAINS SUBROUTINE ZMUMPS_CHECK_DISTRHS( & idNloc_RHS, & idLRHS_loc, & NRHS, & idIRHS_loc, & idRHS_loc, & I_AM_SLAVE, & INFO) C C Purpose: C ======= C C Check distributed RHS format. We assume that C the user has indicated that he/she provided C a distributed RHS (KEEP(248)=-1). We also C assume that the nb of RHS columns NRHS has C been broadcasted to all processes. This C routine should then be called on the workers. C C Arguments: C ========= C INTEGER, INTENT( IN ) :: idNloc_RHS INTEGER, INTENT( IN ) :: idLRHS_loc INTEGER, INTENT( IN ) :: NRHS LOGICAL, INTENT( IN ) :: I_AM_SLAVE #if defined(MUMPS_NOF2003) INTEGER, POINTER :: idIRHS_loc (:) COMPLEX(kind=8), POINTER :: idRHS_loc (:) #else INTEGER, INTENT( IN ), POINTER :: idIRHS_loc (:) COMPLEX(kind=8), INTENT( IN ), POINTER :: idRHS_loc (:) #endif INTEGER, INTENT( INOUT ) :: INFO(80) C C Local declarations: C ================== C INTEGER(8) :: REQSIZE8 C C Executable statements: C ===================== C C Quick return if nothing on this proc IF (idNloc_RHS .LE. 0) RETURN IF (idNloc_RHS .GT. 0 .AND. .NOT. I_AM_SLAVE) THEN C Nloc_RHS should not be greater than 0 C on a non working host because the distribution C of the RHS does not include the non working host. INFO(1)=-55 INFO(2)=-idLRHS_loc RETURN ENDIF C Check for leading dimension IF (NRHS.NE.1) THEN IF ( idLRHS_loc .LT. idNloc_RHS) THEN INFO(1)=-55 INFO(2)=idLRHS_loc RETURN ENDIF ENDIF IF (idNloc_RHS .GT. 0) THEN C Check association and size of index array idIRHS_loc IF (.NOT. associated(idIRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=17 RETURN ELSE IF (size(idIRHS_loc) .LT. idNloc_RHS) THEN INFO(1)=-22 INFO(2)= 17 RETURN ENDIF C Check association and size of value array idRHS_loc IF (.NOT. associated(idRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=18 RETURN ELSE C Check size of array of values idRHS_loc REQSIZE8 = int(idLRHS_loc,8)*int(NRHS,8) & + int(-idLRHS_loc+idNloc_RHS,8) #if defined(MUMPS_NOF2003) IF ( REQSIZE8 .LE. int(huge(idNloc_RHS),8) .AND. & size(idRHS_loc) .LT. int(REQSIZE8) ) THEN #else IF (size(idRHS_loc,kind=8) .LT. REQSIZE8) THEN #endif INFO(1)=-22 INFO(2)=18 RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_CHECK_DISTRHS SUBROUTINE ZMUMPS_PP_SOLVE() IMPLICIT NONE C C Purpose: C ======= C Scatter right-hand side, solve the system, C and gather the solution on the host during C post-processing. C We use an internal subroutine to avoid code C duplication without the complication of adding C new parameters or local variables. All variables C in this routine have the scope of ZMUMPS_SOL_DRIVER. C C IF (KASE .NE. 1 .AND. KASE .NE. 2) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_PP_SOLVE" CALL MUMPS_ABORT() ENDIF IF ( id%MYID .eq. MASTER ) THEN C Define matrix B as follows: C MTYPE=1 => B=A other values B=At C The user asked to solve the system Bx=b C C THEN C KASE = 1........ RW1 = INV(TRANSPOSE(B)) * RW1 C KASE = 2........ RW1 = INV(B) * RW1 IF ( MTYPE .EQ. 1 ) THEN SOLVET = KASE - 1 ELSE SOLVET = KASE END IF C SOLVET= 1 -> solve A x = B, other values solve Atx=b C We force SOLVET to have value either 0 or 1, in order C to be able to test both values, and also, be able to C test whether SOLVET = MTYPE or not. IF ( SOLVET.EQ.2 ) SOLVET = 0 #if defined(USE_OLD_SCALING) IF ( LSCAL ) THEN IF ( SOLVET .EQ. 1 ) THEN C Apply rowscaling DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%ROWSCA( K ) END DO ELSE C Apply column scaling DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%COLSCA( K ) END DO END IF END IF #endif END IF ! MYID.EQ.MASTER C ------------------------------ C Broadcast SOLVET to the slaves C ------------------------------ CALL MPI_BCAST( SOLVET, 1, MPI_INTEGER, MASTER, & id%COMM, IERR) #if ! defined(USE_OLD_SCALING) IF (LSCAL .AND. id%KEEP(89) .GT. 0) THEN IF (SOLVET .EQ. 1) THEN SCALING_LOC_FWD => id%ROWSCA_LOC ELSE SCALING_LOC_FWD => id%COLSCA_LOC ENDIF ELSE SCALING_LOC_FWD => RDUMMY_TARGET ENDIF #endif C -------------------------------------------- C Scatter the right hand side C_Y on all procs C -------------------------------------------- IF ( .NOT.I_AM_SLAVE ) THEN C -- Master not working CALL ZMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, LSCAL, SCALING_LOC_FWD(1), & SOLVET, C_Y(1), id%N, 1, & 1, & C_DUMMY, 1, 1, & IDUMMY, 0, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ELSE IF (SOLVET.EQ.MTYPE) THEN C GLOB2LOC_RHS is with respect to the C original linear system (transposed or not) PTR_POSINRHSINTR_FWD => id%GLOB2LOC_RHS ELSE C Transposed, use column indices of original C system (ie, col indices of A or A^T) PTR_POSINRHSINTR_FWD => id%GLOB2LOC_SOL ENDIF LIW_PASSED = max( LIW, 1 ) CALL ZMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, LSCAL, SCALING_LOC_FWD(1), & SOLVET, C_Y(1), id%N, 1, & 1, & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, 1, & PTR_POSINRHSINTR_FWD(1), NB_FS_RHSINTR_F, C & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ENDIF IF (INFO(1).LT.0) GOTO 89 C C Solve the system C IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) IF (SOLVET.EQ.MTYPE) THEN PTR_POSINRHSINTR_FWD => id%GLOB2LOC_RHS PTR_POSINRHSINTR_BWD => id%GLOB2LOC_SOL ELSE PTR_POSINRHSINTR_FWD => id%GLOB2LOC_SOL PTR_POSINRHSINTR_BWD => id%GLOB2LOC_RHS ENDIF FROM_PP=.TRUE. NBSPARSE_LOC = .FALSE. CALL ZMUMPS_SOL_C(idintr%root,idintr%roota, & id%N,id%S(1),LA_PASSED,id%IS(1), & LIW_PASSED,WORK_WCB(1),LWCB8,IWCB,LIWCB,NBRHS_EFF,id%NA(1), & id%LNA,id%NE_STEPS(1),SRW3,SOLVET,ICNTL(1),FROM_PP,id%STEP(1), & id%FRERE_STEPS(1),id%DAD_STEPS(1),id%FILS(1),id%PTLUST_S(1), & id%PTRFAC(1), IWK_SOLVE(1), LIWK_SOLVE, PTRACB, LIWK_PTRACB, & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1), KEEP(1), KEEP8(1), & id%DKEEP(1),id%COMM_NODES,id%MYID,id%MYID_NODES, BUFR(1), LBUFR, & LBUFR_BYTES, id%ISTEP_TO_INIV2(1), id%TAB_POS_IN_PERE(1,1), C Next 3 arguments are not used in this call & IBEG_ROOT_DEF,IEND_ROOT_DEF,IROOT_DEF_RHS_COL1, PTR_RHS_ROOT(1), & LPTR_RHS_ROOT, SIZE_ROOT, MASTER_ROOT, id%RHSINTR(IBEG_RHSINTR), & id%LD_RHSINTR,PTR_POSINRHSINTR_FWD(1),PTR_POSINRHSINTR_BWD(1), & -1, -1, & IDUMMY(1), IDUMMY(1), & 1,1,1, IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY, 1,1, & NBSPARSE_LOC, PTR_RHS_BOUNDS(1), LPTR_RHS_BOUNDS #if defined(STAT_ES_SOLVE) & , IDUMMY, 1, JDUMMY, 1 #endif & , id%IPOOL_B_L0_OMP(1), id%LPOOL_B_L0_OMP, id%IPOOL_A_L0_OMP(1), & id%LPOOL_A_L0_OMP, id%L_VIRT_L0_OMP, id%VIRT_L0_OMP(1), & id%L_PHYS_L0_OMP, id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1), & id%PTR_LEAFS_L0_OMP(1), id%L0_OMP_MAPPING(1), id%LL0_OMP_MAPPING, & idintr%L0_OMP_FACTORS(1), id%LL0_OMP_FACTORS & ) END IF C ------------------ C Change error codes C ------------------ IF (INFO(1).eq.-2) INFO(1)=-12 IF (INFO(1).eq.-3) INFO(1)=-15 C IF (INFO(1) .GE. 0) THEN C We need a workspace of minimal size KEEP(247) C in order to unpack pieces of the solution during C ZMUMPS_GATHER_SOLUTION below C - Avoid allocation if error already occurred. C - DEALLOCATE called after GATHER_SOLUTION C CWORK not needed for AM1 ALLOCATE( CWORK(max(max(KEEP(247),KEEP(246)),1)), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- 89 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) C C Return in case of error. IF (INFO(1).LT.0) RETURN C ------------------------------- C Assemble the solution on master C ------------------------------- C (Note: currently, if this part of code is executed, C then necessarily NBRHS_EFF = 1) C C === GATHER and SCALE solution ============== C #if defined(USE_OLD_SCALING) 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 #else IF (id%KEEP(89) .EQ. 0 .OR. .NOT. LSCAL) THEN SCALING_LOC_BWD => RDUMMY_TARGET ELSE IF (SOLVET.EQ.1) THEN SCALING_LOC_BWD => id%COLSCA_loc ELSE SCALING_LOC_BWD => id%ROWSCA_loc ENDIF ENDIF #endif LIW_PASSED = max( LIW, 1 ) C Solution computed during ZMUMPS_SOL_C has been stored C in id%RHSINTR and is gathered on the master in C_Y IF ( .NOT. I_AM_SLAVE ) THEN C I did not participate to computing part of the solution C (id%RHSINTR not set/allocate) : receive solution, store C it and scale it. CALL ZMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & SOLVET, C_Y, id%N, NBRHS_EFF, 1, & JDUMMY, id%KEEP(1),id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), size(CWORK), #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING), #else & LSCAL, SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), #endif ! RHSINTR not on non-working master & C_DUMMY, 1 , 1, IDUMMY, 1, ! for sparse permuted RHS on host & PERM_RHS, size(PERM_RHS) & ) ELSE CALL ZMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & SOLVET, C_Y, id%N, NBRHS_EFF, 1, & id%PTLUST_S(1), id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), size(CWORK), #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING), #else & LSCAL, SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), #endif & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, NBRHS_EFF, & PTR_POSINRHSINTR_BWD(1), id%N, & PERM_RHS, size(PERM_RHS)) ! for sparse permuted RHS on host ENDIF DEALLOCATE( CWORK ) END SUBROUTINE ZMUMPS_PP_SOLVE END SUBROUTINE ZMUMPS_SOLVE_DRIVER MUMPS_5.8.1/src/sfac_asm_master_m.F0000664000175000017500000022526515042446437017024 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_ASM_MASTER_M CONTAINS SUBROUTINE SMUMPS_FAC_ASM_NIV1( COMM_LOAD, ASS_IRECV, & UU, N, INODE, IW, LIW, A, LA, INFO, ND, & FILS, FRERE, DAD, MAXFRW, root, roota, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, LRLUSM, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, JOBASS, ETATASS & , LRGROUPS & , MUMPS_TPS_ARR, SMUMPS_TPS_ARR, L0_OMP_MAPPING & ) !$ USE OMP_LIB USE MUMPS_TPS_M USE SMUMPS_TPS_M USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_PTR, & SMUMPS_DM_FREE_BLOCK USE MUMPS_BUILD_SORT_INDEX_M USE MUMPS_BUF_COMMON, ONLY: MUMPS_BUF_SEND_MAPLIG USE MUMPS_LOAD USE SMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE, & SMUMPS_BLR_ASM_NIV1 USE SMUMPS_LR_DATA_M, ONLY : SMUMPS_BLR_INIT_FRONT, & SMUMPS_BLR_SAVE_NFS4FATHER USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N, NSTEPS INTEGER(8) LA, LRLU, LRLUS, LRLUSM, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) REAL UU INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS, LIW TYPE (MUMPS_TPS_T), TARGET, OPTIONAL :: MUMPS_TPS_ARR(:) TYPE (SMUMPS_TPS_T), TARGET, OPTIONAL :: SMUMPS_TPS_ARR(:) INTEGER, INTENT(IN), OPTIONAL :: L0_OMP_MAPPING(:) INTEGER IDUMMY(1) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER, TARGET :: IW(LIW) INTEGER(8), INTENT(IN) :: PTRARW(1), PTRAIW(1) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ITLOC(N+KEEP(253)), & ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)), & PAMASTER(KEEP(28)) INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER JOBASS,ETATASS LOGICAL SON_LEVEL2 REAL, TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR REAL DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) LOGICAL PACKED_CB, IS_CB_LR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF LOGICAL LPOK INTEGER NBPANELS_L, NBPANELS_U INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER(8) NFRONT8, LAELL8, LAELL_REQ8, ITMP8, KEEP8TMPCOPY INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER LREQ_OOC INTEGER :: SON_XXS, SON_XXLR, SON_XXG INTEGER(8) LSTK8, SIZFR8 LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM, IORG, IBROT INTEGER IARR1 #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER JPOS,ICT11 INTEGER IJROW,NBCOL,NUMORG,IOLDPS INTEGER(8) IACHK, POSELT, LAPOS2, IACHK_ini INTEGER(8) APOS, APOS2, APOS3, POSEL1, ICT12 INTEGER(8) :: JJ2, ICT13 INTEGER(8) :: J18, J28, J38, J48, JJ8 INTEGER(8) :: AINPUT8 INTEGER :: K1, K2, K3, KK, KK1 INTEGER :: J253 INTEGER NSLAVES, NSLSON, NPIVS,NPIV_ANA,NPIV INTEGER PTRCOL, ISLAVE, PDEST,LEVEL INTEGER ISON_IN_PLACE LOGICAL SKIP_TOP_STACK INTEGER ISON_TOP INTEGER(8) SIZE_ISON_TOP8, DYN_SIZE_ISON_TOP8 LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE !$ LOGICAL OMP_PARALLEL_FLAG LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE INTEGER INDX, FIRST_INDEX, SHIFT_INDEX INTEGER PARPIV_T1 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: ITHREAD INTEGER, POINTER :: SON_IWPOS, SON_LIW INTEGER, POINTER, DIMENSION(:) :: SON_IW REAL, POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTEGER PIVOT_OPTION REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER NELT, LPTRAR EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR LOGICAL SSARBR DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR !$ NOMP = OMP_GET_MAX_THREADS() LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) NELT = 1 LPTRAR = 1 NFS4FATHER = -1 PACKED_CB = .FALSE. IS_CB_LR = .FALSE. IN = INODE LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (LEVEL.NE.1) THEN WRITE(*,*) 'INTERNAL ERROR 1 in SMUMPS_FAC_ASM_NIV1 ' CALL MUMPS_ABORT() END IF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) IF (JOBASS.EQ.0) THEN ETATASS= 0 ELSE ETATASS= 2 IOLDPS = PTLUST(STEP(INODE)) NFRONT = IW(IOLDPS + KEEP(IXSZ)) NASS1 = abs(IW(IOLDPS + 2 + KEEP(IXSZ))) ICT11 = IOLDPS + HF - 1 + NFRONT SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 ISON = FRERE(STEP(ISON)) ENDDO ENDIF GOTO 123 ENDIF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) END DO NPIV_ANA=NUMORG NSTEPS = NSTEPS + 1 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 SON_IW => IW IF (KEEP(400).GT.0) THEN IF (present(L0_OMP_MAPPING)) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .NE.0) THEN SON_IW=>MUMPS_TPS_ARR(ITHREAD)%IW ENDIF ENDIF ENDIF NASS = NASS + SON_IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG CALL IS_FRONT_BLR_CANDIDATE(INODE, 1, ND(STEP(INODE)), & NUMORG, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, KEEP(280), LRGROUPS) IF (DAD(STEP(INODE)).NE.0) THEN IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199) ) & .NE. MYID & .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199)) & .EQ.1 & ) THEN IF (LRSTATUS.EQ.1 .OR. LRSTATUS.EQ.3) THEN LRSTATUS = LRSTATUS-1 ENDIF ENDIF ENDIF COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_OOC_GET_PP_SIZES(KEEP(50), NFRONT, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL SMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, SLAVEF, & PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'INTERNAL ERROR 2 after compress ' WRITE(LP, * ) 'IN SMUMPS_FAC_ASM_NIV1 ' WRITE(LP, * ) 'LRLU,LRLUS=', LRLU,LRLUS ENDIF GOTO 270 END IF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 END IF IOLDPS = IWPOS IWPOS = IWPOS + LREQ ISON_TOP = -9999 ISON_IN_PLACE = -9999 SIZE_ISON_TOP8 = 0_8 IF (KEEP(234).NE.0) THEN IF ( IWPOSCB .NE. LIW ) THEN IF ( IWPOSCB+IW(IWPOSCB+1+XXI).NE.LIW) THEN ISON = IW( IWPOSCB + 1 + XXN ) IF ( DAD( STEP( ISON ) ) .EQ. INODE .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)),KEEP(199)) & .EQ. 1 ) & THEN ISON_TOP = ISON CALL MUMPS_GETI8(SIZE_ISON_TOP8,IW(IWPOSCB + 1 + XXR)) CALL MUMPS_GETI8(DYN_SIZE_ISON_TOP8, IW(IWPOSCB + 1 + XXD)) IF (DYN_SIZE_ISON_TOP8 .EQ. 0_8) THEN IF (LRLU .LT. int(NFRONT,8) * int(NFRONT,8)) THEN ISON_IN_PLACE = ISON ENDIF ENDIF END IF END IF END IF END IF NIV1 = .TRUE. IF (.NOT. present(MUMPS_TPS_ARR).AND. & .NOT. present(L0_OMP_MAPPING) ) THEN CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP, KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, IDUMMY, LIDUMMY ) ELSE CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP, KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, IDUMMY, LIDUMMY & , MUMPS_TPS_ARR, L0_OMP_MAPPING ) ENDIF IF (INFO(1).LT.0) GOTO 300 IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL MUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1-FLOP1_EFF, & KEEP,KEEP8) ENDIF IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) ' INTERNAL ERROR 3 ', & ' IN SMUMPS_FAC_ASM_NIV1 ', & ' NFRONT, NFRONT_EFF = ', & NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF NCB = NFRONT - NASS1 MAXFRW = max(MAXFRW, NFRONT) ICT11 = IOLDPS + HF - 1 + NFRONT CALL SMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) PIVOT_OPTION = KEEP(468) IF (UU.EQ.ZERO) THEN PIVOT_OPTION=0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF(PARPIV_T1.NE.0) THEN LAELL8 = LAELL8+int(NASS1,8) ENDIF LAELL_REQ8 = LAELL8 IF ( ISON_IN_PLACE > 0 ) THEN LAELL_REQ8 = LAELL8 - SIZE_ISON_TOP8 ENDIF SKIP_TOP_STACK = (ISON_IN_PLACE.GT.0) CALL SMUMPS_GET_SIZE_NEEDED & (0, LAELL_REQ8, SKIP_TOP_STACK, & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 LRLUSM = min( LRLUS, LRLUSM ) ITMP8 = LAELL8 - SIZE_ISON_TOP8 IF (KEEP(405).EQ.0) THEN KEEP8(69) = KEEP8(69) + ITMP8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + ITMP8 KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ENDIF POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8-SIZE_ISON_TOP8, & KEEP,KEEP8, & LRLUS) IF (KEEP(405).EQ.0) KEEP(429)= KEEP(429)+1 #if defined(ZERO_TRIANGLE) LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) !$ CHUNK8=int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (LAPOS2 - POSELT + 1_8 > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8), KEEP(218))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & NCB, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1,TOPDIAG) ENDIF IF (ETATASS.EQ.1) THEN IF (KEEP(234).NE.0) THEN WRITE(*,*) & "Internal error: ETATASS.EQ.1 and IN-PLACE ACTIVATED" CALL MUMPS_ABORT() ENDIF #if defined(__ve__) !NEC$ IVDEP #endif !$ CHUNK = max( KEEP(360)/2, (NFRONT+NOMP-1) / NOMP ) !$OMP PARALLEL DO PRIVATE(APOS, JJ3) SCHEDULE( STATIC, CHUNK ) !$OMP& IF (NFRONT8 - 1_8 > KEEP(360)) DO JJ8 = 0_8, NFRONT8 - 1_8 JJ3 = min(JJ8+TOPDIAG,int(NASS1-1,8)) APOS = POSELT + JJ8 * NFRONT8 A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO ELSE NUMROWS = min(NFRONT8, (IPTRLU-POSELT) / NFRONT8 ) !$ CHUNK = max(KEEP(360)/2, !$ & ( ((int(NUMROWS)+NOMP-1) / NOMP + 2) / 3) ) #if defined(__ve__) !NEC$ IVDEP #endif !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK ) !$OMP& IF (int(NUMROWS - 1) .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = POSELT + JJ8 * NFRONT8 JJ3 = min( NFRONT8 - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS + JJ3) = ZERO ENDDO !$OMP END PARALLEL DO IF( NUMROWS .LT. NFRONT8 ) THEN APOS = POSELT + NFRONT8*NUMROWS A(APOS : min(IPTRLU,APOS+NUMROWS)) = ZERO ENDIF ENDIF END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS IW(IOLDPS + KEEP(IXSZ)) = NFRONT IW(IOLDPS + KEEP(IXSZ)+ 1) = 0 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN CALL SMUMPS_BLR_INIT_FRONT (IW(IOLDPS+XXF), INFO, & MTK405=KEEP(405)) IF (INFO(1).LT.0) GOTO 500 ENDIF ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL SMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) CALL SMUMPS_BLR_SAVE_NFS4FATHER ( IW(IOLDPS+XXF), & ESTIM_NFS4FATHER_ATSON ) IF (INFO(1).LT.0) GOTO 500 ENDIF ENDIF ENDIF 123 CONTINUE IF (NUMSTK.NE.0) THEN IF (ISON_TOP > 0) THEN ISON = ISON_TOP ELSE ISON = IFSON ENDIF DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_LIW => LIW SON_IWPOS => IWPOS SON_A => A ITHREAD = 0 IF (KEEP(400).GT.0) THEN IF (present(L0_OMP_MAPPING)) THEN ITHREAD=L0_OMP_MAPPING(STEP(ISON)) IF (ITHREAD .NE.0) THEN SON_LIW => MUMPS_TPS_ARR(ITHREAD)%LIW SON_IW => MUMPS_TPS_ARR(ITHREAD)%IW SON_IWPOS => MUMPS_TPS_ARR(ITHREAD)%IWPOS SON_A => SMUMPS_TPS_ARR(ITHREAD)%A ENDIF ENDIF ENDIF LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + KEEP(IXSZ) + 1) NPIVS = SON_IW(ISTCHK + KEEP(IXSZ) + 3) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = SON_IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.SON_IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT = PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT = ISTCHK ENDIF SON_XXS = SON_IW(ISTCHK_CB_RIGHT+XXS) SON_XXLR = SON_IW(ISTCHK_CB_RIGHT+XXLR) SON_XXG = SON_IW(ISTCHK_CB_RIGHT+XXG) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IS_CB_LR = ( SON_XXLR.EQ.1 .OR. SON_XXLR.EQ.3 ) & .AND. (KEEP(489).EQ.1.OR.KEEP(489).EQ.3) LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = SON_IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF K1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN K2 = K1 + LSTK - 1 IF (PACKED_CB) THEN SIZFR8 = (LSTK8*(LSTK8+1_8)/2_8) ELSE SIZFR8 = LSTK8*LSTK8 ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * LSTK8 ELSE IF (PACKED_CB) THEN SIZFR8 = int(NELIM,8) * int(NELIM+1,8)/2_8 ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) ENDIF END IF K2 = K1 + NELIM - 1 ENDIF IF (JOBASS.EQ.0) THEN IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + LSTK8*LSTK8 ELSE OPASSW = OPASSW + LSTK8*(LSTK8+1)/2_8 ENDIF ELSE IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + int(NELIM,8)*LSTK8 ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM,8)/2_8 ENDIF ENDIF ENDIF CALL MUMPS_GETI8(DYN_SIZE, SON_IW(ISTCHK_CB_RIGHT+XXD)) IS_DYNAMIC_CB = DYN_SIZE .GT. 0_8 IF ( IS_DYNAMIC_CB ) THEN CALL SMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) ENDIF IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (NFRONT .EQ. LSTK.AND. ISON.EQ.ISON_IN_PLACE & .AND.IACHK + SIZFR8 - 1_8 .EQ. POSFAC - 1_8 ) THEN GOTO 205 ENDIF IF (K2.GE.K1) THEN RESET_TO_ZERO = (IACHK .LT. POSFAC .AND. & ISON.EQ.ISON_IN_PLACE) RISK_OF_SAME_POS = IACHK + SIZFR8 - 1_8 .EQ. POSFAC - 1_8 & .AND. ISON.EQ.ISON_IN_PLACE RISK_OF_SAME_POS_THIS_LINE = .FALSE. IACHK_ini = IACHK !$ OMP_PARALLEL_FLAG = (RESET_TO_ZERO.EQV..FALSE.).AND. !$ & ((K2-K1).GT.KEEP(360)) !$OMP PARALLEL IF(OMP_PARALLEL_FLAG) PRIVATE(APOS, KK1, JJ2,IACHK) !$OMP& FIRSTPRIVATE(RISK_OF_SAME_POS_THIS_LINE,RESET_TO_ZERO) !$OMP DO DO 170 KK = K1, K2 APOS = POSEL1 + int(SON_IW(KK),8) * int(NFRONT,8) IACHK = IACHK_ini + int(KK-K1,8)*int(LSTK,8) IF (RESET_TO_ZERO) THEN IF (RISK_OF_SAME_POS) THEN IF (KK.EQ.K2) THEN RISK_OF_SAME_POS_THIS_LINE = & (ISON .EQ. ISON_IN_PLACE) & .AND. ( APOS + int(SON_IW(K1+LSTK-1)-1,8).EQ. & IACHK+int(LSTK-1,8) ) ENDIF ENDIF IF ((IACHK .GE. POSFAC).AND.(KK>K1))THEN RESET_TO_ZERO =.FALSE. ENDIF IF (RISK_OF_SAME_POS_THIS_LINE) THEN DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1 + KK1 - 1) - 1,8) IF ( IACHK+int(KK1-1,8) .NE. JJ2 ) THEN A(JJ2) = A(IACHK + int(KK1 - 1,8)) A(IACHK + int(KK1 -1,8)) = ZERO ENDIF ENDDO ELSE #if defined(__ve__) !NEC$ IVDEP #endif DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(IACHK + int(KK1 - 1,8)) A(IACHK + int(KK1 -1,8)) = ZERO ENDDO ENDIF ELSE #if defined(__ve__) !NEC$ IVDEP #endif DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) ENDDO ENDIF 170 CONTINUE !$OMP END DO !$OMP END PARALLEL END IF ELSE IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (ISON .EQ. ISON_IN_PLACE) THEN CALL SMUMPS_LDLT_ASM_NIV12_IP(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB) ELSE IF (SIZFR8 .GT. 0) THEN CALL SMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF ENDIF IF (IS_CB_LR .AND. LEVEL1) THEN POSEL1 = PTRAST(STEP(INODE)) CALL SMUMPS_BLR_ASM_NIV1 (A, LA, & POSEL1, NFRONT, NASS1, SON_IW(ISTCHK+XXF), & SON_IW, SON_LIW, & LSTK, NELIM, K1, K1+LSTK-1, KEEP(50), & KEEP, KEEP8, OPASSW) ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF ((SAME_PROC).AND.ETATASS.NE.1) THEN IF (KEEP(50).NE.0) THEN K2 = K1 + LSTK - 1 #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K1, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO ELSE K2 = K1 + LSTK - 1 K3 = K1 + NELIM #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K3, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO IF (NELIM .NE. 0) THEN K3 = K3 - 1 #if defined(__ve__) !NEC$ IVDEP #endif DO KK = K1, K3 JPOS = SON_IW(KK) + ICT11 SON_IW(KK) = IW(JPOS) ENDDO ENDIF ENDIF ENDIF IF (ETATASS.NE.1) THEN IF ( SAME_PROC ) THEN PTRIST(STEP(ISON)) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF IF (ITHREAD .EQ. 0) THEN CALL SMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & (ISON .EQ. ISON_TOP) & ) ELSE CALL MUMPS_LOAD_DISABLE() CALL SMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & MUMPS_TPS_ARR(ITHREAD)%IW(1), & MUMPS_TPS_ARR(ITHREAD)%LIW, & MUMPS_TPS_ARR(ITHREAD)%LRLU, & MUMPS_TPS_ARR(ITHREAD)%LRLUS, & MUMPS_TPS_ARR(ITHREAD)%IPTRLU, & MUMPS_TPS_ARR(ITHREAD)%IWPOSCB, & MUMPS_TPS_ARR(ITHREAD)%LA, KEEP,KEEP8, .FALSE. & ) CALL MUMPS_LOAD_ENABLE() ENDIF IF (IS_DYNAMIC_CB) THEN CALL SMUMPS_DM_FREE_BLOCK(SON_XXG, & SON_A, SIZFR8, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF ELSE PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP, KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL SMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, IDUMMY, & NFRONT, NASS1, NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & IZERO, IDUMMY, IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP, KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE., LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) IF (ISON .LE. 0) THEN ISON = IFSON ENDIF 220 CONTINUE END IF IF (ETATASS.EQ.2) GOTO 500 POSELT = PTRAST(STEP(INODE)) IBROT = INODE IARR1 = PTRDEBARR(STEP(INODE)) DO 260 IORG = 1, NUMORG AINPUT8 = PTR8ARR(IARR1+IORG-1) J18 = AINPUT8 J28 = J18 + NINCOLARR(IARR1+IORG-1) J38 = J28 + 1 J48 = J28 + NINROWARR(IARR1+IORG-1) IJROW = INTARR(J18) ICT12 = POSELT + int(IJROW - NFRONT - 1,8) #if defined(__ve__) IF ( KEEP(265).NE. 0 ) THEN !NEC$ IVDEP #endif DO JJ8 = J18, J28 APOS2 = ICT12 + int(INTARR(JJ8),8) * NFRONT8 A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + 1_8 ENDDO #if defined(__ve__) ELSE DO JJ8 = J18, J28 APOS2 = ICT12 + int(INTARR(JJ8),8) * NFRONT8 A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + 1_8 ENDDO ENDIF #endif IF (J38 .LE. J48) THEN ICT13 = POSELT + int(IJROW - 1,8) * NFRONT8 NBCOL = int(J48 - J38 + 1_8) #if defined(__ve__) IF ( KEEP(265) .NE. 0 ) THEN !NEC$ IVDEP #endif DO JJ8 = 1_8, int(NBCOL,8) APOS3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8) - 1_8,8) A(APOS3) = A(APOS3) + DBLARR(AINPUT8 + JJ8 - 1_8) ENDDO #if defined(__ve__) ELSE DO JJ8 = 1_8, int(NBCOL,8) APOS3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8) - 1_8,8) A(APOS3) = A(APOS3) + DBLARR(AINPUT8 + JJ8 - 1_8) ENDDO ENDIF #endif ENDIF IF (KEEP(50).EQ.0) THEN DO J253=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ELSE DO J253=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+J253-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE IF (PARPIV_T1.NE.0.AND.(.NOT.SON_LEVEL2)) THEN IOLDPS = PTLUST(STEP(INODE)) CALL SMUMPS_PARPIVT1_SET_NVSCHUR_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1, NASS) ENDIF GOTO 500 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING SMUMPS_FAC_ASM' ENDIF GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING SMUMPS_FAC_ASM' ENDIF INFO(1) = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, RECV BUFFER TOO SMALL DURING SMUMPS_FAC_ASM' ENDIF INFO(1) = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF( INFO(1).EQ.-13 ) THEN IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING SMUMPS_FAC_ASM' ENDIF INFO(2) = NUMSTK + 1 ENDIF 490 CONTINUE IF ( KEEP(405) .EQ. 0 ) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_ASM_NIV1 SUBROUTINE SMUMPS_FAC_ASM_NIV2(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, INFO, & ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, roota, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, MEM_DISTRIB & , LRGROUPS & ) !$ USE OMP_LIB USE MUMPS_BUILD_SORT_INDEX_M USE MUMPS_BUF_COMMON, ONLY: MUMPS_BUF_SEND_MAPLIG, & MUMPS_BUF_SEND_DESC_BANDE USE MUMPS_LOAD USE SMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_PTR, & SMUMPS_DM_IS_DYNAMIC USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC, LA INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE, MAXFRW, LPOOL, LEAF, & IWPOS, IWPOSCB, COMP, SLAVEF REAL, TARGET :: A(LA) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(1), PTRAIW(1) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PROCNODE_STEPS(KEEP(28)), BUFR(LBUFR) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR REAL DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INTEGER LP, HS, HF, HF_OLD, NCBSON, NSLAVES_OLD LOGICAL LPOK INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL REAL, DIMENSION(:), POINTER :: SON_A INTEGER :: MAXWASTEDPROCS PARAMETER (MAXWASTEDPROCS=1) INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER I INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER :: SON_XXS INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL PACKED_CB, IS_CB_LR INTEGER(8) :: LCB LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER MP INTEGER :: K1, K2, KK, KK1 INTEGER :: J253 INTEGER(8) :: AINPUT8, J18, J28, J38, J48, JJ8 INTEGER(8) :: LAPOS2, JJ2, JJ3 INTEGER(8) :: ICT13 INTEGER(8) :: IACHK, APOS, APOS2, POSELT, ICT12, POSEL1 #if ! defined(ZERO_TRIANGLE) INTEGER :: TOPDIAG #endif !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM,NPIVS,NCOLS,NROWS, & IORG INTEGER LDAFS, LDA_SON, IJROW, IBROT INTEGER IARR1 INTEGER NBCOL,NUMORG,IOLDPS, NUMORG_SPLIT INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, PDEST INTEGER PDEST1(1) INTEGER :: ISLAVE INTEGER TYPESPLIT INTEGER ISON_IN_PLACE LOGICAL IS_ofType5or6, SPLIT_MAP_RESTART INTEGER NMB_OF_CAND, NMB_OF_CAND_ORIG LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER IZERO INTEGER IDUMMY(1) PARAMETER( IZERO = 0 ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT REAL ZERO REAL RZERO PARAMETER( RZERO = 0.0E0 ) PARAMETER( ZERO = 0.0E0 ) INTEGER NELT, LPTRAR logical :: force_cand INTEGER ETATASS INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX REAL MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER, ALLOCATABLE, DIMENSION(:) :: SONROWS_PER_ROW INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IS_ofType5or6 = .FALSE. PACKED_CB = .FALSE. ETATASS = 0 IN = INODE NSTEPS = NSTEPS + 1 KEEP(429) = KEEP(429)+1 NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON NCBSON_MAX = 0 NELT = 1 LPTRAR = 1 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 IF ( KEEP(48)==5 .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) ENDIF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 CALL IS_FRONT_BLR_CANDIDATE(INODE, 2, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, KEEP(280), LRGROUPS) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then force_cand=.FALSE. ELSE force_cand=(mod(KEEP(24),2).eq.0) end if TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) SPLIT_MAP_RESTART = .FALSE. IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) NMB_OF_CAND = CAND( SLAVEF+1, INIV2 ) NMB_OF_CAND_ORIG = NMB_OF_CAND SIZE_TMP_SLAVES_LIST = NMB_OF_CAND IF (IS_ofType5or6) THEN DO I=NMB_OF_CAND+1,SLAVEF IF ( CAND( I, INIV2 ).LT.0) EXIT NMB_OF_CAND = NMB_OF_CAND +1 ENDDO SIZE_TMP_SLAVES_LIST = NSLSON-1 IF (INODE.EQ.-999999) THEN SPLIT_MAP_RESTART = .TRUE. ENDIF ENDIF IF (IS_ofType5or6.AND.SPLIT_MAP_RESTART) THEN TYPESPLIT = 4 IS_ofType5or6 = .FALSE. SIZE_TMP_SLAVES_LIST = NMB_OF_CAND CAND (SLAVEF+1, INIV2) = SIZE_TMP_SLAVES_LIST ENDIF ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 NMB_OF_CAND = SLAVEF - 1 NMB_OF_CAND_ORIG = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF IF ( (TYPESPLIT.EQ.4) & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) & ) THEN IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) IF (SPLIT_MAP_RESTART) THEN IS_ofType5or6 = .TRUE. TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) CAND( SLAVEF+1, INIV2 ) = NMB_OF_CAND_ORIG ENDIF ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) IF (KEEP(376) .EQ. 1) THEN NFRONT = IW( PIMASTER(STEP(IFSON)) + KEEP(IXSZ)) ENDIF CALL MUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND(1,INIV2), NMB_OF_CAND_ORIG, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES, & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST & ) ENDIF ELSE CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_OOC_GET_PP_SIZES(KEEP(50), NASS1, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL SMUMPS_COMPRE_NEW(N, KEEP, & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & LRLUS,KEEP(IXSZ), & COMP, DKEEP(97), MYID, SLAVEF, & PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress SMUMPS_FAC_ASM_NIV2 ', & 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. ALLOCATE(SONROWS_PER_ROW(NFRONT-NASS1), stat=allocok) IF (allocok > 0) THEN GOTO 275 ENDIF ISON_IN_PLACE = -9999 CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP,KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, SONROWS_PER_ROW, & NFRONT-NASS1 ) IF (INFO(1).LT.0) GOTO 250 IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN WRITE(*,*) ' Internal error 1 in fac_ass due to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF WRITE(*,*) ' SPLITTING NOT YET READY FOR THAT' CALL MUMPS_ABORT() ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN NCB = NFRONT_EFF - NASS1 NSLAVES_OLD = NSLAVES HF_OLD = HF IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE CALL MUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP, KEEP8, ICNTL, & CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - & (NSLAVES_OLD - NSLAVES) IF (NSLAVES_OLD .NE. NSLAVES) THEN IF (NSLAVES_OLD > NSLAVES) THEN DO KK=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+KK)=IW(IOLDPS+HF_OLD+KK) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO KK=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+KK) = IW(IOLDPS+HF_OLD+KK) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) MYID,': INTERNAL ERROR 2 ', & ' IN SMUMPS_FAC_ASM_NIV2 , INODE=', & INODE, ' NFRONT, NFRONT_EFF=', NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max(MAXFRW, NFRONT) PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+KEEP(IXSZ)) = NFRONT IW(IOLDPS + 1+KEEP(IXSZ)) = 0 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+NSLAVES+KEEP(IXSZ))= & TMP_SLAVES_LIST(1:NSLAVES) ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL SMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) ENDIF ENDIF ENDIF CALL MUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM_LOAD, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP, KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) IF(KEEP(86).EQ.1)THEN IF(mod(KEEP(24),2).eq.0)THEN CALL MUMPS_LOAD_SEND_MD_INFO(SLAVEF, & CAND(SLAVEF+1,INIV2), & CAND(1,INIV2), & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN CALL MUMPS_LOAD_SEND_MD_INFO(SLAVEF, & SLAVEF-1, & TMP_SLAVES_LIST, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ENDIF ENDIF DEALLOCATE(TMP_SLAVES_LIST) IF (KEEP(50).EQ.0) THEN LAELL8 = int(NASS1,8) * int(NFRONT,8) LDAFS = NFRONT ELSE LAELL8 = int(NASS1,8)*int(NASS1,8) IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) & LAELL8 = LAELL8+int(NASS1,8) LDAFS = NASS1 ENDIF CALL SMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= LRSTATUS IW(IOLDPS+XXG) = MemNotPinned CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8,LRLUS) POSEL1 = POSELT - int(LDAFS,8) #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8 = int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (LAPOS2 - POSELT > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO JJ8 = POSELT, LAPOS2 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max(KEEP(360)/2, !$ & ( (( LDAFS + NOMP -1 ) / NOMP + 2) / 3) ) APOS = POSELT #if defined(__ve__) !NEC$ IVDEP #endif !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK) !$OMP& IF (LDAFS - 1 .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(LDAFS-1,8) APOS = POSELT + JJ8 * int(LDAFS,8) JJ3 = min( int(LDAFS,8) - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) A(APOSMAX:APOSMAX+int(LDAFS-1,8))=ZERO ENDIF END IF #endif IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) IF (NELIM.EQ.0) GOTO 210 LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT=PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT=ISTCHK ENDIF SON_XXS = IW(ISTCHK_CB_RIGHT + XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF IF (KEEP(50).EQ.0) THEN LDA_SON = LSTK LCB = int(NELIM,8)*int(LSTK,8) ELSE IF (NSLSON.EQ.0) THEN IF (SAME_PROC) THEN IS_CB_LR = IW(ISTCHK_CB_RIGHT+XXLR).EQ. 1 .OR. & IW(ISTCHK_CB_RIGHT+XXLR).EQ. 3 IF (IS_CB_LR) THEN LDA_SON = NELIM ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = NELIM ENDIF IF (PACKED_CB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN OPASSW = OPASSW + dble(LCB) ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM+1,8)/2_8 ENDIF IS_DYNAMIC_CB = & SMUMPS_DM_IS_DYNAMIC(IW(ISTCHK_CB_RIGHT+XXD: & ISTCHK_CB_RIGHT+XXD+1)) IF ( IS_DYNAMIC_CB ) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_CB_RIGHT+XXD)) CALL SMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) SON_A=>A ENDIF K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IF (KEEP(50).eq.0) THEN IF (IS_ofType5or6) THEN APOS = POSELT DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + SON_A(IACHK+JJ8-1_8) ENDDO ELSE DO 170 KK = K1, K2 APOS = POSEL1 + int(IW(KK),8) * int(LDAFS,8) DO 160 KK1 = 1, LSTK JJ2 = APOS + int(IW(K1 + KK1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (LCB .GT. 0) THEN CALL SMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF IBROT = INODE APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) IARR1 = PTRDEBARR(STEP(INODE)) DO 260 IORG = 1, NUMORG AINPUT8 = PTR8ARR(IARR1+IORG-1) J18 = AINPUT8 J28 = J18 + NINCOLARR(IARR1+IORG-1) J38 = J28 + 1_8 J48 = J28 + NINROWARR(IARR1+IORG-1) IJROW = INTARR(J18) ICT12 = POSELT + int(IJROW - 1 - LDAFS, 8) MAXARR = RZERO DO JJ8 = J18, J28 IF (KEEP(219).NE.0) THEN IF (INTARR(JJ8).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ8),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) ELSEIF (KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AINPUT8))) ENDIF ELSE IF (INTARR(JJ8).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ8),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) ENDIF ENDIF AINPUT8 = AINPUT8 + 1_8 ENDDO IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(IJROW-1,8)) = MAXARR ENDIF IF (J38 .GT. J48) GOTO 255 ICT13 = POSELT + int(IJROW - 1,8) * int(LDAFS,8) NBCOL = int(J48 - J38 + 1_8) DO JJ8 = 1_8, int(NBCOL,8) JJ3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8),8) - 1_8 A(JJ3) = A(JJ3) + DBLARR(AINPUT8 + JJ8 - 1_8) ENDDO 255 CONTINUE IF (KEEP(50).EQ.0) THEN DO J253 = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & NBLIG, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 IERR = -1 DO WHILE (IERR .EQ.-1) IF ( KEEP(50) .eq. 0 ) THEN NBCOL = NFRONT CALL MUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL MUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF ENDDO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 ENDDO DEALLOCATE(SONROWS_PER_ROW) IF (NUMSTK.EQ.0) GOTO 500 ISON = IFSON DO IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + 2 + KEEP(IXSZ) ) ELSE NROWS = NCOLS ENDIF PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN NFS4FATHER = NCBSON DO I=0,NCBSON-1 IF(IW(PTRCOL+I) .GT. NASS1) THEN NFS4FATHER = I EXIT ENDIF ENDDO NFS4FATHER = NFS4FATHER + NELIM ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) IF (PDEST1(1).EQ.MYID) THEN CALL SMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & NFRONT, NASS1, NFS4FATHER, NCBSON, IW( PTRCOL ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, roota, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, PDEST1, NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, & NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL SMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & NFRONT, NASS1,NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), INFO(2), & MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, LPTRAR, NELT, IW, & IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & SMUMPS_FAC_ASM_NIV2' ENDIF INFO(2) = NUMSTK + 1 ENDIF GOTO 490 245 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING COPY_CAND', & ' DURING SMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = SLAVEF+1 GOTO 490 265 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING SMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING SMUMPS_FAC_ASM_NIV2' ENDIF GOTO 490 275 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING SONROWS_PER_ROW', & ' DURING SMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = NFRONT-NASS1 GOTO 490 290 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (1) DURING SMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (1) DURING SMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (2)', &' DURING SMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (2)', &' DURING SMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -20 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 490 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_ASM_NIV2 END MODULE SMUMPS_FAC_ASM_MASTER_M MUMPS_5.8.1/src/mumps_thread_affinity.c0000664000175000017500000000114315042446422017754 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mumps_thread_affinity.h" void MUMPS_CALL MUMPS_THREAD_AFFINITY_RETURN() { /* * Thread affinity tools will be available in the future. */ } MUMPS_5.8.1/src/zfac_process_maprow.F0000664000175000017500000023134715042446441017420 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE ZMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW, & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, & LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_BUF USE MUMPS_LOAD USE ZMUMPS_LR_DATA_M USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR USE ZMUMPS_FAC_FRONT_AUX_M, ONLY : ZMUMPS_GET_SIZE_SCHUR_IN_FRONT #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE #if ! defined(NO_FDM_MAPROW) #endif TYPE (MUMPS_ROOT_STRUC ) :: root TYPE (ZMUMPS_ROOT_STRUC ) :: roota INTEGER LBUFR, LBUFR_BYTES INTEGER ICNTL( 60 ), KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER COMP INTEGER NSTK( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM, MYID INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER INODE_PERE, ISON INTEGER :: NFS4FATHER INTEGER NBROWS_ALREADY_SENT INTEGER NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE( * ) INTEGER LMAP INTEGER TROW( LMAP ) DOUBLE PRECISION OPASSW, OPELIW COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER NOSLA, I INTEGER I_POSMYIDIN_PERE INTEGER INDICE_PERE INTEGER PDEST, PDEST_MASTER LOGICAL :: LOCAL_ASSEMBLY_TO_BE_DONE INTEGER NROWS_TO_SEND INTEGER PDEST_MASTER_ISON, IPOS_IN_SLAVE LOGICAL DESCLU, SLAVE_ISON LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG INTEGER LP LOGICAL PACKED_CB LOGICAL IS_ERROR_BROADCASTED, IS_ofType5or6 INTEGER ITYPE_SON, TYPESPLIT INTEGER :: KEEP253_LOC INTEGER :: NVSCHUR, NSLAVES_L, NROW_L, IROW_L, NASS_L, NELIM_L LOGICAL :: CB_IS_LR INTEGER :: IWXXF_HANDLER COMPLEX(kind=8) :: ADummy(1) COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: IACHK, RECSIZE #if ! defined(NO_FDM_MAPROW) INTEGER :: INFO_TMP(2) #endif INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM_LOC IS_ERROR_BROADCASTED = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) ITYPE_SON = MUMPS_TYPENODE( PROCNODE_STEPS(STEP(ISON)), & KEEP(199) ) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 #if ! defined(NO_FDM_MAPROW) #endif ALLOCATE(SLAVES_PERE(0:max(1,NSLAVES_PERE)), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) THEN write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in ZMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 endif IF (NSLAVES_PERE.GT.0) &SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) THEN write(LP,*) MYID, & ' : PB allocation NBROW in ZMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 670 endif LMAP_LOC = LMAP ALLOCATE(MAP(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) THEN write(LP,*) MYID, ' : PB allocation LMAP in ZMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = LMAP GOTO 680 endif MAP( 1 : LMAP ) = TROW( 1 : LMAP ) PDEST_MASTER_ISON = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) SLAVE_ISON = PDEST_MASTER_ISON .NE. MYID IF (SLAVE_ISON) THEN IF ( PTRIST(STEP( ISON )) .EQ. 0 ) THEN CALL ZMUMPS_TREAT_DESCBAND( ISON, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END IF #if ! defined(NO_FDM_MAPROW) IF ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) & THEN INFO_TMP=0 CALL MUMPS_FMRD_SAVE_MAPROW( & IW(PTRIST(STEP(ISON))+XXA), & INODE_PERE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER, & SLAVES_PERE(1:NSLAVES_PERE), & MAP, & INFO_TMP) IF (INFO_TMP(1) < 0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF GOTO 670 ELSE GOTO 10 ENDIF #endif DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END DO ENDIF #if ! defined(NO_FDM_MAPROW) 10 CONTINUE #endif IF ( NSLAVES_PERE .EQ. 0 ) THEN NBROW( 0 ) = LMAP_LOC ELSE DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) NBROW( NOSLA ) = NBROW( NOSLA ) + 1 END DO DO I = 1, NSLAVES_PERE NBROW(I)=NBROW(I)+NBROW(I-1) ENDDO ENDIF ALLOCATE(PERM_LOC(LMAP_LOC), stat=allocok) IF (allocok .GT. 0) THEN IF (LP.GT.0) THEN write(LP,*) MYID,': PB allocation PERM_LOC in ZMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 670 ENDIF KEEP253_LOC = 0 DO I = LMAP_LOC, 1, -1 INDICE_PERE = MAP( I ) IF (INDICE_PERE > NFRONT_PERE - KEEP(253)) THEN KEEP253_LOC = KEEP253_LOC + 1 ENDIF CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) PERM_LOC( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO IF ((KEEP(114).EQ.1) .AND. (KEEP(50).EQ.2) .AND. & (KEEP(116).GT.0) .AND. ((LMAP_LOC-KEEP253_LOC).GT.0) & ) THEN IF (ITYPE_SON.EQ.1) THEN NELIM_L = IW(PTLUST(STEP(ISON))+1+KEEP(IXSZ)) NASS_L = NELIM_L + & IW(PTLUST(STEP(ISON))+3+KEEP(IXSZ)) IROW_L = PTLUST(STEP(ISON))+6+KEEP(IXSZ)+NASS_L NROW_L = LMAP_LOC ELSE NROW_L = LMAP_LOC NSLAVES_L = IW( PTRIST(STEP( ISON )) + 5 + KEEP(IXSZ) ) IROW_L = PTRIST(STEP(ISON)) + 6 + NSLAVES_L + KEEP(IXSZ) ENDIF CALL ZMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NROW_L-KEEP253_LOC, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR ) ELSE NVSCHUR = 0 ENDIF PDEST_MASTER = SLAVES_PERE(0) I_POSMYIDIN_PERE = -99999 LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. DO I = 0, NSLAVES_PERE IF (SLAVES_PERE(I) .EQ. MYID) THEN I_POSMYIDIN_PERE = I LOCAL_ASSEMBLY_TO_BE_DONE = .TRUE. #if ! defined(NO_FDM_DESCBAND) IF (PTRIST(STEP(INODE_PERE)) .EQ. 0 & .AND. MYID .NE. PDEST_MASTER) THEN CALL ZMUMPS_TREAT_DESCBAND( INODE_PERE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF #endif ENDIF END DO IF (KEEP(120).NE.0 .AND. LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL ZMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, LPTRAR, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 CB_IS_LR = (IW(PTRIST(STEP(ISON))+XXLR).EQ.1 .OR. & IW(PTRIST(STEP(ISON))+XXLR).EQ.3) IWXXF_HANDLER = IW(PTRIST(STEP(ISON))+XXF) DO I = NSLAVES_PERE, 0, -1 PDEST = SLAVES_PERE( I ) IF ( PDEST .NE. MYID ) THEN DESCLU = .FALSE. NBROWS_ALREADY_SENT = 0 IF (CB_IS_LR) THEN NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ENDIF IF (I == NSLAVES_PERE) THEN NROWS_TO_SEND=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_SEND=NBROW(I+1)-NBROW(I) ENDIF PACKED_CB=(IW(PTRIST(STEP(ISON))+XXS).EQ.S_CB1COMP) IERR = -1 DO WHILE (IERR .EQ. -1) IF ( IW ( PTRIST(STEP(ISON) )+KEEP(IXSZ) ) & .GT. N + KEEP(253) ) THEN WRITE(*,*) MYID,': Internal error in Maplig' WRITE(*,*) MYID,': PTRIST(STEP(ISON))/N=', & PTRIST(STEP(ISON)), N WRITE(*,*) MYID,': I, NBROW(I)=',I, NBROW(I) WRITE(*,*) MYID,': NSLAVES_PERE=',NSLAVES_PERE WRITE(*,*) MYID,': ISON, INODE_PERE=',ISON,INODE_PERE WRITE(*,*) MYID,': Son header=', & IW(PTRIST(STEP(ISON)): PTRIST(STEP(ISON))+5+KEEP(IXSZ)) CALL MUMPS_ABORT() END IF IF (NROWS_TO_SEND .EQ. 0 .AND. PDEST.NE.PDEST_MASTER) THEN IERR = 0 CYCLE ENDIF IF (CB_IS_LR) THEN CALL ZMUMPS_BUF_SEND_CONTRIB_TYPE2( NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, ISON, & NROWS_TO_SEND, LMAP_LOC, MAP, & min(LMAP_LOC,NBROW(I)), & IW( PTRIST(STEP(ISON))), & ADummy, 1_8, & I, PDEST, PDEST_MASTER, & COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PACKED_CB, & KEEP253_LOC, NVSCHUR, & ITYPE_SON, MYID ) ELSE CALL ZMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) CALL ZMUMPS_BUF_SEND_CONTRIB_TYPE2( NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, ISON, & NROWS_TO_SEND, LMAP_LOC, MAP, & min(LMAP_LOC,NBROW(I)), & IW( PTRIST(STEP(ISON))), & SON_A(IACHK:IACHK+RECSIZE-1_8), & RECSIZE, & I, PDEST, PDEST_MASTER, & COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PACKED_CB, & KEEP253_LOC, NVSCHUR, & ITYPE_SON, MYID) ENDIF IF ( IERR .EQ. -2 ) THEN IFLAG = -17 IF (LP .GT. 0) THEN WRITE(LP,*) & "FAILURE: SEND BUFFER TOO SMALL IN ZMUMPS_MAPLIG" ENDIF IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * IW(PTRIST(STEP(ISON))+KEEP(IXSZ)) & * KEEP( 35 ) GO TO 600 END IF IF ( IERR .EQ. -3 ) THEN IF (LP .GT. 0) THEN WRITE(LP,*) & "FAILURE: RECV BUFFER TOO SMALL IN ZMUMPS_MAPLIG" ENDIF IFLAG = -20 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * IW(PTRIST(STEP(ISON))+KEEP(IXSZ)) & * KEEP( 35 ) GOTO 600 ENDIF IF (KEEP(219).NE.0) THEN IF ( IERR .EQ. -4 ) THEN IFLAG = -13 IERROR = NFS4FATHER IF (LP .GT. 0) THEN WRITE(LP, *) & "FAILURE: MAX_ARRAY allocation failed IN ZMUMPS_MAPLIG" ENDIF GO TO 600 END IF END IF IF ( IERR .EQ. -1 ) THEN IF (LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL ZMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, & LPTRAR, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ELSE BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE,LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED=.TRUE. GOTO 600 ENDIF IF (.NOT. MESSAGE_RECEIVED) THEN CALL MUMPS_USLEEP(1000) ENDIF END IF END IF ENDDO ENDIF END DO IF (LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL ZMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, LPTRAR, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF IF (CB_IS_LR) THEN IF (IWXXF_HANDLER.LE.0) CALL MUMPS_ABORT() CALL ZMUMPS_BLR_FREE_CB_LRB(IWXXF_HANDLER, & .FALSE., KEEP8, KEEP(34)) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN CALL ZMUMPS_BLR_END_FRONT(IWXXF_HANDLER, IFLAG, KEEP8, & KEEP(34)) ENDIF ENDIF IF (KEEP(214) .EQ. 2) THEN CALL ZMUMPS_STACK_BAND( N, ISON, & PTRIST, PTRAST, PTLUST, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, & COMM, KEEP,KEEP8, DKEEP, ITYPE_SON ) IF (IFLAG .LT. 0) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF CALL ZMUMPS_FREE_BAND( N, ISON, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, & STEP, MYID, KEEP, KEEP8, ITYPE_SON &) 600 CONTINUE DEALLOCATE(PERM_LOC) 670 CONTINUE DEALLOCATE(MAP) 680 CONTINUE DEALLOCATE(NBROW) DEALLOCATE(SLAVES_PERE) 700 CONTINUE IF (IFLAG .LT. 0 .AND. .NOT. IS_ERROR_BROADCASTED) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE ZMUMPS_MAPLIG SUBROUTINE ZMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW, & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, & LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_BUF USE MUMPS_LOAD USE ZMUMPS_LR_TYPE USE MUMPS_LR_STATS USE ZMUMPS_FAC_FRONT_AUX_M, ONLY : ZMUMPS_GET_SIZE_SCHUR_IN_FRONT USE ZMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR & , ZMUMPS_DM_FREE_BLOCK IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER ICNTL( 60 ), KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER COMP INTEGER IFLAG, IERROR, COMM, MYID INTEGER LPOOL, LEAF INTEGER INODE_PERE, ISON INTEGER NFS4FATHER DOUBLE PRECISION, POINTER, DIMENSION(:) :: M_ARRAY LOGICAL :: M_ARRAY_RETRIEVED INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE(NSLAVES_PERE) INTEGER NELIM, LMAP, TROW( LMAP ), NASS DOUBLE PRECISION OPASSW, OPELIW COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPTRAR, NELT INTEGER IW( LIW ) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ) INTEGER NSTK( KEEP(28) ), ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PERM(N) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) 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 NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT INTEGER INDICE_PERE INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER PDEST, PDEST_MASTER, NFRONT LOGICAL SAME_PROC, DESCLU INTEGER(8) :: IACHK, POSROW, ASIZE, RECSIZE COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYNSIZE INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND, & NPIV, NROWS_TO_STACK, II, IROW_SON, & IPOS_IN_SLAVE, DECR, ITYPE_SON INTEGER NBCOLS_EFF LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL PACKED_CB LOGICAL :: CB_IS_LR INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR_COLS, NB_BLR_ROWS, & NB_BLR_SHIFT, PANEL2DECOMPRESS, & CURRENT_PANEL_SIZE, PANEL_BEG_OFFSET, & NROWS_ALREADY_STACKED, NROWS_TO_STACK_LOC INTEGER :: ICOL_BEG, ICOL_END INTEGER :: IROW_BEG, IROW_END INTEGER :: IBLOCK, MAXI_CLUSTER DOUBLE PRECISION :: PROMOTE_COST INTEGER :: NVSCHUR, IROW_L INTEGER(8) :: LA_TEMP COMPLEX(kind=8) :: ADummy(1) COMPLEX(kind=8), ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: LRB TYPE (LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER :: XXG_STATUS INCLUDE 'mumps_headers.h' COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM_LOC LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 if (NSLAVES_PERE.le.0) then write(6,*) ' error 2 in maplig_fils_niv1 ', NSLAVES_PERE CALL MUMPS_ABORT() endif ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) IF (allocok .GT. 0) THEN IF (LP > 0) & write(LP,*) MYID, & ' : PB allocation NBROW in ZMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF ALLOCATE(SLAVES_PERE(0:NSLAVES_PERE), stat =allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in ZMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) LMAP_LOC = LMAP ALLOCATE(MAP(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation LMAP in ZMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = LMAP_LOC GOTO 700 endif MAP( 1 : LMAP_LOC ) = TROW( 1 : LMAP_LOC ) DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO IF (NSLAVES_PERE == 0) THEN NBROW(0) = LMAP_LOC ELSE DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) NBROW( NOSLA ) = NBROW( NOSLA ) + 1 END DO DO I = 1, NSLAVES_PERE NBROW(I)=NBROW(I)+NBROW(I-1) ENDDO ENDIF ALLOCATE(PERM_LOC(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) THEN write(LP,*) MYID, & ': PB allocation PERM_LOC in ZMUMPS_MAPLIG_FILS_NIV1' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 700 endif ISTCHK = PIMASTER(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) DO I = LMAP_LOC, 1, -1 INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) PERM_LOC( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO PDEST_MASTER = MYID IF ( SLAVES_PERE(0) .NE. MYID ) THEN WRITE(*,*) 'Error 1 in MAPLIG_FILS_NIV1:',MYID, SLAVES_PERE CALL MUMPS_ABORT() END IF PDEST = PDEST_MASTER I = 0 ISTCHK = PIMASTER(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) NELIM = IW(ISTCHK+1+KEEP(IXSZ)) NROW = IW(ISTCHK+2+KEEP(IXSZ)) NPIV = IW(ISTCHK+3+KEEP(IXSZ)) NASS = NPIV+NELIM IF (NPIV.LT.0) THEN write(6,*) ' Error 2 in ZMUMPS_MAPLIG_FILS_NIV1 ', NPIV CALL MUMPS_ABORT() ENDIF NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) NFRONT = NPIV + NBCOLS PACKED_CB=(IW(PTRIST(STEP(ISON))+XXS) .eq. S_CB1COMP) IF (I == NSLAVES_PERE) THEN NROWS_TO_STACK=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_STACK=NBROW(I+1)-NBROW(I) ENDIF IF ((KEEP(114).EQ.1) .AND. (KEEP(50).EQ.2) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) + NASS CALL ZMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR ) ELSE NVSCHUR = 0 ENDIF DECR=1 IW(PTLUST(STEP(INODE_PERE))+XXNBPR) = & IW(PTLUST(STEP(INODE_PERE))+XXNBPR) - DECR IW(PTRIST(STEP(ISON))+XXNBPR) = & IW(PTRIST(STEP(ISON))+XXNBPR) - DECR CB_IS_LR = (IW(ISTCHK+XXLR).EQ.1 .OR. & IW(ISTCHK+XXLR).EQ.3) NROWS_ALREADY_STACKED = 0 IF (CB_IS_LR) THEN 100 CONTINUE IF (NROWS_TO_STACK.GT.0) THEN PANEL_BEG_OFFSET = 0 CALL ZMUMPS_BLR_RETRIEVE_CB_LRB( & IW(ISTCHK+XXF), CB_LRB) CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR) NB_BLR_ROWS = size(BEGS_BLR) - 1 CALL ZMUMPS_BLR_RETRIEVE_NB_PANELS(IW(ISTCHK+XXF), & NB_BLR_SHIFT) PANEL2DECOMPRESS = -1 DO II=NB_BLR_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR(II+1)-1-NASS.GT. & NROWS_ALREADY_STACKED+NBROW(I)-1) THEN PANEL2DECOMPRESS = II EXIT ENDIF ENDDO IF (PANEL2DECOMPRESS.EQ.-1) THEN write(*,*) 'Internal error: PANEL2DECOMPRESS not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR) - 1 ELSE NB_BLR_COLS = PANEL2DECOMPRESS ENDIF CURRENT_PANEL_SIZE = BEGS_BLR(PANEL2DECOMPRESS+1) & - BEGS_BLR(PANEL2DECOMPRESS) PANEL_BEG_OFFSET = NBROW(I) + NROWS_ALREADY_STACKED & - BEGS_BLR(PANEL2DECOMPRESS) + NASS NROWS_TO_STACK_LOC = & min(NROWS_TO_STACK-NROWS_ALREADY_STACKED, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) MAXI_CLUSTER = 1 DO IBLOCK=1,NB_BLR_COLS-NB_BLR_SHIFT LRB => CB_LRB(PANEL2DECOMPRESS-NB_BLR_SHIFT,IBLOCK) MAXI_CLUSTER = max(MAXI_CLUSTER, LRB%N) ENDDO LA_TEMP = NROWS_TO_STACK_LOC*MAXI_CLUSTER #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(A_TEMP, LRB, II, IBLOCK, ICOL_BEG, ICOL_END, !$OMP& allocok, PROMOTE_COST, IROW_SON, INDICE_PERE, !$OMP& POSROW, NBCOLS_EFF, IROW_BEG, IROW_END, !$OMP& INDICE_PERE_ARRAY_ARG, NOSLA, IPOS_IN_SLAVE) #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 GOTO 550 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP DO SCHEDULE(dynamic,1) #endif DO IBLOCK=1,NB_BLR_COLS-NB_BLR_SHIFT IF (IFLAG.LT.0) CYCLE ICOL_BEG = 1 DO II = 1,IBLOCK-1 LRB => CB_LRB(PANEL2DECOMPRESS-NB_BLR_SHIFT,II) ICOL_BEG = ICOL_BEG + LRB%N ENDDO LRB => CB_LRB(PANEL2DECOMPRESS-NB_BLR_SHIFT,IBLOCK) IF (LRB%ISLR .AND. LRB%K.EQ.0) CYCLE IROW_BEG = PANEL_BEG_OFFSET+1 IROW_END = PANEL_BEG_OFFSET+NROWS_TO_STACK_LOC IF (LRB%ISLR) THEN CALL zgemm('T','T', LRB%N, NROWS_TO_STACK_LOC, LRB%K, & ONE, LRB%R(1,1), LRB%K, LRB%Q(IROW_BEG,1), & LRB%M, ZERO, A_TEMP(1), LRB%N) PROMOTE_COST = 2.0D0*LRB%N*NROWS_TO_STACK_LOC*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE DO II = IROW_BEG, IROW_END A_TEMP( 1+(II-IROW_BEG)*LRB%N : (II-IROW_BEG+1)*LRB%N ) & = LRB%Q(II,1:LRB%N) ENDDO ENDIF CALL ZMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON=PERM_LOC(NBROW(I)+II-1) INDICE_PERE = MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF (PACKED_CB) THEN POSROW = IACHK + & int(NELIM+IROW_SON,8)*int(NELIM+IROW_SON-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+IROW_SON-1,8)*int(NBCOLS,8) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = NELIM + IROW_SON ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE ICOL_END = min(ICOL_BEG+LRB%N-1, NBCOLS_EFF) CALL ZMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, ICOL_END-ICOL_BEG+1, & INDICE_PERE_ARRAY_ARG, & A_TEMP(1+(II-NROWS_ALREADY_STACKED-1)*LRB%N), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS,ICOL_BEG) ENDDO ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO #endif IF (IFLAG.LT.0) GOTO 550 deallocate(A_TEMP) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) 550 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 NROWS_ALREADY_STACKED = NROWS_ALREADY_STACKED & + NROWS_TO_STACK_LOC IF (NROWS_ALREADY_STACKED.LT.NROWS_TO_STACK) THEN GOTO 100 ENDIF ENDIF ELSE CALL ZMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK IROW_SON=PERM_LOC(NBROW(I)+II-1) INDICE_PERE = MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF (PACKED_CB) THEN POSROW = IACHK + & int(NELIM+IROW_SON,8)*int(NELIM+IROW_SON-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+IROW_SON-1,8)*int(NBCOLS,8) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = NELIM + IROW_SON ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE CALL ZMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS_EFF,1) ENDDO ENDIF IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2 & .AND. NFS4FATHER .GT. 0) THEN IF (CB_IS_LR) THEN CALL ZMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW(ISTCHK+XXF), M_ARRAY) M_ARRAY_RETRIEVED = .TRUE. ELSE IF (PACKED_CB) THEN POSROW = IACHK & + int(NELIM+NBROW(1),8)*int(NELIM+NBROW(1)-1,8)/2_8 ASIZE = int(LMAP_LOC+NELIM,8)*int(NELIM+LMAP_LOC+1,8)/2_8 & - int(NELIM+NBROW(1),8)*int(NELIM+NBROW(1)-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+NBROW(1)-1,8)*int(NBCOLS,8) ASIZE = int(LMAP_LOC-NBROW(1)+1,8) * int(NBCOLS,8) ENDIF CALL ZMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP > 0) WRITE(LP,*) MYID, & ": PB allocation MAX_ARRAY during ZMUMPS_MAPLIG_FILS_NIV1" IFLAG=-13 IERROR=NFS4FATHER GOTO 700 ENDIF IF ( LMAP_LOC-NBROW(1)+1-KEEP(253)-NVSCHUR.GT. 0 ) THEN CALL ZMUMPS_COMPUTE_MAXPERCOL( & SON_A(POSROW),ASIZE,NBCOLS, & LMAP_LOC-NBROW(1)+1-KEEP(253)-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB, & NELIM+NBROW(1)) ELSE CALL ZMUMPS_SETMAXTOZERO(BUF_MAX_ARRAY, & NFS4FATHER) ENDIF M_ARRAY => BUF_MAX_ARRAY M_ARRAY_RETRIEVED = .FALSE. ENDIF CALL ZMUMPS_ASM_MAX(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & M_ARRAY(1), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB,MYID, KEEP,KEEP8) IF ( M_ARRAY_RETRIEVED ) & CALL ZMUMPS_BLR_FREE_M_ARRAY ( IW(ISTCHK+XXF) ) ENDIF ENDIF IF (IW(PTRIST(STEP(ISON))+XXNBPR) .EQ. 0 & ) THEN ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF (SAME_PROC) THEN CALL ZMUMPS_RESTORE_INDICES(N, ISON, INODE_PERE, & IWPOSCB, PIMASTER, PTLUST, IW, LIW, STEP, & KEEP,KEEP8) ENDIF ENDIF IF ( IW(PTLUST(STEP(INODE_PERE))+XXNBPR) .EQ. 0 & ) THEN CALL ZMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, INODE_PERE+N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 DO I = 0, NSLAVES_PERE PDEST = SLAVES_PERE( I ) IF ( PDEST .NE. MYID ) THEN NBROWS_ALREADY_SENT = 0 IF (CB_IS_LR) THEN NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ENDIF 95 CONTINUE NFRONT = IW(PIMASTER(STEP(ISON))+KEEP(IXSZ)) NELIM = IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) DESCLU = .TRUE. IF (I == NSLAVES_PERE) THEN NROWS_TO_SEND=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_SEND=NBROW(I+1)-NBROW(I) ENDIF IF ( NROWS_TO_SEND .EQ. 0) CYCLE ITYPE_SON = MUMPS_TYPENODE( PROCNODE_STEPS(STEP(ISON)), & KEEP(199) ) IF (CB_IS_LR) THEN CALL ZMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NROWS_TO_SEND, LMAP_LOC, & MAP, min(LMAP_LOC,NBROW(I)), & IW(PIMASTER(STEP(ISON))), & ADummy, 1_8, & I, PDEST, PDEST_MASTER, COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP(253), NVSCHUR, & ITYPE_SON, MYID ) ELSE CALL ZMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) CALL ZMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NROWS_TO_SEND, LMAP_LOC, & MAP, min(LMAP_LOC,NBROW(I)), & IW(PIMASTER(STEP(ISON))), & SON_A(IACHK:IACHK+RECSIZE-1_8), & RECSIZE, & I, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP(253), NVSCHUR, & ITYPE_SON, MYID) ENDIF IF ( IERR .EQ. -2 ) THEN IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING ZMUMPS_MAPLIG_FILS_NIV1" IFLAG = -17 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * KEEP( 35 ) GO TO 700 END IF IF ( IERR .EQ. -3 ) THEN IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING ZMUMPS_MAPLIG_FILS_NIV1" IFLAG = -20 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * KEEP( 35 ) GO TO 700 ENDIF IF (KEEP(219).NE.0) THEN IF ( IERR .EQ. -4 ) THEN IFLAG = -13 IERROR = BUF_LMAX_ARRAY IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, MAX_ARRAY ALLOC FAILED DURING ZMUMPS_MAPLIG_FILS_NIV1" GO TO 700 ENDIF ENDIF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 GO TO 95 END IF END IF END DO ISTCHK = PTRIST(STEP(ISON)) PTRIST(STEP( ISON )) = -77777777 IF ( IW(ISTCHK+KEEP(IXSZ)) .GE. 0 ) THEN WRITE(*,*) 'error 3 in ZMUMPS_MAPLIG_FILS_NIV1' CALL MUMPS_ABORT() ENDIF CALL MUMPS_GETI8(DYNSIZE,IW(ISTCHK+XXD)) XXG_STATUS = IW(ISTCHK+XXG) CALL ZMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) IF (DYNSIZE .GT. 0_8) THEN CALL ZMUMPS_DM_FREE_BLOCK( XXG_STATUS, SON_A, DYNSIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF GOTO 600 700 CONTINUE CALL ZMUMPS_BDC_ERROR(MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF (CB_IS_LR) THEN CALL ZMUMPS_BLR_FREE_CB_LRB(IW(ISTCHK+XXF), & .FALSE., KEEP8, KEEP(34)) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN CALL ZMUMPS_BLR_END_FRONT(IW(ISTCHK+XXF), IFLAG, KEEP8, & KEEP(34)) ENDIF ENDIF IF (allocated(NBROW)) DEALLOCATE(NBROW) IF (allocated(MAP)) DEALLOCATE(MAP) IF (allocated(PERM_LOC)) DEALLOCATE(PERM_LOC) IF (allocated(SLAVES_PERE)) DEALLOCATE(SLAVES_PERE) RETURN END SUBROUTINE ZMUMPS_MAPLIG_FILS_NIV1 SUBROUTINE ZMUMPS_LOCAL_ASSEMBLY_TYPE2(I, PDEST, MYID, & PDEST_MASTER, ISON, IFATH, NSLAVES_PERE, NASS_PERE, & NFRONT_PERE, NFS4FATHER, LMAP_LOC, MAP, & NBROW, PERM, IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, & IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, & LPTRAR, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & SON_NIV, LRGROUPS) USE ZMUMPS_BUF, ONLY: ZMUMPS_BUF_MAX_ARRAY_MINSIZE, & BUF_MAX_ARRAY USE ZMUMPS_LR_TYPE USE MUMPS_LR_STATS USE ZMUMPS_LR_DATA_M USE MUMPS_LOAD, ONLY : MUMPS_LOAD_POOL_UPD_NEW_POOL USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR & , ZMUMPS_DM_SET_PTR, ZMUMPS_DM_FREE_BLOCK IMPLICIT NONE INTEGER ICNTL(60) INTEGER, intent(in) :: I, PDEST, MYID, PDEST_MASTER, IFATH, ISON INTEGER, intent(in) :: N, SLAVEF INTEGER, intent(in) :: NSLAVES_PERE, NASS_PERE, NFRONT_PERE INTEGER, intent(in) :: NFS4FATHER INTEGER, intent(in) :: KEEP(500), STEP(N) INTEGER, intent(in) :: LMAP_LOC INTEGER, intent(in) :: NBROW(0:NSLAVES_PERE) INTEGER, intent(in) :: MAP(LMAP_LOC), PERM(LMAP_LOC) INTEGER, intent(inout) :: IFLAG, IERROR INTEGER(8), intent(inout) :: KEEP8(150) INTEGER, intent(in) :: LIW, NELT, LPTRAR INTEGER(8), intent(in) :: LA INTEGER(8), intent(inout) :: IPTRLU, LRLU, LRLUS INTEGER, intent(inout) :: IWPOSCB INTEGER, intent(inout) :: IW(LIW) COMPLEX(kind=8), intent(inout) :: A( LA ) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER :: PTRIST(KEEP(28)), PIMASTER(KEEP(28)), ND(KEEP(28)) INTEGER :: PTLUST(KEEP(28)) INTEGER, intent(inout) :: ITLOC(N) INTEGER, intent(in) :: FRTPTR( N+1 ), FRTELT( NELT ) DOUBLE PRECISION, intent(inout) :: OPASSW, OPELIW COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER, intent(in) :: KEEP253_LOC, NVSCHUR INTEGER, intent(in) :: FILS(N), DAD( KEEP(28) ) INTEGER(8), intent(in) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER, intent(in) :: PROCNODE_STEPS( KEEP(28) ), COMM_LOAD INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPOOL INTEGER IPOOL( LPOOL ) LOGICAL, intent(in) :: IS_ofType5or6 INTEGER, intent(in) :: SON_NIV INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INTEGER :: XXG_STATUS INTEGER :: ISTCHK, ISTCHK_LOC, NBCOLS, & NROW, NPIV, NSLSON, & NFRONT, LDA_SON, NROWS_TO_STACK, II, INDICE_PERE, & NOSLA, COLLIST, IPOS_IN_SLAVE, IROW_SON, ITMP, & NBCOLS_EFF, DECR, NELIM INTEGER :: NB_POSTPONED LOGICAL :: PACKED_CB, SAME_PROC INTEGER(8) :: SIZFR, POSROW, SHIFTCB_SON INTEGER(8) :: IACHK INTEGER :: SON_XXS COMPLEX(kind=8), DIMENSION(:), POINTER :: SON_A COMPLEX(kind=8), DIMENSION(:), POINTER :: SON_A_MASTER INTEGER(8) :: DYN_SIZE INTEGER :: IERR, LP INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER :: INBPROCFILS_SON LOGICAL :: CB_IS_LR DOUBLE PRECISION, POINTER, DIMENSION(:) :: M_ARRAY LOGICAL :: M_ARRAY_RETRIEVED INTEGER(8) :: POSELT INTEGER :: IOLDPS, PARPIV_T1 LOGICAL :: LR_ACTIVATED INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL, & BEGS_BLR_STA INTEGER :: NB_BLR_COLS, NB_BLR_ROWS, & NB_COL_SHIFT, PANEL2DECOMPRESS, & CURRENT_PANEL_SIZE, PANEL_BEG_OFFSET, & allocok, NROWS_ALREADY_STACKED, NROWS_TO_STACK_LOC, & NB_ROW_SHIFT, NASS_SHIFT, NCOL_SHIFT, NROW_SHIFT INTEGER :: ICOL_BEG, ICOL_END INTEGER :: IROW_BEG, IROW_END INTEGER :: IBLOCK, MAXI_CLUSTER DOUBLE PRECISION :: PROMOTE_COST INTEGER(8) :: LA_TEMP COMPLEX(kind=8), ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: LRB TYPE (LRB_TYPE), POINTER :: CB_LRB(:,:) COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 IF (I == NSLAVES_PERE) THEN NROWS_TO_STACK = LMAP_LOC - NBROW(I) + 1 ELSE NROWS_TO_STACK = NBROW(I+1) - NBROW(I) ENDIF DECR = 1 IF ( MYID .EQ. PDEST_MASTER ) THEN IW(PTLUST(STEP(IFATH))+XXNBPR) = & IW(PTLUST(STEP(IFATH))+XXNBPR) - DECR IF ( PDEST .EQ. PDEST_MASTER .AND. DECR .NE. 0) THEN IW(PIMASTER(STEP(ISON))+XXNBPR) = & IW(PIMASTER(STEP(ISON))+XXNBPR) - DECR ENDIF ENDIF ISTCHK = PTRIST(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) NROW = IW(ISTCHK+2+KEEP(IXSZ)) NPIV = IW(ISTCHK+3+KEEP(IXSZ)) NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) NFRONT = NPIV + NBCOLS SON_XXS = IW(ISTCHK+XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) CALL ZMUMPS_DM_SET_DYNPTR( & SON_XXS, & A, LA, & PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR) CB_IS_LR = (IW(ISTCHK+XXLR).EQ.1 .OR. & IW(ISTCHK+XXLR).EQ.3) IF (CB_IS_LR.AND.IS_ofType5or6) THEN write(*,*) 'Compress CB + Type5or6 fronts not coded yet!!' CALL MUMPS_ABORT() ENDIF NELIM = -9999 IF (CB_IS_LR.AND.(SON_NIV.EQ.1).AND. & KEEP(50).NE.0) THEN ISTCHK_LOC = PTLUST(STEP(ISON)) NELIM = IW(ISTCHK_LOC+1+KEEP(IXSZ)) NPIV = IW(ISTCHK_LOC+3+KEEP(IXSZ)) NFRONT = IW(ISTCHK_LOC+2+KEEP(IXSZ)) NROW = NFRONT - NPIV NFRONT = NBCOLS NPIV = 0 ENDIF IF (CB_IS_LR) THEN LDA_SON = NBCOLS SHIFTCB_SON = -9999 ELSE IF (SON_XXS.EQ.S_NOLCBCONTIG ) THEN LDA_SON = NBCOLS SHIFTCB_SON = int(NPIV,8)*int(NROW,8) ELSE IF (IW(ISTCHK+XXS).EQ.S_NOLCLEANED) THEN LDA_SON = NBCOLS SHIFTCB_SON = 0_8 ELSE LDA_SON = NFRONT SHIFTCB_SON = int(NPIV,8) ENDIF ENDIF IF (PDEST .NE. PDEST_MASTER) THEN IF ( KEEP(55) .eq. 0 ) THEN CALL ZMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, IFATH, IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ELSE CALL ZMUMPS_ELT_ASM_S_2_S_INIT(NELT, FRTPTR, FRTELT, & N, IFATH, IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP, KEEP8, MYID, LRGROUPS ) ENDIF ENDIF NROWS_ALREADY_STACKED = 0 100 CONTINUE NROWS_TO_STACK_LOC = NROWS_TO_STACK PANEL_BEG_OFFSET = 0 IF (CB_IS_LR) THEN IF (NROWS_TO_STACK.GT.0) THEN CALL ZMUMPS_BLR_RETRIEVE_CB_LRB( & IW(ISTCHK+XXF), CB_LRB) IF (SON_NIV.EQ.1) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR_ROW) CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_DYN( & IW(ISTCHK+XXF), BEGS_BLR_COL) NB_BLR_ROWS = size(BEGS_BLR_ROW) - 1 CALL ZMUMPS_BLR_RETRIEVE_NB_PANELS(IW(ISTCHK+XXF), & NB_COL_SHIFT) NB_ROW_SHIFT = NB_COL_SHIFT NASS_SHIFT = BEGS_BLR_ROW(NB_ROW_SHIFT+1)-1 ELSE CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR_STA) NB_BLR_ROWS = size(BEGS_BLR_STA) - 2 BEGS_BLR_ROW => BEGS_BLR_STA(2:NB_BLR_ROWS+2) CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C( & IW(ISTCHK+XXF), BEGS_BLR_COL, & NB_COL_SHIFT) NB_ROW_SHIFT = 0 NASS_SHIFT = 0 ENDIF PANEL2DECOMPRESS = -1 DO II=NB_ROW_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR_ROW(II+1)-1-NASS_SHIFT.GT. & NROWS_ALREADY_STACKED+NBROW(I)-1) THEN PANEL2DECOMPRESS = II EXIT ENDIF ENDDO IF (PANEL2DECOMPRESS.EQ.-1) THEN write(*,*) 'Internal error: PANEL2DECOMPRESS not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR_COL) - 1 ELSEIF (SON_NIV.EQ.1) THEN NB_BLR_COLS = PANEL2DECOMPRESS ELSE NB_BLR_COLS = -1 NCOL_SHIFT = NPIV NROW_SHIFT = NBCOLS-NROW DO II=NB_COL_SHIFT+1,size(BEGS_BLR_COL)-1 IF (BEGS_BLR_COL(II+1)-NCOL_SHIFT.GT. & BEGS_BLR_ROW(PANEL2DECOMPRESS+1)-1+NROW_SHIFT) THEN NB_BLR_COLS = II EXIT ENDIF ENDDO IF (NB_BLR_COLS.EQ.-1) THEN write(*,*) 'Internal error: NB_BLR_COLS not found' CALL MUMPS_ABORT() ENDIF ENDIF CURRENT_PANEL_SIZE = BEGS_BLR_ROW(PANEL2DECOMPRESS+1) & - BEGS_BLR_ROW(PANEL2DECOMPRESS) PANEL_BEG_OFFSET = NBROW(I) + NROWS_ALREADY_STACKED & - BEGS_BLR_ROW(PANEL2DECOMPRESS) + NASS_SHIFT NROWS_TO_STACK_LOC = & min(NROWS_TO_STACK-NROWS_ALREADY_STACKED, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) MAXI_CLUSTER = 1 DO IBLOCK=1,NB_BLR_COLS-NB_COL_SHIFT LRB => CB_LRB(PANEL2DECOMPRESS-NB_ROW_SHIFT,IBLOCK) MAXI_CLUSTER = max(MAXI_CLUSTER, LRB%N) ENDDO LA_TEMP = NROWS_TO_STACK_LOC*MAXI_CLUSTER #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(A_TEMP, LRB, II, IBLOCK, ICOL_BEG, ICOL_END, !$OMP& allocok, PROMOTE_COST, IROW_BEG, IROW_END, IROW_SON, !$OMP& INDICE_PERE, ITMP, POSROW, NBCOLS_EFF, ISTCHK, !$OMP& ISTCHK_LOC, COLLIST, NOSLA, IPOS_IN_SLAVE, !$OMP& INDICE_PERE_ARRAY_ARG) #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 GOTO 550 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP DO SCHEDULE(dynamic,1) #endif DO IBLOCK=1,NB_BLR_COLS-NB_COL_SHIFT IF (IFLAG.LT.0) CYCLE ICOL_BEG = 1 DO II = 1,IBLOCK-1 LRB => CB_LRB(PANEL2DECOMPRESS-NB_ROW_SHIFT,II) ICOL_BEG = ICOL_BEG + LRB%N ENDDO LRB => CB_LRB(PANEL2DECOMPRESS-NB_ROW_SHIFT,IBLOCK) IF (LRB%ISLR .AND. LRB%K.EQ.0) CYCLE IROW_BEG = PANEL_BEG_OFFSET+1 IROW_END = PANEL_BEG_OFFSET+NROWS_TO_STACK_LOC IF (LRB%ISLR) THEN CALL zgemm('T','T', LRB%N, NROWS_TO_STACK_LOC, LRB%K, & ONE, LRB%R(1,1), LRB%K, LRB%Q(IROW_BEG,1), & LRB%M, ZERO, A_TEMP(1), LRB%N) PROMOTE_COST = 2.0D0*LRB%N*NROWS_TO_STACK_LOC*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE DO II = IROW_BEG, IROW_END A_TEMP( 1+(II-IROW_BEG)*LRB%N : & (II-IROW_BEG+1)*LRB%N ) = LRB%Q(II,1:LRB%N) ENDDO ENDIF DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON = PERM(NBROW(I)+II-1) INDICE_PERE=MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IFATH, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF ( PACKED_CB ) THEN ITMP = IROW_SON + NBCOLS - NROW POSROW = IACHK & + int(ITMP,8) * int(ITMP-1,8) / 2_8 & - int(NBCOLS-NROW,8) * int(NBCOLS-NROW+1,8)/2_8 ELSE POSROW = IACHK + SHIFTCB_SON & +int(IROW_SON-1,8)*int(LDA_SON,8) ENDIF IF (PDEST .EQ. 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 ICOL_END = min(ICOL_BEG+LRB%N-1, NBCOLS_EFF) CALL ZMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, ICOL_END - ICOL_BEG + 1, & INDICE_PERE_ARRAY_ARG, & A_TEMP(1+(II-NROWS_ALREADY_STACKED-1)*LRB%N), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, NBCOLS, ICOL_BEG ) ELSE ISTCHK = PTRIST(STEP(ISON)) COLLIST = ISTCHK + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) + NROW + NPIV IF ((SON_NIV.EQ.1).AND. KEEP(50).NE.0) THEN ISTCHK_LOC = PTLUST(STEP(ISON)) COLLIST = ISTCHK_LOC + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) & + IW(ISTCHK_LOC+2+KEEP(IXSZ)) & + IW(ISTCHK_LOC+3+KEEP(IXSZ)) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = IROW_SON + NBCOLS - NROW IF (SON_NIV.EQ.1) THEN NBCOLS_EFF = IROW_SON + NBCOLS - (NROW-NELIM) ENDIF ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE ICOL_END = min(ICOL_BEG+LRB%N-1, NBCOLS_EFF) CALL ZMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, ICOL_END-ICOL_BEG+1, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST + ICOL_BEG - 1 ), & A_TEMP(1+(II-NROWS_ALREADY_STACKED-1)*LRB%N), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, NBCOLS) ENDIF ENDDO ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO #endif IF (IFLAG.LT.0) GOTO 550 deallocate(A_TEMP) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) 550 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) RETURN IF (PDEST .NE. PDEST_MASTER) THEN IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - NROWS_TO_STACK_LOC ENDIF NROWS_ALREADY_STACKED = NROWS_ALREADY_STACKED & + NROWS_TO_STACK_LOC IF (NROWS_ALREADY_STACKED.LT.NROWS_TO_STACK) THEN GOTO 100 ENDIF ENDIF ELSE DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON = PERM(NBROW(I)+II-1) INDICE_PERE=MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IFATH, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF ( PACKED_CB ) THEN ITMP = IROW_SON + NBCOLS - NROW POSROW = IACHK & + int(ITMP,8) * int(ITMP-1,8) / 2_8 & - int(NBCOLS-NROW,8) * int(NBCOLS-NROW+1,8)/2_8 ELSE POSROW = IACHK + SHIFTCB_SON & +int(IROW_SON-1,8)*int(LDA_SON,8) ENDIF IF (PDEST == PDEST_MASTER) THEN IF (KEEP(50).NE.0) THEN NBCOLS_EFF = IROW_SON + NBCOLS - NROW ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE IF ((IS_ofType5or6).AND.(KEEP(50).EQ.0)) THEN CALL ZMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON, 1 & ) EXIT ELSE IF ( (KEEP(50).NE.0) .AND. & (.NOT.PACKED_CB).AND.(IS_ofType5or6) ) THEN CALL ZMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, & NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON, 1 & ) EXIT ELSE CALL ZMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON, 1 ) 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.PACKED_CB) ) & ) & ) THEN CALL ZMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), SON_A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - NROWS_TO_STACK EXIT ELSE CALL ZMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), SON_A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - 1 ENDIF ENDIF ENDDO ENDIF IF (PDEST.EQ.PDEST_MASTER) THEN IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2 & .AND. NFS4FATHER .GT. 0) THEN IF (CB_IS_LR) THEN CALL ZMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW(ISTCHK+XXF), M_ARRAY) M_ARRAY_RETRIEVED = .TRUE. ELSE IF (PACKED_CB) THEN WRITE(*,*) "Error 1 in PARPIV/ZMUMPS_MAPLIG" CALL MUMPS_ABORT() ELSE POSROW = IACHK + SHIFTCB_SON+ & int(NBROW(1)-1,8)*int(LDA_SON,8) ENDIF CALL ZMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP .GT. 0) THEN WRITE(LP, *) "MAX_ARRAY allocation failed" ENDIF IFLAG=-13 IERROR=NFS4FATHER RETURN ENDIF ITMP=-9999 IF (LMAP_LOC-NBROW(1)+1-KEEP253_LOC-NVSCHUR.NE.0) & THEN CALL ZMUMPS_COMPUTE_MAXPERCOL( & SON_A(POSROW), & SIZFR-SHIFTCB_SON-int(NBROW(1)-1,8)*int(LDA_SON,8), & LDA_SON, & LMAP_LOC-NBROW(1)+1-KEEP253_LOC-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB,ITMP) ELSE CALL ZMUMPS_SETMAXTOZERO( & BUF_MAX_ARRAY, NFS4FATHER) ENDIF M_ARRAY => BUF_MAX_ARRAY(1:size(BUF_MAX_ARRAY)) M_ARRAY_RETRIEVED = .FALSE. ENDIF CALL ZMUMPS_ASM_MAX(N, IFATH, IW, LIW, & A, LA, ISON, NFS4FATHER, & M_ARRAY(1), PTLUST, PTRAST, & STEP, PIMASTER, & OPASSW,IWPOSCB,MYID, KEEP,KEEP8) IF ( M_ARRAY_RETRIEVED ) & CALL ZMUMPS_BLR_FREE_M_ARRAY ( IW(ISTCHK+XXF) ) ENDIF ENDIF ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF ( SAME_PROC ) THEN INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR WRITE(*,*) & "Internal error 0 in ZMUMPS_LOCAL_ASSEMBLY_TYPE2", & INBPROCFILS_SON, PIMASTER(STEP(ISON)) CALL MUMPS_ABORT() ELSE INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ENDIF IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN IF (SAME_PROC) THEN CALL ZMUMPS_RESTORE_INDICES(N, ISON, IFATH, & IWPOSCB, PIMASTER, PTLUST, IW, LIW, STEP, & KEEP,KEEP8) ENDIF IF (SAME_PROC) THEN ISTCHK_LOC = PTRIST(STEP(ISON)) PTRIST(STEP( ISON) ) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_LOC+XXD)) XXG_STATUS = IW(ISTCHK_LOC+XXG) IF (DYN_SIZE .GT. 0_8) THEN CALL ZMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), & DYN_SIZE, SON_A_MASTER ) ENDIF CALL ZMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., MYID, N, & ISTCHK_LOC, & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) IF (DYN_SIZE .GT. 0_8) THEN CALL ZMUMPS_DM_FREE_BLOCK( XXG_STATUS, SON_A_MASTER, & DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF IF ( IW(PTLUST(STEP(IFATH))+XXNBPR) .EQ. 0 & ) THEN IOLDPS = PTLUST(STEP(IFATH)) IF (NSLAVES_PERE.EQ.0) THEN POSELT = PTRAST(STEP(IFATH)) PARPIV_T1 = -999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) NB_POSTPONED = max(NFRONT - ND(STEP(IFATH)),0) CALL ZMUMPS_PARPIVT1_SET_NVSCHUR_MAX ( & N, IFATH, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT_PERE, NASS_PERE, LR_ACTIVATED, PARPIV_T1, & NB_POSTPONED ) ENDIF CALL ZMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, IFATH+N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF ELSE CALL ZMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, IFATH, IW, LIW, & NBROW(I), STEP, PTRIST, ITLOC, RHS_MUMPS, & KEEP,KEEP8) END IF RETURN END SUBROUTINE ZMUMPS_LOCAL_ASSEMBLY_TYPE2 MUMPS_5.8.1/src/cfac_lr.F0000664000175000017500000030036415042446440014736 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC_LR USE CMUMPS_LR_TYPE USE CMUMPS_LR_CORE IMPLICIT NONE CONTAINS SUBROUTINE CMUMPS_BLR_UPDATE_TRAILING_LDLT( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, & NELIM, IW2, BLOCK, & MAXI_CLUSTER, NPIV, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & NELIM, MAXI_CLUSTER, NPIV, NIV, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR COMPLEX, intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_L(:) COMPLEX, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, intent(in) :: IW2(*) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL, J, MID_RANK LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER(8) :: POSELTT, POSELTD COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(CURRENT_BLR)-1,8) & + int(BEGS_BLR(CURRENT_BLR) - 1,8) OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC, CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, !$OMP& MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL*(NB_BLOCKS_PANEL+1)/2) IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT + int(NFRONT,8) * & int(BEGS_BLR(CURRENT_BLR+I)-1,8) & + int(BEGS_BLR(CURRENT_BLR+J) - 1, 8) CALL CMUMPS_LRGEMM4(MONE, & BLR_L(J), BLR_L(I), ONE, A, LA, & POSELTT, NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_L(J)%M, BLR_L(J)%N, BLR_L(J)%K, & BLR_L(J)%ISLR, BLR_L(I)%M, BLR_L(I)%N, BLR_L(I)%K, & BLR_L(I)%ISLR, MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), .FALSE.) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif END SUBROUTINE CMUMPS_BLR_UPDATE_TRAILING_LDLT SUBROUTINE CMUMPS_BLR_SLV_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, JBEG_BLOCK, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA, LA_BLOCFACTO COMPLEX, intent(inout) :: A(LA) COMPLEX, intent(in) :: A_BLOCFACTO(LA_BLOCFACTO) INTEGER(8), intent(in) :: POSELT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), TOL_OPT, & MAXI_CLUSTER, LD_BLOCFACTO, & JBEG_BLOCK INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS, & ISHIFT_LM, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS COMPLEX, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM), & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_LM, NB_BLOCKS_PANEL_LS, J, MID_RANK LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER(8) :: POSELTT COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) NB_BLOCKS_PANEL_LM = NB_BLR_LM-CURRENT_BLR_LM NB_BLOCKS_PANEL_LS = NB_BLR_LS-CURRENT_BLR_LS OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_LS*NB_BLOCKS_PANEL_LM) IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_BLOCKS_PANEL_LM+1 J = IBIS - (I-1)*NB_BLOCKS_PANEL_LM #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT & + int(NCOL,8) * & int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8) & + int((BEGS_BLR_LM(CURRENT_BLR_LM+J)+ISHIFT_LM-1),8) CALL CMUMPS_LRGEMM4(MONE, & BLR_LM(J), BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A_BLOCFACTO, LD_DIAG=LD_BLOCFACTO, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_LM(J)%M, BLR_LM(J)%N, BLR_LM(J)%K, & BLR_LM(J)%ISLR, BLR_LS(I)%M, BLR_LS(I)%N, BLR_LS(I)%K, & BLR_LS(I)%ISLR, MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., .FALSE.) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO IF (IFLAG.LT.0) RETURN IF (JBEG_BLOCK.NE.1) RETURN !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, MID_RANK, OMP_NUM, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_LS*(NB_BLOCKS_PANEL_LS+1)/2) IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT & + int(NCOL,8) * & int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8) & + int((NCOL-NROW+(BEGS_BLR_LS(CURRENT_BLR_LS+J)-1)),8) CALL CMUMPS_LRGEMM4(MONE, & BLR_LS(J),BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A_BLOCFACTO, LD_DIAG=LD_BLOCFACTO, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_LS(J)%M, BLR_LS(J)%N, BLR_LS(J)%K, & BLR_LS(J)%ISLR, BLR_LS(I)%M, BLR_LS(I)%N, BLR_LS(I)%K, & BLR_LS(I)%ISLR, MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), .FALSE.) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif RETURN END SUBROUTINE CMUMPS_BLR_SLV_UPD_TRAIL_LDLT SUBROUTINE CMUMPS_BLR_UPD_NELIM_VAR_U( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_U, NB_BLR, & FIRST_BLOCK, IBEG_BLR, NPIV, NELIM) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & IBEG_BLR, NPIV, NELIM, FIRST_BLOCK INTEGER, intent(inout) :: IFLAG, IERROR COMPLEX, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(:) INTEGER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: IP INTEGER :: allocok INTEGER(8) :: LPOS, UPOS COMPLEX, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) IF (NELIM.NE.0) THEN LPOS = POSELT + int(NFRONT,8)*int(NPIV,8) + int(IBEG_BLR-1,8) #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(LRB, UPOS) #endif DO IP = FIRST_BLOCK, NB_BLR IF (IFLAG.LT.0) CYCLE LRB => BLR_U(IP-CURRENT_BLR) UPOS = POSELT + int(NFRONT,8)*int(NPIV,8) & + int(BEGS_BLR(IP)-1,8) IF (LRB%ISLR) THEN IF (LRB%K.GT.0) THEN allocate(TEMP_BLOCK( LRB%K, NELIM ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * LRB%K GOTO 100 ENDIF CALL cgemm('N', 'N', LRB%K, NELIM, LRB%N, ONE, & LRB%R(1,1), LRB%K, A(LPOS), NFRONT, & ZERO, TEMP_BLOCK, LRB%K) CALL cgemm('N', 'N', LRB%M, NELIM, LRB%K, MONE, & LRB%Q(1,1), LRB%M, TEMP_BLOCK, LRB%K, & ONE, A(UPOS), NFRONT) deallocate(TEMP_BLOCK) ENDIF ELSE CALL cgemm('N', 'N', LRB%M, NELIM, LRB%N, MONE, & LRB%Q(1,1), LRB%M, A(LPOS), NFRONT, & ONE, A(UPOS), NFRONT) ENDIF 100 CONTINUE ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO #endif ENDIF END SUBROUTINE CMUMPS_BLR_UPD_NELIM_VAR_U SUBROUTINE CMUMPS_BLR_UPD_NELIM_VAR_L( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA_U, LA_L INTEGER(8), intent(in) :: UPOS, LPOS INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR, & NELIM, FIRST_BLOCK CHARACTER(len=1),INTENT(IN) :: UTRANS INTEGER, intent(inout) :: IFLAG, IERROR COMPLEX, TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U) TYPE(LRB_TYPE),intent(in) :: BLR_L(:) INTEGER :: BEGS_BLR_L(:) INTEGER :: I, NB_BLOCKS_PANEL_L, KL, ML, NL INTEGER :: allocok INTEGER(8) :: IPOS COMPLEX, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR IF (NELIM.NE.0) THEN #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(KL, ML, NL, IPOS) #endif DO I = FIRST_BLOCK-CURRENT_BLR, NB_BLOCKS_PANEL_L IF (IFLAG.LT.0) CYCLE KL = BLR_L(I)%K ML = BLR_L(I)%M NL = BLR_L(I)%N IPOS = LPOS + int(LDL,8) * & int(BEGS_BLR_L(CURRENT_BLR+I)-BEGS_BLR_L(CURRENT_BLR+1),8) IF (BLR_L(I)%ISLR) THEN IF (KL.GT.0) THEN allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * KL write(*,*) 'Allocation problem in BLR routine & CMUMPS_BLR_UPD_NELIM_VAR_L: ', & 'not enough memory? memory requested = ', IERROR GOTO 100 ENDIF CALL cgemm(UTRANS , 'T' , NELIM, KL, NL , ONE , & A_U(UPOS) , LDU , BLR_L(I)%R(1,1) , KL , & ZERO , TEMP_BLOCK , NELIM) CALL cgemm('N' , 'T' , NELIM , ML , KL , MONE , & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , & ONE , A_L(IPOS) , LDL) deallocate(TEMP_BLOCK) ENDIF ELSE CALL cgemm(UTRANS , 'T' , NELIM, ML, NL , MONE , & A_U(UPOS) , LDU , BLR_L(I)%Q(1,1) , ML , & ONE , A_L(IPOS) , LDL) ENDIF 100 CONTINUE ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO #endif ENDIF END SUBROUTINE CMUMPS_BLR_UPD_NELIM_VAR_L SUBROUTINE CMUMPS_BLR_UPDATE_TRAILING( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, & CURRENT_BLR, & NELIM, NIV, SYM, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT COMPLEX, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(:) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(:) INTEGER :: BEGS_BLR_L(:), BEGS_BLR_U(:) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_L, NB_BLOCKS_PANEL_U, & KL, ML, NL, J, IS, MID_RANK INTEGER :: allocok LOGICAL :: BUILDQ INTEGER :: IBIS #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB, POSELT_TOP COMPLEX, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR NB_BLOCKS_PANEL_U = NB_BLR_U-CURRENT_BLR IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS = 0 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif IF (NELIM.NE.0) THEN DO I = 1, NB_BLOCKS_PANEL_L KL = BLR_L(I)%K ML = BLR_L(I)%M NL = BLR_L(I)%N IF (BLR_L(I)%ISLR) THEN IF (KL.GT.0) THEN allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * KL GOTO 100 ENDIF POSELT_TOP = POSELT & + int(NFRONT,8) * int((BEGS_BLR_U(CURRENT_BLR)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1,8) POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) CALL cgemm('N' , 'T' , NELIM, KL, NL , ONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%R(1,1) , KL , & ZERO , TEMP_BLOCK , NELIM) CALL cgemm('N' , 'T' , NELIM , ML , KL , MONE , & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) deallocate(TEMP_BLOCK) ENDIF ELSE POSELT_TOP = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1, 8) CALL cgemm('N' , 'T' , NELIM, ML, NL , MONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) ENDIF ENDDO ENDIF 100 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 200 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELT_INCB, MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_L*NB_BLOCKS_PANEL_U) IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_BLOCKS_PANEL_U+1 J = IBIS - (I-1)*NB_BLOCKS_PANEL_U POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+J) +IS - 1,8) CALL CMUMPS_LRGEMM4(MONE, BLR_U(J), & BLR_L(I), ONE, A, LA, POSELT_INCB, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT, MID_RANK, BUILDQ, .FALSE.) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_U(J)%M, BLR_U(J)%N, BLR_U(J)%K, & BLR_U(J)%ISLR, BLR_L(I)%M, BLR_L(I)%N, BLR_L(I)%K, & BLR_L(I)%ISLR, MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., .FALSE.) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif 200 CONTINUE END SUBROUTINE CMUMPS_BLR_UPDATE_TRAILING SUBROUTINE CMUMPS_BLR_UPD_PANEL_LEFT_LDLT( & A, LA, POSELT, NFRONT, IWHANDLER, & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, IW2, BLOCK, ACC_LUA, & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, & KEEP8, & FIRST_BLOCK & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS, & CURRENT_BLR, IWHANDLER, TOL_OPT, & NELIM, NIV, K480, K479, K478, & MAXI_CLUSTER, MAXI_RANK, & KPERCENT_LUA, KPERCENT COMPLEX, intent(inout) :: A(LA) INTEGER, intent(in) :: IW2(*) COMPLEX :: BLOCK(MAXI_CLUSTER,*) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:) INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB REAL,intent(in) :: TOLEPS INTEGER,intent(inout) :: IFLAG, IERROR INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK TYPE(LRB_TYPE), POINTER :: BLR_L(:), NEXT_BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES, & I, II, J, JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX, & MAXRANK, NB_DEC, FR_RANK INTEGER :: MID_RANK, allocok INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) LOGICAL :: BUILDQ, COMPRESSED_FR INTEGER :: OFFSET_IW INTEGER :: OMP_NUM #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB, POSELTD COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR ACC_LRB => ACC_LUA(1) IF (K480.GE.5) THEN IF (NB_BLOCKS_PANEL.GT.1) THEN CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & CURRENT_BLR+1, NEXT_BLR_L) ENDIF IF (.not.(present(FIRST_BLOCK))) THEN write(*,*) "Internal error in & CMUMPS_BLR_UPD_PANEL_LEFT_LDLT: KEEP(480)=",K480, & ">= 5, but FIRST_BLOCK argument is missing" CALL MUMPS_ABORT() ENDIF ENDIF OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ, K_MAX, !$OMP& BLR_L, OMP_NUM, J_ORDER, J_RANK, !$OMP& IND_U, IND_L, ACC_LRB, POSELTD, NB_DEC, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, COMPRESSED_FR, FR_RANK, II, OFFSET_IW) #endif DO I = 1, NB_BLOCKS_PANEL #if ! defined(BLR_NOOPENMP) IF (IFLAG.LT.0) CYCLE OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR(CURRENT_BLR+1)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+I+1)-BEGS_BLR(CURRENT_BLR+I) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 COMPRESSED_FR = .FALSE. IF (K480.EQ.2) THEN DO J = 1, CURRENT_BLR J_ORDER(J) = J ENDDO ELSE CALL CMUMPS_GET_LUA_ORDER(CURRENT_BLR, J_ORDER, J_RANK, & IWHANDLER, & 1, 0, I, 0, & FRFR_UPDATES) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL CMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF ENDIF NB_DEC = FRFR_UPDATES DO JJ = 1, CURRENT_BLR J = J_ORDER(JJ) K_MAX = J_RANK(JJ) POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(J)-1,8) & + int(BEGS_BLR(J) - 1,8) OFFSET_IW = BEGS_BLR(J) IND_L = CURRENT_BLR+I-J IND_U = CURRENT_BLR+1-J CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & J, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = JJ-1 CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL CMUMPS_LRGEMM4(MONE, & BLR_L(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_INCB, & NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=0, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, & IW2=IW2(OFFSET_IW), & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_L(IND_U)%M, BLR_L(IND_U)%N, & BLR_L(IND_U)%K, BLR_L(IND_U)%ISLR, BLR_L(IND_L)%M, & BLR_L(IND_L)%N, BLR_L(IND_L)%K, BLR_L(IND_L)%ISLR, & MIDBLK_COMPRESS, MID_RANK, BUILDQ, (I.EQ.1), (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN J_RANK(JJ) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN IF (ACC_LRB%K.GT.0) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (JJ.EQ.FRFR_UPDATES) THEN CALL CMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K IF (COMPRESSED_FR) THEN J_RANK(JJ) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) ELSE allocate(POS_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,CURRENT_BLR POS_LIST(II+1)=POS_LIST(II)+J_RANK(II-1) ENDDO allocate(RANK_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,CURRENT_BLR+1 RANK_LIST(II) = J_RANK(II-1) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & CURRENT_BLR+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = floor(real(ACC_LRB%M*ACC_LRB%N)/real(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ALLOC_LRB_FROM_ACC(ACC_LRB, NEXT_BLR_L(I-1), & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, 0, & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE ACC_LRB%K = 0 ELSE IF (I.NE.1) NEXT_BLR_L(I-1)%ISLR=.FALSE. CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) ENDIF ENDIF 100 CONTINUE ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif END SUBROUTINE CMUMPS_BLR_UPD_PANEL_LEFT_LDLT SUBROUTINE CMUMPS_BLR_UPD_PANEL_LEFT( & A, LA, POSELT, NFRONT, IWHANDLER, LorU, & BEGS_BLR, BEGS_BLR_U, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, NIV, SYM, & LBANDSLAVE, IFLAG, IERROR, ISHIFT, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, & MAXI_CLUSTER, MAXI_RANK, & K474, FSorCB, BLR_U_COL, KEEP8, & FIRST_BLOCK, BEG_I_IN, END_I_IN) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS, & CURRENT_BLR, IWHANDLER, LorU, & NELIM, NIV, SYM, K480, K479, K478, & MAXI_CLUSTER, MAXI_RANK, & KPERCENT_LUA, KPERCENT, ISHIFT, & K474, FSorCB LOGICAL, intent(in) :: LBANDSLAVE COMPLEX, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:) INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT REAL,intent(in) :: TOLEPS INTEGER,intent(inout) :: IFLAG, IERROR INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:), NEXT_BLR(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES, & NB_DEC, FR_RANK, MAXRANK, BEG_I, END_I INTEGER :: I,II,J,JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX INTEGER :: MID_RANK, allocok INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) LOGICAL :: BUILDQ, COMPRESSED_FR #if ! defined(BLR_NOOPENMP) INTEGER :: OMP_NUM INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) IF (NIV.EQ.2.AND.LorU.EQ.0) THEN IF (LBANDSLAVE) THEN NB_BLOCKS_PANEL = NB_BLR ELSE NB_BLOCKS_PANEL = NPARTSASS-CURRENT_BLR ENDIF ELSE NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR ENDIF ACC_LRB => ACC_LUA(1) IF (K480.GE.5) THEN IF (NB_BLOCKS_PANEL.GT.1) THEN CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & LorU, & CURRENT_BLR+1, NEXT_BLR) ENDIF IF (.not.(present(FIRST_BLOCK))) THEN write(*,*) "Internal error in & CMUMPS_BLR_UPD_PANEL_LEFT: KEEP(480)=",K480, & ">=5, but FIRST_BLOCK argument is missing" CALL MUMPS_ABORT() ENDIF ENDIF IF (LorU.EQ.0) THEN BEG_I = 1 ELSE BEG_I = 2 ENDIF END_I = NB_BLOCKS_PANEL IF (K474.EQ.3) THEN IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN - CURRENT_BLR ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN - CURRENT_BLR ENDIF ENDIF #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ, !$OMP& BLR_U, BLR_L, J_ORDER, J_RANK, K_MAX, !$OMP& IND_U, IND_L, OMP_NUM, ACC_LRB, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, FR_RANK, COMPRESSED_FR) #endif DO I = BEG_I, END_I IF (IFLAG.LT.0) CYCLE #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif IF (LorU.EQ.0) THEN IF (LBANDSLAVE) THEN POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(I+1)-1),8) & + int(BEGS_BLR_U(2)+ISHIFT-1,8) ACC_LRB%N = BEGS_BLR(I+2)-BEGS_BLR(I+1) ACC_LRB%M = BEGS_BLR_U(3)-BEGS_BLR_U(2) IF (K474.GE.2) THEN BLR_U => BLR_U_COL ENDIF ELSE POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR(CURRENT_BLR+1)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+I+1) & -BEGS_BLR(CURRENT_BLR+I) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) ENDIF ELSE POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+1)-1),8) & + int(BEGS_BLR(CURRENT_BLR+I)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+I+1)-BEGS_BLR(CURRENT_BLR+I) ENDIF MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 COMPRESSED_FR = .FALSE. IF (K480.EQ.2) THEN DO J = 1, CURRENT_BLR J_ORDER(J) = J ENDDO ELSE CALL CMUMPS_GET_LUA_ORDER(CURRENT_BLR, J_ORDER, J_RANK, & IWHANDLER, & 0, 0, I, LorU, & FRFR_UPDATES, & LBANDSLAVE, K474, BLR_U_COL) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL CMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, LorU, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF ENDIF NB_DEC = FRFR_UPDATES DO JJ = 1, CURRENT_BLR J = J_ORDER(JJ) K_MAX = J_RANK(JJ) IF (LorU.EQ.0) THEN IF (LBANDSLAVE) THEN IND_L = I IF (K474.LT.2) THEN IND_U = CURRENT_BLR+1-J ELSE IND_U = J ENDIF ELSE IND_L = CURRENT_BLR+I-J IND_U = CURRENT_BLR+1-J ENDIF ELSE IND_L = CURRENT_BLR+1-J IND_U = CURRENT_BLR+I-J ENDIF CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & J, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (.NOT.LBANDSLAVE.OR.K474.LT.2) THEN CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, & J, BLR_U) ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = JJ-1 CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL CMUMPS_LRGEMM4(MONE, & BLR_U(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_INCB, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=LorU, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER & ) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_U(IND_U)%M, BLR_U(IND_U)%N, & BLR_U(IND_U)%K, BLR_U(IND_U)%ISLR, BLR_L(IND_L)%M, & BLR_L(IND_L)%N, BLR_L(IND_L)%K, BLR_L(IND_L)%ISLR, & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN J_RANK(JJ) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (JJ.EQ.FRFR_UPDATES) THEN CALL CMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, LorU, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K IF (COMPRESSED_FR) THEN J_RANK(JJ) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF ENDIF ENDIF ENDIF ENDDO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) ELSE allocate(POS_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,CURRENT_BLR POS_LIST(II+1)=POS_LIST(II)+J_RANK(II-1) ENDDO allocate(RANK_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,CURRENT_BLR+1 RANK_LIST(II) = J_RANK(II-1) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & CURRENT_BLR+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(REAL(ACC_LRB%M*ACC_LRB%N)/REAL(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ALLOC_LRB_FROM_ACC(ACC_LRB, NEXT_BLR(I-1), & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, LorU, & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE ACC_LRB%K = 0 ELSE IF (I.NE.1) NEXT_BLR(I-1)%ISLR=.FALSE. CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) ENDIF ENDIF 100 CONTINUE ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO NOWAIT #endif END SUBROUTINE CMUMPS_BLR_UPD_PANEL_LEFT SUBROUTINE CMUMPS_BLR_UPD_CB_LEFT_LDLT(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR_DYN, NB_INCB, NB_INASM, NASS, & IWHANDLER, & IW2, BLOCK, ACC_LUA, & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, KEEP8) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_INCB, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & MAXI_RANK, K480, K479, K478, NASS, & KPERCENT_LUA, KPERCENT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER, DIMENSION(:) :: BEGS_BLR_DYN COMPLEX, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, intent(in) :: IW2(*) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT REAL,intent(in) :: TOLEPS INTEGER :: M, N, allocok INTEGER :: I, II, J, K, KK, IND_L, IND_U, K_MAX, IBIS, & K_ORDER(NB_INASM), K_RANK(NB_INASM), NB_DEC INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) INTEGER(8) :: POSELT_BLOCK, POSELTD INTEGER :: MID_RANK, FRFR_UPDATES, MAXRANK, FR_RANK LOGICAL :: BUILDQ, COMPRESSED_FR TYPE(LRB_TYPE), POINTER :: BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK INTEGER :: OFFSET_IW INTEGER :: OMP_NUM #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) ACC_LRB => ACC_LUA(1) OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ, !$OMP& BLR_L, IND_U, IND_L, M, N, K_ORDER, K_RANK, !$OMP& K_MAX, OMP_NUM, ACC_LRB, POSELTD, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, FR_RANK, NB_DEC, II) #endif DO IBIS = 1,NB_INCB*(NB_INCB+1)/2 IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 I = I+NB_INASM J = J+NB_INASM #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 M = BEGS_BLR(I+1)-BEGS_BLR(I) N = BEGS_BLR(J+1)-BEGS_BLR(J) POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR(J)-1,8) ACC_LRB%M = N ACC_LRB%N = M IF (K480.EQ.2) THEN DO K = 1, NB_INASM K_ORDER(K) = K ENDDO ELSE CALL CMUMPS_GET_LUA_ORDER(NB_INASM, K_ORDER, K_RANK, & IWHANDLER, & 1, 1, I, J, & FRFR_UPDATES) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.J)) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL CMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) FR_RANK = ACC_LRB%K MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K ENDIF ENDIF NB_DEC = FRFR_UPDATES DO KK = 1, NB_INASM K = K_ORDER(KK) K_MAX = K_RANK(KK) POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR_DYN(K)-1,8) & + int(BEGS_BLR_DYN(K) - 1,8) OFFSET_IW = BEGS_BLR_DYN(K) IND_L = I-K IND_U = J-K CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & K, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = KK-1 CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, 2) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL CMUMPS_LRGEMM4(MONE, & BLR_L(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_BLOCK, & NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=2, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, & IW2=IW2(OFFSET_IW), & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_L(IND_U)%M, BLR_L(IND_U)%N, & BLR_L(IND_U)%K, BLR_L(IND_U)%ISLR, BLR_L(IND_L)%M, & BLR_L(IND_L)%N, BLR_L(IND_L)%K, BLR_L(IND_L)%ISLR, & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN K_RANK(KK) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN IF (ACC_LRB%K.GT.0) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.J)) THEN IF (KK.EQ.FRFR_UPDATES) THEN CALL CMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) IF (COMPRESSED_FR) THEN K_RANK(KK) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF END DO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) ELSE allocate(POS_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,NB_INASM POS_LIST(II+1)=POS_LIST(II)+K_RANK(II-1) ENDDO allocate(RANK_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,NB_INASM+1 RANK_LIST(II) = K_RANK(II-1) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & NB_INASM+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(REAL(ACC_LRB%M*ACC_LRB%N)/REAL(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2, & COUNT_FLOPS=.FALSE.) ELSE CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & KEEP8, NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ENDIF 100 CONTINUE END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif END SUBROUTINE CMUMPS_BLR_UPD_CB_LEFT_LDLT SUBROUTINE CMUMPS_BLR_UPD_CB_LEFT(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_INCB, NB_INASM, NASS, & IWHANDLER, NIV, LBANDSLAVE, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & ACC_LUA, K480, K479, K478, KPERCENT_LUA, & KPERCENT, & MAXI_CLUSTER, MAXI_RANK, & K474, FSorCB, BLR_U_COL, COMPRESS_CB, CB_LRB, KEEP8) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_ROWS, NB_INCB, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & MAXI_RANK, KPERCENT_LUA, KPERCENT INTEGER, INTENT(IN) :: K480, K479, K478, NASS, K474, & FSorCB INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U #if defined(MUMPS_NOF2003) TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) #else TYPE(LRB_TYPE), POINTER, intent(inout) :: CB_LRB(:,:) #endif TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:) INTEGER(8) :: KEEP8(150) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT REAL,intent(in) :: TOLEPS LOGICAL, intent(in) :: LBANDSLAVE, COMPRESS_CB INTEGER :: M, N, allocok INTEGER :: I, II, J, K, KK, IND_L, IND_U, IBIS, & K_ORDER(NB_INASM), K_RANK(NB_INASM) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) INTEGER(8) :: POSELT_BLOCK INTEGER :: MID_RANK, K_MAX, FRFR_UPDATES, NB_DEC LOGICAL :: BUILDQ, COMPRESSED_FR TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB, LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, MAXRANK, & FR_RANK #if ! defined(BLR_NOOPENMP) INTEGER :: OMP_NUM INTEGER :: CHUNK #endif COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) ACC_LRB => ACC_LUA(1) #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ, !$OMP& BLR_U, BLR_L, IND_U, IND_L, M, N, !$OMP& ACC_LRB, OMP_NUM, K_MAX, K_ORDER, K_RANK, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, LRB) #endif DO IBIS = 1,NB_ROWS*NB_INCB IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_INCB+1 J = IBIS - (I-1)*NB_INCB IF (.NOT.LBANDSLAVE) THEN I = I+NB_INASM ENDIF J = J+NB_INASM #if ! defined(BLR_NOOPENMP) OMP_NUM=0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 IF (LBANDSLAVE) THEN M = BEGS_BLR(I+2)-BEGS_BLR(I+1) IF (K474.EQ.1) THEN POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I+1)-1,8) & +int(NASS,8) + int(BEGS_BLR_U(J-NB_INASM+1)-1,8) N = BEGS_BLR_U(J-NB_INASM+2)-BEGS_BLR_U(J-NB_INASM+1) ELSEIF (K474.GE.2) THEN BLR_U => BLR_U_COL POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I+1)-1,8) & + int(NASS-1,8) N = BEGS_BLR_U(3)-BEGS_BLR_U(2) ELSE write(*,*) 'Internal error in CMUMPS_BLR_UPD_CB_LEFT', & LBANDSLAVE,K474 CALL MUMPS_ABORT() ENDIF ELSE M = BEGS_BLR(I+1)-BEGS_BLR(I) POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR_U(J)-1,8) N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ENDIF ACC_LRB%M = N ACC_LRB%N = M IF (K480.EQ.2) THEN DO K = 1, NB_INASM K_ORDER(K) = K ENDDO ELSE CALL CMUMPS_GET_LUA_ORDER(NB_INASM, K_ORDER, K_RANK, & IWHANDLER, & 0, 1, I, J, & FRFR_UPDATES, & LBANDSLAVE, K474, BLR_U_COL) ENDIF COMPRESSED_FR = .FALSE. FR_RANK = 0 DO KK = 1, NB_INASM IF ((K480.GE.5.OR.COMPRESS_CB).AND.I.NE.J) THEN IF (KK-1.EQ.FRFR_UPDATES) THEN CALL CMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) IF (COMPRESSED_FR) THEN K_RANK(KK) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF K = K_ORDER(KK) K_MAX = K_RANK(KK) IF (LBANDSLAVE) THEN IND_L = I IF (K474.LT.2) THEN IND_U = J-K ELSE IND_U = K ENDIF ELSE IND_L = I-K IND_U = J-K ENDIF CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & K, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (.NOT.LBANDSLAVE.OR.K474.LT.2) THEN CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, & K, BLR_U) ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN COMPRESSED_FR = .FALSE. NB_DEC = KK-1 CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, 2) MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL CMUMPS_LRGEMM4(MONE, & BLR_U(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_BLOCK, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=2, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_U(IND_U)%M, BLR_U(IND_U)%N, & BLR_U(IND_U)%K, BLR_U(IND_U)%ISLR, BLR_L(IND_L)%M, & BLR_L(IND_L)%N, BLR_L(IND_L)%K, BLR_L(IND_L)%ISLR, & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN K_RANK(KK) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF END DO IF (K480.GE.3) THEN IF (K480.GE.5.OR.COMPRESS_CB) THEN IF (K480.GE.5.AND.(COMPRESSED_FR.OR.K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) ELSE allocate(POS_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,NB_INASM POS_LIST(II+1)=POS_LIST(II)+K_RANK(II-1) ENDDO allocate(RANK_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,NB_INASM+1 RANK_LIST(II) = K_RANK(II-1) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & NB_INASM+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(REAL(ACC_LRB%M*ACC_LRB%N)/REAL(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN LRB => CB_LRB(I-NB_INASM,J-NB_INASM) CALL ALLOC_LRB_FROM_ACC(ACC_LRB, LRB, & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, 0, & IFLAG, IERROR, KEEP8) CALL UPD_MRY_CB_LRGAIN(LRB%M, LRB%N, LRB%K & ) ACC_LRB%K = 0 IF (IFLAG.LT.0) GOTO 100 ELSE CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) LRB => CB_LRB(I-NB_INASM,J-NB_INASM) CALL ALLOC_LRB(LRB, ACC_LRB%K, ACC_LRB%N, ACC_LRB%M, & .FALSE., IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 100 DO II=1,ACC_LRB%N LRB%Q(II,1:ACC_LRB%M) = & A( POSELT_BLOCK+int((II-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((II-1),8)*int(NFRONT,8) & +int(ACC_LRB%M-1,8) ) END DO ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & KEEP8,NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ENDIF 100 CONTINUE END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF (COMPRESS_CB) THEN CALL UPD_MRY_CB_FR(NFRONT-NASS, NFRONT-NASS, 0) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER #endif END SUBROUTINE CMUMPS_BLR_UPD_CB_LEFT SUBROUTINE CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, DECOMP_TIMER, & BEG_I_IN, END_I_IN, ONLY_NELIM_IN & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: COPY_DENSE_BLOCKS INTEGER, intent(in) :: NB_BLR, CURRENT_BLR INTEGER, intent(in) :: BEGS_BLR_DIAG, & BEGS_BLR_FIRST_OFFDIAG TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(:) CHARACTER(len=1) :: DIR INTEGER, intent(in) :: LDA11, LDA21 INTEGER, intent(in) :: DECOMP_TIMER INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN, ONLY_NELIM_IN INTEGER :: IP, M, N, BIP, BIP_START, BEG_I, END_I, ONLY_NELIM #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER :: K, I DOUBLE PRECISION :: PROMOTE_COST INTEGER(8) :: POSELT_BLOCK, LD_BLK_IN_FRONT COMPLEX :: ONE, ALPHA, ZERO PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN ELSE BEG_I = CURRENT_BLR+1 ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN ELSE END_I = NB_BLR ENDIF IF(present(ONLY_NELIM_IN)) THEN ONLY_NELIM = ONLY_NELIM_IN ELSE ONLY_NELIM = 0 ENDIF LD_BLK_IN_FRONT = int(LDA11,8) BIP_START = BEGS_BLR_FIRST_OFFDIAG IF (BEG_I .NE. CURRENT_BLR+1) THEN DO I = 1, BEG_I - CURRENT_BLR - 1 BIP_START = BIP_START + BLR_PANEL(I)%M ENDDO ENDIF #if defined(BLR_NOOPENMP) BIP = BIP_START #endif #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC, CHUNK) #endif DO IP = BEG_I, END_I #if ! defined(BLR_NOOPENMP) BIP = BIP_START DO I = BEG_I, IP-1 BIP = BIP + BLR_PANEL(I-CURRENT_BLR)%M ENDDO #endif IF (DIR .eq. 'V') THEN IF (BIP .LE. LDA21) THEN POSELT_BLOCK = POSELT + int(LDA11,8)*int(BIP-1,8) + & int(BEGS_BLR_DIAG - 1,8) ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(LDA21,8)+ & int(BEGS_BLR_DIAG - 1,8) POSELT_BLOCK = POSELT_BLOCK + & int(LDA21,8)*int(BIP-1-LDA21,8) LD_BLK_IN_FRONT=int(LDA21,8) ENDIF ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(BEGS_BLR_DIAG-1,8) & + int(BIP-1,8) ENDIF M = BLR_PANEL(IP-CURRENT_BLR)%M N = BLR_PANEL(IP-CURRENT_BLR)%N IF(present(ONLY_NELIM_IN)) THEN ONLY_NELIM = ONLY_NELIM_IN ELSE ONLY_NELIM = N ENDIF K = BLR_PANEL(IP-CURRENT_BLR)%K IF (BLR_PANEL(IP-CURRENT_BLR)%ISLR) THEN IF (K.EQ.0) THEN IF (DIR .eq. 'V') THEN DO I = 1, M IF (BIP+I-1.GT.LDA21) THEN LD_BLK_IN_FRONT = int(LDA21,8) ENDIF A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT & + int(N-1,8)) = ZERO ENDDO ELSE DO I = N-ONLY_NELIM+1, N A(POSELT_BLOCK+int(I-1,8)*int(LDA11,8): & POSELT_BLOCK+int(I-1,8)*int(LDA11,8) + int(M-1,8)) & = ZERO ENDDO ENDIF GOTO 1800 ENDIF IF (DIR .eq. 'V') THEN IF (DIR .eq.'V' .AND. BIP .LE. LDA21 & .AND. BIP + M - 1 .GT. LDA21) THEN CALL cgemm('T', 'T', N, LDA21-BIP+1, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) CALL cgemm('T', 'T', N, BIP+M-LDA21-1, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(LDA21-BIP+2,1) , M, & ZERO, A(POSELT_BLOCK+int(LDA21-BIP,8)*int(LDA11,8)), & LDA21) ELSE CALL cgemm('T', 'T', N, M, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) ENDIF ELSE CALL cgemm('N', 'N', M, ONLY_NELIM, K, ONE, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1), M, & BLR_PANEL(IP-CURRENT_BLR)%R(1,N-ONLY_NELIM+1), K, ZERO, & A(POSELT_BLOCK+int(N-ONLY_NELIM,8)*int(LDA11,8)), LDA11) ENDIF PROMOTE_COST = 2.0D0*M*K*ONLY_NELIM IF(present(ONLY_NELIM_IN)) THEN CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .FALSE.) ENDIF ELSE IF (COPY_DENSE_BLOCKS) THEN IF (DIR .eq. 'V') THEN DO I = 1, M IF (BIP+I-1.GT.LDA21) THEN LD_BLK_IN_FRONT = int(LDA21,8) ENDIF A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT & + int(N-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N) ENDDO ELSE DO I = N-ONLY_NELIM+1, N A(POSELT_BLOCK+int(I-1,8)*int(LDA11,8): & POSELT_BLOCK+int(I-1,8)*int(LDA11,8) + int(M-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) ENDDO ENDIF ENDIF 1800 CONTINUE #if defined(BLR_NOOPENMP) BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif END SUBROUTINE CMUMPS_DECOMPRESS_PANEL SUBROUTINE CMUMPS_COMPRESS_CB(A, LA, POSELT, LDA, & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY, & NELIM, & NBROWSinF & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & KPERCENT, TOL_OPT, LWORK INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), TARGET, intent(inout) :: CB_LRB(:,:) INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U REAL, TARGET, DIMENSION(:) :: RWORK COMPLEX, TARGET, DIMENSION(:,:) :: BLOCK COMPLEX, TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER(8) :: KEEP8(150) REAL,intent(in) :: TOLEPS INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500) REAL, OPTIONAL :: M_ARRAY(max(NFS4FATHER,1)) INTEGER, intent(in), OPTIONAL :: NELIM INTEGER, intent(in), OPTIONAL :: NBROWSinF INTEGER :: M, N, INFO INTEGER :: I, J, IBIS, IBIS_END, RANK, MAXRANK, II, JJ INTEGER(8) :: POSELT_BLOCK LOGICAL :: ISLR TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: OMP_NUM INTEGER(8) :: POSA, ASIZE INTEGER :: NROWS_CM #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif REAL, POINTER, DIMENSION(:) :: RWORK_THR COMPLEX, POINTER, DIMENSION(:,:) :: BLOCK_THR COMPLEX, POINTER, DIMENSION(:) :: WORK_THR, TAU_THR INTEGER, POINTER, DIMENSION(:) :: JPVT_THR COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & (NFS4FATHER.GT.0) ) THEN IF (NIV.EQ.1) THEN NROWS_CM = NROWS - (NFS4FATHER-NELIM) ELSE NROWS_CM = NROWS - NBROWSinF ENDIF IF (NROWS_CM-NVSCHUR_K253.GT.0) THEN IF (NIV.EQ.1) THEN POSA = POSELT & + int(LDA,8)*int(NPIV+NFS4FATHER,8) & + int(NPIV,8) ASIZE = int(LDA,8)*int(LDA,8) & - int(LDA,8)*int(NPIV+NFS4FATHER,8) & - int(NPIV,8) ELSE POSA = POSELT & + int(LDA,8)*int(NBROWSinF,8) & + int(NPIV,8) ASIZE = int(NROWS,8)*int(LDA,8) & - int(LDA,8)*int(NBROWSinF,8) & - int(NPIV,8) ENDIF CALL CMUMPS_COMPUTE_MAXPERCOL ( & A(POSA), ASIZE, LDA, & NROWS_CM-NVSCHUR_K253, & M_ARRAY(1), NFS4FATHER, .FALSE., & -9999) ELSE DO I=1, NFS4FATHER M_ARRAY(I) = ZERO ENDDO ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (SYM.EQ.0.OR.NIV.EQ.2) THEN IBIS_END = NB_ROWS*NB_COLS ELSE IBIS_END = NB_ROWS*(NB_COLS+1)/2 ENDIF #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELT_BLOCK, M, N, OMP_NUM, INFO, RANK, !$OMP& MAXRANK, ISLR, II, JJ, LRB) #endif DO IBIS = 1,IBIS_END IF (IFLAG.LT.0) CYCLE OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) WORK_THR => WORK(OMP_NUM*LWORK+1: & (OMP_NUM+1)*LWORK) RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: & (OMP_NUM+1)*2*MAXI_CLUSTER) IF (SYM.EQ.0.OR.NIV.EQ.2) THEN I = (IBIS-1)/NB_COLS+1 J = IBIS - (I-1)*NB_COLS ELSE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 ENDIF IF (NIV.EQ.1) THEN I = I+NB_INASM J = J+NB_INASM ELSE J = J+NB_INASM IF (SYM.NE.0) THEN IF (BEGS_BLR_U(J).GE.BEGS_BLR(I+2)+NCOLS-NROWS-1+ & BEGS_BLR_U(NB_INASM+1)) THEN CYCLE ENDIF ENDIF ENDIF IF (NIV.EQ.1) THEN M = BEGS_BLR(I+1)-BEGS_BLR(I) POSELT_BLOCK = POSELT + int(LDA,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR_U(J)-1,8) IF (I .EQ. NB_INASM+1 .AND. present(NELIM)) THEN POSELT_BLOCK = POSELT_BLOCK + int(NELIM,8)*int(LDA,8) M = M - NELIM ENDIF N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ELSE M = BEGS_BLR(I+2)-BEGS_BLR(I+1) POSELT_BLOCK = POSELT + int(LDA,8)*int(BEGS_BLR(I+1)-1,8) & + int(BEGS_BLR_U(J)-1,8) IF (SYM.EQ.0) THEN N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ELSE N = min(BEGS_BLR_U(J+1), BEGS_BLR(I+2) + NCOLS - NROWS -1 & + BEGS_BLR_U(NB_INASM+1)) - BEGS_BLR_U(J) ENDIF ENDIF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (NIV.EQ.1) THEN LRB => CB_LRB(I-NB_INASM,J-NB_INASM) ELSE LRB => CB_LRB(I,J-NB_INASM) ENDIF IF (K489.EQ.3) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 ISLR = .FALSE. GOTO 3800 ENDIF DO II=1,M BLOCK_THR(II,1:N)= & A( POSELT_BLOCK+int(II-1,8)*int(LDA,8) : & POSELT_BLOCK+int(II-1,8)*int(LDA,8)+int(N-1,8) ) ENDDO MAXRANK = floor(real(M*N)/real(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL CMUMPS_TRUNCATED_RRQR( M, N, & BLOCK_THR(1,1), & MAXI_CLUSTER, JPVT_THR(1), & TAU_THR(1), & WORK_THR(1), N, & RWORK_THR(1), & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO, & ISLR) 3800 CONTINUE IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A CB BLOCK" CALL MUMPS_ABORT() END IF CALL ALLOC_LRB(LRB, RANK, M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF (ISLR) THEN IF (RANK .GT. 0) THEN DO JJ=1,N DO II=1,MIN(RANK,JJ) LRB%R(II,JPVT_THR(JJ)) = BLOCK_THR(II,JJ) ENDDO IF(JJ.LT.RANK) LRB%R(MIN(RANK,JJ)+1:RANK,JPVT_THR(JJ)) & = ZERO ENDDO CALL cungqr & (M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & WORK_THR(1), LWORK, INFO ) DO II=1,RANK DO JJ= 1, M LRB%Q(JJ,II) = BLOCK_THR(JJ,II) ENDDO END DO IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNGQR WHILE COMPRESSING A CB BLOCK" CALL MUMPS_ABORT() END IF IF (K489.NE.3) THEN CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, & LRB%ISLR, CB_COMPRESS=.TRUE.) ENDIF END IF CALL UPD_MRY_CB_LRGAIN(LRB%M, LRB%N, LRB%K & ) ELSE DO II=1,M LRB%Q(II,1:N) = & A( POSELT_BLOCK+int((II-1),8)*int(LDA,8) : & POSELT_BLOCK+int((II-1),8)*int(LDA,8) & +int(N-1,8) ) END DO IF (K489.NE.3) THEN CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, & LRB%ISLR, CB_COMPRESS=.TRUE.) ENDIF LRB%K = -1 END IF END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif CALL UPD_MRY_CB_FR(NROWS, NCOLS, SYM) #if ! defined(BLR_NOOPENMP) !$OMP END MASTER #endif END SUBROUTINE CMUMPS_COMPRESS_CB SUBROUTINE CMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K458, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8, & K480, BEG_I_IN, END_I_IN, FRSWAP & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), TARGET, intent(inout) :: BLR_PANEL(:) REAL, TARGET, DIMENSION(:) :: RWORK COMPLEX, TARGET, DIMENSION(:,:) :: BLOCK COMPLEX, TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER :: BEGS_BLR(:) INTEGER(8) :: KEEP8(150) INTEGER, OPTIONAL, intent(in) :: K480 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN LOGICAL, OPTIONAL, intent(in) :: FRSWAP INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, & K458, K473, TOL_OPT LOGICAL, intent(in) :: LBANDSLAVE INTEGER :: MAXI_CLUSTER, LWORK, NELIM REAL,intent(in) :: TOLEPS CHARACTER(len=1) :: DIR INTEGER :: IP, NB_BLOCKS_PANEL, M, N, RANK, MAXRANK INTEGER :: INFO, I, J, K, IS, BEG_I, END_I INTEGER(8) :: POSELT_BLOCK LOGICAL :: ISLR COMPLEX :: ONE, ALPHA, ZERO PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: OMP_NUM REAL, POINTER, DIMENSION(:) :: RWORK_THR COMPLEX, POINTER, DIMENSION(:,:) :: BLOCK_THR COMPLEX, POINTER, DIMENSION(:) :: WORK_THR, TAU_THR INTEGER, POINTER, DIMENSION(:) :: JPVT_THR #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN ELSE BEG_I = CURRENT_BLR+1 ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN ELSE END_I = NB_BLR ENDIF IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS=0 ENDIF IF (DIR .eq. 'V') THEN IF (LBANDSLAVE) THEN N = NPIV ELSE N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ENDIF ELSE IF (DIR .eq. 'H') THEN N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ELSE WRITE(*,*) " WRONG ARGUMENT IN CMUMPS_COMPRESS_PANEL " CALL MUMPS_ABORT() END IF NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO PRIVATE(INFO, POSELT_BLOCK, RANK, MAXRANK, I, J, OMP_NUM, LRB) !$OMP& SCHEDULE(DYNAMIC,CHUNK) #endif DO IP = BEG_I, END_I IF (IFLAG.LT.0) CYCLE #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) WORK_THR => WORK(OMP_NUM*LWORK+1: & (OMP_NUM+1)*LWORK) RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: & (OMP_NUM+1)*2*MAXI_CLUSTER) LRB => BLR_PANEL(IP-CURRENT_BLR) RANK = 0 M = BEGS_BLR(IP+1)-BEGS_BLR(IP) IF (DIR .eq. 'V') THEN POSELT_BLOCK = POSELT + & int(NFRONT,8) * int(BEGS_BLR(IP)-1,8) + & int(BEGS_BLR(CURRENT_BLR) + IS - 1,8) ELSE POSELT_BLOCK = POSELT + & int(NFRONT,8)*int(BEGS_BLR(CURRENT_BLR)-1,8) + & int( BEGS_BLR(IP) - 1,8) ENDIF IF (present(K480)) then IF (K480.GE.5) THEN IF (LRB%ISLR) THEN IF (M.NE.LRB%M) THEN write(*,*) 'Internal error in CMUMPS_COMPRESS_PANEL', & ' M size inconsistency',M, & LRB%M CALL MUMPS_ABORT() ENDIF IF (N.NE.LRB%N) THEN write(*,*) 'Internal error in CMUMPS_COMPRESS_PANEL', & ' N size inconsistency',N, & LRB%N CALL MUMPS_ABORT() ENDIF MAXRANK = floor(real(M*N)/real(M+N)) IF (LRB%K.GT.MAXRANK) THEN write(*,*) 'Internal error in CMUMPS_COMPRESS_PANEL', & ' MAXRANK inconsistency',MAXRANK, & LRB%K CALL MUMPS_ABORT() ENDIF GOTO 3000 ENDIF ENDIF ENDIF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (K473.EQ.1 .OR. IP .LT. BEG_I+K458) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 ISLR = .FALSE. GOTO 3800 ENDIF IF (DIR .eq. 'V') THEN DO I=1,M BLOCK_THR(I,1:N)= & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(N-1,8) ) END DO ELSE DO I=1,N BLOCK_THR(1:M,I)= & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) END DO END IF MAXRANK = floor(real(M*N)/real(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL CMUMPS_TRUNCATED_RRQR( M, N, & BLOCK_THR(1,1), & MAXI_CLUSTER, JPVT_THR(1), & TAU_THR(1), & WORK_THR(1), N, & RWORK_THR(1), & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO, & ISLR) 3800 CONTINUE IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF CALL ALLOC_LRB(LRB, RANK, & M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF ((M.EQ.0).OR.(N.EQ.0)) THEN GOTO 3000 ENDIF IF (ISLR) THEN IF (RANK .EQ. 0) THEN ELSE DO J=1,N DO K=1,min(RANK,J) LRB%R(K, JPVT_THR(J)) = BLOCK_THR(K,J) ENDDO IF(J.LT.RANK) THEN LRB%R(J+1:RANK,JPVT_THR(J)) = ZERO ENDIF ENDDO CALL cungqr & (M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & WORK_THR(1), LWORK, INFO ) DO I=1,RANK DO K=1,M LRB%Q(K,I) = BLOCK_THR(K,I) ENDDO END DO IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNGQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF IF (present(FRSWAP)) THEN CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, LRB%ISLR, & FRSWAP=FRSWAP) ELSE CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, LRB%ISLR) ENDIF END IF ELSE IF (DIR .eq. 'V') THEN DO I=1,M LRB%Q(I,1:N) = & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) & +int(N-1,8) ) END DO ELSE DO I=1,N LRB%Q(1:M,I) = & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) & +int(M-1,8) ) END DO END IF IF (K473.EQ.0) THEN IF (present(FRSWAP)) THEN CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, LRB%ISLR, & FRSWAP=FRSWAP) ELSE CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, LRB%ISLR) ENDIF ENDIF LRB%K = -1 END IF 3000 CONTINUE END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO NOWAIT #endif RETURN END SUBROUTINE CMUMPS_COMPRESS_PANEL SUBROUTINE CMUMPS_BLR_PANEL_LRTRSM( & A, & LA, POSELT, NFRONT, & IBEG_BLOCK, NB_BLR, & BLR_LorU, & CURRENT_BLR, FIRST_BLOCK, LAST_BLOCK, & NIV, SYM, LorU, LBANDSLAVE, & IW, OFFSET_IW, NASS) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & NIV, SYM, LorU LOGICAL, intent(in) :: LBANDSLAVE INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: IBEG_BLOCK, FIRST_BLOCK, LAST_BLOCK INTEGER, OPTIONAL, intent(in) :: NASS COMPLEX, intent(inout) :: A(LA) TYPE(LRB_TYPE), intent(inout) :: BLR_LorU(:) INTEGER, OPTIONAL :: OFFSET_IW INTEGER, OPTIONAL :: IW(*) INTEGER(8) :: POSELT_LOCAL INTEGER :: IP, LDA #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) LDA = NFRONT IF (LorU.EQ.0.AND.SYM.NE.0.AND.NIV.EQ.2 & .AND.(.NOT.LBANDSLAVE)) THEN IF (present(NASS)) THEN LDA = NASS ELSE write(*,*) 'Internal error in CMUMPS_BLR_PANEL_LRTRSM' CALL MUMPS_ABORT() ENDIF ENDIF IF (LBANDSLAVE) THEN POSELT_LOCAL = POSELT ELSE POSELT_LOCAL = POSELT + & int(IBEG_BLOCK-1,8)*int(LDA,8) + int(IBEG_BLOCK - 1,8) ENDIF #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO !$OMP& SCHEDULE(DYNAMIC,CHUNK) #endif DO IP = FIRST_BLOCK, LAST_BLOCK CALL CMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA, & BLR_LorU(IP-CURRENT_BLR), NIV, SYM, LorU, & IW, OFFSET_IW) END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO NOWAIT #endif END SUBROUTINE CMUMPS_BLR_PANEL_LRTRSM END MODULE CMUMPS_FAC_LR MUMPS_5.8.1/src/fac_descband_data_m.F0000664000175000017500000001247715042446423017234 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_FAC_DESCBAND_DATA_M IMPLICIT NONE #if ! defined(NO_FDM_DESCBAND) INTEGER, SAVE :: INODE_WAITED_FOR PRIVATE PUBLIC :: DESCBAND_STRUC_T, MUMPS_FDBD_INIT, MUMPS_FDBD_END, & MUMPS_FDBD_SAVE_DESCBAND, MUMPS_FDBD_IS_DESCBAND_STORED, & MUMPS_FDBD_RETRIEVE_DESCBAND, & MUMPS_FDBD_FREE_DESCBAND_STRUC, & INODE_WAITED_FOR TYPE DESCBAND_STRUC_T INTEGER :: INODE, LBUFR INTEGER, POINTER, DIMENSION(:) :: BUFR END TYPE DESCBAND_STRUC_T TYPE (DESCBAND_STRUC_T), POINTER, DIMENSION(:), SAVE::FDBD_ARRAY CONTAINS SUBROUTINE MUMPS_FDBD_INIT( INITIAL_SIZE, INFO ) INTEGER, INTENT(IN) :: INITIAL_SIZE INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR ALLOCATE(FDBD_ARRAY( INITIAL_SIZE ), stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=INITIAL_SIZE RETURN ENDIF DO I=1, INITIAL_SIZE FDBD_ARRAY(I)%INODE=-9999 FDBD_ARRAY(I)%LBUFR=-9999 NULLIFY(FDBD_ARRAY(I)%BUFR) ENDDO INODE_WAITED_FOR = -1 RETURN END SUBROUTINE MUMPS_FDBD_INIT FUNCTION MUMPS_FDBD_IS_DESCBAND_STORED( INODE, IWHANDLER ) LOGICAL :: MUMPS_FDBD_IS_DESCBAND_STORED INTEGER, INTENT(IN) :: INODE INTEGER, INTENT(OUT) :: IWHANDLER INTEGER :: I DO I = 1, size(FDBD_ARRAY) IF (FDBD_ARRAY(I)%INODE .EQ. INODE) THEN IWHANDLER = I MUMPS_FDBD_IS_DESCBAND_STORED = .TRUE. RETURN ENDIF ENDDO MUMPS_FDBD_IS_DESCBAND_STORED = .FALSE. RETURN END FUNCTION MUMPS_FDBD_IS_DESCBAND_STORED SUBROUTINE MUMPS_FDBD_SAVE_DESCBAND(INODE, LBUFR, BUFR, & IWHANDLER, INFO) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX INTEGER, INTENT(IN) :: INODE, LBUFR, BUFR(LBUFR) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(OUT) :: IWHANDLER TYPE(DESCBAND_STRUC_T), POINTER, DIMENSION(:) :: FDBD_ARRAY_TMP INTEGER :: OLD_SIZE, NEW_SIZE, I, IERR IWHANDLER = -1 CALL MUMPS_FDM_START_IDX('A', 'DESCBAND', IWHANDLER, INFO) IF (INFO(1) .LT. 0) RETURN IF (IWHANDLER > size(FDBD_ARRAY)) THEN OLD_SIZE = size(FDBD_ARRAY) NEW_SIZE = max( (OLD_SIZE * 3) / 2 + 1, IWHANDLER) ALLOCATE(FDBD_ARRAY_TMP(NEW_SIZE),stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=NEW_SIZE RETURN ENDIF DO I=1, OLD_SIZE FDBD_ARRAY_TMP(I)=FDBD_ARRAY(I) ENDDO DO I=OLD_SIZE+1, NEW_SIZE FDBD_ARRAY_TMP(I)%INODE = -9999 FDBD_ARRAY_TMP(I)%LBUFR = -9999 NULLIFY(FDBD_ARRAY_TMP(I)%BUFR) ENDDO DEALLOCATE(FDBD_ARRAY) FDBD_ARRAY=>FDBD_ARRAY_TMP NULLIFY(FDBD_ARRAY_TMP) ENDIF FDBD_ARRAY(IWHANDLER)%INODE = INODE FDBD_ARRAY(IWHANDLER)%LBUFR = LBUFR ALLOCATE(FDBD_ARRAY(IWHANDLER)%BUFR(LBUFR), stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=LBUFR RETURN ENDIF FDBD_ARRAY(IWHANDLER)%BUFR = BUFR RETURN END SUBROUTINE MUMPS_FDBD_SAVE_DESCBAND SUBROUTINE MUMPS_FDBD_RETRIEVE_DESCBAND(IWHANDLER,DESCBAND_STRUC) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) TYPE (DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC #else TYPE (DESCBAND_STRUC_T), POINTER, INTENT(OUT) :: DESCBAND_STRUC #endif DESCBAND_STRUC => FDBD_ARRAY(IWHANDLER) RETURN END SUBROUTINE MUMPS_FDBD_RETRIEVE_DESCBAND SUBROUTINE MUMPS_FDBD_FREE_DESCBAND_STRUC(IWHANDLER) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX INTEGER, INTENT(INOUT) :: IWHANDLER TYPE (DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC DESCBAND_STRUC => FDBD_ARRAY(IWHANDLER) DESCBAND_STRUC%INODE = -7777 DESCBAND_STRUC%LBUFR = -7777 DEALLOCATE(DESCBAND_STRUC%BUFR) NULLIFY(DESCBAND_STRUC%BUFR) CALL MUMPS_FDM_END_IDX('A', 'DESCBAND', IWHANDLER) RETURN END SUBROUTINE MUMPS_FDBD_FREE_DESCBAND_STRUC SUBROUTINE MUMPS_FDBD_END(INFO1) INTEGER, INTENT(IN) :: INFO1 INTEGER :: I, IWHANDLER IF (.NOT. associated(FDBD_ARRAY)) THEN WRITE(*,*) "Internal error 1 in MUMPS_FAC_FDBD_END" CALL MUMPS_ABORT() ENDIF DO I=1, size(FDBD_ARRAY) IF (FDBD_ARRAY(I)%INODE .GE. 0) THEN IF (INFO1 .GE.0) THEN WRITE(*,*) "Internal error 2 in MUMPS_FAC_FDBD_END",I CALL MUMPS_ABORT() ELSE IWHANDLER=I CALL MUMPS_FDBD_FREE_DESCBAND_STRUC(IWHANDLER) ENDIF ENDIF ENDDO DEALLOCATE(FDBD_ARRAY) RETURN END SUBROUTINE MUMPS_FDBD_END #endif END MODULE MUMPS_FAC_DESCBAND_DATA_M MUMPS_5.8.1/src/zfac_front_LDLT_type2.F0000664000175000017500000010677115042446441017451 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC2_LDLT_M CONTAINS SUBROUTINE ZMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NNEGW, NNULLNEGW, NPVW, NB22T2W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP, PIVNUL_LIST_STRUCT & , LRGROUPS & ) USE ZMUMPS_FAC_FRONT_AUX_M USE ZMUMPS_FAC_FRONT_TYPE2_AUX_M USE ZMUMPS_OOC USE ZMUMPS_FAC_LR USE ZMUMPS_LR_TYPE USE MUMPS_LR_STATS USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_DATA_M !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_TEST USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW INTEGER, intent(inout) :: NNEGW, NPVW, NNULLNEGW, NB22T2W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW INTEGER(8) :: LA INTEGER, TARGET :: IW( LIW ) COMPLEX(kind=8) A( LA ) DOUBLE PRECISION UU, SEUIL TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) INTEGER NBFIN, SLAVEF, & IFLAG, IERROR, LEAF, LPOOL INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER NB_BLOC_FAC INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N), & PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL AVOID_DELAYED TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)) INTEGER(8) :: POSELT INTEGER IOLDPS, allocok, K263,J INTEGER INOPV, IFINB, NFRONT, NPIV, IEND_BLOCK INTEGER NASS, LDAFS, IBEG_BLOCK INTEGER :: NB_POSTPONED INTEGER :: IBEG_BLOCK_FOR_IPIV LOGICAL LASTPANEL, LR_ACTIVATED, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR, CURRENT_BLR INTEGER Inextpiv LOGICAL RESET_TO_ONE INTEGER K109_SAVE INTEGER XSIZE, NBKJIB_ORIG DOUBLE PRECISION UUTEMP INCLUDE 'mumps_headers.h' INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV DOUBLE PRECISION , ALLOCATABLE, DIMENSION ( : ) :: DIAG_ORIG INTEGER :: SIZEDIAG_ORIG INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY, NELIM TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PP_FIRST2SWAP_L, IFLAG_OOC INTEGER PP_LastPIVRPTRFilled INTEGER INFO_TMP(2) INTEGER :: MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_SEND COMPLEX(kind=8), POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP, BEGS_BLR_STATIC INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, I, IP, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG, APOSMAX COMPLEX(kind=8), ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION,ALLOCATABLE :: RWORK(:) COMPLEX(kind=8), ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM LOGICAL :: SWAP_OCCURRED INTEGER :: MY_NUM INTEGER PIVOT_OPTION INTEGER LAST_ROW EXTERNAL ZMUMPS_BDC_ERROR LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC DOUBLE PRECISION GW_FACTCUMUL INTEGER PIVSIZ,IWPOSPIV COMPLEX(kind=8) ONE PARAMETER (ONE=(1.0D0,0.0D0)) NULLIFY(PTDummy) NULLIFY(ACC_LUA) NULLIFY(BEGS_BLR) NULLIFY(BLR_L) NULLIFY(BLR_SEND) NULLIFY(DIAG) NULLIFY(BLR_PANEL) NULLIFY(BEGS_BLR_TMP) NULLIFY(BEGS_BLR_STATIC) IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF SWAP_OCCURRED = .FALSE. INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC=SEUIL UUTEMP=UU ENDIF RESET_TO_ONE = ((KEEP(110).GT.0).AND.(DKEEP(2).LE.0.0D0)) IF (RESET_TO_ONE) THEN K109_SAVE = KEEP(109) ENDIF IBEG_BLOCK = 1 NB_BLOC_FAC = 0 XSIZE = KEEP(IXSZ) IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) NFRONT = IW(IOLDPS+XSIZE) NASS = abs(IW(IOLDPS+2+XSIZE)) LDAFS = NASS IF ((KEEP(219).EQ.1).AND.(KEEP(207).EQ.1).AND.(KEEP(50).EQ.2) & ) THEN APOSMAX = POSELT + int(LDAFS,8)*int(LDAFS,8) NB_POSTPONED = max(NFRONT - ND(STEP(INODE)),0) CALL ZMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, A(APOSMAX), NASS, NB_POSTPONED) ENDIF IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL ZMUMPS_SET_INNERBLOCKSIZE( NBKJIB_ORIG, NASS, KEEP) IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF (LR_ACTIVATED) THEN K263 = 1 ELSE K263 = KEEP(263) IF (K263 .NE. 0 .AND. NASS/NBLR_ORIG < 4) THEN IF ( NBLR_ORIG .GT. NBKJIB_ORIG * 4 ) THEN NBLR_ORIG = max(NBKJIB_ORIG, (NASS+3)/4) ELSE K263 = 0 ENDIF ENDIF ENDIF PIVOT_OPTION = MIN(2,KEEP(468)) IF ((UUTEMP == 0.0D0) .AND. OOC_EFFECTIVE_ON_FRONT) THEN IF (K263.EQ.1.AND.(.NOT.LR_ACTIVATED)) THEN PIVOT_OPTION = 0 ENDIF ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID, ' : ZMUMPS_FAC2_LDLT failed to allocate ', & NASS, ' integers' IFLAG = -13 IERROR=NASS GO TO 500 END IF IF (KEEP(219).GE.3) THEN SIZEDIAG_ORIG = NASS ELSE SIZEDIAG_ORIG = 1 ENDIF ALLOCATE ( DIAG_ORIG(SIZEDIAG_ORIG), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID, & ' : FAC_NIV2 failed to allocate ', & NASS, ' REAL/COMPLEX entries' IFLAG=-13 IERROR=NASS GO TO 500 END IF CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF (OOC_EFFECTIVE_ON_FRONT) THEN IDUMMY = -9876 TYPEFile = TYPEF_L NextPiv2beWritten = 1 PP_FIRST2SWAP_L = NextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 2 MonBloc%NROW = NASS MonBloc%NCOL = NASS MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -66666 MonBloc%INDICES => & IW(IOLDPS+6+NFRONT+XSIZE+IW(IOLDPS+5+XSIZE) & :IOLDPS+5+2*NFRONT+XSIZE+IW(IOLDPS+5+XSIZE)) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(475).EQ.3) THEN IF (UUTEMP == 0.0D0) THEN PIVOT_OPTION = 0 ELSE PIVOT_OPTION = 1 ENDIF ENDIF CNT_NODES = CNT_NODES + 1 ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.2) .AND. & OOC_EFFECTIVE_ON_FRONT ) IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & 0, KEEP(488), .FALSE., KEEP(472), & NFRONT, KEEP(1)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 480 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL ZMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 CALL ZMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .TRUE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF LASTPANEL = .FALSE. DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = BEGS_BLR(CURRENT_BLR+1)-1 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 480 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (K263.EQ.0) THEN IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK ELSE IBEG_BLOCK_FOR_IPIV = IBEG_BLR ENDIF CALL ZMUMPS_FAC_I_LDLT_NIV2( & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, & NFRONT,NASS,IBEG_BLOCK_FOR_IPIV, & IBEG_BLOCK, IEND_BLOCK, & NASS, IPIV, & N,INODE,IW,LIW,A,LA, & NNEGW,NNULLNEGW, NB22T2W,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INOPV, & IFLAG,IERROR,IOLDPS,POSELT,UU, SEUIL_LOC, & KEEP,KEEP8,PIVSIZ, & DKEEP(1), PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, & PIVOT_OPTION, & Inextpiv, IEND_BLR, LR_ACTIVATED, & OOC_EFFECTIVE_ON_FRONT) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ. 1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTPANEL = .TRUE. ELSE IF (INOPV .LE. 0) THEN INOPV = 0 NPVW = NPVW + PIVSIZ CALL ZMUMPS_FAC_MQ_LDLT_NIV2(IEND_BLOCK, & NASS, IW(IOLDPS+1+XSIZE), INODE,A,LA, & LDAFS, POSELT,IFINB, & PIVSIZ, & KEEP(219), & PIVOT_OPTION, IEND_BLR, LR_ACTIVATED) IF(PIVSIZ .EQ. 2) THEN IWPOSPIV = IOLDPS+XSIZE+IW(IOLDPS+1+XSIZE)+6+ & IW(IOLDPS+5+XSIZE) IW(IWPOSPIV+NFRONT) = -IW(IWPOSPIV+NFRONT) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB .EQ. -1) THEN LASTPANEL = .TRUE. ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN IF (.NOT.RESET_TO_ONE.OR.K109_SAVE.EQ.KEEP(109)) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF ENDIF IF (K263.eq.0) THEN NELIM = IEND_BLR - NPIV CALL ZMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEG_BLOCK, NPIV, IPIV, NASS,LASTPANEL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, .FALSE. & , NPARTSASS, CURRENT_BLR, BLR_DUMMY, LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN CALL ZMUMPS_RESET_TO_ONE( & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), & NPIV, IBEG_BLOCK, & K109_SAVE, KEEP(109), PIVNUL_LIST_STRUCT, & A, POSELT, LA, LDAFS) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF ENDIF IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & -6666, -6666, & IEND_BLR, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ENDIF CALL MUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 500 ENDIF NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_FAC2_LDLT", & IEND_BLR, IEND_BLOCK CALL MUMPS_ABORT() ENDIF IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) NULLIFY(BLR_L) ENDIF GOTO 101 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), KEEP(458), & KEEP(473), BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8 & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (PIVOT_OPTION.LT.2) THEN CALL ZMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NB_BLR, 2, 1, 0, .FALSE., & IW, OFFSET_IW=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1, & NASS=NASS) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 480 IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ENDIF ENDIF 101 CONTINUE IF (.NOT. LR_ACTIVATED) THEN CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS, NASS, INODE, A, LA, & LDAFS, POSELT, & KEEP, KEEP8, & IEND_BLR, NASS, & -6666, -6666, & (PIVOT_OPTION.LE.1), .FALSE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ENDIF IF (K263.NE.0) THEN NELIM = IEND_BLR-NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_L)) THEN BLR_SEND=>BLR_L ENDIF CALL ZMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEG_BLR, NPIV, IPIV, NASS,LASTPANEL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S,PTRFAC,STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR , BLR_SEND , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN CALL ZMUMPS_RESET_TO_ONE( & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), & NPIV, IBEG_BLR, & K109_SAVE, KEEP(109), PIVNUL_LIST_STRUCT, & A, POSELT, LA, LDAFS) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF ENDIF IF (.NOT. LR_ACTIVATED) THEN IF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & -6666, -6666, & NASS, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ELSE NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) THEN CALL MUMPS_ABORT() ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN CALL ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NASS, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 2, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8) ENDIF ENDIF IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 450 IF (KEEP(480).LT.2) THEN CALL ZMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, & IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, & MAXI_CLUSTER, NPIV, & 2, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (PIVOT_OPTION.LT.2) THEN IF ((UU.GT.0).OR.(KEEP(486).NE.2)) THEN CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, NASS, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, & 'V', 1) ENDIF ENDIF 450 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 480 IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF ENDIF GOTO 100 ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL(BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & KEEP(34)) DEALLOCATE(BLR_L) ENDIF NULLIFY(BLR_L) ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO J=1,NB_BLR+1 BEGS_BLR_TMP(J) = BEGS_BLR_STATIC(J) ENDDO ENDIF ENDIF IF ( & (KEEP(486).EQ.2) & ) THEN MEM_TOT = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP& PRIVATE(IP, NELIM) #endif #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*DIAGSIZ_STA MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(LDAFS,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN POSELT_DIAG = POSELT_DIAG + int(LDAFS,8) ENDDO CALL ZMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG, KEEP(34)) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO !$OMP SINGLE #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM_TOT,8), & .FALSE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 460 IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN DO IP=1,NPARTSASS NELIM = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8, & KEEP(34)) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, LDAFS, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(458), KEEP(473), & BLR_PANEL, IP, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 440 #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif 440 CONTINUE ENDIF 460 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 ENDIF IF ( & (KEEP(486).EQ.2) & ) THEN CALL ZMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF CALL ZMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 480 CONTINUE 500 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF(allocated(IPIV)) DEALLOCATE( IPIV ) IF (allocated(DIAG_ORIG)) DEALLOCATE(DIAG_ORIG) IF (LR_ACTIVATED) THEN IF (IFLAG.GE.0) THEN CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 1, NELIM) DO IP=1,NPARTSASS CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NPARTSASS-IP & ) ENDDO CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NASS-NELIM, 2, 2) ENDIF IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, KEEP(50), 2) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL ZMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8, KEEP(34)) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL ZMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34)) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_FAC2_LDLT SUBROUTINE ZMUMPS_RESET_TO_ONE(FRONT_INDEX_LIST, NPIV, & IBEG_BLOCK, K109_SAVE, K109, PIVNUL_LIST_STRUCT, & A, POSELT, LA, LDAFS) USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T INTEGER, INTENT(IN) :: NPIV, IBEG_BLOCK INTEGER, INTENT(IN) :: FRONT_INDEX_LIST(NPIV) INTEGER, INTENT(IN) :: K109 INTEGER, INTENT(INOUT) :: K109_SAVE TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT INTEGER(8), INTENT(IN) :: POSELT, LA INTEGER, INTENT(IN) :: LDAFS COMPLEX(kind=8), INTENT(INOUT) :: A(LA) LOGICAL :: TO_UPDATE INTEGER :: I, JJ, K COMPLEX(kind=8) ONE PARAMETER (ONE=(1.0D0,0.0D0)) DO K = K109_SAVE+1, K109 TO_UPDATE = .FALSE. I = PIVNUL_LIST_STRUCT%PIVNUL_LIST(K) DO JJ=IBEG_BLOCK, NPIV IF (FRONT_INDEX_LIST(JJ) .EQ.I) THEN TO_UPDATE=.TRUE. EXIT ENDIF ENDDO IF (TO_UPDATE) THEN A(POSELT+int(JJ,8)+int(LDAFS,8)*int(JJ-1,8))= ONE TO_UPDATE=.FALSE. ELSE write(*,*) ' Internal error related ', & 'to null pivot row detection' CALL MUMPS_ABORT() ENDIF ENDDO K109_SAVE = K109 RETURN END SUBROUTINE ZMUMPS_RESET_TO_ONE END MODULE ZMUMPS_FAC2_LDLT_M MUMPS_5.8.1/src/mumps_scotch.c0000664000175000017500000001727315042446422016112 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Interfacing with SCOTCH and pt-SCOTCH */ #include #include #include #include "mumps_scotch.h" #if defined(scotch) || defined(ptscotch) void MUMPS_CALL MUMPS_SCOTCH_WEIGHTUSED( MUMPS_INT * const weightused /* out */ ) { /* weightused(out) = 1 if weight of nodes can be used = 0 otherwise */ #if ((SCOTCH_VERSION == 6) && (SCOTCH_RELEASE >= 1)) || (SCOTCH_VERSION >= 7) *weightused=1; #else *weightused=0; #endif } void MUMPS_CALL MUMPS_SCOTCH_ESMUMPSCONTEXT( MUMPS_INT * const esmumpscontext /* out */ ) { /* esmumpscontext(out) = 1 if esmumps has a context argument to import threads = 0 otherwise */ #if ((SCOTCH_VERSION == 7) && (SCOTCH_RELEASE >= 1)) || (SCOTCH_VERSION >= 8) *esmumpscontext = 1; #else *esmumpscontext = 0; #endif } void MUMPS_CALL MUMPS_SCOTCH_ORD( const MUMPS_INT * const n, /* NCMP or N */ const MUMPS_INT * const iwlen, /* LIW8 */ MUMPS_INT * const petab, /* IPE */ const MUMPS_INT * const pfree, MUMPS_INT * const lentab, /* numbers of edges for each vertex */ MUMPS_INT * const iwtab, MUMPS_INT * const nvtab, /* weight of nodes */ MUMPS_INT * const elentab, /* permutation on output (permtab) */ MUMPS_INT * const lasttab, MUMPS_INT * const ncmpa, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) SCOTCH_Context * const contextptr, #endif MUMPS_INT * const weightused, /* out */ MUMPS_INT * const weightrequested ) /* in */ { /* weightused(out) = weightrequested since it is always used to build graph FIXME it is not exploited on output and could be suppressed from interface = 0 otherwise */ MUMPS_INT * vendtab ; /* Vertex end array */ SCOTCH_Graph grafdat; /* Graph */ #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) SCOTCH_Graph grafdat_with_context; #endif SCOTCH_Strat stratdat; MUMPS_INT vertnum; int ierr; *weightused = *weightrequested; vendtab=malloc(*n * sizeof(MUMPS_INT)); for (vertnum = 0; vertnum < *n; vertnum ++) vendtab[vertnum] = petab[vertnum] + lentab[vertnum]; ierr=SCOTCH_graphInit (&grafdat); if ( *weightrequested == 1 ) { ierr=SCOTCH_graphBuild (&grafdat, 1, *n, (SCOTCH_Num *) petab, (SCOTCH_Num *) vendtab, (SCOTCH_Num *) nvtab, NULL, *iwlen, (SCOTCH_Num *) iwtab, NULL); /* Assume Fortran-based indexing */ } else { ierr=SCOTCH_graphBuild (&grafdat, 1, *n, (SCOTCH_Num *) petab, (SCOTCH_Num *) vendtab, NULL, NULL, *iwlen, (SCOTCH_Num *) iwtab, NULL); /* Assume Fortran-based indexing */ } ierr=SCOTCH_stratInit(&stratdat); #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) /* Initialize and bind grafdat_with_context */ ierr=SCOTCH_graphInit (&grafdat_with_context); ierr=SCOTCH_contextBindGraph(contextptr, &grafdat, &grafdat_with_context); *ncmpa=SCOTCH_graphOrder(&grafdat_with_context, &stratdat, (SCOTCH_Num *) elentab, (SCOTCH_Num *) lasttab, NULL, NULL, NULL); #else /* order grafdat without threads context */ *ncmpa=SCOTCH_graphOrder(&grafdat, &stratdat, (SCOTCH_Num *) elentab, (SCOTCH_Num *) lasttab, NULL, NULL, NULL); #endif #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) SCOTCH_graphExit(&grafdat_with_context); #endif SCOTCH_stratExit(&stratdat); SCOTCH_graphExit(&grafdat); free(vendtab); } void MUMPS_CALL MUMPS_SCOTCH( const MUMPS_INT * const n, const MUMPS_INT * const iwlen, MUMPS_INT * const petab, const MUMPS_INT * const pfree, MUMPS_INT * const lentab, MUMPS_INT * const iwtab, MUMPS_INT * const nvtab, MUMPS_INT * const elentab, MUMPS_INT * const lasttab, MUMPS_INT * const ncmpa, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) SCOTCH_Context * const contextptr, #endif MUMPS_INT * const weightused, MUMPS_INT * const weightrequested ) { /* weightused(out) = 1 if weight of nodes provided in nvtab are used (esmumpsv is called) = 0 otherwise */ #if ((SCOTCH_VERSION == 6) && (SCOTCH_RELEASE >= 1)) || (SCOTCH_VERSION >= 7) /* esmumpsv with integer weights of nodes in the graph are used on entry (nvtab) */ if ( *weightrequested == 1 ) { #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) #if ((SCOTCH_VERSION == 7) && (SCOTCH_RELEASE == 0)) || (SCOTCH_VERSION <= 6) *ncmpa = -1; printf(" ** internal error: esmumpsv with threads context but Scotch version < 7.1\n"); return; #else *ncmpa = esmumpsvc( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab, contextptr ); #endif #else *ncmpa = esmumpsv( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab ); #endif *weightused=1; } else { /* esmumps (weights of nodes not used on entry) */ #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) #if ((SCOTCH_VERSION == 7) && (SCOTCH_RELEASE == 0)) || (SCOTCH_VERSION <= 6) *ncmpa = -1; printf(" ** internal error: esmumps called with threads context but Scotch version < 7.1\n"); return; #else *ncmpa = esmumpsc( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab, contextptr ); #endif #else *ncmpa = esmumps( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab ); #endif *weightused=0; } #else /* esmumps for Scotch before 6.1: no weights and no context */ *ncmpa = esmumps( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab ); *weightused=0; #endif } void MUMPS_CALL MUMPS_SCOTCH_VERSION(MUMPS_INT *version) { *version = SCOTCH_VERSION; return; } void MUMPS_CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (MUMPS_INT *PTHREAD_NUMBER) { *PTHREAD_NUMBER = -1; /* NOT SET*/ #if (SCOTCH_VERSION>=7) if (getenv("SCOTCH_PTHREAD_NUMBER")) { *PTHREAD_NUMBER = atoi(getenv("SCOTCH_PTHREAD_NUMBER")); } #endif return; } void MUMPS_CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (MUMPS_INT *PTHREAD_NUMBER) { #if (SCOTCH_VERSION>=7) char param[32]; #if defined(MUMPS_WIN32) || defined(__MINGW32__) int ierr; #endif if (*PTHREAD_NUMBER == -1) { #if defined(MUMPS_WIN32) || defined(__MINGW32__) ierr = _putenv("SCOTCH_PTHREAD_NUMBER="); #else unsetenv("SCOTCH_PTHREAD_NUMBER"); #endif } else { #if defined(MUMPS_WIN32) || defined(__MINGW32__) sprintf(param, "SCOTCH_PTHREAD_NUMBER=%d",*PTHREAD_NUMBER); ierr = _putenv(param); #else sprintf(param, "%d", *PTHREAD_NUMBER); setenv("SCOTCH_PTHREAD_NUMBER",param,1); #endif } #endif return; } #endif /* scotch or ptscotch*/ #if defined(ptscotch) void MUMPS_CALL MUMPS_DGRAPHINIT(SCOTCH_Dgraph *graphptr, MPI_Fint *comm, MPI_Fint *ierr) { MPI_Comm int_comm; int_comm = MPI_Comm_f2c(*comm); *ierr = SCOTCH_dgraphInit(graphptr, int_comm); return; } #endif MUMPS_5.8.1/src/mumps_save_restore_modes.h0000664000175000017500000000213715042446423020516 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C Define constants for possible modes: C C memory_save = compute the size of the save C file and of the structure C save = save the instance C restore = restore the instance C restore_ooc = restore the ooc part of the C instance C fake_restore = extract from the saved file C the size of the save file and of C the structure C INTEGER, PARAMETER :: memory_save_mode=1 INTEGER, PARAMETER :: save_mode=2 INTEGER, PARAMETER :: restore_mode=3 INTEGER, PARAMETER :: restore_ooc_mode=4 INTEGER, PARAMETER :: fake_restore_mode=5 MUMPS_5.8.1/src/zana_dist_m.F0000664000175000017500000040631215042446441015636 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ANA_COMPUTE_ESTIMATES ( id, idintr ) USE ZMUMPS_STRUC_DEF, ONLY: ZMUMPS_STRUC USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_INTR_STRUC USE MUMPS_ANA_OMP_M, ONLY: MUMPS_ANA_L0_OMP IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR, MASTER PARAMETER( MASTER = 0 ) TYPE(ZMUMPS_STRUC), TARGET :: id TYPE(ZMUMPS_INTR_STRUC) :: idintr INTEGER, DIMENSION(:), POINTER :: KEEP, INFO, INFOG INTEGER :: allocok INTEGER(8), DIMENSION(:), POINTER :: KEEP8 DOUBLE PRECISION, DIMENSION(:), POINTER :: RINFO DOUBLE PRECISION, DIMENSION(:), POINTER :: RINFOG INTEGER, DIMENSION(:), POINTER :: ICNTL INTEGER IRANK INTEGER :: LP, MP, MPG LOGICAL :: PROK, PROKG, LPOK LOGICAL :: I_AM_SLAVE, PERLU_ON, PRINT_MAXAVG LOGICAL :: SUM_OF_PEAKS, PRINT_NODEINFO INTEGER :: TOTAL_MBYTES_UNDER_L0 INTEGER(8) :: TOTAL_BYTES_UNDER_L0 INTEGER :: NBSTATS_I4, NBSTATS_I8 PARAMETER (NBSTATS_I4=4, NBSTATS_I8=24) INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: TNSTK_afterL0 INTEGER, ALLOCATABLE, DIMENSION(:) :: FLAGGED_LEAVES INTEGER(8) :: PEAK_UNDER_L0, PEAK_ABOVE_L0 INTEGER(8) :: SUM_NRLADU, MAX_NRLADU, MIN_NRLADU, & SUM_NRLADU_if_LR_LU, & SUM_NRLADULR_UD, SUM_NRLADULR_WC, & SUM_NRLNEC, SUM_NRLNEC_ACTIVE, & MIN_NRLNEC INTEGER :: SUM_NIRADU, & SUM_NIRADU_OOC, & SUM_NIRNEC, SUM_NIRNEC_OOC INTEGER :: LIPOOL_local INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: IPOOL INTEGER :: I, LIPOOL INTEGER(4) :: I4 INTEGER, POINTER, DIMENSION(:) :: NE_STEPSPTR INTEGER, POINTER, DIMENSION(:) :: IPOOLPTR LOGICAL :: BDUMMY INTEGER(8) :: K8_33relaxed, K8_34relaxed, K8_35relaxed, & K8_50relaxed INTEGER(8) :: ENTRIES_IN_FACTORS_LOC_MASTERS INTEGER :: OOC_STRAT, BLR_STRAT, IDUMMY, ISTEP, NBNODES_BLR INTEGER(8) :: TOTAL_BYTES, ITMP8 INTEGER(8) :: MAX_FRONT_SURFACE_LOCAL_L0, & MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO INTEGER :: MAXFR_UNDER_L0 DOUBLE PRECISION :: COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0 INTEGER(8):: SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB LOGICAL :: ABOVE_L0 INTEGER :: locMYID_NODES LOGICAL, POINTER :: locI_AM_CAND(:) INTEGER LOCAL_M, LOCAL_N INTEGER, EXTERNAL :: MUMPS_NUMROC INTEGER SBUF_SEND_FR, SBUF_REC_FR INTEGER SBUF_SEND_LR, SBUF_REC_LR INTEGER TOTAL_MBYTES INTEGER(8) SUM_KEEP811_THIS_NODE, MAX_SUM_KEEP811_THIS_NODE INTEGER SUM_INFO15_THIS_NODE, MAX_SUM_INFO15_THIS_NODE INTEGER SUM_INFO17_THIS_NODE, MAX_SUM_INFO17_THIS_NODE INTEGER(8) SBUF_RECOLD8, MIN_BUF_SIZE8 LOGICAL UPDATE_BUFFER INTEGER MIN_BUF_SIZE, SIZE_DESC_BANDE, & MaxBlocSize_FR, MaxBlocSize_BLR, & MIN_BUF_SIZE_FR, MIN_BUF_SIZE_BLR INTEGER(8) MAX_SIZE_FACTOR_TMP, KEEP26_I8_TMP KEEP => id%KEEP KEEP8 => id%KEEP8 INFO => id%INFO RINFO => id%RINFO INFOG => id%INFOG RINFOG => id%RINFOG ICNTL => id%ICNTL LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) PRINT_NODEINFO = PRINT_MAXAVG .AND. id%NPROCS .NE. id%KEEP(412) IDUMMY = 1 BDUMMY = .FALSE. IF ( I_AM_SLAVE ) THEN locI_AM_CAND => id%I_AM_CAND locMYID_NODES = id%MYID_NODES IF ( idintr%root%yes ) THEN LOCAL_M = MUMPS_NUMROC( & id%ND_STEPS(id%STEP(KEEP(38))), & idintr%root%MBLOCK, idintr%root%MYROW, 0, & idintr%root%NPROW ) LOCAL_M = max(1, LOCAL_M) LOCAL_N = MUMPS_NUMROC( & id%ND_STEPS(id%STEP(KEEP(38))), & idintr%root%NBLOCK, idintr%root%MYCOL, 0, & idintr%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 idintr%root%SCHUR_MLOC=LOCAL_M idintr%root%SCHUR_NLOC=LOCAL_N ENDIF IF ( .NOT. associated(id%CANDIDATES)) THEN ALLOCATE(id%CANDIDATES(id%NSLAVES+1,1), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF INFO(1)= -7 INFO(2)= id%NSLAVES+1 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF (KEEP(400) .GT. 0 ) THEN IF ( I_AM_SLAVE ) THEN CALL MUMPS_ANA_L0_OMP( & KEEP(400), id%N, KEEP(28), & KEEP(50), id%NSLAVES, id%DAD_STEPS, id%FRERE_STEPS, & id%FILS, id%NE_STEPS, id%ND_STEPS, id%STEP, & id%PROCNODE_STEPS, KEEP, KEEP8, locMYID_NODES, & id%NA, id%LNA, "ZMUMPS"(1:1), & id%LPOOL_B_L0_OMP, id%IPOOL_B_L0_OMP, & id%LPOOL_A_L0_OMP, id%IPOOL_A_L0_OMP, & id%L_VIRT_L0_OMP,id%VIRT_L0_OMP, id%VIRT_L0_OMP_MAPPING, & id%L_PHYS_L0_OMP,id%PHYS_L0_OMP, id%PERM_L0_OMP, & id%PTR_LEAFS_L0_OMP, & id%INFO, id%ICNTL) IF (id%INFO(1) .GE. 0) THEN ALLOCATE( & id%I4_L0_OMP(NBSTATS_I4, KEEP(400)), & id%I8_L0_OMP(NBSTATS_I8, KEEP(400)), & TNSTK_afterL0(KEEP(28)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'L0_OMP stats' END IF INFO(1)= -7 INFO(2)= NBSTATS_I4* KEEP(400) + & NBSTATS_I8* KEEP(400)*KEEP(10) & + KEEP(28) ENDIF ENDIF ELSE ALLOCATE(id%I4_L0_OMP(1,1), id%I8_L0_OMP(1,1), stat=allocok) IF (allocok.gt.0) THEN INFO(1)= -7 INFO(2)= 2 ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN CALL ZMUMPS_ANA_DISTM_UNDERL0OMP( & id%LPOOL_B_L0_OMP, id%IPOOL_B_L0_OMP(1), & id%L_VIRT_L0_OMP, & id%VIRT_L0_OMP(1), id%VIRT_L0_OMP_MAPPING(1), & id%L_PHYS_L0_OMP, id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1), & id%PTR_LEAFS_L0_OMP(1), & id%KEEP(1), id%N, id%NE_STEPS(1), id%STEP(1), & id%FRERE_STEPS(1), id%FILS(1), id%DAD_STEPS(1), & id%ND_STEPS(1), & locMYID_NODES, id%PROCNODE_STEPS(1), & id%I4_L0_OMP(1,1), NBSTATS_I4, & id%I8_L0_OMP(1,1), NBSTATS_I8, KEEP(400), & SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB, & TNSTK_afterL0, MAXFR_UNDER_L0, & MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0, NBNODES_BLR, & INFO(1), INFO(2) & ) CALL MPI_ALLREDUCE (NBNODES_BLR, KEEP(470), 1, & MPI_INTEGER, MPI_SUM, id%COMM_NODES, IERR) ENDIF ELSE IF ( I_AM_SLAVE ) THEN id%LPOOL_B_L0_OMP = 1 id%LPOOL_A_L0_OMP = 1 id%L_VIRT_L0_OMP = 1 id%L_PHYS_L0_OMP = 1 id%THREAD_LA = -1_8 ALLOCATE ( id%VIRT_L0_OMP ( id%L_VIRT_L0_OMP ), & id%VIRT_L0_OMP_MAPPING ( id%L_VIRT_L0_OMP ), & id%PERM_L0_OMP ( id%L_PHYS_L0_OMP ), & id%PTR_LEAFS_L0_OMP ( id%L_PHYS_L0_OMP + 1 ), & id%IPOOL_B_L0_OMP ( id%LPOOL_B_L0_OMP ), & id%IPOOL_A_L0_OMP ( id%LPOOL_A_L0_OMP ), & id%PHYS_L0_OMP( id%L_PHYS_L0_OMP ), & id%I4_L0_OMP(1,1), id%I8_L0_OMP(1,1), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'Allocation error in multicore' END IF INFO(1)= -7 INFO(2)= id%L_VIRT_L0_OMP & + id%L_PHYS_L0_OMP & + id%L_PHYS_L0_OMP + 1 & + id%LPOOL_B_L0_OMP & + id%LPOOL_A_L0_OMP & + id%L_PHYS_L0_OMP + 1 + KEEP(10) ENDIF ELSE ALLOCATE(id%I4_L0_OMP(1,1), id%I8_L0_OMP(1,1), stat=allocok) IF (allocok.gt.0) THEN INFO(1)= -7 INFO(2)= 2 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN IF (KEEP(400).GT.0) THEN IF (id%NSLAVES .GT.1) THEN ALLOCATE (FLAGGED_LEAVES(KEEP(28)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'L0_OMP FLAGGED LEAVES' END IF INFO(1)= -7 INFO(2)= KEEP(28) ENDIF ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN IF (KEEP(400).GT.0) THEN IF (id%NSLAVES .GT.1) THEN LIPOOL_local= & id%IPOOL_A_L0_OMP(id%LPOOL_A_L0_OMP) CALL ZMUMPS_PREP_ANA_DISTM_ABOVEL0( & id%N, id%NSLAVES, id%COMM_NODES, id%MYID_NODES, & id%STEP(1), id%DAD_STEPS(1),id%ICNTL,LP,LPOK, & id%INFO, & id%PHYS_L0_OMP(1), id%L_PHYS_L0_OMP, & id%IPOOL_A_L0_OMP(1), LIPOOL_local, & id%KEEP, TNSTK_afterL0, & FLAGGED_LEAVES & ) IF ( INFO(1).LT.0 ) GOTO 75 LIPOOL= 0 DO ISTEP=1,KEEP(28) IF (FLAGGED_LEAVES(ISTEP).GT.0) LIPOOL=LIPOOL+1 ENDDO ALLOCATE( IPOOL(max(LIPOOL,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'Allocation IPOOL' END IF INFO(1)= -7 INFO(2)= LIPOOL ENDIF ELSE LIPOOL = id%IPOOL_A_L0_OMP(id%LPOOL_A_L0_OMP) ENDIF ELSE LIPOOL = id%NA(1) ENDIF ENDIF 75 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN IF (KEEP(400) .GT. 0 ) THEN IF (id%NSLAVES .GT.1) THEN IF (LIPOOL .GT.0) THEN I =LIPOOL DO ISTEP=1, KEEP(28) IF (FLAGGED_LEAVES(ISTEP).GT.0) THEN IPOOL(I) = FLAGGED_LEAVES(ISTEP) I=I-1 ENDIF IF (I.EQ.0) EXIT ENDDO ENDIF DEALLOCATE(FLAGGED_LEAVES) IPOOLPTR => IPOOL ELSE IPOOLPTR => id%IPOOL_A_L0_OMP ENDIF ABOVE_L0 =.TRUE. NE_STEPSPTR => TNSTK_afterL0(1:KEEP(28)) ELSE IPOOLPTR => id%NA(3:3+max(LIPOOL,1)-1) ABOVE_L0 =.FALSE. SIZECB_UNDER_L0 = 0_8 SIZECB_UNDER_L0_IF_LRCB = 0_8 MAX_FRONT_SURFACE_LOCAL_L0 = 0_8 MAX_SIZE_FACTOR_L0 = 0_8 ENTRIES_IN_FACTORS_UNDER_L0= 0_8 ENTRIES_IN_FACTORS_MASTERS_LO = 0_8 MAXFR_UNDER_L0 = 0 COST_SUBTREES_UNDER_L0 = 0.0D0 OPSA_UNDER_L0 = 0.0D0 NE_STEPSPTR => id%NE_STEPS ENDIF KEEP(139) = MAXFR_UNDER_L0 CALL ZMUMPS_ANA_DISTM( locMYID_NODES, id%N, id%STEP(1), & id%FRERE_STEPS(1), id%FILS(1), IPOOLPTR(1), LIPOOL, NE_STEPSPTR & (1), id%DAD_STEPS(1), id%ND_STEPS(1), id%PROCNODE_STEPS(1), & id%NSLAVES, ABOVE_L0,SIZECB_UNDER_L0,SIZECB_UNDER_L0_IF_LRCB, & MAXFR_UNDER_L0, MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0, KEEP8(53), KEEP8(54), & KEEP8(11), KEEP(26), KEEP(15), KEEP8(12), KEEP8(14), & KEEP8(32), KEEP8(33), KEEP8(34), KEEP8(35), KEEP8(50), & KEEP8(36), KEEP8(47), KEEP8(37), KEEP8(38), KEEP8(39), & KEEP8(40), KEEP8(41), KEEP8(42), KEEP8(43), KEEP8(44), KEEP8(45), & KEEP8(46), KEEP8(51), KEEP8(52), KEEP(224),KEEP(225),KEEP(27), & RINFO(1),id%CNTL(1), KEEP(1), KEEP8(1), LOCAL_M, LOCAL_N, & SBUF_RECOLD8, SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR, & SBUF_REC_LR, id%COST_SUBTREES, KEEP(28), locI_AM_CAND(1), & max(KEEP(56),1), id%ISTEP_TO_INIV2(1), id%CANDIDATES(1,1), & INFO(1), INFO(2), KEEP8(15),MAX_SIZE_FACTOR_TMP, & KEEP8(9), ENTRIES_IN_FACTORS_LOC_MASTERS, & idintr%root%yes, idintr%root%NPROW, idintr%root%NPCOL & ) IF (ALLOCATED(IPOOL)) DEALLOCATE(IPOOL) NULLIFY(NE_STEPSPTR,IPOOLPTR) IF (KEEP(400) .GT. 0) THEN DEALLOCATE (TNSTK_afterL0) SUM_NIRNEC = 0 SUM_NIRADU = 0 SUM_NIRADU_OOC = 0 SUM_NIRNEC_OOC = 0 DO I=1, KEEP(400) SUM_NIRADU = SUM_NIRADU + id%I4_L0_OMP(1,I) SUM_NIRNEC = SUM_NIRNEC + id%I4_L0_OMP(2,I) SUM_NIRADU_OOC = SUM_NIRADU_OOC+ id%I4_L0_OMP(3,I) SUM_NIRNEC_OOC = SUM_NIRNEC_OOC+ id%I4_L0_OMP(4,I) ENDDO KEEP(26) = KEEP(26) + SUM_NIRADU KEEP(224) = KEEP(224) + SUM_NIRADU_OOC KEEP(15) = max(KEEP(15),KEEP(26)) KEEP(225) = max(KEEP(225),KEEP(224)) KEEP(137) = SUM_NIRNEC KEEP(138) = SUM_NIRNEC_OOC SUM_NIRNEC = int( & (dble(SUM_NIRNEC)*dble(KEEP(34)))/dble(KEEP(35)) & ) SUM_NIRNEC_OOC = int( & (dble(SUM_NIRNEC_OOC)*dble(KEEP(34)))/dble(KEEP(35)) & ) MAX_NRLADU = 0_8 MIN_NRLADU = id%I8_L0_OMP(1,1) SUM_NRLADU = 0_8 SUM_NRLNEC = 0_8 MIN_NRLNEC = huge(MIN_NRLNEC) SUM_NRLNEC_ACTIVE = 0_8 SUM_NRLADU_if_LR_LU = 0_8 SUM_NRLADULR_UD = 0_8 SUM_NRLADULR_WC = 0_8 DO I=1, KEEP(400) MIN_NRLADU = min(MIN_NRLADU, id%I8_L0_OMP(1,I)) MAX_NRLADU = max(MAX_NRLADU, id%I8_L0_OMP(1,I)) SUM_NRLADU = SUM_NRLADU + id%I8_L0_OMP(1,I) SUM_NRLNEC = SUM_NRLNEC + id%I8_L0_OMP(2,I) MIN_NRLNEC = min(MIN_NRLNEC, id%I8_L0_OMP(2,I)) SUM_NRLNEC_ACTIVE = SUM_NRLNEC_ACTIVE + & id%I8_L0_OMP(3,I) SUM_NRLADU_if_LR_LU = SUM_NRLADU_if_LR_LU + & id%I8_L0_OMP(4,I) SUM_NRLADULR_UD = SUM_NRLADULR_UD + & id%I8_L0_OMP(9,I) SUM_NRLADULR_WC = SUM_NRLADULR_WC + & id%I8_L0_OMP(10,I) ENDDO KEEP8(81) = KEEP8(11) KEEP8(11) = KEEP8(11) + SUM_NRLADU KEEP8(82) = KEEP8(32) KEEP8(32) = KEEP8(32) + SUM_NRLADU_if_LR_LU PEAK_UNDER_L0 = SUM_NRLNEC + MIN_NRLNEC + & int( & (dble(id%N*KEEP(400))*dble(KEEP(34)))/dble(KEEP(35)), & 8) PEAK_ABOVE_L0 = KEEP8(53)+ SUM_NRLADU + & & max( int(SBUF_SEND_FR,8), 100000_8) + & & int( & (dble(KEEP(15))*dble(KEEP(34)))/dble(KEEP(35)), & 8) KEEP8(53) = KEEP8(53)+ SUM_NRLADU KEEP8(40) = KEEP8(40)+ & SUM_NRLADU_if_LR_LU + SUM_NRLADULR_UD KEEP8(41) = KEEP8(41)+ SUM_NRLADULR_UD KEEP8(42) = KEEP8(42)+ SUM_NRLADULR_WC KEEP8(43) = KEEP8(43)+ & SUM_NRLADU_if_LR_LU + SUM_NRLADULR_UD KEEP8(44) = KEEP8(44)+ & SUM_NRLADU_if_LR_LU + SUM_NRLADULR_WC KEEP8(45) = KEEP8(45)+ SUM_NRLADULR_UD KEEP8(46) = KEEP8(46)+ SUM_NRLADULR_WC KEEP8(51) = KEEP8(51)+ SUM_NRLADU KEEP8(52) = KEEP8(52)+ SUM_NRLADULR_UD ELSE KEEP(137)=0 KEEP(138)=0 ENDIF id%DKEEP(15) = RINFO(1)/1000000.0D0 IF(ASSOCIATED(locI_AM_CAND)) NULLIFY(locI_AM_CAND) id%MAX_SURF_MASTER = KEEP8(15) KEEP8(19)=MAX_SIZE_FACTOR_TMP KEEP( 29 ) = KEEP(15) + 3* max(KEEP(12),10) & * ( KEEP(15) / 100 + 1) INFO( 19 ) = KEEP(225) + 3* 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) K8_33relaxed = KEEP8(33) + int(KEEP(12),8) * & ( KEEP8(33) /100_8 +1_8) K8_34relaxed = KEEP8(34) + int(KEEP(12),8) * & ( KEEP8(34) /100_8 +1_8) K8_35relaxed = KEEP8(35) + int(KEEP(12),8) * & ( KEEP8(35) /100_8 +1_8) K8_50relaxed = KEEP8(50) + int(KEEP(12),8) * & ( KEEP8(50) /100_8 +1_8) CALL MUMPS_ALLREDUCEI8 ( SBUF_RECOLD8, KEEP8(22), MPI_MAX, & id%COMM_NODES ) IF ( (id%NSLAVES.GT.1) & ) THEN SBUF_SEND_FR = max(SBUF_SEND_FR,KEEP(27)) SBUF_SEND_LR = max(SBUF_SEND_LR,KEEP(27)) SBUF_REC_FR = max(SBUF_REC_FR ,KEEP(27)) SBUF_REC_LR = max(SBUF_REC_LR ,KEEP(27)) ENDIF CALL MPI_ALLREDUCE (SBUF_REC_FR, KEEP(44), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) CALL MPI_ALLREDUCE (SBUF_REC_LR, KEEP(380), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) IF (KEEP(48)==5) THEN KEEP(43) = KEEP(44) KEEP(379) = KEEP(380) ELSE KEEP(43)=SBUF_SEND_FR KEEP(379)=SBUF_SEND_LR ENDIF UPDATE_BUFFER = .TRUE. MIN_BUF_SIZE8 = KEEP8(22) / int(KEEP(238),8) MIN_BUF_SIZE8 = min(MIN_BUF_SIZE8, & int(huge(I4),8)/int(KEEP(35),8) ) MIN_BUF_SIZE = max(int( MIN_BUF_SIZE8 ), KEEP(127)) SIZE_DESC_BANDE=(11+id%NSLAVES+KEEP(127)*2) MaxBlocSize_FR = min (KEEP(420), KEEP(127)) MaxBlocSize_FR = MaxBlocSize_FR*MaxBlocSize_FR MaxBlocSize_BLR = min (KEEP(142), KEEP(127)) MaxBlocSize_BLR = MaxBlocSize_BLR*MaxBlocSize_BLR MIN_BUF_SIZE_FR = MIN_BUF_SIZE MIN_BUF_SIZE_BLR = MIN_BUF_SIZE MIN_BUF_SIZE_FR = min ( MIN_BUF_SIZE_FR, & int ( min ( & dble(KEEP(44)) * & (dble(abs(KEEP(180))) / dble(100)) , & dble(huge(I4))/dble(KEEP(35)) & ) ) & ) MIN_BUF_SIZE_BLR = min ( MIN_BUF_SIZE_BLR, & int ( min ( & dble(KEEP(44)) * & (dble(abs(KEEP(181))) / dble(100)) , & dble(huge(I4))/dble(KEEP(35)) & ) ) & ) IF (KEEP(50).EQ.0) THEN KEEP(43) = max( & min(KEEP(43),MaxBlocSize_FR*max(KEEP(171),3)), & int(KEEP(43)/KEEP(172)) ) KEEP(44) = max( & min(KEEP(44), MaxBlocSize_FR*max(KEEP(171),3)), & int(KEEP(44)/KEEP(172)) ) ELSE KEEP(43) = max( & min(KEEP(43),MaxBlocSize_FR*max(KEEP(171),3)), & int((KEEP(43)*KEEP(178))/KEEP(172)) ) KEEP(44) = max( & min(KEEP(44), MaxBlocSize_FR*max(KEEP(171),3)), & int((KEEP(44)*KEEP(178))/KEEP(172)) ) ENDIF KEEP(379) = max( & min(KEEP(379), MaxBlocSize_BLR*max(KEEP(171),3)), & int(KEEP(379)/KEEP(172)) ) KEEP(380) = max( & min(KEEP(380),MaxBlocSize_BLR*max(KEEP(171),3)), & int(KEEP(380)/KEEP(172)) ) IF (UPDATE_BUFFER) THEN KEEP(43) = max(KEEP(43),MIN_BUF_SIZE_FR) + & (SIZE_DESC_BANDE * KEEP(34))/KEEP(35) KEEP(379)= max(KEEP(379),MIN_BUF_SIZE_BLR)+ & (SIZE_DESC_BANDE * KEEP(34))/KEEP(35) ENDIF IF ( (KEEP(38).NE.0) .OR. UPDATE_BUFFER) THEN KEEP(44) = max(KEEP(44),MIN_BUF_SIZE_FR) + & (SIZE_DESC_BANDE * KEEP(34))/KEEP(35) KEEP(380)= max(KEEP(380),MIN_BUF_SIZE_BLR)+ & (SIZE_DESC_BANDE * KEEP(34))/KEEP(35) ENDIF IF ( int(KEEP(43),8)*int(KEEP(35),8) .GE. & int(huge(I4)-100,8)) THEN KEEP(43) = huge(KEEP(43))-100 ENDIF IF ( int(KEEP(44),8)*int(KEEP(35),8) .GE. & int(huge(I4)-100,8)) THEN KEEP(44) = huge(KEEP(44))-100 ENDIF IF ( int(KEEP(379),8)*int(KEEP(35),8) .GE. & int(huge(I4)-100,8)) THEN KEEP(379) = huge(KEEP(379))-100 ENDIF IF ( int(KEEP(380),8)*int(KEEP(35),8) .GE. & int(huge(I4)-100,8)) THEN KEEP(380) = huge(KEEP(380))-100 ENDIF IF ( PROK ) THEN WRITE(MP,'(A,I16) ') & ' Estimated INTEGER space for factors :', & KEEP(26) WRITE(MP,'(A,I16) ') & ' INFO(3), est. complex space to store factors:', & KEEP8(11) WRITE(MP,'(A,I16) ') & ' Estimated number of entries in factors :', & KEEP8(9) WRITE(MP,'(A,I16) ') & ' Current value of space relaxation parameter :', & KEEP(12) WRITE(MP,'(A,I16) ') & ' Estimated size of IS (In Core factorization):', & KEEP(29) WRITE(MP,'(A,I16) ') & ' Estimated size of S (In Core factorization):', & KEEP8(13) WRITE(MP,'(A,I16) ') & ' Estimated size of S (OOC factorization) :', & KEEP8(17) END IF ELSE ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 KEEP8(13) = 0_8 KEEP(29) = 0 KEEP8(17)= 0_8 INFO(19) = 0 KEEP8(11) = 0_8 KEEP8(81) = 0_8 KEEP8(82) = 0_8 KEEP(26) = 0 KEEP(27) = 0 RINFO(1) = 0.0D0 K8_33relaxed = 0_8 K8_34relaxed = 0_8 K8_35relaxed = 0_8 K8_50relaxed = 0_8 IF (KEEP(400) .GT.0) THEN SUM_NIRNEC = 0 SUM_NIRADU = 0 SUM_NIRADU_OOC = 0 SUM_NIRNEC_OOC = 0 MAX_NRLADU = 0_8 MIN_NRLADU = 0_8 SUM_NRLADU = 0_8 SUM_NRLNEC = 0_8 SUM_NRLNEC_ACTIVE = 0_8 SUM_NRLADU_if_LR_LU = 0_8 SUM_NRLADULR_UD = 0_8 SUM_NRLADULR_WC = 0_8 ENDIF END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 CALL MUMPS_ALLREDUCEI8( ENTRIES_IN_FACTORS_LOC_MASTERS, & KEEP8(109), MPI_SUM, id%COMM) CALL MUMPS_ALLREDUCEI8( KEEP8(19), KEEP8(119), & MPI_MAX, id%COMM) CALL MPI_ALLREDUCE( KEEP(27), KEEP(127), 1, & MPI_INTEGER, MPI_MAX, & id%COMM, IERR) KEEP26_I8_TMP = int(KEEP(26),8) CALL MUMPS_ALLREDUCEI8( KEEP26_I8_TMP, & KEEP8(129), MPI_SUM, id%COMM) CALL MUMPS_REDUCEI8( KEEP8(11), & KEEP8(111), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4( KEEP8(111), INFOG(3) ) RINFO(5) = dble(KEEP8(32) & *int(KEEP(35),8))/1D6 CALL MUMPS_REDUCEI8( KEEP8(32), & ITMP8, MPI_SUM, & MASTER, id%COMM ) IF (id%MYID.EQ.MASTER) THEN RINFOG(15) = dble(ITMP8*int(KEEP(35),8))/1D6 ENDIF CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1, & MPI_DOUBLE_PRECISION, MPI_SUM, & id%COMM, IERR) CALL MUMPS_SETI8TOI4( KEEP8(11), INFO(3) ) INFO ( 4 ) = KEEP( 26 ) INFO ( 5 ) = KEEP( 27 ) INFO ( 7 ) = KEEP( 29 ) CALL MUMPS_SETI8TOI4( KEEP8(13), INFO(8) ) CALL MUMPS_SETI8TOI4( KEEP8(17), INFO(20) ) CALL MUMPS_SETI8TOI4( KEEP8(9), INFO(24) ) CALL MUMPS_SETI8TOI4( K8_33relaxed, INFO(29) ) CALL MUMPS_SETI8TOI4( K8_34relaxed, INFO(32) ) CALL MUMPS_SETI8TOI4( K8_35relaxed, INFO(33) ) CALL MUMPS_SETI8TOI4( K8_50relaxed, INFO(36) ) CALL MUMPS_SETI8TOI4( KEEP8(129), INFOG(4) ) INFOG( 5 ) = KEEP( 127 ) CALL MUMPS_SETI8TOI4( KEEP8(109), INFOG(20) ) CALL ZMUMPS_DIAG_ANA(id%MYID, id%COMM, KEEP(1), KEEP8(1), & INFO(1), INFOG(1), RINFO(1), RINFOG(1), ICNTL(1), & id%SIZE_SCHUR ) IF (PROK) WRITE( MP, 112 ) IF (PROKG .AND. (MPG.NE.MP)) WRITE( MPG, 112 ) SUM_KEEP811_THIS_NODE=0_8 CALL MPI_REDUCE( KEEP8(11), SUM_KEEP811_THIS_NODE, 1, & MPI_INTEGER8, & MPI_SUM, 0, id%KEEP(411), IERR ) CALL MPI_REDUCE( SUM_KEEP811_THIS_NODE, MAX_SUM_KEEP811_THIS_NODE, & 1, MPI_INTEGER8, MPI_MAX, 0, id%COMM, IERR ) IF (PROKG .AND. PRINT_NODEINFO) THEN WRITE(MPG,'(A,I16)') & ' Max. estimated space for factors per compute node :', & MAX_SUM_KEEP811_THIS_NODE ENDIF OOC_STRAT = KEEP(201) BLR_STRAT = 0 IF (KEEP(201) .NE. -1) OOC_STRAT=0 PERLU_ON = .FALSE. CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, .FALSE., & .TRUE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF KEEP8(2) = TOTAL_BYTES PERLU_ON = .TRUE. CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, & id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, .FALSE., & .TRUE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF IF ( PROK ) THEN WRITE(MP,'(A,I16) ') & ' Estimated space in MBytes for IC factorization (INFO(15)):', & TOTAL_MBYTES END IF id%INFO(15) = TOTAL_MBYTES CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(15), id%INFOG(16), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I16) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(16)):', & id%INFOG(16) ENDIF WRITE(MPG,'(A,I16) ') & ' Total space in MBytes, IC factorization (INFOG(17)):' & ,id%INFOG(17) END IF SUM_INFO15_THIS_NODE=0 CALL MPI_REDUCE( INFO(15), SUM_INFO15_THIS_NODE, 1, MPI_INTEGER, & MPI_SUM, 0, id%KEEP(411), IERR ) CALL MPI_REDUCE( SUM_INFO15_THIS_NODE, MAX_SUM_INFO15_THIS_NODE, & 1, MPI_INTEGER, MPI_MAX, 0, id%COMM, IERR ) IF ( PROKG .AND. PRINT_NODEINFO ) THEN WRITE(MPG,'(A,I16)') & ' Max. estim. space per compute node, in MBytes, IC fact :', & MAX_SUM_INFO15_THIS_NODE ENDIF OOC_STRAT = KEEP(201) BLR_STRAT = 0 #if defined(OLD_OOC_NOPANEL) IF (OOC_STRAT .NE. -1) OOC_STRAT=2 #else IF (OOC_STRAT .NE. -1) OOC_STRAT=1 #endif PERLU_ON = .FALSE. CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, .FALSE., & .TRUE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF KEEP8(3) = TOTAL_BYTES PERLU_ON = .TRUE. CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, .FALSE., & .TRUE. & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF id%INFO(17) = TOTAL_MBYTES CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(17), id%INFOG(26), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I16) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(26)):', & id%INFOG(26) ENDIF WRITE(MPG,'(A,I16) ') & ' Total space in MBytes, OOC factorization (INFOG(27)):' & ,id%INFOG(27) END IF SUM_INFO17_THIS_NODE=0 CALL MPI_REDUCE( INFO(17), SUM_INFO17_THIS_NODE, 1, MPI_INTEGER, & MPI_SUM, 0, id%KEEP(411), IERR ) CALL MPI_REDUCE( SUM_INFO17_THIS_NODE, MAX_SUM_INFO17_THIS_NODE, & 1, MPI_INTEGER, MPI_MAX, 0, id%COMM, IERR ) IF (PROKG .AND. PRINT_NODEINFO) THEN WRITE(MPG,'(A,I16)') & ' Max. estim. space per compute node, in MBytes, OOC fact :', & MAX_SUM_INFO17_THIS_NODE ENDIF IF (KEEP(494).NE.0) THEN SUM_OF_PEAKS = .TRUE. CALL ZMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, & KEEP(1), KEEP8(1), & id%MYID, id%COMM, & id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), id%NSLAVES, & id%INFO, id%INFOG, PROK, MP, PROKG, MPG & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) END IF 500 CONTINUE IF (allocated(TNSTK_afterL0)) DEALLOCATE(TNSTK_afterL0) IF (allocated(FLAGGED_LEAVES)) DEALLOCATE(FLAGGED_LEAVES) IF (INFO(1) .LT. 0) THEN IF (associated(id%IPOOL_B_L0_OMP)) THEN DEALLOCATE(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_B_L0_OMP) ENDIF IF (associated(id%IPOOL_A_L0_OMP)) THEN DEALLOCATE(id%IPOOL_A_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) ENDIF IF (associated(id%VIRT_L0_OMP)) THEN DEALLOCATE(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP) ENDIF IF (associated(id%VIRT_L0_OMP_MAPPING)) THEN DEALLOCATE(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%VIRT_L0_OMP_MAPPING) ENDIF IF (associated(id%PERM_L0_OMP)) THEN DEALLOCATE(id%PERM_L0_OMP) NULLIFY(id%PERM_L0_OMP) ENDIF IF (associated(id%PTR_LEAFS_L0_OMP)) THEN DEALLOCATE(id%PTR_LEAFS_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) ENDIF ENDIF RETURN 112 FORMAT(/' MEMORY ESTIMATIONS ... '/ & ' Estimations with standard Full-Rank (FR) factorization:') 150 FORMAT( & /' ** FAILURE DURING ZMUMPS_ANA_DRIVER, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE ZMUMPS_ANA_COMPUTE_ESTIMATES SUBROUTINE ZMUMPS_ANA_DISTM(MYID, N, STEP, FRERE, FILS, IPOOL, & LIPOOL, NE, DAD, ND, PROCNODE, SLAVEF, ABOVE_L0, SIZECB_UNDER_L0, & SIZECB_UNDER_L0_IF_LRCB, MAXFR_UNDER_L0, & MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_LO, OPSA_UNDER_L0, PEAK_FR, PEAK_FR_OOC, & NRLADU, NIRADU, NIRNEC, NRLNEC, NRLNEC_ACTIVE, & NRLADU_if_LR_LU, NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, NRLNEC_if_LR_CB, NRLADULR_UD, NRLADULR_WC, & NRLNECLR_CB_UD, NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC, & PEAK_LRLU_UD,PEAK_OOC_LRLU_UD,PEAK_OOC_LRLU_WC, PEAK_LRLUCB_UD, & PEAK_LRLUCB_WC,PEAK_OOC_LRLUCB_UD, PEAK_OOC_LRLUCB_WC, & PEAK_LRCB_UD, PEAK_OOC_LRCB_UD, NIRADU_OOC, NIRNEC_OOC, MAXFR, & OPSA, UU, KEEP,KEEP8, LOCAL_M, LOCAL_N, SBUF_RECOLD, & SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR, SBUF_REC_LR, & OPS_SUBTREE, NSTEPS, I_AM_CAND,NMB_PAR2, ISTEP_TO_INIV2, & CANDIDATES, IFLAG, IERROR, MAX_FRONT_SURFACE_LOCAL, & MAX_SIZE_FACTOR, ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS, ROOT_yes, ROOT_NPROW, ROOT_NPCOL & ) USE ZMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE IMPLICIT NONE LOGICAL, intent(in) :: ROOT_yes INTEGER, intent(in) :: ROOT_NPROW, ROOT_NPCOL INTEGER, intent(in) :: MYID, N, LIPOOL LOGICAL, intent(in) :: ABOVE_L0 INTEGER, intent(in) :: MAXFR_UNDER_L0 INTEGER(8), intent(in) :: MAX_FRONT_SURFACE_LOCAL_L0, & MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO DOUBLE PRECISION, intent(in) :: COST_SUBTREES_UNDER_LO, & OPSA_UNDER_L0 INTEGER(8), intent(inout) :: SIZECB_UNDER_L0, & SIZECB_UNDER_L0_IF_LRCB INTEGER, intent(inout) :: IFLAG, IERROR INTEGER NIRADU, NIRNEC INTEGER(8) NRLADU, NRLNEC, NRLNEC_ACTIVE INTEGER(8), intent(out) :: NRLADU_if_LR_LU, & NRLADULR_UD, NRLADULR_WC, & NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, NRLNEC_if_LR_CB, & NRLNECOOC_if_LR_LUCB, NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC INTEGER(8), intent(out):: & PEAK_FR, PEAK_FR_OOC, & PEAK_LRLU_UD, & PEAK_OOC_LRLU_UD, PEAK_OOC_LRLU_WC, & PEAK_LRLUCB_UD, PEAK_LRLUCB_WC, & PEAK_OOC_LRLUCB_UD, PEAK_OOC_LRLUCB_WC, & PEAK_LRCB_UD, PEAK_OOC_LRCB_UD INTEGER(8) NRLADU_CURRENT, NRLADU_ROOT_3 INTEGER NIRADU_OOC, NIRNEC_OOC INTEGER MAXFR, NSTEPS INTEGER(8) MAX_FRONT_SURFACE_LOCAL INTEGER STEP(N) INTEGER FRERE(NSTEPS), FILS(N), IPOOL(max(LIPOOL,1)), NE(NSTEPS), & ND(NSTEPS), PROCNODE(NSTEPS), DAD(NSTEPS) DOUBLE PRECISION UU INTEGER SLAVEF, KEEP(500), LOCAL_M, LOCAL_N INTEGER(8) KEEP8(150) INTEGER(8) ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS INTEGER SBUF_SEND_FR, SBUF_REC_FR INTEGER SBUF_SEND_LR, SBUF_REC_LR INTEGER(8) SBUF_RECOLD INTEGER NMB_PAR2 INTEGER ISTEP_TO_INIV2( KEEP(71) ) LOGICAL I_AM_CAND(NMB_PAR2) INTEGER CANDIDATES( SLAVEF+1, NMB_PAR2 ) INTEGER PHASE PARAMETER (PHASE=0) DOUBLE PRECISION OPSA DOUBLE PRECISION OPSA_LOC INTEGER(8) MAX_SIZE_FACTOR DOUBLE PRECISION OPS_SUBTREE DOUBLE PRECISION OPS_SBTR_LOC INTEGER, ALLOCATABLE, DIMENSION(:) :: TNSTK, LSTKI INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR_if_LRCB, & LSTKRLR_CB_UD, & LSTKRLR_CB_WC LOGICAL OUTER_SENDS_FR INTEGER(8) :: SAVE_SIZECB_UNDER_L0, & SAVE_SIZECB_UNDER_L0_IF_LRCB INTEGER SBUFR_FR, SBUFS_FR INTEGER SBUFR_LR, SBUFS_LR INTEGER(8) SBUFS_CB, SBUFR_CB INTEGER ITOP,NELIM,NFR INTEGER(8) ISTKR, LSTK INTEGER(8) :: NRLADU_CURRENT_MISSING INTEGER(8) :: NRLADU_CURRENT_K60_1 LOGICAL :: I_PROCESS_SCHUR_K60_1 INTEGER(8) :: ISTKR_if_LRCB, ISTKRLR_CB_UD, ISTKRLR_CB_WC, & K464_8, K465_8 INTEGER :: LRSTATUS, IDUMMY INTEGER :: NBNODES_BLR LOGICAL :: COMPRESS_PANEL, COMPRESS_CB INTEGER ISTKI, STKI, ISTKI_OOC INTEGER K,NSTK, IFATH INTEGER INODE, LEAF, IN INTEGER LEVEL, MAXITEMPCB INTEGER(8) CURRENT_ACTIVE_MEM, MAXTEMPCB LOGICAL UPDATE, UPDATEF, MASTER, MASTERF, INSSARBR INTEGER LEVELF, NCB, SIZECBI INTEGER(8) NCB8 INTEGER(8) NFR8, NELIM8 INTEGER(8) :: SIZEFRNOCBLU INTEGER :: IDUMMY_ARRAY(1) INTEGER(8) SIZECB, SIZECBINFR, SIZECB_SLAVE INTEGER(8) SIZECB_if_LRCB, SIZECB_SLAVE_if_LRCB INTEGER(8) SIZECBLR_SLAVE_UD, SIZECBLR_SLAVE_WC INTEGER(8) SIZECBLR_UD, SIZECBLR_WC INTEGER(8) SIZECBSLR, NCBS8, & SIZECBS, SIZECBINFRS INTEGER NFRS, NELIMS, NCBS, LEVELS, LRSTATUSS LOGICAL COMPRESS_CBS INTEGER(8) :: PEAK_DYN_LRLU_UD, PEAK_DYN_LRCB_UD, & PEAK_DYN_LRLUCB_UD, PEAK_DYN_LRLU_WC, & PEAK_DYN_LRLUCB_WC INTEGER SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC INTEGER EXTRA_PERM_INFO_OOC INTEGER NBROWMAX, NSLAVES_LOC, NSLAVES_PASSED, & NELIMF, NFRF, NCBF, & NBROWMAXF, LKJIB_FR, LKJIB_LR, & NBR, NBCOLFAC INTEGER(8) LEV3MAXREC, CBMAXR, CBMAXS INTEGER ALLOCOK INTEGER PANEL_SIZE LOGICAL PACKED_CB DOUBLE PRECISION OPS_NODE, OPS_NODE_MASTER, OPS_NODE_SLAVE INTEGER(8) ENTRIES_NODE_UPPER_PART, ENTRIES_NODE_LOWER_PART INTEGER :: FLAG_L0OMP PARAMETER (FLAG_L0OMP=-2014) INCLUDE 'mumps_headers.h' LOGICAL ROOT_OWNER INTEGER(8) LWK_RR INTEGER LIWK_RR INTEGER IROOT, SIZE_ROOT INTEGER WHAT INTEGER(8) IDUMMY8 INTRINSIC min, int INTRINSIC dble INTEGER ZMUMPS_OOC_GET_PANEL_SIZE EXTERNAL ZMUMPS_OOC_GET_PANEL_SIZE INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR EXTERNAL MUMPS_MAX_SURFCB_NBROWS EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, & MUMPS_IN_OR_ROOT_SSARBR logical :: FORCE_CAND, CONCERNED, UPDATES, STACKCB, MASTERSON integer :: IFSON, LEVELSON IDUMMY_ARRAY(1) = 0 IF (KEEP(50).eq.2) THEN EXTRA_PERM_INFO_OOC = 1 ELSE IF (KEEP(50).eq.0) THEN EXTRA_PERM_INFO_OOC = 2 ELSE EXTRA_PERM_INFO_OOC = 0 ENDIF PACKED_CB=( KEEP(215).EQ.0 .AND. KEEP(50).NE.0 ) MAX_FRONT_SURFACE_LOCAL=0_8 MAX_SIZE_FACTOR=0_8 ALLOCATE( LSTKR(NSTEPS), TNSTK(NSTEPS), & LSTKI(NSTEPS) , & LSTKR_if_LRCB(NSTEPS), LSTKRLR_CB_UD(NSTEPS), & LSTKRLR_CB_WC(NSTEPS), & stat=ALLOCOK) if (ALLOCOK .GT. 0) THEN IFLAG =-7 IERROR = 6*NSTEPS RETURN endif LKJIB_FR = max(KEEP(5),KEEP(6)) OUTER_SENDS_FR = (KEEP(263).NE.0 .OR. & KEEP(50).EQ.0. AND. (KEEP(468).LT.3 .OR. UU.EQ.0.0D0)) IF ( OUTER_SENDS_FR ) THEN LKJIB_FR = max(LKJIB_FR, KEEP(420)) ENDIF LKJIB_LR = max(LKJIB_FR,KEEP(142)) IF (KEEP(198).NE.0.AND.SLAVEF.GT.1) THEN LKJIB_FR = min(LKJIB_FR*KEEP(179), KEEP(435)) ENDIF TNSTK = NE LEAF = LIPOOL+1 #if defined(OLD_OOC_NOPANEL) XSIZE_OOC=XSIZE_OOC_NOPANEL #else IF (KEEP(50).EQ.0) THEN XSIZE_OOC=XSIZE_OOC_UNSYM ELSE XSIZE_OOC=XSIZE_OOC_SYM ENDIF #endif SIZEHEADER_OOC = XSIZE_OOC+6 SIZEHEADER = XSIZE_IC + 6 ISTKR_if_LRCB = 0_8 ISTKRLR_CB_UD = 0_8 ISTKRLR_CB_WC = 0_8 ISTKR = 0_8 ISTKI = 0 ISTKI_OOC = 0 NBNODES_BLR = 0 OPSA_LOC = 0.0D0 ENTRIES_IN_FACTORS_LOC = 0_8 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 OPS_SBTR_LOC = 0.0D0 NRLADU = 0_8 NIRADU = 0 NIRADU_OOC = 0 NRLADU_CURRENT_K60_1 = 0_8 I_PROCESS_SCHUR_K60_1 = .FALSE. NRLADU_CURRENT = 0_8 NRLADULR_UD = 0_8 NRLADULR_WC = 0_8 NRLADU_ROOT_3 = 0_8 NRLNEC_ACTIVE = 0_8 IF (ABOVE_L0) THEN SAVE_SIZECB_UNDER_L0 = SIZECB_UNDER_L0 SAVE_SIZECB_UNDER_L0_IF_LRCB = SIZECB_UNDER_L0_IF_LRCB ELSE SAVE_SIZECB_UNDER_L0 = 0_8 SAVE_SIZECB_UNDER_L0_IF_LRCB = 0_8 ENDIF PEAK_DYN_LRLU_UD = SAVE_SIZECB_UNDER_L0 PEAK_DYN_LRCB_UD = SAVE_SIZECB_UNDER_L0_IF_LRCB PEAK_DYN_LRLUCB_UD = SAVE_SIZECB_UNDER_L0_IF_LRCB PEAK_DYN_LRLU_WC = SAVE_SIZECB_UNDER_L0 PEAK_DYN_LRLUCB_WC = SAVE_SIZECB_UNDER_L0 NRLNEC = 0_8 NRLADU_if_LR_LU = 0_8 NRLNEC_if_LR_LU = 0_8 NRLNEC_if_LR_CB = 0_8 NRLNEC_if_LR_LUCB = 0_8 NRLNECOOC_if_LR_LUCB = 0_8 NRLNECLR_CB_UD = 0_8 NRLNECLR_LUCB_UD = 0_8 NRLNECLR_LUCB_WC = 0_8 NIRNEC = 0 NIRNEC_OOC = 0 MAXFR = 0 PEAK_FR = 0_8 PEAK_FR_OOC = 0_8 PEAK_LRLU_UD = 0_8 PEAK_OOC_LRLU_UD = 0_8 PEAK_OOC_LRLU_WC = 0_8 PEAK_LRLUCB_UD = 0_8 PEAK_LRLUCB_WC = 0_8 PEAK_OOC_LRLUCB_UD= 0_8 PEAK_OOC_LRLUCB_WC= 0_8 PEAK_LRCB_UD = 0_8 PEAK_OOC_LRCB_UD = 0_8 ITOP = 0 MAXTEMPCB = 0_8 MAXITEMPCB = 0 SBUFS_CB = 1_8 SBUFS_FR = 1 SBUFS_LR = 1 SBUFR_CB = 1_8 SBUFR_FR = 1 SBUFR_LR = 1 IF (KEEP(38) .NE. 0 .AND. KEEP(60).EQ.0) THEN INODE = KEEP(38) NRLADU_ROOT_3 = int(LOCAL_M,8)*int(LOCAL_N,8) NRLADU = NRLADU_ROOT_3 NRLNEC_ACTIVE = NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_ROOT_3) NRLNEC = NRLADU NRLADU_if_LR_LU = NRLADU_ROOT_3 NRLNECOOC_if_LR_LUCB = NRLNEC_ACTIVE NRLNEC_if_LR_LU = NRLADU NRLNEC_if_LR_CB = NRLADU NRLNEC_if_LR_LUCB = NRLADU PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD + SIZECB_UNDER_L0) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF IF (MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID) THEN NIRADU = SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) NIRADU_OOC = SIZEHEADER_OOC+2*(ND(STEP(INODE))+KEEP(253)) ELSE NIRADU = SIZEHEADER NIRADU_OOC = SIZEHEADER_OOC ENDIF NIRNEC = NIRADU NIRNEC_OOC = NIRADU_OOC ENDIF IF((KEEP(24).eq.0).OR.(KEEP(24).eq.1)) THEN FORCE_CAND=.FALSE. ELSE FORCE_CAND=(mod(KEEP(24),2).eq.0) END IF 90 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF - 1 INODE = IPOOL(LEAF) ELSE IF (LIPOOL.NE.0) THEN WRITE(MYID+6,*) ' ERROR 1 in ZMUMPS_ANA_DISTM ' CALL MUMPS_ABORT() ELSE GOTO 115 ENDIF ENDIF 95 CONTINUE NFR = ND(STEP(INODE))+KEEP(253) NFR8 = int(NFR,8) NSTK = NE(STEP(INODE)) NELIM = 0 IN = INODE 100 NELIM = NELIM + 1 NELIM8=int(NELIM,8) IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IFSON = -IN IFATH = DAD(STEP(INODE)) MASTER = MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID LEVEL = MUMPS_TYPENODE(PROCNODE(STEP(INODE)),KEEP(199)) INSSARBR = MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) UPDATE=.FALSE. if(.NOT.FORCE_CAND) then UPDATE = ( (MASTER.AND.(LEVEL.NE.3) ).OR. LEVEL.EQ.2 ) else if(MASTER.and.(LEVEL.ne.3)) then UPDATE = .TRUE. else if(LEVEL.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(INODE)))) THEN UPDATE = .TRUE. end if end if end if NCB = NFR-NELIM NCB8 = int(NCB,8) SIZECBINFR = NCB8*NCB8 IF (KEEP(50).EQ.0) THEN SIZECB = SIZECBINFR ELSE IFATH = DAD(STEP(INODE)) IF ( IFATH.NE.KEEP(38) .AND. PACKED_CB ) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = SIZECBINFR ENDIF ENDIF IDUMMY = -99999 CALL IS_FRONT_BLR_CANDIDATE (INODE, LEVEL, NFR, NELIM, & KEEP(494), 1, KEEP(490), & KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, IDUMMY) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) IF (COMPRESS_PANEL.OR.COMPRESS_CB) NBNODES_BLR = NBNODES_BLR+1 IF (COMPRESS_PANEL) THEN K464_8 = int(KEEP(464),8) ELSE K464_8 = 1000_8 ENDIF IF (COMPRESS_CB) THEN K465_8 = int(KEEP(465),8) SIZECB_if_LRCB = 0_8 SIZECBLR_UD = SIZECB*K465_8/1000_8 SIZECBLR_WC = SIZECB ELSE K465_8 = 1000_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = SIZECB ENDIF SIZECBI = 2* NCB + SIZEHEADER IF (LEVEL.NE.2) THEN NSLAVES_LOC = -99999999 SIZECB_SLAVE = -99999997_8 SIZECB_SLAVE_if_LRCB = SIZECB_SLAVE NBROWMAX = NCB ELSE IF (KEEP(48) .EQ. 5) THEN WHAT = 5 IF (FORCE_CAND) THEN NSLAVES_LOC=CANDIDATES(SLAVEF+1, & ISTEP_TO_INIV2(STEP(INODE))) ELSE NSLAVES_LOC=SLAVEF-1 ENDIF NSLAVES_PASSED=NSLAVES_LOC ELSE WHAT = 2 NSLAVES_PASSED=SLAVEF NSLAVES_LOC =SLAVEF-1 ENDIF CALL MUMPS_MAX_SURFCB_NBROWS(WHAT, KEEP,KEEP8, & NCB, NFR, NSLAVES_PASSED, NBROWMAX, SIZECB_SLAVE & ) IF (COMPRESS_CB) THEN SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_SLAVE_UD = SIZECB_SLAVE*K465_8/1000_8 SIZECBLR_SLAVE_WC = SIZECB_SLAVE ELSE SIZECB_SLAVE_if_LRCB = SIZECB_SLAVE SIZECBLR_SLAVE_UD = 0_8 SIZECBLR_SLAVE_WC = 0_8 ENDIF ENDIF IF (KEEP(60).GT.1) THEN IF (MASTER .AND. INODE.EQ.KEEP(38)) THEN NIRADU = NIRADU+SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC+ & 2*(ND(STEP(INODE))+KEEP(253)) ENDIF ENDIF IF (LEVEL.EQ.3) THEN IF ( & KEEP(60).LE.1 & ) THEN NRLADU_CURRENT = int(LOCAL_M,8)*int(LOCAL_N,8) NRLNEC = max(NRLNEC,NRLADU+ISTKR+ & NRLADU_CURRENT) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR+ & NRLADU_CURRENT) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB , & NRLADU+ISTKR_if_LRCB+ & NRLADU_CURRENT) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU+ISTKR_if_LRCB+ & NRLADU_CURRENT) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR_if_LRCB) PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF ENDIF IF (MASTER) THEN IF (NFR.GT.MAXFR) MAXFR = NFR ENDIF ENDIF IF(KEEP(86).EQ.1)THEN IF(MASTER.AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)), KEEP(199))) & )THEN IF(LEVEL.EQ.1)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8) IF (KEEP(268).NE.0) THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8+NELIM8) ENDIF ELSEIF(LEVEL.EQ.2)THEN IF(KEEP(50).EQ.0)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NELIM8) ELSE MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NELIM8*NELIM8) IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NELIM8*(NELIM8+1_8)) ENDIF ENDIF ENDIF ENDIF ENDIF IF (LEVEL.EQ.2) THEN IF (MASTER) THEN IF (KEEP(50).EQ.0) THEN SBUFS_FR = max(SBUFS_FR, NFR*LKJIB_FR+LKJIB_FR+4) SBUFS_LR = max(SBUFS_LR, NFR*LKJIB_LR+LKJIB_LR+4) ELSE SBUFS_FR = max(SBUFS_FR, NELIM*LKJIB_FR+NELIM+6) SBUFS_LR = max(SBUFS_LR, NELIM*LKJIB_LR+NELIM+6) ENDIF ELSEIF (UPDATE) THEN if (KEEP(50).EQ.0) THEN SBUFR_FR = max(SBUFR_FR, NFR*LKJIB_FR+LKJIB_FR+4) SBUFR_LR = max(SBUFR_LR, NFR*LKJIB_LR+LKJIB_LR+4) else SBUFR_FR = max( SBUFR_FR, NELIM*LKJIB_FR+NELIM+6 ) SBUFR_LR = max( SBUFR_LR, NELIM*LKJIB_LR+NELIM+6 ) SBUFS_FR = max( SBUFS_FR, NBROWMAX*LKJIB_FR+6 ) SBUFS_LR = max( SBUFS_LR, NBROWMAX*LKJIB_LR+6 ) SBUFR_FR = max( SBUFR_FR, NBROWMAX*LKJIB_FR+6 ) SBUFR_LR = max( SBUFR_LR, NBROWMAX*LKJIB_LR+6 ) endif ENDIF ENDIF IF ( UPDATE ) THEN IF ( (MASTER) .AND. (LEVEL.EQ.1) ) THEN NIRADU = NIRADU + 2*NFR + SIZEHEADER NIRADU_OOC = NIRADU_OOC + 2*NFR + SIZEHEADER_OOC PANEL_SIZE = ZMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NFR, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) IF (KEEP(50).EQ.0) THEN IF (KEEP(251) .EQ. 2) THEN NRLADU_CURRENT = int(NELIM,8) * int(NFR,8) SIZEFRNOCBLU = int(NFR-NELIM,8)*int(NELIM) ELSE NRLADU_CURRENT = int(NELIM,8)*int(2*NFR-NELIM,8) SIZEFRNOCBLU = 0_8 ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR = max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ELSE IF ( KEEP(459) .GT. 1 .AND. KEEP(50).NE.0 ) THEN CALL MUMPS_LDLTPANEL_STORAGE( NELIM, KEEP, & IDUMMY_ARRAY(1), NRLADU_CURRENT ) SIZEFRNOCBLU = int(NELIM,8)*int(NELIM,8) - & NRLADU_CURRENT NRLADU_CURRENT = NRLADU_CURRENT + & int(NELIM,8) * int(NFR-NELIM,8) ELSE SIZEFRNOCBLU = 0_8 NRLADU_CURRENT = int(NELIM,8)*int(NFR,8) ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ENDIF IF (INODE.EQ.KEEP(20).AND.(KEEP(60).EQ.1)) THEN I_PROCESS_SCHUR_K60_1 = .TRUE. NRLADU_CURRENT_K60_1 = NRLADU_CURRENT ENDIF IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_CURRENT_MISSING = 0_8 NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT ENDIF SIZECBI = 2* NCB + SIZEHEADER ELSEIF (LEVEL.EQ.2) THEN IF (MASTER) THEN NIRADU = NIRADU+SIZEHEADER +SLAVEF-1+2*NFR NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC +SLAVEF-1+2*NFR IF (KEEP(50).EQ.0) THEN NRLADU_CURRENT = int(NFR,8)*int(NELIM,8) SIZEFRNOCBLU = 0_8 NBCOLFAC = NFR ELSE NBCOLFAC = NELIM IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 ) THEN CALL MUMPS_LDLTPANEL_STORAGE( NELIM, KEEP, & IDUMMY_ARRAY(1), NRLADU_CURRENT ) SIZEFRNOCBLU = int(NELIM,8)*int(NELIM,8) - & NRLADU_CURRENT ELSE SIZEFRNOCBLU = 0_8 NRLADU_CURRENT = int(NELIM,8)*int(NELIM,8) ENDIF ENDIF PANEL_SIZE = ZMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NBCOLFAC, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) NRLADU = NRLADU + NRLADU_CURRENT IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_CURRENT_MISSING = 0_8 NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT ENDIF MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) SIZECB = 0_8 SIZECBINFR = 0_8 SIZECB_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECB=SIZECB_SLAVE SIZECBINFR = SIZECB NIRADU = NIRADU+4+NELIM+NBROWMAX NIRADU_OOC = NIRADU_OOC+4+NELIM+NBROWMAX IF (KEEP(50).EQ.0) THEN IF (KEEP(251) .EQ. 2) THEN NRLADU_CURRENT = 0_8 SIZEFRNOCBLU = int(NELIM,8)*int(NBROWMAX,8) ELSE NRLADU_CURRENT = int(NELIM,8)*int(NBROWMAX,8) SIZEFRNOCBLU = 0_8 ENDIF ELSE NRLADU_CURRENT = int(NELIM,8)*int(NCB/NSLAVES_LOC,8) SIZEFRNOCBLU = 0_8 ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_CURRENT_MISSING = 0_8 NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT ENDIF IF (KEEP(50).EQ.0) THEN SIZECBI = 7 + NBROWMAX + NCB ELSE SIZECBI = 8 + NBROWMAX + NCB ENDIF IF (KEEP(50).NE.0) THEN SIZECBI=SIZECBI+NSLAVES_LOC+ & XTRA_SLAVES_SYM ELSE SIZECBI=SIZECBI+NSLAVES_LOC+ & XTRA_SLAVES_UNSYM ENDIF ENDIF ENDIF NIRNEC = max(NIRNEC, & NIRADU+ISTKI+SIZECBI+MAXITEMPCB) NIRNEC_OOC = max(NIRNEC_OOC, & NIRADU_OOC+ISTKI_OOC+SIZECBI+MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) CURRENT_ACTIVE_MEM = ISTKR+SIZECBINFR IF ( KEEP(50).NE.0 .AND. LEVEL.EQ.1 ) THEN SIZEFRNOCBLU = SIZEFRNOCBLU + int(NELIM,8)*int(NCB,8) ENDIF CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + SIZEFRNOCBLU IF (MASTER .AND. KEEP(219).NE.0.AND. & KEEP(50).EQ.2.AND.LEVEL.EQ.2) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + int(NELIM,8) ENDIF IF (SLAVEF.EQ.1) THEN NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = & max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & MAXTEMPCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING+ & MAXTEMPCB) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & MAXTEMPCB) ENDIF IF (NSTK .NE. 0 .AND. INSSARBR .AND. & KEEP(234).NE.0 .AND. KEEP(55).EQ.0) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTKR(ITOP) ENDIF IF (SLAVEF.EQ.1) THEN NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT_MISSING) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+MAXTEMPCB+ & NRLADU_CURRENT_MISSING) ENDIF NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF IF (NFR.GT.MAXFR) MAXFR = NFR IF (ABOVE_L0.AND.MASTER.AND.(LEVEL.EQ.1)) THEN DO WHILE (IFSON.GT.0) IF (TNSTK(STEP(IFSON)).EQ.FLAG_L0OMP) THEN LEVELS = MUMPS_TYPENODE(PROCNODE(STEP(IFSON)),KEEP(199)) NFRS = ND(STEP(IFSON))+KEEP(253) NELIMS= 0 IN = IFSON DO WHILE (IN.GT.0) IN = FILS(IN) NELIMS = NELIMS + 1 ENDDO NCBS = NFRS-NELIMS NCBS8 = int(NCBS,8) SIZECBINFRS = NCBS8*NCBS8 IF (KEEP(50).EQ.0) THEN SIZECBS = SIZECBINFRS ELSE IF ( PACKED_CB ) THEN SIZECBS = (NCBS8*(NCBS8+1_8))/2_8 ELSE SIZECBS = SIZECBINFRS ENDIF ENDIF IDUMMY = -99999 CALL IS_FRONT_BLR_CANDIDATE & (IFSON, LEVELS, NFRS, NELIMS, & KEEP(494), 1, KEEP(490), & KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(IFSON)), KEEP(38), & KEEP(123), LRSTATUSS, IDUMMY) COMPRESS_CBS = ((LRSTATUSS.EQ.1).OR.(LRSTATUSS.EQ.3)) IF (COMPRESS_CBS) THEN K465_8 = int(KEEP(465),8) SIZECBSLR = SIZECBS*K465_8/1000_8 ELSE SIZECBSLR = SIZECBS ENDIF SIZECB_UNDER_L0 = SIZECB_UNDER_L0 - SIZECBS SIZECB_UNDER_L0_IF_LRCB = SIZECB_UNDER_L0_IF_LRCB & - SIZECBSLR ENDIF IFSON = FRERE(STEP(IFSON)) ENDDO ENDIF IF (NSTK.GT.0) THEN DO 70 K=1,NSTK LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK IF (K==1 .AND. INSSARBR.AND.KEEP(234).NE.0 & .AND.KEEP(55).EQ.0) THEN ELSE CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTK ENDIF LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in ZMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF 70 CONTINUE ENDIF ELSE IF (LEVEL.NE.3) THEN DO WHILE (IFSON.GT.0) UPDATES=.FALSE. MASTERSON = MUMPS_PROCNODE(PROCNODE(STEP(IFSON)),KEEP(199)) & .EQ.MYID LEVELSON = MUMPS_TYPENODE(PROCNODE(STEP(IFSON)),KEEP(199)) if(.NOT.FORCE_CAND) then UPDATES =((MASTERSON.AND.(LEVELSON.NE.3)).OR. & LEVELSON.EQ.2) else if(MASTERSON.and.(LEVELSON.ne.3)) then UPDATES = .TRUE. else if(LEVELSON.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFSON)))) then UPDATES = .TRUE. end if end if end if IF (UPDATES) THEN LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in ZMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF ENDIF IFSON = FRERE(STEP(IFSON)) END DO ENDIF IF ( & ( (INODE.NE.KEEP(20)).OR.(KEEP(60).EQ.0) ) & .AND. & ( (INODE.NE.KEEP(38)).OR.(KEEP(60).LE.1) ) & ) & THEN ENTRIES_NODE_LOWER_PART = int(NFR-NELIM,8) * int(NELIM,8) IF ( KEEP(50).EQ.0 ) THEN ENTRIES_NODE_UPPER_PART = int(NFR,8) * int(NELIM,8) ELSE ENTRIES_NODE_UPPER_PART = & (int(NELIM,8)*int(NELIM+1,8))/2_8 ENDIF IF (KEEP(50).EQ.2 .AND. LEVEL.EQ.3) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM, 0, & 1,OPS_NODE) ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) ENDIF IF (LEVEL.EQ.2) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 2,OPS_NODE_MASTER) OPS_NODE_SLAVE=OPS_NODE-OPS_NODE_MASTER ENDIF ELSE OPS_NODE = 0.0D0 ENTRIES_NODE_UPPER_PART = 0_8 ENTRIES_NODE_LOWER_PART = 0_8 ENDIF IF ( MASTER ) THEN ENTRIES_IN_FACTORS_LOC_MASTERS = & ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ENDIF IF (UPDATE.OR.LEVEL.EQ.3) THEN IF ( LEVEL .EQ. 3 ) THEN IF (ROOT_yes) THEN OPSA_LOC = OPSA_LOC + & dble( & int(OPS_NODE,8)/ & int(ROOT_NPROW*ROOT_NPCOL,8) & ) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART / & int(ROOT_NPROW*ROOT_NPCOL,8) IF (MASTER) THEN ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & mod(ENTRIES_NODE_UPPER_PART, & int(SLAVEF,8)) ENDIF ENDIF ELSE IF (MASTER .AND. LEVEL.EQ.2) THEN OPSA_LOC = OPSA_LOC + OPS_NODE_MASTER ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART + & mod(ENTRIES_NODE_LOWER_PART, & int(NSLAVES_LOC,8)) ELSE IF (MASTER .AND. LEVEL.EQ.1) THEN OPSA_LOC = OPSA_LOC + OPS_NODE ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ELSE IF (UPDATE) THEN OPSA_LOC = OPSA_LOC + & dble(OPS_NODE_SLAVE)/dble(NSLAVES_LOC) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC & + ENTRIES_NODE_LOWER_PART / & int(NSLAVES_LOC,8) ENDIF IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) .OR. NE(STEP(INODE))==0) THEN IF (LEVEL == 1) THEN OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ENDIF ENDIF ENDIF IF (IFATH .EQ. 0) THEN IF (LEAF.GT.1) THEN GOTO 90 ELSE GOTO 115 ENDIF ELSE NFRF = ND(STEP(IFATH))+KEEP(253) IF (DAD(STEP(IFATH)).EQ.0) THEN NELIMF = NFRF-KEEP(253) IF (ABOVE_L0) IN=0 ELSE NELIMF = 0 IN = IFATH DO WHILE (IN.GT.0) IN = FILS(IN) NELIMF = NELIMF+1 ENDDO ENDIF NCBF = NFRF - NELIMF LEVELF = MUMPS_TYPENODE(PROCNODE(STEP(IFATH)),KEEP(199)) MASTERF= MUMPS_PROCNODE(PROCNODE(STEP(IFATH)), & KEEP(199)).EQ.MYID UPDATEF= .FALSE. if(.NOT.FORCE_CAND) then UPDATEF= ((MASTERF.AND.(LEVELF.NE.3)).OR.LEVELF.EQ.2) else if(MASTERF.and.(LEVELF.ne.3)) then UPDATEF = .TRUE. else if (LEVELF.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFATH)))) THEN UPDATEF = .TRUE. end if end if end if CONCERNED = UPDATEF .OR. UPDATE IF (LEVELF .NE. 2) THEN NBROWMAXF = -999999 ELSE IF (KEEP(48) .EQ. 5) THEN WHAT = 4 IF (FORCE_CAND) THEN NSLAVES_LOC=CANDIDATES(SLAVEF+1, & ISTEP_TO_INIV2(STEP(IFATH))) ELSE NSLAVES_LOC=SLAVEF-1 ENDIF ELSE WHAT = 1 NSLAVES_LOC=SLAVEF ENDIF CALL MUMPS_MAX_SURFCB_NBROWS( WHAT, KEEP, KEEP8, & NCBF, NFRF, NSLAVES_LOC, NBROWMAXF, IDUMMY8 & ) ENDIF IF(LEVEL.EQ.1.AND.UPDATE.AND. & (UPDATEF.OR.LEVELF.EQ.2) & .AND.LEVELF.NE.3) THEN IF ( INSSARBR .AND. KEEP(234).NE.0) THEN NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+SIZECB+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) ENDIF PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) 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,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) IF (.NOT.COMPRESS_PANEL) THEN NRLNEC_if_LR_LU = max( & NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT) NRLNEC_if_LR_CB = max( & NRLNEC_if_LR_CB ,NRLADU + & CURRENT_ACTIVE_MEM-ISTKR + & ISTKR_if_LRCB+NRLADU_CURRENT) NRLNEC_if_LR_LUCB = max( & NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR + & ISTKR_if_LRCB+NRLADU_CURRENT) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF ENDIF ENDIF IF (LEVELF.EQ.3) THEN IF (LEVEL.EQ.1) THEN LEV3MAXREC = int(min(NCB,LOCAL_M),8) * & int(min(NCB,LOCAL_N),8) ELSE LEV3MAXREC = min(SIZECB, & int(min(NBROWMAX,LOCAL_M),8) & *int(min(NCB,LOCAL_N),8)) ENDIF MAXTEMPCB = max(MAXTEMPCB, LEV3MAXREC) MAXITEMPCB = max(MAXITEMPCB,SIZECBI+SIZEHEADER) SBUFR_CB = max(SBUFR_CB, LEV3MAXREC+int(SIZECBI,8)) NIRNEC = max(NIRNEC,NIRADU+ISTKI+ & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) ENDIF IF (CONCERNED) THEN IF (LEVELF.EQ.2) THEN IF (UPDATE.AND.(LEVEL.NE.2.OR..NOT.MASTER)) THEN IF(MASTERF)THEN NBR = min(NBROWMAXF,NBROWMAX) ELSE NBR = min(max(NELIMF,NBROWMAXF),NBROWMAX) ENDIF IF (KEEP(50).EQ.0) THEN CBMAXS = int(NBR,8)*int(NCB,8) ELSE CBMAXS = int(NBR,8)*int(NCB,8) - & (int(NBR,8)*int(NBR-1,8))/2_8 ENDIF ELSE CBMAXS = 0_8 END IF IF (MASTERF) THEN IF (LEVEL.EQ.1) THEN IF (.NOT.UPDATE) THEN NBR = min(NELIMF, NCB) ELSE NBR = 0 ENDIF ELSE NBR = min(NELIMF, NBROWMAX) ENDIF IF (KEEP(50).EQ.0) THEN CBMAXR = int(NBR,8)*NCB8 ELSE CBMAXR = int(NBR,8)*int(min(NCB,NELIMF),8)- & (int(NBR,8)*int(NBR-1,8))/2_8 CBMAXR = min(CBMAXR, int(NELIMF,8)*int(NELIMF+1,8)/2_8) CBMAXR = min(CBMAXR, SIZECB) IF ((LEVEL.EQ.1).AND.(.NOT. PACKED_CB)) THEN CBMAXR = min(CBMAXR,(NCB8*(NCB8+1_8))/2_8) ENDIF ENDIF ELSE IF (UPDATEF) THEN NBR = min(NBROWMAXF,NBROWMAX) CBMAXR = int(NBR,8) * NCB8 IF (KEEP(50).NE.0) THEN CBMAXR = CBMAXR - (int(NBR,8)*(int(NBR-1,8)))/2_8 ENDIF ELSE CBMAXR = 0_8 ENDIF ELSEIF (LEVELF.EQ.3) THEN CBMAXR = LEV3MAXREC IF (UPDATE.AND. .NOT. (MASTER.AND.LEVEL.EQ.2)) THEN CBMAXS = LEV3MAXREC ELSE CBMAXS = 0_8 ENDIF ELSE IF (MASTERF) THEN CBMAXS = 0_8 NBR = min(NFRF,NBROWMAX) IF ((LEVEL.EQ.1).AND.UPDATE) THEN NBR = 0 ENDIF CBMAXR = int(NBR,8)*int(min(NFRF,NCB),8) IF (LEVEL.EQ.2) & CBMAXR = min(CBMAXR, SIZECB_SLAVE) IF ( KEEP(50).NE.0 ) THEN CBMAXR = min(CBMAXR,(int(NFRF,8)*int(NFRF+1,8))/2_8) ELSE CBMAXR = min(CBMAXR,int(NFRF,8)*int(NFRF,8)) ENDIF ELSE CBMAXR = 0_8 CBMAXS = SIZECB ENDIF ENDIF IF (UPDATE) THEN CBMAXS = min(CBMAXS, SIZECB) IF ( .not. ( LEVELF .eq. 1 .AND. UPDATEF ) )THEN SBUFS_CB = max(SBUFS_CB, CBMAXS+int(SIZECBI,8)) ENDIF ENDIF STACKCB = .FALSE. IF (UPDATEF) THEN STACKCB = .TRUE. SIZECBI = 2 * NCB + SIZEHEADER IF (LEVEL.EQ.1) THEN IF (KEEP(50).NE.0.AND.LEVELF.NE.3 & .AND.PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF IF (MASTER) THEN IF (MASTERF) THEN SIZECBI = 2+ XSIZE_IC ENDIF ELSE IF (LEVELF.EQ.1) THEN SIZECB = min(CBMAXR,SIZECB) IF (COMPRESS_CB) THEN SIZECBLR_UD = min(SIZECBLR_UD,SIZECB) SIZECBLR_WC = min(SIZECBLR_WC,SIZECB) SIZECB_if_LRCB = min(SIZECB_if_LRCB,SIZECB) ENDIF SIZECBI = 2 * NCB + 9 SBUFR_CB = max(SBUFR_CB, int(SIZECBI,8)+SIZECB) SIZECBI = 2 * NCB + SIZEHEADER ELSE SIZECBI = 2 * NCB + 9 SBUFR_CB = max(SBUFR_CB, & min(SIZECB,CBMAXR) + int(SIZECBI,8)) MAXTEMPCB = max(MAXTEMPCB, min(SIZECB,CBMAXR)) SIZECBI = 2 * NCB + SIZEHEADER MAXITEMPCB = max(MAXITEMPCB, SIZECBI) IF ( .NOT. MASTERF ) THEN SIZECBI = 0 ELSE SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ENDIF SIZECB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = 0_8 ENDIF ELSE SIZECB = SIZECB_SLAVE SIZECBLR_UD = SIZECBLR_SLAVE_UD SIZECBLR_WC = SIZECBLR_SLAVE_WC SIZECB_if_LRCB = SIZECB_SLAVE_if_LRCB MAXTEMPCB = max(MAXTEMPCB, min(CBMAXR,SIZECB) ) MAXITEMPCB = max(MAXITEMPCB,NBROWMAX+NCB+SIZEHEADER) IF (.NOT. & (UPDATE.AND.(.NOT.MASTER).AND.(NSLAVES_LOC.EQ.1)) & ) & SBUFR_CB = max(SBUFR_CB, & min(CBMAXR,SIZECB) + int(NBROWMAX + NCB + 6,8)) IF (MASTER) THEN SIZECB = 0_8 SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 IF (MASTERF) THEN SIZECBI = 2 + XSIZE_IC ELSE SIZECBI = 0 ENDIF ELSE IF (UPDATE) THEN IF (MASTERF) THEN SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECBI = 0 ENDIF IF (KEEP(50).EQ.0) THEN SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER ELSE SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER+ NSLAVES_LOC ENDIF ELSE SIZECB = 0_8 IF ( MASTERF ) THEN SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECBI = 0 ENDIF SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 ENDIF ENDIF ELSE IF (LEVELF.NE.3) THEN STACKCB = .TRUE. SIZECB = 0_8 SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECBI = 0 IF ( (LEVEL.EQ.1) .AND. (LEVELF.NE.1) ) THEN IF (PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF SIZECBI = 2 * NCB + SIZEHEADER ELSE IF (LEVEL.EQ.2) THEN IF (MASTER) THEN SIZECBI=0 ELSE SIZECB = SIZECB_SLAVE SIZECBLR_UD = SIZECBLR_SLAVE_UD SIZECBLR_WC = SIZECBLR_SLAVE_WC SIZECB_if_LRCB = SIZECB_SLAVE_if_LRCB SIZECBI = NBROWMAX + NFR + SIZEHEADER ENDIF ENDIF ENDIF ENDIF IF (STACKCB) THEN IF (FRERE(STEP(INODE)).EQ.0) THEN write(*,*) ' ERROR 3 in ZMUMPS_ANA_DISTM' CALL MUMPS_ABORT() ENDIF ITOP = ITOP + 1 IF ( ITOP .GT. NSTEPS ) THEN WRITE(*,*) 'ERROR 4 in ZMUMPS_ANA_DISTM ' ENDIF LSTKI(ITOP) = SIZECBI ISTKI=ISTKI + SIZECBI ISTKI_OOC = ISTKI_OOC + SIZECBI + (XSIZE_OOC-XSIZE_IC) LSTKR(ITOP) = SIZECB ISTKR = ISTKR + LSTKR(ITOP) NRLNEC = max(NRLNEC,NRLADU+ISTKR+MAXTEMPCB) NIRNEC = max(NIRNEC,NIRADU+ISTKI+MAXITEMPCB) NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ & MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR+MAXTEMPCB) LSTKR_if_LRCB(ITOP) = SIZECB_if_LRCB ISTKR_if_LRCB = ISTKR_if_LRCB + LSTKR_if_LRCB(ITOP) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB, & NRLADU_if_LR_LU+ISTKR_if_LRCB + & MAXTEMPCB) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU+ISTKR_if_LRCB + & MAXTEMPCB) LSTKRLR_CB_UD(ITOP) = SIZECBLR_UD ISTKRLR_CB_UD = ISTKRLR_CB_UD + LSTKRLR_CB_UD(ITOP) LSTKRLR_CB_WC(ITOP) = SIZECBLR_WC ISTKRLR_CB_WC = ISTKRLR_CB_WC + LSTKRLR_CB_WC(ITOP) NRLNECLR_CB_UD = max(NRLNECLR_CB_UD, ISTKRLR_CB_UD) NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) ENDIF ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH GOTO 95 ELSE GOTO 90 ENDIF ENDIF 115 CONTINUE IF ( KEEP(53) .NE. 0 ) THEN IF ( KEEP(38) .ne. 0 ) THEN IROOT = KEEP( 38 ) ELSE IROOT = KEEP( 20 ) END IF ROOT_OWNER = ( MYID .eq. & MUMPS_PROCNODE( PROCNODE(STEP(IROOT)), KEEP(199) ) ) SIZE_ROOT = ND(STEP(IROOT))+KEEP(253) CALL ZMUMPS_SVD_QR_ESTIM_WK( PHASE, & KEEP(51), KEEP(51), SIZE_ROOT, & LOCAL_M, LOCAL_N, ROOT_OWNER, KEEP,KEEP8, & LIWK_RR, LWK_RR ) IF ( NRLNEC-NRLADU .LT. LWK_RR ) THEN NRLNEC = NRLADU + LWK_RR NRLNEC_if_LR_LU = NRLNEC_if_LR_LU + LWK_RR NRLNEC_if_LR_CB = NRLNEC_if_LR_CB + LWK_RR NRLNEC_if_LR_LUCB = NRLNEC_if_LR_LUCB + LWK_RR NRLNEC_ACTIVE = NRLNEC_ACTIVE + LWK_RR NRLNECOOC_if_LR_LUCB = NRLNECOOC_if_LR_LUCB + LWK_RR PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (ABOVE_L0) THEN PEAK_DYN_LRLU_UD = max( PEAK_DYN_LRLU_UD, & SIZECB_UNDER_L0 + NRLADULR_UD ) PEAK_DYN_LRCB_UD = max( PEAK_DYN_LRCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB) PEAK_DYN_LRLUCB_UD = max( PEAK_DYN_LRLUCB_UD, & SIZECB_UNDER_L0_IF_LRCB + ISTKR_if_LRCB + NRLADULR_UD) PEAK_DYN_LRLU_WC = max( PEAK_DYN_LRLU_WC, & SIZECB_UNDER_L0 + NRLADULR_WC) PEAK_DYN_LRLUCB_WC = max( PEAK_DYN_LRLUCB_WC, & SIZECB_UNDER_L0 + ISTKRLR_CB_WC + NRLADULR_WC) ENDIF END IF IF ( NIRNEC-NIRADU .LT. LIWK_RR ) THEN NIRNEC = NIRADU + LIWK_RR END IF IF ( NIRNEC_OOC-NIRADU_OOC .LT. LIWK_RR ) THEN NIRNEC_OOC = NIRADU_OOC + LIWK_RR END IF END IF NRLNEC = max(NRLNEC, NRLADU+int(KEEP(30),8)) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE, MAX_SIZE_FACTOR+ & int(KEEP(30),8)) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU + int(KEEP(30),8)) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU + int(KEEP(30),8)) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB, & NRLADU + int(KEEP(30),8)) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & MAX_SIZE_FACTOR+ int(KEEP(30),8)) PEAK_FR = SAVE_SIZECB_UNDER_L0 + NRLNEC PEAK_FR_OOC = SAVE_SIZECB_UNDER_L0 + NRLNEC_ACTIVE PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) IF (KEEP(60).EQ.1) THEN IF (I_PROCESS_SCHUR_K60_1) THEN NRLADU = NRLADU - NRLADU_CURRENT_K60_1 NRLADU_IF_LR_LU = NRLADU_IF_LR_LU - NRLADU_CURRENT_K60_1 ENDIF ENDIF IF (ABOVE_L0) THEN PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + SAVE_SIZECB_UNDER_L0_IF_LRCB) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + PEAK_DYN_LRCB_UD) PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + SAVE_SIZECB_UNDER_L0) PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + PEAK_DYN_LRLU_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + SAVE_SIZECB_UNDER_L0) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + PEAK_DYN_LRLU_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + SAVE_SIZECB_UNDER_L0) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + PEAK_DYN_LRLU_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + SAVE_SIZECB_UNDER_L0_IF_LRCB) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + PEAK_DYN_LRLUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + SAVE_SIZECB_UNDER_L0) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + PEAK_DYN_LRLUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + SAVE_SIZECB_UNDER_L0_IF_LRCB) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + PEAK_DYN_LRLUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + SAVE_SIZECB_UNDER_L0) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + PEAK_DYN_LRLUCB_WC) ENDIF SBUF_RECOLD = max(SBUFR_CB, & MAXTEMPCB+int(MAXITEMPCB,8)) + 10_8 SBUF_REC_FR = max(SBUFR_FR, int(min(100000_8,SBUFR_CB))) + 17 SBUF_REC_LR = max(SBUFR_LR, int(min(100000_8,SBUFR_CB))) + 17 SBUF_REC_FR = SBUF_REC_FR + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_REC_LR = SBUF_REC_LR + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_SEND_FR = max(SBUFS_FR, int(min(100000_8,SBUFR_CB)))+17 SBUF_SEND_LR = max(SBUFS_LR, int(min(100000_8,SBUFR_CB)))+17 IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN SBUF_RECOLD = SBUF_RECOLD+int(KEEP(108)+1,8) SBUF_REC_FR = SBUF_REC_FR+KEEP(108)+1 SBUF_REC_LR = SBUF_REC_LR+KEEP(108)+1 SBUF_SEND_FR = SBUF_SEND_FR+KEEP(108)+1 SBUF_SEND_LR = SBUF_SEND_LR+KEEP(108)+1 ENDIF IF (SLAVEF.EQ.1) THEN SBUF_RECOLD = 1_8 SBUF_REC_FR = 1 SBUF_REC_LR = 1 SBUF_SEND_FR= 1 SBUF_SEND_LR= 1 ENDIF DEALLOCATE( LSTKR, TNSTK, LSTKI, & LSTKR_if_LRCB, LSTKRLR_CB_UD, LSTKRLR_CB_WC & ) IF (ABOVE_L0) THEN KEEP(470) = KEEP(470)+ NBNODES_BLR ELSE KEEP(470) = NBNODES_BLR ENDIF IF (.NOT.ABOVE_L0) THEN PEAK_FR = NRLNEC PEAK_FR_OOC = NRLNEC_ACTIVE ENDIF MAXFR = max(MAXFR, MAXFR_UNDER_L0) MAX_FRONT_SURFACE_LOCAL = max (MAX_FRONT_SURFACE_LOCAL, & MAX_FRONT_SURFACE_LOCAL_L0) MAX_SIZE_FACTOR = max (MAX_SIZE_FACTOR, & MAX_SIZE_FACTOR_L0) ENTRIES_IN_FACTORS_LOC_MASTERS = ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_IN_FACTORS_MASTERS_LO ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_IN_FACTORS_UNDER_L0 OPS_SBTR_LOC = OPS_SBTR_LOC + COST_SUBTREES_UNDER_LO OPSA_LOC = OPSA_LOC + OPSA_UNDER_L0 OPS_SUBTREE = dble(OPS_SBTR_LOC) OPSA = dble(OPSA_LOC) RETURN END SUBROUTINE ZMUMPS_ANA_DISTM SUBROUTINE ZMUMPS_ANA_DISTM_UNDERL0OMP( & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP , VIRT_L0_OMP , VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP , PHYS_L0_OMP , PERM_L0_OMP, & PTR_LEAFS_L0_OMP, & KEEP, N, NE, STEP, FRERE, FILS, DAD, ND, & MYID, PROCNODE, & I4_L0, NBSTATS_I4, I8_L0, NBSTATS_I8, NBTHREADS, & SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB_UD, & TNSTK, MAXFR, & MAX_FRONT_SURFACE_LOCAL, MAX_SIZE_FACTOR, & ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS, & OPS_SBTR_LOC, OPSA_LOC, NBNODES_BLR, & IFLAG, IERROR ) IMPLICIT NONE INTEGER, INTENT(IN) :: LPOOL_B_L0_OMP, & L_VIRT_L0_OMP, L_PHYS_L0_OMP INTEGER, INTENT(IN) :: IPOOL_B_L0_OMP ( LPOOL_B_L0_OMP ) INTEGER, INTENT(IN) :: VIRT_L0_OMP ( L_VIRT_L0_OMP ) INTEGER, INTENT(IN) :: VIRT_L0_OMP_MAPPING ( L_VIRT_L0_OMP ) INTEGER, INTENT(IN) :: PHYS_L0_OMP ( L_PHYS_L0_OMP ) INTEGER, INTENT(IN) :: PERM_L0_OMP ( L_PHYS_L0_OMP ) INTEGER, INTENT(IN) :: PTR_LEAFS_L0_OMP ( L_PHYS_L0_OMP + 1 ) INTEGER, INTENT(IN) :: N INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER, INTENT(IN) :: NE(KEEP(28)) INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: FRERE(KEEP(28)) INTEGER, INTENT(IN) :: FILS(N) INTEGER, INTENT(IN) :: DAD(KEEP(28)), ND(KEEP(28)) INTEGER, INTENT(IN) :: MYID, PROCNODE(KEEP(28)) INTEGER, INTENT(IN) :: NBSTATS_I4, NBSTATS_I8, NBTHREADS INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(OUT) :: TNSTK(KEEP(28)) INTEGER, INTENT(OUT) :: I4_L0 (NBSTATS_I4, NBTHREADS) INTEGER(8), INTENT(OUT):: I8_L0 (NBSTATS_I8, NBTHREADS) INTEGER(8), INTENT(OUT):: ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS, & SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB_UD INTEGER, INTENT(OUT) :: MAXFR, NBNODES_BLR INTEGER(8), INTENT(OUT):: MAX_FRONT_SURFACE_LOCAL, & MAX_SIZE_FACTOR DOUBLE PRECISION, INTENT(OUT) :: OPS_SBTR_LOC, OPSA_LOC INTEGER, ALLOCATABLE, DIMENSION(:) :: LSTKI INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR_if_LRCB, & LSTKRLR_CB_UD, & LSTKRLR_CB_WC DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: OPSA_LOC_L0_OMP INTEGER :: ITH INTEGER :: NSTEPS INTEGER :: allocok INTEGER(8):: ISTKR, ISTKR_if_LRCB, ISTKRLR_CB_UD, & ISTKRLR_CB_WC INTEGER :: ISTKI, ISTKI_OOC, ITOP NSTEPS = KEEP(28) ALLOCATE( LSTKR(NSTEPS), LSTKI(NSTEPS) , & LSTKR_if_LRCB(NSTEPS), LSTKRLR_CB_UD(NSTEPS), & LSTKRLR_CB_WC(NSTEPS), & OPSA_LOC_L0_OMP(NBTHREADS), & & stat=allocok) IF ( allocok .GT. 0 ) THEN IFLAG =-7 IERROR = 4*NSTEPS+NBTHREADS RETURN ENDIF TNSTK = NE OPSA_LOC_L0_OMP(1:NBTHREADS) = 0.0D0 OPS_SBTR_LOC = 0.0D0 OPSA_LOC = 0.0D0 I4_L0(1:NBSTATS_I4, 1:NBTHREADS) = 0 I8_L0(1:NBSTATS_I8, 1:NBTHREADS) = 0_8 NBNODES_BLR = 0 SIZECB_UNDER_L0 = 0_8 SIZECB_UNDER_L0_IF_LRCB_UD = 0_8 MAXFR = 0 MAX_FRONT_SURFACE_LOCAL = 0_8 MAX_SIZE_FACTOR = 0_8 ENTRIES_IN_FACTORS_LOC = 0_8 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 DO ITH = 1, NBTHREADS ISTKI = 0 ISTKI_OOC = 0 ITOP = 0 ISTKR = 0_8 ISTKR_if_LRCB = 0_8 ISTKRLR_CB_UD = 0_8 ISTKRLR_CB_WC = 0_8 ISTKR = 0_8 CALL ZMUMPS_ANA_DISTM_UNDERL0_1THR ( ITH, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP , VIRT_L0_OMP , VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP , PHYS_L0_OMP , PERM_L0_OMP, & PTR_LEAFS_L0_OMP, KEEP, N, NE, NSTEPS, & STEP, FRERE, FILS, DAD, ND, MYID, PROCNODE, & ISTKR, ISTKI, ISTKI_OOC, ISTKR_if_LRCB, ISTKRLR_CB_UD, & ISTKRLR_CB_WC, ITOP, & LSTKI, LSTKR, LSTKR_if_LRCB, LSTKRLR_CB_UD, LSTKRLR_CB_WC, & I4_L0(1,ITH), I4_L0(2,ITH), I4_L0(3,ITH), I4_L0(4,ITH), & I8_L0(1,ITH), I8_L0(2,ITH), I8_L0(3,ITH), I8_L0(4,ITH), & I8_L0(5,ITH), I8_L0(6,ITH), I8_L0(7,ITH), I8_L0(8,ITH), & I8_L0(9,ITH), I8_L0(10,ITH), I8_L0(11,ITH), I8_L0(12,ITH), & I8_L0(13,ITH), I8_L0(14,ITH), I8_L0(15,ITH), I8_L0(16,ITH), & I8_L0(17,ITH), I8_L0(18,ITH), I8_L0(19,ITH), I8_L0(20,ITH), & I8_L0(21,ITH), I8_L0(22,ITH), & NBNODES_BLR, TNSTK, MAXFR, & MAX_FRONT_SURFACE_LOCAL, MAX_SIZE_FACTOR, & ENTRIES_IN_FACTORS_LOC, ENTRIES_IN_FACTORS_LOC_MASTERS, & OPS_SBTR_LOC, OPSA_LOC_L0_OMP(ITH), IFLAG, IERROR ) OPSA_LOC = OPSA_LOC + OPSA_LOC_L0_OMP(ITH) I8_L0(23,ITH) = ISTKR SIZECB_UNDER_L0 = SIZECB_UNDER_L0 + ISTKR I8_L0(24,ITH) = ISTKR_if_LRCB + ISTKRLR_CB_UD SIZECB_UNDER_L0_IF_LRCB_UD = SIZECB_UNDER_L0_IF_LRCB_UD + & ISTKR_if_LRCB + ISTKRLR_CB_UD ENDDO DEALLOCATE( LSTKR, LSTKI , & LSTKR_if_LRCB, LSTKRLR_CB_UD, & LSTKRLR_CB_WC, & OPSA_LOC_L0_OMP) RETURN END SUBROUTINE ZMUMPS_ANA_DISTM_UNDERL0OMP SUBROUTINE ZMUMPS_ANA_DISTM_UNDERL0_1THR ( ITHREAD, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP , VIRT_L0_OMP , VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP , PHYS_L0_OMP , PERM_L0_OMP, & PTR_LEAFS_L0_OMP, KEEP, N, NE, NSTEPS, STEP, FRERE, FILS, DAD, & ND, MYID, PROCNODE, ISTKR, ISTKI, ISTKI_OOC, ISTKR_if_LRCB, & ISTKRLR_CB_UD, ISTKRLR_CB_WC, ITOP, & LSTKI, LSTKR, LSTKR_if_LRCB, LSTKRLR_CB_UD, LSTKRLR_CB_WC, & NIRADU, NIRNEC, NIRADU_OOC, NIRNEC_OOC, NRLADU, NRLNEC, & NRLNEC_ACTIVE, NRLADU_if_LR_LU, NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, NRLNECOOC_if_LR_LUCB, NRLNEC_if_LR_CB, & NRLADULR_UD, NRLADULR_WC, NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC, & PEAK_LRLU_UD, PEAK_OOC_LRLU_UD, PEAK_OOC_LRLU_WC, & PEAK_LRLUCB_UD, PEAK_LRLUCB_WC, PEAK_OOC_LRLUCB_UD, & PEAK_OOC_LRLUCB_WC, PEAK_LRCB_UD, PEAK_OOC_LRCB_UD, & NBNODES_BLR, TNSTK, MAXFR, & MAX_FRONT_SURFACE_LOCAL, MAX_SIZE_FACTOR, & ENTRIES_IN_FACTORS_LOC, ENTRIES_IN_FACTORS_LOC_MASTERS, & OPS_SBTR_LOC, OPSA_LOC, IFLAG, IERROR ) USE ZMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE IMPLICIT NONE INTEGER, INTENT(IN) :: ITHREAD, LPOOL_B_L0_OMP, & L_VIRT_L0_OMP, L_PHYS_L0_OMP INTEGER, INTENT(IN) :: IPOOL_B_L0_OMP ( LPOOL_B_L0_OMP ) INTEGER, INTENT(IN) :: VIRT_L0_OMP ( L_VIRT_L0_OMP ) INTEGER, INTENT(IN) :: VIRT_L0_OMP_MAPPING ( L_VIRT_L0_OMP ) INTEGER, INTENT(IN) :: PHYS_L0_OMP ( L_PHYS_L0_OMP ) INTEGER, INTENT(IN) :: PERM_L0_OMP ( L_PHYS_L0_OMP ) INTEGER, INTENT(IN) :: PTR_LEAFS_L0_OMP ( L_PHYS_L0_OMP + 1 ) INTEGER, INTENT(IN) :: KEEP(500), N, NSTEPS INTEGER, INTENT(IN) :: NE(NSTEPS) INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: FRERE(NSTEPS) INTEGER, INTENT(IN) :: FILS(N) INTEGER, INTENT(IN) :: DAD(NSTEPS), ND(NSTEPS) INTEGER, INTENT(IN) :: MYID, PROCNODE(NSTEPS) DOUBLE PRECISION, INTENT(INOUT) :: OPS_SBTR_LOC DOUBLE PRECISION, INTENT(OUT) :: OPSA_LOC INTEGER, INTENT(INOUT) :: NBNODES_BLR INTEGER, INTENT(INOUT) :: TNSTK(NSTEPS) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: MAXFR INTEGER(8), INTENT(INOUT):: MAX_FRONT_SURFACE_LOCAL, & MAX_SIZE_FACTOR INTEGER(8), INTENT(INOUT):: ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS INTEGER(8), INTENT(INOUT) :: & ISTKR, ISTKR_if_LRCB, & ISTKRLR_CB_UD, ISTKRLR_CB_WC INTEGER, INTENT(INOUT) :: ISTKI, ISTKI_OOC, ITOP INTEGER, INTENT(INOUT) :: LSTKI(NSTEPS) INTEGER(8), INTENT(INOUT) :: LSTKR(NSTEPS), & LSTKR_if_LRCB(NSTEPS), & LSTKRLR_CB_UD(NSTEPS), & LSTKRLR_CB_WC(NSTEPS) INTEGER, INTENT(OUT) :: NIRADU, NIRNEC, NIRADU_OOC, NIRNEC_OOC INTEGER(8), INTENT(OUT):: NRLADU, NRLNEC, NRLNEC_ACTIVE, & NRLADU_if_LR_LU, NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, NRLNEC_if_LR_CB, & NRLADULR_UD, NRLADULR_WC, NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC, & PEAK_LRLU_UD, PEAK_OOC_LRLU_UD, PEAK_OOC_LRLU_WC, & PEAK_LRLUCB_UD, PEAK_LRLUCB_WC, PEAK_OOC_LRLUCB_UD, & PEAK_OOC_LRLUCB_WC, PEAK_LRCB_UD, PEAK_OOC_LRCB_UD LOGICAL :: INSSARBR INTEGER :: VIRTUAL_TASK, PHYSICAL_TASK INTEGER :: INODE, IFATH, I INTEGER :: SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC INTEGER :: EXTRA_PERM_INFO_OOC LOGICAL :: PACKED_CB INTEGER(8) :: NRLADU_ROOT_3 INTEGER :: FLAG_L0OMP PARAMETER (FLAG_L0OMP=-2014) INCLUDE 'mumps_headers.h' IF (KEEP(50).eq.2) THEN EXTRA_PERM_INFO_OOC = 1 ELSE IF (KEEP(50).eq.0) THEN EXTRA_PERM_INFO_OOC = 2 ELSE EXTRA_PERM_INFO_OOC = 0 ENDIF PACKED_CB=( KEEP(215).EQ.0 .AND. KEEP(50).NE.0 ) NRLADU_ROOT_3 = 0_8 #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 DO VIRTUAL_TASK = 1, L_VIRT_L0_OMP - 1 IF (VIRT_L0_OMP_MAPPING(VIRTUAL_TASK) .EQ. ITHREAD) THEN DO PHYSICAL_TASK= & VIRT_L0_OMP ( VIRTUAL_TASK ), & VIRT_L0_OMP ( VIRTUAL_TASK + 1 ) - 1 DO I = PTR_LEAFS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK ) ), & PTR_LEAFS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK )+1 ) +1, & - 1 INODE = IPOOL_B_L0_OMP(I) IF (INODE .LE. 0) THEN CYCLE ENDIF 10 CONTINUE IFATH = DAD(STEP(INODE)) CALL ZMUMPS_PROCESS_NODE_UNDERL0 () IF (IFATH .NE. 0) THEN TNSTK( STEP(IFATH) ) = TNSTK( STEP(IFATH) ) - 1 ENDIF IF ( PHYS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK ) ) & .EQ. INODE ) THEN TNSTK(STEP(INODE)) = FLAG_L0OMP ELSE IF ( TNSTK( STEP(IFATH) ) .EQ. 0 ) THEN INODE = IFATH GOTO 10 ENDIF ENDDO ENDDO ENDIF ENDDO RETURN CONTAINS SUBROUTINE ZMUMPS_PROCESS_NODE_UNDERL0 IMPLICIT NONE INTEGER :: LRSTATUS, IDUMMY LOGICAL :: COMPRESS_PANEL, COMPRESS_CB INTEGER :: STKI INTEGER(8) :: LSTK INTEGER :: K, NFR, NFRF, NELIM, NELIMF, NCB, NSTK, & LEVEL, LEVELF, IN, & MAXITEMPCB, PANEL_SIZE, SIZECBI INTEGER(8):: NFR8, NCB8, & K464_8, K465_8, & CURRENT_ACTIVE_MEM, & ENTRIES_NODE_LOWER_PART, ENTRIES_NODE_UPPER_PART, & NRLADU_CURRENT, NRLADU_CURRENT_MISSING INTEGER(8) :: SIZEFRNOCBLU INTEGER :: IDUMMY_ARRAY(1) INTEGER(8):: SIZECB, SIZECBINFR INTEGER(8):: SIZECB_if_LRCB INTEGER(8):: SIZECBLR_UD, SIZECBLR_WC LOGICAL :: MASTER, MASTERF, STACKCB DOUBLE PRECISION :: OPS_NODE INTRINSIC int INTEGER ZMUMPS_OOC_GET_PANEL_SIZE EXTERNAL ZMUMPS_OOC_GET_PANEL_SIZE INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR EXTERNAL MUMPS_MAX_SURFCB_NBROWS EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, & MUMPS_IN_OR_ROOT_SSARBR MAXITEMPCB = 0 STACKCB = .TRUE. NFR = ND(STEP(INODE))+KEEP(253) NFR8 = int(NFR,8) NSTK = NE(STEP(INODE)) NELIM = 0 IN = INODE 100 NELIM = NELIM + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IFATH = DAD(STEP(INODE)) MASTER = MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID LEVEL = MUMPS_TYPENODE(PROCNODE(STEP(INODE)),KEEP(199)) INSSARBR = MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) IDUMMY_ARRAY(1) = 0 NCB = NFR-NELIM NCB8 = int(NCB,8) SIZECBINFR = NCB8*NCB8 IF (KEEP(50).EQ.0) THEN SIZECB = SIZECBINFR ELSE IF ( PACKED_CB ) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = SIZECBINFR ENDIF ENDIF IDUMMY = -99999 CALL IS_FRONT_BLR_CANDIDATE (INODE, LEVEL, NFR, NELIM, & KEEP(494), 1, KEEP(490), & KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & KEEP(123), LRSTATUS, IDUMMY) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) IF (COMPRESS_PANEL.OR.COMPRESS_CB) NBNODES_BLR = NBNODES_BLR+1 IF (COMPRESS_PANEL) THEN K464_8 = int(KEEP(464),8) ELSE K464_8 = 1000_8 ENDIF IF (COMPRESS_CB) THEN K465_8 = int(KEEP(465),8) SIZECB_if_LRCB = 0_8 SIZECBLR_UD = SIZECB*K465_8/1000_8 SIZECBLR_WC = SIZECB ELSE K465_8 = 1000_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = SIZECB ENDIF SIZECBI = 2* NCB + SIZEHEADER IF(KEEP(86).EQ.1)THEN IF(MASTER.AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)), KEEP(199))) & )THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8) ENDIF ENDIF NIRADU = NIRADU + 2*NFR + SIZEHEADER NIRADU_OOC = NIRADU_OOC + 2*NFR + SIZEHEADER_OOC PANEL_SIZE = ZMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NFR, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) IF (KEEP(50).EQ.0) THEN IF (KEEP(251) .EQ. 2) THEN NRLADU_CURRENT = int(NELIM,8) * int(NFR,8) SIZEFRNOCBLU = int(NFR-NELIM,8)*int(NELIM) ELSE NRLADU_CURRENT = int(NELIM,8)*int(2*NFR-NELIM,8) SIZEFRNOCBLU = 0_8 ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR = max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ELSE IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 ) THEN CALL MUMPS_LDLTPANEL_STORAGE( NELIM, KEEP, & IDUMMY_ARRAY(1), NRLADU_CURRENT ) SIZEFRNOCBLU = int(NELIM,8)*int(NELIM,8) - & NRLADU_CURRENT NRLADU_CURRENT = NRLADU_CURRENT + & int(NELIM,8) * int(NFR-NELIM,8) ELSE SIZEFRNOCBLU = 0_8 NRLADU_CURRENT = int(NELIM,8)*int(NFR,8) ENDIF NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ENDIF IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_CURRENT_MISSING = 0_8 NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT ENDIF SIZECBI = 2* NCB + SIZEHEADER NIRNEC = max(NIRNEC, & NIRADU+ISTKI+SIZECBI+MAXITEMPCB) NIRNEC_OOC = max(NIRNEC_OOC, & NIRADU_OOC+ISTKI_OOC+SIZECBI+MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) CURRENT_ACTIVE_MEM = ISTKR+SIZECBINFR IF ( KEEP(50).NE.0 .AND. LEVEL.EQ.1 ) THEN SIZEFRNOCBLU = SIZEFRNOCBLU + int(NELIM,8)*int(NCB,8) ENDIF CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + SIZEFRNOCBLU NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = & max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) 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 NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT_MISSING) NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (NFR.GT.MAXFR) MAXFR = NFR IF (NSTK.GT.0) THEN DO 70 K=1,NSTK LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK IF (K==1 .AND. INSSARBR.AND.KEEP(234).NE.0 & .AND.KEEP(55).EQ.0) THEN ELSE CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTK ENDIF LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in ZMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF 70 CONTINUE ENDIF IF ( & ( (INODE.NE.KEEP(20)).OR.(KEEP(60).EQ.0) ) & .AND. & ( (INODE.NE.KEEP(38)).OR.(KEEP(60).LE.1) ) & ) & THEN ENTRIES_NODE_LOWER_PART = int(NFR-NELIM,8) * int(NELIM,8) IF ( KEEP(50).EQ.0 ) THEN ENTRIES_NODE_UPPER_PART = int(NFR,8) * int(NELIM,8) ELSE ENTRIES_NODE_UPPER_PART = & (int(NELIM,8)*int(NELIM+1,8))/2_8 ENDIF IF (KEEP(50).EQ.2 .AND. LEVEL.EQ.3) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM, 0, & 1,OPS_NODE) ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) ENDIF ELSE OPS_NODE = 0.0D0 ENTRIES_NODE_UPPER_PART = 0_8 ENTRIES_NODE_LOWER_PART = 0_8 ENDIF ENTRIES_IN_FACTORS_LOC_MASTERS = & ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC_MASTERS OPSA_LOC = OPSA_LOC + dble(OPS_NODE) IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) .OR. NE(STEP(INODE))==0) THEN OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ENDIF IF (IFATH .EQ. 0) THEN RETURN 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 LEVELF = MUMPS_TYPENODE(PROCNODE(STEP(IFATH)),KEEP(199)) MASTERF= MUMPS_PROCNODE(PROCNODE(STEP(IFATH)), & KEEP(199)).EQ.MYID IF ( INSSARBR .AND. KEEP(234).NE.0) THEN NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+SIZECB+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) ENDIF PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (KEEP(50).NE.0.AND.LEVELF.NE.3 & .AND.PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF SIZECBI = 2+ XSIZE_IC IF (STACKCB) THEN IF (FRERE(STEP(INODE)).EQ.0) THEN write(*,*) ' ERROR 3 in ZMUMPS_ANA_DISTM' CALL MUMPS_ABORT() ENDIF ITOP = ITOP + 1 IF ( ITOP .GT. NSTEPS ) THEN WRITE(*,*) 'ERROR 4 in ZMUMPS_ANA_DISTM ' CALL MUMPS_ABORT() 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) NIRNEC = max(NIRNEC,NIRADU+ISTKI) NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR) LSTKR_if_LRCB(ITOP) = SIZECB_if_LRCB ISTKR_if_LRCB = ISTKR_if_LRCB + LSTKR_if_LRCB(ITOP) LSTKRLR_CB_UD(ITOP) = SIZECBLR_UD ISTKRLR_CB_UD = ISTKRLR_CB_UD + LSTKRLR_CB_UD(ITOP) LSTKRLR_CB_WC(ITOP) = SIZECBLR_WC ISTKRLR_CB_WC = ISTKRLR_CB_WC + LSTKRLR_CB_WC(ITOP) NRLNECLR_CB_UD = max(NRLNECLR_CB_UD, ISTKRLR_CB_UD) NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) ENDIF ENDIF END SUBROUTINE ZMUMPS_PROCESS_NODE_UNDERL0 END SUBROUTINE ZMUMPS_ANA_DISTM_UNDERL0_1THR SUBROUTINE ZMUMPS_PREP_ANA_DISTM_ABOVEL0 ( & N, SLAVEF, COMM, MYID, & STEP, DAD, ICNTL, LP, LPOK, INFO, & PHYS_L0_OMP, L_PHYS_L0_OMP, & IPOOL_A_L0_OMP, LPOOL_A_L0_OMP, & KEEP, TNSTK_afterL0, & FLAGGED_LEAVES & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, INTENT(IN) :: N, SLAVEF, COMM, MYID, ICNTL(60), & LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: L_PHYS_L0_OMP, LPOOL_A_L0_OMP INTEGER, INTENT(IN) :: PHYS_L0_OMP(max(1,L_PHYS_L0_OMP)), & IPOOL_A_L0_OMP(max(1,LPOOL_A_L0_OMP)) INTEGER, INTENT(IN) :: KEEP(500) INTEGER, INTENT(IN) :: STEP(N), DAD(KEEP(28)) INTEGER, INTENT(OUT) :: FLAGGED_LEAVES(KEEP(28)) INTEGER, INTENT(INOUT) :: TNSTK_afterL0(KEEP(28)), INFO(80) INTEGER :: ISLAVE, IERR, INODE, I, NSTEPS, allocok INTEGER :: SIZE_BUFREC, Itemp, SIZE_RECEIVED INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFREC INTEGER, ALLOCATABLE, DIMENSION(:) :: IREQ INTEGER :: MPI_STATUS(MPI_STATUS_SIZE) SIZE_BUFREC = 0 CALL MPI_ALLREDUCE(L_PHYS_L0_OMP, Itemp, 1, & MPI_INTEGER, MPI_MAX, COMM, IERR) SIZE_BUFREC = Itemp CALL MPI_ALLREDUCE(LPOOL_A_L0_OMP, Itemp, 1, & MPI_INTEGER, MPI_MAX, COMM, IERR) SIZE_BUFREC= max(SIZE_BUFREC, Itemp) ALLOCATE(IREQ(SLAVEF), BUFREC(SIZE_BUFREC), stat=allocok) IF (allocok.GT.0) THEN IF ( LPOK ) THEN WRITE(LP, '(A)') & ' Allocation failed in ZMUMPS_PREP_ANA_DISTM_ABOVEL0' END IF INFO(1)= -7 INFO(2)= SLAVEF+SIZE_BUFREC ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) RETURN NSTEPS = KEEP(28) DO I=1, NSTEPS FLAGGED_LEAVES(I) = 0 ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_ISEND( IPOOL_A_L0_OMP, LPOOL_A_L0_OMP, & MPI_INTEGER, ISLAVE - 1, F_IPOOLAFTER, COMM, & IREQ( ISLAVE ), IERR ) ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_RECV( BUFREC(1), SIZE_BUFREC, & MPI_INTEGER, ISLAVE-1, & F_IPOOLAFTER, COMM, MPI_STATUS, IERR ) CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER, & SIZE_RECEIVED, IERR) DO I=1,SIZE_RECEIVED INODE = BUFREC(I) FLAGGED_LEAVES(STEP(INODE))=INODE ENDDO ENDDO IF (LPOOL_A_L0_OMP.GT.0) THEN DO I=1, LPOOL_A_L0_OMP INODE = IPOOL_A_L0_OMP(I) FLAGGED_LEAVES(STEP(INODE))=INODE ENDDO ENDIF DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_WAIT( IREQ( ISLAVE ), MPI_STATUS, IERR ) ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_ISEND(PHYS_L0_OMP, L_PHYS_L0_OMP, & MPI_INTEGER, ISLAVE - 1, F_PHYS_L0, COMM, & IREQ( ISLAVE ), IERR ) ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_RECV( BUFREC(1), SIZE_BUFREC, & MPI_INTEGER, ISLAVE-1, & F_PHYS_L0, COMM, MPI_STATUS, IERR ) CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER, & SIZE_RECEIVED, IERR) DO I=1,SIZE_RECEIVED INODE = BUFREC(I) IF (DAD(STEP(INODE)).NE.0) THEN TNSTK_afterL0(STEP(DAD(STEP(INODE)))) & = TNSTK_afterL0(STEP(DAD(STEP(INODE)))) - 1 ENDIF ENDDO ENDDO DO ISLAVE=1, SLAVEF IF (MYID.EQ.ISLAVE-1) CYCLE CALL MPI_WAIT( IREQ( ISLAVE ), MPI_STATUS, IERR ) ENDDO IF (allocated(IREQ)) DEALLOCATE(IREQ) IF (allocated(BUFREC)) DEALLOCATE(BUFREC) RETURN END SUBROUTINE ZMUMPS_PREP_ANA_DISTM_ABOVEL0 MUMPS_5.8.1/src/smumps_gpu.c0000664000175000017500000000117315042446422015575 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include #include #include #include "smumps_gpu.h" void MUMPS_CALL smumps_gpu_return() { /* GPU feature will be available in the future */ } MUMPS_5.8.1/src/slr_type.F0000664000175000017500000000464415042446437015216 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_LR_TYPE IMPLICIT NONE TYPE LRB_TYPE REAL,POINTER,DIMENSION(:,:) :: Q => null() REAL,POINTER,DIMENSION(:,:) :: R => null() INTEGER :: K,M,N LOGICAL :: ISLR END TYPE LRB_TYPE CONTAINS SUBROUTINE DEALLOC_LRB(LRB_OUT, KEEP8, K34 & ) TYPE(LRB_TYPE), INTENT(INOUT) :: LRB_OUT INTEGER(8) :: KEEP8(150) INTEGER :: K34 INTEGER :: MEM, IDUMMY, JDUMMY IF (LRB_OUT%M.EQ.0) RETURN IF (LRB_OUT%N.EQ.0) RETURN MEM = 0 IF (LRB_OUT%ISLR) THEN IF (associated(LRB_OUT%Q)) THEN MEM = MEM + size(LRB_OUT%Q) DEALLOCATE (LRB_OUT%Q) NULLIFY(LRB_OUT%Q) ENDIF IF (associated(LRB_OUT%R)) THEN MEM = MEM + size(LRB_OUT%R) DEALLOCATE (LRB_OUT%R) NULLIFY(LRB_OUT%R) ENDIF ELSE IF (associated(LRB_OUT%Q)) THEN MEM = MEM + size(LRB_OUT%Q) DEALLOCATE (LRB_OUT%Q) NULLIFY(LRB_OUT%Q) ENDIF ENDIF CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-int(MEM,8), & .TRUE., KEEP8, & IDUMMY, JDUMMY, & .TRUE., .TRUE.) END SUBROUTINE DEALLOC_LRB SUBROUTINE DEALLOC_BLR_PANEL(BLR_PANEL, IEND, KEEP8, K34, IBEG_IN) INTEGER, INTENT(IN) :: IEND TYPE(LRB_TYPE), INTENT(INOUT) :: BLR_PANEL(:) INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: K34 INTEGER, INTENT(IN), OPTIONAL :: IBEG_IN INTEGER :: I, IBEG IF (present(IBEG_IN)) THEN IBEG = IBEG_IN ELSE IBEG = 1 ENDIF IF (IEND.GE.IBEG) THEN IF (BLR_PANEL(1)%M.NE.0) THEN DO I=IBEG, IEND CALL DEALLOC_LRB(BLR_PANEL(I), KEEP8, K34) ENDDO ENDIF ENDIF END SUBROUTINE DEALLOC_BLR_PANEL END MODULE SMUMPS_LR_TYPE MUMPS_5.8.1/src/dana_reordertree.F0000664000175000017500000012235715042446437016664 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_REORDER_TREE(N,FRERE, STEP, FILS, & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, & NSTEPS,PERM,SYM,INFO,LP,K215,K234,K55,K199, & PROCNODE,SLAVEF, PEAK,SBTR_WHICH_M & ) IMPLICIT NONE INTEGER N,PERM,SYM, NSTEPS, LNA, LP,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER K215,K234,K55,K199 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) INTEGER :: SBTR_WHICH_M DOUBLE PRECISION PEAK DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: COST_TRAV INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH INTEGER IFATH,IN,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 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 EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR DOUBLE PRECISION COST_NODE INCLUDE 'mumps_headers.h' TOTAL_MEM_SIZE=0_8 ROOT_OF_CUR_SBTR=0 IF((PERM.EQ.0).OR.(PERM.EQ.1).OR. & (PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4).OR. & (PERM.EQ.5).OR.(PERM.EQ.6))THEN LOCAL_PERM=0 ENDIF SBTR_M=.FALSE. MEM_SIZE=0_8 FACT_SIZE=0_8 IF ((PERM.LT.0 .OR. PERM.GT.7)) THEN WRITE(*,*) "Internal Error in DMUMPS_REORDER_TREE",PERM CALL MUMPS_ABORT() END IF NBLEAF = NA(1) NBROOT = NA(2) IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) RETURN IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ENDIF IF(PERM.NE.7)THEN ALLOCATE(M(NSTEPS),stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error &in DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ALLOCATE( IPOOL(NBLEAF), fact(NSTEPS),TNSTK(NSTEPS), & stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF II=0 DO I=1,NSTEPS TNSTK(I) = NE(I) IF(NE(I).GE.II) II=NE(I) ENDDO SIZE_TAB=max(II,NBROOT) ALLOCATE(SON(II), TEMP(II), & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), & RESULT(SIZE_TAB),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SIZE_TAB RETURN ENDIF IF(PERM.EQ.7) THEN GOTO 001 ENDIF IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN ALLOCATE(COST_TRAV(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error & in DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF COST_TRAV=0.0D0 COST_NODE=0.0d0 ENDIF IF(NBROOT.EQ.NBLEAF)THEN IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN WRITE(*,*)'Internal Error in reordertree:' WRITE(*,*)' problem with perm parameter in reordertree' CALL MUMPS_ABORT() ENDIF DO I=1,NBROOT TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) IPOOL(I)=NA(I+2+NBLEAF) M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) ENDDO CALL DMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) GOTO 789 ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN ALLOCATE(DEPTH(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DEPTH=0 NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) 499 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 4602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 4602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) SON(I)=IN IN=FRERE(STEP(IN)) ENDDO DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN LEAF=LEAF-1 ELSE fin=fin-1 GOTO 499 ENDIF fin=fin-1 IF(fin.EQ.0) GOTO 489 GOTO 499 489 CONTINUE ENDIF DO I=1,NSTEPS M(I)=0_8 IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN M_TOTAL(I)=0_8 ENDIF ENDIF ENDDO DO I=1,NSTEPS fact(I)=0_8 ENDDO IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 91 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 96 CONTINUE NFR = int(ND(STEP(INODE)),8) NELIM4 = 0 IN = INODE 101 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 101 NELIM=int(NELIM4,8) IF(NE(STEP(INODE)).EQ.0) THEN M(STEP(INODE))=NFR*NFR IF (SBTR_M.OR.(PERM.EQ.2)) THEN M_TOTAL(STEP(INODE))=NFR*NFR ENDIF ENDIF IF((PERM.EQ.4).OR.(PERM.EQ.3))THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN DEPTH(STEP(INODE))=0 ENDIF ENDIF IF ( SYM .eq. 0 ) THEN fact(STEP(INODE))=fact(STEP(INODE))+ & (2_8*NFR*NELIM)-(NELIM*NELIM) ELSE fact(STEP(INODE))=fact(STEP(INODE))+NFR*NELIM ENDIF IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 113 IN = FRERE(IN) IF (IN.GT.0) GO TO 113 IFATH = -IN ENDIF IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 116 GOTO 91 ELSE fact(STEP(IFATH))=fact(STEP(IFATH))+fact(STEP(INODE)) IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEPTH(STEP(IFATH))=max(DEPTH(STEP(INODE)), & DEPTH(STEP(IFATH))) ENDIF ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH IN=INODE dernier=IN I=1 5700 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN I=I+1 GOTO 5700 ENDIF NCB=int(ND(STEP(INODE))-I,8) IN=-IN IF(PERM.NE.7)THEN DO I=1,NE(STEP(INODE)) SON(I)=IN TEMP(I)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) ENDDO ELSE DO I=NE(STEP(INODE)),1,-1 SON(I)=IN TEMP(I)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) ENDDO ENDIF NFR = int(ND(STEP(INODE)),8) DO II=1,NE(STEP(INODE)) TAB1(II)=0_8 TAB2(II)=0_8 cour=SON(II) NELIM4=1 151 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 151 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0)) THEN SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) & *(int(ND(STEP(SON(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) & *(int(ND(STEP(SON(II))),8)- & NELIM+1_8)/2_8 ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.5))THEN IF (K234 .NE. 0 .AND. K55.EQ.0 ) THEN TMP8=NFR TMP8=TMP8*TMP8 TAB1(II)=max(TMP8, M(STEP(SON(II)))) - SIZECB TAB2(II)=SIZECB ELSE TAB1(II)=M(STEP(SON(II)))- SIZECB TAB2(II)=SIZECB ENDIF ENDIF IF((PERM.EQ.1).OR.(PERM.EQ.6)) THEN TAB1(II)=M(STEP(SON(II)))-SIZECB TAB1(II)=TAB1(II)-fact(STEP(SON(II))) TAB2(II)=SIZECB+fact(STEP(SON(II))) ENDIF IF(PERM.EQ.2)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M_TOTAL(STEP(SON(II)))-SIZECB & -fact(STEP(SON(II))) TAB2(II)=SIZECB ELSE TAB1(II)=M(STEP(SON(II)))-SIZECB TAB2(II)=SIZECB ENDIF ENDIF IF(PERM.EQ.3)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M(STEP(SON(II)))-SIZECB TAB2(II)=SIZECB ELSE TAB1(II)=int(DEPTH(STEP(SON(II))),8) TAB2(II)=M(STEP(SON(II))) ENDIF ENDIF IF(PERM.EQ.4)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M(STEP(SON(II)))- & SIZECB-fact(STEP(SON(II))) TAB2(II)=SIZECB ELSE TAB1(II)=int(DEPTH(STEP(SON(II))),8) TAB2(II)=M(STEP(SON(II))) ENDIF ENDIF ENDDO CALL DMUMPS_FUSION_SORT(SON,NE(STEP(INODE)),TAB1,TAB2, & LOCAL_PERM & ,RESULT,T1,T2) IF(PERM.EQ.0) THEN DO II=1,NE(STEP(INODE)) cour=TEMP(II) NELIM4=1 153 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 153 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 ENDIF TAB1(II)=SIZECB ENDDO CALL DMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, & RESULT,T1,T2) ENDIF IF(PERM.EQ.1) THEN DO II=1,NE(STEP(INODE)) cour=TEMP(II) NELIM4=1 187 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 187 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 ENDIF TAB1(II)=SIZECB+fact(STEP(TEMP(II))) ENDDO CALL DMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, & RESULT,T1,T2) ENDIF 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 TMP_SUM=0_8 IF(II.EQ.1) TAB=>SON IF(II.EQ.2) TAB=>TEMP DO I=1,NE(STEP(INODE)) cour=TAB(I) NELIM4=1 149 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 149 ENDIF NELIM=int(NELIM4, 8) NFR=int(ND(STEP(TAB(I))),8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF MEM_SIZE=max(MEM_SIZE,(M(STEP(TAB(I)))+SUM+FACT_SIZE)) IF (SBTR_M.OR.(PERM.EQ.2)) THEN MEM_SIZE_T=max(MEM_SIZE_T,(M_TOTAL(STEP(TAB(I)))+ & SUM+ & FACT_SIZE_T)) FACT_SIZE_T=FACT_SIZE_T+fact(STEP(TAB(I))) ENDIF TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & (M(STEP(TAB(I)))+SUM+FACT_SIZE)) TMP_SUM=TMP_SUM+fact(STEP(TAB(I))) SUM=SUM+SIZECB SIZECB_LASTSON = SIZECB IF((PERM.EQ.1).OR.(PERM.EQ.4))THEN FACT_SIZE=FACT_SIZE+fact(STEP(TAB(I))) ENDIF ENDDO IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=NCB*NCB ELSE SIZECB=(NCB*(NCB+1_8))/2_8 ENDIF IF (K234.NE.0 .AND. K55.EQ.0) THEN TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8) ) & + SUM-SIZECB_LASTSON+TMP_SUM ) & ) ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8) ) & + SUM + TMP_SUM ) & ) ELSE TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8)) & + max(SUM,SIZECB) + TMP_SUM ) & ) ENDIF IF(II.EQ.1)THEN TMP_TOTAL_MEM_SIZE=TOTAL_MEM_SIZE ENDIF IF(II.EQ.1)THEN IF (K234.NE.0 .AND. K55.EQ.0) THEN M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+SUM-SIZECB_LASTSON+ & FACT_SIZE)) ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+SUM+FACT_SIZE)) ELSE M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN M_TOTAL(STEP(IFATH))=max(MEM_SIZE_T, & ((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+ & FACT_SIZE_T)) ENDIF ENDIF IF((II.EQ.2).AND.(PERM.EQ.1).OR.(PERM.EQ.0).OR. & (PERM.EQ.5).OR.(PERM.EQ.6).OR. & (.NOT.SBTR_M.OR.(SBTR_WHICH_M.NE.1)))THEN MEM_SEC_PERM=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) ENDIF IF((PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4))THEN MEM_SEC_PERM=huge(MEM_SEC_PERM) ENDIF ENDDO IF(MEM_SEC_PERM.EQ.M(STEP(IFATH))) THEN TAB=>TEMP ELSE IF (MEM_SEC_PERM.LT.M(STEP(IFATH))) THEN WRITE(*,*)'Internal error 1 in DMUMPS_REORDER_TREE', & MEM_SEC_PERM, M(STEP(IFATH)) CALL MUMPS_ABORT() ELSE TOTAL_MEM_SIZE=TMP_TOTAL_MEM_SIZE TAB=>SON ENDIF DO I=NE(STEP(INODE)),1,-1 IF(I.EQ.NE(STEP(INODE))) THEN FILS(dernier)=-TAB(I) dernier=TAB(I) GOTO 222 ENDIF IF(I.EQ.1) THEN FRERE(STEP(dernier))=TAB(I) FRERE(STEP(TAB(I)))=-INODE GOTO 222 ENDIF IF(I.GT.1) THEN FRERE(STEP(dernier))=TAB(I) dernier=TAB(I) GOTO 222 ENDIF 222 CONTINUE ENDDO GOTO 96 ELSE GOTO 91 ENDIF 116 CONTINUE NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) IF (PERM.eq.1) THEN DO I=1,NBROOT TAB1(I)=M(STEP(NA(I+2+NBLEAF)))-fact(STEP(NA(I+2+NBLEAF))) TAB1(I)=-TAB1(I) ENDDO CALL DMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) ENDIF 001 CONTINUE fin=NBROOT LEAF=NA(1) 999 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 5602 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN GOTO 5602 ENDIF IN=-IN IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF(SLAVEF.NE.1)THEN IF (USE_DAD) THEN IFATH=DAD(INODE) ELSE IN = INODE 395 IN = FRERE(IN) IF (IN.GT.0) GO TO 395 IFATH = -IN ENDIF NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 IN = INODE 396 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 396 NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),K199))THEN COST_TRAV(STEP(INODE))=COST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE COST_TRAV(STEP(INODE))=dble(COST_NODE)+ & COST_TRAV(STEP(IFATH))+ & dble(SIZECB*18_8) ENDIF ELSE COST_TRAV(STEP(INODE))=dble(COST_NODE) ENDIF ENDIF ENDIF DO I=1,NE(STEP(INODE)) TEMP(I)=IN IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)),K199)))THEN NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 II = TEMP(I) 845 NELIM4 = NELIM4 + 1 II = FILS(II) IF (II .GT. 0 ) GOTO 845 NELIM=int(NELIM4,8) CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) TAB1(I)=int(dble(COST_NODE)+ & COST_TRAV(STEP(INODE)),8) TAB2(I)=0_8 ELSE SON(I)=IN ENDIF ELSE SON(I)=IN ENDIF IN=FRERE(STEP(IN)) ENDDO IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)),K199)))THEN CALL DMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2, & LOCAL_PERM & ,RESULT,T1,T2) TAB=>TEMP DO I=NE(STEP(INODE)),1,-1 IF(I.EQ.NE(STEP(INODE))) THEN FILS(dernier)=-TAB(I) dernier=TAB(I) GOTO 221 ENDIF IF(I.EQ.1) THEN FRERE(STEP(dernier))=TAB(I) FRERE(STEP(TAB(I)))=-INODE GOTO 221 ENDIF IF(I.GT.1) THEN FRERE(STEP(dernier))=TAB(I) dernier=TAB(I) GOTO 221 ENDIF 221 CONTINUE SON(NE(STEP(INODE))-I+1)=TAB(I) ENDDO ENDIF ENDIF DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN IF(PERM.NE.7)THEN NA(LEAF+2)=INODE ENDIF LEAF=LEAF-1 ELSE fin=fin-1 GOTO 999 ENDIF fin=fin-1 IF(fin.EQ.0) THEN GOTO 789 ENDIF GOTO 999 789 CONTINUE IF(PERM.EQ.7) GOTO 5483 NBROOT=NA(2) NBLEAF=NA(1) PEAK=0.0D0 FACT_SIZE=0_8 DO I=1,NBROOT PEAK=max(PEAK,dble(M(STEP(NA(2+NBLEAF+I))))) FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) ENDDO 5483 CONTINUE DEALLOCATE(IPOOL) DEALLOCATE(fact) DEALLOCATE(TNSTK) DEALLOCATE(SON) DEALLOCATE(TAB2) DEALLOCATE(TAB1) DEALLOCATE(T1) DEALLOCATE(T2) DEALLOCATE(RESULT) DEALLOCATE(TEMP) IF(PERM.NE.7)THEN DEALLOCATE(M) ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEALLOCATE(DEPTH) ENDIF IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN DEALLOCATE(COST_TRAV) ENDIF IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN DEALLOCATE(M_TOTAL) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_REORDER_TREE SUBROUTINE DMUMPS_BUILD_LOAD_MEM_INFO(N,FRERE, STEP, FILS, & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, & NSTEPS,PERM,SYM,INFO,LP,K47,K81,K76,K215,K234,K55,KEEP199, & PROCNODE,MEM_SUBTREE,SLAVEF, SIZE_MEM_SBTR, PEAK & ,SBTR_WHICH_M,SIZE_DEPTH_FIRST,SIZE_COST_TRAV, & DEPTH_FIRST_TRAV,DEPTH_FIRST_SEQ,COST_TRAV,MY_FIRST_LEAF, & MY_NB_LEAF,MY_ROOT_SBTR,SBTR_ID & ) IMPLICIT NONE INTEGER N,PERM,SYM, NSTEPS, LNA, LP, SIZE_MEM_SBTR,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER K47,K81,K76,K215,K234,K55,KEEP199 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) DOUBLE PRECISION, intent(out) :: MEM_SUBTREE(SIZE_MEM_SBTR,SLAVEF) INTEGER :: SBTR_WHICH_M INTEGER MY_FIRST_LEAF(SIZE_MEM_SBTR,SLAVEF), & MY_ROOT_SBTR(SIZE_MEM_SBTR,SLAVEF), & MY_NB_LEAF(SIZE_MEM_SBTR,SLAVEF) EXTERNAL MUMPS_ROOTSSARBR,MUMPS_PROCNODE LOGICAL MUMPS_ROOTSSARBR INTEGER MUMPS_PROCNODE DOUBLE PRECISION PEAK INTEGER SIZE_DEPTH_FIRST,DEPTH_FIRST_TRAV(SIZE_DEPTH_FIRST), & DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST) INTEGER SIZE_COST_TRAV INTEGER SBTR_ID(SIZE_DEPTH_FIRST),OOC_CUR_SBTR DOUBLE PRECISION COST_TRAV(SIZE_COST_TRAV) INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH INTEGER IFATH,IN,INODE,I,allocok 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,fin,RANK_TRAV INTEGER II INTEGER ROOT_OF_CUR_SBTR INTEGER(8), DIMENSION (:), ALLOCATABLE :: T1,T2 INTEGER, DIMENSION (:), ALLOCATABLE :: RESULT INTEGER(8) FACT_SIZE, & SIZECB LOGICAL SBTR_M INTEGER,DIMENSION(:),ALLOCATABLE :: INDICE INTEGER ID,FIRST_LEAF,SIZE_SBTR EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR DOUBLE PRECISION COST_NODE INTEGER CUR_DEPTH_FIRST_RANK INCLUDE 'mumps_headers.h' ROOT_OF_CUR_SBTR=0 ALLOCATE(INDICE( SLAVEF ), stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in &DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SLAVEF RETURN ENDIF IF (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)))) FACT_SIZE=0_8 IF ((PERM.GT.7).AND. & (.NOT.(K47 == 4 .OR. ((K47.GE.2).AND.(K81 .GE. 1))))) THEN WRITE(*,*) "Internal Error in DMUMPS_REORDER_TREE",PERM CALL MUMPS_ABORT() END IF NBLEAF = NA(1) NBROOT = NA(2) CUR_DEPTH_FIRST_RANK=1 IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) THEN DEALLOCATE(INDICE) RETURN ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ENDIF ALLOCATE( IPOOL(NBLEAF), M(NSTEPS), fact(NSTEPS), & TNSTK(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF II=0 DO I=1,NSTEPS TNSTK(I) = NE(I) IF(NE(I).GE.II) II=NE(I) ENDDO SIZE_TAB=max(II,NBROOT) ALLOCATE(SON(II), TEMP(II), & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), & RESULT(SIZE_TAB),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SIZE_TAB RETURN ENDIF IF(NBROOT.EQ.NBLEAF)THEN IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN WRITE(*,*)'Internal Error in reordertree:' WRITE(*,*)' problem with perm parameter in reordertree' CALL MUMPS_ABORT() ENDIF DO I=1,NBROOT TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) IPOOL(I)=NA(I+2+NBLEAF) M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) ENDDO CALL DMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) GOTO 789 ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN ALLOCATE(DEPTH(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DEPTH=0 NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) 499 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 4602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 4602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) SON(I)=IN IN=FRERE(STEP(IN)) ENDDO DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN LEAF=LEAF-1 ELSE fin=fin-1 GOTO 499 ENDIF fin=fin-1 IF(fin.EQ.0) GOTO 489 GOTO 499 489 CONTINUE ENDIF IF(K76.EQ.4.OR.(K76.EQ.6))THEN RANK_TRAV=NSTEPS DEPTH_FIRST_TRAV=0 DEPTH_FIRST_SEQ=0 ENDIF IF((K76.EQ.5).OR.(PERM.EQ.5).OR.(PERM.EQ.6))THEN COST_TRAV=0.0D0 COST_NODE=0.0d0 ENDIF DO I=1,NSTEPS M(I)=0_8 IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN M_TOTAL(I)=0_8 ENDIF ENDIF ENDDO DO I=1,NSTEPS fact(I)=0_8 ENDDO NBROOT = NA(2) NBLEAF = NA(1) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) FIRST_LEAF=-9999 SIZE_SBTR=0 999 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IF(SIZE_SBTR.NE.0)THEN IF(.NOT.MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1))THEN MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR FIRST_LEAF=-9999 SIZE_SBTR=0 ENDIF ENDIF ENDIF ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN ROOT_OF_CUR_SBTR=INODE ENDIF IF (K76.EQ.4)THEN IF(SLAVEF.NE.1)THEN WRITE(*,*)'INODE=',INODE,'RANK',RANK_TRAV IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN DEPTH_FIRST_TRAV(STEP(INODE))=DEPTH_FIRST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE DEPTH_FIRST_TRAV(STEP(INODE))=RANK_TRAV ENDIF RANK_TRAV=RANK_TRAV-1 ENDIF ENDIF IF (K76.EQ.5)THEN IF(SLAVEF.NE.1)THEN IF (USE_DAD) THEN IFATH=DAD(INODE) ELSE IN = INODE 395 IN = FRERE(IN) IF (IN.GT.0) GO TO 395 IFATH = -IN ENDIF NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 IN = INODE 396 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 396 NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN COST_TRAV(STEP(INODE))=COST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE COST_TRAV(STEP(INODE))=dble(COST_NODE)+ & COST_TRAV(STEP(IFATH))+ & dble(SIZECB*18_8) ENDIF ELSE COST_TRAV(STEP(INODE))=dble(COST_NODE) ENDIF IF(K76.EQ.5)THEN WRITE(*,*)'INODE=',INODE,'COST=',COST_TRAV(STEP(INODE)) ENDIF ENDIF ENDIF IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1).AND. & MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF (NE(STEP(INODE)).NE.0) THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M_TOTAL(STEP(INODE))) ELSE MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M(STEP(INODE))) ENDIF MY_ROOT_SBTR(INDICE(ID+1),ID+1)=INODE INDICE(ID+1)=INDICE(ID+1)+1 ENDIF ENDIF IF((SLAVEF.EQ.1).AND.FRERE(STEP(INODE)).EQ.0)THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M_TOTAL(STEP(INODE))) ELSE MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M(STEP(INODE))) ENDIF INDICE(ID+1)=INDICE(ID+1)+1 ENDIF ENDIF IN=INODE 5602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 5602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) IPOOL(fin)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF(SLAVEF.NE.1)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF(FIRST_LEAF.EQ.-9999)THEN FIRST_LEAF=INODE ENDIF SIZE_SBTR=SIZE_SBTR+1 ENDIF ENDIF ENDIF IF(PERM.NE.7)THEN NA(LEAF+2)=INODE ENDIF LEAF=LEAF-1 ELSE fin=fin-1 GOTO 999 ENDIF fin=fin-1 IF(fin.EQ.0) THEN IF(SIZE_SBTR.NE.0)THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1))THEN MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR FIRST_LEAF=-9999 SIZE_SBTR=0 ENDIF ENDIF ENDIF GOTO 789 ENDIF GOTO 999 789 CONTINUE IF(K76.EQ.6)THEN OOC_CUR_SBTR=1 DO I=1,NSTEPS TNSTK(I) = NE(I) ENDDO NBROOT=NA(2) NBLEAF=NA(1) IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 9100 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 9600 CONTINUE IF(SLAVEF.NE.1)THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) DEPTH_FIRST_TRAV(STEP(INODE))=CUR_DEPTH_FIRST_RANK DEPTH_FIRST_SEQ(CUR_DEPTH_FIRST_RANK)=INODE CUR_DEPTH_FIRST_RANK=CUR_DEPTH_FIRST_RANK+1 IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP199))THEN SBTR_ID(STEP(INODE))=OOC_CUR_SBTR ELSE SBTR_ID(STEP(INODE))=-9999 ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)), & KEEP199))THEN OOC_CUR_SBTR=OOC_CUR_SBTR+1 ENDIF ENDIF IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 1133 IN = FRERE(IN) IF (IN.GT.0) GO TO 1133 IFATH = -IN ENDIF IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 1163 GOTO 9100 ENDIF TNSTK(STEP(IFATH))=TNSTK(STEP(IFATH))-1 IF(TNSTK(STEP(IFATH)).EQ.0) THEN INODE=IFATH GOTO 9600 ELSE GOTO 9100 ENDIF 1163 CONTINUE ENDIF PEAK=0.0D0 FACT_SIZE=0_8 DO I=1,NBROOT PEAK=max(PEAK,dble(M(STEP(NA(2+NBLEAF+I))))) FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) ENDDO DEALLOCATE(IPOOL) DEALLOCATE(M) DEALLOCATE(fact) DEALLOCATE(TNSTK) DEALLOCATE(SON) DEALLOCATE(TAB2) DEALLOCATE(TAB1) DEALLOCATE(T1) DEALLOCATE(T2) DEALLOCATE(RESULT) DEALLOCATE(TEMP) DEALLOCATE(INDICE) IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEALLOCATE(DEPTH) ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN DEALLOCATE(M_TOTAL) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_BUILD_LOAD_MEM_INFO RECURSIVE SUBROUTINE DMUMPS_FUSION_SORT(TAB,DIM,TAB1,TAB2,PERM, & RESULT,TEMP1,TEMP2) IMPLICIT NONE INTEGER DIM INTEGER(8) TAB1(DIM),TAB2(DIM) INTEGER(8) TEMP1(DIM),TEMP2(DIM) INTEGER TAB(DIM), PERM,RESULT(DIM) INTEGER I,J,I1,I2 IF(DIM.EQ.1) THEN RESULT(1)=TAB(1) TEMP1(1)=TAB1(1) TEMP2(1)=TAB2(1) RETURN ENDIF I=DIM/2 CALL DMUMPS_FUSION_SORT(TAB(1),I,TAB1(1),TAB2(1),PERM, & RESULT(1),TEMP1(1),TEMP2(1)) CALL DMUMPS_FUSION_SORT(TAB(I+1),DIM-I,TAB1(I+1),TAB2(I+1), & PERM,RESULT(I+1),TEMP1(I+1),TEMP2(I+1)) I1=1 I2=I+1 J=1 DO WHILE ((I1.LE.I).AND.(I2.LE.DIM)) IF((PERM.EQ.3))THEN IF(TEMP1(I1).LE.TEMP1(I2))THEN TAB(J)=RESULT(I1) TAB1(J)=TEMP1(I1) J=J+1 I1=I1+1 ELSE TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) J=J+1 I2=I2+1 ENDIF GOTO 3 ENDIF IF((PERM.EQ.4).OR.(PERM.EQ.5))THEN IF (TEMP1(I1).GE.TEMP1(I2))THEN TAB(J)=RESULT(I1) TAB1(J)=TEMP1(I1) J=J+1 I1=I1+1 ELSE TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) J=J+1 I2=I2+1 ENDIF GOTO 3 ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.1).OR.(PERM.EQ.2)) THEN IF(TEMP1(I1).GT.TEMP1(I2))THEN TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 GOTO 3 ENDIF IF(TEMP1(I1).LT.TEMP1(I2))THEN TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) TAB(J)=RESULT(I2) J=J+1 I2=I2+1 GOTO 3 ENDIF IF((TEMP1(I1).EQ.TEMP1(I2)))THEN IF(TEMP2(I1).LE.TEMP2(I2))THEN TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 ELSE TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) TAB(J)=RESULT(I2) J=J+1 I2=I2+1 ENDIF ENDIF ENDIF 3 CONTINUE ENDDO IF(I1.GT.I)THEN DO WHILE(I2.LE.DIM) TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) J=J+1 I2=I2+1 ENDDO ELSE IF(I2.GT.DIM)THEN DO WHILE(I1.LE.I) TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 ENDDO ENDIF ENDIF DO I=1,DIM TEMP1(I)=TAB1(I) TEMP2(I)=TAB2(I) RESULT(I)=TAB(I) ENDDO RETURN END SUBROUTINE DMUMPS_FUSION_SORT MUMPS_5.8.1/src/sfac_mem_stack.F0000664000175000017500000005741415042446437016317 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_FAC_STACK(COMM_LOAD, ASS_IRECV, & N, INODE, TYPE, TYPEF, & LA, IW, LIW, A, & IFLAG, IERROR, OPELIW, NELVAW, NMAXNPIV, & PTRIST, PTLUST_S, & PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, NE, & POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP,KEEP8,DKEEP, & COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, SLAVEF, & FPERE, COMM, MYID, IPOOL, LPOOL, LEAF, NSTK_S, & PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, root, roota, & OPASSW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & , FLOP_ESTIM_ACC & ) USE SMUMPS_BUF, ONLY : SMUMPS_BUF_SEND_CB, SMUMPS_BUF_SEND_MAITRE2 USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_RTNELIND, & MUMPS_BUF_SEND_ROOT2SON USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER COMM, MYID, TYPE, TYPEF INTEGER N, LIW, INODE,IFLAG,IERROR INTEGER ICNTL(60), KEEP(500) REAL DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU INTEGER IWPOSCB, IWPOS, & FPERE, SLAVEF, NELVAW, NMAXNPIV INTEGER IW(LIW),PROCNODE_STEPS(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NE(KEEP(28)) REAL A(LA) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER LPOOL, LEAF, COMP INTEGER IPOOL( LPOOL ) INTEGER NSTK_S( KEEP(28) ) INTEGER PERM(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER NBFIN INTEGER NFRONT_ESTIM,NELIM_ESTIM DOUBLE PRECISION FLOP_ESTIM_ACC INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER NBROWS_ALREADY_SENT INTEGER(8) :: POSELT, OPSFAC INTEGER(8) :: IOLD, INEW, FACTOR_POS, I8 INTEGER NSLAVES, NCB, & H_INODE, IERR, NBCOL, NBROW, NBROW_SEND, & NELIM INTEGER NBROW_STACK, NBROW_INDICES, NBCOL_STACK INTEGER NCBROW_ALREADY_MOVED, NCBROW_PREVIOUSLY_MOVED, &NCBROW_NEWLY_MOVED INTEGER(8) :: LAST_ALLOWED_POS INTEGER(8) :: LREQCB, MIN_SPACE_IN_PLACE INTEGER(8) :: SHIFT_VAL_SON INTEGER SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, & LIST_ROW_SON, LIST_COL_SON, LIST_SLAVES INTEGER IOLDPS,NFRONT,NPIV,NASS,IOLDP1,PTROWEND, & LREQI, LCONT INTEGER I,LDA, INIV2 INTEGER MSGDEST, MSGTAG, CHK_LOAD INCLUDE 'mumps_headers.h' LOGICAL MUST_COMPACT_FACTORS LOGICAL PACKED_CB, COMPRESS_PANEL, COMPRESS_CB, LR_SOLVE LOGICAL INPLACE INTEGER(8) :: SIZE_INPLACE, FAC_ENTRIES, COUNT_EXTRA_IP_COPIES INTEGER INTSIZ DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL SSARBR, SSARBR_ROOT, MUMPS_INSSARBR, & MUMPS_IN_OR_ROOT_SSARBR EXTERNAL MUMPS_INSSARBR, MUMPS_IN_OR_ROOT_SSARBR 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 = abs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) H_INODE= 6 + NSLAVES + KEEP(IXSZ) LCONT = NFRONT - NPIV NBCOL = LCONT SSARBR = MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) SSARBR_ROOT = MUMPS_IN_OR_ROOT_SSARBR & (PROCNODE_STEPS(STEP(INODE)),KEEP(199)) LREQCB = 0_8 INPLACE = .FALSE. PACKED_CB = ((KEEP(215).EQ.0) & .AND.(KEEP(50).NE.0) & .AND.(TYPEF.EQ.1 & .OR.TYPEF.EQ.2 & ) & .AND.(TYPE.EQ.1)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = (IW(IOLDPS+XXLR).EQ.1.OR.IW(IOLDPS+XXLR).EQ.3) LR_SOLVE = (KEEP(486).EQ.2) MUST_COMPACT_FACTORS = .TRUE. IF (KEEP(201).EQ.1 .OR. KEEP(201).EQ.-1 & .OR. (COMPRESS_PANEL.AND.LR_SOLVE) & ) THEN MUST_COMPACT_FACTORS = .FALSE. ENDIF IF ((FPERE.EQ.0).AND.(NASS.NE.NPIV)) THEN IFLAG = -10 GOTO 600 ENDIF NBROW = LCONT IF (TYPE.EQ.2) NBROW = NASS - NPIV IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN LDA = NASS ELSE LDA = NFRONT ENDIF NBROW_SEND = NBROW NELIM = NASS-NPIV IF (TYPEF.EQ.2) NBROW_SEND = NELIM POSELT = PTRAST(STEP(INODE)) IF (POSELT .ne. PTRFAC(STEP(INODE))) THEN WRITE(*,*) MYID,":Error 1 in SMUMPS_FAC_STACK:" WRITE(*,*) "INODE, PTRAST, PTRFAC =", & INODE, PTRAST(STEP(INODE)), PTRFAC(STEP(INODE)) WRITE(*,*) "PACKED_CB, NFRONT, NPIV, NASS, NSLAVES", & PACKED_CB, NFRONT, NPIV, NASS, NSLAVES WRITE(*,*) "TYPE, TYPEF, FPERE ", & TYPE, TYPEF, FPERE CALL MUMPS_ABORT() END IF NELVAW = NELVAW + NASS - NPIV IF (KEEP(50) .eq. 0) THEN FAC_ENTRIES = int(NPIV,8) * int(NFRONT,8) ELSE FAC_ENTRIES = ( int(NPIV,8)*int(NPIV+1,8) )/ 2_8 ENDIF FAC_ENTRIES = FAC_ENTRIES + int(NBROW,8) * int(NPIV,8) IF ( KEEP(405) .EQ. 0 ) THEN KEEP8(10) = KEEP8(10) + FAC_ENTRIES KEEP(429) = KEEP(429) - 1 ELSE !$OMP ATOMIC UPDATE KEEP8(10) = KEEP8(10) + FAC_ENTRIES !$OMP END ATOMIC ENDIF CALL MUMPS_GET_FLOPS_COST( NFRONT, NPIV, NASS, & KEEP(50), TYPE,FLOP1 ) IF ( (.NOT. SSARBR_ROOT) .and. TYPE == 1) THEN IF (NE(STEP(INODE))==0) THEN CHK_LOAD=0 ELSE CHK_LOAD=1 ENDIF CALL MUMPS_LOAD_UPDATE(CHK_LOAD, .FALSE., -FLOP1, & KEEP,KEEP8) ENDIF FLOP1_EFFECTIVE = FLOP1 OPELIW = OPELIW + FLOP1 IF ( NPIV .NE. NASS ) THEN CALL MUMPS_GET_FLOPS_COST( NFRONT, NASS, NASS, & KEEP(50), TYPE,FLOP1 ) IF (.NOT. SSARBR_ROOT ) THEN IF (NE(STEP(INODE))==0) THEN CHK_LOAD=0 ELSE CHK_LOAD=1 ENDIF CALL MUMPS_LOAD_UPDATE(CHK_LOAD, .FALSE., & FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) ENDIF END IF IF ( SSARBR_ROOT ) THEN NFRONT_ESTIM=ND(STEP(INODE)) + KEEP(253) NELIM_ESTIM=NASS-(NFRONT-NFRONT_ESTIM) CALL MUMPS_GET_FLOPS_COST(NFRONT_ESTIM,NELIM_ESTIM,NELIM_ESTIM, & KEEP(50),1,FLOP1) END IF FLOP1=-FLOP1 IF (KEEP(400).GT.0) THEN FLOP_ESTIM_ACC = FLOP_ESTIM_ACC + FLOP1 ENDIF IF (SSARBR_ROOT) THEN CALL MUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1,KEEP,KEEP8) ELSE CALL MUMPS_LOAD_UPDATE(2,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF IF ( FPERE .EQ. 0 ) THEN IF ( KEEP(253) .NE. 0 .AND. KEEP(201).NE.-1 & .AND. KEEP(201).NE.1 & .AND. (.NOT.COMPRESS_PANEL.OR..NOT.LR_SOLVE) & ) THEN MUST_COMPACT_FACTORS = .TRUE. GOTO 190 ELSE IF ( KEEP(50) .NE. 0 .AND. KEEP(459).GT.1) THEN MUST_COMPACT_FACTORS = .TRUE. GOTO 190 ELSE MUST_COMPACT_FACTORS = .FALSE. GOTO 190 ENDIF ENDIF IF ( FPERE.EQ.KEEP(38) ) THEN NCB = NFRONT - NASS SHIFT_LIST_ROW_SON = H_INODE + NASS SHIFT_LIST_COL_SON = H_INODE + NFRONT + NASS SHIFT_VAL_SON = int(NASS,8)*int(NFRONT+1,8) IF (TYPE.EQ.1) THEN CALL SMUMPS_BUILD_AND_SEND_CB_ROOT( & COMM_LOAD, ASS_IRECV, N, INODE, FPERE, & PTLUST_S, PTRAST, & root, roota, NCB, NCB, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, & ROOT_CONT_STATIC, MYID, COMM, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE., ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS, 0, 0, 0 ) IF (IFLAG < 0 ) GOTO 500 ENDIF MSGDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)),KEEP(199)) IOLDPS = PTLUST_S(STEP(INODE)) LIST_ROW_SON = IOLDPS + H_INODE + NPIV LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) IF (MSGDEST.EQ.MYID) THEN CALL SMUMPS_PROCESS_RTNELIND( root, roota, & INODE, NELIM, NSLAVES, IW(LIST_ROW_SON), & IW(LIST_COL_SON), IW(LIST_SLAVES), & & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND) IF (IFLAG.LT.0) GOTO 600 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) CALL MUMPS_BUF_SEND_RTNELIND( INODE, NELIM, & IW(LIST_ROW_SON), IW(LIST_COL_SON), NSLAVES, & IW(LIST_SLAVES), MSGDEST, COMM, KEEP, IERR) IF ( IERR .EQ. -1 ) THEN BLOCKING =.FALSE. SET_IRECV =.TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, & ND, FRERE, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & .TRUE., LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IOLDPS = PTLUST_S(STEP(INODE)) LIST_ROW_SON = IOLDPS + H_INODE + NPIV LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) ENDIF ENDDO IF ( IERR .EQ. -2 ) THEN IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) IFLAG = - 17 GOTO 600 ELSE IF ( IERR .EQ. -3 ) THEN IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) IFLAG = -20 GOTO 600 ENDIF ENDIF IF (NELIM.EQ.0) THEN POSELT = PTRAST(STEP(INODE)) OPSFAC = POSELT + int(NPIV,8) * int(NFRONT,8) + int(NPIV,8) GOTO 190 ELSE GOTO 500 ENDIF ENDIF OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .NE. MYID ) THEN MSGTAG =NOEUD MSGDEST=MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), KEEP(199) ) IERR = -1 NBROWS_ALREADY_SENT = 0 DO WHILE (IERR.EQ.-1) IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN CALL SMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, & LCONT, NASS, NPIV, IW( IOLDPS + H_INODE + NPIV ), & IW( IOLDPS + H_INODE + NPIV + NFRONT ), & A( OPSFAC ), PACKED_CB, & MSGDEST, MSGTAG, COMM, KEEP, IERR ) ELSE IF ( TYPE.EQ.2 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ELSE INIV2 = -9999 ENDIF CALL SMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, & FPERE, INODE, & NBROW_SEND, IW(IOLDPS + H_INODE + NPIV ), & NBCOL, IW(IOLDPS + H_INODE + NPIV + NFRONT ), & A(OPSFAC), LDA, NELIM, TYPE, & NSLAVES, IW(IOLDPS+6+KEEP(IXSZ)), MSGDEST, & COMM, IERR, & & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) END IF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IOLDPS = PTLUST_S(STEP( INODE )) OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) END DO IF ( IERR .EQ. -2 .OR. IERR .EQ. -3 ) THEN IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN IERROR = ( 2*LCONT + 9 ) * KEEP( 34 ) + & LCONT*LCONT * KEEP( 35 ) ELSE IF (KEEP(50).ne.0 .AND. TYPE .eq. 2 ) THEN IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) & * KEEP( 34 ) + & NBROW_SEND*NBROW_SEND*KEEP( 35 ) ELSE IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) * KEEP( 34 ) + & NBROW_SEND*NBCOL*KEEP( 35 ) ENDIF IF (IERR .EQ. -2) THEN IFLAG = -17 IF ( LP > 0 ) THEN WRITE(LP, *) MYID, & ": FAILURE, SEND BUFFER TOO SMALL DURING & SMUMPS_FAC_STACK", TYPE, TYPEF ENDIF ENDIF IF (IERR .EQ. -3) THEN IFLAG = -20 IF ( LP > 0 ) THEN WRITE(LP, *) MYID, & ": FAILURE, RECV BUFFER TOO SMALL DURING & SMUMPS_FAC_STACK", TYPE, TYPEF ENDIF ENDIF GOTO 600 ENDIF ENDIF IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID ) THEN NBROW_SEND = 0 LREQI = 2 + KEEP(IXSZ) NBROW_STACK = NBROW NBROW_INDICES = NBROW IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN NBCOL_STACK = NELIM ELSE NBCOL_STACK = NBCOL ENDIF IF (COMPRESS_CB) THEN NBROW_STACK=NELIM IF (KEEP(50).NE.0) NBCOL_STACK = NELIM ENDIF ELSE NBROW_STACK = NBROW-NBROW_SEND NBROW_INDICES = NBROW-NBROW_SEND NBCOL_STACK = NBCOL IF (COMPRESS_CB) THEN NBROW_STACK = 0 NBCOL_STACK = 0 ENDIF LREQI = 6 + NBROW_INDICES + NBCOL + KEEP(IXSZ) IF (.NOT. (TYPE.EQ.1 .AND. TYPEF.EQ.2 ) ) GOTO 190 IF (FPERE.EQ.0) GOTO 190 ENDIF IF (PACKED_CB) THEN IF (NBROW_STACK.EQ.0.OR.NBCOL_STACK.EQ.0) THEN LREQCB = 0 ELSE LREQCB = ( int(NBCOL_STACK,8) * int( NBCOL_STACK + 1, 8) ) / 2_8 & - ( int(NBROW_SEND ,8) * int( NBROW_SEND + 1, 8) ) / 2_8 ENDIF ELSE LREQCB = int(NBROW_STACK,8) * int(NBCOL_STACK,8) ENDIF INPLACE = ( KEEP(234).NE.0 ) IF (KEEP(50).NE.0 .AND. TYPE .EQ. 2) INPLACE = .FALSE. INPLACE = INPLACE .OR. .NOT. MUST_COMPACT_FACTORS INPLACE = INPLACE .AND. & ( PTLUST_S(STEP(INODE)) + INTSIZ .EQ. IWPOS ) MIN_SPACE_IN_PLACE = 0_8 IF ( INPLACE .AND. KEEP(50).eq. 0 .AND. & MUST_COMPACT_FACTORS) THEN MIN_SPACE_IN_PLACE = int(NBCOL_STACK,8) ENDIF IF ( MIN_SPACE_IN_PLACE .GT. LREQCB ) THEN INPLACE = .FALSE. ENDIF CALL SMUMPS_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, .FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER,PAMASTER, & LREQI, LREQCB, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, LRLUSM, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 600 IW(IWPOSCB+1+XXF) = IW(IOLDPS+XXF) IW(IWPOSCB+1+XXLR) = IW(IOLDPS+XXLR) PTRIST(STEP(INODE)) = IWPOSCB+1 IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID ) THEN PIMASTER (STEP(INODE)) = PTLUST_S(STEP(INODE)) PAMASTER(STEP(INODE)) = IPTRLU + 1_8 PTRAST(STEP(INODE)) = -99999999_8 IW(IWPOSCB+1+KEEP(IXSZ)) = min(-NBCOL_STACK,-1) IW(IWPOSCB+2+KEEP(IXSZ)) = NBROW_STACK IF (PACKED_CB) IW(IWPOSCB+1+XXS) = S_CB1COMP ELSE PTRAST(STEP(INODE)) = IPTRLU+1_8 IF (PACKED_CB) IW(IWPOSCB+1+XXS)=S_CB1COMP IW(IWPOSCB+1+KEEP(IXSZ)) = NBCOL IW(IWPOSCB+2+KEEP(IXSZ)) = 0 IW(IWPOSCB+3+KEEP(IXSZ)) = NBROW_STACK IW(IWPOSCB+4+KEEP(IXSZ)) = 0 IW(IWPOSCB+5+KEEP(IXSZ)) = 1 IW(IWPOSCB+6+KEEP(IXSZ)) = 0 IOLDP1 = PTLUST_S(STEP(INODE))+H_INODE PTROWEND = IWPOSCB+6+NBROW_STACK+KEEP(IXSZ) DO I = 1, NBROW_STACK IW(IWPOSCB+7+KEEP(IXSZ)+I-1) = & IW(IOLDP1+NFRONT-NBROW_STACK+I-1) ENDDO DO I = 1, NBCOL IW(PTROWEND+I)=IW(IOLDP1+NFRONT+NPIV+I-1) ENDDO END IF IF ( KEEP(50).NE.0 .AND. TYPE .EQ. 1 & .AND. MUST_COMPACT_FACTORS ) THEN POSELT = PTRFAC(STEP(INODE)) CALL SMUMPS_COMPACT_FACTORS_SYM( A(POSELT), LDA, & NPIV, NBROW, KEEP, & int(LDA,8)*int(NBROW+NPIV,8), & IW( PTLUST_S(STEP(INODE)) + H_INODE + NFRONT ) ) MUST_COMPACT_FACTORS = .FALSE. ENDIF IF (COMPRESS_CB.AND.(LREQCB.EQ.0)) GOTO 190 IF ( KEEP(50).EQ.0 .AND. MUST_COMPACT_FACTORS ) & THEN LAST_ALLOWED_POS = POSELT + int(LDA,8)*int(NPIV+NBROW-1,8) & + int(NPIV,8) ELSE LAST_ALLOWED_POS = -1_8 ENDIF NCBROW_ALREADY_MOVED = 0 COUNT_EXTRA_IP_COPIES = 0_8 10 CONTINUE NCBROW_PREVIOUSLY_MOVED = NCBROW_ALREADY_MOVED IF (IPTRLU .LT. POSFAC ) THEN CALL SMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, PACKED_CB, & LAST_ALLOWED_POS, NCBROW_ALREADY_MOVED ) ELSE CALL SMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, PACKED_CB ) NCBROW_ALREADY_MOVED = NBROW_STACK ENDIF IF (LAST_ALLOWED_POS .NE. -1_8) THEN MUST_COMPACT_FACTORS =.FALSE. IF ( NCBROW_ALREADY_MOVED .EQ. NBROW_STACK ) THEN IF (COMPRESS_CB) THEN NCBROW_ALREADY_MOVED = NBROW ELSE NCBROW_ALREADY_MOVED = NCBROW_ALREADY_MOVED + NBROW_SEND ENDIF ENDIF NCBROW_NEWLY_MOVED = NCBROW_ALREADY_MOVED & - NCBROW_PREVIOUSLY_MOVED FACTOR_POS = POSELT + & int(LDA,8)*int(NPIV+NBROW-NCBROW_ALREADY_MOVED,8) CALL SMUMPS_COMPACT_FACTORS_UNSYM( A(FACTOR_POS), LDA, NPIV, & NCBROW_NEWLY_MOVED, KEEP, & int(NCBROW_NEWLY_MOVED,8) * int(LDA,8) ) INEW = FACTOR_POS + int(NPIV,8) * int(NCBROW_NEWLY_MOVED,8) IOLD = INEW + int(NCBROW_NEWLY_MOVED,8) * int(NBCOL_STACK,8) DO I8 = 0_8, int(NCBROW_PREVIOUSLY_MOVED,8)*int(NPIV,8)-1 A(INEW) = A(IOLD) IOLD = IOLD + 1_8 INEW = INEW + 1_8 ENDDO COUNT_EXTRA_IP_COPIES = COUNT_EXTRA_IP_COPIES + & int(NCBROW_PREVIOUSLY_MOVED,8) & * int(NPIV,8) LAST_ALLOWED_POS = INEW IF (NCBROW_ALREADY_MOVED.LT.NBROW_STACK) THEN GOTO 10 ENDIF ENDIF IF ( COUNT_EXTRA_IP_COPIES .GT. 0_8 ) THEN !$OMP ATOMIC UPDATE KEEP8(8) = KEEP8(8) + COUNT_EXTRA_IP_COPIES !$OMP END ATOMIC COUNT_EXTRA_IP_COPIES = 0_8 ENDIF 190 CONTINUE IF (MUST_COMPACT_FACTORS) THEN POSELT = PTRFAC(STEP(INODE)) IF (KEEP(50).NE.0) THEN CALL SMUMPS_COMPACT_FACTORS_SYM( A(POSELT), LDA, & NPIV, NBROW, KEEP, & int(LDA,8)*int(NBROW+NPIV,8), & IW( PTLUST_S(STEP(INODE)) + H_INODE + NFRONT ) ) ELSE CALL SMUMPS_COMPACT_FACTORS_UNSYM( & A(POSELT+int(NPIV,8)*int(LDA,8)), & LDA, NPIV, NBROW, KEEP, int(NBROW,8)*int(LDA,8) ) ENDIF MUST_COMPACT_FACTORS = .FALSE. ENDIF IOLDPS = PTLUST_S(STEP(INODE)) IW(IOLDPS+KEEP(IXSZ)) = NBCOL IW(IOLDPS + 1+KEEP(IXSZ)) = NASS - NPIV IF (TYPE.EQ.2) THEN IW(IOLDPS + 2+KEEP(IXSZ)) = NASS ELSE IW(IOLDPS + 2+KEEP(IXSZ)) = NFRONT ENDIF IW(IOLDPS + 3+KEEP(IXSZ)) = NPIV IF (INPLACE) THEN SIZE_INPLACE = LREQCB - MIN_SPACE_IN_PLACE ELSE SIZE_INPLACE = 0_8 ENDIF CALL SMUMPS_COMPRESS_LU(SIZE_INPLACE,MYID,N,IOLDPS,TYPE, IW, LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, SSARBR,INODE,IERR & , LRGROUPS, NASS & ) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 GOTO 600 ENDIF 500 CONTINUE RETURN 600 CONTINUE IF (IFLAG .NE. -1 .AND. KEEP(405) .EQ. 0) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE SMUMPS_FAC_STACK MUMPS_5.8.1/src/cfac_driver.F0000664000175000017500000056451215042446441015624 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_FAC_DRIVER(id,idintr) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_INI_MYID, MUMPS_BUF_INIT, & MUMPS_BUF_ALLOC_SMALL_BUF, MUMPS_BUF_DEALL_SMALL_BUF, & MUMPS_BUF_DIST_IRECV_SIZE USE MUMPS_LOAD USE CMUMPS_OOC, ONLY : CMUMPS_OOC_INIT_FACTO, & CMUMPS_OOC_END_FACTO USE CMUMPS_STRUC_DEF USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_INTR_STRUC USE CMUMPS_FACSOL_L0OMP_M, ONLY: CMUMPS_FREE_L0_OMP_FACTORS, & CMUMPS_INIT_L0_OMP_FACTORS USE CMUMPS_DYNAMIC_MEMORY_M, ONLY: CMUMPS_DM_ALLOC_S_WK, & CMUMPS_DM_FREE_S_WK USE MUMPS_LR_STATS USE CMUMPS_LR_DATA_M, only: CMUMPS_BLR_INIT_MODULE, & CMUMPS_BLR_END_MODULE & , CMUMPS_BLR_MOD_TO_STRUC USE CMUMPS_FAC_COMPACT_FACTORS_M, ONLY: & CMUMPS_TRY_COMPACT_FACTORS USE MUMPS_PIVNUL_MOD, only: PIVNUL_LIST_STRUCT_T USE MUMPS_FRONT_DATA_MGT_M #if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M #endif #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif !$ USE OMP_LIB C Derived datatype to pass pointers with implicit interfaces USE CMUMPS_FAC_S_IS_POINTERS_M, ONLY : CMUMPS_S_IS_POINTERS_T IMPLICIT NONE C C Purpose C ======= C C Performs scaling, sorting in arrowhead, then C distributes the matrix, and perform C factorization. C C INTERFACE SUBROUTINE CMUMPS_ANORMINF(id, ANORMINF, LSCAL, EFF_SIZE_SCHUR) USE CMUMPS_STRUC_DEF TYPE (CMUMPS_STRUC), TARGET :: id REAL, INTENT(OUT) :: ANORMINF LOGICAL, INTENT(IN) :: LSCAL INTEGER, INTENT(IN) :: EFF_SIZE_SCHUR END SUBROUTINE CMUMPS_ANORMINF END INTERFACE C C Parameters C ========== C TYPE (CMUMPS_STRUC), TARGET :: id TYPE (CMUMPS_INTR_STRUC) :: idintr C C MPI C === C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 C C Local variables C =============== C INCLUDE 'mumps_headers.h' INTEGER(8) :: NSEND8, NSEND_TOT8 INTEGER(8) :: NLOCAL8, NLOCAL_TOT8 INTEGER(4) :: I4 INTEGER :: LDPTRAR, NELT_arg, NBRECORDS INTEGER :: ITMP, JTMP INTEGER :: KEEP464COPY, KEEP465COPY INTEGER(8) :: KEEP826_SAVE INTEGER(8) :: K67, K68, K70, K74, K75 INTEGER(8) ITMP8 INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER MP, LP, MPG, allocok LOGICAL PROK, PROKG, LSCAL, LPOK, COMPUTE_ANORMINF C Reception buffer INTEGER :: CMUMPS_LBUFR, CMUMPS_LBUFR_BYTES INTEGER(8) :: CMUMPS_LBUFR_BYTES8 ! for intermediate computation INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFR C Size of send buffers (in bytes) INTEGER :: CMUMPS_LBUF, CMUMPS_LBUF_INT INTEGER(8) :: CMUMPS_LBUF8 ! for intermediate computation C INTEGER PTRIST, PTRWB, MAXELT_SIZE, & ITLOC, IPOOL, LPOOL INTEGER IRANK, ID_ROOT INTEGER KKKK INTEGER(8) :: NZ_locMAX8 INTEGER(8) MEMORY_MD_ARG INTEGER(8) MAXS_BASE8, MAXS_BASE_RELAXED8 REAL CNTL4, AVG_FLOPS INTEGER MIN_PERLU, MAXIS_ESTIM INTEGER SUM_INFO22_THIS_NODE, MAX_SUM_INFO22_THIS_NODE C TYPE (CMUMPS_S_IS_POINTERS_T) :: S_IS_POINTERS INTEGER :: MAXIS INTEGER(8) :: MAXS INTEGER :: ICNTL49_LOC, TMP_INFOG_4 C For S argument to arrowhead routines: INTEGER(8) :: MAXS_ARG COMPLEX, TARGET :: S_DUMMY_ARG(1) COMPLEX, POINTER, DIMENSION(:) :: S_PTR_ARG TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT C Arrowheads INTEGER, ALLOCATABLE, DIMENSION(:) :: INTARR COMPLEX, POINTER, DIMENSION(:) :: DBLARR C (pointer to point on used-data in some cases--elt-entry) REAL TMPTIME INTEGER NOMP INTEGER NB_THREADS DOUBLE PRECISION TIMEAVG, TIMEMAX, & FLOPAVG, FLOPMAX REAL TMPFLOP INTEGER NPIV_CRITICAL_PATH, EFF_SIZE_SCHUR DOUBLE PRECISION TIME, TIMEET REAL ZERO, ONE, MONE PARAMETER( ZERO = 0.0E0, ONE = 1.0E0, MONE = -1.0E0) COMPLEX CZERO PARAMETER( CZERO = (0.0E0, 0.0E0) ) INTEGER PERLU, TOTAL_MBYTES, K231, K232, K233, BLR_STRAT INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. INTEGER, PARAMETER :: PANEL_TABSIZE = 20 INTEGER COLOUR, COMM_FOR_SCALING ! For Simultaneous scaling INTEGER(8) :: LIWK, LIWK8 INTEGER(8) :: LWK, LWK_REAL, LWRKR_TH, LWRKC_TH INTEGER :: NOMP_MAX C I_AM_SLAVE: used to determine if proc has the role of a slave C WK_USER_PROVIDED is set to true when WK_USER is provided by user LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED, EARLYT3ROOTINS LOGICAL PRINT_MAXAVG, PRINT_NODEINFO REAL :: ANORMINF, SEUIL, SEUIL_LDLT_NIV2, Thresh_Seuil REAL :: CNTL1, CNTL3, CNTL5, CNTL6, EPS INTEGER N, LPN_LIST,POSBUF INTEGER, DIMENSION (:), ALLOCATABLE :: ITMP2 INTEGER I,K INTEGER(8) :: ITEMP8 INTEGER :: PARPIV_T1 INTEGER FRONTWISE C temporary variables for collecting stats from all processors INTEGER, PARAMETER :: LR_DKEEPSHIFT=49, LR_TABSIZE=18 DOUBLE PRECISION :: LR_TAB(LR_TABSIZE), LR_EPSILON DOUBLE PRECISION :: TMP_MRY_LU_FR DOUBLE PRECISION :: TMP_MRY_LU_LRGAIN INTEGER :: KEEP399_SAVE, KEEP20_SAVE DOUBLE PRECISION :: TMP_MRY_CB_FR DOUBLE PRECISION :: TMP_MRY_CB_LRGAIN DOUBLE PRECISION :: TMP_FLOP_LRGAIN DOUBLE PRECISION :: TMP_FLOP_TRSM DOUBLE PRECISION :: TMP_FLOP_PANEL DOUBLE PRECISION :: TMP_FLOP_FRFRONTS DOUBLE PRECISION :: TMP_FLOP_TRSM_FR DOUBLE PRECISION :: TMP_FLOP_TRSM_LR DOUBLE PRECISION :: TMP_FLOP_UPDATE_FR DOUBLE PRECISION :: TMP_FLOP_UPDATE_LR DOUBLE PRECISION :: TMP_FLOP_UPDATE_LRLR3 DOUBLE PRECISION :: TMP_FLOP_COMPRESS DOUBLE PRECISION :: TMP_FLOP_DECOMPRESS DOUBLE PRECISION :: TMP_FLOP_MIDBLK_COMPRESS DOUBLE PRECISION :: TMP_FLOP_FRSWAP_COMPRESS DOUBLE PRECISION :: TMP_FLOP_ACCUM_COMPRESS DOUBLE PRECISION :: TMP_FLOP_CB_COMPRESS DOUBLE PRECISION :: TMP_FLOP_CB_DECOMPRESS DOUBLE PRECISION :: TMP_FLOP_FACTO_FR INTEGER :: TMP_CNT_NODES DOUBLE PRECISION :: TMP_TIME_UPDATE DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR1 DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR2 DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR3 DOUBLE PRECISION :: TMP_TIME_UPDATE_FRLR DOUBLE PRECISION :: TMP_TIME_UPDATE_FRFR DOUBLE PRECISION :: TMP_TIME_COMPRESS DOUBLE PRECISION :: TMP_TIME_MIDBLK_COMPRESS DOUBLE PRECISION :: TMP_TIME_FRSWAP_COMPRESS DOUBLE PRECISION :: TMP_TIME_CB_COMPRESS DOUBLE PRECISION :: TMP_TIME_PANEL DOUBLE PRECISION :: TMP_TIME_FAC_I DOUBLE PRECISION :: TMP_TIME_FAC_MQ DOUBLE PRECISION :: TMP_TIME_FAC_SQ DOUBLE PRECISION :: TMP_TIME_LRTRSM DOUBLE PRECISION :: TMP_TIME_FRTRSM DOUBLE PRECISION :: TMP_TIME_FRFRONTS DOUBLE PRECISION :: TMP_TIME_LR_MODULE DOUBLE PRECISION :: TMP_TIME_DIAGCOPY DOUBLE PRECISION :: TMP_TIME_DECOMP DOUBLE PRECISION :: TMP_TIME_DECOMP_UCFS DOUBLE PRECISION :: TMP_TIME_LRASM_NIV1 DOUBLE PRECISION :: TMP_TIME_LRASM_LOCASM2 DOUBLE PRECISION :: TMP_TIME_LRASM_MAPLIG1 DOUBLE PRECISION :: TMP_TIME_LRASM_CONTRIB2 DOUBLE PRECISION :: TMP_TIME_FRASM_LOCASM2 DOUBLE PRECISION :: TMP_TIME_FRASM_MAPLIG1 DOUBLE PRECISION :: TMP_TIME_FRASM_CONTRIB2 C C Workspace C INTEGER, DIMENSION(:), ALLOCATABLE :: IWK COMPLEX, DIMENSION(:), ALLOCATABLE :: WK REAL, DIMENSION(:), ALLOCATABLE :: WK_REAL REAL, DIMENSION(:,:), ALLOCATABLE:: WRKR_TH, & WRKC_TH INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWK8 INTEGER, DIMENSION(:), ALLOCATABLE :: BURP INTEGER, DIMENSION(:), ALLOCATABLE :: BUCP INTEGER, DIMENSION(:), ALLOCATABLE :: BURS INTEGER, DIMENSION(:), ALLOCATABLE :: BUCS INTEGER(8) :: BUREGISTRE(12) INTEGER(8) :: BUINTSZ, BURESZ, NZ_loc8 INTEGER :: BUJOB INTEGER BUMAXMN, M, SCMYID, SCNPROCS REAL SCONEERR, SCINFERR C C Parameters arising from the structure C ===================================== C * Control parameters: see description in CMUMPSID REAL,DIMENSION(:),POINTER::RINFO, RINFOG REAL,DIMENSION(:),POINTER:: CNTL INTEGER,DIMENSION(:),POINTER :: INFOG, KEEP INTEGER, DIMENSION(:), POINTER :: IRN_loc_PTR, JCN_loc_PTR REAL, DIMENSION(:), POINTER :: COLSCA_PTR, & ROWSCA_PTR COMPLEX, DIMENSION(:), POINTER:: A_loc_PTR INTEGER, TARGET :: DUMMYIRN_loc(1), DUMMYJCN_loc(1) REAL, TARGET :: DUMMYSCA(1) COMPLEX, TARGET :: DUMMYA_loc(1) INTEGER,DIMENSION(:),POINTER::ICNTL EXTERNAL MUMPS_GET_POOL_LENGTH INTEGER MUMPS_GET_POOL_LENGTH, SIZESCAL INTEGER(8) :: TOTAL_BYTES C C External references C =================== INTEGER, EXTERNAL :: MUMPS_NUMROC INTEGER:: NWORKING LOGICAL:: MEM_EFF_ALLOCATED INTEGER :: TOTAL_MBYTES_UNDER_L0 INTEGER(8):: TOTAL_BYTES_UNDER_L0 C Fwd in facto: COMPLEX, DIMENSION(:), POINTER :: RHS_MUMPS LOGICAL :: RHS_MUMPS_ALLOCATED LOGICAL :: DBLARR_ALLOCATED INTEGER :: NB_ACTIVE_FRONTS_ESTIM INTEGER :: NB_FRONTS_F_ESTIM INTEGER :: KEEP_486_FOR_PRINT C C -------------------------- C Pointers used as shortcuts C -------------------------- RINFO=>id%RINFO RINFOG=>id%RINFOG CNTL=>id%CNTL INFOG=>id%INFOG KEEP=>id%KEEP ICNTL=>id%ICNTL IF (id%KEEP8(29) .NE. 0) THEN IRN_loc_PTR=>id%IRN_loc JCN_loc_PTR=>id%JCN_loc A_loc_PTR=>id%A_loc ELSE IRN_loc_PTR=>DUMMYIRN_loc JCN_loc_PTR=>DUMMYJCN_loc A_loc_PTR=>DUMMYA_loc ENDIF NOMP = 1 N = id%N C TIMINGS: reset to 0 id%DKEEP(92)=0.0E0 id%DKEEP(93)=0.0E0 id%DKEEP(94)=0.0E0 id%DKEEP(95)=0.0E0 id%DKEEP(96)=0.0E0 id%DKEEP(97)=0.0E0 id%DKEEP(98)=0.0E0 id%DKEEP(99)=0.0E0 id%DKEEP(56)=0.0E0 C Count of MPI messages: reset to 0 id%KEEP(266)=0 id%KEEP(267)=0 C ------------------------------------- C Depending on the type of parallelism, C the master can now (soon) potentially C have the role of a slave C ------------------------------------- I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) LIWK = 0_8 LIWK8 = 0_8 C RR related id%KEEP(17) = 0 id%INFOG(28) = 0 C Number of symmetric swaps id%KEEP8(80)=0_8 C Largest increase of internal panel size id%KEEP(425) =0 C Dynamic memory during process_blocfacto, in number of scalar entries id%KEEP8(130) = 0_8 ! instantaneous id%KEEP8(131) = 0_8 ! max id%KEEP8(132) = 0_8 ! max of max id%KEEP8(133) = 0_8 ! sum of max C Measure recursivity =max number of simultaneous calls to C CMUMPS_FAC_PROCESS_BLOCFACTO_LDLT id%KEEP(174) = 0 id%KEEP(175) = 0 C KEEP20_SAVE = KEEP(20) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) C Print per node informtation only in case ther are several C compute nodes (id%KEEP(412): #MPI procs on comupte node) PRINT_NODEINFO = PRINT_MAXAVG .AND. id%NPROCS .NE. id%KEEP(412) C C Related to forward in facto functionality (referred to as "Fwd in facto") NULLIFY(RHS_MUMPS) NULLIFY(DBLARR) RHS_MUMPS_ALLOCATED = .FALSE. DBLARR_ALLOCATED = .FALSE. C ----------------------------------------------------------------------- C Set WK_USER_PROVIDED to true when workspace WK_USER is provided by user C We can accept WK_USER to be provided on only one proc and C different values of WK_USER per processor C WK_USER(LWK_USER): only on working processes WK_USER_PROVIDED = (id%LWK_USER.NE.0 .AND. I_AM_SLAVE) IF (WK_USER_PROVIDED) THEN IF (id%LWK_USER.GT.0) THEN id%KEEP8(24) = int(id%LWK_USER,8) ELSE id%KEEP8(24) = -int(id%LWK_USER,8)* 1000000_8 ENDIF ELSE id%KEEP8(24) = 0_8 ENDIF C Compute sum of LWK_USER provided by user CALL MPI_REDUCE ( id%KEEP8(24), id%KEEP8(124), 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) C C KEEP8(26) might be modified C (element entry format) C but need be restore for C future factorisation C with different scaling option C KEEP826_SAVE = id%KEEP8(26) C In case of loop on factorization with C different scaling options, initialize C DKEEP(4:5) to 0. id%DKEEP(4)=-1.0E0 id%DKEEP(5)=-1.0E0 C Mapping information used during solve. In case of several facto+solve C it has to be recomputed. In case of several solves with the same C facto, it is not recomputed. IF (associated(id%IPTR_WORKING)) THEN DEALLOCATE(id%IPTR_WORKING) NULLIFY(id%IPTR_WORKING) END IF IF (associated(id%WORKING)) THEN DEALLOCATE(id%WORKING) NULLIFY(id%WORKING) END IF C C Units for printing C MP: diagnostics C LP: errors C LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) IF ( PROK ) WRITE( MP, 130 ) IF ( PROKG ) WRITE( MPG, 130 ) C C Prepare work for out-of-core C IF (id%MYID .EQ. MASTER .AND. KEEP(201) .NE. -1) THEN C Note that if KEEP(201)=-1, then we have decided C at analysis phase that factors will not be stored C (neither in memory nor on disk). In that case, C ICNTL(22) is ignored. C -- ICNTL(22) must be set before facto phase C (=1 OOC on; =0 OOC off) C and cannot be changed for subsequent solve phases. KEEP(201)=id%ICNTL(22) IF (KEEP(201) .EQ. 1) THEN # if defined(OLD_OOC_NOPANEL) KEEP(201)=2 # else KEEP(201)=1 # endif ELSE id%KEEP(201)=0 ENDIF ENDIF C C ---------------------- C Broadcast ICNTL(49) IF (id%MYID.EQ.MASTER) THEN ICNTL49_LOC=id%ICNTL(49) C out of range treated as 0 IF ( (ICNTL49_LOC.GT.2).or.(ICNTL49_LOC.LT.0) ) & ICNTL49_LOC = 0 ENDIF CALL MPI_BCAST( ICNTL49_LOC, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C ---------------------- C C Broadcast few other KEEP entries that have been decoded C and are defined for facto: C ---------------------- CALL MPI_BCAST( KEEP(12), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(19), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(21), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(459), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(460), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF ( KEEP(459) .GE. PANEL_TABSIZE ) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I4,A,I3)') " ** WARNING ** KEEP(459)=",KEEP(459), & " too large, resetting to",PANEL_TABSIZE-1 ENDIF KEEP(459) = PANEL_TABSIZE - 1 ENDIF PERLU = KEEP(12) IF (id%MYID.EQ.MASTER) THEN C { C KEEP(50) case C ============== C C KEEP(50) = 0 : matrix is unsymmetric C KEEP(50) /= 0 : matrix is symmetric C KEEP(50) = 1 : Ask L L^T on the root. Matrix is PSD. C KEEP(50) = 2 : Ask for L U on the root C KEEP(50) = 3 ... L D L^T ?? C CNTL1 = id%CNTL(1) C --------------------------------------- C For symmetric (non general) matrices C set (directly) CNTL1 = 0.0 C --------------------------------------- KEEP(17)=0 C Automatic choice if CNTL(1)<0 C For rank-revealing (KEEP(19).GT.0) then C set CNTL1=0.1 even if SYM=1 IF (CNTL1.LT.ZERO) THEN C automatic choice IF (KEEP(19).GT.0) THEN CNTL1=0.1E0 ELSE IF (KEEP(50).EQ.1) THEN CNTL1=ZERO ELSE CNTL1=0.01E0 ENDIF ENDIF IF ( KEEP(50) .eq. 1 ) THEN IF (CNTL1 .ne. ZERO ) THEN IF ( PROKG ) THEN WRITE(MPG,'(A)') & '** Warning : SPD solver called, resetting CNTL(1) to 0.0E0' END IF END IF CNTL1 = ZERO END IF C CNTL1 threshold value must be between C 0.0 and 1.0 (for SYM=0) and 0.5 (for SYM=1,2) IF (CNTL1.GT.ONE) CNTL1=ONE IF (CNTL1.LT.ZERO) CNTL1=ZERO IF (KEEP(50).NE.0.AND.CNTL1.GT.0.5E0) THEN CNTL1 = 0.5E0 ENDIF PARPIV_T1 = id%KEEP(268) IF (PARPIV_T1.EQ.77) THEN PARPIV_T1 = 0 #if defined(__ve__) PARPIV_T1 = -2 #endif ENDIF IF (PARPIV_T1.EQ.-3) THEN PARPIV_T1 = 0 ENDIF IF ((PARPIV_T1.LT.-3).OR.(PARPIV_T1.GT.1)) THEN C out of range values PARPIV_T1 =0 ENDIF C note that KEEP(50).EQ.1 => CNTL1=0.0 IF (CNTL1.EQ.0.0E0.OR.(KEEP(50).eq.1)) PARPIV_T1 = 0 C IF (PARPIV_T1.EQ.-2) THEN IF (KEEP(19).NE.0) THEN C switch off PARPIV_T1 if RR activated C but do NOT switch off PARPIV_1 with null pivot detection PARPIV_T1 = 0 ENDIF ENDIF id%KEEP(269) = PARPIV_T1 C } ENDIF CALL MPI_BCAST(CNTL1, 1, MPI_REAL, & MASTER, id%COMM, IERR) CALL MPI_BCAST( KEEP(269), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (id%MYID.EQ.MASTER) THEN C{ C OMP parallelization of arrowheads C out of range are treated as zero IF (KEEP(399).LT.-1) KEEP(399)=-1 KEEP399_SAVE = KEEP(399) IF (KEEP(399).EQ.-1) THEN IF ((KEEP(54).EQ.0).AND.(id%NPROCS.GT.1)) THEN KEEP(399) = 1 ELSE KEEP(399) = 3 ENDIF ENDIF #if defined(PCPRET) C new multithreaded >=2 algo does not compile on PCPRET KEEP(399) = 1 #endif C ----------------------------------------------------- C Decoding of ICNTL(35) for factorization: same as C at analysis except that we store a copy of ICNTL(35) C in KEEP(486) instead of KEEP(494) and need to check C compatibility of KEEP(486) and KEEP(494): If LR was C not activated during analysis, it cannot be activated C at factorization. C ------------------------------------------------------ id%KEEP(486) = id%ICNTL(35) IF (id%KEEP(486).EQ.1) THEN C -- Automatic BLR option setting id%KEEP(486)= 2 ENDIF IF ( id%KEEP(486).EQ.4) id%KEEP(486)=0 IF ((id%KEEP(486).LT.0).OR.(id%KEEP(486).GT.4)) THEN C Out of range values treated as 0 id%KEEP(486) = 0 ENDIF IF ((KEEP(486).NE.0).AND.(KEEP(494).EQ.0)) THEN C To activate BLR during factorization, C ICNTL(35) must have been set at analysis. IF (LPOK) THEN WRITE(LP,'(A)') & " *** Error with BLR setting " WRITE(LP,'(A)') " *** BLR was not activated during ", & " analysis but is requested during factorization." ENDIF id%INFO(1)=-54 id%INFO(2)=0 GOTO 105 ENDIF C Save value of KEEP(486) before possibly C forcing it to 3 in case of discard factors KEEP_486_FOR_PRINT=KEEP(486) IF (KEEP(201) .EQ. -1 .AND. KEEP(486) .NE.0) THEN KEEP(486) = 3 ENDIF KEEP464COPY = id%ICNTL(38) IF (KEEP464COPY.LT.0.OR.KEEP464COPY.GT.1000) THEN C Out of range values treated as 1000 KEEP464COPY = 1000 ENDIF IF (id%KEEP(461).LT.1) THEN id%KEEP(461) = 10 ENDIF IF (id%KEEP(462).LT.1) THEN id%KEEP(462) = 10 ENDIF KEEP465COPY = id%ICNTL(39) IF (KEEP465COPY.LT.0.OR.(KEEP465COPY.GT.1000)) THEN C Out of range values treated as 1000 KEEP465COPY = 1000 ENDIF IF (id%ICNTL(36).EQ.1.OR.id%ICNTL(36).EQ.3) THEN IF (CNTL1.EQ.ZERO .OR. KEEP(468).LE.1) THEN KEEP(475) = 3 ELSE IF ( (KEEP(269).GT.0).OR. (KEEP(269).EQ.-2)) THEN KEEP(475) = 2 ELSE IF (KEEP(468).EQ.2) THEN KEEP(475) = 2 ELSE KEEP(475) = 1 ENDIF ELSE KEEP(475) = 0 ENDIF KEEP(481)=0 IF (id%ICNTL(36).LT.0 .OR. id%ICNTL(36).GE.2) THEN C Only options 1 and 2 are allowed KEEP(475) = 0 ENDIF C K489 is set according to ICNTL(37) IF (id%ICNTL(37).EQ.0.OR.id%ICNTL(37).EQ.1) THEN KEEP(489) = id%ICNTL(37) ELSE C Other values treated as zero KEEP(489) = 0 ENDIF IF (KEEP(79).GE.1) THEN C CompressCB incompatible with type4,5,6 nodes KEEP(489)=0 ENDIF C id%KEEP(476) \in [1,100] IF ((id%KEEP(476).GT.100).OR.(id%KEEP(476).LT.1)) THEN id%KEEP(476)= 50 ENDIF C id%KEEP(477) \in [1,100] IF ((id%KEEP(477).GT.100).OR.(id%KEEP(477).LT.1)) THEN id%KEEP(477)= 100 ENDIF C id%KEEP(483) \in [1,100] IF ((id%KEEP(483).GT.100).OR.(id%KEEP(483).LT.1)) THEN id%KEEP(483)= 80 ENDIF C id%KEEP(484) \in [1,100] IF ((id%KEEP(484).GT.100).OR.(id%KEEP(484).LT.1)) THEN id%KEEP(484)= 80 ENDIF C id%KEEP(480)=0,2,3,4,5,6 IF ((id%KEEP(480).GT.6).OR.(id%KEEP(480).LT.0) & .OR.(id%KEEP(480).EQ.1)) THEN id%KEEP(480)=0 ENDIF C id%KEEP(473)=0 or 1 IF ((id%KEEP(473).NE.0).AND.(id%KEEP(473).NE.1)) THEN id%KEEP(473)=0 ENDIF C id%KEEP(474)=0,1,2,3 IF ((id%KEEP(474).GT.3).OR.(id%KEEP(474).LT.0)) THEN id%KEEP(474)=0 ENDIF C id%KEEP(479)>0 IF (id%KEEP(479).LE.0) THEN id%KEEP(479)=1 ENDIF IF (id%KEEP(474).NE.0.AND.id%KEEP(480).EQ.0) THEN id%KEEP(474) = 0 ENDIF IF (id%KEEP(478).NE.0.AND.id%KEEP(480).LT.4) THEN id%KEEP(478) = 0 ENDIF IF (id%KEEP(480).GE.5 .OR. & (id%KEEP(480).NE.0.AND.id%KEEP(474).EQ.3)) THEN IF (id%KEEP(475).LT.2) THEN C Reset to 3 if 5 or to 4 if 6 id%KEEP(480) = id%KEEP(480) - 2 write(*,*) ' Resetting KEEP(480) to ', id%KEEP(480) ENDIF ENDIF 105 CONTINUE C} ENDIF ! id%MYID .EQ. MASTER CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C IF (id%INFO(1).LT.0) GOTO 530 EPS = epsilon ( ZERO ) CALL MPI_BCAST( KEEP(281), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(399), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(473), 14, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (KEEP(486).NE.0) THEN CALL MPI_BCAST( KEEP(489), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP464COPY, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP465COPY, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF IF (id%MYID.EQ.MASTER) THEN IF (KEEP(217).GT.2.OR.KEEP(217).LT.0) THEN KEEP(217)=0 ENDIF KEEP(214)=KEEP(217) IF (KEEP(214).EQ.0) THEN IF (KEEP(201).NE.0) THEN ! OOC or no factors KEEP(214)=1 ELSE KEEP(214)=2 ENDIF IF (KEEP(486).EQ.2) THEN KEEP(214)=1 ENDIF ENDIF ENDIF CALL MPI_BCAST( KEEP(214), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (KEEP(201).NE.0) THEN C -- Low Level I/O strategy CALL MPI_BCAST( KEEP(99), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(205), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(211), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(255), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF C Fwd in facto: explicitly forbid C sparse RHS and A-1 computation IF (id%KEEP(252).EQ.1 .AND. id%MYID.EQ.MASTER) THEN IF (id%ICNTL(20).EQ.1) THEN ! out-of-range => 0 C NB: in doc ICNTL(20) only accessed during solve C In practice, will have failed earlier if RHS not allocated. C Still it looks safer to keep this test. id%INFO(1)=-43 id%INFO(2)=20 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: Sparse RHS is incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE IF (id%ICNTL(30).NE.0) THEN ! out-of-range => 1 id%INFO(1)=-43 id%INFO(2)=30 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: A-1 functionality incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE IF (id%ICNTL(9) .NE. 1) THEN id%INFO(1)=-43 id%INFO(2)=9 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C IF (id%INFO(1).LT.0) GOTO 530 C C The memory allowed is given by ICNTL(23) in Mbytes C 0 means that nothing is provided. C Save memory available, ICNTL(23) in KEEP8(4) C IF ( ICNTL(23) .GT. 0 ) THEN ITMP = 1 ELSE ITMP = 0 ENDIF CALL MPI_ALLREDUCE( ITMP, JTMP, 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) IF ( id%MYID.EQ.MASTER ) THEN C Negative values considered 0 ITMP = max(ICNTL(23),0) END IF CALL MPI_BCAST( ITMP, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C JTMP: nb of procs with nonzero ICNTL(23) C ITMP: value of ICNTL(23) on master IF ( ITMP .GT. 0 .AND. JTMP .EQ. 1 ) THEN C ICNTL(23)>0 only on master ELSE C Local values of ICNTL(23) are used, note that C they could all be zeros ITMP = ICNTL(23) ENDIF C ITMP8 = int(ITMP, 8) id%KEEP8(4) = ITMP8 * 1000000_8 ! convert to nb of bytes C Compute \sum of memories allowed CALL MPI_REDUCE( id%KEEP8(4), ITMP8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) ITMP8 = ITMP8 / 1000000_8 ! Use to print \sum_{ICNTL(23)} IF ( PROKG ) THEN NWORKING = id%NSLAVES CALL MUMPS_SETI8TOI4( id%KEEP8(129), TMP_INFOG_4) WRITE( MPG, 172 ) & NWORKING, id%ICNTL(22), KEEP_486_FOR_PRINT, & KEEP(489), & id%ICNTL(49), & id%KEEP(19), & KEEP(12), & id%KEEP8(111), TMP_INFOG_4, KEEP(127), KEEP(28), & id%KEEP8(4)/1000000_8, ITMP8, id%KEEP8(124), CNTL1 IF (KEEP(252).GT.0) & WRITE(MPG,173) KEEP(253) IF (KEEP(269).NE.0) & WRITE(MPG,174) KEEP(269) ENDIF IF (KEEP(201).LE.0) THEN C In-core version or no factors KEEP(IXSZ)=XSIZE_IC ELSE IF (KEEP(201).EQ.2) THEN C OOC version, no panels KEEP(IXSZ)=XSIZE_OOC_NOPANEL ELSE IF (KEEP(201).EQ.1) THEN C Panel versions: IF (KEEP(50).EQ.0) THEN KEEP(IXSZ)=XSIZE_OOC_UNSYM ELSE KEEP(IXSZ)=XSIZE_OOC_SYM ENDIF ENDIF IF ( KEEP(486) .NE. 0 ) THEN !LR is activated C Stats initialization for LR CALL INIT_STATS_GLOBAL() END IF C Memory management: allocate id%S etc. from C or Fortran? id%KEEP(430) = 0 #if defined(MUMPS_MALLOC_FROM_C) id%KEEP(430) = 1 #endif C * ********************************** * Begin intializations regarding the * computation of the determinant * ********************************** IF (id%MYID.EQ.MASTER) KEEP(258)=ICNTL(33) CALL MPI_BCAST(KEEP(258), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF (KEEP(258) .NE. 0) THEN KEEP(259) = 0 ! Initial exponent of the local determinant KEEP(260) = 1 ! Number of permutations id%DKEEP(6) = 1.0E0 ! real part of the local determinant id%DKEEP(7) = 0.0E0 ! imaginary part of the local determinant ENDIF * ******************************** * End intializations regarding the * computation of the determinant * ******************************** C CALL MUMPS_STOP_ON_USER_REQUEST(id%KEEP,id%KEEP8, id%ICNTL, & id%INFO, id%MYID) CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0) GOTO 530 * ********************** * Begin of Scaling phase * ********************** C C SCALING MANAGEMENT C * Options 1, 3, 4 centralized only C C * Options 7, 8 : also works for distributed matrix C C At this point, we have the scaling arrays allocated C on the master. They have been allocated on the master C inside the main MUMPS driver. C CALL MPI_BCAST(KEEP(52), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) LSCAL = ((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) IF (LSCAL) THEN C IF ( id%MYID.EQ.MASTER ) THEN CALL MUMPS_SECDEB(TIMEET) ENDIF C ----------------------- C Retrieve parameters for C simultaneous scaling C ----------------------- IF (KEEP(52) .EQ. 7) THEN C -- Cheap setting of SIMSCALING (it is the default in 4.8.4) K231= KEEP(231) K232= KEEP(232) K233= KEEP(233) ELSEIF (KEEP(52) .EQ. 8) THEN C -- More expensive setting of SIMSCALING (it was the default in 4.8.1,2,3) K231= KEEP(239) K232= KEEP(240) K233= KEEP(241) ENDIF CALL MPI_BCAST(id%DKEEP(3),1,MPI_REAL,MASTER, & id%COMM,IERR) C IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. & KEEP(54).NE.0 ) THEN C{ ------------------------------ C Scaling for distributed matrix C We need to allocate scaling C arrays on all processors, not C only the master. C ------------------------------ IF ( id%MYID .NE. MASTER ) THEN IF ( associated(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=N ENDIF ALLOCATE( id%ROWSCA(N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=N ENDIF ENDIF M = N BUMAXMN=M IF(N > BUMAXMN) BUMAXMN = N LIWK = 4_8*int(BUMAXMN,8) ALLOCATE (IWK(LIWK), BURP(M), BUCP(N), & BURS(2* id%NPROCS), BUCS(2* id%NPROCS), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(LIWK+int(M,8)+int(N,8)+ & 4_8*int(id%NPROCS,8) , id%INFO(2)) ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C -- estimation of memory and construction of partvecs BUJOB = 1 C -- LWK not used LWK_REAL = 1_8 LWRKR_TH = 1_8 LWRKC_TH = 1_8 NOMP_MAX = 1 ALLOCATE(WK_REAL(LWK_REAL), & WRKR_TH(LWRKR_TH,NOMP_MAX), & WRKC_TH(LWRKC_TH,NOMP_MAX), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR( & LWK_REAL+ & LWRKR_TH*int(NOMP_MAX,8)+ & LWRKC_TH*int(NOMP_MAX,8), & id%INFO(2)) ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 CALL CMUMPS_SIMSCALEABS( & IRN_loc_PTR(1), JCN_loc_PTR(1), A_loc_PTR(1), & id%KEEP8(29), & M, N, id%NPROCS, id%MYID, id%COMM, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) IF(LIWK < BUINTSZ) THEN DEALLOCATE(IWK) LIWK = BUINTSZ ALLOCATE(IWK(LIWK), stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(LIWK,id%INFO(2)) ENDIF ENDIF DEALLOCATE(WK_REAL, WRKR_TH, WRKC_TH) LWK_REAL = BURESZ C C -- Set NOMP_MAX from KEEP(281) CALL CMUMPS_SET_NOMP_MAX(id%KEEP(281), id%KEEP(361), & N, NOMP_MAX) C IF (NOMP_MAX.LE.1) THEN C temp array per thread not used LWRKR_TH = 1 LWRKC_TH = 1 ELSE LWRKR_TH = N IF (id%KEEP(50).NE.0) THEN C WRKC_TH not used on symmetric matrices LWRKC_TH = 1 ELSE LWRKC_TH = N ENDIF ENDIF ALLOCATE(WK_REAL(LWK_REAL), & WRKR_TH(LWRKR_TH,max(NOMP_MAX,1)), & WRKC_TH(LWRKC_TH,max(NOMP_MAX,1)), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR( & LWK_REAL+ & LWRKR_TH*int(max(NOMP_MAX,1),8)+ & LWRKC_TH*int(max(NOMP_MAX,1),8), & id%INFO(2)) ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C -- estimation of memory and construction of partvecs BUJOB = 2 CALL CMUMPS_SIMSCALEABS( & IRN_loc_PTR(1), JCN_loc_PTR(1), A_loc_PTR(1), & id%KEEP8(29), & M, N, id%NPROCS, id%MYID, id%COMM, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) id%DKEEP(4) = SCONEERR id%DKEEP(5) = SCINFERR CXXXX DEALLOCATE(IWK, BURP,BUCP,BURS, BUCS) DEALLOCATE(WK_REAL, WRKR_TH, WRKC_TH) C} ELSE IF ( KEEP(54) .EQ. 0 ) THEN C{ ------------------ C Centralized matrix C ------------------ IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN C ------------------------------- C Create a communicator of size 1 C ------------------------------- IF (id%MYID.EQ.MASTER) THEN COLOUR = 0 ELSE COLOUR = MPI_UNDEFINED ENDIF CALL MPI_COMM_SPLIT( id%COMM, COLOUR, 0, & COMM_FOR_SCALING, IERR ) IF (id%MYID.EQ.MASTER) THEN M = N BUMAXMN=N IF(N > BUMAXMN) BUMAXMN = N LIWK = 1_8 ALLOCATE(IWK(LIWK), BURP(1), BUCP(1), & BURS(1), BUCS(1), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR( LIWK+4_8, id%INFO(2) ) GOTO 400 ENDIF LWK_REAL = int(M,8) + int(N,8) C C -- Set NOMP_MAX from KEEP(281) CALL CMUMPS_SET_NOMP_MAX(id%KEEP(281), id%KEEP(361), & N, NOMP_MAX) C IF (NOMP_MAX.LE.1) THEN C temp array per thread not used LWRKR_TH = 1 LWRKC_TH = 1 ELSE LWRKR_TH = N IF (id%KEEP(50).NE.0) THEN C WRKC_TH not used on symmetric matrices LWRKC_TH = 1 ELSE LWRKC_TH = N ENDIF ENDIF ALLOCATE(WK_REAL(LWK_REAL), & WRKR_TH(LWRKR_TH,max(NOMP_MAX,1)), & WRKC_TH(LWRKC_TH,max(NOMP_MAX,1)), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR( & LWK_REAL+ & LWRKR_TH*int(max(NOMP_MAX,1),8)+ & LWRKC_TH*int(max(NOMP_MAX,1),8), & id%INFO(2)) ENDIF CALL MPI_COMM_RANK(COMM_FOR_SCALING, SCMYID, IERR) CALL MPI_COMM_SIZE(COMM_FOR_SCALING, SCNPROCS, IERR) BUJOB = 1 CALL CMUMPS_SIMSCALEABS( & id%IRN(1), id%JCN(1), id%A(1), & id%KEEP8(28), & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) IF(LWK_REAL < BURESZ) THEN id%INFO(1) = -136 GOTO 400 ENDIF BUJOB = 2 CALL CMUMPS_SIMSCALEABS(id%IRN(1), & id%JCN(1), id%A(1), & id%KEEP8(28), & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) id%DKEEP(4) = SCONEERR id%DKEEP(5) = SCINFERR 400 CONTINUE IF (allocated(WK_REAL)) DEALLOCATE(WK_REAL) IF (allocated(WRKR_TH)) DEALLOCATE(WRKR_TH) IF (allocated(WRKC_TH)) DEALLOCATE(WRKC_TH) IF (allocated(IWK)) DEALLOCATE(IWK) IF (allocated(BURP)) DEALLOCATE(BURP) IF (allocated(BUCP)) DEALLOCATE(BUCP) IF (allocated(BURS)) DEALLOCATE(BURS) IF (allocated(BUCS)) DEALLOCATE(BUCS) ENDIF C Centralized matrix: make DKEEP(4:5) available to all processors CALL MPI_BCAST( id%DKEEP(4),2,MPI_REAL, & MASTER, id%COMM, IERR ) IF (id%MYID.EQ.MASTER) THEN C Communicator should only be C freed on the master process CALL MPI_COMM_FREE(COMM_FOR_SCALING, IERR) ENDIF CALL MUMPS_PROPINFO(ICNTL(1), id%INFO(1), & id%COMM, id%MYID) IF (id%INFO(1).LT.0) GOTO 517 ELSE IF (id%MYID.EQ.MASTER) THEN C ------------------- C Centralized scaling C ------------------- IF (KEEP(52).GT.0 .AND. KEEP(52).LE.6) THEN C --------------------- C Allocate temporary C workspace for scaling C --------------------- IF (KEEP(52) .eq. 1 ) THEN C No workspace indeed needed LWK = 1_8 LWK_REAL = 1_8 ELSE IF ( KEEP(52) .eq. 3 ) THEN LWK = 1_8 LWK_REAL = int(N,8) ELSE IF ( KEEP(52) .eq. 4 ) THEN C Options 3 or 4 LWK = 1_8 LWK_REAL = 2_8*int(N,8) END IF C Real workarray ALLOCATE( WK_REAL( LWK_REAL ), stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR( LWK_REAL, id%INFO(2) ) GOTO 137 END IF C Real/complex workarray ALLOCATE( WK( LWK ), stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) GOTO 137 END IF CALL CMUMPS_FAC_A(N, id%KEEP8(28), KEEP(52), id%A(1), & id%IRN(1), id%JCN(1), & id%COLSCA(1), id%ROWSCA(1), & WK, LWK, WK_REAL, LWK_REAL, ICNTL(1), id%INFO(1) ) DEALLOCATE( WK_REAL ) DEALLOCATE( WK ) ENDIF ENDIF C} ENDIF ! Scaling distributed matrices or centralized IF (KEEP(125).NE.0) THEN C ------------------------ C If we enable the scaling of the |A11 A12| block C we set to 1 the scaling corresponding to the Schur C complement matrix A22 C ------------------------ IF ((KEEP(60).GT.0) .and. (KEEP(116).GT.0)) THEN C Schur is active, reset Schur entries to ONE IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. & KEEP(54).NE.0 ) THEN C Scaling available on all procs DO I=1, N IF (id%SYM_PERM(I).GT.id%N-KEEP(116)) THEN id%COLSCA(I) = ONE id%ROWSCA(I) = ONE ENDIF ENDDO ELSE IF ( id%MYID .EQ. MASTER) THEN C Scaling available on master DO I=1, N IF (id%SYM_PERM(I).GT.id%N-KEEP(116)) THEN id%COLSCA(I) = ONE id%ROWSCA(I) = ONE ENDIF ENDDO ENDIF ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIMEET) id%DKEEP(92)=real(TIMEET) IF (PROKG) WRITE( MPG, 140 ) TIMEET C Print inf-norm after last KEEP(233) iterations of C scaling option KEEP(52)=7 or 8 (SimScale) C IF (PROKG.AND.(KEEP(52).EQ.7.OR.KEEP(52).EQ.8)) THEN IF (K233+K231+K232.GT.0) THEN IF (K232.GT.0) WRITE(MPG, 166) id%DKEEP(4) ENDIF ENDIF ENDIF ENDIF ! LSCAL C C scaling might also be provided by the user LSCAL = (LSCAL .OR. (KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) IF (LSCAL .AND. KEEP(258).NE.0 .AND. id%MYID .EQ. MASTER) THEN DO I = 1, id%N CALL CMUMPS_UPDATEDETER_SCALING(id%ROWSCA(I), & id%DKEEP(6), ! determinant & KEEP(259)) ! exponent of the determinant ENDDO IF (KEEP(50) .EQ. 0) THEN ! unsymmetric DO I = 1, id%N CALL CMUMPS_UPDATEDETER_SCALING(id%COLSCA(I), & id%DKEEP(6), ! determinant & KEEP(259)) ! exponent of the determinant ENDDO ELSE C ----------------------------------------- C In this case COLSCA = ROWSCA C Since determinant was initialized to 1, C compute square of the current determinant C rather than going through COLSCA. C ----------------------------------------- CALL CMUMPS_DETER_SQUARE(id%DKEEP(6), KEEP(259)) ENDIF C Now we should have taken the C inverse of the scaling vectors CALL CMUMPS_DETER_SCALING_INVERSE(id%DKEEP(6), KEEP(259)) ENDIF C C ******************** C End of Scaling phase C At this point: either (matrix is distributed and KEEP(52)=7 or 8) C in which case scaling arrays are allocated on all processors, C or scaling arrays are only on the host processor. C In case of distributed matrix input, we will free the scaling C arrays on procs with MYID .NE. 0 after the all-to-all distribution C of the original matrix. C ******************** C 137 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C systematically this array now than waiting for C the root node. We rely on the fact that it is C allocated or not during the solve phase so if C it was allocated in a 1st call to facto and not C in a second, we don't want the solve to think C it was allocated in the second call. IF (associated(idintr%roota%RHS_CNTR_MASTER_ROOT)) THEN DEALLOCATE (idintr%roota%RHS_CNTR_MASTER_ROOT) NULLIFY (idintr%roota%RHS_CNTR_MASTER_ROOT) ENDIF C Fwd in facto: check that id%NRHS has not changed IF ( id%MYID.EQ.MASTER.AND. KEEP(252).EQ.1 .AND. & id%NRHS .NE. id%KEEP(253) ) THEN C Error: NRHS should not have C changed since the analysis id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) ENDIF IF (id%KEEP(252) .EQ. 1) THEN IF ( id%MYID.NE.MASTER ) THEN id%KEEP(254) = N ! Leading dimension id%KEEP8(85) = int(N,8)*int(id%KEEP(253),8) ! Tot size ALLOCATE(RHS_MUMPS(id%KEEP8(85)),stat=IERR) IF (IERR > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(85), id%INFO(2)) IF (LPOK) & WRITE(LP,*) 'ERROR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. ELSE RHS_MUMPS_ALLOCATED = .TRUE. ENDIF ELSE C Case of non working master id%KEEP(254)=id%LRHS ! Leading dimension id%KEEP8(85)=int(id%LRHS,8)*int(id%KEEP(253)-1,8)+ & int(id%N,8) ! Tot size RHS_MUMPS=>id%RHS RHS_MUMPS_ALLOCATED = .FALSE. IF (LSCAL) THEN C Scale before broadcast: apply row C scaling (remark that we assume no C transpose). DO K=1, id%KEEP(253) DO I=1, N RHS_MUMPS( id%KEEP(254) * (K-1) + I ) & = RHS_MUMPS( id%KEEP(254) * (K-1) + I ) & * id%ROWSCA(I) ENDDO ENDDO ENDIF ENDIF ELSE id%KEEP8(85)=1_8 ALLOCATE(RHS_MUMPS(1),stat=IERR) IF (IERR > 0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF (LPOK) & WRITE(LP,*) 'ERREUR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. ELSE RHS_MUMPS_ALLOCATED = .TRUE. ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 516 IF (KEEP(252) .EQ. 1) THEN C C Broadcast the columns of the right-hand side C one by one. Leading dimension is keep(254)=N C on procs with MYID > 0 but may be larger on C the master processor. DO I= 1, id%KEEP(253) CALL MPI_BCAST(RHS_MUMPS((I-1)*id%KEEP(254)+1), N, & MPI_COMPLEX, MASTER,id%COMM,IERR) END DO ENDIF IF (id%MYID.EQ. MASTER) THEN C Copy the value of ICNTL(24) and make it C available on all working processors. KEEP(110)=id%ICNTL(24) C KEEP(110) defaults to 0 for out of range values IF (KEEP(110).NE.1) KEEP(110)=0 ENDIF CALL MPI_BCAST(KEEP(110), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) C ----------------------------------------------- C Depending on the option used for C -detecting null pivots (ICNTL(24)/KEEP(110)) C CNTL(3) is used to set DKEEP(1) C ( A row is considered as null if ||row|| < DKEEP(1) ) C CNTL(5) is then used to define if a large C value is set on the diagonal or if a 1 is set C and other values in the row are reset to zeros. C -rank revealing on the Schur (ICNTL(56)/KEEP(19)) C SEUIL* corresponds to the minimum required C absolute value of pivot. C SEUIL_LDLT_NIV2 is used only in the C case of SYM=2 within a niv2 node for which C we have only a partial view of the fully summed rows. IF (id%MYID .EQ. MASTER) CNTL3 = id%CNTL(3) CALL MPI_BCAST(CNTL3, 1, MPI_REAL, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) CNTL5 = id%CNTL(5) CALL MPI_BCAST(CNTL5, 1, MPI_REAL, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) CNTL6 = id%CNTL(6) CALL MPI_BCAST(CNTL6, 1, MPI_REAL, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) id%DKEEP(8) = id%CNTL(7) CALL MPI_BCAST(id%DKEEP(8), 1, MPI_REAL, & MASTER, id%COMM, IERR) id%DKEEP(11) = id%DKEEP(8)/id%KEEP(461) id%DKEEP(12) = id%DKEEP(8)/id%KEEP(462) IF (KEEP(486).EQ.0) id%DKEEP(8) = ZERO COMPUTE_ANORMINF = .FALSE. IF ( (KEEP(486) .NE. 0).AND. (id%DKEEP(8).LT.ZERO)) THEN COMPUTE_ANORMINF = .TRUE. ENDIF IF (KEEP(19).NE.0) THEN C Rank revealing factorisation COMPUTE_ANORMINF = .TRUE. ENDIF IF (KEEP(110).NE.0) THEN C Null pivot detection COMPUTE_ANORMINF = .TRUE. ENDIF IF (id%DKEEP(8).LT.ZERO) THEN C Experimental setting of CNTL(7) IF (COMPUTE_ANORMINF) THEN EFF_SIZE_SCHUR = 0 CALL CMUMPS_ANORMINF( id , ANORMINF, LSCAL, EFF_SIZE_SCHUR ) C If no schur ANORMINF fine for other cases id%DKEEP(8) = abs(id%DKEEP(8))*ANORMINF ELSE ANORMINF = ZERO id%DKEEP(8) = abs(id%DKEEP(8)) ENDIF C ANORMINF need be recomputed in case of schur IF ((KEEP(60).GT.0).AND.KEEP(116).GT.0) ANORMINF=ZERO ENDIF IF (PROKG) THEN IF ( (CNTL(7) < ZERO) .AND. COMPUTE_ANORMINF .AND. & (KEEP(486) .NE. 0) ) THEN C Warning : using negative values is an experimental and C non recommended setting. WRITE(MPG,'(/A,A/,A/,A,A)') & ' WARNING in BLR input setting: ', & ' CNTL(7) < 0 is experimental: ', & ' Effective BLR threshold = |CNTL(7| x ||A_pre||, ', & ' where A_pre is the preprocessed matrix as defined', & ' in the users guide ' WRITE(MPG,'(A,3D16.4/)') & ' Effective BLR threshold, CNTL(7), ||A_pre|| = ', & id%DKEEP(8), CNTL(7), ANORMINF ENDIF ENDIF C ------------------------------------------------------- C We compute ANORMINF, when needed, based on C the infinite norm of Rowsca *A*Colsca C and make it available on all working processes. IF (COMPUTE_ANORMINF) THEN EFF_SIZE_SCHUR = 0 IF (KEEP(60).GT.0) EFF_SIZE_SCHUR = KEEP(116) CALL CMUMPS_ANORMINF( id , ANORMINF, LSCAL, EFF_SIZE_SCHUR ) ELSE ANORMINF = ZERO ENDIF C IF ((KEEP(19).NE.0).OR.(KEEP(110).NE.0)) THEN IF (PROKG) THEN IF (KEEP(19).NE.0) THEN WRITE(MPG,'(A,1PD16.4)') & ' CNTL(3) for null pivot rows/singularities =',CNTL3 ELSE WRITE(MPG,'(A,1PD16.4)') & ' CNTL(3) for null pivot row detection =',CNTL3 ENDIF ENDIF ENDIF IF (KEEP(19).EQ.0) THEN C{ -- RR is off SEUIL = ZERO id%DKEEP(9) = ZERO C} ELSE C{ -- RR is on C C CNTL(3) is the threshold used in the following to compute C DKEEP(9) the threshold under which the sing val. are considered C as null and from which we start to look for a gap between two C sing val. IF (CNTL3 .LT. ZERO) THEN id%DKEEP(9) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(9) = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN CALL MUMPS_NPIV_CRITICAL_PATH( & N, KEEP(28), id%STEP(1), id%FRERE_STEPS(1), id%FILS(1), & id%NA(1), id%LNA, id%NE_STEPS(1), KEEP(127), & NPIV_CRITICAL_PATH ) id%DKEEP(9) = sqrt(REAL(NPIV_CRITICAL_PATH))*EPS*ANORMINF ENDIF IF (PROKG) THEN WRITE(MPG, '(A,I16)') & ' ICNTL(56) rank revealing effective value =',KEEP(19) WRITE(MPG,'(A,1PD16.4)') & ' ...Threshold for singularities on the root =',id%DKEEP(9) ENDIF C RR postponing considers that pivot rows with norm smaller C than SEUIL should be postponed. C SEUIL should be bigger than DKEEP(9), this means that C DKEEP(13) should be bigger than 1. Thresh_Seuil = id%DKEEP(13) IF (id%DKEEP(13).LT.1) Thresh_Seuil = 10 SEUIL = id%DKEEP(9)*Thresh_Seuil IF (PROKG) WRITE(MPG,'(A,1PD16.4)') & ' ...Threshold for postponing =',SEUIL C} ENDIF !end KEEP(19).ne.0 SEUIL_LDLT_NIV2 = SEUIL C ------------------------------- C -- Null pivot row detection C ------------------------------- IF (KEEP(110).EQ.0) THEN C{ -- Null pivot is off C Initialize DKEEP(1) to a negative value C in order to avoid detection of null pivots C (test max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL C in CMUMPS_FAC_I, where PIVNUL=DKEEP(1)) id%DKEEP(1) = -1.0E0 id%DKEEP(2) = ZERO C} ELSE C{ -- Null pivot detection is on IF (KEEP(19).NE.0) THEN C{ -- RR is on C RR postponing considers that pivot rows of norm smaller that SEUIL C should be postponed, but pivot rows smaller than DKEEP(1) are C directly added to null space and thus considered as null pivot rows. IF ((id%DKEEP(10).LE.0).OR.(id%DKEEP(10).GT.1)) THEN C DKEEP(10) is out of range, set to the default value 10-1 id%DKEEP(1) = id%DKEEP(9)*1E-1 ELSE id%DKEEP(1) = id%DKEEP(9)*id%DKEEP(10) ENDIF C} ELSE C{ -- RR is off C -- only Null pivot detection C We keep strategy currently used in MUMPS 4.10.0 IF (CNTL3 .LT. ZERO) THEN id%DKEEP(1) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(1) = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN c id%DKEEP(1) = NPIV_CRITICAL_PATH*EPS*ANORMINF CALL MUMPS_NPIV_CRITICAL_PATH( & N, KEEP(28), id%STEP(1), id%FRERE_STEPS(1), id%FILS(1), & id%NA(1), id%LNA, id%NE_STEPS(1), KEEP(127), & NPIV_CRITICAL_PATH ) id%DKEEP(1) = sqrt(REAL(NPIV_CRITICAL_PATH))*EPS*ANORMINF ENDIF C} ENDIF ! fin rank revealing IF ((KEEP(110).NE.0).AND.(PROKG)) THEN WRITE(MPG, '(A,I16)') & ' ICNTL(24) null pivot rows detection =',KEEP(110) WRITE(MPG,'(A,1PD16.4)') & ' ...Zero pivot detection threshold =',id%DKEEP(1) ENDIF IF (CNTL5.GT.ZERO) THEN id%DKEEP(2) = CNTL5 * ANORMINF IF (PROKG) WRITE(MPG,'(A,1PD16.4)') & ' ...Fixation for null pivots =',id%DKEEP(2) ELSE IF (PROKG) WRITE(MPG,*) '...Infinite fixation ' IF (id%KEEP(50).EQ.0) THEN C Unsym ! the user let us choose a fixation. set in NEGATIVE ! to detect during facto when to set row to zero ! id%DKEEP(2) = -max(1.0E10*ANORMINF, & sqrt(huge(ANORMINF))/1.0E8) ELSE C Sym id%DKEEP(2) = ZERO ENDIF ENDIF C} ENDIF ! fin null pivot detection. C Find id of root node if RR is on IF (KEEP(19).NE.0) THEN ID_ROOT =MUMPS_PROCNODE(id%PROCNODE_STEPS(id%STEP(KEEP(20))), & id%KEEP(199)) IF ( KEEP( 46 ) .NE. 1 ) THEN ID_ROOT = ID_ROOT + 1 END IF ENDIF IF (KEEP(19).EQ.0.AND.KEEP(53).NE.0) THEN C ICNTL(56)>0 at analysis and =0 at facto C save special root index KEEP20_SAVE = KEEP(20) C suppress special RR treatment KEEP(20) = 0 ENDIF C Second pass: set parameters for null pivot detection C Allocate PIVNUL_LIST_STRUCT in case of null pivot detection C and in case of rank revealing KEEP(109) = 0 LPN_LIST = 0 IF(KEEP(110) .EQ. 1) THEN LPN_LIST = 100 ENDIF IF (KEEP(19).NE.0 .AND. & (ID_ROOT.EQ.id%MYID .OR. id%MYID.EQ.MASTER)) THEN LPN_LIST = 100 ENDIF IF (LPN_LIST.GT.0) THEN PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST = LPN_LIST ALLOCATE( PIVNUL_LIST_STRUCT%PIVNUL_LIST(LPN_LIST),stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=LPN_LIST END IF PIVNUL_LIST_STRUCT%PIVNUL_LIST(1:LPN_LIST) = 0 ENDIF C end set parameter for null pivot detection CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 516 C -------------------------------------------------------------- C STATIC PIVOTING C -- Static pivoting only when RR and Null pivot detection OFF C -------------------------------------------------------------- KEEP(97) = 0 IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (id%MYID .EQ. MASTER) CNTL4 = id%CNTL(4) CALL MPI_BCAST( CNTL4, 1, MPI_REAL, & MASTER, id%COMM, IERR ) C IF ( CNTL4 .GE. ZERO ) THEN KEEP(97) = 1 IF ( CNTL4 .EQ. ZERO ) THEN C -- set seuil to sqrt(eps)*||A|| IF(ANORMINF .EQ. ZERO) THEN EFF_SIZE_SCHUR = 0 IF (KEEP(60).GT.0) EFF_SIZE_SCHUR = KEEP(116) CALL CMUMPS_ANORMINF( id , ANORMINF, LSCAL, & EFF_SIZE_SCHUR ) ENDIF SEUIL = sqrt(EPS) * ANORMINF ELSE SEUIL = CNTL4 ENDIF SEUIL_LDLT_NIV2 = SEUIL ELSE SEUIL = ZERO ENDIF ENDIF C set number of tiny pivots / 2x2 pivots in types 1 / C 2x2 pivots in types 2, to zero. This is because the C user can call the factorization step several times. KEEP(98) = 0 KEEP(103) = 0 KEEP(105) = 0 MAXS = 1_8 * * Start allocations * ***************** * C C The slaves can now perform the factorization C C C or point to user provided data WK_USER when LWK_USER>0 C ======================= C C Compute BLR_STRAT and a first estimation C of MAXS, the size of id%S CALL CMUMPS_SET_BLRSTRAT_AND_MAXS_K8 ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & id%KEEP(1), id%KEEP8(1)) C MAXS = MAXS_BASE_RELAXED8 IF (WK_USER_PROVIDED) THEN C -- Set MAXS to size of WK_USER_ MAXS = id%KEEP8(24) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 516 ENDIF C id%KEEP8(75) = huge(id%KEEP8(75)) id%KEEP8(76) = huge(id%KEEP8(76)) IF (I_AM_SLAVE) THEN C IF (id%KEEP8(4) .NE. 0_8) THEN C IF ( .NOT. WK_USER_PROVIDED ) THEN C Set MAXS given BLR_STRAT, KEEP(201) and MAXS_BASE_RELAXED8 CALL CMUMPS_MEM_ALLOWED_SET_MAXS ( & MAXS, & BLR_STRAT, id%KEEP(201), MAXS_BASE_RELAXED8, & id%KEEP(1), id%KEEP8(1), id%MYID, id%N, id%NELT, & id%NA(1), id%LNA, id%NSLAVES, & KEEP464COPY, KEEP465COPY, & id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) C Given MAXS and max memory allowed KEEP8(4) C compute in KEEP8(75) the number of real/complex C available for dynamic allocations CALL CMUMPS_MEM_ALLOWED_SET_K75 ( & MAXS, id%MYID, & .FALSE., ! UNDER_L0_OMP & N, id%NELT, id%NA(1), id%LNA, id%NSLAVES, & BLR_STRAT, id%KEEP(201), & id%KEEP, id%KEEP8, id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) ELSE C KEEP8(75) dow not include MAXS, since WK_USER is provided CALL CMUMPS_MEM_ALLOWED_SET_K75 ( & 0_8, id%MYID, & .FALSE., ! UNDER_L0_OMP & N, id%NELT, id%NA(1), id%LNA, id%NSLAVES, & BLR_STRAT, id%KEEP(201), & id%KEEP, id%KEEP8, id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) ENDIF IF (KEEP(400) .GT.0) THEN C ------------------------------ C compute KEEP8(75) under L0_OMP C ------------------------------ C Save KEEP8(75) above L0_OMP to reset KEEP8(75) C when starting FAC_PAR_M id%KEEP8(76) = id%KEEP8(75) CALL CMUMPS_MEM_ALLOWED_SET_K75 ( & 0_8, ! MAXS=0_8 & id%MYID, & .TRUE., ! UNDER_L0_OMP & id%N, id%NELT, id%NA(1), id%LNA, id%NSLAVES, & BLR_STRAT, id%KEEP(201), & id%KEEP, id%KEEP8, id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) C KEEP8(75) holds the number of entries that C can be allocated underL0. C It will be used during CMUMPS_FAC_L0_OMP to adjust the C the size of MUMPS_TPS_ARR(ITH)%LA ENDIF ENDIF ! MEM_ALLOWED C ENDIF ! I_AM_SLAVE THEN C IF (I_AM_SLAVE) THEN IF ( (KEEP(400).GT.0) .AND. (KEEP(406).EQ.2) ) THEN C Compute KEEP8(77) the peak authorized used by C CMUMPS_PERFORM_COPIES CALL CMUMPS_L0_COMPUTE_PEAK_ALLOWED( & id%MYID, id%N, & id%NELT, id%NA(1), id%LNA, id%NSLAVES, & BLR_STRAT, id%KEEP(201), & id%KEEP(1), id%KEEP8(1), id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) ENDIF ENDIF ! I_AM_SLAVE) C CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 516 ENDIF CALL MUMPS_SETI8TOI4(MAXS, id%INFO(39)) CALL CMUMPS_AVGMAX_STAT8(PROKG, MPG, MAXS, id%NSLAVES, & PRINT_MAXAVG, & id%COMM, " Effective size of S (based on INFO(39))= ") C IF ( I_AM_SLAVE ) THEN C ---------------------------------------- C Initialize some global variables related C to communication buffer management C ---------------------------------------- CALL MUMPS_BUF_INI_MYID(id%MYID_NODES) CALL MUMPS_BUF_INIT( id%KEEP( 34 ), id%KEEP(35) ) C ------------------ C Dynamic scheduling C ------------------ CALL MUMPS_LOAD_SET_INICOST( dble(id%COST_SUBTREES), & KEEP(64), dble(id%DKEEP(15)), KEEP(375), MAXS ) MEMORY_MD_ARG = min(int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8 ), C Restrict freedom from dynamic scheduler when C MEM_ALLOWED=ICNTL(23) is small (case where KEEP8(4)-MAXS_BASE8 C is negative after call to CMUMPS_MAX_MEM) & max(0_8, MAXS-MAXS_BASE8)) CALL MUMPS_LOAD_INIT( MEMORY_MD_ARG, MAXS, id%KEEP, & id%KEEP8, id%INFO, id%ISTEP_TO_INIV2, id%CANDIDATES, id%ND_STEPS, & id%FILS, id%FRERE_STEPS, id%DAD_STEPS, id%PROCNODE_STEPS, & id%STEP, id%NE_STEPS, id%N, id%MAX_SURF_MASTER, id%SUP_PROC, & id%COMM_LOAD, id%COMM_NODES, & id%DEPTH_FIRST, id%COST_TRAV, id%DEPTH_FIRST_SEQ, id%SBTR_ID, & id%NA, id%NSLAVES, id%FUTURE_NIV2, & id%NBSA, id%NBSA_LOCAL, id%MEM_SUBTREE, id%MY_FIRST_LEAF, & id%MY_NB_LEAF, id%MY_ROOT_SBTR ) IF (KEEP(201) .GT. 0) THEN C ------------------- C OOC initializations C ------------------- IF (KEEP(201).EQ.1 !PANEL Version & .AND.KEEP(50).EQ.0 ! Unsymmetric & .AND.KEEP(251).NE.2 ! Store L to disk & ) THEN id%OOC_NB_FILE_TYPE=2 ! declared in MUMPS_OOC_COMMON ELSE id%OOC_NB_FILE_TYPE=1 ! declared in MUMPS_OOC_COMMON ENDIF C ------------------------------ C Dimension IO buffer, KEEP(100) C ------------------------------ IF (KEEP(205) .GT. 0) THEN KEEP(100) = KEEP(205) ELSE IF (KEEP(201).EQ.1) THEN ! PANEL version ITMP8 = int(id%OOC_NB_FILE_TYPE,8) * & 2_8 * int(KEEP(226),8) ELSE ITMP8 = 2_8 * id%KEEP8(119) ENDIF ITMP8 = ITMP8 + int(max(KEEP(12),0),8) * & (ITMP8/100_8+1_8) C we want to avoid too large IO buffers. C 12M corresponds to 100Mbytes given to buffers. ITMP8 = min(ITMP8, 12000000_8) KEEP(100)=int(ITMP8) ENDIF IF (KEEP(201).EQ.1) THEN C Panel version. Force the use of a buffer. IF ( KEEP(99) < 3 ) THEN KEEP(99) = KEEP(99) + 3 ENDIF ENDIF C -------------------------- C Reset KEEP(100) to 0 if no C buffer is used for OOC. C -------------------------- IF (KEEP(99) .LT.3) KEEP(100)=0 IF((dble(KEEP(100))*dble(KEEP(35))/dble(2)).GT. & (dble(1999999999)))THEN IF (PROKG) THEN WRITE(MPG,*)id%MYID,': Warning: DIM_BUF_IO might be & too big for Filesystem' ENDIF ENDIF ALLOCATE (id%OOC_INODE_SEQUENCE(KEEP(28), & id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_INODE_SEQUENCE) GOTO 112 ENDIF ALLOCATE (id%OOC_TOTAL_NB_NODES(id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE NULLIFY(id%OOC_TOTAL_NB_NODES) GOTO 112 ENDIF ALLOCATE (id%OOC_SIZE_OF_BLOCK(KEEP(28), & id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_SIZE_OF_BLOCK) GOTO 112 ENDIF ALLOCATE (id%OOC_VADDR(KEEP(28),id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_VADDR) GOTO 112 ENDIF ENDIF ENDIF 112 CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) < 0) THEN C LOAD_END must be done but not OOC_END_FACTO GOTO 513 ENDIF IF (I_AM_SLAVE) THEN IF (KEEP(201) .GT. 0) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL CMUMPS_OOC_INIT_FACTO(id%ICNTL(1), id%ICNTL(4), id%N, & id%NSLAVES, id%MYID, MAXS, id%OOC_NB_FILE_TYPE, & id%KEEP, id%KEEP8, id%STEP, id%PROCNODE, & id%OOC_SIZE_OF_BLOCK, id%OOC_VADDR, id%INFO, & id%OOC_TMPDIR, id%OOC_PREFIX, id%OOC_NB_FILES, & id%OOC_INODE_SEQUENCE) ELSE WRITE(*,*) "Internal error in CMUMPS_FAC_DRIVER" CALL MUMPS_ABORT() ENDIF IF(id%INFO(1).LT.0)THEN GOTO 111 ENDIF ENDIF C First increment corresponds to the number of C floating-point operations for subtrees allocated C to the local processor. CALL MUMPS_LOAD_UPDATE(0,.FALSE.,dble(id%COST_SUBTREES), & id%KEEP(1),id%KEEP8(1)) IF (id%INFO(1).LT.0) GOTO 111 END IF C ----------------------- C Manage main workarray S C ----------------------- EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) #if defined (LARGEMATRICES) IF ( id%MYID .ne. MASTER ) THEN #endif IF (.NOT.WK_USER_PROVIDED) THEN IF ( EARLYT3ROOTINS ) THEN C Standard allocation strategy CALL CMUMPS_DM_ALLOC_S_WK(id%S, MAXS, IERR, & KEEP(430), KEEP(35)) id%KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(MAXS, id%INFO(2)) C On some platforms (IBM for example), an C allocation failure returns a non-null pointer. C Therefore we nullify S NULLIFY(id%S) id%KEEP8(23)=0_8 ENDIF ENDIF ELSE id%S => id%WK_USER(1:id%KEEP8(24)) id%KEEP8(23) = 0_8 ENDIF #if defined (LARGEMATRICES) END IF #endif C 111 CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 514 C -------------------------- C Initialization of modules C related to data management C -------------------------- NB_ACTIVE_FRONTS_ESTIM = 3 NB_THREADS = 1 !$ NB_THREADS = OMP_GET_MAX_THREADS() C NB_ACTIVE_FRONTS_ESTIM = 3*NB_THREADS IF (I_AM_SLAVE) THEN C CALL MUMPS_FDM_INIT('A',NB_ACTIVE_FRONTS_ESTIM, id%INFO) C IF ( (KEEP(486).EQ.2) & .OR. ((KEEP(489).NE.0).AND.(KEEP(400).GT.1)) & ) THEN C In case of LRSOLVE or CompressCB, C initialize nb of handlers to nb of BLR C nodes estimated at analysis NB_FRONTS_F_ESTIM = KEEP(470) ELSE IF (KEEP(489).NE.0) THEN C Compress CB and no L0 OMP (or 1 thread under L0): C NB_ACTIVE_FRONTS_ESTIM is too small, C to limit nb of reallocations make it twice larger NB_FRONTS_F_ESTIM = 2*NB_ACTIVE_FRONTS_ESTIM ELSE NB_FRONTS_F_ESTIM = NB_ACTIVE_FRONTS_ESTIM ENDIF ENDIF CALL MUMPS_FDM_INIT('F',NB_FRONTS_F_ESTIM, id%INFO ) IF (id%INFO(1) .LT. 0 ) GOTO 114 #if ! defined(NO_FDM_DESCBAND) C Storage of DESCBAND information CALL MUMPS_FDBD_INIT( NB_ACTIVE_FRONTS_ESTIM, id%INFO ) #endif #if ! defined(NO_FDM_MAPROW) C Storage of MAPROW and ROOT2SON information CALL MUMPS_FMRD_INIT( NB_ACTIVE_FRONTS_ESTIM, id%INFO ) #endif CALL CMUMPS_BLR_INIT_MODULE( NB_FRONTS_F_ESTIM, id%INFO & ) 114 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C GOTO 500: one of the above module initializations failed IF ( id%INFO(1).LT.0 ) GOTO 500 C C C Allocate space for matrix in arrowhead form C =========================================== C C CASE 1 : Matrix is assembled C CASE 2 : Matrix is elemental C IF ( KEEP(55) .eq. 0 ) THEN C ------------------------------------ C Space has been allocated already for C the integer part during analysis C Only slaves need the arrowheads. C ------------------------------------ IF ( I_AM_SLAVE .and. id%KEEP8(26) .ne. 0_8 ) THEN ALLOCATE( DBLARR( id%KEEP8(26) ), & INTARR( id%KEEP8(27) ), stat = IERR ) ELSE ALLOCATE( DBLARR( 1 ), & INTARR( 1 ), stat =IERR ) END IF IF ( IERR .NE. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for DBLARR(',id%KEEP8(26),')+INTARR(', & id%KEEP8(27),')' ENDIF id%INFO(1)=-13 CALL MUMPS_SET_IERROR( max(id%KEEP8(26),1_8)+ & max(id%KEEP8(27),1_8), & id%INFO(2) ) GOTO 100 END IF DBLARR_ALLOCATED = .TRUE. ELSE C -------------------------------- C Allocate element variables lists C -------------------------------- IF ( I_AM_SLAVE .and. id%KEEP8(27) .ne. 0_8 ) THEN ALLOCATE( INTARR( id%KEEP8(27) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(id%KEEP8(27), id%INFO(2)) GOTO 100 END IF ELSE C INTARR also allocated of size 1 on non-working master ALLOCATE( INTARR(1),stat=allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 GOTO 100 END IF END IF C --------------------------------------- C Allocate DBLARR to hold possibly scaled C copies of elemental matrices C On a working master (hybrid host) and C no scaling, avoid the copy and point C directly to user data instead. C --------------------------------------- IF ( I_AM_SLAVE ) THEN IF ( id%MYID_NODES .eq. MASTER & .AND. KEEP(46) .eq. 1 & .AND. KEEP(52) .eq. 0 ) THEN C ------------------- C Pointer association C ------------------- DBLARR => id%A_ELT ELSE C ---------- C Allocation C ---------- ALLOCATE( DBLARR( max(id%KEEP8(26),1_8) ), stat=allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(max(id%KEEP8(26),1_8), id%INFO(2)) NULLIFY(DBLARR) GOTO 100 END IF DBLARR_ALLOCATED = .TRUE. END IF ELSE ALLOCATE( DBLARR(1), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(DBLARR) GOTO 100 END IF DBLARR_ALLOCATED = .TRUE. END IF END IF 100 CONTINUE C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C ------------------------------------------ C Prepare stuff for the 2D block-cyclic root C ------------------------------------------ IF ( KEEP(38).NE.0 ) THEN ALLOCATE(idintr%root%RG2L(id%N), stat=allocok) IF ( allocok .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N END IF IF ( id%INFO(1) .GE.0 ) THEN CALL CMUMPS_INIT_ROOT_FAC( id%N, id%MYID, & idintr%root, id%FILS(1), id%KEEP(1) ) ENDIF ENDIF C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C C ----------------------------------- C C DISTRIBUTION OF THE ORIGINAL MATRIX C C ----------------------------------- C C TIMINGS: computed (and printed) on the host C Next line: global time for distrib(arrowheads,elts) C on the host. Synchronization has been performed. IF (id%MYID.EQ.MASTER) CALL MUMPS_SECDEB(TIME) C ------------------------------------------- C S_PTR_ARG / MAXS_ARG will be used for id%S C argument to arrowhead/element distribution C routines: if id%S is not allocated, we pass C S_DUMMY_ARG instead, which is not accessed. C ------------------------------------------- IF (EARLYT3ROOTINS) THEN S_PTR_ARG => id%S MAXS_ARG = MAXS ELSE S_PTR_ARG => S_DUMMY_ARG MAXS_ARG = 1 ENDIF C IF ( KEEP( 55 ) .eq. 0 ) THEN C { C ---------------------------- C Original matrix is assembled C Arrowhead format to be used. C ---------------------------- C KEEP8(26) and KEEP8(27) hold the number of entries for real/integer C for the matrix in arrowhead format. They have been set by the C analysis phase (CMUMPS_ANA_F and CMUMPS_ANA_G) C C ------------------------------------------------------------------ C Blocking is used for sending arrowhead records (I,J,VAL) C buffer(1) is used to store number of bytes already packed C buffer(2) number of records already packed C KEEP(39) : Number of records (blocking factor) C ------------------------------------------------------------------ C C --------------------------------------------- C In case of parallel root compute minimum C size of workspace to receive arrowheads C of root node. Will be used to check that C MAXS is large enough for arrowheads (case C of EARLYT3ROOTINS (KEEP(200)=0); if .NOT. C EARLYT3ROOTINS (KEEP(200)=1), root will C be assembled into id%S later and size of C id%S will be checked later) C --------------------------------------------- IF (EARLYT3ROOTINS .AND. KEEP(38).NE.0 .AND. & KEEP(60) .EQ.0 .AND. I_AM_SLAVE) THEN LWK = int(MUMPS_NUMROC( idintr%root%ROOT_SIZE, & idintr%root%MBLOCK, & idintr%root%MYROW, 0, idintr%root%NPROW ),8) LWK = max( 1_8, LWK ) LWK = LWK* & int(MUMPS_NUMROC( idintr%root%ROOT_SIZE, & idintr%root%NBLOCK, & idintr%root%MYCOL, 0, idintr%root%NPCOL ),8) LWK = max( 1_8, LWK ) ELSE LWK = 1_8 ENDIF C MAXS must be at least 1, and in case of C parallel root, large enough to receive C arrowheads of root. IF (MAXS .LT. int(LWK,8)) THEN id%INFO(1) = -9 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C C ===================================================== IF (KEEP(399).GE.2) THEN C{ Multihtreaded algorithm taking into account all cases C ===================================================== C C Timing on master. IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIME) END IF C NZ_loc8 = 0_8 NBRECORDS = KEEP(39) SIZESCAL = id%N C Set NZ_loc8, A_loc_PTR, IRN_loc_PTR, JCN_loc_PTR C and update NBRECORDS IF (KEEP(54).EQ.0) THEN C centralized matrix IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF IF (id%MYID.EQ.MASTER) THEN NZ_loc8 = id%KEEP8(28) A_loc_PTR => id%A IRN_loc_PTR => id%IRN JCN_loc_PTR => id%JCN IF (LSCAL) THEN COLSCA_PTR => id%COLSCA ROWSCA_PTR => id%ROWSCA ELSE COLSCA_PTR => DUMMYSCA ROWSCA_PTR => DUMMYSCA SIZESCAL = 1 ENDIF ELSE A_loc_PTR => DUMMYA_loc IRN_loc_PTR => DUMMYIRN_loc JCN_loc_PTR => DUMMYJCN_loc COLSCA_PTR => DUMMYSCA ROWSCA_PTR => DUMMYSCA SIZESCAL = 1 ENDIF ELSE C distributed matrix C --------------------------------------------------- C In order to have possibly IRN_loc/JCN_loc/A_loc C of size 0, avoid to pass them inside REDISTRIBUTION C and pass id instead C NZ_locMAX8 gives as a maximum buffer size (send/recv) used C an upper bound to limit buffers on small matrices C --------------------------------------------------- CALL MPI_ALLREDUCE(id%KEEP8(29), NZ_locMAX8, 1, & MPI_INTEGER8, MPI_MAX, id%COMM, IERR) IF (NZ_locMAX8 .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(NZ_locMAX8) ENDIF NZ_loc8 = id%KEEP8(29) LSCAL = (KEEP(52).EQ.7).OR.(KEEP(52).EQ.8) C available on all MPI IF (LSCAL) THEN COLSCA_PTR => id%COLSCA ROWSCA_PTR => id%ROWSCA ELSE COLSCA_PTR => DUMMYSCA ROWSCA_PTR => DUMMYSCA SIZESCAL = 1 ENDIF ENDIF #if ! defined(PCPRET) IF (id%KEEP(72).EQ.1) THEN NBRECORDS = max(3,NBRECORDS/10) ENDIF CALL CMUMPS_FAC_DIST_ARROWHEADS_OMP ( id%N, & NZ_loc8, C replace id by: & A_loc_PTR(1), IRN_loc_PTR(1), JCN_loc_PTR(1), & SIZESCAL, LSCAL, COLSCA_PTR(1), ROWSCA_PTR(1), & DBLARR(1), id%KEEP8(26), INTARR(1), & id%KEEP8(27), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & id%FILS(1), & KEEP(1), id%KEEP8(1), id%MYID, id%COMM, NBRECORDS, & S_PTR_ARG(1), MAXS_ARG, idintr%root, idintr%roota, & id%PROCNODE_STEPS(1), & id%NPROCS, id%NSLAVES, id%SYM_PERM(1), id%STEP(1), & id%ICNTL(1), id%INFO(1), NSEND8, NLOCAL8, & id%ISTEP_TO_INIV2(1), & id%CANDIDATES(1,1) & ) CALL MPI_BARRIER(id%COMM, IERR) #else #endif C IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN C ------------------------------ C The host is not working -> had C no data from initial matrix C ------------------------------ NSEND8 = 0_8 NLOCAL8 = 0_8 END IF C ------------------------- C Check for possible errors C ------------------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 CALL MPI_REDUCE( NSEND8, NSEND_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( NLOCAL8, NLOCAL_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN WRITE(MPG,125) NLOCAL_TOT8, NSEND_TOT8 END IF C} ELSE C{ ======================================================= IF ( KEEP(54) .eq. 0 ) THEN C { C ================================================ C FIRST CASE : MATRIX IS NOT INITIALLY DISTRIBUTED C ================================================ C A small integer workspace is needed to C send the arrowheads. IF ( id%MYID .eq. MASTER ) THEN #if defined(LARGEMATRICES) ALLOCATE (WK(LWK),stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) write(6,*) ' PB1 ALLOC LARGEMAT' ENDIF #endif ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 IF ( id%MYID .eq. MASTER ) THEN C C -------------------------------- C MASTER sends arowheads using the C global communicator with ranks C also in global communicator C IWK is used as temporary C workspace of size N. C -------------------------------- NBRECORDS = KEEP(39) IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF #if defined(LARGEMATRICES) CALL CMUMPS_FACTO_SEND_ARROWHEADS(id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), id%SYM_PERM(1), & LSCAL, id%COLSCA(1), id%ROWSCA(1), & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), & NBRECORDS, & id%COMM, idintr%root, idintr%roota, KEEP,id%KEEP8, & id%FILS(1), & & INTARR(1), id%KEEP8(27), DBLARR(1), id%KEEP8(26), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & id%FRERE_STEPS(1), id%STEP(1), WK(1), LWK, & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & id%CANDIDATES(1,1), id%ICNTL(1), id%INFO(1) ) C write(6,*) '!!! A,IRN,JCN are freed during factorization ' DEALLOCATE (id%A) NULLIFY(id%A) DEALLOCATE (id%IRN) NULLIFY (id%IRN) DEALLOCATE (id%JCN) NULLIFY (id%JCN) IF (.NOT.WK_USER_PROVIDED) THEN IF (EARLYT3ROOTINS) THEN CALL CMUMPS_ALLOC_S_WORKSPACE(id%S, MAXS, IERR, & KEEP(430), KEEP(35)) id%KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXS NULLIFY(id%S) id%KEEP8(23)=0_8 write(6,*) ' PB2 ALLOC LARGEMAT',MAXS CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ELSE id%S => id%WK_USER(1:id%KEEP8(24)) ENDIF IF (EARLYT3ROOTINS) THEN id%S(MAXS-LWK+1_8:MAXS) = WK(1_8:LWK) ENDIF DEALLOCATE (WK) #else CALL CMUMPS_FACTO_SEND_ARROWHEADS(id%N, id%KEEP8(28), & id%A(1), id%IRN(1), id%JCN(1), id%SYM_PERM(1), & LSCAL, id%COLSCA(1), id%ROWSCA(1), & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), & NBRECORDS, & id%COMM, idintr%root, idintr%roota, KEEP(1),id%KEEP8(1), & id%FILS(1), & & INTARR(1), id%KEEP8(27), DBLARR(1), id%KEEP8(26), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & id%FRERE_STEPS(1), id%STEP(1), S_PTR_ARG(1), MAXS_ARG, & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & id%CANDIDATES(1,1), id%ICNTL(1), id%INFO(1) ) #endif ELSE NBRECORDS = KEEP(39) IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF CALL CMUMPS_FACTO_RECV_ARROWHD2( id%N, & DBLARR(1), id%KEEP8(26), & INTARR(1), id%KEEP8(27), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & KEEP( 1 ), id%KEEP8(1), id%FILS(1), id%MYID, id%COMM, & NBRECORDS, & & S_PTR_ARG(1), MAXS_ARG, & idintr%root, idintr%roota, & id%PROCNODE_STEPS(1), id%NSLAVES, & id%SYM_PERM(1), id%FRERE_STEPS(1), id%STEP(1), & id%ICNTL(1), id%INFO(1) ) ENDIF C } ELSE C { C ============================================= C SECOND CASE : MATRIX IS INITIALLY DISTRIBUTED C ============================================= C Timing on master. IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIME) END IF IF ( I_AM_SLAVE ) THEN C { C --------------------------------------------------- C In order to have possibly IRN_loc/JCN_loc/A_loc C of size 0, avoid to pass them inside REDISTRIBUTION C and pass id instead C NZ_locMAX8 gives as a maximum buffer size (send/recv) used C an upper bound to limit buffers on small matrices C --------------------------------------------------- CALL MPI_ALLREDUCE(id%KEEP8(29), NZ_locMAX8, 1, MPI_INTEGER8, & MPI_MAX, id%COMM_NODES, IERR) NBRECORDS = KEEP(39) IF (NZ_locMAX8 .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(NZ_locMAX8) ENDIF CALL CMUMPS_REDISTRIBUTION( id%N, & id%KEEP8(29), & id, & DBLARR(1), id%KEEP8(26), INTARR(1), & id%KEEP8(27), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & id%FILS(1), & KEEP(1), id%KEEP8(1), id%MYID_NODES, & id%COMM_NODES, NBRECORDS, & S_PTR_ARG(1), MAXS_ARG, idintr%root, idintr%roota, & id%PROCNODE_STEPS(1), & id%NSLAVES, id%SYM_PERM(1), id%STEP(1), & id%ICNTL(1), id%INFO(1), NSEND8, NLOCAL8, & id%ISTEP_TO_INIV2(1), & id%CANDIDATES(1,1) ) IF ( ( KEEP(52).EQ.7 ).OR. (KEEP(52).EQ.8) ) THEN C ------------------------------------------------- C In that case, scaling arrays have been allocated C on all processors. They were useful for matrix C distribution. But we now really only need them C on the host. In case of distributed solution, we C will have to broadcast either ROWSCA or COLSCA C (depending on MTYPE) but this is done later. C C In other words, on exit from the factorization, C we want to have scaling arrays available only C on the host. C ------------------------------------------------- IF ( id%MYID > 0 ) THEN IF (associated(id%ROWSCA)) THEN DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF IF (associated(id%COLSCA)) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ENDIF ENDIF ENDIF #if defined(LARGEMATRICES) C deallocate id%IRN_loc, id%JCN(loc) to free extra space C Note that in this case IRN_loc cannot be used C anymore during the solve phase for IR and Error analysis. IF (associated(id%IRN_loc)) THEN DEALLOCATE(id%IRN_loc) NULLIFY(id%IRN_loc) ENDIF IF (associated(id%JCN_loc)) THEN DEALLOCATE(id%JCN_loc) NULLIFY(id%JCN_loc) ENDIF IF (associated(id%A_loc)) THEN DEALLOCATE(id%A_loc) NULLIFY(id%A_loc) ENDIF write(6,*) ' Warning :', & ' id%A_loc, IRN_loc, JCN_loc deallocated !!! ' #endif IF (PROK) THEN WRITE(MP,120) NLOCAL8, NSEND8 END IF C } END IF ! I_AM_SLAVE C ------------------------- C Check for possible errors C ------------------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN C ------------------------------ C The host is not working -> had C no data from initial matrix C ------------------------------ NSEND8 = 0_8 NLOCAL8 = 0_8 END IF C -------------------------- C Put into some info/infog ? C -------------------------- CALL MPI_REDUCE( NSEND8, NSEND_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( NLOCAL8, NLOCAL_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN WRITE(MPG,125) NLOCAL_TOT8, NSEND_TOT8 END IF C } ENDIF ! distributed matrix C } ENDIF ! "old" multithreaded algorithm C } ELSE C { C ------------------- C Matrix is elemental, C provided on the C master only C ------------------- IF ( id%MYID.eq.MASTER) & CALL CMUMPS_MAXELT_SIZE( id%ELTPTR(1), & id%NELT, & MAXELT_SIZE ) C C Perform the distribution of the elements. C A this point, C PTRAIW/PTRARW have been computed. C INTARR/DBLARR have been allocated C ELTPROC gives the mapping of elements C CALL CMUMPS_ELT_DISTRIB( id%N, id%NELT, id%KEEP8(30), & id%COMM, id%MYID, & id%NSLAVES, id%PTRAR(1), & id%PTRAR(id%NELT+2), & INTARR(1), DBLARR(1), id%KEEP8(27), id%KEEP8(26), & id%KEEP(1), id%KEEP8(1), MAXELT_SIZE, & id%FRTPTR(1), id%FRTELT(1), & S_PTR_ARG(1), MAXS_ARG, id%FILS(1), & id, idintr%root, idintr%roota ) C ---------------- C Broadcast errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C } END IF ! Element entry C ------------------------ C Time the redistribution: C ------------------------ IF ( id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIME) id%DKEEP(93) = real(TIME) IF (PROKG) WRITE(MPG,160) id%DKEEP(93) END IF C ------------------------------------- C Small memory optimizaiton: we can now C free RG2L on the non working host, C ------------------------------------- IF (id%KEEP(38) .NE. 0 .AND. .NOT. I_AM_SLAVE) THEN IF (associated(idintr%root%RG2L)) THEN DEALLOCATE(idintr%root%RG2L) NULLIFY (idintr%root%RG2L) ENDIF ENDIF IF ( KEEP(400) .GT. 0 .AND. KEEP(369).EQ.0) THEN C{ Check if number of threads is consistent with C the one used during analysis for all procs C Note that if KEEP(369)>0 C KEEP(400) was set based on C KEEP(369) and KEEP(381) so that C omp_set_num_threads(KEEP(400)) will be called C explicitly before L0_OMP section C and KEEP(400) cannot be check here in this way NOMP=1 !$ NOMP = omp_get_max_threads() IF ( NOMP .NE. KEEP(400) ) THEN id%INFO(1)=-58 id%INFO(2)=KEEP(400) IF (LPOK) WRITE(LP,'(A,A,I5,A,I5)') &" FAILURE DETECTED IN FACTORIZATION: #threads for multithreaded", &" tree parallelism changed from",KEEP(400)," at analysis to", & NOMP ENDIF C} ENDIF C error check done outside previous if bloc C because KEEP(369) might be 0 on some and nonzero on some proc CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C C TIMINGS: C Next line: elapsed time for factorization IF (id%MYID.EQ.MASTER) CALL MUMPS_SECDEB(TIME) C C Allocate buffers on the workers C =============================== C IF ( I_AM_SLAVE ) THEN C C Some buffers are required to pack/unpack data and for C receiving MPI messages. C For packing/unpacking : the buffer must be large C enough to send several messages while receives might not C be posted yet. C It is assumed that the size of an integer is held in KEEP(34) C while the size of a complex is held in KEEP(35). C BUFR and LBUFR are declared of type integer, since byte is not C a standard datatype. C We now use KEEP(43) or KEEP(379) and KEEP(44) or KEEP(380) C as estimated at analysis to allocate appropriate buffer sizes C C Receive buffer C -------------- IF (KEEP(486).NE.0) THEN CMUMPS_LBUFR_BYTES8 = int(KEEP( 380 ),8) * int(KEEP(35),8) ELSE CMUMPS_LBUFR_BYTES8 = int(KEEP( 44 ),8) * int(KEEP(35),8) ENDIF C --------------------------------------- C Ensure a reasonable minimal buffer size C --------------------------------------- IF (KEEP(72).NE.1) THEN C ensure minimum size for small problems CMUMPS_LBUFR_BYTES8 = max( CMUMPS_LBUFR_BYTES8, & 200000_8 ) ENDIF C C If there is pivoting, size of the message might still increase. C We use a relaxation (so called PERLU) to increase the estimate. C C Note: PERLU is a global estimate for pivoting. C It may happen that one large contribution block size is increased C by more than that. C This is why we use an extra factor 2 relaxation coefficient for C the relaxation of C the reception buffer in the case where pivoting is allowed. C A more dynamic strategy could be applied: if message to C be received is larger than expected, reallocate a larger C buffer. (But this won't work with IRECV.) C Finally, one may want (as we are currently doing it for C most messages) C to cut large messages into a series of smaller ones. C IF (KEEP(48).EQ.5) THEN MIN_PERLU = 2 ELSE MIN_PERLU = 0 ENDIF C IF (KEEP(72).NE.1) THEN CMUMPS_LBUFR_BYTES8 = CMUMPS_LBUFR_BYTES8 & + int( real(max(PERLU/2,MIN_PERLU))* & real(CMUMPS_LBUFR_BYTES8)/100E0, 8) ELSE C on small pb we want to relax buffers C for pivoting CMUMPS_LBUFR_BYTES8 = CMUMPS_LBUFR_BYTES8 & + int( real(max(PERLU,MIN_PERLU))* & real(CMUMPS_LBUFR_BYTES8)/100E0, 8) ENDIF CMUMPS_LBUFR_BYTES8 = min(CMUMPS_LBUFR_BYTES8, & int(huge(I4)-100,8)) CMUMPS_LBUFR_BYTES = int( CMUMPS_LBUFR_BYTES8 ) C CMUMPS_LBUFR is the size of the buffer as a number of integers, C we round CMUMPS_LBUFR (size in #integers) above to have at least C CMUMPS_LBUFR_BYTES available in the buffer. CMUMPS_LBUFR = (CMUMPS_LBUFR_BYTES+KEEP(34)-1)/KEEP(34) C Finally, make CMUMPS_LBUFR_BYTES a multiple of KEEP(34) by setting C CMUMPS_LBUFR_BYTES to the number of bytes that will be allocated CMUMPS_LBUFR_BYTES = CMUMPS_LBUFR*KEEP(34) IF (KEEP(48)==5) THEN C Since the buffer is going to be allocated, use C it as the constraint for memory/granularity C in hybrid scheduler C id%KEEP8(21) = id%KEEP8(22) + & int( real(max(PERLU/2,MIN_PERLU))* & real(id%KEEP8(22))/100E0,8) ENDIF C C Now estimate the size for the buffer for asynchronous C sends of contribution blocks (so called CB). We want to be able to send at C least KEEP(213)/100 (two in general) messages at the C same time. C C Send buffer C ----------- IF (KEEP(486).NE.0) THEN CMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 * & real(KEEP(379)) * real(KEEP(35)), 8 ) ELSE CMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 * & real(KEEP(43)) * real(KEEP(35)), 8 ) ENDIF IF (KEEP(72).NE.1) THEN C ensure minimum size for small problems CMUMPS_LBUF8 = max( CMUMPS_LBUF8, 200000_8 ) CMUMPS_LBUF8 = CMUMPS_LBUF8 & + int( real(max(PERLU/2,MIN_PERLU))* & real(CMUMPS_LBUF8)/100E0, 8) ELSE C for very small pb force extra relaxation CMUMPS_LBUF8 = CMUMPS_LBUF8 & + int( real(max(PERLU,MIN_PERLU))* & real(CMUMPS_LBUF8)/100E0, 8) ENDIF C Make CMUMPS_LBUF8 small enough to be stored in a standard integer CMUMPS_LBUF8 = min(CMUMPS_LBUF8, int(huge(I4)-100,8)) C C No reason to have send buffer smaller than receive buffer. C This should never occur with the formulas above but just C in case: CMUMPS_LBUF8 = max(CMUMPS_LBUF8, CMUMPS_LBUFR_BYTES8+3*KEEP(34)) CMUMPS_LBUF = int(CMUMPS_LBUF8) IF(id%KEEP(48).EQ.4)THEN CMUMPS_LBUFR_BYTES=CMUMPS_LBUFR_BYTES*5 CMUMPS_LBUF=CMUMPS_LBUF*5 ENDIF C C Estimate size of buffer for small messages C Each node can send ( NSLAVES - 1 ) messages to (NSLAVES-1) nodes C C KEEP(56) is the number of nodes of level II. C Messages will be sent for the symmetric case C for synchronisation issues. C C We take an upperbound C CMUMPS_LBUF_INT = ( KEEP(56) + id%NSLAVES * id%NSLAVES ) * 5 & * KEEP(34) IF ( KEEP( 38 ) .NE. 0 ) THEN C C KKKK = MUMPS_PROCNODE( id%PROCNODE_STEPS(id%STEP(KEEP(38))), & id%KEEP(199) ) IF ( KKKK .EQ. id%MYID_NODES ) THEN CMUMPS_LBUF_INT = CMUMPS_LBUF_INT + 4 * KEEP(34) * & ( id%NSLAVES + id%NE_STEPS(id%STEP(KEEP(38))) & + min(KEEP(56), id%NE_STEPS(id%STEP(KEEP(38)))) * id%NSLAVES & ) END IF END IF C At this point, CMUMPS_LBUFR_BYTES, CMUMPS_LBUF C and CMUMPS_LBUF_INT have been computed (all C are in numbers of bytes). IF ( PROK ) THEN WRITE( MP, 9999 ) CMUMPS_LBUFR_BYTES, & CMUMPS_LBUF, CMUMPS_LBUF_INT ELSE IF (PROKG) THEN WRITE( MPG, 9999 ) CMUMPS_LBUFR_BYTES, & CMUMPS_LBUF, CMUMPS_LBUF_INT ENDIF END IF 9999 FORMAT( /,' Allocated buffers',/,' ------------------',/, & ' Size of reception buffer in bytes ...... = ', I12, & /, & ' Size of async. emission buffer (bytes).. = ', I12,/, & ' Small emission buffer (bytes) .......... = ', I12) C -------------------------- C Allocate small send buffer C required for CMUMPS_FAC_B C -------------------------- CALL MUMPS_BUF_ALLOC_SMALL_BUF( CMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)= -13 C convert to size in integer id%INFO(2)= CMUMPS_LBUF_INT id%INFO(2)= (CMUMPS_LBUF_INT+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Allocation error in MUMPS_BUF_ALLOC_SMALL_BUF' & ,id%INFO(2) ENDIF GO TO 110 END IF C C -------------------------------------- C Allocate reception buffer on all procs C This is done now. C -------------------------------------- ALLOCATE( BUFR( CMUMPS_LBUFR ),stat=IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = CMUMPS_LBUFR IF (LPOK) THEN WRITE(LP,*) & ': Allocation error for BUFR(', CMUMPS_LBUFR, & ') on MPI process',id%MYID ENDIF GO TO 110 END IF C ----------------------------------------- C Estimate MAXIS. IS will be allocated in C CMUMPS_FAC_B. It will contain factors and C contribution blocks integer information C ----------------------------------------- C Relax integer workspace based on PERLU PERLU = KEEP( 12 ) IF (KEEP(201).GT.0) THEN C OOC panel or non panel (note that C KEEP(15)=KEEP(225) if non panel) MAXIS_ESTIM = KEEP(225) ELSE C In-core or reals for factors not stored MAXIS_ESTIM = KEEP(15) ENDIF MAXIS = max( 1, int( min( int(huge(MAXIS),8), & int(MAXIS_ESTIM,8) + 3_8 * max(int(PERLU,8),10_8) * & ( int(MAXIS_ESTIM,8) / 100_8 + 1_8 ) & ) ! min & ) ! int & ) !max C ---------------------------- C Allocate PTLUST_S and PTRFAC C They will be used to access C factors in the solve phase. C They are also needed for C CMUMPS_FAC_L0_OMP. C ---------------------------- ALLOCATE( id%PTLUST_S( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(28) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%PTLUST_S(', id%KEEP(28),')' ENDIF NULLIFY(id%PTLUST_S) GOTO 110 END IF ALLOCATE( id%PTRFAC( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(28) NULLIFY(id%PTRFAC) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%PTRFAC(', id%KEEP(28),')' ENDIF GOTO 110 END IF C ----------------------------- C Reserve temporary workspace : C IPOOL, PTRWB, ITLOC, PTRIST C PTRWB will be subdivided again C in routine CMUMPS_FAC_B C ----------------------------- PTRIST = 1 PTRWB = PTRIST + id%KEEP(28) ITLOC = PTRWB + 2 * id%KEEP(28) C Fwd in facto: ITLOC of size id%N + id%KEEP(253) IPOOL = ITLOC + id%N + id%KEEP(253) C C -------------------------------- C NA(1) is an upperbound for LPOOL C -------------------------------- C Structure of the pool: C ____________________________________________________ C | Subtrees | | Top nodes | 1 2 3 | C ---------------------------------------------------- LPOOL = MUMPS_GET_POOL_LENGTH(id%NA(1), id%KEEP(1),id%KEEP8(1)) LIWK = IPOOL + LPOOL - 1 ALLOCATE( IWK( IPOOL + LPOOL - 1 ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=IPOOL + LPOOL - 1 IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for IWK(',IPOOL+LPOOL-1,')' ENDIF GOTO 110 END IF LIWK8 = 2 * id%KEEP(28) ALLOCATE(IWK8( 2 * id%KEEP(28)), stat = IERR) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=2 * id%KEEP(28) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for IWKB(', 2*id%KEEP(28),')' ENDIF GOTO 110 END IF C C Return to SPMD C ENDIF C 110 CONTINUE C ---------------- C Broadcast errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C IF ( I_AM_SLAVE ) THEN C Store size of receive buffers in CMUMPS_LBUF module CALL MUMPS_BUF_DIST_IRECV_SIZE( CMUMPS_LBUFR_BYTES ) IF (PROK) THEN WRITE( MP, 170 ) MAXS, MAXIS, MAXS_BASE8, KEEP(15), & id%KEEP8(26), id%KEEP8(27), id%KEEP8(11), KEEP(26), KEEP(27) ENDIF END IF C =============================================================== C Before calling the main driver, CMUMPS_FAC_B, C some statistics should be initialized to 0, C even on the host node because they will be C used in REDUCE operations afterwards. C -------------------------------------------- C Size of factors written. It will be set to POSFAC in C IC, otherwise we accumulate written factors in it. id%KEEP8(31)= 0_8 C Size of factors under L0 will be returned C in id%KEEP8(64), not included in KEEP8(31)) C Number of entries in factors id%KEEP8(10) = 0_8 C KEEP8(8) will hold the volume of extra copies due to C in-place stacking in fac_mem_stack.F id%KEEP8(8)=0_8 id%INFO(9:14)=0 RINFO(2:3)=ZERO IF ( I_AM_SLAVE ) THEN C ------------------------------------ C Call effective factorization routine C ------------------------------------ IF ( KEEP(55) .eq. 0 ) THEN LDPTRAR = 1 ! PTRAR no longer used (of size 2) ELSE LDPTRAR = id%NELT + 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN NELT_arg = id%NELT ELSE C ------------------------------ C Use size 1 to avoid complaints C when using check bound options C ------------------------------ NELT_arg = 1 END IF ENDIF IF (I_AM_SLAVE) THEN IF (associated(id%L0_OMP_MAPPING)) & DEALLOCATE(id%L0_OMP_MAPPING) IF (KEEP(400) .GT. 0) THEN id%LL0_OMP_MAPPING = KEEP(28) ELSE id%LL0_OMP_MAPPING = 1 ENDIF ALLOCATE(id%L0_OMP_MAPPING(id%LL0_OMP_MAPPING), stat=allocok) IF ( allocok > 0) THEN write(*,*) "Problem allocating L0_OMP_MAPPING", & IERR, KEEP(28) GOTO 115 ENDIF IF (KEEP(400) .GT. 0) THEN id%LL0_OMP_FACTORS = KEEP(400) ELSE id%LL0_OMP_FACTORS = 1 ENDIF ALLOCATE(idintr%L0_OMP_FACTORS(id%LL0_OMP_FACTORS), & stat = allocok) IF (allocok > 0) THEN id%INFO(1)=-7 id%INFO(2)=NB_THREADS GOTO 115 ENDIF CALL CMUMPS_INIT_L0_OMP_FACTORS(idintr%L0_OMP_FACTORS) ENDIF 115 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C Compute DKEEP(17) AVG_FLOPS = RINFOG(1)/(real(id%NSLAVES)) id%DKEEP(17) = max ( id%DKEEP(18), AVG_FLOPS/real(50) ) & IF (PROK.AND.id%MYID.EQ.MASTER) THEN IF (id%NSLAVES.LE.1) THEN WRITE(MP,'(/A,A,1PD10.3)') &' Start factorization with total', &' estimated flops (RINFOG(1)) = ', & RINFOG(1) ELSE WRITE(MP,'(/A,A,1PD10.3,A,1PD10.3)') &' Start factorization with total', &' estimated flops RINFOG(1) / Average per MPI proc = ', & RINFOG(1), ' / ', AVG_FLOPS ENDIF ENDIF IF (I_AM_SLAVE) THEN C IS/S pointers passed to CMUMPS_FAC_B with C implicit interface through intermediate C structure S_IS_POINTERS. IS will be allocated C during CMUMPS_FAC_B. C In case of L0OMP, id%IS and id%S are allocated during C CMUMPS_FAC_B, and only after L0OMP nodes are processed, C in order to limit the global memory peak. S_IS_POINTERS%IW => id%IS; NULLIFY(id%IS) S_IS_POINTERS%A => id%S ; NULLIFY(id%S) CALL CMUMPS_FAC_B(id%N,S_IS_POINTERS,MAXS,MAXIS,id%SYM_PERM(1), & id%NA(1),id%LNA,id%NE_STEPS(1),id%ND_STEPS(1), id%FILS(1), & id%STEP(1),id%FRERE_STEPS(1),id%DAD_STEPS(1),id%CANDIDATES(1,1), & id%ISTEP_TO_INIV2(1),id%TAB_POS_IN_PERE(1,1), id%PTRAR(1), &LDPTRAR,id%PTR8ARR(1),id%NINCOLARR(1),id%NINROWARR(1),id%PTRDEBARR & (1), IWK(PTRIST),id%PTLUST_S(1),id%PTRFAC(1),IWK(PTRWB),IWK8, & IWK(ITLOC),RHS_MUMPS(1),IWK(IPOOL),LPOOL,CNTL1,ICNTL(1), & id%INFO(1), RINFO(1),KEEP(1),id%KEEP8(1),id%PROCNODE_STEPS(1), & id%NSLAVES,id%COMM_NODES,id%MYID,id%MYID_NODES,BUFR,CMUMPS_LBUFR & , CMUMPS_LBUFR_BYTES, CMUMPS_LBUF, INTARR(1), DBLARR(1), & idintr%root, idintr%roota, NELT_arg, id%FRTPTR(1), id%FRTELT(1), & id%COMM_LOAD,id%ASS_IRECV,SEUIL,SEUIL_LDLT_NIV2,id%MEM_DIST(0), & id%DKEEP(1), PIVNUL_LIST_STRUCT, id%LRGROUPS(1) & ,id%IPOOL_B_L0_OMP(1),id%LPOOL_B_L0_OMP, & id%IPOOL_A_L0_OMP(1),id%LPOOL_A_L0_OMP,id%L_VIRT_L0_OMP, & id%VIRT_L0_OMP(1), id%VIRT_L0_OMP_MAPPING(1),id%L_PHYS_L0_OMP, & id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1), id%PTR_LEAFS_L0_OMP(1), & id%L0_OMP_MAPPING(1),id%LL0_OMP_MAPPING, id%THREAD_LA, & idintr%L0_OMP_FACTORS(1), id%LL0_OMP_FACTORS, & id%I4_L0_OMP(1,1), size(id%I4_L0_OMP,1), size(id%I4_L0_OMP,2), & id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), size(id%I8_L0_OMP,2) & ) id%IS => S_IS_POINTERS%IW; NULLIFY(S_IS_POINTERS%IW) id%S => S_IS_POINTERS%A ; NULLIFY(S_IS_POINTERS%A) C C ------------------------------ C Deallocate temporary workspace C ------------------------------ DEALLOCATE( IWK ) DEALLOCATE( IWK8 ) ENDIF C Fwd in facto: free RHS_MUMPS in case it was allocated. IF (RHS_MUMPS_ALLOCATED) THEN DEALLOCATE(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. ENDIF NULLIFY(RHS_MUMPS) C --------------------------------- C Free some workspace corresponding C to the original matrix in C arrowhead or elemental format. C ----- C Note : DBLARR may be a pointer C in case of element-entry. C --------------------------------- IF (allocated( INTARR )) DEALLOCATE( INTARR ) IF (DBLARR_ALLOCATED) THEN DEALLOCATE(DBLARR) DBLARR_ALLOCATED=.FALSE. ENDIF NULLIFY(DBLARR) C We also free RG2L now IF ( KEEP(38) .NE. 0) THEN IF (associated(idintr%root%RG2L)) THEN DEALLOCATE(idintr%root%RG2L) NULLIFY(idintr%root%RG2L) ENDIF ENDIF C C Memory statistics C ----------------------------------- C If QR (Keep(19)) is not zero, and if C the host does not have the information C (ie is not slave), send information C computed on the slaves during facto C to the host. C ----------------------------------- C Note the KEEP(17), KEEP(143) have been bcasted during fac_par_m IF ( KEEP(19) .NE. 0 ) THEN IF ( KEEP(46) .NE. 1 ) THEN C Host was not working during facto_root C Send him the information IF ( id%MYID .eq. MASTER ) THEN CALL MPI_RECV( KEEP(17), 1, MPI_INTEGER, 1, DEFIC_TAG, & id%COMM, STATUS, IERR ) CALL MPI_RECV( KEEP(143), 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 ) CALL MPI_SEND( KEEP(143), 1, MPI_INTEGER, 0, DEFIC_TAG, & id%COMM, IERR ) END IF END IF END IF C -------------------------------- C Deallocate communication buffers C They will be reallocated C in the solve. C -------------------------------- IF (allocated(BUFR)) DEALLOCATE(BUFR) CALL MUMPS_BUF_DEALL_SMALL_BUF( IERR ) C C Check for errors. C After CMUMPS_FAC_B every slave is aware of an error. C The call below informs the master, in case it is not C included in the computations. CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C CALL CMUMPS_EXTRACT_SCHUR_REDRHS(id,idintr) C return to user singular values IF (id%KEEP(19) .NE.0) THEN CALL CMUMPS_EXTRACT_SINGULAR_VALUES(id,idintr) ENDIF IF (KEEP(201) .GT. 0) THEN END IF IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIME) id%DKEEP(94)=real(TIME) IF (KEEP(400).GT.0) THEN C Facto time above L0_OMP = total time - facto time under L0_OMP id%DKEEP(96)=id%DKEEP(94)-id%DKEEP(95) ENDIF ENDIF C Time to process root node: CALL MPI_REDUCE( id%DKEEP(99), TMPTIME, 1, & MPI_REAL, & MPI_MAX, MASTER, id%COMM, IERR ) id%DKEEP(99)=TMPTIME C ===================================================================== C COMPUTE MEMORY ALLOCATED BY MUMPS, INFO(16) C --------------------------------------------- MEM_EFF_ALLOCATED = .TRUE. CALL CMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & BLR_STRAT, .TRUE., TOTAL_BYTES, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .FALSE. ! UNDER_L0_OMP & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN ! L0 activated CALL CMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .TRUE., id%KEEP(201), & BLR_STRAT, .TRUE., TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .TRUE. ! UNDER_L0_OMP & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF IF (id%KEEP8(24).NE.0) THEN C WK_USER is not part of memory allocated by MUMPS C and is not counted, id%KEEP8(23) should be zero id%INFO(16) = TOTAL_MBYTES ELSE C Note that even for the case of ICNTL(23)>0 C we report here the memory effectively allocated C that can be smaller than ICNTL(23) ! id%INFO(16) = TOTAL_MBYTES ENDIF C ---------------------------------------------------- C Centralize memory statistics on the host C id%INFOG(18) = size of mem in Mbytes for facto, C for the processor using largest memory C id%INFOG(19) = size of mem in Mbytes for facto, C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(16), id%INFOG(18), IRANK ) CALL CMUMPS_PRINT_ALLOCATED_MEM( PROK, PROKG, PRINT_MAXAVG, & MP, MPG, id%INFO(16), id%INFOG(18), id%INFOG(19), & id%NSLAVES, IRANK, & id%KEEP(1) ) C If WK_USER is provided, this memory excludes WK_USER IF (PROK ) THEN WRITE(MP,'(A,I12) ') & ' ** Eff. min. Space MBYTES for facto (INFO(16)):', & TOTAL_MBYTES ENDIF C ========================(INFO(16) RELATED)====================== C --------------------------------------- C COMPUTE EFFECTIVE MEMORY USED INFO(22) C --------------------------------------- PERLU_ON = .TRUE. MEM_EFF_ALLOCATED = .FALSE. CALL CMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .FALSE. ! UNDER_L0_OMP & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN ! L0 activated CALL CMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .TRUE., id%KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .TRUE. ! UNDER_L0_OMP & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF C -- TOTAL_BYTES and TOTAL_MBYTES includes both static C -- (MAXS) and BLR structures computed as the SUM of the PEAKS C -- (KEEP8(67) + KEEP8(70)) id%KEEP8(7) = TOTAL_BYTES C -- INFO(22) holds the effective space (in Mbytes) used by MUMPS C -- (it includes part of WK_USER used if provided by user) id%INFO(22) = TOTAL_MBYTES C ---------------------------------------------------- C Centralize memory statistics on the host C INFOG(21) = size of effective mem (Mbytes) for facto, C for the processor using largest memory C INFOG(22) = size of effective mem (Mbytes) for facto, C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(22), id%INFOG(21), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' ** Memory effectively used, max in Mbytes (INFOG(21)):', & id%INFOG(21) ENDIF WRITE( MPG,'(A,I12) ') & ' ** Memory effectively used, total in Mbytes (INFOG(22)):', & id%INFOG(22) END IF SUM_INFO22_THIS_NODE=0 CALL MPI_REDUCE( id%INFO(22), SUM_INFO22_THIS_NODE, 1, & MPI_INTEGER, & MPI_SUM, 0, id%KEEP(411), IERR ) CALL MPI_REDUCE( SUM_INFO22_THIS_NODE, MAX_SUM_INFO22_THIS_NODE, & 1, MPI_INTEGER, MPI_MAX, 0, id%COMM, IERR ) IF (PROKG .AND. PRINT_NODEINFO) THEN WRITE(MPG,'(A,I12)') & ' ** Max. effective space per compute node, in MBytes :', & MAX_SUM_INFO22_THIS_NODE ENDIF C IF (I_AM_SLAVE) THEN K67 = id%KEEP8(67) K68 = id%KEEP8(68) K70 = id%KEEP8(70) K74 = id%KEEP8(74) K75 = id%KEEP8(75) ELSE K67 = 0_8 K68 = 0_8 K70 = 0_8 K74 = 0_8 K75 = 0_8 ENDIF C -- Save the number of entries effectively used C in main working array S CALL MUMPS_SETI8TOI4(K67,id%INFO(21)) C IF (id%NPROCS .GT. 1 .AND. id%KEEP(50) .NE. 0) THEN CALL MPI_REDUCE( id%KEEP8(131), id%KEEP8(132), 1, MPI_INTEGER8, & MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%KEEP8(131), id%KEEP8(133), 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%KEEP(175), id%KEEP(176), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR ) ENDIF C IF (KEEP(400) .GT.0 ) THEN IF (.NOT. I_AM_SLAVE) THEN id%DKEEP(95) = 0.0E0 id%DKEEP(16) = 0.0E0 ENDIF IF (id%NPROCS .GT. 1) THEN C Compute average and max (across MPI's) CALL MPI_REDUCE(id%DKEEP(95), TMPTIME, 1, & MPI_REAL, MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) TIMEAVG=dble(TMPTIME) CALL MPI_REDUCE(id%DKEEP(16), TMPFLOP, 1, & MPI_REAL, MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) FLOPAVG=dble(TMPFLOP) IF (id%MYID.EQ.MASTER) THEN TIMEAVG = TIMEAVG / id%NSLAVES FLOPAVG = FLOPAVG / id%NSLAVES ENDIF CALL MPI_REDUCE(id%DKEEP(95), TMPTIME, 1, & MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) TIMEMAX=dble(TMPTIME) CALL MPI_REDUCE(id%DKEEP(16), TMPFLOP, 1, & MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) FLOPMAX=dble(TMPFLOP) C (PROKG may only be true on master) IF ( PROKG ) THEN WRITE(MPG,190) FLOPAVG, FLOPMAX WRITE(MPG,188) TIMEAVG, TIMEMAX ENDIF ELSE C Print DKEEP(95) directly without reduction IF ( PROKG ) THEN WRITE(MPG,189) id%DKEEP(16) WRITE(MPG,187) id%DKEEP(95) ENDIF ENDIF ENDIF IF ( PROKG ) THEN IF ( ( KEEP(38).NE.0 .OR. KEEP(20).NE.0 ) .AND. & KEEP(60) .EQ. 0 ) THEN WRITE(MPG,186) id%DKEEP(99) ENDIF C Elapsed time for factorization: IF (id%INFO(1) .GE.0) THEN WRITE(MPG,180) id%DKEEP(94) ELSE WRITE(MPG,185) id%DKEEP(94) ENDIF ENDIF C C Sum RINFO(2) : total number of flops for assemblies C Sum RINFO(3) : total number of flops for eliminations C Initialize RINFO(4) in case BLR was not activated RINFO(4) = RINFO(3) C C Should work even if the master does some work C CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_REAL, & MPI_SUM, MASTER, id%COMM, IERR) C Reduce needed to dimension small working array C on all procs during CMUMPS_GATHER_SOLUTION KEEP(247) = 0 CALL MPI_REDUCE( KEEP(246), KEEP(247), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR) C C Reduce compression times: get max compression times CALL MPI_REDUCE( id%DKEEP(97), id%DKEEP(98), 1, & MPI_REAL, & MPI_MAX, MASTER, id%COMM, IERR) C CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_REAL, & MPI_SUM, MASTER, id%COMM, IERR) CALL MUMPS_REDUCEI8( id%KEEP8(31)+id%KEEP8(64),id%KEEP8(6), & MPI_SUM, MASTER, id%COMM ) C IF (id%MYID.EQ.0) THEN C In MegaBytes RINFOG(16) = real(id%KEEP8(6)*int(KEEP(35),8))/real(1E6) IF (KEEP(201).LE.0) THEN RINFOG(16) = ZERO ENDIF ENDIF CALL MUMPS_REDUCEI8( id%KEEP8(48),id%KEEP8(148), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(148), INFOG(9)) C CALL MPI_REDUCE( int(id%INFO(10),8), id%KEEP8(128), & 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SETI8TOI4(id%KEEP8(128), id%INFOG(10)) ENDIF C Use MPI_MAX for this one to get largest front size CALL MPI_ALLREDUCE( id%INFO(11), INFOG(11), 1, MPI_INTEGER, & MPI_MAX, id%COMM, IERR) C make maximum effective frontal size available on all procs C for solve phase C (Note that INFO(11) includes root size on root master) KEEP(133) = INFOG(11) CALL MPI_REDUCE( id%INFO(12), INFOG(12), 3, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( id%INFO(40), INFOG(50), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( KEEP(103), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(229) = INFOG(25) CALL MPI_REDUCE( KEEP(105), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(230) = INFOG(25) C id%INFO(25) = KEEP(98) CALL MPI_ALLREDUCE( id%INFO(25), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) C Extra copies due to in-place stacking CALL MUMPS_REDUCEI8( id%KEEP8(8), id%KEEP8(108), MPI_SUM, & MASTER, id%COMM ) C Entries in factors CALL MUMPS_SETI8TOI4(id%KEEP8(10), id%INFO(27)) CALL MUMPS_REDUCEI8( id%KEEP8(10),id%KEEP8(110), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(110), INFOG(29)) C Initialize INFO(28)/INFOG(35) in case BLR not activated id%INFO(28) = id%INFO(27) INFOG(35) = INFOG(29) C ============================== C LOW-RANK C ============================== IF ( KEEP(486) .NE. 0 ) THEN !LR is activated C Compute and Save local amount of flops in case of BLR RINFO(4) = real(FLOP_FRFRONTS + FLOP_FACTO_FR - FLOP_LRGAIN & + FLOP_COMPRESS + FLOP_FRFRONTS) C C Compute and Save local number of entries in compressed factors C ITMP8 = id%KEEP8(10) - int(MRY_LU_LRGAIN,8) CALL MUMPS_SETI8TOI4( ITMP8, id%INFO(28)) C CALL MPI_REDUCE( MRY_LU_LRGAIN, TMP_MRY_LU_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_LU_FR, TMP_MRY_LU_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_CB_FR, TMP_MRY_CB_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_CB_LRGAIN, TMP_MRY_CB_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_LRGAIN, TMP_FLOP_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM_FR, TMP_FLOP_TRSM_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM_LR, TMP_FLOP_TRSM_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_FR, TMP_FLOP_UPDATE_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_LR, TMP_FLOP_UPDATE_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FRSWAP_COMPRESS, & TMP_FLOP_FRSWAP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_MIDBLK_COMPRESS, & TMP_FLOP_MIDBLK_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_LRLR3, TMP_FLOP_UPDATE_LRLR3 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(FLOP_ACCUM_COMPRESS, TMP_FLOP_ACCUM_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM, TMP_FLOP_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_PANEL, TMP_FLOP_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FRFRONTS, TMP_FLOP_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_COMPRESS, TMP_FLOP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_DECOMPRESS, TMP_FLOP_DECOMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_CB_COMPRESS, TMP_FLOP_CB_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_CB_DECOMPRESS,TMP_FLOP_CB_DECOMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FACTO_FR, TMP_FLOP_FACTO_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( CNT_NODES,TMP_CNT_NODES & , 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%NPROCS.GT.1) THEN FLOP_FACTO_LR = FLOP_FACTO_FR - FLOP_LRGAIN & + FLOP_COMPRESS + FLOP_FRFRONTS CALL MPI_REDUCE( FLOP_FACTO_LR, AVG_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN AVG_FLOP_FACTO_LR = AVG_FLOP_FACTO_LR/id%NPROCS ENDIF CALL MPI_REDUCE( FLOP_FACTO_LR, MIN_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FACTO_LR, MAX_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR) ENDIF ! NPROCS > 1 CALL MPI_REDUCE( TIME_UPDATE, TMP_TIME_UPDATE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR1, TMP_TIME_UPDATE_LRLR1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR2, TMP_TIME_UPDATE_LRLR2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR3, TMP_TIME_UPDATE_LRLR3 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_FRLR, TMP_TIME_UPDATE_FRLR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_FRFR, TMP_TIME_UPDATE_FRFR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DIAGCOPY, TMP_TIME_DIAGCOPY & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_COMPRESS,TMP_TIME_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_MIDBLK_COMPRESS, & TMP_TIME_MIDBLK_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRSWAP_COMPRESS, & TMP_TIME_FRSWAP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_CB_COMPRESS, TMP_TIME_CB_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP, TMP_TIME_DECOMP & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_UCFS, TMP_TIME_DECOMP_UCFS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LRASM_NIV1, TMP_TIME_LRASM_NIV1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_LRASM_LOCASM2, TMP_TIME_LRASM_LOCASM2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_LRASM_MAPLIG1, TMP_TIME_LRASM_MAPLIG1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_LRASM_CONTRIB2, TMP_TIME_LRASM_CONTRIB2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_FRASM_LOCASM2, TMP_TIME_FRASM_LOCASM2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_FRASM_MAPLIG1, TMP_TIME_FRASM_MAPLIG1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_FRASM_CONTRIB2, TMP_TIME_FRASM_CONTRIB2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_PANEL, TMP_TIME_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_I, TMP_TIME_FAC_I & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_MQ, TMP_TIME_FAC_MQ & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_SQ, TMP_TIME_FAC_SQ & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LRTRSM, TMP_TIME_LRTRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRTRSM, TMP_TIME_FRTRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRFRONTS, TMP_TIME_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LR_MODULE, TMP_TIME_LR_MODULE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN IF (id%NPROCS.GT.1) THEN C rename the stat variable so that COMPUTE_GLOBAL_GAINS can work for any C number of procs MRY_LU_FR = TMP_MRY_LU_FR MRY_LU_LRGAIN = TMP_MRY_LU_LRGAIN MRY_CB_FR = TMP_MRY_CB_FR MRY_CB_LRGAIN = TMP_MRY_CB_LRGAIN FLOP_LRGAIN = TMP_FLOP_LRGAIN FLOP_PANEL = TMP_FLOP_PANEL FLOP_TRSM = TMP_FLOP_TRSM FLOP_TRSM_FR = TMP_FLOP_TRSM_FR FLOP_TRSM_LR = TMP_FLOP_TRSM_LR FLOP_UPDATE_FR = TMP_FLOP_UPDATE_FR FLOP_UPDATE_LR = TMP_FLOP_UPDATE_LR FLOP_UPDATE_LRLR3 = TMP_FLOP_UPDATE_LRLR3 FLOP_COMPRESS = TMP_FLOP_COMPRESS FLOP_MIDBLK_COMPRESS = TMP_FLOP_MIDBLK_COMPRESS FLOP_FRSWAP_COMPRESS = TMP_FLOP_FRSWAP_COMPRESS FLOP_ACCUM_COMPRESS = TMP_FLOP_ACCUM_COMPRESS FLOP_CB_COMPRESS = TMP_FLOP_CB_COMPRESS FLOP_DECOMPRESS = TMP_FLOP_DECOMPRESS FLOP_CB_DECOMPRESS = TMP_FLOP_CB_DECOMPRESS FLOP_FRFRONTS = TMP_FLOP_FRFRONTS FLOP_FACTO_FR = TMP_FLOP_FACTO_FR CNT_NODES = TMP_CNT_NODES TIME_UPDATE = TMP_TIME_UPDATE /id%NPROCS TIME_UPDATE_LRLR1 = TMP_TIME_UPDATE_LRLR1 /id%NPROCS TIME_UPDATE_LRLR2 = TMP_TIME_UPDATE_LRLR2 /id%NPROCS TIME_UPDATE_LRLR3 = TMP_TIME_UPDATE_LRLR3 /id%NPROCS TIME_UPDATE_FRLR = TMP_TIME_UPDATE_FRLR /id%NPROCS TIME_UPDATE_FRFR = TMP_TIME_UPDATE_FRFR /id%NPROCS TIME_COMPRESS = TMP_TIME_COMPRESS /id%NPROCS TIME_MIDBLK_COMPRESS = TMP_TIME_MIDBLK_COMPRESS/id%NPROCS TIME_FRSWAP_COMPRESS = TMP_TIME_FRSWAP_COMPRESS/id%NPROCS TIME_DIAGCOPY = TMP_TIME_DIAGCOPY /id%NPROCS TIME_CB_COMPRESS = TMP_TIME_CB_COMPRESS /id%NPROCS TIME_PANEL = TMP_TIME_PANEL /id%NPROCS TIME_FAC_I = TMP_TIME_FAC_I /id%NPROCS TIME_FAC_MQ = TMP_TIME_FAC_MQ /id%NPROCS TIME_FAC_SQ = TMP_TIME_FAC_SQ /id%NPROCS TIME_LRTRSM = TMP_TIME_LRTRSM /id%NPROCS TIME_FRTRSM = TMP_TIME_FRTRSM /id%NPROCS TIME_FRFRONTS = TMP_TIME_FRFRONTS /id%NPROCS TIME_LR_MODULE = TMP_TIME_LR_MODULE /id%NPROCS TIME_DECOMP = TMP_TIME_DECOMP /id%NPROCS TIME_DECOMP_UCFS = TMP_TIME_DECOMP_UCFS /id%NPROCS TIME_LRASM_NIV1 = TMP_TIME_LRASM_NIV1 /id%NPROCS TIME_LRASM_LOCASM2 = TMP_TIME_LRASM_LOCASM2 /id%NPROCS TIME_LRASM_MAPLIG1 = TMP_TIME_LRASM_MAPLIG1 /id%NPROCS TIME_LRASM_CONTRIB2 = TMP_TIME_LRASM_CONTRIB2 /id%NPROCS TIME_FRASM_LOCASM2 = TMP_TIME_FRASM_LOCASM2 /id%NPROCS TIME_FRASM_MAPLIG1 = TMP_TIME_FRASM_MAPLIG1 /id%NPROCS TIME_FRASM_CONTRIB2 = TMP_TIME_FRASM_CONTRIB2 /id%NPROCS ENDIF CALL COMPUTE_GLOBAL_GAINS(id%KEEP8(110), & dble(id%RINFOG(3)), & id%KEEP8(49), PROKG, MPG) C Number of entries in factor INFOG(35) in C compressed form is updated as long as C BLR is activated, this independently of the C fact that factors are saved in LR. CALL MUMPS_SETI8TOI4(id%KEEP8(49), id%INFOG(35)) FRONTWISE = 0 C WRITE gains also compute stats stored in DKEEP array DO I=1,LR_TABSIZE LR_TAB(I) = dble(id%DKEEP(I+LR_DKEEPSHIFT)) LR_EPSILON = dble(id%DKEEP(8)) ENDDO CALL SAVEandWRITE_GAINS(FRONTWISE, KEEP(489), & LR_DKEEPSHIFT, LR_TABSIZE, LR_TAB, LR_EPSILON, & N, id%ICNTL(36), & KEEP(487), KEEP(488), KEEP(490), & KEEP(491), KEEP(50), KEEP(486), & KEEP(249)*max(KEEP(381), 1), & KEEP(472), KEEP(475), KEEP(478), & KEEP(480), KEEP(481), & KEEP(483), KEEP(484), & id%KEEP8(110), id%KEEP8(49), & KEEP(28), id%NPROCS, MPG, PROKG) C flops when BLR activated RINFOG(14) = id%DKEEP(56) DO I=1,18 id%DKEEP(I+LR_DKEEPSHIFT)=real(LR_TAB(I)) ENDDO ELSE RINFOG(14) = 0.0E00 ENDIF IF (id%MYID .eq. MASTER) THEN KEEP(399) = KEEP399_SAVE ENDIF ENDIF C ============================== C NULL PIVOTS AND RANK-REVEALING C ============================== IF (KEEP(19).EQ.0.AND.KEEP(53).NE.0) THEN C restore KEEP(20) KEEP(20) = KEEP20_SAVE ENDIF IF(KEEP(110) .EQ. 1) THEN C -- make available to users the local number of null pivots detected C -- with ICNTL(24) = 1. id%INFO(18) = KEEP(109) CALL MPI_ALLREDUCE( KEEP(109), KEEP(112), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) ELSE id%INFO(18) = 0 KEEP(109) = 0 KEEP(112) = 0 ENDIF IF ( associated( id%PIVNUL_LIST) ) THEN DEALLOCATE(id%PIVNUL_LIST) NULLIFY(id%PIVNUL_LIST) ENDIF C set INFOG(28) even in case of error IF (id%MYID.EQ.MASTER) THEN C INFOG(28) deficiency resulting from ICNTL(24) and ICNTL(56) INFOG(28)=KEEP(112) IF (KEEP(17).GT.0) THEN INFOG(28)=KEEP(112)+KEEP(17) ENDIF ENDIF C IF (id%INFO(1).GE.0) THEN C{ PIVNUL_LIST not meaningful in case of error C (do not allocate) IF (id%MYID.EQ.MASTER) THEN IF ( INFOG(28) .GT. 0 ) THEN ALLOCATE(id%PIVNUL_LIST(INFOG(28)), stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=INFOG(28) END IF ENDIF ELSE C id%PIVNUL_LIST(1:KEEP(109)) used during sol_driver on slaves C to initialize id%RHSINTR IF (KEEP(109).GT.0) THEN ALLOCATE(id%PIVNUL_LIST(KEEP(109)), stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=INFOG(28) END IF ENDIF ENDIF C} ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 490 IF ( (KEEP(19).NE.0) .AND. (KEEP(143) .NE. KEEP(17)) ) THEN C C Raise a warning (on all MPI processes) since determinant or C inertia or null pivot list is not consistent with deficiency C computed with ICNTL(46)=1. C id%INFO(1) = id%INFO(1)+16 id%INFO(2) = KEEP(112)+KEEP(143) IF (KEEP(118) .GE. 40) THEN IF ( PROKG ) THEN WRITE(MPG,'(/A,A/,A,A,I8/,A,A,I8/)') & " WARNING: in the context of rank-revealing,", & " the inertia, determinant and pivnul list", & " are computed with RR (rank-revealing)-LU,", & " but the deficiency found by RR-LU: ", & id%INFO(2), & " is different from the deficiency computed", & " with ICNTL(56)>0: ", KEEP(112)+KEEP(17) ENDIF ELSE IF ( LP .GT. 0 ) THEN WRITE(LP,'(/A,A/,A/)') & " ERROR : in the context of rank-revealing,", & " the inertia, determinant and pivnul list", & " are not correct because RR LU not called " ENDIF ENDIF ENDIF C ======================================== C We now provide to the host the part of C PIVNUL_LIST resulting from the processing C of the root node and we update id%INFO(18) C on the processor holding the root to C include null pivots relative to the root C ======================================== IF ( KEEP(109).GT.0 ) THEN DO I=1, KEEP(109) id%PIVNUL_LIST(I)= & PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) ENDDO ENDIF IF (KEEP(17) .NE. 0) THEN IF (id%MYID .EQ. ID_ROOT) THEN C Include in id%INFO(18) null pivots resulting C from deficiency on the root. In this way, C the sum of all id%INFO(18) is equal to INFOG(28). id%INFO(18)=id%INFO(18)+KEEP(17) ENDIF IF (ID_ROOT .EQ. MASTER) THEN IF (id%MYID.EQ.MASTER) THEN C -------------------------------------------------- C Null pivots of root have been stored in C PIVNUL_LIST_STRUCT%PIVNUL_LIST( C KEEP(109)+1:KEEP(109)+KEEP(17) ) C Shift them at the end of the list because: C * this is what we need to build the null space C * we would otherwise overwrite them on the host C when gathering null pivots from other processors C -------------------------------------------------- DO I= KEEP(17), 1, -1 id%PIVNUL_LIST(KEEP(112)+I)= & PIVNUL_LIST_STRUCT%PIVNUL_LIST(KEEP(109)+I) ENDDO ENDIF ELSE C --------------------------------- C Null pivots of root must be sent C from the processor responsible of C the root to the host (or MASTER). C --------------------------------- IF (id%MYID .EQ. ID_ROOT) THEN CALL MPI_SEND( & PIVNUL_LIST_STRUCT%PIVNUL_LIST(KEEP(109)+1), & KEEP(17), MPI_INTEGER, MASTER, ZERO_PIV, & id%COMM, IERR) ELSE IF (id%MYID .EQ. MASTER) THEN CALL MPI_RECV(id%PIVNUL_LIST(KEEP(112)+1), KEEP(17), & MPI_INTEGER, ID_ROOT, ZERO_PIV, & id%COMM, STATUS, IERR ) ENDIF ENDIF ENDIF C =========================== C gather zero pivots indices C on the host node C =========================== C In case of non working host, the following code also C works considering that KEEP(109) is equal to 0 on C the non-working host IF(KEEP(110) .EQ. 1) THEN ALLOCATE(ITMP2(id%NPROCS),stat = IERR ) ! deallocated in 490 IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%NPROCS END IF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 490 CALL MPI_GATHER ( KEEP(109),1, MPI_INTEGER, & ITMP2(1), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF(id%MYID .EQ. MASTER) THEN POSBUF = ITMP2(1)+1 C First null pivot of master is in C position 1 of global list KEEP(220)=1 DO I = 1,id%NPROCS-1 IF (ITMP2(I+1).GT.0) THEN CALL MPI_RECV(id%PIVNUL_LIST(POSBUF), ITMP2(I+1), & MPI_INTEGER,I, & ZERO_PIV, id%COMM, STATUS, IERR) C Send position POSBUF of first null pivot of proc I C in global list. Will allow to quickly identify during C the solve step if one is concerned by a global position C K, 0 <= K <= INFOG(28). CALL MPI_SEND(POSBUF, 1, MPI_INTEGER, I, ZERO_PIV, & id%COMM, IERR) POSBUF = POSBUF + ITMP2(I+1) ENDIF ENDDO ELSE IF (KEEP(109).GT.0) THEN CALL MPI_SEND( & PIVNUL_LIST_STRUCT%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 ENDIF IF (associated( PIVNUL_LIST_STRUCT%PIVNUL_LIST)) THEN DEALLOCATE(PIVNUL_LIST_STRUCT%PIVNUL_LIST) NULLIFY(PIVNUL_LIST_STRUCT%PIVNUL_LIST) ENDIF C ===================================== C Statistics concerning the determinant C ===================================== C C 1/ on the host better take into account null pivots if scaling: C C Since null pivots are excluded from the computation C of the determinant, we also exclude the corresponding C scaling entries. Since those entries have already been C taken into account before the factorization, we multiply C the determinant on the host by the scaling values corresponding C to pivots in PIVNUL_LIST. IF (id%MYID.EQ.MASTER .AND. LSCAL. AND. KEEP(258).NE.0) THEN K = min(KEEP(143), KEEP(17)) K = max(K, 0) DO I = 1, KEEP(112)+ K c DO I = 1, id%INFOG(28) ! all null pivots + singular values CALL CMUMPS_UPDATEDETER_SCALING( & id%ROWSCA(id%PIVNUL_LIST(I)), & id%DKEEP(6), KEEP(259)) CALL CMUMPS_UPDATEDETER_SCALING( & id%COLSCA(id%PIVNUL_LIST(I)), & id%DKEEP(6), KEEP(259)) ENDDO ENDIF C C 2/ Swap signs depending on pivoting on each proc C IF (KEEP(258).NE.0) THEN C Return the determinant in INFOG(34) and RINFOG(12/13) IF (KEEP(260).EQ.-1) THEN ! Local to each processor id%DKEEP(6)=-id%DKEEP(6) id%DKEEP(7)=-id%DKEEP(7) ENDIF C C 3/ Perform a reduction C CALL CMUMPS_DETER_REDUCTION( & id%COMM, id%DKEEP(6), KEEP(259), & RINFOG(12), INFOG(34), id%NPROCS) C C 4/ Swap sign if needed C IF (id%KEEP(50).EQ.0 .AND. id%MYID.EQ. MASTER) THEN C Modify sign of determinant according C to unsymmetric permutation (max-trans C of max-weighted matching) IF (id%KEEP(23).NE.0) THEN CALL CMUMPS_DETER_SIGN_PERM( & RINFOG(12), id%N, & id%UNS_PERM(1) ) C Remark that RINFOG(12/13) are modified only C on the host but will be broadcast on exit C from MUMPS (see CMUMPS_DRIVER) ENDIF ENDIF ENDIF 490 IF (allocated(ITMP2)) DEALLOCATE(ITMP2) C C ===================================== C Statistics relative to min/max pivots C ===================================== CALL MPI_REDUCE( id%DKEEP(19), RINFOG(19), 1, & MPI_REAL, & MPI_MIN, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(20), RINFOG(20), 1, & MPI_REAL, & MPI_MIN, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(21), RINFOG(21), 1, & MPI_REAL, & MPI_MAX, MASTER, id%COMM, IERR ) C ========================================= C Centralized number of swaps for pivoting C ========================================= CALL MPI_REDUCE( id%KEEP8(80), ITEMP8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF (id%MYID .EQ. MASTER) THEN CALL MUMPS_SETI8TOI4(ITEMP8,id%INFOG(48)) ENDIF C ========================================== C Centralized largest increase of panel size C ========================================== CALL MPI_REDUCE( id%KEEP(425), id%INFOG(49), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN C{ ----------------------------- C PRINT STATISTICS (on master) C ----------------------------- WRITE(MPG,99984) RINFOG(2),RINFOG(3),KEEP(52), & id%KEEP8(148), & id%KEEP8(128), INFOG(11), id%KEEP8(110) IF (id%KEEP(50) == 0) THEN ! off diag pivots WRITE(MPG, 99985) INFOG(12) END IF IF (id%KEEP(50) .NE. 1) THEN ! delayed pivots WRITE(MPG, 99982) INFOG(13) END IF IF (KEEP(97) .NE. 0) THEN ! tiny pivots WRITE(MPG, '(A,D16.4)') & ' Effective static pivoting thresh., CNTL(4) =', SEUIL WRITE(MPG, 99986) INFOG(25) ENDIF IF (id%KEEP(50) == 2) THEN !number of 2x2 pivots in type 1 nodes WRITE(MPG, 99988) KEEP(229) !number of 2x2 pivots in type 2 nodes WRITE(MPG, 99989) KEEP(230) ENDIF !number of zero pivots IF (KEEP(110) .NE.0) THEN WRITE(MPG, 99991) KEEP(112) ENDIF !Deficiency on root IF ( KEEP(19) .ne. 0 ) c IF ( KEEP(17) .ne. 0 ) & WRITE(MPG, 99983) KEEP(17) !Total deficiency IF (KEEP(110).NE.0.OR.KEEP(19).NE.0) & WRITE(MPG, 99992) KEEP(17)+KEEP(112) ! = INFOG(28) !Smallest pivot with also null pivots in abs value WRITE(MPG, 99995) RINFOG(19) !Smallest pivot in abs value WRITE(MPG, 99993) RINFOG(20) !Largest pivot in abs value WRITE(MPG, 99994) RINFOG(21) !value of ICNTL(12) that was effectively used. WRITE(MPG, 99996) INFOG(24) ! Memory compress WRITE(MPG, 99981) INFOG(14) ! Extra copies due to ip stack in unsym case ! in core case (or OLD_OOC_PANEL) IF (id%KEEP8(108) .GT. 0_8) THEN WRITE(MPG, 99980) id%KEEP8(108) ENDIF IF ((KEEP(60).NE.0) .AND. INFOG(25).GT.0) THEN ! Schur on and tiny pivots set in last level ! before the Schur if KEEP(114)=0 WRITE(MPG, '(A)') & " ** Warning Static pivoting was necessary" WRITE(MPG, '(A)') & " ** to factor interior variables with Schur ON" ENDIF IF (KEEP(258).NE.0) THEN WRITE(MPG,99978) RINFOG(12) WRITE(MPG,99979) RINFOG(13) WRITE(MPG,99977) INFOG(34) ENDIF C} END IF * ========================================== * * End of Factorization Phase * * ========================================== C C Goto 500 is done when C LOAD_INIT C OOC_INIT_FACTO C MUMPS_FDM_INIT #if ! defined(NO_FDM_DESCBAND) C MUMPS_FDBD_INIT #endif #if ! defined(NO_FDM_MAPROW) C MUMPS_FMRD_INIT #endif C are all called. C 500 CONTINUE C Redo free INTARR and DBLARR in case an error occurred C after allocating them and before freeing them. IF (associated(DBLARR)) THEN DEALLOCATE(DBLARR) NULLIFY(DBLARR) ENDIF IF (allocated(INTARR)) THEN DEALLOCATE(INTARR) ENDIF IF ( KEEP(38) .NE. 0) THEN IF (associated(idintr%root%RG2L)) THEN DEALLOCATE(idintr%root%RG2L) NULLIFY(idintr%root%RG2L) ENDIF ENDIF #if ! defined(NO_FDM_DESCBAND) IF (I_AM_SLAVE) THEN CALL MUMPS_FDBD_END(id%INFO(1)) ! INFO(1): input only ENDIF #endif #if ! defined(NO_FDM_MAPROW) IF (I_AM_SLAVE) THEN CALL MUMPS_FMRD_END(id%INFO(1)) ! INFO(1): input only ENDIF #endif IF (I_AM_SLAVE) THEN C Terminate BLR module except if it is still needed for solve IF ( & ( & (KEEP(486).EQ.2) & ) & .AND. id%INFO(1).GE.0 & ) THEN C Store pointer to BLR_ARRAY in MUMPS structure C (requires successful factorization otherwise module is freed) CALL CMUMPS_BLR_MOD_TO_STRUC(id%BLRARRAY_ENCODING) ELSE C INFO(1) positive or negative CALL CMUMPS_BLR_END_MODULE(id%INFO(1), id%KEEP8, id%KEEP(34)) ENDIF ENDIF IF (I_AM_SLAVE) THEN CALL MUMPS_FDM_END('A') C Terminate BLR module except if it is still needed for solve IF ( & ( & (KEEP(486).EQ.2) & ) & .AND. id%INFO(1).GE.0 & ) THEN CALL MUMPS_FDM_MOD_TO_STRUC('F', id%FDM_F_ENCODING, & id%INFO(1)) IF (.NOT. associated(id%FDM_F_ENCODING)) THEN WRITE(*,*) "Internal error 2 in CMUMPS_FAC_DRIVER" ENDIF ELSE CALL MUMPS_FDM_END('F') ENDIF ENDIF C C Goto 514 is done when an C error occurred in MUMPS_FDM_INIT C or (after FDM_INIT but before C OOC_INIT) C 514 CONTINUE IF ( I_AM_SLAVE ) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL CMUMPS_OOC_END_FACTO(id%KEEP,id%KEEP8, & id%OOC_MAX_NB_NODES_FOR_ZONE,id%OOC_TOTAL_NB_NODES, & id%OOC_FILE_NAMES, id%INFO, id%OOC_FILE_NAME_LENGTH, & id%OOC_NB_FILES, IERR) IF (id%ASSOCIATED_OOC_FILES) THEN id%ASSOCIATED_OOC_FILES = .FALSE. ENDIF IF (IERR.LT.0 .AND. id%INFO(1) .GE. 0) id%INFO(1) = IERR ENDIF IF (WK_USER_PROVIDED) THEN C at the end of a phase S is always null when WK_USER provided NULLIFY(id%S) ELSE IF (KEEP(201).NE.0) THEN C ---------------------------------------- C In OOC or if KEEP(201).EQ.-1 we always C free S at end of factorization. As id%S C may be unassociated in case of error C during or before the allocation of id%S, C we only free S when it was associated. C ---------------------------------------- IF (associated(id%S)) THEN CALL CMUMPS_DM_FREE_S_WK(id%S, KEEP(430)) C Reset KEEP(430)=0 since S will be allocated C from Fortran during solve KEEP(430) = 0 ENDIF NULLIFY(id%S) ! in all cases id%KEEP8(23)=0_8 ELSE ! in core CALL CMUMPS_TRY_COMPACT_FACTORS(ICNTL49_LOC, & WK_USER_PROVIDED, id%S, id%KEEP, id%KEEP8, & id%INFO, id%MYID, id%ICNTL, PROK, MP, & CMUMPS_LBUFR_BYTES8, CMUMPS_LBUF8, & LIWK, LIWK8 ) ENDIF ELSE ! host not working IF (WK_USER_PROVIDED) THEN C at the end of a phase S is always freed when WK_USER provided NULLIFY(id%S) ELSE IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) id%KEEP8(23)=0_8 END IF END IF C C Goto 513 is done in case of error where LOAD_INIT was C called but not the scaling nor OOC_INIT_FACTO. 513 CONTINUE IF ( I_AM_SLAVE ) THEN CALL MUMPS_LOAD_END( id%INFO(1), id%NSLAVES, IERR ) IF (IERR.LT.0 .AND. id%INFO(1) .GE. 0) id%INFO(1) = IERR ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C C Goto 516 is done in case of error when GPU initialiwqtion C has been performed and scaling was optionally computed but C not LOAD_INIT nor OOC_INIT_FACTO. We can then extract C scaling arrays in case of error. 516 CONTINUE C -------------------------------------------- C We now build id%ROWSCA_loc and id%COLSCA_loc C in case of successful factorization, in the C numbering associated to the fully summed C variables of the frontal matrices. C This requires the factorization to be C successful because otherwise we do not have C the final lists of pivots associated to C the fronts, including delayed pivots and C symmetric/unsymmetric permutations done C during the factorization process. C -------------------------------------------- IF (LSCAL .AND. id%INFO(1).GE.0) THEN CALL CMUMPS_EXTRACT_SCALING(id) C occurs during scaling extraction, keep the error. IF ( id%INFO(1) .LT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) "Facto OK but error during EXTRACT_SCALING", & id%INFO(1:2) ENDIF ENDIF ENDIF C C Goto 517 is done when an error occurs when GPU initialization C has been performed but not LOAD_INIT or OOC_INIT_FACTO, e.g. C when an error occurred during the scaling. 517 CONTINUE IF (associated( PIVNUL_LIST_STRUCT%PIVNUL_LIST)) THEN DEALLOCATE(PIVNUL_LIST_STRUCT%PIVNUL_LIST) NULLIFY(PIVNUL_LIST_STRUCT%PIVNUL_LIST) ENDIF C C Goto 530 is done when an error occurs before C the calls to GPU_INIT, LOAD_INIT and OOC_INIT_FACTO 530 CONTINUE C Fwd in facto: free RHS_MUMPS in case C it was allocated. IF (RHS_MUMPS_ALLOCATED) DEALLOCATE(RHS_MUMPS) NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. C id%KEEP8(26) = KEEP826_SAVE RETURN 120 FORMAT(/' Local redistrib: data local/sent =',I16,I16) 125 FORMAT(/' Redistrib: total data local/sent =',I16,I16) 130 FORMAT(//'****** FACTORIZATION STEP ********'/) 140 FORMAT(/' Statistics on the scaling phase' & /' Elapsed time for scaling =',F12.4) 160 FORMAT( & ' Elapsed time to reformat/distribute matrix =',F12.4/) 166 FORMAT(' Max difference from 1 after scaling the entries', & ' for ONE-NORM (option 7/8) =',D9.2/) 170 FORMAT(' STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' Size of internal working array S =',I16/ & ' Size of internal working array IS =',I16/ & ' Minimum (ICNTL(14)=0) size of S =',I16/ & ' Minimum (ICNTL(14)=0) size of IS =',I16/ & ' Real space for original matrix =',I16/ & ' Integer space for original matrix =',I16/ & ' INFO(3) Real space for factors (estimated) =',I16/ & ' INFO(4) Integer space for factors (estim.) =',I16/ & ' Maximum frontal size (estimated) =',I16) 172 FORMAT(' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' Number of working processes =',I16/ & ' ICNTL(22) Out-of-core option =',I16/ & ' ICNTL(35) BLR activation (eff. choice) =',I16/ & ' ICNTL(37) BLR CB compression (eff. choice) =',I16/ & ' ICNTL(49) Compact workarray S (end facto.) =',I16/ & ' ICNTL(56) Effective value during facto. =',I16/ & ' ICNTL(14) Memory relaxation =',I16/ & ' INFOG(3) Real space for factors (estimated)=',I16/ & ' INFOG(4) Integer space for factors (estim.)=',I16/ & ' Maximum frontal size (estimated) =',I16/ & ' Number of nodes in the tree =',I16/ & ' ICNTL(23) Memory allowed (value on host) =',I16/ & ' Sum over all procs =',I16/ & ' Memory provided by user, sum of LWK_USER =',I16/ & ' Effective threshold for pivoting, CNTL(1) =',D16.4) 173 FORMAT( ' Perform forward during facto, NRHS =',I16) 174 FORMAT( ' KEEP(268) Relaxed pivoting effective value =',I16) 180 FORMAT(/' Elapsed time for factorization =', & F12.4) 185 FORMAT(/' Elapsed time for (failed) factorization =', & F12.4) 186 FORMAT(/' Elapsed time to process root node =', & F12.4) 187 FORMAT( ' Elapsed time under L0 =',F12.4) 188 FORMAT( ' Elapsed time under L0 (avg/max across MPI) =', & F12.4,F12.4) 189 FORMAT(/' Flops under L0 layer =',1PD12.3) 190 FORMAT(/' Flops under L0 layer (avg/max across MPI) =', & 1PD12.3,1PD12.3) 99977 FORMAT( ' INFOG(34) Determinant (base 2 exponent) =', & I16) 99978 FORMAT( ' RINFOG(12) Determinant (real part) =', & F16.8) 99979 FORMAT( ' RINFOG(12) Determinant (imaginary part) =', & F16.8) 99980 FORMAT( ' Extra copies due to In-Place stacking =', & I16) 99981 FORMAT( ' INFOG (14) Number of memory compress =', & I16) 99982 FORMAT( ' INFOG (13) Number of delayed pivots =', & I16) 99983 FORMAT( ' Nb of singularities detected by ICNTL(56) =', & I16) 99991 FORMAT( ' Nb of null pivots detected by ICNTL(24) =', & I16) 99992 FORMAT( ' INFOG (28) Estimated deficiency =', & I16) 99995 FORMAT( ' RINFOG(19) Smallest pivot WITH perturbed pivots =', & 1PD10.3) 99993 FORMAT( ' RINFOG(20) Smallest pivot WITHOUT perturbed pivots =', & 1PD10.3) 99994 FORMAT( ' RINFOG(21) Largest pivot in absolute value =', & 1PD10.3) 99996 FORMAT( ' INFOG (24) Effective value of ICNTL(12) =', & I16) 99984 FORMAT(/'Leaving factorization with ...'/ & ' RINFOG (2) Operations in node assembly =', & 1PD10.3/ & ' ------ (3) Operations in node elimination =', & 1PD10.3/ & ' ICNTL (8) Scaling effectively used =', & I16/ & ' INFOG (9) Real space for factors =', & I16/ & ' INFOG (10) Integer space for factors =', & I16/ & ' INFOG (11) Maximum front size =', & I16/ & ' INFOG (29) Number of entries in factors =', & I16) 99985 FORMAT( ' INFOG (12) Number of off diagonal pivots =', & I16) 99986 FORMAT( ' INFOG (25) Number of tiny pivots(static) =', & I16) 99988 FORMAT( ' Number of 2x2 pivots in type 1 nodes =', & I16) 99989 FORMAT( ' Number of 2x2 pivots in type 2 nodes =', & I16) END SUBROUTINE CMUMPS_FAC_DRIVER C SUBROUTINE CMUMPS_PRINT_ALLOCATED_MEM( PROK, PROKG, PRINT_MAXAVG, & MP, MPG, INFO16, INFOG18, INFOG19, NSLAVES, IRANK, KEEP ) IMPLICIT NONE C C Purpose: C ======= C Print memory allocated during factorization C - called at beginning of factorization in full-rank C - called at end of factorization in low-rank (because C of dynamic allocations) C LOGICAL, INTENT(IN) :: PROK, PROKG, PRINT_MAXAVG INTEGER, INTENT(IN) :: MP, MPG, INFO16, INFOG18, INFOG19 INTEGER, INTENT(IN) :: IRANK, NSLAVES INTEGER, INTENT(IN) :: KEEP(500) C IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' ** Memory allocated, max in Mbytes (INFOG(18)):', & INFOG18 ENDIF WRITE( MPG,'(/A,I12) ') & ' ** Memory allocated, total in Mbytes (INFOG(19)):', & INFOG19 END IF RETURN END SUBROUTINE CMUMPS_PRINT_ALLOCATED_MEM SUBROUTINE CMUMPS_AVGMAX_STAT8(PROKG, MPG, VAL, NSLAVES, & PRINT_MAXAVG, COMM, MSG) IMPLICIT NONE INCLUDE 'mpif.h' LOGICAL, intent(in) :: PROKG INTEGER, intent(in) :: MPG INTEGER(8), intent(in) :: VAL INTEGER, intent(in) :: NSLAVES LOGICAL, intent(in) :: PRINT_MAXAVG INTEGER, intent(in) :: COMM CHARACTER*48 MSG C Local INTEGER(8) MAX_VAL INTEGER IERR, MASTER REAL LOC_VAL, AVG_VAL PARAMETER(MASTER=0) C CALL MUMPS_REDUCEI8( VAL, MAX_VAL, MPI_MAX, MASTER, COMM) LOC_VAL = real(VAL)/real(NSLAVES) CALL MPI_REDUCE( LOC_VAL, AVG_VAL, 1, MPI_REAL, & MPI_SUM, MASTER, COMM, IERR ) IF (PROKG) THEN IF (PRINT_MAXAVG) THEN WRITE(MPG,100) " Average", MSG, int(AVG_VAL,8) ELSE WRITE(MPG,110) MSG, MAX_VAL ENDIF ENDIF RETURN 100 FORMAT(A8,A48,I18) 110 FORMAT(A48,I18) END SUBROUTINE CMUMPS_AVGMAX_STAT8 C C C ================================================================== C SUBROUTINE CMUMPS_EXTRACT_SCALING(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C Extract distributed scaling arrays from CMUMPS_EXTRACT_SCALING C In case of unsymmetric permutation, ROWSCA and COLSCA correspond C to Dr and Dc, in the expression Dr A Q Dc. In other terms, Dc C is compatbile with the front column indices, it does not C correspond to the column indices of A, meaning that Q is not C needed to just extract the scaling values. C C TYPE(CMUMPS_STRUC) :: id INTEGER, EXTERNAL :: MUMPS_PROCNODE C C MPI C === C INCLUDE 'mpif.h' C C Local declarations C ================== C REAL, DIMENSION(:), POINTER :: COLSCA REAL, DIMENSION(:), POINTER :: ROWSCA INTEGER, PARAMETER :: MASTER = 0 C INTEGER :: ISTEP, NPIV, LIELL INTEGER :: IERR_MPI, allocok INTEGER :: ISCA INTEGER :: JROW, JCOL, IPOS, JJ ! access to IS INTEGER :: LIW_PASSED INTEGER(8) :: LALLOC C C Free and reallocate distributed scaling arrays : C - in symmetric, COLSCA_loc points on ROWSCA_loc. C - not allocated if KEEP(89)=0 C NULLIFY(ROWSCA) NULLIFY(COLSCA) IF (associated(id%ROWSCA_loc)) THEN DEALLOCATE(id%ROWSCA_loc) NULLIFY(id%ROWSCA_loc) ENDIF IF (associated(id%COLSCA_loc)) THEN IF (id%KEEP(50) .EQ. 0) THEN DEALLOCATE(id%COLSCA_loc) ENDIF NULLIFY(id%COLSCA_loc) ENDIF C id%ROWSCA and id%COLSCA are available on master, C allocate ROWSCA and COLSCA of order N on other procs IF ( id%MYID .EQ. MASTER ) THEN ROWSCA => id%ROWSCA COLSCA => id%COLSCA IF (.NOT. associated(ROWSCA)) THEN WRITE(*,*) "Internal error 1 in CMUMPS_EXTRACT_SCALING" CALL MUMPS_ABORT() ENDIF IF (.NOT. associated(COLSCA)) THEN WRITE(*,*) "Internal error 2 in CMUMPS_EXTRACT_SCALING" CALL MUMPS_ABORT() ENDIF ELSE IF (id%KEEP(50).EQ.0) THEN ALLOCATE(ROWSCA(id%N),COLSCA(id%N),stat=allocok) LALLOC = int(id%N+id%N,8) ELSE ALLOCATE(ROWSCA(id%N),stat=allocok) COLSCA => ROWSCA LALLOC = int(id%N,8) ENDIF IF (allocok .GT. 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(LALLOC,id%INFO(2)) ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C Jump to 110 in case of error on ROWSCA or COLSCA C on one of the MPI processes. IF (id%INFO(1) .LT. 0) GOTO 110 C IF ( id%KEEP(89) .GT. 0) THEN IF (id%KEEP(50).EQ.0) THEN ALLOCATE(id%ROWSCA_loc(id%KEEP(89)), & id%COLSCA_loc(id%KEEP(89)),stat=allocok) LALLOC = int(id%KEEP(89),8)*2_8 ELSE ALLOCATE(id%ROWSCA_loc(id%KEEP(89)),stat=allocok) id%COLSCA_loc => id%ROWSCA_loc LALLOC = int(id%KEEP(89),8) ENDIF IF (allocok .GT. 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(LALLOC,id%INFO(2)) ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C Jump to 100 in case of error (we free everything) IF (id%INFO(1) .LT. 0) GOTO 100 CALL MPI_BCAST(ROWSCA(1), id%N, MPI_REAL, & MASTER, id%COMM, IERR_MPI) IF (id%KEEP(50) .EQ. 0) THEN CALL MPI_BCAST(COLSCA(1), id%N, MPI_REAL, & MASTER, id%COMM, IERR_MPI) ENDIF LIW_PASSED = max(id%KEEP(32),1) ISCA = 1 IF ( id%MYID .ne. MASTER .OR. & id%KEEP(46) .eq. 1 ) THEN ! I_AM_SLAVE DO ISTEP = 1, id%KEEP(28) IF ( id%MYID_NODES.EQ. MUMPS_PROCNODE( & id%PROCNODE_STEPS(ISTEP), & id%KEEP(199) ) ) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, id%KEEP, & NPIV, LIELL, IPOS, & id%IS(1), LIW_PASSED, id%PTLUST_S(1), id%STEP(1), id%N) IF ( id%KEEP(50) .EQ. 0 ) THEN C Row indices: JROW = IPOS + 1 C Column indices: JCOL = IPOS + 1 + LIELL ELSE C Use row indices because column indices may have C been set to negative to flag 2x2 pivots JROW = IPOS + 1 ENDIF IF (id%KEEP(50).EQ.0) THEN DO JJ = 1, NPIV id%ROWSCA_loc(ISCA+JJ-1) = ROWSCA(id%IS(JROW+JJ-1)) id%COLSCA_loc(ISCA+JJ-1) = COLSCA(id%IS(JCOL+JJ-1)) ENDDO ELSE DO JJ = 1, NPIV id%ROWSCA_loc(ISCA+JJ-1) = ROWSCA(id%IS(JROW+JJ-1)) ENDDO ENDIF ISCA = ISCA + NPIV ENDIF ENDDO ENDIF C End of EXTRACT_SCALING, we keep id%ROWSCA_loc and id%COLSCA_loc C but free ROWSCA and COLSCA GOTO 110 RETURN 100 CONTINUE C Exit with error, free what was allocated IF (associated(id%ROWSCA_loc)) THEN DEALLOCATE(id%ROWSCA_loc) NULLIFY(id%ROWSCA_loc) ENDIF IF (associated(id%COLSCA_loc)) THEN IF (id%KEEP(50) .EQ. 0) THEN DEALLOCATE(id%COLSCA_loc) ENDIF NULLIFY(id%COLSCA_loc) ENDIF 110 CONTINUE C Free local ROWSCA and COLSCA arrays IF ( id%MYID .NE. 0) THEN IF (associated(ROWSCA)) DEALLOCATE(ROWSCA) IF ( id%KEEP(50) .EQ. 0 ) THEN IF (associated(COLSCA)) DEALLOCATE(COLSCA) ENDIF ENDIF NULLIFY(ROWSCA) NULLIFY(COLSCA) RETURN END SUBROUTINE CMUMPS_EXTRACT_SCALING C C ================================================================== C SUBROUTINE CMUMPS_EXTRACT_SCHUR_REDRHS(id,idintr) USE CMUMPS_STRUC_DEF USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_INTR_STRUC IMPLICIT NONE C C Purpose C ======= C C Extract the Schur and possibly also the reduced right-hand side C (if Fwd in facto) from the processor working on Schur and copy C it into the user datastructures id%SCHUR and id%REDRHS on the host. C This routine assumes that the integer list of the Schur has not C been permuted and still corresponds to LISTVAR_SCHUR. C C If the Schur is centralized, the master of the Schur holds the C Schur and possibly also the reduced right-hand side. C If the Schur is distribued (already built in user's datastructure), C then the master of the Schur may hold the reduced right-hand side, C in which case it is available in roota%RHS_CNTR_MASTER_ROOT. C TYPE (CMUMPS_STRUC) :: id TYPE (CMUMPS_INTR_STRUC) :: idintr C C Local variables C =============== C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ID_SCHUR, SIZE_SCHUR, LD_SCHUR, IB, BL4 INTEGER(4) :: I4 ! 32-bit even in 64-bit version INTEGER :: ROW_LENGTH, I INTEGER(8) :: SURFSCHUR8, BL8, SHIFT8 INTEGER(8) :: ISCHUR_SRC, ISCHUR_DEST, ISCHUR_SYM, ISCHUR_UNS C C External functions C ================== C INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE C Quick return in case factorization did not terminate correctly IF (id%INFO(1) .LT. 0) RETURN C Quick return if Schur option off IF (id%KEEP(60) .EQ. 0) RETURN C Get Schur id ID_SCHUR =MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(max(id%KEEP(20),id%KEEP(38)))), & id%KEEP(199)) IF ( id%KEEP( 46 ) .NE. 1 ) THEN ID_SCHUR = ID_SCHUR + 1 END IF C Get size of Schur IF (id%MYID.EQ.ID_SCHUR) THEN IF (id%KEEP(60).EQ.1) THEN C Sequential Schur LD_SCHUR = & id%IS(id%PTLUST_S(id%STEP(id%KEEP(20)))+2+id%KEEP(IXSZ)) SIZE_SCHUR = LD_SCHUR - id%KEEP(253) ELSE C Parallel Schur LD_SCHUR = -999999 ! not used SIZE_SCHUR = idintr%root%TOT_ROOT_SIZE ENDIF ELSE IF (id%MYID .EQ. MASTER) THEN SIZE_SCHUR = id%KEEP(116) LD_SCHUR = -44444 ! Not used ELSE C Proc is not concerned with Schur, return RETURN ENDIF SURFSCHUR8 = int(SIZE_SCHUR,8)*int(SIZE_SCHUR,8) C ===================================== C Case of parallel Schur: if REDRHS C was requested, obtain it directly C from idintr%roota%RHS_CNTR_MASTER_ROOT C ===================================== IF (id%KEEP(60) .GT. 1) THEN IF (id%KEEP(221).EQ.1 .AND. id%KEEP(252).GT.0) THEN DO I = 1, id%KEEP(253) IF (ID_SCHUR.EQ.MASTER) THEN ! Necessarily = id%MYID CALL ccopy(SIZE_SCHUR, & idintr%roota%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), 1, & id%REDRHS((I-1)*id%LREDRHS+1), 1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN C Send CALL MPI_SEND( & idintr%roota%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), & SIZE_SCHUR, & MPI_COMPLEX, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE ! MYID.EQ.MASTER C Receive CALL MPI_RECV( id%REDRHS((I-1)*id%LREDRHS+1), & SIZE_SCHUR, & MPI_COMPLEX, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF ENDDO C ------------------------------ C In case of parallel Schur, we C free roota%RHS_CNTR_MASTER_ROOT C ------------------------------ IF (id%MYID.EQ.ID_SCHUR) THEN DEALLOCATE(idintr%roota%RHS_CNTR_MASTER_ROOT) NULLIFY (idintr%roota%RHS_CNTR_MASTER_ROOT) ENDIF ENDIF C return because this is all we need to do C in case of parallel Schur complement RETURN ENDIF C ============================ C Centralized Schur complement C ============================ C PTRAST has been freed at the moment of calling this C routine. Schur is available through C PTRFAC(IW( PTLUST_S( STEP(KEEP(20)) ) + 4 +KEEP(IXSZ) )) IF (id%KEEP(252).EQ.0) THEN C CASE 1 (ORIGINAL CODE): C Schur is contiguous on ID_SCHUR IF ( ID_SCHUR .EQ. MASTER ) THEN ! Necessarily equals id%MYID C --------------------- C Copy Schur complement C --------------------- CALL CMUMPS_COPYI8SIZE( SURFSCHUR8, & id%S(id%PTRFAC(id%STEP(id%KEEP(20)))), & id%SCHUR(1) ) ELSE C ----------------------------------------- C The processor responsible of the Schur C complement sends it to the host processor C Use blocks to avoid too large messages. C ----------------------------------------- BL8=int(huge(I4)/id%KEEP(35)/10,8) DO IB=1, int((SURFSCHUR8+BL8-1_8) / BL8) SHIFT8 = int(IB-1,8) * BL8 ! Where to send BL4 = int(min(BL8,SURFSCHUR8-SHIFT8)) ! Size of block IF ( id%MYID .eq. ID_SCHUR ) THEN C Send Schur complement CALL MPI_SEND( id%S( SHIFT8 + & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ)))), & BL4, & MPI_COMPLEX, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE IF ( id%MYID .eq. MASTER ) THEN C Receive Schur complement CALL MPI_RECV( id%SCHUR(1_8 + SHIFT8), & BL4, & MPI_COMPLEX, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) END IF ENDDO END IF ELSE C CASE 2 (Fwd in facto): Schur is not contiguous on ID_SCHUR, C process it row by row. C C 2.1: We first centralize Schur complement into id%SCHUR ISCHUR_SRC = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) ISCHUR_DEST= 1_8 DO I=1, SIZE_SCHUR ROW_LENGTH = SIZE_SCHUR IF (ID_SCHUR.EQ.MASTER) THEN ! Necessarily = id%MYID CALL ccopy(ROW_LENGTH, id%S(ISCHUR_SRC), 1, & id%SCHUR(ISCHUR_DEST),1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN C Send CALL MPI_SEND( id%S(ISCHUR_SRC), ROW_LENGTH, & MPI_COMPLEX, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE C Recv CALL MPI_RECV( id%SCHUR(ISCHUR_DEST), & ROW_LENGTH, & MPI_COMPLEX, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF ISCHUR_SRC = ISCHUR_SRC+int(LD_SCHUR,8) ISCHUR_DEST= ISCHUR_DEST+int(SIZE_SCHUR,8) ENDDO C 2.2: Get REDRHS on host C 2.2.1: Symmetric => REDRHS is available in last KEEP(253) C rows of Schur structure on ID_SCHUR C 2.2.2: Unsymmetric => REDRHS corresponds to last KEEP(253) C columns. However it must be transposed. IF (id%KEEP(221).EQ.1) THEN ! Implies Fwd in facto ISCHUR_SYM = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) * & int(LD_SCHUR,8) ISCHUR_UNS = & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) ISCHUR_DEST = 1_8 DO I = 1, id%KEEP(253) IF (ID_SCHUR .EQ. MASTER) THEN ! necessarily = id%MYID IF (id%KEEP(50) .EQ. 0) THEN CALL ccopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, & id%REDRHS(ISCHUR_DEST), 1) ELSE CALL ccopy(SIZE_SCHUR, id%S(ISCHUR_SYM), 1, & id%REDRHS(ISCHUR_DEST), 1) ENDIF ELSE IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(50) .EQ. 0) THEN C Use id%S(ISCHUR_SYM) as temporary contig. workspace C of size SIZE_SCHUR. CALL ccopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, & id%S(ISCHUR_SYM), 1) ENDIF CALL MPI_SEND(id%S(ISCHUR_SYM), SIZE_SCHUR, & MPI_COMPLEX, MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE CALL MPI_RECV(id%REDRHS(ISCHUR_DEST), & SIZE_SCHUR, MPI_COMPLEX, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF IF (id%KEEP(50).EQ.0) THEN ISCHUR_UNS = ISCHUR_UNS + int(LD_SCHUR,8) ELSE ISCHUR_SYM = ISCHUR_SYM + int(LD_SCHUR,8) ENDIF ISCHUR_DEST = ISCHUR_DEST + int(id%LREDRHS,8) ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_EXTRACT_SCHUR_REDRHS SUBROUTINE CMUMPS_EXTRACT_SINGULAR_VALUES(id,idintr) USE CMUMPS_STRUC_DEF USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_INTR_STRUC IMPLICIT NONE C C Purpose C ======= C C TYPE (CMUMPS_STRUC) :: id TYPE (CMUMPS_INTR_STRUC) :: idintr C C Local variables C =============== C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ID_ROOT, ALLOCOK C C External functions C ================== C INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE C Quick return in case factorization did not terminate correctly IF (id%INFO(1) .LT. 0) RETURN C Quick return if Postponing + rank revealing option off IF (id%KEEP(19) .EQ. 0) RETURN C Get Root id ID_ROOT =MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(id%KEEP(20))), & id%KEEP(199)) IF ( id%KEEP( 46 ) .NE. 1 ) THEN ID_ROOT = ID_ROOT + 1 END IF C ================================= C Singular values are stored in C roota%SINGULAR_VALUES C We copy it to id%SINGULAR_VALUES C ================================= IF ((ID_ROOT.EQ.id%MYID).AND.(id%MYID.EQ.MASTER)) THEN C write(6,*) " singular_values already on host" IF (associated(id%SINGULAR_VALUES)) & DEALLOCATE(id%SINGULAR_VALUES) NULLIFY(id%SINGULAR_VALUES) id%NB_SINGULAR_VALUES=idintr%root%NB_SINGULAR_VALUES ALLOCATE(id%SINGULAR_VALUES(id%NB_SINGULAR_VALUES) & , stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN id%INFO(1)=-13 id%INFO(2)= id%NB_SINGULAR_VALUES RETURN END IF CALL scopy(id%NB_SINGULAR_VALUES, & idintr%roota%SINGULAR_VALUES(1), 1, & id%SINGULAR_VALUES(1), 1) ELSE IF (id%MYID.EQ.ID_ROOT) THEN C Send C write(6,*) " id%MYID sends singular_values " CALL MPI_SEND( & idintr%root%NB_SINGULAR_VALUES, & 1, & MPI_INTEGER, & MASTER, TAG_ROOT1, & id%COMM, IERR ) CALL MPI_SEND( & idintr%roota%SINGULAR_VALUES(1), & idintr%root%NB_SINGULAR_VALUES, & MPI_REAL, & MASTER, TAG_ROOT2, & id%COMM, IERR ) ELSEIF (id%MYID.EQ.MASTER) THEN C Receive CALL MPI_RECV( id%NB_SINGULAR_VALUES, & 1, & MPI_INTEGER, ID_ROOT, TAG_ROOT1, & id%COMM, STATUS, IERR ) IF (associated(id%SINGULAR_VALUES)) & DEALLOCATE(id%SINGULAR_VALUES) NULLIFY(id%SINGULAR_VALUES) ALLOCATE(id%SINGULAR_VALUES(id%NB_SINGULAR_VALUES) & , stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN id%INFO(1)=-13 id%INFO(2)= id%NB_SINGULAR_VALUES RETURN END IF CALL MPI_RECV( id%SINGULAR_VALUES(1), & id%NB_SINGULAR_VALUES, & MPI_REAL, ID_ROOT, TAG_ROOT2, & id%COMM, STATUS, IERR ) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_EXTRACT_SINGULAR_VALUES SUBROUTINE CMUMPS_SET_NOMP_MAX(KEEP281, KEEP361, & N, NOMP_MAX) !$ USE OMP_LIB C C Purpose C ======= C set NOMP_MAX from KEEP(281) C on output NOMP_MAX >=0 C C Parameters C ========== C INTEGER, INTENT(IN) :: KEEP281, KEEP361, N INTEGER, INTENT(OUT) :: NOMP_MAX C C Local variables C INTEGER :: NOMP C C out-of-range entries treated as -1 NOMP_MAX= max(-1, KEEP281) NOMP = 1 !$ NOMP = omp_get_max_threads() IF (NOMP_MAX.EQ.-1) THEN C automatic setting IF (N.LE.KEEP361) THEN NOMP_MAX = 0 RETURN ENDIF IF (NOMP.GT.1) THEN C conservative because of memory allocation NOMP_MAX = min(NOMP, 10) ELSE C no multithreading and all parallel do suppressed NOMP_MAX = 0 ENDIF ELSE C NOMP_MAX >=0 C use provided value NOMP_MAX = min(NOMP_MAX, NOMP) ENDIF C RETURN END SUBROUTINE CMUMPS_SET_NOMP_MAX MUMPS_5.8.1/src/sfac_b.F0000664000175000017500000006127415042446437014574 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_FAC_B( N, S_IS_POINTERS, LA, LIW, SYM_PERM, & NA, LNA, NE_STEPS, NFSIZ, FILS, STEP, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PTRAR, LDPTRAR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, PTRIST, & PTLUST_S, PTRFAC, IW1, IW2, ITLOC, RHS_MUMPS, POOL, LPOOL, & CNTL1, ICNTL, INFO, RINFO, KEEP, KEEP8, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & SMUMPS_LBUF, INTARR, DBLARR, root, roota, NELT, FRTPTR, FRTELT, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, & DKEEP, PIVNUL_LIST_STRUCT, LRGROUPS & ,IPOOL_B_L0_OMP, LPOOL_B_L0_OMP, IPOOL_A_L0_OMP, & LPOOL_A_L0_OMP, L_VIRT_L0_OMP, VIRT_L0_OMP, & VIRT_L0_OMP_MAPPING, L_PHYS_L0_OMP, PHYS_L0_OMP, PERM_L0_OMP, & PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, THREAD_LA, & L0_OMP_FACTORS, LL0_OMP_FACTORS, I4_L0_OMP, NBSTATS_I4, & NBCOLS_I4, I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) USE MUMPS_LOAD USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_ALLOC_CB, & MUMPS_BUF_DEALL_CB USE SMUMPS_BUF, ONLY : SMUMPS_BUF_MAX_ARRAY_MINSIZE & , SMUMPS_BUF_DEALL_MAX_ARRAY USE SMUMPS_FAC_S_IS_POINTERS_M, ONLY : SMUMPS_S_IS_POINTERS_T USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T USE OMP_LIB USE MUMPS_TPS_M USE SMUMPS_TPS_M USE SMUMPS_FAC_OMP_M USE SMUMPS_DYNAMIC_MEMORY_M, ONLY: SMUMPS_DM_ALLOC_S_WK, & SMUMPS_DM_FREE_S_WK USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC & , SMUMPS_L0OMPFAC_T IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER(8) :: LA INTEGER N,LIW,LPOOL,SLAVEF,COMM_NODES INTEGER MYID, MYID_NODES,LNA TYPE (SMUMPS_S_IS_POINTERS_T) :: S_IS_POINTERS REAL RINFO(40) INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES INTEGER :: BUFR( LBUFR ) INTEGER, INTENT( IN ) :: SMUMPS_LBUF INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER NELT, LDPTRAR INTEGER FRTPTR(*), FRTELT(*) REAL CNTL1 INTEGER ICNTL(60) INTEGER INFO(80), KEEP(500) INTEGER(8) KEEP8(150) INTEGER LRGROUPS(KEEP(280)) INTEGER SYM_PERM(N), NA(LNA), & NE_STEPS(KEEP(28)), FILS(N), & FRERE(KEEP(28)), NFSIZ(KEEP(28)), & DAD(KEEP(28)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER STEP(N) INTEGER(8), INTENT(IN) :: PTRAR(LDPTRAR,2) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IW1(2*KEEP(28)), ITLOC(N+KEEP(253)), POOL(LPOOL) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: IW2(2*KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER COMM_LOAD, ASS_IRECV INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) REAL SEUIL, SEUIL_LDLT_NIV2 TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER, INTENT (IN) :: LPOOL_B_L0_OMP INTEGER, INTENT (IN) :: IPOOL_B_L0_OMP( LPOOL_B_L0_OMP ) INTEGER, INTENT (IN) :: LPOOL_A_L0_OMP INTEGER, INTENT (IN) :: IPOOL_A_L0_OMP( LPOOL_A_L0_OMP ) INTEGER, INTENT (IN) :: L_PHYS_L0_OMP INTEGER, INTENT (IN) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT (IN) :: L_VIRT_L0_OMP INTEGER, INTENT (IN) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT (IN) :: VIRT_L0_OMP_MAPPING( L_VIRT_L0_OMP ) INTEGER, INTENT (IN) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT (IN) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT (IN) :: LL0_OMP_MAPPING INTEGER, INTENT (OUT):: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INTEGER, INTENT (IN) :: LL0_OMP_FACTORS TYPE(SMUMPS_L0OMPFAC_T), INTENT (INOUT) :: L0_OMP_FACTORS( & LL0_OMP_FACTORS ) INTEGER, INTENT (IN) :: NBSTATS_I4, NBSTATS_I8 INTEGER, INTENT (IN) :: NBCOLS_I4, NBCOLS_I8 INTEGER, INTENT (IN) :: I4_L0_OMP(NBSTATS_I4, NBCOLS_I4) INTEGER(8), INTENT (IN) :: I8_L0_OMP(NBSTATS_I8, NBCOLS_I8) INTEGER(8), INTENT ( IN ) :: THREAD_LA INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER allocok REAL UULOC INTEGER IERR INTEGER LP, MPRINT LOGICAL LPOK INTEGER NSTK,PTRAST INTEGER PIMASTER, PAMASTER LOGICAL PROK REAL,PARAMETER :: ZERO = 0.0E0 INTEGER I INTEGER LTPS_ARR TYPE (MUMPS_TPS_T), DIMENSION(:), ALLOCATABLE :: MUMPS_TPS_ARR TYPE (SMUMPS_TPS_T), DIMENSION(:), ALLOCATABLE :: SMUMPS_TPS_ARR INTEGER NBROOT_UNDER_L0 INTEGER :: NSTEPSDONE DOUBLE PRECISION :: OPASS, OPELI INTEGER :: NELVA, COMP INTEGER :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV, NULLNEGPV INTEGER :: NB22T1, NB22T2, NBTINY, DET_EXP, DET_SIGN REAL :: DET_MANT INTEGER :: NTOTPVTOT INTEGER(8) :: POSFAC, LRLU, IPTRLU, LRLUS INTEGER IWPOS, LEAF, NBROOT, NROOT INTEGER :: LIW_ARG_FAC_PAR INTEGER(8) :: LA_ARG_FAC_PAR REAL, TARGET:: CDUMMY(1) INTEGER, TARGET :: IDUMMY(1) LOGICAL :: IW_DUMMY, A_DUMMY, & IW_ALLOCATED_HERE, A_ALLOCATED_HERE KEEP(41)=0 KEEP(42)=0 LP = ICNTL(1) LPOK = (LP.GT.0) .AND. (ICNTL(4).GE.1) MPRINT = ICNTL(2) PROK = (MPRINT.GT.0) .AND. (ICNTL(4).GE.2) UULOC = CNTL1 PIMASTER = 1 NSTK = PIMASTER + KEEP(28) PTRAST = 1 PAMASTER = 1 + KEEP(28) IF (KEEP(4).LE.0) KEEP(4)=32 IF (KEEP(5).LE.0) KEEP(5)=16 IF (KEEP(5).GT.KEEP(4)) KEEP(5) = KEEP(4) IF (KEEP(6).LE.0) KEEP(6)=24 IF (KEEP(3).LE.KEEP(4)) KEEP(3)=KEEP(4)*2 IF (KEEP(6).GT.KEEP(3)) KEEP(6) = KEEP(3) POSFAC = 1_8 IWPOS = 1 LRLU = LA LRLUS = LRLU KEEP8(62) = 0_8 KEEP8(63) = 0_8 KEEP8(64) = 0_8 KEEP8(65) = 0_8 KEEP8(66) = 0_8 KEEP8(68) = 0_8 KEEP8(69) = 0_8 KEEP8(70) = 0_8 KEEP8(71) = 0_8 KEEP8(73) = 0_8 KEEP8(74) = 0_8 IPTRLU = LRLU DKEEP(19)=huge(0.0E0) DKEEP(20)=huge(0.0E0) DKEEP(21)=0.0E0 NSTEPSDONE = 0 OPASS = 0.0D0 OPELI = 0.0D0 NELVA = 0 COMP = 0 MAXFRT = 0 NMAXNPIV = 0 NTOTPV = 0 NOFFNEGPV = 0 NULLNEGPV = 0 NB22T1 = 0 NB22T2 = 0 NBTINY = 0 DET_EXP = 0 DET_SIGN = 1 DET_MANT = 1.0E0 IW1(NSTK:NSTK+KEEP(28)-1) = NE_STEPS(1:KEEP(28)) CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, NROOT, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP, STEP, & PROCNODE_STEPS) IF (KEEP(400) .GT. 0 & ) THEN IF (LPOOL .NE. LPOOL_A_L0_OMP) THEN WRITE(*,*) "Check LPOOL vs. LPOOL_A_L0_OMP", & LPOOL, LPOOL_A_L0_OMP, KEEP(28) CALL MUMPS_ABORT() ENDIF DO I = 1, LPOOL POOL(I) = IPOOL_A_L0_OMP(I) ENDDO ELSE CALL MUMPS_INIT_POOL_DIST(N, LEAF, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, & POOL, LPOOL) CALL SMUMPS_INIT_POOL_LAST3(POOL, LPOOL, LEAF) ENDIF CALL MUMPS_LOAD_INIT_SBTR_STRUCT(POOL, LPOOL,KEEP,KEEP8) IF ( KEEP( 38 ) .NE. 0 ) THEN NBROOT = NBROOT + root%NPROW * root%NPCOL - 1 END IF IF ( root%yes ) THEN IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(KEEP(38))), & KEEP(199) ) & .NE. MYID_NODES ) THEN NROOT = NROOT + 1 END IF END IF PTRIST(1:KEEP(28))=0 PTLUST_S(1:KEEP(28))=0 PTRFAC(1:KEEP(28))=-99999_8 IW2(PTRAST:PTRAST+KEEP(28)-1)=0_8 IW1(PIMASTER:PIMASTER+KEEP(28)-1)=-99999_8 KEEP(405) = 0 NBROOT_UNDER_L0 = 0 IF (KEEP(400).GT.0 & ) THEN KEEP(405)=1 ALLOCATE( MUMPS_TPS_ARR( KEEP(400) ), stat=allocok ) IF (allocok .GT. 0) THEN IF (LPOK) THEN WRITE(LP,*) "Problem allocating MUMPS_TPS_ARR", & KEEP(400) ENDIF CALL MUMPS_ABORT() ENDIF ALLOCATE( SMUMPS_TPS_ARR( KEEP(400) ), stat=allocok ) IF (allocok .GT. 0) THEN WRITE(*,*) "Problem allocating SMUMPS_TPS_ARR", KEEP(400) CALL MUMPS_ABORT() ENDIF CALL SMUMPS_FAC_L0_OMP(N,LIW, IW1(NSTK), NFSIZ, FILS,STEP,FRERE, & DAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, PTRIST, IW2(PTRAST), & IW1(PIMASTER), IW2(PAMASTER), PTRAR(1,2), PTRAR(1,1), & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, RINFO, NROOT, NBROOT, NBROOT_UNDER_L0, & UULOC, ICNTL, PTLUST_S, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS,SLAVEF, COMM_NODES, MYID, MYID_NODES, BUFR, & LBUFR,LBUFR_BYTES,INTARR,DBLARR,root,roota,SYM_PERM,NELT,FRTPTR, & FRTELT, LDPTRAR, COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB, NE_STEPS, DKEEP, PIVNUL_LIST_STRUCT, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, L_VIRT_L0_OMP, & VIRT_L0_OMP, VIRT_L0_OMP_MAPPING, L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, & THREAD_LA, MUMPS_TPS_ARR, SMUMPS_TPS_ARR, NSTEPSDONE, & OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, NOFFNEGPV, & NULLNEGPV, NB22T1, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & LRGROUPS(1), L0_OMP_FACTORS, LL0_OMP_FACTORS, & I4_L0_OMP, NBSTATS_I4, NBCOLS_I4, & I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 ) KEEP(405)=0 DKEEP(16) = OPELI KEEP8(75)=KEEP8(76) KEEP8(63)=KEEP8(74) KEEP8(62) = KEEP8(74)-KEEP8(62) IF (INFO(1) .LT. 0) THEN KEEP8(69) = KEEP8(73) ENDIF KEEP8(74) = KEEP8(73) IF ((INFO(1).GE.0).AND.(KEEP8(74).GT.KEEP8(75))) THEN INFO(1) = -19 CALL MUMPS_SET_IERROR ( & KEEP8(74)-KEEP8(75), INFO(2)) IF (LPOK) THEN WRITE(LP,'(/A/,A,I8,A,I10/,A/,A/)') & '** ERROR: memory allowed (ICNTL(23)) is not large enough:', & ' INFO(1)=', INFO(1), ' INFO(2)=', INFO(2), & ' memory used at the end of the treatment of L0 thread ', & ' does not enable processing nodes above L0 thread ' ENDIF ENDIF KEEP8(66) = KEEP8(68) KEEP8(65) = KEEP8(64) + KEEP8(71) ENDIF KEEP8(67) = LRLUS IW_ALLOCATED_HERE = .FALSE. A_ALLOCATED_HERE = .FALSE. IF (associated(S_IS_POINTERS%IW)) THEN WRITE(*,*) " Internal error SMUMPS_FAC_B IW" CALL MUMPS_ABORT() ENDIF IF (INFO(1) .GE. 0 ) THEN ALLOCATE(S_IS_POINTERS%IW(LIW), stat=allocok) IF (allocok .GT.0) THEN INFO(1) = -13 INFO(2) = LIW IF (LPOK) THEN WRITE(LP,*) & 'Allocation error for id%IS(',LIW,') on worker', & MYID_NODES ENDIF ELSE IW_ALLOCATED_HERE = .TRUE. ENDIF ENDIF IF (INFO(1) .GE. 0) THEN IF (.NOT. associated(S_IS_POINTERS%A)) THEN CALL SMUMPS_DM_ALLOC_S_WK(S_IS_POINTERS%A, & LA, allocok, KEEP(430), KEEP(35) ) IF (allocok .GT. 0) THEN INFO(1) = -13 CALL MUMPS_SETI8TOI4(LA, INFO(2)) DEALLOCATE(S_IS_POINTERS%IW); NULLIFY(S_IS_POINTERS%IW) IW_ALLOCATED_HERE = .FALSE. KEEP8(23)=0_8 ELSE A_ALLOCATED_HERE = .TRUE. KEEP8(23)=LA ENDIF ENDIF ENDIF IF (INFO(1) .GE. 0) THEN CALL MUMPS_BUF_ALLOC_CB( SMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1)= -13 INFO(2)= (SMUMPS_LBUF+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) & 'Allocation error in SMUMPS_BUF_ALLOC_CB' & ,INFO(2), ' on worker', MYID_NODES ENDIF ELSE IF ((KEEP(50).EQ.2).AND.(KEEP(219).NE.0)) THEN CALL SMUMPS_BUF_MAX_ARRAY_MINSIZE(max(KEEP(108),1),IERR) IF (IERR .NE. 0) THEN INFO(1) = -13 INFO(2) = max(KEEP(108),1) END IF ENDIF ENDIF ENDIF IF ( KEEP(400) .EQ. 0 & ) THEN LTPS_ARR = 1 ALLOCATE( MUMPS_TPS_ARR(1)) ALLOCATE(SMUMPS_TPS_ARR(1)) ELSE LTPS_ARR = KEEP(400) ENDIF IW_DUMMY = .FALSE.; A_DUMMY = .FALSE.; IF (INFO(1) .GE. 0) THEN LIW_ARG_FAC_PAR = LIW LA_ARG_FAC_PAR = LA ELSE IF (IW_ALLOCATED_HERE) THEN DEALLOCATE(S_IS_POINTERS%IW) NULLIFY(S_IS_POINTERS%IW) IW_ALLOCATED_HERE = .FALSE. ENDIF IF (A_ALLOCATED_HERE) THEN CALL SMUMPS_DM_FREE_S_WK(S_IS_POINTERS%A, KEEP(430)) NULLIFY(S_IS_POINTERS%A) A_ALLOCATED_HERE = .FALSE. ENDIF LIW_ARG_FAC_PAR = 1 LA_ARG_FAC_PAR = 1_8 IF (.NOT. associated(S_IS_POINTERS%IW)) THEN S_IS_POINTERS%IW => IDUMMY IW_DUMMY = .TRUE. ENDIF IF (.NOT. associated(S_IS_POINTERS%A)) THEN S_IS_POINTERS%A => CDUMMY A_DUMMY = .TRUE. ENDIF ENDIF IF ( INFO(1) .LT. 0 ) THEN CALL SMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP ) ENDIF KEEP(398)=NSTEPSDONE CALL SMUMPS_FAC_PAR_I(N,S_IS_POINTERS%IW(1),LIW_ARG_FAC_PAR, & S_IS_POINTERS%A(1),LA_ARG_FAC_PAR,IW1(NSTK), NFSIZ,FILS,STEP, & FRERE,DAD,CAND,ISTEP_TO_INIV2, TAB_POS_IN_PERE, NSTEPSDONE, & OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, NOFFNEGPV, & NULLNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & PTRIST, IW2(PTRAST), IW1(PIMASTER), IW2(PAMASTER), & PTRAR(1,2), PTRAR(1,1), PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, POOL, LPOOL, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & MUMPS_TPS_ARR, SMUMPS_TPS_ARR, LTPS_ARR, & RINFO, POSFAC, IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NROOT, NBROOT, & NBROOT_UNDER_L0, & UULOC, ICNTL, PTLUST_S, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS,SLAVEF,MYID,COMM_NODES, MYID_NODES, BUFR, LBUFR, & LBUFR_BYTES, INTARR, DBLARR, root, roota, SYM_PERM, NELT, FRTPTR, & FRTELT, LDPTRAR, COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB,NE_STEPS, DKEEP(1),PIVNUL_LIST_STRUCT, & LRGROUPS(1) ) IF (IW_DUMMY) THEN NULLIFY( S_IS_POINTERS%IW ) ENDIF IF (A_DUMMY) THEN NULLIFY( S_IS_POINTERS%A ) ENDIF IF ((KEEP(50).EQ.2).AND.(KEEP(219).NE.0)) THEN CALL SMUMPS_BUF_DEALL_MAX_ARRAY() ENDIF CALL MUMPS_BUF_DEALL_CB( IERR ) RINFO(2) = real(OPASS) RINFO(3) = real(OPELI) INFO(13) = NELVA INFO(14) = COMP KEEP(33) = MAXFRT; INFO(11) = MAXFRT KEEP(246) = NMAXNPIV KEEP(89) = NTOTPV; INFO(23) = NTOTPV INFO(12) = NOFFNEGPV INFO(40) = NULLNEGPV KEEP(103) = NB22T1 KEEP(105) = NB22T2 KEEP(98) = NBTINY IF (KEEP(258) .NE. 0) THEN KEEP(260) = KEEP(260) * DET_SIGN KEEP(259) = KEEP(259) + DET_EXP CALL SMUMPS_UPDATEDETER( DET_MANT, DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(400) .GT. 0 & ) THEN IF (LL0_OMP_FACTORS.NE.KEEP(400)) THEN WRITE(*,*) "Internal error in SMUMPS_FAC_B, KEEP(400), L..=", & KEEP(400), LL0_OMP_FACTORS CALL MUMPS_ABORT() ENDIF IF ( INFO(1) .GE. 0 ) THEN CALL SMUMPS_L0OMP_COPY_IW(S_IS_POINTERS%IW, & LIW, IWPOS, MUMPS_TPS_ARR, KEEP, PTLUST_S, & ICNTL, INFO) ENDIF !$OMP PARALLEL DO DO I=1, KEEP(400) IF (INFO(1) .LT. 0) THEN IF ( associated( L0_OMP_FACTORS(I)%A ) ) THEN DEALLOCATE( L0_OMP_FACTORS(I)%A ) NULLIFY ( L0_OMP_FACTORS(I)%A ) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -L0_OMP_FACTORS(I)%LA, .TRUE., & KEEP8, INFO(1), INFO(2), .TRUE., .FALSE. ) ENDIF L0_OMP_FACTORS(I)%LA = -99999_8 ENDIF IF (associated(MUMPS_TPS_ARR(I)%IW)) THEN DEALLOCATE(MUMPS_TPS_ARR(I)%IW) NULLIFY(MUMPS_TPS_ARR(I)%IW) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -((int(MUMPS_TPS_ARR(I)%LIW,8) * int(KEEP(34),8)) & / int(KEEP(35),8)), & .TRUE., & KEEP8, INFO(1), INFO(2), .TRUE., .FALSE. ) ENDIF ENDDO !$OMP END PARALLEL DO ENDIF IF (allocated(MUMPS_TPS_ARR)) THEN DEALLOCATE(MUMPS_TPS_ARR) ENDIF IF (allocated(SMUMPS_TPS_ARR)) THEN DEALLOCATE(SMUMPS_TPS_ARR) ENDIF POSFAC = POSFAC -1_8 IWPOS = IWPOS -1 IF (KEEP(201).LE.0) THEN IF (KEEP(201) .EQ. -1 .AND. INFO(1) .LT. 0) THEN POSFAC = 0_8 ENDIF KEEP8(31) = POSFAC RINFO(6) = ZERO ELSE RINFO(6) = real(KEEP8(31)*int(KEEP(35),8))/1E6 ENDIF KEEP8(48) = KEEP8(31)+KEEP8(71)+KEEP8(64) KEEP(32) = IWPOS CALL MUMPS_SETI8TOI4(KEEP8(48), INFO(9)) INFO(10) = KEEP(32) KEEP8(67) = LA - KEEP8(67) CALL MPI_ALLREDUCE(NTOTPV, NTOTPVTOT, 1, MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR) IF ( ( (INFO(1).EQ.-10 .OR. INFO(1).EQ.-40) & .AND. (NTOTPVTOT.EQ.N) ) & .OR. ( NTOTPVTOT.GT.N ) ) THEN write(*,*) ' Error 1 NTOTPVTOT=', NTOTPVTOT,N CALL MUMPS_ABORT() ENDIF IF ( (KEEP(19).NE.0 ) .AND. (NTOTPVTOT.NE.N) .AND. & (INFO(1).GE.0) ) THEN write(*,*) ' Error 2 NTOTPVTOT=', NTOTPVTOT CALL MUMPS_ABORT() ENDIF IF ( (INFO(1) .GE. 0 ) & .AND. (NTOTPVTOT.NE.N) ) THEN INFO(1) = -10 ENDIF IF (INFO(1).EQ.-10) THEN INFO(2) = NTOTPVTOT ENDIF IF (PROK) THEN WRITE (MPRINT,99980) INFO(1), INFO(2), & KEEP(28), KEEP8(48), INFO(10), INFO(11) IF(KEEP(50) .EQ. 0) THEN WRITE(MPRINT,99982) INFO(12) ENDIF IF (KEEP(50) .NE. 0) THEN WRITE(MPRINT,99984) INFO(12) ENDIF WRITE (MPRINT, 99986) & INFO(13), INFO(14), RINFO(2), RINFO(3) IF (KEEP(97) .NE. 0) THEN WRITE (MPRINT, 99987) INFO(25) ENDIF ENDIF RETURN 99980 FORMAT (/' LEAVING FACTORIZATION PHASE WITH ...'/ & ' INFO (1) =',I15/ & ' --- (2) =',I15/ & ' Number of nodes in the tree =',I15/ & ' INFO (9) Real space for factors =',I15/ & ' --- (10) Integer space for factors =',I15/ & ' --- (11) Maximum size of frontal matrices =',I15) 99982 FORMAT (' --- (12) Number of off diagonal pivots =',I15) 99984 FORMAT (' --- (12) Number of negative pivots =',I15) 99986 FORMAT (' --- (13) Number of delayed pivots =',I15/ & ' --- (14) Number of memory compresses =',I15/ & ' RINFO(2) Operations during node assembly =',1PD10.3/ & ' -----(3) Operations during node elimination =',1PD10.3) 99987 FORMAT (' INFO (25) Number of tiny pivots(static) =',I15) END SUBROUTINE SMUMPS_FAC_B SUBROUTINE SMUMPS_FAC_PAR_I(N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NULLNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, & DET_SIGN,PTRIST,PTRAST,PIMASTER,PAMASTER,PTRARW,PTRAIW,PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & MUMPS_TPS_ARR, SMUMPS_TPS_ARR, LTPS_ARR, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & NBROOT_UNDER_L0, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS, SLAVEF, MYID, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, INTARR, DBLARR, root, roota, & PERM, NELT, FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV, & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP, & PIVNUL_LIST_STRUCT, LRGROUPS ) USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T USE SMUMPS_TPS_M, ONLY: SMUMPS_TPS_T USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_FAC_PAR_M, ONLY : SMUMPS_FAC_PAR USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80) DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI INTEGER, INTENT(INOUT) :: NELVA, COMP INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV INTEGER, INTENT(INOUT) :: NULLNEGPV INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP REAL, INTENT(INOUT) :: DET_MANT INTEGER(8) :: LA REAL :: A(LA) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER LPOOL INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER IW(LIW), NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST(KEEP(28)), PERM(N) INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IPOOL(LPOOL) INTEGER NE(KEEP(28)) REAL RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU INTEGER IWPOS, LEAF, NBROOT, NBRTOT INTEGER, INTENT(in) :: NBROOT_UNDER_L0 INTEGER COMM_LOAD, ASS_IRECV REAL UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) REAL DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER LRGROUPS(KEEP(280)) INTEGER, INTENT( IN ) :: LTPS_ARR, LL0_OMP_MAPPING TYPE (MUMPS_TPS_T) :: MUMPS_TPS_ARR(LTPS_ARR) TYPE (SMUMPS_TPS_T) :: SMUMPS_TPS_ARR(LTPS_ARR) INTEGER, INTENT( IN ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) CALL SMUMPS_FAC_PAR( N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NULLNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, & DET_SIGN,PTRIST,PTRAST,PIMASTER,PAMASTER,PTRARW,PTRAIW,PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & MUMPS_TPS_ARR, SMUMPS_TPS_ARR, LTPS_ARR, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & NBROOT_UNDER_L0, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8, & PROCNODE_STEPS,SLAVEF,MYID, COMM_NODES, MYID_NODES, & BUFR,LBUFR,LBUFR_BYTES,INTARR,DBLARR,root,roota,PERM, NELT, & FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV, & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP, & PIVNUL_LIST_STRUCT, LRGROUPS ) RETURN END SUBROUTINE SMUMPS_FAC_PAR_I MUMPS_5.8.1/src/sfac_process_message.F0000664000175000017500000007772615042446437017546 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE SMUMPS_TRAITER_MESSAGE( & COMM_LOAD, ASS_IRECV, & MSGSOU, MSGTAG, MSGLEN, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER KEEP(500), ICNTL( 60 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) REAL A( LA ) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER COMM_LOAD, ASS_IRECV INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD(KEEP(28)) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) REAL DBLARR( KEEP8(26) ) INTEGER INIV2, ISHIFT, IBEG INTEGER ISHIFT_HDR INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL FLAG INTEGER LP INTEGER TMP( 2 ) INTEGER NBRECU, POSITION, INODE, ISON, IROOT INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE, & LMAP, FPERE, NELIM, & HDMAPLIG,NFS4FATHER, & TOT_ROOT_SIZE, TOT_CONT_TO_RECV DOUBLE PRECISION FLOP1 CHARACTER(LEN=35) :: SUBNAME INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) LP = ICNTL(1) SUBNAME="??????" CALL MUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF ( MSGTAG .EQ. RACINE ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NBRECU, & 1, MPI_INTEGER, COMM, IERR) NBRECU = BUFR( 1 ) NBFIN = NBFIN - NBRECU ELSEIF ( MSGTAG .EQ. NOEUD ) THEN CALL SMUMPS_PROCESS_NODE( MYID, KEEP, KEEP8, DKEEP, & BUFR, LBUFR, LBUFR_BYTES, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) SUBNAME="SMUMPS_PROCESS_NODE" IF ( IFLAG .LT. 0 ) GO TO 500 IF ( FLAG ) THEN CALL SMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( FPERE, N, & PROCNODE_STEPS,KEEP(199), & ND, FILS, FRERE, STEP, PIMASTER, & KEEP(28), KEEP(50), KEEP(253), FLOP1, & IW, LIW, KEEP(IXSZ) ) IF (FPERE.NE.KEEP(20)) & CALL MUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ELSEIF ( MSGTAG .EQ. END_NIV2_LDLT ) THEN INODE = BUFR( 1 ) CALL SMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, -INODE ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ELSEIF ( MSGTAG .EQ. TERREUR ) THEN IFLAG = -001 IERROR = MSGSOU GOTO 100 ELSEIF ( MSGTAG .EQ. MAITRE_DESC_BANDE ) THEN CALL SMUMPS_PROCESS_DESC_BANDE( MYID,BUFR, LBUFR, & LBUFR_BYTES, IWPOS, & IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, #if ! defined (NO_FDM_DESCBAND) & -1, #endif & IFLAG, IERROR ) SUBNAME="SMUMPS_PROCESS_DESC_BANDE" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. MAITRE2 ) THEN CALL SMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, SLAVEF, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & KEEP, KEEP8, DKEEP, ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) SUBNAME="SMUMPS_PROCESS_MASTER2" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. BLOC_FACTO .OR. & MSGTAG .EQ. BLOC_FACTO_RELAY ) THEN CALL SMUMPS_PROCESS_BLOCFACTO( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM , IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM_SLAVE ) THEN CALL SMUMPS_PROCESS_BLFAC_SLAVE( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM ) THEN CALL SMUMPS_PROCESS_SYM_BLOCFACTO( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. CONTRIB_TYPE2 ) THEN CALL SMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, & MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, & N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, PERM, COMP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, NBFIN, MYID, COMM, & ICNTL,KEEP,KEEP8,DKEEP,IFLAG, IERROR, IPOOL, LPOOL, LEAF, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSEIF ( MSGTAG .EQ. MAPLIG ) THEN HDMAPLIG = 7 INODE = BUFR( 1 ) ISON = BUFR( 2 ) NSLAVES_PERE = BUFR( 3 ) NFRONT_PERE = BUFR( 4 ) NASS_PERE = BUFR( 5 ) LMAP = BUFR( 6 ) NFS4FATHER = BUFR( 7 ) IF ( NSLAVES_PERE.NE.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ISHIFT = NSLAVES_PERE+1 TAB_POS_IN_PERE(1:NSLAVES_PERE+1, INIV2) = & BUFR(HDMAPLIG+1:HDMAPLIG+1+NSLAVES_PERE) TAB_POS_IN_PERE(SLAVEF+2, INIV2) = NSLAVES_PERE ELSE ISHIFT = 0 ENDIF IBEG = HDMAPLIG+1+ISHIFT CALL SMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES_PERE, & BUFR(IBEG), & NFRONT_PERE, NASS_PERE, NFS4FATHER,LMAP, & BUFR(IBEG+NSLAVES_PERE), & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, roota, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_CONT_STATIC ) THEN CALL SMUMPS_PROCESS_CONTRIB_TYPE3( & BUFR, LBUFR, LBUFR_BYTES, & root, roota, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF, OPASSW) SUBNAME="SMUMPS_PROCESS_CONTRIB_TYPE3" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_NON_ELIM_CB ) THEN IROOT = KEEP( 38 ) MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), & KEEP(199) ) IF ( PTLUST( STEP(IROOT)) .EQ. 0 ) THEN KEEP(266)=KEEP(266)-1 CALL MPI_RECV( TMP, 2 * KEEP(34), MPI_PACKED, & MSGSOU, ROOT_2SLAVE, & COMM, STATUS, IERR ) CALL SMUMPS_PROCESS_ROOT2SLAVE( TMP( 1 ), TMP( 2 ), & root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP,ND ) SUBNAME="SMUMPS_PROCESS_ROOT2SLAVE" IF ( IFLAG .LT. 0 ) GOTO 500 END IF CALL SMUMPS_PROCESS_CONTRIB_TYPE3( & BUFR, LBUFR, LBUFR_BYTES, & root, roota, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF, OPASSW ) SUBNAME="SMUMPS_PROCESS_CONTRIB_TYPE3" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_2SON ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) CALL SMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & ISON, NELIM, root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 IF ( MYID.NE.MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) ) THEN IF (KEEP(50).EQ.0) THEN ISHIFT_HDR = 6 ELSE ISHIFT_HDR = 8 ENDIF IF (IW(PTRIST(STEP(ISON))+ISHIFT_HDR+KEEP(IXSZ)).EQ. & S_REC_CONTSTATIC) THEN IW(PTRIST(STEP(ISON))+ISHIFT_HDR+KEEP(IXSZ)) = & S_ROOT2SON_CALLED ELSE CALL SMUMPS_FREE_BAND( N, ISON, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)),KEEP(199)) & ) ENDIF ENDIF ELSE IF ( MSGTAG .EQ. ROOT_2SLAVE ) THEN TOT_ROOT_SIZE = BUFR( 1 ) TOT_CONT_TO_RECV = BUFR( 2 ) CALL SMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, & TOT_CONT_TO_RECV, root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP, ND ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_NELIM_INDICES ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) NSLAVES_PERE = BUFR( 3 ) CALL SMUMPS_PROCESS_RTNELIND( root, roota, & ISON, NELIM, NSLAVES_PERE, BUFR(4), BUFR(4+BUFR(2)), & BUFR(4+2*BUFR(2)), & & PROCNODE_STEPS, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND) SUBNAME="SMUMPS_PROCESS_RTNELIND" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. UPDATE_LOAD ) THEN WRITE(*,*) "Internal error 3 in SMUMPS_TRAITER_MESSAGE" CALL MUMPS_ABORT() ELSE IF ( MSGTAG .EQ. TAG_DUMMY ) THEN ELSE IF ( LP > 0 ) & WRITE(LP,*) MYID, &': Internal error, routine SMUMPS_TRAITER_MESSAGE.',MSGTAG IFLAG = -100 IERROR= MSGTAG GOTO 500 ENDIF 100 CONTINUE RETURN 500 CONTINUE IF ( ICNTL(1) .GT. 0 .AND. ICNTL(4).GE.1 ) THEN LP=ICNTL(1) IF (IFLAG.EQ.-9) THEN WRITE(LP,*) 'FAILURE, WORKSPACE TOO SMALL DURING ',SUBNAME ENDIF IF (IFLAG.EQ.-8) THEN WRITE(LP,*) 'FAILURE IN INTEGER ALLOCATION DURING ',SUBNAME ENDIF IF (IFLAG.EQ.-13) THEN WRITE(LP,*) 'FAILURE IN DYNAMIC ALLOCATION DURING ',SUBNAME ENDIF ENDIF CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE SMUMPS_TRAITER_MESSAGE RECURSIVE SUBROUTINE SMUMPS_RECV_AND_TREAT( & COMM_LOAD, ASS_IRECV, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT , & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, LA, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST( KEEP(28) ) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) REAL DBLARR( KEEP8(26) ) INTEGER MSGSOU, MSGTAG, MSGLEN, IERR MSGSOU = STATUS( MPI_SOURCE ) MSGTAG = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN IFLAG = -20 IERROR = MSGLEN WRITE(*,*) ' RECEPTION BUF TOO SMALL, Msgtag/len=', & MSGTAG,MSGLEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF KEEP(266)=KEEP(266)-1 CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, & COMM, STATUS, IERR ) CALL SMUMPS_TRAITER_MESSAGE( & COMM_LOAD, ASS_IRECV, & MSGSOU, MSGTAG, MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS ) RETURN END SUBROUTINE SMUMPS_RECV_AND_TREAT RECURSIVE SUBROUTINE SMUMPS_TRY_RECVTREAT( & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, & MESSAGE_RECEIVED, MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED, LRGROUPS ) USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL, INTENT (IN) :: BLOCKING LOGICAL, INTENT (IN) :: SET_IRECV LOGICAL, INTENT (INOUT) :: MESSAGE_RECEIVED INTEGER, INTENT (IN) :: MSGSOU, MSGTAG INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST(KEEP(28)) INTEGER STEP(N), & PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) REAL DBLARR( KEEP8(26) ) LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED LOGICAL FLAG, RIGHT_MESS, FLAGbis INTEGER LP, MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC INTEGER IERR INTEGER :: STATUS_BIS(MPI_STATUS_SIZE) INTEGER, SAVE :: RECURS = 0 CALL MUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF ( .NOT. STACK_RIGHT_AUTHORIZED ) THEN RETURN ENDIF RECURS = RECURS + 1 LP = ICNTL(1) IF (ICNTL(4).LT.1) LP=-1 IF ( MESSAGE_RECEIVED ) THEN MSGSOU_LOC = MPI_ANY_SOURCE MSGTAG_LOC = MPI_ANY_TAG GOTO 250 ENDIF IF ( ASS_IRECV .NE. MPI_REQUEST_NULL) THEN RIGHT_MESS = .TRUE. IF (BLOCKING) THEN CALL MPI_WAIT(ASS_IRECV, & STATUS, IERR) FLAG = .TRUE. IF ( ( (MSGSOU.NE.MPI_ANY_SOURCE) .OR. & (MSGTAG.NE.MPI_ANY_TAG) ) ) THEN IF ( MSGSOU.NE.MPI_ANY_SOURCE) THEN RIGHT_MESS = MSGSOU.EQ.STATUS(MPI_SOURCE) ENDIF IF ( MSGTAG.NE.MPI_ANY_TAG) THEN RIGHT_MESS = & ( (MSGTAG.EQ.STATUS(MPI_TAG)).AND.RIGHT_MESS ) ENDIF IF (.NOT.RIGHT_MESS) THEN CALL MPI_PROBE(MSGSOU,MSGTAG, & COMM, STATUS_BIS, IERR) ENDIF ENDIF ELSE CALL MPI_TEST(ASS_IRECV, & FLAG, STATUS, IERR) ENDIF IF (IERR.LT.0) THEN IFLAG = -20 IF (LP.GT.0) & write(LP,*) ' Error return from MPI_TEST ', & IFLAG, ' in SMUMPS_TRY_RECVTREAT' CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF IF ( FLAG ) THEN KEEP(266)=KEEP(266)-1 MESSAGE_RECEIVED = .TRUE. MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN_LOC, IERR ) IF (.NOT.RIGHT_MESS) RECURS = RECURS + 10 CALL SMUMPS_TRAITER_MESSAGE( COMM_LOAD, ASS_IRECV, & MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (.NOT.RIGHT_MESS) RECURS = RECURS - 10 IF ( IFLAG .LT. 0 ) RETURN IF (.NOT.RIGHT_MESS) THEN IF (ASS_IRECV .NE. MPI_REQUEST_NULL) THEN CALL MUMPS_ABORT() ENDIF CALL MPI_IPROBE(MSGSOU,MSGTAG, & COMM, FLAGbis, STATUS, IERR) IF (FLAGbis) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL SMUMPS_RECV_AND_TREAT( COMM_LOAD, ASS_IRECV, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL,LEAF,NBFIN,MYID,SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & KEEP,KEEP8, DKEEP,ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF ENDIF ENDIF ELSE IF (BLOCKING) THEN CALL MPI_PROBE(MSGSOU,MSGTAG, & COMM, STATUS, IERR) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, FLAG, STATUS, IERR) ENDIF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) MESSAGE_RECEIVED = .TRUE. CALL SMUMPS_RECV_AND_TREAT( COMM_LOAD, ASS_IRECV, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF ENDIF 250 CONTINUE RECURS = RECURS - 1 IF ( NBFIN .EQ. 0 ) RETURN IF ( RECURS .GT. 3 ) RETURN IF ( KEEP(36).EQ.1 .AND. SET_IRECV .AND. & (ASS_IRECV.EQ.MPI_REQUEST_NULL) .AND. & MESSAGE_RECEIVED ) THEN CALL MPI_IRECV ( BUFR(1), & LBUFR_BYTES, MPI_PACKED, MPI_ANY_SOURCE, & MPI_ANY_TAG, COMM, & ASS_IRECV, IERR ) ENDIF RETURN END SUBROUTINE SMUMPS_TRY_RECVTREAT SUBROUTINE SMUMPS_CANCEL_IRECV( INFO1, & KEEP, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & COMM, & MYID, SLAVEF) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER LBUFR, LBUFR_BYTES INTEGER ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER COMM INTEGER MYID, SLAVEF, INFO1, DEST INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL NO_ACTIVE_IRECV INTEGER IERR, DUMMY INTRINSIC mod IF (SLAVEF .EQ. 1) RETURN IF (ASS_IRECV.EQ.MPI_REQUEST_NULL) THEN NO_ACTIVE_IRECV=.TRUE. ELSE CALL MPI_TEST(ASS_IRECV, NO_ACTIVE_IRECV, & STATUS, IERR) IF (NO_ACTIVE_IRECV) THEN KEEP(266) = KEEP(266) - 1 ENDIF ENDIF CALL MPI_BARRIER(COMM,IERR) DUMMY = 1 DEST = mod(MYID+1, SLAVEF) CALL MUMPS_BUF_SEND_1INT & (DUMMY, DEST, TAG_DUMMY, COMM, KEEP, IERR) IF (NO_ACTIVE_IRECV) THEN CALL MPI_RECV( BUFR, LBUFR, & MPI_INTEGER, MPI_ANY_SOURCE, & TAG_DUMMY, COMM, STATUS, IERR ) ELSE CALL MPI_WAIT(ASS_IRECV, & STATUS, IERR) ENDIF KEEP(266)=KEEP(266)-1 RETURN END SUBROUTINE SMUMPS_CANCEL_IRECV MUMPS_5.8.1/src/dfac_compact_factors_m.F0000664000175000017500000001305415042446441020003 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_COMPACT_FACTORS_M PRIVATE PUBLIC :: DMUMPS_TRY_COMPACT_FACTORS CONTAINS SUBROUTINE DMUMPS_TRY_COMPACT_FACTORS(ICNTL49_LOC, & WK_USER_PROVIDED, S, KEEP, KEEP8, INFO, MYID, ICNTL, & PROK, MP, DMUMPS_LBUFR_BYTES8, DMUMPS_LBUF8, & LIWK, LIWK8 ) USE OMP_LIB USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_FREE_S_WK C C Purpose C ======= C If no factors stored in S and .NOT.WK_USER_PROVIDED deallocate(S) C If ICNTL49_LOC = 1, 2 try to compress S C Possible values : C 0 : nothing is done. C 1 : compact S while satisfying the C memory constraint that might have been provided C with ICNTL(23) feature. C 2 : compact S. The memory constraint that might have been C provided with ICNTL(23) feature does not apply C C Parameters C ========== INTEGER :: ICNTL49_LOC, MP, MYID DOUBLE PRECISION, POINTER, DIMENSION(:) :: S INTEGER :: KEEP(500), INFO(80), ICNTL(60) LOGICAL :: PROK, WK_USER_PROVIDED INTEGER(8) :: DMUMPS_LBUFR_BYTES8, DMUMPS_LBUF8 INTEGER(8) :: KEEP8(150) INTEGER(8), INTENT(IN) :: LIWK, LIWK8 C C Local declarations C ================== C LOGICAL :: Compact_S_Authorized INTEGER :: IERR, NOMP DOUBLE PRECISION, DIMENSION(:), POINTER :: TMPS INTEGER(8) :: TMPpeak, I8 !$ INTEGER(8) :: CHUNK8 IF (.NOT.WK_USER_PROVIDED) THEN C{ IF (KEEP8(31).EQ.0) THEN C{ C No factors stored in S IF (associated(S)) THEN CALL DMUMPS_DM_FREE_S_WK(S, KEEP(430)) C Reset KEEP(430)=0 since next allocations of S C will be from Fotran KEEP(430)=0 NULLIFY(S) KEEP8(23) = 0 ENDIF C} ELSE IF (ICNTL49_LOC.NE.0) THEN C{ Factors stored in S, try to compact S TMPpeak = KEEP8(73) + KEEP8(31) & - (DMUMPS_LBUFR_BYTES8+DMUMPS_LBUF8)/int(KEEP(35),8) & - KEEP8(26) & - ((LIWK+LIWK8*KEEP(10)+KEEP8(27))*int(KEEP(34),8)) & /int(KEEP(35),8) Compact_S_Authorized = .FALSE. C Set Compact_S_Authorized IF (KEEP8(4).GT.0_8) THEN IF (TMPpeak.LT.KEEP8(75)) & Compact_S_Authorized=.TRUE. ELSE Compact_S_Authorized = .TRUE. ENDIF IF (ICNTL49_LOC.EQ.1.AND..NOT.Compact_S_Authorized) THEN C{ INFO(1) = INFO(1) + 4 C INFO(2) = C New value of ICNTL(23) (in MBytes: C ( KEEP8(4) + (TMPpeak- KEEP8(75))*KEEP(35) )/1000000 C + 1 for safety INFO(2) = int( & ( & KEEP8(4) + & (TMPpeak- KEEP8(75))*int(KEEP(35),8) & ) / 1000000_8 + 1_8 & ) C In fact increasing INFO(2) will not help C since increasing ICNTL(23) will also increase C MAXS and thus the peak of memory. C Thus setting ICNTL(23) to INFO(2) might not C enable user to Compact_S. C Simplest is to advice to set ICNTL(49)=2 C or to switch of ICNTL(23) feature. IF (PROK) THEN WRITE(MP,'(A,I4,A,I2,A,/A,/A,A)') & " ** WARNING ** on MPI proc= ", MYID, & " ICNTL(49)= ", ICNTL49_LOC, & ", but not enough memory to compact S due to ", & " memory limitation given by ICNTL(23).", & " ICNTL(23) should be reset to zero or", & " ICNTL(49) should be set to 2 " ENDIF C} ELSE IF ( & (ICNTL49_LOC.EQ.1.AND.Compact_S_Authorized) & .OR. & (ICNTL49_LOC.EQ.2) C{ & ) THEN C Try to compact S of size MAXS ALLOCATE(TMPS(KEEP8(31)), stat=IERR) IF (IERR .GT. 0 ) THEN IF (PROK) THEN WRITE(MP,'(A,I4,A,I3,A)') & " ** WARNING ** on MPI proc= ", MYID, & " ICNTL(49)= ", ICNTL49_LOC, & ", but not enough memory to compact S " ENDIF INFO(1) = INFO(1) + 4 GOTO 513 ENDIF C !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK8=int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF ( KEEP8(31) > int(KEEP(361),8) .AND. NOMP .GT. 1) #if defined(__ve__) !NEC$ IVDEP #endif DO I8=1_8, KEEP8(31) TMPS(I8) = S(I8) ENDDO !$OMP END PARALLEL DO CALL DMUMPS_DM_FREE_S_WK(S, KEEP(430)) C Reset KEEP(430)=0 since TMPS is allocated C in Fortran and S=>TMPS should be deallocated C in Fortran. KEEP(430)=0 S => TMPS; NULLIFY(TMPS) KEEP8(23) = KEEP8(31) C} ENDIF C} ENDIF C} ENDIF 513 CONTINUE RETURN END SUBROUTINE DMUMPS_TRY_COMPACT_FACTORS END MODULE DMUMPS_FAC_COMPACT_FACTORS_M MUMPS_5.8.1/src/zarrowheads.F0000664000175000017500000011610415042446441015674 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ANA_ARROWHEADS_WRAPPER ( id, & GATHER_MATRIX_ALLOCATED ) USE ZMUMPS_STRUC_DEF USE ZMUMPS_ANA_AUX_M, ONLY:ZMUMPS_ANA_N_DIST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: MASTER PARAMETER( MASTER = 0 ) TYPE(ZMUMPS_STRUC), TARGET :: id LOGICAL, INTENT(INOUT) :: GATHER_MATRIX_ALLOCATED INTEGER, ALLOCATABLE, DIMENSION(:) :: NBINROW_TMP, NBINCOL_TMP INTEGER, DIMENSION(:), POINTER :: KEEP, ICNTL, INFO INTEGER(8), DIMENSION(:), POINTER :: KEEP8 LOGICAL :: I_AM_SLAVE INTEGER :: allocok KEEP => id%KEEP ICNTL => id%ICNTL INFO => id%INFO KEEP8 => id%KEEP8 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (KEEP(55) .EQ. 0) THEN ALLOCATE( NBINCOL_TMP( id%N ), NBINROW_TMP( id%N ), & stat=allocok ) IF (allocok.GT.0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(int(id%N,8)+int(id%N,8), INFO(2)) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL ZMUMPS_ANA_N_DIST(id, NBINCOL_TMP, NBINROW_TMP) IF ( .NOT. I_AM_SLAVE ) THEN DEALLOCATE(NBINCOL_TMP) DEALLOCATE(NBINROW_TMP) ENDIF IF(id%MYID .EQ. MASTER) THEN IF ( (KEEP(244) .EQ. 1) .AND. (KEEP(54) .EQ. 3) ) THEN IF (GATHER_MATRIX_ALLOCATED) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF GATHER_MATRIX_ALLOCATED= .FALSE. ENDIF END IF END IF ENDIF IF ( I_AM_SLAVE ) THEN IF (KEEP(55) .EQ. 0) THEN CALL ZMUMPS_ANA_DIST_ARROWHEADS( id%MYID, & id%NSLAVES, id%N, id%PROCNODE_STEPS(1), & id%STEP(1), id%FILS(1), & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & KEEP(1),KEEP8(1), ICNTL(1), id, & NBINCOL_TMP, NBINROW_TMP ) DEALLOCATE(NBINCOL_TMP) DEALLOCATE(NBINROW_TMP) ELSE CALL ZMUMPS_ANA_DIST_ELEMENTS( id%MYID, & id%NSLAVES, id%N, id%PROCNODE_STEPS(1), & id%STEP(1), & id%PTRAR(1), & id%PTRAR(id%NELT+2 ), & id%NELT, & id%FRTPTR(1), id%FRTELT(1), & KEEP(1), KEEP8(1), ICNTL(1), id%KEEP(50) ) id%KEEP(193)=1;id%KEEP(194)=1 id%KEEP(195)=1; id%KEEP(196)=1 ALLOCATE( id%PTR8ARR(1), & id%NINCOLARR(1), & id%NINROWARR(1), & id%PTRDEBARR(1), stat=allocok) IF (allocok .GT. 0) THEN id%INFO(1)=-7 id%INFO(2)=4 ENDIF ENDIF ELSE KEEP8(26) = 0_8 KEEP8(27) = 0_8 ALLOCATE( id%PTR8ARR(1), & id%NINCOLARR(1), & id%NINROWARR(1), & id%PTRDEBARR(1), stat=allocok) IF (allocok .GT. 0) THEN id%INFO(1)=-7 id%INFO(2)=4 ENDIF ENDIF 500 CONTINUE IF (allocated(NBINROW_TMP)) DEALLOCATE(NBINROW_TMP) IF (allocated(NBINCOL_TMP)) DEALLOCATE(NBINCOL_TMP) RETURN END SUBROUTINE ZMUMPS_ANA_ARROWHEADS_WRAPPER SUBROUTINE ZMUMPS_ANA_DIST_ARROWHEADS( MYID, SLAVEF, N, & PROCNODE, STEP, FILS, ISTEP_TO_INIV2, & I_AM_CAND, & KEEP, KEEP8, ICNTL, id, NINCOL_TMP, NINROW_TMP ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE (ZMUMPS_STRUC) :: id INTEGER MYID, N, SLAVEF INTEGER KEEP( 500 ), ICNTL( 60 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE( KEEP(28) ), STEP( N ), FILS( N ) INTEGER, INTENT(INOUT) :: NINCOL_TMP( N ) INTEGER, INTENT(INOUT) :: NINROW_TMP( N ) INTEGER ISTEP_TO_INIV2(KEEP(71)) LOGICAL I_AM_CAND(max(1,KEEP(56))) LOGICAL I_AM_SLAVE LOGICAL I_AM_CAND_LOC INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT INTEGER ISTEP, I, J, NINCOL, NINROW, allocok INTEGER TYPE_PARALL, ITYPE, IRANK, INIV2, TYPESPLIT LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS INTEGER :: NBARR_LOCAL INTEGER(8) :: IPTR EARLYT3ROOTINS = KEEP(200) .EQ. 0 & .OR. (KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0) TYPE_PARALL = KEEP(46) I_AM_SLAVE = (KEEP(46).EQ.1 .OR. MYID.NE.0) NBARR_LOCAL=0 DO J = 1, N ISTEP = STEP( J ) IF ( ISTEP .GT. 0 ) THEN I = J DO WHILE (I .GT. 0) ITYPE = MUMPS_TYPENODE( PROCNODE(ISTEP), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), KEEP(199) ) TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. T4_MASTER_CONCERNED = .FALSE. IF (ITYPE.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) THEN I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN IF ( TYPE_PARALL .eq. 0 ) THEN T4_MASTER_CONCERNED = & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID-1 ) ELSE T4_MASTER_CONCERNED = & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID ) ENDIF ENDIF ENDIF ENDIF IF ( TYPE_PARALL .eq. 0 ) THEN IRANK =IRANK + 1 END IF IF ( & ( ITYPE .eq. 2 .and. & IRANK .eq. MYID ) & .or. & ( ITYPE .eq. 1 .and. & IRANK .eq. MYID ) & .or. & ( T4_MASTER_CONCERNED ) & ) THEN NINCOL = NINCOL_TMP(I) NINROW = NINROW_TMP(I) ELSE IF ( ITYPE .EQ. 3 ) THEN IF ( EARLYT3ROOTINS ) THEN NINCOL = -1 NINROW = -1 ELSE NINCOL = NINCOL_TMP(I) NINROW = NINROW_TMP(I) ENDIF ELSE IF ( ITYPE .eq. 2 .AND. I_AM_CAND_LOC ) THEN NINCOL = NINCOL_TMP(I) NINROW = 0 ELSE NINCOL = -1 NINROW = -1 ENDIF IF ( NINCOL .NE. -1 ) THEN NBARR_LOCAL = NBARR_LOCAL + 1 ENDIF NINCOL_TMP(I)=NINCOL NINROW_TMP(I)=NINROW I=FILS(I) ENDDO ENDIF ENDDO KEEP(193) = max(1, NBARR_LOCAL) KEEP(194) = max(1, NBARR_LOCAL) KEEP(195) = max(1, NBARR_LOCAL) KEEP(196) = KEEP(28) ALLOCATE(id%PTR8ARR(KEEP(193)), & id%NINCOLARR(KEEP(194)), id%NINROWARR(KEEP(195)), & id%PTRDEBARR(KEEP(196)), stat=allocok) IF (allocok.GT.0) THEN id%INFO(1)=-7 CALL MUMPS_SET_IERROR( int(KEEP(194),8)+int(KEEP(195),8)+ & int(KEEP(196),8), id%INFO(2) ) RETURN ENDIF IPTR = 1_8 NBARR_LOCAL = 0 DO J = 1, N ISTEP = STEP( J ) IF ( ISTEP .GT. 0 ) THEN id%PTRDEBARR(ISTEP) = NBARR_LOCAL + 1 I = J DO WHILE (I .GT. 0) NINCOL = NINCOL_TMP(I) NINROW = NINROW_TMP(I) IF ( NINCOL .NE. -1 ) THEN NBARR_LOCAL = NBARR_LOCAL + 1 id%NINCOLARR( NBARR_LOCAL ) = NINCOL id%NINROWARR( NBARR_LOCAL ) = NINROW id%PTR8ARR ( NBARR_LOCAL ) = IPTR IPTR = IPTR + int(NINCOL + NINROW + 1,8) ENDIF I=FILS(I) ENDDO IF ( NINCOL .EQ. -1 ) THEN id%PTRDEBARR( ISTEP ) = -99999 ENDIF ENDIF ENDDO KEEP8(26) = IPTR - 1 KEEP8(27) = IPTR - 1 RETURN END SUBROUTINE ZMUMPS_ANA_DIST_ARROWHEADS SUBROUTINE ZMUMPS_FACTO_SEND_ARROWHEADS( N, NZ, ASPK, & IRN, ICN, PERM, & LSCAL,COLSCA,ROWSCA, & MYID, SLAVEF, PROCNODE_STEPS, NBRECORDS, & COMM, root, roota, KEEP, KEEP8, FILS, & INTARR, LINTARR, DBLARR, LDBLARR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, FRERE_STEPS, & STEP, A, LA, ISTEP_TO_INIV2, I_AM_CAND, CANDIDATES, & ICNTL, INFO ) !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER :: N, COMM, NBRECORDS INTEGER(8), INTENT(IN) :: NZ INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) COMPLEX(kind=8) ASPK(NZ) DOUBLE PRECISION COLSCA(*), ROWSCA(*) INTEGER IRN(NZ), ICN(NZ) INTEGER PERM(N), PROCNODE_STEPS(KEEP(28)) INTEGER FILS( N ) INTEGER ISTEP_TO_INIV2(KEEP(71)) LOGICAL I_AM_CAND(max(1,KEEP(56))) INTEGER SLAVEF, MYID INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56))) LOGICAL LSCAL TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER INFO( 80 ), ICNTL(60) INTEGER(8), INTENT(IN) :: LA INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER :: FRERE_STEPS( KEEP(28) ) INTEGER :: STEP(N) INTEGER(8) :: LINTARR, LDBLARR INTEGER :: INTARR( LINTARR ) COMPLEX(kind=8) :: DBLARR( LDBLARR ) COMPLEX(kind=8) :: A( LA ) INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT INTEGER LP LOGICAL LPOK COMPLEX(kind=8) VAL, VAL_SHR INTEGER IOLD,JOLD,ISEND,JSEND,DEST,I,IARR INTEGER ISEND_SHR, JSEND_SHR, DEST_SHR INTEGER IPOSROOT, JPOSROOT INTEGER IROW_GRID, JCOL_GRID INTEGER ISTEP INTEGER NBUFS INTEGER ARROW_ROOT, TAILLE INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT INTEGER TYPE_NODE, MASTER_NODE LOGICAL I_AM_CAND_LOC, I_AM_SLAVE INTEGER JARR, ILOCROOT, JLOCROOT INTEGER allocok, INIV2, TYPESPLIT, T4MASTER INTEGER(8) :: IS8, K INTEGER NCAND LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: PTRAW INTEGER :: IARR1, IORG, J INTEGER, DIMENSION(:,:), ALLOCATABLE :: BUFI COMPLEX(kind=8), DIMENSION(:,:), ALLOCATABLE :: BUFR LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P INTEGER NOMP, NOMP_P, IOMP, P2 LP = ICNTL(1) LPOK = ( LP .GT. 0 .AND. ICNTL(4) .GE. 1 ) ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ. 0 & .OR. (KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0) I_AM_SLAVE=(MYID.NE.0.OR.KEEP(46).EQ.1) IF ( KEEP(46) .eq. 0 ) THEN NBUFS = SLAVEF ELSE NBUFS = SLAVEF - 1 ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8)+int(N,8), INFO(2) ) IF (LPOK ) WRITE (LP,*) MYID, & ': Error allocating IW4 in ZMUMPS_FACTO_SEND_ARROWHEADS' GOTO 100 END IF ALLOCATE( PTRAW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = N IF (LPOK ) WRITE (LP,*) MYID, & ': Error allocating PTRAW in ZMUMPS_FACTO_SEND_ARROWHEADS' GOTO 100 END IF ENDIF IF (NBUFS.GT.0) THEN ALLOCATE( BUFI(NBRECORDS*2+1,NBUFS),stat=allocok ) IF ( allocok .GT. 0 ) THEN IF (LPOK ) WRITE (LP,*) MYID, & ': Error allocating BUFI in ZMUMPS_FACTO_SEND_ARROWHEADS' INFO(1)=-13 CALL MUMPS_SET_IERROR( int(NBUFS,8) * int(NBRECORDS*2+1,8), & INFO(2)) GOTO 100 END IF ALLOCATE( BUFR( NBRECORDS, NBUFS ), stat=allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) =-13 CALL MUMPS_SET_IERROR( int(NBUFS,8) * int(NBRECORDS*2+1,8), & INFO(2)) IF (LPOK ) WRITE (LP,*) MYID, & ': Error allocating BUFR in ZMUMPS_FACTO_SEND_ARROWHEADS' GOTO 100 END IF DO I = 1, NBUFS BUFI( 1, I ) = 0 ENDDO ENDIF 100 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF (KEEP(46) .NE. 0) THEN #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, N ISTEP=STEP(J) IF (ISTEP .GT. 0) THEN IARR1 = PTRDEBARR( ISTEP ) IF ( IARR1 .GT. 0 ) THEN I = J IORG = 0 DO WHILE ( I .GT. 0 ) IORG = IORG + 1 IW4(I, 1) = NINCOLARR( IARR1 + IORG - 1 ) IW4(I, 2) = NINROWARR( IARR1 + IORG - 1 ) + & NINCOLARR( IARR1 + IORG - 1 ) IS8 = PTR8ARR( IARR1 + IORG - 1 ) PTRAW( I ) = IS8 INTARR( IS8 ) = I DBLARR( IS8 ) = ZERO I = FILS(I) ENDDO ENDIF ENDIF ENDDO IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL ZMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, & PTR_ROOT, LA) CALL ZMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF END IF NOMP = 1 !$ NOMP=omp_get_max_threads() OMP_FLAG = KEEP(399).EQ.1 .AND. NOMP.GE.2 .AND. SLAVEF.EQ.1 & .AND. KEEP(46) .EQ. 1 !$OMP PARALLEL PRIVATE(K, I, DEST, I_AM_CAND_LOC, !$OMP& T4MASTER, T4_MASTER_CONCERNED, !$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, !$OMP& ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, !$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE, !$OMP& IS8, TAILLE, VAL, !$OMP& IARR, JARR, ISTEP, ISEND, JSEND, !$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P) !$OMP& REDUCTION(+: ARROW_ROOT) IF (OMP_FLAG) IOMP=0 !$ IOMP=omp_get_thread_num() NOMP_P=1 !$ NOMP_P=omp_get_num_threads() OMP_FLAG_P = .FALSE. !$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1 IF (OMP_FLAG_P) THEN IF ( NOMP_P .GE. 16 ) THEN NOMP_P=16 P2 = 4 ELSE IF (NOMP_P.GE.8) THEN NOMP_P=8 P2 = 3 ELSE IF (NOMP_P.GE.4) THEN NOMP_P=4 P2 = 2 ELSE IF (NOMP_P.GE.2) THEN NOMP_P=2 P2 = 1 ENDIF ELSE NOMP_P = 1 P2 = 0 ENDIF IF ( IOMP .LT. NOMP_P ) THEN DO K=1, NZ IOLD = IRN(K) JOLD = ICN(K) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE END IF IF (OMP_FLAG_P) THEN IF (IOLD.EQ.JOLD) THEN IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD ELSE IARR = JOLD ENDIF DOIT = ( IOMP .EQ. ibits(IARR, P2-1, P2)) ELSE DOIT = .TRUE. ENDIF IF (DOIT) THEN IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = JOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF ISTEP = abs( STEP(IARR) ) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 IF ( TYPE_NODE .EQ. 1 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF ELSE IF ( TYPE_NODE .EQ. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF END IF INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) IF ( KEEP(46) .eq. 0 ) THEN T4MASTER=T4MASTER+1 ENDIF ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND .LT. 0 ) THEN IPOSROOT = root%RG2L(JSEND) JPOSROOT = root%RG2L(IARR) ELSE IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JSEND ) END IF IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL ) IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * root%NPCOL + JCOL_GRID END IF ELSE DEST = -2 ENDIF END IF IF (LSCAL) THEN VAL = ASPK(K)*ROWSCA(IOLD)*COLSCA(JOLD) ELSE VAL = ASPK(K) ENDIF IF ( DEST .eq. 0 & .or. & ( DEST .eq. -1 .and. KEEP( 46 ) .eq. 1 .AND. & ( I_AM_CAND_LOC .OR. MASTER_NODE .EQ. 0 ) ) & .or. & ( T4MASTER.EQ.0 ) & .or. & ( DEST .EQ. -2 .AND. KEEP( 46 ) .EQ. 1 ) & ) THEN IARR = ISEND JARR = JSEND IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%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 IS8 = PTRAW( IARR ) DBLARR( IS8 ) = DBLARR( IS8 ) + VAL ELSE IS8 = PTRAW(IARR) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL END IF ELSE IARR = -IARR IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 .AND. & STEP( IARR) > 0 ) THEN IF ( MASTER_NODE == MYID) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL ZMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF END IF END IF END IF IF ( DEST.EQ. -1 ) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79).GT.0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) IF (KEEP(46).EQ.0.AND.(DEST.GE.0)) DEST=DEST+1 IF (DEST.LT.0) EXIT IF (I.EQ.NCAND+1) CYCLE IF (DEST.NE.0) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL ZMUMPS_ARROW_FILL_SEND_BUF() ENDIF ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) IF (KEEP(46).EQ.0) DEST=DEST+1 IF (DEST.NE.0) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL ZMUMPS_ARROW_FILL_SEND_BUF() ENDIF ENDDO ENDIF DEST = MASTER_NODE IF (KEEP(46).EQ.0) DEST=DEST+1 IF ( DEST .NE. 0 ) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL ZMUMPS_ARROW_FILL_SEND_BUF() ENDIF IF ((T4_MASTER_CONCERNED).AND.(T4MASTER.GT.0)) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=T4MASTER CALL ZMUMPS_ARROW_FILL_SEND_BUF() ENDIF ELSE IF ( DEST .GT. 0 ) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL ZMUMPS_ARROW_FILL_SEND_BUF() IF ( T4MASTER.GT.0 ) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=T4MASTER CALL ZMUMPS_ARROW_FILL_SEND_BUF() ENDIF ELSE IF ( T4MASTER.GT.0 ) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=T4MASTER CALL ZMUMPS_ARROW_FILL_SEND_BUF() ELSE IF ( DEST .EQ. -2 ) THEN DO I = 0, SLAVEF-1 DEST = I IF (KEEP(46) .EQ. 0) DEST = DEST + 1 IF (DEST .NE. 0) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL ZMUMPS_ARROW_FILL_SEND_BUF() ENDIF ENDDO ENDIF ENDIF ENDDO ENDIF !$OMP END PARALLEL KEEP(49) = ARROW_ROOT IF (NBUFS.GT.0) THEN CALL ZMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP( 46 ) ) ENDIF 500 CONTINUE IF ( allocated(IW4 ) ) DEALLOCATE( IW4 ) IF ( allocated(PTRAW ) ) DEALLOCATE( PTRAW ) IF ( allocated(BUFI ) ) DEALLOCATE( BUFI ) IF ( allocated(BUFR ) ) DEALLOCATE( BUFR ) RETURN CONTAINS SUBROUTINE ZMUMPS_ARROW_FILL_SEND_BUF() IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ IF (BUFI(1,DEST_SHR)+1.GT.NBRECORDS) THEN TAILLE_SENDI = BUFI(1,DEST_SHR) * 2 + 1 TAILLE_SENDR = BUFI(1,DEST_SHR) CALL MPI_SEND(BUFI(1,DEST_SHR),TAILLE_SENDI, & MPI_INTEGER, & DEST_SHR, ARROWHEAD, COMM, IERR ) CALL MPI_SEND( BUFR(1,DEST_SHR), TAILLE_SENDR, & MPI_DOUBLE_COMPLEX, DEST_SHR, & ARROWHEAD, COMM, IERR ) BUFI(1,DEST_SHR) = 0 ENDIF IREQ = BUFI(1,DEST_SHR) + 1 BUFI(1,DEST_SHR) = IREQ BUFI( IREQ * 2, DEST_SHR ) = ISEND_SHR BUFI( IREQ * 2 + 1, DEST_SHR ) = JSEND_SHR BUFR( IREQ, DEST_SHR ) = VAL_SHR RETURN END SUBROUTINE ZMUMPS_ARROW_FILL_SEND_BUF END SUBROUTINE ZMUMPS_FACTO_SEND_ARROWHEADS SUBROUTINE ZMUMPS_ARROW_FILL_SEND_BUF_ELT( & ISEND_SHR, JSEND_SHR, VAL_SHR, & DEST_SHR, BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM ) IMPLICIT NONE INTEGER, INTENT(in) :: ISEND_SHR, JSEND_SHR COMPLEX(kind=8), INTENT(in) :: VAL_SHR INTEGER :: DEST_SHR, NBRECORDS, NBUFS, LP, COMM INTEGER :: BUFI( NBRECORDS*2+1, NBUFS ) COMPLEX(kind=8) :: BUFR( NBRECORDS, NBUFS ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ IF (BUFI(1,DEST_SHR)+1.GT.NBRECORDS) THEN TAILLE_SENDI = BUFI(1,DEST_SHR) * 2 + 1 TAILLE_SENDR = BUFI(1,DEST_SHR) CALL MPI_SEND(BUFI(1,DEST_SHR),TAILLE_SENDI, & MPI_INTEGER, & DEST_SHR, ARROWHEAD, COMM, IERR ) CALL MPI_SEND( BUFR(1,DEST_SHR), TAILLE_SENDR, & MPI_DOUBLE_COMPLEX, DEST_SHR, & ARROWHEAD, COMM, IERR ) BUFI(1,DEST_SHR) = 0 ENDIF IREQ = BUFI(1,DEST_SHR) + 1 BUFI(1,DEST_SHR) = IREQ BUFI( IREQ * 2, DEST_SHR ) = ISEND_SHR BUFI( IREQ * 2 + 1, DEST_SHR ) = JSEND_SHR BUFR( IREQ, DEST_SHR ) = VAL_SHR RETURN END SUBROUTINE ZMUMPS_ARROW_FILL_SEND_BUF_ELT SUBROUTINE ZMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM, & TYPE_PARALL ) IMPLICIT NONE INTEGER NBUFS, NBRECORDS, TYPE_PARALL INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS ) COMPLEX(kind=8) BUFR( NBRECORDS, NBUFS ) INTEGER COMM INTEGER LP INTEGER ISLAVE, TAILLE_SENDI, TAILLE_SENDR, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' DO ISLAVE = 1,NBUFS TAILLE_SENDI = BUFI(1,ISLAVE) * 2 + 1 TAILLE_SENDR = BUFI(1,ISLAVE) BUFI(1,ISLAVE) = - BUFI(1,ISLAVE) CALL MPI_SEND(BUFI(1,ISLAVE),TAILLE_SENDI, & MPI_INTEGER, & ISLAVE, ARROWHEAD, COMM, IERR ) IF ( TAILLE_SENDR .NE. 0 ) THEN CALL MPI_SEND( BUFR(1,ISLAVE), TAILLE_SENDR, & MPI_DOUBLE_COMPLEX, ISLAVE, & ARROWHEAD, COMM, IERR ) END IF ENDDO RETURN END SUBROUTINE ZMUMPS_ARROW_FINISH_SEND_BUF RECURSIVE SUBROUTINE ZMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTLIST, DBLLIST, TAILLE, LO, HI ) IMPLICIT NONE INTEGER N, TAILLE INTEGER PERM( N ) INTEGER INTLIST( TAILLE ) COMPLEX(kind=8) DBLLIST( TAILLE ) INTEGER LO, HI INTEGER I,J INTEGER ISWAP, PIVOT COMPLEX(kind=8) zswap I = LO J = HI PIVOT = PERM(INTLIST((I+J)/2)) 10 IF (PERM(INTLIST(I)) < PIVOT) THEN I=I+1 GOTO 10 ENDIF 20 IF (PERM(INTLIST(J)) > PIVOT) THEN J=J-1 GOTO 20 ENDIF IF (I < J) THEN ISWAP = INTLIST(I) INTLIST(I) = INTLIST(J) INTLIST(J)=ISWAP zswap = DBLLIST(I) DBLLIST(I) = DBLLIST(J) DBLLIST(J) = zswap ENDIF IF ( I <= J) THEN I = I+1 J = J-1 ENDIF IF ( I <= J ) GOTO 10 IF ( LO < J ) CALL ZMUMPS_QUICK_SORT_ARROWHEADS(N, PERM, & INTLIST, DBLLIST, TAILLE, LO, J) IF ( I < HI ) CALL ZMUMPS_QUICK_SORT_ARROWHEADS(N, PERM, & INTLIST, DBLLIST, TAILLE, I, HI) RETURN END SUBROUTINE ZMUMPS_QUICK_SORT_ARROWHEADS SUBROUTINE ZMUMPS_FACTO_RECV_ARROWHD2( N, & DBLARR, LDBLARR, INTARR, LINTARR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & KEEP, KEEP8, FILS, MYID, COMM, NBRECORDS, & A, LA, root, roota, & PROCNODE_STEPS, & SLAVEF, PERM, FRERE_STEPS, STEP, ICNTL, INFO ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, MYID, COMM INTEGER KEEP(500) INTEGER(8), INTENT(IN) :: LDBLARR, LINTARR INTEGER INTARR(LINTARR) INTEGER, INTENT(IN) :: FILS( N ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) 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 INFO( 80 ), ICNTL(60) COMPLEX(kind=8) DBLARR(LDBLARR) INTEGER FRERE_STEPS( KEEP(28) ), STEP(N) TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER LP LOGICAL LPOK INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFI COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: PTRAW INTEGER :: IARR1, IORG, J, ISTEP LOGICAL :: EARLYT3ROOTINS LOGICAL FINI INTEGER IREC, NB_REC, IARR, JARR, I, allocok INTEGER(8) :: IS8 INTEGER LOCAL_M, LOCAL_N, ILOCROOT, JLOCROOT, & IPOSROOT, JPOSROOT, TAILLE, & IPROC INTEGER(8) :: PTR_ROOT INTEGER ARROW_ROOT, TYPE_PARALL INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE COMPLEX(kind=8) VAL COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MASTER PARAMETER(MASTER=0) INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) TYPE_PARALL = KEEP(46) LP = ICNTL(1) LPOK = ( LP .GT. 0 .AND. ICNTL(4) .GE. 1 ) ARROW_ROOT=0 EARLYT3ROOTINS = KEEP(200) .EQ. 0 & .OR. (KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0) ALLOCATE( BUFI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = NBRECORDS * 2 + 1 IF (LPOK) WRITE(LP,*) MYID, & ': Error allocaing BUFI in ZMUMPS_FACTO_RECV_ARROWHD2' GOTO 100 END IF ALLOCATE( BUFR( NBRECORDS ) , stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = NBRECORDS IF (LPOK) WRITE(LP,*) MYID, & ': Error allocaing BUFR in ZMUMPS_FACTO_RECV_ARROWHD2' GOTO 100 END IF ALLOCATE( IW4(N,2), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR( 2_8 * int(N,8), INFO(2) ) IF (LPOK) WRITE(LP,*) MYID, & ': Error allocaing IW4 in ZMUMPS_FACTO_RECV_ARROWHD2' GOTO 100 END IF ALLOCATE( PTRAW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = N IF (LPOK) WRITE(LP,*) MYID, & ': Error allocaing PTRAW in ZMUMPS_FACTO_RECV_ARROWHD2' GOTO 100 END IF 100 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF ( KEEP(38).NE.0 .AND. EARLYT3ROOTINS ) THEN CALL ZMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL ZMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF FINI = .FALSE. #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, N ISTEP=STEP(J) IF (ISTEP .GT. 0) THEN IARR1 = PTRDEBARR( ISTEP ) IF ( IARR1 .GT. 0 ) THEN I = J IORG = 0 DO WHILE ( I .GT. 0 ) IORG = IORG + 1 IW4(I, 1) = NINCOLARR( IARR1 + IORG - 1 ) IW4(I, 2) = NINROWARR( IARR1 + IORG - 1 ) + & NINCOLARR( IARR1 + IORG - 1 ) IS8 = PTR8ARR( IARR1 + IORG - 1 ) PTRAW( I ) = IS8 INTARR( IS8 ) = I DBLARR( IS8 ) = ZERO I = FILS(I) ENDDO ENDIF ENDIF ENDDO DO WHILE (.NOT.FINI) CALL MPI_RECV( BUFI(1), 2*NBRECORDS+1, & MPI_INTEGER, MASTER, & ARROWHEAD, & COMM, STATUS, IERR ) NB_REC = BUFI(1) IF (NB_REC.LE.0) THEN FINI = .TRUE. NB_REC = -NB_REC ENDIF IF (NB_REC.EQ.0) EXIT CALL MPI_RECV( BUFR(1), NBRECORDS, MPI_DOUBLE_COMPLEX, & MASTER, ARROWHEAD, & COMM, STATUS, IERR ) DO IREC=1, NB_REC IARR = BUFI( IREC * 2 ) JARR = BUFI( IREC * 2 + 1 ) VAL = BUFR( IREC ) IF ( MUMPS_TYPENODE( PROCNODE_STEPS(abs(STEP(abs(IARR)))), & KEEP(199) ) .eq. 3 & .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JARR ) ELSE IPOSROOT = root%RG2L( JARR ) JPOSROOT = root%RG2L( -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 roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%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 IS8 = PTRAW(IARR) DBLARR(IS8) = DBLARR( IS8 ) + VAL ELSE IS8 = PTRAW(IARR) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)), & KEEP(199) ) IF ( TYPE_PARALL .eq. 0 ) THEN IPROC = IPROC + 1 END IF IF (IPROC .EQ. MYID) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL ZMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF END IF ENDIF ENDDO END DO 500 CONTINUE IF (allocated(BUFI ) ) DEALLOCATE( BUFI ) IF (allocated(BUFR ) ) DEALLOCATE( BUFR ) IF (allocated(IW4 ) ) DEALLOCATE( IW4 ) IF (allocated(PTRAW ) ) DEALLOCATE( PTRAW ) KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE ZMUMPS_FACTO_RECV_ARROWHD2 SUBROUTINE ZMUMPS_SET_TO_ZERO(A, LLD, M, N, KEEP) !$ USE OMP_LIB, ONLY : OMP_GET_MAX_THREADS IMPLICIT NONE INTEGER, INTENT(IN) :: LLD, M, N COMPLEX(kind=8) :: A(int(LLD,8)*int(N-1,8)+int(M,8)) INTEGER :: KEEP(500) COMPLEX(kind=8), PARAMETER :: ZERO = (0.0D0,0.0D0) INTEGER I, J !$ INTEGER :: NOMP INTEGER(8) :: I8, LA !$ NOMP = OMP_GET_MAX_THREADS() IF (LLD .EQ. M) THEN LA=int(LLD,8)*int(N-1,8)+int(M,8) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC,KEEP(361)) !$OMP& IF ( LA > int(KEEP(361),8) .AND. NOMP .GT. 1) DO I8=1, LA A(I8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO PRIVATE(I,J) COLLAPSE(2) !$OMP& SCHEDULE(STATIC,KEEP(361)) IF (int(M,8)*int(N,8) !$OMP& .GT. KEEP(361).AND. NOMP .GT.1) DO I = 1, N DO J = 1, M A( int(I-1,8)*int(LLD,8)+ int(J,8) ) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE ZMUMPS_SET_TO_ZERO SUBROUTINE ZMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER(8), INTENT(IN) :: LA COMPLEX(kind=8), INTENT(INOUT) :: A(LA) INTEGER :: KEEP(500) TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER :: LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT IF (KEEP(60)==0) THEN CALL ZMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA) IF (LOCAL_N .GT. 0) THEN CALL ZMUMPS_SET_TO_ZERO(A(PTR_ROOT), & LOCAL_M, LOCAL_M, LOCAL_N, KEEP) ENDIF ELSE IF (root%yes) THEN CALL ZMUMPS_SET_TO_ZERO(roota%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC, & KEEP) ENDIF RETURN END SUBROUTINE ZMUMPS_SET_ROOT_TO_ZERO SUBROUTINE ZMUMPS_GET_ROOT_INFO(root, & LOCAL_M, LOCAL_N, PTR_ROOT, LA) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC), INTENT(IN) :: root INTEGER, INTENT(OUT) :: LOCAL_M, LOCAL_N INTEGER(8), INTENT(OUT) :: PTR_ROOT INTEGER(8), INTENT(IN) :: LA INTEGER, EXTERNAL :: MUMPS_NUMROC LOCAL_M = MUMPS_NUMROC( root%ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) LOCAL_M = max( 1, LOCAL_M ) LOCAL_N = MUMPS_NUMROC( root%ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) PTR_ROOT = LA - int(LOCAL_M,8) * int(LOCAL_N,8) + 1_8 RETURN END SUBROUTINE ZMUMPS_GET_ROOT_INFO MUMPS_5.8.1/src/zfac_scalings_simScaleAbs.F0000664000175000017500000017535515042446442020435 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SIMSCALEABS(IRN_loc, JCN_loc, A_loc, NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, SYM, NB1, NB2, NB3, EPS, & ONENORMERR,INFNORMERR) C---------------------------------------------------------------------- C IF SYM=0 CALLs unsymmetric variant ZMUMPS_SIMSCALEABSUNS. C IF SYM=2 CALLS symmetric variant where only one of a_ij and a_ji C is stored. ZMUMPS_SIMSCALEABSSYM C--------------------------------------------------------------------- C For details, see the two subroutines below C ZMUMPS_SIMSCALEABSUNS and ZMUMPS_SIMSCALEABSSYM C --------------------------------------------------------------------- C !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) NZ_loc INTEGER(8) :: IWRKSZ INTEGER(8) :: ISZWRKRC, LWRKR_TH, LWRKC_TH INTEGER :: NOMP_MAX INTEGER M, N, OP INTEGER NUMPROCS, MYID, COMM INTEGER(8) :: INTSZ, RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) COMPLEX(kind=8) A_loc(NZ_loc) INTEGER RPARTVEC(M) INTEGER RSNDRCVSZ(2*NUMPROCS) INTEGER CPARTVEC(N) INTEGER CSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER(8) :: REGISTRE(12) DOUBLE PRECISION ROWSCA(M) DOUBLE PRECISION COLSCA(N) DOUBLE PRECISION WRKRC(ISZWRKRC) DOUBLE PRECISION WRKR_TH(LWRKR_TH,max(NOMP_MAX,1)) DOUBLE PRECISION WRKC_TH(LWRKC_TH,max(NOMP_MAX,1)) DOUBLE PRECISION ONENORMERR,INFNORMERR C LOCALS C FOR the scaling phase INTEGER SYM, NB1, NB2, NB3 DOUBLE PRECISION EPS C EXTERNALS EXTERNAL ZMUMPS_SIMSCALEABSUNS,ZMUMPS_SIMSCALEABSSYM, & ZMUMPS_INITREAL C MUST HAVE IT INTEGER I INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER :: NOMP !$ INTEGER :: CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = omp_get_max_threads() !$ CHUNK= max(K361/2, (N+NOMP-1) / NOMP ) !$ ENDIF IF(SYM.EQ.0) THEN CALL ZMUMPS_SIMSCALEABSUNS(IRN_loc, JCN_loc, A_loc, & NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, NOMP_MAX, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) ELSE CALL ZMUMPS_SIMSCALEABSSYM(IRN_loc, JCN_loc, A_loc, & NZ_loc, & N, NUMPROCS, MYID, COMM, & RPARTVEC, & RSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, NOMP_MAX, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) IF (OP.EQ.2) THEN IF (NOMP_MAX.LE.0) THEN DO I=1,N COLSCA(I) = ROWSCA(I) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1,N COLSCA(I) = ROWSCA(I) ENDDO ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SIMSCALEABS SUBROUTINE ZMUMPS_SIMSCALEABSUNS(IRN_loc, JCN_loc, A_loc, NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, NOMP_MAX, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) C---------------------------------------------------------------------- C Input parameters: C M, N: size of matrix (in general M=N, but the algorithm C works for rectangular matrices as well (norms other than C inf-norm are not possible mathematically in this case). C NUMPROCS, MYID, COMM: guess what are those C RPARTVEC: row partvec to be filled when OP=1 C CPARTVEC: col partvec to be filled when OP=1 C RSNDRCVSZ: send recv sizes for row operations. C to be filled when OP=1 C CSNDRCVSZ: send recv sizes for col operations. C to be filled when OP=1 C REGISTRE: to store some pointers (size etc) C IWRK: working space. when OP=1 IWRKSZ.GE.4*MAXMN C when OP=2 INTSZ portion is used. Thus, IWRKSZ>INTSZ C when OP=2 C IWRKSZ: size C INTSZ: to be computed when OP=1, necessary integer space to run C scaling algo when OP=2 C RESZ: to be computed when OP=1, necessary real space to run C scaling algo when OP=2 C OP: C =1 estimation of memory and construction of partvecs C writes into RPARTVEC,CPARTVEC,RSNDRCVSZ,CSNDRCVSZ,REGISTRE C does not access WRKRC, uses IWRK as workspace C computes INTSZ and RESZ. C =2 Compute scalings C restores pointers from REGISTRE, C stores communication structure in IWRK (from the start). C C ROWSCA: space for row scaling factor; has size M C COLSCA: space for col scaling factor; has size N C WRKRC: real working space. when OP=1, is not accessed. Thus, it C can be declared to be of size 1 at OP=1 call. C ISZWRKRC: size C SYM: is matrix symmetric C NB1, NB2, NB3: algo runs C NB1 iters of inf-norm (default 1/1), C NB2 iters of 1-norm (default 3/10), C NB3 iters of inf-norm (default 3/10). C in succession. C EPS: tolerance for concergence. C IF EPS < 0.R0 then does not test convergence. C If convergence occured during the first set of inf-norm C iterations, we start performing one-norm iterations. C If convergence occured during the one-norm iterations, C we start performing the second set of inf-norm iterations. C If convergence occured during the second set of inf-norm, C we prepare to return. C ONENORMERR : error in one norm scaling (associated with the scaling C arrays of the previous iterations), C INFNORMERR : error in inf norm scaling (associated with the scaling C arrays of the previous iterations). C--------------------------------------------------------------------- C On input: C OP=1==>Requirements C IWRKSZ.GE.4*MAXMN C RPARTVEC of size M C CPARTVEC of size N C RSNDRCVSZ of size 2*NUMPROCS C CSNDRCVSZ of size 2*NUMPROCS C REGISTRE of size 12 C C OP=2==>Requirements C INTSZ .GE. REGISTRE(11) C RESZ .GE. REGISTRE(12) C--------------------------------------------------------------------- C On output: C ROWSCA and COLSCA C at processor 0 of COMM: complete factors. C at other processors : only the ROWSCA(i) or COLSCA(j) C for which there is a nonzero a_i* or a_*j are useful. C ONENORMERR : error in one norm scaling C = -1.0 if iter2=0. C INFNORMERR : error in inf norm scaling C = inf norm error at iter3 if iter3 > 0 C = inf norm error at iter1 if iter1 > 0, iter3=0 C = -1.0 if iter1=iter3=0 C --------------------------------------------------------------------- C References: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C C The parallelization approach is discussed in C [3] P. R. Amestoy, I. S. Duff, D. Ruiz, and B. Ucar, C "A parallel matrix scaling algorithm". C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, Jan'08. C and was supported by ANR-SOLSTICE project (ANR-06-CIS6-010) C --------------------------------------------------------------------- !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER(8) :: IWRKSZ, INTSZ INTEGER(8) :: ISZWRKRC, LWRKR_TH, LWRKC_TH INTEGER :: M, N, OP INTEGER :: NUMPROCS, MYID, COMM, NOMP_MAX INTEGER(8) :: RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) COMPLEX(kind=8) A_loc(NZ_loc) INTEGER RPARTVEC(M) INTEGER CPARTVEC(N) INTEGER RSNDRCVSZ(2*NUMPROCS) INTEGER CSNDRCVSZ(2*NUMPROCS) INTEGER(8) :: REGISTRE(12) INTEGER IWRK(IWRKSZ) DOUBLE PRECISION ROWSCA(M) DOUBLE PRECISION COLSCA(N) DOUBLE PRECISION WRKRC(ISZWRKRC) DOUBLE PRECISION WRKR_TH(LWRKR_TH,max(NOMP_MAX,1)) DOUBLE PRECISION WRKC_TH(LWRKC_TH,max(NOMP_MAX,1)) DOUBLE PRECISION ONENORMERR,INFNORMERR C LOCALS INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER ICSNDRCVNUM, OCSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER ICSNDRCVVOL, OCSNDRCVVOL INTEGER INUMMYR, INUMMYC C IMPORTANT POINTERS INTEGER(8) :: IMYRPTR,IMYCPTR INTEGER(8) :: IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER(8) :: ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER(8) :: ICNGHBPRCS, ICSNDRCVIA,ICSNDRCVJA INTEGER(8) :: OCNGHBPRCS, OCSNDRCVIA,OCSNDRCVJA INTEGER(8) :: ISTATUS, REQUESTS, TMPWORK INTEGER(8) :: ITDRPTR, ITDCPTR, ISRRPTR INTEGER(8) :: OSRRPTR, ISRCPTR, OSRCPTR C FOR the scaling phase INTEGER NB1, NB2, NB3 DOUBLE PRECISION EPS C Iteration vars INTEGER ITER, IR, IC INTEGER(8) :: NZIND DOUBLE PRECISION ELM C COMM TAGS.... INTEGER TAG_COMM_COL PARAMETER(TAG_COMM_COL=100) INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) C FUNCTIONS EXTERNAL ZMUMPS_CREATEPARTVEC, & ZMUMPS_NUMVOLSNDRCV, & ZMUMPS_SETUPCOMMS, & ZMUMPS_FILLMYROWCOLINDICES, & ZMUMPS_INITREAL, & ZMUMPS_INITREALLST, & ZMUMPS_DOCOMMINF, & ZMUMPS_DOCOMM1N DOUBLE PRECISION ZMUMPS_ERRSCALOC DOUBLE PRECISION ZMUMPS_ERRSCA1 INTRINSIC abs DOUBLE PRECISION RONE, RZERO PARAMETER(RONE=1.0D0,RZERO=0.0D0) C TMP VARS INTEGER(8) :: RESZR, RESZC INTEGER(8) :: INTSZR, INTSZC INTEGER MAXMN INTEGER I, IERROR, IOMP DOUBLE PRECISION ONEERRROW, ONEERRCOL, ONEERRL, ONEERRG DOUBLE PRECISION INFERRROW, INFERRCOL, INFERRL, INFERRG LOGICAL OORANGEIND INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER :: NOMP !$ INTEGER :: CHUNK, CHUNK_NZ !$ ! Too large => pb with cache L3 ? !$ ! INTEGER(8) :: CHUNK8 !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = omp_get_max_threads() !$ CHUNK = max(K361/2, (N+NOMP-1) / NOMP ) !$ ! CHUNK8= (NZ_loc+int(NOMP-1,8) / int(NOMP,8) ) ) !$ CHUNK_NZ = max(K361/2, (N+NOMP_MAX-1) / NOMP_MAX ) !$ ENDIF C OORANGEIND = .FALSE. INFERRG = -RONE ONEERRG = -RONE MAXMN = M IF(MAXMN < N) MAXMN = N C Create row partvec and col partvec IF(OP == 1) THEN IF(NUMPROCS > 1) THEN C Check done outside C IF(IWRKSZ.LT.4*MAXMN) THEN ERROR.... CALL ZMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, M, N, & IWRK, IWRKSZ, INUMMYR, NOMP_MAX) CALL ZMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & JCN_loc, IRN_loc, NZ_loc, & CPARTVEC, N, M, & IWRK, IWRKSZ, INUMMYC, NOMP_MAX) C Compute sndrcv sizes, store them for later use CALL ZMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, M, RPARTVEC, & NZ_loc, IRN_loc, N, JCN_loc, & IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM,ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) CALL ZMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, N, CPARTVEC, & NZ_loc, JCN_loc, M, IRN_loc, & ICSNDRCVNUM,ICSNDRCVVOL, & OCSNDRCVNUM,OCSNDRCVVOL, & IWRK,IWRKSZ, & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), COMM) INTSZR = int(IRSNDRCVNUM,8) + int(ORSNDRCVNUM,8) + & int(IRSNDRCVVOL,8) + int(ORSNDRCVVOL,8) + & 2_8*int(NUMPROCS+1,8) + int(INUMMYR,8) INTSZC = int(ICSNDRCVNUM,8) + int(OCSNDRCVNUM,8) + & int(ICSNDRCVVOL,8) + int(OCSNDRCVVOL,8) + & 2_8*int(NUMPROCS+1,8) + int(INUMMYC,8) INTSZ = INTSZR + INTSZC + int(MAXMN,8) + & int(MPI_STATUS_SIZE +1,8) * int(NUMPROCS,8) ELSE C NUMPROCS IS 1 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 ICSNDRCVNUM = 0 OCSNDRCVNUM = 0 ICSNDRCVVOL = 0 OCSNDRCVVOL = 0 INUMMYC = 0 INTSZ = 0_8 ENDIF C CALCULATE NECESSARY DOUBLE PRECISION SPACE RESZR = int(M,8) + int(IRSNDRCVVOL,8) + int(ORSNDRCVVOL,8) RESZC = int(N,8) + int(ICSNDRCVVOL,8) + int(OCSNDRCVVOL,8) RESZ = RESZR + RESZC C CALCULATE NECESSARY INT SPACE C The last maxmn is tmpwork for setup comm and fillmyrowcol REGISTRE(1) = int(IRSNDRCVNUM,8) REGISTRE(2) = int(ORSNDRCVNUM,8) REGISTRE(3) = int(IRSNDRCVVOL,8) REGISTRE(4) = int(ORSNDRCVVOL,8) REGISTRE(5) = int(ICSNDRCVNUM,8) REGISTRE(6) = int(OCSNDRCVNUM,8) REGISTRE(7) = int(ICSNDRCVVOL,8) REGISTRE(8) = int(OCSNDRCVVOL,8) REGISTRE(9) = int(INUMMYR,8) REGISTRE(10) = int(INUMMYC,8) REGISTRE(11) = INTSZ REGISTRE(12) = RESZ ELSE C else of op=1. That is op=2 now. C restore the numbers IRSNDRCVNUM = int(REGISTRE(1)) ORSNDRCVNUM = int(REGISTRE(2)) IRSNDRCVVOL = int(REGISTRE(3)) ORSNDRCVVOL = int(REGISTRE(4)) ICSNDRCVNUM = int(REGISTRE(5)) OCSNDRCVNUM = int(REGISTRE(6)) ICSNDRCVVOL = int(REGISTRE(7)) OCSNDRCVVOL = int(REGISTRE(8)) INUMMYR = int(REGISTRE(9)) INUMMYC = int(REGISTRE(10)) IF(NUMPROCS > 1) THEN C Check done outsize C IF(INTSZ < REGISTRE(11)) THEN ERROR C IF(RESZ < REGISTRE(12)) THEN ERROR C Fill up myrows and my colsX CALL ZMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, CPARTVEC, M, N, & IWRK(1_8), INUMMYR, & IWRK(1_8+int(INUMMYR,8)), INUMMYC, & IWRK(1_8+int(INUMMYR,8)+int(INUMMYC,8)), & IWRKSZ-int(INUMMYR,8)-int(INUMMYC,8), NOMP_MAX ) IMYRPTR = 1_8 IMYCPTR = IMYRPTR + int(INUMMYR,8) C Set up comm and run. C set pointers in iwrk (4 parts) C C ROWS [---------------------------------------------] IRNGHBPRCS = IMYCPTR + int(INUMMYC ,8) IRSNDRCVIA = IRNGHBPRCS + int(IRSNDRCVNUM,8) IRSNDRCVJA = IRSNDRCVIA + int(NUMPROCS+1 ,8) ORNGHBPRCS = IRSNDRCVJA + int(IRSNDRCVVOL,8) ORSNDRCVIA = ORNGHBPRCS + int(ORSNDRCVNUM,8) ORSNDRCVJA = ORSNDRCVIA + int(NUMPROCS+1 ,8) C COLS [---------------------------------------------] ICNGHBPRCS = ORSNDRCVJA + int(ORSNDRCVVOL,8) ICSNDRCVIA = ICNGHBPRCS + int(ICSNDRCVNUM,8) ICSNDRCVJA = ICSNDRCVIA + int(NUMPROCS+1 ,8) OCNGHBPRCS = ICSNDRCVJA + int(ICSNDRCVVOL,8) OCSNDRCVIA = OCNGHBPRCS + int(OCSNDRCVNUM,8) OCSNDRCVJA = OCSNDRCVIA + int(NUMPROCS+1 ,8) C C MPI [-----------------] REQUESTS = OCSNDRCVJA + int(OCSNDRCVVOL,8) ISTATUS = REQUESTS + int(NUMPROCS,8) C C TMPWRK [-----------------] TMPWORK = ISTATUS + int(MPI_STATUS_SIZE,8)*int(NUMPROCS,8) CALL ZMUMPS_SETUPCOMMS(MYID, NUMPROCS, M, RPARTVEC, & NZ_loc, IRN_loc,N, JCN_loc, & IRSNDRCVNUM, IRSNDRCVVOL, & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_ROW, COMM) CALL ZMUMPS_SETUPCOMMS(MYID, NUMPROCS, N, CPARTVEC, & NZ_loc, JCN_loc, M, IRN_loc, & ICSNDRCVNUM, ICSNDRCVVOL, & IWRK(ICNGHBPRCS), & IWRK(ICSNDRCVIA), & IWRK(ICSNDRCVJA), & OCSNDRCVNUM, OCSNDRCVVOL, & IWRK(OCNGHBPRCS),IWRK(OCSNDRCVIA),IWRK(OCSNDRCVJA), & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_COL, COMM) CALL ZMUMPS_INITREAL(ROWSCA, M, RZERO, NOMP_MAX) CALL ZMUMPS_INITREAL(COLSCA, N, RZERO, NOMP_MAX) CALL ZMUMPS_INITREALLST(ROWSCA, M, & IWRK(IMYRPTR),INUMMYR, RONE, NOMP_MAX) CALL ZMUMPS_INITREALLST(COLSCA, N, & IWRK(IMYCPTR),INUMMYC, RONE, NOMP_MAX) ELSE CALL ZMUMPS_INITREAL(ROWSCA, M, RONE, NOMP_MAX) CALL ZMUMPS_INITREAL(COLSCA, N, RONE, NOMP_MAX) ENDIF ITDRPTR = 1_8 ITDCPTR = ITDRPTR + int(M,8) C ISRRPTR = ITDCPTR + int(N,8) OSRRPTR = ISRRPTR + int(IRSNDRCVVOL,8) C ISRCPTR = OSRRPTR + int(ORSNDRCVVOL,8) OSRCPTR = ISRCPTR + int(ICSNDRCVVOL,8) C To avoid bound check errors... IF(NUMPROCS == 1)THEN OSRCPTR = OSRCPTR - 1_8 ISRCPTR = ISRCPTR - 1_8 OSRRPTR = OSRRPTR - 1_8 ISRRPTR = ISRRPTR - 1_8 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1_8 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1_8 IF(ICSNDRCVVOL == 0) ISRCPTR = ISRCPTR - 1_8 IF(OCSNDRCVVOL == 0) OSRCPTR = OSRCPTR - 1_8 ENDIF ITER = 1 DO WHILE (ITER.LE.NB1+NB2+NB3) C{ C ------------------------- C CLEAR temporary Dr and Dc C ------------------------- IF (NOMP_MAX.GT.1 .AND. & (ITER.GT.NB1 .AND.ITER.LE.NB1+NB2) & ) THEN C{ !$OMP PARALLEL !$OMP& PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 IF(NUMPROCS > 1) THEN CALL ZMUMPS_ZEROOUT(WRKR_TH(1,IOMP),N, & IWRK(IMYRPTR),INUMMYR, 0) CALL ZMUMPS_ZEROOUT(WRKC_TH(1,IOMP),N, & IWRK(IMYCPTR),INUMMYC, 0) ELSE CALL ZMUMPS_INITREAL(WRKR_TH(1,IOMP),N, RZERO, & 0) CALL ZMUMPS_INITREAL(WRKC_TH(1,IOMP),N, RZERO, & 0) ENDIF !$OMP END PARALLEL C} ELSE C{ IF(NUMPROCS > 1) THEN CALL ZMUMPS_ZEROOUT(WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) CALL ZMUMPS_ZEROOUT(WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) ELSE CALL ZMUMPS_INITREAL(WRKRC(ITDRPTR),M, RZERO, & NOMP_MAX) CALL ZMUMPS_INITREAL(WRKRC(ITDCPTR),N, RZERO, & NOMP_MAX) ENDIF C} ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN C ------------------ C INF-NORM ITERATION C ------------------ IF (NOMP_MAX.LE.0) THEN IF((ITER.EQ.1).OR.(OORANGEIND)) THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) IF(WRKRC(IR) int(K361,8) .AND. NOMP .GT. 1) !$OMP& REDUCTION(.OR.:OORANGEIND) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) !$OMP ATOMIC UPDATE WRKRC(IR)= max (ELM, WRKRC(IR)) !$OMP END ATOMIC C IF(WRKRC(ITDRPTR-1_8+int(IR,8)) int4 !$OMP ATOMIC UPDATE WRKRC(ITDCPTR-1_8+int(IC,8)) = & max (ELM,WRKRC(ITDCPTR-1_8+int(IC,8))) !$OMP END ATOMIC ELSE OORANGEIND = .TRUE. ENDIF ENDDO !$OMP END PARALLEL DO ELSEIF(.NOT.OORANGEIND) THEN !$OMP PARALLEL DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) DO NZIND=1,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) C IF(WRKRC(ITDRPTR-1_8+int(IR,8)) 1) THEN CALL ZMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, & ICSNDRCVNUM,IWRK(ICNGHBPRCS), & ICSNDRCVVOL,IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), & WRKRC(ISRCPTR), & OCSNDRCVNUM,IWRK(OCNGHBPRCS), & OCSNDRCVVOL,IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), & WRKRC( OSRCPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) C CALL ZMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, & IRSNDRCVNUM,IWRK(IRNGHBPRCS), & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM,IWRK(ORNGHBPRCS), & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = ZMUMPS_ERRSCALOC(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) C find error for the cols INFERRCOL = ZMUMPS_ERRSCALOC(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) C get max of those two errors INFERRL = INFERRCOL IF(INFERRROW > INFERRL ) THEN INFERRL = INFERRROW ENDIF C CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL ZMUMPS_UPDATESCALE(COLSCA, & WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) CALL ZMUMPS_UPDATESCALE(ROWSCA, & WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE C SINGLE PROCESSOR CASE: INF-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = ZMUMPS_ERRSCA1(ROWSCA, & WRKRC(ITDRPTR), M, NOMP_MAX) C find error for the cols INFERRCOL = ZMUMPS_ERRSCA1(COLSCA, & WRKRC(ITDCPTR), N, NOMP_MAX) C get max of those two errors INFERRL = INFERRCOL IF(INFERRROW > INFERRL) THEN INFERRL = INFERRROW ENDIF INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL ZMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N, & NOMP_MAX) CALL ZMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M, & NOMP_MAX) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE C ---------------------------------------- C WE HAVE ITER.GT.NB1 AND ITER.LE.NB1+NB2. C ONE-NORM ITERATION C ---------------------------------------- IF (NOMP_MAX.LE.1) THEN IF((ITER .EQ.1).OR.(OORANGEIND))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) C WRKRC(ITDRPTR-1_8+int(IR,8)) = C & WRKRC(ITDRPTR-1_8+int(IR,8)) + ELM WRKRC(IR) = WRKRC(IR) + ELM WRKRC(ITDCPTR-1_8+int(IC,8)) = & WRKRC(ITDCPTR-1_8+int(IC,8)) + ELM ELSE OORANGEIND = .TRUE. ENDIF ENDDO ELSEIF(.NOT.OORANGEIND) THEN DO NZIND=1,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) C WRKRC(ITDRPTR-1_8+int(IR,8)) = C & WRKRC(ITDRPTR-1_8+int(IR,8)) + ELM WRKRC(IR) = WRKRC(IR) + ELM WRKRC(ITDCPTR-1_8+int(IC,8)) = & WRKRC(ITDCPTR-1_8+int(IC,8)) + ELM ENDDO ENDIF C} ELSE ! NOMP_MAX>1 IF((ITER .EQ.1).OR.(OORANGEIND))THEN !$OMP PARALLEL PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 !$OMP DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) !$OMP& REDUCTION(.OR.:OORANGEIND) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) WRKR_TH(IR,IOMP) = WRKR_TH(IR,IOMP) + ELM IF (IR.NE.IC) & WRKC_TH(IC,IOMP) = WRKC_TH(IC,IOMP) + ELM ELSE OORANGEIND = .TRUE. ENDIF ENDDO !$OMP END DO !$OMP END PARALLEL ELSEIF(.NOT.OORANGEIND) THEN !$OMP PARALLEL PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 !$OMP DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) DO NZIND=1,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) WRKR_TH(IR,IOMP) = WRKR_TH(IR,IOMP) + ELM IF (IR.NE.IC) & WRKC_TH(IC,IOMP) = WRKC_TH(IC,IOMP) + ELM ENDDO !$OMP END DO !$OMP END PARALLEL ENDIF C C For all i on MYID: C Build WRKRC(i) = Sum (WRKR_TH(i,IOMP) C IOMP \in [1:NOMP_MAX] IF(NUMPROCS > 1) THEN CALL ZMUMPS_REDUCE_WRK_MPI (WRKRC, N, WRKR_TH, & NOMP_MAX, & IWRK(IMYRPTR),INUMMYR) CALL ZMUMPS_REDUCE_WRK_MPI (WRKRC(ITDCPTR), & N, WRKC_TH, NOMP_MAX, & IWRK(IMYCPTR),INUMMYC) ELSE CALL ZMUMPS_REDUCE_WRK (WRKRC, N, WRKR_TH, NOMP_MAX) CALL ZMUMPS_REDUCE_WRK (WRKRC(ITDCPTR), & N, WRKC_TH, NOMP_MAX) ENDIF C} ENDIF IF(NUMPROCS > 1) THEN CALL ZMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, & ICSNDRCVNUM, IWRK(ICNGHBPRCS), & ICSNDRCVVOL, IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), & WRKRC(ISRCPTR), & OCSNDRCVNUM, IWRK(OCNGHBPRCS), & OCSNDRCVVOL, IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), & WRKRC( OSRCPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) C CALL ZMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, & IRSNDRCVNUM, IWRK(IRNGHBPRCS), & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM, IWRK(ORNGHBPRCS), & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = ZMUMPS_ERRSCALOC(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) C find error for the cols ONEERRCOL = ZMUMPS_ERRSCALOC(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) C get max of those two errors ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL ) THEN ONEERRL = ONEERRROW ENDIF C CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL ZMUMPS_UPDATESCALE(COLSCA, & WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) CALL ZMUMPS_UPDATESCALE(ROWSCA, & WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE C SINGLE-PROCESSOR CASE: ONE-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = ZMUMPS_ERRSCA1(ROWSCA, & WRKRC(ITDRPTR), M, NOMP_MAX) C find error for the cols ONEERRCOL = ZMUMPS_ERRSCA1(COLSCA, & WRKRC(ITDCPTR), N, NOMP_MAX) C get max of those two errors ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL) THEN ONEERRL = ONEERRROW ENDIF ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL ZMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N, & NOMP_MAX) CALL ZMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M, & NOMP_MAX) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL ZMUMPS_UPDATESCALE(COLSCA, WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) CALL ZMUMPS_UPDATESCALE(ROWSCA, WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) C ELSE C SINGLE PROCESSOR CASE: Conv check and update of sca arrays CALL ZMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N, & NOMP_MAX) CALL ZMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M, & NOMP_MAX) ENDIF ITER = ITER + 1 C} ENDDO ONENORMERR = ONEERRG INFNORMERR = INFERRG IF(NUMPROCS > 1) THEN C{ CALL MPI_REDUCE(ROWSCA, WRKRC(1), M, MPI_DOUBLE_PRECISION, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN DO I=1, M ROWSCA(I) = WRKRC(I) ENDDO ENDIF C Scaling factors are printed C WRITE (6,*) MYID, 'ROWSCA=',ROWSCA C WRITE (6,*) MYID, 'COLSCA=',COLSCA C CALL FLUSH(6) c REduce the whole scaling factors to processor 0 of COMM CALL MPI_REDUCE(COLSCA, WRKRC(1_8+int(M,8)), N, & MPI_DOUBLE_PRECISION, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN C{ IF (NOMP_MAX.LE.0) THEN DO I=1, N COLSCA(I) = WRKRC(int(I,8)+int(M,8)) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1, N COLSCA(I) = WRKRC(int(I,8)+int(M,8)) ENDDO !$OMP END PARALLEL DO ENDIF C} ENDIF C} ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SIMSCALEABSUNS C C C SEPARATOR: Another function begins C C SUBROUTINE ZMUMPS_SIMSCALEABSSYM(IRN_loc, JCN_loc, A_loc, NZ_loc, & N, NUMPROCS, MYID, COMM, & PARTVEC, & RSNDRCVSZ, & REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & SCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, NOMP_MAX, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) C---------------------------------------------------------------------- C Input parameters: C N: size of matrix (sym matrix, square). C NUMPROCS, MYID, COMM: guess what are those C PARTVEC: row/col partvec to be filled when OP=1 C RSNDRCVSZ:send recv sizes for row/col operations. C to be filled when OP=1 C REGISTRE: to store some pointers (size etc). Its size is 12, C but we do not use all in this routine. C IWRK: working space. when OP=1 IWRKSZ.GE.2*MAXMN C when OP=2 INTSZ portion is used. Donc, IWRKSZ>INTSZ C when OP=2 C IWRKSZ: size C INTSZ: to be computed when OP=1, necessary integer space to run C scaling algo when OP=2 C RESZ: to be computed when OP=1, necessary real space to run C scaling algo when OP=2 C OP: C =1 estimation of memory and construction of partvecs C writes into PARTVEC,RSNDRCVSZ,REGISTRE C does not access WRKRC, uses IWRK as workspace C computes INTSZ and RESZ. C =2 Compute scalings C restores pointers from REGISTRE, C stores communication structure in IWRK (from the start). C C SCA: space for row/col scaling factor; has size M C WRKRC: real working space. when OP=1, is not accessed. Donc, it C can be declared to be of size 1 at OP=1 call. C ISZWRKRC: size C SYM: is matrix symmetric C NB1, NB2, NB3: algo runs C NB1 iters of inf-norm (default 1/1), C NB2 iters of 1-norm (default 3/10), C NB3 iters of inf-norm (default 3/10). C in succession. C EPS: tolerance for concergence. C IF EPS < 0.R0 then does not test convergence. C See comments for the uns case above. C ONENORMERR : error in one norm scaling (see comments for the C uns case above), C INFNORMERR : error in inf norm scaling (see comments for the C uns case above). C--------------------------------------------------------------------- C On input: C OP=1==>Requirements C IWRKSZ.GE.2*MAXMN XXXX compare with uns variant. C PARTVEC of size N C SNDRCVSZ of size 2*NUMPROCS C REGISTRE of size 12 C C OP=2==>Requirements C INTSZ .GE. REGISTRE(11) C RESZ .GE. REGISTRE(12) C--------------------------------------------------------------------- C On output: C SCA C at processor 0 of COMM: complete factors. C at other processors : only the SCA(i) and SCA(j) C for which there is a nonzero a_ij. C ONENORMERR : error in one norm scaling C = -1.0 if iter2=0. C INFNORMERR : error in inf norm scaling C = inf norm error at iter3 if iter3 > 0 C = inf norm error at iter1 if iter1 > 0, iter3=0 C = -1.0 if iter1=iter3=0 C --------------------------------------------------------------------- C NOTE: some variables are named in such a way that they correspond C to the row variables in unsym case. They are used for both C row and col communications. C --------------------------------------------------------------------- C References: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C C The parallelization approach is based on discussion in C [3] P. R. Amestoy, I. S. Duff, D. Ruiz, and B. Ucar, "A parallel C matrix scaling algorithm", accepted for publication, C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, Jan'08. C and was supported by ANR-SOLSTICE project (ANR-06-CIS6-010) C --------------------------------------------------------------------- !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER N, OP INTEGER(8) :: IWRKSZ, LWRKR_TH INTEGER NUMPROCS, MYID, COMM, NOMP_MAX INTEGER(8) :: 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(8) :: REGISTRE(12) DOUBLE PRECISION SCA(N) INTEGER(8) :: ISZWRKRC DOUBLE PRECISION WRKRC(ISZWRKRC), & WRKR_TH(LWRKR_TH, max(NOMP_MAX,1)) C LOCALS INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER INUMMYR C IMPORTANT POINTERS INTEGER(8) :: IMYRPTR,IMYCPTR INTEGER(8) :: IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER(8) :: ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER(8) :: ISTATUS, REQUESTS, TMPWORK INTEGER(8) :: ITDRPTR, ISRRPTR, OSRRPTR DOUBLE PRECISION ONENORMERR,INFNORMERR C FOR the scaling phase INTEGER NB1, NB2, NB3 DOUBLE PRECISION EPS C Iteration vars INTEGER ITER, IR, IC INTEGER(8) :: NZIND DOUBLE PRECISION ELM C COMM TAGS.... INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) C FUNCTIONS EXTERNAL ZMUMPS_CREATEPARTVECSYM, & ZMUMPS_NUMVOLSNDRCVSYM, & ZMUMPS_SETUPCOMMSSYM, & ZMUMPS_FILLMYROWCOLINDICESSYM, & ZMUMPS_DOCOMMINF, & ZMUMPS_DOCOMM1N, & ZMUMPS_INITREAL, & ZMUMPS_INITREALLST DOUBLE PRECISION ZMUMPS_ERRSCALOC DOUBLE PRECISION ZMUMPS_ERRSCA1 INTRINSIC abs DOUBLE PRECISION RONE, RZERO PARAMETER(RONE=1.0D0,RZERO=0.0D0) C TMP VARS INTEGER(8) :: INTSZR INTEGER MAXMN INTEGER I, IERROR DOUBLE PRECISION ONEERRL, ONEERRG DOUBLE PRECISION INFERRL, INFERRG LOGICAL OORANGEIND INTEGER, PARAMETER :: K361 = 2048 INTEGER :: IOMP !$ INTEGER :: NOMP !$ INTEGER :: CHUNK, CHUNK_NZ !$ ! Too large => pb with cache L3 ? !$ ! INTEGER(8) :: CHUNK8 !$ ! CHUNK8= max(int(K361/2,8), !$ ! & (NZ_loc+int(NOMP-1,8) / int(NOMP,8) ) ) !$ ! CHUNK8 = min(CHUNK8, huge(CHUNK)-1_8) !$ NOMP = omp_get_max_threads() !$ CHUNK= max(K361/2, (N+NOMP-1) / NOMP ) !$ IF (NOMP_MAX.GT.0) THEN !$ CHUNK_NZ = max(K361/2, (N+NOMP_MAX-1) / NOMP_MAX ) !$ ENDIF C OORANGEIND = .FALSE. INFERRG = -RONE ONEERRG = -RONE MAXMN = N IF(OP == 1) THEN C{ IF(NUMPROCS > 1) THEN C Check done outside C IF(IWRKSZ.LT.2*MAXMN) THEN ERROR.... CALL ZMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK, IWRKSZ, INUMMYR ) C C Check done outside CALL ZMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc, JCN_loc, IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) C C INTSZR = int(IRSNDRCVNUM,8) + int(ORSNDRCVNUM,8) + & int(IRSNDRCVVOL,8) + int(ORSNDRCVVOL,8) + & 2_8*int(NUMPROCS+1,8) + int(INUMMYR,8) INTSZ = INTSZR + int(N,8) + & int(MPI_STATUS_SIZE +1,8) * int(NUMPROCS,8) ELSE C NUMPROCS IS 1 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 INTSZ = 0_8 ENDIF C CALCULATE NECESSARY DOUBLE PRECISION SPACE RESZ = int(N,8) + int(IRSNDRCVVOL,8) + int(ORSNDRCVVOL,8) REGISTRE(1) = int(IRSNDRCVNUM,8) REGISTRE(2) = int(ORSNDRCVNUM,8) REGISTRE(3) = int(IRSNDRCVVOL,8) REGISTRE(4) = int(ORSNDRCVVOL,8) REGISTRE(9) = int(INUMMYR,8) REGISTRE(11) = INTSZ REGISTRE(12) = RESZ C} ELSE C{ C else of op=1. That is op=2 now. C restore the numbers IRSNDRCVNUM = int(REGISTRE(1)) ORSNDRCVNUM = int(REGISTRE(2)) IRSNDRCVVOL = int(REGISTRE(3)) ORSNDRCVVOL = int(REGISTRE(4)) INUMMYR = int(REGISTRE(9)) IF(NUMPROCS > 1) THEN C Check done outsize C IF(INTSZ < REGISTRE(11)) THEN ERROR C IF(RESZ < REGISTRE(12)) THEN ERROR C Fill up myrows and my colsX CALL ZMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK(1), INUMMYR, & IWRK(1+INUMMYR), IWRKSZ-int(INUMMYR,8), NOMP_MAX) IMYRPTR = 1_8 IMYCPTR = IMYRPTR + int(INUMMYR,8) C Set up comm and run. C set pointers in iwrk (3 parts) C C ROWS [---------------------------------------------] IRNGHBPRCS = IMYCPTR IRSNDRCVIA = IRNGHBPRCS + int(IRSNDRCVNUM,8) IRSNDRCVJA = IRSNDRCVIA + int(NUMPROCS+1,8) ORNGHBPRCS = IRSNDRCVJA + int(IRSNDRCVVOL,8) ORSNDRCVIA = ORNGHBPRCS + int(ORSNDRCVNUM,8) ORSNDRCVJA = ORSNDRCVIA + int(NUMPROCS + 1,8) C MPI [-----------------] REQUESTS = ORSNDRCVJA + int(ORSNDRCVVOL,8) ISTATUS = REQUESTS + int(NUMPROCS,8) C TMPWRK [-----------------] TMPWORK = ISTATUS + int(MPI_STATUS_SIZE,8)*int(NUMPROCS,8) CALL ZMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc, JCN_loc, & IRSNDRCVNUM, IRSNDRCVVOL, & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_ROW, COMM) CALL ZMUMPS_INITREAL(SCA, N, RZERO, NOMP_MAX) CALL ZMUMPS_INITREALLST(SCA, N, & IWRK(IMYRPTR),INUMMYR, RONE, NOMP_MAX) ELSE CALL ZMUMPS_INITREAL(SCA, N, RONE, NOMP_MAX) ENDIF ITDRPTR = 1_8 ISRRPTR = ITDRPTR + int(N,8) OSRRPTR = ISRRPTR + int(IRSNDRCVVOL,8) C C To avoid bound check errors... IF(NUMPROCS == 1)THEN OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 ENDIF C computation starts ITER = 1 DO WHILE(ITER.LE.NB1+NB2+NB3) C{ C ------------------------- C CLEAR temporary Dr and Dc C ------------------------- IF (NOMP_MAX.GT.1 .AND. & (ITER.GT.NB1 .AND.ITER.LE.NB1+NB2) & ) THEN C if one norm iteration and multithreading activated C WRKR_TH need be initialized and C WRKRC will be set by reduction of WRKR_TH !$OMP PARALLEL !$OMP& PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 IF(NUMPROCS > 1) THEN CALL ZMUMPS_ZEROOUT(WRKR_TH(1,IOMP),N, & IWRK(IMYRPTR),INUMMYR, 0) ELSE CALL ZMUMPS_INITREAL(WRKR_TH(1,IOMP),N, RZERO, & 0) ENDIF !$OMP END PARALLEL ELSE IF(NUMPROCS > 1) THEN CFIXME Size N should be adjusted to effective size CALL ZMUMPS_ZEROOUT(WRKRC(ITDRPTR),N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) ELSE CALL ZMUMPS_INITREAL(WRKRC(ITDRPTR),N, RZERO, & NOMP_MAX) ENDIF ENDIF C IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN C ------------------ C{ INF-NORM ITERATION C ------------------ IF (NOMP_MAX.LE.0) THEN IF((ITER .EQ.1).OR.(OORANGEIND))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) IF (WRKRC(IR) int(K361,8) .AND. NOMP .GT. 1) !$OMP& REDUCTION(.OR.:OORANGEIND) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) !$OMP ATOMIC UPDATE WRKRC(IR)= max (ELM, WRKRC(IR)) !$OMP END ATOMIC C IF(WRKRC(ITDRPTR-1_8+int(IR,8)) int(K361,8) .AND. NOMP .GT. 1) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) !$OMP ATOMIC UPDATE WRKRC(IR)= max (ELM, WRKRC(IR)) !$OMP END ATOMIC C IF(WRKRC(ITDRPTR-1_8+int(IR,8)) 1) THEN C{ CALL ZMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, & IRSNDRCVNUM,IWRK(IRNGHBPRCS), & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM,IWRK(ORNGHBPRCS), & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) CCCC FIXME #if defined(dev_version) IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = ZMUMPS_ERRSCALOC(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL ZMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF CCC #endif C} ELSE C{ SINGLE PROCESSOR CASE: INF-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = ZMUMPS_ERRSCA1(SCA, & WRKRC(ITDRPTR), N, NOMP_MAX) INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL ZMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N, & NOMP_MAX) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF C} ENDIF C} ELSE C ---------------------------------------- C{ WE HAVE ITER.GT.NB1 AND ITER.LE.NB1+NB2. C ONE-NORM ITERATION C ---------------------------------------- IF (NOMP_MAX.LE.1) THEN IF((ITER.EQ.1).OR.(OORANGEIND))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKRC(IR) = WRKRC(IR) + ELM IF(IR.NE.IC) THEN WRKRC(IC) = WRKRC(IC) + ELM ENDIF ELSE OORANGEIND = .TRUE. ENDIF ENDDO ELSEIF(.NOT.OORANGEIND)THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKRC(IR) = WRKRC(IR) + ELM IF(IR.NE.IC) THEN WRKRC(IC) = WRKRC(IC) + ELM ENDIF ENDDO ENDIF ELSE ! NOMP_MAX>1 IF((ITER.EQ.1).OR.(OORANGEIND))THEN !$OMP PARALLEL PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 !$OMP DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) !$OMP& REDUCTION(.OR.:OORANGEIND) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKR_TH(IR,IOMP) = WRKR_TH(IR,IOMP) + ELM IF(IR.NE.IC) THEN WRKR_TH(IC,IOMP) = WRKR_TH(IC,IOMP) + ELM ENDIF ELSE OORANGEIND = .TRUE. ENDIF ENDDO !$OMP END DO !$OMP END PARALLEL ELSEIF(.NOT.OORANGEIND)THEN !$OMP PARALLEL PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 !$OMP DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKR_TH(IR,IOMP) = WRKR_TH(IR,IOMP) + ELM IF(IR.NE.IC) THEN WRKR_TH(IC,IOMP) = WRKR_TH(IC,IOMP) + ELM ENDIF ENDDO !$OMP END DO !$OMP END PARALLEL C} ENDIF C C For all i on MYID: C Build WRKRC(i) = Sum (WRKR_TH(i,IOMP) C IOMP \in [1:NOMP_MAX] IF(NUMPROCS > 1) THEN CALL ZMUMPS_REDUCE_WRK_MPI (WRKRC, N, WRKR_TH, & NOMP_MAX, & IWRK(IMYRPTR),INUMMYR) ELSE CALL ZMUMPS_REDUCE_WRK (WRKRC, N, WRKR_TH, NOMP_MAX) ENDIF ENDIF IF(NUMPROCS > 1) THEN C{ CALL ZMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, & IRSNDRCVNUM, IWRK(IRNGHBPRCS), & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM, IWRK(ORNGHBPRCS), & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = ZMUMPS_ERRSCALOC(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) C mpi allreduce. CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL ZMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF C} ELSE C{ SINGLE-PROCESSOR CASE: ONE-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = ZMUMPS_ERRSCA1(SCA, & WRKRC(ITDRPTR), N, NOMP_MAX) ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL ZMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N, & NOMP_MAX) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF C} ENDIF IF(NUMPROCS > 1) THEN CALL ZMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) ELSE CALL ZMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N, & NOMP_MAX) ENDIF ITER = ITER + 1 C} ENDDO ONENORMERR = ONEERRG INFNORMERR = INFERRG IF(NUMPROCS > 1) THEN C{ CALL MPI_REDUCE(SCA, WRKRC(1), N, MPI_DOUBLE_PRECISION, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN IF (NOMP_MAX.LE.0) THEN DO I=1, N SCA(I) = WRKRC(I) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1, N SCA(I) = WRKRC(I) ENDDO !$OMP END PARALLEL DO ENDIF ENDIF C} ENDIF C} ENDIF RETURN END SUBROUTINE ZMUMPS_SIMSCALEABSSYM MUMPS_5.8.1/src/mumps_config_file_C.h0000664000175000017500000000131215042446422017325 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_CONFIG_FILE_C_H #define MUMPS_CONFIG_FILE_C_H #include "mumps_common.h" #define MUMPS_CONFIG_FILE_RETURN_C \ F_SYMBOL(config_file_return_c,CONFIG_FILE_RETURN_C) void MUMPS_CALL MUMPS_CONFIG_FILE_RETURN_C(); #endif /* MUMPS_CONFIG_FILE_C_H */ MUMPS_5.8.1/src/cfac_mem_dynamic.F0000664000175000017500000005163015042446440016602 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_DYNAMIC_MEMORY_M CONTAINS SUBROUTINE CMUMPS_DM_ALLOC_S_WK(S, MAXS, allocok, & KEEP430, KEEP35 ) IMPLICIT NONE COMPLEX, DIMENSION(:), POINTER :: S INTEGER(8) :: MAXS INTEGER, INTENT(IN) :: KEEP35 INTEGER, INTENT(IN) :: KEEP430 INTEGER, INTENT(OUT) :: allocok INTEGER(8) :: TMP_ADDRESS8 IF (KEEP430.EQ.0) THEN ALLOCATE(S(MAXS), stat=allocok) ELSE IF (KEEP430.EQ.1) THEN CALL MUMPS_MALLOC_C( TMP_ADDRESS8, max(MAXS,1_8) * KEEP35 ) ELSE WRITE(*,*) "KEEP430: wrong value", KEEP430 CALL MUMPS_ABORT() ENDIF IF (TMP_ADDRESS8 .EQ. 0_8) THEN allocok = 1 ELSE allocok = 0 CALL CMUMPS_DM_SET_PTR( TMP_ADDRESS8, max(MAXS,1_8), S ) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_DM_ALLOC_S_WK SUBROUTINE CMUMPS_DM_FREE_S_WK( S, KEEP430 ) IMPLICIT NONE COMPLEX, DIMENSION(:), POINTER :: S INTEGER, INTENT(IN) :: KEEP430 IF ( KEEP430 .EQ. 0 ) THEN DEALLOCATE(S) ELSE IF ( KEEP430 .EQ. 1 ) THEN CALL MUMPS_FREE_C(S(1)) #if defined(USE_XKBLAS) #endif ELSE WRITE(*,*) "KEEP430: wrong value", KEEP430 CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE CMUMPS_DM_FREE_S_WK SUBROUTINE CMUMPS_DM_SET_DYNPTR( CB_STATE, A, LA, & PAMASTER_OR_PTRAST, IXXD, & IXXR, SON_A, IACHK, RECSIZE ) IMPLICIT NONE INTEGER, INTENT(IN) :: CB_STATE INTEGER, INTENT(IN) :: IXXR(2), IXXD(2) INTEGER(8), INTENT(IN) :: LA, PAMASTER_OR_PTRAST COMPLEX, INTENT(IN), TARGET :: A( LA ) #if defined(MUMPS_NOF2003) COMPLEX, POINTER, DIMENSION(:) :: SON_A #else COMPLEX, POINTER, DIMENSION(:), INTENT(OUT) :: SON_A #endif INTEGER(8), INTENT(OUT) :: IACHK, RECSIZE IF ( CMUMPS_DM_IS_DYNAMIC( IXXD ) ) THEN CALL MUMPS_GETI8(RECSIZE, IXXD) CALL CMUMPS_DM_SET_PTR( PAMASTER_OR_PTRAST, RECSIZE, SON_A ) IACHK = 1_8 ELSE CALL MUMPS_GETI8(RECSIZE, IXXR) IACHK = PAMASTER_OR_PTRAST SON_A => A ENDIF RETURN END SUBROUTINE CMUMPS_DM_SET_DYNPTR SUBROUTINE CMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP28, & KEEP199, INODE, CB_STATE, IXXD, & STEP, DAD, PROCNODE_STEPS, & RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IMPLICIT NONE INTEGER, INTENT(in) :: KEEP28, N, SLAVEF, MYID, INODE, CB_STATE INTEGER, INTENT(in) :: KEEP199 INTEGER, INTENT(in) :: IXXD(2) INTEGER, INTENT(in) :: DAD(KEEP28) INTEGER, INTENT(in) :: STEP(N) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP28) LOGICAL, INTENT(out) :: IS_PAMASTER, IS_PTRAST INTEGER(8), INTENT(in) :: PAMASTER(KEEP28), PTRAST(KEEP28) INTEGER(8), INTENT(in) :: RCURRENT LOGICAL :: DAD_TYPE2_NOT_ON_MYID INTEGER :: NODETYPE, DADTYPE INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE IS_PAMASTER = .FALSE. IS_PTRAST = .FALSE. IF (CB_STATE .EQ. S_FREE) THEN RETURN ENDIF NODETYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), KEEP199) DADTYPE=-99999 DAD_TYPE2_NOT_ON_MYID = .FALSE. IF (DAD(STEP(INODE)) .NE. 0) THEN DADTYPE= MUMPS_TYPENODE( & PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP199) IF (DADTYPE .EQ. 2 .AND. & MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP199).NE.MYID & ) THEN DAD_TYPE2_NOT_ON_MYID = .TRUE. ENDIF ENDIF IF (CMUMPS_DM_ISBAND(CB_STATE)) THEN IS_PTRAST=.TRUE. ELSE IF (NODETYPE.EQ.1 & .AND. MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP199).EQ.MYID & .AND. DAD_TYPE2_NOT_ON_MYID) & THEN IS_PTRAST=.TRUE. ELSE IS_PAMASTER=.TRUE. ENDIF RETURN END SUBROUTINE CMUMPS_DM_PAMASTERORPTRAST LOGICAL FUNCTION CMUMPS_DM_ISBAND(XXSTATE) INTEGER, INTENT(IN) :: XXSTATE INCLUDE 'mumps_headers.h' SELECT CASE (XXSTATE) CASE(S_NOTFREE, S_CB1COMP); CMUMPS_DM_ISBAND = .FALSE. CASE(S_ACTIVE, S_ALL, & S_NOLCBCONTIG, S_NOLCBNOCONTIG, S_NOLCLEANED, & S_NOLCBNOCONTIG38, S_NOLCBCONTIG38, S_NOLCLEANED38, & S_NOLNOCB, S_NOLNOCBCLEANED); CMUMPS_DM_ISBAND = .TRUE. CASE(S_FREE); CMUMPS_DM_ISBAND = .FALSE. CASE DEFAULT; WRITE(*,*) "Wrong state during CMUMPS_DM_ISBAND", XXSTATE CALL MUMPS_ABORT() END SELECT RETURN END FUNCTION CMUMPS_DM_ISBAND LOGICAL FUNCTION CMUMPS_DM_IS_DYNAMIC(IXXD) INTEGER :: IXXD(2) INTEGER(8) :: DYN_SIZE CALL MUMPS_GETI8( DYN_SIZE, IXXD ) CMUMPS_DM_IS_DYNAMIC = DYN_SIZE > 0_8 RETURN END FUNCTION CMUMPS_DM_IS_DYNAMIC SUBROUTINE CMUMPS_DM_FAC_ALLOC_ALLOWED & (MEM_COUNT_TO_ALLOCATE, KEEP8, & IFLAG, IERROR) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_COUNT_TO_ALLOCATE INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR IF ( KEEP8(73) + MEM_COUNT_TO_ALLOCATE & .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & KEEP8(73) + MEM_COUNT_TO_ALLOCATE -KEEP8(75), & IERROR ) ENDIF RETURN END SUBROUTINE CMUMPS_DM_FAC_ALLOC_ALLOWED SUBROUTINE CMUMPS_DM_CBSTATIC2DYNAMIC( STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) !$ USE OMP_LIB USE MUMPS_LOAD, ONLY : MUMPS_LOAD_MEM_UPDATE IMPLICIT NONE INTEGER, INTENT(in) :: STRATEGY INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS COMPLEX, INTENT(in) :: A( LA ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER, INTENT(inout) :: IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER :: ICURRENT, INODE, TYPEINODE, CB_STATE INTEGER(8) :: RCURRENT, RCURRENT_SIZE, SIZEHOLE INTEGER(8) :: KEEP8TMPCOPY LOGICAL :: MOVE2DYNAMIC LOGICAL :: SSARBRDAD INTEGER(8) :: TMP_ADDRESS, ITMP8 INTEGER(8) :: I8 COMPLEX, DIMENSION(:), POINTER :: DYNAMIC_CB LOGICAL :: IS_PAMASTER, IS_PTRAST INTEGER :: allocok !$ INTEGER(8) :: CHUNK8 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP LOGICAL :: IFLAG_M13_OCCURED, IFLAG_M19_OCCURED INTEGER(8) :: MIN_SIZE_M13, MIN_SIZE_M19 INTEGER, EXTERNAL :: MUMPS_TYPENODE IF ( STRATEGY .EQ. 0 ) THEN IF (LRLUS.LT.SIZER_NEEDED) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) ENDIF RETURN ENDIF IFLAG_M13_OCCURED = .FALSE. MIN_SIZE_M13 = huge(MIN_SIZE_M13) IFLAG_M19_OCCURED = .FALSE. MIN_SIZE_M19 = huge(MIN_SIZE_M19) !$ NOMP = OMP_GET_MAX_THREADS() ICURRENT = IWPOSCB + 1 RCURRENT = IPTRLU + 1 IF (STRATEGY.EQ.1 .AND. SIZER_NEEDED.LE.LRLUS) GOTO 500 IF (( KEEP8(73) + SIZER_NEEDED-LRLUS).GT. & KEEP8(75)) THEN IFLAG = -19 CALL MUMPS_SET_IERROR & (KEEP8(73) + SIZER_NEEDED-LRLUS-KEEP8(75), IERROR) GOTO 500 ENDIF DO WHILE (ICURRENT .NE. LIW-KEEP(IXSZ)+1) INODE = IW(ICURRENT+XXN) CB_STATE = IW(ICURRENT+XXS) CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT+XXR)) CALL CMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP(28), & KEEP(199), INODE, CB_STATE, & IW(ICURRENT+XXD:ICURRENT+XXD+1), & STEP, DAD, PROCNODE_STEPS, & RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF ( CB_STATE .NE. S_FREE .AND. & .NOT. CMUMPS_DM_IS_DYNAMIC(IW(ICURRENT+XXD)) ) THEN TYPEINODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IF (STRATEGY .EQ. -1) THEN MOVE2DYNAMIC = .FALSE. MOVE2DYNAMIC = MOVE2DYNAMIC .OR. & CB_STATE .EQ. S_NOLCBCONTIG .OR. & CB_STATE .EQ. S_NOLCBNOCONTIG .OR. & CB_STATE .EQ. S_NOLCLEANED .OR. & CB_STATE .EQ. S_ALL .OR. & CB_STATE .EQ. S_ACTIVE ELSE IF (STRATEGY .EQ. 2 .OR. STRATEGY .EQ. 3) THEN MOVE2DYNAMIC = .TRUE. MOVE2DYNAMIC = MOVE2DYNAMIC .AND. (TYPEINODE.NE.3) ELSE IF (STRATEGY .EQ. 1) THEN MOVE2DYNAMIC = .FALSE. IF (LRLUS.GT.SIZER_NEEDED) GOTO 500 IF (TYPEINODE.EQ.3) GOTO 100 MOVE2DYNAMIC = MOVE2DYNAMIC.OR..TRUE. ELSE WRITE(*,*) "Internal error in CMUMPS_DM_CBSTATIC2DYNAMIC", & MOVE2DYNAMIC CALL MUMPS_ABORT() ENDIF MOVE2DYNAMIC = MOVE2DYNAMIC .AND. (RCURRENT_SIZE .NE. 0_8) MOVE2DYNAMIC = MOVE2DYNAMIC .AND. & .NOT. ((ICURRENT.EQ.IWPOSCB + 1).AND.(SKIP_TOP_STACK)) IF (STRATEGY .NE. 3) THEN IF ( KEEP(405) .EQ. 1 ) THEN !$OMP ATOMIC READ KEEP8TMPCOPY = KEEP8(73) !$OMP END ATOMIC ELSE KEEP8TMPCOPY = KEEP8(73) ENDIF IF ( RCURRENT_SIZE + KEEP8TMPCOPY .GT. KEEP8(75) ) THEN IFLAG_M19_OCCURED= .TRUE. MIN_SIZE_M19 = min( MIN_SIZE_M19, & RCURRENT_SIZE+KEEP8(73)-KEEP8(75) ) MOVE2DYNAMIC = .FALSE. ENDIF ENDIF IF ( MOVE2DYNAMIC ) THEN #if defined(MUMPS_ALLOC_FROM_C) || defined(_CRAYFTN) CALL MUMPS_MALLOC_C( TMP_ADDRESS, & RCURRENT_SIZE * KEEP(35) ) IF (TMP_ADDRESS .EQ. 0_8) THEN allocok=1 ELSE allocok=0 ENDIF #else ALLOCATE(DYNAMIC_CB(RCURRENT_SIZE), stat=allocok) #endif IF (allocok .GT. 0) THEN IF ( (STRATEGY .NE. 1).OR. & (SIZER_NEEDED-LRLUS).GE.RCURRENT_SIZE) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) GOTO 500 ENDIF IFLAG_M13_OCCURED = .TRUE. MIN_SIZE_M13 = min(MIN_SIZE_M13, RCURRENT_SIZE) GOTO 100 ENDIF SIZEHOLE=0_8 IF (KEEP(216).NE.3) THEN CALL CMUMPS_SIZEFREEINREC( IW(ICURRENT), & LIW-ICURRENT+1, SIZEHOLE, KEEP(IXSZ)) ENDIF CALL MUMPS_STOREI8(RCURRENT_SIZE,IW(ICURRENT+XXD)) #if defined(MUMPS_ALLOC_FROM_C) || defined(_CRAYFTN) CALL CMUMPS_DM_SET_PTR( TMP_ADDRESS, RCURRENT_SIZE, & DYNAMIC_CB ) #else CALL MUMPS_ADDR_C(DYNAMIC_CB(1), TMP_ADDRESS) #endif IF (IS_PTRAST) THEN PTRAST(STEP(INODE)) = TMP_ADDRESS ELSE IF (IS_PAMASTER) THEN PAMASTER(STEP(INODE)) = TMP_ADDRESS ELSE WRITE(*,*) & "Internal error 3 in CMUMPS_DM_CBSTATIC2DYNAMIC", & RCURRENT, PTRAST(STEP(INODE)), PAMASTER(STEP(INODE)) CALL MUMPS_ABORT() ENDIF ITMP8 = (RCURRENT_SIZE-SIZEHOLE) LRLUS = LRLUS + ITMP8 IF (KEEP(405).EQ.1) THEN IF (SIZEHOLE .NE. 0_8) THEN !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + SIZEHOLE KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max( KEEP8(68), KEEP8TMPCOPY ) !$OMP END ATOMIC ENDIF ELSE KEEP8(69) = KEEP8(69) + SIZEHOLE KEEP8(68) = max( KEEP8(68), KEEP8(69) ) ENDIF CALL MUMPS_SET_SSARBR_DAD(SSARBRDAD, INODE, & DAD, N, KEEP(28), & STEP, PROCNODE_STEPS, KEEP(199)) CALL MUMPS_LOAD_MEM_UPDATE( SSARBRDAD, .FALSE., & LA - LRLUS, 0_8, -(RCURRENT_SIZE-SIZEHOLE), & KEEP, KEEP8, LRLUS) IF (ICURRENT .EQ. IWPOSCB+1) THEN IPTRLU = IPTRLU + RCURRENT_SIZE LRLU = LRLU + RCURRENT_SIZE CALL MUMPS_STOREI8(0_8, IW(ICURRENT+XXR)) ENDIF IF (STRATEGY .NE. 3) THEN CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS ( & RCURRENT_SIZE, KEEP(405).EQ.1, KEEP8, & IFLAG, IERROR, .FALSE., .FALSE.) IF (IFLAG.LT.0) GOTO 500 ENDIF !$ CHUNK8 = max( int(KEEP(361),8), !$ & (RCURRENT_SIZE+NOMP-1) / NOMP) !$ OMP_FLAG = ( (RCURRENT_SIZE > int(KEEP(361),8)) !$ & .AND.(NOMP.GT.1) !$ & ) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (OMP_FLAG) DO I8=1_8, RCURRENT_SIZE DYNAMIC_CB(I8) = A(RCURRENT+I8-1_8) ENDDO !$OMP END PARALLEL DO ENDIF ENDIF 100 CONTINUE RCURRENT = RCURRENT + RCURRENT_SIZE ICURRENT = ICURRENT + IW(ICURRENT+XXI) END DO IF (LRLUS.LT.SIZER_NEEDED) THEN IF (IFLAG_M19_OCCURED) THEN IFLAG = -19 CALL MUMPS_SET_IERROR(MIN_SIZE_M19, IERROR) ELSE IF (IFLAG_M13_OCCURED) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(MIN_SIZE_M13, IERROR) ELSE IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_DM_CBSTATIC2DYNAMIC SUBROUTINE CMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(in) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) LOGICAL, INTENT(in) :: ATOMIC_UPDATES INCLUDE 'mumps_headers.h' INTEGER :: ICURRENT, INODE INTEGER :: CB_STATE INTEGER(8) :: DYN_SIZE, TMP_ADDRESS INTEGER(8), PARAMETER :: RDUMMY = -987654 LOGICAL :: IS_PAMASTER, IS_PTRAST COMPLEX, DIMENSION(:), POINTER :: TMP_PTR ICURRENT = IWPOSCB + 1 IF (KEEP8(73) .NE. 0_8) THEN DO WHILE (ICURRENT .LT. LIW-KEEP(IXSZ)+1) INODE = IW(ICURRENT+XXN) CB_STATE = IW(ICURRENT+XXS) IF (CB_STATE.NE.S_FREE) THEN CALL MUMPS_GETI8( DYN_SIZE, IW(ICURRENT+XXD) ) IF (DYN_SIZE .GT. 0_8) THEN CALL CMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP(28), & KEEP(199), INODE, CB_STATE, IW(ICURRENT+XXD), & STEP, DAD, PROCNODE_STEPS, & RDUMMY, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF (IS_PAMASTER) THEN TMP_ADDRESS = PAMASTER(STEP(INODE)) ELSE IF (IS_PTRAST) THEN TMP_ADDRESS = PTRAST(STEP(INODE)) ELSE WRITE(*,*) "Internal error 1 in CMUMPS_DM_FREEALLDYNAMICCB" & , IS_PTRAST, IS_PAMASTER ENDIF CALL CMUMPS_DM_SET_PTR(TMP_ADDRESS, DYN_SIZE, TMP_PTR) CALL CMUMPS_DM_FREE_BLOCK( IW(ICURRENT+XXG), & TMP_PTR, DYN_SIZE, & ATOMIC_UPDATES, KEEP8 ) CALL MUMPS_STOREI8(0_8, IW(ICURRENT+XXD)) ENDIF ENDIF ICURRENT = ICURRENT + IW(ICURRENT+XXI) ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_DM_FREEALLDYNAMICCB SUBROUTINE CMUMPS_DM_SET_PTR(ADDRESS, SIZFR8, CBPTR) USE CMUMPS_STATIC_PTR_M, ONLY : CMUMPS_GET_TMP_PTR IMPLICIT NONE INTEGER(8), INTENT(IN) :: ADDRESS, SIZFR8 #if defined(MUMPS_NOF2003) COMPLEX, DIMENSION(:), POINTER :: CBPTR #else COMPLEX, DIMENSION(:), POINTER, INTENT(out) :: CBPTR #endif !$OMP CRITICAL(STATIC_PTR_ACCESS) CALL CMUMPS_SET_TMP_PTR_C( ADDRESS, SIZFR8 ) CALL CMUMPS_GET_TMP_PTR( CBPTR ) !$OMP END CRITICAL(STATIC_PTR_ACCESS) RETURN END SUBROUTINE CMUMPS_DM_SET_PTR SUBROUTINE CMUMPS_DM_FREE_BLOCK( XXG_STATUS, DYNPTR, SIZFR8, & ATOMIC_UPDATES, KEEP8 ) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER :: XXG_STATUS COMPLEX, POINTER, DIMENSION(:) :: DYNPTR INTEGER(8) :: SIZFR8 LOGICAL, INTENT(IN) :: ATOMIC_UPDATES INTEGER(8) :: KEEP8(150) INTEGER IDUMMY #if defined(MUMPS_ALLOC_FROM_C) || defined(_CRAYFTN) CALL MUMPS_FREE_C(DYNPTR(1)) #else DEALLOCATE(DYNPTR) #endif NULLIFY(DYNPTR) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS ( & -SIZFR8, ATOMIC_UPDATES, KEEP8, IDUMMY, IDUMMY, & .TRUE., .FALSE.) RETURN END SUBROUTINE CMUMPS_DM_FREE_BLOCK END MODULE CMUMPS_DYNAMIC_MEMORY_M SUBROUTINE CMUMPS_DM_FREEALLDYNAMICCB_I( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_FREEALLDYNAMICCB IMPLICIT NONE INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(in) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) LOGICAL, INTENT(in) :: ATOMIC_UPDATES CALL CMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) RETURN END SUBROUTINE CMUMPS_DM_FREEALLDYNAMICCB_I SUBROUTINE CMUMPS_DM_CBSTATIC2DYNAMIC_I( & STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_CBSTATIC2DYNAMIC IMPLICIT NONE INTEGER, INTENT(in) :: STRATEGY INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS COMPLEX, INTENT(in) :: A( LA ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER, INTENT(inout) :: IFLAG, IERROR CALL CMUMPS_DM_CBSTATIC2DYNAMIC( STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) RETURN END SUBROUTINE CMUMPS_DM_CBSTATIC2DYNAMIC_I MUMPS_5.8.1/src/cfac_process_contrib_type1.F0000664000175000017500000001163615042446440020642 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_PROCESS_NODE( MYID,KEEP,KEEP8,DKEEP, & BUFR, LBUFR, LBUFR_BYTES, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER MYID INTEGER LBUFR, LBUFR_BYTES INTEGER KEEP(500), BUFR( LBUFR ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP, FPERE LOGICAL FLAG INTEGER NSTK_S( KEEP(28) ), ITLOC( N + KEEP(253) ) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER IFLAG, IERROR, COMM INTEGER POSITION, FINODE, FLCONT, LREQ INTEGER(8) :: LREQCB INTEGER(8) :: IPOS_NODE, ISHIFT_PACKET INTEGER SIZE_PACKET INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INCLUDE 'mumps_headers.h' LOGICAL PACKED_CB COMPLEX, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYN_SIZE FLAG = .FALSE. POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FLCONT, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, MPI_INTEGER, & COMM, IERR) PACKED_CB = (FLCONT.LT.0) IF (PACKED_CB) THEN FLCONT = -FLCONT LREQCB = (int(FLCONT,8) * int(FLCONT+1,8)) / 2_8 ELSE LREQCB = int(FLCONT,8) * int(FLCONT,8) ENDIF IF (NBROWS_ALREADY_SENT == 0) THEN LREQ = 2 * FLCONT + 6 + KEEP(IXSZ) CALL CMUMPS_ALLOC_CB( .FALSE., 0_8, .FALSE.,.FALSE., & MYID,N, KEEP,KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & LREQ, LREQCB, FINODE, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PIMASTER(STEP( FINODE )) = IWPOSCB + 1 PAMASTER(STEP( FINODE )) = IPTRLU + 1_8 IF (PACKED_CB) IW(IWPOSCB + 1 + XXS ) = S_CB1COMP CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 1+KEEP(IXSZ)), LREQ-KEEP(IXSZ), & MPI_INTEGER, COMM, IERR) ENDIF IF (PACKED_CB) THEN ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * & int(NBROWS_ALREADY_SENT+1,8) / 2_8 SIZE_PACKET = (NBROWS_PACKET * (NBROWS_PACKET+1))/2 + & NBROWS_ALREADY_SENT * NBROWS_PACKET ELSE ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * int(FLCONT,8) SIZE_PACKET = NBROWS_PACKET * FLCONT ENDIF IF (NBROWS_PACKET.NE.0) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(PIMASTER(STEP(FINODE))+XXD)) IF (DYN_SIZE .GT. 0_8) THEN CALL CMUMPS_DM_SET_PTR( PAMASTER(STEP(FINODE)), & DYN_SIZE, SON_A ) IPOS_NODE = 1_8 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & SON_A(IPOS_NODE + ISHIFT_PACKET), & SIZE_PACKET, MPI_COMPLEX, COMM, IERR) ELSE IPOS_NODE = PAMASTER(STEP(FINODE)) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & A(IPOS_NODE + ISHIFT_PACKET), & SIZE_PACKET, MPI_COMPLEX, COMM, IERR) ENDIF ENDIF IF (NBROWS_ALREADY_SENT+NBROWS_PACKET == FLCONT) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF ( NSTK_S(STEP(FPERE)).EQ.0 ) THEN FLAG = . TRUE. END IF ENDIF RETURN END SUBROUTINE CMUMPS_PROCESS_NODE MUMPS_5.8.1/src/smumps_gpu.h0000664000175000017500000000114315042446422015577 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef SMUMPS_GPU_H #define SMUMPS_GPU_H #include "mumps_compat.h" #include "mumps_common.h" void MUMPS_CALL smumps_gpu_return(); #endif /* SMUMPS_GPU_H */ MUMPS_5.8.1/src/sfac_front_aux.F0000664000175000017500000026445415042446437016365 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_FRONT_AUX_M CONTAINS SUBROUTINE SMUMPS_FAC_H(NFRONT,NASS,IW,LIW,A,LA, & INOPV,NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IOLDPS,POSELT,UU,SEUIL,KEEP, KEEP8, DKEEP, & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U,MAXFROMN,IS_MAXFROMN_AVAIL, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, NVSCHUR &) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,LIW,INOPV INTEGER(8) :: LA INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) REAL :: DKEEP(230) REAL UU, SEUIL REAL A(LA) INTEGER IW(LIW) REAL, intent(in) :: MAXFROMN LOGICAL, intent(inout) :: IS_MAXFROMN_AVAIL INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER, intent(in) :: NVSCHUR REAL AMROW REAL RMAX, SEUIL_LOC REAL SWOP INTEGER(8) :: APOS, POSELT INTEGER(8) :: J1, J2, J3_8, JJ, IDIAG INTEGER(8) :: J1_ini INTEGER(8) :: NFRONT8 INTEGER IOLDPS INTEGER NPIV,IPIV,IPIV_SHIFT INTEGER, intent(inout) :: NOFFW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW INTEGER J, J3 INTEGER NPIVP1,JMAX,ISW,ISWPS1 INTEGER ISWPS2,KSW,XSIZE INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INTEGER ISHIFT, K206 INTEGER SMUMPS_IXAMAX INCLUDE 'mumps_headers.h' INTRINSIC max REAL, PARAMETER :: RZERO = 0.0E0 #if defined(_OPENMP) INTEGER :: NOMP, CHUNK NOMP = OMP_GET_MAX_THREADS() #endif SEUIL_LOC = max(DKEEP(1), SEUIL) NFRONT8 = int(NFRONT,8) INOPV = 0 XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 K206 = KEEP(206) IF ((KEEP(50).NE.1).AND.OOC_EFFECTIVE_ON_FRONT) THEN CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE) & +KEEP(IXSZ), & IW, LIW) CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF ISHIFT = 0 IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.NASS) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF (ISHIFT.GT.0.AND.IS_MAXFROMN_AVAIL) THEN IPIV = NPIVP1 APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)) .GE. UU*MAXFROMN .AND. & abs(A(IDIAG)) .GT. max(SEUIL_LOC,tiny(RMAX)) & ) THEN ISHIFT = 0 ENDIF ENDIF IF ( ISHIFT .GT. 0) THEN IS_MAXFROMN_AVAIL = .FALSE. ENDIF ENDIF DO 460 IPIV_SHIFT=NPIVP1+ISHIFT,NASS+ISHIFT IF (IPIV_SHIFT .LE. NASS) THEN IPIV=IPIV_SHIFT ELSE IPIV=IPIV_SHIFT-NASS-1+NPIVP1 ENDIF APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) JMAX = 1 AMROW = RZERO J1 = APOS J3 = NASS -NPIV JMAX = SMUMPS_IXAMAX(J3,A(J1),NFRONT,KEEP(360)) JJ = J1 + int(JMAX-1,8)*NFRONT8 AMROW = abs(A(JJ)) RMAX = AMROW J1 = APOS + int(NASS-NPIV,8) * NFRONT8 J3 = NFRONT - NASS - KEEP(253)-NVSCHUR IF (IS_MAXFROMN_AVAIL) THEN RMAX = max(MAXFROMN,RMAX) IS_MAXFROMN_AVAIL = .FALSE. ELSE IF (J3.EQ.0) GOTO 370 #if defined(_OPENMP) IF (J3.GE.KEEP(360)) THEN J1_ini = J1 CHUNK = max(KEEP(360)/2,(J3+NOMP-1)/NOMP) !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& FIRSTPRIVATE(J1_ini,NFRONT8,J3) !$OMP& REDUCTION(max:RMAX) DO J=1,J3 RMAX = max(abs(A(J1_ini + int(J-1,8) * NFRONT8)), & RMAX) END DO !$OMP END PARALLEL DO ELSE #endif DO J=1,J3 RMAX = max(abs(A(J1)), RMAX) J1 = J1 + NFRONT8 END DO #if defined(_OPENMP) ENDIF #endif END IF 370 IF (RMAX.LE.tiny(RMAX)) GO TO 460 IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)) .GE. UU*RMAX .AND. & abs(A(IDIAG)) .GT. max(SEUIL_LOC,tiny(RMAX)) ) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF ( .NOT. ( AMROW .GE. UU*RMAX .AND. & AMROW .GT. max(SEUIL_LOC,tiny(RMAX)) & ) & ) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS + int(JMAX - 1,8) * NFRONT8 )), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER( & A(APOS + int(JMAX - 1,8) * NFRONT8 ), & DET_MANTW, DET_EXPW ) ENDIF IF ( IPIV .NE. NPIVP1 .OR. JMAX .NE. 1) THEN IF (KEEP(405) .EQ.0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF ENDIF IF (IPIV.EQ.NPIVP1) GO TO 400 DET_SIGNW = - DET_SIGNW J1 = POSELT + int(NPIV,8) J3_8 = POSELT + int(IPIV-1,8) DO J= 1,NFRONT SWOP = A(J1) A(J1) = A(J3_8) A(J3_8) = SWOP J1 = J1 + NFRONT8 J3_8 = J3_8 + NFRONT8 END DO ISWPS1 = IOLDPS + 5 + NPIVP1 + NFRONT + XSIZE ISWPS2 = IOLDPS + 5 + IPIV + NFRONT + XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW 400 IF (JMAX.EQ.1) GO TO 420 DET_SIGNW = -DET_SIGNW J1 = POSELT + int(NPIV,8) * NFRONT8 J2 = POSELT + int(NPIV + JMAX - 1,8) * NFRONT8 DO KSW=1,NFRONT SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + 1_8 J2 = J2 + 1_8 END DO ISWPS1 = IOLDPS + 5 + NPIV + 1 + XSIZE ISWPS2 = IOLDPS + 5 + NPIV + JMAX + XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE INOPV = 1 GOTO 430 420 CONTINUE IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE IS_MAXFROMN_AVAIL = .FALSE. RETURN END SUBROUTINE SMUMPS_FAC_H SUBROUTINE SMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP,MAXFROMN,IS_MAXFROMN_AVAIL,NVSCHUR) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER NFRONT,NASS,LIW,IFINB INTEGER(8) :: LA REAL A(LA) INTEGER IW(LIW) REAL ALPHA,VALPIV INTEGER(8) :: APOS, POSELT, UUPOS, LPOS, IRWPOS INTEGER(8) :: NFRONT8 INTEGER IOLDPS,NPIV,XSIZE INTEGER, intent(in) :: KEEP(500) REAL, intent(inout) :: MAXFROMN LOGICAL, intent(inout) :: IS_MAXFROMN_AVAIL INTEGER, intent(in) :: NVSCHUR INTEGER NEL,IROW,NEL2,JCOL,NELMAXM INTEGER NPIVP1 REAL, PARAMETER :: ONE = 1.0E0 #if defined(_OPENMP) LOGICAL:: OMP_FLAG INTEGER:: NOMP, CHUNK NOMP = OMP_GET_MAX_THREADS() #endif NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 NELMAXM= NEL -KEEP(253)-NVSCHUR NEL2 = NASS - NPIVP1 IFINB = 0 IF (NPIVP1.EQ.NASS) IFINB = 1 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) #if defined(_OPENMP) OMP_FLAG = .FALSE. CHUNK = max(NEL,1) IF (NOMP.GT.1) THEN IF (NEL.LT.KEEP(360)) THEN IF (NEL*NEL2.GE.KEEP(361)) THEN OMP_FLAG = .TRUE. CHUNK = max(20, (NEL+NOMP-1)/NOMP) ENDIF ELSE OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2, (NEL+NOMP-1)/NOMP) ENDIF ENDIF #endif IF (KEEP(351).EQ.1) THEN MAXFROMN = 0.0E0 IF (NEL2 > 0) THEN IS_MAXFROMN_AVAIL = .TRUE. ENDIF !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& PRIVATE(LPOS, UUPOS, IRWPOS, ALPHA, JCOL) !$OMP& FIRSTPRIVATE(APOS,NFRONT8,VALPIV,NEL,NEL2) !$OMP& REDUCTION(max:MAXFROMN) IF(OMP_FLAG) DO IROW = 1, NEL LPOS = APOS + NFRONT8*int(IROW,8) A(LPOS) = A(LPOS)*VALPIV ALPHA = -A(LPOS) IRWPOS = LPOS + 1_8 UUPOS = APOS + 1_8 IF (NEL2 > 0) THEN A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IF (IROW.LE.NELMAXM) & MAXFROMN=max(MAXFROMN, abs(A(IRWPOS))) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 DO JCOL = 2, NEL2 A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 ENDDO ENDIF END DO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& FIRSTPRIVATE(APOS,NFRONT8,VALPIV,NEL,NEL2) !$OMP& PRIVATE(LPOS, UUPOS, IRWPOS, ALPHA, JCOL) IF(OMP_FLAG) DO IROW = 1, NEL LPOS = APOS + NFRONT8*int(IROW,8) A(LPOS) = A(LPOS)*VALPIV ALPHA = -A(LPOS) IRWPOS = LPOS + 1_8 UUPOS = APOS + 1_8 DO JCOL = 1, NEL2 A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE SMUMPS_FAC_N SUBROUTINE SMUMPS_FAC_PT_SETLOCK427( K427_OUT, K427, & K405, K222, NEL1, NASS ) INTEGER, INTENT(IN) :: K427, K405, K222, NEL1, NASS INTEGER, INTENT(OUT) :: K427_OUT K427_OUT = K427 IF ( K427_OUT .GT. 0 ) K427_OUT = 0 IF ( K427_OUT .LT. 0 ) K427_OUT = -1 RETURN END SUBROUTINE SMUMPS_FAC_PT_SETLOCK427 SUBROUTINE SMUMPS_FAC_P(A,LA,NFRONT, & NPIV,NASS,POSELT,CALL_UTRSM, KEEP, INODE, & CALL_OOC, IWFAC, LIWFAC, LAFAC, MonBloc, MYID, KEEP8, & LNextPiv2beWritten, UNextPiv2beWritten, & IFLAG ) USE SMUMPS_OOC, ONLY : IO_BLOCK, TYPEF_BOTH_LU, & SMUMPS_OOC_IO_LU_PANEL USE MUMPS_OOC_COMMON, ONLY : STRAT_TRY_WRITE IMPLICIT NONE INTEGER(8) :: LA,POSELT,LAFAC REAL A(LA) INTEGER NFRONT, NPIV, NASS LOGICAL, INTENT(IN) :: CALL_UTRSM INTEGER, INTENT(INOUT) :: IFLAG LOGICAL, INTENT(IN) :: CALL_OOC INTEGER LIWFAC, MYID, & LNextPiv2beWritten, UNextPiv2beWritten INTEGER IWFAC(LIWFAC) TYPE(IO_BLOCK) :: MonBloc INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS INTEGER NEL1, NEL11, IFLAG_OOC INTEGER :: INODE REAL ALPHA, ONE PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) INCLUDE 'mumps_headers.h' NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV LPOS2 = POSELT + int(NASS,8)*int(NFRONT,8) LPOS = LPOS2 + int(NPIV,8) LPOS1 = POSELT + int(NPIV,8) UPOS = POSELT + int(NASS,8) IF ( CALL_UTRSM ) THEN CALL strsm('R', 'U', 'N', 'U', NEL1, NPIV, ONE, & A(POSELT), NFRONT, A(UPOS), NFRONT) ENDIF CALL strsm('L','L','N','N',NPIV,NEL1,ONE,A(POSELT),NFRONT, & A(LPOS2),NFRONT) IF (CALL_OOC) THEN CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT_TRY_WRITE, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IWFAC, LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, & .FALSE. ) IF (IFLAG_OOC .LT. 0) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF CALL sgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) IF ((CALL_UTRSM).AND.(NASS-NPIV.GT.0)) THEN LPOS2 = POSELT + int(NPIV,8)*int(NFRONT,8) LPOS = LPOS2 + int(NASS,8) CALL sgemm('N','N',NEL1,NASS-NPIV,NPIV,ALPHA,A(UPOS), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_P SUBROUTINE SMUMPS_FAC_T(A,LA,NPIVB,NFRONT, & NPIV,NASS,POSELT) IMPLICIT NONE INTEGER NPIVB,NASS INTEGER(8) :: LA REAL A(LA) INTEGER(8) :: APOS, POSELT INTEGER NFRONT, NPIV, NASSL INTEGER(8) :: LPOS, LPOS1, LPOS2 INTEGER NEL1, NEL11, NPIVE REAL ALPHA, ONE PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV NPIVE = NPIV - NPIVB NASSL = NASS - NPIVB APOS = POSELT + int(NPIVB,8)*int(NFRONT,8) & + int(NPIVB,8) LPOS2 = APOS + int(NASSL,8) CALL strsm('R','U','N','U',NEL1,NPIVE,ONE,A(APOS),NFRONT, & A(LPOS2),NFRONT) LPOS = LPOS2 + int(NFRONT,8)*int(NPIVE,8) LPOS1 = APOS + int(NFRONT,8)*int(NPIVE,8) CALL sgemm('N','N',NEL1,NEL11,NPIVE,ALPHA,A(LPOS2), & NFRONT,A(LPOS1),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE SMUMPS_FAC_T SUBROUTINE SMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, NPIV, & NFRONT, LAST_ROW, LAST_COL, A, LA, POSELT, & FIRST_COL, CALL_LTRSM, CALL_UTRSM, CALL_GEMM, & WITH_COMM_THREAD, LR_ACTIVATED & ) !$ USE OMP_LIB #if defined(_OPENMP) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_TEST #endif IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: NPIV, NFRONT, LAST_ROW, LAST_COL INTEGER, intent(in) :: FIRST_COL INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: CALL_LTRSM, CALL_UTRSM, CALL_GEMM LOGICAL, intent(in) :: WITH_COMM_THREAD, LR_ACTIVATED INTEGER(8) :: NFRONT8, LPOSN, LPOS2N INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS, POSELT_LOCAL INTEGER :: NELIM, LKJIW, NEL1, NEL11, UTRSM_NCOLS REAL ALPHA, ONE PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) !$ INTEGER :: NOMP !$ LOGICAL :: TRSM_GEMM_FINISHED !$ LOGICAL :: SAVE_NESTED, SAVE_DYNAMIC NFRONT8= int(NFRONT,8) NELIM = IEND_BLOCK - NPIV NEL1 = LAST_ROW - IEND_BLOCK IF ( NEL1 < 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_FAC_SQ,IEND_BLOCK>LAST_ROW", & IEND_BLOCK, LAST_ROW CALL MUMPS_ABORT() ENDIF LKJIW = NPIV - IBEG_BLOCK + 1 NEL11 = LAST_COL - NPIV LPOS2 = POSELT + int(IEND_BLOCK,8)*NFRONT8 + int(IBEG_BLOCK-1,8) UTRSM_NCOLS = LAST_COL - FIRST_COL UPOS = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 + int(FIRST_COL,8) POSELT_LOCAL = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 & + int(IBEG_BLOCK-1,8) IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN IF (WITH_COMM_THREAD .EQV. .FALSE.) THEN IF (CALL_LTRSM) THEN CALL strsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) ENDIF IF (CALL_UTRSM) THEN CALL strsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL sgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF IF (CALL_GEMM) THEN LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSELT_LOCAL + int(LKJIW,8) CALL sgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF ELSE !$ NOMP = OMP_GET_MAX_THREADS() !$ CALL OMP_SET_NUM_THREADS(2) !$ SAVE_NESTED = OMP_GET_NESTED() !$ SAVE_DYNAMIC = OMP_GET_DYNAMIC() !$ CALL OMP_SET_NESTED(.TRUE.) !$ CALL OMP_SET_DYNAMIC(.FALSE.) !$ TRSM_GEMM_FINISHED = .FALSE. !$OMP PARALLEL SHARED(TRSM_GEMM_FINISHED) !$ IF (OMP_GET_THREAD_NUM() .EQ. 1) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL OMP_SET_NUM_THREADS(int(NOMP,4)) #else !$ CALL OMP_SET_NUM_THREADS(NOMP) #endif IF (CALL_LTRSM) THEN CALL strsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) ENDIF IF (CALL_UTRSM) THEN CALL strsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL sgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF IF (CALL_GEMM) THEN LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSELT_LOCAL + int(LKJIW,8) CALL sgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) END IF !$ TRSM_GEMM_FINISHED = .TRUE. !$ ELSE !$ DO WHILE (.NOT. TRSM_GEMM_FINISHED) !$ CALL MUMPS_BUF_TEST() !$ CALL MUMPS_USLEEP(10000) !$ END DO !$ END IF !$OMP END PARALLEL !$ CALL OMP_SET_NESTED(SAVE_NESTED) !$ CALL OMP_SET_DYNAMIC(SAVE_DYNAMIC) #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL OMP_SET_NUM_THREADS(int(NOMP,4)) #else !$ CALL OMP_SET_NUM_THREADS(NOMP) #endif ENDIF ELSE IF (CALL_UTRSM.AND.UTRSM_NCOLS.NE.0) THEN CALL strsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL sgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_FAC_SQ SUBROUTINE SMUMPS_FAC_MQ(IBEG_BLOCK,IEND_BLOCK, & NFRONT, NASS, NPIV, LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED & ) IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK, NFRONT, & NASS, NPIV, LAST_COL INTEGER, intent(out) :: IFINB INTEGER(8), intent(in) :: LA, POSELT REAL, intent(inout) :: A(LA) LOGICAL, intent(in) :: LR_ACTIVATED REAL :: VALPIV INTEGER(8) :: APOS, UUPOS, LPOS INTEGER(8) :: NFRONT8 REAL :: ONE, ALPHA INTEGER :: NEL2,NPIVP1,KROW,NEL PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) NFRONT8= int(NFRONT,8) NPIVP1 = NPIV + 1 NEL = LAST_COL - NPIVP1 IFINB = 0 NEL2 = IEND_BLOCK - NPIVP1 IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ELSE APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 541 KROW = 1,NEL2 A(LPOS) = A(LPOS)*VALPIV LPOS = LPOS + NFRONT8 541 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS + 1_8 #if defined(MUMPS_USE_BLAS2) CALL sger(NEL,NEL2,ALPHA,A(UUPOS),1,A(LPOS),NFRONT, & A(LPOS+1_8),NFRONT) #else CALL sgemm('N','N',NEL,NEL2,1,ALPHA,A(UUPOS),NEL, & A(LPOS),NFRONT,ONE,A(LPOS+1_8),NFRONT) #endif ENDIF RETURN END SUBROUTINE SMUMPS_FAC_MQ SUBROUTINE SMUMPS_FAC_FR_UPDATE_CBROWS( INODE, NFRONT, NASS, & CALL_UTRSM, A, LA, LAFAC, POSELT, IW, LIW, IOLDPS, & MonBloc, MYID, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR) USE SMUMPS_OOC, ONLY: IO_BLOCK IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS, & LIW, MYID, XSIZE, IOLDPS, LIWFAC INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(inout) :: NOFFW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW INTEGER, intent(inout) :: PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & IFLAG LOGICAL, intent(in) :: CALL_UTRSM INTEGER, intent(inout) :: IW(LIW) REAL, intent(inout) :: A(LA) REAL, intent(in) :: SEUIL, UU, DKEEP(230) INTEGER, intent(in) :: KEEP( 500 ) INTEGER(8), intent(inout) :: LAFAC INTEGER(8) :: KEEP8(150) INTEGER, intent(in) :: NVSCHUR TYPE(IO_BLOCK), intent(inout) :: MonBloc LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER :: NPIV, NEL1, IBEG_BLOCK, IFINB, INOPV INTEGER Inextpiv REAL :: MAXFROMN LOGICAL :: IS_MAXFROMN_AVAIL NPIV = IW(IOLDPS+1+XSIZE) NEL1 = NFRONT - NASS IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF IF ((NPIV.GT.0).AND.(NEL1.GT.0)) THEN IF (OOC_EFFECTIVE_ON_FRONT) THEN MonBloc%LastPiv = NPIV ENDIF CALL SMUMPS_FAC_P(A,LA,NFRONT, NPIV, NASS, POSELT, & CALL_UTRSM, KEEP, INODE, & OOC_EFFECTIVE_ON_FRONT, IW(IOLDPS), & LIWFAC, LAFAC, & MonBloc, MYID, KEEP8, & LNextPiv2beWritten, UNextPiv2beWritten, & IFLAG) ENDIF NPIV = IW(IOLDPS+1+XSIZE) IBEG_BLOCK = NPIV IF (NASS.EQ.NPIV) GOTO 500 IF (KEEP(19).GT.0) THEN GOTO 500 ENDIF IS_MAXFROMN_AVAIL = .FALSE. 120 CALL SMUMPS_FAC_H(NFRONT,NASS,IW,LIW,A,LA, & INOPV, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IOLDPS,POSELT,UU,SEUIL, & KEEP, KEEP8, DKEEP, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, MAXFROMN, IS_MAXFROMN_AVAIL, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, NVSCHUR & ) IF (INOPV.NE.1) THEN CALL SMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP, MAXFROMN, IS_MAXFROMN_AVAIL, & NVSCHUR) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) GOTO 120 ENDIF NPIV = IW(IOLDPS+1+XSIZE) NEL1 = NFRONT - NASS IF ((NPIV.LE.IBEG_BLOCK).OR.(NEL1.EQ.0)) GO TO 500 CALL SMUMPS_FAC_T(A,LA,IBEG_BLOCK, & NFRONT,NPIV,NASS,POSELT) 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_FR_UPDATE_CBROWS SUBROUTINE SMUMPS_FAC_I(NFRONT,NASS,LAST_ROW, & IBEG_BLOCK, IEND_BLOCK, & N,INODE,IW,LIW,A,LA, & INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UU,SEUIL,KEEP,KEEP8, & DKEEP,PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR, PARPIV_T1, & TIPIV & ) !$ USE OMP_LIB USE MUMPS_OOC_COMMON USE MUMPS_PIVNUL_MOD IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(inout), OPTIONAL :: TIPIV(:) INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER, intent(in) :: NFRONT,NASS,N,LIW,INODE,LAST_ROW INTEGER, intent(inout) :: IFLAG,IERROR, INOPV,NOFFW, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW REAL, intent(in) :: UU, SEUIL INTEGER, intent(inout) :: IW(LIW) INTEGER, intent(in) :: IOLDPS INTEGER(8), intent(in) :: POSELT INTEGER KEEP(500) INTEGER(8) KEEP8(150) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT LOGICAL, intent(inout) :: SWAP_OCCURRED REAL DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER, intent(in) :: NVSCHUR INTEGER, intent(in) :: PARPIV_T1 INCLUDE 'mumps_headers.h' REAL SWOP INTEGER XSIZE INTEGER(8) :: APOS, IDIAG INTEGER(8) :: J1, J2, JJ, J3 INTEGER(8) :: NFRONT8 INTEGER ILOC REAL ZERO PARAMETER( ZERO = 0.0E0 ) REAL RZERO, RMAX, AMROW, MAX_PREV_in_PARPIV REAL RCMAX INTEGER(8) :: APOSMAX, APOSROW REAL :: RMAX_NORELAX REAL PIVNUL, ABS_PIVOT REAL FIXA, CSEUIL, PIVOT INTEGER NPIV,IPIV, LRLOC INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 INTEGER ISWPS2,KSW, HF, IPIVNUL INTEGER SMUMPS_IXAMAX INTEGER :: ISHIFT, K206 INTEGER :: IPIV_SHIFT,IPIV_END INTRINSIC max DATA RZERO /0.0E0/ #if defined(_OPENMP) INTEGER :: NOMP,CHUNK #endif INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U #if defined(_OPENMP) NOMP = OMP_GET_MAX_THREADS() #endif PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL NFRONT8 = int(NFRONT,8) K206 = KEEP(206) XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE NPIVP1 = NPIV + 1 APOSMAX = POSELT+NFRONT8*NFRONT8-1_8 IF (OOC_EFFECTIVE_ON_FRONT) THEN CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF IF ( present(TIPIV) ) THEN ILOC = NPIVP1 - IBEG_BLOCK + 1 TIPIV(ILOC) = ILOC ENDIF IF (INOPV .EQ. -1) THEN JMAX=1 APOS = POSELT + NFRONT8*int(NPIVP1-1,8) + int(NPIV,8) PIVOT = A(APOS) ABS_PIVOT = abs(PIVOT) IDIAG = APOS CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .TRUE.) IF(ABS_PIVOT.LT.SEUIL) THEN IF (real(PIVOT) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF GO TO 430 ENDIF INOPV = 0 ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) JMAX = 1 IF ((PIVOT_OPTION.EQ.0).OR.(UU.EQ.RZERO)) THEN ABS_PIVOT = abs(A(APOS)) IF(ABS_PIVOT.LT.SEUIL) THEN CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .TRUE.) IF (real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 GO TO 420 ELSE IF (ABS_PIVOT.EQ.RZERO) THEN GO TO 630 ENDIF GO TO 380 ENDIF AMROW = RZERO J1 = APOS IF (PIVOT_OPTION.EQ.1 .OR. (LR_ACTIVATED .AND. & (KEEP(480).GE.2 & ))) THEN J = IEND_BLR - NPIV ELSE J = NASS - NPIV ENDIF J2 = J1 + J - 1_8 JMAX = SMUMPS_IXAMAX(J,A(J1),1,KEEP(361)) JJ = J1 + int(JMAX - 1,8) AMROW = abs(A(JJ)) RMAX = AMROW IF (PIVOT_OPTION.GE.2) THEN J1 = J2 + 1_8 IF (PIVOT_OPTION.GE.3 & ) THEN J2 = APOS + & int(- NPIV + NFRONT - 1 - KEEP(253) - NVSCHUR,8) ELSE J2 = APOS +int(- NPIV + NASS - 1 ,8) ENDIF IF (J2.LT.J1) GO TO 370 IF (KEEP(351).EQ.1 .AND. J2-J1.GT.KEEP(361)) THEN !$ CHUNK = max(KEEP(361)/2,(int(J2-J1)+NOMP-1)/NOMP) !$OMP PARALLEL DO schedule(static, CHUNK) PRIVATE(JJ) !$OMP& FIRSTPRIVATE(J1,J2) !$OMP& REDUCTION(max:RMAX) DO JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) ENDDO !$OMP END PARALLEL DO ELSE DO 360 JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) 360 CONTINUE ENDIF 370 CONTINUE ENDIF IDIAG = APOS + int(IPIV - NPIVP1,8) ABS_PIVOT = abs(A(IDIAG)) IF (PARPIV_T1.NE.0) THEN RMAX_NORELAX = real(A(APOSMAX+int(IPIV,8))) ELSE RMAX_NORELAX = RZERO ENDIF RMAX = max(RMAX,RMAX_NORELAX) IF ( RMAX .LE. PIVNUL ) THEN IF (LAST_ROW.EQ.NFRONT) THEN LRLOC = LAST_ROW -KEEP(253)-NVSCHUR ELSE LRLOC = LAST_ROW ENDIF IF (NFRONT - KEEP(253) .EQ. NASS) THEN IF (IEND_BLOCK.NE.NASS ) THEN GOTO 460 ENDIF J1=POSELT+int(IPIV-1,8)+int(NPIV,8)*NFRONT8 J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 ELSE J1=POSELT+int(IPIV-1,8) J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 ENDIF DO JJ=J1, J2, NFRONT8 IF ( abs(A(JJ)) .GT. PIVNUL ) THEN GOTO 460 END IF ENDDO IF ((PARPIV_T1.NE.0) & .AND.(PARPIV_T1.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & real(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + NFRONT8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) GOTO 460 ENDDO ENDIF ENDIF CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .TRUE.) !$OMP ATOMIC CAPTURE KEEP(109) = KEEP(109)+1 IPIVNUL = KEEP(109) !$OMP END ATOMIC IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST.LT.KEEP(109)) & THEN CALL MUMPS_RESIZE_PIVNUL(KEEP, N, PIVNUL_LIST_STRUCT, & IPIVNUL, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 430 ENDIF IF (KEEP(405).EQ.1) THEN !$OMP CRITICAL(critical_pivnul) PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) !$OMP END CRITICAL(critical_pivnul) ELSE PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) ENDIF IF(real(FIXA).GT.RZERO) THEN IF(real(A(IDIAG)) .GE. RZERO) THEN A(IDIAG) = FIXA ELSE A(IDIAG) = -FIXA ENDIF ELSE J1 = APOS J2 = APOS + & int(- NPIV + NFRONT - 1 - KEEP(253),8) DO JJ=J1,J2 A(JJ) = ZERO ENDDO A(IDIAG) = -FIXA ENDIF JMAX = IPIV - NPIV GOTO 385 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF (ABS_PIVOT .GE. UU*RMAX .AND. & ABS_PIVOT .GT. max(SEUIL,tiny(RMAX))) THEN IF (KEEP(19).GT.0) THEN IF (LAST_ROW.EQ.NFRONT) THEN LRLOC = LAST_ROW -KEEP(253)-NVSCHUR ELSE LRLOC = LAST_ROW ENDIF J1=POSELT+int(IPIV-1,8)+int(NPIV,8)*NFRONT8 J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 RCMAX = RZERO DO JJ=J1, J2, NFRONT8 RCMAX = max(abs(A(JJ)),RCMAX) ENDDO IF (ABS_PIVOT .GE. UU*RCMAX) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF ELSE JMAX = IPIV - NPIV GO TO 380 ENDIF ENDIF IF ( .NOT. (AMROW .GE. UU*RMAX .AND. & AMROW .GT. max(SEUIL,tiny(RMAX))) ) GO TO 460 IF (KEEP(19).GT.0) THEN IF (LAST_ROW.EQ.NFRONT) THEN LRLOC = LAST_ROW -KEEP(253)-NVSCHUR ELSE LRLOC = LAST_ROW ENDIF J1=POSELT+int(NPIV+JMAX-1,8)+int(NPIV,8)*NFRONT8 J2=POSELT+int(NPIV+JMAX-1,8)+int(LRLOC-1,8)*NFRONT8 RCMAX = RZERO DO JJ=J1, J2, NFRONT8 RCMAX = max(abs(A(JJ)),RCMAX) ENDDO IF (.NOT.(AMROW .GE. UU*RCMAX) ) THEN GO TO 460 ENDIF ENDIF NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS+int(JMAX-1,8))), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER( A(APOS+int(JMAX-1,8)), & DET_MANTW, & DET_EXPW ) ENDIF 385 CONTINUE IF ( IPIV .NE. NPIVP1 .OR. JMAX .NE. 1 ) THEN SWAP_OCCURRED = .TRUE. IF (KEEP(405) .EQ. 0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF ENDIF IF (IPIV.EQ.NPIVP1) GO TO 400 IF (PARPIV_T1.NE.0) THEN SWOP = A(APOSMAX+int(NPIVP1,8)) A(APOSMAX+int(NPIVP1,8)) = A(APOSMAX+int(IPIV,8)) A(APOSMAX+int(IPIV,8)) = SWOP ENDIF DET_SIGNW = - DET_SIGNW J1 = POSELT + int(NPIV,8)*NFRONT8 J2 = J1 + NFRONT8 - 1_8 J3 = POSELT + int(IPIV-1,8)*NFRONT8 DO 390 JJ=J1,J2 SWOP = A(JJ) A(JJ) = A(J3) A(J3) = SWOP J3 = J3 + 1_8 390 CONTINUE ISWPS1 = IOLDPS + HF - 1 + NPIVP1 ISWPS2 = IOLDPS + HF - 1 + IPIV ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW 400 IF (JMAX.EQ.1) GO TO 420 DET_SIGNW = - DET_SIGNW IF ( present(TIPIV) ) THEN TIPIV(ILOC) = ILOC + JMAX - 1 ENDIF J1 = POSELT + int(NPIV,8) J2 = POSELT + int(NPIV + JMAX - 1,8) DO 410 KSW=1,LAST_ROW SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + NFRONT8 J2 = J2 + NFRONT8 410 CONTINUE ISWPS1 = IOLDPS + HF - 1 + NFRONT + NPIV + 1 ISWPS2 = IOLDPS + HF - 1 + NFRONT + NPIV + JMAX ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 430 630 CONTINUE IFLAG = -10 GOTO 430 420 CONTINUE IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_I SUBROUTINE SMUMPS_FAC_I_LDLT & ( NFRONT,NASS,N,INODE,IBEG_BLOCK,IEND_BLOCK, & IW,LIW, A,LA, INOPV, & NNEGW, NNULLNEGW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UU, SEUIL,KEEP,KEEP8,PIVSIZ, & DKEEP, PIVNUL_LIST_STRUCT, SWAP_OCCURRED, XSIZE, & PP_FIRST2SWAP_L, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled,MAXFROMM,IS_MAXFROMM_AVAIL, & PIVOT_OPTION, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, LR_ACTIVATED & ) !$ USE OMP_LIB USE MUMPS_OOC_COMMON USE MUMPS_PIVNUL_MOD IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER NFRONT,NASS,LIW,N,INODE,IFLAG,IERROR,INOPV, & IOLDPS INTEGER, intent(inout) :: NNEGW, NNULLNEGW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: PIVOT_OPTION,IEND_BLR INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER PIVSIZ,LPIV, XSIZE REAL A(LA) REAL UU, UULOC, SEUIL INTEGER IW(LIW) INTEGER KEEP(500) INTEGER(8) KEEP8(150) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT LOGICAL, intent(inout) :: SWAP_OCCURRED REAL DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled REAL, intent(in) :: MAXFROMM LOGICAL, intent(inout) :: IS_MAXFROMM_AVAIL INTEGER, intent(in) :: NVSCHUR INTEGER, intent(in) :: PARPIV_T1 LOGICAL, intent(in) :: LR_ACTIVATED include 'mpif.h' INTEGER (8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX, LIM, LIM_SWAP REAL RMAX,AMAX,TMAX, MAX_PREV_in_PARPIV, ABS_PIVOT REAL RMAX_NORELAX, TMAX_NORELAX, UULOCM1 INTEGER(8) :: APOSMAX, APOSROW REAL MAXPIV REAL PIVNUL REAL MAXFROMM_UPDATED REAL FIXA, CSEUIL REAL PIVOT,DETPIV REAL ABSDETPIV INCLUDE 'mumps_headers.h' INTEGER :: HF, IPIVNUL INTEGER :: J INTEGER(8) :: APOS, J1, J2, JJ, NFRONT8, KK, J1_ini, JJ_ini INTEGER :: LDA INTEGER(8) :: LDA8 INTEGER NPIV,IPIV INTEGER NPIVP1,K INTEGER :: ISHIFT, K206, IPIV_SHIFT, IPIV_END INTRINSIC max REAL ZERO, ONE PARAMETER( ZERO = 0.0E0 ) PARAMETER( ONE = 1.0E0 ) REAL RZERO,RONE PARAMETER(RZERO=0.0E0, RONE=1.0E0) #if defined(_OPENMP) LOGICAL :: OMP_FLAG INTEGER :: NOMP, CHUNK, J1_end #endif INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L !$ NOMP = OMP_GET_MAX_THREADS() PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL LDA = NFRONT LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) K206 = KEEP(206) UULOC = UU IF (UULOC.GT.RZERO) THEN UULOCM1 = RONE/UULOC ELSE UULOCM1 = RONE ENDIF HF = 6 + XSIZE IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, IOLDPS+2*NFRONT+6+KEEP(IXSZ), & IW, LIW) ENDIF PIVSIZ = 1 NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 APOSMAX = POSELT+LDA8*LDA8-1_8 IF(INOPV .EQ. -1) THEN APOS = POSELT + (LDA8+1_8) * int(NPIV,8) POSPV1 = APOS CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), DKEEP, KEEP, .TRUE.) IF(abs(A(APOS)).LT.SEUIL) THEN IF(real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL NNEGW = NNEGW+1 ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER( A(APOS), DET_MANTW, DET_EXPW ) ENDIF ENDIF IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF IF (ISHIFT.GT.0.AND.IS_MAXFROMM_AVAIL) THEN IPIV = NPIVP1 APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF ( MAXFROMM .GT. PIVNUL ) THEN IF (PARPIV_T1.NE.0) THEN MAXFROMM_UPDATED = max & ( MAXFROMM, & abs(real(A(APOSMAX+int(IPIV,8)))) & ) ELSE MAXFROMM_UPDATED = MAXFROMM ENDIF IF ( (abs(PIVOT) .GE. UULOC*MAXFROMM_UPDATED).AND. & abs(PIVOT) .GT. max(SEUIL,tiny(MAXFROMM_UPDATED)) & ) THEN ISHIFT = 0 ENDIF ENDIF ENDIF IF ( ISHIFT .GT. 0) THEN IS_MAXFROMM_AVAIL = .FALSE. ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN IF(ABS_PIVOT.LT.SEUIL) THEN CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .TRUE.) IF(real(PIVOT) .GE. RZERO) THEN A(POSPV1) = CSEUIL ELSE A(POSPV1) = -CSEUIL NNEGW = NNEGW+1 ENDIF NBTINYW = NBTINYW + 1 ELSE IF (ABS_PIVOT.EQ.RZERO) THEN GO TO 630 ELSE IF (PIVOT.LT.RZERO) NNEGW = NNEGW+1 CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF ENDIF GO TO 420 ENDIF IF ( IS_MAXFROMM_AVAIL ) THEN IF ( MAXFROMM .GT. PIVNUL ) THEN IF (PARPIV_T1.NE.0) THEN MAXFROMM_UPDATED = max & ( MAXFROMM, & abs(real(A(APOSMAX+int(IPIV,8)))) & ) ELSE MAXFROMM_UPDATED = MAXFROMM ENDIF IF ( (ABS_PIVOT .GE. UULOC*MAXFROMM_UPDATED).AND. & (ABS_PIVOT .GT. max(SEUIL,tiny(MAXFROMM_UPDATED))) & ) THEN IF (PIVOT .LT. RZERO) NNEGW = NNEGW+1 CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GOTO 415 ENDIF ENDIF IS_MAXFROMM_AVAIL = .FALSE. ENDIF AMAX = -RONE JMAX = 0 IF (PIVOT_OPTION.EQ.3 & ) THEN LIM = NFRONT - KEEP(253)-NVSCHUR ELSEIF (PIVOT_OPTION.GE.2 & ) THEN LIM = NASS ELSEIF (PIVOT_OPTION.GE.1) THEN LIM = IEND_BLR ELSE write(*,*) 'Internal error in FAC_I_LDLT 1x1:', & PIVOT_OPTION CALL MUMPS_ABORT() ENDIF J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1, IEND_BLOCK - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDA8 ENDDO RMAX = RZERO J1_ini = J1 #if defined(_OPENMP) J1_end = LIM - IEND_BLOCK CHUNK = max(J1_end,1) IF ( J1_end.GE.KEEP(360)) THEN OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2,(J1_end+NOMP-1)/NOMP) ELSE OMP_FLAG = .FALSE. ENDIF #endif !$OMP PARALLEL DO SCHEDULE(static, CHUNK) PRIVATE(J1) !$OMP& REDUCTION(max:RMAX) IF(OMP_FLAG) DO J=1, LIM - IEND_BLOCK J1 = J1_ini + int(J-1,8) * LDA8 RMAX = max(abs(A(J1)),RMAX) ENDDO !$OMP END PARALLEL DO IF (PARPIV_T1.NE.0) THEN RMAX_NORELAX = real(A(APOSMAX+int(IPIV,8))) ELSE RMAX_NORELAX = RZERO ENDIF RMAX = max(RMAX,RMAX_NORELAX) IF (max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL) THEN IF ((PARPIV_T1.NE.0) & .AND.(PARPIV_T1.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & real(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + NFRONT8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) THEN GOTO 460 ENDIF ENDDO ENDIF ENDIF CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(POSPV1)), DKEEP, KEEP, .TRUE.) IF ( A(POSPV1) .LT. RZERO ) NNULLNEGW=NNULLNEGW+1 !$OMP ATOMIC CAPTURE KEEP(109) = KEEP(109) + 1 IPIVNUL = KEEP(109) !$OMP END ATOMIC IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST.LT.KEEP(109)) & THEN CALL MUMPS_RESIZE_PIVNUL(KEEP, N, & PIVNUL_LIST_STRUCT, & IPIVNUL, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 420 ENDIF IF (KEEP(405).EQ.1) THEN !$OMP CRITICAL(critical_pivnul) PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) !$OMP END CRITICAL(critical_pivnul) ELSE PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) ENDIF IF(real(FIXA).GT.RZERO) THEN IF(real(PIVOT) .GE. RZERO) THEN A(POSPV1) = FIXA ELSE A(POSPV1) = -FIXA ENDIF ELSE J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 A(JJ) = ZERO ENDDO J1 = POSPV1 + LDA8 DO J=1, IEND_BLOCK - IPIV A(J1) = ZERO J1 = J1 + LDA8 ENDDO DO J=1,LIM - IEND_BLOCK A(J1) = ZERO J1 = J1 + LDA8 ENDDO A(POSPV1) = ONE ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF ( abs(PIVOT).GE.UULOC*max(RMAX,AMAX) & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(RMAX)) ) THEN IF (PIVOT .LT. ZERO) NNEGW = NNEGW+1 CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(PIVOT), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL SMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) THEN GOTO 460 ELSE IF (JMAX.EQ.0) THEN GOTO 460 ENDIF IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN GOTO 460 ENDIF IF ( & (KEEP(19).NE.0).AND.(max(AMAX,RMAX,abs(PIVOT)).LE.SEUIL) & ) & THEN GO TO 460 ENDIF IF (RMAX.LT.AMAX) THEN J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN RMAX = max(RMAX,abs(A(JJ))) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1,IEND_BLOCK-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX = max(abs(A(J1)),RMAX) ENDIF J1 = J1 + LDA8 ENDDO ENDIF APOSJ = POSELT + int(JMAX-1,8)*LDA8 + int(NPIV,8) POSPV2 = APOSJ + int(JMAX - NPIVP1,8) IF (IPIV.LT.JMAX) THEN OFFDAG = APOSJ + int(IPIV - NPIVP1,8) ELSE OFFDAG = APOS + int(JMAX - NPIVP1,8) END IF TMAX = RZERO #if defined(_OPENMP) J1_end = LIM-JMAX CHUNK = max(J1_end,1) IF (J1_end.GE.KEEP(360)) THEN OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2,(J1_end+NOMP-1)/NOMP) ELSE OMP_FLAG = .FALSE. ENDIF #endif IF (JMAX .LT. IPIV) THEN JJ_ini = POSPV2 !$OMP PARALLEL DO SCHEDULE(static, CHUNK) IF (OMP_FLAG) !$OMP& PRIVATE(JJ) REDUCTION(max:TMAX) DO K = 1, LIM - JMAX JJ = JJ_ini+ int(K,8)*NFRONT8 IF (JMAX+K.NE.IPIV) THEN TMAX=max(TMAX,abs(A(JJ))) ENDIF ENDDO !$OMP END PARALLEL DO DO KK = APOSJ, POSPV2-1_8 TMAX = max(TMAX,abs(A(KK))) ENDDO ELSE JJ_ini = POSPV2 !$OMP PARALLEL DO SCHEDULE(static, CHUNK) PRIVATE(JJ) !$OMP& REDUCTION(max:TMAX) IF(OMP_FLAG) DO K = 1, LIM-JMAX JJ = JJ_ini + int(K,8)*NFRONT8 TMAX=max(TMAX,abs(A(JJ))) ENDDO !$OMP END PARALLEL DO DO KK = APOSJ, POSPV2 - 1_8 IF (KK.NE.OFFDAG) THEN TMAX = max(TMAX,abs(A(KK))) ENDIF ENDDO ENDIF IF (PARPIV_T1.NE.0) THEN TMAX_NORELAX = max(SEUIL*UULOCM1, & abs(real(A(APOSMAX+int(JMAX,8)))) & ) ELSE TMAX_NORELAX = SEUIL*UULOCM1 ENDIF TMAX = max (TMAX,TMAX_NORELAX) DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)**2 ABSDETPIV = abs(DETPIV) IF (SEUIL.GT.RZERO) THEN IF (sqrt(ABSDETPIV) .LE. SEUIL ) THEN GOTO 460 ENDIF ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & ABSDETPIV .OR. (ABSDETPIV .EQ. RZERO) ) THEN GO TO 460 ENDIF IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & ABSDETPIV .OR. (ABSDETPIV.EQ. RZERO) ) THEN GO TO 460 ENDIF CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( sqrt(ABSDETPIV), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL SMUMPS_UPDATEDETER(DETPIV, DET_MANTW, DET_EXPW ) ENDIF PIVSIZ = 2 NB22T1W = NB22T1W + 1 IF(DETPIV .LT. RZERO) THEN NNEGW = NNEGW+1 ELSE IF(A(POSPV2) .LT. RZERO) THEN NNEGW = NNEGW+2 ENDIF 415 CONTINUE IF (K206.GE.1) THEN Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) ENDIF DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2) THEN IF (K==1) THEN LPIV = min(IPIV,JMAX) ELSE LPIV = max(IPIV,JMAX) ENDIF ELSE LPIV = IPIV ENDIF IF (LPIV.EQ.NPIVP1) GOTO 416 IF (KEEP(405) .EQ. 0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF LIM_SWAP = NFRONT CALL SMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, LIM_SWAP, & LDA, NFRONT, 1, PARPIV_T1, KEEP(50), & KEEP(IXSZ), -9999) SWAP_OCCURRED = .TRUE. 416 CONTINUE IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF NPIVP1 = NPIVP1 + 1 ENDDO IF(PIVSIZ .EQ. 2) THEN A(POSELT+(LDA8+1_8)*int(NPIV,8)+1_8) = DETPIV ENDIF GOTO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE PIVSIZ = 0 IFLAG = -10 420 CONTINUE IS_MAXFROMM_AVAIL = .FALSE. RETURN END SUBROUTINE SMUMPS_FAC_I_LDLT SUBROUTINE SMUMPS_FAC_MQ_LDLT(IEND_BLOCK, & NFRONT,NASS,NPIV,INODE, & A,LA,LDA, & POSELT,IFINB,PIVSIZ, & MAXFROMM, IS_MAXFROMM_AVAIL, IS_MAX_USEFUL, & PARPIV_T1, LAST_ROW, IEND_BLR, NVSCHUR_K253, & LR_ACTIVATED & ) IMPLICIT NONE INTEGER, intent(out):: IFINB INTEGER, intent(in) :: INODE, NFRONT, NASS, NPIV INTEGER, intent(in) :: IEND_BLOCK INTEGER, intent(in) :: LDA INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER, intent(in) :: LAST_ROW INTEGER, intent(in) :: IEND_BLR INTEGER(8) :: POSELT REAL, intent(out) :: MAXFROMM LOGICAL, intent(out) :: IS_MAXFROMM_AVAIL LOGICAL, intent(in) :: IS_MAX_USEFUL INTEGER, intent(in) :: PARPIV_T1 INTEGER, INTENT(in) :: NVSCHUR_K253 LOGICAL, intent(in) :: LR_ACTIVATED REAL VALPIV REAL :: MAXFROMMTMP INTEGER NCB1 INTEGER(8) :: NFRONT8 INTEGER(8) :: LDA8 INTEGER(8) :: K1POS INTEGER NEL2 REAL ONE, ZERO REAL A11,A22,A12 INTEGER(8) :: APOS, LPOS, LPOS1, LPOS2 INTEGER(8) :: POSPV1, POSPV2 INTEGER :: PIVSIZ,NPIV_NEW,J2,I INTEGER(8) :: OFFDAG, OFFDAG_OLD, K1, K2, IROW #if defined(__ve__) INTEGER(8) :: J2_8, KU1, KU2 #else INTEGER(8) :: IBEG, IEND, JJ_LOC, JJ, ROW_SHIFT INTEGER(8) :: IBEG_LOC, IEND_LOC #endif REAL SWOP,DETPIV,MULT1,MULT2 INTEGER(8) :: APOSMAX !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' PARAMETER(ONE = 1.0E0, & ZERO = 0.0E0) LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) NPIV_NEW = NPIV + PIVSIZ IFINB = 0 IS_MAXFROMM_AVAIL = .FALSE. NCB1 = LAST_ROW - IEND_BLOCK NEL2 = IEND_BLOCK - NPIV_NEW IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ENDIF MAXFROMM = 0.0E0 IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDA8 #if defined(__ve__) IF (NEL2+NCB1.GT.0) THEN !$ OMP_FLAG = (NCB1 + NEL2> 300) !$OMP PARALLEL DO PRIVATE(I,K1POS) IF (OMP_FLAG) !NEC$ IVDEP DO I=1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) ENDDO !$OMP END PARALLEL DO !$OMP PARALLEL DO PRIVATE(I,K1POS) IF (OMP_FLAG) !NEC$ IVDEP DO I=1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS) = A(K1POS) * VALPIV ENDDO !$OMP END PARALLEL DO IF (.NOT. IS_MAX_USEFUL) THEN !$ OMP_FLAG = (NCB1 > 300).AND.(NEL2.GE.2) !$OMP PARALLEL DO PRIVATE(I,J2,J2_8,K1POS) IF (OMP_FLAG) !NEC$ IVDEP DO J2 = 1, NEL2 J2_8 = int(J2,8) !NEC$ IVDEP DO I=J2, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS+J2_8)=A(K1POS+J2_8)-(A(K1POS)*A(APOS+J2_8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE IF (NEL2.GT.0) THEN MAXFROMMTMP=0.0E0 !$ OMP_FLAG = (NCB1+NEL2 > 300) !$OMP PARALLEL DO PRIVATE(I,K1POS) IF (OMP_FLAG) !$OMP& REDUCTION(max:MAXFROMMTMP) !NEC$ IVDEP DO I=1, NEL2 + NCB1 - NVSCHUR_K253 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS+1_8)=A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) MAXFROMMTMP=max(MAXFROMMTMP, abs(A(K1POS+1_8))) ENDDO !$OMP END PARALLEL DO IS_MAXFROMM_AVAIL = .TRUE. MAXFROMM=max(MAXFROMM, MAXFROMMTMP) IF (NVSCHUR_K253.GT.0) THEN DO I= NEL2 + NCB1- NVSCHUR_K253 +1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS+1_8)=A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) ENDDO ENDIF ENDIF IF (NEL2.GT.1) THEN !$ OMP_FLAG = (NCB1+NEL2 > 300).AND.(NEL2.GE.3) !$OMP PARALLEL DO PRIVATE(I,J2,J2_8,K1POS) IF (OMP_FLAG) !NEC$ IVDEP DO J2 = 2, NEL2 J2_8 = int(J2,8) !NEC$ IVDEP DO I=J2, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS+J2_8)=A(K1POS+J2_8)-(A(K1POS)*A(APOS+J2_8)) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF ENDIF ENDIF #else 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 (NCB1.GT.0) THEN IF (.NOT. IS_MAX_USEFUL) THEN !$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) DO I=NEL2+1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE MAXFROMMTMP=0.0E0 !$ OMP_FLAG = (NCB1-NVSCHUR_K253>300) !$OMP PARALLEL DO PRIVATE(JJ,K1POS) !$OMP& REDUCTION(max:MAXFROMMTMP) IF (OMP_FLAG) DO I=NEL2+1, NEL2 + NCB1 - NVSCHUR_K253 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV IF (NEL2 > 0) THEN A(K1POS+1_8) = A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) MAXFROMMTMP=max(MAXFROMMTMP, abs(A(K1POS+1_8))) DO JJ = 2_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDIF ENDDO !$OMP END PARALLEL DO DO I = NEL2 + NCB1 - NVSCHUR_K253 + 1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO MAXFROMM=max(MAXFROMM, MAXFROMMTMP) ENDIF ENDIF #endif ELSE POSPV1 = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) POSPV2 = POSPV1 + NFRONT8 + 1_8 OFFDAG_OLD = POSPV2 - 1_8 OFFDAG = POSPV1 + 1_8 SWOP = A(POSPV2) DETPIV = A(OFFDAG) A22 = A(POSPV1)/DETPIV A11 = SWOP/DETPIV A12 = -A(OFFDAG_OLD)/DETPIV A(OFFDAG) = A(OFFDAG_OLD) A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDA8 - 1_8 LPOS2 = LPOS1 + 1_8 #if defined(__ve__) CALL scopy(LAST_ROW-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) CALL scopy(LAST_ROW-NPIV_NEW, A(LPOS2), LDA, A(POSPV2+1_8), 1) !$ OMP_FLAG = (NEL2+NCB1 > 300) !$OMP PARALLEL DO PRIVATE(J2,J2_8,I,K1,K2,KU1,KU2) !$OMP& IF (OMP_FLAG) !NEC$ IVDEP DO J2=1, NEL2 + NCB1 J2_8 = int(J2,8) KU1 = POSPV1 + 2_8 + (J2_8-1_8) KU2 = POSPV2 + 1_8 + (J2_8-1_8) K1 = LPOS1 + (J2_8-1_8)*NFRONT8 K2 = K1 + 1_8 A(K1) = A11*A(KU1)+A12*A(KU2) A(K2) = A12*A(KU1)+A22*A(KU2) ENDDO IF (NEL2.GT.0) THEN !$ OMP_FLAG = (NCB1+NEL2 > 300).AND.(NEL2.GE.2) !$OMP PARALLEL DO PRIVATE(I,J2,J2_8,K1,K2,MULT1,MULT2,IROW) !$OMP& IF (OMP_FLAG) !NEC$ IVDEP DO J2 = 1,NEL2 J2_8 = int(J2,8) MULT1 = -A(POSPV1 + 2_8 + J2_8-1_8) MULT2 = -A(POSPV2 + 1_8 + J2_8-1_8) !NEC$ IVDEP DO I= J2, NEL2 + NCB1 K1 = LPOS1 + (int(I,8)-1_8)*NFRONT8 K2 = K1 + 1_8 IROW = K2 + J2_8 A(IROW) = A(IROW) + MULT1*A(K1) + & MULT2*A(K2) ENDDO ENDDO ENDIF #else JJ = POSPV2 + NFRONT8-1_8 IBEG = JJ + 2_8 IEND = IBEG DO J2 = 1,NEL2 K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) A(POSPV1 + 2_8 + (int(J2,8)-1_8)) = A(K1) A(POSPV2 + 1_8 + (int(J2,8)-1_8)) = A(K2) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 DO IROW = IBEG, IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A( JJ ) = -MULT1 A( JJ + 1_8 ) = -MULT2 IBEG = IBEG + NFRONT8 IEND = IEND + NFRONT8 + 1_8 JJ = JJ+NFRONT8 ENDDO IEND = IEND-1_8 !$OMP PARALLEL DO PRIVATE(J2, K1, K2, MULT1, MULT2, IROW, JJ_LOC, !$OMP& ROW_SHIFT, IBEG_LOC, IEND_LOC) IF (LAST_ROW-IEND_BLOCK>300) DO J2 = 1,LAST_ROW-IEND_BLOCK ROW_SHIFT = (J2-1_8)*NFRONT8 JJ_LOC = JJ + ROW_SHIFT IBEG_LOC = IBEG + ROW_SHIFT IEND_LOC = IEND + ROW_SHIFT K1 = JJ_LOC K2 = JJ_LOC+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) A(POSPV1 + 2_8 + NEL2 + (J2-1_8)) = A(K1) A(POSPV2 + 1_8 + NEL2 + (J2-1_8)) = A(K2) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 DO IROW = IBEG_LOC, IEND_LOC A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A( JJ_LOC ) = -MULT1 A( JJ_LOC + 1_8 ) = -MULT2 ENDDO !$OMP END PARALLEL DO #endif ENDIF IF ((IS_MAXFROMM_AVAIL).AND.(NEL2.GT.0)) THEN IF (PARPIV_T1.NE.0) THEN APOSMAX = POSELT+LDA8*LDA8-1_8 + int(NPIV_NEW+1,8) MAXFROMM = max(MAXFROMM, & real(A(APOSMAX)) & ) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_FAC_MQ_LDLT SUBROUTINE SMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NFRONT,NASS,INODE,A,LA, & LDA, & POSELT, & KEEP,KEEP8, & FIRST_ROW_TRSM, LAST_ROW_TRSM, & LAST_COL_GEMM, LAST_ROW_GEMM, & CALL_TRSM, CALL_GEMM, LR_ACTIVATED, & IW, LIW, OFFSET_IW & ) IMPLICIT NONE INTEGER, intent(in) :: NPIV INTEGER, intent(in) :: NFRONT, NASS, IBEG_BLOCK, IEND_BLOCK INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER, intent(in) :: INODE INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA INTEGER, intent(in) :: LAST_COL_GEMM INTEGER, intent(in) :: LAST_ROW_GEMM, LAST_ROW_TRSM, & FIRST_ROW_TRSM LOGICAL, intent(in) :: CALL_TRSM, CALL_GEMM, LR_ACTIVATED INTEGER :: OFFSET_IW, LIW INTEGER :: IW(LIW) INTEGER(8) :: LDA8 INTEGER NPIV_BLOCK, NEL1 INTEGER NRHS_TRSM INTEGER(8) :: LPOS, UPOS, APOS INTEGER IROW INTEGER Block INTEGER BLSIZE REAL ONE, ALPHA INCLUDE 'mumps_headers.h' PARAMETER (ONE=1.0E0, ALPHA=-1.0E0) LDA8 = int(LDA,8) NEL1 = LAST_COL_GEMM - IEND_BLOCK NRHS_TRSM = LAST_ROW_TRSM-FIRST_ROW_TRSM NPIV_BLOCK = NPIV - IBEG_BLOCK + 1 IF (NPIV_BLOCK.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF (CALL_TRSM) THEN APOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IBEG_BLOCK-1,8) LPOS = POSELT + LDA8*int(FIRST_ROW_TRSM,8)+int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8)+int(FIRST_ROW_TRSM,8) CALL strsm('L', 'U', 'T', 'U', NPIV_BLOCK, NRHS_TRSM, & ONE, A(APOS), LDA, A(LPOS), LDA) CALL SMUMPS_FAC_LDLT_COPY2U_SCALEL(NRHS_TRSM, 1, KEEP(424), & NFRONT, NPIV_BLOCK, LIW, IW, OFFSET_IW, LA, A, & POSELT, LPOS, UPOS, APOS, .NOT.LR_ACTIVATED) ENDIF IF (CALL_GEMM) THEN #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1 .OR. & ( KEEP(421) > 0 .AND. NEL1 > KEEP(421) ) ) THEN LPOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IEND_BLOCK,8) APOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IEND_BLOCK,8) CALL sgemmt( 'U','N','N', NEL1, & NPIV_BLOCK, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) ELSE #endif IF ( LAST_COL_GEMM - IEND_BLOCK > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = LAST_COL_GEMM - IEND_BLOCK END IF IF ( LAST_COL_GEMM - IEND_BLOCK .GT. 0 ) THEN DO IROW = IEND_BLOCK+1, LAST_COL_GEMM, BLSIZE Block = min( BLSIZE, LAST_COL_GEMM - IROW + 1 ) LPOS = POSELT + int( IROW - 1,8) * LDA8 + & int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK - 1,8) * LDA8 + & int( IROW - 1,8) APOS = POSELT + int( IROW - 1,8) * LDA8 + int( IROW - 1,8) CALL sgemm( 'N','N', Block, LAST_COL_GEMM - IROW + 1, & NPIV_BLOCK, ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) END DO END IF #if defined(GEMMT_AVAILABLE) END IF #endif LPOS = POSELT + int(LAST_COL_GEMM,8)*LDA8 + int(IBEG_BLOCK-1,8) UPOS = POSELT + int(IBEG_BLOCK-1,8) * LDA8 + & int(IEND_BLOCK,8) APOS = POSELT + int(LAST_COL_GEMM,8)*LDA8 + int(IEND_BLOCK,8) IF (LAST_ROW_GEMM .GT. LAST_COL_GEMM) THEN CALL sgemm('N', 'N', NEL1, LAST_ROW_GEMM-LAST_COL_GEMM, & NPIV_BLOCK, ALPHA, A(UPOS), LDA, A(LPOS), LDA, & ONE, A(APOS), LDA) ENDIF ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_SQ_LDLT SUBROUTINE SMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, IPIV, POSELT, LASTROW2SWAP, & LDA, NFRONT, LEVEL, PARPIV, K50, XSIZE, & IBEG_BLOCK_TO_SEND ) IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER LIW, IOLDPS, NPIVP1, IPIV INTEGER LDA, NFRONT, LEVEL, PARPIV, K50, XSIZE INTEGER LASTROW2SWAP REAL A( LA ) INTEGER IW( LIW ) INTEGER, INTENT(IN) :: IBEG_BLOCK_TO_SEND INCLUDE 'mumps_headers.h' INTEGER :: IBEG INTEGER ISW, ISWPS1, ISWPS2, HF INTEGER(8) :: IDIAG, APOS INTEGER(8) :: LDA8 REAL SWOP LDA8 = int(LDA,8) APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIVP1-1,8) IDIAG = APOS + int(IPIV - NPIVP1,8) HF = 6 + IW( IOLDPS + 5 + XSIZE) + XSIZE ISWPS1 = IOLDPS + HF + NPIVP1 - 1 ISWPS2 = IOLDPS + HF + IPIV - 1 ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW ISW = IW(ISWPS1+NFRONT) IW(ISWPS1+NFRONT) = IW(ISWPS2+NFRONT) IW(ISWPS2+NFRONT) = ISW IF ( LEVEL .eq. 2 ) THEN IBEG = IBEG_BLOCK_TO_SEND CALL sswap( NPIVP1 - 1 - IBEG + 1, & A( POSELT + int(NPIVP1-1,8) + & int(IBEG-1,8) * LDA8), LDA, & A( POSELT + int(IPIV-1,8) + & int(IBEG-1,8) * LDA8), LDA ) END IF CALL sswap( NPIVP1-1, & A( POSELT+int(NPIVP1-1,8) * LDA8 ), 1, & A( POSELT + int(IPIV-1,8) * LDA8 ), 1 ) CALL sswap( IPIV - NPIVP1 - 1, & A( POSELT+int(NPIVP1,8) * LDA8 + int(NPIVP1-1,8) ), & LDA, A( APOS + 1_8 ), 1 ) SWOP = A(IDIAG) A(IDIAG) = A( POSELT+int(NPIVP1-1,8)*LDA8+int(NPIVP1-1,8) ) A( POSELT + int(NPIVP1-1,8)*LDA8 + int(NPIVP1-1,8) ) = SWOP IF (LASTROW2SWAP - IPIV.GT.0) THEN CALL sswap( LASTROW2SWAP - IPIV, & A( APOS + LDA8 ), LDA, & A( IDIAG + LDA8 ), LDA ) ENDIF IF (PARPIV.NE.0 .AND.K50.EQ.2) THEN IF ( LEVEL .eq. 2 .OR. LEVEL.eq.1) THEN APOS = POSELT+LDA8*LDA8-1_8 SWOP = A(APOS+int(NPIVP1,8)) A(APOS+int(NPIVP1,8))= A(APOS+int(IPIV,8)) A(APOS+int(IPIV,8)) = SWOP ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SWAP_LDLT SUBROUTINE SMUMPS_FAC_LDLT_COPY2U_SCALEL( IROWMAX, IROWMIN, & SIZECOPY, LDA, NCOLS, LIW, IW, OFFSET_IW, & LA, A, POSELT, A_LPOS, A_UPOS, A_DPOS, & COPY_NEEDED ) !$ USE OMP_LIB INTEGER, INTENT(IN) :: IROWMAX, IROWMIN INTEGER, INTENT(IN) :: SIZECOPY INTEGER, INTENT(IN) :: LDA, NCOLS INTEGER, INTENT(IN) :: LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: OFFSET_IW INTEGER(8), INTENT(IN) :: LA REAL, INTENT(INOUT) :: A(LA) INTEGER(8), INTENT(IN) :: POSELT, A_LPOS, A_UPOS, A_DPOS LOGICAL, INTENT(IN) :: COPY_NEEDED INTEGER(8) :: LPOS, UPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER :: IROWEND, IROW, Block2 INTEGER :: I, J REAL :: MULT1, MULT2, A11, DETPIV, A22, A12 INTEGER :: BLSIZECOPY REAL :: ONE PARAMETER (ONE = 1.0E0) INTEGER(8) :: LPOSI, UPOSI LOGICAL :: PIVOT_2X2 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP, CHUNK LDA8 = int(LDA,8) IF (SIZECOPY.NE.0) THEN BLSIZECOPY = SIZECOPY ELSE BLSIZECOPY = 250 ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = (64/4) !$ IF (NOMP .GT. 1 .AND. NCOLS .GE. 4*CHUNK) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max(2*CHUNK, NCOLS/NOMP) !$ ENDIF DO IROWEND = IROWMAX, IROWMIN, -BLSIZECOPY Block2 = min(BLSIZECOPY, IROWEND) IROW = IROWEND - Block2 + 1 LPOS = A_LPOS + int(IROW-1,8)*LDA8 UPOS = A_UPOS + int(IROW-1,8) !$OMP PARALLEL DO PRIVATE(PIVOT_2X2, A11, DPOS, !$OMP& POSPV1, POSPV2, OFFDAG, A22, A12, DETPIV, J, MULT1, MULT2 !$OMP& , LPOSI, UPOSI !$OMP& ) FIRSTPRIVATE(Block2, LDA, LDA8, LPOS, UPOS, A_DPOS) !$OMP& SCHEDULE(STATIC,CHUNK) IF(OMP_FLAG) DO I=1, NCOLS PIVOT_2X2 = .FALSE. IF(IW(OFFSET_IW+I-1) .LE. 0) THEN PIVOT_2X2 = .TRUE. ELSE IF (I .GT. 1) THEN IF (IW(OFFSET_IW+I-2) .LE. 0) THEN cycle ENDIF ENDIF ENDIF DPOS = A_DPOS + LDA8*int(I-1,8) + int(I-1,8) IF(.not. PIVOT_2X2) THEN A11 = ONE/A(DPOS) LPOSI = LPOS+int(I-1,8) IF (COPY_NEEDED) THEN UPOSI = UPOS+int(I-1,8)*LDA8 #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, Block2 A(UPOSI+int(J-1,8)) = A(LPOSI+int(J-1,8)*LDA8) END DO ENDIF #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, Block2 A(LPOSI+int(J-1,8)*LDA8) = A(LPOSI+int(J-1,8)*LDA8)*A11 END DO ELSE IF (COPY_NEEDED) THEN CALL scopy(Block2, A(LPOS+int(I-1,8)), & LDA, A(UPOS+int(I-1,8)*LDA8), 1) CALL scopy(Block2, A(LPOS+int(I,8)), & LDA, A(UPOS+int(I,8)*LDA8), 1) ENDIF POSPV1 = DPOS POSPV2 = DPOS + int(LDA+1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1,Block2 MULT1 = A11*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A12*A(LPOS+int(J-1,8)*LDA8+int(I,8)) MULT2 = A12*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A22*A(LPOS+int(J-1,8)*LDA8+int(I,8)) A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) = MULT1 A(LPOS+int(J-1,8)*LDA8+int(I,8)) = MULT2 ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDDO END SUBROUTINE SMUMPS_FAC_LDLT_COPY2U_SCALEL SUBROUTINE SMUMPS_FAC_LDLT_COPYSCALE_U( IROWMAX, IROWMIN, & SIZECOPY, LDA, NCOLS, LIW, IW, OFFSET_IW, & LA, A, POSELT, A_LPOS, A_UPOS, A_DPOS ) !$ USE OMP_LIB INTEGER, INTENT(IN) :: IROWMAX, IROWMIN INTEGER, INTENT(IN) :: SIZECOPY INTEGER, INTENT(IN) :: LDA, NCOLS INTEGER, INTENT(IN) :: LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: OFFSET_IW INTEGER(8), INTENT(IN) :: LA REAL, INTENT(INOUT) :: A(LA) INTEGER(8), INTENT(IN) :: POSELT, A_LPOS, A_UPOS, A_DPOS INTEGER(8) :: LPOS, UPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER :: IROWEND, IROW, Block2 INTEGER :: I, J REAL :: MULT1, MULT2, A11, A22, A12 INTEGER :: BLSIZECOPY REAL :: ONE PARAMETER (ONE = 1.0E0) INTEGER(8) :: LPOSI, UPOSI LOGICAL :: PIVOT_2X2 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP, CHUNK LDA8 = int(LDA,8) IF (SIZECOPY.NE.0) THEN BLSIZECOPY = SIZECOPY ELSE BLSIZECOPY = 250 ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = (64/4) !$ IF (NOMP .GT. 1 .AND. NCOLS .GE. 4*CHUNK) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max(2*CHUNK, NCOLS/NOMP) !$ ENDIF DO IROWEND = IROWMAX, IROWMIN, -BLSIZECOPY Block2 = min(BLSIZECOPY, IROWEND) IROW = IROWEND - Block2 + 1 LPOS = A_LPOS + int(IROW-1,8)*LDA8 UPOS = A_UPOS + int(IROW-1,8) !$OMP PARALLEL DO PRIVATE(PIVOT_2X2, A11, DPOS, !$OMP& POSPV1, POSPV2, OFFDAG, A22, A12, J, MULT1, MULT2 !$OMP& , LPOSI, UPOSI !$OMP& ) FIRSTPRIVATE(Block2, LDA, LDA8, LPOS, UPOS, POSELT) !$OMP& SCHEDULE(STATIC,CHUNK) IF(OMP_FLAG) DO I=1, NCOLS PIVOT_2X2 = .FALSE. IF(IW(OFFSET_IW+I-1) .LE. 0) THEN PIVOT_2X2 = .TRUE. ELSE IF (I .GT. 1) THEN IF (IW(OFFSET_IW+I-2) .LE. 0) THEN cycle ENDIF ENDIF ENDIF DPOS = A_DPOS + LDA8*int(I-1,8) + int(I-1,8) IF(.not. PIVOT_2X2) THEN A11 = A(DPOS) LPOSI = LPOS+int(I-1,8) UPOSI = UPOS+int(I-1,8)*LDA8 #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, Block2 A(UPOSI+int(J-1,8)) = A(LPOSI+int(J-1,8)*LDA8)*A11 END DO ELSE POSPV1 = DPOS POSPV2 = DPOS + int(LDA+1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1,Block2 MULT1 = A11*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A12*A(LPOS+int(J-1,8)*LDA8+int(I,8)) MULT2 = A12*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A22*A(LPOS+int(J-1,8)*LDA8+int(I,8)) A(UPOS+int(I-1,8)*LDA8+int(J-1,8)) = MULT1 A(UPOS+int(I,8)*LDA8+int(J-1,8)) = MULT2 ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDDO RETURN END SUBROUTINE SMUMPS_FAC_LDLT_COPYSCALE_U SUBROUTINE SMUMPS_FAC_T_LDLT(NFRONT,NASS, & IW,LIW,A,LA, & LDA, & IOLDPS,POSELT,KEEP,KEEP8, & POSTPONE_COL_UPDATE, ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG, OFFSET_IW, INODE ) USE SMUMPS_OOC IMPLICIT NONE INTEGER NFRONT, NASS,LIW INTEGER(8) :: LA REAL A(LA) INTEGER IW(LIW) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: POSELT INTEGER LDA INTEGER IOLDPS, ETATASS LOGICAL POSTPONE_COL_UPDATE INTEGER(8) :: LAFAC INTEGER TYPEFile, NextPiv2beWritten INTEGER LIWFAC, MYID, IFLAG TYPE(IO_BLOCK):: MonBloc INTEGER IDUMMY LOGICAL LAST_CALL INTEGER :: OFFSET_IW INTEGER, intent(in):: INODE INCLUDE 'mumps_headers.h' INTEGER(8) :: UPOS, APOS, LPOS INTEGER(8) :: LDA8 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, IROWEND INTEGER I2, I2END, Block2, IFLAG_OOC REAL ONE, ALPHA, BETA, ZERO PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) PARAMETER (ZERO=0.0E0) LDA8 = int(LDA,8) IF (ETATASS.EQ.1) THEN BETA = ZERO ELSE BETA = ONE ENDIF IF ( NFRONT - NASS > KEEP(58) ) THEN IF ( NFRONT - NASS > KEEP(57) ) THEN BLSIZE = KEEP(58) ELSE BLSIZE = (NFRONT - NASS)/2 END IF ELSE BLSIZE = NFRONT - NASS END IF BLSIZE2 = KEEP(218) NPIV = IW( IOLDPS + 1 + KEEP(IXSZ)) IF ( NFRONT - NASS .GT. 0 ) THEN IF ( POSTPONE_COL_UPDATE ) THEN LPOS = POSELT + LDA8 * int(NASS,8) CALL strsm( 'L', 'U', 'T', 'U', & NPIV, NFRONT-NASS, ONE, & A( POSELT ), LDA, & A( LPOS ), LDA ) ENDIF #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1 .OR. & ( KEEP(421) > 0 .AND. NFRONT-NASS > KEEP(421) ) ) THEN LPOS = POSELT + int(NASS,8)*LDA8 UPOS = POSELT + int(NASS,8) APOS = POSELT + int(NASS,8)*LDA8 + int(NASS,8) IF (POSTPONE_COL_UPDATE) THEN CALL SMUMPS_FAC_LDLT_COPY2U_SCALEL( NFRONT - NASS, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, & POSELT, .TRUE. ) ENDIF CALL sgemmt('U', 'N', 'N', NFRONT-NASS, NPIV, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, & BETA, & A( APOS ), LDA ) ELSE #endif DO IROWEND = NFRONT - NASS, 1, -BLSIZE Block = min( BLSIZE, IROWEND ) IROW = IROWEND - Block + 1 LPOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 APOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 + & int(NASS + IROW - 1,8) UPOS = POSELT + int(NASS,8) IF (.NOT. POSTPONE_COL_UPDATE) THEN UPOS = POSELT + int(NASS + IROW - 1,8) ENDIF IF (POSTPONE_COL_UPDATE) THEN CALL SMUMPS_FAC_LDLT_COPY2U_SCALEL( Block, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, & POSELT, .TRUE. ) ENDIF DO I2END = Block, 1, -BLSIZE2 Block2 = min(BLSIZE2, I2END) I2 = I2END - Block2+1 CALL sgemm('N', 'N', Block2, Block-I2+1, NPIV, ALPHA, & A(UPOS+int(I2-1,8)), LDA, & A(LPOS+int(I2-1,8)*LDA8), LDA, & BETA, & A(APOS + int(I2-1,8) + int(I2-1,8)*LDA8), LDA) IF (KEEP(201).EQ.1) THEN IF (NextPiv2beWritten.LE.NPIV) THEN LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, MYID, & KEEP8(31), & IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC RETURN ENDIF ENDIF ENDIF ENDDO IF ( NFRONT - NASS - IROW + 1 - Block > 0 ) THEN CALL sgemm( 'N', 'N', Block, NFRONT-NASS-Block-IROW+1, NPIV, & ALPHA, A( UPOS ), LDA, & A( LPOS + LDA8 * int(Block,8) ), LDA, & BETA, & A( APOS + LDA8 * int(Block,8) ), LDA ) ENDIF END DO #if defined(GEMMT_AVAILABLE) END IF #endif IF ( (POSTPONE_COL_UPDATE).AND.(NASS-NPIV.GT.0) ) THEN LPOS = POSELT + int(NPIV,8)*LDA8 UPOS = POSELT + int(NPIV,8) CALL SMUMPS_FAC_LDLT_COPYSCALE_U( NASS-NPIV, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, POSELT) LPOS = POSELT + LDA8 * int(NASS,8) CALL sgemm('N', 'N', NASS-NPIV, NFRONT-NASS, NPIV, ALPHA, & A( POSELT + int(NPIV,8)), LDA, & A( LPOS ), LDA, & BETA, & A( LPOS + int(NPIV,8) ), LDA) ENDIF END IF RETURN END SUBROUTINE SMUMPS_FAC_T_LDLT SUBROUTINE SMUMPS_STORE_PERMINFO( PIVRPTR, NBPANELS, PIVR, NASS, & K, P, LastPanelonDisk, & LastPIVRPTRIndexFilled ) IMPLICIT NONE INTEGER, intent(in) :: NBPANELS, NASS, K, P INTEGER, intent(inout) :: PIVRPTR(NBPANELS), PIVR(NASS) INTEGER LastPanelonDisk, LastPIVRPTRIndexFilled INTEGER I IF ( LastPanelonDisk+1 > NBPANELS ) THEN WRITE(*,*) "INTERNAL ERROR IN SMUMPS_STORE_PERMINFO!" WRITE(*,*) "NASS=",NASS,"PIVRPTR=",PIVRPTR(1:NBPANELS) WRITE(*,*) "K=",K, "P=",P, "LastPanelonDisk=",LastPanelonDisk WRITE(*,*) "LastPIVRPTRIndexFilled=", LastPIVRPTRIndexFilled CALL MUMPS_ABORT() ENDIF PIVRPTR(LastPanelonDisk+1) = K + 1 IF (LastPanelonDisk.NE.0) THEN PIVR(K - PIVRPTR(1) + 1) = P DO I = LastPIVRPTRIndexFilled + 1, LastPanelonDisk PIVRPTR(I)=PIVRPTR(LastPIVRPTRIndexFilled) ENDDO ENDIF LastPIVRPTRIndexFilled = LastPanelonDisk + 1 RETURN END SUBROUTINE SMUMPS_STORE_PERMINFO SUBROUTINE SMUMPS_UPDATE_MINMAX_PIVOT & ( DIAG, DKEEP, KEEP, NULLPIVOT) !$ USE OMP_LIB IMPLICIT NONE REAL, INTENT(IN) :: DIAG REAL, INTENT(INOUT) :: DKEEP(230) LOGICAL, INTENT(IN) :: NULLPIVOT INTEGER, INTENT(IN) :: KEEP(500) IF (KEEP(405).EQ.0) THEN DKEEP(21) = max(DKEEP(21), DIAG) DKEEP(19) = min(DKEEP(19), DIAG) IF (.NOT.NULLPIVOT) THEN DKEEP(20) = min(DKEEP(20), DIAG) ENDIF ELSE !$OMP ATOMIC UPDATE DKEEP(21) = max(DKEEP(21), DIAG) !$OMP END ATOMIC !$OMP ATOMIC UPDATE DKEEP(19) = min(DKEEP(19), DIAG) !$OMP END ATOMIC IF (.NOT.NULLPIVOT) THEN !$OMP ATOMIC UPDATE DKEEP(20) = min(DKEEP(20), DIAG) !$OMP END ATOMIC ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_UPDATE_MINMAX_PIVOT SUBROUTINE SMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, NCB, SIZE_SCHUR, ROW_INDICES, PERM, & NVSCHUR & ) IMPLICIT NONE INTEGER, intent(in) :: N, NCB, SIZE_SCHUR INTEGER, intent(in) :: ROW_INDICES(NCB), PERM(N) INTEGER, intent(out):: NVSCHUR INTEGER :: I, IPOS, IBEG_SCHUR IBEG_SCHUR = N - SIZE_SCHUR +1 NVSCHUR = 0 IPOS = NCB DO I= NCB,1,-1 IF (abs(ROW_INDICES(I)).LE.N) THEN IF (PERM(ROW_INDICES(I)).LT.IBEG_SCHUR) EXIT ENDIF IPOS = IPOS -1 ENDDO NVSCHUR = NCB-IPOS RETURN END SUBROUTINE SMUMPS_GET_SIZE_SCHUR_IN_FRONT END MODULE SMUMPS_FAC_FRONT_AUX_M MUMPS_5.8.1/src/ssol_bwd_aux.F0000664000175000017500000021001515042446437016035 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SOLVE_NODE_BWD( INODE, & N, IPOOL, LPOOL, IIPOOL, NBFINF, & A, LA, IW, LIW, W, LWC, NRHS, & POSWCB, PLEFTW, POSIWCB, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, & MYLEAF_LEFT, INFO, & PROCNODE_STEPS, DEJA_SEND, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & , DO_MCAST2_TERMBWD & ) USE SMUMPS_OOC USE SMUMPS_BUF USE SMUMPS_SOL_LR, only : SMUMPS_SOL_BWD_LR_SU IMPLICIT NONE INTEGER :: KEEP( 500 ) INTEGER(8) :: KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER :: INFO(80) INTEGER, INTENT( IN ) :: INODE, N, NRHS, MTYPE, LIW, LIWW INTEGER, INTENT( IN ) :: SLAVEF, COMM, MYID INTEGER, INTENT (IN ) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT( IN ) :: NE_STEPS(KEEP(28)) INTEGER(8), INTENT( IN ) :: LA, LWC INTEGER(8), INTENT( INOUT ) :: POSWCB, PLEFTW INTEGER, INTENT( INOUT ) :: POSIWCB INTEGER, INTENT( IN ) :: LPANEL_POS INTEGER :: PANEL_POS(LPANEL_POS) LOGICAL, INTENT(INOUT) :: DEJA_SEND(0:SLAVEF-1) INTEGER, INTENT(IN) :: LPOOL INTEGER, INTENT(INOUT) :: IPOOL(LPOOL), IIPOOL INTEGER, INTENT(INOUT) :: NBFINF, MYLEAF_LEFT INTEGER :: PTRIST(KEEP(28)), PTRICB(KEEP(28)) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) REAL :: A( LA ) REAL :: W(LWC) REAL :: W2(KEEP(133)) INTEGER :: IW(LIW),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)),FILS(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LRHSINTR, POSINRHSINTR_BWD(N) REAL RHSINTR(LRHSINTR,NRHS) INTEGER(8), intent(in) :: LRHS_ROOT REAL RHS_ROOT( LRHS_ROOT ) LOGICAL, INTENT( IN ) :: PRUN_BELOW INTEGER, INTENT(IN) :: SIZE_TO_PROCESS LOGICAL, INTENT(IN) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, INTENT(IN) :: DO_NBSPARSE INTEGER, INTENT(IN) :: LRHS_BOUNDS INTEGER, INTENT(IN) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, INTENT(IN) :: FROM_PP LOGICAL, INTENT( OUT ) :: ERROR_WAS_BROADCASTED LOGICAL, INTENT( OUT ) :: DO_MCAST2_TERMBWD INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR LOGICAL FLAG INCLUDE 'mumps_headers.h' LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL LTLEVEL2, IN_SUBTREE INTEGER TYPENODE INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL NO_CHILDREN LOGICAL :: ALLOW_OTHERS_TO_LEAVE INTEGER :: K, JBDEB, JBFIN, NRHS_B INTEGER IWHDLR INTEGER NPIV INTEGER IPOS,LIELL,NELIM,JJ,I INTEGER J1,J2,J,NCB INTEGER NSLAVES INTEGER IN,IF,LONG,POOL_FIRST_POS,TMP INTEGER :: NBFILS INTEGER :: PROCDEST, DEST INTEGER(8) :: PTWCB, PPIV_COURANT INTEGER :: Offset, EffectiveSize, ISLAVE, FirstIndex INTEGER :: POSINDICES, IPOSINRHSINTR, IPOSINRHSINTR_PANEL INTEGER(8) :: APOS, IST INTEGER(8) :: IFR8 INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER LDAJ, NBJ, & NBJLAST, NPIV_LAST, PANEL_SIZE, & NCB_PANEL, TYPEF INTEGER BEG_PANEL LOGICAL TWOBYTWO INTEGER NPANELS, IPANEL REAL ALPHA,ONE,ZERO PARAMETER (ZERO=0.0E0, ONE = 1.0E0, ALPHA=-1.0E0) LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE ERROR_WAS_BROADCASTED = .FALSE. DO_MCAST2_TERMBWD = .FALSE. NO_CHILDREN = .FALSE. IF (DO_NBSPARSE) THEN JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) JBFIN= RHS_BOUNDS(2*STEP(INODE)) NRHS_B = JBFIN-JBDEB+1 ELSE JBDEB = 1 JBFIN = NRHS NRHS_B = NRHS ENDIF IF ( INODE .EQ. KEEP( 38 ) .OR. INODE .EQ. KEEP( 20 ) ) THEN IPOS = PTRIST(STEP(INODE))+KEEP(IXSZ) NPIV = IW(IPOS+3) LIELL = IW(IPOS) + NPIV IPOS = PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) IF ( MTYPE .EQ. 1 .AND. KEEP(50) .EQ. 0) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + LIELL + NPIV ELSE J1 = IPOS + 1 J2 = IPOS + NPIV END IF IFR8 = 0_8 IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) CALL SMUMPS_SOL_CPY_FS2RHSINTR(JBDEB, JBFIN, J2-J1+1, & KEEP, RHSINTR, NRHS, LRHSINTR, IPOSINRHSINTR, & RHS_ROOT(1+NPIV*(JBDEB-1)), NPIV, 1) IN = INODE 270 IN = FILS(IN) IF (IN .GT. 0) GOTO 270 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF (KEEP(31) .NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF RETURN ENDIF IF = -IN LONG = NPIV NBFILS = NE_STEPS(STEP(INODE)) IF ( PRUN_BELOW ) THEN I = NBFILS NBFILS = 0 DO WHILE (I.GT.0) IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 IF = FRERE(STEP(IF)) I = I -1 ENDDO IF (NBFILS.EQ.0) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF IF = -IN ENDIF DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1030 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1030 ENDIF NO_CHILDREN = .FALSE. ENDIF IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)),KEEP(199)) & .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) IF (.NOT. DEJA_SEND( PROCDEST )) THEN 600 CONTINUE CALL SMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, & LONG, LONG, IW( J1 ), & RHS_ROOT( 1+NPIV*(JBDEB-1) ), & JBDEB, JBFIN, & RHSINTR(1, 1), NRHS, LRHSINTR, & IPOSINRHSINTR, NPIV, & KEEP, PROCDEST, & NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, & MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 600 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal error 2 SMUMPS_SOLVE_NODE_BWD", & IERR CALL MUMPS_ABORT() END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF ENDIF IF = FRERE(STEP(IF)) ENDDO ALLOW_OTHERS_TO_LEAVE = .FALSE. IF ( PRUN_BELOW .AND. NO_CHILDREN ) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) ENDIF IF ( KEEP(31). NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF IF (IIPOOL.NE.POOL_FIRST_POS) THEN DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP = IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1) = IPOOL(IIPOOL-I) IPOOL(IIPOOL-I) = TMP ENDDO ENDIF RETURN END IF IN_SUBTREE = MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) TYPENODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) LTLEVEL2= ( & (TYPENODE .eq.2 ) .AND. & (MTYPE.NE.1) ) NPIV = IW(PTRIST(STEP(INODE))+2+KEEP(IXSZ)+1) IF ((NPIV.NE.0).AND.(LTLEVEL2)) THEN IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) NCB = LIELL - NPIV - NELIM IPOS = IPOS + 2 NSLAVES = IW( IPOS ) Offset = 0 IPOS = IPOS + NSLAVES IW(PTRIST(STEP(INODE))+XXS)= C_FINI+NSLAVES IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL SMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR(NCB * NRHS_B - POSWCB-PLEFTW+1_8, & INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - int(NCB,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = NCB*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF IF ( NCB.EQ.0 ) THEN write(6,*) ' Internal Error type 2 node with no CB ' CALL MUMPS_ABORT() ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + NELIM +1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + NELIM +1 J2 = IPOS + LIELL END IF IFR8 = PTRACB(STEP( INODE )) - 1_8 CALL SMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSINTR, NRHS, LRHSINTR, & W(PTRACB(STEP(INODE))), NCB, 1, & IW, LIW, KEEP, N, POSINRHSINTR_BWD ) IFR8 = IFR8 + int(J2-KEEP(253)-J1+1,8) IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR8 = IFR8 + 1_8 DO K=JBDEB, JBFIN IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR8+int(K-JBDEB,8)*int(NCB,8)) = ALPHA ELSE W(IFR8+int(K-JBDEB,8)*int(NCB,8)) = ZERO ENDIF ENDDO ENDDO ENDIF DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & EffectiveSize, & FirstIndex ) 500 CONTINUE DEST = IW( PTRIST(STEP(INODE))+5+ISLAVE+KEEP(IXSZ)) CALL SMUMPS_BUF_SEND_BACKVEC(NRHS_B, INODE, & W(Offset+PTRACB(STEP(INODE))), & EffectiveSize, & NCB, DEST, & BACKSLV_MASTER2SLAVE, JBDEB, JBFIN, & KEEP, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, & PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 500 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF Offset = Offset + EffectiveSize END DO IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL SMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) RETURN ENDIF LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) NCB = LIELL - NPIV IPOS = IPOS + 1 IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ENDIF APOS = PTRFAC( STEP(INODE)) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 + NSLAVES IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN IF (MTYPE.NE.1) THEN TYPEF = TYPEF_L ELSE TYPEF = TYPEF_U ENDIF PANEL_SIZE = SMUMPS_OOC_PANEL_SIZE( LIELL ) IF (KEEP(50).NE.1) THEN CALL SMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF LONG = 0 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL ELSE J1 = IPOS + 1 J2 = IPOS + NPIV ENDIF IF (IN_SUBTREE) THEN PTWCB = PLEFTW IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN CALL SMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(int(LIELL,8)*int(NRHS_B,8)-POSWCB, & INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF ELSE IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL SMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB ) IF ( POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR( int(LIELL,8)*int(NRHS_B,8)- & POSWCB-PLEFTW+1_8, & INFO(2) ) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - int(LIELL,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF PTWCB = PTRACB(STEP( INODE )) ENDIF IF (J2.GE.J1) THEN IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) ELSE IPOSINRHSINTR = -99999 ENDIF IF (J2.GE.J1) THEN DO K=JBDEB, JBFIN IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = ZERO ENDDO ENDIF END DO ENDIF IFR8 = PTWCB + int(NPIV - 1,8) IF ( LIELL .GT. NPIV ) THEN IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + 1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + 1 J2 = IPOS + LIELL END IF CALL SMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSINTR, NRHS, LRHSINTR, & W(PTWCB), LIELL, NPIV+1, & IW, LIW, KEEP, N, POSINRHSINTR_BWD ) IFR8 = IFR8 + int(J2-KEEP(253)-J1+1,8) IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR8 = IFR8 + 1_8 DO K=JBDEB, JBFIN IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR8+int(K-JBDEB,8)*int(LIELL,8)) = ALPHA ELSE W(IFR8+int(K-JBDEB,8)*int(LIELL,8)) = ZERO ENDIF ENDDO ENDDO ENDIF NCB = LIELL - NPIV IF (NPIV .EQ. 0) GOTO 160 ENDIF IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN J = NPIV / PANEL_SIZE TWOBYTWO = KEEP(50).EQ.2 .AND. & ((TYPENODE.EQ.1.AND.KEEP(103).GT.0) .OR. & (TYPENODE.EQ.2.AND.KEEP(105).GT.0)) IF (TWOBYTWO) THEN CALL SMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, LPANEL_POS, & IW(IPOS+1+LIELL), NPIV, NPANELS, LIELL, & NBENTRIES_ALLPANELS) ELSE IF (NPIV.EQ.J*PANEL_SIZE) THEN NPIV_LAST = NPIV NBJLAST = PANEL_SIZE NPANELS = J ELSE NPIV_LAST = (J+1)* PANEL_SIZE NBJLAST = NPIV-J*PANEL_SIZE NPANELS = J+1 ENDIF NBENTRIES_ALLPANELS = & int(LIELL,8) * int(NPIV,8) & - int( ( J * ( J - 1 ) ) /2,8 ) & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) & - int(J,8) & * int(mod(NPIV, PANEL_SIZE),8) & * int(PANEL_SIZE,8) JJ=NPIV_LAST ENDIF APOSDEB = APOS + NBENTRIES_ALLPANELS DO IPANEL = NPANELS, 1, -1 IF (TWOBYTWO) THEN NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) BEG_PANEL = PANEL_POS(IPANEL) ELSE IF (JJ.EQ.NPIV_LAST) THEN NBJ = NBJLAST ELSE NBJ = PANEL_SIZE ENDIF BEG_PANEL = JJ- PANEL_SIZE+1 ENDIF LDAJ = LIELL-BEG_PANEL+1 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) IPOSINRHSINTR_PANEL = IPOSINRHSINTR + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ IF (KEEP(50).NE.1.AND.MUST_BE_PERMUTED) THEN CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) IF (NPIV.EQ.(IW(I_PIVRPTR)-1)) THEN MUST_BE_PERMUTED=.FALSE. ELSE CALL SMUMPS_PERMUTE_PANEL( & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, BEG_PANEL-1) ENDIF ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB.NE. 0) THEN CALL sgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL+NBJ,JBDEB), & 1, ONE, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1 ) ENDIF IF (NCB .NE. 0) THEN CALL sgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1 ) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL strsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1) ELSE CALL strsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1) ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB .NE. 0) THEN CALL sgemm( 'T', 'N', NBJ, NRHS_B, & NCB_PANEL-NCB, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL+NBJ,JBDEB), LRHSINTR, & ONE, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ENDIF IF (NCB .NE. 0) THEN CALL sgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, & W( PTWCB+int(NPIV,8) ), LIELL, & ONE, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB),LRHSINTR) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL strsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ELSE CALL strsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO ELSE IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 & .AND. KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL SMUMPS_SOL_BWD_LR_SU ( & INODE, IWHDLR, NPIV, NSLAVES, & LIELL, W, LWC, NRHS_B, PTWCB, & RHSINTR, LRHSINTR, NRHS, & IPOSINRHSINTR, JBDEB, & MTYPE, KEEP, KEEP8, & INFO(1), INFO(2) ) IF (INFO(1).LT.0) THEN ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ELSE IF ( LIELL .GT. NPIV ) THEN IF ( MTYPE .eq. 1 ) THEN IST = APOS + int(NPIV,8) #if defined(MUMPS_USE_BLAS2) IF (NRHS_B == 1) THEN CALL sgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(PTWCB+int(NPIV,8)), 1, & ONE, & RHSINTR(IPOSINRHSINTR,JBDEB), 1 ) ELSE #endif CALL sgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), & LIELL, W(PTWCB+int(NPIV,8)), LIELL, ONE, & RHSINTR(IPOSINRHSINTR,JBDEB), LRHSINTR) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE IF ( KEEP(50) .eq. 0 ) THEN IST = APOS + int(NPIV,8) * int(LIELL,8) ELSE IF( KEEP(459) .GT. 1) THEN CALL MUMPS_GETI8(IST, IW(PTRIST(STEP(INODE))+XXR)) IST = APOS + IST - int(NPIV,8) * int(LIELL-NPIV,8) ELSE IST = APOS + int(NPIV,8) * int(NPIV,8) ENDIF END IF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL sgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSINTR(IPOSINRHSINTR,JBDEB), 1 ) ELSE #endif CALL sgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), & NPIV, W(PTWCB+int(NPIV,8)), LIELL, & ONE, RHSINTR(IPOSINRHSINTR,JBDEB), LRHSINTR) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF ENDIF IF ( MTYPE .eq. 1 ) THEN LDAJ = LIELL ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=LIELL ELSE IF (KEEP(459).GT.1) THEN LDAJ=-999799 ELSE LDAJ=NPIV ENDIF ENDIF END IF PPIV_COURANT = int(JBDEB-1,8)*int(LRHSINTR,8) & + int(IPOSINRHSINTR,8) IF (KEEP(459).GT.1 .AND. KEEP(50).NE.0) THEN CALL SMUMPS_SOLVE_BWD_PANELS( A, LA, APOS, & NPIV, IW(IPOS+1+LIELL), & NRHS_B, RHSINTR(1,1), KEEP8(25), LRHSINTR, PPIV_COURANT, & MTYPE, KEEP ) ELSE CALL SMUMPS_SOLVE_BWD_TRSOLVE( A, LA, APOS, & NPIV, LDAJ, & NRHS_B, RHSINTR(1,1), KEEP8(25), LRHSINTR, PPIV_COURANT, & MTYPE, KEEP ) ENDIF ENDIF ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN J1 = IPOS + LIELL + 1 ELSE J1 = IPOS + 1 END IF IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) 160 CONTINUE IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ENDIF IN = INODE 170 IN = FILS(IN) IF (IN .GT. 0) GOTO 170 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 IF (.NOT. IN_SUBTREE ) THEN IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 CALL SMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF ( KEEP(31) .NE. 0 .AND. & .NOT. IN_SUBTREE ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31).EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF RETURN ENDIF IF = -IN NBFILS = NE_STEPS(STEP(INODE)) IF ( PRUN_BELOW ) THEN I = NBFILS NBFILS = 0 DO WHILE (I.GT.0) IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 IF = FRERE(STEP(IF)) I = I -1 ENDDO IF (NBFILS.EQ.0) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF IF = -IN ENDIF IF (IN_SUBTREE) THEN DO I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1010 CONTINUE IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1010 ENDIF NO_CHILDREN = .FALSE. ENDIF IPOOL((IIPOOL-I+1)+NBFILS-I) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ENDDO IF (PRUN_BELOW .AND. NO_CHILDREN) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF (ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 RETURN ENDIF ENDIF ELSE DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO 190 I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1020 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1020 ENDIF NO_CHILDREN = .FALSE. ENDIF IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) IF (.not. DEJA_SEND( PROCDEST )) THEN 400 CONTINUE CALL SMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, & LIELL, LIELL - KEEP(253), & IW( POSINDICES ), & W( PTRACB(STEP(INODE)) ), JBDEB, JBFIN, & RHSINTR(1, 1), NRHS, LRHSINTR, & IPOSINRHSINTR, NPIV, & KEEP, PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF IF = FRERE(STEP(IF)) ENDIF 190 CONTINUE IF ( PRUN_BELOW .AND. NO_CHILDREN ) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF ( ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 RETURN ENDIF ENDIF DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO IF ( KEEP(31) .NE. 0 ) & THEN KEEP(31) = KEEP(31) - 1 ALLOW_OTHERS_TO_LEAVE = (KEEP(31) .EQ. 1) IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF ENDIF IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 CALL SMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF RETURN END SUBROUTINE SMUMPS_SOLVE_NODE_BWD RECURSIVE SUBROUTINE SMUMPS_BACKSLV_RECV_AND_TREAT( & BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IMPLICIT NONE LOGICAL BLOQ, FLAG INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER(8), intent(in) :: LWC REAL W( LWC ) INTEGER POSIWCB INTEGER IIPOOL, LPOOL INTEGER IPOOL( LPOOL ) INTEGER LPANEL_POS INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(80), KEEP(500) INTEGER(8) :: POSWCB, PLEFTW INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER LIW INTEGER(8) :: LA INTEGER PTRIST(KEEP(28)), IW( LIW ) INTEGER (8) :: PTRFAC(KEEP(28)) REAL A( LA ), W2( KEEP(133) ) INTEGER NRHS INTEGER MYLEAF_LEFT, MTYPE INTEGER LRHSINTR, POSINRHSINTR_BWD(N) REAL RHSINTR(LRHSINTR,NRHS) LOGICAL, INTENT(IN) :: PRUN_BELOW INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR FLAG = .FALSE. IF ( BLOQ ) THEN CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF (FLAG) THEN KEEP(266)=KEEP(266)-1 MSGSOU=STATUS(MPI_SOURCE) MSGTAG=STATUS(MPI_TAG) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN INFO(1) = -20 INFO(2) = MSGLEN IF (NBFINF .NE. 0) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ELSE CALL MPI_RECV(BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, COMM, STATUS, IERR) CALL SMUMPS_BACKSLV_TRAITER_MESSAGE( MSGTAG, MSGSOU, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) END IF END IF RETURN END SUBROUTINE SMUMPS_BACKSLV_RECV_AND_TREAT RECURSIVE SUBROUTINE SMUMPS_BACKSLV_TRAITER_MESSAGE( & MSGTAG, MSGSOU, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) USE SMUMPS_OOC USE SMUMPS_SOL_LR, ONLY: SMUMPS_SOL_SLAVE_LR_U, & SMUMPS_SOL_BWD_LR_SU USE SMUMPS_BUF IMPLICIT NONE INTEGER MSGTAG, MSGSOU INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER(8), intent(in) :: LWC REAL W( LWC ) INTEGER POSIWCB INTEGER IIPOOL, LPOOL, LPANEL_POS INTEGER IPOOL( LPOOL ) INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(80), KEEP(500) INTEGER(8) :: POSWCB, PLEFTW INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER FRERE(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER LIW INTEGER(8) :: LA INTEGER IW( LIW ), PTRIST( KEEP(28) ) INTEGER(8) :: PTRFAC(KEEP(28)) REAL A( LA ), W2( KEEP(133) ) INTEGER NRHS INTEGER MYLEAF_LEFT, MTYPE INTEGER LRHSINTR, POSINRHSINTR_BWD(N) REAL RHSINTR(LRHSINTR,NRHS) LOGICAL, INTENT(IN) :: PRUN_BELOW INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS), NO_CHILDREN LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IF, INODE, IERR, LONG, DUMMY(1) INTEGER :: LIELL, K INTEGER(8) :: APOS, IST INTEGER NPIV, NROW_L, IPOS, NROW_RECU INTEGER(8) :: IFR8 INTEGER I, JJ, IN, PROCDEST, J1, J2, LDA INTEGER NSLAVES, NELIM, J, POSINDICES, INODEPOS, & IPOSINRHSINTR, IPOSINRHSINTR_PANEL INTEGER JBDEB, JBFIN, NRHS_B, allocok INTEGER(8) :: P_UPDATE, P_SOL_MAS INTEGER :: IWHDLR, MTYPE_SLAVE, LDA_SLAVE LOGICAL FLAG REAL ZERO, ALPHA, ONE PARAMETER (ZERO=0.0E0, ONE = 1.0E0, ALPHA=-1.0E0) INCLUDE 'mumps_headers.h' INTEGER POOL_FIRST_POS, TMP LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: NCB INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER(8) :: PTWCB, PPIV_COURANT INTEGER LDAJ, NBJ, & NBJLAST, NPIV_LAST, PANEL_SIZE, & NCB_PANEL, TYPEF LOGICAL TWOBYTWO INTEGER BEG_PANEL INTEGER IPANEL, NPANELS INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL :: ALLOW_OTHERS_TO_LEAVE LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_PROCNODE ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then INFO(1)=-13 INFO(2)=SLAVEF WRITE(6,*) MYID,' Allocation error of DEJA_SEND ' & //'in bwd solve COMPSO' GOTO 260 END IF DUMMY(1)=0 IF (MSGTAG .EQ. TERMBWD) THEN NBFINF = NBFINF - 1 ELSE IF (MSGTAG .EQ. NOEUD) THEN POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & LONG, 1, MPI_INTEGER, & COMM, IERR) NRHS_B = JBFIN-JBDEB+1 IF ( POSIWCB - LONG .LT. 0 & .OR. POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN CALL SMUMPS_COMPSO(N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF (POSIWCB - LONG .LT. 0) THEN INFO(1)=-14 INFO(2)=-POSIWCB + LONG WRITE(6,*) MYID,' Internal error 1 in bwd solve COMPSO' GOTO 260 END IF IF ( POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(LONG + PLEFTW - POSWCB - 1_8, & INFO(2)) WRITE(6,*) MYID,' Internal error 2 in bwd solve COMPSO' GOTO 260 END IF ENDIF POSIWCB = POSIWCB - LONG POSWCB = POSWCB - LONG IF (LONG .GT. 0) THEN CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IWCB(POSIWCB + 1), & LONG, MPI_INTEGER, COMM, IERR) DO K=JBDEB,JBFIN CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & W(POSWCB + 1), LONG, & MPI_REAL, COMM, IERR) DO JJ=0, LONG-1 IPOSINRHSINTR = abs( POSINRHSINTR_BWD( IWCB( & POSIWCB+1+JJ ) ) ) IF (IPOSINRHSINTR.EQ.0) CYCLE RHSINTR(IPOSINRHSINTR,K) = W(POSWCB+1+JJ) ENDDO ENDDO POSIWCB = POSIWCB + LONG POSWCB = POSWCB + LONG ENDIF POOL_FIRST_POS = IIPOOL IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(INODE))) & GOTO 1010 ENDIF IPOOL( IIPOOL ) = INODE IIPOOL = IIPOOL + 1 1010 CONTINUE IF = FRERE( STEP(INODE) ) DO WHILE ( IF .GT. 0 ) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) .eq. MYID ) THEN IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(IF))) THEN IF = FRERE(STEP(IF)) CYCLE ENDIF ENDIF IPOOL( IIPOOL ) = IF IIPOOL = IIPOOL + 1 END IF IF = FRERE( STEP( IF ) ) END DO DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO ELSE IF ( MSGTAG .EQ. BACKSLV_MASTER2SLAVE ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NROW_RECU, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) NPIV = - IW( IPOS ) NROW_L = IW( IPOS + 1 ) IF ( NROW_L .NE. NROW_RECU ) THEN WRITE(*,*) 'Error1 : NROW L/RECU=',NROW_L, NROW_RECU CALL MUMPS_ABORT() END IF LONG = NROW_L + NPIV IF ( POSWCB - int(LONG,8)*int(NRHS_B,8) .LT. PLEFTW - 1_8 ) THEN CALL SMUMPS_COMPSO( N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LONG*NRHS_B .LT. PLEFTW - 1_8 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(LONG * NRHS_B- POSWCB,INFO(2)) WRITE(6,*) MYID,' Internal error 3 in bwd solve COMPSO' GOTO 260 END IF END IF P_UPDATE = PLEFTW P_SOL_MAS = PLEFTW + int(NPIV,8) * int(NRHS_B,8) PLEFTW = P_SOL_MAS + int(NROW_L,8) * int(NRHS_B,8) DO K=JBDEB, JBFIN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W( P_SOL_MAS+(K-JBDEB)*NROW_L),NROW_L, & MPI_REAL, & COMM, IERR ) ENDDO IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF APOS = PTRFAC( STEP(INODE)) IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) MTYPE_SLAVE = 0 W(P_UPDATE:P_UPDATE+NPIV*NRHS_B-1)=ZERO CALL SMUMPS_SOL_SLAVE_LR_U(INODE, IWHDLR, -9999, & W, LWC, & NROW_L, NPIV, & P_SOL_MAS, P_UPDATE, & JBDEB, JBFIN, & MTYPE_SLAVE, KEEP, KEEP8, & INFO(1), INFO(2) ) ELSE IF (KEEP(201) .EQ. 1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN MTYPE_SLAVE = 1 LDA_SLAVE = NROW_L ELSE MTYPE_SLAVE = 0 LDA_SLAVE = NPIV ENDIF CALL SMUMPS_SOLVE_GEMM_UPDATE( & A, LA, APOS, NROW_L, & LDA_SLAVE, & NPIV, & NRHS_B, W, LWC, & P_SOL_MAS, NROW_L, & P_UPDATE, NPIV, & MTYPE_SLAVE, KEEP, ZERO) ENDIF IF (KEEP(201) .EQ. 1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN CALL SMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF PLEFTW = PLEFTW - int(NROW_L,8) * int(NRHS_B,8) 100 CONTINUE CALL SMUMPS_BUF_SEND_BACKVEC( NRHS_B, INODE, & W(P_UPDATE), & NPIV, NPIV, & MSGSOU, & BACKSLV_UPDATERHS, & JBDEB, JBFIN, & KEEP, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 100 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) GOTO 260 END IF PLEFTW = PLEFTW - NPIV * NRHS_B ELSE IF ( MSGTAG .EQ. BACKSLV_UPDATERHS ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPIV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) IPOS = IPOS + 1 NSLAVES = IW( IPOS + 1 ) IPOS = IPOS + 1 + NSLAVES INODEPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 4 IF ( KEEP(50) .eq. 0 ) THEN LDA = LIELL ELSE LDA = NPIV ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL ELSE J1 = IPOS + 1 J2 = IPOS + NPIV ENDIF IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) DO K=JBDEB, JBFIN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W2, NPIV, MPI_REAL, & COMM, IERR ) I = 1 IF ( (KEEP(253).NE.0) .AND. & (IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI+NSLAVES) & ) THEN DO JJ = J1,J2 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = W2(I) I = I+1 ENDDO ELSE DO JJ = J1,J2 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = & RHSINTR(IPOSINRHSINTR+JJ-J1,K) + W2(I) I = I+1 ENDDO ENDIF ENDDO IW(PTRIST(STEP(INODE))+XXS) = & IW(PTRIST(STEP(INODE))+XXS) - 1 IF ( IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI ) THEN IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN CALL SMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL SMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF APOS = PTRFAC(IW(INODEPOS)) IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN TYPEF = TYPEF_L NROW_L = NPIV+NELIM PANEL_SIZE = SMUMPS_OOC_PANEL_SIZE(NROW_L) IF (PANEL_SIZE.LT.0) THEN WRITE(6,*) ' Internal error in bwd solve PANEL_SIZE=', & PANEL_SIZE CALL MUMPS_ABORT() ENDIF ENDIF IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL SMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB ) IF ( POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR( int(LIELL,8)*int(NRHS_B,8)- & POSWCB-PLEFTW+1_8, & INFO(2) ) GOTO 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 - int(LIELL,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 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 PTWCB = PTRACB(STEP( INODE )) IPOSINRHSINTR = POSINRHSINTR_BWD(IW(J1)) IFR8 = PTRACB(STEP( INODE )) IFR8 = PTWCB + int(NPIV - 1,8) IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + 1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + 1 J2 = IPOS + LIELL END IF CALL SMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSINTR, NRHS, LRHSINTR, & W(PTWCB), LIELL, NPIV+1, & IW, LIW, KEEP, N, POSINRHSINTR_BWD ) IFR8 = IFR8 + int(J2-KEEP(253)-J1+1,8) IF ( KEEP(201).EQ.1 .AND. OOCWRITE_COMPATIBLE_WITH_BLR .AND. & (( NELIM .GT. 0 ).OR. (MTYPE.NE.1 ))) THEN J = NPIV / PANEL_SIZE TWOBYTWO = KEEP(50).EQ.2 .AND. KEEP(105).GT.0 IF (TWOBYTWO) THEN CALL SMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, LPANEL_POS, & IW(IPOS+1+LIELL), NPIV, NPANELS, NROW_L, & NBENTRIES_ALLPANELS) ELSE IF (NPIV.EQ.J*PANEL_SIZE) THEN NPIV_LAST = NPIV NBJLAST = PANEL_SIZE NPANELS = J ELSE NPIV_LAST = (J+1)* PANEL_SIZE NBJLAST = NPIV-J*PANEL_SIZE NPANELS = J+1 ENDIF NBENTRIES_ALLPANELS = & int(NROW_L,8) * int(NPIV,8) & - int( ( J * ( J - 1 ) ) /2,8 ) & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) & - int(J,8) & * int(mod(NPIV, PANEL_SIZE),8) & * int(PANEL_SIZE,8) JJ=NPIV_LAST ENDIF APOSDEB = APOS + NBENTRIES_ALLPANELS DO IPANEL = NPANELS, 1, -1 IF (TWOBYTWO) THEN NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) BEG_PANEL = PANEL_POS(IPANEL) ELSE IF (JJ.EQ.NPIV_LAST) THEN NBJ = NBJLAST ELSE NBJ = PANEL_SIZE ENDIF BEG_PANEL = JJ- PANEL_SIZE+1 ENDIF LDAJ = NROW_L-BEG_PANEL+1 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) PTWCB = PTRACB(STEP(INODE)) IPOSINRHSINTR_PANEL = IPOSINRHSINTR + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ NCB = NROW_L - NPIV IF (KEEP(50).NE.1 .AND.MUST_BE_PERMUTED) THEN CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) CALL SMUMPS_PERMUTE_PANEL( & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, BEG_PANEL-1) ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB.NE. 0) THEN CALL sgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL+NBJ,JBDEB), & 1, ONE, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1 ) ENDIF IF (NCB .NE. 0) THEN CALL sgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1 ) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL strsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1) ELSE CALL strsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), 1) ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB .NE. 0) THEN CALL sgemm( 'T', 'N', NBJ, NRHS_B, & NCB_PANEL-NCB, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & RHSINTR(IPOSINRHSINTR_PANEL+NBJ,JBDEB), LRHSINTR, & ONE, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ENDIF IF (NCB .NE. 0) THEN CALL sgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, & W( PTWCB+int(NPIV,8) ), LIELL, & ONE, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB),LRHSINTR) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL strsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ELSE CALL strsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSINTR(IPOSINRHSINTR_PANEL,JBDEB), LRHSINTR) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO GOTO 1234 ENDIF IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 & .AND. KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL SMUMPS_SOL_BWD_LR_SU ( & INODE, IWHDLR, NPIV, NSLAVES, & LIELL, W, LWC, NRHS_B, PTRACB(STEP(INODE)), & RHSINTR, LRHSINTR, NRHS, & IPOSINRHSINTR, JBDEB, & MTYPE, KEEP, KEEP8, & INFO(1), INFO(2) ) ELSE IF (NELIM .GT.0) THEN IF ( KEEP(50) .eq. 0 ) THEN IST = APOS + int(NPIV,8) * int(LIELL,8) ELSE IF( KEEP(459) .GT. 1) THEN CALL MUMPS_GETI8(IST, IW(PTRIST(STEP(INODE))+XXR)) IST = APOS + IST - int(NPIV,8) * int(NELIM,8) ELSE IST = APOS + int(NPIV,8) * int(NPIV,8) ENDIF END IF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL sgemv( 'N', NPIV, NELIM, ALPHA, A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, & RHSINTR(IPOSINRHSINTR,JBDEB), 1 ) ELSE #endif CALL sgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))), LIELL, & ONE, RHSINTR(IPOSINRHSINTR,JBDEB), LRHSINTR) #if defined(MUMPS_USE_BLAS2) END IF #endif ENDIF PPIV_COURANT = int(JBDEB-1,8)*int(LRHSINTR,8) & + int(IPOSINRHSINTR,8) IF (KEEP(459).GT.1 .AND. KEEP(50).NE.0) THEN CALL SMUMPS_SOLVE_BWD_PANELS( A, LA, APOS, & NPIV, IW(IPOS+1+LIELL), & NRHS_B, RHSINTR(1,1), KEEP8(25), LRHSINTR, PPIV_COURANT, & MTYPE, KEEP ) ELSE CALL SMUMPS_SOLVE_BWD_TRSOLVE( A, LA, APOS, & NPIV, LDA, & NRHS_B, RHSINTR(1,1), KEEP8(25), LRHSINTR, PPIV_COURANT, & MTYPE, KEEP ) ENDIF ENDIF 1234 CONTINUE IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 6 + NSLAVES IPOSINRHSINTR = POSINRHSINTR_BWD(IW(IPOS)) IN = INODE 170 IN = FILS(IN) IF (IN .GT. 0) GOTO 170 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) IF (KEEP(31) .NE. 0) THEN IF (.NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN CALL SMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & TERMBWD, SLAVEF, KEEP ) NBFINF = NBFINF - 1 ENDIF IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 CALL SMUMPS_FREETOPSO(N, KEEP(28), & IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) GOTO 270 ENDIF DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO IN = -IN IF ( PRUN_BELOW ) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF DO WHILE (IN.GT.0) IF ( PRUN_BELOW ) THEN IF ( .NOT.TO_PROCESS(STEP(IN)) ) THEN IN = FRERE(STEP(IN)) CYCLE ELSE NO_CHILDREN = .FALSE. ENDIF ENDIF POOL_FIRST_POS = IIPOOL IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)), & KEEP(199)) .EQ. MYID) THEN IPOOL(IIPOOL ) = IN IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IN)), & KEEP(199) ) IF ( .NOT. DEJA_SEND( PROCDEST ) ) THEN 400 CONTINUE CALL SMUMPS_BUF_SEND_VCB( NRHS_B, IN, 0, 0, & LIELL, LIELL - KEEP(253), & IW( POSINDICES ), & W( PTRACB(STEP(INODE)) ), JBDEB, JBFIN, & RHSINTR(1, 1), NRHS, LRHSINTR, & IPOSINRHSINTR, NPIV, & KEEP, PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN GOTO 270 ENDIF GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) GOTO 260 END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF END IF IN = FRERE( STEP( IN ) ) END DO ALLOW_OTHERS_TO_LEAVE = .FALSE. IF (NO_CHILDREN) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) ENDIF IF (KEEP(31) .NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN CALL SMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERMBWD, SLAVEF, KEEP ) NBFINF = NBFINF - 1 ENDIF IF ( .NOT. NO_CHILDREN ) THEN DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO ENDIF IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL SMUMPS_FREETOPSO( N, KEEP(28), & IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) END IF ELSE IF (MSGTAG.EQ.TERREUR) THEN INFO(1) = -001 INFO(2) = MSGSOU GO TO 270 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. & (MSGTAG.EQ.TAG_DUMMY) ) THEN GO TO 270 ELSE INFO(1) = -100 INFO(2) = MSGTAG GOTO 260 ENDIF GO TO 270 260 CONTINUE IF (NBFINF .NE. 0) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 270 CONTINUE IF (allocated(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE SMUMPS_BACKSLV_TRAITER_MESSAGE SUBROUTINE SMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, & LEN_PANEL_POS, INDICES, NPIV, & NPANELS, NFRONT_OR_NASS, & NBENTRIES_ALLPANELS) IMPLICIT NONE INTEGER, intent (in) :: PANEL_SIZE, NPIV INTEGER, intent (in) :: INDICES(NPIV) INTEGER, intent (in) :: LEN_PANEL_POS INTEGER, intent (out) :: NPANELS INTEGER, intent (out) :: PANEL_POS(LEN_PANEL_POS) INTEGER, intent (in) :: NFRONT_OR_NASS INTEGER(8), intent(out):: NBENTRIES_ALLPANELS INTEGER NPANELS_MAX, I, NBeff INTEGER(8) :: NBENTRIES_THISPANEL NBENTRIES_ALLPANELS = 0_8 NPANELS_MAX = (NPIV+PANEL_SIZE-1)/PANEL_SIZE IF (LEN_PANEL_POS .LT. NPANELS_MAX + 1) THEN WRITE(*,*) "Error 1 in SMUMPS_BUILD_PANEL_POS", & LEN_PANEL_POS,NPANELS_MAX CALL MUMPS_ABORT() ENDIF I = 1 NPANELS = 0 IF (I .GT. NPIV) RETURN 10 CONTINUE NPANELS = NPANELS + 1 PANEL_POS(NPANELS) = I NBeff = min(PANEL_SIZE, NPIV-I+1) IF ( INDICES(I+NBeff-1) < 0) THEN NBeff=NBeff+1 ENDIF NBENTRIES_THISPANEL = int(NFRONT_OR_NASS-I+1,8) * int(NBeff,8) NBENTRIES_ALLPANELS = NBENTRIES_ALLPANELS + NBENTRIES_THISPANEL I=I+NBeff IF ( I .LE. NPIV ) GOTO 10 PANEL_POS(NPANELS+1)=NPIV+1 RETURN END SUBROUTINE SMUMPS_BUILD_PANEL_POS MUMPS_5.8.1/src/dmumps_lr_data_m.F0000664000175000017500000036725415042446437016675 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_LR_DATA_M USE DMUMPS_LR_TYPE IMPLICIT NONE PRIVATE PUBLIC :: DMUMPS_BLR_END_FRONT, DMUMPS_BLR_INIT_MODULE, & DMUMPS_BLR_END_MODULE, DMUMPS_BLR_INIT_FRONT, & DMUMPS_BLR_SAVE_INIT, & DMUMPS_BLR_SAVE_PANEL_LORU, DMUMPS_BLR_RETRIEVE_BEGS_BLR_L, & DMUMPS_BLR_SAVE_BEGS_BLR_C, DMUMPS_BLR_RETRIEVE_BEGS_BLR_C, & DMUMPS_BLR_DEC_AND_RETRIEVE_L, DMUMPS_BLR_RETRIEVE_PANEL_LORU, & DMUMPS_BLR_DEC_AND_TRYFREE_L, DMUMPS_BLR_TRY_FREE_PANEL, & DMUMPS_BLR_FORCE_FREE_PANEL_L, & DMUMPS_BLR_FREE_CB_LRB, DMUMPS_BLR_FREE_ALL_PANELS, & DMUMPS_BLR_SAVE_CB_LRB, & DMUMPS_BLR_RETRIEVE_CB_LRB, DMUMPS_BLR_RETRIEVE_BEGSBLR_STA, & DMUMPS_BLR_SAVE_BEGS_BLR_DYN, DMUMPS_BLR_RETRIEVE_BEGSBLR_DYN, & DMUMPS_BLR_RETRIEVE_NB_PANELS, DMUMPS_BLR_EMPTY_PANEL_LORU, & DMUMPS_BLR_SAVE_NFS4FATHER, DMUMPS_BLR_RETRIEVE_NFS4FATHER, & DMUMPS_BLR_SAVE_M_ARRAY, DMUMPS_BLR_RETRIEVE_M_ARRAY, & DMUMPS_BLR_FREE_M_ARRAY & , DMUMPS_BLR_STRUC_TO_MOD, DMUMPS_BLR_MOD_TO_STRUC, BLR_ARRAY #if defined(MUMPS_NOF2003) & , BLR_STRUC_T, blr_panel_type, diag_block_type #endif & , DMUMPS_BLR_SAVE_DIAG_BLOCK, DMUMPS_BLR_RETRIEVE_DIAG_BLOCK #if ! defined(NO_SAVE_RESTORE) & , DMUMPS_SAVE_RESTORE_BLR #endif TYPE blr_panel_type integer :: NB_ACCESSES_LEFT type(LRB_TYPE), pointer :: LRB_PANEL(:) END TYPE blr_panel_type TYPE diag_block_type DOUBLE PRECISION, POINTER :: DIAG_BLOCK(:) END TYPE diag_block_type TYPE BLR_STRUC_T LOGICAL :: IsSYM, IsT2, IsSLAVE TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_L TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_U TYPE(LRB_TYPE), pointer :: CB_LRB(:,:) TYPE(diag_block_type), DIMENSION (:), POINTER :: DIAG_BLOCKS INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_STATIC INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_DYNAMIC INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: NB_ACCESSES_INIT INTEGER :: NB_PANELS INTEGER :: NFS4FATHER DOUBLE PRECISION, DIMENSION(:), POINTER :: M_ARRAY END TYPE BLR_STRUC_T type(BLR_STRUC_T), POINTER, DIMENSION(:), SAVE :: BLR_ARRAY TYPE BLR_ARRAY_T type(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY END TYPE BLR_ARRAY_T INTEGER BLR_ARRAY_FREE, PANELS_NOTUSED, PANELS_FREED, & NB_PANELS_NOTINIT, NFS4FATHER_NOTINIT PARAMETER (BLR_ARRAY_FREE=-9999, & PANELS_NOTUSED=-1111, PANELS_FREED=-2222, & NB_PANELS_NOTINIT=-3333, & NFS4FATHER_NOTINIT=-4444 ) #if ! defined(NO_SAVE_RESTORE) INCLUDE 'mumps_save_restore_modes.h' #endif CONTAINS SUBROUTINE DMUMPS_BLR_INIT_MODULE(INITIAL_SIZE, INFO & ) INTEGER, INTENT(IN) :: INITIAL_SIZE INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR ALLOCATE(BLR_ARRAY( INITIAL_SIZE ), stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=INITIAL_SIZE RETURN ENDIF DO I=1, INITIAL_SIZE NULLIFY(BLR_ARRAY(I)%PANELS_L) NULLIFY(BLR_ARRAY(I)%PANELS_U) NULLIFY(BLR_ARRAY(I)%CB_LRB) NULLIFY(BLR_ARRAY(I)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_DYNAMIC) BLR_ARRAY(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY(I)%NB_PANELS = NB_PANELS_NOTINIT NULLIFY(BLR_ARRAY(I)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_COL) BLR_ARRAY(I)%NFS4FATHER = NFS4FATHER_NOTINIT NULLIFY(BLR_ARRAY(I)%M_ARRAY) ENDDO RETURN END SUBROUTINE DMUMPS_BLR_INIT_MODULE SUBROUTINE DMUMPS_BLR_END_MODULE(INFO1, KEEP8, K34 & , LRSOLVE_ACT_OPT & ) INTEGER, INTENT(IN) :: INFO1, K34 LOGICAL, OPTIONAL, INTENT(IN) :: LRSOLVE_ACT_OPT INTEGER(8) :: KEEP8(150) INTEGER :: I, ILOOP IF (.NOT. associated(BLR_ARRAY)) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_END_MODULE" CALL MUMPS_ABORT() ENDIF DO I=1, size(BLR_ARRAY) ILOOP= I IF (associated(BLR_ARRAY(I)%PANELS_L).OR. & associated(BLR_ARRAY(I)%PANELS_U).OR. & associated(BLR_ARRAY(I)%CB_LRB).OR. & associated(BLR_ARRAY(I)%DIAG_BLOCKS) & ) THEN IF (present(LRSOLVE_ACT_OPT)) THEN CALL DMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8, K34 & , LRSOLVE_ACT_OPT & ) ELSE CALL DMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8, K34 ) ENDIF ENDIF ENDDO DEALLOCATE(BLR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE DMUMPS_BLR_END_MODULE SUBROUTINE DMUMPS_BLR_MOD_TO_STRUC(id_BLRARRAY_ENCODING) # if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING # else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING # endif CHARACTER :: CHAR_ARRAY(1) INTEGER :: CHAR_LENGTH, IERR TYPE(BLR_ARRAY_T) :: BLR_ARRAY_VAR IF (associated(id_BLRARRAY_ENCODING)) THEN WRITE(*,*) "Internal error 1 in MUMPS_BLR_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF BLR_ARRAY_VAR%BLR_ARRAY => BLR_ARRAY CHAR_LENGTH=size(transfer(BLR_ARRAY_VAR,CHAR_ARRAY)) ALLOCATE(id_BLRARRAY_ENCODING(CHAR_LENGTH), stat=IERR) IF (IERR > 0 ) THEN WRITE(*,*) "Allocation error in MUMPS_BLR_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF id_BLRARRAY_ENCODING=transfer(BLR_ARRAY_VAR,CHAR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE DMUMPS_BLR_MOD_TO_STRUC SUBROUTINE DMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) # if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING # else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING # endif TYPE (BLR_ARRAY_T) :: BLR_ARRAY_VAR IF (.NOT.associated(id_BLRARRAY_ENCODING)) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_STRUC_TO_MOD" ENDIF BLR_ARRAY_VAR = transfer(id_BLRARRAY_ENCODING,BLR_ARRAY_VAR) BLR_ARRAY => BLR_ARRAY_VAR%BLR_ARRAY DEALLOCATE(id_BLRARRAY_ENCODING) NULLIFY(id_BLRARRAY_ENCODING) RETURN END SUBROUTINE DMUMPS_BLR_STRUC_TO_MOD SUBROUTINE DMUMPS_BLR_INIT_FRONT(IWHANDLER, & INFO, MTK405) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX !$ USE OMP_LIB INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) INTEGER, INTENT(IN), OPTIONAL :: MTK405 TYPE(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY_TMP INTEGER :: OLD_SIZE, NEW_SIZE INTEGER :: I INTEGER :: IERR LOGICAL :: NEEDS_THREAD_SAFETY NEEDS_THREAD_SAFETY = .FALSE. IF (present(MTK405)) THEN IF (MTK405 .EQ. 1 ) THEN NEEDS_THREAD_SAFETY = .TRUE. ENDIF ENDIF IF ( NEEDS_THREAD_SAFETY ) THEN !$OMP CRITICAL(critical_blr_idx) CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) !$OMP END CRITICAL(critical_blr_idx) ELSE CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) ENDIF IF (IWHANDLER > size(BLR_ARRAY)) THEN OLD_SIZE = size(BLR_ARRAY) NEW_SIZE = max( (OLD_SIZE * 3) / 2 + 1, IWHANDLER) ALLOCATE(BLR_ARRAY_TMP(NEW_SIZE),stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=NEW_SIZE GOTO 500 ENDIF DO I=1, OLD_SIZE BLR_ARRAY_TMP(I)=BLR_ARRAY(I) ENDDO DO I=OLD_SIZE+1, NEW_SIZE NULLIFY(BLR_ARRAY_TMP(I)%PANELS_L) NULLIFY(BLR_ARRAY_TMP(I)%PANELS_U) NULLIFY(BLR_ARRAY_TMP(I)%CB_LRB) NULLIFY(BLR_ARRAY_TMP(I)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_DYNAMIC) BLR_ARRAY_TMP(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY_TMP(I)%NB_PANELS = NB_PANELS_NOTINIT NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_L) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_COL) BLR_ARRAY_TMP(I)%NFS4FATHER = NFS4FATHER_NOTINIT NULLIFY(BLR_ARRAY_TMP(I)%M_ARRAY) ENDDO DEALLOCATE(BLR_ARRAY) BLR_ARRAY => BLR_ARRAY_TMP NULLIFY(BLR_ARRAY_TMP) 500 CONTINUE ENDIF RETURN END SUBROUTINE DMUMPS_BLR_INIT_FRONT SUBROUTINE DMUMPS_BLR_SAVE_INIT(IWHANDLER, & IsSYM, IsT2, IsSLAVE, & NB_PANELS, & BEGS_BLR_L, BEGS_BLR_COL, & NB_ACCESSES_INIT, INFO) LOGICAL, INTENT(IN) :: IsSYM, IsT2, IsSLAVE INTEGER, INTENT(IN) :: NB_PANELS, IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: NB_ACCESSES_INIT INTEGER, INTENT(IN), DIMENSION(:) :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: I INTEGER :: IERR IF (NB_PANELS.EQ.0) THEN WRITE(6,*) " Internal error 1 in DMUMPS_BLR_SAVE_INIT ", & NB_PANELS ENDIF IF (IWHANDLER .LE.0 ) THEN WRITE(6,*) " Internal error 2 in DMUMPS_BLR_SAVE_INIT ", & IWHANDLER ENDIF IF (associated(BEGS_BLR_COL)) THEN ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=size(BEGS_BLR_COL) RETURN ENDIF ENDIF IF (NB_ACCESSES_INIT.EQ.0) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=3*size(BEGS_BLR_L) RETURN ENDIF ELSE IF (IsSYM) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & stat=IERR) ELSE ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%PANELS_U(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & stat=IERR) ENDIF IF (IERR .GT. 0) THEN INFO(1)=-13 IF (IsSYM) THEN INFO(2)=NB_PANELS+3*size(BEGS_BLR_L) ELSE INFO(2)=NB_PANELS+NB_PANELS+3*size(BEGS_BLR_L) ENDIF RETURN ENDIF IF (.NOT.IsSLAVE) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(NB_PANELS), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=NB_PANELS RETURN ENDIF ENDIF DO I=1,NB_PANELS NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L(I)%LRB_PANEL) IF (.NOT.IsSYM) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U(I)%LRB_PANEL) ENDIF IF (.NOT.IsSLAVE) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(I)%DIAG_BLOCK) ENDIF ENDDO ENDIF BLR_ARRAY(IWHANDLER)%IsSYM = IsSYM BLR_ARRAY(IWHANDLER)%IsT2 = IsT2 BLR_ARRAY(IWHANDLER)%IsSLAVE = IsSLAVE BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS BLR_ARRAY(IWHANDLER)%BEGS_BLR_L = BEGS_BLR_L BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC = BEGS_BLR_L BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC = -999991 IF (NB_ACCESSES_INIT.EQ.0) THEN BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = PANELS_NOTUSED ELSE BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = NB_ACCESSES_INIT ENDIF IF (associated(BEGS_BLR_COL)) THEN DO I=1,size(BEGS_BLR_COL) BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) ENDDO ELSE NULLIFY( BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL ) ENDIF RETURN END SUBROUTINE DMUMPS_BLR_SAVE_INIT SUBROUTINE DMUMPS_BLR_END_FRONT(IWHANDLER, INFO1, KEEP8, K34 & , LRSOLVE_ACT_OPT, MTK405 ) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX INTEGER, INTENT(INOUT) :: IWHANDLER INTEGER, INTENT(IN) :: INFO1 INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: K34 LOGICAL, OPTIONAL, INTENT(IN) :: LRSOLVE_ACT_OPT INTEGER, OPTIONAL, INTENT(IN) :: MTK405 INTEGER :: IPANEL, JPANEL INTEGER(8) :: MEM_FREED INTEGER :: IDUMMY, JDUMMY TYPE(blr_panel_type), POINTER :: THEPANEL LOGICAL :: LRSOLVE_ACT, NEEDS_THREAD_SAFETY TYPE(diag_block_type), POINTER :: THEBLOCK LRSOLVE_ACT = .FALSE. IF (present(LRSOLVE_ACT_OPT)) LRSOLVE_ACT = LRSOLVE_ACT_OPT IF (IWHANDLER.LE.0) THEN RETURN ENDIF NEEDS_THREAD_SAFETY = .FALSE. IF (present(MTK405)) THEN IF (MTK405 .EQ. 1 ) THEN NEEDS_THREAD_SAFETY = .TRUE. ENDIF ENDIF IF (IWHANDLER .GT. size(BLR_ARRAY)) THEN RETURN END IF IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ.BLR_ARRAY_FREE) & RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.NE. & PANELS_NOTUSED) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 2a in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated", & " NB_ACCESSES_LEFT= ",THEPANEL%NB_ACCESSES_LEFT CALL MUMPS_ABORT() ELSE CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDDO IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 2b in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated" CALL MUMPS_ABORT() ELSE CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDDO IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN MEM_FREED = 0_8 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) THEBLOCK => BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL) IF (associated(THEBLOCK%DIAG_BLOCK)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 3 in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated" CALL MUMPS_ABORT() ENDIF MEM_FREED = MEM_FREED + int(size(THEBLOCK%DIAG_BLOCK),8) DEALLOCATE (THEBLOCK%DIAG_BLOCK) NULLIFY (THEBLOCK%DIAG_BLOCK) ENDIF ENDDO IF ( MEM_FREED .GT. 0_8 ) THEN CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-MEM_FREED, & NEEDS_THREAD_SAFETY, KEEP8, & IDUMMY, JDUMMY, & .TRUE., .TRUE.) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsT2.OR. & BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN IF (associated(BLR_ARRAY(IWHANDLER)%CB_LRB)) THEN IF (INFO1 .GE. 0) THEN WRITE(*,*) & " Internal Error 4 in MUMPS_BLR_END_FRONT ", & IWHANDLER, "CB block still associated", & BLR_ARRAY(IWHANDLER)%IsT2, & BLR_ARRAY(IWHANDLER)%IsSLAVE CALL MUMPS_ABORT() ELSE DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%CB_LRB,1) DO JPANEL = 1, size(BLR_ARRAY(IWHANDLER)%CB_LRB,2) CALL DEALLOC_LRB( & BLR_ARRAY(IWHANDLER)%CB_LRB(IPANEL,JPANEL), & KEEP8, K34) ENDDO ENDDO DEALLOCATE(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) ENDIF ENDIF ENDIF ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) ENDIF BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS_NOTINIT BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER_NOTINIT IF (associated(BLR_ARRAY(IWHANDLER)%M_ARRAY)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY) NULLIFY(BLR_ARRAY(IWHANDLER)%M_ARRAY) ENDIF IF (NEEDS_THREAD_SAFETY) THEN !$OMP CRITICAL(critical_blr_idx) CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) !$OMP END CRITICAL(critical_blr_idx) ELSE CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) ENDIF RETURN END SUBROUTINE DMUMPS_BLR_END_FRONT SUBROUTINE DMUMPS_BLR_SAVE_PANEL_LORU ( & IWHANDLER, LORU, IPANEL, LRB_PANEL, NB_ACCESSES_INIT_IN ) type(LRB_TYPE), DIMENSION(:), pointer :: LRB_PANEL INTEGER, INTENT(IN) :: IWHANDLER, IPANEL, NB_ACCESSES_INIT_IN INTEGER, INTENT(IN) :: LORU TYPE(blr_panel_type), POINTER :: THEPANEL IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_SAVE_PANEL_LORU" CALL MUMPS_ABORT() ENDIF IF (LORU.EQ.0) THEN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) ELSE THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) ENDIF IF (NB_ACCESSES_INIT_IN.GT.0) THEN THEPANEL%NB_ACCESSES_LEFT = NB_ACCESSES_INIT_IN ELSE THEPANEL%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT ENDIF THEPANEL%LRB_PANEL => LRB_PANEL RETURN END SUBROUTINE DMUMPS_BLR_SAVE_PANEL_LORU SUBROUTINE DMUMPS_BLR_SAVE_CB_LRB ( & IWHANDLER, CB_LRB ) #if defined(MUMPS_NOF2003) TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) #else TYPE(LRB_TYPE), POINTER, INTENT(IN) :: CB_LRB(:,:) #endif INTEGER, INTENT(IN) :: IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_SAVE_CB_LRB" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%CB_LRB => CB_LRB RETURN END SUBROUTINE DMUMPS_BLR_SAVE_CB_LRB SUBROUTINE DMUMPS_BLR_SAVE_DIAG_BLOCK ( & IWHANDLER, IPANEL, D, KEEP34 ) use iso_c_binding DOUBLE PRECISION,POINTER :: D(:) INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER, INTENT(IN) :: KEEP34 IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_SAVE_DIAG_BLOCK" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in DMUMPS_BLR_SAVE_DIAG_BLOCK" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK => D RETURN END SUBROUTINE DMUMPS_BLR_SAVE_DIAG_BLOCK SUBROUTINE DMUMPS_BLR_SAVE_BEGS_BLR_C ( & IWHANDLER, BEGS_BLR_COL, INFO) INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_SAVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in DMUMPS_BLR_SAVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF ALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=size(BEGS_BLR_COL) RETURN ENDIF DO I=1,size(BEGS_BLR_COL) BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) ENDDO RETURN END SUBROUTINE DMUMPS_BLR_SAVE_BEGS_BLR_C SUBROUTINE DMUMPS_BLR_SAVE_BEGS_BLR_DYN ( & IWHANDLER, BEGS_BLR_DYNAMIC ) INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_DYNAMIC INTEGER, INTENT(IN) :: IWHANDLER INTEGER :: I IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_SAVE_BEGS_BLR_DYN" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in DMUMPS_BLR_SAVE_BEGS_BLR_DYN" CALL MUMPS_ABORT() ENDIF DO I=1,size(BEGS_BLR_DYNAMIC) BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(I) = BEGS_BLR_DYNAMIC(I) ENDDO RETURN END SUBROUTINE DMUMPS_BLR_SAVE_BEGS_BLR_DYN SUBROUTINE DMUMPS_BLR_RETRIEVE_BEGS_BLR_L & ( IWHANDLER, BEGS_BLR_L ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_BEGS_BLR_L" CALL MUMPS_ABORT() ENDIF BEGS_BLR_L => BLR_ARRAY(IWHANDLER)%BEGS_BLR_L RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_BEGS_BLR_L SUBROUTINE DMUMPS_BLR_RETRIEVE_BEGSBLR_STA & ( IWHANDLER, BEGS_BLR_STATIC ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_STATIC #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_BEGSBLR_STA" CALL MUMPS_ABORT() ENDIF BEGS_BLR_STATIC => BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_BEGSBLR_STA SUBROUTINE DMUMPS_BLR_RETRIEVE_BEGSBLR_DYN & ( IWHANDLER, BEGS_BLR_DYNAMIC ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_DYNAMIC #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_DYNAMIC #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_BEGSBLR_DYN" CALL MUMPS_ABORT() ENDIF BEGS_BLR_DYNAMIC => BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_BEGSBLR_DYN SUBROUTINE DMUMPS_BLR_RETRIEVE_BEGS_BLR_C & ( IWHANDLER, BEGS_BLR_COL, NB_PANELS ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NB_PANELS #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_COL #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_COL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF BEGS_BLR_COL => BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_BEGS_BLR_C SUBROUTINE DMUMPS_BLR_RETRIEVE_NB_PANELS & ( IWHANDLER, NB_PANELS ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NB_PANELS IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_NB_PANELS" CALL MUMPS_ABORT() ENDIF NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_NB_PANELS SUBROUTINE DMUMPS_BLR_DEC_AND_RETRIEVE_L(IWHANDLER, IPANEL, & BEGS_BLR_L, THELRBPANEL, & NBDEC ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: IPANEL, NBDEC #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) "Internal error 2 in DMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) "Internal error 3 in DMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_L( IWHANDLER, BEGS_BLR_L ) THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - NBDEC RETURN END SUBROUTINE DMUMPS_BLR_DEC_AND_RETRIEVE_L LOGICAL FUNCTION DMUMPS_BLR_EMPTY_PANEL_LORU & (IWHANDLER, LorU, IPANEL) INTEGER, INTENT(IN) :: LorU, IPANEL, IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF (LorU.EQ.0) THEN IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) & "Internal error 2 in DMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF DMUMPS_BLR_EMPTY_PANEL_LORU = .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 3 in DMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF DMUMPS_BLR_EMPTY_PANEL_LORU = .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ENDIF RETURN END FUNCTION DMUMPS_BLR_EMPTY_PANEL_LORU SUBROUTINE DMUMPS_BLR_RETRIEVE_PANEL_LORU & (IWHANDLER, LORU, IPANEL, & THELRBPANEL) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: LORU INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_NOF2003) TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL #else TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF (LORU.EQ.0) THEN IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) & "Internal error 2 in DMUMPS_BLR_RETRIEVE_PANEL_LORU", & " IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) & "Internal error 3 in DMUMPS_BLR_RETRIEVE_PANEL_LORU", & " IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 4 in DMUMPS_BLR_RETRIEVE_PANEL_LORU", & " IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) & "Internal error 5 in DMUMPS_BLR_RETRIEVE_PANEL_LORU", & " IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL ENDIF RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_PANEL_LORU SUBROUTINE DMUMPS_BLR_RETRIEVE_DIAG_BLOCK & (IWHANDLER, IPANEL, & THEBLOCK) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_NOF2003) DOUBLE PRECISION, POINTER :: THEBLOCK(:) #else DOUBLE PRECISION, POINTER, INTENT(OUT) :: THEBLOCK(:) #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN WRITE(*,*) & "Internal error 2 in DMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK)) & THEN WRITE(*,*) & "Internal error 3 in DMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THEBLOCK => & BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_DIAG_BLOCK SUBROUTINE DMUMPS_BLR_RETRIEVE_CB_LRB & (IWHANDLER, THECB) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) TYPE(LRB_TYPE), POINTER :: THECB(:,:) #else TYPE(LRB_TYPE), POINTER, INTENT(OUT) :: THECB(:,:) #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_RETRIEVE_CB_LRB" CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%CB_LRB)) THEN WRITE(*,*) "Internal error 2 in DMUMPS_BLR_RETRIEVE_CB_LRB" CALL MUMPS_ABORT() ENDIF THECB => BLR_ARRAY(IWHANDLER)%CB_LRB RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_CB_LRB SUBROUTINE DMUMPS_BLR_SAVE_NFS4FATHER & ( IWHANDLER, NFS4FATHER ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: NFS4FATHER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_NFS4FATHER" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER RETURN END SUBROUTINE DMUMPS_BLR_SAVE_NFS4FATHER SUBROUTINE DMUMPS_BLR_RETRIEVE_NFS4FATHER & ( IWHANDLER, NFS4FATHER ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NFS4FATHER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_NFS4FATHER" CALL MUMPS_ABORT() ENDIF NFS4FATHER = BLR_ARRAY(IWHANDLER)%NFS4FATHER RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_NFS4FATHER SUBROUTINE DMUMPS_BLR_SAVE_M_ARRAY ( & IWHANDLER, M_ARRAY, INFO) DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: M_ARRAY INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_SAVE_M_ARRAY" CALL MUMPS_ABORT() ENDIF ALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY(size(M_ARRAY)), & stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=size(M_ARRAY) RETURN ENDIF DO I=1,size(M_ARRAY) BLR_ARRAY(IWHANDLER)%M_ARRAY(I) = M_ARRAY(I) ENDDO BLR_ARRAY(IWHANDLER)%NFS4FATHER = size(M_ARRAY) RETURN END SUBROUTINE DMUMPS_BLR_SAVE_M_ARRAY SUBROUTINE DMUMPS_BLR_RETRIEVE_M_ARRAY ( IWHANDLER, M_ARRAY) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) DOUBLE PRECISION, DIMENSION(:), POINTER :: M_ARRAY #else DOUBLE PRECISION, DIMENSION(:), POINTER, INTENT(OUT) :: M_ARRAY #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_RETRIEVE_M_ARRAY" CALL MUMPS_ABORT() ENDIF M_ARRAY => BLR_ARRAY(IWHANDLER)%M_ARRAY RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_M_ARRAY SUBROUTINE DMUMPS_BLR_FREE_M_ARRAY ( IWHANDLER ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_FREE_M_ARRAY" CALL MUMPS_ABORT() ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%M_ARRAY)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY) NULLIFY(BLR_ARRAY(IWHANDLER)%M_ARRAY) ENDIF BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER_NOTINIT RETURN END SUBROUTINE DMUMPS_BLR_FREE_M_ARRAY SUBROUTINE DMUMPS_BLR_DEC_AND_TRYFREE_L( IWHANDLER, IPANEL, & KEEP8, K34, NBDEC) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL, K34, NBDEC INTEGER(8) :: KEEP8(150) IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) & RETURN BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - NBDEC CALL DMUMPS_BLR_TRY_FREE_PANEL (IWHANDLER, IPANEL, & KEEP8, K34) RETURN END SUBROUTINE DMUMPS_BLR_DEC_AND_TRYFREE_L SUBROUTINE DMUMPS_BLR_FORCE_FREE_PANEL_L( IWHANDLER, IPANEL, & KEEP8, K34 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: K34 TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) & RETURN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED RETURN END SUBROUTINE DMUMPS_BLR_FORCE_FREE_PANEL_L SUBROUTINE DMUMPS_BLR_TRY_FREE_PANEL( IWHANDLER, IPANEL, & KEEP8, K34 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: K34 TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0.OR. & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.eq.huge(IPANEL) ) & RETURN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF ( THEPANEL%NB_ACCESSES_LEFT .EQ. 0 ) THEN IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF RETURN END SUBROUTINE DMUMPS_BLR_TRY_FREE_PANEL SUBROUTINE DMUMPS_BLR_FREE_CB_LRB ( IWHANDLER, FREE_ONLY_STRUCT, & KEEP8, K34 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, K34 LOGICAL, INTENT(IN) :: FREE_ONLY_STRUCT INTEGER(8) :: KEEP8(150) TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER :: IPANEL, JPANEL TYPE(LRB_TYPE), POINTER :: THELRB IF (BLR_ARRAY(IWHANDLER)%IsT2.AND. & .NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN write(*,*) 'Internal error 1 in DMUMPS_BLR_FREE_CB_LRB' CALL MUMPS_ABORT() ENDIF CB_LRB => BLR_ARRAY(IWHANDLER)%CB_LRB IF (.NOT.associated(CB_LRB)) THEN write(*,*) 'Internal error 2 in DMUMPS_BLR_FREE_CB_LRB' CALL MUMPS_ABORT() ENDIF IF (.NOT.FREE_ONLY_STRUCT) THEN DO IPANEL = 1,size(CB_LRB,1) DO JPANEL = 1,size(CB_LRB,2) THELRB => CB_LRB(IPANEL,JPANEL) IF (associated(THELRB)) THEN CALL DEALLOC_LRB(THELRB, KEEP8, K34) ENDIF ENDDO ENDDO ENDIF DEALLOCATE(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) RETURN END SUBROUTINE DMUMPS_BLR_FREE_CB_LRB SUBROUTINE DMUMPS_BLR_FREE_ALL_PANELS ( IWHANDLER, & LorU, KEEP8, K34) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, LorU, K34 INTEGER(8) :: KEEP8(150) INTEGER :: IPANEL INTEGER :: IDUMMY, JDUMMY TYPE(blr_panel_type), POINTER :: THEPANEL TYPE(diag_block_type), POINTER :: THEBLOCK INTEGER(8) :: MEM_FREED IF (IWHANDLER.LE.0) RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ. & PANELS_NOTUSED) RETURN IF (LorU.EQ.0.OR.LorU.EQ.2) THEN IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF ENDIF IF (LorU.GE.1.AND..NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF ENDIF IF (LorU.GE.1.AND..NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN IF (associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN MEM_FREED = 0_8 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) THEBLOCK => BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL) IF (associated(THEBLOCK%DIAG_BLOCK)) THEN MEM_FREED = MEM_FREED + int(size(THEBLOCK%DIAG_BLOCK),8) DEALLOCATE(THEBLOCK%DIAG_BLOCK) NULLIFY (THEBLOCK%DIAG_BLOCK) ENDIF ENDDO IF (MEM_FREED .GT. 0 ) THEN CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-MEM_FREED, & .TRUE., KEEP8, & IDUMMY, JDUMMY, & .TRUE., .TRUE.) ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_BLR_FREE_ALL_PANELS #if ! defined(NO_SAVE_RESTORE) SUBROUTINE DMUMPS_SAVE_RESTORE_BLR(id_BLRARRAY_ENCODING & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: j1,NbRecords,NbSubRecords,size_array1,dummy,allocok,err INTEGER:: SIZE_GEST_BLR_ARRAY,SIZE_GEST_BLR_ARRAY_j1 INTEGER(8):: SIZE_VARIABLES_BLR_ARRAY,SIZE_VARIABLES_BLR_ARRAY_j1 INTEGER(4) :: I4 NbRecords=0 SIZE_GEST_BLR_ARRAY=0 SIZE_GEST_BLR_ARRAY_j1=0 SIZE_VARIABLES_BLR_ARRAY=0_8 SIZE_VARIABLES_BLR_ARRAY_j1=0_8 SIZE_GEST=0 SIZE_VARIABLES=0_8 if(mode.EQ.memory_save_mode.OR.mode.EQ.save_mode) then call DMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) endif if(mode.EQ.memory_save_mode) then IF(associated(BLR_ARRAY)) THEN NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 DO j1=1,size(BLR_ARRAY,1) CALL DMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_BLR_ARRAY=SIZE_GEST_BLR_ARRAY+ & SIZE_GEST_BLR_ARRAY_j1 SIZE_VARIABLES_BLR_ARRAY=SIZE_VARIABLES_BLR_ARRAY+ & SIZE_VARIABLES_BLR_ARRAY_j1 ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_ARRAY)) THEN NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 write(unit,iostat=err) size(BLR_ARRAY,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 DO j1=1,size(BLR_ARRAY,1) CALL DMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_ARRAY) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 allocate(BLR_ARRAY(size_array1), stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL DMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_BLR_ARRAY=SIZE_GEST_BLR_ARRAY+ & SIZE_GEST_BLR_ARRAY_j1 SIZE_VARIABLES_BLR_ARRAY=SIZE_VARIABLES_BLR_ARRAY+ & SIZE_VARIABLES_BLR_ARRAY_j1 ENDDO endif endif if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(mode.EQ.memory_save_mode) then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_BLR_ARRAY SIZE_GEST=SIZE_GEST+SIZE_GEST_BLR_ARRAY #if defined(MUMPS_NOF2003) SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif call DMUMPS_BLR_MOD_TO_STRUC(id_BLRARRAY_ENCODING) 100 continue RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_BLR SUBROUTINE DMUMPS_SAVE_RESTORE_BLR_STRUC(BLR_STRUC & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(BLR_STRUC_T) :: BLR_STRUC INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER, PARAMETER :: NBVARIABLES_BLR_STRUC_T = 15 INTEGER, PARAMETER :: B_IsSYM=1 INTEGER, PARAMETER :: B_IsT2=2 INTEGER, PARAMETER :: B_IsSLAVE=3 INTEGER, PARAMETER :: B_PANELS_L=4 INTEGER, PARAMETER :: B_PANELS_U=5 INTEGER, PARAMETER :: B_CB_LRB=6 INTEGER, PARAMETER :: B_DIAG_BLOCKS=7 INTEGER, PARAMETER :: B_BEGS_BLR_STATIC=8 INTEGER, PARAMETER :: B_BEGS_BLR_DYNAMIC=9 INTEGER, PARAMETER :: B_BEGS_BLR_L=10 INTEGER, PARAMETER :: B_BEGS_BLR_COL=11 INTEGER, PARAMETER :: B_NB_ACCESSES_INIT=12 INTEGER, PARAMETER :: B_NB_PANELS=13 INTEGER, PARAMETER :: B_NFS4FATHER=14 INTEGER, PARAMETER :: B_M_ARRAY=15 INTEGER(8),dimension(NBVARIABLES_BLR_STRUC_T):: & SIZE_VARIABLES_BLR_STRUC_T INTEGER,dimension(NBVARIABLES_BLR_STRUC_T)::SIZE_GEST_BLR_STRUC_T INTEGER,dimension(NBVARIABLES_BLR_STRUC_T)::NbRecords_BLR_STRUC_T INTEGER:: size_array1,size_array2,dummy,allocok INTEGER:: err,i1,j1,j2,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER::SIZE_GEST_PANELS_L,SIZE_GEST_PANELS_L_j1 INTEGER(8)::SIZE_VARIABLES_PANELS_L,SIZE_VARIABLES_PANELS_L_j1 INTEGER::SIZE_GEST_PANELS_U,SIZE_GEST_PANELS_U_j1 INTEGER(8)::SIZE_VARIABLES_PANELS_U,SIZE_VARIABLES_PANELS_U_j1 INTEGER::SIZE_GEST_CB_LRB,SIZE_GEST_CB_LRB_j1j2 INTEGER(8)::SIZE_VARIABLES_CB_LRB,SIZE_VARIABLES_CB_LRB_j1j2 INTEGER::SIZE_GEST_DIAG_BLOCKS,SIZE_GEST_DIAG_BLOCKS_j1 INTEGER(8)::SIZE_VARIABLES_DIAG_BLOCKS INTEGER(8)::SIZE_VARIABLES_DIAG_BLOCKS_j1 INTEGER(4)::I4 SIZE_VARIABLES_BLR_STRUC_T(:)=0_8 SIZE_GEST_BLR_STRUC_T(:)=0 NbRecords_BLR_STRUC_T(:)=0 SIZE_GEST_PANELS_L=0 SIZE_GEST_PANELS_L_j1=0 SIZE_VARIABLES_PANELS_L=0_8 SIZE_VARIABLES_PANELS_L_j1=0_8 SIZE_GEST_PANELS_U=0 SIZE_GEST_PANELS_U_j1=0 SIZE_VARIABLES_PANELS_U=0_8 SIZE_VARIABLES_PANELS_U_j1=0_8 SIZE_GEST_CB_LRB=0 SIZE_GEST_CB_LRB_j1j2=0 SIZE_VARIABLES_CB_LRB=0_8 SIZE_VARIABLES_CB_LRB_j1j2=0_8 SIZE_GEST_DIAG_BLOCKS=0 SIZE_GEST_DIAG_BLOCKS_j1=0 SIZE_VARIABLES_DIAG_BLOCKS=0_8 SIZE_VARIABLES_DIAG_BLOCKS_j1=0_8 DO i1=1,NBVARIABLES_BLR_STRUC_T SELECT CASE(i1) CASE(B_IsSYM) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsSYM if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsSYM if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_IsT2) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsT2 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsT2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_IsSLAVE) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsSLAVE if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsSLAVE if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_BEGS_BLR_STATIC) NbRecords_BLR_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_STATIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_STATIC,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_STATIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_STATIC,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_STATIC,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_STATIC ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%BEGS_BLR_STATIC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_STATIC(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_STATIC endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_BEGS_BLR_DYNAMIC) NbRecords_BLR_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_DYNAMIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_DYNAMIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_DYNAMIC ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%BEGS_BLR_DYNAMIC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_DYNAMIC(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_DYNAMIC endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_BEGS_BLR_L) NbRecords_BLR_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_L)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_L,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_L)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_L,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_L,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_L ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%BEGS_BLR_L) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_L(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_L endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_BEGS_BLR_COL) NbRecords_BLR_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_COL)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_COL,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_COL)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_COL,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_COL,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_COL ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%BEGS_BLR_COL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_COL(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_COL endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_NB_ACCESSES_INIT) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NB_ACCESSES_INIT if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NB_ACCESSES_INIT if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_NB_PANELS) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NB_PANELS if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NB_PANELS if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_PANELS_L) if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%PANELS_L)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%PANELS_L,1) CALL DMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_L=SIZE_GEST_PANELS_L+ & SIZE_GEST_PANELS_L_j1 SIZE_VARIABLES_PANELS_L=SIZE_VARIABLES_PANELS_L+ & SIZE_VARIABLES_PANELS_L_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%PANELS_L)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%PANELS_L,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%PANELS_L,1) CALL DMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%PANELS_L) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%PANELS_L(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL DMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_L=SIZE_GEST_PANELS_L+ & SIZE_GEST_PANELS_L_j1 SIZE_VARIABLES_PANELS_L=SIZE_VARIABLES_PANELS_L+ & SIZE_VARIABLES_PANELS_L_j1 ENDDO endif endif CASE(B_PANELS_U) if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%PANELS_U)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%PANELS_U,1) CALL DMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_U=SIZE_GEST_PANELS_U+ & SIZE_GEST_PANELS_U_j1 SIZE_VARIABLES_PANELS_U=SIZE_VARIABLES_PANELS_U+ & SIZE_VARIABLES_PANELS_U_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%PANELS_U)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%PANELS_U,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%PANELS_U,1) CALL DMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%PANELS_U) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%PANELS_U(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL DMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_U=SIZE_GEST_PANELS_U+ & SIZE_GEST_PANELS_U_j1 SIZE_VARIABLES_PANELS_U=SIZE_VARIABLES_PANELS_U+ & SIZE_VARIABLES_PANELS_U_j1 ENDDO endif endif CASE(B_CB_LRB) if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%CB_LRB)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%CB_LRB,1) DO j2=1,size(BLR_STRUC%CB_LRB,2) CALL DMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_CB_LRB=SIZE_GEST_CB_LRB+ & SIZE_GEST_CB_LRB_j1j2 SIZE_VARIABLES_CB_LRB=SIZE_VARIABLES_CB_LRB+ & SIZE_VARIABLES_CB_LRB_j1j2 ENDDO ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%CB_LRB)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%CB_LRB,1),size(BLR_STRUC%CB_LRB,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%CB_LRB,1) DO j2=1,size(BLR_STRUC%CB_LRB,2) CALL DMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,save_mode & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%CB_LRB) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%CB_LRB(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 DO j2=1,size_array2 CALL DMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,restore_mode & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_CB_LRB=SIZE_GEST_CB_LRB+ & SIZE_GEST_CB_LRB_j1j2 SIZE_VARIABLES_CB_LRB=SIZE_VARIABLES_CB_LRB+ & SIZE_VARIABLES_CB_LRB_j1j2 ENDDO ENDDO endif endif CASE(B_DIAG_BLOCKS) if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%DIAG_BLOCKS)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%DIAG_BLOCKS,1) CALL DMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_DIAG_BLOCKS=SIZE_GEST_DIAG_BLOCKS+ & SIZE_GEST_DIAG_BLOCKS_j1 SIZE_VARIABLES_DIAG_BLOCKS= & SIZE_VARIABLES_DIAG_BLOCKS+ & SIZE_VARIABLES_DIAG_BLOCKS_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%DIAG_BLOCKS)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%DIAG_BLOCKS,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%DIAG_BLOCKS,1) CALL DMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%DIAG_BLOCKS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%DIAG_BLOCKS(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL DMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_DIAG_BLOCKS=SIZE_GEST_DIAG_BLOCKS+ & SIZE_GEST_DIAG_BLOCKS_j1 SIZE_VARIABLES_DIAG_BLOCKS= & SIZE_VARIABLES_DIAG_BLOCKS+ & SIZE_VARIABLES_DIAG_BLOCKS_j1 ENDDO endif endif CASE(B_NFS4FATHER) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NFS4FATHER if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NFS4FATHER if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_M_ARRAY) if(mode.EQ.restore_mode) then nullify(BLR_STRUC%M_ARRAY) endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_BLR_STRUC_T(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_BLR_STRUC_T(i1)=NbRecords_BLR_STRUC_T(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_BLR_STRUC_T(i1) & +int(SIZE_GEST_BLR_STRUC_T(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_BLR_STRUC_T(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_BLR_STRUC_T(i1) size_read=size_read+SIZE_VARIABLES_BLR_STRUC_T(i1) & +int(SIZE_GEST_BLR_STRUC_T(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_BLR_STRUC_T(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_BLR_STRUC_T) & +SIZE_VARIABLES_PANELS_L & +SIZE_VARIABLES_PANELS_U & +SIZE_VARIABLES_CB_LRB & +SIZE_VARIABLES_DIAG_BLOCKS Local_SIZE_GEST=sum(SIZE_GEST_BLR_STRUC_T) & +SIZE_GEST_PANELS_L & +SIZE_GEST_PANELS_U & +SIZE_GEST_CB_LRB & +SIZE_GEST_DIAG_BLOCKS #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_BLR_STRUC_T) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 100 continue RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_BLR_STRUC SUBROUTINE DMUMPS_SAVE_RESTORE_LRB(LRB_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(LRB_TYPE) :: LRB_T INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER, PARAMETER :: LRB_Q=1 INTEGER, PARAMETER :: LRB_R=2 INTEGER, PARAMETER :: LRB_K=3 INTEGER, PARAMETER :: LRB_M=4 INTEGER, PARAMETER :: LRB_N=5 INTEGER, PARAMETER :: LRB_ISLR=6 INTEGER, PARAMETER :: NBVARIABLES_LRB_TYPE=6 INTEGER(8),dimension(NBVARIABLES_LRB_TYPE):: & SIZE_VARIABLES_LRB_TYPE INTEGER,dimension(NBVARIABLES_LRB_TYPE):: & SIZE_GEST_LRB_TYPE INTEGER,dimension(NBVARIABLES_LRB_TYPE):: & NbRecords_LRB_TYPE INTEGER:: size_array1,size_array2,dummy,allocok INTEGER:: err,i1,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER(4) ::I4 SIZE_VARIABLES_LRB_TYPE(:)=0_8 SIZE_GEST_LRB_TYPE(:)=0 NbRecords_LRB_TYPE(:)=0 DO i1=1,NBVARIABLES_LRB_TYPE SELECT CASE(i1) CASE(LRB_Q) NbRecords_LRB_TYPE(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(LRB_T%Q)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%Q,1)*size(LRB_T%Q,2) & * SIZE_ARITH_DEP ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(LRB_T%Q)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%Q,1)*size(LRB_T%Q,2) & * SIZE_ARITH_DEP write(unit,iostat=err) size(LRB_T%Q,1),size(LRB_T%Q,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) LRB_T%Q ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then nullify(LRB_T%Q) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(size_array1.EQ.-999) then SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size_array1*size_array2*SIZE_ARITH_DEP allocate(LRB_T%Q(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) LRB_T%Q endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_R) NbRecords_LRB_TYPE(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(LRB_T%R)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%R,1)*size(LRB_T%R,2) & * SIZE_ARITH_DEP ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(LRB_T%R)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%R,1)*size(LRB_T%R,2) & * SIZE_ARITH_DEP write(unit,iostat=err) size(LRB_T%R,1),size(LRB_T%R,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) LRB_T%R ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then nullify(LRB_T%R) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(size_array1.EQ.-999) then SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size_array1*size_array2*SIZE_ARITH_DEP allocate(LRB_T%R(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) LRB_T%R endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_K) NbRecords_LRB_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%K if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%K if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_M) NbRecords_LRB_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%M if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%M if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_N) NbRecords_LRB_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%N if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%N if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_ISLR) NbRecords_LRB_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL write(unit,iostat=err) LRB_T%ISLR if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL read(unit,iostat=err) LRB_T%ISLR if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_LRB_TYPE(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_LRB_TYPE(i1)= & NbRecords_LRB_TYPE(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_LRB_TYPE(i1) & +int(SIZE_GEST_LRB_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_LRB_TYPE(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_LRB_TYPE(i1) size_read=size_read+SIZE_VARIABLES_LRB_TYPE(i1) & +int(SIZE_GEST_LRB_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_LRB_TYPE(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_LRB_TYPE) Local_SIZE_GEST=sum(SIZE_GEST_LRB_TYPE) #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_LRB_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 300 continue RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_LRB SUBROUTINE DMUMPS_SAVE_RESTORE_BLR_PANEL(BLR_PANEL_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(blr_panel_type) :: BLR_PANEL_T INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER, PARAMETER :: P_NB_ACCESSES_LEFT=1 INTEGER, PARAMETER :: P_LRB_PANEL=2 INTEGER, PARAMETER :: NBVARIABLES_BLR_PANEL_TYPE = 2 INTEGER(8),dimension(NBVARIABLES_BLR_PANEL_TYPE):: & SIZE_VARIABLES_BLR_PANEL_TYPE INTEGER,dimension(NBVARIABLES_BLR_PANEL_TYPE):: & SIZE_GEST_BLR_PANEL_TYPE INTEGER,dimension(NBVARIABLES_BLR_PANEL_TYPE):: & NbRecords_BLR_PANEL_TYPE INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,j1,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER:: SIZE_GEST_LRB_PANEL_j1,SIZE_GEST_LRB_PANEL INTEGER(8)::SIZE_VARIABLES_LRB_PANEL_j1,SIZE_VARIABLES_LRB_PANEL INTEGER(4)::I4 SIZE_VARIABLES_BLR_PANEL_TYPE(:)=0_8 SIZE_GEST_BLR_PANEL_TYPE(:)=0 NbRecords_BLR_PANEL_TYPE(:)=0 SIZE_GEST_LRB_PANEL_j1=0 SIZE_GEST_LRB_PANEL=0 SIZE_VARIABLES_LRB_PANEL_j1=0_8 SIZE_VARIABLES_LRB_PANEL=0_8 DO i1=1,NBVARIABLES_BLR_PANEL_TYPE SELECT CASE(i1) CASE(P_NB_ACCESSES_LEFT) NbRecords_BLR_PANEL_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT write(unit,iostat=err) BLR_PANEL_T%NB_ACCESSES_LEFT if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT read(unit,iostat=err) BLR_PANEL_T%NB_ACCESSES_LEFT if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 endif CASE(P_LRB_PANEL) if(mode.EQ.memory_save_mode) then IF(associated(BLR_PANEL_T%LRB_PANEL)) THEN NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 DO j1=1,size(BLR_PANEL_T%LRB_PANEL,1) CALL DMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_LRB_PANEL=SIZE_GEST_LRB_PANEL+ & SIZE_GEST_LRB_PANEL_j1 SIZE_VARIABLES_LRB_PANEL=SIZE_VARIABLES_LRB_PANEL+ & SIZE_VARIABLES_LRB_PANEL_j1 ENDDO ELSE NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_PANEL_T%LRB_PANEL)) THEN NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 write(unit,iostat=err) size(BLR_PANEL_T%LRB_PANEL,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 DO j1=1,size(BLR_PANEL_T%LRB_PANEL,1) CALL DMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 400 ENDDO ELSE NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_PANEL_T%LRB_PANEL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 if(size_array1.EQ.-999) then NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 else NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 allocate(BLR_PANEL_T%LRB_PANEL(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL DMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_LRB_PANEL=SIZE_GEST_LRB_PANEL+ & SIZE_GEST_LRB_PANEL_j1 SIZE_VARIABLES_LRB_PANEL=SIZE_VARIABLES_LRB_PANEL+ & SIZE_VARIABLES_LRB_PANEL_j1 ENDDO endif endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_BLR_PANEL_TYPE(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_BLR_PANEL_TYPE(i1)= & NbRecords_BLR_PANEL_TYPE(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_BLR_PANEL_TYPE(i1) & +int(SIZE_GEST_BLR_PANEL_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_BLR_PANEL_TYPE(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_BLR_PANEL_TYPE(i1) size_read=size_read+SIZE_VARIABLES_BLR_PANEL_TYPE(i1) & +int(SIZE_GEST_BLR_PANEL_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_BLR_PANEL_TYPE(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_BLR_PANEL_TYPE)+ & SIZE_VARIABLES_LRB_PANEL Local_SIZE_GEST=sum(SIZE_GEST_BLR_PANEL_TYPE)+ & SIZE_GEST_LRB_PANEL #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_BLR_PANEL_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 400 continue RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_BLR_PANEL SUBROUTINE DMUMPS_SAVE_RESTORE_DIAG_BLOCK(DIAG_BLOCK_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(diag_block_type) :: DIAG_BLOCK_T INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER, PARAMETER :: D_DIAG_BLOCK=1 INTEGER, PARAMETER :: NBVARIABLES_DIAG_BLOCK_TYPE = 1 INTEGER(8),dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & SIZE_VARIABLES_DIAG_BLOCK_TYPE INTEGER,dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & SIZE_GEST_DIAG_BLOCK_TYPE INTEGER,dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & NbRecords_DIAG_BLOCK_TYPE INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER(4) :: I4 SIZE_VARIABLES_DIAG_BLOCK_TYPE(:)=0_8 SIZE_GEST_DIAG_BLOCK_TYPE(:)=0 NbRecords_DIAG_BLOCK_TYPE(:)=0 DO i1=1,NBVARIABLES_DIAG_BLOCK_TYPE SELECT CASE(i1) CASE(D_DIAG_BLOCK) NbRecords_DIAG_BLOCK_TYPE(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(DIAG_BLOCK_T%DIAG_BLOCK)) THEN SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size(DIAG_BLOCK_T%DIAG_BLOCK,1) & * SIZE_ARITH_DEP ELSE SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(DIAG_BLOCK_T%DIAG_BLOCK)) THEN SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size(DIAG_BLOCK_T%DIAG_BLOCK,1) & * SIZE_ARITH_DEP write(unit,iostat=err) size(DIAG_BLOCK_T%DIAG_BLOCK,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 write(unit,iostat=err) DIAG_BLOCK_T%DIAG_BLOCK ELSE SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 elseif(mode.EQ.restore_mode) then nullify(DIAG_BLOCK_T%DIAG_BLOCK) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 if(size_array1.EQ.-999) then SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size_array1*SIZE_ARITH_DEP allocate(DIAG_BLOCK_T%DIAG_BLOCK(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) GOTO 200 endif read(unit,iostat=err) DIAG_BLOCK_T%DIAG_BLOCK endif if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 200 endif endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)/ & huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_DIAG_BLOCK_TYPE(i1)= & NbRecords_DIAG_BLOCK_TYPE(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) & +int(SIZE_GEST_DIAG_BLOCK_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_DIAG_BLOCK_TYPE(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) size_read=size_read+SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) & +int(SIZE_GEST_DIAG_BLOCK_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_DIAG_BLOCK_TYPE(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_DIAG_BLOCK_TYPE) Local_SIZE_GEST=sum(SIZE_GEST_DIAG_BLOCK_TYPE) #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_DIAG_BLOCK_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 200 continue RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_DIAG_BLOCK #endif END MODULE DMUMPS_LR_DATA_M MUMPS_5.8.1/src/zfac_process_band.F0000664000175000017500000003232615042446441017013 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_PROCESS_DESC_BANDE( MYID, BUFR, LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP,KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, #if ! defined(NO_FDM_DESCBAND) & IWHANDLER_IN, #endif & IFLAG, IERROR ) USE MUMPS_LOAD USE ZMUMPS_LR_DATA_M, ONLY: ZMUMPS_BLR_INIT_FRONT, & ZMUMPS_BLR_SAVE_NFS4FATHER #if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M #endif IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB, N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), & ITLOC( N + KEEP(253) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER :: ISTEP_TO_INIV2(KEEP(71)) #if ! defined(NO_FDM_DESCBAND) INTEGER IWHANDLER_IN #endif INTEGER COMP, IFLAG, IERROR INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES INTEGER NSLAVES_HDR, NFRONT INTEGER LREQ INTEGER :: IBUFR INTEGER(8) :: LREQCB #if ! defined(NO_FDM_DESCBAND) INTEGER :: IWHANDLER_LOC #endif DOUBLE PRECISION FLOP1 INCLUDE 'mumps_headers.h' #if ! defined(NO_FDM_DESCBAND) INTEGER :: INFO_TMP(2) #else #endif INTEGER :: LRSTATUS INTEGER :: ESTIM_NFS4FATHER_ATSON LOGICAL :: LR_ACTIVATED, COMPRESS_CB COMPLEX(kind=8), POINTER, DIMENSION(:) :: DYNAMIC_CB INTEGER(8) :: TMP_ADDRESS INTEGER :: allocok INODE = BUFR( 2 ) NBPROCFILS = BUFR( 3 ) NROW = BUFR( 4 ) NCOL = BUFR( 5 ) NASS = BUFR( 6 ) NFRONT = BUFR( 7 ) NSLAVES_HDR = BUFR( 8 ) NSLAVES = BUFR( 9 ) LRSTATUS = BUFR(10 ) ESTIM_NFS4FATHER_ATSON = BUFR(11) IBUFR = 12 #if ! defined(NO_FDM_DESCBAND) IWHANDLER_LOC = IWHANDLER_IN IF ((IWHANDLER_IN .LE. 0) .AND. & (INODE .NE. INODE_WAITED_FOR)) THEN INFO_TMP=0 CALL MUMPS_FDBD_SAVE_DESCBAND(INODE, BUFR(1), BUFR, & IWHANDLER_LOC, INFO_TMP) IF (INFO_TMP(1) < 0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) RETURN ENDIF GOTO 555 ENDIF #endif IF ( KEEP(50) .eq. 0 ) THEN FLOP1 = dble( NASS * NROW ) + & dble(NROW*NASS)*dble(2*NCOL-NASS-1) ELSE FLOP1 = dble( NASS ) * dble( NROW ) & * dble( 2 * NCOL - NROW - NASS + 1) END IF CALL MUMPS_LOAD_UPDATE(1,.TRUE.,FLOP1, KEEP,KEEP8) IF ( KEEP(50) .eq. 0 ) THEN NSLAVES = NSLAVES_HDR + XTRA_SLAVES_UNSYM ELSE NSLAVES = NSLAVES_HDR + XTRA_SLAVES_SYM END IF LREQ = NROW + NCOL + 6 + NSLAVES + KEEP(IXSZ) LREQCB = int(NCOL,8) * int(NROW,8) IF ( LREQCB .GT. LRLUS .AND. KEEP(101) .EQ. 0 .AND. & KEEP8(73) + LREQCB .LE. KEEP8(75) ) THEN CALL ZMUMPS_ALLOC_CB(.FALSE., 0_8, .FALSE.,.TRUE., & MYID,N, KEEP, KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, & LREQ, 0_8, & INODE, S_ACTIVE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN #if defined(MUMPS_ALLOC_FROM_C) || defined(_CRAYFTN) CALL MUMPS_MALLOC_C( TMP_ADDRESS, & LREQCB * int(KEEP(35),8) ) IF (TMP_ADDRESS .EQ. 0_8) THEN allocok=1 ELSE allocok=0 ENDIF #else ALLOCATE(DYNAMIC_CB(LREQCB), stat=allocok) #endif IF (allocok .GT. 0) THEN CALL ZMUMPS_FREE_BLOCK_CB_STATIC( .FALSE., MYID, N, & IWPOSCB + 1, IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP, KEEP8, .FALSE. ) ELSE CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( LREQCB, & KEEP(405).EQ.1, & KEEP8, IFLAG, IERROR, & .TRUE., & .FALSE. ) #if ! defined(MUMPS_ALLOC_FROM_C) && ! defined(_CRAYFTN) CALL MUMPS_ADDR_C( DYNAMIC_CB(1), TMP_ADDRESS ) #endif CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXD)) PTRIST(STEP(INODE)) = IWPOSCB + 1 PTRAST(STEP(INODE)) = TMP_ADDRESS ENDIF ENDIF IF ( PTRIST(STEP(INODE)) .EQ. 0 ) THEN CALL ZMUMPS_ALLOC_CB(.FALSE., 0_8, .FALSE.,.TRUE., & MYID,N, KEEP, KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, & LREQ, LREQCB, INODE, S_ACTIVE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PTRIST(STEP(INODE)) = IWPOSCB + 1 PTRAST(STEP(INODE)) = IPTRLU + 1_8 ENDIF # if ! defined(NO_FDM_DESCBAND) 555 CONTINUE # endif # if ! defined(NO_FDM_DESCBAND) IF ((IWHANDLER_IN .LE. 0) .AND. & (INODE .NE. INODE_WAITED_FOR)) THEN RETURN ENDIF IW(IWPOSCB+1+XXA) = IWHANDLER_LOC # endif IW(IWPOSCB+1+XXF) = -9999 IW( IWPOSCB + 1+KEEP(IXSZ) ) = NCOL IW( IWPOSCB + 2+KEEP(IXSZ) ) = - NASS IW( IWPOSCB + 3+KEEP(IXSZ) ) = NROW IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 5+KEEP(IXSZ) ) = NASS IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES IW( IWPOSCB + 7+KEEP(IXSZ)+NSLAVES : & IWPOSCB + 6+KEEP(IXSZ)+NSLAVES + NROW + NCOL ) &= BUFR( IBUFR + NSLAVES_HDR : & IBUFR + NSLAVES_HDR + NROW + NCOL - 1 ) IF ( KEEP(50) .eq. 0 ) THEN IW( IWPOSCB + 7+KEEP(IXSZ) ) = S_ROOTBAND_INIT IF (NSLAVES_HDR.GT.0) THEN write(6,*) " Internal error in ZMUMPS_PROCESS_DESC_BANDE " CALL MUMPS_ABORT() ENDIF ELSE IW( IWPOSCB+7+KEEP(IXSZ) ) = huge(IW(IWPOSCB+7+KEEP(IXSZ))) IW( IWPOSCB + 8+KEEP(IXSZ) ) = NFRONT IW( IWPOSCB + 9+KEEP(IXSZ) ) = S_ROOTBAND_INIT IW( IWPOSCB + 7+XTRA_SLAVES_SYM+KEEP(IXSZ): & IWPOSCB + 6+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_HDR ) = & BUFR( IBUFR: IBUFR - 1 + NSLAVES_HDR ) END IF IW(IWPOSCB+1+XXNBPR)=NBPROCFILS IW(IWPOSCB+1+XXLR)=LRSTATUS COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP=0 CALL ZMUMPS_BLR_INIT_FRONT (IW(IWPOSCB+1+XXF), INFO_TMP) IF (INFO_TMP(1).LT.0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) RETURN ENDIF IF (COMPRESS_CB.AND. & (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & (ESTIM_NFS4FATHER_ATSON.GE.0) & ) THEN CALL ZMUMPS_BLR_SAVE_NFS4FATHER ( IW(IWPOSCB+1+XXF), & ESTIM_NFS4FATHER_ATSON ) ENDIF ENDIF IF (NBPROCFILS .EQ. 0) THEN ENDIF RETURN END SUBROUTINE ZMUMPS_PROCESS_DESC_BANDE RECURSIVE SUBROUTINE ZMUMPS_TREAT_DESCBAND( INODE, & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED & , LRGROUPS & ) # if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M # endif USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER, INTENT(IN) :: INODE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST(KEEP(28)) INTEGER STEP(N), & PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' LOGICAL :: BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: SRC_DESCBAND #if ! defined(NO_FDM_DESCBAND) INTEGER :: IWHANDLER TYPE(DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC #endif INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE SRC_DESCBAND = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) # if ! defined(NO_FDM_DESCBAND) IF (MUMPS_FDBD_IS_DESCBAND_STORED( INODE, IWHANDLER )) THEN CALL MUMPS_FDBD_RETRIEVE_DESCBAND(IWHANDLER, DESCBAND_STRUC) CALL ZMUMPS_PROCESS_DESC_BANDE( MYID, DESCBAND_STRUC%BUFR(1), & DESCBAND_STRUC%LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, & IWHANDLER, & IFLAG, IERROR ) IF (IFLAG .LT. 0) GOTO 500 CALL MUMPS_FDBD_FREE_DESCBAND_STRUC(IW(PTRIST(STEP(INODE))+XXA)) ELSE IF (INODE_WAITED_FOR.GT.0) THEN WRITE(*,*) " Internal error 1 in ZMUMPS_TREAT_DESCBAND", & INODE, INODE_WAITED_FOR CALL MUMPS_ABORT() ENDIF INODE_WAITED_FOR = INODE # endif DO WHILE (PTRIST(STEP(INODE)) .EQ. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT(COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & SRC_DESCBAND, MAITRE_DESC_BANDE, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (IFLAG .LT. 0) THEN RETURN ENDIF ENDDO # if ! defined(NO_FDM_DESCBAND) INODE_WAITED_FOR = -1 ENDIF # endif RETURN 500 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE ZMUMPS_TREAT_DESCBAND MUMPS_5.8.1/src/sana_lr.F0000664000175000017500000017733315042446437015002 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_ANA_LR USE SMUMPS_LR_CORE USE MUMPS_LR_STATS USE MUMPS_LR_COMMON USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY: LMATRIX_T !$ USE OMP_LIB, ONLY: omp_get_max_threads IMPLICIT NONE CONTAINS SUBROUTINE GET_CUT(IWR, NASS, NCB, LRGROUPS, NPARTSCB, & NPARTSASS, CUT) INTEGER, INTENT(IN) :: NASS, NCB INTEGER, INTENT(IN) :: IWR(*) INTEGER, INTENT(IN), DIMENSION(:) :: LRGROUPS INTEGER, INTENT(OUT) :: NPARTSCB, NPARTSASS INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: I, CURRENT_PART, CUTBUILDER,allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: BIG_CUT ALLOCATE(BIG_CUT(max(NASS,1)+NCB+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of BIG_CUT in GET_CUT" CALL MUMPS_ABORT() ENDIF CURRENT_PART = LRGROUPS(IWR(1)) BIG_CUT(1) = 1 BIG_CUT(2) = 2 CUTBUILDER = 2 NPARTSASS = 0 NPARTSCB = 0 DO I = 2,NASS + NCB IF (LRGROUPS(IWR(I)) == CURRENT_PART) THEN BIG_CUT(CUTBUILDER) = BIG_CUT(CUTBUILDER) + 1 ELSE CUTBUILDER = CUTBUILDER + 1 BIG_CUT(CUTBUILDER) = BIG_CUT(CUTBUILDER-1) + 1 CURRENT_PART = LRGROUPS(IWR(I)) END IF IF (I == NASS) NPARTSASS = CUTBUILDER - 1 END DO IF (NASS.EQ.1) NPARTSASS= 1 NPARTSCB = CUTBUILDER - 1 - NPARTSASS ALLOCATE(CUT(max(NPARTSASS,1)+NPARTSCB+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of CUT in GET_CUT" CALL MUMPS_ABORT() ENDIF IF (NPARTSASS.EQ.0) THEN CUT(1) = 1 CUT(2:2+NPARTSCB) = BIG_CUT(1:1+NPARTSCB) ELSE CUT = BIG_CUT(1:NPARTSASS+NPARTSCB+1) ENDIF if(allocated(BIG_CUT)) DEALLOCATE(BIG_CUT) END SUBROUTINE GET_CUT SUBROUTINE SEP_GROUPING( NFRONT, KEEP, & NV, VLIST, N, NZ, LRGROUPS, NBGROUPS, IW, & LW, IPE, LEN, GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, NODE, & GEN2HALO, K482, K472, K469, SEP_SIZE, MAXSIZE_PARTS, & KEEP10, LP, LPOK, IFLAG, IERROR) INTEGER, INTENT(IN) :: NFRONT, KEEP(500) INTEGER(8), INTENT(IN) :: NZ, LW INTEGER, INTENT(IN) :: NV, N, GROUP_SIZE, HALO_DEPTH INTEGER, INTENT(IN) :: IW(LW), LEN(N), NODE, K482 INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: K472, K469, SEP_SIZE, KEEP10, LP LOGICAL :: LPOK INTEGER, INTENT(INOUT) :: NBGROUPS, WORKH(N) INTEGER, INTENT(INOUT) :: VLIST(NV), TRACE(N) INTEGER :: LRGROUPS(:) INTEGER, INTENT(INOUT) :: GEN2HALO(N) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: MAXSIZE_PARTS INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IPTRHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: PARTS, JCNHALO INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBG_CAPT, & NBGROUPS_KWAY, I, GROUP_SIZE2, LRGROUPS_SIGN, IERR INTEGER :: MAXSIZE_PARTS_LOC #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) INTEGER :: METIS_IDX_SIZE #endif #if defined (scotch) || defined (ptscotch) INTEGER :: SCOTCH_IDX_SIZE #endif CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV, & NFRONT, KEEP(35)) NBGROUPS_KWAY = MAX( & INT(real(NV+GROUP_SIZE2-1)/real(GROUP_SIZE2)) & ,1) IF (NV .GE. SEP_SIZE) THEN LRGROUPS_SIGN = 1 ELSE LRGROUPS_SIGN = -1 ENDIF IF (NBGROUPS_KWAY > 1) THEN IF (K469.EQ.3) THEN !$OMP CRITICAL(gethalo_cri) CALL GETHALONODES(N, IW, LW, IPE, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, LEN, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(max(HALOEDGENBR,1)), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) ENDIF CALL GETHALOGRAPH(WORKH, NHALO, N, IW, LW, IPE, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO) !$OMP END CRITICAL(gethalo_cri) IF (IFLAG.LT.0) RETURN ELSE CALL GETHALONODES(N, IW, LW, IPE, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, LEN, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(max(HALOEDGENBR,1)), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) RETURN ENDIF CALL GETHALOGRAPH(WORKH, NHALO, N, IW, LW, IPE, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO) ENDIF IF (K482.EQ.1) THEN #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_KWAY_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ELSE IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 1 ELSE CALL MUMPS_METIS_KWAY_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ENDIF #endif ELSE IF (K482.EQ.2) THEN #if defined (scotch) || defined (ptscotch) CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_IDX_SIZE) IF (SCOTCH_IDX_SIZE .EQ. 32) THEN IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 2 ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto32( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto64( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) END IF IF ((IFLAG.LT.0).AND.LPOK) THEN WRITE(LP,*) " Internal error in SCOTCH during ", & " Kway partitioning, SCOTCHFGRAPHPART, " WRITE(LP,*) & " please also provide METIS package to MUMPS " ENDIF #endif ELSE WRITE(6,*) " Internal ERROR K482=", K482 CALL MUMPS_ABORT() END IF IF (IFLAG.LT.0) GOTO 500 CALL GET_GLOBAL_GROUPS(PARTS, VLIST, NV, & NBGROUPS_KWAY, LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN, & MAXSIZE_PARTS_LOC, .FALSE., GROUP_SIZE2) MAXSIZE_PARTS = max(MAXSIZE_PARTS, MAXSIZE_PARTS_LOC) ELSE MAXSIZE_PARTS = max(MAXSIZE_PARTS,NV) !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + 1 !$OMP END ATOMIC DO I=1,NV LRGROUPS(VLIST(I)) = LRGROUPS_SIGN*(NBG_CAPT + 1) END DO END IF 500 IF (allocated(IPTRHALO)) then DEALLOCATE(IPTRHALO) ENDIF IF (allocated(PARTS)) then DEALLOCATE(PARTS) ENDIF IF (allocated(JCNHALO)) then DEALLOCATE(JCNHALO ) ENDIF RETURN END SUBROUTINE SEP_GROUPING SUBROUTINE SEP_GROUPING_AB ( NFRONT, KEEP, & NV, NVEXPANDED, & VLIST, N, LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, NODE, & GEN2HALO, K482, K472, K469, SEP_SIZE, MAXSIZE_PARTS, & KEEP10, LP, LPOK, IFLAG, IERROR) INTEGER, INTENT(IN) :: NFRONT, KEEP(500) TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: NV, NVEXPANDED, & N, GROUP_SIZE, HALO_DEPTH INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: NODE, K482 INTEGER, INTENT(IN) :: K472, K469, SEP_SIZE, KEEP10, LP LOGICAL :: LPOK INTEGER, INTENT(INOUT) :: NBGROUPS, WORKH(N) INTEGER, INTENT(INOUT) :: VLIST(NV), TRACE(N) INTEGER :: LRGROUPS(:) INTEGER, INTENT(INOUT) :: GEN2HALO(N) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: MAXSIZE_PARTS INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IPTRHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: PARTS, JCNHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: VWGT INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBG_CAPT, & NBGROUPS_KWAY, I, GROUP_SIZE2, LRGROUPS_SIGN, IERR INTEGER :: MAXSIZE_PARTS_LOC REAL :: COMPRESS_RATIO LOGICAL :: AB_ACTIVE #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) INTEGER :: METIS_IDX_SIZE #endif #if defined (scotch) || defined (ptscotch) INTEGER :: SCOTCH_IDX_SIZE #endif AB_ACTIVE = (NVEXPANDED.GT.NV) CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED, & NFRONT, KEEP(35)) COMPRESS_RATIO= real(NVEXPANDED)/real(NV) NBGROUPS_KWAY = MAX( & INT(real(NVEXPANDED+GROUP_SIZE2-1)/real(GROUP_SIZE2)) & ,1) NBGROUPS_KWAY = min(NBGROUPS_KWAY, NV) IF (NVEXPANDED .GE. SEP_SIZE) THEN LRGROUPS_SIGN = 1 ELSE LRGROUPS_SIGN = -1 ENDIF IF (NBGROUPS_KWAY > 1) THEN IF (K469.EQ.3) THEN !$OMP CRITICAL(gethalo_cri) CALL GETHALONODES_AB(N, LUMAT, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(max(HALOEDGENBR,1)), VWGT(NHALO), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) ENDIF DO I=1, NHALO VWGT(I) = SIZEOFBLOCKS(WORKH(I)) ENDDO CALL GETHALOGRAPH_AB(WORKH, NV, & NHALO, N, LUMAT, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO, PARTS) !$OMP END CRITICAL(gethalo_cri) IF (IFLAG.LT.0) RETURN ELSE CALL GETHALONODES_AB(N, LUMAT, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(max(HALOEDGENBR,1)), VWGT(NHALO), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) RETURN ENDIF DO I=1, NHALO VWGT(I) = SIZEOFBLOCKS(WORKH(I)) ENDDO CALL GETHALOGRAPH_AB(WORKH, NV, & NHALO, N, LUMAT, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO, PARTS) ENDIF IF (K482.EQ.1) THEN #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_KWAY_AB_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) ELSE IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 1 ELSE CALL MUMPS_METIS_KWAY_AB_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ENDIF #endif ELSE IF (K482.EQ.2) THEN #if defined (scotch) || defined (ptscotch) CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_IDX_SIZE) IF (SCOTCH_IDX_SIZE .EQ. 32) THEN IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 2 ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto32( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto64( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) END IF IF ((IFLAG.LT.0).AND.LPOK) THEN WRITE(LP,*) " Internal error in SCOTCH during ", & " Kway partitioning, SCOTCHFGRAPHPART, " WRITE(LP,*) & " also provide METIS package to MUMPS " ENDIF #endif ELSE WRITE(6,*) " Internal ERROR K482=", K482 CALL MUMPS_ABORT() END IF IF (IFLAG.LT.0) GOTO 500 CALL GET_GLOBAL_GROUPS(PARTS,VLIST, NV, & NBGROUPS_KWAY, LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN, & MAXSIZE_PARTS_LOC, AB_ACTIVE, GROUP_SIZE2) MAXSIZE_PARTS = max( MAXSIZE_PARTS, & int(real(MAXSIZE_PARTS_LOC*COMPRESS_RATIO)) ) ELSE MAXSIZE_PARTS = max(MAXSIZE_PARTS,NV) !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + 1 !$OMP END ATOMIC DO I=1,NV LRGROUPS(VLIST(I)) = LRGROUPS_SIGN*(NBG_CAPT + 1) END DO END IF 500 IF (allocated(IPTRHALO)) then DEALLOCATE(IPTRHALO) ENDIF IF (allocated(PARTS)) then DEALLOCATE(PARTS) ENDIF IF (allocated(JCNHALO)) then DEALLOCATE(JCNHALO ) ENDIF IF (allocated(VWGT)) then DEALLOCATE(VWGT) ENDIF RETURN END SUBROUTINE SEP_GROUPING_AB SUBROUTINE GETHALONODES_AB(N, LUMAT, IND, NIND, PMAX, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) TYPE(LMATRIX_T) :: LUMAT INTEGER,DIMENSION(:),INTENT(IN) :: IND INTEGER, INTENT(IN) :: N, NODE INTEGER, INTENT(IN) :: PMAX,NIND INTEGER, INTENT(OUT) :: NHALO INTEGER, INTENT(INOUT) :: TRACE(N), WORKH(N) INTEGER :: GEN2HALO(N) INTEGER(8), INTENT(OUT) :: HALOEDGENBR INTEGER :: I, J, II INTEGER :: HALOI, NB, NEWNHALO INTEGER(8) :: SEPEDGES_TOTAL, & SEPEDGES_INTERNAL WORKH(1:NIND) = IND NHALO = NIND NEWNHALO = 0 HALOEDGENBR = 0_8 SEPEDGES_TOTAL = 0_8 SEPEDGES_INTERNAL = 0_8 DO I=1,NIND HALOI = WORKH(I) GEN2HALO(HALOI) = I IF (TRACE(HALOI) .NE. NODE) THEN TRACE(HALOI) = NODE END IF ENDDO DO I=1,NIND HALOI = WORKH(I) NB = LUMAT%COL(HALOI)%NBINCOL SEPEDGES_TOTAL = SEPEDGES_TOTAL + int(NB,8) DO J=1, NB II = LUMAT%COL(HALOI)%IRN(J) IF (TRACE(II).NE.NODE) THEN NEWNHALO = NEWNHALO + 1 WORKH(NHALO+NEWNHALO) = II GEN2HALO(II) = NHALO+NEWNHALO TRACE(II) = NODE ELSE IF (GEN2HALO(II).LE.NHALO) THEN SEPEDGES_INTERNAL = SEPEDGES_INTERNAL + 1_8 ENDIF ENDIF ENDDO END DO HALOEDGENBR = SEPEDGES_TOTAL + & (SEPEDGES_TOTAL - SEPEDGES_INTERNAL) NHALO = NHALO + NEWNHALO END SUBROUTINE GETHALONODES_AB SUBROUTINE GETHALOGRAPH_AB(HALO,NSEP,NHALO, & N,LUMAT,IPTRHALO,JCNHALO, & HALOEDGENBR,TRACE,NODE, GEN2HALO, IQ) INTEGER, INTENT(IN) :: N TYPE(LMATRIX_T) :: LUMAT INTEGER,INTENT(IN):: NSEP, NHALO, NODE INTEGER,INTENT(IN):: GEN2HALO(N) INTEGER,DIMENSION(NHALO),INTENT(IN) :: HALO INTEGER, INTENT(IN) :: TRACE(N) INTEGER(8),INTENT(IN) :: HALOEDGENBR INTEGER(8), INTENT(OUT) :: IPTRHALO(NHALO+1) INTEGER, INTENT(OUT) :: JCNHALO(max(HALOEDGENBR,1)) INTEGER :: IQ(NHALO) INTEGER::I,J,NB,II,JJ,HALOI,HALOJ DO I=NSEP+1, NHALO IQ(I) = 0 ENDDO DO I=1,NSEP HALOI = HALO(I) NB = LUMAT%COL(HALOI)%NBINCOL IQ(I) = NB DO JJ=1, NB II = LUMAT%COL(HALOI)%IRN(JJ) J = GEN2HALO(II) IF (J.GT.NSEP) THEN IQ(J) = IQ(J) + 1 ENDIF ENDDO ENDDO IPTRHALO(1) = 1_8 DO I=1,NHALO IPTRHALO(I+1) = IPTRHALO(I)+int(IQ(I),8) ENDDO DO I=1,NSEP HALOI = HALO(I) NB = LUMAT%COL(HALOI)%NBINCOL DO JJ=1, NB HALOJ = LUMAT%COL(HALOI)%IRN(JJ) J = GEN2HALO(HALOJ) JCNHALO(IPTRHALO(I)) = J IPTRHALO(I) = IPTRHALO(I) + 1 IF (J.GT.NSEP) THEN JCNHALO(IPTRHALO(J)) = I IPTRHALO(J) = IPTRHALO(J) + 1 ENDIF ENDDO ENDDO IPTRHALO(1) = 1_8 DO I=1,NHALO IPTRHALO(I+1) = IPTRHALO(I)+int(IQ(I),8) ENDDO END SUBROUTINE GETHALOGRAPH_AB SUBROUTINE GET_GLOBAL_GROUPS(PARTS, SEP, NSEP, NPARTS, & LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN, & MAXSIZE_PARTS_LOC, AB_ACTIVE, GROUP_SIZE2) INTEGER,INTENT(IN) :: NSEP, N, LRGROUPS_SIGN, GROUP_SIZE2 INTEGER :: PARTS(:) LOGICAL :: AB_ACTIVE INTEGER,DIMENSION(:),INTENT(INOUT) :: SEP INTEGER, INTENT(INOUT) :: NPARTS INTEGER, INTENT(INOUT) :: NBGROUPS INTEGER :: LRGROUPS(:) INTEGER, INTENT(OUT) :: MAXSIZE_PARTS_LOC INTRINSIC maxval INTEGER:: I,CNT,NB_PARTS_WITHOUT_SEP_NODE,allocok INTEGER:: TARGET_SIZE_KWAY INTEGER:: MAXSIZE_PARTS_LOC_NEW, NBG_CAPT INTEGER,DIMENSION(:),ALLOCATABLE::SIZES, RIGHTPART INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR #if ! defined(NO_SPLIT_IN_BLRGROUPING) INTEGER :: NB_PARTS_WITH_SPLIT, IP, SZ_FINAL, II, NB_SPLIT INTEGER :: TARGET_SIZE_SPLIT #endif INTEGER,DIMENSION(:),ALLOCATABLE :: NEWSEP ALLOCATE( NEWSEP(NSEP), & SIZES(NPARTS), & RIGHTPART(NPARTS), & PARTPTR(NPARTS+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GLOBAL_GROUPS" CALL MUMPS_ABORT() ENDIF TARGET_SIZE_KWAY = GROUP_SIZE2 TARGET_SIZE_SPLIT = TARGET_SIZE_KWAY IF (AB_ACTIVE) TARGET_SIZE_SPLIT =huge(TARGET_SIZE_SPLIT) NB_PARTS_WITHOUT_SEP_NODE = 0 RIGHTPART = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = SIZES(PARTS(I)) + 1 END DO MAXSIZE_PARTS_LOC = maxval(SIZES) CNT = 0 PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) IF (SIZES(I-1)==0) THEN NB_PARTS_WITHOUT_SEP_NODE = NB_PARTS_WITHOUT_SEP_NODE + 1 ELSE CNT = CNT + 1 RIGHTPART(I-1) = CNT #if ! defined(NO_SPLIT_IN_BLRGROUPING) SIZES(CNT) = SIZES(I-1) #endif END IF END DO NPARTS = NPARTS - NB_PARTS_WITHOUT_SEP_NODE #if ! defined(NO_SPLIT_IN_BLRGROUPING) IF (MAXSIZE_PARTS_LOC.LT.TARGET_SIZE_SPLIT) THEN #endif !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + NPARTS !$OMP END ATOMIC DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) LRGROUPS(SEP(I)) = LRGROUPS_SIGN*(RIGHTPART(PARTS(I)) & + NBG_CAPT) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO SEP = NEWSEP #if ! defined(NO_SPLIT_IN_BLRGROUPING) ELSE DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO SEP = NEWSEP PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) ENDDO NB_PARTS_WITH_SPLIT = 0 MAXSIZE_PARTS_LOC_NEW = 0 DO IP =1, NPARTS NB_SPLIT = (SIZES(IP) + TARGET_SIZE_SPLIT-1) & / TARGET_SIZE_SPLIT SZ_FINAL = (SIZES(IP) + NB_SPLIT-1) / NB_SPLIT NB_PARTS_WITH_SPLIT = NB_PARTS_WITH_SPLIT + & ( & ( (PARTPTR(IP+1) - PARTPTR(IP))+ SZ_FINAL-1 ) / & SZ_FINAL & ) ENDDO !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + NB_PARTS_WITH_SPLIT !$OMP END ATOMIC NB_PARTS_WITH_SPLIT = 0 DO IP=1,NPARTS NB_SPLIT = (SIZES(IP) + TARGET_SIZE_SPLIT-1) & / TARGET_SIZE_SPLIT SZ_FINAL = (SIZES(IP) + NB_SPLIT-1) / NB_SPLIT MAXSIZE_PARTS_LOC_NEW = max(MAXSIZE_PARTS_LOC_NEW, & SZ_FINAL) DO I=PARTPTR(IP), PARTPTR(IP+1)-1, SZ_FINAL NB_PARTS_WITH_SPLIT = NB_PARTS_WITH_SPLIT +1 DO II=I, min(I+SZ_FINAL-1,PARTPTR(IP+1)-1) LRGROUPS(SEP(II)) = LRGROUPS_SIGN*(NB_PARTS_WITH_SPLIT & + NBG_CAPT) ENDDO ENDDO ENDDO NPARTS = NB_PARTS_WITH_SPLIT MAXSIZE_PARTS_LOC = MAXSIZE_PARTS_LOC_NEW ENDIF #endif DEALLOCATE(NEWSEP,SIZES,RIGHTPART,PARTPTR) END SUBROUTINE GET_GLOBAL_GROUPS SUBROUTINE GETHALONODES(N, IW, LW, IPE, IND, NIND, PMAX, & NHALO, TRACE, WORKH, NODE, LEN, CNT, & GEN2HALO) INTEGER,DIMENSION(:),INTENT(IN) :: IND INTEGER(8), INTENT(IN) :: LW INTEGER, INTENT(IN) :: N, NODE INTEGER, INTENT(IN) :: IW(LW), LEN(N) INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: PMAX,NIND INTEGER, INTENT(OUT) :: NHALO INTEGER, INTENT(INOUT) :: TRACE(N), WORKH(N) INTEGER :: GEN2HALO(N) INTEGER(8), INTENT(OUT) :: CNT INTEGER :: DEPTH, I, LAST_LVL_START INTEGER :: HALOI INTEGER(8) :: J WORKH(1:NIND) = IND LAST_LVL_START = 1 NHALO = NIND CNT = 0 DO I=1,NIND HALOI = WORKH(I) GEN2HALO(HALOI) = I IF (TRACE(HALOI) .NE. NODE) THEN TRACE(HALOI) = NODE END IF DO J=IPE(HALOI),IPE(HALOI+1)-1 IF (TRACE(IW(J)).EQ.NODE) THEN CNT = CNT + 2 END IF END DO END DO DO DEPTH=1,PMAX CALL NEIGHBORHOOD(WORKH, NHALO, N, IW, LW, IPE, & TRACE, NODE, LEN, CNT, LAST_LVL_START, & DEPTH, PMAX, GEN2HALO) END DO END SUBROUTINE GETHALONODES SUBROUTINE NEIGHBORHOOD(HALO, NHALO, N, IW, LW, IPE, & TRACE, NODE, LEN, CNT, LAST_LVL_START, & DEPTH, PMAX, GEN2HALO) INTEGER, INTENT(IN) :: N, NODE, DEPTH, PMAX INTEGER,INTENT(INOUT) :: NHALO, GEN2HALO(N) INTEGER, INTENT(INOUT) :: LAST_LVL_START INTEGER(8), INTENT(INOUT) :: CNT INTEGER,DIMENSION(:),INTENT(INOUT) :: HALO INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, TARGET, INTENT(IN) :: IW(LW) INTEGER, INTENT(IN) :: LEN(N) INTEGER,DIMENSION(:) :: TRACE INTEGER :: AvgDens, THRESH INTEGER :: I,INEI,NADJI,NEWNHALO, NEIGH INTEGER, DIMENSION(:), POINTER :: ADJI INTEGER(8) :: J NEWNHALO = 0 AvgDens = nint(real(IPE(N+1)-1_8)/real(N)) THRESH = AvgDens*10 DO I=LAST_LVL_START,NHALO NADJI = LEN(HALO(I)) IF (NADJI.GT.THRESH) CYCLE ADJI => IW(IPE(HALO(I)):IPE(HALO(I)+1)-1) DO INEI=1,NADJI IF (TRACE(ADJI(INEI)) .NE. NODE) THEN NEIGH = ADJI(INEI) IF (LEN(NEIGH).GT.THRESH) CYCLE TRACE(NEIGH) = NODE NEWNHALO = NEWNHALO + 1 HALO(NHALO+NEWNHALO) = NEIGH GEN2HALO(NEIGH) = NHALO + NEWNHALO DO J=IPE(NEIGH),IPE(NEIGH+1)-1 IF (TRACE(IW(J)).EQ.NODE) THEN CNT = CNT + 2 END IF END DO END IF END DO END DO LAST_LVL_START = NHALO + 1 NHALO = NHALO + NEWNHALO END SUBROUTINE NEIGHBORHOOD SUBROUTINE GETHALOGRAPH(HALO,NHALO,N,IW,LW,IPE,IPTRHALO,JCNHALO, & HALOEDGENBR,TRACE,NODE, GEN2HALO) INTEGER, INTENT(IN) :: N INTEGER,INTENT(IN):: NHALO, NODE INTEGER,INTENT(IN):: GEN2HALO(N) INTEGER,DIMENSION(NHALO),INTENT(IN) :: HALO INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: IW(LW), TRACE(N) INTEGER(8),INTENT(IN) :: HALOEDGENBR INTEGER(8), INTENT(OUT) :: IPTRHALO(NHALO+1) INTEGER, INTENT(OUT) :: JCNHALO(max(HALOEDGENBR,1)) INTEGER::I,IPTR_CNT,JCN_CNT,HALOI INTEGER(8) :: J, CNT CNT = 0 IPTR_CNT = 2 JCN_CNT = 1 IPTRHALO(1) = 1 DO I=1,NHALO HALOI = HALO(I) DO J=IPE(HALOI),IPE(HALOI+1)-1 IF (TRACE(IW(J))==NODE) THEN CNT = CNT + 1 JCNHALO(JCN_CNT) = GEN2HALO(IW(J)) JCN_CNT = JCN_CNT + 1 END IF END DO IPTRHALO(IPTR_CNT) = CNT + 1 IPTR_CNT = IPTR_CNT + 1 END DO END SUBROUTINE GETHALOGRAPH SUBROUTINE GET_GROUPS(NHALO,PARTS,SEP,NSEP,NPARTS, & CUT,NEWSEP,PERM,IPERM) INTEGER,INTENT(IN) :: NHALO,NSEP INTEGER,DIMENSION(:),INTENT(IN) :: SEP INTEGER,POINTER,DIMENSION(:)::PARTS INTEGER,POINTER,DIMENSION(:)::CUT,NEWSEP,PERM, & IPERM INTEGER,INTENT(INOUT) :: NPARTS INTEGER::I,CNT,NB_PARTS_WITHOUT_SEP_NODE,allocok INTEGER,DIMENSION(:),ALLOCATABLE::SIZES INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR ALLOCATE(NEWSEP(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(PERM(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(IPERM(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(SIZES(NPARTS),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(PARTPTR(NPARTS+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF NB_PARTS_WITHOUT_SEP_NODE = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = & SIZES(PARTS(I))+1 END DO PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) IF (SIZES(I-1)==0) THEN NB_PARTS_WITHOUT_SEP_NODE = NB_PARTS_WITHOUT_SEP_NODE + 1 END IF END DO ALLOCATE(CUT(NPARTS-NB_PARTS_WITHOUT_SEP_NODE+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF CUT(1) = 1 CNT = 2 DO I=2,NPARTS+1 IF (SIZES(I-1).NE.0) THEN CUT(CNT) = PARTPTR(I) CNT = CNT + 1 END IF END DO NPARTS = NPARTS - NB_PARTS_WITHOUT_SEP_NODE CUT(NPARTS+1) = NSEP+1 DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) PERM(PARTPTR(PARTS(I))) = I IPERM(I) = PARTPTR(PARTS(I)) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO DEALLOCATE(SIZES,PARTPTR) END SUBROUTINE GET_GROUPS SUBROUTINE SMUMPS_LR_GROUPING(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, NE_STEPS, STEP, NA, LNA, & LRGROUPS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, SEP_SIZE, & K38, K20, K60, & IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K10, & K54, K142, LPOK, LP, GATHER_MATRIX_ALLOCATED, & KEEP, ND_STEPS) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, K60, K54 INTEGER, INTENT(IN) :: LP INTEGER, INTENT(OUT) :: K142 LOGICAL, INTENT(IN) :: LPOK INTEGER, POINTER, DIMENSION(:) :: IRN, JCN INTEGER, INTENT(IN) :: NE_STEPS(:), ICNTL(60) INTEGER :: FRERE_STEPS(:), NA(:), DAD_STEPS(:) INTEGER :: FILS(N), STEP(N), LRGROUPS(N) INTEGER, INTENT(IN) :: K472, MAXFRONT LOGICAL, INTENT(INOUT) :: GATHER_MATRIX_ALLOCATED INTEGER, INTENT(IN) :: KEEP(500), ND_STEPS(:) INTEGER :: K482_LOC, K38ou20 INTEGER :: I, F, PV, NV, NLEAVES, NROOTS, PP, C, NF, NODE, & SYMTRY, NBQD, AD INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: LPTR, RPTR, NBGROUPS LOGICAL :: FIRST INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, GEN2HALO INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR LOGICAL :: INPLACE64_GRAPH_COPY K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF NBGROUPS = 0 IF (K265.EQ.-1) THEN LW = NZ8 ELSE LW = 2_8 * NZ8 ENDIF ALLOCATE(IW(LW), IPE(N+1), LEN(N), IQ(N), & POOL(NA(1)), PVS(NSTEPS), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * LW+int(N,8)+int(K10*(2*N+1),8) IFLAG = -7 CALL MUMPS_SET_IERROR(LW+int(N,8)+int(K10*(2*N+1),8),IERROR) GOTO 500 ENDIF CALL SMUMPS_ANA_GNEW(N, NZ8, IRN(1), JCN(1), IW(1), LW, IPE(1), & LEN(1), IQ(1), LRGROUPS(1), IWFR, NRORM, NIORM, & IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265,.FALSE., & INPLACE64_GRAPH_COPY) IF (K54.EQ.3) THEN deallocate(IRN) deallocate(JCN) NULLIFY(IRN) NULLIFY(JCN) GATHER_MATRIX_ALLOCATED = .FALSE. ENDIF IF (allocated(IQ)) DEALLOCATE(IQ) LRGROUPS = -1 NLEAVES = NA(1) NROOTS = NA(2) LPTR = 2+NLEAVES RPTR = 2+NLEAVES+NROOTS DO I = 1, NROOTS POOL(I) = NA(2+NLEAVES+I) END DO PP = NROOTS ALLOCATE(WORK(MAXFRONT), TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * 3*N+MAXFRONT IFLAG = -7 IERROR = 3*N+MAXFRONT RETURN ENDIF TRACE = 0 K142 = 0 DO WHILE(PP .GT. 0) PV = ABS(POOL(PP)) NODE = STEP(PV) FIRST = POOL(PP) .LT. 0 NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV, & ND_STEPS(NODE), KEEP(35)) IF (NV .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + ( (NV-1)/GROUP_SIZE2 + 1 ) K142 = max(K142, min(NV,GROUP_SIZE2)) ELSE CALL SEP_GROUPING( ND_STEPS(NODE), KEEP, & NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE(1), WORKH(1), NODE, & GEN2HALO(1), K482_LOC, K472, 0, SEP_SIZE, K142, & K10, LP, LPOK, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 500 END IF ELSE IF (NV .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = (NBGROUPS + 1) ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -(NBGROUPS + 1) ENDDO ENDIF NBGROUPS = NBGROUPS + 1 K142 = max (K142,NV) ENDIF CALL MUMPS_UPD_TREE(NV, NSTEPS, N, FIRST, LPTR, RPTR, F, & WORK(1), & FILS, FRERE_STEPS, STEP, DAD_STEPS, & NE_STEPS, NA, LNA, PVS(1), K38ou20, & STEP_SCALAPACK_ROOT) IF (STEP_SCALAPACK_ROOT.GT.0) THEN IF (K38.GT.0) THEN K38 = K38ou20 ELSE K20 = K38ou20 ENDIF ENDIF PP = PP-1 NF = NE_STEPS(NODE) IF(NF .GT. 0) THEN PP = PP+1 POOL(PP) = F C = STEP(-F) F = FRERE_STEPS(C) DO WHILE(F .GT. 0) PP = PP+1 POOL(PP) = F C = STEP(F) F = FRERE_STEPS(C) END DO END IF END DO 500 IF (allocated(POOL)) DEALLOCATE(POOL) IF (allocated(PVS)) DEALLOCATE(PVS) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(LEN)) DEALLOCATE(LEN) IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) RETURN END SUBROUTINE SMUMPS_LR_GROUPING SUBROUTINE SMUMPS_LR_GROUPING_NEW(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, K142, LPOK, LP, GATHER_MATRIX_ALLOCATED, & KEEP, ND_STEPS) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, POINTER, DIMENSION(:) :: IRN, JCN INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FRERE_STEPS(:), NA(:), DAD_STEPS(:) INTEGER :: FILS(N), STEP(N), LRGROUPS(N) INTEGER, INTENT(IN) :: K472, K469 LOGICAL, INTENT(INOUT) :: GATHER_MATRIX_ALLOCATED INTEGER, INTENT(OUT) :: K142 INTEGER, INTENT(IN) :: KEEP(500), ND_STEPS(:) INTEGER :: K482_LOC, K469_LOC, K38ou20 INTEGER :: I, F, PV, NV, NODE, & SYMTRY, NBQD, AD LOGICAL :: PVSCHANGED INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: NBGROUPS, NBGROUPS_local, NBG_CAPT INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: INPLACE64_GRAPH_COPY #if defined(ptscotch) || defined(scotch) INTEGER :: VSCOTCH LOGICAL :: SCOTCH_IS_THREAD_SAFE INTEGER :: PTHREAD_NUMBER, NOMP #endif K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF K469_LOC = K469 #if defined(ptscotch) || defined(scotch) SCOTCH_IS_THREAD_SAFE = .FALSE. IF (K482_LOC.EQ.2) THEN CALL MUMPS_SCOTCH_VERSION (VSCOTCH) IF (VSCOTCH.GE.7) SCOTCH_IS_THREAD_SAFE=.TRUE. ENDIF IF (K482_LOC.EQ.2.AND.(.NOT.SCOTCH_IS_THREAD_SAFE) ) THEN K469_LOC = 1 ENDIF #endif NBGROUPS = 0 LW = 2_8 * NZ8 ALLOCATE(IW(LW), IPE(N+1), LEN(N), IQ(N), & PVS(NSTEPS), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * LW+int(N,8)+int(K10*(2*N+1),8) IFLAG = -7 CALL MUMPS_SET_IERROR(LW+int(N,8)+int(K10*(2*N+1),8),IERROR) GOTO 501 ENDIF CALL SMUMPS_ANA_GNEW(N, NZ8, IRN(1), JCN(1), IW(1), LW, IPE(1), & LEN(1), IQ(1), LRGROUPS(1), IWFR, NRORM, NIORM, & IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265,.FALSE., & INPLACE64_GRAPH_COPY) IF (K54.EQ.3) THEN deallocate(IRN) deallocate(JCN) NULLIFY(IRN) NULLIFY(JCN) GATHER_MATRIX_ALLOCATED = .FALSE. ENDIF IF (allocated(IQ)) DEALLOCATE(IQ) LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 501 ENDIF ENDIF #if defined(ptscotch) || defined(scotch) IF (K482_LOC.EQ.2) THEN NOMP=0 !$ NOMP=omp_get_max_threads() IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (PTHREAD_NUMBER) NOMP =1 CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (NOMP) ENDIF ENDIF #endif K142 = 0 PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = omp_get_max_threads() OMP_NUM = min(OMP_NUM,5) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local !$OMP& ) !$OMP& REDUCTION( max : K142) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(MAXFRONT), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", MAXFRONT !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = MAXFRONT !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 3*N !$OMP END ATOMIC ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 500 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE PV = PVS(NODE) NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV, & ND_STEPS(NODE), KEEP(35)) IF (NV .GE. GROUP_SIZE2 & .AND. NV.GE.int(dble(SEP_SIZE)*dble(1.5)) & ) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + ( (NV-1)/GROUP_SIZE2 + 1 ) !$OMP END ATOMIC DO I=1,NV LRGROUPS(WORK(I))=NBG_CAPT+1+(I-1)/GROUP_SIZE2 END DO K142 = max(K142, min(NV,GROUP_SIZE2)) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING( ND_STEPS(NODE), KEEP, & NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K142, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING( ND_STEPS(NODE), KEEP, & NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K142, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NV .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF K142 = max (K142,NV) ENDIF ENDDO !$OMP END DO IF (IFLAG.LT.0) GOTO 500 IF (.NOT.PVSCHANGED) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL #if defined(ptscotch) || defined(scotch) IF (K482_LOC.EQ.2.AND.NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (PTHREAD_NUMBER) ENDIF #endif 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(LEN)) DEALLOCATE(LEN) RETURN END SUBROUTINE SMUMPS_LR_GROUPING_NEW SUBROUTINE SMUMPS_AB_LR_MPI_GROUPING( & N, MAPCOL, SIZEMAPCOL, & NSTEPS, LUMAT, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SIZEOFBLOCKS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, & SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, K142, LPOK, LP, & COMM, MYID, NPROCS_ARG, & KEEP, ND_STEPS & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, INTENT(IN) :: MYID, COMM, NPROCS_ARG TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER, INTENT(IN) :: SIZEMAPCOL INTEGER, INTENT(IN) :: MAPCOL(SIZEMAPCOL) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(OUT) :: K142 INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FRERE_STEPS(:), NA(:), DAD_STEPS(:) INTEGER :: FILS(N), STEP(N), LRGROUPS(N) INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: K472, K469 INTEGER, INTENT(IN) :: KEEP(500), ND_STEPS(:) INTEGER :: NPROCS INTEGER :: K482_LOC, K469_LOC, K38ou20, K142_GLOB INTEGER :: I, F, PV, NV, NVEXPANDED, NODE REAL :: COMPRESS_RATIO LOGICAL :: PVSCHANGED INTEGER :: PVSCHANGED_INT, PVSCHANGED_INT_GLOB, IPROC INTEGER :: NBGROUPS, NBGROUPS_local, NBG_CAPT INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER :: NBGROUPS_sent INTEGER :: NBNODES_LOC, SIZE_SENT, ISHIFT, & MSGSOU, ILOOP INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, GROUP_SIZE2_TMP, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: MAPCOL_PROVIDED #if defined(ptscotch) || defined(scotch) INTEGER :: VSCOTCH LOGICAL :: SCOTCH_IS_THREAD_SAFE INTEGER :: PTHREAD_NUMBER, NOMP #endif MAPCOL_PROVIDED = (MAPCOL(1).GE.0) NPROCS = NPROCS_ARG IF (.NOT.MAPCOL_PROVIDED) NPROCS=1 K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF (MAPCOL_PROVIDED) THEN CALL MPI_BCAST( FILS(1), N, MPI_INTEGER, & MASTER, COMM, IERR ) ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF K469_LOC = K469 #if defined(ptscotch) || defined(scotch) SCOTCH_IS_THREAD_SAFE = .FALSE. IF (K482_LOC.EQ.2) THEN CALL MUMPS_SCOTCH_VERSION (VSCOTCH) IF (VSCOTCH.GE.7) SCOTCH_IS_THREAD_SAFE=.TRUE. ENDIF IF (K482_LOC.EQ.2.AND.(.NOT.SCOTCH_IS_THREAD_SAFE) ) THEN K469_LOC = 1 ENDIF #endif NBGROUPS = 0 K142 = 0 ALLOCATE( PVS(NSTEPS), STAT=IERR) IF (IERR.GT.0) THEN IFLAG = -7 IERROR = NSTEPS IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", IERROR GOTO 491 ENDIF LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 491 ENDIF ENDIF 491 CONTINUE IF (NPROCS.GT.1) THEN CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) ENDIF IF (IFLAG.LT.0) GOTO 501 #if defined(ptscotch) || defined(scotch) NOMP=0 IF (K482_LOC.EQ.2) THEN !$ NOMP=omp_get_max_threads() IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (PTHREAD_NUMBER) NOMP =1 CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (NOMP) ENDIF ENDIF #endif K142 = 0 PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = omp_get_max_threads() OMP_NUM = min(OMP_NUM,5) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local, !$OMP& NVEXPANDED, COMPRESS_RATIO, IPROC, GROUP_SIZE2_TMP !$OMP& ) !$OMP& REDUCTION( max : K142) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(2*MAXFRONT+1), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 2*MAXFRONT+1 !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 2*MAXFRONT+1 !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 3*N !$OMP END ATOMIC ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 498 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE IF (MAPCOL_PROVIDED) THEN IPROC = MAPCOL(NODE) IF (IPROC.NE.MYID) THEN PVS(NODE) = -999 CYCLE ENDIF ENDIF PV = PVS(NODE) NV = 0 NVEXPANDED = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 NVEXPANDED = NVEXPANDED+SIZEOFBLOCKS(F) WORK(NV) = F F = FILS(F) END DO COMPRESS_RATIO = real(NVEXPANDED)/real(NV) CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED, & ND_STEPS(NODE), KEEP(35)) IF (NVEXPANDED .GE. GROUP_SIZE2 & .AND. NVEXPANDED.GE.int(dble(SEP_SIZE)*dble(1.5)) & ) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN GROUP_SIZE2_TMP = GROUP_SIZE2 GROUP_SIZE2_TMP = max( int(real(GROUP_SIZE2_TMP) & /COMPRESS_RATIO), 1) !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + ( (NV-1)/GROUP_SIZE2_TMP + 1 ) !$OMP END ATOMIC DO I=1,NV LRGROUPS(WORK(I))=NBG_CAPT+1+(I-1)/GROUP_SIZE2_TMP END DO K142 = max(K142, min(NV,GROUP_SIZE2_TMP)) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING_AB( ND_STEPS(NODE), KEEP, & NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K142, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING_AB( ND_STEPS(NODE), KEEP, & NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K142, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NVEXPANDED .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF K142 = max (K142,NV) ENDIF ENDDO !$OMP END DO 498 CONTINUE IF (NPROCS.GT.1) THEN !$OMP MASTER CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) !$OMP END MASTER !$OMP BARRIER ENDIF IF (IFLAG.LT.0) GOTO 500 IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP MASTER IF (K469_LOC.NE.2) THEN IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF !$OMP END MASTER IF (.NOT.MAPCOL_PROVIDED) THEN !$OMP MASTER IF (PVSCHANGED) THEN PVSCHANGED_INT_GLOB = 1 ELSE PVSCHANGED_INT_GLOB = 0 ENDIF !$OMP END MASTER ELSE !$OMP MASTER IF (PVSCHANGED) THEN PVSCHANGED_INT = 1 ELSE PVSCHANGED_INT = 0 ENDIF CALL MPI_ALLREDUCE( PVSCHANGED_INT, PVSCHANGED_INT_GLOB, 1, & MPI_INTEGER, & MPI_MAX, COMM, IERR_MPI ) PVSCHANGED_INT_GLOB = 1 IF (PVSCHANGED_INT_GLOB.NE.0) THEN IF (NPROCS.GT.1) THEN ALLOCATE(WORKH(2*N+3*NSTEPS+1), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of ", & "size: ", 2*MAXFRONT+1 IFLAG = -7 IERROR = 2*N+3*NSTEPS+1 ENDIF CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) IF (IFLAG.LT.0) GOTO 499 IF (MYID.EQ.MASTER) THEN IPROC = 0 DO WHILE (IPROC.NE.NPROCS-1) IPROC = IPROC + 1 CALL MPI_RECV( NBNODES_LOC, 1, MPI_INTEGER, & MPI_ANY_SOURCE, & GROUPING, COMM, STATUS, IERR ) MSGSOU = STATUS( MPI_SOURCE ) IF (NBNODES_LOC.EQ.0) THEN CYCLE ENDIF CALL MPI_RECV( NBGROUPS_sent, 1, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) CALL MPI_RECV( SIZE_SENT, 1, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) CALL MPI_RECV( WORKH, SIZE_SENT, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) ISHIFT = 0 DO ILOOP=1, NBNODES_LOC ISHIFT = ISHIFT+1 NODE = WORKH (ISHIFT) ISHIFT = ISHIFT+1 NV = WORKH(ISHIFT) PVS(NODE) = WORKH(ISHIFT+1) STEP(WORKH(ISHIFT+1)) = NODE IF (STEP(WORKH(ISHIFT+1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORKH(ISHIFT+1) ELSE K20 = WORKH(ISHIFT+1) END IF END IF DO I=2, NV STEP(WORKH(I+ISHIFT)) = -NODE END DO DO I=1, NV FILS(WORKH(I+ISHIFT)) = WORKH(I+1+ISHIFT) IF (WORKH(NV+1+I+ISHIFT).LT.0) THEN LRGROUPS(WORKH(I+ISHIFT)) = & - NBGROUPS + WORKH(NV+1+I+ISHIFT) ELSE LRGROUPS(WORKH(I+ISHIFT)) = & NBGROUPS + WORKH(NV+1+I+ISHIFT) END IF END DO ISHIFT = ISHIFT + 2*NV +1 END DO NBGROUPS = NBGROUPS + NBGROUPS_sent ENDDO ELSE NBNODES_LOC = 0 SIZE_SENT = 0 ISHIFT = 0 DO NODE = 1,NSTEPS IPROC = MAPCOL(NODE) IF (IPROC.EQ.MYID) THEN NBNODES_LOC = NBNODES_LOC + 1 ISHIFT = ISHIFT +1 WORKH(ISHIFT) = NODE ISHIFT = ISHIFT +1 NV = 0 F = PVS(NODE) DO WHILE (F.GT.0) NV = NV + 1 WORKH(NV+ISHIFT) = F F = FILS(F) ENDDO WORKH(ISHIFT) = NV WORKH(NV+1+ISHIFT) = F DO I=1, NV WORKH(NV+1+I+ISHIFT) = LRGROUPS(WORKH(I+ISHIFT)) ENDDO ISHIFT = ISHIFT + 2*NV+1 ENDIF ENDDO SIZE_SENT = ISHIFT CALL MPI_SEND( NBNODES_LOC, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) IF (NBNODES_LOC.GT.0) THEN CALL MPI_SEND( NBGROUPS, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) CALL MPI_SEND( SIZE_SENT, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) CALL MPI_SEND( WORKH, SIZE_SENT, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) ENDIF ENDIF ENDIF ENDIF 499 CONTINUE !$OMP END MASTER ENDIF !$OMP BARRIER IF (IFLAG.LT.0) GOTO 500 IF (MYID.EQ.MASTER) THEN IF (PVSCHANGED_INT_GLOB.EQ.0) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO ENDIF 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL IF (NPROCS.GT.1) THEN K142_GLOB = 0 CALL MPI_REDUCE( K142, K142_GLOB, 1, & MPI_INTEGER, & MPI_MAX, MASTER, COMM, IERR_MPI ) K142 = K142_GLOB ENDIF #if defined(ptscotch) || defined(scotch) IF (K482_LOC.EQ.2.AND.NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (PTHREAD_NUMBER) ENDIF #endif 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) RETURN END SUBROUTINE SMUMPS_AB_LR_MPI_GROUPING END MODULE SMUMPS_ANA_LR MUMPS_5.8.1/src/sfac_driver.F0000664000175000017500000056531615042446441015647 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_FAC_DRIVER(id,idintr) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_INI_MYID, MUMPS_BUF_INIT, & MUMPS_BUF_ALLOC_SMALL_BUF, MUMPS_BUF_DEALL_SMALL_BUF, & MUMPS_BUF_DIST_IRECV_SIZE USE MUMPS_LOAD USE SMUMPS_OOC, ONLY : SMUMPS_OOC_INIT_FACTO, & SMUMPS_OOC_END_FACTO USE SMUMPS_STRUC_DEF USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_INTR_STRUC USE SMUMPS_FACSOL_L0OMP_M, ONLY: SMUMPS_FREE_L0_OMP_FACTORS, & SMUMPS_INIT_L0_OMP_FACTORS USE SMUMPS_DYNAMIC_MEMORY_M, ONLY: SMUMPS_DM_ALLOC_S_WK, & SMUMPS_DM_FREE_S_WK USE MUMPS_LR_STATS USE SMUMPS_LR_DATA_M, only: SMUMPS_BLR_INIT_MODULE, & SMUMPS_BLR_END_MODULE & , SMUMPS_BLR_MOD_TO_STRUC USE SMUMPS_FAC_COMPACT_FACTORS_M, ONLY: & SMUMPS_TRY_COMPACT_FACTORS USE MUMPS_PIVNUL_MOD, only: PIVNUL_LIST_STRUCT_T USE MUMPS_FRONT_DATA_MGT_M #if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M #endif #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif !$ USE OMP_LIB C Derived datatype to pass pointers with implicit interfaces USE SMUMPS_FAC_S_IS_POINTERS_M, ONLY : SMUMPS_S_IS_POINTERS_T IMPLICIT NONE C C Purpose C ======= C C Performs scaling, sorting in arrowhead, then C distributes the matrix, and perform C factorization. C C INTERFACE SUBROUTINE SMUMPS_ANORMINF(id, ANORMINF, LSCAL, EFF_SIZE_SCHUR) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET :: id REAL, INTENT(OUT) :: ANORMINF LOGICAL, INTENT(IN) :: LSCAL INTEGER, INTENT(IN) :: EFF_SIZE_SCHUR END SUBROUTINE SMUMPS_ANORMINF END INTERFACE C C Parameters C ========== C TYPE (SMUMPS_STRUC), TARGET :: id TYPE (SMUMPS_INTR_STRUC) :: idintr C C MPI C === C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 C C Local variables C =============== C INCLUDE 'mumps_headers.h' INTEGER(8) :: NSEND8, NSEND_TOT8 INTEGER(8) :: NLOCAL8, NLOCAL_TOT8 INTEGER(4) :: I4 INTEGER :: LDPTRAR, NELT_arg, NBRECORDS INTEGER :: ITMP, JTMP INTEGER :: KEEP464COPY, KEEP465COPY INTEGER(8) :: KEEP826_SAVE INTEGER(8) :: K67, K68, K70, K74, K75 INTEGER(8) ITMP8 INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER MP, LP, MPG, allocok LOGICAL PROK, PROKG, LSCAL, LPOK, COMPUTE_ANORMINF C Reception buffer INTEGER :: SMUMPS_LBUFR, SMUMPS_LBUFR_BYTES INTEGER(8) :: SMUMPS_LBUFR_BYTES8 ! for intermediate computation INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFR C Size of send buffers (in bytes) INTEGER :: SMUMPS_LBUF, SMUMPS_LBUF_INT INTEGER(8) :: SMUMPS_LBUF8 ! for intermediate computation C INTEGER PTRIST, PTRWB, MAXELT_SIZE, & ITLOC, IPOOL, LPOOL INTEGER IRANK, ID_ROOT INTEGER KKKK INTEGER(8) :: NZ_locMAX8 INTEGER(8) MEMORY_MD_ARG INTEGER(8) MAXS_BASE8, MAXS_BASE_RELAXED8 REAL CNTL4, AVG_FLOPS INTEGER MIN_PERLU, MAXIS_ESTIM INTEGER SUM_INFO22_THIS_NODE, MAX_SUM_INFO22_THIS_NODE C TYPE (SMUMPS_S_IS_POINTERS_T) :: S_IS_POINTERS INTEGER :: MAXIS INTEGER(8) :: MAXS INTEGER :: ICNTL49_LOC, TMP_INFOG_4 C For S argument to arrowhead routines: INTEGER(8) :: MAXS_ARG REAL, TARGET :: S_DUMMY_ARG(1) REAL, POINTER, DIMENSION(:) :: S_PTR_ARG TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT C Arrowheads INTEGER, ALLOCATABLE, DIMENSION(:) :: INTARR REAL, POINTER, DIMENSION(:) :: DBLARR C (pointer to point on used-data in some cases--elt-entry) REAL TMPTIME INTEGER NOMP INTEGER NB_THREADS DOUBLE PRECISION TIMEAVG, TIMEMAX, & FLOPAVG, FLOPMAX REAL TMPFLOP INTEGER NPIV_CRITICAL_PATH, EFF_SIZE_SCHUR DOUBLE PRECISION TIME, TIMEET REAL ZERO, ONE, MONE PARAMETER( ZERO = 0.0E0, ONE = 1.0E0, MONE = -1.0E0) REAL CZERO PARAMETER( CZERO = 0.0E0 ) INTEGER PERLU, TOTAL_MBYTES, K231, K232, K233, BLR_STRAT INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. INTEGER, PARAMETER :: PANEL_TABSIZE = 20 INTEGER COLOUR, COMM_FOR_SCALING ! For Simultaneous scaling INTEGER(8) :: LIWK, LIWK8 INTEGER(8) :: LWK, LWK_REAL, LWRKR_TH, LWRKC_TH INTEGER :: NOMP_MAX C I_AM_SLAVE: used to determine if proc has the role of a slave C WK_USER_PROVIDED is set to true when WK_USER is provided by user LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED, EARLYT3ROOTINS LOGICAL PRINT_MAXAVG, PRINT_NODEINFO REAL :: ANORMINF, SEUIL, SEUIL_LDLT_NIV2, Thresh_Seuil REAL :: CNTL1, CNTL3, CNTL5, CNTL6, EPS INTEGER N, LPN_LIST,POSBUF INTEGER, DIMENSION (:), ALLOCATABLE :: ITMP2 INTEGER I,K INTEGER(8) :: ITEMP8 INTEGER :: PARPIV_T1 INTEGER FRONTWISE C temporary variables for collecting stats from all processors INTEGER, PARAMETER :: LR_DKEEPSHIFT=49, LR_TABSIZE=18 DOUBLE PRECISION :: LR_TAB(LR_TABSIZE), LR_EPSILON DOUBLE PRECISION :: TMP_MRY_LU_FR DOUBLE PRECISION :: TMP_MRY_LU_LRGAIN INTEGER :: KEEP399_SAVE, KEEP20_SAVE DOUBLE PRECISION :: TMP_MRY_CB_FR DOUBLE PRECISION :: TMP_MRY_CB_LRGAIN DOUBLE PRECISION :: TMP_FLOP_LRGAIN DOUBLE PRECISION :: TMP_FLOP_TRSM DOUBLE PRECISION :: TMP_FLOP_PANEL DOUBLE PRECISION :: TMP_FLOP_FRFRONTS DOUBLE PRECISION :: TMP_FLOP_TRSM_FR DOUBLE PRECISION :: TMP_FLOP_TRSM_LR DOUBLE PRECISION :: TMP_FLOP_UPDATE_FR DOUBLE PRECISION :: TMP_FLOP_UPDATE_LR DOUBLE PRECISION :: TMP_FLOP_UPDATE_LRLR3 DOUBLE PRECISION :: TMP_FLOP_COMPRESS DOUBLE PRECISION :: TMP_FLOP_DECOMPRESS DOUBLE PRECISION :: TMP_FLOP_MIDBLK_COMPRESS DOUBLE PRECISION :: TMP_FLOP_FRSWAP_COMPRESS DOUBLE PRECISION :: TMP_FLOP_ACCUM_COMPRESS DOUBLE PRECISION :: TMP_FLOP_CB_COMPRESS DOUBLE PRECISION :: TMP_FLOP_CB_DECOMPRESS DOUBLE PRECISION :: TMP_FLOP_FACTO_FR INTEGER :: TMP_CNT_NODES DOUBLE PRECISION :: TMP_TIME_UPDATE DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR1 DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR2 DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR3 DOUBLE PRECISION :: TMP_TIME_UPDATE_FRLR DOUBLE PRECISION :: TMP_TIME_UPDATE_FRFR DOUBLE PRECISION :: TMP_TIME_COMPRESS DOUBLE PRECISION :: TMP_TIME_MIDBLK_COMPRESS DOUBLE PRECISION :: TMP_TIME_FRSWAP_COMPRESS DOUBLE PRECISION :: TMP_TIME_CB_COMPRESS DOUBLE PRECISION :: TMP_TIME_PANEL DOUBLE PRECISION :: TMP_TIME_FAC_I DOUBLE PRECISION :: TMP_TIME_FAC_MQ DOUBLE PRECISION :: TMP_TIME_FAC_SQ DOUBLE PRECISION :: TMP_TIME_LRTRSM DOUBLE PRECISION :: TMP_TIME_FRTRSM DOUBLE PRECISION :: TMP_TIME_FRFRONTS DOUBLE PRECISION :: TMP_TIME_LR_MODULE DOUBLE PRECISION :: TMP_TIME_DIAGCOPY DOUBLE PRECISION :: TMP_TIME_DECOMP DOUBLE PRECISION :: TMP_TIME_DECOMP_UCFS DOUBLE PRECISION :: TMP_TIME_LRASM_NIV1 DOUBLE PRECISION :: TMP_TIME_LRASM_LOCASM2 DOUBLE PRECISION :: TMP_TIME_LRASM_MAPLIG1 DOUBLE PRECISION :: TMP_TIME_LRASM_CONTRIB2 DOUBLE PRECISION :: TMP_TIME_FRASM_LOCASM2 DOUBLE PRECISION :: TMP_TIME_FRASM_MAPLIG1 DOUBLE PRECISION :: TMP_TIME_FRASM_CONTRIB2 C C Workspace C INTEGER, DIMENSION(:), ALLOCATABLE :: IWK REAL, DIMENSION(:), ALLOCATABLE :: WK REAL, DIMENSION(:), ALLOCATABLE :: WK_REAL REAL, DIMENSION(:,:), ALLOCATABLE:: WRKR_TH, & WRKC_TH INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWK8 INTEGER, DIMENSION(:), ALLOCATABLE :: BURP INTEGER, DIMENSION(:), ALLOCATABLE :: BUCP INTEGER, DIMENSION(:), ALLOCATABLE :: BURS INTEGER, DIMENSION(:), ALLOCATABLE :: BUCS INTEGER(8) :: BUREGISTRE(12) INTEGER(8) :: BUINTSZ, BURESZ, NZ_loc8 INTEGER :: BUJOB INTEGER BUMAXMN, M, SCMYID, SCNPROCS REAL SCONEERR, SCINFERR C C Parameters arising from the structure C ===================================== C * Control parameters: see description in SMUMPSID REAL,DIMENSION(:),POINTER::RINFO, RINFOG REAL,DIMENSION(:),POINTER:: CNTL INTEGER,DIMENSION(:),POINTER :: INFOG, KEEP INTEGER, DIMENSION(:), POINTER :: IRN_loc_PTR, JCN_loc_PTR REAL, DIMENSION(:), POINTER :: COLSCA_PTR, & ROWSCA_PTR REAL, DIMENSION(:), POINTER:: A_loc_PTR INTEGER, TARGET :: DUMMYIRN_loc(1), DUMMYJCN_loc(1) REAL, TARGET :: DUMMYSCA(1) REAL, TARGET :: DUMMYA_loc(1) INTEGER,DIMENSION(:),POINTER::ICNTL EXTERNAL MUMPS_GET_POOL_LENGTH INTEGER MUMPS_GET_POOL_LENGTH, SIZESCAL INTEGER(8) :: TOTAL_BYTES C C External references C =================== INTEGER, EXTERNAL :: MUMPS_NUMROC INTEGER:: NWORKING LOGICAL:: MEM_EFF_ALLOCATED INTEGER :: TOTAL_MBYTES_UNDER_L0 INTEGER(8):: TOTAL_BYTES_UNDER_L0 C Fwd in facto: REAL, DIMENSION(:), POINTER :: RHS_MUMPS LOGICAL :: RHS_MUMPS_ALLOCATED LOGICAL :: DBLARR_ALLOCATED INTEGER :: NB_ACTIVE_FRONTS_ESTIM INTEGER :: NB_FRONTS_F_ESTIM INTEGER :: KEEP_486_FOR_PRINT C C -------------------------- C Pointers used as shortcuts C -------------------------- RINFO=>id%RINFO RINFOG=>id%RINFOG CNTL=>id%CNTL INFOG=>id%INFOG KEEP=>id%KEEP ICNTL=>id%ICNTL IF (id%KEEP8(29) .NE. 0) THEN IRN_loc_PTR=>id%IRN_loc JCN_loc_PTR=>id%JCN_loc A_loc_PTR=>id%A_loc ELSE IRN_loc_PTR=>DUMMYIRN_loc JCN_loc_PTR=>DUMMYJCN_loc A_loc_PTR=>DUMMYA_loc ENDIF NOMP = 1 N = id%N C TIMINGS: reset to 0 id%DKEEP(92)=0.0E0 id%DKEEP(93)=0.0E0 id%DKEEP(94)=0.0E0 id%DKEEP(95)=0.0E0 id%DKEEP(96)=0.0E0 id%DKEEP(97)=0.0E0 id%DKEEP(98)=0.0E0 id%DKEEP(99)=0.0E0 id%DKEEP(56)=0.0E0 C Count of MPI messages: reset to 0 id%KEEP(266)=0 id%KEEP(267)=0 C ------------------------------------- C Depending on the type of parallelism, C the master can now (soon) potentially C have the role of a slave C ------------------------------------- I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) LIWK = 0_8 LIWK8 = 0_8 C RR related id%KEEP(17) = 0 id%INFOG(28) = 0 C Number of symmetric swaps id%KEEP8(80)=0_8 C Largest increase of internal panel size id%KEEP(425) =0 C Dynamic memory during process_blocfacto, in number of scalar entries id%KEEP8(130) = 0_8 ! instantaneous id%KEEP8(131) = 0_8 ! max id%KEEP8(132) = 0_8 ! max of max id%KEEP8(133) = 0_8 ! sum of max C Measure recursivity =max number of simultaneous calls to C SMUMPS_FAC_PROCESS_BLOCFACTO_LDLT id%KEEP(174) = 0 id%KEEP(175) = 0 C KEEP20_SAVE = KEEP(20) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) C Print per node informtation only in case ther are several C compute nodes (id%KEEP(412): #MPI procs on comupte node) PRINT_NODEINFO = PRINT_MAXAVG .AND. id%NPROCS .NE. id%KEEP(412) C C Related to forward in facto functionality (referred to as "Fwd in facto") NULLIFY(RHS_MUMPS) NULLIFY(DBLARR) RHS_MUMPS_ALLOCATED = .FALSE. DBLARR_ALLOCATED = .FALSE. C ----------------------------------------------------------------------- C Set WK_USER_PROVIDED to true when workspace WK_USER is provided by user C We can accept WK_USER to be provided on only one proc and C different values of WK_USER per processor C WK_USER(LWK_USER): only on working processes WK_USER_PROVIDED = (id%LWK_USER.NE.0 .AND. I_AM_SLAVE) IF (WK_USER_PROVIDED) THEN IF (id%LWK_USER.GT.0) THEN id%KEEP8(24) = int(id%LWK_USER,8) ELSE id%KEEP8(24) = -int(id%LWK_USER,8)* 1000000_8 ENDIF ELSE id%KEEP8(24) = 0_8 ENDIF C Compute sum of LWK_USER provided by user CALL MPI_REDUCE ( id%KEEP8(24), id%KEEP8(124), 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) C C KEEP8(26) might be modified C (element entry format) C but need be restore for C future factorisation C with different scaling option C KEEP826_SAVE = id%KEEP8(26) C In case of loop on factorization with C different scaling options, initialize C DKEEP(4:5) to 0. id%DKEEP(4)=-1.0E0 id%DKEEP(5)=-1.0E0 C Mapping information used during solve. In case of several facto+solve C it has to be recomputed. In case of several solves with the same C facto, it is not recomputed. IF (associated(id%IPTR_WORKING)) THEN DEALLOCATE(id%IPTR_WORKING) NULLIFY(id%IPTR_WORKING) END IF IF (associated(id%WORKING)) THEN DEALLOCATE(id%WORKING) NULLIFY(id%WORKING) END IF C C Units for printing C MP: diagnostics C LP: errors C LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) IF ( PROK ) WRITE( MP, 130 ) IF ( PROKG ) WRITE( MPG, 130 ) C C Prepare work for out-of-core C IF (id%MYID .EQ. MASTER .AND. KEEP(201) .NE. -1) THEN C Note that if KEEP(201)=-1, then we have decided C at analysis phase that factors will not be stored C (neither in memory nor on disk). In that case, C ICNTL(22) is ignored. C -- ICNTL(22) must be set before facto phase C (=1 OOC on; =0 OOC off) C and cannot be changed for subsequent solve phases. KEEP(201)=id%ICNTL(22) IF (KEEP(201) .EQ. 1) THEN # if defined(OLD_OOC_NOPANEL) KEEP(201)=2 # else KEEP(201)=1 # endif ELSE id%KEEP(201)=0 ENDIF ENDIF C C ---------------------- C Broadcast ICNTL(49) IF (id%MYID.EQ.MASTER) THEN ICNTL49_LOC=id%ICNTL(49) C out of range treated as 0 IF ( (ICNTL49_LOC.GT.2).or.(ICNTL49_LOC.LT.0) ) & ICNTL49_LOC = 0 ENDIF CALL MPI_BCAST( ICNTL49_LOC, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C ---------------------- C C Broadcast few other KEEP entries that have been decoded C and are defined for facto: C ---------------------- CALL MPI_BCAST( KEEP(12), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(19), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(21), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(459), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(460), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF ( KEEP(459) .GE. PANEL_TABSIZE ) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I4,A,I3)') " ** WARNING ** KEEP(459)=",KEEP(459), & " too large, resetting to",PANEL_TABSIZE-1 ENDIF KEEP(459) = PANEL_TABSIZE - 1 ENDIF PERLU = KEEP(12) IF (id%MYID.EQ.MASTER) THEN C { C KEEP(50) case C ============== C C KEEP(50) = 0 : matrix is unsymmetric C KEEP(50) /= 0 : matrix is symmetric C KEEP(50) = 1 : Ask L L^T on the root. Matrix is PSD. C KEEP(50) = 2 : Ask for L U on the root C KEEP(50) = 3 ... L D L^T ?? C CNTL1 = id%CNTL(1) C --------------------------------------- C For symmetric (non general) matrices C set (directly) CNTL1 = 0.0 C --------------------------------------- KEEP(17)=0 C Automatic choice if CNTL(1)<0 C For rank-revealing (KEEP(19).GT.0) then C set CNTL1=0.1 even if SYM=1 IF (CNTL1.LT.ZERO) THEN C automatic choice IF (KEEP(19).GT.0) THEN CNTL1=0.1E0 ELSE IF (KEEP(50).EQ.1) THEN CNTL1=ZERO ELSE CNTL1=0.01E0 ENDIF ENDIF IF ( KEEP(50) .eq. 1 ) THEN IF (CNTL1 .ne. ZERO ) THEN IF ( PROKG ) THEN WRITE(MPG,'(A)') & '** Warning : SPD solver called, resetting CNTL(1) to 0.0E0' END IF END IF CNTL1 = ZERO END IF C CNTL1 threshold value must be between C 0.0 and 1.0 (for SYM=0) and 0.5 (for SYM=1,2) IF (CNTL1.GT.ONE) CNTL1=ONE IF (CNTL1.LT.ZERO) CNTL1=ZERO IF (KEEP(50).NE.0.AND.CNTL1.GT.0.5E0) THEN CNTL1 = 0.5E0 ENDIF PARPIV_T1 = id%KEEP(268) IF (PARPIV_T1.EQ.77) THEN PARPIV_T1 = 0 #if defined(__ve__) PARPIV_T1 = -2 #endif ENDIF IF (PARPIV_T1.EQ.-3) THEN PARPIV_T1 = 0 ENDIF IF ((PARPIV_T1.LT.-3).OR.(PARPIV_T1.GT.1)) THEN C out of range values PARPIV_T1 =0 ENDIF C note that KEEP(50).EQ.1 => CNTL1=0.0 IF (CNTL1.EQ.0.0E0.OR.(KEEP(50).eq.1)) PARPIV_T1 = 0 C IF (PARPIV_T1.EQ.-2) THEN IF (KEEP(19).NE.0) THEN C switch off PARPIV_T1 if RR activated C but do NOT switch off PARPIV_1 with null pivot detection PARPIV_T1 = 0 ENDIF ENDIF id%KEEP(269) = PARPIV_T1 C } ENDIF CALL MPI_BCAST(CNTL1, 1, MPI_REAL, & MASTER, id%COMM, IERR) CALL MPI_BCAST( KEEP(269), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (id%MYID.EQ.MASTER) THEN C{ C OMP parallelization of arrowheads C out of range are treated as zero IF (KEEP(399).LT.-1) KEEP(399)=-1 KEEP399_SAVE = KEEP(399) IF (KEEP(399).EQ.-1) THEN IF ((KEEP(54).EQ.0).AND.(id%NPROCS.GT.1)) THEN KEEP(399) = 1 ELSE KEEP(399) = 3 ENDIF ENDIF #if defined(PCPRET) C new multithreaded >=2 algo does not compile on PCPRET KEEP(399) = 1 #endif C ----------------------------------------------------- C Decoding of ICNTL(35) for factorization: same as C at analysis except that we store a copy of ICNTL(35) C in KEEP(486) instead of KEEP(494) and need to check C compatibility of KEEP(486) and KEEP(494): If LR was C not activated during analysis, it cannot be activated C at factorization. C ------------------------------------------------------ id%KEEP(486) = id%ICNTL(35) IF (id%KEEP(486).EQ.1) THEN C -- Automatic BLR option setting id%KEEP(486)= 2 ENDIF IF ( id%KEEP(486).EQ.4) id%KEEP(486)=0 IF ((id%KEEP(486).LT.0).OR.(id%KEEP(486).GT.4)) THEN C Out of range values treated as 0 id%KEEP(486) = 0 ENDIF IF ((KEEP(486).NE.0).AND.(KEEP(494).EQ.0)) THEN C To activate BLR during factorization, C ICNTL(35) must have been set at analysis. IF (LPOK) THEN WRITE(LP,'(A)') & " *** Error with BLR setting " WRITE(LP,'(A)') " *** BLR was not activated during ", & " analysis but is requested during factorization." ENDIF id%INFO(1)=-54 id%INFO(2)=0 GOTO 105 ENDIF C Save value of KEEP(486) before possibly C forcing it to 3 in case of discard factors KEEP_486_FOR_PRINT=KEEP(486) IF (KEEP(201) .EQ. -1 .AND. KEEP(486) .NE.0) THEN KEEP(486) = 3 ENDIF KEEP464COPY = id%ICNTL(38) IF (KEEP464COPY.LT.0.OR.KEEP464COPY.GT.1000) THEN C Out of range values treated as 1000 KEEP464COPY = 1000 ENDIF IF (id%KEEP(461).LT.1) THEN id%KEEP(461) = 10 ENDIF IF (id%KEEP(462).LT.1) THEN id%KEEP(462) = 10 ENDIF KEEP465COPY = id%ICNTL(39) IF (KEEP465COPY.LT.0.OR.(KEEP465COPY.GT.1000)) THEN C Out of range values treated as 1000 KEEP465COPY = 1000 ENDIF IF (id%ICNTL(36).EQ.1.OR.id%ICNTL(36).EQ.3) THEN IF (CNTL1.EQ.ZERO .OR. KEEP(468).LE.1) THEN KEEP(475) = 3 ELSE IF ( (KEEP(269).GT.0).OR. (KEEP(269).EQ.-2)) THEN KEEP(475) = 2 ELSE IF (KEEP(468).EQ.2) THEN KEEP(475) = 2 ELSE KEEP(475) = 1 ENDIF ELSE KEEP(475) = 0 ENDIF KEEP(481)=0 IF (id%ICNTL(36).LT.0 .OR. id%ICNTL(36).GE.2) THEN C Only options 1 and 2 are allowed KEEP(475) = 0 ENDIF C K489 is set according to ICNTL(37) IF (id%ICNTL(37).EQ.0.OR.id%ICNTL(37).EQ.1) THEN KEEP(489) = id%ICNTL(37) ELSE C Other values treated as zero KEEP(489) = 0 ENDIF IF (KEEP(79).GE.1) THEN C CompressCB incompatible with type4,5,6 nodes KEEP(489)=0 ENDIF C id%KEEP(476) \in [1,100] IF ((id%KEEP(476).GT.100).OR.(id%KEEP(476).LT.1)) THEN id%KEEP(476)= 50 ENDIF C id%KEEP(477) \in [1,100] IF ((id%KEEP(477).GT.100).OR.(id%KEEP(477).LT.1)) THEN id%KEEP(477)= 100 ENDIF C id%KEEP(483) \in [1,100] IF ((id%KEEP(483).GT.100).OR.(id%KEEP(483).LT.1)) THEN id%KEEP(483)= 80 ENDIF C id%KEEP(484) \in [1,100] IF ((id%KEEP(484).GT.100).OR.(id%KEEP(484).LT.1)) THEN id%KEEP(484)= 80 ENDIF C id%KEEP(480)=0,2,3,4,5,6 IF ((id%KEEP(480).GT.6).OR.(id%KEEP(480).LT.0) & .OR.(id%KEEP(480).EQ.1)) THEN id%KEEP(480)=0 ENDIF C id%KEEP(473)=0 or 1 IF ((id%KEEP(473).NE.0).AND.(id%KEEP(473).NE.1)) THEN id%KEEP(473)=0 ENDIF C id%KEEP(474)=0,1,2,3 IF ((id%KEEP(474).GT.3).OR.(id%KEEP(474).LT.0)) THEN id%KEEP(474)=0 ENDIF C id%KEEP(479)>0 IF (id%KEEP(479).LE.0) THEN id%KEEP(479)=1 ENDIF IF (id%KEEP(474).NE.0.AND.id%KEEP(480).EQ.0) THEN id%KEEP(474) = 0 ENDIF IF (id%KEEP(478).NE.0.AND.id%KEEP(480).LT.4) THEN id%KEEP(478) = 0 ENDIF IF (id%KEEP(480).GE.5 .OR. & (id%KEEP(480).NE.0.AND.id%KEEP(474).EQ.3)) THEN IF (id%KEEP(475).LT.2) THEN C Reset to 3 if 5 or to 4 if 6 id%KEEP(480) = id%KEEP(480) - 2 write(*,*) ' Resetting KEEP(480) to ', id%KEEP(480) ENDIF ENDIF 105 CONTINUE C} ENDIF ! id%MYID .EQ. MASTER CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C IF (id%INFO(1).LT.0) GOTO 530 EPS = epsilon ( ZERO ) CALL MPI_BCAST( KEEP(281), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(399), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(473), 14, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (KEEP(486).NE.0) THEN CALL MPI_BCAST( KEEP(489), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP464COPY, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP465COPY, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF IF (id%MYID.EQ.MASTER) THEN IF (KEEP(217).GT.2.OR.KEEP(217).LT.0) THEN KEEP(217)=0 ENDIF KEEP(214)=KEEP(217) IF (KEEP(214).EQ.0) THEN IF (KEEP(201).NE.0) THEN ! OOC or no factors KEEP(214)=1 ELSE KEEP(214)=2 ENDIF IF (KEEP(486).EQ.2) THEN KEEP(214)=1 ENDIF ENDIF ENDIF CALL MPI_BCAST( KEEP(214), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (KEEP(201).NE.0) THEN C -- Low Level I/O strategy CALL MPI_BCAST( KEEP(99), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(205), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(211), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(255), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF C Fwd in facto: explicitly forbid C sparse RHS and A-1 computation IF (id%KEEP(252).EQ.1 .AND. id%MYID.EQ.MASTER) THEN IF (id%ICNTL(20).EQ.1) THEN ! out-of-range => 0 C NB: in doc ICNTL(20) only accessed during solve C In practice, will have failed earlier if RHS not allocated. C Still it looks safer to keep this test. id%INFO(1)=-43 id%INFO(2)=20 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: Sparse RHS is incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE IF (id%ICNTL(30).NE.0) THEN ! out-of-range => 1 id%INFO(1)=-43 id%INFO(2)=30 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: A-1 functionality incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE IF (id%ICNTL(9) .NE. 1) THEN id%INFO(1)=-43 id%INFO(2)=9 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C IF (id%INFO(1).LT.0) GOTO 530 C C The memory allowed is given by ICNTL(23) in Mbytes C 0 means that nothing is provided. C Save memory available, ICNTL(23) in KEEP8(4) C IF ( ICNTL(23) .GT. 0 ) THEN ITMP = 1 ELSE ITMP = 0 ENDIF CALL MPI_ALLREDUCE( ITMP, JTMP, 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) IF ( id%MYID.EQ.MASTER ) THEN C Negative values considered 0 ITMP = max(ICNTL(23),0) END IF CALL MPI_BCAST( ITMP, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C JTMP: nb of procs with nonzero ICNTL(23) C ITMP: value of ICNTL(23) on master IF ( ITMP .GT. 0 .AND. JTMP .EQ. 1 ) THEN C ICNTL(23)>0 only on master ELSE C Local values of ICNTL(23) are used, note that C they could all be zeros ITMP = ICNTL(23) ENDIF C ITMP8 = int(ITMP, 8) id%KEEP8(4) = ITMP8 * 1000000_8 ! convert to nb of bytes C Compute \sum of memories allowed CALL MPI_REDUCE( id%KEEP8(4), ITMP8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) ITMP8 = ITMP8 / 1000000_8 ! Use to print \sum_{ICNTL(23)} IF ( PROKG ) THEN NWORKING = id%NSLAVES CALL MUMPS_SETI8TOI4( id%KEEP8(129), TMP_INFOG_4) WRITE( MPG, 172 ) & NWORKING, id%ICNTL(22), KEEP_486_FOR_PRINT, & KEEP(489), & id%ICNTL(49), & id%KEEP(19), & KEEP(12), & id%KEEP8(111), TMP_INFOG_4, KEEP(127), KEEP(28), & id%KEEP8(4)/1000000_8, ITMP8, id%KEEP8(124), CNTL1 IF (KEEP(252).GT.0) & WRITE(MPG,173) KEEP(253) IF (KEEP(269).NE.0) & WRITE(MPG,174) KEEP(269) ENDIF IF (KEEP(201).LE.0) THEN C In-core version or no factors KEEP(IXSZ)=XSIZE_IC ELSE IF (KEEP(201).EQ.2) THEN C OOC version, no panels KEEP(IXSZ)=XSIZE_OOC_NOPANEL ELSE IF (KEEP(201).EQ.1) THEN C Panel versions: IF (KEEP(50).EQ.0) THEN KEEP(IXSZ)=XSIZE_OOC_UNSYM ELSE KEEP(IXSZ)=XSIZE_OOC_SYM ENDIF ENDIF IF ( KEEP(486) .NE. 0 ) THEN !LR is activated C Stats initialization for LR CALL INIT_STATS_GLOBAL() END IF C Memory management: allocate id%S etc. from C or Fortran? id%KEEP(430) = 0 #if defined(MUMPS_MALLOC_FROM_C) id%KEEP(430) = 1 #endif C * ********************************** * Begin intializations regarding the * computation of the determinant * ********************************** IF (id%MYID.EQ.MASTER) KEEP(258)=ICNTL(33) CALL MPI_BCAST(KEEP(258), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF (KEEP(258) .NE. 0) THEN KEEP(259) = 0 ! Initial exponent of the local determinant KEEP(260) = 1 ! Number of permutations id%DKEEP(6) = 1.0E0 ! real part of the local determinant ENDIF * ******************************** * End intializations regarding the * computation of the determinant * ******************************** C CALL MUMPS_STOP_ON_USER_REQUEST(id%KEEP,id%KEEP8, id%ICNTL, & id%INFO, id%MYID) CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0) GOTO 530 * ********************** * Begin of Scaling phase * ********************** C C SCALING MANAGEMENT C * Options 1, 3, 4 centralized only C C * Options 7, 8 : also works for distributed matrix C C At this point, we have the scaling arrays allocated C on the master. They have been allocated on the master C inside the main MUMPS driver. C CALL MPI_BCAST(KEEP(52), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) LSCAL = ((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) IF (LSCAL) THEN C IF ( id%MYID.EQ.MASTER ) THEN CALL MUMPS_SECDEB(TIMEET) ENDIF C ----------------------- C Retrieve parameters for C simultaneous scaling C ----------------------- IF (KEEP(52) .EQ. 7) THEN C -- Cheap setting of SIMSCALING (it is the default in 4.8.4) K231= KEEP(231) K232= KEEP(232) K233= KEEP(233) ELSEIF (KEEP(52) .EQ. 8) THEN C -- More expensive setting of SIMSCALING (it was the default in 4.8.1,2,3) K231= KEEP(239) K232= KEEP(240) K233= KEEP(241) ENDIF CALL MPI_BCAST(id%DKEEP(3),1,MPI_REAL,MASTER, & id%COMM,IERR) C IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. & KEEP(54).NE.0 ) THEN C{ ------------------------------ C Scaling for distributed matrix C We need to allocate scaling C arrays on all processors, not C only the master. C ------------------------------ IF ( id%MYID .NE. MASTER ) THEN IF ( associated(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=N ENDIF ALLOCATE( id%ROWSCA(N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=N ENDIF ENDIF M = N BUMAXMN=M IF(N > BUMAXMN) BUMAXMN = N LIWK = 4_8*int(BUMAXMN,8) ALLOCATE (IWK(LIWK), BURP(M), BUCP(N), & BURS(2* id%NPROCS), BUCS(2* id%NPROCS), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(LIWK+int(M,8)+int(N,8)+ & 4_8*int(id%NPROCS,8) , id%INFO(2)) ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C -- estimation of memory and construction of partvecs BUJOB = 1 C -- LWK not used LWK_REAL = 1_8 LWRKR_TH = 1_8 LWRKC_TH = 1_8 NOMP_MAX = 1 ALLOCATE(WK_REAL(LWK_REAL), & WRKR_TH(LWRKR_TH,NOMP_MAX), & WRKC_TH(LWRKC_TH,NOMP_MAX), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR( & LWK_REAL+ & LWRKR_TH*int(NOMP_MAX,8)+ & LWRKC_TH*int(NOMP_MAX,8), & id%INFO(2)) ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 CALL SMUMPS_SIMSCALEABS( & IRN_loc_PTR(1), JCN_loc_PTR(1), A_loc_PTR(1), & id%KEEP8(29), & M, N, id%NPROCS, id%MYID, id%COMM, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) IF(LIWK < BUINTSZ) THEN DEALLOCATE(IWK) LIWK = BUINTSZ ALLOCATE(IWK(LIWK), stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(LIWK,id%INFO(2)) ENDIF ENDIF DEALLOCATE(WK_REAL, WRKR_TH, WRKC_TH) LWK_REAL = BURESZ C C -- Set NOMP_MAX from KEEP(281) CALL SMUMPS_SET_NOMP_MAX(id%KEEP(281), id%KEEP(361), & N, NOMP_MAX) C IF (NOMP_MAX.LE.1) THEN C temp array per thread not used LWRKR_TH = 1 LWRKC_TH = 1 ELSE LWRKR_TH = N IF (id%KEEP(50).NE.0) THEN C WRKC_TH not used on symmetric matrices LWRKC_TH = 1 ELSE LWRKC_TH = N ENDIF ENDIF ALLOCATE(WK_REAL(LWK_REAL), & WRKR_TH(LWRKR_TH,max(NOMP_MAX,1)), & WRKC_TH(LWRKC_TH,max(NOMP_MAX,1)), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR( & LWK_REAL+ & LWRKR_TH*int(max(NOMP_MAX,1),8)+ & LWRKC_TH*int(max(NOMP_MAX,1),8), & id%INFO(2)) ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C -- estimation of memory and construction of partvecs BUJOB = 2 CALL SMUMPS_SIMSCALEABS( & IRN_loc_PTR(1), JCN_loc_PTR(1), A_loc_PTR(1), & id%KEEP8(29), & M, N, id%NPROCS, id%MYID, id%COMM, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) id%DKEEP(4) = SCONEERR id%DKEEP(5) = SCINFERR CXXXX DEALLOCATE(IWK, BURP,BUCP,BURS, BUCS) DEALLOCATE(WK_REAL, WRKR_TH, WRKC_TH) C} ELSE IF ( KEEP(54) .EQ. 0 ) THEN C{ ------------------ C Centralized matrix C ------------------ IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN C ------------------------------- C Create a communicator of size 1 C ------------------------------- IF (id%MYID.EQ.MASTER) THEN COLOUR = 0 ELSE COLOUR = MPI_UNDEFINED ENDIF CALL MPI_COMM_SPLIT( id%COMM, COLOUR, 0, & COMM_FOR_SCALING, IERR ) IF (id%MYID.EQ.MASTER) THEN M = N BUMAXMN=N IF(N > BUMAXMN) BUMAXMN = N LIWK = 1_8 ALLOCATE(IWK(LIWK), BURP(1), BUCP(1), & BURS(1), BUCS(1), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR( LIWK+4_8, id%INFO(2) ) GOTO 400 ENDIF LWK_REAL = int(M,8) + int(N,8) C C -- Set NOMP_MAX from KEEP(281) CALL SMUMPS_SET_NOMP_MAX(id%KEEP(281), id%KEEP(361), & N, NOMP_MAX) C IF (NOMP_MAX.LE.1) THEN C temp array per thread not used LWRKR_TH = 1 LWRKC_TH = 1 ELSE LWRKR_TH = N IF (id%KEEP(50).NE.0) THEN C WRKC_TH not used on symmetric matrices LWRKC_TH = 1 ELSE LWRKC_TH = N ENDIF ENDIF ALLOCATE(WK_REAL(LWK_REAL), & WRKR_TH(LWRKR_TH,max(NOMP_MAX,1)), & WRKC_TH(LWRKC_TH,max(NOMP_MAX,1)), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR( & LWK_REAL+ & LWRKR_TH*int(max(NOMP_MAX,1),8)+ & LWRKC_TH*int(max(NOMP_MAX,1),8), & id%INFO(2)) ENDIF CALL MPI_COMM_RANK(COMM_FOR_SCALING, SCMYID, IERR) CALL MPI_COMM_SIZE(COMM_FOR_SCALING, SCNPROCS, IERR) BUJOB = 1 CALL SMUMPS_SIMSCALEABS( & id%IRN(1), id%JCN(1), id%A(1), & id%KEEP8(28), & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) IF(LWK_REAL < BURESZ) THEN id%INFO(1) = -136 GOTO 400 ENDIF BUJOB = 2 CALL SMUMPS_SIMSCALEABS(id%IRN(1), & id%JCN(1), id%A(1), & id%KEEP8(28), & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) id%DKEEP(4) = SCONEERR id%DKEEP(5) = SCINFERR 400 CONTINUE IF (allocated(WK_REAL)) DEALLOCATE(WK_REAL) IF (allocated(WRKR_TH)) DEALLOCATE(WRKR_TH) IF (allocated(WRKC_TH)) DEALLOCATE(WRKC_TH) IF (allocated(IWK)) DEALLOCATE(IWK) IF (allocated(BURP)) DEALLOCATE(BURP) IF (allocated(BUCP)) DEALLOCATE(BUCP) IF (allocated(BURS)) DEALLOCATE(BURS) IF (allocated(BUCS)) DEALLOCATE(BUCS) ENDIF C Centralized matrix: make DKEEP(4:5) available to all processors CALL MPI_BCAST( id%DKEEP(4),2,MPI_REAL, & MASTER, id%COMM, IERR ) IF (id%MYID.EQ.MASTER) THEN C Communicator should only be C freed on the master process CALL MPI_COMM_FREE(COMM_FOR_SCALING, IERR) ENDIF CALL MUMPS_PROPINFO(ICNTL(1), id%INFO(1), & id%COMM, id%MYID) IF (id%INFO(1).LT.0) GOTO 517 ELSE IF (id%MYID.EQ.MASTER) THEN C ------------------- C Centralized scaling C ------------------- IF (KEEP(52).GT.0 .AND. KEEP(52).LE.6) THEN C --------------------- C Allocate temporary C workspace for scaling C --------------------- IF (KEEP(52) .eq. 1 ) THEN C No workspace indeed needed LWK = 1_8 LWK_REAL = 1_8 ELSE IF ( KEEP(52) .eq. 3 ) THEN LWK = 1_8 LWK_REAL = int(N,8) ELSE IF ( KEEP(52) .eq. 4 ) THEN C Options 3 or 4 LWK = 1_8 LWK_REAL = 2_8*int(N,8) END IF C Real workarray ALLOCATE( WK_REAL( LWK_REAL ), stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR( LWK_REAL, id%INFO(2) ) GOTO 137 END IF C Real/complex workarray ALLOCATE( WK( LWK ), stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) GOTO 137 END IF CALL SMUMPS_FAC_A(N, id%KEEP8(28), KEEP(52), id%A(1), & id%IRN(1), id%JCN(1), & id%COLSCA(1), id%ROWSCA(1), & WK, LWK, WK_REAL, LWK_REAL, ICNTL(1), id%INFO(1) ) DEALLOCATE( WK_REAL ) DEALLOCATE( WK ) ENDIF ENDIF C} ENDIF ! Scaling distributed matrices or centralized IF (KEEP(125).NE.0) THEN C ------------------------ C If we enable the scaling of the |A11 A12| block C we set to 1 the scaling corresponding to the Schur C complement matrix A22 C ------------------------ IF ((KEEP(60).GT.0) .and. (KEEP(116).GT.0)) THEN C Schur is active, reset Schur entries to ONE IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. & KEEP(54).NE.0 ) THEN C Scaling available on all procs DO I=1, N IF (id%SYM_PERM(I).GT.id%N-KEEP(116)) THEN id%COLSCA(I) = ONE id%ROWSCA(I) = ONE ENDIF ENDDO ELSE IF ( id%MYID .EQ. MASTER) THEN C Scaling available on master DO I=1, N IF (id%SYM_PERM(I).GT.id%N-KEEP(116)) THEN id%COLSCA(I) = ONE id%ROWSCA(I) = ONE ENDIF ENDDO ENDIF ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIMEET) id%DKEEP(92)=real(TIMEET) IF (PROKG) WRITE( MPG, 140 ) TIMEET C Print inf-norm after last KEEP(233) iterations of C scaling option KEEP(52)=7 or 8 (SimScale) C IF (PROKG.AND.(KEEP(52).EQ.7.OR.KEEP(52).EQ.8)) THEN IF (K233+K231+K232.GT.0) THEN IF (K232.GT.0) WRITE(MPG, 166) id%DKEEP(4) ENDIF ENDIF ENDIF ENDIF ! LSCAL C C scaling might also be provided by the user LSCAL = (LSCAL .OR. (KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) IF (LSCAL .AND. KEEP(258).NE.0 .AND. id%MYID .EQ. MASTER) THEN DO I = 1, id%N CALL SMUMPS_UPDATEDETER_SCALING(id%ROWSCA(I), & id%DKEEP(6), ! determinant & KEEP(259)) ! exponent of the determinant ENDDO IF (KEEP(50) .EQ. 0) THEN ! unsymmetric DO I = 1, id%N CALL SMUMPS_UPDATEDETER_SCALING(id%COLSCA(I), & id%DKEEP(6), ! determinant & KEEP(259)) ! exponent of the determinant ENDDO ELSE C ----------------------------------------- C In this case COLSCA = ROWSCA C Since determinant was initialized to 1, C compute square of the current determinant C rather than going through COLSCA. C ----------------------------------------- CALL SMUMPS_DETER_SQUARE(id%DKEEP(6), KEEP(259)) ENDIF C Now we should have taken the C inverse of the scaling vectors CALL SMUMPS_DETER_SCALING_INVERSE(id%DKEEP(6), KEEP(259)) ENDIF C C ******************** C End of Scaling phase C At this point: either (matrix is distributed and KEEP(52)=7 or 8) C in which case scaling arrays are allocated on all processors, C or scaling arrays are only on the host processor. C In case of distributed matrix input, we will free the scaling C arrays on procs with MYID .NE. 0 after the all-to-all distribution C of the original matrix. C ******************** C 137 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C systematically this array now than waiting for C the root node. We rely on the fact that it is C allocated or not during the solve phase so if C it was allocated in a 1st call to facto and not C in a second, we don't want the solve to think C it was allocated in the second call. IF (associated(idintr%roota%RHS_CNTR_MASTER_ROOT)) THEN DEALLOCATE (idintr%roota%RHS_CNTR_MASTER_ROOT) NULLIFY (idintr%roota%RHS_CNTR_MASTER_ROOT) ENDIF C Fwd in facto: check that id%NRHS has not changed IF ( id%MYID.EQ.MASTER.AND. KEEP(252).EQ.1 .AND. & id%NRHS .NE. id%KEEP(253) ) THEN C Error: NRHS should not have C changed since the analysis id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) ENDIF IF (id%KEEP(252) .EQ. 1) THEN IF ( id%MYID.NE.MASTER ) THEN id%KEEP(254) = N ! Leading dimension id%KEEP8(85) = int(N,8)*int(id%KEEP(253),8) ! Tot size ALLOCATE(RHS_MUMPS(id%KEEP8(85)),stat=IERR) IF (IERR > 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(85), id%INFO(2)) IF (LPOK) & WRITE(LP,*) 'ERROR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. ELSE RHS_MUMPS_ALLOCATED = .TRUE. ENDIF ELSE C Case of non working master id%KEEP(254)=id%LRHS ! Leading dimension id%KEEP8(85)=int(id%LRHS,8)*int(id%KEEP(253)-1,8)+ & int(id%N,8) ! Tot size RHS_MUMPS=>id%RHS RHS_MUMPS_ALLOCATED = .FALSE. IF (LSCAL) THEN C Scale before broadcast: apply row C scaling (remark that we assume no C transpose). DO K=1, id%KEEP(253) DO I=1, N RHS_MUMPS( id%KEEP(254) * (K-1) + I ) & = RHS_MUMPS( id%KEEP(254) * (K-1) + I ) & * id%ROWSCA(I) ENDDO ENDDO ENDIF ENDIF ELSE id%KEEP8(85)=1_8 ALLOCATE(RHS_MUMPS(1),stat=IERR) IF (IERR > 0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF (LPOK) & WRITE(LP,*) 'ERREUR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. ELSE RHS_MUMPS_ALLOCATED = .TRUE. ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 516 IF (KEEP(252) .EQ. 1) THEN C C Broadcast the columns of the right-hand side C one by one. Leading dimension is keep(254)=N C on procs with MYID > 0 but may be larger on C the master processor. DO I= 1, id%KEEP(253) CALL MPI_BCAST(RHS_MUMPS((I-1)*id%KEEP(254)+1), N, & MPI_REAL, MASTER,id%COMM,IERR) END DO ENDIF IF (id%MYID.EQ. MASTER) THEN C Copy the value of ICNTL(24) and make it C available on all working processors. KEEP(110)=id%ICNTL(24) C KEEP(110) defaults to 0 for out of range values IF (KEEP(110).NE.1) KEEP(110)=0 ENDIF CALL MPI_BCAST(KEEP(110), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) C ----------------------------------------------- C Depending on the option used for C -detecting null pivots (ICNTL(24)/KEEP(110)) C CNTL(3) is used to set DKEEP(1) C ( A row is considered as null if ||row|| < DKEEP(1) ) C CNTL(5) is then used to define if a large C value is set on the diagonal or if a 1 is set C and other values in the row are reset to zeros. C -rank revealing on the Schur (ICNTL(56)/KEEP(19)) C SEUIL* corresponds to the minimum required C absolute value of pivot. C SEUIL_LDLT_NIV2 is used only in the C case of SYM=2 within a niv2 node for which C we have only a partial view of the fully summed rows. IF (id%MYID .EQ. MASTER) CNTL3 = id%CNTL(3) CALL MPI_BCAST(CNTL3, 1, MPI_REAL, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) CNTL5 = id%CNTL(5) CALL MPI_BCAST(CNTL5, 1, MPI_REAL, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) CNTL6 = id%CNTL(6) CALL MPI_BCAST(CNTL6, 1, MPI_REAL, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) id%DKEEP(8) = id%CNTL(7) CALL MPI_BCAST(id%DKEEP(8), 1, MPI_REAL, & MASTER, id%COMM, IERR) id%DKEEP(11) = id%DKEEP(8)/id%KEEP(461) id%DKEEP(12) = id%DKEEP(8)/id%KEEP(462) IF (KEEP(486).EQ.0) id%DKEEP(8) = ZERO COMPUTE_ANORMINF = .FALSE. IF ( (KEEP(486) .NE. 0).AND. (id%DKEEP(8).LT.ZERO)) THEN COMPUTE_ANORMINF = .TRUE. ENDIF IF (KEEP(19).NE.0) THEN C Rank revealing factorisation COMPUTE_ANORMINF = .TRUE. ENDIF IF (KEEP(110).NE.0) THEN C Null pivot detection COMPUTE_ANORMINF = .TRUE. ENDIF IF (id%DKEEP(8).LT.ZERO) THEN C Experimental setting of CNTL(7) IF (COMPUTE_ANORMINF) THEN EFF_SIZE_SCHUR = 0 CALL SMUMPS_ANORMINF( id , ANORMINF, LSCAL, EFF_SIZE_SCHUR ) C If no schur ANORMINF fine for other cases id%DKEEP(8) = abs(id%DKEEP(8))*ANORMINF ELSE ANORMINF = ZERO id%DKEEP(8) = abs(id%DKEEP(8)) ENDIF C ANORMINF need be recomputed in case of schur IF ((KEEP(60).GT.0).AND.KEEP(116).GT.0) ANORMINF=ZERO ENDIF IF (PROKG) THEN IF ( (CNTL(7) < ZERO) .AND. COMPUTE_ANORMINF .AND. & (KEEP(486) .NE. 0) ) THEN C Warning : using negative values is an experimental and C non recommended setting. WRITE(MPG,'(/A,A/,A/,A,A)') & ' WARNING in BLR input setting: ', & ' CNTL(7) < 0 is experimental: ', & ' Effective BLR threshold = |CNTL(7| x ||A_pre||, ', & ' where A_pre is the preprocessed matrix as defined', & ' in the users guide ' WRITE(MPG,'(A,3D16.4/)') & ' Effective BLR threshold, CNTL(7), ||A_pre|| = ', & id%DKEEP(8), CNTL(7), ANORMINF ENDIF ENDIF C ------------------------------------------------------- C We compute ANORMINF, when needed, based on C the infinite norm of Rowsca *A*Colsca C and make it available on all working processes. IF (COMPUTE_ANORMINF) THEN EFF_SIZE_SCHUR = 0 IF (KEEP(60).GT.0) EFF_SIZE_SCHUR = KEEP(116) CALL SMUMPS_ANORMINF( id , ANORMINF, LSCAL, EFF_SIZE_SCHUR ) ELSE ANORMINF = ZERO ENDIF C IF ((KEEP(19).NE.0).OR.(KEEP(110).NE.0)) THEN IF (PROKG) THEN IF (KEEP(19).NE.0) THEN WRITE(MPG,'(A,1PD16.4)') & ' CNTL(3) for null pivot rows/singularities =',CNTL3 ELSE WRITE(MPG,'(A,1PD16.4)') & ' CNTL(3) for null pivot row detection =',CNTL3 ENDIF ENDIF ENDIF IF (KEEP(19).EQ.0) THEN C{ -- RR is off SEUIL = ZERO id%DKEEP(9) = ZERO C} ELSE C{ -- RR is on C C CNTL(3) is the threshold used in the following to compute C DKEEP(9) the threshold under which the sing val. are considered C as null and from which we start to look for a gap between two C sing val. IF (CNTL3 .LT. ZERO) THEN id%DKEEP(9) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(9) = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN CALL MUMPS_NPIV_CRITICAL_PATH( & N, KEEP(28), id%STEP(1), id%FRERE_STEPS(1), id%FILS(1), & id%NA(1), id%LNA, id%NE_STEPS(1), KEEP(127), & NPIV_CRITICAL_PATH ) id%DKEEP(9) = sqrt(REAL(NPIV_CRITICAL_PATH))*EPS*ANORMINF ENDIF IF (PROKG) THEN WRITE(MPG, '(A,I16)') & ' ICNTL(56) rank revealing effective value =',KEEP(19) WRITE(MPG,'(A,1PD16.4)') & ' ...Threshold for singularities on the root =',id%DKEEP(9) ENDIF C RR postponing considers that pivot rows with norm smaller C than SEUIL should be postponed. C SEUIL should be bigger than DKEEP(9), this means that C DKEEP(13) should be bigger than 1. Thresh_Seuil = id%DKEEP(13) IF (id%DKEEP(13).LT.1) Thresh_Seuil = 10 SEUIL = id%DKEEP(9)*Thresh_Seuil IF (PROKG) WRITE(MPG,'(A,1PD16.4)') & ' ...Threshold for postponing =',SEUIL C} ENDIF !end KEEP(19).ne.0 SEUIL_LDLT_NIV2 = SEUIL C ------------------------------- C -- Null pivot row detection C ------------------------------- IF (KEEP(110).EQ.0) THEN C{ -- Null pivot is off C Initialize DKEEP(1) to a negative value C in order to avoid detection of null pivots C (test max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL C in SMUMPS_FAC_I, where PIVNUL=DKEEP(1)) id%DKEEP(1) = -1.0E0 id%DKEEP(2) = ZERO C} ELSE C{ -- Null pivot detection is on IF (KEEP(19).NE.0) THEN C{ -- RR is on C RR postponing considers that pivot rows of norm smaller that SEUIL C should be postponed, but pivot rows smaller than DKEEP(1) are C directly added to null space and thus considered as null pivot rows. IF ((id%DKEEP(10).LE.0).OR.(id%DKEEP(10).GT.1)) THEN C DKEEP(10) is out of range, set to the default value 10-1 id%DKEEP(1) = id%DKEEP(9)*1E-1 ELSE id%DKEEP(1) = id%DKEEP(9)*id%DKEEP(10) ENDIF C} ELSE C{ -- RR is off C -- only Null pivot detection C We keep strategy currently used in MUMPS 4.10.0 IF (CNTL3 .LT. ZERO) THEN id%DKEEP(1) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(1) = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN c id%DKEEP(1) = NPIV_CRITICAL_PATH*EPS*ANORMINF CALL MUMPS_NPIV_CRITICAL_PATH( & N, KEEP(28), id%STEP(1), id%FRERE_STEPS(1), id%FILS(1), & id%NA(1), id%LNA, id%NE_STEPS(1), KEEP(127), & NPIV_CRITICAL_PATH ) id%DKEEP(1) = sqrt(REAL(NPIV_CRITICAL_PATH))*EPS*ANORMINF ENDIF C} ENDIF ! fin rank revealing IF ((KEEP(110).NE.0).AND.(PROKG)) THEN WRITE(MPG, '(A,I16)') & ' ICNTL(24) null pivot rows detection =',KEEP(110) WRITE(MPG,'(A,1PD16.4)') & ' ...Zero pivot detection threshold =',id%DKEEP(1) ENDIF IF (CNTL5.GT.ZERO) THEN id%DKEEP(2) = CNTL5 * ANORMINF IF (PROKG) WRITE(MPG,'(A,1PD16.4)') & ' ...Fixation for null pivots =',id%DKEEP(2) ELSE IF (PROKG) WRITE(MPG,*) '...Infinite fixation ' IF (id%KEEP(50).EQ.0) THEN C Unsym ! the user let us choose a fixation. set in NEGATIVE ! to detect during facto when to set row to zero ! id%DKEEP(2) = -max(1.0E10*ANORMINF, & sqrt(huge(ANORMINF))/1.0E8) ELSE C Sym id%DKEEP(2) = ZERO ENDIF ENDIF C} ENDIF ! fin null pivot detection. C Find id of root node if RR is on IF (KEEP(19).NE.0) THEN ID_ROOT =MUMPS_PROCNODE(id%PROCNODE_STEPS(id%STEP(KEEP(20))), & id%KEEP(199)) IF ( KEEP( 46 ) .NE. 1 ) THEN ID_ROOT = ID_ROOT + 1 END IF ENDIF IF (KEEP(19).EQ.0.AND.KEEP(53).NE.0) THEN C ICNTL(56)>0 at analysis and =0 at facto C save special root index KEEP20_SAVE = KEEP(20) C suppress special RR treatment KEEP(20) = 0 ENDIF C Second pass: set parameters for null pivot detection C Allocate PIVNUL_LIST_STRUCT in case of null pivot detection C and in case of rank revealing KEEP(109) = 0 LPN_LIST = 0 IF(KEEP(110) .EQ. 1) THEN LPN_LIST = 100 ENDIF IF (KEEP(19).NE.0 .AND. & (ID_ROOT.EQ.id%MYID .OR. id%MYID.EQ.MASTER)) THEN LPN_LIST = 100 ENDIF IF (LPN_LIST.GT.0) THEN PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST = LPN_LIST ALLOCATE( PIVNUL_LIST_STRUCT%PIVNUL_LIST(LPN_LIST),stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=LPN_LIST END IF PIVNUL_LIST_STRUCT%PIVNUL_LIST(1:LPN_LIST) = 0 ENDIF C end set parameter for null pivot detection CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 516 C -------------------------------------------------------------- C STATIC PIVOTING C -- Static pivoting only when RR and Null pivot detection OFF C -------------------------------------------------------------- KEEP(97) = 0 IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (id%MYID .EQ. MASTER) CNTL4 = id%CNTL(4) CALL MPI_BCAST( CNTL4, 1, MPI_REAL, & MASTER, id%COMM, IERR ) C IF ( CNTL4 .GE. ZERO ) THEN KEEP(97) = 1 IF ( CNTL4 .EQ. ZERO ) THEN C -- set seuil to sqrt(eps)*||A|| IF(ANORMINF .EQ. ZERO) THEN EFF_SIZE_SCHUR = 0 IF (KEEP(60).GT.0) EFF_SIZE_SCHUR = KEEP(116) CALL SMUMPS_ANORMINF( id , ANORMINF, LSCAL, & EFF_SIZE_SCHUR ) ENDIF SEUIL = sqrt(EPS) * ANORMINF ELSE SEUIL = CNTL4 ENDIF SEUIL_LDLT_NIV2 = SEUIL ELSE SEUIL = ZERO ENDIF ENDIF C set number of tiny pivots / 2x2 pivots in types 1 / C 2x2 pivots in types 2, to zero. This is because the C user can call the factorization step several times. KEEP(98) = 0 KEEP(103) = 0 KEEP(105) = 0 MAXS = 1_8 * * Start allocations * ***************** * C C The slaves can now perform the factorization C C C or point to user provided data WK_USER when LWK_USER>0 C ======================= C C Compute BLR_STRAT and a first estimation C of MAXS, the size of id%S CALL SMUMPS_SET_BLRSTRAT_AND_MAXS_K8 ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & id%KEEP(1), id%KEEP8(1)) C MAXS = MAXS_BASE_RELAXED8 IF (WK_USER_PROVIDED) THEN C -- Set MAXS to size of WK_USER_ MAXS = id%KEEP8(24) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 516 ENDIF C id%KEEP8(75) = huge(id%KEEP8(75)) id%KEEP8(76) = huge(id%KEEP8(76)) IF (I_AM_SLAVE) THEN C IF (id%KEEP8(4) .NE. 0_8) THEN C IF ( .NOT. WK_USER_PROVIDED ) THEN C Set MAXS given BLR_STRAT, KEEP(201) and MAXS_BASE_RELAXED8 CALL SMUMPS_MEM_ALLOWED_SET_MAXS ( & MAXS, & BLR_STRAT, id%KEEP(201), MAXS_BASE_RELAXED8, & id%KEEP(1), id%KEEP8(1), id%MYID, id%N, id%NELT, & id%NA(1), id%LNA, id%NSLAVES, & KEEP464COPY, KEEP465COPY, & id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) C Given MAXS and max memory allowed KEEP8(4) C compute in KEEP8(75) the number of real/complex C available for dynamic allocations CALL SMUMPS_MEM_ALLOWED_SET_K75 ( & MAXS, id%MYID, & .FALSE., ! UNDER_L0_OMP & N, id%NELT, id%NA(1), id%LNA, id%NSLAVES, & BLR_STRAT, id%KEEP(201), & id%KEEP, id%KEEP8, id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) ELSE C KEEP8(75) dow not include MAXS, since WK_USER is provided CALL SMUMPS_MEM_ALLOWED_SET_K75 ( & 0_8, id%MYID, & .FALSE., ! UNDER_L0_OMP & N, id%NELT, id%NA(1), id%LNA, id%NSLAVES, & BLR_STRAT, id%KEEP(201), & id%KEEP, id%KEEP8, id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) ENDIF IF (KEEP(400) .GT.0) THEN C ------------------------------ C compute KEEP8(75) under L0_OMP C ------------------------------ C Save KEEP8(75) above L0_OMP to reset KEEP8(75) C when starting FAC_PAR_M id%KEEP8(76) = id%KEEP8(75) CALL SMUMPS_MEM_ALLOWED_SET_K75 ( & 0_8, ! MAXS=0_8 & id%MYID, & .TRUE., ! UNDER_L0_OMP & id%N, id%NELT, id%NA(1), id%LNA, id%NSLAVES, & BLR_STRAT, id%KEEP(201), & id%KEEP, id%KEEP8, id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) C KEEP8(75) holds the number of entries that C can be allocated underL0. C It will be used during SMUMPS_FAC_L0_OMP to adjust the C the size of MUMPS_TPS_ARR(ITH)%LA ENDIF ENDIF ! MEM_ALLOWED C ENDIF ! I_AM_SLAVE THEN C IF (I_AM_SLAVE) THEN IF ( (KEEP(400).GT.0) .AND. (KEEP(406).EQ.2) ) THEN C Compute KEEP8(77) the peak authorized used by C SMUMPS_PERFORM_COPIES CALL SMUMPS_L0_COMPUTE_PEAK_ALLOWED( & id%MYID, id%N, & id%NELT, id%NA(1), id%LNA, id%NSLAVES, & BLR_STRAT, id%KEEP(201), & id%KEEP(1), id%KEEP8(1), id%INFO(1), id%INFO(2) & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) ENDIF ENDIF ! I_AM_SLAVE) C CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 516 ENDIF CALL MUMPS_SETI8TOI4(MAXS, id%INFO(39)) CALL SMUMPS_AVGMAX_STAT8(PROKG, MPG, MAXS, id%NSLAVES, & PRINT_MAXAVG, & id%COMM, " Effective size of S (based on INFO(39))= ") C IF ( I_AM_SLAVE ) THEN C ---------------------------------------- C Initialize some global variables related C to communication buffer management C ---------------------------------------- CALL MUMPS_BUF_INI_MYID(id%MYID_NODES) CALL MUMPS_BUF_INIT( id%KEEP( 34 ), id%KEEP(35) ) C ------------------ C Dynamic scheduling C ------------------ CALL MUMPS_LOAD_SET_INICOST( dble(id%COST_SUBTREES), & KEEP(64), dble(id%DKEEP(15)), KEEP(375), MAXS ) MEMORY_MD_ARG = min(int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8 ), C Restrict freedom from dynamic scheduler when C MEM_ALLOWED=ICNTL(23) is small (case where KEEP8(4)-MAXS_BASE8 C is negative after call to SMUMPS_MAX_MEM) & max(0_8, MAXS-MAXS_BASE8)) CALL MUMPS_LOAD_INIT( MEMORY_MD_ARG, MAXS, id%KEEP, & id%KEEP8, id%INFO, id%ISTEP_TO_INIV2, id%CANDIDATES, id%ND_STEPS, & id%FILS, id%FRERE_STEPS, id%DAD_STEPS, id%PROCNODE_STEPS, & id%STEP, id%NE_STEPS, id%N, id%MAX_SURF_MASTER, id%SUP_PROC, & id%COMM_LOAD, id%COMM_NODES, & id%DEPTH_FIRST, id%COST_TRAV, id%DEPTH_FIRST_SEQ, id%SBTR_ID, & id%NA, id%NSLAVES, id%FUTURE_NIV2, & id%NBSA, id%NBSA_LOCAL, id%MEM_SUBTREE, id%MY_FIRST_LEAF, & id%MY_NB_LEAF, id%MY_ROOT_SBTR ) IF (KEEP(201) .GT. 0) THEN C ------------------- C OOC initializations C ------------------- IF (KEEP(201).EQ.1 !PANEL Version & .AND.KEEP(50).EQ.0 ! Unsymmetric & .AND.KEEP(251).NE.2 ! Store L to disk & ) THEN id%OOC_NB_FILE_TYPE=2 ! declared in MUMPS_OOC_COMMON ELSE id%OOC_NB_FILE_TYPE=1 ! declared in MUMPS_OOC_COMMON ENDIF C ------------------------------ C Dimension IO buffer, KEEP(100) C ------------------------------ IF (KEEP(205) .GT. 0) THEN KEEP(100) = KEEP(205) ELSE IF (KEEP(201).EQ.1) THEN ! PANEL version ITMP8 = int(id%OOC_NB_FILE_TYPE,8) * & 2_8 * int(KEEP(226),8) ELSE ITMP8 = 2_8 * id%KEEP8(119) ENDIF ITMP8 = ITMP8 + int(max(KEEP(12),0),8) * & (ITMP8/100_8+1_8) C we want to avoid too large IO buffers. C 12M corresponds to 100Mbytes given to buffers. ITMP8 = min(ITMP8, 12000000_8) KEEP(100)=int(ITMP8) ENDIF IF (KEEP(201).EQ.1) THEN C Panel version. Force the use of a buffer. IF ( KEEP(99) < 3 ) THEN KEEP(99) = KEEP(99) + 3 ENDIF ENDIF C -------------------------- C Reset KEEP(100) to 0 if no C buffer is used for OOC. C -------------------------- IF (KEEP(99) .LT.3) KEEP(100)=0 IF((dble(KEEP(100))*dble(KEEP(35))/dble(2)).GT. & (dble(1999999999)))THEN IF (PROKG) THEN WRITE(MPG,*)id%MYID,': Warning: DIM_BUF_IO might be & too big for Filesystem' ENDIF ENDIF ALLOCATE (id%OOC_INODE_SEQUENCE(KEEP(28), & id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_INODE_SEQUENCE) GOTO 112 ENDIF ALLOCATE (id%OOC_TOTAL_NB_NODES(id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE NULLIFY(id%OOC_TOTAL_NB_NODES) GOTO 112 ENDIF ALLOCATE (id%OOC_SIZE_OF_BLOCK(KEEP(28), & id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_SIZE_OF_BLOCK) GOTO 112 ENDIF ALLOCATE (id%OOC_VADDR(KEEP(28),id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_VADDR) GOTO 112 ENDIF ENDIF ENDIF 112 CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) < 0) THEN C LOAD_END must be done but not OOC_END_FACTO GOTO 513 ENDIF IF (I_AM_SLAVE) THEN IF (KEEP(201) .GT. 0) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL SMUMPS_OOC_INIT_FACTO(id%ICNTL(1), id%ICNTL(4), id%N, & id%NSLAVES, id%MYID, MAXS, id%OOC_NB_FILE_TYPE, & id%KEEP, id%KEEP8, id%STEP, id%PROCNODE, & id%OOC_SIZE_OF_BLOCK, id%OOC_VADDR, id%INFO, & id%OOC_TMPDIR, id%OOC_PREFIX, id%OOC_NB_FILES, & id%OOC_INODE_SEQUENCE) ELSE WRITE(*,*) "Internal error in SMUMPS_FAC_DRIVER" CALL MUMPS_ABORT() ENDIF IF(id%INFO(1).LT.0)THEN GOTO 111 ENDIF ENDIF C First increment corresponds to the number of C floating-point operations for subtrees allocated C to the local processor. CALL MUMPS_LOAD_UPDATE(0,.FALSE.,dble(id%COST_SUBTREES), & id%KEEP(1),id%KEEP8(1)) IF (id%INFO(1).LT.0) GOTO 111 END IF C ----------------------- C Manage main workarray S C ----------------------- EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) #if defined (LARGEMATRICES) IF ( id%MYID .ne. MASTER ) THEN #endif IF (.NOT.WK_USER_PROVIDED) THEN IF ( EARLYT3ROOTINS ) THEN C Standard allocation strategy CALL SMUMPS_DM_ALLOC_S_WK(id%S, MAXS, IERR, & KEEP(430), KEEP(35)) id%KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(MAXS, id%INFO(2)) C On some platforms (IBM for example), an C allocation failure returns a non-null pointer. C Therefore we nullify S NULLIFY(id%S) id%KEEP8(23)=0_8 ENDIF ENDIF ELSE id%S => id%WK_USER(1:id%KEEP8(24)) id%KEEP8(23) = 0_8 ENDIF #if defined (LARGEMATRICES) END IF #endif C 111 CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 514 C -------------------------- C Initialization of modules C related to data management C -------------------------- NB_ACTIVE_FRONTS_ESTIM = 3 NB_THREADS = 1 !$ NB_THREADS = OMP_GET_MAX_THREADS() C NB_ACTIVE_FRONTS_ESTIM = 3*NB_THREADS IF (I_AM_SLAVE) THEN C CALL MUMPS_FDM_INIT('A',NB_ACTIVE_FRONTS_ESTIM, id%INFO) C IF ( (KEEP(486).EQ.2) & .OR. ((KEEP(489).NE.0).AND.(KEEP(400).GT.1)) & ) THEN C In case of LRSOLVE or CompressCB, C initialize nb of handlers to nb of BLR C nodes estimated at analysis NB_FRONTS_F_ESTIM = KEEP(470) ELSE IF (KEEP(489).NE.0) THEN C Compress CB and no L0 OMP (or 1 thread under L0): C NB_ACTIVE_FRONTS_ESTIM is too small, C to limit nb of reallocations make it twice larger NB_FRONTS_F_ESTIM = 2*NB_ACTIVE_FRONTS_ESTIM ELSE NB_FRONTS_F_ESTIM = NB_ACTIVE_FRONTS_ESTIM ENDIF ENDIF CALL MUMPS_FDM_INIT('F',NB_FRONTS_F_ESTIM, id%INFO ) IF (id%INFO(1) .LT. 0 ) GOTO 114 #if ! defined(NO_FDM_DESCBAND) C Storage of DESCBAND information CALL MUMPS_FDBD_INIT( NB_ACTIVE_FRONTS_ESTIM, id%INFO ) #endif #if ! defined(NO_FDM_MAPROW) C Storage of MAPROW and ROOT2SON information CALL MUMPS_FMRD_INIT( NB_ACTIVE_FRONTS_ESTIM, id%INFO ) #endif CALL SMUMPS_BLR_INIT_MODULE( NB_FRONTS_F_ESTIM, id%INFO & ) 114 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C GOTO 500: one of the above module initializations failed IF ( id%INFO(1).LT.0 ) GOTO 500 C C C Allocate space for matrix in arrowhead form C =========================================== C C CASE 1 : Matrix is assembled C CASE 2 : Matrix is elemental C IF ( KEEP(55) .eq. 0 ) THEN C ------------------------------------ C Space has been allocated already for C the integer part during analysis C Only slaves need the arrowheads. C ------------------------------------ IF ( I_AM_SLAVE .and. id%KEEP8(26) .ne. 0_8 ) THEN ALLOCATE( DBLARR( id%KEEP8(26) ), & INTARR( id%KEEP8(27) ), stat = IERR ) ELSE ALLOCATE( DBLARR( 1 ), & INTARR( 1 ), stat =IERR ) END IF IF ( IERR .NE. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for DBLARR(',id%KEEP8(26),')+INTARR(', & id%KEEP8(27),')' ENDIF id%INFO(1)=-13 CALL MUMPS_SET_IERROR( max(id%KEEP8(26),1_8)+ & max(id%KEEP8(27),1_8), & id%INFO(2) ) GOTO 100 END IF DBLARR_ALLOCATED = .TRUE. ELSE C -------------------------------- C Allocate element variables lists C -------------------------------- IF ( I_AM_SLAVE .and. id%KEEP8(27) .ne. 0_8 ) THEN ALLOCATE( INTARR( id%KEEP8(27) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(id%KEEP8(27), id%INFO(2)) GOTO 100 END IF ELSE C INTARR also allocated of size 1 on non-working master ALLOCATE( INTARR(1),stat=allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 GOTO 100 END IF END IF C --------------------------------------- C Allocate DBLARR to hold possibly scaled C copies of elemental matrices C On a working master (hybrid host) and C no scaling, avoid the copy and point C directly to user data instead. C --------------------------------------- IF ( I_AM_SLAVE ) THEN IF ( id%MYID_NODES .eq. MASTER & .AND. KEEP(46) .eq. 1 & .AND. KEEP(52) .eq. 0 ) THEN C ------------------- C Pointer association C ------------------- DBLARR => id%A_ELT ELSE C ---------- C Allocation C ---------- ALLOCATE( DBLARR( max(id%KEEP8(26),1_8) ), stat=allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(max(id%KEEP8(26),1_8), id%INFO(2)) NULLIFY(DBLARR) GOTO 100 END IF DBLARR_ALLOCATED = .TRUE. END IF ELSE ALLOCATE( DBLARR(1), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(DBLARR) GOTO 100 END IF DBLARR_ALLOCATED = .TRUE. END IF END IF 100 CONTINUE C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C ------------------------------------------ C Prepare stuff for the 2D block-cyclic root C ------------------------------------------ IF ( KEEP(38).NE.0 ) THEN ALLOCATE(idintr%root%RG2L(id%N), stat=allocok) IF ( allocok .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N END IF IF ( id%INFO(1) .GE.0 ) THEN CALL SMUMPS_INIT_ROOT_FAC( id%N, id%MYID, & idintr%root, id%FILS(1), id%KEEP(1) ) ENDIF ENDIF C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C C ----------------------------------- C C DISTRIBUTION OF THE ORIGINAL MATRIX C C ----------------------------------- C C TIMINGS: computed (and printed) on the host C Next line: global time for distrib(arrowheads,elts) C on the host. Synchronization has been performed. IF (id%MYID.EQ.MASTER) CALL MUMPS_SECDEB(TIME) C ------------------------------------------- C S_PTR_ARG / MAXS_ARG will be used for id%S C argument to arrowhead/element distribution C routines: if id%S is not allocated, we pass C S_DUMMY_ARG instead, which is not accessed. C ------------------------------------------- IF (EARLYT3ROOTINS) THEN S_PTR_ARG => id%S MAXS_ARG = MAXS ELSE S_PTR_ARG => S_DUMMY_ARG MAXS_ARG = 1 ENDIF C IF ( KEEP( 55 ) .eq. 0 ) THEN C { C ---------------------------- C Original matrix is assembled C Arrowhead format to be used. C ---------------------------- C KEEP8(26) and KEEP8(27) hold the number of entries for real/integer C for the matrix in arrowhead format. They have been set by the C analysis phase (SMUMPS_ANA_F and SMUMPS_ANA_G) C C ------------------------------------------------------------------ C Blocking is used for sending arrowhead records (I,J,VAL) C buffer(1) is used to store number of bytes already packed C buffer(2) number of records already packed C KEEP(39) : Number of records (blocking factor) C ------------------------------------------------------------------ C C --------------------------------------------- C In case of parallel root compute minimum C size of workspace to receive arrowheads C of root node. Will be used to check that C MAXS is large enough for arrowheads (case C of EARLYT3ROOTINS (KEEP(200)=0); if .NOT. C EARLYT3ROOTINS (KEEP(200)=1), root will C be assembled into id%S later and size of C id%S will be checked later) C --------------------------------------------- IF (EARLYT3ROOTINS .AND. KEEP(38).NE.0 .AND. & KEEP(60) .EQ.0 .AND. I_AM_SLAVE) THEN LWK = int(MUMPS_NUMROC( idintr%root%ROOT_SIZE, & idintr%root%MBLOCK, & idintr%root%MYROW, 0, idintr%root%NPROW ),8) LWK = max( 1_8, LWK ) LWK = LWK* & int(MUMPS_NUMROC( idintr%root%ROOT_SIZE, & idintr%root%NBLOCK, & idintr%root%MYCOL, 0, idintr%root%NPCOL ),8) LWK = max( 1_8, LWK ) ELSE LWK = 1_8 ENDIF C MAXS must be at least 1, and in case of C parallel root, large enough to receive C arrowheads of root. IF (MAXS .LT. int(LWK,8)) THEN id%INFO(1) = -9 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C C ===================================================== IF (KEEP(399).GE.2) THEN C{ Multihtreaded algorithm taking into account all cases C ===================================================== C C Timing on master. IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIME) END IF C NZ_loc8 = 0_8 NBRECORDS = KEEP(39) SIZESCAL = id%N C Set NZ_loc8, A_loc_PTR, IRN_loc_PTR, JCN_loc_PTR C and update NBRECORDS IF (KEEP(54).EQ.0) THEN C centralized matrix IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF IF (id%MYID.EQ.MASTER) THEN NZ_loc8 = id%KEEP8(28) A_loc_PTR => id%A IRN_loc_PTR => id%IRN JCN_loc_PTR => id%JCN IF (LSCAL) THEN COLSCA_PTR => id%COLSCA ROWSCA_PTR => id%ROWSCA ELSE COLSCA_PTR => DUMMYSCA ROWSCA_PTR => DUMMYSCA SIZESCAL = 1 ENDIF ELSE A_loc_PTR => DUMMYA_loc IRN_loc_PTR => DUMMYIRN_loc JCN_loc_PTR => DUMMYJCN_loc COLSCA_PTR => DUMMYSCA ROWSCA_PTR => DUMMYSCA SIZESCAL = 1 ENDIF ELSE C distributed matrix C --------------------------------------------------- C In order to have possibly IRN_loc/JCN_loc/A_loc C of size 0, avoid to pass them inside REDISTRIBUTION C and pass id instead C NZ_locMAX8 gives as a maximum buffer size (send/recv) used C an upper bound to limit buffers on small matrices C --------------------------------------------------- CALL MPI_ALLREDUCE(id%KEEP8(29), NZ_locMAX8, 1, & MPI_INTEGER8, MPI_MAX, id%COMM, IERR) IF (NZ_locMAX8 .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(NZ_locMAX8) ENDIF NZ_loc8 = id%KEEP8(29) LSCAL = (KEEP(52).EQ.7).OR.(KEEP(52).EQ.8) C available on all MPI IF (LSCAL) THEN COLSCA_PTR => id%COLSCA ROWSCA_PTR => id%ROWSCA ELSE COLSCA_PTR => DUMMYSCA ROWSCA_PTR => DUMMYSCA SIZESCAL = 1 ENDIF ENDIF #if ! defined(PCPRET) IF (id%KEEP(72).EQ.1) THEN NBRECORDS = max(3,NBRECORDS/10) ENDIF CALL SMUMPS_FAC_DIST_ARROWHEADS_OMP ( id%N, & NZ_loc8, C replace id by: & A_loc_PTR(1), IRN_loc_PTR(1), JCN_loc_PTR(1), & SIZESCAL, LSCAL, COLSCA_PTR(1), ROWSCA_PTR(1), & DBLARR(1), id%KEEP8(26), INTARR(1), & id%KEEP8(27), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & id%FILS(1), & KEEP(1), id%KEEP8(1), id%MYID, id%COMM, NBRECORDS, & S_PTR_ARG(1), MAXS_ARG, idintr%root, idintr%roota, & id%PROCNODE_STEPS(1), & id%NPROCS, id%NSLAVES, id%SYM_PERM(1), id%STEP(1), & id%ICNTL(1), id%INFO(1), NSEND8, NLOCAL8, & id%ISTEP_TO_INIV2(1), & id%CANDIDATES(1,1) & ) CALL MPI_BARRIER(id%COMM, IERR) #else #endif C IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN C ------------------------------ C The host is not working -> had C no data from initial matrix C ------------------------------ NSEND8 = 0_8 NLOCAL8 = 0_8 END IF C ------------------------- C Check for possible errors C ------------------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 CALL MPI_REDUCE( NSEND8, NSEND_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( NLOCAL8, NLOCAL_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN WRITE(MPG,125) NLOCAL_TOT8, NSEND_TOT8 END IF C} ELSE C{ ======================================================= IF ( KEEP(54) .eq. 0 ) THEN C { C ================================================ C FIRST CASE : MATRIX IS NOT INITIALLY DISTRIBUTED C ================================================ C A small integer workspace is needed to C send the arrowheads. IF ( id%MYID .eq. MASTER ) THEN #if defined(LARGEMATRICES) ALLOCATE (WK(LWK),stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) write(6,*) ' PB1 ALLOC LARGEMAT' ENDIF #endif ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 IF ( id%MYID .eq. MASTER ) THEN C C -------------------------------- C MASTER sends arowheads using the C global communicator with ranks C also in global communicator C IWK is used as temporary C workspace of size N. C -------------------------------- NBRECORDS = KEEP(39) IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF #if defined(LARGEMATRICES) CALL SMUMPS_FACTO_SEND_ARROWHEADS(id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), id%SYM_PERM(1), & LSCAL, id%COLSCA(1), id%ROWSCA(1), & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), & NBRECORDS, & id%COMM, idintr%root, idintr%roota, KEEP,id%KEEP8, & id%FILS(1), & & INTARR(1), id%KEEP8(27), DBLARR(1), id%KEEP8(26), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & id%FRERE_STEPS(1), id%STEP(1), WK(1), LWK, & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & id%CANDIDATES(1,1), id%ICNTL(1), id%INFO(1) ) C write(6,*) '!!! A,IRN,JCN are freed during factorization ' DEALLOCATE (id%A) NULLIFY(id%A) DEALLOCATE (id%IRN) NULLIFY (id%IRN) DEALLOCATE (id%JCN) NULLIFY (id%JCN) IF (.NOT.WK_USER_PROVIDED) THEN IF (EARLYT3ROOTINS) THEN CALL SMUMPS_ALLOC_S_WORKSPACE(id%S, MAXS, IERR, & KEEP(430), KEEP(35)) id%KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXS NULLIFY(id%S) id%KEEP8(23)=0_8 write(6,*) ' PB2 ALLOC LARGEMAT',MAXS CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ELSE id%S => id%WK_USER(1:id%KEEP8(24)) ENDIF IF (EARLYT3ROOTINS) THEN id%S(MAXS-LWK+1_8:MAXS) = WK(1_8:LWK) ENDIF DEALLOCATE (WK) #else CALL SMUMPS_FACTO_SEND_ARROWHEADS(id%N, id%KEEP8(28), & id%A(1), id%IRN(1), id%JCN(1), id%SYM_PERM(1), & LSCAL, id%COLSCA(1), id%ROWSCA(1), & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), & NBRECORDS, & id%COMM, idintr%root, idintr%roota, KEEP(1),id%KEEP8(1), & id%FILS(1), & & INTARR(1), id%KEEP8(27), DBLARR(1), id%KEEP8(26), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & id%FRERE_STEPS(1), id%STEP(1), S_PTR_ARG(1), MAXS_ARG, & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & id%CANDIDATES(1,1), id%ICNTL(1), id%INFO(1) ) #endif ELSE NBRECORDS = KEEP(39) IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF CALL SMUMPS_FACTO_RECV_ARROWHD2( id%N, & DBLARR(1), id%KEEP8(26), & INTARR(1), id%KEEP8(27), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & KEEP( 1 ), id%KEEP8(1), id%FILS(1), id%MYID, id%COMM, & NBRECORDS, & & S_PTR_ARG(1), MAXS_ARG, & idintr%root, idintr%roota, & id%PROCNODE_STEPS(1), id%NSLAVES, & id%SYM_PERM(1), id%FRERE_STEPS(1), id%STEP(1), & id%ICNTL(1), id%INFO(1) ) ENDIF C } ELSE C { C ============================================= C SECOND CASE : MATRIX IS INITIALLY DISTRIBUTED C ============================================= C Timing on master. IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIME) END IF IF ( I_AM_SLAVE ) THEN C { C --------------------------------------------------- C In order to have possibly IRN_loc/JCN_loc/A_loc C of size 0, avoid to pass them inside REDISTRIBUTION C and pass id instead C NZ_locMAX8 gives as a maximum buffer size (send/recv) used C an upper bound to limit buffers on small matrices C --------------------------------------------------- CALL MPI_ALLREDUCE(id%KEEP8(29), NZ_locMAX8, 1, MPI_INTEGER8, & MPI_MAX, id%COMM_NODES, IERR) NBRECORDS = KEEP(39) IF (NZ_locMAX8 .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(NZ_locMAX8) ENDIF CALL SMUMPS_REDISTRIBUTION( id%N, & id%KEEP8(29), & id, & DBLARR(1), id%KEEP8(26), INTARR(1), & id%KEEP8(27), & id%PTR8ARR(1), id%NINCOLARR(1), & id%NINROWARR(1), id%PTRDEBARR(1), & id%FILS(1), & KEEP(1), id%KEEP8(1), id%MYID_NODES, & id%COMM_NODES, NBRECORDS, & S_PTR_ARG(1), MAXS_ARG, idintr%root, idintr%roota, & id%PROCNODE_STEPS(1), & id%NSLAVES, id%SYM_PERM(1), id%STEP(1), & id%ICNTL(1), id%INFO(1), NSEND8, NLOCAL8, & id%ISTEP_TO_INIV2(1), & id%CANDIDATES(1,1) ) IF ( ( KEEP(52).EQ.7 ).OR. (KEEP(52).EQ.8) ) THEN C ------------------------------------------------- C In that case, scaling arrays have been allocated C on all processors. They were useful for matrix C distribution. But we now really only need them C on the host. In case of distributed solution, we C will have to broadcast either ROWSCA or COLSCA C (depending on MTYPE) but this is done later. C C In other words, on exit from the factorization, C we want to have scaling arrays available only C on the host. C ------------------------------------------------- IF ( id%MYID > 0 ) THEN IF (associated(id%ROWSCA)) THEN DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF IF (associated(id%COLSCA)) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ENDIF ENDIF ENDIF #if defined(LARGEMATRICES) C deallocate id%IRN_loc, id%JCN(loc) to free extra space C Note that in this case IRN_loc cannot be used C anymore during the solve phase for IR and Error analysis. IF (associated(id%IRN_loc)) THEN DEALLOCATE(id%IRN_loc) NULLIFY(id%IRN_loc) ENDIF IF (associated(id%JCN_loc)) THEN DEALLOCATE(id%JCN_loc) NULLIFY(id%JCN_loc) ENDIF IF (associated(id%A_loc)) THEN DEALLOCATE(id%A_loc) NULLIFY(id%A_loc) ENDIF write(6,*) ' Warning :', & ' id%A_loc, IRN_loc, JCN_loc deallocated !!! ' #endif IF (PROK) THEN WRITE(MP,120) NLOCAL8, NSEND8 END IF C } END IF ! I_AM_SLAVE C ------------------------- C Check for possible errors C ------------------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN C ------------------------------ C The host is not working -> had C no data from initial matrix C ------------------------------ NSEND8 = 0_8 NLOCAL8 = 0_8 END IF C -------------------------- C Put into some info/infog ? C -------------------------- CALL MPI_REDUCE( NSEND8, NSEND_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( NLOCAL8, NLOCAL_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN WRITE(MPG,125) NLOCAL_TOT8, NSEND_TOT8 END IF C } ENDIF ! distributed matrix C } ENDIF ! "old" multithreaded algorithm C } ELSE C { C ------------------- C Matrix is elemental, C provided on the C master only C ------------------- IF ( id%MYID.eq.MASTER) & CALL SMUMPS_MAXELT_SIZE( id%ELTPTR(1), & id%NELT, & MAXELT_SIZE ) C C Perform the distribution of the elements. C A this point, C PTRAIW/PTRARW have been computed. C INTARR/DBLARR have been allocated C ELTPROC gives the mapping of elements C CALL SMUMPS_ELT_DISTRIB( id%N, id%NELT, id%KEEP8(30), & id%COMM, id%MYID, & id%NSLAVES, id%PTRAR(1), & id%PTRAR(id%NELT+2), & INTARR(1), DBLARR(1), id%KEEP8(27), id%KEEP8(26), & id%KEEP(1), id%KEEP8(1), MAXELT_SIZE, & id%FRTPTR(1), id%FRTELT(1), & S_PTR_ARG(1), MAXS_ARG, id%FILS(1), & id, idintr%root, idintr%roota ) C ---------------- C Broadcast errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C } END IF ! Element entry C ------------------------ C Time the redistribution: C ------------------------ IF ( id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIME) id%DKEEP(93) = real(TIME) IF (PROKG) WRITE(MPG,160) id%DKEEP(93) END IF C ------------------------------------- C Small memory optimizaiton: we can now C free RG2L on the non working host, C ------------------------------------- IF (id%KEEP(38) .NE. 0 .AND. .NOT. I_AM_SLAVE) THEN IF (associated(idintr%root%RG2L)) THEN DEALLOCATE(idintr%root%RG2L) NULLIFY (idintr%root%RG2L) ENDIF ENDIF IF ( KEEP(400) .GT. 0 .AND. KEEP(369).EQ.0) THEN C{ Check if number of threads is consistent with C the one used during analysis for all procs C Note that if KEEP(369)>0 C KEEP(400) was set based on C KEEP(369) and KEEP(381) so that C omp_set_num_threads(KEEP(400)) will be called C explicitly before L0_OMP section C and KEEP(400) cannot be check here in this way NOMP=1 !$ NOMP = omp_get_max_threads() IF ( NOMP .NE. KEEP(400) ) THEN id%INFO(1)=-58 id%INFO(2)=KEEP(400) IF (LPOK) WRITE(LP,'(A,A,I5,A,I5)') &" FAILURE DETECTED IN FACTORIZATION: #threads for multithreaded", &" tree parallelism changed from",KEEP(400)," at analysis to", & NOMP ENDIF C} ENDIF C error check done outside previous if bloc C because KEEP(369) might be 0 on some and nonzero on some proc CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C C TIMINGS: C Next line: elapsed time for factorization IF (id%MYID.EQ.MASTER) CALL MUMPS_SECDEB(TIME) C C Allocate buffers on the workers C =============================== C IF ( I_AM_SLAVE ) THEN C C Some buffers are required to pack/unpack data and for C receiving MPI messages. C For packing/unpacking : the buffer must be large C enough to send several messages while receives might not C be posted yet. C It is assumed that the size of an integer is held in KEEP(34) C while the size of a complex is held in KEEP(35). C BUFR and LBUFR are declared of type integer, since byte is not C a standard datatype. C We now use KEEP(43) or KEEP(379) and KEEP(44) or KEEP(380) C as estimated at analysis to allocate appropriate buffer sizes C C Receive buffer C -------------- IF (KEEP(486).NE.0) THEN SMUMPS_LBUFR_BYTES8 = int(KEEP( 380 ),8) * int(KEEP(35),8) ELSE SMUMPS_LBUFR_BYTES8 = int(KEEP( 44 ),8) * int(KEEP(35),8) ENDIF C --------------------------------------- C Ensure a reasonable minimal buffer size C --------------------------------------- IF (KEEP(72).NE.1) THEN C ensure minimum size for small problems SMUMPS_LBUFR_BYTES8 = max( SMUMPS_LBUFR_BYTES8, & 200000_8 ) ENDIF C C If there is pivoting, size of the message might still increase. C We use a relaxation (so called PERLU) to increase the estimate. C C Note: PERLU is a global estimate for pivoting. C It may happen that one large contribution block size is increased C by more than that. C This is why we use an extra factor 2 relaxation coefficient for C the relaxation of C the reception buffer in the case where pivoting is allowed. C A more dynamic strategy could be applied: if message to C be received is larger than expected, reallocate a larger C buffer. (But this won't work with IRECV.) C Finally, one may want (as we are currently doing it for C most messages) C to cut large messages into a series of smaller ones. C IF (KEEP(48).EQ.5) THEN MIN_PERLU = 2 ELSE MIN_PERLU = 0 ENDIF C IF (KEEP(72).NE.1) THEN SMUMPS_LBUFR_BYTES8 = SMUMPS_LBUFR_BYTES8 & + int( real(max(PERLU/2,MIN_PERLU))* & real(SMUMPS_LBUFR_BYTES8)/100E0, 8) ELSE C on small pb we want to relax buffers C for pivoting SMUMPS_LBUFR_BYTES8 = SMUMPS_LBUFR_BYTES8 & + int( real(max(PERLU,MIN_PERLU))* & real(SMUMPS_LBUFR_BYTES8)/100E0, 8) ENDIF SMUMPS_LBUFR_BYTES8 = min(SMUMPS_LBUFR_BYTES8, & int(huge(I4)-100,8)) SMUMPS_LBUFR_BYTES = int( SMUMPS_LBUFR_BYTES8 ) C SMUMPS_LBUFR is the size of the buffer as a number of integers, C we round SMUMPS_LBUFR (size in #integers) above to have at least C SMUMPS_LBUFR_BYTES available in the buffer. SMUMPS_LBUFR = (SMUMPS_LBUFR_BYTES+KEEP(34)-1)/KEEP(34) C Finally, make SMUMPS_LBUFR_BYTES a multiple of KEEP(34) by setting C SMUMPS_LBUFR_BYTES to the number of bytes that will be allocated SMUMPS_LBUFR_BYTES = SMUMPS_LBUFR*KEEP(34) IF (KEEP(48)==5) THEN C Since the buffer is going to be allocated, use C it as the constraint for memory/granularity C in hybrid scheduler C id%KEEP8(21) = id%KEEP8(22) + & int( real(max(PERLU/2,MIN_PERLU))* & real(id%KEEP8(22))/100E0,8) ENDIF C C Now estimate the size for the buffer for asynchronous C sends of contribution blocks (so called CB). We want to be able to send at C least KEEP(213)/100 (two in general) messages at the C same time. C C Send buffer C ----------- IF (KEEP(486).NE.0) THEN SMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 * & real(KEEP(379)) * real(KEEP(35)), 8 ) ELSE SMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 * & real(KEEP(43)) * real(KEEP(35)), 8 ) ENDIF IF (KEEP(72).NE.1) THEN C ensure minimum size for small problems SMUMPS_LBUF8 = max( SMUMPS_LBUF8, 200000_8 ) SMUMPS_LBUF8 = SMUMPS_LBUF8 & + int( real(max(PERLU/2,MIN_PERLU))* & real(SMUMPS_LBUF8)/100E0, 8) ELSE C for very small pb force extra relaxation SMUMPS_LBUF8 = SMUMPS_LBUF8 & + int( real(max(PERLU,MIN_PERLU))* & real(SMUMPS_LBUF8)/100E0, 8) ENDIF C Make SMUMPS_LBUF8 small enough to be stored in a standard integer SMUMPS_LBUF8 = min(SMUMPS_LBUF8, int(huge(I4)-100,8)) C C No reason to have send buffer smaller than receive buffer. C This should never occur with the formulas above but just C in case: SMUMPS_LBUF8 = max(SMUMPS_LBUF8, SMUMPS_LBUFR_BYTES8+3*KEEP(34)) SMUMPS_LBUF = int(SMUMPS_LBUF8) IF(id%KEEP(48).EQ.4)THEN SMUMPS_LBUFR_BYTES=SMUMPS_LBUFR_BYTES*5 SMUMPS_LBUF=SMUMPS_LBUF*5 ENDIF C C Estimate size of buffer for small messages C Each node can send ( NSLAVES - 1 ) messages to (NSLAVES-1) nodes C C KEEP(56) is the number of nodes of level II. C Messages will be sent for the symmetric case C for synchronisation issues. C C We take an upperbound C SMUMPS_LBUF_INT = ( KEEP(56) + id%NSLAVES * id%NSLAVES ) * 5 & * KEEP(34) IF ( KEEP( 38 ) .NE. 0 ) THEN C C KKKK = MUMPS_PROCNODE( id%PROCNODE_STEPS(id%STEP(KEEP(38))), & id%KEEP(199) ) IF ( KKKK .EQ. id%MYID_NODES ) THEN SMUMPS_LBUF_INT = SMUMPS_LBUF_INT + 4 * KEEP(34) * & ( id%NSLAVES + id%NE_STEPS(id%STEP(KEEP(38))) & + min(KEEP(56), id%NE_STEPS(id%STEP(KEEP(38)))) * id%NSLAVES & ) END IF END IF C At this point, SMUMPS_LBUFR_BYTES, SMUMPS_LBUF C and SMUMPS_LBUF_INT have been computed (all C are in numbers of bytes). IF ( PROK ) THEN WRITE( MP, 9999 ) SMUMPS_LBUFR_BYTES, & SMUMPS_LBUF, SMUMPS_LBUF_INT ELSE IF (PROKG) THEN WRITE( MPG, 9999 ) SMUMPS_LBUFR_BYTES, & SMUMPS_LBUF, SMUMPS_LBUF_INT ENDIF END IF 9999 FORMAT( /,' Allocated buffers',/,' ------------------',/, & ' Size of reception buffer in bytes ...... = ', I12, & /, & ' Size of async. emission buffer (bytes).. = ', I12,/, & ' Small emission buffer (bytes) .......... = ', I12) C -------------------------- C Allocate small send buffer C required for SMUMPS_FAC_B C -------------------------- CALL MUMPS_BUF_ALLOC_SMALL_BUF( SMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)= -13 C convert to size in integer id%INFO(2)= SMUMPS_LBUF_INT id%INFO(2)= (SMUMPS_LBUF_INT+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Allocation error in MUMPS_BUF_ALLOC_SMALL_BUF' & ,id%INFO(2) ENDIF GO TO 110 END IF C C -------------------------------------- C Allocate reception buffer on all procs C This is done now. C -------------------------------------- ALLOCATE( BUFR( SMUMPS_LBUFR ),stat=IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = SMUMPS_LBUFR IF (LPOK) THEN WRITE(LP,*) & ': Allocation error for BUFR(', SMUMPS_LBUFR, & ') on MPI process',id%MYID ENDIF GO TO 110 END IF C ----------------------------------------- C Estimate MAXIS. IS will be allocated in C SMUMPS_FAC_B. It will contain factors and C contribution blocks integer information C ----------------------------------------- C Relax integer workspace based on PERLU PERLU = KEEP( 12 ) IF (KEEP(201).GT.0) THEN C OOC panel or non panel (note that C KEEP(15)=KEEP(225) if non panel) MAXIS_ESTIM = KEEP(225) ELSE C In-core or reals for factors not stored MAXIS_ESTIM = KEEP(15) ENDIF MAXIS = max( 1, int( min( int(huge(MAXIS),8), & int(MAXIS_ESTIM,8) + 3_8 * max(int(PERLU,8),10_8) * & ( int(MAXIS_ESTIM,8) / 100_8 + 1_8 ) & ) ! min & ) ! int & ) !max C ---------------------------- C Allocate PTLUST_S and PTRFAC C They will be used to access C factors in the solve phase. C They are also needed for C SMUMPS_FAC_L0_OMP. C ---------------------------- ALLOCATE( id%PTLUST_S( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(28) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%PTLUST_S(', id%KEEP(28),')' ENDIF NULLIFY(id%PTLUST_S) GOTO 110 END IF ALLOCATE( id%PTRFAC( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(28) NULLIFY(id%PTRFAC) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%PTRFAC(', id%KEEP(28),')' ENDIF GOTO 110 END IF C ----------------------------- C Reserve temporary workspace : C IPOOL, PTRWB, ITLOC, PTRIST C PTRWB will be subdivided again C in routine SMUMPS_FAC_B C ----------------------------- PTRIST = 1 PTRWB = PTRIST + id%KEEP(28) ITLOC = PTRWB + 2 * id%KEEP(28) C Fwd in facto: ITLOC of size id%N + id%KEEP(253) IPOOL = ITLOC + id%N + id%KEEP(253) C C -------------------------------- C NA(1) is an upperbound for LPOOL C -------------------------------- C Structure of the pool: C ____________________________________________________ C | Subtrees | | Top nodes | 1 2 3 | C ---------------------------------------------------- LPOOL = MUMPS_GET_POOL_LENGTH(id%NA(1), id%KEEP(1),id%KEEP8(1)) LIWK = IPOOL + LPOOL - 1 ALLOCATE( IWK( IPOOL + LPOOL - 1 ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=IPOOL + LPOOL - 1 IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for IWK(',IPOOL+LPOOL-1,')' ENDIF GOTO 110 END IF LIWK8 = 2 * id%KEEP(28) ALLOCATE(IWK8( 2 * id%KEEP(28)), stat = IERR) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=2 * id%KEEP(28) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for IWKB(', 2*id%KEEP(28),')' ENDIF GOTO 110 END IF C C Return to SPMD C ENDIF C 110 CONTINUE C ---------------- C Broadcast errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C IF ( I_AM_SLAVE ) THEN C Store size of receive buffers in SMUMPS_LBUF module CALL MUMPS_BUF_DIST_IRECV_SIZE( SMUMPS_LBUFR_BYTES ) IF (PROK) THEN WRITE( MP, 170 ) MAXS, MAXIS, MAXS_BASE8, KEEP(15), & id%KEEP8(26), id%KEEP8(27), id%KEEP8(11), KEEP(26), KEEP(27) ENDIF END IF C =============================================================== C Before calling the main driver, SMUMPS_FAC_B, C some statistics should be initialized to 0, C even on the host node because they will be C used in REDUCE operations afterwards. C -------------------------------------------- C Size of factors written. It will be set to POSFAC in C IC, otherwise we accumulate written factors in it. id%KEEP8(31)= 0_8 C Size of factors under L0 will be returned C in id%KEEP8(64), not included in KEEP8(31)) C Number of entries in factors id%KEEP8(10) = 0_8 C KEEP8(8) will hold the volume of extra copies due to C in-place stacking in fac_mem_stack.F id%KEEP8(8)=0_8 id%INFO(9:14)=0 RINFO(2:3)=ZERO IF ( I_AM_SLAVE ) THEN C ------------------------------------ C Call effective factorization routine C ------------------------------------ IF ( KEEP(55) .eq. 0 ) THEN LDPTRAR = 1 ! PTRAR no longer used (of size 2) ELSE LDPTRAR = id%NELT + 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN NELT_arg = id%NELT ELSE C ------------------------------ C Use size 1 to avoid complaints C when using check bound options C ------------------------------ NELT_arg = 1 END IF ENDIF IF (I_AM_SLAVE) THEN IF (associated(id%L0_OMP_MAPPING)) & DEALLOCATE(id%L0_OMP_MAPPING) IF (KEEP(400) .GT. 0) THEN id%LL0_OMP_MAPPING = KEEP(28) ELSE id%LL0_OMP_MAPPING = 1 ENDIF ALLOCATE(id%L0_OMP_MAPPING(id%LL0_OMP_MAPPING), stat=allocok) IF ( allocok > 0) THEN write(*,*) "Problem allocating L0_OMP_MAPPING", & IERR, KEEP(28) GOTO 115 ENDIF IF (KEEP(400) .GT. 0) THEN id%LL0_OMP_FACTORS = KEEP(400) ELSE id%LL0_OMP_FACTORS = 1 ENDIF ALLOCATE(idintr%L0_OMP_FACTORS(id%LL0_OMP_FACTORS), & stat = allocok) IF (allocok > 0) THEN id%INFO(1)=-7 id%INFO(2)=NB_THREADS GOTO 115 ENDIF CALL SMUMPS_INIT_L0_OMP_FACTORS(idintr%L0_OMP_FACTORS) ENDIF 115 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C Compute DKEEP(17) AVG_FLOPS = RINFOG(1)/(real(id%NSLAVES)) id%DKEEP(17) = max ( id%DKEEP(18), AVG_FLOPS/real(50) ) & IF (PROK.AND.id%MYID.EQ.MASTER) THEN IF (id%NSLAVES.LE.1) THEN WRITE(MP,'(/A,A,1PD10.3)') &' Start factorization with total', &' estimated flops (RINFOG(1)) = ', & RINFOG(1) ELSE WRITE(MP,'(/A,A,1PD10.3,A,1PD10.3)') &' Start factorization with total', &' estimated flops RINFOG(1) / Average per MPI proc = ', & RINFOG(1), ' / ', AVG_FLOPS ENDIF ENDIF IF (I_AM_SLAVE) THEN C IS/S pointers passed to SMUMPS_FAC_B with C implicit interface through intermediate C structure S_IS_POINTERS. IS will be allocated C during SMUMPS_FAC_B. C In case of L0OMP, id%IS and id%S are allocated during C SMUMPS_FAC_B, and only after L0OMP nodes are processed, C in order to limit the global memory peak. S_IS_POINTERS%IW => id%IS; NULLIFY(id%IS) S_IS_POINTERS%A => id%S ; NULLIFY(id%S) CALL SMUMPS_FAC_B(id%N,S_IS_POINTERS,MAXS,MAXIS,id%SYM_PERM(1), & id%NA(1),id%LNA,id%NE_STEPS(1),id%ND_STEPS(1), id%FILS(1), & id%STEP(1),id%FRERE_STEPS(1),id%DAD_STEPS(1),id%CANDIDATES(1,1), & id%ISTEP_TO_INIV2(1),id%TAB_POS_IN_PERE(1,1), id%PTRAR(1), &LDPTRAR,id%PTR8ARR(1),id%NINCOLARR(1),id%NINROWARR(1),id%PTRDEBARR & (1), IWK(PTRIST),id%PTLUST_S(1),id%PTRFAC(1),IWK(PTRWB),IWK8, & IWK(ITLOC),RHS_MUMPS(1),IWK(IPOOL),LPOOL,CNTL1,ICNTL(1), & id%INFO(1), RINFO(1),KEEP(1),id%KEEP8(1),id%PROCNODE_STEPS(1), & id%NSLAVES,id%COMM_NODES,id%MYID,id%MYID_NODES,BUFR,SMUMPS_LBUFR & , SMUMPS_LBUFR_BYTES, SMUMPS_LBUF, INTARR(1), DBLARR(1), & idintr%root, idintr%roota, NELT_arg, id%FRTPTR(1), id%FRTELT(1), & id%COMM_LOAD,id%ASS_IRECV,SEUIL,SEUIL_LDLT_NIV2,id%MEM_DIST(0), & id%DKEEP(1), PIVNUL_LIST_STRUCT, id%LRGROUPS(1) & ,id%IPOOL_B_L0_OMP(1),id%LPOOL_B_L0_OMP, & id%IPOOL_A_L0_OMP(1),id%LPOOL_A_L0_OMP,id%L_VIRT_L0_OMP, & id%VIRT_L0_OMP(1), id%VIRT_L0_OMP_MAPPING(1),id%L_PHYS_L0_OMP, & id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1), id%PTR_LEAFS_L0_OMP(1), & id%L0_OMP_MAPPING(1),id%LL0_OMP_MAPPING, id%THREAD_LA, & idintr%L0_OMP_FACTORS(1), id%LL0_OMP_FACTORS, & id%I4_L0_OMP(1,1), size(id%I4_L0_OMP,1), size(id%I4_L0_OMP,2), & id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), size(id%I8_L0_OMP,2) & ) id%IS => S_IS_POINTERS%IW; NULLIFY(S_IS_POINTERS%IW) id%S => S_IS_POINTERS%A ; NULLIFY(S_IS_POINTERS%A) C C ------------------------------ C Deallocate temporary workspace C ------------------------------ DEALLOCATE( IWK ) DEALLOCATE( IWK8 ) ENDIF C Fwd in facto: free RHS_MUMPS in case it was allocated. IF (RHS_MUMPS_ALLOCATED) THEN DEALLOCATE(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. ENDIF NULLIFY(RHS_MUMPS) C --------------------------------- C Free some workspace corresponding C to the original matrix in C arrowhead or elemental format. C ----- C Note : DBLARR may be a pointer C in case of element-entry. C --------------------------------- IF (allocated( INTARR )) DEALLOCATE( INTARR ) IF (DBLARR_ALLOCATED) THEN DEALLOCATE(DBLARR) DBLARR_ALLOCATED=.FALSE. ENDIF NULLIFY(DBLARR) C We also free RG2L now IF ( KEEP(38) .NE. 0) THEN IF (associated(idintr%root%RG2L)) THEN DEALLOCATE(idintr%root%RG2L) NULLIFY(idintr%root%RG2L) ENDIF ENDIF C C Memory statistics C ----------------------------------- C If QR (Keep(19)) is not zero, and if C the host does not have the information C (ie is not slave), send information C computed on the slaves during facto C to the host. C ----------------------------------- C Note the KEEP(17), KEEP(143) have been bcasted during fac_par_m IF ( KEEP(19) .NE. 0 ) THEN IF ( KEEP(46) .NE. 1 ) THEN C Host was not working during facto_root C Send him the information IF ( id%MYID .eq. MASTER ) THEN CALL MPI_RECV( KEEP(17), 1, MPI_INTEGER, 1, DEFIC_TAG, & id%COMM, STATUS, IERR ) CALL MPI_RECV( KEEP(143), 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 ) CALL MPI_SEND( KEEP(143), 1, MPI_INTEGER, 0, DEFIC_TAG, & id%COMM, IERR ) END IF END IF END IF C -------------------------------- C Deallocate communication buffers C They will be reallocated C in the solve. C -------------------------------- IF (allocated(BUFR)) DEALLOCATE(BUFR) CALL MUMPS_BUF_DEALL_SMALL_BUF( IERR ) C C Check for errors. C After SMUMPS_FAC_B every slave is aware of an error. C The call below informs the master, in case it is not C included in the computations. CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C CALL SMUMPS_EXTRACT_SCHUR_REDRHS(id,idintr) C return to user singular values IF (id%KEEP(19) .NE.0) THEN CALL SMUMPS_EXTRACT_SINGULAR_VALUES(id,idintr) ENDIF IF (KEEP(201) .GT. 0) THEN END IF IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIME) id%DKEEP(94)=real(TIME) IF (KEEP(400).GT.0) THEN C Facto time above L0_OMP = total time - facto time under L0_OMP id%DKEEP(96)=id%DKEEP(94)-id%DKEEP(95) ENDIF ENDIF C Time to process root node: CALL MPI_REDUCE( id%DKEEP(99), TMPTIME, 1, & MPI_REAL, & MPI_MAX, MASTER, id%COMM, IERR ) id%DKEEP(99)=TMPTIME C ===================================================================== C COMPUTE MEMORY ALLOCATED BY MUMPS, INFO(16) C --------------------------------------------- MEM_EFF_ALLOCATED = .TRUE. CALL SMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & BLR_STRAT, .TRUE., TOTAL_BYTES, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .FALSE. ! UNDER_L0_OMP & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN ! L0 activated CALL SMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .TRUE., id%KEEP(201), & BLR_STRAT, .TRUE., TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .TRUE. ! UNDER_L0_OMP & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF IF (id%KEEP8(24).NE.0) THEN C WK_USER is not part of memory allocated by MUMPS C and is not counted, id%KEEP8(23) should be zero id%INFO(16) = TOTAL_MBYTES ELSE C Note that even for the case of ICNTL(23)>0 C we report here the memory effectively allocated C that can be smaller than ICNTL(23) ! id%INFO(16) = TOTAL_MBYTES ENDIF C ---------------------------------------------------- C Centralize memory statistics on the host C id%INFOG(18) = size of mem in Mbytes for facto, C for the processor using largest memory C id%INFOG(19) = size of mem in Mbytes for facto, C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(16), id%INFOG(18), IRANK ) CALL SMUMPS_PRINT_ALLOCATED_MEM( PROK, PROKG, PRINT_MAXAVG, & MP, MPG, id%INFO(16), id%INFOG(18), id%INFOG(19), & id%NSLAVES, IRANK, & id%KEEP(1) ) C If WK_USER is provided, this memory excludes WK_USER IF (PROK ) THEN WRITE(MP,'(A,I12) ') & ' ** Eff. min. Space MBYTES for facto (INFO(16)):', & TOTAL_MBYTES ENDIF C ========================(INFO(16) RELATED)====================== C --------------------------------------- C COMPUTE EFFECTIVE MEMORY USED INFO(22) C --------------------------------------- PERLU_ON = .TRUE. MEM_EFF_ALLOCATED = .FALSE. CALL SMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .FALSE. ! UNDER_L0_OMP & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) IF (KEEP(400) .GT. 0 ) THEN ! L0 activated CALL SMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .TRUE., id%KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .TRUE. ! UNDER_L0_OMP & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1), & size(id%I8_L0_OMP,2) & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF C -- TOTAL_BYTES and TOTAL_MBYTES includes both static C -- (MAXS) and BLR structures computed as the SUM of the PEAKS C -- (KEEP8(67) + KEEP8(70)) id%KEEP8(7) = TOTAL_BYTES C -- INFO(22) holds the effective space (in Mbytes) used by MUMPS C -- (it includes part of WK_USER used if provided by user) id%INFO(22) = TOTAL_MBYTES C ---------------------------------------------------- C Centralize memory statistics on the host C INFOG(21) = size of effective mem (Mbytes) for facto, C for the processor using largest memory C INFOG(22) = size of effective mem (Mbytes) for facto, C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(22), id%INFOG(21), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' ** Memory effectively used, max in Mbytes (INFOG(21)):', & id%INFOG(21) ENDIF WRITE( MPG,'(A,I12) ') & ' ** Memory effectively used, total in Mbytes (INFOG(22)):', & id%INFOG(22) END IF SUM_INFO22_THIS_NODE=0 CALL MPI_REDUCE( id%INFO(22), SUM_INFO22_THIS_NODE, 1, & MPI_INTEGER, & MPI_SUM, 0, id%KEEP(411), IERR ) CALL MPI_REDUCE( SUM_INFO22_THIS_NODE, MAX_SUM_INFO22_THIS_NODE, & 1, MPI_INTEGER, MPI_MAX, 0, id%COMM, IERR ) IF (PROKG .AND. PRINT_NODEINFO) THEN WRITE(MPG,'(A,I12)') & ' ** Max. effective space per compute node, in MBytes :', & MAX_SUM_INFO22_THIS_NODE ENDIF C IF (I_AM_SLAVE) THEN K67 = id%KEEP8(67) K68 = id%KEEP8(68) K70 = id%KEEP8(70) K74 = id%KEEP8(74) K75 = id%KEEP8(75) ELSE K67 = 0_8 K68 = 0_8 K70 = 0_8 K74 = 0_8 K75 = 0_8 ENDIF C -- Save the number of entries effectively used C in main working array S CALL MUMPS_SETI8TOI4(K67,id%INFO(21)) C IF (id%NPROCS .GT. 1 .AND. id%KEEP(50) .NE. 0) THEN CALL MPI_REDUCE( id%KEEP8(131), id%KEEP8(132), 1, MPI_INTEGER8, & MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%KEEP8(131), id%KEEP8(133), 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%KEEP(175), id%KEEP(176), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR ) ENDIF C IF (KEEP(400) .GT.0 ) THEN IF (.NOT. I_AM_SLAVE) THEN id%DKEEP(95) = 0.0E0 id%DKEEP(16) = 0.0E0 ENDIF IF (id%NPROCS .GT. 1) THEN C Compute average and max (across MPI's) CALL MPI_REDUCE(id%DKEEP(95), TMPTIME, 1, & MPI_REAL, MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) TIMEAVG=dble(TMPTIME) CALL MPI_REDUCE(id%DKEEP(16), TMPFLOP, 1, & MPI_REAL, MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) FLOPAVG=dble(TMPFLOP) IF (id%MYID.EQ.MASTER) THEN TIMEAVG = TIMEAVG / id%NSLAVES FLOPAVG = FLOPAVG / id%NSLAVES ENDIF CALL MPI_REDUCE(id%DKEEP(95), TMPTIME, 1, & MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) TIMEMAX=dble(TMPTIME) CALL MPI_REDUCE(id%DKEEP(16), TMPFLOP, 1, & MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) FLOPMAX=dble(TMPFLOP) C (PROKG may only be true on master) IF ( PROKG ) THEN WRITE(MPG,190) FLOPAVG, FLOPMAX WRITE(MPG,188) TIMEAVG, TIMEMAX ENDIF ELSE C Print DKEEP(95) directly without reduction IF ( PROKG ) THEN WRITE(MPG,189) id%DKEEP(16) WRITE(MPG,187) id%DKEEP(95) ENDIF ENDIF ENDIF IF ( PROKG ) THEN IF ( ( KEEP(38).NE.0 .OR. KEEP(20).NE.0 ) .AND. & KEEP(60) .EQ. 0 ) THEN WRITE(MPG,186) id%DKEEP(99) ENDIF C Elapsed time for factorization: IF (id%INFO(1) .GE.0) THEN WRITE(MPG,180) id%DKEEP(94) ELSE WRITE(MPG,185) id%DKEEP(94) ENDIF ENDIF C C Sum RINFO(2) : total number of flops for assemblies C Sum RINFO(3) : total number of flops for eliminations C Initialize RINFO(4) in case BLR was not activated RINFO(4) = RINFO(3) C C Should work even if the master does some work C CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_REAL, & MPI_SUM, MASTER, id%COMM, IERR) C Reduce needed to dimension small working array C on all procs during SMUMPS_GATHER_SOLUTION KEEP(247) = 0 CALL MPI_REDUCE( KEEP(246), KEEP(247), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR) C C Reduce compression times: get max compression times CALL MPI_REDUCE( id%DKEEP(97), id%DKEEP(98), 1, & MPI_REAL, & MPI_MAX, MASTER, id%COMM, IERR) C CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_REAL, & MPI_SUM, MASTER, id%COMM, IERR) CALL MUMPS_REDUCEI8( id%KEEP8(31)+id%KEEP8(64),id%KEEP8(6), & MPI_SUM, MASTER, id%COMM ) C IF (id%MYID.EQ.0) THEN C In MegaBytes RINFOG(16) = real(id%KEEP8(6)*int(KEEP(35),8))/real(1E6) IF (KEEP(201).LE.0) THEN RINFOG(16) = ZERO ENDIF ENDIF CALL MUMPS_REDUCEI8( id%KEEP8(48),id%KEEP8(148), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(148), INFOG(9)) C CALL MPI_REDUCE( int(id%INFO(10),8), id%KEEP8(128), & 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SETI8TOI4(id%KEEP8(128), id%INFOG(10)) ENDIF C Use MPI_MAX for this one to get largest front size CALL MPI_ALLREDUCE( id%INFO(11), INFOG(11), 1, MPI_INTEGER, & MPI_MAX, id%COMM, IERR) C make maximum effective frontal size available on all procs C for solve phase C (Note that INFO(11) includes root size on root master) KEEP(133) = INFOG(11) CALL MPI_REDUCE( id%INFO(12), INFOG(12), 3, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( id%INFO(40), INFOG(50), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( KEEP(103), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(229) = INFOG(25) CALL MPI_REDUCE( KEEP(105), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(230) = INFOG(25) C id%INFO(25) = KEEP(98) CALL MPI_ALLREDUCE( id%INFO(25), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) C Extra copies due to in-place stacking CALL MUMPS_REDUCEI8( id%KEEP8(8), id%KEEP8(108), MPI_SUM, & MASTER, id%COMM ) C Entries in factors CALL MUMPS_SETI8TOI4(id%KEEP8(10), id%INFO(27)) CALL MUMPS_REDUCEI8( id%KEEP8(10),id%KEEP8(110), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(110), INFOG(29)) C Initialize INFO(28)/INFOG(35) in case BLR not activated id%INFO(28) = id%INFO(27) INFOG(35) = INFOG(29) C ============================== C LOW-RANK C ============================== IF ( KEEP(486) .NE. 0 ) THEN !LR is activated C Compute and Save local amount of flops in case of BLR RINFO(4) = real(FLOP_FRFRONTS + FLOP_FACTO_FR - FLOP_LRGAIN & + FLOP_COMPRESS + FLOP_FRFRONTS) C C Compute and Save local number of entries in compressed factors C ITMP8 = id%KEEP8(10) - int(MRY_LU_LRGAIN,8) CALL MUMPS_SETI8TOI4( ITMP8, id%INFO(28)) C CALL MPI_REDUCE( MRY_LU_LRGAIN, TMP_MRY_LU_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_LU_FR, TMP_MRY_LU_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_CB_FR, TMP_MRY_CB_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_CB_LRGAIN, TMP_MRY_CB_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_LRGAIN, TMP_FLOP_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM_FR, TMP_FLOP_TRSM_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM_LR, TMP_FLOP_TRSM_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_FR, TMP_FLOP_UPDATE_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_LR, TMP_FLOP_UPDATE_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FRSWAP_COMPRESS, & TMP_FLOP_FRSWAP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_MIDBLK_COMPRESS, & TMP_FLOP_MIDBLK_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_LRLR3, TMP_FLOP_UPDATE_LRLR3 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(FLOP_ACCUM_COMPRESS, TMP_FLOP_ACCUM_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM, TMP_FLOP_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_PANEL, TMP_FLOP_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FRFRONTS, TMP_FLOP_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_COMPRESS, TMP_FLOP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_DECOMPRESS, TMP_FLOP_DECOMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_CB_COMPRESS, TMP_FLOP_CB_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_CB_DECOMPRESS,TMP_FLOP_CB_DECOMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FACTO_FR, TMP_FLOP_FACTO_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( CNT_NODES,TMP_CNT_NODES & , 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%NPROCS.GT.1) THEN FLOP_FACTO_LR = FLOP_FACTO_FR - FLOP_LRGAIN & + FLOP_COMPRESS + FLOP_FRFRONTS CALL MPI_REDUCE( FLOP_FACTO_LR, AVG_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN AVG_FLOP_FACTO_LR = AVG_FLOP_FACTO_LR/id%NPROCS ENDIF CALL MPI_REDUCE( FLOP_FACTO_LR, MIN_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FACTO_LR, MAX_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR) ENDIF ! NPROCS > 1 CALL MPI_REDUCE( TIME_UPDATE, TMP_TIME_UPDATE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR1, TMP_TIME_UPDATE_LRLR1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR2, TMP_TIME_UPDATE_LRLR2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR3, TMP_TIME_UPDATE_LRLR3 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_FRLR, TMP_TIME_UPDATE_FRLR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_FRFR, TMP_TIME_UPDATE_FRFR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DIAGCOPY, TMP_TIME_DIAGCOPY & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_COMPRESS,TMP_TIME_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_MIDBLK_COMPRESS, & TMP_TIME_MIDBLK_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRSWAP_COMPRESS, & TMP_TIME_FRSWAP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_CB_COMPRESS, TMP_TIME_CB_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP, TMP_TIME_DECOMP & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_UCFS, TMP_TIME_DECOMP_UCFS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LRASM_NIV1, TMP_TIME_LRASM_NIV1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_LRASM_LOCASM2, TMP_TIME_LRASM_LOCASM2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_LRASM_MAPLIG1, TMP_TIME_LRASM_MAPLIG1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_LRASM_CONTRIB2, TMP_TIME_LRASM_CONTRIB2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_FRASM_LOCASM2, TMP_TIME_FRASM_LOCASM2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_FRASM_MAPLIG1, TMP_TIME_FRASM_MAPLIG1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_FRASM_CONTRIB2, TMP_TIME_FRASM_CONTRIB2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_PANEL, TMP_TIME_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_I, TMP_TIME_FAC_I & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_MQ, TMP_TIME_FAC_MQ & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_SQ, TMP_TIME_FAC_SQ & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LRTRSM, TMP_TIME_LRTRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRTRSM, TMP_TIME_FRTRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRFRONTS, TMP_TIME_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LR_MODULE, TMP_TIME_LR_MODULE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN IF (id%NPROCS.GT.1) THEN C rename the stat variable so that COMPUTE_GLOBAL_GAINS can work for any C number of procs MRY_LU_FR = TMP_MRY_LU_FR MRY_LU_LRGAIN = TMP_MRY_LU_LRGAIN MRY_CB_FR = TMP_MRY_CB_FR MRY_CB_LRGAIN = TMP_MRY_CB_LRGAIN FLOP_LRGAIN = TMP_FLOP_LRGAIN FLOP_PANEL = TMP_FLOP_PANEL FLOP_TRSM = TMP_FLOP_TRSM FLOP_TRSM_FR = TMP_FLOP_TRSM_FR FLOP_TRSM_LR = TMP_FLOP_TRSM_LR FLOP_UPDATE_FR = TMP_FLOP_UPDATE_FR FLOP_UPDATE_LR = TMP_FLOP_UPDATE_LR FLOP_UPDATE_LRLR3 = TMP_FLOP_UPDATE_LRLR3 FLOP_COMPRESS = TMP_FLOP_COMPRESS FLOP_MIDBLK_COMPRESS = TMP_FLOP_MIDBLK_COMPRESS FLOP_FRSWAP_COMPRESS = TMP_FLOP_FRSWAP_COMPRESS FLOP_ACCUM_COMPRESS = TMP_FLOP_ACCUM_COMPRESS FLOP_CB_COMPRESS = TMP_FLOP_CB_COMPRESS FLOP_DECOMPRESS = TMP_FLOP_DECOMPRESS FLOP_CB_DECOMPRESS = TMP_FLOP_CB_DECOMPRESS FLOP_FRFRONTS = TMP_FLOP_FRFRONTS FLOP_FACTO_FR = TMP_FLOP_FACTO_FR CNT_NODES = TMP_CNT_NODES TIME_UPDATE = TMP_TIME_UPDATE /id%NPROCS TIME_UPDATE_LRLR1 = TMP_TIME_UPDATE_LRLR1 /id%NPROCS TIME_UPDATE_LRLR2 = TMP_TIME_UPDATE_LRLR2 /id%NPROCS TIME_UPDATE_LRLR3 = TMP_TIME_UPDATE_LRLR3 /id%NPROCS TIME_UPDATE_FRLR = TMP_TIME_UPDATE_FRLR /id%NPROCS TIME_UPDATE_FRFR = TMP_TIME_UPDATE_FRFR /id%NPROCS TIME_COMPRESS = TMP_TIME_COMPRESS /id%NPROCS TIME_MIDBLK_COMPRESS = TMP_TIME_MIDBLK_COMPRESS/id%NPROCS TIME_FRSWAP_COMPRESS = TMP_TIME_FRSWAP_COMPRESS/id%NPROCS TIME_DIAGCOPY = TMP_TIME_DIAGCOPY /id%NPROCS TIME_CB_COMPRESS = TMP_TIME_CB_COMPRESS /id%NPROCS TIME_PANEL = TMP_TIME_PANEL /id%NPROCS TIME_FAC_I = TMP_TIME_FAC_I /id%NPROCS TIME_FAC_MQ = TMP_TIME_FAC_MQ /id%NPROCS TIME_FAC_SQ = TMP_TIME_FAC_SQ /id%NPROCS TIME_LRTRSM = TMP_TIME_LRTRSM /id%NPROCS TIME_FRTRSM = TMP_TIME_FRTRSM /id%NPROCS TIME_FRFRONTS = TMP_TIME_FRFRONTS /id%NPROCS TIME_LR_MODULE = TMP_TIME_LR_MODULE /id%NPROCS TIME_DECOMP = TMP_TIME_DECOMP /id%NPROCS TIME_DECOMP_UCFS = TMP_TIME_DECOMP_UCFS /id%NPROCS TIME_LRASM_NIV1 = TMP_TIME_LRASM_NIV1 /id%NPROCS TIME_LRASM_LOCASM2 = TMP_TIME_LRASM_LOCASM2 /id%NPROCS TIME_LRASM_MAPLIG1 = TMP_TIME_LRASM_MAPLIG1 /id%NPROCS TIME_LRASM_CONTRIB2 = TMP_TIME_LRASM_CONTRIB2 /id%NPROCS TIME_FRASM_LOCASM2 = TMP_TIME_FRASM_LOCASM2 /id%NPROCS TIME_FRASM_MAPLIG1 = TMP_TIME_FRASM_MAPLIG1 /id%NPROCS TIME_FRASM_CONTRIB2 = TMP_TIME_FRASM_CONTRIB2 /id%NPROCS ENDIF CALL COMPUTE_GLOBAL_GAINS(id%KEEP8(110), & dble(id%RINFOG(3)), & id%KEEP8(49), PROKG, MPG) C Number of entries in factor INFOG(35) in C compressed form is updated as long as C BLR is activated, this independently of the C fact that factors are saved in LR. CALL MUMPS_SETI8TOI4(id%KEEP8(49), id%INFOG(35)) FRONTWISE = 0 C WRITE gains also compute stats stored in DKEEP array DO I=1,LR_TABSIZE LR_TAB(I) = dble(id%DKEEP(I+LR_DKEEPSHIFT)) LR_EPSILON = dble(id%DKEEP(8)) ENDDO CALL SAVEandWRITE_GAINS(FRONTWISE, KEEP(489), & LR_DKEEPSHIFT, LR_TABSIZE, LR_TAB, LR_EPSILON, & N, id%ICNTL(36), & KEEP(487), KEEP(488), KEEP(490), & KEEP(491), KEEP(50), KEEP(486), & KEEP(249)*max(KEEP(381), 1), & KEEP(472), KEEP(475), KEEP(478), & KEEP(480), KEEP(481), & KEEP(483), KEEP(484), & id%KEEP8(110), id%KEEP8(49), & KEEP(28), id%NPROCS, MPG, PROKG) C flops when BLR activated RINFOG(14) = id%DKEEP(56) DO I=1,18 id%DKEEP(I+LR_DKEEPSHIFT)=real(LR_TAB(I)) ENDDO ELSE RINFOG(14) = 0.0E00 ENDIF IF (id%MYID .eq. MASTER) THEN KEEP(399) = KEEP399_SAVE ENDIF ENDIF C ============================== C NULL PIVOTS AND RANK-REVEALING C ============================== IF (KEEP(19).EQ.0.AND.KEEP(53).NE.0) THEN C restore KEEP(20) KEEP(20) = KEEP20_SAVE ENDIF IF(KEEP(110) .EQ. 1) THEN C -- make available to users the local number of null pivots detected C -- with ICNTL(24) = 1. id%INFO(18) = KEEP(109) CALL MPI_ALLREDUCE( KEEP(109), KEEP(112), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) ELSE id%INFO(18) = 0 KEEP(109) = 0 KEEP(112) = 0 ENDIF IF ( associated( id%PIVNUL_LIST) ) THEN DEALLOCATE(id%PIVNUL_LIST) NULLIFY(id%PIVNUL_LIST) ENDIF C set INFOG(28) even in case of error IF (id%MYID.EQ.MASTER) THEN C INFOG(28) deficiency resulting from ICNTL(24) and ICNTL(56) INFOG(28)=KEEP(112) IF (KEEP(17).GT.0) THEN INFOG(28)=KEEP(112)+KEEP(17) ENDIF ENDIF C IF (id%INFO(1).GE.0) THEN C{ PIVNUL_LIST not meaningful in case of error C (do not allocate) IF (id%MYID.EQ.MASTER) THEN IF ( INFOG(28) .GT. 0 ) THEN ALLOCATE(id%PIVNUL_LIST(INFOG(28)), stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=INFOG(28) END IF ENDIF ELSE C id%PIVNUL_LIST(1:KEEP(109)) used during sol_driver on slaves C to initialize id%RHSINTR IF (KEEP(109).GT.0) THEN ALLOCATE(id%PIVNUL_LIST(KEEP(109)), stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=INFOG(28) END IF ENDIF ENDIF C} ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 490 IF ( (KEEP(19).NE.0) .AND. (KEEP(143) .NE. KEEP(17)) ) THEN C C Raise a warning (on all MPI processes) since determinant or C inertia or null pivot list is not consistent with deficiency C computed with ICNTL(46)=1. C id%INFO(1) = id%INFO(1)+16 id%INFO(2) = KEEP(112)+KEEP(143) IF (KEEP(118) .GE. 40) THEN IF ( PROKG ) THEN WRITE(MPG,'(/A,A/,A,A,I8/,A,A,I8/)') & " WARNING: in the context of rank-revealing,", & " the inertia, determinant and pivnul list", & " are computed with RR (rank-revealing)-LU,", & " but the deficiency found by RR-LU: ", & id%INFO(2), & " is different from the deficiency computed", & " with ICNTL(56)>0: ", KEEP(112)+KEEP(17) ENDIF ELSE IF ( LP .GT. 0 ) THEN WRITE(LP,'(/A,A/,A/)') & " ERROR : in the context of rank-revealing,", & " the inertia, determinant and pivnul list", & " are not correct because RR LU not called " ENDIF ENDIF ENDIF C ======================================== C We now provide to the host the part of C PIVNUL_LIST resulting from the processing C of the root node and we update id%INFO(18) C on the processor holding the root to C include null pivots relative to the root C ======================================== IF ( KEEP(109).GT.0 ) THEN DO I=1, KEEP(109) id%PIVNUL_LIST(I)= & PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) ENDDO ENDIF IF (KEEP(17) .NE. 0) THEN IF (id%MYID .EQ. ID_ROOT) THEN C Include in id%INFO(18) null pivots resulting C from deficiency on the root. In this way, C the sum of all id%INFO(18) is equal to INFOG(28). id%INFO(18)=id%INFO(18)+KEEP(17) ENDIF IF (ID_ROOT .EQ. MASTER) THEN IF (id%MYID.EQ.MASTER) THEN C -------------------------------------------------- C Null pivots of root have been stored in C PIVNUL_LIST_STRUCT%PIVNUL_LIST( C KEEP(109)+1:KEEP(109)+KEEP(17) ) C Shift them at the end of the list because: C * this is what we need to build the null space C * we would otherwise overwrite them on the host C when gathering null pivots from other processors C -------------------------------------------------- DO I= KEEP(17), 1, -1 id%PIVNUL_LIST(KEEP(112)+I)= & PIVNUL_LIST_STRUCT%PIVNUL_LIST(KEEP(109)+I) ENDDO ENDIF ELSE C --------------------------------- C Null pivots of root must be sent C from the processor responsible of C the root to the host (or MASTER). C --------------------------------- IF (id%MYID .EQ. ID_ROOT) THEN CALL MPI_SEND( & PIVNUL_LIST_STRUCT%PIVNUL_LIST(KEEP(109)+1), & KEEP(17), MPI_INTEGER, MASTER, ZERO_PIV, & id%COMM, IERR) ELSE IF (id%MYID .EQ. MASTER) THEN CALL MPI_RECV(id%PIVNUL_LIST(KEEP(112)+1), KEEP(17), & MPI_INTEGER, ID_ROOT, ZERO_PIV, & id%COMM, STATUS, IERR ) ENDIF ENDIF ENDIF C =========================== C gather zero pivots indices C on the host node C =========================== C In case of non working host, the following code also C works considering that KEEP(109) is equal to 0 on C the non-working host IF(KEEP(110) .EQ. 1) THEN ALLOCATE(ITMP2(id%NPROCS),stat = IERR ) ! deallocated in 490 IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%NPROCS END IF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 490 CALL MPI_GATHER ( KEEP(109),1, MPI_INTEGER, & ITMP2(1), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF(id%MYID .EQ. MASTER) THEN POSBUF = ITMP2(1)+1 C First null pivot of master is in C position 1 of global list KEEP(220)=1 DO I = 1,id%NPROCS-1 IF (ITMP2(I+1).GT.0) THEN CALL MPI_RECV(id%PIVNUL_LIST(POSBUF), ITMP2(I+1), & MPI_INTEGER,I, & ZERO_PIV, id%COMM, STATUS, IERR) C Send position POSBUF of first null pivot of proc I C in global list. Will allow to quickly identify during C the solve step if one is concerned by a global position C K, 0 <= K <= INFOG(28). CALL MPI_SEND(POSBUF, 1, MPI_INTEGER, I, ZERO_PIV, & id%COMM, IERR) POSBUF = POSBUF + ITMP2(I+1) ENDIF ENDDO ELSE IF (KEEP(109).GT.0) THEN CALL MPI_SEND( & PIVNUL_LIST_STRUCT%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 ENDIF IF (associated( PIVNUL_LIST_STRUCT%PIVNUL_LIST)) THEN DEALLOCATE(PIVNUL_LIST_STRUCT%PIVNUL_LIST) NULLIFY(PIVNUL_LIST_STRUCT%PIVNUL_LIST) ENDIF C ===================================== C Statistics concerning the determinant C ===================================== C C 1/ on the host better take into account null pivots if scaling: C C Since null pivots are excluded from the computation C of the determinant, we also exclude the corresponding C scaling entries. Since those entries have already been C taken into account before the factorization, we multiply C the determinant on the host by the scaling values corresponding C to pivots in PIVNUL_LIST. IF (id%MYID.EQ.MASTER .AND. LSCAL. AND. KEEP(258).NE.0) THEN K = min(KEEP(143), KEEP(17)) K = max(K, 0) DO I = 1, KEEP(112)+ K c DO I = 1, id%INFOG(28) ! all null pivots + singular values CALL SMUMPS_UPDATEDETER_SCALING( & id%ROWSCA(id%PIVNUL_LIST(I)), & id%DKEEP(6), KEEP(259)) CALL SMUMPS_UPDATEDETER_SCALING( & id%COLSCA(id%PIVNUL_LIST(I)), & id%DKEEP(6), KEEP(259)) ENDDO ENDIF C C 2/ Swap signs depending on pivoting on each proc C IF (KEEP(258).NE.0) THEN C Return the determinant in INFOG(34) and RINFOG(12/13) C In case of real arithmetic, initialize C RINFOG(13) to 0 (no imaginary part and C not touched by SMUMPS_DETER_REDUCTION) RINFOG(13)=0.0E0 IF (KEEP(260).EQ.-1) THEN ! Local to each processor id%DKEEP(6)=-id%DKEEP(6) ENDIF C C 3/ Perform a reduction C CALL SMUMPS_DETER_REDUCTION( & id%COMM, id%DKEEP(6), KEEP(259), & RINFOG(12), INFOG(34), id%NPROCS) C C 4/ Swap sign if needed C IF (id%KEEP(50).EQ.0 .AND. id%MYID.EQ. MASTER) THEN C Modify sign of determinant according C to unsymmetric permutation (max-trans C of max-weighted matching) IF (id%KEEP(23).NE.0) THEN CALL SMUMPS_DETER_SIGN_PERM( & RINFOG(12), id%N, & id%UNS_PERM(1) ) C Remark that RINFOG(12/13) are modified only C on the host but will be broadcast on exit C from MUMPS (see SMUMPS_DRIVER) ENDIF ENDIF ENDIF 490 IF (allocated(ITMP2)) DEALLOCATE(ITMP2) C C ===================================== C Statistics relative to min/max pivots C ===================================== CALL MPI_REDUCE( id%DKEEP(19), RINFOG(19), 1, & MPI_REAL, & MPI_MIN, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(20), RINFOG(20), 1, & MPI_REAL, & MPI_MIN, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(21), RINFOG(21), 1, & MPI_REAL, & MPI_MAX, MASTER, id%COMM, IERR ) C ========================================= C Centralized number of swaps for pivoting C ========================================= CALL MPI_REDUCE( id%KEEP8(80), ITEMP8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF (id%MYID .EQ. MASTER) THEN CALL MUMPS_SETI8TOI4(ITEMP8,id%INFOG(48)) ENDIF C ========================================== C Centralized largest increase of panel size C ========================================== CALL MPI_REDUCE( id%KEEP(425), id%INFOG(49), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN C{ ----------------------------- C PRINT STATISTICS (on master) C ----------------------------- WRITE(MPG,99984) RINFOG(2),RINFOG(3),KEEP(52), & id%KEEP8(148), & id%KEEP8(128), INFOG(11), id%KEEP8(110) IF (id%KEEP(50) == 1 .OR. id%KEEP(50) == 2) THEN ! negative pivots WRITE(MPG, 99987) INFOG(12) END IF IF (id%KEEP(50) == 0) THEN ! off diag pivots WRITE(MPG, 99985) INFOG(12) END IF IF (id%KEEP(50) .NE. 1) THEN ! delayed pivots WRITE(MPG, 99982) INFOG(13) END IF IF (KEEP(97) .NE. 0) THEN ! tiny pivots WRITE(MPG, '(A,D16.4)') & ' Effective static pivoting thresh., CNTL(4) =', SEUIL WRITE(MPG, 99986) INFOG(25) ENDIF IF (id%KEEP(50) == 2) THEN !number of 2x2 pivots in type 1 nodes WRITE(MPG, 99988) KEEP(229) !number of 2x2 pivots in type 2 nodes WRITE(MPG, 99989) KEEP(230) ENDIF !number of zero pivots IF (KEEP(110) .NE.0) THEN WRITE(MPG, 99991) KEEP(112) ENDIF !Deficiency on root IF ( KEEP(19) .ne. 0 ) c IF ( KEEP(17) .ne. 0 ) & WRITE(MPG, 99983) KEEP(17) !Total deficiency IF (KEEP(110).NE.0.OR.KEEP(19).NE.0) & WRITE(MPG, 99992) KEEP(17)+KEEP(112) ! = INFOG(28) IF (id%KEEP(50) .EQ. 1 .OR. id%KEEP(50) .EQ. 2) THEN IF (KEEP(110) .NE. 0 .OR .KEEP(19).NE.0) THEN WRITE(MPG, 99997) INFOG(50) ENDIF ENDIF !Smallest pivot with also null pivots in abs value WRITE(MPG, 99995) RINFOG(19) !Smallest pivot in abs value WRITE(MPG, 99993) RINFOG(20) !Largest pivot in abs value WRITE(MPG, 99994) RINFOG(21) !value of ICNTL(12) that was effectively used. WRITE(MPG, 99996) INFOG(24) ! Memory compress WRITE(MPG, 99981) INFOG(14) ! Extra copies due to ip stack in unsym case ! in core case (or OLD_OOC_PANEL) IF (id%KEEP8(108) .GT. 0_8) THEN WRITE(MPG, 99980) id%KEEP8(108) ENDIF IF ((KEEP(60).NE.0) .AND. INFOG(25).GT.0) THEN ! Schur on and tiny pivots set in last level ! before the Schur if KEEP(114)=0 WRITE(MPG, '(A)') & " ** Warning Static pivoting was necessary" WRITE(MPG, '(A)') & " ** to factor interior variables with Schur ON" ENDIF IF (KEEP(258).NE.0) THEN WRITE(MPG,99978) RINFOG(12) WRITE(MPG,99977) INFOG(34) ENDIF C} END IF * ========================================== * * End of Factorization Phase * * ========================================== C C Goto 500 is done when C LOAD_INIT C OOC_INIT_FACTO C MUMPS_FDM_INIT #if ! defined(NO_FDM_DESCBAND) C MUMPS_FDBD_INIT #endif #if ! defined(NO_FDM_MAPROW) C MUMPS_FMRD_INIT #endif C are all called. C 500 CONTINUE C Redo free INTARR and DBLARR in case an error occurred C after allocating them and before freeing them. IF (associated(DBLARR)) THEN DEALLOCATE(DBLARR) NULLIFY(DBLARR) ENDIF IF (allocated(INTARR)) THEN DEALLOCATE(INTARR) ENDIF IF ( KEEP(38) .NE. 0) THEN IF (associated(idintr%root%RG2L)) THEN DEALLOCATE(idintr%root%RG2L) NULLIFY(idintr%root%RG2L) ENDIF ENDIF #if ! defined(NO_FDM_DESCBAND) IF (I_AM_SLAVE) THEN CALL MUMPS_FDBD_END(id%INFO(1)) ! INFO(1): input only ENDIF #endif #if ! defined(NO_FDM_MAPROW) IF (I_AM_SLAVE) THEN CALL MUMPS_FMRD_END(id%INFO(1)) ! INFO(1): input only ENDIF #endif IF (I_AM_SLAVE) THEN C Terminate BLR module except if it is still needed for solve IF ( & ( & (KEEP(486).EQ.2) & ) & .AND. id%INFO(1).GE.0 & ) THEN C Store pointer to BLR_ARRAY in MUMPS structure C (requires successful factorization otherwise module is freed) CALL SMUMPS_BLR_MOD_TO_STRUC(id%BLRARRAY_ENCODING) ELSE C INFO(1) positive or negative CALL SMUMPS_BLR_END_MODULE(id%INFO(1), id%KEEP8, id%KEEP(34)) ENDIF ENDIF IF (I_AM_SLAVE) THEN CALL MUMPS_FDM_END('A') C Terminate BLR module except if it is still needed for solve IF ( & ( & (KEEP(486).EQ.2) & ) & .AND. id%INFO(1).GE.0 & ) THEN CALL MUMPS_FDM_MOD_TO_STRUC('F', id%FDM_F_ENCODING, & id%INFO(1)) IF (.NOT. associated(id%FDM_F_ENCODING)) THEN WRITE(*,*) "Internal error 2 in SMUMPS_FAC_DRIVER" ENDIF ELSE CALL MUMPS_FDM_END('F') ENDIF ENDIF C C Goto 514 is done when an C error occurred in MUMPS_FDM_INIT C or (after FDM_INIT but before C OOC_INIT) C 514 CONTINUE IF ( I_AM_SLAVE ) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL SMUMPS_OOC_END_FACTO(id%KEEP,id%KEEP8, & id%OOC_MAX_NB_NODES_FOR_ZONE,id%OOC_TOTAL_NB_NODES, & id%OOC_FILE_NAMES, id%INFO, id%OOC_FILE_NAME_LENGTH, & id%OOC_NB_FILES, IERR) IF (id%ASSOCIATED_OOC_FILES) THEN id%ASSOCIATED_OOC_FILES = .FALSE. ENDIF IF (IERR.LT.0 .AND. id%INFO(1) .GE. 0) id%INFO(1) = IERR ENDIF IF (WK_USER_PROVIDED) THEN C at the end of a phase S is always null when WK_USER provided NULLIFY(id%S) ELSE IF (KEEP(201).NE.0) THEN C ---------------------------------------- C In OOC or if KEEP(201).EQ.-1 we always C free S at end of factorization. As id%S C may be unassociated in case of error C during or before the allocation of id%S, C we only free S when it was associated. C ---------------------------------------- IF (associated(id%S)) THEN CALL SMUMPS_DM_FREE_S_WK(id%S, KEEP(430)) C Reset KEEP(430)=0 since S will be allocated C from Fortran during solve KEEP(430) = 0 ENDIF NULLIFY(id%S) ! in all cases id%KEEP8(23)=0_8 ELSE ! in core CALL SMUMPS_TRY_COMPACT_FACTORS(ICNTL49_LOC, & WK_USER_PROVIDED, id%S, id%KEEP, id%KEEP8, & id%INFO, id%MYID, id%ICNTL, PROK, MP, & SMUMPS_LBUFR_BYTES8, SMUMPS_LBUF8, & LIWK, LIWK8 ) ENDIF ELSE ! host not working IF (WK_USER_PROVIDED) THEN C at the end of a phase S is always freed when WK_USER provided NULLIFY(id%S) ELSE IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) id%KEEP8(23)=0_8 END IF END IF C C Goto 513 is done in case of error where LOAD_INIT was C called but not the scaling nor OOC_INIT_FACTO. 513 CONTINUE IF ( I_AM_SLAVE ) THEN CALL MUMPS_LOAD_END( id%INFO(1), id%NSLAVES, IERR ) IF (IERR.LT.0 .AND. id%INFO(1) .GE. 0) id%INFO(1) = IERR ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C C Goto 516 is done in case of error when GPU initialiwqtion C has been performed and scaling was optionally computed but C not LOAD_INIT nor OOC_INIT_FACTO. We can then extract C scaling arrays in case of error. 516 CONTINUE C -------------------------------------------- C We now build id%ROWSCA_loc and id%COLSCA_loc C in case of successful factorization, in the C numbering associated to the fully summed C variables of the frontal matrices. C This requires the factorization to be C successful because otherwise we do not have C the final lists of pivots associated to C the fronts, including delayed pivots and C symmetric/unsymmetric permutations done C during the factorization process. C -------------------------------------------- IF (LSCAL .AND. id%INFO(1).GE.0) THEN CALL SMUMPS_EXTRACT_SCALING(id) C occurs during scaling extraction, keep the error. IF ( id%INFO(1) .LT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) "Facto OK but error during EXTRACT_SCALING", & id%INFO(1:2) ENDIF ENDIF ENDIF C C Goto 517 is done when an error occurs when GPU initialization C has been performed but not LOAD_INIT or OOC_INIT_FACTO, e.g. C when an error occurred during the scaling. 517 CONTINUE IF (associated( PIVNUL_LIST_STRUCT%PIVNUL_LIST)) THEN DEALLOCATE(PIVNUL_LIST_STRUCT%PIVNUL_LIST) NULLIFY(PIVNUL_LIST_STRUCT%PIVNUL_LIST) ENDIF C C Goto 530 is done when an error occurs before C the calls to GPU_INIT, LOAD_INIT and OOC_INIT_FACTO 530 CONTINUE C Fwd in facto: free RHS_MUMPS in case C it was allocated. IF (RHS_MUMPS_ALLOCATED) DEALLOCATE(RHS_MUMPS) NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. C id%KEEP8(26) = KEEP826_SAVE RETURN 120 FORMAT(/' Local redistrib: data local/sent =',I16,I16) 125 FORMAT(/' Redistrib: total data local/sent =',I16,I16) 130 FORMAT(//'****** FACTORIZATION STEP ********'/) 140 FORMAT(/' Statistics on the scaling phase' & /' Elapsed time for scaling =',F12.4) 160 FORMAT( & ' Elapsed time to reformat/distribute matrix =',F12.4/) 166 FORMAT(' Max difference from 1 after scaling the entries', & ' for ONE-NORM (option 7/8) =',D9.2/) 170 FORMAT(' STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' Size of internal working array S =',I16/ & ' Size of internal working array IS =',I16/ & ' Minimum (ICNTL(14)=0) size of S =',I16/ & ' Minimum (ICNTL(14)=0) size of IS =',I16/ & ' Real space for original matrix =',I16/ & ' Integer space for original matrix =',I16/ & ' INFO(3) Real space for factors (estimated) =',I16/ & ' INFO(4) Integer space for factors (estim.) =',I16/ & ' Maximum frontal size (estimated) =',I16) 172 FORMAT(' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' Number of working processes =',I16/ & ' ICNTL(22) Out-of-core option =',I16/ & ' ICNTL(35) BLR activation (eff. choice) =',I16/ & ' ICNTL(37) BLR CB compression (eff. choice) =',I16/ & ' ICNTL(49) Compact workarray S (end facto.) =',I16/ & ' ICNTL(56) Effective value during facto. =',I16/ & ' ICNTL(14) Memory relaxation =',I16/ & ' INFOG(3) Real space for factors (estimated)=',I16/ & ' INFOG(4) Integer space for factors (estim.)=',I16/ & ' Maximum frontal size (estimated) =',I16/ & ' Number of nodes in the tree =',I16/ & ' ICNTL(23) Memory allowed (value on host) =',I16/ & ' Sum over all procs =',I16/ & ' Memory provided by user, sum of LWK_USER =',I16/ & ' Effective threshold for pivoting, CNTL(1) =',D16.4) 173 FORMAT( ' Perform forward during facto, NRHS =',I16) 174 FORMAT( ' KEEP(268) Relaxed pivoting effective value =',I16) 180 FORMAT(/' Elapsed time for factorization =', & F12.4) 185 FORMAT(/' Elapsed time for (failed) factorization =', & F12.4) 186 FORMAT(/' Elapsed time to process root node =', & F12.4) 187 FORMAT( ' Elapsed time under L0 =',F12.4) 188 FORMAT( ' Elapsed time under L0 (avg/max across MPI) =', & F12.4,F12.4) 189 FORMAT(/' Flops under L0 layer =',1PD12.3) 190 FORMAT(/' Flops under L0 layer (avg/max across MPI) =', & 1PD12.3,1PD12.3) 99977 FORMAT( ' INFOG(34) Determinant (base 2 exponent) =', & I16) 99978 FORMAT( ' RINFOG(12) Determinant (real part) =', & F16.8) 99980 FORMAT( ' Extra copies due to In-Place stacking =', & I16) 99981 FORMAT( ' INFOG (14) Number of memory compress =', & I16) 99982 FORMAT( ' INFOG (13) Number of delayed pivots =', & I16) 99983 FORMAT( ' Nb of singularities detected by ICNTL(56) =', & I16) 99991 FORMAT( ' Nb of null pivots detected by ICNTL(24) =', & I16) 99992 FORMAT( ' INFOG (28) Estimated deficiency =', & I16) 99997 FORMAT( ' INFOG (50) Number of negative AND null pivots =', & I16) 99995 FORMAT( ' RINFOG(19) Smallest pivot WITH perturbed pivots =', & 1PD10.3) 99993 FORMAT( ' RINFOG(20) Smallest pivot WITHOUT perturbed pivots =', & 1PD10.3) 99994 FORMAT( ' RINFOG(21) Largest pivot in absolute value =', & 1PD10.3) 99996 FORMAT( ' INFOG (24) Effective value of ICNTL(12) =', & I16) 99984 FORMAT(/'Leaving factorization with ...'/ & ' RINFOG (2) Operations in node assembly =', & 1PD10.3/ & ' ------ (3) Operations in node elimination =', & 1PD10.3/ & ' ICNTL (8) Scaling effectively used =', & I16/ & ' INFOG (9) Real space for factors =', & I16/ & ' INFOG (10) Integer space for factors =', & I16/ & ' INFOG (11) Maximum front size =', & I16/ & ' INFOG (29) Number of entries in factors =', & I16) 99985 FORMAT( ' INFOG (12) Number of off diagonal pivots =', & I16) 99986 FORMAT( ' INFOG (25) Number of tiny pivots(static) =', & I16) 99987 FORMAT( ' INFOG (12) Number of negative pivots =', & I16) 99988 FORMAT( ' Number of 2x2 pivots in type 1 nodes =', & I16) 99989 FORMAT( ' Number of 2x2 pivots in type 2 nodes =', & I16) END SUBROUTINE SMUMPS_FAC_DRIVER C SUBROUTINE SMUMPS_PRINT_ALLOCATED_MEM( PROK, PROKG, PRINT_MAXAVG, & MP, MPG, INFO16, INFOG18, INFOG19, NSLAVES, IRANK, KEEP ) IMPLICIT NONE C C Purpose: C ======= C Print memory allocated during factorization C - called at beginning of factorization in full-rank C - called at end of factorization in low-rank (because C of dynamic allocations) C LOGICAL, INTENT(IN) :: PROK, PROKG, PRINT_MAXAVG INTEGER, INTENT(IN) :: MP, MPG, INFO16, INFOG18, INFOG19 INTEGER, INTENT(IN) :: IRANK, NSLAVES INTEGER, INTENT(IN) :: KEEP(500) C IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' ** Memory allocated, max in Mbytes (INFOG(18)):', & INFOG18 ENDIF WRITE( MPG,'(/A,I12) ') & ' ** Memory allocated, total in Mbytes (INFOG(19)):', & INFOG19 END IF RETURN END SUBROUTINE SMUMPS_PRINT_ALLOCATED_MEM SUBROUTINE SMUMPS_AVGMAX_STAT8(PROKG, MPG, VAL, NSLAVES, & PRINT_MAXAVG, COMM, MSG) IMPLICIT NONE INCLUDE 'mpif.h' LOGICAL, intent(in) :: PROKG INTEGER, intent(in) :: MPG INTEGER(8), intent(in) :: VAL INTEGER, intent(in) :: NSLAVES LOGICAL, intent(in) :: PRINT_MAXAVG INTEGER, intent(in) :: COMM CHARACTER*48 MSG C Local INTEGER(8) MAX_VAL INTEGER IERR, MASTER REAL LOC_VAL, AVG_VAL PARAMETER(MASTER=0) C CALL MUMPS_REDUCEI8( VAL, MAX_VAL, MPI_MAX, MASTER, COMM) LOC_VAL = real(VAL)/real(NSLAVES) CALL MPI_REDUCE( LOC_VAL, AVG_VAL, 1, MPI_REAL, & MPI_SUM, MASTER, COMM, IERR ) IF (PROKG) THEN IF (PRINT_MAXAVG) THEN WRITE(MPG,100) " Average", MSG, int(AVG_VAL,8) ELSE WRITE(MPG,110) MSG, MAX_VAL ENDIF ENDIF RETURN 100 FORMAT(A8,A48,I18) 110 FORMAT(A48,I18) END SUBROUTINE SMUMPS_AVGMAX_STAT8 C C C ================================================================== C SUBROUTINE SMUMPS_EXTRACT_SCALING(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C Extract distributed scaling arrays from SMUMPS_EXTRACT_SCALING C In case of unsymmetric permutation, ROWSCA and COLSCA correspond C to Dr and Dc, in the expression Dr A Q Dc. In other terms, Dc C is compatbile with the front column indices, it does not C correspond to the column indices of A, meaning that Q is not C needed to just extract the scaling values. C C TYPE(SMUMPS_STRUC) :: id INTEGER, EXTERNAL :: MUMPS_PROCNODE C C MPI C === C INCLUDE 'mpif.h' C C Local declarations C ================== C REAL, DIMENSION(:), POINTER :: COLSCA REAL, DIMENSION(:), POINTER :: ROWSCA INTEGER, PARAMETER :: MASTER = 0 C INTEGER :: ISTEP, NPIV, LIELL INTEGER :: IERR_MPI, allocok INTEGER :: ISCA INTEGER :: JROW, JCOL, IPOS, JJ ! access to IS INTEGER :: LIW_PASSED INTEGER(8) :: LALLOC C C Free and reallocate distributed scaling arrays : C - in symmetric, COLSCA_loc points on ROWSCA_loc. C - not allocated if KEEP(89)=0 C NULLIFY(ROWSCA) NULLIFY(COLSCA) IF (associated(id%ROWSCA_loc)) THEN DEALLOCATE(id%ROWSCA_loc) NULLIFY(id%ROWSCA_loc) ENDIF IF (associated(id%COLSCA_loc)) THEN IF (id%KEEP(50) .EQ. 0) THEN DEALLOCATE(id%COLSCA_loc) ENDIF NULLIFY(id%COLSCA_loc) ENDIF C id%ROWSCA and id%COLSCA are available on master, C allocate ROWSCA and COLSCA of order N on other procs IF ( id%MYID .EQ. MASTER ) THEN ROWSCA => id%ROWSCA COLSCA => id%COLSCA IF (.NOT. associated(ROWSCA)) THEN WRITE(*,*) "Internal error 1 in SMUMPS_EXTRACT_SCALING" CALL MUMPS_ABORT() ENDIF IF (.NOT. associated(COLSCA)) THEN WRITE(*,*) "Internal error 2 in SMUMPS_EXTRACT_SCALING" CALL MUMPS_ABORT() ENDIF ELSE IF (id%KEEP(50).EQ.0) THEN ALLOCATE(ROWSCA(id%N),COLSCA(id%N),stat=allocok) LALLOC = int(id%N+id%N,8) ELSE ALLOCATE(ROWSCA(id%N),stat=allocok) COLSCA => ROWSCA LALLOC = int(id%N,8) ENDIF IF (allocok .GT. 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(LALLOC,id%INFO(2)) ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C Jump to 110 in case of error on ROWSCA or COLSCA C on one of the MPI processes. IF (id%INFO(1) .LT. 0) GOTO 110 C IF ( id%KEEP(89) .GT. 0) THEN IF (id%KEEP(50).EQ.0) THEN ALLOCATE(id%ROWSCA_loc(id%KEEP(89)), & id%COLSCA_loc(id%KEEP(89)),stat=allocok) LALLOC = int(id%KEEP(89),8)*2_8 ELSE ALLOCATE(id%ROWSCA_loc(id%KEEP(89)),stat=allocok) id%COLSCA_loc => id%ROWSCA_loc LALLOC = int(id%KEEP(89),8) ENDIF IF (allocok .GT. 0) THEN id%INFO(1)=-13 CALL MUMPS_SET_IERROR(LALLOC,id%INFO(2)) ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C Jump to 100 in case of error (we free everything) IF (id%INFO(1) .LT. 0) GOTO 100 CALL MPI_BCAST(ROWSCA(1), id%N, MPI_REAL, & MASTER, id%COMM, IERR_MPI) IF (id%KEEP(50) .EQ. 0) THEN CALL MPI_BCAST(COLSCA(1), id%N, MPI_REAL, & MASTER, id%COMM, IERR_MPI) ENDIF LIW_PASSED = max(id%KEEP(32),1) ISCA = 1 IF ( id%MYID .ne. MASTER .OR. & id%KEEP(46) .eq. 1 ) THEN ! I_AM_SLAVE DO ISTEP = 1, id%KEEP(28) IF ( id%MYID_NODES.EQ. MUMPS_PROCNODE( & id%PROCNODE_STEPS(ISTEP), & id%KEEP(199) ) ) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, id%KEEP, & NPIV, LIELL, IPOS, & id%IS(1), LIW_PASSED, id%PTLUST_S(1), id%STEP(1), id%N) IF ( id%KEEP(50) .EQ. 0 ) THEN C Row indices: JROW = IPOS + 1 C Column indices: JCOL = IPOS + 1 + LIELL ELSE C Use row indices because column indices may have C been set to negative to flag 2x2 pivots JROW = IPOS + 1 ENDIF IF (id%KEEP(50).EQ.0) THEN DO JJ = 1, NPIV id%ROWSCA_loc(ISCA+JJ-1) = ROWSCA(id%IS(JROW+JJ-1)) id%COLSCA_loc(ISCA+JJ-1) = COLSCA(id%IS(JCOL+JJ-1)) ENDDO ELSE DO JJ = 1, NPIV id%ROWSCA_loc(ISCA+JJ-1) = ROWSCA(id%IS(JROW+JJ-1)) ENDDO ENDIF ISCA = ISCA + NPIV ENDIF ENDDO ENDIF C End of EXTRACT_SCALING, we keep id%ROWSCA_loc and id%COLSCA_loc C but free ROWSCA and COLSCA GOTO 110 RETURN 100 CONTINUE C Exit with error, free what was allocated IF (associated(id%ROWSCA_loc)) THEN DEALLOCATE(id%ROWSCA_loc) NULLIFY(id%ROWSCA_loc) ENDIF IF (associated(id%COLSCA_loc)) THEN IF (id%KEEP(50) .EQ. 0) THEN DEALLOCATE(id%COLSCA_loc) ENDIF NULLIFY(id%COLSCA_loc) ENDIF 110 CONTINUE C Free local ROWSCA and COLSCA arrays IF ( id%MYID .NE. 0) THEN IF (associated(ROWSCA)) DEALLOCATE(ROWSCA) IF ( id%KEEP(50) .EQ. 0 ) THEN IF (associated(COLSCA)) DEALLOCATE(COLSCA) ENDIF ENDIF NULLIFY(ROWSCA) NULLIFY(COLSCA) RETURN END SUBROUTINE SMUMPS_EXTRACT_SCALING C C ================================================================== C SUBROUTINE SMUMPS_EXTRACT_SCHUR_REDRHS(id,idintr) USE SMUMPS_STRUC_DEF USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_INTR_STRUC IMPLICIT NONE C C Purpose C ======= C C Extract the Schur and possibly also the reduced right-hand side C (if Fwd in facto) from the processor working on Schur and copy C it into the user datastructures id%SCHUR and id%REDRHS on the host. C This routine assumes that the integer list of the Schur has not C been permuted and still corresponds to LISTVAR_SCHUR. C C If the Schur is centralized, the master of the Schur holds the C Schur and possibly also the reduced right-hand side. C If the Schur is distribued (already built in user's datastructure), C then the master of the Schur may hold the reduced right-hand side, C in which case it is available in roota%RHS_CNTR_MASTER_ROOT. C TYPE (SMUMPS_STRUC) :: id TYPE (SMUMPS_INTR_STRUC) :: idintr C C Local variables C =============== C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ID_SCHUR, SIZE_SCHUR, LD_SCHUR, IB, BL4 INTEGER(4) :: I4 ! 32-bit even in 64-bit version INTEGER :: ROW_LENGTH, I INTEGER(8) :: SURFSCHUR8, BL8, SHIFT8 INTEGER(8) :: ISCHUR_SRC, ISCHUR_DEST, ISCHUR_SYM, ISCHUR_UNS C C External functions C ================== C INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE C Quick return in case factorization did not terminate correctly IF (id%INFO(1) .LT. 0) RETURN C Quick return if Schur option off IF (id%KEEP(60) .EQ. 0) RETURN C Get Schur id ID_SCHUR =MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(max(id%KEEP(20),id%KEEP(38)))), & id%KEEP(199)) IF ( id%KEEP( 46 ) .NE. 1 ) THEN ID_SCHUR = ID_SCHUR + 1 END IF C Get size of Schur IF (id%MYID.EQ.ID_SCHUR) THEN IF (id%KEEP(60).EQ.1) THEN C Sequential Schur LD_SCHUR = & id%IS(id%PTLUST_S(id%STEP(id%KEEP(20)))+2+id%KEEP(IXSZ)) SIZE_SCHUR = LD_SCHUR - id%KEEP(253) ELSE C Parallel Schur LD_SCHUR = -999999 ! not used SIZE_SCHUR = idintr%root%TOT_ROOT_SIZE ENDIF ELSE IF (id%MYID .EQ. MASTER) THEN SIZE_SCHUR = id%KEEP(116) LD_SCHUR = -44444 ! Not used ELSE C Proc is not concerned with Schur, return RETURN ENDIF SURFSCHUR8 = int(SIZE_SCHUR,8)*int(SIZE_SCHUR,8) C ===================================== C Case of parallel Schur: if REDRHS C was requested, obtain it directly C from idintr%roota%RHS_CNTR_MASTER_ROOT C ===================================== IF (id%KEEP(60) .GT. 1) THEN IF (id%KEEP(221).EQ.1 .AND. id%KEEP(252).GT.0) THEN DO I = 1, id%KEEP(253) IF (ID_SCHUR.EQ.MASTER) THEN ! Necessarily = id%MYID CALL scopy(SIZE_SCHUR, & idintr%roota%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), 1, & id%REDRHS((I-1)*id%LREDRHS+1), 1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN C Send CALL MPI_SEND( & idintr%roota%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), & SIZE_SCHUR, & MPI_REAL, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE ! MYID.EQ.MASTER C Receive CALL MPI_RECV( id%REDRHS((I-1)*id%LREDRHS+1), & SIZE_SCHUR, & MPI_REAL, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF ENDDO C ------------------------------ C In case of parallel Schur, we C free roota%RHS_CNTR_MASTER_ROOT C ------------------------------ IF (id%MYID.EQ.ID_SCHUR) THEN DEALLOCATE(idintr%roota%RHS_CNTR_MASTER_ROOT) NULLIFY (idintr%roota%RHS_CNTR_MASTER_ROOT) ENDIF ENDIF C return because this is all we need to do C in case of parallel Schur complement RETURN ENDIF C ============================ C Centralized Schur complement C ============================ C PTRAST has been freed at the moment of calling this C routine. Schur is available through C PTRFAC(IW( PTLUST_S( STEP(KEEP(20)) ) + 4 +KEEP(IXSZ) )) IF (id%KEEP(252).EQ.0) THEN C CASE 1 (ORIGINAL CODE): C Schur is contiguous on ID_SCHUR IF ( ID_SCHUR .EQ. MASTER ) THEN ! Necessarily equals id%MYID C --------------------- C Copy Schur complement C --------------------- CALL SMUMPS_COPYI8SIZE( SURFSCHUR8, & id%S(id%PTRFAC(id%STEP(id%KEEP(20)))), & id%SCHUR(1) ) ELSE C ----------------------------------------- C The processor responsible of the Schur C complement sends it to the host processor C Use blocks to avoid too large messages. C ----------------------------------------- BL8=int(huge(I4)/id%KEEP(35)/10,8) DO IB=1, int((SURFSCHUR8+BL8-1_8) / BL8) SHIFT8 = int(IB-1,8) * BL8 ! Where to send BL4 = int(min(BL8,SURFSCHUR8-SHIFT8)) ! Size of block IF ( id%MYID .eq. ID_SCHUR ) THEN C Send Schur complement CALL MPI_SEND( id%S( SHIFT8 + & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ)))), & BL4, & MPI_REAL, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE IF ( id%MYID .eq. MASTER ) THEN C Receive Schur complement CALL MPI_RECV( id%SCHUR(1_8 + SHIFT8), & BL4, & MPI_REAL, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) END IF ENDDO END IF ELSE C CASE 2 (Fwd in facto): Schur is not contiguous on ID_SCHUR, C process it row by row. C C 2.1: We first centralize Schur complement into id%SCHUR ISCHUR_SRC = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) ISCHUR_DEST= 1_8 DO I=1, SIZE_SCHUR ROW_LENGTH = SIZE_SCHUR IF (ID_SCHUR.EQ.MASTER) THEN ! Necessarily = id%MYID CALL scopy(ROW_LENGTH, id%S(ISCHUR_SRC), 1, & id%SCHUR(ISCHUR_DEST),1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN C Send CALL MPI_SEND( id%S(ISCHUR_SRC), ROW_LENGTH, & MPI_REAL, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE C Recv CALL MPI_RECV( id%SCHUR(ISCHUR_DEST), & ROW_LENGTH, & MPI_REAL, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF ISCHUR_SRC = ISCHUR_SRC+int(LD_SCHUR,8) ISCHUR_DEST= ISCHUR_DEST+int(SIZE_SCHUR,8) ENDDO C 2.2: Get REDRHS on host C 2.2.1: Symmetric => REDRHS is available in last KEEP(253) C rows of Schur structure on ID_SCHUR C 2.2.2: Unsymmetric => REDRHS corresponds to last KEEP(253) C columns. However it must be transposed. IF (id%KEEP(221).EQ.1) THEN ! Implies Fwd in facto ISCHUR_SYM = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) * & int(LD_SCHUR,8) ISCHUR_UNS = & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) ISCHUR_DEST = 1_8 DO I = 1, id%KEEP(253) IF (ID_SCHUR .EQ. MASTER) THEN ! necessarily = id%MYID IF (id%KEEP(50) .EQ. 0) THEN CALL scopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, & id%REDRHS(ISCHUR_DEST), 1) ELSE CALL scopy(SIZE_SCHUR, id%S(ISCHUR_SYM), 1, & id%REDRHS(ISCHUR_DEST), 1) ENDIF ELSE IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(50) .EQ. 0) THEN C Use id%S(ISCHUR_SYM) as temporary contig. workspace C of size SIZE_SCHUR. CALL scopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, & id%S(ISCHUR_SYM), 1) ENDIF CALL MPI_SEND(id%S(ISCHUR_SYM), SIZE_SCHUR, & MPI_REAL, MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE CALL MPI_RECV(id%REDRHS(ISCHUR_DEST), & SIZE_SCHUR, MPI_REAL, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF IF (id%KEEP(50).EQ.0) THEN ISCHUR_UNS = ISCHUR_UNS + int(LD_SCHUR,8) ELSE ISCHUR_SYM = ISCHUR_SYM + int(LD_SCHUR,8) ENDIF ISCHUR_DEST = ISCHUR_DEST + int(id%LREDRHS,8) ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_EXTRACT_SCHUR_REDRHS SUBROUTINE SMUMPS_EXTRACT_SINGULAR_VALUES(id,idintr) USE SMUMPS_STRUC_DEF USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_INTR_STRUC IMPLICIT NONE C C Purpose C ======= C C TYPE (SMUMPS_STRUC) :: id TYPE (SMUMPS_INTR_STRUC) :: idintr C C Local variables C =============== C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ID_ROOT, ALLOCOK C C External functions C ================== C INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE C Quick return in case factorization did not terminate correctly IF (id%INFO(1) .LT. 0) RETURN C Quick return if Postponing + rank revealing option off IF (id%KEEP(19) .EQ. 0) RETURN C Get Root id ID_ROOT =MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(id%KEEP(20))), & id%KEEP(199)) IF ( id%KEEP( 46 ) .NE. 1 ) THEN ID_ROOT = ID_ROOT + 1 END IF C ================================= C Singular values are stored in C roota%SINGULAR_VALUES C We copy it to id%SINGULAR_VALUES C ================================= IF ((ID_ROOT.EQ.id%MYID).AND.(id%MYID.EQ.MASTER)) THEN C write(6,*) " singular_values already on host" IF (associated(id%SINGULAR_VALUES)) & DEALLOCATE(id%SINGULAR_VALUES) NULLIFY(id%SINGULAR_VALUES) id%NB_SINGULAR_VALUES=idintr%root%NB_SINGULAR_VALUES ALLOCATE(id%SINGULAR_VALUES(id%NB_SINGULAR_VALUES) & , stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN id%INFO(1)=-13 id%INFO(2)= id%NB_SINGULAR_VALUES RETURN END IF CALL scopy(id%NB_SINGULAR_VALUES, & idintr%roota%SINGULAR_VALUES(1), 1, & id%SINGULAR_VALUES(1), 1) ELSE IF (id%MYID.EQ.ID_ROOT) THEN C Send C write(6,*) " id%MYID sends singular_values " CALL MPI_SEND( & idintr%root%NB_SINGULAR_VALUES, & 1, & MPI_INTEGER, & MASTER, TAG_ROOT1, & id%COMM, IERR ) CALL MPI_SEND( & idintr%roota%SINGULAR_VALUES(1), & idintr%root%NB_SINGULAR_VALUES, & MPI_REAL, & MASTER, TAG_ROOT2, & id%COMM, IERR ) ELSEIF (id%MYID.EQ.MASTER) THEN C Receive CALL MPI_RECV( id%NB_SINGULAR_VALUES, & 1, & MPI_INTEGER, ID_ROOT, TAG_ROOT1, & id%COMM, STATUS, IERR ) IF (associated(id%SINGULAR_VALUES)) & DEALLOCATE(id%SINGULAR_VALUES) NULLIFY(id%SINGULAR_VALUES) ALLOCATE(id%SINGULAR_VALUES(id%NB_SINGULAR_VALUES) & , stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN id%INFO(1)=-13 id%INFO(2)= id%NB_SINGULAR_VALUES RETURN END IF CALL MPI_RECV( id%SINGULAR_VALUES(1), & id%NB_SINGULAR_VALUES, & MPI_REAL, ID_ROOT, TAG_ROOT2, & id%COMM, STATUS, IERR ) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_EXTRACT_SINGULAR_VALUES SUBROUTINE SMUMPS_SET_NOMP_MAX(KEEP281, KEEP361, & N, NOMP_MAX) !$ USE OMP_LIB C C Purpose C ======= C set NOMP_MAX from KEEP(281) C on output NOMP_MAX >=0 C C Parameters C ========== C INTEGER, INTENT(IN) :: KEEP281, KEEP361, N INTEGER, INTENT(OUT) :: NOMP_MAX C C Local variables C INTEGER :: NOMP C C out-of-range entries treated as -1 NOMP_MAX= max(-1, KEEP281) NOMP = 1 !$ NOMP = omp_get_max_threads() IF (NOMP_MAX.EQ.-1) THEN C automatic setting IF (N.LE.KEEP361) THEN NOMP_MAX = 0 RETURN ENDIF IF (NOMP.GT.1) THEN C conservative because of memory allocation NOMP_MAX = min(NOMP, 10) ELSE C no multithreading and all parallel do suppressed NOMP_MAX = 0 ENDIF ELSE C NOMP_MAX >=0 C use provided value NOMP_MAX = min(NOMP_MAX, NOMP) ENDIF C RETURN END SUBROUTINE SMUMPS_SET_NOMP_MAX MUMPS_5.8.1/src/mumps_version.F0000664000175000017500000000145715042446423016255 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_SET_VERSION( VERSION_STR ) IMPLICIT NONE CHARACTER(LEN=*) :: VERSION_STR CHARACTER(LEN=*) :: V; PARAMETER (V = "5.8.1" ) IF ( len(V) .GT. 30 ) THEN WRITE(*,*) "Version string too long ( >30 characters )" CALL MUMPS_ABORT() END IF VERSION_STR = V RETURN END SUBROUTINE MUMPS_SET_VERSION MUMPS_5.8.1/src/ssol_c.F0000664000175000017500000031654515042446437014645 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SOL_C(root, roota, N, A, LA, IW, LIW, W, LWC, & IWCB, LIWW, NRHS, NA, LNA, NE_STEPS, W2, MTYPE, ICNTL, FROM_PP, & STEP, FRERE, DAD, FILS, PTRIST, PTRFAC, IW1, LIW1, PTRACB, & LIWK_PTRACB, PROCNODE_STEPS, SLAVEF, INFO, KEEP,KEEP8, DKEEP, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IBEG_ROOT_DEF, IEND_ROOT_DEF, & IROOT_DEF_RHS_COL1, RHS_ROOT, LRHS_ROOT, SIZE_ROOT, MASTER_ROOT, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, POSINRHSINTR_BWD, & Lnodes_FWD, Lnodes_BWD, & nodes_FWD, nodes_BWD, & NZ_RHS, NBCOL_INBLOC, JBEG_RHS, Step2node, LStep2node, & IRHS_SPARSE, IRHS_PTR, SIZE_PERM_RHS, PERM_RHS, & SIZE_UNS_PERM_INV, UNS_PERM_INV, NB_FS_IN_RHSINTR_F, & NB_FS_IN_RHSINTR_TOT, DO_NBSPARSE , RHS_BOUNDS, LRHS_BOUNDS #if defined(STAT_ES_SOLVE) & , IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING #endif & ,IPOOL_B_L0_OMP, LPOOL_B_L0_OMP, IPOOL_A_L0_OMP, LPOOL_A_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) USE SMUMPS_OOC USE SMUMPS_SOL_ES USE SMUMPS_SOL_L0OMP_M, ONLY : SMUMPS_SOL_L0OMP_R, & SMUMPS_SOL_L0OMP_S USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC & , SMUMPS_L0OMPFAC_T IMPLICIT NONE #if defined(V_T) INCLUDE 'VT.inc' #endif TYPE ( MUMPS_ROOT_STRUC ) :: root TYPE ( SMUMPS_ROOT_STRUC ) :: roota INTEGER(8) :: LA INTEGER(8) :: LWC INTEGER :: N,LIW,MTYPE,LIW1,LIWW,LNA INTEGER ICNTL(60),INFO(80), KEEP(500) REAL, intent(inout) :: DKEEP(230) INTEGER(8) KEEP8(150) INTEGER IW(LIW),IW1(LIW1),NA(LNA),NE_STEPS(KEEP(28)),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)), FILS(N), PTRIST(KEEP(28)), & DAD(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER :: LIWK_PTRACB INTEGER(8) :: PTRACB(LIWK_PTRACB) INTEGER NRHS, LRHSINTR, NB_FS_IN_RHSINTR_F, NB_FS_IN_RHSINTR_TOT REAL A(LA), W(LWC), & W2(KEEP(133)) REAL :: RHSINTR(LRHSINTR,NRHS) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER PROCNODE_STEPS(KEEP(28)), POSINRHSINTR_FWD(N), & POSINRHSINTR_BWD(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, IROOT_DEF_RHS_COL1 INTEGER NRHS_LOC INTEGER SIZE_ROOT, MASTER_ROOT INTEGER(8) :: LRHS_ROOT REAL RHS_ROOT(LRHS_ROOT) LOGICAL, intent(in) :: FROM_PP INTEGER, intent(in) :: Lnodes_FWD, Lnodes_BWD INTEGER, intent(in) :: nodes_FWD(max(1,Lnodes_FWD)), & nodes_BWD(max(1,Lnodes_BWD)) INTEGER, intent(in) :: NZ_RHS, NBCOL_INBLOC INTEGER, intent(in) :: SIZE_UNS_PERM_INV INTEGER, intent(in) :: SIZE_PERM_RHS INTEGER, intent(in) :: JBEG_RHS INTEGER, intent(in) :: IRHS_SPARSE(NZ_RHS) INTEGER, intent(in) :: IRHS_PTR(NBCOL_INBLOC+1) INTEGER, intent(in) :: PERM_RHS(SIZE_PERM_RHS) INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, intent(in) :: LStep2node INTEGER, intent(in) :: Step2node(LStep2node) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(inout) :: RHS_BOUNDS (LRHS_BOUNDS) #if defined(STAT_ES_SOLVE) INTEGER, INTENT(IN) :: SIZE_WORKING, SIZE_IPTR_WORKING, & IPTR_WORKING(SIZE_IPTR_WORKING), & WORKING(SIZE_WORKING) #endif INTEGER, INTENT (IN) :: LPOOL_B_L0_OMP INTEGER, INTENT (IN) :: IPOOL_B_L0_OMP( LPOOL_B_L0_OMP ) INTEGER, INTENT (IN) :: LPOOL_A_L0_OMP INTEGER, INTENT (IN) :: IPOOL_A_L0_OMP( LPOOL_A_L0_OMP ) INTEGER, INTENT (IN) :: L_PHYS_L0_OMP INTEGER, INTENT (INOUT) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT (IN) :: L_VIRT_L0_OMP INTEGER, INTENT (IN) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT (IN) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT (IN) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT (IN) :: LL0_OMP_MAPPING INTEGER, INTENT (IN) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INTEGER, INTENT (IN) :: LL0_OMP_FACTORS TYPE (SMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER MP, LP, LDIAG INTEGER K,I,II INTEGER allocok INTEGER LPOOL,MYLEAF,MYROOT,NBROOT,LPANEL_POS INTEGER MYLEAF_NOT_PRUNED INTEGER NSTK_S,IPOOL,IPANEL_POS,PTRICB INTEGER MTYPE_LOC INTEGER MODE_RHS_BOUNDS INTEGER IPT_RHS_ROOT_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 LOGICAL DOFORWARD, DOROOT, DOBACKWARD LOGICAL :: DO_L0OMP_FWD, DO_L0OMP_BWD LOGICAL I_WORKED_ON_ROOT, SPECIAL_ROOT_REACHED INTEGER IROOT LOGICAL DOROOT_FWD_OOC, DOROOT_BWD_PANEL LOGICAL DUMMY_BOOL INTEGER :: IDUMMY INTEGER :: NBROOT_UNDER_L0 REAL, PARAMETER :: ZERO = 0.0E0 INCLUDE 'mumps_headers.h' INTEGER, DIMENSION(:), POINTER :: nodes_BWD_PTR INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: Pruned_Roots_FWD INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: Pruned_Roots_NS INTEGER :: Lnodes_BWD_PTR, LPruned_Roots_NS INTEGER :: Lnodes_BWD_ROOTS INTEGER nb_prun_leaves INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_Leaves INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_List INTEGER nb_prun_nodes INTEGER INODE_PRINC, nb_prun_roots INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_SONS, Pruned_Roots INTEGER :: SIZE_TO_PROCESS LOGICAL, DIMENSION(:), ALLOCATABLE :: TO_PROCESS INTEGER ISTEP INTEGER :: INODE, ICHILD LOGICAL AM1, DO_PRUN_FWD, DO_PRUN_BWD LOGICAL Exploit_Sparsity_FWD, Exploit_Sparsity_BWD LOGICAL DO_NBSPARSE_BWD, PRUN_BELOW_BWD INTEGER :: OOC_FCT_TYPE_TMP INTEGER :: MUMPS_OOC_GET_FCT_TYPE EXTERNAL :: MUMPS_OOC_GET_FCT_TYPE DOUBLE PRECISION TIME_FWD,TIME_BWD,TIME_SpecialRoot INTEGER :: nb_sparse INTEGER, EXTERNAL :: MUMPS_PROCNODE LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR MYLEAF = -1 LP = ICNTL(1) MP = ICNTL(2) LDIAG = ICNTL(4) CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, MYID ) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 #if defined(V_T) CALL VTCLASSDEF( 'Soln_c',soln_c_class,ierr) CALL VTFUNCDEF( 'forw_soln',soln_c_class,forw_soln,ierr) CALL VTFUNCDEF( 'back_soln',soln_c_class,back_soln,ierr) CALL VTFUNCDEF( 'root_soln',soln_c_class,root_soln,ierr) #endif IF (.NOT. FROM_PP) THEN CALL MUMPS_SECDEB(TIME_FWD) ENDIF NSTK_S = 1 PTRICB = NSTK_S + KEEP(28) IPOOL = PTRICB + KEEP(28) LPOOL = NA(1) + 1 IPANEL_POS = IPOOL + LPOOL IF (KEEP(201).EQ.1) THEN LPANEL_POS = KEEP(228)+1 ELSE LPANEL_POS = 1 ENDIF IF (IPANEL_POS + LPANEL_POS -1 .ne. LIW1 ) THEN WRITE(*,*) MYID, ": Internal Error 1 in SMUMPS_SOL_C", & IPANEL_POS, LPANEL_POS, LIW1 CALL MUMPS_ABORT() ENDIF KEEP(405)=0 DOFORWARD = .TRUE. DOBACKWARD= .TRUE. SPECIAL_ROOT_REACHED = .TRUE. 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_FWD = (KEEP(235) .NE. 0) .AND. (.NOT. AM1) Exploit_Sparsity_BWD = (KEEP(212) .NE. 0) .AND. (.NOT. AM1) Lnodes_BWD_ROOTS = NA(2) DO_PRUN_FWD = (Exploit_Sparsity_FWD.OR.AM1) DO_PRUN_BWD = (Exploit_Sparsity_BWD.OR.AM1) IF (FROM_PP) THEN Exploit_Sparsity_FWD = .FALSE. DO_PRUN_FWD = .FALSE. Exploit_Sparsity_BWD = .FALSE. DO_PRUN_BWD = .FALSE. IF ( AM1 ) THEN WRITE(*,*) "Internal error 2 in SMUMPS_SOL_C" CALL MUMPS_ABORT() ENDIF ENDIF DO_L0OMP_FWD= ( (KEEP(401).EQ.1).AND.(KEEP(400).GT.0) & .AND.DOFORWARD ) DO_L0OMP_FWD = DO_L0OMP_FWD .AND. KEEP(201).EQ.0 DO_L0OMP_BWD = ( (KEEP(401).EQ.1).AND.(KEEP(400).GT.0) & .AND.DOBACKWARD ) DO_L0OMP_BWD = DO_L0OMP_BWD .AND. KEEP(201).EQ.0 IF ( DO_PRUN_FWD.OR.DO_PRUN_BWD ) THEN ALLOCATE (Pruned_SONS(KEEP(28)), stat=I) IF(I.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ENDIF IF ( DO_PRUN_FWD.OR.DO_PRUN_BWD & .OR. DO_L0OMP_BWD & ) THEN SIZE_TO_PROCESS = KEEP(28) ELSE SIZE_TO_PROCESS = 1 ENDIF ALLOCATE (TO_PROCESS(SIZE_TO_PROCESS), stat=I) IF(I.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 IF ( DOFORWARD .AND. DO_PRUN_FWD ) THEN CALL SMUMPS_CHAIN_PRUN_NODES( & .FALSE., & DAD, KEEP(28), & STEP, N, & nodes_FWD, Lnodes_FWD, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, & nb_prun_leaves ) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL SMUMPS_CHAIN_PRUN_NODES( & .TRUE., & DAD, KEEP(28), & STEP, N, & nodes_FWD, Lnodes_FWD, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves ) CALL SMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF ( KEEP(201) .GT. 0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('F',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL SMUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), & KEEP8(31)+KEEP8(64), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP #if defined(STAT_ES_SOLVE) & , NRHS, COMM_NODES, IW, LIW, PTRIST,KEEP(IXSZ),0, & KEEP(50), KEEP(38) #endif & ) IF (DO_NBSPARSE) THEN nb_sparse = max(1,KEEP(497)) MODE_RHS_BOUNDS = 0 IF (Exploit_Sparsity_FWD) MODE_RHS_BOUNDS = 2 CALL SMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243), & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23), & RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & MODE_RHS_BOUNDS) CALL SMUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, KEEP(485), #if defined(STAT_ES_SOLVE) & KEEP(46), & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, #endif & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,0, & KEEP(50), KEEP(38)) END IF SPECIAL_ROOT_REACHED = .FALSE. DO I= 1, nb_prun_roots IF ( (Pruned_Roots(I).EQ.KEEP(38)).OR. & (Pruned_Roots(I).EQ.KEEP(20)) ) THEN SPECIAL_ROOT_REACHED = .TRUE. EXIT ENDIF ENDDO DEALLOCATE(Pruned_List) ENDIF IF (KEEP(201).GT.0) THEN IF (DOFORWARD .OR. DOROOT_FWD_OOC) THEN CALL SMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,KEEP(28),MTYPE, & A,LA,DOFORWARD,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (DOFORWARD) THEN IF ( KEEP( 50 ) .eq. 0 ) THEN MTYPE_LOC = MTYPE ELSE MTYPE_LOC = 1 ENDIF #if defined(V_T) CALL VTBEGIN(forw_soln,ierr) #endif IF ( .NOT. DO_PRUN_FWD ) THEN CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, MYROOT, MYID_NODES, & SLAVEF, NA, LNA, KEEP, STEP, PROCNODE_STEPS) DO ISTEP =1, KEEP(28) IW1(NSTK_S+ISTEP-1) = NE_STEPS(ISTEP) ENDDO ELSE CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & nb_prun_roots, Pruned_Roots, & MYROOT, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) IF ((Exploit_Sparsity_FWD).AND.(nb_prun_roots.NE.NA(2))) THEN Lnodes_BWD_ROOTS = nb_prun_roots ALLOCATE(Pruned_Roots_FWD(Lnodes_BWD_ROOTS), STAT=allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of nodes_FWD' INFO(1) = -13 INFO(2) = Lnodes_BWD_ROOTS CALL MUMPS_ABORT() END IF Pruned_Roots_FWD(1:Lnodes_BWD_ROOTS)= & Pruned_Roots(1:Lnodes_BWD_ROOTS) DEALLOCATE(Pruned_Roots) ELSE DEALLOCATE(Pruned_Roots) ENDIF DO ISTEP = 1, KEEP(28) IW1(NSTK_S+ISTEP-1) = Pruned_SONS(ISTEP) ENDDO ENDIF IF ( DO_L0OMP_FWD ) THEN KEEP(405)=1 CALL SMUMPS_SOL_L0OMP_R( N, MTYPE_LOC, NRHS, LIW, IW, & IW1(PTRICB), RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & STEP, FRERE, DAD, FILS, IW1(NSTK_S), & PTRIST, PTRFAC, INFO, & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, & FROM_PP, & NBROOT_UNDER_L0, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, & L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS, & DO_PRUN_FWD, TO_PROCESS & ) CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, & INFO, MYID ) IF (INFO(1).LT.0) THEN CALL SMUMPS_BDC_ERROR(MYID_NODES, SLAVEF, COMM_NODES, KEEP) ENDIF KEEP(405)=0 MYROOT = MYROOT - NBROOT_UNDER_L0 ENDIF IF ( DO_L0OMP_FWD ) THEN IF ( DO_PRUN_FWD ) THEN MYLEAF_NOT_PRUNED = IPOOL_A_L0_OMP(LPOOL_A_L0_OMP) DO I=1, MYLEAF_NOT_PRUNED IF ( TO_PROCESS( STEP( IPOOL_A_L0_OMP(I) ))) THEN IW1(IPOOL+MYLEAF-1) = IPOOL_A_L0_OMP(I) IW1(NSTK_S+STEP(IPOOL_A_L0_OMP(I))-1) = -99 ENDIF ENDDO DO I = 1, nb_prun_leaves INODE = Pruned_Leaves(I) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) & .EQ. MYID_NODES ) THEN IF (L0_OMP_MAPPING( STEP(INODE) ) .EQ. 0) THEN IW1(NSTK_S+STEP(INODE)-1) = -99 ENDIF ENDIF ENDDO DO I = 1, L_PHYS_L0_OMP INODE = DAD(STEP(PHYS_L0_OMP(I))) IF (INODE .NE. 0) THEN IF ( TO_PROCESS( STEP( INODE ))) THEN IF ( IW1(NSTK_S+STEP(INODE)-1) .EQ. 0 ) THEN IW1(NSTK_S+STEP(INODE)-1) = -99 ENDIF ENDIF ENDIF ENDDO MYLEAF = 0 DO ISTEP = KEEP(28), 1, -1 INODE=Step2Node(ISTEP) IF (IW1(NSTK_S+STEP(INODE)-1).EQ.-99) THEN MYLEAF = MYLEAF + 1 IW1(IPOOL+MYLEAF-1) = INODE IW1(NSTK_S+STEP(INODE)-1) = 0 ENDIF ENDDO DEALLOCATE(Pruned_Leaves) ELSE MYLEAF = IPOOL_A_L0_OMP(LPOOL_A_L0_OMP) DO I=1, MYLEAF IW1(IPOOL+I-1) = IPOOL_A_L0_OMP(I) ENDDO ENDIF ELSE IF ( DO_PRUN_FWD ) THEN CALL MUMPS_INIT_POOL_DIST_NONA( N, MYLEAF, MYID_NODES, & nb_prun_leaves, Pruned_Leaves, KEEP, KEEP8, & STEP, PROCNODE_STEPS, IW1(IPOOL), LPOOL ) MYLEAF = MYLEAF - 1 DEALLOCATE(Pruned_Leaves) ELSE CALL MUMPS_INIT_POOL_DIST( N, MYLEAF, MYID_NODES, & SLAVEF, NA, LNA, KEEP, KEEP8, STEP, & PROCNODE_STEPS, IW1(IPOOL), LPOOL ) MYLEAF = MYLEAF - 1 ENDIF ENDIF CALL SMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1), & LWC, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSINTR,LRHSINTR,POSINRHSINTR_FWD, & STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF, MYROOT, INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE_LOC, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) IF (DO_PRUN_FWD) THEN MYLEAF = -1 ENDIF #if defined(V_T) CALL VTEND(forw_soln,ierr) #endif ENDIF CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, MYID ) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) THEN IF ( LP .GT. 0 ) THEN WRITE(LP,*) MYID, & ': ** ERROR RETURN FROM SMUMPS_SOL_R,INFO(1:2)=', & INFO(1:2) END IF GOTO 500 END IF CALL MPI_BARRIER( COMM_NODES, IERR ) IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_FWD) DKEEP(117)=real(TIME_FWD) + DKEEP(117) ENDIF IF ( .NOT.( & DOBACKWARD.AND. & (DO_PRUN_BWD.OR.(Lnodes_BWD_ROOTS.NE.NA(2))) & ) & ) THEN IF (.NOT. DO_L0OMP_BWD ) THEN IF ( allocated(TO_PROCESS) .AND. SIZE_TO_PROCESS.NE.1 ) THEN DEALLOCATE (TO_PROCESS) SIZE_TO_PROCESS = 1 ALLOCATE(TO_PROCESS(SIZE_TO_PROCESS),stat=I) ENDIF ENDIF ENDIF IF ( (KEEP(111).NE.0).AND.DOBACKWARD.AND. & ( & DO_PRUN_BWD & ) & ) THEN nb_prun_leaves = 0 IF ( Lnodes_BWD_ROOTS.NE.NA(2) ) THEN nodes_BWD_PTR => Pruned_Roots_FWD Lnodes_BWD_PTR = Lnodes_BWD_ROOTS ELSE IF ( (Exploit_Sparsity_BWD.AND.KEEP(111).NE.0) & ) THEN LPruned_Roots_NS = 0 Pruned_SONS(:) = -1 DO II = 1, NZ_RHS I = IRHS_SPARSE(II) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) ISTEP = abs(STEP(I)) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN LPruned_Roots_NS = LPruned_Roots_NS +1 Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ALLOCATE(Pruned_Roots_NS(LPruned_Roots_NS), STAT = allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of nodes_BWD' INFO(1) = -13 INFO(2) = LPruned_Roots_NS CALL MUMPS_ABORT() END IF LPruned_Roots_NS = 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 LPruned_Roots_NS = LPruned_Roots_NS +1 Pruned_Roots_NS(LPruned_Roots_NS) = INODE_PRINC Pruned_SONS(ISTEP) = 0 ENDIF ENDDO nodes_BWD_PTR => Pruned_Roots_NS Lnodes_BWD_PTR = LPruned_Roots_NS ENDIF IF ( & (Exploit_Sparsity_BWD.AND.KEEP(111).NE.0) .OR. & (Lnodes_BWD_ROOTS.NE.NA(2)) & ) THEN CALL SMUMPS_TREE_PRUN_NODES( & .FALSE., & DAD, NE_STEPS, FRERE, KEEP(28), & FILS, STEP, N, & nodes_BWD_PTR, Lnodes_BWD_PTR, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves & ) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL SMUMPS_TREE_PRUN_NODES( & .TRUE., & DAD, NE_STEPS, FRERE, KEEP(28), & FILS, STEP, N, & nodes_BWD_PTR, Lnodes_BWD_PTR, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IF(allocated(Pruned_Roots_NS)) DEALLOCATE(Pruned_Roots_NS) IF(allocated(Pruned_Roots_FWD)) DEALLOCATE(Pruned_Roots_FWD) CALL SMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF ENDIF ENDIF IF(KEEP(201).EQ.1.AND.DOROOT_BWD_PANEL) THEN I_WORKED_ON_ROOT = .FALSE. CALL SMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE, & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) IF (IERR .LT. 0) THEN INFO(1) = -90 INFO(2) = IERR ENDIF ENDIF IF (KEEP(201).EQ.1) THEN CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF IF (KEEP(60).NE.0 .AND. KEEP(221).EQ.0 & .AND. MYID_NODES .EQ. MASTER_ROOT) THEN RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO ENDIF IF (.NOT. FROM_PP) THEN CALL MUMPS_SECDEB(TIME_SpecialRoot) ENDIF IF ( ( KEEP( 38 ) .NE. 0 ).AND. SPECIAL_ROOT_REACHED ) THEN IF ( KEEP(60) .EQ. 0 .AND. KEEP(252) .EQ. 0 ) THEN IF ( root%yes ) THEN IF (KEEP(201).GT.0) THEN IF ( (Exploit_Sparsity_FWD.AND.(KEEP(111).NE.0)) .and. & (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) ) THEN GOTO 1010 ENDIF ENDIF IOLDPS = PTRIST(STEP(KEEP(38))) LOCAL_M = IW( IOLDPS + 2 + KEEP(IXSZ)) LOCAL_N = IW( IOLDPS + 1 + KEEP(IXSZ)) IF (KEEP(201).GT.0) THEN CALL SMUMPS_SOLVE_GET_OOC_NODE( & KEEP(38),PTRFAC,KEEP,A,LA, & STEP,KEEP8,N,DUMMY_BOOL,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) '** ERROR after SMUMPS_SOLVE_GET_OOC_NODE', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF IAPOS = PTRFAC(IW( IOLDPS + 4 + KEEP(IXSZ))) IF (LOCAL_M * LOCAL_N .EQ. 0) THEN IAPOS = min(IAPOS, LA) ENDIF #if defined(V_T) CALL VTBEGIN(root_soln,ierr) #endif CALL SMUMPS_ROOT_SOLVE( NRHS, root%DESCRIPTOR(1), & root%CNTXT_BLACS, LOCAL_M, LOCAL_N, & root%MBLOCK, root%NBLOCK, & root%IPIV(1), root%LPIV, MASTER_ROOT, MYID_NODES, & COMM_NODES, & RHS_ROOT(1), & root%TOT_ROOT_SIZE, A( IAPOS ), & INFO(1), MTYPE, KEEP(50), FROM_PP) IF(KEEP(201).GT.0)THEN CALL SMUMPS_FREE_FACTORS_FOR_SOLVE(KEEP(38), & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) & '** ERROR after SMUMPS_FREE_FACTORS_FOR_SOLVE ', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF ENDIF ENDIF ELSE IF ( ( KEEP(20) .NE. 0) .AND. SPECIAL_ROOT_REACHED ) THEN IF ( MYID_NODES .eq. MASTER_ROOT ) THEN IF ( KEEP(60) .eq. 0 ) THEN IF (KEEP(201).GT.0) THEN CALL SMUMPS_SOLVE_GET_OOC_NODE( & KEEP(20),PTRFAC,KEEP,A,LA, & STEP,KEEP8,N,DUMMY_BOOL,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) '** ERROR after SMUMPS_SOLVE_GET_OOC_NODE', & INFO(1) call MUMPS_ABORT() ENDIF END IF NRHS_LOC = NRHS IPT_RHS_ROOT_LOC = 1 IF ( KEEP(111).NE.0 ) THEN RHS_ROOT( 1: NRHS*SIZE_ROOT) = ZERO NRHS_LOC = IEND_ROOT_DEF - IBEG_ROOT_DEF + 1 IPT_RHS_ROOT_LOC = IPT_RHS_ROOT_LOC + & (IROOT_DEF_RHS_COL1-1)*SIZE_ROOT ENDIF IF (NRHS_LOC .GT. 0) THEN CALL SMUMPS_SEQ_SOLVE_ROOT_SVD_QR(NRHS_LOC, & SIZE_ROOT,A( PTRFAC( & IW( PTRIST(STEP(KEEP(20)))+4+KEEP(IXSZ)))), & root, roota, IBEG_ROOT_DEF, IEND_ROOT_DEF, & RHS_ROOT( IPT_RHS_ROOT_LOC ), & KEEP,KEEP8, & MTYPE,INFO,LWC,W(1), LP) ENDIF IF(KEEP(201).GT.0)THEN CALL SMUMPS_FREE_FACTORS_FOR_SOLVE(KEEP(20), & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) & '** ERROR after SMUMPS_FREE_FACTORS_FOR_SOLVE ', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF ENDIF END IF END IF IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_SpecialRoot) DKEEP(119)=real(TIME_SpecialRoot) + DKEEP(119) ENDIF #if defined(V_T) CALL VTEND(root_soln,ierr) #endif 1010 CONTINUE CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) RETURN IF (DOBACKWARD) THEN IF ( KEEP(201).GT.0 .AND. .NOT. DOROOT_BWD_PANEL ) & THEN I_WORKED_ON_ROOT = DOROOT IF (KEEP(38).gt.0 ) THEN IF ( ( Exploit_Sparsity_FWD.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_FWD.AND.(KEEP(111).NE.0)) THEN IF (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) THEN I_WORKED_ON_ROOT = .FALSE. ENDIF ENDIF ENDIF ENDIF IF (.NOT.AM1) THEN DO_NBSPARSE_BWD = .FALSE. ELSE DO_NBSPARSE_BWD = DO_NBSPARSE ENDIF PRUN_BELOW_BWD = DO_PRUN_BWD .AND. KEEP(111).EQ.0 PRUN_BELOW_BWD = PRUN_BELOW_BWD .OR. DO_L0OMP_BWD IF ( DO_PRUN_BWD ) THEN CALL SMUMPS_CHAIN_PRUN_NODES( & .FALSE., & DAD, KEEP(28), & STEP, N, & nodes_BWD, Lnodes_BWD, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, & nb_prun_leaves) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL SMUMPS_CHAIN_PRUN_NODES( & .TRUE., & DAD, KEEP(28), & STEP, N, & nodes_BWD, Lnodes_BWD, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves ) CALL SMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL SMUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP #if defined(STAT_ES_SOLVE) & , NRHS, COMM_NODES, IW, LIW, PTRIST,KEEP(IXSZ),1, & KEEP(50), KEEP(38) #endif & ) IF (DO_NBSPARSE_BWD) THEN nb_sparse = max(1,KEEP(497)) CALL SMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243), & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23), & RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & 1) CALL SMUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, KEEP(485), #if defined(STAT_ES_SOLVE) & KEEP(46), & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, #endif & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,1, & KEEP(50), KEEP(38)) END IF ENDIF IF ( KEEP(201).GT.0 ) THEN IROOT = max(KEEP(20),KEEP(38)) CALL SMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE, & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) ENDIF IF ( KEEP( 50 ) .eq. 0 ) THEN MTYPE_LOC = MTYPE ELSE MTYPE_LOC = 0 ENDIF #if defined(V_T) CALL VTBEGIN(back_soln,ierr) #endif IF (.NOT.FROM_PP) THEN CALL MUMPS_SECDEB(TIME_BWD) ENDIF IF ( .NOT.SPECIAL_ROOT_REACHED ) THEN RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO ENDIF IF (AM1.AND.(NB_FS_IN_RHSINTR_F.NE.NB_FS_IN_RHSINTR_TOT)) THEN DO I =1, N II = POSINRHSINTR_BWD(I) IF ((II.GT.0).AND.(II.GT.NB_FS_IN_RHSINTR_F)) THEN DO K=1,NRHS RHSINTR(II, K) = ZERO ENDDO ENDIF ENDDO ENDIF IF ( .NOT. DO_PRUN_BWD ) THEN IF ( .NOT. DO_L0OMP_BWD ) THEN IF (DO_L0OMP_FWD) THEN MYLEAF = -1 ENDIF ENDIF IF ( DO_L0OMP_BWD ) THEN TO_PROCESS(:) = .TRUE. DO I=1, L_PHYS_L0_OMP TO_PROCESS( STEP(PHYS_L0_OMP( I ))) & = .FALSE. ENDDO IF (MYLEAF .EQ. -1) THEN MYLEAF = IPOOL_A_L0_OMP(LPOOL_A_L0_OMP) ENDIF CALL MUMPS_INIT_POOL_DIST_NA_BWD_L0( N, MYROOT, MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL, L0_OMP_MAPPING ) ELSE CALL MUMPS_INIT_POOL_DIST_NA_BWD( N, MYROOT, MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL ) IF (MYLEAF .EQ. -1) THEN CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & NA(1), & NA(3), & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) ENDIF ENDIF ELSE IF ( DO_L0OMP_BWD ) THEN DO I=1, L_PHYS_L0_OMP IF ( TO_PROCESS( STEP(PHYS_L0_OMP( I ))) ) THEN TO_PROCESS( STEP(PHYS_L0_OMP( I ))) = .FALSE. PHYS_L0_OMP( I ) = -PHYS_L0_OMP( I ) ENDIF ENDDO MYLEAF=0 DO ISTEP = 1, KEEP(28) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199)) & .NE. MYID_NODES ) THEN CYCLE ENDIF IF ( L0_OMP_MAPPING( ISTEP ) .NE. 0 ) THEN CYCLE ENDIF IF ( .NOT. TO_PROCESS( ISTEP ) ) THEN CYCLE ENDIF I = Step2Node( ISTEP ) ICHILD = FILS ( I ) DO WHILE ( ICHILD .GT. 0 ) ICHILD = FILS( ICHILD ) END DO IF ( ICHILD .LT. 0 ) THEN ICHILD = -ICHILD DO WHILE ( ICHILD .GT. 0 ) IF ( L0_OMP_MAPPING( STEP( ICHILD ) ) .EQ. 0 .AND. & TO_PROCESS(STEP( ICHILD )) ) THEN GOTO 10 ENDIF ICHILD = FRERE( STEP( ICHILD ) ) ENDDO ENDIF MYLEAF = MYLEAF + 1 10 CONTINUE ENDDO CALL MUMPS_INIT_POOL_DIST_NA_BWDL0ES( N, MYROOT, & MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL, L0_OMP_MAPPING, TO_PROCESS ) ELSE CALL MUMPS_INIT_POOL_DIST_BWD(N, nb_prun_roots, & Pruned_Roots, & MYROOT, MYID_NODES, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL) CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & nb_prun_leaves, Pruned_Leaves, & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) ENDIF ENDIF IF ( DO_L0OMP_BWD & ) THEN KEEP(31) = 1 ELSE KEEP(31) = 0 ENDIF IF (KEEP(31) .EQ. 1) THEN DO I = 1, KEEP(28) IF (MUMPS_PROCNODE(PROCNODE_STEPS(I),KEEP(199)) .EQ. & MYID_NODES) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(I), & KEEP(199)) ) THEN IF ( L0_OMP_MAPPING(I) .EQ. 0 ) THEN IF ( DO_PRUN_BWD & .OR. DO_L0OMP_BWD & ) THEN IF ( TO_PROCESS(I) ) THEN KEEP(31) = KEEP(31) + 1 ENDIF ELSE KEEP(31) = KEEP(31) + 1 ENDIF ENDIF ENDIF ENDIF ENDDO ENDIF CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, MYID ) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL SMUMPS_SOL_S( N, A, LA, IW, LIW, W(1), LWC, & NRHS, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & IW1(PTRICB),PTRACB,IWCB,LIWW, W2, & NE_STEPS, & STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,MYROOT,ICNTL,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP, KEEP8, DKEEP, & RHS_ROOT, LRHS_ROOT, & MTYPE_LOC, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), & LPANEL_POS, PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE_BWD & , FROM_PP & , L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) IF ( DO_L0OMP_BWD .AND. DO_PRUN_BWD ) THEN DO I = 1, L_PHYS_L0_OMP IF ( PHYS_L0_OMP( I ) .LT. 0 ) THEN PHYS_L0_OMP( I ) = -PHYS_L0_OMP( I ) TO_PROCESS(STEP(PHYS_L0_OMP( I ) )) = .TRUE. ENDIF ENDDO ENDIF CALL MUMPS_STOP_ON_USER_REQUEST(KEEP, KEEP8, ICNTL, INFO, MYID) IF (DO_L0OMP_BWD .AND. INFO(1) .GE. 0) THEN KEEP(31) = 0 PRUN_BELOW_BWD = DO_PRUN_BWD .AND. KEEP(111).EQ.0 KEEP(405)=1 CALL SMUMPS_SOL_L0OMP_S(N, MTYPE_LOC, NRHS, LIW, IW, & IW1(PTRICB), PTRACB, RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & STEP, FRERE, FILS, NE_STEPS, PTRIST, PTRFAC, INFO, & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & IW1(IPANEL_POS), LPANEL_POS, & PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE_BWD, & FROM_PP, & LPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, & L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS ) KEEP(405)=0 ENDIF CALL MUMPS_CLEAN_PENDING( INFO(1), KEEP, & BUFR, LBUFR,LBUFR_BYTES, & COMM_NODES, IDUMMY, & SLAVEF, .TRUE., .FALSE. ) CALL MUMPS_STOP_ON_USER_REQUEST(KEEP, KEEP8, ICNTL, INFO, MYID) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) #if defined(V_T) CALL VTEND(back_soln,ierr) #endif IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_BWD) DKEEP(118)=real(TIME_BWD)+DKEEP(118) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (DOFORWARD) THEN K = min(10,size(RHSINTR,1)) IF (LDIAG.EQ.4) K = size(RHSINTR,1) IF ( .NOT. FROM_PP) THEN WRITE (MP,99992) IF (size(RHSINTR,1).GT.0) & WRITE (MP,99993) (RHSINTR(I,1),I=1,K) IF (size(RHSINTR,1).GT.0.and.NRHS>1) & WRITE (MP,99994) (RHSINTR(I,2),I=1,K) ENDIF ENDIF ENDIF 500 CONTINUE IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) IF (DO_PRUN_FWD.OR.DO_PRUN_BWD) THEN IF ( allocated(Pruned_Roots_FWD)) & DEALLOCATE (Pruned_Roots_FWD) IF ( allocated(Pruned_Roots_NS)) & DEALLOCATE (Pruned_Roots_NS) IF ( allocated(Pruned_SONS)) DEALLOCATE (Pruned_SONS) IF ( allocated(Pruned_Roots)) DEALLOCATE (Pruned_Roots) IF ( allocated(Pruned_List)) DEALLOCATE (Pruned_List) IF ( allocated(Pruned_Leaves)) DEALLOCATE (Pruned_Leaves) ENDIF RETURN 99993 FORMAT (' RHS (internal, first column)'/(1X,1P,5E14.6)) 99994 FORMAT (' RHS (internal, 2 nd column)'/(1X,1P,5E14.6)) 99992 FORMAT (//' LEAVING SOLVE (SMUMPS_SOL_C) WITH') END SUBROUTINE SMUMPS_SOL_C SUBROUTINE SMUMPS_SET_POSTPros (KEEP, ICNTL, NBRHS, MPG, PROKG, & ICNTL10, ICNTL11, POSTPros) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP(500), ICNTL(60), NBRHS, MPG LOGICAL, INTENT(IN) :: PROKG INTEGER, INTENT(OUT) :: ICNTL10, ICNTL11 LOGICAL, INTENT(OUT) :: POSTPros POSTPros = .FALSE. IF (ICNTL11.NE.0 .OR. ICNTL10.NE.0) THEN POSTPros = .TRUE. IF (KEEP(111).NE.0) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: null space basis', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(237) .NE.0 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: AM1', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(252) .NE.0 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: Fwd in facto ', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF (KEEP(221).NE.0) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: reduced RHS', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF (NBRHS.GT. 1 .OR. ICNTL(21) .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: nrhs>1 or distrib sol', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(248) .EQ. -1 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: distrib rhs', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ENDIF IF (.NOT.POSTPros) THEN ICNTL11 = 0 ICNTL10 = 0 ENDIF ENDIF IF ((ICNTL(10) .NE. 0) .AND. (ICNTL10 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 ' ENDIF IF ((ICNTL(11) .NE. 0) & .AND.(ICNTL11 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF RETURN END SUBROUTINE SMUMPS_SET_POSTPros SUBROUTINE SMUMPS_GATHER_SOLUTION( NSLAVES, N, MYID, COMM, & NRHS, & MTYPE, RHS, LRHS, NCOL_RHS, JBEG_RHS, PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, CWORK, LCWORK, #if defined(USE_OLD_SCALING) & LSCAL, SCALING, LSCALING, #else & LSCAL, SCALING_LOC_BWD, LSCALING_LOC_BWD, #endif & RHSINTR, LRHSINTR, NCOL_RHSINTR, & POSINRHSINTR, LPOS_N, PERM_RHS, SIZE_PERM_RHS ) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE, NCOL_RHS INTEGER NRHS, LRHS, LCWORK, LPOS_N, NCOL_RHSINTR REAL RHS (LRHS, NCOL_RHS) INTEGER, INTENT(in) :: JBEG_RHS INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL :: CWORK(LCWORK) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER SIZE_BUF, SIZE_BUF_BYTES INTEGER BUFFER(SIZE_BUF) INTEGER LRHSINTR, POSINRHSINTR(LPOS_N) #if defined(USE_OLD_SCALING) REAL, intent(in) :: RHSINTR(LRHSINTR, NCOL_RHSINTR) INTEGER, intent(in) :: LSCALING REAL, intent(in) :: SCALING(LSCALING) #else REAL, intent(inout) :: RHSINTR(LRHSINTR, NCOL_RHSINTR) INTEGER, intent(in) :: LSCALING_LOC_BWD REAL, intent(in) :: SCALING_LOC_BWD(LSCALING_LOC_BWD) #endif LOGICAL, intent(in) :: LSCAL INTEGER, INTENT(in) :: SIZE_PERM_RHS INTEGER, INTENT(in) :: PERM_RHS(SIZE_PERM_RHS) INTEGER I, II, J, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL, N2RECV INTEGER LIELL, IPOS, NPIV, MAXNPIV_estim, MAXSurf INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR, allocok PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND, IPOSINRHSINTR INTEGER :: JCOL_RHS INTEGER :: K242 LOGICAL :: OMP_FLAG !$ INTEGER :: CHUNK, NOMP INTEGER, PARAMETER :: FIN = -1 REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER, ALLOCATABLE, DIMENSION(:) :: IROWlist INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_PROCNODE TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 IF ( TYPE_PARAL == 1 ) THEN MYID_NODES = MYID ELSE MYID_NODES = MYID-1 ENDIF IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN IF (LSCAL) THEN OMP_FLAG = .FALSE. IF (KEEP(350).EQ.2) THEN K242 = KEEP(242) !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK = max(N/2,1) !$ IF (int(NRHS,8) * int(N,8) .GE. int(KEEP(363),8)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8)) !$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362)) !$ CHUNK = max(KEEP(363)/2,CHUNK) !$ ENDIF ENDIF IF (OMP_FLAG) THEN !$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242) !$OMP& PRIVATE(J,IPOSINRHSINTR,I,JCOL_RHS) DO J=1, NRHS IF (K242.EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF !$OMP DO SCHEDULE(DYNAMIC,CHUNK) DO I=1, N IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN RHS(I,JCOL_RHS) = RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ELSE DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO I=1, N IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN RHS(I,JCOL_RHS) = RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO ENDDO ENDIF ELSE OMP_FLAG = .FALSE. IF (KEEP(350).EQ.2) THEN K242 = KEEP(242) !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = max(N/2,1) !$ IF (NRHS * N .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8)) !$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362)) !$ CHUNK = max(KEEP(363)/2,CHUNK) !$ ENDIF ENDIF IF (OMP_FLAG) THEN !$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242) !$OMP& PRIVATE(IPOSINRHSINTR,I,JCOL_RHS) IF (OMP_FLAG) DO J=1, NRHS IF (K242.EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF !$OMP DO SCHEDULE(DYNAMIC,CHUNK) DO I=1, N IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN RHS(I,JCOL_RHS) = RHSINTR(IPOSINRHSINTR,J) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ELSE DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO I=1, N IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN RHS(I,JCOL_RHS) = RHSINTR(IPOSINRHSINTR,J) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO ENDDO ENDIF ENDIF RETURN ENDIF MAXNPIV_estim = max(KEEP(246), KEEP(247)) MAXSurf = MAXNPIV_estim*NRHS IF (LCWORK .LT. MAXNPIV_estim) THEN WRITE(*,*) MYID, & ": Internal error 2 in SMUMPS_GATHER_SOLUTION:", & TYPE_PARAL, LCWORK, KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF IF (MYID.EQ.MASTER) THEN ALLOCATE(IROWlist(KEEP(247)),stat=allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of IROWlist' CALL MUMPS_ABORT() ENDIF ENDIF IF (NSLAVES .EQ. 1 .AND. TYPE_PARAL .EQ. 1) THEN CALL MUMPS_ABORT() ENDIF SIZE1=0 CALL MPI_PACK_SIZE(MAXNPIV_estim+2,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(MAXSurf,MPI_REAL, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in SMUMPS_GATHER_SOLUTION ' write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', & RECORD_SIZE_P_1, SIZE_BUF_BYTES CALL MUMPS_ABORT() ENDIF N2SEND =0 N2RECV =N POS_BUF =0 IF (I_AM_SLAVE) THEN POS_BUF = 0 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N) IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-NPIV IF (NPIV.GT.0) & CALL SMUMPS_NPIV_BLOCK_ADD ( .TRUE. ) ELSE IF (NPIV.GT.0) & CALL SMUMPS_NPIV_BLOCK_ADD ( .FALSE.) ENDIF ENDIF ENDDO CALL SMUMPS_NPIV_BLOCK_SEND() ENDIF IF ( MYID .EQ. MASTER ) THEN DO WHILE (N2RECV .NE. 0) CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, & MPI_ANY_SOURCE, & GatherSol, COMM, STATUS, IERR ) POS_BUF = 0 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & NPIV, 1, MPI_INTEGER, COMM, IERR) DO WHILE (NPIV.NE.FIN) CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & IROWlist, NPIV, MPI_INTEGER, COMM, IERR) DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS=J+JBEG_RHS-1 ELSE JCOL_RHS=PERM_RHS(J+JBEG_RHS-1) ENDIF CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & CWORK, NPIV, MPI_REAL, & COMM, IERR) #if defined(USE_OLD_SCALING) IF (LSCAL) THEN DO I=1,NPIV RHS(IROWlist(I),JCOL_RHS)=CWORK(I)*SCALING(IROWlist(I)) ENDDO ELSE #else #endif DO I=1,NPIV RHS(IROWlist(I),JCOL_RHS)=CWORK(I) ENDDO #if defined(USE_OLD_SCALING) ENDIF #endif ENDDO N2RECV=N2RECV-NPIV CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, & NPIV, 1, MPI_INTEGER, COMM, IERR) ENDDO ENDDO DEALLOCATE(IROWlist) ENDIF RETURN CONTAINS SUBROUTINE SMUMPS_NPIV_BLOCK_ADD ( ON_MASTER ) LOGICAL, intent(in) :: ON_MASTER INTEGER :: JPOS, K242 LOGICAL :: PRIV_LSCAL IF (ON_MASTER) THEN IF (KEEP(350).EQ.2 & .AND. (NRHS.EQ.1.OR.((NPIV*NRHS*2*KEEP(16)).GE.KEEP(364)))) THEN PRIV_LSCAL = LSCAL K242 = KEEP(242) DO J=1, NRHS IF (K242.EQ.0) THEN JPOS = J+JBEG_RHS-1 ELSE JPOS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) IF (PRIV_LSCAL) THEN RHS(I,JPOS) = RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ELSE RHS(I,JPOS) = RHSINTR(IPOSINRHSINTR,J) ENDIF ENDDO ENDDO ELSE IF (KEEP(242).EQ.0) THEN IF (LSCAL) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ENDDO ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = RHSINTR(IPOSINRHSINTR,J) ENDDO ENDDO ENDIF ELSE IF (LSCAL) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) !DIR$ NOVECTOR DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSINTR(IPOSINRHSINTR,J)* #if defined(USE_OLD_SCALING) & SCALING(I) #else & SCALING_LOC_BWD(IPOSINRHSINTR) #endif ENDDO ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSINTR= POSINRHSINTR(I) !DIR$ NOVECTOR DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSINTR(IPOSINRHSINTR,J) ENDDO ENDDO ENDIF ENDIF ENDIF RETURN ENDIF CALL MPI_PACK(NPIV, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(IW(J1), NPIV, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) IPOSINRHSINTR= POSINRHSINTR(IW(J1)) DO J=1,NRHS #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO II=IPOSINRHSINTR, IPOSINRHSINTR+NPIV-1 RHSINTR(II,J)= & RHSINTR(II,J)*SCALING_LOC_BWD(II) ENDDO ENDIF #endif CALL MPI_PACK(RHSINTR(IPOSINRHSINTR,J), NPIV, & MPI_REAL, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ENDDO N2SEND=N2SEND+NPIV IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL SMUMPS_NPIV_BLOCK_SEND() END IF RETURN END SUBROUTINE SMUMPS_NPIV_BLOCK_ADD SUBROUTINE SMUMPS_NPIV_BLOCK_SEND() IF (N2SEND .NE. 0) THEN CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, & GatherSol, COMM, IERR) ENDIF POS_BUF=0 N2SEND=0 RETURN END SUBROUTINE SMUMPS_NPIV_BLOCK_SEND END SUBROUTINE SMUMPS_GATHER_SOLUTION SUBROUTINE SMUMPS_GATHER_SOLUTION_AM1(NSLAVES, N, MYID, COMM, & NRHS, RHSINTR, LRHSINTR, NRHSINTR_COL, & KEEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, #if defined(USE_OLD_SCALING) & LSCAL, SCALING, LSCALING, #else & LSCAL, SCALING_LOC_BWD, LSCALING_LOC_BWD, #endif & IRHS_PTR_COPY, LIRHS_PTR_COPY, & IRHS_SPARSE_COPY, LIRHS_SPARSE_COPY, & RHS_SPARSE_COPY, LRHS_SPARSE_COPY, & UNS_PERM_INV, LUNS_PERM_INV, & POSINRHSINTR, LPOS_ROW, NB_FS_IN_RHSINTR ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM INTEGER NRHS, LRHSINTR, NRHSINTR_COL REAL, intent(in) :: RHSINTR (LRHSINTR, NRHSINTR_COL) INTEGER KEEP(500) INTEGER SIZE_BUF, SIZE_BUF_BYTES, LPOS_ROW INTEGER BUFFER(SIZE_BUF) INTEGER, intent(in) :: LIRHS_PTR_COPY, LIRHS_SPARSE_COPY, & LRHS_SPARSE_COPY, LUNS_PERM_INV, & NB_FS_IN_RHSINTR INTEGER :: IRHS_SPARSE_COPY(LIRHS_SPARSE_COPY), & IRHS_PTR_COPY(LIRHS_PTR_COPY), & UNS_PERM_INV(LUNS_PERM_INV), & POSINRHSINTR(LPOS_ROW) REAL :: RHS_SPARSE_COPY(LRHS_SPARSE_COPY) #if defined(USE_OLD_SCALING) INTEGER, intent(in) :: LSCALING REAL, intent(in) :: SCALING(LSCALING) #else INTEGER, intent(in) :: LSCALING_LOC_BWD REAL, intent(in) :: SCALING_LOC_BWD(LSCALING_LOC_BWD) #endif LOGICAL, intent(in) :: LSCAL INTEGER COLSIZE, K, IZ, IPREV, NBCOL_INBLOC INTEGER I, II, J, MASTER, & TYPE_PARAL, N2RECV, IPOSINRHSINTR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND INTEGER, PARAMETER :: FIN = -1 INCLUDE 'mumps_headers.h' TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 NBCOL_INBLOC = size(IRHS_PTR_COPY)-1 IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN K=1 DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.EQ.0) CYCLE DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)= & RHSINTR(IPOSINRHSINTR,K) #if defined(USE_OLD_SCALING) & * SCALING(I) #else & * SCALING_LOC_BWD(IPOSINRHSINTR) #endif ELSE RHS_SPARSE_COPY(IZ)=RHSINTR(IPOSINRHSINTR,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) IPOSINRHSINTR = POSINRHSINTR(I) IF (IPOSINRHSINTR.GT.0) THEN #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)=RHSINTR(IPOSINRHSINTR,K) & * SCALING_LOC_BWD(IPOSINRHSINTR) ELSE #endif RHS_SPARSE_COPY(IZ)=RHSINTR(IPOSINRHSINTR,K) #if ! defined(USE_OLD_SCALING) ENDIF #endif ENDIF ENDDO K = K + 1 ENDDO ENDIF SIZE1=0 CALL MPI_PACK_SIZE(3,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(1,MPI_REAL, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in SMUMPS_GATHER_SOLUTION_AM1 ' write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', & RECORD_SIZE_P_1, SIZE_BUF_BYTES CALL MUMPS_ABORT() ENDIF N2SEND =0 N2RECV =size(IRHS_SPARSE_COPY) POS_BUF =0 IF (I_AM_SLAVE) THEN DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.LE.0) CYCLE K = 0 DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) II = I IF (KEEP(23).NE.0) II = UNS_PERM_INV(I) IPOSINRHSINTR = POSINRHSINTR(II) IF (IPOSINRHSINTR.GT.0) THEN IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-1 #if defined(USE_OLD_SCALING) IF (LSCAL) & CALL SMUMPS_AM1_BLOCK_ADD ( .TRUE. ) #endif 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 #if defined(USE_OLD_SCALING) CALL SMUMPS_AM1_BLOCK_ADD ( .FALSE. ) #else CALL SMUMPS_AM1_BLOCK_ADD () #endif ENDIF ENDIF ENDDO IF (MYID.EQ.MASTER) & IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + K ENDDO CALL SMUMPS_AM1_BLOCK_SEND() ENDIF IF ( MYID .EQ. MASTER ) THEN DO WHILE (N2RECV .NE. 0) CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, & MPI_ANY_SOURCE, & GatherSol, COMM, STATUS, IERR ) POS_BUF = 0 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & J, 1, MPI_INTEGER, COMM, IERR) DO WHILE (J.NE.FIN) IZ = IRHS_PTR_COPY(J) CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & I, 1, MPI_INTEGER, COMM, IERR) IRHS_SPARSE_COPY(IZ) = I CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & RHS_SPARSE_COPY(IZ), 1, MPI_REAL, & COMM, IERR) #if defined(USE_OLD_SCALING) IF (LSCAL) THEN IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) RHS_SPARSE_COPY(IZ) = RHS_SPARSE_COPY(IZ)*SCALING(I) ENDIF #endif N2RECV=N2RECV-1 IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + 1 CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, & J, 1, MPI_INTEGER, COMM, IERR) ENDDO ENDDO IPREV = 1 DO J=1, size(IRHS_PTR_COPY)-1 I= IRHS_PTR_COPY(J) IRHS_PTR_COPY(J) = IPREV IPREV = I ENDDO ENDIF RETURN CONTAINS SUBROUTINE SMUMPS_AM1_BLOCK_ADD ( #if defined(USE_OLD_SCALING) & SCALE_ONLY #endif & ) #if defined(USE_OLD_SCALING) LOGICAL, intent(in) :: SCALE_ONLY #endif #if defined(USE_OLD_SCALING) INTEGER III #endif #if defined(USE_OLD_SCALING) IF (SCALE_ONLY) THEN WRITE(*,*) "SMUMPS_AM1_BLOCK_ADD(true) should not be called" CALL MUMPS_ABORT() 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 #endif CALL MPI_PACK(J, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(I, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(RHS_SPARSE_COPY(IZ), 1, MPI_REAL, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) N2SEND=N2SEND+1 IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL SMUMPS_AM1_BLOCK_SEND() END IF RETURN END SUBROUTINE SMUMPS_AM1_BLOCK_ADD SUBROUTINE SMUMPS_AM1_BLOCK_SEND() IF (N2SEND .NE. 0) THEN CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, & GatherSol, COMM, IERR) ENDIF POS_BUF=0 N2SEND=0 RETURN END SUBROUTINE SMUMPS_AM1_BLOCK_SEND END SUBROUTINE SMUMPS_GATHER_SOLUTION_AM1 SUBROUTINE SMUMPS_DISTSOL_INDICES(MTYPE, ISOL_LOC, & PTRIST, KEEP,KEEP8, & IW, LIW_PASSED, MYID_NODES, N, STEP, & PROCNODE, NSLAVES, #if defined(USE_OLD_SCALING) & scaling_data, LSCAL, #endif & IRHS_loc_MEANINGFUL, IRHS_loc, Nloc_RHS & ) IMPLICIT NONE INTEGER MTYPE, MYID_NODES, N, NSLAVES INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE(KEEP(28)) INTEGER ISOL_LOC(KEEP(89)) INTEGER LIW_PASSED INTEGER IW(LIW_PASSED) INTEGER STEP(N) #if defined(USE_OLD_SCALING) LOGICAL LSCAL #endif LOGICAL :: IRHS_loc_MEANINGFUL INTEGER :: Nloc_RHS INTEGER :: IRHS_loc(Nloc_RHS) #if defined(USE_OLD_SCALING) type scaling_data_t SEQUENCE REAL, dimension(:), pointer :: SCALING REAL, dimension(:), pointer :: SCALING_LOC INTEGER, dimension(:), pointer :: SCALING_IND end type scaling_data_t type (scaling_data_t) :: scaling_data #endif INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER ISTEP, K INTEGER J1, IPOS, LIELL, NPIV, JJ LOGICAL :: CHECK_IRHS_loc INTEGER(8) :: DIFF_ADDR INCLUDE 'mumps_headers.h' CHECK_IRHS_loc=.FALSE. IF ( IRHS_loc_MEANINGFUL ) THEN IF (Nloc_RHS .GT. 0) THEN CALL MUMPS_SIZE_C( IRHS_loc(1), ISOL_loc(1), & DIFF_ADDR ) IF (DIFF_ADDR .EQ. 0_8) THEN CHECK_IRHS_loc=.TRUE. ENDIF ENDIF ENDIF K=0 DO ISTEP=1, KEEP(28) IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW_PASSED, PTRIST, STEP, N) IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF DO JJ=J1,J1+NPIV-1 K=K+1 IF (CHECK_IRHS_loc) THEN IF (K.LE.Nloc_RHS) THEN IF ( IW(JJ) .NE.IRHS_LOC(K) ) THEN ENDIF ENDIF ENDIF ISOL_LOC(K)=IW(JJ) #if defined(USE_OLD_SCALING) IF (LSCAL) THEN scaling_data%SCALING_LOC(K)= & scaling_data%SCALING(IW(JJ)) ENDIF #endif ENDDO ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_DISTSOL_INDICES #if ! defined(USE_OLD_SCALING) SUBROUTINE SMUMPS_SCALINGRHSINTR(LSCAL, N, & SCALING_LOC, SCALING_RHSINTR, & L, POSINRHSINTR, KEEP, ROWORCOL, PTRIST, & IW, LIW_PASSED, MYID_NODES, STEP, & PROCNODE, NSLAVES) IMPLICIT NONE INTEGER :: KEEP(500) LOGICAL, INTENT(IN) :: LSCAL INTEGER, INTENT(IN) :: N, L INTEGER, INTENT(IN) :: POSINRHSINTR(N) REAL , INTENT(IN) :: SCALING_LOC(max(KEEP(89),1)) REAL , INTENT(OUT) :: SCALING_RHSINTR(L) INTEGER, INTENT(IN) :: ROWORCOL, NSLAVES, LIW_PASSED, MYID_NODES INTEGER, INTENT(IN) :: STEP(KEEP(28)), & PROCNODE(KEEP(28)), & PTRIST(KEEP(28)), & IW(LIW_PASSED) INTEGER :: IPOSINRHSINTR INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER :: ISTEP INTEGER :: KLOC, J1, JJ, LIELL, IPOS, NPIV IF (.NOT. LSCAL) THEN WRITE(*,*) "Internal error 1 in SMUMPS_DS_SCALINGRHSINTR" CALL MUMPS_ABORT() ENDIF IF (ROWORCOL .NE. 1 .AND. ROWORCOL.NE.2) THEN WRITE(*,*) "Internal error 2 in SMUMPS_DS_SCALINGRHSINTR", & ROWORCOL ENDIF IF (KEEP(89).EQ.0) RETURN KLOC = 1 DO ISTEP=1, KEEP(28) IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW_PASSED, PTRIST, STEP, N) IF (ROWORCOL .EQ. 1) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IPOSINRHSINTR = POSINRHSINTR(IW(J1)) IF ( IPOSINRHSINTR .GT. 0 ) THEN DO JJ=1, NPIV SCALING_RHSINTR(IPOSINRHSINTR+JJ-1) = & SCALING_LOC(KLOC+JJ-1) ENDDO ENDIF KLOC = KLOC + NPIV ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_SCALINGRHSINTR #endif SUBROUTINE SMUMPS_DISTRIBUTED_SOLUTION( & SLAVEF, N, MYID_NODES, & MTYPE, RHSINTR, LRHSINTR, NBRHS_EFF, & POSINRHSINTR, & ISOL_LOC, & SOL_LOC, NRHS, BEG_RHS, LSOL_LOC, & PTRIST, & PROCNODE_STEPS, KEEP,KEEP8, IW, LIW, STEP, & SCALING_LOC_BWD, LSCALING_LOC_BWD, & LSCAL, NB_RHSSKIPPED, & PERM_RHS, SIZE_PERM_RHS) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' LOGICAL, intent(in) :: LSCAL INTEGER, intent(in) :: LSCALING_LOC_BWD REAL, intent(in) :: SCALING_LOC_BWD(LSCALING_LOC_BWD) INTEGER SLAVEF, N, MYID_NODES, LIW, MTYPE, NBRHS_EFF, LRHSINTR INTEGER POSINRHSINTR(N), NB_RHSSKIPPED INTEGER LSOL_LOC, BEG_RHS INTEGER ISOL_LOC(LSOL_LOC) INTEGER, INTENT(in) :: NRHS REAL SOL_LOC( LSOL_LOC, NRHS ) REAL RHSINTR( LRHSINTR, NBRHS_EFF ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER, INTENT(in) :: SIZE_PERM_RHS INTEGER, INTENT(in) :: PERM_RHS( SIZE_PERM_RHS ) INTEGER :: JJ, J1, ISTEP, K, KLOC, IPOSINRHSINTR, JEMPTY INTEGER :: JCOL, JCOL_PERM INTEGER :: IPOS, LIELL, NPIV, JEND LOGICAL :: IS_ROOT !$ LOGICAL :: OMP_FLAG REAL, PARAMETER :: ZERO = 0.0E0 INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE K=0 JEMPTY = BEG_RHS+NB_RHSSKIPPED-1 JEND = BEG_RHS+NB_RHSSKIPPED+NBRHS_EFF-1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN IS_ROOT=.false. IF (KEEP(38).ne.0) IS_ROOT = STEP(KEEP(38))==ISTEP IF (KEEP(20).ne.0) IS_ROOT = STEP(KEEP(20))==ISTEP IF ( IS_ROOT ) THEN IPOS = PTRIST(ISTEP) + KEEP(IXSZ) LIELL = IW(IPOS+3) NPIV = LIELL IPOS= PTRIST(ISTEP)+5+KEEP(IXSZ) ELSE IPOS = PTRIST(ISTEP) + 2 +KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) IPOS= IPOS+1 NPIV = IW(IPOS) IPOS= IPOS+1 IPOS= IPOS+1+IW( PTRIST(ISTEP) + 5 +KEEP(IXSZ)) END IF IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF IF (NB_RHSSKIPPED.GT.0) THEN DO JCOL = BEG_RHS, JEMPTY IF (KEEP(242) .NE. 0) THEN JCOL_PERM = PERM_RHS(JCOL) ELSE JCOL_PERM = JCOL ENDIF KLOC=K DO JJ=J1,J1+NPIV-1 KLOC=KLOC+1 SOL_LOC(KLOC, JCOL_PERM) = ZERO ENDDO ENDDO ENDIF !$ OMP_FLAG = ( JEND-JEMPTY.GE.KEEP(362) .AND. !$ & (NPIV*(JEND-JEMPTY) .GE. KEEP(363)/2 ) ) !$OMP PARALLEL DO PRIVATE(JCOL,JCOL_PERM,KLOC,JJ,IPOSINRHSINTR) !$OMP& IF(OMP_FLAG) DO JCOL = JEMPTY+1, JEND IF (KEEP(242) .NE. 0) THEN JCOL_PERM = PERM_RHS(JCOL) ELSE JCOL_PERM = JCOL ENDIF DO JJ=J1,J1+NPIV-1 KLOC=K + JJ-J1 + 1 IF (LSCAL) THEN SOL_LOC(KLOC,JCOL_PERM) = & SCALING_LOC_BWD(KLOC)* & RHSINTR(KLOC,JCOL-JEMPTY) ELSE SOL_LOC(KLOC,JCOL_PERM) = & RHSINTR(KLOC,JCOL-JEMPTY) ENDIF ENDDO ENDDO !$OMP END PARALLEL DO K=K+NPIV ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_DISTRIBUTED_SOLUTION SUBROUTINE SMUMPS_SCATTER_RHS & (NSLAVES, N, MYID, COMM, & LSCAL, SCALING_LOC_FWD, & MTYPE, RHS, LRHS, NCOL_RHS, NRHS, & RHSINTR, LRHSINTR, NCOL_RHSINTR, & POSINRHSINTR_FWD, NB_FS_IN_RHSINTR_F, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & ICNTL, INFO) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE INTEGER NRHS, LRHS, NCOL_RHS, LRHSINTR, NCOL_RHSINTR INTEGER ICNTL(60), INFO(80) REAL, intent(in) :: RHS (LRHS, NCOL_RHS) REAL, intent(out) :: RHSINTR(LRHSINTR, NCOL_RHSINTR) INTEGER, intent(in) :: POSINRHSINTR_FWD(N), NB_FS_IN_RHSINTR_F INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) LOGICAL, intent(in) :: LSCAL REAL, intent(in) :: SCALING_LOC_FWD(max(1,KEEP(89))) INTEGER BUF_MAXSIZE, BUF_MAXREF PARAMETER (BUF_MAXREF=200000) INTEGER, ALLOCATABLE, DIMENSION(:) :: BUF_INDX REAL, ALLOCATABLE, DIMENSION(:,:) :: BUF_RHS REAL, ALLOCATABLE, DIMENSION(:) :: BUF_RHS_2 INTEGER ENTRIES_2_PROCESS, PROC_WHO_ASKS, BUF_EFFSIZE INTEGER INDX INTEGER allocok REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER I, J, K, JJ, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL INTEGER LIELL, IPOS, NPIV INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE !$ INTEGER :: CHUNK, NOMP !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. 0 .OR. TYPE_PARAL .eq. 1 IF ( TYPE_PARAL == 1 ) THEN MYID_NODES = MYID ELSE MYID_NODES = MYID-1 ENDIF BUF_EFFSIZE = 0 BUF_MAXSIZE = max(min(BUF_MAXREF,int(2000000/NRHS)),2000) IF ( KEEP(350).EQ.2 ) THEN !$ NOMP = OMP_GET_MAX_THREADS() ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS_2(BUF_MAXSIZE*NRHS), & stat=allocok) ELSE ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS(NRHS,BUF_MAXSIZE), & stat=allocok) END IF IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=BUF_MAXSIZE*(NRHS+1) ENDIF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM, MYID ) IF (INFO(1).LT.0) RETURN IF (MYID.EQ.MASTER) THEN ENTRIES_2_PROCESS = N - KEEP(89) IF (TYPE_PARAL.EQ.1.AND.ENTRIES_2_PROCESS.NE.0) THEN IF (NB_FS_IN_RHSINTR_F.LT.LRHSINTR) THEN DO K=1, NCOL_RHSINTR DO I = NB_FS_IN_RHSINTR_F +1, LRHSINTR RHSINTR (I, K) = ZERO ENDDO ENDDO ENDIF ENDIF IF ( KEEP(350).EQ.2 ) THEN DO WHILE ( ENTRIES_2_PROCESS .NE. 0) CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, & ScatterRhsI, COMM, STATUS, IERR ) CALL MPI_GET_COUNT(STATUS,MPI_INTEGER,BUF_EFFSIZE,IERR) PROC_WHO_ASKS = STATUS(MPI_SOURCE) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = BUF_INDX( I ) BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) = RHS( INDX, K ) ENDDO ENDDO !$OMP END PARALLEL DO CALL MPI_SEND( BUF_RHS_2, & NRHS*BUF_EFFSIZE, & MPI_REAL, PROC_WHO_ASKS, & ScatterRhsR, COMM, IERR) ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE ENDDO BUF_EFFSIZE= 0 ELSE DO WHILE ( ENTRIES_2_PROCESS .NE. 0) CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, & ScatterRhsI, COMM, STATUS, IERR ) CALL MPI_GET_COUNT( STATUS, MPI_INTEGER,BUF_EFFSIZE,IERR) PROC_WHO_ASKS = STATUS(MPI_SOURCE) DO I = 1, BUF_EFFSIZE INDX = BUF_INDX( I ) DO K = 1, NRHS BUF_RHS( K, I ) = RHS( INDX, K ) ENDDO ENDDO CALL MPI_SEND( BUF_RHS, NRHS*BUF_EFFSIZE, & MPI_REAL, PROC_WHO_ASKS, & ScatterRhsR, COMM, IERR) ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE ENDDO BUF_EFFSIZE= 0 ENDIF ENDIF IF (I_AM_SLAVE) THEN IF (MYID.NE.MASTER) THEN IF (NB_FS_IN_RHSINTR_F.LT.LRHSINTR) THEN DO K=1, NCOL_RHSINTR DO I = NB_FS_IN_RHSINTR_F +1, LRHSINTR RHSINTR (I, K) = ZERO ENDDO ENDDO ENDIF ENDIF DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF (MYID.EQ.MASTER) THEN INDX = POSINRHSINTR_FWD(IW(J1)) IF (KEEP(350).EQ.2 .AND. & (NRHS.EQ.1.OR.((NPIV*NRHS*2*KEEP(16)).GE.KEEP(364)))) THEN !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (NPIV*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((NPIV*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(J,JJ) !$OMP& FIRSTPRIVATE(INDX) IF (OMP_FLAG) DO K = 1, NRHS DO JJ=J1,J1+NPIV-1 J=IW(JJ) RHSINTR( INDX+JJ-J1, K ) = RHS( J, K ) * & SCALING_LOC_FWD( INDX+JJ-J1 ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE #endif !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(J,JJ) !$OMP& FIRSTPRIVATE(INDX) IF (OMP_FLAG) DO K = 1, NRHS DO JJ=J1,J1+NPIV-1 J=IW(JJ) RHSINTR( INDX+JJ-J1, K ) = RHS( J, K ) ENDDO ENDDO !$OMP END PARALLEL DO #if ! defined(USE_OLD_SCALING) ENDIF #endif ELSE #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO JJ=J1,J1+NPIV-1 J=IW(JJ) DO K = 1, NRHS RHSINTR( INDX+JJ-J1, K ) = RHS( J, K ) & * SCALING_LOC_FWD( INDX + JJ - J1 ) ENDDO ENDDO ELSE #endif DO JJ=J1,J1+NPIV-1 J=IW(JJ) DO K = 1, NRHS RHSINTR( INDX+JJ-J1, K ) = RHS( J, K ) ENDDO ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif END IF ELSE DO JJ=J1,J1+NPIV-1 BUF_EFFSIZE = BUF_EFFSIZE + 1 BUF_INDX(BUF_EFFSIZE) = IW(JJ) IF (BUF_EFFSIZE + 1 .GT. BUF_MAXSIZE) THEN CALL SMUMPS_GET_BUF_INDX_RHS() ENDIF ENDDO ENDIF ENDIF ENDDO IF ( BUF_EFFSIZE .NE. 0 .AND. MYID.NE.MASTER ) & CALL SMUMPS_GET_BUF_INDX_RHS() ENDIF IF (KEEP(350).EQ.2) THEN DEALLOCATE (BUF_INDX, BUF_RHS_2) ELSE DEALLOCATE (BUF_INDX, BUF_RHS) ENDIF RETURN CONTAINS SUBROUTINE SMUMPS_GET_BUF_INDX_RHS() CALL MPI_SEND(BUF_INDX, BUF_EFFSIZE, MPI_INTEGER, & MASTER, ScatterRhsI, COMM, IERR ) IF (KEEP(350).EQ.2) THEN CALL MPI_RECV(BUF_RHS_2, BUF_EFFSIZE*NRHS, & MPI_REAL, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = POSINRHSINTR_FWD(BUF_INDX(I)) RHSINTR( INDX, K ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) * & SCALING_LOC_FWD( INDX ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE #endif !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = POSINRHSINTR_FWD(BUF_INDX(I)) RHSINTR( INDX, K ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) ENDDO ENDDO !$OMP END PARALLEL DO #if ! defined(USE_OLD_SCALING) ENDIF #endif ELSE CALL MPI_RECV(BUF_RHS, BUF_EFFSIZE*NRHS, & MPI_REAL, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO I = 1, BUF_EFFSIZE INDX = POSINRHSINTR_FWD(BUF_INDX(I)) DO K = 1, NRHS RHSINTR( INDX, K ) = BUF_RHS( K, I ) & * SCALING_LOC_FWD( INDX ) ENDDO ENDDO ELSE #endif DO I = 1, BUF_EFFSIZE INDX = POSINRHSINTR_FWD(BUF_INDX(I)) DO K = 1, NRHS RHSINTR( INDX, K ) = BUF_RHS( K, I ) ENDDO ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif END IF BUF_EFFSIZE = 0 RETURN END SUBROUTINE SMUMPS_GET_BUF_INDX_RHS END SUBROUTINE SMUMPS_SCATTER_RHS SUBROUTINE SMUMPS_BUILD_GLOB2LOC & (NSLAVES, N, MYID_NODES, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & GLOB2LOC_RHS, GLOB2LOC_SOL, & GLOB2LOC_SOL_ALLOC, & MTYPE, & NBENT_RHSINTR, NB_FS_IN_RHSINTR ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER, intent(in) :: IW(LIW), STEP(N) INTEGER, intent(in) :: MTYPE LOGICAL, intent(in) :: GLOB2LOC_SOL_ALLOC INTEGER, intent(out):: GLOB2LOC_RHS(N), GLOB2LOC_SOL(N) INTEGER, intent(out):: NBENT_RHSINTR, NB_FS_IN_RHSINTR INTEGER ISTEP INTEGER NPIV INTEGER IPOS, LIELL INTEGER JJ, J1, JCOL INTEGER IPOSINRHSINTR, IPOSINRHSINTR_SOL INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE GLOB2LOC_RHS = 0 IF (GLOB2LOC_SOL_ALLOC) GLOB2LOC_SOL = 0 IPOSINRHSINTR = 1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, NPIV, LIELL, & IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = J1, J1+NPIV-1 GLOB2LOC_RHS(IW(JJ)) = IPOSINRHSINTR+JJ-J1 ENDDO IF (GLOB2LOC_SOL_ALLOC) THEN DO JJ = JCOL, JCOL+NPIV-1 GLOB2LOC_SOL(IW(JJ)) = IPOSINRHSINTR+JJ-JCOL ENDDO ENDIF IPOSINRHSINTR = IPOSINRHSINTR + NPIV ENDIF ENDDO NB_FS_IN_RHSINTR = IPOSINRHSINTR -1 IF (GLOB2LOC_SOL_ALLOC) IPOSINRHSINTR_SOL=IPOSINRHSINTR IF (IPOSINRHSINTR.GT.N) GOTO 500 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF (GLOB2LOC_SOL_ALLOC) THEN DO JJ = NPIV, LIELL-1-KEEP(253) IF (GLOB2LOC_RHS(IW(J1+JJ)).EQ.0) THEN GLOB2LOC_RHS(IW(J1+JJ)) = - IPOSINRHSINTR IPOSINRHSINTR = IPOSINRHSINTR + 1 ENDIF IF (GLOB2LOC_SOL(IW(JCOL+JJ)).EQ.0) THEN GLOB2LOC_SOL(IW(JCOL+JJ)) = - IPOSINRHSINTR_SOL IPOSINRHSINTR_SOL = IPOSINRHSINTR_SOL + 1 ENDIF ENDDO ELSE DO JJ = J1+NPIV, J1+LIELL-1-KEEP(253) IF (GLOB2LOC_RHS(IW(JJ)).EQ.0) THEN GLOB2LOC_RHS(IW(JJ)) = - IPOSINRHSINTR IPOSINRHSINTR = IPOSINRHSINTR + 1 ENDIF ENDDO ENDIF ENDIF ENDDO 500 NBENT_RHSINTR = IPOSINRHSINTR - 1 IF (GLOB2LOC_SOL_ALLOC) & NBENT_RHSINTR = max(NBENT_RHSINTR, IPOSINRHSINTR_SOL-1) RETURN END SUBROUTINE SMUMPS_BUILD_GLOB2LOC SUBROUTINE SMUMPS_NODES_FWD_BWD_SIZE_FILL ( & fill, ICNTL, & N, NSTEPS, KEEP, STEP, Step2node, & IRHS_loc, Nloc_RHS, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & PERM_RHS, SIZE_PERM_RHS, JBEG_RHS, & UNS_PERM_INV, SIZE_UNS_PERM_INV, & ICNTL21, & MYID, COMM, & INFO, & Pruned_Sons_FWD, Pruned_Sons_BWD, & Lnodes_FWD, Lnodes_BWD & , nodes_FWD, nodes_BWD & , Lnodes_FWD_in, Lnodes_BWD_in & ) USE SMUMPS_SOL_ES, ONLY : SMUMPS_ES_NODES_SIZE_AND_FILL IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: ICNTL(60),N, NSTEPS, KEEP(500) INTEGER, INTENT(IN) :: STEP(N), Step2node(NSTEPS) INTEGER, INTENT(IN) :: Nloc_RHS, & IRHS_loc(max(1,Nloc_RHS)) INTEGER, intent(in) :: NBCOL_INBLOC, IRHS_PTR(NBCOL_INBLOC+1) INTEGER, intent(in) :: NZ_RHS, IRHS_SPARSE(NZ_RHS) INTEGER, intent(in) :: SIZE_PERM_RHS, PERM_RHS(SIZE_PERM_RHS) INTEGER, intent(in) :: JBEG_RHS, SIZE_UNS_PERM_INV INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, intent(IN) :: ICNTL21 INTEGER, intent(in) :: MYID, COMM INTEGER, intent(inout) :: INFO(80) INTEGER, intent(inout) :: Pruned_Sons_FWD(NSTEPS), & Pruned_Sons_BWD(NSTEPS) INTEGER, intent(inout) :: Lnodes_FWD, Lnodes_BWD INTEGER, intent(in) :: Lnodes_FWD_in, Lnodes_BWD_in INTEGER, intent(out) :: nodes_FWD(Lnodes_FWD_in), & nodes_BWD(Lnodes_BWD_in) INCLUDE 'mpif.h' LOGICAL :: DO_PRUN_FWD, AM1, Exploit_Sparsity_FWD, & Exploit_Sparsity_BWD INTEGER :: Lnodes_FWD_loc, Lnodes_BWD_loc, ISTEP, & INODE_PRINC, I, II, JAM1 #if defined(AVOID_MPI_IN_PLACE) INTEGER, DIMENSION(:), ALLOCATABLE :: TMP_INT_ARRAY INTEGER :: allocok #endif #if defined(AVOID_MPI_IN_PLACE) ALLOCATE(TMP_INT_ARRAY(KEEP(28)), STAT = allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM, MYID ) IF(INFO(1).LT.0) GOTO 500 #endif AM1 = (KEEP(237) .NE. 0) Exploit_Sparsity_FWD = (KEEP(235) .NE. 0) .AND. (.NOT. AM1) DO_PRUN_FWD = (Exploit_Sparsity_FWD.OR.AM1) Exploit_Sparsity_BWD = (KEEP(212) .NE. 0) .AND. (.NOT. AM1) IF (.NOT.fill) Lnodes_FWD=-1 IF (.NOT.fill) Lnodes_BWD=-1 IF (.NOT.fill.AND.KEEP(252).NE.0) THEN Lnodes_FWD = 0 ENDIF IF ( KEEP(252).NE.0 ) DO_PRUN_FWD = .FALSE. IF ( DO_PRUN_FWD ) THEN IF ( Exploit_Sparsity_FWD.AND.KEEP(248).EQ.-1 ) THEN IF (.NOT.fill) THEN CALL SMUMPS_ES_NODES_SIZE_AND_FILL ( fill, & N, KEEP(28), KEEP, STEP, Step2node, & IRHS_loc, Nloc_RHS, MYID, COMM, & Pruned_Sons_FWD, Lnodes_FWD #if defined(AVOID_MPI_IN_PLACE) & , TMP_INT_ARRAY #endif & ) ELSE IF (Lnodes_FWD.GT.0) THEN CALL SMUMPS_ES_NODES_SIZE_AND_FILL ( fill, & N, KEEP(28), KEEP, STEP, Step2node, & IRHS_loc, Nloc_RHS, MYID, COMM, & Pruned_Sons_FWD, Lnodes_FWD, #if defined(AVOID_MPI_IN_PLACE) & TMP_INT_ARRAY, #endif & nodes_FWD & ) ENDIF ELSE IF ( Exploit_Sparsity_FWD.AND.KEEP(248).NE.-1 ) THEN IF (.NOT.fill) THEN Lnodes_FWD = 0 Pruned_Sons_FWD(:) = -1 DO I = 1, NZ_RHS ISTEP = abs( STEP(IRHS_SPARSE(I)) ) IF ( Pruned_Sons_FWD(ISTEP) .eq. -1) THEN Lnodes_FWD = Lnodes_FWD +1 Pruned_Sons_FWD(ISTEP) = 0 ENDIF ENDDO ELSE IF (Lnodes_FWD.GT.0) THEN Lnodes_FWD_loc = 0 Pruned_Sons_FWD(:) = -1 DO I = 1, NZ_RHS ISTEP = abs( STEP(IRHS_SPARSE(I)) ) INODE_PRINC = Step2node( ISTEP ) IF ( Pruned_Sons_FWD(ISTEP) .eq. -1) THEN Lnodes_FWD_loc = Lnodes_FWD_loc +1 nodes_FWD(Lnodes_FWD_loc) = INODE_PRINC Pruned_Sons_FWD(ISTEP) = 0 ENDIF ENDDO ENDIF ELSE IF ( AM1 ) THEN IF (.NOT.fill) THEN Lnodes_FWD = 0 Pruned_Sons_FWD(:) = -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_FWD(ISTEP) .eq. -1) THEN Lnodes_FWD = Lnodes_FWD +1 Pruned_Sons_FWD(ISTEP) = 0 ENDIF ENDDO ELSE IF (Lnodes_FWD.GT.0) THEN Lnodes_FWD_loc = 0 Pruned_Sons_FWD = -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_FWD(ISTEP) .eq. -1) THEN Lnodes_FWD_loc = Lnodes_FWD_loc +1 nodes_FWD(Lnodes_FWD_loc) = INODE_PRINC Pruned_Sons_FWD(ISTEP) = 0 ENDIF ENDDO ENDIF ENDIF ENDIF IF (AM1) THEN IF (.NOT.fill) THEN Lnodes_BWD = 0 Pruned_Sons_BWD(:) = -1 DO II = 1, NZ_RHS I = IRHS_SPARSE(II) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) ISTEP = abs(STEP(I)) IF ( Pruned_Sons_BWD(ISTEP) .eq. -1) THEN Lnodes_BWD = Lnodes_BWD +1 Pruned_Sons_BWD(ISTEP) = 0 ENDIF ENDDO ELSE IF (Lnodes_BWD.GT.0) THEN Lnodes_BWD_loc = 0 Pruned_Sons_BWD(:) = -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_BWD(ISTEP) .eq. -1) THEN Lnodes_BWD_loc = Lnodes_BWD_loc +1 nodes_BWD(Lnodes_BWD_loc) = INODE_PRINC Pruned_Sons_BWD(ISTEP) = 0 ENDIF ENDDO ENDIF ENDIF #if defined(AVOID_MPI_IN_PLACE) GOTO 600 500 CONTINUE Lnodes_FWD = -1 Lnodes_BWD = -1 600 CONTINUE #endif #if defined(AVOID_MPI_IN_PLACE) IF ( allocated(TMP_INT_ARRAY)) DEALLOCATE(TMP_INT_ARRAY) #endif RETURN END SUBROUTINE SMUMPS_NODES_FWD_BWD_SIZE_FILL SUBROUTINE SMUMPS_BUILD_GLOB2LOC_NODES_ES ( & NSLAVES, N, MYID_NODES, & PTRIST, DAD, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & Lnodes_FWD, Lnodes_BWD, & nodes_FWD, nodes_BWD, & GLOB2LOC_RHS, GLOB2LOC_SOL, & GLOB2LOC_SOL_ALLOC, & MTYPE, & NBENT_RHSINTR, & NB_FS_IN_RHSINTR_FWD, NB_FS_IN_RHSINTR_TOT & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER, intent(in) :: Lnodes_FWD, Lnodes_BWD INTEGER, intent(in) :: nodes_FWD(max(1,Lnodes_FWD)), & nodes_BWD(max(1,Lnodes_BWD)) INTEGER, intent(inout) :: DAD(KEEP(28)) INTEGER, intent(in) :: IW(LIW), STEP(N) INTEGER, intent(in) :: MTYPE LOGICAL, intent(in) :: GLOB2LOC_SOL_ALLOC INTEGER, intent(out):: GLOB2LOC_RHS(N), GLOB2LOC_SOL(N) INTEGER, intent(out):: NBENT_RHSINTR INTEGER, intent(out):: NB_FS_IN_RHSINTR_FWD, NB_FS_IN_RHSINTR_TOT INTEGER I INTEGER ISTEP, OLDISTEP INTEGER NPIV INTEGER IPOS, LIELL INTEGER JJ, J1, JCOL, ABSJCOL INTEGER IPOSINRHSINTR_RHS, IPOSINRHSINTR_SOL INTEGER NBENT_RHSINTR_ROW, NBENT_RHSINTR_COL LOGICAL GO_UP INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE GLOB2LOC_RHS = 0 IF (GLOB2LOC_SOL_ALLOC) GLOB2LOC_SOL = 0 IPOSINRHSINTR_RHS = 0 IPOSINRHSINTR_SOL = 0 DO I = 1, Lnodes_FWD ISTEP = STEP(nodes_FWD(I)) GO_UP = .TRUE. DO WHILE(GO_UP) IF (DAD(ISTEP) .GE. 0) THEN OLDISTEP=ISTEP IF (DAD(ISTEP).EQ.0) THEN GO_UP=.FALSE. ELSE GO_UP=.TRUE. ISTEP = STEP(DAD(ISTEP)) ENDIF DAD(OLDISTEP)=-DAD(OLDISTEP)-1 ELSE GO_UP = .FALSE. ENDIF END DO END DO DO ISTEP=1, KEEP(28) IF (DAD(ISTEP) .LT. 0) THEN DAD(ISTEP) = -DAD(ISTEP) - 1 IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF(NPIV.GT.0) THEN DO JJ = J1, J1+NPIV-1 GLOB2LOC_RHS(IW(JJ)) & = IPOSINRHSINTR_RHS + JJ - J1 + 1 ENDDO IPOSINRHSINTR_RHS = IPOSINRHSINTR_RHS + NPIV IF (GLOB2LOC_SOL_ALLOC) THEN DO JJ = JCOL, JCOL+NPIV-1 GLOB2LOC_SOL(IW(JJ)) & = - ( IPOSINRHSINTR_SOL + JJ - JCOL + 1 ) ENDDO IPOSINRHSINTR_SOL = IPOSINRHSINTR_SOL + NPIV ENDIF END IF END IF ENDIF END DO NB_FS_IN_RHSINTR_FWD = IPOSINRHSINTR_RHS IF(GLOB2LOC_SOL_ALLOC) THEN DO I=1, Lnodes_BWD ISTEP = STEP(nodes_BWD(I)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF ABSJCOL = abs(IW(JCOL)) IF(NPIV.GT.0) THEN IF(GLOB2LOC_SOL(ABSJCOL).EQ.0) THEN DO JJ = JCOL, JCOL+NPIV-1 GLOB2LOC_SOL(abs(IW(JJ))) = & IPOSINRHSINTR_SOL+JJ-JCOL+1 END DO IPOSINRHSINTR_SOL = IPOSINRHSINTR_SOL + NPIV ELSE IF (GLOB2LOC_SOL(ABSJCOL).LT.0) THEN DO JJ = JCOL, JCOL+NPIV-1 GLOB2LOC_SOL(abs(IW(JJ)))= & -(GLOB2LOC_SOL(abs(IW(JJ)))) END DO ELSE GO_UP = .FALSE. END IF END IF END IF IF(DAD(ISTEP).NE.0) THEN ISTEP = STEP(DAD(ISTEP)) ELSE GO_UP = .FALSE. END IF END DO END DO END IF NB_FS_IN_RHSINTR_TOT = IPOSINRHSINTR_SOL IF (NSLAVES.NE.1) THEN DO I = 1, Lnodes_FWD ISTEP = STEP(nodes_FWD(I)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = NPIV, LIELL-1-KEEP(253) IF(GLOB2LOC_RHS(IW(J1+JJ)).EQ.0) THEN IPOSINRHSINTR_RHS = IPOSINRHSINTR_RHS + 1 GLOB2LOC_RHS(IW(JJ+J1)) = -IPOSINRHSINTR_RHS END IF END DO END IF IF(DAD(ISTEP).GT.0) THEN OLDISTEP=ISTEP ISTEP = STEP(DAD(ISTEP)) DAD(OLDISTEP)=-DAD(OLDISTEP) ELSE GO_UP = .FALSE. END IF END DO END DO DAD=ABS(DAD) IF(GLOB2LOC_SOL_ALLOC) THEN DO I=1, Lnodes_BWD ISTEP = STEP(nodes_BWD(I)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = NPIV, LIELL-1-KEEP(253) IF(GLOB2LOC_SOL(IW(JCOL+JJ)).EQ.0) THEN IPOSINRHSINTR_SOL = IPOSINRHSINTR_SOL + 1 GLOB2LOC_SOL(IW(JCOL+JJ)) = -IPOSINRHSINTR_SOL END IF END DO END IF IF(DAD(ISTEP).GT.0) THEN OLDISTEP=ISTEP ISTEP = STEP(DAD(ISTEP)) DAD(OLDISTEP)=-DAD(OLDISTEP) ELSE GO_UP = .FALSE. END IF END DO END DO DAD=ABS(DAD) END IF ENDIF NBENT_RHSINTR_ROW = IPOSINRHSINTR_RHS NBENT_RHSINTR_COL = IPOSINRHSINTR_SOL NBENT_RHSINTR = max(NBENT_RHSINTR_ROW,NBENT_RHSINTR_COL) RETURN END SUBROUTINE SMUMPS_BUILD_GLOB2LOC_NODES_ES MUMPS_5.8.1/src/dfac_process_maprow.F0000664000175000017500000023131615042446440017365 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE DMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW, & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, & LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_BUF USE MUMPS_LOAD USE DMUMPS_LR_DATA_M USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR USE DMUMPS_FAC_FRONT_AUX_M, ONLY : DMUMPS_GET_SIZE_SCHUR_IN_FRONT #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE #if ! defined(NO_FDM_MAPROW) #endif TYPE (MUMPS_ROOT_STRUC ) :: root TYPE (DMUMPS_ROOT_STRUC ) :: roota INTEGER LBUFR, LBUFR_BYTES INTEGER ICNTL( 60 ), KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER COMP INTEGER NSTK( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM, MYID INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER INODE_PERE, ISON INTEGER :: NFS4FATHER INTEGER NBROWS_ALREADY_SENT INTEGER NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE( * ) INTEGER LMAP INTEGER TROW( LMAP ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER NOSLA, I INTEGER I_POSMYIDIN_PERE INTEGER INDICE_PERE INTEGER PDEST, PDEST_MASTER LOGICAL :: LOCAL_ASSEMBLY_TO_BE_DONE INTEGER NROWS_TO_SEND INTEGER PDEST_MASTER_ISON, IPOS_IN_SLAVE LOGICAL DESCLU, SLAVE_ISON LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG INTEGER LP LOGICAL PACKED_CB LOGICAL IS_ERROR_BROADCASTED, IS_ofType5or6 INTEGER ITYPE_SON, TYPESPLIT INTEGER :: KEEP253_LOC INTEGER :: NVSCHUR, NSLAVES_L, NROW_L, IROW_L, NASS_L, NELIM_L LOGICAL :: CB_IS_LR INTEGER :: IWXXF_HANDLER DOUBLE PRECISION :: ADummy(1) DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: IACHK, RECSIZE #if ! defined(NO_FDM_MAPROW) INTEGER :: INFO_TMP(2) #endif INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM_LOC IS_ERROR_BROADCASTED = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) ITYPE_SON = MUMPS_TYPENODE( PROCNODE_STEPS(STEP(ISON)), & KEEP(199) ) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 #if ! defined(NO_FDM_MAPROW) #endif ALLOCATE(SLAVES_PERE(0:max(1,NSLAVES_PERE)), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) THEN write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in DMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 endif IF (NSLAVES_PERE.GT.0) &SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) THEN write(LP,*) MYID, & ' : PB allocation NBROW in DMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 670 endif LMAP_LOC = LMAP ALLOCATE(MAP(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) THEN write(LP,*) MYID, ' : PB allocation LMAP in DMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = LMAP GOTO 680 endif MAP( 1 : LMAP ) = TROW( 1 : LMAP ) PDEST_MASTER_ISON = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) SLAVE_ISON = PDEST_MASTER_ISON .NE. MYID IF (SLAVE_ISON) THEN IF ( PTRIST(STEP( ISON )) .EQ. 0 ) THEN CALL DMUMPS_TREAT_DESCBAND( ISON, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END IF #if ! defined(NO_FDM_MAPROW) IF ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) & THEN INFO_TMP=0 CALL MUMPS_FMRD_SAVE_MAPROW( & IW(PTRIST(STEP(ISON))+XXA), & INODE_PERE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER, & SLAVES_PERE(1:NSLAVES_PERE), & MAP, & INFO_TMP) IF (INFO_TMP(1) < 0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF GOTO 670 ELSE GOTO 10 ENDIF #endif DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END DO ENDIF #if ! defined(NO_FDM_MAPROW) 10 CONTINUE #endif IF ( NSLAVES_PERE .EQ. 0 ) THEN NBROW( 0 ) = LMAP_LOC ELSE DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) NBROW( NOSLA ) = NBROW( NOSLA ) + 1 END DO DO I = 1, NSLAVES_PERE NBROW(I)=NBROW(I)+NBROW(I-1) ENDDO ENDIF ALLOCATE(PERM_LOC(LMAP_LOC), stat=allocok) IF (allocok .GT. 0) THEN IF (LP.GT.0) THEN write(LP,*) MYID,': PB allocation PERM_LOC in DMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 670 ENDIF KEEP253_LOC = 0 DO I = LMAP_LOC, 1, -1 INDICE_PERE = MAP( I ) IF (INDICE_PERE > NFRONT_PERE - KEEP(253)) THEN KEEP253_LOC = KEEP253_LOC + 1 ENDIF CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) PERM_LOC( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO IF ((KEEP(114).EQ.1) .AND. (KEEP(50).EQ.2) .AND. & (KEEP(116).GT.0) .AND. ((LMAP_LOC-KEEP253_LOC).GT.0) & ) THEN IF (ITYPE_SON.EQ.1) THEN NELIM_L = IW(PTLUST(STEP(ISON))+1+KEEP(IXSZ)) NASS_L = NELIM_L + & IW(PTLUST(STEP(ISON))+3+KEEP(IXSZ)) IROW_L = PTLUST(STEP(ISON))+6+KEEP(IXSZ)+NASS_L NROW_L = LMAP_LOC ELSE NROW_L = LMAP_LOC NSLAVES_L = IW( PTRIST(STEP( ISON )) + 5 + KEEP(IXSZ) ) IROW_L = PTRIST(STEP(ISON)) + 6 + NSLAVES_L + KEEP(IXSZ) ENDIF CALL DMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NROW_L-KEEP253_LOC, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR ) ELSE NVSCHUR = 0 ENDIF PDEST_MASTER = SLAVES_PERE(0) I_POSMYIDIN_PERE = -99999 LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. DO I = 0, NSLAVES_PERE IF (SLAVES_PERE(I) .EQ. MYID) THEN I_POSMYIDIN_PERE = I LOCAL_ASSEMBLY_TO_BE_DONE = .TRUE. #if ! defined(NO_FDM_DESCBAND) IF (PTRIST(STEP(INODE_PERE)) .EQ. 0 & .AND. MYID .NE. PDEST_MASTER) THEN CALL DMUMPS_TREAT_DESCBAND( INODE_PERE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF #endif ENDIF END DO IF (KEEP(120).NE.0 .AND. LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL DMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, LPTRAR, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 CB_IS_LR = (IW(PTRIST(STEP(ISON))+XXLR).EQ.1 .OR. & IW(PTRIST(STEP(ISON))+XXLR).EQ.3) IWXXF_HANDLER = IW(PTRIST(STEP(ISON))+XXF) DO I = NSLAVES_PERE, 0, -1 PDEST = SLAVES_PERE( I ) IF ( PDEST .NE. MYID ) THEN DESCLU = .FALSE. NBROWS_ALREADY_SENT = 0 IF (CB_IS_LR) THEN NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ENDIF IF (I == NSLAVES_PERE) THEN NROWS_TO_SEND=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_SEND=NBROW(I+1)-NBROW(I) ENDIF PACKED_CB=(IW(PTRIST(STEP(ISON))+XXS).EQ.S_CB1COMP) IERR = -1 DO WHILE (IERR .EQ. -1) IF ( IW ( PTRIST(STEP(ISON) )+KEEP(IXSZ) ) & .GT. N + KEEP(253) ) THEN WRITE(*,*) MYID,': Internal error in Maplig' WRITE(*,*) MYID,': PTRIST(STEP(ISON))/N=', & PTRIST(STEP(ISON)), N WRITE(*,*) MYID,': I, NBROW(I)=',I, NBROW(I) WRITE(*,*) MYID,': NSLAVES_PERE=',NSLAVES_PERE WRITE(*,*) MYID,': ISON, INODE_PERE=',ISON,INODE_PERE WRITE(*,*) MYID,': Son header=', & IW(PTRIST(STEP(ISON)): PTRIST(STEP(ISON))+5+KEEP(IXSZ)) CALL MUMPS_ABORT() END IF IF (NROWS_TO_SEND .EQ. 0 .AND. PDEST.NE.PDEST_MASTER) THEN IERR = 0 CYCLE ENDIF IF (CB_IS_LR) THEN CALL DMUMPS_BUF_SEND_CONTRIB_TYPE2( NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, ISON, & NROWS_TO_SEND, LMAP_LOC, MAP, & min(LMAP_LOC,NBROW(I)), & IW( PTRIST(STEP(ISON))), & ADummy, 1_8, & I, PDEST, PDEST_MASTER, & COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PACKED_CB, & KEEP253_LOC, NVSCHUR, & ITYPE_SON, MYID ) ELSE CALL DMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) CALL DMUMPS_BUF_SEND_CONTRIB_TYPE2( NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, ISON, & NROWS_TO_SEND, LMAP_LOC, MAP, & min(LMAP_LOC,NBROW(I)), & IW( PTRIST(STEP(ISON))), & SON_A(IACHK:IACHK+RECSIZE-1_8), & RECSIZE, & I, PDEST, PDEST_MASTER, & COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PACKED_CB, & KEEP253_LOC, NVSCHUR, & ITYPE_SON, MYID) ENDIF IF ( IERR .EQ. -2 ) THEN IFLAG = -17 IF (LP .GT. 0) THEN WRITE(LP,*) & "FAILURE: SEND BUFFER TOO SMALL IN DMUMPS_MAPLIG" ENDIF IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * IW(PTRIST(STEP(ISON))+KEEP(IXSZ)) & * KEEP( 35 ) GO TO 600 END IF IF ( IERR .EQ. -3 ) THEN IF (LP .GT. 0) THEN WRITE(LP,*) & "FAILURE: RECV BUFFER TOO SMALL IN DMUMPS_MAPLIG" ENDIF IFLAG = -20 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * IW(PTRIST(STEP(ISON))+KEEP(IXSZ)) & * KEEP( 35 ) GOTO 600 ENDIF IF (KEEP(219).NE.0) THEN IF ( IERR .EQ. -4 ) THEN IFLAG = -13 IERROR = NFS4FATHER IF (LP .GT. 0) THEN WRITE(LP, *) & "FAILURE: MAX_ARRAY allocation failed IN DMUMPS_MAPLIG" ENDIF GO TO 600 END IF END IF IF ( IERR .EQ. -1 ) THEN IF (LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL DMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, & LPTRAR, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ELSE BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE,LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED=.TRUE. GOTO 600 ENDIF IF (.NOT. MESSAGE_RECEIVED) THEN CALL MUMPS_USLEEP(1000) ENDIF END IF END IF ENDDO ENDIF END DO IF (LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL DMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, LPTRAR, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF IF (CB_IS_LR) THEN IF (IWXXF_HANDLER.LE.0) CALL MUMPS_ABORT() CALL DMUMPS_BLR_FREE_CB_LRB(IWXXF_HANDLER, & .FALSE., KEEP8, KEEP(34)) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN CALL DMUMPS_BLR_END_FRONT(IWXXF_HANDLER, IFLAG, KEEP8, & KEEP(34)) ENDIF ENDIF IF (KEEP(214) .EQ. 2) THEN CALL DMUMPS_STACK_BAND( N, ISON, & PTRIST, PTRAST, PTLUST, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, & COMM, KEEP,KEEP8, DKEEP, ITYPE_SON ) IF (IFLAG .LT. 0) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF CALL DMUMPS_FREE_BAND( N, ISON, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, & STEP, MYID, KEEP, KEEP8, ITYPE_SON &) 600 CONTINUE DEALLOCATE(PERM_LOC) 670 CONTINUE DEALLOCATE(MAP) 680 CONTINUE DEALLOCATE(NBROW) DEALLOCATE(SLAVES_PERE) 700 CONTINUE IF (IFLAG .LT. 0 .AND. .NOT. IS_ERROR_BROADCASTED) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE DMUMPS_MAPLIG SUBROUTINE DMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW, & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, & LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_BUF USE MUMPS_LOAD USE DMUMPS_LR_TYPE USE MUMPS_LR_STATS USE DMUMPS_FAC_FRONT_AUX_M, ONLY : DMUMPS_GET_SIZE_SCHUR_IN_FRONT USE DMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR & , DMUMPS_DM_FREE_BLOCK IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER ICNTL( 60 ), KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER COMP INTEGER IFLAG, IERROR, COMM, MYID INTEGER LPOOL, LEAF INTEGER INODE_PERE, ISON INTEGER NFS4FATHER DOUBLE PRECISION, POINTER, DIMENSION(:) :: M_ARRAY LOGICAL :: M_ARRAY_RETRIEVED INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE(NSLAVES_PERE) INTEGER NELIM, LMAP, TROW( LMAP ), NASS DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPTRAR, NELT INTEGER IW( LIW ) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ) INTEGER NSTK( KEEP(28) ), ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PERM(N) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) 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 NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT INTEGER INDICE_PERE INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER PDEST, PDEST_MASTER, NFRONT LOGICAL SAME_PROC, DESCLU INTEGER(8) :: IACHK, POSROW, ASIZE, RECSIZE DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYNSIZE INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND, & NPIV, NROWS_TO_STACK, II, IROW_SON, & IPOS_IN_SLAVE, DECR, ITYPE_SON INTEGER NBCOLS_EFF LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL PACKED_CB LOGICAL :: CB_IS_LR INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR_COLS, NB_BLR_ROWS, & NB_BLR_SHIFT, PANEL2DECOMPRESS, & CURRENT_PANEL_SIZE, PANEL_BEG_OFFSET, & NROWS_ALREADY_STACKED, NROWS_TO_STACK_LOC INTEGER :: ICOL_BEG, ICOL_END INTEGER :: IROW_BEG, IROW_END INTEGER :: IBLOCK, MAXI_CLUSTER DOUBLE PRECISION :: PROMOTE_COST INTEGER :: NVSCHUR, IROW_L INTEGER(8) :: LA_TEMP DOUBLE PRECISION :: ADummy(1) DOUBLE PRECISION, ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: LRB TYPE (LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER :: XXG_STATUS INCLUDE 'mumps_headers.h' DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM_LOC LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 if (NSLAVES_PERE.le.0) then write(6,*) ' error 2 in maplig_fils_niv1 ', NSLAVES_PERE CALL MUMPS_ABORT() endif ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) IF (allocok .GT. 0) THEN IF (LP > 0) & write(LP,*) MYID, & ' : PB allocation NBROW in DMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF ALLOCATE(SLAVES_PERE(0:NSLAVES_PERE), stat =allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in DMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) LMAP_LOC = LMAP ALLOCATE(MAP(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation LMAP in DMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = LMAP_LOC GOTO 700 endif MAP( 1 : LMAP_LOC ) = TROW( 1 : LMAP_LOC ) DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO IF (NSLAVES_PERE == 0) THEN NBROW(0) = LMAP_LOC ELSE DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) NBROW( NOSLA ) = NBROW( NOSLA ) + 1 END DO DO I = 1, NSLAVES_PERE NBROW(I)=NBROW(I)+NBROW(I-1) ENDDO ENDIF ALLOCATE(PERM_LOC(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) THEN write(LP,*) MYID, & ': PB allocation PERM_LOC in DMUMPS_MAPLIG_FILS_NIV1' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 700 endif ISTCHK = PIMASTER(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) DO I = LMAP_LOC, 1, -1 INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) PERM_LOC( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO PDEST_MASTER = MYID IF ( SLAVES_PERE(0) .NE. MYID ) THEN WRITE(*,*) 'Error 1 in MAPLIG_FILS_NIV1:',MYID, SLAVES_PERE CALL MUMPS_ABORT() END IF PDEST = PDEST_MASTER I = 0 ISTCHK = PIMASTER(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) NELIM = IW(ISTCHK+1+KEEP(IXSZ)) NROW = IW(ISTCHK+2+KEEP(IXSZ)) NPIV = IW(ISTCHK+3+KEEP(IXSZ)) NASS = NPIV+NELIM IF (NPIV.LT.0) THEN write(6,*) ' Error 2 in DMUMPS_MAPLIG_FILS_NIV1 ', NPIV CALL MUMPS_ABORT() ENDIF NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) NFRONT = NPIV + NBCOLS PACKED_CB=(IW(PTRIST(STEP(ISON))+XXS) .eq. S_CB1COMP) IF (I == NSLAVES_PERE) THEN NROWS_TO_STACK=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_STACK=NBROW(I+1)-NBROW(I) ENDIF IF ((KEEP(114).EQ.1) .AND. (KEEP(50).EQ.2) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) + NASS CALL DMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR ) ELSE NVSCHUR = 0 ENDIF DECR=1 IW(PTLUST(STEP(INODE_PERE))+XXNBPR) = & IW(PTLUST(STEP(INODE_PERE))+XXNBPR) - DECR IW(PTRIST(STEP(ISON))+XXNBPR) = & IW(PTRIST(STEP(ISON))+XXNBPR) - DECR CB_IS_LR = (IW(ISTCHK+XXLR).EQ.1 .OR. & IW(ISTCHK+XXLR).EQ.3) NROWS_ALREADY_STACKED = 0 IF (CB_IS_LR) THEN 100 CONTINUE IF (NROWS_TO_STACK.GT.0) THEN PANEL_BEG_OFFSET = 0 CALL DMUMPS_BLR_RETRIEVE_CB_LRB( & IW(ISTCHK+XXF), CB_LRB) CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR) NB_BLR_ROWS = size(BEGS_BLR) - 1 CALL DMUMPS_BLR_RETRIEVE_NB_PANELS(IW(ISTCHK+XXF), & NB_BLR_SHIFT) PANEL2DECOMPRESS = -1 DO II=NB_BLR_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR(II+1)-1-NASS.GT. & NROWS_ALREADY_STACKED+NBROW(I)-1) THEN PANEL2DECOMPRESS = II EXIT ENDIF ENDDO IF (PANEL2DECOMPRESS.EQ.-1) THEN write(*,*) 'Internal error: PANEL2DECOMPRESS not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR) - 1 ELSE NB_BLR_COLS = PANEL2DECOMPRESS ENDIF CURRENT_PANEL_SIZE = BEGS_BLR(PANEL2DECOMPRESS+1) & - BEGS_BLR(PANEL2DECOMPRESS) PANEL_BEG_OFFSET = NBROW(I) + NROWS_ALREADY_STACKED & - BEGS_BLR(PANEL2DECOMPRESS) + NASS NROWS_TO_STACK_LOC = & min(NROWS_TO_STACK-NROWS_ALREADY_STACKED, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) MAXI_CLUSTER = 1 DO IBLOCK=1,NB_BLR_COLS-NB_BLR_SHIFT LRB => CB_LRB(PANEL2DECOMPRESS-NB_BLR_SHIFT,IBLOCK) MAXI_CLUSTER = max(MAXI_CLUSTER, LRB%N) ENDDO LA_TEMP = NROWS_TO_STACK_LOC*MAXI_CLUSTER #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(A_TEMP, LRB, II, IBLOCK, ICOL_BEG, ICOL_END, !$OMP& allocok, PROMOTE_COST, IROW_SON, INDICE_PERE, !$OMP& POSROW, NBCOLS_EFF, IROW_BEG, IROW_END, !$OMP& INDICE_PERE_ARRAY_ARG, NOSLA, IPOS_IN_SLAVE) #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 GOTO 550 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP DO SCHEDULE(dynamic,1) #endif DO IBLOCK=1,NB_BLR_COLS-NB_BLR_SHIFT IF (IFLAG.LT.0) CYCLE ICOL_BEG = 1 DO II = 1,IBLOCK-1 LRB => CB_LRB(PANEL2DECOMPRESS-NB_BLR_SHIFT,II) ICOL_BEG = ICOL_BEG + LRB%N ENDDO LRB => CB_LRB(PANEL2DECOMPRESS-NB_BLR_SHIFT,IBLOCK) IF (LRB%ISLR .AND. LRB%K.EQ.0) CYCLE IROW_BEG = PANEL_BEG_OFFSET+1 IROW_END = PANEL_BEG_OFFSET+NROWS_TO_STACK_LOC IF (LRB%ISLR) THEN CALL dgemm('T','T', LRB%N, NROWS_TO_STACK_LOC, LRB%K, & ONE, LRB%R(1,1), LRB%K, LRB%Q(IROW_BEG,1), & LRB%M, ZERO, A_TEMP(1), LRB%N) PROMOTE_COST = 2.0D0*LRB%N*NROWS_TO_STACK_LOC*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE DO II = IROW_BEG, IROW_END A_TEMP( 1+(II-IROW_BEG)*LRB%N : (II-IROW_BEG+1)*LRB%N ) & = LRB%Q(II,1:LRB%N) ENDDO ENDIF CALL DMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON=PERM_LOC(NBROW(I)+II-1) INDICE_PERE = MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF (PACKED_CB) THEN POSROW = IACHK + & int(NELIM+IROW_SON,8)*int(NELIM+IROW_SON-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+IROW_SON-1,8)*int(NBCOLS,8) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = NELIM + IROW_SON ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE ICOL_END = min(ICOL_BEG+LRB%N-1, NBCOLS_EFF) CALL DMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, ICOL_END-ICOL_BEG+1, & INDICE_PERE_ARRAY_ARG, & A_TEMP(1+(II-NROWS_ALREADY_STACKED-1)*LRB%N), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS,ICOL_BEG) ENDDO ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO #endif IF (IFLAG.LT.0) GOTO 550 deallocate(A_TEMP) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) 550 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 NROWS_ALREADY_STACKED = NROWS_ALREADY_STACKED & + NROWS_TO_STACK_LOC IF (NROWS_ALREADY_STACKED.LT.NROWS_TO_STACK) THEN GOTO 100 ENDIF ENDIF ELSE CALL DMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK IROW_SON=PERM_LOC(NBROW(I)+II-1) INDICE_PERE = MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF (PACKED_CB) THEN POSROW = IACHK + & int(NELIM+IROW_SON,8)*int(NELIM+IROW_SON-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+IROW_SON-1,8)*int(NBCOLS,8) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = NELIM + IROW_SON ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE CALL DMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS_EFF,1) ENDDO ENDIF IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2 & .AND. NFS4FATHER .GT. 0) THEN IF (CB_IS_LR) THEN CALL DMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW(ISTCHK+XXF), M_ARRAY) M_ARRAY_RETRIEVED = .TRUE. ELSE IF (PACKED_CB) THEN POSROW = IACHK & + int(NELIM+NBROW(1),8)*int(NELIM+NBROW(1)-1,8)/2_8 ASIZE = int(LMAP_LOC+NELIM,8)*int(NELIM+LMAP_LOC+1,8)/2_8 & - int(NELIM+NBROW(1),8)*int(NELIM+NBROW(1)-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+NBROW(1)-1,8)*int(NBCOLS,8) ASIZE = int(LMAP_LOC-NBROW(1)+1,8) * int(NBCOLS,8) ENDIF CALL DMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP > 0) WRITE(LP,*) MYID, & ": PB allocation MAX_ARRAY during DMUMPS_MAPLIG_FILS_NIV1" IFLAG=-13 IERROR=NFS4FATHER GOTO 700 ENDIF IF ( LMAP_LOC-NBROW(1)+1-KEEP(253)-NVSCHUR.GT. 0 ) THEN CALL DMUMPS_COMPUTE_MAXPERCOL( & SON_A(POSROW),ASIZE,NBCOLS, & LMAP_LOC-NBROW(1)+1-KEEP(253)-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB, & NELIM+NBROW(1)) ELSE CALL DMUMPS_SETMAXTOZERO(BUF_MAX_ARRAY, & NFS4FATHER) ENDIF M_ARRAY => BUF_MAX_ARRAY M_ARRAY_RETRIEVED = .FALSE. ENDIF CALL DMUMPS_ASM_MAX(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & M_ARRAY(1), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB,MYID, KEEP,KEEP8) IF ( M_ARRAY_RETRIEVED ) & CALL DMUMPS_BLR_FREE_M_ARRAY ( IW(ISTCHK+XXF) ) ENDIF ENDIF IF (IW(PTRIST(STEP(ISON))+XXNBPR) .EQ. 0 & ) THEN ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF (SAME_PROC) THEN CALL DMUMPS_RESTORE_INDICES(N, ISON, INODE_PERE, & IWPOSCB, PIMASTER, PTLUST, IW, LIW, STEP, & KEEP,KEEP8) ENDIF ENDIF IF ( IW(PTLUST(STEP(INODE_PERE))+XXNBPR) .EQ. 0 & ) THEN CALL DMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, INODE_PERE+N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 DO I = 0, NSLAVES_PERE PDEST = SLAVES_PERE( I ) IF ( PDEST .NE. MYID ) THEN NBROWS_ALREADY_SENT = 0 IF (CB_IS_LR) THEN NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ENDIF 95 CONTINUE NFRONT = IW(PIMASTER(STEP(ISON))+KEEP(IXSZ)) NELIM = IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) DESCLU = .TRUE. IF (I == NSLAVES_PERE) THEN NROWS_TO_SEND=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_SEND=NBROW(I+1)-NBROW(I) ENDIF IF ( NROWS_TO_SEND .EQ. 0) CYCLE ITYPE_SON = MUMPS_TYPENODE( PROCNODE_STEPS(STEP(ISON)), & KEEP(199) ) IF (CB_IS_LR) THEN CALL DMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NROWS_TO_SEND, LMAP_LOC, & MAP, min(LMAP_LOC,NBROW(I)), & IW(PIMASTER(STEP(ISON))), & ADummy, 1_8, & I, PDEST, PDEST_MASTER, COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP(253), NVSCHUR, & ITYPE_SON, MYID ) ELSE CALL DMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) CALL DMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NROWS_TO_SEND, LMAP_LOC, & MAP, min(LMAP_LOC,NBROW(I)), & IW(PIMASTER(STEP(ISON))), & SON_A(IACHK:IACHK+RECSIZE-1_8), & RECSIZE, & I, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP(253), NVSCHUR, & ITYPE_SON, MYID) ENDIF IF ( IERR .EQ. -2 ) THEN IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING DMUMPS_MAPLIG_FILS_NIV1" IFLAG = -17 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * KEEP( 35 ) GO TO 700 END IF IF ( IERR .EQ. -3 ) THEN IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING DMUMPS_MAPLIG_FILS_NIV1" IFLAG = -20 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * KEEP( 35 ) GO TO 700 ENDIF IF (KEEP(219).NE.0) THEN IF ( IERR .EQ. -4 ) THEN IFLAG = -13 IERROR = BUF_LMAX_ARRAY IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, MAX_ARRAY ALLOC FAILED DURING DMUMPS_MAPLIG_FILS_NIV1" GO TO 700 ENDIF ENDIF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 GO TO 95 END IF END IF END DO ISTCHK = PTRIST(STEP(ISON)) PTRIST(STEP( ISON )) = -77777777 IF ( IW(ISTCHK+KEEP(IXSZ)) .GE. 0 ) THEN WRITE(*,*) 'error 3 in DMUMPS_MAPLIG_FILS_NIV1' CALL MUMPS_ABORT() ENDIF CALL MUMPS_GETI8(DYNSIZE,IW(ISTCHK+XXD)) XXG_STATUS = IW(ISTCHK+XXG) CALL DMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) IF (DYNSIZE .GT. 0_8) THEN CALL DMUMPS_DM_FREE_BLOCK( XXG_STATUS, SON_A, DYNSIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF GOTO 600 700 CONTINUE CALL DMUMPS_BDC_ERROR(MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF (CB_IS_LR) THEN CALL DMUMPS_BLR_FREE_CB_LRB(IW(ISTCHK+XXF), & .FALSE., KEEP8, KEEP(34)) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN CALL DMUMPS_BLR_END_FRONT(IW(ISTCHK+XXF), IFLAG, KEEP8, & KEEP(34)) ENDIF ENDIF IF (allocated(NBROW)) DEALLOCATE(NBROW) IF (allocated(MAP)) DEALLOCATE(MAP) IF (allocated(PERM_LOC)) DEALLOCATE(PERM_LOC) IF (allocated(SLAVES_PERE)) DEALLOCATE(SLAVES_PERE) RETURN END SUBROUTINE DMUMPS_MAPLIG_FILS_NIV1 SUBROUTINE DMUMPS_LOCAL_ASSEMBLY_TYPE2(I, PDEST, MYID, & PDEST_MASTER, ISON, IFATH, NSLAVES_PERE, NASS_PERE, & NFRONT_PERE, NFS4FATHER, LMAP_LOC, MAP, & NBROW, PERM, IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, & IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, & LPTRAR, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & SON_NIV, LRGROUPS) USE DMUMPS_BUF, ONLY: DMUMPS_BUF_MAX_ARRAY_MINSIZE, & BUF_MAX_ARRAY USE DMUMPS_LR_TYPE USE MUMPS_LR_STATS USE DMUMPS_LR_DATA_M USE MUMPS_LOAD, ONLY : MUMPS_LOAD_POOL_UPD_NEW_POOL USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR & , DMUMPS_DM_SET_PTR, DMUMPS_DM_FREE_BLOCK IMPLICIT NONE INTEGER ICNTL(60) INTEGER, intent(in) :: I, PDEST, MYID, PDEST_MASTER, IFATH, ISON INTEGER, intent(in) :: N, SLAVEF INTEGER, intent(in) :: NSLAVES_PERE, NASS_PERE, NFRONT_PERE INTEGER, intent(in) :: NFS4FATHER INTEGER, intent(in) :: KEEP(500), STEP(N) INTEGER, intent(in) :: LMAP_LOC INTEGER, intent(in) :: NBROW(0:NSLAVES_PERE) INTEGER, intent(in) :: MAP(LMAP_LOC), PERM(LMAP_LOC) INTEGER, intent(inout) :: IFLAG, IERROR INTEGER(8), intent(inout) :: KEEP8(150) INTEGER, intent(in) :: LIW, NELT, LPTRAR INTEGER(8), intent(in) :: LA INTEGER(8), intent(inout) :: IPTRLU, LRLU, LRLUS INTEGER, intent(inout) :: IWPOSCB INTEGER, intent(inout) :: IW(LIW) DOUBLE PRECISION, intent(inout) :: A( LA ) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER :: PTRIST(KEEP(28)), PIMASTER(KEEP(28)), ND(KEEP(28)) INTEGER :: PTLUST(KEEP(28)) INTEGER, intent(inout) :: ITLOC(N) INTEGER, intent(in) :: FRTPTR( N+1 ), FRTELT( NELT ) DOUBLE PRECISION, intent(inout) :: OPASSW, OPELIW DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER, intent(in) :: KEEP253_LOC, NVSCHUR INTEGER, intent(in) :: FILS(N), DAD( KEEP(28) ) INTEGER(8), intent(in) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER, intent(in) :: PROCNODE_STEPS( KEEP(28) ), COMM_LOAD INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPOOL INTEGER IPOOL( LPOOL ) LOGICAL, intent(in) :: IS_ofType5or6 INTEGER, intent(in) :: SON_NIV INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INTEGER :: XXG_STATUS INTEGER :: ISTCHK, ISTCHK_LOC, NBCOLS, & NROW, NPIV, NSLSON, & NFRONT, LDA_SON, NROWS_TO_STACK, II, INDICE_PERE, & NOSLA, COLLIST, IPOS_IN_SLAVE, IROW_SON, ITMP, & NBCOLS_EFF, DECR, NELIM INTEGER :: NB_POSTPONED LOGICAL :: PACKED_CB, SAME_PROC INTEGER(8) :: SIZFR, POSROW, SHIFTCB_SON INTEGER(8) :: IACHK INTEGER :: SON_XXS DOUBLE PRECISION, DIMENSION(:), POINTER :: SON_A DOUBLE PRECISION, DIMENSION(:), POINTER :: SON_A_MASTER INTEGER(8) :: DYN_SIZE INTEGER :: IERR, LP INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER :: INBPROCFILS_SON LOGICAL :: CB_IS_LR DOUBLE PRECISION, POINTER, DIMENSION(:) :: M_ARRAY LOGICAL :: M_ARRAY_RETRIEVED INTEGER(8) :: POSELT INTEGER :: IOLDPS, PARPIV_T1 LOGICAL :: LR_ACTIVATED INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL, & BEGS_BLR_STA INTEGER :: NB_BLR_COLS, NB_BLR_ROWS, & NB_COL_SHIFT, PANEL2DECOMPRESS, & CURRENT_PANEL_SIZE, PANEL_BEG_OFFSET, & allocok, NROWS_ALREADY_STACKED, NROWS_TO_STACK_LOC, & NB_ROW_SHIFT, NASS_SHIFT, NCOL_SHIFT, NROW_SHIFT INTEGER :: ICOL_BEG, ICOL_END INTEGER :: IROW_BEG, IROW_END INTEGER :: IBLOCK, MAXI_CLUSTER DOUBLE PRECISION :: PROMOTE_COST INTEGER(8) :: LA_TEMP DOUBLE PRECISION, ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: LRB TYPE (LRB_TYPE), POINTER :: CB_LRB(:,:) DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 IF (I == NSLAVES_PERE) THEN NROWS_TO_STACK = LMAP_LOC - NBROW(I) + 1 ELSE NROWS_TO_STACK = NBROW(I+1) - NBROW(I) ENDIF DECR = 1 IF ( MYID .EQ. PDEST_MASTER ) THEN IW(PTLUST(STEP(IFATH))+XXNBPR) = & IW(PTLUST(STEP(IFATH))+XXNBPR) - DECR IF ( PDEST .EQ. PDEST_MASTER .AND. DECR .NE. 0) THEN IW(PIMASTER(STEP(ISON))+XXNBPR) = & IW(PIMASTER(STEP(ISON))+XXNBPR) - DECR ENDIF ENDIF ISTCHK = PTRIST(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) NROW = IW(ISTCHK+2+KEEP(IXSZ)) NPIV = IW(ISTCHK+3+KEEP(IXSZ)) NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) NFRONT = NPIV + NBCOLS SON_XXS = IW(ISTCHK+XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) CALL DMUMPS_DM_SET_DYNPTR( & SON_XXS, & A, LA, & PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR) CB_IS_LR = (IW(ISTCHK+XXLR).EQ.1 .OR. & IW(ISTCHK+XXLR).EQ.3) IF (CB_IS_LR.AND.IS_ofType5or6) THEN write(*,*) 'Compress CB + Type5or6 fronts not coded yet!!' CALL MUMPS_ABORT() ENDIF NELIM = -9999 IF (CB_IS_LR.AND.(SON_NIV.EQ.1).AND. & KEEP(50).NE.0) THEN ISTCHK_LOC = PTLUST(STEP(ISON)) NELIM = IW(ISTCHK_LOC+1+KEEP(IXSZ)) NPIV = IW(ISTCHK_LOC+3+KEEP(IXSZ)) NFRONT = IW(ISTCHK_LOC+2+KEEP(IXSZ)) NROW = NFRONT - NPIV NFRONT = NBCOLS NPIV = 0 ENDIF IF (CB_IS_LR) THEN LDA_SON = NBCOLS SHIFTCB_SON = -9999 ELSE IF (SON_XXS.EQ.S_NOLCBCONTIG ) THEN LDA_SON = NBCOLS SHIFTCB_SON = int(NPIV,8)*int(NROW,8) ELSE IF (IW(ISTCHK+XXS).EQ.S_NOLCLEANED) THEN LDA_SON = NBCOLS SHIFTCB_SON = 0_8 ELSE LDA_SON = NFRONT SHIFTCB_SON = int(NPIV,8) ENDIF ENDIF IF (PDEST .NE. PDEST_MASTER) THEN IF ( KEEP(55) .eq. 0 ) THEN CALL DMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, IFATH, IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ELSE CALL DMUMPS_ELT_ASM_S_2_S_INIT(NELT, FRTPTR, FRTELT, & N, IFATH, IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP, KEEP8, MYID, LRGROUPS ) ENDIF ENDIF NROWS_ALREADY_STACKED = 0 100 CONTINUE NROWS_TO_STACK_LOC = NROWS_TO_STACK PANEL_BEG_OFFSET = 0 IF (CB_IS_LR) THEN IF (NROWS_TO_STACK.GT.0) THEN CALL DMUMPS_BLR_RETRIEVE_CB_LRB( & IW(ISTCHK+XXF), CB_LRB) IF (SON_NIV.EQ.1) THEN CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR_ROW) CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_DYN( & IW(ISTCHK+XXF), BEGS_BLR_COL) NB_BLR_ROWS = size(BEGS_BLR_ROW) - 1 CALL DMUMPS_BLR_RETRIEVE_NB_PANELS(IW(ISTCHK+XXF), & NB_COL_SHIFT) NB_ROW_SHIFT = NB_COL_SHIFT NASS_SHIFT = BEGS_BLR_ROW(NB_ROW_SHIFT+1)-1 ELSE CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR_STA) NB_BLR_ROWS = size(BEGS_BLR_STA) - 2 BEGS_BLR_ROW => BEGS_BLR_STA(2:NB_BLR_ROWS+2) CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_C( & IW(ISTCHK+XXF), BEGS_BLR_COL, & NB_COL_SHIFT) NB_ROW_SHIFT = 0 NASS_SHIFT = 0 ENDIF PANEL2DECOMPRESS = -1 DO II=NB_ROW_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR_ROW(II+1)-1-NASS_SHIFT.GT. & NROWS_ALREADY_STACKED+NBROW(I)-1) THEN PANEL2DECOMPRESS = II EXIT ENDIF ENDDO IF (PANEL2DECOMPRESS.EQ.-1) THEN write(*,*) 'Internal error: PANEL2DECOMPRESS not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR_COL) - 1 ELSEIF (SON_NIV.EQ.1) THEN NB_BLR_COLS = PANEL2DECOMPRESS ELSE NB_BLR_COLS = -1 NCOL_SHIFT = NPIV NROW_SHIFT = NBCOLS-NROW DO II=NB_COL_SHIFT+1,size(BEGS_BLR_COL)-1 IF (BEGS_BLR_COL(II+1)-NCOL_SHIFT.GT. & BEGS_BLR_ROW(PANEL2DECOMPRESS+1)-1+NROW_SHIFT) THEN NB_BLR_COLS = II EXIT ENDIF ENDDO IF (NB_BLR_COLS.EQ.-1) THEN write(*,*) 'Internal error: NB_BLR_COLS not found' CALL MUMPS_ABORT() ENDIF ENDIF CURRENT_PANEL_SIZE = BEGS_BLR_ROW(PANEL2DECOMPRESS+1) & - BEGS_BLR_ROW(PANEL2DECOMPRESS) PANEL_BEG_OFFSET = NBROW(I) + NROWS_ALREADY_STACKED & - BEGS_BLR_ROW(PANEL2DECOMPRESS) + NASS_SHIFT NROWS_TO_STACK_LOC = & min(NROWS_TO_STACK-NROWS_ALREADY_STACKED, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) MAXI_CLUSTER = 1 DO IBLOCK=1,NB_BLR_COLS-NB_COL_SHIFT LRB => CB_LRB(PANEL2DECOMPRESS-NB_ROW_SHIFT,IBLOCK) MAXI_CLUSTER = max(MAXI_CLUSTER, LRB%N) ENDDO LA_TEMP = NROWS_TO_STACK_LOC*MAXI_CLUSTER #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(A_TEMP, LRB, II, IBLOCK, ICOL_BEG, ICOL_END, !$OMP& allocok, PROMOTE_COST, IROW_BEG, IROW_END, IROW_SON, !$OMP& INDICE_PERE, ITMP, POSROW, NBCOLS_EFF, ISTCHK, !$OMP& ISTCHK_LOC, COLLIST, NOSLA, IPOS_IN_SLAVE, !$OMP& INDICE_PERE_ARRAY_ARG) #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 GOTO 550 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP DO SCHEDULE(dynamic,1) #endif DO IBLOCK=1,NB_BLR_COLS-NB_COL_SHIFT IF (IFLAG.LT.0) CYCLE ICOL_BEG = 1 DO II = 1,IBLOCK-1 LRB => CB_LRB(PANEL2DECOMPRESS-NB_ROW_SHIFT,II) ICOL_BEG = ICOL_BEG + LRB%N ENDDO LRB => CB_LRB(PANEL2DECOMPRESS-NB_ROW_SHIFT,IBLOCK) IF (LRB%ISLR .AND. LRB%K.EQ.0) CYCLE IROW_BEG = PANEL_BEG_OFFSET+1 IROW_END = PANEL_BEG_OFFSET+NROWS_TO_STACK_LOC IF (LRB%ISLR) THEN CALL dgemm('T','T', LRB%N, NROWS_TO_STACK_LOC, LRB%K, & ONE, LRB%R(1,1), LRB%K, LRB%Q(IROW_BEG,1), & LRB%M, ZERO, A_TEMP(1), LRB%N) PROMOTE_COST = 2.0D0*LRB%N*NROWS_TO_STACK_LOC*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE DO II = IROW_BEG, IROW_END A_TEMP( 1+(II-IROW_BEG)*LRB%N : & (II-IROW_BEG+1)*LRB%N ) = LRB%Q(II,1:LRB%N) ENDDO ENDIF DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON = PERM(NBROW(I)+II-1) INDICE_PERE=MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IFATH, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF ( PACKED_CB ) THEN ITMP = IROW_SON + NBCOLS - NROW POSROW = IACHK & + int(ITMP,8) * int(ITMP-1,8) / 2_8 & - int(NBCOLS-NROW,8) * int(NBCOLS-NROW+1,8)/2_8 ELSE POSROW = IACHK + SHIFTCB_SON & +int(IROW_SON-1,8)*int(LDA_SON,8) ENDIF IF (PDEST .EQ. 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 ICOL_END = min(ICOL_BEG+LRB%N-1, NBCOLS_EFF) CALL DMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, ICOL_END - ICOL_BEG + 1, & INDICE_PERE_ARRAY_ARG, & A_TEMP(1+(II-NROWS_ALREADY_STACKED-1)*LRB%N), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, NBCOLS, ICOL_BEG ) ELSE ISTCHK = PTRIST(STEP(ISON)) COLLIST = ISTCHK + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) + NROW + NPIV IF ((SON_NIV.EQ.1).AND. KEEP(50).NE.0) THEN ISTCHK_LOC = PTLUST(STEP(ISON)) COLLIST = ISTCHK_LOC + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) & + IW(ISTCHK_LOC+2+KEEP(IXSZ)) & + IW(ISTCHK_LOC+3+KEEP(IXSZ)) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = IROW_SON + NBCOLS - NROW IF (SON_NIV.EQ.1) THEN NBCOLS_EFF = IROW_SON + NBCOLS - (NROW-NELIM) ENDIF ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE ICOL_END = min(ICOL_BEG+LRB%N-1, NBCOLS_EFF) CALL DMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, ICOL_END-ICOL_BEG+1, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST + ICOL_BEG - 1 ), & A_TEMP(1+(II-NROWS_ALREADY_STACKED-1)*LRB%N), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, NBCOLS) ENDIF ENDDO ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO #endif IF (IFLAG.LT.0) GOTO 550 deallocate(A_TEMP) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-LA_TEMP, & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) 550 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) RETURN IF (PDEST .NE. PDEST_MASTER) THEN IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - NROWS_TO_STACK_LOC ENDIF NROWS_ALREADY_STACKED = NROWS_ALREADY_STACKED & + NROWS_TO_STACK_LOC IF (NROWS_ALREADY_STACKED.LT.NROWS_TO_STACK) THEN GOTO 100 ENDIF ENDIF ELSE DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON = PERM(NBROW(I)+II-1) INDICE_PERE=MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IFATH, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF ( PACKED_CB ) THEN ITMP = IROW_SON + NBCOLS - NROW POSROW = IACHK & + int(ITMP,8) * int(ITMP-1,8) / 2_8 & - int(NBCOLS-NROW,8) * int(NBCOLS-NROW+1,8)/2_8 ELSE POSROW = IACHK + SHIFTCB_SON & +int(IROW_SON-1,8)*int(LDA_SON,8) ENDIF IF (PDEST == PDEST_MASTER) THEN IF (KEEP(50).NE.0) THEN NBCOLS_EFF = IROW_SON + NBCOLS - NROW ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE IF ((IS_ofType5or6).AND.(KEEP(50).EQ.0)) THEN CALL DMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON, 1 & ) EXIT ELSE IF ( (KEEP(50).NE.0) .AND. & (.NOT.PACKED_CB).AND.(IS_ofType5or6) ) THEN CALL DMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, & NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON, 1 & ) EXIT ELSE CALL DMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON, 1 ) 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.PACKED_CB) ) & ) & ) THEN CALL DMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), SON_A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - NROWS_TO_STACK EXIT ELSE CALL DMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), SON_A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - 1 ENDIF ENDIF ENDDO ENDIF IF (PDEST.EQ.PDEST_MASTER) THEN IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2 & .AND. NFS4FATHER .GT. 0) THEN IF (CB_IS_LR) THEN CALL DMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW(ISTCHK+XXF), M_ARRAY) M_ARRAY_RETRIEVED = .TRUE. ELSE IF (PACKED_CB) THEN WRITE(*,*) "Error 1 in PARPIV/DMUMPS_MAPLIG" CALL MUMPS_ABORT() ELSE POSROW = IACHK + SHIFTCB_SON+ & int(NBROW(1)-1,8)*int(LDA_SON,8) ENDIF CALL DMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP .GT. 0) THEN WRITE(LP, *) "MAX_ARRAY allocation failed" ENDIF IFLAG=-13 IERROR=NFS4FATHER RETURN ENDIF ITMP=-9999 IF (LMAP_LOC-NBROW(1)+1-KEEP253_LOC-NVSCHUR.NE.0) & THEN CALL DMUMPS_COMPUTE_MAXPERCOL( & SON_A(POSROW), & SIZFR-SHIFTCB_SON-int(NBROW(1)-1,8)*int(LDA_SON,8), & LDA_SON, & LMAP_LOC-NBROW(1)+1-KEEP253_LOC-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB,ITMP) ELSE CALL DMUMPS_SETMAXTOZERO( & BUF_MAX_ARRAY, NFS4FATHER) ENDIF M_ARRAY => BUF_MAX_ARRAY(1:size(BUF_MAX_ARRAY)) M_ARRAY_RETRIEVED = .FALSE. ENDIF CALL DMUMPS_ASM_MAX(N, IFATH, IW, LIW, & A, LA, ISON, NFS4FATHER, & M_ARRAY(1), PTLUST, PTRAST, & STEP, PIMASTER, & OPASSW,IWPOSCB,MYID, KEEP,KEEP8) IF ( M_ARRAY_RETRIEVED ) & CALL DMUMPS_BLR_FREE_M_ARRAY ( IW(ISTCHK+XXF) ) ENDIF ENDIF ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF ( SAME_PROC ) THEN INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR WRITE(*,*) & "Internal error 0 in DMUMPS_LOCAL_ASSEMBLY_TYPE2", & INBPROCFILS_SON, PIMASTER(STEP(ISON)) CALL MUMPS_ABORT() ELSE INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ENDIF IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN IF (SAME_PROC) THEN CALL DMUMPS_RESTORE_INDICES(N, ISON, IFATH, & IWPOSCB, PIMASTER, PTLUST, IW, LIW, STEP, & KEEP,KEEP8) ENDIF IF (SAME_PROC) THEN ISTCHK_LOC = PTRIST(STEP(ISON)) PTRIST(STEP( ISON) ) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_LOC+XXD)) XXG_STATUS = IW(ISTCHK_LOC+XXG) IF (DYN_SIZE .GT. 0_8) THEN CALL DMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), & DYN_SIZE, SON_A_MASTER ) ENDIF CALL DMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., MYID, N, & ISTCHK_LOC, & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) IF (DYN_SIZE .GT. 0_8) THEN CALL DMUMPS_DM_FREE_BLOCK( XXG_STATUS, SON_A_MASTER, & DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF IF ( IW(PTLUST(STEP(IFATH))+XXNBPR) .EQ. 0 & ) THEN IOLDPS = PTLUST(STEP(IFATH)) IF (NSLAVES_PERE.EQ.0) THEN POSELT = PTRAST(STEP(IFATH)) PARPIV_T1 = -999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) NB_POSTPONED = max(NFRONT - ND(STEP(IFATH)),0) CALL DMUMPS_PARPIVT1_SET_NVSCHUR_MAX ( & N, IFATH, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT_PERE, NASS_PERE, LR_ACTIVATED, PARPIV_T1, & NB_POSTPONED ) ENDIF CALL DMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, IFATH+N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF ELSE CALL DMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, IFATH, IW, LIW, & NBROW(I), STEP, PTRIST, ITLOC, RHS_MUMPS, & KEEP,KEEP8) END IF RETURN END SUBROUTINE DMUMPS_LOCAL_ASSEMBLY_TYPE2 MUMPS_5.8.1/src/dana_mtrans.F0000664000175000017500000007771615042446441015651 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C History: C ------- C This maximum transversal set of routines are C based on the work done by Jacko Koster at CERFACS for C his PhD thesis from Institut National Polytechnique de Toulouse C at CERFACS (1995-1997) and includes modifications provided C by the author as well as work done by Stephane Pralet C first at CERFACS during his PhD thesis (2003-2004) then C at INPT-IRIT (2004-2005) during his post-doctoral position. C C The main research publication references for this work are: C [1] I. S. Duff, (1981), C "Algorithm 575. Permutations for a zero-free diagonal", C ACM Trans. Math. Software 7(3), 387-390. C [2] I. S. Duff and J. Koster, (1998), C "The design and use of algorithms for permuting large C entries to the diagonal of sparse matrices", C SIAM J. Matrix Anal. Appl., vol. 20, no. 4, pp. 889-901. C [3] I. S. Duff and J. Koster, (2001), C "On algorithms for permuting large entries to the diagonal C of sparse matrices", C SIAM J. Matrix Anal. Appl., vol. 22, no. 4, pp. 973-996. C SUBROUTINE DMUMPS_MTRANSI(ICNTL,CNTL) IMPLICIT NONE INTEGER NICNTL, NCNTL PARAMETER (NICNTL=10, NCNTL=10) INTEGER ICNTL(NICNTL) DOUBLE PRECISION CNTL(NCNTL) INTEGER I ICNTL(1) = 6 ICNTL(2) = 6 ICNTL(3) = -1 ICNTL(4) = -1 ICNTL(5) = 0 DO 10 I = 6,NICNTL ICNTL(I) = 0 10 CONTINUE CNTL(1) = 0.0D0 CNTL(2) = 0.0D0 DO 20 I = 3,NCNTL CNTL(I) = 0.0D0 20 CONTINUE RETURN END SUBROUTINE DMUMPS_MTRANSI SUBROUTINE DMUMPS_MTRANSB & (M,N,NE,IP,IRN,A,IPERM,NUM,JPERM,PR,Q,L,D,RINF) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: NE INTEGER :: IRN(NE),IPERM(M),JPERM(N),Q(M),L(M) INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER(8), INTENT(OUT) :: PR(N) DOUBLE PRECISION :: A(NE) DOUBLE PRECISION :: D(M), RINF INTEGER :: I,II,J,JJ,JORD,Q0,QLEN,IDUM,JDUM,ISP,JSP, & I0,UP,LOW, IK INTEGER(8) :: K,KK,KK1,KK2 DOUBLE PRECISION CSP,DI,DNEW,DQ0,AI,A0,BV,TBV,RLX DOUBLE PRECISION ZERO,MINONE,ONE PARAMETER (ZERO=0.0D0,MINONE=-1.0D0,ONE=1.0D0) INTRINSIC abs,min EXTERNAL DMUMPS_MTRANSD, DMUMPS_MTRANSE, & DMUMPS_MTRANSF, DMUMPS_MTRANSX RLX = D(1) NUM = 0 BV = RINF DO 10 I = 1,N JPERM(I) = 0 PR(I) = IP(I) 10 CONTINUE DO 12 I = 1,M IPERM(I) = 0 D(I) = ZERO 12 CONTINUE DO 30 J = 1,N A0 = MINONE DO 20 K = IP(J),IP(J+1)-1_8 I = IRN(K) AI = abs(A(K)) IF (AI.GT.D(I)) D(I) = AI IF (JPERM(J).NE.0) GO TO 20 IF (AI.GE.BV) THEN A0 = BV IF (IPERM(I).NE.0) GO TO 20 JPERM(J) = I IPERM(I) = J NUM = NUM + 1 ELSE IF (AI.LE.A0) GO TO 20 A0 = AI I0 = I ENDIF 20 CONTINUE IF (A0.NE.MINONE .AND. A0.LT.BV) THEN BV = A0 IF (IPERM(I0).NE.0) GO TO 30 IPERM(I0) = J JPERM(J) = I0 NUM = NUM + 1 ENDIF 30 CONTINUE IF (M.EQ.N) THEN DO 35 I = 1,M BV = min(BV,D(I)) 35 CONTINUE ENDIF IF (NUM.EQ.N) GO TO 1000 DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 DO 50 K = IP(J),IP(J+1)-1_8 I = IRN(K) AI = abs(A(K)) IF (AI.LT.BV) GO TO 50 IF (IPERM(I).EQ.0) GO TO 90 JJ = IPERM(I) KK1 = PR(JJ) KK2 = IP(JJ+1) - 1_8 IF (KK1.GT.KK2) GO TO 50 DO 70 KK = KK1,KK2 II = IRN(KK) IF (IPERM(II).NE.0) GO TO 70 IF (abs(A(KK)).GE.BV) GO TO 80 70 CONTINUE PR(JJ) = KK2 + 1_8 50 CONTINUE GO TO 95 80 JPERM(JJ) = II IPERM(II) = JJ PR(JJ) = KK + 1_8 90 NUM = NUM + 1 JPERM(J) = I IPERM(I) = J PR(J) = K + 1_8 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = MINONE L(I) = 0 99 CONTINUE TBV = BV * (ONE-RLX) DO 100 JORD = 1,N IF (JPERM(JORD).NE.0) GO TO 100 QLEN = 0 LOW = M + 1 UP = M + 1 CSP = MINONE J = JORD PR(J) = -1_8 DO 115 K = IP(J),IP(J+1)-1_8 I = IRN(K) DNEW = abs(A(K)) IF (CSP.GE.DNEW) GO TO 115 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = I JSP = J IF (CSP.GE.TBV) GO TO 160 ELSE D(I) = DNEW IF (DNEW.GE.TBV) THEN LOW = LOW - 1 Q(LOW) = I ELSE QLEN = QLEN + 1 L(I) = QLEN CALL DMUMPS_MTRANSD(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = int(J,8) ENDIF 115 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = Q(1) IF (CSP.GE.D(I)) GO TO 160 BV = D(I) TBV = BV * (ONE-RLX) DO 152 IDUM = 1,M CALL DMUMPS_MTRANSE(QLEN,M,Q,D,L,1) L(I) = 0 LOW = LOW - 1 Q(LOW) = I IF (QLEN.EQ.0) GO TO 153 I = Q(1) IF (D(I).LT.TBV) GO TO 153 152 CONTINUE ENDIF 153 UP = UP - 1 Q0 = Q(UP) DQ0 = D(Q0) L(Q0) = UP J = IPERM(Q0) DO 155 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (L(I).GE.UP) GO TO 155 DNEW = min(DQ0,abs(A(K))) IF (CSP.GE.DNEW) GO TO 155 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = I JSP = J IF (CSP.GE.TBV) GO TO 160 ELSE DI = D(I) IF (DI.GE.TBV .OR. DI.GE.DNEW) GO TO 155 D(I) = DNEW IF (DNEW.GE.TBV) THEN IF (DI.NE.MINONE) THEN CALL DMUMPS_MTRANSF(L(I),QLEN,M,Q,D,L,1) ENDIF L(I) = 0 LOW = LOW - 1 Q(LOW) = I ELSE IF (DI.EQ.MINONE) THEN QLEN = QLEN + 1 L(I) = QLEN ENDIF CALL DMUMPS_MTRANSD(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = int(J,8) ENDIF 155 CONTINUE 150 CONTINUE 160 IF (CSP.EQ.MINONE) GO TO 190 BV = min(BV,CSP) TBV = BV * (ONE-RLX) NUM = NUM + 1 I = ISP J = JSP DO 170 JDUM = 1,NUM+1 I0 = JPERM(J) JPERM(J) = I IPERM(I) = J J = int(PR(J)) IF (J.EQ.-1) GO TO 190 I = I0 170 CONTINUE 190 DO 191 IK = UP,M I = Q(IK) D(I) = MINONE L(I) = 0 191 CONTINUE DO 192 IK = LOW,UP-1 I = Q(IK) D(I) = MINONE 192 CONTINUE DO 193 IK = 1,QLEN I = Q(IK) D(I) = MINONE L(I) = 0 193 CONTINUE 100 CONTINUE 1000 IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL DMUMPS_MTRANSX(M,N,IPERM,L,JPERM) 2000 RETURN END SUBROUTINE DMUMPS_MTRANSB SUBROUTINE DMUMPS_MTRANSD(I,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER I,N,IWAY INTEGER Q(N),L(N) DOUBLE PRECISION D(N) INTEGER IDUM,K,POS,POSK,QK PARAMETER (K=2) DOUBLE PRECISION DI POS = L(I) IF (POS.LE.1) GO TO 20 DI = D(I) IF (IWAY.EQ.1) THEN DO 10 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.LE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 10 CONTINUE ELSE DO 15 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.GE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 15 CONTINUE ENDIF 20 Q(POS) = I L(I) = POS RETURN END SUBROUTINE DMUMPS_MTRANSD SUBROUTINE DMUMPS_MTRANSE(QLEN,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER QLEN,N,IWAY INTEGER Q(N),L(N) DOUBLE PRECISION D(N) INTEGER I,IDUM,K,POS,POSK PARAMETER (K=2) DOUBLE PRECISION DK,DR,DI I = Q(QLEN) DI = D(I) QLEN = QLEN - 1 POS = 1 IF (IWAY.EQ.1) THEN DO 10 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 20 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.LT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.GE.DK) GO TO 20 Q(POS) = Q(POSK) L(Q(POS)) = POS POS = POSK 10 CONTINUE ELSE DO 15 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 20 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.GT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.LE.DK) GO TO 20 Q(POS) = Q(POSK) L(Q(POS)) = POS POS = POSK 15 CONTINUE ENDIF 20 Q(POS) = I L(I) = POS RETURN END SUBROUTINE DMUMPS_MTRANSE SUBROUTINE DMUMPS_MTRANSF(POS0,QLEN,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER POS0,QLEN,N,IWAY INTEGER Q(N),L(N) DOUBLE PRECISION D(N) INTEGER I,IDUM,K,POS,POSK,QK PARAMETER (K=2) DOUBLE PRECISION DK,DR,DI IF (QLEN.EQ.POS0) THEN QLEN = QLEN - 1 RETURN ENDIF I = Q(QLEN) DI = D(I) QLEN = QLEN - 1 POS = POS0 IF (IWAY.EQ.1) THEN IF (POS.LE.1) GO TO 20 DO 10 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.LE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 10 CONTINUE 20 Q(POS) = I L(I) = POS IF (POS.NE.POS0) RETURN DO 30 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 40 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.LT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.GE.DK) GO TO 40 QK = Q(POSK) Q(POS) = QK L(QK) = POS POS = POSK 30 CONTINUE ELSE IF (POS.LE.1) GO TO 34 DO 32 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.GE.D(QK)) GO TO 34 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 34 32 CONTINUE 34 Q(POS) = I L(I) = POS IF (POS.NE.POS0) RETURN DO 36 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 40 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.GT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.LE.DK) GO TO 40 QK = Q(POSK) Q(POS) = QK L(QK) = POS POS = POSK 36 CONTINUE ENDIF 40 Q(POS) = I L(I) = POS RETURN END SUBROUTINE DMUMPS_MTRANSF SUBROUTINE DMUMPS_MTRANSQ(IP,LENL,LENH,W,WLEN,A,NVAL,VAL) IMPLICIT NONE INTEGER ::WLEN,NVAL INTEGER :: LENL(*),LENH(*),W(*) INTEGER(8) :: IP(*) DOUBLE PRECISION :: A(*),VAL INTEGER XX,J,K,S,POS INTEGER(8) :: II PARAMETER (XX=10) DOUBLE PRECISION SPLIT(XX),HA NVAL = 0 DO 10 K = 1,WLEN J = W(K) DO 15 II = IP(J)+int(LENL(J),8),IP(J)+int(LENH(J)-1,8) HA = A(II) IF (NVAL.EQ.0) THEN SPLIT(1) = HA NVAL = 1 ELSE DO 20 S = NVAL,1,-1 IF (SPLIT(S).EQ.HA) GO TO 15 IF (SPLIT(S).GT.HA) THEN POS = S + 1 GO TO 21 ENDIF 20 CONTINUE POS = 1 21 DO 22 S = NVAL,POS,-1 SPLIT(S+1) = SPLIT(S) 22 CONTINUE SPLIT(POS) = HA NVAL = NVAL + 1 ENDIF IF (NVAL.EQ.XX) GO TO 11 15 CONTINUE 10 CONTINUE 11 IF (NVAL.GT.0) VAL = SPLIT((NVAL+1)/2) RETURN END SUBROUTINE DMUMPS_MTRANSQ SUBROUTINE DMUMPS_MTRANSR(N,NE,IP,IRN,A) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NE INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NE) DOUBLE PRECISION, INTENT(INOUT) :: A(NE) INTEGER :: THRESH,TDLEN PARAMETER (THRESH=15,TDLEN=50) INTEGER :: J, LEN, HI INTEGER(8) :: K, IPJ, TD, FIRST, LAST, MID, R, S DOUBLE PRECISION :: HA, KEY INTEGER(8) :: TODO(TDLEN) DO 100 J = 1,N LEN = int(IP(J+1) - IP(J)) IF (LEN.LE.1) GO TO 100 IPJ = IP(J) IF (LEN.LT.THRESH) GO TO 400 TODO(1) = IPJ TODO(2) = IPJ +int(LEN,8) TD = 2_8 500 CONTINUE FIRST = TODO(TD-1) LAST = TODO(TD) KEY = A((FIRST+LAST)/2) DO 475 K = FIRST,LAST-1 HA = A(K) IF (HA.EQ.KEY) GO TO 475 IF (HA.GT.KEY) GO TO 470 KEY = HA GO TO 470 475 CONTINUE TD = TD - 2_8 GO TO 425 470 MID = FIRST DO 450 K = FIRST,LAST-1 IF (A(K).LE.KEY) GO TO 450 HA = A(MID) A(MID) = A(K) A(K) = HA HI = IRN(MID) IRN(MID) = IRN(K) IRN(K) = HI MID = MID + 1 450 CONTINUE IF (MID-FIRST.GE.LAST-MID) THEN TODO(TD+2) = LAST TODO(TD+1) = MID TODO(TD) = MID ELSE TODO(TD+2) = MID TODO(TD+1) = FIRST TODO(TD) = LAST TODO(TD-1) = MID ENDIF TD = TD + 2_8 425 CONTINUE IF (TD.EQ.0_8) GO TO 400 IF (TODO(TD)-TODO(TD-1).GE.int(THRESH,8)) GO TO 500 TD = TD - 2_8 GO TO 425 400 DO 200 R = IPJ+1_8,IPJ+int(LEN-1,8) IF (A(R-1) .LT. A(R)) THEN HA = A(R) HI = IRN(R) A(R) = A(R-1_8) IRN(R) = IRN(R-1_8) DO 300 S = R-1,IPJ+1_8,-1_8 IF (A(S-1) .LT. HA) THEN A(S) = A(S-1) IRN(S) = IRN(S-1) ELSE A(S) = HA IRN(S) = HI GO TO 200 END IF 300 CONTINUE A(IPJ) = HA IRN(IPJ) = HI END IF 200 CONTINUE 100 CONTINUE RETURN END SUBROUTINE DMUMPS_MTRANSR SUBROUTINE DMUMPS_MTRANSS(M,N,NE,IP,IRN,A,IPERM,NUMX, & W,LEN,LENL,LENH,FC,IW,IW4,RLX,RINF) IMPLICIT NONE INTEGER, INTENT(IN) :: M,N INTEGER(8), INTENT(IN) :: NE INTEGER, INTENT(OUT) :: NUMX INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER :: IRN(NE),IPERM(N), & W(N),LEN(N),LENL(N),LENH(N),FC(N),IW(M),IW4(3*N+M) DOUBLE PRECISION A(NE),RLX,RINF INTEGER :: NUM,NVAL,WLEN,I,J,L,CNT,MOD, IDUM INTEGER(8) :: K, II, KDUM1, KDUM2 DOUBLE PRECISION :: BVAL,BMIN,BMAX EXTERNAL DMUMPS_MTRANSQ,DMUMPS_MTRANSU,DMUMPS_MTRANSX DO 20 J = 1,N FC(J) = J LEN(J) = int(IP(J+1) - IP(J)) 20 CONTINUE DO 21 I = 1,M IW(I) = 0 21 CONTINUE CNT = 1 MOD = 1 NUMX = 0 CALL DMUMPS_MTRANSU(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW, & NUMX,N, & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) NUM = NUMX IF (NUM.NE.N) THEN BMAX = RINF ELSE BMAX = RINF DO 30 J = 1,N BVAL = 0.0D0 DO 25 K = IP(J),IP(J+1)-1_8 IF (A(K).GT.BVAL) BVAL = A(K) 25 CONTINUE IF (BVAL.LT.BMAX) BMAX = BVAL 30 CONTINUE BMAX = 1.001D0 * BMAX ENDIF BVAL = 0.0D0 BMIN = 0.0D0 WLEN = 0 DO 48 J = 1,N L = int(IP(J+1) - IP(J)) LENH(J) = L LEN(J) = L DO 45 K = IP(J),IP(J+1)-1_8 IF (A(K).LT.BMAX) GO TO 46 45 CONTINUE K = IP(J+1) 46 LENL(J) = int(K - IP(J)) IF (LENL(J).EQ.L) GO TO 48 WLEN = WLEN + 1 W(WLEN) = J 48 CONTINUE DO 90 KDUM1 = 1_8,NE IF (NUM.EQ.NUMX) THEN DO 50 I = 1,M IPERM(I) = IW(I) 50 CONTINUE DO 80 KDUM2 = 1_8,NE BMIN = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL DMUMPS_MTRANSQ(IP,LENL,LEN,W,WLEN,A,NVAL,BVAL) IF (NVAL.LE.1) GO TO 1000 K = 1 DO 70 IDUM = 1,N IF (K.GT.WLEN) GO TO 71 J = W(K) DO 55 II = IP(J)+int(LEN(J)-1,8), & IP(J)+int(LENL(J),8),-1_8 IF (A(II).GE.BVAL) GO TO 60 I = IRN(II) IF (IW(I).NE.J) GO TO 55 IW(I) = 0 NUM = NUM - 1 FC(N-NUM) = J 55 CONTINUE 60 LENH(J) = LEN(J) LEN(J) = int(II - IP(J) + 1) IF (LENL(J).EQ.LENH(J)) THEN W(K) = W(WLEN) WLEN = WLEN - 1 ELSE K = K + 1 ENDIF 70 CONTINUE 71 IF (NUM.LT.NUMX) GO TO 81 80 CONTINUE 81 MOD = 1 ELSE BMAX = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL DMUMPS_MTRANSQ(IP,LEN,LENH,W,WLEN,A,NVAL,BVAL) IF (NVAL.EQ.0. OR. BVAL.EQ.BMIN) GO TO 1000 K = 1 DO 87 IDUM = 1,N IF (K.GT.WLEN) GO TO 88 J = W(K) DO 85 II = IP(J)+int(LEN(J),8),IP(J)+int(LENH(J)-1,8) IF (A(II).LT.BVAL) GO TO 86 85 CONTINUE 86 LENL(J) = LEN(J) LEN(J) = int(II - IP(J)) IF (LENL(J).EQ.LENH(J)) THEN W(K) = W(WLEN) WLEN = WLEN - 1 ELSE K = K + 1 ENDIF 87 CONTINUE 88 MOD = 0 ENDIF CNT = CNT + 1 CALL DMUMPS_MTRANSU(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW, & NUM,NUMX, & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) 90 CONTINUE 1000 IF (M.EQ.N .and. NUMX.EQ.N) GO TO 2000 CALL DMUMPS_MTRANSX(M,N,IPERM,IW,W) 2000 RETURN END SUBROUTINE DMUMPS_MTRANSS C SUBROUTINE DMUMPS_MTRANSU & (ID,MOD,M,N,IRN,LIRN,IP,LENC,FC,IPERM,NUM,NUMX, & PR,ARP,CV,OUT) IMPLICIT NONE INTEGER :: ID,MOD,M,N,NUM,NUMX INTEGER(8), INTENT(IN) :: LIRN INTEGER :: ARP(N),CV(M),IRN(LIRN), & FC(N),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER(8), INTENT(IN) :: IP(N) INTEGER I,J,J1,JORD,NFC,K,KK, & NUM0,NUM1,NUM2,ID0,ID1,LAST INTEGER(8) :: IN1, IN2, II IF (ID.EQ.1) THEN DO 5 I = 1,M CV(I) = 0 5 CONTINUE DO 6 J = 1,N ARP(J) = 0 6 CONTINUE NUM1 = N NUM2 = N ELSE IF (MOD.EQ.1) THEN DO 8 J = 1,N ARP(J) = 0 8 CONTINUE ENDIF NUM1 = NUMX NUM2 = N - NUMX ENDIF NUM0 = NUM NFC = 0 ID0 = (ID-1)*N DO 100 JORD = NUM0+1,N ID1 = ID0 + JORD J = FC(JORD-NUM0) PR(J) = -1 DO 70 K = 1,JORD IF (ARP(J).GE.LENC(J)) GO TO 30 IN1 = IP(J) + int(ARP(J),8) IN2 = IP(J) + int(LENC(J) - 1,8) DO 20 II = IN1,IN2 I = IRN(II) IF (IPERM(I).EQ.0) GO TO 80 20 CONTINUE ARP(J) = LENC(J) 30 OUT(J) = LENC(J) - 1 DO 60 KK = 1,JORD IN1 = int(OUT(J),8) IF (IN1.LT.0) GO TO 50 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 40 II = IN1,IN2 I = IRN(II) IF (CV(I).EQ.ID1) GO TO 40 J1 = J J = IPERM(I) CV(I) = ID1 PR(J) = J1 OUT(J1) = int(IN2 - II) - 1 GO TO 70 40 CONTINUE 50 J1 = PR(J) IF (J1.EQ.-1) THEN NFC = NFC + 1 FC(NFC) = J IF (NFC.GT.NUM2) THEN LAST = JORD GO TO 101 ENDIF GO TO 100 ENDIF J = J1 60 CONTINUE 70 CONTINUE 80 IPERM(I) = J ARP(J) = int(II - IP(J)) + 1 NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 95 II = IP(J) + int(LENC(J) - OUT(J) - 2,8) I = IRN(II) IPERM(I) = J 90 CONTINUE 95 IF (NUM.EQ.NUM1) THEN LAST = JORD GO TO 101 ENDIF 100 CONTINUE LAST = N 101 DO 110 JORD = LAST+1,N NFC = NFC + 1 FC(NFC) = FC(JORD-NUM0) 110 CONTINUE RETURN END SUBROUTINE DMUMPS_MTRANSU C SUBROUTINE DMUMPS_MTRANSW(M,N,NE,IP,IRN,A,IPERM,NUM, & JPERM,L32,OUT,PR,Q,L,U,D,RINF) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: NE INTEGER :: IRN(NE),IPERM(M),Q(M),L32(max(M,N)) INTEGER(8) :: IP(N+1), PR(N), L(M), JPERM(N), OUT(N) DOUBLE PRECISION A(NE),U(M),D(M),RINF,RINF3 INTEGER :: I,I0,II,J,JJ,JORD,Q0,QLEN,JDUM,JSP, & UP,LOW,IK INTEGER(8) :: K, KK, KK1, KK2, K0, K1, K2, ISP DOUBLE PRECISION :: CSP,DI,DMIN,DNEW,DQ0,VJ,RLX LOGICAL :: LORD DOUBLE PRECISION :: ZERO, ONE PARAMETER (ZERO=0.0D0,ONE=1.0D0) EXTERNAL DMUMPS_MTRANSD, DMUMPS_MTRANSE, & DMUMPS_MTRANSF, DMUMPS_MTRANSX RLX = U(1) RINF3 = U(2) LORD = (JPERM(1).EQ.6) NUM = 0 DO 10 I = 1,N JPERM(I) = 0_8 PR(I) = IP(I) D(I) = RINF 10 CONTINUE DO 15 I = 1,M U(I) = RINF3 IPERM(I) = 0 L(I) = 0_8 15 CONTINUE DO 30 J = 1,N IF (int(IP(J+1)-IP(J)) .GT. N/10 .AND. N.GT.50) GO TO 30 DO 20 K = IP(J),IP(J+1)-1 I = IRN(K) IF (A(K).GT.U(I)) GO TO 20 U(I) = A(K) IPERM(I) = J L(I) = K 20 CONTINUE 30 CONTINUE DO 40 I = 1,M J = IPERM(I) IF (J.EQ.0) GO TO 40 IF (JPERM(J).EQ.0_8) THEN JPERM(J) = L(I) D(J) = U(I) NUM = NUM + 1 ELSEIF (D(J).GT.U(I)) THEN K = JPERM(J) II = IRN(K) IPERM(II) = 0 JPERM(J) = L(I) D(J) = U(I) ELSE IPERM(I) = 0 ENDIF 40 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 45 I = 1,M D(I) = ZERO 45 CONTINUE DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 K1 = IP(J) K2 = IP(J+1) - 1_8 IF (K1.GT.K2) GO TO 95 VJ = RINF DO 50 K = K1,K2 I = IRN(K) DI = A(K) - U(I) IF (DI.GT.VJ) GO TO 50 IF (DI.LT.VJ .OR. DI.EQ.RINF) GO TO 55 IF (IPERM(I).NE.0 .OR. IPERM(I0).EQ.0) GO TO 50 55 VJ = DI I0 = I K0 = K 50 CONTINUE D(J) = VJ K = K0 I = I0 IF (IPERM(I).EQ.0) GO TO 90 DO 60 K = K0,K2 I = IRN(K) IF (A(K)-U(I).GT.VJ) GO TO 60 JJ = IPERM(I) KK1 = PR(JJ) KK2 = IP(JJ+1) - 1_8 IF (KK1.GT.KK2) GO TO 60 DO 70 KK = KK1,KK2 II = IRN(KK) IF (IPERM(II).GT.0) GO TO 70 IF (A(KK)-U(II).LE.D(JJ)) GO TO 80 70 CONTINUE PR(JJ) = KK2 + 1_8 60 CONTINUE GO TO 95 80 JPERM(JJ) = KK IPERM(II) = JJ PR(JJ) = KK + 1_8 90 NUM = NUM + 1 JPERM(J) = K IPERM(I) = J PR(J) = K + 1_8 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = RINF Q(I) = 0 99 CONTINUE DO 100 JORD = 1,N IF (JPERM(JORD).NE.0) GO TO 100 DMIN = RINF QLEN = 0 LOW = M + 1 UP = M + 1 CSP = RINF J = JORD PR(J) = -1_8 DO 115 K = IP(J),IP(J+1)-1_8 I = IRN(K) DNEW = A(K) - U(I) IF (DNEW.GE.CSP) GO TO 115 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = K JSP = J ELSE IF (DNEW.LT.DMIN) DMIN = DNEW D(I) = DNEW QLEN = QLEN + 1 L(QLEN) = K ENDIF 115 CONTINUE Q0 = QLEN QLEN = 0 DO 120 IK = 1,Q0 K = L(IK) I = IRN(K) IF (CSP.LE.D(I)) THEN D(I) = RINF GO TO 120 ENDIF IF (D(I).LE.DMIN) THEN LOW = LOW - 1 L32(LOW) = I Q(I) = LOW ELSE QLEN = QLEN + 1 Q(I) = QLEN CALL DMUMPS_MTRANSD(I,M,L32,D,Q,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = int(J,8) 120 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = L32(1) IF (D(I).LT.RINF) DMIN = D(I)*(ONE+RLX) IF (DMIN.GE.CSP) GO TO 160 152 CALL DMUMPS_MTRANSE(QLEN,M,L32,D,Q,2) LOW = LOW - 1 L32(LOW) = I Q(I) = LOW IF (QLEN.EQ.0) GO TO 153 I = L32(1) IF (D(I).GT.DMIN) GO TO 153 GO TO 152 ENDIF 153 Q0 = L32(UP-1) DQ0 = D(Q0) IF (DQ0.GE.CSP) GO TO 160 IF (DMIN.GE.CSP) GO TO 160 UP = UP - 1 J = IPERM(Q0) VJ = DQ0 - A(JPERM(J)) + U(Q0) K1 = IP(J+1)-1_8 IF (LORD) THEN IF (CSP.NE.RINF) THEN DI = CSP - VJ IF (A(K1).GE.DI) THEN K0 = JPERM(J) IF (K0.GE.K1-6) GO TO 178 177 CONTINUE K = (K0+K1)/2 IF (A(K).GE.DI) THEN K1 = K ELSE K0 = K ENDIF IF (K0.GE.K1-6) GO TO 178 GO TO 177 178 DO 179 K = K0+1,K1 IF (A(K).LT.DI) GO TO 179 K1 = K - 1 GO TO 181 179 CONTINUE ENDIF ENDIF 181 IF (K1.EQ.JPERM(J)) K1 = K1 - 1 ENDIF K0 = IP(J) DI = CSP - VJ DO 155 K = K0,K1 I = IRN(K) IF (Q(I).GE.LOW) GO TO 155 DNEW = A(K) - U(I) IF (DNEW.GE.DI) GO TO 155 DNEW = DNEW + VJ IF (DNEW.GT.D(I)) GO TO 155 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = K JSP = J DI = CSP - VJ ELSE IF (DNEW.GE.D(I)) GO TO 155 D(I) = DNEW IF (DNEW.LE.DMIN) THEN IF (Q(I).NE.0) THEN CALL DMUMPS_MTRANSF(Q(I),QLEN,M,L32,D,Q,2) ENDIF LOW = LOW - 1 L32(LOW) = I Q(I) = LOW ELSE IF (Q(I).EQ.0) THEN QLEN = QLEN + 1 Q(I) = QLEN ENDIF CALL DMUMPS_MTRANSD(I,M,L32,D,Q,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = int(J,8) ENDIF 155 CONTINUE 150 CONTINUE 160 IF (CSP.EQ.RINF) GO TO 190 NUM = NUM + 1 I = IRN(ISP) J = JSP IPERM(I) = J JPERM(J) = ISP DO 170 JDUM = 1,NUM JJ = int(PR(J)) IF (JJ.EQ.-1) GO TO 180 K = OUT(J) I = IRN(K) IPERM(I) = JJ JPERM(JJ) = K J = JJ 170 CONTINUE 180 DO 182 JJ = UP,M I = L32(JJ) U(I) = U(I) + D(I) - CSP 182 CONTINUE 190 DO 191 JJ = UP,M I = L32(JJ) D(I) = RINF Q(I) = 0 191 CONTINUE DO 192 JJ = LOW,UP-1 I = L32(JJ) D(I) = RINF Q(I) = 0 192 CONTINUE DO 193 JJ = 1,QLEN I = L32(JJ) D(I) = RINF Q(I) = 0 193 CONTINUE 100 CONTINUE 1000 CONTINUE DO 1200 J = 1,N K = JPERM(J) IF (K.NE.0) THEN D(J) = A(K) - U(IRN(K)) ELSE D(J) = ZERO ENDIF 1200 CONTINUE DO 1201 I = 1,M IF (IPERM(I).EQ.0) U(I) = ZERO 1201 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL DMUMPS_MTRANSX(M,N,IPERM,Q,L32) 2000 RETURN END SUBROUTINE DMUMPS_MTRANSW SUBROUTINE DMUMPS_MTRANSZ & (M,N,IRN,LIRN,IP,LENC,IPERM,NUM,PR,ARP,CV,OUT) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: LIRN INTEGER :: ARP(N),CV(M),IRN(LIRN),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER(8), INTENT(IN) :: IP(N) C Local variables INTEGER :: I,J,J1,JORD,K,KK INTEGER(8) :: II, IN1, IN2 INTEGER, PARAMETER :: KXX = 100 ! default DOUBLE PRECISION :: R INTEGER :: MAXNUM EXTERNAL DMUMPS_MTRANSX R = dble(KXX)/dble(100) MAXNUM = min(N, INT(N*R)) DO 10 I = 1,M CV(I) = 0 IPERM(I) = 0 10 CONTINUE DO 12 J = 1,N ARP(J) = LENC(J) - 1 12 CONTINUE NUM = 0 DO 1000 JORD = 1,N J = JORD PR(J) = -1 DO 70 K = 1,JORD IN1 = int(ARP(J),8) IF (IN1.LT.0_8) GO TO 30 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 20 II = IN1,IN2 I = IRN(II) IF (IPERM(I).EQ.0) GO TO 80 20 CONTINUE ARP(J) = -1 30 CONTINUE OUT(J) = LENC(J) - 1 DO 60 KK = 1,JORD IN1 = int(OUT(J),8) IF (IN1.LT.0_8) GO TO 50 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 40 II = IN1,IN2 I = IRN(II) IF (CV(I).EQ.JORD) GO TO 40 J1 = J J = IPERM(I) CV(I) = JORD PR(J) = J1 OUT(J1) = int(IN2 - II - 1_8) GO TO 70 40 CONTINUE 50 CONTINUE J = PR(J) IF (J.EQ.-1) GO TO 999 60 CONTINUE 70 CONTINUE 80 CONTINUE IPERM(I) = J ARP(J) = int(IN2 - II - 1_8) NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 999 II = IP(J) + int(LENC(J) - OUT(J) - 2,8) I = IRN(II) IPERM(I) = J 90 CONTINUE 999 CONTINUE IF (KXX.GE.100) GOTO 1000 C we may stop if NUM large enough IF (NUM.GE.MAXNUM) EXIT 1000 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL DMUMPS_MTRANSX(M,N,IPERM,CV,ARP) 2000 RETURN END SUBROUTINE DMUMPS_MTRANSZ SUBROUTINE DMUMPS_MTRANSX(M,N,IPERM,RW,CW) IMPLICIT NONE INTEGER M,N INTEGER RW(M),CW(N),IPERM(M) INTEGER I,J,K INTEGER, PARAMETER :: KXX = 100 INTEGER SIG SIG = -1 IF (KXX.LT.100) SIG = 1 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*SIG 30 CONTINUE DO 40 J = N+1,M K = K + 1 I = RW(K) IPERM(I) = J*SIG 40 CONTINUE RETURN END SUBROUTINE DMUMPS_MTRANSX MUMPS_5.8.1/src/zfac_process_message.F0000664000175000017500000010013515042446441017525 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE ZMUMPS_TRAITER_MESSAGE( & COMM_LOAD, ASS_IRECV, & MSGSOU, MSGTAG, MSGLEN, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER KEEP(500), ICNTL( 60 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) COMPLEX(kind=8) A( LA ) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER COMM_LOAD, ASS_IRECV INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER INIV2, ISHIFT, IBEG INTEGER ISHIFT_HDR INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL FLAG INTEGER LP INTEGER TMP( 2 ) INTEGER NBRECU, POSITION, INODE, ISON, IROOT INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE, & LMAP, FPERE, NELIM, & HDMAPLIG,NFS4FATHER, & TOT_ROOT_SIZE, TOT_CONT_TO_RECV DOUBLE PRECISION FLOP1 CHARACTER(LEN=35) :: SUBNAME INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) LP = ICNTL(1) SUBNAME="??????" CALL MUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF ( MSGTAG .EQ. RACINE ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NBRECU, & 1, MPI_INTEGER, COMM, IERR) NBRECU = BUFR( 1 ) NBFIN = NBFIN - NBRECU ELSEIF ( MSGTAG .EQ. NOEUD ) THEN CALL ZMUMPS_PROCESS_NODE( MYID, KEEP, KEEP8, DKEEP, & BUFR, LBUFR, LBUFR_BYTES, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) SUBNAME="ZMUMPS_PROCESS_NODE" IF ( IFLAG .LT. 0 ) GO TO 500 IF ( FLAG ) THEN CALL ZMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( FPERE, N, & PROCNODE_STEPS,KEEP(199), & ND, FILS, FRERE, STEP, PIMASTER, & KEEP(28), KEEP(50), KEEP(253), FLOP1, & IW, LIW, KEEP(IXSZ) ) IF (FPERE.NE.KEEP(20)) & CALL MUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ELSEIF ( MSGTAG .EQ. END_NIV2_LDLT ) THEN INODE = BUFR( 1 ) CALL ZMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, -INODE ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ELSEIF ( MSGTAG .EQ. TERREUR ) THEN IFLAG = -001 IERROR = MSGSOU GOTO 100 ELSEIF ( MSGTAG .EQ. MAITRE_DESC_BANDE ) THEN CALL ZMUMPS_PROCESS_DESC_BANDE( MYID,BUFR, LBUFR, & LBUFR_BYTES, IWPOS, & IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, #if ! defined (NO_FDM_DESCBAND) & -1, #endif & IFLAG, IERROR ) SUBNAME="ZMUMPS_PROCESS_DESC_BANDE" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. MAITRE2 ) THEN CALL ZMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, SLAVEF, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & KEEP, KEEP8, DKEEP, ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) SUBNAME="ZMUMPS_PROCESS_MASTER2" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. BLOC_FACTO .OR. & MSGTAG .EQ. BLOC_FACTO_RELAY ) THEN CALL ZMUMPS_PROCESS_BLOCFACTO( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM , IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM_SLAVE ) THEN CALL ZMUMPS_PROCESS_BLFAC_SLAVE( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM ) THEN CALL ZMUMPS_PROCESS_SYM_BLOCFACTO( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. CONTRIB_TYPE2 ) THEN CALL ZMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, & MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, & N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, PERM, COMP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, NBFIN, MYID, COMM, & ICNTL,KEEP,KEEP8,DKEEP,IFLAG, IERROR, IPOOL, LPOOL, LEAF, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSEIF ( MSGTAG .EQ. MAPLIG ) THEN HDMAPLIG = 7 INODE = BUFR( 1 ) ISON = BUFR( 2 ) NSLAVES_PERE = BUFR( 3 ) NFRONT_PERE = BUFR( 4 ) NASS_PERE = BUFR( 5 ) LMAP = BUFR( 6 ) NFS4FATHER = BUFR( 7 ) IF ( NSLAVES_PERE.NE.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ISHIFT = NSLAVES_PERE+1 TAB_POS_IN_PERE(1:NSLAVES_PERE+1, INIV2) = & BUFR(HDMAPLIG+1:HDMAPLIG+1+NSLAVES_PERE) TAB_POS_IN_PERE(SLAVEF+2, INIV2) = NSLAVES_PERE ELSE ISHIFT = 0 ENDIF IBEG = HDMAPLIG+1+ISHIFT CALL ZMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES_PERE, & BUFR(IBEG), & NFRONT_PERE, NASS_PERE, NFS4FATHER,LMAP, & BUFR(IBEG+NSLAVES_PERE), & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, roota, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_CONT_STATIC ) THEN CALL ZMUMPS_PROCESS_CONTRIB_TYPE3( & BUFR, LBUFR, LBUFR_BYTES, & root, roota, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF, OPASSW) SUBNAME="ZMUMPS_PROCESS_CONTRIB_TYPE3" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_NON_ELIM_CB ) THEN IROOT = KEEP( 38 ) MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), & KEEP(199) ) IF ( PTLUST( STEP(IROOT)) .EQ. 0 ) THEN KEEP(266)=KEEP(266)-1 CALL MPI_RECV( TMP, 2 * KEEP(34), MPI_PACKED, & MSGSOU, ROOT_2SLAVE, & COMM, STATUS, IERR ) CALL ZMUMPS_PROCESS_ROOT2SLAVE( TMP( 1 ), TMP( 2 ), & root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP,ND ) SUBNAME="ZMUMPS_PROCESS_ROOT2SLAVE" IF ( IFLAG .LT. 0 ) GOTO 500 END IF CALL ZMUMPS_PROCESS_CONTRIB_TYPE3( & BUFR, LBUFR, LBUFR_BYTES, & root, roota, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF, OPASSW ) SUBNAME="ZMUMPS_PROCESS_CONTRIB_TYPE3" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_2SON ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) CALL ZMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & ISON, NELIM, root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 IF ( MYID.NE.MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) ) THEN IF (KEEP(50).EQ.0) THEN ISHIFT_HDR = 6 ELSE ISHIFT_HDR = 8 ENDIF IF (IW(PTRIST(STEP(ISON))+ISHIFT_HDR+KEEP(IXSZ)).EQ. & S_REC_CONTSTATIC) THEN IW(PTRIST(STEP(ISON))+ISHIFT_HDR+KEEP(IXSZ)) = & S_ROOT2SON_CALLED ELSE CALL ZMUMPS_FREE_BAND( N, ISON, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)),KEEP(199)) & ) ENDIF ENDIF ELSE IF ( MSGTAG .EQ. ROOT_2SLAVE ) THEN TOT_ROOT_SIZE = BUFR( 1 ) TOT_CONT_TO_RECV = BUFR( 2 ) CALL ZMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, & TOT_CONT_TO_RECV, root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP, ND ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_NELIM_INDICES ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) NSLAVES_PERE = BUFR( 3 ) CALL ZMUMPS_PROCESS_RTNELIND( root, roota, & ISON, NELIM, NSLAVES_PERE, BUFR(4), BUFR(4+BUFR(2)), & BUFR(4+2*BUFR(2)), & & PROCNODE_STEPS, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND) SUBNAME="ZMUMPS_PROCESS_RTNELIND" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. UPDATE_LOAD ) THEN WRITE(*,*) "Internal error 3 in ZMUMPS_TRAITER_MESSAGE" CALL MUMPS_ABORT() ELSE IF ( MSGTAG .EQ. TAG_DUMMY ) THEN ELSE IF ( LP > 0 ) & WRITE(LP,*) MYID, &': Internal error, routine ZMUMPS_TRAITER_MESSAGE.',MSGTAG IFLAG = -100 IERROR= MSGTAG GOTO 500 ENDIF 100 CONTINUE RETURN 500 CONTINUE IF ( ICNTL(1) .GT. 0 .AND. ICNTL(4).GE.1 ) THEN LP=ICNTL(1) IF (IFLAG.EQ.-9) THEN WRITE(LP,*) 'FAILURE, WORKSPACE TOO SMALL DURING ',SUBNAME ENDIF IF (IFLAG.EQ.-8) THEN WRITE(LP,*) 'FAILURE IN INTEGER ALLOCATION DURING ',SUBNAME ENDIF IF (IFLAG.EQ.-13) THEN WRITE(LP,*) 'FAILURE IN DYNAMIC ALLOCATION DURING ',SUBNAME ENDIF ENDIF CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE ZMUMPS_TRAITER_MESSAGE RECURSIVE SUBROUTINE ZMUMPS_RECV_AND_TREAT( & COMM_LOAD, ASS_IRECV, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT , & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, LA, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST( KEEP(28) ) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER MSGSOU, MSGTAG, MSGLEN, IERR MSGSOU = STATUS( MPI_SOURCE ) MSGTAG = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN IFLAG = -20 IERROR = MSGLEN WRITE(*,*) ' RECEPTION BUF TOO SMALL, Msgtag/len=', & MSGTAG,MSGLEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF KEEP(266)=KEEP(266)-1 CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, & COMM, STATUS, IERR ) CALL ZMUMPS_TRAITER_MESSAGE( & COMM_LOAD, ASS_IRECV, & MSGSOU, MSGTAG, MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS ) RETURN END SUBROUTINE ZMUMPS_RECV_AND_TREAT RECURSIVE SUBROUTINE ZMUMPS_TRY_RECVTREAT( & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, & MESSAGE_RECEIVED, MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED, LRGROUPS ) USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL, INTENT (IN) :: BLOCKING LOGICAL, INTENT (IN) :: SET_IRECV LOGICAL, INTENT (INOUT) :: MESSAGE_RECEIVED INTEGER, INTENT (IN) :: MSGSOU, MSGTAG INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST(KEEP(28)) INTEGER STEP(N), & PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED LOGICAL FLAG, RIGHT_MESS, FLAGbis INTEGER LP, MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC INTEGER IERR INTEGER :: STATUS_BIS(MPI_STATUS_SIZE) INTEGER, SAVE :: RECURS = 0 CALL MUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF ( .NOT. STACK_RIGHT_AUTHORIZED ) THEN RETURN ENDIF RECURS = RECURS + 1 LP = ICNTL(1) IF (ICNTL(4).LT.1) LP=-1 IF ( MESSAGE_RECEIVED ) THEN MSGSOU_LOC = MPI_ANY_SOURCE MSGTAG_LOC = MPI_ANY_TAG GOTO 250 ENDIF IF ( ASS_IRECV .NE. MPI_REQUEST_NULL) THEN RIGHT_MESS = .TRUE. IF (BLOCKING) THEN CALL MPI_WAIT(ASS_IRECV, & STATUS, IERR) FLAG = .TRUE. IF ( ( (MSGSOU.NE.MPI_ANY_SOURCE) .OR. & (MSGTAG.NE.MPI_ANY_TAG) ) ) THEN IF ( MSGSOU.NE.MPI_ANY_SOURCE) THEN RIGHT_MESS = MSGSOU.EQ.STATUS(MPI_SOURCE) ENDIF IF ( MSGTAG.NE.MPI_ANY_TAG) THEN RIGHT_MESS = & ( (MSGTAG.EQ.STATUS(MPI_TAG)).AND.RIGHT_MESS ) ENDIF IF (.NOT.RIGHT_MESS) THEN CALL MPI_PROBE(MSGSOU,MSGTAG, & COMM, STATUS_BIS, IERR) ENDIF ENDIF ELSE CALL MPI_TEST(ASS_IRECV, & FLAG, STATUS, IERR) ENDIF IF (IERR.LT.0) THEN IFLAG = -20 IF (LP.GT.0) & write(LP,*) ' Error return from MPI_TEST ', & IFLAG, ' in ZMUMPS_TRY_RECVTREAT' CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF IF ( FLAG ) THEN KEEP(266)=KEEP(266)-1 MESSAGE_RECEIVED = .TRUE. MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN_LOC, IERR ) IF (.NOT.RIGHT_MESS) RECURS = RECURS + 10 CALL ZMUMPS_TRAITER_MESSAGE( COMM_LOAD, ASS_IRECV, & MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (.NOT.RIGHT_MESS) RECURS = RECURS - 10 IF ( IFLAG .LT. 0 ) RETURN IF (.NOT.RIGHT_MESS) THEN IF (ASS_IRECV .NE. MPI_REQUEST_NULL) THEN CALL MUMPS_ABORT() ENDIF CALL MPI_IPROBE(MSGSOU,MSGTAG, & COMM, FLAGbis, STATUS, IERR) IF (FLAGbis) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL ZMUMPS_RECV_AND_TREAT( COMM_LOAD, ASS_IRECV, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL,LEAF,NBFIN,MYID,SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & KEEP,KEEP8, DKEEP,ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF ENDIF ENDIF ELSE IF (BLOCKING) THEN CALL MPI_PROBE(MSGSOU,MSGTAG, & COMM, STATUS, IERR) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, FLAG, STATUS, IERR) ENDIF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) MESSAGE_RECEIVED = .TRUE. CALL ZMUMPS_RECV_AND_TREAT( COMM_LOAD, ASS_IRECV, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF ENDIF 250 CONTINUE RECURS = RECURS - 1 IF ( NBFIN .EQ. 0 ) RETURN IF ( RECURS .GT. 3 ) RETURN IF ( KEEP(36).EQ.1 .AND. SET_IRECV .AND. & (ASS_IRECV.EQ.MPI_REQUEST_NULL) .AND. & MESSAGE_RECEIVED ) THEN CALL MPI_IRECV ( BUFR(1), & LBUFR_BYTES, MPI_PACKED, MPI_ANY_SOURCE, & MPI_ANY_TAG, COMM, & ASS_IRECV, IERR ) ENDIF RETURN END SUBROUTINE ZMUMPS_TRY_RECVTREAT SUBROUTINE ZMUMPS_CANCEL_IRECV( INFO1, & KEEP, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & COMM, & MYID, SLAVEF) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER LBUFR, LBUFR_BYTES INTEGER ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER COMM INTEGER MYID, SLAVEF, INFO1, DEST INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL NO_ACTIVE_IRECV INTEGER IERR, DUMMY INTRINSIC mod IF (SLAVEF .EQ. 1) RETURN IF (ASS_IRECV.EQ.MPI_REQUEST_NULL) THEN NO_ACTIVE_IRECV=.TRUE. ELSE CALL MPI_TEST(ASS_IRECV, NO_ACTIVE_IRECV, & STATUS, IERR) IF (NO_ACTIVE_IRECV) THEN KEEP(266) = KEEP(266) - 1 ENDIF ENDIF CALL MPI_BARRIER(COMM,IERR) DUMMY = 1 DEST = mod(MYID+1, SLAVEF) CALL MUMPS_BUF_SEND_1INT & (DUMMY, DEST, TAG_DUMMY, COMM, KEEP, IERR) IF (NO_ACTIVE_IRECV) THEN CALL MPI_RECV( BUFR, LBUFR, & MPI_INTEGER, MPI_ANY_SOURCE, & TAG_DUMMY, COMM, STATUS, IERR ) ELSE CALL MPI_WAIT(ASS_IRECV, & STATUS, IERR) ENDIF KEEP(266)=KEEP(266)-1 RETURN END SUBROUTINE ZMUMPS_CANCEL_IRECV MUMPS_5.8.1/src/zmumps_config_file.F0000664000175000017500000000103315042446441017214 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_CONFIG_FILE_RETURN() RETURN END SUBROUTINE ZMUMPS_CONFIG_FILE_RETURN MUMPS_5.8.1/src/dtools.F0000664000175000017500000026712615042446440014661 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_COMPRESS_LU(SIZE_INPLACE, &MYID,N,IOLDPS,TYPE,IW, LIW, A, LA, &POSFAC, LRLU, LRLUS, IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, &SSARBR,INODE,IERR & , LRGROUPS, NASS &) USE MUMPS_LOAD USE DMUMPS_OOC !$ USE OMP_LIB USE DMUMPS_LR_CORE IMPLICIT NONE INTEGER MYID INTEGER IOLDPS, TYPE, LIW, N, KEEP(500) INTEGER(8) :: SIZE_INPLACE, LA, POSFAC, LRLU, LRLUS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) KEEP8(150) INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER IWPOS INTEGER STEP( N ) INTEGER (8) :: PTRFAC(KEEP(28)) LOGICAL SSARBR INTEGER IOLDSHIFT, IPSSHIFT INTEGER LRGROUPS(KEEP(280)), NASS INCLUDE 'mumps_headers.h' INTEGER LCONT, NELIM, NROW, NPIV, INTSIZ INTEGER NFRONT, NSLAVES INTEGER IPS, IPSIZE INTEGER(8) :: SIZELU, SIZENOTLU, IAPOS, I, SIZESHIFT, ITMP8 INTEGER(8) :: SIZEXXR LOGICAL LRCOMPRESS_PANEL INTEGER INODE INTEGER IERR IERR=0 IOLDSHIFT = IOLDPS + KEEP(IXSZ) IF ( IW( IOLDSHIFT ) < 0 ) THEN write(*,*) ' ERROR 1 compressLU:Should not point to a band.' CALL MUMPS_ABORT() ELSE IF ( IW( IOLDSHIFT + 2 ) < 0 ) THEN write(*,*) ' ERROR 2 compressLU:Stack not performed yet', & IW(IOLDSHIFT + 2) CALL MUMPS_ABORT() ENDIF LCONT = IW( IOLDSHIFT ) NELIM = IW( IOLDSHIFT + 1 ) NROW = IW( IOLDSHIFT + 2 ) NPIV = IW( IOLDSHIFT + 3 ) IAPOS = PTRFAC(IW( IOLDSHIFT + 4 )) NSLAVES= IW( IOLDSHIFT + 5 ) NFRONT = LCONT + NPIV INTSIZ = IW(IOLDPS+XXI) LRCOMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) IF ( (NSLAVES > 0 .AND. TYPE .NE. 2) .OR. & (NSLAVES .eq. 0 .AND. TYPE .EQ. 2 ) ) THEN WRITE(*,*) ' ERROR 3 compressLU: problem with level of inode' CALL MUMPS_ABORT() END IF IF ( KEEP(50) .EQ. 0 ) THEN IF (KEEP(251) .NE. 2) THEN SIZELU = int(LCONT + NROW, 8) * int(NPIV,8) ELSE SIZELU = NPIV * NFRONT ENDIF ELSE IF ( KEEP(459) .GT. 1 ) THEN CALL MUMPS_LDLTPANEL_STORAGE( NPIV, KEEP, & IW(IOLDSHIFT+6+NSLAVES+NFRONT), SIZELU) SIZELU = SIZELU + int( NROW - NPIV, 8 ) * int( NPIV, 8 ) ELSE SIZELU = int(NROW,8) * int(NPIV,8) ENDIF ENDIF CALL MUMPS_GETI8(SIZEXXR, IW(IOLDPS+XXR)) SIZENOTLU = SIZEXXR - SIZELU CALL MUMPS_SUBTRI8TOARRAY( IW(IOLDPS+XXR), SIZENOTLU ) IF ((KEEP(201).NE.0) & .OR.(LRCOMPRESS_PANEL.AND.KEEP(486).EQ.2) & ) THEN SIZESHIFT = SIZEXXR ELSE SIZESHIFT = SIZENOTLU IF (SIZENOTLU.EQ.0_8) THEN GOTO 500 ENDIF ENDIF IF (KEEP(201).EQ.2) THEN IF (KEEP(405) .EQ. 0) THEN KEEP8(31)=KEEP8(31)+SIZELU CALL DMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) ELSE !$OMP CRITICAL(critical_old_ooc) KEEP8(31)=KEEP8(31)+SIZELU CALL DMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) !$OMP END CRITICAL(critical_old_ooc) ENDIF IF(IERR.LT.0)THEN WRITE(*,*)MYID,': Internal error in DMUMPS_NEW_FACTOR' CALL MUMPS_ABORT() ENDIF ENDIF IF ( IOLDPS + INTSIZ .NE. IWPOS ) THEN IPS = IOLDPS + INTSIZ DO WHILE ( IPS .NE. IWPOS ) IPSIZE = IW(IPS+XXI) IPSSHIFT = IPS + KEEP(IXSZ) IF ( IPSIZE .LE. 0 .OR. IPS .GT. IWPOS ) THEN WRITE(*,*) " Internal error 1 DMUMPS_COMPRESS_LU" WRITE(*,*) " IOLDPS, INTSIZ, IWPOS, LIW=", & IOLDPS, INTSIZ, IWPOS, LIW WRITE(*,*) " IWPOS, IPS, IPSIZE =", IWPOS, IPS, IPSIZE WRITE(*,*) " Header at IOLDPS =", & IW(IOLDPS:IOLDPS+KEEP(IXSZ)+5) WRITE(*,*) " Header at IPS =", & IW(IPS:IPS+KEEP(IXSZ)+5) CALL MUMPS_ABORT() ENDIF IF (IPS+IPSIZE .GT. IWPOS) THEN WRITE(*,*) " Internal error 2 DMUMPS_COMPRESS_LU" WRITE(*,*) " IOLDPS, INTSIZ, IWPOS, LIW=", & IOLDPS, INTSIZ, IWPOS, LIW WRITE(*,*) " IWPOS, IPS, IPSIZE =", IWPOS, IPS, IPSIZE WRITE(*,*) " Header at IOLDPS =", & IW(IOLDPS:IOLDPS+KEEP(IXSZ)+5) WRITE(*,*) " Header at IOLDPS+INTSIZ =", & IW(IOLDPS+INTSIZ:IOLDPS+INTSIZ+KEEP(IXSZ)+5) WRITE(*,*) " Header at IPS =", & IW(IPS:IPS+KEEP(IXSZ)+5) WRITE(*,*) " ========================== " WRITE(*,*) " Headers starting at IOLDPS:" IPS = IOLDPS DO WHILE (IPS .LE. IWPOS) WRITE(*,*) " -> new IW header at position" , IPS, ":", & IW(IPS:IPS+KEEP(IXSZ)+5) IPS = IPS + IW(IPS+XXI) ENDDO CALL MUMPS_ABORT() ENDIF IF ( IW( IPSSHIFT + 2 ) < 0 ) THEN NFRONT = IW( IPSSHIFT ) IF (IW(IPSSHIFT+4) .LT. 0) THEN WRITE(*,*) " Internal error 3 DMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW(IPSSHIFT+4))=PTRFAC(IW(IPSSHIFT+4)) & - SIZESHIFT PTRAST(IW(IPSSHIFT+4))=PTRAST(IW(IPSSHIFT+4)) & - SIZESHIFT ELSE IF ( IW( IPSSHIFT ) < 0 ) THEN IF (IW(IPSSHIFT+3) .LT. 0) THEN WRITE(*,*) " Internal error 4 DMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW(IPSSHIFT+3)) = PTRFAC(IW(IPSSHIFT+3)) & -SIZESHIFT ELSE NFRONT = IW( IPSSHIFT ) + IW( IPSSHIFT + 3 ) IF (IW(IPSSHIFT+4) .LT. 0) THEN WRITE(*,*) " Internal error 4 DMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZESHIFT END IF IPS = IPS + IPSIZE END DO IF (SIZESHIFT .NE. 0_8) THEN DO I=IAPOS+SIZEXXR-SIZESHIFT, POSFAC-SIZESHIFT-1_8 A( I ) = A( I + SIZESHIFT) END DO END IF ENDIF POSFAC = POSFAC - SIZESHIFT LRLU = LRLU + SIZESHIFT ITMP8 = SIZESHIFT - SIZE_INPLACE LRLUS = LRLUS + ITMP8 IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) - ITMP8 ELSE !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - ITMP8 !$OMP END ATOMIC ENDIF 500 CONTINUE IF (LRCOMPRESS_PANEL.AND.KEEP(486).EQ.2) THEN CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & -SIZESHIFT+SIZE_INPLACE, & KEEP,KEEP8,LRLUS) ELSE CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,SIZELU,-SIZENOTLU+SIZE_INPLACE, & KEEP,KEEP8,LRLUS) ENDIF RETURN END SUBROUTINE DMUMPS_COMPRESS_LU SUBROUTINE DMUMPS_STACK_BAND( N, ISON, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP, KEEP8, DKEEP, TYPE_SON & ) !$ USE OMP_LIB USE DMUMPS_OOC USE MUMPS_LOAD USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER(8) :: LA, LRLU, LRLUS, POSFAC, IPTRLU INTEGER N, ISON, LIW, IWPOS, IWPOSCB, & COMP, IFLAG, IERROR, SLAVEF, MYID, COMM, & TYPE_SON INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), IW(LIW) INTEGER PTLUST_S(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION OPELIW DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE DOUBLE PRECISION A( LA ) INTEGER(8) :: LREQA, POSA, POSALOC, OLDPOS, JJ INTEGER NFRONT, NCOL_L, NROW_L, LREQI, NSLAVES_L, & POSI, I, IROW_L, ICOL_L, LDA_BAND, NASS LOGICAL NONEED_TO_COPY_FACTORS INTEGER(8) :: LREQA_HEADER INTEGER LIWFAC, STRAT, TYPEFile, NextPivDummy, & IOLDPS_CB LOGICAL LAST_CALL TYPE(IO_BLOCK) :: MonBloc INTEGER LRSTATUS INCLUDE 'mumps_headers.h' DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0d0) DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: IACHK, SIZFR_SON_A, ITMP8 FLOP1 = ZERO NCOL_L = IW( PTRIST(STEP( ISON )) + 3 + KEEP(IXSZ) ) NROW_L = IW( PTRIST(STEP( ISON )) + 2 + KEEP(IXSZ) ) NSLAVES_L = IW( PTRIST(STEP( ISON )) + 5 + KEEP(IXSZ) ) LRSTATUS = IW( PTRIST(STEP( ISON )) + XXLR) LDA_BAND = NCOL_L + IW( PTRIST(STEP( ISON )) + KEEP(IXSZ) ) IF ( KEEP(50) .eq. 0 ) THEN NFRONT = LDA_BAND ELSE NFRONT = IW( PTRIST(STEP( ISON )) + 7 + KEEP(IXSZ) ) END IF IF (KEEP(201).EQ.1) THEN IOLDPS_CB = PTRIST(STEP( ISON )) LIWFAC = IW(IOLDPS_CB+XXI) TYPEFile = TYPEF_L NextPivDummy = -8888 MonBloc%INODE = ISON MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW_L MonBloc%NCOL = LDA_BAND MonBloc%NFS = IW(IOLDPS_CB+1+KEEP(IXSZ)) MonBloc%LastPiv = NCOL_L MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX LAST_CALL = .TRUE. MonBloc%Last = .TRUE. CALL DMUMPS_DM_SET_DYNPTR(IW(PTRIST(STEP(ISON))+XXS), & A, LA, PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR_SON_A) CALL DMUMPS_OOC_IO_LU_PANEL_I & ( STRAT, TYPEFile, & SON_A(IACHK), SIZFR_SON_A, MonBloc, & NextPivDummy, NextPivDummy, & IW(IOLDPS_CB), LIWFAC, & MYID, KEEP8(31), IFLAG,LAST_CALL ) IF ((NCOL_L.EQ.0).OR.(NROW_L.EQ.0)) THEN ENDIF ENDIF NONEED_TO_COPY_FACTORS = ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.-1) & .OR. KEEP(251) .EQ. 2 & .OR. (LRSTATUS.GE.2.AND.KEEP(486).EQ.2) & ) IF ((NCOL_L.EQ.0).OR.(NROW_L.EQ.0)) THEN GOTO 80 ENDIF LREQI = 4 + NCOL_L + NROW_L + KEEP(IXSZ) LREQA_HEADER = int(NCOL_L,8) * int(NROW_L,8) IF (NONEED_TO_COPY_FACTORS) THEN LREQA = 0_8 ELSE LREQA = LREQA_HEADER ENDIF IF ( LRLU .LT. LREQA .OR. & IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LREQA ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) GO TO 700 END IF CALL DMUMPS_COMPRE_NEW( N, KEEP, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS,IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress DMUMPS_STACK_BAND:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) GOTO 700 END IF IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB GOTO 700 END IF END IF IF (.NOT. NONEED_TO_COPY_FACTORS) THEN POSA = POSFAC POSFAC = POSFAC + LREQA LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) IF(KEEP(201).NE.2)THEN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,LREQA,LREQA,KEEP,KEEP8,LRLUS) ELSE CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) ENDIF ENDIF POSI = IWPOS IWPOS = IWPOS + LREQI PTLUST_S(STEP( ISON )) = POSI IW(POSI:POSI+KEEP(IXSZ)-1)=-99999 IW(POSI+XXS)=-9999 IW(POSI+XXI)=LREQI CALL MUMPS_STOREI8(0_8, IW(POSI+XXD)) CALL MUMPS_STOREI8(LREQA, IW(POSI+XXR)) CALL MUMPS_STOREI8(LREQA_HEADER, IW(POSI+XXR)) IW(POSI+XXLR) = LRSTATUS IW(POSI+XXF) = IW(PTRIST(STEP(ISON))+XXF) POSI=POSI+KEEP(IXSZ) IW( POSI ) = - NCOL_L IW( POSI + 1 ) = NROW_L IW( POSI + 2 ) = NFRONT - NCOL_L IW( POSI + 3 ) = STEP(ISON) IF (.NOT. NONEED_TO_COPY_FACTORS) THEN PTRFAC(STEP(ISON)) = POSA ELSE PTRFAC(STEP(ISON)) = -77777_8 ENDIF IROW_L = PTRIST(STEP(ISON)) + 6 + NSLAVES_L + KEEP(IXSZ) ICOL_L = PTRIST(STEP(ISON)) + 6 + NROW_L + NSLAVES_L + KEEP(IXSZ) DO I = 1, NROW_L IW( POSI+3+I ) = IW( IROW_L+I-1 ) ENDDO DO I = 1, NCOL_L IW( POSI+NROW_L+3+I) = IW( ICOL_L+I-1 ) ENDDO IF (.NOT.NONEED_TO_COPY_FACTORS) THEN CALL DMUMPS_DM_SET_DYNPTR(IW(PTRIST(STEP(ISON))+XXS), & A, LA, PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR_SON_A) IF (int(NROW_L,8)*int(NCOL_L,8).GT.int(KEEP(361),8)) THEN !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(I,JJ,OLDPOS,POSALOC) DO I = 1, NROW_L DO JJ = 0_8, int(NCOL_L-1,8) OLDPOS = IACHK + int(I-1,8)*int(LDA_BAND,8) POSALOC = POSA + int(NCOL_L,8)*int(I-1,8) A( POSALOC+JJ ) = SON_A( OLDPOS+JJ ) ENDDO END DO !$OMP END PARALLEL DO ELSE POSALOC = POSA DO I = 1, NROW_L OLDPOS = IACHK + int(I-1,8)*int(LDA_BAND,8) DO JJ = 0_8, int(NCOL_L-1,8) A( POSALOC+JJ ) = SON_A( OLDPOS+JJ ) ENDDO POSALOC = POSALOC + int(NCOL_L,8) END DO ENDIF ENDIF ITMP8 = int(NCOL_L,8) * int(NROW_L,8) IF (KEEP(405) .EQ.1) THEN !$OMP ATOMIC UPDATE KEEP8(10) = KEEP8(10) + ITMP8 !$OMP END ATOMIC ELSE KEEP8(10) = KEEP8(10) + ITMP8 ENDIF IF (KEEP(201).EQ.2) THEN IF (KEEP(405).EQ.0) THEN KEEP8(31)=KEEP8(31)+LREQA CALL DMUMPS_NEW_FACTOR(ISON,PTRFAC,KEEP,KEEP8,A,LA,LREQA,IFLAG) ELSE !$OMP CRITICAL(critical_old_ooc) KEEP8(31)=KEEP8(31)+LREQA CALL DMUMPS_NEW_FACTOR(ISON,PTRFAC,KEEP,KEEP8,A,LA,LREQA,IFLAG) !$OMP END CRITICAL(critical_old_ooc) ENDIF IF(IFLAG.LT.0)THEN WRITE(*,*)MYID,': Internal error in DMUMPS_NEW_FACTOR' IERROR=0 GOTO 700 ENDIF POSFAC = POSFAC - LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - LREQA !$OMP END ATOMIC CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,LREQA,0_8,KEEP,KEEP8,LRLUS) ENDIF 80 CONTINUE IF (TYPE_SON == 1) THEN GOTO 90 ENDIF IF ( KEEP(50) .eq. 0 ) THEN FLOP1 = dble( NCOL_L * NROW_L) + & dble(NROW_L*NCOL_L)*dble(2*NFRONT-NCOL_L-1) ELSE FLOP1 = dble( NCOL_L ) * dble( NROW_L ) & * dble( 2 * LDA_BAND - NROW_L - NCOL_L + 1) END IF OPELIW = OPELIW + FLOP1 FLOP1_EFFECTIVE = FLOP1 NASS = IW( PTRIST(STEP( ISON )) + 4 + KEEP(IXSZ) ) IF ( NCOL_L .NE. NASS ) THEN IF ( KEEP(50).eq.0 ) THEN FLOP1 = dble( NASS * NROW_L) + & dble(NROW_L*NASS)*dble(2*NFRONT-NASS-1) ELSE FLOP1 = dble( NASS ) * dble( NROW_L ) * & dble( 2 * LDA_BAND - NROW_L - NASS + 1) END IF END IF CALL MUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) CALL MUMPS_LOAD_UPDATE(2,.FALSE.,-FLOP1,KEEP,KEEP8) 90 CONTINUE RETURN 700 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE DMUMPS_STACK_BAND SUBROUTINE DMUMPS_FREE_BAND( N, ISON, & PTRIST, PTRAST, IW, LIW, A, LA, & LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON & ) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_PTR, & DMUMPS_DM_FREE_BLOCK IMPLICIT NONE INTEGER(8) :: LRLU, LRLUS, IPTRLU, LA INTEGER ISON, MYID, N, IWPOSCB, TYPE_SON INTEGER KEEP(500), STEP(N) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)) INTEGER LIW INTEGER IW(LIW) DOUBLE PRECISION A(LA) INTEGER ISTCHK INTEGER(8) :: DYN_SIZE DOUBLE PRECISION, DIMENSION(:), POINTER :: FORTRAN_POINTER INTEGER :: XXG_STATUS INCLUDE 'mumps_headers.h' ISTCHK = PTRIST(STEP(ISON)) CALL MUMPS_GETI8( DYN_SIZE, IW(ISTCHK+XXD) ) XXG_STATUS = IW(ISTCHK+XXG) IF (DYN_SIZE .GT. 0_8) THEN CALL DMUMPS_DM_SET_PTR( PTRAST(STEP(ISON)), & DYN_SIZE, FORTRAN_POINTER ) ENDIF CALL DMUMPS_FREE_BLOCK_CB_STATIC(.FALSE.,MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) IF (DYN_SIZE .GT. 0_8) THEN CALL DMUMPS_DM_FREE_BLOCK(XXG_STATUS, FORTRAN_POINTER, DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF PTRIST(STEP( ISON )) = -9999888 PTRAST(STEP( ISON )) = -9999888_8 RETURN END SUBROUTINE DMUMPS_FREE_BAND SUBROUTINE DMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, KEEP, KEEP8, & MYID, COMM, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & INFO, INFOG, PROK, MP, PROKG, MPG & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: PROK, PROKG, SUM_OF_PEAKS INTEGER , INTENT(IN) :: MYID, COMM, N, NELT, NSLAVES, & LNA, MP, MPG INTEGER(8), INTENT(IN):: NA_ELT8, NNZ8 INTEGER, INTENT(IN):: NA(LNA) INTEGER :: KEEP(500), INFO(80), INFOG(80) INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER, PARAMETER :: MASTER = 0 INTEGER :: OOC_STAT, BLR_STRAT, BLR_CASE INTEGER :: IRANK LOGICAL :: EFF, PERLU_ON, COMPUTE_MAXAVG INTEGER(8) :: TOTAL_BYTES INTEGER :: TOTAL_MBYTES INTEGER(8) :: TOTAL_BYTES_UNDER_L0 INTEGER :: TOTAL_MBYTES_UNDER_L0 INTEGER, DIMENSION(3) :: LRLU_UD, OOC_LRLU_UD INTEGER, DIMENSION(3) :: & LRLUCB_UD, OOC_LRLUCB_UD, & LRCB_UD, OOC_LRCB_UD PERLU_ON = .TRUE. EFF = .FALSE. COMPUTE_MAXAVG = .NOT.(NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) IF ( PROKG.AND.SUM_OF_PEAKS) THEN WRITE( MPG,'(A)') & ' Estimations with BLR compression of LU factors:' WRITE( MPG,'(A,I6,A) ') & ' ICNTL(38) Estimated compression rate of LU factors =', & KEEP(464), '/1000' ENDIF OOC_STAT = 0 BLR_STRAT = 1 BLR_CASE = 1 CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, LRLU_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(30) = TOTAL_MBYTES IF (MYID.EQ.MASTER) THEN INFOG(36) = LRLU_UD(1) INFOG(37) = LRLU_UD(2) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN LRLU_UD(3) = (LRLU_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE LRLU_UD(3) = LRLU_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(36)):', & INFOG(36) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, IC factorization (INFOG(37)):' & ,INFOG(37) END IF OOC_STAT = 1 BLR_STRAT = 1 BLR_CASE = 1 CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, OOC_LRLU_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(31) = TOTAL_MBYTES IF (MYID.EQ.MASTER) THEN INFOG(38)= OOC_LRLU_UD(1) INFOG(39)= OOC_LRLU_UD(2) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN OOC_LRLU_UD(3) = (OOC_LRLU_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE OOC_LRLU_UD(3) = OOC_LRLU_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(38)):', & INFOG(38) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, OOC factorization (INFOG(39)):' & ,INFOG(39) END IF IF (SUM_OF_PEAKS) THEN OOC_STAT = 0 BLR_STRAT = 3 BLR_CASE = 1 CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, LRCB_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(37) = TOTAL_MBYTES ENDIF IF (MYID.EQ.MASTER.AND.SUM_OF_PEAKS) THEN INFOG(44)= LRCB_UD(1) INFOG(45)= LRCB_UD(2) ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN LRCB_UD(3) = (LRCB_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE LRCB_UD(3) = LRCB_UD(2)/NSLAVES ENDIF ENDIF OOC_STAT = 1 BLR_STRAT = 3 BLR_CASE = 1 CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, OOC_LRCB_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(38) = TOTAL_MBYTES ENDIF IF (MYID.EQ.MASTER.AND.SUM_OF_PEAKS) THEN INFOG(46)= OOC_LRCB_UD(1) INFOG(47)= OOC_LRCB_UD(2) ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN OOC_LRCB_UD(3) = (OOC_LRCB_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE OOC_LRCB_UD(3) = OOC_LRCB_UD(2)/NSLAVES ENDIF ENDIF END IF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN WRITE( MPG,'(A,A)') & ' Estimations with BLR compression of LU factors ', & 'and Contribution Blocks:' WRITE( MPG,'(A,I6,A) ') & ' ICNTL(38) Estimated compression rate of LU factors =', & KEEP(464), '/1000' WRITE( MPG,'(A,I6,A) ') & ' ICNTL(39) Estimated compression rate of CB =', & KEEP(465), '/1000' ENDIF OOC_STAT = 0 BLR_STRAT = 2 BLR_CASE = 1 CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, LRLUCB_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(34) = TOTAL_MBYTES ENDIF IF (MYID.EQ.MASTER.AND.SUM_OF_PEAKS) THEN INFOG(40)=LRLUCB_UD(1) INFOG(41)=LRLUCB_UD(2) ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN LRLUCB_UD(3) = (LRLUCB_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE LRLUCB_UD(3) = LRLUCB_UD(2)/NSLAVES ENDIF ELSE LRLUCB_UD(1) = TOTAL_MBYTES ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(40)):', & INFOG(40) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, IC factorization (INFOG(41)):' & ,INFOG(41) END IF OOC_STAT = 1 BLR_STRAT = 2 BLR_CASE = 1 CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, OOC_LRLUCB_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(35) = TOTAL_MBYTES ENDIF IF (MYID.EQ.MASTER.AND.SUM_OF_PEAKS) THEN INFOG(42)=OOC_LRLUCB_UD(1) INFOG(43)=OOC_LRLUCB_UD(2) ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN OOC_LRLUCB_UD(3) = (OOC_LRLUCB_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE OOC_LRLUCB_UD(3) = OOC_LRLUCB_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(42)):', & INFOG(42) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, OOC factorization (INFOG(43)):' & ,INFOG(43) END IF END SUBROUTINE DMUMPS_MEM_ESTIM_BLR_ALL SUBROUTINE DMUMPS_MAX_MEM( KEEP, KEEP8, & MYID, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & MEMORY_MBYTES, EFF, OOC_STRAT, BLR_STRAT, PERLU_ON, & MEMORY_BYTES, & BLR_CASE, SUM_OF_PEAKS, MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: EFF, PERLU_ON, UNDER_L0_OMP INTEGER, INTENT(IN) :: OOC_STRAT, BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID, N, NELT, NSLAVES, LNA INTEGER(8), INTENT(IN) :: NA_ELT8, NNZ8 INTEGER, INTENT(IN) :: NA(LNA) INTEGER(8), INTENT(OUT):: MEMORY_BYTES INTEGER, INTENT(OUT) :: MEMORY_MBYTES INTEGER, INTENT(IN) :: BLR_CASE LOGICAL, INTENT(IN) :: SUM_OF_PEAKS LOGICAL, INTENT(IN) :: MEM_EFF_ALLOCATED INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER :: MUMPS_GET_POOL_LENGTH EXTERNAL :: MUMPS_GET_POOL_LENGTH INTEGER(8) :: MemEstimGlobal LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: PERLU, NBRECORDS INTEGER(8) :: NB_REAL INTEGER(8) :: TEMP, NB_BYTES, NB_INT INTEGER :: DMUMPS_LBUF_INT INTEGER(8) :: DMUMPS_LBUFR_BYTES8, DMUMPS_LBUF8 INTEGER :: NBUFS INTEGER(8) :: TEMPI INTEGER(8) :: TEMPR INTEGER :: MIN_PERLU INTEGER(8) :: BUF_OOC, BUF_OOC_PANEL, BUF_OOC_NOPANEL INTEGER(8) :: OOC_NB_FILE_TYPE INTEGER(8) :: NSTEPS8, N8, NELT8 INTEGER(8) :: I8OVERI INTEGER(8) :: SUM_NRLADU_underL0, & SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, & SUM_NRLADULR_WC_underL0 INTEGER(4) :: I4 INTEGER(8) :: MIN_NRLADU_underL0, MIN_NRLADU_if_LR_LU_underL0 INTEGER :: ITH, ITHMIN, ITHMIN_if_LRLU INTEGER(8) :: I8_L0_OMP_2, I8_L0_OMP_3, & I8_L0_OMP_5, I8_L0_OMP_6, I8_L0_OMP_7, & I8_L0_OMP_8, I8_L0_OMP_9, I8_L0_OMP_10, & I8_L0_OMP_11, I8_L0_OMP_12, I8_L0_OMP_13 I8OVERI = int(KEEP(10),8) PERLU = KEEP(12) NSTEPS8 = int(KEEP(28),8) N8 = int(N,8) NELT8 = int(NELT,8) IF (.NOT.PERLU_ON) PERLU = 0 I_AM_MASTER = ( MYID .eq. 0 ) I_AM_SLAVE = ( KEEP(46).eq. 1 .or. MYID .ne. 0 ) TEMP = 0_8 NB_REAL = 0_8 NB_BYTES = 0_8 NB_INT = 0_8 IF (KEEP(235) .NE. 0 .OR. KEEP(237) .NE. 0) THEN NB_INT = NB_INT + NSTEPS8 ENDIF NB_INT = NB_INT + 5_8 * NSTEPS8 NB_INT = NB_INT + NSTEPS8 + int(KEEP(56),8)*int(NSLAVES+2,8) NB_INT = NB_INT + 3_8*N8 + KEEP(280) IF (KEEP(38) .NE. 0 .AND.I_AM_SLAVE) NB_INT = NB_INT + 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 + KEEP(193)*I8OVERI NB_INT = NB_INT + KEEP(194)+KEEP(195)+KEEP(196) NB_INT = NB_INT + 2 ELSE NB_INT = NB_INT + 2_8 * ( NELT8 + 1_8 ) * I8OVERI NB_INT = NB_INT + N8 + 1_8 + NELT8 NB_INT = NB_INT + I8OVERI + 3 END IF NB_INT = NB_INT + int(LNA,8) IF ( .NOT. EFF ) THEN IF (I_AM_SLAVE) THEN IF (UNDER_L0_OMP) THEN I8_L0_OMP_2 = 0_8 I8_L0_OMP_3 = 0_8 MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,1) MIN_NRLADU_underL0 = I8_L0_OMP(1,1) ITHMIN = 1 ITHMIN_if_LRLU = 1 DO ITH=1, KEEP(400) IF (I8_L0_OMP(1,ITH).LT.MIN_NRLADU_underL0) & THEN MIN_NRLADU_underL0 = I8_L0_OMP(1,ITH) ITHMIN = ITH ENDIF IF (I8_L0_OMP(4,ITH).LT.MIN_NRLADU_if_LR_LU_underL0) & THEN MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,ITH) ITHMIN_if_LRLU = ITH ENDIF I8_L0_OMP_2=I8_L0_OMP_2 + I8_L0_OMP(2,ITH) I8_L0_OMP_3=I8_L0_OMP_3 + I8_L0_OMP(3,ITH) ENDDO IF (SUM_OF_PEAKS.AND.BLR_STRAT.GT.0) THEN I8_L0_OMP_5 = 0_8 I8_L0_OMP_6 = 0_8 I8_L0_OMP_7 = 0_8 I8_L0_OMP_8 = 0_8 I8_L0_OMP_9 = 0_8 I8_L0_OMP_10= 0_8 I8_L0_OMP_11= 0_8 I8_L0_OMP_12= 0_8 I8_L0_OMP_13= 0_8 DO ITH=1, KEEP(400) I8_L0_OMP_5 = I8_L0_OMP_5 + I8_L0_OMP(5,ITH) I8_L0_OMP_6 = I8_L0_OMP_6 + I8_L0_OMP(6,ITH) I8_L0_OMP_7 = I8_L0_OMP_7 + I8_L0_OMP(7,ITH) I8_L0_OMP_8 = I8_L0_OMP_8 + I8_L0_OMP(8,ITH) I8_L0_OMP_9 = I8_L0_OMP_9 + I8_L0_OMP(9,ITH) I8_L0_OMP_10= I8_L0_OMP_10+ I8_L0_OMP(10,ITH) I8_L0_OMP_11= I8_L0_OMP_11+ I8_L0_OMP(11,ITH) I8_L0_OMP_12= I8_L0_OMP_12+ I8_L0_OMP(12,ITH) I8_L0_OMP_13= I8_L0_OMP_13+ I8_L0_OMP(13,ITH) ENDDO ENDIF CALL DMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & 0_8, 0_8, 0_8, 0_8, & I8_L0_OMP_2, & I8_L0_OMP_3, & I8_L0_OMP_5, & I8_L0_OMP_6, & I8_L0_OMP_7, & I8_L0_OMP_8, & I8_L0_OMP_9, & I8_L0_OMP_10, & I8_L0_OMP_11, & I8_L0_OMP_12, & I8_L0_OMP_13, & MemEstimGlobal & ) IF (BLR_STRAT.EQ.0) THEN IF ( OOC_STRAT .LE. 0 .AND. OOC_STRAT .NE. -1 ) THEN MemEstimGlobal = MemEstimGlobal + & I8_L0_OMP(1,ITHMIN) + & I8_L0_OMP(23, ITHMIN) ELSE MemEstimGlobal = MemEstimGlobal + & I8_L0_OMP(23, ITHMIN) ENDIF ELSE IF ( OOC_STRAT .LE. 0 .AND. OOC_STRAT .NE. -1 ) THEN MemEstimGlobal = MemEstimGlobal + & I8_L0_OMP(4,ITHMIN_if_LRLU) + & I8_L0_OMP(23, ITHMIN_if_LRLU) ELSE MemEstimGlobal = MemEstimGlobal + & I8_L0_OMP(23, ITHMIN_if_LRLU) ENDIF ENDIF NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ELSE IF ( KEEP8(24).EQ.0_8 ) THEN SUM_NRLADU_underL0 = 0_8 SUM_NRLADU_if_LR_LU_underL0 = 0_8 SUM_NRLADULR_UD_underL0 = 0_8 SUM_NRLADULR_WC_underL0 = 0_8 IF (KEEP(400) .GT. 0 ) THEN DO ITH=1, KEEP(400) SUM_NRLADU_underL0 = & SUM_NRLADU_underL0 + I8_L0_OMP(1,ITH) SUM_NRLADU_if_LR_LU_underL0 = & SUM_NRLADU_if_LR_LU_underL0 + I8_L0_OMP(4,ITH) SUM_NRLADULR_UD_underL0 = & SUM_NRLADULR_UD_underL0 + I8_L0_OMP(9,ITH) SUM_NRLADULR_WC_underL0 = & SUM_NRLADULR_WC_underL0 + I8_L0_OMP(10,ITH) ENDDO ENDIF CALL DMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & SUM_NRLADU_underL0, SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, SUM_NRLADULR_WC_underL0, & KEEP8(53), & KEEP8(54), & KEEP8(33), & KEEP8(34), & KEEP8(35), & KEEP8(50), & KEEP8(36), & KEEP8(47), & KEEP8(37), & KEEP8(38), & KEEP8(39), & MemEstimGlobal & ) IF (KEEP(400).LE.0) THEN NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ELSE IF (BLR_STRAT.EQ.0) THEN IF ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(KEEP8(14) / 100_8 + 1_8 ) ELSE NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(KEEP8(12) / 100_8 + 1_8 ) ENDIF ELSE NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ENDIF ENDIF ENDIF ELSE NB_REAL = NB_REAL + 1_8 ENDIF ELSE IF (I_AM_SLAVE) THEN IF (UNDER_L0_OMP) THEN IF (MEM_EFF_ALLOCATED) THEN NB_REAL = NB_REAL + KEEP8(63) ELSE NB_REAL = NB_REAL + KEEP8(62) ENDIF ELSE IF (MEM_EFF_ALLOCATED) THEN NB_REAL = NB_REAL + KEEP8(23) + KEEP8(74) ELSE NB_REAL = NB_REAL + KEEP8(67) + KEEP8(74) ENDIF ENDIF ENDIF IF ( OOC_STRAT .GT. 0 .AND. I_AM_SLAVE ) THEN BUF_OOC_NOPANEL = 2_8 * KEEP8(119) IF (KEEP(50).EQ.0)THEN BUF_OOC_PANEL = 8_8 * int(KEEP(226),8) ELSE BUF_OOC_PANEL = 4_8 * int(KEEP(226),8) ENDIF IF (OOC_STRAT .EQ. 2) THEN BUF_OOC = BUF_OOC_NOPANEL ELSE BUF_OOC = BUF_OOC_PANEL ENDIF NB_REAL = NB_REAL + min(BUF_OOC + int(max(PERLU,0),8) * & (BUF_OOC/100_8+1_8),12000000_8) IF (OOC_STRAT .EQ. 2) THEN OOC_NB_FILE_TYPE = 1_8 ELSE IF (KEEP(50).EQ.0) THEN OOC_NB_FILE_TYPE = 2_8 ELSE OOC_NB_FILE_TYPE = 1_8 ENDIF ENDIF NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 * I8OVERI NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 * I8OVERI NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 ENDIF IF (KEEP(252).EQ.1 .AND. .NOT. I_AM_MASTER) THEN NB_REAL = NB_REAL + N8 ENDIF IF ( .not. ( I_AM_SLAVE .and. I_AM_MASTER .and. KEEP(52) .eq. 0 & .and. KEEP(55) .ne. 0 ) ) THEN NB_INT = NB_INT + KEEP8(27) END IF TEMPI= 0_8 TEMPR = 0_8 NBRECORDS = KEEP(39) IF (KEEP(55).eq.0) THEN IF (NNZ8 < int(NBRECORDS,8)) THEN NBRECORDS=int(NNZ8) ENDIF ELSE IF (NA_ELT8 < int(NBRECORDS,8)) THEN NBRECORDS=int(NA_ELT8) ENDIF ENDIF IF ( KEEP(54) .eq. 0 ) THEN IF ( I_AM_MASTER ) THEN IF ( KEEP(46) .eq. 0 ) THEN NBUFS = NSLAVES ELSE NBUFS = NSLAVES - 1 IF (KEEP(55) .eq. 0 ) & TEMPI = TEMPI + 2_8 * N8 END IF TEMPI = TEMPI + 2_8 * int(NBRECORDS,8) * int(NBUFS,8) TEMPR = TEMPR + int(NBRECORDS,8) * int(NBUFS,8) ELSE IF ( KEEP(55) .eq. 0 )THEN TEMPI = TEMPI + 2_8 * int(NBRECORDS,8) TEMPR = TEMPR + int(NBRECORDS,8) END IF END IF ELSE IF ( I_AM_SLAVE ) THEN TEMPI = TEMPI + int(1+4*NSLAVES,8) * int(NBRECORDS,8) TEMPR = TEMPR + int(1+2*NSLAVES,8) * int(NBRECORDS,8) END IF END IF TEMP = NB_BYTES + (NB_INT + TEMPI) * int(KEEP(34),8) & + NB_REAL * int(KEEP(35),8) & + (TEMPR+KEEP8(26)) * int(KEEP(149),8) NB_REAL = NB_REAL + KEEP8(26) IF ( I_AM_SLAVE ) THEN IF (BLR_STRAT.NE.0) THEN DMUMPS_LBUFR_BYTES8 = int(KEEP(380),8) * int(KEEP(35),8) ELSE DMUMPS_LBUFR_BYTES8 = int(KEEP(44),8) * int(KEEP(35),8) ENDIF DMUMPS_LBUFR_BYTES8 = max( DMUMPS_LBUFR_BYTES8, & 200000_8 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF IF (KEEP(72).NE.1) THEN DMUMPS_LBUFR_BYTES8 = DMUMPS_LBUFR_BYTES8 & + int( dble(max(PERLU/2,MIN_PERLU))* & dble(DMUMPS_LBUFR_BYTES8)/100D0,8) ELSE DMUMPS_LBUFR_BYTES8 = DMUMPS_LBUFR_BYTES8 & + int( dble(max(PERLU,MIN_PERLU))* & dble(DMUMPS_LBUFR_BYTES8)/100D0,8) ENDIF DMUMPS_LBUFR_BYTES8 = min(DMUMPS_LBUFR_BYTES8, & int(huge (I4)-100,8)) NB_BYTES = NB_BYTES + DMUMPS_LBUFR_BYTES8 IF (.NOT.UNDER_L0_OMP) THEN IF (BLR_STRAT.NE.0) THEN DMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 & * dble(KEEP( 379 ) * KEEP( 35 )), 8 ) ELSE DMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 & * dble(KEEP( 43 ) * KEEP( 35 )), 8 ) ENDIF DMUMPS_LBUF8 = max( DMUMPS_LBUF8, 200000_8 ) IF (KEEP(72).NE.1) THEN DMUMPS_LBUF8 = DMUMPS_LBUF8 & + int( dble(max(PERLU/2,MIN_PERLU))* & dble(DMUMPS_LBUF8)/100D0, 8) ELSE DMUMPS_LBUF8 = DMUMPS_LBUF8 & + int( dble(max(PERLU,MIN_PERLU))* & dble(DMUMPS_LBUF8)/100D0, 8) ENDIF DMUMPS_LBUF8 = min(DMUMPS_LBUF8, int(huge(I4)-100,8)) DMUMPS_LBUF8 = max(DMUMPS_LBUF8, DMUMPS_LBUFR_BYTES8+ & 3_8*int(KEEP(34),8)) NB_BYTES = NB_BYTES + DMUMPS_LBUF8 ENDIF DMUMPS_LBUF_INT = ( KEEP(56) + & NSLAVES * NSLAVES ) * 5 & * KEEP(34) NB_BYTES = NB_BYTES + int(DMUMPS_LBUF_INT,8) IF (.NOT.EFF) THEN IF (UNDER_L0_OMP) THEN IF (KEEP(144).GT.0) THEN NB_INT = NB_INT + N8*int(KEEP(400),8) NB_INT = NB_INT + & int(MUMPS_GET_POOL_LENGTH(NA(1), KEEP, KEEP8),8)* & int(KEEP(400),8) ENDIF ENDIF IF (KEEP(400).GT.0) THEN NB_INT = NB_INT + & int(MUMPS_GET_POOL_LENGTH(NA(1), KEEP, KEEP8),8) ENDIF IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int( & KEEP(138) + 3 * max(PERLU,10) * & ( KEEP(138) / 100 + 1 ) & ,8) ELSE NB_INT = NB_INT + int( & KEEP(137) + 3 * max(PERLU,10) * & ( KEEP(137) / 100 + 1 ) & ,8) ENDIF ENDIF IF (.NOT.UNDER_L0_OMP) THEN IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int( & KEEP(225) + 2 * max(PERLU,10) * & ( KEEP(225) / 100 + 1 ) & ,8) ELSE NB_INT = NB_INT + int( & KEEP(15) + 2 * max(PERLU,10) * & ( KEEP(15) / 100 + 1 ) & ,8) ENDIF ENDIF NB_INT = NB_INT + NSTEPS8 NB_INT = NB_INT + NSTEPS8 * I8OVERI NB_INT = NB_INT + N8 + 4_8 * NSTEPS8 + & int(MUMPS_GET_POOL_LENGTH(NA(1), KEEP, KEEP8),8) NB_INT = NB_INT + 2_8 * NSTEPS8 * I8OVERI ENDIF MEMORY_BYTES = NB_BYTES + NB_INT * int(KEEP(34),8) + & NB_REAL * int(KEEP(35),8) MEMORY_BYTES = max( MEMORY_BYTES, TEMP ) MEMORY_MBYTES = nint( dble(MEMORY_BYTES) / dble(1000000) ) RETURN END SUBROUTINE DMUMPS_MAX_MEM SUBROUTINE DMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & SUM_NRLADU_underL0, SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, SUM_NRLADULR_WC_underL0, & PEAK_FR, & PEAK_FR_OOC, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB, & NRLADULR_UD, & NRLADULR_WC, & NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, & NRLNECLR_LUCB_WC, & MemEstimGlobal & ) INTEGER, INTENT(IN) :: OOC_STRAT, BLR_STRAT INTEGER, INTENT(IN) :: BLR_CASE LOGICAL, INTENT(IN) :: SUM_OF_PEAKS INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER(8), INTENT(IN) :: SUM_NRLADU_underL0, & SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, & SUM_NRLADULR_WC_underL0 INTEGER(8), INTENT(IN) :: & PEAK_FR, & PEAK_FR_OOC, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB, & NRLADULR_UD, & NRLADULR_WC, & NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, & NRLNECLR_LUCB_WC INTEGER(8), INTENT(OUT) :: MemEstimGlobal IF ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN MemEstimGlobal = PEAK_FR_OOC ELSE MemEstimGlobal = PEAK_FR ENDIF IF (BLR_STRAT.GT.0) THEN IF (.NOT.SUM_OF_PEAKS) THEN IF (BLR_STRAT.EQ.1) THEN IF (BLR_CASE.LE.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(40) ELSE MemEstimGlobal = KEEP8(41) ENDIF ELSE IF (BLR_CASE.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(33) ELSE MemEstimGlobal = KEEP8(54) ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(53) ELSE MemEstimGlobal = KEEP8(42) ENDIF ENDIF ELSE IF (BLR_CASE.LE.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(43) ELSE MemEstimGlobal = KEEP8(45) ENDIF ELSE IF (BLR_CASE.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(34) ELSE MemEstimGlobal = KEEP8(35) ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(44) ELSE MemEstimGlobal = KEEP8(46) ENDIF ENDIF ENDIF ELSE IF (BLR_STRAT.EQ.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_LU & + SUM_NRLADU_if_LR_LU_underL0 ELSE MemEstimGlobal = PEAK_FR_OOC ENDIF IF (BLR_CASE.EQ.1) THEN MemEstimGlobal = MemEstimGlobal + NRLADULR_UD & + SUM_NRLADULR_UD_underL0 ELSE IF (BLR_CASE.EQ.3) THEN MemEstimGlobal = MemEstimGlobal + NRLADULR_WC & + SUM_NRLADULR_WC_underL0 ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_LUCB & + SUM_NRLADU_if_LR_LU_underL0 ELSE MemEstimGlobal = NRLNECOOC_if_LR_LUCB ENDIF IF (BLR_CASE.EQ.1) THEN MemEstimGlobal = MemEstimGlobal + NRLNECLR_LUCB_UD & + SUM_NRLADULR_UD_underL0 ELSE IF (BLR_CASE.EQ.3) THEN MemEstimGlobal = MemEstimGlobal + NRLNECLR_LUCB_WC & + SUM_NRLADULR_WC_underL0 ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_CB & + SUM_NRLADU_underL0 ELSE MemEstimGlobal = NRLNECOOC_if_LR_LUCB ENDIF MemEstimGlobal = MemEstimGlobal + NRLNECLR_CB_UD ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SET_MEMESTIMGLOBAL SUBROUTINE DMUMPS_SET_BLRSTRAT_AND_MAXS_K8 ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & KEEP, KEEP8) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS_BASE8, MAXS_BASE_RELAXED8 INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) CALL DMUMPS_SET_BLRSTRAT_AND_MAXS ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & KEEP(1), & KEEP8(12), & KEEP8(14), & KEEP8(33), & KEEP8(34), & KEEP8(35), & KEEP8(50) ) RETURN END SUBROUTINE DMUMPS_SET_BLRSTRAT_AND_MAXS_K8 SUBROUTINE DMUMPS_SET_BLRSTRAT_AND_MAXS( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, KEEP, & NRLNEC, & NRLNEC_ACTIVE, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB ) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS_BASE8, MAXS_BASE_RELAXED8 INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: NRLNEC, & NRLNEC_ACTIVE, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB INTEGER :: PERLU PERLU = KEEP(12) IF (KEEP(201) .EQ. 0) THEN MAXS_BASE8 = NRLNEC ELSE MAXS_BASE8 = NRLNEC_ACTIVE ENDIF BLR_STRAT = 0 IF (KEEP(486).EQ.2) THEN IF (KEEP(489).EQ.1) THEN BLR_STRAT = 2 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNECOOC_if_LR_LUCB ELSE MAXS_BASE8 = NRLNEC_if_LR_LUCB ENDIF ELSE BLR_STRAT = 1 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNEC_ACTIVE ELSE MAXS_BASE8 = NRLNEC_if_LR_LU ENDIF ENDIF ELSE IF (KEEP(486).EQ.3) THEN IF (KEEP(489).EQ.1) THEN BLR_STRAT = 3 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNECOOC_if_LR_LUCB ELSE MAXS_BASE8 = NRLNEC_if_LR_CB ENDIF ENDIF ENDIF IF ( MAXS_BASE8 .GT. 0_8 ) THEN MAXS_BASE_RELAXED8 = & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) ELSE MAXS_BASE_RELAXED8 = 1_8 END IF RETURN END SUBROUTINE DMUMPS_SET_BLRSTRAT_AND_MAXS SUBROUTINE DMUMPS_MEM_ALLOWED_SET_MAXS ( MAXS, & BLR_STRAT, OOC_STRAT, MAXS_ESTIM_RELAXED8, & KEEP, KEEP8, MYID, N, NELT, NA, LNA, & NSLAVES, ICNTL38, ICNTL39, IFLAG, IERROR & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(IN) :: BLR_STRAT INTEGER, INTENT(IN) :: OOC_STRAT INTEGER(8), INTENT(IN) :: MAXS_ESTIM_RELAXED8 INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID, N, NELT, NSLAVES, LNA INTEGER, INTENT(IN) :: NA(LNA), ICNTL38, ICNTL39 INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER(8) :: SMALLER_MAXS, UPDATED_DIFF LOGICAL :: EFF, PERLU_ON, SUM_OF_PEAKS INTEGER :: BLR_CASE INTEGER(8) :: TOTAL_BYTES, MEM_ALLOWED_BYTES, & MEM_DISPO_BYTES, MEM_DISPO INTEGER :: TOTAL_MBYTES, PERLU INTEGER(8) :: MEM_DISPO_BYTES_NR, MEM_DISPO_NR, & TOTAL_BYTES_NR INTEGER :: TOTAL_MBYTES_NR INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. PERLU_ON = .TRUE. PERLU = KEEP(12) EFF = .FALSE. SUM_OF_PEAKS = .TRUE. BLR_CASE = 1 MEM_ALLOWED_BYTES = KEEP8(4) CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, & KEEP8(28), KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF, OOC_STRAT, & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) MEM_DISPO_BYTES = MEM_ALLOWED_BYTES-TOTAL_BYTES IF (MEM_DISPO_BYTES.GT.0) THEN MEM_DISPO = MEM_DISPO_BYTES/int(KEEP(35),8) ELSE MEM_DISPO = (MEM_DISPO_BYTES-int(KEEP(35),8)+1)/ & int(KEEP(35),8) ENDIF IF (BLR_STRAT.EQ.0) THEN UPDATED_DIFF = 0_8 ELSE IF (BLR_STRAT.EQ.1) THEN IF (KEEP(464).NE.0) THEN UPDATED_DIFF = int( & dble(KEEP8(36)) * ( 1.0D0 - & dble(ICNTL38)/dble(KEEP(464)) ) & , 8) ELSE UPDATED_DIFF = int ( & -dble(KEEP8(11)-KEEP8(32)) * & dble(ICNTL38) / 1000.0D0 & , 8) ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF (KEEP(464)+KEEP(465).NE.0) THEN UPDATED_DIFF = int( & dble(KEEP8(38)) * ( 1.0D0 - & dble(ICNTL38+ICNTL39)/ & dble(KEEP(464)+KEEP(465)) ) & , 8) ELSE UPDATED_DIFF = int( & -dble(KEEP8(39))* & dble(ICNTL38+ICNTL39)/1000.0D0 & , 8) ENDIF ELSE IF (BLR_STRAT.EQ.3) THEN IF (KEEP(465).NE.0) THEN UPDATED_DIFF = int( & dble(KEEP8(37)) * ( 1.0D0 - & dble(ICNTL39)/dble(KEEP(465)) ) & , 8) ELSE UPDATED_DIFF = int( & -dble(KEEP8(39))* & dble(ICNTL39)/1000.0D0 & , 8) ENDIF ELSE UPDATED_DIFF = 0_8 ENDIF MEM_DISPO = MEM_DISPO + UPDATED_DIFF MAXS = MAXS_ESTIM_RELAXED8 MEM_DISPO_NR = 0_8 IF ( (MEM_DISPO.LT.0) .AND. MAXS_ESTIM_RELAXED8.GT. & (MEM_ALLOWED_BYTES/int(KEEP(35),8)) ) THEN PERLU_ON = .FALSE. CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, & KEEP8(28), KEEP8(30), & NSLAVES, TOTAL_MBYTES_NR, EFF, OOC_STRAT, & BLR_STRAT, PERLU_ON, TOTAL_BYTES_NR, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) MEM_DISPO_BYTES_NR = MEM_ALLOWED_BYTES-TOTAL_BYTES_NR MEM_DISPO_NR = & MEM_DISPO_BYTES_NR/int(KEEP(35),8) & + UPDATED_DIFF IF ( MEM_DISPO_NR.LT.0 ) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE IF (BLR_STRAT.GE.2) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE MEM_DISPO_NR = MEM_DISPO_NR - & (int(KEEP(12),8)/120_8)* & (KEEP8(11)/4_8) IF ( MEM_DISPO_NR.LT.0 ) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE ENDIF ENDIF ENDIF ENDIF MAXS = MAXS_ESTIM_RELAXED8 IF (BLR_STRAT.EQ.0) THEN IF (MEM_DISPO.GT.0) THEN IF (OOC_STRAT.EQ.0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/2_8) ELSE MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/2_8) ENDIF ELSE MAXS = MAXS_ESTIM_RELAXED8 + MEM_DISPO ENDIF ELSE IF (BLR_STRAT.EQ.1) THEN IF ( MEM_DISPO .GT. 0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/10_8) ELSE IF ( MEM_DISPO .LT. 0) THEN IF (OOC_STRAT.EQ.0) THEN SMALLER_MAXS = KEEP8(34) + & int(PERLU,8) * ( KEEP8(34) / 100_8 + 1_8) ELSE SMALLER_MAXS = KEEP8(35) + & int(PERLU,8) * ( KEEP8(35) / 100_8 + 1_8) ENDIF MAXS = max(MAXS_ESTIM_RELAXED8+MEM_DISPO, & SMALLER_MAXS) ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF ( MEM_DISPO .GT. 0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/10_8) ELSE IF ( MEM_DISPO.LT.0) THEN MAXS = max( & MAXS_ESTIM_RELAXED8+MEM_DISPO, & MAXS_ESTIM_RELAXED8) ENDIF ELSE IF (BLR_STRAT.EQ.3) THEN IF ( MEM_DISPO .GT. 0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/4_8) ELSE IF ( MEM_DISPO.LT.0) THEN MAXS = max( & MAXS_ESTIM_RELAXED8+MEM_DISPO, & MAXS_ESTIM_RELAXED8) ENDIF ENDIF IF (MAXS .LE. 0_8) THEN IFLAG=-19 IF (MEM_DISPO.LT.0) THEN CALL MUMPS_SET_IERROR(MEM_DISPO,IERROR) ELSE CALL MUMPS_SET_IERROR(MAXS_ESTIM_RELAXED8-MAXS,IERROR) ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_MEM_ALLOWED_SET_MAXS SUBROUTINE DMUMPS_MEM_ALLOWED_SET_K75 ( & MAXS, MYID, UNDER_L0_OMP, & N, NELT, NA, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT, & KEEP, KEEP8, IFLAG, IERROR & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MAXS INTEGER, INTENT(IN) :: MYID, N, NELT, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT LOGICAL, INTENT(IN) :: UNDER_L0_OMP INTEGER, INTENT(IN) :: NA(LNA), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER(8) :: KEEP8_23_SAVETMP, TOTAL_BYTES INTEGER :: TOTAL_MBYTES LOGICAL :: PERLU_ON, MEM_EFF_ALLOCATED, EFF INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. KEEP8_23_SAVETMP = KEEP8(23) KEEP8(23) = MAXS PERLU_ON =.TRUE. MEM_EFF_ALLOCATED = .TRUE. EFF = .TRUE. KEEP8(74) = 0_8 KEEP8(63) = 0_8 CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) KEEP8(23) = KEEP8_23_SAVETMP KEEP8(75) = KEEP8(4) - TOTAL_BYTES KEEP8(75) = KEEP8(75)/int(KEEP(35),8) IF (KEEP8(75).LT.0_8) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-KEEP8(75),IERROR) ENDIF RETURN END SUBROUTINE DMUMPS_MEM_ALLOWED_SET_K75 SUBROUTINE DMUMPS_L0_COMPUTE_PEAK_ALLOWED ( & MYID, N, & NELT, NA, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT, & KEEP, KEEP8, IFLAG, IERROR & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, N, NELT, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT INTEGER, INTENT(IN) :: NA(LNA), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER(8) :: KEEP8_23_SAVETMP, TOTAL_BYTES, TOTAL_STATIC, & TOTAL_ABOVE, TOTAL_UNDER INTEGER(8) :: EXTRA_MEM, MIN_NRLADU_underL0, & MIN_NRLADU_if_LR_LU_underL0 INTEGER :: TOTAL_MBYTES LOGICAL :: PERLU_ON, MEM_EFF_ALLOCATED, EFF LOGICAL :: UNDER_L0_OMP, SUM_OF_PEAKS INTEGER :: BLR_CASE, ITH INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. KEEP8_23_SAVETMP = KEEP8(23) KEEP8(23) = 0_8 UNDER_L0_OMP = .TRUE. PERLU_ON = .TRUE. MEM_EFF_ALLOCATED = .TRUE. EFF = .TRUE. KEEP8(74) = 0_8 KEEP8(63) = 0_8 CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_STATIC = TOTAL_BYTES KEEP8(23) = KEEP8_23_SAVETMP MEM_EFF_ALLOCATED = .FALSE. EFF = .FALSE. BLR_CASE = 2 SUM_OF_PEAKS = .TRUE. UNDER_L0_OMP = .FALSE. CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_ABOVE = TOTAL_BYTES IF (PERLU_ON.AND.KEEP(201).LE.0) THEN IF (BLR_STRAT.GT.0) THEN MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,1) DO ITH=1, KEEP(400) MIN_NRLADU_if_LR_LU_underL0 = min ( & MIN_NRLADU_if_LR_LU_underL0, I8_L0_OMP(4,ITH) & ) ENDDO EXTRA_MEM = int(KEEP(12),8)* & ( MIN_NRLADU_if_LR_LU_underL0 / 100_8 + 1_8 ) ELSE MIN_NRLADU_underL0 = I8_L0_OMP(1,1) DO ITH=1, KEEP(400) MIN_NRLADU_underL0 = min ( & MIN_NRLADU_underL0, I8_L0_OMP(1,ITH) & ) ENDDO EXTRA_MEM = int(KEEP(12),8)* & ( MIN_NRLADU_underL0 / 100_8 + 1_8 ) ENDIF TOTAL_ABOVE = TOTAL_ABOVE + EXTRA_MEM ENDIF UNDER_L0_OMP = .TRUE. CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_UNDER = TOTAL_BYTES KEEP8(77) = ( max(TOTAL_UNDER,TOTAL_ABOVE) - TOTAL_STATIC ) & / int(KEEP(35),8) RETURN END SUBROUTINE DMUMPS_L0_COMPUTE_PEAK_ALLOWED SUBROUTINE DMUMPS_SETMAXTOZERO(M_ARRAY, M_SIZE) IMPLICIT NONE INTEGER M_SIZE DOUBLE PRECISION M_ARRAY(M_SIZE) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0D0) M_ARRAY=ZERO RETURN END SUBROUTINE DMUMPS_SETMAXTOZERO SUBROUTINE DMUMPS_COMPUTE_NBROWSinF ( & N, INODE, IFATH, KEEP, & IOLDPS, HF, IW, LIW, & NROWS, NCOLS, NPIV, & NELIM, NFS4FATHER, & NBROWSinF & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, INODE, IFATH INTEGER, INTENT(IN) :: KEEP(500) INTEGER, INTENT(IN) :: IOLDPS, HF, LIW, NROWS, NCOLS INTEGER, INTENT(IN) :: NPIV, NELIM, NFS4FATHER INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT):: NBROWSinF INTEGER :: ShiftFirstRowinFront NBROWSinF = 0 IF ( (KEEP(219).EQ.0).OR.(KEEP(50).NE.2).OR. & (NFS4FATHER.LE.0) ) THEN RETURN ENDIF ShiftFirstRowinFront = NCOLS-NPIV-NELIM-NROWS IF (ShiftFirstRowinFront.EQ.0) THEN NBROWSinF = min(NROWS, NFS4FATHER-NELIM) ELSE IF (ShiftFirstRowinFront.LT.NFS4FATHER-NELIM) THEN NBROWSinF = min(NROWS,NFS4FATHER-NELIM-ShiftFirstRowinFront) ELSE NBROWSinF=0 ENDIF RETURN END SUBROUTINE DMUMPS_COMPUTE_NBROWSinF SUBROUTINE DMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, INODE, IFATH INTEGER, INTENT(IN) :: FILS(N), PERM(N), KEEP(500) INTEGER, INTENT(IN) :: IOLDPS, HF, LIW, NFRONT, NASS1 INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT):: ESTIM_NFS4FATHER_ATSON INTEGER :: J, J_LASTFS, IN, NCB, I, IPOS ESTIM_NFS4FATHER_ATSON = 0 IN = IFATH J_LASTFS = IN DO WHILE (IN.GT.0) J_LASTFS = IN IN = FILS(IN) ENDDO NCB = NFRONT-NASS1 IPOS = IOLDPS + HF + NASS1 ESTIM_NFS4FATHER_ATSON = 0 DO I=1, NCB J = IW(IPOS+ESTIM_NFS4FATHER_ATSON) IF (PERM(J).LE.PERM(J_LASTFS)) THEN ESTIM_NFS4FATHER_ATSON = & ESTIM_NFS4FATHER_ATSON+1 ELSE EXIT ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_COMPUTE_ESTIM_NFS4FATHER SUBROUTINE DMUMPS_COMPUTE_MAXPERCOL( & A,ASIZE,NCOL,NROW, & M_ARRAY,NMAX,PACKED_CB,LROW1) IMPLICIT NONE INTEGER(8) :: ASIZE INTEGER NROW,NCOL,NMAX,LROW1 LOGICAL PACKED_CB DOUBLE PRECISION A(ASIZE) DOUBLE PRECISION M_ARRAY(NMAX) INTEGER I INTEGER(8):: APOS, J, LROW DOUBLE PRECISION ZERO,TMP PARAMETER (ZERO=0.0D0) DO I=1, NMAX M_ARRAY(I) = ZERO ENDDO APOS = 0_8 IF (PACKED_CB) THEN LROW=int(LROW1,8) ELSE LROW=int(NCOL,8) ENDIF DO I=1,NROW DO J=1_8,int(NMAX,8) TMP = abs(A(APOS+J)) IF(TMP.GT.M_ARRAY(J)) M_ARRAY(J) = TMP ENDDO APOS = APOS + LROW IF (PACKED_CB) LROW=LROW+1_8 ENDDO RETURN END SUBROUTINE DMUMPS_COMPUTE_MAXPERCOL SUBROUTINE DMUMPS_SIZE_IN_STRUCT( id, idintr, & NB_INT, NB_CMPLX, NB_CHAR ) USE DMUMPS_STRUC_DEF, ONLY: DMUMPS_STRUC USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_INTR_STRUC IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(DMUMPS_INTR_STRUC) :: idintr INTEGER(8) NB_INT, NB_CMPLX INTEGER(8) NB_REAL,NB_CHAR NB_INT = 0_8 NB_CMPLX = 0_8 NB_REAL = 0_8 NB_CHAR = 0_8 IF (associated(id%IS)) NB_INT=NB_INT+size(id%IS) NB_INT=NB_INT+size(id%KEEP) NB_INT=NB_INT+size(id%ICNTL) NB_INT=NB_INT+size(id%INFO) NB_INT=NB_INT+size(id%INFOG) IF (associated(id%MAPPING)) NB_INT=NB_INT+size(id%MAPPING) IF (associated(id%STEP)) THEN NB_INT=NB_INT+size(id%STEP) ENDIF 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)) THEN NB_INT=NB_INT+size(id%FILS) ENDIF IF (associated(id%FRTPTR)) NB_INT=NB_INT+size(id%FRTPTR) IF (associated(id%FRTELT)) NB_INT=NB_INT+size(id%FRTELT) IF (associated(id%PTRAR)) & NB_INT=NB_INT+size(id%PTRAR)* id%KEEP(10) IF (associated(id%PTR8ARR)) & NB_INT=NB_INT+size(id%PTR8ARR)* id%KEEP(10) IF (associated(id%NINCOLARR)) & NB_INT=NB_INT+size(id%NINCOLARR) IF (associated(id%NINROWARR)) & NB_INT=NB_INT+size(id%NINROWARR) IF (associated(id%PTRDEBARR)) & NB_INT=NB_INT+size(id%PTRDEBARR) 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%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%ELTPROC)) NB_INT=NB_INT+size(id%ELTPROC) IF (associated(id%CANDIDATES)) & NB_INT=NB_INT+size(id%CANDIDATES,DIM=1)* & size(id%CANDIDATES,DIM=2) IF (associated(id%SYM_PERM)) THEN NB_INT=NB_INT+size(id%SYM_PERM) ENDIF IF (associated(id%UNS_PERM)) & NB_INT=NB_INT+size(id%UNS_PERM) IF (associated(id%ISTEP_TO_INIV2)) & NB_INT=NB_INT+size(id%ISTEP_TO_INIV2) IF (associated(id%FUTURE_NIV2)) & NB_INT=NB_INT+size(id%FUTURE_NIV2) IF (associated(id%TAB_POS_IN_PERE)) & NB_INT=NB_INT+size(id%TAB_POS_IN_PERE,DIM=1)* & size(id%TAB_POS_IN_PERE,DIM=2) 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%GLOB2LOC_RHS)) & NB_INT=NB_INT+size(id%GLOB2LOC_RHS) IF(id%GLOB2LOC_SOL_ALLOC.AND.associated(id%GLOB2LOC_SOL)) & NB_INT=NB_INT+size(id%GLOB2LOC_SOL) IF (associated(id%MEM_SUBTREE)) & NB_REAL=NB_REAL+size(id%MEM_SUBTREE)*(id%KEEP(35)/id%KEEP(16)) IF (associated(id%MY_ROOT_SBTR)) & NB_INT=NB_INT+size(id%MY_ROOT_SBTR) IF (associated(id%MY_FIRST_LEAF)) & NB_INT=NB_INT+size(id%MY_FIRST_LEAF) IF (associated(id%MY_NB_LEAF)) NB_INT=NB_INT+size(id%MY_NB_LEAF) IF (associated(id%DEPTH_FIRST)) NB_INT=NB_INT+size(id%DEPTH_FIRST) IF (associated(id%DEPTH_FIRST_SEQ)) & NB_INT=NB_INT+size(id%DEPTH_FIRST_SEQ) IF (associated(id%SBTR_ID)) NB_INT=NB_INT+size(id%SBTR_ID) IF (associated(id%SCHED_DEP)) NB_INT=NB_INT+size(id%SCHED_DEP) IF (associated(id%SCHED_GRP)) NB_INT=NB_INT+size(id%SCHED_GRP) IF (associated(id%SCHED_SBTR)) NB_INT=NB_INT+size(id%SCHED_SBTR) IF (associated(id%CROIX_MANU)) NB_INT=NB_INT+size(id%CROIX_MANU) IF (associated(id%COST_TRAV)) & NB_REAL=NB_REAL+size(id%COST_TRAV)*(id%KEEP(35)/id%KEEP(16)) IF (associated(id%CB_SON_SIZE)) NB_INT=NB_INT+size(id%CB_SON_SIZE) IF (associated(id%OOC_INODE_SEQUENCE)) & NB_INT=NB_INT+size(id%OOC_INODE_SEQUENCE) IF (associated(id%OOC_SIZE_OF_BLOCK)) & NB_INT=NB_INT+size(id%OOC_SIZE_OF_BLOCK)*id%KEEP(10) IF (associated(id%OOC_VADDR)) & NB_INT=NB_INT+size(id%OOC_VADDR,DIM=1)* & size(id%OOC_VADDR,DIM=2)*id%KEEP(10) IF (associated(id%OOC_TOTAL_NB_NODES)) & NB_INT=NB_INT+size(id%OOC_TOTAL_NB_NODES) IF (associated(id%OOC_NB_FILES)) & NB_INT=NB_INT+size(id%OOC_NB_FILES) IF (associated(id%OOC_FILE_NAME_LENGTH)) & NB_INT=NB_INT+size(id%OOC_FILE_NAME_LENGTH) IF (associated(id%PIVNUL_LIST)) NB_INT=NB_INT+size(id%PIVNUL_LIST) IF (associated(id%SUP_PROC)) NB_INT=NB_INT+size(id%SUP_PROC) IF (associated(id%IPTR_WORKING)) & NB_INT=NB_INT+size(id%IPTR_WORKING) IF (associated(id%WORKING)) NB_INT=NB_INT+size(id%WORKING) IF (associated(id%LRGROUPS)) THEN NB_INT=NB_INT+size(id%LRGROUPS) ENDIF IF (associated(id%I4_L0_OMP)) & NB_INT=NB_INT+size(id%I4_L0_OMP,DIM=1)* & size(id%I8_L0_OMP,DIM=2) IF (associated(id%I8_L0_OMP)) & NB_INT=NB_INT+size(id%I8_L0_OMP,DIM=1)* & size(id%I8_L0_OMP,DIM=2)*id%KEEP(10) IF (associated(id%IPOOL_B_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_B_L0_OMP) IF (associated(id%IPOOL_A_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_A_L0_OMP) IF (associated(id%PHYS_L0_OMP)) & NB_INT=NB_INT+size(id%PHYS_L0_OMP) IF (associated(id%VIRT_L0_OMP)) & NB_INT=NB_INT+size(id%VIRT_L0_OMP) IF (associated(id%PERM_L0_OMP)) & NB_INT=NB_INT+size(id%PERM_L0_OMP) IF (associated(id%PTR_LEAFS_L0_OMP)) & NB_INT=NB_INT+size(id%PTR_LEAFS_L0_OMP) IF (associated(id%L0_OMP_MAPPING)) & NB_INT=NB_INT+size(id%L0_OMP_MAPPING) IF (associated(id%SINGULAR_VALUES)) & NB_REAL=NB_REAL+size(id%SINGULAR_VALUES) IF (associated(idintr%root%RG2L)) THEN NB_INT=NB_INT+size(idintr%root%RG2L) ENDIF IF (associated(idintr%root%IPIV)) & NB_INT=NB_INT+size(idintr%root%IPIV) IF (associated(idintr%roota%RHS_CNTR_MASTER_ROOT)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%RHS_CNTR_MASTER_ROOT) IF (associated(idintr%roota%SCHUR_POINTER)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%SCHUR_POINTER) IF (associated(idintr%roota%QR_TAU)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%QR_TAU) IF (associated(idintr%roota%RHS_ROOT)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%RHS_ROOT) IF (associated(idintr%roota%SVD_U)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%SVD_U) IF (associated(idintr%roota%SVD_VT)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%SVD_VT) IF (associated(idintr%roota%SINGULAR_VALUES)) & NB_REAL=NB_REAL+size(idintr%roota%SINGULAR_VALUES) IF (associated(id%RHSINTR)) NB_CMPLX = NB_CMPLX + id%KEEP8(25) IF (associated(id%S)) NB_CMPLX=NB_CMPLX+id%KEEP8(23) IF (associated(id%COLSCA).AND.(id%KEEP(52).NE.-1)) & NB_REAL=NB_REAL+size(id%COLSCA) IF (associated(id%ROWSCA).AND.(id%KEEP(52).NE.-1)) & NB_REAL=NB_REAL+size(id%ROWSCA) IF (associated(id%ROWSCA_loc)) & NB_REAL=NB_REAL+size(id%ROWSCA_loc) IF (associated(id%COLSCA_loc).AND.id%KEEP(50).EQ.0) & NB_REAL=NB_REAL+size(id%COLSCA_loc) NB_REAL=NB_REAL+size(id%CNTL) NB_REAL=NB_REAL+size(id%RINFO) NB_REAL=NB_REAL+size(id%RINFOG) NB_REAL=NB_REAL+size(id%DKEEP) NB_CHAR=NB_CHAR+len(id%VERSION_NUMBER) NB_CHAR=NB_CHAR+len(id%OOC_TMPDIR) NB_CHAR=NB_CHAR+len(id%OOC_PREFIX) NB_CHAR=NB_CHAR+len(id%WRITE_PROBLEM) NB_CHAR=NB_CHAR+len(id%SAVE_DIR) NB_CHAR=NB_CHAR+len(id%SAVE_PREFIX) NB_CMPLX = NB_CMPLX + NB_REAL RETURN END SUBROUTINE DMUMPS_SIZE_IN_STRUCT SUBROUTINE DMUMPS_COPYI8SIZE(N8,SRC,DEST) IMPLICIT NONE INTEGER(8) :: N8 DOUBLE PRECISION, intent(in) :: SRC(N8) DOUBLE PRECISION, intent(out) :: DEST(N8) INTEGER(8) :: SHIFT8, HUG8 INTEGER :: I, I4SIZE IF(int(huge(I4SIZE),8) .EQ. int(huge(HUG8),8)) THEN CALL dcopy(int(N8), SRC(1), 1, DEST(1), 1) ELSE HUG8=int(huge(I4SIZE),8) DO I = 1, int(( N8 + HUG8 - 1_8 ) / HUG8) SHIFT8 = 1_8 + int(I-1,8) * HUG8 I4SIZE = int(min(HUG8, N8-SHIFT8+1_8)) CALL dcopy(I4SIZE, SRC(SHIFT8), 1, DEST(SHIFT8), 1) ENDDO END IF RETURN END SUBROUTINE DMUMPS_COPYI8SIZE SUBROUTINE DMUMPS_SET_TMP_PTR( THE_ADDRESS, THE_SIZE8 ) USE DMUMPS_STATIC_PTR_M INTEGER(8), INTENT(IN) :: THE_SIZE8 DOUBLE PRECISION, INTENT(IN) :: THE_ADDRESS(THE_SIZE8) CALL DMUMPS_SET_STATIC_PTR(THE_ADDRESS(1:THE_SIZE8)) RETURN END SUBROUTINE DMUMPS_SET_TMP_PTR SUBROUTINE DMUMPS_OOC_IO_LU_PANEL_I & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) USE DMUMPS_OOC, ONLY : IO_BLOCK, & DMUMPS_OOC_IO_LU_PANEL IMPLICIT NONE TYPE(IO_BLOCK), INTENT(INOUT):: MonBloc INTEGER(8) :: LAFAC INTEGER, INTENT(IN) :: STRAT, LIWFAC, MYID, TYPEFile INTEGER, INTENT(INOUT) :: IW(0:LIWFAC-1) DOUBLE PRECISION, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LNextPiv2beWritten, UNextPiv2beWritten INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) RETURN END SUBROUTINE DMUMPS_OOC_IO_LU_PANEL_I SUBROUTINE DMUMPS_BUF_SEND_CONTRIB_TYPE3_I ( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) USE DMUMPS_BUF, ONLY : DMUMPS_BUF_SEND_CONTRIB_TYPE3 IMPLICIT NONE INTEGER N, ISON, NBCOL_SON, NBROW_SON, NSUBSET_ROW, NSUBSET_COL INTEGER NPROW, NPCOL, MBLOCK, NBLOCK, LD_SON INTEGER BBPCBP INTEGER PDEST, TAG, COMM, IERR INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER :: RG2L(N) INTEGER NSUPROW, NSUPCOL INTEGER(8), INTENT(IN) :: TABSIZE INTEGER SIZE_PACK INTEGER KEEP(500) DOUBLE PRECISION VAL_SON( LD_SON, * ), TAB(*) LOGICAL TRANSP INTEGER N_ALREADY_SENT INTEGER NELIM_ROOT, NELIM_ROW, NELIM_COL CALL DMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) RETURN END SUBROUTINE DMUMPS_BUF_SEND_CONTRIB_TYPE3_I SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING_I( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, sizeBEGS_BLR_L, & BEGS_BLR_U, sizeBEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, NB_BLR_U, & NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) USE DMUMPS_LR_TYPE, ONLY : LRB_TYPE USE DMUMPS_FAC_LR, ONLY : DMUMPS_BLR_UPDATE_TRAILING INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, & CURRENT_BLR, & NELIM, NIV, SYM, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT DOUBLE PRECISION, intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_U(NB_BLR_U-CURRENT_BLR) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER :: sizeBEGS_BLR_L, sizeBEGS_BLR_U INTEGER :: BEGS_BLR_L(sizeBEGS_BLR_L) INTEGER :: BEGS_BLR_U(sizeBEGS_BLR_U) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS CALL DMUMPS_BLR_UPDATE_TRAILING( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) RETURN END SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING_I SUBROUTINE DMUMPS_COMPRESS_CB_I(A_PTR, LA_PTR, POSELT, LDA, & BEGS_BLR, sizeBEGS_BLR, BEGS_BLR_U, sizeBEGS_BLR_U, & NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY, & NELIM, & NBROWSinF & ) USE DMUMPS_LR_TYPE, ONLY : LRB_TYPE USE DMUMPS_FAC_LR, ONLY : DMUMPS_COMPRESS_CB IMPLICIT NONE INTEGER(8), intent(in) :: LA_PTR DOUBLE PRECISION, intent(inout) :: A_PTR(LA_PTR) INTEGER(8), intent(in) :: POSELT INTEGER :: sizeBEGS_BLR, sizeBEGS_BLR_U INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & KPERCENT, TOL_OPT, LWORK, OMP_NUM INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: CB_LRB(NB_ROWS,NB_COLS) INTEGER :: BEGS_BLR(sizeBEGS_BLR), BEGS_BLR_U(sizeBEGS_BLR_U) DOUBLE PRECISION :: RWORK(2*MAXI_CLUSTER*OMP_NUM) DOUBLE PRECISION :: BLOCK(MAXI_CLUSTER, MAXI_CLUSTER*OMP_NUM) DOUBLE PRECISION :: WORK(LWORK*OMP_NUM), TAU(MAXI_CLUSTER*OMP_NUM) INTEGER :: JPVT(MAXI_CLUSTER*OMP_NUM) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500) DOUBLE PRECISION :: M_ARRAY(max(NFS4FATHER,1)) INTEGER, intent(in) :: NELIM INTEGER, intent(in) :: NBROWSinF CALL DMUMPS_COMPRESS_CB(A_PTR, LA_PTR, POSELT, LDA, & BEGS_BLR, BEGS_BLR_U, & NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY=M_ARRAY, & NELIM=NELIM, & NBROWSinF=NBROWSinF & ) RETURN END SUBROUTINE DMUMPS_COMPRESS_CB_I SUBROUTINE DMUMPS_COMPRESS_PANEL_I_NOOPT( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, sizeBEGS_BLR, & NB_BLR, TOLEPS, TOL_OPT, K458, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8, & OMP_NUM & ) USE DMUMPS_LR_TYPE, ONLY : LRB_TYPE USE DMUMPS_FAC_LR, ONLY : DMUMPS_COMPRESS_PANEL IMPLICIT NONE INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV INTEGER, intent(in) :: OMP_NUM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER :: MAXI_CLUSTER DOUBLE PRECISION :: RWORK(2*MAXI_CLUSTER*OMP_NUM) DOUBLE PRECISION :: BLOCK(MAXI_CLUSTER,MAXI_CLUSTER*OMP_NUM) DOUBLE PRECISION :: WORK(LWORK*OMP_NUM) DOUBLE PRECISION :: TAU(MAXI_CLUSTER*OMP_NUM) INTEGER :: JPVT(MAXI_CLUSTER*OMP_NUM) INTEGER :: sizeBEGS_BLR INTEGER :: BEGS_BLR(sizeBEGS_BLR) INTEGER(8) :: KEEP8(150) INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, & K458, K473, TOL_OPT LOGICAL, intent(in) :: LBANDSLAVE INTEGER :: LWORK, NELIM DOUBLE PRECISION,intent(in) :: TOLEPS CHARACTER(len=1) :: DIR CALL DMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K458, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8 & ) RETURN END SUBROUTINE DMUMPS_COMPRESS_PANEL_I_NOOPT SUBROUTINE DMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & DECOMP_TIMER) USE DMUMPS_LR_TYPE, ONLY : LRB_TYPE USE DMUMPS_FAC_LR, ONLY : DMUMPS_DECOMPRESS_PANEL IMPLICIT NONE INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: COPY_DENSE_BLOCKS INTEGER, intent(in) :: NB_BLR, CURRENT_BLR INTEGER, intent(in) :: BEGS_BLR_DIAG, & BEGS_BLR_FIRST_OFFDIAG TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) CHARACTER(len=1) :: DIR INTEGER, intent(in) :: DECOMP_TIMER INTEGER, intent(in) :: LDA11, LDA21 CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & DECOMP_TIMER) RETURN END SUBROUTINE DMUMPS_DECOMPRESS_PANEL_I_NOOPT SUBROUTINE DMUMPS_BLR_UPD_NELIM_VAR_L_I( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, sizeBEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) USE DMUMPS_LR_TYPE, ONLY : LRB_TYPE USE DMUMPS_FAC_LR, ONLY : DMUMPS_BLR_UPD_NELIM_VAR_L IMPLICIT NONE INTEGER(8), intent(in) :: LA_U, LA_L INTEGER(8), intent(in) :: UPOS, LPOS INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR, & NELIM, FIRST_BLOCK CHARACTER(len=1),INTENT(IN) :: UTRANS INTEGER, intent(inout) :: IFLAG, IERROR DOUBLE PRECISION, TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER, INTENT(in) :: sizeBEGS_BLR_L INTEGER :: BEGS_BLR_L(sizeBEGS_BLR_L) CALL DMUMPS_BLR_UPD_NELIM_VAR_L( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) RETURN END SUBROUTINE DMUMPS_BLR_UPD_NELIM_VAR_L_I SUBROUTINE DMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, JBEG_BLOCK, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, sizeBEGS_BLR_LM, & NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, sizeBEGS_BLR_LS, & NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, OMP_NUM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) USE DMUMPS_LR_TYPE, ONLY : LRB_TYPE USE DMUMPS_FAC_LR, ONLY : DMUMPS_BLR_SLV_UPD_TRAIL_LDLT IMPLICIT NONE INTEGER(8), intent(in) :: LA, LA_BLOCFACTO DOUBLE PRECISION, intent(inout) :: A(LA) DOUBLE PRECISION, intent(in) :: A_BLOCFACTO(LA_BLOCFACTO) INTEGER(8), intent(in) :: POSELT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), TOL_OPT, & MAXI_CLUSTER, OMP_NUM, LD_BLOCFACTO, & JBEG_BLOCK INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS, & ISHIFT_LM, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS DOUBLE PRECISION, INTENT(INOUT) :: & BLOCK(MAXI_CLUSTER,MAXI_CLUSTER*OMP_NUM) INTEGER :: sizeBEGS_BLR_LM, sizeBEGS_BLR_LS INTEGER :: BEGS_BLR_LM(sizeBEGS_BLR_LM) INTEGER :: BEGS_BLR_LS(sizeBEGS_BLR_LS) TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM), & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS CALL DMUMPS_BLR_SLV_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, JBEG_BLOCK, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) RETURN END SUBROUTINE DMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I SUBROUTINE DMUMPS_SET_INNERBLOCKSIZE( SIZE_INNER, & NASS, KEEP ) IMPLICIT NONE INTEGER :: SIZE_INNER, NASS, KEEP(500) IF (NASS.LT.KEEP(4)) THEN SIZE_INNER = NASS ELSE IF (NASS .GT. KEEP(3)) THEN SIZE_INNER = min( KEEP(6), NASS ) ELSE SIZE_INNER = min( KEEP(5), NASS ) ENDIF RETURN END SUBROUTINE DMUMPS_SET_INNERBLOCKSIZE SUBROUTINE DMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) DOUBLE PRECISION :: OPELI INTEGER(8) :: KEEP8( 150 ) CALL MUMPS_SETDVAL_ADDR_C(OPELI, KEEP8(84)) RETURN END SUBROUTINE DMUMPS_UPDATE_PROGRESS MUMPS_5.8.1/src/mumps_static_mapping.F0000664000175000017500000055204115042446423017572 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_STATIC_MAPPING USE MUMPS_LR_COMMON IMPLICIT NONE PRIVATE PUBLIC :: MUMPS_DISTRIBUTE, MUMPS_RETURN_CANDIDATES, & MUMPS_INIT_ARCH_PARAMETERS,MUMPS_END_ARCH_CV, & MUMPS_SET_K78_83_91 integer,pointer,dimension(:,:),SAVE::cv_cand integer,pointer,dimension(:),SAVE::cv_par2_nodes integer,SAVE::cv_slavef,cv_nb_niv2,cv_lp,cv_mp integer, parameter:: tsplit_beg=4 integer, parameter:: tsplit_mid=5 integer, parameter:: tsplit_last=6 integer,parameter::cv_invalid=-9999 DOUBLE PRECISION,parameter::cv_d_invalid=-9999.D0 integer,parameter::cv_equilib_flops=1 integer,parameter::cv_equilib_mem=2 integer,parameter::cv_error_memalloc = -13 integer,parameter::cv_error_memdeloc = -96 integer,dimension(:),allocatable,save :: mem_distribtmp integer, dimension(:),allocatable, save :: table_of_process integer,dimension(:),allocatable,save :: mem_distribmpi integer, save ::ke69,nb_arch_nodes logical,dimension(:),allocatable,save :: allowed_nodes integer,dimension(:),allocatable,save :: score type nodelist integer::nodenumber type(nodelist),pointer::next end type nodelist type alloc_arraytype integer, pointer, dimension(:)::t2_nodenumbers integer, pointer, dimension(:,:)::t2_cand DOUBLE PRECISION, pointer, dimension(:)::t2_candcostw, & t2_candcostm integer:: nmb_t2s end type alloc_arraytype type splitting_data integer:: new_ison,new_ifather,old_keep2 DOUBLE PRECISION:: ncostw_oldinode,ncostm_oldinode, & tcostw_oldinode,tcostm_oldinode end type splitting_data type procs4node_t integer, dimension(:), pointer :: ind_proc end type procs4node_t DOUBLE PRECISION, pointer, dimension(:) :: & cv_proc_workload, & cv_proc_maxwork, & cv_proc_memused, & cv_proc_maxmem type(splitting_data)::cv_last_splitting integer::cv_n,cv_nsteps,cv_maxlayer, & cv_nbsa,cv_maxnsteps,cv_maxdepth, & cv_maxnodenmb,cv_total_amalg,cv_total_split, & cv_bitsize_of_int,cv_size_ind_proc & ,cv_mixed_strat_bound,cv_dist_L0_mixed_strat_bound & ,cv_layerl0_end,cv_layerl0_start integer :: layerL0_endforarrangeL0 DOUBLE PRECISION :: mincostw DOUBLE PRECISION:: cv_costw_upper,cv_costm_upper, & cv_costw_layer0,cv_costm_layer0,cv_relax, & cv_costw_total,cv_costm_total,cv_l0wthresh logical::cv_constr_work,cv_constr_mem integer,pointer,dimension(:):: cv_nodetype,cv_nodelayer, & cv_layerl0_array,cv_proc_sorted,cv_depth integer,dimension(:),pointer:: & cv_ne,cv_nfsiz,cv_frere,cv_fils,cv_keep,cv_info, & cv_procnode,cv_ssarbr,cv_icntl integer(8),dimension(:),pointer::cv_keep8 type(alloc_arraytype),pointer,dimension(:)::cv_layer_p2node DOUBLE PRECISION,dimension(:),pointer:: cv_ncostw, & cv_tcostw,cv_ncostm,cv_tcostm,cv_layerworkload,cv_layermemused & ,cv_layerl0_sorted_costw type(procs4node_t),dimension(:),pointer :: cv_prop_map integer, dimension(:), pointer :: cv_SIZEOFBLOCKS logical :: cv_BLKON contains subroutine MUMPS_DISTRIBUTE(n,slavef,icntl,info, & ne,nfsiz,frere,fils,keep,KEEP8, & procnode,ssarbr,nbsa,peak,istat & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) implicit none integer,intent(in)::n,slavef integer, intent(inout),TARGET:: ne(n),nfsiz(n), & procnode(n),ssarbr(n),frere(n),fils(n),keep(500), & icntl(60),info(80) integer, intent(in) :: LSIZEOFBLOCKS integer, intent(in) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) INTEGER(8) KEEP8(150) integer,intent(out)::nbsa,istat integer ierr,nmb_thislayer,layernmb,mapalgo,allocok,i integer,pointer,dimension(:)::thislayer integer,parameter::memonly=1,floponly=2,hybrid=3 DOUBLE PRECISION:: & maxwork,minwork,maxmem,minmem,workbalance,membalance DOUBLE PRECISION:: cost_root_node DOUBLE PRECISION,dimension(:),allocatable:: work_per_proc integer,dimension(:),allocatable::id_son logical :: cont character (len=48):: err_rep,subname DOUBLE PRECISION peak logical :: BLKON BLKON = (SIZEOFBLOCKS(1).GT.0) cv_BLKON = BLKON istat=-1 subname='DISTRIBUTE' cv_lp=icntl(1) cv_mp=icntl(3) IF (icntl(4).LT.2) cv_mp=0 nullify(thislayer) err_rep='INITPART1' call MUMPS_INITPART1(n,slavef, & frere,fils,nfsiz,ne,keep,KEEP8,icntl,info, & procnode,ssarbr,peak,ierr & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) if (ierr.ne.0) goto 99999 err_rep='PROCINIT' call MUMPS_PROCINIT(istat=ierr) if (ierr.ne.0) goto 99999 err_rep='CALCCOST' call MUMPS_CALCCOSTS(ierr) if (ierr.ne.0) goto 99999 err_rep='ROOTLIST' call MUMPS_ROOTLIST(ierr) if (ierr.ne.0) goto 99999 err_rep='LAYERL0' call MUMPS_LAYERL0(ierr) if (ierr.ne.0) goto 99999 if (ierr.ne.0) goto 99999 err_rep='INITPART2' call MUMPS_INITPART2(ierr) if (ierr.ne.0) goto 99999 err_rep='WORKMEM_' call MUMPS_WORKMEM_IMBALANCE( & cv_proc_workload,cv_proc_memused, & maxwork,minwork,maxmem,minmem) if(maxwork.gt.0.0D0) then workbalance=minwork/maxwork else workbalance=0.0D0 endif if(maxmem.gt.0.0D0) then membalance=minmem/maxmem else membalance=0.0D0 endif err_rep='mem_alloc' allocate(thislayer(cv_maxnodenmb),STAT=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = 2*cv_maxnsteps+cv_maxnodenmb if(cv_lp.gt.0) & write(cv_lp,*)'memory allocation error in ',subname ierr = cv_error_memalloc goto 99999 end if cont=.TRUE. layernmb=0 mapalgo=floponly err_rep='SELECT_TYPE3' call MUMPS_SELECT_TYPE3(ierr) if (ierr.ne.0) goto 99999 IF (cv_keep(38) .ne. 0 .and. cv_keep(60) .eq. 0 ) THEN call MUMPS_GET_FLOPS_COST(cv_nfsiz(keep(38)), & cv_nfsiz(keep(38)), cv_nfsiz(keep(38)), & cv_keep(50), 3, cost_root_node) cost_root_node = cost_root_node / dble(cv_slavef) do i=1, cv_slavef cv_proc_memused(i)=cv_proc_memused(i)+ & dble(cv_nfsiz(keep(38)))*dble(cv_nfsiz(keep(38)))/ & dble(cv_slavef) cv_proc_workload(i)=cv_proc_workload(i)+dble(cost_root_node) enddo ENDIF do while((cont).OR.(layernmb.le.cv_maxlayer)) err_rep='FIND_THIS' call MUMPS_FIND_THISLAYER(layernmb,thislayer,nmb_thislayer, & ierr) if (ierr.ne.0) goto 99999 err_rep='DO_SPLITTING' if(cv_keep(82) .gt. 0) then if(layernmb.gt.0) call MUMPS_SPLIT_DURING_MAPPING & (layernmb,thislayer,nmb_thislayer,ierr) endif if (ierr.ne.0) goto 99999 err_rep='ASSIGN_TYPES' call MUMPS_ASSIGN_TYPES(layernmb,thislayer,nmb_thislayer, & ierr) if (ierr.ne.0) goto 99999 if(layernmb.gt.0) then if ((cv_keep(24).eq.1).OR.(cv_keep(24).eq.2).OR. & (cv_keep(24).eq.4).OR.(cv_keep(24).eq.6)) then err_rep='COSTS_LAYER_T2' call MUMPS_COSTS_LAYER_T2(layernmb,nmb_thislayer,ierr) elseif((cv_keep(24).eq.8).OR.(cv_keep(24).eq.10) & .OR.(cv_keep(24).eq.12).OR.(cv_keep(24).eq.14) & .OR.(cv_keep(24).eq.16).OR.(cv_keep(24).eq.18)) then err_rep='COSTS_LAYER_T2PM' call MUMPS_COSTS_LAYER_T2PM(layernmb,nmb_thislayer,ierr) else err_rep='wrong strategy for COSTS_LAYER_T2' ierr = -9999 endif if (ierr.ne.0) goto 99999 err_rep='WORKMEM_' call MUMPS_WORKMEM_IMBALANCE( & cv_proc_workload,cv_proc_memused, & maxwork,minwork,maxmem,minmem) if(maxwork.gt.0.0D0) then workbalance=minwork/maxwork else workbalance=0.0D0 endif if(maxmem.gt.0.0D0) then membalance=minmem/maxmem else membalance=0.0D0 endif if(mapalgo.eq.memonly) then err_rep='MAP_LAYER' call MUMPS_MAP_LAYER(layernmb,thislayer, & nmb_thislayer,cv_equilib_mem,ierr) if (ierr.ne.0) goto 99999 elseif(mapalgo.eq.floponly) then err_rep='MAP_LAYER' call MUMPS_MAP_LAYER(layernmb,thislayer, & nmb_thislayer,cv_equilib_flops,ierr) if (ierr.ne.0) goto 99999 elseif(mapalgo.eq.hybrid) then if (workbalance <= membalance) then err_rep='MAP_LAYER' call MUMPS_MAP_LAYER(layernmb,thislayer, & nmb_thislayer,cv_equilib_flops,ierr) if (ierr.ne.0) goto 99999 else err_rep='MAP_LAYER' call MUMPS_MAP_LAYER(layernmb,thislayer, & nmb_thislayer,cv_equilib_mem,ierr) if (ierr.ne.0) goto 99999 endif else if(cv_lp.gt.0) & write(cv_lp,*)'Unknown mapalgo in ',subname return endif endif layernmb=layernmb+1 err_rep='HIGHER_LAYER' call MUMPS_HIGHER_LAYER(layernmb,thislayer, & nmb_thislayer,cont,ierr) if (ierr.ne.0) goto 99999 end do IF ( (cv_keep(79).EQ.0).OR.(cv_keep(79).EQ.3).OR. & (cv_keep(79).EQ.5).OR.(cv_keep(79).EQ.7) & ) THEN if(cv_slavef.gt.4) then err_rep='POSTPROCESS' call MUMPS_POSTPROCESS_MEM() endif ENDIF err_rep='SETUP_CAND' call MUMPS_SETUP_CAND(ierr) if (ierr.ne.0) goto 99999 err_rep='ENCODE_PROC' call MUMPS_ENCODE_PROCNODE(ierr) if (ierr.ne.0) goto 99999 err_rep='STORE_GLOB' call MUMPS_STORE_GLOBALS(ne,nfsiz,frere,fils,keep,KEEP8, & info,procnode,ssarbr,nbsa) err_rep='mem_dealloc' deallocate(thislayer,STAT=ierr) if (ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ',subname ierr = cv_error_memdeloc goto 99999 endif err_rep='TERMGLOB' call MUMPS_TERMGLOB(ierr) if (ierr.ne.0) goto 99999 istat=0 return 99999 continue if(cv_lp.gt.0) then write(cv_lp,*)'Error in ',subname,', layernmb=',layernmb write(cv_lp,*)'procedure reporting the error: ',err_rep endif if(ierr.eq.cv_error_memalloc) then info(1) = cv_info(1) info(2) = cv_info(2) endif istat=ierr return CONTAINS subroutine MUMPS_ACCEPT_L0( & map_strat,workload,memused,accepted, & istat) implicit none integer,intent(in)::map_strat DOUBLE PRECISION,dimension(:),intent(in)::workload, memused logical,intent(out)::accepted integer,intent(out)::istat DOUBLE PRECISION maxi,mini,mean,stddev, dpkeep102 integer i,nmb character (len=48):: subname logical alternative_criterion DOUBLE PRECISION:: & MINFLOPS , MINMEM, & CL_RATE, DV_RATE istat=-1 if ( cv_keep(72) .EQ. 1) then MINFLOPS = 2.0D0 MINMEM=50.0D0 CL_RATE =0.8D0 DV_RATE=0.2D0 else IF (cv_keep(198).NE.0) THEN MINFLOPS = 5.0D8 MINMEM=5.0D7 CL_RATE =0.8D0 DV_RATE=0.2D0 ELSE MINFLOPS = 5.0D7 MINMEM=5.0D6 CL_RATE =0.8D0 DV_RATE=0.2D0 ENDIF endif IF (cv_keep(102) .NE. -1) THEN dpkeep102 = max(dble(cv_keep(102)),dble(100)) ELSE IF(cv_slavef.LT.48)THEN dpkeep102=dble(150) ELSEIF(cv_slavef.LT.128)THEN dpkeep102=dble(150) ELSEIF(cv_slavef.LT.256)THEN dpkeep102=dble(200) ELSEIF(cv_slavef.LT.512)THEN dpkeep102=dble(300) ELSEIF(cv_slavef.GE.512)THEN dpkeep102=dble(400) ENDIF ENDIF IF (cv_keep(198).NE.0) THEN IF (cv_slavef.LT.3)THEN dpkeep102 = max(dble(150), dpkeep102) ELSEIF (cv_slavef.LT.5)THEN dpkeep102 = max(dble(200), dpkeep102) ELSEIF (cv_slavef.LT.8)THEN dpkeep102 = max(dble(250), dpkeep102) ELSEIF (cv_slavef.LT.32)THEN dpkeep102 = max(dble(275), dpkeep102) ELSEIF (cv_slavef.LT.512)THEN dpkeep102 = max(dble(300), dpkeep102) ELSEIF (cv_slavef.GE.512)THEN dpkeep102 = max(dble(400), dpkeep102) ENDIF ENDIF subname='ACCEPT_L0' accepted=.FALSE. alternative_criterion=.FALSE. if(map_strat.eq.cv_equilib_flops) then maxi=maxval(workload) mini=minval(workload) if (maxi.lt.MINFLOPS) then accepted=.TRUE. elseif(maxi.le.(dpkeep102/dble(100))*mini)then accepted=.TRUE. endif if ((.NOT.accepted).AND.(alternative_criterion)) then mean=sum(workload)/max(dble(cv_slavef),dble(1)) stddev=dble(0) do i=1,cv_slavef stddev=stddev+ & (abs(workload(i)-mean)*abs(workload(i)-mean)) enddo stddev=sqrt(stddev/max(dble(cv_slavef),dble(1))) nmb=count(mask=abs(workload-mean)0) in=cv_fils(in) end do in=-in do while(in.gt.0) call MUMPS_TYPEINSSARBR(in) in=cv_frere(in) enddo enddo do i=1,cv_n if (cv_frere(i).lt.cv_n+1) then if(cv_nodetype(i).eq.cv_invalid) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname return endif if (i.eq.cv_keep(38)) then if (cv_nodetype(i).ne.3) then cv_nodetype(i)=3 endif endif cv_procnode(i)=MUMPS_ENCODE_TPN_IPROC( cv_nodetype(i), & cv_procnode(i)-1, cv_keep(199)) in=cv_fils(i) do while (in>0) cv_procnode(in)=cv_procnode(i) in=cv_fils(in) end do end if end do istat = 0 return end subroutine MUMPS_ENCODE_PROCNODE subroutine MUMPS_FATHSON_REPLACE(ifather,istat) implicit none integer,intent(in)::ifather integer,intent(out)::istat integer in,son,oldl0end logical father_has_sons character (len=48):: subname istat=-1 subname='FATHSON_REPLACE' father_has_sons=.TRUE. in=ifather do while (in.gt.0) in=cv_fils(in) end do if(in.eq.0) then cv_nodelayer(ifather)=1 cv_keep(262)=cv_keep(262)+1 father_has_sons=.FALSE. end if if(cv_layerl0_end-cv_layerl0_start.gt.0) then cv_layerl0_start= cv_layerl0_start+1 elseif(father_has_sons) then cv_layerl0_start= cv_layerl0_start+1 else istat=1 cv_nodelayer(ifather)=0 return endif cv_nbsa=cv_nbsa-1 oldl0end = cv_layerl0_end if (father_has_sons) then son=-in son=-in 10 continue cv_layerl0_end=cv_layerl0_end+1 if (cv_tcostw(son).GT.mincostw) & layerL0_endforarrangeL0 = layerL0_endforarrangeL0+1 cv_layerl0_array(cv_layerl0_end)=son cv_layerl0_sorted_costw(cv_layerl0_end)=cv_tcostw(son) cv_nbsa=cv_nbsa+1 if((cv_frere(son).gt.0).and.(cv_frere(son).lt.cv_n+1)) then son=cv_frere(son) goto 10 end if endif cv_costw_layer0=cv_costw_layer0 - cv_ncostw(ifather) cv_costm_layer0=cv_costm_layer0 - cv_ncostm(ifather) cv_costw_upper=cv_costw_upper + cv_ncostw(ifather) cv_costm_upper=cv_costm_upper + cv_ncostm(ifather) if(cv_layerl0_end.gt.oldl0end) then call MUMPS_SORT_MSORT(ierr,cv_layerl0_end-oldl0end, & cv_layerl0_array(oldl0end+1:cv_layerl0_end), & cv_layerl0_sorted_costw(oldl0end+1:cv_layerl0_end)) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*) 'Error reported by MUMPS_SORT_MSORT in', & subname istat = ierr return endif call MUMPS_SORT_MMERGE( & cv_layerl0_start,oldl0end,oldl0end-cv_layerl0_start+1, & oldl0end+1,cv_layerl0_end,cv_layerl0_end-oldl0end, & cv_layerl0_array(1:cv_layerl0_end), & cv_layerl0_sorted_costw(1:cv_layerl0_end),ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*) & 'Error reported by MUMPS_SORT_MMERGE in', & subname istat = ierr return endif endif istat=0 return end subroutine MUMPS_FATHSON_REPLACE subroutine MUMPS_FIND_BEST_PROC(inode,map_strat,work,mem, & workload,memused,proc,istat,respect_prop) !DEC$ NOOPTIMIZE implicit none integer, intent(in)::inode,map_strat DOUBLE PRECISION,intent(in)::work,mem DOUBLE PRECISION,dimension(:),intent(inout)::workload, memused integer,intent(out):: proc,istat logical,intent(in),OPTIONAL::respect_prop integer i logical respect_proportional DOUBLE PRECISION dummy character (len=48):: subname istat=-1 respect_proportional=.FALSE. if(present(respect_prop)) respect_proportional=respect_prop subname='FIND_BEST_PROC' proc=-1 if((map_strat.ne.cv_equilib_flops).and. & (map_strat.ne.cv_equilib_mem)) return dummy=huge(dummy) do i=cv_slavef,1,-1 if ( & ((.NOT.respect_proportional) & .OR. & (MUMPS_BIT_GET4PROC(inode,i).AND.respect_proportional)) & .AND. & (((workload(i).lt.dummy).AND. & (map_strat.eq.cv_equilib_flops)) & .OR. & ((memused(i).lt.dummy).AND. & (map_strat.eq.cv_equilib_mem))))then if((.not.cv_constr_work).or. & (workload(i)+work.lt.cv_proc_maxwork(i))) then if((.not.cv_constr_mem).or. & (memused(i)+mem.lt.cv_proc_maxmem(i))) then proc=i if(map_strat.eq.cv_equilib_flops) then dummy=workload(i) elseif(map_strat.eq.cv_equilib_mem) then dummy=memused(i) endif end if end if end if end do if (proc.ne.-1) then workload(proc)=workload(proc)+work memused(proc)=memused(proc)+mem istat=0 end if return end subroutine MUMPS_FIND_BEST_PROC subroutine MUMPS_FIND_THISLAYER(nmb, & thislayer,nmb_thislayer,istat) implicit none integer, intent(in)::nmb integer,intent(out) :: thislayer(:) integer,intent(out) :: nmb_thislayer,istat integer i character (len=48):: subname istat=-1 subname='FIND_THISLAYER' thislayer=0 nmb_thislayer=0 if((nmb.lt.0).or.(nmb.gt.cv_maxlayer)) return do i=1,cv_n if(cv_nodelayer(i).eq.nmb) then nmb_thislayer=nmb_thislayer+1 if(nmb_thislayer.gt.cv_maxnodenmb) then if(cv_lp.gt.0) & write(cv_lp,*)'Problem with nmb_thislayer in ',subname return endif thislayer(nmb_thislayer)=i end if end do istat=0 return end subroutine MUMPS_FIND_THISLAYER subroutine MUMPS_HIGHER_LAYER(startlayer,thislayer, & nmb_thislayer,cont,istat) implicit none integer,intent(in)::startlayer,nmb_thislayer integer,intent(in)::thislayer(:) logical,intent(inout)::cont integer,intent(out)::istat integer :: visited integer il,i,current,in,ifather logical father_valid,upper_layer_exists character (len=48):: subname istat=-1 subname='HIGHER_LAYER' if(.NOT.cont) return if(startlayer.lt.1) return current=startlayer-1 visited = -current-1 upper_layer_exists=.FALSE. if (current.eq.0) then do i=1,cv_n if (cv_nodelayer(i).ne.current) then if(cv_nodelayer(i).eq.1) then upper_layer_exists=.TRUE. exit endif endif enddo endif do il=1,nmb_thislayer i = thislayer(il) in=i if (cv_nodetype(in).eq.tsplit_beg) then do while (cv_frere(in).lt.0) ifather = -cv_frere(in) if (abs(cv_nodetype(ifather)).eq.tsplit_mid) then in = ifather cv_nodelayer (in) = -visited-1 cycle else if (abs(cv_nodetype(ifather)).eq.tsplit_last) then in = ifather cv_nodelayer (in) = current exit else write(6,*) ' Internal error 1 in MUMPS_HIGHER_LAYER' call MUMPS_ABORT() endif end do endif enddo do il=1,nmb_thislayer i = thislayer(il) if (cv_nodelayer(i).lt.current) cycle in=i if (cv_nodetype(in).eq.tsplit_beg) then cv_nodelayer (in) = visited do while (cv_frere(in).lt.0) ifather = -cv_frere(in) if (abs(cv_nodetype(ifather)).eq.tsplit_mid) then in = ifather cv_nodelayer (in) = -visited-1 cycle else if (abs(cv_nodetype(ifather)).eq.tsplit_last) then in = ifather exit else write(6,*) ' Internal error 1 in MUMPS_HIGHER_LAYER', & cv_nodetype(ifather) call MUMPS_ABORT() endif end do endif if(cv_frere(in).eq.0) cycle cv_nodelayer (in) = visited father_valid=.TRUE. do while(cv_frere(in).gt.0) if (cv_nodelayer(cv_frere(in)).gt.current) then father_valid=.FALSE. in = cv_frere(in) cycle endif if (cv_nodelayer(cv_frere(in)).eq.visited) exit in=cv_frere(in) if (cv_nodelayer(in).eq.current) then cv_nodelayer(in) = visited endif end do if (.not.father_valid .or. cv_frere(in).gt.0) then cycle endif ifather=-cv_frere(in) if(cv_nodelayer(ifather).eq.current+1) then cycle endif in=ifather do while (cv_fils(in).gt.0) in=cv_fils(in) end do in=-cv_fils(in) if(cv_nodelayer(in).gt.current) then father_valid=.FALSE. else father_valid=.TRUE. do while(cv_frere(in).gt.0) in=cv_frere(in) if(cv_nodelayer(in).gt.current) then father_valid=.FALSE. exit endif if(cv_nodelayer(in).eq.visited) then exit endif end do endif if(father_valid) then cv_nodelayer(ifather)=current+1 upper_layer_exists=.TRUE. end if end do if (upper_layer_exists) then current=current+1 cv_maxlayer=current cont=.TRUE. else cv_maxlayer=current cont=.FALSE. endif do il=1,nmb_thislayer i = thislayer(il) if (cv_nodelayer(i).eq.visited) cv_nodelayer(i) = -visited-1 enddo istat=0 return end subroutine MUMPS_HIGHER_LAYER subroutine MUMPS_INITPART1(n,slavef, & frere,fils,nfsiz,ne,keep,KEEP8,icntl,info, & procnode,ssarbr,peak,istat & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) implicit none integer, intent(in)::n,slavef integer, intent(in), TARGET:: frere(n),fils(n),nfsiz(n),ne(n), & keep(500),icntl(60),info(80), & procnode(n),ssarbr(n) INTEGER(8), intent(in), TARGET:: KEEP8(150) integer,intent(out)::istat integer, intent(in) :: LSIZEOFBLOCKS integer, intent(in), TARGET :: SIZEOFBLOCKS(LSIZEOFBLOCKS) integer i,allocok,rest DOUBLE PRECISION peak character (len=48):: subname istat=-1 nullify(cv_frere,cv_fils,cv_nfsiz,cv_ne,cv_keep,cv_keep8, & cv_icntl,cv_info,cv_procnode,cv_ssarbr) nullify(cv_ncostw,cv_tcostw,cv_ncostm,cv_tcostm, & cv_nodelayer,cv_nodetype,cv_depth, & cv_layerworkload,cv_layermemused,cv_prop_map) nullify(cv_SIZEOFBLOCKS) cv_SIZEOFBLOCKS => SIZEOFBLOCKS subname='INITPART1' cv_n=n cv_slavef=slavef cv_keep=>keep cv_keep8=>KEEP8 if(cv_keep(82) .lt. 0) then write(cv_lp,*) & 'Warning in mumps_static_mapping : splitting is set off' cv_keep(82) = 0 endif if(abs(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(abs(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_relax=dble(1) + dble(max(0,keep(68)))/dble(100) cv_maxlayer=0 cv_maxnsteps= cv_nsteps+1 cv_layerworkload=dble(0) cv_layermemused=dble(0) cv_total_amalg=0 cv_total_split=0 cv_last_splitting%new_ison=cv_invalid cv_last_splitting%new_ifather=cv_invalid cv_last_splitting%old_keep2=cv_invalid cv_last_splitting%ncostw_oldinode=cv_d_invalid cv_last_splitting%ncostm_oldinode=cv_d_invalid cv_last_splitting%tcostw_oldinode=cv_d_invalid cv_last_splitting%tcostm_oldinode=cv_d_invalid do i=1,cv_n nullify(cv_prop_map(i)%ind_proc) end do istat=0 return end subroutine MUMPS_INITPART1 subroutine MUMPS_INITPART2(istat) implicit none integer,intent(out)::istat integer i,allocok,inode,in,inoderoot,ierr,maxcut character (len=48):: subname istat=-1 subname='INITPART2' if(associated(cv_layerl0_array))deallocate(cv_layerl0_array) if(associated(cv_layerl0_sorted_costw)) & deallocate(cv_layerl0_sorted_costw) deallocate(cv_depth,cv_tcostw,cv_tcostm,STAT=ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ',subname istat = cv_error_memdeloc return end if if(cv_maxnsteps.lt.1) then if(cv_lp.gt.0) & write(cv_lp,*)'problem with maxnsteps in ',subname return end if cv_maxnodenmb=cv_maxnsteps do i=1,cv_nbsa inode=cv_ssarbr(i) inoderoot=inode 300 continue in = inode do while (in.ne.0) inode = in do while (in.gt.0) in = cv_fils(in) end do if (in.lt.0) in=-in end do 100 continue if (inode.ne.inoderoot) then cv_maxnodenmb=cv_maxnodenmb-1 in = cv_frere(inode) inode = abs(in) if (in.lt.0) then go to 100 else go to 300 end if end if end do if(cv_keep(82) .gt. 0) then maxcut = min((cv_keep(82)-1)*cv_maxnodenmb,cv_n) cv_maxnsteps = min(cv_maxnsteps+maxcut,cv_n) cv_maxnodenmb = min(cv_maxnodenmb+maxcut,cv_n) endif nullify(cv_layer_p2node) if(cv_maxnodenmb.lt.0) then if(cv_lp.gt.0) & write(cv_lp,*)'problem with maxnodenmb in ',subname return elseif(cv_maxnodenmb.lt.1) then cv_maxnodenmb = 1 end if allocate(cv_layer_p2node(cv_maxnodenmb),STAT=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = cv_maxnodenmb istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*)'memory allocation error in ',subname return end if do i=1,cv_maxnodenmb nullify(cv_layer_p2node(i)%t2_nodenumbers, & cv_layer_p2node(i)%t2_cand, & cv_layer_p2node(i)%t2_candcostw, & cv_layer_p2node(i)%t2_candcostm) cv_layer_p2node(i)%nmb_t2s=0 enddo istat = 0 end subroutine MUMPS_INITPART2 function MUMPS_ISTYPE2BYSIZE(nfront,npiv) implicit none logical::MUMPS_ISTYPE2BYSIZE integer,intent(in)::nfront,npiv MUMPS_ISTYPE2BYSIZE=.FALSE. if( (nfront - npiv > cv_keep(9)) & .and. ((npiv > cv_keep(4)).or.(.TRUE.)) & .and. (cv_icntl(59).eq.0) ) MUMPS_ISTYPE2BYSIZE=.TRUE. return end function MUMPS_ISTYPE2BYSIZE subroutine MUMPS_LAYERL0(istat) implicit none integer,intent(out)::istat integer i,ierr,inode logical accepted integer,parameter::map_strat=cv_equilib_flops character (len=48):: err_rep,subname logical use_geist_ng_replace, skiparrangeL0 INTEGER MINSIZE_L0 INTEGER CURRENT_SIZE_L0 istat=-1 subname='LAYERL0' accepted=.FALSE. IF (cv_keep(72).EQ.2) THEN MINSIZE_L0 = 6*cv_slavef ELSE IF (cv_keep(198).NE.0) THEN IF (cv_keep(198).EQ.1) THEN MINSIZE_L0 = 3*cv_slavef ELSE MINSIZE_L0 = 2*cv_slavef ENDIF ELSE MINSIZE_L0 = 3*cv_slavef ENDIF ENDIF 55 continue skiparrangeL0 = .false. do while(.not.accepted) IF (cv_keep(198).EQ.2) THEN CURRENT_SIZE_L0 = layerL0_endforarrangeL0 ELSE CURRENT_SIZE_L0 = layerL0_endforarrangeL0 ENDIF IF ( ( (CURRENT_SIZE_L0.LT.MINSIZE_L0) & .OR. skiparrangeL0 & ) & .AND. & (cv_layerl0_end.LT.cv_maxnsteps/2) ) THEN accepted = .false. ELSE err_rep='ARRANGEL0' call MUMPS_ARRANGEL0(map_strat, layerL0_endforarrangeL0, & cv_layerworkload,cv_layermemused, & cv_procnode,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error reported by ',err_rep,' in ',subname istat = ierr return end if err_rep='ACCEPT_L0' call MUMPS_ACCEPT_L0(map_strat, & cv_layerworkload,cv_layermemused, & accepted,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error reported by ',err_rep,' in ',subname istat = ierr return end if ENDIF IF (cv_keep(198).EQ.0) THEN IF (cv_slavef.GT.16) & skiparrangeL0 = .NOT.skiparrangeL0 ENDIF if (accepted.OR.(cv_costw_total.le.0.0D0)) then exit elseif(((cv_costw_layer0/cv_costw_total).gt.cv_l0wthresh) .AND. & (.TRUE.))then err_rep='MAX_TCOST_L0' inode = cv_layerl0_array(cv_layerl0_start) use_geist_ng_replace = .TRUE. if(use_geist_ng_replace) then err_rep='FATHSON_REPLACE' call MUMPS_FATHSON_REPLACE(inode,ierr) if(ierr.eq.1) then accepted=.TRUE. elseif(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*) & 'Error rep. by ',err_rep,' in ',subname istat = ierr return endif endif else accepted=.TRUE. end if end do accepted=.TRUE. if (accepted) then else goto 55 endif err_rep='LIST2LAYER' call MUMPS_LIST2LAYER(ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error reported by ',err_rep,' in ',subname istat = ierr return end if err_rep='MAKE_PROPMAP' call MUMPS_MAKE_PROPMAP(ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error reported by ',err_rep,' in ',subname istat = ierr return end if if ( cv_keep(75).EQ.1 ) then call MUMPS_ARRANGEL0(map_strat, cv_layerl0_end, & cv_layerworkload,cv_layermemused, & cv_procnode,ierr, respect_prop=.TRUE.) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error reported by ',err_rep,' in ',subname istat = ierr return end if else if (layerL0_endforarrangeL0.LT.cv_layerl0_end) THEN call MUMPS_ARRANGEL0(map_strat, cv_layerl0_end, & cv_layerworkload,cv_layermemused, & cv_procnode,ierr) endif call MUMPS_MAPSUBTREE(cv_procnode) do i=1,cv_slavef cv_proc_workload(i)=cv_layerworkload(i) cv_proc_memused(i)=cv_layermemused(i) end do istat=0 return end subroutine MUMPS_LAYERL0 subroutine MUMPS_LIST2LAYER(istat) implicit none integer, intent(out)::istat character (len=48):: subname integer i,inode istat=-1 subname='LIST2LAYER' cv_dist_L0_mixed_strat_bound=0 cv_nbsa=0 do i=cv_layerl0_start,cv_layerl0_end inode=cv_layerl0_array(i) if(inode.gt.0) then cv_dist_L0_mixed_strat_bound=max(cv_dist_L0_mixed_strat_bound & ,max(cv_depth(inode)-cv_mixed_strat_bound,0)) cv_nodelayer(inode)=0 cv_nbsa=cv_nbsa+1 cv_ssarbr(cv_nbsa)=inode endif enddo istat=0 return end subroutine MUMPS_LIST2LAYER subroutine MUMPS_MAKE_PROPMAP(istat) implicit none integer,intent(out)::istat integer i,pctr,pctr2,ierr character (len=48):: subname INTEGER, ALLOCATABLE, DIMENSION(:) :: procindex INTEGER :: allocok subname = "MUMPS_MAKE_PROPMAP" istat = -1 ALLOCATE(procindex(cv_size_ind_proc),stat=allocok) IF (allocok > 0) THEN cv_info(1) = cv_error_memalloc cv_info(2) = cv_maxnodenmb istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*) 'Memory allocation error in ',subname return ENDIF pctr=cv_n pctr2=cv_mixed_strat_bound do i=1,cv_slavef call MUMPS_BIT_SET(procindex,i,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'MUMPS_BIT_SET signalled error to ',subname istat = ierr GOTO 999 end if end do do i=1,cv_n if(cv_frere(i).eq.0) then if(.NOT.associated(cv_prop_map(i)%ind_proc)) then call MUMPS_PROPMAP_INIT(i,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'PROPMAP_INIT signalled error to' & ,subname istat = ierr GOTO 999 end if endif cv_prop_map(i)%ind_proc = procindex call MUMPS_PROPMAP(i,pctr,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'PROPMAP signalled error to ',subname istat = ierr GOTO 999 endif if( (cv_keep(24).eq.16.OR.cv_keep(24).eq.18) & .and.cv_keep(77) .ne.0) then call MUMPS_MOD_PROPMAP(i,pctr2,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'MOD_PROPMAP signalled error to ',subname istat = ierr GOTO 999 endif endif endif end do istat = 0 999 CONTINUE DEALLOCATE(procindex) return end subroutine MUMPS_MAKE_PROPMAP subroutine MUMPS_MAP_LAYER(layernmb,thislayer, & nmb_thislayer,map_strat,istat) implicit none integer, intent(in)::layernmb,thislayer(:), & nmb_thislayer,map_strat integer,intent(out)::istat integer i,inode,j,k,ierr,nmb,aux_int,nmb_cand_needed DOUBLE PRECISION aux_flop,aux_mem INTEGER, ALLOCATABLE, DIMENSION(:) :: candid, sorted_nmb DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: & sorted_costw, sorted_costm, old_workload, old_memused character (len=48):: err_rep,subname logical use_propmap istat=-1 subname='MAP_LAYER' if((cv_keep(24).eq.8).OR.(cv_keep(24).eq.10) & .OR.(cv_keep(24).eq.12).OR.(cv_keep(24).eq.14) & .OR.(cv_keep(24).eq.16).OR.(cv_keep(24).eq.18)) then use_propmap=.TRUE. else use_propmap=.FALSE. endif if((layernmb.lt.0).or.(layernmb.gt.cv_maxlayer)) return if((map_strat.ne.cv_equilib_flops).and. & (map_strat.ne.cv_equilib_mem)) return ALLOCATE(candid(cv_slavef), sorted_nmb(2*nmb_thislayer), & sorted_costw(2*nmb_thislayer), sorted_costm(2*nmb_thislayer), & old_workload(cv_slavef), old_memused(cv_slavef), stat=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = 7*nmb_thislayer+2*cv_slavef istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*)'memory allocation error in ',subname goto 999 end if do i=1,nmb_thislayer inode=thislayer(i) if (cv_nodetype(inode).eq.3) then cv_procnode(inode)=1 exit end if end do do i=1,cv_slavef old_workload(i)=cv_layerworkload(i) old_memused(i)=cv_layermemused(i) enddo nmb=0 do i=1,nmb_thislayer inode=thislayer(i) if(cv_nodetype(inode).eq.1) then nmb=nmb+1 sorted_nmb(nmb)=inode sorted_costw(nmb)=cv_ncostw(inode) sorted_costm(nmb)=cv_ncostm(inode) else if(MUMPS_IS_NODE_OF_TYPE2(inode)) then nmb=nmb+1 do j=1,cv_layer_p2node(layernmb)%nmb_t2s if(cv_layer_p2node(layernmb)%t2_nodenumbers(j).ne.inode) & then cycle else sorted_costw(nmb)= & cv_layer_p2node(layernmb)%t2_candcostw(j) sorted_costm(nmb)= & cv_layer_p2node(layernmb)%t2_candcostm(j) endif enddo if((sorted_costw(nmb).eq.cv_d_invalid).OR. & (sorted_costm(nmb).eq.cv_d_invalid)) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 end if if(sorted_costw(nmb).lt.cv_ncostw(inode))then sorted_costw(nmb)=cv_ncostw(inode) sorted_costm(nmb)=cv_ncostm(inode) sorted_nmb(nmb)=inode else sorted_nmb(nmb)=-inode endif else if(cv_nodetype(inode).eq.3) then cycle else if(cv_lp.gt.0) & write(cv_lp,*)'Unknown node type. Error in ',subname goto 999 end if end do if (map_strat.eq.cv_equilib_flops) then call MUMPS_SORT_MSORT(ierr,nmb,sorted_nmb(1:nmb), & sorted_costw(1:nmb),sorted_costm(1:nmb)) elseif(map_strat.eq.cv_equilib_mem) then call MUMPS_SORT_MSORT(ierr,nmb,sorted_nmb(1:nmb), & sorted_costm(1:nmb),sorted_costw(1:nmb)) endif if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*) & 'Error reported by MUMPS_SORT_MSORT in ',subname istat = ierr goto 999 endif do i=1,nmb aux_int=sorted_nmb(i) aux_flop=sorted_costw(i) aux_mem=sorted_costm(i) k=1 if (aux_int.lt.0) then inode=-aux_int err_rep='SORTPROCS' if(use_propmap) then call MUMPS_SORTPROCS(map_strat, & cv_proc_workload,cv_proc_memused, & inode=inode,istat=ierr) else call MUMPS_SORTPROCS(map_strat, & cv_proc_workload,cv_proc_memused, & istat=ierr) end if if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*) & 'Error reported by ',err_rep,' in ',subname istat = ierr goto 999 endif nmb_cand_needed=cv_invalid do j=1,cv_layer_p2node(layernmb)%nmb_t2s if(cv_layer_p2node(layernmb)%t2_nodenumbers(j).ne.inode) & then cycle else nmb_cand_needed= & cv_layer_p2node(layernmb)%t2_cand(j,cv_slavef+1) exit endif enddo if(nmb_cand_needed.eq.cv_invalid) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif do while((k.le.cv_slavef).and.(nmb_cand_needed.gt.0)) if(((.not.cv_constr_work).or. & (cv_proc_workload(cv_proc_sorted(k))+aux_flop.lt. & cv_proc_maxwork(cv_proc_sorted(k)))) & .AND.((.not.cv_constr_mem).or. & (cv_proc_memused(cv_proc_sorted(k))+aux_mem.lt. & cv_proc_maxmem(cv_proc_sorted(k)))) & .AND. & (cv_layer_p2node(layernmb)%t2_cand(j,cv_proc_sorted(k)).eq.0)) & then cv_proc_workload(cv_proc_sorted(k))= & cv_proc_workload(cv_proc_sorted(k))+aux_flop cv_proc_memused(cv_proc_sorted(k))= & cv_proc_memused(cv_proc_sorted(k))+aux_mem cv_layer_p2node(layernmb)%t2_cand(j,cv_proc_sorted(k)) & =inode cv_layerworkload(cv_proc_sorted(k))= & cv_layerworkload(cv_proc_sorted(k))+aux_flop cv_layermemused(cv_proc_sorted(k))= & cv_layermemused(cv_proc_sorted(k))+aux_mem nmb_cand_needed=nmb_cand_needed-1 k=k+1 else k=k+1 if(k.gt.cv_slavef) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif end if end do if(nmb_cand_needed.gt.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif aux_flop=cv_ncostw(inode) aux_mem=cv_ncostm(inode) do while(k.le.cv_slavef) if(((.not.cv_constr_work).or. & (cv_proc_workload(cv_proc_sorted(k))+aux_flop.lt. & cv_proc_maxwork(cv_proc_sorted(k)))) & .AND.((.not.cv_constr_mem).or. & (cv_proc_memused(cv_proc_sorted(k))+aux_mem.lt. & cv_proc_maxmem(cv_proc_sorted(k)))) & .AND. & (cv_layer_p2node(layernmb)%t2_cand(j,cv_proc_sorted(k)).eq.0)) & then cv_procnode(inode)=cv_proc_sorted(k) cv_proc_workload(cv_proc_sorted(k))= & cv_proc_workload(cv_proc_sorted(k))+aux_flop cv_proc_memused(cv_proc_sorted(k))= & cv_proc_memused(cv_proc_sorted(k))+aux_mem cv_layer_p2node(layernmb)%t2_cand(j,cv_proc_sorted(k)) & =-inode cv_layerworkload(cv_proc_sorted(k))= & cv_layerworkload(cv_proc_sorted(k))+aux_flop cv_layermemused(cv_proc_sorted(k))= & cv_layermemused(cv_proc_sorted(k))+aux_mem exit else k=k+1 if(k.gt.cv_slavef) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif end if end do else inode=aux_int err_rep='SORTPROCS' if(use_propmap) then call MUMPS_SORTPROCS(map_strat, & cv_proc_workload,cv_proc_memused, & inode=inode,istat=ierr) else call MUMPS_SORTPROCS(map_strat, & cv_proc_workload,cv_proc_memused, & inode,istat=ierr) endif if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*) & 'Error reported by ',err_rep,' in ',subname istat = ierr goto 999 endif if (cv_nodetype(inode).eq.1) then do while(k.le.cv_slavef) if((.not.cv_constr_work).or. & (cv_proc_workload(cv_proc_sorted(k))+aux_flop.lt. & cv_proc_maxwork(cv_proc_sorted(k))) & .AND.((.not.cv_constr_mem).or. & (cv_proc_memused(cv_proc_sorted(k))+aux_mem.lt. & cv_proc_maxmem(cv_proc_sorted(k))))) then cv_procnode(inode)=cv_proc_sorted(k) cv_proc_workload(cv_proc_sorted(k))= & cv_proc_workload(cv_proc_sorted(k))+aux_flop cv_proc_memused(cv_proc_sorted(k))= & cv_proc_memused(cv_proc_sorted(k))+aux_mem cv_layerworkload(cv_proc_sorted(k))= & cv_layerworkload(cv_proc_sorted(k))+aux_flop cv_layermemused(cv_proc_sorted(k))= & cv_layermemused(cv_proc_sorted(k))+aux_mem exit else k=k+1 if(k.gt.cv_slavef) then if(cv_lp.gt.0) & write(cv_lp,*)'Inconsist data in ',subname goto 999 endif end if end do elseif (MUMPS_IS_NODE_OF_TYPE2(inode)) then do j=1,cv_layer_p2node(layernmb)%nmb_t2s if(cv_layer_p2node(layernmb)%t2_nodenumbers(j).ne. & inode) then cycle else exit endif enddo do while(k.le.cv_slavef) if(((.not.cv_constr_work).or. & (cv_proc_workload(cv_proc_sorted(k))+aux_flop.lt. & cv_proc_maxwork(cv_proc_sorted(k)))) & .AND.((.not.cv_constr_mem).or. & (cv_proc_memused(cv_proc_sorted(k))+aux_mem.lt. & cv_proc_maxmem(cv_proc_sorted(k)))) & .AND. & (cv_layer_p2node(layernmb)%t2_cand(j,cv_proc_sorted(k)).eq.0)) & then cv_procnode(inode)=cv_proc_sorted(k) cv_proc_workload(cv_proc_sorted(k))= & cv_proc_workload(cv_proc_sorted(k))+aux_flop cv_proc_memused(cv_proc_sorted(k))= & cv_proc_memused(cv_proc_sorted(k))+aux_mem cv_layer_p2node(layernmb)%t2_cand(j,cv_proc_sorted(k)) & =-inode cv_layerworkload(cv_proc_sorted(k))= & cv_layerworkload(cv_proc_sorted(k))+aux_flop cv_layermemused(cv_proc_sorted(k))= & cv_layermemused(cv_proc_sorted(k))+aux_mem exit else k=k+1 if(k.gt.cv_slavef) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif end if end do nmb_cand_needed=cv_invalid do j=1,cv_layer_p2node(layernmb)%nmb_t2s if(cv_layer_p2node(layernmb)%t2_nodenumbers(j) & .ne.inode) & then cycle else nmb_cand_needed= & cv_layer_p2node(layernmb)% & t2_cand(j,cv_slavef+1) exit endif enddo if(nmb_cand_needed.eq.cv_invalid) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif aux_flop= & cv_layer_p2node(layernmb)%t2_candcostw(j) aux_mem= & cv_layer_p2node(layernmb)%t2_candcostm(j) do while((k.le.cv_slavef).and.(nmb_cand_needed.gt.0)) if(((.not.cv_constr_work).or. & (cv_proc_workload(cv_proc_sorted(k))+aux_flop.lt. & cv_proc_maxwork(cv_proc_sorted(k)))) & .AND.((.not.cv_constr_mem).or. & (cv_proc_memused(cv_proc_sorted(k))+aux_mem.lt. & cv_proc_maxmem(cv_proc_sorted(k)))) & .AND. & (cv_layer_p2node(layernmb)% & t2_cand(j,cv_proc_sorted(k)).eq.0)) & then cv_proc_workload(cv_proc_sorted(k))= & cv_proc_workload(cv_proc_sorted(k))+aux_flop cv_proc_memused(cv_proc_sorted(k))= & cv_proc_memused(cv_proc_sorted(k))+aux_mem cv_layer_p2node(layernmb)% & t2_cand(j,cv_proc_sorted(k)) & =inode cv_layerworkload(cv_proc_sorted(k))= & cv_layerworkload(cv_proc_sorted(k))+aux_flop cv_layermemused(cv_proc_sorted(k))= & cv_layermemused(cv_proc_sorted(k))+aux_mem nmb_cand_needed=nmb_cand_needed-1 k=k+1 else k=k+1 if(k.gt.cv_slavef) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif end if end do if(nmb_cand_needed.gt.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif end if end if end do do i=1,cv_layer_p2node(layernmb)%nmb_t2s nmb_cand_needed= & cv_layer_p2node(layernmb)%t2_cand(i,cv_slavef+1) candid= cv_layer_p2node(layernmb)%t2_cand(i,1:cv_slavef) cv_layer_p2node(layernmb)%t2_cand(i,1:cv_slavef)=-1 k=0 do j=1,cv_slavef if(candid(j).gt.0) then k=k+1 cv_layer_p2node(layernmb)%t2_cand(i,k)=j-1 end if end do if (k.ne.nmb_cand_needed) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif enddo do i=1,cv_slavef cv_layerworkload(i)=cv_layerworkload(i)-old_workload(i) cv_layermemused(i)=cv_layermemused(i)-old_memused(i) enddo istat=0 999 continue DEALLOCATE(candid, sorted_nmb, sorted_costw, sorted_costm, & old_workload, old_memused) return end subroutine MUMPS_MAP_LAYER recursive subroutine MUMPS_MAPBELOW(inode,procnmb, & procnode) integer,intent(in)::inode,procnmb integer,intent(inout)::procnode(:) integer in procnode(inode)=procnmb if (cv_fils(inode).eq.0) return in=cv_fils(inode) do while(in>0) procnode(in)=procnmb in=cv_fils(in) end do in=-in do while(in>0) call MUMPS_MAPBELOW(in,procnmb,procnode) in=cv_frere(in) end do return end subroutine MUMPS_MAPBELOW subroutine MUMPS_MAPSUBTREE(procnode) implicit none integer,intent(inout)::procnode(:) integer i,inode,procnmb do i=cv_layerl0_start,cv_layerl0_end inode=cv_layerl0_array(i) if(inode.gt.0) then procnmb=procnode(inode) call MUMPS_MAPBELOW(inode,procnmb,procnode) endif enddo return end subroutine MUMPS_MAPSUBTREE subroutine MUMPS_POSTPROCESS_MEM() implicit none integer candid,inode,index,i,j,layernmb,master,nmbcand,swapper, & totalnmb,node_of_master,node_of_candid,node_of_swapper DOUBLE PRECISION::mastermem,slavemem,maxmem logical swapthem,cand_better_master_arch,cand_better_swapper_arch maxmem=maxval(cv_proc_memused(:)) totalnmb=0 do layernmb=cv_maxlayer,1,-1 do i=1,cv_layer_p2node(layernmb)%nmb_t2s inode=cv_layer_p2node(layernmb)%t2_nodenumbers(i) master=cv_procnode(inode) if(ke69 .gt. 1) then allowed_nodes = .FALSE. call MUMPS_FIX_ACCEPTED_MASTER(layernmb,i) node_of_master = mem_distribmpi(master-1) if (node_of_master .lt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*)'node_of_master_not found' endif node_of_swapper = node_of_master endif mastermem=cv_proc_memused(master) nmbcand=cv_layer_p2node(layernmb)%t2_cand(i,cv_slavef+1) swapper=master index=0 do j=1,nmbcand candid=cv_layer_p2node(layernmb)%t2_cand(i,j)+1 slavemem=cv_proc_memused(candid) if(ke69 .gt. 1) then node_of_candid = mem_distribmpi(candid-1) if (node_of_candid .lt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) & 'node_of_candid_not found' endif endif if(ke69 .le. 1) then if((slavemem.lt.mastermem) .and. & (slavemem.lt.cv_proc_memused(swapper))) then swapper=candid index=j endif else cand_better_master_arch = ( & ( & (slavemem.lt.mastermem) .or. & (.not. allowed_nodes(node_of_master)) & ) & .and. allowed_nodes(node_of_candid) & ) cand_better_swapper_arch = ( & ( & (slavemem.lt.cv_proc_memused(swapper)) .or. & (.not. allowed_nodes(node_of_swapper)) & ) & .and. allowed_nodes(node_of_candid) & ) if(cand_better_master_arch .and. & cand_better_swapper_arch ) then swapper=candid node_of_swapper = node_of_candid index=j endif endif enddo if(swapper.ne.master) then swapthem = .FALSE. if(0.75D0*mastermem.ge.cv_proc_memused(swapper)) & swapthem=.TRUE. if(mastermem.le.mastermem-cv_ncostm(inode) & +cv_layer_p2node(layernmb)%t2_candcostm(i)) & swapthem=.FALSE. if(mastermem.le.cv_proc_memused(swapper) & +cv_ncostm(inode) & -cv_layer_p2node(layernmb)%t2_candcostm(i)) & swapthem=.FALSE. if(maxmem.le.mastermem-cv_ncostm(inode) & +cv_layer_p2node(layernmb)%t2_candcostm(i)) & swapthem=.FALSE. if(maxmem.le.cv_proc_memused(swapper)+cv_ncostm(inode) & -cv_layer_p2node(layernmb)%t2_candcostm(i)) & swapthem=.FALSE. if(ke69 .gt. 1) then if (.not. allowed_nodes(node_of_master)) then swapthem=.TRUE. endif endif if(.NOT.swapthem) cycle cv_proc_workload(master)=cv_proc_workload(master) & -cv_ncostw(inode) & +cv_layer_p2node(layernmb)%t2_candcostw(i) cv_proc_memused(master)=cv_proc_memused(master) & -cv_ncostm(inode) & +cv_layer_p2node(layernmb)%t2_candcostm(i) cv_proc_workload(swapper)=cv_proc_workload(swapper) & +cv_ncostw(inode) & -cv_layer_p2node(layernmb)%t2_candcostw(i) cv_proc_memused(swapper)=cv_proc_memused(swapper) & +cv_ncostm(inode) & -cv_layer_p2node(layernmb)%t2_candcostm(i) cv_layer_p2node(layernmb)%t2_cand(i,index)=master-1 cv_procnode(inode)=swapper maxmem=maxval(cv_proc_memused(:)) totalnmb = totalnmb+1 endif enddo enddo end subroutine MUMPS_POSTPROCESS_MEM subroutine MUMPS_PROCINIT(maxwork,maxmem,istat) implicit none DOUBLE PRECISION,intent(in),OPTIONAL::maxwork(cv_slavef), & maxmem(cv_slavef) integer,intent(out)::istat integer i,allocok DOUBLE PRECISION dummy character (len=48):: subname istat=-1 subname='PROCINIT' if(present(maxwork)) then cv_constr_work=.TRUE. else cv_constr_work=.FALSE. end if if(present(maxmem)) then cv_constr_mem=.TRUE. else cv_constr_mem=.FALSE. end if allocate(cv_proc_workload(cv_slavef), & cv_proc_maxwork(cv_slavef), & cv_proc_memused(cv_slavef), & cv_proc_maxmem(cv_slavef), & cv_proc_sorted(cv_slavef), & STAT=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = 2*cv_slavef istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*)'memory allocation error in ',subname return end if allocate(work_per_proc(cv_slavef),id_son(cv_slavef),STAT=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = 2*cv_slavef istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*)'memory allocation error in ',subname return end if do i=1,cv_slavef cv_proc_workload(i)=dble(0) if(cv_constr_work) then cv_proc_maxwork(i)=maxwork(i) else cv_proc_maxwork(i)=(huge(dummy)) endif cv_proc_memused(i)=dble(0) if(cv_constr_mem) then cv_proc_maxmem(i)=maxmem(i) else cv_proc_maxmem(i)=(huge(dummy)) endif end do do i=1, cv_slavef cv_proc_sorted(i)=i enddo istat=0 return end subroutine MUMPS_PROCINIT recursive subroutine MUMPS_MOD_PROPMAP & (inode_entry,ctr_entry,istat) implicit none integer, intent(in)::inode_entry,ctr_entry integer, intent(inout)::istat integer::j,k,in,in1,ierr,son,nmb_procs_inode,nmb_sons_inode, & current,i INTEGER, ALLOCATABLE, DIMENSION(:) :: procs4son INTEGER :: allocok character (len=48):: subname DOUBLE PRECISION :: relative_weight,costs_sons DOUBLE PRECISION :: loc_relax INTEGER :: depth INTEGER :: inode,ctr logical force_cand DOUBLE PRECISION Y integer nmb_propmap_strict,share2,procsrest,current2 integer k69onid INTEGER, ALLOCATABLE, DIMENSION(:) :: procs_inode LOGICAL UPDATE_CTR inode = inode_entry ctr = ctr_entry 1234 CONTINUE if (ctr.le.0) then istat = 0 return endif istat= -1 if(cv_frere(inode).eq.cv_n+1) return subname='MOD_PROPMAP' if(.NOT.associated(cv_prop_map(inode)%ind_proc)) return nmb_sons_inode = 0 costs_sons = dble(0) force_cand=(mod(cv_keep(24),2).eq.0) in = inode do while (cv_fils(in).gt.0) in=cv_fils(in) end do if (cv_fils(in).eq.0) then istat = 0 goto 999 endif in = -cv_fils(in) son=in do while(in.gt.0) nmb_sons_inode = nmb_sons_inode + 1 if (cv_keep(67) .ne. 1) then costs_sons = costs_sons + cv_tcostw(in) else costs_sons = costs_sons + cv_tcostm(in) end if in=cv_frere(in) enddo if(costs_sons.le.0D0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname & ,subname goto 999 endif if ((cv_nodelayer(inode).eq.0).AND. & (cv_frere(inode).ne.cv_n+1)) then istat = 0 goto 999 endif IF (nmb_sons_inode.eq.1) THEN if(.NOT.associated(cv_prop_map(son)%ind_proc)) then WRITE(6,*) son, " cv_prop_map(son)%ind_proc not associated " endif cv_prop_map(son)%ind_proc = cv_prop_map(inode)%ind_proc inode = son GOTO 1234 ENDIF ALLOCATE(procs_inode(cv_slavef), & procs4son(cv_size_ind_proc),stat=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = cv_size_ind_proc + cv_slavef istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*)'memory allocation error in ',subname return end if procs_inode=-1 nmb_procs_inode = 0 do j=1,cv_slavef if( MUMPS_BIT_GET4PROC(inode,j))then nmb_procs_inode = nmb_procs_inode + 1 endif end do i=0 do j=1,cv_slavef if(ke69 .gt.1) then call MUMPS_GET_IDP1_PROC(j-1, & k69onid,ierr) else k69onid = j endif if(MUMPS_BIT_GET4PROC(inode,k69onid))then i = i + 1 procs_inode(i)=k69onid endif end do if(i.ne.nmb_procs_inode)then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname & ,subname goto 999 endif if(nmb_procs_inode.eq.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname & ,subname goto 999 end if depth= max(cv_mixed_strat_bound - ctr,0) if ((cv_keep(24).eq.16).OR.(cv_keep(24).eq.18)) then if(depth.ge.cv_mixed_strat_bound) then loc_relax = dble(1) else loc_relax = dble(1) + & max(dble(cv_keep(77))/dble(100), dble(0)) endif else loc_relax = dble(1) endif in=son current = 1 do while(in.gt.0) UPDATE_CTR = .TRUE. if( ( (nmb_sons_inode.ge.nmb_procs_inode).AND. & (nmb_procs_inode.LT.4) ) & .OR. ( nmb_sons_inode.EQ.1 ) & ) then procs4son = cv_prop_map(inode)%ind_proc IF (nmb_sons_inode.EQ.1) UPDATE_CTR=.FALSE. else do k=1,cv_size_ind_proc do j=0,cv_bitsize_of_int-1 procs4son(k)=ibclr(procs4son(k),j) end do end do nmb_propmap_strict=0 do k=1,cv_slavef if( MUMPS_BIT_GET4PROC(in,k)) then nmb_propmap_strict=nmb_propmap_strict+1 call MUMPS_BIT_SET(procs4son,k,ierr) end if end do if(costs_sons.gt.0.0D0) then if (cv_keep(67) .ne. 1) then relative_weight=cv_tcostw(in)/costs_sons else relative_weight=cv_tcostm(in)/costs_sons endif else relative_weight=0.0D0 endif current = nmb_propmap_strict share2= & max(0,nint(relative_weight*(loc_relax-dble(1))* & dble(nmb_procs_inode))) procsrest=nmb_procs_inode - nmb_propmap_strict share2=min(share2,procsrest) CALL random_number(Y) current2=int(dble(Y)*dble(procsrest)) k=1 i=1 do while((share2.gt.0).and.(i.le.2)) do j=1,nmb_procs_inode if(share2.le.0) exit k69onid = procs_inode(j) if(( MUMPS_BIT_GET4PROC(inode,k69onid)).AND. & (.NOT.MUMPS_BIT_GET(procs4son,k69onid))) then if(k.ge.current2)then call MUMPS_BIT_SET(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr goto 999 end if share2 = share2 - 1 endif k=k+1 end if enddo i=i+1 enddo if(share2.ne.0) then if(cv_lp.gt.0) write(cv_lp,*) & 'Error reported in ',subname goto 999 end if end if ierr=0 in1=in cv_prop_map(in1)%ind_proc=procs4son IF (UPDATE_CTR) THEN call MUMPS_MOD_PROPMAP(in1,ctr-1,ierr) ELSE call MUMPS_MOD_PROPMAP(in1,ctr,ierr) ENDIF if(ierr.ne.0) then if(cv_lp.gt.0) write(cv_lp,*) & 'Error reported in ',subname istat=ierr goto 999 endif in=cv_frere(in) end do istat = 0 999 continue if (allocated(procs_inode)) DEALLOCATE(procs_inode) if (allocated(procs4son)) DEALLOCATE(procs4son) return end subroutine MUMPS_MOD_PROPMAP recursive subroutine MUMPS_PROPMAP(inode_entry, ctr_entry, istat) implicit none integer, intent(in)::inode_entry,ctr_entry integer, intent(inout)::istat integer::j,k,in,in1,ierr,son,nmb_procs_inode,nmb_sons_inode, & share,current,offset, & in_tmp,nfront,npiv,ncb, & keep48_loc,min_cand_needed integer, dimension(:), allocatable :: procs4son character (len=48):: subname DOUBLE PRECISION :: relative_weight,costs_sons, shtemp DOUBLE PRECISION :: costs_sons_real DOUBLE PRECISION :: PartofaProc LOGICAL :: SkipSmallNodes PARAMETER (PartofaProc=0.01D0) DOUBLE PRECISION :: loc_relax INTEGER :: depth logical force_cand integer MUMPS_BLOC2_GET_NSLAVESMIN external MUMPS_BLOC2_GET_NSLAVESMIN DOUBLE PRECISION Y integer nmb_propmap_strict,share2,procsrest,current2 integer k69onid,nb_free_procs,local_son_indice,nb_procs_for_sons, & ptr_upper_ro_procs integer :: inode, ctr INTEGER :: allocok logical upper_round_off,are_sons_treated DOUBLE PRECISION tmp_cost inode = inode_entry ctr = ctr_entry 1234 CONTINUE if (ctr.le.0) then istat = 0 return endif istat= -1 if(cv_frere(inode).eq.cv_n+1) return subname='PROPMAP' nmb_procs_inode = 0 do j=1,cv_slavef if( MUMPS_BIT_GET4PROC(inode,j)) & nmb_procs_inode = nmb_procs_inode + 1 end do if(nmb_procs_inode.eq.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname & ,subname return end if if ((cv_nodelayer(inode).eq.0).AND. & (cv_frere(inode).ne.cv_n+1)) then istat = 0 return endif ptr_upper_ro_procs=1 work_per_proc(1:cv_slavef)=0.0D0 id_son(1:cv_slavef)=0 nmb_sons_inode = 0 costs_sons = dble(0) force_cand=(mod(cv_keep(24),2).eq.0) min_cand_needed=0 in = inode do while (cv_fils(in).gt.0) in=cv_fils(in) end do if (cv_fils(in).eq.0) then istat = 0 return endif in = -cv_fils(in) son=in do while(in.gt.0) nmb_sons_inode = nmb_sons_inode + 1 if (cv_keep(67) .ne. 1) then costs_sons = costs_sons + cv_tcostw(in) else costs_sons = costs_sons + cv_tcostm(in) endif in=cv_frere(in) enddo IF (nmb_sons_inode.eq.1) THEN if(.NOT.associated(cv_prop_map(son)%ind_proc)) then call MUMPS_PROPMAP_INIT(son,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'PROPMAP_INIT signalled error to' & ,subname istat = ierr goto 999 end if endif ctr = ctr -1 cv_prop_map(son)%ind_proc = cv_prop_map(inode)%ind_proc inode = son GOTO 1234 ENDIF costs_sons_real = costs_sons SkipSmallNodes = .true. IF (costs_sons_real.gt.0.0D0) then in = son do while (in.gt.0) if (cv_keep(67) .ne. 1) then relative_weight=cv_tcostw(in)/costs_sons_real else relative_weight=cv_tcostm(in)/costs_sons_real endif shtemp = relative_weight*dble(nmb_procs_inode) IF (shtemp.lt.PartofaProc) THEN if (cv_keep(67) .ne. 1) then costs_sons = costs_sons - cv_tcostw(in) else costs_sons = costs_sons - cv_tcostm(in) endif ENDIF in=cv_frere(in) enddo IF (costs_sons.LT. PartofaProc*costs_sons_real) THEN costs_sons = costs_sons_real SkipSmallNodes = .false. ENDIF ENDIF if(costs_sons.le.0.0D0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname & ,subname return endif if(cv_relax.le.0.0D0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname,'. Wrong cv_relax' return endif ALLOCATE(procs4son(cv_size_ind_proc),stat=allocok) IF (allocok .GT. 0) THEN cv_info(1) = cv_error_memalloc cv_info(2) = cv_size_ind_proc istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*) & 'Memory allocation error in ',subname return ENDIF depth= max(cv_n - ctr,0) if(cv_keep(24).eq.8) then loc_relax = cv_relax elseif ((cv_keep(24).eq.16).OR.(cv_keep(24).eq.18)) then loc_relax = cv_relax elseif (cv_keep(24).eq.10) then loc_relax = cv_relax elseif ((cv_keep(24).eq.12).OR.(cv_keep(24).eq.14)) then if(depth.ge.cv_mixed_strat_bound) then loc_relax = cv_relax else loc_relax = cv_relax + & max(dble(cv_keep(77))/dble(100), dble(0)) endif endif in=son current = 1 local_son_indice=1 nb_procs_for_sons=0 upper_round_off=.FALSE. are_sons_treated=.TRUE. do while(in.gt.0) if( (nmb_sons_inode.ge.nmb_procs_inode).AND. & (nmb_procs_inode.LT.4) ) then procs4son = cv_prop_map(inode)%ind_proc are_sons_treated=.FALSE. nb_procs_for_sons=nmb_procs_inode nmb_propmap_strict=nmb_procs_inode elseif(nmb_procs_inode .LE. abs(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 if (cv_keep(67) .ne. 1) then relative_weight=cv_tcostw(in)/costs_sons else relative_weight=cv_tcostm(in)/costs_sons endif else relative_weight=dble(0) endif shtemp = relative_weight*dble(nmb_procs_inode) IF ( (shtemp.LT.PartofaProc) & .AND. ( SkipSmallNodes ) ) THEN share = 1 do j=current,cv_slavef if(ke69 .gt.1) then call MUMPS_GET_IDP1_PROC(j-1,k69onid,ierr) else k69onid = j endif if( MUMPS_BIT_GET4PROC(inode,k69onid)) then call MUMPS_BIT_SET(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr goto 999 end if share = share -1 exit endif enddo if (share.gt.0) then do j=1,current-1 if(ke69 .gt.1) then call MUMPS_GET_IDP1_PROC(j-1,k69onid,ierr) else k69onid = j endif if( MUMPS_BIT_GET4PROC(inode,k69onid)) then call MUMPS_BIT_SET(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr goto 999 end if share = share -1 exit endif enddo endif if(share.ne.0) then if(cv_lp.gt.0) write(cv_lp,*) & 'Error reported in ',subname goto 999 end if if(.NOT.associated(cv_prop_map(in)%ind_proc)) then call MUMPS_PROPMAP_INIT(in,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'PROPMAP_INIT signalled error to' & ,subname istat = ierr goto 999 end if endif current = j cv_prop_map(in)%ind_proc = procs4son in = cv_frere(in) cycle ENDIF share = max(1,nint(shtemp)) if (dble(share).ge.shtemp) then upper_round_off=.TRUE. else upper_round_off = .FALSE. endif share=min(share,nmb_procs_inode) nmb_propmap_strict=share nb_procs_for_sons=nb_procs_for_sons+nmb_propmap_strict offset=1 do j=current,cv_slavef if(ke69 .gt.1) then call MUMPS_GET_IDP1_PROC(j-1,k69onid,ierr) else k69onid = j endif if( MUMPS_BIT_GET4PROC(inode,k69onid)) then call MUMPS_BIT_SET(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr goto 999 end if share = share-1 if(share.le.0) then current = j + offset if(current.gt.cv_slavef) current = 1 exit end if end if end do if(share.gt.0) then do j=1,current-1 if(ke69 .gt.1) then call MUMPS_GET_IDP1_PROC(j-1,k69onid,ierr) else k69onid = j endif if( MUMPS_BIT_GET4PROC(inode,k69onid)) then call MUMPS_BIT_SET(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr goto 999 end if share = share-1 if(share.le.0) then current = j + offset if(current.gt.cv_slavef) current = 1 exit end if end if end do endif if(share.ne.0) then if(cv_lp.gt.0) write(cv_lp,*) & 'Error reported in ',subname goto 999 end if if(.not.upper_round_off)then if(local_son_indice.lt.cv_slavef)then id_son(local_son_indice)=in if ( cv_keep(67) .ne. 1 ) then work_per_proc(local_son_indice)=cv_tcostw(in)/ & dble(nmb_propmap_strict) else work_per_proc(local_son_indice)=cv_tcostm(in)/ & dble(nmb_propmap_strict) endif local_son_indice=local_son_indice+1 if(local_son_indice.eq.cv_slavef)then CALL MUMPS_SORT_MSORT(ierr,cv_slavef,id_son, & work_per_proc) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*) & 'Error reported by MUMPS_SORT_MSORT in ',subname istat = ierr goto 999 endif endif else current2=cv_slavef if (cv_keep(67) .ne.1) then tmp_cost=cv_tcostw(in)/dble(nmb_propmap_strict) else tmp_cost=cv_tcostm(in)/dble(nmb_propmap_strict) endif do while(current2.ge.1) if(tmp_cost.lt.work_per_proc(current2))exit current2=current2-1 enddo if(current2.ne.cv_slavef)then if(current2.eq.0)then current2=1 endif do j=cv_slavef-1,current2,-1 id_son(j+1)=id_son(j) work_per_proc(j+1)=work_per_proc(j) enddo id_son(current2)=in work_per_proc(current2)=tmp_cost endif endif endif upper_round_off=.FALSE. endif if(.NOT.associated(cv_prop_map(in)%ind_proc)) then call MUMPS_PROPMAP_INIT(in,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'PROPMAP_INIT signalled error to' & ,subname istat = ierr goto 999 end if endif cv_prop_map(in)%ind_proc = procs4son in=cv_frere(in) end do if(are_sons_treated)then if(nb_procs_for_sons.ne.nmb_procs_inode)then do j=1,nmb_procs_inode-nb_procs_for_sons procs4son=cv_prop_map(id_son(j))%ind_proc do while(current.le.cv_slavef) if(ke69 .gt.1) then call MUMPS_GET_IDP1_PROC(current-1,k69onid,ierr) else k69onid = current endif if(.NOT.MUMPS_BIT_GET4PROC(inode,k69onid)) then current=current+1 else exit endif enddo call MUMPS_BIT_SET(procs4son,k69onid,ierr) cv_prop_map(id_son(j))%ind_proc=procs4son enddo ptr_upper_ro_procs=min(j,nmb_procs_inode-nb_procs_for_sons) endif endif in=son current = 1 do while(in.gt.0) if( (nmb_sons_inode.ge.nmb_procs_inode).AND. & (nmb_procs_inode.LT.4) ) then procs4son = cv_prop_map(inode)%ind_proc elseif(nmb_procs_inode .LE. abs(cv_keep(83))) then procs4son = cv_prop_map(inode)%ind_proc else procs4son = cv_prop_map(in)%ind_proc in_tmp=in nfront=cv_nfsiz(in_tmp) npiv=0 in_tmp=in_tmp do while(in_tmp.gt.0) if (cv_BLKON) then npiv = npiv + cv_SIZEOFBLOCKS(in_tmp) else npiv=npiv+1 endif in_tmp=cv_fils(in_tmp) end do ncb=nfront-npiv if (force_cand) then if (cv_keep(50) == 0) then keep48_loc=0 else keep48_loc=3 endif if (cv_keep(48).EQ.5) keep48_loc = 5 min_cand_needed= & MUMPS_BLOC2_GET_NSLAVESMIN & (cv_slavef, keep48_loc,cv_keep8(21), & cv_keep(50), & nfront,ncb, & cv_keep(375), cv_keep(119)) min_cand_needed=min(cv_slavef,min_cand_needed+1) else min_cand_needed = 0 endif min_cand_needed = max(min_cand_needed, abs(cv_keep(91))) if(costs_sons.gt.0.0D0) then if (cv_keep(67) .ne.1) then relative_weight=cv_tcostw(in)/costs_sons else relative_weight=cv_tcostm(in)/costs_sons endif else relative_weight=dble(0) endif nmb_propmap_strict=0 do k=1,cv_slavef if( MUMPS_BIT_GET(procs4son,k)) then nmb_propmap_strict=nmb_propmap_strict+1 end if end do offset=1 share2= & max(0,nint(relative_weight*(loc_relax-dble(1))* & dble(nmb_procs_inode))) share2 = max(share2, min_cand_needed -nmb_propmap_strict, & (abs(cv_keep(83))/2) - nmb_propmap_strict) procsrest=nmb_procs_inode - nmb_propmap_strict share2=min(share2,procsrest) share2 = 0 CALL random_number(Y) current2 =int(dble(Y)*dble(procsrest)) nb_free_procs=1 do j=1,cv_slavef if(share2.le.0) exit if(ke69 .gt.1) then call MUMPS_GET_IDP1_PROC(j-1,k69onid,ierr) else k69onid = j endif if(( MUMPS_BIT_GET4PROC(inode,k69onid)).AND. & (.NOT.MUMPS_BIT_GET(procs4son,k69onid))) then if(nb_free_procs.ge.current2)then call MUMPS_BIT_SET(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr goto 999 end if share2 = share2 - 1 endif nb_free_procs=nb_free_procs+1 end if end do if(share2.gt.0) then do j=1,cv_slavef if(share2.le.0) exit if(ke69 .gt.1) then call MUMPS_GET_IDP1_PROC(j-1,k69onid,ierr) else k69onid = j endif if(( MUMPS_BIT_GET4PROC(inode,k69onid)).AND. & (.NOT.MUMPS_BIT_GET(procs4son,k69onid))) then call MUMPS_BIT_SET(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr goto 999 end if share2 = share2 - 1 end if end do endif if(share2.ne.0) then if(cv_lp.gt.0) write(cv_lp,*) & 'Error reported in ',subname goto 999 end if endif ierr=0 in1=in cv_prop_map(in1)%ind_proc = procs4son IF (nmb_sons_inode.EQ.1) DEALLOCATE(procs4son) call MUMPS_PROPMAP(in1,ctr-1,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) write(cv_lp,*) & 'Error reported in ',subname istat=ierr goto 999 endif in=cv_frere(in) end do istat = 0 999 CONTINUE if (allocated(procs4son)) DEALLOCATE(procs4son) return end subroutine MUMPS_PROPMAP subroutine MUMPS_PROPMAP_INIT(inode,istat) implicit none integer, intent(in)::inode integer, intent(out)::istat integer j,k,allocok character (len=48):: subname istat = -1 if(cv_frere(inode).eq.cv_n+1) return subname='PROPMAP_INIT' if(.not.associated( & cv_prop_map(inode)%ind_proc)) then allocate(cv_prop_map(inode)%ind_proc & (cv_size_ind_proc),STAT=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = cv_size_ind_proc istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*) & 'memory allocation error in ',subname return end if end if do k=1,cv_size_ind_proc do j=0,cv_bitsize_of_int-1 cv_prop_map(inode)%ind_proc(k)= & ibclr(cv_prop_map(inode)%ind_proc(k),j) end do end do istat = 0 return end subroutine MUMPS_PROPMAP_INIT subroutine MUMPS_PROPMAP_TERM(inode,istat) integer,intent(in)::inode integer,intent(out)::istat integer ierr character (len=48):: subname subname='PROPMAP_TERM' istat =-1 if(associated(cv_prop_map(inode)%ind_proc)) then deallocate(cv_prop_map(inode)%ind_proc, STAT=ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ', subname istat = cv_error_memdeloc return endif nullify(cv_prop_map(inode)%ind_proc) end if istat =0 return end subroutine MUMPS_PROPMAP_TERM subroutine MUMPS_PROPMAP4SPLIT(inode,ifather,istat) implicit none integer,intent(in)::inode,ifather integer,intent(out)::istat character (len=48):: subname istat= -1 subname='PROPMAP4SPLIT' if((cv_frere(inode).eq.cv_n+1).OR.(cv_frere(ifather).eq.cv_n+1) & .OR.(.NOT.associated(cv_prop_map(inode)%ind_proc))) then if(cv_lp.gt.0) & write(cv_lp,*)'tototo signalled error to' & ,subname return endif if(.NOT.associated(cv_prop_map(ifather)%ind_proc)) then call MUMPS_PROPMAP_INIT(ifather,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'PROPMAP_INIT signalled error to ' & ,subname istat = ierr return end if endif cv_prop_map(ifather)%ind_proc = & cv_prop_map(inode)%ind_proc istat=0 return end subroutine MUMPS_PROPMAP4SPLIT subroutine MUMPS_ROOTLIST(istat) implicit none integer,intent(out)::istat integer i,allocok character (len=48):: subname istat=-1 subname='ROOTLIST' allocate(cv_layerl0_array(cv_maxnsteps), & cv_layerl0_sorted_costw(cv_maxnsteps),STAT=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = 12*cv_maxnsteps istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*) & 'memory allocation error in ',subname return end if do i=1,cv_maxnsteps cv_layerl0_sorted_costw(i)=dble(0) cv_layerl0_array(i)=0 end do cv_layerl0_start = 0 cv_layerl0_end = 0 layerL0_endforarrangeL0 = 0 if ((.NOT.associated(cv_tcostw)).OR.(.NOT.associated(cv_tcostm))) & then if(cv_lp.gt.0) & write(cv_lp,*)'Error:tcost must be allocated in ',subname return end if cv_nbsa=0 do i=1,cv_n if (cv_frere(i).eq.0) then cv_layerl0_start=1 cv_layerl0_end=cv_layerl0_end+1 IF (cv_tcostw(i).GT.mincostw) & layerL0_endforarrangeL0 = layerL0_endforarrangeL0+1 cv_layerl0_array(cv_layerl0_end)=i cv_layerl0_sorted_costw(cv_layerl0_end)=cv_tcostw(i) cv_costw_layer0=cv_costw_layer0 + cv_tcostw(i) cv_costm_layer0=cv_costm_layer0 + cv_tcostm(i) cv_nbsa=cv_nbsa+1 end if end do if(cv_nbsa.eq.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error:no root nodes in ',subname return end if call MUMPS_SORT_MSORT(ierr,cv_layerl0_end-cv_layerl0_start+1, & cv_layerl0_array(cv_layerl0_start:cv_layerl0_end), & cv_layerl0_sorted_costw(cv_layerl0_start:cv_layerl0_end)) IF (ierr .ne.0) then if(cv_lp.gt.0) & write(cv_lp,*) & 'Error reported by MUMPS_SORT_MSORT in ',subname istat = ierr return ENDIF cv_costw_total=cv_costw_layer0 cv_costm_total=cv_costm_layer0 istat=0 return end subroutine MUMPS_ROOTLIST subroutine MUMPS_SELECT_TYPE3(istat) implicit none integer,intent(out)::istat character (len=48):: subname subname='SELECT_TYPE3' CALL MUMPS_SELECT_K38(cv_n, slavef, cv_mp, cv_icntl(13), & cv_keep(1), cv_frere(1), cv_nfsiz(1), istat) IF (istat .NE. 0) THEN if(cv_lp.gt.0) & write(cv_lp,*) & 'Error: Can''t select type 3 node in ',subname ELSE IF (cv_keep(38) .ne. 0) then IF(cv_nodelayer(cv_keep(38)).eq.0.and. & (cv_keep(60).EQ.0)) then cv_keep(38)=0 ELSE cv_nodetype(cv_keep(38))=3 ENDIF ENDIF RETURN end subroutine MUMPS_SELECT_TYPE3 subroutine MUMPS_SETUP_CAND(istat) integer,intent(out):: istat integer :: i,dummy,layernmb,allocok integer :: montype, nbcand, inode character (len=48) :: subname istat=-1 subname='SETUP_CAND' cv_nb_niv2=0 do i=1,cv_n if(MUMPS_IS_NODE_OF_TYPE2(i)) cv_nb_niv2=cv_nb_niv2+1 end do cv_keep(56)=cv_nb_niv2 nullify(cv_par2_nodes,cv_cand) if(cv_nb_niv2.GT.0) then allocate(cv_par2_nodes(cv_nb_niv2), & cv_cand(cv_nb_niv2,cv_slavef+1),STAT=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = cv_nb_niv2*(cv_slavef+2) istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*) & 'memory allocation error in ',subname return end if cv_par2_nodes=0 cv_cand(:,:)=0 dummy=1 do layernmb=1,cv_maxlayer do i=1,cv_layer_p2node(layernmb)%nmb_t2s inode = cv_layer_p2node(layernmb)%t2_nodenumbers(i) cv_par2_nodes(dummy)= inode nbcand = cv_layer_p2node(layernmb)%t2_cand(i,cv_slavef+1) cv_cand(dummy,:)=cv_layer_p2node(layernmb)%t2_cand(i,:) montype= cv_nodetype(inode) if (montype.eq.tsplit_beg) then CALL MUMPS_SETUP_CAND_CHAIN(cv_n, cv_nb_niv2, & cv_frere(1), cv_nodetype(1), & cv_par2_nodes(1), cv_procnode(1), cv_cand(1,1), & inode, & slavef, dummy, nbcand, istat) endif dummy=dummy+1 enddo enddo if(dummy.ne.cv_nb_niv2+1) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname, & ' : dummy =',dummy,'nbniv2 =',cv_nb_niv2 return endif endif istat=0 return end subroutine MUMPS_SETUP_CAND subroutine MUMPS_SORTPROCS(map_strat,workload,memused, & inode,istat) implicit none integer,intent(in)::map_strat DOUBLE PRECISION,dimension(:),intent(in)::workload, memused integer, optional::inode,istat integer i,j,aux_int,nmb_procs,pos character (len=48):: subname logical enforce_prefsort logical use_propmap logical,SAVE::init1 = .FALSE. logical,SAVE::init2 = .FALSE. subname='SORTPROCS' enforce_prefsort=.TRUE. use_propmap=present(inode) if(present(istat))istat=-1 if((map_strat.ne.cv_equilib_flops).and. & (map_strat.ne.cv_equilib_mem)) then if(cv_lp.gt.0) & write(cv_lp,*)'error in ',subname return endif i=0 do i = 1, cv_slavef cv_proc_sorted(i)=i enddo if (.not.present(inode)) then if(.NOT.init1) then init1=.TRUE. end if do i=1,cv_slavef-1 do j=i+1,cv_slavef if(((workload(cv_proc_sorted(j)).lt. & workload(cv_proc_sorted(i))).AND. & (map_strat.eq.cv_equilib_flops)) & .OR. & ((memused(cv_proc_sorted(j)).lt. & memused(cv_proc_sorted(i))).AND. & (map_strat.eq.cv_equilib_mem)))then aux_int=cv_proc_sorted(j) cv_proc_sorted(j)=cv_proc_sorted(i) cv_proc_sorted(i)=aux_int end if end do end do else if(present(inode)) then if (use_propmap) then if(.NOT.init2) then init2=.TRUE. end if nmb_procs=0 do pos=1,cv_slavef if( MUMPS_BIT_GET4PROC(inode,pos)) then if (pos.le.nmb_procs) then exit else nmb_procs=nmb_procs+1 aux_int=cv_proc_sorted(pos) cv_proc_sorted(pos)= & cv_proc_sorted(nmb_procs) cv_proc_sorted(nmb_procs)=aux_int cycle end if end if end do end if do i=1,nmb_procs-1 do j=i+1,nmb_procs if(((workload(cv_proc_sorted(j)).lt. & workload(cv_proc_sorted(i))).AND. & (map_strat.eq.cv_equilib_flops)) & .OR. & ((memused(cv_proc_sorted(j)).lt. & memused(cv_proc_sorted(i))).AND. & (map_strat.eq.cv_equilib_mem)))then aux_int=cv_proc_sorted(j) cv_proc_sorted(j)=cv_proc_sorted(i) cv_proc_sorted(i)=aux_int end if end do end do do i=nmb_procs+1,cv_slavef-1 do j=i+1,cv_slavef if(((workload(cv_proc_sorted(j)).lt. & workload(cv_proc_sorted(i))).AND. & (map_strat.eq.cv_equilib_flops)) & .OR. & ((memused(cv_proc_sorted(j)).lt. & memused(cv_proc_sorted(i))).AND. & (map_strat.eq.cv_equilib_mem)))then aux_int=cv_proc_sorted(j) cv_proc_sorted(j)=cv_proc_sorted(i) cv_proc_sorted(i)=aux_int end if end do end do if(.NOT.enforce_prefsort) then if(((2.0D0*workload(cv_proc_sorted(nmb_procs+1)).lt. & workload(cv_proc_sorted(1))).AND. & (map_strat.eq.cv_equilib_flops)) & .OR. & ((2.0D0*memused(cv_proc_sorted(nmb_procs+1)).lt. & memused(cv_proc_sorted(1))).AND. & (map_strat.eq.cv_equilib_mem)))then do i=1,cv_slavef-1 do j=i+1,cv_slavef if(((workload(cv_proc_sorted(j)).lt. & workload(cv_proc_sorted(i))).AND. & (map_strat.eq.cv_equilib_flops)) & .OR. & ((memused(cv_proc_sorted(j)).lt. & memused(cv_proc_sorted(i))).AND. & (map_strat.eq.cv_equilib_mem)))then aux_int=cv_proc_sorted(j) cv_proc_sorted(j)=cv_proc_sorted(i) cv_proc_sorted(i)=aux_int end if end do end do endif end if endif if(present(istat))istat=0 return end subroutine MUMPS_SORTPROCS subroutine MUMPS_STORE_GLOBALS(ne,nfsiz,frere,fils,keep,KEEP8, & info,procnode,ssarbr,nbsa) implicit none integer,dimension(cv_n),intent(inout)::ne,nfsiz,frere,fils, & procnode,ssarbr integer, intent(inout):: keep(500),info(80),nbsa INTEGER(8) KEEP8(150) ne=cv_ne nfsiz=cv_nfsiz frere=cv_frere fils=cv_fils keep(2) =cv_keep(2) keep(20)=cv_keep(20) keep(28)=cv_nsteps keep(38)=cv_keep(38) keep(56)=cv_keep(56) keep(61)=cv_keep(61) info(5)=cv_info(5) info(6)=cv_nsteps procnode=cv_procnode ssarbr=cv_ssarbr nbsa=cv_nbsa end subroutine MUMPS_STORE_GLOBALS subroutine MUMPS_TERMGLOB(istat) implicit none integer,intent(out)::istat integer i,ierr,layernmb character (len=48):: subname istat=-1 subname='TERMGLOB' nullify(cv_frere,cv_fils,cv_nfsiz,cv_ne,cv_keep,cv_keep8, & cv_icntl,cv_info,cv_procnode,cv_ssarbr) deallocate(cv_proc_workload,cv_proc_maxwork,cv_proc_memused, & cv_proc_maxmem,cv_nodetype, & cv_nodelayer,cv_proc_sorted, & cv_ncostw,cv_ncostm, & cv_layerworkload,cv_layermemused, & STAT=ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ',subname istat = cv_error_memdeloc return end if deallocate(work_per_proc,id_son,STAT=ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ',subname istat = cv_error_memdeloc return end if do layernmb=1,cv_maxlayer if(cv_layer_p2node(layernmb)%nmb_t2s.gt.0) then deallocate(cv_layer_p2node(layernmb)%t2_nodenumbers, & cv_layer_p2node(layernmb)%t2_cand, & cv_layer_p2node(layernmb)%t2_candcostw, & cv_layer_p2node(layernmb)%t2_candcostm, & STAT=ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ', & subname istat = cv_error_memdeloc return end if endif enddo if(associated(cv_layer_p2node)) then deallocate(cv_layer_p2node,STAT=ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ',subname istat = cv_error_memdeloc return end if end if do i=1,cv_n call MUMPS_PROPMAP_TERM(i,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'PROPMAP_TERM signalled error in ', & subname istat = ierr return end if end do if(associated(cv_prop_map))deallocate(cv_prop_map,STAT=ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ',subname istat = cv_error_memdeloc return end if istat=0 return end subroutine MUMPS_TERMGLOB recursive subroutine MUMPS_TREECOSTS(pos) implicit none integer,intent(in)::pos integer i,nfront,npiv,nextpos if ((.NOT.associated(cv_tcostw)).OR.(.NOT.associated(cv_tcostm))) & then call MUMPS_ABORT() end if nfront=cv_nfsiz(pos) npiv=1 nextpos=cv_fils(pos) do while (nextpos.gt.0) if (cv_BLKON) then npiv = npiv + cv_SIZEOFBLOCKS(nextpos) else npiv=npiv+1 endif nextpos=cv_fils(nextpos) end do call MUMPS_CALCNODECOSTS(npiv,nfront, & cv_ncostw(pos), cv_ncostm(pos)) cv_tcostw(pos)=cv_ncostw(pos) cv_tcostm(pos)=cv_ncostm(pos) if (cv_ne(pos).ne.0) then nextpos=cv_fils(pos) do while(nextpos.gt.0) nextpos=cv_fils(nextpos) end do nextpos=-nextpos do i=1,cv_ne(pos) cv_depth(nextpos)=cv_depth(pos)+1 call MUMPS_TREECOSTS(nextpos) cv_tcostw(pos)=cv_tcostw(pos)+cv_tcostw(nextpos) cv_tcostm(pos)=cv_tcostm(pos)+cv_tcostm(nextpos) nextpos=cv_frere(nextpos) end do endif return end subroutine MUMPS_TREECOSTS recursive subroutine MUMPS_TYPEINSSARBR(inode) implicit none integer, intent(in)::inode integer in cv_nodetype(inode)=-1 in=cv_fils(inode) do while (in>0) in=cv_fils(in) end do in=-in do while(in.gt.0) call MUMPS_TYPEINSSARBR(in) in=cv_frere(in) enddo end subroutine MUMPS_TYPEINSSARBR subroutine MUMPS_WORKMEM_IMBALANCE(workload,memused, & maxwork,minwork,maxmem,minmem) implicit none DOUBLE PRECISION,dimension(:),intent(in)::workload, & memused DOUBLE PRECISION,intent(out)::maxwork,minwork,maxmem,minmem maxwork=maxval(workload) minwork=minval(workload, mask= workload > dble(0)) maxmem=maxval(memused) minmem=minval(memused, mask= memused > dble(0)) end subroutine MUMPS_WORKMEM_IMBALANCE subroutine MUMPS_FIX_ACCEPTED_MASTER(layernumber,nodenumber) implicit none integer layernumber,nodenumber integer i integer inode integer current_max,current_proc current_max = 0 score = 0 allowed_nodes = .FALSE. inode=cv_layer_p2node(layernumber)%t2_nodenumbers(nodenumber) do i=1,cv_layer_p2node(layernumber)%t2_cand(nodenumber, & cv_slavef+1) current_proc=cv_layer_p2node(layernumber)%t2_cand(nodenumber,i) if ( current_proc .ge. 0) then score(mem_distribmpi(current_proc)) = & score(mem_distribmpi(current_proc)) + 1 endif enddo current_proc = cv_procnode(inode) - 1 score(mem_distribmpi(current_proc)) = & score(mem_distribmpi(current_proc)) + 1 do i=0,nb_arch_nodes - 1 if ( score(i) .gt. current_max ) then current_max = score(i) allowed_nodes = .FALSE. allowed_nodes(i) = .TRUE. else if(score(i) .eq. current_max) then allowed_nodes(i) = .TRUE. endif endif enddo return end subroutine MUMPS_FIX_ACCEPTED_MASTER end subroutine MUMPS_DISTRIBUTE subroutine MUMPS_RETURN_CANDIDATES(par2_nodes,cand, & istat) integer, intent(out) :: par2_nodes(cv_nb_niv2), istat integer, intent(out) :: cand(:,:) character (len=48):: subname integer iloop istat=-1 subname='MUMPS_RETURN_CANDIDATES' par2_nodes=cv_par2_nodes do iloop=1, cv_slavef+1 cand(iloop,:)=cv_cand(:,iloop) enddo deallocate(cv_par2_nodes,cv_cand,STAT=istat) if(istat.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ',subname istat = cv_error_memdeloc return end if istat = 0 return end subroutine MUMPS_RETURN_CANDIDATES subroutine MUMPS_INIT_ARCH_PARAMETERS( & total_comm,working_comm,keep69,par, & nbslaves,mem_distrib,informerr &) implicit none include 'mpif.h' integer nbslaves integer, dimension(0:) :: mem_distrib integer total_comm,working_comm,keep69,par integer, dimension(:) ::informerr integer myrank integer host,i,ierr integer,dimension(:),allocatable :: buffer_memdistrib ierr = 0 myrank = -1 host = -1 ke69 = keep69 cv_slavef = nbslaves if (ke69 .eq. 1) then return endif if ( allocated(mem_distribtmp) ) deallocate(mem_distribtmp ) allocate( mem_distribtmp( 0:cv_slavef-1 ), & buffer_memdistrib( 0:cv_slavef-1 ), stat=ierr ) if ( ierr .gt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) 'pb allocation mem_dist' informerr(1) = -13 informerr(2) = cv_slavef return end if mem_distribtmp = -1 call MPI_COMM_RANK( total_comm, host, ierr ) if ((par .eq. 1) .or. (host .ne. 0)) then call MPI_COMM_RANK( working_comm, myrank, ierr ) call MUMPS_COMPUTE_DISTRIB(ierr,myrank, & working_comm,mem_distrib) if ( ierr .ne. 0 ) then if(cv_mp.gt.0) & write(cv_mp,*) 'pb in mumps_init_arch_parameters' informerr(1) = -13 informerr(2) = cv_slavef return end if mem_distribtmp = mem_distrib call MUMPS_FIX_NODE_MASTER(ierr) if ( ierr .ne. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) &'pb in mumps_init_arch_parameters' informerr(1) = -13 informerr(2) = cv_slavef return endif endif if(ke69 .le. 0) then deallocate(mem_distribtmp) deallocate(buffer_memdistrib) return endif call MPI_ALLREDUCE(mem_distribtmp(0),buffer_memdistrib(0), & cv_slavef,MPI_INTEGER, & MPI_MAX,total_comm,ierr) mem_distribtmp = buffer_memdistrib deallocate (buffer_memdistrib) call MUMPS_COMPUTE_NB_ARCH_NODES() if((cv_slavef/nb_arch_nodes) .le. 4) then do i = 0, cv_slavef-1 if ( mem_distrib(i) .NE. 1 ) then mem_distrib(i)=max(ke69/2,2) endif enddo endif if((nb_arch_nodes .eq. 1) .or. & (nb_arch_nodes .eq. cv_slavef) & ) then ke69 = 1 deallocate(mem_distribtmp) keep69 = 1 return endif if (host .eq. 0) then if ( allocated(mem_distribmpi) ) deallocate(mem_distribmpi ) allocate( mem_distribmpi( 0:cv_slavef-1 ), stat=ierr ) if ( ierr .gt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) 'pb allocation mem_dist' informerr(1) = -13 informerr(2) = cv_slavef return endif call MUMPS_ALLOC_ALLOW_MASTER(ierr) if(ierr .ne. 0 ) then return endif mem_distribmpi = mem_distribtmp call MUMPS_FIX_TABLE_OF_PROCESS(ierr) if ( ierr .ne. 0 ) then if(cv_mp.gt.0) & write(cv_mp,*) 'pb in mumps_init_arch_parameters' informerr(1) = -13 informerr(2) = cv_slavef return endif else deallocate(mem_distribtmp) endif return end subroutine MUMPS_INIT_ARCH_PARAMETERS subroutine MUMPS_SET_K78_83_91 (NSLAVES, & KEEP78, KEEP83, KEEP91) INTEGER, INTENT(IN) :: NSLAVES INTEGER, INTENT(INOUT) :: KEEP78, KEEP83, KEEP91 IF (KEEP78 .LT. 0) THEN IF (NSLAVES.GT.4) THEN KEEP78=max( & int(log(real(NSLAVES))/log(real(2))) - 2 & , 0 ) KEEP78 = -KEEP78 ELSE KEEP78 = 0 ENDIF ENDIF IF (KEEP83.LT.0) THEN KEEP83 = min(8,NSLAVES/4) KEEP83 = max(min(4,NSLAVES),max(KEEP83,1)) KEEP83 = - KEEP83 ENDIF IF (KEEP91.LT.0) THEN KEEP91 = min(8, NSLAVES) KEEP91 = max(min(4,NSLAVES),min(abs(KEEP83),KEEP91)) KEEP91 = - KEEP91 ENDIF return end subroutine MUMPS_SET_K78_83_91 subroutine MUMPS_COMPUTE_NB_ARCH_NODES() implicit none integer i nb_arch_nodes = 0 do i=0,cv_slavef-1 if(mem_distribtmp(i) .eq. i) then nb_arch_nodes = nb_arch_nodes + 1 endif enddo return end subroutine MUMPS_COMPUTE_NB_ARCH_NODES subroutine MUMPS_FIX_TABLE_OF_PROCESS(ierr) implicit none external MUMPS_SORT_INT integer i,precnode,nodecount integer sizesmp integer ierr ierr = 0 sizesmp = 0 if ( allocated(table_of_process) ) & deallocate(table_of_process ) allocate( table_of_process(0:cv_slavef-1), stat=ierr ) if ( ierr .gt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) & 'pb allocation in MUMPS_FIX_TABLE_OF_PROCESS' return end if do i=0,cv_slavef - 1 table_of_process(i) = i enddo call MUMPS_SORT_INT(cv_slavef,mem_distribtmp(0), & table_of_process(0)) precnode = 0 nodecount = 0 do i=0,cv_slavef-1 if(mem_distribtmp(i) .eq. precnode) then sizesmp = sizesmp + 1 mem_distribtmp(i) = nodecount mem_distribmpi(table_of_process(i)) = nodecount else score(nodecount) = sizesmp sizesmp = 1 nodecount = nodecount + 1 precnode = mem_distribtmp(i) mem_distribtmp(i) = nodecount mem_distribmpi(table_of_process(i)) = nodecount endif enddo score(nodecount) = sizesmp do i=0,cv_slavef-1 mem_distribtmp(i) = score(mem_distribtmp(i)) enddo CALL MUMPS_SORT_INT_DEC(cv_slavef,mem_distribtmp(0), & table_of_process(0)) ierr = 0 return end subroutine MUMPS_FIX_TABLE_OF_PROCESS subroutine MUMPS_FIX_NODE_MASTER(ierr) implicit none integer i,j,ierr integer idmaster idmaster = -1 ierr = 0 do i=0,cv_slavef-1 if (mem_distribtmp(i) .eq. 1) then idmaster = i do j=i,cv_slavef-1 if (mem_distribtmp(j) .eq. 1) then mem_distribtmp(j) = idmaster else mem_distribtmp(j) = 0 endif enddo return else mem_distribtmp(i) = 0 endif enddo if(cv_mp.gt.0) write(cv_mp,*)'problem in MUMPS_FIX_NODE_MASTER: & cannot find a master' ierr = 1 return end subroutine MUMPS_FIX_NODE_MASTER subroutine MUMPS_COMPUTE_DISTRIB(ierr,myrank,working_comm, & mem_distrib) implicit none include 'mpif.h' integer ierr,resultlen,myrank,i,working_comm integer , dimension(0:) :: mem_distrib integer allocok character(len=MPI_MAX_PROCESSOR_NAME) name integer, dimension(:),allocatable :: namercv integer, dimension(:),allocatable :: myname integer lenrcv external MUMPS_COMPARE_TAB logical MUMPS_COMPARE_TAB ierr = 0 call MPI_GET_PROCESSOR_NAME(name,resultlen,ierr) allocate(myname(resultlen),stat=allocok) if ( allocok .gt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) & 'pb allocation in compute_dist for myname' ierr = 1 return end if do i=1, resultlen myname(i) = ichar(name(i:i)) enddo do i=0, cv_slavef-1 if(myrank .eq. i) then lenrcv = resultlen else lenrcv = 0 endif call MPI_BCAST(lenrcv,1,MPI_INTEGER,i, & working_comm,ierr) allocate(namercv(lenrcv),stat=allocok) if ( allocok .gt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) & 'pb allocation in compute_dist for namercv' ierr = 1 return end if if(myrank .eq. i) then namercv = myname endif call MPI_BCAST(namercv,lenrcv,MPI_INTEGER,i, & working_comm,ierr) if( MUMPS_COMPARE_TAB(myname,namercv, & resultlen,lenrcv)) then mem_distrib(i)=1 else mem_distrib(i)=ke69 endif deallocate(namercv) enddo deallocate(myname) ierr = 0 return end subroutine MUMPS_COMPUTE_DISTRIB subroutine MUMPS_GET_IDP1_PROC(current_proc,idarch,ierr) implicit none integer current_proc integer idarch,ierr ierr = 0 if (current_proc .ge. cv_slavef) then ierr = -1 return endif if (current_proc .lt. 0) then idarch = 1 return else idarch = table_of_process(current_proc) + 1 endif return end subroutine MUMPS_GET_IDP1_PROC subroutine MUMPS_END_ARCH_CV() if (allocated(table_of_process)) deallocate(table_of_process) if (allocated(allowed_nodes)) deallocate(allowed_nodes) if (allocated(score)) deallocate(score) if (allocated(mem_distribtmp)) deallocate(mem_distribtmp) if (allocated(mem_distribmpi)) deallocate(mem_distribmpi) return end subroutine MUMPS_END_ARCH_CV subroutine MUMPS_ALLOC_ALLOW_MASTER(ierr) integer ierr ierr = 0 if (allocated(allowed_nodes)) deallocate(allowed_nodes) allocate( allowed_nodes(0:nb_arch_nodes-1),stat=ierr) if ( ierr .gt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) & 'pb allocation MUMPS_ALLOC_ALLOW_MASTER' ierr = -13 return end if allowed_nodes = .FALSE. if (allocated(score)) deallocate(score) allocate( score(0:nb_arch_nodes-1),stat=ierr) if ( ierr .gt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) & 'pb allocation MUMPS_ALLOC_ALLOW_MASTER' ierr = -13 return end if score = 0 ierr = 0 return end subroutine MUMPS_ALLOC_ALLOW_MASTER SUBROUTINE MUMPS_SORT_MMERGE(start1st,end1st,dim1, & start2nd,end2nd,dim2, & indx, & val, istat) implicit none integer, intent(in):: start1st,end1st,dim1,start2nd,end2nd,dim2 integer, intent(inout):: indx(:) DOUBLE PRECISION, intent(inout):: val(:) INTEGER, intent(out) :: istat INTEGER, ALLOCATABLE, DIMENSION(:) :: index DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: dummy1 integer :: a,b,c integer :: allocok character (len=48):: subname subname = "MUMPS_SORT_MMERGE" istat=-1 ALLOCATE(index(dim1+dim2),dummy1(dim1+dim2),stat=allocok) if ( allocok .gt. 0 ) then cv_info(1) = cv_error_memalloc cv_info(2) = dim1+dim2+dim1+dim2 istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*) & 'memory allocation error in ',subname return end if a=start1st b=start2nd c=1 do while((a.LT.end1st+1).AND.(b.LT.end2nd+1)) if(val(a).GT.val(b))then index(c)=indx(a) dummy1(c)=val(a) a=a+1 c=c+1 else index(c)=indx(b) dummy1(c)=val(b) b=b+1 c=c+1 endif end do if(a.LT.end1st+1) then do while(a.LT.end1st+1) index(c)=indx(a) dummy1(c)=val(a) a=a+1 c=c+1 enddo elseif(b.LT.end2nd+1) then do while(b.LT.end2nd+1) index(c)=indx(b) dummy1(c)=val(b) b=b+1 c=c+1 enddo endif indx(start1st:end1st)=index(1:dim1) val(start1st:end1st)=dummy1(1:dim1) indx(start2nd:end2nd)=index(dim1+1:dim1+dim2) val(start2nd:end2nd)=dummy1(dim1+1:dim1+dim2) DEALLOCATE(index,dummy1) istat=0 return end SUBROUTINE MUMPS_SORT_MMERGE SUBROUTINE MUMPS_SORT_MSORT(istat,dim,indx,val1,val2) implicit none integer, intent(in):: dim integer, intent(inout):: indx(:) integer, intent(out)::istat DOUBLE PRECISION, intent(inout):: val1(:) DOUBLE PRECISION, intent(inout),optional:: val2(:) INTEGER, ALLOCATABLE, DIMENSION(:) :: index, dummy1 DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: dummy2 integer, parameter :: ss = 35 integer :: a,b,c,i,k,l,r,s,stackl(ss),stackr(ss) integer :: allocok character (len=48):: subname istat=-1 subname = "MUMPS_SORT_MSORT" ALLOCATE(index(dim),dummy1(dim),dummy2(dim),stat=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = 3*dim istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*)'memory allocation error in ',subname return end if do i=1,dim index(i)=i enddo s = 1 stackl(1) = 1 stackr(1) = dim 5511 CONTINUE l = stackl(s) r = stackr(s) k = (l+r) / 2 if(l.LT.k) then if(s.GE.ss) stop 'maxsize of stack reached' s = s + 1 stackl(s) = l stackr(s) = k goto 5511 endif 5512 CONTINUE l = stackl(s) r = stackr(s) k = (l+r) / 2 if(k+1.LT.r) then if(s.GE.ss) stop 'maxsize of stack reached' s = s + 1 stackl(s) = k+1 stackr(s) = r goto 5511 endif 5513 CONTINUE l = stackl(s) r = stackr(s) k = (l+r) / 2 a=l b=k+1 c=1 do while((a.LT.k+1).AND.(b.LT.r+1)) if(val1(index(a)).GT.val1(index(b)))then dummy1(c)=index(a) a=a+1 c=c+1 else dummy1(c)=index(b) b=b+1 c=c+1 endif end do if(a.LT.k+1) then dummy1(c:r-l+1)=index(a:k) elseif(b.LT.r+1) then dummy1(c:r-l+1)=index(b:r) endif index(l:r)=dummy1(1:r-l+1) if(s.GT.1) then s = s - 1 if(l.EQ.stackl(s)) goto 5512 if(r.EQ.stackr(s)) goto 5513 endif do i=1,dim dummy1(i)=indx(index(i)) enddo indx=dummy1 do i=1,dim dummy2(i)=val1(index(i)) enddo val1=dummy2 if(present(val2)) then do i=1,dim dummy2(i)=val2(index(i)) enddo val2=dummy2 endif istat=0 DEALLOCATE(index,dummy1,dummy2) return end subroutine MUMPS_SORT_MSORT END MODULE MUMPS_STATIC_MAPPING SUBROUTINE MUMPS_SELECT_K38(N, SLAVEF, MP, & ICNTL13, KEEP, FRERE, ND, ISTAT) IMPLICIT NONE INTEGER, intent(in) :: N, SLAVEF, ICNTL13, MP INTEGER KEEP(500) INTEGER FRERE(N), ND(N) INTEGER, intent(out) :: ISTAT #if ! defined(NOSCALAPACK) INTEGER IROOTTREE, SIZEROOT, NFRONT, I #endif ISTAT = 0 IF (KEEP(60).EQ.2 .or. KEEP(60).EQ.3 ) THEN ELSE IF ( KEEP(53) .NE. 0 .OR. KEEP(60) .NE. 0) THEN ELSE #if ! defined(NOSCALAPACK) IF((SLAVEF.EQ.1).OR.(ICNTL13.GT.0).OR. & (KEEP(60).NE.0)) THEN #endif KEEP(38) = 0 #if ! defined(NOSCALAPACK) ELSE IF ((KEEP(38).GT.0).AND.(KEEP(38).LE.N)) THEN IROOTTREE = KEEP(38) SIZEROOT = ND(KEEP(38)) 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 ENDIF IF (SIZEROOT.LE.SLAVEF) THEN KEEP(38) = 0 ELSE IF ( SIZEROOT.GT.KEEP(37) ) THEN IF (MP.GT.0) WRITE(MP,*) 'A root of estimated size ', & SIZEROOT,' has been selected for Scalapack.' KEEP(38) = IROOTTREE ELSE KEEP(38) = 0 IF (MP.GT.0) WRITE(MP,'(A,I9,A)') & ' WARNING: Largest root node of size ', SIZEROOT, & ' not selected for parallel execution' END IF ENDIF #endif ENDIF RETURN END SUBROUTINE MUMPS_SELECT_K38 SUBROUTINE MUMPS_SPLITNODE_INTREE(inode,nfront,npiv,k, & lnpivsplit, npivsplit, keep, n, fils, frere, & nfsiz, ne, info5_nfrmax, k28_nsteps, nodetype, & istat & , SIZEOFBLOCKS, LSIZEOFBLOCKS & , BLKON & ) implicit none integer, intent(in)::nfront,npiv integer, intent(in):: k integer, intent(in)::lnpivsplit integer, intent(in)::npivsplit(lnpivsplit) integer, intent(in):: inode integer, intent(out)::istat integer, intent(inout):: keep(500) integer, intent(inout):: k28_nsteps integer, intent(in) :: info5_nfrmax integer, intent(in) :: n integer, intent(inout)::frere(n), fils(n), nfsiz(n), ne(n) integer, intent(inout):: nodetype(n) integer, intent(in) :: LSIZEOFBLOCKS integer, intent(in) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) logical,intent(in) :: BLKON integer i,lev,in,in_son,in_father,in_grandpa,npiv_father, & npiv_son,nfrontk,npivk,d1,f1,e1,dk,fk,next_father integer::ison,ifather character (len=48):: subname integer, parameter:: tsplit_beg=4 integer, parameter:: tsplit_mid=5 integer, parameter:: tsplit_last=6 istat=-1 subname='SPLITNODE_INTREE' ison=-1 ifather=-1 nfrontk = nfront npivk = npiv npiv_son = npivsplit(1) keep(2)=max(keep(2),nfront-npiv_son) d1 = inode f1 = d1 e1 = frere(d1) if (BLKON) then i= SIZEOFBLOCKS(f1) do while (i.lt.npiv_son) f1 = fils(f1) i = i + SIZEOFBLOCKS(f1) enddo else do i=1,npiv_son-1 f1 = fils(f1) enddo endif ison = d1 in_son = f1 next_father = fils(in_son) do lev = 1, k-1 ifather = next_father in_father = ifather npiv_son= abs(npivsplit(lev)) npiv_father=abs(npivsplit(lev+1)) if (BLKON) then i= SIZEOFBLOCKS(in_father) do while (i.lt.npiv_father) in_father=fils(in_father) i = i + SIZEOFBLOCKS(in_father) enddo else do i=1,npiv_father-1 in_father=fils(in_father) enddo endif frere(ison)=-ifather next_father = fils(in_father) fils(in_father)=-ison nfsiz(ison)=nfrontk nfsiz(ifather)=nfrontk-npiv_son ne(ifather)=1 keep(61)=keep(61)+1 IF (keep(79).EQ.0) THEN if( nfront-npiv_son > keep(9)) then nodetype(ifather) = 2 else nodetype(ifather) = 1 endif ELSE if (lev.EQ.1) then nodetype(ison) = tsplit_beg endif if (lev.eq.k-1) then nodetype(ifather) = tsplit_last else nodetype(ifather) = tsplit_mid endif if (npivsplit(lev+1) < 0) then if (lev.eq.k-1) then nodetype(ifather)=-tsplit_last else nodetype(ifather)=-tsplit_mid endif endif ENDIF nfrontk = nfrontk-npiv_son npivk = npivk - npiv_son ison = ifather in_son = in_father enddo dk = ifather fk = in_father # if (check_mumps_static_mapping >= 3) write(6,*) ' Last (close to root) node in chain :', ifather #endif fils(f1) = next_father frere(dk) = e1 in = e1 do while (in.gt.0) in=frere(in) end do in = -in do while(fils(in).gt.0) in=fils(in) end do in_grandpa = in if(fils(in_grandpa).eq.-d1) then fils(in_grandpa)=-dk else in=-fils(in_grandpa) do while(frere(in) .ne. d1) in=frere(in) end do frere(in) = dk end if k28_nsteps = k28_nsteps + k-1 istat = 0 return END SUBROUTINE MUMPS_SPLITNODE_INTREE subroutine MUMPS_SETUP_CAND_CHAIN(n, nb_niv2, & frere, nodetype, par2_nodes, & procnode, cand, inode_chain, slavef, dummy, nbcand, istat) implicit none integer, intent(in) :: n, nb_niv2, slavef integer,intent(in)::frere(n) integer, intent(inout) :: par2_nodes(nb_niv2), procnode(n) integer,intent(inout)::nodetype(n) integer,intent(inout)::cand(nb_niv2, slavef+1) integer,intent(in)::inode_chain integer,intent(inout)::dummy, nbcand integer,intent(out):: istat integer, parameter:: tsplit_beg=4 integer, parameter:: tsplit_mid=5 integer, parameter:: tsplit_last=6 integer, parameter:: invalid=-9999 integer :: inode, ifather, k logical :: last_iteration_reached istat = -1 inode = inode_chain k = 1 do if (.not. (frere(inode) .lt. 0) ) then write(*,*) " Internal error 0 in SETUP_CAND", & frere(inode), inode CALL MUMPS_ABORT() endif ifather = -frere(inode) last_iteration_reached = (abs(nodetype(ifather)).eq.tsplit_last) par2_nodes(dummy+1) = ifather procnode(ifather) = cand(dummy,1) + 1 if ( (nodetype(ifather).eq.tsplit_mid) .or. & (nodetype(ifather).eq.tsplit_last) ) then if (nbcand.lt.2) then par2_nodes(dummy+1) = ifather procnode(ifather) = procnode(inode) cand(dummy+1,:) = cand(dummy,:) dummy = dummy + 1 write(6,*) ' Mapping property', & ' of procs in chain lost ' CALL MUMPS_ABORT() endif cand(dummy+1,1:nbcand-1+k-1) = cand(dummy,2:nbcand+k-1) cand(dummy+1,nbcand-1+k) = procnode(inode)-1 cand(dummy+1,nbcand-1+k+1:slavef) = invalid nbcand = nbcand -1 k = k + 1 else if ( (nodetype(ifather).eq.-tsplit_mid) .or. & (nodetype(ifather).eq.-tsplit_last) ) then if (nodetype(inode).eq.tsplit_beg) then nodetype(inode)=2 else nodetype(inode)=tsplit_last endif if (nodetype(ifather) .eq. -tsplit_last) then nodetype(ifather) = 2 else nodetype(ifather) = tsplit_beg endif cand(dummy+1,1:nbcand-1+k-1) = cand(dummy,2:nbcand+k-1) cand(dummy+1,nbcand-1+k) = procnode(inode)-1 nbcand = nbcand+k-1 k = 1 else write(6,*) ' Internal error 2 in SETUP_CAND', & ' in, ifather =', inode, ifather, & ' nodetype(ifather) ', nodetype(ifather) CALL MUMPS_ABORT() endif cand(dummy+1,slavef+1)= nbcand dummy = dummy+1 if (last_iteration_reached) exit inode = ifather end do istat = 0 end subroutine MUMPS_SETUP_CAND_CHAIN subroutine MUMPS_GET_SPLIT_4_PERF(inode, nfront, npiv, nproc, & k, lnpivsplit, npivsplit, & n, frere, keep, & fils, BLKON, sizeofblocks, & istat) implicit none integer,intent(in)::inode, nfront, npiv, lnpivsplit, n integer,intent(in)::frere(n) integer,intent(in) :: fils(n) logical, intent(in) :: BLKON integer, intent(in) :: sizeofblocks(*) integer,intent(in)::keep(500) double precision, intent(in):: nproc integer,intent(out)::k, npivsplit(lnpivsplit), istat logical :: nosplit integer :: inode_tmp integer :: kk, optimization_strategy, nass, npiv2 double precision :: nproc2 integer :: npivOld, npivNew double precision :: timeFacOld, timeFacNew, timeAss double precision ,parameter :: alpha=8.0D9 double precision ,parameter :: gamma=1.2D9 nosplit = npiv .le. npiv4equilibreRows(nfront, nproc) optimization_strategy = 0 nosplit = nosplit .or. (frere(inode) .eq. 0) if ( nosplit ) then k = 1 npivsplit(1) = npiv istat = 0 return endif if (nproc .le. 1.0d0) then k = 1 npivsplit(1) = npiv istat = -1 return endif nproc2 = nproc nass = 0 kk = 0 inode_tmp = inode do while (nass .lt. npiv) if ((nproc2 .eq. 2.0d0) .or. & (nfront - nass .le. 6*keep(9))) then npiv2 = npiv - nass else if (nproc2 .gt. 2) then if (optimization_strategy .eq. 0) then npiv2 = min(npiv - nass, & npiv4equilibreRows(nfront - nass, nproc2 )) else if (optimization_strategy .eq. 1) then if (nproc2 .eq. nproc) then npiv2 = min(npiv - nass, & npiv4equilibreFlops(nfront - nass, nproc2 )) else npiv2 = min(npiv - nass, & npiv4equilibreRows(nfront - nass, nproc2 )) endif else write(*,*) "Internal error in MUMPS_GET_SPLIT_4_PERF," write(*,*) "optimization_strategy not implemented" call MUMPS_ABORT() endif endif kk = kk + 1 IF (BLKON) THEN npivsplit(kk) = 0 DO WHILE (npivsplit(kk) .LT. npiv2 .and. inode_tmp .gt. 0) npivsplit(kk) = npivsplit(kk) + sizeofblocks(inode_tmp) inode_tmp= fils(inode_tmp) ENDDO npiv2 = npivsplit(kk) ELSE npivsplit(kk) = npiv2 ENDIF if (keep(79) .ge. 1 & .and. nproc2 .le. 2 & .and. kk .ne. 1) then npivsplit(kk)=-npiv2 nproc2=nproc else if (keep(79) .ge. 1 & .and. kk .ne. 1) then if (optimization_strategy .eq. 0) then npivOld = min(npiv - nass, & npiv4equilibreRows(nfront - nass, nproc )) npivNew = min(npiv - nass, & npiv4equilibreRows(nfront - nass, nproc2 - 1.0d0)) else if (optimization_strategy .eq. 1) then npivOld = min(npiv - nass, & npiv4equilibreFlops(nfront - nass, nproc )) npivNew = min(npiv - nass, & npiv4equilibreRows(nfront - nass, nproc2 - 1.0d0)) else write(*,*) "Internal error in MUMPS_GET_SPLIT_4_PERF," write(*,*) "optimization_strategy not implemented" call MUMPS_ABORT() endif timeAss = timeAssembly(int(nfront-nass,8), nproc2) timeFacOld = timeFacto(int(nfront-nass,8), int(npivOld,8), & nproc) timeFacNew = timeFacto(int(nfront-nass,8),int(npivNew,8), & nproc2-1) if ( (flopsFactoPanel(int(npivOld,8),int(nfront-nass,8))+ & flopsUpdate(int(nfront-nass-npivOld,8), & int(nfront-nass-npivOld,8), int(npivOld,8)))/ & (timeFacOld+timeAss) & .gt. (flopsFactoPanel(int(npivNew,8),int(nfront-nass,8))+ & flopsUpdate(int(nfront-nass-npivNew,8), & int(nfront-nass-npivNew,8), int(npivNew,8)))/ & timeFacNew ) then npivsplit(kk) = -npiv2 nproc2 = nproc else nproc2 = nproc2 - 1.0d0 npiv2 = npivNew npivsplit(kk)=npivNew endif endif nass = nass + npiv2 enddo k = kk istat=0 return CONTAINS function npiv4equilibreRows(nfront, nproc) implicit none integer npiv4equilibreRows integer, intent(in) :: nfront double precision, intent(in) :: nproc npiv4equilibreRows = max(1, int(dble(nfront)/nproc)) return end function npiv4equilibreRows function npiv4equilibreFlops(nfront, nproc) implicit none integer npiv4equilibreFlops integer, intent(in) :: nfront double precision, intent(in) :: nproc double precision::n,s,a,b,c,sdelta,npiv n = dble(nfront) s = nproc - 1.0d0 a = s/3.+1. b = -3.*n - s*n - s/2. c = 2.*n**2 + s*n + s/6. sdelta = (b*b) - 4*a*c if (sdelta < 0.0E0) then WRITE(*,*) "Delta < 0 in npiv4equilibreFlops" call MUMPS_ABORT() endif sdelta = sqrt(sdelta) npiv = (-b - sdelta)/(2*a) npiv4equilibreFlops = max(1, int(npiv)) return end function npiv4equilibreFlops function flopsFactoPanel(nbrows, nbcols) integer(8) :: nbrows, nbcols double precision :: flopsFactoPanel flopsFactoPanel = (nbrows*((-1.d0/3.d0)*nbrows**2 + & (nbcols + 1.d0/2.d0)*nbrows + & (nbcols + 1.d0/6.d0))) end function flopsFactoPanel function flopsUpdate(m, n, k) integer(8) :: m, n, k double precision :: flopsUpdate flopsUpdate = dble(2*m*n*k + m*k**2) end function flopsUpdate function timeFacto(nfront, npiv, nproc) integer(8), intent(in) :: nfront, npiv double precision, intent(in) :: nproc double precision :: timeFacto timeFacto = (max(flopsFactoPanel(npiv,nfront), & flopsUpdate(nfront-npiv, nfront-npiv, npiv)/ & (nproc-1))/alpha) end function timeFacto function timeNIV1(nfront, npiv) integer(8) :: nfront, npiv double precision :: timeNIV1 timeNIV1 = ((flopsFactoPanel(npiv, nfront) + & flopsUpdate(nfront - npiv, nfront - npiv, npiv))/alpha) end function timeNIV1 function timeAssembly(n, p) integer(8) :: n double precision, intent(in) :: p double precision :: timeAssembly timeAssembly = ((n*n/p)/(gamma/(log(p)/log(2.0d0)))) end function timeAssembly end subroutine MUMPS_GET_SPLIT_4_PERF MUMPS_5.8.1/src/dfac_distrib_ELT.F0000664000175000017500000004561515042446440016473 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ELT_DISTRIB( & N, NELT, NA_ELT8, & COMM, MYID, SLAVEF, & IELPTR_LOC8, RELPTR_LOC8, & ELTVAR_LOC, ELTVAL_LOC, & LINTARR, LDBLARR, & KEEP,KEEP8, MAXELT_SIZE, & FRTPTR, FRTELT, A, LA, FILS, & id, root, roota ) USE DMUMPS_STRUC_DEF USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY: DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, NELT INTEGER(8) :: NA_ELT8 INTEGER COMM, MYID, SLAVEF, MAXELT_SIZE, MSGLEN INTEGER(8), intent(IN) :: LA INTEGER FRTPTR( N+1 ) INTEGER FRTELT( NELT ), FILS ( N ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), INTENT(IN) :: IELPTR_LOC8( NELT + 1 ) INTEGER(8), INTENT(INOUT) :: RELPTR_LOC8( NELT + 1 ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER ELTVAR_LOC( LINTARR ) DOUBLE PRECISION ELTVAL_LOC( LDBLARR ) DOUBLE PRECISION A( LA ) TYPE(DMUMPS_STRUC) :: id TYPE(MUMPS_ROOT_STRUC) :: root TYPE(DMUMPS_ROOT_STRUC) :: roota INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGTAG INTEGER allocok INTEGER I, DEST, MAXELT_REAL_SIZE, MPG, IEL, SIZEI, SIZER INTEGER NBRECORDS, NBUF INTEGER(8) :: RECV_IELTPTR8 INTEGER(8) :: RECV_RELTPTR8 INTEGER(8) :: IELTPTR8, RELTPTR8 LOGICAL FINI, PROKG, I_AM_SLAVE, EARLYT3ROOTINS INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, LP, IBEG, IGLOB, JGLOB INTEGER ARROW_ROOT INTEGER IELT, J, NB_REC, IREC INTEGER(8) :: K8, IVALPTR8 INTEGER ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, IPTR INTEGER JCOL_GRID, IROW_GRID INTEGER NBELROOT INTEGER MASTER PARAMETER( MASTER = 0 ) DOUBLE PRECISION VAL DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER, DIMENSION( :, : ), ALLOCATABLE :: BUFI DOUBLE PRECISION, DIMENSION( :, : ), ALLOCATABLE :: BUFR DOUBLE PRECISION, DIMENSION( : ), ALLOCATABLE :: TEMP_ELT_R INTEGER, DIMENSION( : ), ALLOCATABLE :: TEMP_ELT_I INTEGER(8), DIMENSION( : ), ALLOCATABLE :: ELROOTPOS8 MPG = id%ICNTL(3) LP = id%ICNTL(1) I_AM_SLAVE = ( KEEP(46) .eq. 1 .or. MYID .ne.MASTER ) PROKG = ( MPG > 0 .and. MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) KEEP(49) = 0 ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) IF ( MYID .eq. MASTER ) THEN IF ( KEEP(46) .eq. 0 ) THEN NBUF = SLAVEF ELSE NBUF = SLAVEF - 1 END IF NBRECORDS = KEEP(39) IF (NA_ELT8 < int(NBRECORDS,8)) THEN NBRECORDS = int(NA_ELT8) ENDIF IF ( KEEP(50) .eq. 0 ) THEN MAXELT_REAL_SIZE = MAXELT_SIZE * MAXELT_SIZE ELSE MAXELT_REAL_SIZE = MAXELT_SIZE * (MAXELT_SIZE+1)/2 END IF IF ( MAXELT_REAL_SIZE .GT. KEEP(39) ) THEN NBRECORDS = MAXELT_REAL_SIZE IF ( MPG .GT. 0 ) THEN WRITE(MPG,*) & ' ** Warning : For element distrib NBRECORDS set to ', & MAXELT_REAL_SIZE,' because one element is large' END IF END IF ALLOCATE( BUFI( 2*NBRECORDS+1, NBUF ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 2*NBRECORDS + 1 GOTO 100 END IF ALLOCATE( BUFR( NBRECORDS+1, NBUF ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS + 1 GOTO 100 END IF IF ( KEEP(52) .ne. 0 ) THEN ALLOCATE( TEMP_ELT_R( MAXELT_REAL_SIZE ), stat =allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXELT_REAL_SIZE GOTO 100 END IF END IF ALLOCATE( TEMP_ELT_I( MAXELT_SIZE ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXELT_SIZE GOTO 100 END IF IF ( KEEP(38) .ne. 0 ) THEN NBELROOT = FRTPTR(KEEP(38)+1)-FRTPTR(KEEP(38)) IF ( EARLYT3ROOTINS ) THEN ALLOCATE( ELROOTPOS8( max(NBELROOT,1) ), & stat = allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBELROOT GOTO 100 END IF ENDIF END IF DO I = 1, NBUF BUFI( 1, I ) = 0 BUFR( 1, I ) = ZERO END DO END IF 100 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MPI_BCAST( NBRECORDS, 1, MPI_INTEGER, MASTER, & COMM, IERR_MPI ) RECV_IELTPTR8 = 1_8 RECV_RELTPTR8 = 1_8 IF ( MYID .eq. MASTER ) THEN NBELROOT = 0 RELTPTR8 = 1_8 RELPTR_LOC8(1) = 1 DO IEL = 1, NELT IELTPTR8 = int(id%ELTPTR( IEL ),8) SIZEI = int(int(id%ELTPTR( IEL + 1 ),8) - IELTPTR8) IF ( KEEP( 50 ) .eq. 0 ) THEN SIZER = SIZEI * SIZEI ELSE SIZER = SIZEI * ( SIZEI + 1 ) / 2 END IF DEST = id%ELTPROC( IEL ) IF ( DEST .eq. -2 ) THEN NBELROOT = NBELROOT + 1 FRTELT( FRTPTR(KEEP(38)) + NBELROOT - 1 ) = IEL ELROOTPOS8( NBELROOT ) = RELTPTR8 GOTO 200 END IF IF ( DEST .ge. 0 .and. KEEP(46) .eq. 0 ) DEST = DEST + 1 IF ( KEEP(52) .ne. 0 ) THEN CALL DMUMPS_SCALE_ELEMENT( N, SIZEI, SIZER, & id%ELTVAR( IELTPTR8 ), id%A_ELT( RELTPTR8 ), & TEMP_ELT_R(1), MAXELT_REAL_SIZE, & id%ROWSCA(1), id%COLSCA(1), KEEP(50) ) END IF IF ( DEST .eq. 0 .or. ( DEST .eq. -1 .and. KEEP(46) .ne. 0 ) ) & THEN ELTVAR_LOC( RECV_IELTPTR8: RECV_IELTPTR8 + SIZEI - 1 ) & = id%ELTVAR( IELTPTR8: IELTPTR8 + SIZEI - 1 ) RECV_IELTPTR8 = RECV_IELTPTR8 + SIZEI IF ( KEEP(52) .ne. 0 & ) THEN ELTVAL_LOC( RECV_RELTPTR8: RECV_RELTPTR8 + SIZER - 1) & = TEMP_ELT_R( 1: SIZER ) RECV_RELTPTR8 = RECV_RELTPTR8 + SIZER END IF END IF IF ( DEST .NE. 0 .AND. DEST. NE. -3 ) THEN IF ( KEEP(52) .eq. 0 ) THEN CALL DMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & id%A_ELT (RELTPTR8), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) ELSE CALL DMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & TEMP_ELT_R( 1 ), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) END IF END IF 200 CONTINUE RELTPTR8 = RELTPTR8 + SIZER IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN RELPTR_LOC8( IEL + 1 ) = RELTPTR8 ELSE RELPTR_LOC8( IEL + 1 ) = RECV_RELTPTR8 ENDIF END DO IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN KEEP8(26) = RELTPTR8 - 1_8 ELSE KEEP8(26) = RECV_RELTPTR8 - 1_8 ENDIF IF ( RELTPTR8 - 1_8 .NE. NA_ELT8 ) THEN WRITE(*,*) " ** Internal error in DMUMPS_ELT_DISTRIB", & RELTPTR8 - 1_8, NA_ELT8 CALL MUMPS_ABORT() END IF DEST = -2 IELTPTR8 = 1_8 RELTPTR8 = 1_8 SIZEI = 1 SIZER = 1 CALL DMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & id%A_ELT (RELTPTR8), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) IF ( KEEP(52) .NE. 0 ) DEALLOCATE( TEMP_ELT_R ) ELSE FINI = ( RECV_IELTPTR8 .eq. IELPTR_LOC8( NELT+1 ) & .and. RECV_RELTPTR8 .eq. RELPTR_LOC8( NELT+1 ) ) DO WHILE ( .not. FINI ) CALL MPI_PROBE( MASTER, MPI_ANY_TAG, & COMM, STATUS, IERR_MPI ) MSGTAG = STATUS( MPI_TAG ) SELECT CASE ( MSGTAG ) CASE( ELT_INT ) CALL MPI_GET_COUNT( STATUS, MPI_INTEGER, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAR_LOC( RECV_IELTPTR8 ), MSGLEN, & MPI_INTEGER, MASTER, ELT_INT, & COMM, STATUS, IERR_MPI ) RECV_IELTPTR8 = RECV_IELTPTR8 + MSGLEN CASE( ELT_REAL ) CALL MPI_GET_COUNT( STATUS, MPI_DOUBLE_PRECISION, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAL_LOC( RECV_RELTPTR8 ), MSGLEN, & MPI_DOUBLE_PRECISION, MASTER, ELT_REAL, & COMM, STATUS, IERR_MPI ) RECV_RELTPTR8 = RECV_RELTPTR8 + MSGLEN END SELECT FINI = ( RECV_IELTPTR8 .eq. IELPTR_LOC8( NELT+1 ) & .and. RECV_RELTPTR8 .eq. RELPTR_LOC8( NELT+1 ) ) END DO END IF IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN IF ( I_AM_SLAVE .and. root%yes ) THEN CALL DMUMPS_GET_ROOT_INFO(root, & LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL DMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) END IF IF ( MYID .NE. MASTER ) THEN ALLOCATE( BUFI( NBRECORDS * 2 + 1, 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS * 2 + 1 GOTO 250 END IF ALLOCATE( BUFR( NBRECORDS, 1 ) , stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS END IF END IF 250 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF ( MYID .eq. MASTER ) THEN DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1 IELT = FRTELT( IPTR ) SIZEI = id%ELTPTR( IELT + 1 ) - id%ELTPTR( IELT ) DO I = 1, SIZEI TEMP_ELT_I( I ) = root%RG2L & ( id%ELTVAR( id%ELTPTR(IELT) + I - 1 ) ) END DO IVALPTR8 = ELROOTPOS8( IPTR - FRTPTR(KEEP(38)) + 1 ) - 1 K8 = 1_8 DO J = 1, SIZEI JGLOB = id%ELTVAR( id%ELTPTR( IELT ) + J - 1 ) IF ( KEEP(50).eq. 0 ) THEN IBEG = 1 ELSE IBEG = J END IF DO I = IBEG, SIZEI IGLOB = id%ELTVAR( id%ELTPTR( IELT ) + I - 1 ) IF ( KEEP(52) .eq. 0 ) THEN VAL = id%A_ELT( IVALPTR8 + K8 ) ELSE VAL = id%A_ELT( IVALPTR8 + K8 ) * & id%ROWSCA( IGLOB ) * id%COLSCA( JGLOB ) END IF IF ( KEEP(50).eq.0 ) THEN IPOSROOT = TEMP_ELT_I( I ) JPOSROOT = TEMP_ELT_I( J ) ELSE IF ( TEMP_ELT_I(I) .GT. TEMP_ELT_I(J) ) THEN IPOSROOT = TEMP_ELT_I(I) JPOSROOT = TEMP_ELT_I(J) ELSE IPOSROOT = TEMP_ELT_I(J) JPOSROOT = TEMP_ELT_I(I) END IF END IF IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, & root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, & root%NPCOL ) IF ( KEEP(46) .eq. 0 ) THEN DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * root%NPCOL + JCOL_GRID END IF IF ( DEST .eq. MASTER ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 ARROW_ROOT = ARROW_ROOT + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & + VAL ENDIF ELSE CALL DMUMPS_ARROW_FILL_SEND_BUF_ELT( & IPOSROOT, JPOSROOT, VAL, DEST, BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM ) END IF K8 = K8 + 1_8 END DO END DO END DO CALL DMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM, KEEP(46) ) ELSE FINI = .FALSE. DO WHILE ( .not. FINI ) CALL MPI_RECV( BUFI(1,1), 2*NBRECORDS+1, & MPI_INTEGER, MASTER, & ARROWHEAD, & COMM, STATUS, IERR_MPI ) NB_REC = BUFI(1,1) ARROW_ROOT = ARROW_ROOT + NB_REC IF (NB_REC.LE.0) THEN FINI = .TRUE. NB_REC = -NB_REC ENDIF IF (NB_REC.EQ.0) EXIT CALL MPI_RECV( BUFR(1,1), NBRECORDS, MPI_DOUBLE_PRECISION, & MASTER, ARROWHEAD, & COMM, STATUS, IERR_MPI ) DO IREC = 1, NB_REC IPOSROOT = BUFI( IREC * 2, 1 ) JPOSROOT = BUFI( IREC * 2 + 1, 1 ) VAL = BUFR( IREC, 1 ) ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60).eq.0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) & = A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) & + VAL ELSE roota%SCHUR_POINTER(int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF END DO END DO DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) END IF END IF IF ( MYID .eq. MASTER ) THEN DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) IF (allocated(ELROOTPOS8)) DEALLOCATE(ELROOTPOS8) DEALLOCATE( TEMP_ELT_I ) END IF KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE DMUMPS_ELT_DISTRIB SUBROUTINE DMUMPS_ELT_FILL_BUF( & ELNODES, ELVAL, SIZEI, SIZER, & DEST, NBUF, NBRECORDS, BUFI, BUFR, COMM ) IMPLICIT NONE INTEGER SIZEI, SIZER, DEST, NBUF, NBRECORDS, COMM INTEGER ELNODES( SIZEI ), BUFI( 2*NBRECORDS + 1, NBUF ) DOUBLE PRECISION ELVAL( SIZER ), BUFR( NBRECORDS + 1, NBUF ) INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER I, IBEG, IEND, IERR_MPI, NBRECR INTEGER NBRECI DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) IF ( DEST .lt. 0 ) THEN IBEG = 1 IEND = NBUF ELSE IBEG = DEST IEND = DEST END IF DO I = IBEG, IEND NBRECI = BUFI(1,I) IF ( NBRECI .ne.0 .and. & ( DEST.eq.-2 .or. & NBRECI + SIZEI .GT. 2*NBRECORDS ) ) THEN CALL MPI_SEND( BUFI(2, I), NBRECI, MPI_INTEGER, & I, ELT_INT, COMM, IERR_MPI ) BUFI(1,I) = 0 NBRECI = 0 END IF NBRECR = int(dble(BUFR(1,I))+0.5D0) IF ( NBRECR .ne.0 .and. & ( DEST.eq.-2 .or. & NBRECR + SIZER .GT. NBRECORDS ) ) THEN CALL MPI_SEND( BUFR(2, I), NBRECR, MPI_DOUBLE_PRECISION, & I, ELT_REAL, COMM, IERR_MPI ) BUFR(1,I) = ZERO NBRECR = 0 END IF IF ( DEST .ne. -2 ) THEN BUFI( 2 + NBRECI : 2 + NBRECI + SIZEI - 1, I ) = & ELNODES( 1: SIZEI ) BUFR( 2 + NBRECR : 2 + NBRECR + SIZER - 1, I ) = & ELVAL( 1: SIZER ) BUFI(1,I) = NBRECI + SIZEI BUFR(1,I) = dble( NBRECR + SIZER ) END IF END DO RETURN END SUBROUTINE DMUMPS_ELT_FILL_BUF SUBROUTINE DMUMPS_MAXELT_SIZE( ELTPTR, NELT, MAXELT_SIZE ) INTEGER NELT, MAXELT_SIZE INTEGER ELTPTR( NELT + 1 ) INTEGER I, S MAXELT_SIZE = 0 DO I = 1, NELT S = ELTPTR( I + 1 ) - ELTPTR( I ) MAXELT_SIZE = max( S, MAXELT_SIZE ) END DO RETURN END SUBROUTINE DMUMPS_MAXELT_SIZE SUBROUTINE DMUMPS_SCALE_ELEMENT( N, SIZEI, SIZER, & ELTVAR, ELTVAL, & SELTVAL, LSELTVAL, & ROWSCA, COLSCA, K50 ) INTEGER N, SIZEI, SIZER, LSELTVAL, K50 INTEGER ELTVAR( SIZEI ) DOUBLE PRECISION ELTVAL( SIZER ) DOUBLE PRECISION SELTVAL( LSELTVAL ) DOUBLE PRECISION ROWSCA( N ), COLSCA( N ) INTEGER I, J, K K = 1 IF ( K50 .eq. 0 ) THEN DO J = 1, SIZEI DO I = 1, SIZEI SELTVAL(K) = ELTVAL(K) * & ROWSCA(ELTVAR(I)) * & COLSCA(ELTVAR(J)) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI DO I = J, SIZEI SELTVAL(K) = ELTVAL(K) * & ROWSCA(ELTVAR(I)) * & COLSCA(ELTVAR(J)) K = K + 1 END DO END DO END IF RETURN END SUBROUTINE DMUMPS_SCALE_ELEMENT MUMPS_5.8.1/src/sfac_type3_symmetrize.F0000664000175000017500000001361215042446437017700 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SYMMETRIZE( BUF, BLOCK_SIZE, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, COMM ) IMPLICIT NONE INTEGER BLOCK_SIZE, NPROW, NPCOL, LOCAL_M, LOCAL_N, N, COMM INTEGER MYROW, MYCOL, MYID REAL BUF( BLOCK_SIZE * BLOCK_SIZE ) REAL A( LOCAL_M, LOCAL_N ) INTEGER NBLOCK, IBLOCK, JBLOCK, IBLOCK_SIZE, JBLOCK_SIZE INTEGER ROW_SOURCE, ROW_DEST, COL_SOURCE, COL_DEST INTEGER IGLOB, JGLOB INTEGER IROW_LOC_SOURCE, JCOL_LOC_SOURCE INTEGER IROW_LOC_DEST, JCOL_LOC_DEST INTEGER PROC_SOURCE, PROC_DEST NBLOCK = ( N - 1 ) / BLOCK_SIZE + 1 DO IBLOCK = 1, NBLOCK IF ( IBLOCK .NE. NBLOCK & ) THEN IBLOCK_SIZE = BLOCK_SIZE ELSE IBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE END IF ROW_SOURCE = mod( IBLOCK - 1, NPROW ) COL_DEST = mod( IBLOCK - 1, NPCOL ) IGLOB = ( IBLOCK - 1 ) * BLOCK_SIZE + 1 IROW_LOC_SOURCE = BLOCK_SIZE * & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 JCOL_LOC_DEST = BLOCK_SIZE * & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 DO JBLOCK = 1, IBLOCK IF ( JBLOCK .NE. NBLOCK & ) THEN JBLOCK_SIZE = BLOCK_SIZE ELSE JBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE END IF COL_SOURCE = mod( JBLOCK - 1, NPCOL ) ROW_DEST = mod( JBLOCK - 1, NPROW ) PROC_SOURCE = ROW_SOURCE * NPCOL + COL_SOURCE PROC_DEST = ROW_DEST * NPCOL + COL_DEST IF ( PROC_SOURCE .eq. PROC_DEST ) THEN IF ( MYID .eq. PROC_DEST ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 JCOL_LOC_SOURCE = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 IROW_LOC_DEST = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 IF ( IBLOCK .eq. JBLOCK ) THEN IF ( IBLOCK_SIZE .ne. JBLOCK_SIZE ) THEN WRITE(*,*) MYID,': Error in calling transdiag:unsym' CALL MUMPS_ABORT() END IF CALL SMUMPS_TRANS_DIAG( A( IROW_LOC_SOURCE, & JCOL_LOC_SOURCE), & IBLOCK_SIZE, LOCAL_M ) ELSE CALL SMUMPS_TRANSPO( & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), & A( IROW_LOC_DEST, JCOL_LOC_DEST ), & IBLOCK_SIZE, JBLOCK_SIZE, LOCAL_M ) END IF END IF ELSE IF ( MYROW .eq. ROW_SOURCE & .AND. MYCOL .eq. COL_SOURCE ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 JCOL_LOC_SOURCE = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 CALL SMUMPS_SEND_BLOCK( BUF, & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), LOCAL_M, & IBLOCK_SIZE, JBLOCK_SIZE, COMM, PROC_DEST ) ELSE IF ( MYROW .eq. ROW_DEST & .AND. MYCOL .eq. COL_DEST ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 IROW_LOC_DEST = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 CALL SMUMPS_RECV_BLOCK( BUF, & A( IROW_LOC_DEST, JCOL_LOC_DEST ), LOCAL_M, & JBLOCK_SIZE, IBLOCK_SIZE, COMM, PROC_SOURCE ) END IF END DO END DO RETURN END SUBROUTINE SMUMPS_SYMMETRIZE SUBROUTINE SMUMPS_SEND_BLOCK( BUF, A, LDA, M, N, COMM, DEST ) IMPLICIT NONE INTEGER M, N, LDA, DEST, COMM REAL BUF(*), A(LDA,*) INTEGER I, IBUF, IERR INTEGER J INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IBUF = 1 DO J = 1, N BUF( IBUF: IBUF + M - 1 ) = A( 1 : M, J ) DO I = 1, M END DO IBUF = IBUF + M END DO CALL MPI_SEND( BUF, M * N, MPI_REAL, & DEST, SYMMETRIZE, COMM, IERR ) RETURN END SUBROUTINE SMUMPS_SEND_BLOCK SUBROUTINE SMUMPS_RECV_BLOCK( BUF, A, LDA, M, N, COMM, SOURCE ) IMPLICIT NONE INTEGER LDA, M, N, COMM, SOURCE REAL BUF(*), A( LDA, *) INTEGER I, IBUF, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) CALL MPI_RECV( BUF(1), M * N, MPI_REAL, SOURCE, & SYMMETRIZE, COMM, STATUS, IERR ) IBUF = 1 DO I = 1, M CALL scopy( N, BUF(IBUF), 1, A(I,1), LDA ) IBUF = IBUF + N END DO RETURN END SUBROUTINE SMUMPS_RECV_BLOCK SUBROUTINE SMUMPS_TRANS_DIAG( A, N, LDA ) IMPLICIT NONE INTEGER N,LDA REAL A( LDA, * ) INTEGER I, J DO I = 2, N DO J = 1, I - 1 A( J, I ) = A( I, J ) END DO END DO RETURN END SUBROUTINE SMUMPS_TRANS_DIAG SUBROUTINE SMUMPS_TRANSPO( A1, A2, M, N, LD ) IMPLICIT NONE INTEGER M,N,LD REAL A1( LD,* ), A2( LD, * ) INTEGER I, J DO J = 1, N DO I = 1, M A2( J, I ) = A1( I, J ) END DO END DO RETURN END SUBROUTINE SMUMPS_TRANSPO MUMPS_5.8.1/src/sfac_process_blfac_slave.F0000664000175000017500000005560215042446437020350 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE SMUMPS_PROCESS_BLFAC_SLAVE( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT USE MUMPS_LOAD USE SMUMPS_LR_CORE USE SMUMPS_LR_TYPE USE SMUMPS_FAC_LR USE SMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR USE SMUMPS_FAC_FRONT_AUX_M, ONLY : SMUMPS_GET_SIZE_SCHUR_IN_FRONT #if ! defined(BLR_NOOPENMP) !$ USE OMP_LIB #endif IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER PERM(N), STEP(N), PIMASTER(KEEP(28)) INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER NELT, LPTRAR INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)) INTEGER ITLOC( N + KEEP(253)), FILS( N ), DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER ND( KEEP(28) ), FRERE_STEPS( KEEP(28) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 REAL DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER INODE, IPOSK, JPOSK, NCOLU, NPIV, POSITION, IERR INTEGER(8) POSELT, POSBLOCFACTO INTEGER(8) LAELL INTEGER(8) :: LA_PTR REAL, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1 , HS, DEST, NSLAVES_FOLLOW INTEGER FPERE, TO_UPDATE_CPT_RECUR INTEGER(8) CPOS, LPOS LOGICAL DYNAMIC_ALLOC, COUNTER_WAS_HUGE LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL LASTBL_INPANEL INTEGER allocok INTEGER LR_ACTIVATED_INT LOGICAL LR_ACTIVATED, COMPRESS_CB INTEGER NB_BLR_U, CURRENT_BLR_U TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_U INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_U TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS, BEGS_BLR_COL INTEGER :: NB_BLR_LS, IPANEL, & MAXI_CLUSTER_LS, MAXI_CLUSTER, & NB_BLR_COL, MAXI_CLUSTER_COL, NPARTSASS_MASTER REAL, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT REAL, ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR REAL,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, LWORK INTEGER :: II,JJ INTEGER :: MSGSOU_BL INTEGER :: NFS4FATHER, NASS1, NELIM, INFO_TMP(2) INTEGER :: NVSCHUR_K253, NSLAVES_L, IROW_L INTEGER :: NBROWSinF REAL, ALLOCATABLE, DIMENSION(:) :: M_ARRAY REAL, ALLOCATABLE, DIMENSION(:) :: UDYNAMIC REAL ONE,ALPHA PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) DYNAMIC_ALLOC = .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 <=0 NPIV in BLFAC', NPIV 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 ) LASTBL_INPANEL = (NCOLU.LT.0) IF (LASTBL_INPANEL) NCOLU = -NCOLU CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LR_ACTIVATED_INT, 1, & MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IPANEL, 1, & MPI_INTEGER, COMM, IERR ) IF (LR_ACTIVATED) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_U, 1, MPI_INTEGER, & COMM, IERR ) CURRENT_BLR_U = 1 ALLOCATE(BLR_U(max(NB_BLR_U,1)), & BEGS_BLR_U(NB_BLR_U+2), stat=allocok) if (allocok .GT. 0) THEN IFLAG = -13 IERROR = max(NB_BLR_U,1) + NB_BLR_U+2 GOTO 700 endif CALL SMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, JPOSK-1, 0, 'V', & BLR_U, NB_BLR_U, & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE LAELL = int(NPIV,8) * int(NCOLU,8) CALL SMUMPS_GET_SIZE_NEEDED( & 0, LAELL, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID, SLAVEF, & PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8, LAELL,KEEP,KEEP8,LRLUS) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOLU, & MPI_REAL, & COMM, IERR ) ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) DYNAMIC_ALLOC = .TRUE. IF ( (PTRIST(STEP( INODE )).NE.0) .AND. & (IPOSK + NPIV -1 .GT. & IW(PTRIST(STEP(INODE))+3+KEEP(IXSZ))) )THEN DYNAMIC_ALLOC = .TRUE. ENDIF IF (LR_ACTIVATED) THEN DYNAMIC_ALLOC = .FALSE. ENDIF IF (DYNAMIC_ALLOC) THEN ALLOCATE(UDYNAMIC(LAELL), stat=allocok) if (allocok .GT. 0) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(LAELL,IERROR) GOTO 700 endif UDYNAMIC(1_8:LAELL) = A(POSBLOCFACTO:POSBLOCFACTO+LAELL-1_8) LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(69) = KEEP8(69) - LAELL POSFAC = POSFAC - LAELL CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) THEN CALL SMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF DO WHILE ( IPOSK + NPIV -1 .GT. & IW( PTRIST(STEP( INODE )) + 3 +KEEP(IXSZ)) ) MSGSOU_BL = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IOLDPS = PTRIST(STEP(INODE)) NSLAVES_FOLLOW = IW( IOLDPS+5+KEEP(IXSZ))-XTRA_SLAVES_SYM NASS1 = abs(IW( IOLDPS + 1 + KEEP(IXSZ))) TO_UPDATE_CPT_RECUR = & ( SLAVEF - NSLAVES_FOLLOW - 1 ) * & (2*NASS1/KEEP(6)) IF ( IW(IOLDPS+6+KEEP(IXSZ)) .eq. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN COUNTER_WAS_HUGE=.TRUE. IW(IOLDPS+6+KEEP(IXSZ)) = 1 ELSE COUNTER_WAS_HUGE=.FALSE. ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) - TO_UPDATE_CPT_RECUR - 10 BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU_BL, BLOC_FACTO_SYM, STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + TO_UPDATE_CPT_RECUR + 10 IF ( COUNTER_WAS_HUGE .AND. & IW(IOLDPS+6+KEEP(IXSZ)).EQ.1 ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = huge(IW(IOLDPS+6+KEEP(IXSZ))) ENDIF IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP( INODE )) CALL SMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF (LR_ACTIVATED) THEN CALL SMUMPS_BLR_DEC_AND_RETRIEVE_L (IW(IOLDPS+XXF), IPANEL, & BEGS_BLR_LS, BLR_LS, NCOLU) NB_BLR_LS = size(BEGS_BLR_LS)-2 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL SMUMPS_BLR_UPDATE_TRAILING_I ( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_U(1), size(BEGS_BLR_U), & CURRENT_BLR_U, & BLR_LS(1), NB_BLR_LS+1, & BLR_U(1), NB_BLR_U+1, & 0, & .TRUE., & 0, & 2, & 1, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif CALL DEALLOC_BLR_PANEL(BLR_U, NB_BLR_U, KEEP8, KEEP(34)) IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) IF (IFLAG.LT.0) GOTO 700 IF (KEEP(486).EQ.3) THEN CALL SMUMPS_BLR_TRY_FREE_PANEL(IW(IOLDPS+XXF), IPANEL, & KEEP8, KEEP(34)) ENDIF ELSE CPOS = POSELT + int(JPOSK - 1,8) LPOS = POSELT + int(IPOSK - 1,8) IF ( NPIV .GT. 0 ) THEN IF (DYNAMIC_ALLOC) THEN CALL sgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & UDYNAMIC(1), NPIV, & A_PTR( LPOS ), NCOL1, ONE, & A_PTR( CPOS ), NCOL1 ) ELSE CALL sgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & A( POSBLOCFACTO ), NPIV, & A_PTR( LPOS ), NCOL1, ONE, & A_PTR( CPOS ), NCOL1 ) ENDIF ENDIF ENDIF IF (NPIV .GT. 0) THEN FLOP1 = dble(NCOLU*NPIV)*dble(2*NROW1) FLOP1 = -FLOP1 CALL MUMPS_LOAD_UPDATE(1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IF (LASTBL_INPANEL) THEN IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + 1 ENDIF IF (.NOT.LR_ACTIVATED) THEN IF (DYNAMIC_ALLOC) THEN DEALLOCATE(UDYNAMIC) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(69) = KEEP8(69) - LAELL POSFAC = POSFAC - LAELL CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF ENDIF NSLAVES_FOLLOW = IW( IOLDPS + 5 +KEEP(IXSZ) ) - XTRA_SLAVES_SYM IF ( IW( IOLDPS + 6 +KEEP(IXSZ)) .eq. 0 .and. & KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 ) & THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) CALL MUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_BLFAC_SLAVE.' IFLAG = -99 GOTO 700 END IF END IF IF (IW(PTRIST(STEP(INODE)) + 6+KEEP(IXSZ) ) .eq. 0) THEN NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 4 + KEEP(IXSZ)) NELIM = NASS1 - NPIV1 COMPRESS_CB= .FALSE. IF (LR_ACTIVATED) THEN COMPRESS_CB = ((IW(PTRIST(STEP(INODE))+XXLR).EQ.1).OR. & (IW(PTRIST(STEP(INODE))+XXLR).EQ.3)) IF (NPIV.EQ.0) CALL MUMPS_ABORT() IF (COMPRESS_CB) THEN CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) NB_BLR_COL = size(BEGS_BLR_COL) - 1 allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_MASTER), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_MASTER) GOTO 700 ENDIF DO II=1,NB_BLR_LS DO JJ=1,NB_BLR_COL-NPARTSASS_MASTER CB_LRB(II,JJ)%M=0 CB_LRB(II,JJ)%N=0 NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL SMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) CALL MAX_CLUSTER(BEGS_BLR_COL( max(NPARTSASS_MASTER,1)+1: & NB_BLR_COL+1), & NB_BLR_COL-max(NPARTSASS_MASTER,1), MAXI_CLUSTER_COL ) MAXI_CLUSTER = max(MAXI_CLUSTER_LS, & MAXI_CLUSTER_COL+NELIM,NPIV) LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL SMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) NFS4FATHER = max(NFS4FATHER,0) + NELIM ENDIF ALLOCATE(M_ARRAY(max(NFS4FATHER,1)), stat=allocok) IF (allocok.gt.0) THEN IFLAG = -13 IERROR = max(NFS4FATHER,1) GOTO 700 ENDIF BEGS_BLR_COL(1+NPARTSASS_MASTER) = & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM NBROWSinF = 0 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN CALL SMUMPS_COMPUTE_NBROWSinF ( & N, INODE, FPERE, KEEP, & IOLDPS, HS, & IW, LIW, & NROW1, NCOL1, NPIV1, & NELIM, NFS4FATHER, & NBROWSinF & ) ENDIF IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) & .AND. (KEEP(50).EQ.2) & ) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL SMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR_K253 ) ELSE NVSCHUR_K253 = 0 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL SMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_LS, NB_BLR_COL-NPARTSASS_MASTER, & NPARTSASS_MASTER, & NROW1, NCOL1-NPIV1, INODE, & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV1, NVSCHUR_K253, KEEP(1), & M_ARRAY, & NELIM, NBROWSinF ) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 650 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL SMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF 650 CONTINUE IF (allocated(M_ARRAY)) DEALLOCATE(M_ARRAY) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF CALL SMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, roota, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF RETURN 700 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (COMPRESS_CB) THEN IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) ENDIF IF (allocated(M_ARRAY)) DEALLOCATE(M_ARRAY) IF (DYNAMIC_ALLOC) THEN IF (allocated(UDYNAMIC)) DEALLOCATE(UDYNAMIC) ENDIF RETURN END SUBROUTINE SMUMPS_PROCESS_BLFAC_SLAVE MUMPS_5.8.1/src/clr_core.F0000664000175000017500000022500715042446442015137 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C Note: the last routine of this file, xMUMPS_TRUNCATED_RRQR is derived from C the LAPACK package, for which BSD 3-clause license applies C (see header of the routine). MODULE CMUMPS_LR_CORE USE MUMPS_LR_COMMON USE CMUMPS_LR_TYPE USE MUMPS_LR_STATS USE CMUMPS_LR_DATA_M !$ USE OMP_LIB IMPLICIT NONE CONTAINS SUBROUTINE INIT_LRB(LRB_OUT,K,M,N,ISLR) C This routine simply initializes a LR block but does NOT allocate it C (allocation occurs somewhere else) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,M,N LOGICAL,INTENT(IN) :: ISLR LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%ISLR = ISLR NULLIFY(LRB_OUT%Q) NULLIFY(LRB_OUT%R) END SUBROUTINE INIT_LRB C C SUBROUTINE IS_FRONT_BLR_CANDIDATE(INODE, NIV, NFRONT, NASS, & BLRON, K489, & K490, K491, K492, K20, K60, IDAD, K38, & K123, LRSTATUS, K280, LRGROUPS) INTEGER,INTENT(IN) :: INODE, NFRONT, NASS, BLRON, K123, & K489, K490, & K491, K492, NIV, K20, K60, IDAD, K38 INTEGER,INTENT(OUT):: LRSTATUS INTEGER, INTENT(IN):: K280 INTEGER, INTENT(IN), OPTIONAL :: LRGROUPS(K280) C C Local variables LOGICAL :: COMPRESS_PANEL, COMPRESS_CB LRSTATUS = 0 C Type 3 node is not BLR IF (NIV.EQ.3) RETURN COMPRESS_PANEL = .FALSE. IF ((BLRON.NE.0).and.( & ((K492.LT.0).and.INODE.EQ.abs(K492)) & .or. & ( (K492.GT.0).and.(K491.LE.NFRONT) & .and.(K490.LE.NASS)))) THEN COMPRESS_PANEL = .TRUE. C Compression for NASS =1 is useless IF (NASS.LE.1) THEN COMPRESS_PANEL =.FALSE. ENDIF IF (present(LRGROUPS)) THEN IF (LRGROUPS (INODE) .LT. 0) COMPRESS_PANEL = .FALSE. ENDIF ENDIF COMPRESS_CB = .FALSE. IF ((BLRON.NE.0).and. & (K489.GT.0.AND.(K489.NE.2.OR.NIV.EQ.2)) & .and.( & ((K492.LT.0).and.INODE.EQ.abs(K492)) & .or. & ((K492.GT.0).AND.(NFRONT-NASS.GT.K491)))) & THEN COMPRESS_CB = .TRUE. ENDIF IF (.NOT.COMPRESS_PANEL) COMPRESS_CB=.FALSE. IF (COMPRESS_PANEL.OR.COMPRESS_CB) THEN IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN LRSTATUS = 1 ELSE IF (COMPRESS_PANEL.AND.(.NOT.COMPRESS_CB)) THEN LRSTATUS = 2 ELSE LRSTATUS = 3 ENDIF ELSE LRSTATUS = 0 ENDIF C C Schur complement cannot be BLR for now C IF ( INODE .EQ. K20 .AND. K60 .NE. 0 ) THEN LRSTATUS = 0 ENDIF C C Do not compress CB of children of root C IF ( IDAD .EQ. K38 .AND. K38 .NE.0 ) THEN COMPRESS_CB = .FALSE. IF (LRSTATUS.GE.2) THEN LRSTATUS = 2 ELSE LRSTATUS = 0 ENDIF ENDIF RETURN END SUBROUTINE IS_FRONT_BLR_CANDIDATE SUBROUTINE ALLOC_LRB(LRB_OUT,K,M,N,ISLR,IFLAG,IERROR,KEEP8) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,M,N INTEGER,INTENT(INOUT) :: IFLAG, IERROR LOGICAL,INTENT(IN) :: ISLR INTEGER(8) :: KEEP8(150) INTEGER :: MEM, allocok COMPLEX :: ZERO PARAMETER (ZERO=(0.0E0,0.0E0)) LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%ISLR = ISLR IF ((M.EQ.0).OR.(N.EQ.0)) THEN nullify(LRB_OUT%Q) nullify(LRB_OUT%R) RETURN ENDIF IF (ISLR) THEN IF (K.EQ.0) THEN nullify(LRB_OUT%Q) nullify(LRB_OUT%R) ELSE allocate(LRB_OUT%Q(M,K),LRB_OUT%R(K,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = K*(M+N) RETURN ENDIF ENDIF ELSE nullify(LRB_OUT%R) allocate(LRB_OUT%Q(M,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = M*N RETURN ENDIF ENDIF IF (ISLR) THEN MEM = M*K + N*K ELSE MEM = M*N ENDIF CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM,8), & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) RETURN END SUBROUTINE ALLOC_LRB SUBROUTINE ALLOC_LRB_FROM_ACC(ACC_LRB, LRB_OUT, K, M, N, LorU, & IFLAG, IERROR, KEEP8) TYPE(LRB_TYPE), INTENT(IN) :: ACC_LRB TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K, M, N, LorU INTEGER,INTENT(INOUT) :: IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER :: I IF (LorU.EQ.1) THEN CALL ALLOC_LRB(LRB_OUT,K,M,N,.TRUE.,IFLAG,IERROR,KEEP8) IF (IFLAG.LT.0) RETURN DO I=1,K LRB_OUT%Q(1:M,I) = ACC_LRB%Q(1:M,I) LRB_OUT%R(I,1:N) = -ACC_LRB%R(I,1:N) ENDDO ELSE CALL ALLOC_LRB(LRB_OUT,K,N,M,.TRUE.,IFLAG,IERROR,KEEP8) IF (IFLAG.LT.0) RETURN DO I=1,K LRB_OUT%Q(1:N,I) = ACC_LRB%R(I,1:N) LRB_OUT%R(I,1:M) = -ACC_LRB%Q(1:M,I) ENDDO ENDIF END SUBROUTINE ALLOC_LRB_FROM_ACC SUBROUTINE REGROUPING2(CUT, NPARTSASS, NASS, & NPARTSCB, NCB, IBCKSZ, ONLYCB, K472, & NFRONT, KEEP) INTEGER, INTENT(IN) :: IBCKSZ, NASS, NCB, NFRONT, KEEP(500) INTEGER, INTENT(INOUT) :: NPARTSCB, NPARTSASS INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER, POINTER, DIMENSION(:) :: NEW_CUT INTEGER :: I, INEW, MINSIZE, NEW_NPARTSASS, allocok LOGICAL :: ONLYCB, TRACE INTEGER, INTENT(IN) :: K472 INTEGER :: IBCKSZ2,IFLAG,IERROR ALLOCATE(NEW_CUT(max(NPARTSASS,1)+NPARTSCB+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = max(NPARTSASS,1)+NPARTSCB+1 write(*,*) 'Allocation problem in BLR routine REGROUPING2:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF CALL COMPUTE_BLR_VCS(K472, IBCKSZ2, IBCKSZ, NASS, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) NEW_NPARTSASS = max(NPARTSASS,1) IF (.NOT. ONLYCB) THEN NEW_CUT(1) = 1 INEW = 2 I = 2 DO WHILE (I .LE. NPARTSASS + 1) NEW_CUT(INEW) = CUT(I) TRACE = .FALSE. IF (NEW_CUT(INEW) - NEW_CUT(INEW-1) .GT. MINSIZE) THEN INEW = INEW + 1 TRACE = .TRUE. ENDIF I = I + 1 END DO IF (TRACE) THEN INEW = INEW - 1 ELSE IF (INEW .NE. 2) THEN NEW_CUT(INEW-1) = NEW_CUT(INEW) INEW = INEW - 1 ENDIF ENDIF NEW_NPARTSASS = INEW - 1 ENDIF IF (ONLYCB) THEN DO I=1,max(NPARTSASS,1)+1 NEW_CUT(I) = CUT(I) ENDDO ENDIF IF (NCB .EQ. 0) GO TO 50 INEW = NEW_NPARTSASS+2 I = max(NPARTSASS,1) + 2 DO WHILE (I .LE. max(NPARTSASS,1) + NPARTSCB + 1) NEW_CUT(INEW) = CUT(I) TRACE = .FALSE. IF (NEW_CUT(INEW) - NEW_CUT(INEW-1) .GT. MINSIZE) THEN INEW = INEW + 1 TRACE = .TRUE. ENDIF I = I + 1 END DO IF (TRACE) THEN INEW = INEW - 1 ELSE IF (INEW .NE. NEW_NPARTSASS+2) THEN NEW_CUT(INEW-1) = NEW_CUT(INEW) INEW = INEW - 1 ENDIF ENDIF NPARTSCB = INEW - 1 - NEW_NPARTSASS 50 CONTINUE NPARTSASS = NEW_NPARTSASS DEALLOCATE(CUT) ALLOCATE(CUT(NPARTSASS+NPARTSCB+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSASS+NPARTSCB+1 write(*,*) 'Allocation problem in BLR routine REGROUPING2:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF DO I=1,NPARTSASS+NPARTSCB+1 CUT(I) = NEW_CUT(I) ENDDO DEALLOCATE(NEW_CUT) END SUBROUTINE REGROUPING2 SUBROUTINE UPD_MRY_LU_LRGAIN( BLR_PANEL, NBBLOCKS & ) C Updates the memory gain associated with a given BLR panel INTEGER,INTENT(IN) :: NBBLOCKS TYPE(LRB_TYPE), INTENT(IN) :: BLR_PANEL(:) DOUBLE PRECISION :: MRY INTEGER :: I C MRY = 0.0D0 DO I = 1, NBBLOCKS IF (BLR_PANEL(I)%ISLR) THEN MRY = MRY + dble(BLR_PANEL(I)%M*BLR_PANEL(I)%N & - BLR_PANEL(I)%K*(BLR_PANEL(I)%M + BLR_PANEL(I)%N)) ELSE ! islr MRY = MRY + 0.0d0 ENDIF ! islr ENDDO !$OMP ATOMIC UPDATE MRY_LU_LRGAIN = MRY_LU_LRGAIN + MRY !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_LU_LRGAIN SUBROUTINE CMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA, LRB, & NIV, SYM, LorU, IW, OFFSET_IW) C ----------- C Parameters C ----------- INTEGER(8), intent(in) :: LA INTEGER, intent(in) :: NFRONT, NIV, SYM, LorU, LDA INTEGER(8), intent(in) :: POSELT_LOCAL COMPLEX, intent(inout) :: A(LA) TYPE(LRB_TYPE), intent(inout) :: LRB INTEGER, OPTIONAL:: OFFSET_IW INTEGER, OPTIONAL :: IW(*) C ----------- C Local variables C ----------- INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER :: M, N, I, J COMPLEX, POINTER :: LR_BLOCK_PTR(:,:) COMPLEX :: ONE, MONE, ZERO COMPLEX :: MULT1, MULT2, A11, DETPIV, A22, A12 PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) N = LRB%N IF (LRB%ISLR) THEN M = LRB%K LR_BLOCK_PTR => LRB%R ELSE M = LRB%M LR_BLOCK_PTR => LRB%Q END IF IF (M.NE.0) THEN C Why is it Right, Lower, Tranpose? C Because A is stored by rows C but BLR_L is stored by columns IF (SYM.EQ.0.AND.LorU.EQ.0) THEN CALL ctrsm('R', 'L', 'T', 'N', M, N, ONE, & A(POSELT_LOCAL), NFRONT, & LR_BLOCK_PTR(1,1), M) ELSE CALL ctrsm('R', 'U', 'N', 'U', M, N, ONE, & A(POSELT_LOCAL), LDA, & LR_BLOCK_PTR(1,1), M) IF (LorU.EQ.0) THEN C Now apply D scaling IF (.NOT.present(OFFSET_IW)) THEN write(*,*) 'Internal error in ', & 'CMUMPS_LRTRSM' CALL MUMPS_ABORT() ENDIF DPOS = POSELT_LOCAL I = 1 DO IF(I .GT. N) EXIT IF(IW(OFFSET_IW+I-1) .GT. 0) THEN C 1x1 pivot A11 = ONE/A(DPOS) CALL cscal(M, A11, LR_BLOCK_PTR(1,I), 1) DPOS = DPOS + int(LDA + 1,8) I = I+1 ELSE C 2x2 pivot POSPV1 = DPOS POSPV2 = DPOS+ int(LDA + 1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV DO J = 1,M MULT1 = A11*LR_BLOCK_PTR(J,I)+A12*LR_BLOCK_PTR(J,I+1) MULT2 = A12*LR_BLOCK_PTR(J,I)+A22*LR_BLOCK_PTR(J,I+1) LR_BLOCK_PTR(J,I) = MULT1 LR_BLOCK_PTR(J,I+1) = MULT2 ENDDO DPOS = POSPV2 + int(LDA + 1,8) I = I+2 ENDIF ENDDO ENDIF ENDIF ENDIF CALL UPD_FLOP_TRSM(LRB%M, LRB%N, LRB%K, LRB%ISLR, LorU) END SUBROUTINE CMUMPS_LRTRSM SUBROUTINE CMUMPS_LRGEMM_SCALING(LRB, SCALED, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, MAXI_CLUSTER) C This routine does the scaling (for the symmetric case) before C computing the LR product (done in CMUMPS_LRGEMM4) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) COMPLEX, intent(inout), DIMENSION(:,:) :: SCALED INTEGER,INTENT(IN) :: LD_DIAG, NFRONT, IW2(*) INTEGER(8), INTENT(IN) :: POSELTT COMPLEX, INTENT(IN), OPTIONAL :: DIAG(*) INTEGER, INTENT(IN) :: MAXI_CLUSTER COMPLEX, intent(inout) :: BLOCK(MAXI_CLUSTER) INTEGER :: J, NROWS COMPLEX :: PIV1, PIV2, OFFDIAG IF (LRB%ISLR) THEN NROWS = LRB%K ELSE NROWS = LRB%M ENDIF J = 1 DO WHILE (J <= LRB%N) IF (IW2(J) > 0) THEN SCALED(1:NROWS,J) = DIAG(1+LD_DIAG*(J-1)+J-1) & * SCALED(1:NROWS,J) J = J+1 ELSE !2x2 pivot PIV1 = DIAG(1+LD_DIAG*(J-1)+J-1) PIV2 = DIAG(1+LD_DIAG*J+J) OFFDIAG = DIAG(1+LD_DIAG*(J-1)+J) BLOCK(1:NROWS) = SCALED(1:NROWS,J) SCALED(1:NROWS,J) = PIV1 * SCALED(1:NROWS,J) & + OFFDIAG * SCALED(1:NROWS,J+1) SCALED(1:NROWS,J+1) = OFFDIAG * BLOCK(1:NROWS) & + PIV2 * SCALED(1:NROWS,J+1) J=J+2 ENDIF END DO END SUBROUTINE CMUMPS_LRGEMM_SCALING SUBROUTINE CMUMPS_LRGEMM4(ALPHA, & LRB1, LRB2, BETA, & A, LA, POSELTT, NFRONT, SYM, & IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & RANK, BUILDQ, & LUA_ACTIVATED, C Start of OPTIONAL arguments & LorU, & LRB3, MAXI_RANK, & MAXI_CLUSTER, & DIAG, LD_DIAG, IW2, BLOCK & ) C CC TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, SYM, TOL_OPT INTEGER,INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), INTENT(IN) :: POSELTT COMPLEX, INTENT(IN), OPTIONAL :: DIAG(*) INTEGER,INTENT(IN), OPTIONAL :: LD_DIAG, IW2(*) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL, intent(in) :: TOLEPS COMPLEX :: ALPHA,BETA LOGICAL, INTENT(OUT) :: BUILDQ COMPLEX, intent(inout), OPTIONAL :: BLOCK(*) INTEGER, INTENT(IN), OPTIONAL :: LorU LOGICAL, INTENT(IN) :: LUA_ACTIVATED INTEGER, INTENT(IN), OPTIONAL :: MAXI_CLUSTER INTEGER, INTENT(IN), OPTIONAL :: MAXI_RANK TYPE(LRB_TYPE), INTENT(INOUT), OPTIONAL :: LRB3 COMPLEX, POINTER, DIMENSION(:,:) :: XY_YZ COMPLEX, ALLOCATABLE, TARGET, DIMENSION(:,:) :: XQ, R_Y COMPLEX, POINTER, DIMENSION(:,:) :: X, Y, Y1, Y2, Z CHARACTER(len=1) :: SIDE, TRANSY INTEGER :: K_XY, K_YZ, LDY, LDY1, LDY2, K_Y INTEGER :: LDXY_YZ, SAVE_K INTEGER :: I, J, RANK, MAXRANK, INFO, LWORK REAL, ALLOCATABLE :: RWORK_RRQR(:) COMPLEX, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:), & Y_RRQR(:,:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: allocok, MREQ COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) IF (LRB1%M.EQ.0) THEN RETURN ENDIF IF (LRB2%M.EQ.0) THEN ENDIF RANK = 0 BUILDQ = .FALSE. IF (LRB1%ISLR.AND.LRB2%ISLR) THEN IF ((LRB1%K.EQ.0).OR.(LRB2%K.EQ.0)) THEN GOTO 1200 ENDIF allocate(Y(LRB1%K,LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K GOTO 1570 ENDIF X => LRB1%Q K_Y = LRB1%N IF (SYM .EQ. 0) THEN Y1 => LRB1%R ELSE allocate(Y1(LRB1%K,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%K Y1(I,J) = LRB1%R(I,J) ENDDO ENDDO CALL CMUMPS_LRGEMM_SCALING(LRB1, Y1, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY1 = LRB1%K Z => LRB2%Q Y2 => LRB2%R LDY2 = LRB2%K CALL cgemm('N', 'T', LRB1%K, LRB2%K, K_Y, ONE, & Y1(1,1), LDY1, Y2(1,1), LDY2, ZERO, Y(1,1), LRB1%K ) IF (MIDBLK_COMPRESS.GE.1) THEN LWORK = LRB2%K*(LRB2%K+1) allocate(Y_RRQR(LRB1%K,LRB2%K), & WORK_RRQR(LWORK), RWORK_RRQR(2*LRB2%K), & TAU_RRQR(MIN(LRB1%K,LRB2%K)), & JPVT_RRQR(LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K + LWORK + 2*LRB2%K + & MIN(LRB1%K,LRB2%K) + LRB2%K GOTO 1570 ENDIF DO J=1,LRB2%K DO I=1,LRB1%K Y_RRQR(I,J) = Y(I,J) ENDDO ENDDO MAXRANK = MIN(LRB1%K, LRB2%K)-1 MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) JPVT_RRQR = 0 CALL CMUMPS_TRUNCATED_RRQR(LRB1%K, LRB2%K, Y_RRQR(1,1), & LRB1%K, JPVT_RRQR, TAU_RRQR, WORK_RRQR, & LRB2%K, RWORK_RRQR, TOLEPS, TOL_OPT, RANK, & MAXRANK, INFO, & BUILDQ) IF (RANK.GT.MAXRANK) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) BUILDQ = .FALSE. ELSE BUILDQ = .TRUE. ENDIF IF (BUILDQ) THEN IF (RANK.EQ.0) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) deallocate(Y) nullify(Y) C GOTO 1580 not ok because BUILDQ .EQV. true C would try to free XQ and R_Y that are not allocated C in that case. So we free Y1 now if it was allocated. IF (SYM .NE. 0) deallocate(Y1) GOTO 1200 ELSE allocate(XQ(LRB1%M,RANK), R_Y(RANK,LRB2%K), & stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*RANK + RANK*LRB2%K GOTO 1570 ENDIF DO J=1, LRB2%K R_Y(1:MIN(RANK,J),JPVT_RRQR(J)) = & Y_RRQR(1:MIN(RANK,J),J) IF(J.LT.RANK) R_Y(MIN(RANK,J)+1: & RANK,JPVT_RRQR(J))= ZERO END DO C LWORK=LRB2%K*(LRB2%K+1), with LRB2%K>RANK C large enough for cungqr CALL cungqr & (LRB1%K, RANK, RANK, Y_RRQR(1,1), & LRB1%K, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) CALL cgemm('N', 'N', LRB1%M, RANK, LRB1%K, ONE, & X(1,1), LRB1%M, Y_RRQR(1,1), LRB1%K, ZERO, & XQ(1,1), LRB1%M) deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) nullify(X) X => XQ K_XY = RANK deallocate(Y) nullify(Y) Y => R_Y LDY = RANK K_YZ = LRB2%K TRANSY = 'N' SIDE = 'R' ENDIF ENDIF ENDIF IF (.NOT.BUILDQ) THEN LDY = LRB1%K K_XY = LRB1%K K_YZ = LRB2%K TRANSY = 'N' IF (LRB1%K .GE. LRB2%K) THEN SIDE = 'L' ELSE SIDE = 'R' ENDIF ENDIF ENDIF IF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN IF (LRB1%K.EQ.0) THEN GOTO 1200 ENDIF SIDE = 'R' K_XY = LRB1%K TRANSY = 'N' Z => LRB2%Q X => LRB1%Q LDY = LRB1%K IF (SYM .EQ. 0) THEN Y => LRB1%R ELSE allocate(Y(LRB1%K,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%K Y(I,J) = LRB1%R(I,J) ENDDO ENDDO CALL CMUMPS_LRGEMM_SCALING(LRB1, Y, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF K_YZ = LRB2%N ENDIF IF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN IF (LRB2%K.EQ.0) THEN GOTO 1200 ENDIF SIDE = 'L' K_YZ = LRB2%K X => LRB1%Q TRANSY = 'T' K_XY = LRB1%N IF (SYM .EQ. 0) THEN Y => LRB2%R ELSE allocate(Y(LRB2%K,LRB2%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB2%K*LRB2%N GOTO 1570 ENDIF DO J=1,LRB2%N DO I=1,LRB2%K Y(I,J) = LRB2%R(I,J) ENDDO ENDDO CALL CMUMPS_LRGEMM_SCALING(LRB2, Y, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY = LRB2%K Z => LRB2%Q ENDIF IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .EQ. 0) THEN X => LRB1%Q ELSE allocate(X(LRB1%M,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%M X(I,J) = LRB1%Q(I,J) ENDDO ENDDO CALL CMUMPS_LRGEMM_SCALING(LRB1, X, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF SIDE = 'N' Z => LRB2%Q K_XY = LRB1%N ENDIF IF (LUA_ACTIVATED) THEN SAVE_K = LRB3%K IF (SIDE == 'L') THEN LRB3%K = LRB3%K+K_YZ ELSEIF (SIDE == 'R') THEN LRB3%K = LRB3%K+K_XY ENDIF ENDIF IF (SIDE == 'L') THEN ! LEFT: XY_YZ = X*Y; A = XY_YZ*Z IF (.NOT.LUA_ACTIVATED) THEN allocate(XY_YZ(LRB1%M,K_YZ),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*K_YZ GOTO 1570 ENDIF LDXY_YZ = LRB1%M ELSE IF (SAVE_K+K_YZ.GT.MAXI_RANK) THEN write(*,*) 'Internal error in CMUMPS_LRGEMM4 1a', & 'K_ACC+K_CUR>K_MAX:',SAVE_K,K_YZ,MAXI_RANK CALL MUMPS_ABORT() ENDIF IF (LRB3%M.NE.LRB1%M) THEN write(*,*) 'Internal error in CMUMPS_LRGEMM4 1b', & 'LRB1%M =/= LRB3%M',LRB1%M,LRB3%M CALL MUMPS_ABORT() ENDIF XY_YZ => LRB3%Q(1:LRB1%M,SAVE_K+1:SAVE_K+K_YZ) LDXY_YZ = MAXI_CLUSTER DO I=1,K_YZ LRB3%R(SAVE_K+I,1:LRB2%M) = Z(1:LRB2%M,I) ENDDO ENDIF CALL cgemm('N', TRANSY, LRB1%M, K_YZ, K_XY, ONE, & X(1,1), LRB1%M, Y(1,1), LDY, ZERO, XY_YZ(1,1), & LDXY_YZ) IF (.NOT.LUA_ACTIVATED) THEN CALL cgemm('N', 'T', LRB1%M, LRB2%M, K_YZ, ALPHA, & XY_YZ(1,1), LRB1%M, Z(1,1), LRB2%M, BETA, & A(POSELTT), NFRONT) deallocate(XY_YZ) ENDIF ELSEIF (SIDE == 'R') THEN ! RIGHT: XY_YZ = Y*Z; A = X*XY_YZ IF (.NOT.LUA_ACTIVATED) THEN allocate(XY_YZ(K_XY,LRB2%M),stat=allocok) IF (allocok > 0) THEN MREQ = K_XY*LRB2%M GOTO 1570 ENDIF LDXY_YZ = K_XY ELSE IF (SAVE_K+K_XY.GT.MAXI_RANK) THEN write(*,*) 'Internal error in CMUMPS_LRGEMM4 2a', & 'K_ACC+K_CUR>K_MAX:',SAVE_K,K_XY,MAXI_RANK CALL MUMPS_ABORT() ENDIF IF (LRB3%N.NE.LRB2%M) THEN write(*,*) 'Internal error in CMUMPS_LRGEMM4 2b', & 'LRB2%M =/= LRB3%N',LRB2%M,LRB3%N CALL MUMPS_ABORT() ENDIF XY_YZ => LRB3%R(SAVE_K+1:SAVE_K+K_XY,1:LRB2%M) LDXY_YZ = MAXI_RANK DO I=1,K_XY LRB3%Q(1:LRB1%M,SAVE_K+I) = X(1:LRB1%M,I) ENDDO ENDIF CALL cgemm(TRANSY, 'T', K_XY, LRB2%M, K_YZ, ONE, & Y(1,1), LDY, Z(1,1), LRB2%M, ZERO, XY_YZ(1,1), & LDXY_YZ) IF (.NOT.LUA_ACTIVATED) THEN CALL cgemm('N', 'N', LRB1%M, LRB2%M, K_XY, ALPHA, & X(1,1), LRB1%M, XY_YZ(1,1), K_XY, BETA, A(POSELTT), & NFRONT) deallocate(XY_YZ) ENDIF ELSE ! SIDE == 'N' : NONE; A = X*Z CALL cgemm('N', 'T', LRB1%M, LRB2%M, K_XY, ALPHA, & X(1,1), LRB1%M, Z(1,1), LRB2%M, BETA, A(POSELTT), & NFRONT) ENDIF GOTO 1580 1570 CONTINUE C Alloc NOT ok!! IFLAG = -13 IERROR = MREQ RETURN 1580 CONTINUE C Alloc ok!! IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .NE. 0) deallocate(X) ELSEIF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN IF (SYM .NE. 0) deallocate(Y) ELSEIF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .NE. 0) deallocate(Y) ELSE IF (SYM .NE. 0) deallocate(Y1) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN deallocate(XQ) deallocate(R_Y) ELSE deallocate(Y) ENDIF ENDIF 1200 CONTINUE END SUBROUTINE CMUMPS_LRGEMM4 SUBROUTINE CMUMPS_DECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, LorU, & COUNT_FLOPS) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK INTEGER(8), INTENT(IN) :: POSELTT LOGICAL, OPTIONAL :: COUNT_FLOPS LOGICAL :: COUNT_FLOPS_LOC INTEGER :: LorU COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) IF (present(COUNT_FLOPS)) THEN COUNT_FLOPS_LOC=COUNT_FLOPS ELSE COUNT_FLOPS_LOC=.TRUE. ENDIF CALL cgemm('N', 'N', ACC_LRB%M, ACC_LRB%N, ACC_LRB%K, & MONE, ACC_LRB%Q(1,1), MAXI_CLUSTER, ACC_LRB%R(1,1), & MAXI_RANK, ONE, A(POSELTT), NFRONT) ACC_LRB%K = 0 END SUBROUTINE CMUMPS_DECOMPRESS_ACC SUBROUTINE CMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & TOLEPS, TOL_OPT, KPERCENT, BUILDQ, LorU, CB_COMPRESS) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, LorU, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT INTEGER(8), INTENT(IN) :: POSELTT REAL, intent(in) :: TOLEPS LOGICAL, INTENT(OUT) :: BUILDQ LOGICAL, INTENT(IN) :: CB_COMPRESS REAL, ALLOCATABLE :: RWORK_RRQR(:) COMPLEX, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: INFO, RANK, MAXRANK, LWORK INTEGER :: I, J, M, N INTEGER :: allocok, MREQ COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) M = ACC_LRB%M N = ACC_LRB%N MAXRANK = floor(real(M*N)/real(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) LWORK = N*(N+1) allocate(WORK_RRQR(LWORK), RWORK_RRQR(2*N), & TAU_RRQR(N), & JPVT_RRQR(N), stat=allocok) IF (allocok > 0) THEN MREQ = LWORK +4 *N GOTO 100 ENDIF DO I=1,N ACC_LRB%Q(1:M,I)= & - A(POSELTT+int(I-1,8)*int(NFRONT,8) : & POSELTT+int(I-1,8)*int(NFRONT,8) + int(M-1,8) ) END DO JPVT_RRQR = 0 CALL CMUMPS_TRUNCATED_RRQR(M, N, ACC_LRB%Q(1,1), & MAXI_CLUSTER, JPVT_RRQR(1), TAU_RRQR(1), & WORK_RRQR(1), & N, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK, MAXRANK, INFO, & BUILDQ) IF (BUILDQ) THEN DO J=1, N ACC_LRB%R(1:MIN(RANK,J),JPVT_RRQR(J)) = & ACC_LRB%Q(1:MIN(RANK,J),J) IF(J.LT.RANK) ACC_LRB%R(MIN(RANK,J)+1: & RANK,JPVT_RRQR(J))= ZERO END DO CALL cungqr & (M, RANK, RANK, ACC_LRB%Q(1,1), & MAXI_CLUSTER, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) DO I=1,N A( POSELTT+int(I-1,8)*int(NFRONT,8) : & POSELTT+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) = ZERO END DO ACC_LRB%K = RANK CALL UPD_FLOP_COMPRESS(ACC_LRB%M, ACC_LRB%N, ACC_LRB%K, & ACC_LRB%ISLR, CB_COMPRESS=CB_COMPRESS) ELSE ACC_LRB%K = RANK ACC_LRB%ISLR = .FALSE. CALL UPD_FLOP_COMPRESS(ACC_LRB%M, ACC_LRB%N, ACC_LRB%K, & ACC_LRB%ISLR, CB_COMPRESS=CB_COMPRESS) ACC_LRB%ISLR = .TRUE. ACC_LRB%K = 0 ENDIF deallocate(JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & CMUMPS_COMPRESS_FR_UPDATES: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE CMUMPS_COMPRESS_FR_UPDATES SUBROUTINE CMUMPS_RECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER :: IFLAG, IERROR INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER,INTENT(INOUT) :: NEW_ACC_RANK INTEGER(8), INTENT(IN) :: POSELTT INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB REAL, intent(in) :: TOLEPS REAL, ALLOCATABLE:: RWORK_RRQR(:) COMPLEX, ALLOCATABLE:: WORK_RRQR(:), TAU_RRQR(:) COMPLEX, ALLOCATABLE, DIMENSION(:,:),TARGET:: Q1, R1, & Q2, R2 INTEGER, ALLOCATABLE :: JPVT_RRQR(:) TYPE(LRB_TYPE) :: LRB1, LRB2 INTEGER :: INFO, RANK1, RANK2, RANK, MAXRANK, LWORK LOGICAL :: BUILDQ, BUILDQ1, BUILDQ2, SKIP1, SKIP2 INTEGER :: I, J, M, N, K INTEGER :: allocok, MREQ COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) SKIP1 = .FALSE. SKIP2 = .FALSE. SKIP1 = .TRUE. 1500 CONTINUE M = ACC_LRB%M N = ACC_LRB%N K = ACC_LRB%K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) IF (.FALSE.) THEN CALL CMUMPS_RECOMPRESS_ACC_V2(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, & NEW_ACC_RANK) K = ACC_LRB%K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) SKIP1 = .TRUE. SKIP2 = K.EQ.0 ENDIF IF (SKIP1.AND.SKIP2) GOTO 1600 allocate(Q1(M,K), Q2(N,K), & WORK_RRQR(LWORK), & RWORK_RRQR(2*K), & TAU_RRQR(K), & JPVT_RRQR(K), stat=allocok) IF (allocok > 0) THEN MREQ = LWORK + M*N + N*K+ 4 * K GOTO 100 ENDIF IF (SKIP1) THEN BUILDQ1 = .FALSE. ELSE DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J) ENDDO ENDDO JPVT_RRQR = 0 CALL CMUMPS_TRUNCATED_RRQR(M, K, Q1(1,1), & M, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, RANK1, & MAXRANK, INFO, & BUILDQ1) ENDIF IF (BUILDQ1) THEN allocate(R1(RANK1,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK1*K GOTO 100 ENDIF DO J=1, K R1(1:MIN(RANK1,J),JPVT_RRQR(J)) = & Q1(1:MIN(RANK1,J),J) IF(J.LT.RANK1) R1(MIN(RANK1,J)+1: & RANK1,JPVT_RRQR(J))= ZERO END DO CALL cungqr & (M, RANK1, RANK1, Q1(1,1), & M, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) ENDIF IF (SKIP2) THEN BUILDQ2 = .FALSE. ELSE DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J,I) ENDDO ENDDO JPVT_RRQR = 0 CALL CMUMPS_TRUNCATED_RRQR(N, K, Q2(1,1), & N, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK2, MAXRANK, INFO, & BUILDQ2) ENDIF IF (BUILDQ2) THEN allocate(R2(RANK2,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK2*K GOTO 100 ENDIF DO J=1, K R2(1:MIN(RANK2,J),JPVT_RRQR(J)) = & Q2(1:MIN(RANK2,J),J) IF(J.LT.RANK2) R2(MIN(RANK2,J)+1: & RANK2,JPVT_RRQR(J))= ZERO END DO CALL cungqr & (N, RANK2, RANK2, Q2(1,1), & N, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) ENDIF CALL INIT_LRB(LRB1,RANK1,M,K,BUILDQ1) CALL INIT_LRB(LRB2,RANK2,N,K,BUILDQ2) IF (BUILDQ1.OR.BUILDQ2) THEN IF (BUILDQ1) THEN LRB1%R => R1 ELSE DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J) ENDDO ENDDO ENDIF LRB1%Q => Q1 IF (BUILDQ2) THEN LRB2%R => R2 ELSE DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J,I) ENDDO ENDDO ENDIF LRB2%Q => Q2 ACC_LRB%K = 0 CALL CMUMPS_LRGEMM4(MONE, LRB1, LRB2, ONE, & A, LA, POSELTT, NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS-1, TOLEPS, TOL_OPT, & KPERCENT_RMB, & RANK, BUILDQ, .TRUE., LRB3=ACC_LRB, & MAXI_RANK=MAXI_RANK, MAXI_CLUSTER=MAXI_CLUSTER) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(LRB1%M, LRB1%N, LRB1%K, LRB1%ISLR, & LRB2%M, LRB2%N, LRB2%K, LRB2%ISLR, & MIDBLK_COMPRESS-1, RANK, BUILDQ, & .TRUE., .FALSE., REC_ACC=.TRUE.) ENDIF IF (.NOT. SKIP1) & CALL UPD_FLOP_COMPRESS(LRB1%M, LRB1%N, LRB1%K, & LRB1%ISLR, REC_ACC=.TRUE.) IF (.NOT. SKIP2) & CALL UPD_FLOP_COMPRESS(LRB2%M, LRB2%N, LRB2%K, & LRB2%ISLR, REC_ACC=.TRUE.) deallocate(Q1,Q2) IF (BUILDQ1) deallocate(R1) IF (BUILDQ2) deallocate(R2) deallocate(JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) IF (SKIP1.AND.(RANK2.GT.0)) THEN SKIP1 = .FALSE. SKIP2 = .TRUE. GOTO 1500 ENDIF 1600 CONTINUE NEW_ACC_RANK = 0 RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & CMUMPS_RECOMPRESS_ACC: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE CMUMPS_RECOMPRESS_ACC RECURSIVE SUBROUTINE CMUMPS_RECOMPRESS_ACC_NARYTREE( & ACC_LRB, MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, & KPERCENT_LUA, K478, RANK_LIST, POS_LIST, NB_NODES, & LEVEL, ACC_TMP) TYPE(LRB_TYPE),TARGET,INTENT(INOUT) :: ACC_LRB TYPE(LRB_TYPE),TARGET,INTENT(INOUT),OPTIONAL :: ACC_TMP INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER(8), INTENT(IN) :: POSELTT INTEGER(8) :: KEEP8(150) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB REAL, intent(in) :: TOLEPS INTEGER,INTENT(IN) :: K478, NB_NODES, LEVEL INTEGER,INTENT(INOUT) :: RANK_LIST(NB_NODES), POS_LIST(NB_NODES) TYPE(LRB_TYPE) :: LRB, ACC_NEW TYPE(LRB_TYPE), POINTER :: LRB_PTR LOGICAL :: RESORT INTEGER :: I, J, M, N, L, NODE_RANK, NARY, IOFF, IMAX, CURPOS INTEGER :: NB_NODES_NEW, KTOT, NEW_ACC_RANK INTEGER, ALLOCATABLE :: RANK_LIST_NEW(:), POS_LIST_NEW(:) COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) INTEGER :: allocok RESORT = .FALSE. M = ACC_LRB%M N = ACC_LRB%N NARY = -K478 IOFF = 0 NB_NODES_NEW = NB_NODES/NARY IF (NB_NODES_NEW*NARY.NE.NB_NODES) THEN NB_NODES_NEW = NB_NODES_NEW + 1 ENDIF ALLOCATE(RANK_LIST_NEW(NB_NODES_NEW),POS_LIST_NEW(NB_NODES_NEW), & stat=allocok) IF (allocok > 0) THEN write(*,*) 'Allocation error of RANK_LIST_NEW/POS_LIST_NEW ', & 'in CMUMPS_RECOMPRESS_ACC_NARYTREE' call MUMPS_ABORT() ENDIF DO J=1,NB_NODES_NEW NODE_RANK = RANK_LIST(IOFF+1) CURPOS = POS_LIST(IOFF+1) IMAX = MIN(NARY,NB_NODES-IOFF) IF (IMAX.GE.2) THEN DO I=2,IMAX IF (POS_LIST(IOFF+I).NE.CURPOS+NODE_RANK) THEN DO L=0,RANK_LIST(IOFF+I)-1 ACC_LRB%Q(1:M,CURPOS+NODE_RANK+L) = & ACC_LRB%Q(1:M,POS_LIST(IOFF+I)+L) ACC_LRB%R(CURPOS+NODE_RANK+L,1:N) = & ACC_LRB%R(POS_LIST(IOFF+I)+L,1:N) ENDDO POS_LIST(IOFF+I) = CURPOS+NODE_RANK ENDIF NODE_RANK = NODE_RANK+RANK_LIST(IOFF+I) ENDDO CALL INIT_LRB(LRB,NODE_RANK,M,N,.TRUE.) IF (.NOT.RESORT.OR.LEVEL.EQ.0) THEN LRB%Q => ACC_LRB%Q(1:M,CURPOS:CURPOS+NODE_RANK) LRB%R => ACC_LRB%R(CURPOS:CURPOS+NODE_RANK,1:N) ELSE LRB%Q => ACC_TMP%Q(1:M,CURPOS:CURPOS+NODE_RANK) LRB%R => ACC_TMP%R(CURPOS:CURPOS+NODE_RANK,1:N) ENDIF NEW_ACC_RANK = NODE_RANK-RANK_LIST(IOFF+1) IF (NEW_ACC_RANK.GT.0) THEN CALL CMUMPS_RECOMPRESS_ACC(LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF RANK_LIST_NEW(J) = LRB%K POS_LIST_NEW(J) = CURPOS ELSE RANK_LIST_NEW(J) = NODE_RANK POS_LIST_NEW(J) = CURPOS ENDIF IOFF = IOFF+IMAX ENDDO IF (NB_NODES_NEW.GT.1) THEN IF (RESORT) THEN KTOT = SUM(RANK_LIST_NEW) CALL INIT_LRB(ACC_NEW,KTOT,M,N,.TRUE.) ALLOCATE(ACC_NEW%Q(MAXI_CLUSTER,MAXI_RANK), & ACC_NEW%R(MAXI_RANK,MAXI_CLUSTER), stat=allocok) IF (allocok > 0) THEN write(*,*) 'Allocation error of ACC_NEW%Q/ACC_NEW%R ', & 'in CMUMPS_RECOMPRESS_ACC_NARYTREE' call MUMPS_ABORT() ENDIF CALL MUMPS_SORT_INT(NB_NODES_NEW, RANK_LIST_NEW, & POS_LIST_NEW) CURPOS = 1 IF (LEVEL.EQ.0) THEN LRB_PTR => ACC_LRB ELSE LRB_PTR => ACC_TMP ENDIF DO J=1,NB_NODES_NEW DO L=0,RANK_LIST_NEW(J)-1 ACC_NEW%Q(1:M,CURPOS+L) = & LRB_PTR%Q(1:M,POS_LIST_NEW(J)+L) ACC_NEW%R(CURPOS+L,1:N) = & LRB_PTR%R(POS_LIST_NEW(J)+L,1:N) ENDDO POS_LIST_NEW(J) = CURPOS CURPOS = CURPOS + RANK_LIST_NEW(J) ENDDO IF (LEVEL.GT.0) THEN CALL DEALLOC_LRB(ACC_TMP, KEEP8, 4) ENDIF CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST_NEW, POS_LIST_NEW, NB_NODES_NEW, & LEVEL+1, ACC_NEW) ELSE CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST_NEW, POS_LIST_NEW, NB_NODES_NEW, LEVEL+1) ENDIF ELSE IF (POS_LIST_NEW(1).NE.1) THEN write(*,*) 'Internal error in ', & 'CMUMPS_RECOMPRESS_ACC_NARYTREE', POS_LIST_NEW(1) ENDIF ACC_LRB%K = RANK_LIST_NEW(1) IF (RESORT.AND.LEVEL.GT.0) THEN DO L=1,ACC_LRB%K DO I=1,M ACC_LRB%Q(I,L) = ACC_TMP%Q(I,L) ENDDO DO I=1,N ACC_LRB%R(L,I) = ACC_TMP%R(L,I) ENDDO ENDDO CALL DEALLOC_LRB(ACC_TMP, KEEP8, 4) ENDIF ENDIF DEALLOCATE(RANK_LIST_NEW, POS_LIST_NEW) END SUBROUTINE CMUMPS_RECOMPRESS_ACC_NARYTREE SUBROUTINE CMUMPS_RECOMPRESS_ACC_V2(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER,INTENT(INOUT) :: NEW_ACC_RANK INTEGER(8), INTENT(IN) :: POSELTT INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB REAL, intent(in) :: TOLEPS REAL, ALLOCATABLE :: RWORK_RRQR(:) COMPLEX, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) COMPLEX, ALLOCATABLE, DIMENSION(:,:), TARGET :: & Q1, R1, Q2, PROJ INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: INFO, RANK1, MAXRANK, LWORK LOGICAL :: BUILDQ1 INTEGER :: I, J, M, N, K, K1 INTEGER :: allocok, MREQ COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) M = ACC_LRB%M N = ACC_LRB%N K = NEW_ACC_RANK K1 = ACC_LRB%K - K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) allocate(Q1(M,K), PROJ(K1, K), & WORK_RRQR(LWORK), RWORK_RRQR(2*K), & TAU_RRQR(K), & JPVT_RRQR(K), stat=allocok) IF (allocok > 0) THEN MREQ = M * K + K1 * K + LWORK + 4 * K GOTO 100 ENDIF DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J+K1) ENDDO ENDDO CALL cgemm('T', 'N', K1, K, M, ONE, ACC_LRB%Q(1,1), & MAXI_CLUSTER, Q1(1,1), M, ZERO, PROJ(1,1), K1) CALL cgemm('N', 'N', M, K, K1, MONE, ACC_LRB%Q(1,1), & MAXI_CLUSTER, PROJ(1,1), K1, ONE, Q1(1,1), M) JPVT_RRQR = 0 CALL CMUMPS_TRUNCATED_RRQR(M, K, Q1(1,1), & M, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK1, MAXRANK, INFO, & BUILDQ1) IF (BUILDQ1) THEN allocate(Q2(N,K), stat=allocok) IF (allocok > 0) THEN MREQ = N*K GOTO 100 ENDIF DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J+K1,I) ENDDO ENDDO CALL cgemm('N', 'T', K1, N, K, ONE, PROJ(1,1), K1, & Q2(1,1), N, ONE, ACC_LRB%R(1,1), MAXI_RANK) IF (RANK1.GT.0) THEN allocate(R1(RANK1,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK1*K GOTO 100 ENDIF DO J=1, K R1(1:MIN(RANK1,J),JPVT_RRQR(J)) = & Q1(1:MIN(RANK1,J),J) IF(J.LT.RANK1) R1(MIN(RANK1,J)+1: & RANK1,JPVT_RRQR(J))= ZERO END DO CALL cungqr & (M, RANK1, RANK1, Q1(1,1), & M, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) DO J=1,K DO I=1,M ACC_LRB%Q(I,J+K1) = Q1(I,J) ENDDO ENDDO CALL cgemm('N', 'T', RANK1, N, K, ONE, R1(1,1), RANK1, & Q2(1,1), N, ZERO, ACC_LRB%R(K1+1,1), MAXI_RANK) deallocate(R1) ENDIF deallocate(Q2) ACC_LRB%K = K1 + RANK1 ENDIF deallocate(PROJ) deallocate(Q1, JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & CMUMPS_RECOMPRESS_ACC_V2: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE CMUMPS_RECOMPRESS_ACC_V2 SUBROUTINE MAX_CLUSTER(CUT,CUT_SIZE,MAXI_CLUSTER) INTEGER, intent(in) :: CUT_SIZE INTEGER, intent(out) :: MAXI_CLUSTER INTEGER, DIMENSION(:), intent(in) :: CUT INTEGER :: I MAXI_CLUSTER = 0 DO I = 1, CUT_SIZE IF (CUT(I+1) - CUT(I) .GE. MAXI_CLUSTER) THEN MAXI_CLUSTER = CUT(I+1) - CUT(I) END IF END DO END SUBROUTINE MAX_CLUSTER SUBROUTINE CMUMPS_GET_LUA_ORDER(NB_BLOCKS, ORDER, RANK, IWHANDLER, & SYM, FS_OR_CB, I, J, FRFR_UPDATES, & LBANDSLAVE_IN, K474, BLR_U_COL) C ----------- C Parameters C ----------- INTEGER, INTENT(IN) :: NB_BLOCKS, IWHANDLER, SYM, FS_OR_CB, I, J INTEGER, INTENT(OUT) :: ORDER(NB_BLOCKS), RANK(NB_BLOCKS), & FRFR_UPDATES LOGICAL, OPTIONAL, INTENT(IN) :: LBANDSLAVE_IN INTEGER, OPTIONAL, INTENT(IN) :: K474 TYPE(LRB_TYPE), POINTER, OPTIONAL :: BLR_U_COL(:) C ----------- C Local variables C ----------- INTEGER :: K, IND_L, IND_U LOGICAL :: LBANDSLAVE TYPE(LRB_TYPE), POINTER :: BLR_L(:), BLR_U(:) IF (PRESENT(LBANDSLAVE_IN)) THEN LBANDSLAVE = LBANDSLAVE_IN ELSE LBANDSLAVE = .FALSE. ENDIF IF ((SYM.NE.0).AND.(FS_OR_CB.EQ.0).AND.(J.NE.0)) THEN write(6,*) 'Internal error in CMUMPS_GET_LUA_ORDER', & 'SYM, FS_OR_CB, J = ',SYM,FS_OR_CB,J CALL MUMPS_ABORT() ENDIF FRFR_UPDATES = 0 DO K = 1, NB_BLOCKS ORDER(K) = K IF (FS_OR_CB.EQ.0) THEN ! FS IF (J.EQ.0) THEN ! L panel IND_L = NB_BLOCKS+I-K IND_U = NB_BLOCKS+1-K ELSE ! U panel IND_L = NB_BLOCKS+1-K IND_U = NB_BLOCKS+I-K ENDIF ELSE ! CB IND_L = I-K IND_U = J-K ENDIF IF (LBANDSLAVE) THEN IND_L = I IF (K474.GE.2) THEN IND_U = K ENDIF ENDIF CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, ! L Panel & K, BLR_L) IF (SYM.EQ.0) THEN IF (LBANDSLAVE.AND.K474.GE.2) THEN BLR_U => BLR_U_COL ELSE CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, ! L Panel & K, BLR_U) ENDIF ELSE BLR_U => BLR_L ENDIF IF (BLR_L(IND_L)%ISLR) THEN IF (BLR_U(IND_U)%ISLR) THEN RANK(K) = min(BLR_L(IND_L)%K, BLR_U(IND_U)%K) ELSE RANK(K) = BLR_L(IND_L)%K ENDIF ELSE IF (BLR_U(IND_U)%ISLR) THEN RANK(K) = BLR_U(IND_U)%K ELSE RANK(K) = -1 FRFR_UPDATES = FRFR_UPDATES + 1 ENDIF ENDIF ENDDO CALL MUMPS_SORT_INT(NB_BLOCKS, RANK, ORDER) END SUBROUTINE CMUMPS_GET_LUA_ORDER SUBROUTINE CMUMPS_BLR_ASM_NIV1 (A, LA, POSEL1, NFRONT, NASS1, & IWHANDLER, SON_IW, LIW, LSTK, NELIM, K1, K2, SYM, & KEEP, KEEP8, OPASSW) C C Purpose C ======= C C Called by a level 1 master assembling the contribution C block of a level 1 son that has been BLR-compressed C C C Parameters C ========== C INTEGER(8) :: LA, POSEL1 INTEGER :: LIW, NFRONT, NASS1, LSTK, NELIM, K1, K2, IWHANDLER COMPLEX :: A(LA) C INTEGER :: SON_IW(LIW) INTEGER :: SON_IW(:) ! contiguity information lost but no copy INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER :: SYM DOUBLE PRECISION, INTENT(INOUT) :: OPASSW C C Local variables C =============== C COMPLEX, ALLOCATABLE :: SON_A(:) INTEGER(8) :: APOS, SON_APOS, IACHK, JJ2, NFRONT8 INTEGER :: KK, KK1, allocok, SON_LA TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:), LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_DYNAMIC INTEGER :: NB_INCB, NB_INASM, NB_BLR, I, J, M, N, II, NPIV, & IBIS, IBIS_END, FIRST_ROW, LAST_ROW, FIRST_COL, LAST_COL, & SON_LDA DOUBLE PRECISION :: PROMOTE_COST COMPLEX :: ONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_DYN(IWHANDLER, & BEGS_BLR_DYNAMIC) CALL CMUMPS_BLR_RETRIEVE_CB_LRB(IWHANDLER, CB_LRB) NB_BLR = size(BEGS_BLR_DYNAMIC)-1 NB_INCB = size(CB_LRB,1) NB_INASM = NB_BLR - NB_INCB NPIV = BEGS_BLR_DYNAMIC(NB_INASM+1)-1 NFRONT8 = int(NFRONT,8) IF (SYM.EQ.0) THEN IBIS_END = NB_INCB*NB_INCB ELSE IBIS_END = NB_INCB*(NB_INCB+1)/2 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP DO PRIVATE(IBIS, I, J, M, N, SON_LA, SON_LDA, FIRST_ROW, !$OMP& LAST_ROW, FIRST_COL, LAST_COL, LRB, SON_A, II, KK, !$OMP& APOS, IACHK, KK1, JJ2, PROMOTE_COST, allocok, SON_APOS) #endif DO IBIS = 1,IBIS_END C Determining I,J from IBIS IF (SYM.EQ.0) THEN I = (IBIS-1)/NB_INCB+1 J = IBIS - (I-1)*NB_INCB ELSE I = ceiling((1.0D0+sqrt(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 ENDIF I = I+NB_INASM J = J+NB_INASM IF (I.EQ.NB_INASM+1) THEN C first CB block, add NELIM because FIRST_ROW starts at NELIM+1 FIRST_ROW = BEGS_BLR_DYNAMIC(I)-NPIV+NELIM ELSE FIRST_ROW = BEGS_BLR_DYNAMIC(I)-NPIV ENDIF LAST_ROW = BEGS_BLR_DYNAMIC(I+1)-1-NPIV M=LAST_ROW-FIRST_ROW+1 FIRST_COL = BEGS_BLR_DYNAMIC(J)-NPIV LAST_COL = BEGS_BLR_DYNAMIC(J+1)-1-NPIV N = BEGS_BLR_DYNAMIC(J+1)-BEGS_BLR_DYNAMIC(J) SON_APOS = 1_8 SON_LA = M*N SON_LDA = N LRB => CB_LRB(I-NB_INASM,J-NB_INASM) IF (LRB%ISLR.AND.LRB%K.EQ.0) THEN C No need to perform extend-add CALL DEALLOC_LRB(LRB, KEEP8, KEEP(34)) NULLIFY(LRB) CYCLE ENDIF allocate(SON_A(SON_LA),stat=allocok) IF (allocok.GT.0) THEN write(*,*) 'Not enough memory in CMUMPS_BLR_ASM_NIV1', & ", Memory requested = ", SON_LA CALL MUMPS_ABORT() ENDIF C decompress block IF (LRB%ISLR) THEN CALL cgemm('T', 'T', N, M, LRB%K, ONE, LRB%R(1,1), LRB%K, & LRB%Q(1,1), M, ZERO, SON_A(SON_APOS), SON_LDA) PROMOTE_COST = 2.0D0*M*N*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE IF (I.EQ.J.AND.SYM.NE.0) THEN C Diag block and LDLT, copy only lower half IF (J-NB_INASM.EQ.1.AND.NELIM.GT.0) THEN C The first diagonal block is rectangular !! C with NELIM more cols than rows DO II=1,M DO KK=1,II+NELIM SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ELSE DO II=1,M DO KK=1,II SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ENDIF ELSE DO II=1,M DO KK=1,N SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ENDIF ENDIF C Deallocate block CALL DEALLOC_LRB(LRB, KEEP8, KEEP(34)) NULLIFY(LRB) C extend add in father IF (SYM.NE.0.AND.J-NB_INASM.EQ.1.AND.NELIM.GT.0) THEN C Case of LDLT with NELIM: first-block column is treated C differently as the NELIM are assembled at the end of the C father DO KK = FIRST_ROW, LAST_ROW IACHK = 1_8 + int(KK-FIRST_ROW,8)*int(SON_LDA,8) IF (SON_IW(KK+K1-1).LE.NASS1) THEN C Fully summed row of the father => permute destination in C father, symmetric swap to be done C First NELIM columns APOS = POSEL1 + int(SON_IW(KK+K1-1),8) - 1_8 DO KK1 = FIRST_COL, FIRST_COL+NELIM-1 JJ2 = APOS + int(SON_IW(K1+KK1-1)-1,8)*NFRONT8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO C Remaining columns APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 C DO KK1 = FIRST_COL+NELIM, LAST_COL C In case I=J and first block, one may have C LAST_COL > KK, but only lower triangular part C should be assembled. We use min(LAST_COL,KK) C below index to cover this case. DO KK1 = FIRST_COL+NELIM, min(LAST_COL,KK) JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ELSE APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 DO KK1 = FIRST_COL, min(LAST_COL,KK) JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ENDIF ENDDO ELSE C Case of LDLT without NELIM or LU: everything is simpler DO KK = FIRST_ROW, LAST_ROW APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 IACHK = 1_8 + int(KK-FIRST_ROW,8)*int(SON_LDA,8) IF (I.EQ.J.AND.SYM.NE.0) THEN C LDLT diag block: assemble only lower half DO KK1 = FIRST_COL, KK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ELSE DO KK1 = FIRST_COL, LAST_COL JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ENDIF ENDDO ENDIF C Deallocate SON_A DEALLOCATE(SON_A) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO !$OMP END PARALLEL #endif CALL CMUMPS_BLR_FREE_CB_LRB(IWHANDLER, C Only CB_LRB structure is left to deallocate & .TRUE., KEEP8, KEEP(34)) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN C Case of FR solve: the BLR structure could not be freed C in CMUMPS_END_FACTO_SLAVE and should be freed here C Not reachable in case of error: set INFO1 to 0 CALL CMUMPS_BLR_END_FRONT(IWHANDLER, 0, KEEP8, KEEP(34), & MTK405=KEEP(405)) ENDIF END SUBROUTINE CMUMPS_BLR_ASM_NIV1 END MODULE CMUMPS_LR_CORE C -------------------------------------------------------------------- SUBROUTINE CMUMPS_TRUNCATED_RRQR( M, N, A, LDA, JPVT, TAU, WORK, & LDW, RWORK, TOLEPS, TOL_OPT, RANK, MAXRANK, INFO, & ISLR) C This routine computes a Rank-Revealing QR factorization of a dense C matrix A. The factorization is truncated when the absolute value of C a diagonal coefficient of the R factor becomes smaller than a C prescribed threshold TOLEPS. The resulting partial Q and R factors C provide a rank-k approximation of the input matrix A with accuracy C TOLEPS. C C This routine is obtained by merging the LAPACK C (http://www.netlib.org/lapack/) CGEQP3 and CLAQPS routines and by C applying a minor modification to the outer factorization loop in C order to stop computations as soon as possible when the required C accuracy is reached. C C Copyright (c) 1992-2017 The University of Tennessee and The C University of Tennessee Research Foundation. All rights reserved. C Copyright (c) 2000-2017 The University of California Berkeley. C All rights reserved. C Copyright (c) 2006-2017 The University of Colorado Denver. C All rights reserved. C C Redistribution and use in source and binary forms, with or without C modification, are permitted provided that the following conditions C are met: C C - Redistributions of source code must retain the above copyright C notice, this list of conditions and the following disclaimer. C C - Redistributions in binary form must reproduce the above C copyright notice, this list of conditions and the following C disclaimer listed in this license in the documentation and/or C other materials provided with the distribution. C C - Neither the name of the copyright holders nor the names of its C contributors may be used to endorse or promote products derived from C this software without specific prior written permission. C C The copyright holders provide no reassurances that the source code C provided does not infringe any patent, copyright, or any other C intellectual property rights of third parties. The copyright holders C disclaim any liability to any recipient for claims brought against C recipient by any third party for infringement of that parties C intellectual property rights. C C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. C IMPLICIT NONE C INTEGER :: INFO, LDA, LDW, M, N, RANK, MAXRANK C TOL_OPT controls the tolerance option used C >0 => use 2-norm (||.||_X = ||.||_2) C <0 => use Frobenius-norm (||.||_X = ||.||_F) C Furthermore, depending on abs(TOL_OPT): C 1 => absolute: ||B_{I(k+1:end),J(k+1:end)}||_X <= TOLEPS C 2 => relative to 2-norm of the compressed block: C ||B_{I(k+1:end),J(k+1:end)}||_X <= TOLEPS*||B_{I,J}||_2 C 3 => relative to the max of the 2-norms of the row and column diagonal blocks C ||B_{I(k+1:end),J{k+1:end}}||_X <= TOLEPS*max(||B_{I,I}||_2,||B_{J,J}||_2) C 4 => relative to the sqrt of product of the 2-norms of the row and column diagonal blocks C ||B_{I(k+1:end),J{k+1:end}}||_X <= TOLEPS*sqrt(||B_{I,I}||_2*||B_{J,J}||_2) INTEGER :: TOL_OPT REAL :: TOLEPS INTEGER :: JPVT(*) REAL :: RWORK(*) COMPLEX :: A(LDA,*), TAU(*) COMPLEX :: WORK(LDW,*) LOGICAL :: ISLR REAL :: TOLEPS_EFF, TRUNC_ERR INTEGER, PARAMETER :: INB=1, INBMIN=2 INTEGER :: J, JB, MINMN, NB INTEGER :: OFFSET, ITEMP INTEGER :: LSTICC, PVT, K, RK REAL :: TEMP, TEMP2, TOL3Z COMPLEX :: AKK LOGICAL INADMISSIBLE REAL, PARAMETER :: RZERO=0.0E+0, RONE=1.0E+0 COMPLEX :: ZERO COMPLEX :: ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) REAL :: slamch INTEGER :: ilaenv, isamax EXTERNAL :: isamax, slamch EXTERNAL cgeqrf, cunmqr, xerbla EXTERNAL ilaenv EXTERNAL cgemm, cgemv, clarfg, cswap REAL, EXTERNAL :: scnrm2 REAL, EXTERNAL :: snrm2 INFO = 0 ISLR = .FALSE. IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.EQ.0 ) THEN IF( LDW.LT.N ) THEN INFO = -8 END IF END IF IF( INFO.NE.0 ) THEN WRITE(*,999) -INFO RETURN END IF MINMN = MIN(M,N) IF( MINMN.EQ.0 ) THEN RANK = 0 RETURN END IF NB = ilaenv( INB, 'CGEQRF', ' ', M, N, -1, -1 ) SELECT CASE(abs(TOL_OPT)) CASE(1) TOLEPS_EFF = TOLEPS CASE(2) C TOLEPS_EFF will be computed at step K=1 below CASE DEFAULT write(*,*) 'Internal error in CMUMPS_TRUNCATED_RRQR: TOL_OPT =', & TOL_OPT CALL MUMPS_ABORT() END SELECT TOLEPS_EFF = TOLEPS C C Avoid pointers (and TARGET attribute on RWORK/WORK) C because of implicit interface. An implicit interface C is needed to avoid intermediate array copies C VN1 => RWORK(1:N) C VN2 => RWORK(N+1:2*N) C AUXV => WORK(1:LDW,1:1) C F => WORK(1:LDW,2:NB+1) C LDF = LDW * Initialize partial column norms. The first N elements of work * store the exact column norms. DO J = 1, N C VN1( J ) = scnrm2( M, A( 1, J ), 1 ) RWORK( J ) = scnrm2( M, A( 1, J ), 1 ) C VN2( J ) = VN1( J ) RWORK( N + J ) = RWORK( J ) JPVT(J) = J END DO IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for first step C TRUNC_ERR = snrm2( N, VN1( 1 ), 1 ) TRUNC_ERR = snrm2( N, RWORK( 1 ), 1 ) ENDIF OFFSET = 0 TOL3Z = SQRT(slamch('Epsilon')) DO JB = MIN(NB,MINMN-OFFSET) LSTICC = 0 K = 0 DO IF(K.EQ.JB) EXIT K = K+1 RK = OFFSET+K C PVT = ( RK-1 ) + ISAMAX( N-RK+1, VN1( RK ), 1 ) PVT = ( RK-1 ) + isamax( N-RK+1, RWORK( RK ), 1 ) IF (RK.EQ.1) THEN C IF (abs(TOL_OPT).EQ.2) TOLEPS_EFF = VN1(PVT)*TOLEPS IF (abs(TOL_OPT).EQ.2) TOLEPS_EFF = RWORK(PVT)*TOLEPS ENDIF IF (TOL_OPT.GT.0) THEN C TRUNC_ERR = VN1(PVT) TRUNC_ERR = RWORK(PVT) C ELSE C TRUNC_ERR has been already computed at previous step ENDIF IF(TRUNC_ERR.LT.TOLEPS_EFF) THEN RANK = RK-1 ISLR = .TRUE. RETURN ENDIF INADMISSIBLE = (RK.GT.MAXRANK) IF (INADMISSIBLE) THEN RANK = RK INFO = RK ISLR = .FALSE. RETURN END IF IF( PVT.NE.RK ) THEN CALL cswap( M, A( 1, PVT ), 1, A( 1, RK ), 1 ) c CALL cswap( K-1, F( PVT-OFFSET, 1 ), LDF, c & F( K, 1 ), LDF ) CALL cswap( K-1, WORK( PVT-OFFSET, 2 ), LDW, & WORK( K, 2 ), LDW ) ITEMP = JPVT(PVT) JPVT(PVT) = JPVT(RK) JPVT(RK) = ITEMP C VN1(PVT) = VN1(RK) C VN2(PVT) = VN2(RK) RWORK(PVT) = RWORK(RK) RWORK(N+PVT) = RWORK(N+RK) END IF * Apply previous Householder reflectors to column K: * A(RK:M,RK) := A(RK:M,RK) - A(RK:M,OFFSET+1:RK-1)*F(K,1:K-1)**H. IF( K.GT.1 ) THEN DO J = 1, K-1 C F( K, J ) = CONJG( F( K, J ) ) WORK( K, J+1 ) = CONJG( WORK( K, J+1 ) ) END DO CALL cgemv( 'No transpose', M-RK+1, K-1, -ONE, C & A(RK,OFFSET+1), LDA, F(K,1), LDF, & A(RK,OFFSET+1), LDA, WORK(K,2), LDW, & ONE, A(RK,RK), 1 ) DO J = 1, K - 1 C F( K, J ) = CONJG( F( K, J ) ) WORK( K, J + 1 ) = CONJG( WORK( K, J + 1 ) ) END DO END IF * Generate elementary reflector H(k). IF( RK.LT.M ) THEN CALL clarfg( M-RK+1, A(RK,RK), A(RK+1,RK), 1, TAU(RK) ) ELSE CALL clarfg( 1, A(RK,RK), A(RK,RK), 1, TAU(RK) ) END IF AKK = A(RK,RK) A(RK,RK) = ONE * Compute Kth column of F: * F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**H*A(RK:M,K). IF( RK.LT.N ) THEN CALL cgemv( 'Conjugate transpose', M-RK+1, N-RK, TAU(RK), & A(RK,RK+1), LDA, A(RK,RK), 1, ZERO, C & F( K+1, K ), 1 ) & WORK( K+1, K+1 ), 1 ) END IF * Padding F(1:K,K) with zeros. DO J = 1, K C F( J, K ) = ZERO WORK( J, K+1 ) = ZERO END DO * Incremental updating of F: * F(1:N,K) := F(1:N-OFFSET,K) - * tau(RK)*F(1:N,1:K-1)*A(RK:M,OFFSET+1:RK-1)**H*A(RK:M,RK). IF( K.GT.1 ) THEN CALL cgemv( 'Conjugate transpose', M-RK+1, K-1, -TAU(RK), & A(RK,OFFSET+1), LDA, A(RK,RK), 1, ZERO, & WORK(1,1), 1 ) C & AUXV(1,1), 1 ) CALL cgemv( 'No transpose', N-OFFSET, K-1, ONE, & WORK(1,2), LDW, WORK(1,1), 1, ONE, WORK(1,K+1), 1 ) C & F(1,1), LDF, AUXV(1,1), 1, ONE, F(1,K), 1 ) END IF * Update the current row of A: * A(RK,RK+1:N) := A(RK,RK+1:N) - A(RK,OFFSET+1:RK)*F(K+1:N,1:K)**H. IF( RK.LT.N ) THEN CALL cgemm( 'No transpose', 'Conjugate transpose', & 1, N-RK, C & K, -ONE, A( RK, OFFSET+1 ), LDA, F( K+1, 1 ), LDF, & K, -ONE, A( RK, OFFSET+1 ), LDA, WORK( K+1,2 ), LDW, & ONE, A( RK, RK+1 ), LDA ) END IF * Update partial column norms. * IF( RK.LT.MINMN ) THEN DO J = RK + 1, N C IF( VN1( J ).NE.RZERO ) THEN IF( RWORK( J ).NE.RZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * C TEMP = ABS( A( RK, J ) ) / VN1( J ) TEMP = ABS( A( RK, J ) ) / RWORK( J ) TEMP = MAX( RZERO, ( RONE+TEMP )*( RONE-TEMP ) ) C TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 TEMP2 = TEMP*( RWORK( J ) / RWORK( N+J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN C VN2( J ) = REAL( LSTICC ) RWORK( N+J ) = REAL( LSTICC ) LSTICC = J ELSE C VN1( J ) = VN1( J )*SQRT( TEMP ) RWORK( J ) = RWORK( J )*SQRT( TEMP ) END IF END IF END DO END IF A( RK, RK ) = AKK IF (LSTICC.NE.0) EXIT IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for next step C TRUNC_ERR = snrm2( N-RK, VN1( RK+1 ), 1 ) TRUNC_ERR = snrm2( N-RK, RWORK( RK+1 ), 1 ) ENDIF END DO * Apply the block reflector to the rest of the matrix: * A(RK+1:M,RK+1:N) := A(RK+1:M,RK+1:N) - * A(RK+1:M,OFFSET+1:RK)*F(K+1:N-OFFSET,1:K)**H. IF( RK.LT.MIN(N,M) ) THEN CALL cgemm( 'No transpose', 'Conjugate transpose', M-RK, & N-RK, K, -ONE, A(RK+1,OFFSET+1), LDA, C & F(K+1,1), LDF, ONE, A(RK+1,RK+1), LDA ) & WORK(K+1,2), LDW, ONE, A(RK+1,RK+1), LDA ) END IF * Recomputation of difficult columns. DO WHILE( LSTICC.GT.0 ) C ITEMP = NINT( VN2( LSTICC ) ) ITEMP = NINT( RWORK( N + LSTICC ) ) C VN1( LSTICC ) = scnrm2( M-RK, A( RK+1, LSTICC ), 1 ) RWORK( LSTICC ) = scnrm2( M-RK, A( RK+1, LSTICC ), 1 ) * * NOTE: The computation of RWORK( LSTICC ) relies on the fact that * SNRM2 does not fail on vectors with norm below the value of * SQRT(DLAMCH('S')) * C VN2( LSTICC ) = VN1( LSTICC ) RWORK( N + LSTICC ) = RWORK( LSTICC ) LSTICC = ITEMP END DO IF(RK.GE.MINMN) EXIT OFFSET = RK IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for next step C TRUNC_ERR = snrm2( N-RK, VN1( RK+1 ), 1 ) TRUNC_ERR = snrm2( N-RK, RWORK( RK+1 ), 1 ) ENDIF END DO RANK = RK ISLR = .NOT.(RK.GT.MAXRANK) RETURN 999 FORMAT ('On entry to CMUMPS_TRUNCATED_RRQR, parameter number', & I2,' had an illegal value') END SUBROUTINE CMUMPS_TRUNCATED_RRQR MUMPS_5.8.1/src/mumps_int_def64_h.in0000664000175000017500000000116215042446422017072 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #if ! defined(MUMPS_INT_H) # define MUMPS_INT_H /* MUMPS has been configured with -DINTSIZE64: * all integers are 64-bit integers */ # define MUMPS_INTSIZE64 #endif MUMPS_5.8.1/src/zomp_tps_m.F0000664000175000017500000000126115042446441015527 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_TPS_M TYPE ZMUMPS_TPS_T COMPLEX(kind=8), DIMENSION(:), POINTER :: A END TYPE ZMUMPS_TPS_T END MODULE ZMUMPS_TPS_M SUBROUTINE ZMUMPS_TPS_M_RETURN() RETURN END SUBROUTINE ZMUMPS_TPS_M_RETURN MUMPS_5.8.1/src/zfac_process_blfac_slave.F0000664000175000017500000005602615042446441020353 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE ZMUMPS_PROCESS_BLFAC_SLAVE( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT USE MUMPS_LOAD USE ZMUMPS_LR_CORE USE ZMUMPS_LR_TYPE USE ZMUMPS_FAC_LR USE ZMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR USE ZMUMPS_FAC_FRONT_AUX_M, ONLY : ZMUMPS_GET_SIZE_SCHUR_IN_FRONT #if ! defined(BLR_NOOPENMP) !$ USE OMP_LIB #endif IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER PERM(N), STEP(N), PIMASTER(KEEP(28)) INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER NELT, LPTRAR INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)) INTEGER ITLOC( N + KEEP(253)), FILS( N ), DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER ND( KEEP(28) ), FRERE_STEPS( KEEP(28) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER INODE, IPOSK, JPOSK, NCOLU, NPIV, POSITION, IERR INTEGER(8) POSELT, POSBLOCFACTO INTEGER(8) LAELL INTEGER(8) :: LA_PTR COMPLEX(kind=8), DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1 , HS, DEST, NSLAVES_FOLLOW INTEGER FPERE, TO_UPDATE_CPT_RECUR INTEGER(8) CPOS, LPOS LOGICAL DYNAMIC_ALLOC, COUNTER_WAS_HUGE LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL LASTBL_INPANEL INTEGER allocok INTEGER LR_ACTIVATED_INT LOGICAL LR_ACTIVATED, COMPRESS_CB INTEGER NB_BLR_U, CURRENT_BLR_U TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_U INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_U TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS, BEGS_BLR_COL INTEGER :: NB_BLR_LS, IPANEL, & MAXI_CLUSTER_LS, MAXI_CLUSTER, & NB_BLR_COL, MAXI_CLUSTER_COL, NPARTSASS_MASTER COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, LWORK INTEGER :: II,JJ INTEGER :: MSGSOU_BL INTEGER :: NFS4FATHER, NASS1, NELIM, INFO_TMP(2) INTEGER :: NVSCHUR_K253, NSLAVES_L, IROW_L INTEGER :: NBROWSinF DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: M_ARRAY COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: UDYNAMIC COMPLEX(kind=8) ONE,ALPHA PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) DYNAMIC_ALLOC = .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 <=0 NPIV in BLFAC', NPIV 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 ) LASTBL_INPANEL = (NCOLU.LT.0) IF (LASTBL_INPANEL) NCOLU = -NCOLU CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LR_ACTIVATED_INT, 1, & MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IPANEL, 1, & MPI_INTEGER, COMM, IERR ) IF (LR_ACTIVATED) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_U, 1, MPI_INTEGER, & COMM, IERR ) CURRENT_BLR_U = 1 ALLOCATE(BLR_U(max(NB_BLR_U,1)), & BEGS_BLR_U(NB_BLR_U+2), stat=allocok) if (allocok .GT. 0) THEN IFLAG = -13 IERROR = max(NB_BLR_U,1) + NB_BLR_U+2 GOTO 700 endif CALL ZMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, JPOSK-1, 0, 'V', & BLR_U, NB_BLR_U, & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE LAELL = int(NPIV,8) * int(NCOLU,8) CALL ZMUMPS_GET_SIZE_NEEDED( & 0, LAELL, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID, SLAVEF, & PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8, LAELL,KEEP,KEEP8,LRLUS) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOLU, & MPI_DOUBLE_COMPLEX, & COMM, IERR ) ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) DYNAMIC_ALLOC = .TRUE. IF ( (PTRIST(STEP( INODE )).NE.0) .AND. & (IPOSK + NPIV -1 .GT. & IW(PTRIST(STEP(INODE))+3+KEEP(IXSZ))) )THEN DYNAMIC_ALLOC = .TRUE. ENDIF IF (LR_ACTIVATED) THEN DYNAMIC_ALLOC = .FALSE. ENDIF IF (DYNAMIC_ALLOC) THEN ALLOCATE(UDYNAMIC(LAELL), stat=allocok) if (allocok .GT. 0) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(LAELL,IERROR) GOTO 700 endif UDYNAMIC(1_8:LAELL) = A(POSBLOCFACTO:POSBLOCFACTO+LAELL-1_8) LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(69) = KEEP8(69) - LAELL POSFAC = POSFAC - LAELL CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) THEN CALL ZMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF DO WHILE ( IPOSK + NPIV -1 .GT. & IW( PTRIST(STEP( INODE )) + 3 +KEEP(IXSZ)) ) MSGSOU_BL = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IOLDPS = PTRIST(STEP(INODE)) NSLAVES_FOLLOW = IW( IOLDPS+5+KEEP(IXSZ))-XTRA_SLAVES_SYM NASS1 = abs(IW( IOLDPS + 1 + KEEP(IXSZ))) TO_UPDATE_CPT_RECUR = & ( SLAVEF - NSLAVES_FOLLOW - 1 ) * & (2*NASS1/KEEP(6)) IF ( IW(IOLDPS+6+KEEP(IXSZ)) .eq. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN COUNTER_WAS_HUGE=.TRUE. IW(IOLDPS+6+KEEP(IXSZ)) = 1 ELSE COUNTER_WAS_HUGE=.FALSE. ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) - TO_UPDATE_CPT_RECUR - 10 BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU_BL, BLOC_FACTO_SYM, STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + TO_UPDATE_CPT_RECUR + 10 IF ( COUNTER_WAS_HUGE .AND. & IW(IOLDPS+6+KEEP(IXSZ)).EQ.1 ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = huge(IW(IOLDPS+6+KEEP(IXSZ))) ENDIF IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP( INODE )) CALL ZMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF (LR_ACTIVATED) THEN CALL ZMUMPS_BLR_DEC_AND_RETRIEVE_L (IW(IOLDPS+XXF), IPANEL, & BEGS_BLR_LS, BLR_LS, NCOLU) NB_BLR_LS = size(BEGS_BLR_LS)-2 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL ZMUMPS_BLR_UPDATE_TRAILING_I ( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_U(1), size(BEGS_BLR_U), & CURRENT_BLR_U, & BLR_LS(1), NB_BLR_LS+1, & BLR_U(1), NB_BLR_U+1, & 0, & .TRUE., & 0, & 2, & 1, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif CALL DEALLOC_BLR_PANEL(BLR_U, NB_BLR_U, KEEP8, KEEP(34)) IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) IF (IFLAG.LT.0) GOTO 700 IF (KEEP(486).EQ.3) THEN CALL ZMUMPS_BLR_TRY_FREE_PANEL(IW(IOLDPS+XXF), IPANEL, & KEEP8, KEEP(34)) ENDIF ELSE CPOS = POSELT + int(JPOSK - 1,8) LPOS = POSELT + int(IPOSK - 1,8) IF ( NPIV .GT. 0 ) THEN IF (DYNAMIC_ALLOC) THEN CALL zgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & UDYNAMIC(1), NPIV, & A_PTR( LPOS ), NCOL1, ONE, & A_PTR( CPOS ), NCOL1 ) ELSE CALL zgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & A( POSBLOCFACTO ), NPIV, & A_PTR( LPOS ), NCOL1, ONE, & A_PTR( CPOS ), NCOL1 ) ENDIF ENDIF ENDIF IF (NPIV .GT. 0) THEN FLOP1 = dble(NCOLU*NPIV)*dble(2*NROW1) FLOP1 = -FLOP1 CALL MUMPS_LOAD_UPDATE(1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IF (LASTBL_INPANEL) THEN IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + 1 ENDIF IF (.NOT.LR_ACTIVATED) THEN IF (DYNAMIC_ALLOC) THEN DEALLOCATE(UDYNAMIC) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(69) = KEEP8(69) - LAELL POSFAC = POSFAC - LAELL CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF ENDIF NSLAVES_FOLLOW = IW( IOLDPS + 5 +KEEP(IXSZ) ) - XTRA_SLAVES_SYM IF ( IW( IOLDPS + 6 +KEEP(IXSZ)) .eq. 0 .and. & KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 ) & THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) CALL MUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_BLFAC_SLAVE.' IFLAG = -99 GOTO 700 END IF END IF IF (IW(PTRIST(STEP(INODE)) + 6+KEEP(IXSZ) ) .eq. 0) THEN NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 4 + KEEP(IXSZ)) NELIM = NASS1 - NPIV1 COMPRESS_CB= .FALSE. IF (LR_ACTIVATED) THEN COMPRESS_CB = ((IW(PTRIST(STEP(INODE))+XXLR).EQ.1).OR. & (IW(PTRIST(STEP(INODE))+XXLR).EQ.3)) IF (NPIV.EQ.0) CALL MUMPS_ABORT() IF (COMPRESS_CB) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) NB_BLR_COL = size(BEGS_BLR_COL) - 1 allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_MASTER), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_MASTER) GOTO 700 ENDIF DO II=1,NB_BLR_LS DO JJ=1,NB_BLR_COL-NPARTSASS_MASTER CB_LRB(II,JJ)%M=0 CB_LRB(II,JJ)%N=0 NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL ZMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) CALL MAX_CLUSTER(BEGS_BLR_COL( max(NPARTSASS_MASTER,1)+1: & NB_BLR_COL+1), & NB_BLR_COL-max(NPARTSASS_MASTER,1), MAXI_CLUSTER_COL ) MAXI_CLUSTER = max(MAXI_CLUSTER_LS, & MAXI_CLUSTER_COL+NELIM,NPIV) LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL ZMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) NFS4FATHER = max(NFS4FATHER,0) + NELIM ENDIF ALLOCATE(M_ARRAY(max(NFS4FATHER,1)), stat=allocok) IF (allocok.gt.0) THEN IFLAG = -13 IERROR = max(NFS4FATHER,1) GOTO 700 ENDIF BEGS_BLR_COL(1+NPARTSASS_MASTER) = & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM NBROWSinF = 0 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN CALL ZMUMPS_COMPUTE_NBROWSinF ( & N, INODE, FPERE, KEEP, & IOLDPS, HS, & IW, LIW, & NROW1, NCOL1, NPIV1, & NELIM, NFS4FATHER, & NBROWSinF & ) ENDIF IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) & .AND. (KEEP(50).EQ.2) & ) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL ZMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR_K253 ) ELSE NVSCHUR_K253 = 0 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL ZMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_LS, NB_BLR_COL-NPARTSASS_MASTER, & NPARTSASS_MASTER, & NROW1, NCOL1-NPIV1, INODE, & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV1, NVSCHUR_K253, KEEP(1), & M_ARRAY, & NELIM, NBROWSinF ) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 650 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL ZMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF 650 CONTINUE IF (allocated(M_ARRAY)) DEALLOCATE(M_ARRAY) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF CALL ZMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, roota, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF RETURN 700 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (COMPRESS_CB) THEN IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) ENDIF IF (allocated(M_ARRAY)) DEALLOCATE(M_ARRAY) IF (DYNAMIC_ALLOC) THEN IF (allocated(UDYNAMIC)) DEALLOCATE(UDYNAMIC) ENDIF RETURN END SUBROUTINE ZMUMPS_PROCESS_BLFAC_SLAVE MUMPS_5.8.1/src/dfac_process_root2slave.F0000664000175000017500000003276415042446440020166 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, & TOT_CONT_TO_RECV, root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND) USE MUMPS_LOAD USE DMUMPS_OOC USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER TOT_ROOT_SIZE, TOT_CONT_TO_RECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER ND( KEEP(28) ) INTEGER IFLAG, IERROR, COMM, COMM_LOAD INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER INTARR(KEEP8(27)) DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER :: allocok DOUBLE PRECISION, DIMENSION(:,:), POINTER :: TMP INTEGER NEW_LOCAL_M, NEW_LOCAL_N INTEGER OLD_LOCAL_M, OLD_LOCAL_N INTEGER I, J INTEGER LREQI, IROOT INTEGER(8) :: LREQA INTEGER POSHEAD, IPOS_SON,IERR LOGICAL MASTER_OF_ROOT, NO_OLD_ROOT DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INCLUDE 'mumps_headers.h' INTEGER MUMPS_NUMROC, MUMPS_PROCNODE EXTERNAL MUMPS_NUMROC, MUMPS_PROCNODE IROOT = KEEP( 38 ) root%TOT_ROOT_SIZE = TOT_ROOT_SIZE MASTER_OF_ROOT = ( MYID .EQ. & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), & KEEP(199) ) ) NEW_LOCAL_M = MUMPS_NUMROC( TOT_ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) NEW_LOCAL_M = max( 1, NEW_LOCAL_M ) NEW_LOCAL_N = MUMPS_NUMROC( TOT_ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) IF ( PTRIST(STEP( IROOT )).GT.0) THEN OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) ELSE OLD_LOCAL_N = 0 OLD_LOCAL_M = NEW_LOCAL_M ENDIF IF (PTRIST(STEP(IROOT)) .EQ.0) THEN NO_OLD_ROOT = .TRUE. ELSE NO_OLD_ROOT =.FALSE. ENDIF IF (KEEP(60) .NE. 0) THEN IF ( MASTER_OF_ROOT ) THEN LREQI=6+2*TOT_ROOT_SIZE+KEEP(IXSZ) LREQA=0_8 IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN CALL DMUMPS_COMPRE_NEW( N, KEEP, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ),COMP,DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA-LRLUS, IERROR) GOTO 700 END IF ENDIF IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB GOTO 700 ENDIF PTLUST(STEP(IROOT))= IWPOS IWPOS = IWPOS + LREQI POSHEAD = PTLUST( STEP(IROOT)) IW( POSHEAD + XXI )=LREQI CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR) ) CALL MUMPS_STOREI8( 0_8, IW(POSHEAD + XXD) ) IW( POSHEAD + XXS )=-9999 IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 IW( POSHEAD +KEEP(IXSZ)) = 0 IW( POSHEAD + 1 +KEEP(IXSZ)) = -1 IW( POSHEAD + 2 +KEEP(IXSZ)) = -1 IW( POSHEAD + 4 +KEEP(IXSZ)) = STEP(IROOT) IW( POSHEAD + 5 +KEEP(IXSZ)) = 0 IW( POSHEAD + 3 +KEEP(IXSZ)) = TOT_ROOT_SIZE ELSE PTLUST(STEP(IROOT)) = -4444 ENDIF PTRIST(STEP(IROOT)) = 0 PTRFAC(STEP(IROOT)) = -4445_8 IF (root%yes .and. NO_OLD_ROOT) THEN IF (NEW_LOCAL_N .GT. 0) THEN CALL DMUMPS_SET_TO_ZERO(roota%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC, & KEEP) IF (KEEP(55).EQ.0) THEN CALL DMUMPS_ASM_ARR_ROOT( N, root, roota, & IROOT, STEP(IROOT), & roota%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC, & root%SCHUR_NLOC, FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL DMUMPS_ASM_ELT_ROOT(N, root, roota, & roota%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC, & root%SCHUR_NLOC, LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF ENDIF ENDIF ELSE IF ( MASTER_OF_ROOT ) THEN LREQI = 6 + 2 * TOT_ROOT_SIZE+KEEP(IXSZ) ELSE LREQI = 6+KEEP(IXSZ) END IF LREQA = int(NEW_LOCAL_M, 8) * int(NEW_LOCAL_N, 8) CALL DMUMPS_GET_SIZE_NEEDED( & LREQI , LREQA, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 700 PTLUST(STEP( IROOT )) = IWPOS IWPOS = IWPOS + LREQI IF (LREQA.EQ.0_8) THEN PTRAST (STEP(IROOT)) = POSFAC PTRFAC (STEP(IROOT)) = POSFAC ELSE PTRAST (STEP(IROOT)) = POSFAC PTRFAC (STEP(IROOT)) = POSFAC ENDIF POSFAC = POSFAC + LREQA LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA KEEP8(67) = min(KEEP8(67), LRLUS) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) POSHEAD = PTLUST( STEP(IROOT)) IW( POSHEAD + XXI ) = LREQI CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR)) CALL MUMPS_STOREI8( 0_8, IW(POSHEAD + XXD)) IW( POSHEAD + XXS ) = S_NOTFREE IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 IW( POSHEAD + KEEP(IXSZ) ) = 0 IW( POSHEAD + 1 + KEEP(IXSZ) ) = NEW_LOCAL_N IW( POSHEAD + 2 + KEEP(IXSZ) ) = NEW_LOCAL_M IW( POSHEAD + 4 + KEEP(IXSZ) ) = STEP(IROOT) IW( POSHEAD + 5 + KEEP(IXSZ) ) = 0 IF ( MASTER_OF_ROOT ) THEN IW( POSHEAD + 3 + KEEP(IXSZ) ) = TOT_ROOT_SIZE ELSE IW( POSHEAD + 3 + KEEP(IXSZ) ) = 0 ENDIF IF ( PTRIST(STEP(IROOT)) .EQ. 0) THEN CALL DMUMPS_SET_TO_ZERO(A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, KEEP) IF (KEEP(55) .EQ.0 ) THEN CALL DMUMPS_ASM_ARR_ROOT( N, root, roota, & IROOT, STEP(IROOT), & A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, & FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL DMUMPS_ASM_ELT_ROOT( N, root, roota, & A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF PAMASTER(STEP(IROOT)) = 0_8 ELSE IF ( PTRIST(STEP(IROOT)) .LT. 0 ) THEN CALL DMUMPS_SET_TO_ZERO(A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, KEEP) ELSE OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) IF ( TOT_ROOT_SIZE .eq. root%ROOT_SIZE ) THEN IF ( LREQA .NE. int(OLD_LOCAL_M,8) * int(OLD_LOCAL_N,8) ) & THEN write(*,*) 'error 1 in PROCESS_ROOT2SLAVE', & OLD_LOCAL_M, OLD_LOCAL_N CALL MUMPS_ABORT() END IF CALL DMUMPS_COPYI8SIZE(LREQA, & A( PAMASTER(STEP(IROOT)) ), & A( PTRAST (STEP(IROOT)) ) ) ELSE CALL DMUMPS_COPY_ROOT( A( PTRAST(STEP(IROOT))), & NEW_LOCAL_M, & NEW_LOCAL_N, A( PAMASTER( STEP(IROOT)) ), OLD_LOCAL_M, & OLD_LOCAL_N ) END IF IF ( PTRIST( STEP( IROOT ) ) .GT. 0 ) THEN IPOS_SON= PTRIST( STEP(IROOT)) CALL DMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., & MYID, N, IPOS_SON, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) END IF ENDIF PTRIST(STEP( IROOT )) = 0 PAMASTER(STEP( IROOT )) = 0_8 ENDIF IF ( NO_OLD_ROOT ) THEN IF (KEEP(253) .GT.0) THEN root%RHS_NLOC = MUMPS_NUMROC( KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) root%RHS_NLOC = max( root%RHS_NLOC, 1 ) ELSE root%RHS_NLOC = 1 ENDIF IF (associated(roota%RHS_ROOT)) DEALLOCATE(roota%RHS_ROOT) ALLOCATE(roota%RHS_ROOT(NEW_LOCAL_M, root%RHS_NLOC), & stat=allocok) IF ( allocok.GT.0 ) THEN IFLAG = -13 IERROR = NEW_LOCAL_N * root%RHS_NLOC GOTO 700 ENDIF IF (KEEP(253) .NE. 0) THEN roota%RHS_ROOT=ZERO CALL DMUMPS_ASM_RHS_ROOT( N, FILS, root, roota, KEEP, KEEP8, & RHS_MUMPS, IFLAG, IERROR ) ENDIF ELSE IF (NEW_LOCAL_M.GT.OLD_LOCAL_M .AND. KEEP(253) .GT.0) THEN TMP => roota%RHS_ROOT NULLIFY(roota%RHS_ROOT) ALLOCATE (roota%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 roota%RHS_ROOT(I,J)=TMP(I,J) ENDDO DO I = OLD_LOCAL_M+1, NEW_LOCAL_M roota%RHS_ROOT(I,J) = ZERO ENDDO ENDDO DEALLOCATE(TMP) NULLIFY(TMP) ENDIF KEEP(121) = KEEP(121) + TOT_CONT_TO_RECV IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL DMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL DMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL DMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT + N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN 700 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE DMUMPS_PROCESS_ROOT2SLAVE SUBROUTINE DMUMPS_COPY_ROOT &( NEW, M_NEW, N_NEW,OLD, M_OLD, N_OLD ) INTEGER M_NEW, N_NEW, M_OLD, N_OLD DOUBLE PRECISION NEW( M_NEW, N_NEW ), OLD( M_OLD, N_OLD ) INTEGER J DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) DO J = 1, N_OLD NEW( 1: M_OLD, J ) = OLD( 1: M_OLD, J ) NEW( M_OLD + 1: M_NEW, J ) = ZERO END DO NEW( 1: M_NEW,N_OLD + 1: N_NEW ) = ZERO RETURN END SUBROUTINE DMUMPS_COPY_ROOT MUMPS_5.8.1/src/sfac_process_blocfacto.F0000664000175000017500000011065715042446437020045 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE SMUMPS_PROCESS_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, roota, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL, KEEP,KEEP8, DKEEP, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_OOC, ONLY : IO_BLOCK USE MUMPS_OOC_COMMON, ONLY : TYPEF_L, STRAT_TRY_WRITE USE MUMPS_LOAD USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT USE SMUMPS_LR_CORE USE SMUMPS_LR_TYPE USE MUMPS_LR_STATS USE SMUMPS_FAC_LR USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_DATA_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER(8) :: POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PERM(N), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER COMM, MYID INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)), ND(KEEP(28)) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) REAL DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER INODE, POSITION, NPIV, IERR, LP INTEGER NCOL_RECV, JBEG_BLOCK, NCOL_GEMM, SHIFT_LPOS, SHIFT_UPOS INTEGER SHIFT_BEGS_BLR_U INTEGER :: IFLAG_OOC INTEGER(8) :: POSBLOCFACTO INTEGER :: LD_BLOCFACTO INTEGER(8) :: LA_BLOCFACTO INTEGER(8) :: LA_PTR INTEGER(8) :: POSELT REAL, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW INTEGER (8) :: LPOS, UPOS, LPOS2, IPOS, KPOS INTEGER ICT11 INTEGER I, IPIV, FPERE LOGICAL LASTPANEL, KEEP_BEGS_BLR_L, KEEP_BEGS_BLR_COL LOGICAL LASTBL_INPANEL, LASTBL_INLASTPANEL LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED REAL ONE,ALPHA PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER :: INFO_TMP(2) INTEGER :: IDUMMY(1) INTEGER :: NELIM, NPARTSASS_MASTER, NPARTSASS_MASTER_AUX, & IPANEL, & CURRENT_BLR, & NB_BLR_L, NB_BLR_U, NB_BLR_COL INTEGER :: NBCOL_in_LRB, SIZE_BEGS_BLR_COL TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_U, BLR_L LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: LR_ACTIVATED_INT INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U, & BEGS_BLR_COL REAL, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT REAL,ALLOCATABLE,DIMENSION(:) :: RWORK REAL, ALLOCATABLE, DIMENSION(:,:) :: BLOCK INTEGER :: OMP_NUM INTEGER NPARTSASS, NPARTSCB, MAXI_CLUSTER, LWORK, & MAXI_CLUSTER_L, MAXI_CLUSTER_U, MAXI_CLUSTER_COL INTEGER :: allocok KEEP_BEGS_BLR_COL = .FALSE. KEEP_BEGS_BLR_L = .FALSE. nullify(BEGS_BLR_L) NB_BLR_U = -7654321 SHIFT_BEGS_BLR_U = 0 NULLIFY(BEGS_BLR_U) NULLIFY(BEGS_BLR_COL) MAXI_CLUSTER = 0 CURRENT_BLR = 1 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 ) LASTPANEL = (NPIV.LE.0) IF (LASTPANEL) 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_RECV, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, JBEG_BLOCK, 1, & MPI_INTEGER, COMM, IERR ) IF (JBEG_BLOCK.EQ.1) THEN NCOL_GEMM = NCOL_RECV - NPIV SHIFT_LPOS = NPIV SHIFT_UPOS = NPIV ELSE NCOL_GEMM = NCOL_RECV SHIFT_LPOS = JBEG_BLOCK-1 SHIFT_UPOS = 0 ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER , 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT, & 1, MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) IF ( LR_ACTIVATED ) THEN IF (JBEG_BLOCK.NE.1) THEN LA_BLOCFACTO = 0_8 ELSE LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8) ENDIF ELSE LA_BLOCFACTO = int(NPIV,8) * int(NCOL_RECV,8) ENDIF CALL SMUMPS_GET_SIZE_NEEDED( & NPIV, LA_BLOCFACTO, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID,SLAVEF, PROCNODE_STEPS, & DAD, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LA_BLOCFACTO LRLUS = LRLUS - LA_BLOCFACTO KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LA_BLOCFACTO KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LA_BLOCFACTO CALL MUMPS_LOAD_MEM_UPDATE(.FALSE., .FALSE., & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS) IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SIZE_BEGS_BLR_COL, 1, & MPI_INTEGER, COMM, IERR ) IF (SIZE_BEGS_BLR_COL.GT.0) THEN ALLOCATE(BEGS_BLR_COL(SIZE_BEGS_BLR_COL+2+IPANEL-1), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = SIZE_BEGS_BLR_COL+2 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during SMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF IF (IPANEL.GT.1) THEN BEGS_BLR_COL(1:IPANEL-1) = 1 ENDIF BEGS_BLR_COL(IPANEL) = 1 BEGS_BLR_COL(IPANEL+1) = NPIV+NELIM+1 DO I = 1, SIZE_BEGS_BLR_COL CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBCOL_in_LRB, 1, & MPI_INTEGER, COMM, IERR ) BEGS_BLR_COL(I+IPANEL+1) = & BEGS_BLR_COL(I+IPANEL) + NBCOL_in_LRB ENDDO ENDIF ENDIF IF ((NPIV .EQ. 0) & ) THEN IPIV=1 ELSE IPIV = IWPOS IWPOS = IWPOS + NPIV IF (NPIV .GT. 0.AND.JBEG_BLOCK.EQ.1) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) ENDIF IF ( LR_ACTIVATED .AND. JBEG_BLOCK.EQ.1) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*(NPIV+NELIM), & MPI_REAL, & COMM, IERR ) LD_BLOCFACTO = NPIV+NELIM ENDIF IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_U, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_U(max(NB_BLR_U,1)), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = max(NB_BLR_U,1) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during SMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF ALLOCATE(BEGS_BLR_U(NB_BLR_U+2), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_U+2 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during SMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF CALL SMUMPS_MPI_UNPACK_LR_PARTIAL & (BUFR, LBUFR, LBUFR_BYTES, & POSITION, NPIV, NELIM, 'H', & BLR_U(1), NB_BLR_U, & JBEG_BLOCK, & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (JBEG_BLOCK.NE.1) SHIFT_BEGS_BLR_U = 1 IF (IFLAG.LT.0) GOTO 700 ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL_RECV, & MPI_REAL, & COMM, IERR ) LD_BLOCFACTO = NCOL_RECV ENDIF ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) THEN CALL SMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 550 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 +KEEP(IXSZ)) .EQ. 0 ) THEN DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 550 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) CALL SMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LASTBL_INPANEL = JBEG_BLOCK+NCOL_RECV.GT.LCONT1 LASTBL_INLASTPANEL = LASTPANEL .AND. LASTBL_INPANEL IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL SMUMPS_ASM_SLAVE_ARROWHEADS(INODE, STEP(INODE), & N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, & LRGROUPS) ELSE CALL SMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 +KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) COMPRESS_CB = .FALSE. IF (LR_ACTIVATED) THEN COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) IF (COMPRESS_CB.AND.NPIV.EQ.0) THEN COMPRESS_CB = .FALSE. IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 ENDIF ENDIF NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF (NPIV.GT.0) THEN IF (JBEG_BLOCK.EQ.1) 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_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO ENDIF LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(SHIFT_LPOS,8) IF ( (JBEG_BLOCK.EQ.1) .AND. & ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) & ) THEN CALL strsm('L','L','N','N', NPIV, NROW1, ONE, & A(POSBLOCFACTO), LD_BLOCFACTO, & A_PTR(LPOS2), NCOL1) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (NPIV.NE.0) THEN IF ( (NPIV1.EQ.0).AND.(JBEG_BLOCK.EQ.1) & ) THEN IOLDPS = PTRIST(STEP(INODE)) CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_L) CALL REGROUPING2(BEGS_BLR_L, NPARTSASS, NASS1, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472), & NCOL1, KEEP(1)) NB_BLR_L = NPARTSCB IF (IFLAG.LT.0) GOTO 700 CALL SMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .TRUE., & .TRUE., & NPARTSASS_MASTER, & BEGS_BLR_L, & BEGS_BLR_COL, & huge(NPARTSASS_MASTER), & INFO_TMP) IF (associated(BEGS_BLR_COL)) DEALLOCATE(BEGS_BLR_COL) IF (IFLAG.LT.0) GOTO 700 ELSE CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_L) KEEP_BEGS_BLR_L = .TRUE. NB_BLR_L = size(BEGS_BLR_L) - 2 NPARTSASS = 1 NPARTSCB = NB_BLR_L ENDIF ENDIF ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (LR_ACTIVATED) THEN IF ( (JBEG_BLOCK.EQ.1) & ) THEN call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) call MAX_CLUSTER(BEGS_BLR_U(1+SHIFT_BEGS_BLR_U:NB_BLR_U+2), & NB_BLR_U+1-SHIFT_BEGS_BLR_U, & MAXI_CLUSTER_U) IF (SHIFT_BEGS_BLR_U.EQ.1) & MAXI_CLUSTER_U = max(MAXI_CLUSTER_U,NPIV+NELIM) IF (LASTBL_INLASTPANEL.AND.COMPRESS_CB) THEN MAXI_CLUSTER=max(MAXI_CLUSTER_U+NELIM,MAXI_CLUSTER_L) ELSE MAXI_CLUSTER=max(MAXI_CLUSTER_U,MAXI_CLUSTER_L) ENDIF LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER & + 2*MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + LWORK*OMP_NUM LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during SMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF CURRENT_BLR=1 ALLOCATE(BLR_L(NB_BLR_L), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_L LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during SMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL SMUMPS_COMPRESS_PANEL_I_NOOPT & (A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), NB_BLR_L+1, & DKEEP(8), KEEP(466), 0, & KEEP(473), BLR_L(1), & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP8, & OMP_NUM ) #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_L, 0) #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 300 IF ((KEEP(475).GE.1).AND.(JBEG_BLOCK.EQ.1)) THEN CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, & LD_BLOCFACTO, -6666, & NB_BLR_L+1, & BLR_L, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_L+1, & 2, 0, 0, & .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (KEEP(486).NE.2) THEN CALL SMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A_PTR(POSELT), LA_PTR, 1_8, & NCOL1, NCOL1, & .TRUE., & NPIV1+1, & 1, & NB_BLR_L+1, BLR_L(1), CURRENT_BLR, 'V', 1) ENDIF ENDIF 300 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ELSE CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_L) CURRENT_BLR=1 ENDIF ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & (OOCWRITE_COMPATIBLE_WITH_BLR .OR. NPIV.EQ.0) & .AND. (JBEG_BLOCK.EQ.1) & ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTPANEL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) LAST_CALL = .FALSE. CALL SMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L, & A_PTR(POSELT), & LA_PTR, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG_OOC, LAST_CALL) IF ( IFLAG_OOC .LT. 0 )THEN IFLAG = IFLAG_OOC GOTO 700 ENDIF ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (LR_ACTIVATED) THEN IF (NELIM.GT.0.AND.JBEG_BLOCK.EQ.1) THEN UPOS = 1_8+int(SHIFT_UPOS,8) CALL SMUMPS_BLR_UPD_NELIM_VAR_L_I( & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & CURRENT_BLR, BLR_L(1), NB_BLR_L+1, & CURRENT_BLR+1, NELIM, 'N') ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL SMUMPS_BLR_UPDATE_TRAILING_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & BEGS_BLR_U(1), size(BEGS_BLR_U), CURRENT_BLR, & BLR_L(1), NB_BLR_L+1, & BLR_U(1), NB_BLR_U+1, & 0, & .TRUE., & NPIV1, & 2, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ELSE UPOS = POSBLOCFACTO+int(SHIFT_UPOS,8) CALL sgemm('N','N', NCOL_GEMM, NROW1, NPIV, & ALPHA,A(UPOS), NCOL_RECV, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ENDIF ENDIF IF (LASTBL_INPANEL) THEN IW(IOLDPS + KEEP(IXSZ)) = IW(IOLDPS + KEEP(IXSZ)) - NPIV IW(IOLDPS + 3 + KEEP(IXSZ))= IW(IOLDPS + 3 + KEEP(IXSZ)) + NPIV IF (LASTPANEL) THEN IW(IOLDPS+1+KEEP(IXSZ) ) = IW(IOLDPS+3+KEEP(IXSZ) ) ENDIF ENDIF IF ( .not. LASTBL_INLASTPANEL .AND. & (IW(IOLDPS+1+KEEP(IXSZ)) .EQ. IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN write(*,*) 'Internal ERROR 1 **** IN BLACFACTO ' CALL MUMPS_ABORT() ENDIF IF (LR_ACTIVATED) THEN IF ((NPIV.GT.0) & ) THEN CALL DEALLOC_BLR_PANEL( BLR_U, NB_BLR_U, KEEP8, KEEP(34)) DEALLOCATE(BLR_U) IF (KEEP(486).NE.3) THEN CALL UPD_MRY_LU_LRGAIN(BLR_L, NPARTSCB & ) ENDIF ENDIF ENDIF LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) IWPOS = IWPOS - NPIV IF (LASTBL_INPANEL) THEN 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 MUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IF (LR_ACTIVATED.AND.LASTBL_INPANEL.AND. & (KEEP(486).EQ.3) & ) THEN IF (NPIV.NE.0) THEN CALL SMUMPS_BLR_FORCE_FREE_PANEL_L(IW(IOLDPS+XXF), IPANEL, & KEEP8, KEEP(34)) nullify(BLR_L) ENDIF ENDIF IF (LASTBL_INLASTPANEL) THEN IF (KEEP(486).NE.0) THEN IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (COMPRESS_CB) THEN CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER_AUX) KEEP_BEGS_BLR_COL = .TRUE. BEGS_BLR_COL(1+NPARTSASS_MASTER) = & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM NB_BLR_COL = size(BEGS_BLR_COL) - 1 call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) call MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER_COL=MAXI_CLUSTER_COL+NELIM IF ( (MAXI_CLUSTER.LT.MAXI_CLUSTER_COL).OR. & (MAXI_CLUSTER.LT.MAXI_CLUSTER_L) ) THEN MAXI_CLUSTER = max(MAXI_CLUSTER_COL,MAXI_CLUSTER_L) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER & + 2*MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + LWORK*OMP_NUM LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during SMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF ENDIF allocate(CB_LRB(NB_BLR_L,NB_BLR_COL-NPARTSASS_MASTER), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_L*(NB_BLR_COL-NPARTSASS_MASTER) GOTO 700 ENDIF CALL SMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif IF (COMPRESS_CB) THEN CALL SMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_L, NB_BLR_COL-NPARTSASS_MASTER, & NPARTSASS_MASTER, & NROW1, NCOL1-NPIV1-NPIV, INODE, & IW(IOLDPS+XXF), 0, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, OMP_NUM, & -9999, -9999, -9999, KEEP(1), & IDUMMY, 0, -9999 ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 IF ( KEEP(251).EQ.2 .AND. KEEP(486).EQ.2 ) THEN CALL SMUMPS_BLR_FREE_ALL_PANELS( IW(IOLDPS+XXF), & 0, & KEEP8, KEEP(34) ) ENDIF ENDIF CALL SMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, roota, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF GOTO 550 700 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 550 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(BEGS_BLR_COL)) THEN IF (.NOT. KEEP_BEGS_BLR_COL) DEALLOCATE(BEGS_BLR_COL) ENDIF IF (associated(BEGS_BLR_L)) THEN IF (.NOT. KEEP_BEGS_BLR_L) DEALLOCATE(BEGS_BLR_L) ENDIF IF ((NPIV.GT.0) & ) THEN IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_PROCESS_BLOCFACTO SUBROUTINE SMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, & NPIV, NELIM, DIR, & BLR_U, NB_BLOCK_U, & BEGS_BLR_U, KEEP8, & COMM, IERR, IFLAG, IERROR) USE SMUMPS_LR_CORE, ONLY : LRB_TYPE, ALLOC_LRB USE SMUMPS_LR_TYPE IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR INTEGER, INTENT(IN) :: LBUFR_BYTES INTEGER, INTENT(IN) :: BUFR(LBUFR) INTEGER, INTENT(INOUT) :: POSITION INTEGER, INTENT(IN) :: NB_BLOCK_U, NELIM, NPIV CHARACTER(len=1) :: DIR INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(OUT) :: IERR TYPE (LRB_TYPE), INTENT(OUT), & DIMENSION(max(NB_BLOCK_U,1)):: BLR_U INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2) :: BEGS_BLR_U INTEGER(8) :: KEEP8(150) LOGICAL :: ISLR INTEGER :: ISLR_INT, I INTEGER :: K, M, N INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IERR = 0 IF (size(BLR_U) .NE. & MAX(NB_BLOCK_U,1) ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_MPI_UNPACK", & NB_BLOCK_U,size(BLR_U) CALL MUMPS_ABORT() ENDIF BEGS_BLR_U(1) = 1 BEGS_BLR_U(2) = NPIV+NELIM+1 DO I = 1, NB_BLOCK_U CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ISLR_INT, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & K, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & M, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & N, 1, & MPI_INTEGER, COMM, IERR ) BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M IF (ISLR_INT .eq. 1) THEN ISLR = .TRUE. ELSE ISLR = .FALSE. ENDIF CALL ALLOC_LRB( BLR_U(I), K, M, N, ISLR, & IFLAG, IERROR, KEEP8 ) IF (IFLAG.LT.0) RETURN IF (ISLR) THEN IF (K .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*K, MPI_REAL, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%R(1,1), N*K, MPI_REAL, & COMM, IERR) ENDIF ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*N, MPI_REAL, & COMM, IERR) ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_MPI_UNPACK_LR SUBROUTINE SMUMPS_MPI_UNPACK_LR_PARTIAL( & BUFR, LBUFR, LBUFR_BYTES, POSITION, & NPIV, NELIM, DIR, & BLR_U, NB_BLOCK_U, & JBEG_BLOCK, & BEGS_BLR_U, KEEP8, & COMM, IERR, IFLAG, IERROR) USE SMUMPS_LR_CORE, ONLY : LRB_TYPE, ALLOC_LRB USE SMUMPS_LR_TYPE IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR INTEGER, INTENT(IN) :: LBUFR_BYTES INTEGER, INTENT(IN) :: BUFR(LBUFR) INTEGER, INTENT(INOUT) :: POSITION INTEGER, INTENT(IN) :: NB_BLOCK_U, NELIM, NPIV, JBEG_BLOCK CHARACTER(len=1) :: DIR INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(OUT) :: IERR TYPE (LRB_TYPE), INTENT(OUT), & DIMENSION(max(NB_BLOCK_U,1)):: BLR_U INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2) :: BEGS_BLR_U INTEGER(8) :: KEEP8(150) LOGICAL :: ISLR INTEGER :: ISLR_INT, I INTEGER :: K, M, N INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IERR = 0 IF (size(BLR_U) .NE. & MAX(NB_BLOCK_U,1) ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_MPI_UNPACK", & NB_BLOCK_U,size(BLR_U) CALL MUMPS_ABORT() ENDIF BEGS_BLR_U(1) = 1 BEGS_BLR_U(2) = NPIV+NELIM+1 IF (JBEG_BLOCK.NE.1) THEN BEGS_BLR_U(2) = JBEG_BLOCK ENDIF DO I = 1, NB_BLOCK_U CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ISLR_INT, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & K, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & M, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & N, 1, & MPI_INTEGER, COMM, IERR ) BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M IF (ISLR_INT .eq. 1) THEN ISLR = .TRUE. ELSE ISLR = .FALSE. ENDIF CALL ALLOC_LRB( BLR_U(I), K, M, N, ISLR, & IFLAG, IERROR, KEEP8 ) IF (IFLAG.LT.0) RETURN IF (ISLR) THEN IF (K .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*K, MPI_REAL, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%R(1,1), N*K, MPI_REAL, & COMM, IERR) ENDIF ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*N, MPI_REAL, & COMM, IERR) ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_MPI_UNPACK_LR_PARTIAL MUMPS_5.8.1/src/zfac_diag.F0000664000175000017500000000120215042446442015243 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_GETSETDIAGRETURN() C C This file contain code to access/return the C diagonal of a factorized matrix in the future. C RETURN END SUBROUTINE ZMUMPS_GETSETDIAGRETURN MUMPS_5.8.1/src/dfac_mem_compress_cb.F0000664000175000017500000005051015042446440017452 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SIZEFREEINREC(IW,LREC,SIZE_FREE,XSIZE) IMPLICIT NONE INTEGER, intent(in) :: LREC, XSIZE INTEGER, intent(in) :: IW(LREC) INTEGER(8), intent(out):: SIZE_FREE INTEGER(8) :: SIZE_STA, SIZE_DYN INCLUDE 'mumps_headers.h' CALL MUMPS_GETI8( SIZE_STA,IW(1+XXR) ) CALL MUMPS_GETI8( SIZE_DYN,IW(1+XXD) ) IF ( SIZE_DYN .GT. 0) THEN SIZE_FREE = SIZE_STA ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG .OR. & IW(1+XXS).EQ.S_NOLCBNOCONTIG) THEN SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE+3),8) ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG38 .OR. & IW(1+XXS).EQ.S_NOLCBNOCONTIG38) THEN SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE)+ & IW(1+XSIZE + 3) - & ( IW(1+XSIZE + 4) & - IW(1+XSIZE + 3) ), 8) ELSE IF (IW(1+XXS).EQ.S_NOLNOCB) THEN SIZE_FREE = SIZE_STA ELSE SIZE_FREE=0_8 ENDIF RETURN END SUBROUTINE DMUMPS_SIZEFREEINREC SUBROUTINE DMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, IW, XSIZE, KEEP216) IMPLICIT NONE LOGICAL, INTENT(out) :: RECORD_CAN_BE_COMPRESSED INTEGER, INTENT(in) :: XSIZE, KEEP216 INTEGER, INTENT(in) :: IW(XSIZE) INCLUDE 'mumps_headers.h' INTEGER(8) :: SIZE_DYN, SIZE_STA CALL MUMPS_GETI8( SIZE_STA, IW(1+XXR)) CALL MUMPS_GETI8( SIZE_DYN, IW(1+XXD)) IF (IW(1+XXS) .EQ. S_FREE) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE IF ( SIZE_DYN .GT. 0_8 .AND. SIZE_STA .GT. 0_8) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE IF ( IW(1+XXS) .EQ. S_NOLNOCB) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE RECORD_CAN_BE_COMPRESSED = & ( IW(1+XXS) .EQ. S_NOLCBNOCONTIG .OR. & IW(1+XXS) .EQ. S_NOLCBCONTIG .OR. & IW(1+XXS) .EQ. S_NOLCBNOCONTIG38 .OR. & IW(1+XXS) .EQ. S_NOLCBCONTIG38 ) & .AND. KEEP216.NE.3 ENDIF RETURN END SUBROUTINE DMUMPS_CAN_RECORD_BE_COMPRESSED SUBROUTINE DMUMPS_MOVETONEXTRECORD &(IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER(8) :: RCURRENT INTEGER LIW,IXXP,ICURRENT,NEXT,ISIZE2SHIFT INTEGER IW(LIW) INTEGER(8) :: RSIZE ICURRENT=NEXT CALL MUMPS_GETI8( RSIZE, IW(ICURRENT + XXR) ) RCURRENT = RCURRENT - RSIZE NEXT=IW(ICURRENT+XXP) IW(IXXP)=ICURRENT+ISIZE2SHIFT IXXP=ICURRENT+XXP RETURN END SUBROUTINE DMUMPS_MOVETONEXTRECORD SUBROUTINE DMUMPS_ISHIFT(IW,LIW,BEG2SHIFT,END2SHIFT,ISIZE2SHIFT) IMPLICIT NONE INTEGER LIW, BEG2SHIFT, END2SHIFT, ISIZE2SHIFT INTEGER IW(LIW) INTEGER I IF (ISIZE2SHIFT.GT.0) THEN DO I=END2SHIFT,BEG2SHIFT,-1 IW(I+ISIZE2SHIFT)=IW(I) ENDDO ELSE IF (ISIZE2SHIFT.LT.0) THEN DO I=BEG2SHIFT,END2SHIFT IW(I+ISIZE2SHIFT)=IW(I) ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_ISHIFT SUBROUTINE DMUMPS_RSHIFT(A, LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT) IMPLICIT NONE INTEGER(8) :: LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT DOUBLE PRECISION A(LA) INTEGER(8) :: I IF (RSIZE2SHIFT.GT.0_8) THEN DO I=END2SHIFT,BEG2SHIFT,-1_8 A(I+RSIZE2SHIFT)=A(I) ENDDO ELSE IF (RSIZE2SHIFT.LT.0_8) THEN DO I=BEG2SHIFT,END2SHIFT A(I+RSIZE2SHIFT)=A(I) ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_RSHIFT SUBROUTINE DMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY: DMUMPS_DM_PAMASTERORPTRAST IMPLICIT NONE INTEGER, INTENT(in) :: N, LIW, XSIZE INTEGER, INTENT(in) :: KEEP(500) INTEGER(8), INTENT(in) :: LA INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS INTEGER, INTENT(inout) :: IWPOSCB INTEGER :: IWPOS INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP(28)), & PIMASTER(KEEP(28)) INTEGER, INTENT(in) :: STEP(N), SLAVEF INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) DOUBLE PRECISION, INTENT(inout) :: A(LA) INTEGER, INTENT(inout) :: COMP DOUBLE PRECISION, INTENT(inout) :: ACC_TIME INTEGER, INTENT(in) :: MYID INCLUDE 'mumps_headers.h' INTEGER ICURRENT, NEXT, STATE_NEXT INTEGER(8) :: RCURRENT INTEGER ISIZE2SHIFT INTEGER(8) :: RSIZE2SHIFT INTEGER IBEGCONTIG INTEGER(8) :: RBEGCONTIG INTEGER(8) :: RBEG2SHIFT, REND2SHIFT INTEGER INODE LOGICAL :: IS_PAMASTER, IS_PTRAST INTEGER(8) :: FREE_IN_REC INTEGER(8) :: RCURRENT_SIZE, DYN_SIZE LOGICAL :: RECORD_CAN_BE_COMPRESSED INTEGER IXXP EXTERNAL MPI_WTIME DOUBLE PRECISION MPI_WTIME DOUBLE PRECISION TIME_STRT DOUBLE PRECISION TIME_COMP TIME_STRT = MPI_WTIME() ISIZE2SHIFT=0 RSIZE2SHIFT=0_8 ICURRENT = LIW-XSIZE+1 RCURRENT = LA+1_8 IBEGCONTIG = -999999 RBEGCONTIG = -999999_8 NEXT = IW(ICURRENT+XXP) IF (NEXT.EQ.TOP_OF_STACK) GOTO 120 COMP=COMP+1 STATE_NEXT = IW(NEXT+XXS) IXXP = ICURRENT+XXP 10 CONTINUE CALL DMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, & IW(NEXT), XSIZE, KEEP(216)) IF ( .NOT. RECORD_CAN_BE_COMPRESSED ) THEN CALL DMUMPS_MOVETONEXTRECORD(IW,LIW, & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) CALL MUMPS_GETI8(DYN_SIZE, IW(ICURRENT+XXD)) CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) IF (IBEGCONTIG < 0) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF IF (RBEGCONTIG < 0_8) THEN RBEGCONTIG=RCURRENT+RCURRENT_SIZE-1_8 ENDIF INODE=IW(ICURRENT+XXN) IF ( DYN_SIZE .EQ. 0_8 ) THEN IF (RSIZE2SHIFT .NE. 0_8) THEN CALL DMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, & KEEP(28), KEEP(199), & INODE, IW(ICURRENT+XXS), & IW(ICURRENT+XXD:ICURRENT+XXD+1), STEP, & DAD, PROCNODE_STEPS, RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF (IS_PTRAST) THEN PTRAST(STEP(INODE))= & PTRAST(STEP(INODE))+RSIZE2SHIFT ELSE IF (IS_PAMASTER) THEN PAMASTER(STEP(INODE))= & PAMASTER(STEP(INODE))+RSIZE2SHIFT ENDIF ENDIF ENDIF IF (ISIZE2SHIFT .NE. 0) THEN IF (PTRIST(STEP(INODE)).EQ.ICURRENT) & PTRIST(STEP(INODE))= & PTRIST(STEP(INODE))+ISIZE2SHIFT IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) & PIMASTER(STEP(INODE))= & PIMASTER(STEP(INODE))+ISIZE2SHIFT ENDIF IF (NEXT .NE. TOP_OF_STACK) THEN STATE_NEXT=IW(NEXT+XXS) GOTO 10 ENDIF ENDIF 20 CONTINUE IF (IBEGCONTIG.NE.0 .AND. ISIZE2SHIFT .NE. 0) THEN CALL DMUMPS_ISHIFT(IW,LIW,ICURRENT,IBEGCONTIG,ISIZE2SHIFT) IF (IXXP .LE.IBEGCONTIG) THEN IXXP=IXXP+ISIZE2SHIFT ENDIF ENDIF IBEGCONTIG=-9999 25 CONTINUE IF (RBEGCONTIG .GT.0_8 .AND. RSIZE2SHIFT .NE. 0_8) THEN CALL DMUMPS_RSHIFT(A,LA,RCURRENT,RBEGCONTIG,RSIZE2SHIFT) ENDIF RBEGCONTIG=-99999_8 30 CONTINUE IF (NEXT.EQ. TOP_OF_STACK) GOTO 100 CALL DMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, IW(NEXT), XSIZE, KEEP(216)) IF ( STATE_NEXT .NE. S_FREE .AND. & RECORD_CAN_BE_COMPRESSED ) THEN IF (RBEGCONTIG > 0_8) GOTO 25 CALL DMUMPS_MOVETONEXTRECORD & (IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IF (IBEGCONTIG < 0 ) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF CALL DMUMPS_SIZEFREEINREC(IW(ICURRENT), & LIW-ICURRENT+1, & FREE_IN_REC, & XSIZE) CALL MUMPS_GETI8(DYN_SIZE, IW(ICURRENT+XXD)) IF (DYN_SIZE .GT. 0_8) THEN ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG) THEN CALL DMUMPS_MAKECBCONTIG(A,LA,RCURRENT, & IW(ICURRENT+XSIZE+2), & IW(ICURRENT+XSIZE), & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), 0, & IW(ICURRENT+XXS),RSIZE2SHIFT) IW(ICURRENT+XXS) = S_NOLCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN CALL DMUMPS_MAKECBCONTIG(A,LA,RCURRENT, & IW(ICURRENT+XSIZE+2), & IW(ICURRENT+XSIZE), & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), & IW(ICURRENT+XSIZE+4)-IW(ICURRENT+XSIZE+3), & IW(ICURRENT+XXS),RSIZE2SHIFT) IW(ICURRENT+XXS) = S_NOLCLEANED38 ELSE IF (STATE_NEXT.EQ.S_NOLNOCB) THEN IW(ICURRENT+XXS) = S_NOLNOCBCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38) THEN IF (STATE_NEXT .EQ. S_NOLCBCONTIG) THEN IW(ICURRENT+XXS) = S_NOLCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG38) THEN IW(ICURRENT+XXS) = S_NOLCLEANED38 ENDIF IF (RSIZE2SHIFT .GT.0_8) THEN RBEG2SHIFT = RCURRENT + FREE_IN_REC CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) REND2SHIFT = RCURRENT + RCURRENT_SIZE - 1_8 CALL DMUMPS_RSHIFT(A, LA, & RBEG2SHIFT, REND2SHIFT, & RSIZE2SHIFT) ENDIF ELSE WRITE(*,*) "Internal error 3 in DMUMPS_COMPRE_NEW", & STATE_NEXT, DYN_SIZE, FREE_IN_REC CALL MUMPS_ABORT() ENDIF INODE = IW(ICURRENT+XXN) IF ( DYN_SIZE .GT. 0_8 ) THEN IF (PTRIST(STEP(INODE)).EQ.ICURRENT) & PTRIST(STEP(INODE))= & PTRIST(STEP(INODE))+ISIZE2SHIFT IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) & PIMASTER(STEP(INODE))= & PIMASTER(STEP(INODE))+ISIZE2SHIFT ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLNOCB ) THEN IF (ISIZE2SHIFT.NE.0) THEN PTRIST(STEP(INODE))=PTRIST(STEP(INODE))+ISIZE2SHIFT ENDIF PTRAST(STEP(INODE))=PTRAST(STEP(INODE))+RSIZE2SHIFT+ & FREE_IN_REC ELSE WRITE(*,*) "Internal error 4 in DMUMPS_COMPRE_NEW", & STATE_NEXT CALL MUMPS_ABORT() ENDIF CALL MUMPS_SUBTRI8TOARRAY(IW(ICURRENT+XXR),FREE_IN_REC) RSIZE2SHIFT=RSIZE2SHIFT+FREE_IN_REC RBEGCONTIG=-9999_8 IF (NEXT.EQ.TOP_OF_STACK) THEN GOTO 20 ELSE STATE_NEXT=IW(NEXT+XXS) ENDIF GOTO 30 ENDIF IF (IBEGCONTIG.GT.0) THEN GOTO 20 ENDIF 40 CONTINUE IF (STATE_NEXT == S_FREE) THEN ICURRENT = NEXT CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT + XXR) ) ISIZE2SHIFT = ISIZE2SHIFT + IW(ICURRENT+XXI) RSIZE2SHIFT = RSIZE2SHIFT + RCURRENT_SIZE RCURRENT = RCURRENT - RCURRENT_SIZE NEXT=IW(ICURRENT+XXP) IF (NEXT.EQ.TOP_OF_STACK) THEN WRITE(*,*) "Internal error 1 in DMUMPS_COMPRE_NEW" CALL MUMPS_ABORT() ENDIF STATE_NEXT = IW(NEXT+XXS) GOTO 40 ENDIF GOTO 10 100 CONTINUE IWPOSCB = IWPOSCB + ISIZE2SHIFT LRLU = LRLU + RSIZE2SHIFT IPTRLU = IPTRLU + RSIZE2SHIFT 120 CONTINUE TIME_COMP = MPI_WTIME() - TIME_STRT IF (KEEP(405).EQ.0) THEN ACC_TIME = ACC_TIME + TIME_COMP ELSE !$OMP ATOMIC UPDATE ACC_TIME = ACC_TIME + TIME_COMP !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE DMUMPS_COMPRE_NEW SUBROUTINE DMUMPS_GET_SIZEHOLE(IREC, IW, LIW, & ISIZEHOLE, RSIZEHOLE) IMPLICIT NONE INTEGER, intent(in) :: IREC, LIW INTEGER, intent(in) :: IW(LIW) INTEGER, intent(out):: ISIZEHOLE INTEGER(8), intent(out) :: RSIZEHOLE INTEGER IRECLOC INTEGER(8) :: RECLOC_SIZE INCLUDE 'mumps_headers.h' ISIZEHOLE=0 RSIZEHOLE=0_8 IRECLOC = IREC + IW( IREC+XXI ) 10 CONTINUE CALL MUMPS_GETI8(RECLOC_SIZE, IW(IRECLOC+XXR)) IF (IW(IRECLOC+XXS).EQ.S_FREE) THEN ISIZEHOLE=ISIZEHOLE+IW(IRECLOC+XXI) RSIZEHOLE=RSIZEHOLE+RECLOC_SIZE IRECLOC=IRECLOC+IW(IRECLOC+XXI) GOTO 10 ENDIF RETURN END SUBROUTINE DMUMPS_GET_SIZEHOLE SUBROUTINE DMUMPS_MAKECBCONTIG(A, LA, RCURRENT, & NROW, NCB, LD, NELIM, NODESTATE, ISHIFT) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER LD, NROW, NCB, NELIM, NODESTATE INTEGER(8) :: ISHIFT INTEGER(8) :: LA, RCURRENT DOUBLE PRECISION A(LA) INTEGER I,J INTEGER(8) :: IOLD,INEW LOGICAL NELIM_ROOT NELIM_ROOT=.TRUE. IF (NODESTATE.EQ. S_NOLCBNOCONTIG) THEN NELIM_ROOT=.FALSE. IF (NELIM.NE.0) THEN WRITE(*,*) "Internal error 1 IN DMUMPS_MAKECBCONTIG" CALL MUMPS_ABORT() ENDIF ELSE IF (NODESTATE .NE. S_NOLCBNOCONTIG38) THEN WRITE(*,*) "Internal error 2 in DMUMPS_MAKECBCONTIG" & ,NODESTATE CALL MUMPS_ABORT() ENDIF IF (ISHIFT .LT.0_8) THEN WRITE(*,*) "Internal error 3 in DMUMPS_MAKECBCONTIG",ISHIFT CALL MUMPS_ABORT() ENDIF IF (NELIM_ROOT) THEN IOLD=RCURRENT+int(LD,8)*int(NROW,8)+int(NELIM-1-NCB,8) ELSE IOLD = RCURRENT+int(LD,8)*int(NROW,8)-1_8 ENDIF INEW = RCURRENT+int(LD,8)*int(NROW,8)+ISHIFT-1_8 DO I = NROW, 1, -1 IF (I.EQ.NROW .AND. ISHIFT.EQ.0_8.AND. & .NOT. NELIM_ROOT) THEN IOLD=IOLD-int(LD,8) INEW=INEW-int(NCB,8) CYCLE ENDIF IF (NELIM_ROOT) THEN DO J=1,NELIM A( INEW ) = A( IOLD + int(- J + 1,8)) INEW = INEW - 1_8 ENDDO ELSE DO J=1, NCB A( INEW ) = A( IOLD + int(- J + 1, 8)) INEW = INEW - 1_8 ENDDO ENDIF IOLD = IOLD - int(LD,8) ENDDO IF (NELIM_ROOT) THEN NODESTATE=S_NOLCBCONTIG38 ELSE NODESTATE=S_NOLCBCONTIG ENDIF RETURN END SUBROUTINE DMUMPS_MAKECBCONTIG SUBROUTINE DMUMPS_GET_SIZE_NEEDED( & SIZEI_NEEDED, SIZER_NEEDED, SKIP_TOP_STACK, & KEEP, KEEP8, & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR & ) #if ! defined(NODYNAMICCB) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY: DMUMPS_DM_CBSTATIC2DYNAMIC #endif IMPLICIT NONE INTEGER, INTENT(in) :: SIZEI_NEEDED INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: KEEP(500) INTEGER(8), INTENT(inout):: KEEP8(150) INTEGER, INTENT(in) :: N, LIW, XSIZE INTEGER(8), INTENT(in) :: LA INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS INTEGER, INTENT(inout) :: IWPOSCB INTEGER, INTENT(inout) :: IWPOS INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP(28)), & PIMASTER(KEEP(28)) INTEGER, INTENT(in) :: STEP(N), SLAVEF INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) DOUBLE PRECISION, INTENT(inout) :: A(LA) INTEGER, INTENT(inout) :: COMP DOUBLE PRECISION, INTENT(inout) :: ACC_TIME INTEGER, INTENT(iN) :: MYID INTEGER, INTENT(inout) :: IFLAG, IERROR LOGICAL DMUMPS_COMPRE_NEW_CALLED DMUMPS_COMPRE_NEW_CALLED = .FALSE. IF (IWPOSCB-IWPOS+1 .LT. SIZEI_NEEDED) THEN CALL DMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 1 in DMUMPS_GET_SIZE_NEEDED ', & 'PB compress... DMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF DMUMPS_COMPRE_NEW_CALLED = .TRUE. IF (IWPOSCB-IWPOS+1 .LT. SIZEI_NEEDED) THEN IFLAG = -8 IERROR = SIZEI_NEEDED GOTO 500 ENDIF ENDIF IF ( .NOT.DMUMPS_COMPRE_NEW_CALLED.AND. & (LRLU.LT.SIZER_NEEDED).AND. & (LRLUS.GE.SIZER_NEEDED).AND. & (LRLU.NE.LRLUS) & ) THEN CALL DMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) DMUMPS_COMPRE_NEW_CALLED = .TRUE. IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 2 ', & 'in DMUMPS_GET_SIZE_NEEDED ', & 'PB compress... DMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF IF (LRLUS.LT.SIZER_NEEDED) THEN #if ! defined(NODYNAMICCB) IF (.NOT. DMUMPS_COMPRE_NEW_CALLED) THEN CALL DMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 2 ', & 'in DMUMPS_GET_SIZE_NEEDED ', & 'PB compress... DMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF CALL DMUMPS_DM_CBSTATIC2DYNAMIC(KEEP(141), & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 500 IF (LRLU.LT.SIZER_NEEDED) THEN CALL DMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 4 ', & 'in DMUMPS_GET_SIZE_NEEDED ', & 'PB compress... DMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF #else IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) GOTO 500 #endif ENDIF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_GET_SIZE_NEEDED MUMPS_5.8.1/src/zfac_mem_stack_aux.F0000664000175000017500000002312415042446441017165 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_COMPACT_FACTORS_SYM(A, LDA, NPIV, NBROW, KEEP, & SIZEA, IW ) IMPLICIT NONE INTEGER, INTENT(IN) :: LDA, NPIV, NBROW INTEGER(8), INTENT(IN) :: SIZEA INTEGER, INTENT(IN) :: IW( NPIV ) INTEGER :: KEEP(500) COMPLEX(kind=8) :: A(SIZEA) INTEGER(8) :: IOLD, INEW, J8 INTEGER I , ILAST INTEGER NBROW_L_RECTANGLE_TO_MOVE INTEGER :: ICOL_BEG, ICOL_END, NBPANELS, NB_TARGET INTEGER :: NBCOLS_PANEL, NBROWS_PANEL INTEGER(8) :: SIZE_COPY LOGICAL :: OMP_FLAG IF ( NPIV .EQ. 0 ) GOTO 500 NB_TARGET = NPIV IF ( KEEP(459) .GT. 1 ) THEN CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, NB_TARGET, KEEP ) ENDIF IF ( NB_TARGET .EQ. NPIV ) THEN IF (LDA.EQ.NPIV) GOTO 500 IOLD = int(LDA + 1,8) INEW = int(NPIV + 1,8) IF (IOLD .EQ. INEW ) THEN WRITE(*,*) " Internal error in ZMUMPS_COMPACT_FACTORS", & IOLD, INEW, NPIV CALL MUMPS_ABORT() ENDIF 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 ELSE ICOL_BEG = 1 NBPANELS = 0 INEW = 1_8 NBROWS_PANEL = NPIV DO WHILE ( ICOL_BEG .LE. NPIV ) NBPANELS=NBPANELS + 1 ICOL_END = min(NB_TARGET * NBPANELS, NPIV) IF ( IW( ICOL_END ) < 0 ) THEN ICOL_END = ICOL_END + 1 ENDIF NBCOLS_PANEL = ICOL_END - ICOL_BEG + 1 IOLD = int(ICOL_BEG-1,8) * int(LDA,8) + int(ICOL_BEG,8) DO I =1, NBROWS_PANEL IF (IOLD .NE. INEW) THEN DO J8=0, min(I+1, NBCOLS_PANEL)-1 A(INEW+J8) = A(IOLD+J8) ENDDO ENDIF INEW = INEW + int(NBCOLS_PANEL,8) IOLD = IOLD + int(LDA,8) ENDDO NBROWS_PANEL = NBROWS_PANEL - NBCOLS_PANEL ICOL_BEG = ICOL_END + 1 ENDDO IOLD = 1_8 + int(LDA,8)*int(NPIV,8) ENDIF NBROW_L_RECTANGLE_TO_MOVE = NBROW SIZE_COPY = int(NBROW_L_RECTANGLE_TO_MOVE,8) * int(NPIV,8) OMP_FLAG = SIZE_COPY .GT. int(KEEP(361),8) .AND. KEEP(405).EQ.0 IF (OMP_FLAG &) THEN !$OMP PARALLEL DO COLLAPSE(2) DO I = 0, NBROW_L_RECTANGLE_TO_MOVE-1 DO J8 = 0_8, int(NPIV - 1,8) A( INEW + J8 + int(I,8)*int(NPIV,8) ) = & A( IOLD + J8 + int(I,8)*int(LDA,8)) END DO ENDDO !$OMP END PARALLEL DO ELSE DO I = 0, NBROW_L_RECTANGLE_TO_MOVE-1 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 ENDIF 500 RETURN END SUBROUTINE ZMUMPS_COMPACT_FACTORS_SYM SUBROUTINE ZMUMPS_COMPACT_FACTORS_UNSYM(A, LDA, NPIV, NCONTIG, & KEEP, SIZEA ) IMPLICIT NONE INTEGER, INTENT(IN) :: NCONTIG, NPIV, LDA INTEGER(8), INTENT(IN) :: SIZEA COMPLEX(kind=8), INTENT(INOUT) :: A(SIZEA) INTEGER, INTENT(IN) :: KEEP(500) INTEGER I INTEGER(8) :: IDEST, ISRC INTEGER(8) :: J8 INTEGER :: NBLK2COPY INTEGER(8) :: IBLK, NBLK IF (int(NCONTIG,8) * int(NPIV,8) .LE. int(KEEP(361),8) & ) THEN IDEST = int(NPIV+1,8) ISRC = int(LDA+1,8) DO I = 2, NCONTIG DO J8 = 0_8, int(NPIV-1,8) A(IDEST+J8)=A(ISRC+J8) ENDDO ISRC = ISRC + int(LDA,8) IDEST = IDEST + int(NPIV,8) ENDDO ELSE NBLK2COPY = NCONTIG-1 IDEST = int(NPIV+1,8) ISRC = int(LDA+1,8) DO WHILE ( NBLK2COPY .GT. 0 .AND. & ISRC - IDEST .LT. int(max(KEEP(361),NPIV),8) ) DO J8 = 0, int(NPIV-1,8) A(IDEST+J8) = A(ISRC+J8) ENDDO ISRC = ISRC + int(LDA,8) IDEST = IDEST + int(NPIV,8) NBLK2COPY = NBLK2COPY - 1 END DO DO WHILE ( NBLK2COPY .GT. 0 ) NBLK = min( (ISRC - IDEST) / int(NPIV,8), int(NBLK2COPY,8) ) !$OMP PARALLEL DO COLLAPSE(2) DO IBLK = 0_8, NBLK - 1_8 DO J8 = 0_8, int(NPIV-1,8) A( IDEST + J8 + IBLK * int(NPIV,8) ) = & A( ISRC + J8 + IBLK * int(LDA,8) ) ENDDO ENDDO !$OMP END PARALLEL DO NBLK2COPY = NBLK2COPY - int(NBLK) ISRC = ISRC + NBLK * int(LDA,8) IDEST = IDEST + NBLK * int(NPIV,8) ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_COMPACT_FACTORS_UNSYM SUBROUTINE ZMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, POSELT, & IPTRLU, NPIV, & NBCOL_STACK, NBROW_STACK, & NBROW_SEND, SIZECB, KEEP, PACKED_CB, & LAST_ALLOWED, NBROW_ALREADY_STACKED ) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: PACKED_CB COMPLEX(kind=8) A(LA) INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND INTEGER, intent(inout) :: NBROW_ALREADY_STACKED INTEGER(8), intent(in) :: LAST_ALLOWED INTEGER(8) :: APOS, NPOS INTEGER NBROW INTEGER(8) :: J INTEGER I, KEEP(500) #if defined(ZERO_TRIANGLE) COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) #endif NBROW = NBROW_STACK + NBROW_SEND IF (NBROW_STACK .NE. 0 ) THEN NPOS = IPTRLU + SIZECB APOS = POSELT + int(NPIV+NBROW,8) & * int(LDA,8) - 1_8 IF ( KEEP(50) .EQ. 0 .OR. .NOT. PACKED_CB ) THEN APOS = APOS - int(LDA,8) * int(NBROW_ALREADY_STACKED,8) NPOS = NPOS & - int(NBCOL_STACK,8) * int(NBROW_ALREADY_STACKED,8) ELSE APOS = APOS - int(LDA - 1,8) * int(NBROW_ALREADY_STACKED,8) NPOS = NPOS - ( int(NBROW_ALREADY_STACKED,8) * & int(NBROW_ALREADY_STACKED+1,8) ) / 2_8 ENDIF DO I = NBROW - NBROW_ALREADY_STACKED, NBROW_SEND+1, -1 IF (KEEP(50).EQ.0) THEN IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. & LAST_ALLOWED ) THEN EXIT ENDIF DO J= 1_8,int(NBCOL_STACK,8) A(NPOS-J+1_8) = A(APOS-J+1_8) ENDDO NPOS = NPOS - int(NBCOL_STACK,8) ELSE IF (.NOT. PACKED_CB) THEN IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. & LAST_ALLOWED ) THEN EXIT ENDIF #if defined(ZERO_TRIANGLE) DO J = 1_8, int(NBCOL_STACK - I,8) A(NPOS - J + 1_8) = ZERO END DO #endif NPOS = NPOS + int(- NBCOL_STACK + I,8) ENDIF IF ( NPOS - int(I,8) + 1_8 .LT. LAST_ALLOWED ) THEN EXIT ENDIF DO J =1_8, int(I,8) A(NPOS-J+1_8) = A(APOS-J+1_8) ENDDO NPOS = NPOS - int(I,8) ENDIF IF (KEEP(50).EQ.0) THEN APOS = APOS - int(LDA,8) ELSE APOS = APOS - int(LDA + 1,8) ENDIF NBROW_ALREADY_STACKED = NBROW_ALREADY_STACKED + 1 ENDDO END IF RETURN END SUBROUTINE ZMUMPS_COPY_CB_RIGHT_TO_LEFT SUBROUTINE ZMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, POSELT, & IPTRLU, NPIV, & NBCOL_STACK, NBROW_STACK, & NBROW_SEND, SIZECB, KEEP, PACKED_CB) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: PACKED_CB COMPLEX(kind=8) A(LA) INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND INTEGER(8) :: APOS, NPOS, APOS_ini, NPOS_ini INTEGER I, KEEP(500) INTEGER(8) :: J, LDA8 #if defined(ZERO_TRIANGLE) COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) #endif LDA8 = int(LDA,8) NPOS_ini = IPTRLU + 1_8 APOS_ini = POSELT + int(NPIV+NBROW_SEND,8)* LDA8 + int(NPIV,8) !$OMP PARALLEL DO PRIVATE(J, NPOS, APOS) IF (NBROW_STACK > KEEP(360)) DO I = 1, NBROW_STACK IF (PACKED_CB) THEN NPOS = NPOS_ini + int(I-1,8) * int(I,8)/2_8 + & int(I-1,8) * int(NBROW_SEND,8) ELSE NPOS = NPOS_ini + int(I-1,8) * int(NBCOL_STACK,8) ENDIF APOS = APOS_ini + int(I-1,8) * LDA8 IF (KEEP(50).EQ.0) THEN DO J = 1_8, int(NBCOL_STACK,8) A(NPOS+J-1_8) = A(APOS+J-1_8) ENDDO ELSE DO J = 1_8, int(I + NBROW_SEND,8) A(NPOS+J-1_8)=A(APOS+J-1_8) ENDDO #if defined(ZERO_TRIANGLE) IF (.NOT. PACKED_CB) THEN A(NPOS+int(I+NBROW_SEND,8): & NPOS+int(NBCOL_STACK-1,8))=ZERO ENDIF #endif ENDIF ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE ZMUMPS_COPY_CB_LEFT_TO_RIGHT MUMPS_5.8.1/src/sfac_determinant.F0000664000175000017500000001736415042446437016666 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_UPDATEDETER(PIV, DETER, NEXP) IMPLICIT NONE REAL, intent(in) :: PIV REAL, intent(inout) :: DETER INTEGER, intent(inout) :: NEXP DETER=DETER*fraction(PIV) NEXP=NEXP+exponent(PIV)+exponent(DETER) DETER=fraction(DETER) RETURN END SUBROUTINE SMUMPS_UPDATEDETER SUBROUTINE SMUMPS_UPDATEDETER_SCALING(PIV, DETER, NEXP) IMPLICIT NONE REAL, intent(in) :: PIV REAL, intent(inout) :: DETER INTEGER, intent(inout) :: NEXP DETER=DETER*fraction(PIV) NEXP=NEXP+exponent(PIV)+exponent(DETER) DETER=fraction(DETER) RETURN END SUBROUTINE SMUMPS_UPDATEDETER_SCALING SUBROUTINE SMUMPS_GETDETER2D(BLOCK_SIZE,IPIV, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, & DETER,NEXP,SYM) IMPLICIT NONE INTEGER, intent (in) :: SYM INTEGER, intent (inout) :: NEXP REAL, intent (inout) :: DETER INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, & LOCAL_M, LOCAL_N, N INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) REAL, intent(in) :: A(*) INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, & ROW_PROC,COL_PROC, K DI = LOCAL_M + 1 NBLOCK = ( N - 1 ) / BLOCK_SIZE DO IBLOCK = 0, NBLOCK ROW_PROC = mod( IBLOCK, NPROW ) IF ( MYROW.EQ.ROW_PROC ) THEN COL_PROC = mod( IBLOCK, NPCOL ) IF ( MYCOL.EQ.COL_PROC ) THEN ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE I = ILOC + JLOC * LOCAL_M + 1 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M & + 1 K=1 DO WHILE ( I .LT. IMX ) CALL SMUMPS_UPDATEDETER(A(I),DETER,NEXP) IF (SYM.EQ.1) THEN CALL SMUMPS_UPDATEDETER(A(I),DETER,NEXP) ENDIF IF (SYM.NE.1) THEN IF (IPIV(ILOC+K) .NE. IBLOCK*BLOCK_SIZE+K) THEN DETER = -DETER ENDIF ENDIF K = K + 1 I = I + DI END DO END IF END IF END DO RETURN END SUBROUTINE SMUMPS_GETDETER2D SUBROUTINE SMUMPS_DETER_REDUCTION( & COMM, DETER_IN, NEXP_IN, & DETER_OUT, NEXP_OUT, NPROCS) IMPLICIT NONE INTEGER, intent(in) :: COMM, NPROCS REAL, intent(in) :: DETER_IN INTEGER,intent(in) :: NEXP_IN REAL,intent(out):: DETER_OUT INTEGER,intent(out):: NEXP_OUT INTEGER :: IERR_MPI EXTERNAL SMUMPS_DETERREDUCE_FUNC INTEGER TWO_SCALARS_TYPE, DETERREDUCE_OP REAL :: INV(2) REAL :: OUTV(2) INCLUDE 'mpif.h' IF (NPROCS .EQ. 1) THEN DETER_OUT = DETER_IN NEXP_OUT = NEXP_IN RETURN ENDIF CALL MPI_TYPE_CONTIGUOUS(2, MPI_REAL, & TWO_SCALARS_TYPE, & IERR_MPI) CALL MPI_TYPE_COMMIT(TWO_SCALARS_TYPE, IERR_MPI) CALL MPI_OP_CREATE(SMUMPS_DETERREDUCE_FUNC, & .TRUE., & DETERREDUCE_OP, & IERR_MPI) INV(1)=DETER_IN INV(2)=real(NEXP_IN) CALL MPI_ALLREDUCE( INV, OUTV, 1, TWO_SCALARS_TYPE, & DETERREDUCE_OP, COMM, IERR_MPI) CALL MPI_OP_FREE(DETERREDUCE_OP, IERR_MPI) CALL MPI_TYPE_FREE(TWO_SCALARS_TYPE, IERR_MPI) DETER_OUT = OUTV(1) NEXP_OUT = int(OUTV(2)) RETURN END SUBROUTINE SMUMPS_DETER_REDUCTION SUBROUTINE SMUMPS_DETERREDUCE_FUNC(INV, INOUTV, NEL, DATATYPE) IMPLICIT NONE #if defined(WORKAROUNDINTELILP64MPI2INTEGER) || defined(WORKAROUNDILP64MPICUSTOMREDUCE) INTEGER(4), INTENT(IN) :: NEL, DATATYPE #else INTEGER, INTENT(IN) :: NEL, DATATYPE #endif REAL, INTENT(IN) :: INV ( 2 * NEL ) REAL, INTENT(INOUT) :: INOUTV ( 2 * NEL ) INTEGER I, TMPEXPIN, TMPEXPINOUT DO I = 1, NEL TMPEXPIN = int(INV (I*2)) TMPEXPINOUT = int(INOUTV(I*2)) CALL SMUMPS_UPDATEDETER(INV(I*2-1), & INOUTV(I*2-1), & TMPEXPINOUT) TMPEXPINOUT = TMPEXPINOUT + TMPEXPIN INOUTV(I*2) = real(TMPEXPINOUT) ENDDO RETURN END SUBROUTINE SMUMPS_DETERREDUCE_FUNC SUBROUTINE SMUMPS_DETER_SQUARE(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP REAL, intent (inout) :: DETER DETER=DETER*DETER NEXP=NEXP+NEXP RETURN END SUBROUTINE SMUMPS_DETER_SQUARE SUBROUTINE SMUMPS_DETER_SCALING_INVERSE(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP REAL, intent (inout) :: DETER DETER=1.0E0/DETER NEXP=-NEXP RETURN END SUBROUTINE SMUMPS_DETER_SCALING_INVERSE SUBROUTINE SMUMPS_DETER_SIGN_PERM(DETER, N, PERM) IMPLICIT NONE REAL, intent(inout) :: DETER INTEGER, intent(in) :: N INTEGER, intent(inout) :: PERM(N) INTEGER I, J, K K = 0 DO I = 1, N IF (PERM(I) .LT. 0) THEN PERM(I)=-PERM(I) ELSE J = PERM(I) DO WHILE (J.NE.I) PERM(J)=-PERM(J) K = K + 1 J = -PERM(J) ENDDO ENDIF ENDDO IF (mod(K,2).EQ.1) THEN DETER = -DETER ENDIF RETURN END SUBROUTINE SMUMPS_DETER_SIGN_PERM SUBROUTINE SMUMPS_PAR_ROOT_MINMAX_PIV_UPD ( & BLOCK_SIZE,IPIV, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, & DKEEP, KEEP, SYM) USE SMUMPS_FAC_FRONT_AUX_M, & ONLY : SMUMPS_UPDATE_MINMAX_PIVOT IMPLICIT NONE INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, & LOCAL_M, LOCAL_N, N, SYM INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) REAL, intent(in) :: A(*) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER, INTENT(IN) :: KEEP(500) INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, & ROW_PROC,COL_PROC, K REAL :: ABSPIVOT DI = LOCAL_M + 1 NBLOCK = ( N - 1 ) / BLOCK_SIZE DO IBLOCK = 0, NBLOCK ROW_PROC = mod( IBLOCK, NPROW ) IF ( MYROW.EQ.ROW_PROC ) THEN COL_PROC = mod( IBLOCK, NPCOL ) IF ( MYCOL.EQ.COL_PROC ) THEN ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE I = ILOC + JLOC * LOCAL_M + 1 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M & + 1 K=1 DO WHILE ( I .LT. IMX ) IF (SYM.NE.1) THEN ABSPIVOT = abs(A(I)) ELSE ABSPIVOT = abs(A(I)*A(I)) ENDIF CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( ABSPIVOT, & DKEEP, KEEP, .FALSE.) K = K + 1 I = I + DI END DO END IF END IF END DO RETURN END SUBROUTINE SMUMPS_PAR_ROOT_MINMAX_PIV_UPD MUMPS_5.8.1/src/sana_driver.F0000664000175000017500000057066715042446441015662 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C SUBROUTINE SMUMPS_ANA_DRIVER(id,idintr) USE MUMPS_STATIC_MAPPING USE SMUMPS_STRUC_DEF USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_INTR_STRUC USE MUMPS_MEMORY_MOD USE SMUMPS_PARALLEL_ANALYSIS USE SMUMPS_ANA_LR USE SMUMPS_LR_CORE USE MUMPS_LR_STATS USE MUMPS_LR_COMMON USE SMUMPS_ANA_AUX_M USE MUMPS_ANA_BLK_M, ONLY: COMPACT_GRAPH_T, LMATRIX_T IMPLICIT NONE INTERFACE C Explicit interfaces when id has the TARGET attribute SUBROUTINE SMUMPS_ANA_ARROWHEADS_WRAPPER & (id, GATHER_MATRIX_ALLOCATED) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET :: id LOGICAL, INTENT(INOUT) :: GATHER_MATRIX_ALLOCATED END SUBROUTINE SMUMPS_ANA_ARROWHEADS_WRAPPER SUBROUTINE SMUMPS_ANA_COMPUTE_ESTIMATES (id, idintr) USE SMUMPS_STRUC_DEF USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_INTR_STRUC TYPE (SMUMPS_STRUC), TARGET :: id TYPE (SMUMPS_INTR_STRUC) :: idintr END SUBROUTINE SMUMPS_ANA_COMPUTE_ESTIMATES END INTERFACE C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) C C Purpose C ======= C C Performs analysis and (if required) Max-trans on the master, then C broadcasts information to the slaves. Also includes mapping. C C C Parameters C ========== C TYPE(SMUMPS_STRUC), TARGET :: id TYPE(SMUMPS_INTR_STRUC) :: idintr C C Local variables C =============== C C C Pointers inside integer array IKEEPALLOC, various data INTEGER(8) IKEEP, NE, NA INTEGER I, allocok C Other locals INTEGER NB_NIV2, IDEST INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MP, LP, MPG LOGICAL PROK, PROKG, LISTVAR_SCHUR_2BE_FREED, LPOK INTEGER SIZE_SCHUR_PASSED INTEGER LEAF, INODE, ISTEP, INN, LPTRAR INTEGER NBLEAF, NBROOT, MYROW_CHECK, INIV2 DOUBLE PRECISION TIMEG REAL :: PEAK C C Related to commuicators for parallel analysis: C COMM_PARAORD: communicator on which Parmetis/PTscotch C is performed C COMM_PARASYMB: communicator on which parallel symbolic C facto is performed C PARAORD_to_idCOMM (1:NPROCS_PARAORD) is such that C PARAORD_to_idCOMM(idPARAORD+1)=idCOMM, C where idPARAORD \in [0:NPROCS_PARAORD] C RKinSYMB_PROC0ORD: Rank in COMM_PARASYMB of proc 0 in C COMM_PARAORD C RKinidCOMM_PROC0SYMB: Rank in id%COMM of proc 0 in C COMM_PARASYMB C INTEGER :: COMM_PARAORD, NPROCS_PARAORD, RKinSYMB_PROC0ORD, & OPTION_COMM_PARAORD INTEGER :: COMM_PARASYMB, NPROCS_PARASYMB, & RKinidCOMM_PROC0SYMB LOGICAL :: COMM_PARAORD_ALLOCATED, COMM_PARASYMB_ALLOCATED INTEGER, ALLOCATABLE, DIMENSION(:) :: PARAORD_to_idCOMM #if defined(AVOID_MPI_IN_PLACE) INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP #endif C C INTEGER WORKSPACE C INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: PAR2_NODES INTEGER, DIMENSION(:), POINTER :: PAR2_NODESPTR INTEGER, ALLOCATABLE, DIMENSION(:) :: PROCNODE INTEGER, DIMENSION(:), ALLOCATABLE :: IWtemp INTEGER, DIMENSION(:), ALLOCATABLE :: XNODEL, NODEL INTEGER, DIMENSION(:), POINTER :: SSARBR C Element matrix entry INTEGER, POINTER :: NELT, LELTVAR INTEGER, DIMENSION(:), POINTER :: KEEP, INFO, INFOG INTEGER(8), DIMENSION(:), POINTER :: KEEP8 REAL, DIMENSION(:), POINTER :: RINFO REAL, DIMENSION(:), POINTER :: RINFOG INTEGER, DIMENSION(:), POINTER :: ICNTL LOGICAL :: I_AM_SLAVE, COND INTEGER, TARGET :: IDUMMY_ARRAY(1) INTEGER(8) :: NNZ_loc, NNZ_TMP INTEGER, POINTER, DIMENSION(:) :: IRN_loc_PTR INTEGER, POINTER, DIMENSION(:) :: JCN_loc_PTR INTEGER, POINTER, DIMENSION(:) :: IRN_PTR INTEGER, POINTER, DIMENSION(:) :: JCN_PTR INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR INTEGER, POINTER, DIMENSION(:) :: UNS_PERM_PTR !$ INTEGER :: NOMPMAX INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER, EXTERNAL :: MUMPS_ENCODE_TPN_IPROC INTEGER :: PROCNODE_VALUE INTEGER K,J, IFS INTEGER SIZE_TEMP_MEM,SIZE_DEPTH_FIRST,SIZE_COST_TRAV LOGICAL IS_BUILD_LOAD_MEM_CALLED LOGICAL PRINT_MAXAVG LOGICAL :: PRINT_NODEINFO 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 :: SIZE_PAR2_NODESPTR INTEGER :: LSIZEOFBLOCKS_PTR LOGICAL :: READY_FOR_ANA_F INTEGER, ALLOCATABLE, DIMENSION(:) :: MAPCOL LOGICAL :: BLKPTR_ALLOCATED, BLKVAR_ALLOCATED INTEGER, POINTER, DIMENSION(:) :: BLKPTR_PTRLOC, BLKVAR_PTRLOC INTEGER :: IB, BLKSIZE INTEGER :: IBcurrent, IPOS, IPOSB, II C Internal work arrays: C DOF2BLOCK(idof)=inode, idof in [1,N], inode in [1,NBLK] C SIZEBLOCK(1:NBLK) (for node valuation) INTEGER, TARGET, DIMENSION(:), allocatable:: SIZEOFBLOCKS INTEGER, DIMENSION(:), allocatable:: DOF2BLOCK INTEGER :: NBRECORDS INTEGER(8) :: NSEND8, NLOCAL8, IDUMMY8 C LMAT_BLOCK: in case of centralized matrix, C to store on MASTER the cleaned Lmatrix C used to compute GCOMP C LMAT_BLOCK might also be saved to C be used during grouping C LUMAT : in case of distributed matrix C to store distributed the cleaned LU matrix C LUMAT might also be saved to C be used for MPI based grouping C LUMAT_REMAP : in case of distributed matrix C it is used to remap LUMAT C C GCOMP : Graph "ready" to be called by orderings C INTEGER(8) :: MEMCNT TYPE(LMATRIX_T) :: LMAT_BLOCK, LUMAT, LUMAT_REMAP INTEGER :: LMAT_BLOCK_AVAIL_I LOGICAL :: GCOMP_PROVIDED, & LUMAT_AVAIL, LMAT_BLOCK_AVAIL LOGICAL :: LUMAT_REMAP_DIST_AVAIL, & LUMAT_REMAP_CENT_AVAIL TYPE(COMPACT_GRAPH_T) :: GCOMP TYPE(COMPACT_GRAPH_T) :: GCOMP_DIST INTEGER(4) :: I4 INTEGER, POINTER, DIMENSION(:) :: & NFSIZPTR, & FREREPTR, & IKEEP1, IKEEP2, IKEEP3 #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: FILS_TMPPTR #endif INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: FILS_TMP INTEGER, ALLOCATABLE, DIMENSION(:) :: STEP_TMP, & LRGROUPS_TMP INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: IKEEPALLOC INTEGER, ALLOCATABLE, DIMENSION(:) :: WORK2ALLOC INTEGER :: SIZELRGROUPS_TMP INTEGER(8) :: SIZEIKEEPALLOC, SIZEWORK2ALLOC INTEGER(kind=8) :: NZ8, LIW8 C NBLK : id%N or order of blocked matrix INTEGER :: NBLK, idNBLKSAVE INTEGER(8) :: LIW8_ELT C GATHER_MATRIX_ALLOCATED: C To be sure that id%IRN and id%JCN are C deallocated only when SMUMPS_GATHER_MATRIX was called LOGICAL :: GATHER_MATRIX_ALLOCATED C C Beginning of executable statements C C SMUMPS_FREE_DATA_ANAFACSOL was called in SMUMPS_DRIVER C to reduce the memory peak during analysis, especially C when computing the graph associated to the input matrix. IS_BUILD_LOAD_MEM_CALLED=.FALSE. KEEP => id%KEEP KEEP8 => id%KEEP8 INFO => id%INFO RINFO => id%RINFO INFOG => id%INFOG RINFOG => id%RINFOG ICNTL => id%ICNTL NELT => id%NELT LELTVAR => id%LELTVAR KEEP(264) = 0 ! reinitialise out-of-range status (0=yes) KEEP(265) = 0 ! reinitialise dupplicates (0=yes) KEEP(280) = 0 ! size of id%LRGROUPS PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) C FIXME: count memory used during analysis MEMCNT = 0_8 C Print per node information only in case there are several C compute nodes (id%KEEP(412): #MPI procs on compute node) PRINT_NODEINFO = PRINT_MAXAVG .AND. id%NPROCS .NE. id%KEEP(412) GATHER_MATRIX_ALLOCATED = .FALSE. COMM_PARAORD = MPI_COMM_NULL COMM_PARASYMB = id%COMM COMM_PARAORD_ALLOCATED = .FALSE. COMM_PARASYMB_ALLOCATED = .FALSE. RKinidCOMM_PROC0SYMB = MASTER NULLIFY ( NFSIZPTR, FREREPTR, & IKEEP1, IKEEP2, IKEEP3, & SSARBR, SIZEOFBLOCKS_PTR, IRN_loc_PTR, JCN_loc_PTR, & IRN_PTR, JCN_PTR, & PAR2_NODESPTR, BLKPTR_PTRLOC, BLKVAR_PTRLOC) IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM) nullify(id%UNS_PERM) C Set default value that witl be reset in C case of blocked format matrices NBLK = id%N GCOMP_PROVIDED = .FALSE. BLKPTR_ALLOCATED = .FALSE. BLKVAR_ALLOCATED = .FALSE. LUMAT_AVAIL = .FALSE. LMAT_BLOCK_AVAIL = .FALSE. C ------------------------------------- C Depending on the type of parallelism, C the master can now (soon) potentially C have the role of a slave C ------------------------------------- I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(ICNTL(4).GE.2)) IF ( PROK ) THEN IF ( KEEP(50) .eq. 0 ) THEN WRITE(MP, '(A)') 'L U Solver for unsymmetric matrices' ELSE IF ( KEEP(50) .eq. 1 ) THEN WRITE(MP, '(A)') & 'L D L^T Solver for symmetric positive definite matrices' ELSE WRITE(MP, '(A)') & 'L D L^T Solver for general symmetric matrices' END IF IF ( KEEP(46) .eq. 1 ) THEN WRITE(MP, '(A)') 'Type of parallelism: Working host' ELSE WRITE(MP, '(A)') 'Type of parallelism: Host not working' END IF END IF IF ( PROKG .AND. (MP.NE.MPG)) THEN IF ( KEEP(50) .eq. 0 ) THEN WRITE(MPG, '(A)') 'L U Solver for unsymmetric matrices' ELSE IF ( KEEP(50) .eq. 1 ) THEN WRITE(MPG, '(A)') & 'L D L^T Solver for symmetric positive definite matrices' ELSE WRITE(MPG, '(A)') & 'L D L^T Solver for general symmetric matrices' END IF IF ( KEEP(46) .eq. 1 ) THEN WRITE(MPG, '(A)') 'Type of parallelism: Working host' ELSE WRITE(MPG, '(A)') 'Type of parallelism: Host not working' END IF END IF IF (PROK) WRITE( MP, 110 ) IF (PROKG .AND. (MPG.NE.MP)) WRITE( MPG, 110 ) C Reinitialize last used size of WK_USER C --------------------------------------- KEEP8(24) = 0_8 C C C C Decode API (ICNTL parameters, mainly) C and check consistency of the KEEP array. C Note: SMUMPS_ANA_CHECK_KEEP also sets C some INFOG parameters CALL SMUMPS_ANA_CHECK_KEEP(id, I_AM_SLAVE) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C ------------------------------------------- C Broadcast KEEP(60) since we need to broadcast C related information C ------------------------------------------ CALL MPI_BCAST( KEEP(60), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C broadcast also size of schur IF (id%KEEP(60) .NE. 0 ) THEN CALL MPI_BCAST( KEEP(116), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF IF (id%KEEP(60) .EQ. 2 .or. id%KEEP(60). EQ. 3) THEN CALL MPI_BCAST( id%NPROW, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NPCOL, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%MBLOCK, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NBLOCK, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) C Note that SMUMPS_INIT_ROOT_ANA will C then use that information. ENDIF C ---------------------------------------------- C Broadcast KEEP(54) now to know if the C structure of the graph is intially distributed C and should be assembled on the master C Broadcast KEEP(55) now to know if the C matrix is in assembled or elemental format C ---------------------------------------------- CALL MPI_BCAST( KEEP(54), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast KEEP(69) now to know if C we will need to communicate during analysis C ---------------------------------------------- CALL MPI_BCAST( KEEP(69), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast Out of core strategy (used only on master so far) C Boradcast KEEP(201), KEEP(202) and KEEP(203) C ---------------------------------------------- CALL MPI_BCAST( KEEP(201), 3, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast analysis strategy (used only on master so far) C ---------------------------------------------- CALL MPI_BCAST( KEEP(244), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) IF (KEEP(244).NE.1) THEN C broadcast parallel ordering strategy used CALL MPI_BCAST( KEEP(245), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF C --------------------------- C Fwd in facto C Broadcast KEEP(251,252,253) defined on master so far CALL MPI_BCAST( KEEP(251), 3, MPI_INTEGER,MASTER,id%COMM,IERR) C CALL MPI_BCAST( KEEP(401), 1, MPI_INTEGER,MASTER,id%COMM,IERR) id%KEEP(400) = 0 id%KEEP(369) = id%KEEP(368) !$ IF (id%KEEP(401).GT.0) THEN !$ id%KEEP(400) = omp_get_max_threads() C => id%KEEP(400)>=1 C C IF KEEP(400)<=1 on all procs switch off L0 thread: !$ CALL MPI_ALLREDUCE(id%KEEP(400),NOMPMAX,1,MPI_INTEGER, !$ & MPI_MAX,id%COMM,IERR) !$ IF (NOMPMAX.LE.1) THEN !$ id%KEEP(400) = 0 !$ id%KEEP(401) = 0 !$ ENDIF !$ ENDIF !$ IF (id%KEEP(400).GT.0 .AND. id%KEEP(401).GT.0 !$ & .AND. id%KEEP(369).GT.0) THEN C reset id%KEEP(400) to value provided by user !$ id%KEEP(400) = min(id%KEEP(400),id%KEEP(369)) !$ ENDIF CALL MPI_BCAST( id%KEEP(490), 5, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( KEEP(123),1,MPI_INTEGER,MASTER,id%COMM,IERR) C ---------------------------------------------- C Broadcast N C ---------------------------------------------- CALL MPI_BCAST( id%N, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast NZ for assembled entry C ---------------------------------------------- IF ( KEEP(55) .EQ. 0) THEN IF ( KEEP(54) .eq. 3 ) THEN C Reset to 0 id%KEEP8(29) for host not working, since C value provided by user might be undefined IF (.NOT.I_AM_SLAVE) id%KEEP8(29)= 0_8 C Compute total number of non-zeros CALL MPI_ALLREDUCE( id%KEEP8(29), id%KEEP8(28), 1, & MPI_INTEGER8, & MPI_SUM, id%COMM, IERR ) C Local number of non-zeros cannot be negative IF (id%KEEP8(29) .LT. 0_8) THEN id%INFO(1) = -2 CALL MUMPS_SET_IERROR(id%KEEP8(29), id%INFO(2)) ENDIF ELSE C Broadcast NZ from the master node CALL MPI_BCAST( id%KEEP8(28), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) END IF C Total number of non zeros must be positive strictly IF (id%KEEP8(28) .LE. 0_8) THEN id%INFO(1) = -2 CALL MUMPS_SET_IERROR(id%KEEP8(28), id%INFO(2)) ENDIF ELSE C Broadcast NA_ELT <=> KEEP8(30) for elemental entry CALL MPI_BCAST( id%KEEP8(30), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) ENDIF IF( id%KEEP(54).EQ.3) THEN C test IRN_loc and JCN_loc allocated on working procs IF (I_AM_SLAVE .AND. id%KEEP8(29).GT.0 .AND. & ( (.NOT. associated(id%IRN_loc)) .OR. & (.NOT. associated(id%JCN_loc)) ) & ) THEN id%INFO(1) = -22 id%INFO(2) = 16 ENDIF ENDIF IF ( associated(id%MEM_DIST) ) THEN DEALLOCATE( id%MEM_DIST ) ENDIF allocate( id%MEM_DIST( 0:id%NSLAVES-1 ), STAT=IERR ) IF ( IERR .GT. 0 ) THEN INFO(1) = -7 INFO(2) = id%NSLAVES IF ( LPOK ) THEN WRITE(LP, 150) 'MEM_DIST' END IF END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 id%MEM_DIST(0:id%NSLAVES-1) = 0 CALL MUMPS_INIT_ARCH_PARAMETERS( & id%COMM,id%COMM_NODES,KEEP(69),KEEP(46), & id%NSLAVES,id%MEM_DIST,INFO ) C ======================== C Write problem to a file, C if requested by the user C ======================== CALL SMUMPS_DUMP_PROBLEM(id) IF ( id%INFO(1) .LT. 0 ) GOTO 500 C ================= C ANALYSIS BY BLOCK C ================= IF ( id%MYID .EQ. MASTER ) THEN IF (KEEP(13).EQ.1) THEN NBLK=id%NBLK ELSE IF (KEEP(13).LT.0) THEN C regular blocks in BLKVAR of size -KEEP(13) C mod(id%N,-KEEP(13)) has already been checked NBLK = id%N/(-KEEP(13)) ENDIF C end of id%MYID .EQ. MASTER ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 500 C C Broadcast KEEP(13-14), NBLK CALL MPI_BCAST( KEEP(13), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( NBLK, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C C =========================== IF (KEEP(13).NE.0) THEN C { BEGIN preparation ANA_BLK C =========================== IF ( & ( KEEP(244).NE.1) & .OR. ( (KEEP(54).NE.3).AND.(id%MYID.EQ.MASTER) ) & .OR. (KEEP(54).EQ.3) ) THEN C{ C ---------------------------------------- C Allocate SIZEOFBLOCKS, DOF2BLOCK C ---------------------------------------- IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) allocate(SIZEOFBLOCKS(NBLK), DOF2BLOCK(id%N), & STAT=allocok) C IF (allocok.NE.0) THEN id%INFO( 1 ) = -7 id%INFO( 2 ) = id%N+NBLK IF ( LPOK ) WRITE(LP, 150) ' SIZEOFBLOCKS, DOF2BLOCK' ENDIF C IF ( (allocok.EQ.0) .AND. (id%MYID.EQ.MASTER)) THEN C{ BLKPTR and BLKVAR needed for SMUMPS_EXPAND_TREE C allocate then if not associated IF (.NOT.associated(id%BLKPTR).OR.KEEP(13).LT.0) THEN BLKPTR_ALLOCATED = .TRUE. C allocate(id%BLKPTR(NBLK+1), STAT=allocok) allocate(BLKPTR_PTRLOC(NBLK+1), STAT=allocok) IF (allocok.NE.0) THEN BLKPTR_ALLOCATED = .FALSE. id%INFO( 1 ) = -7 id%INFO( 2 ) = NBLK+1 IF ( LPOK ) WRITE(LP, 150) ' id%BLKPTR ' ENDIF ELSE BLKPTR_PTRLOC=>id%BLKPTR ENDIF IF (allocok.EQ.0) THEN IF (.NOT.associated(id%BLKVAR).OR.KEEP(13).LT.0) THEN allocate(BLKVAR_PTRLOC(id%N), STAT=allocok) BLKVAR_ALLOCATED = .TRUE. IF (allocok.NE.0) THEN BLKVAR_ALLOCATED = .FALSE. id%INFO( 1 ) = -7 id%INFO( 2 ) = id%N IF ( LPOK ) WRITE(LP, 150) ' id%BLKVAR ' ENDIF ELSE BLKVAR_PTRLOC => id%BLKVAR ENDIF ENDIF C} ENDIF C} ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 500 IF ( id%MYID .EQ. MASTER ) THEN C{ ----------------------------------------- C Compute SIZEOFBLOCKS, DOF2BLOCK on MASTER C based on id%BLKPTR and id%BLKVAR C and compute id%BLKPTR and id%BLKVAR if not C provided by user C ----------------------------------------- IF (BLKVAR_ALLOCATED) THEN C implicitly id%BLKVAR(I)=I DO I=1, id%N BLKVAR_PTRLOC(I)=I ENDDO ENDIF IF (BLKPTR_ALLOCATED) THEN IB=0 BLKSIZE=-KEEP(13) DO I=1, id%N, BLKSIZE IB=IB+1 BLKPTR_PTRLOC(IB) = I ENDDO BLKPTR_PTRLOC(NBLK+1) = id%N+1 ENDIF C CALL MUMPS_AB_COMPUTE_SIZEOFBLOCK ( & NBLK, id%N, BLKPTR_PTRLOC(1), BLKVAR_PTRLOC(1), & SIZEOFBLOCKS, DOF2BLOCK) C} ENDIF C ======================== IF (KEEP(244).NE.1) THEN C{ Parallel analysis C ======================== C KEEP(13).ne.0 only if KEEP(339).NE.0 : IF (KEEP(339).EQ.0) THEN INFO(1) = -901 INFO(2) = KEEP(13) IF ( LPOK ) WRITE(LP, 150) ' Internal error K339' ENDIF NNZ_loc = 0_8 C ----------------------------------------- C Build distributed clean LUMAT matrix C even when matrix is provided centralised C ----------------------------------------- IF (KEEP(54).EQ.3) THEN IF (.NOT. I_AM_SLAVE .OR. ! non-working master & KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc NNZ_loc = KEEP8(29) ENDIF ELSE C Matrix on host IF (id%MYID.EQ.MASTER) THEN C Store input matrix (IRN/JCN) as a cleaned blocked Lmatrix C of nodes (indices \in [1,NBLK]) IF (id%KEEP8(28) .EQ. 0_8) THEN IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ELSE IRN_loc_PTR => id%IRN JCN_loc_PTR => id%JCN NNZ_loc = id%KEEP8(28) ENDIF ELSE IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ENDIF ENDIF C build communicator for parallel ordering C used to distribute LUMAT OPTION_COMM_PARAORD = 0 CALL MUMPS_BUILD_COMM_PARA_ANA ( & OPTION_COMM_PARAORD, id%N, & id%COMM, id%MYID, id%COMM_NODES, id%MYID_NODES, & id%NPROCS, id%NSLAVES, & id%KEEP(1), & COMM_PARAORD, NPROCS_PARAORD, & COMM_PARAORD_ALLOCATED, & COMM_PARASYMB, NPROCS_PARASYMB, & COMM_PARASYMB_ALLOCATED, & id%ICNTL(1), id%INFO(1)) C allocate and initialize PARAORD_to_idCOMM if (allocated(PARAORD_to_idCOMM)) & DEALLOCATE(PARAORD_to_idCOMM) allocate(PARAORD_to_idCOMM(NPROCS_PARAORD), #if defined(AVOID_MPI_IN_PLACE) & TMP(NPROCS_PARAORD), #endif & STAT=allocok) IF (allocok.NE.0) THEN id%INFO( 1 ) = -7 id%INFO( 2 ) = NPROCS_PARAORD #if defined(AVOID_MPI_IN_PLACE) & + NPROCS_PARAORD #endif IF ( LPOK ) WRITE(LP, 150) ' PARAORD_to_idCOMM' ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 500 CALL MUMPS_BUILD_PARAORD_to_idCOMM ( & id%COMM, id%MYID, id%KEEP(1), & COMM_PARASYMB, NPROCS_PARASYMB, & COMM_PARAORD, NPROCS_PARAORD, & PARAORD_to_idCOMM, #if defined(AVOID_MPI_IN_PLACE) & TMP, #endif & RKinSYMB_PROC0ORD, & RKinidCOMM_PROC0SYMB, id%NPROCS ) #if defined(AVOID_MPI_IN_PLACE) DEALLOCATE(TMP) #endif C C C build LUMAT such that col of LUMAT are distributed C only procs in COMM_PARAORD C CALL MUMPS_AB_DCOORD_TO_DLUMAT ( & id%MYID, id%NPROCS, id%COMM, & NPROCS_PARAORD, PARAORD_to_idCOMM, & NBLK, id%N, & NNZ_loc, & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), id%KEEP8(1), & LUMAT) IF (allocated(PARAORD_to_idCOMM)) THEN DEALLOCATE(PARAORD_to_idCOMM) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 LUMAT_AVAIL = .TRUE. C SIZEOFBLOCKS needed on all procs during // analysis CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, & id%COMM, IERR ) C C} End of Parallel analysis ELSE C =================== C{ Sequential analysis C =================== C ======================= IF (KEEP(54).NE.3.OR.id%NPROCS.EQ.1) THEN C ======================= C{ Matrix structure available on host C also case of distributed input matrix format C with one mpi proc C --------------------- KEEP(14) = 0 IF (id%MYID.EQ.MASTER) THEN C Store input matrix (IRN/JCN) as a cleaned blocked Lmatrix C of nodes (indices \in [1,NBLK]) IF (KEEP(54).NE.3) THEN IF (id%KEEP8(28) .EQ. 0_8) THEN IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY ELSE IRN_PTR => id%IRN JCN_PTR => id%JCN ENDIF NNZ_TMP = id%KEEP8(28) ELSE IF (id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY id%KEEP8(29) = 0_8 ELSE IRN_PTR => id%IRN_loc JCN_PTR => id%JCN_loc ENDIF NNZ_TMP = id%KEEP8(29) ENDIF CALL MUMPS_AB_COORD_TO_LMAT ( id%MYID, & NBLK, id%N, NNZ_TMP, IRN_PTR(1), JCN_PTR(1), & DOF2BLOCK, & INFO(1), INFO(2), LP, LPOK, & LMAT_BLOCK, IDUMMY8, KEEP(1) ) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C IF (id%MYID.EQ.MASTER) THEN C From LMAT_BLOCK build GCOMP format wich requires C symmetrizing the Lmatrix CALL MUMPS_AB_LMAT_TO_CLEAN_G ( id%MYID, .TRUE., & .TRUE., ! not relevant because unfold is true & LMAT_BLOCK, GCOMP, & INFO(1), ICNTL(1), MEMCNT) GCOMP_PROVIDED = .TRUE. IF (KEEP(494).EQ.0.OR.KEEP(487).NE.1) THEN CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK, KEEP(147)) LMAT_BLOCK_AVAIL_I = 0 ELSE LMAT_BLOCK_AVAIL_I = 1 ENDIF ENDIF CALL MPI_BCAST( LMAT_BLOCK_AVAIL_I, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) LMAT_BLOCK_AVAIL = (LMAT_BLOCK_AVAIL_I.EQ.1) C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C} C ==== ELSE C ==== C ---------------------- C{ matrix is distributed C ---------------------- IF (.NOT. I_AM_SLAVE .OR. ! non-working master & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY id%KEEP8(29) = 0_8 ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc ENDIF C C Given distributed matrix IRN_loc_PTR, JCN_loc_PTR C build distributed cleaned graph GCOMP and C save distributed LUMAT in case of grouping C IF (id%NPROCS.EQ.1) THEN C Build GCOMP, the centralized final cleaned graph READY_FOR_ANA_F = .TRUE. CALL MUMPS_AB_DCOORD_TO_DCOMPG ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & LUMAT, LUMAT_AVAIL, GCOMP, READY_FOR_ANA_F) GCOMP_PROVIDED = .TRUE. ELSE READY_FOR_ANA_F = .FALSE. CALL MUMPS_AB_DCOORD_TO_DCOMPG ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & LUMAT, LUMAT_AVAIL, GCOMP_DIST, READY_FOR_ANA_F) ENDIF IF (LUMAT_AVAIL.AND.KEEP(487).NE.1) THEN CALL MUMPS_AB_FREE_LMAT(LUMAT, KEEP(147)) LUMAT_AVAIL = .FALSE. ENDIF C C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C C} end matrix structure is distributed C ===== ENDIF C ===== C} end of sequential analysis C ===== ENDIF C ===== IF (allocated(DOF2BLOCK)) THEN C DOF2BLOCK reused on master if pivot order given by user IF ( (id%MYID.NE.MASTER) .OR. & (id%MYID.EQ.MASTER).AND. (KEEP(256) .NE. 1)) THEN DEALLOCATE(DOF2BLOCK) ENDIF ENDIF C ======================== ENDIF C } END preparation ANA_BLK C ========================= C ==================================================== C TEST FOR SEQUENTIAL OR PARALLEL ANALYSIS (KEEP(244)) C ==================================================== IF ( (KEEP(244).EQ.1) .AND. (KEEP(54) .eq. 3) ) THEN C ----------------------------------------------- C Sequential analysis: C Collect on the host -- if matrix is distributed C at analysis -- all integer information needed C to perform ordering C ----------------------------------------------- C FIXME: one should test instead if GCOMP_DIST available C instead of retestinf KEEP(13) and NPROCS.NE.1 IF (KEEP(13).NE.0) THEN IF (id%NPROCS.NE.1) THEN CALL MUMPS_AB_GATHER_GRAPH( & id%ICNTL(1), KEEP(1), id%COMM, id%MYID, id%NPROCS, & id%INFO(1), & GCOMP_DIST, GCOMP) GCOMP_PROVIDED = .TRUE. C CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST, MEMCNT) ENDIF ELSE CALL SMUMPS_GATHER_MATRIX(id) GATHER_MATRIX_ALLOCATED = .TRUE. CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF 1234 CONTINUE IF (KEEP(244) .EQ. 1) THEN C Sequential analysis : Schur IF ( id%MYID .eq. MASTER ) THEN C Prepare arguments for call to SMUMPS_ANA_F and C SMUMPS_ANA_F_ELT in case id%SCHUR was not allocated C by user. The objective is to avoid passing a null C pointer. C FIXME Block fomat for Schur IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN SIZE_SCHUR_PASSED = 1 LISTVAR_SCHUR_2BE_FREED=.TRUE. allocate( id%LISTVAR_SCHUR( 1 ), STAT=allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) & 'PB allocating an array of size 1 for Schur!! ' INFO(1)=-7 INFO(2)=1 END IF ELSE SIZE_SCHUR_PASSED=id%SIZE_SCHUR LISTVAR_SCHUR_2BE_FREED = .FALSE. END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF C IF ((id%MYID.EQ.MASTER).AND.(KEEP(244) .EQ. 1) & .AND. (id%N.EQ.NBLK) & ) THEN C Sequential analysis : maximum transversal on master IF ((KEEP(50).NE.1).AND. & .NOT.((KEEP(23).EQ.7).AND.KEEP(50).EQ.0) & ) THEN C (KEEP(23).EQ.7).AND.KEEP(50).EQ.0) : C For unsymmetric matrix, if automatic setting is requested C default setting of Maximum Transversal is decided during C SMUMPS_ANA_F and is based on matrix unsymmetry. C Thus in this case we skip SMUMPS_ANA_O IF ( ( KEEP(23) .NE. 0 ) .OR. C Automatic choice for scaling does not force Maxtrans C Only when scaling is explicitly asked during analysis C (KEEP(52)=-2) SMUMPS_ANA_O is called & KEEP(52) .EQ. -2 ) THEN C C Maximum Trans. algorithm called on original matrix. C We compute a permutation of the original matrix to C have a zero free diagonal C KEEP(23)=7 means that automatic choice C of max trans value will be done during analysis C Permutation is held in UNS_PERM(1, ...,N). C Maximum transversal is not available for element C entry format C UNS_PERM that might be set to C to permutation computed during Max transversal ALLOCATE(id%UNS_PERM(id%N),IKEEPALLOC(3_8*int(id%N,8)), & WORK2ALLOC(id%N), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( 5_8 * int(id%N,8), INFO(2) ) ELSE CALL SMUMPS_ANA_O(id%N, id%KEEP8(28), KEEP(23), & id%UNS_PERM, IKEEPALLOC, 3_8*int(id%N,8), & id%IRN, id%JCN, id%A, & id%ROWSCA, id%COLSCA, & WORK2ALLOC, id%KEEP, id%ICNTL, id%INFO, id%INFOG) IF (allocated(WORK2ALLOC)) DEALLOCATE(WORK2ALLOC) IF (KEEP(23).EQ.0) THEN C Maximum tranversal did not produce a permutation IF (associated( id%UNS_PERM )) & DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF C Check if IKEEPALLOC needed for ANA_F IF (KEEP(23).EQ.0.AND.(KEEP(95).EQ.1)) THEN IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) ENDIF ENDIF IF (INFO(1) .LT. 0) THEN C Fatal error C Permutation was not computed; reset keep(23) KEEP(23) = 0 ELSE ENDIF ELSE KEEP(23) = 0 C Switch off C compressed/contrained ordering id%KEEP(95) = 1 END IF ENDIF C END OF MAX-TRANS ON THE MASTER ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C IF ( KEEP(244) .EQ. 1) THEN C Sequential analysis: allocate data for ordering on MASTER IF (id%MYID.EQ.MASTER) THEN C allocate IKEEPALLOC and TREE related pointers C IKEEPALLOC might have been allocated in SMUMPS_ANA_O C and IKEEPALLOC(1:N) might hold information to C be given to ANA_F. IF (allocated(IKEEPALLOC)) THEN ALLOCATE( FILS_TMP(NBLK), FREREPTR(NBLK), & NFSIZPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(int(NBLK,8)*3_8, INFO(2)) ENDIF ELSE ALLOCATE(IKEEPALLOC(int(NBLK,8)+2_8*int(id%N,8)), & FILS_TMP(NBLK), FREREPTR(NBLK), & NFSIZPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(int(NBLK,8)*4_8+2_8*int(id%N,8), & INFO(2)) ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF C IF (KEEP(244) .EQ. 1) THEN C Sequential analysis IF ( id%MYID .eq. MASTER ) THEN C BEGINNING OF ANALYSIS ON THE MASTER C ------------------------------------------------------ C For element entry (KEEP(55).ne.0), we do not know NZ, C and so the whole allocation of IW cannot be done at this C point and more workspace is declared/allocated/used C inside SMUMPS_ANA_F_ELT. C ------------------------------------------------------ C IF (KEEP(55) .EQ. 0) THEN C ---------------- C Assembled format C ---------------- NZ8=id%KEEP8(28) C Compute LIW8: C For local orderings a contiguous space IW C of size LIW8 must be provided. C IW must hold the graph (with double adjacency C list) and and extra space of size the number of C nodes in the graph: C ==> LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8 C In case of analysis by block and C However, when GCOMP is provided directly then C IW is not allocated C ==> LIW8 = 0 C In this case C size(LCOMP%ADJ)>= 2_8*NZ8+int(NBLK,8)+1_8 C should hold IF (KEEP(13).NE.0) THEN C Compact graph is provided on entry to SMUMPS_ANA_F NZ8=0_8 ! GCOMP is provided on entry ENDIF IF (NZ8.EQ.0_8) THEN LIW8 = 0_8 ELSE LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8 ENDIF C ELSE C ---------------- C Elemental format C ---------------- C Only available for AMD, METIS, and given ordering #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) COND = (KEEP(60) .NE. 0) .OR. (KEEP(256) .EQ. 5) #else COND = (KEEP(60) .NE. 0) #endif IF( COND ) THEN C C C we suppress supervariable detection when Schur C is active or when METIS is applied C Workspaces for FLAG(N), and either LEN(N) or some pointers(N+1) LIW8_ELT = int(id%N,8) + int(id%N,8) + 1_8 ELSE C Spaces FLAG(N), LEN(N), N+3, SVAR(0:N), LIW8_ELT = int(id%N,8) + int(id%N,8) + & int(id%N,8)+3_8 + int(id%N,8)+1_8 ENDIF C ENDIF C We must ensure that an array of order C 3*N is available for SMUMPS_ANA_LNEW IF (KEEP(55) .EQ. 0) THEN IF (LIW8.LT.3_8*int(NBLK,8)) LIW8=3_8*int(NBLK,8) ELSE IF (LIW8_ELT.LT.3_8*int(id%N,8)) LIW8_ELT=3_8*int(id%N,8) ENDIF C IF ( KEEP(256) .EQ. 1 ) THEN C It has been checked that id%PERM_IN is associated but C values of pivot order will be checked later and C should be checked here too C PERM_IN( I ) = position of I in the pivot order IKEEP2 => IKEEPALLOC(int(NBLK+1,8):int(NBLK,8)+int(id%N,8)) C Build inverse permutation and check PERM_IN DO I = 1, id%N IKEEP2(I) = 0 ENDDO DO I = 1, id%N IF ( id%PERM_IN(I) .LT.1 .OR. & id%PERM_IN(I) .GT. id%N ) THEN C PERM_IN entry is out-of-range INFO(1) = -4 INFO(2) = I GOTO 10 ELSE IF ( IKEEP2(id%PERM_IN(I)) .NE. 0 ) THEN C Duplicate entry in PERM_IN was found INFO(1) = -4 INFO(2) = I GOTO 10 ELSE C Store entry in inverse permutation IKEEP2(id%PERM_IN( I )) = I ENDIF ENDDO IF ((KEEP(55) .EQ. 0).AND.(KEEP(13).NE.0) & .AND.(KEEP(13).NE.-1) & ) THEN C Build blocked permutation: C IKEEPALLOC(IB)= IBPos where IB, IBPos \in [1:NBLK] C IKEEP2 holds inverse permutation IPOSB = 0 IPOS = 1 DO WHILE (IPOS.LE.id%N) IPOSB = IPOSB+1 I = IKEEP2(IPOS) IBcurrent = DOF2BLOCK(I) BLKSIZE = SIZEOFBLOCKS(IBcurrent) IKEEPALLOC(IBcurrent) = IPOSB IF (BLKSIZE.GT.1) THEN DO II = 1, BLKSIZE-1 IPOS = IPOS+1 I = IKEEP2(IPOS) IB = DOF2BLOCK(I) IF (IB.NE.IBcurrent) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & " ERROR: given permutation (ICNTL(7)=1)", & " incompatible with block format" ENDIF INFO(1)= -4 INFO(2)= I GOTO 10 ENDIF ENDDO ENDIF IPOS = IPOS+1 ENDDO C IF PERM_IN is correct then C on exit last position should be NBLK IF (IPOSB.NE.NBLK) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & " ERROR: given permutation (ICNTL(7)=1)", & " incompatible with block format" ENDIF INFO(1)= -4 C N+1 to indicate "global" error INFO(2)= id%N+1 GOTO 10 ENDIF ELSE DO I = 1, id%N IKEEPALLOC( I ) = id%PERM_IN( I ) END DO ENDIF IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) END IF INFOG(1) = 0 INFOG(2) = 0 C Initialize structural symmetry value to not yet computed. INFOG(8) = -1 IF (KEEP(55) .EQ. 0) THEN IKEEP1 => IKEEPALLOC(1:NBLK) IKEEP2 => IKEEPALLOC(int(NBLK+1,8): & int(NBLK,8)+int(id%N,8)) IKEEP3 => IKEEPALLOC(int(NBLK,8)+int(id%N+1,8): & int(NBLK,8)+2_8*int(id%N,8)) C id%UNS_PERM corresponds to argument PIV C in SMUMPS_ANA_F, it should be an assumed-shape C array rather than a possibly null pointer: IF (associated(id%UNS_PERM)) THEN UNS_PERM_PTR => id%UNS_PERM ELSE UNS_PERM_PTR => IDUMMY_ARRAY ENDIF IF (KEEP(13).EQ.0) THEN CALL SMUMPS_ANA_F(id%N, NZ8, & id%IRN, id%JCN, & LIW8, IKEEP1, IKEEP2, IKEEP3, & KEEP(256), NFSIZPTR, & FILS_TMP, & FREREPTR, & id%LISTVAR_SCHUR, SIZE_SCHUR_PASSED, & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, & UNS_PERM_PTR, & id%CNTL(4), id%COLSCA, id%ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & ) ELSE IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY CALL SMUMPS_ANA_F(NBLK, NZ8, & IRN_loc_PTR, JCN_loc_PTR, & LIW8, IKEEP1, IKEEP2, IKEEP3, & KEEP(256), NFSIZPTR, & FILS_TMP, FREREPTR, & id%LISTVAR_SCHUR, SIZE_SCHUR_PASSED, & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, & UNS_PERM_PTR, & id%CNTL(4), id%COLSCA, id%ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & , id%N, SIZEOFBLOCKS, GCOMP_PROVIDED, GCOMP & ) IF (GCOMP_PROVIDED) & CALL MUMPS_AB_FREE_GCOMP(GCOMP, MEMCNT) C ENDIF INFOG(7) = KEEP(256) C UNS_PERM_PTR was only used locally C for the call to SMUMPS_ANA_F NULLIFY(UNS_PERM_PTR) ELSE allocate( XNODEL ( id%N+1 ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = id%N + 1 IF ( LPOK ) THEN WRITE(LP, 150) 'XNODEL' END IF GOTO 10 ENDIF IF (LELTVAR.ne.id%ELTPTR(NELT+1)-1) THEN C -- internal error INFO(1) = -2002 INFO(2) = id%ELTPTR(NELT+1)-1 GOTO 10 ENDIF allocate( NODEL ( LELTVAR ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LELTVAR IF ( LPOK ) THEN WRITE(LP, 150) 'NODEL' END IF GOTO 10 ENDIF CALL SMUMPS_ANA_F_ELT(id%N, NELT, & id%ELTPTR(1), id%ELTVAR(1), LIW8_ELT, & IKEEPALLOC(1), & KEEP(256), NFSIZPTR(1), FILS_TMP(1), & FREREPTR(1), id%LISTVAR_SCHUR(1), & SIZE_SCHUR_PASSED, & ICNTL(1), INFOG(1), KEEP(1),KEEP8(1), & id%NSLAVES, & XNODEL(1), NODEL(1) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & ) INFOG(7)=KEEP(256) C C XNODEL and NODEL as output to SMUMPS_ANA_F_ELT C be used in SMUMPS_FRTELT and thus C cannot be deallocated at this point C ENDIF IF ( LISTVAR_SCHUR_2BE_FREED ) THEN C We do not want to have LISTVAR_SCHUR C allocated of size 1 if Schur is off. DEALLOCATE( id%LISTVAR_SCHUR ) NULLIFY ( id%LISTVAR_SCHUR ) LISTVAR_SCHUR_2BE_FREED = .TRUE. ENDIF C ------------------------------ C Significant error codes should C always be in INFO(1/2) C ------------------------------ INFO(1)=INFOG(1) INFO(2)=INFOG(2) C save statistics in KEEP array. KEEP(28) = INFOG(6) IKEEP = 1_8 NA = IKEEP + int(id%N,8) NE = IKEEP + 2_8 * int(id%N,8) C -- if (id%myid.eq.master) ENDIF C -- if sequential analysis ENDIF C 10 CONTINUE IF (KEEP(244).EQ.1) THEN CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF IF ((KEEP(244).EQ.1).AND.(KEEP(55).EQ.0)) THEN C Sequential analysis on assembled matrix C check if max transversal should be called CALL MPI_BCAST(KEEP(23),1,MPI_INTEGER,MASTER,id%COMM,IERR) IF ( (KEEP(23).LE.-1).AND.(KEEP(23).GE.-6) ) THEN C -- Perform max transversal KEEP(23) = -KEEP(23) IF (id%MYID.EQ.MASTER) THEN IF (.NOT. associated(id%A)) KEEP(23) = 1 IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (allocated(FILS_TMP) ) THEN DEALLOCATE(FILS_TMP) ENDIF IF (associated(FREREPTR) ) THEN DEALLOCATE(FREREPTR) NULLIFY(FREREPTR) ENDIF IF (associated(NFSIZPTR) ) THEN DEALLOCATE(NFSIZPTR) NULLIFY(NFSIZPTR) ENDIF ENDIF GOTO 1234 ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(244).EQ.1).AND. (KEEP(55).EQ.0)) THEN C Sequential ordering on assembled matrix IF ((KEEP(54).EQ.3).AND.KEEP(494).EQ.0) THEN IF (GATHER_MATRIX_ALLOCATED) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF GATHER_MATRIX_ALLOCATED= .FALSE. ENDIF ENDIF ENDIF ENDIF IF (KEEP(244).NE.1) THEN C{ Parallel analysis IF (id%MYID .EQ. MASTER) THEN C KEEPALLOC reuse later C FIXME allocate of size 2*NBLK and C allocate of size 3*id%N after call ana_aux_par SIZEIKEEPALLOC = 3_8*int(id%N,8) SIZEWORK2ALLOC = max(4_8*int(NBLK,8), int(id%NPROCS+1,8)) ALLOCATE( IKEEPALLOC(SIZEIKEEPALLOC), & WORK2ALLOC(SIZEWORK2ALLOC), & FILS_TMP(NBLK), FREREPTR(NBLK), NFSIZPTR(NBLK), & stat=IERR) ELSE IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN C Allocate only on procs concerned by parallel analysis SIZEIKEEPALLOC = 3_8*int(NBLK,8) SIZEWORK2ALLOC = 4_8*int(NBLK,8) ALLOCATE(IKEEPALLOC(SIZEIKEEPALLOC), & WORK2ALLOC(SIZEWORK2ALLOC), stat=IERR ) ELSE C Not concerned by SMUMPS_ANA_F_PAR IERR = 0 SIZEIKEEPALLOC = 0_8 SIZEWORK2ALLOC = 0_8 ENDIF IF (IERR.GT.0) THEN INFO(1) = -7 IF (id%MYID .EQ. MASTER) THEN CALL MUMPS_SET_IERROR( & SIZEIKEEPALLOC+SIZEWORK2ALLOC+3_8*int(NBLK,8), & INFO(2) ) ELSE CALL MUMPS_SET_IERROR( & SIZEIKEEPALLOC+SIZEWORK2ALLOC, & INFO(2) ) ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C save value provided by user idNBLKSAVE= id%NBLK C #if defined(MUMPS_NOF2003) C Allocatable not allowed in SMUMPS_ANA_F_PAR, C use a pointer instead. FILS_TMP is typically C allocated only on MPI rank 0. IF (allocated(FILS_TMP)) THEN FILS_TMPPTR => FILS_TMP ELSE FILS_TMPPTR => IDUMMY_ARRAY ENDIF #endif IF (LUMAT_AVAIL) THEN C{ C id%NBLK = NBLK IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN IF (RKinidCOMM_PROC0SYMB.NE.MASTER) CALL MUMPS_ABORT() CALL SMUMPS_ANA_F_PAR(id, & IKEEPALLOC, & WORK2ALLOC, & SIZEIKEEPALLOC, & SIZEWORK2ALLOC, & NFSIZPTR, #if defined(MUMPS_NOF2003) & FILS_TMPPTR, #else & FILS_TMP, #endif & FREREPTR, & COMM_PARASYMB ! optional: & , LUMAT, SIZEOFBLOCKS & , COMM_PARAORD, NPROCS_PARAORD & , RKinSYMB_PROC0ORD & ) ENDIF IF (KEEP(494).EQ.0.OR.KEEP(487).NE.1) THEN CALL MUMPS_AB_FREE_LMAT(LUMAT,KEEP(147)) LUMAT_AVAIL = .FALSE. ELSE LUMAT_AVAIL = .TRUE. ENDIF C C} ELSE C{ LUMAT not available and COMM_PARASYMB=id%COMM id%NBLK = id%N CALL SMUMPS_ANA_F_PAR(id, & IKEEPALLOC, & WORK2ALLOC, & SIZEIKEEPALLOC, & SIZEWORK2ALLOC, & NFSIZPTR, #if defined(MUMPS_NOF2003) & FILS_TMPPTR, #else & FILS_TMP, #endif & FREREPTR, & id%COMM & ) C} ENDIF id%NBLK = idNBLKSAVE IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN DEALLOCATE(WORK2ALLOC) IF(id%MYID .NE. MASTER) THEN DEALLOCATE(IKEEPALLOC) ENDIF ENDIF KEEP(28) = INFOG(6) IF (COMM_PARAORD_ALLOCATED) THEN IF (COMM_PARAORD.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_FREE( COMM_PARAORD, IERR ) COMM_PARAORD_ALLOCATED = .FALSE. ENDIF ENDIF IF (COMM_PARASYMB_ALLOCATED) THEN IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_FREE( COMM_PARASYMB, IERR ) COMM_PARASYMB_ALLOCATED = .FALSE. ENDIF ENDIF C Check error after freeing communicators CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C IF (id%MYID.EQ.MASTER) THEN IKEEP = 1_8 NA = IKEEP + int(id%N,8) NE = IKEEP + 2_8 * int(id%N,8) ENDIF C --------------------------------------------------------- C Check whether FILS_TMP, FREREPTR, NFSIZPTR C computed on master of COMM_PARSYMB (RKinidCOMM_PROC0SYMB) C should be send on MASTER C --------------------------------------------------------- IF (RKinidCOMM_PROC0SYMB.NE.MASTER) THEN C allocate data on MASTER of id%COMM IF (id%MYID.EQ.MASTER) THEN C FILS_TMP allocate to size NBLK since it will be C allways copied back in structure ALLOCATE( FILS_TMP(NBLK), FREREPTR(id%N), NFSIZPTR(id%N), & stat=IERR) ENDIF ENDIF IF (IERR.GT.0) THEN INFO(1) = -7 IF (id%MYID .EQ. MASTER) THEN CALL MUMPS_SET_IERROR(3_8*int(id%N,8), INFO(2)) ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF (RKinidCOMM_PROC0SYMB.NE.MASTER) THEN C data computed on master of COMM_PARASYMB to be C sent on MASTER of id%COMM C FIXME to be authorized INFOG data should also C be sent to MASTER of id%COMM CALL MUMPS_ABORT() IF (id%MYID.EQ.RKinidCOMM_PROC0SYMB) THEN CALL MPI_SEND (FILS_TMP(1), NBLK, MPI_INTEGER, & MASTER, CENT_AFTER_PARAORD, id%COMM, IERR) CALL MPI_SEND (FREREPTR(1), NBLK, MPI_INTEGER, & MASTER, CENT_AFTER_PARAORD, id%COMM, IERR) CALL MPI_SEND (NFSIZPTR(1), NBLK, MPI_INTEGER, & MASTER, CENT_AFTER_PARAORD, id%COMM, IERR) C C deallocate data sent to MASTER DEALLOCATE(FILS_TMP, FREREPTR, NFSIZPTR) C FILS_TMP is an allocatable array nullify(FREREPTR, NFSIZPTR) C ENDIF IF (id%MYID.EQ.MASTER) THEN CALL MPI_RECV (FILS_TMP(1), NBLK, MPI_INTEGER, & RKinidCOMM_PROC0SYMB, CENT_AFTER_PARAORD, & id%COMM, STATUS, IERR) CALL MPI_RECV (FREREPTR(1), NBLK, MPI_INTEGER, & RKinidCOMM_PROC0SYMB, CENT_AFTER_PARAORD, & id%COMM, STATUS, IERR) CALL MPI_RECV (NFSIZPTR(1), NBLK, MPI_INTEGER, & RKinidCOMM_PROC0SYMB, CENT_AFTER_PARAORD, & id%COMM, STATUS, IERR) ENDIF C ENDIF C} END IF C Allocated PROCNODE on MASTER IF (id%MYID.EQ.MASTER) THEN allocok = 0 allocate(PROCNODE(NBLK), STAT=allocok) IF (allocok .ne. 0) THEN INFO(1) = -7 INFO(2) = NBLK ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF ( I_AM_SLAVE) THEN KEEP(144)=1 ! MPI process is working ELSE KEEP(144)=0 ENDIF IF(id%MYID .EQ. MASTER) THEN C Save ICNTL(14) value into KEEP(12) CALL MUMPS_GET_PERLU(KEEP(12),ICNTL(14), & KEEP(50),KEEP(54),ICNTL(6),KEEP(52)) CALL SMUMPS_ANA_R(NBLK, FILS_TMP(1), FREREPTR(1), & IKEEPALLOC(NE), IKEEPALLOC(NA)) C ********************************************************** C Continue with CALL to MAPPING routine C ********************* C BEGIN SEQUENTIAL CODE C No mapping computed C ********************* C C In sequential, if no special root C reset KEEP(20) and KEEP(38) to 0 C IF (id%NSLAVES .EQ. 1 & ) THEN id%NBSA = 0 IF ( (id%KEEP(60).EQ.0). & AND.(id%KEEP(53).EQ.0)) THEN C If Schur is on (keep(60).ne.0) C or if RR is on (keep (53) > 0 C then we keep root numbers C root node number in seq id%KEEP(20)=0 C root node number in paral id%KEEP(38)=0 ENDIF C No type 2 nodes: id%KEEP(56)=0 C All mapped on MPI process 0, and of type TPN=0 C (treated as if they were all root of subtree) PROCNODE_VALUE = MUMPS_ENCODE_TPN_IPROC(0, 0, KEEP(199)) DO I = 1, NBLK PROCNODE(I) = PROCNODE_VALUE END DO C It may also happen that KEEP(38) has already been set, C in the case of a distributed Schur complement (KEEP(60)=2 or 3). C In that case, PROCNODE should be set accordingly and KEEP(38) is C not modified. IF (id%KEEP(60) .EQ. 2 .OR. id%KEEP(60).EQ.3) THEN PROCNODE_VALUE = MUMPS_ENCODE_TPN_IPROC(3, 0, KEEP(199)) CALL SMUMPS_SET_PROCNODE(id%KEEP(38), PROCNODE(1), & PROCNODE_VALUE, FILS_TMP(1), NBLK) ENDIF C ******************* C END SEQUENTIAL CODE C ******************* ELSE C ***************************** C BEGIN MAPPING WITH CANDIDATES C (NSLAVES > 1) C ***************************** C C C peak is set by default to 1 largest front + One largest CB PEAK = real(id%INFOG(5))*real(id%INFOG(5)) + ! front matrix & real(id%KEEP(2))*real(id%KEEP(2)) ! cb bloc C IKEEP(1:N,1) can be used as a work space since it is set C to its final state by the SORT_PERM subroutine below. SSARBR => IKEEPALLOC(IKEEP:IKEEP+int(NBLK-1,8)) C ====================================================== C Map nodes and assign candidates for dynamic scheduling C ====================================================== IF ((KEEP(13).NE.0).AND.(NBLK.NE.id%N)) THEN SIZEOFBLOCKS_PTR => SIZEOFBLOCKS(1:NBLK) LSIZEOFBLOCKS_PTR = NBLK ELSE SIZEOFBLOCKS_PTR => IDUMMY_ARRAY LSIZEOFBLOCKS_PTR = 1 IDUMMY_ARRAY(1) = -1 ENDIF CALL SMUMPS_DIST_AVOID_COPIES( & NBLK,id%NSLAVES,ICNTL(1), & INFOG(1), & IKEEPALLOC(NE), & NFSIZPTR(1), & FREREPTR(1), & FILS_TMP(1), & KEEP(1),KEEP8(1),PROCNODE(1), & SSARBR(1),id%NBSA,PEAK,IERR & , SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR & ) NULLIFY(SSARBR) if(IERR.eq.-999) then write(6,*) ' Internal error during static mapping ' INFO(1) = IERR GOTO 11 ENDIF IF(IERR.NE.0) THEN INFO(1) = -135 INFO(2) = IERR GOTO 11 ENDIF CALL SMUMPS_ANA_R(NBLK, FILS_TMP(1), & FREREPTR(1), IKEEPALLOC(NE), & IKEEPALLOC(NA)) ENDIF 11 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C The following part is done in parallel CALL MPI_BCAST( id%NELT, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KEEP(55) .EQ. 0) THEN C Assembled matrix format. Fill up the id%PTRAR array C Broadcast id%SYM_PERM needed to fill up id%PTRAR C postpone to after computation of id%SYM_PERM C computed after id%DAD_STEPS if (associated(id%FRTPTR)) DEALLOCATE(id%FRTPTR) if (associated(id%FRTELT)) DEALLOCATE(id%FRTELT) allocate( id%FRTPTR(1), id%FRTELT(1) ,STAT=allocok) IF (allocok .GT. 0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'FRTPTR,FRTELT' END IF INFO(1)= -7 INFO(2)= 2 END IF ELSE C Element Entry: C ------------------------------- C COMPUTE THE LIST OF ELEMENTS THAT WILL BE ASSEMBLED C AT EACH NODE OF THE ELIMINATION TREE. ALSO COMPUTE C FOR EACH ELEMENT THE TREE NODE TO WHICH IT IS ASSIGNED. C C FRTPTR is an INTEGER array of length N+1 which need not be set by C the user. On output, FRTPTR(I) points in FRTELT to first element C in the list of elements assigned to node I in the elimination tree. C C FRTELT is an INTEGER array of length NELT which need not be set by C the user. On output, positions FRTELT(FRTPTR(I)) to C FRTELT(FRTPTR(I+1)-1) contain the list of elements assigned to C node I in the elimination tree. C LPTRAR = id%NELT+id%NELT+2 CALL MUMPS_I8REALLOC(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%FRTPTR, id%N+1, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTPTR (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%ELTPROC, id%NELT, id%INFO, LP, & FORCE=.TRUE., STRING='id%ELTPROC (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%FRTELT, id%NELT, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTELT (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF(id%MYID .EQ. MASTER) THEN C In the elemental format case, PTRAR&friends are still C computed sequentially and then broadcasted CALL SMUMPS_FRTELT( & id%N, NELT, id%ELTPTR(NELT+1)-1, FREREPTR(1), & FILS_TMP(1), & IKEEPALLOC(NA), IKEEPALLOC(NE), XNODEL, & NODEL, id%FRTPTR(1), id%FRTELT(1), id%ELTPROC(1)) DO I=1, id%NELT+1 C PTRAR declared 64-bit id%PTRAR(id%NELT+I+1)=int(id%ELTPTR(I),8) ENDDO DEALLOCATE(XNODEL) DEALLOCATE(NODEL) END IF CALL MPI_BCAST( id%PTRAR(id%NELT+2), id%NELT+1, MPI_INTEGER8, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRTPTR(1), id%N+1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRTELT(1), id%NELT, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C We switch again to sequential computations on the master node IF(id%MYID .EQ. MASTER) THEN IF ( INFO( 1 ) .LT. 0 ) GOTO 12 IF ( KEEP(55) .ne. 0 ) THEN C --------------------------------------- C Build ELTPROC: correspondance between elements and slave ranks C in COMM_NODES with special values -1 (all procs) and -2 and -3 C (no procs). This is used later to distribute the elements on C the processes at the beginning of the factorisation phase C --------------------------------------- CALL SMUMPS_ELTPROC(NBLK, NELT, id%ELTPROC(1),id%NSLAVES, & PROCNODE(1), id%KEEP(1)) END IF NB_NIV2 = KEEP(56) IF ( NB_NIV2.GT.0 ) THEN C allocate(PAR2_NODES(NB_NIV2), & STAT=allocok) IF (allocok .GT.0) then INFO(1)= -7 INFO(2)= NB_NIV2 IF ( LPOK ) THEN WRITE(LP, 150) 'PAR2_NODES' END IF GOTO 12 END IF ENDIF IF ((NB_NIV2.GT.0) .AND. (KEEP(24).EQ.0)) THEN INIV2 = 0 DO 777 INODE = 1, NBLK IF ( ( FREREPTR(INODE) .NE. NBLK ) .AND. & ( MUMPS_TYPENODE(PROCNODE(INODE),id%KEEP(199)) & .eq. 2) ) THEN INIV2 = INIV2 + 1 PAR2_NODES(INIV2) = INODE END IF 777 CONTINUE IF ( INIV2 .NE. NB_NIV2 ) THEN WRITE(*,*) "Internal Error 2 in SMUMPS_ANA_DRIVER", & INIV2, NB_NIV2 CALL MUMPS_ABORT() ENDIF ENDIF IF ( (KEEP(24) .NE. 0) .AND. (NB_NIV2.GT.0) ) THEN C allocate array to store cadidates stategy C for each level two nodes IF ( associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES) allocate( id%CANDIDATES(id%NSLAVES+1,NB_NIV2), & stat=allocok) if (allocok .gt.0) then INFO(1)= -7 INFO(2)= NB_NIV2*(id%NSLAVES+1) IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 END IF CALL MUMPS_RETURN_CANDIDATES & (PAR2_NODES,id%CANDIDATES, & IERR) IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF C deallocation of variables of module mumps_static_mapping CALL MUMPS_END_ARCH_CV() IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF ELSE IF (associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES) allocate(id%CANDIDATES(1,1), stat=allocok) IF (allocok .NE. 0) THEN INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 ENDIF ENDIF C******************************************************************* C --------------- 12 CONTINUE C --------------- * * =============================== * End of analysis phase on master * =============================== * END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C C We now allocate and compute arrays in NSTEPS C on the master, as this makes more sense. C C Broadcast KEEP8(101) to be used in MUMPS_ANA_L0_OMP CALL MPI_BCAST( id%KEEP8(101), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) C C ============================== C PREPARE DATA FOR FACTORIZATION C ============================== C ------------------ CALL MPI_BCAST( id%KEEP(1), 110, MPI_INTEGER, MASTER, & id%COMM, IERR ) C We also need to broadcast KEEP8(21) CALL MPI_BCAST( id%KEEP8(21), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) C -------------------------------------------------- C Broadcast KEEP(205) which is outside the first 110 C KEEP entries but is needed for factorization. C -------------------------------------------------- CALL MPI_BCAST( id%KEEP(205), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C -------------- C Broadcast NBSA CALL MPI_BCAST( id%NBSA, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- C Global MAXFRT (computed in SMUMPS_ANA_M) C is needed on all the procs during SMUMPS_ANA_DISTM C to evaluate workspace for solve. C We could also recompute it in SMUMPS_ANA_DISTM IF (id%MYID==MASTER) KEEP(127)=INFOG(5) CALL MPI_BCAST( id%KEEP(127), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- C Global max panel size KEEP(226) CALL MPI_BCAST( id%KEEP(226), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- CALL MPI_BCAST( id%KEEP(464), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(471), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(475), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(482), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(487), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) C Number of leaves not belonging to L0 KEEP(262) C and KEEP(263) : inner or outer sends for blocked facto CALL MPI_BCAST( id%KEEP(262), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ---------------------------------------- C Allocate new workspace on all processors C ---------------------------------------- C STEP_TMP is of size NBLK because it C is computed on compressed graph and C broadcasted when needed. C It is then extended in id%STEP on master C and broadcasted on all procs ALLOCATE(STEP_TMP(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NBLK ENDIF IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%PROCNODE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%PROCNODE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%NE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%NE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%ND_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%ND_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%FRERE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%FRERE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%DAD_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%DAD_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 IF (KEEP(55) .EQ. 0) THEN LPTRAR = 2 CALL MUMPS_I8REALLOC(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 ENDIF IF (id%KEEP(494).NE.0) THEN C of size NBLK that will be extended and copies later C on master SIZELRGROUPS_TMP = NBLK ELSE C needed as argument for SMUMPS_EXPAND_TREE_STEPS SIZELRGROUPS_TMP = 1 ENDIF ALLOCATE(LRGROUPS_TMP(SIZELRGROUPS_TMP), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NBLK ENDIF C IF(INFO(1).LT.0) GOTO 94 C Copy data for factorization and/or solve. C ================================ C COMPUTE ON THE MASTER, BROADCAST C TO OTHER PROCESSES C ================================ IF ( id%MYID .NE. MASTER .OR. id%KEEP(23) .EQ. 0 ) THEN IF ( associated( id%UNS_PERM ) ) THEN DEALLOCATE(id%UNS_PERM) ENDIF ENDIF 94 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( id%MYID .EQ. MASTER ) THEN C NA -> compressed NA containing only list C of leaves of the elimination tree and list of roots C (the two useful informations for factorization/solve). IF (NBLK.eq.1) THEN NBROOT = 1 NBLEAF = 1 ELSE IF (IKEEPALLOC(NA+int(NBLK-1,8)) .LT.0) THEN NBLEAF= NBLK NBROOT= NBLK ELSE IF (IKEEPALLOC(NA+int(NBLK-2,8)) .LT.0) THEN NBLEAF = NBLK-1 NBROOT = IKEEPALLOC(NA+int(NBLK-1,8)) ELSE NBLEAF = IKEEPALLOC(NA+int(NBLK-2,8)) NBROOT = IKEEPALLOC(NA+int(NBLK-1,8)) ENDIF id%LNA = 2+NBLEAF+NBROOT ENDIF CALL MPI_BCAST( id%LNA, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MUMPS_REALLOC(id%NA, id%LNA, id%INFO, LP, FORCE=.TRUE., & STRING='id%NA (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF (id%MYID .EQ.MASTER ) THEN C{ The structure of NA is the following: C NA(1) is the number of leaves. C NA(2) is the number of roots. C NA(3:2+NA(1)) are the leaves. C NA(3+NA(1):2+NA(1)+NA(2)) are the roots. id%NA(1) = NBLEAF id%NA(2) = NBROOT C C Initialize NA with the leaves and roots LEAF = 3 IF ( NBLK == 1 ) THEN id%NA(LEAF) = 1 LEAF = LEAF + 1 ELSE IF (IKEEPALLOC(NA+int(NBLK-1,8)) < 0) THEN id%NA(LEAF) = - IKEEPALLOC(NA+int(NBLK-1,8))-1 LEAF = LEAF + 1 DO I = 1, NBLEAF - 1 id%NA(LEAF) = IKEEPALLOC(NA+int(I-1,8)) LEAF = LEAF + 1 ENDDO ELSE IF (IKEEPALLOC(NA+int(NBLK-2,8)) < 0 ) THEN INODE = - IKEEPALLOC(NA+int(NBLK-2,8)) - 1 id%NA(LEAF) = INODE LEAF =LEAF + 1 IF ( NBLEAF > 1 ) THEN DO I = 1, NBLEAF - 1 id%NA(LEAF) = IKEEPALLOC(NA+int(I-1,8)) LEAF = LEAF + 1 ENDDO ENDIF ELSE DO I = 1, NBLEAF id%NA(LEAF) = IKEEPALLOC(NA+int(I-1,8)) LEAF = LEAF + 1 ENDDO END IF C C Build array STEP_TMP(1:NBLK) to hold step numbers in C range 1..id%KEEP(28), allowing compression of C other arrays from id%N to id%KEEP(28) C (the number of nodes/steps in the assembly tree) ISTEP = 0 DO I = 1, NBLK IF ( FREREPTR(I) .ne. NBLK + 1 ) THEN C New node in the tree. c (Set step( inode_n ) = inode_nsteps for principal C variables and -inode_nsteps for internal variables C of the node) ISTEP = ISTEP + 1 STEP_TMP(I)=ISTEP INN = FILS_TMP(I) DO WHILE ( INN .GT. 0 ) STEP_TMP(INN) = - ISTEP INN = FILS_TMP(INN) END DO IF (FREREPTR(I) .eq. 0) THEN C Keep root nodes list in NA id%NA(LEAF) = I LEAF = LEAF + 1 ENDIF ENDIF END DO IF ( LEAF - 1 .NE. 2+NBROOT + NBLEAF ) THEN WRITE(*,*) 'Internal error 2 in SMUMPS_ANA_DRIVER' CALL MUMPS_ABORT() ENDIF IF ( ISTEP .NE. id%KEEP(28) ) THEN write(*,*) 'Internal error 3 in SMUMPS_ANA_DRIVER', & ISTEP, id%KEEP(28) CALL MUMPS_ABORT() ENDIF C ============ C SET PROCNODE, FRERE, NE C ============ C copies to NSTEP array should be ok DO I = 1, NBLK IF (FREREPTR(I) .NE. NBLK+1) THEN id%PROCNODE_STEPS(STEP_TMP(I)) = PROCNODE( I ) id%FRERE_STEPS(STEP_TMP(I)) = FREREPTR(I) id%NE_STEPS(STEP_TMP(I)) = IKEEPALLOC(NE+int(I-1,8)) id%ND_STEPS(STEP_TMP(I)) = NFSIZPTR(I) ENDIF ENDDO C =============================== C Algorithm to compute array DAD_STEPS: C ---- C For each node set dad for all of its sons C plus, for root nodes set dad to zero. C C =============================== DO I = 1, NBLK C -- skip non principal nodes IF ( STEP_TMP(I) .LE. 0) CYCLE C -- (I) is a principal node IF (FREREPTR(I) .eq. 0) THEN C -- I is a root node and has no father id%DAD_STEPS(STEP_TMP(I)) = 0 ENDIF C -- Find first son node (IFS) IFS = FILS_TMP(I) DO WHILE ( IFS .GT. 0 ) IFS= FILS_TMP(IFS) END DO C -- IFS > 0 if I is not a leave node C -- Go through list of brothers of IFS if any IFS = -IFS DO WHILE (IFS.GT.0) C -- I is not a leave node and has a son node IFS id%DAD_STEPS(STEP_TMP(IFS)) = I IFS = FREREPTR(IFS) ENDDO END DO C C C Following arrays (PROCNODE and IKEEPALLOC) not used anymore C during analysis IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (associated(FREREPTR)) DEALLOCATE(FREREPTR) NULLIFY(FREREPTR) IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR) NULLIFY(NFSIZPTR) ENDIF IF (KEEP(494).NE.0) THEN C{ IF (id%MYID.EQ.MASTER) THEN IF (PROKG) THEN CALL MUMPS_SECDEB(TIMEG) END IF ENDIF C ======================================================= C Compute a grouping of variables for LR approximations. C Grouping may be performed on a distributed matrix C ======================================================= C C ======================================= C I/ Prepare data before call to grouping C ======================================= LUMAT_REMAP_DIST_AVAIL = .FALSE. LUMAT_REMAP_CENT_AVAIL = .FALSE. C IF (LUMAT_AVAIL) THEN C Use clean symmetrized LUMAT matrix available ALLOCATE(MAPCOL(id%KEEP(28)), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C CALL MUMPS_INIALIZE_REDIST_LUMAT ( & id%INFO, id%ICNTL, id%KEEP, id%COMM, id%MYID, NBLK, & id%NPROCS, & LUMAT, id%PROCNODE_STEPS(1), id%KEEP(28), MAPCOL, & LUMAT_REMAP, NBRECORDS, STEP_TMP(1)) C INFO(1) has been broadcasted already in routine IF ( id%INFO(1).LT.0 ) GOTO 500 C C -- Redistribute LUMAT into LU_REMAP relying on procnode CALL MUMPS_AB_DIST_LMAT_TO_LUMAT ( & .FALSE., ! do not UNFOLD & .TRUE., ! MAPCOL in NSTEPS=> STEP array needed & id%INFO, id%ICNTL, id%COMM, id%MYID, NBLK, id%NPROCS, & LUMAT, MAPCOL, id%KEEP(28), STEP_TMP(1), NBLK, & LUMAT_REMAP, NBRECORDS, NSEND8, NLOCAL8 & ) LUMAT_REMAP_DIST_AVAIL = .TRUE. CALL MUMPS_AB_FREE_LMAT(LUMAT,KEEP(147)) C Distribute SIZEOFBLOCKS that was defined only on master CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, & id%COMM, IERR ) C} ELSE IF ( LMAT_BLOCK_AVAIL ) THEN C{ Centralized matrix and clean LMAT_BLOCK available C IF (id%MYID.EQ.MASTER) THEN C CALL MUMPS_AB_CLEANLMAT_TO_LUMAT ( & LMAT_BLOCK, LUMAT_REMAP, KEEP(147), & INFO(1), ICNTL(1)) LUMAT_REMAP_CENT_AVAIL=.TRUE. C --- LMAT_BLOCK not needed anymore CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK,KEEP(147)) C ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C} ELSE IF ((KEEP(54).EQ.3).AND.(KEEP(13).EQ.0) & .AND. KEEP(487).EQ.1) THEN C{ C Matrix is distributed on entry and compression not requested C (this will be the case when ICNTL(15).EQ.0 and C // analysis, or Schur, etc...) C note that with distributed matrix and centralized ordering C compression is forced to limit memory peak) C Free centralized matrix before grouping to C limit memory peak IF (GATHER_MATRIX_ALLOCATED) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF GATHER_MATRIX_ALLOCATED= .FALSE. ENDIF IF (.NOT. I_AM_SLAVE .OR. ! non-working master & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc ENDIF ALLOCATE(MAPCOL(id%KEEP(28)), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C C Build MAPCOL and LUMAT_REMAP mapped according C to MAPCOL (outputs available on all MPI procs). CALL MUMPS_AB_DCOORD_TO_DTREE_LUMAT ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & id%PROCNODE_STEPS(1), id%KEEP(28), STEP_TMP(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & MAPCOL, LUMAT_REMAP ) LUMAT_REMAP_DIST_AVAIL = .TRUE. IF (INFO(1).GE.0) THEN C SIZEOFBLOCKS needed on all procs during MPI grouping ALLOCATE(SIZEOFBLOCKS(NBLK), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= NBLK ENDIF DO I=1, NBLK SIZEOFBLOCKS(I) = 1 ENDDO ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C} ELSE IF ((KEEP(54).EQ.3) .AND. (KEEP(487).NE.1) & ) THEN C{ C Grouping preparation on slaves: C If the input matrix is distributed C the graph is centralized to compute the C clustering. C CALL SMUMPS_GATHER_MATRIX(id) GATHER_MATRIX_ALLOCATED = .TRUE. C} ENDIF C ============ C ============ C II/ GROUPING C ============ IF (LUMAT_REMAP_DIST_AVAIL) THEN C{ Distributed memory based grouping is used IF (id%MYID.NE.MASTER) THEN ALLOCATE(FILS_TMP(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NBLK ENDIF ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL MPI_BCAST( id%ND_STEPS(1), KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL SMUMPS_AB_LR_MPI_GROUPING(NBLK, & MAPCOL, id%KEEP(28), & id%KEEP(28), LUMAT_REMAP, FILS_TMP(1), & id%FRERE_STEPS, & id%DAD_STEPS, STEP_TMP(1), id%NA, & id%LNA, LRGROUPS_TMP(1), SIZEOFBLOCKS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), id%KEEP(142), & LPOK, LP, id%COMM, id%MYID, id%NPROCS, & id%KEEP(1), id%ND_STEPS) IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) IF (id%MYID.NE.MASTER) DEALLOCATE(FILS_TMP) C} ELSE IF (id%MYID.EQ.MASTER) THEN C{ IF (LUMAT_REMAP_CENT_AVAIL) THEN C{ C IDUMMY_ARRAY(1) = -1 CALL SMUMPS_AB_LR_MPI_GROUPING(NBLK, & IDUMMY_ARRAY, 1, & id%KEEP(28), LUMAT_REMAP, FILS_TMP, & id%FRERE_STEPS, & id%DAD_STEPS, STEP_TMP, id%NA, & id%LNA, LRGROUPS_TMP, SIZEOFBLOCKS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), id%KEEP(142), & LPOK, LP, id%COMM, id%MYID, id%NPROCS, & id%KEEP(1), id%ND_STEPS) C} ELSE C{ grouping based on centralized matrix IF (KEEP(469).EQ.0) THEN CALL SMUMPS_LR_GROUPING(id%N, id%KEEP8(28), id%KEEP(28), & id%IRN, & id%JCN, FILS_TMP, id%FRERE_STEPS, & id%DAD_STEPS, id%NE_STEPS, STEP_TMP, id%NA, & id%LNA, LRGROUPS_TMP, & id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(10), & id%KEEP(54), id%KEEP(142), & LPOK, LP, GATHER_MATRIX_ALLOCATED, & id%KEEP(1), id%ND_STEPS) ELSE CALL SMUMPS_LR_GROUPING_NEW(id%N, id%KEEP8(28), & id%KEEP(28), id%IRN, & id%JCN, FILS_TMP, id%FRERE_STEPS, & id%DAD_STEPS, STEP_TMP, id%NA, & id%LNA, LRGROUPS_TMP, id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), id%KEEP(142), & LPOK, LP, GATHER_MATRIX_ALLOCATED, & id%KEEP(1), id%ND_STEPS) ENDIF C} ENDIF C} ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C update KEEP(142): maximum group size CALL MPI_BCAST( KEEP(142), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ============ C III/ CLEANUP C ============ C Free LUMAT_REMAP if allocated IF (LUMAT_REMAP_DIST_AVAIL.OR.LUMAT_REMAP_CENT_AVAIL) & CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP,KEEP(147)) IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF ( (KEEP(54).EQ.3) .AND. (KEEP(244).EQ.2).AND. & (KEEP(487).NE.1) ) THEN C Cleanup the irn and jcn arrays filled up by the C cmumps_gather_matrix above. It might have been done C during grouping IF (GATHER_MATRIX_ALLOCATED) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF GATHER_MATRIX_ALLOCATED= .FALSE. ENDIF END IF IF (PROKG) THEN CALL MUMPS_SECFIN(TIMEG) WRITE(MPG,145) TIMEG END IF C} Grouping: KEEP(494) .NE. 0 ENDIF C ALLOCATE id%FILS(id%N)on all procs possibly using mpi3 CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 C C ALLOCATE id%STEP(id%N)on all procs possibly using mpi3 CALL MUMPS_REALLOC(id%STEP, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 C C ALLOCATE id%LRGROUPS on all procs possibly using mpi3 C compute size of id%LRGROUPS in KEEP(280) IF (id%KEEP(494).EQ.0) THEN C not used id%KEEP(280) = 1 ELSE id%KEEP(280) = id%N ENDIF CALL MUMPS_REALLOC(id%LRGROUPS, id%KEEP(280), id%INFO, LP, & FORCE=.TRUE., & STRING='id%LRGROUPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 IF (id%MYID.EQ.MASTER) THEN C{ IF (KEEP(13).NE.0) THEN C{ =========== C Expand tree C =========== C Current tree is relative to the analysis by block. C Expand the tree on the master if compression is effective C (in all cases, grouping done or not) IF (NBLK.LT.id%N.OR.(.NOT.BLKVAR_ALLOCATED)) THEN C { C even if NBLK.EQ.N BLKVAR provided by user might hold C a permutation of the variables and this expand_tree_steps C should also be called C Expand FILS_TMP, STEP_TMP into id%FILS, id%STEP C and update arrays of size NSTEPS IF (NB_NIV2.EQ.0) THEN IDUMMY_ARRAY(1) = -9999 PAR2_NODESPTR => IDUMMY_ARRAY(1:1) SIZE_PAR2_NODESPTR=1 ELSE PAR2_NODESPTR => PAR2_NODES(1:NB_NIV2) SIZE_PAR2_NODESPTR=NB_NIV2 ENDIF CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 CALL SMUMPS_EXPAND_TREE_STEPS (id%ICNTL, & id%N, NBLK, BLKPTR_PTRLOC(1), BLKVAR_PTRLOC(1), & FILS_TMP(1), id%FILS(1), id%KEEP(28), & STEP_TMP(1), id%STEP(1), & PAR2_NODESPTR(1), SIZE_PAR2_NODESPTR, & id%DAD_STEPS(1), id%FRERE_STEPS(1), & id%NA(1), id%LNA, & LRGROUPS_TMP(1), SIZELRGROUPS_TMP, & id%LRGROUPS(1), KEEP(280), & id%KEEP(20), id%KEEP(38), KEEP(494) & ) NULLIFY(PAR2_NODESPTR) C C } ELSE C{ NBLK=N C perform local copies DO I=1, NBLK id%STEP(I) = STEP_TMP(I) id%FILS(I) = FILS_TMP(I) ENDDO IF (id%KEEP(494).NE.0) THEN DO I=1, id%KEEP(280) id%LRGROUPS(I) = LRGROUPS_TMP(I) ENDDO ENDIF C} ENDIF C} ELSE C{ NBLK=N C perform local copies DO I=1, NBLK id%STEP(I) = STEP_TMP(I) id%FILS(I) = FILS_TMP(I) ENDDO IF (id%KEEP(494).NE.0) THEN C we copy only in case of BLR since C LRGROUPS_TMP is otherwise allocated C and not used/initialized DO I=1, id%KEEP(280) id%LRGROUPS(I) = LRGROUPS_TMP(I) ENDDO ENDIF C} ENDIF C C ------------------------------------------- C Adjust LR_GROUPING to bound size of groups C and update KEEP(142): maximum group size C that should then be broadcasted again C ------------------------------------------- IF (id%N.GT.NBLK.AND.KEEP(494).NE.0) THEN CALL MUMPS_ADJUST_SIZE_LRGROUPS ( & id%STEP(1), id%FILS(1), id%N, & id%ND_STEPS(1), id%KEEP(28), id%KEEP(1), & id%LRGROUPS(1), INFO(1), INFO(2)) ENDIF C} ENDIF C update KEEP(142): maximum group size that might have been C updated in MUMPS_ADJUST_SIZE_LRGROUPS CALL MPI_BCAST( KEEP(142), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C 97 CONTINUE C IF (allocated(STEP_TMP)) DEALLOCATE(STEP_TMP) IF (allocated(LRGROUPS_TMP)) DEALLOCATE(LRGROUPS_TMP) IF (allocated(FILS_TMP)) DEALLOCATE(FILS_TMP) C C CALL MUMPS_REALLOC(id%SYM_PERM, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF (id%MYID.EQ.MASTER) THEN C ================================================================= C Reorder the tree using a variant of Liu's algorithm. Note that C REORDER_TREE MUST always be called since it sorts NA (the list of C leaves) in a valid order in the sense of a depth-first traversal. C ================================================================= CALL SMUMPS_REORDER_TREE(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%KEEP(70), & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(215), & id%KEEP(234), id%KEEP(55), id%KEEP(199), & id%PROCNODE_STEPS(1),id%NSLAVES,PEAK,id%KEEP(90) & ) IF(id%KEEP(261).EQ.1)THEN CALL MUMPS_SORT_STEP(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%INFO(1), & id%ICNTL(1),id%PROCNODE_STEPS(1),id%NSLAVES & ) ENDIF C Compute and export some global information on the tree needed by C dynamic schedulers during the factorization. The type of C information depends on the selected strategy. IF ((id%KEEP(76).GE.4).OR.(id%KEEP(76).GE.6).OR. & (id%KEEP(47).EQ.4).OR.((id%KEEP(81).GT.0) & .AND.(id%KEEP(47).GE.2)))THEN IS_BUILD_LOAD_MEM_CALLED=.TRUE. IF ((id%KEEP(47) .EQ. 4).OR. & (( id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN IF(id%NSLAVES.GT.1) THEN C NBSA is the total number of subtrees and C is an upperbound of the local number of C subtrees SIZE_TEMP_MEM = id%NBSA ELSE C Only one processor, NA(2) is the number of leaves SIZE_TEMP_MEM = id%NA(2) ENDIF ELSE SIZE_TEMP_MEM = 1 ENDIF IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN SIZE_DEPTH_FIRST=id%KEEP(28) ELSE SIZE_DEPTH_FIRST=1 ENDIF allocate(TEMP_MEM(SIZE_TEMP_MEM,id%NSLAVES),STAT=allocok) IF (allocok .NE.0) THEN INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_MEM' END IF GOTO 80 !! FIXME propagate error END IF allocate(TEMP_LEAF(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_LEAF' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 !! FIXME propagate error end if allocate(TEMP_SIZE(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_SIZE' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 end if allocate(TEMP_ROOT(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_ROOT' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 end if allocate(DEPTH_FIRST(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'DEPTH_FIRST' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if ALLOCATE(DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'DEPTH_FIRST_SEQ' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if ALLOCATE(SBTR_ID(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'SBTR_ID' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if IF(id%KEEP(76).EQ.5)THEN C We reuse the same variable as before SIZE_COST_TRAV=id%KEEP(28) ELSE SIZE_COST_TRAV=1 ENDIF allocate(COST_TRAV_TMP(SIZE_COST_TRAV),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'COST_TRAV_TMP' END IF INFO(1)= -7 INFO(2)= SIZE_COST_TRAV GOTO 80 END IF IF(id%KEEP(76).EQ.5)THEN IF(id%KEEP(70).EQ.0)THEN id%KEEP(70)=5 ENDIF IF(id%KEEP(70).EQ.1)THEN id%KEEP(70)=6 ENDIF ENDIF IF(id%KEEP(76).EQ.4)THEN IF(id%KEEP(70).EQ.0)THEN id%KEEP(70)=3 ENDIF IF(id%KEEP(70).EQ.1)THEN id%KEEP(70)=4 ENDIF ENDIF CALL SMUMPS_BUILD_LOAD_MEM_INFO(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%KEEP(70), & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(47), & id%KEEP(81),id%KEEP(76),id%KEEP(215), & id%KEEP(234), id%KEEP(55), id%KEEP(199), & id%PROCNODE_STEPS(1),TEMP_MEM,id%NSLAVES, & SIZE_TEMP_MEM, PEAK,id%KEEP(90),SIZE_DEPTH_FIRST, & SIZE_COST_TRAV,DEPTH_FIRST(1),DEPTH_FIRST_SEQ(1), & COST_TRAV_TMP(1), & TEMP_LEAF,TEMP_SIZE,TEMP_ROOT,SBTR_ID(1) & ) END IF ENDIF IF (id%MYID.EQ.MASTER) THEN CALL SMUMPS_SORT_PERM(id%N, id%NA(1), id%LNA, & id%NE_STEPS(1), id%SYM_PERM(1), & id%FILS(1), id%DAD_STEPS(1), & id%STEP(1), id%KEEP(28), & id%KEEP(60), id%KEEP(20), id%KEEP(38), & id%INFO(1) ) ENDIF C Root principal variable C for scalapack (KEEP(38)) or special serial root (KEEP(20)) C might have been updated C since root variables might have been permuted C and/or expanded (MUMPS_EXPAND_TREE) in case of compressed graph C It should thus be redistributed to all procs IF ( KEEP(494).NE.0 .OR. KEEP(13).NE.0 ) THEN C Value of KEEP(20) and KEEP(38) on master is always correct C + non-zero status is identical on all procs since 110 first C KEEP entries have been broadcasted IF (KEEP(38) .NE. 0) THEN CALL MPI_BCAST( id%KEEP(38), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF IF (KEEP(20) .NE. 0) THEN CALL MPI_BCAST( id%KEEP(20), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF ENDIF 80 CONTINUE C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C --------------------------------------------------- C Broadcast information computed on the master to C the slaves. C The matrix itself with numerical values and C integer data for the arrowhead/element description C will be received at the beginning of FACTO. C --------------------------------------------------- CALL MPI_BCAST( id%NA(1), id%LNA, 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%FILS(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%SYM_PERM(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%STEP(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF(KEEP(494).NE.0) THEN CALL MPI_BCAST( id%LRGROUPS(1), id%KEEP(280), MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF C C Store size of the stack memory for each C of the sequential subtree. IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN IF(associated(id%DEPTH_FIRST)) THEN DEALLOCATE(id%DEPTH_FIRST) ENDIF allocate(id%DEPTH_FIRST(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST' END IF GOTO 87 END IF IF(associated(id%DEPTH_FIRST_SEQ)) THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) ENDIF ALLOCATE(id%DEPTH_FIRST_SEQ(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(associated(id%SBTR_ID)) THEN DEALLOCATE(id%SBTR_ID) ENDIF ALLOCATE(id%SBTR_ID(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(id%MYID.EQ.MASTER)THEN id%DEPTH_FIRST(1:id%KEEP(28))=DEPTH_FIRST(1:id%KEEP(28)) id%DEPTH_FIRST_SEQ(1:id%KEEP(28))= & DEPTH_FIRST_SEQ(1:id%KEEP(28)) id%SBTR_ID(1:KEEP(28))=SBTR_ID(1:KEEP(28)) ENDIF CALL MPI_BCAST( id%DEPTH_FIRST(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%DEPTH_FIRST_SEQ(1), id%KEEP(28), & MPI_INTEGER,MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%SBTR_ID(1), id%KEEP(28), & MPI_INTEGER,MASTER, id%COMM, IERR ) ELSE IF(associated(id%DEPTH_FIRST)) THEN DEALLOCATE(id%DEPTH_FIRST) ENDIF allocate(id%DEPTH_FIRST(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST' END IF GOTO 87 END IF IF(associated(id%DEPTH_FIRST_SEQ)) THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) ENDIF ALLOCATE(id%DEPTH_FIRST_SEQ(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(associated(id%SBTR_ID)) THEN DEALLOCATE(id%SBTR_ID) ENDIF ALLOCATE(id%SBTR_ID(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF id%SBTR_ID(1)=0 id%DEPTH_FIRST(1)=0 id%DEPTH_FIRST_SEQ(1)=0 ENDIF IF(id%KEEP(76).EQ.5)THEN IF(associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) ENDIF allocate(id%COST_TRAV(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%COST_TRAV' END IF INFO(1)= -7 INFO(2)= id%KEEP(28) GOTO 87 END IF IF(id%MYID.EQ.MASTER)THEN id%COST_TRAV(1:id%KEEP(28))= & dble(COST_TRAV_TMP(1:id%KEEP(28))) ENDIF CALL MPI_BCAST( id%COST_TRAV(1), id%KEEP(28), & MPI_DOUBLE_PRECISION,MASTER, id%COMM, IERR ) ELSE IF(associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) ENDIF allocate(id%COST_TRAV(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%COST_TRAV(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF id%COST_TRAV(1)=0.0d0 ENDIF IF (id%KEEP(47) .EQ. 4 .OR. & ((id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN IF(id%MYID .EQ. MASTER)THEN DO K=1,id%NSLAVES DO J=1,SIZE_TEMP_MEM IF(TEMP_MEM(J,K) < 0.0D0) GOTO 666 ENDDO 666 CONTINUE J=J-1 IF (id%KEEP(46) == 1) THEN IDEST = K - 1 ELSE IDEST = K ENDIF IF (IDEST .NE. MASTER) THEN CALL MPI_SEND(J,1,MPI_INTEGER,IDEST,0, & id%COMM,IERR) CALL MPI_SEND(TEMP_MEM(1,K),J,MPI_DOUBLE_PRECISION, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_LEAF(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_SIZE(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_ROOT(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) ELSE IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%NBSA_LOCAL = J id%MEM_SUBTREE(1:J)=TEMP_MEM(1:J,1) IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_ROOT_SBTR(1:J)=TEMP_ROOT(1:J,1) IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_FIRST_LEAF' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_FIRST_LEAF(1:J)=TEMP_LEAF(1:J,1) IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_NB_LEAF' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_NB_LEAF(1:J)=TEMP_SIZE(1:J,1) ENDIF ENDDO ELSE CALL MPI_RECV(id%NBSA_LOCAL,1,MPI_INTEGER, & MASTER,0,id%COMM,STATUS, IERR) IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'MY_FIRST_LEAF' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'MY_NB_LEAF' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF CALL MPI_RECV(id%MEM_SUBTREE(1),id%NBSA_LOCAL, & MPI_DOUBLE_PRECISION,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_FIRST_LEAF(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_NB_LEAF(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_ROOT_SBTR(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) ENDIF ELSE id%NBSA_LOCAL = -999999 IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_FIRST_LEAF(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_NB_LEAF(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF ENDIF IF(id%MYID.EQ.MASTER)THEN IF(IS_BUILD_LOAD_MEM_CALLED)THEN DEALLOCATE(TEMP_MEM) DEALLOCATE(TEMP_SIZE) DEALLOCATE(TEMP_ROOT) DEALLOCATE(TEMP_LEAF) DEALLOCATE(COST_TRAV_TMP) DEALLOCATE(DEPTH_FIRST) DEALLOCATE(DEPTH_FIRST_SEQ) DEALLOCATE(SBTR_ID) ENDIF ENDIF 87 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C NB_NIV2 = KEEP(56) ! KEEP(1:110) was broadcast earlier C NB_NIV2 is now available on all processors. IF ( NB_NIV2.GT.0 ) THEN C Allocate arrays on slaves if (id%MYID.ne.MASTER) then IF (associated(id%CANDIDATES)) THEN DEALLOCATE(id%CANDIDATES) ENDIF allocate(PAR2_NODES(NB_NIV2), & id%CANDIDATES(id%NSLAVES+1,NB_NIV2), & STAT=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= NB_NIV2*(id%NSLAVES+1) IF ( LPOK ) THEN WRITE(LP, 150) 'PAR2_NODES/id%CANDIDATES' END IF end if end if CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL MPI_BCAST(PAR2_NODES(1),NB_NIV2, & MPI_INTEGER, MASTER, id%COMM, IERR ) IF (KEEP(24) .NE.0 ) THEN CALL MPI_BCAST(id%CANDIDATES(1,1), & (NB_NIV2*(id%NSLAVES+1)), & MPI_INTEGER, MASTER, id%COMM, IERR ) ENDIF ENDIF IF ( associated(id%ISTEP_TO_INIV2)) THEN DEALLOCATE(id%ISTEP_TO_INIV2) NULLIFY(id%ISTEP_TO_INIV2) ENDIF IF ( associated(id%I_AM_CAND)) THEN DEALLOCATE(id%I_AM_CAND) NULLIFY(id%I_AM_CAND) ENDIF IF (NB_NIV2.EQ.0) THEN C allocate dummy arrays C ISTEP_TO_INIV2 will never be used C Add a parameter SIZE_ISTEP_TO_INIV2 and make C it always available in a keep(71) id%KEEP(71) = 1 ELSE id%KEEP(71) = id%KEEP(28) ENDIF allocate(id%ISTEP_TO_INIV2(id%KEEP(71)), & id%I_AM_CAND(max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'id%ISTEP_TO_INIV2' WRITE(LP, 150) 'id%TAB_POS_IN_PERE' END IF INFO(1)= -7 IF (NB_NIV2.EQ.0) THEN INFO(2)= 2 ELSE INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2) END IF GOTO 321 ENDIF IF ( NB_NIV2 .GT.0 ) THEN C If BLR grouping was performed then PAR2_NODES(INIV2) C might then point to a non principal variable C for which STEP might be negative C id%ISTEP_TO_INIV2 = -9999 DO INIV2 = 1, NB_NIV2 INN = PAR2_NODES(INIV2) id%ISTEP_TO_INIV2(abs(id%STEP(INN))) = INIV2 END DO CALL SMUMPS_BUILD_I_AM_CAND( id%NSLAVES, KEEP(79), & NB_NIV2, id%MYID_NODES, & id%CANDIDATES(1,1), id%I_AM_CAND(1) ) ENDIF IF ( I_AM_SLAVE ) THEN IF (associated(id%FUTURE_NIV2)) THEN DEALLOCATE(id%FUTURE_NIV2) NULLIFY(id%FUTURE_NIV2) ENDIF allocate(id%FUTURE_NIV2(id%NSLAVES), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'FUTURE_NIV2' END IF INFO(1)= -7 INFO(2)= id%NSLAVES GOTO 321 ENDIF id%FUTURE_NIV2=0 DO INIV2 = 1, NB_NIV2 IDEST = MUMPS_PROCNODE( & id%PROCNODE_STEPS(abs(id%STEP(PAR2_NODES(INIV2)))), & id%KEEP(199)) id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1 ENDDO C Allocate id%TAB_POS_IN_PERE, C TAB_POS_IN_PERE is an array of size (id%NSLAVES+2,NB_NIV2) C where NB_NIV2 is the number of type 2 nodes in the tree. IF ( associated(id%TAB_POS_IN_PERE)) THEN DEALLOCATE(id%TAB_POS_IN_PERE) NULLIFY(id%TAB_POS_IN_PERE) ENDIF allocate(id%TAB_POS_IN_PERE(id%NSLAVES+2,max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'id%ISTEP_TO_INIV2' WRITE(LP, 150) 'id%TAB_POS_IN_PERE' END IF INFO(1)= -7 IF (NB_NIV2.EQ.0) THEN INFO(2)= 2 ELSE INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2) END IF GOTO 321 ENDIF END IF C deallocate PAR2_NODES that was computed C on master and broadcasted on all slaves IF (NB_NIV2.GT.0) DEALLOCATE (PAR2_NODES) 321 CONTINUE C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C IF ( KEEP(38) .NE. 0 ) THEN C ------------------------- C Initialize root structure C ------------------------- CALL SMUMPS_INIT_ROOT_ANA( id%MYID, & id%NSLAVES, id%N, idintr%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 idintr%root%yes = .FALSE. END IF IF ( KEEP(38) .NE. 0 .and. I_AM_SLAVE ) THEN C ----------------------------------------------- C Check if at least one processor belongs to the C root. In the case where all of them have MYROW C equal to -1, this could be a problem due to the C BLACS. (mpxlf90_r and IBM BLACS). C ----------------------------------------------- CALL MPI_ALLREDUCE(idintr%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 ( idintr%root%MYROW .LT. -1 .OR. & idintr%root%MYCOL .LT. -1 ) THEN INFO(1) = -25 INFO(2) = 0 END IF IF ( LPOK .AND. INFO(1) == -25 ) THEN WRITE(LP, '(A)') & 'Problem with your version of the BLACS.' WRITE(LP, '(A)') 'Try using a BLACS version from netlib.' ENDIF END IF C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C C C CALL SMUMPS_ANA_ARROWHEADS_WRAPPER ( id, & GATHER_MATRIX_ALLOCATED ) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL SMUMPS_ANA_COMPUTE_ESTIMATES (id,idintr) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C ------------------------- C Define a specific mapping C for the user C ------------------------- IF ( id%MYID. eq. MASTER .AND. KEEP(54) .eq. 1 ) THEN IF (associated( id%MAPPING)) THEN DEALLOCATE( id%MAPPING) ENDIF allocate( id%MAPPING(id%KEEP8(28)), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28), INFO(2)) IF ( LPOK ) THEN WRITE(LP, 150) 'id%MAPPING' END IF GOTO 92 END IF allocate(IWtemp( id%N ), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-7 INFO(2)=id%N IF ( LPOK ) THEN WRITE(LP, 150) 'IWtemp(N)' END IF GOTO 92 END IF IF ( id%KEEP8(28) .EQ. 0_8 ) THEN IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY ELSE IRN_PTR => id%IRN JCN_PTR => id%JCN ENDIF CALL SMUMPS_BUILD_MAPPING( & id%N, id%MAPPING(1), id%KEEP8(28), & IRN_PTR(1),JCN_PTR(1), id%PROCNODE_STEPS(1), & id%STEP(1), & id%NSLAVES, id%SYM_PERM(1), & id%FILS(1), IWtemp, id%KEEP(1),id%KEEP8(1), & idintr%root%MBLOCK, idintr%root%NBLOCK, & idintr%root%NPROW, idintr%root%NPCOL ) DEALLOCATE( IWtemp ) 92 CONTINUE END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C 500 CONTINUE C Deallocate allocated working space IF (allocated(FILS_TMP)) DEALLOCATE(FILS_TMP) IF (allocated(STEP_TMP)) DEALLOCATE(STEP_TMP) IF (allocated(LRGROUPS_TMP)) DEALLOCATE(LRGROUPS_TMP) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (allocated(WORK2ALLOC)) DEALLOCATE(WORK2ALLOC) IF (KEEP(244).NE.1) THEN IF (allocated(PARAORD_to_idCOMM)) & DEALLOCATE(PARAORD_to_idCOMM) IF (COMM_PARAORD_ALLOCATED) THEN IF (COMM_PARAORD.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_FREE( COMM_PARAORD, IERR ) COMM_PARAORD_ALLOCATED = .FALSE. ENDIF ENDIF IF (COMM_PARASYMB_ALLOCATED) THEN IF (COMM_PARASYMB.NE.MPI_COMM_NULL) THEN CALL MPI_COMM_FREE( COMM_PARASYMB, IERR ) COMM_PARASYMB_ALLOCATED = .FALSE. ENDIF ENDIF ENDIF IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE) IF (allocated(XNODEL)) DEALLOCATE(XNODEL) IF (allocated(NODEL)) DEALLOCATE(NODEL) IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK,KEEP(147)) CALL MUMPS_AB_FREE_LMAT(LUMAT,KEEP(147)) CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP,KEEP(147)) CALL MUMPS_AB_FREE_GCOMP(GCOMP, MEMCNT) CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST, MEMCNT) C Standard deallocations (error or not) IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR) IF (associated(FREREPTR)) DEALLOCATE(FREREPTR) nullify(FREREPTR, NFSIZPTR) IF (associated(BLKPTR_PTRLOC).AND.BLKPTR_ALLOCATED) THEN DEALLOCATE(BLKPTR_PTRLOC) nullify(BLKPTR_PTRLOC) ENDIF IF (associated(BLKVAR_PTRLOC).AND.BLKVAR_ALLOCATED) THEN DEALLOCATE(BLKVAR_PTRLOC) nullify(BLKVAR_PTRLOC) ENDIF KEEP8(26)=max(1_8,KEEP8(26)) KEEP8(27)=max(1_8,KEEP8(27)) RETURN 110 FORMAT(/' ****** ANALYSIS STEP ********'/) 145 FORMAT(' ELAPSED TIME SPENT IN BLR CLUSTERING =',F12.4) 150 FORMAT( & /' ** FAILURE DURING SMUMPS_ANA_DRIVER, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE SMUMPS_ANA_DRIVER SUBROUTINE SMUMPS_ANA_CHECK_KEEP(id, I_AM_SLAVE) !$ USE OMP_LIB, ONLY : omp_get_max_threads C C Purpose C ======= C This subroutine decodes the control parameters, C stores them in the KEEP array, and performs a C consistency check on the KEEP array. USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id LOGICAL :: I_AM_SLAVE C internal variables INTEGER :: LP, MP, MPG, I INTEGER :: MASTER LOGICAL :: PROK, PROKG, LPOK PARAMETER( MASTER = 0 ) C LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) C Re-intialize few KEEPs entries corresponding C to stat that are incremented such C the number of split nodes: id%KEEP(61)=0 IF (id%MYID.eq.MASTER) THEN id%KEEP(38) = 0 id%KEEP(20) = 0 CALL SMUMPS_ANA_CHECK_ICNTL48 ( id ) id%KEEP(256) = id%ICNTL(7) ! copy ordering option id%KEEP(252) = id%ICNTL(32) IF (id%KEEP(252) < 0 .OR. id%KEEP(252) > 1 ) THEN id%KEEP(252) = 0 ENDIF C Which factors to store id%KEEP(251) = id%ICNTL(31) IF (id%KEEP(251) < 0 .OR. id%KEEP(251) > 2 ) THEN id%KEEP(251)=0 ENDIF C For unsymmetric matrices, if forward solve C performed during facto, C no reason to store L factors at all. Reset C KEEP(251) accordingly... except if the user C tells that no solve is needed. IF (id%KEEP(50) .EQ. 0 .AND. id%KEEP(252).EQ.1) THEN IF (id%KEEP(251) .NE. 1) id%KEEP(251) = 2 ENDIF C Symmetric case, even if no backward needed, C store all factors IF (id%KEEP(50) .NE.0 .AND. id%KEEP(251) .EQ. 2) THEN id%KEEP(251) = 0 ENDIF C Case of solve not needed: IF (id%KEEP(251) .EQ. 1) THEN id%KEEP(201) = -1 C In that case, id%ICNTL(22) will C be ignored in future phases ELSE C Reset id%KEEP(201) -- typically for the case C of a previous analysis with KEEP(201)=-1 id%KEEP(201) = 0 ENDIF IF (id%KEEP(252).EQ.1) THEN id%KEEP(253) = id%NRHS IF (id%KEEP(253) .LE. 0) THEN id%INFO(1)=-42 id%INFO(2)=id%NRHS RETURN ENDIF ELSE id%KEEP(253) = 0 ENDIF ENDIF IF ( (id%KEEP(24).NE.0) .AND. & id%NSLAVES.eq.1 ) THEN id%KEEP(24) = 0 END IF IF ( (id%KEEP(24).EQ.0) .AND. & id%NSLAVES.GT.1 ) THEN id%KEEP(24) = 8 ENDIF IF ( (id%KEEP(24).NE.0) .AND. (id%KEEP(24).NE.1) .AND. & (id%KEEP(24).NE.8) .AND. (id%KEEP(24).NE.10) .AND. & (id%KEEP(24).NE.12) .AND. (id%KEEP(24).NE.14) .AND. & (id%KEEP(24).NE.16) .AND. (id%KEEP(24).NE.18)) THEN id%KEEP(24) = 8 END IF C**************************************************** C C The master is doing most of the work C C NOTE: Treatment of the errors on the master= C Go to the next SPMD part of the code in which C the first statement must be a call to PROPINFO C C**************************************************** C ========================================= C Check (raise error or modify) some input C parameters or KEEP values on the master. C ========================================= id%KEEP8(21) = int(id%KEEP(85),8) IF ( id%MYID .EQ. MASTER ) THEN C ---------------------------- C Save id%ICNTL(18) (distributed C matrix on entry) in id%KEEP(54) C ---------------------------- id%KEEP(54) = id%ICNTL(18) IF ( id%KEEP(54) .LT. 0 .or. id%KEEP(54).GT.3 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Out-of-range value for id%ICNTL(18).' WRITE(MPG, *) ' Used 0 ie matrix not distributed' END IF id%KEEP(54) = 0 END IF IF ( id%KEEP(54) .EQ. 1 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Option id%ICNTL(18)=1 is obsolete.' WRITE(MPG, *) ' We recommend not to use it.' WRITE(MPG, *) ' It will disappear in a future release' END IF END IF C ----------------------------------------- C Save id%ICNTL(5) (matrix format) in id%KEEP(55) C ----------------------------------------- id%KEEP(55) = id%ICNTL(5) IF ( id%KEEP(55) .LT. 0 .OR. id%KEEP(55) .GT. 1 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Out-of-range value for id%ICNTL(5).' WRITE(MPG, *) ' Used 0 ie matrix is assembled' END IF id%KEEP(55) = 0 END IF id%KEEP(60) = id%ICNTL(19) IF ( id%KEEP( 60 ) .LE. 0 ) id%KEEP( 60 ) = 0 IF ( id%KEEP( 60 ) .GT. 3 ) id%KEEP( 60 ) = 0 IF (id%KEEP(60) .NE. 0 .AND. id%SIZE_SCHUR == 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Schur option ignored because SIZE_SCHUR=0' ENDIF id%KEEP(60)=0 END IF C --------------------------------------- C Save SIZE_SCHUR in a KEEP, for possible C check at factorization and solve phases C --------------------------------------- IF ( id%KEEP(60) .NE.0 ) THEN id%KEEP(116) = id%SIZE_SCHUR IF (id%SIZE_SCHUR .LT. 0 .OR. id%SIZE_SCHUR .GE. id%N) THEN id%INFO(1)=-49 id%INFO(2)=id%SIZE_SCHUR RETURN ENDIF C List of Schur variables provided by user. IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 8 RETURN ELSE IF (size(id%LISTVAR_SCHUR) 0 .AND. id%NBLOCK > 0 .AND. & id%NPROW > 0 .AND. id%NPCOL > 0 ) THEN IF (id%NPROW *id%NPCOL .LE. id%NSLAVES) THEN C We will eventually have to "symmetrize the C Schur complement. For that NBLOCK and MBLOCK C must be equal. IF (id%MBLOCK .NE. id%NBLOCK ) THEN id%INFO(1)=-31 id%INFO(2)=id%MBLOCK - id%NBLOCK RETURN ENDIF ENDIF ENDIF ENDIF C Check the ordering strategy and compatibility with C other control parameters id%KEEP(244) = id%ICNTL(28) IF ((id%KEEP(244) .LT. 0) .OR. (id%KEEP(244) .GT. 2)) THEN id%KEEP(244) = 0 ENDIF IF(id%KEEP(244) .EQ. 0) THEN ! Automatic C One could check for availability of parallel ordering C tools, or for possible options incompatible with // C analysis to decide (e.g. avoid returning an error if C // analysis not compatible with some option but user C lets MUMPS decide to choose sequential or paralllel C analysis) C Current strategy for automatic is sequential analysis id%KEEP(244) = 1 ENDIF #if ! defined (ptscotch) && ! defined(parmetis) && ! defined(parmetis3) IF (id%KEEP(244) .EQ. 2) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("ParMETIS and PT-SCOTCH not available.")') END IF RETURN END IF #endif id%KEEP(245) = id%ICNTL(29) IF ((id%KEEP(245) .LT. 0) .OR. (id%KEEP(245) .GT. 2)) THEN id%KEEP(245) = 0 END IF IF (id%KEEP(244) .EQ. 2) THEN IF ( id%KEEP(245).EQ.0 ) THEN #if defined(parmetis) || defined(parmetis3) id%KEEP(245) = 2 #elif defined(ptscotch) id%KEEP(245) = 1 #endif ENDIF ENDIF C #if ! defined(parmetis) && ! defined(parmetis3) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 2)) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("ParMETIS not available.")') END IF RETURN END IF #endif #if ! defined(ptscotch) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 1)) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("PT-SCOTCH not available.")') END IF RETURN END IF #endif IF (id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(55) .NE. 0) THEN id%INFO(1) = -39 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(5), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if the")') WRITE(LP, & '("matrix is not assembled")') ENDIF RETURN ELSE IF(id%KEEP(60) .NE. 0) THEN id%INFO(1) = -39 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(19), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if SCHUR")') WRITE(LP, & '("complement must be returned")') ENDIF RETURN END IF C In the case where there are too few processes to do C the parallel analysis we simply revert to sequential version IF(id%NSLAVES .LT. 2) THEN id%KEEP(244) = 1 IF(PROKG) WRITE(MPG, & '("Too few processes. & Reverting to sequential analysis")',advance='no') IF(id%KEEP(245) .EQ. 1) THEN C Scotch necessarily available because pt-scotch C is, otherwise an error would have occurred IF(PROKG) WRITE(MPG, '(" with SCOTCH.")') id%KEEP(256) = 3 ELSE IF(id%KEEP(245) .EQ. 2) THEN C Metis necessarily available because parmetis C is, otherwise an error would have occurred IF(PROKG) WRITE(MPG, '(" with Metis.")') id%KEEP(256) = 5 ELSE IF(PROKG) WRITE(MPG, '(".")') id%KEEP(256) = 7 END IF END IF C In the case where there the input matrix is too small to do C the parallel analysis we simply revert to sequential version IF(id%N .LE. 50) THEN id%KEEP(244) = 1 IF(PROKG) WRITE(MPG, & '("Input matrix is too small for the parallel & analysis. Reverting to sequential analysis")',advance='no') IF(id%KEEP(245) .EQ. 1) THEN IF(PROKG) WRITE(MPG, '(" with SCOTCH.")') id%KEEP(256) = 3 ELSE IF(id%KEEP(245) .EQ. 2) THEN IF(PROKG) WRITE(MPG, '(" with Metis.")') id%KEEP(256) = 5 ELSE IF(PROKG) WRITE(MPG, '(".")') id%KEEP(256) = 7 END IF END IF END IF id%INFOG(32) = id%KEEP(244) IF ( (id%KEEP(244) .EQ. 1) .AND. & (id%KEEP(256) .EQ. 1) ) THEN C ordering given, PERM_IN must be of size N IF ( .NOT. associated( id%PERM_IN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 3 RETURN ELSE IF ( size( id%PERM_IN ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 3 RETURN END IF ENDIF C Check KEEP(9-10) for level 2 IF (id%KEEP(9) .LE. 1 ) id%KEEP(9) = 500 IF ( id%KEEP8(21) .GT. 0_8 ) THEN IF ((id%KEEP8(21).LE.1_8) .OR. & (id%KEEP8(21).GT.int(id%KEEP(9),8))) & id%KEEP8(21) = int(min(id%KEEP(9),100),8) ENDIF C IF (id%KEEP(48). EQ. 1 ) id%KEEP(48) = -12345 C IF ( (id%KEEP(48).LT.0) .OR. (id%KEEP(48).GT.5) ) THEN id%KEEP(48)=5 ENDIF C Schur C Given ordering must be compatible with Schur variables. IF ( (id%KEEP(60) .NE. 0) .AND. (id%KEEP(256) .EQ. 1) ) THEN DO I = 1, id%SIZE_SCHUR IF (id%PERM_IN(id%LISTVAR_SCHUR(I)) & .EQ. id%N-id%SIZE_SCHUR+I) & CYCLE C ------------------------------- C Problem with PERM_IN: -22/3 C Above constrained explained in C doc of PERM_IN in user guide. C ------------------------------- id%INFO(1) = -4 id%INFO(2) = id%LISTVAR_SCHUR(I) RETURN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Ignoring user-ordering, because incompatible with Schur.' WRITE(MPG,'(A)') ' ** id%ICNTL(7) treated as 0.' END IF EXIT ENDDO END IF C C Note that schur is not compatible with C C 1/Max-trans DONE C 2/Null space C 3/Ordering given DONE C 4/Scaling C 5/Iterative Refinement C 6/Error analysis C 7/Parallel Analysis C C Graph modification prior to ordering (id%ICNTL(12) option) C id%KEEP (95) will hold the eventually modified value of id%ICNTL(12) C id%KEEP(95) = id%ICNTL(12) C reset to usual ordering (KEEP(95)=1) C - when matrix is not general symmetric C - for out-of-range values IF (id%KEEP(50).NE.2) id%KEEP(95) = 1 IF ((id%KEEP(95).GT.3).OR.(id%KEEP(95).LT.0)) id%KEEP(95) = 1 C MAX-TRANS C C id%KEEP (23) will hold the eventually modified value of id%ICNTL(6) C (maximum transversal if >= 1) C id%KEEP(23) = id%ICNTL(6) C C C -------------------------------------------- C Avoid max-trans unsymmetric permutation in case of C matrix is symmetric with SYM=1 or C ordering is given, C or matrix is in element form, or Schur is asked C or initial matrix is distributed C -------------------------------------------- IF (id%KEEP(23).LT.0.OR.id%KEEP(23).GT.7) id%KEEP(23) = 0 C still forbid max trans for SYM=1 case IF ( id%KEEP(50) .EQ. 1 ) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not needed with SYM=1 factorization' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(95) .GT. 1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) ignored: not needed with SYM=1 factorization' END IF ENDIF id%KEEP(95) = 1 END IF C IF (id%KEEP(60) .GT. 0) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not allowed because of Schur' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Scaling during analysis not allowed because of Schur' ENDIF id%KEEP(52) = 0 ENDIF C also forbid compressed/constrained ordering... IF (id%KEEP(95) .GT. 1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) option not allowed because of Schur' END IF ENDIF id%KEEP(95) = 1 END IF IF ( (id%KEEP(23) .NE. 0) .AND. (id%KEEP(256).EQ.1)) THEN id%KEEP(23) = 0 IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'because ordering is given' END IF END IF IF ( id%KEEP(256) .EQ. 1 ) THEN IF (id%KEEP(95) > 1 .AND. PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) option incompatible with given ordering' END IF id%KEEP(95) = 1 END IF IF (id%KEEP(54) .NE. 0) THEN IF( id%KEEP(23) .NE. 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'because matrix is distributed' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Scaling (ICNTL(8)) during analysis not ', & 'allowed because matrix is distributed)' ENDIF ENDIF id%KEEP(52) = 0 IF (id%KEEP(95) .GT. 1 .AND. MPG.GT.0) THEN WRITE(MPG,'(A,A)') & ' ** ICNTL(12) option not allowed because matrix is ', & 'distributed' ENDIF id%KEEP(95) = 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN IF( id%KEEP(23) .NE. 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'for matrices in elemental format' END IF id%KEEP(23) = 0 ENDIF IF (PROKG .AND. id%KEEP(52).EQ.-2) THEN WRITE(MPG,'(A)') & ' ** Scaling (ICNTL(8)) not allowed ', & 'for matrices in elemental format' ENDIF id%KEEP(52) = 0 id%KEEP(95) = 1 ENDIF C In the case where parallel analysis is done, column permutation C is not allowed IF(id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(23) .EQ. 7) THEN C Automatic hoice: set it to 0 id%KEEP(23) = 0 ELSE IF (id%KEEP(23) .GT. 0) THEN id%INFO(1) = -39 id%KEEP(23) = 0 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(6), ICNTL(28)")') WRITE(LP, & '("Maximum transversal not allowed & in parallel analysis")') ENDIF RETURN END IF END IF C -------------------------------------------- C Avoid distributed entry for element matrix. C -------------------------------------------- IF ( id%KEEP(54) .NE. 0 .AND. id%KEEP(55) .NE. 0 ) THEN id%KEEP(54) = 0 IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Distributed entry not available for element matrix' END IF ENDIF C ---------------------------------- C Choice of symbolic analysis option C ---------------------------------- IF (id%ICNTL(58).NE.1 .and. id%ICNTL(58).NE.2 & .and. id%ICNTL(58).NE.3 .and. id%ICNTL(58).NE.4 ) THEN C out of range values leads to default id%KEEP(106)=2 ELSE id%KEEP(106)=id%ICNTL(58) C Options 3 and 4 not available, reset to default IF (id%KEEP(106).EQ.4) id%KEEP(106)=2 IF (id%KEEP(106).EQ.3) id%KEEP(106)=2 ENDIF C modify input parameters to avoid incompatible C input data between ordering, scaling and maxtrans C note that if id%ICNTL(12)/id%KEEP(95) = 0 then C the automatic choice will be done in ANA_O IF(id%KEEP(50) .EQ. 2) THEN C LDLT case IF( .NOT. associated(id%A) ) THEN C constraint ordering can be computed only if values are C given to analysis IF(id%KEEP(95) .EQ. 3) THEN id%KEEP(95) = 2 ENDIF ENDIF IF(id%KEEP(95) .EQ. 3 .AND. id%KEEP(256) .NE. 2) THEN C if constraint and ordering is not AMF then use compress IF (PROK) WRITE(MP,*) & 'WARNING: SMUMPS_ANA_O constrained ordering not ', & 'available with selected ordering' id%KEEP(95) = 2 ENDIF IF(id%KEEP(95) .EQ. 3) THEN C if constraint ordering required then we need to compute scaling C and max trans C NOTE that if we enter this condition then C id%A is associated because of the test above: C (IF( .NOT. associated(id%A) ) THEN) id%KEEP(23) = 5 id%KEEP(52) = -2 ELSE IF(id%KEEP(95) .EQ. 2 .AND. & (id%KEEP(23) .EQ. 0 .OR. id%KEEP(23) .EQ. 7) ) THEN C compressed ordering requires max trans but not necessary scaling IF( associated(id%A) ) THEN id%KEEP(23) = 5 ELSE C we can do compressed ordering without C information on the numerical values: C a maximum transversal already provides C information on the location of off-diagonal C nonzeros which can be candidates for 2x2 C pivots id%KEEP(23) = 1 ENDIF ELSE IF(id%KEEP(95) .EQ. 1) THEN id%KEEP(23) = 0 ELSE IF(id%KEEP(95) .EQ. 0 .AND. id%KEEP(23) .EQ. 0) THEN C if max trans desactivated then the automatic choice for type of ord C is set to 1, which means that we will use usual ordering C (no constraints or compression) id%KEEP(95) = 1 ENDIF ELSE id%KEEP(95) = 1 ENDIF C -------------------------------- C Save ICNTL(56) (QR) in KEEP(53) C Will be broadcasted to all other C nodes in routine SMUMPS_BDCAST C -------------------------------- id%KEEP(53) = id%ICNTL(56) C --------------------------- C Possible values are 0..2 C Other values are treated as 0 C ------------------------------ IF ( id%KEEP(53) .LT. 0 .OR. & id%KEEP(53) .GE. 2 & ) THEN id%KEEP(53) = 0 IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(56) treated as if set to 0 ' END IF IF(id%KEEP(86).EQ.1)THEN C Force the exchange of both the memory and flops information during C the factorization IF(id%KEEP(47).LT.2) id%KEEP(47)=2 ENDIF IF(id%KEEP(48).EQ.5)THEN IF(id%KEEP(50).EQ.0)THEN id%KEEP(87)=50 id%KEEP(88)=50 ELSE id%KEEP(87)=70 id%KEEP(88)=70 ENDIF ENDIF IF((id%NSLAVES.EQ.1).AND.(id%KEEP(76).GT.3))THEN id%KEEP(76)=2 ENDIF IF(id%KEEP(81).GT.0)THEN IF(id%KEEP(47).LT.2) id%KEEP(47)=2 ENDIF C C -- Save Block Low Rank input parameter id%KEEP(494) = id%ICNTL(35) IF (id%KEEP(494).EQ.1) THEN C -- Automatic BLR option setting id%KEEP(494)= 2 ENDIF IF ( id%KEEP(494).EQ.4) id%KEEP(494)=0 IF ((id%KEEP(494).LT.0).OR.(id%KEEP(494).GT.4)) THEN C Out of range values treated as 0 id%KEEP(494) = 0 ENDIF IF(id%KEEP(494).NE.0) THEN C test BLR incompatibilities C id%KEEP(464) = id%ICNTL(38) IF (id%KEEP(464).LT.0.OR.(id%KEEP(464).GT.1000)) THEN C Out of range values treated as 0 id%KEEP(464) = 0 ENDIF id%KEEP(465) = id%ICNTL(39) IF (id%KEEP(465).LT.0.OR.(id%KEEP(465).GT.1000)) THEN C Out of range values treated as 0 id%KEEP(465) = 0 ENDIF C LR is incompatible with elemental matrices, forbid it at analysis IF (id%KEEP(55).NE.0) THEN IF (LPOK) WRITE(LP,*) & " *** BLR feature currently incompatible " & ,"with elemental matrices" C BLR for elt entry might be developed in the future id%INFO(1)=-800 id%INFO(2)=5 RETURN ENDIF C C LR incompatible with forward in facto IF (id%KEEP(252).NE.0) THEN IF (LPOK) WRITE(LP,*) & " *** BLR feature currently incompatible" & ," with forward during factorization" id%INFO(1) = -43 id%INFO(2) = 35 RETURN ENDIF C ENDIF C IF(id%KEEP(494).NE.0) THEN C id%KEEP(469)=0,1,2,3,4 IF ((id%KEEP(469).GT.4).OR.(id%KEEP(469).LT.0)) THEN id%KEEP(469)=0 ENDIF C Not implemented yet IF (id%KEEP(469).EQ.4) id%KEEP(469)=0 C id%KEEP(471)=-1,0,1 IF ((id%KEEP(471).LT.-1).AND.(id%KEEP(471).GT.1)) THEN id%KEEP(471)=-1 ENDIF C id%KEEP(472)=0 or 1 IF ((id%KEEP(472).NE.0).AND.(id%KEEP(472).NE.1)) THEN id%KEEP(472)=1 ENDIF C id%KEEP(475)=0,1,2,3 IF ((id%KEEP(475).GT.3).OR.(id%KEEP(475).LT.0)) THEN id%KEEP(475)=0 ENDIF C id%KEEP(482)=0,1,2,3 IF ((id%KEEP(482).GT.3).OR.(id%KEEP(482).LT.0)) THEN id%KEEP(482)=0 ENDIF IF((id%KEEP(487).LT.0)) THEN id%KEEP(487)= 2 ! default value ENDIF C id%KEEP(488)>0 IF((id%KEEP(488).LE.0)) THEN id%KEEP(488)= 8*id%KEEP(6) ENDIF C id%KEEP(490)>0 IF((id%KEEP(490).LE.0)) THEN id%KEEP(490) = 128 ENDIF C KEEP(491)>0 IF((id%KEEP(491).LE.0)) THEN id%KEEP(491) = 1000 ENDIF ENDIF C id%KEEP(13) = 0 id%KEEP(14) = 0 C Analysis by Blocks id%KEEP(13) = id%ICNTL(15) IF (id%KEEP(13).GT.1) THEN CV0 out-of range values id%KEEP(13) = 0 ENDIF IF (id%KEEP(13).EQ.1) THEN C{ Analysis by block with block data provided by user C check input data IF ( .NOT.associated(id%BLKPTR)) THEN C BLKPTR provided by user IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " id%BLKPTR should be provided by user on host " ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ELSE IF ( (id%NBLK.LE.0).OR.(id%NBLK.GT.id%N) & .OR. (id%NBLK+1.NE.size(id%BLKPTR)) & ) THEN C id%NBLK out of range IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ERROR incorrect value of id%NBLK:", id%NBLK ENDIF id%INFO(1) = -57 id%INFO(2) = 1 ELSE IF (id%BLKPTR(id%NBLK+1)-1.NE.id%N) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR id%BLKPTR(id%NBLK+1)-1 ", & "should be equal to id%N instead of ", & id%BLKPTR(id%NBLK+1)-1 ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ELSE IF (id%BLKPTR(1).NE.1) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR id%BLKPTR(1)", & "should be equal to 1 instead of ", & id%BLKPTR(1) ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ELSE IF (associated(id%BLKVAR)) THEN C id%BLKVAR IF (size(id%BLKVAR).NE.id%N) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR with centralized matrix. Size of id%BLKVAR ", & "should be equal to id%N instead of ", & size(id%BLKVAR) ENDIF id%INFO(1) = -57 id%INFO(2) = 3 ENDIF ENDIF C} ENDIF IF (id%KEEP(13).LT.0) THEN C note that id%BLKPTR might still be associated C but will not be used IF (mod(id%N,-id%KEEP(13)) .NE.0) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ICNTL(15)=", id%ICNTL(15), & " is incompatible with N=", id%N ENDIF id%INFO(1) = -57 id%INFO(2) = 1 ENDIF ENDIF IF (id%KEEP(13).EQ.0) THEN IF ( & ((id%KEEP(54).EQ.3).AND.(id%KEEP(244).EQ.1)) & .OR. & ((id%KEEP(244).EQ.2).AND.(id%KEEP(339).NE.0)) & ) THEN id%KEEP(13)=-1 ENDIF C unsymmetric assembled matrices with or without BLR, C also in case of centralized matrix (if C matrix is distributed, then KEEP(13) has C been set to -1 in the block above) IF (id%KEEP(50).EQ.0.AND. id%KEEP(55).EQ.0) THEN C Respect decision taken for Maxtrans C since it will be switch off C if one activates the analysis by block IF ( (id%KEEP(23).LE.0) .OR. (id%KEEP(23).GT.7) & ) THEN id%KEEP(13)=-1 ENDIF ENDIF ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(55).NE.0) & ) THEN IF (PROKG.AND.(id%KEEP(13).NE.-1)) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with elemental matrices" C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(106).NE.1).AND. (id%KEEP(106).NE.2) & ) THEN IF (PROKG.AND.(id%KEEP(13).NE.-1)) WRITE(MPG,'(A,A,I4)') & " ** Analysis by block not compatible ", & "with symbolic factorization option ", & id%KEEP(106) C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. (id%KEEP(244) .EQ. 2) .AND. & (id%KEEP(339).EQ.0) & ) THEN IF (PROKG.AND.(id%KEEP(13).NE.-1)) WRITE(MPG,'(A)') & " ** Analysis by block switched off " C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(60).NE.0) & ) THEN IF (PROKG.AND.(id%KEEP(13).NE.-1)) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with Schur " C switch off analysis by block id%KEEP(13)= 0 ENDIF IF (id%KEEP(13).NE.0) THEN C Maximum transversal not compatible with analysis by block IF (id%KEEP(23).NE.0) THEN C in case of automatic choice (id%KEEP(27).EQ.7) C do not print message IF (PROKG.AND.id%KEEP(23).NE.7) WRITE(MPG,'(A,A)') & " ** Maximum transversal (ICNTL(6)) ", & "not compatible with analysis by block" C switch off max transversal id%KEEP(23)= 0 ENDIF C - compression for LDLT IF (id%KEEP(95).NE.1) THEN C in case of automatic choice (id%KEEP(95).EQ.0) C do not print message IF (PROKG.AND.id%KEEP(95).NE.0) WRITE(MPG,'(A,A)') & " ** ICNTL(12) not compatible with ", & " analysis by block" C switch off 2x2 preprocessing for symmetric matrices id%KEEP(95) = 1 ENDIF ENDIF C C end id%MYID.EQ.MASTER END IF RETURN END SUBROUTINE SMUMPS_ANA_CHECK_KEEP C ======================================== SUBROUTINE SMUMPS_ANA_CHECK_ICNTL48 (id ) !$ USE OMP_LIB, ONLY : omp_get_max_threads USE SMUMPS_STRUC_DEF C IMPLICIT NONE C C Purpose C ======= C This subroutine performed part of SMUMPS_ANA_CHECK_KEEP concerned by ICNTL(48) C and is called by SMUMPS_ANA_CHECK_KEEP and SMUMPS_ANA_REDO_STAT C C Parameters C TYPE(SMUMPS_STRUC) :: id C C Local variables C INTEGER :: LP, MP, MPG, NOMP INTEGER :: MASTER LOGICAL :: PROK, PROKG, LPOK LOGICAL :: I_AM_SLAVE PARAMETER( MASTER = 0 ) C LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (id%MYID.eq.MASTER) THEN C C L0-OMP settings of KEEP(400) C id%KEEP(401) = 0 NOMP = 0 IF (id%ICNTL(48).EQ.1) id%KEEP(401)=1 IF (id%KEEP(401) .GT. 0) THEN !$ NOMP=omp_get_max_threads() IF ( NOMP .EQ. 0 ) THEN C Compilation without OMP! id%KEEP(400) = 0 id%INFO(1)=-58 id%INFO(2)=0 IF (LPOK) WRITE(LP,'(A)') & " FAILURE DETECTED IN ANALYSIS: ICNTL(48) requires OpenMP" RETURN ENDIF ENDIF C ENDIF RETURN END SUBROUTINE SMUMPS_ANA_CHECK_ICNTL48 C SUBROUTINE SMUMPS_GATHER_MATRIX(id) C This subroutine gathers a distributed matrix C on the host node USE SMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) TYPE(SMUMPS_STRUC) :: id C local variables INTEGER, ALLOCATABLE :: REQPTR(:,:) INTEGER(8), ALLOCATABLE :: MATPTR(:) INTEGER(8), ALLOCATABLE :: MATPTR_cp(:) INTEGER(8) :: IBEG8, IEND8 INTEGER :: INDX INTEGER :: LP, MP, MPG, I, K INTEGER(8) :: I8 LOGICAL :: PROKG C C messages are split into blocks of size BLOCKSIZE C (smaller than IOVFLO (=2^31-1)) C on all processors INTEGER(4) :: IOVFLO INTEGER :: BLOCKSIZE INTEGER :: MAX_NBBLOCK_loc, NBBLOCK_loc INTEGER :: SIZE_SENT, NRECV LOGICAL :: OMP_FLAG INTEGER(8) :: NZ_loc8 C for validation only: INTEGER :: NB_BLOCKS, NB_BLOCK_SENT LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) C iovflo = huge(INTEGER, kind=4) IOVFLO = huge(IOVFLO) C we do not want too large messages BLOCKSIZE = int(max(100000_8,int(IOVFLO,8)/200_8)) IF ( id%KEEP(46) .EQ. 0 .AND. id%MYID .EQ. MASTER ) THEN C host-node mode: master has no entries. id%KEEP8(29) = 0_8 END IF IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------- C Allocate small arrays for pointers C into arrays IRN/JCN C ----------------------------------- ALLOCATE( MATPTR( id%NPROCS ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) ' array MATPTR' END IF GOTO 13 END IF ALLOCATE( MATPTR_cp( id%NPROCS ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) ' array MATPTR' END IF GOTO 13 END IF C ----------------------------------- C Allocate a small array for requests C ----------------------------------- ALLOCATE( REQPTR( id%NPROCS-1, 2 ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = 2 * (id%NPROCS-1) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array REQPTR' END IF GOTO 13 END IF C -------------------- C Allocate now IRN/JCN C -------------------- ALLOCATE( id%IRN( id%KEEP8(28) ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2)) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array IRN' END IF GOTO 13 END IF ALLOCATE( id%JCN( id%KEEP8(28) ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2)) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array JCN' END IF GOTO 13 END IF END IF 13 CONTINUE C Propagate errors CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) < 0 ) RETURN C ------------------------------------- C Get numbers of non-zeros for everyone C and count total and maximum C nb of blocks of size BLOCKSIZE C that slaves will sent C ------------------------------------- IF ( id%MYID .EQ. MASTER ) THEN C each block will correspond to 2 messages (IRN_LOC,JCN_LOC) NB_BLOCK_SENT = 0 MAX_NBBLOCK_loc = 0 DO I = 1, id%NPROCS - 1 CALL MPI_RECV( MATPTR( I+1 ), 1, & MPI_INTEGER8, I, & COLLECT_NZ, id%COMM, STATUS, IERR ) NBBLOCK_loc = ceiling(dble(MATPTR(I+1))/dble(BLOCKSIZE)) MAX_NBBLOCK_loc = max(MAX_NBBLOCK_loc, NBBLOCK_loc) NB_BLOCK_SENT = NB_BLOCK_SENT + NBBLOCK_loc END DO IF ( id%KEEP(46) .eq. 0 ) THEN MATPTR( 1 ) = 1_8 ELSE NZ_loc8=id%KEEP8(29) MATPTR( 1 ) = NZ_loc8 + 1_8 END IF C -------------- C Build pointers C -------------- DO I = 2, id%NPROCS MATPTR( I ) = MATPTR( I ) + MATPTR( I-1 ) END DO ELSE NZ_loc8=id%KEEP8(29) CALL MPI_SEND( NZ_loc8, 1, MPI_INTEGER8, MASTER, & COLLECT_NZ, id%COMM, IERR ) END IF IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------------------- C Bottleneck is here master; use synchronous send C for slaves, but asynchronous receives on master C Then while master receives indices do the local C copies for better overlap. C (If master has other things to do, he could try C to do them here.) C ------------------------------------ C copy pointers to position in IRN/JCN MATPTR_cp = MATPTR IF ( id%KEEP8(29) .NE. 0_8 ) THEN OMP_FLAG = ( id%KEEP8(29).GE.50000_8 ) !$OMP PARALLEL DO PRIVATE(I8) !$OMP& IF(OMP_FLAG) DO I8=1,id%KEEP8(29) id%IRN(I8) = id%IRN_loc(I8) id%JCN(I8) = id%JCN_loc(I8) ENDDO !$OMP END PARALLEL DO ENDIF C C Compute position for each block to be received C and store it. NB_BLOCKS = 0 C at least one slave will send MAX_NBBLOCK_loc C couple of messages (IRN_loc/JCN_loc) DO K = 1, MAX_NBBLOCK_loc C Post irecv for all messages from proc I C that have been sent NRECV = 0 DO I = 1, id%NPROCS - 1 C Check if message was sent IBEG8 = MATPTR_cp( I ) IF ( IBEG8 .LT. MATPTR(I+1)) THEN C Count number of request in NRECV NRECV = NRECV + 2 IEND8 = min(IBEG8+int(BLOCKSIZE,8)-1_8, & MATPTR(I+1)-1_8) C update pointer for receiving messages C from proc I in MATPTR_cp: MATPTR_cp( I ) = IEND8 + 1_8 SIZE_SENT = int(IEND8 - IBEG8 + 1_8) NB_BLOCKS = NB_BLOCKS + 1 C CALL MPI_IRECV( id%IRN(IBEG8), SIZE_SENT, MPI_INTEGER, & I, COLLECT_IRN, id%COMM, REQPTR(I,1), IERR ) C CALL MPI_IRECV( id%JCN(IBEG8), SIZE_SENT, MPI_INTEGER, & I, COLLECT_JCN, id%COMM, REQPTR(I,2), IERR ) ELSE REQPTR( I,1 ) = MPI_REQUEST_NULL REQPTR( I,2 ) = MPI_REQUEST_NULL ENDIF END DO C Wait set of messages corresponding to current block C ( we dont exploit the fact that C messages are not overtaking C (if sent by one source to the same destination) ) C C Loop on only non MPI_REQUEST_NULL requests DO I = 1, NRECV CALL MPI_WAITANY & ( 2 * (id%NPROCS-1), REQPTR( 1, 1 ), INDX, & STATUS, IERR ) ENDDO C C process next block END DO DEALLOCATE( REQPTR ) DEALLOCATE( MATPTR ) DEALLOCATE( MATPTR_cp ) C end of reception by master ELSE C ----------------------------- C Send only if size is not zero C ----------------------------- IF ( id%KEEP8(29) .NE. 0_8 ) THEN NZ_loc8=id%KEEP8(29) C send by blocks of size BLOCKSIZE DO I8=1_8, NZ_loc8, int(BLOCKSIZE,8) SIZE_SENT = BLOCKSIZE IF (NZ_loc8-I8+1_8.LT.int(BLOCKSIZE,8)) THEN SIZE_SENT = int(NZ_loc8-I8+1_8) ENDIF CALL MPI_SEND( id%IRN_loc(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & COLLECT_IRN, id%COMM, IERR ) CALL MPI_SEND( id%JCN_loc(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & COLLECT_JCN, id%COMM, IERR ) END DO END IF END IF RETURN 150 FORMAT( &/' ** FAILURE DURING SMUMPS_GATHER_MATRIX, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE SMUMPS_GATHER_MATRIX SUBROUTINE SMUMPS_DUMP_PROBLEM(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C If id%WRITE_PROBLEM has been set by the user, C possibly on all processors in case of distributed C matrix, open a file and dumps the matrix and/or C the right hand side. In case the last characters C of id.WRITE_PROBLEM are "bin" (uppercase letters C are also accepted), then the matrix is written C in binary stream format (a C routine is called to C avoid depending on the access='stream' mode that C is only available since Fortran 2003). In that case, C a small header file is also written. C Otherwise, this subroutine calls C SMUMPS_DUMP_MATRIX (to write the matrix in C matrix-market format) and SMUMPS_DUMP_RHS. C The routine should be called on all MPI processes. C C Examples: C 1/ WRITE_PROBLEM='mymatrix.txt', centralized matrix C mymatrix.txt contains the matrix in matrix-market format C 2/ WRITE_PROBLEM='mymatrix.txt', distributed matrix C mymatrix.txt contains the portion of the matrix C on process , in matrix-market format C 3/ WRITE_PROBLEM='mymatrix.bin', centralized matrix C mymatrix.bin contains the matrix in binary format C mymatrix.header contains a short description in text format, C with the first line identical to the one of C a matrix-market format C 4/ WRITE_PROBLEM='mymatrix.bin', distributed matrix C mymatrix.bin contains the portion of the matrix C on process , in binary format C C mymatrix.header contains a short description in text format, C with the first line identical to matrix-market format C C If a centralized, dense, RHS is available, it is also written, C either in matrix-market or binary format (if WRITE_PROBLEM C has a .bin extension). In that case the filename for the RHS C is WRITE_PROBLEM//".rhs". If written in binary form, information C on the RHS is also provided in the header file. C INCLUDE 'mpif.h' C C Arguments C ========= C TYPE(SMUMPS_STRUC) :: id C C Local variables C =============== C INTEGER :: MASTER, IERR, I INTEGER :: IUNIT LOGICAL :: IS_ELEMENTAL LOGICAL :: IS_DISTRIBUTED LOGICAL :: NAME_INITIALIZED INTEGER :: DO_WRITE, DO_WRITE_CHECK CHARACTER(LEN=20) :: IDSTR LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: L LOGICAL :: BINARY_FORMAT, DUMP_RHS, & DUMP_BLKPTR, DUMP_BLKVAR INTEGER :: IS_A_PROVIDED, IS_A_PROVIDED_GLOB REAL, TARGET :: A_DUMMY(1) INTEGER, TARGET :: IRN_DUMMY(1), JCN_DUMMY(1) INTEGER, POINTER, DIMENSION(:) :: IRN_PASSED, JCN_PASSED REAL, POINTER, DIMENSION(:) :: A_PASSED INTEGER :: MPG LOGICAL :: PROKG PARAMETER( MASTER = 0 ) 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) MPG = id%ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) NAME_INITIALIZED = id%WRITE_PROBLEM(1:20) & .NE. "NAME_NOT_INITIALIZED" BINARY_FORMAT = .FALSE. L=len_trim(id%WRITE_PROBLEM) IF (L.GT.4) THEN IF ( id%WRITE_PROBLEM(L-3:L-3) .EQ. '.' .AND. & ( id%WRITE_PROBLEM(L-2:L-2) .EQ. 'b' .OR. & id%WRITE_PROBLEM(L-2:L-2) .EQ. 'B' ) .AND. & ( id%WRITE_PROBLEM(L-1:L-1) .EQ. 'i' .OR. & id%WRITE_PROBLEM(L-1:L-1) .EQ. 'I' ) .AND. & ( id%WRITE_PROBLEM(L:L) .EQ. 'n' .OR. & id%WRITE_PROBLEM(L:L) .EQ. 'N' ) ) THEN BINARY_FORMAT = .TRUE. ENDIF ENDIF IF (NAME_INITIALIZED.AND.PROKG) THEN WRITE(MPG,'(/A,A/)') & " Write input matrix to file, WRITE_PROBLEM= ", & id%WRITE_PROBLEM(1:L) ENDIF C Check if RHS should also be dumped DUMP_RHS = id%MYID.EQ.MASTER .AND. & associated(id%RHS) .AND. NAME_INITIALIZED DUMP_RHS = DUMP_RHS .AND. id%NRHS .GE. 1 DUMP_RHS = DUMP_RHS .AND. id%N .GE. 1 DUMP_RHS = DUMP_RHS .AND. id%ICNTL(20) .EQ. 0 C Check if BLKPTR and/or BLKVAR should also be dumped DUMP_BLKPTR = .FALSE. DUMP_BLKVAR = .FALSE. IF ( id%MYID.EQ.MASTER .AND. NAME_INITIALIZED ) THEN IF ( id%ICNTL(15) .EQ. 1 & .AND. id%NBLK .GT. 0 ) THEN IF (associated(id%BLKPTR)) THEN DUMP_BLKPTR = .TRUE. IF (associated(id%BLKVAR)) THEN C Dump also BLKVAR, except if allocated by MUMPS DUMP_BLKVAR = .TRUE. ENDIF ENDIF ELSE IF ( id%ICNTL(15) .LT. 0 ) THEN IF (associated(id%BLKVAR)) THEN C Dump also BLKVAR, except if allocated by MUMPS DUMP_BLKVAR = .TRUE. ENDIF ENDIF ENDIF C Remark: if id%KEEP(54) = 1 or 2, the structure C is centralized at analysis. Since SMUMPS_DUMP_PROBLEM C is called at analysis phase, we define IS_DISTRIBUTED C as below, which implies that the structure of the problem C is distributed in IRN_loc/JCN_loc at analysis. IS_DISTRIBUTED = (id%KEEP(54) .EQ. 3) IS_ELEMENTAL = (id%KEEP(55) .NE. 0) IF (NAME_INITIALIZED) THEN IF (I_AM_MASTER .OR. IS_DISTRIBUTED) THEN C Try to find a free Fortran unit CALL MUMPS_FIND_UNIT(IUNIT) IF ( IUNIT .EQ. -1 ) THEN id%INFO(1) = -79 id%INFO(2) = 1 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) GOTO 500 IF (I_AM_MASTER .AND. .NOT. IS_DISTRIBUTED) THEN C ==================== C Matrix is assembled C and centralized C ==================== IF (NAME_INITIALIZED) THEN IF ( BINARY_FORMAT ) THEN IF (id%KEEP8(28) .EQ. 0_8) THEN C Special case of empty matrix A_PASSED => A_DUMMY IRN_PASSED => IRN_DUMMY JCN_PASSED => JCN_DUMMY IS_A_PROVIDED = 1 ELSE IF (associated(id%A)) THEN A_PASSED=>id%A IRN_PASSED => id%IRN JCN_PASSED => id%JCN IS_A_PROVIDED = 1 ELSE A_PASSED => A_DUMMY IRN_PASSED => id%IRN JCN_PASSED => id%JCN IS_A_PROVIDED = 0 ENDIF OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' ) CALL SMUMPS_DUMP_HEADER( IUNIT, id%N, & IS_A_PROVIDED, id%KEEP(50), IS_DISTRIBUTED, & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) ) CLOSE( IUNIT ) CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(28), & id%KEEP(35), & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1), & IS_A_PROVIDED, & trim(id%WRITE_PROBLEM)//char(0) ) ELSE OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)) CALL SMUMPS_DUMP_MATRIX( id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! = .FALSE., centralized & IS_ELEMENTAL, ! Elemental or not & .FALSE.) CLOSE(IUNIT) ENDIF ENDIF ELSE IF ( IS_DISTRIBUTED ) THEN C ===================== C Matrix is distributed C ===================== IF ( .NOT.NAME_INITIALIZED & .OR. .NOT. I_AM_SLAVE )THEN DO_WRITE = 0 ELSE DO_WRITE = 1 ENDIF CALL MPI_ALLREDUCE(DO_WRITE, DO_WRITE_CHECK, 1, & MPI_INTEGER, MPI_SUM, id%COMM, IERR) C ----------------------------------------- C If yes, each processor writes its share C of the matrix in a file in matrix market C format (otherwise nothing written). We C append the process id to the filename. C Safer in case all filenames are the C same if all processors share the same C file system. C ----------------------------------------- IF (DO_WRITE_CHECK.EQ.id%NSLAVES .AND. I_AM_SLAVE) THEN WRITE(IDSTR,'(I9)') id%MYID_NODES IF (BINARY_FORMAT) THEN IF (id%KEEP8(29) .EQ. 0_8) THEN C Special case of empty matrix A_PASSED => A_DUMMY IRN_PASSED => IRN_DUMMY JCN_PASSED => JCN_DUMMY C (consider that A is provided when NNZ_loc=0) IS_A_PROVIDED = 1 ELSE IF (associated(id%A_loc)) THEN A_PASSED=>id%A_loc IRN_PASSED => id%IRN_loc JCN_PASSED => id%JCN_loc IS_A_PROVIDED = 1 ELSE A_PASSED => A_DUMMY IRN_PASSED => id%IRN_loc JCN_PASSED => id%JCN_loc IS_A_PROVIDED = 0 ENDIF CALL MPI_ALLREDUCE( IS_A_PROVIDED, & IS_A_PROVIDED_GLOB, 1, & MPI_INTEGER, MPI_PROD, id%COMM_NODES, IERR ) C IS_A_PROVIDED_GLOB = 1 => dump numerical values C IS_A_PROVIDED_GLOB = 0 => some processes did not provide C numerical values, dump only pattern, C and indicate this in the header IF ( id%MYID_NODES.EQ.0) THEN C Print header on first MPI worker (only one global header C file in case of distributed matrix), replacing the .bin C extension by a .header extension OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' ) CALL SMUMPS_DUMP_HEADER( IUNIT, id%N, & IS_A_PROVIDED_GLOB, id%KEEP(50), IS_DISTRIBUTED, & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) ) CLOSE( IUNIT ) ENDIF CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(29), & id%KEEP(35), & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1), & IS_A_PROVIDED_GLOB, & trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))//char(0) ) ELSE OPEN(IUNIT, & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))) CALL SMUMPS_DUMP_MATRIX(id, & IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! =.TRUE., distributed & IS_ELEMENTAL, ! Elemental or not & .FALSE.) CLOSE(IUNIT) ENDIF ENDIF C ELSE ... C Nothing written in other cases. ENDIF C =============== C Right-hand side C =============== IF ( DUMP_RHS ) THEN IF (BINARY_FORMAT) THEN C dump RHS in binary format CALL MUMPS_DUMPRHSBINARY_C( id%N, id%NRHS, id%LRHS, id%RHS(1), & id%KEEP(35), & trim(id%WRITE_PROBLEM)//'.rhs'//char(0) ) ELSE C dump RHS in matrix-market format OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM) //".rhs") CALL SMUMPS_DUMP_RHS(IUNIT, id) CLOSE(IUNIT) ENDIF ENDIF IF ( DUMP_BLKPTR ) THEN IF (BINARY_FORMAT) THEN ! suppress trailing '.bin' and use '.blkptr' OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkptr' ) ELSE ! just append '.blkptr' OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkptr") ENDIF WRITE(IUNIT,'(I9)') id%NBLK DO I=1,id%NBLK+1 WRITE(IUNIT,'(I9)') id%BLKPTR(I) ENDDO CLOSE(IUNIT) ENDIF IF ( DUMP_BLKVAR ) THEN IF (BINARY_FORMAT) THEN ! suppress trailing '.bin' and use '.blkvar' OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkvar' ) ELSE ! just append '.blkvar' OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkvar") ENDIF DO I=1,id%N WRITE(IUNIT,'(I9)') id%BLKVAR(I) ENDDO CLOSE(IUNIT) ENDIF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_DUMP_PROBLEM SUBROUTINE SMUMPS_DUMP_HEADER( IUNIT, N, IS_A_PROVIDED_GLOB, & SYM, IS_DISTRIBUTED, NSLAVES, NNZTOT, DUMP_RHS, NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, NBLK, ICNTL15 ) C C Purpose: C ======= C C Write a small header file, similar to matrix-market headers, C to accompany a matrix written in binary format. C INTEGER, INTENT(IN) :: IUNIT, N, IS_A_PROVIDED_GLOB , SYM, NSLAVES INTEGER(8), INTENT(IN) :: NNZTOT LOGICAL, INTENT(IN) :: IS_DISTRIBUTED, DUMP_RHS INTEGER, INTENT(IN) :: NRHS LOGICAL, INTENT(IN) :: DUMP_BLKPTR, DUMP_BLKVAR INTEGER, INTENT(IN) :: NBLK INTEGER, INTENT(IN) :: ICNTL15 C C Local declarations: C ================== C CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH C 1/ write a line identical to first line of matrix-market header IF ( IS_A_PROVIDED_GLOB .EQ. 1 ) THEN ARITH='real' ELSE ARITH='pattern' ENDIF IF (SYM .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) C 2/ indicate if matrix is distributed or centralized, C then describe binary file content and format IF ( IS_DISTRIBUTED ) THEN WRITE(IUNIT,FMT='(A,I5,A)') & '% Matrix is distributed (MPI ranks=',NSLAVES,')' ELSE WRITE(IUNIT,FMT='(A)') & '% Matrix is centralized' ENDIF WRITE(IUNIT,FMT='(A)') & '% Unformatted stream IO (no record boundaries):' IF (ARITH(1:7).EQ.'pattern') THEN IF (IS_DISTRIBUTED) THEN WRITE(IUNIT,'(A)') & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc)' ELSE WRITE(IUNIT,'(A)') & '% N,NNZ,IRN(1:NNZ),JCN(1:NNZ)' ENDIF WRITE(IUNIT,'(A)') '% (numerical values not provided)' ELSE IF (IS_DISTRIBUTED) THEN WRITE(IUNIT,'(A)') & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc),'// & 'A_loc(1:NNZ_loc)' ELSE WRITE(IUNIT,'(A)') '% N/NNZ/IRN(1:NNZ),JCN(1:NNZ),A(1:NNZ)' ENDIF WRITE(IUNIT,'(A)') '% Single precision storage' ENDIF IF ( IS_DISTRIBUTED ) THEN WRITE(IUNIT,'(A,/,A)') & '% N,IRN_loc(i),JCN_loc(i): 32 bits', & '% NNZ_loc: 64 bits' ELSE WRITE(IUNIT,'(A,/,A)') & '% N,IRN(i),JCN(i): 32 bits', & '% NNZ: 64 bits' ENDIF WRITE(IUNIT,FMT='(A,I16)') '% Matrix order: N=',N WRITE(IUNIT,FMT='(A,I16)') '% Matrix nonzeros: NNZ=',NNZTOT IF (DUMP_RHS) THEN WRITE(IUNIT,FMT='(A)') '%' WRITE(IUNIT,FMT='(A,/,A,I10,A,I5)') & '% A RHS was also written to disk by columns in binary form.', & '% Size: N rows x NRHS columns with N=',N,' NRHS=',NRHS WRITE(IUNIT,FMT='(A,I16,A)') & '% Total:',int(N,8)*int(NRHS,8),' scalar values.' WRITE(IUNIT,'(A)') '% Single precision storage' ENDIF IF (DUMP_BLKPTR) THEN WRITE(IUNIT,FMT='(A)') '%' WRITE(IUNIT,'(A,I9,A)') '% Matrix has a block format with', & NBLK,' blocks' WRITE(IUNIT,'(A)') & '% File .blkptr contains NBLK and BLKPTR(1:NBLK+1)' ELSE IF (ICNTL15 .LT. 0) THEN WRITE(IUNIT,FMT='(A)') '%' WRITE(IUNIT,'(A,I9,A)') & '% Matrix has a block format with ICNTL15=',ICNTL15 ENDIF IF (DUMP_BLKVAR) THEN WRITE(IUNIT,'(A)') & '% File .blkvar contains BLKVAR (N integers)' ELSE IF (ICNTL15 .NE. 0) THEN WRITE(IUNIT,'(A)') & '% (BLKVAR considered to be identity is not written)' ENDIF RETURN END SUBROUTINE SMUMPS_DUMP_HEADER SUBROUTINE SMUMPS_DUMP_MATRIX & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, IS_ELEMENTAL, PATTERN_ONLY ) USE SMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C This subroutine dumps a routine in matrix-market format C if the matrix is assembled, and in "MUMPS" format (see C example in the MUMPS users'guide, if the matrix is C centralized and elemental). C The routine can be called on all processors. In case of C distributed assembled matrix, each processor writes its C share as a matrix market file on IUNIT (IUNIT may have C different values on different processors). C C C C Arguments (input parameters) C ============================ C C IUNIT: should be set to the Fortran unit where C data should be written. C I_AM_SLAVE: .TRUE. except on a non working master C IS_DISTRIBUTED: .TRUE. if matrix is distributed, C i.e., if IRN_loc/JCN_loc are provided. C IS_ELEMENTAL : .TRUE. if matrix is elemental C id : main MUMPS structure C LOGICAL, intent(in) :: I_AM_SLAVE, & I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL, & PATTERN_ONLY INTEGER, intent(in) :: IUNIT TYPE(SMUMPS_STRUC), intent(in) :: id C C Local variables: C =============== C CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH INTEGER(8) :: I8, NNZ_i C C Executable statements: C ===================== IF (I_AM_MASTER .AND. .NOT. IS_DISTRIBUTED .AND. & .NOT. IS_ELEMENTAL) THEN C ================== C CENTRALIZED MATRIX C ================== IF (id%KEEP8(28) .EQ. 0_8) THEN CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ, id%NZ, NNZ_i) ELSE NNZ_i=id%KEEP8(28) ENDIF IF ((associated(id%A)).AND.(.NOT.PATTERN_ONLY)) THEN C Write header line: ARITH='real' ELSE ARITH='pattern ' ENDIF IF (id%KEEP(50) .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) WRITE(IUNIT,*) id%N, id%N, NNZ_i IF ((associated(id%A)).AND.(.NOT.PATTERN_ONLY)) THEN DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. id%IRN(I8).LT.id%JCN(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8), id%A(I8) ELSE WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8), id%A(I8) ENDIF ENDDO ELSE C pattern only DO I8=1_8,id%KEEP8(28) IF (id%KEEP(50).NE.0 .AND. id%IRN(I8).LT.id%JCN(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8) ELSE WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8) ENDIF ENDDO ENDIF ELSE IF ( IS_DISTRIBUTED .AND. I_AM_SLAVE ) THEN C ================== C DISTRIBUTED MATRIX C ================== IF (id%KEEP8(29) .EQ. 0_8) THEN CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ_loc, id%NZ_loc, NNZ_i) ELSE NNZ_i=id%KEEP8(29) ENDIF IF ((associated(id%A_loc)).AND.(.NOT.PATTERN_ONLY)) THEN ARITH='real' ELSE ARITH='pattern ' ENDIF IF (id%KEEP(50) .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) WRITE(IUNIT,*) id%N, id%N, NNZ_i IF ((associated(id%A_loc)).AND.(.NOT.PATTERN_ONLY)) THEN DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I8).LT.id%JCN_loc(I8)) THEN WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8), & id%A_loc(I8) ELSE WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8), & id%A_loc(I8) ENDIF ENDDO ELSE DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I8).LT.id%JCN_loc(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8) ELSE WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8) ENDIF ENDDO ENDIF ELSE IF (IS_ELEMENTAL .AND. I_AM_MASTER) THEN C ================== C ELEMENTAL MATRIX C ================== WRITE(IUNIT,*) id%N," :: N" WRITE(IUNIT,*) id%NELT," :: NELT" WRITE(IUNIT,*) size(id%ELTVAR)," :: NELTVAR" WRITE(IUNIT,*) size(id%A_ELT)," :: NELTVL" WRITE(IUNIT,*) id%ELTPTR(:)," ::ELTPTR" WRITE(IUNIT,*) id%ELTVAR(:)," ::ELTVAR" IF(.NOT.PATTERN_ONLY) THEN WRITE(IUNIT,*) id%A_ELT(:) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_DUMP_MATRIX SUBROUTINE SMUMPS_DUMP_RHS(IUNIT, id) C C Purpose: C ======= C Dumps a dense, centralized, C right-hand side in matrix market format on unit C IUNIT. Should be called on the host only. C USE SMUMPS_STRUC_DEF IMPLICIT NONE C Arguments C ========= TYPE(SMUMPS_STRUC), intent(in) :: id INTEGER, intent(in) :: IUNIT C C Local variables C =============== C CHARACTER (LEN=8) :: ARITH INTEGER :: I, J INTEGER(8) :: LD_RHS8, K8 C C Executable statements C ===================== C IF (associated(id%RHS)) THEN ARITH='real' WRITE(IUNIT,'(A,A,A)') '%%MatrixMarket matrix array ', & trim(ARITH), & ' general' WRITE(IUNIT,*) id%N, id%NRHS IF ( id%NRHS .EQ. 1 ) THEN LD_RHS8 = int(id%N,8) ELSE LD_RHS8 = int(id%LRHS,8) ENDIF DO J = 1, id%NRHS DO I = 1, id%N K8=int(J-1,8)*LD_RHS8+int(I,8) WRITE(IUNIT,*) id%RHS(K8) ENDDO ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_DUMP_RHS SUBROUTINE SMUMPS_BUILD_I_AM_CAND( NSLAVES, K79, & NB_NIV2, MYID_NODES, & CANDIDATES, I_AM_CAND ) IMPLICIT NONE C C Purpose: C ======= C Given a list of candidate processors per node, C returns an array of booleans telling whether the C processor is candidate or not for a given node. C C K79 holds splitting strategy (KEEP(79)). If K79>1 then C TPYE4,5,6 nodes might have been introduced and C in this case "hidden" slaves should be taken C into account to enable dynamic redistribution C of the hidden slaves while climbing the chain of C split nodes. The master of the first node in the C chain requires a special treatment and is thus here C not considered as a slave. C INTEGER, intent(in) :: NSLAVES, NB_NIV2, MYID_NODES, K79 INTEGER, intent(in) :: CANDIDATES( NSLAVES+1, NB_NIV2 ) LOGICAL, intent(out):: I_AM_CAND( NB_NIV2 ) INTEGER I, INIV2, NCAND IF (K79.GT.0) THEN C Because of potential restarting the number of C candidates that will be used to distribute C arrowheads have to include all possible candidates. DO INIV2=1, NB_NIV2 I_AM_CAND(INIV2)=.FALSE. NCAND = CANDIDATES(NSLAVES+1,INIV2) C check if some hidden slaves are there C Note that if hidden candidates exists (type 5 or 6 nodes) then C in position CANDIDATES (NCAND+1,INIV2) must be the master C of the first node in the chain (type 4) that we skip here because C a special treatment (it has to be "considered as a master" for all C nodes in the list) is needed. DO I=1, NSLAVES IF (CANDIDATES(I,INIV2).LT.0) EXIT ! end of extra slaves IF (I.EQ.NCAND+1) CYCLE ! skip master of associated TYPE 4 node IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN I_AM_CAND(INIV2)=.TRUE. EXIT ENDIF ENDDO END DO ELSE DO INIV2=1, NB_NIV2 I_AM_CAND(INIV2)=.FALSE. NCAND = CANDIDATES(NSLAVES+1,INIV2) DO I=1, NCAND IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN I_AM_CAND(INIV2)=.TRUE. EXIT ENDIF ENDDO END DO ENDIF RETURN END SUBROUTINE SMUMPS_BUILD_I_AM_CAND MUMPS_5.8.1/src/cfac_process_rtnelind.F0000664000175000017500000001133415042446440017672 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_PROCESS_RTNELIND( root, roota, & INODE, NELIM, NSLAVES, ROW_LIST, & COL_LIST, SLAVE_LIST, & & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND ) USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER INODE, NELIM, NSLAVES INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER ROW_LIST(*), COL_LIST(*), & SLAVE_LIST(*) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), ITLOC( N + KEEP(253) ) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER IFLAG, IERROR INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF INTEGER COMM, COMM_LOAD, ND(KEEP(28)), FILS(N), DAD(KEEP(28)) INTEGER IROOT, TYPE_INODE, DEB_ROW, DEB_COL, & NOINT INTEGER(8) :: NOREAL INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE IROOT = KEEP(38) NSTK_S(STEP(IROOT))= NSTK_S(STEP(IROOT)) - 1 KEEP(42) = KEEP(42) + NELIM TYPE_INODE= MUMPS_TYPENODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IF (TYPE_INODE.EQ.1) THEN IF (NELIM.EQ.0) THEN KEEP(41) = KEEP(41) + 1 ELSE KEEP(41) = KEEP(41) + 3 ENDIF ELSE IF (NELIM.EQ.0) THEN KEEP(41) = KEEP(41) + NSLAVES ELSE KEEP(41) = KEEP(41) + 2*NSLAVES + 1 ENDIF ENDIF IF (NELIM.EQ.0) THEN PIMASTER(STEP(INODE)) = 0 ELSE NOINT = 6 + NSLAVES + NELIM + NELIM + KEEP(IXSZ) NOREAL= 0_8 CALL CMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) THEN WRITE(*,*) ' Failure in int space allocation in CB area ', & ' during assembly of root : CMUMPS_PROCESS_RTNELIND', & ' size required was :', NOINT, & 'INODE=',INODE,' NELIM=',NELIM, ' NSLAVES=', NSLAVES RETURN ENDIF PIMASTER(STEP( INODE )) = IWPOSCB + 1 PAMASTER(STEP( INODE )) = IPTRLU + 1_8 IW( IWPOSCB + 1+KEEP(IXSZ) ) = 2*NELIM IW( IWPOSCB + 2+KEEP(IXSZ) ) = NELIM IW( IWPOSCB + 3+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 5+KEEP(IXSZ) ) = 1 IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES IF (NSLAVES.GT.0) THEN IW( IWPOSCB+7+KEEP(IXSZ):IWPOSCB+7+KEEP(IXSZ)+NSLAVES-1) = & SLAVE_LIST(1:NSLAVES) ENDIF DEB_ROW = IWPOSCB+7+NSLAVES+KEEP(IXSZ) IW(DEB_ROW : DEB_ROW+NELIM -1) = ROW_LIST(1:NELIM) DEB_COL = DEB_ROW + NELIM IW(DEB_COL : DEB_COL+NELIM -1) = COL_LIST(1:NELIM) ENDIF IF (NSTK_S(STEP(IROOT)) .EQ. 0 ) THEN CALL CMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN END SUBROUTINE CMUMPS_PROCESS_RTNELIND MUMPS_5.8.1/src/slr_core.F0000664000175000017500000022342415042446441015157 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C Note: the last routine of this file, xMUMPS_TRUNCATED_RRQR is derived from C the LAPACK package, for which BSD 3-clause license applies C (see header of the routine). MODULE SMUMPS_LR_CORE USE MUMPS_LR_COMMON USE SMUMPS_LR_TYPE USE MUMPS_LR_STATS USE SMUMPS_LR_DATA_M !$ USE OMP_LIB IMPLICIT NONE CONTAINS SUBROUTINE INIT_LRB(LRB_OUT,K,M,N,ISLR) C This routine simply initializes a LR block but does NOT allocate it C (allocation occurs somewhere else) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,M,N LOGICAL,INTENT(IN) :: ISLR LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%ISLR = ISLR NULLIFY(LRB_OUT%Q) NULLIFY(LRB_OUT%R) END SUBROUTINE INIT_LRB C C SUBROUTINE IS_FRONT_BLR_CANDIDATE(INODE, NIV, NFRONT, NASS, & BLRON, K489, & K490, K491, K492, K20, K60, IDAD, K38, & K123, LRSTATUS, K280, LRGROUPS) INTEGER,INTENT(IN) :: INODE, NFRONT, NASS, BLRON, K123, & K489, K490, & K491, K492, NIV, K20, K60, IDAD, K38 INTEGER,INTENT(OUT):: LRSTATUS INTEGER, INTENT(IN):: K280 INTEGER, INTENT(IN), OPTIONAL :: LRGROUPS(K280) C C Local variables LOGICAL :: COMPRESS_PANEL, COMPRESS_CB LRSTATUS = 0 C Type 3 node is not BLR IF (NIV.EQ.3) RETURN COMPRESS_PANEL = .FALSE. IF ((BLRON.NE.0).and.( & ((K492.LT.0).and.INODE.EQ.abs(K492)) & .or. & ( (K492.GT.0).and.(K491.LE.NFRONT) & .and.(K490.LE.NASS)))) THEN COMPRESS_PANEL = .TRUE. C Compression for NASS =1 is useless IF (NASS.LE.1) THEN COMPRESS_PANEL =.FALSE. ENDIF IF (present(LRGROUPS)) THEN IF (LRGROUPS (INODE) .LT. 0) COMPRESS_PANEL = .FALSE. ENDIF ENDIF COMPRESS_CB = .FALSE. IF ((BLRON.NE.0).and. & (K489.GT.0.AND.(K489.NE.2.OR.NIV.EQ.2)) & .and.( & ((K492.LT.0).and.INODE.EQ.abs(K492)) & .or. & ((K492.GT.0).AND.(NFRONT-NASS.GT.K491)))) & THEN COMPRESS_CB = .TRUE. ENDIF IF (.NOT.COMPRESS_PANEL) COMPRESS_CB=.FALSE. IF (COMPRESS_PANEL.OR.COMPRESS_CB) THEN IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN LRSTATUS = 1 ELSE IF (COMPRESS_PANEL.AND.(.NOT.COMPRESS_CB)) THEN LRSTATUS = 2 ELSE LRSTATUS = 3 ENDIF ELSE LRSTATUS = 0 ENDIF C C Schur complement cannot be BLR for now C IF ( INODE .EQ. K20 .AND. K60 .NE. 0 ) THEN LRSTATUS = 0 ENDIF C C Do not compress CB of children of root C IF ( IDAD .EQ. K38 .AND. K38 .NE.0 ) THEN COMPRESS_CB = .FALSE. IF (LRSTATUS.GE.2) THEN LRSTATUS = 2 ELSE LRSTATUS = 0 ENDIF ENDIF RETURN END SUBROUTINE IS_FRONT_BLR_CANDIDATE SUBROUTINE ALLOC_LRB(LRB_OUT,K,M,N,ISLR,IFLAG,IERROR,KEEP8) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,M,N INTEGER,INTENT(INOUT) :: IFLAG, IERROR LOGICAL,INTENT(IN) :: ISLR INTEGER(8) :: KEEP8(150) INTEGER :: MEM, allocok REAL :: ZERO PARAMETER (ZERO = 0.0D0) LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%ISLR = ISLR IF ((M.EQ.0).OR.(N.EQ.0)) THEN nullify(LRB_OUT%Q) nullify(LRB_OUT%R) RETURN ENDIF IF (ISLR) THEN IF (K.EQ.0) THEN nullify(LRB_OUT%Q) nullify(LRB_OUT%R) ELSE allocate(LRB_OUT%Q(M,K),LRB_OUT%R(K,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = K*(M+N) RETURN ENDIF ENDIF ELSE nullify(LRB_OUT%R) allocate(LRB_OUT%Q(M,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = M*N RETURN ENDIF ENDIF IF (ISLR) THEN MEM = M*K + N*K ELSE MEM = M*N ENDIF CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM,8), & .TRUE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) RETURN END SUBROUTINE ALLOC_LRB SUBROUTINE ALLOC_LRB_FROM_ACC(ACC_LRB, LRB_OUT, K, M, N, LorU, & IFLAG, IERROR, KEEP8) TYPE(LRB_TYPE), INTENT(IN) :: ACC_LRB TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K, M, N, LorU INTEGER,INTENT(INOUT) :: IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER :: I IF (LorU.EQ.1) THEN CALL ALLOC_LRB(LRB_OUT,K,M,N,.TRUE.,IFLAG,IERROR,KEEP8) IF (IFLAG.LT.0) RETURN DO I=1,K LRB_OUT%Q(1:M,I) = ACC_LRB%Q(1:M,I) LRB_OUT%R(I,1:N) = -ACC_LRB%R(I,1:N) ENDDO ELSE CALL ALLOC_LRB(LRB_OUT,K,N,M,.TRUE.,IFLAG,IERROR,KEEP8) IF (IFLAG.LT.0) RETURN DO I=1,K LRB_OUT%Q(1:N,I) = ACC_LRB%R(I,1:N) LRB_OUT%R(I,1:M) = -ACC_LRB%Q(1:M,I) ENDDO ENDIF END SUBROUTINE ALLOC_LRB_FROM_ACC SUBROUTINE REGROUPING2(CUT, NPARTSASS, NASS, & NPARTSCB, NCB, IBCKSZ, ONLYCB, K472, & NFRONT, KEEP) INTEGER, INTENT(IN) :: IBCKSZ, NASS, NCB, NFRONT, KEEP(500) INTEGER, INTENT(INOUT) :: NPARTSCB, NPARTSASS INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER, POINTER, DIMENSION(:) :: NEW_CUT INTEGER :: I, INEW, MINSIZE, NEW_NPARTSASS, allocok LOGICAL :: ONLYCB, TRACE INTEGER, INTENT(IN) :: K472 INTEGER :: IBCKSZ2,IFLAG,IERROR ALLOCATE(NEW_CUT(max(NPARTSASS,1)+NPARTSCB+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = max(NPARTSASS,1)+NPARTSCB+1 write(*,*) 'Allocation problem in BLR routine REGROUPING2:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF CALL COMPUTE_BLR_VCS(K472, IBCKSZ2, IBCKSZ, NASS, & NFRONT, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) NEW_NPARTSASS = max(NPARTSASS,1) IF (.NOT. ONLYCB) THEN NEW_CUT(1) = 1 INEW = 2 I = 2 DO WHILE (I .LE. NPARTSASS + 1) NEW_CUT(INEW) = CUT(I) TRACE = .FALSE. IF (NEW_CUT(INEW) - NEW_CUT(INEW-1) .GT. MINSIZE) THEN INEW = INEW + 1 TRACE = .TRUE. ENDIF I = I + 1 END DO IF (TRACE) THEN INEW = INEW - 1 ELSE IF (INEW .NE. 2) THEN NEW_CUT(INEW-1) = NEW_CUT(INEW) INEW = INEW - 1 ENDIF ENDIF NEW_NPARTSASS = INEW - 1 ENDIF IF (ONLYCB) THEN DO I=1,max(NPARTSASS,1)+1 NEW_CUT(I) = CUT(I) ENDDO ENDIF IF (NCB .EQ. 0) GO TO 50 INEW = NEW_NPARTSASS+2 I = max(NPARTSASS,1) + 2 DO WHILE (I .LE. max(NPARTSASS,1) + NPARTSCB + 1) NEW_CUT(INEW) = CUT(I) TRACE = .FALSE. IF (NEW_CUT(INEW) - NEW_CUT(INEW-1) .GT. MINSIZE) THEN INEW = INEW + 1 TRACE = .TRUE. ENDIF I = I + 1 END DO IF (TRACE) THEN INEW = INEW - 1 ELSE IF (INEW .NE. NEW_NPARTSASS+2) THEN NEW_CUT(INEW-1) = NEW_CUT(INEW) INEW = INEW - 1 ENDIF ENDIF NPARTSCB = INEW - 1 - NEW_NPARTSASS 50 CONTINUE NPARTSASS = NEW_NPARTSASS DEALLOCATE(CUT) ALLOCATE(CUT(NPARTSASS+NPARTSCB+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSASS+NPARTSCB+1 write(*,*) 'Allocation problem in BLR routine REGROUPING2:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF DO I=1,NPARTSASS+NPARTSCB+1 CUT(I) = NEW_CUT(I) ENDDO DEALLOCATE(NEW_CUT) END SUBROUTINE REGROUPING2 SUBROUTINE UPD_MRY_LU_LRGAIN( BLR_PANEL, NBBLOCKS & ) C Updates the memory gain associated with a given BLR panel INTEGER,INTENT(IN) :: NBBLOCKS TYPE(LRB_TYPE), INTENT(IN) :: BLR_PANEL(:) DOUBLE PRECISION :: MRY INTEGER :: I C MRY = 0.0D0 DO I = 1, NBBLOCKS IF (BLR_PANEL(I)%ISLR) THEN MRY = MRY + dble(BLR_PANEL(I)%M*BLR_PANEL(I)%N & - BLR_PANEL(I)%K*(BLR_PANEL(I)%M + BLR_PANEL(I)%N)) ELSE ! islr MRY = MRY + 0.0d0 ENDIF ! islr ENDDO !$OMP ATOMIC UPDATE MRY_LU_LRGAIN = MRY_LU_LRGAIN + MRY !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_LU_LRGAIN SUBROUTINE SMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA, LRB, & NIV, SYM, LorU, IW, OFFSET_IW) C ----------- C Parameters C ----------- INTEGER(8), intent(in) :: LA INTEGER, intent(in) :: NFRONT, NIV, SYM, LorU, LDA INTEGER(8), intent(in) :: POSELT_LOCAL REAL, intent(inout) :: A(LA) TYPE(LRB_TYPE), intent(inout) :: LRB INTEGER, OPTIONAL:: OFFSET_IW INTEGER, OPTIONAL :: IW(*) C ----------- C Local variables C ----------- INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER :: M, N, I, J REAL, POINTER :: LR_BLOCK_PTR(:,:) REAL :: ONE, MONE, ZERO REAL :: MULT1, MULT2, A11, DETPIV, A22, A12 PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) N = LRB%N IF (LRB%ISLR) THEN M = LRB%K LR_BLOCK_PTR => LRB%R ELSE M = LRB%M LR_BLOCK_PTR => LRB%Q END IF IF (M.NE.0) THEN C Why is it Right, Lower, Tranpose? C Because A is stored by rows C but BLR_L is stored by columns IF (SYM.EQ.0.AND.LorU.EQ.0) THEN CALL strsm('R', 'L', 'T', 'N', M, N, ONE, & A(POSELT_LOCAL), NFRONT, & LR_BLOCK_PTR(1,1), M) ELSE CALL strsm('R', 'U', 'N', 'U', M, N, ONE, & A(POSELT_LOCAL), LDA, & LR_BLOCK_PTR(1,1), M) IF (LorU.EQ.0) THEN C Now apply D scaling IF (.NOT.present(OFFSET_IW)) THEN write(*,*) 'Internal error in ', & 'SMUMPS_LRTRSM' CALL MUMPS_ABORT() ENDIF DPOS = POSELT_LOCAL I = 1 DO IF(I .GT. N) EXIT IF(IW(OFFSET_IW+I-1) .GT. 0) THEN C 1x1 pivot A11 = ONE/A(DPOS) CALL sscal(M, A11, LR_BLOCK_PTR(1,I), 1) DPOS = DPOS + int(LDA + 1,8) I = I+1 ELSE C 2x2 pivot POSPV1 = DPOS POSPV2 = DPOS+ int(LDA + 1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV DO J = 1,M MULT1 = A11*LR_BLOCK_PTR(J,I)+A12*LR_BLOCK_PTR(J,I+1) MULT2 = A12*LR_BLOCK_PTR(J,I)+A22*LR_BLOCK_PTR(J,I+1) LR_BLOCK_PTR(J,I) = MULT1 LR_BLOCK_PTR(J,I+1) = MULT2 ENDDO DPOS = POSPV2 + int(LDA + 1,8) I = I+2 ENDIF ENDDO ENDIF ENDIF ENDIF CALL UPD_FLOP_TRSM(LRB%M, LRB%N, LRB%K, LRB%ISLR, LorU) END SUBROUTINE SMUMPS_LRTRSM SUBROUTINE SMUMPS_LRGEMM_SCALING(LRB, SCALED, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, MAXI_CLUSTER) C This routine does the scaling (for the symmetric case) before C computing the LR product (done in SMUMPS_LRGEMM4) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) REAL, intent(inout), DIMENSION(:,:) :: SCALED INTEGER,INTENT(IN) :: LD_DIAG, NFRONT, IW2(*) INTEGER(8), INTENT(IN) :: POSELTT REAL, INTENT(IN), OPTIONAL :: DIAG(*) INTEGER, INTENT(IN) :: MAXI_CLUSTER REAL, intent(inout) :: BLOCK(MAXI_CLUSTER) INTEGER :: J, NROWS REAL :: PIV1, PIV2, OFFDIAG IF (LRB%ISLR) THEN NROWS = LRB%K ELSE NROWS = LRB%M ENDIF J = 1 DO WHILE (J <= LRB%N) IF (IW2(J) > 0) THEN SCALED(1:NROWS,J) = DIAG(1+LD_DIAG*(J-1)+J-1) & * SCALED(1:NROWS,J) J = J+1 ELSE !2x2 pivot PIV1 = DIAG(1+LD_DIAG*(J-1)+J-1) PIV2 = DIAG(1+LD_DIAG*J+J) OFFDIAG = DIAG(1+LD_DIAG*(J-1)+J) BLOCK(1:NROWS) = SCALED(1:NROWS,J) SCALED(1:NROWS,J) = PIV1 * SCALED(1:NROWS,J) & + OFFDIAG * SCALED(1:NROWS,J+1) SCALED(1:NROWS,J+1) = OFFDIAG * BLOCK(1:NROWS) & + PIV2 * SCALED(1:NROWS,J+1) J=J+2 ENDIF END DO END SUBROUTINE SMUMPS_LRGEMM_SCALING SUBROUTINE SMUMPS_LRGEMM4(ALPHA, & LRB1, LRB2, BETA, & A, LA, POSELTT, NFRONT, SYM, & IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & RANK, BUILDQ, & LUA_ACTIVATED, C Start of OPTIONAL arguments & LorU, & LRB3, MAXI_RANK, & MAXI_CLUSTER, & DIAG, LD_DIAG, IW2, BLOCK & ) C CC TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, SYM, TOL_OPT INTEGER,INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), INTENT(IN) :: POSELTT REAL, INTENT(IN), OPTIONAL :: DIAG(*) INTEGER,INTENT(IN), OPTIONAL :: LD_DIAG, IW2(*) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL, intent(in) :: TOLEPS REAL :: ALPHA,BETA LOGICAL, INTENT(OUT) :: BUILDQ REAL, intent(inout), OPTIONAL :: BLOCK(*) INTEGER, INTENT(IN), OPTIONAL :: LorU LOGICAL, INTENT(IN) :: LUA_ACTIVATED INTEGER, INTENT(IN), OPTIONAL :: MAXI_CLUSTER INTEGER, INTENT(IN), OPTIONAL :: MAXI_RANK TYPE(LRB_TYPE), INTENT(INOUT), OPTIONAL :: LRB3 REAL, POINTER, DIMENSION(:,:) :: XY_YZ REAL, ALLOCATABLE, TARGET, DIMENSION(:,:) :: XQ, R_Y REAL, POINTER, DIMENSION(:,:) :: X, Y, Y1, Y2, Z CHARACTER(len=1) :: SIDE, TRANSY INTEGER :: K_XY, K_YZ, LDY, LDY1, LDY2, K_Y INTEGER :: LDXY_YZ, SAVE_K INTEGER :: I, J, RANK, MAXRANK, INFO, LWORK REAL, ALLOCATABLE :: RWORK_RRQR(:) REAL, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:), & Y_RRQR(:,:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: allocok, MREQ REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) IF (LRB1%M.EQ.0) THEN RETURN ENDIF IF (LRB2%M.EQ.0) THEN ENDIF RANK = 0 BUILDQ = .FALSE. IF (LRB1%ISLR.AND.LRB2%ISLR) THEN IF ((LRB1%K.EQ.0).OR.(LRB2%K.EQ.0)) THEN GOTO 1200 ENDIF allocate(Y(LRB1%K,LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K GOTO 1570 ENDIF X => LRB1%Q K_Y = LRB1%N IF (SYM .EQ. 0) THEN Y1 => LRB1%R ELSE allocate(Y1(LRB1%K,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%K Y1(I,J) = LRB1%R(I,J) ENDDO ENDDO CALL SMUMPS_LRGEMM_SCALING(LRB1, Y1, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY1 = LRB1%K Z => LRB2%Q Y2 => LRB2%R LDY2 = LRB2%K CALL sgemm('N', 'T', LRB1%K, LRB2%K, K_Y, ONE, & Y1(1,1), LDY1, Y2(1,1), LDY2, ZERO, Y(1,1), LRB1%K ) IF (MIDBLK_COMPRESS.GE.1) THEN LWORK = LRB2%K*(LRB2%K+1) allocate(Y_RRQR(LRB1%K,LRB2%K), & WORK_RRQR(LWORK), RWORK_RRQR(2*LRB2%K), & TAU_RRQR(MIN(LRB1%K,LRB2%K)), & JPVT_RRQR(LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K + LWORK + 2*LRB2%K + & MIN(LRB1%K,LRB2%K) + LRB2%K GOTO 1570 ENDIF DO J=1,LRB2%K DO I=1,LRB1%K Y_RRQR(I,J) = Y(I,J) ENDDO ENDDO MAXRANK = MIN(LRB1%K, LRB2%K)-1 MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) JPVT_RRQR = 0 CALL SMUMPS_TRUNCATED_RRQR(LRB1%K, LRB2%K, Y_RRQR(1,1), & LRB1%K, JPVT_RRQR, TAU_RRQR, WORK_RRQR, & LRB2%K, RWORK_RRQR, TOLEPS, TOL_OPT, RANK, & MAXRANK, INFO, & BUILDQ) IF (RANK.GT.MAXRANK) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) BUILDQ = .FALSE. ELSE BUILDQ = .TRUE. ENDIF IF (BUILDQ) THEN IF (RANK.EQ.0) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) deallocate(Y) nullify(Y) C GOTO 1580 not ok because BUILDQ .EQV. true C would try to free XQ and R_Y that are not allocated C in that case. So we free Y1 now if it was allocated. IF (SYM .NE. 0) deallocate(Y1) GOTO 1200 ELSE allocate(XQ(LRB1%M,RANK), R_Y(RANK,LRB2%K), & stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*RANK + RANK*LRB2%K GOTO 1570 ENDIF DO J=1, LRB2%K R_Y(1:MIN(RANK,J),JPVT_RRQR(J)) = & Y_RRQR(1:MIN(RANK,J),J) IF(J.LT.RANK) R_Y(MIN(RANK,J)+1: & RANK,JPVT_RRQR(J))= ZERO END DO C LWORK=LRB2%K*(LRB2%K+1), with LRB2%K>RANK C large enough for sorgqr CALL sorgqr & (LRB1%K, RANK, RANK, Y_RRQR(1,1), & LRB1%K, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) CALL sgemm('N', 'N', LRB1%M, RANK, LRB1%K, ONE, & X(1,1), LRB1%M, Y_RRQR(1,1), LRB1%K, ZERO, & XQ(1,1), LRB1%M) deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) nullify(X) X => XQ K_XY = RANK deallocate(Y) nullify(Y) Y => R_Y LDY = RANK K_YZ = LRB2%K TRANSY = 'N' SIDE = 'R' ENDIF ENDIF ENDIF IF (.NOT.BUILDQ) THEN LDY = LRB1%K K_XY = LRB1%K K_YZ = LRB2%K TRANSY = 'N' IF (LRB1%K .GE. LRB2%K) THEN SIDE = 'L' ELSE SIDE = 'R' ENDIF ENDIF ENDIF IF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN IF (LRB1%K.EQ.0) THEN GOTO 1200 ENDIF SIDE = 'R' K_XY = LRB1%K TRANSY = 'N' Z => LRB2%Q X => LRB1%Q LDY = LRB1%K IF (SYM .EQ. 0) THEN Y => LRB1%R ELSE allocate(Y(LRB1%K,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%K Y(I,J) = LRB1%R(I,J) ENDDO ENDDO CALL SMUMPS_LRGEMM_SCALING(LRB1, Y, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF K_YZ = LRB2%N ENDIF IF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN IF (LRB2%K.EQ.0) THEN GOTO 1200 ENDIF SIDE = 'L' K_YZ = LRB2%K X => LRB1%Q TRANSY = 'T' K_XY = LRB1%N IF (SYM .EQ. 0) THEN Y => LRB2%R ELSE allocate(Y(LRB2%K,LRB2%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB2%K*LRB2%N GOTO 1570 ENDIF DO J=1,LRB2%N DO I=1,LRB2%K Y(I,J) = LRB2%R(I,J) ENDDO ENDDO CALL SMUMPS_LRGEMM_SCALING(LRB2, Y, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY = LRB2%K Z => LRB2%Q ENDIF IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .EQ. 0) THEN X => LRB1%Q ELSE allocate(X(LRB1%M,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%M X(I,J) = LRB1%Q(I,J) ENDDO ENDDO CALL SMUMPS_LRGEMM_SCALING(LRB1, X, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF SIDE = 'N' Z => LRB2%Q K_XY = LRB1%N ENDIF IF (LUA_ACTIVATED) THEN SAVE_K = LRB3%K IF (SIDE == 'L') THEN LRB3%K = LRB3%K+K_YZ ELSEIF (SIDE == 'R') THEN LRB3%K = LRB3%K+K_XY ENDIF ENDIF IF (SIDE == 'L') THEN ! LEFT: XY_YZ = X*Y; A = XY_YZ*Z IF (.NOT.LUA_ACTIVATED) THEN allocate(XY_YZ(LRB1%M,K_YZ),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*K_YZ GOTO 1570 ENDIF LDXY_YZ = LRB1%M ELSE IF (SAVE_K+K_YZ.GT.MAXI_RANK) THEN write(*,*) 'Internal error in SMUMPS_LRGEMM4 1a', & 'K_ACC+K_CUR>K_MAX:',SAVE_K,K_YZ,MAXI_RANK CALL MUMPS_ABORT() ENDIF IF (LRB3%M.NE.LRB1%M) THEN write(*,*) 'Internal error in SMUMPS_LRGEMM4 1b', & 'LRB1%M =/= LRB3%M',LRB1%M,LRB3%M CALL MUMPS_ABORT() ENDIF XY_YZ => LRB3%Q(1:LRB1%M,SAVE_K+1:SAVE_K+K_YZ) LDXY_YZ = MAXI_CLUSTER DO I=1,K_YZ LRB3%R(SAVE_K+I,1:LRB2%M) = Z(1:LRB2%M,I) ENDDO ENDIF CALL sgemm('N', TRANSY, LRB1%M, K_YZ, K_XY, ONE, & X(1,1), LRB1%M, Y(1,1), LDY, ZERO, XY_YZ(1,1), & LDXY_YZ) IF (.NOT.LUA_ACTIVATED) THEN CALL sgemm('N', 'T', LRB1%M, LRB2%M, K_YZ, ALPHA, & XY_YZ(1,1), LRB1%M, Z(1,1), LRB2%M, BETA, & A(POSELTT), NFRONT) deallocate(XY_YZ) ENDIF ELSEIF (SIDE == 'R') THEN ! RIGHT: XY_YZ = Y*Z; A = X*XY_YZ IF (.NOT.LUA_ACTIVATED) THEN allocate(XY_YZ(K_XY,LRB2%M),stat=allocok) IF (allocok > 0) THEN MREQ = K_XY*LRB2%M GOTO 1570 ENDIF LDXY_YZ = K_XY ELSE IF (SAVE_K+K_XY.GT.MAXI_RANK) THEN write(*,*) 'Internal error in SMUMPS_LRGEMM4 2a', & 'K_ACC+K_CUR>K_MAX:',SAVE_K,K_XY,MAXI_RANK CALL MUMPS_ABORT() ENDIF IF (LRB3%N.NE.LRB2%M) THEN write(*,*) 'Internal error in SMUMPS_LRGEMM4 2b', & 'LRB2%M =/= LRB3%N',LRB2%M,LRB3%N CALL MUMPS_ABORT() ENDIF XY_YZ => LRB3%R(SAVE_K+1:SAVE_K+K_XY,1:LRB2%M) LDXY_YZ = MAXI_RANK DO I=1,K_XY LRB3%Q(1:LRB1%M,SAVE_K+I) = X(1:LRB1%M,I) ENDDO ENDIF CALL sgemm(TRANSY, 'T', K_XY, LRB2%M, K_YZ, ONE, & Y(1,1), LDY, Z(1,1), LRB2%M, ZERO, XY_YZ(1,1), & LDXY_YZ) IF (.NOT.LUA_ACTIVATED) THEN CALL sgemm('N', 'N', LRB1%M, LRB2%M, K_XY, ALPHA, & X(1,1), LRB1%M, XY_YZ(1,1), K_XY, BETA, A(POSELTT), & NFRONT) deallocate(XY_YZ) ENDIF ELSE ! SIDE == 'N' : NONE; A = X*Z CALL sgemm('N', 'T', LRB1%M, LRB2%M, K_XY, ALPHA, & X(1,1), LRB1%M, Z(1,1), LRB2%M, BETA, A(POSELTT), & NFRONT) ENDIF GOTO 1580 1570 CONTINUE C Alloc NOT ok!! IFLAG = -13 IERROR = MREQ RETURN 1580 CONTINUE C Alloc ok!! IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .NE. 0) deallocate(X) ELSEIF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN IF (SYM .NE. 0) deallocate(Y) ELSEIF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .NE. 0) deallocate(Y) ELSE IF (SYM .NE. 0) deallocate(Y1) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN deallocate(XQ) deallocate(R_Y) ELSE deallocate(Y) ENDIF ENDIF 1200 CONTINUE END SUBROUTINE SMUMPS_LRGEMM4 SUBROUTINE SMUMPS_DECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, LorU, & COUNT_FLOPS) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK INTEGER(8), INTENT(IN) :: POSELTT LOGICAL, OPTIONAL :: COUNT_FLOPS LOGICAL :: COUNT_FLOPS_LOC INTEGER :: LorU REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) IF (present(COUNT_FLOPS)) THEN COUNT_FLOPS_LOC=COUNT_FLOPS ELSE COUNT_FLOPS_LOC=.TRUE. ENDIF CALL sgemm('N', 'N', ACC_LRB%M, ACC_LRB%N, ACC_LRB%K, & MONE, ACC_LRB%Q(1,1), MAXI_CLUSTER, ACC_LRB%R(1,1), & MAXI_RANK, ONE, A(POSELTT), NFRONT) ACC_LRB%K = 0 END SUBROUTINE SMUMPS_DECOMPRESS_ACC SUBROUTINE SMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & TOLEPS, TOL_OPT, KPERCENT, BUILDQ, LorU, CB_COMPRESS) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, LorU, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT INTEGER(8), INTENT(IN) :: POSELTT REAL, intent(in) :: TOLEPS LOGICAL, INTENT(OUT) :: BUILDQ LOGICAL, INTENT(IN) :: CB_COMPRESS REAL, ALLOCATABLE :: RWORK_RRQR(:) REAL, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: INFO, RANK, MAXRANK, LWORK INTEGER :: I, J, M, N INTEGER :: allocok, MREQ REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) M = ACC_LRB%M N = ACC_LRB%N MAXRANK = floor(real(M*N)/real(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) LWORK = N*(N+1) allocate(WORK_RRQR(LWORK), RWORK_RRQR(2*N), & TAU_RRQR(N), & JPVT_RRQR(N), stat=allocok) IF (allocok > 0) THEN MREQ = LWORK +4 *N GOTO 100 ENDIF DO I=1,N ACC_LRB%Q(1:M,I)= & - A(POSELTT+int(I-1,8)*int(NFRONT,8) : & POSELTT+int(I-1,8)*int(NFRONT,8) + int(M-1,8) ) END DO JPVT_RRQR = 0 CALL SMUMPS_TRUNCATED_RRQR(M, N, ACC_LRB%Q(1,1), & MAXI_CLUSTER, JPVT_RRQR(1), TAU_RRQR(1), & WORK_RRQR(1), & N, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK, MAXRANK, INFO, & BUILDQ) IF (BUILDQ) THEN DO J=1, N ACC_LRB%R(1:MIN(RANK,J),JPVT_RRQR(J)) = & ACC_LRB%Q(1:MIN(RANK,J),J) IF(J.LT.RANK) ACC_LRB%R(MIN(RANK,J)+1: & RANK,JPVT_RRQR(J))= ZERO END DO CALL sorgqr & (M, RANK, RANK, ACC_LRB%Q(1,1), & MAXI_CLUSTER, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) DO I=1,N A( POSELTT+int(I-1,8)*int(NFRONT,8) : & POSELTT+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) = ZERO END DO ACC_LRB%K = RANK CALL UPD_FLOP_COMPRESS(ACC_LRB%M, ACC_LRB%N, ACC_LRB%K, & ACC_LRB%ISLR, CB_COMPRESS=CB_COMPRESS) ELSE ACC_LRB%K = RANK ACC_LRB%ISLR = .FALSE. CALL UPD_FLOP_COMPRESS(ACC_LRB%M, ACC_LRB%N, ACC_LRB%K, & ACC_LRB%ISLR, CB_COMPRESS=CB_COMPRESS) ACC_LRB%ISLR = .TRUE. ACC_LRB%K = 0 ENDIF deallocate(JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & SMUMPS_COMPRESS_FR_UPDATES: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE SMUMPS_COMPRESS_FR_UPDATES SUBROUTINE SMUMPS_RECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER :: IFLAG, IERROR INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER,INTENT(INOUT) :: NEW_ACC_RANK INTEGER(8), INTENT(IN) :: POSELTT INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB REAL, intent(in) :: TOLEPS REAL, ALLOCATABLE:: RWORK_RRQR(:) REAL, ALLOCATABLE:: WORK_RRQR(:), TAU_RRQR(:) REAL, ALLOCATABLE, DIMENSION(:,:),TARGET:: Q1, R1, & Q2, R2 INTEGER, ALLOCATABLE :: JPVT_RRQR(:) TYPE(LRB_TYPE) :: LRB1, LRB2 INTEGER :: INFO, RANK1, RANK2, RANK, MAXRANK, LWORK LOGICAL :: BUILDQ, BUILDQ1, BUILDQ2, SKIP1, SKIP2 INTEGER :: I, J, M, N, K INTEGER :: allocok, MREQ REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) SKIP1 = .FALSE. SKIP2 = .FALSE. SKIP1 = .TRUE. 1500 CONTINUE M = ACC_LRB%M N = ACC_LRB%N K = ACC_LRB%K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) IF (.FALSE.) THEN CALL SMUMPS_RECOMPRESS_ACC_V2(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, & NEW_ACC_RANK) K = ACC_LRB%K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) SKIP1 = .TRUE. SKIP2 = K.EQ.0 ENDIF IF (SKIP1.AND.SKIP2) GOTO 1600 allocate(Q1(M,K), Q2(N,K), & WORK_RRQR(LWORK), & RWORK_RRQR(2*K), & TAU_RRQR(K), & JPVT_RRQR(K), stat=allocok) IF (allocok > 0) THEN MREQ = LWORK + M*N + N*K+ 4 * K GOTO 100 ENDIF IF (SKIP1) THEN BUILDQ1 = .FALSE. ELSE DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J) ENDDO ENDDO JPVT_RRQR = 0 CALL SMUMPS_TRUNCATED_RRQR(M, K, Q1(1,1), & M, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, RANK1, & MAXRANK, INFO, & BUILDQ1) ENDIF IF (BUILDQ1) THEN allocate(R1(RANK1,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK1*K GOTO 100 ENDIF DO J=1, K R1(1:MIN(RANK1,J),JPVT_RRQR(J)) = & Q1(1:MIN(RANK1,J),J) IF(J.LT.RANK1) R1(MIN(RANK1,J)+1: & RANK1,JPVT_RRQR(J))= ZERO END DO CALL sorgqr & (M, RANK1, RANK1, Q1(1,1), & M, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) ENDIF IF (SKIP2) THEN BUILDQ2 = .FALSE. ELSE DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J,I) ENDDO ENDDO JPVT_RRQR = 0 CALL SMUMPS_TRUNCATED_RRQR(N, K, Q2(1,1), & N, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK2, MAXRANK, INFO, & BUILDQ2) ENDIF IF (BUILDQ2) THEN allocate(R2(RANK2,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK2*K GOTO 100 ENDIF DO J=1, K R2(1:MIN(RANK2,J),JPVT_RRQR(J)) = & Q2(1:MIN(RANK2,J),J) IF(J.LT.RANK2) R2(MIN(RANK2,J)+1: & RANK2,JPVT_RRQR(J))= ZERO END DO CALL sorgqr & (N, RANK2, RANK2, Q2(1,1), & N, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) ENDIF CALL INIT_LRB(LRB1,RANK1,M,K,BUILDQ1) CALL INIT_LRB(LRB2,RANK2,N,K,BUILDQ2) IF (BUILDQ1.OR.BUILDQ2) THEN IF (BUILDQ1) THEN LRB1%R => R1 ELSE DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J) ENDDO ENDDO ENDIF LRB1%Q => Q1 IF (BUILDQ2) THEN LRB2%R => R2 ELSE DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J,I) ENDDO ENDDO ENDIF LRB2%Q => Q2 ACC_LRB%K = 0 CALL SMUMPS_LRGEMM4(MONE, LRB1, LRB2, ONE, & A, LA, POSELTT, NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS-1, TOLEPS, TOL_OPT, & KPERCENT_RMB, & RANK, BUILDQ, .TRUE., LRB3=ACC_LRB, & MAXI_RANK=MAXI_RANK, MAXI_CLUSTER=MAXI_CLUSTER) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(LRB1%M, LRB1%N, LRB1%K, LRB1%ISLR, & LRB2%M, LRB2%N, LRB2%K, LRB2%ISLR, & MIDBLK_COMPRESS-1, RANK, BUILDQ, & .TRUE., .FALSE., REC_ACC=.TRUE.) ENDIF IF (.NOT. SKIP1) & CALL UPD_FLOP_COMPRESS(LRB1%M, LRB1%N, LRB1%K, & LRB1%ISLR, REC_ACC=.TRUE.) IF (.NOT. SKIP2) & CALL UPD_FLOP_COMPRESS(LRB2%M, LRB2%N, LRB2%K, & LRB2%ISLR, REC_ACC=.TRUE.) deallocate(Q1,Q2) IF (BUILDQ1) deallocate(R1) IF (BUILDQ2) deallocate(R2) deallocate(JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) IF (SKIP1.AND.(RANK2.GT.0)) THEN SKIP1 = .FALSE. SKIP2 = .TRUE. GOTO 1500 ENDIF 1600 CONTINUE NEW_ACC_RANK = 0 RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & SMUMPS_RECOMPRESS_ACC: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE SMUMPS_RECOMPRESS_ACC RECURSIVE SUBROUTINE SMUMPS_RECOMPRESS_ACC_NARYTREE( & ACC_LRB, MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, & KPERCENT_LUA, K478, RANK_LIST, POS_LIST, NB_NODES, & LEVEL, ACC_TMP) TYPE(LRB_TYPE),TARGET,INTENT(INOUT) :: ACC_LRB TYPE(LRB_TYPE),TARGET,INTENT(INOUT),OPTIONAL :: ACC_TMP INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER(8), INTENT(IN) :: POSELTT INTEGER(8) :: KEEP8(150) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB REAL, intent(in) :: TOLEPS INTEGER,INTENT(IN) :: K478, NB_NODES, LEVEL INTEGER,INTENT(INOUT) :: RANK_LIST(NB_NODES), POS_LIST(NB_NODES) TYPE(LRB_TYPE) :: LRB, ACC_NEW TYPE(LRB_TYPE), POINTER :: LRB_PTR LOGICAL :: RESORT INTEGER :: I, J, M, N, L, NODE_RANK, NARY, IOFF, IMAX, CURPOS INTEGER :: NB_NODES_NEW, KTOT, NEW_ACC_RANK INTEGER, ALLOCATABLE :: RANK_LIST_NEW(:), POS_LIST_NEW(:) REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) INTEGER :: allocok RESORT = .FALSE. M = ACC_LRB%M N = ACC_LRB%N NARY = -K478 IOFF = 0 NB_NODES_NEW = NB_NODES/NARY IF (NB_NODES_NEW*NARY.NE.NB_NODES) THEN NB_NODES_NEW = NB_NODES_NEW + 1 ENDIF ALLOCATE(RANK_LIST_NEW(NB_NODES_NEW),POS_LIST_NEW(NB_NODES_NEW), & stat=allocok) IF (allocok > 0) THEN write(*,*) 'Allocation error of RANK_LIST_NEW/POS_LIST_NEW ', & 'in SMUMPS_RECOMPRESS_ACC_NARYTREE' call MUMPS_ABORT() ENDIF DO J=1,NB_NODES_NEW NODE_RANK = RANK_LIST(IOFF+1) CURPOS = POS_LIST(IOFF+1) IMAX = MIN(NARY,NB_NODES-IOFF) IF (IMAX.GE.2) THEN DO I=2,IMAX IF (POS_LIST(IOFF+I).NE.CURPOS+NODE_RANK) THEN DO L=0,RANK_LIST(IOFF+I)-1 ACC_LRB%Q(1:M,CURPOS+NODE_RANK+L) = & ACC_LRB%Q(1:M,POS_LIST(IOFF+I)+L) ACC_LRB%R(CURPOS+NODE_RANK+L,1:N) = & ACC_LRB%R(POS_LIST(IOFF+I)+L,1:N) ENDDO POS_LIST(IOFF+I) = CURPOS+NODE_RANK ENDIF NODE_RANK = NODE_RANK+RANK_LIST(IOFF+I) ENDDO CALL INIT_LRB(LRB,NODE_RANK,M,N,.TRUE.) IF (.NOT.RESORT.OR.LEVEL.EQ.0) THEN LRB%Q => ACC_LRB%Q(1:M,CURPOS:CURPOS+NODE_RANK) LRB%R => ACC_LRB%R(CURPOS:CURPOS+NODE_RANK,1:N) ELSE LRB%Q => ACC_TMP%Q(1:M,CURPOS:CURPOS+NODE_RANK) LRB%R => ACC_TMP%R(CURPOS:CURPOS+NODE_RANK,1:N) ENDIF NEW_ACC_RANK = NODE_RANK-RANK_LIST(IOFF+1) IF (NEW_ACC_RANK.GT.0) THEN CALL SMUMPS_RECOMPRESS_ACC(LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF RANK_LIST_NEW(J) = LRB%K POS_LIST_NEW(J) = CURPOS ELSE RANK_LIST_NEW(J) = NODE_RANK POS_LIST_NEW(J) = CURPOS ENDIF IOFF = IOFF+IMAX ENDDO IF (NB_NODES_NEW.GT.1) THEN IF (RESORT) THEN KTOT = SUM(RANK_LIST_NEW) CALL INIT_LRB(ACC_NEW,KTOT,M,N,.TRUE.) ALLOCATE(ACC_NEW%Q(MAXI_CLUSTER,MAXI_RANK), & ACC_NEW%R(MAXI_RANK,MAXI_CLUSTER), stat=allocok) IF (allocok > 0) THEN write(*,*) 'Allocation error of ACC_NEW%Q/ACC_NEW%R ', & 'in SMUMPS_RECOMPRESS_ACC_NARYTREE' call MUMPS_ABORT() ENDIF CALL MUMPS_SORT_INT(NB_NODES_NEW, RANK_LIST_NEW, & POS_LIST_NEW) CURPOS = 1 IF (LEVEL.EQ.0) THEN LRB_PTR => ACC_LRB ELSE LRB_PTR => ACC_TMP ENDIF DO J=1,NB_NODES_NEW DO L=0,RANK_LIST_NEW(J)-1 ACC_NEW%Q(1:M,CURPOS+L) = & LRB_PTR%Q(1:M,POS_LIST_NEW(J)+L) ACC_NEW%R(CURPOS+L,1:N) = & LRB_PTR%R(POS_LIST_NEW(J)+L,1:N) ENDDO POS_LIST_NEW(J) = CURPOS CURPOS = CURPOS + RANK_LIST_NEW(J) ENDDO IF (LEVEL.GT.0) THEN CALL DEALLOC_LRB(ACC_TMP, KEEP8, 4) ENDIF CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST_NEW, POS_LIST_NEW, NB_NODES_NEW, & LEVEL+1, ACC_NEW) ELSE CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST_NEW, POS_LIST_NEW, NB_NODES_NEW, LEVEL+1) ENDIF ELSE IF (POS_LIST_NEW(1).NE.1) THEN write(*,*) 'Internal error in ', & 'SMUMPS_RECOMPRESS_ACC_NARYTREE', POS_LIST_NEW(1) ENDIF ACC_LRB%K = RANK_LIST_NEW(1) IF (RESORT.AND.LEVEL.GT.0) THEN DO L=1,ACC_LRB%K DO I=1,M ACC_LRB%Q(I,L) = ACC_TMP%Q(I,L) ENDDO DO I=1,N ACC_LRB%R(L,I) = ACC_TMP%R(L,I) ENDDO ENDDO CALL DEALLOC_LRB(ACC_TMP, KEEP8, 4) ENDIF ENDIF DEALLOCATE(RANK_LIST_NEW, POS_LIST_NEW) END SUBROUTINE SMUMPS_RECOMPRESS_ACC_NARYTREE SUBROUTINE SMUMPS_RECOMPRESS_ACC_V2(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER,INTENT(INOUT) :: NEW_ACC_RANK INTEGER(8), INTENT(IN) :: POSELTT INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB REAL, intent(in) :: TOLEPS REAL, ALLOCATABLE :: RWORK_RRQR(:) REAL, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) REAL, ALLOCATABLE, DIMENSION(:,:), TARGET :: & Q1, R1, Q2, PROJ INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: INFO, RANK1, MAXRANK, LWORK LOGICAL :: BUILDQ1 INTEGER :: I, J, M, N, K, K1 INTEGER :: allocok, MREQ REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) M = ACC_LRB%M N = ACC_LRB%N K = NEW_ACC_RANK K1 = ACC_LRB%K - K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) allocate(Q1(M,K), PROJ(K1, K), & WORK_RRQR(LWORK), RWORK_RRQR(2*K), & TAU_RRQR(K), & JPVT_RRQR(K), stat=allocok) IF (allocok > 0) THEN MREQ = M * K + K1 * K + LWORK + 4 * K GOTO 100 ENDIF DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J+K1) ENDDO ENDDO CALL sgemm('T', 'N', K1, K, M, ONE, ACC_LRB%Q(1,1), & MAXI_CLUSTER, Q1(1,1), M, ZERO, PROJ(1,1), K1) CALL sgemm('N', 'N', M, K, K1, MONE, ACC_LRB%Q(1,1), & MAXI_CLUSTER, PROJ(1,1), K1, ONE, Q1(1,1), M) JPVT_RRQR = 0 CALL SMUMPS_TRUNCATED_RRQR(M, K, Q1(1,1), & M, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK1, MAXRANK, INFO, & BUILDQ1) IF (BUILDQ1) THEN allocate(Q2(N,K), stat=allocok) IF (allocok > 0) THEN MREQ = N*K GOTO 100 ENDIF DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J+K1,I) ENDDO ENDDO CALL sgemm('N', 'T', K1, N, K, ONE, PROJ(1,1), K1, & Q2(1,1), N, ONE, ACC_LRB%R(1,1), MAXI_RANK) IF (RANK1.GT.0) THEN allocate(R1(RANK1,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK1*K GOTO 100 ENDIF DO J=1, K R1(1:MIN(RANK1,J),JPVT_RRQR(J)) = & Q1(1:MIN(RANK1,J),J) IF(J.LT.RANK1) R1(MIN(RANK1,J)+1: & RANK1,JPVT_RRQR(J))= ZERO END DO CALL sorgqr & (M, RANK1, RANK1, Q1(1,1), & M, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) DO J=1,K DO I=1,M ACC_LRB%Q(I,J+K1) = Q1(I,J) ENDDO ENDDO CALL sgemm('N', 'T', RANK1, N, K, ONE, R1(1,1), RANK1, & Q2(1,1), N, ZERO, ACC_LRB%R(K1+1,1), MAXI_RANK) deallocate(R1) ENDIF deallocate(Q2) ACC_LRB%K = K1 + RANK1 ENDIF deallocate(PROJ) deallocate(Q1, JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & SMUMPS_RECOMPRESS_ACC_V2: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE SMUMPS_RECOMPRESS_ACC_V2 SUBROUTINE MAX_CLUSTER(CUT,CUT_SIZE,MAXI_CLUSTER) INTEGER, intent(in) :: CUT_SIZE INTEGER, intent(out) :: MAXI_CLUSTER INTEGER, DIMENSION(:), intent(in) :: CUT INTEGER :: I MAXI_CLUSTER = 0 DO I = 1, CUT_SIZE IF (CUT(I+1) - CUT(I) .GE. MAXI_CLUSTER) THEN MAXI_CLUSTER = CUT(I+1) - CUT(I) END IF END DO END SUBROUTINE MAX_CLUSTER SUBROUTINE SMUMPS_GET_LUA_ORDER(NB_BLOCKS, ORDER, RANK, IWHANDLER, & SYM, FS_OR_CB, I, J, FRFR_UPDATES, & LBANDSLAVE_IN, K474, BLR_U_COL) C ----------- C Parameters C ----------- INTEGER, INTENT(IN) :: NB_BLOCKS, IWHANDLER, SYM, FS_OR_CB, I, J INTEGER, INTENT(OUT) :: ORDER(NB_BLOCKS), RANK(NB_BLOCKS), & FRFR_UPDATES LOGICAL, OPTIONAL, INTENT(IN) :: LBANDSLAVE_IN INTEGER, OPTIONAL, INTENT(IN) :: K474 TYPE(LRB_TYPE), POINTER, OPTIONAL :: BLR_U_COL(:) C ----------- C Local variables C ----------- INTEGER :: K, IND_L, IND_U LOGICAL :: LBANDSLAVE TYPE(LRB_TYPE), POINTER :: BLR_L(:), BLR_U(:) IF (PRESENT(LBANDSLAVE_IN)) THEN LBANDSLAVE = LBANDSLAVE_IN ELSE LBANDSLAVE = .FALSE. ENDIF IF ((SYM.NE.0).AND.(FS_OR_CB.EQ.0).AND.(J.NE.0)) THEN write(6,*) 'Internal error in SMUMPS_GET_LUA_ORDER', & 'SYM, FS_OR_CB, J = ',SYM,FS_OR_CB,J CALL MUMPS_ABORT() ENDIF FRFR_UPDATES = 0 DO K = 1, NB_BLOCKS ORDER(K) = K IF (FS_OR_CB.EQ.0) THEN ! FS IF (J.EQ.0) THEN ! L panel IND_L = NB_BLOCKS+I-K IND_U = NB_BLOCKS+1-K ELSE ! U panel IND_L = NB_BLOCKS+1-K IND_U = NB_BLOCKS+I-K ENDIF ELSE ! CB IND_L = I-K IND_U = J-K ENDIF IF (LBANDSLAVE) THEN IND_L = I IF (K474.GE.2) THEN IND_U = K ENDIF ENDIF CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, ! L Panel & K, BLR_L) IF (SYM.EQ.0) THEN IF (LBANDSLAVE.AND.K474.GE.2) THEN BLR_U => BLR_U_COL ELSE CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, ! L Panel & K, BLR_U) ENDIF ELSE BLR_U => BLR_L ENDIF IF (BLR_L(IND_L)%ISLR) THEN IF (BLR_U(IND_U)%ISLR) THEN RANK(K) = min(BLR_L(IND_L)%K, BLR_U(IND_U)%K) ELSE RANK(K) = BLR_L(IND_L)%K ENDIF ELSE IF (BLR_U(IND_U)%ISLR) THEN RANK(K) = BLR_U(IND_U)%K ELSE RANK(K) = -1 FRFR_UPDATES = FRFR_UPDATES + 1 ENDIF ENDIF ENDDO CALL MUMPS_SORT_INT(NB_BLOCKS, RANK, ORDER) END SUBROUTINE SMUMPS_GET_LUA_ORDER SUBROUTINE SMUMPS_BLR_ASM_NIV1 (A, LA, POSEL1, NFRONT, NASS1, & IWHANDLER, SON_IW, LIW, LSTK, NELIM, K1, K2, SYM, & KEEP, KEEP8, OPASSW) C C Purpose C ======= C C Called by a level 1 master assembling the contribution C block of a level 1 son that has been BLR-compressed C C C Parameters C ========== C INTEGER(8) :: LA, POSEL1 INTEGER :: LIW, NFRONT, NASS1, LSTK, NELIM, K1, K2, IWHANDLER REAL :: A(LA) C INTEGER :: SON_IW(LIW) INTEGER :: SON_IW(:) ! contiguity information lost but no copy INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER :: SYM DOUBLE PRECISION, INTENT(INOUT) :: OPASSW C C Local variables C =============== C REAL, ALLOCATABLE :: SON_A(:) INTEGER(8) :: APOS, SON_APOS, IACHK, JJ2, NFRONT8 INTEGER :: KK, KK1, allocok, SON_LA TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:), LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_DYNAMIC INTEGER :: NB_INCB, NB_INASM, NB_BLR, I, J, M, N, II, NPIV, & IBIS, IBIS_END, FIRST_ROW, LAST_ROW, FIRST_COL, LAST_COL, & SON_LDA DOUBLE PRECISION :: PROMOTE_COST REAL :: ONE, ZERO PARAMETER (ONE = 1.0E0) PARAMETER (ZERO = 0.0D0) CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_DYN(IWHANDLER, & BEGS_BLR_DYNAMIC) CALL SMUMPS_BLR_RETRIEVE_CB_LRB(IWHANDLER, CB_LRB) NB_BLR = size(BEGS_BLR_DYNAMIC)-1 NB_INCB = size(CB_LRB,1) NB_INASM = NB_BLR - NB_INCB NPIV = BEGS_BLR_DYNAMIC(NB_INASM+1)-1 NFRONT8 = int(NFRONT,8) IF (SYM.EQ.0) THEN IBIS_END = NB_INCB*NB_INCB ELSE IBIS_END = NB_INCB*(NB_INCB+1)/2 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP DO PRIVATE(IBIS, I, J, M, N, SON_LA, SON_LDA, FIRST_ROW, !$OMP& LAST_ROW, FIRST_COL, LAST_COL, LRB, SON_A, II, KK, !$OMP& APOS, IACHK, KK1, JJ2, PROMOTE_COST, allocok, SON_APOS) #endif DO IBIS = 1,IBIS_END C Determining I,J from IBIS IF (SYM.EQ.0) THEN I = (IBIS-1)/NB_INCB+1 J = IBIS - (I-1)*NB_INCB ELSE I = ceiling((1.0D0+sqrt(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 ENDIF I = I+NB_INASM J = J+NB_INASM IF (I.EQ.NB_INASM+1) THEN C first CB block, add NELIM because FIRST_ROW starts at NELIM+1 FIRST_ROW = BEGS_BLR_DYNAMIC(I)-NPIV+NELIM ELSE FIRST_ROW = BEGS_BLR_DYNAMIC(I)-NPIV ENDIF LAST_ROW = BEGS_BLR_DYNAMIC(I+1)-1-NPIV M=LAST_ROW-FIRST_ROW+1 FIRST_COL = BEGS_BLR_DYNAMIC(J)-NPIV LAST_COL = BEGS_BLR_DYNAMIC(J+1)-1-NPIV N = BEGS_BLR_DYNAMIC(J+1)-BEGS_BLR_DYNAMIC(J) SON_APOS = 1_8 SON_LA = M*N SON_LDA = N LRB => CB_LRB(I-NB_INASM,J-NB_INASM) IF (LRB%ISLR.AND.LRB%K.EQ.0) THEN C No need to perform extend-add CALL DEALLOC_LRB(LRB, KEEP8, KEEP(34)) NULLIFY(LRB) CYCLE ENDIF allocate(SON_A(SON_LA),stat=allocok) IF (allocok.GT.0) THEN write(*,*) 'Not enough memory in SMUMPS_BLR_ASM_NIV1', & ", Memory requested = ", SON_LA CALL MUMPS_ABORT() ENDIF C decompress block IF (LRB%ISLR) THEN CALL sgemm('T', 'T', N, M, LRB%K, ONE, LRB%R(1,1), LRB%K, & LRB%Q(1,1), M, ZERO, SON_A(SON_APOS), SON_LDA) PROMOTE_COST = 2.0D0*M*N*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE IF (I.EQ.J.AND.SYM.NE.0) THEN C Diag block and LDLT, copy only lower half IF (J-NB_INASM.EQ.1.AND.NELIM.GT.0) THEN C The first diagonal block is rectangular !! C with NELIM more cols than rows DO II=1,M DO KK=1,II+NELIM SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ELSE DO II=1,M DO KK=1,II SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ENDIF ELSE DO II=1,M DO KK=1,N SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ENDIF ENDIF C Deallocate block CALL DEALLOC_LRB(LRB, KEEP8, KEEP(34)) NULLIFY(LRB) C extend add in father IF (SYM.NE.0.AND.J-NB_INASM.EQ.1.AND.NELIM.GT.0) THEN C Case of LDLT with NELIM: first-block column is treated C differently as the NELIM are assembled at the end of the C father DO KK = FIRST_ROW, LAST_ROW IACHK = 1_8 + int(KK-FIRST_ROW,8)*int(SON_LDA,8) IF (SON_IW(KK+K1-1).LE.NASS1) THEN C Fully summed row of the father => permute destination in C father, symmetric swap to be done C First NELIM columns APOS = POSEL1 + int(SON_IW(KK+K1-1),8) - 1_8 DO KK1 = FIRST_COL, FIRST_COL+NELIM-1 JJ2 = APOS + int(SON_IW(K1+KK1-1)-1,8)*NFRONT8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO C Remaining columns APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 C DO KK1 = FIRST_COL+NELIM, LAST_COL C In case I=J and first block, one may have C LAST_COL > KK, but only lower triangular part C should be assembled. We use min(LAST_COL,KK) C below index to cover this case. DO KK1 = FIRST_COL+NELIM, min(LAST_COL,KK) JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ELSE APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 DO KK1 = FIRST_COL, min(LAST_COL,KK) JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ENDIF ENDDO ELSE C Case of LDLT without NELIM or LU: everything is simpler DO KK = FIRST_ROW, LAST_ROW APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 IACHK = 1_8 + int(KK-FIRST_ROW,8)*int(SON_LDA,8) IF (I.EQ.J.AND.SYM.NE.0) THEN C LDLT diag block: assemble only lower half DO KK1 = FIRST_COL, KK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ELSE DO KK1 = FIRST_COL, LAST_COL JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ENDIF ENDDO ENDIF C Deallocate SON_A DEALLOCATE(SON_A) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO !$OMP END PARALLEL #endif CALL SMUMPS_BLR_FREE_CB_LRB(IWHANDLER, C Only CB_LRB structure is left to deallocate & .TRUE., KEEP8, KEEP(34)) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN C Case of FR solve: the BLR structure could not be freed C in SMUMPS_END_FACTO_SLAVE and should be freed here C Not reachable in case of error: set INFO1 to 0 CALL SMUMPS_BLR_END_FRONT(IWHANDLER, 0, KEEP8, KEEP(34), & MTK405=KEEP(405)) ENDIF END SUBROUTINE SMUMPS_BLR_ASM_NIV1 END MODULE SMUMPS_LR_CORE C -------------------------------------------------------------------- SUBROUTINE SMUMPS_TRUNCATED_RRQR( M, N, A, LDA, JPVT, TAU, WORK, & LDW, RWORK, TOLEPS, TOL_OPT, RANK, MAXRANK, INFO, & ISLR) C This routine computes a Rank-Revealing QR factorization of a dense C matrix A. The factorization is truncated when the absolute value of C a diagonal coefficient of the R factor becomes smaller than a C prescribed threshold TOLEPS. The resulting partial Q and R factors C provide a rank-k approximation of the input matrix A with accuracy C TOLEPS. C C This routine is obtained by merging the LAPACK C (http://www.netlib.org/lapack/) CGEQP3 and CLAQPS routines and by C applying a minor modification to the outer factorization loop in C order to stop computations as soon as possible when the required C accuracy is reached. C C Copyright (c) 1992-2017 The University of Tennessee and The C University of Tennessee Research Foundation. All rights reserved. C Copyright (c) 2000-2017 The University of California Berkeley. C All rights reserved. C Copyright (c) 2006-2017 The University of Colorado Denver. C All rights reserved. C C Redistribution and use in source and binary forms, with or without C modification, are permitted provided that the following conditions C are met: C C - Redistributions of source code must retain the above copyright C notice, this list of conditions and the following disclaimer. C C - Redistributions in binary form must reproduce the above C copyright notice, this list of conditions and the following C disclaimer listed in this license in the documentation and/or C other materials provided with the distribution. C C - Neither the name of the copyright holders nor the names of its C contributors may be used to endorse or promote products derived from C this software without specific prior written permission. C C The copyright holders provide no reassurances that the source code C provided does not infringe any patent, copyright, or any other C intellectual property rights of third parties. The copyright holders C disclaim any liability to any recipient for claims brought against C recipient by any third party for infringement of that parties C intellectual property rights. C C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. C IMPLICIT NONE C INTEGER :: INFO, LDA, LDW, M, N, RANK, MAXRANK C TOL_OPT controls the tolerance option used C >0 => use 2-norm (||.||_X = ||.||_2) C <0 => use Frobenius-norm (||.||_X = ||.||_F) C Furthermore, depending on abs(TOL_OPT): C 1 => absolute: ||B_{I(k+1:end),J(k+1:end)}||_X <= TOLEPS C 2 => relative to 2-norm of the compressed block: C ||B_{I(k+1:end),J(k+1:end)}||_X <= TOLEPS*||B_{I,J}||_2 C 3 => relative to the max of the 2-norms of the row and column diagonal blocks C ||B_{I(k+1:end),J{k+1:end}}||_X <= TOLEPS*max(||B_{I,I}||_2,||B_{J,J}||_2) C 4 => relative to the sqrt of product of the 2-norms of the row and column diagonal blocks C ||B_{I(k+1:end),J{k+1:end}}||_X <= TOLEPS*sqrt(||B_{I,I}||_2*||B_{J,J}||_2) INTEGER :: TOL_OPT REAL :: TOLEPS INTEGER :: JPVT(*) REAL :: RWORK(*) REAL :: A(LDA,*), TAU(*) REAL :: WORK(LDW,*) LOGICAL :: ISLR REAL :: TOLEPS_EFF, TRUNC_ERR INTEGER, PARAMETER :: INB=1, INBMIN=2 INTEGER :: J, JB, MINMN, NB INTEGER :: OFFSET, ITEMP INTEGER :: LSTICC, PVT, K, RK REAL :: TEMP, TEMP2, TOL3Z REAL :: AKK LOGICAL INADMISSIBLE REAL, PARAMETER :: RZERO=0.0E+0, RONE=1.0E+0 REAL :: ZERO REAL :: ONE PARAMETER ( ONE = 1.0E+0 ) PARAMETER ( ZERO = 0.0E+0 ) REAL :: slamch INTEGER :: ilaenv, isamax EXTERNAL :: isamax, slamch EXTERNAL sgeqrf, sormqr, xerbla EXTERNAL ilaenv EXTERNAL sgemm, sgemv, slarfg, sswap REAL, EXTERNAL :: snrm2 INFO = 0 ISLR = .FALSE. IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.EQ.0 ) THEN IF( LDW.LT.N ) THEN INFO = -8 END IF END IF IF( INFO.NE.0 ) THEN WRITE(*,999) -INFO RETURN END IF MINMN = MIN(M,N) IF( MINMN.EQ.0 ) THEN RANK = 0 RETURN END IF NB = ilaenv( INB, 'CGEQRF', ' ', M, N, -1, -1 ) SELECT CASE(abs(TOL_OPT)) CASE(1) TOLEPS_EFF = TOLEPS CASE(2) C TOLEPS_EFF will be computed at step K=1 below CASE DEFAULT write(*,*) 'Internal error in SMUMPS_TRUNCATED_RRQR: TOL_OPT =', & TOL_OPT CALL MUMPS_ABORT() END SELECT TOLEPS_EFF = TOLEPS C C Avoid pointers (and TARGET attribute on RWORK/WORK) C because of implicit interface. An implicit interface C is needed to avoid intermediate array copies C VN1 => RWORK(1:N) C VN2 => RWORK(N+1:2*N) C AUXV => WORK(1:LDW,1:1) C F => WORK(1:LDW,2:NB+1) C LDF = LDW * Initialize partial column norms. The first N elements of work * store the exact column norms. DO J = 1, N C VN1( J ) = snrm2( M, A( 1, J ), 1 ) RWORK( J ) = snrm2( M, A( 1, J ), 1 ) C VN2( J ) = VN1( J ) RWORK( N + J ) = RWORK( J ) JPVT(J) = J END DO IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for first step C TRUNC_ERR = snrm2( N, VN1( 1 ), 1 ) TRUNC_ERR = snrm2( N, RWORK( 1 ), 1 ) ENDIF OFFSET = 0 TOL3Z = SQRT(slamch('Epsilon')) DO JB = MIN(NB,MINMN-OFFSET) LSTICC = 0 K = 0 DO IF(K.EQ.JB) EXIT K = K+1 RK = OFFSET+K C PVT = ( RK-1 ) + ISAMAX( N-RK+1, VN1( RK ), 1 ) PVT = ( RK-1 ) + isamax( N-RK+1, RWORK( RK ), 1 ) IF (RK.EQ.1) THEN C IF (abs(TOL_OPT).EQ.2) TOLEPS_EFF = VN1(PVT)*TOLEPS IF (abs(TOL_OPT).EQ.2) TOLEPS_EFF = RWORK(PVT)*TOLEPS ENDIF IF (TOL_OPT.GT.0) THEN C TRUNC_ERR = VN1(PVT) TRUNC_ERR = RWORK(PVT) C ELSE C TRUNC_ERR has been already computed at previous step ENDIF IF(TRUNC_ERR.LT.TOLEPS_EFF) THEN RANK = RK-1 ISLR = .TRUE. RETURN ENDIF INADMISSIBLE = (RK.GT.MAXRANK) IF (INADMISSIBLE) THEN RANK = RK INFO = RK ISLR = .FALSE. RETURN END IF IF( PVT.NE.RK ) THEN CALL sswap( M, A( 1, PVT ), 1, A( 1, RK ), 1 ) c CALL sswap( K-1, F( PVT-OFFSET, 1 ), LDF, c & F( K, 1 ), LDF ) CALL sswap( K-1, WORK( PVT-OFFSET, 2 ), LDW, & WORK( K, 2 ), LDW ) ITEMP = JPVT(PVT) JPVT(PVT) = JPVT(RK) JPVT(RK) = ITEMP C VN1(PVT) = VN1(RK) C VN2(PVT) = VN2(RK) RWORK(PVT) = RWORK(RK) RWORK(N+PVT) = RWORK(N+RK) END IF * Apply previous Householder reflectors to column K: * A(RK:M,RK) := A(RK:M,RK) - A(RK:M,OFFSET+1:RK-1)*F(K,1:K-1)**H. IF( K.GT.1 ) THEN CALL sgemv( 'No transpose', M-RK+1, K-1, -ONE, C & A(RK,OFFSET+1), LDA, F(K,1), LDF, & A(RK,OFFSET+1), LDA, WORK(K,2), LDW, & ONE, A(RK,RK), 1 ) END IF * Generate elementary reflector H(k). IF( RK.LT.M ) THEN CALL slarfg( M-RK+1, A(RK,RK), A(RK+1,RK), 1, TAU(RK) ) ELSE CALL slarfg( 1, A(RK,RK), A(RK,RK), 1, TAU(RK) ) END IF AKK = A(RK,RK) A(RK,RK) = ONE * Compute Kth column of F: * F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**H*A(RK:M,K). IF( RK.LT.N ) THEN CALL sgemv( 'Transpose', M-RK+1, N-RK, TAU(RK), & A(RK,RK+1), LDA, A(RK,RK), 1, ZERO, C & F( K+1, K ), 1 ) & WORK( K+1, K+1 ), 1 ) END IF * Padding F(1:K,K) with zeros. DO J = 1, K C F( J, K ) = ZERO WORK( J, K+1 ) = ZERO END DO * Incremental updating of F: * F(1:N,K) := F(1:N-OFFSET,K) - * tau(RK)*F(1:N,1:K-1)*A(RK:M,OFFSET+1:RK-1)**H*A(RK:M,RK). IF( K.GT.1 ) THEN CALL sgemv( 'Transpose', M-RK+1, K-1, -TAU(RK), & A(RK,OFFSET+1), LDA, A(RK,RK), 1, ZERO, & WORK(1,1), 1 ) C & AUXV(1,1), 1 ) CALL sgemv( 'No transpose', N-OFFSET, K-1, ONE, & WORK(1,2), LDW, WORK(1,1), 1, ONE, WORK(1,K+1), 1 ) C & F(1,1), LDF, AUXV(1,1), 1, ONE, F(1,K), 1 ) END IF * Update the current row of A: * A(RK,RK+1:N) := A(RK,RK+1:N) - A(RK,OFFSET+1:RK)*F(K+1:N,1:K)**H. IF( RK.LT.N ) THEN C CALL sgemv( 'No Transpose', N-RK, K, -ONE, F( K+1, 1 ), CALL sgemv( 'No Transpose', N-RK, K, -ONE, WORK( K+1,2 ), & LDW, & A( RK, OFFSET+1 ), LDA, ONE, A( RK, RK+1 ), LDA ) END IF * Update partial column norms. * IF( RK.LT.MINMN ) THEN DO J = RK + 1, N C IF( VN1( J ).NE.RZERO ) THEN IF( RWORK( J ).NE.RZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * C TEMP = ABS( A( RK, J ) ) / VN1( J ) TEMP = ABS( A( RK, J ) ) / RWORK( J ) TEMP = MAX( RZERO, ( RONE+TEMP )*( RONE-TEMP ) ) C TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 TEMP2 = TEMP*( RWORK( J ) / RWORK( N+J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN C VN2( J ) = REAL( LSTICC ) RWORK( N+J ) = REAL( LSTICC ) LSTICC = J ELSE C VN1( J ) = VN1( J )*SQRT( TEMP ) RWORK( J ) = RWORK( J )*SQRT( TEMP ) END IF END IF END DO END IF A( RK, RK ) = AKK IF (LSTICC.NE.0) EXIT IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for next step C TRUNC_ERR = snrm2( N-RK, VN1( RK+1 ), 1 ) TRUNC_ERR = snrm2( N-RK, RWORK( RK+1 ), 1 ) ENDIF END DO * Apply the block reflector to the rest of the matrix: * A(RK+1:M,RK+1:N) := A(RK+1:M,RK+1:N) - * A(RK+1:M,OFFSET+1:RK)*F(K+1:N-OFFSET,1:K)**H. IF( RK.LT.MIN(N,M) ) THEN CALL sgemm( 'No transpose', 'Transpose', M-RK, & N-RK, K, -ONE, A(RK+1,OFFSET+1), LDA, C & F(K+1,1), LDF, ONE, A(RK+1,RK+1), LDA ) & WORK(K+1,2), LDW, ONE, A(RK+1,RK+1), LDA ) END IF * Recomputation of difficult columns. DO WHILE( LSTICC.GT.0 ) C ITEMP = NINT( VN2( LSTICC ) ) ITEMP = NINT( RWORK( N + LSTICC ) ) C VN1( LSTICC ) = snrm2( M-RK, A( RK+1, LSTICC ), 1 ) RWORK( LSTICC ) = snrm2( M-RK, A( RK+1, LSTICC ), 1 ) * * NOTE: The computation of RWORK( LSTICC ) relies on the fact that * SNRM2 does not fail on vectors with norm below the value of * SQRT(DLAMCH('S')) * C VN2( LSTICC ) = VN1( LSTICC ) RWORK( N + LSTICC ) = RWORK( LSTICC ) LSTICC = ITEMP END DO IF(RK.GE.MINMN) EXIT OFFSET = RK IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for next step C TRUNC_ERR = snrm2( N-RK, VN1( RK+1 ), 1 ) TRUNC_ERR = snrm2( N-RK, RWORK( RK+1 ), 1 ) ENDIF END DO RANK = RK ISLR = .NOT.(RK.GT.MAXRANK) RETURN 999 FORMAT ('On entry to SMUMPS_TRUNCATED_RRQR, parameter number', & I2,' had an illegal value') END SUBROUTINE SMUMPS_TRUNCATED_RRQR MUMPS_5.8.1/src/smumps_save_restore_files.F0000664000175000017500000002740715042446437020646 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if ! defined(NO_SAVE_RESTORE) MODULE SMUMPS_SAVE_RESTORE_FILES USE SMUMPS_STRUC_DEF IMPLICIT NONE INTEGER, PARAMETER :: LEN_SAVE_FILE = 1318 CONTAINS SUBROUTINE MUMPS_READ_HEADER(fileunit, ierr, size_read, SIZE_INT & ,SIZE_INT8, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE & ,READ_ARITH, READ_INT_TYPE_64 & ,READ_OOC_FILE_NAME_LENGTH, READ_OOC_FIRST_FILE_NAME & ,READ_HASH,READ_SYM,READ_PAR,READ_NPROCS & ,FORTRAN_VERSION_OK) INTEGER,intent(in) :: fileunit INTEGER,intent(out) :: ierr INTEGER(8), intent(inout) :: size_read INTEGER,intent(in) :: SIZE_INT, SIZE_INT8 INTEGER(8), intent(out) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE CHARACTER, intent(out) :: READ_ARITH LOGICAL, intent(out) :: READ_INT_TYPE_64 INTEGER, intent(out) :: READ_OOC_FILE_NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE),intent(out)::READ_OOC_FIRST_FILE_NAME CHARACTER(len=23), intent(out) :: READ_HASH INTEGER, intent(out) :: READ_SYM,READ_PAR,READ_NPROCS LOGICAL, intent(out) :: FORTRAN_VERSION_OK CHARACTER(len=5) :: READ_FORTRAN_VERSION INTEGER :: SIZE_CHARACTER, SIZE_LOGICAL INTEGER :: dummy SIZE_CHARACTER = 1 SIZE_LOGICAL = 4 FORTRAN_VERSION_OK = .true. read(fileunit,iostat=ierr) READ_FORTRAN_VERSION if(ierr.ne.0) GOTO 100 if (READ_FORTRAN_VERSION.NE."MUMPS") THEN ierr = 0 FORTRAN_VERSION_OK = .false. GOTO 100 endif size_read=size_read+int(5*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_HASH if(ierr.ne.0) GOTO 100 size_read=size_read+int(23*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(ierr.ne.0) GOTO 100 size_read=size_read+int(2*SIZE_INT8,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_ARITH if(ierr.ne.0) GOTO 100 size_read=size_read+int(1,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_SYM,READ_PAR,READ_NPROCS if(ierr.ne.0) GOTO 100 size_read=size_read+int(3*SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_INT_TYPE_64 if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_LOGICAL,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_OOC_FILE_NAME_LENGTH if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif IF(READ_OOC_FILE_NAME_LENGTH.EQ.-999) THEN read(fileunit,iostat=ierr) dummy if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_INT,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif ELSE read(fileunit,iostat=ierr) & READ_OOC_FIRST_FILE_NAME(1:READ_OOC_FILE_NAME_LENGTH) if(ierr.ne.0) GOTO 100 size_read=size_read+int( & READ_OOC_FILE_NAME_LENGTH*SIZE_CHARACTER,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif ENDIF 100 continue RETURN END SUBROUTINE MUMPS_READ_HEADER SUBROUTINE SMUMPS_CHECK_HEADER(id, BASIC_CHECK, READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) INCLUDE 'mpif.h' TYPE (SMUMPS_STRUC),intent(inout) :: id LOGICAL, intent(in) :: BASIC_CHECK LOGICAL, intent(in) :: READ_INT_TYPE_64 CHARACTER(len=23), intent(in) :: READ_HASH INTEGER, intent(in) :: READ_NPROCS CHARACTER, intent(in) :: READ_ARITH INTEGER, intent(in) :: READ_SYM,READ_PAR LOGICAL :: INT_TYPE_64 CHARACTER(len=23) :: HASH_MASTER CHARACTER :: ARITH INTEGER :: IERR IF(id%KEEP(10).EQ.1) THEN INT_TYPE_64=.TRUE. ELSE INT_TYPE_64=.FALSE. ENDIF if(INT_TYPE_64.neqv.READ_INT_TYPE_64) THEN id%INFO(1) = -73 id%INFO(2) = 2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(id%MYID.EQ.0) THEN HASH_MASTER=READ_HASH ENDIF call MPI_BCAST(HASH_MASTER,23,MPI_CHARACTER,0,id%COMM,IERR) if(HASH_MASTER.ne.READ_HASH) THEN id%INFO(1) = -73 id%INFO(2) = 3 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(id%NPROCS.ne.READ_NPROCS) THEN id%INFO(1) = -73 id%INFO(2) = 4 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 IF (.NOT.BASIC_CHECK) THEN ARITH="SMUMPS"(1:1) if(ARITH.ne.READ_ARITH) THEN id%INFO(1) = -73 id%INFO(2) = 5 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if((id%MYID.EQ.0).AND.(id%SYM.ne.READ_SYM)) THEN id%INFO(1) = -73 id%INFO(2) = 6 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if((id%MYID.EQ.0).AND.(id%PAR.ne.READ_PAR)) THEN write (*,*) id%MYID, 'PAR ',id%PAR, 'READ_PAR ', READ_PAR id%INFO(1) = -73 id%INFO(2) = 7 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF 100 continue RETURN END SUBROUTINE SMUMPS_CHECK_HEADER SUBROUTINE MUMPS_CLEAN_SAVED_DATA(MYID,ierr,SUPPFILE,INFOFILE) INCLUDE 'mpif.h' INTEGER,intent(in) :: MYID INTEGER,intent(out) :: ierr CHARACTER(len=LEN_SAVE_FILE),intent(in):: SUPPFILE,INFOFILE INTEGER::supp,tmp_err ierr = 0 tmp_err = 0 CALL MUMPS_FIND_UNIT(supp) IF ( supp .EQ. -1 ) THEN ierr=-79 RETURN ENDIF open(UNIT=supp,FILE=SUPPFILE,STATUS='old', & form='unformatted',iostat=tmp_err) if (tmp_err.eq.0) THEN close(UNIT=supp,STATUS='delete',iostat=tmp_err) if(tmp_err.ne.0) then ierr = 1 tmp_err = 0 endif endif if (ierr .eq. 0) then if (tmp_err.ne.0) then ierr = 1 tmp_err = 0 endif open(UNIT=supp,FILE=INFOFILE,STATUS='old',iostat=tmp_err) if (tmp_err.eq.0) THEN close(UNIT=supp,STATUS='delete',iostat=tmp_err) endif if (tmp_err.ne.0) THEN ierr = ierr + 2 tmp_err = 0 endif endif RETURN END SUBROUTINE MUMPS_CLEAN_SAVED_DATA SUBROUTINE SMUMPS_GET_SAVE_FILES(id,SAVE_FILE,INFO_FILE) INCLUDE 'mpif.h' TYPE (SMUMPS_STRUC),intent(inout) :: id CHARACTER(len=LEN_SAVE_FILE),intent(out):: SAVE_FILE, INFO_FILE INTEGER::len_save_dir,len_save_prefix INTEGER, PARAMETER :: SAVE_PREFIX_MAX_LENGTH = 255 INTEGER, PARAMETER :: SAVE_DIR_MAX_LENGTH = 1023 CHARACTER(len=SAVE_DIR_MAX_LENGTH) :: tmp_save_dir CHARACTER(len=SAVE_DIR_MAX_LENGTH) :: save_dir CHARACTER(len=SAVE_PREFIX_MAX_LENGTH) :: save_prefix CHARACTER(len=SAVE_PREFIX_MAX_LENGTH) :: tmp_save_prefix CHARACTER(len=10):: STRING_MYID CHARACTER:: LAST_CHAR_DIR INFO_FILE='' SAVE_FILE='' tmp_save_dir='' tmp_save_prefix='' IF(id%SAVE_DIR.EQ."NAME_NOT_INITIALIZED") THEN call MUMPS_GET_SAVE_DIR_C(len_save_dir,tmp_save_dir) if (len_save_dir > SAVE_DIR_MAX_LENGTH) then id%INFO(1) = -77 id%INFO(2) = SAVE_DIR_MAX_LENGTH else if(tmp_save_dir(1:len_save_dir).EQ."NAME_NOT_INITIALIZED") & then id%INFO(1) = -77 id%INFO(2) = 0 else save_dir=trim(adjustl(tmp_save_dir(1:len_save_dir))) len_save_dir=len_trim(save_dir(1:len_save_dir)) endif ELSE save_dir=trim(adjustl(id%SAVE_DIR)) len_save_dir=len_trim(save_dir) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 IF(id%SAVE_PREFIX.EQ."NAME_NOT_INITIALIZED") THEN call MUMPS_GET_SAVE_PREFIX_C(len_save_prefix,tmp_save_prefix) if(len_save_prefix.GT.SAVE_PREFIX_MAX_LENGTH) then id%INFO(1)=-77 id%INFO(2)=-SAVE_PREFIX_MAX_LENGTH else if(tmp_save_prefix(1:len_save_prefix).EQ. & "NAME_NOT_INITIALIZED") then save_prefix="save" len_save_prefix=len_trim(save_prefix) else save_prefix= & trim(adjustl(tmp_save_prefix(1:len_save_prefix))) len_save_prefix=len_trim(save_prefix(1:len_save_prefix)) endif ELSE save_prefix=trim(adjustl(id%SAVE_PREFIX)) len_save_prefix=len_trim(save_prefix) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(STRING_MYID,'(I10)') id%MYID LAST_CHAR_DIR=save_dir(len_save_dir:len_save_dir) if(LAST_CHAR_DIR.NE."/") then SAVE_FILE=trim(adjustl(save_dir))//"/" else SAVE_FILE=trim(adjustl(save_dir)) endif INFO_FILE=trim(adjustl(SAVE_FILE)) SAVE_FILE=trim(adjustl(SAVE_FILE)) & //trim(adjustl(save_prefix)) & //"_" & //trim(adjustl(STRING_MYID)) & //".mumps" INFO_FILE=trim(adjustl(INFO_FILE)) & //trim(adjustl(save_prefix)) & //"_" & //trim(adjustl(STRING_MYID)) & //".info" 100 continue RETURN END SUBROUTINE SMUMPS_GET_SAVE_FILES SUBROUTINE SMUMPS_CHECK_FILE_NAME(id,NAME_LENGTH,FILE_NAME,CHECK) TYPE (SMUMPS_STRUC),intent(in) :: id INTEGER,intent(in) :: NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE),intent(in) :: FILE_NAME LOGICAL,intent(out) :: CHECK INTEGER :: I CHECK = .false. IF (NAME_LENGTH.NE.-999) THEN IF (associated(id%OOC_FILE_NAME_LENGTH) .AND. & associated(id%OOC_FILE_NAMES)) THEN IF (NAME_LENGTH .EQ. id%OOC_FILE_NAME_LENGTH(1)) THEN CHECK = .true. I = 1 DO WHILE(I.LE.NAME_LENGTH) IF (FILE_NAME(I:I).NE.id%OOC_FILE_NAMES(1,I)) THEN CHECK = .false. I = NAME_LENGTH + 1 ELSE I = I + 1 ENDIF END DO ENDIF ENDIF ENDIF END SUBROUTINE SMUMPS_CHECK_FILE_NAME END MODULE SMUMPS_SAVE_RESTORE_FILES #else SUBROUTINE SMUMPS_SAVE_FILES_RETURN() RETURN END SUBROUTINE SMUMPS_SAVE_FILES_RETURN #endif MUMPS_5.8.1/src/dfac_front_LDLT_type1.F0000664000175000017500000011535315042446437017423 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC1_LDLT_M CONTAINS SUBROUTINE DMUMPS_FAC1_LDLT( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, IERROR, & UU, NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) USE DMUMPS_FAC_FRONT_AUX_M USE DMUMPS_OOC USE DMUMPS_FAC_LR USE DMUMPS_LR_TYPE USE MUMPS_LR_STATS USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_DATA_M USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T #if ! defined(BLR_NOOPENMP) #endif !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, intent(inout) :: NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW INTEGER MYID, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION UU, SEUIL DOUBLE PRECISION A( LA ) INTEGER, TARGET :: IW( LIW ) INTEGER, intent(in) :: PERM(N) LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER :: LDA DOUBLE PRECISION UUTEMP LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC LOGICAL IS_MAXFROMM_AVAIL INTEGER PIVOT_OPTION INTEGER LRTRSM_OPTION INTEGER LAST_ROW, FIRST_ROW DOUBLE PRECISION MAXFROMM INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPiv2beWritten, IFLAG_OOC, & IDUMMY, PP_FIRST2SWAP_L, PP_LastPIVRPTRFilled TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PARPIV_T1, OFFSET INTEGER NFS4FATHER DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: M_ARRAY LOGICAL LASTPANEL INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER K473_LOC INTEGER INFO_TMP(2), MAXI_RANK INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM, NELIM_LOC TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L DOUBLE PRECISION, POINTER, DIMENSION(:) :: DIAG INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DIAGPOS, I, IP, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG DOUBLE PRECISION, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) DOUBLE PRECISION, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok,J INTEGER :: OMP_NUM INTEGER :: II,JJ INTEGER(8) :: UPOS, LPOS, DPOS DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) LOGICAL :: SWAP_OCCURRED INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC INTEGER :: NVSCHUR, NVSCHUR_K253, IROW_L INCLUDE 'mumps_headers.h' INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER PIVSIZ,IWPOSP2 IS_MAXFROMM_AVAIL = .FALSE. IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF SWAP_OCCURRED = .FALSE. INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF UUTEMP=UU IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC = SEUIL ENDIF LAFAC = -9999_8 XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) LDA = NFRONT NASS = abs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. COMPRESS_PANEL = .FALSE. COMPRESS_CB = .FALSE. NULLIFY(PTDummy) NULLIFY(BEGS_BLR) NULLIFY(CB_LRB) NULLIFY(ACC_LUA) NULLIFY(BLR_L) NULLIFY(BEGS_BLR_TMP) NULLIFY(BLR_PANEL) NULLIFY(DIAG) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. K473_LOC = 1 ELSE K473_LOC = KEEP(473) ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL DMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS, KEEP, & LR_ACTIVATED, PARPIV_T1) LRTRSM_OPTION = KEEP(475) PIVOT_OPTION = KEEP(468) IF (UUTEMP.EQ.ZERO) THEN PIVOT_OPTION = 0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF IF (LR_ACTIVATED) THEN IF (LRTRSM_OPTION.EQ.3) THEN PIVOT_OPTION = MIN(PIVOT_OPTION,1) ELSEIF (LRTRSM_OPTION.EQ.2) THEN PIVOT_OPTION = MIN(PIVOT_OPTION, 2) ENDIF ENDIF IF (PIVOT_OPTION.LE.1) THEN PARPIV_T1 = 0 ENDIF CALL DMUMPS_SET_INNERBLOCKSIZE( NBKJIB_ORIG, NASS, KEEP) IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = IOLDPS+6+XSIZE+NASS CALL DMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 LASTPANEL = .FALSE. CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF (OOC_EFFECTIVE_ON_FRONT) THEN IDUMMY = -8765 NextPiv2beWritten = 1 PP_FIRST2SWAP_L = NextPiv2beWritten MonBloc%LastPanelWritten_L = 0 PP_LastPIVRPTRFilled = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 1 MonBloc%NROW = NFRONT MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -77777 MonBloc%INDICES => & IW(IOLDPS+6+NFRONT+XSIZE: & IOLDPS+5+NFRONT+XSIZE+NFRONT) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(405) .EQ. 1) THEN !$OMP ATOMIC UPDATE CNT_NODES = CNT_NODES + 1 !$OMP END ATOMIC ELSE CNT_NODES = CNT_NODES + 1 ENDIF ELSE IF (KEEP(486).NE.0) THEN ENDIF OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472), & NFRONT, KEEP(1)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 500 CALL DMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .FALSE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF IF (COMPRESS_CB) THEN IF (NPARTSCB.GT.0) THEN allocate(CB_LRB(NPARTSCB,NPARTSCB),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSCB*NPARTSCB GOTO 490 ENDIF DO II=1,NPARTSCB DO JJ=1,NPARTSCB CB_LRB(II,JJ)%M=0 CB_LRB(II,JJ)%N=0 NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL DMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF ENDIF DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = BEGS_BLR(CURRENT_BLR+1)-1 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (KEEP(480).GE.5) THEN IF (CURRENT_BLR.EQ.1) THEN ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR) THEN BLR_L(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ELSE IF (NB_BLR.GT.CURRENT_BLR) THEN CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF IF (CURRENT_BLR.LT.NPARTSASS) THEN ALLOCATE(NEXT_BLR_L(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR+1) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR+1, NEXT_BLR_L, 0) ENDIF ENDIF ELSE ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ENDIF ENDIF IF (LR_ACTIVATED) THEN ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE CALL DMUMPS_FAC_I_LDLT(NFRONT,NASS,N,INODE, & IBEG_BLOCK, IEND_BLOCK, & IW,LIW,A,LA, & INOPV, NNEGW, NNULLNEGW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UUTEMP, & SEUIL_LOC,KEEP,KEEP8,PIVSIZ, & DKEEP(1), PIVNUL_LIST_STRUCT, SWAP_OCCURRED, XSIZE, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, MAXFROMM, IS_MAXFROMM_AVAIL, & PIVOT_OPTION, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, LR_ACTIVATED & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTPANEL = .TRUE. ELSE IF ( INOPV.LE.0 ) THEN INOPV = 0 NPVW = NPVW + PIVSIZ NVSCHUR_K253 = 0 IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT NVSCHUR_K253 = NVSCHUR + KEEP(253) ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL DMUMPS_FAC_MQ_LDLT(IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & INODE,A,LA, & LDA, & POSELT,IFINB, & PIVSIZ, MAXFROMM, & IS_MAXFROMM_AVAIL, (UUTEMP.NE.0.0D0), & PARPIV_T1, & LAST_ROW, IEND_BLR, NVSCHUR_K253, & LR_ACTIVATED & ) IF(PIVSIZ .EQ. 2) THEN IWPOSP2 = IOLDPS+IW(IOLDPS+1+XSIZE)+6 IW(IWPOSP2+NFRONT+XSIZE) = & -IW(IWPOSP2+NFRONT+XSIZE) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB.EQ.-1) THEN LASTPANEL = .TRUE. ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = LASTPANEL MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL DMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK, & NPIV, NFRONT,NASS,INODE,A,LA, & LDA, POSELT, & KEEP, KEEP8, & -6666, -6666, & IEND_BLR, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL DMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NFRONT,NASS,INODE,A,LA, & LDA, POSELT, & KEEP, KEEP8, & IEND_BLR, NASS, & NASS, LAST_ROW, & (PIVOT_OPTION.LE.1), .TRUE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ELSE NELIM = IEND_BLOCK - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) NULLIFY(BLR_L) IF (KEEP(480).GE.2 .AND. IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS-CURRENT_BLR ELSE FIRST_BLOCK = 1 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL DMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8, FIRST_BLOCK=FIRST_BLOCK) #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF ENDIF GOTO 100 ENDIF IF (PIVOT_OPTION.GE.3) THEN FIRST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN FIRST_ROW = NASS ELSE FIRST_ROW = IEND_BLR ENDIF IF (LRTRSM_OPTION.EQ.3) THEN LAST_ROW = IEND_BLR ELSEIF (LRTRSM_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = NFRONT ENDIF IF ((IEND_BLR.LT.NFRONT) .AND. (LAST_ROW-FIRST_ROW.GT.0)) THEN CALL DMUMPS_FAC_SQ_LDLT(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & INODE, A, LA, LDA, POSELT, & KEEP, KEEP8, & FIRST_ROW, LAST_ROW, & -6666, -6666, & .TRUE., .FALSE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ENDIF #if ! defined(BLR_NOOPENMP) #endif #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(UPOS,LPOS,DPOS,OFFSET) !$OMP& FIRSTPRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), KEEP(458), & K473_LOC, BLR_L, & CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (PIVOT_OPTION.LT.3) THEN IF (LRTRSM_OPTION.GE.2) THEN IF (PIVOT_OPTION.LE.1.AND.LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, NB_BLR, BLR_L, & CURRENT_BLR, FIRST_BLOCK, NB_BLR, & 1, 1, 0, & .FALSE., & IW, OFFSET_IW=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF IF (NELIM.GT.0) THEN IF (PIVOT_OPTION.LE.1) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF LPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR)-1,8) DPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR)-1,8) OFFSET=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1 UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8) #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL DMUMPS_FAC_LDLT_COPYSCALE_U( NELIM, 1, & KEEP(424), NFRONT, NPIV-IBEG_BLR+1, & LIW, IW, OFFSET, LA, A, POSELT, LPOS, UPOS, DPOS) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif LPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8) CALL DMUMPS_BLR_UPD_NELIM_VAR_L( & A, LA, UPOS, A, LA, LPOS, & IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & FIRST_BLOCK, NELIM, 'N') ENDIF ENDIF IF (IFLAG.LT.0) GOTO 400 #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS-CURRENT_BLR ELSE FIRST_BLOCK = 1 ENDIF CALL DMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8, FIRST_BLOCK=FIRST_BLOCK) ENDIF ELSE CALL DMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, & MAXI_CLUSTER, NPIV, & 1, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (LRTRSM_OPTION.GE.2) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF IF (KEEP(486).NE.2) THEN LAST_BLOCK = NB_BLR ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, NFRONT, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL(BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & KEEP(34)) DEALLOCATE(BLR_L) ELSE NULLIFY(NEXT_BLR_L) ENDIF ENDIF NULLIFY(BLR_L) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = LASTPANEL MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO J=1,NB_BLR+1 BEGS_BLR_TMP(J) = BEGS_BLR_STATIC(J) ENDDO ENDIF ENDIF MEM_TOT = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP& PRIVATE(IP, NELIM_LOC, BLR_PANEL) #endif IF ( & (KEEP(486).EQ.2) & ) THEN #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DIAGPOS, POSELT_DIAG, !$OMP& MEM, allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*DIAGSIZ_STA MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DIAGPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA DIAG(DIAGPOS:DIAGPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DIAGPOS = DIAGPOS + DIAGSIZ_DYN POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL DMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG, KEEP(34)) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO !$OMP SINGLE #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM_TOT,8), & (KEEP(405).NE.0), KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 447 IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN DO IP=1,NPARTSASS NELIM_LOC = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8, & KEEP(34)) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(458), K473_LOC, & BLR_PANEL, IP, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM_LOC, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif 445 CONTINUE ENDIF 447 CONTINUE ENDIF IF (IFLAG .LT. 0) GOTO 450 IF (KEEP(480) .GE. 2) THEN #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif CALL DMUMPS_BLR_UPD_CB_LEFT_LDLT(A, LA, POSELT, NFRONT, & BEGS_BLR_STATIC, BEGS_BLR, NPARTSCB, NPARTSASS, NASS, & IW(IOLDPS+XXF), & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(484), KEEP8) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF IF (IFLAG.LT.0) GOTO 450 #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF (COMPRESS_CB & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL DMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (COMPRESS_CB) THEN IEND_BLR = BEGS_BLR(CURRENT_BLR+2) IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) ENDIF ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (COMPRESS_CB) THEN #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL DMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) IF (NFS4FATHER.GE.0) NFS4FATHER = NFS4FATHER + NELIM ENDIF ALLOCATE(M_ARRAY(max(NFS4FATHER,1)), stat=allocok) IF ( allocok.GT.0 ) THEN IFLAG = -13 IERROR = max(NFS4FATHER,1) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 448 CALL DMUMPS_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR, NPARTSCB, NPARTSCB, NPARTSASS, & NFRONT-NASS, NFRONT-NASS, INODE, & IW(IOLDPS+XXF), 2, 1, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR+KEEP(253), KEEP(1), & M_ARRAY=M_ARRAY, & NELIM=NELIM ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 448 #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL DMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF DEALLOCATE(M_ARRAY) #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif 448 CONTINUE ENDIF 450 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF ( & ( & (KEEP(486).EQ.2) & ) & .AND.UU.GT.0 .AND. SWAP_OCCURRED & ) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 1, NASS-NPIV) DO IP=1,NPARTSASS CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NB_BLR-IP & ) ENDDO CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NPIV, 2, 1) ENDIF IF (.NOT. COMPRESS_PANEL) THEN CALL DMUMPS_FAC_T_LDLT(NFRONT,NASS,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, KEEP,KEEP8, & (PIVOT_OPTION.NE.3), ETATASS, & TYPEF_L, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG, IOLDPS+6+XSIZE+NFRONT, INODE ) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 1, 1) ENDIF ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_L, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF CALL DMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 490 CONTINUE 500 CONTINUE 600 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) deallocate(TAU) IF (allocated(JPVT)) deallocate(JPVT) IF (allocated(BLOCK)) deallocate(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) ENDDO ENDIF DEALLOCATE(ACC_LUA) NULLIFY(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL DMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8, KEEP(34)) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND. .NOT.COMPRESS_CB) THEN CALL DMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34), MTK405=KEEP(405)) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_FAC1_LDLT END MODULE DMUMPS_FAC1_LDLT_M SUBROUTINE DMUMPS_FAC1_LDLT_I( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, IERROR, & UU, NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T USE DMUMPS_FAC1_LDLT_M, ONLY: DMUMPS_FAC1_LDLT IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, intent(inout) :: NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW INTEGER MYID, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION UU, SEUIL DOUBLE PRECISION A( LA ) INTEGER IW( LIW ) INTEGER, intent(in) :: PERM(N) LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)) CALL DMUMPS_FAC1_LDLT( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, IERROR, & UU, NNEGW, NNULLNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP, PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) RETURN END SUBROUTINE DMUMPS_FAC1_LDLT_I MUMPS_5.8.1/src/ana_orderings.F0000664000175000017500000151411315042446423016161 0ustar amestoyamestoyC ========================================================= C C This file includes various modifications of an original C routine MUMPS_ANA_H. The main reference for the approach C used in this routine is C Patrick Amestoy, Timothy A. Davis, and Iain S. Duff, C "An approximate minimum degree ordering algorithm," C SIAM J. Matrix Analysis vol 17, pages=886--905 (1996) C MUMPS_ANA_H is based on the original AMD code: C C AMD, Copyright (c), 1996-2016, Timothy A. Davis, C Patrick R. Amestoy, and Iain S. Duff. All Rights Reserved. C Used in MUMPS under the BSD 3-clause license. C C All other routines are modifications of this original routine C done by MUMPS developers over the years (1996-2020) and are C used in MUMPS under the BSD 3-clause license. C C BSD 3-clause licence: C Redistribution and use in source and binary forms, with or without C modification, are permitted provided that the following conditions C are met: C * Redistributions of source code must retain the above copyright C notice, this list of conditions and the following disclaimer. C * Redistributions in binary form must reproduce the above C copyright notice, this list of conditions and the following C disclaimer in the documentation and/or other materials provided C with the distribution. C * Neither the name of the University of California, Berkeley nor C the names of its contributors may be used to endorse or promote C products derived from this software without specific prior C written permission. C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND C CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, C INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF C MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE C DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR C CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT C NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; C LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) C HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR C OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, C EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. C C MUMPS_AMD_ELT is a modification C designed to handle amalgamated and compressed C graphs and was developed in 1999 by Patrick Amestoy C in the context of the PARASOL project (1997-1999). C C MUMPS_HAMD is a modification C designed to take into account a halo in the graph. C The graph is composed is partitioned in two types of nodes C the so called internal nodes and the so called halo nodes. C Halo nodes cannot be selected the both the initial degrees C and updated degrees of internal node should be taken C into account. C This routine also referred to as HALOAMD in MUMPS comments C is used for both Schur functionality and in the coupling with C partitioners such as SCOTCH. C This code was developed for MUMPS platform C by Patrick Amestoy between 1997 and 1999. C C MUMPS_HAMF4 is a major modification of MUMPS_HAMD C since metric used to select pivots in not anymore the C degree but an approximation of the fill-in. C In this approximation C all cliques of elements adjacent to the variable are deducted. C Written by Patrick Amestoy between 1999 and 2000. C It is also used by F. Pellegrini in SCOTCH since 2000. C C MUMPS_QAMD: modified version of reference AMD routine MUMPS_ANA_H C designed to automatically detect and exploit dense or quasi dense C rows in the reduced matrix at any step of the minimum degree. C Written in 1997 by Patrick Amestoy. C References: C P.R. AMESTOY, Recent progress in parallel multifrontal solvers C for unsymmetric sparse matrices, C Proceedings of the 15th World Congress on Scientific Computation, C Modelling and Applied Mathematics, IMACS, Berlin (1997). C P.R. AMESTOY (1999), Methodes directes paralleles de C resolution des systemes creux de grande taille. C Rapport de these d'habilitation de l'INPT. C C MUMPS_CST_AMF: modified version of MUMPS_HAMF4 routine C implementing constraint minimum fill-in based ordering. C Written by Stephane Pralet for MUMPS platform C during his post-doctorate at INPT-IRIT (Oct. 2004- Oct. 2005) C C ---------------------------------------- C To suppress aggressive absorption in ... C MUMPS_ANA_H : Historical AMD C define NOAGG1 C MUMPS_AMD_ELT : (work on compressed graphs) C define NOAGG2 C MUMPS_HAMD : AMD with Halo and used for Schur C define NOAGG3 C MUMPS_HAMF4 : Halo AMF version C define NOAGG4 C MUMPS_QAMD : Quasi dense C define NOAGG5 C MUMPS_SYMQAMD : Symbolic facto based on quasi dense C In the case of MUMPS_SYMQAMD, the aggressive absorption C is controlled by a parameter, AGG6. C C----------------------------------------------------------------------- C----------------------------------------------------------------------- C MUMPS_ANA_H: Approximate Minimum Degree AMD approach. C C Description of MUMPS_ANA_H C Given a representation of the nonzero pattern of a symmetric matrix, C A, (excluding the diagonal) perform an approximate minimum C degree ordering to compute a pivot order C such that fill-in in the Cholesky factors A = LL^T is kept low. C Aggressive absorption might be used to C tighten the bound on the degree. This can result a C significant improvement in the quality of the ordering for C some matrices. C C References and definitions: C [1] Timothy A. Davis and Iain Duff, "An unsymmetric-pattern C multifrontal method for sparse LU factorization", C SIAM J. Matrix Analysis and Applications, C volume=18, pages=140-158 (1997) C [2] Patrick R. Amestoy, Timothy A. Davis, and Iain S. Duff, C "An approximate minimum degree ordering algorithm," C SIAM J. Matrix Analysis vol 17, pages=886--905 (1996) C [3] Alan George and Joseph Liu, "The evolution of the C minimum degree ordering algorithm," SIAM Review, vol. C 31, no. 1, pp. 1-19, March 1989. We list below the C features mentioned in that paper that this code C includes: C mass elimination: C Yes. supervariable detection for mass elimination. C indistinguishable nodes: C Yes (we call these "supervariables"). C We modified the approach used by Duff and Reid to C detect them (the previous hash was the true degree, C which we no longer keep track of). A supervariable is C a set of rows with identical nonzero pattern. All C variables in a supervariable are eliminated together. C Each supervariable has as its numerical name that of C one of its variables (its principal variable). C quotient graph representation: C Yes. We use the term "element" for the cliques formed C during elimination. C The algorithm can operate in place, but it will work C more efficiently if given some "elbow room." C element absorption: C Yes. Similar to Duff,Reid and George,Liu approaches C external degree: C Yes. Similar to Duff, Reid and George, Liu approaches C incomplete degree update and multiple elimination: C No implemented. Our method of C degree update within MUMPS_ANA_H is element-based, not C variable-based. It is thus not well-suited for use C with incomplete degree update or multiple elimination. C C----------------------------------------------------------------------- SUBROUTINE MUMPS_ANA_H(TOTEL, COMPUTE_PERM, & N, IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, HEAD, NEXT, W, PARENT) C C Restrictive integer 64 bit variant : C it is assumed that IW array size can exceed 32-bit integer C C Input not modified INTEGER, INTENT(IN) :: TOTEL, N INTEGER(8), INTENT(IN) :: IWLEN LOGICAL, INTENT(IN) :: COMPUTE_PERM C Input undefined on output INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) C C Output only INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: ELEN(N), LAST(N), PARENT(N) C C Input/output INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(N) C NV also meaningful as input to encode compressed graphs INTEGER, INTENT(INOUT) :: NV(N) C C Internal Workspace only INTEGER :: NEXT(N), DEGREE(N), HEAD(TOTEL), W(N) C --------------------- C Interface Description C --------------------- C INPUT ARGUMENTS (unaltered): C----------------------------- C n : The matrix order. C number of supervariables if compress/blocked format C Restriction: n .ge. 1 C totel : Number of variables to eliminate C In case of blocked format: C each variable i is a supervariable of size nv(i) C totel is computed as the sum(nv(i)) for i \in [1:n] C the algorithm stops when totel variables are C eliminated. C compute_perm : indicates if permutations should be computed C on output in last/elen C iwlen: The length of iw (1..iwlen). On input, the matrix is C stored in iw (1..pfree-1). However, iw (1..iwlen) should be C slightly larger than what is required to hold the matrix, at C least iwlen .ge. pfree + n is recommended. Otherwise, C excessive compressions will take place. C *** We do not recommend running this algorithm with *** C *** iwlen .lt. pfree + n. *** C *** Better performance will be obtained if *** C *** iwlen .ge. pfree + n *** C *** or better yet *** C *** iwlen .gt. 1.2 * pfree *** C *** (where pfree is its value on input). *** C The algorithm will not run at all if iwlen .lt. pfree-1. C C Restriction: iwlen .ge. pfree-1 C----------------------------------------------------------------------- C INPUT/OUPUT ARGUMENTS: C----------------------------------------------------------------------- C pe: On input, pe (i) is the index in iw of the start of row i, or C zero if row i has no off-diagonal non-zeros. C C During execution, it is used for both supervariables and C elements: C C * Principal supervariable i: index into iw of the C description of supervariable i. A supervariable C represents one or more rows of the matrix C with identical nonzero pattern. C * Non-principal supervariable i: if i has been absorbed C into another supervariable j, then pe (i) = -j. C That is, j has the same pattern as i. C Note that j might later be absorbed into another C supervariable j2, in which case pe (i) is still -j, C and pe (j) = -j2. C * Unabsorbed element e: the index into iw of the description C of element e, if e has not yet been absorbed by a C subsequent element. Element e is created when C the supervariable of the same name is selected as C the pivot. C * Absorbed element e: if element e is absorbed into element C e2, then pe (e) = -e2. This occurs when the pattern of C e (that is, Le) is found to be a subset of the pattern C of e2 (that is, Le2). If element e is "null" (it has C no nonzeros outside its pivot block), then pe (e) = 0. C C On output, pe holds the assembly tree/forest, which implicitly C represents a pivot order with identical fill-in as the actual C order (via a depth-first search of the tree). C C On output: (PE is copied on output into PARENT array) C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C pfree:On input, the matrix is stored in iw (1..pfree-1) and C the rest of the array iw is free. C During execution, additional data is placed in iw, and pfree C is modified so that components of iw from pfree are free. C On output, pfree is set equal to the size of iw that C would have been needed for no compressions to occur. If C ncmpa is zero, then pfree (on output) is less than or equal to C iwlen, and the space iw (pfree+1 ... iwlen) was not used. C Otherwise, pfree (on output) is greater than iwlen, and all the C memory in iw was used. C nv: On input, encoding of compressed graph: C if nv(1) = -1 then graph is not compressed otherwise C nv(I) holds the weight of node I. C During execution, abs (nv (i)) is equal to the number of rows C that are represented by the principal supervariable i. If i is C a nonprincipal variable, then nv (i) = 0. C nv (i) .lt. 0 signifies that i is a C principal variable in the pattern Lme of the current pivot C element me. C On output, nv (e) holds the true degree of element C e at the time it was created (including the diagonal part). C----------------------------------------------------------------------- C INPUT/MODIFIED (undefined on output): C----------------------------------------------------------------------- C len: On input, len (i) holds the number of entries in row i of the C matrix, excluding the diagonal. The contents of len (1..n) C are undefined on output. C iw: On input, iw (1..pfree-1) holds the description of each row i C in the matrix. The matrix must be symmetric, and both upper C and lower triangular parts must be present. The diagonal must C not be present. C Row i is held as follows: C len (i): the length of the row i data structure C iw (pe (i) ... pe (i) + len (i) - 1): C the list of column indices for nonzeros C in row i (simple supervariables), excluding C the diagonal. All supervariables start with C one row/column each (supervariable i is just C row i). C if len (i) is zero on input, then pe (i) is ignored C on input. C C Note that the rows need not be in any particular order, C and there may be empty space between the rows. C C During execution, the supervariable i experiences fill-in. C This is represented by placing in i a list of the elements C that cause fill-in in supervariable i: C C len (i): the length of supervariable i C iw (pe (i) ... pe (i) + elen (i) - 1): C the list of elements that contain i. This list C is kept short by removing absorbed elements. C iw (pe (i) + elen (i) ... pe (i) + len (i) - 1): C the list of supervariables in i. This list C is kept short by removing nonprincipal C variables, and any entry j that is also C contained in at least one of the elements C (j in Le) in the list for i (e in row i). C C When supervariable i is selected as pivot, we create an C element e of the same name (e=i): C C len (e): the length of element e C iw (pe (e) ... pe (e) + len (e) - 1): C the list of supervariables in element e. C C An element represents the fill-in that occurs when supervariable C i is selected as pivot (which represents the selection of row i C and all non-principal variables whose principal variable is i). C We use the term Le to denote the set of all supervariables C in element e. Absorbed supervariables and elements are pruned C from these lists when computationally convenient. C C CAUTION: THE INPUT MATRIX IS OVERWRITTEN DURING COMPUTATION. C The contents of iw are undefined on output. C----------------------------------------------------------------------- C OUTPUT (need not be set on input): C----------------------------------------------------------------------- C elen: C See the description of iw above. At the start of execution, C elen (i) is set to zero. During execution, elen (i) is the C number of elements in the list for supervariable i. When e C becomes an element, elen (e) = -nel is set, where nel is the C current step of factorization. elen (i) = 0 is done when i C becomes nonprincipal. C C For variables, elen (i) .ge. 0 holds until just before the C permutation vectors are computed. For elements, C elen (e) .lt. 0 holds. C C On output elen (1..n) holds the inverse permutation (the same C as the 'INVP' argument in Sparspak). That is, if k = elen (i), C then row i is the kth pivot row. Row i of A appears as the C (elen(i))-th row in the permuted matrix, PAP^T. C last: C In a degree list, last (i) is the supervariable preceding i, C or zero if i is the head of the list. In a hash bucket, C last (i) is the hash key for i. last (head (hash)) is also C used as the head of a hash bucket if head (hash) contains a C degree list (see head, below). C C On output, last (1..n) holds the permutation (the same as the C 'PERM' argument in Sparspak). That is, if i = last (k), then C row i is the kth pivot row. Row last (k) of A is the k-th row C in the permuted matrix, PAP^T. C ncmpa: The number of times iw was compressed. If this is C excessive, then the execution took longer than what could have C been. To reduce ncmpa, try increasing iwlen to be 10% or 20% C larger than the value of pfree on input (or at least C iwlen .ge. pfree + n). The fastest performance will be C obtained when ncmpa is returned as zero. If iwlen is set to C the value returned by pfree on *output*, then no compressions C will occur. C----------------------------------------------------------------------- C LOCAL (not input or output - used only during execution): C----------------------------------------------------------------------- C degree: If i is a supervariable, then degree (i) holds the C current approximation of the external degree of row i (an upper C bound). The external degree is the number of nonzeros in row i, C minus abs (nv (i)) (the diagonal part). The bound is equal to C the external degree if elen (i) is less than or equal to two. C C We also use the term "external degree" for elements e to refer C to |Le \ Lme|. If e is an element, then degree (e) holds |Le|, C which is the degree of the off-diagonal part of the element e C (not including the diagonal part). C head: head is used for degree lists. head (deg) is the first C supervariable in a degree list (all supervariables i in a C degree list deg have the same approximate degree, namely, C deg = degree (i)). If the list deg is empty then C head (deg) = 0. C C During supervariable detection head (hash) also serves as a C pointer to a hash bucket. C If head (hash) .gt. 0, there is a degree list of degree hash. C The hash bucket head pointer is last (head (hash)). C If head (hash) = 0, then the degree list and hash bucket are C both empty. C If head (hash) .lt. 0, then the degree list is empty, and C -head (hash) is the head of the hash bucket. C After supervariable detection is complete, all hash buckets C are empty, and the (last (head (hash)) = 0) condition is C restored for the non-empty degree lists. C next: next (i) is the supervariable following i in a link list, or C zero if i is the last in the list. Used for two kinds of C lists: degree lists and hash buckets (a supervariable can be C in only one kind of list at a time). C w: The flag array w determines the status of elements and C variables, and the external degree of elements. C C for elements: C if w (e) = 0, then the element e is absorbed C if w (e) .ge. wflg, then w (e) - wflg is the size of C the set |Le \ Lme|, in terms of nonzeros (the C sum of abs (nv (i)) for each principal variable i that C is both in the pattern of element e and NOT in the C pattern of the current pivot element, me). C if wflg .gt. w (e) .gt. 0, then e is not absorbed and has C not yet been seen in the scan of the element lists in C the computation of |Le\Lme| in loop 150 below. C C for variables: C during supervariable detection, if w (j) .ne. wflg then j is C not in the pattern of variable i C C The w array is initialized by setting w (i) = 1 for all i, C and by setting wflg = 2. It is reinitialized if wflg becomes C too large (to ensure that wflg+n does not cause integer C overflow). C----------------------------------------------------------------------- C LOCAL INTEGERS: C----------------------------------------------------------------------- INTEGER :: DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, ME, MINDEG, NEL, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X INTEGER KNT1_UPDATED, KNT2_UPDATED INTEGER(8) :: MAXMEM, MEM, NEWMEM INTEGER :: MAXINT_N INTEGER(8) :: HASH, HMOD C deg: the degree of a variable or element C degme: size, |Lme|, of the current element, me (= degree (me)) C dext: external degree, |Le \ Lme|, of some element e C dmax: largest |Le| seen so far C e: an element C elenme: the length, elen (me), of element list of pivotal var. C eln: the length, elen (...), of an element list C hash: the computed value of the hash function C hmod: the hash function is computed modulo hmod = max (1,n-1) C i: a supervariable C ilast: the entry in a link list preceding i C inext: the entry in a link list following i C j: a supervariable C jlast: the entry in a link list preceding j C jnext: the entry in a link list, or path, following j C k: the pivot order of an element or variable C knt1: loop counter used during element construction C knt2: loop counter used during element construction C knt3: loop counter used during compression C lenj: len (j) C ln: length of a supervariable list C maxint_n large integer to test risk of overflow on wflg C maxmem: amount of memory needed for no compressions C me: current supervariable being eliminated, and the C current element created by eliminating that C supervariable C mem: memory in use assuming no compressions have occurred C mindeg: current minimum degree C nel: number of pivots selected so far C newmem: amount of new memory needed for current pivot element C nleft: n - nel, the number of nonpivotal rows/columns remaining C nvi: the number of variables in a supervariable i (= nv (i)) C nvj: the number of variables in a supervariable j (= nv (j)) C nvpiv: number of pivots in current element C slenme: number of variables in variable list of pivotal variable C we: w (e) C wflg: used for flagging the w array. See description of iw. C wnvi: wflg - nv (i) C x: either a supervariable or an element C----------------------------------------------------------------------- C LOCAL POINTERS: C----------------------------------------------------------------------- INTEGER(8) P, P1, P2, P3, PDST, PEND, PJ, PME, & PME1, PME2, PN, PSRC C Any parameter (pe (...) or pfree) or local variable C starting with "p" (for Pointer) is an index into iw, C and all indices into iw use variables starting with C "p." The only exception to this rule is the iwlen C input argument. C p: pointer into lots of things C p1: pe (i) for some variable i (start of element list) C p2: pe (i) + elen (i) - 1 for some var. i (end of el. list) C p3: index of first supervariable in clean list C pdst: destination pointer, for compression C pend: end of memory to compress C pj: pointer into an element or variable C pme: pointer into the current element (pme1...pme2) C pme1: the current element, me, is stored in iw (pme1...pme2) C pme2: the end of the current element C pn: pointer into a "clean" variable, also used to compress C psrc: source pointer, for compression LOGICAL COMPRESS C----------------------------------------------------------------------- C FUNCTIONS CALLED: C----------------------------------------------------------------------- INTRINSIC max, min, mod C======================================================================= C INITIALIZATIONS C======================================================================= WFLG = 2 MAXINT_N=huge(WFLG)-N MINDEG = 1 NCMPA = 0 NEL = 0 HMOD = int(max (1, N-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM DO I = 1, N LAST (I) = 0 HEAD (I) = 0 W (I) = 1 ELEN (I) = 0 ENDDO DO I = 1, TOTEL HEAD(I) = 0 ENDDO IF(NV(1) .LT. 0) THEN COMPRESS = .FALSE. ELSE COMPRESS = .TRUE. ENDIF IF (COMPRESS) THEN DO I=1,N DEGREE(I) = 0 DO P= PE(I) , PE(I)+int(LEN(I)-1,8) DEGREE(I) = DEGREE(I) + NV(IW(P)) ENDDO ENDDO ELSE DO I=1,N NV(I) = 1 DEGREE (I) = LEN (I) ENDDO ENDIF C C ---------------------------------------------------------------- C initialize degree lists and eliminate rows with no off-diag. nz. C ---------------------------------------------------------------- DO 20 I = 1, N DEG = DEGREE (I) IF (DEG .GT. 0) THEN C ---------------------------------------------------------- C place i in the degree list corresponding to its degree C ---------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ELSE C ---------------------------------------------------------- C we have a variable that can be eliminated at once because C there is no off-diagonal non-zero in its row. C ---------------------------------------------------------- NEL = NEL + NV(I) ELEN (I) = -NEL PE (I) = 0 W (I) = 0 ENDIF 20 CONTINUE C ===================================================================== C WHILE (selecting pivots) DO C ===================================================================== 30 IF (NEL .LT. TOTEL) THEN C ===================================================================== C GET PIVOT OF MINIMUM DEGREE C ====================================================================== C ------------------------------------------------------------- C find next supervariable for elimination C ------------------------------------------------------------- DO 40 DEG = MINDEG, TOTEL ME = HEAD (DEG) IF (ME .GT. 0) GO TO 50 40 CONTINUE 50 MINDEG = DEG C ------------------------------------------------------------- C remove chosen variable from link list C ------------------------------------------------------------- INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT C ------------------------------------------------------------- C me represents the elimination of pivots nel+1 to nel+nv(me). C place me itself as the first in this set. It will be moved C to the nel+nv(me) position when the permutation vectors are C computed. C ------------------------------------------------------------- ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV C======================================================================= C CONSTRUCT NEW ELEMENT C======================================================================= C ------------------------------------------------------------- C At this point, me is the pivotal supervariable. It will be C converted into the current element. Scan list of the C pivotal supervariable, me, setting tree pointers and C constructing new list of supervariables for the new element, C me. p is a pointer to the current position in the old list. C ------------------------------------------------------------- C flag the variable "me" as being in Lme by negating nv (me) NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN C ---------------------------------------------------------- C construct the new element in place C ---------------------------------------------------------- PME1 = PE (ME) PME2 = PME1 - 1 DO 60 P = PME1, PME1 + LEN (ME) - 1 I = IW (P) NVI = NV (I) IF (NVI .GT. 0) THEN C ---------------------------------------------------- C i is a principal variable not yet placed in Lme. C store i in new list C ---------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I C ---------------------------------------------------- C remove variable i from degree list. C ---------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (DEGREE (I)) = INEXT ENDIF ENDIF 60 CONTINUE C this element takes no new memory in iw: NEWMEM = 0 ELSE C ---------------------------------------------------------- C construct the new element in empty space, iw (pfree ...) C ---------------------------------------------------------- P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME KNT1_UPDATED = 0 DO 120 KNT1 = 1, ELENME + 1 KNT1_UPDATED = KNT1_UPDATED +1 IF (KNT1 .GT. ELENME) THEN C search the supervariables in me. E = ME PJ = P LN = SLENME ELSE C search the elements in me. E = IW (P) P = P + 1 PJ = PE (E) LN = LEN (E) ENDIF C ------------------------------------------------------- C search for different supervariables and add them to the C new list, compressing when necessary. this loop is C executed once for each element in the list and once for C all the supervariables in the list. C ------------------------------------------------------- KNT2_UPDATED = 0 DO 110 KNT2 = 1, LN KNT2_UPDATED = KNT2_UPDATED+1 I = IW (PJ) PJ = PJ + 1 NVI = NV (I) IF (NVI .GT. 0) THEN C ------------------------------------------------- C compress iw, if necessary C ------------------------------------------------- IF (PFREE .GT. IWLEN) THEN C prepare for compressing iw by adjusting C pointers and lengths so that the lists being C searched in the inner and outer loops contain C only the remaining entries. PE (ME) = P LEN (ME) = LEN (ME) - KNT1_UPDATED C Reset KNT1_UPDATED in case of recompress C at same iteration of the loop 120 KNT1_UPDATED = 0 C Check if anything left in supervariable ME IF (LEN (ME) .EQ. 0) PE (ME) = 0 PE (E) = PJ LEN (E) = LN - KNT2_UPDATED C Reset KNT2_UPDATED in case of recompress C at same iteration of the loop 110 KNT2_UPDATED = 0 C Check if anything left in element E IF (LEN (E) .EQ. 0) PE (E) = 0 NCMPA = NCMPA + 1 C store first item in pe C set first entry to -item DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = int(IW (PN), 8) IW (PN) = -J ENDIF 70 CONTINUE C psrc/pdst point to source/destination PDST = 1 PSRC = 1 PEND = PME1 - 1 C while loop: 80 CONTINUE IF (PSRC .LE. PEND) THEN C search for next negative entry J = -IW (PSRC) PSRC = PSRC + 1 IF (J .GT. 0) THEN IW (PDST) = int(PE (J)) PE (J) = PDST PDST = PDST + 1 C copy from source to destination LENJ = LEN (J) DO 90 KNT3 = 0, LENJ - 2 IW (PDST + KNT3) = IW (PSRC + KNT3) 90 CONTINUE PDST = PDST + LENJ - 1 PSRC = PSRC + LENJ - 1 ENDIF GO TO 80 ENDIF C move the new partially-constructed element P1 = PDST DO 100 PSRC = PME1, PFREE - 1 IW (PDST) = IW (PSRC) PDST = PDST + 1 100 CONTINUE PME1 = P1 PFREE = PDST PJ = PE (E) P = PE (ME) ENDIF C ------------------------------------------------- C i is a principal variable not yet placed in Lme C store i in new list C ------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI IW (PFREE) = I PFREE = PFREE + 1 C ------------------------------------------------- C remove variable i from degree link list C ------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (DEGREE (I)) = INEXT ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN C set tree pointer and flag to indicate element e is C absorbed into new element me (the parent of e is me) PE (E) = int(-ME,8) W (E) = 0 ENDIF 120 CONTINUE PME2 = PFREE - 1 C this element takes newmem new memory in iw (possibly zero) NEWMEM = PFREE - PME1 MEM = MEM + NEWMEM MAXMEM = max (MAXMEM, MEM) ENDIF C ------------------------------------------------------------- C me has now been converted into an element in iw (pme1..pme2) C ------------------------------------------------------------- C degme holds the external degree of new element DEGREE (ME) = DEGME PE (ME) = PME1 LEN (ME) = int(PME2 - PME1 + 1) C ------------------------------------------------------------- C make sure that wflg is not too large. With the current C value of wflg, wflg+n must not cause integer overflow C ------------------------------------------------------------- IF (WFLG .GT. MAXINT_N) THEN DO 130 X = 1, N IF (W (X) .NE. 0) W (X) = 1 130 CONTINUE WFLG = 2 ENDIF C======================================================================= C COMPUTE (w (e) - wflg) = |Le\Lme| FOR ALL ELEMENTS C======================================================================= C ------------------------------------------------------------- C Scan 1: compute the external degrees of previous elements C with respect to the current element. That is: C (w (e) - wflg) = |Le \ Lme| C for each element e that appears in any supervariable in Lme. C The notation Le refers to the pattern (list of C supervariables) of a previous element e, where e is not yet C absorbed, stored in iw (pe (e) + 1 ... pe (e) + iw (pe (e))). C The notation Lme refers to the pattern of the current element C (stored in iw (pme1..pme2)). If (w (e) - wflg) becomes C zero, then the element e will be absorbed in scan 2. C ------------------------------------------------------------- DO 150 PME = PME1, PME2 I = IW (PME) ELN = ELEN (I) IF (ELN .GT. 0) THEN C note that nv (i) has been negated to denote i in Lme: NVI = -NV (I) WNVI = WFLG - NVI DO 140 P = PE (I), PE (I) + ELN - 1 E = IW (P) WE = W (E) IF (WE .GE. WFLG) THEN C unabsorbed element e has been seen in this loop WE = WE - NVI ELSE IF (WE .NE. 0) THEN C e is an unabsorbed element C this is the first we have seen e in all of Scan 1 WE = DEGREE (E) + WNVI ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE C======================================================================= C DEGREE UPDATE AND ELEMENT ABSORPTION C======================================================================= C ------------------------------------------------------------- C Scan 2: for each i in Lme, sum up the degree of Lme C (which is degme), C plus the sum of the external degrees of each Le C for the elements e appearing within i, plus the C supervariables in i. Place i in hash list. C ------------------------------------------------------------- DO 180 PME = PME1, PME2 I = IW (PME) P1 = PE (I) P2 = P1 + ELEN (I) - 1 PN = P1 HASH = 0_8 DEG = 0 C ---------------------------------------------------------- C scan the element list associated with supervariable i C ---------------------------------------------------------- DO 160 P = P1, P2 E = IW (P) C dext = | Le \ Lme | DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN DEG = DEG + DEXT IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) ELSE IF (DEXT .EQ. 0) THEN #if defined (NOAGG1) IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) #else C aggressive absorption: e is not adjacent to me, but C the |Le \ Lme| is 0, so absorb it into me PE (E) = int(-ME,8) W (E) = 0 #endif ENDIF 160 CONTINUE C count the number of elements in i (including me): ELEN (I) = int(PN - P1 + 1) C ---------------------------------------------------------- C scan the supervariables in the list associated with i C ---------------------------------------------------------- P3 = PN DO 170 P = P2 + 1, P1 + int(LEN (I) - 1,8) J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN C j is unabsorbed, and not in Lme. C add to degree and add to new list DEG = DEG + NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE C ---------------------------------------------------------- C update the degree and check for mass elimination C ---------------------------------------------------------- #if defined (NOAGG1) IF (DEG.EQ.0.AND.(ELEN(I).GT.1)) THEN C When DEG is zero we need to C absorb in ME all elements adjacent to I P1 = PE (I) C exclude ME --> -2 P2 = P1 + int(ELEN (I),8) - 2_8 DO P =P1,P2 E = IW(P) PE (E) = int(-ME,8) W (E) = 0 ENDDO ENDIF C .... Ready for mass elimination #endif IF (DEG .EQ. 0) THEN C ------------------------------------------------------- C mass elimination C ------------------------------------------------------- C There is nothing left of this node except for an C edge to the current pivot element. elen (i) is 1, C and there are no variables adjacent to node i. C Absorb i into the current pivot element, me. PE (I) = int(-ME,8) NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE C ------------------------------------------------------- C update the upper-bound degree of i C ------------------------------------------------------- C the following degree does not yet include the size C of the current element, which is added later: DEGREE (I) = min (DEGREE (I), DEG) C ------------------------------------------------------- C add me to the list for i C ------------------------------------------------------- C move first supervariable to end of list IW (PN) = IW (P3) C move first element to end of element part of list IW (P3) = IW (P1) C add new element to front of list. IW (P1) = ME C store the new length of the list in len (i) LEN (I) = int(PN - P1 + 1) C ------------------------------------------------------- C place in hash bucket. Save hash key of i in last (i). C ------------------------------------------------------- HASH = mod (HASH, HMOD) + 1_8 J = HEAD (HASH) IF (J .LE. 0) THEN C the degree list is empty, hash head is -j NEXT (I) = -J HEAD (HASH) = -I ELSE C degree list is not empty C use last (head (hash)) as hash head NEXT (I) = LAST (J) LAST (J) = I ENDIF LAST (I) = int(HASH,kind=kind(LAST)) ENDIF 180 CONTINUE DEGREE (ME) = DEGME C ------------------------------------------------------------- C Clear the counter array, w (...), by incrementing wflg. C ------------------------------------------------------------- DMAX = max (DMAX, DEGME) WFLG = WFLG + DMAX C make sure that wflg+n does not cause integer overflow IF (WFLG .GT. MAXINT_N) THEN DO 190 X = 1, N IF (W (X) .NE. 0) W (X) = 1 190 CONTINUE WFLG = 2 ENDIF C at this point, w (1..n) .lt. wflg holds C======================================================================= C SUPERVARIABLE DETECTION C======================================================================= DO 250 PME = PME1, PME2 I = IW (PME) IF (NV (I) .LT. 0) THEN C i is a principal variable in Lme C ------------------------------------------------------- C examine all hash buckets with 2 or more variables. We C do this by examing all unique hash keys for super- C variables in the pattern Lme of the current element, me C ------------------------------------------------------- HASH = int(LAST (I),kind=8) C let i = head of hash bucket, and empty the hash bucket J = HEAD (HASH) IF (J .EQ. 0) GO TO 250 IF (J .LT. 0) THEN C degree list is empty I = -J HEAD (HASH) = 0 ELSE C degree list is not empty, restore last () of head I = LAST (J) LAST (J) = 0 ENDIF IF (I .EQ. 0) GO TO 250 C while loop: 200 CONTINUE IF (NEXT (I) .NE. 0) THEN C ---------------------------------------------------- C this bucket has one or more variables following i. C scan all of them to see if i can absorb any entries C that follow i in hash bucket. Scatter i into w. C ---------------------------------------------------- LN = LEN (I) ELN = ELEN (I) C do not flag the first element in the list (me) DO 210 P = PE (I) + 1, PE (I) + LN - 1 W (IW (P)) = WFLG 210 CONTINUE C ---------------------------------------------------- C scan every other entry j following i in bucket C ---------------------------------------------------- JLAST = I J = NEXT (I) C while loop: 220 CONTINUE IF (J .NE. 0) THEN C ------------------------------------------------- C check if j and i have identical nonzero pattern C ------------------------------------------------- C jump if i and j do not have same size data structure IF (LEN (J) .NE. LN) GO TO 240 C jump if i and j do not have same number adj elts IF (ELEN (J) .NE. ELN) GO TO 240 C do not flag the first element in the list (me) DO 230 P = PE (J) + 1, PE (J) + LN - 1 C jump if an entry (iw(p)) is in j but not in i IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE C ------------------------------------------------- C found it! j can be absorbed into i C ------------------------------------------------- PE (J) = int(-I,8) C both nv (i) and nv (j) are negated since they C are in Lme, and the absolute values of each C are the number of variables in i and j: NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 C delete j from hash bucket J = NEXT (J) NEXT (JLAST) = J GO TO 220 C ------------------------------------------------- 240 CONTINUE C j cannot be absorbed into i C ------------------------------------------------- JLAST = J J = NEXT (J) GO TO 220 ENDIF C ---------------------------------------------------- C no more variables can be absorbed into i C go to next i in bucket and clear flag array C ---------------------------------------------------- WFLG = WFLG + 1 I = NEXT (I) IF (I .NE. 0) GO TO 200 ENDIF ENDIF 250 CONTINUE C======================================================================= C RESTORE DEGREE LISTS AND REMOVE NONPRINCIPAL SUPERVAR. FROM ELEMENT C======================================================================= P = PME1 NLEFT = TOTEL - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN C i is a principal variable in Lme C restore nv (i) to signify that i is principal NV (I) = NVI C ------------------------------------------------------- C compute the external degree (add size of current elem) C ------------------------------------------------------- DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) C ------------------------------------------------------- C place the supervariable at the head of the degree list C ------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I C ------------------------------------------------------- C save the new degree, and find the minimum degree C ------------------------------------------------------- MINDEG = min (MINDEG, DEG) DEGREE (I) = DEG C ------------------------------------------------------- C place the supervariable in the element pattern C ------------------------------------------------------- IW (P) = I P = P + 1 ENDIF 260 CONTINUE C======================================================================= C FINALIZE THE NEW ELEMENT C======================================================================= NV (ME) = NVPIV + DEGME C nv (me) is now the degree of pivot (including diagonal part) C save the length of the list for the new element me LEN (ME) = int(P - PME1) IF (LEN (ME) .EQ. 0) THEN C there is nothing left of the current pivot element PE (ME) = 0_8 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN C element was not constructed in place: deallocate part C of it (final size is less than or equal to newmem, C since newly nonprincipal variables have been removed). PFREE = P MEM = MEM - NEWMEM + LEN (ME) ENDIF C======================================================================= C END WHILE (selecting pivots) GO TO 30 ENDIF C======================================================================= C======================================================================= C COMPUTE THE PERMUTATION VECTORS and update TREE C======================================================================= C ---------------------------------------------------------------- C The time taken by the following code is O(n). At this C point, elen (e) = -k has been done for all elements e, C and elen (i) = 0 has been done for all nonprincipal C variables i. At this point, there are no principal C supervariables left, and all elements are absorbed. C ---------------------------------------------------------------- C ---------------------------------------------------------------- C compute the ordering of unordered nonprincipal variables C ---------------------------------------------------------------- DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN C ---------------------------------------------------------- C i is an un-ordered row. Traverse the tree from i until C reaching an element, e. The element, e, was the C principal supervariable of i and all nodes in the path C from i to when e was selected as pivot. C ---------------------------------------------------------- J = int(-PE (I)) C while (j is a variable) do: 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = int(-PE (J)) GO TO 270 ENDIF E = J C ---------------------------------------------------------- C get the current pivot ordering of e C ---------------------------------------------------------- K = -ELEN (E) C ---------------------------------------------------------- C traverse the path again from i to e, and compress the C path (all nodes point to e). Path compression allows C this code to compute in O(n) time. Order the unordered C nodes in the path, and place the element e at the end. C ---------------------------------------------------------- J = I C while (j is a variable) do: 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = int(-PE (J)) PE (J) = int(-E,8) IF (ELEN (J) .EQ. 0) THEN C j is an unordered row ELEN (J) = K K = K + 1 ENDIF J = JNEXT GO TO 280 ENDIF C leave elen (e) negative, so we know it is an element ELEN (E) = -K ENDIF 290 CONTINUE C IF (COMPUTE_PERM) THEN C ---------------------------------------------------------------- C reset the inverse permutation (elen (1..n)) to be positive, C and compute the permutation (last (1..n)). C ---------------------------------------------------------------- IF(COMPRESS) THEN LAST(1:N) = 0 HEAD(1:TOTEL-N)=0 DO I = 1, N K = abs (ELEN (I)) IF ( K <= N ) THEN LAST (K) = I ELSE HEAD(K-N)=I ENDIF ENDDO I = 1 DO K = 1, N IF(LAST (K) .NE. 0) THEN LAST(I) = LAST(K) ELEN(LAST(K)) = I I = I + 1 ENDIF ENDDO DO K = N+1, TOTEL IF (HEAD(K-N) .NE. 0) THEN LAST(I)=HEAD(K-N) ELEN(HEAD(K-N)) = I I = I + 1 ENDIF END DO ELSE DO 300 I = 1, N K = abs (ELEN (I)) LAST (K) = I ELEN (I) = K 300 CONTINUE ENDIF C======================================================================= C END OF COMPUTING PERMUTATIONS C======================================================================= ENDIF C======================================================================= C RETURN THE MEMORY USAGE IN IW C======================================================================= C If maxmem is less than or equal to iwlen, then no compressions C occurred, and iw (maxmem+1 ... iwlen) was unused. Otherwise C compressions did occur, and iwlen would have had to have been C greater than or equal to maxmem for no compressions to occur. C Return the value of maxmem in the pfree argument. PFREE = MAXMEM C=============================== C Save IPE in PARENT array DO I=1,N PARENT(I) = int(PE(I)) ENDDO C=============================== RETURN END SUBROUTINE MUMPS_ANA_H C----------------------------------------------------------------------- C MUMPS_AMD_ELT: modified version of reference AMD routine MUMPS_ANA_H C capable of processing already amalgamated or compressed graph. C Used within MUMPS process for the elemental input format of matrices C Input data is in this context modified to be a graph of supervariables. C C Modifications of the interface : C ------------------------------ C INPUT: C ----- C 1/ LEN(I) < 0 <=> i is a secondary variable whose principal C variable is -LEN(I) C 2/ For all secondary variables the adj list MUST not be provided. C THAT is: C ------- C if pe(isecondary) = 0 then C adjacency list of isecondary is not provided C else C pe(isecondary) >0 C len(isecondary) must be equal to len(iprincipal_associated) C then the corresponding space wil not be used and C will be freed by amd if necessary. C endif C REMARK: C ------ C 1/ N must be still set to the order of the matrix C (not of the amalgamated gragh) C 2/ For each supervariable S only supervariables adjacent to S are provided C len(S) is then the number of such supervariables C NV(S) is however updated during the initialisation phase to represent C the size of the supervariable C ( increment nv(s) for each i / len(i) =-s ) C 3/ If (len(i) >=0 for all i ) then we get the classical AMD code C ------------------ SUBROUTINE MUMPS_AMD_ELT(N,IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, HEAD, NEXT, W, PARENT) C C Restrictive integer 64 bit variant : C it is assumed that IW array size can exceed 32-bit integer C C Input not modified INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: IWLEN C Input undefined on output INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) C C Output only INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: NV(N), ELEN(N), LAST(N), PARENT(N) C C Input/output INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(N) C C Internal Workspace only INTEGER NEXT(N), DEGREE(N), HEAD(N), W(N) C C Description: C Given a representation of the nonzero pattern of a symmetric matrix, C A, (excluding the diagonal) perform an approximate minimum C degree ordering to compute a pivot order C such that fill-in in the Cholesky factors A = LL^T is kept low. C --------------------- C Interface Description C --------------------- C INPUT ARGUMENTS (unaltered): C----------------------------- C n: The matrix order. C C Restriction: n .ge. 1 C iwlen: The length of iw (1..iwlen). On input, the matrix is C stored in iw (1..pfree-1). However, iw (1..iwlen) should be C slightly larger than what is required to hold the matrix, at C least iwlen .ge. pfree + n is recommended. Otherwise, C excessive compressions will take place. C *** We do not recommend running this algorithm with *** C *** iwlen .lt. pfree + n. *** C *** Better performance will be obtained if *** C *** iwlen .ge. pfree + n *** C *** or better yet *** C *** iwlen .gt. 1.2 * pfree *** C *** (where pfree is its value on input). *** C The algorithm will not run at all if iwlen .lt. pfree-1. C C Restriction: iwlen .ge. pfree-1 C----------------------------------------------------------------------- C INPUT/OUPUT ARGUMENTS: C----------------------------------------------------------------------- C pe: On input, pe (i) is the index in iw of the start of row i, or C zero if row i has no off-diagonal non-zeros. C C During execution, it is used for both supervariables and C elements: C C * Principal supervariable i: index into iw of the C description of supervariable i. A supervariable C represents one or more rows of the matrix C with identical nonzero pattern. C * Non-principal supervariable i: if i has been absorbed C into another supervariable j, then pe (i) = -j. C That is, j has the same pattern as i. C Note that j might later be absorbed into another C supervariable j2, in which case pe (i) is still -j, C and pe (j) = -j2. C * Unabsorbed element e: the index into iw of the description C of element e, if e has not yet been absorbed by a C subsequent element. Element e is created when C the supervariable of the same name is selected as C the pivot. C * Absorbed element e: if element e is absorbed into element C e2, then pe (e) = -e2. This occurs when the pattern of C e (that is, Le) is found to be a subset of the pattern C of e2 (that is, Le2). If element e is "null" (it has C no nonzeros outside its pivot block), then pe (e) = 0. C C On output, pe holds the assembly tree/forest, which implicitly C represents a pivot order with identical fill-in as the actual C order (via a depth-first search of the tree). C C On output: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C C On output: (PE is copied on output into PARENT array) C pfree: On input, the matrix is stored in iw (1..pfree-1) and C the rest of the array iw is free. C During execution, additional data is placed in iw, and pfree C is modified so that components of iw from pfree are free. C On output, pfree is set equal to the size of iw that C would have been needed for no compressions to occur. If C ncmpa is zero, then pfree (on output) is less than or equal to C iwlen, and the space iw (pfree+1 ... iwlen) was not used. C Otherwise, pfree (on output) is greater than iwlen, and all the C memory in iw was used. C----------------------------------------------------------------------- C INPUT/MODIFIED (undefined on output): C----------------------------------------------------------------------- C len: On input, len (i) holds the number of entries in row i of the C matrix, excluding the diagonal. The contents of len (1..n) C are undefined on output. C iw: On input, iw (1..pfree-1) holds the description of each row i C in the matrix. The matrix must be symmetric, and both upper C and lower triangular parts must be present. The diagonal must C not be present. Row i is held as follows: C C len (i): the length of the row i data structure C iw (pe (i) ... pe (i) + len (i) - 1): C the list of column indices for nonzeros C in row i (simple supervariables), excluding C the diagonal. All supervariables start with C one row/column each (supervariable i is just C row i). C if len (i) is zero on input, then pe (i) is ignored C on input. C C Note that the rows need not be in any particular order, C and there may be empty space between the rows. C C During execution, the supervariable i experiences fill-in. C This is represented by placing in i a list of the elements C that cause fill-in in supervariable i: C C len (i): the length of supervariable i C iw (pe (i) ... pe (i) + elen (i) - 1): C the list of elements that contain i. This list C is kept short by removing absorbed elements. C iw (pe (i) + elen (i) ... pe (i) + len (i) - 1): C the list of supervariables in i. This list C is kept short by removing nonprincipal C variables, and any entry j that is also C contained in at least one of the elements C (j in Le) in the list for i (e in row i). C C When supervariable i is selected as pivot, we create an C element e of the same name (e=i): C C len (e): the length of element e C iw (pe (e) ... pe (e) + len (e) - 1): C the list of supervariables in element e. C C An element represents the fill-in that occurs when supervariable C i is selected as pivot (which represents the selection of row i C and all non-principal variables whose principal variable is i). C We use the term Le to denote the set of all supervariables C in element e. Absorbed supervariables and elements are pruned C from these lists when computationally convenient. C C CAUTION: THE INPUT MATRIX IS OVERWRITTEN DURING COMPUTATION. C The contents of iw are undefined on output. C----------------------------------------------------------------------- C OUTPUT (need not be set on input): C----------------------------------------------------------------------- C nv: During execution, abs (nv (i)) is equal to the number of rows C that are represented by the principal supervariable i. If i is C a nonprincipal variable, then nv (i) = 0. Initially, C nv (i) = 1 for all i. nv (i) .lt. 0 signifies that i is a C principal variable in the pattern Lme of the current pivot C element me. On output, nv (e) holds the true degree of element C e at the time it was created (including the diagonal part). C elen: See the description of iw above. At the start of execution, C elen (i) is set to zero. During execution, elen (i) is the C number of elements in the list for supervariable i. When e C becomes an element, elen (e) = -nel is set, where nel is the C current step of factorization. elen (i) = 0 is done when i C becomes nonprincipal. C C For variables, elen (i) .ge. 0 holds until just before the C permutation vectors are computed. For elements, C elen (e) .lt. 0 holds. C C On output elen (1..n) holds the inverse permutation (the same C as the 'INVP' argument in Sparspak). That is, if k = elen (i), C then row i is the kth pivot row. Row i of A appears as the C (elen(i))-th row in the permuted matrix, PAP^T. C last: In a degree list, last (i) is the supervariable preceding i, C or zero if i is the head of the list. In a hash bucket, C last (i) is the hash key for i. last (head (hash)) is also C used as the head of a hash bucket if head (hash) contains a C degree list (see head, below). C C On output, last (1..n) holds the permutation (the same as the C 'PERM' argument in Sparspak). That is, if i = last (k), then C row i is the kth pivot row. Row last (k) of A is the k-th row C in the permuted matrix, PAP^T. C ncmpa: The number of times iw was compressed. If this is C excessive, then the execution took longer than what could have C been. To reduce ncmpa, try increasing iwlen to be 10% or 20% C larger than the value of pfree on input (or at least C iwlen .ge. pfree + n). The fastest performance will be C obtained when ncmpa is returned as zero. If iwlen is set to C the value returned by pfree on *output*, then no compressions C will occur. C----------------------------------------------------------------------- C LOCAL (not input or output - used only during execution): C----------------------------------------------------------------------- C degree: If i is a supervariable, then degree (i) holds the C current approximation of the external degree of row i (an upper C bound). The external degree is the number of nonzeros in row i, C minus abs (nv (i)) (the diagonal part). The bound is equal to C the external degree if elen (i) is less than or equal to two. C C We also use the term "external degree" for elements e to refer C to |Le \ Lme|. If e is an element, then degree (e) holds |Le|, C which is the degree of the off-diagonal part of the element e C (not including the diagonal part). C head: head is used for degree lists. head (deg) is the first C supervariable in a degree list (all supervariables i in a C degree list deg have the same approximate degree, namely, C deg = degree (i)). If the list deg is empty then C head (deg) = 0. C C During supervariable detection head (hash) also serves as a C pointer to a hash bucket. C If head (hash) .gt. 0, there is a degree list of degree hash. C The hash bucket head pointer is last (head (hash)). C If head (hash) = 0, then the degree list and hash bucket are C both empty. C If head (hash) .lt. 0, then the degree list is empty, and C -head (hash) is the head of the hash bucket. C After supervariable detection is complete, all hash buckets C are empty, and the (last (head (hash)) = 0) condition is C restored for the non-empty degree lists. C next: next (i) is the supervariable following i in a link list, or C zero if i is the last in the list. Used for two kinds of C lists: degree lists and hash buckets (a supervariable can be C in only one kind of list at a time). C w: The flag array w determines the status of elements and C variables, and the external degree of elements. C C for elements: C if w (e) = 0, then the element e is absorbed C if w (e) .ge. wflg, then w (e) - wflg is the size of C the set |Le \ Lme|, in terms of nonzeros (the C sum of abs (nv (i)) for each principal variable i that C is both in the pattern of element e and NOT in the C pattern of the current pivot element, me). C if wflg .gt. w (e) .gt. 0, then e is not absorbed and has C not yet been seen in the scan of the element lists in C the computation of |Le\Lme| in loop 150 below. C C for variables: C during supervariable detection, if w (j) .ne. wflg then j is C not in the pattern of variable i C C The w array is initialized by setting w (i) = 1 for all i, C and by setting wflg = 2. It is reinitialized if wflg becomes C too large (to ensure that wflg+n does not cause integer C overflow). C----------------------------------------------------------------------- C LOCAL INTEGERS: C----------------------------------------------------------------------- INTEGER :: DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, ME, MINDEG, NEL, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, & NPRINC INTEGER KNT1_UPDATED, KNT2_UPDATED INTEGER(8) :: MAXMEM, MEM, NEWMEM INTEGER :: MAXINT_N INTEGER(8) :: HASH, HMOD C deg: the degree of a variable or element C degme: size, |Lme|, of the current element, me (= degree (me)) C dext: external degree, |Le \ Lme|, of some element e C dmax: largest |Le| seen so far C e: an element C elenme: the length, elen (me), of element list of pivotal var. C eln: the length, elen (...), of an element list C hash: the computed value of the hash function C hmod: the hash function is computed modulo hmod = max (1,n-1) C i: a supervariable C ilast: the entry in a link list preceding i C inext: the entry in a link list following i C j: a supervariable C jlast: the entry in a link list preceding j C jnext: the entry in a link list, or path, following j C k: the pivot order of an element or variable C knt1: loop counter used during element construction C knt2: loop counter used during element construction C knt3: loop counter used during compression C lenj: len (j) C ln: length of a supervariable list C maxint_n large integer to test risk of overflow on wflg C maxmem: amount of memory needed for no compressions C me: current supervariable being eliminated, and the C current element created by eliminating that C supervariable C mem: memory in use assuming no compressions have occurred C mindeg: current minimum degree C nel: number of pivots selected so far C newmem: amount of new memory needed for current pivot element C nleft: n - nel, the number of nonpivotal rows/columns remaining C nvi: the number of variables in a supervariable i (= nv (i)) C nvj: the number of variables in a supervariable j (= nv (j)) C nvpiv: number of pivots in current element C slenme: number of variables in variable list of pivotal variable C we: w (e) C wflg: used for flagging the w array. See description of iw. C wnvi: wflg - nv (i) C x: either a supervariable or an element C nprinc : number of principal variables = number of varialbles C of the compressed graph. C (if the graph is not compressed then nprinc = n) C----------------------------------------------------------------------- C LOCAL POINTERS: C----------------------------------------------------------------------- INTEGER(8) :: P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, & PN, PSRC C Any parameter (pe (...) or pfree) or local variable C starting with "p" (for Pointer) is an index into iw, C and all indices into iw use variables starting with C "p." The only exception to this rule is the iwlen C input argument. C p: pointer into lots of things C p1: pe (i) for some variable i (start of element list) C p2: pe (i) + elen (i) - 1 for some var. i (end of el. list) C p3: index of first supervariable in clean list C pdst: destination pointer, for compression C pend: end of memory to compress C pj: pointer into an element or variable C pme: pointer into the current element (pme1...pme2) C pme1: the current element, me, is stored in iw (pme1...pme2) C pme2: the end of the current element C pn: pointer into a "clean" variable, also used to compress C psrc: source pointer, for compression C----------------------------------------------------------------------- C FUNCTIONS CALLED: C----------------------------------------------------------------------- INTRINSIC max, min, mod C======================================================================= C INITIALIZATIONS C======================================================================= WFLG = 2 MAXINT_N=huge(WFLG)-N MINDEG = 1 NCMPA = 0 NEL = 0 HMOD = int(max (1, N-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM NPRINC = 0 DO I = 1, N LAST (I) = 0 HEAD (I) = 0 NV (I) = 1 W (I) = 1 ELEN (I) = 0 ENDDO DO I=1, N IF (LEN (I).GE.0) THEN DEGREE (I) = LEN (I) NPRINC = NPRINC + 1 ELSE C i is a secondary variable belonging C to supervariable j=-len (i) J = -LEN (I) C used only to skip secondary variables in loop 20 DEGREE (I) = - 1 IF ( PE(I) .NE. 0_8 ) THEN C adjacency list of secondary variable was C provided by the user, C the space will be compressed if necessary LEN (I) = LEN(J) ELSE LEN (I) = 0 ENDIF PE (I) = int(-J,8) NV (J) = NV (J) + NV (I) NV (I) = 0 ELEN (I) = 0 ENDIF ENDDO C ---------------------------------------------------------------- C initialize degree lists and eliminate rows with no off-diag. nz. C ---------------------------------------------------------------- DO 20 I = 1, N DEG = DEGREE (I) C degree(i) < 0 corresponds to secondary variables C that need be skipped. IF (DEG .GT. 0) THEN C ---------------------------------------------------------- C place i in the degree list corresponding to its degree C ---------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ELSE IF ( DEG.EQ. 0) THEN C ---------------------------------------------------------- C we have a variable that can be eliminated at once because C there is no off-diagonal non-zero in its row. C ---------------------------------------------------------- C C We have a graph of supervariable and thus need to update C singleton that might already be supervariables with nv(i) C When a supervariable is eliminated its C principal variable must be set to the current step C (NEL+1) which must be stored (negated) in ELEN C ONLY THEN (current step) NEL should be incremented. C This will be exploited when computing the global ordering C of all (secondary and principal) variables at the end of the AMD routine. ELEN (I) = - (NEL + 1) NEL = NEL + NV(I) PE (I) = 0_8 W (I) = 0 ENDIF 20 CONTINUE C======================================================================= C WHILE (selecting pivots) DO C======================================================================= C C Note that we do want to loop until NEL = N since C we update NEL with the size of the eliminated supervariable C 30 IF (NEL .LT. N) THEN C======================================================================= C GET PIVOT OF MINIMUM DEGREE C======================================================================= C ------------------------------------------------------------- C find next supervariable for elimination C ------------------------------------------------------------- DO 40 DEG = MINDEG, N ME = HEAD (DEG) IF (ME .GT. 0) GO TO 50 40 CONTINUE 50 MINDEG = DEG C ------------------------------------------------------------- C remove chosen variable from link list C ------------------------------------------------------------- INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT C ------------------------------------------------------------- C me represents the elimination of pivots nel+1 to nel+nv(me). C place me itself as the first in this set. It will be moved C to the nel+nv(me) position when the permutation vectors are C computed. C ------------------------------------------------------------- ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV C======================================================================= C CONSTRUCT NEW ELEMENT C======================================================================= C ------------------------------------------------------------- C At this point, me is the pivotal supervariable. It will be C converted into the current element. Scan list of the C pivotal supervariable, me, setting tree pointers and C constructing new list of supervariables for the new element, C me. p is a pointer to the current position in the old list. C ------------------------------------------------------------- C flag the variable "me" as being in Lme by negating nv (me) NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN C ---------------------------------------------------------- C construct the new element in place C ---------------------------------------------------------- PME1 = PE (ME) PME2 = PME1 - 1 DO 60 P = PME1, PME1 + int(LEN (ME) - 1,8) I = IW (P) NVI = NV (I) IF (NVI .GT. 0) THEN C ---------------------------------------------------- C i is a principal variable not yet placed in Lme. C store i in new list C ---------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI PME2 = PME2 + 1_8 IW (PME2) = I C ---------------------------------------------------- C remove variable i from degree list. C ---------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (DEGREE (I)) = INEXT ENDIF ENDIF 60 CONTINUE C this element takes no new memory in iw: NEWMEM = 0 ELSE C ---------------------------------------------------------- C construct the new element in empty space, iw (pfree ...) C ---------------------------------------------------------- P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME KNT1_UPDATED = 0 DO 120 KNT1 = 1, ELENME + 1 KNT1_UPDATED = KNT1_UPDATED +1 IF (KNT1 .GT. ELENME) THEN C search the supervariables in me. E = ME PJ = P LN = SLENME ELSE C search the elements in me. E = IW (P) P = P + 1 PJ = PE (E) LN = LEN (E) ENDIF C ------------------------------------------------------- C search for different supervariables and add them to the C new list, compressing when necessary. this loop is C executed once for each element in the list and once for C all the supervariables in the list. C ------------------------------------------------------- KNT2_UPDATED = 0 DO 110 KNT2 = 1, LN KNT2_UPDATED = KNT2_UPDATED+1 I = IW (PJ) PJ = PJ + 1 NVI = NV (I) IF (NVI .GT. 0) THEN C ------------------------------------------------- C compress iw, if necessary C ------------------------------------------------- IF (PFREE .GT. IWLEN) THEN C prepare for compressing iw by adjusting C pointers and lengths so that the lists being C searched in the inner and outer loops contain C only the remaining entries. PE (ME) = P LEN (ME) = LEN (ME) - KNT1_UPDATED C Reset KNT1_UPDATED in case of recompress C at same iteration of the loop 120 KNT1_UPDATED = 0 C Check if anything left in supervariable ME IF (LEN (ME) .EQ. 0) PE (ME) = 0_8 PE (E) = PJ LEN (E) = LN - KNT2_UPDATED C Reset KNT2_UPDATED in case of recompress C at same iteration of the loop 110 KNT2_UPDATED = 0 C Check if anything left in element E IF (LEN (E) .EQ. 0) PE (E) = 0_8 NCMPA = NCMPA + 1 C store first item in pe C set first entry to -item DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0_8) THEN PE (J) = int(IW (PN),8) IW (PN) = -J ENDIF 70 CONTINUE C psrc/pdst point to source/destination PDST = 1 PSRC = 1 PEND = PME1 - 1 C while loop: 80 CONTINUE IF (PSRC .LE. PEND) THEN C search for next negative entry J = -IW (PSRC) PSRC = PSRC + 1 IF (J .GT. 0) THEN IW (PDST) = int(PE (J)) PE (J) = PDST PDST = PDST + 1_8 C copy from source to destination LENJ = LEN (J) DO 90 KNT3 = 0, LENJ - 2 IW (PDST + KNT3) = IW (PSRC + KNT3) 90 CONTINUE PDST = PDST + int(LENJ - 1,8) PSRC = PSRC + int(LENJ - 1,8) ENDIF GO TO 80 ENDIF C move the new partially-constructed element P1 = PDST DO 100 PSRC = PME1, PFREE - 1 IW (PDST) = IW (PSRC) PDST = PDST + 1 100 CONTINUE PME1 = P1 PFREE = PDST PJ = PE (E) P = PE (ME) ENDIF C ------------------------------------------------- C i is a principal variable not yet placed in Lme C store i in new list C ------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI IW (PFREE) = I PFREE = PFREE + 1 C ------------------------------------------------- C remove variable i from degree link list C ------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (DEGREE (I)) = INEXT ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN C set tree pointer and flag to indicate element e is C absorbed into new element me (the parent of e is me) PE (E) = int(-ME,8) W (E) = 0 ENDIF 120 CONTINUE PME2 = PFREE - 1 C this element takes newmem new memory in iw (possibly zero) NEWMEM = PFREE - PME1 MEM = MEM + NEWMEM MAXMEM = max (MAXMEM, MEM) ENDIF C ------------------------------------------------------------- C me has now been converted into an element in iw (pme1..pme2) C ------------------------------------------------------------- C degme holds the external degree of new element DEGREE (ME) = DEGME PE (ME) = PME1 LEN (ME) = int(PME2 - PME1 + 1) C ------------------------------------------------------------- C make sure that wflg is not too large. With the current C value of wflg, wflg+n must not cause integer overflow C ------------------------------------------------------------- IF (WFLG .GT. MAXINT_N) THEN DO 130 X = 1, N IF (W (X) .NE. 0) W (X) = 1 130 CONTINUE WFLG = 2 ENDIF C======================================================================= C COMPUTE (w (e) - wflg) = |Le\Lme| FOR ALL ELEMENTS C======================================================================= C ------------------------------------------------------------- C Scan 1: compute the external degrees of previous elements C with respect to the current element. That is: C (w (e) - wflg) = |Le \ Lme| C for each element e that appears in any supervariable in Lme. C The notation Le refers to the pattern (list of C supervariables) of a previous element e, where e is not yet C absorbed, stored in iw (pe (e) + 1 ... pe (e) + iw (pe (e))). C The notation Lme refers to the pattern of the current element C (stored in iw (pme1..pme2)). If (w (e) - wflg) becomes C zero, then the element e will be absorbed in scan 2. C ------------------------------------------------------------- DO 150 PME = PME1, PME2 I = IW (PME) ELN = ELEN (I) IF (ELN .GT. 0) THEN C note that nv (i) has been negated to denote i in Lme: NVI = -NV (I) WNVI = WFLG - NVI DO 140 P = PE (I), PE (I) + int(ELN - 1,8) E = IW (P) WE = W (E) IF (WE .GE. WFLG) THEN C unabsorbed element e has been seen in this loop WE = WE - NVI ELSE IF (WE .NE. 0) THEN C e is an unabsorbed element C this is the first we have seen e in all of Scan 1 WE = DEGREE (E) + WNVI ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE C======================================================================= C DEGREE UPDATE AND ELEMENT ABSORPTION C======================================================================= C ------------------------------------------------------------- C Scan 2: for each i in Lme, sum up the degree of Lme (which C is degme), plus the sum of the external degrees of each Le C for the elements e appearing within i, plus the C supervariables in i. Place i in hash list. C ------------------------------------------------------------- DO 180 PME = PME1, PME2 I = IW (PME) P1 = PE (I) P2 = P1 + int(ELEN (I) - 1,8) PN = P1 HASH = 0_8 DEG = 0 C ---------------------------------------------------------- C scan the element list associated with supervariable i C ---------------------------------------------------------- DO 160 P = P1, P2 E = IW (P) C dext = | Le \ Lme | DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN DEG = DEG + DEXT IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) ELSE IF (DEXT .EQ. 0) THEN #if defined (NOAGG2) IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) #else C aggressive absorption: e is not adjacent to me, but C the |Le \ Lme| is 0, so absorb it into me PE (E) = int(-ME,8) W (E) = 0 #endif ENDIF 160 CONTINUE C count the number of elements in i (including me): ELEN (I) = int(PN - P1 + 1_8) C ---------------------------------------------------------- C scan the supervariables in the list associated with i C ---------------------------------------------------------- P3 = PN DO 170 P = P2 + 1, P1 + int(LEN (I) - 1,8) J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN C j is unabsorbed, and not in Lme. C add to degree and add to new list DEG = DEG + NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE C ---------------------------------------------------------- C update the degree and check for mass elimination C ---------------------------------------------------------- #if defined (NOAGG2) IF (DEG.EQ.0.AND.(ELEN(I).GT.1)) THEN C When DEG is zero we need to C absorb in ME all elements adjacent to I P1 = PE (I) C exclude ME --> -2 P2 = P1 + int(ELEN (I),8) - 2_8 DO P =P1,P2 E = IW(P) PE (E) = int(-ME,8) W (E) = 0 ENDDO ENDIF C .... Ready for mass elimination #endif IF (DEG .EQ. 0) THEN C ------------------------------------------------------- C mass elimination C ------------------------------------------------------- C There is nothing left of this node except for an C edge to the current pivot element. elen (i) is 1, C and there are no variables adjacent to node i. C Absorb i into the current pivot element, me. PE (I) = int(-ME,8) NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE C ------------------------------------------------------- C update the upper-bound degree of i C ------------------------------------------------------- C the following degree does not yet include the size C of the current element, which is added later: DEGREE (I) = min (DEGREE (I), DEG) C ------------------------------------------------------- C add me to the list for i C ------------------------------------------------------- C move first supervariable to end of list IW (PN) = IW (P3) C move first element to end of element part of list IW (P3) = IW (P1) C add new element to front of list. IW (P1) = ME C store the new length of the list in len (i) LEN (I) = int(PN - P1 + 1_8) C ------------------------------------------------------- C place in hash bucket. Save hash key of i in last (i). C ------------------------------------------------------- HASH = mod (HASH, HMOD) + 1_8 J = HEAD (HASH) IF (J .LE. 0) THEN C the degree list is empty, hash head is -j NEXT (I) = -J HEAD (HASH) = -I ELSE C degree list is not empty C use last (head (hash)) as hash head NEXT (I) = LAST (J) LAST (J) = I ENDIF LAST (I) = int(HASH,kind=kind(LAST)) ENDIF 180 CONTINUE DEGREE (ME) = DEGME C ------------------------------------------------------------- C Clear the counter array, w (...), by incrementing wflg. C ------------------------------------------------------------- DMAX = max (DMAX, DEGME) WFLG = WFLG + DMAX C make sure that wflg+n does not cause integer overflow IF (WFLG .GT. MAXINT_N) THEN DO 190 X = 1, N IF (W (X) .NE. 0) W (X) = 1 190 CONTINUE WFLG = 2 ENDIF C at this point, w (1..n) .lt. wflg holds C======================================================================= C SUPERVARIABLE DETECTION C======================================================================= DO 250 PME = PME1, PME2 I = IW (PME) IF (NV (I) .LT. 0) THEN C i is a principal variable in Lme C ------------------------------------------------------- C examine all hash buckets with 2 or more variables. We C do this by examing all unique hash keys for super- C variables in the pattern Lme of the current element, me C ------------------------------------------------------- HASH = int(LAST (I),kind=8) C let i = head of hash bucket, and empty the hash bucket J = HEAD (HASH) IF (J .EQ. 0) GO TO 250 IF (J .LT. 0) THEN C degree list is empty I = -J HEAD (HASH) = 0 ELSE C degree list is not empty, restore last () of head I = LAST (J) LAST (J) = 0 ENDIF IF (I .EQ. 0) GO TO 250 C while loop: 200 CONTINUE IF (NEXT (I) .NE. 0) THEN C ---------------------------------------------------- C this bucket has one or more variables following i. C scan all of them to see if i can absorb any entries C that follow i in hash bucket. Scatter i into w. C ---------------------------------------------------- LN = LEN (I) ELN = ELEN (I) C do not flag the first element in the list (me) DO 210 P = PE (I) + 1, PE (I) + int(LN - 1,8) W (IW (P)) = WFLG 210 CONTINUE C ---------------------------------------------------- C scan every other entry j following i in bucket C ---------------------------------------------------- JLAST = I J = NEXT (I) C while loop: 220 CONTINUE IF (J .NE. 0) THEN C ------------------------------------------------- C check if j and i have identical nonzero pattern C ------------------------------------------------- C jump if i and j do not have same size data structure IF (LEN (J) .NE. LN) GO TO 240 C jump if i and j do not have same number adj elts IF (ELEN (J) .NE. ELN) GO TO 240 C do not flag the first element in the list (me) DO 230 P = PE (J) + 1, PE (J) + int(LN - 1,8) C jump if an entry (iw(p)) is in j but not in i IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE C ------------------------------------------------- C found it! j can be absorbed into i C ------------------------------------------------- PE (J) = int(-I,8) C both nv (i) and nv (j) are negated since they C are in Lme, and the absolute values of each C are the number of variables in i and j: NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 C delete j from hash bucket J = NEXT (J) NEXT (JLAST) = J GO TO 220 C ------------------------------------------------- 240 CONTINUE C j cannot be absorbed into i C ------------------------------------------------- JLAST = J J = NEXT (J) GO TO 220 ENDIF C ---------------------------------------------------- C no more variables can be absorbed into i C go to next i in bucket and clear flag array C ---------------------------------------------------- WFLG = WFLG + 1 I = NEXT (I) IF (I .NE. 0) GO TO 200 ENDIF ENDIF 250 CONTINUE C======================================================================= C RESTORE DEGREE LISTS AND REMOVE NONPRINCIPAL SUPERVAR. FROM ELEMENT C======================================================================= P = PME1 NLEFT = N - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN C i is a principal variable in Lme C restore nv (i) to signify that i is principal NV (I) = NVI C ------------------------------------------------------- C compute the external degree (add size of current elem) C ------------------------------------------------------- DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) C ------------------------------------------------------- C place the supervariable at the head of the degree list C ------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I C ------------------------------------------------------- C save the new degree, and find the minimum degree C ------------------------------------------------------- MINDEG = min (MINDEG, DEG) DEGREE (I) = DEG C ------------------------------------------------------- C place the supervariable in the element pattern C ------------------------------------------------------- IW (P) = I P = P + 1 ENDIF 260 CONTINUE C======================================================================= C FINALIZE THE NEW ELEMENT C======================================================================= NV (ME) = NVPIV + DEGME C nv (me) is now the degree of pivot (including diagonal part) C save the length of the list for the new element me LEN (ME) = int(P - PME1) IF (LEN (ME) .EQ. 0) THEN C there is nothing left of the current pivot element PE (ME) = 0_8 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN C element was not constructed in place: deallocate part C of it (final size is less than or equal to newmem, C since newly nonprincipal variables have been removed). PFREE = P MEM = MEM - NEWMEM + int(LEN (ME),8) ENDIF C======================================================================= C END WHILE (selecting pivots) GO TO 30 ENDIF C======================================================================= C======================================================================= C COMPUTE THE PERMUTATION VECTORS C======================================================================= C ---------------------------------------------------------------- C The time taken by the following code is O(n). At this C point, elen (e) = -k has been done for all elements e, C and elen (i) = 0 has been done for all nonprincipal C variables i. At this point, there are no principal C supervariables left, and all elements are absorbed. C ---------------------------------------------------------------- C ---------------------------------------------------------------- C compute the ordering of unordered nonprincipal variables C ---------------------------------------------------------------- DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN C ---------------------------------------------------------- C i is an un-ordered row. Traverse the tree from i until C reaching an element, e. The element, e, was the C principal supervariable of i and all nodes in the path C from i to when e was selected as pivot. C ---------------------------------------------------------- J = int(-PE (I)) C while (j is a variable) do: 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = int(-PE (J)) GO TO 270 ENDIF E = J C ---------------------------------------------------------- C get the current pivot ordering of e C ---------------------------------------------------------- K = -ELEN (E) C ---------------------------------------------------------- C traverse the path again from i to e, and compress the C path (all nodes point to e). Path compression allows C this code to compute in O(n) time. Order the unordered C nodes in the path, and place the element e at the end. C ---------------------------------------------------------- J = I C while (j is a variable) do: 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = int(-PE (J)) PE (J) = int(-E,8) IF (ELEN (J) .EQ. 0) THEN C j is an unordered row ELEN (J) = K K = K + 1 ENDIF J = JNEXT GO TO 280 ENDIF C leave elen (e) negative, so we know it is an element ELEN (E) = -K ENDIF 290 CONTINUE C ---------------------------------------------------------------- C reset the inverse permutation (elen (1..n)) to be positive, C and compute the permutation (last (1..n)). C ---------------------------------------------------------------- DO 300 I = 1, N K = abs (ELEN (I)) LAST (K) = I ELEN (I) = K 300 CONTINUE C======================================================================= C RETURN THE MEMORY USAGE IN IW C======================================================================= C If maxmem is less than or equal to iwlen, then no compressions C occurred, and iw (maxmem+1 ... iwlen) was unused. Otherwise C compressions did occur, and iwlen would have had to have been C greater than or equal to maxmem for no compressions to occur. C Return the value of maxmem in the pfree argument. PFREE = MAXMEM C=============================== C Save PE in PARENT array DO I=1,N PARENT(I) = int(PE(I)) ENDDO C=============================== RETURN END SUBROUTINE MUMPS_AMD_ELT C ---------------------------------------------------------------------- C Description of MUMPS_HAMD: C MUMPS_HAMD is a modification of AMD reference code (MUMPS_ANA_H) C designed to take into account a halo in the graph. C The graph is composed is partitioned in two types of nodes C the so called internal nodes and the so called halo nodes. C Halo nodes cannot be selected the both the inital degrees C and updated degrees of internal node should be taken C into account. C This routine also referred to as HALOAMD in MUMPS comments C is used for both Schur functionality and in the coupling with C partitioners such as SCOTCH. C C Restrictive integer 64 bit variant : C it is assumed that IW array size can exceed 32-bit integer C C SUBROUTINE MUMPS_HAMD(N, IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, HEAD, NEXT, W, PARENT, & LISTVAR_SCHUR, SIZE_SCHUR) C C Parameters C Input not modified INTEGER, intent(in) :: SIZE_SCHUR INTEGER, intent(in) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: IWLEN C Input undefined on output INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) C C Output only INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: NV(N), ELEN(N), LAST(N), PARENT(N) C C Input/output INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(N) C C Internal Workspace only INTEGER :: NEXT(N), DEGREE(N), HEAD(N), W(N) C C --------------------- C Interface Description C --------------------- C HAMD (short for HALOAMD) C The initial version (so called HALOAMD_V1, developped in September 1997) C is designed to experiment the numerical (fill-in) impact C of taking into account the halo. This code should be able C to experiment no-halo, partial halo, complete halo. C DATE: September 17th 1997 C C HALOAMD is designed to process a gragh composed of two types C of nodes, V0 and V1, extracted from a larger gragh. C V0^V1 = {}, C C We used Min. degree heuristic to order only C nodes in V0, but the adjacency to nodes C in V1 is taken into account during ordering. C Nodes in V1 are odered at last. C Adjacency between nodes of V1 need not be provided, C however |len(i)| must always corresponds to the number of C edges effectively provided in the adjacency list of i. C On input : C ******** C Nodes INODE in V1 are flagged with len(INODE) = -degree C modif version HALO V3 (August 1998): C if len(i) =0 and i \in V1 then C len(i) must be set on input to -N-1 C ERROR return (negative values in ncmpa) C ************ C negative value in ncmpa indicates an error detected C by HALOAMD. C C The graph provided MUST follow the rule: C if (i,j) is an edge in the gragh then C j must be in the adjacency list of i AND C i must be in the adjacency list of j. C REMARKS: C 1/ Providing edges between nodes of V1 should not C affect the final ordering, only the amount of edges C of the halo should effectively affect the solution. C This code should work in the following cases: C 1/ halo not provided C 2/ halo partially provided C 3/ complete halo C 4/ complete halo+interconnection between nodes of V1. C C 1/ should run and provide identical results (w.r.t to current C implementation of AMD in SCOTCH). C 3/ and 4 should provide identical results. C C 2/ All modifications of the AMD initial code are indicated C with begin HALO .. end HALO C C C Ordering of nodes in V0 is based on C Approximate Minimum Degree ordering algorithm, C with aggressive absorption: C Given a representation of the nonzero pattern of a symmetric matrix, C A, (excluding the diagonal) perform an approximate minimum C degree ordering to compute a pivot order C such that fill-in in the Cholesky factors A = LL^T is kept low. C C ------------------------------ C Modification history: C --------------------- C Date: September, 1997 (V1) C April, 1998 (V2) C August, 1998 (V3) C Octobre, 1998 (V4) C December, 1998 (V5) C January, 1999 (V6) C HALOAMD_V6: C ---------- C 1/ ERROR 2 detection followed by stop statement suppressed C . 2/ pb 1 identified in V5 was not correctly solved C C HALOAMD_V5: C ---------- C 1/ Pb with matrix psmigr 1, because upper bound C degree DEG >N was considered as a node in V1 C C HALOAMD_V4: C ---------- C Only UnsymetrizedMultifrontal interface C (ok for both scotch and UnsymetricMultifrontal) is C included in this file C C HALOAMD_V3: C ---------- C Problem in version 2 : variables of V1 with len(i) =0 C are not well processed. C See modification of the C input to characterize those variables. C C Problem detected by Jacko Koster while experimenting with C version 2 of haloAMD in the context of multiple front method : C "if for an interface variable i, row i in the matrix has only a C nonzero entry on the diagonal, we first remove this entry and len(i) C is set to zero on input to HALOAMD. However, this means that HALOAMD C will treat variable i as an interior variable (in V0) instead as an C interface variable (in V1). (It is indeed a bit strange to have such C interface variables but we encountered some in our debugging C experiments with some random partitionings.) C C Solution : C IF on input i \in V1 and len(i) =0 (that is adjlist(i)={}) THEN C len(i) must be set on input to -N-1. C ENDIF C therefore all variables i / len(i) < 0 an only those are in V1 C variable with len(i) = -N-1 are then processed differently at C the beginning of the code C C HALOAMD_V2: C ---------- C The end of the tree (including links to block of flagged indices C is built) . The list of flagged indices is C considered as a dense amalgamated node. C C Comments on the OUTPUT: C ---------------------- C Let V= V0 U V1 the nodes of the initial graph (|V|=n). C The assembly tree corresponds to the tree C of the supernodes (or supervariables). Each node of the C assembly tree is then composed of one principal variable C and a list of secondary variables. The list of C variable of a node (principal + secondary variables) then C describes the structure of the diagonal bloc of the C supernode. C The elimination tree denotes the tree of all the variables(=node) and C is therefore of order n. C C The arrays NV(N) and PE(N) give a description of the C assembly tree. C 1/ Description of array nv(N) (on OUPUT) C nv(i)=0 i is a secondary variable C N+1> nv(i) >0 i is a principal variable, nv(i) holds the C the number of elements in column i of L (true degree of i) C 2/ Description of array PE(N) (on OUPUT) C pe(i) = -(father of variable/node i) in the elimination tree: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C 3/ Example: C Let If be a root node father of Is in the assembly tree. C If is the principal C variable of the node If and let If1, If2, If3 be the C secondary variables of node If. C Is is the principal C variable of the node Is and let Is1, Is2 be the secondary variables C of node Is. C C THEN: C NV(If1)=NV(If2)=NV(If3) = 0 (secondary variables) C NV(Is1)=NV(Is2) = 0 (secondary variables) C NV(If) > 0 ( principal variable) C NV(Is) > 0 ( principal variable) C PE(If) = 0 (root node) C PE(Is) = -If (If is the father of Is in the assembly tree) C PE(If1)=PE(If2)=PE(If3)= -If ( If is the principal variable) C PE(Is1)=PE(Is2)= -Is ( Is is the principal variable) C----------------------------------------------------------------------- C INPUT ARGUMENTS (unaltered): C----------------------------------------------------------------------- C n: The matrix order. C C Restriction: n .ge. 1 C iwlen: The length of iw (1..iwlen). On input, the matrix is C stored in iw (1..pfree-1). However, iw (1..iwlen) should be C slightly larger than what is required to hold the matrix, at C least iwlen .ge. pfree + n is recommended. Otherwise, C excessive compressions will take place. C *** We do not recommend running this algorithm with *** C *** iwlen .lt. pfree + n. *** C *** Better performance will be obtained if *** C *** iwlen .ge. pfree + n *** C *** or better yet *** C *** iwlen .gt. 1.2 * pfree *** C *** (where pfree is its value on input). *** C The algorithm will not run at all if iwlen .lt. pfree-1. C C Restriction: iwlen .ge. pfree-1 C----------------------------------------------------------------------- C INPUT/OUPUT ARGUMENTS: C----------------------------------------------------------------------- C pe: On input, pe (i) is the index in iw of the start of row i, or C zero if row i has no off-diagonal non-zeros. C C During execution, it is used for both supervariables and C elements: C C * Principal supervariable i: index into iw of the C description of supervariable i. A supervariable C represents one or more rows of the matrix C with identical nonzero pattern. C * Non-principal supervariable i: if i has been absorbed C into another supervariable j, then pe (i) = -j. C That is, j has the same pattern as i. C Note that j might later be absorbed into another C supervariable j2, in which case pe (i) is still -j, C and pe (j) = -j2. C * Unabsorbed element e: the index into iw of the description C of element e, if e has not yet been absorbed by a C subsequent element. Element e is created when C the supervariable of the same name is selected as C the pivot. C * Absorbed element e: if element e is absorbed into element C e2, then pe (e) = -e2. This occurs when the pattern of C e (that is, Le) is found to be a subset of the pattern C of e2 (that is, Le2). If element e is "null" (it has C no nonzeros outside its pivot block), then pe (e) = 0. C C On output, pe holds the assembly tree/forest, which implicitly C represents a pivot order with identical fill-in as the actual C order (via a depth-first search of the tree). C C On output: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C On output: (PE is copied on output into PARENT array) C C pfree: On input, the matrix is stored in iw (1..pfree-1) and C the rest of the array iw is free. C During execution, additional data is placed in iw, and pfree C is modified so that components of iw from pfree are free. C On output, pfree is set equal to the size of iw that C would have been needed for no compressions to occur. If C ncmpa is zero, then pfree (on output) is less than or equal to C iwlen, and the space iw (pfree+1 ... iwlen) was not used. C Otherwise, pfree (on output) is greater than iwlen, and all the C memory in iw was used. C----------------------------------------------------------------------- C INPUT/MODIFIED (undefined on output): C----------------------------------------------------------------------- C len: On input, len (i) C positive or null (>=0) : i \in V0 and C len(i) holds the number of entries in row i of the C matrix, excluding the diagonal. C negative (<0) : i \in V1, and C -len(i) hold the number of entries in row i of the C matrix, excluding the diagonal. C len(i) = - | Adj(i) | if i \in V1 C or -N -1 if | Adj(i) | = 0 and i \in V1 C The contents of len (1..n) C are undefined on output. C iw: On input, iw (1..pfree-1) holds the description of each row i C in the matrix. The matrix must be symmetric, and both upper C and lower triangular parts must be present. The diagonal must C not be present. Row i is held as follows: C C len (i): the length of the row i data structure C iw (pe (i) ... pe (i) + len (i) - 1): C the list of column indices for nonzeros C in row i (simple supervariables), excluding C the diagonal. All supervariables start with C one row/column each (supervariable i is just C row i). C if len (i) is zero on input, then pe (i) is ignored C on input. C C Note that the rows need not be in any particular order, C and there may be empty space between the rows. C C During execution, the supervariable i experiences fill-in. C This is represented by placing in i a list of the elements C that cause fill-in in supervariable i: C C len (i): the length of supervariable i C iw (pe (i) ... pe (i) + elen (i) - 1): C the list of elements that contain i. This list C is kept short by removing absorbed elements. C iw (pe (i) + elen (i) ... pe (i) + len (i) - 1): C the list of supervariables in i. This list C is kept short by removing nonprincipal C variables, and any entry j that is also C contained in at least one of the elements C (j in Le) in the list for i (e in row i). C C When supervariable i is selected as pivot, we create an C element e of the same name (e=i): C C len (e): the length of element e C iw (pe (e) ... pe (e) + len (e) - 1): C the list of supervariables in element e. C C An element represents the fill-in that occurs when supervariable C i is selected as pivot (which represents the selection of row i C and all non-principal variables whose principal variable is i). C We use the term Le to denote the set of all supervariables C in element e. Absorbed supervariables and elements are pruned C from these lists when computationally convenient. C C CAUTION: THE INPUT MATRIX IS OVERWRITTEN DURING COMPUTATION. C The contents of iw are undefined on output. C----------------------------------------------------------------------- C OUTPUT (need not be set on input): C----------------------------------------------------------------------- C nv: During execution, abs (nv (i)) is equal to the number of rows C that are represented by the principal supervariable i. If i is C a nonprincipal variable, then nv (i) = 0. Initially, C nv (i) = 1 for all i. nv (i) .lt. 0 signifies that i is a C principal variable in the pattern Lme of the current pivot C element me. On output, nv (e) holds the true degree of element C e at the time it was created (including the diagonal part). C begin HALO C On output, nv(I) can be used to find node in set V1. C nv(I) = N+1 characterizes nodes in V1. C end HALO C elen: See the description of iw above. At the start of execution, C elen (i) is set to zero. During execution, elen (i) is the C number of elements in the list for supervariable i. When e C becomes an element, elen (e) = -nel is set, where nel is the C current step of factorization. elen (i) = 0 is done when i C becomes nonprincipal. C C For variables, elen (i) .ge. 0 holds until just before the C permutation vectors are computed. For elements, C elen (e) .lt. 0 holds. C C On output elen (1..n) holds the inverse permutation (the same C as the 'INVP' argument in Sparspak). That is, if k = elen (i), C then row i is the kth pivot row. Row i of A appears as the C (elen(i))-th row in the permuted matrix, PAP^T. C last: In a degree list, last (i) is the supervariable preceding i, C or zero if i is the head of the list. In a hash bucket, C last (i) is the hash key for i. last (head (hash)) is also C used as the head of a hash bucket if head (hash) contains a C degree list (see head, below). C C On output, last (1..n) holds the permutation (the same as the C 'PERM' argument in Sparspak). That is, if i = last (k), then C row i is the kth pivot row. Row last (k) of A is the k-th row C in the permuted matrix, PAP^T. C ncmpa: The number of times iw was compressed. If this is C excessive, then the execution took longer than what could have C been. To reduce ncmpa, try increasing iwlen to be 10% or 20% C larger than the value of pfree on input (or at least C iwlen .ge. pfree + n). The fastest performance will be C obtained when ncmpa is returned as zero. If iwlen is set to C the value returned by pfree on *output*, then no compressions C will occur. C begin HALO C on output ncmpa <0 --> error detected during HALO_AMD: C error 1: ncmpa = -N , ordering was stopped. C end HALO C C----------------------------------------------------------------------- C LOCAL (not input or output - used only during execution): C----------------------------------------------------------------------- C degree: If i is a supervariable, then degree (i) holds the C current approximation of the external degree of row i (an upper C bound). The external degree is the number of nonzeros in row i, C minus abs (nv (i)) (the diagonal part). The bound is equal to C the external degree if elen (i) is less than or equal to two. C We also use the term "external degree" for elements e to refer C to |Le \ Lme|. If e is an element, then degree (e) holds |Le|, C which is the degree of the off-diagonal part of the element e C (not including the diagonal part). C begin HALO C degree(I) = n+1 indicates that i belongs to V1 C end HALO C C head: head is used for degree lists. head (deg) is the first C supervariable in a degree list (all supervariables i in a C degree list deg have the same approximate degree, namely, C deg = degree (i)). If the list deg is empty then C head (deg) = 0. C C During supervariable detection head (hash) also serves as a C pointer to a hash bucket. C If head (hash) .gt. 0, there is a degree list of degree hash. C The hash bucket head pointer is last (head (hash)). C If head (hash) = 0, then the degree list and hash bucket are C both empty. C If head (hash) .lt. 0, then the degree list is empty, and C -head (hash) is the head of the hash bucket. C After supervariable detection is complete, all hash buckets C are empty, and the (last (head (hash)) = 0) condition is C restored for the non-empty degree lists. C next: next (i) is the supervariable following i in a link list, or C zero if i is the last in the list. Used for two kinds of C lists: degree lists and hash buckets (a supervariable can be C in only one kind of list at a time). C w: The flag array w determines the status of elements and C variables, and the external degree of elements. C C for elements: C if w (e) = 0, then the element e is absorbed C if w (e) .ge. wflg, then w (e) - wflg is the size of C the set |Le \ Lme|, in terms of nonzeros (the C sum of abs (nv (i)) for each principal variable i that C is both in the pattern of element e and NOT in the C pattern of the current pivot element, me). C if wflg .gt. w (e) .gt. 0, then e is not absorbed and has C not yet been seen in the scan of the element lists in C the computation of |Le\Lme| in loop 150 below. C C for variables: C during supervariable detection, if w (j) .ne. wflg then j is C not in the pattern of variable i C C The w array is initialized by setting w (i) = 1 for all i, C and by setting wflg = 2. It is reinitialized if wflg becomes C too large (to ensure that wflg+n does not cause integer C overflow). C----------------------------------------------------------------------- C LOCAL INTEGERS: C----------------------------------------------------------------------- INTEGER :: DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, ME, MINDEG, NEL, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, & NBFLAG, NREAL, LASTD, NELME INTEGER KNT1_UPDATED, KNT2_UPDATED INTEGER(8) :: MAXMEM, MEM, NEWMEM INTEGER :: MAXINT_N INTEGER(8) :: HASH, HMOD C deg: the degree of a variable or element C degme: size, |Lme|, of the current element, me (= degree (me)) C dext: external degree, |Le \ Lme|, of some element e C dmax: largest |Le| seen so far C e: an element C elenme: the length, elen (me), of element list of pivotal var. C eln: the length, elen (...), of an element list C hash: the computed value of the hash function C hmod: the hash function is computed modulo hmod = max (1,n-1) C i: a supervariable C ilast: the entry in a link list preceding i C inext: the entry in a link list following i C j: a supervariable C jlast: the entry in a link list preceding j C jnext: the entry in a link list, or path, following j C k: the pivot order of an element or variable C knt1: loop counter used during element construction C knt2: loop counter used during element construction C knt3: loop counter used during compression C lenj: len (j) C ln: length of a supervariable list C maxint_n: large integer to test risk of overflow on wflg C maxmem: amount of memory needed for no compressions C me: current supervariable being eliminated, and the C current element created by eliminating that C supervariable C mem: memory in use assuming no compressions have occurred C mindeg: current minimum degree C nel: number of pivots selected so far C newmem: amount of new memory needed for current pivot element C nleft: n - nel, the number of nonpivotal rows/columns remaining C nvi: the number of variables in a supervariable i (= nv (i)) C nvj: the number of variables in a supervariable j (= nv (j)) C nvpiv: number of pivots in current element C slenme: number of variables in variable list of pivotal variable C we: w (e) C wflg: used for flagging the w array. See description of iw. C wnvi: wflg - nv (i) C x: either a supervariable or an element C begin HALO C nbflag: number of flagged entries in the initial gragh. C nreal : number of entries on which ordering must be perfomed C (nreel = N- nbflag) C nelme number of pivots selected when reaching the root C lastd index of the last row in the list of dense rows C end HALO C----------------------------------------------------------------------- C LOCAL POINTERS: C----------------------------------------------------------------------- INTEGER(8) :: P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, & PN, PSRC C Any parameter (pe (...) or pfree) or local variable C starting with "p" (for Pointer) is an index into iw, C and all indices into iw use variables starting with C "p." The only exception to this rule is the iwlen C input argument. C p: pointer into lots of things C p1: pe (i) for some variable i (start of element list) C p2: pe (i) + elen (i) - 1 for some var. i (end of el. list) C p3: index of first supervariable in clean list C pdst: destination pointer, for compression C pend: end of memory to compress C pj: pointer into an element or variable C pme: pointer into the current element (pme1...pme2) C pme1: the current element, me, is stored in iw (pme1...pme2) C pme2: the end of the current element C pn: pointer into a "clean" variable, also used to compress C psrc: source pointer, for compression C----------------------------------------------------------------------- C FUNCTIONS CALLED: C----------------------------------------------------------------------- INTRINSIC max, min, mod C======================================================================= C INITIALIZATIONS C======================================================================= WFLG = 2 MAXINT_N=huge(WFLG)-N MINDEG = 1 NCMPA = 0 NEL = 0 HMOD = int(max (1, N-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM C begin HALO NBFLAG = 0 LASTD = 0 C end HALO DO 10 I = 1, N LAST (I) = 0 HEAD (I) = 0 NV (I) = 1 W (I) = 1 ELEN (I) = 0 DEGREE(I) = LEN(I) 10 CONTINUE C C begin HALO-SCHUR NBFLAG = SIZE_SCHUR C DO K=1,SIZE_SCHUR C I = LISTVAR_SCHUR(K) DEGREE(I) = N+1 IF ((LEN(I) .EQ.0).OR.(LEN(I).EQ.-N-1)) THEN C Both ways of characterizing i \in Schur with Adj(I) = 0 C Because of compress, we force skipping this C entry which is anyway empty PE (I) = 0_8 LEN(I) = 0 ENDIF C insert I at the end of degree list of n C (safe: because max external degree is N-1) DEG = N IF (LASTD.EQ.0) THEN C degree list is empty LASTD = I HEAD(DEG) = I NEXT(I) = 0 LAST(I) = 0 ELSE NEXT(LASTD) = I LAST(I) = LASTD LASTD = I NEXT(I) = 0 ENDIF C ENDDO C number of entries to be ordered. NREAL = N - NBFLAG C end HALO-SCHUR C ---------------------------------------------------------------- C initialize degree lists and eliminate rows with no off-diag. nz. C ---------------------------------------------------------------- DO 20 I = 1, N DEG = DEGREE (I) C begin HALO-SCHUR IF (DEG.EQ.N+1) GOTO 20 C end HALO-SCHUR C IF (DEG .GT. 0) THEN C ---------------------------------------------------------- C place i in the degree list corresponding to its degree C ---------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ELSE C ---------------------------------------------------------- C we have a variable that can be eliminated at once because C there is no off-diagonal non-zero in its row. C ---------------------------------------------------------- NEL = NEL + NV(I) ELEN (I) = -NEL PE (I) = 0_8 W (I) = 0 ENDIF 20 CONTINUE C======================================================================= C WHILE (selecting pivots) DO C======================================================================= C begin HALO V5 NLEFT = N-NEL C end HALO V5 C begin HALO C AMD test: 30 IF (NEL .LT. N) THEN 30 IF (NEL .LT. NREAL) THEN C end HALO C======================================================================= C GET PIVOT OF MINIMUM DEGREE C======================================================================= C ------------------------------------------------------------- C find next supervariable for elimination C ------------------------------------------------------------- DO 40 DEG = MINDEG, N ME = HEAD (DEG) IF (ME .GT. 0) GO TO 50 40 CONTINUE 50 MINDEG = DEG C begin HALO IF (ME.LE.0) THEN write (*,*) ' ERROR 1 in HALO_AMD ' C return to calling program with error return NCMPA = -N GOTO 500 ENDIF C end HALO C ------------------------------------------------------------- C remove chosen variable from link list C ------------------------------------------------------------- INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT C ------------------------------------------------------------- C me represents the elimination of pivots nel+1 to nel+nv(me). C place me itself as the first in this set. It will be moved C to the nel+nv(me) position when the permutation vectors are C computed. C ------------------------------------------------------------- ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV C======================================================================= C CONSTRUCT NEW ELEMENT C======================================================================= C ------------------------------------------------------------- C At this point, me is the pivotal supervariable. It will be C converted into the current element. Scan list of the C pivotal supervariable, me, setting tree pointers and C constructing new list of supervariables for the new element, C me. p is a pointer to the current position in the old list. C ------------------------------------------------------------- C flag the variable "me" as being in Lme by negating nv (me) NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN C ---------------------------------------------------------- C construct the new element in place C ---------------------------------------------------------- PME1 = PE (ME) PME2 = PME1 - 1 DO 60 P = PME1, PME1 + LEN (ME) - 1 I = IW (P) NVI = NV (I) IF (NVI .GT. 0) THEN C ---------------------------------------------------- C i is a principal variable not yet placed in Lme. C store i in new list C ---------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I C begin HALO IF (DEGREE(I).LE.N) THEN C end HALO C ---------------------------------------------------- C remove variable i from degree list. (only if i \in V0) C ---------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (DEGREE (I)) = INEXT ENDIF C begin HALO ENDIF C end HALO ENDIF 60 CONTINUE C this element takes no new memory in iw: NEWMEM = 0 ELSE C ---------------------------------------------------------- C construct the new element in empty space, iw (pfree ...) C ---------------------------------------------------------- P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME KNT1_UPDATED = 0 DO 120 KNT1 = 1, ELENME + 1 KNT1_UPDATED = KNT1_UPDATED +1 IF (KNT1 .GT. ELENME) THEN C search the supervariables in me. E = ME PJ = P LN = SLENME ELSE C search the elements in me. E = IW (P) P = P + 1 PJ = PE (E) LN = LEN (E) ENDIF C ------------------------------------------------------- C search for different supervariables and add them to the C new list, compressing when necessary. this loop is C executed once for each element in the list and once for C all the supervariables in the list. C ------------------------------------------------------- KNT2_UPDATED = 0 DO 110 KNT2 = 1, LN KNT2_UPDATED = KNT2_UPDATED+1 I = IW (PJ) PJ = PJ + 1 NVI = NV (I) IF (NVI .GT. 0) THEN C ------------------------------------------------- C compress iw, if necessary C ------------------------------------------------- IF (PFREE .GT. IWLEN) THEN C prepare for compressing iw by adjusting C pointers and lengths so that the lists being C searched in the inner and outer loops contain C only the remaining entries. PE (ME) = P LEN (ME) = LEN (ME) - KNT1_UPDATED C Reset KNT1_UPDATED in case of recompress C at same iteration of the loop 120 KNT1_UPDATED = 0 C Check if anything left in supervariable ME IF (LEN (ME) .EQ. 0) PE (ME) = 0_8 PE (E) = PJ LEN (E) = LN - KNT2_UPDATED C Reset KNT2_UPDATED in case of recompress C at same iteration of the loop 110 KNT2_UPDATED = 0 C Check if anything left in element E IF (LEN (E) .EQ. 0) PE (E) = 0 NCMPA = NCMPA + 1 C store first item in pe C set first entry to -item DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = int(IW (PN),8) IW (PN) = -J ENDIF 70 CONTINUE C psrc/pdst point to source/destination PDST = 1 PSRC = 1 PEND = PME1 - 1 C while loop: 80 CONTINUE IF (PSRC .LE. PEND) THEN C search for next negative entry J = -IW (PSRC) PSRC = PSRC + 1 IF (J .GT. 0) THEN IW (PDST) = int(PE (J)) PE (J) = PDST PDST = PDST + 1 C copy from source to destination LENJ = LEN (J) DO 90 KNT3 = 0, LENJ - 2 IW (PDST + KNT3) = IW (PSRC + KNT3) 90 CONTINUE PDST = PDST + LENJ - 1 PSRC = PSRC + LENJ - 1 ENDIF GO TO 80 ENDIF C move the new partially-constructed element P1 = PDST DO 100 PSRC = PME1, PFREE - 1 IW (PDST) = IW (PSRC) PDST = PDST + 1 100 CONTINUE PME1 = P1 PFREE = PDST PJ = PE (E) P = PE (ME) ENDIF C ------------------------------------------------- C i is a principal variable not yet placed in Lme C store i in new list C ------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI IW (PFREE) = I PFREE = PFREE + 1 C begin HALO IF (DEGREE(I).LE.N) THEN C end HALO C ------------------------------------------------- C remove variable i from degree link list C (only if i in V0) C ------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (DEGREE (I)) = INEXT ENDIF C begin HALO ENDIF C end HALO ENDIF 110 CONTINUE IF (E .NE. ME) THEN C set tree pointer and flag to indicate element e is C absorbed into new element me (the parent of e is me) PE (E) = int(-ME,8) W (E) = 0 ENDIF 120 CONTINUE PME2 = PFREE - 1 C this element takes newmem new memory in iw (possibly zero) NEWMEM = PFREE - PME1 MEM = MEM + NEWMEM MAXMEM = max (MAXMEM, MEM) ENDIF C ------------------------------------------------------------- C me has now been converted into an element in iw (pme1..pme2) C ------------------------------------------------------------- C degme holds the external degree of new element DEGREE (ME) = DEGME PE (ME) = PME1 LEN (ME) = int(PME2 - PME1 + 1_8) C ------------------------------------------------------------- C make sure that wflg is not too large. With the current C value of wflg, wflg+n must not cause integer overflow C ------------------------------------------------------------- IF (WFLG .GT. MAXINT_N) THEN DO 130 X = 1, N IF (W (X) .NE. 0) W (X) = 1 130 CONTINUE WFLG = 2 ENDIF C======================================================================= C COMPUTE (w (e) - wflg) = |Le\Lme| FOR ALL ELEMENTS C======================================================================= C ------------------------------------------------------------- C Scan 1: compute the external degrees of previous elements C with respect to the current element. That is: C (w (e) - wflg) = |Le \ Lme| C for each element e that appears in any supervariable in Lme. C The notation Le refers to the pattern (list of C supervariables) of a previous element e, where e is not yet C absorbed, stored in iw (pe (e) + 1 ... pe (e) + iw (pe (e))). C The notation Lme refers to the pattern of the current element C (stored in iw (pme1..pme2)). If (w (e) - wflg) becomes C zero, then the element e will be absorbed in scan 2. C ------------------------------------------------------------- DO 150 PME = PME1, PME2 I = IW (PME) ELN = ELEN (I) IF (ELN .GT. 0) THEN C note that nv (i) has been negated to denote i in Lme: NVI = -NV (I) WNVI = WFLG - NVI DO 140 P = PE (I), PE (I) + int(ELN - 1,8) E = IW (P) WE = W (E) IF (WE .GE. WFLG) THEN C unabsorbed element e has been seen in this loop WE = WE - NVI ELSE IF (WE .NE. 0) THEN C e is an unabsorbed element C this is the first we have seen e in all of Scan 1 WE = DEGREE (E) + WNVI ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE C======================================================================= C DEGREE UPDATE AND ELEMENT ABSORPTION C======================================================================= C ------------------------------------------------------------- C Scan 2: for each i in Lme, sum up the degree of Lme (which C is degme), plus the sum of the external degrees of each Le C for the elements e appearing within i, plus the C supervariables in i. Place i in hash list. C ------------------------------------------------------------- DO 180 PME = PME1, PME2 I = IW (PME) P1 = PE (I) P2 = P1 + ELEN (I) - 1 PN = P1 HASH = 0_8 DEG = 0 C ---------------------------------------------------------- C scan the element list associated with supervariable i C ---------------------------------------------------------- DO 160 P = P1, P2 E = IW (P) C dext = | Le \ Lme | DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN DEG = DEG + DEXT IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) ELSE IF (DEXT .EQ. 0) THEN #if defined (NOAGG3) IW (PN) = E PN = PN + 1 HASH = HASH + E #else C aggressive absorption: e is not adjacent to me, but C the |Le \ Lme| is 0, so absorb it into me PE (E) = int(-ME,8) W (E) = 0 #endif ENDIF 160 CONTINUE C count the number of elements in i (including me): ELEN (I) = int(PN - P1 + 1_8) C ---------------------------------------------------------- C scan the supervariables in the list associated with i C ---------------------------------------------------------- P3 = PN DO 170 P = P2 + 1, P1 + int(LEN (I) - 1,8) J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN C j is unabsorbed, and not in Lme. C add to degree and add to new list DEG = DEG + NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE C begin HALO IF (DEGREE(I).EQ.N+1) DEG = N+1 C end HALO C ---------------------------------------------------------- C update the degree and check for mass elimination C ---------------------------------------------------------- #if defined (NOAGG3) IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN #else IF (DEG .EQ. 0) THEN #endif C ------------------------------------------------------- C mass elimination C ------------------------------------------------------- C There is nothing left of this node except for an C edge to the current pivot element. elen (i) is 1, C and there are no variables adjacent to node i. C Absorb i into the current pivot element, me. PE (I) = int(-ME,8) NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE C ------------------------------------------------------- C update the upper-bound degree of i C ------------------------------------------------------- C the following degree does not yet include the size C of the current element, which is added later: C begin HALO V6 IF (DEGREE(I).NE.N+1) THEN C I does not belong to halo DEG = min (DEG, NLEFT) DEGREE (I) = min (DEGREE (I), DEG) ENDIF C end HALO V6 C ------------------------------------------------------- C add me to the list for i C ------------------------------------------------------- C move first supervariable to end of list IW (PN) = IW (P3) C move first element to end of element part of list IW (P3) = IW (P1) C add new element to front of list. IW (P1) = ME C store the new length of the list in len (i) LEN (I) = int(PN - P1 + 1) C begin HALO IF (DEG.LE.N) THEN C end HALO C ------------------------------------------------------- C place in hash bucket. Save hash key of i in last (i). C ------------------------------------------------------- HASH = mod (HASH, HMOD) + 1_8 J = HEAD (HASH) IF (J .LE. 0) THEN C the degree list is empty, hash head is -j NEXT (I) = -J HEAD (HASH) = -I ELSE C degree list is not empty C use last (head (hash)) as hash head NEXT (I) = LAST (J) LAST (J) = I ENDIF LAST (I) = int(HASH, kind=kind(LAST)) C begin HALO ENDIF C end HALO ENDIF 180 CONTINUE DEGREE (ME) = DEGME C ------------------------------------------------------------- C Clear the counter array, w (...), by incrementing wflg. C ------------------------------------------------------------- DMAX = max (DMAX, DEGME) WFLG = WFLG + DMAX C make sure that wflg+n does not cause integer overflow IF (WFLG .GT. MAXINT_N) THEN DO 190 X = 1, N IF (W (X) .NE. 0) W (X) = 1 190 CONTINUE WFLG = 2 ENDIF C at this point, w (1..n) .lt. wflg holds C======================================================================= C SUPERVARIABLE DETECTION C======================================================================= DO 250 PME = PME1, PME2 I = IW (PME) C begin HALO C old AMD IF (NV (I) .LT. 0) THEN IF ( (NV (I) .LT. 0) .AND. (DEGREE(I) .LE. N) ) THEN C end HALO C i is a principal variable in Lme C ------------------------------------------------------- C examine all hash buckets with 2 or more variables. We C do this by examing all unique hash keys for super- C variables in the pattern Lme of the current element, me C ------------------------------------------------------- HASH = int(LAST (I),kind=8) C let i = head of hash bucket, and empty the hash bucket J = HEAD (HASH) IF (J .EQ. 0) GO TO 250 IF (J .LT. 0) THEN C degree list is empty I = -J HEAD (HASH) = 0 ELSE C degree list is not empty, restore last () of head I = LAST (J) LAST (J) = 0 ENDIF IF (I .EQ. 0) GO TO 250 C while loop: 200 CONTINUE IF (NEXT (I) .NE. 0) THEN C ---------------------------------------------------- C this bucket has one or more variables following i. C scan all of them to see if i can absorb any entries C that follow i in hash bucket. Scatter i into w. C ---------------------------------------------------- LN = LEN (I) ELN = ELEN (I) C do not flag the first element in the list (me) DO 210 P = PE (I) + 1, PE (I) + LN - 1 W (IW (P)) = WFLG 210 CONTINUE C ---------------------------------------------------- C scan every other entry j following i in bucket C ---------------------------------------------------- JLAST = I J = NEXT (I) C while loop: 220 CONTINUE IF (J .NE. 0) THEN C ------------------------------------------------- C check if j and i have identical nonzero pattern C ------------------------------------------------- C jump if i and j do not have same size data structure IF (LEN (J) .NE. LN) GO TO 240 C jump if i and j do not have same number adj elts IF (ELEN (J) .NE. ELN) GO TO 240 C do not flag the first element in the list (me) DO 230 P = PE (J) + 1, PE (J) + LN - 1 C jump if an entry (iw(p)) is in j but not in i IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE C ------------------------------------------------- C found it! j can be absorbed into i C ------------------------------------------------- PE (J) = int(-I,8) C both nv (i) and nv (j) are negated since they C are in Lme, and the absolute values of each C are the number of variables in i and j: NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 C delete j from hash bucket J = NEXT (J) NEXT (JLAST) = J GO TO 220 C ------------------------------------------------- 240 CONTINUE C j cannot be absorbed into i C ------------------------------------------------- JLAST = J J = NEXT (J) GO TO 220 ENDIF C ---------------------------------------------------- C no more variables can be absorbed into i C go to next i in bucket and clear flag array C ---------------------------------------------------- WFLG = WFLG + 1 I = NEXT (I) IF (I .NE. 0) GO TO 200 ENDIF ENDIF 250 CONTINUE C======================================================================= C RESTORE DEGREE LISTS AND REMOVE NONPRINCIPAL SUPERVAR. FROM ELEMENT C======================================================================= P = PME1 NLEFT = N - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN C i is a principal variable in Lme C restore nv (i) to signify that i is principal NV (I) = NVI C begin HALO IF (DEGREE(I).LE.N) THEN C end HALO C ------------------------------------------------------- C compute the external degree (add size of current elem) C ------------------------------------------------------- DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) C ------------------------------------------------------- C place the supervariable at the head of the degree list C ------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I C ------------------------------------------------------- C save the new degree, and find the minimum degree C ------------------------------------------------------- MINDEG = min (MINDEG, DEG) DEGREE (I) = DEG C begin HALO ENDIF C end HALO C ------------------------------------------------------- C place the supervariable in the element pattern C ------------------------------------------------------- IW (P) = I P = P + 1 ENDIF 260 CONTINUE C======================================================================= C FINALIZE THE NEW ELEMENT C======================================================================= NV (ME) = NVPIV + DEGME C nv (me) is now the degree of pivot (including diagonal part) C save the length of the list for the new element me LEN (ME) = int(P - PME1) IF (LEN (ME) .EQ. 0) THEN C there is nothing left of the current pivot element PE (ME) = 0_8 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN C element was not constructed in place: deallocate part C of it (final size is less than or equal to newmem, C since newly nonprincipal variables have been removed). PFREE = P MEM = MEM - NEWMEM + LEN (ME) ENDIF C======================================================================= C END WHILE (selecting pivots) GO TO 30 ENDIF C======================================================================= C begin HALO V2 IF (NEL.LT.N) THEN C C All possible pivots (not flagged have been eliminated). C We amalgamate all flagged variables at the root and C we finish the elimination tree. C 1/ Go through all C non absorbed elements (root of the subgraph) C and absorb in ME C 2/ perform mass elimination of all dense rows DO DEG = MINDEG, N ME = HEAD (DEG) IF (ME .GT. 0) GO TO 51 ENDDO 51 MINDEG = DEG C IF (ME.NE.LISTVAR_SCHUR(1)) THEN write(6,*) ' ERROR 2 in MUMPS_HAMD ' write(6,*) ' wrong principal var for Schur !!' NCMPA = -N - 2 CALL MUMPS_ABORT() ENDIF C NELME = -(NEL+1) DO X=1,N IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN C X is an unabsorbed element PE(X) = int(-ME,8) C W(X) = 0 could be suppressed ?? check it ELSEIF (DEGREE(X).EQ.N+1) THEN C X is a dense row, absorb it in ME (mass elimination) NEL = NEL + NV(X) PE(X) = int(-ME,8) ELEN(X) = 0 C Correct value of NV is (secondary variable) NV(X) = 0 ENDIF ENDDO C ME is the root node ELEN(ME) = NELME C Correct value of NV is (principal variable) NV(ME) = N-NREAL PE(ME) = 0 C end HALO V2 C C begin HALO IF (NEL.NE.N) THEN write(*,*) ' ERROR 2 in MUMPS_HAMD NEL, N=', NEL,N NCMPA = -N - 1 ENDIF ENDIF C end HALO C======================================================================= C COMPUTE THE PERMUTATION VECTORS C======================================================================= C ---------------------------------------------------------------- C The time taken by the following code is O(n). At this C point, elen (e) = -k has been done for all elements e, C and elen (i) = 0 has been done for all nonprincipal C variables i. At this point, there are no principal C supervariables left, and all elements are absorbed. C ---------------------------------------------------------------- C ---------------------------------------------------------------- C compute the ordering of unordered nonprincipal variables C ---------------------------------------------------------------- DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN C ---------------------------------------------------------- C i is an un-ordered row. Traverse the tree from i until C reaching an element, e. The element, e, was the C principal supervariable of i and all nodes in the path C from i to when e was selected as pivot. C ---------------------------------------------------------- J = int(-PE (I)) C while (j is a variable) do: 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = int(-PE (J)) GO TO 270 ENDIF E = J C ---------------------------------------------------------- C get the current pivot ordering of e C ---------------------------------------------------------- K = -ELEN (E) C ---------------------------------------------------------- C traverse the path again from i to e, and compress the C path (all nodes point to e). Path compression allows C this code to compute in O(n) time. Order the unordered C nodes in the path, and place the element e at the end. C ---------------------------------------------------------- J = I C while (j is a variable) do: 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = int(-PE (J)) PE (J) = int(-E,8) IF (ELEN (J) .EQ. 0) THEN C j is an unordered row ELEN (J) = K K = K + 1 ENDIF J = JNEXT GO TO 280 ENDIF C leave elen (e) negative, so we know it is an element ELEN (E) = -K ENDIF 290 CONTINUE C ---------------------------------------------------------------- C reset the inverse permutation (elen (1..n)) to be positive, C and compute the permutation (last (1..n)). C ---------------------------------------------------------------- DO 300 I = 1, N K = abs (ELEN (I)) LAST (K) = I ELEN (I) = K 300 CONTINUE C======================================================================= C RETURN THE MEMORY USAGE IN IW C======================================================================= C If maxmem is less than or equal to iwlen, then no compressions C occurred, and iw (maxmem+1 ... iwlen) was unused. Otherwise C compressions did occur, and iwlen would have had to have been C greater than or equal to maxmem for no compressions to occur. C Return the value of maxmem in the pfree argument. 500 PFREE = MAXMEM C=============================== C Save IPE in PARENT array DO I=1,N PARENT(I) = int(PE(I)) ENDDO C=============================== RETURN END SUBROUTINE MUMPS_HAMD C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Description of MUMPS_HAMF4: C MUMPS_HAMF4 is a modified version of halo AMD routine MUMPS_HAMD C implementing an approximate minimum fill-in heuritic. C Version provided to F. Pellegrini on Nov 2000 to be used in SCOTCH. C Approximation of level4 of the minimum fill heuristic C C Restrictive integer 64 bit variant : C it is assumed that IW array size can exceed 32-bit integer C SUBROUTINE MUMPS_HAMF4 & (NORIG, N, COMPUTE_PERM, NBBUCK, & IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, WF, NEXT, W, HEAD & , PARENT & ) IMPLICIT NONE C C Parameters C Input not modified C N : number of nodes in the complete graph including halo C NORIG : C if compressed graph (nv(1).ne-1) then C NORIG is the sum(nv(i)) for i \in [1:N] C else NORIG = N INTEGER, INTENT(IN) :: NORIG, N, NBBUCK LOGICAL, INTENT(IN) :: COMPUTE_PERM INTEGER(8), INTENT(IN) :: IWLEN C Input undefined on output INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) C NV also meaningful as input to encode compressed graphs INTEGER, INTENT(INOUT) :: NV(N) C C Output only INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: ELEN(N), LAST(N) INTEGER, INTENT(OUT) :: PARENT(N) C C Input/output INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(N) C C Internal Workspace only C Min fill approximation one extra array of size NBBUCK+2 C is also needed INTEGER :: NEXT(N), DEGREE(N), W(N) INTEGER :: HEAD(0:NBBUCK+1), WF(N) C C Comments on the OUTPUT: C ---------------------- C Let V= V0 U V1 the nodes of the initial graph (|V|=n). C The assembly tree corresponds to the tree C of the supernodes (or supervariables). Each node of the C assembly tree is then composed of one principal variable C and a list of secondary variables. The list of C variable of a node (principal + secondary variables) then C describes the structure of the diagonal bloc of the C supernode. C The elimination tree denotes the tree of all the variables(=node) and C is therefore of order n. C C The arrays NV(N) and PE(N) give a description of the C assembly tree. C Note that on output C INTEGER(8) PE array is copied on output into C INTEGER PARENT array C C 1/ Description of array nv(N) (on OUTPUT) C nv(i)=0 i is a secondary variable C nv(i) >0 i is a principal variable, nv(i) holds the C the number of elements in column i of L (true degree of i) C With compressed graph (nv(1).ne.-1 on input), C nv(i) can be greater than N since degree can be as large as NORIG C C 2/ Description of array PE(N) (on OUTPUT) C Note that on C pe(i) = -(father of variable/node i) in the elimination tree: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C C 3/ Example: C Let If be a root node father of Is in the assembly tree. C If is the principal C variable of the node If and let If1, If2, If3 be the secondary variables C of node If. C Is is the principal C variable of the node Is and let Is1, Is2 be the secondary variables C of node Is. C C THEN: C NV(If1)=NV(If2)=NV(If3) = 0 (secondary variables) C NV(Is1)=NV(Is2) = 0 (secondary variables) C NV(If) > 0 ( principal variable) C NV(Is) > 0 ( principal variable) C PE(If) = 0 (root node) C PE(Is) = -If (If is the father of Is in the assembly tree) C PE(If1)=PE(If2)=PE(If3)= -If ( If is the principal variable) C PE(Is1)=PE(Is2)= -Is ( Is is the principal variable) C C C C HALOAMD_V1: (September 1997) C ********** C Initial version designed to experiment the numerical (fill-in) impact C of taking into account the halo. This code should be able C to experiment no-halo, partial halo, complete halo. C DATE: September 17th 1997 C C HALOAMD is designed to process a gragh composed of two types C of nodes, V0 and V1, extracted from a larger gragh. C V0^V1 = {}, C C We used Min. degree heuristic to order only C nodes in V0, but the adjacency to nodes C in V1 is taken into account during ordering. C Nodes in V1 are odered at last. C Adjacency between nodes of V1 need not be provided, C however |len(i)| must always corresponds to the number of C edges effectively provided in the adjacency list of i. C On input : c ******** C Nodes INODE in V1 are flagged with len(INODE) = -degree C if len(i) =0 and i \in V1 then C len(i) must be set on input to -NORIG-1 C ERROR return (negative values in ncmpa) C ************ C negative value in ncmpa indicates an error detected C by HALOAMD. C C The graph provided MUST follow the rule: C if (i,j) is an edge in the gragh then C j must be in the adjacency list of i AND C i must be in the adjacency list of j. C REMARKS C ------- C C 1/ Providing edges between nodes of V1 should not C affect the final ordering, only the amount of edges C of the halo should effectively affect the solution. C This code should work in the following cases: C 1/ halo not provided C 2/ halo partially provided C 3/ complete halo C 4/ complete halo+interconnection between nodes of V1. C C 1/ should run and provide identical results (w.r.t to current C implementation of AMD in SCOTCH). C 3/ and 4 should provide identical results. C C 2/ All modifications of the AMD initial code are indicated C with begin HALO .. end HALO C C C Given a representation of the nonzero pattern of a symmetric matrix, C A, (excluding the diagonal) perform an approximate minimum C fill-in heuristic. Aggresive absorption is C used to tighten the bound on the degree. This can result an C significant improvement in the quality of the ordering for C some matrices. C----------------------------------------------------------------------- C INPUT ARGUMENTS (unaltered): C----------------------------------------------------------------------- C n: The matrix order. C Restriction: n .ge. 1 C compute_perm : indicates if permutations should be computed C on output in last/elen C iwlen: The length of iw (1..iwlen). On input, the matrix is C stored in iw (1..pfree-1). However, iw (1..iwlen) should be C slightly larger than what is required to hold the matrix, at C least iwlen .ge. pfree + n is recommended. Otherwise, C excessive compressions will take place. C *** We do not recommend running this algorithm with *** C *** iwlen .lt. pfree + n. *** C *** Better performance will be obtained if *** C *** iwlen .ge. pfree + n *** C *** or better yet *** C *** iwlen .gt. 1.2 * pfree *** C *** (where pfree is its value on input). *** C The algorithm will not run at all if iwlen .lt. pfree-1. C C Restriction: iwlen .ge. pfree-1 C----------------------------------------------------------------------- C INPUT/OUPUT ARGUMENTS: C----------------------------------------------------------------------- C pe: On input, pe (i) is the index in iw of the start of row i, or C zero if row i has no off-diagonal non-zeros. C C During execution, it is used for both supervariables and C elements: C C * Principal supervariable i: index into iw of the C description of supervariable i. A supervariable C represents one or more rows of the matrix C with identical nonzero pattern. C * Non-principal supervariable i: if i has been absorbed C into another supervariable j, then pe (i) = -j. C That is, j has the same pattern as i. C Note that j might later be absorbed into another C supervariable j2, in which case pe (i) is still -j, C and pe (j) = -j2. C * Unabsorbed element e: the index into iw of the description C of element e, if e has not yet been absorbed by a C subsequent element. Element e is created when C the supervariable of the same name is selected as C the pivot. C * Absorbed element e: if element e is absorbed into element C e2, then pe (e) = -e2. This occurs when the pattern of C e (that is, Le) is found to be a subset of the pattern C of e2 (that is, Le2). If element e is "null" (it has C no nonzeros outside its pivot block), then pe (e) = 0. C C On output, pe holds the assembly tree/forest, which implicitly C represents a pivot order with identical fill-in as the actual C order (via a depth-first search of the tree). C C On output: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C On output: (PE is copied on output into PARENT array) C C pfree: On input, the matrix is stored in iw (1..pfree-1) and C the rest of the array iw is free. C During execution, additional data is placed in iw, and pfree C is modified so that components of iw from pfree are free. C On output, pfree is set equal to the size of iw that C would have been needed for no compressions to occur. If C ncmpa is zero, then pfree (on output) is less than or equal to C iwlen, and the space iw (pfree+1 ... iwlen) was not used. C Otherwise, pfree (on output) is greater than iwlen, and all the C memory in iw was used. C C nv: On input, encoding of compressed graph: C if NV(1) = -1 then graph is not compressed otherwise C NV(I) holds the weight of node I. C During execution, abs (nv (i)) is equal to the number of rows C that are represented by the principal supervariable i. If i is C a nonprincipal variable, then nv (i) = 0. Initially, C nv (i) = 1 for all i. nv (i) .lt. 0 signifies that i is a C principal variable in the pattern Lme of the current pivot C element me. On output, nv (e) holds the true degree of element C e at the time it was created (including the diagonal part). C begin HALO C On output, nv(I) can be used to find node in set V1. C Not true anymore : ( nv(I) = N+1 characterizes nodes in V1 C instead nodes in V1 are considered as a dense root node ) C end HALO C----------------------------------------------------------------------- C INPUT/MODIFIED (undefined on output): C----------------------------------------------------------------------- C len: On input, len (i) C positive or null (>=0) : i \in V0 and C len(i) holds the number of entries in row i of the C matrix, excluding the diagonal. C negative (<0) : i \in V1, and C -len(i) hold the number of entries in row i of the C matrix, excluding the diagonal. C The contents of len (1..n) C are undefined on output. C iw: On input, iw (1..pfree-1) holds the description of each row i C in the matrix. The matrix must be symmetric, and both upper C and lower triangular parts must be present. The diagonal must C not be present. Row i is held as follows: C C len (i): the length of the row i data structure C iw (pe (i) ... pe (i) + len (i) - 1): C the list of column indices for nonzeros C in row i (simple supervariables), excluding C the diagonal. All supervariables start with C one row/column each (supervariable i is just C row i). C if len (i) is zero on input, then pe (i) is ignored C on input. C C Note that the rows need not be in any particular order, C and there may be empty space between the rows. C C During execution, the supervariable i experiences fill-in. C This is represented by placing in i a list of the elements C that cause fill-in in supervariable i: C C len (i): the length of supervariable i C iw (pe (i) ... pe (i) + elen (i) - 1): C the list of elements that contain i. This list C is kept short by removing absorbed elements. C iw (pe (i) + elen (i) ... pe (i) + len (i) - 1): C the list of supervariables in i. This list C is kept short by removing nonprincipal C variables, and any entry j that is also C contained in at least one of the elements C (j in Le) in the list for i (e in row i). C C When supervariable i is selected as pivot, we create an C element e of the same name (e=i): C C len (e): the length of element e C iw (pe (e) ... pe (e) + len (e) - 1): C the list of supervariables in element e. C C An element represents the fill-in that occurs when supervariable C i is selected as pivot (which represents the selection of row i C and all non-principal variables whose principal variable is i). C We use the term Le to denote the set of all supervariables C in element e. Absorbed supervariables and elements are pruned C from these lists when computationally convenient. C C CAUTION: THE INPUT MATRIX IS OVERWRITTEN DURING COMPUTATION. C The contents of iw are undefined on output. C C----------------------------------------------------------------------- C OUTPUT (need not be set on input): C----------------------------------------------------------------------- C elen: See the description of iw above. At the start of execution, C elen (i) is set to zero. During execution, elen (i) is the C number of elements in the list for supervariable i. When e C becomes an element, elen (e) = -nel is set, where nel is the C current step of factorization. elen (i) = 0 is done when i C becomes nonprincipal. C C For variables, elen (i) .ge. 0 holds C until just before the permutation vectors are computed. C For elements, elen (e) .lt. 0 holds. C C On output elen (1..n) holds the inverse permutation (the same C as the 'INVP' argument in Sparspak). That is, if k = elen (i), C then row i is the kth pivot row. Row i of A appears as the C (elen(i))-th row in the permuted matrix, PAP^T. C last: In a degree list, last (i) is the supervariable preceding i, C or zero if i is the head of the list. In a hash bucket, C last (i) is the hash key for i. last (head (hash)) is also C used as the head of a hash bucket if head (hash) contains a C degree list (see head, below). C C On output, last (1..n) holds the permutation (the same as the C 'PERM' argument in Sparspak). That is, if i = last (k), then C row i is the kth pivot row. Row last (k) of A is the k-th row C in the permuted matrix, PAP^T. C ncmpa: The number of times iw was compressed. If this is C excessive, then the execution took longer than what could have C been. To reduce ncmpa, try increasing iwlen to be 10% or 20% C larger than the value of pfree on input (or at least C iwlen .ge. pfree + n). The fastest performance will be C obtained when ncmpa is returned as zero. If iwlen is set to C the value returned by pfree on *output*, then no compressions C will occur. C begin HALO C on output ncmpa <0 --> error detected during HALO_AMD: C error 1: ncmpa = -N , ordering was stopped. C end HALO C C----------------------------------------------------------------------- C LOCAL (not input or output - used only during execution): C----------------------------------------------------------------------- C degree: If i is a supervariable, then degree (i) holds the C current approximation of the external degree of row i (an upper C bound). The external degree is the number of nonzeros in row i, C minus abs (nv (i)) (the diagonal part). The bound is equal to C the external degree if elen (i) is less than or equal to two. C We also use the term "external degree" for elements e to refer C to |Le \ Lme|. If e is an element, then degree (e) holds |Le|, C which is the degree of the off-diagonal part of the element e C (not including the diagonal part). C begin HALO C while processing variables degree(I) = -NBBUCK-1 (=N2) C indicates that i belongs to V1 C end HALO C C head: head is used for degree lists. head (deg) is the first C supervariable in a degree list (all supervariables i in a C degree list deg have the same approximate degree, namely, C deg = degree (i)). If the list deg is empty then C head (deg) = 0. C C During supervariable detection head (hash) also serves as a C pointer to a hash bucket. C If head (hash) .gt. 0, there is a degree list of degree hash. C The hash bucket head pointer is last (head (hash)). C If head (hash) = 0, then the degree list and hash bucket are C both empty. C If head (hash) .lt. 0, then the degree list is empty, and C -head (hash) is the head of the hash bucket. C After supervariable detection is complete, all hash buckets C are empty, and the (last (head (hash)) = 0) condition is C restored for the non-empty degree lists. C next: next (i) is the supervariable following i in a link list, or C zero if i is the last in the list. Used for two kinds of C lists: degree lists and hash buckets (a supervariable can be C in only one kind of list at a time). C w: The flag array w determines the status of elements and C variables, and the external degree of elements. C C for elements: C if w (e) = 0, then the element e is absorbed C if w (e) .ge. wflg, then w (e) - wflg is the size of C the set |Le \ Lme|, in terms of nonzeros (the C sum of abs (nv (i)) for each principal variable i that C is both in the pattern of element e and NOT in the C pattern of the current pivot element, me). C if wflg .gt. w (e) .gt. 0, then e is not absorbed and has C not yet been seen in the scan of the element lists in C the computation of |Le\Lme| in loop 150 below. C C for variables: C during supervariable detection, if w (j) .ne. wflg then j is C not in the pattern of variable i C C The w array is initialized by setting w (i) = 1 for all i, C and by setting wflg = 2. It is reinitialized if wflg becomes C too large (to ensure that wflg+n does not cause integer C overflow). C C wf : integer array used to store the already filled area of C the variables adajcent to current pivot. C wf is then used to update the score of variable i. C C----------------------------------------------------------------------- C LOCAL INTEGERS: C----------------------------------------------------------------------- INTEGER :: DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, ME, MINDEG, NEL, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, & NBFLAG, LASTD, NELME, WF3, WF4, N2, PAS INTEGER :: NLEFT_V1 INTEGER KNT1_UPDATED, KNT2_UPDATED INTEGER(8) :: MAXMEM, MEM, NEWMEM INTEGER :: MAXINT_N INTEGER(8) :: HASH, HMOD DOUBLE PRECISION RMF, RMF1 DOUBLE PRECISION dummy INTEGER idummy C deg: the degree of a variable or element C degme: size, |Lme|, of the current element, me (= degree (me)) C dext: external degree, |Le \ Lme|, of some element e C dmax: largest |Le| seen so far C e: an element C elenme: the length, elen (me), of element list of pivotal var. C eln: the length, elen (...), of an element list C hash: the computed value of the hash function C hmod: the hash function is computed modulo hmod = max (1,n-1) C i: a supervariable C ilast: the entry in a link list preceding i C inext: the entry in a link list following i C j: a supervariable C jlast: the entry in a link list preceding j C jnext: the entry in a link list, or path, following j C k: the pivot order of an element or variable C knt1: loop counter used during element construction C knt2: loop counter used during element construction C knt3: loop counter used during compression C lenj: len (j) C ln: length of a supervariable list C maxint_n: large integer to test risk of overflow on wflg C maxmem: amount of memory needed for no compressions C me: current supervariable being eliminated, and the C current element created by eliminating that C supervariable C mem: memory in use assuming no compressions have occurred C mindeg: current minimum degree C nel: number of pivots selected so far C newmem: amount of new memory needed for current pivot element C nleft: n - nel, the number of nonpivotal rows/columns remaining C nvi: the number of variables in a supervariable i (= nv (i)) C nvj: the number of variables in a supervariable j (= nv (j)) C nvpiv: number of pivots in current element C slenme: number of variables in variable list of pivotal variable C we: w (e) C wflg: used for flagging the w array. See description of iw. C wnvi: wflg - nv (i) C x: either a supervariable or an element C wf3: off diagoanl block area C wf4: diagonal block area C mf : Minimum fill C begin HALO C nbflag: number of flagged entries in the initial gragh. C nreal : number of entries on which ordering must be perfomed C (nreel = N- nbflag) C nelme number of pivots selected when reaching the root C lastd index of the last row in the list of dense rows C end HALO C----------------------------------------------------------------------- C LOCAL POINTERS: C----------------------------------------------------------------------- INTEGER(8) :: P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, & PN, PSRC C Any parameter (pe (...) or pfree) or local variable C starting with "p" (for Pointer) is an index into iw, C and all indices into iw use variables starting with C "p." The only exception to this rule is the iwlen C input argument. C p: pointer into lots of things C p1: pe (i) for some variable i (start of element list) C p2: pe (i) + elen (i) - 1 for some var. i (end of el. list) C p3: index of first supervariable in clean list C pdst: destination pointer, for compression C pend: end of memory to compress C pj: pointer into an element or variable C pme: pointer into the current element (pme1...pme2) C pme1: the current element, me, is stored in iw (pme1...pme2) C pme2: the end of the current element C pn: pointer into a "clean" variable, also used to compress C psrc: source pointer, for compression C----------------------------------------------------------------------- C FUNCTIONS CALLED: C----------------------------------------------------------------------- INTRINSIC max, min, mod, huge INTEGER TOTEL LOGICAL COMPRESS C======================================================================= C INITIALIZATIONS C======================================================================= C HEAD (0:NBBUCK+1) C C idummy holds the largest integer - 1 C dummy = dble (idummy) idummy = huge(idummy) - 1 dummy = dble(idummy) C variable with degree equal to N2 are in halo C bucket NBBUCK+1 used for HALO variables N2 = -NBBUCK-1 C Distance betweeen elements of the N, ..., NBBUCK entries of HEAD C PAS = max((N/8), 1) WFLG = 2 MAXINT_N=huge(WFLG)-N NCMPA = 0 NEL = 0 HMOD = int(max (1, NBBUCK-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM MINDEG = 0 NLEFT_V1 = 0 C NBFLAG = 0 LASTD = 0 HEAD(0:NBBUCK+1) = 0 DO 10 I = 1, N LAST(I) = 0 C NV(I) = 1 W(I) = 1 ELEN (I) = 0 10 CONTINUE IF(NV(1) .LT. 0) THEN COMPRESS = .FALSE. ELSE COMPRESS = .TRUE. ENDIF IF(COMPRESS) THEN TOTEL = 0 DO I=1,N IF (LEN(I).LT.0) THEN DEGREE (I) = N2 NBFLAG = NBFLAG +1 NLEFT_V1 = NLEFT_V1 + NV(I) IF (LEN(I).EQ.-NORIG-1) THEN C variable in V1 with empty adj list LEN (I) = 0 C Because of compress, we force skipping this C entry which is anyway empty PE (I) = 0_8 ELSE LEN (I) = - LEN(I) ENDIF C end HALO V3 ELSE TOTEL = TOTEL + NV(I) DEGREE(I) = 0 DO P= PE(I) , PE(I)+int(LEN(I)-1,8) DEGREE(I) = DEGREE(I) + NV(IW(P)) ENDDO C DEGREE (I) = LEN (I) ENDIF ENDDO ELSE DO I=1,N NV(I) = 1 IF (LEN(I).LT.0) THEN DEGREE (I) = N2 NBFLAG = NBFLAG +1 NLEFT_V1 = NLEFT_V1 + NV(I) IF (LEN(I).EQ.-N-1) THEN LEN (I) = 0 C Because of compress, we force skipping this C entry which is anyway empty PE (I) = 0_8 ELSE LEN (I) = - LEN(I) ENDIF C end HALO V3 ELSE DEGREE (I) = LEN (I) ENDIF ENDDO TOTEL = N - NBFLAG ENDIF C C C ---------------------------------------------------------------- C initialize degree lists and eliminate rows with no off-diag. nz. C ---------------------------------------------------------------- DO 20 I = 1, N DEG = DEGREE (I) IF (DEG.EQ.N2) THEN C DEG = N2 (flagged variables are stored C in the degree list of NBBUCK + 1 C (safe: because max C max value of degree is NBBUCK) C DEG = NBBUCK + 1 IF (LASTD.EQ.0) THEN C degree list is empty LASTD = I HEAD(DEG) = I NEXT(I) = 0 LAST(I) = 0 ELSE NEXT(LASTD) = I LAST(I) = LASTD LASTD = I NEXT(I) = 0 ENDIF GOTO 20 ENDIF C C IF (DEG .GT. 0) THEN WF(I) = DEG C version 1 IF (DEG.GT.NORIG) THEN DEG = min(((DEG-NORIG)/PAS) + NORIG, NBBUCK) ENDIF C Note that if deg=0 then C No fill-in will occur, C but one variable is adjacent to I C ---------------------------------------------------------- C place i in the degree list corresponding to its degree C ---------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ELSE C ---------------------------------------------------------- C we have a variable that can be eliminated at once because C there is no off-diagonal non-zero in its row. C ---------------------------------------------------------- NEL = NEL + NV(I) ELEN (I) = -NEL PE (I) = 0_8 W (I) = 0 ENDIF C======================================================================= C 20 CONTINUE C======================================================================= C WHILE (selecting pivots) DO C======================================================================= NLEFT = TOTEL-NEL + NLEFT_V1 C======================================================================= C ===================================================================== 30 IF (NEL .LT. TOTEL) THEN C ===================================================================== C GET PIVOT OF MINIMUM DEGREE C======================================================================= C ------------------------------------------------------------- C find next supervariable for elimination C ------------------------------------------------------------- DO 40 DEG = MINDEG, NBBUCK ME = HEAD (DEG) IF (ME .GT. 0) GO TO 50 40 CONTINUE 50 MINDEG = DEG IF (ME.LE.0) THEN NCMPA = -N CALL MUMPS_ABORT() ENDIF IF (DEG.GT.NORIG) THEN C ------------------------------- C Linear search to find variable C with best score in the list C ------------------------------- C While end of list list not reached C NEXT(J) = 0 J = NEXT(ME) K = WF(ME) 55 CONTINUE IF (J.GT.0) THEN IF (WF(J).LT.K) THEN ME = J K = WF(ME) ENDIF J= NEXT(J) GOTO 55 ENDIF ILAST = LAST(ME) INEXT = NEXT(ME) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C me is at the head of the degree list HEAD (DEG) = INEXT ENDIF C ELSE C ------------------------------------------------------------- C remove chosen variable from link list C ------------------------------------------------------------- INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT ENDIF C ------------------------------------------------------------- C me represents the elimination of pivots nel+1 to nel+nv(me). C place me itself as the first in this set. It will be moved C to the nel+nv(me) position when the permutation vectors are C computed. C ------------------------------------------------------------- ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV C======================================================================= C CONSTRUCT NEW ELEMENT C======================================================================= C ------------------------------------------------------------- C At this point, me is the pivotal supervariable. It will be C converted into the current element. Scan list of the C pivotal supervariable, me, setting tree pointers and C constructing new list of supervariables for the new element, C me. p is a pointer to the current position in the old list. C ------------------------------------------------------------- C flag the variable "me" as being in Lme by negating nv (me) NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN C ---------------------------------------------------------- C construct the new element in place C ---------------------------------------------------------- PME1 = PE (ME) PME2 = PME1 - 1 DO 60 P = PME1, PME1 + LEN (ME) - 1 I = IW (P) NVI = NV (I) IF (NVI .GT. 0) THEN C ---------------------------------------------------- C i is a principal variable not yet placed in Lme. C store i in new list C ---------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I IF (DEGREE(I).NE.N2) THEN C ---------------------------------------------------- C remove variable i from degree list. (only if i \in V0) C ---------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list IF (WF(I).GT.NORIG) THEN DEG = min(((WF(I)-NORIG)/PAS) + NORIG, NBBUCK) ELSE DEG = WF(I) ENDIF HEAD (DEG) = INEXT ENDIF ENDIF ENDIF 60 CONTINUE C this element takes no new memory in iw: NEWMEM = 0 ELSE C ---------------------------------------------------------- C construct the new element in empty space, iw (pfree ...) C ---------------------------------------------------------- P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME KNT1_UPDATED = 0 DO 120 KNT1 = 1, ELENME + 1 KNT1_UPDATED = KNT1_UPDATED +1 IF (KNT1 .GT. ELENME) THEN C search the supervariables in me. E = ME PJ = P LN = SLENME ELSE C search the elements in me. E = IW (P) P = P + 1 PJ = PE (E) LN = LEN (E) ENDIF C ------------------------------------------------------- C search for different supervariables and add them to the C new list, compressing when necessary. this loop is C executed once for each element in the list and once for C all the supervariables in the list. C ------------------------------------------------------- KNT2_UPDATED = 0 DO 110 KNT2 = 1, LN KNT2_UPDATED = KNT2_UPDATED+1 I = IW (PJ) PJ = PJ + 1 NVI = NV (I) IF (NVI .GT. 0) THEN C ------------------------------------------------- C compress iw, if necessary C ------------------------------------------------- IF (PFREE .GT. IWLEN) THEN C prepare for compressing iw by adjusting C pointers and lengths so that the lists being C searched in the inner and outer loops contain C only the remaining entries. PE (ME) = P LEN (ME) = LEN (ME) - KNT1_UPDATED C Reset KNT1_UPDATED in case of recompress C at same iteration of the loop 120 KNT1_UPDATED = 0 C Check if anything left in supervariable ME IF (LEN (ME) .EQ. 0) PE (ME) = 0_8 PE (E) = PJ LEN (E) = LN - KNT2_UPDATED C Reset KNT2_UPDATED in case of recompress C at same iteration of the loop 110 KNT2_UPDATED = 0 C Check if anything left in element E IF (LEN (E) .EQ. 0) PE (E) = 0_8 NCMPA = NCMPA + 1 C store first item in pe C set first entry to -item DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = int(IW (PN),8) IW (PN) = -J ENDIF 70 CONTINUE C psrc/pdst point to source/destination PDST = 1 PSRC = 1 PEND = PME1 - 1 C while loop: 80 CONTINUE IF (PSRC .LE. PEND) THEN C search for next negative entry J = -IW (PSRC) PSRC = PSRC + 1 IF (J .GT. 0) THEN IW (PDST) = int(PE (J)) PE (J) = PDST PDST = PDST + 1_8 C copy from source to destination LENJ = LEN (J) DO 90 KNT3 = 0, LENJ - 2 IW (PDST + KNT3) = IW (PSRC + KNT3) 90 CONTINUE PDST = PDST + LENJ - 1 PSRC = PSRC + LENJ - 1 ENDIF GO TO 80 ENDIF C move the new partially-constructed element P1 = PDST DO 100 PSRC = PME1, PFREE - 1 IW (PDST) = IW (PSRC) PDST = PDST + 1 100 CONTINUE PME1 = P1 PFREE = PDST PJ = PE (E) P = PE (ME) ENDIF C ------------------------------------------------- C i is a principal variable not yet placed in Lme C store i in new list C ------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI IW (PFREE) = I PFREE = PFREE + 1 IF (DEGREE(I).NE.N2) THEN C ------------------------------------------------- C remove variable i from degree link list C (only if i in V0) C ------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE IF (WF(I).GT.NORIG) THEN DEG = min(((WF(I)-NORIG)/PAS) + NORIG , NBBUCK) ELSE DEG = WF(I) ENDIF C i is at the head of the degree list HEAD (DEG) = INEXT ENDIF ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN C set tree pointer and flag to indicate element e is C absorbed into new element me (the parent of e is me) PE (E) = int(-ME,8) W (E) = 0 ENDIF 120 CONTINUE PME2 = PFREE - 1 C this element takes newmem new memory in iw (possibly zero) NEWMEM = PFREE - PME1 MEM = MEM + NEWMEM MAXMEM = max (MAXMEM, MEM) ENDIF C ------------------------------------------------------------- C me has now been converted into an element in iw (pme1..pme2) C ------------------------------------------------------------- C degme holds the external degree of new element DEGREE (ME) = DEGME PE (ME) = PME1 LEN (ME) = int(PME2 - PME1 + 1_8) C ------------------------------------------------------------- C make sure that wflg is not too large. With the current C value of wflg, wflg+n must not cause integer overflow C ------------------------------------------------------------- IF (WFLG .GT. MAXINT_N) THEN DO 130 X = 1, N IF (W (X) .NE. 0) W (X) = 1 130 CONTINUE WFLG = 2 ENDIF C======================================================================= C COMPUTE (w (e) - wflg) = |Le\Lme| FOR ALL ELEMENTS C======================================================================= C ------------------------------------------------------------- C Scan 1: compute the external degrees of previous elements C with respect to the current element. That is: C (w (e) - wflg) = |Le \ Lme| C for each element e that appears in any supervariable in Lme. C The notation Le refers to the pattern (list of C supervariables) of a previous element e, where e is not yet C absorbed, stored in iw (pe (e) + 1 ... pe (e) + iw (pe (e))). C The notation Lme refers to the pattern of the current element C (stored in iw (pme1..pme2)). If (w (e) - wflg) becomes C zero, then the element e will be absorbed in scan 2. C ------------------------------------------------------------- DO 150 PME = PME1, PME2 I = IW (PME) ELN = ELEN (I) IF (ELN .GT. 0) THEN C note that nv (i) has been negated to denote i in Lme: NVI = -NV (I) WNVI = WFLG - NVI DO 140 P = PE (I), PE (I) + int(ELN - 1,8) E = IW (P) WE = W (E) IF (WE .GE. WFLG) THEN C unabsorbed element e has been seen in this loop WE = WE - NVI ELSE IF (WE .NE. 0) THEN C e is an unabsorbed element C this is the first we have seen e in all of Scan 1 WE = DEGREE (E) + WNVI WF(E) = 0 ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE C======================================================================= C DEGREE UPDATE AND ELEMENT ABSORPTION C======================================================================= C ------------------------------------------------------------- C Scan 2: for each i in Lme, sum up the degree of Lme (which C is degme), plus the sum of the external degrees of each Le C for the elements e appearing within i, plus the C supervariables in i. Place i in hash list. C ------------------------------------------------------------- DO 180 PME = PME1, PME2 I = IW (PME) P1 = PE (I) P2 = P1 + ELEN (I) - 1 PN = P1 HASH = 0_8 DEG = 0 WF3 = 0 WF4 = 0 NVI = -NV(I) C ---------------------------------------------------------- C scan the element list associated with supervariable i C ---------------------------------------------------------- DO 160 P = P1, P2 E = IW (P) C dext = | Le \ Lme | DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN IF ( WF(E) .EQ. 0 ) THEN C First time we meet e : compute wf(e) C which holds the surface associated to element e C it will later be deducted from fill-in C area of all variables adjacent to e WF(E) = DEXT * ( (2 * DEGREE(E)) - DEXT - 1) ENDIF WF4 = WF4 + WF(E) DEG = DEG + DEXT IW (PN) = E PN = PN + 1 HASH = HASH + int(E, kind=8) ELSE IF (DEXT .EQ. 0) THEN #if defined (NOAGG4) IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) #else C aggressive absorption: e is not adjacent to me, but C the |Le \ Lme| is 0, so absorb it into me PE (E) = int(-ME,8) W (E) = 0 #endif ENDIF 160 CONTINUE C count the number of elements in i (including me): ELEN (I) = int(PN - P1 + 1_8) C ---------------------------------------------------------- C scan the supervariables in the list associated with i C ---------------------------------------------------------- P3 = PN DO 170 P = P2 + 1_8, P1 + int(LEN (I) - 1,8) J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN C j is unabsorbed, and not in Lme. C add to degree and add to new list DEG = DEG + NVJ WF3 = WF3 + NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE C IF (DEGREE(I).EQ.N2) DEG = N2 C ---------------------------------------------------------- C update the degree and check for mass elimination C ---------------------------------------------------------- #if defined (NOAGG4) IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN #else IF (DEG .EQ. 0) THEN #endif C ------------------------------------------------------- C mass elimination C ------------------------------------------------------- C There is nothing left of this node except for an C edge to the current pivot element. elen (i) is 1, C and there are no variables adjacent to node i. C Absorb i into the current pivot element, me. PE (I) = int(-ME,8) NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE C ------------------------------------------------------- C update the upper-bound degree of i C ------------------------------------------------------- C the following degree does not yet include the size C of the current element, which is added later: IF (DEGREE(I).NE.N2) THEN C I does not belong to halo IF ( DEGREE (I).LT.DEG ) THEN C Our appox degree is loose. C we keep old value. Note that in C this case we cannot substract WF(I) C for min-fill score. WF4 = 0 WF3 = 0 ELSE DEGREE(I) = DEG ENDIF ENDIF C C compute WF(I) taking into account size of block 3.0 WF(I) = WF4 + 2*NVI*WF3 C ------------------------------------------------------- C add me to the list for i C ------------------------------------------------------- C move first supervariable to end of list IW (PN) = IW (P3) C move first element to end of element part of list IW (P3) = IW (P1) C add new element to front of list. IW (P1) = ME C store the new length of the list in len (i) LEN (I) = int(PN - P1 + 1) IF (DEG.NE.N2) THEN C ------------------------------------------------------- C place in hash bucket. Save hash key of i in last (i). C ------------------------------------------------------- HASH = mod (HASH, HMOD) + 1_8 J = HEAD (HASH) IF (J .LE. 0) THEN C the degree list is empty, hash head is -j NEXT (I) = -J HEAD (HASH) = -I ELSE C degree list is not empty C use last (head (hash)) as hash head NEXT (I) = LAST (J) LAST (J) = I ENDIF LAST (I) = int(HASH,kind=kind(LAST)) ENDIF ENDIF 180 CONTINUE DEGREE (ME) = DEGME C ------------------------------------------------------------- C Clear the counter array, w (...), by incrementing wflg. C ------------------------------------------------------------- DMAX = max (DMAX, DEGME) WFLG = WFLG + DMAX C make sure that wflg+n does not cause integer overflow IF (WFLG .GT. MAXINT_N) THEN DO 190 X = 1, N IF (W (X) .NE. 0) W (X) = 1 190 CONTINUE WFLG = 2 ENDIF C at this point, w (1..n) .lt. wflg holds C======================================================================= C SUPERVARIABLE DETECTION C======================================================================= DO 250 PME = PME1, PME2 I = IW (PME) IF ( (NV (I) .LT. 0) .AND. (DEGREE(I).NE.N2) ) THEN C i is a principal variable in Lme C ------------------------------------------------------- C examine all hash buckets with 2 or more variables. We C do this by examing all unique hash keys for super- C variables in the pattern Lme of the current element, me C ------------------------------------------------------- HASH = int(LAST (I),kind=8) C let i = head of hash bucket, and empty the hash bucket J = HEAD (HASH) IF (J .EQ. 0) GO TO 250 IF (J .LT. 0) THEN C degree list is empty I = -J HEAD (HASH) = 0 ELSE C degree list is not empty, restore last () of head I = LAST (J) LAST (J) = 0 ENDIF IF (I .EQ. 0) GO TO 250 C while loop: 200 CONTINUE IF (NEXT (I) .NE. 0) THEN C ---------------------------------------------------- C this bucket has one or more variables following i. C scan all of them to see if i can absorb any entries C that follow i in hash bucket. Scatter i into w. C ---------------------------------------------------- LN = LEN (I) ELN = ELEN (I) C do not flag the first element in the list (me) DO 210 P = PE (I) + 1_8, PE (I) + int(LN - 1,8) W (IW (P)) = WFLG 210 CONTINUE C ---------------------------------------------------- C scan every other entry j following i in bucket C ---------------------------------------------------- JLAST = I J = NEXT (I) C while loop: 220 CONTINUE IF (J .NE. 0) THEN C ------------------------------------------------- C check if j and i have identical nonzero pattern C ------------------------------------------------- C jump if i and j do not have same size data structure IF (LEN (J) .NE. LN) GO TO 240 C jump if i and j do not have same number adj elts IF (ELEN (J) .NE. ELN) GO TO 240 C do not flag the first element in the list (me) DO 230 P = PE (J) + 1_8, PE (J) + int(LN - 1,8) C jump if an entry (iw(p)) is in j but not in i IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE C ------------------------------------------------- C found it! j can be absorbed into i C ------------------------------------------------- PE (J) = int(-I,8) WF(I) = max(WF(I),WF(J)) C both nv (i) and nv (j) are negated since they C are in Lme, and the absolute values of each C are the number of variables in i and j: NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 C delete j from hash bucket J = NEXT (J) NEXT (JLAST) = J GO TO 220 C ------------------------------------------------- 240 CONTINUE C j cannot be absorbed into i C ------------------------------------------------- JLAST = J J = NEXT (J) GO TO 220 ENDIF C ---------------------------------------------------- C no more variables can be absorbed into i C go to next i in bucket and clear flag array C ---------------------------------------------------- WFLG = WFLG + 1 I = NEXT (I) IF (I .NE. 0) GO TO 200 ENDIF ENDIF 250 CONTINUE C======================================================================= C RESTORE DEGREE LISTS AND REMOVE NONPRINCIPAL SUPERVAR. FROM ELEMENT C======================================================================= P = PME1 NLEFT = TOTEL - NEL + NLEFT_V1 DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN C i is a principal variable in Lme C restore nv (i) to signify that i is principal NV (I) = NVI IF (DEGREE(I).NE.N2) THEN C ------------------------------------------------------- C compute the external degree (add size of current elem) C ------------------------------------------------------- C-------------------------- C-------------------------- IF (DEGREE (I) + DEGME .GT. NLEFT ) THEN C DEG = DEGREE(I) RMF1 = dble(DEG)*dble( (DEG-1) + 2*DEGME ) & - dble(WF(I)) DEGREE(I) = NLEFT - NVI DEG = DEGREE(I) RMF = dble(DEG)*dble(DEG-1) & - dble(DEGME-NVI)*dble(DEGME-NVI-1) RMF = min(RMF, RMF1) ELSE DEG = DEGREE(I) DEGREE(I) = DEGREE (I) + DEGME - NVI C All previous cliques taken into account (AMF4) RMF = dble(DEG)*dble( (DEG-1) + 2*DEGME ) & - dble(WF(I)) ENDIF C RMF = RMF / dble(NVI+1) C IF (RMF.LT.dummy) THEN WF(I) = int ( anint( RMF )) ELSEIF (RMF / dble(N) .LT. dummy) THEN WF(I) = int ( anint( RMF/dble(N) )) ELSE WF(I) = idummy ENDIF WF(I) = max(1,WF(I)) DEG = WF(I) IF (DEG.GT.NORIG) THEN DEG = min(((DEG-NORIG)/PAS) + NORIG, NBBUCK) ENDIF INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I C ------------------------------------------------------- C save the new degree, and find the minimum degree C ------------------------------------------------------- MINDEG = min (MINDEG, DEG) C begin HALO ENDIF C end HALO C ------------------------------------------------------- C place the supervariable in the element pattern C ------------------------------------------------------- IW (P) = I P = P + 1 ENDIF 260 CONTINUE C======================================================================= C FINALIZE THE NEW ELEMENT C======================================================================= NV (ME) = NVPIV + DEGME C fill_est = fill_est + nvpiv * (nvpiv + 2 * degme) C nv (me) is now the degree of pivot (including diagonal part) C save the length of the list for the new element me LEN (ME) = int(P - PME1) IF (LEN (ME) .EQ. 0) THEN C there is nothing left of the current pivot element PE (ME) = 0_8 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN C element was not constructed in place: deallocate part C of it (final size is less than or equal to newmem, C since newly nonprincipal variables have been removed). PFREE = P MEM = MEM - NEWMEM + int(LEN (ME),8) ENDIF C======================================================================= C END WHILE (selecting pivots) GO TO 30 ENDIF C======================================================================= C begin HALO V2 IF (NEL.LT.NORIG) THEN C C All possible pivots (not flagged have been eliminated). C We amalgamate all flagged variables at the root and C we finish the elimination tree. C 1/ Go through all C non absorbed elements (root of the subgraph) C and absorb in ME C 2/ perform mass elimination of all dense rows DO DEG = MINDEG, NBBUCK+1 ME = HEAD (DEG) IF (ME .GT. 0) GO TO 51 ENDDO 51 MINDEG = DEG NELME = -(NEL+1) DO X=1,N IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN C X is an unabsorbed element PE(X) = int(-ME,8) C W(X) = 0 could be suppressed ?? check it ELSEIF (DEGREE(X).EQ.N2) THEN C X is a dense row, absorb it in ME (mass elimination) NEL = NEL + NV(X) PE(X) = int(-ME,8) ELEN(X) = 0 C Correct value of NV is (secondary variable) NV(X) = 0 ENDIF ENDDO C ME is the root node ELEN(ME) = NELME C Correct value of NV is (principal variable) NV(ME) = NBFLAG PE(ME) = 0_8 IF (NEL.NE.NORIG) THEN NCMPA = -NORIG - 1 GOTO 500 ENDIF ENDIF C end HALO C======================================================================= C COMPUTE THE PERMUTATION VECTORS and update TREE C======================================================================= C ---------------------------------------------------------------- C The time taken by the following code is O(n). At this C point, elen (e) = -k has been done for all elements e, C and elen (i) = 0 has been done for all nonprincipal C variables i. At this point, there are no principal C supervariables left, and all elements are absorbed. C ---------------------------------------------------------------- C ---------------------------------------------------------------- C compute the ordering of unordered nonprincipal variables C ---------------------------------------------------------------- DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN C ---------------------------------------------------------- C i is an un-ordered row. Traverse the tree from i until C reaching an element, e. The element, e, was the C principal supervariable of i and all nodes in the path C from i to when e was selected as pivot. C ---------------------------------------------------------- J = int(-PE (I)) C while (j is a variable) do: 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = int(-PE (J)) GO TO 270 ENDIF E = J C ---------------------------------------------------------- C get the current pivot ordering of e C ---------------------------------------------------------- K = -ELEN (E) C ---------------------------------------------------------- C traverse the path again from i to e, and compress the C path (all nodes point to e). Path compression allows C this code to compute in O(n) time. Order the unordered C nodes in the path, and place the element e at the end. C ---------------------------------------------------------- J = I C while (j is a variable) do: 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = int(-PE (J)) PE (J) = int(-E,8) IF (ELEN (J) .EQ. 0) THEN C j is an unordered row ELEN (J) = K K = K + 1 ENDIF J = JNEXT GO TO 280 ENDIF C leave elen (e) negative, so we know it is an element ELEN (E) = -K ENDIF 290 CONTINUE IF (COMPUTE_PERM) THEN C ---------------------------------------------------------------- C reset the inverse permutation (elen (1..n)) to be positive, C and compute the pivot order (last (1..n)). C ---------------------------------------------------------------- C begin COMPRESS IF(COMPRESS) THEN C N is the size of the compressed graph. C If the graph was compressed on input then C indices in ELEN are in [1,TOTEL] C We build the inverse of ELEN in LAST (similar to C the pivot order but has zeros in it) and then compress C it. Since LAST is assumed to be of size N at the C interface level, we need another array to store C the inverse of ELEN for entries greater than N C We use DEGREE. LAST(1:N) = 0 HEAD(1:TOTEL-N)=0 DO I = 1, N K = abs (ELEN (I)) IF ( K <= N ) THEN LAST (K) = I ELSE HEAD(K-N)=I ENDIF ENDDO I = 1 DO K = 1, N IF(LAST (K) .NE. 0) THEN LAST(I) = LAST(K) ELEN(LAST(K)) = I I = I + 1 ENDIF ENDDO DO K = N+1, TOTEL IF (HEAD(K-N) .NE. 0) THEN LAST(I)=HEAD(K-N) ELEN(HEAD(K-N)) = I I = I + 1 ENDIF END DO ELSE DO 300 I = 1, N K = abs (ELEN (I)) LAST (K) = I ELEN (I) = K 300 CONTINUE ENDIF C end COMPRESS ENDIF C======================================================================= C RETURN THE MEMORY USAGE IN IW C======================================================================= C If maxmem is less than or equal to iwlen, then no compressions C occurred, and iw (maxmem+1 ... iwlen) was unused. Otherwise C compressions did occur, and iwlen would have had to have been C greater than or equal to maxmem for no compressions to occur. C Return the value of maxmem in the pfree argument. 500 PFREE = MAXMEM C=============================== C Save IPE in PARENT array DO I=1,N PARENT(I) = int(PE(I)) ENDDO C=============================== RETURN END SUBROUTINE MUMPS_HAMF4 C C----------------------------------------------------------------------- C MUMPS_QAMD: modified version of reference AMD routine MUMPS_ANA_H C designed to automatically detect and exploit dense or quasi dense C rows in the reduced matrix at any step of the minimum degree. C C References: C P.R. AMESTOY, Recent progress in parallel multifrontal solvers C for unsymmetric sparse matrices, C Proceedings of the 15th World Congress on Scientific Computation, C Modelling and Applied Mathematics, IMACS, Berlin (1997). C P.R. AMESTOY (1999), Methodes directes paralleles de C resolution des systemes creux de grande taille. C Rapport de these d'habilitation de l'INPT. C C Date 1997 C --------- C SUBROUTINE MUMPS_QAMD & (TOTEL, COMPUTE_PERM, IVersion, THRESH, NDENSE, & N, IWLEN, PE, PFREE, LEN, IW, NV, & ELEN, LAST, NCMPA, DEGREE, HEAD, NEXT, W, & PARENT) C Input not modified INTEGER, INTENT(IN) :: TOTEL, N LOGICAL, INTENT(IN) :: COMPUTE_PERM INTEGER, INTENT(IN) :: IVersion, THRESH INTEGER(8), INTENT(IN) :: IWLEN INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: ELEN(N), PARENT(N) INTEGER, INTENT(OUT) :: LAST(N) INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(N) C NV also meaningful as input to encode compressed graphs INTEGER, INTENT(INOUT) :: NV(N) INTEGER, INTENT(OUT) :: NEXT(N), DEGREE(N), HEAD(TOTEL), W(N) INTEGER, INTENT(OUT) :: NDENSE(N) C The input integer parameter THRESH defines the quasi density: C THRESH : input parameter (not modified) C THRESH is used to compute THRESM C <=0 or N Only exactly dense rows in the reduced matrix are selected. C >1 and <=N THRESH correspond to the munimum density requirement. C C IVersion = C 1 : No dense row detection during elimination C Suppressing dense row selection after 1st C and final restrart (Using initial degree of C quasi dense C rows when restarting and suppress C dense row selection) C else : All functionalities enabled C Additionnal parameters/variables due to dense row manipulation: C PARAMETERS: C ---------- C C Local variables: C --------------- INTEGER THRESM, MINDEN, MAXDEN, NDME INTEGER NBD,NBED, NBDM, LASTD, NELME C INTEGER DEG1 LOGICAL IDENSE DOUBLE PRECISION RELDEN C C THRESM : Local Integer holding a C potentially modified value of THRESH. C When quasi dense rows are reintegrated in the C graph to be processed then THRESM is modified. C Note that if one sets THRESM to negative value then C <0 Classical AMD algorithm (no dense row detection) C RELDEN : holds average density to set THRESM automatically C MINDEN: min degree of quasi-dense rows when restarting C MAXDEN: max degree of quasi-dense rows when restarting C NDME : number of dense row adjacent to me C NELME number of pivots selected when reching the root C LASTD index of the last row in the list of dense rows C NBD is the total number of dense rows selected C NBED is the total number of exactly dense rows detected. C NBDM is the maximum number of dense rows selected C IDENSE is used to indicate that the supervariable I is a dense or C quasi-dense row. C----------------------------------------------------------------------- C Given a representation of the nonzero pattern of a symmetric matrix, C A, (excluding the diagonal) perform an approximate minimum C degree ordering to compute a pivot order C such that fill-in in the Cholesky factors A = LL^T is kept low. C Aggressive absorption might be used to C tighten the bound on the degree. This can result a C significant improvement in the quality of the ordering for C some matrices. C----------------------------------------------------------------------- C INPUT ARGUMENTS (unaltered): C----------------------------------------------------------------------- C n : The matrix order. C number of supervariables if compress/blocked format C Restriction: n .ge. 1 C totel : Number of variables to eliminate C In case of blocked format: C each variable i is a supervariable of size nv(i) C totel is computed as the sum(nv(i)) for i \in [1:n] C the algorithm stops when totel variables are C eliminated. C compute_perm : indicates if permutations should be computed C on output in last/elen C iwlen: The length of iw (1..iwlen). On input, the matrix is C stored in iw (1..pfree-1). However, iw (1..iwlen) should be C slightly larger than what is required to hold the matrix, at C least iwlen .ge. pfree + n is recommended. Otherwise, C excessive compressions will take place. C *** We do not recommend running this algorithm with *** C *** iwlen .lt. pfree + n. *** C *** Better performance will be obtained if *** C *** iwlen .ge. pfree + n *** C *** or better yet *** C *** iwlen .gt. 1.2 * pfree *** C *** (where pfree is its value on input). *** C The algorithm will not run at all if iwlen .lt. pfree-1. C C Restriction: iwlen .ge. pfree-1 C----------------------------------------------------------------------- C INPUT/OUPUT ARGUMENTS: C----------------------------------------------------------------------- C pe: On input, pe (i) is the index in iw of the start of row i, or C zero if row i has no off-diagonal non-zeros. C C During execution, it is used for both supervariables and C elements: C C * Principal supervariable i: index into iw of the C description of supervariable i. A supervariable C represents one or more rows of the matrix C with identical nonzero pattern. C * Non-principal supervariable i: if i has been absorbed C into another supervariable j, then pe (i) = -j. C That is, j has the same pattern as i. C Note that j might later be absorbed into another C supervariable j2, in which case pe (i) is still -j, C and pe (j) = -j2. C * Unabsorbed element e: the index into iw of the description C of element e, if e has not yet been absorbed by a C subsequent element. Element e is created when C the supervariable of the same name is selected as C the pivot. C * Absorbed element e: if element e is absorbed into element C e2, then pe (e) = -e2. This occurs when the pattern of C e (that is, Le) is found to be a subset of the pattern C of e2 (that is, Le2). If element e is "null" (it has C no nonzeros outside its pivot block), then pe (e) = 0. C C On output, pe holds the assembly tree/forest, which implicitly C represents a pivot order with identical fill-in as the actual C order (via a depth-first search of the tree). C C On output: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C C On output: (PE is copied on output into PARENT array) C C pfree: On input, the matrix is stored in iw (1..pfree-1) and C the rest of the array iw is free. C During execution, additional data is placed in iw, and pfree C is modified so that components of iw from pfree are free. C On output, pfree is set equal to the size of iw that C would have been needed for no compressions to occur. If C ncmpa is zero, then pfree (on output) is less than or equal to C iwlen, and the space iw (pfree+1 ... iwlen) was not used. C Otherwise, pfree (on output) is greater than iwlen, and all the C memory in iw was used. C C nv: On input, encoding of compressed graph: C if nv(1) = -1 then graph is not compressed otherwise C nv(I) holds the weight of node I. C During execution, abs (nv (i)) is equal to the number of rows C that are represented by the principal supervariable i. If i is C a nonprincipal variable, then nv (i) = 0. C nv (i) .lt. 0 signifies that i is a C principal variable in the pattern Lme of the current pivot C element me. C On output, nv (e) holds the true degree of element C e at the time it was created (including the diagonal part). C begin HALO C On output, nv(I) can be used to find node in set V1. C Not true anymore : ( nv(I) = N+1 characterizes nodes in V1. C instead nodes in V1 are considered as a dense root node ) C end HALO C----------------------------------------------------------------------- C INPUT/MODIFIED (undefined on output): C----------------------------------------------------------------------- C len: On input, len (i) holds the number of entries in row i of the C matrix, excluding the diagonal. The contents of len (1..n) C are undefined on output. C iw: On input, iw (1..pfree-1) holds the description of each row i C in the matrix. The matrix must be symmetric, and both upper C and lower triangular parts must be present. The diagonal must C not be present. Row i is held as follows: C C len (i): the length of the row i data structure C iw (pe (i) ... pe (i) + len (i) - 1): C the list of column indices for nonzeros C in row i (simple supervariables), excluding C the diagonal. All supervariables start with C one row/column each (supervariable i is just C row i). C if len (i) is zero on input, then pe (i) is ignored C on input. C C Note that the rows need not be in any particular order, C and there may be empty space between the rows. C C During execution, the supervariable i experiences fill-in. C This is represented by placing in i a list of the elements C that cause fill-in in supervariable i: C C len (i): the length of supervariable i C iw (pe (i) ... pe (i) + elen (i) - 1): C the list of elements that contain i. This list C is kept short by removing absorbed elements. C iw (pe (i) + elen (i) ... pe (i) + len (i) - 1): C the list of supervariables in i. This list C is kept short by removing nonprincipal C variables, and any entry j that is also C contained in at least one of the elements C (j in Le) in the list for i (e in row i). C C When supervariable i is selected as pivot, we create an C element e of the same name (e=i): C C len (e): the length of element e C iw (pe (e) ... pe (e) + len (e) - 1): C the list of supervariables in element e. C C An element represents the fill-in that occurs when supervariable C i is selected as pivot (which represents the selection of row i C and all non-principal variables whose principal variable is i). C We use the term Le to denote the set of all supervariables C in element e. Absorbed supervariables and elements are pruned C from these lists when computationally convenient. C C CAUTION: THE INPUT MATRIX IS OVERWRITTEN DURING COMPUTATION. C The contents of iw are undefined on output. C----------------------------------------------------------------------- C OUTPUT (need not be set on input): C----------------------------------------------------------------------- C elen: See the description of iw above. At the start of execution, C elen (i) is set to zero. During execution, elen (i) is the C number of elements in the list for supervariable i. When e C becomes an element, elen (e) = -nel is set, where nel is the C current step of factorization. elen (i) = 0 is done when i C becomes nonprincipal. C C For variables, elen (i) .ge. 0 holds until just before the C permutation vectors are computed. For elements, C elen (e) .lt. 0 holds. C C On output elen (1..n) holds the inverse permutation (the same C as the 'INVP' argument in Sparspak). That is, if k = elen (i), C then row i is the kth pivot row. Row i of A appears as the C (elen(i))-th row in the permuted matrix, PAP^T. C last: In a degree list, last (i) is the supervariable preceding i, C or zero if i is the head of the list. In a hash bucket, C last (i) is the hash key for i. last (head (hash)) is also C used as the head of a hash bucket if head (hash) contains a C degree list (see head, below). C C On output, last (1..n) holds the permutation (the same as the C 'PERM' argument in Sparspak). That is, if i = last (k), then C row i is the kth pivot row. Row last (k) of A is the k-th row C in the permuted matrix, PAP^T. C ncmpa: The number of times iw was compressed. If this is C excessive, then the execution took longer than what could have C been. To reduce ncmpa, try increasing iwlen to be 10% or 20% C larger than the value of pfree on input (or at least C iwlen .ge. pfree + n). The fastest performance will be C obtained when ncmpa is returned as zero. If iwlen is set to C the value returned by pfree on *output*, then no compressions C will occur. C----------------------------------------------------------------------- C LOCAL (not input or output - used only during execution): C----------------------------------------------------------------------- C degree: If i is a supervariable, then degree (i) holds the C current approximation of the external degree of row i (an upper C bound). The external degree is the number of nonzeros in row i, C minus abs (nv (i)) (the diagonal part). The bound is equal to C the external degree if elen (i) is less than or equal to two. C C We also use the term "external degree" for elements e to refer C to |Le \ Lme|. If e is an element, then degree (e) holds |Le|, C which is the degree of the off-diagonal part of the element e C (not including the diagonal part). Cdense C degree (I) =N+1 if I is an exactly dense row in reduced matrix. C =N+1+LAST_approximate_external_deg of I C if I is a quasi dense row in reduced matrix. C All dense or quasi dense rows are stored in the list pointed C by head(n). Quasi-dense rows (degree(I)=n) are stored first, C and are followed by exactly dense rows in the reduced matrix. C LASTD holds the last row in this list of dense rows or is zero C if the list is empty. Cdense C head: head is used for degree lists. head (deg) is the first C supervariable in a degree list (all supervariables i in a C degree list deg have the same approximate degree, namely, C deg = degree (i)). If the list deg is empty then C head (deg) = 0. C C During supervariable detection head (hash) also serves as a C pointer to a hash bucket. C If head (hash) .gt. 0, there is a degree list of degree hash. C The hash bucket head pointer is last (head (hash)). C If head (hash) = 0, then the degree list and hash bucket are C both empty. C If head (hash) .lt. 0, then the degree list is empty, and C -head (hash) is the head of the hash bucket. C After supervariable detection is complete, all hash buckets C are empty, and the (last (head (hash)) = 0) condition is C restored for the non-empty degree lists. C next: next (i) is the supervariable following i in a link list, or C zero if i is the last in the list. Used for two kinds of C lists: degree lists and hash buckets (a supervariable can be C in only one kind of list at a time). C w: The flag array w determines the status of elements and C variables, and the external degree of elements. C C for elements: C if w (e) = 0, then the element e is absorbed C if w (e) .ge. wflg, then w (e) - wflg is the size of C the set |Le \ Lme|, in terms of nonzeros (the C sum of abs (nv (i)) for each principal variable i that C is both in the pattern of element e and NOT in the C pattern of the current pivot element, me). C if wflg .gt. w (e) .gt. 0, then e is not absorbed and has C not yet been seen in the scan of the element lists in C the computation of |Le\Lme| in loop 150 below. C C for variables: C during supervariable detection, if w (j) .ne. wflg then j is C not in the pattern of variable i C C The w array is initialized by setting w (i) = 1 for all i, C and by setting wflg = 2. It is reinitialized if wflg becomes C too large (to ensure that wflg+n does not cause integer C overflow). C----------------------------------------------------------------------- C LOCAL INTEGERS: C----------------------------------------------------------------------- INTEGER :: DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, ME, MINDEG, NEL, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X INTEGER KNT1_UPDATED, KNT2_UPDATED INTEGER(8) MAXMEM, MEM, NEWMEM INTEGER :: MAXINT_N INTEGER(8):: HASH, HMOD C deg: the degree of a variable or element C degme: size, |Lme|, of the current element, me (= degree (me)) C dext: external degree, |Le \ Lme|, of some element e C dmax: largest |Le| seen so far C e: an element C elenme: the length, elen (me), of element list of pivotal var. C eln: the length, elen (...), of an element list C hash: the computed value of the hash function C hmod: the hash function is computed modulo hmod = max (1,n-1) C i: a supervariable C ilast: the entry in a link list preceding i C inext: the entry in a link list following i C j: a supervariable C jlast: the entry in a link list preceding j C jnext: the entry in a link list, or path, following j C k: the pivot order of an element or variable C knt1: loop counter used during element construction C knt2: loop counter used during element construction C knt3: loop counter used during compression C lenj: len (j) C ln: length of a supervariable list C maxint_n: large integer to test risk of overflow on wflg C maxmem: amount of memory needed for no compressions C me: current supervariable being eliminated, and the C current element created by eliminating that C supervariable C mem: memory in use assuming no compressions have occurred C mindeg: current minimum degree C nel: number of pivots selected so far C newmem: amount of new memory needed for current pivot element C nleft: n - nel, the number of nonpivotal rows/columns remaining C nvi: the number of variables in a supervariable i (= nv (i)) C nvj: the number of variables in a supervariable j (= nv (j)) C nvpiv: number of pivots in current element C slenme: number of variables in variable list of pivotal variable C we: w (e) C wflg: used for flagging the w array. See description of iw. C wnvi: wflg - nv (i) C x: either a supervariable or an element C----------------------------------------------------------------------- C LOCAL POINTERS: C----------------------------------------------------------------------- INTEGER(8) P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, & PN, PSRC, PLN, PELN C Any parameter (pe (...) or pfree) or local variable C starting with "p" (for Pointer) is an index into iw, C and all indices into iw use variables starting with C "p." The only exception to this rule is the iwlen C input argument. C p: pointer into lots of things C p1: pe (i) for some variable i (start of element list) C p2: pe (i) + elen (i) - 1 for some var. i (end of el. list) C p3: index of first supervariable in clean list C pdst: destination pointer, for compression C pend: end of memory to compress C pj: pointer into an element or variable C pme: pointer into the current element (pme1...pme2) C pme1: the current element, me, is stored in iw (pme1...pme2) C pme2: the end of the current element C pn: pointer into a "clean" variable, also used to compress C psrc: source pointer, for compression LOGICAL COMPRESS C----------------------------------------------------------------------- C FUNCTIONS CALLED: C----------------------------------------------------------------------- INTRINSIC max, min, mod C======================================================================= C INITIALIZATIONS C======================================================================= C ------------------------------------------------------ C Experiments with automatic setting of parameter THRESH. C ------------------------------------------------------ IF (THRESH.GT.0) THEN THRESM = min(N,THRESH) DO I=1,N THRESM = max(THRESM, LEN(I)) ENDDO RELDEN = dble(PFREE-1)/dble(N) C RELDEN holds the average density, THRESM the maximum density THRESM = int(RELDEN)*10 + (THRESM-int(RELDEN))/10 + 1 C ------------------------------------------------------ C end automatic setting of THRESM C ------------------------------------------------------ ELSE C only exactly dense row will be selected THRESM = TOTEL ENDIF IF (THRESM.GE.0) THEN IF ((THRESM.GT.TOTEL).OR.(THRESM.LT.2)) THEN C exactly dense rows only THRESM = TOTEL ENDIF ENDIF LASTD = 0 NBD = 0 NBED = 0 NBDM = 0 WFLG = 2 MAXINT_N=huge(WFLG)-N MINDEG = 1 NCMPA = 0 NEL = 0 HMOD = int(max (1, N-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM DO I = 1, N NDENSE(I)= 0 W (I) = 1 ELEN (I) = 0 LAST(I) = 0 ENDDO DO I = 1, TOTEL HEAD(I) = 0 ENDDO IF(NV(1) .LT. 0) THEN COMPRESS = .FALSE. ELSE COMPRESS = .TRUE. ENDIF IF (COMPRESS) THEN DO I=1,N DEGREE(I) = 0 DO P= PE(I) , PE(I)+int(LEN(I)-1,8) DEGREE(I) = DEGREE(I) + NV(IW(P)) ENDDO ENDDO ELSE DO I=1,N NV(I) = 1 DEGREE (I) = LEN (I) ENDDO ENDIF C ---------------------------------------------------------------- C initialize degree lists and eliminate rows with no off-diag. nz. C ---------------------------------------------------------------- C NEXT = 0 DO 20 I = 1, N DEG = DEGREE (I) IF (DEG .GT. 0) THEN C ---------------------------------------------------------- C place i in the degree list corresponding to its degree C or in the dense row list if i is dense or quasi dense. C ---------------------------------------------------------- C test for row density IF ( (THRESM.GE.0) .AND. & (DEG+NV(I).GE.THRESM) ) THEN C I will be inserted in the degree list of N NBD = NBD+NV(I) IF (DEG+NV(I).NE.TOTEL-NEL) THEN DEGREE(I) = DEGREE(I)+TOTEL+1 C insert I at the beginning of degree list of n DEG = TOTEL INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I LAST(I) = 0 IF (LASTD.EQ.0) LASTD=I ELSE NBED = NBED+NV(I) DEGREE(I) = TOTEL+1 C insert I at the end of degree list of n DEG = TOTEL IF (LASTD.EQ.0) THEN C degree list is empty LASTD = I HEAD(DEG) = I NEXT(I) = 0 LAST(I) = 0 ELSE NEXT(LASTD) = I LAST(I) = LASTD LASTD = I NEXT(I) = 0 ENDIF ENDIF ELSE C place i in the degree list corresponding to its degree INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ENDIF ELSE C ---------------------------------------------------------- C we have a variable that can be eliminated at once because C there is no off-diagonal non-zero in its row. C ---------------------------------------------------------- NEL = NEL + NV(I) C NEL = NEL + 1 ELEN (I) = -NEL PE (I) = 0_8 W (I) = 0 ENDIF 20 CONTINUE C We suppress dense row selection if none of them was found in A C in the 1st pass IF (NBD.EQ.0) THRESM = TOTEL C C======================================================================= C WHILE (selecting pivots) DO C======================================================================= 30 IF (NEL .LT. TOTEL) THEN C======================================================================= C GET PIVOT OF MINIMUM DEGREE C======================================================================= C ------------------------------------------------------------- C find next supervariable for elimination C ------------------------------------------------------------- DO 40 DEG = MINDEG, TOTEL ME = HEAD (DEG) IF (ME .GT. 0) GO TO 50 40 CONTINUE 50 MINDEG = DEG IF (DEG.LT.TOTEL) THEN C ------------------------------------------------------------- C remove chosen variable from link list C ------------------------------------------------------------- INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT ELSE NBDM = max(NBDM,NBD) IF (DEGREE(ME).GT.TOTEL+1) THEN MINDEN = NBD MAXDEN = 0 IF (WFLG .GT. MAXINT_N) THEN DO 52 X = 1, N IF (W (X) .NE. 0) W (X) = 1 52 CONTINUE WFLG = 2 ENDIF WFLG = WFLG + 1 51 CONTINUE C --------------------------------------------------------- C remove chosen variable from link list C --------------------------------------------------------- INEXT = NEXT (ME) IF (INEXT .NE. 0) THEN LAST (INEXT) = 0 ELSE LASTD = 0 ENDIF C ---------------------------------------------------------- c build adjacency list of ME in quotient gragh C and calculate its external degree in ndense(me) C ---------------------------------------------------------- NDENSE(ME) = 0 W(ME) = WFLG P1 = PE(ME) P2 = P1 + int(LEN(ME) -1,8) C PLN-1 holds the pointer in IW to the last elet/var in adj list C of ME. LEN(ME) will then be set to PLN-P1 C PELN-1 hold the pointer in IW to the last elet in adj list C of ME. ELEN(ME) will then be set to PELN-P1 C element adjacent to ME PLN = P1 PELN = P1 DO 55 P=P1,P2 E= IW(P) IF (W(E).EQ.WFLG) GOTO 55 W(E) = WFLG IF (PE(E).LT.0_8) THEN C E is a nonprincipal variable or absorbed element X = E 53 X = int(-PE(X)) IF (W(X) .EQ.WFLG) GOTO 55 W(X) = WFLG IF ( PE(X) .LT. 0_8 ) GOTO 53 E = X ENDIF C ------------------------------------------- C E is an unabsorbed element or a "dense" row C (NOT already flagged) C ------------------------------------------- IF (ELEN(E).LT.0) then C E is a new element in adj(ME) NDENSE(E) = NDENSE(E) - NV(ME) IW(PLN) = IW(PELN) IW(PELN) = E PLN = PLN+1_8 PELN = PELN + 1_8 C update ndense of ME with all unflagged dense C rows in E PME1 = PE(E) DO 54 PME = PME1, PME1+int(LEN(E)-1,8) X = IW(PME) IF ((ELEN(X).GE.0).AND.(W(X).NE.WFLG)) THEN C X is a dense row NDENSE(ME) = NDENSE(ME) + NV(X) W(X) = WFLG ENDIF 54 CONTINUE ELSE C E is a dense row NDENSE(ME) = NDENSE(ME) + NV(E) IW(PLN)=E PLN = PLN+1_8 ENDIF 55 CONTINUE C ---------------------------------------------- C DEGREE(ME)-(N+1) holds last external degree computed C when Me was detected as dense C NDENSE(ME) is the exact external degree of ME C ---------------------------------------------- WFLG = WFLG + 1 LEN(ME) = int(PLN-P1) ELEN(ME) = int(PELN-P1) NDME = NDENSE(ME)+NV(ME) MINDEN = min (MINDEN, NDME) MAXDEN = max (MAXDEN, NDME) C If we want to select ME as exactly dense (NDME.EQ.NBD) C of quasi dense NDME.GE.THRESMupdated then C ndense(of elements adjacent to ME) sould be updated IF (NDENSE(ME).EQ.0) NDENSE(ME) =1 IF (IVersion.EQ.1) THEN C ------------------------------------------------ C place ME in the degree list of DEGREE(ME)-(N+1) C NDENSE is not used in this case (simulate of C preprocessing ) C ------------------------------------------------ DEG = max (DEGREE(ME)-(TOTEL+1), 1) ELSE C ----------------------------------------- C place ME in the degree list of NDENSE(ME) C ----------------------------------------- DEG = NDENSE(ME) ENDIF DEGREE(ME) = DEG MINDEG = min(DEG,MINDEG) JNEXT = HEAD(DEG) IF (JNEXT.NE. 0) LAST (JNEXT) = ME NEXT(ME) = JNEXT HEAD(DEG) = ME C ------------------------------ C process next quasi dense row C ------------------------------ ME = INEXT IF (ME.NE.0) THEN IF (DEGREE(ME).GT.(TOTEL+1) ) GOTO 51 ENDIF HEAD (TOTEL) = ME C --------------------------------------- C update dense row selection strategy C ------------------------------------- C IF (IVersion .EQ.1 ) THEN THRESM = TOTEL ELSE THRESM=max(THRESM*2,MINDEN+(MAXDEN-MINDEN)/2) C THRESM = max(THRESM*2, MINDEN*2) THRESM = min(THRESM,NBD) IF (THRESM.GE.NBD) THRESM=TOTEL ENDIF NBD = NBED C GOTO 30 ENDIF C ------------------------------------------------------------- C ------------------------------------------------------------- IF (DEGREE(ME).EQ.TOTEL+1) THEN C we have only exactly "dense" rows that we C amalgamate at the root node IF (NBD.NE.NBED) THEN write(6,*) ' Internal ERROR quasi dense rows remains' CALL MUMPS_ABORT() ENDIF C 1/ Go through all C non absorbed elements (root of the subgraph) C and absorb in ME C 2/ perform mass elimination of all dense rows C RMK: we could compute sum(NVPIV(d)) to check if = NBD NELME = -(NEL+1) DO 59 X=1,N IF ((PE(X).GT.0_8) .AND. (ELEN(X).LT.0)) THEN C X is an unabsorbed element PE(X) = int(-ME,8) C W(X) = 0 could be suppressed ?? check it ELSEIF (DEGREE(X).EQ.TOTEL+1) THEN C X is a dense row, absorb it in ME (mass elimination) NEL = NEL + NV(X) PE(X) = int(-ME,8) ELEN(X) = 0 NV(X) = 0 ENDIF 59 CONTINUE C ME is the root node ELEN(ME) = NELME NV(ME) = NBD PE(ME) = 0_8 IF (NEL.NE.TOTEL) THEN write(6,*) 'Internal ERROR 2 detected in QAMD' write(6,*) ' NEL not equal to N: N, NEL =',N,NEL CALL MUMPS_ABORT() ENDIF GOTO 265 ENDIF ENDIF C ------------------------------------------------------------- C me represents the elimination of pivots nel+1 to nel+nv(me). C place me itself as the first in this set. It will be moved C to the nel+nv(me) position when the permutation vectors are C computed. C ------------------------------------------------------------- ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV NDENSE(ME) = 0 C======================================================================= C CONSTRUCT NEW ELEMENT C======================================================================= C ------------------------------------------------------------- C At this point, me is the pivotal supervariable. It will be C converted into the current element. Scan list of the C pivotal supervariable, me, setting tree pointers and C constructing new list of supervariables for the new element, C me. p is a pointer to the current position in the old list. C ------------------------------------------------------------- C flag the variable "me" as being in Lme by negating nv (me) NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN C ---------------------------------------------------------- C construct the new element in place C ---------------------------------------------------------- PME1 = PE (ME) PME2 = PME1 - 1 DO 60 P = PME1, PME1 + int(LEN (ME) - 1,8) I = IW (P) NVI = NV (I) IF (NVI .GT. 0) THEN C ---------------------------------------------------- C i is a principal variable not yet placed in Lme. C store i in new list C ---------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI PME2 = PME2 + 1_8 IW (PME2) = I C ---------------------------------------------------- C remove variable i from degree list. C ---------------------------------------------------- C only done for non "dense" rows IF (DEGREE(I).LE.TOTEL) THEN ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (DEGREE (I)) = INEXT ENDIF ELSE NDENSE(ME) = NDENSE(ME) + NVI ENDIF ENDIF 60 CONTINUE C this element takes no new memory in iw: NEWMEM = 0 ELSE C ---------------------------------------------------------- C construct the new element in empty space, iw (pfree ...) C ---------------------------------------------------------- P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME KNT1_UPDATED = 0 DO 120 KNT1 = 1, ELENME + 1 KNT1_UPDATED = KNT1_UPDATED +1 IF (KNT1 .GT. ELENME) THEN C search the supervariables in me. E = ME PJ = P LN = SLENME ELSE C search the elements in me. E = IW (P) P = P + 1 PJ = PE (E) LN = LEN (E) ENDIF C ------------------------------------------------------- C search for different supervariables and add them to the C new list, compressing when necessary. this loop is C executed once for each element in the list and once for C all the supervariables in the list. C ------------------------------------------------------- KNT2_UPDATED = 0 DO 110 KNT2 = 1, LN KNT2_UPDATED = KNT2_UPDATED+1 I = IW (PJ) PJ = PJ + 1 NVI = NV (I) IF (NVI .GT. 0) THEN C ------------------------------------------------- C compress iw, if necessary C ------------------------------------------------- IF (PFREE .GT. IWLEN) THEN C prepare for compressing iw by adjusting C pointers and lengths so that the lists being C searched in the inner and outer loops contain C only the remaining entries. PE (ME) = P LEN (ME) = LEN (ME) - KNT1_UPDATED C Reset KNT1_UPDATED in case of recompress C at same iteration of the loop 120 KNT1_UPDATED = 0 C Check if anything left in supervariable ME IF (LEN (ME) .EQ. 0) PE (ME) = 0_8 PE (E) = PJ LEN (E) = LN - KNT2_UPDATED C Reset KNT2_UPDATED in case of recompress C at same iteration of the loop 110 KNT2_UPDATED = 0 C Check if anything left in element E IF (LEN (E) .EQ. 0) PE (E) = 0_8 NCMPA = NCMPA + 1 C store first item in pe C set first entry to -item DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = int(IW (PN),8) IW (PN) = -J ENDIF 70 CONTINUE C psrc/pdst point to source/destination PDST = 1 PSRC = 1 PEND = PME1 - 1 C while loop: 80 CONTINUE IF (PSRC .LE. PEND) THEN C search for next negative entry J = -IW (PSRC) PSRC = PSRC + 1 IF (J .GT. 0) THEN IW (PDST) = int(PE (J)) PE (J) = PDST PDST = PDST + 1_8 C copy from source to destination LENJ = LEN (J) DO 90 KNT3 = 0, LENJ - 2 IW (PDST + KNT3) = IW (PSRC + KNT3) 90 CONTINUE PDST = PDST + LENJ - 1 PSRC = PSRC + LENJ - 1 ENDIF GO TO 80 ENDIF C move the new partially-constructed element P1 = PDST DO 100 PSRC = PME1, PFREE - 1 IW (PDST) = IW (PSRC) PDST = PDST + 1 100 CONTINUE PME1 = P1 PFREE = PDST PJ = PE (E) P = PE (ME) ENDIF C ------------------------------------------------- C i is a principal variable not yet placed in Lme C store i in new list C ------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI IW (PFREE) = I PFREE = PFREE + 1 C ------------------------------------------------- C remove variable i from degree link list C ------------------------------------------------- C only done for non "dense" rows IF (DEGREE(I).LE.TOTEL) THEN ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (DEGREE (I)) = INEXT ENDIF ELSE NDENSE(ME) = NDENSE(ME) + NVI ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN C set tree pointer and flag to indicate element e is C absorbed into new element me (the parent of e is me) PE (E) = int(-ME,8) W (E) = 0 ENDIF 120 CONTINUE PME2 = PFREE - 1_8 C this element takes newmem new memory in iw (possibly zero) NEWMEM = PFREE - PME1 MEM = MEM + NEWMEM MAXMEM = max (MAXMEM, MEM) ENDIF C ------------------------------------------------------------- C me has now been converted into an element in iw (pme1..pme2) C ------------------------------------------------------------- C degme holds the external degree of new element DEGREE (ME) = DEGME PE (ME) = PME1 LEN (ME) = int(PME2 - PME1 + 1_8) C ------------------------------------------------------------- C make sure that wflg is not too large. With the current C value of wflg, wflg+n must not cause integer overflow C ------------------------------------------------------------- IF (WFLG .GT. MAXINT_N) THEN DO 130 X = 1, N IF (W (X) .NE. 0) W (X) = 1 130 CONTINUE WFLG = 2 ENDIF C======================================================================= C COMPUTE (w (e) - wflg) = |Le\Lme| FOR ALL ELEMENTS C======================================================================= C ------------------------------------------------------------- C Scan 1: compute the external degrees of previous elements C with respect to the current element. That is: C (w (e) - wflg) = |Le \ Lme| C for each element e that appears in any supervariable in Lme. C The notation Le refers to the pattern (list of C supervariables) of a previous element e, where e is not yet C absorbed, stored in iw (pe (e) + 1 ... pe (e) + iw (pe (e))). C The notation Lme refers to the pattern of the current element C (stored in iw (pme1..pme2)). If (w (e) - wflg) becomes C zero, then the element e will be absorbed in scan 2. C ------------------------------------------------------------- DO 150 PME = PME1, PME2 I = IW (PME) IF (DEGREE(I).GT.TOTEL) GOTO 150 ELN = ELEN (I) IF (ELN .GT. 0) THEN C note that nv (i) has been negated to denote i in Lme: NVI = -NV (I) WNVI = WFLG - NVI DO 140 P = PE (I), PE (I) + int(ELN - 1,8) E = IW (P) WE = W (E) IF (WE .GE. WFLG) THEN C unabsorbed element e has been seen in this loop WE = WE - NVI ELSE IF (WE .NE. 0) THEN C e is an unabsorbed element C this is the first we have seen e in all of Scan 1 WE = DEGREE (E) + WNVI - NDENSE(E) ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE C======================================================================= C DEGREE UPDATE AND ELEMENT ABSORPTION C======================================================================= C ------------------------------------------------------------- C Scan 2: for each i in Lme, sum up the degree of Lme (which C is degme), plus the sum of the external degrees of each Le C for the elements e appearing within i, plus the C supervariables in i. Place i in hash list. C ------------------------------------------------------------- DO 180 PME = PME1, PME2 I = IW (PME) IF (DEGREE(I).GT.TOTEL) GOTO 180 P1 = PE (I) P2 = P1 + int(ELEN (I) - 1,8) PN = P1 HASH = 0_8 DEG = 0 C ---------------------------------------------------------- C scan the element list associated with supervariable i C ---------------------------------------------------------- DO 160 P = P1, P2 E = IW (P) C dext = | Le \ Lme | DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN DEG = DEG + DEXT IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) #if defined (NOAGG5) C ------------------------------ C suppress aggressive absorption C ------------------------------ ELSE IF (DEXT .EQ. 0) THEN IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) #else C C ------------------------------ C try aggressive absorption C when possible C ELSE IF ((DEXT .EQ. 0) .AND. & (NDENSE(ME).EQ.NBD)) THEN C aggressive absorption: e is not adjacent to me, but C |Le(G') \ Lme(G')| is 0 and all dense rows C are in me, so absorb it into me PE (E) = int(-ME,8) W (E) = 0 ELSE IF (DEXT.EQ.0) THEN IW(PN) = E PN = PN+1 HASH = HASH + int(E,kind=8) #endif ENDIF 160 CONTINUE C count the number of elements in i (including me): ELEN (I) = int(PN - P1 + 1) C ---------------------------------------------------------- C scan the supervariables in the list associated with i C ---------------------------------------------------------- P3 = PN DO 170 P = P2 + 1, P1 + int(LEN (I) - 1,8) J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN C j is unabsorbed, and not in Lme. C add to degree and add to new list C add degree only of non-dense rows. IF (DEGREE(J).LE.TOTEL) DEG=DEG+NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE C ---------------------------------------------------------- C update the degree and check for mass elimination C ---------------------------------------------------------- #if defined (NOAGG5) IF (DEG.EQ.0.AND.(NDENSE(ME).EQ.NBD).AND.(ELEN(I).GT.1)) THEN C When mass elimination will be performed then C absorb in ME all element adjacent to I P1 = PE (I) C exclude ME --> -2 P2 = P1 + int(ELEN (I),8) - 2_8 DO P =P1,P2 E = IW(P) PE (E) = int(-ME,8) W (E) = 0 ENDDO ENDIF C .... Ready for mass elimination #endif IF ((DEG .EQ. 0).AND.(NDENSE(ME).EQ.NBD)) THEN C ------------------------------------------------------- C mass elimination C ------------------------------------------------------- C There is nothing left of this node except for an C edge to the current pivot element. elen (i) is 1, C and there are no variables adjacent to node i. C Absorb i into the current pivot element, me. PE (I) = int(-ME,8) NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE C ------------------------------------------------------- C update the upper-bound degree of i C ------------------------------------------------------- C the following degree does not yet include the size C of the current element, which is added later: DEGREE(I) = min (DEG+NBD-NDENSE(ME), & DEGREE(I)) C ------------------------------------------------------- C add me to the list for i C ------------------------------------------------------- C move first supervariable to end of list IW (PN) = IW (P3) C move first element to end of element part of list IW (P3) = IW (P1) C add new element to front of list. IW (P1) = ME C store the new length of the list in len (i) LEN (I) = int(PN - P1 + 1) C ------------------------------------------------------- C place in hash bucket. Save hash key of i in last (i). C ------------------------------------------------------- HASH = mod (HASH, HMOD) + 1_8 J = HEAD (HASH) IF (J .LE. 0) THEN C the degree list is empty, hash head is -j NEXT (I) = -J HEAD (HASH) = -I ELSE C degree list is not empty C use last (head (hash)) as hash head NEXT (I) = LAST (J) LAST (J) = I ENDIF LAST (I) = int(HASH,kind=kind(LAST)) ENDIF 180 CONTINUE DEGREE (ME) = DEGME C ------------------------------------------------------------- C Clear the counter array, w (...), by incrementing wflg. C ------------------------------------------------------------- DMAX = max (DMAX, DEGME) WFLG = WFLG + DMAX C make sure that wflg+n does not cause integer overflow IF (WFLG .GT. MAXINT_N) THEN DO 190 X = 1, N IF (W (X) .NE. 0) W (X) = 1 190 CONTINUE WFLG = 2 ENDIF C at this point, w (1..n) .lt. wflg holds C======================================================================= C SUPERVARIABLE DETECTION C======================================================================= DO 250 PME = PME1, PME2 I = IW (PME) IF ( (NV(I).LT.0) .AND. (DEGREE(I).LE.TOTEL) ) THEN C only done for nondense rows C i is a principal variable in Lme C ------------------------------------------------------- C examine all hash buckets with 2 or more variables. We C do this by examing all unique hash keys for super- C variables in the pattern Lme of the current element, me C ------------------------------------------------------- HASH = int(LAST (I),kind=8) C let i = head of hash bucket, and empty the hash bucket J = HEAD (HASH) IF (J .EQ. 0) GO TO 250 IF (J .LT. 0) THEN C degree list is empty I = -J HEAD (HASH) = 0 ELSE C degree list is not empty, restore last () of head I = LAST (J) LAST (J) = 0 ENDIF IF (I .EQ. 0) GO TO 250 C while loop: 200 CONTINUE IF (NEXT (I) .NE. 0) THEN C ---------------------------------------------------- C this bucket has one or more variables following i. C scan all of them to see if i can absorb any entries C that follow i in hash bucket. Scatter i into w. C ---------------------------------------------------- LN = LEN (I) ELN = ELEN (I) C do not flag the first element in the list (me) DO 210 P = PE (I) + 1, PE (I) + int(LN - 1,8) W (IW (P)) = WFLG 210 CONTINUE C ---------------------------------------------------- C scan every other entry j following i in bucket C ---------------------------------------------------- JLAST = I J = NEXT (I) C while loop: 220 CONTINUE IF (J .NE. 0) THEN C ------------------------------------------------- C check if j and i have identical nonzero pattern C ------------------------------------------------- C jump if i and j do not have same size data structure IF (LEN (J) .NE. LN) GO TO 240 C jump if i and j do not have same number adj elts IF (ELEN (J) .NE. ELN) GO TO 240 C do not flag the first element in the list (me) DO 230 P = PE (J) + 1, PE (J) + int(LN - 1,8) C jump if an entry (iw(p)) is in j but not in i IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE C ------------------------------------------------- C found it! j can be absorbed into i C ------------------------------------------------- PE (J) = int(-I,8) C both nv (i) and nv (j) are negated since they C are in Lme, and the absolute values of each C are the number of variables in i and j: NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 C delete j from hash bucket J = NEXT (J) NEXT (JLAST) = J GO TO 220 C ------------------------------------------------- 240 CONTINUE C j cannot be absorbed into i C ------------------------------------------------- JLAST = J J = NEXT (J) GO TO 220 ENDIF C ---------------------------------------------------- C no more variables can be absorbed into i C go to next i in bucket and clear flag array C ---------------------------------------------------- WFLG = WFLG + 1 I = NEXT (I) IF (I .NE. 0) GO TO 200 ENDIF ENDIF 250 CONTINUE C======================================================================= C RESTORE DEGREE LISTS AND REMOVE NONPRINCIPAL SUPERVAR. FROM ELEMENT C======================================================================= P = PME1 NLEFT = TOTEL - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN C i is a principal variable in Lme C restore nv (i) to signify that i is principal NV (I) = NVI IF (DEGREE(I).LE.TOTEL) THEN C ------------------------------------------------------- C compute the external degree (add size of current elem) C ------------------------------------------------------- DEG = min (DEGREE (I)+ DEGME - NVI, NLEFT - NVI) DEGREE (I) = DEG IDENSE = .FALSE. C IF ( (IVersion .NE. 1).AND. (THRESM.GE.0)) THEN C ------------------- C Dense row detection C ------------------- C DEGME is exact external degree of pivot ME |Le\Ve|, C DEG is is approx external degree of I C Relaxed dense row selection based on: C 1/ We want to avoid selecting dense rows that are C almost completely represented by adj(ME) C 1/ its density in reduced matrix and IF (DEG+NVI .GE. THRESM) THEN IF (THRESM.EQ.TOTEL) THEN C We must be sure that I is exactly dense in reduced matrix IF ((ELEN(I).LE.2) .AND. ((DEG+NVI).EQ.NLEFT) ) THEN C DEG approximation is exact and I is dense DEGREE(I) = TOTEL+1 IDENSE = .TRUE. ENDIF ELSE C relaxed dense row detection IDENSE = .TRUE. IF ((ELEN(I).LE.2).AND.((DEG+NVI).EQ.NLEFT) ) THEN DEGREE(I) = TOTEL+1 ELSE DEGREE(I) = TOTEL+1+DEGREE(I) ENDIF ENDIF ENDIF IF (IDENSE) THEN C update NDENSE of all elements in the list of element C adjacent to I (including ME). P1 = PE(I) P2 = P1 + int(ELEN(I) - 1,8) IF (P2.GE.P1) THEN DO 264 PJ=P1,P2 E= IW(PJ) NDENSE (E) = NDENSE(E) + NVI 264 CONTINUE ENDIF C insert I in the list of dense rows NBD = NBD+NVI DEG = TOTEL IF (DEGREE(I).EQ.TOTEL+1) THEN c insert I at the end of the list NBED = NBED +NVI IF (LASTD.EQ.0) THEN C degree list is empty LASTD = I HEAD(DEG) = I NEXT(I) = 0 LAST(I) = 0 ELSE NEXT(LASTD) = I LAST(I) = LASTD LASTD = I NEXT(I) = 0 ENDIF ELSE C insert I at the beginning of the list INEXT = HEAD(DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I LAST(I) = 0 IF (LASTD.EQ.0) LASTD=I ENDIF C end of IDENSE=true ENDIF C end of THRESM>0 ENDIF C IF (.NOT.IDENSE) THEN C ------------------------------------------------------- C place the supervariable at the head of the degree list C ------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I ENDIF C ------------------------------------------------------- C save the new degree, and find the minimum degree C ------------------------------------------------------- MINDEG = min (MINDEG, DEG) ENDIF C ------------------------------------------------------- C place the supervariable in the element pattern C ------------------------------------------------------- IW (P) = I P = P + 1 ENDIF 260 CONTINUE C======================================================================= C FINALIZE THE NEW ELEMENT C======================================================================= NV (ME) = NVPIV + DEGME C nv (me) is now the degree of pivot (including diagonal part) C save the length of the list for the new element me LEN (ME) = int(P - PME1) IF (LEN (ME) .EQ. 0) THEN C there is nothing left of the current pivot element PE (ME) = 0_8 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN C element was not constructed in place: deallocate part C of it (final size is less than or equal to newmem, C since newly nonprincipal variables have been removed). PFREE = P MEM = MEM - NEWMEM + int(LEN (ME),8) ENDIF C======================================================================= C END WHILE (selecting pivots) GO TO 30 ENDIF C======================================================================= 265 CONTINUE C======================================================================= C COMPUTE THE PERMUTATION VECTORS and update TREE C======================================================================= C ---------------------------------------------------------------- C The time taken by the following code is O(n). At this C point, elen (e) = -k has been done for all elements e, C and elen (i) = 0 has been done for all nonprincipal C variables i. At this point, there are no principal C supervariables left, and all elements are absorbed. C ---------------------------------------------------------------- C ---------------------------------------------------------------- C compute the ordering of unordered nonprincipal variables C ---------------------------------------------------------------- DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN C ---------------------------------------------------------- C i is an un-ordered row. Traverse the tree from i until C reaching an element, e. The element, e, was the C principal supervariable of i and all nodes in the path C from i to when e was selected as pivot. C ---------------------------------------------------------- J = int(-PE (I)) C while (j is a variable) do: 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = int(-PE (J)) GO TO 270 ENDIF E = J C ---------------------------------------------------------- C get the current pivot ordering of e C ---------------------------------------------------------- K = -ELEN (E) C ---------------------------------------------------------- C traverse the path again from i to e, and compress the C path (all nodes point to e). Path compression allows C this code to compute in O(n) time. Order the unordered C nodes in the path, and place the element e at the end. C ---------------------------------------------------------- J = I C while (j is a variable) do: 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = int(-PE (J)) PE (J) = int(-E,8) IF (ELEN (J) .EQ. 0) THEN C j is an unordered row ELEN (J) = K K = K + 1 ENDIF J = JNEXT GO TO 280 ENDIF C leave elen (e) negative, so we know it is an element ELEN (E) = -K ENDIF 290 CONTINUE IF (COMPUTE_PERM) THEN C ---------------------------------------------------------------- C reset the inverse permutation (elen (1..n)) to be positive, C and compute the permutation (last (1..n)). C ---------------------------------------------------------------- IF(COMPRESS) THEN LAST(1:N) = 0 HEAD(1:TOTEL-N)=0 DO I = 1, N K = abs (ELEN (I)) IF ( K <= N ) THEN LAST (K) = I ELSE HEAD(K-N)=I ENDIF ENDDO I = 1 DO K = 1, N IF(LAST (K) .NE. 0) THEN LAST(I) = LAST(K) ELEN(LAST(K)) = I I = I + 1 ENDIF ENDDO DO K = N+1, TOTEL IF (HEAD(K-N) .NE. 0) THEN LAST(I)=HEAD(K-N) ELEN(HEAD(K-N)) = I I = I + 1 ENDIF END DO ELSE DO 300 I = 1, N K = abs (ELEN (I)) LAST (K) = I ELEN (I) = K 300 CONTINUE ENDIF C======================================================================= C END OF COMPUTING PERMUTATIONS C======================================================================= ENDIF C======================================================================= C RETURN THE MEMORY USAGE IN IW C======================================================================= C If maxmem is less than or equal to iwlen, then no compressions C occurred, and iw (maxmem+1 ... iwlen) was unused. Otherwise C compressions did occur, and iwlen would have had to have been C greater than or equal to maxmem for no compressions to occur. C Return the value of maxmem in the pfree argument. PFREE = MAXMEM C=============================== C Save PE in PARENT array DO I=1,N PARENT(I) = int(PE(I)) ENDDO C=============================== RETURN END SUBROUTINE MUMPS_QAMD C----------------------------------------------------------------------- C MUMPS_CST_AMF: modified version of MUMPS_HAMF4 routine C implementing constraint minimum fill-in based C ordering. C Written by Stephane Pralet iduring his post-doctorate at INPT-IRIT C (Oct. 2004- Oct. 2005) C C Restrictive integer 64 bit variant : C it is assumed that IW array size can exceed 32-bit integer C SUBROUTINE MUMPS_CST_AMF (N, NBBUCK, & IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, WF, NEXT, W, HEAD, & CONSTRAINT,THESON, PARENT) IMPLICIT NONE C C Parameters C Input not modified INTEGER, INTENT(IN) :: N, NBBUCK INTEGER(8), INTENT(IN) :: IWLEN C Input undefined on output INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) C NV meaningful as input to encode compressed graphs INTEGER, INTENT(INOUT) :: NV(N) C C Output only INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: ELEN(N), LAST(N), PARENT(N) C C Input/output INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(N) C C Internal Workspace only C Min fill approximation one extra array of size NBBUCK+2 C is also needed INTEGER :: NEXT(N), DEGREE(N), W(N) INTEGER :: HEAD(0:NBBUCK+1), WF(N) C C Comments on the OUTPUT: C ---------------------- C Let V= V0 U V1 the nodes of the initial graph (|V|=n). C The assembly tree corresponds to the tree C of the supernodes (or supervariables). Each node of the C assembly tree is then composed of one principal variable C and a list of secondary variables. The list of C variable of a node (principal + secondary variables) then C describes the structure of the diagonal bloc of the C supernode. C The elimination tree denotes the tree of all the variables(=node) and C is therefore of order n. C C The arrays NV(N) and PE(N) give a description of the C assembly tree. C C 1/ Description of array nv(N) (on OUPUT) C nv(i)=0 i is a secondary variable C N+1> nv(i) >0 i is a principal variable, nv(i) holds the C the number of elements in column i of L (true degree of i) C C 2/ Description of array PE(N) (on OUPUT) C pe(i) = -(father of variable/node i) in the elimination tree: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C C 3/ Example: C Let If be a root node father of Is in the assembly tree. C If is the principal C variable of the node If and let If1, If2, If3 be the secondary variables C of node If. C Is is the principal C variable of the node Is and let Is1, Is2 be the secondary variables C of node Is. C C THEN: C NV(If1)=NV(If2)=NV(If3) = 0 (secondary variables) C NV(Is1)=NV(Is2) = 0 (secondary variables) C NV(If) > 0 ( principal variable) C NV(Is) > 0 ( principal variable) C PE(If) = 0 (root node) C PE(Is) = -If (If is the father of Is in the assembly tree) C PE(If1)=PE(If2)=PE(If3)= -If ( If is the principal variable) C PE(Is1)=PE(Is2)= -Is ( Is is the principal variable) C C C C HALOAMD_V1: (September 1997) C ********** C Initial version designed to experiment the numerical (fill-in) impact C of taking into account the halo. This code should be able C to experiment no-halo, partial halo, complete halo. C DATE: September 17th 1997 C C HALOAMD is designed to process a gragh composed of two types C of nodes, V0 and V1, extracted from a larger gragh. C V0^V1 = {}, C C We used Min. degree heuristic to order only C nodes in V0, but the adjacency to nodes C in V1 is taken into account during ordering. C Nodes in V1 are odered at last. C Adjacency between nodes of V1 need not be provided, C however |len(i)| must always corresponds to the number of C edges effectively provided in the adjacency list of i. C On input : c ******** C Nodes INODE in V1 are flagged with len(INODE) = -degree C modif version HALO V3 (August 1998): C if len(i) =0 and i \in V1 then C len(i) must be set on input to -N-1 C ERROR return (negative values in ncmpa) C ************ C negative value in ncmpa indicates an error detected C by HALOAMD. C C The graph provided MUST follow the rule: C if (i,j) is an edge in the gragh then C j must be in the adjacency list of i AND C i must be in the adjacency list of j. C REMARKS C ------- C C 1/ Providing edges between nodes of V1 should not C affect the final ordering, only the amount of edges C of the halo should effectively affect the solution. C This code should work in the following cases: C 1/ halo not provided C 2/ halo partially provided C 3/ complete halo C 4/ complete halo+interconnection between nodes of V1. C C 1/ should run and provide identical results (w.r.t to current C implementation of AMD in SCOTCH). C 3/ and 4 should provide identical results. C C 2/ All modifications of the AMD initial code are indicated C with begin HALO .. end HALO C C C Ordering of nodes in V0 is based on approximate minimum C fill-in heuristic. C C----------------------------------------------------------------------- C begin CONSTRAINT C CONSTRAINT(I) >= 0 : I can be selected C < 0 : I cannot be selected C > 0 : I release CONSTRAINT(I) C THESON(I) = 0 : I is a leaf in the supervariable representation C THESON(I) > I : THESON(I) belongs to the same supervariable as I C Parameters: INTEGER, INTENT(INOUT) :: CONSTRAINT(N) INTEGER, INTENT(out) :: THESON(N) INTEGER PREV,TOTO C end CONSTRAINT C----------------------------------------------------------------------- C INPUT ARGUMENTS (unaltered): C----------------------------------------------------------------------- C n: The matrix order. C C Restriction: n .ge. 1 C iwlen: The length of iw (1..iwlen). On input, the matrix is C stored in iw (1..pfree-1). However, iw (1..iwlen) should be C slightly larger than what is required to hold the matrix, at C least iwlen .ge. pfree + n is recommended. Otherwise, C excessive compressions will take place. C *** We do not recommend running this algorithm with *** C *** iwlen .lt. pfree + n. *** C *** Better performance will be obtained if *** C *** iwlen .ge. pfree + n *** C *** or better yet *** C *** iwlen .gt. 1.2 * pfree *** C *** (where pfree is its value on input). *** C The algorithm will not run at all if iwlen .lt. pfree-1. C C Restriction: iwlen .ge. pfree-1 C----------------------------------------------------------------------- C INPUT/OUPUT ARGUMENTS: C----------------------------------------------------------------------- C pe: On input, pe (i) is the index in iw of the start of row i, or C zero if row i has no off-diagonal non-zeros. C C During execution, it is used for both supervariables and C elements: C C * Principal supervariable i: index into iw of the C description of supervariable i. A supervariable C represents one or more rows of the matrix C with identical nonzero pattern. C * Non-principal supervariable i: if i has been absorbed C into another supervariable j, then pe (i) = -j. C That is, j has the same pattern as i. C Note that j might later be absorbed into another C supervariable j2, in which case pe (i) is still -j, C and pe (j) = -j2. C * Unabsorbed element e: the index into iw of the description C of element e, if e has not yet been absorbed by a C subsequent element. Element e is created when C the supervariable of the same name is selected as C the pivot. C * Absorbed element e: if element e is absorbed into element C e2, then pe (e) = -e2. This occurs when the pattern of C e (that is, Le) is found to be a subset of the pattern C of e2 (that is, Le2). If element e is "null" (it has C no nonzeros outside its pivot block), then pe (e) = 0. C C On output, pe holds the assembly tree/forest, which implicitly C represents a pivot order with identical fill-in as the actual C order (via a depth-first search of the tree). C C On output: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C On output: (PE is copied on output into PARENT array) C C pfree: On input, the matrix is stored in iw (1..pfree-1) and C the rest of the array iw is free. C During execution, additional data is placed in iw, and pfree C is modified so that components of iw from pfree are free. C On output, pfree is set equal to the size of iw that C would have been needed for no compressions to occur. If C ncmpa is zero, then pfree (on output) is less than or equal to C iwlen, and the space iw (pfree+1 ... iwlen) was not used. C Otherwise, pfree (on output) is greater than iwlen, and all the C memory in iw was used. C C nv: On input, encoding of compressed graph: C if NV(1) = -1 then graph is not compressed otherwise C NV(I) holds the weight of node I. C During execution, abs (nv (i)) is equal to the number of rows C that are represented by the principal supervariable i. If i is C a nonprincipal variable, then nv (i) = 0. Initially, C nv (i) = 1 for all i. nv (i) .lt. 0 signifies that i is a C principal variable in the pattern Lme of the current pivot C element me. On output, nv (e) holds the true degree of element C e at the time it was created (including the diagonal part). C begin HALO C On output, nv(I) can be used to find node in set V1. C Not true anymore : ( nv(I) = N+1 characterizes nodes in V1. C instead nodes in V1 are considered as a dense root node ) C end HALO C----------------------------------------------------------------------- C INPUT/MODIFIED (undefined on output): C----------------------------------------------------------------------- C len: On input, len (i) C positive or null (>=0) : i \in V0 and C len(i) holds the number of entries in row i of the C matrix, excluding the diagonal. C negative (<0) : i \in V1, and C -len(i) hold the number of entries in row i of the C matrix, excluding the diagonal. C len(i) = - | Adj(i) | if i \in V1 C or -N -1 if | Adj(i) | = 0 and i \in V1 C The contents of len (1..n) C are undefined on output. C iw: On input, iw (1..pfree-1) holds the description of each row i C in the matrix. The matrix must be symmetric, and both upper C and lower triangular parts must be present. The diagonal must C not be present. Row i is held as follows: C C len (i): the length of the row i data structure C iw (pe (i) ... pe (i) + len (i) - 1): C the list of column indices for nonzeros C in row i (simple supervariables), excluding C the diagonal. All supervariables start with C one row/column each (supervariable i is just C row i). C if len (i) is zero on input, then pe (i) is ignored C on input. C C Note that the rows need not be in any particular order, C and there may be empty space between the rows. C C During execution, the supervariable i experiences fill-in. C This is represented by placing in i a list of the elements C that cause fill-in in supervariable i: C C len (i): the length of supervariable i C iw (pe (i) ... pe (i) + elen (i) - 1): C the list of elements that contain i. This list C is kept short by removing absorbed elements. C iw (pe (i) + elen (i) ... pe (i) + len (i) - 1): C the list of supervariables in i. This list C is kept short by removing nonprincipal C variables, and any entry j that is also C contained in at least one of the elements C (j in Le) in the list for i (e in row i). C C When supervariable i is selected as pivot, we create an C element e of the same name (e=i): C C len (e): the length of element e C iw (pe (e) ... pe (e) + len (e) - 1): C the list of supervariables in element e. C C An element represents the fill-in that occurs when supervariable C i is selected as pivot (which represents the selection of row i C and all non-principal variables whose principal variable is i). C We use the term Le to denote the set of all supervariables C in element e. Absorbed supervariables and elements are pruned C from these lists when computationally convenient. C C CAUTION: THE INPUT MATRIX IS OVERWRITTEN DURING COMPUTATION. C The contents of iw are undefined on output. C----------------------------------------------------------------------- C OUTPUT (need not be set on input): C----------------------------------------------------------------------- C elen: See the description of iw above. At the start of execution, C elen (i) is set to zero. During execution, elen (i) is the C number of elements in the list for supervariable i. When e C becomes an element, elen (e) = -nel is set, where nel is the C current step of factorization. elen (i) = 0 is done when i C becomes nonprincipal. C C For variables, elen (i) .ge. 0 holds until just before the C permutation vectors are computed. For elements, C elen (e) .lt. 0 holds. C C On output elen (1..n) holds the inverse permutation (the same C as the 'INVP' argument in Sparspak). That is, if k = elen (i), C then row i is the kth pivot row. Row i of A appears as the C (elen(i))-th row in the permuted matrix, PAP^T. C last: In a degree list, last (i) is the supervariable preceding i, C or zero if i is the head of the list. In a hash bucket, C last (i) is the hash key for i. last (head (hash)) is also C used as the head of a hash bucket if head (hash) contains a C degree list (see head, below). C C On output, last (1..n) holds the permutation (the same as the C 'PERM' argument in Sparspak). That is, if i = last (k), then C row i is the kth pivot row. Row last (k) of A is the k-th row C in the permuted matrix, PAP^T. C ncmpa: The number of times iw was compressed. If this is C excessive, then the execution took longer than what could have C been. To reduce ncmpa, try increasing iwlen to be 10% or 20% C larger than the value of pfree on input (or at least C iwlen .ge. pfree + n). The fastest performance will be C obtained when ncmpa is returned as zero. If iwlen is set to C the value returned by pfree on *output*, then no compressions C will occur. C begin HALO C on output ncmpa <0 --> error detected during HALO_AMD: C error 1: ncmpa = -N , ordering was stopped. C end HALO C C----------------------------------------------------------------------- C LOCAL (not input or output - used only during execution): C----------------------------------------------------------------------- C degree: If i is a supervariable, then degree (i) holds the C current approximation of the external degree of row i (an upper C bound). The external degree is the number of nonzeros in row i, C minus abs (nv (i)) (the diagonal part). The bound is equal to C the external degree if elen (i) is less than or equal to two. C We also use the term "external degree" for elements e to refer C to |Le \ Lme|. If e is an element, then degree (e) holds |Le|, C which is the degree of the off-diagonal part of the element e C (not including the diagonal part). C begin HALO C degree(I) = n+1 indicates that i belongs to V1 C end HALO C C head: head is used for degree lists. head (deg) is the first C supervariable in a degree list (all supervariables i in a C degree list deg have the same approximate degree, namely, C deg = degree (i)). If the list deg is empty then C head (deg) = 0. C C During supervariable detection head (hash) also serves as a C pointer to a hash bucket. C If head (hash) .gt. 0, there is a degree list of degree hash. C The hash bucket head pointer is last (head (hash)). C If head (hash) = 0, then the degree list and hash bucket are C both empty. C If head (hash) .lt. 0, then the degree list is empty, and C -head (hash) is the head of the hash bucket. C After supervariable detection is complete, all hash buckets C are empty, and the (last (head (hash)) = 0) condition is C restored for the non-empty degree lists. C next: next (i) is the supervariable following i in a link list, or C zero if i is the last in the list. Used for two kinds of C lists: degree lists and hash buckets (a supervariable can be C in only one kind of list at a time). C w: The flag array w determines the status of elements and C variables, and the external degree of elements. C C for elements: C if w (e) = 0, then the element e is absorbed C if w (e) .ge. wflg, then w (e) - wflg is the size of C the set |Le \ Lme|, in terms of nonzeros (the C sum of abs (nv (i)) for each principal variable i that C is both in the pattern of element e and NOT in the C pattern of the current pivot element, me). C if wflg .gt. w (e) .gt. 0, then e is not absorbed and has C not yet been seen in the scan of the element lists in C the computation of |Le\Lme| in loop 150 below. C C for variables: C during supervariable detection, if w (j) .ne. wflg then j is C not in the pattern of variable i C C The w array is initialized by setting w (i) = 1 for all i, C and by setting wflg = 2. It is reinitialized if wflg becomes C too large (to ensure that wflg+n does not cause integer C overflow). C C wf : integer array used to store the already filled area of C the variables adajcent to current pivot. C wf is then used to update the score of variable i. C C----------------------------------------------------------------------- C LOCAL INTEGERS: C----------------------------------------------------------------------- INTEGER :: DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, ME, MINDEG, NEL, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, & NBFLAG, NREAL, LASTD, NELME, WF3, WF4, N2, PAS INTEGER KNT1_UPDATED, KNT2_UPDATED INTEGER(8) :: MAXMEM, MEM, NEWMEM INTEGER :: MAXINT_N INTEGER(8):: HASH, HMOD DOUBLE PRECISION :: RMF, RMF1 DOUBLE PRECISION :: dummy INTEGER :: idummy C deg: the degree of a variable or element C degme: size, |Lme|, of the current element, me (= degree (me)) C dext: external degree, |Le \ Lme|, of some element e C dmax: largest |Le| seen so far C e: an element C elenme: the length, elen (me), of element list of pivotal var. C eln: the length, elen (...), of an element list C hash: the computed value of the hash function C hmod: the hash function is computed modulo hmod = max (1,n-1) C i: a supervariable C ilast: the entry in a link list preceding i C inext: the entry in a link list following i C j: a supervariable C jlast: the entry in a link list preceding j C jnext: the entry in a link list, or path, following j C k: the pivot order of an element or variable C knt1: loop counter used during element construction C knt2: loop counter used during element construction C knt3: loop counter used during compression C lenj: len (j) C ln: length of a supervariable list C maxint_n: large integer to test risk of overflow on wflg C maxmem: amount of memory needed for no compressions C me: current supervariable being eliminated, and the C current element created by eliminating that C supervariable C mem: memory in use assuming no compressions have occurred C mindeg: current minimum degree C nel: number of pivots selected so far C newmem: amount of new memory needed for current pivot element C nleft: n - nel, the number of nonpivotal rows/columns remaining C nvi: the number of variables in a supervariable i (= nv (i)) C nvj: the number of variables in a supervariable j (= nv (j)) C nvpiv: number of pivots in current element C slenme: number of variables in variable list of pivotal variable C we: w (e) C wflg: used for flagging the w array. See description of iw. C wnvi: wflg - nv (i) C x: either a supervariable or an element C wf3: off diagonal block area C wf4: diagonal block area C mf : Minimum fill C begin HALO C nbflag: number of flagged entries in the initial gragh. C nreal : number of entries on which ordering must be perfomed C (nreel = N- nbflag) C nelme number of pivots selected when reaching the root C lastd index of the last row in the list of dense rows C end HALO C----------------------------------------------------------------------- C LOCAL POINTERS: C----------------------------------------------------------------------- INTEGER(8) P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, & PN, PSRC C Any parameter (pe (...) or pfree) or local variable C starting with "p" (for Pointer) is an index into iw, C and all indices into iw use variables starting with C "p." The only exception to this rule is the iwlen C input argument. C p: pointer into lots of things C p1: pe (i) for some variable i (start of element list) C p2: pe (i) + elen (i) - 1 for some var. i (end of el. list) C p3: index of first supervariable in clean list C pdst: destination pointer, for compression C pend: end of memory to compress C pj: pointer into an element or variable C pme: pointer into the current element (pme1...pme2) C pme1: the current element, me, is stored in iw (pme1...pme2) C pme2: the end of the current element C pn: pointer into a "clean" variable, also used to compress C psrc: source pointer, for compression C----------------------------------------------------------------------- C FUNCTIONS CALLED: C----------------------------------------------------------------------- INTRINSIC max, min, mod, huge INTEGER TOTEL C======================================================================= C INITIALIZATIONS C======================================================================= C HEAD (0:NBBUCK+1) C begin HALO C C idummy holds the largest integer - 1 C dummy = dble (idummy) idummy = huge(idummy) - 1 dummy = dble(idummy) C variable with degree equal to N2 are in halo C bucket NBBUCK+1 used for HALO variables N2 = -NBBUCK-1 C end HALO C Distance betweeen elements of the N, ..., NBBUCK entries of HEAD C C update done on 20 Feb 2002 (PAS>= 1) PAS = max((N/8), 1) WFLG = 2 MAXINT_N=huge(WFLG)-N NCMPA = 0 NEL = 0 HMOD = int(max (1, NBBUCK-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM MINDEG = 0 C NBFLAG = 0 LASTD = 0 HEAD(0:NBBUCK+1) = 0 DO 10 I = 1, N THESON(I) = 0 LAST (I) = 0 C NV (I) = 1 W (I) = 1 ELEN (I) = 0 10 CONTINUE TOTEL = 0 DO I=1,N IF (LEN(I).LT.0) THEN DEGREE (I) = N2 NBFLAG = NBFLAG +1 IF (LEN(I).EQ.-N-1) THEN C variable in V1 with empty adj list LEN (I) = 0 C Because of compress, we force skipping this C entry which is anyway empty PE (I) = 0_8 ELSE LEN (I) = - LEN(I) ENDIF C end HALO V3 ELSE TOTEL = TOTEL + NV(I) DEGREE(I) = 0 DO P= PE(I) , PE(I)+int(LEN(I)-1,8) DEGREE(I) = DEGREE(I) + NV(IW(P)) ENDDO ENDIF ENDDO C C C number of entries to be ordered. NREAL = N - NBFLAG C ---------------------------------------------------------------- C initialize degree lists and eliminate rows with no off-diag. nz. C ---------------------------------------------------------------- DO 20 I = 1, N DEG = DEGREE (I) IF (DEG.EQ.N2) THEN C DEG = N2 (flagged variables are stored C in the degree list of NBBUCK + 1 C (safe: because max C max value of degree is NBBUCK) C DEG = NBBUCK + 1 IF (LASTD.EQ.0) THEN C degree list is empty LASTD = I HEAD(DEG) = I NEXT(I) = 0 LAST(I) = 0 ELSE NEXT(LASTD) = I LAST(I) = LASTD LASTD = I NEXT(I) = 0 ENDIF GOTO 20 ENDIF C C IF (DEG .GT. 0) THEN WF(I) = DEG IF (DEG.GT.N) THEN DEG = min(((DEG-N)/PAS) + N , NBBUCK) ENDIF C Note that if deg=0 then C No fill-in will occur, C but one variable is adjacent to I C ---------------------------------------------------------- C place i in the degree list corresponding to its degree C ---------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ELSE C ---------------------------------------------------------- C we have a variable that can be eliminated at once because C there is no off-diagonal non-zero in its row. C ---------------------------------------------------------- NEL = NEL + NV(I) ELEN (I) = -NEL PE (I) = 0_8 W (I) = 0 ENDIF C======================================================================= C 20 CONTINUE C======================================================================= C WHILE (selecting pivots) DO C======================================================================= NLEFT = TOTEL-NEL C======================================================================= C ===================================================================== 30 IF (NEL .LT. TOTEL) THEN C ===================================================================== C GET PIVOT OF MINIMUM DEGREE C======================================================================= C ------------------------------------------------------------- C find next supervariable for elimination C ------------------------------------------------------------- DO 40 DEG = MINDEG, NBBUCK ME = HEAD (DEG) IF (ME .GT. 0) GO TO 50 40 CONTINUE 50 MINDEG = DEG IF (ME.LE.0) THEN NCMPA = -N CALL MUMPS_ABORT() ENDIF IF (DEG.GT.N) THEN C ------------------------------- C Linear search to find variable C with best score in the list C ------------------------------- C While end of list list not reached C NEXT(J) = 0 J = NEXT(ME) K = WF(ME) C if ME is not available IF(CONSTRAINT(ME) .LT. 0) THEN K = -1 ENDIF 55 CONTINUE IF (J.GT.0) THEN C j is available IF(CONSTRAINT(J) .GE. 0) THEN IF (WF(J).LT.K .OR. K .LT. 0) THEN ME = J K = WF(ME) ENDIF ENDIF J= NEXT(J) GOTO 55 ENDIF ILAST = LAST(ME) INEXT = NEXT(ME) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C me is at the head of the degree list HEAD (DEG) = INEXT ENDIF C ELSE C select ME which verify the constraint C if it is directly ok IF(CONSTRAINT(ME) .GE. 0) GOTO 59 56 CONTINUE C if ME has a successor exaine it IF(NEXT(ME) .NE. 0) THEN ME = NEXT(ME) IF(CONSTRAINT(ME) .GE. 0) THEN GOTO 59 ELSE GOTO 56 ENDIF ELSE C ME has no successor -> increase deg till finding a valid ME C 57: increase deg till a non empty list is found 57 DEG = DEG+1 ME = HEAD(DEG) C no empty found IF(ME .GT. 0) THEN C good piv found IF(CONSTRAINT(ME) .GE. 0) THEN GOTO 59 ELSE C else loop on next GOTO 56 ENDIF ELSE C increase degree GOTO 57 ENDIF ENDIF 59 PREV = LAST (ME) INEXT = NEXT (ME) IF(PREV .NE. 0) THEN NEXT(PREV) = INEXT ELSE HEAD (DEG) = INEXT ENDIF C remove ME from the x2 linked lists IF (INEXT .NE. 0) LAST (INEXT) = PREV ENDIF C ------------------------------------------------------------- C remove chosen variable from link list C ------------------------------------------------------------- TOTO = ME 5910 IF(TOTO .NE. 0) THEN J = CONSTRAINT(TOTO) IF(J .GT. 0) THEN CONSTRAINT(J) = 0 ENDIF TOTO = THESON(TOTO) GOTO 5910 ENDIF C ------------------------------------------------------------- C me represents the elimination of pivots nel+1 to nel+nv(me). C place me itself as the first in this set. It will be moved C to the nel+nv(me) position when the permutation vectors are C computed. C ------------------------------------------------------------- ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV C======================================================================= C CONSTRUCT NEW ELEMENT C======================================================================= C ------------------------------------------------------------- C At this point, me is the pivotal supervariable. It will be C converted into the current element. Scan list of the C pivotal supervariable, me, setting tree pointers and C constructing new list of supervariables for the new element, C me. p is a pointer to the current position in the old list. C ------------------------------------------------------------- C flag the variable "me" as being in Lme by negating nv (me) NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN C ---------------------------------------------------------- C construct the new element in place C ---------------------------------------------------------- PME1 = PE (ME) PME2 = PME1 - 1 DO 60 P = PME1, PME1 + LEN (ME) - 1 I = IW (P) NVI = NV (I) IF (NVI .GT. 0) THEN C ---------------------------------------------------- C i is a principal variable not yet placed in Lme. C store i in new list C ---------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I IF (DEGREE(I).NE.N2) THEN C ---------------------------------------------------- C remove variable i from degree list. (only if i \in V0) C ---------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list IF (WF(I).GT.N) THEN DEG = min(((WF(I)-N)/PAS) + N , NBBUCK) ELSE DEG = WF(I) ENDIF HEAD (DEG) = INEXT ENDIF ENDIF ENDIF 60 CONTINUE C this element takes no new memory in iw: NEWMEM = 0 ELSE C ---------------------------------------------------------- C construct the new element in empty space, iw (pfree ...) C ---------------------------------------------------------- P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME KNT1_UPDATED = 0 DO 120 KNT1 = 1, ELENME + 1 KNT1_UPDATED = KNT1_UPDATED +1 IF (KNT1 .GT. ELENME) THEN C search the supervariables in me. E = ME PJ = P LN = SLENME ELSE C search the elements in me. E = IW (P) P = P + 1 PJ = PE (E) LN = LEN (E) ENDIF C ------------------------------------------------------- C search for different supervariables and add them to the C new list, compressing when necessary. this loop is C executed once for each element in the list and once for C all the supervariables in the list. C ------------------------------------------------------- KNT2_UPDATED = 0 DO 110 KNT2 = 1, LN KNT2_UPDATED = KNT2_UPDATED+1 I = IW (PJ) PJ = PJ + 1 NVI = NV (I) IF (NVI .GT. 0) THEN C ------------------------------------------------- C compress iw, if necessary C ------------------------------------------------- IF (PFREE .GT. IWLEN) THEN C prepare for compressing iw by adjusting C pointers and lengths so that the lists being C searched in the inner and outer loops contain C only the remaining entries. PE (ME) = P LEN (ME) = LEN (ME) - KNT1_UPDATED C Reset KNT1_UPDATED in case of recompress C at same iteration of the loop 120 KNT1_UPDATED = 0 C Check if anything left in supervariable ME IF (LEN (ME) .EQ. 0) PE (ME) = 0_8 PE (E) = PJ LEN (E) = LN - KNT2_UPDATED C Reset KNT2_UPDATED in case of recompress C at same iteration of the loop 110 KNT2_UPDATED = 0 C Check if anything left in element E IF (LEN (E) .EQ. 0) PE (E) = 0_8 NCMPA = NCMPA + 1 C store first item in pe C set first entry to -item DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = int(IW (PN),8) IW (PN) = -J ENDIF 70 CONTINUE C psrc/pdst point to source/destination PDST = 1 PSRC = 1 PEND = PME1 - 1 C while loop: 80 CONTINUE IF (PSRC .LE. PEND) THEN C search for next negative entry J = -IW (PSRC) PSRC = PSRC + 1 IF (J .GT. 0) THEN IW (PDST) = int(PE (J)) PE (J) = PDST PDST = PDST + 1_8 C copy from source to destination LENJ = LEN (J) DO 90 KNT3 = 0, LENJ - 2 IW (PDST + KNT3) = IW (PSRC + KNT3) 90 CONTINUE PDST = PDST + int(LENJ - 1,8) PSRC = PSRC + int(LENJ - 1,8) ENDIF GO TO 80 ENDIF C move the new partially-constructed element P1 = PDST DO 100 PSRC = PME1, PFREE - 1 IW (PDST) = IW (PSRC) PDST = PDST + 1 100 CONTINUE PME1 = P1 PFREE = PDST PJ = PE (E) P = PE (ME) ENDIF C ------------------------------------------------- C i is a principal variable not yet placed in Lme C store i in new list C ------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI IW (PFREE) = I PFREE = PFREE + 1 IF (DEGREE(I).NE.N2) THEN C ------------------------------------------------- C remove variable i from degree link list C (only if i in V0) C ------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE IF (WF(I).GT.N) THEN DEG = min(((WF(I)-N)/PAS) + N , NBBUCK) ELSE DEG = WF(I) ENDIF C i is at the head of the degree list HEAD (DEG) = INEXT ENDIF ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN C set tree pointer and flag to indicate element e is C absorbed into new element me (the parent of e is me) PE (E) = int(-ME,8) W (E) = 0 ENDIF 120 CONTINUE PME2 = PFREE - 1 C this element takes newmem new memory in iw (possibly zero) NEWMEM = PFREE - PME1 MEM = MEM + NEWMEM MAXMEM = max (MAXMEM, MEM) ENDIF C ------------------------------------------------------------- C me has now been converted into an element in iw (pme1..pme2) C ------------------------------------------------------------- C degme holds the external degree of new element DEGREE (ME) = DEGME PE (ME) = PME1 LEN (ME) = int(PME2 - PME1 + 1_8) C ------------------------------------------------------------- C make sure that wflg is not too large. With the current C value of wflg, wflg+n must not cause integer overflow C ------------------------------------------------------------- IF (WFLG .GT. MAXINT_N) THEN DO 130 X = 1, N IF (W (X) .NE. 0) W (X) = 1 130 CONTINUE WFLG = 2 ENDIF C======================================================================= C COMPUTE (w (e) - wflg) = |Le\Lme| FOR ALL ELEMENTS C======================================================================= C ------------------------------------------------------------- C Scan 1: compute the external degrees of previous elements C with respect to the current element. That is: C (w (e) - wflg) = |Le \ Lme| C for each element e that appears in any supervariable in Lme. C The notation Le refers to the pattern (list of C supervariables) of a previous element e, where e is not yet C absorbed, stored in iw (pe (e) + 1 ... pe (e) + iw (pe (e))). C The notation Lme refers to the pattern of the current element C (stored in iw (pme1..pme2)). If (w (e) - wflg) becomes C zero, then the element e will be absorbed in scan 2. C ------------------------------------------------------------- DO 150 PME = PME1, PME2 I = IW (PME) ELN = ELEN (I) IF (ELN .GT. 0) THEN C note that nv (i) has been negated to denote i in Lme: NVI = -NV (I) WNVI = WFLG - NVI DO 140 P = PE (I), PE (I) + int(ELN - 1,8) E = IW (P) WE = W (E) IF (WE .GE. WFLG) THEN C unabsorbed element e has been seen in this loop WE = WE - NVI ELSE IF (WE .NE. 0) THEN C e is an unabsorbed element C this is the first we have seen e in all of Scan 1 WE = DEGREE (E) + WNVI WF(E) = 0 ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE C======================================================================= C DEGREE UPDATE AND ELEMENT ABSORPTION C======================================================================= C ------------------------------------------------------------- C Scan 2: for each i in Lme, sum up the degree of Lme (which C is degme), plus the sum of the external degrees of each Le C for the elements e appearing within i, plus the C supervariables in i. Place i in hash list. C ------------------------------------------------------------- DO 180 PME = PME1, PME2 I = IW (PME) P1 = PE (I) P2 = P1 + int(ELEN (I) - 1,8) PN = P1 HASH = 0_8 DEG = 0 WF3 = 0 WF4 = 0 NVI = -NV(I) C ---------------------------------------------------------- C scan the element list associated with supervariable i C ---------------------------------------------------------- DO 160 P = P1, P2 E = IW (P) C dext = | Le \ Lme | DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN IF ( WF(E) .EQ. 0 ) THEN C First time we meet e : compute wf(e) C which holds the surface associated to element e C it will later be deducted from fill-in C area of all variables adjacent to e WF(E) = DEXT * ( (2 * DEGREE(E)) - DEXT - 1) ENDIF WF4 = WF4 + WF(E) DEG = DEG + DEXT IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) ELSE IF (DEXT .EQ. 0) THEN #if defined (NOAGG4) IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) #else C aggressive absorption: e is not adjacent to me, but C the |Le \ Lme| is 0, so absorb it into me PE (E) = int(-ME,8) W (E) = 0 #endif ENDIF 160 CONTINUE C count the number of elements in i (including me): ELEN (I) = int(PN - P1 + 1_8) C ---------------------------------------------------------- C scan the supervariables in the list associated with i C ---------------------------------------------------------- P3 = PN DO 170 P = P2 + 1, P1 + int(LEN (I) - 1,8) J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN C j is unabsorbed, and not in Lme. C add to degree and add to new list DEG = DEG + NVJ WF3 = WF3 + NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE C IF (DEGREE(I).EQ.N2) DEG = N2 C ---------------------------------------------------------- C update the degree and check for mass elimination C ---------------------------------------------------------- #if defined (NOAGG4) IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN #else IF (DEG .EQ. 0) THEN #endif C ------------------------------------------------------- C mass elimination C ------------------------------------------------------- C There is nothing left of this node except for an C edge to the current pivot element. elen (i) is 1, C and there are no variables adjacent to node i. C Absorb i into the current pivot element, me. TOTO = I 5911 IF(TOTO .NE. 0) THEN J = CONSTRAINT(TOTO) IF(J .GT. 0) THEN CONSTRAINT(J) = 0 ENDIF TOTO = THESON(TOTO) GOTO 5911 ENDIF PE (I) = int(-ME,8) NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE C ------------------------------------------------------- C update the upper-bound degree of i C ------------------------------------------------------- C the following degree does not yet include the size C of the current element, which is added later: C AMD DEGREE (I) = min (DEGREE (I), DEG) IF (DEGREE(I).NE.N2) THEN C I does not belong to halo C dk = min (d(k-1)+degme, deg+degme) IF ( DEGREE (I).LT.DEG ) THEN C Our appox degree is loose. C we keep old value. Note that in C this case we cannot substract WF(I) C for min-fill score. WF4 = 0 WF3 = 0 ELSE DEGREE(I) = DEG ENDIF ENDIF C C compute WF(I) taking into account size of block 3.0 WF(I) = WF4 + 2*NVI*WF3 C ------------------------------------------------------- C add me to the list for i C ------------------------------------------------------- C move first supervariable to end of list IW (PN) = IW (P3) C move first element to end of element part of list IW (P3) = IW (P1) C add new element to front of list. IW (P1) = ME C store the new length of the list in len (i) LEN (I) = int(PN - P1 + 1_8) IF (DEG.NE.N2) THEN C ------------------------------------------------------- C place in hash bucket. Save hash key of i in last (i). C ------------------------------------------------------- HASH = mod (HASH, HMOD) + 1_8 J = HEAD (HASH) IF (J .LE. 0) THEN C the degree list is empty, hash head is -j NEXT (I) = -J HEAD (HASH) = -I ELSE C degree list is not empty C use last (head (hash)) as hash head NEXT (I) = LAST (J) LAST (J) = I ENDIF LAST (I) = int(HASH,kind=kind(LAST)) ENDIF ENDIF 180 CONTINUE DEGREE (ME) = DEGME C ------------------------------------------------------------- C Clear the counter array, w (...), by incrementing wflg. C ------------------------------------------------------------- DMAX = max (DMAX, DEGME) WFLG = WFLG + DMAX C make sure that wflg+n does not cause integer overflow IF (WFLG .GT. MAXINT_N) THEN DO 190 X = 1, N IF (W (X) .NE. 0) W (X) = 1 190 CONTINUE WFLG = 2 ENDIF C at this point, w (1..n) .lt. wflg holds C======================================================================= C SUPERVARIABLE DETECTION C======================================================================= DO 250 PME = PME1, PME2 I = IW (PME) IF ( (NV (I) .LT. 0) .AND. (DEGREE(I).NE.N2) ) THEN C i is a principal variable in Lme C ------------------------------------------------------- C examine all hash buckets with 2 or more variables. We C do this by examing all unique hash keys for super- C variables in the pattern Lme of the current element, me C ------------------------------------------------------- HASH = int(LAST (I),kind=8) C let i = head of hash bucket, and empty the hash bucket J = HEAD (HASH) IF (J .EQ. 0) GO TO 250 IF (J .LT. 0) THEN C degree list is empty I = -J HEAD (HASH) = 0 ELSE C degree list is not empty, restore last () of head I = LAST (J) LAST (J) = 0 ENDIF IF (I .EQ. 0) GO TO 250 C while loop: 200 CONTINUE IF (NEXT (I) .NE. 0) THEN C ---------------------------------------------------- C this bucket has one or more variables following i. C scan all of them to see if i can absorb any entries C that follow i in hash bucket. Scatter i into w. C ---------------------------------------------------- LN = LEN (I) ELN = ELEN (I) C do not flag the first element in the list (me) DO 210 P = PE (I) + 1, PE (I) + int(LN - 1,8) W (IW (P)) = WFLG 210 CONTINUE C ---------------------------------------------------- C scan every other entry j following i in bucket C ---------------------------------------------------- JLAST = I J = NEXT (I) C while loop: 220 CONTINUE IF (J .NE. 0) THEN IF(CONSTRAINT(J) .LT. 0 & .AND. CONSTRAINT(I) .LT. 0) THEN GOTO 240 ENDIF IF(CONSTRAINT(I) .GE. 0) THEN IF(CONSTRAINT(J) .LT. 0) THEN TOTO = I 221 IF(TOTO .NE. 0) THEN IF(CONSTRAINT(TOTO) .EQ. J) THEN GOTO 225 ENDIF TOTO =THESON(TOTO) GOTO 221 ENDIF ELSE GOTO 225 ENDIF ELSE C if I is locked see if it is freed thanks to J IF(CONSTRAINT(J) .GE. 0) THEN TOTO = J 222 IF(TOTO .NE. 0) THEN IF(CONSTRAINT(TOTO) .EQ. I) THEN GOTO 225 ENDIF TOTO =THESON(TOTO) GOTO 222 ENDIF ENDIF ENDIF GOTO 240 225 CONTINUE C ------------------------------------------------- C check if j and i have identical nonzero pattern C ------------------------------------------------- C jump if i and j do not have same size data structure IF (LEN (J) .NE. LN) GO TO 240 C jump if i and j do not have same number adj elts IF (ELEN (J) .NE. ELN) GO TO 240 C do not flag the first element in the list (me) DO 230 P = PE (J) + 1_8, PE (J) + int(LN - 1,8) C jump if an entry (iw(p)) is in j but not in i IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE C ------------------------------------------------- C found it! j can be absorbed into i C ------------------------------------------------- C update the supervariable composition TOTO = I 231 IF(THESON(TOTO) .NE. 0) THEN TOTO = THESON(TOTO) GOTO 231 ENDIF THESON(TOTO) = J IF(CONSTRAINT(I) .LT. 0) THEN CONSTRAINT(I) = 0 ENDIF PE (J) = int(-I,8) WF(I) = max(WF(I),WF(J)) C both nv (i) and nv (j) are negated since they C are in Lme, and the absolute values of each C are the number of variables in i and j: NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 C delete j from hash bucket J = NEXT (J) NEXT (JLAST) = J GO TO 220 C ------------------------------------------------- 240 CONTINUE C j cannot be absorbed into i C ------------------------------------------------- JLAST = J J = NEXT (J) GO TO 220 ENDIF C ---------------------------------------------------- C no more variables can be absorbed into i C go to next i in bucket and clear flag array C ---------------------------------------------------- WFLG = WFLG + 1 I = NEXT (I) IF (I .NE. 0) GO TO 200 ENDIF ENDIF 250 CONTINUE C======================================================================= C RESTORE DEGREE LISTS AND REMOVE NONPRINCIPAL SUPERVAR. FROM ELEMENT C======================================================================= P = PME1 NLEFT = TOTEL - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN C i is a principal variable in Lme C restore nv (i) to signify that i is principal NV (I) = NVI IF (DEGREE(I).NE.N2) THEN C ------------------------------------------------------- C compute the external degree (add size of current elem) C ------------------------------------------------------- DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) IF (DEGREE (I) + DEGME .GT. NLEFT ) THEN C DEG = DEGREE(I) RMF1 = dble(DEG)*dble( (DEG-1) + 2*DEGME ) & - dble(WF(I)) DEGREE(I) = NLEFT - NVI DEG = DEGREE(I) RMF = dble(DEG)*dble(DEG-1) & - dble(DEGME-NVI)*dble(DEGME-NVI-1) RMF = min(RMF, RMF1) ELSE DEG = DEGREE(I) DEGREE(I) = DEGREE (I) + DEGME - NVI RMF = dble(DEG)*dble( (DEG-1) + 2*DEGME ) & - dble(WF(I)) ENDIF RMF = RMF / dble(NVI+1) C IF (RMF.LT.dummy) THEN WF(I) = int ( anint( RMF )) ELSEIF (RMF / dble(N) .LT. dummy) THEN WF(I) = int ( anint( RMF/dble(N) )) ELSE WF(I) = idummy ENDIF WF(I) = max(1,WF(I)) C ------------------------------------------------------- C place the supervariable at the head of the degree list C ------------------------------------------------------- DEG = WF(I) IF (DEG.GT.N) THEN DEG = min(((DEG-N)/PAS) + N , NBBUCK) ENDIF INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I C ------------------------------------------------------- C save the new degree, and find the minimum degree C ------------------------------------------------------- MINDEG = min (MINDEG, DEG) ENDIF C ------------------------------------------------------- C place the supervariable in the element pattern C ------------------------------------------------------- IW (P) = I P = P + 1 ENDIF 260 CONTINUE C======================================================================= C FINALIZE THE NEW ELEMENT C======================================================================= NV (ME) = NVPIV + DEGME C fill_est = fill_est + nvpiv * (nvpiv + 2 * degme) C nv (me) is now the degree of pivot (including diagonal part) C save the length of the list for the new element me LEN (ME) = int(P - PME1) IF (LEN (ME) .EQ. 0) THEN C there is nothing left of the current pivot element PE (ME) = 0_8 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN C element was not constructed in place: deallocate part C of it (final size is less than or equal to newmem, C since newly nonprincipal variables have been removed). PFREE = P MEM = MEM - NEWMEM + int(LEN (ME),8) ENDIF C======================================================================= C END WHILE (selecting pivots) GO TO 30 ENDIF C======================================================================= C begin HALO V2 IF (NBFLAG.GT.0) THEN C C All possible pivots (not flagged have been eliminated). C We amalgamate all flagged variables at the root and C we finish the elimination tree. C 1/ Go through all C non absorbed elements (root of the subgraph) C and absorb in ME C 2/ perform mass elimination of all dense rows DO DEG = MINDEG, NBBUCK+1 ME = HEAD (DEG) IF (ME .GT. 0) GO TO 51 ENDDO 51 MINDEG = DEG NELME = -(NEL+1) DO X=1,N IF ((PE(X).GT.0_8) .AND. (ELEN(X).LT.0)) THEN C X is an unabsorbed element PE(X) = int(-ME,8) C W(X) = 0 could be suppressed ?? check it ELSEIF (DEGREE(X).EQ.N2) THEN C X is a dense row, absorb it in ME (mass elimination) NEL = NEL + NV(X) PE(X) = int(-ME,8) ELEN(X) = 0 C Correct value of NV is (secondary variable) NV(X) = 0 ENDIF ENDDO C ME is the root node ELEN(ME) = NELME C Correct value of NV is (principal variable) NV(ME) = N-NREAL PE(ME) = 0_8 C ENDIF C end HALO C======================================================================= C COMPUTE THE PERMUTATION VECTORS C======================================================================= C ---------------------------------------------------------------- C The time taken by the following code is O(n). At this C point, elen (e) = -k has been done for all elements e, C and elen (i) = 0 has been done for all nonprincipal C variables i. At this point, there are no principal C supervariables left, and all elements are absorbed. C ---------------------------------------------------------------- C ---------------------------------------------------------------- C compute the ordering of unordered nonprincipal variables C ---------------------------------------------------------------- DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN C ---------------------------------------------------------- C i is an un-ordered row. Traverse the tree from i until C reaching an element, e. The element, e, was the C principal supervariable of i and all nodes in the path C from i to when e was selected as pivot. C ---------------------------------------------------------- J = int(-PE (I)) C while (j is a variable) do: 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = int(-PE (J)) GO TO 270 ENDIF E = J C ---------------------------------------------------------- C get the current pivot ordering of e C ---------------------------------------------------------- K = -ELEN (E) C ---------------------------------------------------------- C traverse the path again from i to e, and compress the C path (all nodes point to e). Path compression allows C this code to compute in O(n) time. Order the unordered C nodes in the path, and place the element e at the end. C ---------------------------------------------------------- J = I C while (j is a variable) do: 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = int(-PE (J)) PE (J) = int(-E,8) IF (ELEN (J) .EQ. 0) THEN C j is an unordered row ELEN (J) = K K = K + 1 ENDIF J = JNEXT GO TO 280 ENDIF C leave elen (e) negative, so we know it is an element ELEN (E) = -K ENDIF 290 CONTINUE C ---------------------------------------------------------------- C reset the inverse permutation (elen (1..n)) to be positive, C and compute the permutation (last (1..n)). C ---------------------------------------------------------------- IF(.TRUE.) THEN C N is the size of the compressed graph. C If the graph was compressed on input then C indices in ELEN are in [1,TOTEL] C We build the inverse of ELEN in LAST (similar to C the pivot order but has zeros in it) and then compress C it. Since LAST is assumed to be of size N at the C interface level, we need another array to store C the inverse of ELEN for entries greater than N C We use DEGREE. LAST(1:N) = 0 DEGREE(1:TOTEL-N)=0 DO I = 1, N K = abs (ELEN (I)) IF ( K <= N ) THEN LAST (K) = I ELSE DEGREE(K-N)=I ENDIF ENDDO I = 1 DO K = 1, N IF(LAST (K) .NE. 0) THEN LAST(I) = LAST(K) ELEN(LAST(K)) = I I = I + 1 ENDIF ENDDO DO K = N+1, TOTEL IF (DEGREE(K-N) .NE. 0) THEN LAST(I)=DEGREE(K-N) ELEN(DEGREE(K-N)) = I I = I + 1 ENDIF END DO ELSE DO 300 I = 1, N K = abs (ELEN (I)) LAST (K) = I ELEN (I) = K 300 CONTINUE ENDIF C======================================================================= C RETURN THE MEMORY USAGE IN IW C======================================================================= C If maxmem is less than or equal to iwlen, then no compressions C occurred, and iw (maxmem+1 ... iwlen) was unused. Otherwise C compressions did occur, and iwlen would have had to have been C greater than or equal to maxmem for no compressions to occur. C Return the value of maxmem in the pfree argument. PFREE = MAXMEM C=============================== C Save PE in PARENT array DO I=1,N PARENT(I) = int(PE(I)) ENDDO C=============================== RETURN END SUBROUTINE MUMPS_CST_AMF C----------------------------------------------------------------------- C MUMPS_SYMQAMD: modified version of MUMPS_QAMD code to C designed to compute a symbolic factorization given C an input ordering (provided in PERM array) and possibly C a schur area. C --------- SUBROUTINE MUMPS_SYMQAMD & ( THRESH, NDENSE, & N, TOTEL, IWLEN, PE, PFREE, LEN, IW, NV, & ELEN, LAST, NCMPA, DEGREE, HEAD, NEXT, W, & PERM, LISTVAR_SCHUR, SIZE_SCHUR, & AGG6, PARENT ) IMPLICIT NONE C Input not modified INTEGER, INTENT(IN) :: N, TOTEL, SIZE_SCHUR LOGICAL, INTENT(IN) :: AGG6 INTEGER, INTENT(IN) :: THRESH INTEGER(8), INTENT(IN) :: IWLEN INTEGER, INTENT(IN) :: LISTVAR_SCHUR(max(1,SIZE_SCHUR)) C Input undefined on output INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) C C Output only INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: ELEN(N), LAST(TOTEL), PARENT(N) C C Input/output INTEGER, INTENT(INOUT) :: NV(N) INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(N) INTEGER, INTENT(INOUT) :: PERM(N) C C Internal Workspace only INTEGER, INTENT(OUT) :: NDENSE(N), DEGREE(N), & HEAD(TOTEL), NEXT(N), W(N) CPA2JY: FIXME should HEAD/LAST (N) instead of TOTEL ? C C ======================= C INTERFACE DOCUMENTATION C SPECIFIC TO SYMQAMD. C ======================= C (more details are sometimes C available in the C PREVIOUS DOCUMENTATION C section) C C N (in): the size of the matrix C number of supervariables if blocked format C TOTEL (in) : Number of variables to eliminate C C IWLEN (in): the length of the workspace IW C C PFREE (inout): says that IW(1:PFREE-1) contains the graph on input, see C below. (on output see meaning bellow) C IW (inout): C On input, IW(1:PFREE-1) contains the orginal graph C On output it has been corrupted because IW(1:IWLEN) has been C used as workspace. C C LEN(inout): On input, C LEN (i) holds the number of entries in row i of the C matrix, excluding the diagonal. The contents of LEN(1..N) C are undefined on output. C C PE(inout): On input PE(i) contains the pointers in IW to (the column C indices of) row i of the matrix. C On output it contains the tree: C - if I is a principal variable (NV(I) >0) then -pe(I) is the principal C variable of the father, or 0 if I is a root node. C - if I is a secondary variable (NV(I)=0) then -pe(I) is the principal C variable of the node it belongs to. C C On output: (PE is copied on output into PARENT array) C C C NV(inout): C On input: encoding of a blocked matrix C if NV(1).NE.-1 then NV(I) holds the weight of node I. C During execution, C abs (nv (i)) is equal to the number of rows C that are represented by the principal supervariable i. C If i is a nonprincipal variable, then nv (i) = 0. C nv (i) .lt. 0 signifies that i is a C principal variable in the pattern Lme of the current pivot C element me. C On output: C - if i is a principal variable, NV(i) is the size of the front C in the multifrontal terminology. C - if i is a secondary variable, NV(i)=0 C C PERM (inout) : MUST BE SET TO HOLD THE POSITION OF VARIABLE I IN THE C PERMUTED ORDER. C PERM(I) = J means that I is the Jth pivot. C PERM IS NOT ALTERED IF SIZE_SCHUR = 0. C IF SIZE_SCHUR > 0 and variable I is part of the Schur, C then PERM(I) must be greater than N - SIZE_SCHUR. C In that case, PERM(I) is altered: it is set to N+1 internally ! C C SIZE_SCHUR (in) : > 0 means that the last SIZE_SCHUR variable C in the order (such that PERM(I) > N-SIZE_SCHUR) C are part of the schur decompositon C and should remain ordered last and amalgamated C at the root of the elimination tree. C C LISTVAR_SCHUR(1:SIZE_SCHUR) (in): should be set on entry to the list of C variables (original indices) in the Schur complement C C THRESH (in): is used to set the local variable THRESM, corresponding C to the internal restarting feature. C <= 0 Recommended value. Automatic setting will be done. C Note that this does not correspond to the historical C documentation further below. C = N Only exactly dense rows in the reduced matrix are selected. C > 1 and <= N THRESH correspond to the minimum density requirement. C C At the moment if SIZE_SCHUR > 0 restarting functionality is disabled, C which means that performance is not optimal. It should work again with C a small modification but this has to be tested when it is re-enabled. C C ELEN (out) needs not be set on entry. C It contains the inverse C permutation on output. Not sure what it contains for the Schur C variables. C (it should be ok for the Schur too). C C LAST used internally as working space; C On output, last (1..n) holds the permutation, i = last (k), then C row i is the kth pivot row. C Not used on output and C Computation has been suppressed C since in the context of blocked matrix format C one cannot so easily compute last out of elen C (see end of MUMPS_QAMD in case of COMRPESS, C because elen(i) \in [1:TOTEL] and not \in [1:N]) C C AGG6 (in): controls if aggressive absorption should be authorized. C C ------------------------------------------- C ARGUMENTS USED INTERNALLY AS WORKARRAYS C Maybe some things are significant on output C but not in the normal cases of usage. C ------------------------------------------- C C NDENSE, LAST, NEXT, HEAD, DEGREE, W C C ------ C OUTPUT C ------ C C NCMPA (out): number of compressions. C C C ====================== C PREVIOUS DOCUMENTATION C ====================== C C NDENSE of an element is the number of dense rows in the element. C----------------------------------------------------------------------- C It is a modified version of MUMPS_QAMD C designed to automatically detect and exploit dense or quasi dense C rows in the reduced matrix at any step of the minimum degree. C The input integer parameter THRESH defines the quasi density: C THRESH : input parameter (not modified) C THRESH is used to compute THRESM C <=0 or N Only exactly dense rows in the reduced matrix are selected. C >1 and <=N THRESH correspond to the munimum density requirement. C Version 0: All dense and quasi dense rows are amalgamated at the C root node. C Version 1: Restart AMD with all quasi dense rows, and C increase density requirement. C----------------------------------------------------------------------- C Additionnal parameters/variables due to dense row manipulation: C C Local variables: C --------------- INTEGER THRESM, NDME, PERMeqN INTEGER NBD,NBED, NBDM, LASTD, NELME LOGICAL IDENSE C THRESM : Local Integer holding a C potentially modified value of THRESH. C When quasi dense rows are reintegrated in the C graph to be processed then THRESM is modified. C Note that if one sets THRESM to negative value then C <0 Classical AMD algorithm (no dense row detection) C NDME : number of dense row adjacent to me C NELME number of pivots selected when reching the root C LASTD index of the last row in the list of dense rows C NBD is the total number of dense rows selected C NBED is the total number of exactly dense rows detected. C NBDM is the maximum number of dense rows selected C IDENSE is used to indicate that the supervariable I is a dense or C quasi-dense row. C----------------------------------------------------------------------- C INPUT ARGUMENTS (unaltered): C----------------------------------------------------------------------- C n: The matrix order. C C Restriction: n .ge. 1 C iwlen: The length of iw (1..iwlen). On input, the matrix is C stored in iw (1..pfree-1). However, iw (1..iwlen) should be C slightly larger than what is required to hold the matrix, at C least iwlen .ge. pfree + n is recommended. Otherwise, C excessive compressions will take place. C *** We do not recommend running this algorithm with *** C *** iwlen .lt. pfree + n. *** C *** Better performance will be obtained if *** C *** iwlen .ge. pfree + n *** C *** or better yet *** C *** iwlen .gt. 1.2 * pfree *** C *** (where pfree is its value on input). *** C The algorithm will not run at all if iwlen .lt. pfree-1. C C Restriction: iwlen .ge. pfree-1 C----------------------------------------------------------------------- C INPUT/OUPUT ARGUMENTS: C----------------------------------------------------------------------- C pe: On input, pe (i) is the index in iw of the start of row i, or C zero if row i has no off-diagonal non-zeros. C C During execution, it is used for both supervariables and C elements: C C * Principal supervariable i: index into iw of the C description of supervariable i. A supervariable C represents one or more rows of the matrix C with identical nonzero pattern. C * Non-principal supervariable i: if i has been absorbed C into another supervariable j, then pe (i) = -j. C That is, j has the same pattern as i. C Note that j might later be absorbed into another C supervariable j2, in which case pe (i) is still -j, C and pe (j) = -j2. C * Unabsorbed element e: the index into iw of the description C of element e, if e has not yet been absorbed by a C subsequent element. Element e is created when C the supervariable of the same name is selected as C the pivot. C * Absorbed element e: if element e is absorbed into element C e2, then pe (e) = -e2. This occurs when the pattern of C e (that is, Le) is found to be a subset of the pattern C of e2 (that is, Le2). If element e is "null" (it has C no nonzeros outside its pivot block), then pe (e) = 0. C C On output, pe holds the assembly tree/forest, which implicitly C represents a pivot order with identical fill-in as the actual C order (via a depth-first search of the tree). C C On output: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C pfree: On input, the matrix is stored in iw (1..pfree-1) and C the rest of the array iw is free. C During execution, additional data is placed in iw, and pfree C is modified so that components of iw from pfree are free. C On output, pfree is set equal to the size of iw that C would have been needed for no compressions to occur. If C ncmpa is zero, then pfree (on output) is less than or equal to C iwlen, and the space iw (pfree+1 ... iwlen) was not used. C Otherwise, pfree (on output) is greater than iwlen, and all the C memory in iw was used. C----------------------------------------------------------------------- C INPUT/MODIFIED (undefined on output): C----------------------------------------------------------------------- C len: On input, len (i) holds the number of entries in row i of the C matrix, excluding the diagonal. The contents of len (1..n) C are undefined on output. C iw: On input, iw (1..pfree-1) holds the description of each row i C in the matrix. The matrix must be symmetric, and both upper C and lower triangular parts must be present. The diagonal must C not be present. Row i is held as follows: C C len (i): the length of the row i data structure C iw (pe (i) ... pe (i) + len (i) - 1): C the list of column indices for nonzeros C in row i (simple supervariables), excluding C the diagonal. All supervariables start with C one row/column each (supervariable i is just C row i). C if len (i) is zero on input, then pe (i) is ignored C on input. C C Note that the rows need not be in any particular order, C and there may be empty space between the rows. C C During execution, the supervariable i experiences fill-in. C This is represented by placing in i a list of the elements C that cause fill-in in supervariable i: C C len (i): the length of supervariable i C iw (pe (i) ... pe (i) + elen (i) - 1): C the list of elements that contain i. This list C is kept short by removing absorbed elements. C iw (pe (i) + elen (i) ... pe (i) + len (i) - 1): C the list of supervariables in i. This list C is kept short by removing nonprincipal C variables, and any entry j that is also C contained in at least one of the elements C (j in Le) in the list for i (e in row i). C C When supervariable i is selected as pivot, we create an C element e of the same name (e=i): C C len (e): the length of element e C iw (pe (e) ... pe (e) + len (e) - 1): C the list of supervariables in element e. C C An element represents the fill-in that occurs when supervariable C i is selected as pivot (which represents the selection of row i C and all non-principal variables whose principal variable is i). C We use the term Le to denote the set of all supervariables C in element e. Absorbed supervariables and elements are pruned C from these lists when computationally convenient. C C CAUTION: THE INPUT MATRIX IS OVERWRITTEN DURING COMPUTATION. C The contents of iw are undefined on output. C----------------------------------------------------------------------- C OUTPUT (need not be set on input): C----------------------------------------------------------------------- C nv: During execution, abs (nv (i)) is equal to the number of rows C that are represented by the principal supervariable i. If i is C a nonprincipal variable, then nv (i) = 0. Initially, C nv (i) = 1 for all i. nv (i) .lt. 0 signifies that i is a C principal variable in the pattern Lme of the current pivot C element me. On output, nv (e) holds the true degree of element C e at the time it was created (including the diagonal part). C elen: See the description of iw above. At the start of execution, C elen (i) is set to zero. During execution, elen (i) is the C number of elements in the list for supervariable i. When e C becomes an element, elen (e) = -nel is set, where nel is the C current step of factorization. elen (i) = 0 is done when i C becomes nonprincipal. C C For variables, elen (i) .ge. 0 holds until just before the C permutation vectors are computed. For elements, C elen (e) .lt. 0 holds. C C On output elen (1..n) holds the inverse permutation (the same C as the 'INVP' argument in Sparspak). That is, if k = elen (i), C then row i is the kth pivot row. Row i of A appears as the C (elen(i))-th row in the permuted matrix, PAP^T. C last: In a degree list, last (i) is the supervariable preceding i, C or zero if i is the head of the list. In a hash bucket, C last (i) is the hash key for i. last (head (hash)) is also C used as the head of a hash bucket if head (hash) contains a C degree list (see head, below). C C On output, last (1..n) holds the permutation (the same as the C 'PERM' argument in Sparspak). That is, if i = last (k), then C row i is the kth pivot row. Row last (k) of A is the k-th row C in the permuted matrix, PAP^T. C ncmpa: The number of times iw was compressed. If this is C excessive, then the execution took longer than what could have C been. To reduce ncmpa, try increasing iwlen to be 10% or 20% C larger than the value of pfree on input (or at least C iwlen .ge. pfree + n). The fastest performance will be C obtained when ncmpa is returned as zero. If iwlen is set to C the value returned by pfree on *output*, then no compressions C will occur. C----------------------------------------------------------------------- C LOCAL (not input or output - used only during execution): C----------------------------------------------------------------------- C degree: If i is a supervariable, then degree (i) holds the C current approximation of the external degree of row i (an upper C bound). The external degree is the number of nonzeros in row i, C minus abs (nv (i)) (the diagonal part). The bound is equal to C the external degree if elen (i) is less than or equal to two. C C We also use the term "external degree" for elements e to refer C to |Le \ Lme|. If e is an element, then degree (e) holds |Le|, C which is the degree of the off-diagonal part of the element e C (not including the diagonal part). C degree (I) =N+1 if I is an exactly dense row in reduced matrix. C =N+1+LAST_approximate_external_deg of I C if I is a quasi dense row in reduced matrix. C All dense or quasi dense rows are stored in the list pointed C by head(n). Quasi-dense rows (degree(I)=n) are stored first, C and are followed by exactly dense rows in the reduced matrix. C LASTD holds the last row in this list of dense rows or is zero C if the list is empty. C head: head is used for degree lists. head (deg) is the first C supervariable in a degree list (all supervariables i in a C degree list deg have the same approximate degree, namely, C deg = degree (i)). If the list deg is empty then C head (deg) = 0. C C During supervariable detection head (hash) also serves as a C pointer to a hash bucket. C If head (hash) .gt. 0, there is a degree list of degree hash. C The hash bucket head pointer is last (head (hash)). C If head (hash) = 0, then the degree list and hash bucket are C both empty. C If head (hash) .lt. 0, then the degree list is empty, and C -head (hash) is the head of the hash bucket. C After supervariable detection is complete, all hash buckets C are empty, and the (last (head (hash)) = 0) condition is C restored for the non-empty degree lists. C next: next (i) is the supervariable following i in a link list, or C zero if i is the last in the list. Used for two kinds of C lists: degree lists and hash buckets (a supervariable can be C in only one kind of list at a time). C w: The flag array w determines the status of elements and C variables, and the external degree of elements. C C for elements: C if w (e) = 0, then the element e is absorbed C if w (e) .ge. wflg, then w (e) - wflg is the size of C the set |Le \ Lme|, in terms of nonzeros (the C sum of abs (nv (i)) for each principal variable i that C is both in the pattern of element e and NOT in the C pattern of the current pivot element, me). C if wflg .gt. w (e) .gt. 0, then e is not absorbed and has C not yet been seen in the scan of the element lists in C the computation of |Le\Lme| in loop 150 below. C C for variables: C during supervariable detection, if w (j) .ne. wflg then j is C not in the pattern of variable i C C The w array is initialized by setting w (i) = 1 for all i, C and by setting wflg = 2. It is reinitialized if wflg becomes C too large (to ensure that wflg+n does not cause integer C overflow). C----------------------------------------------------------------------- C LOCAL INTEGERS: C----------------------------------------------------------------------- C THRESM is used to C accelerate symolic factorization C THRESM is dynamically updated to C allow more quasi-dense row selection C ThresPrev holds last starting value C at the beginning of one iteration C ThresMin holds minimum value of THRESH INTEGER :: FDEG, ThresMin, ThresPrev, IBEGSchur, NbSchur, & ThresMinINIT INTEGER :: DEGMAX,THD, THDperm, THD_AGG DOUBLE PRECISION :: RELDEN LOGICAL :: AGG6_loc, DenseRows LOGICAL :: SchurON INTEGER :: DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, ME, MINDEG, NEL, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X INTEGER KNT1_UPDATED, KNT2_UPDATED INTEGER :: SIZE_SCHUR_LOC INTEGER(8) MAXMEM, MEM, NEWMEM INTEGER :: MAXINT_N INTEGER(8) :: HASH, HMOD LOGICAL :: COMPRESS C deg: the degree of a variable or element C degme: size, |Lme|, of the current element, me (= degree (me)) C dext: external degree, |Le \ Lme|, of some element e C dmax: largest |Le| seen so far C e: an element C elenme: the length, elen (me), of element list of pivotal var. C eln: the length, elen (...), of an element list C hash: the computed value of the hash function C hmod: the hash function is computed modulo hmod = max (1,n-1) C i: a supervariable C ilast: the entry in a link list preceding i C inext: the entry in a link list following i C j: a supervariable C jlast: the entry in a link list preceding j C jnext: the entry in a link list, or path, following j C k: the pivot order of an element or variable C knt1: loop counter used during element construction C knt2: loop counter used during element construction C knt3: loop counter used during compression C lenj: len (j) C ln: length of a supervariable list C maxint_n: large integer to test risk of overflow on wflg C maxmem: amount of memory needed for no compressions C me: current supervariable being eliminated, and the C current element created by eliminating that C supervariable C mem: memory in use assuming no compressions have occurred C mindeg: current minimum degree C nel: number of pivots selected so far C newmem: amount of new memory needed for current pivot element C nleft: n - nel, the number of nonpivotal rows/columns remaining C nvi: the number of variables in a supervariable i (= nv (i)) C nvj: the number of variables in a supervariable j (= nv (j)) C nvpiv: number of pivots in current element C slenme: number of variables in variable list of pivotal variable C we: w (e) C wflg: used for flagging the w array. See description of iw. C wnvi: wflg - nv (i) C x: either a supervariable or an element C----------------------------------------------------------------------- C LOCAL POINTERS: C----------------------------------------------------------------------- INTEGER(8) P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, & PN, PSRC, PLN, PELN C Any parameter (pe (...) or pfree) or local variable C starting with "p" (for Pointer) is an index into iw, C and all indices into iw use variables starting with C "p." The only exception to this rule is the iwlen C input argument. C p: pointer into lots of things C p1: pe (i) for some variable i (start of element list) C p2: pe (i) + elen (i) - 1 for some var. i (end of el. list) C p3: index of first supervariable in clean list C pdst: destination pointer, for compression C pend: end of memory to compress C pj: pointer into an element or variable C pme: pointer into the current element (pme1...pme2) C pme1: the current element, me, is stored in iw (pme1...pme2) C pme2: the end of the current element C pn: pointer into a "clean" variable, also used to compress C psrc: source pointer, for compression C----------------------------------------------------------------------- C FUNCTIONS CALLED: C----------------------------------------------------------------------- INTRINSIC max, min, mod, maxval C======================================================================= C INITIALIZATIONS C======================================================================= IF (N.EQ.1) THEN ELEN(1) = 1 LAST(1) = 1 PE(1) = 0_8 IF (NV(1).LT.0) NV(1) = 1 NCMPA = 0 PARENT(1) = 0 RETURN ENDIF AGG6_loc = AGG6 DenseRows = .FALSE. C C We can now assume that N>1 C CSymbolic Intialize degrees with the order given by PERM C SIZE_SCHUR_LOC = SIZE_SCHUR SIZE_SCHUR_LOC = min(N,SIZE_SCHUR_LOC) SIZE_SCHUR_LOC = max(0,SIZE_SCHUR_LOC) SchurON = (SIZE_SCHUR_LOC > 0) IBEGSchur = N-SIZE_SCHUR_LOC+1 THRESM = THRESH ! local value of THRESH IF (THRESM.GT.N) THRESM = N IF (THRESM.LT.0) THRESM = 0 C Variables in the schur are considered as exactly dense C (Schur variables are ordered last, we check it here) IF ( SchurON ) THEN DO I= 1, N IF ( PERM(I) .GE. IBEGSchur) THEN PERM(I) = N + 1 C Because of compress, we force skipping this C entry which is anyway empty IF (LEN(I) .EQ.0) THEN PE(I) = 0_8 ENDIF ENDIF ENDDO ENDIF C IF (SchurON) THEN C C Only restriction is n>= THRESM > 0 C C only exactly dense row will be selected C It should also work ok combined to C quasi dense row selection. C (To be Tested it seperately) THRESM = N ThresMin = N ThresPrev = N ELSE THRESM = max(int(31*N/32),THRESM) THRESM = max(THRESM,1) C DEGMAX= maxval(LEN) RELDEN=dble(PFREE-1)/dble(N) THD = int(RELDEN)*10 + (DEGMAX-int(RELDEN))/10 + 1 IF (THD.LT.DEGMAX) THEN DenseRows = .TRUE. THDperm = N DO I = 1,N IF (LEN(I) .GT. THD) THEN THDperm = min(THDperm,PERM(I)) ENDIF ENDDO THRESM = min(THRESM, THDperm) ENDIF C Compute ThresMin and initialise ThresPrev ThresMin = max( 3*THRESM / 4, 1) ThresPrev = THRESM C ENDIF ! test on SchurON C ThresMinINIT = ThresMin/4 THD_AGG = max(128, min(TOTEL/2048, 1024)) IF (THRESM.GT.0) THEN IF ((THRESM.GT.N).OR.(THRESM.LT.2)) THEN C exactly dense rows only THRESM = N ENDIF ENDIF LASTD = 0 NBD = 0 NBED = 0 NBDM = 0 WFLG = 2 MAXINT_N=huge(WFLG)-TOTEL MINDEG = 1 NCMPA = 0 NEL = 0 HMOD = int(max (1, N-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM DO I = 1, N NDENSE(I)= 0 W (I) = 1 ELEN (I) = 0 C NV (I) = 1 C DEGREE (I) = LEN (I) ENDDO DO I=1, N LAST (I) = 0 HEAD (I) = 0 ENDDO C initialize degree IF(NV(1) .LT. 0) THEN COMPRESS = .FALSE. ELSE COMPRESS = .TRUE. ENDIF IF (COMPRESS) THEN DO I=1,N DEGREE(I) = 0 DO P= PE(I) , PE(I)+int(LEN(I)-1,8) DEGREE(I) = DEGREE(I) + NV(IW(P)) ENDDO ENDDO ELSE DO I=1,N NV(I) = 1 DEGREE (I) = LEN (I) ENDDO ENDIF C ---------------------------------------------------------------- C initialize degree lists and eliminate rows with no off-diag. nz. C ---------------------------------------------------------------- DO 20 I = 1, N DEG = DEGREE (I) IF (PERM(I).EQ.N) THEN C save that I is last in the order PERMeqN = I PERM(I) = N-1 ENDIF FDEG = PERM(I) IF ( (DEG .GT. 0).OR.(PERM(I).EQ.N+1) ) THEN C ---------------------------------------------------------- C place i in the degree list corresponding to its degree C or in the dense row list if i is dense or quasi dense. C ---------------------------------------------------------- C test for row density IF ( (THRESM.GT.0) .AND. & (FDEG .GT.THRESM) ) THEN C I will be inserted in the degree list of N NBD = NBD+NV(I) IF (FDEG.NE.N+1) THEN C DEGREE(I) = DEGREE(I)+TOTEL+2 C insert I at the beginning of degree list of n DEG = N INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I LAST(I) = 0 IF (LASTD.EQ.0) LASTD=I ELSE C Only Schur variables are concerned here C Property: LISTVAR_SCHUR (1) will C be first in the list of schur variables NBED = NBED+NV(I) DEGREE(I) = TOTEL+1 C insert I at the end of degree list of n DEG = N IF (LASTD.EQ.0) THEN C degree list is empty LASTD = I HEAD(DEG) = I NEXT(I) = 0 LAST(I) = 0 ELSE NEXT(LASTD) = I LAST(I) = LASTD LASTD = I NEXT(I) = 0 ENDIF ENDIF ELSE C place i in the degree list corresponding to its degree INEXT = HEAD (FDEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (FDEG) = I ENDIF ELSE C ---------------------------------------------------------- C we have a variable that can be eliminated at once because C there is no off-diagonal non-zero in its row. C ---------------------------------------------------------- NEL = NEL + NV(I) ELEN (I) = -NEL PE (I) = 0_8 W (I) = 0 ENDIF 20 CONTINUE C We suppress dense row selection if none of them was found in A C in the 1st pass IF ((NBD.EQ.0).AND.(THRESM.GT.0)) THRESM = N C C======================================================================= C WHILE (selecting pivots) DO C======================================================================= 30 IF (NEL .LT. TOTEL) THEN C======================================================================= C GET PIVOT OF MINIMUM DEGREE C======================================================================= C ------------------------------------------------------------- C find next supervariable for elimination C ------------------------------------------------------------- DO 40 DEG = MINDEG, N ME = HEAD (DEG) IF (ME .GT. 0) GO TO 50 40 CONTINUE 50 MINDEG = DEG C ------------------------------------------------------------- C We want to respect the ordering provided by the user C Therefefore if (DEG > THRESM .and. NBD.ge.0) then C A quasi-dense variable might have a perm value C smaller than ME. C We thus in this case force restarting. C ------------------------------------------------------------- IF ( (DEG.NE.N) .AND. & (DEG.GT.THRESM+1) .AND. (NBD.GT.0) ) THEN MINDEG = N GOTO 30 ENDIF IF (DEGREE(ME).LE.TOTEL) THEN C ------------------------------------------------------------- C remove chosen variable from link list C ------------------------------------------------------------- INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT ELSE C C Because of restarting forced even if C variable (not yet quasi dense) but of C value of perm larger than thresm still C to be eliminated we have to reset MINDEB to 1 MINDEG = 1 NBDM = max(NBDM,NBD) IF (DEGREE(ME).GT.TOTEL+1) THEN IF (WFLG .GT. MAXINT_N) THEN DO 52 X = 1, N IF (W (X) .NE. 0) W (X) = 1 52 CONTINUE WFLG = 2 ENDIF WFLG = WFLG + 1 51 CONTINUE C --------------------------------------------------------- C remove chosen variable from link list C --------------------------------------------------------- INEXT = NEXT (ME) IF (INEXT .NE. 0) THEN LAST (INEXT) = 0 ELSE LASTD = 0 ENDIF C ---------------------------------------------------------- c build adjacency list of ME in quotient gragh C and calculate its external degree in ndense(me) C ---------------------------------------------------------- NDENSE(ME) = 0 W(ME) = WFLG P1 = PE(ME) P2 = P1 + int(LEN(ME) -1,8) C PLN-1 holds the pointer in IW to the last elet/var in adj list C of ME. LEN(ME) will then be set to PLN-P1 C PELN-1 hold the pointer in IW to the last elet in in adj list C of ME. ELEN(ME) will then be set to PELN-P1 C element adjacent to ME PLN = P1 PELN = P1 DO 55 P=P1,P2 E= IW(P) IF (W(E).EQ.WFLG) GOTO 55 W(E) = WFLG IF (PE(E).LT.0_8) THEN C E is a nonprincipal variable or absorbed element X = E 53 X = int(-PE(X)) IF (W(X) .EQ.WFLG) GOTO 55 W(X) = WFLG IF ( PE(X) .LT. 0_8 ) GOTO 53 E = X ENDIF C ------------------------------------------- C E is an unabsorbed element or a "dense" row C (NOT already flagged) C ------------------------------------------- IF (ELEN(E).LT.0) THEN C E is a new element in adj(ME) NDENSE(E) = NDENSE(E) - NV(ME) IW(PLN) = IW(PELN) IW(PELN) = E PLN = PLN+1_8 PELN = PELN + 1_8 C update ndense of ME with all unflagged dense C rows in E PME1 = PE(E) DO 54 PME = PME1, PME1+int(LEN(E)-1,8) X = IW(PME) IF ((ELEN(X).GE.0).AND.(W(X).NE.WFLG)) THEN C X is a dense row NDENSE(ME) = NDENSE(ME) + NV(X) W(X) = WFLG ENDIF 54 CONTINUE ELSE C E is a dense row NDENSE(ME) = NDENSE(ME) + NV(E) IW(PLN)=E PLN = PLN+1_8 ENDIF 55 CONTINUE C ---------------------------------------------- C DEGREE(ME)-(TOTEL+2) holds last external degree computed C when Me was detected as dense C NDENSE(ME) is the exact external degree of ME C ---------------------------------------------- WFLG = WFLG + 1 LEN(ME) = int(PLN-P1) ELEN(ME) = int(PELN-P1) NDME = NDENSE(ME)+NV(ME) IF (NDENSE(ME).EQ.0) NDENSE(ME) =1 C --------------------------------------------------------- C place ME in the degree list of NDENSE(ME), update DEGREE C --------------------------------------------------------- DEGREE(ME) = NDENSE(ME) DEG = PERM(ME) MINDEG = min(DEG,MINDEG) JNEXT = HEAD(DEG) IF (JNEXT.NE. 0) LAST (JNEXT) = ME NEXT(ME) = JNEXT HEAD(DEG) = ME C ------------------------------ C process next quasi dense row C ------------------------------ ME = INEXT IF (ME.NE.0) THEN IF (DEGREE(ME).GT.(TOTEL+1) ) GOTO 51 ENDIF HEAD (N) = ME C --------------------------------------- C update dense row selection strategy C ------------------------------------- IF (THRESM.LT.N) THEN ThresMin = max(THRESM+ThresMin,ThresPrev+ThresMin/2+1) ThresMin = min(ThresMin, N) ThresPrev = ThresPrev+(N-ThresPrev)/2+ThresMinINIT THRESM = max( & THRESM + int(sqrt(dble(ThresMin)))+ ThresMinINIT , & ThresPrev) THRESM = min(THRESM,N) ThresMin = min(THRESM, ThresMin) ThresPrev = THRESM ENDIF NBD = NBED C get back to Min degree elimination loop C GOTO 30 ENDIF C ------------------------------------------------------------- C ------------------------------------------------------------- IF (DEGREE(ME).EQ.TOTEL+1) THEN C we have only exactly "dense" rows that we C amalgamate at the root node IF (NBD.NE.NBED) THEN write(6,*) ' ERROR in MUMPS_SYMQAMD quasi dense rows remains' CALL MUMPS_ABORT() ENDIF NbSchur = 0 ! Only for checking NELME = -(NEL+1) DO 59 X=1,N IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN C X is an unabsorbed element C -- Force sons to be linked to first node in Schur PE(X) = int(-LISTVAR_SCHUR(1),8) C W(X) = 0 could be suppressed ?? check it ELSEIF (DEGREE(X).EQ.TOTEL+1) THEN C X is a dense row, absorb it in ME (mass elimination) NEL = NEL + NV(X) PE(X) = int(-ME,8) ELEN(X) = 0 NV(X) = 0 NbSchur = NbSchur+ 1 ENDIF 59 CONTINUE IF (NbSchur.NE.SIZE_SCHUR_LOC) then write(6,*) ' Internal error 2 in MUMPS_SYMQAMD:', & ' Schur size expected:',SIZE_SCHUR_LOC, 'Real:', NbSchur CALL MUMPS_ABORT() ENDIF C ME is the root node ELEN(ME) = NELME NV(ME) = NBD PE(ME) = 0_8 IF (NEL.NE.N) THEN write(6,*) 'Internal error 3 detected in MUMPS_SYMQAMD:' write(6,*) ' NEL not equal to N: N, NEL =',N,NEL CALL MUMPS_ABORT() ENDIF IF (ME.NE. LISTVAR_SCHUR(1)) THEN C -- Set all node in Schur list to point to LISTVAR_SCHUR(1) DO I=1, SIZE_SCHUR_LOC PE(LISTVAR_SCHUR(I)) = int(-LISTVAR_SCHUR(1),8) ENDDO PE(LISTVAR_SCHUR(1)) = 0_8 NV( LISTVAR_SCHUR(1))= NV(ME) NV(ME) = 0 ELEN( LISTVAR_SCHUR(1)) = ELEN(ME) ELEN(ME) = 0 ENDIF GOTO 265 ENDIF ENDIF C ------------------------------------------------------------- C me represents the elimination of pivots nel+1 to nel+nv(me). C place me itself as the first in this set. It will be moved C to the nel+nv(me) position when the permutation vectors are C computed. C ------------------------------------------------------------- ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV NDENSE(ME) = 0 C======================================================================= C CONSTRUCT NEW ELEMENT C======================================================================= C ------------------------------------------------------------- C At this point, me is the pivotal supervariable. It will be C converted into the current element. Scan list of the C pivotal supervariable, me, setting tree pointers and C constructing new list of supervariables for the new element, C me. p is a pointer to the current position in the old list. C ------------------------------------------------------------- C flag the variable "me" as being in Lme by negating nv (me) NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN C ---------------------------------------------------------- C construct the new element in place C ---------------------------------------------------------- PME1 = PE (ME) PME2 = PME1 - 1 DO 60 P = PME1, PME1 + int(LEN (ME) - 1,8) I = IW (P) NVI = NV (I) IF (NVI .GT. 0) THEN C ---------------------------------------------------- C i is a principal variable not yet placed in Lme. C store i in new list C ---------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I C ---------------------------------------------------- C remove variable i from degree list. C ---------------------------------------------------- C only done for non "dense" rows IF (DEGREE(I).LE.TOTEL) THEN ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (PERM(I)) = INEXT ENDIF ELSE NDENSE(ME) = NDENSE(ME) + NVI ENDIF ENDIF 60 CONTINUE C this element takes no new memory in iw: NEWMEM = 0 ELSE C ---------------------------------------------------------- C construct the new element in empty space, iw (pfree ...) C ---------------------------------------------------------- P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME KNT1_UPDATED = 0 DO 120 KNT1 = 1, ELENME + 1 KNT1_UPDATED = KNT1_UPDATED +1 IF (KNT1 .GT. ELENME) THEN C search the supervariables in me. E = ME PJ = P LN = SLENME ELSE C search the elements in me. E = IW (P) P = P + 1 PJ = PE (E) LN = LEN (E) ENDIF C ------------------------------------------------------- C search for different supervariables and add them to the C new list, compressing when necessary. this loop is C executed once for each element in the list and once for C all the supervariables in the list. C ------------------------------------------------------- KNT2_UPDATED = 0 DO 110 KNT2 = 1, LN KNT2_UPDATED = KNT2_UPDATED+1 I = IW (PJ) PJ = PJ + 1 NVI = NV (I) IF (NVI .GT. 0) THEN C ------------------------------------------------- C compress iw, if necessary C ------------------------------------------------- IF (PFREE .GT. IWLEN) THEN C prepare for compressing iw by adjusting C pointers and lengths so that the lists being C searched in the inner and outer loops contain C only the remaining entries. PE (ME) = P LEN (ME) = LEN (ME) - KNT1_UPDATED C Reset KNT1_UPDATED in case of recompress C at same iteration of the loop 120 KNT1_UPDATED = 0 C Check if anything left in supervariable ME IF (LEN (ME) .EQ. 0) PE (ME) = 0 PE (E) = PJ LEN (E) = LN - KNT2_UPDATED C Reset KNT2_UPDATED in case of recompress C at same iteration of the loop 110 KNT2_UPDATED = 0 C Check if anything left in element E IF (LEN (E) .EQ. 0) PE (E) = 0 NCMPA = NCMPA + 1 C store first item in pe C set first entry to -item DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = int(IW (PN),8) IW (PN) = -J ENDIF 70 CONTINUE C psrc/pdst point to source/destination PDST = 1 PSRC = 1 PEND = PME1 - 1 C while loop: 80 CONTINUE IF (PSRC .LE. PEND) THEN C search for next negative entry J = -IW (PSRC) PSRC = PSRC + 1 IF (J .GT. 0) THEN IW (PDST) = int(PE (J)) PE (J) = PDST PDST = PDST + 1 C copy from source to destination LENJ = LEN (J) DO 90 KNT3 = 0, LENJ - 2 IW (PDST + KNT3) = IW (PSRC + KNT3) 90 CONTINUE PDST = PDST + LENJ - 1 PSRC = PSRC + LENJ - 1 ENDIF GO TO 80 ENDIF C move the new partially-constructed element P1 = PDST DO 100 PSRC = PME1, PFREE - 1 IW (PDST) = IW (PSRC) PDST = PDST + 1 100 CONTINUE PME1 = P1 PFREE = PDST PJ = PE (E) P = PE (ME) ENDIF C ------------------------------------------------- C i is a principal variable not yet placed in Lme C store i in new list C ------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI IW (PFREE) = I PFREE = PFREE + 1 C ------------------------------------------------- C remove variable i from degree link list C ------------------------------------------------- C only done for non "dense" rows IF (DEGREE(I).LE.TOTEL) THEN ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (PERM(I)) = INEXT ENDIF ELSE NDENSE(ME) = NDENSE(ME) + NVI ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN C set tree pointer and flag to indicate element e is C absorbed into new element me (the parent of e is me) PE (E) = int(-ME,8) W (E) = 0 ENDIF 120 CONTINUE PME2 = PFREE - 1 C this element takes newmem new memory in iw (possibly zero) NEWMEM = PFREE - PME1 MEM = MEM + NEWMEM MAXMEM = max (MAXMEM, MEM) ENDIF C ------------------------------------------------------------- C me has now been converted into an element in iw (pme1..pme2) C ------------------------------------------------------------- C degme holds the external degree of new element DEGREE (ME) = DEGME PE (ME) = PME1 LEN (ME) = int(PME2 - PME1 + 1_8) C ------------------------------------------------------------- C make sure that wflg is not too large. With the current C value of wflg, wflg+n must not cause integer overflow C ------------------------------------------------------------- IF (WFLG .GT. MAXINT_N) THEN DO 130 X = 1, N IF (W (X) .NE. 0) W (X) = 1 130 CONTINUE WFLG = 2 ENDIF C======================================================================= C COMPUTE (w (e) - wflg) = |Le\Lme| FOR ALL ELEMENTS Cdense C COMPUTE (w(e) - wflg) = |Le(G')\Lme(G')| FOR ALL ELEMENTS C where G' is the subgraph of G excluding ''dense" rows) Cdense C======================================================================= C ------------------------------------------------------------- C Scan 1: compute the external degrees of previous elements C with respect to the current element. That is: C (w (e) - wflg) = |Le \ Lme| C for each element e that appears in any supervariable in Lme. C The notation Le refers to the pattern (list of C supervariables) of a previous element e, where e is not yet C absorbed, stored in iw (pe (e) + 1 ... pe (e) + iw (pe (e))). C The notation Lme refers to the pattern of the current element C (stored in iw (pme1..pme2)). If (w (e) - wflg) becomes C zero, then the element e will be absorbed in scan 2. C aggressive absorption is possible only if NDENSE(ME) = NBD C which is true when only exactly dense rows have been selected. C ------------------------------------------------------------- DO 150 PME = PME1, PME2 I = IW (PME) IF (DEGREE(I).GT.TOTEL) GOTO 150 ELN = ELEN (I) IF (ELN .GT. 0) THEN C note that nv (i) has been negated to denote i in Lme: NVI = -NV (I) WNVI = WFLG - NVI DO 140 P = PE (I), PE (I) + int(ELN - 1,8) E = IW (P) WE = W (E) IF (WE .GE. WFLG) THEN C unabsorbed element e has been seen in this loop WE = WE - NVI ELSE IF (WE .NE. 0) THEN C e is an unabsorbed element C this is the first we have seen e in all of Scan 1 WE = DEGREE (E) + WNVI - NDENSE(E) Cn dense ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE C======================================================================= C DEGREE UPDATE AND ELEMENT ABSORPTION C======================================================================= C ------------------------------------------------------------- C Scan 2: for each i in Lme, sum up the degree of Lme (which C is degme), plus the sum of the external degrees of each Le C for the elements e appearing within i, plus the C supervariables in i. Place i in hash list. C ------------------------------------------------------------- AGG6_loc = (AGG6 .OR. (DEGREE(ME) .LT. THD_AGG)) DO 180 PME = PME1, PME2 I = IW (PME) IF (DEGREE(I).GT.TOTEL) GOTO 180 P1 = PE (I) P2 = P1 + int(ELEN (I) - 1,8) PN = P1 HASH = 0_8 DEG = 0 C ---------------------------------------------------------- C scan the element list associated with supervariable i C ---------------------------------------------------------- DO 160 P = P1, P2 E = IW (P) C dext = | Le \ Lme | DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN DEG = DEG + DEXT IW (PN) = E PN = PN + 1_8 HASH = HASH + int(E,kind=8) C ------------------------------ C suppress aggressive absorption C ------------------------------ ELSE IF (.NOT. AGG6_loc .AND. DEXT .EQ. 0) THEN IW (PN) = E PN = PN + 1_8 HASH = HASH + int(E,kind=8) C C ------------------------------ C try aggressive absorption C when possible ELSE IF (AGG6_loc .AND. (DEXT .EQ. 0) .AND. & ((NDENSE(ME).EQ.NBD).OR.(NDENSE(E).EQ.0))) THEN C aggressive absorption: e is not adjacent to me, but C |Le(G') \ Lme(G')| is 0 and all dense rows C are in me, so absorb it into me PE (E) = int(-ME,8) W (E) = 0 ELSE IF (AGG6_loc .AND. DEXT.EQ.0) THEN IW(PN) = E PN = PN+1 HASH = HASH + int(E,kind=8) ENDIF 160 CONTINUE C count the number of elements in i (including me): ELEN (I) = int(PN - P1 + 1) C ---------------------------------------------------------- C scan the supervariables in the list associated with i C ---------------------------------------------------------- P3 = PN DO 170 P = P2 + 1, P1 + int(LEN (I) - 1,8) J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN C j is unabsorbed, and not in Lme. C add to degree and add to new list C add degree only of non-dense rows. IF (DEGREE(J).LE.TOTEL) DEG=DEG+NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE C ---------------------------------------------------------- C update the degree and check for mass elimination C ---------------------------------------------------------- IF (((ELEN(I).EQ.1).AND.(P3.EQ.PN)) & .OR. & (AGG6_loc.AND.(DEG .EQ. 0).AND.(NDENSE(ME).EQ.NBD)) & ) & THEN C ------------------------------------------------------- C mass elimination C ------------------------------------------------------- C There is nothing left of this node except for an C edge to the current pivot element. elen (i) is 1, C and there are no variables adjacent to node i. C Absorb i into the current pivot element, me. PE (I) = int(-ME,8) NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE C ------------------------------------------------------- C update the upper-bound degree of i C ------------------------------------------------------- C the following degree does not yet include the size C of the current element, which is added later: DEGREE(I) = min (DEG+NBD-NDENSE(ME), & DEGREE(I)) C ------------------------------------------------------- C add me to the list for i C ------------------------------------------------------- C move first supervariable to end of list IW (PN) = IW (P3) C move first element to end of element part of list IW (P3) = IW (P1) C add new element to front of list. IW (P1) = ME C store the new length of the list in len (i) LEN (I) = int(PN - P1 + 1) C ------------------------------------------------------- C place in hash bucket. Save hash key of i in last (i). C ------------------------------------------------------- HASH = mod (HASH, HMOD) + 1_8 J = HEAD (HASH) IF (J .LE. 0) THEN C the degree list is empty, hash head is -j NEXT (I) = -J HEAD (HASH) = -I ELSE C degree list is not empty C use last (head (hash)) as hash head NEXT (I) = LAST (J) LAST (J) = I ENDIF LAST (I) = int(HASH,kind=kind(LAST)) ENDIF 180 CONTINUE DEGREE (ME) = DEGME C ------------------------------------------------------------- C Clear the counter array, w (...), by incrementing wflg. C ------------------------------------------------------------- DMAX = max (DMAX, DEGME) WFLG = WFLG + DMAX C make sure that wflg+n does not cause integer overflow IF (WFLG .GT. MAXINT_N) THEN DO 190 X = 1, N IF (W (X) .NE. 0) W (X) = 1 190 CONTINUE WFLG = 2 ENDIF C at this point, w (1..n) .lt. wflg holds C======================================================================= C SUPERVARIABLE DETECTION C======================================================================= DO 250 PME = PME1, PME2 I = IW (PME) IF ( (NV(I).LT.0) .AND. (DEGREE(I).LE.TOTEL) ) THEN C only done for nondense rows C i is a principal variable in Lme C ------------------------------------------------------- C examine all hash buckets with 2 or more variables. We C do this by examing all unique hash keys for super- C variables in the pattern Lme of the current element, me C ------------------------------------------------------- HASH = int(LAST (I),kind=8) C let i = head of hash bucket, and empty the hash bucket J = HEAD (HASH) IF (J .EQ. 0) GO TO 250 IF (J .LT. 0) THEN C degree list is empty I = -J HEAD (HASH) = 0 ELSE C degree list is not empty, restore last () of head I = LAST (J) LAST (J) = 0 ENDIF IF (I .EQ. 0) GO TO 250 C while loop: 200 CONTINUE IF (NEXT (I) .NE. 0) THEN X = I C ---------------------------------------------------- C this bucket has one or more variables following i. C scan all of them to see if i can absorb any entries C that follow i in hash bucket. Scatter i into w. C ---------------------------------------------------- LN = LEN (I) ELN = ELEN (I) C do not flag the first element in the list (me) DO 210 P = PE (I) + 1, PE (I) + int(LN - 1,8) W (IW (P)) = WFLG 210 CONTINUE C ---------------------------------------------------- C scan every other entry j following i in bucket C ---------------------------------------------------- JLAST = I J = NEXT (I) C while loop: 220 CONTINUE IF (J .NE. 0) THEN C ------------------------------------------------- C check if j and i have identical nonzero pattern C ------------------------------------------------- C jump if i and j do not have same size data structure IF (LEN (J) .NE. LN) GO TO 240 C jump if i and j do not have same number adj elts IF (ELEN (J) .NE. ELN) GO TO 240 C do not flag the first element in the list (me) DO 230 P = PE (J) + 1, PE (J) + int(LN - 1,8) C jump if an entry (iw(p)) is in j but not in i IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE C ------------------------------------------------- C found it! j can be absorbed into i C ------------------------------------------------- IF (PERM(J).GT.PERM(X)) THEN ! J is absorbed by X PE (J) = int(-X,8) NV (X) = NV (X) + NV (J) NV (J) = 0 ELEN (J) = 0 ELSE ! X is absorbed by J PE (X) = int(-J,8) NV (J) = NV (X) + NV (J) NV (X) = 0 ELEN (X) = 0 X = J ENDIF C both nv (i) and nv (j) are negated since they C are in Lme, and the absolute values of each C are the number of variables in i and j: C delete j from hash bucket J = NEXT (J) NEXT (JLAST) = J GO TO 220 C ------------------------------------------------- 240 CONTINUE C j cannot be absorbed into i C ------------------------------------------------- JLAST = J J = NEXT (J) GO TO 220 ENDIF C ---------------------------------------------------- C no more variables can be absorbed into i C go to next i in bucket and clear flag array C ---------------------------------------------------- WFLG = WFLG + 1 I = NEXT (I) IF (I .NE. 0) GO TO 200 ENDIF ENDIF 250 CONTINUE C======================================================================= C RESTORE DEGREE LISTS AND REMOVE NONPRINCIPAL SUPERVAR. FROM ELEMENT C======================================================================= C ------------------------------ C Update thresm for having more C quasi dense rows to select C ------------------------------ IF ( .NOT.DenseRows.AND.(THRESM .GT. 0).AND.(THRESM.LT.N) ) & THEN THRESM = max(ThresMin, THRESM-NVPIV) ENDIF P = PME1 NLEFT = TOTEL - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN C i is a principal variable in Lme C restore nv (i) to signify that i is principal NV (I) = NVI IF (DEGREE(I).LE.TOTEL) THEN C ------------------------------------------------------- C compute the external degree (add size of current elem) C ------------------------------------------------------- DEG = min (DEGREE (I)+ DEGME - NVI, NLEFT - NVI) DEGREE (I) = DEG IDENSE = .FALSE. C C ------------------- C Dense row detection C ------------------- IF (THRESM.GT.0) THEN IF (PERM(I) .GT. THRESM) THEN C relaxed dense row detection IDENSE = .TRUE. C DEGREE(I) = DEGREE(I)+TOTEL+2 ENDIF IF (IDENSE) THEN C update NDENSE of all elements in the list of element C adjacent to I (including ME). P1 = PE(I) P2 = P1 + int(ELEN(I) - 1,8) IF (P2.GE.P1) THEN DO 264 PJ=P1,P2 E= IW(PJ) NDENSE (E) = NDENSE(E) + NVI 264 CONTINUE ENDIF C insert I in the list of dense rows NBD = NBD+NVI FDEG = N DEG = N C insert I at the beginning of the list INEXT = HEAD(DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I LAST(I) = 0 IF (LASTD.EQ.0) LASTD=I C end of IDENSE=true ENDIF C end of THRESM>0 ENDIF C IF (.NOT.IDENSE) THEN FDEG = PERM(I) C ------------------------------------------------------- C place the supervariable at the head of the degree list C ------------------------------------------------------- INEXT = HEAD (FDEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (FDEG) = I ENDIF C ------------------------------------------------------- C save the new degree, and find the minimum degree C ------------------------------------------------------- MINDEG = min (MINDEG, FDEG) ENDIF C ------------------------------------------------------- C place the supervariable in the element pattern C ------------------------------------------------------- IW (P) = I P = P + 1 ENDIF 260 CONTINUE C======================================================================= C FINALIZE THE NEW ELEMENT C======================================================================= NV (ME) = NVPIV + DEGME C nv (me) is now the degree of pivot (including diagonal part) C save the length of the list for the new element me LEN (ME) = int(P - PME1) IF (LEN (ME) .EQ. 0) THEN C there is nothing left of the current pivot element PE (ME) = 0_8 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN C element was not constructed in place: deallocate part C of it (final size is less than or equal to newmem, C since newly nonprincipal variables have been removed). PFREE = P MEM = MEM - NEWMEM + int(LEN (ME),8) ENDIF C======================================================================= C END WHILE (selecting pivots) GO TO 30 ENDIF C======================================================================= 265 CONTINUE C======================================================================= C COMPUTE THE PERMUTATION VECTORS C======================================================================= C ---------------------------------------------------------------- C The time taken by the following code is O(n). At this C point, elen (e) = -k has been done for all elements e, C and elen (i) = 0 has been done for all nonprincipal C variables i. At this point, there are no principal C supervariables left, and all elements are absorbed. C ---------------------------------------------------------------- C ---------------------------------------------------------------- C compute the ordering of unordered nonprincipal variables C ---------------------------------------------------------------- DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN C ---------------------------------------------------------- C i is an un-ordered row. Traverse the tree from i until C reaching an element, e. The element, e, was the C principal supervariable of i and all nodes in the path C from i to when e was selected as pivot. C ---------------------------------------------------------- J = int(-PE (I)) C while (j is a variable) do: 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = int(-PE (J)) GO TO 270 ENDIF E = J C ---------------------------------------------------------- C get the current pivot ordering of e C ---------------------------------------------------------- K = -ELEN (E) C ---------------------------------------------------------- C traverse the path again from i to e, and compress the C path (all nodes point to e). Path compression allows C this code to compute in O(n) time. Order the unordered C nodes in the path, and place the element e at the end. C ---------------------------------------------------------- J = I C while (j is a variable) do: 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = int(-PE (J)) PE (J) = int(-E,8) IF (ELEN (J) .EQ. 0) THEN C j is an unordered row ELEN (J) = K K = K + 1 ENDIF J = JNEXT GO TO 280 ENDIF C leave elen (e) negative, so we know it is an element ELEN (E) = -K ENDIF 290 CONTINUE C ---------------------------------------------------------------- C reset the inverse permutation (elen (1..n)) to be positive, C and compute the permutation (last (1..n)). C ---------------------------------------------------------------- DO 300 I = 1, N K = abs (ELEN (I)) C LAST (K) = I C LAST (K) = I ELEN (I) = K 300 CONTINUE IF (.NOT.SchurON) THEN C ----------------------------- C restore PERM(I)=N for PERMeqN C ----------------------------- PERM(PERMeqN) = N ENDIF C======================================================================= C RETURN THE MEMORY USAGE IN IW C======================================================================= C If maxmem is less than or equal to iwlen, then no compressions C occurred, and iw (maxmem+1 ... iwlen) was unused. Otherwise C compressions did occur, and iwlen would have had to have been C greater than or equal to maxmem for no compressions to occur. C Return the value of maxmem in the pfree argument. PFREE = MAXMEM C=============================== C Save PE in PARENT array DO I=1,N PARENT(I) = int(PE(I)) ENDDO C=============================== RETURN END SUBROUTINE MUMPS_SYMQAMD MUMPS_5.8.1/src/csol_driver.F0000664000175000017500000100677015042446441015666 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SOLVE_DRIVER(id,idintr) USE CMUMPS_STRUC_DEF USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_INTR_STRUC USE CMUMPS_SOL_ES C Lock Initialization (_LI) and Desruction (_LD) USE MUMPS_SOL_L0OMP_M, ONLY: MUMPS_SOL_L0OMP_LI, & MUMPS_SOL_L0OMP_LD C C Purpose C ======= C C Performs solution phase (solve), Iterative Refinements C and Error analysis. C C c C USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_ALLOC_SMALL_BUF, & MUMPS_BUF_ALLOC_CB, MUMPS_BUF_INIT, & MUMPS_BUF_DEALL_CB, & MUMPS_BUF_DEALL_SMALL_BUF USE CMUMPS_OOC USE MUMPS_MEMORY_MOD USE CMUMPS_LR_DATA_M, only : CMUMPS_BLR_STRUC_TO_MOD & , CMUMPS_BLR_MOD_TO_STRUC USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_MOD_TO_STRUC #if ! defined(NO_SAVE_RESTORE) USE CMUMPS_SAVE_RESTORE #endif !$ USE OMP_LIB IMPLICIT NONE C ------------------- C Explicit interfaces C ------------------- INTERFACE SUBROUTINE CMUMPS_SIZE_IN_STRUCT( id, idintr, & NB_INT,NB_CMPLX,NB_CHAR ) USE CMUMPS_STRUC_DEF, ONLY: CMUMPS_STRUC USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_INTR_STRUC TYPE (CMUMPS_STRUC) :: id TYPE (CMUMPS_INTR_STRUC) :: idintr INTEGER(8) :: NB_INT,NB_CMPLX,NB_CHAR END SUBROUTINE CMUMPS_SIZE_IN_STRUCT SUBROUTINE CMUMPS_CHECK_DENSE_RHS &(idRHS, idINFO, idN, idNRHS, idLRHS) COMPLEX, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE CMUMPS_CHECK_DENSE_RHS END INTERFACE C INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' #if defined(V_T) INCLUDE 'VT.inc' #endif INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 C C Parameters C ========== C TYPE (CMUMPS_STRUC), TARGET :: id TYPE (CMUMPS_INTR_STRUC) :: idintr C C Local variables C =============== C INTEGER MP,LP, MPG LOGICAL PROK, PROKG, LPOK INTEGER MTYPE, ICNTL21 LOGICAL LSCAL, POSTPros, GIVSOL INTEGER ICNTL10, ICNTL11, ICNTL48_EFF INTEGER I,K,JPERM, J, II, IZ2 #if defined(USE_OLD_SCALING) INTEGER IPERM #endif INTEGER IZ, NZ_THIS_BLOCK, PJ C pointers in IS INTEGER LIW C pointers in id%S INTEGER(8) :: LA, LA_PASSED INTEGER LIW_PASSED INTEGER(8) :: LWCB8_MIN, LWCB8 C buffer sizes INTEGER CMUMPS_LBUF, CMUMPS_LBUF_INT INTEGER(8) :: CMUMPS_LBUF_8 INTEGER :: LBUFR, LBUFR_BYTES INTEGER :: MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL INTEGER(8) :: MSG_MAX_BYTES_SOLVE8 C reception buffer INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFR C null space INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, & IBEG_GLOB_DEF, IEND_GLOB_DEF, & IROOT_DEF_RHS_COL1 C INTEGER NITREF, NOITER, SOLVET, KASE C Meaningful only with tree pruning and sparse RHS LOGICAL INTERLEAVE_PAR, DO_PERMUTE_RHS LOGICAL CALL_NODES_FWD_BWD, FIRST_CALL_NODES_FWD_BWD C true if CMUMPS_SOL_C called during postprocessing LOGICAL FROM_PP LOGICAL ALLOCATE_S C C TIMINGS DOUBLE PRECISION TIMEIT, TIMEEA, TIMEEA1, TIMELCOND DOUBLE PRECISION TIME3 DOUBLE PRECISION TIMEC1,TIMEC2 DOUBLE PRECISION TIMEGATHER1,TIMEGATHER2 DOUBLE PRECISION TIMESCATTER1,TIMESCATTER2 DOUBLE PRECISION TIMECOPYSCALE1,TIMECOPYSCALE2 C ------------------------------------------ C Declarations related to exploit sparsity C ------------------------------------------ INTEGER :: NRHS_NONEMPTY INTEGER :: STRAT_PERMAM1 LOGICAL :: DO_NULL_PIV INTEGER, DIMENSION(:), POINTER :: IRHS_PTR_COPY INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE_COPY COMPLEX, DIMENSION(:), POINTER :: RHS_SPARSE_COPY LOGICAL IRHS_SPARSE_COPY_ALLOCATED, IRHS_PTR_COPY_ALLOCATED, & RHS_SPARSE_COPY_ALLOCATED C INTEGER, DIMENSION(:), ALLOCATABLE :: MAP_RHS_loc INTEGER, DIMENSION(:), POINTER :: IRHS_loc_PTR LOGICAL :: IRHS_loc_PTR_ALLOCATED INTEGER(8) :: SUM_idNloc_RHS_8 COMPLEX, DIMENSION(:), POINTER :: idRHS_loc INTEGER(8) :: DIFF_SOL_loc_RHS_loc INTEGER(8) :: RHS_loc_size, RHS_loc_shift INTEGER(8) :: NBT INTEGER :: NBCOL, COLSIZE, JBEG_RHS, JEND_RHS, JBEG_NEW, & NBCOL_INBLOC, IPOS, IPOSRHSINTR C Nb of pruned NE_STEPS, useful for FWD step; and list of root nodes LOGICAL :: fill INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_Sons_FWD, & Pruned_Sons_BWD INTEGER, DIMENSION(:), ALLOCATABLE :: PERM_RHS INTEGER, DIMENSION(:), POINTER :: PTR_POSINRHSINTR_FWD, & PTR_POSINRHSINTR_BWD COMPLEX, DIMENSION(:), POINTER :: PTR_RHS INTEGER, DIMENSION(:), POINTER :: idIPTR_WORKING, idWORKING INTEGER :: SIZE_IPTR_WORKING, SIZE_WORKING C NRHS_NONEMPTY: holds C either the original number of RHS (id%NRHS defined on host) C or, when the RHS is sparse, it holds the C number of non empty columns. C it is computed on master and is C then broadcasted on all processes. C IRHS_PTR_COPY holds a compressed local copy of IRHS_PTR (or points C on the master to id%IRHS_PTR if no permutation requested) C IRHS_SPARSE_COPY might be allocated or might also point to C id%IRHS_SPARSE. To test if we can deallocate it we trace C with IRHS_SPARSE_COPY_ALLOCATED when it was effectively C allocated. C NBCOL_INBLOC total nb columns to process in this block C JBEG_RHS global ptr for starting column requested for this block C JEND_RHS global ptr for end column_number requested for this block C PERM_RHS -- Permutation of RHS computed on master and broadcasted C on all procs (of size id%NRHS orginal) C PERM_RHS(k) = i means that i is the kth column to be processed C Note that PERM_RHS will be used also in case of interleaving C ------------------------------------ INTEGER :: NOMP COMPLEX ONE COMPLEX ZERO PARAMETER( ONE = (1.0E0,0.0E0) ) PARAMETER( ZERO = (0.0E0,0.0E0) ) REAL RZERO, RONE PARAMETER( RZERO = 0.0E0, RONE = 1.0E0 ) C C RHS_IR is internal to CMUMPS and used for iterative refinement C or the error analysis section. It either points to the user's C RHS (on the host when the solution is centralized or the RHS C is dense), or is a workarray allocated inside this routine C of size N. COMPLEX, DIMENSION(:), POINTER :: RHS_IR COMPLEX, DIMENSION(:), POINTER :: WORK_WCB COMPLEX, DIMENSION(:), POINTER :: PTR_RHS_ROOT INTEGER(8) :: LPTR_RHS_ROOT C C Local workarrays that will be dynamically allocated C COMPLEX, ALLOCATABLE :: SAVERHS(:), C_RW1(:), & C_RW2(:), & SRW3(:), C_Y(:), & C_W(:) INTEGER :: LCWORK COMPLEX, ALLOCATABLE :: CWORK(:) INTEGER, ALLOCATABLE :: MAP_RHS(:) REAL, ALLOCATABLE :: R_Y(:), D(:) REAL, ALLOCATABLE :: R_W(:) C The 2 following workarrays are temporary local C arrays only used for distributed matrix input C (KEEP(54) .NE. 0). REAL, ALLOCATABLE, DIMENSION(:) :: R_LOCWK54 COMPLEX, ALLOCATABLE, DIMENSION(:) :: C_LOCWK54 INTEGER :: NBENT_RHSINTR, NB_FS_RHSINTR_F, & NB_FS_RHSINTR_TOT INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV LOGICAL :: UNS_PERM_INV_NEEDED_INMAINLOOP, & UNS_PERM_INV_NEEDED_BEFMAINLOOP, & UNS_PERM_INV_NEEDED_ONSLAVES INTEGER LIWK_SOLVE, LIWCB INTEGER, ALLOCATABLE :: IW1(:), IWK_SOLVE(:), IWCB(:) INTEGER :: LIWK_PTRACB INTEGER(8), ALLOCATABLE :: PTRACB(:) C C Parameters arising from the structure C INTEGER(8) :: MAXS REAL, DIMENSION(:), POINTER :: CNTL INTEGER, DIMENSION (:), POINTER :: KEEP,ICNTL,INFO INTEGER(8), DIMENSION (:), POINTER :: KEEP8 INTEGER, DIMENSION (:), POINTER :: IS REAL, DIMENSION(:),POINTER:: RINFOG C =============================================================== C SCALING issues: C When scaling was performed C RHS holds the solution of the scaled system C The unscaled second member (b0) was given C then we have to scale both rhs and solution: C A(sca) = LU = D1*A*D2 , with D2 = COLSCA C D1 = ROWSCA C -------------- C CASE OF A X =B C -------------- C (ICNTL(9)=1 or MTYPE=1) C A*x0 = b0 C b(sca) = D1 * b0 = ROWSCA*b0 C A(sca) [(D2) **(-1)] x0 = b(sca) C so the computed solution of LU * x(sca) = b(sca) C is : x(sca) =[(D2) **(-1)] x0 and so x0= D2*x(sca) C -------------- C CASE OF AT X =B C -------------- C (ICNTL(9).NE.1 or MTYPE=0) C A(sca) = LU = D1*A*D2 C AT*x0 = b0 => D2*AT*D1 * D1-1 x0 = D2 * b0 C b(sca) = D2 * b0 = COLSCA*b0 C A(sca)T [(D1) **(-1)] x0 = b(sca) C so the computed solution of (LU)^T * x(sca) = b(sca) C is : x(sca) =[(D1) **(-1)] x0 and so x0= D1*y0 is modified C C In case of distributed RHS or distributed solution we need C scaling information on each processor and this information has C been stored in ROWSCA_loc(1:INFO(23)) and COLSCA_loc(1:INFO(23)) C such that: C C ---------------- C CASE OF A X = B C ---------------- C C - the scaling factor of row i of A is stored on the C processor for which GLOB2LOC_RHS(i) > 0 at position C ROWSCA_loc(GLOB2LOC_RHS(i)) C C - the scaling factor of column j of A is stored on the C processor for which GLOB2LOC_SOL(j) > 0 at position C COLSCA_loc(GLOB2LOC_SOL(j)) C C ------------------ C CASE OF A^T X = B C ------------------ C C - the scaling factor of row i of A^T is stored on the C processor for which GLOB2LOC_RHS(i) > 0 at position C COLSCA_loc(GLOB2LOC_RHS(i)) C C - the scaling factor of column j of A^T is stored on the C processor for which GLOB2LOC_SOL(j) > 0 at position C ROWSCA_loc(GLOB2LOC_SOL(j)) C #if defined(USE_OLD_SCALING) type scaling_data_t SEQUENCE REAL , dimension(:), pointer :: SCALING REAL , dimension(:), pointer :: SCALING_LOC INTEGER, dimension(:), pointer :: SCALING_IND end type scaling_data_t type (scaling_data_t) :: scaling_data_dr type (scaling_data_t) :: scaling_data_sol C To scale on the fly during GATHER SOLUTION: REAL, DIMENSION(:), POINTER :: PT_SCALING REAL, TARGET :: Dummy_SCAL(1) #else INTEGER :: ROWORCOL #endif C C ==================== END OF SCALING related data ================ C C Local variables C C Interval associated to the subblocks of RHS a node has to process INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: RHS_BOUNDS INTEGER :: LPTR_RHS_BOUNDS INTEGER, DIMENSION(:), POINTER :: PTR_RHS_BOUNDS LOGICAL :: DO_NBSPARSE, NBSPARSE_LOC LOGICAL :: PRINT_MAXAVG REAL ARRET COMPLEX C_DUMMY(1) REAL R_DUMMY(1) INTEGER IDUMMY(1), JDUMMY(1), KDUMMY(1), LDUMMY(1), MDUMMY(1) INTEGER, TARGET :: IDUMMY_TARGET(1) COMPLEX, TARGET :: CDUMMY_TARGET(1) INTEGER JJ INTEGER allocok INTEGER NBRHS, NBRHS_EFF, BEG_RHS, NB_RHSSKIPPED, & LD_RHS, & MASTER_ROOT, MASTER_ROOT_IN_COMM C NRHS_COLS_SOL_C is used to estimate NRHS_EFF C before the loop on RHS column blocks INTEGER NRHS_COLS_SOL_C INTEGER SIZE_ROOT, LD_REDRHS INTEGER(8) :: IBEG, IBEG_RHSINTR, KDEC, IBEG_loc, IBEG_REDRHS INTEGER NCOL_RHS_loc INTEGER LD_RHS_loc, JBEG_RHS_loc INTEGER NB_K133, IRANK, TSIZE INTEGER KMAX_246_247 INTEGER IFLAG_IR, IRStep LOGICAL TESTConv LOGICAL WORKSPACE_MINIMAL_PREFERRED, WK_USER_PROVIDED INTEGER(8) NB_BYTES !size of data allocated during solve INTEGER(8) NB_BYTES_MAX !MAX size of data allocated during solve INTEGER(8) NB_BYTES_EXTRA !For Step2Node, which may be freed later INTEGER(8) NB_BYTES_LOC !For temp. computations INTEGER(8) NB_INT, NB_CMPLX, NB_CHAR, K34_8, K35_8, K149_8, K151_8 INTEGER(8) K16_8, ITMP8, SUM_ITMP8, NB_BYTES_ON_ENTRY #if defined(V_T) C Vampir INTEGER soln_drive_class, glob_comm_ini, perm_scal_ini, soln_dist, & soln_assem, perm_scal_post #endif LOGICAL I_AM_SLAVE, BUILD_POSINRHSINTR LOGICAL :: BUILD_RHSMAPINFO REAL, TARGET :: RDUMMY_TARGET(1) LOGICAL :: ES_RHSINTR INTEGER, DIMENSION(:), POINTER :: nodes_FWD, nodes_BWD C to manage sparsity: compute target nodes for starting chains C Lnodes_FWD/Lnodes_BWD = -1 => all nodes to be processed INTEGER, DIMENSION(:), POINTER :: nodes_FWD_PTR, nodes_BWD_PTR INTEGER :: Lnodes_FWD, Lnodes_BWD, Lnodes_FWD_PTR, Lnodes_BWD_PTR REAL, POINTER, DIMENSION(:) :: SCALING_loc_FWD REAL, POINTER, DIMENSION(:) :: SCALING_loc_BWD REAL, POINTER, DIMENSION(:) :: SCALING_RHSINTR_BWD REAL, POINTER, DIMENSION(:) :: SCALING_RHSINTR_FWD INTEGER :: LSCALING_RHSINTR_BWD, LSCALING_RHSINTR_FWD LOGICAL :: SCALING_RHSINTR_BWD_ALLOCATED, & SCALING_RHSINTR_FWD_ALLOCATED, & BUILD_SCALING_RHSINTR C NSOL_loc will be equal to KEEP(89) in case ICNTL(21)=1 INTEGER :: NSOL_loc LOGICAL WORK_WCB_ALLOCATED, IS_INIT_OOC_DONE LOGICAL PTR_RHS_ROOT_ALLOCATED LOGICAL :: IS_LR_MOD_TO_STRUC_DONE INTEGER :: KEEP350_SAVE, KEEP20_SAVE LOGICAL STOP_AT_NEXT_EMPTY_COL INTEGER MTYPE_LOC INTEGER(4) :: I4 INTEGER MAT_ALLOC_LOC, MAT_ALLOC INTEGER :: NZ_THIS_BLOCK_ARG, NBCOL_INBLOC_ARG, LStep2node_ARG INTEGER, POINTER :: Step2node_ARG(:), IRHS_PTR_COPY_ARG(:), & IRHS_SPARSE_COPY_ARG(:) INTEGER :: NB_FS_RHSINTR_F_ARG, NB_FS_RHSINTR_TOT_ARG INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE C C First executable statement C #if defined(V_T) CALL VTCLASSDEF( 'Soln driver',soln_drive_class,IERR) CALL VTFUNCDEF( 'glob_comm_ini',soln_drive_class, & glob_comm_ini,IERR) CALL VTFUNCDEF( 'perm_scal_ini',soln_drive_class, & perm_scal_ini,IERR) CALL VTFUNCDEF( 'soln_dist',soln_drive_class,soln_dist,IERR) CALL VTFUNCDEF( 'soln_assem',soln_drive_class,soln_assem,IERR) CALL VTFUNCDEF( 'perm_scal_post',soln_drive_class, & perm_scal_post,IERR) #endif C Depending on the type of parallelism, C the master can have the role of a slave I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) C -- The following pointers xxCOPY might be allocated but then C -- the associated xxCOPY_ALLOCATED will be set to C -- enable deallocation SCALING_RHSINTR_FWD_ALLOCATED = .FALSE. SCALING_RHSINTR_BWD_ALLOCATED = .FALSE. C Initialize scalings to possilby pass them as arguments C (e.g. to CMUMPS_DS_ALL2ALL) even on non working host C and/or when LSCAL is false SCALING_RHSINTR_FWD => RDUMMY_TARGET SCALING_RHSINTR_BWD => RDUMMY_TARGET LSCALING_RHSINTR_FWD = 1 LSCALING_RHSINTR_BWD = 1 SCALING_LOC_FWD => RDUMMY_TARGET SCALING_LOC_BWD => RDUMMY_TARGET 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. C ALLOCATE_S will be set to true if S needs be allocated. C It is then tested to free S befgore returning ALLOCATE_S = .FALSE. NULLIFY(RHS_IR) NULLIFY(WORK_WCB) #if defined(USE_OLD_SCALING) NULLIFY(scaling_data_dr%SCALING) NULLIFY(scaling_data_dr%SCALING_LOC) NULLIFY(scaling_data_dr%SCALING_IND) NULLIFY(scaling_data_sol%SCALING) NULLIFY(scaling_data_sol%SCALING_LOC) NULLIFY(scaling_data_sol%SCALING_IND) #endif NULLIFY(nodes_FWD) NULLIFY(nodes_BWD) IRHS_loc_PTR_allocated = .FALSE. IS_INIT_OOC_DONE = .FALSE. IS_LR_MOD_TO_STRUC_DONE = .FALSE. WK_USER_PROVIDED = .FALSE. WORK_WCB_ALLOCATED = .FALSE. PTR_RHS_ROOT_ALLOCATED = .FALSE. CNTL =>id%CNTL KEEP =>id%KEEP KEEP8=>id%KEEP8 IS =>id%IS ICNTL=>id%ICNTL INFO =>id%INFO RINFOG =>id%RINFOG LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) IF (.not.PROK) MP =0 IF (.not.PROKG) MPG=0 IF ( PROK ) WRITE(MP,100) IF ( PROKG ) WRITE(MPG,100) NB_BYTES = 0_8 NB_BYTES_MAX = 0_8 NB_BYTES_EXTRA = 0_8 K34_8 = int(KEEP(34), 8) K35_8 = int(KEEP(35), 8) ! complex factor K16_8 = int(KEEP(16), 8) K149_8 = int(KEEP(149),8) ! complex in instance K151_8 = int(KEEP(151),8) ! complex in instance C RR KEEP20_SAVE = KEEP(20) IF (KEEP(19).EQ.0.AND.KEEP(53).NE.0) THEN C ICNTL(56)>0 at analysis and =0 at facto C save special root index KEEP20_SAVE = KEEP(20) C suppress special RR treatment KEEP(20) = 0 ENDIF NBENT_RHSINTR = 0 C Used by DISTRIBUTED_SOLUTION to skip empty columns C that are skipped (case of sparse RHS) NB_RHSSKIPPED = 0 C next 4 initialisations needed in case of error C to free space allocated LSCAL = .FALSE. C ICNTL21 = -99998 ! will be bcasted later to slaves IBEG_RHSINTR =-152525_8 ! Should not be used BUILD_POSINRHSINTR = .TRUE. C NSOL_loc, KEEP(212) will be set if ICNTL(21).EQ.2 NSOL_loc = 0 KEEP(212)= 0 C SCALING_RHSINTR was initialized to a dummy array of size 1 C on the non working host, no need to reset it at each block BUILD_SCALING_RHSINTR = I_AM_SLAVE IBEG_GLOB_DEF = -9888 ! unitialized state IEND_GLOB_DEF = -9888 ! unitialized state IBEG_ROOT_DEF = -9777 ! unitialized state IEND_ROOT_DEF = -9777 ! unitialized state IROOT_DEF_RHS_COL1 = -9666 ! unitialized state C ------------------------------ C id%LD_RHSINTR will be set each C time RHSINTR is allocated C ------------------------------ NB_FS_RHSINTR_TOT = KEEP(89) ! number of FS var of the pruned tree ! mapped on this proc NB_FS_RHSINTR_F = NB_FS_RHSINTR_TOT C Save value of KEEP(350), in case of LR solve C KEEP(350) may be overwritten and restored C Old unoptimized version before 5.0.2 not available anymore IF (KEEP(350).LE.0) KEEP(350)=1 IF (KEEP(350).GT.2) KEEP(350)=1 KEEP350_SAVE = KEEP(350) C C Compute the number of integers and nb of reals in the structure CALL CMUMPS_SIZE_IN_STRUCT (id, idintr, NB_INT, NB_CMPLX, NB_CHAR) NB_BYTES = NB_BYTES + NB_INT * K34_8 + NB_CMPLX * K149_8 + NB_CHAR ! KE15: size of a cmplx in current MUMPS instance NB_BYTES_ON_ENTRY = NB_BYTES !used to check alloc/dealloc count ok NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ====================================== C BEGIN CHECK KEEP ENTRIES AND INTERFACE C ====================================== IF (id%MYID .EQ. MASTER) THEN C { C Set ICNTL(26) -> KEEP(221) (called at facto and solve) C (might be called at facto in case of fwd in facto C with Schur+reduced RHS requested) CALL CMUMPS_SET_K221(id, .TRUE.) id%KEEP(111) = id%ICNTL(25) C For the case of ICNTL(20)=1 one could C switch off exploit sparsity when RHS is too dense. IF (id%ICNTL(20) .EQ. 1) id%KEEP(235) = -1 !automatic IF (id%ICNTL(20) .EQ. 2) id%KEEP(235) = 0 !off IF (id%ICNTL(20) .EQ. 3) id%KEEP(235) = 1 !on IF (id%ICNTL(20).EQ.1 .or. id%ICNTL(20).EQ.2 .or. & id%ICNTL(20).EQ.3) THEN id%KEEP(248) = 1 !sparse RHS ELSE IF (id%ICNTL(20).EQ.10 .OR. id%ICNTL(20).EQ.11) THEN id%KEEP(248) = -1 ! dist. RHS ELSE id%KEEP(248) = 0 !dense RHS ENDIF C C set ICNTL21 and test for out-of range entries ICNTL21 = id%ICNTL(21) IF ( ICNTL21.NE.0 .AND. ICNTL21.NE.1 & ) ICNTL21 = 0 C IF ( id%ICNTL(30) .NE.0 ) THEN C A-1 is on id%KEEP(237) = 1 ELSE C A-1 is off id%KEEP(237) = 0 ENDIF IF (id%KEEP(248) .eq.0.and. id%KEEP(237).ne.0) THEN C For A-1 we have a sparse RHS in the API. C Force KEEP(248) accordingly. id%KEEP(248)=1 ENDIF IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(248).NE.0) ) THEN IF (KEEP(60).NE.0) THEN C -- input RHS is stored in REDRHS and RHSINTR id%KEEP(248) = 0 ENDIF ENDIF C} ENDIF C ============================================================= C KEEP(248) and KEEP(221): need be broadcasted C before continuing other checking/settings CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(248), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) IF (KEEP(248).EQ.-1 & ) THEN C{ CALL CMUMPS_CHECK_DISTRHS( & id%Nloc_RHS, & id%LRHS_loc, & id%NRHS, & id%IRHS_loc, & id%RHS_loc, & I_AM_SLAVE, & id%INFO) CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 C Compute sum of id%Nloc_RHS (without out-of-range) C and store it in SUM_idNloc_RHS_8 C (to be used to decide whether exploit sparsity C is exploited) CALL CMUMPS_ES_GET_SUM_Nloc ( & id%N, id%Nloc_RHS, id%IRHS_loc, id%COMM, & SUM_idNloc_RHS_8 ) C} ENDIF C =========================================================== IF (id%MYID .EQ. MASTER) THEN C { IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(235).NE.0) ) THEN C -- input RHS is in fact effectively C -- stored in REDRHS and/or RHSINTR C (for both Schur and bwd only) id%KEEP(235) = 0 ENDIF IF ( (id%KEEP(248).EQ.0).AND.(id%KEEP(111).EQ.0) ) THEN C RHS is not sparse and thus exploit sparsity is reset to 0 id%KEEP(235) = 0 ENDIF IF (id%KEEP(248) .EQ. -1 & ) THEN IF (id%KEEP(126).EQ.0) THEN id%KEEP(235) = 0 ELSE IF (id%KEEP(126).EQ.-1) THEN id%KEEP(235) = 1 ELSE IF (id%KEEP(126).GT.0) THEN IF ( SUM_idNloc_RHS_8 .LE. & int( & (real(id%KEEP(126))/real(1000))*real(id%N) & , 8) & ) THEN id%KEEP(235) = 1 ELSE id%KEEP(235) = 0 ENDIF ELSE id%KEEP(235) = 0 ENDIF ENDIF C Case of Automatic setting of exploit sparsity (KEEP(235)=-1) C (in MUMPS_DRIVER original value of KEEP(235) is reset) IF(id%KEEP(111).NE.0) id%KEEP(235)=0 IF(id%KEEP(111).NE.0) id%KEEP(212)=0 C IF (id%KEEP(235).EQ.-1) THEN IF (id%KEEP(237).NE.0) THEN C for A-1 id%KEEP(235)=1 ELSE id%KEEP(235)=1 ENDIF ELSE IF (id%KEEP(235).NE.0) THEN id%KEEP(235)=1 ENDIF C Setting of KEEP(242) (permute RHS) IF ((KEEP(111).NE.0).OR.(KEEP(248) .EQ. -1)) THEN C In the context of C - distributed RHS, all columns share the same structure C - null space, the null pivots C are by default permuted to post-order C However for null space there is in this case no need to C permute null pivots since they are already in correct order. C Setting KEEP(242)=1 would just force to go through C part of the code permuting to identity. C Apart for validation purposes this is not interesting C costly (and more risky). KEEP(242) = 0 ENDIF IF (KEEP(248).EQ.0.AND.KEEP(111).EQ.0) THEN C Permutation possible if sparse RHS C (KEEP(248).NE.0: A-1 or General Sparse) C or null space (even if in current version C it is deactived) KEEP(242) = 0 ENDIF IF ((KEEP(242).NE.0).AND.KEEP(237).EQ.0) THEN IF ((KEEP(242).NE.-9).AND.KEEP(242).NE.1.AND. & KEEP(242).NE.-1) THEN C Reset it to 0 KEEP(242) = 0 ENDIF ENDIF IF (KEEP(242).EQ.-9) THEN C { C Automatic setting of permute RHS IF (id%KEEP(237).NE.0) THEN KEEP(242) = 1 ! postorder for A-1 ELSE ! dense or general sparse or distributed RHS KEEP(242) = 0 ! no permutation in most general case IF (KEEP(248) .EQ. 1) THEN ! sparse RHS IF (id%KEEP(235) .EQ. 1) THEN ! Tree pruning IF (id%NRHS .GT. 1) THEN IF (KEEP(497).EQ.-1 .OR. KEEP(497).GE.1) THEN KEEP(242)=1 ENDIF ENDIF ENDIF ENDIF ENDIF C } ENDIF IF ( id%KEEP(221).NE.0 ) THEN C -- Do not permute RHS with REDRHS/RHSINTR id%KEEP(242) = 0 ENDIF IF (KEEP(242).EQ.0) KEEP(243)=0 ! interleave off IF ((KEEP(237).EQ.0).OR.(KEEP(242).EQ.0)) THEN C Interleave (243) possible only C when permute RHS (242) is on and with A-1 KEEP(243) = 0 ENDIF IF (id%KEEP(237).EQ.1) THEN ! A-1 entries C Case of automatic setting of KEEP(243), KEEP(493-498) C (exploit sparsity parameters) IF (id%NSLAVES.EQ.1) THEN IF (id%KEEP(243).EQ.-1) id%KEEP(243)=0 IF (id%KEEP(495).EQ.-1) id%KEEP(495)=1 IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ELSE IF (id%KEEP(243).EQ.-1) id%KEEP(243)=1 IF (id%KEEP(495).EQ.-1) id%KEEP(495)=1 IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ENDIF ELSE ! dense or general sparse or distributed RHS id%KEEP(243)=0 id%KEEP(495)=0 IF (KEEP(248) .EQ. 1) THEN ! sparse RHS IF (id%KEEP(235) .EQ. 1) THEN ! Tree pruning IF (id%NRHS .GT. 1) THEN IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ENDIF ENDIF ELSE C nbsparse meaningless for distributed or dense RHS C Force it to 0 whatever was the initial value id%KEEP(497)=0 ENDIF ENDIF MTYPE = id%ICNTL( 9 ) IF (MTYPE.NE.1) MTYPE=0 ! see interface IF ((MTYPE.EQ.0).AND.KEEP(50).NE.0) MTYPE =1 ! suppress option Atx=b for A-1 IF (id%KEEP(237).NE.0) MTYPE = 1 C C ICNTL(35) was defined at analysis and C consistently reset at factorization C It was stored in KEEP(486) after factorization C Set KEEP(485) accordingly. C IF (KEEP(486) .EQ. 2) THEN KEEP(485) = 1 ! BLR solve ELSE KEEP(485) = 0 ! FR solve ENDIF C } ENDIF id%KEEP(401) = 0 IF (id%ICNTL(48).EQ.1) id%KEEP(401)=1 C Bcast id%KEEP(401) strategy (which C may be switched off or on during solve) CALL MPI_BCAST( id%KEEP(401), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) C define ICNTL48_EFF on master IF (id%MYID.EQ.MASTER) THEN IF ( (id%KEEP(401).EQ.1). AND. (id%KEEP(400).GT.0) ) THEN ICNTL48_EFF = 1 ELSE ICNTL48_EFF = 0 ENDIF ENDIF CALL MPI_BCAST(MTYPE,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST( id%KEEP(111), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(235), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(237), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(242), 2, MPI_INTEGER, MASTER, id%COMM, & IERR ) C Allready done CALL MPI_BCAST( id%KEEP(248), ...) CALL MPI_BCAST( id%KEEP(350), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(485), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(495), 3, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( ICNTL21, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C Broadcast original id%NRHS (used at least for checks on SOL_loc C and to allocate PERM_RHS in case of exploit sparsity) CALL MPI_BCAST( id%NRHS,1, MPI_INTEGER, MASTER, id%COMM,IERR) C C TIMINGS: reset to 0 TIMEC2=0.0D0 TIMECOPYSCALE2=0.0D0 TIMEGATHER2=0.0D0 TIMESCATTER2=0.0D0 id%DKEEP(112)=0.0E0 id%DKEEP(113)=0.0E0 C id%DKEEP(114) time for the iterative refinement C id%DKEEP(120) time for the error analysis C id%DKEEP(121) time for condition number C id%DKEEP(122) time for matrix redistribution (copy+scale solution) id%DKEEP(114)=0.0E0 id%DKEEP(120)=0.0E0 id%DKEEP(121)=0.0E0 id%DKEEP(115)=0.0E0 id%DKEEP(116)=0.0E0 id%DKEEP(122)=0.0E0 C Time for fwd, bwd and scalapack is C accumulated in DKEEP(117-119) within SOL_C C If requested time for each call to FWD/BWD C might be print but on output to solve C phase DKEEP will hold on each proc the accumulated time id%DKEEP(117)=0.0E0 id%DKEEP(118)=0.0E0 id%DKEEP(119)=0.0E0 id%DKEEP(123)=0.0E0 id%DKEEP(124)=0.0E0 id%DKEEP(125)=0.0E0 id%DKEEP(126)=0.0E0 id%DKEEP(127)=0.0E0 id%DKEEP(128:134)=0.0E0 id%DKEEP(140:153)=0.0E0 C CALL MUMPS_SECDEB(TIME3) C ------------------------------ C Check parameters on the master C ------------------------------ IF ( id%MYID .EQ. MASTER ) THEN IF ((KEEP(23).NE.0).AND.KEEP(50).NE.0) THEN C Maximum transversal permutation C has not been saved (KEEP(23)>0 and UNS_PERM allocated) C when matrix is symmetric. IF (PROKG) WRITE(MPG,'(A)') & ' Internal Error 1 in solution driver ' id%INFO(1)=-444 id%INFO(2)=KEEP(23) ENDIF C ------------------------------------ C Check that factors are available C either in-core or on disk, case C where factors were discarded during C factorization (e.g. useful to simulate C an OOC factorization or just get nb of C negative pivots or determinant) C ------------------------------------ IF (KEEP(201) .EQ. -1) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: Solve impossible because factors not kept' ENDIF id%INFO(1)=-44 id%INFO(2)=KEEP(251) GOTO 333 ELSE IF (KEEP(221).EQ.0 .AND. KEEP(251) .EQ. 2 & .AND. KEEP(252).EQ.0) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: Solve impossible because factors not kept' ENDIF id%INFO(1)=-44 id%INFO(2)=KEEP(251) GOTO 333 ENDIF C ------------------ IF (KEEP(252).NE.0 .AND. id%NRHS .NE. id%KEEP(253)) THEN C Fwd in facto C KEEP(252-253) available on all procs since analysis phase C Error: id%NRHS is not allowed to change since analysis C because fwd has been performed during facto with C KEEP(253) RHS IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: id%NRHS not allowed to change when', & ' ICNTL(32)=1' ENDIF id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) GOTO 333 ENDIF C Testing MTYPE instead of ICNTL(9) IF (KEEP(252).NE.0 .AND. MTYPE.NE.1) THEN C Fwd in facto is not compatible with transpose system INFO(1) = -43 INFO(2) = 9 IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.1) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' ENDIF GOTO 333 ENDIF IF (KEEP(248) .NE. 0.AND.KEEP(252).NE.0) THEN C Fwd during facto incompatible with sparse RHS C Forbid sparse RHS when Fwd performed during facto C Sparse RHS may be due to A-1 (ICNTL(30) INFO(1) = -43 IF (KEEP(237).NE.0) THEN INFO(2) = 30 ! ICNTL(30) IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: A-1 functionality incompatible with', & ' forward performed during factorization', & ' (ICNTL(32)=1)' ENDIF ELSE INFO(2) = 20 ! ICNTL(20) IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: sparse or dist. RHS incompatible with forward', & ' elimination during factorization (ICNTL(32)=1)' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. ICNTL21.NE.0) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with distributed solution.' ENDIF INFO(1)=-48 INFO(2)=21 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(60) .NE.0) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with Schur.' ENDIF INFO(1)=-48 INFO(2)=19 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(111) .NE.0) THEN IF (LPOK) THEN WRITE(LP,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with null space.' ENDIF INFO(1)=-48 INFO(2)=25 GOTO 333 ENDIF IF (id%NRHS .LE. 0) THEN id%INFO(1)=-45 id%INFO(2)=id%NRHS IF ((id%KEEP(111).NE.0).AND.(id%INFOG(28).EQ.0)) THEN IF (LPOK) THEN WRITE(LP,'(A)') & 'ICNTL(25) NE 0 but INFOG(28)=0', & ' the matrix is not deficient' ENDIF ENDIF GOTO 333 ENDIF C Entries of A-1 are stored in place of the input sparse RHS C thus no need for RHS to be allocated. IF (id%KEEP(237).EQ.0) THEN IF ((id%KEEP(248) == 0 .AND.KEEP(221).NE.2) & .OR. & (ICNTL21==0.AND.(KEEP(221).NE.1)) & )THEN C RHS must be of size N*NRHS on the master either to C store the dense centralized RHS, either to store C the dense centralized solution. CALL CMUMPS_CHECK_DENSE_RHS & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) IF (id%INFO(1) .LT. 0) GOTO 333 ENDIF ELSE C AM1: check that the constraint NRHS=N is respected C Check for valid sparse RHS structure done IF (id%NRHS .NE. id%N) THEN id%INFO(1)= -47 id%INFO(2)=id%NRHS GOTO 333 ENDIF ENDIF IF (id%KEEP(248) == 1 & ) THEN C{ ------------------------------------ C RHS_SPARSE, IRHS_SPARSE and IRHS_PTR C must be allocated of adequate size C ------------------------------------ IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(237).NE.0)) THEN C At least one entry of A-1 must be requested id%INFO(1)=-46 id%INFO(2)=id%NZ_RHS GOTO 333 ENDIF IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(221).EQ.1)) THEN C At least one entry of RHS must be nonzero with c Schur reduced RHS option id%INFO(1)=-46 id%INFO(2)=id%NZ_RHS GOTO 333 ENDIF IF ( id%NZ_RHS .GT. 0 ) THEN IF ( .not. associated(id%RHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 ENDIF ENDIF IF (id%NZ_RHS .GT. 0) THEN IF ( .not. associated(id%IRHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 ENDIF ENDIF IF ( .not. associated(id%IRHS_PTR) )THEN id%INFO(1)=-22 id%INFO(2)=12 GOTO 333 ENDIF C IF (size(id%IRHS_PTR) < id%NRHS + 1) THEN id%INFO(1)=-22 id%INFO(2)=12 GOTO 333 END IF IF (id%IRHS_PTR(id%NRHS + 1).ne.id%NZ_RHS+1) THEN id%INFO(1)=-27 id%INFO(2)=id%IRHS_PTR(id%NRHS+1) GOTO 333 END IF C compare with dble to prevent overflow IF (dble(id%N)*dble(id%NRHS).LT.dble(id%NZ_RHS)) THEN C Possible in case of dupplicate entries in Sparse RHS IF (PROKG) THEN write(MPG,*) & " WARNING: many dupplicate entries in ", & " sparse RHS provided by the user ", & " id%NZ_RHS,id%N,id%NRHS =", & id%NZ_RHS,id%N,id%NRHS ENDIF END IF IF (id%IRHS_PTR(1).ne.1) THEN id%INFO(1)=-28 id%INFO(2)=id%IRHS_PTR(1) GOTO 333 END IF IF (size(id%IRHS_SPARSE) < id%NZ_RHS) THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 END IF IF (size(id%RHS_SPARSE) < id%NZ_RHS) THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 END IF C} ENDIF C -------------------------------- C Set null space options for solve C -------------------------------- CALL CMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL(1),KEEP(1), & id%NRHS, & MPG,INFO(1)) IF (INFO(1) .LT. 0) GOTO 333 C END IF ! MASTER C -------------------------------------- C Check distributed solution vectors C -------------------------------------- IF (ICNTL21 .NE. 0 ) THEN IF (I_AM_SLAVE) THEN NSOL_loc = id%KEEP(89) ELSE NSOL_loc = 0 ENDIF C (I)SOL_loc should be allocated to hold the C distributed solution on exit IF ( id%LSOL_loc .LT. NSOL_loc ) THEN id%INFO(1)= -29 id%INFO(2)= id%LSOL_loc GOTO 333 ENDIF IF ( NSOL_loc .GT. 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) < NSOL_loc ) THEN id%INFO(1)=-22 id%INFO(2)=13 GOTO 333 END IF # if defined(MUMPS_NOF2003) C Warning: size returns a standard INTEGER and could C overflow if id%SOL_loc was allocated of size > 2^31-1; C still we prefer to perform this test since only (1) very C large problems with large NRHS and small numbers of MPI C can result in such a situation; (2) the test could be C suppressed if needed but might be still be ok in case C the right-hand side overflows too. IF (size(id%SOL_loc) < & (id%NRHS-1)*id%LSOL_loc+NSOL_loc) THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 END IF # else IF (size(id%SOL_loc,kind=8) < & int(id%NRHS-1,8)*int(id%LSOL_loc,8)+ & int(NSOL_loc,8)) THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 END IF # endif ENDIF ! NSOL_loc > 0 ENDIF ! ICNTL21 .NE. 0 IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(248) == 1 & ) THEN C RHS should NOT be associated C if I am not master since it is C not even used to store the solution IF ( associated( id%RHS ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 7 GOTO 333 END IF IF ( associated( id%RHS_SPARSE ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 10 GOTO 333 END IF IF ( associated( id%IRHS_SPARSE ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 11 GOTO 333 END IF IF ( associated( id%IRHS_PTR ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 12 GOTO 333 END IF END IF ENDIF C Prepare pointers to pass POINTERS(1) to C routines with implicit interfaces which C will then assume contiguous information C without needing to copy pointer arrays C in and out. Do this even if KEEP(248) C is different from -1 because of the C call to CMUMPS_DISTSOL_INDICES IF (associated(id%IRHS_loc)) THEN IF (size(id%IRHS_loc) .NE. 0) THEN IRHS_loc_PTR=>id%IRHS_loc ELSE C so that IRHS_loc_PTR(1) is ok IRHS_loc_PTR=>IDUMMY_TARGET ENDIF ELSE IRHS_loc_PTR=>IDUMMY_TARGET ENDIF IF (associated(id%RHS_loc)) THEN IF (size(id%RHS_loc) .NE. 0) THEN idRHS_loc=>id%RHS_loc ELSE idRHS_loc=>CDUMMY_TARGET ENDIF ELSE idRHS_loc=>CDUMMY_TARGET ENDIF C C C Check as soon as solution is distributed IF (I_AM_SLAVE .AND. ICNTL21.NE.0 .AND. & KEEP(248) .EQ. -1 & ) THEN ! Dist RHS and dist solution C IF (associated(id%RHS_loc) .AND. & associated(id%SOL_loc)) THEN C NSOL_loc was defined earlier IF (NSOL_loc.GT.0) THEN C ---------------------------------------------------- C Check if RHS_loc and SOL_loc point to same object... C id%SOL_loc(1) ok otherwise an error -22/14 C would have been raised earlier. C idRHS_loc(1) may point to CDUMMY but is ok C ---------------------------------------------------- CALL MUMPS_SIZE_C(idRHS_loc(1),id%SOL_loc(1), & DIFF_SOL_loc_RHS_loc) C ---------------------------------------- C Check for compatible dimensions in case C SOL_loc and RHS_loc point to same memory C ---------------------------------------- IF (DIFF_SOL_loc_RHS_loc .EQ. 0_8 .AND. & id%LSOL_loc .GT. id%LRHS_loc) THEN C Note that, depending on the block size, C if all columns are processed in one C shot, this could still work. However, C and since this was forbidden in the UG, C we raise the error systematically id%INFO(1)=-56 id%INFO(2)=id%LRHS_loc IF (LPOK) THEN WRITE(LP,'(A,I9,A,I9)') &" ** Error RHS_loc and SOL_loc pointers match but LRHS_loc=" &,id%LRHS_loc, " and LSOL_loc=", id%LSOL_loc ENDIF GOTO 333 ENDIF ENDIF ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN C Do some checks on KEEP(221) and REDRHS (in case of Schur) CALL CMUMPS_CHECK_K221andREDRHS(id) END IF ! MYID.EQ.MASTER IF (id%INFO(1) .LT. 0) GOTO 333 C ------------------------- C Propagate possible errors C ------------------------- 333 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 C ==================================== C END CHECK INTERFACE AND KEEP ENTRIES C ==================================== C ----------------------------------- 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) ENDIF C C ======================================================= C BEGIN Test for empty RHS : C sparse RHS and General Sparse (NOT A-1) and NZ_RHS = 0 C OR C Distributed RHS and sum of id%Nloc_RHS C (without off out-of-range) equal to 0 C ======================================================= IF & ( & ( (id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0) & .AND. (id%NZ_RHS.EQ.0) ) & .OR. & ( (id%KEEP(248).EQ.-1).AND. (SUM_idNloc_RHS_8.EQ.0_8) & ) & ) THEN C{ C We reset solution to zero and we return C (first freeing working space at label 90) IF ((ICNTL21.EQ.1).AND.(I_AM_SLAVE)) THEN C ---------------------- C SOL_loc reset to zero C ---------------------- C ---------------------- C Prepare ISOL_loc array C ---------------------- LIW_PASSED=max(1,KEEP(32)) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF (KEEP(89) .GT. 0) THEN CALL CMUMPS_DISTSOL_INDICES( MTYPE, id%ISOL_loc(1), & id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%IS(1), LIW_PASSED,id%MYID_NODES, & id%N, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES, #if defined(USE_OLD_SCALING) & scaling_data_sol, .FALSE., ! empty RHS, no scaling #endif C For checking only & .FALSE., IDUMMY(1), 1 & ) ENDIF ENDIF C Solution is null IF (ICNTL21.NE.0) THEN ! distributed solution DO J=1, id%NRHS C (NSOL_loc=KEEP(89) or id%NSOL_loc, and in case C ICNTL21=1, NSOL_loc is 0 on non-working host) DO I=1, NSOL_loc id%SOL_loc(int(J-1,8)*id%LSOL_loc + I) =ZERO ENDDO ENDDO ENDIF IF (ICNTL21.EQ.0) THEN ! centralized solution C ---------------------------- C RHS reset to zero on master C ---------------------------- IF (id%MYID.EQ.MASTER) THEN DO J=1, id%NRHS DO I=1, id%N id%RHS(int(J-1,8)*int(id%LRHS,8) + int(I,8)) =ZERO ENDDO ENDDO ENDIF ENDIF C C print solve phase stats if requested IF ( PROKG ) THEN WRITE( MPG, 150 ) C ICNTL(35) should not been accessed during SOLVE thus C print KEEP(486) value set during factorization & id%NRHS, ICNTL(27), ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30), KEEP(486), & ICNTL48_EFF IF (KEEP(221).NE.0) THEN WRITE (MPG, 152) KEEP(221) ENDIF IF (KEEP(252).GT.0) THEN ! Fwd during facto WRITE (MPG, 153) KEEP(252) ENDIF ENDIF C C -------- GOTO 90 ! end of solve deallocate what is needed C} ENDIF ! test empty RHS (general sparse or Distributed) C ======================================================= C END of Test for empty RHS : C ======================================================= C ==================================== C END CHECK INTERFACE AND KEEP ENTRIES C ==================================== INTERLEAVE_PAR =.FALSE. DO_PERMUTE_RHS =.FALSE. CALL_NODES_FWD_BWD = .FALSE. FIRST_CALL_NODES_FWD_BWD = .FALSE. C Default is no sparsity exploited nodes_FWD_PTR => IDUMMY_TARGET nodes_BWD_PTR => IDUMMY_TARGET Lnodes_FWD = -1 Lnodes_BWD = -1 C IF ((id%KEEP(235).NE.0).or.(id%KEEP(237).NE.0) & ) THEN CALL_NODES_FWD_BWD = .TRUE. FIRST_CALL_NODES_FWD_BWD = .TRUE. C Case of pruned elimination tree or selected entries in A-1 IF (id%KEEP(237).NE.0.AND. & id%KEEP(248).EQ.0) THEN C When A-1 is requested (keep(237).ne.0) C sparse RHS has been forced to be on. IF (LPOK) THEN WRITE(LP,'(A,I4,I4)') & ' Internal Error 2 in solution driver (A-1) ', & id%KEEP(237), id%KEEP(248) ENDIF CALL MUMPS_ABORT() ENDIF C NBT (in Bytes) is inout in MUMPS_REALLOC and C should be initialized. NBT = 0 C -- Allocate Step2node on each proc CALL MUMPS_REALLOC(id%Step2node, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%Step2node (Solve)', MEMCNT=NBT, ERRCODE=-13) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C -- build Step2node on each proc; C -- this is usefull to have at each step a unique C -- representative node (associated with principal variable of C -- that node. IF (NBT.NE.0) THEN ! Step2node was reallocated and needs be recomputed DO I=1, id%N IF (id%STEP(I).LE.0) CYCLE ! nonprincipal variables id%Step2node(id%STEP(I)) = I ENDDO C ELSE C we reuse Step2node computed in a previous solve phase C Step2node is deallocated each time a new analysis is C performed or when job=-2 is called ENDIF C --- NBT is the nb of extra bytes allocated NB_BYTES = NB_BYTES + NBT NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) NB_BYTES_EXTRA = NB_BYTES_EXTRA + NBT C Mapping information used during solve. In case of several C facto+solve it has to be recomputed. C In case of several solves with the same C facto, it is not recomputed. C It is used to compute the interleaving C for A-1, and, in dev_version, passed to sol_c to compute C some stats IF((KEEP(235).NE.0).OR.(KEEP(237).NE.0)) THEN IF(.NOT.associated(id%IPTR_WORKING)) THEN C Not computed at a previous solve: C recompute id%IPTR_WORKING and id%WORKING CALL CMUMPS_BUILD_MAPPING_INFO(id) END IF idIPTR_WORKING => id%IPTR_WORKING idWORKING => id%WORKING ELSE C case of selected entries in solution C with no ES during fwd SIZE_WORKING = 1 SIZE_IPTR_WORKING = 1 idIPTR_WORKING => IDUMMY_TARGET idWORKING => IDUMMY_TARGET END IF ENDIF C C Initialize SIZE_OF_BLOCK from MUMPS_SOL_ES module IF ( I_AM_SLAVE ) THEN CALL CMUMPS_SOL_ES_INIT(id%OOC_SIZE_OF_BLOCK, id%KEEP(201)) ENDIF DO_NULL_PIV = .TRUE. NBCOL_INBLOC = -9998 NZ_THIS_BLOCK= -9998 JBEG_RHS = -9998 c IF (id%MYID.EQ.MASTER) THEN ! Compute NRHS_NONEMPTY C C -- Sparse RHS (general, centralized) IF ( KEEP(111)==0 .AND. KEEP(248)==1 & ) THEN C -- Note that KEEP(111).NE.0 (null space on) C -- and KEEP(248).NE.0 will be made incompatible C -- When computing entries of A-1 (or SparseRHS only) NRHS_NONEMPTY = 0 DO I=1, id%NRHS IF (id%IRHS_PTR(I).LT.id%IRHS_PTR(I+1)) THEN NRHS_NONEMPTY = NRHS_NONEMPTY+1 !ith col in non empty ENDIF ENDDO IF (NRHS_NONEMPTY.LE.0) THEN C Internal error: tested before in mumps_driver IF (LPOK) & WRITE(LP,*) " Internal Error 3 in solution driver ", & " NRHS_NONEMPTY= ", & NRHS_NONEMPTY CALL MUMPS_ABORT() ENDIF ELSE NRHS_NONEMPTY = id%NRHS ENDIF ENDIF C ------------------------------------ C If there is a special root node, C precompute mapping of root's master C ------------------------------------ SIZE_ROOT = -33333 IF ( KEEP( 38 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP( KEEP(38))), & KEEP(199) ) IF (id%MYID_NODES .eq. MASTER_ROOT) THEN SIZE_ROOT = idintr%root%TOT_ROOT_SIZE ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN C SIZE_ROOT also used for KEEP(221).NE.0 SIZE_ROOT=id%KEEP(116) ENDIF ELSE IF (KEEP( 20 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(KEEP(20))), & KEEP(199) ) IF (id%MYID_NODES .eq. MASTER_ROOT) THEN SIZE_ROOT = id%IS( & id%PTLUST_S(id%STEP(KEEP(20)))+KEEP(IXSZ) + 3) ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN C SIZE_ROOT also used for KEEP(221).NE.0 SIZE_ROOT=id%KEEP(116) ENDIF ELSE MASTER_ROOT = -44444 END IF C -------------- C Get block size C -------------- C We work on a maximum of NBRHS at a time. C The leading dimension of RHS is id%LRHS on the host process C and it is set to N on slave processes. IF (id%MYID .eq. MASTER) THEN C{ KEEP(84) = ICNTL(27) C Treating ICNTL(27)=0 as if ICNTL(27)=1 IF(ICNTL(27).EQ.0) KEEP(84)=1 IF (KEEP(252).NE.0) THEN ! Fwd in facto: all rhs (KEEP(253) need be processed in one pass NBRHS = KEEP(253) ELSE IF (KEEP(201) .EQ. 0 .OR. KEEP(84) .GT. 0) THEN NBRHS = abs(KEEP(84)) ELSE NBRHS = -2*KEEP(84) END IF IF (NBRHS .GT. NRHS_NONEMPTY ) NBRHS = NRHS_NONEMPTY C ENDIF C} ENDIF #if defined(V_T) CALL VTBEGIN(glob_comm_ini,IERR) #endif C NRHS_NONEMPTY needed on all procs to allocate RHSINTR on slaves CALL MPI_BCAST(NRHS_NONEMPTY,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(NBRHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) C IF (KEEP(201).GT.0) THEN C --- id%KEEP(201) indicates if OOC is on (=1) of not (=0) C -- 107: number of buffers C Define number of types of files (L, possibly U) WORKSPACE_MINIMAL_PREFERRED = .FALSE. IF (id%MYID .eq. MASTER) THEN KEEP(107) = max(0,KEEP(107)) IF ((KEEP(107).EQ.0).AND. & (KEEP(204).EQ.0).AND.(KEEP(211).NE.1) ) THEN C -- default setting for release 4.8 ! Case of ! -Emmergency buffer only and ! -Synchronous mode ! -NO_O_DIRECT (because of synchronous choice) ! THEN ! "Basic system-based version" ! We can force to allocate S to a minimal ! value. WORKSPACE_MINIMAL_PREFERRED=.TRUE. ENDIF ENDIF CALL MPI_BCAST( KEEP(107), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(204), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(208), 2, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( WORKSPACE_MINIMAL_PREFERRED, 1, & MPI_LOGICAL, & MASTER, id%COMM, IERR ) C --- end of OOC case ENDIF IF ( I_AM_SLAVE ) THEN C C NB_K133: Max number of simultaneously processed C active fronts. C Why more than one active node ? C 1/ In parallel when we start a level 2 node C then we do not know exactly when we will C have received all contributions from the C slaves. C This is very critical in OOC since the C size provided to the solve phase is C much smaller and since we need C to determine the size fo the buffers for IO. C We pospone the allocation of the block NFRONT*NB_NRHS C and solve the problem. C C C 2/ While processing a node and sending information C if we have not enough memory in send buffer C then we must receive. C We feel that this is not so critical. C NB_K133 = 3 C To this we must add one time KEEP(133) to store C the RHS of the root node if the root is local. C Furthermore this quantity has to be multiplied by the C blocking size in case of multiple RHS. IF ( KEEP( 38 ) .NE. 0 .OR. KEEP( 20 ) .NE. 0 ) THEN IF ( MASTER_ROOT .eq. id%MYID_NODES ) THEN IF ( & .NOT. associated(idintr%roota%RHS_CNTR_MASTER_ROOT) & ) THEN NB_K133 = NB_K133 + 1 ENDIF END IF ENDIF C -------------------------------------- C NRHS_COLS_SOL_C is the maximum number C of colums for the call to CMUMPS_SOL_C C -------------------------------------- NRHS_COLS_SOL_C = min(NRHS_NONEMPTY,NBRHS) C C LWCB8_MIN = int(NB_K133,8)*int(KEEP(133),8)* & int(NRHS_COLS_SOL_C,8) C ENDIF C --------------------------------------------------------------- C Set WK_USER_PROVIDED to true when workspace WK_USER is provided C We can accept WK_USER to be provided on only some process and C different values of WK_USER per process. WK_USER_PROVIDED = (id%LWK_USER.NE.0 .AND.I_AM_SLAVE) IF (WK_USER_PROVIDED) THEN IF (id%LWK_USER.GT.0) THEN ITMP8= int(id%LWK_USER,8) ELSE ITMP8 = -int(id%LWK_USER,8)* 1000000_8 ENDIF ELSE ITMP8 = 0_8 ENDIF CALL MPI_REDUCE ( ITMP8, SUM_ITMP8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) C Incore: Check if the provided size is equal to that used during C facto (case of ITMP8/=0 and KEEP8(24)/=ITMP8) C But also check case of space not provided during solve C but was provided during facto C (case of ITMP8=0 and KEEP8(24)/=0) IF (KEEP(201).EQ.0) THEN ! incore C Compare provided size with previous size IF (ITMP8.NE.KEEP8(24)) THEN C -- error when reusing space allocated INFO(1) = -41 INFO(2) = id%LWK_USER ENDIF ELSE KEEP8(24)=ITMP8 ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 IF (.NOT. I_AM_SLAVE) KEEP8(124)=SUM_ITMP8 C all procs: KEEP8(24) holds the size of WK_USER provided by user. C master only: KEEP8(124) indicates if WK_USER provided on some proc MAXS = 0_8 IF (I_AM_SLAVE) THEN IF (WK_USER_PROVIDED) THEN MAXS = KEEP8(24) IF (MAXS.LT. KEEP8(20)) THEN INFO(1)= -11 ! MAXS should be increased by at least ITMP8 ITMP8 = KEEP8(20)+1_8-MAXS CALL MUMPS_SET_IERROR(ITMP8, INFO(2)) ENDIF IF (INFO(1) .GE. 0 ) id%S => id%WK_USER(1:KEEP8(24)) ALLOCATE_S = .FALSE. ELSE IF (KEEP8(23) .GT. 0) THEN MAXS = KEEP8(23) C S is already allocated, of size KEEP8(23) ALLOCATE_S = .FALSE. ELSE IF (KEEP(201).EQ.0) THEN ! incore C id%S might have been freed during factorization and C reallocated of size KEEP8(31) ( if KEEP8(31)>0 ) IF (KEEP8(31).EQ.0) THEN MAXS = 1 ALLOCATE_S = .TRUE. ENDIF ELSE C -- OOC and WK_USER not provided: C define size (S) and allocate it C ---- modify size of MAXS: in a simple C ---- system-based version, we want to C ---- use a small size for MAXS, to C ---- avoid the system pagecache to be C ---- polluted by 'our memory' ALLOCATE_S = .TRUE. IF ( KEEP(209).EQ.-1 .AND. WORKSPACE_MINIMAL_PREFERRED) & THEN C We need space to load at least the largest factor MAXS = KEEP8(20) + 1_8 ELSE IF ( KEEP(209) .GE.0 ) THEN C Use suggested value of MAXS provided in KEEP(209) MAXS = max(int(KEEP(209),8), KEEP8(20) + 1_8) ELSE MAXS = id%KEEP8(14) ! initial value: do not use more than ! minimum (non relaxed) size of OOC facto ENDIF C MAXS = max(MAXS, id%KEEP8(20)+1_8) C --- end of OOC case ENDIF IF ( ALLOCATE_S ) THEN ALLOCATE (id%S(MAXS), stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID,': problem allocation of S ', & 'at solve' ENDIF INFO(1) = -13 CALL MUMPS_SET_IERROR(MAXS, INFO(2)) KEEP8(23)=0_8 ALLOCATE_S = .FALSE. ELSE KEEP8(23)=MAXS ENDIF NB_BYTES = NB_BYTES + KEEP8(23) * K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C IF (KEEP(201).EQ.0) THEN C On the slaves, S is divided as follows: C S(1..LA) holds the factors, C S(LA+1..MAXS) is free workspace LA = KEEP8(31) ELSE C MAXS has normally been dimensionned to store only factors. LA = MAXS IF(MAXS.GT.KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8))THEN C If we have a very large MAXS, the size reserved for C loading the factors into memory does not need to exceed the C total size of factors. The (KEEP8(20)*(KEEP(107)+1)) term C is here in order to ensure that even with round-off C problems (linked to the number of solve zones) factors can C all be stored in-core LA=KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8) ENDIF ENDIF C C We need to allocate a workspace of size LWCB8 for the solve phase. C Either it is available at the end of MAXS, or we perform a C dynamic allocation. IF ( MAXS-LA .GT. LWCB8_MIN & ) THEN LWCB8 = MAXS - LA WORK_WCB => id%S(LA+1_8:LA+LWCB8) WORK_WCB_ALLOCATED=.FALSE. ELSE LWCB8 = LWCB8_MIN ALLOCATE(WORK_WCB(LWCB8), stat=allocok) IF (allocok < 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(LWCB8,INFO(2)) ELSE WORK_WCB_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + LWCB8*K151_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C --------------------------------- C Space for the RHS of special root C --------------------------------- IF ( id%MYID_NODES .EQ. MASTER_ROOT ) THEN C This is a special root (otherwise MASTER_ROOT < 0) IF ( associated(idintr%roota%RHS_CNTR_MASTER_ROOT) ) THEN C RHS_CNTR_MASTER_ROOT may have been allocated C during the factorization phase. PTR_RHS_ROOT => idintr%roota%RHS_CNTR_MASTER_ROOT # if defined(MUMPS_NOF2003) LPTR_RHS_ROOT = & int(size(idintr%roota%RHS_CNTR_MASTER_ROOT),8) # else LPTR_RHS_ROOT = & size(idintr%roota%RHS_CNTR_MASTER_ROOT,kind=8) # endif ELSE C In this case, the space for RHS_CNTR_MASTER_ROOT C is always part of WORKWCB, which can itself be C part of id%S or not. LPTR_RHS_ROOT = NRHS_COLS_SOL_C * int(SIZE_ROOT,8) PTR_RHS_ROOT => WORK_WCB(LWCB8-LPTR_RHS_ROOT+1_8:LWCB8) C Reduce size of WORK_WCB LWCB8=LWCB8-LPTR_RHS_ROOT ENDIF ELSE LPTR_RHS_ROOT = 1_8 PTR_RHS_ROOT => CDUMMY_TARGET ENDIF ENDIF ! I_AM_SLAVE C ----------------------------------- 99 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 C ----------------------------------- IF ( I_AM_SLAVE ) THEN IF (KEEP(201).GT.0) THEN CALL CMUMPS_INIT_FACT_AREA_SIZE_S(LA) C -- This includes thread creation C -- for asynchronous strategies CALL CMUMPS_OOC_INIT_SOLVE(id%ICNTL(1), id%ICNTL(4), id%N, & id%NSLAVES, id%MYID, id%OOC_NB_FILE_TYPE, id%KEEP, id%KEEP8, & id%INFO, id%STEP, id%PROCNODE_STEPS, id%OOC_SIZE_OF_BLOCK, & id%OOC_INODE_SEQUENCE, id%OOC_VADDR, & id%OOC_MAX_NB_NODES_FOR_ZONE, id%OOC_TOTAL_NB_NODES, & id%OOC_NB_FILES, id%OOC_FILE_NAME_LENGTH, id%OOC_FILE_NAMES, & id%COMM_NODES, idintr%root%yes) IS_INIT_OOC_DONE = .TRUE. ENDIF ! KEEP(201).GT.0 ENDIF C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 C IF (I_AM_SLAVE) THEN IF (KEEP(485).EQ.1) THEN IF (.NOT. (associated(id%FDM_F_ENCODING))) THEN WRITE(*,*) "Internal error 18 in CMUMPS_SOL_DRIVER" CALL MUMPS_ABORT() ENDIF IF (.NOT. (associated(id%BLRARRAY_ENCODING))) THEN WRITE(*,*) "Internal error 19 in CMUMPS_SOL_DRIVER" CALL MUMPS_ABORT() ENDIF C Access to OOC data in module during solve CALL MUMPS_FDM_STRUC_TO_MOD('F',id%FDM_F_ENCODING) CALL CMUMPS_BLR_STRUC_TO_MOD(id%BLRARRAY_ENCODING) IS_LR_MOD_TO_STRUC_DONE = .TRUE. ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN C{ IF ( PROKG ) THEN WRITE( MPG, 150 ) C ICNTL(35) should not been accessed during SOLVE thus C print KEEP(486) value set during factorization & id%NRHS, NBRHS, ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30), KEEP(486), & ICNTL48_EFF IF (KEEP(111).NE.0) THEN WRITE (MPG, 151) KEEP(111) ENDIF IF (KEEP(221).NE.0) THEN WRITE (MPG, 152) KEEP(221) ENDIF IF (KEEP(252).GT.0) THEN ! Fwd during facto WRITE (MPG, 153) KEEP(252) ENDIF ENDIF C ==================================== C Define LSCAL, ICNTL10 and ICNTL11 C ==================================== LSCAL = (((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) .OR. ( & KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) ICNTL10 = ICNTL(10) ICNTL11 = ICNTL(11) C Values of ICNTL(11) out of range IF ((ICNTL11 .LT. 0).OR.(ICNTL11 .GE. 3)) THEN ICNTL11 = 0 IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) out of range' ENDIF CALL CMUMPS_SET_POSTPros ( & KEEP(1), ICNTL(1), NBRHS, MPG, PROKG, & ICNTL10, ICNTL11, POSTPros) C} -- end of test master END IF CALL MPI_BCAST(POSTPros,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) C We need the original matrix only in the case of C we want to perform IR or Error Analysis, i.e. if C POSTPros = TRUE MAT_ALLOC_LOC = 0 IF ( POSTPros ) THEN MAT_ALLOC_LOC = 1 C Check if the original matrix has been allocated. IF ( KEEP(54) .EQ. 0 ) THEN C The original matrix is centralized IF ( id%MYID .eq. MASTER ) THEN IF (KEEP(55).eq.0) THEN C Case of matrix assembled centralized IF (.NOT.associated(id%A) .OR. & (.NOT.associated(id%IRN)) .OR. & ( .NOT.associated(id%JCN))) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original centralized assembled', & ' matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ELSE C Case of matrix in elemental format IF (.NOT.associated(id%A_ELT).OR. & .NOT.associated(id%ELTPTR).OR. & .NOT.associated(id%ELTVAR)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original elemental matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ENDIF ENDIF !end master, centralized matrix ELSE C The original matrix is assembled distributed IF ( I_AM_SLAVE .AND. (id%KEEP8(29) .GT. 0_8) ) THEN C If MAT_ALLOC_LOC = 1 the local distributed matrix is C allocated, otherwise MAT_ALLOC_LOC = 0 IF ((.NOT.associated(id%A_loc)) .OR. & (.NOT.associated(id%IRN_loc)) .OR. & (.NOT.associated(id%JCN_loc))) THEN IF (PROK) WRITE(MP,'(A/,A,I5,I12)') & ' WARNING: original distributed matrix not allocated', & ' MPI rank, local nonzeros=', & id%MYID, id%KEEP8(29) MAT_ALLOC_LOC = 0 ENDIF ENDIF ENDIF ! end test allocation matrix (keep(54)) ENDIF ! POSTPros CALL MPI_REDUCE( MAT_ALLOC_LOC, MAT_ALLOC, 1, & MPI_INTEGER, & MPI_MIN, MASTER, id%COMM, IERR) IF ( POSTPros.and.(id%MYID .eq. MASTER) ) THEN C if postprocessing requested matrix must be allocated IF (MAT_ALLOC.EQ.0) THEN IF (KEEP(54).NE.0) THEN C Write on MPG this time (we wrote on MP before in C case of distributed matrix and wrote on MPG already C in case of centralized matrix) IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original distributed matrix is not allocated' ENDIF POSTPros = .FALSE. ICNTL11 = 0 ICNTL10 = 0 C Write a warning. IF ((ICNTL(10) .NE. 0) .AND. (ICNTL10 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0' ENDIF IF ((ICNTL(11) .EQ. 1).OR.(ICNTL(11) .EQ. 2) & .AND.(ICNTL11 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF ENDIF IF (POSTPros) THEN ALLOCATE(SAVERHS(id%N*NBRHS),stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Problem in solve: error allocating SAVERHS' ENDIF INFO(1) = -13 INFO(2) = id%N*NBRHS END IF NB_BYTES = NB_BYTES + int(size(SAVERHS),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C C Forbid entries in a-1, in case of null space computations c IF (KEEP(237).NE.0 .AND.KEEP(111).NE.0) THEN C Ignore ENTRIES IN A-1 in case we compute C vectors of the null space (KEEP(111)).NE.0.) C We should still allocate IRHS_SPARSE IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: KEEP(237) treated as if set to 0 (null space)' KEEP(237)=0 ENDIF C -- end of test master END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C -------------------------------------------------- C Broadcast information to have all processes do the C same thing (error analysis/iterative refinements/ C scaling/distribution of solution) C -------------------------------------------------- CALL MPI_BCAST(ICNTL10,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(ICNTL11,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(POSTPros,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) CALL MPI_BCAST(LSCAL,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) CALL MPI_BCAST(KEEP(237),1,MPI_INTEGER,MASTER, & id%COMM,IERR) #if ! defined(USE_OLD_SCALING) C ---------------------------------------------- C Initialize SCALING_LOC_FWD and SCALING_LOC_BWD C They corespond to all pivots factorized on a C given MPI process and point to a dummy array C of size 1 on the host of if no pivot was C factorized (KEEP(89))=0 C ---------------------------------------------- IF (LSCAL .AND. id%KEEP(89) .GT. 0) THEN IF (MTYPE .EQ. 1) THEN SCALING_LOC_FWD => id%ROWSCA_loc SCALING_LOC_BWD => id%COLSCA_loc ELSE SCALING_LOC_FWD => id%COLSCA_loc SCALING_LOC_BWD => id%ROWSCA_loc ENDIF ELSE ! includes non working master on which KEEP(89)=0 SCALING_LOC_FWD => RDUMMY_TARGET SCALING_LOC_BWD => RDUMMY_TARGET ENDIF C Remarks related to scalings: C * During postprocessing, one performs solves C with alternatively A and A^T, meaning that C SCALING_LOC_FWD and SCALING_LOC_BWD will C be redefined. C * In case of exploit sparsity, RHSINTR may C have less rows than ROWSCA_loc/COLSCA_loc. C SCALING_RHSINTR_FWD and SCALING_RHSINTR_BWD C will then be extracted from C SCALING_LOC_FWD and SCALING_LOC_BWD thanks C to the subroutine CMUMPS_SCALINGRHSINTR #endif C KEEP(248)==1 if not_NullSpace (KEEP(111)=0) C and sparse RHS on input (id%ICNTL(20)/KEEP(248)==1) C (KEEP(248)==1 implies KEEP(111) = 0, otherwise error was raised) C We cant thus isolate the case of C sparse RHS associated to Null space computation because C in this case preparation is different since C -we skip the forward step and C -the pattern of the RHS C of the bwd is related to null pivot indices found and not C to information contained in the sparse rhs input format. DO_PERMUTE_RHS = (KEEP(242).NE.0) C apply interleaving in parallel (FOR A-1 or Null space only) IF ( (id%NSLAVES.GT.1) .AND. (KEEP(243).NE.0) & ) THEN C -- Option to interleave RHS only makes sense when C -- A-1 option is on or Null space compution are on C (note also that KEEP(243).NE.0 only when PERMUTE_RHS is on) IF ((KEEP(237).NE.0).or.(KEEP(111).GT.0)) THEN INTERLEAVE_PAR= .TRUE. IF (KEEP(237).EQ.1) THEN IF (NRHS_NONEMPTY.LT.2*NBRHS) THEN INTERLEAVE_PAR= .FALSE. ENDIF ENDIF ELSE IF (PROKG) THEN write(MPG,*) ' Warning incompatible options ', & ' interleave RHS reset to false ' ENDIF ENDIF ENDIF CALL MUMPS_BUF_INIT( id%KEEP( 34 ), id%KEEP(151) ) C -------------------------------------- C Compute an upperbound of message size C for forward and backward solutions: C -------------------------------------- MSG_MAX_BYTES_SOLVE8 = int(( 4 + KEEP(133) ) * KEEP(34),8) + & int(KEEP(133)*KEEP(151),8) * int(NBRHS,8) & + int(16*KEEP(34),8) ! for request id, pointer to next + safety IF ( MSG_MAX_BYTES_SOLVE8 .GT. & int(huge(I4),8)) THEN INFO(1) = -18 C Max NBRHS to avoid overflow: INFO(2) = ( huge(I4) - & ( 16 + 4 + KEEP(133) ) * KEEP(34) ) / & ( KEEP(133) * KEEP(151) ) ENDIF IF (INFO(1) .LT.0 ) GOTO 111 MSG_MAX_BYTES_SOLVE = int(MSG_MAX_BYTES_SOLVE8) C ------------------------------------------ C Compute an upperbound of message size C for CMUMPS_GATHER_SOLUTION. Except C possibly on the non working host, it C should be smaller than MSG_MAX_BYTES_SOLVE C ------------------------------------------ IF (KEEP(237).EQ.0) THEN C Note that for CMUMPS_GATHER_SOLUTION LBUFR buffer should C be larger that MAX_inode(NPIV))*NBRHS + NPIV C which is covered by next formula since KMAX_246_247 is larger C than MAX_inode(NPIV)) C 2 integers packed (npiv and termination) C Note that MSG_MAX_BYTES_GTHRSOL < MSG_MAX_BYTES_SOLVE C so that it should not overflow KMAX_246_247 = max(KEEP(246),KEEP(247)) MSG_MAX_BYTES_GTHRSOL = ( 2 + KMAX_246_247 ) * KEEP(34) + & KMAX_246_247 * NBRHS * KEEP(149) ELSE IF (ICNTL21.EQ.0) THEN C Each message from a slave is of size max 4: C 2 integers : I,J C 1 complex : (Aij)-1 C 1 terminaison MSG_MAX_BYTES_GTHRSOL = ( 3 * KEEP(34) + KEEP(149) ) ELSE C Not needed in case of distributed solution and A-1 C because the entries of A −1 are C returned in RHS SPARSE on the host. MSG_MAX_BYTES_GTHRSOL = 0 ENDIF C The buffer is used both for solve and for CMUMPS_GATHER_SOLUTION LBUFR_BYTES = max(MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL) TSIZE = int(min(100_8*int(MSG_MAX_BYTES_GTHRSOL,8), & 10000000_8)) LBUFR_BYTES = max(LBUFR_BYTES,TSIZE) LBUFR = ( LBUFR_BYTES + KEEP(34) - 1 ) / KEEP(34) ALLOCATE (BUFR(LBUFR),stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ' Problem in solve: error allocating BUFR' ENDIF INFO(1) = -13 INFO(2) = LBUFR GOTO 111 ENDIF NB_BYTES = NB_BYTES + int(size(BUFR),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( I_AM_SLAVE .AND. id%NSLAVES .GT. 1 ) THEN C ------------------------------------------------------ C Dimension send buffer for small integers, e.g. TRACINE C ------------------------------------------------------ CMUMPS_LBUF_INT = ( 20 + id%NSLAVES * id%NSLAVES * 4 ) & * KEEP(34) CALL MUMPS_BUF_ALLOC_SMALL_BUF( CMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = CMUMPS_LBUF_INT IF ( LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating small Send buffer:IERR=',IERR END IF GOTO 111 END IF C C --------------------------------------- C Dimension cyclic send buffer for normal C messages, based on largest message C size during forward and backward solves C --------------------------------------- C Compute buffer size in BYTES (CMUMPS_LBUF) C using integer8 in CMUMPS_LBUF_8 C then convert it in integer4 and bound it to largest integer value C CMUMPS_LBUF_8 = & (int(MSG_MAX_BYTES_SOLVE,8)+2_8*int(KEEP(34),8))* & int(id%NSLAVES,8) C Avoid buffers larger than 100 Mbytes ... CMUMPS_LBUF_8 = min(CMUMPS_LBUF_8, 100000000_8) C ... as long as we can send messages to at least 3 C destinations simultaneously CMUMPS_LBUF_8 = max(CMUMPS_LBUF_8, & int((MSG_MAX_BYTES_SOLVE+2*KEEP(34)),8) * & int(min(id%NSLAVES,3),8) ) CMUMPS_LBUF_8 = CMUMPS_LBUF_8 + 2_8*int(KEEP(34),8) C Convert to integer and bound it to largest 32-bit integer C and suppress 10 integers (one should be enough!) C to enable computation of integer size. CMUMPS_LBUF_8 = min(CMUMPS_LBUF_8, & int(huge(I4),8) & - 10_8*int(KEEP(34),8) & ) CMUMPS_LBUF = int(CMUMPS_LBUF_8, kind(CMUMPS_LBUF)) CALL MUMPS_BUF_ALLOC_CB( CMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = CMUMPS_LBUF/KEEP(34) + 1 IF ( LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating Send buffer:IERR=', IERR END IF GOTO 111 END IF C C C -- end of I am slave ENDIF C IF ( POSTPros ) THEN C When Iterative refinement of error analysis requested C Allocate RHS_IR on slave processors C (note that on MASTER RHS_IR points to RHS) IF ( id%MYID .NE. MASTER ) THEN C ALLOCATE(RHS_IR(id%N),stat=IERR) NB_BYTES = NB_BYTES + int(size(RHS_IR),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( IERR .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) THEN WRITE(LP,*) 'ERROR while allocating RHS on a slave' ENDIF GOTO 111 END IF ELSE RHS_IR=>id%RHS ENDIF ENDIF C C Parallel A-1 or General sparse and C exploit sparsity between columns DO_NBSPARSE = ( ( (KEEP(237).NE.0).OR.(KEEP(235).NE.0) ) & .AND. & ( KEEP(497).NE.0 ) & ) IF ( I_AM_SLAVE ) THEN IF(DO_NBSPARSE) THEN c --- ALLOCATE outside loop RHS_BOUNDS is needed LPTR_RHS_BOUNDS = 2*KEEP(28) ALLOCATE(RHS_BOUNDS(LPTR_RHS_BOUNDS), STAT=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=LPTR_RHS_BOUNDS IF (LPOK) THEN WRITE(LP,*) 'ERROR while allocating RHS_BOUNDS on', & ' a slave' ENDIF GOTO 111 END IF NB_BYTES = NB_BYTES + & int(size(RHS_BOUNDS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) PTR_RHS_BOUNDS => RHS_BOUNDS ELSE LPTR_RHS_BOUNDS = 1 PTR_RHS_BOUNDS => IDUMMY_TARGET ENDIF ENDIF C -------------------------------------------------- IF ( I_AM_SLAVE ) THEN IF ((KEEP(221).EQ.2 .AND. KEEP(252).EQ.0)) THEN C -- RHSINTR must have been allocated in C -- previous solve step (with option KEEP(221)=1) IF (.NOT.associated(id%RHSINTR)) THEN INFO(1) = -35 INFO(2) = 1 GOTO 111 ENDIF C IF ((KEEP(248).EQ.0) .OR. (id%NRHS.EQ.1)) THEN C GLOB2LOC_RHS/SOL are meaningful and could even be reused IF (.NOT.associated(id%GLOB2LOC_RHS) ) ! .OR. ! & .NOT.(id%GLOB2LOC_SOL_ALLOC)) & THEN INFO(1) = -35 INFO(2) = 2 GOTO 111 ENDIF IF (.not.id%GLOB2LOC_SOL_ALLOC) THEN C GLOB2LOC_SOL that is kept from C previous call to solve must then (already) C point to id%GLOB2LOC_RHS id%GLOB2LOC_SOL => id%GLOB2LOC_RHS ENDIF ELSE C ---------------------- C Allocate GLOB2LOC_RHS/SOL C ---------------------- C The size of POSINRHSINTR arrays C does not depend on the block of RHS C GLOB2LOC_RHS/SOL are initialized in the loop of RHS IF (associated(id%GLOB2LOC_RHS)) THEN NB_BYTES = NB_BYTES - & int(size(id%GLOB2LOC_RHS),8)*K34_8 DEALLOCATE(id%GLOB2LOC_RHS) ENDIF ALLOCATE (id%GLOB2LOC_RHS(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 END IF NB_BYTES = NB_BYTES + & int(size(id%GLOB2LOC_RHS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%GLOB2LOC_SOL_ALLOC) THEN NB_BYTES = NB_BYTES - & int(size(id%GLOB2LOC_SOL),8)*K34_8 DEALLOCATE(id%GLOB2LOC_SOL) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF C IF ( (KEEP(50).EQ.0).OR.(KEEP(237).NE.0).OR. & (KEEP(212).NE.0) & ) THEN ALLOCATE (id%GLOB2LOC_SOL(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 END IF id%GLOB2LOC_SOL_ALLOC = .TRUE. NB_BYTES = NB_BYTES + & int(size(id%GLOB2LOC_SOL),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE C Do no allocate GLOB2LOC_SOL id%GLOB2LOC_SOL => id%GLOB2LOC_RHS id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF IF (KEEP(221).NE.2) THEN C -- only in the case of bwd after C -- fwd only (with or without Schur) C -- we have to keep "old" RHSINTR IF (associated(id%RHSINTR)) THEN NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25) = 0_8 id%LD_RHSINTR = 0 ENDIF ENDIF ENDIF C --------------------------- C Allocate local workspace C for the solve (CMUMPS_SOL_C) C --------------------------- LIWK_SOLVE = 2 * KEEP(28) + id%NA(1)+1 LIWK_PTRACB= KEEP(28) C KEEP(228)+1 temporary integer positions C will be needed in CMUMPS_SOL_S IF (KEEP(201).EQ.1) THEN LIWK_SOLVE = LIWK_SOLVE + KEEP(228) + 1 ELSE C Reserve 1 position to pass array of size 1 in routines LIWK_SOLVE = LIWK_SOLVE + 1 ENDIF ALLOCATE ( IWK_SOLVE(LIWK_SOLVE), & PTRACB(LIWK_PTRACB), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWK_SOLVE + LIWK_PTRACB*KEEP(10) GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWK_SOLVE,8)*K34_8 + & int(LIWK_PTRACB,8)*K34_8 *int(KEEP(10),8) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C array IWCB used temporarily to hold C indices of a front unpacked from a message C and to stack (potentially in a recursive call) C headers of size 2 positions of CB blocks. LIWCB = 20*NB_K133*2 + KEEP(133) ALLOCATE ( IWCB( LIWCB), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWCB GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWCB,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C C -- Code for a slave C ----------- C Subdivision C of array IS C ----------- LIW = KEEP(32) C Define a work array of size maximum global frontal C size (KEEP(133)) for the call to CMUMPS_SOL_C C This used to be of size id%N. ALLOCATE(SRW3(KEEP(133)), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=KEEP(133) GOTO 111 END IF NB_BYTES = NB_BYTES + int(KEEP(133),8)*K151_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ----------------- C End of slave code C ----------------- ELSE C I am the master with host not working C C LIW is used on master when calling C the routine CMUMPS_GATHER_SOLUTION. LIW=0 END IF C C Precompute inverse of UNS_PERM outside loop IF (allocated(UNS_PERM_INV)) DEALLOCATE(UNS_PERM_INV) UNS_PERM_INV_NEEDED_INMAINLOOP = .FALSE. IF ( ( id%MYID .eq. MASTER.AND.(KEEP(23).GT.0) .AND. & (MTYPE .NE. 1).AND.(KEEP(248).NE.0) & ) C Permute UNS_PERM on master only with C sparse RHS (KEEP(248).NE.0 ) when AT x = b is solved & .OR. ( KEEP(237).NE.0 .AND. KEEP(23).NE.0 ) C When A-1 is active and when the matrix is unsymmetric C and a column permutation has been applied (Max transversal) C then we have performed a C factorization of a column permuted matrix AQ = LU. C In this case, C the permuted entry must be used to select the target C entries for the BWD (note that a diagonal entry of A-1 C is not anymore a diagonal of AQ. Thus a diagonal C of A-1 does not correspond to the same path C in the tree during FWD and BWD steps when MAXTRANS is on C and permutation is not identity.) C Note that the inverse permutation C UNS_PERM_INV needs to be allocated on each proc C since it is used in CMUMPS_SOL_C routine for pruning. C It is allocated only once and its allocation has been C migrated outside the blocking on the right hand sides. & ) THEN UNS_PERM_INV_NEEDED_INMAINLOOP = .TRUE. ENDIF UNS_PERM_INV_NEEDED_BEFMAINLOOP = .FALSE. IF (KEEP(23) .GT. 0 .AND. MTYPE.EQ.1 .AND. ICNTL21.EQ.2) THEN UNS_PERM_INV_NEEDED_INMAINLOOP = .TRUE. ENDIF IF ( KEEP(23) .GT.0 .AND. & MTYPE .NE. 1 .AND. KEEP(248).EQ.-1 ) THEN C Similar to sparse RHS case, we need to modify IRHS_loc C indices in the distributed RHS case. However, we need C UNS_PERM_INV on all processors. But only before the C main loop on the RHS blocks. UNS_PERM_INV_NEEDED_BEFMAINLOOP = .TRUE. ENDIF C UNS_PERM_INV_NEEDED_ONSLAVES = .FALSE. IF ( UNS_PERM_INV_NEEDED_INMAINLOOP .OR. & UNS_PERM_INV_NEEDED_BEFMAINLOOP ) THEN C We need UNS_PERM_INV ALLOCATE(UNS_PERM_INV(id%N),stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 endif NB_BYTES = NB_BYTES + int(id%N,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.EQ.MASTER) THEN C Build inverse permutation DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I ENDDO ENDIF C ELSE ALLOCATE(UNS_PERM_INV(1), stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=1 GOTO 111 endif NB_BYTES = NB_BYTES + 1_8*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C 111 CONTINUE #if defined(V_T) CALL VTEND(glob_comm_ini,IERR) #endif C C Synchro point + Broadcast of errors C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C C UNS_PERM_INV needed on slaves: IF ( KEEP(23).NE.0 .AND. & ( KEEP(237).NE.0 .OR. & ( MTYPE.NE.1 .AND. KEEP(248).EQ.-1 ) .OR. & ( MTYPE.EQ.1 .AND. ICNTL21.EQ.2) & ) & ) THEN UNS_PERM_INV_NEEDED_ONSLAVES = .TRUE. ENDIF IF (UNS_PERM_INV_NEEDED_ONSLAVES) THEN C Broadcast UNS_PERM_INV CALL MPI_BCAST( UNS_PERM_INV,id%N,MPI_INTEGER,MASTER, & id%COMM,IERR ) ENDIF C ------------------------------- C BEGIN C Preparation for distributed RHS C ------------------------------- IF (I_AM_SLAVE .AND. KEEP(248).EQ.-1 & ) THEN C Distributed RHS case ALLOCATE(MAP_RHS_loc(max(id%Nloc_RHS,1)), stat=allocok) IF (allocok .GT. 0) THEN id%INFO(1)=-13 id%INFO(2)=max(id%Nloc_RHS,1) GOTO 20 ENDIF NB_BYTES = NB_BYTES + max(int(id%Nloc_RHS,8),1_8)*K34_8 ENDIF C MAP_RHS_loc will be built in the main C loop, when processing the first block. C It requires POSINRHSINTR to be built. BUILD_RHSMAPINFO = .TRUE. 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT.0 ) GOTO 90 C In case of Unsymmetric column permutation and C transpose system, use MUMPS internal indices C for IRHS_loc_PTR. Done before scaling since C scaling is on permuted matrix IF ( I_AM_SLAVE .AND. KEEP(23).GT.0 .AND. KEEP(248).EQ.-1 & .AND. MTYPE.NE.1 & ) THEN IF (id%Nloc_RHS .GT. 0) THEN ALLOCATE(IRHS_loc_PTR(id%Nloc_RHS),stat=allocok) IF (allocok.GT.0) THEN INFO(1)=-13 INFO(2)=id%Nloc_RHS GOTO 25 ENDIF IRHS_loc_PTR_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + max(int(id%Nloc_RHS,8),1_8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) DO I=1, id%Nloc_RHS IF (id%IRHS_loc(I).GE.1 .AND. id%IRHS_loc(I).LE.id%N) & THEN IRHS_loc_PTR(I)=UNS_PERM_INV(id%IRHS_loc(I)) ELSE C Keep track of out-of range entries IRHS_loc_PTR(I)=id%IRHS_loc(I) ENDIF ENDDO ENDIF ENDIF C Check if UNS_PERM_INV still needed C to free memory IF (UNS_PERM_INV_NEEDED_BEFMAINLOOP .AND. & .NOT. UNS_PERM_INV_NEEDED_INMAINLOOP) THEN NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 DEALLOCATE(UNS_PERM_INV) ALLOCATE(UNS_PERM_INV(1)) ! to posibly pass it as an argument NB_BYTES = NB_BYTES + K34_8 ENDIF #if defined(USE_OLD_SCALING) IF (LSCAL .AND. id%KEEP(248).EQ.-1 & ) THEN C Scaling done based on original indices C provided by user IF (MTYPE == 1) THEN C No transpose scaling_data_dr%SCALING=>id%ROWSCA ELSE C Transpose scaling_data_dr%SCALING=>id%COLSCA ENDIF CALL CMUMPS_SET_SCALING_LOC( scaling_data_dr, id%N, & IRHS_loc_PTR(1), id%Nloc_RHS, & id%COMM, id%MYID, I_AM_SLAVE, MASTER, & NB_BYTES, NB_BYTES_MAX, K16_8, LP, LPOK, & ICNTL(1), INFO(1) ) ENDIF #endif C ------------------------------- C END C Preparation for distributed RHS C ------------------------------- 25 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT.0 ) GOTO 90 C ------------------------------------- C BEGIN C Preparation for distributed solution C ------------------------------------- IF ( ICNTL21 .NE. 0 ) THEN C{ #if defined(USE_OLD_SCALING) IF (LSCAL) THEN C{ In case of scaling we will need to scale C back the sol. Put the values of the scaling C arrays needed to do that on each processor. IF (id%MYID.NE.MASTER) THEN IF (MTYPE == 1) THEN ALLOCATE(id%COLSCA(id%N),stat=allocok) ELSE ALLOCATE(id%ROWSCA(id%N),stat=allocok) ENDIF IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating temporary scaling array' ENDIF INFO(1)=-13 INFO(2)=id%N GOTO 37 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ! MYID .NE. MASTER 37 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data_sol%SCALING_LOC(max(1,id%KEEP(89))), & stat=allocok) IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating local scaling array' ENDIF INFO(1)=-13 INFO(2)=max(1,id%KEEP(89)) GOTO 38 ENDIF IF (ICNTL21.NE.0) THEN C Real entries for scaling NB_BYTES = NB_BYTES + int(max(1,id%KEEP(89)),8)*K16_8 ENDIF NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ! I_AM_SLAVE 38 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) THEN GOTO 90 ENDIF IF (MTYPE == 1) THEN CALL MPI_BCAST(id%COLSCA(1),id%N, & MPI_REAL,MASTER, & id%COMM,IERR) scaling_data_sol%SCALING=>id%COLSCA ELSE CALL MPI_BCAST(id%ROWSCA(1),id%N, & MPI_REAL,MASTER, & id%COMM,IERR) scaling_data_sol%SCALING=>id%ROWSCA ENDIF C} ENDIF ! LSCAL #endif IF ( ICNTL21.EQ.1 .AND. I_AM_SLAVE & ) THEN C -------------------------------- C Prepare ISOL_loc array #if defined(USE_OLD_SCALING) C and on the fly, scaling_data_sol #endif C -------------------------------- LIW_PASSED=max(1,LIW) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF (KEEP(89) .GT. 0) THEN CALL CMUMPS_DISTSOL_INDICES( MTYPE, id%ISOL_loc(1), & id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%IS(1), LIW_PASSED,id%MYID_NODES, & id%N, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES, #if defined(USE_OLD_SCALING) & scaling_data_sol, LSCAL, #endif C For checking only & (KEEP(248).EQ.-1), IRHS_loc_PTR(1), id%Nloc_RHS & ) ENDIF ENDIF ! I_AM_SLAVE #if defined(USE_OLD_SCALING) #endif #if defined(USE_OLD_SCALING) IF (id%MYID.NE.MASTER .AND. LSCAL) THEN C --------------------------------- C Local (small) scaling arrays have C been built, free temporary copies C --------------------------------- IF (MTYPE == 1) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ELSE DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF NB_BYTES = NB_BYTES - int(id%N,8)*K16_8 ENDIF #endif C} ENDIF ! ICNTL21 .NE. 0 IF (ICNTL21 .EQ.1) THEN C --------------------------------------------------- C Take into account unsymmetric permutation to modify C ISOL_loc, in case ISOL_loc is provided by MUMPS C --------------------------------------------------- IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN C Broadcast the unsymmetric permutation and C permute the indices in ISOL_loc IF (id%MYID.NE.MASTER) THEN ALLOCATE(id%UNS_PERM(id%N),stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=id%N GOTO 40 ENDIF ENDIF ENDIF C C ===================== ERROR handling and propagation ================ 40 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN CALL MPI_BCAST(id%UNS_PERM(1),id%N,MPI_INTEGER,MASTER, & id%COMM,IERR) IF (I_AM_SLAVE) THEN DO I=1, KEEP(89) id%ISOL_loc(I) = id%UNS_PERM(id%ISOL_loc(I)) ENDDO ENDIF IF (id%MYID.NE.MASTER) THEN DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF ENDIF ENDIF ! ICNTL(21)=1 C -------------------------------------- C Preparation for distributed solution C END C -------------------------------------- C --------------------------------------------- C In case of Schur, preparation for reduced RHS C --------------------------------------------- IF ( (KEEP(60).NE.0) .AND. & ( & ( KEEP(221) .EQ. 1 ) .OR. & ( KEEP(221) .EQ. 2 ) & ) & ) THEN C -- First compute MASTER_ROOT_IN_COMM proc number in C COMM_NODES on which is mapped the master of the root. IF (KEEP(46).EQ.1) THEN MASTER_ROOT_IN_COMM=MASTER_ROOT ELSE MASTER_ROOT_IN_COMM =MASTER_ROOT+1 ENDIF IF ( id%MYID .EQ. MASTER ) THEN C -------------------------------- C Avoid using LREDRHS when id%NRHS is C equal to 1, as was done for RHS C -------------------------------- IF (id%NRHS.EQ.1) THEN LD_REDRHS = id%KEEP(116) ELSE LD_REDRHS = id%LREDRHS ENDIF ENDIF IF (MASTER.NE.MASTER_ROOT_IN_COMM) THEN C -- Make available LD_REDRHS on MASTER_ROOT_IN_COMM C This will then be used to test if a single C message can be sent C (this is possible if LD_REDRHS=SIZE_SCHUR) IF ( id%MYID .EQ. MASTER ) THEN C -- send LD_REDRHS to MASTER_ROOT_IN_COMM C using COMM communicator CALL MPI_SEND(LD_REDRHS,1,MPI_INTEGER, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSEIF ( id%MYID.EQ.MASTER_ROOT_IN_COMM) THEN C -- recv LD_REDRHS CALL MPI_RECV(LD_REDRHS,1,MPI_INTEGER, & MASTER, 0, id%COMM,STATUS,IERR) ENDIF C -- other procs not concerned ENDIF ENDIF C IF ( KEEP(248)==1 & ) THEN ! Sparse RHS (A-1 or general sparse) ! JBEG_RHS - current starting column within A-1 or sparse rhs ! set in the loop below and used to obtain the ! global index of the column of the sparse RHS ! Also used to get index in global permutation. ! It also allows to skip empty columns; JEND_RHS = 0 ! last column in current blockin A-1 C C Compute and apply permutations IF (DO_PERMUTE_RHS) THEN C Allocate PERM_RHS ALLOCATE(PERM_RHS(id%NRHS),stat=allocok) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = id%NRHS GOTO 109 ENDIF NB_BYTES = NB_BYTES + int(id%NRHS,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.EQ.MASTER) THEN C PERM_RHS is computed on MASTER, it might be modified C in case of interleaving and will thus be distributed C (BCAST) to all slaves only later. C Compute PERM_RHS C on output: PERM_RHS(k) = i means that i is the kth column C to be processed IF (KEEP(237).EQ.0) THEN C Permute RHS : case of GS (General Sparse) RHS C IRHS_SPARSE is of size at least NZ_RHS > 0 C since all this is skipped when NZ_RHS=0. So C accessing IRHS_SPARSE(1) is ok. CALL CMUMPS_PERMUTE_RHS_GS( & LP, LPOK, PROKG, MPG, KEEP(242), & id%SYM_PERM(1), id%N, id%NRHS, & id%IRHS_PTR(1), id%NRHS+1, & id%IRHS_SPARSE(1), id%NZ_RHS, & PERM_RHS, IERR) IF (IERR.LT.0) THEN INFO(1) = -9999 INFO(2) = IERR GOTO 109 ! propagate error ENDIF ELSE C Case of A-1 : C We compute the permutation of the RHS (sparse matrix) C (to compute all inverse entries) C We apply permutation to IRHS_SPARSE ONLY. C Note NRHS_NONEMPTY holds the nb of non empty columns C in A-1. STRAT_PERMAM1 = KEEP(242) CALL CMUMPS_PERMUTE_RHS_AM1 & (STRAT_PERMAM1, id%SYM_PERM(1), & id%IRHS_PTR(1), id%NRHS+1, & PERM_RHS, id%NRHS, & IERR & ) ENDIF ENDIF ENDIF ENDIF C C Note that within CMUMPS_SOL_C, PERM_RHS could be used C for A-1 case (with DO_PERMUTE_RHS OR INTERLEAVE_RHS C being tested) to get the column index for the C original matrix of RHS (column index in A-1) C of the permuted columns that have been selected. C PERM_RHS is also used in CMUMPS_GATHER_SOLUTION C in case of sparse RHS awith DO_PERMUTE_RHS. C C Allocate PERM_RHS of size 1 if not allocated IF (.NOT. allocated(PERM_RHS)) THEN ALLOCATE(PERM_RHS(1),stat=allocok) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = 1 GOTO 109 ENDIF NB_BYTES = NB_BYTES + int(size(PERM_RHS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C Propagate errors 109 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 c -------------------------- c -------------------------- IF (id%NSLAVES .EQ. 1) THEN C{ - In case of NS/A-1 we may want to permute RHS C - for NS thus is to apply permutation to PIVNUL_LIST C - before starting loop of NBRHS IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN C NOTE: C when host not working both master and slaves have C in this case the complete list WRITE(*,*) id%MYID, ':INTERNAL ERROR 1 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF ! End Permute_RHS C} ELSE IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 2 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() C ENDIF ! End DO_PERMUTE_RHS IF (INTERLEAVE_PAR.AND. (KEEP(111).NE.0)) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 3 : ', & ' INTERLEAVE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF IF (INTERLEAVE_PAR.AND.KEEP(111).EQ.0 & ) THEN C - A-1 + Interleave: C permute RHS on master IF (id%MYID.EQ.MASTER) THEN C -- PERM_RHS must have been already set or initialized C -- it is then modified in next routine SIZE_WORKING = id%IPTR_WORKING(id%NPROCS+1)-1 SIZE_IPTR_WORKING = id%NPROCS+1 CALL CMUMPS_INTERLEAVE_RHS_AM1( & PERM_RHS, id%NRHS, & id%IPTR_WORKING(1), SIZE_IPTR_WORKING, & id%WORKING(1), SIZE_WORKING, & id%IRHS_PTR(1), & id%STEP(1), id%SYM_PERM(1), id%N, NBRHS, & id%PROCNODE_STEPS(1), KEEP(28), id%NSLAVES, & KEEP(199), & KEEP(493).NE.0, & KEEP(495).NE.0, KEEP(496), PROKG, MPG & ) ENDIF ! End Master ENDIF ! End A-1 and INTERLEAVE_PAR C ------------- ENDIF ! End Parallel Case c -------------------------- c IF (DO_PERMUTE_RHS.AND.(KEEP(111).EQ.0)) THEN C --- Distribute PERM_RHS before loop of RHS C --- (with null space option PERM_RHS is not allocated / needed C to permute the null column pivot list) CALL MPI_BCAST(PERM_RHS(1), & id%NRHS, & MPI_INTEGER, & MASTER, id%COMM,IERR) ENDIF C L0-threads to be activated iff KEEP(401)=1 and KEEP(400)>0 IF (KEEP(401) .EQ. 1) THEN C L0-threads was requested for solve phase C and will be effective only if KEEP(400) >0 C which indicates that L0-threads was C performed during analysis+factorization IF ( KEEP(400) .GT. 0 .AND. KEEP(369).EQ.0 ) THEN C{ Check if number of threads is consistent with C the one used during factorization for all procs C Note that if KEEP(369)>0 C KEEP(400) was set based on C KEEP(369) and KEEP(381) so that C omp_set_num_threads(KEEP(400)) will be called C explicitly before L0_OMP section C and KEEP(400) cannot be check here in this way C NOMP = 1 !$ NOMP=omp_get_max_threads() IF (KEEP(400).NE.NOMP) THEN C NOMP should be the one from analysis id%INFO(1) = -58 id%INFO(2) = KEEP(400) IF (LPOK) WRITE(LP,'(A,A,I5,A,I5)') &" FAILURE DETECTED IN SOLVE: #threads for multithreaded", &" tree parallelism changed from",KEEP(400)," at analysis to", & NOMP ENDIF C} ENDIF C error check CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 C} ENDIF IF (KEEP(400) .GT. 0) THEN CALL MUMPS_SOL_L0OMP_LI(KEEP(400)) ENDIF C ============================== C MAIN LOOP: C BLOCKING ON the number of RHS C We work on a maximum of NBRHS at a time. C the leading dimension of RHS is id%LRHS on master C and is set to N on slaves C ============================== C We may want to allow to have NBRHS that varies C this is typically the case when a partitionning of C the right hand side is performed and leads to C irregular partitions. C We only have to be sure that the size of each partition C is smaller than NBRHS. BEG_RHS=1 DO WHILE (BEG_RHS.LE.NRHS_NONEMPTY) C { CALL MUMPS_STOP_ON_USER_REQUEST( id%KEEP, id%KEEP8, id%ICNTL, & id%INFO, id%MYID ) CALL MUMPS_PROPINFO( id%ICNTL, id%INFO, id%COMM, id%MYID ) IF (id%INFO(1). LT. 0) GOTO 90 C ========================== C -- NBRHS : Original block size C -- BEG_RHS : Column index of the first RHS in the list of C non empty RHS (RHS_loc) to C be processed during this iteration C -- NBRHS_EFF : Effective block size at current iteration C that will be set to nb of contiguous non empty C columns C In case of sparse RHS (KEEP(248)==1) NBRHS_EFF only refers to C non-empty columns and is used to compute NBCOL_INBLOC C -- NBCOL_INBLOC : the number of columns of sparse RHS needed C to get NBRHS_EFF non empty columns columns of C sparse RHS processed at each step C NBRHS_EFF = min(NRHS_NONEMPTY-BEG_RHS+1, NBRHS) C C Sparse RHS C Free space and reset pointers if needed IF (IRHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_SPARSE_COPY),8)*K34_8 DEALLOCATE(IRHS_SPARSE_COPY) IRHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_SPARSE_COPY) ENDIF IF (IRHS_PTR_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_PTR_COPY),8)*K34_8 DEALLOCATE(IRHS_PTR_COPY) IRHS_PTR_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_PTR_COPY) ENDIF IF (RHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(RHS_SPARSE_COPY),8)*K35_8 DEALLOCATE(RHS_SPARSE_COPY) RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_SPARSE_COPY) ENDIF C C =========================================================== C Set LD_RHS and IBEG for the accesses to id%RHS (in cases C id%RHS is accessed). Remark that IBEG might still be C overwritten later, in case of general sparse right-hand side C and centralized solution to skip empty columns C =========================================================== IF ( C slave procs & ( id%MYID .NE. MASTER ) C even on master when RHS not allocated & .or. C Case of Master working but with distributed sol and C ( sparse RHS or null space ) C -- Allocate not needed on host not working & ( I_AM_SLAVE .AND. id%MYID .EQ. MASTER .AND. & ICNTL21 .NE.0 .AND. & ( KEEP(248).ne.0 .OR. KEEP(221).EQ.2 & .OR. KEEP(111).NE.0 ) & ) & .or. C Case of Master and C (compute entries of INV(A)) C Even when I am a master with host not working I C am in charge of gathering solution to scale it C and to copy it back in the sparse RHS format & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) C & ) THEN LD_RHS = id%N IBEG = 1 ELSE ! (id%MYID .eq. MASTER) IF ( associated(id%RHS) ) THEN C Leading dimension of RHS on master is id%LRHS LD_RHS = max(id%LRHS, id%N) ELSE C --- LRHS might not be defined (dont use it) LD_RHS = id%N ENDIF IBEG = int(BEG_RHS-1,8) * int(LD_RHS,8) + 1_8 ENDIF C JBEG_RHS might also be used in DISTRIBUTED_SOLUTION C even when RHS is not sparse on input. In this case, C there are no empty columns. (If RHS is sparse JBEG_RHS C is overwritten). JBEG_RHS = BEG_RHS C ========================================== C Shift empty columns in case of sparse RHS C ========================================== IF ( (id%MYID.EQ.MASTER) .AND. & KEEP(248)==1 & ) THEN C update position of JBEG_RHS on first non-empty C column of this block JBEG_RHS = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( id%IRHS_PTR(PERM_RHS(JBEG_RHS)) .EQ. & id%IRHS_PTR(PERM_RHS(JBEG_RHS)+1) ) C Empty column IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) & ) THEN C General sparse RHS (NOT A-1) and centralized solution C Set to zero part of the C solution corresponding to empty columns DO I=1, id%N id%RHS(int(PERM_RHS(JBEG_RHS) -1,8)*int(LD_RHS,8)+ & int(I,8)) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ELSE DO WHILE( id%IRHS_PTR(JBEG_RHS) .EQ. & id%IRHS_PTR(JBEG_RHS+1) ) IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) & ) THEN C Case of general sparse RHS (NOT A-1) and C centralized solution: set to zero part of C the solution corresponding to empty columns DO I=1, id%N id%RHS(int(JBEG_RHS -1,8)*int(LD_RHS,8) + & int(I,8)) = ZERO ENDDO ENDIF IF (KEEP(221).EQ.1) THEN IF (KEEP(60).NE.0) THEN C Fwd with Schur: reduced RHS set to ZERO DO I = 1, id%SIZE_SCHUR id%REDRHS(int(JBEG_RHS-1,8)*int(LD_REDRHS,8) + & int(I,8)) = ZERO ENDDO ENDIF ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR C Count nb of RHS columns skipped: useful for C * CMUMPS_DISTRIBUTED_SOLUTION to reset those C columns to zero. C * in case of reduced right-hand side, to set C corresponding entries of RHSINTR to 0 after C forward phase. NB_RHSSKIPPED = JBEG_RHS - (JEND_RHS + 1) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0) & .AND. (ICNTL21.EQ.0)) & THEN ! case of general sparse rhs with centralized solution, !set IBEG to shifted columns ! (after empty columns have been skipped) IBEG = int(JBEG_RHS-1,8) * int(LD_RHS,8) + 1_8 ENDIF ENDIF ! of if (id%MYID.EQ.MASTER) .AND. KEEP(248)==1 CALL MPI_BCAST( JBEG_RHS, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C C Shift on REDRHS in reduced RHS functionality C IF (id%MYID.EQ.MASTER .AND. KEEP(221).NE.0 & .AND. KEEP(60).NE.0 ) THEN C Initialize IBEG_REDRHS C Note that REDRHS always has id%NRHS Colmuns IBEG_REDRHS= int(JBEG_RHS-1,8)*int(LD_REDRHS,8) + 1_8 ELSE IBEG_REDRHS=-142424_8 ! Should not be used ENDIF C C ===================== C BEGIN C Prepare RHS on master C #if defined(V_T) CALL VTBEGIN(perm_scal_ini,IERR) #endif IF (id%MYID .eq. MASTER) THEN C{ ====================== IF (KEEP(248)==1 & ) THEN C{ ====================== C C Sparse RHS format ( A-1 or sparse centralized input format) C is provided as input by the user (IRHS_SPARSE ...) C -------------------------------------------------- C Compute NZ_THIS_BLOCK and NBCOL_INBLOC C where C NZ_THIS_BLOCK is defined C as the number of entries in the next NBRHS_EFF C non empty columns (note that since they might be permuted C then the following formula is not always valid: C NZ_THIS_BLOCK=id%IRHS_PTR(BEG_RHS+NBRHS_EFF)- C & id%IRHS_PTR(BEG_RHS) C anyway NBCOL_INBLOC also need be computed so going through C columns one at a time is needed. C NBCOL = 0 NBCOL_INBLOC = 0 NZ_THIS_BLOCK = 0 C With exploit sparsity we skip empty columns up to reaching C the first non empty column; then we process a block of C maximum size NBRHS_EFF except if we reach another empty C column. (We are not sure to have a copy allocated C and thus cannot compress on the fly, as done naturally C for A-1) C For A-1 we process NBRHS_EFF non empty columns C in the bloc that contains NBCOL_INBLOC columns C (empty+non empty) STOP_AT_NEXT_EMPTY_COL = .FALSE. DO I=JBEG_RHS, id%NRHS NBCOL_INBLOC = NBCOL_INBLOC +1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN C PERM_RHS(k) = i means that i is the kth C column to be processed C PERM_RHS should also be defined for C empty columns i in A-1 (PERM_RHS(K) = i) COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) ELSE COLSIZE = id%IRHS_PTR(I+1) - id%IRHS_PTR(I) ENDIF IF ((.NOT.STOP_AT_NEXT_EMPTY_COL).AND.(COLSIZE.GT.0).AND. & (KEEP(237).EQ.0)) THEN C -- set STOP_NEXT_EMPTY_COL only for general C -- sparse case (not AM-1) STOP_AT_NEXT_EMPTY_COL =.TRUE. ENDIF IF (COLSIZE.GT.0 C{ & ) THEN NBCOL = NBCOL+1 NZ_THIS_BLOCK = NZ_THIS_BLOCK + COLSIZE C} ELSE IF (STOP_AT_NEXT_EMPTY_COL) THEN C{ We have reached an empty column with already selected non empty C columns: reduce block size to non empty columns reached so far. NBCOL_INBLOC = NBCOL_INBLOC -1 C Note that NBRHS_EFF is udated only on master NBRHS_EFF = NBCOL EXIT C} ENDIF IF (NBCOL.EQ.NBRHS_EFF) EXIT ENDDO IF (NZ_THIS_BLOCK.EQ.0) THEN WRITE(*,*) " Internal Error 16 in sol driver NZ_THIS_BLOCK=", & NZ_THIS_BLOCK CALL MUMPS_ABORT() ENDIF C IF (NBCOL.NE.NBRHS_EFF.AND. (KEEP(237).NE.0) & .AND.KEEP(221).NE.1) THEN C With exploit sparsity for general sparse RHS (Not A-1) C we skip empty rows up to reaching C the first non empty column; then we process a block of C maximum size NBRHS_EFF except if we reach another empty C column. (We are not sure to have a copy allocated C and thus cannot compress on the fly, as done naturally C for A-1). Thus NBCOL might be smaller than NBRHS_EFF WRITE(6,*) ' Internal Error 8 in solution driver ', & NBCOL, NBRHS_EFF call MUMPS_ABORT() ENDIF C ------------------------------------------------------------- C IF (NZ_THIS_BLOCK .NE. 0) THEN C ----------------------------------------------------------- C We recall that C NBCOL_INBLOC is the number of columns of sparse RHS needed C to get NBRHS_EFF non empty columns: ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NBCOL_INBLOC+1 GOTO 30 endif IRHS_PTR_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 C ----------------------------------------------------------- C Initialize IRHS_PTR_COPY C compute local copy (compressed) of id%IRHS_PTR on Master IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 IRHS_PTR_COPY(J) = IPOS COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) IPOS = IPOS + COLSIZE ENDDO ELSE IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 IRHS_PTR_COPY(J) = IPOS COLSIZE = id%IRHS_PTR(I+1) & - id%IRHS_PTR(I) IPOS = IPOS + COLSIZE ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR IRHS_PTR_COPY(NBCOL_INBLOC+1)= IPOS IF ( IPOS-1 .NE. NZ_THIS_BLOCK ) THEN WRITE(*,*) "Error in compressed copy of IRHS_PTR" IERR = 99 call MUMPS_ABORT() ENDIF C ----------------------------------------------------------- C IRHS_SPARSE : do a copy or point to the original indices C C Check whether IRHS_SPARSE_COPY need be allocated IF (KEEP(23) .NE. 0 .and. MTYPE .NE. 1) THEN C AP = LU and At x = b ==> b need be permuted ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK) & ,stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 30 endif IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN C Columns are not contiguous and need be copied one by one C IRHS_SPARSE_COPY will hold a copy of contiguous permuted C columns so an explicit copy is needed. C IRHS_SPARSE_COPY is also allways allocated with A-1, C to enable receiving during mumps_gather_solution C . on the master in any order. ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) IF (allocok .GT.0 ) THEN IERR = 99 GOTO 30 ENDIF IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ENDIF C C Initialize IRHS_SPARSE_COPY IF (IRHS_SPARSE_COPY_ALLOCATED) THEN IF ( DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ) THEN IPOS = 1 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) DO K=0,COLSIZE-1 IRHS_SPARSE_COPY(IPOS+K) = & id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K) ENDDO IPOS = IPOS + COLSIZE ENDDO ELSE DO K=1,NZ_THIS_BLOCK IRHS_SPARSE_COPY(K) = id%IRHS_SPARSE( & id%IRHS_PTR(JBEG_RHS)+K-1) ENDDO ENDIF ELSE IRHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => & id%IRHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ENDIF #if defined(USE_OLD_SCALING) C Centralized scaling: perform scaling on master C in RHS_SPARSE_COPY IF (LSCAL.OR.DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN #else IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN #endif C if columns of the RHS are C permuted then a copy of RHS_SPARSE is needed. C Also always allocated with A-1, c to enable receiving during mumps_gather_solution C on the master in any order. C ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 30 ENDIF RHS_SPARSE_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE IF ( KEEP(248)==1 ) THEN RHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => id%RHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ELSE RHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => id%RHS_SPARSE(id%IRHS_PTR(BEG_RHS): & id%IRHS_PTR(BEG_RHS)+NZ_THIS_BLOCK-1) ENDIF ENDIF IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) THEN IF (id%KEEP(237).NE.0) THEN C --initialized to one #if defined(USE_OLD_SCALING) C it might be modified if scaling is on (one first entry C in each col is scaled) RHS_SPARSE_COPY = ONE #else C Local scalings are used: RHSINTR is initialized C directly on the workers and RHS_SPARSE_COPY will C only be used during CMUMPS_GATHER_SOLUTION_AM1. #endif ELSE C -- Columns are not contiguous and need be copied one by one #if defined(USE_OLD_SCALING) C -- This need not be done if scaling is on because it C -- will done and scaled later. IF (.NOT. LSCAL) THEN #endif 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 DO K=0, COLSIZE-1 RHS_SPARSE_COPY(IPOS+K) = & id%RHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K) ENDDO IPOS = IPOS + COLSIZE ENDDO #if defined(USE_OLD_SCALING) ENDIF #endif ENDIF ENDIF C ========================= IF (KEEP(23) .NE. 0) THEN C ========================= * maximum transversal was performed IF (MTYPE .NE. 1) THEN * At x = b is asked while * we have AP = LU where P is the column permutation * due to max trans. * Therefore we need to modify rhs: * b' = P-1 b (P-1=Pt) * Apply column permutation to the right hand side RHS * Column J of the permuted matrix corresponds to * column PERMW(J) of the original matrix. * C ========== C SPARSE RHS : permute indices rather than values C ========== C Solve with At X = B should never occur for A-1 IPOS = 1 DO I=1, NBCOL_INBLOC C Note that: (i) IRHS_PTR_COPY is compressed; C (ii) columns might have been permuted COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) DO K = 1, COLSIZE JPERM = UNS_PERM_INV(IRHS_SPARSE_COPY(IPOS+K-1)) IRHS_SPARSE_COPY(IPOS+K-1) = JPERM ENDDO IPOS = IPOS + COLSIZE ENDDO ENDIF ! MTYPE.NE.1 ENDIF ! KEEP(23).NE.0 ENDIF ! NZ_THIS_BLOCK .NE. 0 C} ----- ENDIF ! ============ KEEP(248)==1 C} ----- ENDIF ! (id%MYID .eq. MASTER) C C ===================== ERROR handling and propagation ================ 30 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C C NBCOL_INBLOC depends on loop IF (KEEP(248)==1 & ) THEN CALL MPI_BCAST( NBCOL_INBLOC,1, MPI_INTEGER, & MASTER, id%COMM,IERR) ELSE NBCOL_INBLOC = NBRHS_EFF ENDIF JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN C Only case (in previous block) for which C NBRHS_EFF has been modified only on master ! case of general sparse: in case of empty columns ! modifed version of ! NBRHS_EFF need be broadcasted since it is used ! to update BEG_RHS at the end of the DO WHILE CALL MPI_BCAST( NBRHS_EFF,1, MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(NB_RHSSKIPPED,1,MPI_INTEGER,MASTER, & id%COMM,IERR) ENDIF IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0) & .AND.(KEEP(221).NE.2 ).AND.(KEEP(248).EQ.1) ) THEN C{ ---------------------------- C -- SPARSE RIGHT-HAND-SIDE C ---------------------------- CALL MPI_BCAST( NZ_THIS_BLOCK,1, MPI_INTEGER, & MASTER, id%COMM,IERR) IF (id%MYID.NE.MASTER .and. NZ_THIS_BLOCK.NE.0) THEN ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 45 endif IRHS_SPARSE_COPY_ALLOCATED=.TRUE. C RHS_SPARSE_COPY is broadcasted C for A-1 even if on the slaves the initialisation of the RHS C could be only based on the pattern. Doing so we C broadcast the scaled version of the RHS (scaling arrays C that are not available on slaves). ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 45 endif RHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*(K34_8+K35_8) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NBCOL_INBLOC+1 GOTO 45 endif IRHS_PTR_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C C ===================== ERROR handling and propagation ================ 45 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== IF (NZ_THIS_BLOCK > 0) THEN CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(IRHS_PTR_COPY(1), & NBCOL_INBLOC+1, & MPI_INTEGER, & MASTER, id%COMM,IERR) ENDIF C} ENDIF C C ========================================================= C INITIALIZE C - nodes_FWD and nodes_BWD C ========================================================= IF (FIRST_CALL_NODES_FWD_BWD) THEN C{ First time CMUMPS_NODES_FWD_BWD_SIZE_FILL C is called allocated Pruned_Sons_FWD IF (allocated(Pruned_Sons_FWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_FWD) * K34_8 DEALLOCATE(Pruned_Sons_FWD) ENDIF IF (allocated(Pruned_Sons_BWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_BWD) * K34_8 DEALLOCATE(Pruned_Sons_BWD) ENDIF ALLOCATE (Pruned_Sons_FWD(KEEP(28)), & Pruned_Sons_BWD(KEEP(28)), & stat=allocok) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)= 2*KEEP(28) ELSE NB_BYTES = NB_BYTES + & int(size(Pruned_Sons_FWD),8)*K34_8 + & int(size(Pruned_Sons_BWD),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C} ENDIF C ===================== ERROR handling and propagation ============== CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C===================================================================== C Reset FIRST_CALL_NODES_FWD_BWD for not allocating C (Pruned_Sons_FWD/BWD within loop) FIRST_CALL_NODES_FWD_BWD = .FALSE. C IF (CALL_NODES_FWD_BWD) THEN C{ fill = .FALSE. nodes_FWD_PTR => IDUMMY_TARGET Lnodes_FWD_PTR = 1 nodes_BWD_PTR => IDUMMY_TARGET Lnodes_BWD_PTR = 1 CALL CMUMPS_NODES_FWD_BWD_SIZE_FILL ( & fill, id%ICNTL(1), & id%N, id%KEEP(28), id%KEEP(1), & id%STEP(1), id%Step2node(1), & IRHS_loc_PTR(1), id%Nloc_RHS, & IRHS_PTR_COPY(1), NBCOL_INBLOC, IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, PERM_RHS, size(PERM_RHS), JBEG_RHS, & UNS_PERM_INV, size(UNS_PERM_INV), ! size 1 if not used & ICNTL21, & id%MYID, id%COMM, & id%INFO, & Pruned_Sons_FWD, Pruned_Sons_BWD, & Lnodes_FWD, Lnodes_BWD & , nodes_FWD_PTR(1), nodes_BWD_PTR(1) & , Lnodes_FWD_PTR, Lnodes_BWD_PTR & ) C C ALLOCATE nodes_FWD and nodes_BWD if needed C IF (Lnodes_FWD.GT.0) THEN C NBT is inout in MUMPS_REALLOC and should be initialized. NBT = 0 CALL MUMPS_REALLOC(nodes_FWD, Lnodes_FWD, id%INFO, LP, & FORCE=.FALSE., & STRING='nodes_FWD', MEMCNT=NBT, ERRCODE=-13) IF (INFO(1).LT.0) GOTO 46 C nodes_FWD_PTR => nodes_FWD Lnodes_FWD_PTR = Lnodes_FWD NB_BYTES = NB_BYTES + NBT NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE nodes_FWD_PTR => IDUMMY_TARGET Lnodes_FWD_PTR = 1 ENDIF IF (Lnodes_BWD.GT.0) THEN C NBT is inout in MUMPS_REALLOC and should be initialized. NBT = 0 CALL MUMPS_REALLOC(nodes_BWD, Lnodes_BWD, id%INFO, LP, & FORCE=.FALSE., & STRING='nodes_BWD', MEMCNT=NBT, ERRCODE=-13) IF (INFO(1).LT.0) GOTO 46 C nodes_BWD_PTR => nodes_BWD Lnodes_BWD_PTR = Lnodes_BWD NB_BYTES = NB_BYTES + NBT NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE nodes_BWD_PTR => IDUMMY_TARGET Lnodes_BWD_PTR = 1 ENDIF C C ===================== ERROR handling and propagation ============== 46 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C===================================================================== IF (Lnodes_FWD.GT.0 .OR. Lnodes_BWD.GT.0) THEN C{ C we build nodes_FWD_PTR and/or nodes_BWD_PTR C that will be used to prune flops C and even if one of the steps FWD/BWD does not C lead to pruning (in this case C POSTINRHS_COMP will not benefit from pruning). fill = .TRUE. CALL CMUMPS_NODES_FWD_BWD_SIZE_FILL ( & fill, id%ICNTL(1), & id%N, id%KEEP(28), id%KEEP(1), & id%STEP(1), id%Step2node(1), & IRHS_loc_PTR(1), id%Nloc_RHS, & IRHS_PTR_COPY(1), NBCOL_INBLOC, IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, PERM_RHS, size(PERM_RHS), JBEG_RHS, & UNS_PERM_INV, size(UNS_PERM_INV), ! size 1 if not used & ICNTL21, & id%MYID, id%COMM, & id%INFO, & Pruned_Sons_FWD, Pruned_Sons_BWD, & Lnodes_FWD, Lnodes_BWD & , nodes_FWD_PTR(1), nodes_BWD_PTR(1) & , Lnodes_FWD_PTR, Lnodes_BWD_PTR & ) C} ENDIF C ------------------------------------------------ C Update CALL_NODES_FWD_BWD and free workspace if C not used again in loop of RHS C ------------------------------------------------ IF ( & (KEEP(237) .NE. 0).OR. ! AM1 & ((KEEP(235) .NE. 0).AND.KEEP(248).NE.-1) ! GS & ) THEN C target nodes for chain pruning C need be updated in case of AM1 or General Sparse CALL_NODES_FWD_BWD = .TRUE. ELSE C all other cases including C distributed RHS and distributed solution CALL_NODES_FWD_BWD = .FALSE. ENDIF IF (.NOT. CALL_NODES_FWD_BWD & ) THEN C Not needed anymore in the loop of RHS IF (allocated(Pruned_Sons_FWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_FWD) * K34_8 DEALLOCATE(Pruned_Sons_FWD) ENDIF IF (allocated(Pruned_Sons_BWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_BWD) * K34_8 DEALLOCATE(Pruned_Sons_BWD) ENDIF C ELSE C deallocate later ENDIF C} ENDIF C ========================================================= C INITIALIZE C - GLOB2LOC_RHS/SOL, RHSINTR and related data C - For distributed RHS, initialize RHSMAPINFO (at 1st block) C ========================================================= C C Fwd in facto: in this case only POSINRHSINTR need be computed C C (GLOB2LOC_RHS/SOL indirection arrays should C have been allocated once outside loop) C Compute size of RHSINTR since it might depend C on the process index and of the sparsity of the RHS C if it is exploited. C Initialize GLOB2LOC_RHS/SOL C C Note that id%LD_RHSINTR and id%KEEP8(25) C are not set on the host in this routine in C the case of a non-working host. C Note that POSINRHSINTR is now always computed in SOL_DRIVER C at least during the first block of RHS when sparsity of RHS C is not exploited. C ------------------------------- C INITTIALZE GLOB2LOC_RHS/SOL C ------------------------------- C C next block ok for Schur only IF ( KEEP(221).EQ.2 .AND. KEEP(252).EQ.0 & .AND. (KEEP(248).NE.1 .OR. (id%NRHS.EQ.1)) & ) THEN C Reduced RHS (Schur feature) was already computed during C a previous forward step AND is valid. C By valid we mean: C -no forward in facto (KEEP(252)==0) during which C POSINRHSINTR was not computed C AND C -no exploit sparsity with multiple RHS C because in this case POSINRHSINTR would C be valid only for the last block processed during fwd. C In those cases since we only perform the backward step, c we do not need to compute POSINRHSINTR BUILD_POSINRHSINTR = .FALSE. ENDIF C ------------------------ C INITIALIZE POSINRHSINTR C ------------------------ IF (BUILD_POSINRHSINTR) THEN C{ -- we first set MTYPE_LOC and C -- reset BUILD_POSINRHSINTR for next iteration in loop C C general case only POSINRHSINTR is computed BUILD_POSINRHSINTR = .FALSE. ! POSINRHSINTR does not change between blocks MTYPE_LOC = MTYPE C IF ( (KEEP(111).NE.0) .OR. (KEEP(237).NE.0) .OR. & (KEEP(252).NE.0) ) THEN C IF (KEEP(111).NE.0) THEN C -- in the context of null space, we need to C -- build RHSINTR to skip SOL_R. Therefore C -- we need to know for each concerned C -- row index its position in C -- RHSINTR C We use row indices, as these are the ones that C were used to detect zero pivots during factorization. C GLOB2LOC_RHS will allow to find the (row) index of a C zero in RHSINTR before calling CMUMPS_SOL_S. Then C CMUMPS_SOL_S uses column indices to build the solution C (corresponding to null space vectors) MTYPE_LOC = 1 ELSE IF (KEEP(252).NE.0) THEN C -- Fwd in facto: since fwd is skipped we need to build POSINRHSINTR MTYPE_LOC = 1 ! (no transpose) ELSE C -- A-1 only MTYPE_LOC = MTYPE BUILD_POSINRHSINTR = .TRUE. ENDIF ENDIF C -- compute POSINRHSINTR LIW_PASSED=max(1,LIW) IF ( C no sparsity at fwd or bwd: & (Lnodes_FWD.EQ.-1).OR.(Lnodes_BWD.EQ.-1) C & ) THEN C C RHSINTR is not sparse (in the sense that it has N rows C distributed on the MPI procs) and thus POSINRHSINTR C does not change with loop. C Remarks: C 1/ sparsity might still be exploited during C fwd or bwd to reduce the number of operations. C 2/ BUILD_POSINRHSINTR = .FALSE. C IF ( I_AM_SLAVE ) THEN C{ CALL CMUMPS_BUILD_GLOB2LOC( & 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%GLOB2LOC_RHS(1), id%GLOB2LOC_SOL(1), & id%GLOB2LOC_SOL_ALLOC, & MTYPE_LOC, & NBENT_RHSINTR, NB_FS_RHSINTR_TOT ) NB_FS_RHSINTR_F = NB_FS_RHSINTR_TOT C} ENDIF C ELSE C C Note that POSINRHSINTR* need not be recomputed before IR : C because distributed solution => NO IR. C C Exploit sparsity in solution and RHS C (AM1 or (Sparse RHS and solution) ) C Since sparsity is exploited during C both fwd and bwd then we need to recompute C POSINRHSINTR only when CALL_NODES_FWD_BWD will C be performed at next iteration. IF (CALL_NODES_FWD_BWD) BUILD_POSINRHSINTR = .TRUE. C IF ( I_AM_SLAVE ) THEN C{ CALL CMUMPS_BUILD_GLOB2LOC_NODES_ES( & id%NSLAVES,id%N, & id%MYID_NODES, id%PTLUST_S(1), id%DAD_STEPS(1), & id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), id%IS(1), LIW, & id%STEP(1), C & Lnodes_FWD, Lnodes_BWD, & nodes_FWD_PTR(1), nodes_BWD_PTR(1), C & id%GLOB2LOC_RHS(1), id%GLOB2LOC_SOL(1), & id%GLOB2LOC_SOL_ALLOC, & MTYPE_LOC, & NBENT_RHSINTR, & NB_FS_RHSINTR_F, NB_FS_RHSINTR_TOT & ) C} ENDIF ENDIF C} ENDIF ! BUILD_POSINRHSINTR=.TRUE. IF (BUILD_RHSMAPINFO .AND. KEEP(248).EQ.-1 & ) THEN C C Prepare symbolic data for sends. C For the moment: only MAP_RHS_loc C C id%GLOB2LOC_RHS is always associated to the C forward step (with or without transposed system) IF ( I_AM_SLAVE ) THEN C{ CALL MUMPS_SOL_RHSMAPINFO( id%N, id%Nloc_RHS, id%KEEP(89), & IRHS_loc_PTR(1), MAP_RHS_loc, id%GLOB2LOC_RHS(1), & id%NSLAVES, id%MYID_NODES, & id%COMM_NODES, id%ICNTL(1), id%INFO(1) ) BUILD_RHSMAPINFO = .FALSE. C MUMPS_SOL_RHSMAPINFO does not propagate errors C} ENDIF ! I_AM_SLAVE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF ( BUILD_SCALING_RHSINTR ) THEN C{ IF (SCALING_RHSINTR_BWD_ALLOCATED) THEN NB_BYTES = NB_BYTES - LSCALING_RHSINTR_BWD * K16_8 DEALLOCATE(SCALING_RHSINTR_BWD) ENDIF IF (SCALING_RHSINTR_FWD_ALLOCATED) THEN NB_BYTES = NB_BYTES - LSCALING_RHSINTR_FWD * K16_8 DEALLOCATE(SCALING_RHSINTR_FWD) ENDIF NULLIFY(SCALING_RHSINTR_BWD) NULLIFY(SCALING_RHSINTR_FWD) SCALING_RHSINTR_BWD_ALLOCATED = .FALSE. SCALING_RHSINTR_FWD_ALLOCATED = .FALSE. SCALING_RHSINTR_BWD => RDUMMY_TARGET SCALING_RHSINTR_FWD => RDUMMY_TARGET LSCALING_RHSINTR_BWD = 1 LSCALING_RHSINTR_FWD = 1 C Define or allocate SCALING_RHSINTR if needed: IF (LSCAL .AND. I_AM_SLAVE ) THEN IF (KEEP(221).EQ.2) THEN C In case of sparsity during bwd, we cannot C rely on the value of Lnodes_FWD to know C whether the scaling will match SCALING_LOC C and should thus consider that (Lnodes_FWD.NE.-1) ES_RHSINTR = (Lnodes_BWD.NE.-1) ELSE C sparsity at fwd and at bwd: ES_RHSINTR = (Lnodes_FWD.NE.-1).AND.(Lnodes_BWD.NE.-1) ENDIF C Scaling allocations performed only if needed C Forward or normal solve: IF ( ES_RHSINTR ) THEN LSCALING_RHSINTR_FWD = max(1, NB_FS_RHSINTR_F ) ALLOCATE(SCALING_RHSINTR_FWD(LSCALING_RHSINTR_FWD), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=LSCALING_RHSINTR_FWD ELSE SCALING_RHSINTR_FWD_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + LSCALING_RHSINTR_FWD * K16_8 ENDIF ELSE C RHSINTR matches SCALING_loc, no need to C allocate and compute a different scaling LSCALING_RHSINTR_FWD = max(1,KEEP(89)) #if defined(USE_OLD_SCALING) #else SCALING_RHSINTR_FWD => SCALING_LOC_FWD #endif ENDIF IF (ES_RHSINTR) THEN LSCALING_RHSINTR_BWD = max(1, NB_FS_RHSINTR_TOT ) ALLOCATE(SCALING_RHSINTR_BWD(LSCALING_RHSINTR_BWD), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=LSCALING_RHSINTR_BWD ELSE SCALING_RHSINTR_BWD_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + LSCALING_RHSINTR_BWD * K16_8 ENDIF ELSE C RHSINTR matches SCALING_loc, no need to C allocate and compute a different scaling LSCALING_RHSINTR_BWD = max(1,KEEP(89)) #if defined(USE_OLD_SCALING) SCALING_RHSINTR_BWD => scaling_data_sol%SCALING_LOC #else SCALING_RHSINTR_BWD => SCALING_LOC_BWD SCALING_RHSINTR_FWD => SCALING_LOC_FWD #endif ENDIF ENDIF C} ENDIF CALL MUMPS_PROPINFO( id%ICNTL, id%INFO, id%COMM,id%MYID) IF (id%INFO(1) .LT.0 ) GOTO 90 IF (BUILD_SCALING_RHSINTR) THEN C{ IF ( LSCAL .AND. I_AM_SLAVE. AND. ES_RHSINTR ) THEN #if ! defined(USE_OLD_SCALING) C SCALING_RHSINTR_FWD has been allocated and should C now be filled. It is a compressed version of the C local scaling array SCALING_LOC_FWD: IF (MTYPE.eq.0 .AND. KEEP(50).EQ.0) THEN ! tranpose ROWORCOL = 2 ! access 2nd list -- col indices ELSE ROWORCOL = 1 ! access 1st list -- row indices ENDIF CALL CMUMPS_SCALINGRHSINTR(LSCAL, id%N, & SCALING_LOC_FWD(1), & SCALING_RHSINTR_FWD(1), & LSCALING_RHSINTR_FWD, id%GLOB2LOC_RHS(1), & id%KEEP, ROWORCOL, id%PTLUST_S(1), & id%IS(1), max(1,LIW), & id%MYID_NODES, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES) C SCALING_RHSINTR_BWD has been allocated and should C now be filled. It is a compressed version of the C local scaling array SCALING_LOC_BWD: IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN ! no tranpose C access 2nd list corresponding to col indices ROWORCOL = 2 ELSE C access 1st list corresponding to row indices ROWORCOL = 1 ENDIF CALL CMUMPS_SCALINGRHSINTR(LSCAL, id%N, & SCALING_LOC_BWD(1), & SCALING_RHSINTR_BWD(1), & LSCALING_RHSINTR_BWD, id%GLOB2LOC_SOL(1), & id%KEEP, ROWORCOL, id%PTLUST_S(1), & id%IS(1), max(1,LIW), & id%MYID_NODES, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES) #endif #if defined(USE_OLD_SCALING) #endif ENDIF C Rebuild SCALING_RHSINTR* next time C only if POSINRHSINTR has to be built C again next time: BUILD_SCALING_RHSINTR= BUILD_POSINRHSINTR C} ENDIF IF (I_AM_SLAVE) THEN IF ((KEEP(221).EQ.1).OR.KEEP(221).EQ.-1) THEN C For the following cases: C -[Schur] we need to save the reduced RHS for all RHS C to perform later the backward phase with an C updated reduced RHS C -[Fwd only] return RHSINTR to user C -KEEP(221)=-1, allocate RHSINTR to enable bwd only step C We need to allocate NRHS_NONEMPTY columns in one shot. C Note that C -RHSINTR might have been allocated in previous block C -RHSINTR has been deallocated previous to entering C loop on RHS IF (.not. associated(id%RHSINTR)) THEN C So far we cannot combine this to exploit sparsity C so that NBENT_RHSINTR will not change in the loop C and can be used to dimension RHSINTR C C Furthermore, during bwd phase the REDRHS provided C by the user might also have a different non empty C column pattern than the sparse RHS provided on input to C this phase: thus we need to allocate id%NRHS columns too. id%LD_RHSINTR = max(NBENT_RHSINTR,1) id%KEEP8(25) = int(id%LD_RHSINTR,8)*int(id%NRHS,8) ALLOCATE (id%RHSINTR(id%KEEP8(25)), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(25),INFO(2)) id%KEEP8(25)=0_8 GOTO 41 END IF NB_BYTES = NB_BYTES + id%KEEP8(25)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C C IF ((KEEP(221).NE.1).AND. & ((KEEP(221).NE.2).OR.(KEEP(252).NE.0)) & ) THEN C ------------------ C Allocate RHSINTR C (case of RHSINTR allocated at each block of RHS) C ------------------ C RHSINTR allocated per block of maximum size NBRHS C NBRHS_EFF could be used instead on NBRHS IF (associated(id%RHSINTR)) THEN C RHSINTR already associated for previous C block, check if we can reuse it. id%LD_RHSINTR = max(NBENT_RHSINTR, 1) IF (id%KEEP8(25).LT.int(id%LD_RHSINTR,8)*int(NBRHS,8)) & THEN ! deallocate and reallocate since larger array is needed NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25) = 0_8 id%LD_RHSINTR = 0 ENDIF ENDIF IF (.not. associated(id%RHSINTR)) THEN id%LD_RHSINTR = max(NBENT_RHSINTR, 1) id%KEEP8(25) = int(id%LD_RHSINTR,8)*int(NBRHS,8) ALLOCATE (id%RHSINTR(id%KEEP8(25)), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(25),INFO(2)) GOTO 41 END IF NB_BYTES = NB_BYTES + id%KEEP8(25)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C C Shift on RHSINTR C IF ( KEEP(221).EQ.0 ) THEN C -- RHSINTR reused in the loop IBEG_RHSINTR= 1_8 ELSE C Initialize IBEG_RHSINTR C IBEG_RHSINTR= int(JBEG_RHS-1,8)*int(id%LD_RHSINTR,8)+1_8 ENDIF ENDIF ! I_AM_SLAVE C ===================== ERROR handling and propagation ================ 41 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C C --------------------------- C Prepare RHS on master (case C of dense and sparse RHS) C --------------------------- IF (id%MYID .eq. MASTER & ) THEN C ========================= IF (KEEP(23) .NE. 0) THEN C ========================= * maximum transversal was performed IF (MTYPE .NE. 1) THEN * At x = b is asked while * we have AP = LU where P is the column permutation * due to max trans. * Therefore we need to modify rhs: * b' = P-1 b (P-1=Pt) * Apply column permutation to the right hand side RHS * Column J of the permuted matrix corresponds to * column PERMW(J) of the original matrix. * IF (KEEP(248)==0) THEN C ========= C DENSE RHS : permute values in RHS C ========= ALLOCATE( C_RW2( id%N ),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating C_RW2 in CMUMPS_SOLVE_DRIVE' END IF GOTO 30 END IF C We directly permute in id%RHS. DO K = 1, NBRHS_EFF KDEC = IBEG+int(K-1,8)*int(LD_RHS,8) DO I = 1, id%N C_RW2(I)=id%RHS(I-1+KDEC) END DO DO I = 1, id%N JPERM = id%UNS_PERM(I) id%RHS(I-1+KDEC) = C_RW2(JPERM) END DO END DO DEALLOCATE(C_RW2) ENDIF ENDIF ENDIF C IF (POSTPros) THEN IF ( KEEP(248) == 0 ) THEN DO K = 1, NBRHS_EFF KDEC = IBEG+int(K-1,8)*int(LD_RHS,8) DO I = 1, id%N SAVERHS(I+(K-1)*id%N) = id%RHS(KDEC+I-1) END DO ENDDO ELSE IF (KEEP(248)==1) THEN SAVERHS(:) = ZERO DO K = 1, NBRHS DO J = id%IRHS_PTR(K), id%IRHS_PTR(K+1)-1 I = id%IRHS_SPARSE(J) SAVERHS(I+(K-1)*id%N) = id%RHS_SPARSE(J) ENDDO ENDDO ENDIF ENDIF #if defined(USE_OLD_SCALING) C C RHS is set to scaled right hand side C (case of centralized scaling only) C IF (LSCAL) THEN C scaling was performed IF (KEEP(248)==0) THEN C dense RHS IF (MTYPE .EQ. 1) THEN C we solve Ax=b, use ROWSCA to scale the RHS DO K =1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHS,8) + int(IBEG-1,8) DO I = 1, id%N id%RHS(KDEC+I) = id%RHS(KDEC+I) * & id%ROWSCA(I) ENDDO ENDDO ELSE C we solve Atx=b, use COLSCA to scale the RHS DO K =1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHS,8) + int(IBEG-1,8) DO I = 1, id%N id%RHS(KDEC+I) = id%RHS(KDEC+I) * & id%COLSCA(I) ENDDO ENDDO ENDIF ELSE IF (KEEP(248)==1) THEN C ------------------------- C KEEP(248)==1 (and MASTER) C ------------------------- KDEC=int(id%IRHS_PTR(JBEG_RHS),8) C Compute IF ((KEEP(248)==1) .AND. & (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) & ) THEN C -- copy from RHS_SPARSE need be done per C column following PERM_RHS C Columns are not contiguous and need be copied one by one IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN IPERM = PERM_RHS(I) ENDIF J = J+1 C Note that we work here on compressed IRHS_PTR_COPY COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) C -- skip empty column IF (COLSIZE .EQ. 0) CYCLE IF (id%KEEP(237).NE.0) THEN IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN C if A-1 only, then, for each non empty target C column PERM_RHS(I), scale in first position C in column the diagonal entry C build the scaled rhs ej on each slave. RHS_SPARSE_COPY(IPOS) = id%ROWSCA(IPERM) * & ONE ELSE RHS_SPARSE_COPY(IPOS) = id%ROWSCA(I) * ONE ENDIF ELSE C Loop over nonzeros in column DO K = 1, COLSIZE C Formula for II below is ok, except in case C of maximum transversal (KEEP(23).NE.0) and C transpose system (MTYPE .NE. 1): C II = id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K-1) C In case of maximum transversal + transpose, one C should then apply II=UNS_PERM_INV(II) after the C above definition of II. C C Instead, we rely on IRHS_SPARSE_COPY, whose row C indices have already been permuted in case of C maximum transversal. II = IRHS_SPARSE_COPY( & IRHS_PTR_COPY(I-JBEG_RHS+1) & +K-1) C PERM_RHS(I) corresponds to column in original RHS. C Original IRHS_PTR must be used to access id%RHS_SPARSE IF (MTYPE.EQ.1) THEN RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(IPERM)+K-1)* & id%ROWSCA(II) ELSE RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(IPERM)+K-1)* & id%COLSCA(II) ENDIF ENDDO ENDIF IPOS = IPOS + COLSIZE ENDDO ELSE ! general sparse RHS ! without permutation IF (MTYPE .eq. 1) THEN DO IZ=1,NZ_THIS_BLOCK I=IRHS_SPARSE_COPY(IZ) RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* & id%ROWSCA(I) ENDDO ELSE DO IZ=1,NZ_THIS_BLOCK I=IRHS_SPARSE_COPY(IZ) RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* & id%COLSCA(I) ENDDO ENDIF ENDIF ENDIF ! KEEP(248)==1 ENDIF ! LSCAL #endif ENDIF ! id%MYID.EQ.MASTER #if defined(V_T) CALL VTEND(perm_scal_ini,IERR) #endif C C Prepare RHS on master C END C ===================== C ----------------------------------- C Two main cases depending on option C for null space computation: C C KEEP(111)=0 : use RHS from user C (sparse or dense) C KEEP(111)!=0: build an RHS on each C proc for null space C computations C ----------------------------------- #if defined(V_T) CALL VTBEGIN(soln_dist,IERR) #endif TIMESCATTER1=MPI_WTIME() IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0) & .AND.(KEEP(221).NE.2 )) THEN C{ ------------------------ C Use RHS provided by user C when not null space and not Fwd in facto C ------------------------ IF (KEEP(248) == 0) THEN C ---------------------------- C -- DENSE RIGHT-HAND-SIDE C ---------------------------- IF ( .NOT.I_AM_SLAVE ) THEN C -- Master not working CALL CMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, LSCAL, SCALING_LOC_FWD(1), & MTYPE, id%RHS(IBEG), LD_RHS, NBRHS_EFF, & NBRHS_EFF, & C_DUMMY, 1, 1, & IDUMMY, 0, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ELSE IF (id%MYID .eq. MASTER) THEN PTR_RHS => id%RHS LD_RHS_loc = LD_RHS NCOL_RHS_loc = NBRHS_EFF IBEG_loc = IBEG ELSE PTR_RHS => CDUMMY_TARGET LD_RHS_loc = 1 NCOL_RHS_loc = 1 IBEG_loc = 1_8 ENDIF LIW_PASSED = max( LIW, 1 ) CALL CMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, LSCAL, SCALING_LOC_FWD(1), & MTYPE, PTR_RHS(IBEG_loc),LD_RHS_loc,NCOL_RHS_loc, & NBRHS_EFF, & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, NBRHS_EFF, & id%GLOB2LOC_RHS(1), NB_FS_RHSINTR_F, C & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).LT.0) GOTO 90 ELSE IF (KEEP(248) .EQ. -1) THEN IF (I_AM_SLAVE) THEN IF (id%Nloc_RHS .NE. 0) THEN RHS_loc_size=int(id%LRHS_loc,8)*int(NBRHS_EFF-1,8)+ & int(id%Nloc_RHS,8) RHS_loc_shift=1_8+int(BEG_RHS-1,8)*id%LRHS_loc ELSE RHS_loc_size=1_8 RHS_loc_shift=1_8 ENDIF CALL CMUMPS_SCATTER_DIST_RHS(id%NSLAVES, id%N, & id%MYID_NODES, id%COMM_NODES, & NBRHS_EFF, id%Nloc_RHS, id%LRHS_loc, & MAP_RHS_loc, & IRHS_loc_PTR(1), & idRHS_loc(RHS_loc_shift), & RHS_loc_size, & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, & id%GLOB2LOC_RHS(1), NB_FS_RHSINTR_F, & LSCAL, #if defined(USE_OLD_SCALING) & scaling_data_dr, #else & SCALING_RHSINTR_FWD(1), LSCALING_RHSINTR_FWD, #endif & LP, LPOK, KEEP(1), NB_BYTES_LOC, INFO(1)) C NB_BYTES_LOC were allocated and freed above NB_BYTES_MAX = max(NB_BYTES_MAX, & NB_BYTES_MAX+NB_BYTES_LOC) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).LT.0) GOTO 90 ELSE C === KEEP(248)==1 ========= C -- SPARSE RIGHT-HAND-SIDE C ---------------------------- IF (NZ_THIS_BLOCK > 0 #if ! defined(USE_OLD_SCALING) C For AM1, no need to broadcast RHS_SPARSE C when using local scalings. RHSINTR will C be initialized directly and RHS_SPARSE C is used during CMUMPS_GATHER_SOLUTION_AM1 & .AND. id%KEEP(237) .EQ.0 #endif & ) THEN CALL MPI_BCAST(RHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_COMPLEX, & MASTER, id%COMM, IERR) ENDIF C IF (KEEP(237).NE.0) THEN IF ( I_AM_SLAVE ) THEN C ----- C case of A-1 C ----- C - Take columns with non-zero entry, say j, C - to build Ej and store it in RHSINTR K=1 ! Column index in RHSINTR id%RHSINTR(1_8:int(NBRHS_EFF,8)*int(id%LD_RHSINTR,8)) & = ZERO IPOS = 1 DO I = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) IF (COLSIZE.GT.0) THEN ! Find global column index J and set ! column K of RHSINTR to ej (here IBEG is one) J = I - 1 + JBEG_RHS IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN J = PERM_RHS(J) ENDIF IPOSRHSINTR = id%GLOB2LOC_RHS(J) C IF ( (IPOSRHSINTR.LE.NB_FS_RHSINTR_F) C & .AND.(IPOSRHSINTR.GT.0) ) THEN IF (IPOSRHSINTR.GT.0) THEN C Columns J corresponds to ej and thus to variable j C that is on my proc. C We know that only one entry is needed, C the diagonal entry (for the forward with A-1). C #if defined(USE_OLD_SCALING) id%RHSINTR(int(K-1,8)*int(id%LD_RHSINTR,8)+ & int(IPOSRHSINTR,8)) = & RHS_SPARSE_COPY(IPOS) #else IF (LSCAL) THEN id%RHSINTR(int(K-1,8)*int(id%LD_RHSINTR,8)+ & int(IPOSRHSINTR,8)) = & SCALING_RHSINTR_FWD(IPOSRHSINTR) ELSE id%RHSINTR(int(K-1,8)*int(id%LD_RHSINTR,8)+ & int(IPOSRHSINTR,8)) = ONE ENDIF #endif ENDIF ! End of J on my proc K = K + 1 IPOS = IPOS + COLSIZE ! go to next column ENDIF ENDDO IF (K.NE.NBRHS_EFF+1) THEN WRITE(6,*) 'Internal Error 9 in solution driver ', & K,NBRHS_EFF call MUMPS_ABORT() ENDIF ENDIF ! I_AM_SLAVE C ------- c END A-1 C ------- ELSE C -------------- C General sparse C -------------- C -- At this point each process has a copy of the C -- sparse RHS. We need to store it into RHSINTR. C -- reset to zero RHSINTR for skipped columns (if any) IF ((KEEP(221).EQ.1).AND.(NB_RHSSKIPPED.GT.0) & .AND.I_AM_SLAVE) THEN DO K = JBEG_RHS-NB_RHSSKIPPED, JBEG_RHS-1 DO I = 1, id%LD_RHSINTR id%RHSINTR(int(K-1,8)*int(id%LD_RHSINTR,8) & + int(I,8)) = ZERO ENDDO ENDDO ENDIF IF (I_AM_SLAVE) THEN DO K = 1, NBCOL_INBLOC ! it is equal to NBRHS_EFF in this case KDEC = int(K-1,8) * int(id%LD_RHSINTR,8) + & IBEG_RHSINTR - 1_8 id%RHSINTR(KDEC+1_8:KDEC+NBENT_RHSINTR) = ZERO #if ! defined(USE_OLD_SCALING) IF (LSCAL) THEN DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 I=IRHS_SPARSE_COPY(IZ) IPOSRHSINTR = id%GLOB2LOC_RHS(I) C Since all fully summed variables mapped C on each proc are stored at the beginning C of RHSINTR, we can compare to KEEP(89) C to know if RHSINTR should be initialized C So far the tree has not been pruned to exploit C sparsity to compress RHSINTR so we compare to C NB_FS_RHSINTR_TOT IF ( (IPOSRHSINTR.LE.NB_FS_RHSINTR_TOT) & .AND.(IPOSRHSINTR.GT.0) ) THEN C ! I is fully summed var mapped on my proc id%RHSINTR(KDEC+IPOSRHSINTR)= & id%RHSINTR(KDEC+IPOSRHSINTR) + & RHS_SPARSE_COPY(IZ) & * SCALING_RHSINTR_FWD(IPOSRHSINTR) ENDIF ENDDO ELSE #endif DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 I=IRHS_SPARSE_COPY(IZ) IPOSRHSINTR = id%GLOB2LOC_RHS(I) C Since all fully summed variables mapped C on each proc are stored at the beginning C of RHSINTR, we can compare to KEEP(89) C to know if RHSINTR should be initialized C So far the tree has not been pruned to exploit C sparsity to compress RHSINTR so we compare to C NB_FS_RHSINTR_TOT IF ( (IPOSRHSINTR.LE.NB_FS_RHSINTR_TOT) & .AND.(IPOSRHSINTR.GT.0) ) THEN C ! I is fully summed var mapped on my proc id%RHSINTR(KDEC+IPOSRHSINTR)= & id%RHSINTR(KDEC+IPOSRHSINTR) + & RHS_SPARSE_COPY(IZ) ENDIF ENDDO #if ! defined(USE_OLD_SCALING) ENDIF #endif ENDDO END IF ! I_AM_SLAVE ENDIF ! KEEP(237) ENDIF ! ==== KEEP(248)==1 ===== C} ELSE IF (I_AM_SLAVE) THEN ! I_AM_SLAVE AND (null space or Fwd in facto) IF (KEEP(111).NE.0) THEN C{ ----------------------- C Null space computations C ----------------------- C C We are working on columns BEG_RHS:BEG_RHS+NBRHS_EFF-1 C of RHS. C Columns in 1..KEEP(112): C Put a one in corresponding C position of the right-hand-side, C and zeros in other places. C Columns in KEEP(112)+1: KEEP(112)+KEEP(17): C root node => set C 0 everywhere and compute the local range C corresponding to IBEG/IEND in root C that will be passed to CMUMPS_SEQ_SOLVE_ROOT_RR C Also keep track of which part of C CMUMPS_RHS must be passed to C CMUMPS_SEQ_SOLVE_ROOT_RR. C IF (KEEP(111).GT.0) THEN IBEG_GLOB_DEF = KEEP(111) IEND_GLOB_DEF = KEEP(111) ELSE IBEG_GLOB_DEF = BEG_RHS IEND_GLOB_DEF = BEG_RHS+NBRHS_EFF-1 ENDIF IF ( id%KEEP(112) .GT. 0 .AND. DO_NULL_PIV) THEN IF (IBEG_GLOB_DEF .GT.id%KEEP(112)) THEN id%KEEP(235) = 0 DO_NULL_PIV = .FALSE. ENDIF IF (IBEG_GLOB_DEF .LT.id%KEEP(112) & .AND. IEND_GLOB_DEF .GT.id%KEEP(112) & .AND. DO_NULL_PIV ) THEN C IEND_GLOB_DEF = id%KEEP(112) C forcing exploit sparsity C - cannot be done at this point C - and is not what the user would have expected the C code to to do anyway !!!! C suppress: id%KEEP(235) = 1 ! End Block of sparsity ON DO_NULL_PIV = .FALSE. ENDIF ENDIF IF (id%KEEP(235).NE.0) THEN C Exploit Sparsity in null space computations C We build /allocate the sparse RHS on MASTER C based on pivnul_list. Then we broadcast it C on the slaves C In this case we have ONLY ONE ENTRY per RHS C NZ_THIS_BLOCK=IEND_GLOB_DEF-IBEG_GLOB_DEF+1 ALLOCATE(IRHS_PTR_COPY(NZ_THIS_BLOCK+1),stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 50 ENDIF IRHS_PTR_COPY_ALLOCATED = .TRUE. ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK),stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 50 ENDIF IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + & int(NZ_THIS_BLOCK,8)*(K34_8+K34_8) & + K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.eq.MASTER) THEN ! compute IRHS_PTR and IRHS_SPARSE_COPY II = 1 DO I = IBEG_GLOB_DEF, IEND_GLOB_DEF IRHS_PTR_COPY(I-IBEG_GLOB_DEF+1) = I IRHS_SPARSE_COPY(II) = id%PIVNUL_LIST(I) II = II +1 ENDDO IRHS_PTR_COPY(NZ_THIS_BLOCK+1) = NZ_THIS_BLOCK+1 ENDIF C C ===================== ERROR handling and propagation ================ 50 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(IRHS_PTR_COPY(1), & NZ_THIS_BLOCK+1, & MPI_INTEGER, & MASTER, id%COMM,IERR) C End IF Exploit Sparsity ENDIF c C Initialize RHSINTR to 0 ! to be suppressed DO K=1, NBRHS_EFF KDEC = int(K-1,8) * int(id%LD_RHSINTR,8) id%RHSINTR(KDEC+1_8:KDEC+int(id%LD_RHSINTR,8))=ZERO END DO C Loop over the columns. C Note that if ( KEEP(220)+KEEP(109)-1 < IBEG_GLOB_DEF C .OR. KEEP(220) > IEND_GLOB_DEF ) then we do not enter C the loop. C Note that local processor has indices C KEEP(220):KEEP(220)+KEEP(109)-1 C C Computation of null space and computation of backward C step incompatible, do one or the other. DO I=max(IBEG_GLOB_DEF,KEEP(220)), & min(IEND_GLOB_DEF,KEEP(220)+KEEP(109)-1) C Local processor is concerned by I-th column of C global right-hand side. JJ= id%GLOB2LOC_RHS(id%PIVNUL_LIST(I-KEEP(220)+1)) IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN ! unsymmetric : always set to fixation id%RHSINTR( IBEG_RHSINTR+ & int(I-IBEG_GLOB_DEF,8)*int(id%LD_RHSINTR,8)+ & int(JJ-1,8) ) = & cmplx(id%DKEEP(2),kind=kind(id%RHSINTR)) ELSE ! Symmetric: always set to one id%RHSINTR( IBEG_RHSINTR+ & int(I-IBEG_GLOB_DEF,8)*int(id%LD_RHSINTR,8)+ & int(JJ-1,8) )= & ONE ENDIF ENDIF ENDDO IF ( KEEP(17).NE.0 .AND. & id%MYID_NODES.EQ.MASTER_ROOT) THEN C --------------------------- C Deficiency of the root node C Find range relative to root C --------------------------- C Among IBEG_GLOB_DEF:IEND_GLOB_DEF, find C intersection with KEEP(112)+1:KEEP(112)+KEEP(17) IBEG_ROOT_DEF = max(IBEG_GLOB_DEF,KEEP(112)+1) IEND_ROOT_DEF = min(IEND_GLOB_DEF,KEEP(112)+KEEP(17)) C First column of right-hand side that must C be passed to CMUMPS_SEQ_SOLVE_ROOT_RR is: IROOT_DEF_RHS_COL1 = IBEG_ROOT_DEF-IBEG_GLOB_DEF + 1 C We look for indices relatively to the root node, C substract number of null pivots outside root node IBEG_ROOT_DEF = IBEG_ROOT_DEF-KEEP(112) IEND_ROOT_DEF = IEND_ROOT_DEF-KEEP(112) C Note that if IBEG_ROOT_DEF > IEND_ROOT_DEF, then this C means that nothing must be done on the root node C for this set of right-hand sides. ELSE IBEG_ROOT_DEF = -90999 IEND_ROOT_DEF = -95999 IROOT_DEF_RHS_COL1= 1 ENDIF C} ELSE ! End of null space (test on KEEP(111)) C case of Fwd in facto C id%RHSINTR need not be initialized. It will be set on the fly C to zero for normal fully summed variables of the fronts and C to -1 on the roots for the id%N+KEEP(253) variables added C to the roots. ENDIF ! End of null space (test on KEEP(111)) ENDIF ! I am slave TIMESCATTER2=MPI_WTIME()-TIMESCATTER1+TIMESCATTER2 IF (KEEP(221) .EQ. 2 .AND. KEEP(60).NE.0 ) THEN C Copy/send REDRHS in PTR_RHS_ROOT C (column by column if leading dimension LD_REDRHS C of REDRHS is not equal to SIZE_ROOT). C REDRHS was provided on the host IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN C -- Same proc : copy is possible: II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8)-1_8 DO I = 1, SIZE_ROOT PTR_RHS_ROOT(II+I) = id%REDRHS(KDEC+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE C -- send REDRHS IF ( id%MYID .EQ. MASTER) THEN C -- send to MASTER_ROOT_IN_COMM using COMM communicator C assert: id%KEEP(116).EQ.SIZE_ROOT IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- One send KDEC = IBEG_REDRHS CALL MPI_SEND(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSE C -- NBRHS_EFF sends DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) CALL MPI_SEND(id%REDRHS(KDEC),SIZE_ROOT, & MPI_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ENDDO ENDIF ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN C -- receive from MASTER II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- receive all in on shot CALL MPI_RECV(PTR_RHS_ROOT(II), & SIZE_ROOT*NBRHS_EFF, & MPI_COMPLEX, & MASTER, 0, id%COMM,STATUS,IERR) ELSE DO K=1, NBRHS_EFF CALL MPI_RECV(PTR_RHS_ROOT(II),SIZE_ROOT, & MPI_COMPLEX, & MASTER, 0, id%COMM,STATUS,IERR) II = II + SIZE_ROOT ENDDO ENDIF ENDIF C -- other procs are not concerned ENDIF ENDIF TIMEC1=MPI_WTIME() IF ( I_AM_SLAVE ) THEN C { LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) C FROM_PP = .FALSE. NBSPARSE_LOC = (DO_NBSPARSE.AND.NBRHS_EFF.GT.1) C ----------------------------------------- C Define arguments to have a single call to C SOL_C with and without exploit sparsity. C ----------------------------------------- IF (Lnodes_FWD.EQ.-1 .AND. Lnodes_BWD.EQ.-1) THEN NZ_THIS_BLOCK_ARG = 1 NBCOL_INBLOC_ARG = 1 Step2node_ARG => IDUMMY_TARGET LStep2node_ARG = 1 IRHS_SPARSE_COPY_ARG => IDUMMY_TARGET IRHS_PTR_COPY_ARG => IDUMMY_TARGET NB_FS_RHSINTR_F_ARG = 1 NB_FS_RHSINTR_TOT_ARG = 1 #if defined(STAT_ES_SOLVE) SIZE_WORKING = 1 SIZE_IPTR_WORKING = 1 idIPTR_WORKING => IDUMMY_TARGET idWORKING => IDUMMY_TARGET #endif ELSE NZ_THIS_BLOCK_ARG = NZ_THIS_BLOCK NBCOL_INBLOC_ARG = NBCOL_INBLOC Step2node_ARG => id%Step2node LStep2node_ARG = KEEP(28) IRHS_SPARSE_COPY_ARG => IRHS_SPARSE_COPY IRHS_PTR_COPY_ARG => IRHS_PTR_COPY NB_FS_RHSINTR_F_ARG = NB_FS_RHSINTR_F NB_FS_RHSINTR_TOT_ARG = NB_FS_RHSINTR_TOT #if defined(STAT_ES_SOLVE) SIZE_WORKING = 1 SIZE_IPTR_WORKING = 1 IF((KEEP(235).NE.0).OR.(KEEP(237).NE.0)) THEN IF(id%MYID.EQ.MASTER) THEN SIZE_WORKING = id%IPTR_WORKING(id%NPROCS+1)-1 SIZE_IPTR_WORKING = id%NPROCS+1 END IF ENDIF #endif ENDIF CALL CMUMPS_SOL_C(idintr%root,idintr%roota,id%N,id%S(1), &LA_PASSED,IS(1),LIW_PASSED,WORK_WCB(1),LWCB8,IWCB,LIWCB, &NBRHS_EFF,id%NA(1),id%LNA,id%NE_STEPS(1),SRW3, MTYPE, ICNTL(1), &FROM_PP,id%STEP(1),id%FRERE_STEPS(1),id%DAD_STEPS(1),id%FILS(1), &id%PTLUST_S(1),id%PTRFAC(1),IWK_SOLVE,LIWK_SOLVE,PTRACB, &LIWK_PTRACB,id%PROCNODE_STEPS(1),id%NSLAVES,INFO(1),KEEP(1), &KEEP8(1),id%DKEEP(1),id%COMM_NODES,id%MYID,id%MYID_NODES,BUFR(1), &LBUFR,LBUFR_BYTES,id%ISTEP_TO_INIV2(1),id%TAB_POS_IN_PERE(1,1), &IBEG_ROOT_DEF,IEND_ROOT_DEF,IROOT_DEF_RHS_COL1, PTR_RHS_ROOT(1), &LPTR_RHS_ROOT,SIZE_ROOT,MASTER_ROOT,id%RHSINTR(IBEG_RHSINTR), &id%LD_RHSINTR,id%GLOB2LOC_RHS(1),id%GLOB2LOC_SOL(1), &Lnodes_FWD, Lnodes_BWD, nodes_FWD_PTR(1), nodes_BWD_PTR(1), &NZ_THIS_BLOCK_ARG, NBCOL_INBLOC_ARG, JBEG_RHS, Step2node_ARG(1), &LStep2node_ARG, IRHS_SPARSE_COPY_ARG(1), IRHS_PTR_COPY_ARG(1), &size(PERM_RHS), PERM_RHS, size(UNS_PERM_INV), UNS_PERM_INV, &NB_FS_RHSINTR_F, NB_FS_RHSINTR_TOT, NBSPARSE_LOC, &PTR_RHS_BOUNDS(1), LPTR_RHS_BOUNDS #if defined(STAT_ES_SOLVE) &,idIPTR_WORKING(1),SIZE_IPTR_WORKING,idWORKING(1),SIZE_WORKING #endif & , id%IPOOL_B_L0_OMP(1), id%LPOOL_B_L0_OMP, id%IPOOL_A_L0_OMP(1), & id%LPOOL_A_L0_OMP, id%L_VIRT_L0_OMP, id%VIRT_L0_OMP(1), & id%L_PHYS_L0_OMP, id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1), & id%PTR_LEAFS_L0_OMP(1), id%L0_OMP_MAPPING(1), id%LL0_OMP_MAPPING, & idintr%L0_OMP_FACTORS(1), id%LL0_OMP_FACTORS & ) C C ================================================================ C C } END IF ! I_AM_SLAVE C ----------------- C End of slave code C ----------------- C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) TIMEC2=MPI_WTIME()-TIMEC1+TIMEC2 C C Change error code. IF (INFO(1).eq.-2) then INFO(1)=-11 IF (LPOK) & write(LP,*) & ' WARNING : -11 error code obtained in solve' END IF IF (INFO(1).eq.-3) then INFO(1)=-14 IF (LPOK) & write(LP,*) & ' WARNING : -14 error code obtained in solve' END IF C C Return in case of error. IF (INFO(1).LT.0) GO TO 90 C C ====================================================== C ONLY FORWARD was performed (case of reduced RHS with Schur C option during factorisation) C ====================================================== IF ( (KEEP(60).NE.0) .AND. & KEEP(221) .EQ. 1 ) THEN ! === Begin OF REDUCED RHS ====== C -------------------------------------- C Send (or copy) reduced RHS from PTR_RHS_ROOT located on C MASTER_ROOT_IN_COMM to REDRHS located on MASTER (host node). C (column by column if leading dimension LD_REDRHS C of REDRHS is not equal to SIZE_ROOT) C -------------------------------------- IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN C -- same proc --> copy II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) - 1_8 DO I = 1, SIZE_ROOT id%REDRHS(KDEC+I) = PTR_RHS_ROOT(II+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE C -- recv in REDRHS IF ( id%MYID .EQ. MASTER ) THEN C -- recv from MASTER_ROOT_IN_COMM IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- One message to receive KDEC = IBEG_REDRHS CALL MPI_RECV(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM, & STATUS,IERR) ELSE C -- NBRHS_EFF receives DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) CALL MPI_RECV(id%REDRHS(KDEC),SIZE_ROOT, & MPI_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM, & STATUS,IERR) ENDDO ENDIF ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN C -- send to MASTER II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- send all in on shot CALL MPI_SEND(PTR_RHS_ROOT(II), & SIZE_ROOT*NBRHS_EFF, & MPI_COMPLEX, & MASTER, 0, id%COMM,IERR) ELSE DO K=1, NBRHS_EFF CALL MPI_SEND(PTR_RHS_ROOT(II),SIZE_ROOT, & MPI_COMPLEX, & MASTER, 0, id%COMM,IERR) II = II + SIZE_ROOT ENDDO ENDIF ENDIF C -- other procs are not concerned ENDIF ENDIF ! ===== END OF REDUCED RHS (Schur+Fwd only performed) == C ======================================================= C BACKWARD was PERFORMED C Postprocess solution that is distributed IF ( KEEP(221) .NE. 1 ) THEN ! BACKWARD was PERFORMED C -- KEEP(221).NE.1 => we are sure that backward has been performed IF (ICNTL21 == 0) THEN ! CENTRALIZED SOLUTION C{ ======================================================== C GATHER SOLUTION computed during bwd C Each proc holds the pieces of solution corresponding C to all fully summed variables mapped on that processor C (i.e. corresponding to master nodes mapped on that proc) C In case of A-1 we gather directly in RHS_SPARSE C the distributed solution. C Scaling is done in all case on the fly of the reception C Note that when only FORWARD has been performed C RSH_MUMPS holds the solution computed during forward step C (CMUMPS_SOL_R) C there is no need to copy back in RSH_MUMPS the solution C ======================================================== C centralized solution IF (KEEP(237).EQ.0) THEN C CWORK not needed for AM1 LCWORK = max(max(KEEP(247),KEEP(246)),1) ALLOCATE( CWORK(LCWORK), stat=allocok ) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) ENDIF ENDIF IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & .AND. (id%NSLAVES.NE.1)) THEN C Precompute map of indices in current column C (no need to reset it between columns ALLOCATE (MAP_RHS(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) ' Problem allocation of MAP_RHS at solve' ENDIF INFO(1) = -13 INFO(2) = id%N ELSE NB_BYTES = NB_BYTES + int(id%N,8) * K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) C Return in case of error. IF (INFO(1).LT.0) GO TO 90 #if defined(USE_OLD_SCALING) 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 #endif LIW_PASSED = max( LIW, 1 ) TIMEGATHER1=MPI_WTIME() IF ( .NOT.I_AM_SLAVE ) THEN C I did not participate to computing part of the solution C (id%RHSINTR not set/allocate) : receive solution, store C it and scale it. IF (KEEP(237).EQ.0) THEN C We need a workspace of minimal size KEEP(247) C in order to unpack pieces of the solution. CALL CMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & MTYPE, id%RHS(1), LD_RHS, id%NRHS, JBEG_RHS, & JDUMMY, id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), IDUMMY, 1, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), LCWORK, LSCAL, #if defined(USE_OLD_SCALING) & PT_SCALING(1), size(PT_SCALING), #else & SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), #endif & C_DUMMY, 1 , 1, IDUMMY, 1, & PERM_RHS, size(PERM_RHS) ! for sparse permuted RHS & ) ELSE C only gather target entries of A-1 CALL CMUMPS_GATHER_SOLUTION_AM1(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & C_DUMMY, 1, 1, & id%KEEP(1), BUFR(1), LBUFR, LBUFR_BYTES, #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING) #else & LSCAL, SCALING_RHSINTR_BWD(1), & size(SCALING_RHSINTR_BWD) #endif C --- A-1 related entries & ,IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), & UNS_PERM_INV, size(UNS_PERM_INV), & IDUMMY, 1, 0 & ) ENDIF ELSE C Avoid temporary copy (IS(1)) that some old C compilers would do otherwise IF (KEEP(237).EQ.0) THEN IF (id%MYID.EQ.MASTER) THEN PTR_RHS => id%RHS NCOL_RHS_loc = id%NRHS LD_RHS_loc = LD_RHS JBEG_RHS_loc = JBEG_RHS ELSE PTR_RHS => CDUMMY_TARGET NCOL_RHS_loc = 1 LD_RHS_loc = 1 JBEG_RHS_loc = 1 ENDIF CALL CMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, MTYPE, & PTR_RHS(1), LD_RHS_loc, NCOL_RHS_loc, JBEG_RHS_loc, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), IS(1), LIW_PASSED, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), LCWORK, #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING), #else & LSCAL, SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), #endif & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, NBRHS_EFF, & id%GLOB2LOC_SOL(1), id%N, & PERM_RHS, size(PERM_RHS) ! For sparse permuted RHS & ) ELSE ! only gather target entries of A-1 CALL CMUMPS_GATHER_SOLUTION_AM1(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, NBRHS_EFF, & id%KEEP(1), BUFR(1), LBUFR, LBUFR_BYTES, #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING) #else & LSCAL, SCALING_RHSINTR_BWD(1), size(SCALING_RHSINTR_BWD) #endif C --- A-1 related entries & , IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), & UNS_PERM_INV, size(UNS_PERM_INV), & id%GLOB2LOC_SOL(1), id%N, NB_FS_RHSINTR_TOT & ) ENDIF ENDIF TIMEGATHER2=MPI_WTIME()-TIMEGATHER1+TIMEGATHER2 IF (KEEP(237).EQ.0) DEALLOCATE( CWORK ) IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & ) THEN C Copy back solution from RHS_SPARSE_COPY TO RHS_SPARSE DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN PJ = PERM_RHS(J) ELSE PJ =J ENDIF COLSIZE = id%IRHS_PTR(PJ+1) - & id%IRHS_PTR(PJ) IF (COLSIZE.EQ.0) CYCLE JJ = J-JBEG_RHS+1 C Precompute map of indices in current column C (no need to reset it between columns IF (id%NSLAVES.NE.1) THEN DO II=1, COLSIZE MAP_RHS(id%IRHS_SPARSE( & id%IRHS_PTR(PJ) + II - 1)) = II ENDDO DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 II = IRHS_SPARSE_COPY(IZ2) id%RHS_SPARSE(id%IRHS_PTR(PJ)+MAP_RHS(II)-1)= & RHS_SPARSE_COPY(IZ2) ENDDO ELSE C Entries within a column are in order C IZ - Column index in Sparse RHS DO IZ= id%IRHS_PTR(PJ), id%IRHS_PTR(PJ+1)-1 IZ2 = IRHS_PTR_COPY(JJ) + & IZ - id%IRHS_PTR(PJ) id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDIF ENDDO IF (id%NSLAVES.NE.1) THEN NB_BYTES = NB_BYTES - int(size(MAP_RHS),8) * K34_8 DEALLOCATE ( MAP_RHS ) ENDIF ENDIF ! end A-1 on master C C} -- END of backward was performed with centralized solution ELSE ! (KEEP(221).NE.1) .AND.(ICNTL21.NE.0)) C C BEGIN of backward performed with distributed solution C time local copy + scaling TIMECOPYSCALE1=MPI_WTIME() C The non working host should not do this: IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF ( KEEP(89) .GT. 0 ) THEN IF ( LSCAL .AND. id%KEEP(89).GT.0) THEN #if defined(USE_OLD_SCALING) SCALING_LOC_BWD => scaling_data_sol%SCALING_LOC #else IF (MTYPE.EQ.1) THEN SCALING_LOC_BWD => id%COLSCA_loc ELSE SCALING_LOC_BWD => id%ROWSCA_loc ENDIF #endif ELSE SCALING_LOC_BWD => RDUMMY_TARGET ENDIF CALL CMUMPS_DISTRIBUTED_SOLUTION(id%NSLAVES, & id%N,id%MYID_NODES, & MTYPE, id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, & NBRHS_EFF, id%GLOB2LOC_SOL(1), & id%ISOL_loc(1), id%SOL_loc(1), id%NRHS, & JBEG_RHS-NB_RHSSKIPPED, id%LSOL_loc, & id%PTLUST_S(1), id%PROCNODE_STEPS(1), & id%KEEP(1),id%KEEP8(1), & IS(1), LIW_PASSED, id%STEP(1), & SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), & LSCAL, NB_RHSSKIPPED, & PERM_RHS, size(PERM_RHS) ) ! For permuted sparse RHS ENDIF ENDIF TIMECOPYSCALE2=MPI_WTIME()-TIMECOPYSCALE1+TIMECOPYSCALE2 ENDIF C === BACKWARD was PERFORMED WITH DISTRIBUTED SOLUTION === C ======================================================== ENDIF ! ==== END of BACKWARD was PERFORMED (KEEP(221).NE.1) C note that the main DO-loop on blocks is not ended yet C C ============================================ C BEGIN C C ITERATIVE REFINEMENT AND/OR ERROR ANALYSIS C C ============================================ IF ( ICNTL10 > 0 .AND. NBRHS_EFF > 1 ) THEN C C ---------------------------------- C Multiple RHS: apply a fixed number C of iterative refinement steps C ---------------------------------- C DO I = 1, ICNTL10 write(6,*) ' Internal error 15 in sol_driver ' C Compute residual: Y <- SAVERHS - A * RHS C Solve RHS <- A^-1 Y, Y modified C Assemble in RHS(REDUCE) C RHS <- RHS + Y C END DO END IF IF (POSTPros) THEN C{ C SAVERHS holds the original right hand side C Sparse rhs are saved in SAVERHS as dense rhs C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C Start iterative refinements. The master is managing the C organisation of work, but slaves are used to solve systems of C equations and, in case of distributed matrix, perform C matrix-vector products. It is more complicated to do this with C the SPMD version than it was with the master/slave approach. C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * c IF ( PROK .AND. ICNTL10 .NE. 0 ) WRITE( MP, 270 ) IF ( PROKG .AND. ICNTL10 .NE. 0 ) WRITE( MPG, 270 ) C Initializations and allocations NITREF = abs(ICNTL10) ALLOCATE(R_Y(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 ALLOCATE(C_Y(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 IF ( id%MYID .EQ. MASTER ) THEN ALLOCATE( IW1( 2 * id%N ),stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=2 * id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(2*id%N,8)*K34_8 ALLOCATE( C_W(id%N), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 ALLOCATE( R_W(2*id%N), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(2*id%N,8)*K16_8 C end allocations on Master END IF ALLOCATE(C_LOCWK54(id%N),stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 ALLOCATE(R_LOCWK54(id%N),stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 KASE = 0 C Synchro point with broadcast of errors 777 CONTINUE NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 C TIMEEA needed if EA and IR with stopping criterium C and IR with fixed n.of steps. TIMEEA = 0.0E0 C TIMEEA1 needed if EA and IR with fixed n.of steps TIMEEA1 = 0.0E0 CALL MUMPS_SECDEB(TIMEIT) C ------------------------- C C RHSOL holds the initial guess for the solution C We start the loop on the Iterative refinement procedure C C C C |- IRefin. L O O P -| C V V C C ========================================================= C Computation of the infinity norm of A C ========================================================= IF ((ICNTL11.GT.0).OR.(ICNTL10.GT.0)) THEN C We don't get through these lines if ICNTL10<=0 AND ICNTL11<=0 IF ( KEEP(54) .eq. 0 ) THEN C ------------------ C Centralized matrix C ------------------ IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------------- C Call CMUMPS_SOL_X outside, if needed, C in order to compute w(i,2)=sum|Aij|,j=1:n C in vector R_W(id%N+i) C ----------------------------------------- IF (KEEP(55).NE.0) THEN C unassembled matrix and norm of row required CALL CMUMPS_SOL_X_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), id%A_ELT(1), & R_W(id%N+1), KEEP(1),KEEP8(1) ) ELSE C assembled matrix IF ( MTYPE .eq. 1 ) THEN CALL CMUMPS_SOL_X & ( id%A(1), id%KEEP8(28), id%N, id%IRN(1), id%JCN(1), & R_W(id%N+1), KEEP(1),KEEP8(1), & 0, id%SYM_PERM(1) ) ELSE CALL CMUMPS_SOL_X & ( id%A(1), id%KEEP8(28), id%N, id%JCN(1), id%IRN(1), & R_W(id%N+1), KEEP(1),KEEP8(1), & 0, id%SYM_PERM(1) ) END IF ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL CMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1), & 0, id%SYM_PERM(1) ) ELSE CALL CMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%JCN_loc(1), id%IRN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1), & 0, id%SYM_PERM(1) ) END IF ELSE R_LOCWK54 = RZERO END IF C ------------------------- C Assemble result on master C ------------------------- IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_W( id%N + 1 ), & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) END IF C End if KEEP(54) END IF C IF ( id%MYID .eq. MASTER ) THEN C R_W is available on the master process only RINFOG(4) = real(ZERO) DO I = 1, id%N RINFOG(4) = max(R_W( id%N +I), RINFOG(4)) ENDDO ENDIF C end ICNTL11 =/0 v ICNTL10>0 ENDIF C ========================================================= C END norm of A C ========================================================= C Initializations for the IR NOITER = 0 IFLAG_IR = 0 TESTConv = .FALSE. IF ( id%MYID .eq. MASTER ) THEN IF (ICNTL10.GT.0) THEN C Test of convergence should be made TESTConv = .TRUE. ARRET = CNTL(2) IF (ARRET .LT. 0.0E0) THEN ARRET = sqrt(epsilon(0.0E0)) END IF IF ( PROKG ) THEN WRITE( MPG, 240) NITREF, ARRET,id%DKEEP(22) ENDIF ELSE IF ( PROKG ) THEN WRITE( MPG, 245) NITREF ENDIF ENDIF C ========================================================= C Starting IR DO 22 IRStep = 1, NITREF +1 C ========================================================= C C ========================================================= C Refine the solution starting from the second step of do loop C ========================================================= IF (( id%MYID .eq. MASTER ).AND.(IRStep.GT.1)) THEN NOITER = NOITER + 1 DO I = 1, id%N id%RHS(IBEG+I-1) = id%RHS(IBEG+I-1) + C_Y(I) ENDDO ENDIF C =========================================== C Computation of the RESIDUAL and of |A||x| C =========================================== IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN IF (KEEP(55).NE.0) THEN C input matrix by element CALL CMUMPS_ELTYD( MTYPE, id%N, & id%NELT, id%ELTPTR(1), id%LELTVAR, & id%ELTVAR(1), id%KEEP8(30), id%A_ELT(1), & SAVERHS, id%RHS(IBEG), & C_Y, R_W, KEEP(50)) ELSE IF ( MTYPE .eq. 1 ) THEN CALL CMUMPS_SOL_Y(id%A(1), id%KEEP8(28), & id%N, id%IRN(1), & id%JCN(1), SAVERHS, & id%RHS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ELSE CALL CMUMPS_SOL_Y(id%A(1), id%KEEP8(28), & id%N, id%JCN(1), & id%IRN(1), SAVERHS, & id%RHS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ENDIF ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- CALL MPI_BCAST( RHS_IR(IBEG), id%N, & MPI_COMPLEX, MASTER, & id%COMM, IERR ) C -------------------------------------- C Compute Y = SAVERHS - A * RHS C Y, SAVERHS defined only on master C -------------------------------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN CALL CMUMPS_LOC_MV8( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_Y, & id%N, MPI_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) C =========================== C_Y = SAVERHS - C_Y C =========================== ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) END IF C -------------------------------------- C Compute C * If MTYPE = 1 C W(i) = Sum | Aij | | RHSj | C j C * If MTYPE = 0 C W(j) = Sum | Aij | | RHSi | C i C R_LOCWK54 used as local array for W C RHS has been broadcasted C -------------------------------------- IF ( I_AM_SLAVE .and. id%KEEP8(29) .NE. 0_8 ) THEN CALL CMUMPS_LOC_OMEGA1( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), R_LOCWK54, KEEP(50), MTYPE ) ELSE R_LOCWK54 = RZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_W, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, & id%N, MPI_REAL, & MPI_SUM, MASTER, id%COMM, IERR) ENDIF ENDIF C ===================================== C END computation RESIDUAL and |A||x| C ===================================== IF ( id%MYID .eq. MASTER ) THEN C IF ((ICNTL11.GT.0).OR.(ICNTL10.GT.0)) THEN C -------------- C Error analysis and test of convergence, C Compute the sparse componentwise backward error: C - at each step if test of convergence of IR is C requested (ICNTL(10)>0) C - at step 1 and NITREF+1 if error analysis C to be computed (ICNTL(11)>0) and if ICNTL(10)< 0 IF (((ICNTL11.GT.0).OR.((ICNTL10.LT.0).AND. & ((IRStep.EQ.1).OR.(IRStep.EQ.NITREF+1))) & .OR.((ICNTL10.EQ.0).AND.(IRStep.EQ.1))) & .OR.(ICNTL10.GT.0)) THEN C Compute w1 and w2 C always if ICNTL10>0 in the other case if ICNTL11>0 C ----------------- IF (ICNTL10.LT.0) CALL MUMPS_SECDEB(TIMEEA1) CALL CMUMPS_SOL_OMEGA(id%N,SAVERHS, & id%RHS(IBEG), C_Y, R_W, C_W, IW1, IFLAG_IR, & RINFOG(7), NOITER, TESTConv, & MP, ARRET, KEEP(361), id%DKEEP(22) ) IF (ICNTL10.LT.0) THEN CALL MUMPS_SECFIN(TIMEEA1) id%DKEEP(120)=id%DKEEP(120)+real(TIMEEA1) ENDIF ENDIF IF ((ICNTL11.GT.0).AND.( & (ICNTL10.LT.0.AND.(IRStep.EQ.1.OR.IRStep.EQ.NITREF+1)) & .OR.((ICNTL10.GE.0).AND.(IRStep.EQ.1)) & )) THEN C Error analysis before iterative refinement C or for last if icntl10<0 C ------------------------------------------ CALL MUMPS_SECDEB(TIMEEA) IF (ICNTL10.EQ.0) THEN C No IR : there will be only the EA of the 1st sol. IF ( MPG .GT. 0 ) WRITE( MPG, 170 ) ELSEIF (IRStep.EQ.1) THEN C IR : we print the EA of the 1st sol. IF ( MPG .GT. 0 ) WRITE( MPG, 55 ) ELSEIF ((ICNTL10.LT.0).AND.(IRStep.EQ.NITREF+1)) THEN C IR with fixed n. of steps: we print the EA C of the last sol. IF ( MPG .GT. 0 ) THEN WRITE( MPG, 81 ) WRITE( MPG, * ) WRITE( MPG, 141 ) & 'NUMBER OF STEPS OF ITERATIVE REFINEMENT REQUESTED =', & NOITER ENDIF ENDIF GIVSOL = .TRUE. CALL CMUMPS_SOL_Q(MTYPE,INFO(1),id%N, & id%RHS(IBEG), & SAVERHS,R_W(id%N+1),C_Y,GIVSOL, & RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) IF ( MPG .GT. 0 ) THEN C Error analysis before iterative refinement WRITE( MPG, 115 ) & 'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', & RINFOG(7) WRITE( MPG, 115 ) & '------(8):---------------------------- (W2)=', & RINFOG(8) END IF CALL MUMPS_SECFIN(TIMEEA) id%DKEEP(120)=id%DKEEP(120)+real(TIMEEA) C end EA of the first solution END IF END IF C -------------- IF (IRStep.EQ.NITREF +1) THEN C If we are at the NITREF+1 step , we have refined the C solution NITREF times so we have to stop. KASE = 0 C If we test the convergence (ICNTL10.GT.0) and C IFLAG_IR = 0 we set a warning : more than NITREF steps C needed IF ((ICNTL10.GT.0).AND.(IFLAG_IR.EQ.0)) & id%INFO(1) = id%INFO(1) + 8 ELSE IF (ICNTL10.GT.0) THEN C ------------------- C Results of the test of convergence. C IFLAG_IR = 0 we should try to improve the solution C = 1 the stopping criterium is satisfied C = 2 the method is diverging, we go back C to the previous iterate C = 3 the convergence is too slow IF (IFLAG_IR.GT.0) THEN C If the convergence criterion is satisfied C or the convergence too slow C we set KASE=0 (end of the Iterative refinement) KASE = 0 C If the convergence is not improved, C we go back to the previous iterate. C IFLAG_IR can be equal to 2 only if IRStep >= 2 IF (IFLAG_IR.EQ.2) NOITER = NOITER - 1 ELSE C IFLAG_IR=0, try to improve the solution KASE = 2 ENDIF ELSEIF (ICNTL10.LT.0) THEN C ------------------- KASE = 2 ELSE C ICNTL10 = 0, we want to perform only EA and not IR. C ----------------- KASE = 0 END IF ENDIF C End Master ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C If Kase= 0 we quit the IR process IF (KASE.LE.0) GOTO 666 IF (KASE.LT.0) THEN WRITE(*,*) "Internal error 17 in CMUMPS_SOL_DRIVER" ENDIF C ========================================================= C COMPUTE the solution of Ay = r C ========================================================= C Call internal routine to avoid code duplication CALL CMUMPS_PP_SOLVE() IF (INFO(1) .LT. 0) GOTO 90 C ----------------------- C Go back to beginning of C loop to apply next step C of iterative refinement C ----------------------- 22 CONTINUE 666 CONTINUE C ************************************************ C C End of the iterative refinement procedure C C ************************************************ CALL MUMPS_SECFIN(TIMEIT) IF ( id%MYID .EQ. MASTER ) THEN IF ( NITREF .GT. 0 ) THEN id%INFOG(15) = NOITER END IF C id%DKEEP(114) time for the iterative refinement C id%DKEEP(120) time for the error analysis C id%DKEEP(121) time for condition number C these values are meaningful only on the host. IF (ICNTL10.EQ.0) THEN C No IR has been requested. All the time is needed C for computing EA id%DKEEP(120)=real(TIMEIT) ELSE C IR has been requested id%DKEEP(114)=real(TIMEIT)-id%DKEEP(120) ENDIF END IF IF ( PROKG ) THEN IF (ICNTL10.GT.0) THEN WRITE( MPG, 81 ) WRITE( MPG, * ) WRITE( MPG, 141 ) & 'NUMBER OF STEPS OF ITERATIVE REFINEMENTS PERFORMED =', & NOITER ENDIF ENDIF C C ================================================== C BEGIN C Perform error analysis after iterative refinement C ================================================== IF ((ICNTL11 .GT. 0).AND.(ICNTL10.GT.0)) THEN C If IR is requested with test of convergence, C the EA of the last step of IR is done here, C otherwise EA of the last step is done at the C end of IR CALL MUMPS_SECDEB(TIMEEA) KASE = 0 IF (id%MYID .eq. MASTER ) THEN C Test if IFLAG_IR = 2, that is if the the IR was diverging, C we went back to the previous iterate C We have to do EA on the last computed solution. IF (IFLAG_IR.EQ.2) KASE = 2 ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KASE.EQ.2) THEN C We went back to the previous iterate C We have to do EA on the last computed solution. C Compute the residual in C_Y using IRN, JCN, ASPK C and the solution RHS(IBEG) C The norm of the ith row in R_Y(I). IF ( KEEP(54) .eq. 0 ) THEN C --------------------- C Matrix is centralized C --------------------- IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN CALL CMUMPS_QD2( MTYPE, id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), & id%RHS(IBEG), SAVERHS, R_Y, C_Y, KEEP(1),KEEP8(1)) ELSE CALL CMUMPS_ELTQD2( MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), id%A_ELT(1), & id%RHS(IBEG), SAVERHS, R_Y, C_Y, KEEP(1),KEEP8(1)) ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- CALL MPI_BCAST( RHS_IR(IBEG), id%N, & MPI_COMPLEX, MASTER, & id%COMM, IERR ) C ---------------- C Compute residual C ---------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN CALL CMUMPS_LOC_MV8( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_Y, & id%N, MPI_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) C_Y = SAVERHS - C_Y ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) END IF ENDIF ENDIF ! KASE.EQ.2 IF (id%MYID .EQ. MASTER) THEN C Compute which equations are associated to w1 and which C ones are associated to w2 in case of IFLAG_IR=2. C If IFLAG_IR = 0 or 1 IW1 should be correct IF (IFLAG_IR.EQ.2) THEN TESTConv = .FALSE. CALL CMUMPS_SOL_OMEGA(id%N,SAVERHS, & id%RHS(IBEG), C_Y, R_W, C_W, IW1, IFLAG_IR, & RINFOG(7), 0, TESTConv, & MP, ARRET, KEEP(361), id%DKEEP(22) ) ENDIF ! (IFLAG_IR.EQ.2) c Compute some statistics for GIVSOL = .TRUE. CALL CMUMPS_SOL_Q(MTYPE,INFO(1),id%N, & id%RHS(IBEG), & SAVERHS,R_W(id%N+1),C_Y,GIVSOL, & RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) ENDIF ! Master CALL MUMPS_SECFIN(TIMEEA) id%DKEEP(120)=id%DKEEP(120)+real(TIMEEA) ENDIF ! ICNTL11>0 and ICNTL10>0 C ========================================================= C Compute the Condition number associated if requested. C ========================================================= CALL MUMPS_SECDEB(TIMELCOND) IF (ICNTL11 .EQ. 1) THEN IF ( id%MYID .eq. MASTER ) THEN C Notice that D is always the identity ALLOCATE( D(id%N),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 DO I = 1, id%N D( I ) = RONE END DO ENDIF KASE = 0 222 CONTINUE IF ( id%MYID .EQ. MASTER ) THEN CALL CMUMPS_SOL_LCOND(id%N, SAVERHS, & id%RHS(IBEG), C_Y, D, R_W, C_W, IW1, KASE, & RINFOG(7), RINFOG(9), RINFOG(10), & MP, KEEP(1),KEEP8(1)) ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C KASE <= 0 C We reach the end of iterative method to compute C LCOND1 and LCOND2 IF (KASE.LE.0) GOTO 224 CALL CMUMPS_PP_SOLVE() IF (INFO(1) .LT. 0) GOTO 90 C --------------------------- C Go back to beginning of C loop to apply next step C of iterative method C ----------------------- GO TO 222 C End ICNTL11 = 1 ENDIF 224 CONTINUE CALL MUMPS_SECFIN(TIMELCOND) id%DKEEP(121)=id%DKEEP(121)+real(TIMELCOND) IF ((id%MYID .EQ. MASTER).AND.(ICNTL11.GT.0)) THEN IF (ICNTL10.GT.0) THEN C If ICNTL10<0 these stats have been printed before IR IF ( MPG .GT. 0 ) THEN WRITE( MPG, 115 ) & 'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', & RINFOG(7) WRITE( MPG, 115 ) & '------(8):---------------------------- (W2)=', & RINFOG(8) ENDIF END IF IF (ICNTL11.EQ.1) THEN C If ICNTL11/=1 these stats haven't been computed IF (MPG.GT.0) THEN WRITE( MPG, 115 ) & '------(9):Upper bound ERROR ...............=', & RINFOG(9) WRITE( MPG, 115 ) & '-----(10):CONDITION NUMBER (1) ............=', & RINFOG(10) WRITE( MPG, 115 ) & '-----(11):CONDITION NUMBER (2) ............=', & RINFOG(11) END IF END IF END IF ! MASTER && ICNTL11.GT.0 IF ( PROKG ) THEN WRITE( MPG, * ) IF (abs(ICNTL10) .GT.0 ) WRITE( MPG, 101 ) id%DKEEP(114) IF (ICNTL11 .GT.0 ) WRITE( MPG, 102 ) id%DKEEP(120) IF (ICNTL11 .EQ.1 ) WRITE( MPG, 103 ) id%DKEEP(121) WRITE( MPG, * ) ENDIF IF ( PROKG .AND. abs(ICNTL10) .GT.0 ) WRITE( MPG, 131 ) C=================================================== C Perform error analysis after iterative refinements C END C=================================================== C IF (id%MYID == MASTER) THEN NB_BYTES = NB_BYTES - int(size(C_W),8)*K35_8 DEALLOCATE(C_W) NB_BYTES = NB_BYTES - int(size(R_W),8)*K16_8 & - int(size(IW1),8)*K34_8 DEALLOCATE(R_W) DEALLOCATE(IW1) IF (ICNTL11 .EQ. 1) THEN C We have used D only for LCOND1,2 NB_BYTES = NB_BYTES - int(size(D ),8)*K16_8 DEALLOCATE(D) ENDIF ENDIF NB_BYTES = NB_BYTES - & (int(size(R_Y),8)+int(size(R_LOCWK54),8))*K16_8 NB_BYTES = NB_BYTES - & (int(size(C_Y),8)+int(size(C_LOCWK54),8))*K35_8 DEALLOCATE(R_Y) DEALLOCATE(C_Y) DEALLOCATE(R_LOCWK54) DEALLOCATE(C_LOCWK54) C} End POSTPros END IF C============================================ C C ITERATIVE REFINEMENT AND/OR ERROR ANALYSIS C C END C C============================================ C ========================== C Begin reordering on master C corresponding to maximum transversal permutation C in case of centralized solution C (ICNTL21==0) C IF ( id%MYID .EQ. MASTER .AND. ICNTL21==0 & .AND. KEEP(23) .NE. 0.AND.KEEP(237).EQ.0) THEN C ((No transpose and backward performed and NO A-1) C or null space computation): permutation C must be done on solution. IF ((KEEP(221).NE.1 .AND. MTYPE .EQ. 1) & .OR. KEEP(111) .NE.0 .OR. KEEP(252).NE.0 ) THEN C Permute the solution RHS according to the column C permutation held in UNS_PERM C Column J of the permuted matrix corresponds to C column UNS_PERM(J) of the original matrix. C RHS holds the permuted solution C Note that id%N>1 since KEEP(23)=0 when id%N=1 C ALLOCATE( C_RW1( id%N ),stat =allocok ) ! temporary not in NB_BYTES IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) & WRITE(LP,*) 'could not allocate ', id%N, 'integers.' CALL MUMPS_ABORT() END IF DO K = 1, NBRHS_EFF IF (KEEP(242).EQ.0) THEN KDEC = (K-1)*LD_RHS+IBEG-1 ELSE C ------------------------------- C Columns just computed might not C be contiguous in original RHS C ------------------------------- KDEC = int(PERM_RHS(K-1+JBEG_RHS)-1,8)*int(LD_RHS,8) ENDIF DO I = 1, id%N C_RW1(I) = id%RHS(KDEC+I) ENDDO DO I = 1, id%N JPERM = id%UNS_PERM(I) id%RHS( KDEC+JPERM ) = C_RW1( I ) ENDDO ENDDO DEALLOCATE( C_RW1 ) !temporary not in NB_BYTES END IF END IF C C End reordering on master C ======================== IF (id%MYID.EQ.MASTER .and.ICNTL21==0.and.KEEP(221).NE.1.AND. & (KEEP(237).EQ.0) ) THEN * print out the solution IF ( INFO(1) .GE. 0 .AND. ICNTL(4).GE.3 .AND. ICNTL(3).GT.0) & THEN K = min(10, id%N) IF (ICNTL(4) .eq. 4 ) K = id%N J = min(10,NBRHS_EFF) IF (ICNTL(4) .eq. 4 ) J = NBRHS_EFF DO II=1, J WRITE(ICNTL(3),110) BEG_RHS+II-1 WRITE(ICNTL(3),160) & (id%RHS(IBEG+(II-1)*LD_RHS+I-1),I=1,K) ENDDO END IF END IF C ========================== C blocking for multiple RHS (END OF DO WHILE (BEG_RHS.LE.NBRHS) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN ! case of general sparse: in case of empty columns ! NBRHS_EFF might has been updated and broadcasted ! and holds the effective size of a contiguous block of ! non empty columns BEG_RHS = BEG_RHS + NBRHS_EFF ! nb of nonempty columns ELSE BEG_RHS = BEG_RHS + NBRHS ENDIF C } ENDDO C END DO WHILE (BEG_RHS.LE.id%NRHS) C ================================= C C ======================================================== C Reset RHS to zero for all remaining columns that C have not been processed because they were emtpy C ======================================================== IF ( (id%MYID.EQ.MASTER) & .AND. ( KEEP(248).NE.0 ) ! sparse RHS on input & .AND. ( KEEP(237).EQ.0 ) ! No A-1 & .AND. ( ICNTL21.EQ.0 ) ! Centralized solution & .AND. ( KEEP(221) .NE.1 ) ! Not Reduced RHS step of Schur & .AND. ( JEND_RHS .LT. id%NRHS ) & ) & THEN JBEG_NEW = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%N id%RHS(int(PERM_RHS(JBEG_NEW) -1,8)*int(LD_RHS,8)+I) & = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ELSE DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%N id%RHS(int(JBEG_NEW -1,8)*int(LD_RHS,8) + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ENDIF C ======================================================== C Reset id%SOL_loc to zero for all remaining columns that C have not been processed because they were empty C ======================================================== IF ( I_AM_SLAVE .AND. (ICNTL21.NE.0) .AND. & ( JEND_RHS .LT. id%NRHS ) .AND. KEEP(221).NE.1 ) THEN JBEG_NEW = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, NSOL_loc id%SOL_loc(int(PERM_RHS(JBEG_NEW) -1,8)* & int(id%LSOL_loc,8)+int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ELSE C DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, NSOL_loc id%SOL_loc((JBEG_NEW -1)*id%LSOL_loc + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF C C ================================================================ C Reset id%RHSINTR and id%REDRHS to zero for all remaining columns C that have not been processed because they were emtpy C ================================================================ IF ((KEEP(221).EQ.1) .AND. & ( JEND_RHS .LT. id%NRHS ) ) THEN IF (id%MYID .EQ. MASTER) THEN JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%SIZE_SCHUR id%REDRHS(int(JBEG_NEW -1,8)*int(LD_REDRHS,8) + & int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF IF (I_AM_SLAVE) THEN JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1,NBENT_RHSINTR id%RHSINTR(int(JBEG_NEW -1,8)*int(id%LD_RHSINTR,8) + & int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF C C C ! maximum size used on that proc id%INFO(26) = int(NB_BYTES_MAX / 1000000_8) C Centralize memory statistics on the host C C INFOG(30) = size of mem in bytes for solve C for the processor using largest memory C INFOG(31) = size of mem in bytes for solve C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(26), id%INFOG(30), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I10) ') & ' ** Rank of processor needing largest memory in solve :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used by this processor for solve :', & id%INFOG(30) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during solve :', & ( id%INFOG(31)-id%INFO(26) ) / id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during solve :', & id%INFOG(31) / id%NSLAVES END IF ELSE WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used for solve :', & id%INFOG(30) ENDIF END IF *=============================== *End of Solve Phase *=============================== C Store and print timings CALL MUMPS_SECFIN(TIME3) id%DKEEP(112)=real(TIME3) id%DKEEP(113)=real(TIMEC2) id%DKEEP(115)=real(TIMESCATTER2) id%DKEEP(116)=real(TIMEGATHER2) id%DKEEP(122)=real(TIMECOPYSCALE2) C Reductions of DKEEP(115,116,117,118,119,122): CALL MPI_REDUCE( id%DKEEP(115), id%DKEEP(160),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(116), id%DKEEP(161),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(117), id%DKEEP(162),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(118), id%DKEEP(163),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(119), id%DKEEP(164),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(122), id%DKEEP(165),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) C IF (PROKG) THEN WRITE ( MPG, *) WRITE ( MPG, *) "Leaving solve with ..." WRITE( MPG, 434 ) id%DKEEP(160) ! max id%DKEEP(115) WRITE( MPG, 432 ) id%DKEEP(113) ! ok without reduction WRITE( MPG, 435 ) id%DKEEP(162) ! max id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MPG, 437 ) id%DKEEP(164) ! id%DKEEP(119) WRITE( MPG, 436 ) id%DKEEP(163) ! id%DKEEP(118) WRITE( MPG, 433 ) id%DKEEP(161) ! max(DKEEP(116)) -- Gather WRITE( MPG, 431 ) id%DKEEP(165) ! max(DKEEP(122)) -- Dist. sol. ENDIF IF ( PROK ) THEN WRITE ( MP, *) WRITE ( MP, *) "Local statistics" WRITE( MP, 434 ) id%DKEEP(115) WRITE( MP, 432 ) id%DKEEP(113) WRITE( MP, 435 ) id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MP, 437 ) id%DKEEP(119) WRITE( MP, 436 ) id%DKEEP(118) WRITE( MP, 433 ) id%DKEEP(116) WRITE( MP, 431 ) id%DKEEP(122) END IF 90 CONTINUE IF (KEEP(400) .GT. 0) THEN CALL MUMPS_SOL_L0OMP_LD(KEEP(400)) ENDIF IF (INFO(1) .LT.0 ) THEN IF (INFO(1) .EQ. -80) INFO(1) = -81 ENDIF C -- related to exploit sparsity IF (associated(nodes_FWD)) THEN NB_BYTES = NB_BYTES - size(nodes_FWD) * K34_8 DEALLOCATE(nodes_FWD) NULLIFY(nodes_FWD) ENDIF IF (associated(nodes_BWD)) THEN NB_BYTES = NB_BYTES - size(nodes_BWD) * K34_8 DEALLOCATE(nodes_BWD) NULLIFY(nodes_BWD) ENDIF IF (allocated(Pruned_Sons_FWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_FWD) * K34_8 DEALLOCATE(Pruned_Sons_FWD) ENDIF IF (allocated(Pruned_Sons_BWD)) THEN NB_BYTES = NB_BYTES - size(Pruned_Sons_BWD) * K34_8 DEALLOCATE(Pruned_Sons_BWD) ENDIF IF (SCALING_RHSINTR_FWD_ALLOCATED) THEN NB_BYTES = NB_BYTES - LSCALING_RHSINTR_FWD * K16_8 DEALLOCATE(SCALING_RHSINTR_FWD) ENDIF SCALING_RHSINTR_FWD_ALLOCATED = .FALSE. NULLIFY(SCALING_RHSINTR_FWD) IF (SCALING_RHSINTR_BWD_ALLOCATED) THEN NB_BYTES = NB_BYTES - LSCALING_RHSINTR_BWD * K16_8 DEALLOCATE(SCALING_RHSINTR_BWD) ENDIF SCALING_RHSINTR_BWD_ALLOCATED = .FALSE. NULLIFY(SCALING_RHSINTR_BWD) IF (KEEP(485) .EQ. 1) THEN KEEP(350) = KEEP350_SAVE IF (IS_LR_MOD_TO_STRUC_DONE) THEN CALL CMUMPS_BLR_MOD_TO_STRUC(id%BLRARRAY_ENCODING) CALL MUMPS_FDM_MOD_TO_STRUC('F',id%FDM_F_ENCODING, & id%INFO(1)) ENDIF ENDIF IF (KEEP(19).EQ.0.AND.KEEP(53).NE.0) THEN C restore KEEP(20) KEEP(20) = KEEP20_SAVE ENDIF IF (KEEP(201).GT.0)THEN IF (IS_INIT_OOC_DONE) THEN CALL CMUMPS_OOC_END_SOLVE(IERR) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) ENDIF C ------------------------ C Check allocation before C to deallocate (cases of C errors that could happen C before or after allocate C statement) C C Sparse RHS C Free space and reset pointers if needed IF (IRHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_SPARSE_COPY),8)*K34_8 DEALLOCATE(IRHS_SPARSE_COPY) IRHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_SPARSE_COPY) ENDIF IF (IRHS_PTR_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_PTR_COPY),8)*K34_8 DEALLOCATE(IRHS_PTR_COPY) IRHS_PTR_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_PTR_COPY) ENDIF IF (RHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(RHS_SPARSE_COPY),8)*K35_8 DEALLOCATE(RHS_SPARSE_COPY) RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_SPARSE_COPY) ENDIF IF (allocated(MAP_RHS_loc)) THEN NB_BYTES = NB_BYTES - int(size(MAP_RHS_loc),8)*K34_8 DEALLOCATE(MAP_RHS_loc) ENDIF IF (IRHS_loc_PTR_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(IRHS_loc_PTR),8)*K34_8 DEALLOCATE(IRHS_loc_PTR) NULLIFY(IRHS_loc_PTR) IRHS_loc_PTR_ALLOCATED = .FALSE. ENDIF #if defined(USE_OLD_SCALING) IF (I_AM_SLAVE.AND.LSCAL.AND.KEEP(248).EQ.-1) THEN IF (associated(scaling_data_dr%SCALING_LOC)) THEN NB_BYTES = NB_BYTES - & int(size(scaling_data_dr%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data_dr%SCALING_LOC) NULLIFY (scaling_data_dr%SCALING_LOC) ENDIF ENDIF #endif IF (allocated(PERM_RHS)) THEN NB_BYTES = NB_BYTES - int(size(PERM_RHS),8)*K34_8 DEALLOCATE(PERM_RHS) ENDIF C END A-1 IF (allocated(UNS_PERM_INV)) THEN NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 DEALLOCATE(UNS_PERM_INV) ENDIF IF (allocated(BUFR)) THEN NB_BYTES = NB_BYTES - int(size(BUFR),8)*K34_8 DEALLOCATE(BUFR) ENDIF IF ( I_AM_SLAVE ) THEN IF (allocated(RHS_BOUNDS)) THEN NB_BYTES = NB_BYTES - & int(size(RHS_BOUNDS),8)*K34_8 DEALLOCATE(RHS_BOUNDS) ENDIF IF (allocated(IWK_SOLVE)) THEN NB_BYTES = NB_BYTES - int(size(IWK_SOLVE),8)*K34_8 DEALLOCATE( IWK_SOLVE ) ENDIF IF (allocated(PTRACB)) THEN NB_BYTES = NB_BYTES - int(size(PTRACB),8)*K34_8* & int(KEEP(10),8) DEALLOCATE( PTRACB ) ENDIF IF (allocated(IWCB)) THEN NB_BYTES = NB_BYTES - int(size(IWCB),8)*K34_8 DEALLOCATE( IWCB ) ENDIF C ------------------------ C SLAVE CODE C ----------------------- C Deallocate send buffers C ----------------------- IF (id%NSLAVES .GT. 1) THEN CALL MUMPS_BUF_DEALL_CB( IERR ) CALL MUMPS_BUF_DEALL_SMALL_BUF( IERR ) ENDIF END IF C IF ( id%MYID .eq. MASTER ) THEN C ------------------------ C SAVERHS may have been C allocated only on master C ------------------------ IF (allocated(SAVERHS)) THEN NB_BYTES = NB_BYTES - int(size(SAVERHS),8)*K35_8 DEALLOCATE( SAVERHS) ENDIF C Nullify RHS_IR might have been pointing to id%RHS NULLIFY(RHS_IR) ELSE C -------------------- C Free right-hand-side C on slave processors C -------------------- IF (associated(RHS_IR)) THEN NB_BYTES = NB_BYTES - int(size(RHS_IR),8)*K35_8 DEALLOCATE(RHS_IR) NULLIFY(RHS_IR) END IF END IF IF (I_AM_SLAVE) THEN C Deallocate temporary workspace SRW3 IF (allocated(SRW3)) THEN NB_BYTES = NB_BYTES - int(size(SRW3),8)*K151_8 DEALLOCATE(SRW3) ENDIF #if defined(USE_OLD_SCALING) C Free local scaling arrays IF (LSCAL .AND. ICNTL21 .NE. 0) THEN IF (associated(scaling_data_sol%SCALING_LOC)) THEN NB_BYTES = NB_BYTES - & int(size(scaling_data_sol%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data_sol%SCALING_LOC) NULLIFY(scaling_data_sol%SCALING_LOC) ENDIF ENDIF #endif #if defined(USE_OLD_SCALING) #endif C Free memory until next call to CMUMPS IF (WK_USER_PROVIDED) THEN C S points to WK_USER provided by user C KEEP8(24) holds size of WK_USER C it should be kept on exit because it will be used C at a future solve to check that size provided is consistent C (see error -41) NULLIFY(id%S) ELSE IF (ALLOCATE_S) THEN C S was allocated, free it NB_BYTES = NB_BYTES - KEEP8(23)*K35_8 id%KEEP8(23)=0_8 DEALLOCATE(id%S) NULLIFY(id%S) NB_BYTES = NB_BYTES - KEEP8(23) * K35_8 KEEP8(23) = 0_8 ENDIF IF (KEEP(221).NE.1 & ) THEN C -- After reduction of RHS to Schur variables C -- keep compressed RHS generated during FWD step C -- to be used for future expansion IF (associated(id%RHSINTR)) THEN NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSINTR) NULLIFY(id%RHSINTR) id%KEEP8(25) = 0_8 id%LD_RHSINTR = 0 ENDIF IF (associated(id%GLOB2LOC_RHS)) THEN NB_BYTES = NB_BYTES - & int(size(id%GLOB2LOC_RHS),8)*K34_8 DEALLOCATE(id%GLOB2LOC_RHS) NULLIFY(id%GLOB2LOC_RHS) ENDIF IF (id%GLOB2LOC_SOL_ALLOC) THEN NB_BYTES = NB_BYTES - & int(size(id%GLOB2LOC_SOL),8)*K34_8 DEALLOCATE(id%GLOB2LOC_SOL) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. ENDIF ENDIF IF ( WORK_WCB_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(WORK_WCB),8)*K151_8 DEALLOCATE( WORK_WCB ) NULLIFY ( WORK_WCB ) ELSE C Otherwise, WORK_WCB may point to some C position inside id%S, nullify it NULLIFY( WORK_WCB ) ENDIF IF ( PTR_RHS_ROOT_ALLOCATED ) THEN DEALLOCATE(PTR_RHS_ROOT) NB_BYTES = NB_BYTES - LPTR_RHS_ROOT * K151_8 ENDIF NULLIFY(PTR_RHS_ROOT) ENDIF #if defined(STAT_ES_SOLVE) IF ( & (id%MYID.EQ.MASTER).AND. & ( (id%KEEP(235).NE.0).OR.(id%KEEP(212).NE.0) ) & ) & THEN C If exploit sparsity then C stats saved in DKEEP(200:204) and C set RINFOG(24), RINFOG(25), RINFOG(26) CALL CMUMPS_SOL_ES_PRINT_STATS( & id%KEEP(212), id%KEEP(235), id%KEEP(237), & id%KEEP(485), id%KEEP(497), & id%KEEP8(110),id%NRHS, id%ICNTL(27), id%N, & id%KEEP(50), id%DKEEP(200:204), & id%RINFOG(24:28), MPG) END IF #endif 500 CONTINUE RETURN 55 FORMAT (//' ERROR ANALYSIS BEFORE ITERATIVE REFINEMENT') 100 FORMAT(//' ****** SOLVE & CHECK STEP ********'/) 110 FORMAT (//' Vector solution for column ',I12) 115 FORMAT(1X, A44,1P,D9.2) 434 FORMAT(' Time to build/scatter RHS =',F15.6) 432 FORMAT(' Time in solution step (fwd/bwd) =',F15.6) 435 FORMAT(' .. Time in forward (fwd) step = ',F15.6) 437 FORMAT(' .. Time in ScaLAPACK root = ',F15.6) 436 FORMAT(' .. Time in backward (bwd) step = ',F15.6) 433 FORMAT(' Time to gather solution(cent.sol)=',F15.6) 431 FORMAT(' Time for distributed solution =',F15.6) 150 FORMAT(' GLOBAL STATISTICS PRIOR SOLVE PHASE ...........'/ & ' Number of right-hand-sides =',I12/ & ' Blocking factor for multiple rhs =',I12/ & ' ICNTL (9) =',I12/ & ' --- (10) =',I12/ & ' --- (11) =',I12/ & ' --- (20) =',I12/ & ' --- (21) =',I12/ & ' --- (30) =',I12/ & ' --- (35) =',I12/ & ' --- (48) (effective) =',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 ( & 2X, "Maximum number of steps = ",I4/, & 2X, "Effective stopping criterion (based on CNTL(2)) = ",E14.6/ & 2x, "Slow convergence threshold (W1+W2 ratio) = ",E14.6) 245 FORMAT ( & 2X, "Number of steps is fixed = ",I4) 270 FORMAT (/' BEGIN ITERATIVE REFINEMENT' ) 81 FORMAT (/' STATISTICS AFTER ITERATIVE REFINEMENT ') 101 FORMAT(' Time for Iterative Refinement =',F12.4) 102 FORMAT(' Time for Error Analysis =',F12.4) 103 FORMAT(' Time for Condition Number =',F12.4) 131 FORMAT (' END ITERATIVE REFINEMENT '/) 141 FORMAT(1X, A52,I4) ! Number of steps performed CONTAINS SUBROUTINE CMUMPS_CHECK_DISTRHS( & idNloc_RHS, & idLRHS_loc, & NRHS, & idIRHS_loc, & idRHS_loc, & I_AM_SLAVE, & INFO) C C Purpose: C ======= C C Check distributed RHS format. We assume that C the user has indicated that he/she provided C a distributed RHS (KEEP(248)=-1). We also C assume that the nb of RHS columns NRHS has C been broadcasted to all processes. This C routine should then be called on the workers. C C Arguments: C ========= C INTEGER, INTENT( IN ) :: idNloc_RHS INTEGER, INTENT( IN ) :: idLRHS_loc INTEGER, INTENT( IN ) :: NRHS LOGICAL, INTENT( IN ) :: I_AM_SLAVE #if defined(MUMPS_NOF2003) INTEGER, POINTER :: idIRHS_loc (:) COMPLEX, POINTER :: idRHS_loc (:) #else INTEGER, INTENT( IN ), POINTER :: idIRHS_loc (:) COMPLEX, INTENT( IN ), POINTER :: idRHS_loc (:) #endif INTEGER, INTENT( INOUT ) :: INFO(80) C C Local declarations: C ================== C INTEGER(8) :: REQSIZE8 C C Executable statements: C ===================== C C Quick return if nothing on this proc IF (idNloc_RHS .LE. 0) RETURN IF (idNloc_RHS .GT. 0 .AND. .NOT. I_AM_SLAVE) THEN C Nloc_RHS should not be greater than 0 C on a non working host because the distribution C of the RHS does not include the non working host. INFO(1)=-55 INFO(2)=-idLRHS_loc RETURN ENDIF C Check for leading dimension IF (NRHS.NE.1) THEN IF ( idLRHS_loc .LT. idNloc_RHS) THEN INFO(1)=-55 INFO(2)=idLRHS_loc RETURN ENDIF ENDIF IF (idNloc_RHS .GT. 0) THEN C Check association and size of index array idIRHS_loc IF (.NOT. associated(idIRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=17 RETURN ELSE IF (size(idIRHS_loc) .LT. idNloc_RHS) THEN INFO(1)=-22 INFO(2)= 17 RETURN ENDIF C Check association and size of value array idRHS_loc IF (.NOT. associated(idRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=18 RETURN ELSE C Check size of array of values idRHS_loc REQSIZE8 = int(idLRHS_loc,8)*int(NRHS,8) & + int(-idLRHS_loc+idNloc_RHS,8) #if defined(MUMPS_NOF2003) IF ( REQSIZE8 .LE. int(huge(idNloc_RHS),8) .AND. & size(idRHS_loc) .LT. int(REQSIZE8) ) THEN #else IF (size(idRHS_loc,kind=8) .LT. REQSIZE8) THEN #endif INFO(1)=-22 INFO(2)=18 RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_CHECK_DISTRHS SUBROUTINE CMUMPS_PP_SOLVE() IMPLICIT NONE C C Purpose: C ======= C Scatter right-hand side, solve the system, C and gather the solution on the host during C post-processing. C We use an internal subroutine to avoid code C duplication without the complication of adding C new parameters or local variables. All variables C in this routine have the scope of CMUMPS_SOL_DRIVER. C C IF (KASE .NE. 1 .AND. KASE .NE. 2) THEN WRITE(*,*) "Internal error 1 in CMUMPS_PP_SOLVE" CALL MUMPS_ABORT() ENDIF IF ( id%MYID .eq. MASTER ) THEN C Define matrix B as follows: C MTYPE=1 => B=A other values B=At C The user asked to solve the system Bx=b C C THEN C KASE = 1........ RW1 = INV(TRANSPOSE(B)) * RW1 C KASE = 2........ RW1 = INV(B) * RW1 IF ( MTYPE .EQ. 1 ) THEN SOLVET = KASE - 1 ELSE SOLVET = KASE END IF C SOLVET= 1 -> solve A x = B, other values solve Atx=b C We force SOLVET to have value either 0 or 1, in order C to be able to test both values, and also, be able to C test whether SOLVET = MTYPE or not. IF ( SOLVET.EQ.2 ) SOLVET = 0 #if defined(USE_OLD_SCALING) IF ( LSCAL ) THEN IF ( SOLVET .EQ. 1 ) THEN C Apply rowscaling DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%ROWSCA( K ) END DO ELSE C Apply column scaling DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%COLSCA( K ) END DO END IF END IF #endif END IF ! MYID.EQ.MASTER C ------------------------------ C Broadcast SOLVET to the slaves C ------------------------------ CALL MPI_BCAST( SOLVET, 1, MPI_INTEGER, MASTER, & id%COMM, IERR) #if ! defined(USE_OLD_SCALING) IF (LSCAL .AND. id%KEEP(89) .GT. 0) THEN IF (SOLVET .EQ. 1) THEN SCALING_LOC_FWD => id%ROWSCA_LOC ELSE SCALING_LOC_FWD => id%COLSCA_LOC ENDIF ELSE SCALING_LOC_FWD => RDUMMY_TARGET ENDIF #endif C -------------------------------------------- C Scatter the right hand side C_Y on all procs C -------------------------------------------- IF ( .NOT.I_AM_SLAVE ) THEN C -- Master not working CALL CMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, LSCAL, SCALING_LOC_FWD(1), & SOLVET, C_Y(1), id%N, 1, & 1, & C_DUMMY, 1, 1, & IDUMMY, 0, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ELSE IF (SOLVET.EQ.MTYPE) THEN C GLOB2LOC_RHS is with respect to the C original linear system (transposed or not) PTR_POSINRHSINTR_FWD => id%GLOB2LOC_RHS ELSE C Transposed, use column indices of original C system (ie, col indices of A or A^T) PTR_POSINRHSINTR_FWD => id%GLOB2LOC_SOL ENDIF LIW_PASSED = max( LIW, 1 ) CALL CMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, LSCAL, SCALING_LOC_FWD(1), & SOLVET, C_Y(1), id%N, 1, & 1, & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, 1, & PTR_POSINRHSINTR_FWD(1), NB_FS_RHSINTR_F, C & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ENDIF IF (INFO(1).LT.0) GOTO 89 C C Solve the system C IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) IF (SOLVET.EQ.MTYPE) THEN PTR_POSINRHSINTR_FWD => id%GLOB2LOC_RHS PTR_POSINRHSINTR_BWD => id%GLOB2LOC_SOL ELSE PTR_POSINRHSINTR_FWD => id%GLOB2LOC_SOL PTR_POSINRHSINTR_BWD => id%GLOB2LOC_RHS ENDIF FROM_PP=.TRUE. NBSPARSE_LOC = .FALSE. CALL CMUMPS_SOL_C(idintr%root,idintr%roota, & id%N,id%S(1),LA_PASSED,id%IS(1), & LIW_PASSED,WORK_WCB(1),LWCB8,IWCB,LIWCB,NBRHS_EFF,id%NA(1), & id%LNA,id%NE_STEPS(1),SRW3,SOLVET,ICNTL(1),FROM_PP,id%STEP(1), & id%FRERE_STEPS(1),id%DAD_STEPS(1),id%FILS(1),id%PTLUST_S(1), & id%PTRFAC(1), IWK_SOLVE(1), LIWK_SOLVE, PTRACB, LIWK_PTRACB, & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1), KEEP(1), KEEP8(1), & id%DKEEP(1),id%COMM_NODES,id%MYID,id%MYID_NODES, BUFR(1), LBUFR, & LBUFR_BYTES, id%ISTEP_TO_INIV2(1), id%TAB_POS_IN_PERE(1,1), C Next 3 arguments are not used in this call & IBEG_ROOT_DEF,IEND_ROOT_DEF,IROOT_DEF_RHS_COL1, PTR_RHS_ROOT(1), & LPTR_RHS_ROOT, SIZE_ROOT, MASTER_ROOT, id%RHSINTR(IBEG_RHSINTR), & id%LD_RHSINTR,PTR_POSINRHSINTR_FWD(1),PTR_POSINRHSINTR_BWD(1), & -1, -1, & IDUMMY(1), IDUMMY(1), & 1,1,1, IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY, 1,1, & NBSPARSE_LOC, PTR_RHS_BOUNDS(1), LPTR_RHS_BOUNDS #if defined(STAT_ES_SOLVE) & , IDUMMY, 1, JDUMMY, 1 #endif & , id%IPOOL_B_L0_OMP(1), id%LPOOL_B_L0_OMP, id%IPOOL_A_L0_OMP(1), & id%LPOOL_A_L0_OMP, id%L_VIRT_L0_OMP, id%VIRT_L0_OMP(1), & id%L_PHYS_L0_OMP, id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1), & id%PTR_LEAFS_L0_OMP(1), id%L0_OMP_MAPPING(1), id%LL0_OMP_MAPPING, & idintr%L0_OMP_FACTORS(1), id%LL0_OMP_FACTORS & ) END IF C ------------------ C Change error codes C ------------------ IF (INFO(1).eq.-2) INFO(1)=-12 IF (INFO(1).eq.-3) INFO(1)=-15 C IF (INFO(1) .GE. 0) THEN C We need a workspace of minimal size KEEP(247) C in order to unpack pieces of the solution during C CMUMPS_GATHER_SOLUTION below C - Avoid allocation if error already occurred. C - DEALLOCATE called after GATHER_SOLUTION C CWORK not needed for AM1 ALLOCATE( CWORK(max(max(KEEP(247),KEEP(246)),1)), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- 89 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) C C Return in case of error. IF (INFO(1).LT.0) RETURN C ------------------------------- C Assemble the solution on master C ------------------------------- C (Note: currently, if this part of code is executed, C then necessarily NBRHS_EFF = 1) C C === GATHER and SCALE solution ============== C #if defined(USE_OLD_SCALING) 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 #else IF (id%KEEP(89) .EQ. 0 .OR. .NOT. LSCAL) THEN SCALING_LOC_BWD => RDUMMY_TARGET ELSE IF (SOLVET.EQ.1) THEN SCALING_LOC_BWD => id%COLSCA_loc ELSE SCALING_LOC_BWD => id%ROWSCA_loc ENDIF ENDIF #endif LIW_PASSED = max( LIW, 1 ) C Solution computed during CMUMPS_SOL_C has been stored C in id%RHSINTR and is gathered on the master in C_Y IF ( .NOT. I_AM_SLAVE ) THEN C I did not participate to computing part of the solution C (id%RHSINTR not set/allocate) : receive solution, store C it and scale it. CALL CMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & SOLVET, C_Y, id%N, NBRHS_EFF, 1, & JDUMMY, id%KEEP(1),id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), size(CWORK), #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING), #else & LSCAL, SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), #endif ! RHSINTR not on non-working master & C_DUMMY, 1 , 1, IDUMMY, 1, ! for sparse permuted RHS on host & PERM_RHS, size(PERM_RHS) & ) ELSE CALL CMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & SOLVET, C_Y, id%N, NBRHS_EFF, 1, & id%PTLUST_S(1), id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), size(CWORK), #if defined(USE_OLD_SCALING) & LSCAL, PT_SCALING(1), size(PT_SCALING), #else & LSCAL, SCALING_LOC_BWD(1), size(SCALING_LOC_BWD), #endif & id%RHSINTR(IBEG_RHSINTR), id%LD_RHSINTR, NBRHS_EFF, & PTR_POSINRHSINTR_BWD(1), id%N, & PERM_RHS, size(PERM_RHS)) ! for sparse permuted RHS on host ENDIF DEALLOCATE( CWORK ) END SUBROUTINE CMUMPS_PP_SOLVE END SUBROUTINE CMUMPS_SOLVE_DRIVER MUMPS_5.8.1/src/cana_lr.F0000664000175000017500000017733315042446440014754 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_ANA_LR USE CMUMPS_LR_CORE USE MUMPS_LR_STATS USE MUMPS_LR_COMMON USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY: LMATRIX_T !$ USE OMP_LIB, ONLY: omp_get_max_threads IMPLICIT NONE CONTAINS SUBROUTINE GET_CUT(IWR, NASS, NCB, LRGROUPS, NPARTSCB, & NPARTSASS, CUT) INTEGER, INTENT(IN) :: NASS, NCB INTEGER, INTENT(IN) :: IWR(*) INTEGER, INTENT(IN), DIMENSION(:) :: LRGROUPS INTEGER, INTENT(OUT) :: NPARTSCB, NPARTSASS INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: I, CURRENT_PART, CUTBUILDER,allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: BIG_CUT ALLOCATE(BIG_CUT(max(NASS,1)+NCB+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of BIG_CUT in GET_CUT" CALL MUMPS_ABORT() ENDIF CURRENT_PART = LRGROUPS(IWR(1)) BIG_CUT(1) = 1 BIG_CUT(2) = 2 CUTBUILDER = 2 NPARTSASS = 0 NPARTSCB = 0 DO I = 2,NASS + NCB IF (LRGROUPS(IWR(I)) == CURRENT_PART) THEN BIG_CUT(CUTBUILDER) = BIG_CUT(CUTBUILDER) + 1 ELSE CUTBUILDER = CUTBUILDER + 1 BIG_CUT(CUTBUILDER) = BIG_CUT(CUTBUILDER-1) + 1 CURRENT_PART = LRGROUPS(IWR(I)) END IF IF (I == NASS) NPARTSASS = CUTBUILDER - 1 END DO IF (NASS.EQ.1) NPARTSASS= 1 NPARTSCB = CUTBUILDER - 1 - NPARTSASS ALLOCATE(CUT(max(NPARTSASS,1)+NPARTSCB+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of CUT in GET_CUT" CALL MUMPS_ABORT() ENDIF IF (NPARTSASS.EQ.0) THEN CUT(1) = 1 CUT(2:2+NPARTSCB) = BIG_CUT(1:1+NPARTSCB) ELSE CUT = BIG_CUT(1:NPARTSASS+NPARTSCB+1) ENDIF if(allocated(BIG_CUT)) DEALLOCATE(BIG_CUT) END SUBROUTINE GET_CUT SUBROUTINE SEP_GROUPING( NFRONT, KEEP, & NV, VLIST, N, NZ, LRGROUPS, NBGROUPS, IW, & LW, IPE, LEN, GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, NODE, & GEN2HALO, K482, K472, K469, SEP_SIZE, MAXSIZE_PARTS, & KEEP10, LP, LPOK, IFLAG, IERROR) INTEGER, INTENT(IN) :: NFRONT, KEEP(500) INTEGER(8), INTENT(IN) :: NZ, LW INTEGER, INTENT(IN) :: NV, N, GROUP_SIZE, HALO_DEPTH INTEGER, INTENT(IN) :: IW(LW), LEN(N), NODE, K482 INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: K472, K469, SEP_SIZE, KEEP10, LP LOGICAL :: LPOK INTEGER, INTENT(INOUT) :: NBGROUPS, WORKH(N) INTEGER, INTENT(INOUT) :: VLIST(NV), TRACE(N) INTEGER :: LRGROUPS(:) INTEGER, INTENT(INOUT) :: GEN2HALO(N) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: MAXSIZE_PARTS INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IPTRHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: PARTS, JCNHALO INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBG_CAPT, & NBGROUPS_KWAY, I, GROUP_SIZE2, LRGROUPS_SIGN, IERR INTEGER :: MAXSIZE_PARTS_LOC #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) INTEGER :: METIS_IDX_SIZE #endif #if defined (scotch) || defined (ptscotch) INTEGER :: SCOTCH_IDX_SIZE #endif CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV, & NFRONT, KEEP(35)) NBGROUPS_KWAY = MAX( & INT(real(NV+GROUP_SIZE2-1)/real(GROUP_SIZE2)) & ,1) IF (NV .GE. SEP_SIZE) THEN LRGROUPS_SIGN = 1 ELSE LRGROUPS_SIGN = -1 ENDIF IF (NBGROUPS_KWAY > 1) THEN IF (K469.EQ.3) THEN !$OMP CRITICAL(gethalo_cri) CALL GETHALONODES(N, IW, LW, IPE, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, LEN, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(max(HALOEDGENBR,1)), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) ENDIF CALL GETHALOGRAPH(WORKH, NHALO, N, IW, LW, IPE, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO) !$OMP END CRITICAL(gethalo_cri) IF (IFLAG.LT.0) RETURN ELSE CALL GETHALONODES(N, IW, LW, IPE, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, LEN, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(max(HALOEDGENBR,1)), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) RETURN ENDIF CALL GETHALOGRAPH(WORKH, NHALO, N, IW, LW, IPE, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO) ENDIF IF (K482.EQ.1) THEN #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_KWAY_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ELSE IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 1 ELSE CALL MUMPS_METIS_KWAY_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ENDIF #endif ELSE IF (K482.EQ.2) THEN #if defined (scotch) || defined (ptscotch) CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_IDX_SIZE) IF (SCOTCH_IDX_SIZE .EQ. 32) THEN IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 2 ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto32( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto64( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) END IF IF ((IFLAG.LT.0).AND.LPOK) THEN WRITE(LP,*) " Internal error in SCOTCH during ", & " Kway partitioning, SCOTCHFGRAPHPART, " WRITE(LP,*) & " please also provide METIS package to MUMPS " ENDIF #endif ELSE WRITE(6,*) " Internal ERROR K482=", K482 CALL MUMPS_ABORT() END IF IF (IFLAG.LT.0) GOTO 500 CALL GET_GLOBAL_GROUPS(PARTS, VLIST, NV, & NBGROUPS_KWAY, LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN, & MAXSIZE_PARTS_LOC, .FALSE., GROUP_SIZE2) MAXSIZE_PARTS = max(MAXSIZE_PARTS, MAXSIZE_PARTS_LOC) ELSE MAXSIZE_PARTS = max(MAXSIZE_PARTS,NV) !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + 1 !$OMP END ATOMIC DO I=1,NV LRGROUPS(VLIST(I)) = LRGROUPS_SIGN*(NBG_CAPT + 1) END DO END IF 500 IF (allocated(IPTRHALO)) then DEALLOCATE(IPTRHALO) ENDIF IF (allocated(PARTS)) then DEALLOCATE(PARTS) ENDIF IF (allocated(JCNHALO)) then DEALLOCATE(JCNHALO ) ENDIF RETURN END SUBROUTINE SEP_GROUPING SUBROUTINE SEP_GROUPING_AB ( NFRONT, KEEP, & NV, NVEXPANDED, & VLIST, N, LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, NODE, & GEN2HALO, K482, K472, K469, SEP_SIZE, MAXSIZE_PARTS, & KEEP10, LP, LPOK, IFLAG, IERROR) INTEGER, INTENT(IN) :: NFRONT, KEEP(500) TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: NV, NVEXPANDED, & N, GROUP_SIZE, HALO_DEPTH INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: NODE, K482 INTEGER, INTENT(IN) :: K472, K469, SEP_SIZE, KEEP10, LP LOGICAL :: LPOK INTEGER, INTENT(INOUT) :: NBGROUPS, WORKH(N) INTEGER, INTENT(INOUT) :: VLIST(NV), TRACE(N) INTEGER :: LRGROUPS(:) INTEGER, INTENT(INOUT) :: GEN2HALO(N) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: MAXSIZE_PARTS INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IPTRHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: PARTS, JCNHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: VWGT INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBG_CAPT, & NBGROUPS_KWAY, I, GROUP_SIZE2, LRGROUPS_SIGN, IERR INTEGER :: MAXSIZE_PARTS_LOC REAL :: COMPRESS_RATIO LOGICAL :: AB_ACTIVE #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) INTEGER :: METIS_IDX_SIZE #endif #if defined (scotch) || defined (ptscotch) INTEGER :: SCOTCH_IDX_SIZE #endif AB_ACTIVE = (NVEXPANDED.GT.NV) CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED, & NFRONT, KEEP(35)) COMPRESS_RATIO= real(NVEXPANDED)/real(NV) NBGROUPS_KWAY = MAX( & INT(real(NVEXPANDED+GROUP_SIZE2-1)/real(GROUP_SIZE2)) & ,1) NBGROUPS_KWAY = min(NBGROUPS_KWAY, NV) IF (NVEXPANDED .GE. SEP_SIZE) THEN LRGROUPS_SIGN = 1 ELSE LRGROUPS_SIGN = -1 ENDIF IF (NBGROUPS_KWAY > 1) THEN IF (K469.EQ.3) THEN !$OMP CRITICAL(gethalo_cri) CALL GETHALONODES_AB(N, LUMAT, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(max(HALOEDGENBR,1)), VWGT(NHALO), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) ENDIF DO I=1, NHALO VWGT(I) = SIZEOFBLOCKS(WORKH(I)) ENDDO CALL GETHALOGRAPH_AB(WORKH, NV, & NHALO, N, LUMAT, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO, PARTS) !$OMP END CRITICAL(gethalo_cri) IF (IFLAG.LT.0) RETURN ELSE CALL GETHALONODES_AB(N, LUMAT, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(max(HALOEDGENBR,1)), VWGT(NHALO), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) RETURN ENDIF DO I=1, NHALO VWGT(I) = SIZEOFBLOCKS(WORKH(I)) ENDDO CALL GETHALOGRAPH_AB(WORKH, NV, & NHALO, N, LUMAT, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO, PARTS) ENDIF IF (K482.EQ.1) THEN #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_KWAY_AB_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) ELSE IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 1 ELSE CALL MUMPS_METIS_KWAY_AB_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ENDIF #endif ELSE IF (K482.EQ.2) THEN #if defined (scotch) || defined (ptscotch) CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_IDX_SIZE) IF (SCOTCH_IDX_SIZE .EQ. 32) THEN IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 2 ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto32( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto64( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) END IF IF ((IFLAG.LT.0).AND.LPOK) THEN WRITE(LP,*) " Internal error in SCOTCH during ", & " Kway partitioning, SCOTCHFGRAPHPART, " WRITE(LP,*) & " also provide METIS package to MUMPS " ENDIF #endif ELSE WRITE(6,*) " Internal ERROR K482=", K482 CALL MUMPS_ABORT() END IF IF (IFLAG.LT.0) GOTO 500 CALL GET_GLOBAL_GROUPS(PARTS,VLIST, NV, & NBGROUPS_KWAY, LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN, & MAXSIZE_PARTS_LOC, AB_ACTIVE, GROUP_SIZE2) MAXSIZE_PARTS = max( MAXSIZE_PARTS, & int(real(MAXSIZE_PARTS_LOC*COMPRESS_RATIO)) ) ELSE MAXSIZE_PARTS = max(MAXSIZE_PARTS,NV) !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + 1 !$OMP END ATOMIC DO I=1,NV LRGROUPS(VLIST(I)) = LRGROUPS_SIGN*(NBG_CAPT + 1) END DO END IF 500 IF (allocated(IPTRHALO)) then DEALLOCATE(IPTRHALO) ENDIF IF (allocated(PARTS)) then DEALLOCATE(PARTS) ENDIF IF (allocated(JCNHALO)) then DEALLOCATE(JCNHALO ) ENDIF IF (allocated(VWGT)) then DEALLOCATE(VWGT) ENDIF RETURN END SUBROUTINE SEP_GROUPING_AB SUBROUTINE GETHALONODES_AB(N, LUMAT, IND, NIND, PMAX, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) TYPE(LMATRIX_T) :: LUMAT INTEGER,DIMENSION(:),INTENT(IN) :: IND INTEGER, INTENT(IN) :: N, NODE INTEGER, INTENT(IN) :: PMAX,NIND INTEGER, INTENT(OUT) :: NHALO INTEGER, INTENT(INOUT) :: TRACE(N), WORKH(N) INTEGER :: GEN2HALO(N) INTEGER(8), INTENT(OUT) :: HALOEDGENBR INTEGER :: I, J, II INTEGER :: HALOI, NB, NEWNHALO INTEGER(8) :: SEPEDGES_TOTAL, & SEPEDGES_INTERNAL WORKH(1:NIND) = IND NHALO = NIND NEWNHALO = 0 HALOEDGENBR = 0_8 SEPEDGES_TOTAL = 0_8 SEPEDGES_INTERNAL = 0_8 DO I=1,NIND HALOI = WORKH(I) GEN2HALO(HALOI) = I IF (TRACE(HALOI) .NE. NODE) THEN TRACE(HALOI) = NODE END IF ENDDO DO I=1,NIND HALOI = WORKH(I) NB = LUMAT%COL(HALOI)%NBINCOL SEPEDGES_TOTAL = SEPEDGES_TOTAL + int(NB,8) DO J=1, NB II = LUMAT%COL(HALOI)%IRN(J) IF (TRACE(II).NE.NODE) THEN NEWNHALO = NEWNHALO + 1 WORKH(NHALO+NEWNHALO) = II GEN2HALO(II) = NHALO+NEWNHALO TRACE(II) = NODE ELSE IF (GEN2HALO(II).LE.NHALO) THEN SEPEDGES_INTERNAL = SEPEDGES_INTERNAL + 1_8 ENDIF ENDIF ENDDO END DO HALOEDGENBR = SEPEDGES_TOTAL + & (SEPEDGES_TOTAL - SEPEDGES_INTERNAL) NHALO = NHALO + NEWNHALO END SUBROUTINE GETHALONODES_AB SUBROUTINE GETHALOGRAPH_AB(HALO,NSEP,NHALO, & N,LUMAT,IPTRHALO,JCNHALO, & HALOEDGENBR,TRACE,NODE, GEN2HALO, IQ) INTEGER, INTENT(IN) :: N TYPE(LMATRIX_T) :: LUMAT INTEGER,INTENT(IN):: NSEP, NHALO, NODE INTEGER,INTENT(IN):: GEN2HALO(N) INTEGER,DIMENSION(NHALO),INTENT(IN) :: HALO INTEGER, INTENT(IN) :: TRACE(N) INTEGER(8),INTENT(IN) :: HALOEDGENBR INTEGER(8), INTENT(OUT) :: IPTRHALO(NHALO+1) INTEGER, INTENT(OUT) :: JCNHALO(max(HALOEDGENBR,1)) INTEGER :: IQ(NHALO) INTEGER::I,J,NB,II,JJ,HALOI,HALOJ DO I=NSEP+1, NHALO IQ(I) = 0 ENDDO DO I=1,NSEP HALOI = HALO(I) NB = LUMAT%COL(HALOI)%NBINCOL IQ(I) = NB DO JJ=1, NB II = LUMAT%COL(HALOI)%IRN(JJ) J = GEN2HALO(II) IF (J.GT.NSEP) THEN IQ(J) = IQ(J) + 1 ENDIF ENDDO ENDDO IPTRHALO(1) = 1_8 DO I=1,NHALO IPTRHALO(I+1) = IPTRHALO(I)+int(IQ(I),8) ENDDO DO I=1,NSEP HALOI = HALO(I) NB = LUMAT%COL(HALOI)%NBINCOL DO JJ=1, NB HALOJ = LUMAT%COL(HALOI)%IRN(JJ) J = GEN2HALO(HALOJ) JCNHALO(IPTRHALO(I)) = J IPTRHALO(I) = IPTRHALO(I) + 1 IF (J.GT.NSEP) THEN JCNHALO(IPTRHALO(J)) = I IPTRHALO(J) = IPTRHALO(J) + 1 ENDIF ENDDO ENDDO IPTRHALO(1) = 1_8 DO I=1,NHALO IPTRHALO(I+1) = IPTRHALO(I)+int(IQ(I),8) ENDDO END SUBROUTINE GETHALOGRAPH_AB SUBROUTINE GET_GLOBAL_GROUPS(PARTS, SEP, NSEP, NPARTS, & LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN, & MAXSIZE_PARTS_LOC, AB_ACTIVE, GROUP_SIZE2) INTEGER,INTENT(IN) :: NSEP, N, LRGROUPS_SIGN, GROUP_SIZE2 INTEGER :: PARTS(:) LOGICAL :: AB_ACTIVE INTEGER,DIMENSION(:),INTENT(INOUT) :: SEP INTEGER, INTENT(INOUT) :: NPARTS INTEGER, INTENT(INOUT) :: NBGROUPS INTEGER :: LRGROUPS(:) INTEGER, INTENT(OUT) :: MAXSIZE_PARTS_LOC INTRINSIC maxval INTEGER:: I,CNT,NB_PARTS_WITHOUT_SEP_NODE,allocok INTEGER:: TARGET_SIZE_KWAY INTEGER:: MAXSIZE_PARTS_LOC_NEW, NBG_CAPT INTEGER,DIMENSION(:),ALLOCATABLE::SIZES, RIGHTPART INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR #if ! defined(NO_SPLIT_IN_BLRGROUPING) INTEGER :: NB_PARTS_WITH_SPLIT, IP, SZ_FINAL, II, NB_SPLIT INTEGER :: TARGET_SIZE_SPLIT #endif INTEGER,DIMENSION(:),ALLOCATABLE :: NEWSEP ALLOCATE( NEWSEP(NSEP), & SIZES(NPARTS), & RIGHTPART(NPARTS), & PARTPTR(NPARTS+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GLOBAL_GROUPS" CALL MUMPS_ABORT() ENDIF TARGET_SIZE_KWAY = GROUP_SIZE2 TARGET_SIZE_SPLIT = TARGET_SIZE_KWAY IF (AB_ACTIVE) TARGET_SIZE_SPLIT =huge(TARGET_SIZE_SPLIT) NB_PARTS_WITHOUT_SEP_NODE = 0 RIGHTPART = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = SIZES(PARTS(I)) + 1 END DO MAXSIZE_PARTS_LOC = maxval(SIZES) CNT = 0 PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) IF (SIZES(I-1)==0) THEN NB_PARTS_WITHOUT_SEP_NODE = NB_PARTS_WITHOUT_SEP_NODE + 1 ELSE CNT = CNT + 1 RIGHTPART(I-1) = CNT #if ! defined(NO_SPLIT_IN_BLRGROUPING) SIZES(CNT) = SIZES(I-1) #endif END IF END DO NPARTS = NPARTS - NB_PARTS_WITHOUT_SEP_NODE #if ! defined(NO_SPLIT_IN_BLRGROUPING) IF (MAXSIZE_PARTS_LOC.LT.TARGET_SIZE_SPLIT) THEN #endif !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + NPARTS !$OMP END ATOMIC DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) LRGROUPS(SEP(I)) = LRGROUPS_SIGN*(RIGHTPART(PARTS(I)) & + NBG_CAPT) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO SEP = NEWSEP #if ! defined(NO_SPLIT_IN_BLRGROUPING) ELSE DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO SEP = NEWSEP PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) ENDDO NB_PARTS_WITH_SPLIT = 0 MAXSIZE_PARTS_LOC_NEW = 0 DO IP =1, NPARTS NB_SPLIT = (SIZES(IP) + TARGET_SIZE_SPLIT-1) & / TARGET_SIZE_SPLIT SZ_FINAL = (SIZES(IP) + NB_SPLIT-1) / NB_SPLIT NB_PARTS_WITH_SPLIT = NB_PARTS_WITH_SPLIT + & ( & ( (PARTPTR(IP+1) - PARTPTR(IP))+ SZ_FINAL-1 ) / & SZ_FINAL & ) ENDDO !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + NB_PARTS_WITH_SPLIT !$OMP END ATOMIC NB_PARTS_WITH_SPLIT = 0 DO IP=1,NPARTS NB_SPLIT = (SIZES(IP) + TARGET_SIZE_SPLIT-1) & / TARGET_SIZE_SPLIT SZ_FINAL = (SIZES(IP) + NB_SPLIT-1) / NB_SPLIT MAXSIZE_PARTS_LOC_NEW = max(MAXSIZE_PARTS_LOC_NEW, & SZ_FINAL) DO I=PARTPTR(IP), PARTPTR(IP+1)-1, SZ_FINAL NB_PARTS_WITH_SPLIT = NB_PARTS_WITH_SPLIT +1 DO II=I, min(I+SZ_FINAL-1,PARTPTR(IP+1)-1) LRGROUPS(SEP(II)) = LRGROUPS_SIGN*(NB_PARTS_WITH_SPLIT & + NBG_CAPT) ENDDO ENDDO ENDDO NPARTS = NB_PARTS_WITH_SPLIT MAXSIZE_PARTS_LOC = MAXSIZE_PARTS_LOC_NEW ENDIF #endif DEALLOCATE(NEWSEP,SIZES,RIGHTPART,PARTPTR) END SUBROUTINE GET_GLOBAL_GROUPS SUBROUTINE GETHALONODES(N, IW, LW, IPE, IND, NIND, PMAX, & NHALO, TRACE, WORKH, NODE, LEN, CNT, & GEN2HALO) INTEGER,DIMENSION(:),INTENT(IN) :: IND INTEGER(8), INTENT(IN) :: LW INTEGER, INTENT(IN) :: N, NODE INTEGER, INTENT(IN) :: IW(LW), LEN(N) INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: PMAX,NIND INTEGER, INTENT(OUT) :: NHALO INTEGER, INTENT(INOUT) :: TRACE(N), WORKH(N) INTEGER :: GEN2HALO(N) INTEGER(8), INTENT(OUT) :: CNT INTEGER :: DEPTH, I, LAST_LVL_START INTEGER :: HALOI INTEGER(8) :: J WORKH(1:NIND) = IND LAST_LVL_START = 1 NHALO = NIND CNT = 0 DO I=1,NIND HALOI = WORKH(I) GEN2HALO(HALOI) = I IF (TRACE(HALOI) .NE. NODE) THEN TRACE(HALOI) = NODE END IF DO J=IPE(HALOI),IPE(HALOI+1)-1 IF (TRACE(IW(J)).EQ.NODE) THEN CNT = CNT + 2 END IF END DO END DO DO DEPTH=1,PMAX CALL NEIGHBORHOOD(WORKH, NHALO, N, IW, LW, IPE, & TRACE, NODE, LEN, CNT, LAST_LVL_START, & DEPTH, PMAX, GEN2HALO) END DO END SUBROUTINE GETHALONODES SUBROUTINE NEIGHBORHOOD(HALO, NHALO, N, IW, LW, IPE, & TRACE, NODE, LEN, CNT, LAST_LVL_START, & DEPTH, PMAX, GEN2HALO) INTEGER, INTENT(IN) :: N, NODE, DEPTH, PMAX INTEGER,INTENT(INOUT) :: NHALO, GEN2HALO(N) INTEGER, INTENT(INOUT) :: LAST_LVL_START INTEGER(8), INTENT(INOUT) :: CNT INTEGER,DIMENSION(:),INTENT(INOUT) :: HALO INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, TARGET, INTENT(IN) :: IW(LW) INTEGER, INTENT(IN) :: LEN(N) INTEGER,DIMENSION(:) :: TRACE INTEGER :: AvgDens, THRESH INTEGER :: I,INEI,NADJI,NEWNHALO, NEIGH INTEGER, DIMENSION(:), POINTER :: ADJI INTEGER(8) :: J NEWNHALO = 0 AvgDens = nint(real(IPE(N+1)-1_8)/real(N)) THRESH = AvgDens*10 DO I=LAST_LVL_START,NHALO NADJI = LEN(HALO(I)) IF (NADJI.GT.THRESH) CYCLE ADJI => IW(IPE(HALO(I)):IPE(HALO(I)+1)-1) DO INEI=1,NADJI IF (TRACE(ADJI(INEI)) .NE. NODE) THEN NEIGH = ADJI(INEI) IF (LEN(NEIGH).GT.THRESH) CYCLE TRACE(NEIGH) = NODE NEWNHALO = NEWNHALO + 1 HALO(NHALO+NEWNHALO) = NEIGH GEN2HALO(NEIGH) = NHALO + NEWNHALO DO J=IPE(NEIGH),IPE(NEIGH+1)-1 IF (TRACE(IW(J)).EQ.NODE) THEN CNT = CNT + 2 END IF END DO END IF END DO END DO LAST_LVL_START = NHALO + 1 NHALO = NHALO + NEWNHALO END SUBROUTINE NEIGHBORHOOD SUBROUTINE GETHALOGRAPH(HALO,NHALO,N,IW,LW,IPE,IPTRHALO,JCNHALO, & HALOEDGENBR,TRACE,NODE, GEN2HALO) INTEGER, INTENT(IN) :: N INTEGER,INTENT(IN):: NHALO, NODE INTEGER,INTENT(IN):: GEN2HALO(N) INTEGER,DIMENSION(NHALO),INTENT(IN) :: HALO INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: IW(LW), TRACE(N) INTEGER(8),INTENT(IN) :: HALOEDGENBR INTEGER(8), INTENT(OUT) :: IPTRHALO(NHALO+1) INTEGER, INTENT(OUT) :: JCNHALO(max(HALOEDGENBR,1)) INTEGER::I,IPTR_CNT,JCN_CNT,HALOI INTEGER(8) :: J, CNT CNT = 0 IPTR_CNT = 2 JCN_CNT = 1 IPTRHALO(1) = 1 DO I=1,NHALO HALOI = HALO(I) DO J=IPE(HALOI),IPE(HALOI+1)-1 IF (TRACE(IW(J))==NODE) THEN CNT = CNT + 1 JCNHALO(JCN_CNT) = GEN2HALO(IW(J)) JCN_CNT = JCN_CNT + 1 END IF END DO IPTRHALO(IPTR_CNT) = CNT + 1 IPTR_CNT = IPTR_CNT + 1 END DO END SUBROUTINE GETHALOGRAPH SUBROUTINE GET_GROUPS(NHALO,PARTS,SEP,NSEP,NPARTS, & CUT,NEWSEP,PERM,IPERM) INTEGER,INTENT(IN) :: NHALO,NSEP INTEGER,DIMENSION(:),INTENT(IN) :: SEP INTEGER,POINTER,DIMENSION(:)::PARTS INTEGER,POINTER,DIMENSION(:)::CUT,NEWSEP,PERM, & IPERM INTEGER,INTENT(INOUT) :: NPARTS INTEGER::I,CNT,NB_PARTS_WITHOUT_SEP_NODE,allocok INTEGER,DIMENSION(:),ALLOCATABLE::SIZES INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR ALLOCATE(NEWSEP(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(PERM(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(IPERM(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(SIZES(NPARTS),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(PARTPTR(NPARTS+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF NB_PARTS_WITHOUT_SEP_NODE = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = & SIZES(PARTS(I))+1 END DO PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) IF (SIZES(I-1)==0) THEN NB_PARTS_WITHOUT_SEP_NODE = NB_PARTS_WITHOUT_SEP_NODE + 1 END IF END DO ALLOCATE(CUT(NPARTS-NB_PARTS_WITHOUT_SEP_NODE+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF CUT(1) = 1 CNT = 2 DO I=2,NPARTS+1 IF (SIZES(I-1).NE.0) THEN CUT(CNT) = PARTPTR(I) CNT = CNT + 1 END IF END DO NPARTS = NPARTS - NB_PARTS_WITHOUT_SEP_NODE CUT(NPARTS+1) = NSEP+1 DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) PERM(PARTPTR(PARTS(I))) = I IPERM(I) = PARTPTR(PARTS(I)) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO DEALLOCATE(SIZES,PARTPTR) END SUBROUTINE GET_GROUPS SUBROUTINE CMUMPS_LR_GROUPING(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, NE_STEPS, STEP, NA, LNA, & LRGROUPS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, SEP_SIZE, & K38, K20, K60, & IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K10, & K54, K142, LPOK, LP, GATHER_MATRIX_ALLOCATED, & KEEP, ND_STEPS) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, K60, K54 INTEGER, INTENT(IN) :: LP INTEGER, INTENT(OUT) :: K142 LOGICAL, INTENT(IN) :: LPOK INTEGER, POINTER, DIMENSION(:) :: IRN, JCN INTEGER, INTENT(IN) :: NE_STEPS(:), ICNTL(60) INTEGER :: FRERE_STEPS(:), NA(:), DAD_STEPS(:) INTEGER :: FILS(N), STEP(N), LRGROUPS(N) INTEGER, INTENT(IN) :: K472, MAXFRONT LOGICAL, INTENT(INOUT) :: GATHER_MATRIX_ALLOCATED INTEGER, INTENT(IN) :: KEEP(500), ND_STEPS(:) INTEGER :: K482_LOC, K38ou20 INTEGER :: I, F, PV, NV, NLEAVES, NROOTS, PP, C, NF, NODE, & SYMTRY, NBQD, AD INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: LPTR, RPTR, NBGROUPS LOGICAL :: FIRST INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, GEN2HALO INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR LOGICAL :: INPLACE64_GRAPH_COPY K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF NBGROUPS = 0 IF (K265.EQ.-1) THEN LW = NZ8 ELSE LW = 2_8 * NZ8 ENDIF ALLOCATE(IW(LW), IPE(N+1), LEN(N), IQ(N), & POOL(NA(1)), PVS(NSTEPS), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * LW+int(N,8)+int(K10*(2*N+1),8) IFLAG = -7 CALL MUMPS_SET_IERROR(LW+int(N,8)+int(K10*(2*N+1),8),IERROR) GOTO 500 ENDIF CALL CMUMPS_ANA_GNEW(N, NZ8, IRN(1), JCN(1), IW(1), LW, IPE(1), & LEN(1), IQ(1), LRGROUPS(1), IWFR, NRORM, NIORM, & IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265,.FALSE., & INPLACE64_GRAPH_COPY) IF (K54.EQ.3) THEN deallocate(IRN) deallocate(JCN) NULLIFY(IRN) NULLIFY(JCN) GATHER_MATRIX_ALLOCATED = .FALSE. ENDIF IF (allocated(IQ)) DEALLOCATE(IQ) LRGROUPS = -1 NLEAVES = NA(1) NROOTS = NA(2) LPTR = 2+NLEAVES RPTR = 2+NLEAVES+NROOTS DO I = 1, NROOTS POOL(I) = NA(2+NLEAVES+I) END DO PP = NROOTS ALLOCATE(WORK(MAXFRONT), TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * 3*N+MAXFRONT IFLAG = -7 IERROR = 3*N+MAXFRONT RETURN ENDIF TRACE = 0 K142 = 0 DO WHILE(PP .GT. 0) PV = ABS(POOL(PP)) NODE = STEP(PV) FIRST = POOL(PP) .LT. 0 NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV, & ND_STEPS(NODE), KEEP(35)) IF (NV .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + ( (NV-1)/GROUP_SIZE2 + 1 ) K142 = max(K142, min(NV,GROUP_SIZE2)) ELSE CALL SEP_GROUPING( ND_STEPS(NODE), KEEP, & NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE(1), WORKH(1), NODE, & GEN2HALO(1), K482_LOC, K472, 0, SEP_SIZE, K142, & K10, LP, LPOK, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 500 END IF ELSE IF (NV .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = (NBGROUPS + 1) ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -(NBGROUPS + 1) ENDDO ENDIF NBGROUPS = NBGROUPS + 1 K142 = max (K142,NV) ENDIF CALL MUMPS_UPD_TREE(NV, NSTEPS, N, FIRST, LPTR, RPTR, F, & WORK(1), & FILS, FRERE_STEPS, STEP, DAD_STEPS, & NE_STEPS, NA, LNA, PVS(1), K38ou20, & STEP_SCALAPACK_ROOT) IF (STEP_SCALAPACK_ROOT.GT.0) THEN IF (K38.GT.0) THEN K38 = K38ou20 ELSE K20 = K38ou20 ENDIF ENDIF PP = PP-1 NF = NE_STEPS(NODE) IF(NF .GT. 0) THEN PP = PP+1 POOL(PP) = F C = STEP(-F) F = FRERE_STEPS(C) DO WHILE(F .GT. 0) PP = PP+1 POOL(PP) = F C = STEP(F) F = FRERE_STEPS(C) END DO END IF END DO 500 IF (allocated(POOL)) DEALLOCATE(POOL) IF (allocated(PVS)) DEALLOCATE(PVS) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(LEN)) DEALLOCATE(LEN) IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) RETURN END SUBROUTINE CMUMPS_LR_GROUPING SUBROUTINE CMUMPS_LR_GROUPING_NEW(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, K142, LPOK, LP, GATHER_MATRIX_ALLOCATED, & KEEP, ND_STEPS) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, POINTER, DIMENSION(:) :: IRN, JCN INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FRERE_STEPS(:), NA(:), DAD_STEPS(:) INTEGER :: FILS(N), STEP(N), LRGROUPS(N) INTEGER, INTENT(IN) :: K472, K469 LOGICAL, INTENT(INOUT) :: GATHER_MATRIX_ALLOCATED INTEGER, INTENT(OUT) :: K142 INTEGER, INTENT(IN) :: KEEP(500), ND_STEPS(:) INTEGER :: K482_LOC, K469_LOC, K38ou20 INTEGER :: I, F, PV, NV, NODE, & SYMTRY, NBQD, AD LOGICAL :: PVSCHANGED INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: NBGROUPS, NBGROUPS_local, NBG_CAPT INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: INPLACE64_GRAPH_COPY #if defined(ptscotch) || defined(scotch) INTEGER :: VSCOTCH LOGICAL :: SCOTCH_IS_THREAD_SAFE INTEGER :: PTHREAD_NUMBER, NOMP #endif K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF K469_LOC = K469 #if defined(ptscotch) || defined(scotch) SCOTCH_IS_THREAD_SAFE = .FALSE. IF (K482_LOC.EQ.2) THEN CALL MUMPS_SCOTCH_VERSION (VSCOTCH) IF (VSCOTCH.GE.7) SCOTCH_IS_THREAD_SAFE=.TRUE. ENDIF IF (K482_LOC.EQ.2.AND.(.NOT.SCOTCH_IS_THREAD_SAFE) ) THEN K469_LOC = 1 ENDIF #endif NBGROUPS = 0 LW = 2_8 * NZ8 ALLOCATE(IW(LW), IPE(N+1), LEN(N), IQ(N), & PVS(NSTEPS), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * LW+int(N,8)+int(K10*(2*N+1),8) IFLAG = -7 CALL MUMPS_SET_IERROR(LW+int(N,8)+int(K10*(2*N+1),8),IERROR) GOTO 501 ENDIF CALL CMUMPS_ANA_GNEW(N, NZ8, IRN(1), JCN(1), IW(1), LW, IPE(1), & LEN(1), IQ(1), LRGROUPS(1), IWFR, NRORM, NIORM, & IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265,.FALSE., & INPLACE64_GRAPH_COPY) IF (K54.EQ.3) THEN deallocate(IRN) deallocate(JCN) NULLIFY(IRN) NULLIFY(JCN) GATHER_MATRIX_ALLOCATED = .FALSE. ENDIF IF (allocated(IQ)) DEALLOCATE(IQ) LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 501 ENDIF ENDIF #if defined(ptscotch) || defined(scotch) IF (K482_LOC.EQ.2) THEN NOMP=0 !$ NOMP=omp_get_max_threads() IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (PTHREAD_NUMBER) NOMP =1 CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (NOMP) ENDIF ENDIF #endif K142 = 0 PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = omp_get_max_threads() OMP_NUM = min(OMP_NUM,5) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local !$OMP& ) !$OMP& REDUCTION( max : K142) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(MAXFRONT), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", MAXFRONT !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = MAXFRONT !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 3*N !$OMP END ATOMIC ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 500 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE PV = PVS(NODE) NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV, & ND_STEPS(NODE), KEEP(35)) IF (NV .GE. GROUP_SIZE2 & .AND. NV.GE.int(dble(SEP_SIZE)*dble(1.5)) & ) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + ( (NV-1)/GROUP_SIZE2 + 1 ) !$OMP END ATOMIC DO I=1,NV LRGROUPS(WORK(I))=NBG_CAPT+1+(I-1)/GROUP_SIZE2 END DO K142 = max(K142, min(NV,GROUP_SIZE2)) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING( ND_STEPS(NODE), KEEP, & NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K142, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING( ND_STEPS(NODE), KEEP, & NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K142, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NV .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF K142 = max (K142,NV) ENDIF ENDDO !$OMP END DO IF (IFLAG.LT.0) GOTO 500 IF (.NOT.PVSCHANGED) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL #if defined(ptscotch) || defined(scotch) IF (K482_LOC.EQ.2.AND.NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (PTHREAD_NUMBER) ENDIF #endif 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(LEN)) DEALLOCATE(LEN) RETURN END SUBROUTINE CMUMPS_LR_GROUPING_NEW SUBROUTINE CMUMPS_AB_LR_MPI_GROUPING( & N, MAPCOL, SIZEMAPCOL, & NSTEPS, LUMAT, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SIZEOFBLOCKS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, & SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, K142, LPOK, LP, & COMM, MYID, NPROCS_ARG, & KEEP, ND_STEPS & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, INTENT(IN) :: MYID, COMM, NPROCS_ARG TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER, INTENT(IN) :: SIZEMAPCOL INTEGER, INTENT(IN) :: MAPCOL(SIZEMAPCOL) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(OUT) :: K142 INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FRERE_STEPS(:), NA(:), DAD_STEPS(:) INTEGER :: FILS(N), STEP(N), LRGROUPS(N) INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: K472, K469 INTEGER, INTENT(IN) :: KEEP(500), ND_STEPS(:) INTEGER :: NPROCS INTEGER :: K482_LOC, K469_LOC, K38ou20, K142_GLOB INTEGER :: I, F, PV, NV, NVEXPANDED, NODE REAL :: COMPRESS_RATIO LOGICAL :: PVSCHANGED INTEGER :: PVSCHANGED_INT, PVSCHANGED_INT_GLOB, IPROC INTEGER :: NBGROUPS, NBGROUPS_local, NBG_CAPT INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER :: NBGROUPS_sent INTEGER :: NBNODES_LOC, SIZE_SENT, ISHIFT, & MSGSOU, ILOOP INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, GROUP_SIZE2_TMP, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: MAPCOL_PROVIDED #if defined(ptscotch) || defined(scotch) INTEGER :: VSCOTCH LOGICAL :: SCOTCH_IS_THREAD_SAFE INTEGER :: PTHREAD_NUMBER, NOMP #endif MAPCOL_PROVIDED = (MAPCOL(1).GE.0) NPROCS = NPROCS_ARG IF (.NOT.MAPCOL_PROVIDED) NPROCS=1 K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF (MAPCOL_PROVIDED) THEN CALL MPI_BCAST( FILS(1), N, MPI_INTEGER, & MASTER, COMM, IERR ) ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF K469_LOC = K469 #if defined(ptscotch) || defined(scotch) SCOTCH_IS_THREAD_SAFE = .FALSE. IF (K482_LOC.EQ.2) THEN CALL MUMPS_SCOTCH_VERSION (VSCOTCH) IF (VSCOTCH.GE.7) SCOTCH_IS_THREAD_SAFE=.TRUE. ENDIF IF (K482_LOC.EQ.2.AND.(.NOT.SCOTCH_IS_THREAD_SAFE) ) THEN K469_LOC = 1 ENDIF #endif NBGROUPS = 0 K142 = 0 ALLOCATE( PVS(NSTEPS), STAT=IERR) IF (IERR.GT.0) THEN IFLAG = -7 IERROR = NSTEPS IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", IERROR GOTO 491 ENDIF LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 491 ENDIF ENDIF 491 CONTINUE IF (NPROCS.GT.1) THEN CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) ENDIF IF (IFLAG.LT.0) GOTO 501 #if defined(ptscotch) || defined(scotch) NOMP=0 IF (K482_LOC.EQ.2) THEN !$ NOMP=omp_get_max_threads() IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (PTHREAD_NUMBER) NOMP =1 CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (NOMP) ENDIF ENDIF #endif K142 = 0 PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = omp_get_max_threads() OMP_NUM = min(OMP_NUM,5) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local, !$OMP& NVEXPANDED, COMPRESS_RATIO, IPROC, GROUP_SIZE2_TMP !$OMP& ) !$OMP& REDUCTION( max : K142) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(2*MAXFRONT+1), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 2*MAXFRONT+1 !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 2*MAXFRONT+1 !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 3*N !$OMP END ATOMIC ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 498 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE IF (MAPCOL_PROVIDED) THEN IPROC = MAPCOL(NODE) IF (IPROC.NE.MYID) THEN PVS(NODE) = -999 CYCLE ENDIF ENDIF PV = PVS(NODE) NV = 0 NVEXPANDED = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 NVEXPANDED = NVEXPANDED+SIZEOFBLOCKS(F) WORK(NV) = F F = FILS(F) END DO COMPRESS_RATIO = real(NVEXPANDED)/real(NV) CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED, & ND_STEPS(NODE), KEEP(35)) IF (NVEXPANDED .GE. GROUP_SIZE2 & .AND. NVEXPANDED.GE.int(dble(SEP_SIZE)*dble(1.5)) & ) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN GROUP_SIZE2_TMP = GROUP_SIZE2 GROUP_SIZE2_TMP = max( int(real(GROUP_SIZE2_TMP) & /COMPRESS_RATIO), 1) !$OMP ATOMIC CAPTURE NBG_CAPT = NBGROUPS NBGROUPS = NBGROUPS + ( (NV-1)/GROUP_SIZE2_TMP + 1 ) !$OMP END ATOMIC DO I=1,NV LRGROUPS(WORK(I))=NBG_CAPT+1+(I-1)/GROUP_SIZE2_TMP END DO K142 = max(K142, min(NV,GROUP_SIZE2_TMP)) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING_AB( ND_STEPS(NODE), KEEP, & NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K142, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING_AB( ND_STEPS(NODE), KEEP, & NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K142, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NVEXPANDED .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF K142 = max (K142,NV) ENDIF ENDDO !$OMP END DO 498 CONTINUE IF (NPROCS.GT.1) THEN !$OMP MASTER CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) !$OMP END MASTER !$OMP BARRIER ENDIF IF (IFLAG.LT.0) GOTO 500 IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP MASTER IF (K469_LOC.NE.2) THEN IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF !$OMP END MASTER IF (.NOT.MAPCOL_PROVIDED) THEN !$OMP MASTER IF (PVSCHANGED) THEN PVSCHANGED_INT_GLOB = 1 ELSE PVSCHANGED_INT_GLOB = 0 ENDIF !$OMP END MASTER ELSE !$OMP MASTER IF (PVSCHANGED) THEN PVSCHANGED_INT = 1 ELSE PVSCHANGED_INT = 0 ENDIF CALL MPI_ALLREDUCE( PVSCHANGED_INT, PVSCHANGED_INT_GLOB, 1, & MPI_INTEGER, & MPI_MAX, COMM, IERR_MPI ) PVSCHANGED_INT_GLOB = 1 IF (PVSCHANGED_INT_GLOB.NE.0) THEN IF (NPROCS.GT.1) THEN ALLOCATE(WORKH(2*N+3*NSTEPS+1), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of ", & "size: ", 2*MAXFRONT+1 IFLAG = -7 IERROR = 2*N+3*NSTEPS+1 ENDIF CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) IF (IFLAG.LT.0) GOTO 499 IF (MYID.EQ.MASTER) THEN IPROC = 0 DO WHILE (IPROC.NE.NPROCS-1) IPROC = IPROC + 1 CALL MPI_RECV( NBNODES_LOC, 1, MPI_INTEGER, & MPI_ANY_SOURCE, & GROUPING, COMM, STATUS, IERR ) MSGSOU = STATUS( MPI_SOURCE ) IF (NBNODES_LOC.EQ.0) THEN CYCLE ENDIF CALL MPI_RECV( NBGROUPS_sent, 1, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) CALL MPI_RECV( SIZE_SENT, 1, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) CALL MPI_RECV( WORKH, SIZE_SENT, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) ISHIFT = 0 DO ILOOP=1, NBNODES_LOC ISHIFT = ISHIFT+1 NODE = WORKH (ISHIFT) ISHIFT = ISHIFT+1 NV = WORKH(ISHIFT) PVS(NODE) = WORKH(ISHIFT+1) STEP(WORKH(ISHIFT+1)) = NODE IF (STEP(WORKH(ISHIFT+1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORKH(ISHIFT+1) ELSE K20 = WORKH(ISHIFT+1) END IF END IF DO I=2, NV STEP(WORKH(I+ISHIFT)) = -NODE END DO DO I=1, NV FILS(WORKH(I+ISHIFT)) = WORKH(I+1+ISHIFT) IF (WORKH(NV+1+I+ISHIFT).LT.0) THEN LRGROUPS(WORKH(I+ISHIFT)) = & - NBGROUPS + WORKH(NV+1+I+ISHIFT) ELSE LRGROUPS(WORKH(I+ISHIFT)) = & NBGROUPS + WORKH(NV+1+I+ISHIFT) END IF END DO ISHIFT = ISHIFT + 2*NV +1 END DO NBGROUPS = NBGROUPS + NBGROUPS_sent ENDDO ELSE NBNODES_LOC = 0 SIZE_SENT = 0 ISHIFT = 0 DO NODE = 1,NSTEPS IPROC = MAPCOL(NODE) IF (IPROC.EQ.MYID) THEN NBNODES_LOC = NBNODES_LOC + 1 ISHIFT = ISHIFT +1 WORKH(ISHIFT) = NODE ISHIFT = ISHIFT +1 NV = 0 F = PVS(NODE) DO WHILE (F.GT.0) NV = NV + 1 WORKH(NV+ISHIFT) = F F = FILS(F) ENDDO WORKH(ISHIFT) = NV WORKH(NV+1+ISHIFT) = F DO I=1, NV WORKH(NV+1+I+ISHIFT) = LRGROUPS(WORKH(I+ISHIFT)) ENDDO ISHIFT = ISHIFT + 2*NV+1 ENDIF ENDDO SIZE_SENT = ISHIFT CALL MPI_SEND( NBNODES_LOC, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) IF (NBNODES_LOC.GT.0) THEN CALL MPI_SEND( NBGROUPS, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) CALL MPI_SEND( SIZE_SENT, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) CALL MPI_SEND( WORKH, SIZE_SENT, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) ENDIF ENDIF ENDIF ENDIF 499 CONTINUE !$OMP END MASTER ENDIF !$OMP BARRIER IF (IFLAG.LT.0) GOTO 500 IF (MYID.EQ.MASTER) THEN IF (PVSCHANGED_INT_GLOB.EQ.0) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO ENDIF 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL IF (NPROCS.GT.1) THEN K142_GLOB = 0 CALL MPI_REDUCE( K142, K142_GLOB, 1, & MPI_INTEGER, & MPI_MAX, MASTER, COMM, IERR_MPI ) K142 = K142_GLOB ENDIF #if defined(ptscotch) || defined(scotch) IF (K482_LOC.EQ.2.AND.NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (PTHREAD_NUMBER) ENDIF #endif 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) RETURN END SUBROUTINE CMUMPS_AB_LR_MPI_GROUPING END MODULE CMUMPS_ANA_LR MUMPS_5.8.1/src/mumps_l0_omp_m.F0000664000175000017500000000135215042446423016264 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_L0_OMP_M LOGICAL, DIMENSION(:), POINTER :: NB_CORE_PER_THREAD_CHANGED INTEGER, DIMENSION(:), POINTER :: NB_CORE_PER_THREAD INTEGER :: THREAD_ID LOGICAL :: IS_ROOT_OF_L0_OMP !$OMP THREADPRIVATE ( THREAD_ID , IS_ROOT_OF_L0_OMP ) END MODULE MUMPS_L0_OMP_M MUMPS_5.8.1/src/dlr_type.F0000664000175000017500000000467415042446437015202 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_LR_TYPE IMPLICIT NONE TYPE LRB_TYPE DOUBLE PRECISION,POINTER,DIMENSION(:,:) :: Q => null() DOUBLE PRECISION,POINTER,DIMENSION(:,:) :: R => null() INTEGER :: K,M,N LOGICAL :: ISLR END TYPE LRB_TYPE CONTAINS SUBROUTINE DEALLOC_LRB(LRB_OUT, KEEP8, K34 & ) TYPE(LRB_TYPE), INTENT(INOUT) :: LRB_OUT INTEGER(8) :: KEEP8(150) INTEGER :: K34 INTEGER :: MEM, IDUMMY, JDUMMY IF (LRB_OUT%M.EQ.0) RETURN IF (LRB_OUT%N.EQ.0) RETURN MEM = 0 IF (LRB_OUT%ISLR) THEN IF (associated(LRB_OUT%Q)) THEN MEM = MEM + size(LRB_OUT%Q) DEALLOCATE (LRB_OUT%Q) NULLIFY(LRB_OUT%Q) ENDIF IF (associated(LRB_OUT%R)) THEN MEM = MEM + size(LRB_OUT%R) DEALLOCATE (LRB_OUT%R) NULLIFY(LRB_OUT%R) ENDIF ELSE IF (associated(LRB_OUT%Q)) THEN MEM = MEM + size(LRB_OUT%Q) DEALLOCATE (LRB_OUT%Q) NULLIFY(LRB_OUT%Q) ENDIF ENDIF CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-int(MEM,8), & .TRUE., KEEP8, & IDUMMY, JDUMMY, & .TRUE., .TRUE.) END SUBROUTINE DEALLOC_LRB SUBROUTINE DEALLOC_BLR_PANEL(BLR_PANEL, IEND, KEEP8, K34, IBEG_IN) INTEGER, INTENT(IN) :: IEND TYPE(LRB_TYPE), INTENT(INOUT) :: BLR_PANEL(:) INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: K34 INTEGER, INTENT(IN), OPTIONAL :: IBEG_IN INTEGER :: I, IBEG IF (present(IBEG_IN)) THEN IBEG = IBEG_IN ELSE IBEG = 1 ENDIF IF (IEND.GE.IBEG) THEN IF (BLR_PANEL(1)%M.NE.0) THEN DO I=IBEG, IEND CALL DEALLOC_LRB(BLR_PANEL(I), KEEP8, K34) ENDDO ENDIF ENDIF END SUBROUTINE DEALLOC_BLR_PANEL END MODULE DMUMPS_LR_TYPE MUMPS_5.8.1/src/smumps_intr_types.F0000664000175000017500000001065215042446441017150 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_INTR_TYPES USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC PRIVATE PUBLIC :: SMUMPS_ROOT_STRUC, & SMUMPS_L0OMPFAC_T, & SMUMPS_INTR_STRUC, & SMUMPS_INIT_INTR_ENCODING, & SMUMPS_FREE_INTR_ENCODING, & SMUMPS_ENCODE_INTR, & SMUMPS_DECODE_INTR C SMUMPS_ROOT_STRUC no longer contains INTEGERS TYPE SMUMPS_ROOT_STRUC ! 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 ! Fwd in facto: ! case of scalapack root: to store RHS in 2D block cyclic ! format compatible with root distribution REAL, DIMENSION(:,:), POINTER :: RHS_ROOT ! for SVD on root (#define try_null_space) REAL, DIMENSION(:,:), POINTER :: SVD_U, SVD_VT ! for RR on root (#define try_null_space) REAL, DIMENSION(:), POINTER :: SINGULAR_VALUES ! END TYPE SMUMPS_ROOT_STRUC ! multicore TYPE SMUMPS_L0OMPFAC_T REAL, POINTER, DIMENSION(:) :: A INTEGER(8) :: LA END TYPE SMUMPS_L0OMPFAC_T C C All MUMPS internal datatypes are in an internal structure: TYPE SMUMPS_INTR_STRUC TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota TYPE (SMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & L0_OMP_FACTORS END TYPE SMUMPS_INTR_STRUC C ================================================================= CONTAINS C ================================================================= SUBROUTINE SMUMPS_INIT_INTR_ENCODING(id_intr_ENCODING) IMPLICIT NONE CHARACTER, DIMENSION(:), POINTER :: id_intr_ENCODING C To be called only before JOB=-1 NULLIFY(id_intr_ENCODING) END SUBROUTINE SMUMPS_INIT_INTR_ENCODING C ================================================================= SUBROUTINE SMUMPS_FREE_INTR_ENCODING(id_intr_ENCODING) IMPLICIT NONE CHARACTER, DIMENSION(:), POINTER :: id_intr_ENCODING C To be called only after JOB=-2 DEALLOCATE(id_intr_ENCODING) NULLIFY(id_intr_ENCODING) RETURN END SUBROUTINE SMUMPS_FREE_INTR_ENCODING C ================================================================= SUBROUTINE SMUMPS_ENCODE_INTR(id_intr_ENCODING, id_intr) IMPLICIT NONE C C Arguments: C ========= CHARACTER, DIMENSION(:), POINTER :: id_intr_ENCODING TYPE (SMUMPS_INTR_STRUC) :: id_intr C C Local variables: C =============== CHARACTER :: CHAR_ARRAY(1) INTEGER :: CHAR_LENGTH, IERR C IF (associated(id_intr_ENCODING)) THEN C Should be unassociated on entry WRITE(*,*) "Internal error in SMUMPS_ENCODE_INTR:", & " id_intr_ENCODING already allocated" CALL MUMPS_ABORT() ENDIF CHAR_LENGTH=size(transfer(id_intr,CHAR_ARRAY)) ALLOCATE(id_intr_ENCODING(CHAR_LENGTH), stat=IERR) IF (IERR > 0 ) THEN WRITE(*,*) "Allocation error in MUMPS_ENCODE_INTR" CALL MUMPS_ABORT() ENDIF C Fill with derived datatype id_intr_ENCODING=transfer(id_intr,CHAR_ARRAY) RETURN END SUBROUTINE SMUMPS_ENCODE_INTR C ================================================================= SUBROUTINE SMUMPS_DECODE_INTR(id_intr_ENCODING, id_intr) IMPLICIT NONE CHARACTER(len=1), DIMENSION(:), POINTER :: id_intr_ENCODING TYPE (SMUMPS_INTR_STRUC) :: id_intr IF (.NOT.associated(id_intr_ENCODING)) THEN WRITE(*,*) "Internal error 1 in SMUMPS_DECODE_INTR" CALL MUMPS_ABORT() ENDIf id_intr=transfer(id_intr_ENCODING,id_intr) DEALLOCATE(id_intr_ENCODING) NULLIFY(id_intr_ENCODING) RETURN END SUBROUTINE SMUMPS_DECODE_INTR END MODULE SMUMPS_INTR_TYPES MUMPS_5.8.1/src/cmumps_ooc.F0000664000175000017500000036273615042446440015524 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_OOC USE MUMPS_OOC_COMMON !$ USE OMP_LIB, ONLY : OMP_LOCK_KIND, OMP_SET_LOCK, OMP_UNSET_LOCK, !$ & OMP_INIT_LOCK, OMP_DESTROY_LOCK, OMP_TEST_LOCK IMPLICIT NONE !$ INTEGER(KIND=OMP_LOCK_KIND) :: LOCK_FOR_L0OMP INTEGER NOT_IN_MEM,BEING_READ,NOT_USED,PERMUTED,USED, & USED_NOT_PERMUTED,ALREADY_USED PARAMETER (NOT_IN_MEM=0,BEING_READ=-1,NOT_USED=-2, & PERMUTED=-3,USED=-4,USED_NOT_PERMUTED=-5,ALREADY_USED=-6) INTEGER OOC_NODE_NOT_IN_MEM,OOC_NODE_PERMUTED, & OOC_NODE_NOT_PERMUTED PARAMETER (OOC_NODE_NOT_IN_MEM=-20, & OOC_NODE_PERMUTED=-21,OOC_NODE_NOT_PERMUTED=-22) INTEGER(8), DIMENSION(:,:),POINTER :: SIZE_OF_BLOCK INTEGER, DIMENSION(:),POINTER :: TOTAL_NB_OOC_NODES INTEGER :: OOC_SOLVE_TYPE_FCT INTEGER, DIMENSION(:),ALLOCATABLE :: IO_REQ INTEGER(8), DIMENSION(:), ALLOCATABLE:: LRLUS_SOLVE INTEGER(8), DIMENSION(:), ALLOCATABLE:: SIZE_SOLVE_Z, & LRLU_SOLVE_T, POSFAC_SOLVE, IDEB_SOLVE_Z, LRLU_SOLVE_B INTEGER, DIMENSION(:),ALLOCATABLE :: PDEB_SOLVE_Z INTEGER (8),SAVE :: FACT_AREA_SIZE, & SIZE_ZONE_SOLVE,SIZE_SOLVE_EMM,TMP_SIZE_FACT, & MAX_SIZE_FACTOR_OOC INTEGER(8), SAVE :: MIN_SIZE_READ INTEGER, SAVE :: TMP_NB_NODES, MAX_NB_NODES_FOR_ZONE,MAX_NB_REQ, & CURRENT_SOLVE_READ_ZONE, & CUR_POS_SEQUENCE,NB_Z,SOLVE_STEP, & NB_ZONE_REQ,MTYPE_OOC,NB_ACT & ,NB_CALLED,REQ_ACT,NB_CALL INTEGER(8), SAVE :: OOC_VADDR_PTR INTEGER(8), SAVE :: SIZE_ZONE_REQ INTEGER(8), DIMENSION(:), ALLOCATABLE :: SIZE_OF_READ, READ_DEST INTEGER,DIMENSION(:),ALLOCATABLE :: FIRST_POS_IN_READ, & READ_MNG,REQ_TO_ZONE,POS_HOLE_T, & POS_HOLE_B,REQ_ID,OOC_STATE_NODE INTEGER CMUMPS_ELEMENTARY_DATA_SIZE,N_OOC INTEGER, DIMENSION(:), ALLOCATABLE :: POS_IN_MEM, INODE_TO_POS INTEGER, DIMENSION(:), ALLOCATABLE :: CURRENT_POS_T,CURRENT_POS_B LOGICAL IS_ROOT_SPECIAL INTEGER SPECIAL_ROOT_NODE PUBLIC :: CMUMPS_OOC_INIT_FACTO,CMUMPS_NEW_FACTOR, & CMUMPS_READ_OOC, & CMUMPS_SOLVE_ALLOC_FACTOR_SPACE, & CMUMPS_IS_THERE_FREE_SPACE, & CMUMPS_OOC_END_SOLVE, & CMUMPS_SOLVE_INIT_OOC_FWD,CMUMPS_SOLVE_INIT_OOC_BWD, & CMUMPS_INITIATE_READ_OPS,CMUMPS_OOC_INIT_SOLVE INTEGER, PARAMETER, PUBLIC :: TYPEF_BOTH_LU = -99976 PUBLIC CMUMPS_OOC_IO_LU_PANEL, & CMUMPS_OOC_PANEL_SIZE PRIVATE CMUMPS_OOC_STORE_LorU, & CMUMPS_OOC_WRT_IN_PANELS_LorU CONTAINS SUBROUTINE CMUMPS_SET_STRAT_IO_FLAGS( STRAT_IO_ARG, & STRAT_IO_ASYNC_ARG, WITH_BUF_ARG, LOW_LEVEL_STRAT_IO_ARG ) IMPLICIT NONE INTEGER, intent(out) :: LOW_LEVEL_STRAT_IO_ARG LOGICAL, intent(out) :: STRAT_IO_ASYNC_ARG, WITH_BUF_ARG INTEGER, intent(in) :: STRAT_IO_ARG INTEGER TMP CALL MUMPS_OOC_IS_ASYNC_AVAIL(TMP) STRAT_IO_ASYNC_ARG=.FALSE. WITH_BUF_ARG=.FALSE. IF(TMP.EQ.1)THEN IF((STRAT_IO_ARG.EQ.1).OR.(STRAT_IO_ARG.EQ.2))THEN STRAT_IO_ASYNC=.TRUE. WITH_BUF=.FALSE. ELSEIF((STRAT_IO_ARG.EQ.4).OR.(STRAT_IO_ARG.EQ.5))THEN STRAT_IO_ASYNC_ARG=.TRUE. WITH_BUF_ARG=.TRUE. ELSEIF(STRAT_IO_ARG.EQ.3)THEN STRAT_IO_ASYNC_ARG=.FALSE. WITH_BUF_ARG=.TRUE. ENDIF LOW_LEVEL_STRAT_IO_ARG=mod(STRAT_IO_ARG,3) ELSE LOW_LEVEL_STRAT_IO_ARG=0 IF(STRAT_IO_ARG.GE.3)THEN WITH_BUF_ARG=.TRUE. ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SET_STRAT_IO_FLAGS FUNCTION CMUMPS_IS_THERE_FREE_SPACE(INODE,ZONE) IMPLICIT NONE INTEGER INODE,ZONE LOGICAL CMUMPS_IS_THERE_FREE_SPACE CMUMPS_IS_THERE_FREE_SPACE=(LRLUS_SOLVE(ZONE).GE. & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) RETURN END FUNCTION CMUMPS_IS_THERE_FREE_SPACE SUBROUTINE CMUMPS_INIT_FACT_AREA_SIZE_S(LA) IMPLICIT NONE INTEGER(8) :: LA FACT_AREA_SIZE=LA END SUBROUTINE CMUMPS_INIT_FACT_AREA_SIZE_S SUBROUTINE CMUMPS_OOC_INIT_FACTO(idICNTL1, idICNTL4, & idN, idNSLAVES, & idMYID, MAXS, idOOC_NB_FILE_TYPE, & idKEEP, idKEEP8, idSTEP, idPROCNODE_STEPS, & idOOC_SIZE_OF_BLOCK, & idOOC_VADDR, idINFO, idOOC_TMPDIR, idOOC_PREFIX, & idOOC_NB_FILES, idOOC_INODE_SEQUENCE) & USE CMUMPS_STRUC_DEF USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER :: idICNTL1, idICNTL4, idN, idNSLAVES, idMYID INTEGER :: idOOC_NB_FILE_TYPE INTEGER, TARGET :: idKEEP(500) INTEGER :: idINFO(2) INTEGER(8), TARGET :: idKEEP8(150) INTEGER, POINTER, DIMENSION(:) :: idSTEP, idPROCNODE_STEPS INTEGER(8),DIMENSION(:,:), POINTER :: idOOC_SIZE_OF_BLOCK INTEGER(8), DIMENSION(:,:), POINTER :: idOOC_VADDR INTEGER(8), INTENT(IN) :: MAXS INTEGER OOC_TMPDIR_MAX_LENGTH, OOC_PREFIX_MAX_LENGTH PARAMETER (OOC_TMPDIR_MAX_LENGTH=1023, OOC_PREFIX_MAX_LENGTH=255) CHARACTER(LEN=OOC_TMPDIR_MAX_LENGTH) :: idOOC_TMPDIR CHARACTER(LEN=OOC_PREFIX_MAX_LENGTH) :: idOOC_PREFIX INTEGER, DIMENSION(:), POINTER :: idOOC_NB_FILES INTEGER, DIMENSION(:,:), POINTER :: idOOC_INODE_SEQUENCE INTEGER IERR INTEGER allocok INTEGER DIM_TMPDIR,DIM_PREFIX INTEGER, DIMENSION(:), ALLOCATABLE :: FILE_FLAG_TAB INTEGER TMP INTEGER KEEP211_LOC ICNTL1 = idICNTL1 IF (idICNTL4 .LT. 1) idICNTL1=0 MAX_SIZE_FACTOR_OOC=0_8 N_OOC=idN SOLVE=.FALSE. IERR=0 IF (idKEEP(400).GT.0) THEN !$ CALL OMP_INIT_LOCK( LOCK_FOR_L0OMP ) 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(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_VADDR))THEN NULLIFY(OOC_VADDR) ENDIF IF(allocated(I_CUR_HBUF_NEXTPOS))THEN DEALLOCATE(I_CUR_HBUF_NEXTPOS) ENDIF OOC_NB_FILE_TYPE=idOOC_NB_FILE_TYPE IF(IERR.LT.0)THEN IF (ICNTL1 > 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) idINFO(1) = IERR idINFO(2) = 0 RETURN ENDIF CALL MUMPS_OOC_INIT_FILETYPE(TYPEF_L, TYPEF_U, TYPEF_CB, & idKEEP(201), idKEEP(251), idKEEP(50), TYPEF_INVALID ) IF (idKEEP(201).EQ.2) THEN OOC_FCT_TYPE=1 ENDIF STEP_OOC=>idSTEP PROCNODE_OOC=>idPROCNODE_STEPS MYID_OOC=idMYID SLAVEF_OOC=idNSLAVES KEEP_OOC => idKEEP SIZE_OF_BLOCK=>idOOC_SIZE_OF_BLOCK OOC_VADDR=>idOOC_VADDR IF(idKEEP(107).GT.0)THEN SIZE_SOLVE_EMM=max(idKEEP8(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(idKEEP(107)),8)) IF(SIZE_ZONE_SOLVE.EQ.SIZE_SOLVE_EMM)THEN SIZE_SOLVE_EMM=idKEEP8(19) SIZE_ZONE_SOLVE=int((dble(MAXS)*0.9d0- & dble(SIZE_SOLVE_EMM))/dble(idKEEP(107)),8) ENDIF ELSE SIZE_ZONE_SOLVE=int(dble(MAXS)*0.9d0,8) SIZE_SOLVE_EMM=SIZE_ZONE_SOLVE ENDIF CMUMPS_ELEMENTARY_DATA_SIZE = idKEEP(35) SIZE_OF_BLOCK=0_8 ALLOCATE(idOOC_NB_FILES(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF idINFO(1) = -13 idINFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF idOOC_NB_FILES=0 OOC_VADDR_PTR=0_8 CALL CMUMPS_SET_STRAT_IO_FLAGS( idKEEP(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=>idOOC_INODE_SEQUENCE ALLOCATE(I_CUR_HBUF_NEXTPOS(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF idINFO(1) = -13 idINFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF I_CUR_HBUF_NEXTPOS = 1 IF(WITH_BUF)THEN CALL CMUMPS_INIT_OOC_BUF(idINFO(1),idINFO(2),IERR) IF(IERR.LT.0)THEN RETURN ENDIF 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_TMPDIR=len(trim(idOOC_TMPDIR)) DIM_PREFIX=len(trim(idOOC_PREFIX)) CALL MUMPS_LOW_LEVEL_INIT_PREFIX(DIM_PREFIX, idOOC_PREFIX) CALL MUMPS_LOW_LEVEL_INIT_TMPDIR(DIM_TMPDIR, idOOC_TMPDIR) ALLOCATE(FILE_FLAG_TAB(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1 .GT. 0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF idINFO(1) = -13 idINFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF FILE_FLAG_TAB(1:OOC_NB_FILE_TYPE)=0 IERR=0 TMP=int(idKEEP8(11)/1000000_8)+1 IF((idKEEP(201).EQ.1).AND.(idKEEP(50).EQ.0) & ) THEN TMP=max(1,TMP/2) ENDIF CALL MUMPS_LOW_LEVEL_INIT_OOC_C(MYID_OOC,TMP, & idKEEP(35),LOW_LEVEL_STRAT_IO,KEEP211_LOC,OOC_NB_FILE_TYPE, & FILE_FLAG_TAB,idKEEP(255),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 idINFO(1) = IERR idINFO(2) = 0 RETURN ENDIF DEALLOCATE(FILE_FLAG_TAB) RETURN END SUBROUTINE CMUMPS_OOC_INIT_FACTO SUBROUTINE CMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZE,IERR) USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) :: LA INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)), SIZE COMPLEX A(LA) INTEGER IERR,REQUEST INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=FCT IERR=0 SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)=SIZE MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,SIZE) OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)=OOC_VADDR_PTR OOC_VADDR_PTR=OOC_VADDR_PTR+SIZE TMP_SIZE_FACT=TMP_SIZE_FACT+SIZE TMP_NB_NODES=TMP_NB_NODES+1 IF(TMP_SIZE_FACT.GT.SIZE_ZONE_SOLVE)THEN MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE,TMP_NB_NODES) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 ENDIF IF (.NOT. WITH_BUF) THEN CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & A(PTRFAC(STEP_OOC(INODE))),SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE).GT.KEEP_OOC(28))THEN WRITE(*,*)MYID_OOC,': Internal error (37) in OOC ' CALL MUMPS_ABORT() ENDIF OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE)=INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)= & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)+1 ELSE IF(SIZE.LE.HBUF_SIZE)THEN CALL CMUMPS_OOC_COPY_DATA_TO_BUFFER & (A(PTRFAC(STEP_OOC(INODE))),SIZE,IERR) OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE) = INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE) = & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE) + 1 PTRFAC(STEP_OOC(INODE))=-777777_8 RETURN ELSE CALL CMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL CMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & A(PTRFAC(STEP_OOC(INODE))),SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(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 (38) in OOC ' CALL MUMPS_ABORT() ENDIF OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE)=INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)= & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)+1 CALL CMUMPS_OOC_NEXT_HBUF(OOC_FCT_TYPE) ENDIF END IF PTRFAC(STEP_OOC(INODE))=-777777_8 IF(STRAT_IO_ASYNC)THEN IERR=0 CALL MUMPS_WAIT_REQUEST(REQUEST,IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_NEW_FACTOR SUBROUTINE CMUMPS_READ_OOC(DEST,INODE,IERR & ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR,INODE COMPLEX DEST INTEGER 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 IERR=0 OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_LOW_LEVEL_DIRECT_READ(DEST, & SIZE_INT1,SIZE_INT2, & TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) WRITE(ICNTL1,*)MYID_OOC, & ': Problem in MUMPS_LOW_LEVEL_DIRECT_READ' ENDIF RETURN ENDIF 555 CONTINUE IF(.NOT.CMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE).EQ. & INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL CMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_READ_OOC SUBROUTINE CMUMPS_OOC_CLEAN_PENDING(IERR) USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out):: IERR IERR=0 IF (WITH_BUF) THEN CALL CMUMPS_OOC_BUF_CLEAN_PENDING(IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF RETURN END SUBROUTINE CMUMPS_OOC_CLEAN_PENDING SUBROUTINE CMUMPS_OOC_END_FACTO(idKEEP,idKEEP8, & idOOC_MAX_NB_NODES_FOR_ZONE, & idOOC_TOTAL_NB_NODES, & idOOC_FILE_NAMES,idINFO, & idOOC_FILE_NAME_LENGTH, & idOOC_NB_FILES, & IERR) USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER :: idKEEP(500), idINFO(2) INTEGER(8) :: idKEEP8(150) INTEGER :: idOOC_MAX_NB_NODES_FOR_ZONE INTEGER,DIMENSION(:), POINTER :: idOOC_TOTAL_NB_NODES CHARACTER,DIMENSION(:,:), POINTER :: idOOC_FILE_NAMES INTEGER,DIMENSION(:), POINTER :: idOOC_FILE_NAME_LENGTH INTEGER,DIMENSION(:), POINTER :: idOOC_NB_FILES INTEGER, intent(out) :: IERR INTEGER I,SOLVE_OR_FACTO IERR=0 IF (idKEEP(400).GT.0) THEN !$ CALL OMP_DESTROY_LOCK( LOCK_FOR_L0OMP ) ENDIF IF(WITH_BUF)THEN CALL CMUMPS_END_OOC_BUF() ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_VADDR))THEN NULLIFY(OOC_VADDR) ENDIF CALL MUMPS_OOC_END_WRITE_C(IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) GOTO 500 ENDIF idOOC_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 idOOC_TOTAL_NB_NODES(I)=I_CUR_HBUF_NEXTPOS(I)-1 ENDDO DEALLOCATE(I_CUR_HBUF_NEXTPOS) ENDIF idKEEP8(20)=MAX_SIZE_FACTOR_OOC CALL CMUMPS_STRUC_STORE_FILE_NAME( idOOC_NB_FILES, & idOOC_FILE_NAMES, idOOC_FILE_NAME_LENGTH, & idINFO, IERR) IF(IERR.LT.0)THEN GOTO 500 ENDIF 500 CONTINUE SOLVE_OR_FACTO=0 CALL MUMPS_CLEAN_IO_DATA_C(MYID_OOC,SOLVE_OR_FACTO,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF RETURN END SUBROUTINE CMUMPS_OOC_END_FACTO SUBROUTINE CMUMPS_OOC_INIT_SOLVE(idICNTL1, idICNTL4, idN, & idNSLAVES, idMYID, idOOC_NB_FILE_TYPE, idKEEP, idKEEP8, & idINFO, idSTEP, idPROCNODE_STEPS, idOOC_SIZE_OF_BLOCK, & idOOC_INODE_SEQUENCE, & idOOC_VADDR, idOOC_MAX_NB_NODES_FOR_ZONE, idOOC_TOTAL_NB_NODES, & idOOC_NB_FILES, idOOC_FILE_NAME_LENGTH, idOOC_FILE_NAMES, & idCOMM_NODES, idrootyes) IMPLICIT NONE INTEGER :: idICNTL1, idICNTL4, idN, idNSLAVES, idMYID INTEGER :: idOOC_NB_FILE_TYPE INTEGER, TARGET :: idKEEP(500) INTEGER(8) :: idKEEP8(150) INTEGER :: idINFO(2) INTEGER,POINTER,DIMENSION(:) :: idSTEP, idPROCNODE_STEPS INTEGER(8),DIMENSION(:,:), POINTER :: idOOC_SIZE_OF_BLOCK INTEGER, DIMENSION(:,:), POINTER :: idOOC_INODE_SEQUENCE INTEGER(8), DIMENSION(:,:),POINTER :: idOOC_VADDR INTEGER :: idOOC_MAX_NB_NODES_FOR_ZONE INTEGER, DIMENSION(:), POINTER :: idOOC_TOTAL_NB_NODES INTEGER :: idCOMM_NODES LOGICAL :: idrootyes INTEGER,DIMENSION(:), POINTER :: idOOC_NB_FILES INTEGER,DIMENSION(:), POINTER :: idOOC_FILE_NAME_LENGTH CHARACTER,DIMENSION(:,:), POINTER :: idOOC_FILE_NAMES INCLUDE 'mpif.h' INTEGER TMP,I,J INTEGER(8) :: TMP_SIZE8 INTEGER allocok,IERR EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER MASTER_ROOT IERR=0 ICNTL1=idICNTL1 IF (idICNTL4 > 1) ICNTL1 = 0 SOLVE=.TRUE. N_OOC=idN IF(allocated(LRLUS_SOLVE))THEN DEALLOCATE(LRLUS_SOLVE) ENDIF IF(allocated(LRLU_SOLVE_T))THEN DEALLOCATE(LRLU_SOLVE_T) ENDIF IF(allocated(LRLU_SOLVE_B))THEN DEALLOCATE(LRLU_SOLVE_B) ENDIF IF(allocated(POSFAC_SOLVE))THEN DEALLOCATE(POSFAC_SOLVE) ENDIF IF(allocated(IDEB_SOLVE_Z))THEN DEALLOCATE(IDEB_SOLVE_Z) ENDIF IF(allocated(PDEB_SOLVE_Z))THEN DEALLOCATE(PDEB_SOLVE_Z) ENDIF IF(allocated(SIZE_SOLVE_Z))THEN DEALLOCATE(SIZE_SOLVE_Z) ENDIF IF(allocated(CURRENT_POS_T))THEN DEALLOCATE(CURRENT_POS_T) ENDIF IF(allocated(CURRENT_POS_B))THEN DEALLOCATE(CURRENT_POS_B) ENDIF IF(allocated(POS_HOLE_T))THEN DEALLOCATE(POS_HOLE_T) ENDIF IF(allocated(POS_HOLE_B))THEN DEALLOCATE(POS_HOLE_B) ENDIF IF(allocated(OOC_STATE_NODE))THEN DEALLOCATE(OOC_STATE_NODE) ENDIF IF(allocated(POS_IN_MEM))THEN DEALLOCATE(POS_IN_MEM) ENDIF IF(allocated(INODE_TO_POS))THEN DEALLOCATE(INODE_TO_POS) ENDIF IF(allocated(SIZE_OF_READ))THEN DEALLOCATE(SIZE_OF_READ) ENDIF IF(allocated(FIRST_POS_IN_READ))THEN DEALLOCATE(FIRST_POS_IN_READ) ENDIF IF(allocated(READ_DEST))THEN DEALLOCATE(READ_DEST) ENDIF IF(allocated(READ_MNG))THEN DEALLOCATE(READ_MNG) ENDIF IF(allocated(REQ_TO_ZONE))THEN DEALLOCATE(REQ_TO_ZONE) ENDIF IF(allocated(REQ_ID))THEN DEALLOCATE(REQ_ID) ENDIF IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF OOC_NB_FILE_TYPE=idOOC_NB_FILE_TYPE CALL MUMPS_OOC_INIT_FILETYPE(TYPEF_L, TYPEF_U, TYPEF_CB, & idKEEP(201), idKEEP(251), idKEEP(50), TYPEF_INVALID ) DIM_ERR_STR_OOC = ERR_STR_OOC_MAX_LEN CALL MUMPS_LOW_LEVEL_INIT_ERR_STR(DIM_ERR_STR_OOC,ERR_STR_OOC) CALL CMUMPS_OOC_OPEN_FILES_FOR_SOLVE(idINFO, idOOC_NB_FILES, & idMYID, idKEEP, idOOC_FILE_NAME_LENGTH, idOOC_FILE_NAMES ) IF(idINFO(1).LT.0)THEN RETURN ENDIF STEP_OOC=>idSTEP PROCNODE_OOC=>idPROCNODE_STEPS SLAVEF_OOC=idNSLAVES MYID_OOC=idMYID KEEP_OOC => idKEEP SIZE_OF_BLOCK=>idOOC_SIZE_OF_BLOCK OOC_INODE_SEQUENCE=>idOOC_INODE_SEQUENCE OOC_VADDR=>idOOC_VADDR ALLOCATE(IO_REQ(idKEEP(28)), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = idKEEP(28) RETURN ENDIF CMUMPS_ELEMENTARY_DATA_SIZE = idKEEP(35) MAX_NB_NODES_FOR_ZONE=idOOC_MAX_NB_NODES_FOR_ZONE TOTAL_NB_OOC_NODES=>idOOC_TOTAL_NB_NODES CALL CMUMPS_SET_STRAT_IO_FLAGS( idKEEP(204), STRAT_IO_ASYNC, & WITH_BUF, LOW_LEVEL_STRAT_IO) IF(idKEEP(107).GT.0)THEN SIZE_SOLVE_EMM=max(idKEEP8(20), & FACT_AREA_SIZE / 5_8) SIZE_ZONE_SOLVE=max(SIZE_SOLVE_EMM, & int((dble(FACT_AREA_SIZE)- & dble(SIZE_SOLVE_EMM))/dble(idKEEP(107)),8)) SIZE_ZONE_SOLVE=max(SIZE_ZONE_SOLVE,0_8) IF(SIZE_ZONE_SOLVE.EQ.SIZE_SOLVE_EMM)THEN SIZE_SOLVE_EMM=idKEEP8(20) SIZE_ZONE_SOLVE=int((real(FACT_AREA_SIZE)- & real(SIZE_SOLVE_EMM))/real(idKEEP(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.idKEEP8(20))THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': More space needed for & solution step in CMUMPS_OOC_INIT_SOLVE' idINFO(1) = -11 CALL MUMPS_SET_IERROR(idKEEP8(20), idINFO(2)) ENDIF TMP=MAX_NB_NODES_FOR_ZONE CALL MPI_ALLREDUCE(TMP,MAX_NB_NODES_FOR_ZONE,1, & MPI_INTEGER,MPI_MAX,idCOMM_NODES, IERR) NB_Z=KEEP_OOC(107)+1 ALLOCATE(POS_IN_MEM(MAX_NB_NODES_FOR_ZONE*NB_Z), & INODE_TO_POS(KEEP_OOC(28)), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = idKEEP(28)+(MAX_NB_NODES_FOR_ZONE*NB_Z) RETURN ENDIF ALLOCATE(OOC_STATE_NODE(KEEP_OOC(28)),stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = idKEEP(28) RETURN ENDIF OOC_STATE_NODE(1:KEEP_OOC(28))=0 INODE_TO_POS=0 POS_IN_MEM=0 ALLOCATE(LRLUS_SOLVE(NB_Z), LRLU_SOLVE_T(NB_Z),LRLU_SOLVE_B(NB_Z), & POSFAC_SOLVE(NB_Z),IDEB_SOLVE_Z(NB_Z), & PDEB_SOLVE_Z(NB_Z),SIZE_SOLVE_Z(NB_Z), & CURRENT_POS_T(NB_Z),CURRENT_POS_B(NB_Z), & POS_HOLE_T(NB_Z),POS_HOLE_B(NB_Z), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = 9*(NB_Z+1) RETURN ENDIF IERR=0 CALL MUMPS_GET_MAX_NB_REQ_C(MAX_NB_REQ,IERR) ALLOCATE(SIZE_OF_READ(MAX_NB_REQ),FIRST_POS_IN_READ(MAX_NB_REQ), & READ_DEST(MAX_NB_REQ),READ_MNG(MAX_NB_REQ), & REQ_TO_ZONE(MAX_NB_REQ),REQ_ID(MAX_NB_REQ),stat=allocok) SIZE_OF_READ=-9999_8 FIRST_POS_IN_READ=-9999 READ_DEST=-9999_8 READ_MNG=-9999 REQ_TO_ZONE=-9999 REQ_ID=-9999 IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_OOC_INIT_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = 6*(NB_Z+1) RETURN ENDIF MIN_SIZE_READ=min(max((1024_8*1024_8)/int(idKEEP(35),8), & SIZE_ZONE_SOLVE/3_8), & SIZE_ZONE_SOLVE) TMP_SIZE8=1_8 J=1 DO I=1,NB_Z-1 IDEB_SOLVE_Z(I)=TMP_SIZE8 POSFAC_SOLVE(I)=TMP_SIZE8 LRLUS_SOLVE(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_T(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_B(I)=0_8 SIZE_SOLVE_Z(I)=SIZE_ZONE_SOLVE CURRENT_POS_T(I)=J CURRENT_POS_B(I)=J PDEB_SOLVE_Z(I)=J POS_HOLE_T(I)=J POS_HOLE_B(I)=J J=J+MAX_NB_NODES_FOR_ZONE TMP_SIZE8=TMP_SIZE8+SIZE_ZONE_SOLVE ENDDO IDEB_SOLVE_Z(NB_Z)=TMP_SIZE8 PDEB_SOLVE_Z(NB_Z)=J POSFAC_SOLVE(NB_Z)=TMP_SIZE8 LRLUS_SOLVE(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_T(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_B(NB_Z)=0_8 SIZE_SOLVE_Z(NB_Z)=SIZE_SOLVE_EMM CURRENT_POS_T(NB_Z)=J CURRENT_POS_B(NB_Z)=J POS_HOLE_T(NB_Z)=J POS_HOLE_B(NB_Z)=J IO_REQ=-77777 REQ_ACT=0 OOC_STATE_NODE(1:KEEP_OOC(28))=NOT_IN_MEM IF(KEEP_OOC(38).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(38))), & KEEP_OOC(199) ) SPECIAL_ROOT_NODE=KEEP_OOC(38) ELSEIF(KEEP_OOC(20).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(20))), & KEEP_OOC(199) ) SPECIAL_ROOT_NODE=KEEP_OOC(20) ELSE MASTER_ROOT=-111111 SPECIAL_ROOT_NODE=-2222222 ENDIF IF ( KEEP_OOC(60).EQ.0 .AND. & ( & (KEEP_OOC(38).NE.0 .AND. idrootyes) & .OR. & (KEEP_OOC(20).NE.0 .AND. MYID_OOC.EQ.MASTER_ROOT)) & ) & THEN IS_ROOT_SPECIAL = .TRUE. ELSE IS_ROOT_SPECIAL = .FALSE. ENDIF NB_ZONE_REQ=0 SIZE_ZONE_REQ=0_8 CURRENT_SOLVE_READ_ZONE=0 NB_CALLED=0 NB_CALL=0 SOLVE_STEP=-9999 RETURN END SUBROUTINE CMUMPS_OOC_INIT_SOLVE SUBROUTINE CMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA COMPLEX A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER I IERR=0 IF(NB_Z.GT.1)THEN IF(STRAT_IO_ASYNC)THEN DO I=1,NB_Z-1 CALL CMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO ELSE CALL CMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_INITIATE_READ_OPS SUBROUTINE CMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA COMPLEX A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER ZONE CALL CMUMPS_SOLVE_SELECT_ZONE(ZONE) IERR=0 CALL CMUMPS_SOLVE_ZONE_READ(ZONE,A,LA,PTRFAC,NSTEPS,IERR) RETURN END SUBROUTINE CMUMPS_SUBMIT_READ_FOR_Z SUBROUTINE CMUMPS_READ_SOLVE_BLOCK(DEST,INDICE,SIZE, & ZONE,PTRFAC,NSTEPS,POS_SEQ,NB_NODES,FLAG,IERR) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER ZONE,NSTEPS,FLAG,POS_SEQ,NB_NODES COMPLEX DEST INTEGER (8) :: INDICE, SIZE, PTRFAC(NSTEPS) INTEGER REQUEST,INODE,IERR INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=OOC_SOLVE_TYPE_FCT IERR=0 INODE=OOC_INODE_SEQUENCE(POS_SEQ,OOC_FCT_TYPE) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_READ_OOC_C(LOW_LEVEL_STRAT_IO, & DEST,SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(STRAT_IO_ASYNC)THEN CALL CMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL CMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL CMUMPS_SOLVE_UPDATE_POINTERS(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF END SUBROUTINE CMUMPS_READ_SOLVE_BLOCK SUBROUTINE CMUMPS_SOLVE_UPDATE_POINTERS(REQUEST,PTRFAC, & NSTEPS) IMPLICIT NONE INTEGER NSTEPS,REQUEST INTEGER (8) :: PTRFAC(NSTEPS) INTEGER (8) :: LAST, POS_IN_S, J INTEGER ZONE INTEGER POS_REQ,I,TMP_NODE,POS_IN_MANAGE INTEGER (8) SIZE LOGICAL DONT_USE EXTERNAL MUMPS_TYPENODE,MUMPS_PROCNODE INTEGER MUMPS_TYPENODE,MUMPS_PROCNODE POS_REQ=mod(REQUEST,MAX_NB_REQ)+1 SIZE=SIZE_OF_READ(POS_REQ) I=FIRST_POS_IN_READ(POS_REQ) POS_IN_S=READ_DEST(POS_REQ) POS_IN_MANAGE=READ_MNG(POS_REQ) ZONE=REQ_TO_ZONE(POS_REQ) DONT_USE=.FALSE. J=0_8 DO WHILE((J.LT.SIZE).AND.(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))) TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) LAST=SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN I=I+1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(TMP_NODE)).NE.0).AND. & (INODE_TO_POS(STEP_OOC(TMP_NODE)).LT. & -((N_OOC+1)*NB_Z)))THEN DONT_USE= & (((MTYPE_OOC.EQ.1).AND.(KEEP_OOC(50).EQ.0).AND. & (SOLVE_STEP.EQ.1).AND. & ((MUMPS_TYPENODE(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & KEEP_OOC(199)).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),KEEP_OOC(199)).NE. & MYID_OOC))) & .OR. & ((MTYPE_OOC.NE.1).AND.(KEEP_OOC(50).EQ.0).AND. & (SOLVE_STEP.EQ.0).AND. & ((MUMPS_TYPENODE(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & KEEP_OOC(199)).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),KEEP_OOC(199)).NE. & MYID_OOC)))).OR. & (OOC_STATE_NODE(STEP_OOC(TMP_NODE)).EQ.ALREADY_USED) IF(DONT_USE)THEN PTRFAC(STEP_OOC(TMP_NODE))=-POS_IN_S ELSE PTRFAC(STEP_OOC(TMP_NODE))=POS_IN_S ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).LT. & IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Inernal error (42) in OOC ', & PTRFAC(STEP_OOC(TMP_NODE)),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).GT. & (IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)-1_8))THEN WRITE(*,*)MYID_OOC,': Inernal error (43) in OOC ' CALL MUMPS_ABORT() ENDIF IF(DONT_USE)THEN POS_IN_MEM(POS_IN_MANAGE)=-TMP_NODE INODE_TO_POS(STEP_OOC(TMP_NODE))=-POS_IN_MANAGE IF(OOC_STATE_NODE(STEP_OOC(TMP_NODE)).NE. & ALREADY_USED)THEN OOC_STATE_NODE(STEP_OOC(TMP_NODE))=USED_NOT_PERMUTED ENDIF LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+LAST ELSE POS_IN_MEM(POS_IN_MANAGE)=TMP_NODE INODE_TO_POS(STEP_OOC(TMP_NODE))=POS_IN_MANAGE OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED ENDIF IO_REQ(STEP_OOC(TMP_NODE))=-7777 ELSE POS_IN_MEM(POS_IN_MANAGE)=0 ENDIF POS_IN_S=POS_IN_S+LAST POS_IN_MANAGE=POS_IN_MANAGE+1 J=J+LAST I=I+1 ENDDO SIZE_OF_READ(POS_REQ)=-9999_8 FIRST_POS_IN_READ(POS_REQ)=-9999 READ_DEST(POS_REQ)=-9999_8 READ_MNG(POS_REQ)=-9999 REQ_TO_ZONE(POS_REQ)=-9999 REQ_ID(POS_REQ)=-9999 RETURN END SUBROUTINE CMUMPS_SOLVE_UPDATE_POINTERS SUBROUTINE CMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,DEST,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER INODE,ZONE,REQUEST,FLAG,POS_SEQ,NB_NODES,NSTEPS INTEGER(8) :: SIZE INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: DEST, LOCAL_DEST, J8 INTEGER I,TMP_NODE,LOC_I,POS_REQ,NB INTEGER(8)::LAST INTEGER, intent(out) :: IERR IERR=0 IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN RETURN ENDIF NB=0 LOCAL_DEST=DEST I=POS_SEQ POS_REQ=mod(REQUEST,MAX_NB_REQ)+1 IF(REQ_ID(POS_REQ).NE.-9999)THEN CALL MUMPS_WAIT_REQUEST(REQ_ID(POS_REQ),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF CALL CMUMPS_SOLVE_UPDATE_POINTERS(REQUEST,PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF SIZE_OF_READ(POS_REQ)=SIZE FIRST_POS_IN_READ(POS_REQ)=I READ_DEST(POS_REQ)=DEST IF(FLAG.EQ.0)THEN READ_MNG(POS_REQ)=CURRENT_POS_B(ZONE)-NB_NODES+1 ELSEIF(FLAG.EQ.1)THEN READ_MNG(POS_REQ)=CURRENT_POS_T(ZONE) ENDIF REQ_TO_ZONE(POS_REQ)=ZONE REQ_ID(POS_REQ)=REQUEST J8=0_8 IF(FLAG.EQ.0)THEN LOC_I=CURRENT_POS_B(ZONE)-NB_NODES+1 ENDIF DO WHILE((J8.LT.SIZE).AND.(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))) TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) LAST=SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I+1 CYCLE ENDIF IF((IO_REQ(STEP_OOC(TMP_NODE)).GE.0).OR. & (INODE_TO_POS(STEP_OOC(TMP_NODE)).NE.0))THEN IF(FLAG.EQ.1)THEN POS_IN_MEM(CURRENT_POS_T(ZONE))=0 ELSEIF(FLAG.EQ.0)THEN POS_IN_MEM(CURRENT_POS_B(ZONE))=0 ENDIF ELSE IO_REQ(STEP_OOC(TMP_NODE))=REQUEST LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)-LAST IF(FLAG.EQ.1)THEN IF(POSFAC_SOLVE(ZONE).EQ.IDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)+LAST LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)-LAST POS_IN_MEM(CURRENT_POS_T(ZONE))=-TMP_NODE- & ((N_OOC+1)*NB_Z) INODE_TO_POS(STEP_OOC(TMP_NODE))=-CURRENT_POS_T(ZONE)- & ((N_OOC+1)*NB_Z) OOC_STATE_NODE(STEP_OOC(TMP_NODE))=BEING_READ PTRFAC(STEP_OOC(TMP_NODE))=-LOCAL_DEST LOCAL_DEST=LOCAL_DEST+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(FLAG.EQ.0)THEN LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)-LAST POS_IN_MEM(LOC_I)=-TMP_NODE-((N_OOC+1)*NB_Z) IF(LOC_I.EQ.POS_HOLE_T(ZONE))THEN IF(POS_HOLE_T(ZONE).LT.CURRENT_POS_T(ZONE))THEN POS_HOLE_T(ZONE)=POS_HOLE_T(ZONE)+1 ENDIF ENDIF INODE_TO_POS(STEP_OOC(TMP_NODE))=-LOC_I-((N_OOC+1)*NB_Z) OOC_STATE_NODE(STEP_OOC(TMP_NODE))=BEING_READ PTRFAC(STEP_OOC(TMP_NODE))=-LOCAL_DEST LOCAL_DEST=LOCAL_DEST+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSE WRITE(*,*)MYID_OOC,': Internal error (39) in OOC ', & ' Invalid Flag Value in ', & ' CMUMPS_UPDATE_READ_REQ_NODE',FLAG CALL MUMPS_ABORT() ENDIF ENDIF IF(POS_IN_MEM(CURRENT_POS_T(ZONE)).NE.0)THEN IF(POS_IN_MEM(CURRENT_POS_T(ZONE)).EQ. & POS_IN_MEM(PDEB_SOLVE_Z(ZONE)))THEN IF(CURRENT_POS_T(ZONE).NE.PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (40) in OOC ', & CURRENT_POS_T(ZONE), & PDEB_SOLVE_Z(ZONE), & POS_IN_MEM(CURRENT_POS_T(ZONE)), & POS_IN_MEM(PDEB_SOLVE_Z(ZONE)) CALL MUMPS_ABORT() ENDIF ENDIF ENDIF J8=J8+LAST IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (41) in OOC ', & ' LRLUS_SOLVE must be (1) > 0', & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF I=I+1 IF(FLAG.EQ.1)THEN CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)+1 IF(CURRENT_POS_T(ZONE).GT. & MAX_NB_NODES_FOR_ZONE+PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (1) in OOC ' CALL MUMPS_ABORT() ENDIF POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) ELSEIF(FLAG.EQ.0)THEN IF(POS_HOLE_B(ZONE).LT.PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (2) in OOC ', & POS_HOLE_B(ZONE),LOC_I CALL MUMPS_ABORT() ENDIF CURRENT_POS_B(ZONE)=CURRENT_POS_B(ZONE)-1 POS_HOLE_B(ZONE)=CURRENT_POS_B(ZONE) IF(POS_HOLE_B(ZONE).LT.PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF ELSE WRITE(*,*)MYID_OOC,': Internal error (3) in OOC ', & ' Invalid Flag Value in ', & ' CMUMPS_UPDATE_READ_REQ_NODE',FLAG CALL MUMPS_ABORT() ENDIF IF(FLAG.EQ.0)THEN LOC_I=LOC_I+1 ENDIF NB=NB+1 ENDDO IF(NB.NE.NB_NODES)THEN WRITE(*,*)MYID_OOC,': Internal error (4) in OOC ', & ' CMUMPS_UPDATE_READ_REQ_NODE ',NB,NB_NODES ENDIF IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=I ELSE CUR_POS_SEQUENCE=POS_SEQ-1 ENDIF RETURN END SUBROUTINE CMUMPS_UPDATE_READ_REQ_NODE SUBROUTINE CMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,NSTEPS,A, & LA,FLAG,IERR) IMPLICIT NONE INTEGER(8) :: LA INTEGER, intent(out):: IERR COMPLEX A(LA) INTEGER INODE,NSTEPS INTEGER(8) :: PTRFAC(NSTEPS) LOGICAL FLAG INTEGER(8) FREE_SIZE INTEGER TMP,TMP_NODE,I,ZONE,J INTEGER WHICH INTEGER(8) :: DUMMY_SIZE DUMMY_SIZE=1_8 IERR = 0 WHICH=-1 IF(INODE_TO_POS(STEP_OOC(INODE)).LE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (5) in OOC ', & ' Problem in CMUMPS_FREE_FACTORS_FOR_SOLVE', & INODE, STEP_OOC(INODE), INODE_TO_POS(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE).EQ.0_8)THEN INODE_TO_POS(STEP_OOC(INODE))=0 OOC_STATE_NODE(STEP_OOC(INODE))=ALREADY_USED RETURN ENDIF CALL CMUMPS_SOLVE_FIND_ZONE(INODE,ZONE,PTRFAC,NSTEPS) TMP=INODE_TO_POS(STEP_OOC(INODE)) INODE_TO_POS(STEP_OOC(INODE))=-TMP POS_IN_MEM(TMP)=-INODE PTRFAC(STEP_OOC(INODE))=-PTRFAC(STEP_OOC(INODE)) IF (KEEP_OOC(237).eq.0) THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).NE.PERMUTED)THEN WRITE(*,*)MYID_OOC,': INTERNAL ERROR (53) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF ENDIF OOC_STATE_NODE(STEP_OOC(INODE))=USED LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (6) in OOC ', & ': LRLUS_SOLVE must be (2) > 0' CALL MUMPS_ABORT() ENDIF IF(ZONE.EQ.NB_Z)THEN IF(INODE.NE.SPECIAL_ROOT_NODE)THEN CALL CMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & DUMMY_SIZE,PTRFAC,KEEP_OOC(28),ZONE,IERR) ENDIF ELSE IF(SOLVE_STEP.EQ.0)THEN IF(TMP.GT.POS_HOLE_B(ZONE))THEN WHICH=0 ELSEIF(TMP.LT.POS_HOLE_T(ZONE))THEN WHICH=1 ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(TMP.LT.POS_HOLE_T(ZONE))THEN WHICH=1 ELSEIF(TMP.GT.POS_HOLE_B(ZONE))THEN WHICH=0 ENDIF ENDIF IF(WHICH.EQ.1)THEN J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_T(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE=0_8 DO I=J,TMP,-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN GOTO 666 ENDIF ENDDO POS_HOLE_T(ZONE)=TMP 666 CONTINUE ELSEIF(WHICH.EQ.0)THEN J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_B(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE=0_8 DO I=J,TMP IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN IF(J.EQ.PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 CURRENT_POS_B(ZONE)=-9999 ENDIF GOTO 777 ENDIF ENDDO POS_HOLE_B(ZONE)=TMP 777 CONTINUE ENDIF IERR=0 ENDIF IF((NB_Z.GT.1).AND.FLAG)THEN CALL CMUMPS_SOLVE_TRY_ZONE_FOR_READ(ZONE) IF((LRLUS_SOLVE(ZONE).GE.MIN_SIZE_READ).OR. & (LRLUS_SOLVE(ZONE).GE. & int(0.3E0*real(SIZE_SOLVE_Z(ZONE)),8)))THEN CALL CMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL CMUMPS_SOLVE_SELECT_ZONE(ZONE) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_FREE_FACTORS_FOR_SOLVE FUNCTION CMUMPS_SOLVE_IS_INODE_IN_MEM(INODE,PTRFAC,NSTEPS,A,LA, & IERR) IMPLICIT NONE INTEGER INODE,NSTEPS INTEGER(8) :: LA INTEGER, INTENT(out)::IERR COMPLEX A(LA) INTEGER (8) :: PTRFAC(NSTEPS) INTEGER CMUMPS_SOLVE_IS_INODE_IN_MEM IERR=0 IF(INODE_TO_POS(STEP_OOC(INODE)).GT.0)THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN CMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_PERMUTED ELSE CMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_PERMUTED ENDIF IF(.NOT.CMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE) & .EQ.INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL CMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF ELSEIF(INODE_TO_POS(STEP_OOC(INODE)).LT.0)THEN IF(INODE_TO_POS(STEP_OOC(INODE)).LT.-((N_OOC+1)*NB_Z))THEN CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(INODE)),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': Internal error (7) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF CALL CMUMPS_SOLVE_UPDATE_POINTERS(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ELSE CALL CMUMPS_SOLVE_UPD_NODE_INFO(INODE,PTRFAC,NSTEPS) IF(.NOT.CMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE).EQ. & INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL CMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF ENDIF IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN CMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_PERMUTED ELSE CMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_PERMUTED ENDIF ELSE CMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_IN_MEM ENDIF RETURN END FUNCTION CMUMPS_SOLVE_IS_INODE_IN_MEM SUBROUTINE CMUMPS_SOLVE_MODIFY_STATE_NODE(INODE) IMPLICIT NONE INTEGER INODE IF ( (KEEP_OOC(237).EQ.0) & .AND. (KEEP_OOC(235).EQ.0) & .AND. (KEEP_OOC(212).EQ.0) & ) THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).NE.NOT_USED)THEN WRITE(*,*)MYID_OOC,': INTERNAL ERROR (51) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF ENDIF OOC_STATE_NODE(STEP_OOC(INODE))=PERMUTED END SUBROUTINE CMUMPS_SOLVE_MODIFY_STATE_NODE SUBROUTINE CMUMPS_SOLVE_UPD_NODE_INFO(INODE,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER INODE,NSTEPS INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZONE INODE_TO_POS(STEP_OOC(INODE))=-INODE_TO_POS(STEP_OOC(INODE)) POS_IN_MEM(INODE_TO_POS(STEP_OOC(INODE)))= & -POS_IN_MEM(INODE_TO_POS(STEP_OOC(INODE))) PTRFAC(STEP_OOC(INODE))=-PTRFAC(STEP_OOC(INODE)) IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.USED_NOT_PERMUTED)THEN OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED ELSEIF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.USED)THEN OOC_STATE_NODE(STEP_OOC(INODE))=PERMUTED ELSE WRITE(*,*)MYID_OOC,': Internal error (52) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)), & INODE_TO_POS(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF CALL CMUMPS_SEARCH_SOLVE(PTRFAC(STEP_OOC(INODE)),ZONE) IF(INODE_TO_POS(STEP_OOC(INODE)).LE.POS_HOLE_B(ZONE))THEN IF(INODE_TO_POS(STEP_OOC(INODE)).GT. & PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)= & INODE_TO_POS(STEP_OOC(INODE))-1 ELSE CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF ENDIF IF(INODE_TO_POS(STEP_OOC(INODE)).GE.POS_HOLE_T(ZONE))THEN IF(INODE_TO_POS(STEP_OOC(INODE)).LT. & CURRENT_POS_T(ZONE)-1)THEN POS_HOLE_T(ZONE)=INODE_TO_POS(STEP_OOC(INODE))+1 ELSE POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) ENDIF ENDIF CALL CMUMPS_OOC_UPDATE_SOLVE_STAT(INODE,PTRFAC,NSTEPS,1) END SUBROUTINE CMUMPS_SOLVE_UPD_NODE_INFO SUBROUTINE CMUMPS_SOLVE_FIND_ZONE(INODE,ZONE,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER INODE,ZONE,NSTEPS INTEGER (8) :: PTRFAC(NSTEPS) ZONE=1 DO WHILE (ZONE.LE.NB_Z) IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN ZONE=ZONE-1 EXIT ENDIF ZONE=ZONE+1 ENDDO IF(ZONE.EQ.NB_Z+1)THEN ZONE=ZONE-1 ENDIF END SUBROUTINE CMUMPS_SOLVE_FIND_ZONE SUBROUTINE CMUMPS_SOLVE_TRY_ZONE_FOR_READ(ZONE) IMPLICIT NONE INTEGER ZONE ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1)+1 END SUBROUTINE CMUMPS_SOLVE_TRY_ZONE_FOR_READ SUBROUTINE CMUMPS_SOLVE_SELECT_ZONE(ZONE) IMPLICIT NONE INTEGER ZONE IF(NB_Z.GT.1)THEN CURRENT_SOLVE_READ_ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1) ZONE=CURRENT_SOLVE_READ_ZONE+1 ELSE ZONE=NB_Z ENDIF END SUBROUTINE CMUMPS_SOLVE_SELECT_ZONE SUBROUTINE CMUMPS_SOLVE_ALLOC_FACTOR_SPACE(INODE,PTRFAC, & KEEP,KEEP8, & A,IERR) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER, intent(out)::IERR INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX A(FACT_AREA_SIZE) INTEGER(8) :: REQUESTED_SIZE INTEGER ZONE,IFLAG IERR=0 IFLAG=0 IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) & .EQ.0_8)THEN INODE_TO_POS(STEP_OOC(INODE))=1 OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED PTRFAC(STEP_OOC(INODE))=1_8 RETURN ENDIF REQUESTED_SIZE=SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ZONE=NB_Z IF(CURRENT_POS_T(ZONE).GT. & (PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1))THEN CALL CMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF((LRLU_SOLVE_T(ZONE).GT.SIZE_OF_BLOCK(STEP_OOC(INODE), & OOC_FCT_TYPE)).AND. & (CURRENT_POS_T(ZONE).LE. & (PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1)))THEN CALL CMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(LRLU_SOLVE_B(ZONE).GT.SIZE_OF_BLOCK(STEP_OOC(INODE), & OOC_FCT_TYPE).AND. & (CURRENT_POS_B(ZONE).GT.0))THEN CALL CMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSE IF(CMUMPS_IS_THERE_FREE_SPACE(INODE,ZONE))THEN IF(SOLVE_STEP.EQ.0)THEN CALL CMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL CMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL CMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL CMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ELSE CALL CMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL CMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL CMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL CMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ENDIF IF(IFLAG.EQ.0)THEN CALL CMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL CMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ELSE WRITE(*,*)MYID_OOC,': Internal error (8) in OOC ', & ' Not enough space for Solve',INODE, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE), & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF ENDIF IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (9) in OOC ', & ' LRLUS_SOLVE must be (3) > 0' CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE CMUMPS_SOLVE_ALLOC_FACTOR_SPACE SUBROUTINE CMUMPS_GET_TOP_AREA_SPACE(A,LA,REQUESTED_SIZE,PTRFAC, & NSTEPS,ZONE,FLAG,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE,FLAG INTEGER(8) :: REQUESTED_SIZE, LA INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: FREE_SIZE, FREE_HOLE, FREE_HOLE_POS COMPLEX A(LA) INTEGER I,TMP_NODE,FREE_HOLE_FLAG, J INTEGER, intent(out)::IERR IERR=0 FLAG=0 IF(LRLU_SOLVE_T(ZONE).EQ.SIZE_SOLVE_Z(ZONE).AND. & (.NOT.(CURRENT_POS_T(ZONE) & .GT.PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1)))THEN GOTO 50 ENDIF J=max(POS_HOLE_B(ZONE),PDEB_SOLVE_Z(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) DO I=POS_HOLE_T(ZONE)-1,J,-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) ELSEIF(POS_IN_MEM(I).NE.0)THEN EXIT ENDIF ENDDO POS_HOLE_T(ZONE)=I+1 IF((POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE)).OR. & (POS_HOLE_T(ZONE).LE.POS_HOLE_B(ZONE)).OR. & (POS_HOLE_T(ZONE).EQ.POS_HOLE_B(ZONE)+1))THEN CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_T(ZONE)=PDEB_SOLVE_Z(ZONE) ENDIF FREE_HOLE=0_8 FREE_SIZE=0_8 FREE_HOLE_FLAG=0 FREE_HOLE_POS=POSFAC_SOLVE(ZONE) DO I=CURRENT_POS_T(ZONE)-1,POS_HOLE_T(ZONE),-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) FREE_HOLE_FLAG=0 FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE))) PTRFAC(STEP_OOC(TMP_NODE))=-777777_8 INODE_TO_POS(STEP_OOC(TMP_NODE))=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED POS_IN_MEM(I)=0 FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).EQ.0)THEN FREE_HOLE_FLAG=1 ELSEIF(POS_IN_MEM(I).NE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (10) in OOC ', & ' CMUMPS_GET_TOP_AREA_SPACE', & CURRENT_POS_T(ZONE)-1,POS_HOLE_T(ZONE),I CALL MUMPS_ABORT() ENDIF ENDDO IF(POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE))THEN IF(FREE_HOLE_FLAG.EQ.0)THEN FREE_HOLE_FLAG=1 ENDIF ENDIF IF(FREE_HOLE_FLAG.EQ.1)THEN IF(POS_HOLE_T(ZONE)-1.GT.PDEB_SOLVE_Z(ZONE))THEN I=POS_HOLE_T(ZONE)-1 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.(N_OOC+1)*NB_Z)THEN TMP_NODE=TMP_NODE-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (11) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL CMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSEIF(TMP_NODE.EQ.0)THEN DO J=I,PDEB_SOLVE_Z(ZONE),-1 IF(POS_IN_MEM(J).NE.0) EXIT ENDDO IF(POS_IN_MEM(J).LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (12) in OOC ', & ' CMUMPS_GET_TOP_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF(J.GE.PDEB_SOLVE_Z(ZONE))THEN TMP_NODE=POS_IN_MEM(J) FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE FREE_HOLE=FREE_HOLE_POS-IDEB_SOLVE_Z(ZONE) ENDIF ELSEIF(TMP_NODE.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (13) in OOC', & ' CMUMPS_GET_TOP_AREA_SPACE' CALL MUMPS_ABORT() ELSE FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ENDIF ELSE FREE_HOLE=FREE_HOLE_POS-IDEB_SOLVE_Z(ZONE) ENDIF FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF CURRENT_POS_T(ZONE)=POS_HOLE_T(ZONE) LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)+FREE_SIZE POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)-FREE_SIZE 50 CONTINUE IF(REQUESTED_SIZE.LE.LRLU_SOLVE_T(ZONE))THEN FLAG=1 ELSE FLAG=0 ENDIF RETURN END SUBROUTINE CMUMPS_GET_TOP_AREA_SPACE SUBROUTINE CMUMPS_GET_BOTTOM_AREA_SPACE(A,LA,REQUESTED_SIZE, & PTRFAC,NSTEPS,ZONE,FLAG,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE,FLAG INTEGER (8) :: REQUESTED_SIZE INTEGER (8) :: LA INTEGER (8) :: PTRFAC(NSTEPS) COMPLEX A(LA) INTEGER(8) :: FREE_SIZE, FREE_HOLE_POS, FREE_HOLE INTEGER I,J,TMP_NODE,FREE_HOLE_FLAG INTEGER, intent(out) :: IERR IERR=0 FLAG=0 IF(LRLU_SOLVE_B(ZONE).EQ.SIZE_SOLVE_Z(ZONE))THEN GOTO 50 ENDIF IF(POS_HOLE_B(ZONE).EQ.-9999)THEN GOTO 50 ENDIF J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_T(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE = 0_8 DO I=POS_HOLE_B(ZONE)+1,J IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN EXIT ENDIF ENDDO POS_HOLE_B(ZONE)=I-1 IF((POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE)).OR. & (POS_HOLE_T(ZONE).LE.POS_HOLE_B(ZONE)).OR. & (POS_HOLE_T(ZONE).EQ.POS_HOLE_B(ZONE)+1))THEN CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_T(ZONE)=PDEB_SOLVE_Z(ZONE) ENDIF FREE_HOLE=0_8 FREE_SIZE=0_8 FREE_HOLE_FLAG=0 FREE_HOLE_POS=IDEB_SOLVE_Z(ZONE) IF(POS_HOLE_B(ZONE).EQ.-9999)THEN GOTO 50 ENDIF DO I=PDEB_SOLVE_Z(ZONE),POS_HOLE_B(ZONE) IF((POS_IN_MEM(I).LE.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) IF(TMP_NODE.NE.0)THEN IF(I.EQ.PDEB_SOLVE_Z(ZONE))THEN IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).NE. & IDEB_SOLVE_Z(ZONE))THEN FREE_SIZE=FREE_SIZE+abs(PTRFAC(STEP_OOC(TMP_NODE))) & -IDEB_SOLVE_Z(ZONE) ENDIF ENDIF IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(TMP_NODE))=-777777_8 INODE_TO_POS(STEP_OOC(TMP_NODE))=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSE FREE_HOLE_FLAG=1 ENDIF POS_IN_MEM(I)=0 ELSEIF(POS_IN_MEM(I).NE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (14) in OOC ', & ' CMUMPS_GET_BOTTOM_AREA_SPACE', & CURRENT_POS_T(ZONE)-1,POS_HOLE_B(ZONE),I,POS_IN_MEM(I) CALL MUMPS_ABORT() ENDIF ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN IF(POS_HOLE_B(ZONE)+1.LT.CURRENT_POS_T(ZONE)-1)THEN I=POS_HOLE_B(ZONE)+1 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.(N_OOC+1)*NB_Z)THEN TMP_NODE=TMP_NODE-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (15) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL CMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))-FREE_HOLE_POS ELSEIF(TMP_NODE.EQ.0)THEN DO J=I,CURRENT_POS_T(ZONE)-1 IF(POS_IN_MEM(J).NE.0) EXIT ENDDO IF(POS_IN_MEM(J).LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (16) in OOC ', & ' CMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF(J.LE.CURRENT_POS_T(ZONE)-1)THEN TMP_NODE=POS_IN_MEM(J) FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS ELSE FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS ENDIF ELSEIF(TMP_NODE.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (17) in OOC ', & ' CMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ELSE FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS ENDIF ELSE FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS ENDIF FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF LRLU_SOLVE_B(ZONE)=FREE_SIZE IF(POS_HOLE_B(ZONE).LT.CURRENT_POS_T(ZONE)-1)THEN TMP_NODE=POS_IN_MEM(POS_HOLE_B(ZONE)+1) IF(TMP_NODE.LT.-(N_OOC+1)*NB_Z)THEN TMP_NODE=abs(TMP_NODE)-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (18) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL CMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) ENDIF LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)+ & (abs(PTRFAC(STEP_OOC(abs(TMP_NODE))))-IDEB_SOLVE_Z(ZONE)- & LRLU_SOLVE_B(ZONE)) ENDIF CURRENT_POS_B(ZONE)=POS_HOLE_B(ZONE) 50 CONTINUE IF((POS_HOLE_B(ZONE).EQ.-9999).AND. & (LRLU_SOLVE_B(ZONE).NE.0_8))THEN WRITE(*,*)MYID_OOC,': Internal error (19) in OOC ', & 'CMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF((REQUESTED_SIZE.LE.LRLU_SOLVE_B(ZONE)).AND. & (POS_HOLE_B(ZONE).NE.-9999))THEN FLAG=1 ELSE FLAG=0 ENDIF END SUBROUTINE CMUMPS_GET_BOTTOM_AREA_SPACE SUBROUTINE CMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8, A,ZONE) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX A(FACT_AREA_SIZE) INTEGER ZONE LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(INODE))=POSFAC_SOLVE(ZONE) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED IF(POSFAC_SOLVE(ZONE).EQ.IDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (20) in OOC ', & ' Problem avec debut (2)',INODE, & PTRFAC(STEP_OOC(INODE)),IDEB_SOLVE_Z(ZONE),ZONE CALL MUMPS_ABORT() ENDIF INODE_TO_POS(STEP_OOC(INODE))=CURRENT_POS_T(ZONE) POS_IN_MEM(CURRENT_POS_T(ZONE))=INODE IF(CURRENT_POS_T(ZONE).GT.(PDEB_SOLVE_Z(ZONE)+ & MAX_NB_NODES_FOR_ZONE-1))THEN WRITE(*,*)MYID_OOC,': Internal error (21) in OOC ', & ' Problem with CURRENT_POS_T', & CURRENT_POS_T(ZONE),ZONE CALL MUMPS_ABORT() ENDIF CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)+1 POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) END SUBROUTINE CMUMPS_SOLVE_ALLOC_PTR_UPD_T SUBROUTINE CMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8, & A,ZONE) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX A(FACT_AREA_SIZE) INTEGER ZONE IF(POS_HOLE_B(ZONE).EQ.-9999)THEN WRITE(*,*)MYID_OOC,': Internal error (22) in OOC ', & ' CMUMPS_SOLVE_ALLOC_PTR_UPD_B' CALL MUMPS_ABORT() ENDIF LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(INODE))=IDEB_SOLVE_Z(ZONE)+ & LRLU_SOLVE_B(ZONE) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (23) in OOC ', & PTRFAC(STEP_OOC(INODE)),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF INODE_TO_POS(STEP_OOC(INODE))=CURRENT_POS_B(ZONE) IF(CURRENT_POS_B(ZONE).EQ.0)THEN WRITE(*,*)MYID_OOC,': Internal error (23b) in OOC ' CALL MUMPS_ABORT() ENDIF POS_IN_MEM(CURRENT_POS_B(ZONE))=INODE CURRENT_POS_B(ZONE)=CURRENT_POS_B(ZONE)-1 POS_HOLE_B(ZONE)=CURRENT_POS_B(ZONE) END SUBROUTINE CMUMPS_SOLVE_ALLOC_PTR_UPD_B SUBROUTINE CMUMPS_FREE_SPACE_FOR_SOLVE(A,LA,REQUESTED_SIZE,PTRFAC, & NSTEPS,ZONE,IERR) IMPLICIT NONE INTEGER(8) :: LA, REQUESTED_SIZE INTEGER NSTEPS,ZONE INTEGER, intent(out) :: IERR INTEGER(8) :: PTRFAC(NSTEPS) COMPLEX A(LA) INTEGER (8) :: APOS_FIRST_FREE, & SIZE_HOLE, & FREE_HOLE, & FREE_HOLE_POS INTEGER J,I,TMP_NODE, NB_FREE, IPOS_FIRST_FREE INTEGER(8) :: K8, AREA_POINTER INTEGER FREE_HOLE_FLAG IERR=0 IF(LRLU_SOLVE_T(ZONE).EQ.SIZE_SOLVE_Z(ZONE))THEN RETURN ENDIF AREA_POINTER=IDEB_SOLVE_Z(ZONE) SIZE_HOLE=0_8 DO I=PDEB_SOLVE_Z(ZONE),CURRENT_POS_T(ZONE)-1 IF((POS_IN_MEM(I).LE.0).AND. & (POS_IN_MEM(I).GT.-((N_OOC+1)*NB_Z))) GOTO 666 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.((N_OOC+1)*NB_Z))THEN TMP_NODE=TMP_NODE-((N_OOC+1)*NB_Z) ENDIF AREA_POINTER=AREA_POINTER+ & abs(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ENDDO 666 CONTINUE IF((I.EQ.CURRENT_POS_T(ZONE)-1).AND. & (PDEB_SOLVE_Z(ZONE).NE.CURRENT_POS_T(ZONE)-1))THEN IF((POS_IN_MEM(I).GT.0).OR. & (POS_IN_MEM(I).LT.-((N_OOC+1)*NB_Z)))THEN WRITE(*,*)MYID_OOC,': Internal error (25) in OOC ', & ': There are no free blocks ', & 'in CMUMPS_FREE_SPACE_FOR_SOLVE',PDEB_SOLVE_Z(ZONE), & CURRENT_POS_T(ZONE) CALL MUMPS_ABORT() ENDIF ENDIF IF(POS_IN_MEM(I).EQ.0)THEN APOS_FIRST_FREE=AREA_POINTER FREE_HOLE_POS=AREA_POINTER ELSE TMP_NODE=abs(POS_IN_MEM(I)) APOS_FIRST_FREE=abs(PTRFAC(STEP_OOC(TMP_NODE))) ENDIF IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).NE.0)THEN IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=abs(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)))- & ((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL CMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) ELSE TMP_NODE=abs(POS_IN_MEM(PDEB_SOLVE_Z(ZONE))) ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).NE.IDEB_SOLVE_Z(ZONE))THEN IF((POS_IN_MEM(I).NE.0).OR.(I.EQ.CURRENT_POS_T(ZONE)))THEN SIZE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & IDEB_SOLVE_Z(ZONE) ENDIF APOS_FIRST_FREE=IDEB_SOLVE_Z(ZONE) IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).GT.0)THEN DO J=PDEB_SOLVE_Z(ZONE),I-1 TMP_NODE=POS_IN_MEM(J) IF(TMP_NODE.LE.0)THEN IF(TMP_NODE.LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=abs(POS_IN_MEM(J))-((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST( & IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL CMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=POS_IN_MEM(J) ELSE WRITE(*,*)MYID_OOC,': Internal error (26) in OOC ', & ' CMUMPS_FREE_SPACE_FOR_SOLVE',TMP_NODE, & J,I-1,(N_OOC+1)*NB_Z CALL MUMPS_ABORT() ENDIF ENDIF DO K8=1_8, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) A(APOS_FIRST_FREE+K8-1_8)= & A(PTRFAC(STEP_OOC(TMP_NODE))+K8-1_8) ENDDO PTRFAC(STEP_OOC(TMP_NODE))=APOS_FIRST_FREE APOS_FIRST_FREE=APOS_FIRST_FREE+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) ENDDO ENDIF ENDIF ENDIF NB_FREE=0 FREE_HOLE=0_8 FREE_HOLE_FLAG=0 DO J=I,CURRENT_POS_T(ZONE)-1 TMP_NODE=abs(POS_IN_MEM(J)) IF(POS_IN_MEM(J).LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=TMP_NODE-((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL CMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=abs(POS_IN_MEM(J)) ENDIF IF(POS_IN_MEM(J).GT.0)THEN DO K8=1_8,SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) A(APOS_FIRST_FREE+K8-1_8)= & A(PTRFAC(STEP_OOC(TMP_NODE))+K8-1_8) ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(TMP_NODE))=APOS_FIRST_FREE APOS_FIRST_FREE=APOS_FIRST_FREE+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(J).EQ.0)THEN FREE_HOLE_FLAG=1 NB_FREE=NB_FREE+1 ELSE NB_FREE=NB_FREE+1 IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) SIZE_HOLE=SIZE_HOLE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) PTRFAC(STEP_OOC(abs(POS_IN_MEM(J))))=-77777_8 ENDIF ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF IPOS_FIRST_FREE=I DO J=I,CURRENT_POS_T(ZONE)-1 IF(POS_IN_MEM(J).LT.0)THEN TMP_NODE=abs(POS_IN_MEM(J)) INODE_TO_POS(STEP_OOC(TMP_NODE))=0 POS_IN_MEM(J)=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED ELSEIF(POS_IN_MEM(J).GT.0)THEN TMP_NODE=abs(POS_IN_MEM(J)) POS_IN_MEM(IPOS_FIRST_FREE)=POS_IN_MEM(J) INODE_TO_POS(STEP_OOC(TMP_NODE))=IPOS_FIRST_FREE IPOS_FIRST_FREE=IPOS_FIRST_FREE+1 ENDIF ENDDO LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)+SIZE_HOLE POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)-SIZE_HOLE CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)-NB_FREE POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 IF(LRLU_SOLVE_T(ZONE).NE.LRLUS_SOLVE(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (27) in OOC ', & LRLU_SOLVE_T(ZONE), & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF LRLU_SOLVE_T(ZONE)=LRLUS_SOLVE(ZONE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (28) in OOC ', & ' LRLUS_SOLVE must be (4) > 0' CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (29) in OOC ', & POSFAC_SOLVE(ZONE),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).NE.(IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)- & LRLUS_SOLVE(ZONE)))THEN WRITE(*,*)MYID_OOC,': Internal error (30) in OOC ', & ' Problem avec debut POSFAC_SOLVE', & POSFAC_SOLVE(ZONE),(SIZE_SOLVE_Z(ZONE)- & LRLUS_SOLVE(ZONE))+IDEB_SOLVE_Z(ZONE),LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).GT. & (IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)-1_8))THEN WRITE(*,*)MYID_OOC,': Internal error (31) in OOC ', & POSFAC_SOLVE(ZONE),IDEB_SOLVE_Z(ZONE)+ & SIZE_SOLVE_Z(ZONE)-1_8 CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE CMUMPS_FREE_SPACE_FOR_SOLVE SUBROUTINE CMUMPS_OOC_UPDATE_SOLVE_STAT(INODE,PTRFAC,NSTEPS,FLAG) IMPLICIT NONE INTEGER INODE,NSTEPS,FLAG INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZONE IF((FLAG.LT.0).OR.(FLAG.GT.1))THEN WRITE(*,*)MYID_OOC,': Internal error (32) in OOC ', & ' CMUMPS_OOC_UPDATE_SOLVE_STAT' CALL MUMPS_ABORT() ENDIF CALL CMUMPS_SEARCH_SOLVE(PTRFAC(STEP_OOC(INODE)),ZONE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (33) in OOC ', & ' LRLUS_SOLVE must be (5) ++ > 0' CALL MUMPS_ABORT() ENDIF IF(FLAG.EQ.0)THEN LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ELSE LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ENDIF IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (34) in OOC ', & ' LRLUS_SOLVE must be (5) > 0' CALL MUMPS_ABORT() ENDIF END SUBROUTINE CMUMPS_OOC_UPDATE_SOLVE_STAT SUBROUTINE CMUMPS_SEARCH_SOLVE(ADDR,ZONE) IMPLICIT NONE INTEGER (8) :: ADDR INTEGER ZONE INTEGER I I=1 DO WHILE (I.LE.NB_Z) IF(ADDR.LT.IDEB_SOLVE_Z(I))THEN EXIT ENDIF I=I+1 ENDDO ZONE=I-1 END SUBROUTINE CMUMPS_SEARCH_SOLVE FUNCTION CMUMPS_SOLVE_IS_END_REACHED() IMPLICIT NONE LOGICAL CMUMPS_SOLVE_IS_END_REACHED CMUMPS_SOLVE_IS_END_REACHED=.FALSE. IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN CMUMPS_SOLVE_IS_END_REACHED=.TRUE. ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.LT.1)THEN CMUMPS_SOLVE_IS_END_REACHED=.TRUE. ENDIF ENDIF RETURN END FUNCTION CMUMPS_SOLVE_IS_END_REACHED SUBROUTINE CMUMPS_SOLVE_ZONE_READ(ZONE,A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE INTEGER(8), INTENT(IN) :: LA INTEGER, intent(out) :: IERR COMPLEX A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: SIZE, DEST INTEGER(8) :: NEEDED_SIZE INTEGER FLAG,TMP_FLAG,POS_SEQ,TMP_NODE, & NB_NODES IERR=0 TMP_FLAG=0 FLAG=0 IF(CMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE).GT. & SIZE_SOLVE_Z(ZONE)) CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 IF(CMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL CMUMPS_OOC_SKIP_NULL_SIZE_NODE() NEEDED_SIZE=max(MIN_SIZE_READ, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE NEEDED_SIZE=MIN_SIZE_READ ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.GE.1)THEN TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE).GT. & SIZE_SOLVE_Z(ZONE)) CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 IF(CMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL CMUMPS_OOC_SKIP_NULL_SIZE_NODE() NEEDED_SIZE=max(MIN_SIZE_READ, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE NEEDED_SIZE=MIN_SIZE_READ ENDIF ENDIF IF(LRLUS_SOLVE(ZONE).LT.NEEDED_SIZE)THEN RETURN ELSEIF((LRLU_SOLVE_T(ZONE).LT.NEEDED_SIZE).AND. & (LRLU_SOLVE_B(ZONE).LT.NEEDED_SIZE).AND. & (dble(LRLUS_SOLVE(ZONE)).LT.0.3d0* & dble(SIZE_SOLVE_Z(ZONE)))) THEN RETURN ENDIF IF((LRLU_SOLVE_T(ZONE).GT.NEEDED_SIZE).AND.(SOLVE_STEP.EQ.0).AND. & ((CURRENT_POS_T(ZONE)-PDEB_SOLVE_Z(ZONE)+1).LT. & MAX_NB_NODES_FOR_ZONE))THEN FLAG=1 ELSE IF(SOLVE_STEP.EQ.0)THEN CALL CMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 IF(TMP_FLAG.EQ.0)THEN CALL CMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=0 ENDIF ELSE CALL CMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=0 IF(TMP_FLAG.EQ.0)THEN CALL CMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF IF(TMP_FLAG.EQ.0)THEN CALL CMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF CALL CMUMPS_SOLVE_COMPUTE_READ_SIZE(ZONE,SIZE,DEST,POS_SEQ, & NB_NODES,FLAG,PTRFAC,NSTEPS) IF(SIZE.EQ.0_8)THEN RETURN ENDIF NB_ZONE_REQ=NB_ZONE_REQ+1 SIZE_ZONE_REQ=SIZE_ZONE_REQ+SIZE REQ_ACT=REQ_ACT+1 CALL CMUMPS_READ_SOLVE_BLOCK(A(DEST),DEST,SIZE,ZONE,PTRFAC,NSTEPS, & POS_SEQ,NB_NODES,FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END SUBROUTINE CMUMPS_SOLVE_ZONE_READ SUBROUTINE CMUMPS_SOLVE_COMPUTE_READ_SIZE(ZONE,SIZE,DEST,POS_SEQ, & NB_NODES,FLAG,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER(8) :: SIZE, DEST INTEGER ZONE,FLAG,POS_SEQ,NSTEPS INTEGER(8) :: PTRFAC(NSTEPS), MAX_SIZE, LAST, J8 INTEGER I,START_NODE,K,MAX_NB, & NB_NODES INTEGER NB_NODES_LOC LOGICAL ALREADY IF(CMUMPS_SOLVE_IS_END_REACHED())THEN SIZE=0_8 RETURN ENDIF IF(FLAG.EQ.0)THEN MAX_SIZE=LRLU_SOLVE_B(ZONE) MAX_NB=max(0,CURRENT_POS_B(ZONE)-PDEB_SOLVE_Z(ZONE)+1) ELSEIF(FLAG.EQ.1)THEN MAX_SIZE=LRLU_SOLVE_T(ZONE) MAX_NB=MAX_NB_NODES_FOR_ZONE ELSE WRITE(*,*)MYID_OOC,': Internal error (35) in OOC ', & ' Unknown Flag value in ', & ' CMUMPS_SOLVE_COMPUTE_READ_SIZE',FLAG CALL MUMPS_ABORT() ENDIF CALL CMUMPS_OOC_SKIP_NULL_SIZE_NODE() I=CUR_POS_SEQUENCE START_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ALREADY=.FALSE. NB_NODES=0 NB_NODES_LOC=0 IF(ZONE.EQ.NB_Z)THEN SIZE=SIZE_OF_BLOCK(STEP_OOC(START_NODE),OOC_FCT_TYPE) ELSE J8=0_8 IF(FLAG.EQ.0)THEN K=0 ELSEIF(FLAG.EQ.1)THEN K=CURRENT_POS_T(ZONE)-PDEB_SOLVE_Z(ZONE)+1 ENDIF IF(SOLVE_STEP.EQ.0)THEN I=CUR_POS_SEQUENCE DO WHILE(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) IF(SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF I=I+1 ENDDO CUR_POS_SEQUENCE=min(I,TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) I=CUR_POS_SEQUENCE DO WHILE((J8.LE.MAX_SIZE).AND. & (I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)).AND. & (K.LT.MAX_NB) ) LAST=SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ENDIF I=I+1 NB_NODES_LOC=NB_NODES_LOC+1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))) & .NE.0).OR. & (IO_REQ(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))).GE. & 0))THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 I=I+1 CYCLE ELSE EXIT ENDIF ENDIF ALREADY=.TRUE. J8=J8+LAST I=I+1 K=K+1 NB_NODES_LOC=NB_NODES_LOC+1 NB_NODES=NB_NODES+1 ENDDO IF(J8.GT.MAX_SIZE)THEN SIZE=J8-LAST NB_NODES=NB_NODES-1 NB_NODES_LOC=NB_NODES_LOC-1 ELSE SIZE=J8 ENDIF DO WHILE (CUR_POS_SEQUENCE+NB_NODES_LOC-1.GE. & CUR_POS_SEQUENCE) IF(SIZE_OF_BLOCK(STEP_OOC( & OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE+NB_NODES-1, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF NB_NODES_LOC=NB_NODES_LOC-1 ENDDO POS_SEQ=CUR_POS_SEQUENCE ELSEIF(SOLVE_STEP.EQ.1)THEN DO WHILE(I.GE.1) IF(SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF I=I-1 ENDDO CUR_POS_SEQUENCE=max(I,1) I=CUR_POS_SEQUENCE DO WHILE((J8.LE.MAX_SIZE).AND.(I.GE.1).AND. & (K.LT.MAX_NB)) LAST=SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF NB_NODES_LOC=NB_NODES_LOC+1 I=I-1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))) & .NE.0).OR. & (IO_REQ(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))).GE. & 0))THEN IF(.NOT.ALREADY)THEN I=I-1 CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 CYCLE ELSE EXIT ENDIF ENDIF ALREADY=.TRUE. J8=J8+LAST I=I-1 K=K+1 NB_NODES=NB_NODES+1 NB_NODES_LOC=NB_NODES_LOC+1 ENDDO IF(J8.GT.MAX_SIZE)THEN SIZE=J8-LAST NB_NODES=NB_NODES-1 NB_NODES_LOC=NB_NODES_LOC-1 ELSE SIZE=J8 ENDIF I=CUR_POS_SEQUENCE-NB_NODES_LOC+1 DO WHILE (I.LE.CUR_POS_SEQUENCE) IF(SIZE_OF_BLOCK(STEP_OOC( & OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE)), & OOC_FCT_TYPE).NE.0_8)THEN EXIT ENDIF I=I+1 NB_NODES_LOC=NB_NODES_LOC-1 ENDDO POS_SEQ=CUR_POS_SEQUENCE-NB_NODES_LOC+1 ENDIF ENDIF IF(FLAG.EQ.0)THEN DEST=IDEB_SOLVE_Z(ZONE)+LRLU_SOLVE_B(ZONE)-SIZE ELSE DEST=POSFAC_SOLVE(ZONE) ENDIF END SUBROUTINE CMUMPS_SOLVE_COMPUTE_READ_SIZE SUBROUTINE CMUMPS_OOC_END_SOLVE(IERR) IMPLICIT NONE INTEGER SOLVE_OR_FACTO INTEGER, intent(out) :: IERR IERR=0 IF(allocated(LRLUS_SOLVE))THEN DEALLOCATE(LRLUS_SOLVE) ENDIF IF(allocated(LRLU_SOLVE_T))THEN DEALLOCATE(LRLU_SOLVE_T) ENDIF IF(allocated(LRLU_SOLVE_B))THEN DEALLOCATE(LRLU_SOLVE_B) ENDIF IF(allocated(POSFAC_SOLVE))THEN DEALLOCATE(POSFAC_SOLVE) ENDIF IF(allocated(IDEB_SOLVE_Z))THEN DEALLOCATE(IDEB_SOLVE_Z) ENDIF IF(allocated(PDEB_SOLVE_Z))THEN DEALLOCATE(PDEB_SOLVE_Z) ENDIF IF(allocated(SIZE_SOLVE_Z))THEN DEALLOCATE(SIZE_SOLVE_Z) ENDIF IF(allocated(CURRENT_POS_T))THEN DEALLOCATE(CURRENT_POS_T) ENDIF IF(allocated(CURRENT_POS_B))THEN DEALLOCATE(CURRENT_POS_B) ENDIF IF(allocated(POS_HOLE_T))THEN DEALLOCATE(POS_HOLE_T) ENDIF IF(allocated(POS_HOLE_B))THEN DEALLOCATE(POS_HOLE_B) ENDIF IF(allocated(OOC_STATE_NODE))THEN DEALLOCATE(OOC_STATE_NODE) ENDIF IF(allocated(POS_IN_MEM))THEN DEALLOCATE(POS_IN_MEM) ENDIF IF(allocated(INODE_TO_POS))THEN DEALLOCATE(INODE_TO_POS) ENDIF IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(allocated(SIZE_OF_READ))THEN DEALLOCATE(SIZE_OF_READ) ENDIF IF(allocated(FIRST_POS_IN_READ))THEN DEALLOCATE(FIRST_POS_IN_READ) ENDIF IF(allocated(READ_DEST))THEN DEALLOCATE(READ_DEST) ENDIF IF(allocated(READ_MNG))THEN DEALLOCATE(READ_MNG) ENDIF IF(allocated(REQ_TO_ZONE))THEN DEALLOCATE(REQ_TO_ZONE) ENDIF IF(allocated(REQ_ID))THEN DEALLOCATE(REQ_ID) ENDIF SOLVE_OR_FACTO=1 CALL MUMPS_CLEAN_IO_DATA_C(MYID_OOC,SOLVE_OR_FACTO,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF END SUBROUTINE CMUMPS_OOC_END_SOLVE SUBROUTINE CMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS, & A,LA) IMPLICIT NONE INTEGER, INTENT(in) :: NSTEPS INTEGER(8), INTENT(INOUT) :: PTRFAC(NSTEPS) INTEGER(8), INTENT(IN) :: LA COMPLEX :: A(LA) INTEGER :: I, TMP, ZONE, IPAS, IBEG, IEND INTEGER(8) :: SAVE_PTR LOGICAL :: COMPRESS_TO_BE_DONE, SET_POS_SEQUENCE INTEGER :: J, IERR INTEGER(8) :: DUMMY_SIZE COMPRESS_TO_BE_DONE = .FALSE. DUMMY_SIZE = 1_8 IERR = 0 SET_POS_SEQUENCE = .TRUE. IF(SOLVE_STEP.EQ.0)THEN IBEG = 1 IEND = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) IPAS = 1 ELSE IBEG = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) IEND = 1 IPAS = -1 ENDIF DO I=IBEG,IEND,IPAS J = OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) TMP=INODE_TO_POS(STEP_OOC(J)) IF(TMP.EQ.0)THEN IF (SET_POS_SEQUENCE) THEN SET_POS_SEQUENCE = .FALSE. CUR_POS_SEQUENCE = I ENDIF IF (KEEP_OOC(237).EQ.0 .AND. KEEP_OOC(235).EQ.0 & .AND. KEEP_OOC(212).EQ.0 ) THEN OOC_STATE_NODE(STEP_OOC(J)) = NOT_IN_MEM ENDIF CYCLE ELSE IF(TMP.LT.0)THEN IF(TMP.GT.-(N_OOC+1)*NB_Z)THEN SAVE_PTR=PTRFAC(STEP_OOC(J)) PTRFAC(STEP_OOC(J)) = abs(SAVE_PTR) CALL CMUMPS_SOLVE_FIND_ZONE(J, & ZONE,PTRFAC,NSTEPS) PTRFAC(STEP_OOC(J)) = SAVE_PTR IF(ZONE.EQ.NB_Z)THEN IF(J.NE.SPECIAL_ROOT_NODE)THEN WRITE(*,*)MYID_OOC,': Internal error 6 ', & ' Node ', J, & ' is in status USED in the & emmergency buffer ' CALL MUMPS_ABORT() ENDIF ENDIF IF (KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0 & .OR. KEEP_OOC(212).NE.0 ) & THEN IF (OOC_STATE_NODE(STEP_OOC(J)).EQ.NOT_IN_MEM) THEN OOC_STATE_NODE(STEP_OOC(J)) = USED IF((SOLVE_STEP.NE.0).AND.(J.NE.SPECIAL_ROOT_NODE) & .AND.(ZONE.NE.NB_Z))THEN CALL CMUMPS_SOLVE_UPD_NODE_INFO(J,PTRFAC,NSTEPS) ENDIF CYCLE ELSEIF(OOC_STATE_NODE(STEP_OOC(J)).EQ.USED) & THEN COMPRESS_TO_BE_DONE = .TRUE. ELSE WRITE(*,*)MYID_OOC,': Internal error Mila 4 ', & ' wrong node status :', OOC_STATE_NODE(STEP_OOC(J)), & ' on node ', J CALL MUMPS_ABORT() ENDIF ENDIF IF (KEEP_OOC(237).EQ.0 .AND. KEEP_OOC(235).EQ.0 & .AND. KEEP_OOC(212).EQ.0 ) THEN CALL CMUMPS_SOLVE_UPD_NODE_INFO(J,PTRFAC,NSTEPS) ENDIF ENDIF ENDIF ENDDO IF (KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0 .OR. & KEEP_OOC(212).NE.0 ) & THEN IF (COMPRESS_TO_BE_DONE) THEN DO ZONE=1,NB_Z-1 CALL CMUMPS_FREE_SPACE_FOR_SOLVE(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,ZONE,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error Mila 5 ', & ' IERR on return to CMUMPS_FREE_SPACE_FOR_SOLVE =', & IERR CALL MUMPS_ABORT() ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SOLVE_PREPARE_PREF SUBROUTINE CMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,NSTEPS,MTYPE, & A,LA,DOPREFETCH,IERR) IMPLICIT NONE INTEGER NSTEPS,MTYPE INTEGER, intent(out)::IERR INTEGER(8) :: LA COMPLEX A(LA) INTEGER(8) :: PTRFAC(NSTEPS) LOGICAL DOPREFETCH INTEGER MUMPS_OOC_GET_FCT_TYPE EXTERNAL MUMPS_OOC_GET_FCT_TYPE IERR = 0 OOC_FCT_TYPE=MUMPS_OOC_GET_FCT_TYPE("F",MTYPE,KEEP_OOC(201), & KEEP_OOC(50)) OOC_SOLVE_TYPE_FCT = OOC_FCT_TYPE - 1 IF (KEEP_OOC(201).NE.1) THEN OOC_SOLVE_TYPE_FCT = FCT ENDIF SOLVE_STEP=0 CUR_POS_SEQUENCE=1 MTYPE_OOC=MTYPE IF ( KEEP_OOC(201).NE.1 & .OR. KEEP_OOC(50).NE.0 & ) THEN CALL CMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS,A,LA) ELSE CALL CMUMPS_SOLVE_STAT_REINIT_PANEL(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) ENDIF IF (DOPREFETCH) THEN CALL CMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC, & KEEP_OOC(28),IERR) ELSE CUR_POS_SEQUENCE = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) ENDIF RETURN END SUBROUTINE CMUMPS_SOLVE_INIT_OOC_FWD SUBROUTINE CMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,NSTEPS,MTYPE, & I_WORKED_ON_ROOT,IROOT,A,LA,IERR) IMPLICIT NONE INTEGER NSTEPS INTEGER(8) :: LA INTEGER(8) :: PTRFAC(NSTEPS) INTEGER MTYPE INTEGER IROOT LOGICAL I_WORKED_ON_ROOT INTEGER, intent(out):: IERR COMPLEX A(LA) INTEGER(8) :: DUMMY_SIZE INTEGER ZONE INTEGER MUMPS_OOC_GET_FCT_TYPE EXTERNAL MUMPS_OOC_GET_FCT_TYPE IERR=0 OOC_FCT_TYPE=MUMPS_OOC_GET_FCT_TYPE("B",MTYPE,KEEP_OOC(201), & KEEP_OOC(50)) OOC_SOLVE_TYPE_FCT = OOC_FCT_TYPE - 1 IF (KEEP_OOC(201).NE.1) OOC_SOLVE_TYPE_FCT=FCT SOLVE_STEP=1 CUR_POS_SEQUENCE=TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) MTYPE_OOC=MTYPE IF ( KEEP_OOC(201).NE.1 & .OR. KEEP_OOC(50).NE.0 & ) THEN CALL CMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS,A,LA) IF (I_WORKED_ON_ROOT.AND. $ ((IROOT.GT.0)))THEN IF(SIZE_OF_BLOCK(STEP_OOC(IROOT),OOC_FCT_TYPE).NE.0) THEN IF (.NOT.(KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0)) & THEN CALL CMUMPS_FREE_FACTORS_FOR_SOLVE ( IROOT, & PTRFAC, KEEP_OOC(28), A, LA,.FALSE.,IERR) IF (IERR .LT. 0) RETURN ENDIF CALL CMUMPS_SOLVE_FIND_ZONE(IROOT, & ZONE,PTRFAC,NSTEPS) IF(ZONE.EQ.NB_Z)THEN DUMMY_SIZE=1_8 CALL CMUMPS_FREE_SPACE_FOR_SOLVE(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,NB_Z,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error in & CMUMPS_FREE_SPACE_FOR_SOLVE', & IERR CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ENDIF IF (NB_Z.GT.1) THEN CALL CMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC, & KEEP_OOC(28),IERR) IF (IERR .LT. 0) RETURN ENDIF ELSE CALL CMUMPS_SOLVE_STAT_REINIT_PANEL(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) CALL CMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC,KEEP_OOC(28),IERR) IF (IERR .LT. 0 ) RETURN ENDIF RETURN END SUBROUTINE CMUMPS_SOLVE_INIT_OOC_BWD SUBROUTINE CMUMPS_STRUC_STORE_FILE_NAME(idOOC_NB_FILES, & idOOC_FILE_NAMES, idOOC_FILE_NAME_LENGTH, idINFO, IERR) IMPLICIT NONE INTEGER,DIMENSION(:), POINTER :: idOOC_NB_FILES CHARACTER,DIMENSION(:,:), POINTER :: idOOC_FILE_NAMES INTEGER,DIMENSION(:), POINTER :: idOOC_FILE_NAME_LENGTH INTEGER :: idINFO(2) INTEGER, intent(out) :: IERR INTEGER I,DIM,J,TMP,SIZE,K,I1 CHARACTER(len=1):: TMP_NAME(FILENAMELENGTH) 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) idOOC_NB_FILES(J)=I SIZE=SIZE+I ENDDO IF(associated(idOOC_FILE_NAMES))THEN DEALLOCATE(idOOC_FILE_NAMES) NULLIFY(idOOC_FILE_NAMES) ENDIF ALLOCATE(idOOC_FILE_NAMES(SIZE,FILENAMELENGTH),stat=IERR) IF (IERR .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'CMUMPS_STRUC_STORE_FILE_NAME' ENDIF IERR=-1 IF(idINFO(1).GE.0)THEN idINFO(1) = -13 idINFO(2) = SIZE*FILENAMELENGTH RETURN ENDIF ENDIF IF(associated(idOOC_FILE_NAME_LENGTH))THEN DEALLOCATE(idOOC_FILE_NAME_LENGTH) NULLIFY(idOOC_FILE_NAME_LENGTH) ENDIF ALLOCATE(idOOC_FILE_NAME_LENGTH(SIZE),stat=IERR) IF (IERR .GT. 0) THEN IERR=-1 IF(idINFO(1).GE.0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) & 'PB allocation in CMUMPS_STRUC_STORE_FILE_NAME' ENDIF idINFO(1) = -13 idINFO(2) = SIZE RETURN ENDIF ENDIF K=1 DO I1=1,OOC_NB_FILE_TYPE TMP=I1-1 DO I=1,idOOC_NB_FILES(I1) CALL MUMPS_OOC_GET_FILE_NAME_C(TMP,I,DIM,TMP_NAME(1)) DO J=1,DIM+1 idOOC_FILE_NAMES(K,J)=TMP_NAME(J) ENDDO idOOC_FILE_NAME_LENGTH(K)=DIM+1 K=K+1 ENDDO ENDDO RETURN END SUBROUTINE CMUMPS_STRUC_STORE_FILE_NAME SUBROUTINE CMUMPS_OOC_OPEN_FILES_FOR_SOLVE(idINFO, idOOC_NB_FILES, & idMYID, idKEEP, idOOC_FILE_NAME_LENGTH, & idOOC_FILE_NAMES) IMPLICIT NONE INTEGER :: idINFO(2), idMYID INTEGER, DIMENSION(:), POINTER :: idOOC_NB_FILES INTEGER, DIMENSION(:), POINTER :: idOOC_FILE_NAME_LENGTH CHARACTER,DIMENSION(:,:), POINTER :: idOOC_FILE_NAMES INTEGER :: idKEEP(500) CHARACTER(len=1):: TMP_NAME(FILENAMELENGTH) INTEGER I,I1,TMP,J,K,L,DIM,IERR INTEGER, DIMENSION(:),ALLOCATABLE :: NB_FILES ALLOCATE(NB_FILES(OOC_NB_FILE_TYPE),stat=IERR) IF (IERR .GT. 0) THEN IERR=-1 IF(idINFO(1).GE.0)THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) & 'PB allocation in CMUMPS_OOC_OPEN_FILES_FOR_SOLVE' ENDIF idINFO(1) = -13 idINFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF ENDIF IERR=0 NB_FILES=idOOC_NB_FILES I=idMYID K=idKEEP(35) L=mod(idKEEP(204),3) 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) idINFO(1)=IERR RETURN ENDIF CALL MUMPS_OOC_INIT_VARS_C(I,K,L,idKEEP(211),idKEEP(255),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) idINFO(1)=IERR RETURN ENDIF K=1 DO I1=1,OOC_NB_FILE_TYPE DO I=1,NB_FILES(I1) DIM=idOOC_FILE_NAME_LENGTH(K) DO J=1,DIM TMP_NAME(J)=idOOC_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) idINFO(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) idINFO(1)=IERR RETURN ENDIF DEALLOCATE(NB_FILES) RETURN END SUBROUTINE CMUMPS_OOC_OPEN_FILES_FOR_SOLVE SUBROUTINE CMUMPS_FORCE_WRITE_BUF(IERR) USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF CALL CMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF (IERR < 0) THEN RETURN ENDIF RETURN END SUBROUTINE CMUMPS_FORCE_WRITE_BUF SUBROUTINE CMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR INTEGER I IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF DO I=1,OOC_NB_FILE_TYPE CALL CMUMPS_OOC_DO_IO_AND_CHBUF(I,IERR) IF (IERR < 0) RETURN ENDDO RETURN END SUBROUTINE CMUMPS_OOC_FORCE_WRT_BUF_PANEL SUBROUTINE CMUMPS_SOLVE_STAT_REINIT_PANEL(NSTEPS, & KEEP38, KEEP20) IMPLICIT NONE INTEGER NSTEPS INTEGER I, J INTEGER(8) :: TMP_SIZE8 INTEGER KEEP38, KEEP20 INODE_TO_POS = 0 POS_IN_MEM = 0 OOC_STATE_NODE(1:NSTEPS)=0 TMP_SIZE8=1_8 J=1 DO I=1,NB_Z-1 IDEB_SOLVE_Z(I)=TMP_SIZE8 PDEB_SOLVE_Z(I)=J POSFAC_SOLVE(I)=TMP_SIZE8 LRLUS_SOLVE(I) =SIZE_ZONE_SOLVE LRLU_SOLVE_T(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_B(I)=0_8 SIZE_SOLVE_Z(I)=SIZE_ZONE_SOLVE CURRENT_POS_T(I)=J CURRENT_POS_B(I)=J POS_HOLE_T(I) =J POS_HOLE_B(I) =J J = J + MAX_NB_NODES_FOR_ZONE TMP_SIZE8 = TMP_SIZE8 + SIZE_ZONE_SOLVE ENDDO IDEB_SOLVE_Z(NB_Z)=TMP_SIZE8 PDEB_SOLVE_Z(NB_Z)=J POSFAC_SOLVE(NB_Z)=TMP_SIZE8 LRLUS_SOLVE(NB_Z) =SIZE_SOLVE_EMM LRLU_SOLVE_T(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_B(NB_Z)=0_8 SIZE_SOLVE_Z(NB_Z)=SIZE_SOLVE_EMM CURRENT_POS_T(NB_Z)=J CURRENT_POS_B(NB_Z)=J POS_HOLE_T(NB_Z) =J POS_HOLE_B(NB_Z) =J IO_REQ=-77777 SIZE_OF_READ=-9999_8 FIRST_POS_IN_READ=-9999 READ_DEST=-9999_8 READ_MNG=-9999 REQ_TO_ZONE=-9999 REQ_ID=-9999 RETURN END SUBROUTINE CMUMPS_SOLVE_STAT_REINIT_PANEL SUBROUTINE CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) IMPLICIT NONE TYPE(IO_BLOCK), INTENT(INOUT):: MonBloc INTEGER(8) :: LAFAC INTEGER, INTENT(IN) :: STRAT, LIWFAC, & MYID, TYPEFile INTEGER, INTENT(INOUT) :: IW(0:LIWFAC-1) COMPLEX, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LNextPiv2beWritten, & UNextPiv2beWritten INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL INTEGER(8) :: TMPSIZE_OF_BLOCK INTEGER :: TempFTYPE LOGICAL WRITE_L, WRITE_U LOGICAL DO_U_FIRST INCLUDE 'mumps_headers.h' IERR = 0 IF (KEEP_OOC(50).EQ.0 & .AND.KEEP_OOC(251).EQ.2) THEN WRITE_L = .FALSE. ELSE WRITE_L = (TYPEFile.EQ.TYPEF_BOTH_LU .OR. TYPEFile.EQ.TYPEF_L) ENDIF WRITE_U = (TYPEFile.EQ.TYPEF_BOTH_LU .OR. TYPEFile.EQ.TYPEF_U) #if defined(_OPENMP) IF (KEEP_OOC(400).GT.0 .AND. KEEP_OOC(405) .GT. 0) THEN IF ( STRAT .EQ. STRAT_WRITE_MAX .OR. LAST_CALL ) THEN CALL OMP_SET_LOCK(LOCK_FOR_L0OMP) #if defined(_WIN32) ELSE #else ELSE IF ( .NOT. OMP_TEST_LOCK(LOCK_FOR_L0OMP )) THEN #endif RETURN ENDIF ENDIF #endif DO_U_FIRST = .FALSE. IF ( TYPEFile.EQ.TYPEF_BOTH_LU ) THEN IF ( LNextPiv2beWritten .GT. UNextPiv2beWritten ) THEN DO_U_FIRST = .TRUE. END IF END IF IF (DO_U_FIRST) GOTO 200 100 IF (WRITE_L .AND. TYPEF_L > 0 ) THEN TempFTYPE = TYPEF_L IF ((MonBloc%Typenode.EQ.2).AND.(.NOT.MonBloc%MASTER)) & THEN TMPSIZE_OF_BLOCK = SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE), & TempFTYPE) IF (TMPSIZE_OF_BLOCK .LT. 0_8) THEN TMPSIZE_OF_BLOCK = -TMPSIZE_OF_BLOCK - 1_8 ENDIF LNextPiv2beWritten = & int( & TMPSIZE_OF_BLOCK & / int(MonBloc%NROW,8) & ) & + 1 ENDIF CALL CMUMPS_OOC_STORE_LorU( STRAT, & TempFTYPE, AFAC, LAFAC, MonBloc, & IERR, & LNextPiv2beWritten, & OOC_VADDR(STEP_OOC(MonBloc%INODE),TempFTYPE), & SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE),TempFTYPE), & FILESIZE, LAST_CALL ) IF (IERR .LT. 0) GOTO 300 IF (DO_U_FIRST) GOTO 300 ENDIF 200 IF (WRITE_U) THEN TempFTYPE = TYPEF_U CALL CMUMPS_OOC_STORE_LorU( STRAT, & TempFTYPE, AFAC, LAFAC, MonBloc, & IERR, & UNextPiv2beWritten, & OOC_VADDR(STEP_OOC(MonBloc%INODE),TempFTYPE), & SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE),TempFTYPE), & FILESIZE, LAST_CALL) IF (IERR .LT. 0) GOTO 300 IF (DO_U_FIRST) GOTO 100 ENDIF 300 CONTINUE #if defined(_OPENMP) IF (KEEP_OOC(400).GT.0 .AND. KEEP_OOC(405) .GT. 0) THEN CALL OMP_UNSET_LOCK(LOCK_FOR_L0OMP) ENDIF #endif RETURN END SUBROUTINE CMUMPS_OOC_IO_LU_PANEL SUBROUTINE CMUMPS_OOC_STORE_LorU( STRAT, TYPEF, & AFAC, LAFAC, MonBloc, & IERR, & LorU_NextPiv2beWritten, & LorU_AddVirtNodeI8, LorUSIZE_OF_BLOCK, & FILESIZE, LAST_CALL & ) USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, INTENT(IN) :: STRAT INTEGER, INTENT(IN) :: TYPEF INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER(8), INTENT(IN) :: LAFAC COMPLEX, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LorU_NextPiv2beWritten INTEGER(8), INTENT(INOUT) :: LorU_AddVirtNodeI8 INTEGER(8), INTENT(INOUT) :: LorUSIZE_OF_BLOCK TYPE(IO_BLOCK), INTENT(INOUT) :: MonBloc INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL INTEGER NNMAX INTEGER(8) :: TOTSIZE, EFFSIZE INTEGER(8) :: TailleEcrite INTEGER SIZE_PANEL INTEGER(8) :: AddVirtCour LOGICAL VIRT_ADD_RESERVED_BEF_CALL LOGICAL VIRTUAL_ADDRESS_JUST_RESERVED LOGICAL HOLE_PROCESSED_BEFORE_CALL LOGICAL TMP_ESTIM INTEGER ICUR, INODE_CUR INTEGER(8) :: ADDR_LAST IERR = 0 IF (TYPEF == TYPEF_L ) THEN NNMAX = MonBloc%NROW ELSE NNMAX = MonBloc%NCOL ENDIF SIZE_PANEL = CMUMPS_OOC_PANEL_SIZE(NNMAX) IF ( (.NOT.MonBloc%Last) .AND. & (MonBloc%LastPiv-LorU_NextPiv2beWritten+1.LT.SIZE_PANEL)) & THEN RETURN ENDIF TMP_ESTIM = .TRUE. TOTSIZE = CMUMPS_OOC_NBENTRIES_PANEL_123 & (MonBloc%NFS, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) IF (MonBloc%Last) THEN TMP_ESTIM=.FALSE. EFFSIZE = CMUMPS_OOC_NBENTRIES_PANEL_123 & (MonBloc%LastPiv, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) ELSE EFFSIZE = -1034039740327_8 ENDIF IF (MonBloc%Typenode.EQ.3.AND. MonBloc%NFS.NE.MonBloc%NCOL) THEN WRITE(*,*) 'Internal error in CMUMPS_OOC_STORE_LorU for type3', & MonBloc%NFS,MonBloc%NCOL CALL MUMPS_ABORT() ENDIF IF (MonBloc%Typenode.EQ.3.AND. TYPEF.NE.TYPEF_L) THEN WRITE(*,*) 'Internal error in CMUMPS_OOC_STORE_LorU,TYPEF=', & TYPEF, 'for typenode=3' CALL MUMPS_ABORT() ENDIF IF (MonBloc%Typenode.EQ.2.AND. & TYPEF.EQ.TYPEF_U.AND. & .NOT. MonBloc%MASTER ) THEN WRITE(*,*) 'Internal error in CMUMPS_OOC_STORE_LorU', & MonBloc%MASTER,MonBloc%Typenode, TYPEF CALL MUMPS_ABORT() ENDIF HOLE_PROCESSED_BEFORE_CALL = (LorUSIZE_OF_BLOCK .LT. 0_8) IF (HOLE_PROCESSED_BEFORE_CALL.AND.(.NOT.MonBloc%Last)) THEN WRITE(6,*) ' Internal error in CMUMPS_OOC_STORE_LorU ', & ' last is false after earlier calls with last=true' CALL MUMPS_ABORT() ENDIF IF (HOLE_PROCESSED_BEFORE_CALL) THEN LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 TOTSIZE = -99999999_8 ENDIF VIRTUAL_ADDRESS_JUST_RESERVED = .FALSE. VIRT_ADD_RESERVED_BEF_CALL = & ( LorUSIZE_OF_BLOCK .NE. 0_8 .OR. & HOLE_PROCESSED_BEFORE_CALL ) IF (MonBloc%Last .AND. .NOT. HOLE_PROCESSED_BEFORE_CALL) THEN KEEP_OOC(228) = max(KEEP_OOC(228), & (MonBloc%LastPiv+SIZE_PANEL-1) / SIZE_PANEL) IF (VIRT_ADD_RESERVED_BEF_CALL) THEN IF (AddVirtLibre(TYPEF).EQ. & (LorU_AddVirtNodeI8+TOTSIZE) ) THEN AddVirtLibre(TYPEF) = LorU_AddVirtNodeI8 + EFFSIZE ENDIF ELSE VIRTUAL_ADDRESS_JUST_RESERVED = .TRUE. IF (EFFSIZE .EQ. 0_8) THEN LorU_AddVirtNodeI8 = -9999_8 ELSE LorU_AddVirtNodeI8 = AddVirtLibre(TYPEF) ENDIF AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) + EFFSIZE ENDIF ELSE IF (.NOT. VIRT_ADD_RESERVED_BEF_CALL & ) THEN LorU_AddVirtNodeI8 = AddVirtLibre(TYPEF) AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) + TOTSIZE ENDIF ENDIF AddVirtCour = LorU_AddVirtNodeI8 + LorUSIZE_OF_BLOCK CALL CMUMPS_OOC_WRT_IN_PANELS_LorU( STRAT, TYPEF, MonBloc, & SIZE_PANEL, & AFAC, LAFAC, & LorU_NextPiv2beWritten, AddVirtCour, & TailleEcrite, & IERR ) IF ( IERR .LT. 0 ) RETURN LorUSIZE_OF_BLOCK = LorUSIZE_OF_BLOCK + TailleEcrite IF (LorUSIZE_OF_BLOCK.EQ.0_8 ) THEN IF ( .NOT. VIRT_ADD_RESERVED_BEF_CALL & .AND. .NOT. VIRTUAL_ADDRESS_JUST_RESERVED ) & THEN AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) - TOTSIZE LorU_AddVirtNodeI8 = 0_8 ENDIF ELSE IF (.NOT. VIRT_ADD_RESERVED_BEF_CALL ) THEN VIRTUAL_ADDRESS_JUST_RESERVED = .TRUE. ENDIF IF ( VIRTUAL_ADDRESS_JUST_RESERVED) THEN OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(TYPEF), & TYPEF) = MonBloc%INODE I_CUR_HBUF_NEXTPOS(TYPEF) = I_CUR_HBUF_NEXTPOS(TYPEF) + 1 IF (MonBloc%Last) THEN MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,EFFSIZE) TMP_SIZE_FACT=TMP_SIZE_FACT+EFFSIZE ELSE MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,TOTSIZE) TMP_SIZE_FACT=TMP_SIZE_FACT+TOTSIZE ENDIF TMP_NB_NODES=TMP_NB_NODES+1 IF(TMP_SIZE_FACT.GT.SIZE_ZONE_SOLVE)THEN MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE, & TMP_NB_NODES) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 ENDIF ENDIF IF (MonBloc%Last) THEN LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 ENDIF IF (LAST_CALL) THEN IF (.NOT.MonBloc%Last) THEN WRITE(6,*) ' Internal error in CMUMPS_OOC_STORE_LorU ', & ' LAST and LAST_CALL are incompatible ' CALL MUMPS_ABORT() ENDIF LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 ICUR = I_CUR_HBUF_NEXTPOS(TYPEF) - 1 INODE_CUR = OOC_INODE_SEQUENCE(ICUR,TYPEF) ADDR_LAST = AddVirtLibre(TYPEF) IF ( INODE_CUR .NE. MonBloc%INODE .AND. & OOC_VADDR(STEP_OOC(MonBloc%INODE),TYPEF) .NE. -9999 ) THEN 10 CONTINUE IF ( OOC_VADDR(STEP_OOC(INODE_CUR),TYPEF) .NE. -9999_8) THEN ADDR_LAST = OOC_VADDR(STEP_OOC(INODE_CUR), TYPEF) ENDIF ICUR = ICUR - 1 INODE_CUR = OOC_INODE_SEQUENCE(ICUR,TYPEF) IF (INODE_CUR .EQ. MonBloc%INODE) THEN LorUSIZE_OF_BLOCK = ADDR_LAST - & OOC_VADDR(STEP_OOC(INODE_CUR),TYPEF) ELSE IF (ICUR .LE. 1) THEN WRITE(*,*) "Internal error in CMUMPS_OOC_STORE_LorU" WRITE(*,*) "Did not find current node in sequence" CALL MUMPS_ABORT() ENDIF GOTO 10 ENDIF ENDIF FILESIZE = FILESIZE + LorUSIZE_OF_BLOCK ENDIF RETURN END SUBROUTINE CMUMPS_OOC_STORE_LorU SUBROUTINE CMUMPS_OOC_WRT_IN_PANELS_LorU( & STRAT, TYPEF, MonBloc, & SIZE_PANEL, & AFAC, LAFAC, & NextPiv2beWritten, AddVirtCour, & TailleEcrite, IERR ) USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, INTENT(IN) :: STRAT, TYPEF, SIZE_PANEL INTEGER(8) :: LAFAC INTEGER(8), INTENT(IN) :: AddVirtCour COMPLEX, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: NextPiv2beWritten TYPE(IO_BLOCK),INTENT(INOUT) :: MonBloc INTEGER(8), INTENT(OUT) :: TailleEcrite INTEGER, INTENT(OUT) :: IERR INTEGER :: I, NBeff, LPANELeff, IEND INTEGER(8) :: AddVirtDeb IERR = 0 TailleEcrite = 0_8 AddVirtDeb = AddVirtCour I = NextPiv2beWritten IF ( NextPiv2beWritten .GT. MonBloc%LastPiv ) THEN RETURN ENDIF 10 CONTINUE NBeff = min(SIZE_PANEL,MonBloc%LastPiv-I+1 ) IF ((NBeff.NE.SIZE_PANEL) .AND. (.NOT.MonBloc%Last)) THEN GOTO 20 ENDIF IF (TYPEF.EQ.TYPEF_L.AND.MonBloc%MASTER.AND. & KEEP_OOC(50).EQ.2 .AND. MonBloc%Typenode.NE.3) THEN IF (MonBloc%INDICES(NBeff+I-1) < 0) & THEN NBeff=NBeff+1 ENDIF ENDIF IEND = I + NBeff -1 CALL CMUMPS_COPY_LU_TO_BUFFER( STRAT, TYPEF, MonBloc, & AFAC, LAFAC, & AddVirtDeb, I, IEND, LPANELeff, & IERR) IF ( IERR .LT. 0 ) THEN RETURN ENDIF IF ( IERR .EQ. 1 ) THEN IERR=0 GOTO 20 ENDIF IF (TYPEF .EQ. TYPEF_L) THEN MonBloc%LastPanelWritten_L = MonBloc%LastPanelWritten_L+1 ELSE MonBloc%LastPanelWritten_U = MonBloc%LastPanelWritten_U+1 ENDIF AddVirtDeb = AddVirtDeb + int(LPANELeff,8) TailleEcrite = TailleEcrite + int(LPANELeff,8) I=I+NBeff IF ( I .LE. MonBloc%LastPiv ) GOTO 10 20 CONTINUE NextPiv2beWritten = I RETURN END SUBROUTINE CMUMPS_OOC_WRT_IN_PANELS_LorU INTEGER(8) FUNCTION CMUMPS_OOC_NBENTRIES_PANEL_123 & (NFSorNPIV, NNMAX, SIZE_PANEL, MonBloc, ESTIM) IMPLICIT NONE TYPE(IO_BLOCK), INTENT(IN):: MonBloc INTEGER, INTENT(IN) :: NFSorNPIV, NNMAX, SIZE_PANEL LOGICAL, INTENT(IN) :: ESTIM INTEGER :: I, NBeff INTEGER(8) :: TOTSIZE TOTSIZE = 0_8 IF (NFSorNPIV.EQ.0) GOTO 100 IF (.NOT. MonBloc%MASTER .OR. MonBloc%Typenode.EQ.3) THEN TOTSIZE = int(NFSorNPIV,8) * int(NNMAX,8) ELSE I = 1 10 CONTINUE NBeff = min(SIZE_PANEL, NFSorNPIV-I+1) IF (KEEP_OOC(50).EQ.2) THEN IF (ESTIM) THEN NBeff = NBeff + 1 ELSE IF (MonBloc%INDICES(I+NBeff-1) < 0) THEN NBeff = NBeff + 1 ENDIF ENDIF ENDIF TOTSIZE = TOTSIZE + & int(NNMAX-I+1,8) * int(NBeff,8) I = I + NBeff IF ( I .LE. NFSorNPIV ) GOTO 10 ENDIF 100 CONTINUE CMUMPS_OOC_NBENTRIES_PANEL_123 = TOTSIZE RETURN END FUNCTION CMUMPS_OOC_NBENTRIES_PANEL_123 INTEGER FUNCTION CMUMPS_OOC_PANEL_SIZE( NNMAX ) IMPLICIT NONE INTEGER, INTENT(IN) :: NNMAX INTEGER CMUMPS_OOC_GET_PANEL_SIZE CMUMPS_OOC_PANEL_SIZE=CMUMPS_OOC_GET_PANEL_SIZE( & int(KEEP_OOC(223),8), NNMAX, KEEP_OOC(227),KEEP_OOC(50)) RETURN END FUNCTION CMUMPS_OOC_PANEL_SIZE SUBROUTINE CMUMPS_OOC_SKIP_NULL_SIZE_NODE() IMPLICIT NONE INTEGER I,TMP_NODE IF(.NOT.CMUMPS_SOLVE_IS_END_REACHED())THEN IF(SOLVE_STEP.EQ.0)THEN I=CUR_POS_SEQUENCE TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE ((I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)).AND. & (SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) & .EQ.0_8)) INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I+1 IF(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ENDIF ENDDO CUR_POS_SEQUENCE=min(I,TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) ELSE I=CUR_POS_SEQUENCE TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE ((I.GE.1).AND. & (SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) & .EQ.0_8)) INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I-1 IF(I.GE.1)THEN TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ENDIF ENDDO CUR_POS_SEQUENCE=max(I,1) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_OOC_SKIP_NULL_SIZE_NODE SUBROUTINE CMUMPS_OOC_SET_STATES_ES(N,KEEP201, & Pruned_List,nb_prun_nodes,STEP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP201, nb_prun_nodes INTEGER, INTENT(IN) :: STEP(N), & Pruned_List(nb_prun_nodes) INTEGER I, ISTEP IF (KEEP201 .GT. 0) THEN OOC_STATE_NODE(:) = ALREADY_USED DO I = 1, nb_prun_nodes ISTEP = STEP(Pruned_List(I)) OOC_STATE_NODE(ISTEP) = NOT_IN_MEM ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_OOC_SET_STATES_ES END MODULE CMUMPS_OOC MUMPS_5.8.1/src/zsol_lr.F0000664000175000017500000010330015042446441015021 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_SOL_LR USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_CORE USE MUMPS_LR_STATS USE ZMUMPS_LR_DATA_M, only: BLR_ARRAY IMPLICIT NONE CONTAINS SUBROUTINE ZMUMPS_SOL_FWD_LR_SU & (INODE, N, IWHDLR, NPIV_GLOBAL, NSLAVES, & IW, IPOS_INIT, LIW, & LIELL, WCB, LWCB, & LD_WCBPIV, LD_WCBCB, & PPIV_INIT, PCB_INIT, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, KEEP8, OOCWRITE_COMPATIBLE_WITH_BLR, & IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, N, IWHDLR, NPIV_GLOBAL, NSLAVES INTEGER, INTENT(IN) :: MTYPE, LIELL, KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: LIW, IPOS_INIT, LRHSINTR INTEGER, INTENT(IN) :: IW(LIW), POSINRHSINTR_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, PPIV_INIT, PCB_INIT INTEGER, INTENT(IN) :: LD_WCBPIV, LD_WCBCB, NRHS, JBDEB, JBFIN COMPLEX(kind=8), INTENT(INOUT) :: WCB(LWCB) INTEGER, INTENT(INOUT) :: IFLAG, IERROR COMPLEX(kind=8), INTENT(INOUT) :: RHSINTR(LRHSINTR, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: I, NPARTSASS, NB_BLR , NELIM, LDADIAG, & DIAGSIZ_DYN, DIAGSIZ_STA, IBEG_BLR, IEND_BLR, & LD_CB, NRHS_B, IPOS, KCB INTEGER(8) :: PPIV, PCB INTEGER :: LAST_BLR COMPLEX(kind=8), POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) NRHS_B = JBFIN-JBDEB+1 IF (MTYPE.EQ.1) THEN IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ELSE WRITE(6,*) " Internal error in ZMUMPS_SOL_FWD_SU_MASTER" ENDIF ELSE IF (associated(BLR_ARRAY(IWHDLR)%PANELS_U)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_U) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ENDIF ENDIF IF (NSLAVES.EQ.0 .OR. (KEEP(50).eq.0 .and. MTYPE .NE.1)) THEN LAST_BLR = NB_BLR ELSE LAST_BLR = NPARTSASS ENDIF IPOS = IPOS_INIT PPIV = PPIV_INIT DO I=1, NPARTSASS IBEG_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I) IEND_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) -1 DIAGSIZ_DYN = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) - & IBEG_BLR DIAGSIZ_STA = BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(I+1) - & IBEG_BLR IF (KEEP(50).NE.0) THEN LDADIAG = DIAGSIZ_DYN ELSE LDADIAG = DIAGSIZ_STA ENDIF IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN PCB = PCB_INIT ELSE PCB = PPIV + int(DIAGSIZ_DYN,8) ENDIF IF ( DIAGSIZ_DYN.EQ.0) CYCLE NELIM = DIAGSIZ_STA - DIAGSIZ_DYN IF ( MTYPE .EQ. 1 ) THEN BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL ELSE BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_U(I)%LRB_PANEL END IF DIAG => BLR_ARRAY(IWHDLR)%DIAG_BLOCKS(I)%DIAG_BLOCK CALL ZMUMPS_SOLVE_FWD_TRSOLVE (DIAG(1), & int(size(DIAG),8), 1_8, & DIAGSIZ_DYN , LDADIAG, NRHS_B, WCB, LWCB, NPIV_GLOBAL, & PPIV, MTYPE, KEEP) IF (NELIM.GT.0) THEN KCB = int(PCB-PPIV_INIT+1) IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN LD_CB = LD_WCBCB ELSE LD_CB = LD_WCBPIV ENDIF IF (MTYPE.EQ.1) THEN IF (KCB.LE.NPIV_GLOBAL .AND. & KCB+NELIM-1.GT.NPIV_GLOBAL) THEN CALL zgemm('T', 'N', NPIV_GLOBAL-KCB+1, NRHS_B, & DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) CALL zgemm('T', 'N', KCB+NELIM-NPIV_GLOBAL-1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG + & (NPIV_GLOBAL-KCB+1)*DIAGSIZ_DYN), & DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB_INIT), LD_WCBCB) ELSE CALL zgemm('T', 'N', NELIM, NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) ENDIF ELSE IF (KCB.LE.NPIV_GLOBAL .AND. & KCB+NELIM-1.GT.NPIV_GLOBAL) THEN CALL zgemm('N', 'N', NPIV_GLOBAL-KCB+1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) CALL zgemm('N', 'N', KCB+NELIM-NPIV_GLOBAL-1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN+NPIV_GLOBAL-KCB+1), & DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB_INIT), LD_WCBCB) ELSE CALL zgemm('N', 'N', NELIM, NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) ENDIF ENDIF ENDIF CALL ZMUMPS_SOL_FWD_BLR_UPDATE ( & WCB, LWCB, 1, LD_WCBPIV, PPIV_INIT, 1, & WCB, LWCB, LD_WCBCB, PCB_INIT, & PPIV, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, LAST_BLR, I, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC, & KEEP8, KEEP(34), & KEEP(448), KEEP(450), KEEP(451), & .FALSE., & IFLAG, IERROR) IF (IFLAG.LT.0) RETURN CALL ZMUMPS_SOL_LD_AND_RELOAD_PANEL ( & INODE, N, DIAGSIZ_DYN, LIELL, NELIM, NSLAVES, & PPIV, & IW, IPOS, LIW, & DIAG(1), int(size(DIAG),8), 1_8, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & .TRUE. & ) PPIV = PPIV + int(DIAGSIZ_DYN,8) IPOS = IPOS + DIAGSIZ_DYN ENDDO RETURN END SUBROUTINE ZMUMPS_SOL_FWD_LR_SU SUBROUTINE ZMUMPS_SOL_SLAVE_LR_U & (INODE, IWHDLR, NPIV_GLOBAL, & WCB, LWCB, & LDX, LDY, & PTRX_INIT, PTRY_INIT, & JBDEB, JBFIN, & MTYPE, KEEP, KEEP8, IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, IWHDLR, NPIV_GLOBAL INTEGER, INTENT(IN) :: MTYPE, KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER(8), INTENT(IN) :: LWCB, PTRX_INIT, PTRY_INIT INTEGER, INTENT(IN) :: LDX, LDY, JBDEB, JBFIN COMPLEX(kind=8), INTENT(INOUT) :: WCB(LWCB) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, NPARTSASS, NB_BLR , NRHS_B INTEGER(8) :: PTRX, PTRY TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) NRHS_B = JBFIN-JBDEB+1 IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) NB_BLR = NB_BLR - 2 ELSE WRITE(6,*) " Internal error 1 in ZMUMPS_SOL_SLAVE_LR_U" CALL MUMPS_ABORT() ENDIF PTRX = PTRX_INIT PTRY = PTRY_INIT DO I = 1, NPARTSASS BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL IF (associated(BLR_PANEL)) THEN IF (MTYPE.EQ.1) THEN CALL ZMUMPS_SOL_FWD_BLR_UPDATE ( & WCB, LWCB, 1, LDX, -99999_8, 1, & WCB, LWCB, LDY, PTRY, & PTRX, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, NB_BLR, 0, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(2:NB_BLR+2), & KEEP8, KEEP(34), & KEEP(448), KEEP(450), KEEP(451), & .TRUE., IFLAG, IERROR ) ELSE CALL ZMUMPS_SOL_BWD_BLR_UPDATE ( & WCB, LWCB, 1, LDY, -99999_8, 1, & WCB, LWCB, LDX, PTRX, & PTRY, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, NB_BLR, 0, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(2:NB_BLR+2), & KEEP8, KEEP(34), & KEEP(448), KEEP(450), KEEP(451), & .TRUE., & IFLAG, IERROR ) ENDIF IF (MTYPE .EQ. 1) THEN PTRX = PTRX + BLR_PANEL(1)%N ELSE PTRY = PTRY + BLR_PANEL(1)%N ENDIF IF (IFLAG.LT.0) RETURN ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_SOL_SLAVE_LR_U SUBROUTINE GEMM_Q_FWD(m, nrhs_b, k, npiv, & Q, TMP, ldT, & arraypiv, ldpiv, arraycb, lcb, ldcb, & ibeg_block, iend_block, is_t2_slave, & poscb, pospiv, pospivcol, ibeg_tmp) implicit none integer, intent(in) :: m, nrhs_b, k, npiv COMPLEX(kind=8), dimension(:,:), intent(inout) :: Q COMPLEX(kind=8), dimension(ldt, *), intent(inout) :: TMP integer(8), intent(in) :: lcb integer, intent(in) :: ldpiv COMPLEX(kind=8), intent(inout) :: arraypiv(ldpiv,*) COMPLEX(kind=8), intent(inout) :: arraycb(lcb) integer, intent(in) :: ldt, ldcb integer, intent(in) :: ibeg_block, iend_block logical, intent(in) :: is_t2_slave integer(8), intent(in) :: poscb, pospiv integer, intent(in) :: pospivcol integer, intent(in) :: ibeg_tmp integer :: posblock COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL zgemm('N', 'N', M, NRHS_B, K, MONE, & Q(1,1), M, TMP(ibeg_tmp,1), LDT, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND. & IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('N', 'N', NPIV-IBEG_BLOCK+1,NRHS_B, K, & MONE, Q(1,1), M, TMP(ibeg_tmp,1), LDT, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL zgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, & NRHS_B, K, & MONE, Q(NPIV-IBEG_BLOCK+2,1), M, & TMP(ibeg_tmp,1), LDT, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('N', 'N', M, NRHS_B, K, MONE, & Q(1,1), M, TMP(ibeg_tmp,1), LDT, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL zgemm('N', 'N', M, NRHS_B, K, MONE, & Q(1,1), M, TMP(ibeg_tmp,1), LDT, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF RETURN END SUBROUTINE GEMM_Q_FWD SUBROUTINE GEMM_Q_BWD(m, nrhs_b, k, npiv, & Q, TMP, ldT, & arraypiv, lpiv, ldpiv, arraycb, lcb, ldcb, & ibeg_block, iend_block, is_t2_slave, & poscb, pospiv, pospivcol, ibeg_tmp) implicit none integer, intent(in) :: m, nrhs_b, k, npiv COMPLEX(kind=8), dimension(:, :), intent(inout) :: Q COMPLEX(kind=8), dimension(ldt, *), intent(inout) :: TMP integer(8), intent(in) :: lcb, lpiv COMPLEX(kind=8), intent(inout) :: arraypiv(lpiv,*) COMPLEX(kind=8), intent(inout) :: arraycb(lcb) integer, intent(in) :: ldt, ldcb, ldpiv integer, intent(in) :: ibeg_block, iend_block logical, intent(in) :: is_t2_slave integer(8), intent(in) :: poscb, pospiv integer, intent(in) :: pospivcol integer, intent(in) :: ibeg_tmp integer(8) :: posblock COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB +int(IBEG_BLOCK-1,8) CALL zgemm('T', 'N', K, NRHS_B, M, ONE, & Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TMP(ibeg_tmp,1), ldt) ELSEIF (IBEG_BLOCK.LE.NPIV.AND. & IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('T', 'N', K, NRHS_B, & NPIV-IBEG_BLOCK+1, & ONE, Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TMP(ibeg_tmp, 1), ldt) CALL zgemm('T', 'N', & K, NRHS_B, IBEG_BLOCK+M-NPIV-1, & ONE, Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYCB(POSCB), LDCB, & ONE, & TMP(ibeg_tmp,1), ldt) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('T', 'N', K, NRHS_B, M, ONE, & Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TMP(ibeg_tmp, 1), ldt) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL zgemm('T', 'N', K, NRHS_B, M, ONE, & Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TMP(ibeg_tmp, 1), ldt) ENDIF RETURN END SUBROUTINE GEMM_Q_BWD SUBROUTINE ZMUMPS_SOL_FWD_BLR_UPDATE ( & ARRAYPIV, LPIV, LPIVCOL, LDPIV, POSPIV, POSPIVCOL, & ARRAYCB, LCB, LDCB, POSCB, & POSDIAG, & NRHS_B, NPIV, & BLR_PANEL, LAST_BLR, & CURRENT_BLR, BEGS_BLR_STATIC, & KEEP8, K34, K448, K450, K451, IS_T2_SLAVE, IFLAG, IERROR ) !$ USE OMP_LIB INTEGER(8), INTENT(IN) :: LPIV, LCB, POSPIV, POSCB, POSDIAG INTEGER, INTENT(IN) :: LPIVCOL, POSPIVCOL COMPLEX(kind=8), INTENT(INOUT) :: ARRAYPIV(LPIV,LPIVCOL) COMPLEX(kind=8), INTENT(INOUT) :: ARRAYCB(LCB) INTEGER, INTENT(IN) :: LAST_BLR, NRHS_B, LDPIV, LDCB, & CURRENT_BLR, NPIV, K34, K448, K450, K451 TYPE(LRB_TYPE), TARGET,INTENT(IN) :: & BLR_PANEL(:) INTEGER :: BEGS_BLR_STATIC(:) LOGICAL, INTENT(IN) :: IS_T2_SLAVE INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, K, M, N, IBEG_BLOCK, IEND_BLOCK INTEGER :: KMAX INTEGER :: MMAX INTEGER(8) :: POSBLOCK INTEGER :: allocok TYPE(LRB_TYPE), POINTER :: LRB COMPLEX(kind=8), ALLOCATABLE,DIMENSION(:) :: TEMP_BLOCK COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) KMAX = -1 MMAX = -1 DO I = CURRENT_BLR+1, LAST_BLR KMAX = max(KMAX, BLR_PANEL(I-CURRENT_BLR)%K) MMAX = max(MMAX, BLR_PANEL(I-CURRENT_BLR)%M) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(TEMP_BLOCK, allocok !$OMP& ) #endif IF (KMAX.GT.0) THEN allocate(TEMP_BLOCK(KMAX*NRHS_B), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NRHS_B * KMAX write(*,*) 'Allocation problem in BLR routine & ZMUMPS_SOL_FWD_BLR_UPDATE for TEMP_BLOCK: ', & 'not enough memory? memory requested = ', IERROR ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif #if ! defined(BLR_NOOPENMP) !$OMP DO SCHEDULE(DYNAMIC,1) !$OMP& PRIVATE(IBEG_BLOCK, IEND_BLOCK, LRB, K, M, N, !$OMP& POSBLOCK) #endif DO I = CURRENT_BLR+1, LAST_BLR IF (IFLAG.LT.0) CYCLE IBEG_BLOCK = BEGS_BLR_STATIC(I) IEND_BLOCK = BEGS_BLR_STATIC(I+1)-1 IF (IBEG_BLOCK .EQ. IEND_BLOCK + 1) CYCLE LRB => BLR_PANEL(I-CURRENT_BLR) K = LRB%K M = LRB%M N = LRB%N IF (LRB%ISLR) THEN IF (K.GT.0) THEN CALL zgemm('N', 'N', K, NRHS_B, N, ONE, & LRB%R(1,1), K, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL zgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('N', 'N', NPIV-IBEG_BLOCK+1, NRHS_B, K, & MONE, LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL zgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, NRHS_B, K, & MONE, LRB%Q(NPIV-IBEG_BLOCK+2,1), M, TEMP_BLOCK(1), & K, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL zgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF ENDIF ELSE IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB + int(IBEG_BLOCK-1,8) CALL zgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('N', 'N', NPIV-IBEG_BLOCK+1, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL zgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, NRHS_B, N, MONE, & LRB%Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYPIV(POSDIAG,POSPIVCOL), & LDPIV, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB + int(IBEG_BLOCK-1-NPIV,8) CALL zgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF ENDIF ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif IF (KMAX.GT.0) THEN IF (allocated(TEMP_BLOCK)) deallocate(TEMP_BLOCK) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif RETURN END SUBROUTINE ZMUMPS_SOL_FWD_BLR_UPDATE SUBROUTINE ZMUMPS_SOL_BWD_LR_SU & ( INODE, IWHDLR, NPIV_GLOBAL, NSLAVES, & LIELL, WCB, LWCB, NRHS_B, PTWCB, & RHSINTR, LRHSINTR, NRHS, & IPOSINRHSINTR, JBDEB, & MTYPE, KEEP, KEEP8, & IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, IWHDLR, NPIV_GLOBAL, NSLAVES INTEGER, INTENT(IN) :: MTYPE, LIELL, KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IPOSINRHSINTR, JBDEB, LRHSINTR, NRHS INTEGER(8), INTENT(IN) :: LWCB, PTWCB INTEGER, INTENT(IN) :: NRHS_B INTEGER, INTENT(INOUT) :: IFLAG, IERROR COMPLEX(kind=8), INTENT(INOUT) :: WCB(LWCB) COMPLEX(kind=8) RHSINTR(LRHSINTR,NRHS) INTEGER :: I, NPARTSASS, NB_BLR, LAST_BLR, & NELIM_PANEL, LD_WCB, & DIAGSIZ_DYN, DIAGSIZ_STA, LDADIAG, & IEND_BLR, IBEG_BLR INTEGER(8) :: PWCB INTEGER :: IPIV_PANEL COMPLEX(kind=8), POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) IF ((MTYPE.EQ.1).AND.(KEEP(50).EQ.0)) THEN IF (associated(BLR_ARRAY(IWHDLR)%PANELS_U)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_U) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ENDIF ELSE IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ELSE WRITE(6,*) " Internal error in ZMUMPS_SOL_FWD_SU_MASTER" ENDIF ENDIF PWCB = PTWCB + int(NPIV_GLOBAL,8) LD_WCB = LIELL IF (KEEP(50).EQ.0 .AND. NSLAVES.GT.0 .AND. MTYPE.NE.1) THEN LAST_BLR = NPARTSASS ELSE LAST_BLR = NB_BLR ENDIF DO I=NPARTSASS,1,-1 IBEG_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I) IEND_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) -1 DIAGSIZ_DYN = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) - & IBEG_BLR DIAGSIZ_STA = BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(I+1) - & IBEG_BLR IF (KEEP(50).NE.0) THEN LDADIAG = DIAGSIZ_DYN ELSE LDADIAG = DIAGSIZ_STA ENDIF IF (DIAGSIZ_DYN.EQ.0) GOTO 1000 NELIM_PANEL = DIAGSIZ_STA - DIAGSIZ_DYN IPIV_PANEL = IPOSINRHSINTR + IBEG_BLR -1 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_U(I)%LRB_PANEL ELSE BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL END IF CALL ZMUMPS_SOL_BWD_BLR_UPDATE ( & RHSINTR, int(LRHSINTR,8), NRHS, LRHSINTR, & int(IPOSINRHSINTR,8), JBDEB, & WCB, LWCB, LD_WCB, PWCB, & int(IPIV_PANEL,8), & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, LAST_BLR, & I, BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC, & KEEP8, KEEP(34), & KEEP(448), KEEP(450), KEEP(451), & .FALSE., & IFLAG, IERROR) IF (IFLAG.LT.0) RETURN DIAG => BLR_ARRAY(IWHDLR)%DIAG_BLOCKS(I)%DIAG_BLOCK IF (NELIM_PANEL.GT.0) THEN IF (MTYPE.EQ.1.AND.KEEP(50).EQ.0) THEN IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN CALL zgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, WCB(PWCB), & LD_WCB, ONE , RHSINTR(IPIV_PANEL,JBDEB),LRHSINTR) ELSE IF (IEND_BLR+1.LE.NPIV_GLOBAL .AND. & IEND_BLR+NELIM_PANEL.GT.NPIV_GLOBAL) THEN CALL zgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, & NPIV_GLOBAL-IEND_BLR, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & RHSINTR(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSINTR, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) CALL zgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, & IEND_BLR+NELIM_PANEL-NPIV_GLOBAL, & MONE, DIAG(1+DIAGSIZ_DYN+NPIV_GLOBAL-IEND_BLR), & DIAGSIZ_STA, & WCB(PWCB), LD_WCB, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ELSE CALL zgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & RHSINTR(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSINTR, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ENDIF ENDIF ELSE IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN CALL zgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PWCB), LD_WCB, ONE, & RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ELSE IF (IEND_BLR+1.LE.NPIV_GLOBAL .AND. & IEND_BLR+NELIM_PANEL.GT.NPIV_GLOBAL) THEN CALL zgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, & NPIV_GLOBAL-IEND_BLR, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & RHSINTR(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSINTR, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) CALL zgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, & IEND_BLR+NELIM_PANEL-NPIV_GLOBAL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG + & (NPIV_GLOBAL-IEND_BLR)*DIAGSIZ_DYN), & DIAGSIZ_DYN, & WCB(PWCB), LD_WCB, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ELSE CALL zgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & RHSINTR(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSINTR, & ONE, RHSINTR(IPIV_PANEL,JBDEB), LRHSINTR) ENDIF ENDIF ENDIF ENDIF IF (IFLAG.LT.0) RETURN CALL ZMUMPS_SOLVE_BWD_LR_TRSOLVE ( & DIAG(1), size(DIAG), DIAGSIZ_DYN, NELIM_PANEL, LIELL, & NRHS_B, WCB, LWCB, & RHSINTR, LRHSINTR, NRHS, & IPIV_PANEL, JBDEB, & MTYPE, KEEP ) 1000 CONTINUE ENDDO RETURN END SUBROUTINE ZMUMPS_SOL_BWD_LR_SU SUBROUTINE ZMUMPS_SOL_BWD_BLR_UPDATE ( & ARRAYPIV, LPIV, LPIVCOL, LDPIV, POSPIV, POSPIVCOL, & ARRAYCB, LCB, LDCB, POSCB, & POSDIAG, & NRHS_B, NPIV, & BLR_PANEL, LAST_BLR, CURRENT_BLR, & BEGS_BLR_STATIC, & KEEP8, K34, K448, K450, K451, IS_T2_SLAVE, & IFLAG, IERROR) !$ USE OMP_LIB INTEGER(8), INTENT(IN) :: LPIV, LCB, POSPIV, POSCB, POSDIAG INTEGER,INTENT(IN) :: LPIVCOL, POSPIVCOL COMPLEX(kind=8), INTENT(INOUT) :: ARRAYPIV(LPIV,LPIVCOL) COMPLEX(kind=8), INTENT(INOUT) :: ARRAYCB(LCB) INTEGER, INTENT(IN) :: LAST_BLR, NRHS_B, LDPIV, LDCB, & CURRENT_BLR, NPIV, K34, K448, K450, K451 TYPE(LRB_TYPE), TARGET,INTENT(IN) :: & BLR_PANEL(:) INTEGER(8), INTENT(IN) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_T2_SLAVE INTEGER :: BEGS_BLR_STATIC(:) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, K, M, N, IBEG_BLOCK, IEND_BLOCK INTEGER :: KMAX INTEGER(8) :: POSBLOCK TYPE(LRB_TYPE), POINTER :: LRB COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: TEMP_BLOCK COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: DEST_ARRAY INTEGER :: allocok COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) KMAX = -1 DO I = CURRENT_BLR+1, LAST_BLR KMAX = max(KMAX, BLR_PANEL(I-CURRENT_BLR)%K) ENDDO IF (CURRENT_BLR.LT.LAST_BLR) THEN N = BLR_PANEL(1)%N ELSE RETURN ENDIF allocate(DEST_ARRAY(N*NRHS_B),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = N * NRHS_B GOTO 100 ENDIF DEST_ARRAY = ZERO #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL PRIVATE(TEMP_BLOCK, allocok !$OMP& ) #endif IF (KMAX.GT.0) THEN allocate(TEMP_BLOCK(KMAX*NRHS_B), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NRHS_B * KMAX write(*,*) 'Allocation problem in BLR routine & ZMUMPS_SOL_BWD_BLR_UPDATE: ', & 'not enough memory? memory requested = ', IERROR ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP DO SCHEDULE(DYNAMIC,1) !$OMP& PRIVATE(IBEG_BLOCK, IEND_BLOCK, LRB, K, M, POSBLOCK) !$OMP& REDUCTION(+:DEST_ARRAY) #endif DO I = CURRENT_BLR+1, LAST_BLR IF (IFLAG.LT.0) CYCLE IBEG_BLOCK = BEGS_BLR_STATIC(I) IEND_BLOCK = BEGS_BLR_STATIC(I+1)-1 LRB => BLR_PANEL(I-CURRENT_BLR) K = LRB%K M = LRB%M IF (LRB%ISLR) THEN IF (K.GT.0) THEN IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB +int(IBEG_BLOCK-1,8) CALL zgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TEMP_BLOCK(1), K) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('T', 'N', K, NRHS_B, NPIV-IBEG_BLOCK+1, & ONE, LRB%Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) CALL zgemm('T', 'N', K, NRHS_B, IBEG_BLOCK+M-NPIV-1, & ONE, LRB%Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYCB(POSCB), LDCB, & ONE, & TEMP_BLOCK(1), K) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL zgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TEMP_BLOCK(1), K) ENDIF CALL zgemm('T', 'N', N, NRHS_B, K, MONE, & LRB%R(1,1), K, & TEMP_BLOCK(1), K, ONE, & DEST_ARRAY(1), N) ENDIF ELSE IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL zgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYCB(POSBLOCK), LDCB, & ONE, DEST_ARRAY(1), N) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('T', 'N', N, NRHS_B, NPIV-IBEG_BLOCK+1, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ONE, DEST_ARRAY(1), N) CALL zgemm('T', 'N', N, NRHS_B, IBEG_BLOCK+M-NPIV-1, MONE, & LRB%Q(NPIV-IBEG_BLOCK+2,1), M, ARRAYCB(POSCB), & LDCB, ONE, DEST_ARRAY(1), N) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ONE, DEST_ARRAY(1), N) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL zgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYCB(POSBLOCK), LDCB, & ONE, DEST_ARRAY(1), N) ENDIF ENDIF ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif IF (KMAX.GT.0) THEN IF (allocated(TEMP_BLOCK)) deallocate(TEMP_BLOCK) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IS_T2_SLAVE) THEN DO I=1,NRHS_B call zaxpy(N, ONE, DEST_ARRAY((I-1)*N+1), 1, & ARRAYPIV(POSDIAG+(I-1)*LDPIV,POSPIVCOL), 1) ENDDO ELSE DO I=1,NRHS_B call zaxpy(N, ONE, DEST_ARRAY((I-1)*N+1), 1, & ARRAYPIV(POSDIAG,POSPIVCOL+I-1), 1) ENDDO ENDIF 100 CONTINUE IF (allocated(DEST_ARRAY)) DEALLOCATE(DEST_ARRAY) RETURN END SUBROUTINE ZMUMPS_SOL_BWD_BLR_UPDATE END MODULE ZMUMPS_SOL_LR SUBROUTINE ZMUMPS_SOLVE_BWD_LR_TRSOLVE ( & DIAG, LDIAG, NPIV, NELIM, LIELL, & NRHS_B, W, LWC, & RHSINTR, LRHSINTR, NRHS, & PPIVINRHSINTR, JBDEB, & MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LIELL, NPIV, NELIM, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDIAG INTEGER, INTENT(IN) :: PPIVINRHSINTR, JBDEB, LRHSINTR, NRHS INTEGER(8), INTENT(IN) :: LWC COMPLEX(kind=8), INTENT(IN) :: DIAG(LDIAG) COMPLEX(kind=8), INTENT(INOUT) :: W(LWC) COMPLEX(kind=8) RHSINTR(LRHSINTR,NRHS) INTEGER :: LDAJ COMPLEX(kind=8) ONE PARAMETER ( ONE=(1.0D0,0.0D0) ) IF ( MTYPE .eq. 1 ) THEN LDAJ = NPIV + NELIM CALL ztrsm('L','L','T','N', NPIV, NRHS_B, ONE, DIAG(1), & LDAJ, RHSINTR(PPIVINRHSINTR,JBDEB), & LRHSINTR) ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=NPIV+NELIM ELSE LDAJ=NPIV ENDIF CALL ztrsm('L','U','N','U', NPIV, NRHS_B, ONE, DIAG(1), & LDAJ, RHSINTR(PPIVINRHSINTR,JBDEB), LRHSINTR) END IF RETURN END SUBROUTINE ZMUMPS_SOLVE_BWD_LR_TRSOLVE MUMPS_5.8.1/src/dfac_par_m.F0000664000175000017500000015266415042446440015430 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_PAR_M CONTAINS SUBROUTINE DMUMPS_FAC_PAR(N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NULLNEGPV, NB22T1, NB22T2, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & PTRIST, PTRAST, PIMASTER, PAMASTER, PTRARW, PTRAIW, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & MUMPS_TPS_ARR, DMUMPS_TPS_ARR, LTPS_ARR, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & NBROOT_UNDER_L0, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8, PROCNODE_STEPS, & SLAVEF,MYID, COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & INTARR, DBLARR, root, roota, PERM, NELT, FRTPTR, FRTELT, LPTRAR, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, & DKEEP, PIVNUL_LIST_STRUCT, LRGROUPS ) !$ USE OMP_LIB USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : & DMUMPS_DM_FREEALLDYNAMICCB USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_TEST USE MUMPS_LOAD USE DMUMPS_OOC, ONLY: DMUMPS_OOC_CLEAN_PENDING, & IO_BLOCK, & DMUMPS_OOC_FORCE_WRT_BUF_PANEL, & DMUMPS_NEW_FACTOR, & DMUMPS_OOC_IO_LU_PANEL, & DMUMPS_FORCE_WRITE_BUF USE MUMPS_OOC_COMMON, ONLY: TYPEF_L, STRAT_WRITE_MAX USE DMUMPS_FAC_ASM_MASTER_M USE DMUMPS_FAC_ASM_MASTER_ELT_M USE DMUMPS_FAC1_LDLT_M USE DMUMPS_FAC2_LDLT_M USE DMUMPS_FAC1_LU_M USE DMUMPS_FAC2_LU_M USE OMP_LIB USE MUMPS_TPS_M USE DMUMPS_TPS_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC USE MUMPS_PIVNUL_MOD IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80) DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI INTEGER, INTENT(INOUT) :: NELVA, COMP INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV, & NULLNEGPV INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP DOUBLE PRECISION, INTENT(INOUT) :: DET_MANT INTEGER(8) :: LA DOUBLE PRECISION, TARGET :: A(LA) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER LPOOL INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER IW(LIW), NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST(KEEP(28)), PERM(N) INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IPOOL(LPOOL) INTEGER NE(KEEP(28)) DOUBLE PRECISION RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU INTEGER IWPOS, LEAF, NBROOT, NBRTOT INTEGER, INTENT(in) :: NBROOT_UNDER_L0 INTEGER COMM_LOAD, ASS_IRECV DOUBLE PRECISION UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) LOGICAL IS_ISOLATED_NODE TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER LRGROUPS(KEEP(280)) INTEGER, INTENT( IN ) :: LTPS_ARR TYPE (MUMPS_TPS_T), TARGET :: MUMPS_TPS_ARR( LTPS_ARR ) TYPE (DMUMPS_TPS_T), TARGET :: DMUMPS_TPS_ARR( LTPS_ARR ) INTEGER, INTENT( IN ) :: LL0_OMP_MAPPING INTEGER, INTENT( IN ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 INTEGER INODE INTEGER IWPOSCB INTEGER FPERE, TYPEF INTEGER MP, LP, DUMMY(1) INTEGER NBFIN, NBROOT_TRAITEES INTEGER NFRONT, IOLDPS 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 !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 INTEGER LIWK_RR, PHASE, MBLOCK, NBLOCK INTEGER(8) :: LWK_RR INTEGER(8) :: I8 INTEGER I, K, KEEP17_LU INTEGER NOFFNEGPV_ROOT, NTOTPV_ROOT, NB22T1_ROOT, NBTINY_ROOT, & NULLNEGPV_ROOT, & DET_EXP_ROOT, DET_SIGN_ROOT, & LRecord, Header_ROOT(5) DOUBLE PRECISION DET_MANT_ROOT DOUBLE PRECISION DKEEP_SAVE(230) DOUBLE PRECISION, DIMENSION(:), POINTER :: A_ROOT_SAVE LOGICAL :: IS_A_ROOT_SAVE_ALLOCATED INTEGER, DIMENSION(:), ALLOCATABLE :: RECORD_ROOT INTEGER KEEP_SAVE(500) INTEGER(8) KEEP8_SAVE(150) EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE LOGICAL MUMPS_INSSARBR EXTERNAL MUMPS_INSSARBR LOGICAL DMUMPS_POOL_EMPTY EXTERNAL DMUMPS_POOL_EMPTY, DMUMPS_EXTRACT_POOL LOGICAL STACK_RIGHT_AUTHORIZED INTEGER, EXTERNAL :: MUMPS_NUMROC INTEGER JOBASS, ETATASS INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY INTEGER(8) :: ITMP8 TYPE(IO_BLOCK) :: MonBloc INCLUDE 'mumps_headers.h' INTEGER MPA DOUBLE PRECISION OPLAST_PRINTED DOUBLE PRECISION :: ROOTTIME INTEGER:: ITH DOUBLE PRECISION :: DUMMY_FLOP_ESTIM_ACC DUMMY_FLOP_ESTIM_ACC = 0.0d0 ITLOC(1:N+KEEP(253)) =0 ASS_IRECV = MPI_REQUEST_NULL MP = ICNTL(2) LP = ICNTL(1) IWPOSCB = LIW NULLIFY(BUFRX) IS_BUFRX_ALLOCATED = .FALSE. KEEP(143) = -1 KEEP17_LU = -1 NULLIFY(A_ROOT_SAVE) IS_A_ROOT_SAVE_ALLOCATED = .FALSE. IF ( INFO(1) .LT. 0 ) THEN GOTO 640 ENDIF OPLAST_PRINTED = DONE MPA = ICNTL(2) IF (ICNTL(4).LT.2) MPA=0 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) CALL DMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) STACK_RIGHT_AUTHORIZED = .TRUE. CALL DMUMPS_ALLOC_CB( .FALSE., 0_8, & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, DKEEP, & IW, LIW, A, LA, LRLU, IPTRLU, IWPOS, IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, LRLUS, KEEP8(67), & INFO(1), INFO(2) & ) JOBASS = 0 ETATASS = 0 NBFIN = NBRTOT NBROOT_TRAITEES = 0 KEEP(121)=0 IF ( KEEP(38).NE.0 ) THEN IF (root%yes) THEN CALL DMUMPS_ROOT_ALLOC_STATIC( & root, roota, KEEP(38), N, IW, LIW, & A, LA, & FILS, DAD, MYID_NODES, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, INFO(1), KEEP,KEEP8, DKEEP, INFO(2) ) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 635 END IF IF (KEEP(400).GT.0) THEN NBROOT_TRAITEES = NBROOT_UNDER_L0 IF (NBROOT_TRAITEES .GT.0) THEN IF (NBROOT_TRAITEES.EQ.NBROOT) THEN NBFIN = NBFIN - NBROOT IF (SLAVEF .GT. 1) THEN CALL DMUMPS_MCAST2( NBROOT, 1, MPI_INTEGER, & MYID_NODES, COMM_NODES, RACINE, SLAVEF, KEEP ) ENDIF ENDIF ENDIF IF (NBFIN .EQ. 0) GOTO 640 ENDIF KEEP(429)=0 20 CONTINUE CALL DMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 635 NIV1_FLAG=0 SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .FALSE. IF ( SLAVEF .GT. 1 ) THEN CALL DMUMPS_TRY_RECVTREAT( & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, & MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, & COMP, INFO(1), INFO(2), COMM_NODES, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, & root, roota, OPASS, OPELI, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED & , LRGROUPS & ) CALL MUMPS_LOAD_RECV_MSGS(COMM_LOAD) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (MESSAGE_RECEIVED) THEN IF ( INFO(1) .LT. 0 ) GO TO 640 IF ( NBFIN .eq. 0 ) GOTO 640 ELSE IF ( .NOT. DMUMPS_POOL_EMPTY( IPOOL, LPOOL) )THEN CALL DMUMPS_EXTRACT_POOL( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, STEP, INODE, KEEP,KEEP8, MYID_NODES, ND, & (.NOT. STACK_RIGHT_AUTHORIZED) ) STACK_RIGHT_AUTHORIZED = .TRUE. IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF IF (KEEP(47).EQ.4) THEN IF(INODE.GT.0.AND.INODE.LE.N)THEN IF((NE(STEP(INODE)).EQ.0).AND. & (FRERE(STEP(INODE)).EQ.0))THEN IS_ISOLATED_NODE=.TRUE. ELSE IS_ISOLATED_NODE=.FALSE. ENDIF ENDIF CALL MUMPS_LOAD_SBTR_UPD_NEW_POOL( & IS_ISOLATED_NODE,INODE,IPOOL,LPOOL, & MYID_NODES,SLAVEF,COMM_LOAD,KEEP,KEEP8) ENDIF IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. & ( KEEP(47) == 4 )).OR. & (KEEP(80) == 1 .AND. KEEP(47) .GE. 1)) THEN CALL MUMPS_UPPER_PREDICT(INODE,STEP,KEEP(28), & PROCNODE_STEPS,FRERE,ND,COMM_LOAD,SLAVEF, & MYID_NODES,KEEP,KEEP8,N) END IF GOTO 30 ELSE CALL MUMPS_BUF_TEST() ENDIF ENDIF GO TO 20 30 CONTINUE IF ( INODE .LT. 0 ) THEN INODE = -INODE FPERE = DAD(STEP(INODE)) GOTO 130 ELSE IF (INODE.GT.N) THEN INODE = INODE - N IF (INODE.EQ.KEEP(38)) THEN NBROOT_TRAITEES = NBROOT_TRAITEES + 1 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN NBFIN = NBFIN - NBROOT IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL DMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID_NODES, & COMM_NODES, RACINE, SLAVEF, KEEP ) END IF ENDIF IF (NBFIN.EQ.0) GOTO 640 GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (TYPE.EQ.1) GOTO 100 FPERE = DAD(STEP(INODE)) AVOID_DELAYED = ( (FPERE .eq. KEEP(20) .OR. FPERE .eq. KEEP(38)) & .AND. KEEP(60).ne.0 ) IF ( KEEP(50) .eq. 0 ) THEN CALL DMUMPS_FAC2_LU( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, & NOFFNEGPV, NTOTPV, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, & NBFIN,LEAF, INFO(1), INFO(2), IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_STEPS,PERM,PROCNODE_STEPS, & root, roota, OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & 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_STRUCT & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) ELSE CALL DMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, & NOFFNEGPV, NULLNEGPV, NTOTPV, & NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, & NBFIN,LEAF, INFO(1), INFO(2), IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_STEPS,PERM,PROCNODE_STEPS, & root, roota, OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & 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_STRUCT & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF ( IW( PTLUST(STEP(INODE)) + KEEP(IXSZ) + 5 ) .GT. 1 ) THEN GOTO 20 END IF END IF GOTO 130 ENDIF IF (INODE.EQ.KEEP(38)) THEN CALL DMUMPS_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, & root, roota, FRERE, & INODE, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, COMP, & INFO(1), INFO(2), COMM_NODES, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID_NODES, SLAVEF, & & OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP, ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (TYPE.EQ.1) THEN IF (KEEP(55).NE.0) THEN CALL DMUMPS_FAC_ASM_NIV1_ELT( COMM_LOAD, ASS_IRECV, & UU, NELT, FRTPTR, FRTELT, & N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,roota,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP, & INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS,PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & , MUMPS_TPS_ARR, DMUMPS_TPS_ARR, & L0_OMP_MAPPING & ) ELSE JOBASS = 0 CALL DMUMPS_FAC_ASM_NIV1(COMM_LOAD, ASS_IRECV, & UU, N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,roota,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP, INTARR,KEEP8(27), & DBLARR,KEEP8(26), & NSTK_STEPS,PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, JOBASS,ETATASS & , LRGROUPS & , MUMPS_TPS_ARR, DMUMPS_TPS_ARR, & L0_OMP_MAPPING & ) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF ( INFO(1) .LT. 0 ) GOTO 640 IF ((IW(PTLUST(STEP(INODE))+XXNBPR).GT.0).OR.(SON_LEVEL2)) THEN GOTO 20 ENDIF ELSE IF ( KEEP(55) .eq. 0 ) THEN CALL DMUMPS_FAC_ASM_NIV2(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, & INFO(1), & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, & root, roota, OPASS, OPELI, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) ELSE CALL DMUMPS_FAC_ASM_NIV2_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, INFO(1), & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, & root, roota, OPASS, OPELI, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) END IF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 640 GOTO 20 ENDIF 100 CONTINUE FPERE = DAD(STEP(INODE)) IF ( INODE .eq. KEEP(20) ) THEN POSELT = PTRAST(STEP(INODE)) IF (PTRFAC(STEP(INODE)).NE.POSELT) THEN WRITE(*,*) "ERROR 2 in DMUMPS_FAC_PAR", POSELT GOTO 635 ENDIF IF (KEEP(118).GE.40) THEN IOLDPS = PTLUST(STEP(INODE)) LRecord = IW(IOLDPS+XXI) IF (allocated(RECORD_ROOT)) DEALLOCATE(RECORD_ROOT) ALLOCATE(RECORD_ROOT(LRecord), stat=IERR) IF (IERR.GT.0) THEN INFO(1)= -13 INFO(2)= LRecord IF (LP > 0) & write(LP,*) "ERROR allocate RECORD_ROOT" GOTO 635 ENDIF RECORD_ROOT(1:LRecord) = IW(IOLDPS:IOLDPS+LRecord-1) ENDIF CALL DMUMPS_CHANGE_HEADER & ( IW(PTLUST(STEP(INODE))+KEEP(IXSZ)), KEEP(253) ) IF (KEEP(118).GE.40) THEN Header_ROOT(1:5) = IW(PTLUST(STEP(INODE))+KEEP(IXSZ): & PTLUST(STEP(INODE))+KEEP(IXSZ)+4) ENDIF GOTO 200 END IF POSELT = PTRAST(STEP(INODE)) IOLDPS = PTLUST(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_FAC1_LU ( & N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFNEGPV, NTOTPV, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & KEEP,KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) GOTO 635 ELSE IW( IOLDPS+4+KEEP(IXSZ) ) = 1 CALL DMUMPS_FAC1_LDLT( N, INODE, & IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFNEGPV, NULLNEGPV, NTOTPV, & NB22T1, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, & ETATASS, & DKEEP(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) GOTO 635 IW( IOLDPS+4+KEEP(IXSZ) ) = STEP(INODE) ENDIF JOBASS = ETATASS IF (JOBASS.EQ.1) THEN CALL DMUMPS_FAC_ASM_NIV1(COMM_LOAD, ASS_IRECV, & UU, N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,roota,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, & PTRARW,PTRAIW,PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & JOBASS,ETATASS & , LRGROUPS & ) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 635 130 CONTINUE TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF ( FPERE .NE. 0 ) THEN TYPEF = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(FPERE)),KEEP(199)) ELSE TYPEF = -9999 END IF CALL DMUMPS_FAC_STACK( COMM_LOAD, ASS_IRECV, & N,INODE,TYPE,TYPEF,LA,IW,LIW,A, & INFO(1),INFO(2),OPELI,NELVA,NMAXNPIV, & PTRIST,PTLUST,PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NE, POSFAC,LRLU, LRLUS,KEEP8(67), & IPTRLU,ICNTL,KEEP,KEEP8,DKEEP,COMP,IWPOS,IWPOSCB, & PROCNODE_STEPS,SLAVEF,FPERE,COMM_NODES,MYID_NODES, & IPOOL, LPOOL, LEAF, & NSTK_STEPS, PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, & root, roota, & OPASS, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ,DUMMY_FLOP_ESTIM_ACC & ) IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 640 200 CONTINUE IF ( INODE .eq. KEEP(38) ) THEN WRITE(*,*) 'Error .. in DMUMPS_FAC_PAR: ', & ' INODE == KEEP(38)' CALL MUMPS_ABORT() END IF IF ( FPERE.EQ.0 ) THEN NBROOT_TRAITEES = NBROOT_TRAITEES + 1 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN IF (KEEP(201).EQ.1) THEN CALL DMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF ( KEEP(201).EQ.2) THEN CALL DMUMPS_FORCE_WRITE_BUF(IERR) ENDIF NBFIN = NBFIN - NBROOT IF ( NBFIN .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in DMUMPS_FAC_PAR: ', & ' NBFIN=', NBFIN CALL MUMPS_ABORT() END IF IF ( NBROOT .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in DMUMPS_FAC_PAR: ', & ' NBROOT=', NBROOT CALL MUMPS_ABORT() END IF IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL DMUMPS_MCAST2( DUMMY(1), 1, MPI_INTEGER, & MYID_NODES, COMM_NODES, RACINE, SLAVEF, KEEP ) END IF ENDIF IF (NBFIN.EQ.0)THEN GOTO 640 ENDIF ELSEIF ( FPERE.NE.KEEP(38) .AND. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID_NODES ) THEN NSTK_STEPS(STEP(FPERE)) = NSTK_STEPS(STEP(FPERE))-1 IF ( NSTK_STEPS( STEP( FPERE )).EQ.0) THEN IF (KEEP(234).NE.0 .AND. & MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199))) & THEN STACK_RIGHT_AUTHORIZED = .FALSE. ENDIF CALL DMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( FPERE, N, PROCNODE_STEPS,KEEP(199), & ND, FILS, FRERE, STEP, PIMASTER, KEEP(28), & KEEP(50), KEEP(253), FLOP1, & IW, LIW, KEEP(IXSZ) ) IF (FPERE.NE.KEEP(20)) & CALL MUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ENDIF GO TO 20 635 CONTINUE IF (allocated(RECORD_ROOT)) DEALLOCATE(RECORD_ROOT) CALL DMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP ) 640 CONTINUE CALL DMUMPS_CANCEL_IRECV( INFO(1), & KEEP, & ASS_IRECV, BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, & MYID_NODES, SLAVEF) CALL MUMPS_CLEAN_PENDING( INFO(1), KEEP, & BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, & .TRUE., & .TRUE.) CALL MPI_BARRIER( COMM_NODES, IERR ) IF (INFO(1) .LT. 0) THEN CALL DMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & .FALSE. ) IF ( KEEP(400) .GT. 0 & ) THEN !$OMP PARALLEL DO SCHEDULE(STATIC,1) DO ITH = 1, KEEP(400) IF (associated(MUMPS_TPS_ARR(ITH)%IW)) THEN CALL DMUMPS_DM_FREEALLDYNAMICCB_I( MYID, N, SLAVEF, & KEEP, KEEP8, & MUMPS_TPS_ARR(ITH)%IW(1), MUMPS_TPS_ARR(ITH)%LIW, & MUMPS_TPS_ARR(ITH)%IWPOSCB, MUMPS_TPS_ARR(ITH)%IWPOS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & .TRUE. ) ENDIF ENDDO !$OMP END PARALLEL DO ENDIF ENDIF IF ( INFO(1) .GE. 0 ) THEN IF( KEEP(38) .NE. 0 .OR. KEEP(20).NE.0) THEN CALL MUMPS_SECDEB(ROOTTIME) MASTER_ROOT = MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(max(KEEP(38),KEEP(20)))), & KEEP(199)) ROOT_OWNER = (MASTER_ROOT .EQ. MYID_NODES) IF ( KEEP(38) .NE. 0 ) THEN IF (KEEP(60).EQ.0) THEN IOLDPS = PTLUST(STEP(KEEP(38))) LOCAL_M = IW(IOLDPS+2+KEEP(IXSZ)) LOCAL_N = IW(IOLDPS+1+KEEP(IXSZ)) ELSE IOLDPS = -999 LOCAL_M = root%SCHUR_MLOC LOCAL_N = root%SCHUR_NLOC ENDIF ITMP8 = int(LOCAL_M,8)*int(LOCAL_N,8) LBUFRX = min(int(root%MBLOCK,8)*int(root%NBLOCK,8), & int(root%TOT_ROOT_SIZE,8)*int(root%TOT_ROOT_SIZE,8) ) IS_BUFRX_ALLOCATED = .FALSE. IF ( LRLU .GT. LBUFRX ) THEN BUFRX => A(POSFAC:POSFAC+LRLU-1_8) LBUFRX=LRLU ELSE ALLOCATE( BUFRX( LBUFRX ), stat = IERR ) IF (IERR.gt.0) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR(LBUFRX, INFO(2) ) IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before DMUMPS_FACTO_ROOT', LBUFRX ELSE IS_BUFRX_ALLOCATED = .TRUE. ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL, INFO, & COMM_NODES, MYID_NODES ) IF (INFO(1).GE.0) THEN CALL DMUMPS_FACTO_ROOT( & MPA, MYID_NODES, MASTER_ROOT, & root, roota, N, KEEP(38), & COMM_NODES, IW, LIW, IWPOS + 1, & A, LA, PTRAST, PTLUST, PTRFAC, STEP, & INFO(1), KEEP(50), KEEP(19), & BUFRX(1), LBUFRX, KEEP,KEEP8, DKEEP, & OPELI, DET_EXP, DET_MANT, DET_SIGN ) CALL DMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IS_BUFRX_ALLOCATED = .FALSE. CALL MUMPS_PROPINFO( ICNTL, INFO, & COMM_NODES, MYID_NODES ) ENDIF IF ( MYID_NODES .eq. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))), & KEEP(199)) & ) THEN IF ( INFO(1) .EQ. -10 .OR. INFO(1) .EQ. -40 ) THEN NTOTPV = NTOTPV + INFO(2) ELSE IF ( INFO(1) .GE. 0 ) THEN NTOTPV = NTOTPV + root%TOT_ROOT_SIZE NMAXNPIV = max(NMAXNPIV,root%TOT_ROOT_SIZE) END IF END IF IF (INFO(1).GE.0.AND.KEEP(60).EQ.0) THEN IF (root%yes) THEN IF (KEEP(252).EQ.0) THEN IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_L NextPiv2beWritten = 1 MonBloc%INODE = KEEP(38) MonBloc%MASTER = .TRUE. MonBloc%Typenode = 3 MonBloc%NROW = LOCAL_M MonBloc%NCOL = LOCAL_N MonBloc%NFS = MonBloc%NCOL MonBloc%Last = .TRUE. MonBloc%LastPiv = MonBloc%NCOL MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. LAST_CALL = .TRUE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(PTRFAC(STEP(KEEP(38)))), & LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IERR,LAST_CALL) IF (IERR .LT.0) THEN INFO(1) = IERR IF (LP > 0 ) THEN WRITE(LP,*)MYID, & ': Error in DMUMPS_OOC_IO_LU_PANEL',IERR ENDIF ENDIF ELSE IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+ ITMP8 CALL DMUMPS_NEW_FACTOR(KEEP(38),PTRFAC, & KEEP,KEEP8,A,LA, ITMP8, IERR) IF(IERR.LT.0)THEN INFO(1)=IERR IF (LP > 0 ) THEN WRITE(LP,*)MYID, & ': Error in DMUMPS_NEW_FACTOR',IERR ENDIF ENDIF ENDIF ENDIF IF (KEEP(201).NE.0 .OR. KEEP(252).NE.0) THEN LRLUS = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 IF (KEEP(252).NE.0) THEN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,0_8,-ITMP8, & KEEP,KEEP8,LRLUS) ELSE CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLUS) ENDIF IF (PTRFAC(STEP(KEEP(38))).EQ.POSFAC-ITMP8) THEN POSFAC = POSFAC - ITMP8 LRLU = LRLU + ITMP8 ENDIF ELSE CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLUS) ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL, INFO, & COMM_NODES, MYID_NODES ) ENDIF IF ( INFO(1).GE.0 .AND. KEEP(252) .NE. 0 .AND. & (KEEP(60).EQ.0 .OR. KEEP(221).EQ.1)) THEN IF (root%yes) 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(roota%RHS_CNTR_MASTER_ROOT( & LRHS_CNTR_MASTER_ROOT), stat=IERR ) IF (IERR.gt.0) THEN INFO(1) = -13 INFO(2) = LRHS_CNTR_MASTER_ROOT IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'CNTR_MASTER_ROOT of size', & LRHS_CNTR_MASTER_ROOT ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL, INFO, COMM_NODES, & MYID_NODES) IF (root%yes .AND. INFO(1).GE.0) THEN FWD_LOCAL_N_RHS = MUMPS_NUMROC(KEEP(253), & root%NBLOCK, root%MYCOL, 0, root%NPCOL) FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) CALL DMUMPS_GATHER_ROOT( MYID_NODES, & root%TOT_ROOT_SIZE, KEEP(253), & roota%RHS_CNTR_MASTER_ROOT(1), LOCAL_M, & FWD_LOCAL_N_RHS, root%MBLOCK, root%NBLOCK, & roota%RHS_ROOT(1,1), MASTER_ROOT, & root%NPROW, root%NPCOL, COMM_NODES ) ENDIF ENDIF ELSE IF (KEEP(19).NE.0) THEN CALL MPI_REDUCE(KEEP(109), GLOBK109, 1, & MPI_INTEGER, MPI_SUM, & MASTER_ROOT, & COMM_NODES, IERR) ENDIF IF (ROOT_OWNER) THEN IPOSROOT = PTLUST(STEP(KEEP(20))) NFRONT = IW(IPOSROOT+KEEP(IXSZ)+3) NFRONT8 = int(NFRONT,8) IPOSROOTROWINDICES=IPOSROOT+6+KEEP(IXSZ)+ & IW(IPOSROOT+5+KEEP(IXSZ)) NTOTPV = NTOTPV + NFRONT NMAXNPIV = max(NMAXNPIV,NFRONT) END IF IF ( KEEP(60) .EQ. 0 ) THEN IF ( ROOT_OWNER ) THEN IF (KEEP(118).GE.40) THEN NOFFNEGPV_ROOT = 0 NULLNEGPV_ROOT = 0 NTOTPV_ROOT = 0 NB22T1_ROOT = 0 NBTINY_ROOT = 0 DET_SIGN_ROOT = 1 DET_EXP_ROOT = 0 DET_MANT_ROOT = 1.0D0 DKEEP_SAVE(:) = DKEEP(:) KEEP_SAVE(:) = KEEP(:) KEEP8_SAVE(:) = KEEP8(:) KEEP_SAVE(201) = 0 IF (KEEP(110).EQ.0) THEN KEEP_SAVE(110)= 1 IF (KEEP(118).EQ.40) THEN IF ((DKEEP(10).LE.0).OR.(DKEEP(10).GT.1)) THEN DKEEP_SAVE(1) = DKEEP(9)*1D-1 ELSE DKEEP_SAVE(1) = DKEEP(9)*DKEEP(10) ENDIF ELSE IF (KEEP(118).EQ.41) THEN DKEEP_SAVE(1) = DKEEP(9) ELSE IF (KEEP(118).EQ.42) THEN IF (DKEEP(13).LT.1) THEN DKEEP_SAVE(1) = DKEEP(9)*10 ELSE DKEEP_SAVE(1) = DKEEP(9)*DKEEP(13) ENDIF ENDIF ELSE DKEEP_SAVE(1) = DKEEP(9) ENDIF IS_A_ROOT_SAVE_ALLOCATED = .FALSE. IF (LRLU.GT.NFRONT8*NFRONT8) THEN A_ROOT_SAVE => A(POSFAC:POSFAC+LRLU-1_8) ELSE IF (associated(A_ROOT_SAVE)) & DEALLOCATE(A_ROOT_SAVE) ALLOCATE(A_ROOT_SAVE(NFRONT8*NFRONT8),stat=IERR) IF (IERR.GT.0) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR(NFRONT8*NFRONT8, INFO(2) ) IF (LP > 0 ) & write(LP,*) "ERROR allocating A_ROOT_SAVE ", & " of size ", NFRONT*NFRONT GOTO 735 ENDIF IS_A_ROOT_SAVE_ALLOCATED = .TRUE. ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK8=int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF ( NFRONT8*NFRONT8 > int(KEEP(361),8) .AND. NOMP .GT. 1) DO I8 =1_8, NFRONT8*NFRONT8 A_ROOT_SAVE(I8) = & A(PTRAST(STEP(KEEP(20)))+I8-1_8) ENDDO IW(PTLUST(STEP(INODE))+KEEP(IXSZ): & PTLUST(STEP(INODE))+KEEP(IXSZ)+4) & = RECORD_ROOT(KEEP(IXSZ)+1:KEEP(IXSZ)+5) IW(PTLUST(STEP(INODE))+XXLR) = 0 AVOID_DELAYED = .TRUE. IF (KEEP(50).EQ.0) THEN CALL DMUMPS_FAC1_LU_I ( & N, INODE, IW, LIW, A_ROOT_SAVE(1), & NFRONT8*NFRONT8, IPOSROOT, 1_8, & INFO(1), INFO(2), UU, NOFFNEGPV_ROOT, NTOTPV_ROOT, & NBTINY_ROOT, & DET_EXP_ROOT, DET_MANT_ROOT, DET_SIGN_ROOT, & KEEP_SAVE,KEEP8_SAVE, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP_SAVE(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) THEN IF (LP.GT.0) & write(LP,*) "ERROR after DMUMPS_FAC1_LU ", & "on the root INFO(1)= ", INFO(1) GOTO 735 ENDIF ELSE CALL DMUMPS_FAC1_LDLT_I (N,KEEP_SAVE(20), & IW, LIW, A_ROOT_SAVE(1), NFRONT8*NFRONT8, & IPOSROOT, 1_8, & INFO(1), INFO(2), UU, & NOFFNEGPV_ROOT, NULLNEGPV_ROOT, NTOTPV_ROOT, & NB22T1_ROOT, NBTINY_ROOT, & DET_EXP_ROOT, DET_MANT_ROOT, DET_SIGN_ROOT, & KEEP_SAVE,KEEP8_SAVE, MYID_NODES, SEUIL, & AVOID_DELAYED, ETATASS, DKEEP_SAVE(1), & PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) THEN IF (LP.GT.0) & write(LP,*) "ERROR after DMUMPS_FAC1_LDLT ", & "on the root INFO(1)= ", INFO(1) GOTO 735 ENDIF ENDIF LRecord = IW(IOLDPS+XXI) IW(PTLUST(STEP(INODE)): & PTLUST(STEP(INODE))+LRecord-1) = & RECORD_ROOT(1:LRecord) IW(PTLUST(STEP(INODE))+KEEP(IXSZ): & PTLUST(STEP(INODE))+KEEP(IXSZ)+4) = & Header_ROOT(1:5) KEEP17_LU = KEEP_SAVE(109)-KEEP(109) IF (KEEP_SAVE(109).GT.KEEP(109)) THEN K = 1 DO I = KEEP(109)+1, KEEP(109)+KEEP17_LU RECORD_ROOT(K) = & PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) K = K+1 ENDDO ENDIF IF (IS_A_ROOT_SAVE_ALLOCATED) DEALLOCATE(A_ROOT_SAVE) NULLIFY(A_ROOT_SAVE) IS_A_ROOT_SAVE_ALLOCATED = .FALSE. DET_SIGN = DET_SIGN * DET_SIGN_ROOT DET_EXP = DET_EXP + DET_EXP_ROOT CALL DMUMPS_UPDATEDETER ( DET_MANT_ROOT, & DET_MANT, DET_EXP) NOFFNEGPV = NOFFNEGPV + NOFFNEGPV_ROOT NULLNEGPV = NULLNEGPV + NULLNEGPV_ROOT ENDIF LOCAL_M = 0 LOCAL_N = 0 MBLOCK = 0 NBLOCK = 0 PHASE = 1 CALL DMUMPS_SVD_QR_ESTIM_WK( PHASE, & MBLOCK, NBLOCK, NFRONT, LOCAL_M, LOCAL_N, & ROOT_OWNER, KEEP,KEEP8, & LIWK_RR, LWK_RR ) LBUFRX = LWK_RR IS_BUFRX_ALLOCATED = .FALSE. IF ( LRLU .GT. LBUFRX ) THEN BUFRX => A(POSFAC:POSFAC+LBUFRX-1_8) ELSE ALLOCATE( BUFRX( LBUFRX ), stat = IERR ) IF (IERR.gt.0) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR(LBUFRX, INFO(2)) IF (LP.GT.0) & write(LP,*) ' Error allocating, real & array ','of size ', LBUFRX, & ' before DMUMPS_SEQ_FACTO_ROOT_SVD_QR' GOTO 735 ENDIF IS_BUFRX_ALLOCATED = .TRUE. ENDIF IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST .LT. & KEEP(109)+NFRONT) THEN CALL MUMPS_RESIZE_PIVNUL(KEEP, N, PIVNUL_LIST_STRUCT, & KEEP(109)+NFRONT, INFO(1), INFO(2) ) IF (INFO(1).LT.0) GOTO 735 ENDIF CALL DMUMPS_SEQ_FACTO_ROOT_SVD_QR( & NFRONT,A(PTRAST(STEP(KEEP(20)))), & root, roota, & BUFRX(1), int(LBUFRX), & KEEP,KEEP8, INFO, LP, DKEEP, & GLOBK109, OPELI, & PIVNUL_LIST_STRUCT%PIVNUL_LIST(KEEP(109)+1), & PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST- KEEP(109), & IW(IPOSROOTROWINDICES)) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IS_BUFRX_ALLOCATED = .FALSE. IF (INFO(1).LT.0) GOTO 735 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) CALL DMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) KEEP(143) = KEEP17_LU IF (KEEP(118).GE.40) THEN K = 1 IF (KEEP(17).GT.0) THEN DO I = KEEP(109)+1, KEEP(109)+KEEP(17) IF ( K .GT. KEEP17_LU ) THEN PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) = -1 ELSE PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) = & RECORD_ROOT(K) ENDIF K = K+1 ENDDO ENDIF ENDIF IF (allocated(RECORD_ROOT)) DEALLOCATE(RECORD_ROOT) IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC, IW(IPOSROOT+XXR)) LIWFAC = IW(IPOSROOT+XXI) TYPEFile = TYPEF_L NextPiv2beWritten = 1 MonBloc%INODE = KEEP(20) MonBloc%MASTER = .TRUE. MonBloc%Typenode = 3 MonBloc%NCOL = NFRONT MonBloc%NROW = NFRONT MonBloc%NFS = NFRONT MonBloc%Last = .TRUE. MonBloc%LastPiv = MonBloc%NCOL MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. LAST_CALL = .TRUE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(PTRAST(STEP(KEEP(20)))), & LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IPOSROOT), LIWFAC, & MYID, KEEP8(31), IERR, LAST_CALL) IF(IERR.LT.0)THEN IF (LP > 0) & WRITE(LP,*)MYID, & ': Error raised in DMUMPS_OOC_IO_LU_PANEL', & IERR INFO(1)=IERR ENDIF ELSE IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+NFRONT8*NFRONT8 CALL DMUMPS_NEW_FACTOR(KEEP(20),PTRFAC, & KEEP,KEEP8,A,LA, NFRONT8*NFRONT8, IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID, & ': Internal error in DMUMPS_NEW_FACTOR', & IERR GOTO 735 ENDIF ENDIF ITMP8 = NFRONT8*NFRONT8 IF(KEEP(201).NE.0)THEN IF (PTRFAC(STEP(KEEP(20))).EQ. & POSFAC-ITMP8) THEN POSFAC = POSFAC - ITMP8 LRLU = LRLU + ITMP8 LRLUS = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 ELSE IF (LP.GT.0) & WRITE(LP,*) "Internal error", & POSFAC,NFRONT8, & "root KEEP(20) not on top in OOC" GOTO 735 ENDIF ENDIF CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,ITMP8,0_8,KEEP,KEEP8,LRLUS) ENDIF 735 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM_NODES, MYID_NODES ) IF (INFO(1).LT.0) GOTO 745 CALL MPI_BCAST( KEEP(17), 1, MPI_INTEGER, & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(20))), & KEEP(199)), & COMM_NODES, IERR ) CALL MPI_BCAST( KEEP(143), 1, MPI_INTEGER, & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(20))), & KEEP(199)), & COMM_NODES, IERR ) END IF IF (ROOT_OWNER.AND.KEEP(60).NE.0) THEN ITMP8 = NFRONT8*NFRONT8 IF ( PTRFAC(STEP(KEEP(20))) .EQ. POSFAC - & ITMP8 ) THEN POSFAC = POSFAC - ITMP8 LRLUS = LRLUS + ITMP8 LRLU = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-ITMP8,KEEP,KEEP8,LRLUS) ENDIF ENDIF END IF GOTO 750 745 CONTINUE IF (allocated(RECORD_ROOT)) DEALLOCATE(RECORD_ROOT) IF (IS_A_ROOT_SAVE_ALLOCATED) DEALLOCATE(A_ROOT_SAVE) NULLIFY(A_ROOT_SAVE) 750 CONTINUE IF (INFO(1).LT.0) GOTO 500 CALL MUMPS_SECFIN(ROOTTIME) DKEEP(99)=ROOTTIME END IF END IF 500 CONTINUE IF ( KEEP(38) .NE. 0 ) THEN IF (MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))),KEEP(199)) & ) THEN MAXFRT = max ( MAXFRT, root%TOT_ROOT_SIZE) END IF END IF IF ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.2)) THEN CALL DMUMPS_OOC_CLEAN_PENDING(IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ENDIF CALL MUMPS_PROPINFO( ICNTL, INFO, COMM_NODES, MYID_NODES ) ENDIF IF (associated(roota%RHS_ROOT)) THEN DEALLOCATE(roota%RHS_ROOT) NULLIFY(roota%RHS_ROOT) ENDIF RETURN END SUBROUTINE DMUMPS_FAC_PAR SUBROUTINE DMUMPS_CHANGE_HEADER( HEADER, KEEP253 ) INTEGER HEADER( 6 ), KEEP253 INTEGER NFRONT, NASS NFRONT = HEADER(1) IF ( HEADER(2) .ne. 0 ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 1 :',HEADER(2) CALL MUMPS_ABORT() END IF NASS = abs( HEADER( 3 ) ) IF ( NASS .NE. abs( HEADER( 4 ) ) ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 2 :',HEADER(3:4) CALL MUMPS_ABORT() END IF IF ( NASS+KEEP253 .NE. NFRONT ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 3 : not root', & NASS, KEEP253, NFRONT CALL MUMPS_ABORT() END IF HEADER( 1 ) = KEEP253 HEADER( 2 ) = 0 HEADER( 3 ) = NFRONT HEADER( 4 ) = NFRONT-KEEP253 RETURN END SUBROUTINE DMUMPS_CHANGE_HEADER END MODULE DMUMPS_FAC_PAR_M MUMPS_5.8.1/src/cfac_mem_stack.F0000664000175000017500000005742515042446440016273 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_FAC_STACK(COMM_LOAD, ASS_IRECV, & N, INODE, TYPE, TYPEF, & LA, IW, LIW, A, & IFLAG, IERROR, OPELIW, NELVAW, NMAXNPIV, & PTRIST, PTLUST_S, & PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, NE, & POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP,KEEP8,DKEEP, & COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, SLAVEF, & FPERE, COMM, MYID, IPOOL, LPOOL, LEAF, NSTK_S, & PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, root, roota, & OPASSW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & , FLOP_ESTIM_ACC & ) USE CMUMPS_BUF, ONLY : CMUMPS_BUF_SEND_CB, CMUMPS_BUF_SEND_MAITRE2 USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_RTNELIND, & MUMPS_BUF_SEND_ROOT2SON USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER COMM, MYID, TYPE, TYPEF INTEGER N, LIW, INODE,IFLAG,IERROR INTEGER ICNTL(60), KEEP(500) REAL DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU INTEGER IWPOSCB, IWPOS, & FPERE, SLAVEF, NELVAW, NMAXNPIV INTEGER IW(LIW),PROCNODE_STEPS(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NE(KEEP(28)) COMPLEX A(LA) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW COMPLEX DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER LPOOL, LEAF, COMP INTEGER IPOOL( LPOOL ) INTEGER NSTK_S( KEEP(28) ) INTEGER PERM(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER NBFIN INTEGER NFRONT_ESTIM,NELIM_ESTIM DOUBLE PRECISION FLOP_ESTIM_ACC INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER NBROWS_ALREADY_SENT INTEGER(8) :: POSELT, OPSFAC INTEGER(8) :: IOLD, INEW, FACTOR_POS, I8 INTEGER NSLAVES, NCB, & H_INODE, IERR, NBCOL, NBROW, NBROW_SEND, & NELIM INTEGER NBROW_STACK, NBROW_INDICES, NBCOL_STACK INTEGER NCBROW_ALREADY_MOVED, NCBROW_PREVIOUSLY_MOVED, &NCBROW_NEWLY_MOVED INTEGER(8) :: LAST_ALLOWED_POS INTEGER(8) :: LREQCB, MIN_SPACE_IN_PLACE INTEGER(8) :: SHIFT_VAL_SON INTEGER SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, & LIST_ROW_SON, LIST_COL_SON, LIST_SLAVES INTEGER IOLDPS,NFRONT,NPIV,NASS,IOLDP1,PTROWEND, & LREQI, LCONT INTEGER I,LDA, INIV2 INTEGER MSGDEST, MSGTAG, CHK_LOAD INCLUDE 'mumps_headers.h' LOGICAL MUST_COMPACT_FACTORS LOGICAL PACKED_CB, COMPRESS_PANEL, COMPRESS_CB, LR_SOLVE LOGICAL INPLACE INTEGER(8) :: SIZE_INPLACE, FAC_ENTRIES, COUNT_EXTRA_IP_COPIES INTEGER INTSIZ DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL SSARBR, SSARBR_ROOT, MUMPS_INSSARBR, & MUMPS_IN_OR_ROOT_SSARBR EXTERNAL MUMPS_INSSARBR, MUMPS_IN_OR_ROOT_SSARBR 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 = abs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) H_INODE= 6 + NSLAVES + KEEP(IXSZ) LCONT = NFRONT - NPIV NBCOL = LCONT SSARBR = MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) SSARBR_ROOT = MUMPS_IN_OR_ROOT_SSARBR & (PROCNODE_STEPS(STEP(INODE)),KEEP(199)) LREQCB = 0_8 INPLACE = .FALSE. PACKED_CB = ((KEEP(215).EQ.0) & .AND.(KEEP(50).NE.0) & .AND.(TYPEF.EQ.1 & .OR.TYPEF.EQ.2 & ) & .AND.(TYPE.EQ.1)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = (IW(IOLDPS+XXLR).EQ.1.OR.IW(IOLDPS+XXLR).EQ.3) LR_SOLVE = (KEEP(486).EQ.2) MUST_COMPACT_FACTORS = .TRUE. IF (KEEP(201).EQ.1 .OR. KEEP(201).EQ.-1 & .OR. (COMPRESS_PANEL.AND.LR_SOLVE) & ) THEN MUST_COMPACT_FACTORS = .FALSE. ENDIF IF ((FPERE.EQ.0).AND.(NASS.NE.NPIV)) THEN IFLAG = -10 GOTO 600 ENDIF NBROW = LCONT IF (TYPE.EQ.2) NBROW = NASS - NPIV IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN LDA = NASS ELSE LDA = NFRONT ENDIF NBROW_SEND = NBROW NELIM = NASS-NPIV IF (TYPEF.EQ.2) NBROW_SEND = NELIM POSELT = PTRAST(STEP(INODE)) IF (POSELT .ne. PTRFAC(STEP(INODE))) THEN WRITE(*,*) MYID,":Error 1 in CMUMPS_FAC_STACK:" WRITE(*,*) "INODE, PTRAST, PTRFAC =", & INODE, PTRAST(STEP(INODE)), PTRFAC(STEP(INODE)) WRITE(*,*) "PACKED_CB, NFRONT, NPIV, NASS, NSLAVES", & PACKED_CB, NFRONT, NPIV, NASS, NSLAVES WRITE(*,*) "TYPE, TYPEF, FPERE ", & TYPE, TYPEF, FPERE CALL MUMPS_ABORT() END IF NELVAW = NELVAW + NASS - NPIV IF (KEEP(50) .eq. 0) THEN FAC_ENTRIES = int(NPIV,8) * int(NFRONT,8) ELSE FAC_ENTRIES = ( int(NPIV,8)*int(NPIV+1,8) )/ 2_8 ENDIF FAC_ENTRIES = FAC_ENTRIES + int(NBROW,8) * int(NPIV,8) IF ( KEEP(405) .EQ. 0 ) THEN KEEP8(10) = KEEP8(10) + FAC_ENTRIES KEEP(429) = KEEP(429) - 1 ELSE !$OMP ATOMIC UPDATE KEEP8(10) = KEEP8(10) + FAC_ENTRIES !$OMP END ATOMIC ENDIF CALL MUMPS_GET_FLOPS_COST( NFRONT, NPIV, NASS, & KEEP(50), TYPE,FLOP1 ) IF ( (.NOT. SSARBR_ROOT) .and. TYPE == 1) THEN IF (NE(STEP(INODE))==0) THEN CHK_LOAD=0 ELSE CHK_LOAD=1 ENDIF CALL MUMPS_LOAD_UPDATE(CHK_LOAD, .FALSE., -FLOP1, & KEEP,KEEP8) ENDIF FLOP1_EFFECTIVE = FLOP1 OPELIW = OPELIW + FLOP1 IF ( NPIV .NE. NASS ) THEN CALL MUMPS_GET_FLOPS_COST( NFRONT, NASS, NASS, & KEEP(50), TYPE,FLOP1 ) IF (.NOT. SSARBR_ROOT ) THEN IF (NE(STEP(INODE))==0) THEN CHK_LOAD=0 ELSE CHK_LOAD=1 ENDIF CALL MUMPS_LOAD_UPDATE(CHK_LOAD, .FALSE., & FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) ENDIF END IF IF ( SSARBR_ROOT ) THEN NFRONT_ESTIM=ND(STEP(INODE)) + KEEP(253) NELIM_ESTIM=NASS-(NFRONT-NFRONT_ESTIM) CALL MUMPS_GET_FLOPS_COST(NFRONT_ESTIM,NELIM_ESTIM,NELIM_ESTIM, & KEEP(50),1,FLOP1) END IF FLOP1=-FLOP1 IF (KEEP(400).GT.0) THEN FLOP_ESTIM_ACC = FLOP_ESTIM_ACC + FLOP1 ENDIF IF (SSARBR_ROOT) THEN CALL MUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1,KEEP,KEEP8) ELSE CALL MUMPS_LOAD_UPDATE(2,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF IF ( FPERE .EQ. 0 ) THEN IF ( KEEP(253) .NE. 0 .AND. KEEP(201).NE.-1 & .AND. KEEP(201).NE.1 & .AND. (.NOT.COMPRESS_PANEL.OR..NOT.LR_SOLVE) & ) THEN MUST_COMPACT_FACTORS = .TRUE. GOTO 190 ELSE IF ( KEEP(50) .NE. 0 .AND. KEEP(459).GT.1) THEN MUST_COMPACT_FACTORS = .TRUE. GOTO 190 ELSE MUST_COMPACT_FACTORS = .FALSE. GOTO 190 ENDIF ENDIF IF ( FPERE.EQ.KEEP(38) ) THEN NCB = NFRONT - NASS SHIFT_LIST_ROW_SON = H_INODE + NASS SHIFT_LIST_COL_SON = H_INODE + NFRONT + NASS SHIFT_VAL_SON = int(NASS,8)*int(NFRONT+1,8) IF (TYPE.EQ.1) THEN CALL CMUMPS_BUILD_AND_SEND_CB_ROOT( & COMM_LOAD, ASS_IRECV, N, INODE, FPERE, & PTLUST_S, PTRAST, & root, roota, NCB, NCB, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, & ROOT_CONT_STATIC, MYID, COMM, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE., ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS, 0, 0, 0 ) IF (IFLAG < 0 ) GOTO 500 ENDIF MSGDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)),KEEP(199)) IOLDPS = PTLUST_S(STEP(INODE)) LIST_ROW_SON = IOLDPS + H_INODE + NPIV LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) IF (MSGDEST.EQ.MYID) THEN CALL CMUMPS_PROCESS_RTNELIND( root, roota, & INODE, NELIM, NSLAVES, IW(LIST_ROW_SON), & IW(LIST_COL_SON), IW(LIST_SLAVES), & & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND) IF (IFLAG.LT.0) GOTO 600 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) CALL MUMPS_BUF_SEND_RTNELIND( INODE, NELIM, & IW(LIST_ROW_SON), IW(LIST_COL_SON), NSLAVES, & IW(LIST_SLAVES), MSGDEST, COMM, KEEP, IERR) IF ( IERR .EQ. -1 ) THEN BLOCKING =.FALSE. SET_IRECV =.TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, & ND, FRERE, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & .TRUE., LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IOLDPS = PTLUST_S(STEP(INODE)) LIST_ROW_SON = IOLDPS + H_INODE + NPIV LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) ENDIF ENDDO IF ( IERR .EQ. -2 ) THEN IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) IFLAG = - 17 GOTO 600 ELSE IF ( IERR .EQ. -3 ) THEN IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) IFLAG = -20 GOTO 600 ENDIF ENDIF IF (NELIM.EQ.0) THEN POSELT = PTRAST(STEP(INODE)) OPSFAC = POSELT + int(NPIV,8) * int(NFRONT,8) + int(NPIV,8) GOTO 190 ELSE GOTO 500 ENDIF ENDIF OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .NE. MYID ) THEN MSGTAG =NOEUD MSGDEST=MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), KEEP(199) ) IERR = -1 NBROWS_ALREADY_SENT = 0 DO WHILE (IERR.EQ.-1) IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN CALL CMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, & LCONT, NASS, NPIV, IW( IOLDPS + H_INODE + NPIV ), & IW( IOLDPS + H_INODE + NPIV + NFRONT ), & A( OPSFAC ), PACKED_CB, & MSGDEST, MSGTAG, COMM, KEEP, IERR ) ELSE IF ( TYPE.EQ.2 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ELSE INIV2 = -9999 ENDIF CALL CMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, & FPERE, INODE, & NBROW_SEND, IW(IOLDPS + H_INODE + NPIV ), & NBCOL, IW(IOLDPS + H_INODE + NPIV + NFRONT ), & A(OPSFAC), LDA, NELIM, TYPE, & NSLAVES, IW(IOLDPS+6+KEEP(IXSZ)), MSGDEST, & COMM, IERR, & & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) END IF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IOLDPS = PTLUST_S(STEP( INODE )) OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) END DO IF ( IERR .EQ. -2 .OR. IERR .EQ. -3 ) THEN IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN IERROR = ( 2*LCONT + 9 ) * KEEP( 34 ) + & LCONT*LCONT * KEEP( 35 ) ELSE IF (KEEP(50).ne.0 .AND. TYPE .eq. 2 ) THEN IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) & * KEEP( 34 ) + & NBROW_SEND*NBROW_SEND*KEEP( 35 ) ELSE IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) * KEEP( 34 ) + & NBROW_SEND*NBCOL*KEEP( 35 ) ENDIF IF (IERR .EQ. -2) THEN IFLAG = -17 IF ( LP > 0 ) THEN WRITE(LP, *) MYID, & ": FAILURE, SEND BUFFER TOO SMALL DURING & CMUMPS_FAC_STACK", TYPE, TYPEF ENDIF ENDIF IF (IERR .EQ. -3) THEN IFLAG = -20 IF ( LP > 0 ) THEN WRITE(LP, *) MYID, & ": FAILURE, RECV BUFFER TOO SMALL DURING & CMUMPS_FAC_STACK", TYPE, TYPEF ENDIF ENDIF GOTO 600 ENDIF ENDIF IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID ) THEN NBROW_SEND = 0 LREQI = 2 + KEEP(IXSZ) NBROW_STACK = NBROW NBROW_INDICES = NBROW IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN NBCOL_STACK = NELIM ELSE NBCOL_STACK = NBCOL ENDIF IF (COMPRESS_CB) THEN NBROW_STACK=NELIM IF (KEEP(50).NE.0) NBCOL_STACK = NELIM ENDIF ELSE NBROW_STACK = NBROW-NBROW_SEND NBROW_INDICES = NBROW-NBROW_SEND NBCOL_STACK = NBCOL IF (COMPRESS_CB) THEN NBROW_STACK = 0 NBCOL_STACK = 0 ENDIF LREQI = 6 + NBROW_INDICES + NBCOL + KEEP(IXSZ) IF (.NOT. (TYPE.EQ.1 .AND. TYPEF.EQ.2 ) ) GOTO 190 IF (FPERE.EQ.0) GOTO 190 ENDIF IF (PACKED_CB) THEN IF (NBROW_STACK.EQ.0.OR.NBCOL_STACK.EQ.0) THEN LREQCB = 0 ELSE LREQCB = ( int(NBCOL_STACK,8) * int( NBCOL_STACK + 1, 8) ) / 2_8 & - ( int(NBROW_SEND ,8) * int( NBROW_SEND + 1, 8) ) / 2_8 ENDIF ELSE LREQCB = int(NBROW_STACK,8) * int(NBCOL_STACK,8) ENDIF INPLACE = ( KEEP(234).NE.0 ) IF (KEEP(50).NE.0 .AND. TYPE .EQ. 2) INPLACE = .FALSE. INPLACE = INPLACE .OR. .NOT. MUST_COMPACT_FACTORS INPLACE = INPLACE .AND. & ( PTLUST_S(STEP(INODE)) + INTSIZ .EQ. IWPOS ) MIN_SPACE_IN_PLACE = 0_8 IF ( INPLACE .AND. KEEP(50).eq. 0 .AND. & MUST_COMPACT_FACTORS) THEN MIN_SPACE_IN_PLACE = int(NBCOL_STACK,8) ENDIF IF ( MIN_SPACE_IN_PLACE .GT. LREQCB ) THEN INPLACE = .FALSE. ENDIF CALL CMUMPS_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, .FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER,PAMASTER, & LREQI, LREQCB, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, LRLUSM, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 600 IW(IWPOSCB+1+XXF) = IW(IOLDPS+XXF) IW(IWPOSCB+1+XXLR) = IW(IOLDPS+XXLR) PTRIST(STEP(INODE)) = IWPOSCB+1 IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID ) THEN PIMASTER (STEP(INODE)) = PTLUST_S(STEP(INODE)) PAMASTER(STEP(INODE)) = IPTRLU + 1_8 PTRAST(STEP(INODE)) = -99999999_8 IW(IWPOSCB+1+KEEP(IXSZ)) = min(-NBCOL_STACK,-1) IW(IWPOSCB+2+KEEP(IXSZ)) = NBROW_STACK IF (PACKED_CB) IW(IWPOSCB+1+XXS) = S_CB1COMP ELSE PTRAST(STEP(INODE)) = IPTRLU+1_8 IF (PACKED_CB) IW(IWPOSCB+1+XXS)=S_CB1COMP IW(IWPOSCB+1+KEEP(IXSZ)) = NBCOL IW(IWPOSCB+2+KEEP(IXSZ)) = 0 IW(IWPOSCB+3+KEEP(IXSZ)) = NBROW_STACK IW(IWPOSCB+4+KEEP(IXSZ)) = 0 IW(IWPOSCB+5+KEEP(IXSZ)) = 1 IW(IWPOSCB+6+KEEP(IXSZ)) = 0 IOLDP1 = PTLUST_S(STEP(INODE))+H_INODE PTROWEND = IWPOSCB+6+NBROW_STACK+KEEP(IXSZ) DO I = 1, NBROW_STACK IW(IWPOSCB+7+KEEP(IXSZ)+I-1) = & IW(IOLDP1+NFRONT-NBROW_STACK+I-1) ENDDO DO I = 1, NBCOL IW(PTROWEND+I)=IW(IOLDP1+NFRONT+NPIV+I-1) ENDDO END IF IF ( KEEP(50).NE.0 .AND. TYPE .EQ. 1 & .AND. MUST_COMPACT_FACTORS ) THEN POSELT = PTRFAC(STEP(INODE)) CALL CMUMPS_COMPACT_FACTORS_SYM( A(POSELT), LDA, & NPIV, NBROW, KEEP, & int(LDA,8)*int(NBROW+NPIV,8), & IW( PTLUST_S(STEP(INODE)) + H_INODE + NFRONT ) ) MUST_COMPACT_FACTORS = .FALSE. ENDIF IF (COMPRESS_CB.AND.(LREQCB.EQ.0)) GOTO 190 IF ( KEEP(50).EQ.0 .AND. MUST_COMPACT_FACTORS ) & THEN LAST_ALLOWED_POS = POSELT + int(LDA,8)*int(NPIV+NBROW-1,8) & + int(NPIV,8) ELSE LAST_ALLOWED_POS = -1_8 ENDIF NCBROW_ALREADY_MOVED = 0 COUNT_EXTRA_IP_COPIES = 0_8 10 CONTINUE NCBROW_PREVIOUSLY_MOVED = NCBROW_ALREADY_MOVED IF (IPTRLU .LT. POSFAC ) THEN CALL CMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, PACKED_CB, & LAST_ALLOWED_POS, NCBROW_ALREADY_MOVED ) ELSE CALL CMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, PACKED_CB ) NCBROW_ALREADY_MOVED = NBROW_STACK ENDIF IF (LAST_ALLOWED_POS .NE. -1_8) THEN MUST_COMPACT_FACTORS =.FALSE. IF ( NCBROW_ALREADY_MOVED .EQ. NBROW_STACK ) THEN IF (COMPRESS_CB) THEN NCBROW_ALREADY_MOVED = NBROW ELSE NCBROW_ALREADY_MOVED = NCBROW_ALREADY_MOVED + NBROW_SEND ENDIF ENDIF NCBROW_NEWLY_MOVED = NCBROW_ALREADY_MOVED & - NCBROW_PREVIOUSLY_MOVED FACTOR_POS = POSELT + & int(LDA,8)*int(NPIV+NBROW-NCBROW_ALREADY_MOVED,8) CALL CMUMPS_COMPACT_FACTORS_UNSYM( A(FACTOR_POS), LDA, NPIV, & NCBROW_NEWLY_MOVED, KEEP, & int(NCBROW_NEWLY_MOVED,8) * int(LDA,8) ) INEW = FACTOR_POS + int(NPIV,8) * int(NCBROW_NEWLY_MOVED,8) IOLD = INEW + int(NCBROW_NEWLY_MOVED,8) * int(NBCOL_STACK,8) DO I8 = 0_8, int(NCBROW_PREVIOUSLY_MOVED,8)*int(NPIV,8)-1 A(INEW) = A(IOLD) IOLD = IOLD + 1_8 INEW = INEW + 1_8 ENDDO COUNT_EXTRA_IP_COPIES = COUNT_EXTRA_IP_COPIES + & int(NCBROW_PREVIOUSLY_MOVED,8) & * int(NPIV,8) LAST_ALLOWED_POS = INEW IF (NCBROW_ALREADY_MOVED.LT.NBROW_STACK) THEN GOTO 10 ENDIF ENDIF IF ( COUNT_EXTRA_IP_COPIES .GT. 0_8 ) THEN !$OMP ATOMIC UPDATE KEEP8(8) = KEEP8(8) + COUNT_EXTRA_IP_COPIES !$OMP END ATOMIC COUNT_EXTRA_IP_COPIES = 0_8 ENDIF 190 CONTINUE IF (MUST_COMPACT_FACTORS) THEN POSELT = PTRFAC(STEP(INODE)) IF (KEEP(50).NE.0) THEN CALL CMUMPS_COMPACT_FACTORS_SYM( A(POSELT), LDA, & NPIV, NBROW, KEEP, & int(LDA,8)*int(NBROW+NPIV,8), & IW( PTLUST_S(STEP(INODE)) + H_INODE + NFRONT ) ) ELSE CALL CMUMPS_COMPACT_FACTORS_UNSYM( & A(POSELT+int(NPIV,8)*int(LDA,8)), & LDA, NPIV, NBROW, KEEP, int(NBROW,8)*int(LDA,8) ) ENDIF MUST_COMPACT_FACTORS = .FALSE. ENDIF IOLDPS = PTLUST_S(STEP(INODE)) IW(IOLDPS+KEEP(IXSZ)) = NBCOL IW(IOLDPS + 1+KEEP(IXSZ)) = NASS - NPIV IF (TYPE.EQ.2) THEN IW(IOLDPS + 2+KEEP(IXSZ)) = NASS ELSE IW(IOLDPS + 2+KEEP(IXSZ)) = NFRONT ENDIF IW(IOLDPS + 3+KEEP(IXSZ)) = NPIV IF (INPLACE) THEN SIZE_INPLACE = LREQCB - MIN_SPACE_IN_PLACE ELSE SIZE_INPLACE = 0_8 ENDIF CALL CMUMPS_COMPRESS_LU(SIZE_INPLACE,MYID,N,IOLDPS,TYPE, IW, LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, SSARBR,INODE,IERR & , LRGROUPS, NASS & ) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 GOTO 600 ENDIF 500 CONTINUE RETURN 600 CONTINUE IF (IFLAG .NE. -1 .AND. KEEP(405) .EQ. 0) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE CMUMPS_FAC_STACK MUMPS_5.8.1/src/mumps_scotch64.h0000664000175000017500000000721315042446422016262 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_SCOTCH64_H #define MUMPS_SCOTCH64_H #include "mumps_common.h" #if defined(scotch) || defined(ptscotch) #include "scotch.h" /* Instead of the prototypes below, one could include esmumps.h, * when provided in include directory of scotch installation */ #if ((SCOTCH_VERSION == 6) && (SCOTCH_RELEASE >= 1)) || (SCOTCH_VERSION >= 7) /* esmumpsv prototype with weights of nodes in the graph are used on entry (nv) */ MUMPS_INT esmumpsv( const MUMPS_INT8 n, const MUMPS_INT8 iwlen, MUMPS_INT8 * const pe, const MUMPS_INT8 pfree, MUMPS_INT8 * const len, MUMPS_INT8 * const iw, MUMPS_INT8 * const nv, MUMPS_INT8 * const elen, MUMPS_INT8 * const last); #endif /* esmumps prototype (weights of nodes not used on entry) */ MUMPS_INT esmumps( const MUMPS_INT8 n, const MUMPS_INT8 iwlen, MUMPS_INT8 * const pe, const MUMPS_INT8 pfree, MUMPS_INT8 * const len, MUMPS_INT8 * const iw, MUMPS_INT8 * const nv, MUMPS_INT8 * const elen, MUMPS_INT8 * const last); #if ((SCOTCH_VERSION == 7) && (SCOTCH_RELEASE >= 1)) || (SCOTCH_VERSION >= 8) /* prototypes with contexts */ MUMPS_INT esmumpsvc( const MUMPS_INT8 n, const MUMPS_INT8 iwlen, MUMPS_INT8 * const pe, const MUMPS_INT8 pfree, MUMPS_INT8 * const len, MUMPS_INT8 * const iw, MUMPS_INT8 * const nv, MUMPS_INT8 * const elen, MUMPS_INT8 * const last, SCOTCH_Context * const esmumpscontext); MUMPS_INT esmumpsc( const MUMPS_INT8 n, const MUMPS_INT8 iwlen, MUMPS_INT8 * const pe, const MUMPS_INT8 pfree, MUMPS_INT8 * const len, MUMPS_INT8 * const iw, MUMPS_INT8 * const nv, MUMPS_INT8 * const elen, MUMPS_INT8 * const last, SCOTCH_Context * const esmumpscontext); #endif #define MUMPS_SCOTCH_ORD_64 \ F_SYMBOL(scotch_ord_64,SCOTCH_ORD_64) void MUMPS_CALL MUMPS_SCOTCH_ORD_64( const MUMPS_INT8 * const n, const MUMPS_INT8 * const iwlen, MUMPS_INT8 * const petab, const MUMPS_INT8 * const pfree, MUMPS_INT8 * const lentab, MUMPS_INT8 * const iwtab, MUMPS_INT8 * const nvtab, MUMPS_INT8 * const elentab, MUMPS_INT8 * const lasttab, MUMPS_INT * const ncmpa, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) SCOTCH_Context * const contextptr, #endif MUMPS_INT * const weightused, MUMPS_INT * const weightrequested ); #define MUMPS_SCOTCH_64 \ F_SYMBOL(scotch_64,SCOTCH_64) void MUMPS_CALL MUMPS_SCOTCH_64( const MUMPS_INT8 * const n, const MUMPS_INT8 * const iwlen, MUMPS_INT8 * const petab, const MUMPS_INT8 * const pfree, MUMPS_INT8 * const lentab, MUMPS_INT8 * const iwtab, MUMPS_INT8 * const nvtab, MUMPS_INT8 * const elentab, MUMPS_INT8 * const lasttab, MUMPS_INT * const ncmpa, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) SCOTCH_Context * const contextptr, #endif MUMPS_INT * const weightused, MUMPS_INT * const weightrequested ); #endif #endif MUMPS_5.8.1/src/smumps_iXamax.F0000664000175000017500000000131315042446437016176 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C INTEGER FUNCTION SMUMPS_IXAMAX(N,X,INCX,GRAIN) IMPLICIT NONE REAL, intent(in) :: X(*) INTEGER, intent(in) :: INCX,N INTEGER, intent(in) :: GRAIN INTEGER isamax SMUMPS_IXAMAX = isamax(N,X,INCX) RETURN END FUNCTION SMUMPS_IXAMAX MUMPS_5.8.1/src/dana_aux.F0000664000175000017500000043073215042446437015136 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if defined(__ve__) #if defined(VHOFFLOAD) #include 've.h' #endif #endif MODULE DMUMPS_ANA_AUX_M IMPLICIT NONE CONTAINS SUBROUTINE DMUMPS_ANA_F(N, NZ8, IRN, ICN, LIWALLOC, & IKEEP1, IKEEP2, IKEEP3, & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, & CNTL4, COLSCA, ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , METIS_OPTIONS #endif & , NORIG_ARG, SIZEOFBLOCKS, GCOMP_PROVIDED_IN, GCOMP & ) USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY : COMPACT_GRAPH_T IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR, NSLAVES INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: LIWALLOC INTEGER, INTENT(in) :: LISTVAR_SCHUR(:) INTEGER, POINTER :: IRN(:), ICN(:) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: INFO(80), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(OUT) :: NFSIZ(:), FILS(:), FRERE(:) INTEGER, INTENT(INOUT) :: PIV(:) INTEGER, INTENT(INOUT) :: IKEEP1(:), IKEEP2(:), IKEEP3(:) DOUBLE PRECISION :: CNTL4 DOUBLE PRECISION, POINTER :: COLSCA(:), ROWSCA(:) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER, INTENT(IN) :: METIS_OPTIONS(40) #endif INTEGER, INTENT(IN), OPTIONAL :: NORIG_ARG INTEGER, INTENT(IN), TARGET, OPTIONAL :: SIZEOFBLOCKS(N) LOGICAL, INTENT(IN), OPTIONAL :: GCOMP_PROVIDED_IN TYPE(COMPACT_GRAPH_T), OPTIONAL :: GCOMP INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: IWALLOC INTEGER, DIMENSION(:), POINTER :: IW INTEGER(8), DIMENSION(:), ALLOCATABLE, TARGET :: IPEALLOC INTEGER(8), DIMENSION(:), POINTER :: IPE INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8 INTEGER, DIMENSION(:,:), ALLOCATABLE :: PTRAR INTEGER, DIMENSION(:), ALLOCATABLE :: PARENT INTEGER, DIMENSION(:), ALLOCATABLE :: IWL1 INTEGER NBBUCK INTEGER, DIMENSION(:), ALLOCATABLE :: WTEMP INTEGER IERR INTEGER I, K, NCMPA, IN, IFSON INTEGER(8) :: J8, I8 INTEGER :: NORIG INTEGER(8) :: IFIRST, ILAST INTEGER(8) IWFR8 INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry INTEGER NBQD, AvgDens LOGICAL PROK, COMPRESS_SCHUR, LPOK, COMPUTE_PERM #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) INTEGER NUMFLAG #endif INTEGER METIS_IDX_SIZE INTEGER OPT_METIS_SIZE #endif #if defined(scotch) || defined(ptscotch) INTEGER :: SCOTCH_INT_SIZE #endif #if defined(pord) INTEGER :: PORD_INT_SIZE #endif DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: COLSCA_TEMP INTEGER THRESH, IVersion LOGICAL AGG6 INTEGER MINSYM PARAMETER (MINSYM=50) INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) INTEGER MTRANS, COMPRESS,NCMP,IERROR,J,JPERM,NCST INTEGER TOTEL INTEGER NFR #if defined(pord) INTEGER TOTW #endif INTEGER WEIGHTUSED #if defined(scotch) || defined(ptscotch) INTEGER WEIGHTREQUESTED #endif INTEGER HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & NBSONS_Scalapack_CAND LOGICAL SCOTCH_SYMBOLIC LOGICAL IDENT,SPLITROOT LOGICAL FREE_CENTRALIZED_MATRIX LOGICAL GCOMP_PROVIDED LOGICAL INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH INTEGER(8) :: LIW8, NZG8 DOUBLE PRECISION TIMEB INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR INTEGER, TARGET :: IDUMMY_ARRAY(1) INTEGER :: LSIZEOFBLOCKS_PTR LOGICAL :: SIZEOFBLOCKS_AVAIL #if defined (MUMPS_SCOTCHIMPORTOMPTHREADS) INTEGER :: ESMUMPSCONTEXT #endif EXTERNAL MUMPS_ANA_H, DMUMPS_ANA_J, & DMUMPS_ANA_K, DMUMPS_ANA_GNEW, & DMUMPS_ANA_LNEW, DMUMPS_ANA_M EXTERNAL DMUMPS_GNEW_SCHUR EXTERNAL DMUMPS_LDLT_COMPRESS, DMUMPS_EXPAND_PERMUTATION, & DMUMPS_SET_CONSTRAINTS ALLOCATE( IWL1 (N), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF ALLOCATE( PTRAR (N,3), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 3*N GOTO 90 ENDIF SCOTCH_SYMBOLIC=(KEEP(270).EQ.0) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL MUMPS_SCOTCH_ESMUMPSCONTEXT( ESMUMPSCONTEXT ) SCOTCH_SYMBOLIC=SCOTCH_SYMBOLIC .AND. (ESMUMPSCONTEXT.EQ.1) #endif symmetry = INFO(8) NBQD = 0 GCOMP_PROVIDED=.FALSE. WEIGHTUSED = 0 NORIG = N IF (present(NORIG_ARG)) THEN NORIG=NORIG_ARG ENDIF IF (present(GCOMP_PROVIDED_IN)) & GCOMP_PROVIDED = GCOMP_PROVIDED_IN IF (GCOMP_PROVIDED.AND.(.NOT. present(GCOMP))) THEN INFO(1) = -900 WRITE(6,*) " INTERNAL ERROR in MUMPS(ANA_F) ", & GCOMP_PROVIDED_IN, present(GCOMP) INFO(2) = 1 RETURN ENDIF IF (GCOMP_PROVIDED) THEN NZG8 = GCOMP%NZG LIW8 = NZG8 + int(GCOMP%NG,8)+1_8 IW => GCOMP%ADJ(1:LIW8) IPE => GCOMP%IPE(1:GCOMP%NG+1) DO I=1,GCOMP%NG PTRAR(I,2) = int(IPE(I+1)-IPE(I)) ENDDO ELSE IF (LIWALLOC.GT.0_8) THEN ALLOCATE( IWALLOC (LIWALLOC), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(LIWALLOC,INFO(2)) GOTO 90 ENDIF ENDIF IF ( LIWALLOC.EQ.0_8 ) THEN INFO(1) = -900 WRITE(6,*) " INTERNAL ERROR in MUMPS(ANA_F) ", & "LIWALLOC, GCOMP_PROVIDED=", LIWALLOC, GCOMP_PROVIDED INFO(2) = 2 RETURN ENDIF LIW8 = LIWALLOC NZG8 = NZ8 IW => IWALLOC(1:LIW8) ALLOCATE( IPEALLOC(N+1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (N+1)*KEEP(10) GOTO 90 ENDIF IPE => IPEALLOC(1:N+1) ENDIF LP = ICNTL(1) MP = ICNTL(3) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) LDIAG = ICNTL(4) COMPRESS_SCHUR = .FALSE. IF (present(SIZEOFBLOCKS)) THEN SIZEOFBLOCKS_PTR => SIZEOFBLOCKS(1:N) LSIZEOFBLOCKS_PTR = N SIZEOFBLOCKS_AVAIL = .TRUE. ELSE SIZEOFBLOCKS_PTR => IDUMMY_ARRAY SIZEOFBLOCKS_AVAIL = .FALSE. LSIZEOFBLOCKS_PTR = 1 IDUMMY_ARRAY(1) = -1 ENDIF IF (PROK) THEN IF (present(GCOMP)) THEN WRITE(MP,'(A,I10,A,I13,A)') " Processing a graph of size:", N & ," with ", GCOMP%NZG, " edges" ELSE WRITE(MP,'(A,I10)') " Processing a graph of size:", N ENDIF ENDIF IF (GCOMP_PROVIDED) THEN FREE_CENTRALIZED_MATRIX = .FALSE. ELSE FREE_CENTRALIZED_MATRIX = ( & (KEEP(54).EQ.3).AND. & (KEEP(494).EQ.0).AND. & (KEEP(106).NE.3) & ) ENDIF INPLACE64_GRAPH_COPY = .FALSE. INPLACE64_RESTORE_GRAPH = .TRUE. IF (KEEP(1).LT.0) KEEP(1) = 0 NEMIN = KEEP(1) IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (present(SIZEOFBLOCKS)) THEN K = min(10,GCOMP%NG) IF (LDIAG.EQ.4) K = GCOMP%NG WRITE (MP,99909) N, NZG8, INFO(1) I8= 0_8 WRITE(MP,'(A)') " Graph adjacency " DO J=1, K IFIRST = GCOMP%IPE(J) ILAST= min(GCOMP%IPE(J+1)-1,GCOMP%IPE(J)+K-1) write(MP,'(A,I10)') " .... node/column:", J write(MP,'(8X,10I9)') & (GCOMP%ADJ(I8),I8=IFIRST,ILAST) ENDDO ELSE J8 = min(NZG8, 10_8) IF (LDIAG .EQ.4) J8 = NZG8 WRITE (MP,99999) N, NZG8, LIW8, INFO(1) IF (J8.GT.0_8) WRITE (MP,99998) (IRN(I8),ICN(I8),I8=1_8,J8) ENDIF K = min(10,N) IF (LDIAG.EQ.4) K = N IF (IORD.EQ.1 .AND. K.GT.0) THEN WRITE (MP,99997) (IKEEP1(I),I=1,K) ENDIF ENDIF NCMP = N IF (KEEP(60).NE.0) THEN IF ((SIZE_SCHUR.LE.0 ).OR. & (SIZE_SCHUR.GE.N) ) GOTO 90 ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF ( ( KEEP(60).NE.0).AND.(SIZE_SCHUR.GT.0) & .AND. & ((IORD.EQ.7).OR.(IORD.EQ.5)) & )THEN COMPRESS_SCHUR=.TRUE. NCMP = N-SIZE_SCHUR ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL DMUMPS_GNEW_SCHUR(N,NCMP,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, & KEEP(264), KEEP(265), & LISTVAR_SCHUR(1), SIZE_SCHUR, FRERE(1), FILS(1), & INPLACE64_GRAPH_COPY) INFO(8) = symmetry INPLACE64_GRAPH_COPY = INPLACE64_GRAPH_COPY.AND. & (.NOT.FREE_CENTRALIZED_MATRIX) DEALLOCATE(IPQ8) IORD = 5 KEEP(95) = 1 NBQD = 0 ELSE #endif IF (GCOMP_PROVIDED) THEN IWFR8 = GCOMP%NZG+1_8 ELSE ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF CALL DMUMPS_ANA_GNEW(N,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, KEEP(264), KEEP(265), & .TRUE., INPLACE64_GRAPH_COPY) INFO(8) = symmetry INPLACE64_GRAPH_COPY = INPLACE64_GRAPH_COPY.AND. & (.NOT.FREE_CENTRALIZED_MATRIX) DEALLOCATE(IPQ8) ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif IF(NBQD .GT. 0) THEN IF( KEEP(50) .EQ. 2 .AND. ICNTL(12) .EQ. 0 ) THEN IF(KEEP(95) .NE. 1) THEN IF ( PROK ) & WRITE( MP,*) & 'Compressed/constrained ordering set OFF' KEEP(95) = 1 ENDIF ENDIF ENDIF IF ( (KEEP(60).NE.0) .AND. (IORD.GT.1) .AND. & .NOT. COMPRESS_SCHUR ) THEN IORD = 0 ENDIF IF ( (KEEP(50).EQ.2) & .AND. (KEEP(95) .EQ. 3) & .AND. (IORD .EQ. 7) ) THEN IORD = 2 ENDIF CALL MUMPS_SET_ORDERING( NORIG, KEEP, & KEEP(50), NSLAVES, IORD, & NBQD, AvgDens, & PROK, MP ) IF(KEEP(50) .EQ. 2) THEN IF(KEEP(95) .EQ. 3 .AND. IORD .NE. 2) THEN IF (PROK) WRITE(MP,*) & 'WARNING: DMUMPS_ANA_F constrained ordering not '// & ' available with selected ordering. Move to' // & ' compressed ordering.' KEEP(95) = 2 ENDIF ELSE KEEP(95) = 1 ENDIF MTRANS = KEEP(23) COMPRESS = KEEP(95) - 1 IF(COMPRESS .GT. 0 .AND. KEEP(52) .EQ. -2) THEN IF(CNTL4 .GE. 0.0D0) THEN IF (KEEP(1).LE.8) THEN NEMIN = 16 ELSE NEMIN = 2*KEEP(1) ENDIF ENDIF ENDIF IF(MTRANS .GT. 0 .AND. KEEP(50) .EQ. 2) THEN KEEP(23) = 0 ENDIF IF (COMPRESS .EQ. 2) THEN IF (IORD.NE.2) THEN WRITE(*,*) "IORD not compatible with COMPRESS:", & IORD, COMPRESS CALL MUMPS_ABORT() ENDIF CALL DMUMPS_SET_CONSTRAINTS( & N,PIV(1),FRERE(1),FILS(1),NFSIZ(1),IKEEP1(1), & NCST,KEEP,KEEP8, ROWSCA(1) & ) ENDIF IF ( IORD .NE. 1 ) THEN IF (COMPRESS .GE. 1) THEN ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL DMUMPS_LDLT_COMPRESS( & N, NZ8, IRN(1), ICN(1), PIV(1), & NCMP, IW(1), LIW8, IPE(1), PTRAR(1,2), IPQ8, & IWL1, FILS(1), IWFR8, & IERROR, KEEP, KEEP8, ICNTL, INPLACE64_GRAPH_COPY) DEALLOCATE(IPQ8) symmetry = 100 ENDIF IF ( (symmetry.LT.MINSYM).AND.(KEEP(50).EQ.0) ) THEN IF(KEEP(23) .EQ. 7 ) THEN KEEP(23) = -5 GOTO 90 ELSE IF(KEEP(23) .EQ. -9876543) THEN IDENT = .TRUE. KEEP(23) = 5 IF (PROK) WRITE(MP,'(A)') & ' ... Apply column permutation (already computed)' DO J=1,N JPERM = PIV(J) FILS(JPERM) = J IF (JPERM.NE.J) IDENT = .FALSE. ENDDO IF (.NOT.IDENT) THEN DO J8=1_8,NZ8 J = ICN(J8) IF ((J.LE.0).OR.(J.GT.N)) CYCLE ICN(J8) = FILS(J) ENDDO ALLOCATE(COLSCA_TEMP(N), stat=IERR) IF ( IERR > 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF DO J = 1, N COLSCA_TEMP(J)=COLSCA(J) ENDDO DO J=1, N COLSCA(FILS(J))=COLSCA_TEMP(J) ENDDO DEALLOCATE(COLSCA_TEMP) IF (PROK) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL DMUMPS_ANA_GNEW & (N,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264), KEEP(265), & .TRUE.,INPLACE64_GRAPH_COPY) INFO(8) = symmetry DEALLOCATE(IPQ8) NCMP = N ELSE KEEP(23) = 0 ENDIF ENDIF ELSE IF (KEEP(23) .EQ. 7 .OR. KEEP(23) .EQ. -9876543 ) THEN IF (PROK) WRITE(MP,'(A)') & ' ... No column permutation' KEEP(23) = 0 ENDIF ENDIF IF (FREE_CENTRALIZED_MATRIX & .AND.COMPRESS.EQ.0.AND.(.NOT.COMPRESS_SCHUR)) THEN deallocate(IRN) NULLIFY(IRN) deallocate(ICN) NULLIFY(ICN) ENDIF INPLACE64_RESTORE_GRAPH = & INPLACE64_RESTORE_GRAPH.AND.(COMPRESS.NE.1) ALLOCATE( PARENT ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF IF (IORD.NE.1 .AND. IORD.NE.5) THEN IF ( KEEP(60) .NE. 0 ) THEN IORD = 0 ENDIF IF (PROK) THEN IF (IORD.EQ.2) THEN WRITE(MP,'(A)') ' Ordering based on AMF ' #if defined(scotch) || defined(ptscotch) ELSE IF (IORD.EQ.3) THEN WRITE(MP,'(A)') ' Ordering based on SCOTCH ' #endif #if defined(pord) ELSE IF (IORD.EQ.4) THEN WRITE(MP,'(A)') ' Ordering based on PORD ' #endif ELSE IF (IORD.EQ.6) THEN WRITE(MP,'(A)') ' Ordering based on QAMD ' ELSE WRITE(MP,'(A)') ' Ordering based on AMD ' ENDIF ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF IF ( KEEP(60) .NE. 0 ) THEN CALL MUMPS_HAMD(N, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP1(1), & IKEEP2(1), NCMPA, FILS(1), IKEEP3(1), & PTRAR, PTRAR(1,3), & PARENT, & LISTVAR_SCHUR(1), SIZE_SCHUR) IF (KEEP(60)==1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ELSE IF ( .FALSE. ) THEN #if defined(pord) ELSEIF (IORD .EQ. 4) THEN CALL MUMPS_PORD_INTSIZE(PORD_INT_SIZE) TOTW = N IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) & ) THEN IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IF & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) THEN TOTW = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF IF (PORD_INT_SIZE .EQ. 64) THEN CALL MUMPS_PORDF_WND_MIXEDto64(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, TOTW, PARENT, & INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY & ) ELSE IF (PORD_INT_SIZE .EQ. 32) THEN CALL MUMPS_PORDF_WND_MIXEDto32(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, TOTW, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE WRITE(*,*) & "Internal error in PORD wrappers, PORD_INT_SIZE=", & PORD_INT_SIZE CALL MUMPS_ABORT() ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 GOTO 90 ENDIF IF (INFO(1) .LT.0) GOTO 90 IF (COMPRESS.EQ.1) THEN CALL DMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS(1)) CALL DMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP1(1), & FRERE(1),PTRAR(1,1)) DO I=1,NCMP IKEEP2(IKEEP1(I))=I ENDDO ENDIF ELSE IF (PORD_INT_SIZE.EQ.64) THEN CALL MUMPS_PORDF_MIXEDto64(NCMP, IWFR8-1_8, IPE, & IW, & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY & ) ELSE IF (PORD_INT_SIZE.EQ.32) THEN CALL MUMPS_PORDF_MIXEDto32(NCMP, IWFR8-1_8, IPE, & IW, & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE WRITE(*,*) & "Internal error in PORD wrappers, PORD_INT_SIZE=", & PORD_INT_SIZE CALL MUMPS_ABORT() ENDIF ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 GOTO 90 ENDIF IF (INFO(1) .LT. 0) GOTO 90 #endif #if defined(scotch) || defined(ptscotch) ELSEIF (IORD .EQ. 3) THEN CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE) IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) & ) THEN WEIGHTREQUESTED=1 IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IF & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) THEN DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF ELSE WEIGHTREQUESTED = 0 DO I= 1, N IWL1(I) = 1 ENDDO ENDIF IF (SCOTCH_INT_SIZE.EQ.32) THEN IF (KEEP(10).EQ.1) THEN INFO(1) = -52 INFO(2) = 2 ELSE CALL MUMPS_SCOTCH_MIXEDto32(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, & WEIGHTUSED, WEIGHTREQUESTED, SCOTCH_SYMBOLIC) ENDIF ELSE IF (SCOTCH_INT_SIZE.EQ.64) THEN CALL MUMPS_SCOTCH_MIXEDto64(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH, & WEIGHTUSED, WEIGHTREQUESTED, SCOTCH_SYMBOLIC) ELSE WRITE(*,*) & "Internal error in SCOTCH wrappers, SCOTCH_INT_SIZE=", & SCOTCH_INT_SIZE CALL MUMPS_ABORT() ENDIF IF (INFO(1) .LT. 0) GOTO 90 IF (.NOT. SCOTCH_SYMBOLIC) THEN IF ( COMPRESS .EQ. 1 ) THEN CALL DMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94), & KEEP(93),PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF ELSE IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS).AND. & (WEIGHTUSED.EQ.0) ) & ) THEN CALL DMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS(1)) CALL DMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP1(1), & FRERE(1),PTRAR(1,1)) DO I=1,NCMP IKEEP2(IKEEP1(I))=I ENDDO ENDIF #endif ELSEIF (IORD .EQ. 2) THEN NBBUCK = 2*N COMPUTE_PERM=.FALSE. IF(COMPRESS .GE. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.GE.1) THEN CALL MUMPS_ABORT() ENDIF NBBUCK = max(NBBUCK, NORIG-N) NBBUCK = max(NBBUCK, 2*NORIG) NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF ALLOCATE( WTEMP ( 0: NBBUCK + 1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = NBBUCK+2 GOTO 90 ENDIF IF(COMPRESS .LE. 1) THEN CALL MUMPS_HAMF4 & (TOTEL, NCMP, COMPUTE_PERM, NBBUCK, LIW8, IPE(1), & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), WTEMP, PARENT(1)) ELSE IF(PROK) WRITE(MP,'(A)') & ' Constrained Ordering based on AMF' CALL MUMPS_CST_AMF(NCMP, NBBUCK, LIW8, IPE(1), & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), WTEMP, & NFSIZ(1), FRERE(1), PARENT(1)) ENDIF DEALLOCATE(WTEMP) ELSEIF (IORD .EQ. 6) THEN ALLOCATE( WTEMP ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF THRESH = 1 IVersion = 2 COMPUTE_PERM=.FALSE. IF(COMPRESS .EQ. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.EQ.1) THEN CALL MUMPS_ABORT() ENDIF NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL MUMPS_QAMD & (TOTEL,COMPUTE_PERM,IVersion, THRESH, WTEMP, & NCMP, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), PARENT(1)) DEALLOCATE(WTEMP) ELSE COMPUTE_PERM=.FALSE. IF(COMPRESS .EQ. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.EQ.1) THEN CALL MUMPS_ABORT() ENDIF NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL MUMPS_ANA_H(TOTEL, COMPUTE_PERM, & NCMP, LIW8, IPE(1), IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), PARENT(1)) ENDIF ENDIF IF(COMPRESS .GE. 1) THEN CALL DMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94),KEEP(93), & PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) #if defined(scotch) || defined(ptscotch) IF (IORD.EQ.3) THEN WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME SPENT IN SCOTCH reordering =', TIMEB ENDIF #endif ENDIF ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MP,'(A)') ' Ordering based on METIS' ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN INFO(1) = -52 INFO(2) = 1 GOTO 90 ENDIF #if defined(metis4) || defined(parmetis3) NUMFLAG = 1 OPT_METIS_SIZE = 8 #else OPT_METIS_SIZE = 40 #endif IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 FRERE(I) = 2 ENDDO DO I=KEEP(93)/2+1,NCMP FRERE(I) = 1 ENDDO #if defined(metis4) || defined(parmetis3) IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEWND_MIXEDto32( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ELSE IF ((NORIG.NE.N).AND.present(SIZEOFBLOCKS)) THEN DO I=1, N FRERE(I) = SIZEOFBLOCKS(I) ENDDO IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEWND_MIXEDto32( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ELSE IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW, NUMFLAG, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW, NUMFLAG, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP,LPOK,KEEP(10), & LIW8, INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ENDIF ENDIF #else ELSE IF (present(SIZEOFBLOCKS)) THEN DO I=1,N FRERE(I) = SIZEOFBLOCKS(I) ENDDO ELSE DO I=1,NCMP FRERE(I) = 1 ENDDO ENDIF ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW, FRERE, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW, FRERE, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP,LPOK,KEEP(10), & LIW8, INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH) ELSE IF (LPOK) WRITE(LP,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF #endif IF (INFO(1) .LT.0) GOTO 90 IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME SPENT IN METIS reordering =', TIMEB ENDIF IF ( COMPRESS_SCHUR ) THEN CALL DMUMPS_EXPAND_PERM_SCHUR( & N, NCMP, IKEEP1(1),IKEEP2(1), & LISTVAR_SCHUR(1), SIZE_SCHUR, FILS(1)) COMPRESS = -1 ENDIF IF (COMPRESS .EQ. 1) THEN CALL DMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94), & KEEP(93),PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF ENDIF #endif IF (PROK) THEN IF (IORD.EQ.1) THEN WRITE(MP,'(A)') ' Ordering given is used' ENDIF ENDIF IF (IORD.EQ.1 .OR. IORD.EQ.5 .OR. COMPRESS.EQ.-1 & .OR. ( (IORD.EQ.3).AND.(.NOT.SCOTCH_SYMBOLIC) ) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) .AND.(IORD.EQ.3) & .AND. (WEIGHTUSED.EQ.0) & ) & ) THEN IF ((KEEP(106).EQ.1).OR.(KEEP(106).EQ.2).OR.(KEEP(106).EQ.4) & .OR.(KEEP(60).NE.0)) THEN IF ( COMPRESS .EQ. -1 ) THEN ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL DMUMPS_ANA_GNEW(N,NZ8,IRN(1),ICN(1),IW(1),LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264),KEEP(265), .TRUE., & INPLACE64_GRAPH_COPY) DEALLOCATE(IPQ8) ENDIF COMPRESS = 0 IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF IF (KEEP(106).EQ.2) THEN IF (PROK) THEN WRITE(MP,'(A)') " SYMBOLIC based on column counts " ENDIF IF (present(SIZEOFBLOCKS)) THEN DO I=1, N FRERE(I) = SIZEOFBLOCKS(I) ENDDO ELSE FRERE(1) = -1 ENDIF CALL MUMPS_WRAP_GINP94 ( & N, IPE(1), IW(1), IWFR8, & IKEEP1(1), & FRERE(1), & KEEP(60), LISTVAR_SCHUR(1), SIZE_SCHUR, & KEEP(378), & IWL1, PARENT, & IKEEP2(1), IKEEP3(1), NFSIZ(1), & PTRAR(1,1), PTRAR(1,2), PTRAR(1,3), & INFO ) IF (INFO(1).LT.0) GOTO 90 ELSE IF ((KEEP(106).EQ.4).AND.(KEEP(60).EQ.0).AND. & (.NOT.present(SIZEOFBLOCKS) .OR. (NORIG.EQ.N)) & ) THEN WRITE(MP,*) " Undefined option for ICNTL(58) " INFO(1)= -99998 GOTO 90 ELSE ALLOCATE( WTEMP ( 2_8*int(N,8) ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(2_8*int(N,8), INFO(2) ) GOTO 90 ENDIF THRESH = -1 IF (KEEP(60) == 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR ENDIF AGG6 =.FALSE. IF (present(SIZEOFBLOCKS)) THEN DO I=1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO TOTEL = NORIG ELSE IWL1(1) = -1 TOTEL = N ENDIF CALL MUMPS_SYMQAMD(THRESH, WTEMP, & N, TOTEL, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1(1), WTEMP(N+1), & IKEEP2(1), NCMPA, FILS(1), IKEEP3(1), PTRAR, & PTRAR(1,3),IKEEP1(1), LISTVAR_SCHUR(1), ITEMP, & AGG6, PARENT) DEALLOCATE(WTEMP) ENDIF IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME IN symbolic factorization =', TIMEB ENDIF ELSE CALL DMUMPS_ANA_J(N, NZ8, IRN(1), ICN(1), IKEEP1(1), IW(1), & LIW8, IPE(1), & PTRAR(1,2), IWL1, IWFR8, & INFO(1),INFO(2), MP) IF (KEEP(60) .EQ. 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR ENDIF CALL DMUMPS_ANA_K(N, IPE(1), IW(1), LIW8, IWFR8, IKEEP1(1), & IKEEP2(1), IWL1, & PTRAR, NCMPA, ITEMP, PARENT) ENDIF ENDIF IF (KEEP(60) .NE. 0) THEN IF (KEEP(60)==1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ENDIF IF (allocated(IPEALLOC)) DEALLOCATE(IPEALLOC) ALLOCATE(WTEMP(N), stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF CALL DMUMPS_ANA_LNEW & (N, PARENT, IWL1, IKEEP1(1), IKEEP2(1), IKEEP3(1), & NFSIZ(1), PTRAR, INFO(6), FILS(1), FRERE(1), & PTRAR(1,3), NEMIN, WTEMP, KEEP(60), & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), & ICNTL(13), KEEP(37), KEEP(197), NSLAVES, KEEP(250).EQ.1, & SIZEOFBLOCKS_AVAIL, SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR & , INODE_Scalapack_CAND, NBSONS_Scalapack_CAND, & KEEP(11), KEEP(191), KEEP(192), KEEP(193) & ) DEALLOCATE(WTEMP) IF (KEEP(60).NE.0) THEN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO WHILE (IN.GT.0) IN = FILS (IN) END DO IFSON = -IN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO I=2,SIZE_SCHUR FILS(IN) = LISTVAR_SCHUR (I) IN = FILS(IN) FRERE (IN) = N+1 ENDDO FILS(IN) = -IFSON ENDIF CALL DMUMPS_ANA_M(IKEEP2(1), & PTRAR(1,3), INFO(6), & INFO(5), KEEP(2), KEEP(50), & KEEP8(101), KEEP(108), KEEP(5), & KEEP(6), KEEP(226), KEEP(253)) KEEP(59) = INFO(5) IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) INODE_Scalapack_CAND = KEEP(20) NBSONS_Scalapack_CAND = 1 END IF IF ( (KEEP(48) == 4 .AND. KEEP8(21).GT.0_8) & .OR. & (KEEP (48)==5 .AND. KEEP8(21) .GT. 0_8 ) & .OR. & (KEEP(24).NE.0.AND.KEEP8(21).GT.0_8) ) THEN CALL DMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2), & KEEP(48), KEEP(50), NSLAVES) END IF IF (KEEP(210).LT.1.OR.KEEP(210).GT.2) KEEP(210)=2 IF (KEEP(210).EQ.2) KEEP8(79)=huge(KEEP8(79)) IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF IF (KEEP(11).EQ.0) THEN IF ( (KEEP(79).EQ.0).OR.(KEEP(79).EQ.2).OR. & (KEEP(79).EQ.3).OR.(KEEP(79).EQ.5).OR. & (KEEP(79).EQ.6) & ) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN CALL DMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF (PROK) THEN WRITE(MP,*) " Number of split nodes in pre-splitting=", & KEEP(61) ENDIF ENDIF ENDIF ENDIF ENDIF HOW_TO_SPLIT_ROOT = 0 SPLITROOT = ICNTL(13) .EQ. -1 IF (KEEP(11).GT.1) THEN NFR = NFSIZ(INODE_Scalapack_CAND) #if defined(NOSCALAPACK) SPLITROOT = SPLITROOT .OR. & ( NSLAVES.GT.0.AND. & ( dble(NFR) - dble(NFR)/dble(max(2,NSLAVES)) & .GT. dble(KEEP(9)) ) & ) #else SPLITROOT = SPLITROOT .OR. & ( ICNTL(13).GT.0 .AND. NSLAVES .GT. ICNTL(13). AND. & ( dble(NFR) - dble(NFR)/dble(max(2,NSLAVES)) & .GT. dble(KEEP(9)) ) & ) #endif ELSE #if defined(NOSCALAPACK) SPLITROOT = SPLITROOT .OR. NSLAVES.GT.0 #else SPLITROOT = SPLITROOT .OR. & (ICNTL(13).GT.0 .AND. NSLAVES .GT. ICNTL(13) & ) #endif ENDIF IF (SPLITROOT.AND.KEEP(11).GT.0) HOW_TO_SPLIT_ROOT =1 IF (KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. IF (KEEP(11).GT.0) HOW_TO_SPLIT_ROOT = 2 ENDIF #if defined(NOSCALAPACK) #else IF ( KEEP(11).GT.0) THEN IF (.NOT.SPLITROOT .AND. & (KEEP(60).EQ.0).AND. & ( (NFSIZ(INODE_Scalapack_CAND).GT.KEEP(37)) & .AND.(ICNTL(13).LE.0) ) & .AND. & (NBSONS_Scalapack_CAND.GT.KEEP(11)) & ) THEN HOW_TO_SPLIT_ROOT = 3 SPLITROOT=.TRUE. ENDIF ENDIF #endif SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) )) IF (SPLITROOT) THEN IF (KEEP(11).EQ.0) THEN CALL DMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) ENDIF ELSE CALL DMUMPS_SPLIT_ROOT( NSLAVES, & HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(1), KEEP8(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, INFO(6)) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN K = min(10,N) IF (LDIAG.EQ.4) K = N IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) ENDIF GO TO 90 90 CONTINUE IF (INFO(1) .NE. 0) THEN IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE (LP,99996) INFO(1), INFO(2) ENDIF IF (allocated(IWALLOC)) DEALLOCATE(IWALLOC) IF (allocated(IWL1)) DEALLOCATE(IWL1) IF (allocated(IPEALLOC)) DEALLOCATE(IPEALLOC) IF (allocated(PTRAR)) DEALLOCATE(PTRAR) IF (allocated(PARENT)) DEALLOCATE(PARENT) RETURN 99999 FORMAT (/'Entering ordering phase with ...'/ & ' N NNZ LIW INFO(1)'/, & 6X, I10, I11, I12, I10) 99998 FORMAT ('Matrix entries: IRN() ICN()'/ & (I12, I9, I12, I9, I12, I9)) 99909 FORMAT (/'Entering ordering phase with graph dimensions ...'/ & ' |V| |E| INFO(1)'/, & 10X, I10, I13, I10) 99997 FORMAT ('IKEEP1(.)=', 10I8/(12X, 10I8)) 99996 FORMAT & (/'** Error/warning return ** from Analysis * INFO(1:2)= ', & (I3, I16)) 99989 FORMAT ('FILS (.) =', 10I9/(11X, 10I9)) 99988 FORMAT ('FRERE(.) =', 10I9/(11X, 10I9)) 99987 FORMAT ('NFSIZ(.) =', 10I9/(11X, 10I9)) END SUBROUTINE DMUMPS_ANA_F SUBROUTINE DMUMPS_ANA_N_DIST( id, NBINCOL, NBINROW ) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_STRUC IMPLICIT NONE include 'mpif.h' TYPE(DMUMPS_STRUC), INTENT(INOUT), TARGET :: id INTEGER, INTENT(OUT), TARGET :: NBINCOL(:) INTEGER, INTENT(OUT), TARGET :: NBINROW(:) INTEGER :: IERR, allocok INTEGER :: IOLD, JOLD, INEW, JNEW INTEGER(8) :: K, INZ INTEGER, POINTER :: IIRN(:), IJCN(:) INTEGER, POINTER :: IWORK1(:), IWORK2(:) LOGICAL :: IDO IF(id%KEEP(54) .EQ. 3) THEN IIRN => id%IRN_loc IJCN => id%JCN_loc INZ = id%KEEP8(29) IWORK1 => NBINROW(1:id%N) allocate(IWORK2(id%N),stat=allocok) IF (allocok > 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%N RETURN ENDIF IDO = .TRUE. ELSE IIRN => id%IRN IJCN => id%JCN INZ = id%KEEP8(28) IWORK1 => NBINCOL(1:id%N) IWORK2 => NBINROW(1:id%N) IDO = id%MYID .EQ. 0 END IF DO 50 IOLD=1,id%N IWORK1(IOLD) = 0_8 IWORK2(IOLD) = 0_8 50 CONTINUE IF(IDO) THEN DO 70 K=1_8,INZ IOLD = IIRN(K) JOLD = IJCN(K) IF ( (IOLD.GT.id%N).OR.(JOLD.GT.id%N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) GOTO 70 IF (IOLD.NE.JOLD) THEN INEW = id%SYM_PERM(IOLD) JNEW = id%SYM_PERM(JOLD) IF ( id%KEEP( 50 ) .EQ. 0 ) THEN IF (INEW.LT.JNEW) THEN IWORK2(IOLD) = IWORK2(IOLD) + 1 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 (id%KEEP(54) .EQ. 3) THEN CALL MUMPS_BIGALLREDUCE(.FALSE., IWORK1(1), NBINCOL(1), id%N, & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) CALL MUMPS_BIGALLREDUCE(.FALSE., IWORK2(1), NBINROW(1), id%N, & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) deallocate(IWORK2) ELSE CALL MPI_BCAST( NBINCOL(1), id%N, MPI_INTEGER, & 0, id%COMM, IERR ) CALL MPI_BCAST( NBINROW(1), id%N, MPI_INTEGER, & 0, id%COMM, IERR ) END IF RETURN END SUBROUTINE DMUMPS_ANA_N_DIST SUBROUTINE DMUMPS_ANA_O( N, NZ, MTRANS, PERM, & IKEEPALLOC, LIKEEPALLOC, & idIRN, idJCN, idA, idROWSCA, idCOLSCA, WORK2, KEEP, & ICNTL, INFO, INFOG ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ INTEGER, INTENT(OUT) :: PERM(:) INTEGER, POINTER, DIMENSION(:) :: idIRN, idJCN DOUBLE PRECISION, POINTER, DIMENSION(:) :: idA DOUBLE PRECISION, POINTER, DIMENSION(:) :: idROWSCA, idCOLSCA INTEGER(8), INTENT(IN) :: LIKEEPALLOC INTEGER, TARGET :: IKEEPALLOC(LIKEEPALLOC) INTEGER, INTENT(INOUT) :: MTRANS INTEGER :: KEEP(500) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(INOUT) :: INFOG(80) INTEGER, TARGET :: WORK2(N) INTEGER :: allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: IW DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: S2 TARGET :: S2 INTEGER ICNTL64(10), INFO64(10) INTEGER ICNTL_SYM_MWM(10),INFO_SYM_MWM(10) DOUBLE PRECISION CNTL64(10) INTEGER MPRINT,LP, MP INTEGER JPERM INTEGER NUMNZ, I, J, JPOS LOGICAL PROK, IDENT, DUPPLI INTEGER K50, KER_SIZE, NZER_DIAG, MTRANSLOC,RZ_DIAG INTEGER(8) :: LIWG INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8 INTEGER :: LSC INTEGER(8) :: NZTOT, NZREAL, IPIW, LIW, LIWMIN, NZsave, & K, KPOS, LDW, LDWMIN, IRNW, RSPOS, CSPOS, & LS2,J8, N8 LOGICAL SCALINGLOC INTEGER,POINTER,DIMENSION(:) :: ZERODIAG INTEGER,POINTER,DIMENSION(:) :: STR_KER INTEGER,POINTER,DIMENSION(:) :: MARKED INTEGER,POINTER,DIMENSION(:) :: FLAG INTEGER,POINTER,DIMENSION(:) :: PIV_OUT DOUBLE PRECISION THEMIN, THEMAX, COLNORM,MAXDBL, ABSAK DOUBLE PRECISION ZERO,TWO,ONE PARAMETER(ZERO = 0.0D0,TWO = 2.0D0,ONE = 1.0D0) N8 = int(N,8) MPRINT = ICNTL(3) LP = ICNTL(1) MP = ICNTL(2) PROK = ((MPRINT.GT.0).AND.(ICNTL(4).GE.2)) K50 = KEEP(50) SCALINGLOC = .FALSE. IF(KEEP(52) .EQ. -2) THEN IF(.not.associated(idA)) THEN ELSE SCALINGLOC = .TRUE. ENDIF ELSE IF(KEEP(52) .EQ. 77) THEN SCALINGLOC = .TRUE. IF( MTRANS .NE. 5 .AND. MTRANS .NE. 6 & .AND. MTRANS .NE. 7) THEN SCALINGLOC = .FALSE. ENDIF IF(.not.associated(idA)) THEN SCALINGLOC = .FALSE. IF (PROK) & WRITE(MPRINT,*) 'Analysis: auto scaling OFF because ', & 'A not provided at analysis ' ENDIF ENDIF IF ( (KEEP(50).EQ.2).AND.(ICNTL(8).NE.-2).AND. & (MTRANS .EQ. 7 .OR. KEEP(95) .EQ. 0) ) THEN ZERODIAG => IKEEPALLOC(1:N) ZERODIAG = 0 NZER_DIAG = N RZ_DIAG = 0 DO K=1,NZ I = idIRN(K) J = idJCN(K) IF (I.NE.J) CYCLE IF ( (J.LE.N).AND.(J.GE.1) ) THEN IF(ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = 1 IF(associated(idA)) THEN ABSAK= abs(idA(K)) IF(ABSAK .EQ. dble(0.0D0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ENDIF NZER_DIAG = NZER_DIAG - 1 ENDIF ENDIF ENDDO IF( (NZER_DIAG+RZ_DIAG) .LT. max(1,(N/10)) ) THEN MTRANS = 0 KEEP(95) = 1 GOTO 500 ENDIF ENDIF IF(SCALINGLOC) THEN IF (PROK) WRITE(MPRINT,*) & 'Scaling will be computed during analysis' ENDIF IF( MTRANS.NE.0 .AND. (.NOT.associated(idA)) ) MTRANS=1 MTRANSLOC = MTRANS IF (MTRANS.LT.0 .OR. MTRANS.GT.7) GO TO 500 IF (K50 .EQ. 0) THEN IF(.NOT. SCALINGLOC .AND. MTRANS .EQ. 7) THEN GO TO 500 ENDIF IF(SCALINGLOC) THEN IF (MTRANSLOC.NE.6) THEN MTRANSLOC = 5 ENDIF ENDIF ELSE IF (MTRANS .EQ. 7) MTRANSLOC = 5 ENDIF IF(SCALINGLOC .AND. MTRANSLOC .NE. 5 .AND. & MTRANSLOC .NE. 6 ) THEN IF (PROK) WRITE(MPRINT,*) & 'WARNING scaling required: set MTRANS option to 5' MTRANSLOC = 5 ENDIF IF (N.EQ.1) THEN MTRANS = 0 KEEP(95) = 1 GO TO 500 ENDIF IF(K50 .NE. 0) THEN NZTOT = 2_8*NZ+N8 ELSE NZTOT = NZ ENDIF ZERODIAG => IKEEPALLOC(1:N) STR_KER => IKEEPALLOC(int(N+1,8):2_8*int(N,8)) CALL DMUMPS_MTRANSI(ICNTL64,CNTL64) ICNTL64(1) = ICNTL(1) ICNTL64(2) = ICNTL(2) ICNTL64(3) = ICNTL(3) ICNTL64(4) = -1 IF (ICNTL(4).EQ.3) ICNTL64(4) = 0 IF (ICNTL(4).EQ.4) ICNTL64(4) = 1 ICNTL64(5) = -1 IF (PROK) THEN WRITE(MPRINT,'(A,I3)') & 'Compute maximum matching (Maximum Transversal):', & MTRANSLOC IF (MTRANSLOC.EQ.1) & WRITE(MPRINT,'(A,I3)')' ... JOB =',MTRANSLOC IF (MTRANSLOC.EQ.2) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': BOTTLENECK THESIS' IF (MTRANSLOC.EQ.3) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': BOTTLENECK SIMAX' IF (MTRANSLOC.EQ.4) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': MAXIMIZE SUM DIAGONAL' IF (MTRANSLOC.EQ.5 .OR. MTRANSLOC.EQ.6) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC, & ': MAXIMIZE PRODUCT DIAGONAL AND SCALE' ENDIF INFOG(23) = MTRANSLOC CNTL64(2) = huge(CNTL64(2)) IRNW = 1 IPIW = IRNW + NZTOT IF (MTRANSLOC.EQ.1) LIWMIN = 5_8*N8 IF (MTRANSLOC.EQ.2) LIWMIN = 3_8*N8 IF (MTRANSLOC.EQ.3) LIWMIN = 10_8*N8 + NZTOT IF (MTRANSLOC.EQ.4) LIWMIN = 2_8*N8 IF (MTRANSLOC.EQ.5) LIWMIN = 5_8*N8 IF (MTRANSLOC.EQ.6) LIWMIN = 5_8*N8 + NZTOT LIW = LIWMIN LIWG = LIW + NZTOT ALLOCATE(IW(LIWG), stat=allocok) IF (allocok .GT. 0 ) THEN GOTO 410 ENDIF ALLOCATE( IPQ8(N), IPE(N+1), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR( (2_8*int(N,8)+1_8) * int(KEEP(10),8), & INFO(2) ) GOTO 500 ENDIF IF (MTRANSLOC.EQ.1) THEN LDWMIN = N8+3_8 ENDIF IF (MTRANSLOC.EQ.2) LDWMIN = max( N8+NZTOT , N8+3_8 ) IF (MTRANSLOC.EQ.3) LDWMIN = max( NZTOT+1_8 , N8+3_8 ) IF (MTRANSLOC.EQ.4) LDWMIN = 2_8 * N8 + & max( NZTOT , N8+3_8 ) IF (MTRANSLOC.EQ.5) LDWMIN = 3_8 * N8 + NZTOT IF (MTRANSLOC.EQ.6) LDWMIN = 4_8 * N8 + NZTOT LDW = LDWMIN ALLOCATE(S2(LDW), stat=allocok) IF (allocok .GT. 0 ) THEN GOTO 430 ENDIF IF(MTRANSLOC .NE. 1) LDW = LDW-NZTOT RSPOS = NZTOT CSPOS = RSPOS+N8 NZREAL = 0_8 DO 5 J=1,N IPQ8(J) = 0_8 5 CONTINUE IF(K50 .EQ. 0) THEN DO 10 K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1).AND. & (I.LE.N).AND.(I.GE.1) ) THEN IPQ8(J) = IPQ8(J) + 1_8 NZREAL = NZREAL + 1_8 ENDIF 10 CONTINUE ELSE ZERODIAG = 0 NZER_DIAG = N RZ_DIAG = 0 DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1).AND. & (I.LE.N).AND.(I.GE.1) ) THEN IPQ8(J) = IPQ8(J) + 1_8 NZREAL = NZREAL + 1_8 IF(I .NE. J) THEN IPQ8(I) = IPQ8(I) + 1_8 NZREAL = NZREAL + 1_8 ELSE IF (ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = 1 IF(associated(idA)) THEN ABSAK= abs(idA(K)) IF(ABSAK .EQ. dble(0.0D0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ZERODIAG(I) = exponent(ABSAK) if ( ZERODIAG(I).EQ.0) ZERODIAG(I)=1 ENDIF NZER_DIAG = NZER_DIAG - 1 ELSE IF(associated(idA)) THEN ABSAK= abs(idA(K)) ZERODIAG(I) = ZERODIAG(I)+ exponent(ABSAK) if ( ZERODIAG(I).EQ.0) ZERODIAG(I)=1 ENDIF ENDIF ENDIF ENDIF ENDDO IF(MTRANSLOC .GE. 4) THEN DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN IPQ8(I) = IPQ8(I) + 1_8 NZREAL = NZREAL + 1_8 ENDIF ENDDO ENDIF ENDIF IPE(1) = 1 DO 20 J=1,N IPE(J+1) = IPE(J)+IPQ8(J) 20 CONTINUE DO 25 J=1, N IPQ8(J ) = IPE(J) 25 CONTINUE IF(K50 .EQ. 0) THEN IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1_8) = I IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ELSE IF ( .not.associated(idA)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1) = I S2(KPOS) = abs(idA(K)) IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ENDIF ELSE IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1) = I IPQ8(J) = IPQ8(J) + 1_8 IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDIF ENDDO ELSE IF ( .not.associated(idA) ) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF THEMAX = ZERO THEMIN = huge(THEMIN) DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1_8) = I S2(KPOS) = abs(idA(K)) IPQ8(J) = IPQ8(J) + 1_8 IF(abs(idA(K)) .GT. THEMAX) THEN THEMAX = abs(idA(K)) ELSE IF(abs(idA(K)) .LT. THEMIN & .AND. abs(idA(K)).GT. ZERO) THEN THEMIN = abs(idA(K)) ENDIF IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J S2(KPOS) = abs(idA(K)) IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDIF ENDDO DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = I S2(KPOS) = ZERO IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDDO IF ( THEMAX .NE. ZERO ) THEN CNTL64(2) = (log(THEMAX/THEMIN))*(dble(N)) & - log(THEMIN) + ONE ENDIF ENDIF ENDIF DUPPLI = .FALSE. NZsave = NZREAL FLAG => IKEEPALLOC(2_8*int(N,8)+1:3_8*int(N,8)) IF(MTRANSLOC.NE.1) THEN CALL DMUMPS_SUPPRESS_DUPPLI_VAL(N,NZREAL,IPE(1),IW(IRNW),S2, & PERM(1),IPQ8(1)) ELSE CALL DMUMPS_SUPPRESS_DUPPLI_STR(N,NZREAL,IPE(1),IW(IRNW), & PERM(1)) ENDIF IF(NZREAL .NE. NZsave) DUPPLI = .TRUE. LS2 = NZTOT IF ( MTRANSLOC .EQ. 1 ) THEN LS2 = 1_8 LDW = 1_8 ENDIF CALL DMUMPS_MTRANS_DRIVER(MTRANSLOC ,N, N, NZREAL, & IPE, IW(IRNW), S2(1), LS2, & NUMNZ, PERM(1), LIW, IW(IPIW), LDW, S2(LS2+1), & IPQ8, & ICNTL64, CNTL64, INFO64, INFO) IF (INFO(1).LT.0) THEN IF (LP.GT.0 .AND. ICNTL(4).GE.1) & WRITE(LP,'(A,I5)') & ' Not enough memory in MAXTRANS INFO(1)=',INFO(1) GOTO 500 ENDIF IF (INFO64(1).LT.0) THEN IF (LP.GT.0 .AND. ICNTL(4).GE.1) & WRITE(LP,'(A,I5)') & ' INTERNAL ERROR in MAXTRANS INFO(1)=',INFO64(1) INFO(1) = -9964 INFO(2) = INFO64(1) GO TO 500 ENDIF IF (INFO64(1).GT.0) THEN IF (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(A,I5)') & ' WARNING in MAXTRANS INFO(1)=',INFO64(1) ENDIF KER_SIZE = 0 IF(K50 .EQ. 2) THEN DO I=1,N IF(ZERODIAG(I) .EQ. 0) THEN IF(PERM(I) .EQ. I) THEN KER_SIZE = KER_SIZE + 1 PERM(I) = -I STR_KER(KER_SIZE) = I ENDIF ENDIF ENDDO ENDIF IF (NUMNZ.LT.N) then IF (MTRANSLOC.EQ.1) THEN IF (MINVAL(PERM(1:N)) .LE. 0) THEN GOTO 400 ENDIF ELSE GO TO 400 ENDIF ENDIF IF(K50 .EQ. 0) THEN IDENT = .TRUE. IF (MTRANS .EQ. 0 ) GOTO 102 DO 80 J=1,N JPERM = PERM(J) IW(IRNW+int(JPERM-1,8)) = J IF (JPERM.NE.J) IDENT = .FALSE. 80 CONTINUE IF(IDENT) THEN MTRANS = 0 ELSE IF(MTRANS .EQ. 7) THEN MTRANS = -9876543 GOTO 102 ENDIF IF (PROK) WRITE(MPRINT,'(A)') & ' ... Apply column permutation' DO 100 K=1,NZ J = idJCN(K) IF ((J.LE.0).OR.(J.GT.N)) GO TO 100 idJCN(K) = IW(IRNW+int(J-1,8)) 100 CONTINUE IF (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' ENDIF 102 CONTINUE IF (SCALINGLOC) THEN IF ( associated(idCOLSCA)) & DEALLOCATE( idCOLSCA ) IF ( associated(idROWSCA)) & DEALLOCATE( idROWSCA ) ALLOCATE( idCOLSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of COLSCA' GOTO 500 ENDIF ENDIF ALLOCATE( idROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of ROWSCA' GOTO 500 ENDIF ENDIF KEEP(52) = -2 KEEP(74) = 1 MAXDBL = log(huge(MAXDBL)) DO J=1,N IF(S2(RSPOS+J) .GT. MAXDBL) THEN S2(RSPOS+J) = ZERO ENDIF IF(S2(CSPOS+J) .GT. MAXDBL) THEN S2(CSPOS+J)= ZERO ENDIF ENDDO DO 105 J=1,N J8 = int(J,8) idROWSCA(J) = exp(S2(RSPOS+J8)) IF(idROWSCA(J) .EQ. ZERO) THEN idROWSCA(J) = ONE ENDIF IF ( MTRANS .EQ. -9876543 .OR. MTRANS.EQ. 0 ) THEN idCOLSCA(J)= exp(S2(CSPOS+J8)) IF(idCOLSCA(J) .EQ. ZERO) THEN idCOLSCA(J) = ONE ENDIF ELSE idCOLSCA(IW(IRNW+J8-1_8))= exp(S2(CSPOS+J8)) IF(idCOLSCA(IW(IRNW+J8-1_8)) .EQ. ZERO) THEN idCOLSCA(IW(IRNW+J8-1_8)) = ONE ENDIF ENDIF 105 CONTINUE ENDIF ELSE IDENT = .FALSE. IF(SCALINGLOC) THEN IF ( associated(idCOLSCA)) DEALLOCATE( idCOLSCA ) IF ( associated(idROWSCA)) DEALLOCATE( idROWSCA ) ALLOCATE( idCOLSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of COLSCA' GOTO 500 ENDIF ENDIF ALLOCATE( idROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of ROWSCA' GOTO 500 ENDIF ENDIF KEEP(52) = -2 KEEP(74) = 1 MAXDBL = log(huge(MAXDBL)) DO J=1,N J8 = int(J,8) IF(S2(RSPOS+J8)+S2(CSPOS+J8) .GT. MAXDBL) THEN S2(RSPOS+J8) = ZERO S2(CSPOS+J8)= ZERO ENDIF ENDDO DO J=1,N J8 = int(J,8) IF(PERM(J) .GT. 0) THEN idROWSCA(J) = & exp((S2(RSPOS+J8)+S2(CSPOS+J8))/TWO) IF(idROWSCA(J) .EQ. ZERO) THEN idROWSCA(J) = ONE ENDIF idCOLSCA(J)= idROWSCA(J) ENDIF ENDDO DO JPOS=1,KER_SIZE I = STR_KER(JPOS) COLNORM = ZERO DO K = IPE(I),IPE(I+1) - 1 IF ( PERM( IW( IRNW+K-1_8) ) > 0 ) THEN COLNORM = max(COLNORM,S2(J)) ENDIF ENDDO COLNORM = exp(COLNORM) idROWSCA(I) = ONE / COLNORM idCOLSCA(I) = idROWSCA(I) ENDDO ENDIF IF(MTRANS .EQ. 7 .OR. KEEP(95) .EQ. 0) THEN IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) & .AND. KEEP(95) .EQ. 0) THEN MTRANS = 0 KEEP(95) = 1 GOTO 390 ELSE IF(KEEP(95) .EQ. 0) THEN IF(SCALINGLOC) THEN KEEP(95) = 3 ELSE KEEP(95) = 2 ENDIF ENDIF IF(MTRANS .EQ. 7) MTRANS = 5 ENDIF ENDIF IF(MTRANS .EQ. 0) GOTO 390 ICNTL_SYM_MWM = 0 INFO_SYM_MWM = 0 IF(MTRANS .EQ. 5 .OR. MTRANS .EQ. 6 .OR. & MTRANS .EQ. 7) THEN ICNTL_SYM_MWM(1) = 0 ICNTL_SYM_MWM(2) = 1 ELSE IF(MTRANS .EQ. 4) THEN ICNTL_SYM_MWM(1) = 2 ICNTL_SYM_MWM(2) = 1 ELSE ICNTL_SYM_MWM(1) = 0 ICNTL_SYM_MWM(2) = 1 ENDIF MARKED => IKEEPALLOC( int(N,8)+1_8 : 2_8*int(N,8)) FLAG => IKEEPALLOC(2_8*int(N,8)+1_8 : 3_8*int(N,8)) PIV_OUT => WORK2(1:N) IF(MTRANSLOC .LT. 4) THEN LSC = 1 ELSE LSC = 2*N ENDIF CALL DMUMPS_SYM_MWM( & N, NZREAL, IPE, IW(IRNW), S2(1),LSC, PERM(1), & ZERODIAG(1), & ICNTL_SYM_MWM, S2(LSC+1),MARKED(1),FLAG(1), & PIV_OUT(1), INFO_SYM_MWM) IF(INFO_SYM_MWM(1) .NE. 0) THEN WRITE(*,*) '** Error in DMUMPS_ANA_O' RETURN ENDIF IF(INFO_SYM_MWM(3) .EQ. N) THEN IDENT = .TRUE. ELSEIF ( (ICNTL(12).EQ.0).AND. & ( (N-INFO_SYM_MWM(4)-INFO_SYM_MWM(3)) .GT. N/10 ) & ) THEN IDENT = .TRUE. KEEP(95) = 1 ELSE DO I=1,N PERM(I) = PIV_OUT(I) ENDDO ENDIF KEEP(93) = INFO_SYM_MWM(4) KEEP(94) = INFO_SYM_MWM(3) IF (IDENT) MTRANS=0 ENDIF 390 IF(MTRANS .EQ. 0) THEN KEEP(95) = 1 IF (PROK) THEN WRITE (MPRINT,'(A)') & ' ... Column permutation not used' ENDIF ENDIF GO TO 500 400 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) & WRITE (LP,'(/A)') '** Error: Matrix is structurally singular' INFO(1) = -6 INFO(2) = NUMNZ GOTO 500 410 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O' WRITE (LP,'(A,I14)') & '** Failure during allocation of INTEGER array of size ', & LIWG ENDIF INFO(1) = -7 CALL MUMPS_SET_IERROR(LIWG,INFO(2)) GOTO 500 430 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O' WRITE (LP,'(A)') '** Failure during allocation of S2' ENDIF INFO(1) = -5 CALL MUMPS_SET_IERROR(LDW,INFO(2)) 500 CONTINUE IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(S2)) DEALLOCATE(S2) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(IPQ8)) DEALLOCATE(IPQ8) RETURN END SUBROUTINE DMUMPS_ANA_O END MODULE DMUMPS_ANA_AUX_M SUBROUTINE DMUMPS_ANA_K(N,IPE, IW, LW, IWFR, IPS, IPV, & NV, FLAG, & NCMPA, SIZE_SCHUR, PARENT) IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR INTEGER, INTENT(IN) :: IPS(N) INTEGER(8), INTENT(IN) :: LW INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: IPV(N), NV(N), PARENT(N) INTEGER(8), INTENT(INOUT) :: IWFR INTEGER(8), INTENT(INOUT) :: IPE(N) INTEGER, INTENT(INOUT) :: IW(LW) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER I,J,ML,MS,ME,MINJS,IE,KDUMMY INTEGER LN,JS,JE INTEGER(8) :: JP, JP1, JP2, LWFR, IP DO 10 I=1,N FLAG(I) = 0 NV(I) = 0 J = IPS(I) IPV(J) = I 10 CONTINUE NCMPA = 0 DO 100 ML=1,N-SIZE_SCHUR MS = IPV(ML) ME = MS FLAG(MS) = ME IP = IWFR MINJS = N IE = ME DO 70 KDUMMY=1,N JP = IPE(IE) LN = 0 IF (JP.LE.0_8) GO TO 60 LN = IW(JP) DO 50 JP1=1_8,int(LN,8) JP = JP + 1_8 JS = IW(JP) IF (FLAG(JS).EQ.ME) GO TO 50 FLAG(JS) = ME IF (IWFR.LT.LW) GO TO 40 IPE(IE) = JP IW(JP) = LN - int(JP1) CALL DMUMPS_ANA_D(N, IPE, IW, IP-1_8, LWFR, NCMPA) JP2 = IWFR - 1 IWFR = LWFR IF (IP.GT.JP2) GO TO 30 DO 20 JP=IP,JP2 IW(IWFR) = IW(JP) IWFR = IWFR + 1_8 20 CONTINUE 30 IP = LWFR JP = IPE(IE) 40 IW(IWFR) = JS MINJS = min(MINJS,IPS(JS)+0) IWFR = IWFR + 1_8 50 CONTINUE 60 IPE(IE) = int(-ME,8) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 80 70 CONTINUE 80 IF (IWFR.GT.IP) GO TO 90 IPE(ME) = 0_8 NV(ME) = 1 GO TO 100 90 MINJS = IPV(MINJS) NV(ME) = NV(MINJS) NV(MINJS) = ME IW(IWFR) = IW(IP) IW(IP) = int(IWFR - IP) IPE(ME) = IP IWFR = IWFR + 1_8 100 CONTINUE IF (SIZE_SCHUR == 0) GOTO 500 DO ML = N-SIZE_SCHUR+1,N ME = IPV(ML) IE = ME DO KDUMMY=1,N JP = IPE(IE) LN = 0 IF (JP.LE.0_8) GO TO 160 LN = IW(JP) 160 IPE(IE) = int(-IPV(N-SIZE_SCHUR+1),8) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 190 ENDDO 190 NV(ME) = 0 IPE(ME) = int(-IPV(N-SIZE_SCHUR+1),8) ENDDO ME = IPV(N-SIZE_SCHUR+1) IPE(ME) = 0_8 NV(ME) = SIZE_SCHUR 500 DO I=1,N PARENT(I) = int(IPE(I)) ENDDO RETURN END SUBROUTINE DMUMPS_ANA_K SUBROUTINE DMUMPS_ANA_J(N, NZ, IRN, ICN, PERM, & IW, LW, IPE, IQ, FLAG, & IWFR, IFLAG, IERROR, MP) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ, LW INTEGER, INTENT(IN) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: PERM(N) INTEGER, INTENT(IN) :: MP INTEGER(8), INTENT(OUT):: IWFR INTEGER, INTENT(OUT) :: IERROR INTEGER, INTENT(OUT) :: IQ(N) INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER, INTENT(OUT) :: IW(LW) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER, INTENT(INOUT) :: IFLAG INTEGER :: I,J,LBIG,IN,LEN,JDUMMY,L1 INTEGER(8) :: K, K1, K2, KL, KID IERROR = 0 DO 10 I=1,N IQ(I) = 0 10 CONTINUE DO 80 K=1_8,NZ I = IRN(K) J = ICN(K) IW(K) = -I IF (I.EQ.J) GOTO 40 IF (I.GT.J) GOTO 30 IF (I.GE.1 .AND. J.LE.N) GO TO 60 GO TO 50 30 IF (J.GE.1 .AND. I.LE.N) GO TO 60 GO TO 50 40 IW(K) = 0 IF (I.GE.1 .AND. I.LE.N) GO TO 80 50 IERROR = IERROR + 1 IW(K) = 0 IF (IERROR.LE.1 .AND. MP.GT.0) WRITE (MP,99999) IF (IERROR.LE.10 .AND. MP.GT.0) WRITE (MP,99998) K, I, J GO TO 80 60 IF (PERM(J).GT.PERM(I)) GO TO 70 IQ(J) = IQ(J) + 1 GO TO 80 70 IQ(I) = IQ(I) + 1 80 CONTINUE IF (IERROR.GE.1) THEN IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 ENDIF IWFR = 1_8 LBIG = 0 DO 100 I=1,N L1 = IQ(I) LBIG = max(L1,LBIG) IWFR = IWFR + int(L1,8) IPE(I) = IWFR - 1_8 100 CONTINUE DO 140 K=1_8,NZ I = -IW(K) IF (I.LE.0) GO TO 140 KL = K IW(K) = 0 DO 130 KID=1,NZ J = ICN(KL) IF (PERM(I).LT.PERM(J)) GO TO 110 KL = IPE(J) IPE(J) = KL - 1_8 IN = IW(KL) IW(KL) = I GO TO 120 110 KL = IPE(I) IPE(I) = KL - 1_8 IN = IW(KL) IW(KL) = J 120 I = -IN IF (I.LE.0) GO TO 140 130 CONTINUE 140 CONTINUE K = IWFR - 1_8 KL = K + int(N,8) IWFR = KL + 1_8 DO 170 I=1,N FLAG(I) = 0 J = N + 1 - I LEN = IQ(J) IF (LEN.LE.0) GO TO 160 DO 150 JDUMMY=1,LEN IW(KL) = IW(K) K = K - 1_8 KL = KL - 1_8 150 CONTINUE 160 IPE(J) = KL KL = KL - 1_8 170 CONTINUE IF (LBIG.GE.huge(N)) GO TO 190 DO 180 I=1,N K = IPE(I) IW(K) = IQ(I) IF (IQ(I).EQ.0) IPE(I) = 0_8 180 CONTINUE GO TO 230 190 IWFR = 1_8 DO 220 I=1,N K1 = IPE(I) + 1_8 K2 = IPE(I) + int(IQ(I),8) IF (K1.LE.K2) GO TO 200 IPE(I) = 0_8 GO TO 220 200 IPE(I) = IWFR IWFR = IWFR + 1_8 DO 210 K=K1,K2 J = IW(K) IF (FLAG(J).EQ.I) GO TO 210 IW(IWFR) = J IWFR = IWFR + 1_8 FLAG(J) = I 210 CONTINUE K = IPE(I) IW(K) = int(IWFR - K - 1_8) 220 CONTINUE 230 RETURN 99999 FORMAT (' *** WARNING MESSAGE FROM DMUMPS_ANA_J ***' ) 99998 FORMAT (I6, ' NON-ZERO (IN ROW, I6, 11H AND COLUMN ', I6, & ') IGNORED') END SUBROUTINE DMUMPS_ANA_J SUBROUTINE DMUMPS_ANA_D(N, IPE, IW, LW, IWFR,NCMPA) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(INOUT):: IPE(N) INTEGER, INTENT(INOUT) :: NCMPA INTEGER, INTENT(INOUT) :: IW(LW) INTEGER :: I, IR INTEGER(8) :: K1, K, K2, LWFR NCMPA = NCMPA + 1 DO 10 I=1,N K1 = IPE(I) IF (K1.LE.0_8) GO TO 10 IPE(I) = int(IW(K1), 8) IW(K1) = -I 10 CONTINUE IWFR = 1_8 LWFR = IWFR DO 60 IR=1,N IF (LWFR.GT.LW) GO TO 70 DO 20 K=LWFR,LW IF (IW(K).LT.0) GO TO 30 20 CONTINUE GO TO 70 30 I = -IW(K) IW(IWFR) = int(IPE(I)) IPE(I) = int(IWFR,8) K1 = K + 1_8 K2 = K + int(IW(IWFR),8) IWFR = IWFR + 1_8 IF (K1.GT.K2) GO TO 50 DO 40 K=K1,K2 IW(IWFR) = IW(K) IWFR = IWFR + 1_8 40 CONTINUE 50 LWFR = K2 + 1_8 60 CONTINUE 70 RETURN END SUBROUTINE DMUMPS_ANA_D SUBROUTINE DMUMPS_ANA_LNEW(N, IPE, NV, IPS, NE, NA, NFSIZ, & NODE, NSTEPS, & FILS, FRERE, ND, NEMIN, SUBORD, KEEP60, & KEEP20, KEEP38, NAMALG,NAMALGMAX, & CUMUL,KEEP50, ICNTL13, KEEP37, KEEP197, NSLAVES, & ALLOW_AMALG_TINY_NODES & , BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS & , INODE_Scalapack_CAND, NBSONS_Scalapack_CAND & , KEEP11, KEEP191, KEEP192, KEEP193 & ) IMPLICIT NONE INTEGER N, NSTEPS, KEEP60, KEEP20, KEEP38, KEEP50 INTEGER ND(N), NFSIZ(N) INTEGER IPE(N), FILS(N), FRERE(N), SUBORD(N) INTEGER NV(N), IPS(N), NE(N), NA(N), NODE(N) INTEGER NEMIN,AMALG_COUNT INTEGER NAMALG(N),NAMALGMAX, CUMUL(N) DOUBLE PRECISION SIZE_DADI_AMALGAMATED, PERCENT_FILL DOUBLE PRECISION ACCU, FLOPS_FATHER, FLOPS_SON, & FLOPS_AVANT, FLOPS_APRES INTEGER ICNTL13, KEEP37, NSLAVES LOGICAL ALLOW_AMALG_TINY_NODES INTEGER KEEP197 LOGICAL, INTENT(IN) :: BLKON INTEGER, INTENT(IN) :: LSIZEOFBLOCKS INTEGER, INTENT(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) INTEGER, INTENT(OUT):: INODE_Scalapack_CAND, & NBSONS_Scalapack_CAND INTEGER, INTENT(IN) :: KEEP11, KEEP191, KEEP192, KEEP193 #if defined(NOAMALGTOFATHER) #else #endif INTEGER I,IF,IS,NR,INS INTEGER K,L,ISON,IN,IFSON,INO INTEGER INOS,IB,IL INTEGER IPERM INTEGER MAXNODE INTEGER SIZE_Scalapack_CAND, NBSONS_current_root LOGICAL ROOT_WITH_FEW_SONS #if defined(NOAMALGTOFATHER) INTEGER INB,INF,INFS,INL,INSW,INT1,NR1 #else INTEGER DADI #endif LOGICAL AMALG_TO_father_OK AMALG_COUNT = 0 INODE_Scalapack_CAND = -1 NBSONS_Scalapack_CAND = -1 SIZE_Scalapack_CAND = -1 NBSONS_current_root = 0 DO 10 I=1,N CUMUL(I)= 0 IPS(I) = 0 NE(I) = 0 SUBORD(I) = 0 NAMALG(I) = 0 10 CONTINUE DO I=1,N IF (BLKON) THEN NODE(I) = SIZEOFBLOCKS(I) ELSE NODE(I) = 1 ENDIF ENDDO FRERE(1:N) = IPE(1:N) NR = N + 1 MAXNODE = 1 DO 50 I=1,N IF = -FRERE(I) IF (NV(I).EQ.0) THEN IF (SUBORD(IF).NE.0) SUBORD(I) = SUBORD(IF) SUBORD(IF) = I IF (BLKON) THEN NODE(IF) = NODE(IF)+SIZEOFBLOCKS(I) ELSE NODE(IF) = NODE(IF)+1 ENDIF MAXNODE = max(NODE(IF),MAXNODE) ELSE IF (IF.NE.0) THEN IS = -IPS(IF) IF (IS.GT.0) FRERE(I) = IS IPS(IF) = -I ELSE NR = NR - 1 NE(NR) = I ENDIF ENDIF 50 CONTINUE MAXNODE = int(dble(MAXNODE)*dble(NEMIN) / dble(100)) MAXNODE = max(MAXNODE,2000) #if defined(NOAMALGTOFATHER) DO 999 I=1,N FILS(I) = IPS(I) 999 CONTINUE NR1 = NR INS = 0 1000 IF (NR1.GT.N) GO TO 1151 INS = NE(NR1) NR1 = NR1 + 1 1070 INL = FILS(INS) IF (INL.LT.0) THEN INS = -INL GO TO 1070 ENDIF 1080 IF (FRERE(INS).LT.0) THEN INS = -FRERE(INS) FILS(INS) = 0 GO TO 1080 ENDIF IF (FRERE(INS).EQ.0) THEN INS = 0 GO TO 1000 ENDIF INB = FRERE(INS) IF (NV(INB).GE.NV(INS)) THEN INS = INB GO TO 1070 ENDIF INF = INB 1090 INF = FRERE(INF) IF (INF.GT.0) GO TO 1090 INF = -INF INFS = -FILS(INF) IF (INFS.EQ.INS) THEN FILS(INF) = -INB IPS(INF) = -INB FRERE(INS) = FRERE(INB) FRERE(INB) = INS ELSE INSW = INFS 1100 INFS = FRERE(INSW) IF (INFS.NE.INS) THEN INSW = INFS GO TO 1100 ENDIF FRERE(INS) = FRERE(INB) FRERE(INB) = INS FRERE(INSW)= INB ENDIF INS = INB GO TO 1070 1151 CONTINUE #endif DO 51 I=1,N FILS(I) = IPS(I) 51 CONTINUE IS = 1 I = 0 IPERM = 1 DO 160 K=1,N AMALG_TO_father_OK=.FALSE. IF (I.LE.0) THEN IF (NR.GT.N) EXIT I = NE(NR) NE(NR) = 0 NR = NR + 1 IL = N NA(N) = 0 NBSONS_current_root =0 IF (IPS(I).LT.0) THEN IB = -IPS(I) NBSONS_current_root = NBSONS_current_root + 1 69 IB =FRERE(IB) IF (IB.GT.0) THEN NBSONS_current_root = NBSONS_current_root + 1 GOTO 69 ENDIF ENDIF 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 DADI = -IPE(I) IF (DADI.EQ.0) THEN IF (NV(I) .GT. SIZE_Scalapack_CAND) THEN INODE_Scalapack_CAND = I SIZE_Scalapack_CAND = NV(I) ENDIF ENDIF #if ! defined(NOAMALGTOFATHER) IF ( (DADI.NE.0) .AND. & ( & (KEEP60.EQ.0).OR. & ( (KEEP20.NE.DADI).AND.(KEEP38.NE.DADI) ) & ) & ) THEN ACCU = dble(2)*dble(NODE(I))*dble(NV(DADI)-NV(I)+NODE(I)) SIZE_DADI_AMALGAMATED = & dble(NV(DADI)+NODE(I)) * & dble(NV(DADI)+NODE(I)) PERCENT_FILL = dble(100) * ACCU / SIZE_DADI_AMALGAMATED ACCU = ACCU + dble(CUMUL(I)) AMALG_TO_father_OK = ( & ( (NODE(I).LE.MAXNODE).AND.(NODE(DADI).LE.MAXNODE) ) & .OR. & ( (NODE(I).LE.NEMIN.and. NODE(DADI).GT. MAXNODE) & .OR.(NODE(DADI).LE.NEMIN .and. NODE(I).GT.MAXNODE))) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( PERCENT_FILL < dble(NEMIN) ) ) IF (KEEP197 .EQ. 1 ) THEN AMALG_TO_father_OK = AMALG_TO_father_OK.OR. & ( NODE(I).LE.2*NEMIN .AND. NODE(DADI).LT.4*NEMIN) ENDIF AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( ACCU / SIZE_DADI_AMALGAMATED .LE. dble(NEMIN)) ) IF (AMALG_TO_father_OK) THEN CALL MUMPS_GET_FLOPS_COST(NV(I),NODE(I),NODE(I), & KEEP50,1,FLOPS_SON) CALL MUMPS_GET_FLOPS_COST(NV(DADI),NODE(DADI), & NODE(DADI), & KEEP50,1,FLOPS_FATHER) FLOPS_AVANT = FLOPS_FATHER+FLOPS_SON & + max(dble(200.0) * dble(NV(I)-NODE(I)) & * dble(NV(I)-NODE(I)), & dble(10000.0)) CALL MUMPS_GET_FLOPS_COST(NV(DADI)+NODE(I), & NODE(DADI)+NODE(I), & NODE(DADI)+NODE(I), & KEEP50,1,FLOPS_APRES) IF (FLOPS_APRES.GT.FLOPS_AVANT* & (dble(1)+dble(max(8,NEMIN)-8)/dble(100))) THEN AMALG_TO_father_OK = .FALSE. ENDIF ENDIF ROOT_WITH_FEW_SONS =.TRUE. IF (KEEP11.GT.0) THEN IF (IPE(DADI).EQ.0) THEN IF & (NA(IL)+max(NA(IL+1),NBSONS_current_root) & .GT.KEEP11) & ROOT_WITH_FEW_SONS= .FALSE. ELSE IF & (NA(IL)+NA(IL+1)+max(NA(N),NBSONS_current_root) & .GT.KEEP11) & ROOT_WITH_FEW_SONS= .FALSE. ENDIF ENDIF IF ( (NV(I).GT. max(KEEP191,1)*NV(DADI)) & .AND. (NSLAVES.GT.1) & .AND. (ICNTL13.LE.0) & .AND. (NV(I).GT. KEEP37) & .AND. ROOT_WITH_FEW_SONS & ) THEN IF ( ( ACCU / SIZE_DADI_AMALGAMATED ) .LT. & 10.0D0/dble(max(KEEP191,1)) ) THEN AMALG_TO_father_OK = .TRUE. ENDIF ENDIF IF ( ALLOW_AMALG_TINY_NODES .AND. & (NODE(I)*max(KEEP192,1)) .LE. (NV(DADI)-NAMALG(DADI)) ) & THEN IF ( NAMALG(DADI) < & (NV(DADI)-NAMALG(DADI))/max(KEEP193,1) ) THEN AMALG_TO_father_OK = .TRUE. NAMALG(DADI) = NAMALG(DADI) + NODE(I) ENDIF ENDIF IF ( DADI .EQ. -FRERE(I) & .AND. -FILS(DADI).EQ.I & ) THEN AMALG_TO_father_OK = ( AMALG_TO_father_OK .OR. & ( NV(I)-NODE(I).EQ.NV(DADI)) ) ENDIF IF (AMALG_TO_father_OK) THEN CUMUL(DADI)=CUMUL(DADI)+nint(ACCU) NAMALG(DADI) = NAMALG(DADI) + NAMALG(I) AMALG_COUNT = AMALG_COUNT+1 IN = DADI 75 IF (SUBORD(IN).EQ.0) GOTO 76 IN = SUBORD(IN) GOTO 75 76 CONTINUE SUBORD(IN) = I NV(I) = 0 IFSON = -FILS(DADI) IF (IFSON.EQ.I) THEN IF (FILS(I).LT.0) THEN FILS(DADI) = FILS(I) GOTO 78 ELSE IF (FRERE(I).GT.0) THEN FILS(DADI) = -FRERE(I) ELSE FILS(DADI) = 0 ENDIF GOTO 90 ENDIF ENDIF IN = IFSON 77 INS = IN IN = FRERE(IN) IF (IN.NE.I) GOTO 77 IF (FILS(I) .LT.0) THEN FRERE(INS) = -FILS(I) ELSE FRERE(INS) = FRERE(I) GOTO 90 ENDIF 78 CONTINUE IN = -FILS(I) 79 INO = IN IN = FRERE(IN) IF (IN.GT.0) GOTO 79 FRERE(INO) = FRERE(I) 90 CONTINUE NODE(DADI) = NODE(DADI)+ NODE(I) NV(DADI) = NV(DADI) + NODE(I) NA(IL+1) = NA(IL+1) + NA(IL) GOTO 120 ENDIF ENDIF #endif NE(IS) = NE(IS) + NODE(I) IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1 NA(IS) = NA(IL) ND(IS) = NV(I) NODE(I) = IS IPS(I) = IPERM IPERM = IPERM + 1 IN = I 777 IF (SUBORD(IN).EQ.0) GO TO 778 IN = SUBORD(IN) NODE(IN) = IS IPS(IN) = IPERM IPERM = IPERM + 1 GO TO 777 778 IF (NA(IS).LE.0) GO TO 110 #if defined(NOAMALGTOFATHER) IF ( (KEEP60.NE.0).AND. & (NE(IS).EQ.ND(IS)) ) GOTO 110 IF (ND(IS-1)-NE(IS-1).EQ.ND(IS)) THEN GO TO 100 ENDIF IF(NAMALG(IS-1) .GE. NAMALGMAX) THEN GOTO 110 ENDIF IF ((NE(IS-1).GE.NEMIN).AND. & (NE(IS).GE.NEMIN) ) GO TO 110 IF (2*NE(IS-1)*(ND(IS)-ND(IS-1)+NE(IS-1)).GE. & ((ND(IS)+NE(IS-1))* & (ND(IS)+NE(IS-1))*NEMIN/100)) GO TO 110 NAMALG(IS-1) = NAMALG(IS-1)+1 100 NA(IS-1) = NA(IS-1) + NA(IS) - 1 ND(IS-1) = ND(IS) + NE(IS-1) NE(IS-1) = NE(IS) + NE(IS-1) NE(IS) = 0 NODE(I) = IS-1 IFSON = -FILS(I) IN = IFSON 102 INO = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 102 NV(INO) = 0 IN = I 888 IF (SUBORD(IN).EQ.0) GO TO 889 IN = SUBORD(IN) GO TO 888 889 SUBORD(IN) = INO INOS = -FILS(INO) IF (IFSON.EQ.INO) THEN FILS(I) = -INOS GO TO 107 ENDIF IN = IFSON 105 INS = IN IN = FRERE(IN) IF (IN.NE.INO) GO TO 105 IF (INOS.EQ.0) THEN FRERE(INS) = -I GO TO 120 ELSE FRERE(INS) = INOS ENDIF 107 IN = INOS IF (IN.EQ.0) GO TO 120 108 INT1 = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 108 FRERE(INT1) = -I GO TO 120 #endif 110 IS = IS + 1 120 IB = FRERE(I) IF (IB.GE.0) THEN IF (IB.GT.0) NA(IL) = 0 I = IB ELSE I = -IB IL = IL + 1 ENDIF 160 CONTINUE NSTEPS = IS - 1 I = INODE_Scalapack_CAND INOS = -FILS(I) NBSONS_Scalapack_CAND = 0 IF (INOS.GT.0) THEN NBSONS_Scalapack_CAND = NBSONS_Scalapack_CAND+1 INO = FRERE(INOS) DO WHILE (INO.GT.0 .AND. INO.LE.N) NBSONS_Scalapack_CAND = NBSONS_Scalapack_CAND+1 INO = FRERE(INO) ENDDO ENDIF DO I=1, N IF (NV(I).EQ.0) THEN FRERE(I) = N+1 NFSIZ(I) = 0 ELSE NFSIZ(I) = ND(NODE(I)) IF (SUBORD(I) .NE.0) THEN INOS = -FILS(I) INO = I DO WHILE (SUBORD(INO).NE.0) IS = SUBORD(INO) FILS(INO) = IS INO = IS END DO FILS(INO) = -INOS ENDIF ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_ANA_LNEW SUBROUTINE DMUMPS_ANA_M(NE, ND, NSTEPS, & MAXFR, MAXELIM, K50, SIZEFAC_TOT, MAXNPIV, & K5,K6,PANEL_SIZE,K253) IMPLICIT NONE INTEGER, INTENT(in) :: NSTEPS, K50, K253, K5, K6 INTEGER, INTENT(in) :: NE(NSTEPS), ND(NSTEPS) INTEGER, INTENT(out) :: MAXNPIV, PANEL_SIZE INTEGER, INTENT(out) :: MAXFR, MAXELIM INTEGER(8), INTENT(out):: SIZEFAC_TOT INTEGER ITREE, NFR, NELIM INTEGER LKJIB INTEGER(8) :: SIZEFAC LKJIB = max(K5,K6) MAXFR = 0 MAXELIM = 0 MAXNPIV = 0 PANEL_SIZE = 0 SIZEFAC_TOT = 0_8 DO ITREE=1,NSTEPS NELIM = NE(ITREE) NFR = ND(ITREE) + K253 IF (NFR.GT.MAXFR) MAXFR = NFR IF (NFR-NELIM.GT.MAXELIM) MAXELIM = NFR - NELIM IF (NELIM .GT. MAXNPIV) THEN MAXNPIV = NELIM ENDIF IF (K50.EQ.0) THEN SIZEFAC = (2_8*int(NFR,8) - int(NELIM,8))*int(NELIM,8) PANEL_SIZE = max(PANEL_SIZE, NFR*(LKJIB+1)) ELSE SIZEFAC = int(NFR,8) * int(NELIM,8) PANEL_SIZE = max(PANEL_SIZE, NELIM*(LKJIB+1)) PANEL_SIZE = max(PANEL_SIZE, (NFR-NELIM)*(LKJIB+1)) ENDIF SIZEFAC_TOT = SIZEFAC_TOT + SIZEFAC END DO RETURN END SUBROUTINE DMUMPS_ANA_M SUBROUTINE DMUMPS_ANA_R( N, FILS, FRERE, & NSTK, NA ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: FILS(N), FRERE(N) INTEGER, INTENT(OUT) :: NSTK(N), NA(N) INTEGER NBROOT, NBLEAF, ILEAF, I, IN, ISON NA = 0 NSTK = 0 NBROOT = 0 ILEAF = 1 DO 11 I=1,N IF (FRERE(I).EQ. N+1) CYCLE IF (FRERE(I).EQ.0) NBROOT = NBROOT + 1 IN = I 12 IN = FILS(IN) IF (IN.GT.0) GO TO 12 IF (IN.EQ.0) THEN NA(ILEAF) = I ILEAF = ILEAF + 1 CYCLE ENDIF ISON = -IN 13 NSTK(I) = NSTK(I) + 1 ISON = FRERE(ISON) IF (ISON.GT.0) GO TO 13 11 CONTINUE NBLEAF = ILEAF-1 IF (N.GT.1) THEN IF (NBLEAF.GT.N-2) THEN IF (NBLEAF.EQ.N-1) THEN NA(N-1) = -NA(N-1)-1 NA(N) = NBROOT ELSE NA(N) = -NA(N)-1 ENDIF ELSE NA(N-1) = NBLEAF NA(N) = NBROOT ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_ANA_R SUBROUTINE DMUMPS_DIAG_ANA &( MYID, COMM, KEEP,KEEP8, INFO, INFOG, RINFO, RINFOG, ICNTL, & SIZE_SCHUR ) IMPLICIT NONE INTEGER, INTENT(IN) :: COMM, MYID, KEEP(500), INFO(80), & ICNTL(60), INFOG(80), SIZE_SCHUR INTEGER(8), INTENT(IN) :: KEEP8(150) DOUBLE PRECISION, INTENT(IN) :: RINFO(40), RINFOG(40) INCLUDE 'mpif.h' INTEGER MASTER, MPG INTEGER ITMP, ICNTL48_EFF PARAMETER( MASTER = 0 ) MPG = ICNTL(3) IF ( MYID.eq.MASTER.and.MPG.GT.0.AND.ICNTL(4).GE.2) THEN ITMP = KEEP(13) IF (ICNTL(15).EQ.0) THEN ITMP = 0 ENDIF IF (KEEP(400).GT.0) THEN ICNTL48_EFF=1 ELSE ICNTL48_EFF=0 ENDIF 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(95), ICNTL(13), KEEP(12), & ITMP, & ICNTL(18), KEEP(252), KEEP(494), & ICNTL48_EFF, & KEEP(106), & 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), SIZE_SCHUR IF (KEEP(251).GT.0) WRITE(MPG, 99997) KEEP(251) IF (KEEP(253).GT.0) WRITE(MPG, 99996) KEEP(253) ENDIF RETURN 99992 FORMAT(/'Leaving analysis phase with ...'/ & ' INFOG(1) =',I16/ & ' INFOG(2) =',I16/ & ' -- (20) Number of entries in factors (estim.) =',I16/ & ' -- (3) Real space for factors (estimated) =',I16/ & ' -- (4) Integer space for factors (estimated) =',I16/ & ' -- (5) Maximum frontal size (estimated) =',I16/ & ' -- (6) Number of nodes in the tree =',I16/ & ' -- (32) Type of analysis effectively used =',I16/ & ' -- (7) Ordering option effectively used =',I16/ & ' ICNTL (6) Maximum transversal option =',I16/ & ' ICNTL (7) Pivot order option =',I16/ & ' ICNTL(12) Ordering symmetric indef. matrices =',I16/ & ' ICNTL(13) Parallelism/splitting of root node =',I16/ & ' ICNTL(14) Percentage of memory relaxation =',I16/ & ' ICNTL(15) Analysis by block effectively used =',I16/ & ' ICNTL(18) Distributed input matrix (on if >0) =',I16/ & ' ICNTL(32) Forward elimination during facto. =',I16/ & ' ICNTL(35) BLR activation =',I16/ & ' ICNTL(48) Tree based multithreading (effective)=',I16/ & ' ICNTL(58) Symbolic factorization option =',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/ & ' Size of Schur (SIZE_SCHUR) =',I16) 99996 FORMAT(' Forward solution during factorization, NRHS =',I16) 99997 FORMAT(' ICNTL(31) Discard factors (eff. value) =',I16) END SUBROUTINE DMUMPS_DIAG_ANA SUBROUTINE DMUMPS_CUTNODES & ( N, FRERE, FILS, NFSIZ, SIZEOFBLOCKS, LSIZEOFBLOCKS, & NSTEPS, NSLAVES, & KEEP, KEEP8, SPLITROOT, MP, LDIAG, INFO1, INFO2 ) IMPLICIT NONE INTEGER N, NSTEPS, NSLAVES, KEEP(500) INTEGER(8) KEEP8(150) INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) INTEGER LSIZEOFBLOCKS INTEGER SIZEOFBLOCKS(LSIZEOFBLOCKS) LOGICAL SPLITROOT INTEGER MP, LDIAG INTEGER INFO1, INFO2 INTEGER, DIMENSION(:), ALLOCATABLE :: IPOOL INTEGER INODE, DEPTH, I, IBEG, IEND, IIPOOL, NROOT INTEGER MAX_DEPTH, ISON, TOT_CUT, MAX_CUT, STRAT INTEGER(8) :: K79 INTEGER K82, allocok LOGICAL BLKON BLKON = .NOT.(SIZEOFBLOCKS(1).EQ.-1) K79 = KEEP8(79) K82 = abs(KEEP(82)) STRAT= KEEP(62) IF (KEEP(210).EQ.1) THEN MAX_DEPTH = 2*NSLAVES*K82 STRAT = STRAT/4 ELSE IF (( NSLAVES .eq. 1 ).AND. (.NOT. SPLITROOT) ) RETURN IF (NSLAVES.EQ.1) THEN MAX_DEPTH=1 ELSE MAX_DEPTH = int( log( dble( NSLAVES - 1 ) ) & / log(2.0D0) ) ENDIF ENDIF ALLOCATE(IPOOL(NSTEPS+1), stat=allocok) IF (allocok.GT.0) THEN INFO1= -7 INFO2= NSTEPS+1 RETURN ENDIF NROOT = 0 DO INODE = 1, N IF ( FRERE(INODE) .eq. 0 ) THEN NROOT = NROOT + 1 IPOOL( NROOT ) = INODE END IF END DO IBEG = 1 IEND = NROOT IIPOOL = NROOT + 1 IF (SPLITROOT) THEN MAX_DEPTH=0 ENDIF DO DEPTH = 1, MAX_DEPTH DO I = IBEG, IEND INODE = IPOOL( I ) ISON = INODE DO WHILE ( ISON .GT. 0 ) ISON = FILS( ISON ) END DO ISON = - ISON DO WHILE ( ISON .GT. 0 ) IPOOL( IIPOOL ) = ISON IIPOOL = IIPOOL + 1 ISON = FRERE( ISON ) END DO END DO IPOOL( IBEG ) = -IPOOL( IBEG ) IBEG = IEND + 1 IEND = IIPOOL - 1 END DO IPOOL( IBEG ) = -IPOOL( IBEG ) TOT_CUT = 0 IF (SPLITROOT) THEN MAX_CUT = NROOT*max(K82,2) IF (KEEP(72).EQ.1) THEN K79 = min(3_8*3_8,K79) ELSE K79 = min(2000_8*2000_8,K79) IF (KEEP(376) .EQ. 1) THEN K79 = min(int(KEEP(9)+1,8)*int(KEEP(9)+1,8),K79) ENDIF ENDIF IF (KEEP(53).NE.0) THEN K79 = 121_8*121_8 ENDIF ELSE MAX_CUT = 2 * NSLAVES IF (KEEP(210).EQ.1) THEN MAX_CUT = 4 * (MAX_CUT + 4) ENDIF ENDIF DEPTH = -1 DO I = 1, IIPOOL - 1 INODE = IPOOL( I ) IF ( INODE .LT. 0 ) THEN INODE = -INODE DEPTH = DEPTH + 1 END IF CALL DMUMPS_SPLIT_1NODE & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, & KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IF ( TOT_CUT > MAX_CUT ) EXIT END DO KEEP(61) = TOT_CUT DEALLOCATE(IPOOL) RETURN END SUBROUTINE DMUMPS_CUTNODES RECURSIVE SUBROUTINE DMUMPS_SPLIT_1NODE & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, KEEP,KEEP8, & TOT_CUT, STRAT, DEPTH, K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IMPLICIT NONE INTEGER(8) :: K79 INTEGER INODE, N, NSTEPS, NSLAVES, KEEP(500), STRAT, & DEPTH, TOT_CUT, MP, LDIAG INTEGER(8) KEEP8(150) INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) LOGICAL SPLITROOT LOGICAL BLKON INTEGER LSIZEOFBLOCKS INTEGER SIZEOFBLOCKS(LSIZEOFBLOCKS) INTEGER I, IN, NPIV, NFRONT, NSLAVES_ESTIM DOUBLE PRECISION WK_SLAVE, WK_MASTER INTEGER INODE_SON, INODE_FATH, IN_SON, IN_FATH, IN_GRANDFATH INTEGER NPIV_COMPG, NPIV_SON_COMPG, NPIV_FATH_COMPG INTEGER NPIV_SON, NPIV_FATH, NPIV_TEMP INTEGER NCB, NSLAVESMIN, NSLAVESMAX INTEGER MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX EXTERNAL MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX IF ( (KEEP(210).EQ.1.AND.KEEP(60).EQ.0) .OR. & (SPLITROOT) ) THEN IF ( FRERE ( INODE ) .eq. 0 ) THEN NFRONT = NFSIZ( INODE ) NPIV = NFRONT IF (BLKON) THEN IN = INODE NPIV_COMPG = 0 DO WHILE( IN > 0 ) NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) ENDDO ELSE NPIV_COMPG = NPIV ENDIF NCB = 0 IF ( int(NFRONT,8)*int(NFRONT,8).GT.K79 & ) THEN GOTO 333 ENDIF ENDIF ENDIF IF ( FRERE ( INODE ) .eq. 0 ) RETURN NFRONT = NFSIZ( INODE ) IN = INODE NPIV = 0 NPIV_COMPG = 0 DO WHILE( IN > 0 ) IF (BLKON) THEN NPIV = NPIV + SIZEOFBLOCKS(IN) ENDIF NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) END DO IF (.NOT.BLKON) NPIV = NPIV_COMPG NCB = NFRONT - NPIV IF ( (NFRONT - (NPIV/2)) .LE. KEEP(9)) RETURN IF ((KEEP(50) == 0.and.int(NFRONT,8) * int(NPIV,8) > K79 ) .OR. &(KEEP(50) .NE.0.and.int(NPIV,8) * int(NPIV,8) > K79 )) GOTO 333 IF (KEEP(210).EQ.1) THEN NSLAVESMIN = 1 NSLAVESMAX = 64 NSLAVES_ESTIM = 32+NSLAVES ELSE NSLAVESMIN = MUMPS_BLOC2_GET_NSLAVESMIN & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375), KEEP(119)) NSLAVESMAX = MUMPS_BLOC2_GET_NSLAVESMAX & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375), KEEP(119)) NSLAVES_ESTIM = max (1, & nint( dble(NSLAVESMAX-NSLAVESMIN)/dble(3) ) & ) NSLAVES_ESTIM = min (NSLAVES_ESTIM, NSLAVES-1) ENDIF IF ( KEEP(50) .eq. 0 ) THEN WK_MASTER = 0.6667D0 * & dble(NPIV)*dble(NPIV)*dble(NPIV) + & dble(NPIV)*dble(NPIV)*dble(NCB) WK_SLAVE = dble( NPIV ) * dble( NCB ) * & ( 2.0D0 * dble(NFRONT) - dble(NPIV) ) & / dble(NSLAVES_ESTIM) ELSE WK_MASTER = dble(NPIV)*dble(NPIV)*dble(NPIV) / dble(3) WK_SLAVE = & (dble(NPIV)*dble(NCB)*dble(NFRONT)) & / dble(NSLAVES_ESTIM) ENDIF IF (KEEP(210).EQ.1) THEN IF ( dble( 100 + STRAT ) & * WK_SLAVE / dble(100) .GE. WK_MASTER ) RETURN ELSE IF ( dble( 100 + STRAT * max( DEPTH-1, 1 ) ) & * WK_SLAVE / dble(100) .GE. WK_MASTER ) RETURN ENDIF 333 CONTINUE IF (NPIV .LE. 1 ) RETURN NPIV_SON = max(NPIV/2,1) NPIV_FATH = NPIV - NPIV_SON IF (SPLITROOT) THEN IF (NCB .NE .0) THEN WRITE(*,*) "Error splitting" CALL MUMPS_ABORT() ENDIF NPIV_FATH = min(int(sqrt(dble(K79))), int(NPIV/2)) NPIV_SON = NPIV - NPIV_FATH ENDIF INODE_SON = INODE IF (BLKON) THEN NPIV_TEMP = 0 NPIV_SON_COMPG = 0 IN_SON = INODE DO WHILE (IN_SON > 0) NPIV_TEMP = NPIV_TEMP + SIZEOFBLOCKS(IN_SON) NPIV_SON_COMPG = NPIV_SON_COMPG +1 IF (NPIV_TEMP.GE.NPIV_SON) EXIT IN_SON = FILS( IN_SON ) END DO NPIV_FATH_COMPG = NPIV_COMPG - NPIV_SON_COMPG NPIV_SON = NPIV_TEMP NPIV_FATH = NPIV - NPIV_SON ELSE NPIV_SON_COMPG = NPIV_SON NPIV_FATH_COMPG = NPIV_FATH IN_SON = INODE DO I = 1, NPIV_SON_COMPG - 1 IN_SON = FILS( IN_SON ) END DO ENDIF IF (NPIV_FATH_COMPG.EQ.0) RETURN NSTEPS = NSTEPS + 1 TOT_CUT = TOT_CUT + 1 INODE_FATH = FILS( IN_SON ) IF ( INODE_FATH .LT. 0 ) THEN write(*,*) 'Error: INODE_FATH < 0 ', INODE_FATH END IF IN_FATH = INODE_FATH DO WHILE ( FILS( IN_FATH ) > 0 ) IN_FATH = FILS( IN_FATH ) END DO FRERE( INODE_FATH ) = FRERE( INODE_SON ) FRERE( INODE_SON ) = - INODE_FATH FILS ( IN_SON ) = FILS( IN_FATH ) FILS ( IN_FATH ) = - INODE_SON IN = FRERE( INODE_FATH ) DO WHILE ( IN > 0 ) IN = FRERE( IN ) END DO IF ( IN .eq. 0 ) GO TO 10 IN = -IN DO WHILE ( FILS( IN ) > 0 ) IN = FILS( IN ) END DO IN_GRANDFATH = IN IF ( FILS( IN_GRANDFATH ) .eq. - INODE_SON ) THEN FILS( IN_GRANDFATH ) = -INODE_FATH ELSE IN = IN_GRANDFATH IN = - FILS ( IN ) DO WHILE ( FRERE( IN ) > 0 ) IF ( FRERE( IN ) .eq. INODE_SON ) THEN FRERE( IN ) = INODE_FATH GOTO 10 END IF IN = FRERE( IN ) END DO WRITE(*,*) 'ERROR 2 in SPLIT NODE', & IN_GRANDFATH, IN, FRERE(IN) END IF 10 CONTINUE NFSIZ(INODE_SON) = NFRONT NFSIZ(INODE_FATH) = NFRONT - NPIV_SON KEEP(2) = max( KEEP(2), NFRONT - NPIV_SON ) IF (SPLITROOT) THEN RETURN ENDIF CALL DMUMPS_SPLIT_1NODE & ( INODE_FATH, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IF (.NOT. SPLITROOT) THEN CALL DMUMPS_SPLIT_1NODE & ( INODE_SON, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) ENDIF RETURN END SUBROUTINE DMUMPS_SPLIT_1NODE SUBROUTINE DMUMPS_SPLIT_ROOT & ( NSLAVES, HOW, INODE, N, FRERE, FILS, NFSIZ, KEEP, KEEP8, & SIZEOFBLOCKS, LSIZEOFBLOCKS, NSTEPS) IMPLICIT NONE INTEGER, INTENT(in) :: NSLAVES, HOW INTEGER, INTENT(in) :: INODE, N INTEGER(8), INTENT(in) :: KEEP8(150) INTEGER, INTENT(inout) :: NSTEPS INTEGER, INTENT(inout) :: KEEP(500) INTEGER, INTENT(inout) :: FRERE( N ), FILS( N ), NFSIZ( N ) INTEGER, INTENT(IN) :: LSIZEOFBLOCKS INTEGER, INTENT(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) LOGICAL :: BLKON INTEGER(8) :: K79 INTEGER I, IN, NPIV, NFRONT INTEGER INODE_SON, INODE_FATH, IN_SON, IN_FATH, IN_GRANDFATH INTEGER NPIV_COMPG, NPIV_SON_COMPG, NPIV_FATH_COMPG INTEGER NPIV_SON, NPIV_FATH, NPIV_TEMP INTEGER, PARAMETER :: K_HOW1 = 4000 IF (FRERE(INODE).NE.0) RETURN BLKON = .NOT.(SIZEOFBLOCKS(1).EQ.-1) K79 = max(KEEP8(79), 4_8) K79 = min(20000_8*20000_8,K79) IF (KEEP(72).EQ.1) THEN K79 = min(3_8*3_8,K79) ENDIF IF ((HOW.LT.1) .OR. (HOW.GT.3)) THEN RETURN ENDIF IF (HOW.EQ.2) THEN K79 = min(K79, 121_8*121_8) ENDIF NFRONT = NFSIZ (INODE) NPIV = NFRONT IF (NPIV .LE. 1 ) RETURN IF (BLKON) THEN IN = INODE NPIV_COMPG = 0 DO WHILE( IN > 0 ) NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) ENDDO ELSE NPIV_COMPG = NPIV ENDIF IF (HOW.EQ.1) THEN IF ( (NFRONT/2) .LT. K_HOW1 ) RETURN NPIV_FATH = max(NFRONT/max(NSLAVES,2), 1) NPIV_FATH = max(NPIV_FATH, K_HOW1/2) NPIV_FATH = min(NPIV_FATH, max(NFRONT/2,1)) NPIV_FATH = min(int(sqrt(dble(K79))), NPIV_FATH) NPIV_SON = NPIV - NPIV_FATH ELSE IF (HOW.EQ.2) THEN NPIV_FATH = min(int(sqrt(dble(K79))), int(NPIV/2)) NPIV_SON = NPIV - NPIV_FATH ELSE NPIV_FATH = max(NFRONT - 3*KEEP(6),1) NPIV_SON = NPIV - NPIV_FATH ENDIF INODE_SON = INODE IF (BLKON) THEN NPIV_TEMP = 0 NPIV_SON_COMPG = 0 IN_SON = INODE DO WHILE (IN_SON > 0) NPIV_TEMP = NPIV_TEMP + SIZEOFBLOCKS(IN_SON) NPIV_SON_COMPG = NPIV_SON_COMPG +1 IF (NPIV_TEMP.GE.NPIV_SON) EXIT IN_SON = FILS( IN_SON ) END DO NPIV_FATH_COMPG = NPIV_COMPG - NPIV_SON_COMPG NPIV_SON = NPIV_TEMP NPIV_FATH = NPIV - NPIV_SON ELSE NPIV_SON_COMPG = NPIV_SON NPIV_FATH_COMPG = NPIV_FATH IN_SON = INODE DO I = 1, NPIV_SON_COMPG - 1 IN_SON = FILS( IN_SON ) END DO ENDIF IF (NPIV_FATH_COMPG.EQ.0) RETURN 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 ) NSTEPS = NSTEPS + 1 IF ( (KEEP(53).EQ.0) .AND. NSLAVES.GT.1) THEN KEEP(38) = INODE_FATH ENDIF IF ( KEEP(53).NE.0 ) THEN KEEP(20) = INODE_FATH ENDIF RETURN END SUBROUTINE DMUMPS_SPLIT_ROOT SUBROUTINE DMUMPS_ANA_GNEW & (N, NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, NBQD, AvgDens, & KEEP264, KEEP265, PRINTSTAT, & INPLACE64_GRAPH_COPY & ) IMPLICIT NONE INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) INTEGER, intent(inout) :: IERROR INTEGER, intent(out) :: symmetry INTEGER, intent(out) :: NBQD, AvgDens INTEGER, intent(out) :: LEN(N), IW(LW) INTEGER(8), intent(out):: IWFR INTEGER(8), intent(out):: NRORM, NIORM INTEGER(8), intent(out):: IPE(N+1) INTEGER, intent(inout) :: IFLAG, KEEP264, KEEP265 INTEGER(8), intent(out):: IQ(N) INTEGER, intent(out) :: FLAG(N) LOGICAL, intent(in) :: PRINTSTAT LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, MPG, I, J, N1 INTEGER :: NBERR, THRESH, IERROR_LOC INTEGER(8) :: K8, K1, K2, LAST, NDUP INTEGER(8) :: NZOFFA, NDIAGA, L, N8 DOUBLE PRECISION :: RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) NZOFFA = 0_8 NDIAGA = 0 IERROR_LOC = 0 N8 = int(N,8) DO I=1,N+1 IPE(I) = 0_8 ENDDO IF (KEEP264.EQ.0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR_LOC = IERROR_LOC + 1 ELSE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR_LOC = IERROR_LOC + 1 ELSE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.EQ.J) THEN NDIAGA = NDIAGA + 1_8 ELSE IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDDO ENDIF ENDIF NIORM = NZOFFA + 3_8*N8 IF ((IERROR_LOC.GE.1).AND.(mod(IFLAG,2) .EQ. 0)) THEN IFLAG = IFLAG+1 IERROR = IERROR_LOC IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN NBERR = 0 WRITE (MP,99999) DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR. & (10_8.LE.K8 .AND. K8.LE.20_8)) THEN WRITE (MP,'(I16,A,I10,A,I10,A)') & K8,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K8,10_8).EQ.1_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'st entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.2_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.3_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE EXIT ENDIF ENDIF ENDDO ENDIF ENDIF NRORM = NIORM - 2_8*N8 IQ(1) = 1_8 N1 = N - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(N)+IQ(N)-1,IQ(N)) FLAG(1:N) = 0 IPE(1:N) = IQ(1:N) IW(1:LAST) = 0 IWFR = LAST + 1_8 IF (KEEP264 .EQ. 0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF (I.LT.J) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDDO ENDIF ENDIF IF (KEEP265.EQ.0) THEN NDUP = 0_8 DO I=1,N K1 = IPE(I) K2 = IQ(I) - 1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) EXIT IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE L = IQ(J) IW(L) = I IQ(J) = L + 1 IW(K8) = J FLAG(J) = I ENDIF END DO LEN(I) = int((IQ(I) - IPE(I))) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,N IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K1 = IPE(I) K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF 270 CONTINUE LEN(I) = int(IWFR - L) ENDDO ELSE KEEP265 = 1 ENDIF IPE(N+1) = IPE(N) + int(LEN(N),8) IWFR = IPE(N+1) ELSE IPE(1) = 1_8 DO I = 1, N LEN(I) = int(IQ(I) - IPE(I)) ENDDO DO I = 1, N IPE(I+1) = IPE(I) + int(LEN(I),8) ENDDO IWFR = IPE(N+1) ENDIF symmetry = 100 IF (SYM.EQ.0) THEN RSYM = dble(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/ & dble(NZOFFA+NDIAGA) IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) & THEN KEEP265 = -1 ENDIF symmetry = min(nint (100.0D0*RSYM), 100) IF (PRINTSTAT) THEN IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) ) & write(MPG,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) ) & write(MP,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry ENDIF ELSE ENDIF AvgDens = nint(dble(IWFR-1_8)/dble(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN DO I= 1, N J = max(LEN(I),1) IF (J.GT.THRESH) NBQD = NBQD+1 ENDDO ENDIF INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1_8)) IF (PRINTSTAT) THEN IF (MPG .GT. 0.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2)) & write(MP,'(A,1I5)') & ' Average density of rows/columns =', AvgDens ENDIF RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE DMUMPS_ANA_GNEW SUBROUTINE DMUMPS_SET_K821_SURFACE & (KEEP821, KEEP2, KEEP48 ,KEEP50, NSLAVES) IMPLICIT NONE INTEGER NSLAVES, KEEP2, KEEP48, KEEP50 INTEGER (8) :: KEEP821 INTEGER(8) KEEP2_SQUARE, NSLAVES8 NSLAVES8= int(NSLAVES,8) KEEP2_SQUARE = int(KEEP2,8) * int(KEEP2,8) KEEP821 = max(KEEP821*int(KEEP2,8),1_8) #if defined(t3e) KEEP821 = min(1500000_8, KEEP821) #elif defined(SP_) KEEP821 = min(3000000_8, KEEP821) #else KEEP821 = min(2000000_8, KEEP821) #endif #if defined(t3e) IF (NSLAVES .GT. 64) THEN KEEP821 = & min(8_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ELSE KEEP821 = & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ENDIF #else IF (NSLAVES.GT.64) THEN KEEP821 = & min(6_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ELSE KEEP821 = & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ENDIF #endif IF (KEEP50 .EQ. 0 ) THEN KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) ELSE KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) ENDIF IF (KEEP50 .EQ. 0 ) THEN #if defined(t3e) KEEP821 = max(KEEP821,200000_8) #else KEEP821 = max(KEEP821,300000_8) #endif ELSE #if defined(t3e) KEEP821 = max(KEEP821,40000_8) #else KEEP821 = max(KEEP821,80000_8) #endif ENDIF KEEP821 = -KEEP821 RETURN END SUBROUTINE DMUMPS_SET_K821_SURFACE SUBROUTINE DMUMPS_MTRANS_DRIVER(JOB,M,N,NE, & IP,IRN,A,LA,NUM,PERM,LIW,IW,LDW,DW, & IPQ8, & ICNTL,CNTL,INFO, INFOMUMPS) IMPLICIT NONE INTEGER :: NICNTL, NCNTL, NINFO, INFOMUMPS(80) PARAMETER (NICNTL=10, NCNTL=10, NINFO=10) INTEGER :: JOB,M,N,NUM INTEGER(8), INTENT(IN) :: NE, LIW,LDW, LA INTEGER(8) :: IP(N+1), IPQ8(N) INTEGER :: IRN(NE),PERM(M),IW(LIW) INTEGER :: ICNTL(NICNTL),INFO(NINFO) DOUBLE PRECISION :: A(LA) DOUBLE PRECISION :: DW(LDW),CNTL(NCNTL) INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWtemp8 INTEGER :: allocok INTEGER :: I,J,WARN1,WARN2,WARN4 INTEGER(8) :: K DOUBLE PRECISION :: FACT,ZERO,ONE,RINF,RINF2,RINF3 PARAMETER (ZERO=0.0D+00,ONE=1.0D+0) EXTERNAL DMUMPS_MTRANSZ,DMUMPS_MTRANSB,DMUMPS_MTRANSR, & DMUMPS_MTRANSS,DMUMPS_MTRANSW INTRINSIC abs,log RINF = CNTL(2) RINF2 = huge(RINF2)/dble(int(2,8)*int(N,8)) RINF3 = 0.0D0 WARN1 = 0 WARN2 = 0 WARN4 = 0 IF (JOB.LT.1 .OR. JOB.GT.6) THEN INFO(1) = -1 INFO(2) = JOB IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'JOB',JOB GO TO 99 ENDIF IF (M.LT.1 .OR. M.LT.N) THEN INFO(1) = -2 INFO(2) = M IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'M',M GO TO 99 ENDIF IF (N.LT.1) THEN INFO(1) = -2 INFO(2) = N IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'N',N GO TO 99 ENDIF IF (NE.LT.1) THEN INFO(1) = -3 CALL MUMPS_SET_IERROR(NE,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'NE',NE GO TO 99 ENDIF IF (JOB.EQ.1) K = 4_8*int(N,8)+int(M,8) IF (JOB.EQ.2) K = int(N,8) + 2_8*int(M,8) IF (JOB.EQ.3) K = 8_8*int(N,8) + 2*int(M,8) + NE IF (JOB.EQ.4) K = int(N,8) + int(M,8) IF (JOB.EQ.5) K = 3_8*int(N,8) + 2_8*int(M,8) IF (JOB.EQ.6) K = 3_8*int(N,8) + 2_8*int(M,8) + NE IF (LIW.LT.K) THEN INFO(1) = -4 CALL MUMPS_SET_IERROR(K,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9004) INFO(1),K GO TO 99 ENDIF IF (JOB.GT.1) THEN IF (JOB.EQ.2) K = int(M,8) IF (JOB.EQ.3) K = int(1,8) IF (JOB.EQ.4) K = 2_8*int(M,8) IF (JOB.EQ.5) K = int(N,8) + 2_8*int(M,8) IF (JOB.EQ.6) K = int(N,8) + 3_8*int(M,8) IF (LDW .LT. K) THEN INFO(1) = -5 CALL MUMPS_SET_IERROR(K,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9005) INFO(1),K GO TO 99 ENDIF ENDIF IF (ICNTL(5).EQ.0) THEN DO 3 I = 1,M IW(I) = 0 3 CONTINUE DO 6 J = 1,N DO 4 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (I.LT.1 .OR. I.GT.M) THEN INFO(1) = -6 INFO(2) = J IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9006) INFO(1),J,I GO TO 99 ENDIF IF (IW(I).EQ.J) THEN INFO(1) = -7 INFO(2) = J IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9007) INFO(1),J,I GO TO 99 ELSE IW(I) = J ENDIF 4 CONTINUE 6 CONTINUE ENDIF IF (ICNTL(3).GT.0) THEN IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9020) JOB,M,N,NE IF (ICNTL(4).EQ.0) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,min(10,N+1)) WRITE(ICNTL(3),9022) (IRN(K),K=1_8,min(10_8,NE)) IF (JOB.GT.1) WRITE(ICNTL(3),9023) & (A(K),K=1_8,min(10_8,NE)) ELSEIF (ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,N+1) WRITE(ICNTL(3),9022) (IRN(K),K=1_8,NE) IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(K),K=1_8,NE) ENDIF WRITE(ICNTL(3),9024) (ICNTL(J),J=1,NICNTL) WRITE(ICNTL(3),9025) (CNTL(J),J=1,NCNTL) ENDIF ENDIF DO 8 I=1,NINFO INFO(I) = 0 8 CONTINUE IF (JOB.EQ.1) THEN DO 10 J = 1,N IW(J) = int(IP(J+1) - IP(J)) 10 CONTINUE CALL DMUMPS_MTRANSZ(M,N,IRN,NE,IP,IW(1),PERM,NUM, & IW( int(N,8)+1_8), & IW(2_8*int(N,8)+1_8), & IW(3_8*int(N,8)+1_8), & IW(3_8*int(N,8)+int(M,8)+1_8)) GO TO 90 ENDIF IF (JOB.EQ.2) THEN DW(1) = max(ZERO,CNTL(1)) CALL DMUMPS_MTRANSB(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IPQ8,IW(int(N,8)+1_8), & IW(int(N,8)+int(M,8)+1_8), & DW,RINF2) GO TO 90 ENDIF IF (JOB.EQ.3) THEN DO 20 K = 1,NE IW(K) = IRN(K) 20 CONTINUE CALL DMUMPS_MTRANSR(N,NE,IP,IW,A) FACT = max(ZERO,CNTL(1)) CALL DMUMPS_MTRANSS(M,N,NE,IP,IW(1),A,PERM,NUM,IW(NE+1_8), & IW(NE+int(N,8)+1_8),IW(NE+2_8*int(N,8)+1_8), & IW(NE+3_8*int(N,8)+1_8), & IW(NE+4_8*int(N,8)+1_8), & IW(NE+5_8*int(N,8)+1_8), & IW(NE+5_8*int(N,8)+int(M,8)+1_8), & FACT,RINF2) GO TO 90 ENDIF IF ((JOB.EQ.4).OR.(JOB.EQ.5).or.(JOB.EQ.6)) THEN ALLOCATE(IWtemp8(int(M,8)+int(N,8)+int(N,8)), stat=allocok) IF (allocok.GT.0) THEN INFOMUMPS(1) = -7 CALL MUMPS_SET_IERROR( int(M,8)+int(N,8)+int(N,8), & INFOMUMPS(2) ) GOTO 90 ENDIF ENDIF IF (JOB.EQ.4) THEN DO 50 J = 1,N FACT = ZERO DO 30 K = IP(J),IP(J+1)-1_8 IF (abs(A(K)).GT.FACT) FACT = abs(A(K)) 30 CONTINUE IF(FACT .GT. RINF3) RINF3 = FACT DO 40 K = IP(J),IP(J+1)-1_8 A(K) = FACT - abs(A(K)) 40 CONTINUE 50 CONTINUE DW(1) = max(ZERO,CNTL(1)) DW(2) = RINF3 IWtemp8(1) = int(JOB,8) CALL DMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(int(N,8)+1_8),IPQ8, & IW(int(N,8)+1_8), & IWtemp8(2_8*int(N,8)+1_8), & DW(1),DW(int(M,8)+1_8),RINF2) DEALLOCATE(IWtemp8) GO TO 90 ENDIF IF (JOB.EQ.5 .or. JOB.EQ.6) THEN RINF3=ONE IF (JOB.EQ.5) THEN DO 75 J = 1,N FACT = ZERO DO 60 K = IP(J),IP(J+1)-1_8 IF (A(K).GT.FACT) FACT = A(K) 60 CONTINUE DW(2_8*int(M,8)+int(J,8)) = FACT IF (FACT.NE.ZERO) THEN FACT = log(FACT) IF(FACT .GT. RINF3) RINF3=FACT DO 70 K = IP(J),IP(J+1)-1_8 IF (A(K).NE.ZERO) THEN A(K) = FACT - log(A(K)) IF(A(K) .GT. RINF3) RINF3=A(K) ELSE A(K) = FACT + RINF ENDIF 70 CONTINUE ELSE DO 71 K = IP(J),IP(J+1)-1_8 A(K) = ONE 71 CONTINUE ENDIF 75 CONTINUE ENDIF IF (JOB.EQ.6) THEN DO 175 K = 1,NE IW(3_8*int(N,8)+2_8*int(M,8)+int(K,8)) = IRN(K) 175 CONTINUE DO 61 I = 1,M DW(2_8*int(M,8)+int(N,8)+int(I,8)) = ZERO 61 CONTINUE DO 63 J = 1,N DO 62 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (A(K).GT.DW(2_8*int(M,8)+int(N,8)+int(I,8))) THEN DW(2_8*int(M,8)+int(N,8)+int(I,8)) = A(K) ENDIF 62 CONTINUE 63 CONTINUE DO 64 I = 1,M IF (DW(2_8*int(M,8)+int(N,8)+int(I,8)).NE.ZERO) THEN DW(2_8*int(M,8)+int(N,8)+int(I,8)) = & 1.0D0/DW(2_8*int(M,8)+int(N,8)+int(I,8)) ENDIF 64 CONTINUE DO 66 J = 1,N DO 65 K = IP(J),IP(J+1)-1 I = IRN(K) A(K) = DW(2_8*int(M,8)+int(N,8)+int(I,8)) * A(K) 65 CONTINUE 66 CONTINUE CALL DMUMPS_MTRANSR(N,NE,IP, & IW(3_8*int(N,8)+2_8*int(M,8)+1_8),A) DO 176 J = 1,N IF (IP(J).NE.IP(J+1)) THEN FACT = A(IP(J)) ELSE FACT = ZERO ENDIF DW(2_8*int(M,8)+int(J,8)) = FACT IF (FACT.NE.ZERO) THEN FACT = log(FACT) DO 170 K = IP(J),IP(J+1)-1_8 IF (A(K).NE.ZERO) THEN A(K) = FACT - log(A(K)) IF(A(K) .GT. RINF3) RINF3=A(K) ELSE A(K) = FACT + RINF ENDIF 170 CONTINUE ELSE DO 171 K = IP(J),IP(J+1)-1_8 A(K) = ONE 171 CONTINUE ENDIF 176 CONTINUE ENDIF DW(1) = max(ZERO,CNTL(1)) RINF3 = RINF3+ONE DW(2) = RINF3 IWtemp8(1) = int(JOB,8) IF (JOB.EQ.5) THEN CALL DMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(int(N,8)+1_8),IPQ8, & IW(int(N,8)+1_8), & IWtemp8(2_8*int(N,8)+1_8), & DW(1),DW(int(M,8)+1_8),RINF2) ENDIF IF (JOB.EQ.6) THEN CALL DMUMPS_MTRANSW(M,N,NE,IP, & IW(3_8*int(N,8)+2_8*int(M,8)+1_8),A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(int(N,8)+1_8),IPQ8, & IW(int(N,8)+1_8), & IWtemp8(2_8*int(N,8)+1_8), & DW(1),DW(int(M,8)+1_8),RINF2) ENDIF IF ((JOB.EQ.5).or.(JOB.EQ.6)) THEN DEALLOCATE(IWtemp8) ENDIF IF (JOB.EQ.6) THEN DO 79 I = 1,M IF (DW(2_8*int(M,8)+int(N,8)+int(I,8)).NE.0.0D0) THEN DW(I) = DW(I) + log(DW(2_8*int(M,8)+int(N,8)+int(I,8))) ENDIF 79 CONTINUE ENDIF IF (NUM.EQ.N) THEN DO 80 J = 1,N IF (DW(2_8*int(M,8)+int(J,8)).NE.ZERO) THEN DW(int(M,8)+int(J,8)) = DW(int(M,8)+int(J,8)) - & log(DW(2_8*int(M,8)+int(J,8))) ELSE DW(int(M,8)+int(J,8)) = ZERO ENDIF 80 CONTINUE ENDIF FACT = 0.5D0*log(RINF2) DO 86 I = 1,M IF (DW(I).LT.FACT) GO TO 86 WARN2 = 2 GO TO 90 86 CONTINUE DO 87 J = 1,N IF (DW(M+J).LT.FACT) GO TO 87 WARN2 = 2 GO TO 90 87 CONTINUE ENDIF 90 IF (INFOMUMPS(1).LT.0) RETURN IF (NUM.LT.N) WARN1 = 1 IF (JOB.EQ.4 .OR. JOB.EQ.5 .OR. JOB.EQ.6) THEN IF (CNTL(1).LT.ZERO) WARN4 = 4 ENDIF IF (INFO(1).EQ.0) THEN INFO(1) = WARN1 + WARN2 + WARN4 IF (INFO(1).GT.0 .AND. ICNTL(2).GT.0) THEN WRITE(ICNTL(2),9010) INFO(1) IF (WARN1.EQ.1) WRITE(ICNTL(2),9011) IF (WARN2.EQ.2) WRITE(ICNTL(2),9012) IF (WARN4.EQ.4) WRITE(ICNTL(2),9014) ENDIF ENDIF IF (ICNTL(3).GE.0) THEN IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9030) (INFO(J),J=1,2) WRITE(ICNTL(3),9031) NUM IF (ICNTL(4).EQ.0) THEN WRITE(ICNTL(3),9032) (PERM(J),J=1,min(10,M)) IF (JOB.EQ.5 .OR. JOB.EQ.6) THEN WRITE(ICNTL(3),9033) (DW(J),J=1,min(10,M)) WRITE(ICNTL(3),9034) (DW(int(M,8)+int(J,8)), & 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(int(M,8)+int(J,8)), & J=1,N) ENDIF ENDIF ENDIF ENDIF 99 RETURN 9001 FORMAT (' ****** Error in DMUMPS_MTRANSA. INFO(1) = ',I2, & ' because ',(A),' = ',I14) 9004 FORMAT (' ****** Error in DMUMPS_MTRANSA. INFO(1) = ',I2/ & ' LIW too small, must be at least ',I14) 9005 FORMAT (' ****** Error in DMUMPS_MTRANSA. INFO(1) = ',I2/ & ' LDW too small, must be at least ',I14) 9006 FORMAT (' ****** Error in DMUMPS_MTRANSA. INFO(1) = ',I2/ & ' Column ',I8, & ' contains an entry with invalid row index ',I8) 9007 FORMAT (' ****** Error in DMUMPS_MTRANSA. INFO(1) = ',I2/ & ' Column ',I8, & ' contains two or more entries with row index ',I8) 9010 FORMAT (' ****** Warning from DMUMPS_MTRANSA. INFO(1) = ',I2) 9011 FORMAT (' - The matrix is structurally singular.') 9012 FORMAT (' - Some scaling factors may be too large.') 9014 FORMAT (' - CNTL(1) is negative and was treated as zero.') 9020 FORMAT (' ****** Input parameters for DMUMPS_MTRANSA:'/ & ' JOB =',I10/' M =',I10/' N =',I10/' NE =',I14) 9021 FORMAT (' IP(1:N+1) = ',8I8/(15X,8I8)) 9022 FORMAT (' IRN(1:NE) = ',8I8/(15X,8I8)) 9023 FORMAT (' A(1:NE) = ',4(1PD14.4)/(15X,4(1PD14.4))) 9024 FORMAT (' ICNTL(1:10) = ',8I8/(15X,2I8)) 9025 FORMAT (' CNTL(1:10) = ',4(1PD14.4)/(15X,4(1PD14.4))) 9030 FORMAT (' ****** Output parameters for DMUMPS_MTRANSA:'/ & ' INFO(1:2) = ',2I8) 9031 FORMAT (' NUM = ',I8) 9032 FORMAT (' PERM(1:M) = ',8I8/(15X,8I8)) 9033 FORMAT (' DW(1:M) = ',5(F11.3)/(15X,5(F11.3))) 9034 FORMAT (' DW(M+1:M+N) = ',5(F11.3)/(15X,5(F11.3))) END SUBROUTINE DMUMPS_MTRANS_DRIVER SUBROUTINE DMUMPS_SUPPRESS_DUPPLI_VAL(N,NZ,IP,IRN,A,FLAG,POSI) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(INOUT) :: NZ INTEGER(8), INTENT(INOUT) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NZ) DOUBLE PRECISION, INTENT(INOUT) :: A(NZ) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER(8), INTENT(OUT) :: POSI(N) INTEGER :: ROW, COL INTEGER(8) :: K, WR_POS, BEG_COL, SV_POS FLAG = 0 WR_POS = 1_8 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1_8 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW A(WR_POS) = A(K) FLAG(ROW) = COL POSI(ROW) = WR_POS WR_POS = WR_POS+1 ELSE SV_POS = POSI(ROW) A(SV_POS) = A(SV_POS) + A(K) ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1_8 RETURN END SUBROUTINE DMUMPS_SUPPRESS_DUPPLI_VAL SUBROUTINE DMUMPS_SUPPRESS_DUPPLI_STR(N,NZ,IP,IRN,FLAG) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(INOUT) :: NZ INTEGER(8), INTENT(INOUT) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NZ) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER :: ROW, COL INTEGER(8) :: K, WR_POS, BEG_COL FLAG = 0 WR_POS = 1_8 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1_8 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW FLAG(ROW) = COL WR_POS = WR_POS+1_8 ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1_8 RETURN END SUBROUTINE DMUMPS_SUPPRESS_DUPPLI_STR SUBROUTINE DMUMPS_SORT_PERM( N, NA, LNA, NE_STEPS, & PERM, FILS, & DAD_STEPS, STEP, NSTEPS, & KEEP60, KEEP20, KEEP38, & INFO) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA INTEGER, INTENT(IN) :: FILS( N ), STEP(N), NA(LNA) INTEGER, INTENT(IN) :: DAD_STEPS ( NSTEPS ), NE_STEPS (NSTEPS) INTEGER, INTENT(IN) :: KEEP60, KEEP20, KEEP38 INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(OUT) :: PERM( N ) INTEGER :: IPERM, INODE, IN, ISCHUR INTEGER :: INBLEAF, INBROOT, allocok INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, NSTK INBLEAF = NA(1) INBROOT = NA(2) ALLOCATE(POOL(INBLEAF), NSTK(NSTEPS), stat=allocok) IF (allocok > 0 ) THEN INFO(1) = -7 INFO(2) = INBLEAF + NSTEPS RETURN ENDIF POOL(1:INBLEAF) = NA(3:2+INBLEAF) NSTK(1:NSTEPS) = NE_STEPS(1:NSTEPS) ISCHUR = 0 IF ( KEEP60.GT.0 ) THEN ISCHUR = max (KEEP20, KEEP38) ENDIF IPERM = 1 DO WHILE ( INBLEAF .NE. 0 ) INODE = POOL( INBLEAF ) INBLEAF = INBLEAF - 1 IN = INODE IF (INODE.NE.ISCHUR) THEN DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO ENDIF IN = DAD_STEPS(STEP( INODE )) IF ( IN .eq. 0 ) THEN INBROOT = INBROOT - 1 ELSE NSTK( STEP(IN) ) = NSTK( STEP(IN) ) - 1 IF ( NSTK( STEP(IN) ) .eq. 0 ) THEN INBLEAF = INBLEAF + 1 POOL( INBLEAF ) = IN END IF END IF END DO IF (IPERM.LE.N) THEN IF (ISCHUR.GT.0) THEN IN = ISCHUR DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO ENDIF ENDIF DEALLOCATE(POOL, NSTK) RETURN END SUBROUTINE DMUMPS_SORT_PERM SUBROUTINE DMUMPS_EXPAND_TREE_STEPS( ICNTL, & N, NBLK, BLKPTR, BLKVAR, & FILS_OLD, FILS_NEW, NSTEPS, & STEP_OLD, STEP_NEW, PAR2_NODES, NB_NIV2, & DAD_STEPS, FRERE_STEPS, & NA, LNA, & LRGROUPS_OLD, SIZELRGROUPS_OLD, & LRGROUPS_NEW, SIZELRGROUPS_NEW, & K20, K38, K494 & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NBLK, ICNTL(60), NSTEPS, LNA, & NB_NIV2, K494 INTEGER, INTENT(IN) :: BLKPTR(NBLK+1), BLKVAR(N) INTEGER, INTENT(IN) :: SIZELRGROUPS_OLD, SIZELRGROUPS_NEW INTEGER, INTENT(IN) :: FILS_OLD(NBLK), STEP_OLD(NBLK), & LRGROUPS_OLD(SIZELRGROUPS_OLD) INTEGER, INTENT(INOUT) :: DAD_STEPS(NSTEPS), FRERE_STEPS(NSTEPS) INTEGER, INTENT(INOUT) :: NA(LNA), PAR2_NODES(NB_NIV2), K20,K38 INTEGER, INTENT(OUT) :: FILS_NEW(N), STEP_NEW(N), & LRGROUPS_NEW(SIZELRGROUPS_NEW) INTEGER :: IB, I, IBFS, IBNB, IFS, INB INTEGER NBLEAF, NBROOT, ISTEP, IGROUP INTEGER :: II IF (K20.GT.0) K20 = BLKVAR(BLKPTR(K20)) IF (K38.GT.0) K38 = BLKVAR(BLKPTR(K38)) NBLEAF = NA(1) NBROOT = NA(2) IF (NBLK.GT.1) THEN DO I= 3, 3+NBLEAF+NBROOT-1 IBNB = NA(I) INB = BLKVAR(BLKPTR(IBNB)) NA(I) = INB ENDDO ENDIF IF (PAR2_NODES(1).GT.0) THEN DO I=1, NB_NIV2 IBNB = PAR2_NODES(I) INB = BLKVAR(BLKPTR(IBNB)) PAR2_NODES(I) = INB ENDDO ENDIF DO I= 1, NSTEPS IBNB = DAD_STEPS(I) IF (IBNB.EQ.0) THEN INB = 0 ELSE INB = BLKVAR(BLKPTR(IBNB)) ENDIF DAD_STEPS(I) = INB ENDDO DO I= 1, NSTEPS IBNB = FRERE_STEPS(I) IF (IBNB.EQ.0) THEN INB = 0 ELSE INB = BLKVAR(BLKPTR(abs(IBNB))) IF (IBNB.LT.0) INB=-INB ENDIF FRERE_STEPS(I) = INB ENDDO DO IB=1, NBLK IBFS = FILS_OLD(IB) IF (IBFS.EQ.0) THEN IFS = 0 ELSE IFS = BLKVAR(BLKPTR(abs(IBFS))) IF (IBFS.LT.0) IFS=-IFS ENDIF IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE DO II=BLKPTR(IB), BLKPTR(IB+1)-1 IF (II.LT. BLKPTR(IB+1)-1) THEN FILS_NEW(BLKVAR(II))= BLKVAR(II+1) ELSE FILS_NEW(BLKVAR(II))= IFS ENDIF ENDDO ENDDO DO IB=1, NBLK ISTEP = STEP_OLD(IB) IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE IF (ISTEP.LT.0) THEN DO II=BLKPTR(IB), BLKPTR(IB+1)-1 STEP_NEW(BLKVAR(II)) = ISTEP ENDDO ELSE I = BLKVAR(BLKPTR(IB)) STEP_NEW(I) = ISTEP DO II=BLKPTR(IB)+1, BLKPTR(IB+1)-1 STEP_NEW(BLKVAR(II)) = -ISTEP ENDDO ENDIF ENDDO IF (K494.NE.0) THEN DO IB=1, NBLK IGROUP = LRGROUPS_OLD(IB) IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE DO II=BLKPTR(IB), BLKPTR(IB+1)-1 LRGROUPS_NEW(BLKVAR(II)) = IGROUP ENDDO ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_EXPAND_TREE_STEPS SUBROUTINE DMUMPS_DIST_AVOID_COPIES(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,PEAK,IERR & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) USE MUMPS_STATIC_MAPPING IMPLICIT NONE INTEGER N, NSLAVES, NBSA, IERR INTEGER ICNTL(60),INFOG(80),KEEP(500) INTEGER(8) KEEP8(150) INTEGER NE(N),NFSIZ(N),FRERE(N),FILS(N),PROCNODE(N) INTEGER SSARBR(N) DOUBLE PRECISION PEAK INTEGER, intent(IN) :: LSIZEOFBLOCKS INTEGER, intent(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) CALL MUMPS_SET_K78_83_91 (NSLAVES,KEEP(78),KEEP(83),KEEP(91)) CALL MUMPS_DISTRIBUTE(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,dble(PEAK),IERR & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) RETURN END SUBROUTINE DMUMPS_DIST_AVOID_COPIES SUBROUTINE DMUMPS_SET_PROCNODE(INODE, PROCNODE, VALUE, FILS, N) INTEGER, intent(in) :: INODE, N, VALUE INTEGER, intent(in) :: FILS(N) INTEGER, intent(inout) :: PROCNODE(N) INTEGER IN IN=INODE DO WHILE ( IN > 0 ) PROCNODE( IN ) = VALUE IN=FILS( IN ) ENDDO RETURN END SUBROUTINE DMUMPS_SET_PROCNODE MUMPS_5.8.1/src/mumps_metis_int.c0000664000175000017500000000310115042446422016603 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mumps_metis_int.h" #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) # include "metis.h" # if defined(parmetis3) || defined(metis4) /* IDXTYPEWIDTH not available, use sizeof(idxtype) */ /* We use metis.h and assume that parmetis datatypes will be identical to those of metis.h since it does not make senss to combine metis and parmetis with different int sizes */ void MUMPS_CALL MUMPS_METIS_IDXSIZE(MUMPS_INT *metis_idx_size) { *metis_idx_size=8*sizeof(idxtype); } # else /* Rely on IDXTYPEWIDTH */ void MUMPS_CALL MUMPS_METIS_IDXSIZE(MUMPS_INT *metis_idx_size) { /* *metis_idx_size=sizeof(idx_t); */ *metis_idx_size=IDXTYPEWIDTH; } /* Retrieve METIS_OPTION_NUMERING */ void MUMPS_CALL MUMPS_METIS_OPTION_NUMBERING(MUMPS_INT *i) { *i=METIS_OPTION_NUMBERING; } # endif #else void MUMPS_CALL MUMPS_METIS_IDXSIZE(MUMPS_INT *metis_int_size) { *metis_int_size=-99999; } void MUMPS_CALL MUMPS_METIS_OPTION_NUMBERING(MUMPS_INT *i) { *i=-99999; } #endif MUMPS_5.8.1/src/mumps_comm_buffer_common.F0000664000175000017500000013064515042446423020426 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_BUF_COMMON PRIVATE PUBLIC :: BUF_ADJUST, BUF_LOOK, MUMPS_BUF_SIZE_AVAILABLE PUBLIC :: MUMPS_BUF_INIT, & MUMPS_BUF_INI_MYID, & MUMPS_BUF_ALLOC_CB , MUMPS_BUF_DEALL_CB , & MUMPS_BUF_ALLOC_SMALL_BUF, MUMPS_BUF_DEALL_SMALL_BUF, & MUMPS_BUF_ALLOC_LOAD_BUFFER,MUMPS_BUF_DEALL_LOAD_BUFFER, & MUMPS_BUF_SEND_1INT, MUMPS_BUF_SEND_DESC_BANDE, & MUMPS_BUF_SEND_MAPLIG, & MUMPS_BUF_SEND_RTNELIND, & MUMPS_BUF_SEND_ROOT2SLAVE, MUMPS_BUF_SEND_ROOT2SON, & MUMPS_BUF_SEND_UPDATE_LOAD, & MUMPS_BUF_DIST_IRECV_SIZE, & MUMPS_BUF_BCAST_ARRAY, MUMPS_BUF_ALL_EMPTY, & MUMPS_BUF_BROADCAST, MUMPS_BUF_SEND_NOT_MSTR, & MUMPS_BUF_SEND_FILS, & MUMPS_BUF_TEST INTEGER NEXT, REQ, CONTENT, OVHSIZE PARAMETER( NEXT = 0, REQ = 1, CONTENT = 2, OVHSIZE = 2 ) PUBLIC :: OVHSIZE INTEGER, SAVE, PUBLIC :: SIZEofINT, SIZEofREAL, BUF_MYID TYPE MUMPS_COMM_BUFFER_TYPE INTEGER LBUF, HEAD, TAIL,LBUF_INT, ILASTMSG INTEGER, DIMENSION(:),POINTER :: CONTENT END TYPE MUMPS_COMM_BUFFER_TYPE TYPE ( MUMPS_COMM_BUFFER_TYPE ), SAVE, PUBLIC :: BUF_CB TYPE ( MUMPS_COMM_BUFFER_TYPE ), SAVE, PUBLIC :: BUF_SMALL TYPE ( MUMPS_COMM_BUFFER_TYPE ), SAVE, PUBLIC :: BUF_LOAD INTEGER, SAVE, PUBLIC :: SIZE_RBUF_BYTES CONTAINS SUBROUTINE MUMPS_BUF_INI_MYID( MYID ) IMPLICIT NONE INTEGER MYID BUF_MYID = MYID RETURN END SUBROUTINE MUMPS_BUF_INI_MYID SUBROUTINE MUMPS_BUF_INIT( IntSize, RealSize ) IMPLICIT NONE INTEGER IntSize, RealSize SIZEofINT = IntSize SIZEofREAL = RealSize NULLIFY(BUF_CB %CONTENT) NULLIFY(BUF_SMALL%CONTENT) NULLIFY(BUF_LOAD%CONTENT) BUF_CB%LBUF = 0 BUF_CB%LBUF_INT = 0 BUF_CB%HEAD = 1 BUF_CB%TAIL = 1 BUF_CB%ILASTMSG = 1 BUF_SMALL%LBUF = 0 BUF_SMALL%LBUF_INT = 0 BUF_SMALL%HEAD = 1 BUF_SMALL%TAIL = 1 BUF_SMALL%ILASTMSG = 1 BUF_LOAD%LBUF = 0 BUF_LOAD%LBUF_INT = 0 BUF_LOAD%HEAD = 1 BUF_LOAD%TAIL = 1 BUF_LOAD%ILASTMSG = 1 RETURN END SUBROUTINE MUMPS_BUF_INIT SUBROUTINE MUMPS_BUF_ALLOC_CB( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL BUF_ALLOC( BUF_CB, SIZE, IERR ) RETURN END SUBROUTINE MUMPS_BUF_ALLOC_CB SUBROUTINE MUMPS_BUF_ALLOC_SMALL_BUF( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL BUF_ALLOC( BUF_SMALL, SIZE, IERR ) RETURN END SUBROUTINE MUMPS_BUF_ALLOC_SMALL_BUF SUBROUTINE MUMPS_BUF_ALLOC_LOAD_BUFFER( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL BUF_ALLOC( BUF_LOAD, SIZE, IERR ) RETURN END SUBROUTINE MUMPS_BUF_ALLOC_LOAD_BUFFER SUBROUTINE MUMPS_BUF_DEALL_LOAD_BUFFER( IERR ) IMPLICIT NONE INTEGER IERR CALL BUF_DEALL( BUF_LOAD, IERR ) RETURN END SUBROUTINE MUMPS_BUF_DEALL_LOAD_BUFFER SUBROUTINE MUMPS_BUF_DEALL_CB( IERR ) IMPLICIT NONE INTEGER IERR CALL BUF_DEALL( BUF_CB, IERR ) RETURN END SUBROUTINE MUMPS_BUF_DEALL_CB SUBROUTINE MUMPS_BUF_DEALL_SMALL_BUF( IERR ) IMPLICIT NONE INTEGER IERR CALL BUF_DEALL( BUF_SMALL, IERR ) RETURN END SUBROUTINE MUMPS_BUF_DEALL_SMALL_BUF SUBROUTINE BUF_ALLOC( BUF, SIZE, IERR ) IMPLICIT NONE TYPE ( MUMPS_COMM_BUFFER_TYPE ) :: BUF INTEGER SIZE, IERR IERR = 0 BUF%LBUF = SIZE BUF%LBUF_INT = ( SIZE + SIZEofINT - 1 ) / SIZEofINT IF ( associated ( BUF%CONTENT ) ) DEALLOCATE( BUF%CONTENT ) ALLOCATE( BUF%CONTENT( BUF%LBUF_INT ), stat = IERR ) IF (IERR .NE. 0) THEN NULLIFY( BUF%CONTENT ) IERR = -1 BUF%LBUF = 0 BUF%LBUF_INT = 0 END IF BUF%HEAD = 1 BUF%TAIL = 1 BUF%ILASTMSG = 1 RETURN END SUBROUTINE BUF_ALLOC SUBROUTINE BUF_DEALL( BUF, IERR ) IMPLICIT NONE TYPE ( MUMPS_COMM_BUFFER_TYPE ) :: BUF INTEGER :: IERR INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: FLAG IF ( .NOT. associated ( BUF%CONTENT ) ) THEN BUF%HEAD = 1 BUF%LBUF = 0 BUF%LBUF_INT = 0 BUF%TAIL = 1 BUF%ILASTMSG = 1 RETURN END IF DO WHILE ( BUF%HEAD.NE.0 .AND. BUF%HEAD .NE. BUF%TAIL ) CALL MPI_TEST(BUF%CONTENT( BUF%HEAD + REQ ), FLAG, & STATUS, IERR_MPI) IF ( .not. FLAG ) THEN WRITE(*,*) '** Warning: trying to cancel a request.' WRITE(*,*) '** This might be problematic' CALL MPI_CANCEL( BUF%CONTENT( BUF%HEAD + REQ ), IERR_MPI ) CALL MPI_REQUEST_FREE( BUF%CONTENT( BUF%HEAD + REQ ), & IERR_MPI ) END IF BUF%HEAD = BUF%CONTENT( BUF%HEAD + NEXT ) END DO DEALLOCATE( BUF%CONTENT ) NULLIFY( BUF%CONTENT ) BUF%LBUF = 0 BUF%LBUF_INT = 0 BUF%HEAD = 1 BUF%TAIL = 1 BUF%ILASTMSG = 1 RETURN END SUBROUTINE BUF_DEALL SUBROUTINE MUMPS_BUF_SEND_1INT( I, DEST, TAG, COMM, & KEEP, IERR ) IMPLICIT NONE INTEGER I INTEGER DEST, TAG, COMM, IERR INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER IPOS, IREQ, MSG_SIZE, POSITION INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1)=DEST IERR = 0 CALL MPI_PACK_SIZE( 1, MPI_INTEGER, & COMM, MSG_SIZE, IERR_MPI ) CALL BUF_LOOK( BUF_SMALL, IPOS, IREQ, MSG_SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN write(6,*) ' Internal error in MUMPS_BUF_SEND_1INT', & ' Buf size (bytes)= ',BUF_SMALL%LBUF RETURN ENDIF POSITION=0 CALL MPI_PACK( I, 1, & MPI_INTEGER, BUF_SMALL%CONTENT( IPOS ), & MSG_SIZE, & POSITION, COMM, IERR_MPI ) KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_SMALL%CONTENT(IPOS), MSG_SIZE, & MPI_PACKED, DEST, TAG, COMM, & BUF_SMALL%CONTENT( IREQ ), IERR_MPI ) RETURN END SUBROUTINE MUMPS_BUF_SEND_1INT SUBROUTINE MUMPS_BUF_ALL_EMPTY(CHECK_COMM_NODES, & CHECK_COMM_LOAD,FLAG) LOGICAL, INTENT(IN) :: CHECK_COMM_NODES, CHECK_COMM_LOAD LOGICAL, INTENT(OUT) :: FLAG LOGICAL FLAG1, FLAG2, FLAG3 FLAG = .TRUE. IF (CHECK_COMM_NODES) THEN CALL MUMPS_BUF_EMPTY( BUF_SMALL, FLAG1 ) CALL MUMPS_BUF_EMPTY( BUF_CB, FLAG2 ) FLAG = FLAG .AND. FLAG1 .AND. FLAG2 ENDIF IF ( CHECK_COMM_LOAD ) THEN CALL MUMPS_BUF_EMPTY( BUF_LOAD, FLAG3 ) FLAG = FLAG .AND. FLAG3 ENDIF RETURN END SUBROUTINE MUMPS_BUF_ALL_EMPTY SUBROUTINE MUMPS_BUF_EMPTY( B, FLAG ) TYPE ( MUMPS_COMM_BUFFER_TYPE ) :: B LOGICAL :: FLAG INTEGER SIZE_AVAIL CALL MUMPS_BUF_SIZE_AVAILABLE(B, SIZE_AVAIL) FLAG = ( B%HEAD == B%TAIL ) RETURN END SUBROUTINE MUMPS_BUF_EMPTY SUBROUTINE MUMPS_BUF_FREEREQUESTS( B ) IMPLICIT NONE TYPE ( MUMPS_COMM_BUFFER_TYPE ) :: B INCLUDE 'mpif.h' INTEGER :: IERR_MPI, CURRENT, LAST_NOT_FREE, LAST_NOT_FREE_TAIL INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: FLAG, BROADCAST_NOT_FREE IF ( B%HEAD .NE. B%TAIL ) THEN 10 CONTINUE CALL MPI_TEST( B%CONTENT( B%HEAD + REQ ), FLAG, STATUS, & IERR_MPI ) IF ( FLAG ) THEN B%HEAD = B%CONTENT( B%HEAD + NEXT ) IF ( B%HEAD .EQ. 0 ) B%HEAD = B%TAIL IF ( B%HEAD .NE. B%TAIL ) GOTO 10 ELSE LAST_NOT_FREE = B%HEAD CURRENT = B%CONTENT( LAST_NOT_FREE + NEXT ) LAST_NOT_FREE_TAIL = CURRENT BROADCAST_NOT_FREE = B%CONTENT(LAST_NOT_FREE+NEXT).EQ. & LAST_NOT_FREE+OVHSIZE DO WHILE ( CURRENT .NE. 0 ) IF (BROADCAST_NOT_FREE) THEN FLAG = .FALSE. ELSE CALL MPI_TEST( B%CONTENT( CURRENT + REQ ), FLAG, STATUS, & IERR_MPI ) ENDIF IF (FLAG) THEN CURRENT = B%CONTENT( CURRENT + NEXT ) B%CONTENT( LAST_NOT_FREE + NEXT ) = CURRENT ELSE LAST_NOT_FREE = CURRENT CURRENT = B%CONTENT( CURRENT + NEXT ) IF ( CURRENT .NE. 0 ) THEN LAST_NOT_FREE_TAIL = CURRENT ELSE LAST_NOT_FREE_TAIL = B%TAIL ENDIF BROADCAST_NOT_FREE = B%CONTENT(LAST_NOT_FREE+NEXT).EQ. & LAST_NOT_FREE+OVHSIZE ENDIF ENDDO IF ( LAST_NOT_FREE_TAIL .NE. 0 ) THEN B%TAIL = LAST_NOT_FREE_TAIL B%ILASTMSG = LAST_NOT_FREE ELSE IF (B%ILASTMSG .NE. LAST_NOT_FREE) THEN WRITE(*,*) "ABORT", B%ILASTMSG, LAST_NOT_FREE CALL MUMPS_ABORT() ENDIF END IF END IF IF ( B%HEAD .EQ. B%TAIL ) THEN B%HEAD = 1 B%TAIL = 1 B%ILASTMSG = 1 END IF RETURN END SUBROUTINE MUMPS_BUF_FREEREQUESTS SUBROUTINE MUMPS_BUF_SIZE_AVAILABLE( B, SIZE_AV, SIZE_AV2 ) IMPLICIT NONE TYPE ( MUMPS_COMM_BUFFER_TYPE ) :: B INTEGER, INTENT(OUT) :: SIZE_AV INTEGER, OPTIONAL, INTENT(OUT) :: SIZE_AV2 CALL MUMPS_BUF_FREEREQUESTS( B ) IF ( B%HEAD .LE. B%TAIL ) THEN SIZE_AV = max( B%LBUF_INT - B%TAIL, B%HEAD - 2 ) IF ( B%LBUF_INT - B%TAIL .GT. B%HEAD - 2 ) THEN SIZE_AV = B%LBUF_INT - B%TAIL IF (present(SIZE_AV2)) SIZE_AV2 = 0 ELSE SIZE_AV = B%HEAD - 2 IF (present(SIZE_AV2)) SIZE_AV2 = B%LBUF_INT - B%TAIL ENDIF ELSE SIZE_AV = B%HEAD - B%TAIL - 1 IF (present(SIZE_AV2)) SIZE_AV2 = 0 END IF SIZE_AV = max(0,SIZE_AV - OVHSIZE) SIZE_AV = SIZE_AV * SIZEofINT IF (present(SIZE_AV2)) THEN IF (SIZE_AV2 .NE. 0) THEN SIZE_AV = max(0,SIZE_AV2 - OVHSIZE) SIZE_AV2 = SIZE_AV2 * SIZEofINT ENDIF ENDIF RETURN END SUBROUTINE MUMPS_BUF_SIZE_AVAILABLE SUBROUTINE MUMPS_BUF_TEST() CALL MUMPS_BUF_FREEREQUESTS(BUF_CB) RETURN END SUBROUTINE MUMPS_BUF_TEST SUBROUTINE BUF_LOOK( B, IPOS, IREQ, MSG_SIZE, IERR, & NDEST , PDEST ) IMPLICIT NONE TYPE ( MUMPS_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 IERR = 0 CALL MUMPS_BUF_FREEREQUESTS( B ) MSG_SIZE_INT = ( MSG_SIZE + ( SIZEofINT - 1 ) ) / SIZEofINT MSG_SIZE_INT = MSG_SIZE_INT + OVHSIZE IF ( MSG_SIZE_INT .GT. B%LBUF_INT - 1 ) THEN IERR = -2 IPOS = -1 IREQ = -1 RETURN END IF IF ( B%HEAD .LE. B%TAIL ) THEN IF ( MSG_SIZE_INT .LE. B%LBUF_INT - B%TAIL ) THEN IBUF = B%TAIL ELSE IF ( MSG_SIZE_INT .LE. B%HEAD - 2 ) THEN IBUF = 1 ELSE IERR = -1 END IF ELSE IF ( MSG_SIZE_INT .LE . B%HEAD - B%TAIL - 1) THEN IBUF = B%TAIL ELSE IERR = -1 ENDIF END IF IF (IERR .LT. 0) RETURN B%CONTENT( B%ILASTMSG + NEXT ) = IBUF B%ILASTMSG = IBUF B%TAIL = IBUF + MSG_SIZE_INT B%CONTENT( IBUF + NEXT ) = 0 IPOS = IBUF + CONTENT IREQ = IBUF + REQ RETURN END SUBROUTINE BUF_LOOK SUBROUTINE BUF_ADJUST( BUF, SIZE ) IMPLICIT NONE TYPE ( MUMPS_COMM_BUFFER_TYPE ) :: BUF INTEGER SIZE INTEGER SIZE_INT SIZE_INT = ( SIZE + SIZEofINT - 1 ) / SIZEofINT SIZE_INT = SIZE_INT + OVHSIZE BUF%TAIL = BUF%ILASTMSG + SIZE_INT RETURN END SUBROUTINE BUF_ADJUST SUBROUTINE MUMPS_BUF_SEND_DESC_BANDE( & INODE, NBPROCFILS, NLIG, ILIG, NCOL, ICOL, & NASS, NSLAVES_HDR, LIST_SLAVES, & NSLAVES, & ESTIM_NFS4FATHER_ATSON, & DEST, NFRONT, COMM, KEEP, IERR & , LRSTATUS &) IMPLICIT NONE INTEGER COMM, IERR, NFRONT INTEGER, intent(in) :: INODE INTEGER, intent(in) :: NLIG, NCOL, NASS, NSLAVES_HDR, NSLAVES INTEGER, intent(in) :: ESTIM_NFS4FATHER_ATSON INTEGER NBPROCFILS, DEST INTEGER ILIG( NLIG ) INTEGER ICOL( NCOL ) INTEGER LIST_SLAVES( max(NSLAVES_HDR,1) ) INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER, INTENT(IN) :: LRSTATUS INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE_INT, SIZE_BYTES, POSITION, IPOS, IREQ INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 SIZE_INT = ( 11 + NLIG + NCOL + NSLAVES_HDR ) SIZE_BYTES = SIZE_INT * SIZEofINT IF (SIZE_INT.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 RETURN END IF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_BYTES, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = IPOS BUF_CB%CONTENT( POSITION ) = SIZE_INT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = INODE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NBPROCFILS POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NLIG POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NCOL POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NASS POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFRONT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES_HDR POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = LRSTATUS POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = ESTIM_NFS4FATHER_ATSON POSITION = POSITION + 1 IF (NSLAVES_HDR.GT.0) THEN BUF_CB%CONTENT( POSITION: POSITION + NSLAVES_HDR - 1 ) = & LIST_SLAVES( 1: NSLAVES_HDR ) POSITION = POSITION + NSLAVES_HDR ENDIF BUF_CB%CONTENT( POSITION:POSITION + NLIG - 1 ) = ILIG POSITION = POSITION + NLIG BUF_CB%CONTENT( POSITION:POSITION + NCOL - 1 ) = ICOL POSITION = POSITION + NCOL POSITION = POSITION - IPOS IF ( POSITION * SIZEofINT .NE. SIZE_BYTES ) THEN WRITE(*,*) 'Error in MUMPS_BUF_SEND_DESC_BANDE :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE_BYTES, & MPI_PACKED, & DEST, MAITRE_DESC_BANDE, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) RETURN END SUBROUTINE MUMPS_BUF_SEND_DESC_BANDE SUBROUTINE MUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, NSLAVES, SLAVES_PERE, & TROW, NCBSON, & COMM, IERR, & DEST, NDEST, SLAVEF, & & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & & ) IMPLICIT NONE INTEGER INODE, NFRONT, NASS1, NCBSON, NSLAVES, & NDEST INTEGER SLAVEF, MYID, ISON INTEGER TROW( NCBSON ) INTEGER DEST( NDEST ) INTEGER SLAVES_PERE( NSLAVES ) INTEGER COMM, IERR INTEGER KEEP(500), N INTEGER(8) KEEP8(150) INTEGER STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE_AV, IDEST, NSEND, SIZE, NFS4FATHER INTEGER TROW_SIZE, POSITION, INDX, INIV2 INTEGER IPOS, IREQ INTEGER IONE PARAMETER ( IONE=1 ) IERR = 0 IF ( NDEST .eq. 1 ) THEN IF ( DEST(1).EQ.MYID ) GOTO 500 SIZE = SIZEofINT * ( 7 + NSLAVES + NCBSON ) IF ( NSLAVES.GT.0 ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF IF (SIZE.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 RETURN END IF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST & ) IF (IERR .LT. 0 ) THEN RETURN ENDIF POSITION = IPOS BUF_CB%CONTENT( POSITION ) = INODE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = ISON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFRONT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NASS1 POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NCBSON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF ( NSLAVES.GT.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) BUF_CB%CONTENT( POSITION: POSITION + NSLAVES ) & = TAB_POS_IN_PERE(1:NSLAVES+1,INIV2) POSITION = POSITION + NSLAVES + 1 ENDIF IF ( NSLAVES .NE. 0 ) THEN BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) & = SLAVES_PERE( 1: NSLAVES ) POSITION = POSITION + NSLAVES END IF BUF_CB%CONTENT( POSITION:POSITION+NCBSON-1 ) = & TROW( 1: NCBSON ) POSITION = POSITION + NCBSON POSITION = POSITION - IPOS IF ( POSITION * SIZEofINT .NE. SIZE ) THEN WRITE(*,*) 'Error in MUMPS_BUF_SEND_MAPLIG :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, & MPI_PACKED, & DEST( NDEST ), MAPLIG, COMM, & BUF_CB%CONTENT( IREQ ), & IERR_MPI ) ELSE NSEND = 0 DO IDEST = 1, NDEST IF ( DEST( IDEST ) .ne. MYID ) NSEND = NSEND + 1 END DO SIZE = SIZEofINT * & ( ( OVHSIZE + 7 + NSLAVES )* NSEND + NCBSON ) IF ( NSLAVES.GT.0 ) THEN SIZE = SIZE + SIZEofINT * NSEND*( NSLAVES + 1 ) ENDIF CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE ) THEN IERR = -1 RETURN END IF DO IDEST= 1, NDEST CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & IDEST, NCBSON, & NDEST, & TROW_SIZE, INDX ) SIZE = SIZEofINT * ( NSLAVES + TROW_SIZE + 7 ) IF ( NSLAVES.GT.0 ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF IF ( MYID .NE. DEST( IDEST ) ) THEN IF (SIZE.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST(IDEST) ) IF ( IERR .LT. 0 ) THEN WRITE(*,*) 'Internal error MUMPS_BUF_SEND_MAPLIG', & 'IERR after BUF_LOOK=',IERR CALL MUMPS_ABORT() END IF POSITION = IPOS BUF_CB%CONTENT( POSITION ) = INODE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = ISON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFRONT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NASS1 POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = TROW_SIZE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF ( NSLAVES.GT.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) BUF_CB%CONTENT( POSITION: POSITION + NSLAVES ) & = TAB_POS_IN_PERE(1:NSLAVES+1,INIV2) POSITION = POSITION + NSLAVES + 1 ENDIF IF ( NSLAVES .NE. 0 ) THEN BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) & = SLAVES_PERE( 1: NSLAVES ) POSITION = POSITION + NSLAVES END IF BUF_CB%CONTENT( POSITION:POSITION+TROW_SIZE-1 ) = & TROW( INDX: INDX + TROW_SIZE - 1 ) POSITION = POSITION + TROW_SIZE POSITION = POSITION - IPOS IF ( POSITION * SIZEofINT .NE. SIZE ) THEN WRITE(*,*) ' ERROR 1 in TRY_SEND_MAPLIG:', & 'Wrong estimated size' CALL MUMPS_ABORT() END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, & MPI_PACKED, & DEST( IDEST ), MAPLIG, COMM, & BUF_CB%CONTENT( IREQ ), & IERR_MPI ) END IF END DO END IF 500 CONTINUE RETURN END SUBROUTINE MUMPS_BUF_SEND_MAPLIG SUBROUTINE MUMPS_BUF_SEND_RTNELIND( ISON, NELIM, & NELIM_ROW, NELIM_COL, NSLAVES, SLAVES, & DEST, COMM, KEEP, IERR ) INTEGER ISON, NELIM INTEGER NSLAVES, DEST, COMM, IERR INTEGER NELIM_ROW( NELIM ), NELIM_COL( NELIM ) INTEGER SLAVES( NSLAVES ) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE, POSITION, IPOS, IREQ INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 SIZE = ( 3 + NSLAVES + 2 * NELIM ) * SIZEofINT IF (SIZE.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = IPOS BUF_CB%CONTENT( POSITION ) = ISON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NELIM POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION: POSITION + NELIM - 1 ) = NELIM_ROW POSITION = POSITION + NELIM BUF_CB%CONTENT( POSITION: POSITION + NELIM - 1 ) = NELIM_COL POSITION = POSITION + NELIM BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) = SLAVES POSITION = POSITION + NSLAVES POSITION = POSITION - IPOS IF ( POSITION * SIZEofINT .NE. SIZE ) THEN WRITE(*,*) 'Error in MUMPS_BUF_SEND_ROOT_NELIM_INDICES:', & 'wrong estimated size' CALL MUMPS_ABORT() END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, & MPI_PACKED, & DEST, ROOT_NELIM_INDICES, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) RETURN END SUBROUTINE MUMPS_BUF_SEND_RTNELIND SUBROUTINE MUMPS_BUF_SEND_ROOT2SON( ISON, NELIM_ROOT, & DEST, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER ISON, NELIM_ROOT, DEST, COMM, IERR INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER IPOS, IREQ, SIZE INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1)=DEST IERR = 0 SIZE = 2 * SIZEofINT CALL BUF_LOOK( BUF_SMALL, IPOS, IREQ, SIZE, IERR, & IONE, DEST2 & ) IF ( IERR .LT. 0 ) THEN WRITE(*,*) 'Internal error 1 with small buffers ' CALL MUMPS_ABORT() END IF IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_SMALL%CONTENT( IPOS ) = ISON BUF_SMALL%CONTENT( IPOS + 1 ) = NELIM_ROOT KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_SMALL%CONTENT( IPOS ), SIZE, & MPI_PACKED, & DEST, ROOT_2SON, COMM, & BUF_SMALL%CONTENT( IREQ ), IERR_MPI ) RETURN END SUBROUTINE MUMPS_BUF_SEND_ROOT2SON SUBROUTINE MUMPS_BUF_SEND_ROOT2SLAVE & ( TOT_ROOT_SIZE, TOT_CONT2RECV, DEST, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER TOT_ROOT_SIZE, TOT_CONT2RECV, DEST, COMM, IERR INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE, IPOS, IREQ INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) IERR = 0 DEST2(1) = DEST SIZE = 2 * SIZEofINT CALL BUF_LOOK( BUF_SMALL, IPOS, IREQ, SIZE, IERR, & IONE, DEST2 & ) IF ( IERR .LT. 0 ) THEN WRITE(*,*) 'Internal error 2 with small buffers ' CALL MUMPS_ABORT() END IF IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_SMALL%CONTENT( IPOS ) = TOT_ROOT_SIZE BUF_SMALL%CONTENT( IPOS + 1 ) = TOT_CONT2RECV KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_SMALL%CONTENT( IPOS ), SIZE, & MPI_PACKED, & DEST, ROOT_2SLAVE, COMM, & BUF_SMALL%CONTENT( IREQ ), IERR_MPI ) RETURN END SUBROUTINE MUMPS_BUF_SEND_ROOT2SLAVE SUBROUTINE MUMPS_BUF_SEND_UPDATE_LOAD & ( BDC_SBTR,BDC_MEM,BDC_MD, COMM, NPROCS, LOAD, & MEM,SBTR_CUR, & LU_USAGE, & FUTURE_NIV2, & MYID, KEEP, IERR) IMPLICIT NONE INTEGER COMM, NPROCS, MYID, IERR INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER FUTURE_NIV2(NPROCS) DOUBLE PRECISION LU_USAGE DOUBLE PRECISION LOAD DOUBLE PRECISION MEM,SBTR_CUR LOGICAL BDC_MEM,BDC_SBTR,BDC_MD INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE INTEGER I, NDEST, IDEST, IPOSMSG, WHAT, NREALS INTEGER IZERO INTEGER MYID2(1) PARAMETER ( IZERO=0 ) IERR = 0 MYID2(1) = MYID NDEST = NPROCS - 1 NDEST = 0 DO I = 1, NPROCS IF ( I .NE. MYID + 1 .AND. FUTURE_NIV2(I).NE.0) THEN NDEST = NDEST + 1 ENDIF ENDDO IF ( NDEST .eq. 0 ) THEN RETURN ENDIF CALL MPI_PACK_SIZE( 1 + (NDEST-1) * OVHSIZE, & MPI_INTEGER, COMM, & SIZE1, IERR_MPI ) NREALS = 1 IF (BDC_MEM) THEN NREALS = 2 ENDIf IF (BDC_SBTR)THEN NREALS = 3 ENDIF IF(BDC_MD)THEN NREALS=NREALS+1 ENDIF CALL MPI_PACK_SIZE( NREALS, MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR_MPI ) SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_LOAD, IPOS, IREQ, SIZE, IERR, & IZERO, MYID2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_LOAD%ILASTMSG = BUF_LOAD%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_LOAD%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_LOAD%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST WHAT = 0 POSITION = 0 CALL MPI_PACK( WHAT, 1, MPI_INTEGER, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LOAD, 1, MPI_DOUBLE_PRECISION, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) IF (BDC_MEM) THEN CALL MPI_PACK( MEM, 1, MPI_DOUBLE_PRECISION, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) END IF IF (BDC_SBTR) THEN CALL MPI_PACK( SBTR_CUR, 1, MPI_DOUBLE_PRECISION, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) END IF IF(BDC_MD)THEN CALL MPI_PACK( LU_USAGE, 1, MPI_DOUBLE_PRECISION, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF IDEST = 0 DO I = 0, NPROCS - 1 IF ( I .NE. MYID .AND. FUTURE_NIV2(I+1) .NE. 0) THEN IDEST = IDEST + 1 KEEP(267)=KEEP(267)+1 CALL MPI_ISEND( BUF_LOAD%CONTENT( IPOSMSG ), & POSITION, MPI_PACKED, I, & UPDATE_LOAD, COMM, & BUF_LOAD%CONTENT( IREQ+(IDEST-1)*OVHSIZE ), & IERR_MPI ) END IF END DO SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) ' Error in MUMPS_BUF_SEND_UPDATE_LOAD' WRITE(*,*) ' Size,position=',SIZE,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) & CALL BUF_ADJUST( BUF_LOAD, POSITION ) RETURN END SUBROUTINE MUMPS_BUF_SEND_UPDATE_LOAD SUBROUTINE MUMPS_BUF_BROADCAST & ( WHAT, COMM, NPROCS, & FUTURE_NIV2, & LOAD, UPD_LOAD, & MYID, KEEP267, IERR) IMPLICIT NONE INTEGER COMM, NPROCS, MYID, IERR, WHAT DOUBLE PRECISION LOAD,UPD_LOAD INTEGER, INTENT(INOUT) :: KEEP267 INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE INTEGER I, NDEST, IDEST, IPOSMSG, NREALS INTEGER IZERO INTEGER MYID2(1) INTEGER FUTURE_NIV2(NPROCS) PARAMETER ( IZERO=0 ) IERR = 0 IF (WHAT .NE. 2 .AND. WHAT .NE. 3 .AND. & WHAT.NE.6.AND. WHAT.NE.8 .AND.WHAT.NE.9.AND. & WHAT.NE.17) THEN WRITE(*,*) & "Internal error 1 in MUMPS_BUF_BROADCAST",WHAT END IF MYID2(1) = MYID NDEST = NPROCS - 1 NDEST = 0 DO I = 1, NPROCS IF ( I .NE. MYID + 1 .AND. FUTURE_NIV2(I).NE.0) THEN NDEST = NDEST + 1 ENDIF ENDDO IF ( NDEST .eq. 0 ) THEN RETURN ENDIF CALL MPI_PACK_SIZE( 1 + (NDEST-1) * OVHSIZE, & MPI_INTEGER, COMM, & SIZE1, IERR_MPI ) IF((WHAT.NE.17).AND.(WHAT.NE.10))THEN NREALS = 1 ELSE NREALS = 2 ENDIF CALL MPI_PACK_SIZE( NREALS, MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR_MPI ) SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_LOAD, IPOS, IREQ, SIZE, IERR, & IZERO, MYID2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_LOAD%ILASTMSG = BUF_LOAD%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_LOAD%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_LOAD%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST POSITION = 0 CALL MPI_PACK( WHAT, 1, MPI_INTEGER, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LOAD, 1, MPI_DOUBLE_PRECISION, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) IF((WHAT.EQ.17).OR.(WHAT.EQ.10))THEN CALL MPI_PACK( UPD_LOAD, 1, MPI_DOUBLE_PRECISION, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF IDEST = 0 DO I = 0, NPROCS - 1 IF ( I .NE. MYID .AND. FUTURE_NIV2(I+1) .NE. 0) THEN IDEST = IDEST + 1 KEEP267 = KEEP267 + 1 CALL MPI_ISEND( BUF_LOAD%CONTENT( IPOSMSG ), & POSITION, MPI_PACKED, I, & UPDATE_LOAD, COMM, & BUF_LOAD%CONTENT( IREQ+(IDEST-1)*OVHSIZE ), & IERR_MPI ) END IF END DO SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) ' Error in MUMPS_BUF_BROADCAST' WRITE(*,*) ' Size,position=',SIZE,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) & CALL BUF_ADJUST( BUF_LOAD, POSITION ) RETURN END SUBROUTINE MUMPS_BUF_BROADCAST SUBROUTINE MUMPS_BUF_SEND_FILS & ( WHAT, COMM, NPROCS, & FATHER_NODE,INODE,NCB,KEEP, & MYID,REMOTE, IERR) IMPLICIT NONE INTEGER COMM, NPROCS, MYID, IERR, WHAT,REMOTE INTEGER FATHER_NODE,INODE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS, SIZE INTEGER NDEST, IDEST, IPOSMSG INTEGER IZERO,NCB,KEEP(500) INTEGER MYID2(1) PARAMETER ( IZERO=0 ) MYID2(1) = MYID NDEST = 1 IF ( NDEST .eq. 0 ) THEN RETURN ENDIF IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN CALL MPI_PACK_SIZE( 4 + OVHSIZE, & MPI_INTEGER, COMM, & SIZE, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 2, & MPI_INTEGER, COMM, & SIZE, IERR_MPI ) ENDIF CALL BUF_LOOK( BUF_LOAD, IPOS, IREQ, SIZE, IERR, & IZERO, MYID2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_LOAD%ILASTMSG = BUF_LOAD%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_LOAD%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_LOAD%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST POSITION = 0 CALL MPI_PACK( WHAT, 1, MPI_INTEGER, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FATHER_NODE, 1, MPI_INTEGER, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCB, 1, MPI_INTEGER, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF IDEST = 1 KEEP(267)=KEEP(267)+1 CALL MPI_ISEND( BUF_LOAD%CONTENT( IPOSMSG ), & POSITION, MPI_PACKED, REMOTE, & UPDATE_LOAD, COMM, & BUF_LOAD%CONTENT( IREQ+(IDEST-1)*OVHSIZE ), & IERR_MPI ) SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) ' Error in MUMPS_BUF_SEND_FILS' WRITE(*,*) ' Size,position=',SIZE,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) & CALL BUF_ADJUST( BUF_LOAD, POSITION ) RETURN END SUBROUTINE MUMPS_BUF_SEND_FILS SUBROUTINE MUMPS_BUF_SEND_NOT_MSTR( COMM, MYID, NPROCS, & MAX_SURF_MASTER, KEEP, IERR) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER COMM, MYID, IERR, NPROCS DOUBLE PRECISION MAX_SURF_MASTER INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER :: IERR_MPI INTEGER IPOS, IREQ, IDEST, IPOSMSG, POSITION, I INTEGER IZERO INTEGER MYID2(1) PARAMETER ( IZERO=0 ) INTEGER NDEST, NINTS, NREALS, SIZE, SIZE1, SIZE2 INTEGER WHAT IERR = 0 MYID2(1) = MYID NDEST = NPROCS - 1 NINTS = 1 + ( NDEST-1 ) * OVHSIZE NREALS = 1 CALL MPI_PACK_SIZE( NINTS, & MPI_INTEGER, COMM, & SIZE1, IERR_MPI ) CALL MPI_PACK_SIZE( NREALS, & MPI_DOUBLE_PRECISION, COMM, & SIZE2, IERR_MPI ) SIZE=SIZE1+SIZE2 CALL BUF_LOOK( BUF_LOAD, IPOS, IREQ, SIZE, IERR, & IZERO, MYID2 ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_LOAD%ILASTMSG = BUF_LOAD%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_LOAD%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_LOAD%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST POSITION = 0 WHAT = 4 CALL MPI_PACK( WHAT, 1, MPI_INTEGER, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( MAX_SURF_MASTER, 1, MPI_DOUBLE_PRECISION, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) IDEST = 0 DO I = 0, NPROCS - 1 IF ( I .ne. MYID ) THEN IDEST = IDEST + 1 KEEP(267)=KEEP(267)+1 CALL MPI_ISEND( BUF_LOAD%CONTENT( IPOSMSG ), & POSITION, MPI_PACKED, I, & UPDATE_LOAD, COMM, & BUF_LOAD%CONTENT( IREQ+(IDEST-1)*OVHSIZE ), & IERR_MPI ) END IF END DO SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) ' Error in MUMPS_BUF_BCAST_ARRAY' WRITE(*,*) ' Size,position=',SIZE,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) & CALL BUF_ADJUST( BUF_LOAD, POSITION ) RETURN END SUBROUTINE MUMPS_BUF_SEND_NOT_MSTR SUBROUTINE MUMPS_BUF_BCAST_ARRAY( BDC_MEM, & COMM, MYID, NPROCS, & FUTURE_NIV2, & NSLAVES, & LIST_SLAVES,INODE, & MEM_INCREMENT, FLOPS_INCREMENT,CB_BAND, WHAT, & KEEP, & IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' LOGICAL BDC_MEM INTEGER COMM, MYID, NPROCS, NSLAVES, IERR INTEGER FUTURE_NIV2(NPROCS) INTEGER LIST_SLAVES(NSLAVES),INODE DOUBLE PRECISION MEM_INCREMENT(NSLAVES) DOUBLE PRECISION FLOPS_INCREMENT(NSLAVES) DOUBLE PRECISION CB_BAND(NSLAVES) INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER :: IERR_MPI INTEGER NDEST, NINTS, NREALS, SIZE1, SIZE2, SIZE INTEGER IPOS, IPOSMSG, IREQ, POSITION INTEGER I, IDEST, WHAT INTEGER IZERO INTEGER MYID2(1) PARAMETER ( IZERO=0 ) MYID2(1)=MYID IERR = 0 NDEST = 0 DO I = 1, NPROCS IF ( I .NE. MYID + 1 .AND. FUTURE_NIV2(I).NE.0) THEN NDEST = NDEST + 1 ENDIF ENDDO IF ( NDEST == 0 ) THEN RETURN ENDIF NINTS = 2 + NSLAVES + ( NDEST - 1 ) * OVHSIZE + 1 NREALS = NSLAVES IF (BDC_MEM) NREALS = NREALS + NSLAVES IF(WHAT.EQ.19) THEN NREALS = NREALS + NSLAVES ENDIF CALL MPI_PACK_SIZE( NINTS, & MPI_INTEGER, COMM, & SIZE1, IERR_MPI ) CALL MPI_PACK_SIZE( NREALS, MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR_MPI ) SIZE = SIZE1+SIZE2 CALL BUF_LOOK( BUF_LOAD, IPOS, IREQ, SIZE, IERR, & IZERO, MYID2 ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_LOAD%ILASTMSG = BUF_LOAD%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_LOAD%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_LOAD%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST POSITION = 0 CALL MPI_PACK( WHAT, 1, MPI_INTEGER, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSLAVES, 1, MPI_INTEGER, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LIST_SLAVES, NSLAVES, MPI_INTEGER, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FLOPS_INCREMENT, NSLAVES, & MPI_DOUBLE_PRECISION, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) IF (BDC_MEM) THEN CALL MPI_PACK( MEM_INCREMENT, NSLAVES, & MPI_DOUBLE_PRECISION, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) END IF IF(WHAT.EQ.19)THEN CALL MPI_PACK( CB_BAND, NSLAVES, & MPI_DOUBLE_PRECISION, & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF IDEST = 0 DO I = 0, NPROCS - 1 IF ( I .NE. MYID .AND. FUTURE_NIV2(I+1) .NE. 0) THEN IDEST = IDEST + 1 KEEP(267)=KEEP(267)+1 CALL MPI_ISEND( BUF_LOAD%CONTENT( IPOSMSG ), & POSITION, MPI_PACKED, I, & UPDATE_LOAD, COMM, & BUF_LOAD%CONTENT( IREQ+(IDEST-1)*OVHSIZE ), & IERR_MPI ) END IF END DO SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) ' Error in MUMPS_BUF_BCAST_ARRAY' WRITE(*,*) ' Size,position=',SIZE,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) & CALL BUF_ADJUST( BUF_LOAD, POSITION ) RETURN END SUBROUTINE MUMPS_BUF_BCAST_ARRAY SUBROUTINE MUMPS_BUF_DIST_IRECV_SIZE & ( MUMPS_LBUFR_BYTES) IMPLICIT NONE INTEGER MUMPS_LBUFR_BYTES SIZE_RBUF_BYTES = MUMPS_LBUFR_BYTES RETURN END SUBROUTINE MUMPS_BUF_DIST_IRECV_SIZE END MODULE MUMPS_BUF_COMMON MUMPS_5.8.1/src/cfac_process_message.F0000664000175000017500000007776115042446440017517 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE CMUMPS_TRAITER_MESSAGE( & COMM_LOAD, ASS_IRECV, & MSGSOU, MSGTAG, MSGLEN, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER KEEP(500), ICNTL( 60 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) COMPLEX A( LA ) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER COMM_LOAD, ASS_IRECV INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) COMPLEX DBLARR( KEEP8(26) ) INTEGER INIV2, ISHIFT, IBEG INTEGER ISHIFT_HDR INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL FLAG INTEGER LP INTEGER TMP( 2 ) INTEGER NBRECU, POSITION, INODE, ISON, IROOT INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE, & LMAP, FPERE, NELIM, & HDMAPLIG,NFS4FATHER, & TOT_ROOT_SIZE, TOT_CONT_TO_RECV DOUBLE PRECISION FLOP1 CHARACTER(LEN=35) :: SUBNAME INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) LP = ICNTL(1) SUBNAME="??????" CALL MUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF ( MSGTAG .EQ. RACINE ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NBRECU, & 1, MPI_INTEGER, COMM, IERR) NBRECU = BUFR( 1 ) NBFIN = NBFIN - NBRECU ELSEIF ( MSGTAG .EQ. NOEUD ) THEN CALL CMUMPS_PROCESS_NODE( MYID, KEEP, KEEP8, DKEEP, & BUFR, LBUFR, LBUFR_BYTES, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) SUBNAME="CMUMPS_PROCESS_NODE" IF ( IFLAG .LT. 0 ) GO TO 500 IF ( FLAG ) THEN CALL CMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( FPERE, N, & PROCNODE_STEPS,KEEP(199), & ND, FILS, FRERE, STEP, PIMASTER, & KEEP(28), KEEP(50), KEEP(253), FLOP1, & IW, LIW, KEEP(IXSZ) ) IF (FPERE.NE.KEEP(20)) & CALL MUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ELSEIF ( MSGTAG .EQ. END_NIV2_LDLT ) THEN INODE = BUFR( 1 ) CALL CMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, -INODE ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ELSEIF ( MSGTAG .EQ. TERREUR ) THEN IFLAG = -001 IERROR = MSGSOU GOTO 100 ELSEIF ( MSGTAG .EQ. MAITRE_DESC_BANDE ) THEN CALL CMUMPS_PROCESS_DESC_BANDE( MYID,BUFR, LBUFR, & LBUFR_BYTES, IWPOS, & IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, #if ! defined (NO_FDM_DESCBAND) & -1, #endif & IFLAG, IERROR ) SUBNAME="CMUMPS_PROCESS_DESC_BANDE" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. MAITRE2 ) THEN CALL CMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, SLAVEF, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & KEEP, KEEP8, DKEEP, ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) SUBNAME="CMUMPS_PROCESS_MASTER2" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. BLOC_FACTO .OR. & MSGTAG .EQ. BLOC_FACTO_RELAY ) THEN CALL CMUMPS_PROCESS_BLOCFACTO( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM , IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM_SLAVE ) THEN CALL CMUMPS_PROCESS_BLFAC_SLAVE( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM ) THEN CALL CMUMPS_PROCESS_SYM_BLOCFACTO( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. CONTRIB_TYPE2 ) THEN CALL CMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, & MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, & N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, PERM, COMP, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, NBFIN, MYID, COMM, & ICNTL,KEEP,KEEP8,DKEEP,IFLAG, IERROR, IPOOL, LPOOL, LEAF, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSEIF ( MSGTAG .EQ. MAPLIG ) THEN HDMAPLIG = 7 INODE = BUFR( 1 ) ISON = BUFR( 2 ) NSLAVES_PERE = BUFR( 3 ) NFRONT_PERE = BUFR( 4 ) NASS_PERE = BUFR( 5 ) LMAP = BUFR( 6 ) NFS4FATHER = BUFR( 7 ) IF ( NSLAVES_PERE.NE.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ISHIFT = NSLAVES_PERE+1 TAB_POS_IN_PERE(1:NSLAVES_PERE+1, INIV2) = & BUFR(HDMAPLIG+1:HDMAPLIG+1+NSLAVES_PERE) TAB_POS_IN_PERE(SLAVEF+2, INIV2) = NSLAVES_PERE ELSE ISHIFT = 0 ENDIF IBEG = HDMAPLIG+1+ISHIFT CALL CMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES_PERE, & BUFR(IBEG), & NFRONT_PERE, NASS_PERE, NFS4FATHER,LMAP, & BUFR(IBEG+NSLAVES_PERE), & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, roota, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_CONT_STATIC ) THEN CALL CMUMPS_PROCESS_CONTRIB_TYPE3( & BUFR, LBUFR, LBUFR_BYTES, & root, roota, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF, OPASSW) SUBNAME="CMUMPS_PROCESS_CONTRIB_TYPE3" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_NON_ELIM_CB ) THEN IROOT = KEEP( 38 ) MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), & KEEP(199) ) IF ( PTLUST( STEP(IROOT)) .EQ. 0 ) THEN KEEP(266)=KEEP(266)-1 CALL MPI_RECV( TMP, 2 * KEEP(34), MPI_PACKED, & MSGSOU, ROOT_2SLAVE, & COMM, STATUS, IERR ) CALL CMUMPS_PROCESS_ROOT2SLAVE( TMP( 1 ), TMP( 2 ), & root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP,ND ) SUBNAME="CMUMPS_PROCESS_ROOT2SLAVE" IF ( IFLAG .LT. 0 ) GOTO 500 END IF CALL CMUMPS_PROCESS_CONTRIB_TYPE3( & BUFR, LBUFR, LBUFR_BYTES, & root, roota, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF, OPASSW ) SUBNAME="CMUMPS_PROCESS_CONTRIB_TYPE3" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_2SON ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) CALL CMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & ISON, NELIM, root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 IF ( MYID.NE.MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) ) THEN IF (KEEP(50).EQ.0) THEN ISHIFT_HDR = 6 ELSE ISHIFT_HDR = 8 ENDIF IF (IW(PTRIST(STEP(ISON))+ISHIFT_HDR+KEEP(IXSZ)).EQ. & S_REC_CONTSTATIC) THEN IW(PTRIST(STEP(ISON))+ISHIFT_HDR+KEEP(IXSZ)) = & S_ROOT2SON_CALLED ELSE CALL CMUMPS_FREE_BAND( N, ISON, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)),KEEP(199)) & ) ENDIF ENDIF ELSE IF ( MSGTAG .EQ. ROOT_2SLAVE ) THEN TOT_ROOT_SIZE = BUFR( 1 ) TOT_CONT_TO_RECV = BUFR( 2 ) CALL CMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, & TOT_CONT_TO_RECV, root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP, ND ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_NELIM_INDICES ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) NSLAVES_PERE = BUFR( 3 ) CALL CMUMPS_PROCESS_RTNELIND( root, roota, & ISON, NELIM, NSLAVES_PERE, BUFR(4), BUFR(4+BUFR(2)), & BUFR(4+2*BUFR(2)), & & PROCNODE_STEPS, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND) SUBNAME="CMUMPS_PROCESS_RTNELIND" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. UPDATE_LOAD ) THEN WRITE(*,*) "Internal error 3 in CMUMPS_TRAITER_MESSAGE" CALL MUMPS_ABORT() ELSE IF ( MSGTAG .EQ. TAG_DUMMY ) THEN ELSE IF ( LP > 0 ) & WRITE(LP,*) MYID, &': Internal error, routine CMUMPS_TRAITER_MESSAGE.',MSGTAG IFLAG = -100 IERROR= MSGTAG GOTO 500 ENDIF 100 CONTINUE RETURN 500 CONTINUE IF ( ICNTL(1) .GT. 0 .AND. ICNTL(4).GE.1 ) THEN LP=ICNTL(1) IF (IFLAG.EQ.-9) THEN WRITE(LP,*) 'FAILURE, WORKSPACE TOO SMALL DURING ',SUBNAME ENDIF IF (IFLAG.EQ.-8) THEN WRITE(LP,*) 'FAILURE IN INTEGER ALLOCATION DURING ',SUBNAME ENDIF IF (IFLAG.EQ.-13) THEN WRITE(LP,*) 'FAILURE IN DYNAMIC ALLOCATION DURING ',SUBNAME ENDIF ENDIF CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE CMUMPS_TRAITER_MESSAGE RECURSIVE SUBROUTINE CMUMPS_RECV_AND_TREAT( & COMM_LOAD, ASS_IRECV, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT , & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, LA, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST( KEEP(28) ) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) COMPLEX DBLARR( KEEP8(26) ) INTEGER MSGSOU, MSGTAG, MSGLEN, IERR MSGSOU = STATUS( MPI_SOURCE ) MSGTAG = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN IFLAG = -20 IERROR = MSGLEN WRITE(*,*) ' RECEPTION BUF TOO SMALL, Msgtag/len=', & MSGTAG,MSGLEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF KEEP(266)=KEEP(266)-1 CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, & COMM, STATUS, IERR ) CALL CMUMPS_TRAITER_MESSAGE( & COMM_LOAD, ASS_IRECV, & MSGSOU, MSGTAG, MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS ) RETURN END SUBROUTINE CMUMPS_RECV_AND_TREAT RECURSIVE SUBROUTINE CMUMPS_TRY_RECVTREAT( & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, & MESSAGE_RECEIVED, MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED, LRGROUPS ) USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL, INTENT (IN) :: BLOCKING LOGICAL, INTENT (IN) :: SET_IRECV LOGICAL, INTENT (INOUT) :: MESSAGE_RECEIVED INTEGER, INTENT (IN) :: MSGSOU, MSGTAG INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST(KEEP(28)) INTEGER STEP(N), & PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) COMPLEX DBLARR( KEEP8(26) ) LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED LOGICAL FLAG, RIGHT_MESS, FLAGbis INTEGER LP, MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC INTEGER IERR INTEGER :: STATUS_BIS(MPI_STATUS_SIZE) INTEGER, SAVE :: RECURS = 0 CALL MUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF ( .NOT. STACK_RIGHT_AUTHORIZED ) THEN RETURN ENDIF RECURS = RECURS + 1 LP = ICNTL(1) IF (ICNTL(4).LT.1) LP=-1 IF ( MESSAGE_RECEIVED ) THEN MSGSOU_LOC = MPI_ANY_SOURCE MSGTAG_LOC = MPI_ANY_TAG GOTO 250 ENDIF IF ( ASS_IRECV .NE. MPI_REQUEST_NULL) THEN RIGHT_MESS = .TRUE. IF (BLOCKING) THEN CALL MPI_WAIT(ASS_IRECV, & STATUS, IERR) FLAG = .TRUE. IF ( ( (MSGSOU.NE.MPI_ANY_SOURCE) .OR. & (MSGTAG.NE.MPI_ANY_TAG) ) ) THEN IF ( MSGSOU.NE.MPI_ANY_SOURCE) THEN RIGHT_MESS = MSGSOU.EQ.STATUS(MPI_SOURCE) ENDIF IF ( MSGTAG.NE.MPI_ANY_TAG) THEN RIGHT_MESS = & ( (MSGTAG.EQ.STATUS(MPI_TAG)).AND.RIGHT_MESS ) ENDIF IF (.NOT.RIGHT_MESS) THEN CALL MPI_PROBE(MSGSOU,MSGTAG, & COMM, STATUS_BIS, IERR) ENDIF ENDIF ELSE CALL MPI_TEST(ASS_IRECV, & FLAG, STATUS, IERR) ENDIF IF (IERR.LT.0) THEN IFLAG = -20 IF (LP.GT.0) & write(LP,*) ' Error return from MPI_TEST ', & IFLAG, ' in CMUMPS_TRY_RECVTREAT' CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF IF ( FLAG ) THEN KEEP(266)=KEEP(266)-1 MESSAGE_RECEIVED = .TRUE. MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN_LOC, IERR ) IF (.NOT.RIGHT_MESS) RECURS = RECURS + 10 CALL CMUMPS_TRAITER_MESSAGE( COMM_LOAD, ASS_IRECV, & MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (.NOT.RIGHT_MESS) RECURS = RECURS - 10 IF ( IFLAG .LT. 0 ) RETURN IF (.NOT.RIGHT_MESS) THEN IF (ASS_IRECV .NE. MPI_REQUEST_NULL) THEN CALL MUMPS_ABORT() ENDIF CALL MPI_IPROBE(MSGSOU,MSGTAG, & COMM, FLAGbis, STATUS, IERR) IF (FLAGbis) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL CMUMPS_RECV_AND_TREAT( COMM_LOAD, ASS_IRECV, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL,LEAF,NBFIN,MYID,SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, & KEEP,KEEP8, DKEEP,ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF ENDIF ENDIF ELSE IF (BLOCKING) THEN CALL MPI_PROBE(MSGSOU,MSGTAG, & COMM, STATUS, IERR) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, FLAG, STATUS, IERR) ENDIF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) MESSAGE_RECEIVED = .TRUE. CALL CMUMPS_RECV_AND_TREAT( COMM_LOAD, ASS_IRECV, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF ENDIF 250 CONTINUE RECURS = RECURS - 1 IF ( NBFIN .EQ. 0 ) RETURN IF ( RECURS .GT. 3 ) RETURN IF ( KEEP(36).EQ.1 .AND. SET_IRECV .AND. & (ASS_IRECV.EQ.MPI_REQUEST_NULL) .AND. & MESSAGE_RECEIVED ) THEN CALL MPI_IRECV ( BUFR(1), & LBUFR_BYTES, MPI_PACKED, MPI_ANY_SOURCE, & MPI_ANY_TAG, COMM, & ASS_IRECV, IERR ) ENDIF RETURN END SUBROUTINE CMUMPS_TRY_RECVTREAT SUBROUTINE CMUMPS_CANCEL_IRECV( INFO1, & KEEP, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & COMM, & MYID, SLAVEF) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_1INT IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER LBUFR, LBUFR_BYTES INTEGER ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER COMM INTEGER MYID, SLAVEF, INFO1, DEST INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL NO_ACTIVE_IRECV INTEGER IERR, DUMMY INTRINSIC mod IF (SLAVEF .EQ. 1) RETURN IF (ASS_IRECV.EQ.MPI_REQUEST_NULL) THEN NO_ACTIVE_IRECV=.TRUE. ELSE CALL MPI_TEST(ASS_IRECV, NO_ACTIVE_IRECV, & STATUS, IERR) IF (NO_ACTIVE_IRECV) THEN KEEP(266) = KEEP(266) - 1 ENDIF ENDIF CALL MPI_BARRIER(COMM,IERR) DUMMY = 1 DEST = mod(MYID+1, SLAVEF) CALL MUMPS_BUF_SEND_1INT & (DUMMY, DEST, TAG_DUMMY, COMM, KEEP, IERR) IF (NO_ACTIVE_IRECV) THEN CALL MPI_RECV( BUFR, LBUFR, & MPI_INTEGER, MPI_ANY_SOURCE, & TAG_DUMMY, COMM, STATUS, IERR ) ELSE CALL MPI_WAIT(ASS_IRECV, & STATUS, IERR) ENDIF KEEP(266)=KEEP(266)-1 RETURN END SUBROUTINE CMUMPS_CANCEL_IRECV MUMPS_5.8.1/src/zfac_process_root2slave.F0000664000175000017500000003277515042446441020217 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, & TOT_CONT_TO_RECV, root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND) USE MUMPS_LOAD USE ZMUMPS_OOC USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER TOT_ROOT_SIZE, TOT_CONT_TO_RECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER ND( KEEP(28) ) INTEGER IFLAG, IERROR, COMM, COMM_LOAD INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER INTARR(KEEP8(27)) COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER :: allocok COMPLEX(kind=8), DIMENSION(:,:), POINTER :: TMP INTEGER NEW_LOCAL_M, NEW_LOCAL_N INTEGER OLD_LOCAL_M, OLD_LOCAL_N INTEGER I, J INTEGER LREQI, IROOT INTEGER(8) :: LREQA INTEGER POSHEAD, IPOS_SON,IERR LOGICAL MASTER_OF_ROOT, NO_OLD_ROOT COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INCLUDE 'mumps_headers.h' INTEGER MUMPS_NUMROC, MUMPS_PROCNODE EXTERNAL MUMPS_NUMROC, MUMPS_PROCNODE IROOT = KEEP( 38 ) root%TOT_ROOT_SIZE = TOT_ROOT_SIZE MASTER_OF_ROOT = ( MYID .EQ. & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), & KEEP(199) ) ) NEW_LOCAL_M = MUMPS_NUMROC( TOT_ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) NEW_LOCAL_M = max( 1, NEW_LOCAL_M ) NEW_LOCAL_N = MUMPS_NUMROC( TOT_ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) IF ( PTRIST(STEP( IROOT )).GT.0) THEN OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) ELSE OLD_LOCAL_N = 0 OLD_LOCAL_M = NEW_LOCAL_M ENDIF IF (PTRIST(STEP(IROOT)) .EQ.0) THEN NO_OLD_ROOT = .TRUE. ELSE NO_OLD_ROOT =.FALSE. ENDIF IF (KEEP(60) .NE. 0) THEN IF ( MASTER_OF_ROOT ) THEN LREQI=6+2*TOT_ROOT_SIZE+KEEP(IXSZ) LREQA=0_8 IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN CALL ZMUMPS_COMPRE_NEW( N, KEEP, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ),COMP,DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA-LRLUS, IERROR) GOTO 700 END IF ENDIF IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB GOTO 700 ENDIF PTLUST(STEP(IROOT))= IWPOS IWPOS = IWPOS + LREQI POSHEAD = PTLUST( STEP(IROOT)) IW( POSHEAD + XXI )=LREQI CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR) ) CALL MUMPS_STOREI8( 0_8, IW(POSHEAD + XXD) ) IW( POSHEAD + XXS )=-9999 IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 IW( POSHEAD +KEEP(IXSZ)) = 0 IW( POSHEAD + 1 +KEEP(IXSZ)) = -1 IW( POSHEAD + 2 +KEEP(IXSZ)) = -1 IW( POSHEAD + 4 +KEEP(IXSZ)) = STEP(IROOT) IW( POSHEAD + 5 +KEEP(IXSZ)) = 0 IW( POSHEAD + 3 +KEEP(IXSZ)) = TOT_ROOT_SIZE ELSE PTLUST(STEP(IROOT)) = -4444 ENDIF PTRIST(STEP(IROOT)) = 0 PTRFAC(STEP(IROOT)) = -4445_8 IF (root%yes .and. NO_OLD_ROOT) THEN IF (NEW_LOCAL_N .GT. 0) THEN CALL ZMUMPS_SET_TO_ZERO(roota%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC, & KEEP) IF (KEEP(55).EQ.0) THEN CALL ZMUMPS_ASM_ARR_ROOT( N, root, roota, & IROOT, STEP(IROOT), & roota%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC, & root%SCHUR_NLOC, FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL ZMUMPS_ASM_ELT_ROOT(N, root, roota, & roota%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC, & root%SCHUR_NLOC, LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF ENDIF ENDIF ELSE IF ( MASTER_OF_ROOT ) THEN LREQI = 6 + 2 * TOT_ROOT_SIZE+KEEP(IXSZ) ELSE LREQI = 6+KEEP(IXSZ) END IF LREQA = int(NEW_LOCAL_M, 8) * int(NEW_LOCAL_N, 8) CALL ZMUMPS_GET_SIZE_NEEDED( & LREQI , LREQA, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 700 PTLUST(STEP( IROOT )) = IWPOS IWPOS = IWPOS + LREQI IF (LREQA.EQ.0_8) THEN PTRAST (STEP(IROOT)) = POSFAC PTRFAC (STEP(IROOT)) = POSFAC ELSE PTRAST (STEP(IROOT)) = POSFAC PTRFAC (STEP(IROOT)) = POSFAC ENDIF POSFAC = POSFAC + LREQA LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA KEEP8(67) = min(KEEP8(67), LRLUS) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) POSHEAD = PTLUST( STEP(IROOT)) IW( POSHEAD + XXI ) = LREQI CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR)) CALL MUMPS_STOREI8( 0_8, IW(POSHEAD + XXD)) IW( POSHEAD + XXS ) = S_NOTFREE IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 IW( POSHEAD + KEEP(IXSZ) ) = 0 IW( POSHEAD + 1 + KEEP(IXSZ) ) = NEW_LOCAL_N IW( POSHEAD + 2 + KEEP(IXSZ) ) = NEW_LOCAL_M IW( POSHEAD + 4 + KEEP(IXSZ) ) = STEP(IROOT) IW( POSHEAD + 5 + KEEP(IXSZ) ) = 0 IF ( MASTER_OF_ROOT ) THEN IW( POSHEAD + 3 + KEEP(IXSZ) ) = TOT_ROOT_SIZE ELSE IW( POSHEAD + 3 + KEEP(IXSZ) ) = 0 ENDIF IF ( PTRIST(STEP(IROOT)) .EQ. 0) THEN CALL ZMUMPS_SET_TO_ZERO(A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, KEEP) IF (KEEP(55) .EQ.0 ) THEN CALL ZMUMPS_ASM_ARR_ROOT( N, root, roota, & IROOT, STEP(IROOT), & A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, & FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL ZMUMPS_ASM_ELT_ROOT( N, root, roota, & A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF PAMASTER(STEP(IROOT)) = 0_8 ELSE IF ( PTRIST(STEP(IROOT)) .LT. 0 ) THEN CALL ZMUMPS_SET_TO_ZERO(A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, KEEP) ELSE OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) IF ( TOT_ROOT_SIZE .eq. root%ROOT_SIZE ) THEN IF ( LREQA .NE. int(OLD_LOCAL_M,8) * int(OLD_LOCAL_N,8) ) & THEN write(*,*) 'error 1 in PROCESS_ROOT2SLAVE', & OLD_LOCAL_M, OLD_LOCAL_N CALL MUMPS_ABORT() END IF CALL ZMUMPS_COPYI8SIZE(LREQA, & A( PAMASTER(STEP(IROOT)) ), & A( PTRAST (STEP(IROOT)) ) ) ELSE CALL ZMUMPS_COPY_ROOT( A( PTRAST(STEP(IROOT))), & NEW_LOCAL_M, & NEW_LOCAL_N, A( PAMASTER( STEP(IROOT)) ), OLD_LOCAL_M, & OLD_LOCAL_N ) END IF IF ( PTRIST( STEP( IROOT ) ) .GT. 0 ) THEN IPOS_SON= PTRIST( STEP(IROOT)) CALL ZMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., & MYID, N, IPOS_SON, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) END IF ENDIF PTRIST(STEP( IROOT )) = 0 PAMASTER(STEP( IROOT )) = 0_8 ENDIF IF ( NO_OLD_ROOT ) THEN IF (KEEP(253) .GT.0) THEN root%RHS_NLOC = MUMPS_NUMROC( KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) root%RHS_NLOC = max( root%RHS_NLOC, 1 ) ELSE root%RHS_NLOC = 1 ENDIF IF (associated(roota%RHS_ROOT)) DEALLOCATE(roota%RHS_ROOT) ALLOCATE(roota%RHS_ROOT(NEW_LOCAL_M, root%RHS_NLOC), & stat=allocok) IF ( allocok.GT.0 ) THEN IFLAG = -13 IERROR = NEW_LOCAL_N * root%RHS_NLOC GOTO 700 ENDIF IF (KEEP(253) .NE. 0) THEN roota%RHS_ROOT=ZERO CALL ZMUMPS_ASM_RHS_ROOT( N, FILS, root, roota, KEEP, KEEP8, & RHS_MUMPS, IFLAG, IERROR ) ENDIF ELSE IF (NEW_LOCAL_M.GT.OLD_LOCAL_M .AND. KEEP(253) .GT.0) THEN TMP => roota%RHS_ROOT NULLIFY(roota%RHS_ROOT) ALLOCATE (roota%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 roota%RHS_ROOT(I,J)=TMP(I,J) ENDDO DO I = OLD_LOCAL_M+1, NEW_LOCAL_M roota%RHS_ROOT(I,J) = ZERO ENDDO ENDDO DEALLOCATE(TMP) NULLIFY(TMP) ENDIF KEEP(121) = KEEP(121) + TOT_CONT_TO_RECV IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL ZMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL ZMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL ZMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT + N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN 700 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE ZMUMPS_PROCESS_ROOT2SLAVE SUBROUTINE ZMUMPS_COPY_ROOT &( NEW, M_NEW, N_NEW,OLD, M_OLD, N_OLD ) INTEGER M_NEW, N_NEW, M_OLD, N_OLD COMPLEX(kind=8) NEW( M_NEW, N_NEW ), OLD( M_OLD, N_OLD ) INTEGER J COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) DO J = 1, N_OLD NEW( 1: M_OLD, J ) = OLD( 1: M_OLD, J ) NEW( M_OLD + 1: M_NEW, J ) = ZERO END DO NEW( 1: M_NEW,N_OLD + 1: N_NEW ) = ZERO RETURN END SUBROUTINE ZMUMPS_COPY_ROOT MUMPS_5.8.1/src/tools_common_m.F0000664000175000017500000000630115042446423016364 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_TOOLS_COMMON_M C C This module with arithmetic-independant utility routines C such as integer sorting algorithms C PRIVATE PUBLIC :: MUMPS_MERGESORT, MUMPS_MERGESWAP, MUMPS_MERGESWAP1 CONTAINS SUBROUTINE MUMPS_MERGESORT(N, K, L) IMPLICIT NONE C Plain implementation of the merge-sort algorithm C as described in: C C D. E. Knuth "The Art of Computer Programming," C vol.3: Sorting and Searching, Addison-Wesley, 1973 INTEGER :: N INTEGER :: K(:), L(0:) INTEGER :: P, Q, S, T 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 L(S) = sign(P,L(S)) S = P P = L(P) IF (P .GT. 0) GOTO 300 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 L(S) = P S = T DO T = P P = L(P) IF (P .LE. 0) EXIT END DO 800 CONTINUE P = -P Q = -Q IF(Q.EQ.0) THEN L(S) = sign(P, L(S)) L(T) = 0 GOTO 200 END IF GOTO 300 END SUBROUTINE MUMPS_MERGESORT SUBROUTINE MUMPS_MERGESWAP1(N, L, A) IMPLICIT NONE INTEGER :: I, LP, ISWAP, N INTEGER :: L(0:), A(:) LP = L(0) I = 1 DO IF ((LP==0).OR.(I>N)) EXIT DO IF (LP >= I) EXIT LP = L(LP) END DO ISWAP = A(LP) A(LP) = A(I) A(I) = ISWAP ISWAP = L(LP) L(LP) = L(I) L(I) = LP LP = ISWAP I = I + 1 ENDDO END SUBROUTINE MUMPS_MERGESWAP1 SUBROUTINE MUMPS_MERGESWAP(N, L, A1, A2) IMPLICIT NONE 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 MUMPS_MERGESWAP END MODULE MUMPS_TOOLS_COMMON_M MUMPS_5.8.1/src/sana_reordertree.F0000664000175000017500000012227715042446436016703 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_REORDER_TREE(N,FRERE, STEP, FILS, & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, & NSTEPS,PERM,SYM,INFO,LP,K215,K234,K55,K199, & PROCNODE,SLAVEF, PEAK,SBTR_WHICH_M & ) IMPLICIT NONE INTEGER N,PERM,SYM, NSTEPS, LNA, LP,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER K215,K234,K55,K199 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) INTEGER :: SBTR_WHICH_M REAL PEAK REAL, DIMENSION(:), ALLOCATABLE :: COST_TRAV INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH INTEGER IFATH,IN,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 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 EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR DOUBLE PRECISION COST_NODE INCLUDE 'mumps_headers.h' TOTAL_MEM_SIZE=0_8 ROOT_OF_CUR_SBTR=0 IF((PERM.EQ.0).OR.(PERM.EQ.1).OR. & (PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4).OR. & (PERM.EQ.5).OR.(PERM.EQ.6))THEN LOCAL_PERM=0 ENDIF SBTR_M=.FALSE. MEM_SIZE=0_8 FACT_SIZE=0_8 IF ((PERM.LT.0 .OR. PERM.GT.7)) THEN WRITE(*,*) "Internal Error in SMUMPS_REORDER_TREE",PERM CALL MUMPS_ABORT() END IF NBLEAF = NA(1) NBROOT = NA(2) IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) RETURN IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ENDIF IF(PERM.NE.7)THEN ALLOCATE(M(NSTEPS),stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error &in SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ALLOCATE( IPOOL(NBLEAF), fact(NSTEPS),TNSTK(NSTEPS), & stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF II=0 DO I=1,NSTEPS TNSTK(I) = NE(I) IF(NE(I).GE.II) II=NE(I) ENDDO SIZE_TAB=max(II,NBROOT) ALLOCATE(SON(II), TEMP(II), & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), & RESULT(SIZE_TAB),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SIZE_TAB RETURN ENDIF IF(PERM.EQ.7) THEN GOTO 001 ENDIF IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN ALLOCATE(COST_TRAV(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error & in SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF COST_TRAV=0.0E0 COST_NODE=0.0d0 ENDIF IF(NBROOT.EQ.NBLEAF)THEN IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN WRITE(*,*)'Internal Error in reordertree:' WRITE(*,*)' problem with perm parameter in reordertree' CALL MUMPS_ABORT() ENDIF DO I=1,NBROOT TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) IPOOL(I)=NA(I+2+NBLEAF) M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) ENDDO CALL SMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) GOTO 789 ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN ALLOCATE(DEPTH(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DEPTH=0 NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) 499 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 4602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 4602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) SON(I)=IN IN=FRERE(STEP(IN)) ENDDO DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN LEAF=LEAF-1 ELSE fin=fin-1 GOTO 499 ENDIF fin=fin-1 IF(fin.EQ.0) GOTO 489 GOTO 499 489 CONTINUE ENDIF DO I=1,NSTEPS M(I)=0_8 IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN M_TOTAL(I)=0_8 ENDIF ENDIF ENDDO DO I=1,NSTEPS fact(I)=0_8 ENDDO IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 91 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 96 CONTINUE NFR = int(ND(STEP(INODE)),8) NELIM4 = 0 IN = INODE 101 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 101 NELIM=int(NELIM4,8) IF(NE(STEP(INODE)).EQ.0) THEN M(STEP(INODE))=NFR*NFR IF (SBTR_M.OR.(PERM.EQ.2)) THEN M_TOTAL(STEP(INODE))=NFR*NFR ENDIF ENDIF IF((PERM.EQ.4).OR.(PERM.EQ.3))THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN DEPTH(STEP(INODE))=0 ENDIF ENDIF IF ( SYM .eq. 0 ) THEN fact(STEP(INODE))=fact(STEP(INODE))+ & (2_8*NFR*NELIM)-(NELIM*NELIM) ELSE fact(STEP(INODE))=fact(STEP(INODE))+NFR*NELIM ENDIF IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 113 IN = FRERE(IN) IF (IN.GT.0) GO TO 113 IFATH = -IN ENDIF IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 116 GOTO 91 ELSE fact(STEP(IFATH))=fact(STEP(IFATH))+fact(STEP(INODE)) IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEPTH(STEP(IFATH))=max(DEPTH(STEP(INODE)), & DEPTH(STEP(IFATH))) ENDIF ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH IN=INODE dernier=IN I=1 5700 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN I=I+1 GOTO 5700 ENDIF NCB=int(ND(STEP(INODE))-I,8) IN=-IN IF(PERM.NE.7)THEN DO I=1,NE(STEP(INODE)) SON(I)=IN TEMP(I)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) ENDDO ELSE DO I=NE(STEP(INODE)),1,-1 SON(I)=IN TEMP(I)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) ENDDO ENDIF NFR = int(ND(STEP(INODE)),8) DO II=1,NE(STEP(INODE)) TAB1(II)=0_8 TAB2(II)=0_8 cour=SON(II) NELIM4=1 151 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 151 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0)) THEN SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) & *(int(ND(STEP(SON(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) & *(int(ND(STEP(SON(II))),8)- & NELIM+1_8)/2_8 ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.5))THEN IF (K234 .NE. 0 .AND. K55.EQ.0 ) THEN TMP8=NFR TMP8=TMP8*TMP8 TAB1(II)=max(TMP8, M(STEP(SON(II)))) - SIZECB TAB2(II)=SIZECB ELSE TAB1(II)=M(STEP(SON(II)))- SIZECB TAB2(II)=SIZECB ENDIF ENDIF IF((PERM.EQ.1).OR.(PERM.EQ.6)) THEN TAB1(II)=M(STEP(SON(II)))-SIZECB TAB1(II)=TAB1(II)-fact(STEP(SON(II))) TAB2(II)=SIZECB+fact(STEP(SON(II))) ENDIF IF(PERM.EQ.2)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M_TOTAL(STEP(SON(II)))-SIZECB & -fact(STEP(SON(II))) TAB2(II)=SIZECB ELSE TAB1(II)=M(STEP(SON(II)))-SIZECB TAB2(II)=SIZECB ENDIF ENDIF IF(PERM.EQ.3)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M(STEP(SON(II)))-SIZECB TAB2(II)=SIZECB ELSE TAB1(II)=int(DEPTH(STEP(SON(II))),8) TAB2(II)=M(STEP(SON(II))) ENDIF ENDIF IF(PERM.EQ.4)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M(STEP(SON(II)))- & SIZECB-fact(STEP(SON(II))) TAB2(II)=SIZECB ELSE TAB1(II)=int(DEPTH(STEP(SON(II))),8) TAB2(II)=M(STEP(SON(II))) ENDIF ENDIF ENDDO CALL SMUMPS_FUSION_SORT(SON,NE(STEP(INODE)),TAB1,TAB2, & LOCAL_PERM & ,RESULT,T1,T2) IF(PERM.EQ.0) THEN DO II=1,NE(STEP(INODE)) cour=TEMP(II) NELIM4=1 153 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 153 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 ENDIF TAB1(II)=SIZECB ENDDO CALL SMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, & RESULT,T1,T2) ENDIF IF(PERM.EQ.1) THEN DO II=1,NE(STEP(INODE)) cour=TEMP(II) NELIM4=1 187 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 187 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 ENDIF TAB1(II)=SIZECB+fact(STEP(TEMP(II))) ENDDO CALL SMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, & RESULT,T1,T2) ENDIF 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 TMP_SUM=0_8 IF(II.EQ.1) TAB=>SON IF(II.EQ.2) TAB=>TEMP DO I=1,NE(STEP(INODE)) cour=TAB(I) NELIM4=1 149 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 149 ENDIF NELIM=int(NELIM4, 8) NFR=int(ND(STEP(TAB(I))),8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF MEM_SIZE=max(MEM_SIZE,(M(STEP(TAB(I)))+SUM+FACT_SIZE)) IF (SBTR_M.OR.(PERM.EQ.2)) THEN MEM_SIZE_T=max(MEM_SIZE_T,(M_TOTAL(STEP(TAB(I)))+ & SUM+ & FACT_SIZE_T)) FACT_SIZE_T=FACT_SIZE_T+fact(STEP(TAB(I))) ENDIF TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & (M(STEP(TAB(I)))+SUM+FACT_SIZE)) TMP_SUM=TMP_SUM+fact(STEP(TAB(I))) SUM=SUM+SIZECB SIZECB_LASTSON = SIZECB IF((PERM.EQ.1).OR.(PERM.EQ.4))THEN FACT_SIZE=FACT_SIZE+fact(STEP(TAB(I))) ENDIF ENDDO IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=NCB*NCB ELSE SIZECB=(NCB*(NCB+1_8))/2_8 ENDIF IF (K234.NE.0 .AND. K55.EQ.0) THEN TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8) ) & + SUM-SIZECB_LASTSON+TMP_SUM ) & ) ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8) ) & + SUM + TMP_SUM ) & ) ELSE TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8)) & + max(SUM,SIZECB) + TMP_SUM ) & ) ENDIF IF(II.EQ.1)THEN TMP_TOTAL_MEM_SIZE=TOTAL_MEM_SIZE ENDIF IF(II.EQ.1)THEN IF (K234.NE.0 .AND. K55.EQ.0) THEN M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+SUM-SIZECB_LASTSON+ & FACT_SIZE)) ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+SUM+FACT_SIZE)) ELSE M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN M_TOTAL(STEP(IFATH))=max(MEM_SIZE_T, & ((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+ & FACT_SIZE_T)) ENDIF ENDIF IF((II.EQ.2).AND.(PERM.EQ.1).OR.(PERM.EQ.0).OR. & (PERM.EQ.5).OR.(PERM.EQ.6).OR. & (.NOT.SBTR_M.OR.(SBTR_WHICH_M.NE.1)))THEN MEM_SEC_PERM=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) ENDIF IF((PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4))THEN MEM_SEC_PERM=huge(MEM_SEC_PERM) ENDIF ENDDO IF(MEM_SEC_PERM.EQ.M(STEP(IFATH))) THEN TAB=>TEMP ELSE IF (MEM_SEC_PERM.LT.M(STEP(IFATH))) THEN WRITE(*,*)'Internal error 1 in SMUMPS_REORDER_TREE', & MEM_SEC_PERM, M(STEP(IFATH)) CALL MUMPS_ABORT() ELSE TOTAL_MEM_SIZE=TMP_TOTAL_MEM_SIZE TAB=>SON ENDIF DO I=NE(STEP(INODE)),1,-1 IF(I.EQ.NE(STEP(INODE))) THEN FILS(dernier)=-TAB(I) dernier=TAB(I) GOTO 222 ENDIF IF(I.EQ.1) THEN FRERE(STEP(dernier))=TAB(I) FRERE(STEP(TAB(I)))=-INODE GOTO 222 ENDIF IF(I.GT.1) THEN FRERE(STEP(dernier))=TAB(I) dernier=TAB(I) GOTO 222 ENDIF 222 CONTINUE ENDDO GOTO 96 ELSE GOTO 91 ENDIF 116 CONTINUE NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) IF (PERM.eq.1) THEN DO I=1,NBROOT TAB1(I)=M(STEP(NA(I+2+NBLEAF)))-fact(STEP(NA(I+2+NBLEAF))) TAB1(I)=-TAB1(I) ENDDO CALL SMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) ENDIF 001 CONTINUE fin=NBROOT LEAF=NA(1) 999 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 5602 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN GOTO 5602 ENDIF IN=-IN IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF(SLAVEF.NE.1)THEN IF (USE_DAD) THEN IFATH=DAD(INODE) ELSE IN = INODE 395 IN = FRERE(IN) IF (IN.GT.0) GO TO 395 IFATH = -IN ENDIF NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 IN = INODE 396 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 396 NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),K199))THEN COST_TRAV(STEP(INODE))=COST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE COST_TRAV(STEP(INODE))=real(COST_NODE)+ & COST_TRAV(STEP(IFATH))+ & real(SIZECB*18_8) ENDIF ELSE COST_TRAV(STEP(INODE))=real(COST_NODE) ENDIF ENDIF ENDIF DO I=1,NE(STEP(INODE)) TEMP(I)=IN IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)),K199)))THEN NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 II = TEMP(I) 845 NELIM4 = NELIM4 + 1 II = FILS(II) IF (II .GT. 0 ) GOTO 845 NELIM=int(NELIM4,8) CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) TAB1(I)=int(real(COST_NODE)+ & COST_TRAV(STEP(INODE)),8) TAB2(I)=0_8 ELSE SON(I)=IN ENDIF ELSE SON(I)=IN ENDIF IN=FRERE(STEP(IN)) ENDDO IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)),K199)))THEN CALL SMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2, & LOCAL_PERM & ,RESULT,T1,T2) TAB=>TEMP DO I=NE(STEP(INODE)),1,-1 IF(I.EQ.NE(STEP(INODE))) THEN FILS(dernier)=-TAB(I) dernier=TAB(I) GOTO 221 ENDIF IF(I.EQ.1) THEN FRERE(STEP(dernier))=TAB(I) FRERE(STEP(TAB(I)))=-INODE GOTO 221 ENDIF IF(I.GT.1) THEN FRERE(STEP(dernier))=TAB(I) dernier=TAB(I) GOTO 221 ENDIF 221 CONTINUE SON(NE(STEP(INODE))-I+1)=TAB(I) ENDDO ENDIF ENDIF DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN IF(PERM.NE.7)THEN NA(LEAF+2)=INODE ENDIF LEAF=LEAF-1 ELSE fin=fin-1 GOTO 999 ENDIF fin=fin-1 IF(fin.EQ.0) THEN GOTO 789 ENDIF GOTO 999 789 CONTINUE IF(PERM.EQ.7) GOTO 5483 NBROOT=NA(2) NBLEAF=NA(1) PEAK=0.0E0 FACT_SIZE=0_8 DO I=1,NBROOT PEAK=max(PEAK,real(M(STEP(NA(2+NBLEAF+I))))) FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) ENDDO 5483 CONTINUE DEALLOCATE(IPOOL) DEALLOCATE(fact) DEALLOCATE(TNSTK) DEALLOCATE(SON) DEALLOCATE(TAB2) DEALLOCATE(TAB1) DEALLOCATE(T1) DEALLOCATE(T2) DEALLOCATE(RESULT) DEALLOCATE(TEMP) IF(PERM.NE.7)THEN DEALLOCATE(M) ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEALLOCATE(DEPTH) ENDIF IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN DEALLOCATE(COST_TRAV) ENDIF IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN DEALLOCATE(M_TOTAL) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_REORDER_TREE SUBROUTINE SMUMPS_BUILD_LOAD_MEM_INFO(N,FRERE, STEP, FILS, & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, & NSTEPS,PERM,SYM,INFO,LP,K47,K81,K76,K215,K234,K55,KEEP199, & PROCNODE,MEM_SUBTREE,SLAVEF, SIZE_MEM_SBTR, PEAK & ,SBTR_WHICH_M,SIZE_DEPTH_FIRST,SIZE_COST_TRAV, & DEPTH_FIRST_TRAV,DEPTH_FIRST_SEQ,COST_TRAV,MY_FIRST_LEAF, & MY_NB_LEAF,MY_ROOT_SBTR,SBTR_ID & ) IMPLICIT NONE INTEGER N,PERM,SYM, NSTEPS, LNA, LP, SIZE_MEM_SBTR,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER K47,K81,K76,K215,K234,K55,KEEP199 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) DOUBLE PRECISION, intent(out) :: MEM_SUBTREE(SIZE_MEM_SBTR,SLAVEF) INTEGER :: SBTR_WHICH_M INTEGER MY_FIRST_LEAF(SIZE_MEM_SBTR,SLAVEF), & MY_ROOT_SBTR(SIZE_MEM_SBTR,SLAVEF), & MY_NB_LEAF(SIZE_MEM_SBTR,SLAVEF) EXTERNAL MUMPS_ROOTSSARBR,MUMPS_PROCNODE LOGICAL MUMPS_ROOTSSARBR INTEGER MUMPS_PROCNODE REAL PEAK INTEGER SIZE_DEPTH_FIRST,DEPTH_FIRST_TRAV(SIZE_DEPTH_FIRST), & DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST) INTEGER SIZE_COST_TRAV INTEGER SBTR_ID(SIZE_DEPTH_FIRST),OOC_CUR_SBTR REAL COST_TRAV(SIZE_COST_TRAV) INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH INTEGER IFATH,IN,INODE,I,allocok 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,fin,RANK_TRAV INTEGER II INTEGER ROOT_OF_CUR_SBTR INTEGER(8), DIMENSION (:), ALLOCATABLE :: T1,T2 INTEGER, DIMENSION (:), ALLOCATABLE :: RESULT INTEGER(8) FACT_SIZE, & SIZECB LOGICAL SBTR_M INTEGER,DIMENSION(:),ALLOCATABLE :: INDICE INTEGER ID,FIRST_LEAF,SIZE_SBTR EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR DOUBLE PRECISION COST_NODE INTEGER CUR_DEPTH_FIRST_RANK INCLUDE 'mumps_headers.h' ROOT_OF_CUR_SBTR=0 ALLOCATE(INDICE( SLAVEF ), stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in &SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SLAVEF RETURN ENDIF IF (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)))) FACT_SIZE=0_8 IF ((PERM.GT.7).AND. & (.NOT.(K47 == 4 .OR. ((K47.GE.2).AND.(K81 .GE. 1))))) THEN WRITE(*,*) "Internal Error in SMUMPS_REORDER_TREE",PERM CALL MUMPS_ABORT() END IF NBLEAF = NA(1) NBROOT = NA(2) CUR_DEPTH_FIRST_RANK=1 IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) THEN DEALLOCATE(INDICE) RETURN ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ENDIF ALLOCATE( IPOOL(NBLEAF), M(NSTEPS), fact(NSTEPS), & TNSTK(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF II=0 DO I=1,NSTEPS TNSTK(I) = NE(I) IF(NE(I).GE.II) II=NE(I) ENDDO SIZE_TAB=max(II,NBROOT) ALLOCATE(SON(II), TEMP(II), & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), & RESULT(SIZE_TAB),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SIZE_TAB RETURN ENDIF IF(NBROOT.EQ.NBLEAF)THEN IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN WRITE(*,*)'Internal Error in reordertree:' WRITE(*,*)' problem with perm parameter in reordertree' CALL MUMPS_ABORT() ENDIF DO I=1,NBROOT TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) IPOOL(I)=NA(I+2+NBLEAF) M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) ENDDO CALL SMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) GOTO 789 ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN ALLOCATE(DEPTH(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DEPTH=0 NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) 499 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 4602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 4602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) SON(I)=IN IN=FRERE(STEP(IN)) ENDDO DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN LEAF=LEAF-1 ELSE fin=fin-1 GOTO 499 ENDIF fin=fin-1 IF(fin.EQ.0) GOTO 489 GOTO 499 489 CONTINUE ENDIF IF(K76.EQ.4.OR.(K76.EQ.6))THEN RANK_TRAV=NSTEPS DEPTH_FIRST_TRAV=0 DEPTH_FIRST_SEQ=0 ENDIF IF((K76.EQ.5).OR.(PERM.EQ.5).OR.(PERM.EQ.6))THEN COST_TRAV=0.0E0 COST_NODE=0.0d0 ENDIF DO I=1,NSTEPS M(I)=0_8 IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN M_TOTAL(I)=0_8 ENDIF ENDIF ENDDO DO I=1,NSTEPS fact(I)=0_8 ENDDO NBROOT = NA(2) NBLEAF = NA(1) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) FIRST_LEAF=-9999 SIZE_SBTR=0 999 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IF(SIZE_SBTR.NE.0)THEN IF(.NOT.MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1))THEN MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR FIRST_LEAF=-9999 SIZE_SBTR=0 ENDIF ENDIF ENDIF ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN ROOT_OF_CUR_SBTR=INODE ENDIF IF (K76.EQ.4)THEN IF(SLAVEF.NE.1)THEN WRITE(*,*)'INODE=',INODE,'RANK',RANK_TRAV IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN DEPTH_FIRST_TRAV(STEP(INODE))=DEPTH_FIRST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE DEPTH_FIRST_TRAV(STEP(INODE))=RANK_TRAV ENDIF RANK_TRAV=RANK_TRAV-1 ENDIF ENDIF IF (K76.EQ.5)THEN IF(SLAVEF.NE.1)THEN IF (USE_DAD) THEN IFATH=DAD(INODE) ELSE IN = INODE 395 IN = FRERE(IN) IF (IN.GT.0) GO TO 395 IFATH = -IN ENDIF NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 IN = INODE 396 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 396 NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN COST_TRAV(STEP(INODE))=COST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE COST_TRAV(STEP(INODE))=real(COST_NODE)+ & COST_TRAV(STEP(IFATH))+ & real(SIZECB*18_8) ENDIF ELSE COST_TRAV(STEP(INODE))=real(COST_NODE) ENDIF IF(K76.EQ.5)THEN WRITE(*,*)'INODE=',INODE,'COST=',COST_TRAV(STEP(INODE)) ENDIF ENDIF ENDIF IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1).AND. & MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF (NE(STEP(INODE)).NE.0) THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M_TOTAL(STEP(INODE))) ELSE MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M(STEP(INODE))) ENDIF MY_ROOT_SBTR(INDICE(ID+1),ID+1)=INODE INDICE(ID+1)=INDICE(ID+1)+1 ENDIF ENDIF IF((SLAVEF.EQ.1).AND.FRERE(STEP(INODE)).EQ.0)THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M_TOTAL(STEP(INODE))) ELSE MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M(STEP(INODE))) ENDIF INDICE(ID+1)=INDICE(ID+1)+1 ENDIF ENDIF IN=INODE 5602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 5602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) IPOOL(fin)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF(SLAVEF.NE.1)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF(FIRST_LEAF.EQ.-9999)THEN FIRST_LEAF=INODE ENDIF SIZE_SBTR=SIZE_SBTR+1 ENDIF ENDIF ENDIF IF(PERM.NE.7)THEN NA(LEAF+2)=INODE ENDIF LEAF=LEAF-1 ELSE fin=fin-1 GOTO 999 ENDIF fin=fin-1 IF(fin.EQ.0) THEN IF(SIZE_SBTR.NE.0)THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1))THEN MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR FIRST_LEAF=-9999 SIZE_SBTR=0 ENDIF ENDIF ENDIF GOTO 789 ENDIF GOTO 999 789 CONTINUE IF(K76.EQ.6)THEN OOC_CUR_SBTR=1 DO I=1,NSTEPS TNSTK(I) = NE(I) ENDDO NBROOT=NA(2) NBLEAF=NA(1) IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 9100 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 9600 CONTINUE IF(SLAVEF.NE.1)THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) DEPTH_FIRST_TRAV(STEP(INODE))=CUR_DEPTH_FIRST_RANK DEPTH_FIRST_SEQ(CUR_DEPTH_FIRST_RANK)=INODE CUR_DEPTH_FIRST_RANK=CUR_DEPTH_FIRST_RANK+1 IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP199))THEN SBTR_ID(STEP(INODE))=OOC_CUR_SBTR ELSE SBTR_ID(STEP(INODE))=-9999 ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)), & KEEP199))THEN OOC_CUR_SBTR=OOC_CUR_SBTR+1 ENDIF ENDIF IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 1133 IN = FRERE(IN) IF (IN.GT.0) GO TO 1133 IFATH = -IN ENDIF IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 1163 GOTO 9100 ENDIF TNSTK(STEP(IFATH))=TNSTK(STEP(IFATH))-1 IF(TNSTK(STEP(IFATH)).EQ.0) THEN INODE=IFATH GOTO 9600 ELSE GOTO 9100 ENDIF 1163 CONTINUE ENDIF PEAK=0.0E0 FACT_SIZE=0_8 DO I=1,NBROOT PEAK=max(PEAK,real(M(STEP(NA(2+NBLEAF+I))))) FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) ENDDO DEALLOCATE(IPOOL) DEALLOCATE(M) DEALLOCATE(fact) DEALLOCATE(TNSTK) DEALLOCATE(SON) DEALLOCATE(TAB2) DEALLOCATE(TAB1) DEALLOCATE(T1) DEALLOCATE(T2) DEALLOCATE(RESULT) DEALLOCATE(TEMP) DEALLOCATE(INDICE) IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEALLOCATE(DEPTH) ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN DEALLOCATE(M_TOTAL) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_BUILD_LOAD_MEM_INFO RECURSIVE SUBROUTINE SMUMPS_FUSION_SORT(TAB,DIM,TAB1,TAB2,PERM, & RESULT,TEMP1,TEMP2) IMPLICIT NONE INTEGER DIM INTEGER(8) TAB1(DIM),TAB2(DIM) INTEGER(8) TEMP1(DIM),TEMP2(DIM) INTEGER TAB(DIM), PERM,RESULT(DIM) INTEGER I,J,I1,I2 IF(DIM.EQ.1) THEN RESULT(1)=TAB(1) TEMP1(1)=TAB1(1) TEMP2(1)=TAB2(1) RETURN ENDIF I=DIM/2 CALL SMUMPS_FUSION_SORT(TAB(1),I,TAB1(1),TAB2(1),PERM, & RESULT(1),TEMP1(1),TEMP2(1)) CALL SMUMPS_FUSION_SORT(TAB(I+1),DIM-I,TAB1(I+1),TAB2(I+1), & PERM,RESULT(I+1),TEMP1(I+1),TEMP2(I+1)) I1=1 I2=I+1 J=1 DO WHILE ((I1.LE.I).AND.(I2.LE.DIM)) IF((PERM.EQ.3))THEN IF(TEMP1(I1).LE.TEMP1(I2))THEN TAB(J)=RESULT(I1) TAB1(J)=TEMP1(I1) J=J+1 I1=I1+1 ELSE TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) J=J+1 I2=I2+1 ENDIF GOTO 3 ENDIF IF((PERM.EQ.4).OR.(PERM.EQ.5))THEN IF (TEMP1(I1).GE.TEMP1(I2))THEN TAB(J)=RESULT(I1) TAB1(J)=TEMP1(I1) J=J+1 I1=I1+1 ELSE TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) J=J+1 I2=I2+1 ENDIF GOTO 3 ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.1).OR.(PERM.EQ.2)) THEN IF(TEMP1(I1).GT.TEMP1(I2))THEN TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 GOTO 3 ENDIF IF(TEMP1(I1).LT.TEMP1(I2))THEN TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) TAB(J)=RESULT(I2) J=J+1 I2=I2+1 GOTO 3 ENDIF IF((TEMP1(I1).EQ.TEMP1(I2)))THEN IF(TEMP2(I1).LE.TEMP2(I2))THEN TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 ELSE TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) TAB(J)=RESULT(I2) J=J+1 I2=I2+1 ENDIF ENDIF ENDIF 3 CONTINUE ENDDO IF(I1.GT.I)THEN DO WHILE(I2.LE.DIM) TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) J=J+1 I2=I2+1 ENDDO ELSE IF(I2.GT.DIM)THEN DO WHILE(I1.LE.I) TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 ENDDO ENDIF ENDIF DO I=1,DIM TEMP1(I)=TAB1(I) TEMP2(I)=TAB2(I) RESULT(I)=TAB(I) ENDDO RETURN END SUBROUTINE SMUMPS_FUSION_SORT MUMPS_5.8.1/src/cfac_front_type2_aux.F0000664000175000017500000007521115042446440017451 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC_FRONT_TYPE2_AUX_M CONTAINS SUBROUTINE CMUMPS_FAC_I_LDLT_NIV2( & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, & NFRONT, NASS, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK, & NASS2, TIPIV, & N, INODE, IW, LIW, A, LA, NNEGW, NNULLNEGW, & NB22T2W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INOPV, IFLAG,IERROR, & IOLDPS, POSELT, UU, & SEUIL,KEEP,KEEP8,PIVSIZ, & DKEEP, PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & PP_FIRST2SWAP_L, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled, & PIVOT_OPTION, & Inextpiv, IEND_BLR, LR_ACTIVATED, & OOC_EFFECTIVE_ON_FRONT) USE MUMPS_OOC_COMMON, ONLY : TYPEF_L USE CMUMPS_FAC_FRONT_AUX_M USE MUMPS_PIVNUL_MOD IMPLICIT NONE INTEGER SIZEDIAG_ORIG REAL DIAG_ORIG(SIZEDIAG_ORIG) REAL GW_FACTCUMUL INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,IERROR,INOPV INTEGER NASS2, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK INTEGER, intent(inout) :: NNEGW, NNULLNEGW, NB22T2W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX, intent(inout) :: DET_MANTW INTEGER TIPIV( NASS2 ) INTEGER PIVSIZ,LPIV INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER(8) :: LA COMPLEX A(LA) REAL UU, UULOC, SEUIL COMPLEX CSEUIL INTEGER IW(LIW) INTEGER IOLDPS INTEGER(8) :: POSELT INTEGER KEEP(500) INTEGER(8) KEEP8(150) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT LOGICAL :: SWAP_OCCURRED REAL DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled include 'mpif.h' INTEGER(8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX INTEGER :: IPIVNUL, HF REAL RMAX,AMAX,TMAX,RMAX_NORELAX,MAX_PREV_in_PARPIV REAL MAXPIV, ABS_PIVOT REAL RMAX_NOSLAVE, TMAX_NOSLAVE COMPLEX PIVOT,DETPIV REAL ABSDETPIV INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX, APOSROW INTEGER(8) :: APOS INTEGER(8) :: J1, J2, JJ, KK REAL :: GROWTH, RSWOP REAL :: UULOCM1 INTEGER :: LDAFS INTEGER(8) :: LDAFS8 REAL, PARAMETER :: RZERO = 0.0E0 REAL, PARAMETER :: RONE = 1.0E0 COMPLEX ZERO, ONE PARAMETER( ZERO = (0.0E0,0.0E0) ) PARAMETER( ONE = (1.0E0,0.0E0) ) REAL PIVNUL, VALTMP COMPLEX FIXA INTEGER NPIV,IPIV,K219 INTEGER NPIVP1,ILOC,K,J INTEGER ISHIFT, K206, IPIV_END, IPIV_SHIFT INTRINSIC max INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L REAL GW_FACT GW_FACT = RONE AMAX = RZERO RMAX = RZERO TMAX = RZERO RMAX_NOSLAVE = RZERO PIVOT = ONE HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) K206 = KEEP(206) PIVNUL = DKEEP(1) FIXA = cmplx(DKEEP(2),kind=kind(FIXA)) CSEUIL = cmplx(SEUIL,kind=kind(CSEUIL)) LDAFS = NASS LDAFS8 = int(LDAFS,8) IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+KEEP(IXSZ)) & +KEEP(IXSZ), & IW, LIW) ENDIF UULOC = UU K219 = KEEP(219) IF (UULOC.GT.RZERO) THEN UULOCM1 = RONE/UULOC ELSE K219=0 UULOCM1 = RONE ENDIF IF (K219.LT.2) GW_FACTCUMUL = RONE PIVSIZ = 1 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NPIVP1 = NPIV + 1 ILOC = NPIVP1 - IBEG_BLOCK_TO_SEND + 1 TIPIV( ILOC ) = ILOC APOSMAX = POSELT+LDAFS8*LDAFS8-1_8 IF(INOPV .EQ. -1) THEN APOS = POSELT + LDAFS8*int(NPIVP1-1,8) + int(NPIV,8) POSPV1 = APOS ABS_PIVOT = abs(PIVOT) CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, & DKEEP, KEEP, .TRUE.) IF(ABS_PIVOT.LT.SEUIL) THEN IF(real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE.0 ) THEN CALL CMUMPS_UPDATEDETER( A(APOS), DET_MANTW, DET_EXPW ) ENDIF IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 IF ((K219.GE.2).AND.(NPIVP1.EQ.1)) THEN GW_FACTCUMUL = RONE IF (K219.EQ.3) THEN DO IPIV=1,NASS DIAG_ORIG (IPIV) = abs(A(POSELT + & (LDAFS8+1_8)*int(IPIV-1,8))) ENDDO ELSE IF (K219.GE.4) THEN DIAG_ORIG = RZERO DO IPIV=1,NASS APOS = POSELT + LDAFS8*int(IPIV-1,8) POSPV1 = APOS + int(IPIV - 1,8) DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) DO J=IPIV+1,NASS DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) DIAG_ORIG(IPIV+J-IPIV) = max( abs(A(POSPV1)), & DIAG_ORIG(IPIV+J-IPIV) ) POSPV1 = POSPV1 + LDAFS8 ENDDO ENDDO ENDIF ENDIF ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + LDAFS8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN IF(ABS_PIVOT.LT.SEUIL) THEN CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, & DKEEP, KEEP, .TRUE.) IF(real(PIVOT) .GE. RZERO) THEN A(POSPV1) = CSEUIL ELSE A(POSPV1) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (ABS_PIVOT.EQ.RZERO) THEN GO TO 630 ELSE CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF ENDIF GO TO 420 ENDIF AMAX = -RONE JMAX = 0 J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDAFS8 DO J=1, IEND_BLOCK - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDAFS8 ENDDO RMAX_NOSLAVE = RZERO IF (PIVOT_OPTION.EQ.2) THEN DO J=1,NASS - IEND_BLOCK RMAX_NOSLAVE = max(abs(A(J1+LDAFS8*int(J-1,8))), & RMAX_NOSLAVE) ENDDO ENDIF IF (K219.NE.0) THEN RMAX_NORELAX = real(A(APOSMAX+int(IPIV,8))) RMAX = RMAX_NORELAX IF (K219.GE.2) THEN IF (ABS_PIVOT.NE.RZERO.AND. & ABS_PIVOT.GE.UULOC*max(RMAX,RMAX_NOSLAVE,AMAX)) & THEN GROWTH = RONE IF (K219.EQ.3) THEN IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN DIAG_ORIG(IPIV) = ABS_PIVOT ELSE GROWTH = ABS_PIVOT / DIAG_ORIG(IPIV) ENDIF ELSE IF (K219.GE.4) THEN IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN DIAG_ORIG(IPIV) = max(AMAX,RMAX_NOSLAVE) ELSE GROWTH = max(ABS_PIVOT,AMAX,RMAX_NOSLAVE)/ & DIAG_ORIG(IPIV) ENDIF ENDIF RMAX = RMAX*max(GROWTH,GW_FACTCUMUL) ENDIF ENDIF ELSE RMAX = RZERO RMAX_NORELAX = RZERO ENDIF RMAX_NOSLAVE = max(RMAX_NORELAX,RMAX_NOSLAVE) RMAX = max(RMAX,RMAX_NOSLAVE) IF (max(AMAX,RMAX,ABS_PIVOT).LE.PIVNUL) THEN IF ((K219.NE.0) & .AND.(K219.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & real(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + LDAFS8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) THEN GOTO 460 ENDIF ENDDO ENDIF ENDIF CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(POSPV1)), DKEEP, KEEP, .TRUE.) KEEP(109) = KEEP(109) + 1 IPIVNUL = KEEP(109) IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST.LT.KEEP(109)) & THEN CALL MUMPS_RESIZE_PIVNUL(KEEP, N, PIVNUL_LIST_STRUCT, & IPIVNUL, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 430 ENDIF PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) IF (real(FIXA).GT.RZERO) THEN IF(real(PIVOT) .GE. RZERO) THEN A(POSPV1) = FIXA ELSE A(POSPV1) = -FIXA ENDIF ELSE J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 A(JJ) = ZERO ENDDO DO J=1, NASS-IPIV A(POSPV1+int(J,8)*LDAFS8) = ZERO ENDDO VALTMP = max(1.0E10*RMAX, sqrt(huge(RMAX))/1.0E8) A(POSPV1) = cmplx(VALTMP,kind=kind(A)) ENDIF PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) GO TO 415 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF (ABS_PIVOT.GE.UULOC*max(RMAX,AMAX) & .AND. ABS_PIVOT .GT. max(SEUIL, tiny(RMAX))) THEN CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL CMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) THEN GOTO 460 ELSE IF (JMAX .EQ.0) THEN GOTO 460 ENDIF IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN GOTO 460 ENDIF IF (RMAX_NOSLAVE.LT.AMAX) THEN J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN RMAX_NOSLAVE = max(RMAX_NOSLAVE,abs(A(JJ))) ENDIF ENDDO DO J=1,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX_NOSLAVE = max(abs(A(POSPV1+LDAFS8*int(J,8))), & RMAX_NOSLAVE) ENDIF ENDDO RMAX = max(RMAX, RMAX_NOSLAVE) ENDIF APOSJ = POSELT + int(JMAX-1,8)*LDAFS8 + int(NPIV,8) POSPV2 = APOSJ + int(JMAX - NPIVP1,8) IF (IPIV.LT.JMAX) THEN OFFDAG = APOSJ + int(IPIV - NPIVP1,8) ELSE OFFDAG = APOS + int(JMAX - NPIVP1,8) END IF TMAX_NOSLAVE = RZERO IF(JMAX .LT. IPIV) THEN JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+LDAFS8 IF (JMAX+K.NE.IPIV) THEN TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) ENDIF ENDDO DO KK = APOSJ, POSPV2-1_8 TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) ENDDO ELSE JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+LDAFS8 TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) ENDDO DO KK = APOSJ, POSPV2 - 1_8 IF (KK.NE.OFFDAG) THEN TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) ENDIF ENDDO ENDIF IF (K219.NE.0) THEN TMAX = max(SEUIL*UULOCM1, & abs(real(A(APOSMAX+int(JMAX,8)))) & ) ELSE TMAX = SEUIL*UULOCM1 ENDIF IF (K219.GE.2) THEN GROWTH = RONE IF (K219.EQ.3) THEN IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN DIAG_ORIG(JMAX) = abs(A(POSPV2)) ELSE GROWTH = abs(A(POSPV2))/DIAG_ORIG(JMAX) ENDIF ELSE IF (K219.EQ.4) THEN IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN DIAG_ORIG(JMAX)=max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) ELSE GROWTH = max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) & / DIAG_ORIG(JMAX) ENDIF ENDIF TMAX = TMAX*max(GROWTH,GW_FACTCUMUL) ENDIF TMAX = max (TMAX,TMAX_NOSLAVE) DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)*A(OFFDAG) ABSDETPIV = abs(DETPIV) IF (SEUIL.GT.RZERO) THEN IF (sqrt(ABSDETPIV) .LE. SEUIL ) THEN GOTO 460 ENDIF ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN GO TO 460 ENDIF IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN GO TO 460 ENDIF CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( sqrt(abs(DETPIV)), & DKEEP, KEEP, .FALSE.) IF (KEEP(258).NE.0) THEN CALL CMUMPS_UPDATEDETER(DETPIV, DET_MANTW, DET_EXPW ) ENDIF PIVSIZ = 2 NB22T2W = NB22T2W+1 415 CONTINUE IF (K206.GE.1) THEN Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) ENDIF DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2 ) THEN IF (K==1) THEN LPIV = min(IPIV, JMAX) TIPIV(ILOC) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) ELSE LPIV = max(IPIV, JMAX) TIPIV(ILOC+1) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) ENDIF ELSE LPIV = IPIV TIPIV(ILOC) = IPIV - IBEG_BLOCK_TO_SEND + 1 ENDIF IF (LPIV.EQ.NPIVP1) THEN GOTO 416 ENDIF KEEP8(80) = KEEP8(80)+1 CALL CMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDAFS, NFRONT, 2, K219, KEEP(50), & KEEP(IXSZ), IBEG_BLOCK_TO_SEND ) SWAP_OCCURRED = .TRUE. IF (K219.GE.3) THEN RSWOP = DIAG_ORIG(LPIV) DIAG_ORIG(LPIV) = DIAG_ORIG(NPIVP1) DIAG_ORIG(NPIVP1) = RSWOP ENDIF 416 CONTINUE IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL CMUMPS_STORE_PERMINFO( & IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF NPIVP1 = NPIVP1+1 ENDDO IF(PIVSIZ .EQ. 2) THEN A(POSELT+LDAFS8*int(NPIV,8)+int(NPIV+1,8)) = DETPIV ENDIF GOTO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE IFLAG = -10 420 CONTINUE IF (K219.GE.2) THEN IF(INOPV .EQ. 0) THEN IF(PIVSIZ .EQ. 1) THEN GW_FACT = max(AMAX,RMAX_NOSLAVE)/ABS_PIVOT ELSE IF(PIVSIZ .EQ. 2) THEN GW_FACT = max( & (abs(A(POSPV2))*RMAX_NOSLAVE+AMAX*TMAX_NOSLAVE) & / ABSDETPIV , & (abs(A(POSPV1))*TMAX_NOSLAVE+AMAX*RMAX_NOSLAVE) & / ABSDETPIV & ) ENDIF GW_FACT = min(GW_FACT, UULOCM1) GW_FACTCUMUL = max(GW_FACT,GW_FACTCUMUL) ENDIF ENDIF 430 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_I_LDLT_NIV2 SUBROUTINE CMUMPS_FAC_MQ_LDLT_NIV2 & (IEND_BLOCK, & NASS, NPIV, INODE, A, LA, LDAFS, & POSELT,IFINB,PIVSIZ, & K219, PIVOT_OPTION, IEND_BLR, LR_ACTIVATED) IMPLICIT NONE INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: K219 COMPLEX, intent(inout) :: A(LA) INTEGER, intent(in) :: IEND_BLOCK INTEGER, intent(in) :: NPIV, PIVSIZ INTEGER, intent(in) :: NASS,INODE,LDAFS INTEGER, intent(out) :: IFINB INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED COMPLEX VALPIV INTEGER NCB1 INTEGER(8) :: APOS, APOSMAX INTEGER(8) :: LPOS, LPOS1, LPOS2, K1POS INTEGER(8) :: JJ, K1, K2 INTEGER(8) :: POSPV1, POSPV2, OFFDAG, OFFDAG_OLD INTEGER(8) :: LDAFS8 INTEGER NEL2 COMPLEX ONE, ALPHA COMPLEX ZERO INTEGER NPIV_NEW, I INTEGER(8) :: IBEG, IEND, IROW, J8 INTEGER :: J2 COMPLEX SWOP,DETPIV,MULT1,MULT2, A11, A22, A12 PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) INCLUDE 'mumps_headers.h' LDAFS8 = int(LDAFS,8) NPIV_NEW = NPIV + PIVSIZ IFINB = 0 NEL2 = IEND_BLOCK - NPIV_NEW IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ENDIF IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDAFS8 DO I = 1, NEL2 K1POS = LPOS + int(I-1,8)*LDAFS8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ=1_8, int(I,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO IF (PIVOT_OPTION.EQ.2) THEN NCB1 = NASS - IEND_BLOCK ELSE NCB1 = IEND_BLR - IEND_BLOCK ENDIF !$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) DO I=NEL2+1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDAFS8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO !$OMP END PARALLEL DO IF (K219.eq. -1) THEN APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) A(APOSMAX) = A(APOSMAX) * abs(VALPIV) DO J8 = 1_8, int(NEL2+NCB1,8) A(APOSMAX+J8) = A(APOSMAX+J8) + & A(APOSMAX) * abs(A(APOS+J8)) ENDDO ENDIF ELSE POSPV1 = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) POSPV2 = POSPV1+LDAFS8+1_8 OFFDAG_OLD = POSPV2 - 1_8 OFFDAG = POSPV1+1_8 SWOP = A(POSPV2) DETPIV = A(OFFDAG) A22 = A(POSPV1)/DETPIV A11 = SWOP/DETPIV A12 = -A(OFFDAG_OLD)/DETPIV A(OFFDAG) = A(OFFDAG_OLD) A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDAFS8 - 1_8 LPOS2 = LPOS1 + 1_8 CALL ccopy(NASS-NPIV_NEW, A(LPOS1), LDAFS, A(POSPV1+2_8), 1) CALL ccopy(NASS-NPIV_NEW, A(LPOS2), LDAFS, A(POSPV2+1_8), 1) JJ = POSPV2 + int(NASS-1,8) IBEG = JJ + 2_8 IEND = IBEG DO J2 = 1,NEL2 K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1+2_8 K2 = POSPV2+1_8 DO IROW = IBEG,IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = -MULT1 A(JJ+1_8) = -MULT2 IBEG = IBEG + int(NASS,8) IEND = IEND + int(NASS + 1,8) JJ = JJ+int(NASS,8) ENDDO IEND = IEND-1_8 DO J2 = IEND_BLOCK+1,NASS K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1+2_8 K2 = POSPV2+1_8 DO IROW = IBEG,IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = -MULT1 A(JJ+1_8) = -MULT2 IBEG = IBEG + int(NASS,8) IEND = IEND + int(NASS,8) JJ = JJ+int(NASS,8) ENDDO IF (K219.eq. -1) THEN APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) JJ = APOSMAX K1 = JJ K2 = JJ + 1_8 MULT1 = abs(A11)*A(K1)+abs(A12)*A(K2) MULT2 = abs(A12)*A(K1)+abs(A22)*A(K2) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 IBEG = APOSMAX + 2_8 IEND = APOSMAX + 1_8 + NASS - NPIV_NEW DO IROW = IBEG, IEND A(IROW) = A(IROW) + MULT1*abs(A(K1)) + MULT2*abs(A(K2)) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = MULT1 A(JJ+1_8) = MULT2 ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_FAC_MQ_LDLT_NIV2 SUBROUTINE CMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, N, & INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, LDA_FS, & IBEG_PANEL, IEND, TIPIV, LPIV, LASTPANEL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED, NPARTSASS, CURRENT_BLR_PANEL & , BLR_LorU & , LRGROUPS & ) USE CMUMPS_BUF USE MUMPS_LOAD USE CMUMPS_LR_TYPE USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, IBEG_PANEL, IEND, LPIV, & IOLDPS, LDA_FS, NB_BLOC_FAC INTEGER(8) :: POSELT, LA INTEGER IW(LIW), TIPIV(LPIV) LOGICAL LASTPANEL COMPLEX A(LA) INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL, & SLAVEF, ICNTL(60) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), & PERM(N), PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW COMPLEX DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL, intent(in) :: LR_ACTIVATED TYPE (LRB_TYPE), DIMENSION(:) :: BLR_LorU INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER :: NELIM INTEGER, intent(in) :: NPARTSASS, CURRENT_BLR_PANEL INCLUDE 'mumps_headers.h' INTEGER(8) :: APOS, LREQA INTEGER NPIV, NCOL, PDEST, NSLAVES, WIDTH INTEGER IERR, LREQI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED DOUBLE PRECISION FLOP1,FLOP2 LOGICAL COMPRESS_CB INTEGER NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 IF (NSLAVES.EQ.0) THEN WRITE(6,*) ' ERROR 1 in CMUMPS_SEND_FACTORED_PANEL ' CALL MUMPS_ABORT() ENDIF NPIV = IEND - IBEG_PANEL + 1 NCOL = LDA_FS - IBEG_PANEL + 1 APOS = POSELT + int(LDA_FS,8)*int(IBEG_PANEL-1,8) + & int(IBEG_PANEL - 1,8) IF (IBEG_PANEL > 0) THEN CALL MUMPS_GET_FLOPS_COST( LDA_FS, IBEG_PANEL-1, LPIV, & KEEP(50),2,FLOP1) ELSE FLOP1=0.0D0 ENDIF CALL MUMPS_GET_FLOPS_COST( LDA_FS, IEND, LPIV, & KEEP(50),2,FLOP2) FLOP2 = FLOP1 - FLOP2 CALL MUMPS_LOAD_UPDATE(1, .FALSE., FLOP2, KEEP,KEEP8) IF ((NPIV.GT.0) .OR. & ((NPIV.EQ.0).AND.(LASTPANEL)) & ) THEN IF ((NPIV.EQ.0).AND.(LASTPANEL)) THEN IF (COMPRESS_CB) THEN IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 COMPRESS_CB = .FALSE. ENDIF ENDIF PDEST = IOLDPS + 6 + KEEP(IXSZ) IF (( NPIV .NE. 0 ).AND.(KEEP(50).NE.0)) THEN NB_BLOC_FAC = NB_BLOC_FAC + 1 END IF IERR = -1 DO WHILE (IERR .EQ.-1) WIDTH = NSLAVES CALL CMUMPS_BUF_SEND_BLOCFACTO( INODE, LDA_FS, NCOL, & NPIV, FPERE, LASTPANEL, TIPIV, A(APOS), & IW(PDEST), NSLAVES, KEEP, NB_BLOC_FAC, & NSLAVES, WIDTH, COMM, & NELIM, NPARTSASS, CURRENT_BLR_PANEL, & LR_ACTIVATED, BLR_LorU, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & IBEG_PANEL, COMPRESS_CB, & ICNTL, IERR ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (MESSAGE_RECEIVED) THEN POSELT = PTRAST(STEP(INODE)) APOS = POSELT + int(LDA_FS,8)*int(IBEG_PANEL-1,8) + & int(IBEG_PANEL - 1,8) ENDIF IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2 .OR. IERR.EQ.-3 ) THEN IF (IERR.EQ.-2) IFLAG = -17 IF (IERR.EQ.-3) IFLAG = -20 LREQA = int(NCOL,8)*int(NPIV,8) LREQI = NPIV + 6 + 2*NSLAVES + 2 CALL MUMPS_SET_IERROR( & int(LREQI,8) * int(KEEP(34),8) + LREQA * int(KEEP(35),8), & IERROR) GOTO 300 ENDIF ENDIF GOTO 500 300 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE CMUMPS_SEND_FACTORED_PANEL END MODULE CMUMPS_FAC_FRONT_TYPE2_AUX_M MUMPS_5.8.1/src/cmumps_driver.F0000664000175000017500000030716015042446441016226 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C =========================== C FORTRAN 90 Driver for CMUMPS C (MPI based code) C =========================== C SUBROUTINE CMUMPS( id ) USE MUMPS_MEMORY_MOD USE CMUMPS_STRUC_DEF USE CMUMPS_STATIC_PTR_M ! For Schur pointer #if ! defined(NO_SAVE_RESTORE) USE CMUMPS_SAVE_RESTORE #endif USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_INTR_STRUC, & CMUMPS_ENCODE_INTR, & CMUMPS_DECODE_INTR, & CMUMPS_INIT_INTR_ENCODING, & CMUMPS_FREE_INTR_ENCODING C !$ USE OMP_LIB C IMPLICIT NONE C C ======= C Purpose C ======= C C TO SOLVE a SPARSE SYSTEM OF LINEAR EQUATIONS. C GIVEN AN UNSYMMETRIC, SYMMETRIC, OR SYMMETRIC POSITIVE DEFINITE C SPARSE MATRIX A AND AN N-VECTOR B, THIS SUBROUTINE SOLVES THE C SYSTEM A x = b or ATRANSPOSE x = b. C C List of main functionalities provided by the package: C ---------------------------------------------------- C -Unsymmetric solver with partial pivoting (LU factorization) C -Symmetric positive definite solver (LDLT factorization) C -General symmetric solver with pivoting C -Either elemental or assembled matrix input C -Analysis/Factorization/Solve callable separately C -Deficient matrices (symmetric or unsymmetric) C -Rank revealing C -Null space basis computation C -Solution C -Return the Schur complement matrix while C also providing solution of interior problem C -Distributed input matrix and analysis phase C -Sequential or parallel MPI version (any number of processors) C -Error analysis and iterative refinement C -Out-of-Core factorization and solution C -Solution phase: C -Multiple Right-Hand-sides (RHS) C -Sparse RHS C -Distributed RHS C -Computation of selected entries of the inverse of C original matrix. C - Block Low-Rank (BLR) approximation based factorization C C Method C ------ C The method used is a parallel direct method C based on a sparse multifrontal variant C of Gaussian elimination with partial numerical pivoting. C An initial ordering for the pivotal sequence C is chosen using the pattern of the matrix A + A^T and is C later modified for reasons of numerical stability. Thus this code C performs best on matrices whose pattern is symmetric, or nearly so. C For symmetric sparse matrices or for very unsymmetric and C very sparse matrices, other software might be more appropriate. C C C References : C ----------- C Please see https://mumps-solver.org/index.php?page=doc C C============================================ C Argument lists and calling sequences C============================================ C C There is only one entry: * * A Fortran 90 driver subroutine CMUMPS has been designed as a user * friendly interface to the multifrontal code. * This driver, in addition to providing the * normal functionality of a sparse solver, incorporates some * pre- and post-processing. * This driver enables the user to preprocess the matrix to obtain a * maximum * transversal so that the permuted matrix has a zero-free diagonal, * to perform prescaling * of the original matrix (a choice of scaling strategies is provided), * to use iterative refinement to improve the solution, * and finally to perform error analysis. * * The driver routine CMUMPS offers similar functionalities to other * sparse direct solvers, depending on the value of one of * its parameters (JOB). The main ones are: * * (i) JOB = -1 C initializes an instance of the package. This must be C called before any other call to the package concerning that instance. C It sets default values for other C components of CMUMPS_STRUC, which may then be altered before C subsequent calls to CMUMPS. C Note that three components of the structure must always be set by the C user (on all processors) before a call with JOB=-1. These are C id%COMM, C id%SYM, and C id%PAR. C CNTL, ICNTL can then be modified (see documentation) by the user. C * A value of JOB = -1 cannot be combined with other values for JOB * * (ii) JOB = 1 accepts the pattern of matrix A and chooses pivots * from the diagonal using a selection criterion to * preserve sparsity. It uses the pattern of A + A^T * but ignores numerical values. It subsequently constructs subsidiary * information for the actual factorization by a call with JOB_=_2. * An option exists for the user to * input the pivot sequence, in which case only the necessary * information for a JOB = 2 entry will be generated. We call the JOB=1 * entry, the analysis phase. C The following components of the structure define the centralized matrix C pattern and must be set by the user (on the host only) C before a call with JOB=1: C --- id%N, id%NZ (32-bit int) or id%NNZ (64-bit int), C id%IRN, and id%JCN C if the user wishes to input the structure of the C matrix in assembled format (ICNTL(5)=0, and ICNTL(18) $\neq$ 3), C --- id%ELTPTR, and id%ELTVAR C if the user wishes to input the matrix in elemental C format (ICNTL(5)=1). C A distributed matrix format is also available (see documentation) C * (iii) JOB = 2 factorizes a matrix A using the information * from a previous call with JOB = 1. The actual pivot sequence * used may differ slightly from that of this earlier call if A is not * diagonally dominant. * * (iv) JOB = 3 uses the factors generated by a JOB = 2 call to solve * a system of equations A X = B or A^T X =B, where X and B are matrices * that can be either dense or sparse. * The sparsity of B is exploited to limit the number of operations * performed during solution. When only part of the solution is * also needed (such as when computing selected entries of A^1) then * further reduction of the number of operations is performed. * This is particularly beneficial in the context of an * out-of-core factorization. * * (v) JOB = -2 frees all internal data allocated by the package. * * A call with JOB=3 must be preceded by a call with JOB=2, * which in turn must be preceded by a call with JOB=1, which * in turn must be preceded by a call with JOB=-1. Since the * information passed from one call to the next is not * corrupted by the second, several calls with JOB=2 for matrices * with the same sparsity pattern but different values may follow * a single call with JOB=1, and similarly several calls with JOB=3 * can be used for different right-hand sides. * Values 4, 5, 6 for the parameter JOB can invoke combinations * of the three basic operations corresponding to JOB=1, 2 or 3. * * JOB = -4 : frees all data structures from the factorization * while keeping data structures from the analysis. Can be * followed by a JOB = 2 call. * #if ! defined(NO_SAVE_RESTORE) * JOB = -3, 7, 8 : save and restore feature, see userguide #endif * JOB = 9 : provide suggested data distribution for IRHS_LOC C ********* C -------------------------------------- C Explicit interface needed for routines C using a target argument if they appear C in the same compilation unit. C -------------------------------------- INTERFACE SUBROUTINE CMUMPS_CHECK_DENSE_RHS &(idRHS, idINFO, idN, idNRHS, idLRHS) COMPLEX, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE CMUMPS_CHECK_DENSE_RHS SUBROUTINE CMUMPS_ANA_DRIVER( id, idintr ) USE CMUMPS_STRUC_DEF USE CMUMPS_INTR_TYPES TYPE (CMUMPS_STRUC), TARGET :: id TYPE (CMUMPS_INTR_STRUC) :: idintr END SUBROUTINE CMUMPS_ANA_DRIVER SUBROUTINE CMUMPS_FAC_DRIVER( id, idintr ) USE CMUMPS_STRUC_DEF USE CMUMPS_INTR_TYPES TYPE (CMUMPS_STRUC), TARGET :: id TYPE (CMUMPS_INTR_STRUC) :: idintr END SUBROUTINE CMUMPS_FAC_DRIVER SUBROUTINE CMUMPS_SOLVE_DRIVER( id, idintr ) USE CMUMPS_STRUC_DEF USE CMUMPS_INTR_TYPES TYPE (CMUMPS_STRUC), TARGET :: id TYPE (CMUMPS_INTR_STRUC) :: idintr END SUBROUTINE CMUMPS_SOLVE_DRIVER SUBROUTINE CMUMPS_PRINT_ICNTL(id, LP) USE CMUMPS_STRUC_DEF TYPE (CMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP END SUBROUTINE CMUMPS_PRINT_ICNTL END INTERFACE * MPI * === INCLUDE 'mpif.h' INTEGER MASTER PARAMETER ( MASTER = 0 ) INTEGER IERR * * ========== * Parameters * ========== TYPE (CMUMPS_STRUC) :: id C C Main components of the structure are: C ------------------------------------ C C (see documentation for a complete description) C C JOB is an INTEGER variable which must be set by the user to C characterize the factorization step. Possible values of JOB C are given below C C 1 Analysis: Ordering and symbolic factorization steps. C 2 Scaling and Numerical Factorization C 3 Solve and Error analysis C 4 Analysis followed by numerical factorization C 5 Numerical factorization followed by Solving step C 6 Analysis, Numerical factorization and Solve C C N is an INTEGER variable which must be set by the user to the C order n of the matrix A. It is not altered by the C subroutine. C C NZ / NNZ are INTEGER / INTEGER(8) variables which must be set by the user C to the number of entries being input, in case of centralized assembled C entry. It is not altered by the subroutine. Only used if C ICNTL(5).eq.0 and ICNTL(18) .ne. 3 (assembled matrix entry, C or, at least, centralized matrix graph during analysis). C C Restriction: NZ > 0 or NNZ > 0. C If NNZ is different from 0, NNZ is used. Otherwise, NZ is used. C C NELT is an INTEGER variable which must be set by the user to the C number of elements being input. It is not altered by the C subroutine. Only used if ICNTL(5).eq.1 (elemental matrix entry). C Restriction: NELT > 0. C C IRN and JCN are INTEGER arrays of length [N]NZ. C IRN(k) and JCN(k), k=1..[N]NZ must be set on entry to hold C the row and column indices respectively. C They are not altered by the subroutine except when ICNTL(6) = 1. C (in which case only the column indices are modified). C The arrays are only used if ICNTL(5).eq.0 (assembled entry) C or out-of-range. C C ELTPTR is an INTEGER array of length NELT+1. C ELTVAR is an INTEGER array of length ELTPTR(NELT+1)-1. C ELTPTR(I) points in ELTVAR to the first variable in the list of C variables that correspond to element I. ELTPTR(NELT+1) points C to the first unused location in ELTVAR. C The positions ELTVAR(I) .. ELTPTR(I+1)-1 contain the variables C for element I. No free space is allowed between variable lists. C ELTPTR/ELTVAR are not altered by the subroutine. C The arrays are only used if ICNTL(5).ne.0 (element entry). C C A is a COMPLEX array of length [N]NZ. C The user must set A(k) to the value C of the entry in row IRN(k) and column JCN(k) of the matrix. C It is not altered by the subroutine. C (Note that the matrix can also be provided in a distributed C assembled input format) C C RHS is a COMPLEX array of length N that is only accessed when C JOB = 3, 5, or 6. On entry, RHS(i) C must hold the i th component of the right-hand side of the C equations being solved. C On exit, RHS(i) will hold the i th component of the C solution vector. For other values of JOB, RHS is not accessed and C can be declared to have size one. C RHS should only be available on the host processor. If C it is associated on other processors, an error is raised. C (Note that the right-hand sides can also be provided in a C sparse format). C C COLSCA, ROWSCA are REAL C arrays of length N that are used to hold C the values used to scale the columns and the rows C of the original matrix, respectively. C These arrays need to be set by the user C only if ICNTL(8) is set to -1. If ICNTL(8)=0, C COLSCA and ROWSCA are not accessed and C so can be declared to have size one. C For any other values of ICNTL(8), C the scaling arrays are computed before C numerical factorization. The factors of the scaled matrix C diag(ROWSCA(i)) automatic choice IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ( id%KEEP(52) .EQ. 2 .OR. id%KEEP(52).EQ.5 & .OR. id%KEEP(52) .EQ. 6 ) & id%KEEP(52) = 77 IF ((id%KEEP(52).EQ.77).AND.(id%KEEP(50).EQ.1)) THEN ! for SPD matrices default is no scaling id%KEEP(52) = 0 ENDIF IF ( id%KEEP(52).EQ.77 .OR. id%KEEP(52).LE.-2) THEN C -- suppress scaling computed during analysis C -- if centralized matrix is not associated IF (.not.associated(id%A)) id%KEEP(52) = 0 ENDIF C deactivate analysis scaling if scaling given IF(id%KEEP(52) .EQ. -1) id%KEEP(52) = 0 C C deactivate analysis scaling if C permutation to zero-free diagonal not requested IF (id%ICNTL(6).EQ.0) id%KEEP(52) = 0 C deactivate analysis scaling for SPD matrices IF (id%KEEP(50).EQ.1) id%KEEP(52) = 0 C IF (id%KEEP(52).EQ.-2) THEN C deallocate scalings in case of ordering allocated/computed C during analysis. This is needed because in case of C KEEP(52)=-2 then one cannot be sure that C scaling will be effectivly computed during analysis C Thus to test if scaling was effectively allocated/computed C during analysis after CMUMPS_ANA_DRIVER one must C be sure that scaling arrays are nullified. IF ( associated(id%COLSCA)) THEN DEALLOCATE( id%COLSCA ) NULLIFY(id%COLSCA) ENDIF IF ( associated(id%ROWSCA)) THEN DEALLOCATE( id%ROWSCA ) NULLIFY(id%ROWSCA) ENDIF ENDIF C C} ENDIF C C ANALYSIS PHASE: CALL CMUMPS_ANA_DRIVER( id, idintr ) C restore values id%KEEP(77) = KEEP77SAVE id%KEEP(78) = KEEP78SAVE id%KEEP(83) = KEEP83SAVE id%KEEP(91) = KEEP91SAVE id%KEEP(172) = KEEP172SAVE id%KEEP(178) = KEEP178SAVE #if ! defined(LARGEMATRICES) IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0) THEN IF (.not.associated(id%UNS_PERM)) THEN C I may happen C (for ex in case of error -7 during analysis: C UNS_PERM can be not associated, C KEEP(23) was set to to automatic choice(=7) and C an error of memory allocation occurs during analysis C before having decided value of KEEP(23)) C UNS_PERM not associated and KEEP(23).NE.0 C Permuting JCN back does not make sense and KEEP(23) C should be reset to zero id%KEEP(23) = 0 ELSE UNS_PERM_DONE = .TRUE. ENDIF ENDIF #endif C C Check and save scaling option in INFOG(33) IF (id%MYID .eq. MASTER) THEN C{ IF (id%KEEP(52).EQ.0) id%INFOG(33)=id%ICNTL(8) IF (id%KEEP(52).EQ.-2) THEN C Scaling should have been computed during analysis IF (.not.associated(id%COLSCA).OR. & .not.associated(id%ROWSCA) & ) THEN C scaling was not computed reset KEEP(52) C the user can then decide during factorization C to activate scaling id%KEEP(52) =0 id%INFOG(33)=0 IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') & ' Warning; scaling was not computed during analysis' ENDIF IF ( associated(id%COLSCA)) THEN DEALLOCATE( id%COLSCA ) NULLIFY(id%COLSCA) ENDIF IF ( associated(id%ROWSCA)) THEN DEALLOCATE( id%ROWSCA ) NULLIFY(id%ROWSCA) ENDIF ENDIF ENDIF IF (id%KEEP(52) .NE. 0) THEN id%INFOG(33)=id%KEEP(52) ENDIF C} ENDIF C return value of ICNTL(12) effectively used C that was saved on the master in KEEP(95) IF (id%MYID .eq. MASTER) id%INFOG(24)=id%KEEP(95) C TIMINGS: IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(71) = real(TIMEG) ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in analysis driver= ', TIMEG END IF C ----------------------- C Return in case of error C ----------------------- IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 id%KEEP(40) = 1 -456789 END IF C C------------------------------------------------------- C- C C BEGIN FACTORIZATION PHASE C C- C------------------------------------------------------- IF ( LFACTO ) THEN C{ IF (id%MYID .eq. MASTER) THEN id%DKEEP(91)=0.0E0 CALL MUMPS_SECDEB(TIMEG) END IF C ---------------------- C Reset KEEP(40) to 1 in C case of error in facto C ---------------------- id%KEEP(40) = 1 - 456789 C C------------------------------------------------------- C- C- CHECKS, SCALING, ARROWHEAD + FACTORIZATION PHASE C- C------------------------------------------------------- C C Broadcast the value of KEEP(125) to decide if performing C the scaling with the Schur complement feature. CALL MPI_BCAST( id%KEEP(125), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) IF ( id%MYID .EQ. MASTER ) THEN C ------------------------- C Check if Schur complement C is allocated. C ------------------------- IF (id%KEEP(60).EQ.1) THEN IF ( associated( id%SCHUR_CINTERFACE)) THEN C Called from C interface... C Since id%SCHUR_CINTERFACE is of size 1, C instruction below which causes bound check C errors should be avoided. We cheat by first C setting a static pointer with a routine with C implicit interface, and then copying this pointer C into id%SCHUR. CALL CMUMPS_SET_TMP_PTR(id%SCHUR_CINTERFACE(1), & int(id%SIZE_SCHUR,8)*int(id%SIZE_SCHUR,8)) CALL CMUMPS_GET_TMP_PTR(id%SCHUR) NULLIFY(id%SCHUR_CINTERFACE) ENDIF IF ( .NOT. associated (id%SCHUR)) THEN IF (LP.GT.0) & write(LP,'(A)') & ' SCHUR not associated' id%INFO(1)=-22 id%INFO(2)=9 ELSE IF ( size(id%SCHUR) .LT. & id%SIZE_SCHUR * id%SIZE_SCHUR ) THEN IF (LP.GT.0) & write(LP,'(A)') & ' SCHUR allocated but too small' id%INFO(1)=-22 id%INFO(2)=9 END IF END IF C ------------------------------------------------------------ C Assembled entry: check input parameterd IRN,JCN,A C Element entry: check input parameters ELTPTR,ELTVAR,A_ELT C ------------------------------------------------------------ IF ( id%KEEP(54) .EQ. 0 ) THEN IF ( id%KEEP(55).eq.0 ) THEN C Assembled entry IF ( .not. associated( id%IRN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 #if defined(MUMPS_NOF2003) C size with kind=8 output not available. One can still C check that if NZ can be stored in a 32-bit integer, C the 32-bit size(id%IRN) (which we then assume not C to overflow...) is large enough ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%IRN) < int(id%KEEP8(28)) ) THEN #else ELSE IF ( size( id%IRN, KIND=8 ) < id%KEEP8(28) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%JCN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 #if defined(MUMPS_NOF2003) C Same as for IRN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%JCN) < int(id%KEEP8(28)) ) THEN #else ELSE IF ( size( id%JCN, KIND=8 ) < id%KEEP8(28) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( .not. associated( id%A ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 #if defined(MUMPS_NOF2003) C Same as for IRN/JCN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size( id%A ) < int(id%KEEP8(28)) ) THEN #else ELSE IF ( size( id%A, KIND=8 ) < id%KEEP8(28) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 END IF ELSE C Element entry IF ( .not. associated( id%ELTPTR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( size( id%ELTPTR ) < id%NELT+1 ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%ELTVAR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( size( id%ELTVAR ) < id%LELTVAR ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( .not. associated( id%A_ELT ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ELSE #if defined(MUMPS_NOF2003) IF ( id%KEEP8(30) < int(huge(id%NZ),8) .AND. & size( id%A_ELT ) < int(id%KEEP8(30)) ) THEN #else IF ( size( id%A_ELT, KIND=8 ) < id%KEEP8(30) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ENDIF END IF ENDIF ENDIF C ---------------------- C Get the value of PERLU C ---------------------- CALL MUMPS_GET_PERLU(id%KEEP(12),id%ICNTL(14), & id%KEEP(50),id%KEEP(54),id%ICNTL(6),id%ICNTL(8)) C C ---------------------- C Get null space options C Note that nullspace is forbidden in case of Schur complement C ---------------------- CALL CMUMPS_GET_NS_OPTIONS_FACTO(id%N,id%KEEP(1), & id%ICNTL(1),MPG) C ======================================== C Decode and set scaling options for facto C ======================================== IF (.NOT. ((id%KEEP(52).EQ.-2).AND.(id%ICNTL(8).EQ.77)) ) & THEN C if scaling was computed during analysis and automatic C choice of scaling then we do not recompute scaling id%KEEP(52)=id%ICNTL(8) ENDIF IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ( id%KEEP(52) .EQ. 2 .OR. id%KEEP(52).EQ.5 & .OR. id%KEEP(52) .EQ. 6 ) & id%KEEP(52) = 77 IF (id%KEEP(52).EQ.77) THEN IF (id%KEEP(50).EQ.1) THEN ! for SPD matrices the default is "no scaling" id%KEEP(52) = 0 ELSE ! SYM .ne. 1 the default is cheap SIMSCA id%KEEP(52) = 7 ENDIF ENDIF IF (id%KEEP(23) .NE. 0 .AND. id%ICNTL(8) .EQ. -1) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** WARNING : SCALING' WRITE(MPG,'(A)') & ' ** column permutation applied:' WRITE(MPG,'(A)') & ' ** column scaling has to be permuted' ENDIF ENDIF C ----------------------------------- C If Schur has been asked for C choose to disable or enable scaling C ---------------------------------- IF (id%KEEP(125).EQ.0) THEN C ------------------------ C scaling is disabled C ------------------------ IF ( id%KEEP(60) .ne. 0 .and. id%KEEP(52) .ne. 0 ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 .AND. id%ICNTL(8) .NE. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: scaling not applied.' WRITE(MPG,'(A)') ' ** (disabled with Schur)' END IF END IF END IF C ------------------------------- C If matrix is distributed on C entry, only options 7 and 8 C of scaling are allowed. C ------------------------------- IF (id%KEEP(54) .NE. 0 .AND. & id%KEEP(52).NE.7 .AND. id%KEEP(52).NE.8 .AND. & id%KEEP(52) .NE. 0 ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 .and. id%ICNTL(8) .ne. 0 ) THEN WRITE(MPG,'(A)') & ' ** Warning: requested scaling option not available' WRITE(MPG,'(A)') ' ** for distributed matrix entry' END IF END IF C ------------------------------------ C If matrix is symmetric, only scaling C options -1 (given scaling), 1 C (diagonal scaling), 7 and 8 (SIMSCALING) C are allowed. C ------------------------------------ IF ( id%KEEP(50) .NE. 0 ) THEN IF ( id%KEEP(52).ne. 1 .and. & id%KEEP(52).ne. -1 .and. & id%KEEP(52).ne. 0 .and. & id%KEEP(52).ne. 7 .and. & id%KEEP(52).ne. 8 .and. & id%KEEP(52).ne. -2 .and. & id%KEEP(52).ne. 77) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') & ' ** Warning: scaling option n.a. for symmetric matrix' END IF id%KEEP(52) = 0 END IF END IF C ---------------------------------- C If matrix is elemental on entry, C automatic scaling is now forbidden C ---------------------------------- IF (id%KEEP(55) .NE. 0 .AND. & ( id%KEEP(52) .gt. 0 ) ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: scaling not applied.' WRITE(MPG,'(A)') & ' ** (only user scaling av. for elt. entry)' END IF END IF C -------------------------------------- C Check input parameters ROWSCA / COLSCA C -------------------------------------- IF ( id%KEEP(52) .eq. -1 ) THEN IF ( .not. associated( id%ROWSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( .not. associated( id%COLSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 6 ELSE IF ( size( id%COLSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 6 END IF END IF C C Allocate -- if required, C ROWSCA and COLSCA on the master C C Allocation of scaling arrays. C IF (KEEP(52)==-2 then scaling should have been allocated C and computed during analysis C C If ICNTL(8) == -1, ROWSCA and COLSCA must have been associated and C filled by the user. If ICNTL(8) is >0 and <= 8, the scaling is C computed at the beginning of CMUMPS_FAC_DRIVER and is allocated now. C IF (id%KEEP(52).GT.0 .AND. & id%KEEP(52) .LE.8) THEN IF ( associated(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(id%N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=id%N ENDIF ALLOCATE( id%ROWSCA(id%N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=id%N ENDIF END IF C C Allocate scaling arrays of size 1 if C they are not used to avoid problems C when passing them in arguments C IF (.NOT. associated(id%COLSCA)) THEN ALLOCATE( id%COLSCA(1), stat=IERR) END IF IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 ENDIF IF (.NOT. associated(id%ROWSCA)) & ALLOCATE( id%ROWSCA(1), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF ( LPOK ) WRITE(LP,'(A)') & 'Problems in allocations before facto' GOTO 200 END IF IF (id%KEEP(252) .EQ. 1) THEN CALL CMUMPS_CHECK_DENSE_RHS & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) C Sets KEEP(221) and do some checks C in case of Schur check if reduced RHS C requested CALL CMUMPS_SET_K221(id,.FALSE.) CALL CMUMPS_CHECK_K221andREDRHS(id) ENDIF 200 CONTINUE END IF ! End of IF (MYID .eq. MASTER) C KEEP(221) was set in CMUMPS_SET_K221 but not broadcast CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) C broadcast RR option CALL MPI_BCAST( id%KEEP(19), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) C C Check distributed matrices on all processors. I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (I_AM_SLAVE .AND. & id%KEEP(54).NE.0 .AND. id%KEEP8(29).GT.0_8) THEN IF ( .not. associated( id%IRN_loc ) ) THEN id%INFO(1) = -22 id%INFO(2) = 16 #if defined(MUMPS_NOF2003) C size with kind=8 output not available. One can still C check that if NZ_loc can be stored in a 32-bit integer, C the 32-bit size(id%IRN_loc) (which we then assume not C to overflow...) is large enough ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size(id%IRN_loc) < int(id%KEEP8(29)) ) THEN #else ELSE IF ( size( id%IRN_loc, KIND=8 ) < id%KEEP8(29) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 16 ELSE IF ( .not. associated( id%JCN_loc ) ) THEN id%INFO(1) = -22 id%INFO(2) = 16 #if defined(MUMPS_NOF2003) C Same as for IRN_loc above ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size(id%JCN_loc) < int(id%KEEP8(29)) ) THEN #else ELSE IF ( size( id%JCN_loc, KIND=8 ) < id%KEEP8(29) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 16 ELSEIF ( .not. associated( id%A_loc ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 16 #if defined(MUMPS_NOF2003) C Same as for IRN_loc/JCN_loc above ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size( id%A_loc ) < int(id%KEEP8(29)) ) THEN #else ELSE IF ( size( id%A_loc, KIND=8 ) < id%KEEP8(29) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 16 END IF ENDIF C C Check Schur complement on all processors. C CMUMPS_PROPINFO will be called right after those checks. C IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF ( idintr%root%yes ) THEN IF ( associated( id%SCHUR_CINTERFACE )) THEN C Called from C interface... C The next instruction may cause C bound check errors at runtime C id%SCHUR=>id%SCHUR_CINTERFACE C & (1:id%SCHUR_LLD*(idintr%root%SCHUR_NLOC-1)+ C & idintr%root%SCHUR_MLOC) C Instead, we set a temporary C pointer and then retrieve it CALL CMUMPS_SET_TMP_PTR(id%SCHUR_CINTERFACE(1), & int(id%SCHUR_LLD,8)*int(idintr%root%SCHUR_NLOC-1,8)+ & int(idintr%root%SCHUR_MLOC,8)) CALL CMUMPS_GET_TMP_PTR(id%SCHUR) NULLIFY(id%SCHUR_CINTERFACE) ENDIF C Check that SCHUR_LLD is large enough IF (id%SCHUR_LLD < idintr%root%SCHUR_MLOC) THEN IF (LP.GT.0) write(LP,*) & ' SCHUR leading dimension SCHUR_LLD ', & id%SCHUR_LLD, 'too small with respect to', & idintr%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*(idintr%root%SCHUR_NLOC-1)+ & idintr%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=', idintr%root%SCHUR_NLOC, & ' SCHUR_NLOC=', idintr%root%SCHUR_NLOC ENDIF id%INFO(1)=-22 id%INFO(2)= 9 ELSE C We initialize the pointer that C we will use within CMUMPS here. idintr%root%SCHUR_LLD=id%SCHUR_LLD IF (idintr%root%SCHUR_NLOC==0) THEN ALLOCATE(idintr%roota%SCHUR_POINTER(1), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF ( LPOK ) THEN WRITE(LP,'(A)') & 'Problems in allocations before facto' ENDIF END IF ELSE idintr%roota%SCHUR_POINTER=>id%SCHUR ENDIF ENDIF ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 C ----------------------------------------------- C Call factorization procedure CMUMPS_FAC_DRIVER C ----------------------------------------------- CALL CMUMPS_FAC_DRIVER(id,idintr) C Save scaling in INFOG(33) IF (id%MYID .eq. MASTER) id%INFOG(33)=id%KEEP(52) C C In the case of Schur, free or not associated C idintr%roota%SCHUR_POINTER now rather than in end_driver.F C (Case of repeated factorizations). IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF (idintr%root%yes) THEN IF (idintr%root%SCHUR_NLOC==0) THEN DEALLOCATE(idintr%roota%SCHUR_POINTER) NULLIFY(idintr%roota%SCHUR_POINTER) ELSE NULLIFY(idintr%roota%SCHUR_POINTER) ENDIF ENDIF ENDIF IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(91) = real(TIMEG) ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in factorization driver =', & TIMEG END IF C C Check for errors after FACTO C (it was propagated inside) IF(id%INFO(1).LT.0) THEN C ------------------------------------------------------- C Free data from this factorization. Since factorization C fails, factors, etc. can not be used to perform a solve C ------------------------------------------------------- CALL CMUMPS_FREE_DATA_FACTO(id,idintr) GO TO 499 ENDIF C C Update last successful step C id%KEEP(40) = 2 - 456789 C} END IF C------------------------------------------------------- C- C C BEGIN SOLVE PHASE C C- C------------------------------------------------------- IF (LSOLVE) THEN IF (id%MYID .eq. MASTER) THEN id%DKEEP(111)=0.0E0 CALL MUMPS_SECDEB(TIMEG) END IF C --------------------- C Reset KEEP(40) to 2. C (last successful step C was facto) C --------------------- id%KEEP(40) = 2 -456789 C ------------------------------------------ C Call solution procedure CMUMPS_SOLVE_DRIVER C ------------------------------------------ IF (id%MYID .eq. MASTER) THEN KEEP235SAVE = id%KEEP(235) KEEP242SAVE = id%KEEP(242) KEEP243SAVE = id%KEEP(243) KEEP495SAVE = id%KEEP(495) KEEP497SAVE = id%KEEP(497) ! if no permutation of RHS asked then suppress request ! to interleave the RHS ! to interleave the RHS on ordering given then ! using option to set permutation to identity should be ! used (note though that ! they # with A-1/sparseRHS and Null Space) IF (id%KEEP(242).EQ.0) id%KEEP(243)=0 C -------------------------------------- C Check input parameters ROWSCA / COLSCA C Only if KEEP(52).NE.0 because C only 0 means that no colsca/rowsca are needed C -------------------------------------- IF ( id%KEEP(52) .ne. 0) THEN IF ( .not. associated( id%ROWSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( .not. associated( id%COLSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 6 ELSE IF ( size( id%COLSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 6 END IF ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 CALL CMUMPS_SOLVE_DRIVER(id,idintr) IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(111) = real(TIMEG) ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in solve driver= ', TIMEG END IF IF (id%MYID .eq. MASTER) THEN id%KEEP(235) = KEEP235SAVE id%KEEP(242) = KEEP242SAVE id%KEEP(243) = KEEP243SAVE id%KEEP(495) = KEEP495SAVE id%KEEP(497) = KEEP497SAVE ENDIF IF (id%INFO(1).LT.0) GOTO 499 C --------------------------- C Update last successful step C --------------------------- id%KEEP(40) = 3 -456789 ENDIF C C What was actually done is saved in KEEP(40) C IF (PROK) CALL CMUMPS_PRINT_ICNTL(id, MP) GOTO 500 * *================= * ERROR section *================= 499 CONTINUE * Print error message if PROK IF (LPOK) WRITE (LP,99995) id%INFO(1) IF (LPOK) WRITE (LP,99994) id%INFO(2) * 500 CONTINUE #if ! defined(LARGEMATRICES) C --------------------------------- C Permute JCN on output to CMUMPS if C KEEP(23) is different from 0. C --------------------------------- IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0 & .AND. NOERRORBEFOREPERM) THEN C ------------------------------- C IF JOB=3 and PERM was not C done (no iterative refinement/ C error analysis), then we do not C permute JCN back. C ------------------------------- IF (UNS_PERM_DONE) THEN DO I8 = 1_8, id%KEEP8(28) J=id%JCN(I8) C -- skip out-of range (that are ignored in ANA_O) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I8)=id%UNS_PERM(J) END DO END IF END IF #endif 510 CONTINUE C ------------------------------------ C Set INFOG(1:2): same value on all C processors + broadcast other entries C ------------------------------------ CALL CMUMPS_SET_INFOG(id%INFO(1), id%INFOG(1), id%COMM, id%MYID) C C -------------------------------- C Broadcast RINFOG entries to make C them available on all procs. C -------------------------------- CALL MPI_BCAST( id%RINFOG(1), 40, MPI_REAL, MASTER, & id%COMM, IERR ) IF (id%INFOG(1).GE.0 .AND. JOB.NE.-1 & .AND. JOB.NE.-2 ) THEN IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMETOTAL) id%DKEEP(70) = real(TIMETOTAL) ENDIF ENDIF C ------------------------------------------------------------ C SCHUR_CINTERFACE is no longer needed. It will be set again C the next time MUMPS is entered through its C interface. C ------------------------------------------------------------ NULLIFY(id%SCHUR_CINTERFACE) C #if ! defined(NO_SAVE_RESTORE) *======================= * Compute space for save *======================= IF (id%INFOG(1).GE.0) THEN IF ( IDINTR_MEANINGFUL_ON_EXIT ) THEN C Only do this if idintr is meaningful on exit. This includes C the case of JOB -2 that needs to update statistics. This excludes C the cases of JOBs that did not decode idintr, for which the save C restore statistics have not changed. CALL CMUMPS_COMPUTE_MEMORY_SAVE(id,idintr,FILE_SIZE,STRUC_SIZE) id%KEEP8(55)=FILE_SIZE call MPI_ALLREDUCE(id%KEEP8(55),id%KEEP8(57),1, & MPI_INTEGER8, MPI_SUM,id%COMM,IERR) id%KEEP8(56)=STRUC_SIZE call MPI_ALLREDUCE(id%KEEP8(56),id%KEEP8(58),1, & MPI_INTEGER8, MPI_SUM,id%COMM,IERR) id%RINFO(7)=REAL(id%KEEP8(55))/1E6 id%RINFO(8)=REAL(id%KEEP8(56))/1E6 id%RINFOG(17)=REAL(id%KEEP8(57))/1E6 id%RINFOG(18)=REAL(id%KEEP8(58))/1E6 ENDIF ENDIF #endif !$ IF (ICNTL16_LOC .GT. 0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(PREVIOUS_OMP_THREADS_NUM,4)) #else !$ CALL omp_set_num_threads(PREVIOUS_OMP_THREADS_NUM) #endif !$ ICNTL16_LOC = 0 !$ ENDIF *=============== * ERRORG section *=============== IF (id%MYID.EQ.MASTER.and.MPG.GT.0.and. & id%INFOG(1).lt.0) THEN WRITE(MPG,'(A,I16)') ' On return from CMUMPS, INFOG(1)=', & id%INFOG(1) WRITE(MPG,'(A,I16)') ' On return from CMUMPS, INFOG(2)=', & id%INFOG(2) END IF C ------------------------- C Restore user communicator C ------------------------- CALL MPI_COMM_FREE( id%COMM, IERR ) id%COMM = COMM_SAVE C ------------------------------------ C Set id%INTR_ENCODING from idintr C ------------------------------------ IF (MUST_ENCODE_IDINTR_ON_EXIT) THEN CALL CMUMPS_ENCODE_INTR(id%INTR_ENCODING, idintr) ENDIF RETURN * 99995 FORMAT (' ** ERROR RETURN ** FROM CMUMPS INFO(1)=', I5) 99994 FORMAT (' ** INFO(2)=', I16) 99993 FORMAT (' ** Allocation error: could not permute JCN.') END SUBROUTINE CMUMPS * SUBROUTINE CMUMPS_SET_INFOG( INFO, INFOG, COMM, MYID ) IMPLICIT NONE INCLUDE 'mpif.h' C C Purpose: C ======= C C If one proc has INFO(1).lt.0 and INFO(1) .ne. -1, C puts INFO(1:2) of this proc on all procs in INFOG C C Arguments: C ========= C INTEGER, PARAMETER :: SIZE_INFOG = 80 INTEGER :: INFO(80) INTEGER :: INFOG(SIZE_INFOG) ! INFOG(80) INTEGER :: COMM, MYID C C Local variables C =============== C #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) :: TMP1(2),TMP(2) #else INTEGER :: TMP1(2),TMP(2) #endif INTEGER ROOT, IERR INTEGER MASTER, WARNING_COUNT PARAMETER (MASTER=0) C C IF ( INFO(1) .ge. 0 ) THEN C C This can only happen if the phase was successful C on all procs. If one proc failed, then all other C procs would have INFO(1)=-1. C IF (INFO(1) .GT.0) THEN WARNING_COUNT=1 ELSE WARNING_COUNT=0 ENDIF INFOG(1) = INFO(1) INFOG(2) = INFO(2) CALL MPI_ALLREDUCE(WARNING_COUNT, INFOG(2), 1,MPI_INTEGER, & MPI_SUM, COMM, IERR) CALL MPI_ALLREDUCE(INFO(1),INFOG(1),1, MPI_INTEGER, & MPI_BOR, COMM, IERR) ELSE C --------------------- C Find who has smallest C error code INFO(1) C --------------------- INFOG(1) = INFO(1) C INFOG(2) = MYID TMP1(1) = INFO(1) TMP1(2) = MYID CALL MPI_ALLREDUCE(TMP1,TMP,1,MPI_2INTEGER, & MPI_MINLOC,COMM,IERR ) INFOG(2) = INFO(2) ROOT = TMP(2) CALL MPI_BCAST( INFOG(1), 1, MPI_INTEGER, ROOT, COMM, IERR ) CALL MPI_BCAST( INFOG(2), 1, MPI_INTEGER, ROOT, COMM, IERR ) END IF C C Make INFOG available on all procs: C CALL MPI_BCAST(INFOG(3), SIZE_INFOG-2, MPI_INTEGER, & MASTER, COMM, IERR ) RETURN END SUBROUTINE CMUMPS_SET_INFOG C-------------------------------------------------------------------- SUBROUTINE CMUMPS_PRINT_ICNTL (id, LP) USE CMUMPS_STRUC_DEF * * Purpose: * Print main control parameters CNTL and ICNTL * * ========== * Parameters * ========== TYPE (CMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP ** Local Variables INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL REAL, DIMENSION(:),POINTER::CNTL INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL CNTL=>id%CNTL IF (id%MYID.EQ.MASTER) THEN SELECT CASE (JOB) CASE(1); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ENDIF IF ((ICNTL(6).EQ.5).OR.(ICNTL(6).EQ.6).OR. & (ICNTL(12).NE.1) ) THEN WRITE (LP,992) ICNTL(8) ENDIF IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) WRITE (LP,996) ICNTL(56) CASE(2); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36), ICNTL(49) WRITE (LP,996) ICNTL(56) 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),ICNTL(26) CASE(4); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ENDIF WRITE (LP,992) ICNTL(8) IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36), ICNTL(49) WRITE (LP,996) ICNTL(56) CASE(5); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ENDIF WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21),ICNTL(26) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36), ICNTL(49) WRITE (LP,996) ICNTL(56) CASE(6); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ENDIF IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,992) ICNTL(8) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21), ICNTL(26) WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36), ICNTL(49) WRITE (LP,996) ICNTL(56) END SELECT ENDIF 980 FORMAT (/'***********CONTROL PARAMETERS (ICNTL)**************'/) 981 FORMAT ( & ' CNTL(1) Threshold for numerical pivoting =',D16.4/ & ' CNTL(3) Threshold to detect singularities =',D16.4/ & ' CNTL(4) Threshold for static pivoting =',D16.4/ & ' CNTL(5) Fixation for null pivots =',D16.4/ & ' CNTL(7) Dropping threshold for BLR compression =',D16.4) 990 FORMAT ( & 'ICNTL(1) Output stream for error messages =',I10/ & 'ICNTL(2) Output stream for diagnostic messages =',I10/ & 'ICNTL(3) Output stream for global information =',I10/ & 'ICNTL(4) Level of printing =',I10) 991 FORMAT ( & 'ICNTL(5) Matrix format =',I10/ & 'ICNTL(6) Maximum transversal =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(12) LDLT ordering strat =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(15) Analysis by block =',I10/ & 'ICNTL(18) Distributed matrix =',I10/ & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-of-core option (1=on, off otherwise)=',I10/ & 'ICNTL(48) Tree based multithreading =',I10/ & 'ICNTL(58) Symbolic factorization option =',I10) 891 FORMAT ( & 'ICNTL(5) Matrix format =',I10/ & 'ICNTL(6) Maximum transversal =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(15) Analysis by block =',I10/ & 'ICNTL(18) Distributed matrix =',I10/ & 'ICNTL(19) Schur option ( 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-of-core option (1=on, off otherwise)=',I10/ & 'ICNTL(48) Tree based multithreading =',I10/ & 'ICNTL(58) Symbolic factorization option =',I10) 992 FORMAT ( & 'ICNTL(8) Scaling strategy =',I10) 923 FORMAT ( & 'ICNTL(24) Null pivot detection (0=off) =',I10/ & 'ICNTL(31) Discard factors (0=off, else=on) =',I10/ & 'ICNTL(32) Forward elimination during facto (0=off)=',I10/ & 'ICNTL(33) Compute determinant (0=off) =',I10/ & 'ICNTL(35) Block Low Rank (BLR, 0=off >0=on) =',I10/ & 'ICNTL(36) BLR variant =',I10/ & 'ICNTL(49) Compact workarray S (end of facto.) =',I10) 993 FORMAT ( & 'ICNTL(14) Percent of memory increase =',I10) 996 FORMAT ( & 'ICNTL(56) Null space functionality =',I10) 995 FORMAT ( & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ & 'ICNTL(10) Max steps iterative refinement =',I10/ & 'ICNTL(11) Error analysis (1=all,2=some,else=off) =',I10/ & 'ICNTL(20) Den.(0)/sparse(1,2,3)/dist.(10,11) RHS =',I10/ & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10/ & 'ICNTL(26) Solution step =',I10) 998 FORMAT ( & ' Size of SCHUR matrix (SIZE_SCHUR) =',I10) END SUBROUTINE CMUMPS_PRINT_ICNTL C-------------------------------------------------------------------- SUBROUTINE CMUMPS_PRINT_KEEP(id, LP) USE CMUMPS_STRUC_DEF * * ========== * Parameters * ========== TYPE (CMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER ::LP ** Local Variables INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL, KEEP INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL KEEP=>id%KEEP IF (id%MYID.EQ.MASTER) THEN SELECT CASE (JOB) CASE(1); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6))THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) CASE(2); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (KEEP(23).EQ.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) WRITE (LP,996) KEEP(19), KEEP(118) WRITE (LP,994) KEEP(21) 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), ICNTL(26) 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), ICNTL(26) WRITE (LP,993) KEEP(12) WRITE (LP,997) KEEP(53) WRITE (LP,996) KEEP(19), KEEP(118) WRITE (LP,994) KEEP(21) 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) WRITE (LP,996) KEEP(19), KEEP(118) WRITE (LP,994) KEEP(21) 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), ICNTL(26) WRITE (LP,993) KEEP(12) WRITE (LP,997) KEEP(53) WRITE (LP,996) KEEP(19), KEEP(118) WRITE (LP,994) KEEP(21) 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-of-core option (1=on, off otherwise)=',I10) 992 FORMAT ( & 'ICNTL(8) Scaling strategy ( keep(52) ) =',I10) 993 FORMAT ( & 'ICNTL(14) Percent of memory increase ( keep(12) ) =',I10) 995 FORMAT ( & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ & 'ICNTL(10) Max steps iterative refinement =',I10/ & 'ICNTL(11) Error analysis ( 0= off, else=on) =',I10/ & 'ICNTL(20) Den.(0)/sparse(1,2,3)/dist.(10,11) RHS =',I10/ & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10/ & 'ICNTL(26) Solution step =',I10) 997 FORMAT ( & 'ICNTL(56) Null space-analysis ( keep(53) ) =',I10) 996 FORMAT ( & 'ICNTL(56) Null space-factorisation ( keep(19) ) =',I10/ & 'KEEP(118) Algorithm used for null space =',I10) 994 FORMAT ( & 'ICNTL(57) Estimate of null space size ( keep(21) )=',I10) END SUBROUTINE CMUMPS_PRINT_KEEP SUBROUTINE CMUMPS_CHECK_DENSE_RHS & (idRHS, idINFO, idN, idNRHS, idLRHS) IMPLICIT NONE C C Purpose: C ======= C C Check that the dense RHS is associated and of C correct size. Called on master only, when dense C RHS is supposed to be allocated. This can be used C either at the beginning of the solve phase or C at the beginning of the factorization phase C if forward solve is done during factorization C (see ICNTL(32)) ; idINFO(1), idINFO(2) may be C modified. C C C Arguments: C ========= C C id* : see corresponding components of the main C MUMPS structure. C COMPLEX, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) IF ( .not. associated( idRHS ) ) THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 ELSE IF (idNRHS.EQ.1) THEN IF ( size( idRHS ) < idN ) THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 ENDIF ELSE IF (idLRHS < idN) & THEN idINFO( 1 ) = -26 idINFO( 2 ) = idLRHS ELSE IF #if defined(MUMPS_NOF2003) C size with kind=8 not available. One can still C perform the check if minimal size small enough. & (int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN & .LE. int(huge(idN),8) & .and. & size(idRHS) < int(int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN)) #else & (size(idRHS,kind=8) < & int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN) #endif & THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 END IF RETURN END SUBROUTINE CMUMPS_CHECK_DENSE_RHS C SUBROUTINE CMUMPS_SET_K221(id,ATSOLVE) USE CMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C Sets KEEP(221) on master. C [Schur only] must be called before CMUMPS_CHECK_REDRHS C C Can be called at factorization C (in case of fwd in facto) or at solve phase C ATSOLVE=.TRUE. if called during solve phase C TYPE (CMUMPS_STRUC) :: id LOGICAL, INTENT(IN) :: ATSOLVE LOGICAL :: PROKG INTEGER :: MPG INTEGER MASTER PARAMETER( MASTER = 0 ) MPG = id%ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) IF (id%MYID.EQ.MASTER) THEN id%KEEP(221)=id%ICNTL(26) IF (id%KEEP(221).NE.0 .AND. id%KEEP(221) .NE.1 & .AND.id%KEEP(221).NE.2) id%KEEP(221)=0 ENDIF RETURN END SUBROUTINE CMUMPS_SET_K221 C SUBROUTINE CMUMPS_CHECK_K221andREDRHS(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C * Decode API related to REDRHS and check REDRHS C * Can be called at factorization or solve phase C * Constraints: C - Must be called after solve phase. C - KEEP(60) must have been set (ok to check C since KEEP(60) was set during analysis phase) C * Remark that during solve phase, ICNTL(26)#0 is C forbidden in case of fwd in facto. C TYPE (CMUMPS_STRUC) :: id INTEGER MASTER PARAMETER( MASTER = 0 ) C write(6,*) " Entering CMUMPS_CHECK_K221andREDRHS with : ", C & " id%JOB, id%KEEP(221), id%KEEP(60), id%SIZE_SCHUR= ", C & id%JOB, id%KEEP(221), id%KEEP(60), id%SIZE_SCHUR 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 .NE.3 ) & ) THEN id%INFO(1)=-33 id%INFO(2)=id%JOB 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) C write(6,*) " id%KEEP(60), id%SIZE_SCHUR=", C & id%KEEP(60), id%SIZE_SCHUR GOTO 333 ENDIF IF ( id%KEEP(60).NE.0 ) THEN C Schur feature IF ( 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 ENDIF 333 CONTINUE C Error is not propagated. It should be propagated outside. C The reason to propagate it outside is that there can be C one call to PROPINFO instead of several ones. RETURN END SUBROUTINE CMUMPS_CHECK_K221andREDRHS MUMPS_5.8.1/src/dfac_diag.F0000664000175000017500000000120215042446441015214 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_GETSETDIAGRETURN() C C This file contain code to access/return the C diagonal of a factorized matrix in the future. C RETURN END SUBROUTINE DMUMPS_GETSETDIAGRETURN MUMPS_5.8.1/src/dfac_mem_alloc_cb.F0000664000175000017500000001561015042446440016713 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, PROCESS_BANDE, & MYID,N, KEEP,KEEP8,DKEEP, & IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LREQ, LREQCB, NODE_ARG, STATE_ARG, SET_HEADER, & COMP, LRLUS, LRLUSM, IFLAG, IERROR ) !$ USE OMP_LIB USE MUMPS_LOAD IMPLICIT NONE INTEGER N,LIW, KEEP(500) INTEGER(8) LA, LRLU, IPTRLU, LRLUS, LRLUSM, LREQCB INTEGER(8) PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER IWPOS,IWPOSCB INTEGER(8) :: MIN_SPACE_IN_PLACE INTEGER NODE_ARG, STATE_ARG INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER IW(LIW),PTRIST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER MYID, IXXP DOUBLE PRECISION A(LA) LOGICAL INPLACE, PROCESS_BANDE, SSARBR, SET_HEADER INTEGER COMP, LREQ, IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER INODE_LOC,NPIV,NASS,NROW,NCB INTEGER ISIZEHOLE INTEGER(8) :: MEM_GAIN, RSIZEHOLE, LREQCB_EFF, LREQCB_WISHED INTEGER(8) :: DYN_SIZE, KEEP8TMPCOPY IF ( INPLACE ) THEN LREQCB_EFF = MIN_SPACE_IN_PLACE IF ( MIN_SPACE_IN_PLACE > 0_8 ) THEN LREQCB_WISHED = LREQCB ELSE LREQCB_WISHED = 0_8 ENDIF ELSE LREQCB_EFF = LREQCB LREQCB_WISHED = LREQCB ENDIF IF (IWPOSCB.EQ.LIW) THEN IF (LREQ.NE.KEEP(IXSZ).OR.LREQCB.NE.0_8 & .OR. .NOT. SET_HEADER) THEN WRITE(*,*) "Internal error in DMUMPS_ALLOC_CB ", & SET_HEADER, LREQ, LREQCB CALL MUMPS_ABORT() ENDIF IF (IWPOSCB-IWPOS+1 .LT. KEEP(IXSZ)) THEN WRITE(*,*) "Problem with integer stack size",IWPOSCB, & IWPOS, KEEP(IXSZ) IFLAG = -8 IERROR = LREQ RETURN ENDIF IWPOSCB=IWPOSCB-KEEP(IXSZ) IW(IWPOSCB+1+XXI)=KEEP(IXSZ) CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXR)) CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXD)) IW(IWPOSCB+1+XXN)=-919191 IW(IWPOSCB+1+XXS)=S_NOTFREE IW(IWPOSCB+1+XXP)=TOP_OF_STACK RETURN ENDIF CALL MUMPS_GETI8( DYN_SIZE, IW(IWPOSCB+1 + XXD)) IF (DYN_SIZE .EQ. 0_8 & .AND. KEEP(214).EQ.1.AND. & KEEP(216).EQ.1.AND. & IWPOSCB.NE.LIW) THEN IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG.OR. & IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN NCB = IW( IWPOSCB+1 + KEEP(IXSZ) ) NROW = IW( IWPOSCB+1 + KEEP(IXSZ) + 2) NPIV = IW( IWPOSCB+1 + KEEP(IXSZ) + 3) INODE_LOC= IW( IWPOSCB+1 + XXN) CALL DMUMPS_GET_SIZEHOLE(IWPOSCB+1,IW,LIW, & ISIZEHOLE,RSIZEHOLE) IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG) THEN CALL DMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, & NROW,NCB,NPIV+NCB,0, & IW(IWPOSCB+1 + XXS),RSIZEHOLE) IW(IWPOSCB+1 + XXS) =S_NOLCLEANED MEM_GAIN = int(NROW,8)*int(NPIV,8) ENDIF IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN NASS = IW( IWPOSCB+1 + KEEP(IXSZ) + 4) CALL DMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, & NROW,NCB,NPIV+NCB,NASS-NPIV, & IW(IWPOSCB+1 + XXS),RSIZEHOLE) IW(IWPOSCB+1 + XXS) =S_NOLCLEANED38 MEM_GAIN = int(NROW,8)*int(NPIV+NCB-(NASS-NPIV),8) ENDIF IF (ISIZEHOLE.NE.0) THEN CALL DMUMPS_ISHIFT( IW,LIW,IWPOSCB+1, & IWPOSCB+IW(IWPOSCB+1+XXI), & ISIZEHOLE ) IWPOSCB=IWPOSCB+ISIZEHOLE IW(IWPOSCB+1+XXP+IW(IWPOSCB+1+XXI))=IWPOSCB+1 PTRIST(STEP(INODE_LOC))=PTRIST(STEP(INODE_LOC))+ & ISIZEHOLE ENDIF CALL MUMPS_SUBTRI8TOARRAY(IW(IWPOSCB+1+XXR), MEM_GAIN) IPTRLU = IPTRLU+MEM_GAIN+RSIZEHOLE LRLU = LRLU+MEM_GAIN+RSIZEHOLE PTRAST(STEP(INODE_LOC))= & PTRAST(STEP(INODE_LOC))+MEM_GAIN+RSIZEHOLE ENDIF ENDIF IF (LRLU.LT.LREQCB_WISHED)THEN IF (LREQCB_EFF.LT.LREQCB_WISHED) THEN CALL DMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD) ENDIF ENDIF CALL DMUMPS_GET_SIZE_NEEDED & (LREQ, LREQCB_EFF, .FALSE., & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 650 IXXP=IWPOSCB+XXP+1 IF (IXXP.GT.LIW) THEN WRITE(*,*) "Internal error 3 in DMUMPS_ALLOC_CB ",IXXP ENDIF IF (IW(IXXP).GT.0) THEN WRITE(*,*) "Internal error 2 in DMUMPS_ALLOC_CB ",IW(IXXP),IXXP ENDIF IWPOSCB = IWPOSCB - LREQ IF (SET_HEADER) THEN IW(IXXP)= IWPOSCB + 1 IW(IWPOSCB+1:IWPOSCB+1+KEEP(IXSZ))=-99999 IW(IWPOSCB+1+XXI)=LREQ CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXR)) CALL MUMPS_STOREI8(0_8, IW(IWPOSCB+1+XXD)) IW(IWPOSCB+1+XXS)=STATE_ARG IW(IWPOSCB+1+XXN)=NODE_ARG IW(IWPOSCB+1+XXP)=TOP_OF_STACK IW(IWPOSCB+1+XXNBPR)=0 ENDIF IPTRLU = IPTRLU - LREQCB LRLU = LRLU - LREQCB LRLUS = LRLUS - LREQCB_EFF LRLUSM = min(LRLUS, LRLUSM) IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) + LREQCB_EFF KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + LREQCB_EFF KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC ENDIF CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) 650 CONTINUE RETURN END SUBROUTINE DMUMPS_ALLOC_CB MUMPS_5.8.1/src/ssol_bwd.F0000664000175000017500000001651115042446437015165 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SOL_S(N, A, LA, IW, LIW, W, LWC, & NRHS, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, & MYLEAF, MYROOT, ICNTL, INFO, & PROCNODE_STEPS, & SLAVEF, COMM,MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS & , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS & ) USE SMUMPS_STATIC_PTR_M, ONLY : SMUMPS_SET_STATIC_PTR, & SMUMPS_GET_TMP_PTR USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_L0OMPFAC_T IMPLICIT NONE INTEGER MTYPE INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: LWC INTEGER, intent(in) :: N,LIW,LIWW,LPOOL INTEGER, intent(in) :: SLAVEF,MYLEAF,MYROOT,COMM,MYID INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER NE_STEPS(KEEP(28)) INTEGER IPOOL(LPOOL) INTEGER LPANEL_POS INTEGER PANEL_POS(LPANEL_POS) INTEGER ICNTL(60), INFO(80) INTEGER PTRIST(KEEP(28)), & PTRICB(KEEP(28)) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER NRHS REAL A(LA), W(LWC) REAL W2(KEEP(133)) INTEGER IW(LIW),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)),DAD(KEEP(28)),FILS(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LRHSINTR, POSINRHSINTR_BWD(N) REAL RHSINTR(LRHSINTR,NRHS) INTEGER(8), intent(in) :: LRHS_ROOT REAL RHS_ROOT( LRHS_ROOT ) LOGICAL, INTENT(in) :: PRUN_BELOW INTEGER, intent(in) :: SIZE_TO_PROCESS LOGICAL, intent(in) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP INTEGER, INTENT( in ) :: LL0_OMP_MAPPING, LL0_OMP_FACTORS INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) TYPE (SMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' LOGICAL FLAG REAL, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER :: UNDERL0MAP INTEGER(8) :: POSWCB, PLEFTW INTEGER POSIWCB INTEGER NBFINF INTEGER INODE INTEGER III,IIPOOL,MYLEAF_LEFT LOGICAL BLOQ INTEGER DUMMY(1) LOGICAL :: ERROR_WAS_BROADCASTED, DO_MCAST2_TERMBWD LOGICAL :: ALLOW_OTHERS_TO_LEAVE LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: allocok DUMMY(1)=0 KEEP(266)=0 ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of DEJA_SEND in ' & //'routine SMUMPS_SOL_S ' INFO(1)=-13 INFO(2)=SLAVEF endif CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT.0 ) GOTO 340 PLEFTW = 1_8 POSIWCB = LIWW POSWCB = LWC III = 1 IIPOOL = MYROOT + 1 MYLEAF_LEFT = MYLEAF NBFINF = SLAVEF ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) ALLOW_OTHERS_TO_LEAVE = ALLOW_OTHERS_TO_LEAVE .OR. & KEEP(31) .EQ. 1 IF (ALLOW_OTHERS_TO_LEAVE) THEN CALL SMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERMBWD, & SLAVEF, KEEP) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0 .AND. MYLEAF_LEFT .EQ. 0) THEN GOTO 340 ENDIF ENDIF ERROR_WAS_BROADCASTED = .FALSE. DO_MCAST2_TERMBWD = .FALSE. DO WHILE ( NBFINF .NE. 0 .OR. MYLEAF_LEFT .NE. 0 ) IF ( SLAVEF.EQ.1 ) THEN FLAG = .FALSE. ELSE BLOQ = ( III .EQ. IIPOOL ) CALL SMUMPS_BACKSLV_RECV_AND_TREAT( BLOQ, FLAG, BUFR, LBUFR, & LBUFR_BYTES, MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD & , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO(1) .LT. 0 ) GOTO 340 ENDIF IF ( .NOT. FLAG ) THEN IF (III .NE. IIPOOL) THEN INODE = IPOOL(IIPOOL-1) IIPOOL = IIPOOL - 1 IF (KEEP(400) .GT. 0 ) THEN UNDERL0MAP = L0_OMP_MAPPING(STEP(INODE)) ELSE UNDERL0MAP = 0 ENDIF IF (UNDERL0MAP .EQ. 0 .OR. KEEP(201).GT.0) THEN CALL SMUMPS_SET_STATIC_PTR(A) CALL SMUMPS_GET_TMP_PTR(A_PTR) LA_PTR = LA ELSE A_PTR => L0_OMP_FACTORS(UNDERL0MAP)%A LA_PTR = L0_OMP_FACTORS(UNDERL0MAP)%LA ENDIF CALL SMUMPS_SOLVE_NODE_BWD( INODE, & N, IPOOL, LPOOL, IIPOOL, NBFINF, & A_PTR(1), LA_PTR, IW, LIW, W, LWC, NRHS, & POSWCB, PLEFTW, POSIWCB, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, & MYLEAF_LEFT, INFO, & PROCNODE_STEPS, DEJA_SEND, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & , DO_MCAST2_TERMBWD & ) IF ( INFO(1) .LT. 0 ) THEN IF (.NOT. ERROR_WAS_BROADCASTED) THEN IF (NBFINF .NE. 0 ) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ENDIF ENDIF IF (DO_MCAST2_TERMBWD) THEN CALL SMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & TERMBWD, SLAVEF, KEEP ) ENDIF ENDIF END IF ENDDO 340 CONTINUE IF (ALLOCATED(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE SMUMPS_SOL_S MUMPS_5.8.1/src/sana_aux_par.F0000664000175000017500000044367215042446437016026 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_PARALLEL_ANALYSIS USE SMUMPS_STRUC_DEF USE MUMPS_MEMORY_MOD USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T, COMPACT_GRAPH_T INCLUDE 'mpif.h' PUBLIC SMUMPS_ANA_F_PAR INTERFACE SMUMPS_ANA_F_PAR MODULE PROCEDURE SMUMPS_ANA_F_PAR END INTERFACE PRIVATE TYPE ORD_TYPE INTEGER :: CBLKNBR, N INTEGER, POINTER :: PERMTAB(:) => null() INTEGER, POINTER :: PERITAB(:) => null() INTEGER, POINTER :: RANGTAB(:) => null() INTEGER, POINTER :: TREETAB(:) => null() INTEGER, POINTER :: BROTHER(:) => null() INTEGER, POINTER :: SON(:) => null() INTEGER, POINTER :: NW(:) => null() INTEGER, POINTER :: FIRST(:) => null() INTEGER, POINTER :: LAST(:) => null() INTEGER, POINTER :: TOPNODES(:) => null() INTEGER :: COMM, NPROCS, MYID, & COMM_PARAORD, NPROCS_PARAORD, MYID_PARAORD, & RKinSYMB_PROC0ORD INTEGER :: TOPSTRAT, SUBSTRAT, ORDTOOL, TOPVARS LOGICAL :: IDO END TYPE ORD_TYPE TYPE GRAPH_TYPE INTEGER(8) :: NZ_LOC INTEGER, POINTER :: IRN_LOC(:) => null() INTEGER, POINTER :: JCN_LOC(:) => null() END TYPE GRAPH_TYPE TYPE ARRPNT INTEGER, POINTER :: BUF(:) => null() END TYPE ARRPNT INTEGER :: MP, MPG, LP, NRL, TOPROWS INTEGER(8) :: MEMCNT, MAXMEM LOGICAL :: PROK, PROKG, LPOK INTEGER N, NORIG CONTAINS SUBROUTINE SMUMPS_ANA_F_PAR(id, WORK1, WORK2, LWORK1, LWORK2, & NFSIZ, FILS, & FRERE, COMM_PARASYMB, LUMAT, SIZEOFBLOCKS, & COMM_PARAORD, NPROCS_PARAORD, & RKinSYMB_PROC0ORD) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id INTEGER, TARGET :: WORK1(:), WORK2(:) INTEGER(8), INTENT(IN) :: LWORK1, LWORK2 #if defined(MUMPS_NOF2003) INTEGER, POINTER :: FILS(:) #else INTEGER, ALLOCATABLE :: FILS(:) #endif INTEGER, POINTER :: NFSIZ(:), FRERE(:) INTEGER, INTENT(IN) :: COMM_PARASYMB TYPE(LMATRIX_T), OPTIONAL :: LUMAT INTEGER, INTENT(IN), TARGET, OPTIONAL :: SIZEOFBLOCKS(id%NBLK) INTEGER, INTENT(IN), OPTIONAL :: COMM_PARAORD, & NPROCS_PARAORD, & RKinSYMB_PROC0ORD 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 DOUBLE PRECISION :: TIMEB INTEGER HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & NBSONS_Scalapack_CAND INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR INTEGER, TARGET :: IDUMMY_ARRAY(1) INTEGER :: LSIZEOFBLOCKS_PTR LOGICAL :: SIZEOFBLOCKS_AVAIL nullify(IPE, NV, NE, NA, NODE, ND, SUBORD, NAMALG, IPS, & CUMUL, SAVEIRN, SAVEJCN) CALL MPI_COMM_RANK (COMM_PARASYMB, MYID, IERR) CALL MPI_COMM_SIZE (COMM_PARASYMB, NPROCS, IERR) NORIG = id%N IF (id%KEEP(339).NE.0) THEN N = id%NBLK ELSE N = NORIG ENDIF ord%N = N LP = id%ICNTL(1) MP = id%ICNTL(2) MPG = id%ICNTL(3) PROK = (MP.GT.0) PROKG = (MPG.GT.0) .AND. (MYID .EQ. 0) LPOK = (LP.GT.0) .AND. (id%ICNTL(4).GE.1) LDIAG = id%ICNTL(4) IF (present(SIZEOFBLOCKS)) THEN SIZEOFBLOCKS_PTR => SIZEOFBLOCKS(1:N) LSIZEOFBLOCKS_PTR = N SIZEOFBLOCKS_AVAIL = .TRUE. ELSE SIZEOFBLOCKS_PTR => IDUMMY_ARRAY SIZEOFBLOCKS_AVAIL = .FALSE. LSIZEOFBLOCKS_PTR = 1 IDUMMY_ARRAY(1) = -1 ENDIF IF (PROKG) THEN WRITE(MPG,'(A,I10)') & " Parallel analysis, processing a graph of size:", N ENDIF IF (id%KEEP(339).GT.0) THEN IF (.NOT.present(LUMAT) .OR. .NOT. present(SIZEOFBLOCKS)) THEN IF (PROK) THEN WRITE(MP,*) MYID, " Internal error in SMUMPS_ANA_F_PAR" ENDIF id%INFO(1) = -9991 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM_PARASYMB, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN ENDIF IF (id%KEEP(339).GT.0) THEN MEMCNT = MEMCNT + LUMAT%NZL + LUMAT%NBCOL_LOC + 3 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ENDIF CALL SMUMPS_SET_PAR_ORD(id, COMM_PARASYMB, MYID, NPROCS, & ord, COMM_PARAORD, NPROCS_PARAORD, & RKinSYMB_PROC0ORD) IF ( LWORK1 .LT. 3_8 *int(N,8) ) THEN WRITE(LP,*) & 'Insufficient workspace in SMUMPS_ANA_F_PAR' CALL MUMPS_ABORT() ENDIF IF ( ord%COMM .NE. MPI_COMM_NULL ) THEN ord%PERMTAB => WORK1( 1 : N) ord%PERITAB => WORK1( int(N,8)+1_8 : 2_8*int(N,8)) ord%TREETAB => WORK1(2_8*int(N,8)+1_8 : 3_8*int(N,8)) ENDIF IF ( id%KEEP(54) .NE. 3 ) THEN IF(MYID.EQ.0) THEN SAVEIRN => id%IRN_loc SAVEJCN => id%JCN_loc id%IRN_loc => id%IRN id%JCN_loc => id%JCN id%KEEP8(29) = id%KEEP8(28) ELSE id%KEEP8(29)=0_8 END IF END IF MAXMEM=0 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT id%INFOG(7) = id%KEEP(245) IF (PROKG) CALL MUMPS_SECDEB( TIMEB ) IF (id%KEEP(339).GT.0) THEN CALL SMUMPS_DO_PAR_ORD(id, MYID, NPROCS, & ord, WORK2, LWORK2, LUMAT, SIZEOFBLOCKS) ELSE CALL SMUMPS_DO_PAR_ORD(id, MYID, NPROCS, & ord, WORK2, LWORK2) ENDIF IF (PROKG) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE(MPG, & '(" ELAPSED time in parallel ordering =",F12.4)') & TIMEB ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF(ord%MYID .EQ. 0) THEN CALL MUMPS_REALLOC(IPE, N, id%INFO, LP, FORCE=.FALSE., & COPY=.FALSE., STRING='', & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, N, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT END IF ord%SUBSTRAT = 0 ord%TOPSTRAT = 0 IF (id%KEEP(339).NE.0) THEN CALL SMUMPS_PARSYMFACT_LUMAT(id, ord, IPE, NV, & WORK2, LWORK2, LUMAT, & SIZEOFBLOCKS) ELSE CALL SMUMPS_PARSYMFACT(id, ord, IPE, NV, WORK2, LWORK2) ENDIF IF(id%KEEP(54) .NE. 3) THEN IF(ord%MYID.EQ.0) THEN id%IRN_loc => SAVEIRN id%JCN_loc => SAVEJCN END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN NULLIFY(ord%PERMTAB) NULLIFY(ord%PERITAB) NULLIFY(ord%TREETAB) CALL MUMPS_IDEALLOC(ord%FIRST, ord%LAST, MEMCNT=MEMCNT) IF (MYID .EQ. 0) THEN IPS => WORK1(1:N) NE => WORK1( int(N,8)+1_8 : 2_8*int(N,8)) NA => WORK1(2_8*int(N,8)+1_8 : 3_8*int(N,8)) NODE => WORK2( 1 : N ) ND => WORK2( int(N,8)+1_8 : 2_8*int(N,8)) SUBORD => WORK2(2_8*int(N,8)+1_8 : 3_8*int(N,8)) NAMALG => WORK2(3_8*int(N,8)+1_8 : 4_8*int(N,8)) CALL MUMPS_REALLOC(CUMUL, N, id%INFO, LP, & STRING='CUMUL', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT NEMIN = id%KEEP(1) CALL SMUMPS_ANA_LNEW(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%KEEP(197), & id%NSLAVES, id%KEEP(250).EQ.1, SIZEOFBLOCKS_AVAIL, & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, & INODE_Scalapack_CAND, NBSONS_Scalapack_CAND, & id%KEEP(11), id%KEEP(191), id%KEEP(192), id%KEEP(193)) CALL MUMPS_DEALLOC(CUMUL, NV, IPE, MEMCNT=MEMCNT) CALL SMUMPS_ANA_M(NE(1), ND(1), id%INFOG(6), id%INFOG(5), & id%KEEP(2), id%KEEP(50), id%KEEP8(101), id%KEEP(108), & id%KEEP(5), id%KEEP(6), id%KEEP(226), id%KEEP(253)) IF ( id%KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT(N, FRERE(1), FILS(1), NFSIZ(1), & id%KEEP(20)) INODE_Scalapack_CAND = id%KEEP(20) NBSONS_Scalapack_CAND = 1 END IF IF ( (id%KEEP(48) == 4 .AND. id%KEEP8(21).GT.0_8) & .OR. & (id%KEEP (48)==5 .AND. id%KEEP8(21) .GT. 0_8 ) & .OR. & (id%KEEP(24).NE.0.AND.id%KEEP8(21).GT.0_8) ) THEN CALL SMUMPS_SET_K821_SURFACE(id%KEEP8(21), id%KEEP(2), & id%KEEP(48), id%KEEP(50), id%NSLAVES) END IF IF (id%KEEP(210).LT.1.OR.id%KEEP(210).GT.2) id%KEEP(210)=2 IF (id%KEEP(210).EQ.2) id%KEEP8(79)=huge(id%KEEP8(79)) IF (id%KEEP(210).EQ.1.AND.id%KEEP8(79).LE.0_8) THEN id%KEEP8(79)=K79REF * int(id%NSLAVES,8) ENDIF IF (id%KEEP(11).EQ.0) THEN IF ( (id%KEEP(79).EQ.0).OR.(id%KEEP(79).EQ.2).OR. & (id%KEEP(79).EQ.3).OR.(id%KEEP(79).EQ.5).OR. & (id%KEEP(79).EQ.6) & ) THEN IF (id%KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( id%KEEP(62).GE.1) THEN CALL SMUMPS_CUTNODES(N, FRERE(1), FILS(1), & NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, 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 ENDIF HOW_TO_SPLIT_ROOT = 0 SPLITROOT = id%ICNTL(13) .EQ. -1 #if defined(NOSCALAPACK) SPLITROOT = SPLITROOT .OR. id%NSLAVES.GT.0 #else SPLITROOT = SPLITROOT .OR. & (id%ICNTL(13).GT.0 .AND. id%NSLAVES.GT.id%ICNTL(13)) #endif IF (SPLITROOT.AND.id%KEEP(11).GT.0) HOW_TO_SPLIT_ROOT =1 IF (id%KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. IF (id%KEEP(11).GT.0) HOW_TO_SPLIT_ROOT = 2 ENDIF #if defined(NOSCALAPACK) #else IF ( id%KEEP(11).GT.0 .AND. (id%KEEP(339).NE.0) ) THEN IF (.NOT.SPLITROOT .AND. & (id%KEEP(60).EQ.0).AND. & ( (NFSIZ(INODE_Scalapack_CAND).GT.id%KEEP(37)) & .AND.(id%ICNTL(13).LE.0) ) & .AND. & (NBSONS_Scalapack_CAND.GT.id%KEEP(11)) & ) THEN HOW_TO_SPLIT_ROOT = 3 SPLITROOT=.TRUE. ENDIF ENDIF #endif SPLITROOT = (SPLITROOT.AND.( (id%KEEP(60).EQ.0) )) IF (SPLITROOT) THEN IF (id%KEEP(339).EQ.0) THEN CALL SMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, id%INFOG(6), & id%NSLAVES, id%KEEP(1), id%KEEP8(1), & SPLITROOT, MP, LDIAG, id%INFOG(1), id%INFOG(2)) ELSE IF (id%KEEP(11).EQ.0) THEN CALL SMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, 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 IF ( id%KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT(N, FRERE(1), FILS(1), NFSIZ(1), & id%KEEP(20)) END IF ELSE CALL SMUMPS_SPLIT_ROOT( id%NSLAVES, & HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & N, FRERE(1), FILS(1), NFSIZ(1), & id%KEEP(1), id%KEEP8(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, & id%INFOG(6)) END IF END IF ENDIF END IF RETURN END SUBROUTINE SMUMPS_ANA_F_PAR SUBROUTINE SMUMPS_SET_PAR_ORD(id, COMM_PARASYMB, MYID, NPROCS, & ord, & COMM_PARAORD, NPROCS_PARAORD, RKinSYMB_PROC0ORD) TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, INTENT(IN) :: COMM_PARASYMB, MYID, NPROCS INTEGER, INTENT(IN), OPTIONAL :: COMM_PARAORD, NPROCS_PARAORD, & RKinSYMB_PROC0ORD INTEGER :: IERR #if defined(parmetis) || defined(parmetis3) INTEGER :: I INTEGER :: COLOR, BASE, WORKERS LOGICAL :: IDO #endif IF (id%KEEP(339).GT.0) THEN ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%COMM = COMM_PARASYMB ord%MYID = MYID ord%NPROCS = NPROCS ord%COMM_PARAORD = COMM_PARAORD ord%RKinSYMB_PROC0ORD = RKinSYMB_PROC0ORD ord%NPROCS_PARAORD = NPROCS_PARAORD ord%IDO = (COMM_PARAORD.NE.MPI_COMM_NULL) IF (ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ELSE ord%MYID_PARAORD = -1 ENDIF IF (id%KEEP(245) .EQ. 1) THEN #if defined(ptscotch) ord%ORDTOOL = 1 IF(PROKG) WRITE(MPG, & '(" Using PT-SCOTCH for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(ord%MYID .EQ.0 ) WRITE(LP, & '(" PT-SCOTCH not available")') RETURN #endif ELSE IF (id%KEEP(245) .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) ord%ORDTOOL = 2 IF(PROKG) WRITE(MPG, & '(" Using ParMETIS for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(ord%MYID .EQ.0 ) WRITE(LP, & '(" ParMETIS not available.")') RETURN #endif END IF ELSE ord%NPROCS = NPROCS ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%COMM = COMM_PARASYMB ord%MYID = MYID ord%RKinSYMB_PROC0ORD = NPROCS-id%NSLAVES 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%COMM_PARAORD = id%COMM_NODES ord%NPROCS_PARAORD = id%NSLAVES ord%IDO = (ord%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1) IF (ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ELSE ord%MYID_PARAORD = -1 ENDIF IF(PROKG) WRITE(MPG, & '(" Using PT-SCOTCH for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(ord%MYID .EQ.0 ) WRITE(LP, & '(" PT-SCOTCH not available")') RETURN #endif ELSE IF (id%KEEP(245) .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) BASE = ord%NPROCS-id%NSLAVES IF(N.LE.100) THEN WORKERS = 2 ELSE WORKERS = min(id%NSLAVES,N/16) END IF I=1 DO IF (I .GT. WORKERS) EXIT ord%NPROCS_PARAORD = I I = I*2 END DO IDO = (ord%MYID .GE. BASE) .AND. & (ord%MYID .LE. BASE+ord%NPROCS_PARAORD-1) ord%IDO = IDO IF ( IDO ) THEN COLOR = 1 ELSE COLOR = MPI_UNDEFINED END IF CALL MPI_COMM_SPLIT( COMM_PARASYMB, COLOR, 0, ord%COMM_PARAORD, & IERR ) IF (ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ELSE ord%MYID_PARAORD = -1 ENDIF ord%ORDTOOL = 2 IF(PROKG) WRITE(MPG, & '(" Using ParMETIS for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(ord%MYID .EQ.0 ) WRITE(LP, & '(" ParMETIS not available.")') RETURN #endif END IF ENDIF END SUBROUTINE SMUMPS_SET_PAR_ORD SUBROUTINE SMUMPS_DO_PAR_ORD(id, MYID, NPROCS, ord, & WORK, LWORK, LUMAT, & SIZEOFBLOCKS) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id INTEGER, INTENT(IN) :: MYID, NPROCS TYPE(ORD_TYPE) :: ord INTEGER :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK TYPE(LMATRIX_T), OPTIONAL :: LUMAT INTEGER, INTENT(IN), OPTIONAL :: SIZEOFBLOCKS(N) #if defined(parmetis) || defined(parmetis3) INTEGER :: IERR #endif TYPE(COMPACT_GRAPH_T) :: GCOMP_DIST IF (id%KEEP(339).NE.0) THEN CALL MUMPS_AB_LMAT_TO_CLEAN_G ( ord%MYID, & .FALSE., & .FALSE., & LUMAT, GCOMP_DIST, id%INFO, id%ICNTL & , MEMCNT & ) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ENDIF IF (ord%ORDTOOL .EQ. 1) THEN #if defined(ptscotch) IF (id%KEEP(339).NE.0) THEN CALL SMUMPS_PTSCOTCH_ORD(id, ord, WORK, LWORK, & GCOMP_DIST, & SIZEOFBLOCKS ) ELSE CALL SMUMPS_PTSCOTCH_ORD(id, ord, WORK, LWORK) ENDIF #else id%INFOG(1) = -38 id%INFO(1) = -38 WRITE(LP,*)'PT-SCOTCH not available. Aborting...' CALL MUMPS_ABORT() #endif ELSE IF (ord%ORDTOOL .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) IF (id%KEEP(339).GT.0) THEN CALL SMUMPS_PARMETIS_ORD_LUMAT (id, ord, WORK, LWORK, & GCOMP_DIST, & SIZEOFBLOCKS) ELSE CALL SMUMPS_PARMETIS_ORD(id, ord, WORK, LWORK) ENDIF IF (id%KEEP(339).EQ.0) THEN if(ord%IDO) CALL MPI_COMM_FREE(ord%COMM_PARAORD, IERR) ENDIF #else id%INFOG(1) = -38 id%INFO(1) = -38 WRITE(LP,*)'ParMETIS not available. Aborting...' CALL MUMPS_ABORT() #endif END IF IF (id%KEEP(339).NE.0) THEN CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST, MEMCNT) ENDIF RETURN END SUBROUTINE SMUMPS_DO_PAR_ORD #if defined(parmetis) || defined(parmetis3) SUBROUTINE SMUMPS_PARMETIS_ORD(id, ord, WORK, LWORK) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT (IN) :: LWORK INTEGER :: I, MYID, NPROCS, IERR, BASE, METIS_IDX_SIZE INTEGER, POINTER :: FIRST(:), LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & OPTIONS(10) INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:), RCVCNTS(:) INTEGER(8) :: EDGELOCNBR INTEGER, POINTER :: SIZES(:), ORDER(:) INTEGER, POINTER :: IDUMMY_PTR(:) INTEGER :: SIZE_IDUMMY_PTR nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB, RCVCNTS, & SIZES, ORDER, IDUMMY_PTR) MYID = ord%MYID NPROCS = ord%NPROCS IERR = 0 SIZE_IDUMMY_PTR = 0 IF( LWORK.LT. int(N,8)*3_8 .OR. LWORK .LT. int(NPROCS+1,8)) THEN WRITE(LP, & '("Insufficient workspace inside SMUMPS_PARMETIS_ORD")') CALL MUMPS_ABORT() END IF BASEVAL = 1 CALL MUMPS_REALLOC(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT BASE = id%NPROCS-id%NSLAVES CALL SMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK(1_8: 2_8*int(N,8)), & 2_8*int(N,8), TYPE=2) VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 CALL MUMPS_I8REALLOC(VERTLOCTAB, VERTLOCNBR+1, id%INFO, & LP, STRING='VERTLOCTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT SWORK => WORK(int(N+1,8):3_8*int(N,8)) CALL SMUMPS_BUILD_DIST_GRAPH(id, ord, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK, 2_8 * int(N,8)) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF(id%INFO(1).LT.0) GOTO 20 EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1_8 OPTIONS(:) = 0 ORDER => WORK(1:N) CALL MUMPS_REALLOC(SIZES, 2*ord%NPROCS_PARAORD, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IF(ord%IDO) THEN CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 1 ELSE CALL MUMPS_PARMETIS_MIXEDto32(id, & BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & IDUMMY_PTR, SIZE_IDUMMY_PTR, & SIZES, ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ENDIF ELSE IF (METIS_IDX_SIZE.EQ.64) THEN CALL MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & IDUMMY_PTR, SIZE_IDUMMY_PTR, & SIZES, ord%COMM_PARAORD, ord%MYID_PARAORD, IERR) ELSE WRITE(*,*) & "Internal error in PARMETIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() END IF END IF IF (id%KEEP(339).NE.0) THEN nullify(VERTLOCTAB, EDGELOCTAB) ELSE CALL MUMPS_IDEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(VERTLOCTAB) ENDIF IF(IERR.GT.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 20 CALL MPI_BCAST(SIZES(1), 2*ord%NPROCS_PARAORD, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) ord%CBLKNBR = 2*ord%NPROCS_PARAORD-1 CALL MUMPS_REALLOC(RCVCNTS, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, id%NPROCS RCVCNTS(I) = max(LAST(I)-FIRST(I)+1,0) END DO FIRST = FIRST-1 IF(FIRST(1) .LT. 0) THEN FIRST(1) = 0 END IF CALL MPI_ALLGATHERV ( ORDER(1), VERTLOCNBR, MPI_INTEGER, & ord%PERMTAB(1), & RCVCNTS(1), FIRST(1), MPI_INTEGER, ord%COMM, IERR ) DO I=1, N ord%PERITAB(ord%PERMTAB(I)) = I END DO CALL MUMPS_REALLOC(ord%RANGTAB, 2*ord%NPROCS_PARAORD, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL SMUMPS_BUILD_TREETAB(ord%TREETAB, ord%RANGTAB, & SIZES, ord%CBLKNBR) CALL MUMPS_DEALLOC(SIZES, FIRST, LAST, & RCVCNTS, MEMCNT=MEMCNT) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL SMUMPS_BUILD_TREE(ord) RETURN 20 CONTINUE CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(SIZES , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) RETURN END SUBROUTINE SMUMPS_PARMETIS_ORD SUBROUTINE SMUMPS_PARMETIS_ORD_LUMAT (id, ord, WORK, LWORK, & GCOMP_DIST, & SIZEOFBLOCKS ) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK TYPE(COMPACT_GRAPH_T), OPTIONAL :: GCOMP_DIST INTEGER, INTENT(IN), OPTIONAL, TARGET :: SIZEOFBLOCKS(N) INTEGER :: I, MYID, NPROCS, IERR, BASE, METIS_IDX_SIZE INTEGER :: MASTER PARAMETER (MASTER=0) INTEGER, POINTER :: FIRST(:), LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & OPTIONS(10) INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:), RCVCNTS(:) INTEGER(8) :: EDGELOCNBR INTEGER, POINTER :: SIZES(:), ORDER(:) INTEGER, POINTER :: VELOLOCTAB(:) INTEGER :: SIZE_VELOLOCTAB INTEGER, TARGET :: IDUMMY(1) nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB, RCVCNTS, & SIZES, ORDER ) VELOLOCTAB => IDUMMY MYID = ord%MYID NPROCS = ord%NPROCS IERR = 0 SIZE_VELOLOCTAB = 0 IF( LWORK.LT. int(N,8)*3_8 .OR. LWORK .LT. int(NPROCS+1,8)) THEN WRITE(LP, & '("Insufficient workspace inside SMUMPS_PARMETIS_ORD")') CALL MUMPS_ABORT() END IF IF(ord%IDO) THEN CALL MUMPS_REALLOC(FIRST, ord%NPROCS_PARAORD+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, ord%NPROCS_PARAORD+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_REALLOC(SIZES, 2*ord%NPROCS_PARAORD, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 20 IF(ord%IDO) THEN CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) VERTLOCNBR = GCOMP_DIST%LAST-GCOMP_DIST%FIRST+1 EDGELOCNBR = GCOMP_DIST%NZG VERTLOCTAB => GCOMP_DIST%IPE EDGELOCTAB => GCOMP_DIST%ADJ IF (id%KEEP(339).NE.0) THEN VELOLOCTAB=>SIZEOFBLOCKS(GCOMP_DIST%FIRST:GCOMP_DIST%LAST) SIZE_VELOLOCTAB = VERTLOCNBR ENDIF DO I=1,ord%NPROCS_PARAORD+1 FIRST(I) = -99 LAST(I) = -99 ENDDO BASE = 0 #if defined(AVOID_MPI_IN_PLACE) CALL MPI_ALLGATHER( GCOMP_DIST%FIRST, 1, MPI_INTEGER, & FIRST, 1, MPI_INTEGER, ord%COMM_PARAORD, IERR ) CALL MPI_ALLGATHER( GCOMP_DIST%LAST, 1, MPI_INTEGER, & LAST, 1, MPI_INTEGER, ord%COMM_PARAORD, IERR ) #else FIRST(ord%MYID_PARAORD + 1)= GCOMP_DIST%FIRST LAST (ord%MYID_PARAORD + 1)= GCOMP_DIST%LAST CALL MPI_ALLREDUCE(MPI_IN_PLACE, FIRST(1), & ord%NPROCS_PARAORD+1, & MPI_INTEGER, MPI_MAX, ord%COMM_PARAORD, IERR) CALL MPI_ALLREDUCE(MPI_IN_PLACE, LAST(1), & ord%NPROCS_PARAORD+1, & MPI_INTEGER, MPI_MAX, ord%COMM_PARAORD, IERR) #endif DO I=1, ord%NPROCS_PARAORD+1 IF (FIRST(I).EQ.-99) THEN FIRST(I) = GCOMP_DIST%NG+1 ENDIF IF (LAST(I).EQ.-99) THEN LAST (I) = GCOMP_DIST%NG ENDIF ENDDO OPTIONS(:) = 0 ORDER => WORK(1:N) BASEVAL = 1 IF (METIS_IDX_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 1 ELSE CALL MUMPS_PARMETIS_MIXEDto32(id, & BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & VELOLOCTAB, SIZE_VELOLOCTAB, & SIZES, ord%COMM_PARAORD, ord%MYID_PARAORD, & IERR) ENDIF ELSE IF (METIS_IDX_SIZE.EQ.64) THEN CALL MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & VELOLOCTAB, SIZE_VELOLOCTAB, & SIZES, ord%COMM_PARAORD, ord%MYID_PARAORD, & IERR) ELSE WRITE(*,*) & "Internal error in PARMETIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() END IF END IF nullify(VERTLOCTAB, EDGELOCTAB) IF(IERR.GT.0) THEN id%INFO(1:2) = -50 END IF ord%CBLKNBR = 2*ord%NPROCS_PARAORD-1 CALL MUMPS_REALLOC(ord%RANGTAB, ord%CBLKNBR+1, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_REALLOC(RCVCNTS, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 20 IF (ord%IDO) THEN DO I=1, ord%NPROCS_PARAORD 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_GATHERV ( ORDER(1), VERTLOCNBR, MPI_INTEGER, & ord%PERMTAB(1), & RCVCNTS(1), FIRST(1), MPI_INTEGER, MASTER, & ord%COMM_PARAORD, IERR ) END IF IF (ord%MYID_PARAORD.EQ.MASTER) THEN DO I=1, N ord%PERITAB(ord%PERMTAB(I)) = I END DO CALL MUMPS_REALLOC(ord%TREETAB, ord%CBLKNBR, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL SMUMPS_BUILD_TREETAB(ord%TREETAB, ord%RANGTAB, & SIZES, ord%CBLKNBR) ENDIF CALL MUMPS_DEALLOC(SIZES, FIRST, LAST, & RCVCNTS, MEMCNT=MEMCNT) CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%PERMTAB(1), N, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%PERITAB(1), N, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%RANGTAB(1), ord%CBLKNBR+1, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%TREETAB(1), ord%CBLKNBR, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL SMUMPS_BUILD_TREE(ord) RETURN 20 CONTINUE CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(SIZES , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) RETURN END SUBROUTINE SMUMPS_PARMETIS_ORD_LUMAT #endif #if defined(ptscotch) SUBROUTINE SMUMPS_PTSCOTCH_ORD(id, ord, WORK, LWORK, GCOMP_DIST, & SIZEOFBLOCKS) !$ USE OMP_LIB IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK TYPE(COMPACT_GRAPH_T), OPTIONAL :: GCOMP_DIST INTEGER, INTENT(IN), OPTIONAL, TARGET:: SIZEOFBLOCKS(N) INTEGER :: MYID, NPROCS, IERR INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & BASE, SCOTCH_INT_SIZE INTEGER(8) :: EDGELOCNBR INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:) INTEGER, POINTER :: VELOLOCTAB(:) INTEGER :: SIZE_VELOLOCTAB INTEGER, TARGET :: IDUMMY(1) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) INCLUDE 'scotchf.h' INTEGER :: IOMP, NOMP DOUBLE PRECISION :: CONTDAT(SCOTCH_CONTEXTDIM) INTEGER(4) :: IERR_SCOTCH #else INTEGER :: PTHREAD_NUMBER, NOMP #endif nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB) VELOLOCTAB => IDUMMY CALL MPI_BARRIER(ord%COMM, IERR) MYID = ord%MYID NPROCS = ord%NPROCS SIZE_VELOLOCTAB = 0 BASEVAL = 1 IF (id%KEEP(339).NE.0) THEN VERTLOCNBR = GCOMP_DIST%LAST-GCOMP_DIST%FIRST+1 EDGELOCNBR = GCOMP_DIST%NZG VERTLOCTAB => GCOMP_DIST%IPE EDGELOCTAB => GCOMP_DIST%ADJ IF (id%KEEP(339).NE.0) THEN VELOLOCTAB => SIZEOFBLOCKS(GCOMP_DIST%FIRST:GCOMP_DIST%LAST) SIZE_VELOLOCTAB = VERTLOCNBR ENDIF ELSE IF (LWORK .LT. int(N,8)*3_8) THEN WRITE(LP, & '("Insufficient workspace inside SMUMPS_PTSCOTCH_ORD")') CALL MUMPS_ABORT() END IF BASE = id%NPROCS-id%NSLAVES CALL MUMPS_REALLOC(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL SMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK(1: 2_8*int(N,8)), & 2_8*int(N,8), TYPE=2) VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 CALL MUMPS_I8REALLOC(VERTLOCTAB, VERTLOCNBR+1, id%INFO, & LP, STRING='VERTLOCTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT SWORK => WORK(int(N+1,8):3_8*int(N,8)) CALL SMUMPS_BUILD_DIST_GRAPH(id, ord, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK, 2_8*int(N,8)) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 11 EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1_8 ENDIF CALL MUMPS_REALLOC(ord%PERMTAB, N, id%INFO, & LP, STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%PERITAB, N, id%INFO, & LP, STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%RANGTAB, N+1, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%TREETAB, N, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IF(ord%IDO) THEN CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) !$OMP PARALLEL PRIVATE(IOMP, IERR_SCOTCH) !$OMP SINGLE NOMP=omp_get_num_threads() !$OMP END SINGLE IOMP=omp_get_thread_num() IF (IOMP.EQ.0) THEN CALL SCOTCHFCONTEXTINIT(CONTDAT, IERR_SCOTCH) CALL SCOTCHFCONTEXTRANDOMCLONE(CONTDAT, IERR_SCOTCH) CALL SCOTCHFCONTEXTTHREADIMPORT1(CONTDAT, NOMP, IERR_SCOTCH) ENDIF !$OMP BARRIER CALL SCOTCHFCONTEXTTHREADIMPORT2(CONTDAT, IOMP, IERR_SCOTCH) #else NOMP=0 !$ NOMP=omp_get_max_threads() IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_GET_PTHREAD_NUMBER (PTHREAD_NUMBER) CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (NOMP) ENDIF #endif #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) IF (IOMP.EQ.0) THEN #endif IF(SCOTCH_INT_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 2 ELSE CALL MUMPS_PTSCOTCH_MIXEDto32(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & VELOLOCTAB, SIZE_VELOLOCTAB, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, SCOTCH_CONTEXTDIM, #endif & IERR) ENDIF ELSE CALL MUMPS_PTSCOTCH_MIXEDto64(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & VELOLOCTAB, SIZE_VELOLOCTAB, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, SCOTCH_CONTEXTDIM, #endif & IERR) END IF #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL SCOTCHFCONTEXTEXIT(CONTDAT) ENDIF !$OMP END PARALLEL #else IF (NOMP .GT. 0) THEN CALL MUMPS_SCOTCH_SET_PTHREAD_NUMBER (PTHREAD_NUMBER) ENDIF #endif END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 11 CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%PERMTAB(1), N, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%PERITAB(1), N, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%RANGTAB(1), ord%CBLKNBR+1, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MPI_BCAST (ord%TREETAB(1), ord%CBLKNBR, MPI_INTEGER, & ord%RKinSYMB_PROC0ORD, ord%COMM, IERR) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) CALL SMUMPS_BUILD_TREE(ord) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ord%N = N IF (id%KEEP(339).NE.0) THEN nullify(VERTLOCTAB, EDGELOCTAB) ELSE CALL MUMPS_DEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(VERTLOCTAB, MEMCNT=MEMCNT) ENDIF RETURN 11 CONTINUE IF (id%KEEP(339).NE.0) THEN CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(VERTLOCTAB, MEMCNT=MEMCNT) ELSE CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) nullify(VERTLOCTAB, EDGELOCTAB) ENDIF RETURN END SUBROUTINE SMUMPS_PTSCOTCH_ORD #endif FUNCTION SMUMPS_STOP_DESCENT(id, ord, NACTIVE, ANODE, RPROC, & ALIST, LIST, PEAKMEM, NNODES, CHECKMEM) IMPLICIT NONE LOGICAL :: SMUMPS_STOP_DESCENT INTEGER :: NACTIVE, RPROC, ANODE, PEAKMEM, NNODES INTEGER :: ALIST(NNODES), LIST(NNODES) TYPE(ORD_TYPE) :: ord TYPE(SMUMPS_STRUC) :: id LOGICAL, OPTIONAL :: CHECKMEM INTEGER :: IPEAKMEM, BIG, MAX_NROWS, MIN_NROWS INTEGER :: TOPROWS, NRL, HOSTMEM, SUBMEM INTEGER :: I, NZ_ROW, WEIGHT LOGICAL :: ICHECKMEM INTEGER :: NZ4 IF(present(CHECKMEM)) THEN ICHECKMEM = CHECKMEM ELSE ICHECKMEM = .FALSE. END IF SMUMPS_STOP_DESCENT = .FALSE. IF(NACTIVE .GE. RPROC) THEN SMUMPS_STOP_DESCENT = .TRUE. RETURN END IF IF(NACTIVE .EQ. 0) THEN SMUMPS_STOP_DESCENT = .TRUE. RETURN END IF IF(.NOT. ICHECKMEM) RETURN BIG = ALIST(NACTIVE) IF(NACTIVE .GT. 1) THEN MAX_NROWS = ord%NW(ALIST(NACTIVE-1)) MIN_NROWS = ord%NW(ALIST(1)) ELSE MAX_NROWS = 0 MIN_NROWS = 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 *N HOSTMEM = 12*N NZ4=int(id%KEEP8(28)) NZ_ROW = 2*(NZ4/N) IF (id%KEEP(339).NE.0) THEN NRL = 0 ELSE IF(id%KEEP(46) .EQ. 0) THEN NRL = 0 ELSE NRL = MIN_NROWS END IF ENDIF HOSTMEM = HOSTMEM + 2*TOPROWS*NZ_ROW HOSTMEM = HOSTMEM +NRL HOSTMEM = HOSTMEM + max(NRL,TOPROWS)*(NZ_ROW+2) HOSTMEM = HOSTMEM + 6*max(NRL,TOPROWS) HOSTMEM = HOSTMEM + 3*TOPROWS NRL = MAX_NROWS SUBMEM = SUBMEM +NRL SUBMEM = SUBMEM + NRL*(NZ_ROW+2) SUBMEM = SUBMEM + 6*NRL IPEAKMEM = max(HOSTMEM, SUBMEM) IF((IPEAKMEM .GT. PEAKMEM) .AND. & (PEAKMEM .NE. 0)) THEN SMUMPS_STOP_DESCENT = .TRUE. RETURN ELSE SMUMPS_STOP_DESCENT = .FALSE. PEAKMEM = IPEAKMEM RETURN END IF END FUNCTION SMUMPS_STOP_DESCENT FUNCTION SMUMPS_CNT_KIDS(NODE, ord) IMPLICIT NONE INTEGER :: SMUMPS_CNT_KIDS INTEGER :: NODE TYPE(ORD_TYPE) :: ord INTEGER :: CURR SMUMPS_CNT_KIDS = 0 IF(ord%SON(NODE) .EQ. -1) THEN RETURN ELSE SMUMPS_CNT_KIDS = 1 CURR = ord%SON(NODE) DO IF(ord%BROTHER(CURR) .NE. -1) THEN SMUMPS_CNT_KIDS = SMUMPS_CNT_KIDS+1 CURR = ord%BROTHER(CURR) ELSE EXIT END IF END DO END IF RETURN END FUNCTION SMUMPS_CNT_KIDS SUBROUTINE SMUMPS_GET_SUBTREES(ord, id) USE MUMPS_TOOLS_COMMON_M, ONLY : MUMPS_MERGESORT, & MUMPS_MERGESWAP IMPLICIT NONE TYPE(ORD_TYPE) :: ord TYPE(SMUMPS_STRUC) :: id INTEGER, ALLOCATABLE :: ALIST(:), AWEIGHTS(:), LIST(:), WORK(:) INTEGER :: NNODES, BIG, CURR, ND, NACTIVE, RPROC, ANODE, BASE, I, & NK, PEAKMEM, allocok, Iprocdeb LOGICAL :: SD NNODES = ord%NPROCS_PARAORD CALL MUMPS_REALLOC(ord%TOPNODES, 2*max(NNODES,2), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%FIRST, ord%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%LAST, ord%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(ALIST(NNODES), AWEIGHTS(NNODES), LIST(NNODES), & WORK(0:NNODES+1), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=4*NNODES+2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 NACTIVE = 0 DO I=1, ord%CBLKNBR IF (ord%TREETAB(I).EQ.-1) THEN NACTIVE = NACTIVE+1 IF(NACTIVE.LE.NNODES) THEN ALIST(NACTIVE) = I AWEIGHTS(NACTIVE) = ord%NW(I) END IF END IF END DO IF((ord%CBLKNBR .EQ. 1) .OR. & (NACTIVE.GT.NNODES) .OR. & ( NNODES .LT. SMUMPS_CNT_KIDS(ord%CBLKNBR, ord) )) THEN ord%TOPNODES =0 ord%TOPNODES(1) = 1 ord%TOPNODES(2) = ord%RANGTAB(ord%CBLKNBR+1) - ord%RANGTAB(1) ord%TOPNODES(3) = ord%RANGTAB(1) ord%TOPNODES(4) = ord%RANGTAB(ord%CBLKNBR+1)-1 ord%FIRST = 0 ord%LAST = -1 RETURN END IF CALL MUMPS_MERGESORT(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL MUMPS_MERGESWAP(NACTIVE, WORK(0:NACTIVE+1), & AWEIGHTS(1:NACTIVE), & ALIST(1:NACTIVE)) RPROC = NNODES ANODE = 0 PEAKMEM = 0 ord%TOPNODES = 0 DO IF(NACTIVE .EQ. 0) EXIT BIG = ALIST(NACTIVE) NK = SMUMPS_CNT_KIDS(BIG, ord) IF((NK .GT. (RPROC-NACTIVE+1)) .OR. (NK .EQ. 0)) THEN ANODE = ANODE+1 LIST(ANODE) = BIG NACTIVE = NACTIVE-1 RPROC = RPROC-1 CYCLE END IF SD = SMUMPS_STOP_DESCENT(id, ord, NACTIVE, ANODE, & RPROC, ALIST, LIST, PEAKMEM, NNODES, CHECKMEM=.TRUE.) IF ( SD ) & THEN IF(NACTIVE.GT.0) THEN LIST(ANODE+1:ANODE+NACTIVE) = ALIST(1:NACTIVE) ANODE = ANODE+NACTIVE END IF EXIT END IF ord%TOPNODES(1) = ord%TOPNODES(1)+1 ord%TOPNODES(2) = ord%TOPNODES(2) + & ord%RANGTAB(BIG+1) - ord%RANGTAB(BIG) ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+1) = ord%RANGTAB(BIG) ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+2) = & ord%RANGTAB(BIG+1)-1 CURR = ord%SON(BIG) ALIST(NACTIVE) = CURR AWEIGHTS(NACTIVE) = ord%NW(CURR) DO IF(ord%BROTHER(CURR) .EQ. -1) EXIT NACTIVE = NACTIVE+1 CURR = ord%BROTHER(CURR) ALIST(NACTIVE) = CURR AWEIGHTS(NACTIVE) = ord%NW(CURR) END DO CALL MUMPS_MERGESORT(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL MUMPS_MERGESWAP(NACTIVE, WORK(0:NACTIVE+1), & AWEIGHTS(1:NACTIVE), & ALIST(1:NACTIVE)) END DO DO I=1, ANODE AWEIGHTS(I) = ord%NW(LIST(I)) END DO CALL MUMPS_MERGESORT(ANODE, AWEIGHTS(1:ANODE), WORK(0:ANODE+1)) CALL MUMPS_MERGESWAP(ANODE, WORK(0:ANODE+1), AWEIGHTS(1:ANODE), & ALIST(1:ANODE)) IF (id%KEEP(339).NE.0) THEN Iprocdeb = ord%NPROCS-ANODE+1 IF (Iprocdeb.GT.1) THEN DO I=1, Iprocdeb-1 ord%FIRST(I) = 0 ord%LAST(I) = -1 ENDDO ENDIF 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(Iprocdeb) = ord%RANGTAB(ND) ord%LAST(Iprocdeb) = ord%RANGTAB(CURR+1)-1 Iprocdeb = Iprocdeb +1 ENDDO ELSE 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) = N+1 ord%LAST(BASE+I) = N END DO ENDIF DEALLOCATE(LIST, ALIST, AWEIGHTS, WORK) 90 continue RETURN END SUBROUTINE SMUMPS_GET_SUBTREES SUBROUTINE SMUMPS_PARSYMFACT(id, ord, GPE, GNV, WORK, LWORK) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: GPE(:), GNV(:) INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:), IPET(:), & BUF_PE1(:), BUF_PE2(:), TMP1(:) INTEGER, POINTER :: PE(:), LENG(:), I_HALO_MAP(:) INTEGER, POINTER :: NDENSE(:), LAST(:), & DEGREE(:), W(:), PERM(:), & LISTVAR_SCHUR(:), NEXT(:), & HEAD(:), NV(:), ELEN(:), & LSTVAR(:) INTEGER, POINTER :: MYLIST(:), LPERM(:), LIPERM(:), & NVT(:), BUF_NV1(:), & BUF_NV2(:), ROOTPERM(:), & TMP2(:), BWORK(:), NCLIQUES(:) INTEGER :: MYNCLIQUES, MYMAXVARS, ICLIQUES, & TOTNCLIQUES INTEGER(8) :: MYNVARS, TOTNVARS INTEGER(8), POINTER :: LVARPT(:) INTEGER :: HIDX, TOTEL, & NCMPA, I, J, SIZE_SCHUR, MYID, & NPROCS, IERR, NROWS_LOC, GLOB_IDX, TMP, & NTVAR, TGSIZE, MAXS, RHANDPE, & RHANDNV, RIDX, PROC, JOB, K INTEGER(8) :: PFREES, PFS_SAVE, PELEN, PFREET, PFT_SAVE INTEGER :: STATUSPE(MPI_STATUS_SIZE) INTEGER :: STATUSNV(MPI_STATUS_SIZE) INTEGER :: STATUSCLIQUES(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30 LOGICAL :: AGG6 INTEGER :: THRESH nullify(PE, IPE, LENG, I_HALO_MAP, NCLIQUES) nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, & NEXT, HEAD, NV, ELEN, LSTVAR) nullify(MYLIST, LVARPT, & LPERM, LIPERM, IPET, NVT, BUF_PE1, BUF_PE2, & BUF_NV1, BUF_NV2, ROOTPERM, TMP1, TMP2, BWORK) MYID = ord%MYID NPROCS = ord%NPROCS IF(LWORK .LT. 4_8*int(N,8)) THEN WRITE(LP,*)'Insufficient workspace in SMUMPS_PARSYMFACT' CALL MUMPS_ABORT() ELSE HEAD => WORK( 1 : N ) ELEN => WORK( int(N,8)+1 : 2_8*int(N,8) ) LENG => WORK( 2_8*int(N,8)+1 : 3_8*int(N,8) ) PERM => WORK( 3_8*int(N,8)+1 : 4_8*int(N,8) ) END IF CALL SMUMPS_GET_SUBTREES(ord, id) CALL MUMPS_IDEALLOC(ord%SON, ord%BROTHER, ord%NW, & ord%RANGTAB, MEMCNT=MEMCNT) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 NRL = NROWS_LOC TOPROWS = ord%TOPNODES(2) BWORK => WORK(1_8 : 2_8*int(N,8)) CALL SMUMPS_BUILD_LOC_GRAPH(id, ord, HIDX, IPE, PE, LENG, & I_HALO_MAP, top_graph, BWORK, 2_8*int(N,8)) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF(id%INFO(1).lt.0) RETURN TMP = N DO I=1, NPROCS TMP = TMP-(ord%LAST(I)-ord%FIRST(I)+1) END DO TMP = ceiling(real(TMP)*1.10E0) IF(MYID .EQ. 0) THEN TMP = max(max(TMP, HIDX),1) ELSE TMP = max(HIDX,1) END IF SIZE_SCHUR = HIDX - NROWS_LOC CALL MUMPS_REALLOC(NDENSE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, SIZE_SCHUR LISTVAR_SCHUR(I) = NROWS_LOC+I END DO THRESH = -1 AGG6 = .FALSE. PFREES = IPE(NROWS_LOC+1) PFS_SAVE = PFREES PELEN = PFREES-1 + 2_8*int(NROWS_LOC+ord%TOPNODES(2),8) DO I=1, HIDX PERM(I) = I END DO IF(SIZE_SCHUR.EQ.0) THEN JOB = 0 ELSE JOB = 1 END IF IF(HIDX .GT.0) THEN TOTEL = HIDX NV(1) = -1 CALL MUMPS_SYMQAMD_NEW(JOB, THRESH, NDENSE(1), HIDX, & TOTEL, PELEN, IPE(1), PFREES, LENG(1), PE(1), NV(1), & ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), NEXT(1), & W(1), PERM(1), LISTVAR_SCHUR(1), SIZE_SCHUR, AGG6) ENDIF MYNCLIQUES = 0 MYNVARS = 0 MYMAXVARS = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN MYMAXVARS = MAX(MYMAXVARS,LENG(I)) MYNVARS = MYNVARS+LENG(I) MYNCLIQUES = MYNCLIQUES+1 END IF END DO CALL MPI_REDUCE(MYNVARS, TOTNVARS, 1, MPI_INTEGER8, & MPI_SUM, 0, ord%COMM, IERR) CALL MUMPS_REALLOC(NCLIQUES, NPROCS, id%INFO, & LP, STRING='NCLIQUES', MEMCNT=MEMCNT, ERRCODE=-7) CALL MPI_GATHER(MYNCLIQUES, 1, MPI_INTEGER, NCLIQUES(1), 1, & MPI_INTEGER, 0, ord%COMM, IERR) IF(ord%MYID.EQ.0) THEN TOTNCLIQUES = sum(NCLIQUES) CALL MUMPS_I8REALLOC(LVARPT, TOTNCLIQUES+1, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(LSTVAR, TOTNVARS, id%INFO, & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) LVARPT(1) = 1_8 ICLIQUES = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN ICLIQUES = ICLIQUES+1 LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+LENG(I) DO J=0, LENG(I)-1 LSTVAR(LVARPT(ICLIQUES)+J) = & I_HALO_MAP(PE(IPE(I)+J)-NROWS_LOC) END DO END IF END DO DO PROC=1, NPROCS-1 DO I=1, NCLIQUES(PROC+1) ICLIQUES = ICLIQUES+1 CALL MPI_RECV(K, 1, MPI_INTEGER, PROC, ITAG, ord%COMM, & STATUSCLIQUES, IERR) LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+K CALL MPI_RECV(LSTVAR(LVARPT(ICLIQUES)), K, MPI_INTEGER, & PROC, ITAG, ord%COMM, STATUSCLIQUES, IERR) END DO END DO LPERM => WORK(3_8*int(N,8)+1_8 : 4_8*int(N,8)) NTVAR = ord%TOPNODES(2) CALL SMUMPS_MAKE_LOC_IDX(id, ord%TOPNODES, LPERM, LIPERM, ord) CALL SMUMPS_ASSEMBLE_TOP_GRAPH(id, ord%TOPNODES(2), LPERM, & top_graph, TOTNCLIQUES, LSTVAR, LVARPT, IPET, PE, & LENG, ELEN) TGSIZE = ord%TOPNODES(2)+TOTNCLIQUES PFREET = IPET(TGSIZE+1) PFT_SAVE = PFREET nullify(LPERM) ELSE CALL MUMPS_REALLOC(MYLIST, MYMAXVARS, id%INFO, & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, HIDX IF(IPE(I) .GT. 0) THEN DO J=1, LENG(I) MYLIST(J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) END DO CALL MPI_SEND(LENG(I), 1, MPI_INTEGER, 0, ITAG, & ord%COMM, IERR) CALL MPI_SEND(MYLIST(1), LENG(I), MPI_INTEGER, 0, ITAG, & ord%COMM, IERR) END IF END DO END IF CALL MUMPS_IDEALLOC(top_graph%IRN_LOC, & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN CALL MUMPS_IREALLOC8(PE, max(PFREET+int(TGSIZE,8),1_8),id%INFO, & LP, COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, & ERRCODE=-7) CALL MUMPS_REALLOC(NDENSE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NVT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, max(TGSIZE,1), id%INFO, LP, & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, max(TGSIZE,1), id%INFO, LP, & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(TOTNCLIQUES,1), id%INFO, & LP, STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TOTNCLIQUES LISTVAR_SCHUR(I) = NTVAR+I END DO THRESH = -1 CALL MUMPS_REALLOC(HEAD, max(TGSIZE,1), id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(PERM, max(TGSIZE,1), id%INFO, & LP, COPY=.TRUE., STRING='J2:PERM', & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TGSIZE PERM(I) = I END DO PELEN = max(PFREET+int(TGSIZE,8),1_8) IF(TGSIZE.GT.0) THEN TOTEL = TGSIZE NVT(1) = -1 CALL MUMPS_SYMQAMD_NEW(2, -1, NDENSE(1), TGSIZE, & TOTEL, PELEN, IPET(1), PFREET, LENG(1), PE(1), & NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), & NEXT(1), W(1), PERM(1), LISTVAR_SCHUR(1), TOTNCLIQUES, & AGG6) ENDIF END IF CALL MPI_BARRIER(ord%COMM, IERR) CALL MPI_BARRIER(ord%COMM, IERR) CALL MUMPS_DEALLOC(LISTVAR_SCHUR, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN MAXS = NROWS_LOC DO I=2, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) & MAXS = (ord%LAST(I)-ord%FIRST(I)+1) END DO CALL MUMPS_I8REALLOC(BUF_PE1, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(BUF_PE2, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV1, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV2, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GPE, N, id%INFO, & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GNV, N, id%INFO, & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ROOTPERM, TOTNCLIQUES, id%INFO, & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RIDX = 0 TMP1 => BUF_PE1 TMP2 => BUF_NV1 NULLIFY(BUF_PE1, BUF_NV1) BUF_PE1 => IPE BUF_NV1 => NV DO PROC=0, NPROCS-2 CALL MPI_IRECV(BUF_PE2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER8, PROC+1, PROC+1, & ord%COMM, RHANDPE, IERR) CALL MPI_IRECV(BUF_NV2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER, PROC+1, PROC+1, & ord%COMM, RHANDNV, IERR) DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO CALL MPI_WAIT(RHANDPE, STATUSPE, IERR) CALL MPI_WAIT(RHANDNV, STATUSNV, IERR) IF(PROC .NE. 0) THEN TMP1 => BUF_PE1 TMP2 => BUF_NV1 END IF BUF_PE1 => BUF_PE2 BUF_NV1 => BUF_NV2 NULLIFY(BUF_PE2, BUF_NV2) BUF_PE2 => TMP1 BUF_NV2 => TMP2 NULLIFY(TMP1, TMP2) END DO DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO DO I=1, NTVAR GLOB_IDX = LIPERM(I) IF(IPET(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = NVT(I) ELSE GPE(GLOB_IDX) = -LIPERM(-IPET(I)) GNV(GLOB_IDX) = NVT(I) END IF END DO DO I=1, TOTNCLIQUES GLOB_IDX = ROOTPERM(I) GPE(GLOB_IDX) = -LIPERM(-IPET(NTVAR+I)) END DO ELSE CALL MPI_SEND(IPE(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER8, 0, MYID, ord%COMM, IERR) CALL MPI_SEND(NV(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER, 0, MYID, ord%COMM, IERR) END IF CALL MUMPS_DEALLOC(BUF_NV1, BUF_NV2, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(BUF_PE1, BUF_PE2, IPE, IPET, & TMP1, LVARPT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, I_HALO_MAP, NDENSE, & LAST, DEGREE, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(W, LISTVAR_SCHUR, NEXT, & NV, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LSTVAR, NCLIQUES, MYLIST, & MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LPERM, LIPERM, NVT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ROOTPERM, TMP2, MEMCNT=MEMCNT) NULLIFY(HEAD, ELEN, LENG, PERM) RETURN END SUBROUTINE SMUMPS_PARSYMFACT SUBROUTINE SMUMPS_PARSYMFACT_LUMAT(id, ord, GPE, GNV, WORK, LWORK, & LUMAT, SIZEOFBLOCKS) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: GPE(:), GNV(:) INTEGER, TARGET :: WORK(:) TYPE(LMATRIX_T), INTENT(IN) :: LUMAT INTEGER, INTENT(IN) :: SIZEOFBLOCKS(id%NBLK) TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:), IPET(:), & BUF_PE1(:), BUF_PE2(:), TMP1(:) INTEGER, POINTER :: PE(:), & LENG(:), I_HALO_MAP(:) INTEGER, POINTER :: NDENSE(:), LAST(:), & DEGREE(:), W(:), PERM(:), & LISTVAR_SCHUR(:), NEXT(:), & HEAD(:), NV(:), ELEN(:), & LSTVAR(:) INTEGER, POINTER :: MYLIST(:), & LPERM(:), & LIPERM(:), & NVT(:), BUF_NV1(:), & BUF_NV2(:), ROOTPERM(:), & TMP2(:), BWORK(:), NCLIQUES(:), MAPTAB(:) INTEGER :: MYNCLIQUES, MYMAXVARS, ICLIQUES, & TOTNCLIQUES INTEGER(8) :: MYNVARS, TOTNVARS, LWORK INTEGER(8), POINTER :: LVARPT(:) INTEGER :: HIDX, TOTEL, & NCMPA, I, J, SIZE_SCHUR, MYID, & NPROCS, IERR, NROWS_LOC, GLOB_IDX, TMP, & NTVAR, TGSIZE, MAXS, RHANDPE, & RHANDNV, RIDX, PROC, JOB, K INTEGER(8) :: PFREES, PFS_SAVE, PELEN, PFREET, PFT_SAVE INTEGER :: STATUSPE(MPI_STATUS_SIZE) INTEGER :: STATUSNV(MPI_STATUS_SIZE) INTEGER :: STATUSCLIQUES(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30 LOGICAL :: AGG6 INTEGER :: THRESH nullify(PE, IPE, LENG, I_HALO_MAP, NCLIQUES) nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, & NEXT, HEAD, NV, ELEN, LSTVAR) nullify(MYLIST, LVARPT, MAPTAB, & LPERM, LIPERM, IPET, NVT, BUF_PE1, BUF_PE2, & BUF_NV1, BUF_NV2, ROOTPERM, TMP1, TMP2, BWORK, MAPTAB) MYID = ord%MYID NPROCS = ord%NPROCS IF( LWORK .LT. 4_8*int(N,8) ) THEN WRITE(LP,*) & 'Insufficient workspace in SMUMPS_PARSYMFACT_LUMAT' CALL MUMPS_ABORT() ENDIF HEAD => WORK( 1 : N ) ELEN => WORK( int(N,8)+1_8 : 2_8*int(N,8) ) LENG => WORK( 2_8*int(N,8)+1_8 : 3_8*int(N,8) ) PERM => WORK( 3_8*int(N,8)+1_8 : 4_8*int(N,8) ) CALL SMUMPS_GET_SUBTREES(ord, id) CALL MUMPS_IDEALLOC(ord%SON, ord%BROTHER, ord%NW, & ord%RANGTAB, MEMCNT=MEMCNT) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 NRL = NROWS_LOC TOPROWS = ord%TOPNODES(2) BWORK => WORK(1_8 : 2_8*int(N,8)) CALL SMUMPS_LUMAT_TO_LOC_GRAPH( & LUMAT, id, ord, HIDX, IPE, PE, LENG, & I_HALO_MAP, BWORK, 2_8*int(N,8)) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID ) IF(id%INFO(1).lt.0) RETURN TMP = N DO I=1, NPROCS TMP = TMP-(ord%LAST(I)-ord%FIRST(I)+1) END DO TMP = ceiling(real(TMP)*1.10E0) IF(MYID .EQ. 0) THEN TMP = max(max(TMP, HIDX),1) ELSE TMP = max(HIDX,1) END IF SIZE_SCHUR = HIDX - NROWS_LOC CALL MUMPS_REALLOC(NDENSE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, SIZE_SCHUR LISTVAR_SCHUR(I) = NROWS_LOC+I END DO THRESH = -1 AGG6 = .FALSE. PFREES = IPE(NROWS_LOC+1) PFS_SAVE = PFREES PELEN = PFREES-1 + 2_8*int(NROWS_LOC+ord%TOPNODES(2),8) DO I=1, HIDX PERM(I) = I END DO IF(SIZE_SCHUR.EQ.0) THEN JOB = 0 ELSE JOB = 1 END IF IF(HIDX .GT.0) THEN NV(1) = -1 TOTEL = HIDX IF ((N.LT.NORIG).OR.(id%KEEP(339).NE.0)) THEN TOTEL = 0 DO I=1,NROWS_LOC NV(I) = SIZEOFBLOCKS ( & ord%PERITAB(ord%FIRST(MYID+1)+I-1) & ) TOTEL = TOTEL + NV(I) ENDDO DO I=NROWS_LOC+1, HIDX NV(I) = SIZEOFBLOCKS (I_HALO_MAP(I-NROWS_LOC)) TOTEL = TOTEL + NV(I) ENDDO ENDIF CALL MUMPS_SYMQAMD_NEW(JOB, THRESH, NDENSE(1), HIDX, & TOTEL, PELEN, IPE(1), PFREES, LENG(1), PE(1), NV(1), & ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), NEXT(1), & W(1), PERM(1), LISTVAR_SCHUR(1), SIZE_SCHUR, AGG6) ENDIF MYNCLIQUES = 0 MYNVARS = 0 MYMAXVARS = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN MYMAXVARS = MAX(MYMAXVARS,LENG(I)) MYNVARS = MYNVARS+LENG(I) MYNCLIQUES = MYNCLIQUES+1 END IF END DO CALL MPI_REDUCE(MYNVARS, TOTNVARS, 1, MPI_INTEGER8, & MPI_SUM, 0, ord%COMM, IERR) CALL MUMPS_REALLOC(NCLIQUES, NPROCS, id%INFO, & LP, STRING='NCLIQUES', MEMCNT=MEMCNT, ERRCODE=-7) CALL MPI_GATHER(MYNCLIQUES, 1, MPI_INTEGER, NCLIQUES(1), 1, & MPI_INTEGER, 0, ord%COMM, IERR) IF(ord%MYID.EQ.0) THEN TOTNCLIQUES = sum(NCLIQUES) CALL MUMPS_I8REALLOC(LVARPT, TOTNCLIQUES+1, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(LSTVAR, TOTNVARS, id%INFO, & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) LVARPT(1) = 1_8 ICLIQUES = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN ICLIQUES = ICLIQUES+1 LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+LENG(I) DO J=0, LENG(I)-1 LSTVAR(LVARPT(ICLIQUES)+J) = & I_HALO_MAP(PE(IPE(I)+J)-NROWS_LOC) END DO END IF END DO DO PROC=1, NPROCS-1 DO I=1, NCLIQUES(PROC+1) ICLIQUES = ICLIQUES+1 CALL MPI_RECV(K, 1, MPI_INTEGER, PROC, ITAG, ord%COMM, & STATUSCLIQUES, IERR) LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+K CALL MPI_RECV(LSTVAR(LVARPT(ICLIQUES)), K, MPI_INTEGER, & PROC, ITAG, ord%COMM, STATUSCLIQUES, IERR) END DO END DO ELSE CALL MUMPS_REALLOC(MYLIST, MYMAXVARS, id%INFO, & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, HIDX IF(IPE(I) .GT. 0) THEN DO J=1, LENG(I) MYLIST(J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) END DO CALL MPI_SEND(LENG(I), 1, MPI_INTEGER, 0, ITAG, & ord%COMM, IERR) CALL MPI_SEND(MYLIST(1), LENG(I), MPI_INTEGER, 0, ITAG, & ord%COMM, IERR) END IF END DO END IF CALL MUMPS_DEALLOC(PE, MEMCNT=MEMCNT) IF (id%KEEP(339).NE.0) THEN MAPTAB => WORK(1:N) CALL MUMPS_BUILD_TOP_GRAPH (LUMAT, id, ord, top_graph, MAPTAB) ENDIF IF (MYID.EQ.0) THEN LPERM => WORK( 3_8*int(N,8)+1_8 : 4_8*int(N,8) ) NTVAR = ord%TOPNODES(2) CALL SMUMPS_MAKE_LOC_IDX(id, ord%TOPNODES, LPERM, LIPERM, ord) CALL SMUMPS_ASSEMBLE_TOP_GRAPH(id, ord%TOPNODES(2), LPERM, & top_graph, TOTNCLIQUES, LSTVAR, LVARPT, IPET, PE, & LENG, ELEN) TGSIZE = ord%TOPNODES(2)+TOTNCLIQUES PFREET = IPET(TGSIZE+1) PFT_SAVE = PFREET nullify(LPERM) ENDIF CALL MUMPS_IDEALLOC(top_graph%IRN_LOC, & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN CALL MUMPS_IREALLOC8(PE, max(PFREET+int(TGSIZE,8),1_8),id%INFO, & LP, COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, & ERRCODE=-7) CALL MUMPS_REALLOC(NDENSE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NVT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, max(TGSIZE,1), id%INFO, LP, & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, max(TGSIZE,1), id%INFO, LP, & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(TOTNCLIQUES,1), id%INFO, & LP, STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TOTNCLIQUES LISTVAR_SCHUR(I) = NTVAR+I END DO THRESH = -1 CALL MUMPS_REALLOC(HEAD, max(TGSIZE,1), id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(PERM, max(TGSIZE,1), id%INFO, & LP, COPY=.TRUE., STRING='J2:PERM', & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TGSIZE PERM(I) = I END DO PELEN = max(PFREET+int(TGSIZE,8),1_8) IF(TGSIZE.GT.0) THEN NVT(1) = -1 TOTEL = TGSIZE IF ((N.LT.NORIG).OR.(id%KEEP(339).NE.0)) THEN TOTEL = TOTNCLIQUES DO I=1,NTVAR NVT(I) = SIZEOFBLOCKS( LIPERM(I) ) TOTEL = TOTEL + NVT(I) ENDDO ENDIF CALL MUMPS_SYMQAMD_NEW(2, -1, NDENSE(1), & TGSIZE, TOTEL, PELEN, IPET(1), PFREET, LENG(1), PE(1), & NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), & NEXT(1), W(1), PERM(1), LISTVAR_SCHUR(1), TOTNCLIQUES, & AGG6) ENDIF CALL MUMPS_DEALLOC(PE, MEMCNT=MEMCNT) END IF CALL MPI_BARRIER(ord%COMM, IERR) CALL MPI_BARRIER(ord%COMM, IERR) CALL MUMPS_DEALLOC(LISTVAR_SCHUR, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN MAXS = NROWS_LOC DO I=2, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) & MAXS = (ord%LAST(I)-ord%FIRST(I)+1) END DO CALL MUMPS_I8REALLOC(BUF_PE1, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(BUF_PE2, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV1, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV2, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GPE, N, id%INFO, & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GNV, N, id%INFO, & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ROOTPERM, TOTNCLIQUES, id%INFO, & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RIDX = 0 TMP1 => BUF_PE1 TMP2 => BUF_NV1 NULLIFY(BUF_PE1, BUF_NV1) BUF_PE1 => IPE BUF_NV1 => NV DO PROC=0, NPROCS-2 CALL MPI_IRECV(BUF_PE2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER8, PROC+1, PROC+1, & ord%COMM, RHANDPE, IERR) CALL MPI_IRECV(BUF_NV2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER, PROC+1, PROC+1, & ord%COMM, RHANDNV, IERR) DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO CALL MPI_WAIT(RHANDPE, STATUSPE, IERR) CALL MPI_WAIT(RHANDNV, STATUSNV, IERR) IF(PROC .NE. 0) THEN TMP1 => BUF_PE1 TMP2 => BUF_NV1 END IF BUF_PE1 => BUF_PE2 BUF_NV1 => BUF_NV2 NULLIFY(BUF_PE2, BUF_NV2) BUF_PE2 => TMP1 BUF_NV2 => TMP2 NULLIFY(TMP1, TMP2) END DO DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO DO I=1, NTVAR GLOB_IDX = LIPERM(I) IF(IPET(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = NVT(I) ELSE GPE(GLOB_IDX) = -LIPERM(-IPET(I)) GNV(GLOB_IDX) = NVT(I) END IF END DO DO I=1, TOTNCLIQUES GLOB_IDX = ROOTPERM(I) GPE(GLOB_IDX) = -LIPERM(-IPET(NTVAR+I)) END DO ELSE CALL MPI_SEND(IPE(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER8, 0, MYID, ord%COMM, IERR) CALL MPI_SEND(NV(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER, 0, MYID, ord%COMM, IERR) END IF CALL MUMPS_DEALLOC(BUF_NV1, BUF_NV2, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(BUF_PE1, BUF_PE2, IPE, IPET, & TMP1, LVARPT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, I_HALO_MAP, NDENSE, & LAST, DEGREE, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(W, LISTVAR_SCHUR, NEXT, & NV, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LSTVAR, NCLIQUES, MYLIST, & MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LPERM, LIPERM, NVT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ROOTPERM, TMP2, MEMCNT=MEMCNT) NULLIFY(HEAD, ELEN, LENG, PERM, BWORK, MAPTAB, LPERM) RETURN END SUBROUTINE SMUMPS_PARSYMFACT_LUMAT SUBROUTINE SMUMPS_MAKE_LOC_IDX(id, TOPNODES, LPERM, LIPERM, ord) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id INTEGER, POINTER :: TOPNODES(:), LPERM(:), LIPERM(:) TYPE(ORD_TYPE) :: ord INTEGER :: I, J, K, GIDX CALL MUMPS_REALLOC(LPERM , ord%N, id%INFO, & LP, STRING='LIDX:LPERM', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LIPERM, TOPNODES(2), id%INFO, & LP, STRING='LIDX:LIPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LPERM = 0 K = 1 DO I=TOPNODES(1), 1, -1 DO J=TOPNODES(2*I+1), TOPNODES(2*I+2) GIDX = ord%PERITAB(J) LPERM(GIDX) = K LIPERM(K) = GIDX K = K+1 END DO END DO RETURN END SUBROUTINE SMUMPS_MAKE_LOC_IDX SUBROUTINE SMUMPS_ASSEMBLE_TOP_GRAPH(id, NLOCVARS, LPERM, & top_graph, NCLIQUES, LSTVAR, LVARPT, IPE, PE, LENG, ELEN) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(GRAPH_TYPE) :: top_graph INTEGER, POINTER :: LPERM(:), LSTVAR(:), & PE(:), LENG(:), ELEN(:) INTEGER(8) :: LVARPT(:) INTEGER :: NCLIQUES INTEGER(8), POINTER :: IPE(:) INTEGER :: I, IDX, NLOCVARS INTEGER(8) :: INNZ, PNT, SAVEPNT CALL MUMPS_REALLOC(LENG, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:LENG', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ELEN, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:ELEN', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(IPE , NLOCVARS+NCLIQUES+1, id%INFO, & LP, STRING='ATG:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG = 0 ELEN = 0 DO INNZ=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(INNZ)) .NE. 0) .AND. & (top_graph%JCN_LOC(INNZ) .NE. top_graph%IRN_LOC(INNZ))) & THEN LENG(LPERM(top_graph%IRN_LOC(INNZ))) = & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1 END IF END DO DO I=1, NCLIQUES DO INNZ=LVARPT(I), LVARPT(I+1)-1 ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 END DO END DO IPE(1) = 1 DO I=1, NLOCVARS+NCLIQUES IPE(I+1) = IPE(I)+int(LENG(I),8)+int(ELEN(I),8) END DO CALL MUMPS_IREALLOC8(PE, IPE(NLOCVARS+NCLIQUES+1)+ & int(NLOCVARS,8)+int(NCLIQUES,8), & id%INFO, LP, STRING='ATG:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG = 0 ELEN = 0 DO I=1, NCLIQUES DO INNZ=LVARPT(I), LVARPT(I+1)-1 IDX = LPERM(LSTVAR(INNZ)) PE(IPE(IDX)+int(ELEN(IDX),8)) = NLOCVARS+I PE(IPE(NLOCVARS+I)+int(LENG(NLOCVARS+I),8)) = IDX ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 end do end do DO INNZ=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(INNZ)) .NE. 0) .AND. & (top_graph%JCN_LOC(INNZ) .NE. top_graph%IRN_LOC(INNZ))) & THEN PE(IPE(LPERM(top_graph%IRN_LOC(INNZ)))+ & ELEN(LPERM(top_graph%IRN_LOC(INNZ))) + & LENG(LPERM(top_graph%IRN_LOC(INNZ)))) = & LPERM(top_graph%JCN_LOC(INNZ)) LENG(LPERM(top_graph%IRN_LOC(INNZ))) = & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1 END IF END DO DO I=1, NLOCVARS+NCLIQUES LENG(I) = LENG(I)+ELEN(I) END DO SAVEPNT = 1 PNT = 0 LPERM(1:NLOCVARS+NCLIQUES) = 0 DO I=1, NLOCVARS+NCLIQUES DO INNZ=IPE(I), IPE(I+1)-1 IF(LPERM(PE(INNZ)) .EQ. I) THEN LENG(I) = LENG(I)-1 ELSE LPERM(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NLOCVARS+NCLIQUES+1) = SAVEPNT RETURN END SUBROUTINE SMUMPS_ASSEMBLE_TOP_GRAPH #if defined(parmetis) || defined(parmetis3) SUBROUTINE SMUMPS_BUILD_TREETAB(TREETAB, RANGTAB, SIZES, CBLKNBR) INTEGER, POINTER :: TREETAB(:), RANGTAB(:), SIZES(:) INTEGER :: CBLKNBR,allocok INTEGER :: LCHILD, RCHILD, K, I INTEGER, POINTER :: PERM(:) ALLOCATE(PERM(CBLKNBR),stat=allocok) if(allocok.GT.0) then write(*,*) "Allocation error of PERM in SMUMPS_BUILD_TREETAB" return endif TREETAB(CBLKNBR) = -1 IF(CBLKNBR .EQ. 1) THEN DEALLOCATE(PERM) TREETAB(1) = -1 RANGTAB(1) = 1 RANGTAB(2)= SIZES(1)+1 RETURN END IF LCHILD = CBLKNBR - (CBLKNBR+1)/2 RCHILD = CBLKNBR-1 K = 1 PERM(CBLKNBR) = CBLKNBR PERM(LCHILD) = CBLKNBR+1 - (2*K+1) PERM(RCHILD) = CBLKNBR+1 - (2*K) TREETAB(RCHILD) = CBLKNBR TREETAB(LCHILD) = CBLKNBR IF(CBLKNBR .GT. 3) THEN CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, & LCHILD, CBLKNBR, 2*K+1) CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, & RCHILD, CBLKNBR, 2*K) END IF RANGTAB(1)=1 DO I=1, CBLKNBR RANGTAB(I+1) = RANGTAB(I)+SIZES(PERM(I)) END DO DEALLOCATE(PERM) RETURN CONTAINS RECURSIVE SUBROUTINE REC_TREETAB(TREETAB, PERM, SUBNODES, & ROOTN, CBLKNBR, K) INTEGER, POINTER :: TREETAB(:), PERM(:) INTEGER :: SUBNODES, ROOTN, K, CBLKNBR INTEGER :: LCHILD, RCHILD LCHILD = ROOTN - (SUBNODES+1)/2 RCHILD = ROOTN-1 PERM(LCHILD) = CBLKNBR+1 - (2*K+1) PERM(RCHILD) = CBLKNBR+1 - (2*K) TREETAB(RCHILD) = ROOTN TREETAB(LCHILD) = ROOTN IF(SUBNODES .GT. 3) THEN CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, LCHILD, & CBLKNBR, 2*K+1) CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, RCHILD, & CBLKNBR, 2*K) END IF END SUBROUTINE REC_TREETAB END SUBROUTINE SMUMPS_BUILD_TREETAB #endif #if defined(ptscotch) || defined(parmetis) || defined(parmetis3) SUBROUTINE SMUMPS_BUILD_DIST_GRAPH(id, ord, FIRST, LAST, IPE, & PE, WORK, LWORK) #if defined(DETERMINISTIC_PARALLEL_GRAPH) USE MUMPS_TOOLS_COMMON_M, ONLY : MUMPS_MERGESORT, & MUMPS_MERGESWAP1 #endif IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: FIRST(:), LAST(:), PE(:), & WORK(:) INTEGER(8), INTENT(IN) :: LWORK INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, OFFDIAG, & RCVPNT, PNT, SAVEPNT, DUPS, TOTDUPS INTEGER :: NROWS_LOC INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, POINTER :: MAPTAB(:) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: RDISPL(:), BUFLEVEL(:), & SIPES(:,:), LENG(:) INTEGER, POINTER :: TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER, PARAMETER :: ITAG=30 LOGICAL :: FLAG DOUBLE PRECISION :: SYMMETRY INTEGER(KIND=8) :: TLEN #if defined(DETERMINISTIC_PARALLEL_GRAPH) INTEGER :: L #endif nullify(MAPTAB, SNDCNT, RCVCNT) nullify(RDISPL, MSGCNT, SIPES, LENG, BUFLEVEL) nullify(TSENDI, TSENDJ, RCVBUF, APNT) MYID = ord%MYID NPROCS = ord%NPROCS IF(LWORK .LT. int(N,8)*2_8) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_SCOTCH_GRAPH")') CALL MUMPS_ABORT() END IF CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 BUFSIZE = 1000 BUFSIZE = id%KEEP(39) LOCNNZ = id%KEEP8(29) NROWS_LOC = LAST(MYID+1)-FIRST(MYID+1)+1 MAPTAB => WORK( 1 : N ) LENG => WORK( int(N+1,8) : 2_8*int(N,8) ) MAXS = 0 DO I=1, NPROCS IF((LAST(I)-FIRST(I)+1) .GT. MAXS) THEN MAXS = LAST(I)-FIRST(I)+1 END IF DO J=FIRST(I), LAST(I) MAPTAB(J) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 OFFDIAG=0 SIPES=0 DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN OFFDIAG = OFFDIAG+1 PROC = MAPTAB(id%IRN_loc(INNZ)) LOC_ROW = id%IRN_loc(INNZ)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 PROC = MAPTAB(id%JCN_loc(INNZ)) LOC_ROW = id%JCN_loc(INNZ)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF END DO CALL MPI_ALLREDUCE (OFFDIAG, id%KEEP8(127), 1, MPI_INTEGER8, & MPI_SUM, ord%COMM, IERR) id%KEEP8(127) = id%KEEP8(127)+3*N id%KEEP8(126) = id%KEEP8(127)-2*N CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, ord%COMM, IERR) CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, ord%COMM, IERR ) DEALLOCATE(SIPES) TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO CALL MUMPS_IREALLOC8(PE, max(IPE(NROWS_LOC+1)-1_8,1_8), id%INFO, & LP, STRING='PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL SMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ+RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO RCVPNT = 1 BUFLEVEL = 0 DO INNZ=1, LOCNNZ IF(mod(INNZ,int(BUFSIZE,8)/10_8) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, ord%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, ord%COMM, STATUS, IERR) CALL SMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%IRN_loc(INNZ)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%JCN_loc(INNZ) BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL SMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF PROC = MAPTAB(id%JCN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%JCN_loc(INNZ)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%IRN_loc(INNZ) BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL SMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF END IF END DO CALL SMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(MAPTAB(PE(INNZ)) .EQ. I) THEN DUPS = DUPS+1 ELSE MAPTAB(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO CALL MPI_REDUCE( DUPS, TOTDUPS, 1, MPI_INTEGER8, MPI_SUM, & 0, ord%COMM, IERR ) IF(MYID .EQ. 0) THEN SYMMETRY = dble(TOTDUPS)/(dble(id%KEEP8(28))-dble(N)) SYMMETRY = min(SYMMETRY,1.0d0) IF(id%KEEP(50) .GE. 1) SYMMETRY = 1.d0 IF(PROKG) WRITE(MPG,'(" Structural symmetry is:",i3,"%")') & ceiling(SYMMETRY*100.d0) id%INFOG(8) = ceiling(SYMMETRY*100.0d0) END IF IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) #if defined(DETERMINISTIC_PARALLEL_GRAPH) DO I=1, LAST(MYID+1)-FIRST(MYID+1)+1 L = int(IPE(I+1)-IPE(I)) CALL MUMPS_MERGESORT(L, & PE(IPE(I):IPE(I+1)-1), & WORK(:)) CALL MUMPS_MERGESWAP1(L, WORK(:), & PE(IPE(I):IPE(I+1)-1)) END DO #endif 90 continue RETURN END SUBROUTINE SMUMPS_BUILD_DIST_GRAPH #endif SUBROUTINE SMUMPS_BUILD_LOC_GRAPH(id, ord, GSIZE, IPE, PE, LENG, & I_HALO_MAP, top_graph, WORK, LWORK) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: PE(:), LENG(:), & I_HALO_MAP(:), WORK(:) INTEGER(8), INTENT(in) :: LWORK INTEGER :: GSIZE INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, TOP_CNT, TIDX, & RCVPNT INTEGER :: IIDX,JJDX INTEGER :: HALO_SIZE, NROWS_LOC, DUPS INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: MAPTAB(:), & HALO_MAP(:), BUFLEVEL(:) INTEGER, POINTER :: RDISPL(:), & SIPES(:,:) INTEGER, POINTER :: TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER(8) :: PNT, SAVEPNT INTEGER, PARAMETER :: ITAG=30 INTEGER(KIND=8) :: TLEN LOGICAL :: FLAG nullify(MAPTAB, SNDCNT, RCVCNT, HALO_MAP) nullify(RDISPL, MSGCNT, SIPES, BUFLEVEL) nullify(TSENDI, TSENDJ, RCVBUF, APNT) MYID = ord%MYID NPROCS = ord%NPROCS IF( LWORK .LT. int(N,8)*2_8 ) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_LOC_GRAPH")') CALL MUMPS_ABORT() END IF MAPTAB => WORK( 1 : N ) HALO_MAP => WORK(int(N+1,8) : 2_8*int(N,8)) CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 TOP_CNT = 0 BUFSIZE = 10000 BUFSIZE = id%KEEP(39) LOCNNZ = id%KEEP8(29) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 MAPTAB = 0 MAXS = 0 DO I=1, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) THEN MAXS = ord%LAST(I)-ord%FIRST(I)+1 END IF DO J=ord%FIRST(I), ord%LAST(I) MAPTAB(ord%PERITAB(J)) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SIPES(:,:) = 0 TOP_CNT = 0 DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%IRN_loc(INNZ)) LOC_ROW = IIDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF PROC = MAPTAB(id%JCN_loc(INNZ)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%JCN_loc(INNZ)) LOC_ROW = IIDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF END IF END DO CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, ord%COMM, IERR) I = ceiling(real(MAXS)*1.20E0) CALL MUMPS_REALLOC(LENG, max(I,1), id%INFO, & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, ord%COMM, IERR ) DEALLOCATE(SIPES) I = ceiling(real(NROWS_LOC+1)*1.20E0) CALL MUMPS_I8REALLOC(IPE, max(I,1), id%INFO, & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO CALL MUMPS_IREALLOC8(TSENDI, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(TSENDJ, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL SMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ + RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO CALL MUMPS_IREALLOC8(PE, max(NEW_LOCNNZ+ & 2_8*int(NROWS_LOC+ord%TOPNODES(2),8),1_8), & id%INFO, LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RCVPNT = 1 BUFLEVEL = 0 TIDX = 0 DO INNZ=1, LOCNNZ IF(mod(INNZ,int(BUFSIZE/10,8)) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, ord%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, ord%COMM, STATUS, IERR) CALL SMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) IF((MAPTAB(id%JCN_loc(INNZ)).NE.PROC) .AND. & (MAPTAB(id%JCN_loc(INNZ)).NE.0) .AND. & (PROC.NE.0)) THEN IERR = -50 id%INFO(1) = IERR END IF IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%IRN_loc(INNZ) TSENDJ(TIDX) = id%JCN_loc(INNZ) ELSE IIDX = ord%PERMTAB(id%IRN_loc(INNZ)) JJDX = ord%PERMTAB(id%JCN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1)=IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%JCN_loc(INNZ) END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL SMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF END IF PROC = MAPTAB(id%JCN_loc(INNZ)) IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%JCN_loc(INNZ) TSENDJ(TIDX) = id%IRN_loc(INNZ) ELSE IIDX = ord%PERMTAB(id%JCN_loc(INNZ)) JJDX = ord%PERMTAB(id%IRN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = & IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%IRN_loc(INNZ) END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL SMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF END IF END IF END DO CALL SMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB(:) = 0 HALO_MAP(:) = 0 HALO_SIZE = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(PE(INNZ) .LT. 0) THEN IF(HALO_MAP(-PE(INNZ)) .EQ. 0) THEN HALO_SIZE = HALO_SIZE+1 HALO_MAP(-PE(INNZ)) = NROWS_LOC+HALO_SIZE END IF PE(INNZ) = HALO_MAP(-PE(INNZ)) END IF IF(MAPTAB(PE(INNZ)) .EQ. I) THEN DUPS = DUPS+1 LENG(I) = LENG(I)-1 ELSE MAPTAB(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_REALLOC(I_HALO_MAP, HALO_SIZE, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT J=0 DO I=1, N IF(HALO_MAP(I) .GT. 0) THEN J = J+1 I_HALO_MAP(HALO_MAP(I)-NROWS_LOC) = I END IF IF(J .EQ. HALO_SIZE) EXIT END DO CALL MUMPS_REALLOC(LENG, max(NROWS_LOC+HALO_SIZE,1), id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:leng', MEMCNT=MEMCNT, ERRCODE=-7) LENG(NROWS_LOC+1:NROWS_LOC+HALO_SIZE) = 0 CALL MUMPS_I8REALLOC(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IPE(NROWS_LOC+2:NROWS_LOC+HALO_SIZE+1) = IPE(NROWS_LOC+1) GSIZE = NROWS_LOC + HALO_SIZE CALL MPI_GATHER(TOP_CNT, 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, 0, ord%COMM, IERR) IF(MYID.EQ.0) THEN NEW_LOCNNZ = sum(RCVCNT) top_graph%NZ_LOC = NEW_LOCNNZ CALL MUMPS_IREALLOC8(top_graph%IRN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(top_graph%JCN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1), & stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM, ord%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 END IF IF(MYID.EQ.0) THEN top_graph%IRN_LOC(1:TOP_CNT) = TSENDI(1:TOP_CNT) top_graph%JCN_LOC(1:TOP_CNT) = TSENDJ(1:TOP_CNT) DO PROC=2, NPROCS DO WHILE (RCVCNT(PROC) .GT. 0) I = int(min(int(BUFSIZE,8), RCVCNT(PROC))) CALL MPI_RECV(top_graph%IRN_LOC(TOP_CNT+1), I, & MPI_INTEGER, PROC-1, ITAG, ord%COMM, STATUS, IERR) CALL MPI_RECV(top_graph%JCN_LOC(TOP_CNT+1), I, & MPI_INTEGER, PROC-1, ITAG, ord%COMM, STATUS, IERR) RCVCNT(PROC) = RCVCNT(PROC)-I TOP_CNT = TOP_CNT+I END DO END DO ELSE DO WHILE (TOP_CNT .GT. 0) I = int(MIN(int(BUFSIZE,8), TOP_CNT)) CALL MPI_SEND(TSENDI(TOP_CNT-I+1), I, & MPI_INTEGER, 0, ITAG, ord%COMM, IERR) CALL MPI_SEND(TSENDJ(TOP_CNT-I+1), I, & MPI_INTEGER, 0, ITAG, ord%COMM, IERR) TOP_CNT = TOP_CNT-I END DO END IF CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, TSENDI, & TSENDJ, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) 90 continue RETURN END SUBROUTINE SMUMPS_BUILD_LOC_GRAPH SUBROUTINE SMUMPS_LUMAT_TO_LOC_GRAPH & (LUMAT, id, ord, GSIZE, IPE, PE, LENG, & I_HALO_MAP, WORK, LWORK) IMPLICIT NONE TYPE(LMATRIX_T), INTENT(IN) :: LUMAT TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: PE(:), LENG(:), & I_HALO_MAP(:), WORK(:) INTEGER(8), INTENT(IN) :: LWORK INTEGER :: GSIZE INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER :: ROWSIZE, IORIG, JORIG, PROCJ INTEGER(8) :: INNZ, NEW_LOCNNZ, RCVPNT INTEGER :: IIDX,JJDX INTEGER :: HALO_SIZE, NROWS_LOC INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: MAPTAB(:) INTEGER, POINTER :: HALO_MAP(:), BUFLEVEL(:) INTEGER, POINTER :: RDISPL(:), SIPES(:,:) INTEGER, POINTER :: RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER, PARAMETER :: ITAG=30 INTEGER(KIND=8) :: TLEN LOGICAL :: FLAG nullify(MAPTAB, SNDCNT, RCVCNT, HALO_MAP) nullify(RDISPL, MSGCNT, SIPES, BUFLEVEL) nullify( RCVBUF, APNT) MYID = ord%MYID NPROCS = ord%NPROCS IF ( LWORK .LT.2_8 * int(N,8) ) THEN WRITE(LP, & '("Insufficient workspace inside SMUMPS_LUMAT_TO_LOC_GRAPH")') CALL MUMPS_ABORT() END IF MAPTAB => WORK( 1 : N ) HALO_MAP => WORK( int(N+1,8) : 2_8*int(N,8)) CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 BUFSIZE = 10000 BUFSIZE = id%KEEP(39) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 MAPTAB = 0 MAXS = 0 DO I=1, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) THEN MAXS = ord%LAST(I)-ord%FIRST(I)+1 END IF DO J=ord%FIRST(I), ord%LAST(I) MAPTAB(ord%PERITAB(J)) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SIPES = 0 DO J =1, LUMAT%NBCOL_LOC ROWSIZE = LUMAT%COL(J)%NBINCOL JORIG = J + LUMAT%FIRST -1 PROC = MAPTAB(JORIG) IF(PROC .EQ. 0) CYCLE JJDX = ord%PERMTAB(JORIG) LOC_ROW = JJDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+ROWSIZE SNDCNT(PROC) = SNDCNT(PROC)+ROWSIZE ENDDO CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, ord%COMM, IERR) I = ceiling(real(MAXS)*1.20E0) CALL MUMPS_REALLOC(LENG, max(I,1), id%INFO, & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, ord%COMM, IERR ) DEALLOCATE(SIPES) I = ceiling(real(NROWS_LOC+1)*1.20E0) CALL MUMPS_I8REALLOC(IPE, max(I,1), id%INFO, & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL SMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ + RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO CALL MUMPS_IREALLOC8(PE, max(NEW_LOCNNZ+ & 2_8*int(NROWS_LOC+ord%TOPNODES(2),8),1_8), & id%INFO, LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RCVPNT = 1 BUFLEVEL = 0 INNZ = 1 DO I=1, LUMAT%NBCOL_LOC IF ( LUMAT%COL(I)%NBINCOL.EQ.0) CYCLE IORIG = I + LUMAT%FIRST -1 PROC = MAPTAB(IORIG) DO J=1, LUMAT%COL(I)%NBINCOL IF(mod(INNZ,int(BUFSIZE/10,8)) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, ord%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, ord%COMM, STATUS, IERR) CALL SMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF INNZ = INNZ +1 JORIG = LUMAT%COL(I)%IRN(J) PROCJ = MAPTAB(JORIG) IF((PROCJ.NE.PROC) .AND. & (PROC.NE.0) .AND. & (PROCJ.NE.0)) THEN IERR = -50 id%INFO(1) = IERR END IF IF (PROC.NE.0) THEN IIDX = ord%PERMTAB(IORIG) JJDX = ord%PERMTAB(JORIG) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1)=IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -JORIG END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL SMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) END IF END IF ENDDO ENDDO CALL SMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, ord%COMM) HALO_MAP(:) = 0 HALO_SIZE = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(PE(INNZ) .LT. 0) THEN IF(HALO_MAP(-PE(INNZ)) .EQ. 0) THEN HALO_SIZE = HALO_SIZE+1 HALO_MAP(-PE(INNZ)) = NROWS_LOC+HALO_SIZE END IF PE(INNZ) = HALO_MAP(-PE(INNZ)) END IF END DO END DO CALL MUMPS_REALLOC(I_HALO_MAP, HALO_SIZE, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT J=0 DO I=1, N IF(HALO_MAP(I) .GT. 0) THEN J = J+1 I_HALO_MAP(HALO_MAP(I)-NROWS_LOC) = I END IF IF(J .EQ. HALO_SIZE) EXIT END DO CALL MUMPS_REALLOC(LENG, max(NROWS_LOC+HALO_SIZE,1), id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:leng', MEMCNT=MEMCNT, ERRCODE=-7) LENG(NROWS_LOC+1:NROWS_LOC+HALO_SIZE) = 0 CALL MUMPS_I8REALLOC(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IPE(NROWS_LOC+2:NROWS_LOC+HALO_SIZE+1) = IPE(NROWS_LOC+1) GSIZE = NROWS_LOC + HALO_SIZE CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) 90 continue RETURN END SUBROUTINE SMUMPS_LUMAT_TO_LOC_GRAPH SUBROUTINE MUMPS_BUILD_TOP_GRAPH & (LUMAT, id, ord, top_graph, MAPTAB) IMPLICIT NONE TYPE(LMATRIX_T), INTENT(IN) :: LUMAT TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord TYPE(GRAPH_TYPE) :: top_graph INTEGER, POINTER :: MAPTAB(:) INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, PROCJ INTEGER :: ROWSIZE, IORIG, JORIG INTEGER(8) :: NEW_LOCNNZ, TOP_CNT, TIDX INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER(8), POINTER :: RCVCNT(:) INTEGER, POINTER :: TSENDI(:), TSENDJ(:) INTEGER :: BUFSIZE, allocok INTEGER, PARAMETER :: ITAG=30 nullify(RCVCNT,TSENDI,TSENDJ) MYID = ord%MYID NPROCS = ord%NPROCS MAPTAB = 0 DO I=1, NPROCS DO J=ord%FIRST(I), ord%LAST(I) MAPTAB(ord%PERITAB(J)) = I END DO END DO CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 TOP_CNT = 0 BUFSIZE = 10000 BUFSIZE = id%KEEP(39) TOP_CNT = 0 DO J =1, LUMAT%NBCOL_LOC JORIG = J + LUMAT%FIRST -1 PROC = MAPTAB(JORIG) IF(PROC .EQ. 0) THEN ROWSIZE = LUMAT%COL(J)%NBINCOL TOP_CNT = TOP_CNT+ROWSIZE ENDIF ENDDO CALL MUMPS_IREALLOC8(TSENDI, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(TSENDJ, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT TIDX = 0 DO I=1, LUMAT%NBCOL_LOC IF ( LUMAT%COL(I)%NBINCOL.EQ.0) CYCLE IORIG = I + LUMAT%FIRST -1 PROC = MAPTAB(IORIG) IF (PROC.NE.0) CYCLE DO J=1, LUMAT%COL(I)%NBINCOL JORIG = LUMAT%COL(I)%IRN(J) PROCJ = MAPTAB(JORIG) IF (PROCJ.EQ.0) THEN TIDX = TIDX+1 TSENDI(TIDX) = IORIG TSENDJ(TIDX) = JORIG ENDIF ENDDO ENDDO CALL MPI_GATHER(TIDX, 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, 0, ord%COMM, IERR) IF(MYID.EQ.0) THEN NEW_LOCNNZ = sum(RCVCNT) ELSE NEW_LOCNNZ = 0_8 ENDIF top_graph%NZ_LOC = NEW_LOCNNZ IF(MYID.EQ.0) THEN CALL MUMPS_IREALLOC8(top_graph%IRN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(top_graph%JCN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1), & stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=2 ENDIF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), ord%COMM, ord%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 IF(MYID.EQ.0) THEN top_graph%IRN_LOC(1:TIDX) = TSENDI(1:TIDX) top_graph%JCN_LOC(1:TIDX) = TSENDJ(1:TIDX) DO PROC=2, NPROCS DO WHILE (RCVCNT(PROC) .GT. 0) I = int(min(int(BUFSIZE,8), RCVCNT(PROC))) CALL MPI_RECV(top_graph%IRN_LOC(TIDX+1), I, & MPI_INTEGER, PROC-1, ITAG, ord%COMM, STATUS, IERR) CALL MPI_RECV(top_graph%JCN_LOC(TIDX+1), I, & MPI_INTEGER, PROC-1, ITAG, ord%COMM, STATUS, IERR) RCVCNT(PROC) = RCVCNT(PROC)-I TIDX = TIDX+I END DO END DO ELSE DO WHILE (TIDX .GT. 0) I = int(MIN(int(BUFSIZE,8), TIDX)) CALL MPI_SEND(TSENDI(TIDX-I+1), I, & MPI_INTEGER, 0, ITAG, ord%COMM, IERR) CALL MPI_SEND(TSENDJ(TIDX-I+1), I, & MPI_INTEGER, 0, ITAG, ord%COMM, IERR) TIDX = TIDX-I END DO END IF CALL MUMPS_DEALLOC( TSENDI, TSENDJ, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(RCVCNT, MEMCNT=MEMCNT) 90 continue RETURN END SUBROUTINE MUMPS_BUILD_TOP_GRAPH SUBROUTINE SMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, COMM) IMPLICIT NONE INTEGER :: NPROCS, PROC, COMM, allocok TYPE(ARRPNT) :: APNT(:) INTEGER :: BUFSIZE INTEGER, POINTER :: RCVBUF(:), LENG(:), PE(:) INTEGER :: SNDCNT(:) INTEGER(8) :: MSGCNT(:), IPE(:) LOGICAL, SAVE :: INIT = .TRUE. INTEGER, POINTER, SAVE :: SPACE(:,:,:) LOGICAL, POINTER, SAVE :: PENDING(:) INTEGER, POINTER, SAVE :: REQ(:), CPNT(:) INTEGER :: IERR, MYID, I, SOURCE INTEGER(8) :: TOTMSG LOGICAL :: FLAG, TFLAG INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: TSTATUS(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30, FTAG=31 INTEGER, POINTER :: TMPI(:), RCVCNT(:) CALL MPI_COMM_RANK (COMM, MYID, IERR) CALL MPI_COMM_SIZE (COMM, NPROCS, IERR) IF(INIT) THEN ALLOCATE(SPACE(2*BUFSIZE, 2, NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of SPACE in SMUMPS_SEND_BUF" return ENDIF ALLOCATE(RCVBUF(2*BUFSIZE), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of RCVBUF in SMUMPS_SEND_BUF" return ENDIF ALLOCATE(PENDING(NPROCS), CPNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of PENDING/CPNT" & ," in SMUMPS_SEND_BUF" return ENDIF ALLOCATE(REQ(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of REQ in SMUMPS_SEND_BUF" return ENDIF PENDING = .FALSE. DO I=1, NPROCS APNT(I)%BUF => SPACE(:,1,I) CPNT(I) = 1 END DO INIT = .FALSE. RETURN END IF IF(PROC .EQ. -1) THEN TOTMSG = sum(MSGCNT) DO IF(TOTMSG .EQ. 0) EXIT CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, ITAG, COMM, STATUS, IERR) CALL SMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) SOURCE = STATUS(MPI_SOURCE) TOTMSG = TOTMSG-1 MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 END DO DO I=1, NPROCS IF(PENDING(I)) THEN CALL MPI_WAIT(REQ(I), TSTATUS, IERR) END IF END DO ALLOCATE(RCVCNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of RCVCNT in SMUMPS_SEND_BUF" return ENDIF CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, COMM, IERR) DO I=1, NPROCS IF(SNDCNT(I) .GT. 0) THEN TMPI => APNT(I)%BUF(:) CALL MPI_ISEND(TMPI(1), 2*SNDCNT(I), MPI_INTEGER, I-1, & FTAG, COMM, REQ(I), IERR) END IF END DO DO I=1, NPROCS IF(RCVCNT(I) .GT. 0) THEN CALL MPI_RECV(RCVBUF(1), 2*RCVCNT(I), MPI_INTEGER, I-1, & FTAG, COMM, STATUS, IERR) CALL SMUMPS_ASSEMBLE_MSG(RCVCNT(I), RCVBUF, & IPE, PE, LENG) END IF END DO DO I=1, NPROCS IF(SNDCNT(I) .GT. 0) THEN CALL MPI_WAIT(REQ(I), TSTATUS, IERR) END IF END DO DEALLOCATE(SPACE) DEALLOCATE(PENDING, CPNT) DEALLOCATE(REQ) DEALLOCATE(RCVBUF, RCVCNT) nullify(SPACE, PENDING, CPNT, REQ, RCVBUF, RCVCNT) INIT = .TRUE. RETURN END IF IF(PENDING(PROC)) THEN DO CALL MPI_TEST(REQ(PROC), TFLAG, TSTATUS, IERR) IF(TFLAG) THEN PENDING(PROC) = .FALSE. EXIT ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, & SOURCE, ITAG, COMM, STATUS, IERR) CALL SMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, & PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 END IF END IF END DO END IF TMPI => APNT(PROC)%BUF(:) CALL MPI_ISEND(TMPI(1), 2*BUFSIZE, MPI_INTEGER, PROC-1, & ITAG, COMM, REQ(PROC), IERR) PENDING(PROC) = .TRUE. CPNT(PROC) = mod(CPNT(PROC),2)+1 APNT(PROC)%BUF => SPACE(:,CPNT(PROC),PROC) SNDCNT(PROC) = 0 RETURN END SUBROUTINE SMUMPS_SEND_BUF SUBROUTINE SMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) IMPLICIT NONE INTEGER :: BUFSIZE INTEGER :: RCVBUF(:), PE(:), LENG(:) INTEGER(8) :: IPE(:) INTEGER :: I, ROW, COL DO I=1, 2*BUFSIZE, 2 ROW = RCVBUF(I) COL = RCVBUF(I+1) PE(IPE(ROW)+LENG(ROW)) = COL LENG(ROW) = LENG(ROW) + 1 END DO RETURN END SUBROUTINE SMUMPS_ASSEMBLE_MSG #if defined(ptscotch) || defined(parmetis) || defined(parmetis3) SUBROUTINE SMUMPS_BUILD_TREE(ord) TYPE(ORD_TYPE) :: ord INTEGER :: I ord%SON = -1 ord%BROTHER = -1 ord%NW = 0 DO I=1, ord%CBLKNBR ord%NW(I) = ord%NW(I)+ord%RANGTAB(I+1) - ord%RANGTAB(I) IF (ord%TREETAB(I) .NE. -1) THEN IF (ord%SON(ord%TREETAB(I)) .EQ. -1) THEN ord%SON(ord%TREETAB(I)) = I ELSE ord%BROTHER(I) = ord%SON(ord%TREETAB(I)) ord%SON(ord%TREETAB(I)) = I END IF ord%NW(ord%TREETAB(I)) = ord%NW(ord%TREETAB(I))+ ord%NW(I) END IF END DO RETURN END SUBROUTINE SMUMPS_BUILD_TREE SUBROUTINE SMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK, LWORK, TYPE) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: FIRST(:), LAST(:), BASE, NPROCS, TYPE INTEGER, TARGET :: WORK(:) INTEGER(8), INTENT(IN) :: LWORK INTEGER, POINTER :: TMP(:), NZ_ROW(:) INTEGER :: I, IERR, P, F, J INTEGER(8) :: LOCNNZ, INNZ, LOCOFFDIAG, & OFFDIAG, T, SHARE DO I=0, BASE-1 FIRST(I+1) = 0 LAST(I+1) = -1 END DO IF(TYPE.EQ.1) THEN SHARE = int(N/ord%NPROCS_PARAORD,8) DO I=1, ord%NPROCS_PARAORD FIRST(BASE+I) = (I-1)*int(SHARE)+1 LAST (BASE+I) = (I)*int(SHARE) END DO LAST(BASE+ord%NPROCS_PARAORD) = & MAX(LAST(BASE+ord%NPROCS_PARAORD), N) DO I = ord%NPROCS_PARAORD+1, id%NSLAVES+1 FIRST(BASE+I) = N+1 LAST (BASE+I) = N END DO ELSE IF (TYPE.EQ.2) THEN IF (LWORK .LT. 2_8*int(N,8)) THEN WRITE(*,*) "Insufficient workspace in SMUMPS_GRAPH_DIST" CALL MUMPS_ABORT() ENDIF TMP => WORK(1:N) NZ_ROW => WORK(int(N+1,8):2-8*int(N,8)) TMP = 0 LOCOFFDIAG = 0_8 LOCNNZ = id%KEEP8(29) DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN TMP(id%IRN_loc(INNZ)) = TMP(id%IRN_loc(INNZ))+1 LOCOFFDIAG = LOCOFFDIAG+1 IF(id%SYM.GT.0) THEN TMP(id%JCN_loc(INNZ)) = TMP(id%JCN_loc(INNZ))+1 LOCOFFDIAG = LOCOFFDIAG+1 END IF END IF END DO CALL MUMPS_BIGALLREDUCE(.FALSE., TMP(1), NZ_ROW(1), N, & MPI_INTEGER, MPI_SUM, ord%COMM, IERR) CALL MPI_ALLREDUCE(LOCOFFDIAG, OFFDIAG, 1, & MPI_INTEGER8, MPI_SUM, ord%COMM, IERR) nullify(TMP) SHARE = (OFFDIAG-1_8)/int(ord%NPROCS_PARAORD,8) + 1_8 P = 0 T = 0_8 F = 1 DO I=1, N T = T+int(NZ_ROW(I),8) IF ( & (T .GE. SHARE) .OR. & ((N-I).EQ.(ord%NPROCS_PARAORD-P-1)) .OR. & (I.EQ.N) & ) THEN P = P+1 IF(P.EQ.ord%NPROCS_PARAORD) THEN FIRST(BASE+P) = F LAST(BASE+P) = N EXIT ELSE FIRST(BASE+P) = F LAST(BASE+P) = I F = I+1 T = 0_8 END IF END IF END DO DO J=P+1, NPROCS+1-BASE FIRST(BASE+J) = N+1 LAST(BASE+J) = N END DO END IF RETURN END SUBROUTINE SMUMPS_GRAPH_DIST #endif FUNCTION MUMPS_GETSIZE(A) INTEGER, POINTER :: A(:) INTEGER :: MUMPS_GETSIZE IF(associated(A)) THEN MUMPS_GETSIZE = size(A) ELSE MUMPS_GETSIZE = 0_8 END IF RETURN END FUNCTION MUMPS_GETSIZE #if defined(parmetis) || defined(parmetis3) SUBROUTINE MUMPS_PARMETIS_MIXEDto32(id, & BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & VELOLOCTAB, SIZE_VELOLOCTAB, & SIZES, COMM, MYID, IERR) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:) INTEGER :: SIZES(:), ORDER(:) INTEGER(8) :: VERTLOCTAB(:) INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, MYID, & BASE INTEGER :: VELOLOCTAB(:) INTEGER :: SIZE_VELOLOCTAB INTEGER, POINTER :: VERTLOCTAB_I4(:) IF( VERTLOCTAB(VERTLOCNBR+1).GT.huge(VERTLOCNBR)) THEN id%INFO(1) = -51 CALL MUMPS_SET_IERROR( & VERTLOCTAB(VERTLOCNBR+1), id%INFO(2)) RETURN END IF nullify(VERTLOCTAB_I4) CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1), & VERTLOCNBR+1, VERTLOCTAB_I4(1)) IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_PARMETIS_VWGT(FIRST(1+BASE), VERTLOCTAB_I4(1), & EDGELOCTAB(1), BASEVAL, OPTIONS(1), ORDER(1), & SIZES(1), COMM, VELOLOCTAB(1), IERR) ELSE CALL MUMPS_PARMETIS(FIRST(1+BASE), VERTLOCTAB_I4(1), & EDGELOCTAB(1), BASEVAL, OPTIONS(1), ORDER(1), & SIZES(1), COMM, IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT) RETURN END SUBROUTINE MUMPS_PARMETIS_MIXEDto32 SUBROUTINE MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & VELOLOCTAB, SIZE_VELOLOCTAB, & SIZES, COMM, MYID, IERR) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:) INTEGER :: SIZES(:), ORDER(:) INTEGER(8) :: VERTLOCTAB(:) INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, MYID, & BASE INTEGER :: VELOLOCTAB(:) INTEGER :: SIZE_VELOLOCTAB INTEGER(8), POINTER :: FIRST_I8(:), EDGELOCTAB_I8(:), & SIZES_I8(:), ORDER_I8(:), VELOLOCTAB_I8(:) INTEGER(8) :: VERTLOCNBR_I8 #if defined(parmetis) INTEGER(8), POINTER :: OPTIONS_I8(:) INTEGER(8) :: BASEVAL_I8 nullify(OPTIONS_I8) IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8REALLOC(OPTIONS_I8, size(OPTIONS), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64(OPTIONS(1), size(OPTIONS) & , OPTIONS_I8(1)) BASEVAL_I8 = int(BASEVAL,8) END IF #endif nullify(FIRST_I8, EDGELOCTAB_I8, SIZES_I8, ORDER_I8, & VELOLOCTAB_I8) IF (id%KEEP(10).EQ.1) THEN IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_PARMETIS_VWGT_64(FIRST(1+BASE), VERTLOCTAB(1), & EDGELOCTAB(1), & BASEVAL, OPTIONS(1), & ORDER(1), & SIZES(1), COMM, VELOLOCTAB(1), IERR) ELSE CALL MUMPS_PARMETIS_64(FIRST(1+BASE), VERTLOCTAB(1), & EDGELOCTAB(1), & BASEVAL, OPTIONS(1), & ORDER(1), & SIZES(1), COMM, IERR) ENDIF ELSE CALL MUMPS_I8REALLOC(FIRST_I8, size(FIRST), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_I8REALLOC(VELOLOCTAB_I8, VERTLOCNBR, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 ENDIF CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8, & VERTLOCTAB(VERTLOCNBR+1)-1_8, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(SIZES_I8, size(SIZES), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(ORDER_I8, size(ORDER), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 5 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64(FIRST(1), size(FIRST), FIRST_I8(1)) CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1), & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1)) IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN VERTLOCNBR_I8 = int(VERTLOCNBR,8) CALL MUMPS_ICOPY_32TO64_64C(VELOLOCTAB(1), & VERTLOCNBR_I8, VELOLOCTAB_I8(1)) ENDIF IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_PARMETIS_VWGT_64(FIRST_I8(1+BASE), VERTLOCTAB(1), & EDGELOCTAB_I8(1), #if defined(parmetis3) & BASEVAL, OPTIONS(1), #else & BASEVAL_I8, OPTIONS_I8(1), #endif & ORDER_I8(1), & SIZES_I8(1), COMM, VELOLOCTAB_I8(1), & IERR) ELSE CALL MUMPS_PARMETIS_64(FIRST_I8(1+BASE), VERTLOCTAB(1), & EDGELOCTAB_I8(1), #if defined(parmetis3) & BASEVAL, OPTIONS(1), #else & BASEVAL_I8, OPTIONS_I8(1), #endif & ORDER_I8(1), & SIZES_I8(1), COMM, IERR) ENDIF END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF ( id%KEEP(10) .NE. 1 ) THEN CALL MUMPS_ICOPY_64TO32(ORDER_I8(1), & size(ORDER), ORDER(1)) CALL MUMPS_ICOPY_64TO32(SIZES_I8(1), & size(SIZES), SIZES(1)) ENDIF 10 CONTINUE CALL MUMPS_I8DEALLOC(FIRST_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(SIZES_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(ORDER_I8, MEMCNT=MEMCNT) IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) & CALL MUMPS_I8DEALLOC(VELOLOCTAB_I8, MEMCNT=MEMCNT) #if defined(parmetis) CALL MUMPS_I8DEALLOC(OPTIONS_I8, MEMCNT=MEMCNT) #endif RETURN END SUBROUTINE MUMPS_PARMETIS_MIXEDto64 #endif #if defined(ptscotch) SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & VELOLOCTAB, SIZE_VELOLOCTAB, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, LCONTDAT, #endif & IERR) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: BASEVAL, VERTLOCNBR INTEGER(8) :: EDGELOCNBR INTEGER(8) :: VERTLOCTAB(:) INTEGER :: EDGELOCTAB(:) INTEGER :: VELOLOCTAB(:) INTEGER, INTENT(IN) :: SIZE_VELOLOCTAB INTEGER :: IERR INTEGER, POINTER :: VERTLOCTAB_I4(:) INTEGER :: EDGELOCNBR_I4, MYWORKID DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) INTEGER :: LCONTDAT DOUBLE PRECISION :: CONTDAT(LCONTDAT) DOUBLE PRECISION :: GRAPHDAT_BEFORE_CONTEXT(SCOTCH_DGRAPHDIM) #endif IF (.NOT.ord%IDO) RETURN nullify(VERTLOCTAB_I4) CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1), & VERTLOCNBR+1, VERTLOCTAB_I4(1)) EDGELOCNBR_I4 = int(EDGELOCNBR) IF(ord%SUBSTRAT .NE. 0) THEN STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// & 'proc=1,seq=q{strat=m{type=h,vert=100,'// & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' END IF IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, MYWORKID, IERR) ELSE MYWORKID = -1 END IF #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL MUMPS_DGRAPHINIT(GRAPHDAT_BEFORE_CONTEXT, ord%COMM_PARAORD, & IERR) CALL SCOTCHFCONTEXTBINDDGRAPH(CONTDAT, GRAPHDAT_BEFORE_CONTEXT, & GRAPHDAT, IERR) #else CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_PARAORD, IERR) #endif IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB_I4(1), VERTLOCTAB_I4(2), & VELOLOCTAB(1), VERTLOCTAB_I4(1), EDGELOCNBR_I4, & EDGELOCNBR_I4, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ELSE CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB_I4(1), VERTLOCTAB_I4(2), & VERTLOCTAB_I4(1), VERTLOCTAB_I4(1), EDGELOCNBR_I4, & EDGELOCNBR_I4, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(ord%SUBSTRAT .NE. 0) THEN CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR, & ord%RANGTAB(1), ord%TREETAB(1), IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT_BEFORE_CONTEXT) #endif 10 CONTINUE CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT) RETURN END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32 SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & VELOLOCTAB, SIZE_VELOLOCTAB, #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) & CONTDAT, LCONTDAT, #endif & IERR) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: BASEVAL, VERTLOCNBR INTEGER(8) :: EDGELOCNBR INTEGER(8) :: VERTLOCTAB(:) INTEGER :: EDGELOCTAB(:) INTEGER :: VELOLOCTAB(:) INTEGER, INTENT(IN) :: SIZE_VELOLOCTAB INTEGER :: IERR INTEGER :: MYWORKID DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) INTEGER :: LCONTDAT DOUBLE PRECISION :: CONTDAT(LCONTDAT) DOUBLE PRECISION :: GRAPHDAT_BEFORE_CONTEXT(SCOTCH_DGRAPHDIM) #endif INTEGER(8), POINTER :: EDGELOCTAB_I8(:), PERMTAB_I8(:), & PERITAB_I8(:), RANGTAB_I8(:), TREETAB_I8(:), VELOLOCTAB_I8(:) INTEGER(8) :: CBLKNBR_I8, VERTLOCNBR_I8, BASEVAL_I8 IF(ord%SUBSTRAT .NE. 0) THEN STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// & 'proc=1,seq=q{strat=m{type=h,vert=100,'// & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' END IF IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_PARAORD, MYWORKID, IERR) ELSE MYWORKID = -1 END IF nullify(EDGELOCTAB_I8, PERMTAB_I8, PERITAB_I8, & RANGTAB_I8, TREETAB_I8, VELOLOCTAB_I8) IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8, & VERTLOCTAB(VERTLOCNBR+1)-1_8, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_I8REALLOC(VELOLOCTAB_I8, VERTLOCNBR, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 ENDIF IF (MYWORKID .EQ. 0) THEN CALL MUMPS_I8REALLOC(PERMTAB_I8, size(ord%PERMTAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(PERITAB_I8, size(ord%PERITAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(TREETAB_I8, size(ord%TREETAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(RANGTAB_I8, size(ord%RANGTAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) END IF 5 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1), & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1)) VERTLOCNBR_I8 = int(VERTLOCNBR,8) IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN CALL MUMPS_ICOPY_32TO64_64C(VELOLOCTAB(1), & VERTLOCNBR_I8, VELOLOCTAB_I8(1)) ENDIF BASEVAL_I8 = int(BASEVAL,8) ENDIF #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL MUMPS_DGRAPHINIT(GRAPHDAT_BEFORE_CONTEXT, ord%COMM_PARAORD, & IERR) CALL SCOTCHFCONTEXTBINDDGRAPH(CONTDAT, GRAPHDAT_BEFORE_CONTEXT, & GRAPHDAT, IERR) #else CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_PARAORD, IERR) #endif IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF (SIZE_VELOLOCTAB.EQ.VERTLOCNBR) THEN IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL_I8, VERTLOCNBR_I8, & VERTLOCNBR_I8, VERTLOCTAB(1), VERTLOCTAB(2), & VELOLOCTAB_I8(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB_I8(1), EDGELOCTAB_I8(1), & EDGELOCTAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), & VELOLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ENDIF ELSE IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL_I8, VERTLOCNBR_I8, & VERTLOCNBR_I8, VERTLOCTAB(1), VERTLOCTAB(2), & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB_I8(1), EDGELOCTAB_I8(1), & EDGELOCTAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ENDIF ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(ord%SUBSTRAT .NE. 0) THEN CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & PERMTAB_I8(1), PERITAB_I8(1), CBLKNBR_I8, RANGTAB_I8(1), & TREETAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR, & ord%RANGTAB(1),ord%TREETAB(1), IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_PARAORD, ord%MYID_PARAORD ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT_BEFORE_CONTEXT) #endif 10 CONTINUE IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT) IF (SIZE_VELOLOCTAB.GT.0) & CALL MUMPS_I8DEALLOC(VELOLOCTAB_I8, MEMCNT=MEMCNT) IF(MYWORKID .EQ. 0) THEN CALL MUMPS_ICOPY_64TO32(PERMTAB_I8(1), & size(ord%PERMTAB), ord%PERMTAB(1)) CALL MUMPS_ICOPY_64TO32(PERITAB_I8(1), & size(ord%PERITAB), ord%PERITAB(1)) CALL MUMPS_ICOPY_64TO32(TREETAB_I8(1), & size(ord%TREETAB), ord%TREETAB(1)) CALL MUMPS_ICOPY_64TO32(RANGTAB_I8(1), & size(ord%RANGTAB), ord%RANGTAB(1)) ord%CBLKNBR = int(CBLKNBR_I8) CALL MUMPS_I8DEALLOC(PERMTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(PERITAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(RANGTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(TREETAB_I8, MEMCNT=MEMCNT) END IF ENDIF RETURN END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64 #endif END MODULE MUMPS_5.8.1/src/dfac_process_contrib_type1.F0000664000175000017500000001172715042446440020644 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_PROCESS_NODE( MYID,KEEP,KEEP8,DKEEP, & BUFR, LBUFR, LBUFR_BYTES, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER MYID INTEGER LBUFR, LBUFR_BYTES INTEGER KEEP(500), BUFR( LBUFR ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP, FPERE LOGICAL FLAG INTEGER NSTK_S( KEEP(28) ), ITLOC( N + KEEP(253) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER IFLAG, IERROR, COMM INTEGER POSITION, FINODE, FLCONT, LREQ INTEGER(8) :: LREQCB INTEGER(8) :: IPOS_NODE, ISHIFT_PACKET INTEGER SIZE_PACKET INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INCLUDE 'mumps_headers.h' LOGICAL PACKED_CB DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYN_SIZE FLAG = .FALSE. POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FLCONT, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, MPI_INTEGER, & COMM, IERR) PACKED_CB = (FLCONT.LT.0) IF (PACKED_CB) THEN FLCONT = -FLCONT LREQCB = (int(FLCONT,8) * int(FLCONT+1,8)) / 2_8 ELSE LREQCB = int(FLCONT,8) * int(FLCONT,8) ENDIF IF (NBROWS_ALREADY_SENT == 0) THEN LREQ = 2 * FLCONT + 6 + KEEP(IXSZ) CALL DMUMPS_ALLOC_CB( .FALSE., 0_8, .FALSE.,.FALSE., & MYID,N, KEEP,KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & LREQ, LREQCB, FINODE, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PIMASTER(STEP( FINODE )) = IWPOSCB + 1 PAMASTER(STEP( FINODE )) = IPTRLU + 1_8 IF (PACKED_CB) IW(IWPOSCB + 1 + XXS ) = S_CB1COMP CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 1+KEEP(IXSZ)), LREQ-KEEP(IXSZ), & MPI_INTEGER, COMM, IERR) ENDIF IF (PACKED_CB) THEN ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * & int(NBROWS_ALREADY_SENT+1,8) / 2_8 SIZE_PACKET = (NBROWS_PACKET * (NBROWS_PACKET+1))/2 + & NBROWS_ALREADY_SENT * NBROWS_PACKET ELSE ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * int(FLCONT,8) SIZE_PACKET = NBROWS_PACKET * FLCONT ENDIF IF (NBROWS_PACKET.NE.0) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(PIMASTER(STEP(FINODE))+XXD)) IF (DYN_SIZE .GT. 0_8) THEN CALL DMUMPS_DM_SET_PTR( PAMASTER(STEP(FINODE)), & DYN_SIZE, SON_A ) IPOS_NODE = 1_8 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & SON_A(IPOS_NODE + ISHIFT_PACKET), & SIZE_PACKET, MPI_DOUBLE_PRECISION, COMM, IERR) ELSE IPOS_NODE = PAMASTER(STEP(FINODE)) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & A(IPOS_NODE + ISHIFT_PACKET), & SIZE_PACKET, MPI_DOUBLE_PRECISION, COMM, IERR) ENDIF ENDIF IF (NBROWS_ALREADY_SENT+NBROWS_PACKET == FLCONT) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF ( NSTK_S(STEP(FPERE)).EQ.0 ) THEN FLAG = . TRUE. END IF ENDIF RETURN END SUBROUTINE DMUMPS_PROCESS_NODE MUMPS_5.8.1/src/ssol_distsol.F0000664000175000017500000000101115042446437016057 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_DS_RETURN() RETURN END SUBROUTINE SMUMPS_DS_RETURN MUMPS_5.8.1/src/dfac_lr.F0000664000175000017500000030077415042446437014752 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_LR USE DMUMPS_LR_TYPE USE DMUMPS_LR_CORE IMPLICIT NONE CONTAINS SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING_LDLT( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, & NELIM, IW2, BLOCK, & MAXI_CLUSTER, NPIV, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & NELIM, MAXI_CLUSTER, NPIV, NIV, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR DOUBLE PRECISION, intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_L(:) DOUBLE PRECISION, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, intent(in) :: IW2(*) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL, J, MID_RANK LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER(8) :: POSELTT, POSELTD DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(CURRENT_BLR)-1,8) & + int(BEGS_BLR(CURRENT_BLR) - 1,8) OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC, CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, !$OMP& MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL*(NB_BLOCKS_PANEL+1)/2) IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT + int(NFRONT,8) * & int(BEGS_BLR(CURRENT_BLR+I)-1,8) & + int(BEGS_BLR(CURRENT_BLR+J) - 1, 8) CALL DMUMPS_LRGEMM4(MONE, & BLR_L(J), BLR_L(I), ONE, A, LA, & POSELTT, NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_L(J)%M, BLR_L(J)%N, BLR_L(J)%K, & BLR_L(J)%ISLR, BLR_L(I)%M, BLR_L(I)%N, BLR_L(I)%K, & BLR_L(I)%ISLR, MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), .FALSE.) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif END SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING_LDLT SUBROUTINE DMUMPS_BLR_SLV_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, JBEG_BLOCK, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA, LA_BLOCFACTO DOUBLE PRECISION, intent(inout) :: A(LA) DOUBLE PRECISION, intent(in) :: A_BLOCFACTO(LA_BLOCFACTO) INTEGER(8), intent(in) :: POSELT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), TOL_OPT, & MAXI_CLUSTER, LD_BLOCFACTO, & JBEG_BLOCK INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS, & ISHIFT_LM, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS DOUBLE PRECISION, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM), & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_LM, NB_BLOCKS_PANEL_LS, J, MID_RANK LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER(8) :: POSELTT DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) NB_BLOCKS_PANEL_LM = NB_BLR_LM-CURRENT_BLR_LM NB_BLOCKS_PANEL_LS = NB_BLR_LS-CURRENT_BLR_LS OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_LS*NB_BLOCKS_PANEL_LM) IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_BLOCKS_PANEL_LM+1 J = IBIS - (I-1)*NB_BLOCKS_PANEL_LM #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT & + int(NCOL,8) * & int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8) & + int((BEGS_BLR_LM(CURRENT_BLR_LM+J)+ISHIFT_LM-1),8) CALL DMUMPS_LRGEMM4(MONE, & BLR_LM(J), BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A_BLOCFACTO, LD_DIAG=LD_BLOCFACTO, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_LM(J)%M, BLR_LM(J)%N, BLR_LM(J)%K, & BLR_LM(J)%ISLR, BLR_LS(I)%M, BLR_LS(I)%N, BLR_LS(I)%K, & BLR_LS(I)%ISLR, MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., .FALSE.) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO IF (IFLAG.LT.0) RETURN IF (JBEG_BLOCK.NE.1) RETURN !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, MID_RANK, OMP_NUM, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_LS*(NB_BLOCKS_PANEL_LS+1)/2) IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT & + int(NCOL,8) * & int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8) & + int((NCOL-NROW+(BEGS_BLR_LS(CURRENT_BLR_LS+J)-1)),8) CALL DMUMPS_LRGEMM4(MONE, & BLR_LS(J),BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A_BLOCFACTO, LD_DIAG=LD_BLOCFACTO, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_LS(J)%M, BLR_LS(J)%N, BLR_LS(J)%K, & BLR_LS(J)%ISLR, BLR_LS(I)%M, BLR_LS(I)%N, BLR_LS(I)%K, & BLR_LS(I)%ISLR, MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), .FALSE.) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif RETURN END SUBROUTINE DMUMPS_BLR_SLV_UPD_TRAIL_LDLT SUBROUTINE DMUMPS_BLR_UPD_NELIM_VAR_U( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_U, NB_BLR, & FIRST_BLOCK, IBEG_BLR, NPIV, NELIM) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & IBEG_BLR, NPIV, NELIM, FIRST_BLOCK INTEGER, intent(inout) :: IFLAG, IERROR DOUBLE PRECISION, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(:) INTEGER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: IP INTEGER :: allocok INTEGER(8) :: LPOS, UPOS DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) IF (NELIM.NE.0) THEN LPOS = POSELT + int(NFRONT,8)*int(NPIV,8) + int(IBEG_BLR-1,8) #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(LRB, UPOS) #endif DO IP = FIRST_BLOCK, NB_BLR IF (IFLAG.LT.0) CYCLE LRB => BLR_U(IP-CURRENT_BLR) UPOS = POSELT + int(NFRONT,8)*int(NPIV,8) & + int(BEGS_BLR(IP)-1,8) IF (LRB%ISLR) THEN IF (LRB%K.GT.0) THEN allocate(TEMP_BLOCK( LRB%K, NELIM ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * LRB%K GOTO 100 ENDIF CALL dgemm('N', 'N', LRB%K, NELIM, LRB%N, ONE, & LRB%R(1,1), LRB%K, A(LPOS), NFRONT, & ZERO, TEMP_BLOCK, LRB%K) CALL dgemm('N', 'N', LRB%M, NELIM, LRB%K, MONE, & LRB%Q(1,1), LRB%M, TEMP_BLOCK, LRB%K, & ONE, A(UPOS), NFRONT) deallocate(TEMP_BLOCK) ENDIF ELSE CALL dgemm('N', 'N', LRB%M, NELIM, LRB%N, MONE, & LRB%Q(1,1), LRB%M, A(LPOS), NFRONT, & ONE, A(UPOS), NFRONT) ENDIF 100 CONTINUE ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO #endif ENDIF END SUBROUTINE DMUMPS_BLR_UPD_NELIM_VAR_U SUBROUTINE DMUMPS_BLR_UPD_NELIM_VAR_L( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA_U, LA_L INTEGER(8), intent(in) :: UPOS, LPOS INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR, & NELIM, FIRST_BLOCK CHARACTER(len=1),INTENT(IN) :: UTRANS INTEGER, intent(inout) :: IFLAG, IERROR DOUBLE PRECISION, TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U) TYPE(LRB_TYPE),intent(in) :: BLR_L(:) INTEGER :: BEGS_BLR_L(:) INTEGER :: I, NB_BLOCKS_PANEL_L, KL, ML, NL INTEGER :: allocok INTEGER(8) :: IPOS DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR IF (NELIM.NE.0) THEN #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(KL, ML, NL, IPOS) #endif DO I = FIRST_BLOCK-CURRENT_BLR, NB_BLOCKS_PANEL_L IF (IFLAG.LT.0) CYCLE KL = BLR_L(I)%K ML = BLR_L(I)%M NL = BLR_L(I)%N IPOS = LPOS + int(LDL,8) * & int(BEGS_BLR_L(CURRENT_BLR+I)-BEGS_BLR_L(CURRENT_BLR+1),8) IF (BLR_L(I)%ISLR) THEN IF (KL.GT.0) THEN allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * KL write(*,*) 'Allocation problem in BLR routine & DMUMPS_BLR_UPD_NELIM_VAR_L: ', & 'not enough memory? memory requested = ', IERROR GOTO 100 ENDIF CALL dgemm(UTRANS , 'T' , NELIM, KL, NL , ONE , & A_U(UPOS) , LDU , BLR_L(I)%R(1,1) , KL , & ZERO , TEMP_BLOCK , NELIM) CALL dgemm('N' , 'T' , NELIM , ML , KL , MONE , & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , & ONE , A_L(IPOS) , LDL) deallocate(TEMP_BLOCK) ENDIF ELSE CALL dgemm(UTRANS , 'T' , NELIM, ML, NL , MONE , & A_U(UPOS) , LDU , BLR_L(I)%Q(1,1) , ML , & ONE , A_L(IPOS) , LDL) ENDIF 100 CONTINUE ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO #endif ENDIF END SUBROUTINE DMUMPS_BLR_UPD_NELIM_VAR_L SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, & CURRENT_BLR, & NELIM, NIV, SYM, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT DOUBLE PRECISION, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(:) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(:) INTEGER :: BEGS_BLR_L(:), BEGS_BLR_U(:) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_L, NB_BLOCKS_PANEL_U, & KL, ML, NL, J, IS, MID_RANK INTEGER :: allocok LOGICAL :: BUILDQ INTEGER :: IBIS #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB, POSELT_TOP DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR NB_BLOCKS_PANEL_U = NB_BLR_U-CURRENT_BLR IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS = 0 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif IF (NELIM.NE.0) THEN DO I = 1, NB_BLOCKS_PANEL_L KL = BLR_L(I)%K ML = BLR_L(I)%M NL = BLR_L(I)%N IF (BLR_L(I)%ISLR) THEN IF (KL.GT.0) THEN allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * KL GOTO 100 ENDIF POSELT_TOP = POSELT & + int(NFRONT,8) * int((BEGS_BLR_U(CURRENT_BLR)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1,8) POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) CALL dgemm('N' , 'T' , NELIM, KL, NL , ONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%R(1,1) , KL , & ZERO , TEMP_BLOCK , NELIM) CALL dgemm('N' , 'T' , NELIM , ML , KL , MONE , & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) deallocate(TEMP_BLOCK) ENDIF ELSE POSELT_TOP = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1, 8) CALL dgemm('N' , 'T' , NELIM, ML, NL , MONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) ENDIF ENDDO ENDIF 100 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 200 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELT_INCB, MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_L*NB_BLOCKS_PANEL_U) IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_BLOCKS_PANEL_U+1 J = IBIS - (I-1)*NB_BLOCKS_PANEL_U POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+J) +IS - 1,8) CALL DMUMPS_LRGEMM4(MONE, BLR_U(J), & BLR_L(I), ONE, A, LA, POSELT_INCB, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT, MID_RANK, BUILDQ, .FALSE.) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_U(J)%M, BLR_U(J)%N, BLR_U(J)%K, & BLR_U(J)%ISLR, BLR_L(I)%M, BLR_L(I)%N, BLR_L(I)%K, & BLR_L(I)%ISLR, MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., .FALSE.) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif 200 CONTINUE END SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING SUBROUTINE DMUMPS_BLR_UPD_PANEL_LEFT_LDLT( & A, LA, POSELT, NFRONT, IWHANDLER, & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, IW2, BLOCK, ACC_LUA, & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, & KEEP8, & FIRST_BLOCK & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS, & CURRENT_BLR, IWHANDLER, TOL_OPT, & NELIM, NIV, K480, K479, K478, & MAXI_CLUSTER, MAXI_RANK, & KPERCENT_LUA, KPERCENT DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER, intent(in) :: IW2(*) DOUBLE PRECISION :: BLOCK(MAXI_CLUSTER,*) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:) INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER,intent(inout) :: IFLAG, IERROR INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK TYPE(LRB_TYPE), POINTER :: BLR_L(:), NEXT_BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES, & I, II, J, JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX, & MAXRANK, NB_DEC, FR_RANK INTEGER :: MID_RANK, allocok INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) LOGICAL :: BUILDQ, COMPRESSED_FR INTEGER :: OFFSET_IW INTEGER :: OMP_NUM #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB, POSELTD DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR ACC_LRB => ACC_LUA(1) IF (K480.GE.5) THEN IF (NB_BLOCKS_PANEL.GT.1) THEN CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & CURRENT_BLR+1, NEXT_BLR_L) ENDIF IF (.not.(present(FIRST_BLOCK))) THEN write(*,*) "Internal error in & DMUMPS_BLR_UPD_PANEL_LEFT_LDLT: KEEP(480)=",K480, & ">= 5, but FIRST_BLOCK argument is missing" CALL MUMPS_ABORT() ENDIF ENDIF OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ, K_MAX, !$OMP& BLR_L, OMP_NUM, J_ORDER, J_RANK, !$OMP& IND_U, IND_L, ACC_LRB, POSELTD, NB_DEC, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, COMPRESSED_FR, FR_RANK, II, OFFSET_IW) #endif DO I = 1, NB_BLOCKS_PANEL #if ! defined(BLR_NOOPENMP) IF (IFLAG.LT.0) CYCLE OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR(CURRENT_BLR+1)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+I+1)-BEGS_BLR(CURRENT_BLR+I) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 COMPRESSED_FR = .FALSE. IF (K480.EQ.2) THEN DO J = 1, CURRENT_BLR J_ORDER(J) = J ENDDO ELSE CALL DMUMPS_GET_LUA_ORDER(CURRENT_BLR, J_ORDER, J_RANK, & IWHANDLER, & 1, 0, I, 0, & FRFR_UPDATES) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL DMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF ENDIF NB_DEC = FRFR_UPDATES DO JJ = 1, CURRENT_BLR J = J_ORDER(JJ) K_MAX = J_RANK(JJ) POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(J)-1,8) & + int(BEGS_BLR(J) - 1,8) OFFSET_IW = BEGS_BLR(J) IND_L = CURRENT_BLR+I-J IND_U = CURRENT_BLR+1-J CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & J, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = JJ-1 CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL DMUMPS_LRGEMM4(MONE, & BLR_L(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_INCB, & NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=0, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, & IW2=IW2(OFFSET_IW), & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_L(IND_U)%M, BLR_L(IND_U)%N, & BLR_L(IND_U)%K, BLR_L(IND_U)%ISLR, BLR_L(IND_L)%M, & BLR_L(IND_L)%N, BLR_L(IND_L)%K, BLR_L(IND_L)%ISLR, & MIDBLK_COMPRESS, MID_RANK, BUILDQ, (I.EQ.1), (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN J_RANK(JJ) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN IF (ACC_LRB%K.GT.0) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (JJ.EQ.FRFR_UPDATES) THEN CALL DMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K IF (COMPRESSED_FR) THEN J_RANK(JJ) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) ELSE allocate(POS_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,CURRENT_BLR POS_LIST(II+1)=POS_LIST(II)+J_RANK(II-1) ENDDO allocate(RANK_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,CURRENT_BLR+1 RANK_LIST(II) = J_RANK(II-1) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & CURRENT_BLR+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = floor(dble(ACC_LRB%M*ACC_LRB%N)/dble(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ALLOC_LRB_FROM_ACC(ACC_LRB, NEXT_BLR_L(I-1), & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, 0, & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE ACC_LRB%K = 0 ELSE IF (I.NE.1) NEXT_BLR_L(I-1)%ISLR=.FALSE. CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) ENDIF ENDIF 100 CONTINUE ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif END SUBROUTINE DMUMPS_BLR_UPD_PANEL_LEFT_LDLT SUBROUTINE DMUMPS_BLR_UPD_PANEL_LEFT( & A, LA, POSELT, NFRONT, IWHANDLER, LorU, & BEGS_BLR, BEGS_BLR_U, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, NIV, SYM, & LBANDSLAVE, IFLAG, IERROR, ISHIFT, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, & MAXI_CLUSTER, MAXI_RANK, & K474, FSorCB, BLR_U_COL, KEEP8, & FIRST_BLOCK, BEG_I_IN, END_I_IN) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS, & CURRENT_BLR, IWHANDLER, LorU, & NELIM, NIV, SYM, K480, K479, K478, & MAXI_CLUSTER, MAXI_RANK, & KPERCENT_LUA, KPERCENT, ISHIFT, & K474, FSorCB LOGICAL, intent(in) :: LBANDSLAVE DOUBLE PRECISION, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:) INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER,intent(inout) :: IFLAG, IERROR INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:), NEXT_BLR(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES, & NB_DEC, FR_RANK, MAXRANK, BEG_I, END_I INTEGER :: I,II,J,JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX INTEGER :: MID_RANK, allocok INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) LOGICAL :: BUILDQ, COMPRESSED_FR #if ! defined(BLR_NOOPENMP) INTEGER :: OMP_NUM INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) IF (NIV.EQ.2.AND.LorU.EQ.0) THEN IF (LBANDSLAVE) THEN NB_BLOCKS_PANEL = NB_BLR ELSE NB_BLOCKS_PANEL = NPARTSASS-CURRENT_BLR ENDIF ELSE NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR ENDIF ACC_LRB => ACC_LUA(1) IF (K480.GE.5) THEN IF (NB_BLOCKS_PANEL.GT.1) THEN CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & LorU, & CURRENT_BLR+1, NEXT_BLR) ENDIF IF (.not.(present(FIRST_BLOCK))) THEN write(*,*) "Internal error in & DMUMPS_BLR_UPD_PANEL_LEFT: KEEP(480)=",K480, & ">=5, but FIRST_BLOCK argument is missing" CALL MUMPS_ABORT() ENDIF ENDIF IF (LorU.EQ.0) THEN BEG_I = 1 ELSE BEG_I = 2 ENDIF END_I = NB_BLOCKS_PANEL IF (K474.EQ.3) THEN IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN - CURRENT_BLR ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN - CURRENT_BLR ENDIF ENDIF #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ, !$OMP& BLR_U, BLR_L, J_ORDER, J_RANK, K_MAX, !$OMP& IND_U, IND_L, OMP_NUM, ACC_LRB, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, FR_RANK, COMPRESSED_FR) #endif DO I = BEG_I, END_I IF (IFLAG.LT.0) CYCLE #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif IF (LorU.EQ.0) THEN IF (LBANDSLAVE) THEN POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(I+1)-1),8) & + int(BEGS_BLR_U(2)+ISHIFT-1,8) ACC_LRB%N = BEGS_BLR(I+2)-BEGS_BLR(I+1) ACC_LRB%M = BEGS_BLR_U(3)-BEGS_BLR_U(2) IF (K474.GE.2) THEN BLR_U => BLR_U_COL ENDIF ELSE POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR(CURRENT_BLR+1)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+I+1) & -BEGS_BLR(CURRENT_BLR+I) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) ENDIF ELSE POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+1)-1),8) & + int(BEGS_BLR(CURRENT_BLR+I)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+I+1)-BEGS_BLR(CURRENT_BLR+I) ENDIF MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 COMPRESSED_FR = .FALSE. IF (K480.EQ.2) THEN DO J = 1, CURRENT_BLR J_ORDER(J) = J ENDDO ELSE CALL DMUMPS_GET_LUA_ORDER(CURRENT_BLR, J_ORDER, J_RANK, & IWHANDLER, & 0, 0, I, LorU, & FRFR_UPDATES, & LBANDSLAVE, K474, BLR_U_COL) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL DMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, LorU, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF ENDIF NB_DEC = FRFR_UPDATES DO JJ = 1, CURRENT_BLR J = J_ORDER(JJ) K_MAX = J_RANK(JJ) IF (LorU.EQ.0) THEN IF (LBANDSLAVE) THEN IND_L = I IF (K474.LT.2) THEN IND_U = CURRENT_BLR+1-J ELSE IND_U = J ENDIF ELSE IND_L = CURRENT_BLR+I-J IND_U = CURRENT_BLR+1-J ENDIF ELSE IND_L = CURRENT_BLR+1-J IND_U = CURRENT_BLR+I-J ENDIF CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & J, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (.NOT.LBANDSLAVE.OR.K474.LT.2) THEN CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, & J, BLR_U) ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = JJ-1 CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL DMUMPS_LRGEMM4(MONE, & BLR_U(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_INCB, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=LorU, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER & ) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_U(IND_U)%M, BLR_U(IND_U)%N, & BLR_U(IND_U)%K, BLR_U(IND_U)%ISLR, BLR_L(IND_L)%M, & BLR_L(IND_L)%N, BLR_L(IND_L)%K, BLR_L(IND_L)%ISLR, & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN J_RANK(JJ) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (JJ.EQ.FRFR_UPDATES) THEN CALL DMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, LorU, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K IF (COMPRESSED_FR) THEN J_RANK(JJ) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF ENDIF ENDIF ENDIF ENDDO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) ELSE allocate(POS_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,CURRENT_BLR POS_LIST(II+1)=POS_LIST(II)+J_RANK(II-1) ENDDO allocate(RANK_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,CURRENT_BLR+1 RANK_LIST(II) = J_RANK(II-1) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & CURRENT_BLR+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(dble(ACC_LRB%M*ACC_LRB%N)/dble(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ALLOC_LRB_FROM_ACC(ACC_LRB, NEXT_BLR(I-1), & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, LorU, & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE ACC_LRB%K = 0 ELSE IF (I.NE.1) NEXT_BLR(I-1)%ISLR=.FALSE. CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) ENDIF ENDIF 100 CONTINUE ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO NOWAIT #endif END SUBROUTINE DMUMPS_BLR_UPD_PANEL_LEFT SUBROUTINE DMUMPS_BLR_UPD_CB_LEFT_LDLT(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR_DYN, NB_INCB, NB_INASM, NASS, & IWHANDLER, & IW2, BLOCK, ACC_LUA, & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, KEEP8) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_INCB, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & MAXI_RANK, K480, K479, K478, NASS, & KPERCENT_LUA, KPERCENT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER, DIMENSION(:) :: BEGS_BLR_DYN DOUBLE PRECISION, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, intent(in) :: IW2(*) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: M, N, allocok INTEGER :: I, II, J, K, KK, IND_L, IND_U, K_MAX, IBIS, & K_ORDER(NB_INASM), K_RANK(NB_INASM), NB_DEC INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) INTEGER(8) :: POSELT_BLOCK, POSELTD INTEGER :: MID_RANK, FRFR_UPDATES, MAXRANK, FR_RANK LOGICAL :: BUILDQ, COMPRESSED_FR TYPE(LRB_TYPE), POINTER :: BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK INTEGER :: OFFSET_IW INTEGER :: OMP_NUM #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) ACC_LRB => ACC_LUA(1) OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ, !$OMP& BLR_L, IND_U, IND_L, M, N, K_ORDER, K_RANK, !$OMP& K_MAX, OMP_NUM, ACC_LRB, POSELTD, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, FR_RANK, NB_DEC, II) #endif DO IBIS = 1,NB_INCB*(NB_INCB+1)/2 IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 I = I+NB_INASM J = J+NB_INASM #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 M = BEGS_BLR(I+1)-BEGS_BLR(I) N = BEGS_BLR(J+1)-BEGS_BLR(J) POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR(J)-1,8) ACC_LRB%M = N ACC_LRB%N = M IF (K480.EQ.2) THEN DO K = 1, NB_INASM K_ORDER(K) = K ENDDO ELSE CALL DMUMPS_GET_LUA_ORDER(NB_INASM, K_ORDER, K_RANK, & IWHANDLER, & 1, 1, I, J, & FRFR_UPDATES) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.J)) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL DMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) FR_RANK = ACC_LRB%K MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K ENDIF ENDIF NB_DEC = FRFR_UPDATES DO KK = 1, NB_INASM K = K_ORDER(KK) K_MAX = K_RANK(KK) POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR_DYN(K)-1,8) & + int(BEGS_BLR_DYN(K) - 1,8) OFFSET_IW = BEGS_BLR_DYN(K) IND_L = I-K IND_U = J-K CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & K, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = KK-1 CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, 2) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL DMUMPS_LRGEMM4(MONE, & BLR_L(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_BLOCK, & NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=2, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, & IW2=IW2(OFFSET_IW), & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_L(IND_U)%M, BLR_L(IND_U)%N, & BLR_L(IND_U)%K, BLR_L(IND_U)%ISLR, BLR_L(IND_L)%M, & BLR_L(IND_L)%N, BLR_L(IND_L)%K, BLR_L(IND_L)%ISLR, & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN K_RANK(KK) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN IF (ACC_LRB%K.GT.0) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.J)) THEN IF (KK.EQ.FRFR_UPDATES) THEN CALL DMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) IF (COMPRESSED_FR) THEN K_RANK(KK) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF END DO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) ELSE allocate(POS_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,NB_INASM POS_LIST(II+1)=POS_LIST(II)+K_RANK(II-1) ENDDO allocate(RANK_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,NB_INASM+1 RANK_LIST(II) = K_RANK(II-1) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & NB_INASM+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(dble(ACC_LRB%M*ACC_LRB%N)/dble(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2, & COUNT_FLOPS=.FALSE.) ELSE CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & KEEP8, NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ENDIF 100 CONTINUE END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif END SUBROUTINE DMUMPS_BLR_UPD_CB_LEFT_LDLT SUBROUTINE DMUMPS_BLR_UPD_CB_LEFT(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_INCB, NB_INASM, NASS, & IWHANDLER, NIV, LBANDSLAVE, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & ACC_LUA, K480, K479, K478, KPERCENT_LUA, & KPERCENT, & MAXI_CLUSTER, MAXI_RANK, & K474, FSorCB, BLR_U_COL, COMPRESS_CB, CB_LRB, KEEP8) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_ROWS, NB_INCB, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & MAXI_RANK, KPERCENT_LUA, KPERCENT INTEGER, INTENT(IN) :: K480, K479, K478, NASS, K474, & FSorCB INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U #if defined(MUMPS_NOF2003) TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) #else TYPE(LRB_TYPE), POINTER, intent(inout) :: CB_LRB(:,:) #endif TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:) INTEGER(8) :: KEEP8(150) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT DOUBLE PRECISION,intent(in) :: TOLEPS LOGICAL, intent(in) :: LBANDSLAVE, COMPRESS_CB INTEGER :: M, N, allocok INTEGER :: I, II, J, K, KK, IND_L, IND_U, IBIS, & K_ORDER(NB_INASM), K_RANK(NB_INASM) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) INTEGER(8) :: POSELT_BLOCK INTEGER :: MID_RANK, K_MAX, FRFR_UPDATES, NB_DEC LOGICAL :: BUILDQ, COMPRESSED_FR TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB, LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, MAXRANK, & FR_RANK #if ! defined(BLR_NOOPENMP) INTEGER :: OMP_NUM INTEGER :: CHUNK #endif DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) ACC_LRB => ACC_LUA(1) #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ, !$OMP& BLR_U, BLR_L, IND_U, IND_L, M, N, !$OMP& ACC_LRB, OMP_NUM, K_MAX, K_ORDER, K_RANK, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, LRB) #endif DO IBIS = 1,NB_ROWS*NB_INCB IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_INCB+1 J = IBIS - (I-1)*NB_INCB IF (.NOT.LBANDSLAVE) THEN I = I+NB_INASM ENDIF J = J+NB_INASM #if ! defined(BLR_NOOPENMP) OMP_NUM=0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 IF (LBANDSLAVE) THEN M = BEGS_BLR(I+2)-BEGS_BLR(I+1) IF (K474.EQ.1) THEN POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I+1)-1,8) & +int(NASS,8) + int(BEGS_BLR_U(J-NB_INASM+1)-1,8) N = BEGS_BLR_U(J-NB_INASM+2)-BEGS_BLR_U(J-NB_INASM+1) ELSEIF (K474.GE.2) THEN BLR_U => BLR_U_COL POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I+1)-1,8) & + int(NASS-1,8) N = BEGS_BLR_U(3)-BEGS_BLR_U(2) ELSE write(*,*) 'Internal error in DMUMPS_BLR_UPD_CB_LEFT', & LBANDSLAVE,K474 CALL MUMPS_ABORT() ENDIF ELSE M = BEGS_BLR(I+1)-BEGS_BLR(I) POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR_U(J)-1,8) N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ENDIF ACC_LRB%M = N ACC_LRB%N = M IF (K480.EQ.2) THEN DO K = 1, NB_INASM K_ORDER(K) = K ENDDO ELSE CALL DMUMPS_GET_LUA_ORDER(NB_INASM, K_ORDER, K_RANK, & IWHANDLER, & 0, 1, I, J, & FRFR_UPDATES, & LBANDSLAVE, K474, BLR_U_COL) ENDIF COMPRESSED_FR = .FALSE. FR_RANK = 0 DO KK = 1, NB_INASM IF ((K480.GE.5.OR.COMPRESS_CB).AND.I.NE.J) THEN IF (KK-1.EQ.FRFR_UPDATES) THEN CALL DMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) IF (COMPRESSED_FR) THEN K_RANK(KK) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF K = K_ORDER(KK) K_MAX = K_RANK(KK) IF (LBANDSLAVE) THEN IND_L = I IF (K474.LT.2) THEN IND_U = J-K ELSE IND_U = K ENDIF ELSE IND_L = I-K IND_U = J-K ENDIF CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & K, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (.NOT.LBANDSLAVE.OR.K474.LT.2) THEN CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, & K, BLR_U) ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN COMPRESSED_FR = .FALSE. NB_DEC = KK-1 CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, 2) MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL DMUMPS_LRGEMM4(MONE, & BLR_U(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_BLOCK, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=2, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_U(IND_U)%M, BLR_U(IND_U)%N, & BLR_U(IND_U)%K, BLR_U(IND_U)%ISLR, BLR_L(IND_L)%M, & BLR_L(IND_L)%N, BLR_L(IND_L)%K, BLR_L(IND_L)%ISLR, & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN K_RANK(KK) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF END DO IF (K480.GE.3) THEN IF (K480.GE.5.OR.COMPRESS_CB) THEN IF (K480.GE.5.AND.(COMPRESSED_FR.OR.K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) ELSE allocate(POS_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,NB_INASM POS_LIST(II+1)=POS_LIST(II)+K_RANK(II-1) ENDDO allocate(RANK_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,NB_INASM+1 RANK_LIST(II) = K_RANK(II-1) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & NB_INASM+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(dble(ACC_LRB%M*ACC_LRB%N)/dble(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN LRB => CB_LRB(I-NB_INASM,J-NB_INASM) CALL ALLOC_LRB_FROM_ACC(ACC_LRB, LRB, & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, 0, & IFLAG, IERROR, KEEP8) CALL UPD_MRY_CB_LRGAIN(LRB%M, LRB%N, LRB%K & ) ACC_LRB%K = 0 IF (IFLAG.LT.0) GOTO 100 ELSE CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) LRB => CB_LRB(I-NB_INASM,J-NB_INASM) CALL ALLOC_LRB(LRB, ACC_LRB%K, ACC_LRB%N, ACC_LRB%M, & .FALSE., IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 100 DO II=1,ACC_LRB%N LRB%Q(II,1:ACC_LRB%M) = & A( POSELT_BLOCK+int((II-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((II-1),8)*int(NFRONT,8) & +int(ACC_LRB%M-1,8) ) END DO ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & KEEP8,NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ENDIF 100 CONTINUE END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF (COMPRESS_CB) THEN CALL UPD_MRY_CB_FR(NFRONT-NASS, NFRONT-NASS, 0) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER #endif END SUBROUTINE DMUMPS_BLR_UPD_CB_LEFT SUBROUTINE DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, DECOMP_TIMER, & BEG_I_IN, END_I_IN, ONLY_NELIM_IN & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: COPY_DENSE_BLOCKS INTEGER, intent(in) :: NB_BLR, CURRENT_BLR INTEGER, intent(in) :: BEGS_BLR_DIAG, & BEGS_BLR_FIRST_OFFDIAG TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(:) CHARACTER(len=1) :: DIR INTEGER, intent(in) :: LDA11, LDA21 INTEGER, intent(in) :: DECOMP_TIMER INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN, ONLY_NELIM_IN INTEGER :: IP, M, N, BIP, BIP_START, BEG_I, END_I, ONLY_NELIM #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif INTEGER :: K, I DOUBLE PRECISION :: PROMOTE_COST INTEGER(8) :: POSELT_BLOCK, LD_BLK_IN_FRONT DOUBLE PRECISION :: ONE, ALPHA, ZERO PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) PARAMETER (ZERO = 0.0D0) IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN ELSE BEG_I = CURRENT_BLR+1 ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN ELSE END_I = NB_BLR ENDIF IF(present(ONLY_NELIM_IN)) THEN ONLY_NELIM = ONLY_NELIM_IN ELSE ONLY_NELIM = 0 ENDIF LD_BLK_IN_FRONT = int(LDA11,8) BIP_START = BEGS_BLR_FIRST_OFFDIAG IF (BEG_I .NE. CURRENT_BLR+1) THEN DO I = 1, BEG_I - CURRENT_BLR - 1 BIP_START = BIP_START + BLR_PANEL(I)%M ENDDO ENDIF #if defined(BLR_NOOPENMP) BIP = BIP_START #endif #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC, CHUNK) #endif DO IP = BEG_I, END_I #if ! defined(BLR_NOOPENMP) BIP = BIP_START DO I = BEG_I, IP-1 BIP = BIP + BLR_PANEL(I-CURRENT_BLR)%M ENDDO #endif IF (DIR .eq. 'V') THEN IF (BIP .LE. LDA21) THEN POSELT_BLOCK = POSELT + int(LDA11,8)*int(BIP-1,8) + & int(BEGS_BLR_DIAG - 1,8) ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(LDA21,8)+ & int(BEGS_BLR_DIAG - 1,8) POSELT_BLOCK = POSELT_BLOCK + & int(LDA21,8)*int(BIP-1-LDA21,8) LD_BLK_IN_FRONT=int(LDA21,8) ENDIF ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(BEGS_BLR_DIAG-1,8) & + int(BIP-1,8) ENDIF M = BLR_PANEL(IP-CURRENT_BLR)%M N = BLR_PANEL(IP-CURRENT_BLR)%N IF(present(ONLY_NELIM_IN)) THEN ONLY_NELIM = ONLY_NELIM_IN ELSE ONLY_NELIM = N ENDIF K = BLR_PANEL(IP-CURRENT_BLR)%K IF (BLR_PANEL(IP-CURRENT_BLR)%ISLR) THEN IF (K.EQ.0) THEN IF (DIR .eq. 'V') THEN DO I = 1, M IF (BIP+I-1.GT.LDA21) THEN LD_BLK_IN_FRONT = int(LDA21,8) ENDIF A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT & + int(N-1,8)) = ZERO ENDDO ELSE DO I = N-ONLY_NELIM+1, N A(POSELT_BLOCK+int(I-1,8)*int(LDA11,8): & POSELT_BLOCK+int(I-1,8)*int(LDA11,8) + int(M-1,8)) & = ZERO ENDDO ENDIF GOTO 1800 ENDIF IF (DIR .eq. 'V') THEN IF (DIR .eq.'V' .AND. BIP .LE. LDA21 & .AND. BIP + M - 1 .GT. LDA21) THEN CALL dgemm('T', 'T', N, LDA21-BIP+1, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) CALL dgemm('T', 'T', N, BIP+M-LDA21-1, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(LDA21-BIP+2,1) , M, & ZERO, A(POSELT_BLOCK+int(LDA21-BIP,8)*int(LDA11,8)), & LDA21) ELSE CALL dgemm('T', 'T', N, M, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) ENDIF ELSE CALL dgemm('N', 'N', M, ONLY_NELIM, K, ONE, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1), M, & BLR_PANEL(IP-CURRENT_BLR)%R(1,N-ONLY_NELIM+1), K, ZERO, & A(POSELT_BLOCK+int(N-ONLY_NELIM,8)*int(LDA11,8)), LDA11) ENDIF PROMOTE_COST = 2.0D0*M*K*ONLY_NELIM IF(present(ONLY_NELIM_IN)) THEN CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .FALSE.) ENDIF ELSE IF (COPY_DENSE_BLOCKS) THEN IF (DIR .eq. 'V') THEN DO I = 1, M IF (BIP+I-1.GT.LDA21) THEN LD_BLK_IN_FRONT = int(LDA21,8) ENDIF A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT & + int(N-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N) ENDDO ELSE DO I = N-ONLY_NELIM+1, N A(POSELT_BLOCK+int(I-1,8)*int(LDA11,8): & POSELT_BLOCK+int(I-1,8)*int(LDA11,8) + int(M-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) ENDDO ENDIF ENDIF 1800 CONTINUE #if defined(BLR_NOOPENMP) BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif END SUBROUTINE DMUMPS_DECOMPRESS_PANEL SUBROUTINE DMUMPS_COMPRESS_CB(A, LA, POSELT, LDA, & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY, & NELIM, & NBROWSinF & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & KPERCENT, TOL_OPT, LWORK INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), TARGET, intent(inout) :: CB_LRB(:,:) INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U DOUBLE PRECISION, TARGET, DIMENSION(:) :: RWORK DOUBLE PRECISION, TARGET, DIMENSION(:,:) :: BLOCK DOUBLE PRECISION, TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER(8) :: KEEP8(150) DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500) DOUBLE PRECISION, OPTIONAL :: M_ARRAY(max(NFS4FATHER,1)) INTEGER, intent(in), OPTIONAL :: NELIM INTEGER, intent(in), OPTIONAL :: NBROWSinF INTEGER :: M, N, INFO INTEGER :: I, J, IBIS, IBIS_END, RANK, MAXRANK, II, JJ INTEGER(8) :: POSELT_BLOCK LOGICAL :: ISLR TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: OMP_NUM INTEGER(8) :: POSA, ASIZE INTEGER :: NROWS_CM #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif DOUBLE PRECISION, POINTER, DIMENSION(:) :: RWORK_THR DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: BLOCK_THR DOUBLE PRECISION, POINTER, DIMENSION(:) :: WORK_THR, TAU_THR INTEGER, POINTER, DIMENSION(:) :: JPVT_THR DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & (NFS4FATHER.GT.0) ) THEN IF (NIV.EQ.1) THEN NROWS_CM = NROWS - (NFS4FATHER-NELIM) ELSE NROWS_CM = NROWS - NBROWSinF ENDIF IF (NROWS_CM-NVSCHUR_K253.GT.0) THEN IF (NIV.EQ.1) THEN POSA = POSELT & + int(LDA,8)*int(NPIV+NFS4FATHER,8) & + int(NPIV,8) ASIZE = int(LDA,8)*int(LDA,8) & - int(LDA,8)*int(NPIV+NFS4FATHER,8) & - int(NPIV,8) ELSE POSA = POSELT & + int(LDA,8)*int(NBROWSinF,8) & + int(NPIV,8) ASIZE = int(NROWS,8)*int(LDA,8) & - int(LDA,8)*int(NBROWSinF,8) & - int(NPIV,8) ENDIF CALL DMUMPS_COMPUTE_MAXPERCOL ( & A(POSA), ASIZE, LDA, & NROWS_CM-NVSCHUR_K253, & M_ARRAY(1), NFS4FATHER, .FALSE., & -9999) ELSE DO I=1, NFS4FATHER M_ARRAY(I) = ZERO ENDDO ENDIF ENDIF #if ! defined(BLR_NOOPENMP) !$OMP END MASTER !$OMP BARRIER #endif IF (SYM.EQ.0.OR.NIV.EQ.2) THEN IBIS_END = NB_ROWS*NB_COLS ELSE IBIS_END = NB_ROWS*(NB_COLS+1)/2 ENDIF #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELT_BLOCK, M, N, OMP_NUM, INFO, RANK, !$OMP& MAXRANK, ISLR, II, JJ, LRB) #endif DO IBIS = 1,IBIS_END IF (IFLAG.LT.0) CYCLE OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) WORK_THR => WORK(OMP_NUM*LWORK+1: & (OMP_NUM+1)*LWORK) RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: & (OMP_NUM+1)*2*MAXI_CLUSTER) IF (SYM.EQ.0.OR.NIV.EQ.2) THEN I = (IBIS-1)/NB_COLS+1 J = IBIS - (I-1)*NB_COLS ELSE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 ENDIF IF (NIV.EQ.1) THEN I = I+NB_INASM J = J+NB_INASM ELSE J = J+NB_INASM IF (SYM.NE.0) THEN IF (BEGS_BLR_U(J).GE.BEGS_BLR(I+2)+NCOLS-NROWS-1+ & BEGS_BLR_U(NB_INASM+1)) THEN CYCLE ENDIF ENDIF ENDIF IF (NIV.EQ.1) THEN M = BEGS_BLR(I+1)-BEGS_BLR(I) POSELT_BLOCK = POSELT + int(LDA,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR_U(J)-1,8) IF (I .EQ. NB_INASM+1 .AND. present(NELIM)) THEN POSELT_BLOCK = POSELT_BLOCK + int(NELIM,8)*int(LDA,8) M = M - NELIM ENDIF N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ELSE M = BEGS_BLR(I+2)-BEGS_BLR(I+1) POSELT_BLOCK = POSELT + int(LDA,8)*int(BEGS_BLR(I+1)-1,8) & + int(BEGS_BLR_U(J)-1,8) IF (SYM.EQ.0) THEN N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ELSE N = min(BEGS_BLR_U(J+1), BEGS_BLR(I+2) + NCOLS - NROWS -1 & + BEGS_BLR_U(NB_INASM+1)) - BEGS_BLR_U(J) ENDIF ENDIF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (NIV.EQ.1) THEN LRB => CB_LRB(I-NB_INASM,J-NB_INASM) ELSE LRB => CB_LRB(I,J-NB_INASM) ENDIF IF (K489.EQ.3) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 ISLR = .FALSE. GOTO 3800 ENDIF DO II=1,M BLOCK_THR(II,1:N)= & A( POSELT_BLOCK+int(II-1,8)*int(LDA,8) : & POSELT_BLOCK+int(II-1,8)*int(LDA,8)+int(N-1,8) ) ENDDO MAXRANK = floor(dble(M*N)/dble(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL DMUMPS_TRUNCATED_RRQR( M, N, & BLOCK_THR(1,1), & MAXI_CLUSTER, JPVT_THR(1), & TAU_THR(1), & WORK_THR(1), N, & RWORK_THR(1), & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO, & ISLR) 3800 CONTINUE IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A CB BLOCK" CALL MUMPS_ABORT() END IF CALL ALLOC_LRB(LRB, RANK, M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF (ISLR) THEN IF (RANK .GT. 0) THEN DO JJ=1,N DO II=1,MIN(RANK,JJ) LRB%R(II,JPVT_THR(JJ)) = BLOCK_THR(II,JJ) ENDDO IF(JJ.LT.RANK) LRB%R(MIN(RANK,JJ)+1:RANK,JPVT_THR(JJ)) & = ZERO ENDDO CALL dorgqr & (M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & WORK_THR(1), LWORK, INFO ) DO II=1,RANK DO JJ= 1, M LRB%Q(JJ,II) = BLOCK_THR(JJ,II) ENDDO END DO IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNGQR WHILE COMPRESSING A CB BLOCK" CALL MUMPS_ABORT() END IF IF (K489.NE.3) THEN CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, & LRB%ISLR, CB_COMPRESS=.TRUE.) ENDIF END IF CALL UPD_MRY_CB_LRGAIN(LRB%M, LRB%N, LRB%K & ) ELSE DO II=1,M LRB%Q(II,1:N) = & A( POSELT_BLOCK+int((II-1),8)*int(LDA,8) : & POSELT_BLOCK+int((II-1),8)*int(LDA,8) & +int(N-1,8) ) END DO IF (K489.NE.3) THEN CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, & LRB%ISLR, CB_COMPRESS=.TRUE.) ENDIF LRB%K = -1 END IF END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO #endif #if ! defined(BLR_NOOPENMP) !$OMP MASTER #endif CALL UPD_MRY_CB_FR(NROWS, NCOLS, SYM) #if ! defined(BLR_NOOPENMP) !$OMP END MASTER #endif END SUBROUTINE DMUMPS_COMPRESS_CB SUBROUTINE DMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K458, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8, & K480, BEG_I_IN, END_I_IN, FRSWAP & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), TARGET, intent(inout) :: BLR_PANEL(:) DOUBLE PRECISION, TARGET, DIMENSION(:) :: RWORK DOUBLE PRECISION, TARGET, DIMENSION(:,:) :: BLOCK DOUBLE PRECISION, TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER :: BEGS_BLR(:) INTEGER(8) :: KEEP8(150) INTEGER, OPTIONAL, intent(in) :: K480 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN LOGICAL, OPTIONAL, intent(in) :: FRSWAP INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, & K458, K473, TOL_OPT LOGICAL, intent(in) :: LBANDSLAVE INTEGER :: MAXI_CLUSTER, LWORK, NELIM DOUBLE PRECISION,intent(in) :: TOLEPS CHARACTER(len=1) :: DIR INTEGER :: IP, NB_BLOCKS_PANEL, M, N, RANK, MAXRANK INTEGER :: INFO, I, J, K, IS, BEG_I, END_I INTEGER(8) :: POSELT_BLOCK LOGICAL :: ISLR DOUBLE PRECISION :: ONE, ALPHA, ZERO PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) PARAMETER (ZERO = 0.0D0) TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: OMP_NUM DOUBLE PRECISION, POINTER, DIMENSION(:) :: RWORK_THR DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: BLOCK_THR DOUBLE PRECISION, POINTER, DIMENSION(:) :: WORK_THR, TAU_THR INTEGER, POINTER, DIMENSION(:) :: JPVT_THR #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN ELSE BEG_I = CURRENT_BLR+1 ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN ELSE END_I = NB_BLR ENDIF IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS=0 ENDIF IF (DIR .eq. 'V') THEN IF (LBANDSLAVE) THEN N = NPIV ELSE N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ENDIF ELSE IF (DIR .eq. 'H') THEN N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ELSE WRITE(*,*) " WRONG ARGUMENT IN DMUMPS_COMPRESS_PANEL " CALL MUMPS_ABORT() END IF NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR OMP_NUM = 0 #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO PRIVATE(INFO, POSELT_BLOCK, RANK, MAXRANK, I, J, OMP_NUM, LRB) !$OMP& SCHEDULE(DYNAMIC,CHUNK) #endif DO IP = BEG_I, END_I IF (IFLAG.LT.0) CYCLE #if ! defined(BLR_NOOPENMP) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) WORK_THR => WORK(OMP_NUM*LWORK+1: & (OMP_NUM+1)*LWORK) RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: & (OMP_NUM+1)*2*MAXI_CLUSTER) LRB => BLR_PANEL(IP-CURRENT_BLR) RANK = 0 M = BEGS_BLR(IP+1)-BEGS_BLR(IP) IF (DIR .eq. 'V') THEN POSELT_BLOCK = POSELT + & int(NFRONT,8) * int(BEGS_BLR(IP)-1,8) + & int(BEGS_BLR(CURRENT_BLR) + IS - 1,8) ELSE POSELT_BLOCK = POSELT + & int(NFRONT,8)*int(BEGS_BLR(CURRENT_BLR)-1,8) + & int( BEGS_BLR(IP) - 1,8) ENDIF IF (present(K480)) then IF (K480.GE.5) THEN IF (LRB%ISLR) THEN IF (M.NE.LRB%M) THEN write(*,*) 'Internal error in DMUMPS_COMPRESS_PANEL', & ' M size inconsistency',M, & LRB%M CALL MUMPS_ABORT() ENDIF IF (N.NE.LRB%N) THEN write(*,*) 'Internal error in DMUMPS_COMPRESS_PANEL', & ' N size inconsistency',N, & LRB%N CALL MUMPS_ABORT() ENDIF MAXRANK = floor(dble(M*N)/dble(M+N)) IF (LRB%K.GT.MAXRANK) THEN write(*,*) 'Internal error in DMUMPS_COMPRESS_PANEL', & ' MAXRANK inconsistency',MAXRANK, & LRB%K CALL MUMPS_ABORT() ENDIF GOTO 3000 ENDIF ENDIF ENDIF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (K473.EQ.1 .OR. IP .LT. BEG_I+K458) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 ISLR = .FALSE. GOTO 3800 ENDIF IF (DIR .eq. 'V') THEN DO I=1,M BLOCK_THR(I,1:N)= & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(N-1,8) ) END DO ELSE DO I=1,N BLOCK_THR(1:M,I)= & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) END DO END IF MAXRANK = floor(dble(M*N)/dble(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL DMUMPS_TRUNCATED_RRQR( M, N, & BLOCK_THR(1,1), & MAXI_CLUSTER, JPVT_THR(1), & TAU_THR(1), & WORK_THR(1), N, & RWORK_THR(1), & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO, & ISLR) 3800 CONTINUE IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF CALL ALLOC_LRB(LRB, RANK, & M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF ((M.EQ.0).OR.(N.EQ.0)) THEN GOTO 3000 ENDIF IF (ISLR) THEN IF (RANK .EQ. 0) THEN ELSE DO J=1,N DO K=1,min(RANK,J) LRB%R(K, JPVT_THR(J)) = BLOCK_THR(K,J) ENDDO IF(J.LT.RANK) THEN LRB%R(J+1:RANK,JPVT_THR(J)) = ZERO ENDIF ENDDO CALL dorgqr & (M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & WORK_THR(1), LWORK, INFO ) DO I=1,RANK DO K=1,M LRB%Q(K,I) = BLOCK_THR(K,I) ENDDO END DO IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNGQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF IF (present(FRSWAP)) THEN CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, LRB%ISLR, & FRSWAP=FRSWAP) ELSE CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, LRB%ISLR) ENDIF END IF ELSE IF (DIR .eq. 'V') THEN DO I=1,M LRB%Q(I,1:N) = & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) & +int(N-1,8) ) END DO ELSE DO I=1,N LRB%Q(1:M,I) = & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) & +int(M-1,8) ) END DO END IF IF (K473.EQ.0) THEN IF (present(FRSWAP)) THEN CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, LRB%ISLR, & FRSWAP=FRSWAP) ELSE CALL UPD_FLOP_COMPRESS(LRB%M, LRB%N, LRB%K, LRB%ISLR) ENDIF ENDIF LRB%K = -1 END IF 3000 CONTINUE END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO NOWAIT #endif RETURN END SUBROUTINE DMUMPS_COMPRESS_PANEL SUBROUTINE DMUMPS_BLR_PANEL_LRTRSM( & A, & LA, POSELT, NFRONT, & IBEG_BLOCK, NB_BLR, & BLR_LorU, & CURRENT_BLR, FIRST_BLOCK, LAST_BLOCK, & NIV, SYM, LorU, LBANDSLAVE, & IW, OFFSET_IW, NASS) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & NIV, SYM, LorU LOGICAL, intent(in) :: LBANDSLAVE INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: IBEG_BLOCK, FIRST_BLOCK, LAST_BLOCK INTEGER, OPTIONAL, intent(in) :: NASS DOUBLE PRECISION, intent(inout) :: A(LA) TYPE(LRB_TYPE), intent(inout) :: BLR_LorU(:) INTEGER, OPTIONAL :: OFFSET_IW INTEGER, OPTIONAL :: IW(*) INTEGER(8) :: POSELT_LOCAL INTEGER :: IP, LDA #if ! defined(BLR_NOOPENMP) INTEGER :: CHUNK #endif DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) LDA = NFRONT IF (LorU.EQ.0.AND.SYM.NE.0.AND.NIV.EQ.2 & .AND.(.NOT.LBANDSLAVE)) THEN IF (present(NASS)) THEN LDA = NASS ELSE write(*,*) 'Internal error in DMUMPS_BLR_PANEL_LRTRSM' CALL MUMPS_ABORT() ENDIF ENDIF IF (LBANDSLAVE) THEN POSELT_LOCAL = POSELT ELSE POSELT_LOCAL = POSELT + & int(IBEG_BLOCK-1,8)*int(LDA,8) + int(IBEG_BLOCK - 1,8) ENDIF #if ! defined(BLR_NOOPENMP) CHUNK = 1 !$OMP DO !$OMP& SCHEDULE(DYNAMIC,CHUNK) #endif DO IP = FIRST_BLOCK, LAST_BLOCK CALL DMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA, & BLR_LorU(IP-CURRENT_BLR), NIV, SYM, LorU, & IW, OFFSET_IW) END DO #if ! defined(BLR_NOOPENMP) !$OMP END DO NOWAIT #endif END SUBROUTINE DMUMPS_BLR_PANEL_LRTRSM END MODULE DMUMPS_FAC_LR MUMPS_5.8.1/src/sfac_mem_compress_cb.F0000664000175000017500000005037215042446437017505 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SIZEFREEINREC(IW,LREC,SIZE_FREE,XSIZE) IMPLICIT NONE INTEGER, intent(in) :: LREC, XSIZE INTEGER, intent(in) :: IW(LREC) INTEGER(8), intent(out):: SIZE_FREE INTEGER(8) :: SIZE_STA, SIZE_DYN INCLUDE 'mumps_headers.h' CALL MUMPS_GETI8( SIZE_STA,IW(1+XXR) ) CALL MUMPS_GETI8( SIZE_DYN,IW(1+XXD) ) IF ( SIZE_DYN .GT. 0) THEN SIZE_FREE = SIZE_STA ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG .OR. & IW(1+XXS).EQ.S_NOLCBNOCONTIG) THEN SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE+3),8) ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG38 .OR. & IW(1+XXS).EQ.S_NOLCBNOCONTIG38) THEN SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE)+ & IW(1+XSIZE + 3) - & ( IW(1+XSIZE + 4) & - IW(1+XSIZE + 3) ), 8) ELSE IF (IW(1+XXS).EQ.S_NOLNOCB) THEN SIZE_FREE = SIZE_STA ELSE SIZE_FREE=0_8 ENDIF RETURN END SUBROUTINE SMUMPS_SIZEFREEINREC SUBROUTINE SMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, IW, XSIZE, KEEP216) IMPLICIT NONE LOGICAL, INTENT(out) :: RECORD_CAN_BE_COMPRESSED INTEGER, INTENT(in) :: XSIZE, KEEP216 INTEGER, INTENT(in) :: IW(XSIZE) INCLUDE 'mumps_headers.h' INTEGER(8) :: SIZE_DYN, SIZE_STA CALL MUMPS_GETI8( SIZE_STA, IW(1+XXR)) CALL MUMPS_GETI8( SIZE_DYN, IW(1+XXD)) IF (IW(1+XXS) .EQ. S_FREE) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE IF ( SIZE_DYN .GT. 0_8 .AND. SIZE_STA .GT. 0_8) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE IF ( IW(1+XXS) .EQ. S_NOLNOCB) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE RECORD_CAN_BE_COMPRESSED = & ( IW(1+XXS) .EQ. S_NOLCBNOCONTIG .OR. & IW(1+XXS) .EQ. S_NOLCBCONTIG .OR. & IW(1+XXS) .EQ. S_NOLCBNOCONTIG38 .OR. & IW(1+XXS) .EQ. S_NOLCBCONTIG38 ) & .AND. KEEP216.NE.3 ENDIF RETURN END SUBROUTINE SMUMPS_CAN_RECORD_BE_COMPRESSED SUBROUTINE SMUMPS_MOVETONEXTRECORD &(IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER(8) :: RCURRENT INTEGER LIW,IXXP,ICURRENT,NEXT,ISIZE2SHIFT INTEGER IW(LIW) INTEGER(8) :: RSIZE ICURRENT=NEXT CALL MUMPS_GETI8( RSIZE, IW(ICURRENT + XXR) ) RCURRENT = RCURRENT - RSIZE NEXT=IW(ICURRENT+XXP) IW(IXXP)=ICURRENT+ISIZE2SHIFT IXXP=ICURRENT+XXP RETURN END SUBROUTINE SMUMPS_MOVETONEXTRECORD SUBROUTINE SMUMPS_ISHIFT(IW,LIW,BEG2SHIFT,END2SHIFT,ISIZE2SHIFT) IMPLICIT NONE INTEGER LIW, BEG2SHIFT, END2SHIFT, ISIZE2SHIFT INTEGER IW(LIW) INTEGER I IF (ISIZE2SHIFT.GT.0) THEN DO I=END2SHIFT,BEG2SHIFT,-1 IW(I+ISIZE2SHIFT)=IW(I) ENDDO ELSE IF (ISIZE2SHIFT.LT.0) THEN DO I=BEG2SHIFT,END2SHIFT IW(I+ISIZE2SHIFT)=IW(I) ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_ISHIFT SUBROUTINE SMUMPS_RSHIFT(A, LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT) IMPLICIT NONE INTEGER(8) :: LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT REAL A(LA) INTEGER(8) :: I IF (RSIZE2SHIFT.GT.0_8) THEN DO I=END2SHIFT,BEG2SHIFT,-1_8 A(I+RSIZE2SHIFT)=A(I) ENDDO ELSE IF (RSIZE2SHIFT.LT.0_8) THEN DO I=BEG2SHIFT,END2SHIFT A(I+RSIZE2SHIFT)=A(I) ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_RSHIFT SUBROUTINE SMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY: SMUMPS_DM_PAMASTERORPTRAST IMPLICIT NONE INTEGER, INTENT(in) :: N, LIW, XSIZE INTEGER, INTENT(in) :: KEEP(500) INTEGER(8), INTENT(in) :: LA INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS INTEGER, INTENT(inout) :: IWPOSCB INTEGER :: IWPOS INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP(28)), & PIMASTER(KEEP(28)) INTEGER, INTENT(in) :: STEP(N), SLAVEF INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) REAL, INTENT(inout) :: A(LA) INTEGER, INTENT(inout) :: COMP REAL, INTENT(inout) :: ACC_TIME INTEGER, INTENT(in) :: MYID INCLUDE 'mumps_headers.h' INTEGER ICURRENT, NEXT, STATE_NEXT INTEGER(8) :: RCURRENT INTEGER ISIZE2SHIFT INTEGER(8) :: RSIZE2SHIFT INTEGER IBEGCONTIG INTEGER(8) :: RBEGCONTIG INTEGER(8) :: RBEG2SHIFT, REND2SHIFT INTEGER INODE LOGICAL :: IS_PAMASTER, IS_PTRAST INTEGER(8) :: FREE_IN_REC INTEGER(8) :: RCURRENT_SIZE, DYN_SIZE LOGICAL :: RECORD_CAN_BE_COMPRESSED INTEGER IXXP EXTERNAL MPI_WTIME DOUBLE PRECISION MPI_WTIME DOUBLE PRECISION TIME_STRT REAL TIME_COMP TIME_STRT = MPI_WTIME() ISIZE2SHIFT=0 RSIZE2SHIFT=0_8 ICURRENT = LIW-XSIZE+1 RCURRENT = LA+1_8 IBEGCONTIG = -999999 RBEGCONTIG = -999999_8 NEXT = IW(ICURRENT+XXP) IF (NEXT.EQ.TOP_OF_STACK) GOTO 120 COMP=COMP+1 STATE_NEXT = IW(NEXT+XXS) IXXP = ICURRENT+XXP 10 CONTINUE CALL SMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, & IW(NEXT), XSIZE, KEEP(216)) IF ( .NOT. RECORD_CAN_BE_COMPRESSED ) THEN CALL SMUMPS_MOVETONEXTRECORD(IW,LIW, & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) CALL MUMPS_GETI8(DYN_SIZE, IW(ICURRENT+XXD)) CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) IF (IBEGCONTIG < 0) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF IF (RBEGCONTIG < 0_8) THEN RBEGCONTIG=RCURRENT+RCURRENT_SIZE-1_8 ENDIF INODE=IW(ICURRENT+XXN) IF ( DYN_SIZE .EQ. 0_8 ) THEN IF (RSIZE2SHIFT .NE. 0_8) THEN CALL SMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, & KEEP(28), KEEP(199), & INODE, IW(ICURRENT+XXS), & IW(ICURRENT+XXD:ICURRENT+XXD+1), STEP, & DAD, PROCNODE_STEPS, RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF (IS_PTRAST) THEN PTRAST(STEP(INODE))= & PTRAST(STEP(INODE))+RSIZE2SHIFT ELSE IF (IS_PAMASTER) THEN PAMASTER(STEP(INODE))= & PAMASTER(STEP(INODE))+RSIZE2SHIFT ENDIF ENDIF ENDIF IF (ISIZE2SHIFT .NE. 0) THEN IF (PTRIST(STEP(INODE)).EQ.ICURRENT) & PTRIST(STEP(INODE))= & PTRIST(STEP(INODE))+ISIZE2SHIFT IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) & PIMASTER(STEP(INODE))= & PIMASTER(STEP(INODE))+ISIZE2SHIFT ENDIF IF (NEXT .NE. TOP_OF_STACK) THEN STATE_NEXT=IW(NEXT+XXS) GOTO 10 ENDIF ENDIF 20 CONTINUE IF (IBEGCONTIG.NE.0 .AND. ISIZE2SHIFT .NE. 0) THEN CALL SMUMPS_ISHIFT(IW,LIW,ICURRENT,IBEGCONTIG,ISIZE2SHIFT) IF (IXXP .LE.IBEGCONTIG) THEN IXXP=IXXP+ISIZE2SHIFT ENDIF ENDIF IBEGCONTIG=-9999 25 CONTINUE IF (RBEGCONTIG .GT.0_8 .AND. RSIZE2SHIFT .NE. 0_8) THEN CALL SMUMPS_RSHIFT(A,LA,RCURRENT,RBEGCONTIG,RSIZE2SHIFT) ENDIF RBEGCONTIG=-99999_8 30 CONTINUE IF (NEXT.EQ. TOP_OF_STACK) GOTO 100 CALL SMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, IW(NEXT), XSIZE, KEEP(216)) IF ( STATE_NEXT .NE. S_FREE .AND. & RECORD_CAN_BE_COMPRESSED ) THEN IF (RBEGCONTIG > 0_8) GOTO 25 CALL SMUMPS_MOVETONEXTRECORD & (IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IF (IBEGCONTIG < 0 ) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF CALL SMUMPS_SIZEFREEINREC(IW(ICURRENT), & LIW-ICURRENT+1, & FREE_IN_REC, & XSIZE) CALL MUMPS_GETI8(DYN_SIZE, IW(ICURRENT+XXD)) IF (DYN_SIZE .GT. 0_8) THEN ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG) THEN CALL SMUMPS_MAKECBCONTIG(A,LA,RCURRENT, & IW(ICURRENT+XSIZE+2), & IW(ICURRENT+XSIZE), & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), 0, & IW(ICURRENT+XXS),RSIZE2SHIFT) IW(ICURRENT+XXS) = S_NOLCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN CALL SMUMPS_MAKECBCONTIG(A,LA,RCURRENT, & IW(ICURRENT+XSIZE+2), & IW(ICURRENT+XSIZE), & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), & IW(ICURRENT+XSIZE+4)-IW(ICURRENT+XSIZE+3), & IW(ICURRENT+XXS),RSIZE2SHIFT) IW(ICURRENT+XXS) = S_NOLCLEANED38 ELSE IF (STATE_NEXT.EQ.S_NOLNOCB) THEN IW(ICURRENT+XXS) = S_NOLNOCBCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38) THEN IF (STATE_NEXT .EQ. S_NOLCBCONTIG) THEN IW(ICURRENT+XXS) = S_NOLCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG38) THEN IW(ICURRENT+XXS) = S_NOLCLEANED38 ENDIF IF (RSIZE2SHIFT .GT.0_8) THEN RBEG2SHIFT = RCURRENT + FREE_IN_REC CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) REND2SHIFT = RCURRENT + RCURRENT_SIZE - 1_8 CALL SMUMPS_RSHIFT(A, LA, & RBEG2SHIFT, REND2SHIFT, & RSIZE2SHIFT) ENDIF ELSE WRITE(*,*) "Internal error 3 in SMUMPS_COMPRE_NEW", & STATE_NEXT, DYN_SIZE, FREE_IN_REC CALL MUMPS_ABORT() ENDIF INODE = IW(ICURRENT+XXN) IF ( DYN_SIZE .GT. 0_8 ) THEN IF (PTRIST(STEP(INODE)).EQ.ICURRENT) & PTRIST(STEP(INODE))= & PTRIST(STEP(INODE))+ISIZE2SHIFT IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) & PIMASTER(STEP(INODE))= & PIMASTER(STEP(INODE))+ISIZE2SHIFT ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLNOCB ) THEN IF (ISIZE2SHIFT.NE.0) THEN PTRIST(STEP(INODE))=PTRIST(STEP(INODE))+ISIZE2SHIFT ENDIF PTRAST(STEP(INODE))=PTRAST(STEP(INODE))+RSIZE2SHIFT+ & FREE_IN_REC ELSE WRITE(*,*) "Internal error 4 in SMUMPS_COMPRE_NEW", & STATE_NEXT CALL MUMPS_ABORT() ENDIF CALL MUMPS_SUBTRI8TOARRAY(IW(ICURRENT+XXR),FREE_IN_REC) RSIZE2SHIFT=RSIZE2SHIFT+FREE_IN_REC RBEGCONTIG=-9999_8 IF (NEXT.EQ.TOP_OF_STACK) THEN GOTO 20 ELSE STATE_NEXT=IW(NEXT+XXS) ENDIF GOTO 30 ENDIF IF (IBEGCONTIG.GT.0) THEN GOTO 20 ENDIF 40 CONTINUE IF (STATE_NEXT == S_FREE) THEN ICURRENT = NEXT CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT + XXR) ) ISIZE2SHIFT = ISIZE2SHIFT + IW(ICURRENT+XXI) RSIZE2SHIFT = RSIZE2SHIFT + RCURRENT_SIZE RCURRENT = RCURRENT - RCURRENT_SIZE NEXT=IW(ICURRENT+XXP) IF (NEXT.EQ.TOP_OF_STACK) THEN WRITE(*,*) "Internal error 1 in SMUMPS_COMPRE_NEW" CALL MUMPS_ABORT() ENDIF STATE_NEXT = IW(NEXT+XXS) GOTO 40 ENDIF GOTO 10 100 CONTINUE IWPOSCB = IWPOSCB + ISIZE2SHIFT LRLU = LRLU + RSIZE2SHIFT IPTRLU = IPTRLU + RSIZE2SHIFT 120 CONTINUE TIME_COMP = real(MPI_WTIME() - TIME_STRT) IF (KEEP(405).EQ.0) THEN ACC_TIME = ACC_TIME + TIME_COMP ELSE !$OMP ATOMIC UPDATE ACC_TIME = ACC_TIME + TIME_COMP !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE SMUMPS_COMPRE_NEW SUBROUTINE SMUMPS_GET_SIZEHOLE(IREC, IW, LIW, & ISIZEHOLE, RSIZEHOLE) IMPLICIT NONE INTEGER, intent(in) :: IREC, LIW INTEGER, intent(in) :: IW(LIW) INTEGER, intent(out):: ISIZEHOLE INTEGER(8), intent(out) :: RSIZEHOLE INTEGER IRECLOC INTEGER(8) :: RECLOC_SIZE INCLUDE 'mumps_headers.h' ISIZEHOLE=0 RSIZEHOLE=0_8 IRECLOC = IREC + IW( IREC+XXI ) 10 CONTINUE CALL MUMPS_GETI8(RECLOC_SIZE, IW(IRECLOC+XXR)) IF (IW(IRECLOC+XXS).EQ.S_FREE) THEN ISIZEHOLE=ISIZEHOLE+IW(IRECLOC+XXI) RSIZEHOLE=RSIZEHOLE+RECLOC_SIZE IRECLOC=IRECLOC+IW(IRECLOC+XXI) GOTO 10 ENDIF RETURN END SUBROUTINE SMUMPS_GET_SIZEHOLE SUBROUTINE SMUMPS_MAKECBCONTIG(A, LA, RCURRENT, & NROW, NCB, LD, NELIM, NODESTATE, ISHIFT) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER LD, NROW, NCB, NELIM, NODESTATE INTEGER(8) :: ISHIFT INTEGER(8) :: LA, RCURRENT REAL A(LA) INTEGER I,J INTEGER(8) :: IOLD,INEW LOGICAL NELIM_ROOT NELIM_ROOT=.TRUE. IF (NODESTATE.EQ. S_NOLCBNOCONTIG) THEN NELIM_ROOT=.FALSE. IF (NELIM.NE.0) THEN WRITE(*,*) "Internal error 1 IN SMUMPS_MAKECBCONTIG" CALL MUMPS_ABORT() ENDIF ELSE IF (NODESTATE .NE. S_NOLCBNOCONTIG38) THEN WRITE(*,*) "Internal error 2 in SMUMPS_MAKECBCONTIG" & ,NODESTATE CALL MUMPS_ABORT() ENDIF IF (ISHIFT .LT.0_8) THEN WRITE(*,*) "Internal error 3 in SMUMPS_MAKECBCONTIG",ISHIFT CALL MUMPS_ABORT() ENDIF IF (NELIM_ROOT) THEN IOLD=RCURRENT+int(LD,8)*int(NROW,8)+int(NELIM-1-NCB,8) ELSE IOLD = RCURRENT+int(LD,8)*int(NROW,8)-1_8 ENDIF INEW = RCURRENT+int(LD,8)*int(NROW,8)+ISHIFT-1_8 DO I = NROW, 1, -1 IF (I.EQ.NROW .AND. ISHIFT.EQ.0_8.AND. & .NOT. NELIM_ROOT) THEN IOLD=IOLD-int(LD,8) INEW=INEW-int(NCB,8) CYCLE ENDIF IF (NELIM_ROOT) THEN DO J=1,NELIM A( INEW ) = A( IOLD + int(- J + 1,8)) INEW = INEW - 1_8 ENDDO ELSE DO J=1, NCB A( INEW ) = A( IOLD + int(- J + 1, 8)) INEW = INEW - 1_8 ENDDO ENDIF IOLD = IOLD - int(LD,8) ENDDO IF (NELIM_ROOT) THEN NODESTATE=S_NOLCBCONTIG38 ELSE NODESTATE=S_NOLCBCONTIG ENDIF RETURN END SUBROUTINE SMUMPS_MAKECBCONTIG SUBROUTINE SMUMPS_GET_SIZE_NEEDED( & SIZEI_NEEDED, SIZER_NEEDED, SKIP_TOP_STACK, & KEEP, KEEP8, & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR & ) #if ! defined(NODYNAMICCB) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY: SMUMPS_DM_CBSTATIC2DYNAMIC #endif IMPLICIT NONE INTEGER, INTENT(in) :: SIZEI_NEEDED INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: KEEP(500) INTEGER(8), INTENT(inout):: KEEP8(150) INTEGER, INTENT(in) :: N, LIW, XSIZE INTEGER(8), INTENT(in) :: LA INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS INTEGER, INTENT(inout) :: IWPOSCB INTEGER, INTENT(inout) :: IWPOS INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP(28)), & PIMASTER(KEEP(28)) INTEGER, INTENT(in) :: STEP(N), SLAVEF INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) REAL, INTENT(inout) :: A(LA) INTEGER, INTENT(inout) :: COMP REAL, INTENT(inout) :: ACC_TIME INTEGER, INTENT(iN) :: MYID INTEGER, INTENT(inout) :: IFLAG, IERROR LOGICAL SMUMPS_COMPRE_NEW_CALLED SMUMPS_COMPRE_NEW_CALLED = .FALSE. IF (IWPOSCB-IWPOS+1 .LT. SIZEI_NEEDED) THEN CALL SMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 1 in SMUMPS_GET_SIZE_NEEDED ', & 'PB compress... SMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF SMUMPS_COMPRE_NEW_CALLED = .TRUE. IF (IWPOSCB-IWPOS+1 .LT. SIZEI_NEEDED) THEN IFLAG = -8 IERROR = SIZEI_NEEDED GOTO 500 ENDIF ENDIF IF ( .NOT.SMUMPS_COMPRE_NEW_CALLED.AND. & (LRLU.LT.SIZER_NEEDED).AND. & (LRLUS.GE.SIZER_NEEDED).AND. & (LRLU.NE.LRLUS) & ) THEN CALL SMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) SMUMPS_COMPRE_NEW_CALLED = .TRUE. IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 2 ', & 'in SMUMPS_GET_SIZE_NEEDED ', & 'PB compress... SMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF IF (LRLUS.LT.SIZER_NEEDED) THEN #if ! defined(NODYNAMICCB) IF (.NOT. SMUMPS_COMPRE_NEW_CALLED) THEN CALL SMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 2 ', & 'in SMUMPS_GET_SIZE_NEEDED ', & 'PB compress... SMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF CALL SMUMPS_DM_CBSTATIC2DYNAMIC(KEEP(141), & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 500 IF (LRLU.LT.SIZER_NEEDED) THEN CALL SMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 4 ', & 'in SMUMPS_GET_SIZE_NEEDED ', & 'PB compress... SMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF #else IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) GOTO 500 #endif ENDIF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_GET_SIZE_NEEDED MUMPS_5.8.1/src/dmumps_driver.F0000664000175000017500000030727115042446441016232 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C =========================== C FORTRAN 90 Driver for DMUMPS C (MPI based code) C =========================== C SUBROUTINE DMUMPS( id ) USE MUMPS_MEMORY_MOD USE DMUMPS_STRUC_DEF USE DMUMPS_STATIC_PTR_M ! For Schur pointer #if ! defined(NO_SAVE_RESTORE) USE DMUMPS_SAVE_RESTORE #endif USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_INTR_STRUC, & DMUMPS_ENCODE_INTR, & DMUMPS_DECODE_INTR, & DMUMPS_INIT_INTR_ENCODING, & DMUMPS_FREE_INTR_ENCODING C !$ USE OMP_LIB C IMPLICIT NONE C C ======= C Purpose C ======= C C TO SOLVE a SPARSE SYSTEM OF LINEAR EQUATIONS. C GIVEN AN UNSYMMETRIC, SYMMETRIC, OR SYMMETRIC POSITIVE DEFINITE C SPARSE MATRIX A AND AN N-VECTOR B, THIS SUBROUTINE SOLVES THE C SYSTEM A x = b or ATRANSPOSE x = b. C C List of main functionalities provided by the package: C ---------------------------------------------------- C -Unsymmetric solver with partial pivoting (LU factorization) C -Symmetric positive definite solver (LDLT factorization) C -General symmetric solver with pivoting C -Either elemental or assembled matrix input C -Analysis/Factorization/Solve callable separately C -Deficient matrices (symmetric or unsymmetric) C -Rank revealing C -Null space basis computation C -Solution C -Return the Schur complement matrix while C also providing solution of interior problem C -Distributed input matrix and analysis phase C -Sequential or parallel MPI version (any number of processors) C -Error analysis and iterative refinement C -Out-of-Core factorization and solution C -Solution phase: C -Multiple Right-Hand-sides (RHS) C -Sparse RHS C -Distributed RHS C -Computation of selected entries of the inverse of C original matrix. C - Block Low-Rank (BLR) approximation based factorization C C Method C ------ C The method used is a parallel direct method C based on a sparse multifrontal variant C of Gaussian elimination with partial numerical pivoting. C An initial ordering for the pivotal sequence C is chosen using the pattern of the matrix A + A^T and is C later modified for reasons of numerical stability. Thus this code C performs best on matrices whose pattern is symmetric, or nearly so. C For symmetric sparse matrices or for very unsymmetric and C very sparse matrices, other software might be more appropriate. C C C References : C ----------- C Please see https://mumps-solver.org/index.php?page=doc C C============================================ C Argument lists and calling sequences C============================================ C C There is only one entry: * * A Fortran 90 driver subroutine DMUMPS has been designed as a user * friendly interface to the multifrontal code. * This driver, in addition to providing the * normal functionality of a sparse solver, incorporates some * pre- and post-processing. * This driver enables the user to preprocess the matrix to obtain a * maximum * transversal so that the permuted matrix has a zero-free diagonal, * to perform prescaling * of the original matrix (a choice of scaling strategies is provided), * to use iterative refinement to improve the solution, * and finally to perform error analysis. * * The driver routine DMUMPS offers similar functionalities to other * sparse direct solvers, depending on the value of one of * its parameters (JOB). The main ones are: * * (i) JOB = -1 C initializes an instance of the package. This must be C called before any other call to the package concerning that instance. C It sets default values for other C components of DMUMPS_STRUC, which may then be altered before C subsequent calls to DMUMPS. C Note that three components of the structure must always be set by the C user (on all processors) before a call with JOB=-1. These are C id%COMM, C id%SYM, and C id%PAR. C CNTL, ICNTL can then be modified (see documentation) by the user. C * A value of JOB = -1 cannot be combined with other values for JOB * * (ii) JOB = 1 accepts the pattern of matrix A and chooses pivots * from the diagonal using a selection criterion to * preserve sparsity. It uses the pattern of A + A^T * but ignores numerical values. It subsequently constructs subsidiary * information for the actual factorization by a call with JOB_=_2. * An option exists for the user to * input the pivot sequence, in which case only the necessary * information for a JOB = 2 entry will be generated. We call the JOB=1 * entry, the analysis phase. C The following components of the structure define the centralized matrix C pattern and must be set by the user (on the host only) C before a call with JOB=1: C --- id%N, id%NZ (32-bit int) or id%NNZ (64-bit int), C id%IRN, and id%JCN C if the user wishes to input the structure of the C matrix in assembled format (ICNTL(5)=0, and ICNTL(18) $\neq$ 3), C --- id%ELTPTR, and id%ELTVAR C if the user wishes to input the matrix in elemental C format (ICNTL(5)=1). C A distributed matrix format is also available (see documentation) C * (iii) JOB = 2 factorizes a matrix A using the information * from a previous call with JOB = 1. The actual pivot sequence * used may differ slightly from that of this earlier call if A is not * diagonally dominant. * * (iv) JOB = 3 uses the factors generated by a JOB = 2 call to solve * a system of equations A X = B or A^T X =B, where X and B are matrices * that can be either dense or sparse. * The sparsity of B is exploited to limit the number of operations * performed during solution. When only part of the solution is * also needed (such as when computing selected entries of A^1) then * further reduction of the number of operations is performed. * This is particularly beneficial in the context of an * out-of-core factorization. * * (v) JOB = -2 frees all internal data allocated by the package. * * A call with JOB=3 must be preceded by a call with JOB=2, * which in turn must be preceded by a call with JOB=1, which * in turn must be preceded by a call with JOB=-1. Since the * information passed from one call to the next is not * corrupted by the second, several calls with JOB=2 for matrices * with the same sparsity pattern but different values may follow * a single call with JOB=1, and similarly several calls with JOB=3 * can be used for different right-hand sides. * Values 4, 5, 6 for the parameter JOB can invoke combinations * of the three basic operations corresponding to JOB=1, 2 or 3. * * JOB = -4 : frees all data structures from the factorization * while keeping data structures from the analysis. Can be * followed by a JOB = 2 call. * #if ! defined(NO_SAVE_RESTORE) * JOB = -3, 7, 8 : save and restore feature, see userguide #endif * JOB = 9 : provide suggested data distribution for IRHS_LOC C ********* C -------------------------------------- C Explicit interface needed for routines C using a target argument if they appear C in the same compilation unit. C -------------------------------------- INTERFACE SUBROUTINE DMUMPS_CHECK_DENSE_RHS &(idRHS, idINFO, idN, idNRHS, idLRHS) DOUBLE PRECISION, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE DMUMPS_CHECK_DENSE_RHS SUBROUTINE DMUMPS_ANA_DRIVER( id, idintr ) USE DMUMPS_STRUC_DEF USE DMUMPS_INTR_TYPES TYPE (DMUMPS_STRUC), TARGET :: id TYPE (DMUMPS_INTR_STRUC) :: idintr END SUBROUTINE DMUMPS_ANA_DRIVER SUBROUTINE DMUMPS_FAC_DRIVER( id, idintr ) USE DMUMPS_STRUC_DEF USE DMUMPS_INTR_TYPES TYPE (DMUMPS_STRUC), TARGET :: id TYPE (DMUMPS_INTR_STRUC) :: idintr END SUBROUTINE DMUMPS_FAC_DRIVER SUBROUTINE DMUMPS_SOLVE_DRIVER( id, idintr ) USE DMUMPS_STRUC_DEF USE DMUMPS_INTR_TYPES TYPE (DMUMPS_STRUC), TARGET :: id TYPE (DMUMPS_INTR_STRUC) :: idintr END SUBROUTINE DMUMPS_SOLVE_DRIVER SUBROUTINE DMUMPS_PRINT_ICNTL(id, LP) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP END SUBROUTINE DMUMPS_PRINT_ICNTL END INTERFACE * MPI * === INCLUDE 'mpif.h' INTEGER MASTER PARAMETER ( MASTER = 0 ) INTEGER IERR * * ========== * Parameters * ========== TYPE (DMUMPS_STRUC) :: id C C Main components of the structure are: C ------------------------------------ C C (see documentation for a complete description) C C JOB is an INTEGER variable which must be set by the user to C characterize the factorization step. Possible values of JOB C are given below C C 1 Analysis: Ordering and symbolic factorization steps. C 2 Scaling and Numerical Factorization C 3 Solve and Error analysis C 4 Analysis followed by numerical factorization C 5 Numerical factorization followed by Solving step C 6 Analysis, Numerical factorization and Solve C C N is an INTEGER variable which must be set by the user to the C order n of the matrix A. It is not altered by the C subroutine. C C NZ / NNZ are INTEGER / INTEGER(8) variables which must be set by the user C to the number of entries being input, in case of centralized assembled C entry. It is not altered by the subroutine. Only used if C ICNTL(5).eq.0 and ICNTL(18) .ne. 3 (assembled matrix entry, C or, at least, centralized matrix graph during analysis). C C Restriction: NZ > 0 or NNZ > 0. C If NNZ is different from 0, NNZ is used. Otherwise, NZ is used. C C NELT is an INTEGER variable which must be set by the user to the C number of elements being input. It is not altered by the C subroutine. Only used if ICNTL(5).eq.1 (elemental matrix entry). C Restriction: NELT > 0. C C IRN and JCN are INTEGER arrays of length [N]NZ. C IRN(k) and JCN(k), k=1..[N]NZ must be set on entry to hold C the row and column indices respectively. C They are not altered by the subroutine except when ICNTL(6) = 1. C (in which case only the column indices are modified). C The arrays are only used if ICNTL(5).eq.0 (assembled entry) C or out-of-range. C C ELTPTR is an INTEGER array of length NELT+1. C ELTVAR is an INTEGER array of length ELTPTR(NELT+1)-1. C ELTPTR(I) points in ELTVAR to the first variable in the list of C variables that correspond to element I. ELTPTR(NELT+1) points C to the first unused location in ELTVAR. C The positions ELTVAR(I) .. ELTPTR(I+1)-1 contain the variables C for element I. No free space is allowed between variable lists. C ELTPTR/ELTVAR are not altered by the subroutine. C The arrays are only used if ICNTL(5).ne.0 (element entry). C C A is a DOUBLE PRECISION array of length [N]NZ. C The user must set A(k) to the value C of the entry in row IRN(k) and column JCN(k) of the matrix. C It is not altered by the subroutine. C (Note that the matrix can also be provided in a distributed C assembled input format) C C RHS is a DOUBLE PRECISION array of length N that is only accessed when C JOB = 3, 5, or 6. On entry, RHS(i) C must hold the i th component of the right-hand side of the C equations being solved. C On exit, RHS(i) will hold the i th component of the C solution vector. For other values of JOB, RHS is not accessed and C can be declared to have size one. C RHS should only be available on the host processor. If C it is associated on other processors, an error is raised. C (Note that the right-hand sides can also be provided in a C sparse format). C C COLSCA, ROWSCA are DOUBLE PRECISION C arrays of length N that are used to hold C the values used to scale the columns and the rows C of the original matrix, respectively. C These arrays need to be set by the user C only if ICNTL(8) is set to -1. If ICNTL(8)=0, C COLSCA and ROWSCA are not accessed and C so can be declared to have size one. C For any other values of ICNTL(8), C the scaling arrays are computed before C numerical factorization. The factors of the scaled matrix C diag(ROWSCA(i)) automatic choice IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ( id%KEEP(52) .EQ. 2 .OR. id%KEEP(52).EQ.5 & .OR. id%KEEP(52) .EQ. 6 ) & id%KEEP(52) = 77 IF ((id%KEEP(52).EQ.77).AND.(id%KEEP(50).EQ.1)) THEN ! for SPD matrices default is no scaling id%KEEP(52) = 0 ENDIF IF ( id%KEEP(52).EQ.77 .OR. id%KEEP(52).LE.-2) THEN C -- suppress scaling computed during analysis C -- if centralized matrix is not associated IF (.not.associated(id%A)) id%KEEP(52) = 0 ENDIF C deactivate analysis scaling if scaling given IF(id%KEEP(52) .EQ. -1) id%KEEP(52) = 0 C C deactivate analysis scaling if C permutation to zero-free diagonal not requested IF (id%ICNTL(6).EQ.0) id%KEEP(52) = 0 C deactivate analysis scaling for SPD matrices IF (id%KEEP(50).EQ.1) id%KEEP(52) = 0 C IF (id%KEEP(52).EQ.-2) THEN C deallocate scalings in case of ordering allocated/computed C during analysis. This is needed because in case of C KEEP(52)=-2 then one cannot be sure that C scaling will be effectivly computed during analysis C Thus to test if scaling was effectively allocated/computed C during analysis after DMUMPS_ANA_DRIVER one must C be sure that scaling arrays are nullified. IF ( associated(id%COLSCA)) THEN DEALLOCATE( id%COLSCA ) NULLIFY(id%COLSCA) ENDIF IF ( associated(id%ROWSCA)) THEN DEALLOCATE( id%ROWSCA ) NULLIFY(id%ROWSCA) ENDIF ENDIF C C} ENDIF C C ANALYSIS PHASE: CALL DMUMPS_ANA_DRIVER( id, idintr ) C restore values id%KEEP(77) = KEEP77SAVE id%KEEP(78) = KEEP78SAVE id%KEEP(83) = KEEP83SAVE id%KEEP(91) = KEEP91SAVE id%KEEP(172) = KEEP172SAVE id%KEEP(178) = KEEP178SAVE #if ! defined(LARGEMATRICES) IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0) THEN IF (.not.associated(id%UNS_PERM)) THEN C I may happen C (for ex in case of error -7 during analysis: C UNS_PERM can be not associated, C KEEP(23) was set to to automatic choice(=7) and C an error of memory allocation occurs during analysis C before having decided value of KEEP(23)) C UNS_PERM not associated and KEEP(23).NE.0 C Permuting JCN back does not make sense and KEEP(23) C should be reset to zero id%KEEP(23) = 0 ELSE UNS_PERM_DONE = .TRUE. ENDIF ENDIF #endif C C Check and save scaling option in INFOG(33) IF (id%MYID .eq. MASTER) THEN C{ IF (id%KEEP(52).EQ.0) id%INFOG(33)=id%ICNTL(8) IF (id%KEEP(52).EQ.-2) THEN C Scaling should have been computed during analysis IF (.not.associated(id%COLSCA).OR. & .not.associated(id%ROWSCA) & ) THEN C scaling was not computed reset KEEP(52) C the user can then decide during factorization C to activate scaling id%KEEP(52) =0 id%INFOG(33)=0 IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') & ' Warning; scaling was not computed during analysis' ENDIF IF ( associated(id%COLSCA)) THEN DEALLOCATE( id%COLSCA ) NULLIFY(id%COLSCA) ENDIF IF ( associated(id%ROWSCA)) THEN DEALLOCATE( id%ROWSCA ) NULLIFY(id%ROWSCA) ENDIF ENDIF ENDIF IF (id%KEEP(52) .NE. 0) THEN id%INFOG(33)=id%KEEP(52) ENDIF C} ENDIF C return value of ICNTL(12) effectively used C that was saved on the master in KEEP(95) IF (id%MYID .eq. MASTER) id%INFOG(24)=id%KEEP(95) C TIMINGS: IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(71) = TIMEG ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in analysis driver= ', TIMEG END IF C ----------------------- C Return in case of error C ----------------------- IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 id%KEEP(40) = 1 -456789 END IF C C------------------------------------------------------- C- C C BEGIN FACTORIZATION PHASE C C- C------------------------------------------------------- IF ( LFACTO ) THEN C{ IF (id%MYID .eq. MASTER) THEN id%DKEEP(91)=0.0D0 CALL MUMPS_SECDEB(TIMEG) END IF C ---------------------- C Reset KEEP(40) to 1 in C case of error in facto C ---------------------- id%KEEP(40) = 1 - 456789 C C------------------------------------------------------- C- C- CHECKS, SCALING, ARROWHEAD + FACTORIZATION PHASE C- C------------------------------------------------------- C C Broadcast the value of KEEP(125) to decide if performing C the scaling with the Schur complement feature. CALL MPI_BCAST( id%KEEP(125), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) IF ( id%MYID .EQ. MASTER ) THEN C ------------------------- C Check if Schur complement C is allocated. C ------------------------- IF (id%KEEP(60).EQ.1) THEN IF ( associated( id%SCHUR_CINTERFACE)) THEN C Called from C interface... C Since id%SCHUR_CINTERFACE is of size 1, C instruction below which causes bound check C errors should be avoided. We cheat by first C setting a static pointer with a routine with C implicit interface, and then copying this pointer C into id%SCHUR. CALL DMUMPS_SET_TMP_PTR(id%SCHUR_CINTERFACE(1), & int(id%SIZE_SCHUR,8)*int(id%SIZE_SCHUR,8)) CALL DMUMPS_GET_TMP_PTR(id%SCHUR) NULLIFY(id%SCHUR_CINTERFACE) ENDIF IF ( .NOT. associated (id%SCHUR)) THEN IF (LP.GT.0) & write(LP,'(A)') & ' SCHUR not associated' id%INFO(1)=-22 id%INFO(2)=9 ELSE IF ( size(id%SCHUR) .LT. & id%SIZE_SCHUR * id%SIZE_SCHUR ) THEN IF (LP.GT.0) & write(LP,'(A)') & ' SCHUR allocated but too small' id%INFO(1)=-22 id%INFO(2)=9 END IF END IF C ------------------------------------------------------------ C Assembled entry: check input parameterd IRN,JCN,A C Element entry: check input parameters ELTPTR,ELTVAR,A_ELT C ------------------------------------------------------------ IF ( id%KEEP(54) .EQ. 0 ) THEN IF ( id%KEEP(55).eq.0 ) THEN C Assembled entry IF ( .not. associated( id%IRN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 #if defined(MUMPS_NOF2003) C size with kind=8 output not available. One can still C check that if NZ can be stored in a 32-bit integer, C the 32-bit size(id%IRN) (which we then assume not C to overflow...) is large enough ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%IRN) < int(id%KEEP8(28)) ) THEN #else ELSE IF ( size( id%IRN, KIND=8 ) < id%KEEP8(28) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%JCN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 #if defined(MUMPS_NOF2003) C Same as for IRN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%JCN) < int(id%KEEP8(28)) ) THEN #else ELSE IF ( size( id%JCN, KIND=8 ) < id%KEEP8(28) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( .not. associated( id%A ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 #if defined(MUMPS_NOF2003) C Same as for IRN/JCN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size( id%A ) < int(id%KEEP8(28)) ) THEN #else ELSE IF ( size( id%A, KIND=8 ) < id%KEEP8(28) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 END IF ELSE C Element entry IF ( .not. associated( id%ELTPTR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( size( id%ELTPTR ) < id%NELT+1 ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%ELTVAR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( size( id%ELTVAR ) < id%LELTVAR ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( .not. associated( id%A_ELT ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ELSE #if defined(MUMPS_NOF2003) IF ( id%KEEP8(30) < int(huge(id%NZ),8) .AND. & size( id%A_ELT ) < int(id%KEEP8(30)) ) THEN #else IF ( size( id%A_ELT, KIND=8 ) < id%KEEP8(30) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ENDIF END IF ENDIF ENDIF C ---------------------- C Get the value of PERLU C ---------------------- CALL MUMPS_GET_PERLU(id%KEEP(12),id%ICNTL(14), & id%KEEP(50),id%KEEP(54),id%ICNTL(6),id%ICNTL(8)) C C ---------------------- C Get null space options C Note that nullspace is forbidden in case of Schur complement C ---------------------- CALL DMUMPS_GET_NS_OPTIONS_FACTO(id%N,id%KEEP(1), & id%ICNTL(1),MPG) C ======================================== C Decode and set scaling options for facto C ======================================== IF (.NOT. ((id%KEEP(52).EQ.-2).AND.(id%ICNTL(8).EQ.77)) ) & THEN C if scaling was computed during analysis and automatic C choice of scaling then we do not recompute scaling id%KEEP(52)=id%ICNTL(8) ENDIF IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ( id%KEEP(52) .EQ. 2 .OR. id%KEEP(52).EQ.5 & .OR. id%KEEP(52) .EQ. 6 ) & id%KEEP(52) = 77 IF (id%KEEP(52).EQ.77) THEN IF (id%KEEP(50).EQ.1) THEN ! for SPD matrices the default is "no scaling" id%KEEP(52) = 0 ELSE ! SYM .ne. 1 the default is cheap SIMSCA id%KEEP(52) = 7 ENDIF ENDIF IF (id%KEEP(23) .NE. 0 .AND. id%ICNTL(8) .EQ. -1) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** WARNING : SCALING' WRITE(MPG,'(A)') & ' ** column permutation applied:' WRITE(MPG,'(A)') & ' ** column scaling has to be permuted' ENDIF ENDIF C ----------------------------------- C If Schur has been asked for C choose to disable or enable scaling C ---------------------------------- IF (id%KEEP(125).EQ.0) THEN C ------------------------ C scaling is disabled C ------------------------ IF ( id%KEEP(60) .ne. 0 .and. id%KEEP(52) .ne. 0 ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 .AND. id%ICNTL(8) .NE. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: scaling not applied.' WRITE(MPG,'(A)') ' ** (disabled with Schur)' END IF END IF END IF C ------------------------------- C If matrix is distributed on C entry, only options 7 and 8 C of scaling are allowed. C ------------------------------- IF (id%KEEP(54) .NE. 0 .AND. & id%KEEP(52).NE.7 .AND. id%KEEP(52).NE.8 .AND. & id%KEEP(52) .NE. 0 ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 .and. id%ICNTL(8) .ne. 0 ) THEN WRITE(MPG,'(A)') & ' ** Warning: requested scaling option not available' WRITE(MPG,'(A)') ' ** for distributed matrix entry' END IF END IF C ------------------------------------ C If matrix is symmetric, only scaling C options -1 (given scaling), 1 C (diagonal scaling), 7 and 8 (SIMSCALING) C are allowed. C ------------------------------------ IF ( id%KEEP(50) .NE. 0 ) THEN IF ( id%KEEP(52).ne. 1 .and. & id%KEEP(52).ne. -1 .and. & id%KEEP(52).ne. 0 .and. & id%KEEP(52).ne. 7 .and. & id%KEEP(52).ne. 8 .and. & id%KEEP(52).ne. -2 .and. & id%KEEP(52).ne. 77) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') & ' ** Warning: scaling option n.a. for symmetric matrix' END IF id%KEEP(52) = 0 END IF END IF C ---------------------------------- C If matrix is elemental on entry, C automatic scaling is now forbidden C ---------------------------------- IF (id%KEEP(55) .NE. 0 .AND. & ( id%KEEP(52) .gt. 0 ) ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: scaling not applied.' WRITE(MPG,'(A)') & ' ** (only user scaling av. for elt. entry)' END IF END IF C -------------------------------------- C Check input parameters ROWSCA / COLSCA C -------------------------------------- IF ( id%KEEP(52) .eq. -1 ) THEN IF ( .not. associated( id%ROWSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( .not. associated( id%COLSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 6 ELSE IF ( size( id%COLSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 6 END IF END IF C C Allocate -- if required, C ROWSCA and COLSCA on the master C C Allocation of scaling arrays. C IF (KEEP(52)==-2 then scaling should have been allocated C and computed during analysis C C If ICNTL(8) == -1, ROWSCA and COLSCA must have been associated and C filled by the user. If ICNTL(8) is >0 and <= 8, the scaling is C computed at the beginning of DMUMPS_FAC_DRIVER and is allocated now. C IF (id%KEEP(52).GT.0 .AND. & id%KEEP(52) .LE.8) THEN IF ( associated(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(id%N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=id%N ENDIF ALLOCATE( id%ROWSCA(id%N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=id%N ENDIF END IF C C Allocate scaling arrays of size 1 if C they are not used to avoid problems C when passing them in arguments C IF (.NOT. associated(id%COLSCA)) THEN ALLOCATE( id%COLSCA(1), stat=IERR) END IF IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 ENDIF IF (.NOT. associated(id%ROWSCA)) & ALLOCATE( id%ROWSCA(1), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF ( LPOK ) WRITE(LP,'(A)') & 'Problems in allocations before facto' GOTO 200 END IF IF (id%KEEP(252) .EQ. 1) THEN CALL DMUMPS_CHECK_DENSE_RHS & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) C Sets KEEP(221) and do some checks C in case of Schur check if reduced RHS C requested CALL DMUMPS_SET_K221(id,.FALSE.) CALL DMUMPS_CHECK_K221andREDRHS(id) ENDIF 200 CONTINUE END IF ! End of IF (MYID .eq. MASTER) C KEEP(221) was set in DMUMPS_SET_K221 but not broadcast CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) C broadcast RR option CALL MPI_BCAST( id%KEEP(19), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) C C Check distributed matrices on all processors. I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (I_AM_SLAVE .AND. & id%KEEP(54).NE.0 .AND. id%KEEP8(29).GT.0_8) THEN IF ( .not. associated( id%IRN_loc ) ) THEN id%INFO(1) = -22 id%INFO(2) = 16 #if defined(MUMPS_NOF2003) C size with kind=8 output not available. One can still C check that if NZ_loc can be stored in a 32-bit integer, C the 32-bit size(id%IRN_loc) (which we then assume not C to overflow...) is large enough ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size(id%IRN_loc) < int(id%KEEP8(29)) ) THEN #else ELSE IF ( size( id%IRN_loc, KIND=8 ) < id%KEEP8(29) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 16 ELSE IF ( .not. associated( id%JCN_loc ) ) THEN id%INFO(1) = -22 id%INFO(2) = 16 #if defined(MUMPS_NOF2003) C Same as for IRN_loc above ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size(id%JCN_loc) < int(id%KEEP8(29)) ) THEN #else ELSE IF ( size( id%JCN_loc, KIND=8 ) < id%KEEP8(29) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 16 ELSEIF ( .not. associated( id%A_loc ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 16 #if defined(MUMPS_NOF2003) C Same as for IRN_loc/JCN_loc above ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size( id%A_loc ) < int(id%KEEP8(29)) ) THEN #else ELSE IF ( size( id%A_loc, KIND=8 ) < id%KEEP8(29) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 16 END IF ENDIF C C Check Schur complement on all processors. C DMUMPS_PROPINFO will be called right after those checks. C IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF ( idintr%root%yes ) THEN IF ( associated( id%SCHUR_CINTERFACE )) THEN C Called from C interface... C The next instruction may cause C bound check errors at runtime C id%SCHUR=>id%SCHUR_CINTERFACE C & (1:id%SCHUR_LLD*(idintr%root%SCHUR_NLOC-1)+ C & idintr%root%SCHUR_MLOC) C Instead, we set a temporary C pointer and then retrieve it CALL DMUMPS_SET_TMP_PTR(id%SCHUR_CINTERFACE(1), & int(id%SCHUR_LLD,8)*int(idintr%root%SCHUR_NLOC-1,8)+ & int(idintr%root%SCHUR_MLOC,8)) CALL DMUMPS_GET_TMP_PTR(id%SCHUR) NULLIFY(id%SCHUR_CINTERFACE) ENDIF C Check that SCHUR_LLD is large enough IF (id%SCHUR_LLD < idintr%root%SCHUR_MLOC) THEN IF (LP.GT.0) write(LP,*) & ' SCHUR leading dimension SCHUR_LLD ', & id%SCHUR_LLD, 'too small with respect to', & idintr%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*(idintr%root%SCHUR_NLOC-1)+ & idintr%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=', idintr%root%SCHUR_NLOC, & ' SCHUR_NLOC=', idintr%root%SCHUR_NLOC ENDIF id%INFO(1)=-22 id%INFO(2)= 9 ELSE C We initialize the pointer that C we will use within DMUMPS here. idintr%root%SCHUR_LLD=id%SCHUR_LLD IF (idintr%root%SCHUR_NLOC==0) THEN ALLOCATE(idintr%roota%SCHUR_POINTER(1), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF ( LPOK ) THEN WRITE(LP,'(A)') & 'Problems in allocations before facto' ENDIF END IF ELSE idintr%roota%SCHUR_POINTER=>id%SCHUR ENDIF ENDIF ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 C ----------------------------------------------- C Call factorization procedure DMUMPS_FAC_DRIVER C ----------------------------------------------- CALL DMUMPS_FAC_DRIVER(id,idintr) C Save scaling in INFOG(33) IF (id%MYID .eq. MASTER) id%INFOG(33)=id%KEEP(52) C C In the case of Schur, free or not associated C idintr%roota%SCHUR_POINTER now rather than in end_driver.F C (Case of repeated factorizations). IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF (idintr%root%yes) THEN IF (idintr%root%SCHUR_NLOC==0) THEN DEALLOCATE(idintr%roota%SCHUR_POINTER) NULLIFY(idintr%roota%SCHUR_POINTER) ELSE NULLIFY(idintr%roota%SCHUR_POINTER) ENDIF ENDIF ENDIF IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(91) = TIMEG ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in factorization driver =', & TIMEG END IF C C Check for errors after FACTO C (it was propagated inside) IF(id%INFO(1).LT.0) THEN C ------------------------------------------------------- C Free data from this factorization. Since factorization C fails, factors, etc. can not be used to perform a solve C ------------------------------------------------------- CALL DMUMPS_FREE_DATA_FACTO(id,idintr) GO TO 499 ENDIF C C Update last successful step C id%KEEP(40) = 2 - 456789 C} END IF C------------------------------------------------------- C- C C BEGIN SOLVE PHASE C C- C------------------------------------------------------- IF (LSOLVE) THEN IF (id%MYID .eq. MASTER) THEN id%DKEEP(111)=0.0D0 CALL MUMPS_SECDEB(TIMEG) END IF C --------------------- C Reset KEEP(40) to 2. C (last successful step C was facto) C --------------------- id%KEEP(40) = 2 -456789 C ------------------------------------------ C Call solution procedure DMUMPS_SOLVE_DRIVER C ------------------------------------------ IF (id%MYID .eq. MASTER) THEN KEEP235SAVE = id%KEEP(235) KEEP242SAVE = id%KEEP(242) KEEP243SAVE = id%KEEP(243) KEEP495SAVE = id%KEEP(495) KEEP497SAVE = id%KEEP(497) ! if no permutation of RHS asked then suppress request ! to interleave the RHS ! to interleave the RHS on ordering given then ! using option to set permutation to identity should be ! used (note though that ! they # with A-1/sparseRHS and Null Space) IF (id%KEEP(242).EQ.0) id%KEEP(243)=0 C -------------------------------------- C Check input parameters ROWSCA / COLSCA C Only if KEEP(52).NE.0 because C only 0 means that no colsca/rowsca are needed C -------------------------------------- IF ( id%KEEP(52) .ne. 0) THEN IF ( .not. associated( id%ROWSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( .not. associated( id%COLSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 6 ELSE IF ( size( id%COLSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 6 END IF ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 CALL DMUMPS_SOLVE_DRIVER(id,idintr) IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(111) = TIMEG ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in solve driver= ', TIMEG END IF IF (id%MYID .eq. MASTER) THEN id%KEEP(235) = KEEP235SAVE id%KEEP(242) = KEEP242SAVE id%KEEP(243) = KEEP243SAVE id%KEEP(495) = KEEP495SAVE id%KEEP(497) = KEEP497SAVE ENDIF IF (id%INFO(1).LT.0) GOTO 499 C --------------------------- C Update last successful step C --------------------------- id%KEEP(40) = 3 -456789 ENDIF C C What was actually done is saved in KEEP(40) C IF (PROK) CALL DMUMPS_PRINT_ICNTL(id, MP) GOTO 500 * *================= * ERROR section *================= 499 CONTINUE * Print error message if PROK IF (LPOK) WRITE (LP,99995) id%INFO(1) IF (LPOK) WRITE (LP,99994) id%INFO(2) * 500 CONTINUE #if ! defined(LARGEMATRICES) C --------------------------------- C Permute JCN on output to DMUMPS if C KEEP(23) is different from 0. C --------------------------------- IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0 & .AND. NOERRORBEFOREPERM) THEN C ------------------------------- C IF JOB=3 and PERM was not C done (no iterative refinement/ C error analysis), then we do not C permute JCN back. C ------------------------------- IF (UNS_PERM_DONE) THEN DO I8 = 1_8, id%KEEP8(28) J=id%JCN(I8) C -- skip out-of range (that are ignored in ANA_O) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I8)=id%UNS_PERM(J) END DO END IF END IF #endif 510 CONTINUE C ------------------------------------ C Set INFOG(1:2): same value on all C processors + broadcast other entries C ------------------------------------ CALL DMUMPS_SET_INFOG(id%INFO(1), id%INFOG(1), id%COMM, id%MYID) C C -------------------------------- C Broadcast RINFOG entries to make C them available on all procs. C -------------------------------- CALL MPI_BCAST( id%RINFOG(1), 40, MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) IF (id%INFOG(1).GE.0 .AND. JOB.NE.-1 & .AND. JOB.NE.-2 ) THEN IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMETOTAL) id%DKEEP(70) = TIMETOTAL ENDIF ENDIF C ------------------------------------------------------------ C SCHUR_CINTERFACE is no longer needed. It will be set again C the next time MUMPS is entered through its C interface. C ------------------------------------------------------------ NULLIFY(id%SCHUR_CINTERFACE) C #if ! defined(NO_SAVE_RESTORE) *======================= * Compute space for save *======================= IF (id%INFOG(1).GE.0) THEN IF ( IDINTR_MEANINGFUL_ON_EXIT ) THEN C Only do this if idintr is meaningful on exit. This includes C the case of JOB -2 that needs to update statistics. This excludes C the cases of JOBs that did not decode idintr, for which the save C restore statistics have not changed. CALL DMUMPS_COMPUTE_MEMORY_SAVE(id,idintr,FILE_SIZE,STRUC_SIZE) id%KEEP8(55)=FILE_SIZE call MPI_ALLREDUCE(id%KEEP8(55),id%KEEP8(57),1, & MPI_INTEGER8, MPI_SUM,id%COMM,IERR) id%KEEP8(56)=STRUC_SIZE call MPI_ALLREDUCE(id%KEEP8(56),id%KEEP8(58),1, & MPI_INTEGER8, MPI_SUM,id%COMM,IERR) id%RINFO(7)=dble(id%KEEP8(55))/1D6 id%RINFO(8)=dble(id%KEEP8(56))/1D6 id%RINFOG(17)=dble(id%KEEP8(57))/1D6 id%RINFOG(18)=dble(id%KEEP8(58))/1D6 ENDIF ENDIF #endif !$ IF (ICNTL16_LOC .GT. 0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(PREVIOUS_OMP_THREADS_NUM,4)) #else !$ CALL omp_set_num_threads(PREVIOUS_OMP_THREADS_NUM) #endif !$ ICNTL16_LOC = 0 !$ ENDIF *=============== * ERRORG section *=============== IF (id%MYID.EQ.MASTER.and.MPG.GT.0.and. & id%INFOG(1).lt.0) THEN WRITE(MPG,'(A,I16)') ' On return from DMUMPS, INFOG(1)=', & id%INFOG(1) WRITE(MPG,'(A,I16)') ' On return from DMUMPS, INFOG(2)=', & id%INFOG(2) END IF C ------------------------- C Restore user communicator C ------------------------- CALL MPI_COMM_FREE( id%COMM, IERR ) id%COMM = COMM_SAVE C ------------------------------------ C Set id%INTR_ENCODING from idintr C ------------------------------------ IF (MUST_ENCODE_IDINTR_ON_EXIT) THEN CALL DMUMPS_ENCODE_INTR(id%INTR_ENCODING, idintr) ENDIF RETURN * 99995 FORMAT (' ** ERROR RETURN ** FROM DMUMPS INFO(1)=', I5) 99994 FORMAT (' ** INFO(2)=', I16) 99993 FORMAT (' ** Allocation error: could not permute JCN.') END SUBROUTINE DMUMPS * SUBROUTINE DMUMPS_SET_INFOG( INFO, INFOG, COMM, MYID ) IMPLICIT NONE INCLUDE 'mpif.h' C C Purpose: C ======= C C If one proc has INFO(1).lt.0 and INFO(1) .ne. -1, C puts INFO(1:2) of this proc on all procs in INFOG C C Arguments: C ========= C INTEGER, PARAMETER :: SIZE_INFOG = 80 INTEGER :: INFO(80) INTEGER :: INFOG(SIZE_INFOG) ! INFOG(80) INTEGER :: COMM, MYID C C Local variables C =============== C #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) :: TMP1(2),TMP(2) #else INTEGER :: TMP1(2),TMP(2) #endif INTEGER ROOT, IERR INTEGER MASTER, WARNING_COUNT PARAMETER (MASTER=0) C C IF ( INFO(1) .ge. 0 ) THEN C C This can only happen if the phase was successful C on all procs. If one proc failed, then all other C procs would have INFO(1)=-1. C IF (INFO(1) .GT.0) THEN WARNING_COUNT=1 ELSE WARNING_COUNT=0 ENDIF INFOG(1) = INFO(1) INFOG(2) = INFO(2) CALL MPI_ALLREDUCE(WARNING_COUNT, INFOG(2), 1,MPI_INTEGER, & MPI_SUM, COMM, IERR) CALL MPI_ALLREDUCE(INFO(1),INFOG(1),1, MPI_INTEGER, & MPI_BOR, COMM, IERR) ELSE C --------------------- C Find who has smallest C error code INFO(1) C --------------------- INFOG(1) = INFO(1) C INFOG(2) = MYID TMP1(1) = INFO(1) TMP1(2) = MYID CALL MPI_ALLREDUCE(TMP1,TMP,1,MPI_2INTEGER, & MPI_MINLOC,COMM,IERR ) INFOG(2) = INFO(2) ROOT = TMP(2) CALL MPI_BCAST( INFOG(1), 1, MPI_INTEGER, ROOT, COMM, IERR ) CALL MPI_BCAST( INFOG(2), 1, MPI_INTEGER, ROOT, COMM, IERR ) END IF C C Make INFOG available on all procs: C CALL MPI_BCAST(INFOG(3), SIZE_INFOG-2, MPI_INTEGER, & MASTER, COMM, IERR ) RETURN END SUBROUTINE DMUMPS_SET_INFOG C-------------------------------------------------------------------- SUBROUTINE DMUMPS_PRINT_ICNTL (id, LP) USE DMUMPS_STRUC_DEF * * Purpose: * Print main control parameters CNTL and ICNTL * * ========== * Parameters * ========== TYPE (DMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP ** Local Variables INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL DOUBLE PRECISION, DIMENSION(:),POINTER::CNTL INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL CNTL=>id%CNTL IF (id%MYID.EQ.MASTER) THEN SELECT CASE (JOB) CASE(1); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ENDIF IF ((ICNTL(6).EQ.5).OR.(ICNTL(6).EQ.6).OR. & (ICNTL(12).NE.1) ) THEN WRITE (LP,992) ICNTL(8) ENDIF IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) WRITE (LP,996) ICNTL(56) CASE(2); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36), ICNTL(49) WRITE (LP,996) ICNTL(56) 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),ICNTL(26) CASE(4); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ENDIF WRITE (LP,992) ICNTL(8) IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36), ICNTL(49) WRITE (LP,996) ICNTL(56) CASE(5); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ENDIF WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21),ICNTL(26) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36), ICNTL(49) WRITE (LP,996) ICNTL(56) CASE(6); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(15), & ICNTL(18),ICNTL(19),ICNTL(22),ICNTL(48),ICNTL(58) ENDIF IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,992) ICNTL(8) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21), ICNTL(26) WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36), ICNTL(49) WRITE (LP,996) ICNTL(56) END SELECT ENDIF 980 FORMAT (/'***********CONTROL PARAMETERS (ICNTL)**************'/) 981 FORMAT ( & ' CNTL(1) Threshold for numerical pivoting =',D16.4/ & ' CNTL(3) Threshold to detect singularities =',D16.4/ & ' CNTL(4) Threshold for static pivoting =',D16.4/ & ' CNTL(5) Fixation for null pivots =',D16.4/ & ' CNTL(7) Dropping threshold for BLR compression =',D16.4) 990 FORMAT ( & 'ICNTL(1) Output stream for error messages =',I10/ & 'ICNTL(2) Output stream for diagnostic messages =',I10/ & 'ICNTL(3) Output stream for global information =',I10/ & 'ICNTL(4) Level of printing =',I10) 991 FORMAT ( & 'ICNTL(5) Matrix format =',I10/ & 'ICNTL(6) Maximum transversal =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(12) LDLT ordering strat =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(15) Analysis by block =',I10/ & 'ICNTL(18) Distributed matrix =',I10/ & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-of-core option (1=on, off otherwise)=',I10/ & 'ICNTL(48) Tree based multithreading =',I10/ & 'ICNTL(58) Symbolic factorization option =',I10) 891 FORMAT ( & 'ICNTL(5) Matrix format =',I10/ & 'ICNTL(6) Maximum transversal =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(15) Analysis by block =',I10/ & 'ICNTL(18) Distributed matrix =',I10/ & 'ICNTL(19) Schur option ( 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-of-core option (1=on, off otherwise)=',I10/ & 'ICNTL(48) Tree based multithreading =',I10/ & 'ICNTL(58) Symbolic factorization option =',I10) 992 FORMAT ( & 'ICNTL(8) Scaling strategy =',I10) 923 FORMAT ( & 'ICNTL(24) Null pivot detection (0=off) =',I10/ & 'ICNTL(31) Discard factors (0=off, else=on) =',I10/ & 'ICNTL(32) Forward elimination during facto (0=off)=',I10/ & 'ICNTL(33) Compute determinant (0=off) =',I10/ & 'ICNTL(35) Block Low Rank (BLR, 0=off >0=on) =',I10/ & 'ICNTL(36) BLR variant =',I10/ & 'ICNTL(49) Compact workarray S (end of facto.) =',I10) 993 FORMAT ( & 'ICNTL(14) Percent of memory increase =',I10) 996 FORMAT ( & 'ICNTL(56) Null space functionality =',I10) 995 FORMAT ( & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ & 'ICNTL(10) Max steps iterative refinement =',I10/ & 'ICNTL(11) Error analysis (1=all,2=some,else=off) =',I10/ & 'ICNTL(20) Den.(0)/sparse(1,2,3)/dist.(10,11) RHS =',I10/ & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10/ & 'ICNTL(26) Solution step =',I10) 998 FORMAT ( & ' Size of SCHUR matrix (SIZE_SCHUR) =',I10) END SUBROUTINE DMUMPS_PRINT_ICNTL C-------------------------------------------------------------------- SUBROUTINE DMUMPS_PRINT_KEEP(id, LP) USE DMUMPS_STRUC_DEF * * ========== * Parameters * ========== TYPE (DMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER ::LP ** Local Variables INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL, KEEP INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL KEEP=>id%KEEP IF (id%MYID.EQ.MASTER) THEN SELECT CASE (JOB) CASE(1); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6))THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) CASE(2); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (KEEP(23).EQ.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) WRITE (LP,996) KEEP(19), KEEP(118) WRITE (LP,994) KEEP(21) 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), ICNTL(26) 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), ICNTL(26) WRITE (LP,993) KEEP(12) WRITE (LP,997) KEEP(53) WRITE (LP,996) KEEP(19), KEEP(118) WRITE (LP,994) KEEP(21) 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) WRITE (LP,996) KEEP(19), KEEP(118) WRITE (LP,994) KEEP(21) 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), ICNTL(26) WRITE (LP,993) KEEP(12) WRITE (LP,997) KEEP(53) WRITE (LP,996) KEEP(19), KEEP(118) WRITE (LP,994) KEEP(21) 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-of-core option (1=on, off otherwise)=',I10) 992 FORMAT ( & 'ICNTL(8) Scaling strategy ( keep(52) ) =',I10) 993 FORMAT ( & 'ICNTL(14) Percent of memory increase ( keep(12) ) =',I10) 995 FORMAT ( & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ & 'ICNTL(10) Max steps iterative refinement =',I10/ & 'ICNTL(11) Error analysis ( 0= off, else=on) =',I10/ & 'ICNTL(20) Den.(0)/sparse(1,2,3)/dist.(10,11) RHS =',I10/ & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10/ & 'ICNTL(26) Solution step =',I10) 997 FORMAT ( & 'ICNTL(56) Null space-analysis ( keep(53) ) =',I10) 996 FORMAT ( & 'ICNTL(56) Null space-factorisation ( keep(19) ) =',I10/ & 'KEEP(118) Algorithm used for null space =',I10) 994 FORMAT ( & 'ICNTL(57) Estimate of null space size ( keep(21) )=',I10) END SUBROUTINE DMUMPS_PRINT_KEEP SUBROUTINE DMUMPS_CHECK_DENSE_RHS & (idRHS, idINFO, idN, idNRHS, idLRHS) IMPLICIT NONE C C Purpose: C ======= C C Check that the dense RHS is associated and of C correct size. Called on master only, when dense C RHS is supposed to be allocated. This can be used C either at the beginning of the solve phase or C at the beginning of the factorization phase C if forward solve is done during factorization C (see ICNTL(32)) ; idINFO(1), idINFO(2) may be C modified. C C C Arguments: C ========= C C id* : see corresponding components of the main C MUMPS structure. C DOUBLE PRECISION, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) IF ( .not. associated( idRHS ) ) THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 ELSE IF (idNRHS.EQ.1) THEN IF ( size( idRHS ) < idN ) THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 ENDIF ELSE IF (idLRHS < idN) & THEN idINFO( 1 ) = -26 idINFO( 2 ) = idLRHS ELSE IF #if defined(MUMPS_NOF2003) C size with kind=8 not available. One can still C perform the check if minimal size small enough. & (int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN & .LE. int(huge(idN),8) & .and. & size(idRHS) < int(int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN)) #else & (size(idRHS,kind=8) < & int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN) #endif & THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 END IF RETURN END SUBROUTINE DMUMPS_CHECK_DENSE_RHS C SUBROUTINE DMUMPS_SET_K221(id,ATSOLVE) USE DMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C Sets KEEP(221) on master. C [Schur only] must be called before DMUMPS_CHECK_REDRHS C C Can be called at factorization C (in case of fwd in facto) or at solve phase C ATSOLVE=.TRUE. if called during solve phase C TYPE (DMUMPS_STRUC) :: id LOGICAL, INTENT(IN) :: ATSOLVE LOGICAL :: PROKG INTEGER :: MPG INTEGER MASTER PARAMETER( MASTER = 0 ) MPG = id%ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) IF (id%MYID.EQ.MASTER) THEN id%KEEP(221)=id%ICNTL(26) IF (id%KEEP(221).NE.0 .AND. id%KEEP(221) .NE.1 & .AND.id%KEEP(221).NE.2) id%KEEP(221)=0 ENDIF RETURN END SUBROUTINE DMUMPS_SET_K221 C SUBROUTINE DMUMPS_CHECK_K221andREDRHS(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C * Decode API related to REDRHS and check REDRHS C * Can be called at factorization or solve phase C * Constraints: C - Must be called after solve phase. C - KEEP(60) must have been set (ok to check C since KEEP(60) was set during analysis phase) C * Remark that during solve phase, ICNTL(26)#0 is C forbidden in case of fwd in facto. C TYPE (DMUMPS_STRUC) :: id INTEGER MASTER PARAMETER( MASTER = 0 ) C write(6,*) " Entering DMUMPS_CHECK_K221andREDRHS with : ", C & " id%JOB, id%KEEP(221), id%KEEP(60), id%SIZE_SCHUR= ", C & id%JOB, id%KEEP(221), id%KEEP(60), id%SIZE_SCHUR 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 .NE.3 ) & ) THEN id%INFO(1)=-33 id%INFO(2)=id%JOB 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) C write(6,*) " id%KEEP(60), id%SIZE_SCHUR=", C & id%KEEP(60), id%SIZE_SCHUR GOTO 333 ENDIF IF ( id%KEEP(60).NE.0 ) THEN C Schur feature IF ( 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 ENDIF 333 CONTINUE C Error is not propagated. It should be propagated outside. C The reason to propagate it outside is that there can be C one call to PROPINFO instead of several ones. RETURN END SUBROUTINE DMUMPS_CHECK_K221andREDRHS MUMPS_5.8.1/src/sarrowheads.F0000664000175000017500000011545215042446437015677 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ANA_ARROWHEADS_WRAPPER ( id, & GATHER_MATRIX_ALLOCATED ) USE SMUMPS_STRUC_DEF USE SMUMPS_ANA_AUX_M, ONLY:SMUMPS_ANA_N_DIST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: MASTER PARAMETER( MASTER = 0 ) TYPE(SMUMPS_STRUC), TARGET :: id LOGICAL, INTENT(INOUT) :: GATHER_MATRIX_ALLOCATED INTEGER, ALLOCATABLE, DIMENSION(:) :: NBINROW_TMP, NBINCOL_TMP INTEGER, DIMENSION(:), POINTER :: KEEP, ICNTL, INFO INTEGER(8), DIMENSION(:), POINTER :: KEEP8 LOGICAL :: I_AM_SLAVE INTEGER :: allocok KEEP => id%KEEP ICNTL => id%ICNTL INFO => id%INFO KEEP8 => id%KEEP8 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (KEEP(55) .EQ. 0) THEN ALLOCATE( NBINCOL_TMP( id%N ), NBINROW_TMP( id%N ), & stat=allocok ) IF (allocok.GT.0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(int(id%N,8)+int(id%N,8), INFO(2)) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL SMUMPS_ANA_N_DIST(id, NBINCOL_TMP, NBINROW_TMP) IF ( .NOT. I_AM_SLAVE ) THEN DEALLOCATE(NBINCOL_TMP) DEALLOCATE(NBINROW_TMP) ENDIF IF(id%MYID .EQ. MASTER) THEN IF ( (KEEP(244) .EQ. 1) .AND. (KEEP(54) .EQ. 3) ) THEN IF (GATHER_MATRIX_ALLOCATED) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF GATHER_MATRIX_ALLOCATED= .FALSE. ENDIF END IF END IF ENDIF IF ( I_AM_SLAVE ) THEN IF (KEEP(55) .EQ. 0) THEN CALL SMUMPS_ANA_DIST_ARROWHEADS( id%MYID, & id%NSLAVES, id%N, id%PROCNODE_STEPS(1), & id%STEP(1), id%FILS(1), & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & KEEP(1),KEEP8(1), ICNTL(1), id, & NBINCOL_TMP, NBINROW_TMP ) DEALLOCATE(NBINCOL_TMP) DEALLOCATE(NBINROW_TMP) ELSE CALL SMUMPS_ANA_DIST_ELEMENTS( id%MYID, & id%NSLAVES, id%N, id%PROCNODE_STEPS(1), & id%STEP(1), & id%PTRAR(1), & id%PTRAR(id%NELT+2 ), & id%NELT, & id%FRTPTR(1), id%FRTELT(1), & KEEP(1), KEEP8(1), ICNTL(1), id%KEEP(50) ) id%KEEP(193)=1;id%KEEP(194)=1 id%KEEP(195)=1; id%KEEP(196)=1 ALLOCATE( id%PTR8ARR(1), & id%NINCOLARR(1), & id%NINROWARR(1), & id%PTRDEBARR(1), stat=allocok) IF (allocok .GT. 0) THEN id%INFO(1)=-7 id%INFO(2)=4 ENDIF ENDIF ELSE KEEP8(26) = 0_8 KEEP8(27) = 0_8 ALLOCATE( id%PTR8ARR(1), & id%NINCOLARR(1), & id%NINROWARR(1), & id%PTRDEBARR(1), stat=allocok) IF (allocok .GT. 0) THEN id%INFO(1)=-7 id%INFO(2)=4 ENDIF ENDIF 500 CONTINUE IF (allocated(NBINROW_TMP)) DEALLOCATE(NBINROW_TMP) IF (allocated(NBINCOL_TMP)) DEALLOCATE(NBINCOL_TMP) RETURN END SUBROUTINE SMUMPS_ANA_ARROWHEADS_WRAPPER SUBROUTINE SMUMPS_ANA_DIST_ARROWHEADS( MYID, SLAVEF, N, & PROCNODE, STEP, FILS, ISTEP_TO_INIV2, & I_AM_CAND, & KEEP, KEEP8, ICNTL, id, NINCOL_TMP, NINROW_TMP ) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE (SMUMPS_STRUC) :: id INTEGER MYID, N, SLAVEF INTEGER KEEP( 500 ), ICNTL( 60 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE( KEEP(28) ), STEP( N ), FILS( N ) INTEGER, INTENT(INOUT) :: NINCOL_TMP( N ) INTEGER, INTENT(INOUT) :: NINROW_TMP( N ) INTEGER ISTEP_TO_INIV2(KEEP(71)) LOGICAL I_AM_CAND(max(1,KEEP(56))) LOGICAL I_AM_SLAVE LOGICAL I_AM_CAND_LOC INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT INTEGER ISTEP, I, J, NINCOL, NINROW, allocok INTEGER TYPE_PARALL, ITYPE, IRANK, INIV2, TYPESPLIT LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS INTEGER :: NBARR_LOCAL INTEGER(8) :: IPTR EARLYT3ROOTINS = KEEP(200) .EQ. 0 & .OR. (KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0) TYPE_PARALL = KEEP(46) I_AM_SLAVE = (KEEP(46).EQ.1 .OR. MYID.NE.0) NBARR_LOCAL=0 DO J = 1, N ISTEP = STEP( J ) IF ( ISTEP .GT. 0 ) THEN I = J DO WHILE (I .GT. 0) ITYPE = MUMPS_TYPENODE( PROCNODE(ISTEP), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), KEEP(199) ) TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. T4_MASTER_CONCERNED = .FALSE. IF (ITYPE.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) THEN I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN IF ( TYPE_PARALL .eq. 0 ) THEN T4_MASTER_CONCERNED = & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID-1 ) ELSE T4_MASTER_CONCERNED = & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID ) ENDIF ENDIF ENDIF ENDIF IF ( TYPE_PARALL .eq. 0 ) THEN IRANK =IRANK + 1 END IF IF ( & ( ITYPE .eq. 2 .and. & IRANK .eq. MYID ) & .or. & ( ITYPE .eq. 1 .and. & IRANK .eq. MYID ) & .or. & ( T4_MASTER_CONCERNED ) & ) THEN NINCOL = NINCOL_TMP(I) NINROW = NINROW_TMP(I) ELSE IF ( ITYPE .EQ. 3 ) THEN IF ( EARLYT3ROOTINS ) THEN NINCOL = -1 NINROW = -1 ELSE NINCOL = NINCOL_TMP(I) NINROW = NINROW_TMP(I) ENDIF ELSE IF ( ITYPE .eq. 2 .AND. I_AM_CAND_LOC ) THEN NINCOL = NINCOL_TMP(I) NINROW = 0 ELSE NINCOL = -1 NINROW = -1 ENDIF IF ( NINCOL .NE. -1 ) THEN NBARR_LOCAL = NBARR_LOCAL + 1 ENDIF NINCOL_TMP(I)=NINCOL NINROW_TMP(I)=NINROW I=FILS(I) ENDDO ENDIF ENDDO KEEP(193) = max(1, NBARR_LOCAL) KEEP(194) = max(1, NBARR_LOCAL) KEEP(195) = max(1, NBARR_LOCAL) KEEP(196) = KEEP(28) ALLOCATE(id%PTR8ARR(KEEP(193)), & id%NINCOLARR(KEEP(194)), id%NINROWARR(KEEP(195)), & id%PTRDEBARR(KEEP(196)), stat=allocok) IF (allocok.GT.0) THEN id%INFO(1)=-7 CALL MUMPS_SET_IERROR( int(KEEP(194),8)+int(KEEP(195),8)+ & int(KEEP(196),8), id%INFO(2) ) RETURN ENDIF IPTR = 1_8 NBARR_LOCAL = 0 DO J = 1, N ISTEP = STEP( J ) IF ( ISTEP .GT. 0 ) THEN id%PTRDEBARR(ISTEP) = NBARR_LOCAL + 1 I = J DO WHILE (I .GT. 0) NINCOL = NINCOL_TMP(I) NINROW = NINROW_TMP(I) IF ( NINCOL .NE. -1 ) THEN NBARR_LOCAL = NBARR_LOCAL + 1 id%NINCOLARR( NBARR_LOCAL ) = NINCOL id%NINROWARR( NBARR_LOCAL ) = NINROW id%PTR8ARR ( NBARR_LOCAL ) = IPTR IPTR = IPTR + int(NINCOL + NINROW + 1,8) ENDIF I=FILS(I) ENDDO IF ( NINCOL .EQ. -1 ) THEN id%PTRDEBARR( ISTEP ) = -99999 ENDIF ENDIF ENDDO KEEP8(26) = IPTR - 1 KEEP8(27) = IPTR - 1 RETURN END SUBROUTINE SMUMPS_ANA_DIST_ARROWHEADS SUBROUTINE SMUMPS_FACTO_SEND_ARROWHEADS( N, NZ, ASPK, & IRN, ICN, PERM, & LSCAL,COLSCA,ROWSCA, & MYID, SLAVEF, PROCNODE_STEPS, NBRECORDS, & COMM, root, roota, KEEP, KEEP8, FILS, & INTARR, LINTARR, DBLARR, LDBLARR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, FRERE_STEPS, & STEP, A, LA, ISTEP_TO_INIV2, I_AM_CAND, CANDIDATES, & ICNTL, INFO ) !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER :: N, COMM, NBRECORDS INTEGER(8), INTENT(IN) :: NZ INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL ASPK(NZ) REAL COLSCA(*), ROWSCA(*) INTEGER IRN(NZ), ICN(NZ) INTEGER PERM(N), PROCNODE_STEPS(KEEP(28)) INTEGER FILS( N ) INTEGER ISTEP_TO_INIV2(KEEP(71)) LOGICAL I_AM_CAND(max(1,KEEP(56))) INTEGER SLAVEF, MYID INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56))) LOGICAL LSCAL TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER INFO( 80 ), ICNTL(60) INTEGER(8), INTENT(IN) :: LA INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER :: FRERE_STEPS( KEEP(28) ) INTEGER :: STEP(N) INTEGER(8) :: LINTARR, LDBLARR INTEGER :: INTARR( LINTARR ) REAL :: DBLARR( LDBLARR ) REAL :: A( LA ) INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT INTEGER LP LOGICAL LPOK REAL VAL, VAL_SHR INTEGER IOLD,JOLD,ISEND,JSEND,DEST,I,IARR INTEGER ISEND_SHR, JSEND_SHR, DEST_SHR INTEGER IPOSROOT, JPOSROOT INTEGER IROW_GRID, JCOL_GRID INTEGER ISTEP INTEGER NBUFS INTEGER ARROW_ROOT, TAILLE INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT INTEGER TYPE_NODE, MASTER_NODE LOGICAL I_AM_CAND_LOC, I_AM_SLAVE INTEGER JARR, ILOCROOT, JLOCROOT INTEGER allocok, INIV2, TYPESPLIT, T4MASTER INTEGER(8) :: IS8, K INTEGER NCAND LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: PTRAW INTEGER :: IARR1, IORG, J INTEGER, DIMENSION(:,:), ALLOCATABLE :: BUFI REAL, DIMENSION(:,:), ALLOCATABLE :: BUFR LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P INTEGER NOMP, NOMP_P, IOMP, P2 LP = ICNTL(1) LPOK = ( LP .GT. 0 .AND. ICNTL(4) .GE. 1 ) ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ. 0 & .OR. (KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0) I_AM_SLAVE=(MYID.NE.0.OR.KEEP(46).EQ.1) IF ( KEEP(46) .eq. 0 ) THEN NBUFS = SLAVEF ELSE NBUFS = SLAVEF - 1 ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR( int(N,8)+int(N,8), INFO(2) ) IF (LPOK ) WRITE (LP,*) MYID, & ': Error allocating IW4 in SMUMPS_FACTO_SEND_ARROWHEADS' GOTO 100 END IF ALLOCATE( PTRAW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = N IF (LPOK ) WRITE (LP,*) MYID, & ': Error allocating PTRAW in SMUMPS_FACTO_SEND_ARROWHEADS' GOTO 100 END IF ENDIF IF (NBUFS.GT.0) THEN ALLOCATE( BUFI(NBRECORDS*2+1,NBUFS),stat=allocok ) IF ( allocok .GT. 0 ) THEN IF (LPOK ) WRITE (LP,*) MYID, & ': Error allocating BUFI in SMUMPS_FACTO_SEND_ARROWHEADS' INFO(1)=-13 CALL MUMPS_SET_IERROR( int(NBUFS,8) * int(NBRECORDS*2+1,8), & INFO(2)) GOTO 100 END IF ALLOCATE( BUFR( NBRECORDS, NBUFS ), stat=allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) =-13 CALL MUMPS_SET_IERROR( int(NBUFS,8) * int(NBRECORDS*2+1,8), & INFO(2)) IF (LPOK ) WRITE (LP,*) MYID, & ': Error allocating BUFR in SMUMPS_FACTO_SEND_ARROWHEADS' GOTO 100 END IF DO I = 1, NBUFS BUFI( 1, I ) = 0 ENDDO ENDIF 100 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF (KEEP(46) .NE. 0) THEN #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, N ISTEP=STEP(J) IF (ISTEP .GT. 0) THEN IARR1 = PTRDEBARR( ISTEP ) IF ( IARR1 .GT. 0 ) THEN I = J IORG = 0 DO WHILE ( I .GT. 0 ) IORG = IORG + 1 IW4(I, 1) = NINCOLARR( IARR1 + IORG - 1 ) IW4(I, 2) = NINROWARR( IARR1 + IORG - 1 ) + & NINCOLARR( IARR1 + IORG - 1 ) IS8 = PTR8ARR( IARR1 + IORG - 1 ) PTRAW( I ) = IS8 INTARR( IS8 ) = I DBLARR( IS8 ) = ZERO I = FILS(I) ENDDO ENDIF ENDIF ENDDO IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL SMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, & PTR_ROOT, LA) CALL SMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF END IF NOMP = 1 !$ NOMP=omp_get_max_threads() OMP_FLAG = KEEP(399).EQ.1 .AND. NOMP.GE.2 .AND. SLAVEF.EQ.1 & .AND. KEEP(46) .EQ. 1 !$OMP PARALLEL PRIVATE(K, I, DEST, I_AM_CAND_LOC, !$OMP& T4MASTER, T4_MASTER_CONCERNED, !$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, !$OMP& ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, !$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE, !$OMP& IS8, TAILLE, VAL, !$OMP& IARR, JARR, ISTEP, ISEND, JSEND, !$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P) !$OMP& REDUCTION(+: ARROW_ROOT) IF (OMP_FLAG) IOMP=0 !$ IOMP=omp_get_thread_num() NOMP_P=1 !$ NOMP_P=omp_get_num_threads() OMP_FLAG_P = .FALSE. !$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1 IF (OMP_FLAG_P) THEN IF ( NOMP_P .GE. 16 ) THEN NOMP_P=16 P2 = 4 ELSE IF (NOMP_P.GE.8) THEN NOMP_P=8 P2 = 3 ELSE IF (NOMP_P.GE.4) THEN NOMP_P=4 P2 = 2 ELSE IF (NOMP_P.GE.2) THEN NOMP_P=2 P2 = 1 ENDIF ELSE NOMP_P = 1 P2 = 0 ENDIF IF ( IOMP .LT. NOMP_P ) THEN DO K=1, NZ IOLD = IRN(K) JOLD = ICN(K) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE END IF IF (OMP_FLAG_P) THEN IF (IOLD.EQ.JOLD) THEN IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD ELSE IARR = JOLD ENDIF DOIT = ( IOMP .EQ. ibits(IARR, P2-1, P2)) ELSE DOIT = .TRUE. ENDIF IF (DOIT) THEN IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = JOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF ISTEP = abs( STEP(IARR) ) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 IF ( TYPE_NODE .EQ. 1 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF ELSE IF ( TYPE_NODE .EQ. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF END IF INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) IF ( KEEP(46) .eq. 0 ) THEN T4MASTER=T4MASTER+1 ENDIF ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND .LT. 0 ) THEN IPOSROOT = root%RG2L(JSEND) JPOSROOT = root%RG2L(IARR) ELSE IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JSEND ) END IF IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL ) IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * root%NPCOL + JCOL_GRID END IF ELSE DEST = -2 ENDIF END IF IF (LSCAL) THEN VAL = ASPK(K)*ROWSCA(IOLD)*COLSCA(JOLD) ELSE VAL = ASPK(K) ENDIF IF ( DEST .eq. 0 & .or. & ( DEST .eq. -1 .and. KEEP( 46 ) .eq. 1 .AND. & ( I_AM_CAND_LOC .OR. MASTER_NODE .EQ. 0 ) ) & .or. & ( T4MASTER.EQ.0 ) & .or. & ( DEST .EQ. -2 .AND. KEEP( 46 ) .EQ. 1 ) & ) THEN IARR = ISEND JARR = JSEND IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%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 IS8 = PTRAW( IARR ) DBLARR( IS8 ) = DBLARR( IS8 ) + VAL ELSE IS8 = PTRAW(IARR) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL END IF ELSE IARR = -IARR IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 .AND. & STEP( IARR) > 0 ) THEN IF ( MASTER_NODE == MYID) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL SMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF END IF END IF END IF IF ( DEST.EQ. -1 ) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79).GT.0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) IF (KEEP(46).EQ.0.AND.(DEST.GE.0)) DEST=DEST+1 IF (DEST.LT.0) EXIT IF (I.EQ.NCAND+1) CYCLE IF (DEST.NE.0) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL SMUMPS_ARROW_FILL_SEND_BUF() ENDIF ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) IF (KEEP(46).EQ.0) DEST=DEST+1 IF (DEST.NE.0) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL SMUMPS_ARROW_FILL_SEND_BUF() ENDIF ENDDO ENDIF DEST = MASTER_NODE IF (KEEP(46).EQ.0) DEST=DEST+1 IF ( DEST .NE. 0 ) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL SMUMPS_ARROW_FILL_SEND_BUF() ENDIF IF ((T4_MASTER_CONCERNED).AND.(T4MASTER.GT.0)) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=T4MASTER CALL SMUMPS_ARROW_FILL_SEND_BUF() ENDIF ELSE IF ( DEST .GT. 0 ) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL SMUMPS_ARROW_FILL_SEND_BUF() IF ( T4MASTER.GT.0 ) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=T4MASTER CALL SMUMPS_ARROW_FILL_SEND_BUF() ENDIF ELSE IF ( T4MASTER.GT.0 ) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=T4MASTER CALL SMUMPS_ARROW_FILL_SEND_BUF() ELSE IF ( DEST .EQ. -2 ) THEN DO I = 0, SLAVEF-1 DEST = I IF (KEEP(46) .EQ. 0) DEST = DEST + 1 IF (DEST .NE. 0) THEN ISEND_SHR=ISEND; JSEND_SHR=JSEND VAL_SHR=VAL; DEST_SHR=DEST CALL SMUMPS_ARROW_FILL_SEND_BUF() ENDIF ENDDO ENDIF ENDIF ENDDO ENDIF !$OMP END PARALLEL KEEP(49) = ARROW_ROOT IF (NBUFS.GT.0) THEN CALL SMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP( 46 ) ) ENDIF 500 CONTINUE IF ( allocated(IW4 ) ) DEALLOCATE( IW4 ) IF ( allocated(PTRAW ) ) DEALLOCATE( PTRAW ) IF ( allocated(BUFI ) ) DEALLOCATE( BUFI ) IF ( allocated(BUFR ) ) DEALLOCATE( BUFR ) RETURN CONTAINS SUBROUTINE SMUMPS_ARROW_FILL_SEND_BUF() IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ IF (BUFI(1,DEST_SHR)+1.GT.NBRECORDS) THEN TAILLE_SENDI = BUFI(1,DEST_SHR) * 2 + 1 TAILLE_SENDR = BUFI(1,DEST_SHR) CALL MPI_SEND(BUFI(1,DEST_SHR),TAILLE_SENDI, & MPI_INTEGER, & DEST_SHR, ARROWHEAD, COMM, IERR ) CALL MPI_SEND( BUFR(1,DEST_SHR), TAILLE_SENDR, & MPI_REAL, DEST_SHR, & ARROWHEAD, COMM, IERR ) BUFI(1,DEST_SHR) = 0 ENDIF IREQ = BUFI(1,DEST_SHR) + 1 BUFI(1,DEST_SHR) = IREQ BUFI( IREQ * 2, DEST_SHR ) = ISEND_SHR BUFI( IREQ * 2 + 1, DEST_SHR ) = JSEND_SHR BUFR( IREQ, DEST_SHR ) = VAL_SHR RETURN END SUBROUTINE SMUMPS_ARROW_FILL_SEND_BUF END SUBROUTINE SMUMPS_FACTO_SEND_ARROWHEADS SUBROUTINE SMUMPS_ARROW_FILL_SEND_BUF_ELT( & ISEND_SHR, JSEND_SHR, VAL_SHR, & DEST_SHR, BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM ) IMPLICIT NONE INTEGER, INTENT(in) :: ISEND_SHR, JSEND_SHR REAL, INTENT(in) :: VAL_SHR INTEGER :: DEST_SHR, NBRECORDS, NBUFS, LP, COMM INTEGER :: BUFI( NBRECORDS*2+1, NBUFS ) REAL :: BUFR( NBRECORDS, NBUFS ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ IF (BUFI(1,DEST_SHR)+1.GT.NBRECORDS) THEN TAILLE_SENDI = BUFI(1,DEST_SHR) * 2 + 1 TAILLE_SENDR = BUFI(1,DEST_SHR) CALL MPI_SEND(BUFI(1,DEST_SHR),TAILLE_SENDI, & MPI_INTEGER, & DEST_SHR, ARROWHEAD, COMM, IERR ) CALL MPI_SEND( BUFR(1,DEST_SHR), TAILLE_SENDR, & MPI_REAL, DEST_SHR, & ARROWHEAD, COMM, IERR ) BUFI(1,DEST_SHR) = 0 ENDIF IREQ = BUFI(1,DEST_SHR) + 1 BUFI(1,DEST_SHR) = IREQ BUFI( IREQ * 2, DEST_SHR ) = ISEND_SHR BUFI( IREQ * 2 + 1, DEST_SHR ) = JSEND_SHR BUFR( IREQ, DEST_SHR ) = VAL_SHR RETURN END SUBROUTINE SMUMPS_ARROW_FILL_SEND_BUF_ELT SUBROUTINE SMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM, & TYPE_PARALL ) IMPLICIT NONE INTEGER NBUFS, NBRECORDS, TYPE_PARALL INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS ) REAL BUFR( NBRECORDS, NBUFS ) INTEGER COMM INTEGER LP INTEGER ISLAVE, TAILLE_SENDI, TAILLE_SENDR, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' DO ISLAVE = 1,NBUFS TAILLE_SENDI = BUFI(1,ISLAVE) * 2 + 1 TAILLE_SENDR = BUFI(1,ISLAVE) BUFI(1,ISLAVE) = - BUFI(1,ISLAVE) CALL MPI_SEND(BUFI(1,ISLAVE),TAILLE_SENDI, & MPI_INTEGER, & ISLAVE, ARROWHEAD, COMM, IERR ) IF ( TAILLE_SENDR .NE. 0 ) THEN CALL MPI_SEND( BUFR(1,ISLAVE), TAILLE_SENDR, & MPI_REAL, ISLAVE, & ARROWHEAD, COMM, IERR ) END IF ENDDO RETURN END SUBROUTINE SMUMPS_ARROW_FINISH_SEND_BUF RECURSIVE SUBROUTINE SMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTLIST, DBLLIST, TAILLE, LO, HI ) IMPLICIT NONE INTEGER N, TAILLE INTEGER PERM( N ) INTEGER INTLIST( TAILLE ) REAL DBLLIST( TAILLE ) INTEGER LO, HI INTEGER I,J INTEGER ISWAP, PIVOT REAL sswap I = LO J = HI PIVOT = PERM(INTLIST((I+J)/2)) 10 IF (PERM(INTLIST(I)) < PIVOT) THEN I=I+1 GOTO 10 ENDIF 20 IF (PERM(INTLIST(J)) > PIVOT) THEN J=J-1 GOTO 20 ENDIF IF (I < J) THEN ISWAP = INTLIST(I) INTLIST(I) = INTLIST(J) INTLIST(J)=ISWAP sswap = DBLLIST(I) DBLLIST(I) = DBLLIST(J) DBLLIST(J) = sswap ENDIF IF ( I <= J) THEN I = I+1 J = J-1 ENDIF IF ( I <= J ) GOTO 10 IF ( LO < J ) CALL SMUMPS_QUICK_SORT_ARROWHEADS(N, PERM, & INTLIST, DBLLIST, TAILLE, LO, J) IF ( I < HI ) CALL SMUMPS_QUICK_SORT_ARROWHEADS(N, PERM, & INTLIST, DBLLIST, TAILLE, I, HI) RETURN END SUBROUTINE SMUMPS_QUICK_SORT_ARROWHEADS SUBROUTINE SMUMPS_FACTO_RECV_ARROWHD2( N, & DBLARR, LDBLARR, INTARR, LINTARR, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & KEEP, KEEP8, FILS, MYID, COMM, NBRECORDS, & A, LA, root, roota, & PROCNODE_STEPS, & SLAVEF, PERM, FRERE_STEPS, STEP, ICNTL, INFO ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, MYID, COMM INTEGER KEEP(500) INTEGER(8), INTENT(IN) :: LDBLARR, LINTARR INTEGER INTARR(LINTARR) INTEGER, INTENT(IN) :: FILS( N ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER(8) KEEP8(150) INTEGER(8), intent(IN) :: LA INTEGER PROCNODE_STEPS( KEEP(28) ), PERM( N ) INTEGER SLAVEF, NBRECORDS REAL A( LA ) INTEGER INFO( 80 ), ICNTL(60) REAL DBLARR(LDBLARR) INTEGER FRERE_STEPS( KEEP(28) ), STEP(N) TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER LP LOGICAL LPOK INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFI REAL, ALLOCATABLE, DIMENSION(:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: PTRAW INTEGER :: IARR1, IORG, J, ISTEP LOGICAL :: EARLYT3ROOTINS LOGICAL FINI INTEGER IREC, NB_REC, IARR, JARR, I, allocok INTEGER(8) :: IS8 INTEGER LOCAL_M, LOCAL_N, ILOCROOT, JLOCROOT, & IPOSROOT, JPOSROOT, TAILLE, & IPROC INTEGER(8) :: PTR_ROOT INTEGER ARROW_ROOT, TYPE_PARALL INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE REAL VAL REAL ZERO PARAMETER( ZERO = 0.0E0 ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MASTER PARAMETER(MASTER=0) INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) TYPE_PARALL = KEEP(46) LP = ICNTL(1) LPOK = ( LP .GT. 0 .AND. ICNTL(4) .GE. 1 ) ARROW_ROOT=0 EARLYT3ROOTINS = KEEP(200) .EQ. 0 & .OR. (KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0) ALLOCATE( BUFI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = NBRECORDS * 2 + 1 IF (LPOK) WRITE(LP,*) MYID, & ': Error allocaing BUFI in SMUMPS_FACTO_RECV_ARROWHD2' GOTO 100 END IF ALLOCATE( BUFR( NBRECORDS ) , stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = NBRECORDS IF (LPOK) WRITE(LP,*) MYID, & ': Error allocaing BUFR in SMUMPS_FACTO_RECV_ARROWHD2' GOTO 100 END IF ALLOCATE( IW4(N,2), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR( 2_8 * int(N,8), INFO(2) ) IF (LPOK) WRITE(LP,*) MYID, & ': Error allocaing IW4 in SMUMPS_FACTO_RECV_ARROWHD2' GOTO 100 END IF ALLOCATE( PTRAW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = N IF (LPOK) WRITE(LP,*) MYID, & ': Error allocaing PTRAW in SMUMPS_FACTO_RECV_ARROWHD2' GOTO 100 END IF 100 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF ( KEEP(38).NE.0 .AND. EARLYT3ROOTINS ) THEN CALL SMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL SMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF FINI = .FALSE. #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, N ISTEP=STEP(J) IF (ISTEP .GT. 0) THEN IARR1 = PTRDEBARR( ISTEP ) IF ( IARR1 .GT. 0 ) THEN I = J IORG = 0 DO WHILE ( I .GT. 0 ) IORG = IORG + 1 IW4(I, 1) = NINCOLARR( IARR1 + IORG - 1 ) IW4(I, 2) = NINROWARR( IARR1 + IORG - 1 ) + & NINCOLARR( IARR1 + IORG - 1 ) IS8 = PTR8ARR( IARR1 + IORG - 1 ) PTRAW( I ) = IS8 INTARR( IS8 ) = I DBLARR( IS8 ) = ZERO I = FILS(I) ENDDO ENDIF ENDIF ENDDO DO WHILE (.NOT.FINI) CALL MPI_RECV( BUFI(1), 2*NBRECORDS+1, & MPI_INTEGER, MASTER, & ARROWHEAD, & COMM, STATUS, IERR ) NB_REC = BUFI(1) IF (NB_REC.LE.0) THEN FINI = .TRUE. NB_REC = -NB_REC ENDIF IF (NB_REC.EQ.0) EXIT CALL MPI_RECV( BUFR(1), NBRECORDS, MPI_REAL, & MASTER, ARROWHEAD, & COMM, STATUS, IERR ) DO IREC=1, NB_REC IARR = BUFI( IREC * 2 ) JARR = BUFI( IREC * 2 + 1 ) VAL = BUFR( IREC ) IF ( MUMPS_TYPENODE( PROCNODE_STEPS(abs(STEP(abs(IARR)))), & KEEP(199) ) .eq. 3 & .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L( IARR ) JPOSROOT = root%RG2L( JARR ) ELSE IPOSROOT = root%RG2L( JARR ) JPOSROOT = root%RG2L( -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 roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%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 IS8 = PTRAW(IARR) DBLARR(IS8) = DBLARR( IS8 ) + VAL ELSE IS8 = PTRAW(IARR) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 INTARR(IS8) = JARR DBLARR(IS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)), & KEEP(199) ) IF ( TYPE_PARALL .eq. 0 ) THEN IPROC = IPROC + 1 END IF IF (IPROC .EQ. MYID) THEN TAILLE = NINCOLARR(PTRDEBARR(STEP( IARR ) )) CALL SMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAW(IARR) + 1 ), & DBLARR( PTRAW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF END IF ENDIF ENDDO END DO 500 CONTINUE IF (allocated(BUFI ) ) DEALLOCATE( BUFI ) IF (allocated(BUFR ) ) DEALLOCATE( BUFR ) IF (allocated(IW4 ) ) DEALLOCATE( IW4 ) IF (allocated(PTRAW ) ) DEALLOCATE( PTRAW ) KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE SMUMPS_FACTO_RECV_ARROWHD2 SUBROUTINE SMUMPS_SET_TO_ZERO(A, LLD, M, N, KEEP) !$ USE OMP_LIB, ONLY : OMP_GET_MAX_THREADS IMPLICIT NONE INTEGER, INTENT(IN) :: LLD, M, N REAL :: A(int(LLD,8)*int(N-1,8)+int(M,8)) INTEGER :: KEEP(500) REAL, PARAMETER :: ZERO = 0.0E0 INTEGER I, J !$ INTEGER :: NOMP INTEGER(8) :: I8, LA !$ NOMP = OMP_GET_MAX_THREADS() IF (LLD .EQ. M) THEN LA=int(LLD,8)*int(N-1,8)+int(M,8) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC,KEEP(361)) !$OMP& IF ( LA > int(KEEP(361),8) .AND. NOMP .GT. 1) DO I8=1, LA A(I8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO PRIVATE(I,J) COLLAPSE(2) !$OMP& SCHEDULE(STATIC,KEEP(361)) IF (int(M,8)*int(N,8) !$OMP& .GT. KEEP(361).AND. NOMP .GT.1) DO I = 1, N DO J = 1, M A( int(I-1,8)*int(LLD,8)+ int(J,8) ) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE SMUMPS_SET_TO_ZERO SUBROUTINE SMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER(8), INTENT(IN) :: LA REAL, INTENT(INOUT) :: A(LA) INTEGER :: KEEP(500) TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER :: LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT IF (KEEP(60)==0) THEN CALL SMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA) IF (LOCAL_N .GT. 0) THEN CALL SMUMPS_SET_TO_ZERO(A(PTR_ROOT), & LOCAL_M, LOCAL_M, LOCAL_N, KEEP) ENDIF ELSE IF (root%yes) THEN CALL SMUMPS_SET_TO_ZERO(roota%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC, & KEEP) ENDIF RETURN END SUBROUTINE SMUMPS_SET_ROOT_TO_ZERO SUBROUTINE SMUMPS_GET_ROOT_INFO(root, & LOCAL_M, LOCAL_N, PTR_ROOT, LA) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC), INTENT(IN) :: root INTEGER, INTENT(OUT) :: LOCAL_M, LOCAL_N INTEGER(8), INTENT(OUT) :: PTR_ROOT INTEGER(8), INTENT(IN) :: LA INTEGER, EXTERNAL :: MUMPS_NUMROC LOCAL_M = MUMPS_NUMROC( root%ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) LOCAL_M = max( 1, LOCAL_M ) LOCAL_N = MUMPS_NUMROC( root%ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) PTR_ROOT = LA - int(LOCAL_M,8) * int(LOCAL_N,8) + 1_8 RETURN END SUBROUTINE SMUMPS_GET_ROOT_INFO MUMPS_5.8.1/src/zfac_asm_ELT.F0000664000175000017500000002422215042446441015631 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ELT_ASM_S_2_S_INIT( & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP, KEEP8, MYID, LRGROUPS) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER NELT, N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID INTEGER NBROWS, NBCOLS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER INTARR(KEEP8(27)) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) COMPLEX(kind=8) :: A(LA) COMPLEX(kind=8) :: DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) INTEGER(8) :: POSELT COMPLEX(kind=8), DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL ZMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) IF (NASS.LT.0) THEN NASS = -NASS IW(IOLDPS+1+KEEP(IXSZ)) = NASS CALL ZMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, FILS, & PTRAIW, PTRARW, & INTARR, DBLARR, KEEP8(27), KEEP8(26), FRT_PTR, FRT_ELT, & RHS_MUMPS, LRGROUPS) ENDIF IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_ELT_ASM_S_2_S_INIT SUBROUTINE ZMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW, &IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, PTRARW, &INTARR, DBLARR, LINTARR, LDBLARR, FRT_PTR, FRT_ELT, RHS_MUMPS, &LRGROUPS) !$ USE OMP_LIB USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, intent(in) :: N, NELT, LIW, IOLDPS, INODE INTEGER(8), intent(in) :: LA, POSELT, LINTARR, LDBLARR INTEGER, intent(in) :: IW(LIW) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(inout) :: ITLOC(N+KEEP(253)) COMPLEX(kind=8), intent(inout) :: A(LA) COMPLEX(kind=8), intent(in) :: RHS_MUMPS(KEEP8(85)) INTEGER, intent(in) :: INTARR(LINTARR) COMPLEX(kind=8), intent(in) :: DBLARR(LDBLARR) INTEGER, intent(in) :: FRT_PTR(N+1), FRT_ELT(NELT) INTEGER, intent(in) :: FILS(N) INTEGER(8), intent(in) :: PTRAIW(NELT+1), PTRARW(NELT+1) INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 !$ INTEGER :: CHUNK INCLUDE 'mumps_headers.h' INTEGER :: HF, NBROWF, NBCOLF, NASS, NSLAVES INTEGER :: ILOC, IELL, ELTI, ELBEG, NUMELT INTEGER(8) :: SIZE_ELTI8 INTEGER :: I, J, K, K1, K2 INTEGER :: IPOS, IPOS1, IPOS2, JPOS, IJROW INTEGER :: IN INTEGER(8) :: II8, JJ8, J18, J28 INTEGER(8) :: AINPUT8 INTEGER(8) :: AII8 INTEGER(8) :: APOS, APOS2, ICT12 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE, TOPDIAG INTEGER(8) :: JJ3 INTEGER :: K1RHS, K2RHS, JFirstRHS COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) !$ NOMP = OMP_GET_MAX_THREADS() IF (KEEP(50) .EQ. 0 .OR. NBROWF .LT. KEEP(63)) THEN !$ CHUNK8 = int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8) !$OMP& .AND. NOMP .GT. 1) DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = 0 IF (IW(IOLDPS+XXLR).GE.1) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0, & NBROWF, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) NB_BLR_LS = NPARTSCB call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR_LS) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS, & NBCOLF, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max( KEEP(360)/2, !$ & ((NBROWF+NOMP-1)/NOMP +2) / 3 ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK) !$OMP& IF (NBROWF .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(NBROWF-1,8) APOS = POSELT+ JJ8*int(NBCOLF,8) JJ3 = min( int(NBCOLF,8) - 1_8, & JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG ) A(APOS: APOS+JJ3) = ZERO ENDDO !$OMP END PARALLEL DO ENDIF K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = -JPOS JPOS = JPOS + 1 END DO K1 = IOLDPS + HF K2 = K1 + NBROWF - 1 JPOS = 1 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN K1RHS = 0 K2RHS = -1 DO K = K1, K2 J = IW(K) ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN K1RHS = K JFirstRHS=J-N ENDIF JPOS = JPOS + 1 ENDDO IF (K1RHS.GT.0) K2RHS=K2 IF ( K2RHS.GE.K1RHS ) THEN IN = INODE DO WHILE (IN.GT.0) IJROW = -ITLOC(IN) DO K = K1RHS, K2RHS J = IW(K) I = ITLOC(J) ILOC = mod(I,NBCOLF) APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+ IN) ENDDO IN = FILS(IN) ENDDO ENDIF ELSE DO K = K1, K2 J = IW(K) ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS JPOS = JPOS + 1 END DO ENDIF ELBEG = FRT_PTR(INODE) NUMELT = FRT_PTR(INODE+1) - ELBEG DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1_8 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = ITLOC(INTARR(II8)) IF (KEEP(50).EQ.0) THEN IF (I.LE.0) CYCLE AINPUT8 = AII8 + II8 - J18 IPOS = mod(I,NBCOLF) ICT12 = POSELT + int(IPOS-1,8) * int(NBCOLF,8) DO JJ8 = J18, J28 JPOS = ITLOC(INTARR(JJ8)) IF (JPOS.LE.0) THEN JPOS = -JPOS ELSE JPOS = JPOS/NBCOLF END IF APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ELSE IF ( I .EQ. 0 ) THEN AII8 = AII8 + J28 - II8 + 1_8 CYCLE ENDIF IF ( I .LE. 0 ) THEN IPOS1 = -I IPOS2 = 0 ELSE IPOS1 = I/NBCOLF IPOS2 = mod(I,NBCOLF) END IF ICT12 = POSELT + int(IPOS2-1,8)*int(NBCOLF,8) DO JJ8=II8,J28 AII8 = AII8 + 1_8 J = ITLOC(INTARR(JJ8)) IF ( J .EQ. 0 ) CYCLE IF ( IPOS2.EQ.0 .AND. J.LE.0) CYCLE IF ( J .LE. 0 ) THEN JPOS = -J ELSE JPOS = J/NBCOLF END IF IF ( (IPOS1.GE.JPOS) .AND. (IPOS2.GT.0) ) THEN APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AII8-1_8) END IF IF ( (IPOS1.LT.JPOS) .AND. (J.GT.0) ) THEN IPOS = mod(J,NBCOLF) JPOS = IPOS1 APOS2 = POSELT + int(IPOS-1,8)*int(NBCOLF,8) & + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AII8-1_8) END IF END DO END IF END DO END DO K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 END DO END SUBROUTINE ZMUMPS_ASM_SLAVE_ELEMENTS MUMPS_5.8.1/src/sfac_distrib_ELT.F0000664000175000017500000004533115042446437016513 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ELT_DISTRIB( & N, NELT, NA_ELT8, & COMM, MYID, SLAVEF, & IELPTR_LOC8, RELPTR_LOC8, & ELTVAR_LOC, ELTVAL_LOC, & LINTARR, LDBLARR, & KEEP,KEEP8, MAXELT_SIZE, & FRTPTR, FRTELT, A, LA, FILS, & id, root, roota ) USE SMUMPS_STRUC_DEF USE MUMPS_INTR_TYPES, ONLY: MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, NELT INTEGER(8) :: NA_ELT8 INTEGER COMM, MYID, SLAVEF, MAXELT_SIZE, MSGLEN INTEGER(8), intent(IN) :: LA INTEGER FRTPTR( N+1 ) INTEGER FRTELT( NELT ), FILS ( N ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), INTENT(IN) :: IELPTR_LOC8( NELT + 1 ) INTEGER(8), INTENT(INOUT) :: RELPTR_LOC8( NELT + 1 ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER ELTVAR_LOC( LINTARR ) REAL ELTVAL_LOC( LDBLARR ) REAL A( LA ) TYPE(SMUMPS_STRUC) :: id TYPE(MUMPS_ROOT_STRUC) :: root TYPE(SMUMPS_ROOT_STRUC) :: roota INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGTAG INTEGER allocok INTEGER I, DEST, MAXELT_REAL_SIZE, MPG, IEL, SIZEI, SIZER INTEGER NBRECORDS, NBUF INTEGER(8) :: RECV_IELTPTR8 INTEGER(8) :: RECV_RELTPTR8 INTEGER(8) :: IELTPTR8, RELTPTR8 LOGICAL FINI, PROKG, I_AM_SLAVE, EARLYT3ROOTINS INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, LP, IBEG, IGLOB, JGLOB INTEGER ARROW_ROOT INTEGER IELT, J, NB_REC, IREC INTEGER(8) :: K8, IVALPTR8 INTEGER ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, IPTR INTEGER JCOL_GRID, IROW_GRID INTEGER NBELROOT INTEGER MASTER PARAMETER( MASTER = 0 ) REAL VAL REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER, DIMENSION( :, : ), ALLOCATABLE :: BUFI REAL, DIMENSION( :, : ), ALLOCATABLE :: BUFR REAL, DIMENSION( : ), ALLOCATABLE :: TEMP_ELT_R INTEGER, DIMENSION( : ), ALLOCATABLE :: TEMP_ELT_I INTEGER(8), DIMENSION( : ), ALLOCATABLE :: ELROOTPOS8 MPG = id%ICNTL(3) LP = id%ICNTL(1) I_AM_SLAVE = ( KEEP(46) .eq. 1 .or. MYID .ne.MASTER ) PROKG = ( MPG > 0 .and. MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) KEEP(49) = 0 ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ.0 & .OR. ( KEEP(200) .LT. 0 .AND. KEEP(400) .EQ. 0 ) IF ( MYID .eq. MASTER ) THEN IF ( KEEP(46) .eq. 0 ) THEN NBUF = SLAVEF ELSE NBUF = SLAVEF - 1 END IF NBRECORDS = KEEP(39) IF (NA_ELT8 < int(NBRECORDS,8)) THEN NBRECORDS = int(NA_ELT8) ENDIF IF ( KEEP(50) .eq. 0 ) THEN MAXELT_REAL_SIZE = MAXELT_SIZE * MAXELT_SIZE ELSE MAXELT_REAL_SIZE = MAXELT_SIZE * (MAXELT_SIZE+1)/2 END IF IF ( MAXELT_REAL_SIZE .GT. KEEP(39) ) THEN NBRECORDS = MAXELT_REAL_SIZE IF ( MPG .GT. 0 ) THEN WRITE(MPG,*) & ' ** Warning : For element distrib NBRECORDS set to ', & MAXELT_REAL_SIZE,' because one element is large' END IF END IF ALLOCATE( BUFI( 2*NBRECORDS+1, NBUF ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 2*NBRECORDS + 1 GOTO 100 END IF ALLOCATE( BUFR( NBRECORDS+1, NBUF ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS + 1 GOTO 100 END IF IF ( KEEP(52) .ne. 0 ) THEN ALLOCATE( TEMP_ELT_R( MAXELT_REAL_SIZE ), stat =allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXELT_REAL_SIZE GOTO 100 END IF END IF ALLOCATE( TEMP_ELT_I( MAXELT_SIZE ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXELT_SIZE GOTO 100 END IF IF ( KEEP(38) .ne. 0 ) THEN NBELROOT = FRTPTR(KEEP(38)+1)-FRTPTR(KEEP(38)) IF ( EARLYT3ROOTINS ) THEN ALLOCATE( ELROOTPOS8( max(NBELROOT,1) ), & stat = allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBELROOT GOTO 100 END IF ENDIF END IF DO I = 1, NBUF BUFI( 1, I ) = 0 BUFR( 1, I ) = ZERO END DO END IF 100 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MPI_BCAST( NBRECORDS, 1, MPI_INTEGER, MASTER, & COMM, IERR_MPI ) RECV_IELTPTR8 = 1_8 RECV_RELTPTR8 = 1_8 IF ( MYID .eq. MASTER ) THEN NBELROOT = 0 RELTPTR8 = 1_8 RELPTR_LOC8(1) = 1 DO IEL = 1, NELT IELTPTR8 = int(id%ELTPTR( IEL ),8) SIZEI = int(int(id%ELTPTR( IEL + 1 ),8) - IELTPTR8) IF ( KEEP( 50 ) .eq. 0 ) THEN SIZER = SIZEI * SIZEI ELSE SIZER = SIZEI * ( SIZEI + 1 ) / 2 END IF DEST = id%ELTPROC( IEL ) IF ( DEST .eq. -2 ) THEN NBELROOT = NBELROOT + 1 FRTELT( FRTPTR(KEEP(38)) + NBELROOT - 1 ) = IEL ELROOTPOS8( NBELROOT ) = RELTPTR8 GOTO 200 END IF IF ( DEST .ge. 0 .and. KEEP(46) .eq. 0 ) DEST = DEST + 1 IF ( KEEP(52) .ne. 0 ) THEN CALL SMUMPS_SCALE_ELEMENT( N, SIZEI, SIZER, & id%ELTVAR( IELTPTR8 ), id%A_ELT( RELTPTR8 ), & TEMP_ELT_R(1), MAXELT_REAL_SIZE, & id%ROWSCA(1), id%COLSCA(1), KEEP(50) ) END IF IF ( DEST .eq. 0 .or. ( DEST .eq. -1 .and. KEEP(46) .ne. 0 ) ) & THEN ELTVAR_LOC( RECV_IELTPTR8: RECV_IELTPTR8 + SIZEI - 1 ) & = id%ELTVAR( IELTPTR8: IELTPTR8 + SIZEI - 1 ) RECV_IELTPTR8 = RECV_IELTPTR8 + SIZEI IF ( KEEP(52) .ne. 0 & ) THEN ELTVAL_LOC( RECV_RELTPTR8: RECV_RELTPTR8 + SIZER - 1) & = TEMP_ELT_R( 1: SIZER ) RECV_RELTPTR8 = RECV_RELTPTR8 + SIZER END IF END IF IF ( DEST .NE. 0 .AND. DEST. NE. -3 ) THEN IF ( KEEP(52) .eq. 0 ) THEN CALL SMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & id%A_ELT (RELTPTR8), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) ELSE CALL SMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & TEMP_ELT_R( 1 ), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) END IF END IF 200 CONTINUE RELTPTR8 = RELTPTR8 + SIZER IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN RELPTR_LOC8( IEL + 1 ) = RELTPTR8 ELSE RELPTR_LOC8( IEL + 1 ) = RECV_RELTPTR8 ENDIF END DO IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN KEEP8(26) = RELTPTR8 - 1_8 ELSE KEEP8(26) = RECV_RELTPTR8 - 1_8 ENDIF IF ( RELTPTR8 - 1_8 .NE. NA_ELT8 ) THEN WRITE(*,*) " ** Internal error in SMUMPS_ELT_DISTRIB", & RELTPTR8 - 1_8, NA_ELT8 CALL MUMPS_ABORT() END IF DEST = -2 IELTPTR8 = 1_8 RELTPTR8 = 1_8 SIZEI = 1 SIZER = 1 CALL SMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & id%A_ELT (RELTPTR8), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) IF ( KEEP(52) .NE. 0 ) DEALLOCATE( TEMP_ELT_R ) ELSE FINI = ( RECV_IELTPTR8 .eq. IELPTR_LOC8( NELT+1 ) & .and. RECV_RELTPTR8 .eq. RELPTR_LOC8( NELT+1 ) ) DO WHILE ( .not. FINI ) CALL MPI_PROBE( MASTER, MPI_ANY_TAG, & COMM, STATUS, IERR_MPI ) MSGTAG = STATUS( MPI_TAG ) SELECT CASE ( MSGTAG ) CASE( ELT_INT ) CALL MPI_GET_COUNT( STATUS, MPI_INTEGER, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAR_LOC( RECV_IELTPTR8 ), MSGLEN, & MPI_INTEGER, MASTER, ELT_INT, & COMM, STATUS, IERR_MPI ) RECV_IELTPTR8 = RECV_IELTPTR8 + MSGLEN CASE( ELT_REAL ) CALL MPI_GET_COUNT( STATUS, MPI_REAL, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAL_LOC( RECV_RELTPTR8 ), MSGLEN, & MPI_REAL, MASTER, ELT_REAL, & COMM, STATUS, IERR_MPI ) RECV_RELTPTR8 = RECV_RELTPTR8 + MSGLEN END SELECT FINI = ( RECV_IELTPTR8 .eq. IELPTR_LOC8( NELT+1 ) & .and. RECV_RELTPTR8 .eq. RELPTR_LOC8( NELT+1 ) ) END DO END IF IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN IF ( I_AM_SLAVE .and. root%yes ) THEN CALL SMUMPS_GET_ROOT_INFO(root, & LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL SMUMPS_SET_ROOT_TO_ZERO(root, roota, KEEP, A, LA) END IF IF ( MYID .NE. MASTER ) THEN ALLOCATE( BUFI( NBRECORDS * 2 + 1, 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS * 2 + 1 GOTO 250 END IF ALLOCATE( BUFR( NBRECORDS, 1 ) , stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS END IF END IF 250 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF ( MYID .eq. MASTER ) THEN DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1 IELT = FRTELT( IPTR ) SIZEI = id%ELTPTR( IELT + 1 ) - id%ELTPTR( IELT ) DO I = 1, SIZEI TEMP_ELT_I( I ) = root%RG2L & ( id%ELTVAR( id%ELTPTR(IELT) + I - 1 ) ) END DO IVALPTR8 = ELROOTPOS8( IPTR - FRTPTR(KEEP(38)) + 1 ) - 1 K8 = 1_8 DO J = 1, SIZEI JGLOB = id%ELTVAR( id%ELTPTR( IELT ) + J - 1 ) IF ( KEEP(50).eq. 0 ) THEN IBEG = 1 ELSE IBEG = J END IF DO I = IBEG, SIZEI IGLOB = id%ELTVAR( id%ELTPTR( IELT ) + I - 1 ) IF ( KEEP(52) .eq. 0 ) THEN VAL = id%A_ELT( IVALPTR8 + K8 ) ELSE VAL = id%A_ELT( IVALPTR8 + K8 ) * & id%ROWSCA( IGLOB ) * id%COLSCA( JGLOB ) END IF IF ( KEEP(50).eq.0 ) THEN IPOSROOT = TEMP_ELT_I( I ) JPOSROOT = TEMP_ELT_I( J ) ELSE IF ( TEMP_ELT_I(I) .GT. TEMP_ELT_I(J) ) THEN IPOSROOT = TEMP_ELT_I(I) JPOSROOT = TEMP_ELT_I(J) ELSE IPOSROOT = TEMP_ELT_I(J) JPOSROOT = TEMP_ELT_I(I) END IF END IF IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, & root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, & root%NPCOL ) IF ( KEEP(46) .eq. 0 ) THEN DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * root%NPCOL + JCOL_GRID END IF IF ( DEST .eq. MASTER ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 ARROW_ROOT = ARROW_ROOT + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & + VAL ENDIF ELSE CALL SMUMPS_ARROW_FILL_SEND_BUF_ELT( & IPOSROOT, JPOSROOT, VAL, DEST, BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM ) END IF K8 = K8 + 1_8 END DO END DO END DO CALL SMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM, KEEP(46) ) ELSE FINI = .FALSE. DO WHILE ( .not. FINI ) CALL MPI_RECV( BUFI(1,1), 2*NBRECORDS+1, & MPI_INTEGER, MASTER, & ARROWHEAD, & COMM, STATUS, IERR_MPI ) NB_REC = BUFI(1,1) ARROW_ROOT = ARROW_ROOT + NB_REC IF (NB_REC.LE.0) THEN FINI = .TRUE. NB_REC = -NB_REC ENDIF IF (NB_REC.EQ.0) EXIT CALL MPI_RECV( BUFR(1,1), NBRECORDS, MPI_REAL, & MASTER, ARROWHEAD, & COMM, STATUS, IERR_MPI ) DO IREC = 1, NB_REC IPOSROOT = BUFI( IREC * 2, 1 ) JPOSROOT = BUFI( IREC * 2 + 1, 1 ) VAL = BUFR( IREC, 1 ) ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60).eq.0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) & = A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) & + VAL ELSE roota%SCHUR_POINTER(int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = roota%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF END DO END DO DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) END IF END IF IF ( MYID .eq. MASTER ) THEN DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) IF (allocated(ELROOTPOS8)) DEALLOCATE(ELROOTPOS8) DEALLOCATE( TEMP_ELT_I ) END IF KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE SMUMPS_ELT_DISTRIB SUBROUTINE SMUMPS_ELT_FILL_BUF( & ELNODES, ELVAL, SIZEI, SIZER, & DEST, NBUF, NBRECORDS, BUFI, BUFR, COMM ) IMPLICIT NONE INTEGER SIZEI, SIZER, DEST, NBUF, NBRECORDS, COMM INTEGER ELNODES( SIZEI ), BUFI( 2*NBRECORDS + 1, NBUF ) REAL ELVAL( SIZER ), BUFR( NBRECORDS + 1, NBUF ) INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER I, IBEG, IEND, IERR_MPI, NBRECR INTEGER NBRECI REAL ZERO PARAMETER( ZERO = 0.0E0 ) IF ( DEST .lt. 0 ) THEN IBEG = 1 IEND = NBUF ELSE IBEG = DEST IEND = DEST END IF DO I = IBEG, IEND NBRECI = BUFI(1,I) IF ( NBRECI .ne.0 .and. & ( DEST.eq.-2 .or. & NBRECI + SIZEI .GT. 2*NBRECORDS ) ) THEN CALL MPI_SEND( BUFI(2, I), NBRECI, MPI_INTEGER, & I, ELT_INT, COMM, IERR_MPI ) BUFI(1,I) = 0 NBRECI = 0 END IF NBRECR = int(real(BUFR(1,I))+0.5E0) IF ( NBRECR .ne.0 .and. & ( DEST.eq.-2 .or. & NBRECR + SIZER .GT. NBRECORDS ) ) THEN CALL MPI_SEND( BUFR(2, I), NBRECR, MPI_REAL, & I, ELT_REAL, COMM, IERR_MPI ) BUFR(1,I) = ZERO NBRECR = 0 END IF IF ( DEST .ne. -2 ) THEN BUFI( 2 + NBRECI : 2 + NBRECI + SIZEI - 1, I ) = & ELNODES( 1: SIZEI ) BUFR( 2 + NBRECR : 2 + NBRECR + SIZER - 1, I ) = & ELVAL( 1: SIZER ) BUFI(1,I) = NBRECI + SIZEI BUFR(1,I) = real( NBRECR + SIZER ) END IF END DO RETURN END SUBROUTINE SMUMPS_ELT_FILL_BUF SUBROUTINE SMUMPS_MAXELT_SIZE( ELTPTR, NELT, MAXELT_SIZE ) INTEGER NELT, MAXELT_SIZE INTEGER ELTPTR( NELT + 1 ) INTEGER I, S MAXELT_SIZE = 0 DO I = 1, NELT S = ELTPTR( I + 1 ) - ELTPTR( I ) MAXELT_SIZE = max( S, MAXELT_SIZE ) END DO RETURN END SUBROUTINE SMUMPS_MAXELT_SIZE SUBROUTINE SMUMPS_SCALE_ELEMENT( N, SIZEI, SIZER, & ELTVAR, ELTVAL, & SELTVAL, LSELTVAL, & ROWSCA, COLSCA, K50 ) INTEGER N, SIZEI, SIZER, LSELTVAL, K50 INTEGER ELTVAR( SIZEI ) REAL ELTVAL( SIZER ) REAL SELTVAL( LSELTVAL ) REAL ROWSCA( N ), COLSCA( N ) INTEGER I, J, K K = 1 IF ( K50 .eq. 0 ) THEN DO J = 1, SIZEI DO I = 1, SIZEI SELTVAL(K) = ELTVAL(K) * & ROWSCA(ELTVAR(I)) * & COLSCA(ELTVAR(J)) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI DO I = J, SIZEI SELTVAL(K) = ELTVAL(K) * & ROWSCA(ELTVAR(I)) * & COLSCA(ELTVAR(J)) K = K + 1 END DO END DO END IF RETURN END SUBROUTINE SMUMPS_SCALE_ELEMENT MUMPS_5.8.1/src/zfac_mem_stack.F0000664000175000017500000005747115042446441016324 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_FAC_STACK(COMM_LOAD, ASS_IRECV, & N, INODE, TYPE, TYPEF, & LA, IW, LIW, A, & IFLAG, IERROR, OPELIW, NELVAW, NMAXNPIV, & PTRIST, PTLUST_S, & PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, NE, & POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP,KEEP8,DKEEP, & COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, SLAVEF, & FPERE, COMM, MYID, IPOOL, LPOOL, LEAF, NSTK_S, & PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, root, roota, & OPASSW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & , FLOP_ESTIM_ACC & ) USE ZMUMPS_BUF, ONLY : ZMUMPS_BUF_SEND_CB, ZMUMPS_BUF_SEND_MAITRE2 USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_RTNELIND, & MUMPS_BUF_SEND_ROOT2SON USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER COMM, MYID, TYPE, TYPEF INTEGER N, LIW, INODE,IFLAG,IERROR INTEGER ICNTL(60), KEEP(500) DOUBLE PRECISION DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU INTEGER IWPOSCB, IWPOS, & FPERE, SLAVEF, NELVAW, NMAXNPIV INTEGER IW(LIW),PROCNODE_STEPS(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NE(KEEP(28)) COMPLEX(kind=8) A(LA) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER LPOOL, LEAF, COMP INTEGER IPOOL( LPOOL ) INTEGER NSTK_S( KEEP(28) ) INTEGER PERM(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER NBFIN INTEGER NFRONT_ESTIM,NELIM_ESTIM DOUBLE PRECISION FLOP_ESTIM_ACC INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER NBROWS_ALREADY_SENT INTEGER(8) :: POSELT, OPSFAC INTEGER(8) :: IOLD, INEW, FACTOR_POS, I8 INTEGER NSLAVES, NCB, & H_INODE, IERR, NBCOL, NBROW, NBROW_SEND, & NELIM INTEGER NBROW_STACK, NBROW_INDICES, NBCOL_STACK INTEGER NCBROW_ALREADY_MOVED, NCBROW_PREVIOUSLY_MOVED, &NCBROW_NEWLY_MOVED INTEGER(8) :: LAST_ALLOWED_POS INTEGER(8) :: LREQCB, MIN_SPACE_IN_PLACE INTEGER(8) :: SHIFT_VAL_SON INTEGER SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, & LIST_ROW_SON, LIST_COL_SON, LIST_SLAVES INTEGER IOLDPS,NFRONT,NPIV,NASS,IOLDP1,PTROWEND, & LREQI, LCONT INTEGER I,LDA, INIV2 INTEGER MSGDEST, MSGTAG, CHK_LOAD INCLUDE 'mumps_headers.h' LOGICAL MUST_COMPACT_FACTORS LOGICAL PACKED_CB, COMPRESS_PANEL, COMPRESS_CB, LR_SOLVE LOGICAL INPLACE INTEGER(8) :: SIZE_INPLACE, FAC_ENTRIES, COUNT_EXTRA_IP_COPIES INTEGER INTSIZ DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL SSARBR, SSARBR_ROOT, MUMPS_INSSARBR, & MUMPS_IN_OR_ROOT_SSARBR EXTERNAL MUMPS_INSSARBR, MUMPS_IN_OR_ROOT_SSARBR 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 = abs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) H_INODE= 6 + NSLAVES + KEEP(IXSZ) LCONT = NFRONT - NPIV NBCOL = LCONT SSARBR = MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) SSARBR_ROOT = MUMPS_IN_OR_ROOT_SSARBR & (PROCNODE_STEPS(STEP(INODE)),KEEP(199)) LREQCB = 0_8 INPLACE = .FALSE. PACKED_CB = ((KEEP(215).EQ.0) & .AND.(KEEP(50).NE.0) & .AND.(TYPEF.EQ.1 & .OR.TYPEF.EQ.2 & ) & .AND.(TYPE.EQ.1)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = (IW(IOLDPS+XXLR).EQ.1.OR.IW(IOLDPS+XXLR).EQ.3) LR_SOLVE = (KEEP(486).EQ.2) MUST_COMPACT_FACTORS = .TRUE. IF (KEEP(201).EQ.1 .OR. KEEP(201).EQ.-1 & .OR. (COMPRESS_PANEL.AND.LR_SOLVE) & ) THEN MUST_COMPACT_FACTORS = .FALSE. ENDIF IF ((FPERE.EQ.0).AND.(NASS.NE.NPIV)) THEN IFLAG = -10 GOTO 600 ENDIF NBROW = LCONT IF (TYPE.EQ.2) NBROW = NASS - NPIV IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN LDA = NASS ELSE LDA = NFRONT ENDIF NBROW_SEND = NBROW NELIM = NASS-NPIV IF (TYPEF.EQ.2) NBROW_SEND = NELIM POSELT = PTRAST(STEP(INODE)) IF (POSELT .ne. PTRFAC(STEP(INODE))) THEN WRITE(*,*) MYID,":Error 1 in ZMUMPS_FAC_STACK:" WRITE(*,*) "INODE, PTRAST, PTRFAC =", & INODE, PTRAST(STEP(INODE)), PTRFAC(STEP(INODE)) WRITE(*,*) "PACKED_CB, NFRONT, NPIV, NASS, NSLAVES", & PACKED_CB, NFRONT, NPIV, NASS, NSLAVES WRITE(*,*) "TYPE, TYPEF, FPERE ", & TYPE, TYPEF, FPERE CALL MUMPS_ABORT() END IF NELVAW = NELVAW + NASS - NPIV IF (KEEP(50) .eq. 0) THEN FAC_ENTRIES = int(NPIV,8) * int(NFRONT,8) ELSE FAC_ENTRIES = ( int(NPIV,8)*int(NPIV+1,8) )/ 2_8 ENDIF FAC_ENTRIES = FAC_ENTRIES + int(NBROW,8) * int(NPIV,8) IF ( KEEP(405) .EQ. 0 ) THEN KEEP8(10) = KEEP8(10) + FAC_ENTRIES KEEP(429) = KEEP(429) - 1 ELSE !$OMP ATOMIC UPDATE KEEP8(10) = KEEP8(10) + FAC_ENTRIES !$OMP END ATOMIC ENDIF CALL MUMPS_GET_FLOPS_COST( NFRONT, NPIV, NASS, & KEEP(50), TYPE,FLOP1 ) IF ( (.NOT. SSARBR_ROOT) .and. TYPE == 1) THEN IF (NE(STEP(INODE))==0) THEN CHK_LOAD=0 ELSE CHK_LOAD=1 ENDIF CALL MUMPS_LOAD_UPDATE(CHK_LOAD, .FALSE., -FLOP1, & KEEP,KEEP8) ENDIF FLOP1_EFFECTIVE = FLOP1 OPELIW = OPELIW + FLOP1 IF ( NPIV .NE. NASS ) THEN CALL MUMPS_GET_FLOPS_COST( NFRONT, NASS, NASS, & KEEP(50), TYPE,FLOP1 ) IF (.NOT. SSARBR_ROOT ) THEN IF (NE(STEP(INODE))==0) THEN CHK_LOAD=0 ELSE CHK_LOAD=1 ENDIF CALL MUMPS_LOAD_UPDATE(CHK_LOAD, .FALSE., & FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) ENDIF END IF IF ( SSARBR_ROOT ) THEN NFRONT_ESTIM=ND(STEP(INODE)) + KEEP(253) NELIM_ESTIM=NASS-(NFRONT-NFRONT_ESTIM) CALL MUMPS_GET_FLOPS_COST(NFRONT_ESTIM,NELIM_ESTIM,NELIM_ESTIM, & KEEP(50),1,FLOP1) END IF FLOP1=-FLOP1 IF (KEEP(400).GT.0) THEN FLOP_ESTIM_ACC = FLOP_ESTIM_ACC + FLOP1 ENDIF IF (SSARBR_ROOT) THEN CALL MUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1,KEEP,KEEP8) ELSE CALL MUMPS_LOAD_UPDATE(2,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF IF ( FPERE .EQ. 0 ) THEN IF ( KEEP(253) .NE. 0 .AND. KEEP(201).NE.-1 & .AND. KEEP(201).NE.1 & .AND. (.NOT.COMPRESS_PANEL.OR..NOT.LR_SOLVE) & ) THEN MUST_COMPACT_FACTORS = .TRUE. GOTO 190 ELSE IF ( KEEP(50) .NE. 0 .AND. KEEP(459).GT.1) THEN MUST_COMPACT_FACTORS = .TRUE. GOTO 190 ELSE MUST_COMPACT_FACTORS = .FALSE. GOTO 190 ENDIF ENDIF IF ( FPERE.EQ.KEEP(38) ) THEN NCB = NFRONT - NASS SHIFT_LIST_ROW_SON = H_INODE + NASS SHIFT_LIST_COL_SON = H_INODE + NFRONT + NASS SHIFT_VAL_SON = int(NASS,8)*int(NFRONT+1,8) IF (TYPE.EQ.1) THEN CALL ZMUMPS_BUILD_AND_SEND_CB_ROOT( & COMM_LOAD, ASS_IRECV, N, INODE, FPERE, & PTLUST_S, PTRAST, & root, roota, NCB, NCB, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, & ROOT_CONT_STATIC, MYID, COMM, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE., ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS, 0, 0, 0 ) IF (IFLAG < 0 ) GOTO 500 ENDIF MSGDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)),KEEP(199)) IOLDPS = PTLUST_S(STEP(INODE)) LIST_ROW_SON = IOLDPS + H_INODE + NPIV LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) IF (MSGDEST.EQ.MYID) THEN CALL ZMUMPS_PROCESS_RTNELIND( root, roota, & INODE, NELIM, NSLAVES, IW(LIST_ROW_SON), & IW(LIST_COL_SON), IW(LIST_SLAVES), & & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND) IF (IFLAG.LT.0) GOTO 600 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) CALL MUMPS_BUF_SEND_RTNELIND( INODE, NELIM, & IW(LIST_ROW_SON), IW(LIST_COL_SON), NSLAVES, & IW(LIST_SLAVES), MSGDEST, COMM, KEEP, IERR) IF ( IERR .EQ. -1 ) THEN BLOCKING =.FALSE. SET_IRECV =.TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, & ND, FRERE, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & .TRUE., LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IOLDPS = PTLUST_S(STEP(INODE)) LIST_ROW_SON = IOLDPS + H_INODE + NPIV LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) ENDIF ENDDO IF ( IERR .EQ. -2 ) THEN IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) IFLAG = - 17 GOTO 600 ELSE IF ( IERR .EQ. -3 ) THEN IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) IFLAG = -20 GOTO 600 ENDIF ENDIF IF (NELIM.EQ.0) THEN POSELT = PTRAST(STEP(INODE)) OPSFAC = POSELT + int(NPIV,8) * int(NFRONT,8) + int(NPIV,8) GOTO 190 ELSE GOTO 500 ENDIF ENDIF OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .NE. MYID ) THEN MSGTAG =NOEUD MSGDEST=MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), KEEP(199) ) IERR = -1 NBROWS_ALREADY_SENT = 0 DO WHILE (IERR.EQ.-1) IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN CALL ZMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, & LCONT, NASS, NPIV, IW( IOLDPS + H_INODE + NPIV ), & IW( IOLDPS + H_INODE + NPIV + NFRONT ), & A( OPSFAC ), PACKED_CB, & MSGDEST, MSGTAG, COMM, KEEP, IERR ) ELSE IF ( TYPE.EQ.2 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ELSE INIV2 = -9999 ENDIF CALL ZMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, & FPERE, INODE, & NBROW_SEND, IW(IOLDPS + H_INODE + NPIV ), & NBCOL, IW(IOLDPS + H_INODE + NPIV + NFRONT ), & A(OPSFAC), LDA, NELIM, TYPE, & NSLAVES, IW(IOLDPS+6+KEEP(IXSZ)), MSGDEST, & COMM, IERR, & & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) END IF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IOLDPS = PTLUST_S(STEP( INODE )) OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) END DO IF ( IERR .EQ. -2 .OR. IERR .EQ. -3 ) THEN IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN IERROR = ( 2*LCONT + 9 ) * KEEP( 34 ) + & LCONT*LCONT * KEEP( 35 ) ELSE IF (KEEP(50).ne.0 .AND. TYPE .eq. 2 ) THEN IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) & * KEEP( 34 ) + & NBROW_SEND*NBROW_SEND*KEEP( 35 ) ELSE IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) * KEEP( 34 ) + & NBROW_SEND*NBCOL*KEEP( 35 ) ENDIF IF (IERR .EQ. -2) THEN IFLAG = -17 IF ( LP > 0 ) THEN WRITE(LP, *) MYID, & ": FAILURE, SEND BUFFER TOO SMALL DURING & ZMUMPS_FAC_STACK", TYPE, TYPEF ENDIF ENDIF IF (IERR .EQ. -3) THEN IFLAG = -20 IF ( LP > 0 ) THEN WRITE(LP, *) MYID, & ": FAILURE, RECV BUFFER TOO SMALL DURING & ZMUMPS_FAC_STACK", TYPE, TYPEF ENDIF ENDIF GOTO 600 ENDIF ENDIF IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID ) THEN NBROW_SEND = 0 LREQI = 2 + KEEP(IXSZ) NBROW_STACK = NBROW NBROW_INDICES = NBROW IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN NBCOL_STACK = NELIM ELSE NBCOL_STACK = NBCOL ENDIF IF (COMPRESS_CB) THEN NBROW_STACK=NELIM IF (KEEP(50).NE.0) NBCOL_STACK = NELIM ENDIF ELSE NBROW_STACK = NBROW-NBROW_SEND NBROW_INDICES = NBROW-NBROW_SEND NBCOL_STACK = NBCOL IF (COMPRESS_CB) THEN NBROW_STACK = 0 NBCOL_STACK = 0 ENDIF LREQI = 6 + NBROW_INDICES + NBCOL + KEEP(IXSZ) IF (.NOT. (TYPE.EQ.1 .AND. TYPEF.EQ.2 ) ) GOTO 190 IF (FPERE.EQ.0) GOTO 190 ENDIF IF (PACKED_CB) THEN IF (NBROW_STACK.EQ.0.OR.NBCOL_STACK.EQ.0) THEN LREQCB = 0 ELSE LREQCB = ( int(NBCOL_STACK,8) * int( NBCOL_STACK + 1, 8) ) / 2_8 & - ( int(NBROW_SEND ,8) * int( NBROW_SEND + 1, 8) ) / 2_8 ENDIF ELSE LREQCB = int(NBROW_STACK,8) * int(NBCOL_STACK,8) ENDIF INPLACE = ( KEEP(234).NE.0 ) IF (KEEP(50).NE.0 .AND. TYPE .EQ. 2) INPLACE = .FALSE. INPLACE = INPLACE .OR. .NOT. MUST_COMPACT_FACTORS INPLACE = INPLACE .AND. & ( PTLUST_S(STEP(INODE)) + INTSIZ .EQ. IWPOS ) MIN_SPACE_IN_PLACE = 0_8 IF ( INPLACE .AND. KEEP(50).eq. 0 .AND. & MUST_COMPACT_FACTORS) THEN MIN_SPACE_IN_PLACE = int(NBCOL_STACK,8) ENDIF IF ( MIN_SPACE_IN_PLACE .GT. LREQCB ) THEN INPLACE = .FALSE. ENDIF CALL ZMUMPS_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, .FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER,PAMASTER, & LREQI, LREQCB, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, LRLUSM, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 600 IW(IWPOSCB+1+XXF) = IW(IOLDPS+XXF) IW(IWPOSCB+1+XXLR) = IW(IOLDPS+XXLR) PTRIST(STEP(INODE)) = IWPOSCB+1 IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID ) THEN PIMASTER (STEP(INODE)) = PTLUST_S(STEP(INODE)) PAMASTER(STEP(INODE)) = IPTRLU + 1_8 PTRAST(STEP(INODE)) = -99999999_8 IW(IWPOSCB+1+KEEP(IXSZ)) = min(-NBCOL_STACK,-1) IW(IWPOSCB+2+KEEP(IXSZ)) = NBROW_STACK IF (PACKED_CB) IW(IWPOSCB+1+XXS) = S_CB1COMP ELSE PTRAST(STEP(INODE)) = IPTRLU+1_8 IF (PACKED_CB) IW(IWPOSCB+1+XXS)=S_CB1COMP IW(IWPOSCB+1+KEEP(IXSZ)) = NBCOL IW(IWPOSCB+2+KEEP(IXSZ)) = 0 IW(IWPOSCB+3+KEEP(IXSZ)) = NBROW_STACK IW(IWPOSCB+4+KEEP(IXSZ)) = 0 IW(IWPOSCB+5+KEEP(IXSZ)) = 1 IW(IWPOSCB+6+KEEP(IXSZ)) = 0 IOLDP1 = PTLUST_S(STEP(INODE))+H_INODE PTROWEND = IWPOSCB+6+NBROW_STACK+KEEP(IXSZ) DO I = 1, NBROW_STACK IW(IWPOSCB+7+KEEP(IXSZ)+I-1) = & IW(IOLDP1+NFRONT-NBROW_STACK+I-1) ENDDO DO I = 1, NBCOL IW(PTROWEND+I)=IW(IOLDP1+NFRONT+NPIV+I-1) ENDDO END IF IF ( KEEP(50).NE.0 .AND. TYPE .EQ. 1 & .AND. MUST_COMPACT_FACTORS ) THEN POSELT = PTRFAC(STEP(INODE)) CALL ZMUMPS_COMPACT_FACTORS_SYM( A(POSELT), LDA, & NPIV, NBROW, KEEP, & int(LDA,8)*int(NBROW+NPIV,8), & IW( PTLUST_S(STEP(INODE)) + H_INODE + NFRONT ) ) MUST_COMPACT_FACTORS = .FALSE. ENDIF IF (COMPRESS_CB.AND.(LREQCB.EQ.0)) GOTO 190 IF ( KEEP(50).EQ.0 .AND. MUST_COMPACT_FACTORS ) & THEN LAST_ALLOWED_POS = POSELT + int(LDA,8)*int(NPIV+NBROW-1,8) & + int(NPIV,8) ELSE LAST_ALLOWED_POS = -1_8 ENDIF NCBROW_ALREADY_MOVED = 0 COUNT_EXTRA_IP_COPIES = 0_8 10 CONTINUE NCBROW_PREVIOUSLY_MOVED = NCBROW_ALREADY_MOVED IF (IPTRLU .LT. POSFAC ) THEN CALL ZMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, PACKED_CB, & LAST_ALLOWED_POS, NCBROW_ALREADY_MOVED ) ELSE CALL ZMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, PACKED_CB ) NCBROW_ALREADY_MOVED = NBROW_STACK ENDIF IF (LAST_ALLOWED_POS .NE. -1_8) THEN MUST_COMPACT_FACTORS =.FALSE. IF ( NCBROW_ALREADY_MOVED .EQ. NBROW_STACK ) THEN IF (COMPRESS_CB) THEN NCBROW_ALREADY_MOVED = NBROW ELSE NCBROW_ALREADY_MOVED = NCBROW_ALREADY_MOVED + NBROW_SEND ENDIF ENDIF NCBROW_NEWLY_MOVED = NCBROW_ALREADY_MOVED & - NCBROW_PREVIOUSLY_MOVED FACTOR_POS = POSELT + & int(LDA,8)*int(NPIV+NBROW-NCBROW_ALREADY_MOVED,8) CALL ZMUMPS_COMPACT_FACTORS_UNSYM( A(FACTOR_POS), LDA, NPIV, & NCBROW_NEWLY_MOVED, KEEP, & int(NCBROW_NEWLY_MOVED,8) * int(LDA,8) ) INEW = FACTOR_POS + int(NPIV,8) * int(NCBROW_NEWLY_MOVED,8) IOLD = INEW + int(NCBROW_NEWLY_MOVED,8) * int(NBCOL_STACK,8) DO I8 = 0_8, int(NCBROW_PREVIOUSLY_MOVED,8)*int(NPIV,8)-1 A(INEW) = A(IOLD) IOLD = IOLD + 1_8 INEW = INEW + 1_8 ENDDO COUNT_EXTRA_IP_COPIES = COUNT_EXTRA_IP_COPIES + & int(NCBROW_PREVIOUSLY_MOVED,8) & * int(NPIV,8) LAST_ALLOWED_POS = INEW IF (NCBROW_ALREADY_MOVED.LT.NBROW_STACK) THEN GOTO 10 ENDIF ENDIF IF ( COUNT_EXTRA_IP_COPIES .GT. 0_8 ) THEN !$OMP ATOMIC UPDATE KEEP8(8) = KEEP8(8) + COUNT_EXTRA_IP_COPIES !$OMP END ATOMIC COUNT_EXTRA_IP_COPIES = 0_8 ENDIF 190 CONTINUE IF (MUST_COMPACT_FACTORS) THEN POSELT = PTRFAC(STEP(INODE)) IF (KEEP(50).NE.0) THEN CALL ZMUMPS_COMPACT_FACTORS_SYM( A(POSELT), LDA, & NPIV, NBROW, KEEP, & int(LDA,8)*int(NBROW+NPIV,8), & IW( PTLUST_S(STEP(INODE)) + H_INODE + NFRONT ) ) ELSE CALL ZMUMPS_COMPACT_FACTORS_UNSYM( & A(POSELT+int(NPIV,8)*int(LDA,8)), & LDA, NPIV, NBROW, KEEP, int(NBROW,8)*int(LDA,8) ) ENDIF MUST_COMPACT_FACTORS = .FALSE. ENDIF IOLDPS = PTLUST_S(STEP(INODE)) IW(IOLDPS+KEEP(IXSZ)) = NBCOL IW(IOLDPS + 1+KEEP(IXSZ)) = NASS - NPIV IF (TYPE.EQ.2) THEN IW(IOLDPS + 2+KEEP(IXSZ)) = NASS ELSE IW(IOLDPS + 2+KEEP(IXSZ)) = NFRONT ENDIF IW(IOLDPS + 3+KEEP(IXSZ)) = NPIV IF (INPLACE) THEN SIZE_INPLACE = LREQCB - MIN_SPACE_IN_PLACE ELSE SIZE_INPLACE = 0_8 ENDIF CALL ZMUMPS_COMPRESS_LU(SIZE_INPLACE,MYID,N,IOLDPS,TYPE, IW, LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, SSARBR,INODE,IERR & , LRGROUPS, NASS & ) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 GOTO 600 ENDIF 500 CONTINUE RETURN 600 CONTINUE IF (IFLAG .NE. -1 .AND. KEEP(405) .EQ. 0) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_STACK MUMPS_5.8.1/src/stools.F0000664000175000017500000026632715042446437014710 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_COMPRESS_LU(SIZE_INPLACE, &MYID,N,IOLDPS,TYPE,IW, LIW, A, LA, &POSFAC, LRLU, LRLUS, IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, &SSARBR,INODE,IERR & , LRGROUPS, NASS &) USE MUMPS_LOAD USE SMUMPS_OOC !$ USE OMP_LIB USE SMUMPS_LR_CORE IMPLICIT NONE INTEGER MYID INTEGER IOLDPS, TYPE, LIW, N, KEEP(500) INTEGER(8) :: SIZE_INPLACE, LA, POSFAC, LRLU, LRLUS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) KEEP8(150) INTEGER IW( LIW ) REAL A( LA ) INTEGER IWPOS INTEGER STEP( N ) INTEGER (8) :: PTRFAC(KEEP(28)) LOGICAL SSARBR INTEGER IOLDSHIFT, IPSSHIFT INTEGER LRGROUPS(KEEP(280)), NASS INCLUDE 'mumps_headers.h' INTEGER LCONT, NELIM, NROW, NPIV, INTSIZ INTEGER NFRONT, NSLAVES INTEGER IPS, IPSIZE INTEGER(8) :: SIZELU, SIZENOTLU, IAPOS, I, SIZESHIFT, ITMP8 INTEGER(8) :: SIZEXXR LOGICAL LRCOMPRESS_PANEL INTEGER INODE INTEGER IERR IERR=0 IOLDSHIFT = IOLDPS + KEEP(IXSZ) IF ( IW( IOLDSHIFT ) < 0 ) THEN write(*,*) ' ERROR 1 compressLU:Should not point to a band.' CALL MUMPS_ABORT() ELSE IF ( IW( IOLDSHIFT + 2 ) < 0 ) THEN write(*,*) ' ERROR 2 compressLU:Stack not performed yet', & IW(IOLDSHIFT + 2) CALL MUMPS_ABORT() ENDIF LCONT = IW( IOLDSHIFT ) NELIM = IW( IOLDSHIFT + 1 ) NROW = IW( IOLDSHIFT + 2 ) NPIV = IW( IOLDSHIFT + 3 ) IAPOS = PTRFAC(IW( IOLDSHIFT + 4 )) NSLAVES= IW( IOLDSHIFT + 5 ) NFRONT = LCONT + NPIV INTSIZ = IW(IOLDPS+XXI) LRCOMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) IF ( (NSLAVES > 0 .AND. TYPE .NE. 2) .OR. & (NSLAVES .eq. 0 .AND. TYPE .EQ. 2 ) ) THEN WRITE(*,*) ' ERROR 3 compressLU: problem with level of inode' CALL MUMPS_ABORT() END IF IF ( KEEP(50) .EQ. 0 ) THEN IF (KEEP(251) .NE. 2) THEN SIZELU = int(LCONT + NROW, 8) * int(NPIV,8) ELSE SIZELU = NPIV * NFRONT ENDIF ELSE IF ( KEEP(459) .GT. 1 ) THEN CALL MUMPS_LDLTPANEL_STORAGE( NPIV, KEEP, & IW(IOLDSHIFT+6+NSLAVES+NFRONT), SIZELU) SIZELU = SIZELU + int( NROW - NPIV, 8 ) * int( NPIV, 8 ) ELSE SIZELU = int(NROW,8) * int(NPIV,8) ENDIF ENDIF CALL MUMPS_GETI8(SIZEXXR, IW(IOLDPS+XXR)) SIZENOTLU = SIZEXXR - SIZELU CALL MUMPS_SUBTRI8TOARRAY( IW(IOLDPS+XXR), SIZENOTLU ) IF ((KEEP(201).NE.0) & .OR.(LRCOMPRESS_PANEL.AND.KEEP(486).EQ.2) & ) THEN SIZESHIFT = SIZEXXR ELSE SIZESHIFT = SIZENOTLU IF (SIZENOTLU.EQ.0_8) THEN GOTO 500 ENDIF ENDIF IF (KEEP(201).EQ.2) THEN IF (KEEP(405) .EQ. 0) THEN KEEP8(31)=KEEP8(31)+SIZELU CALL SMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) ELSE !$OMP CRITICAL(critical_old_ooc) KEEP8(31)=KEEP8(31)+SIZELU CALL SMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) !$OMP END CRITICAL(critical_old_ooc) ENDIF IF(IERR.LT.0)THEN WRITE(*,*)MYID,': Internal error in SMUMPS_NEW_FACTOR' CALL MUMPS_ABORT() ENDIF ENDIF IF ( IOLDPS + INTSIZ .NE. IWPOS ) THEN IPS = IOLDPS + INTSIZ DO WHILE ( IPS .NE. IWPOS ) IPSIZE = IW(IPS+XXI) IPSSHIFT = IPS + KEEP(IXSZ) IF ( IPSIZE .LE. 0 .OR. IPS .GT. IWPOS ) THEN WRITE(*,*) " Internal error 1 SMUMPS_COMPRESS_LU" WRITE(*,*) " IOLDPS, INTSIZ, IWPOS, LIW=", & IOLDPS, INTSIZ, IWPOS, LIW WRITE(*,*) " IWPOS, IPS, IPSIZE =", IWPOS, IPS, IPSIZE WRITE(*,*) " Header at IOLDPS =", & IW(IOLDPS:IOLDPS+KEEP(IXSZ)+5) WRITE(*,*) " Header at IPS =", & IW(IPS:IPS+KEEP(IXSZ)+5) CALL MUMPS_ABORT() ENDIF IF (IPS+IPSIZE .GT. IWPOS) THEN WRITE(*,*) " Internal error 2 SMUMPS_COMPRESS_LU" WRITE(*,*) " IOLDPS, INTSIZ, IWPOS, LIW=", & IOLDPS, INTSIZ, IWPOS, LIW WRITE(*,*) " IWPOS, IPS, IPSIZE =", IWPOS, IPS, IPSIZE WRITE(*,*) " Header at IOLDPS =", & IW(IOLDPS:IOLDPS+KEEP(IXSZ)+5) WRITE(*,*) " Header at IOLDPS+INTSIZ =", & IW(IOLDPS+INTSIZ:IOLDPS+INTSIZ+KEEP(IXSZ)+5) WRITE(*,*) " Header at IPS =", & IW(IPS:IPS+KEEP(IXSZ)+5) WRITE(*,*) " ========================== " WRITE(*,*) " Headers starting at IOLDPS:" IPS = IOLDPS DO WHILE (IPS .LE. IWPOS) WRITE(*,*) " -> new IW header at position" , IPS, ":", & IW(IPS:IPS+KEEP(IXSZ)+5) IPS = IPS + IW(IPS+XXI) ENDDO CALL MUMPS_ABORT() ENDIF IF ( IW( IPSSHIFT + 2 ) < 0 ) THEN NFRONT = IW( IPSSHIFT ) IF (IW(IPSSHIFT+4) .LT. 0) THEN WRITE(*,*) " Internal error 3 SMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW(IPSSHIFT+4))=PTRFAC(IW(IPSSHIFT+4)) & - SIZESHIFT PTRAST(IW(IPSSHIFT+4))=PTRAST(IW(IPSSHIFT+4)) & - SIZESHIFT ELSE IF ( IW( IPSSHIFT ) < 0 ) THEN IF (IW(IPSSHIFT+3) .LT. 0) THEN WRITE(*,*) " Internal error 4 SMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW(IPSSHIFT+3)) = PTRFAC(IW(IPSSHIFT+3)) & -SIZESHIFT ELSE NFRONT = IW( IPSSHIFT ) + IW( IPSSHIFT + 3 ) IF (IW(IPSSHIFT+4) .LT. 0) THEN WRITE(*,*) " Internal error 4 SMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZESHIFT END IF IPS = IPS + IPSIZE END DO IF (SIZESHIFT .NE. 0_8) THEN DO I=IAPOS+SIZEXXR-SIZESHIFT, POSFAC-SIZESHIFT-1_8 A( I ) = A( I + SIZESHIFT) END DO END IF ENDIF POSFAC = POSFAC - SIZESHIFT LRLU = LRLU + SIZESHIFT ITMP8 = SIZESHIFT - SIZE_INPLACE LRLUS = LRLUS + ITMP8 IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) - ITMP8 ELSE !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - ITMP8 !$OMP END ATOMIC ENDIF 500 CONTINUE IF (LRCOMPRESS_PANEL.AND.KEEP(486).EQ.2) THEN CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & -SIZESHIFT+SIZE_INPLACE, & KEEP,KEEP8,LRLUS) ELSE CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,SIZELU,-SIZENOTLU+SIZE_INPLACE, & KEEP,KEEP8,LRLUS) ENDIF RETURN END SUBROUTINE SMUMPS_COMPRESS_LU SUBROUTINE SMUMPS_STACK_BAND( N, ISON, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP, KEEP8, DKEEP, TYPE_SON & ) !$ USE OMP_LIB USE SMUMPS_OOC USE MUMPS_LOAD USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER(8) :: LA, LRLU, LRLUS, POSFAC, IPTRLU INTEGER N, ISON, LIW, IWPOS, IWPOSCB, & COMP, IFLAG, IERROR, SLAVEF, MYID, COMM, & TYPE_SON INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), IW(LIW) INTEGER PTLUST_S(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION OPELIW DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE REAL A( LA ) INTEGER(8) :: LREQA, POSA, POSALOC, OLDPOS, JJ INTEGER NFRONT, NCOL_L, NROW_L, LREQI, NSLAVES_L, & POSI, I, IROW_L, ICOL_L, LDA_BAND, NASS LOGICAL NONEED_TO_COPY_FACTORS INTEGER(8) :: LREQA_HEADER INTEGER LIWFAC, STRAT, TYPEFile, NextPivDummy, & IOLDPS_CB LOGICAL LAST_CALL TYPE(IO_BLOCK) :: MonBloc INTEGER LRSTATUS INCLUDE 'mumps_headers.h' DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0d0) REAL, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: IACHK, SIZFR_SON_A, ITMP8 FLOP1 = ZERO NCOL_L = IW( PTRIST(STEP( ISON )) + 3 + KEEP(IXSZ) ) NROW_L = IW( PTRIST(STEP( ISON )) + 2 + KEEP(IXSZ) ) NSLAVES_L = IW( PTRIST(STEP( ISON )) + 5 + KEEP(IXSZ) ) LRSTATUS = IW( PTRIST(STEP( ISON )) + XXLR) LDA_BAND = NCOL_L + IW( PTRIST(STEP( ISON )) + KEEP(IXSZ) ) IF ( KEEP(50) .eq. 0 ) THEN NFRONT = LDA_BAND ELSE NFRONT = IW( PTRIST(STEP( ISON )) + 7 + KEEP(IXSZ) ) END IF IF (KEEP(201).EQ.1) THEN IOLDPS_CB = PTRIST(STEP( ISON )) LIWFAC = IW(IOLDPS_CB+XXI) TYPEFile = TYPEF_L NextPivDummy = -8888 MonBloc%INODE = ISON MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW_L MonBloc%NCOL = LDA_BAND MonBloc%NFS = IW(IOLDPS_CB+1+KEEP(IXSZ)) MonBloc%LastPiv = NCOL_L MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX LAST_CALL = .TRUE. MonBloc%Last = .TRUE. CALL SMUMPS_DM_SET_DYNPTR(IW(PTRIST(STEP(ISON))+XXS), & A, LA, PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR_SON_A) CALL SMUMPS_OOC_IO_LU_PANEL_I & ( STRAT, TYPEFile, & SON_A(IACHK), SIZFR_SON_A, MonBloc, & NextPivDummy, NextPivDummy, & IW(IOLDPS_CB), LIWFAC, & MYID, KEEP8(31), IFLAG,LAST_CALL ) IF ((NCOL_L.EQ.0).OR.(NROW_L.EQ.0)) THEN ENDIF ENDIF NONEED_TO_COPY_FACTORS = ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.-1) & .OR. KEEP(251) .EQ. 2 & .OR. (LRSTATUS.GE.2.AND.KEEP(486).EQ.2) & ) IF ((NCOL_L.EQ.0).OR.(NROW_L.EQ.0)) THEN GOTO 80 ENDIF LREQI = 4 + NCOL_L + NROW_L + KEEP(IXSZ) LREQA_HEADER = int(NCOL_L,8) * int(NROW_L,8) IF (NONEED_TO_COPY_FACTORS) THEN LREQA = 0_8 ELSE LREQA = LREQA_HEADER ENDIF IF ( LRLU .LT. LREQA .OR. & IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LREQA ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) GO TO 700 END IF CALL SMUMPS_COMPRE_NEW( N, KEEP, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS,IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress SMUMPS_STACK_BAND:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) GOTO 700 END IF IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB GOTO 700 END IF END IF IF (.NOT. NONEED_TO_COPY_FACTORS) THEN POSA = POSFAC POSFAC = POSFAC + LREQA LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) IF(KEEP(201).NE.2)THEN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,LREQA,LREQA,KEEP,KEEP8,LRLUS) ELSE CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) ENDIF ENDIF POSI = IWPOS IWPOS = IWPOS + LREQI PTLUST_S(STEP( ISON )) = POSI IW(POSI:POSI+KEEP(IXSZ)-1)=-99999 IW(POSI+XXS)=-9999 IW(POSI+XXI)=LREQI CALL MUMPS_STOREI8(0_8, IW(POSI+XXD)) CALL MUMPS_STOREI8(LREQA, IW(POSI+XXR)) CALL MUMPS_STOREI8(LREQA_HEADER, IW(POSI+XXR)) IW(POSI+XXLR) = LRSTATUS IW(POSI+XXF) = IW(PTRIST(STEP(ISON))+XXF) POSI=POSI+KEEP(IXSZ) IW( POSI ) = - NCOL_L IW( POSI + 1 ) = NROW_L IW( POSI + 2 ) = NFRONT - NCOL_L IW( POSI + 3 ) = STEP(ISON) IF (.NOT. NONEED_TO_COPY_FACTORS) THEN PTRFAC(STEP(ISON)) = POSA ELSE PTRFAC(STEP(ISON)) = -77777_8 ENDIF IROW_L = PTRIST(STEP(ISON)) + 6 + NSLAVES_L + KEEP(IXSZ) ICOL_L = PTRIST(STEP(ISON)) + 6 + NROW_L + NSLAVES_L + KEEP(IXSZ) DO I = 1, NROW_L IW( POSI+3+I ) = IW( IROW_L+I-1 ) ENDDO DO I = 1, NCOL_L IW( POSI+NROW_L+3+I) = IW( ICOL_L+I-1 ) ENDDO IF (.NOT.NONEED_TO_COPY_FACTORS) THEN CALL SMUMPS_DM_SET_DYNPTR(IW(PTRIST(STEP(ISON))+XXS), & A, LA, PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR_SON_A) IF (int(NROW_L,8)*int(NCOL_L,8).GT.int(KEEP(361),8)) THEN !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(I,JJ,OLDPOS,POSALOC) DO I = 1, NROW_L DO JJ = 0_8, int(NCOL_L-1,8) OLDPOS = IACHK + int(I-1,8)*int(LDA_BAND,8) POSALOC = POSA + int(NCOL_L,8)*int(I-1,8) A( POSALOC+JJ ) = SON_A( OLDPOS+JJ ) ENDDO END DO !$OMP END PARALLEL DO ELSE POSALOC = POSA DO I = 1, NROW_L OLDPOS = IACHK + int(I-1,8)*int(LDA_BAND,8) DO JJ = 0_8, int(NCOL_L-1,8) A( POSALOC+JJ ) = SON_A( OLDPOS+JJ ) ENDDO POSALOC = POSALOC + int(NCOL_L,8) END DO ENDIF ENDIF ITMP8 = int(NCOL_L,8) * int(NROW_L,8) IF (KEEP(405) .EQ.1) THEN !$OMP ATOMIC UPDATE KEEP8(10) = KEEP8(10) + ITMP8 !$OMP END ATOMIC ELSE KEEP8(10) = KEEP8(10) + ITMP8 ENDIF IF (KEEP(201).EQ.2) THEN IF (KEEP(405).EQ.0) THEN KEEP8(31)=KEEP8(31)+LREQA CALL SMUMPS_NEW_FACTOR(ISON,PTRFAC,KEEP,KEEP8,A,LA,LREQA,IFLAG) ELSE !$OMP CRITICAL(critical_old_ooc) KEEP8(31)=KEEP8(31)+LREQA CALL SMUMPS_NEW_FACTOR(ISON,PTRFAC,KEEP,KEEP8,A,LA,LREQA,IFLAG) !$OMP END CRITICAL(critical_old_ooc) ENDIF IF(IFLAG.LT.0)THEN WRITE(*,*)MYID,': Internal error in SMUMPS_NEW_FACTOR' IERROR=0 GOTO 700 ENDIF POSFAC = POSFAC - LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - LREQA !$OMP END ATOMIC CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,LREQA,0_8,KEEP,KEEP8,LRLUS) ENDIF 80 CONTINUE IF (TYPE_SON == 1) THEN GOTO 90 ENDIF IF ( KEEP(50) .eq. 0 ) THEN FLOP1 = dble( NCOL_L * NROW_L) + & dble(NROW_L*NCOL_L)*dble(2*NFRONT-NCOL_L-1) ELSE FLOP1 = dble( NCOL_L ) * dble( NROW_L ) & * dble( 2 * LDA_BAND - NROW_L - NCOL_L + 1) END IF OPELIW = OPELIW + FLOP1 FLOP1_EFFECTIVE = FLOP1 NASS = IW( PTRIST(STEP( ISON )) + 4 + KEEP(IXSZ) ) IF ( NCOL_L .NE. NASS ) THEN IF ( KEEP(50).eq.0 ) THEN FLOP1 = dble( NASS * NROW_L) + & dble(NROW_L*NASS)*dble(2*NFRONT-NASS-1) ELSE FLOP1 = dble( NASS ) * dble( NROW_L ) * & dble( 2 * LDA_BAND - NROW_L - NASS + 1) END IF END IF CALL MUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) CALL MUMPS_LOAD_UPDATE(2,.FALSE.,-FLOP1,KEEP,KEEP8) 90 CONTINUE RETURN 700 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE SMUMPS_STACK_BAND SUBROUTINE SMUMPS_FREE_BAND( N, ISON, & PTRIST, PTRAST, IW, LIW, A, LA, & LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON & ) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_PTR, & SMUMPS_DM_FREE_BLOCK IMPLICIT NONE INTEGER(8) :: LRLU, LRLUS, IPTRLU, LA INTEGER ISON, MYID, N, IWPOSCB, TYPE_SON INTEGER KEEP(500), STEP(N) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)) INTEGER LIW INTEGER IW(LIW) REAL A(LA) INTEGER ISTCHK INTEGER(8) :: DYN_SIZE REAL, DIMENSION(:), POINTER :: FORTRAN_POINTER INTEGER :: XXG_STATUS INCLUDE 'mumps_headers.h' ISTCHK = PTRIST(STEP(ISON)) CALL MUMPS_GETI8( DYN_SIZE, IW(ISTCHK+XXD) ) XXG_STATUS = IW(ISTCHK+XXG) IF (DYN_SIZE .GT. 0_8) THEN CALL SMUMPS_DM_SET_PTR( PTRAST(STEP(ISON)), & DYN_SIZE, FORTRAN_POINTER ) ENDIF CALL SMUMPS_FREE_BLOCK_CB_STATIC(.FALSE.,MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) IF (DYN_SIZE .GT. 0_8) THEN CALL SMUMPS_DM_FREE_BLOCK(XXG_STATUS, FORTRAN_POINTER, DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF PTRIST(STEP( ISON )) = -9999888 PTRAST(STEP( ISON )) = -9999888_8 RETURN END SUBROUTINE SMUMPS_FREE_BAND SUBROUTINE SMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, KEEP, KEEP8, & MYID, COMM, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & INFO, INFOG, PROK, MP, PROKG, MPG & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: PROK, PROKG, SUM_OF_PEAKS INTEGER , INTENT(IN) :: MYID, COMM, N, NELT, NSLAVES, & LNA, MP, MPG INTEGER(8), INTENT(IN):: NA_ELT8, NNZ8 INTEGER, INTENT(IN):: NA(LNA) INTEGER :: KEEP(500), INFO(80), INFOG(80) INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER, PARAMETER :: MASTER = 0 INTEGER :: OOC_STAT, BLR_STRAT, BLR_CASE INTEGER :: IRANK LOGICAL :: EFF, PERLU_ON, COMPUTE_MAXAVG INTEGER(8) :: TOTAL_BYTES INTEGER :: TOTAL_MBYTES INTEGER(8) :: TOTAL_BYTES_UNDER_L0 INTEGER :: TOTAL_MBYTES_UNDER_L0 INTEGER, DIMENSION(3) :: LRLU_UD, OOC_LRLU_UD INTEGER, DIMENSION(3) :: & LRLUCB_UD, OOC_LRLUCB_UD, & LRCB_UD, OOC_LRCB_UD PERLU_ON = .TRUE. EFF = .FALSE. COMPUTE_MAXAVG = .NOT.(NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) IF ( PROKG.AND.SUM_OF_PEAKS) THEN WRITE( MPG,'(A)') & ' Estimations with BLR compression of LU factors:' WRITE( MPG,'(A,I6,A) ') & ' ICNTL(38) Estimated compression rate of LU factors =', & KEEP(464), '/1000' ENDIF OOC_STAT = 0 BLR_STRAT = 1 BLR_CASE = 1 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, LRLU_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(30) = TOTAL_MBYTES IF (MYID.EQ.MASTER) THEN INFOG(36) = LRLU_UD(1) INFOG(37) = LRLU_UD(2) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN LRLU_UD(3) = (LRLU_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE LRLU_UD(3) = LRLU_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(36)):', & INFOG(36) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, IC factorization (INFOG(37)):' & ,INFOG(37) END IF OOC_STAT = 1 BLR_STRAT = 1 BLR_CASE = 1 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, OOC_LRLU_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(31) = TOTAL_MBYTES IF (MYID.EQ.MASTER) THEN INFOG(38)= OOC_LRLU_UD(1) INFOG(39)= OOC_LRLU_UD(2) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN OOC_LRLU_UD(3) = (OOC_LRLU_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE OOC_LRLU_UD(3) = OOC_LRLU_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(38)):', & INFOG(38) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, OOC factorization (INFOG(39)):' & ,INFOG(39) END IF IF (SUM_OF_PEAKS) THEN OOC_STAT = 0 BLR_STRAT = 3 BLR_CASE = 1 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, LRCB_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(37) = TOTAL_MBYTES ENDIF IF (MYID.EQ.MASTER.AND.SUM_OF_PEAKS) THEN INFOG(44)= LRCB_UD(1) INFOG(45)= LRCB_UD(2) ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN LRCB_UD(3) = (LRCB_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE LRCB_UD(3) = LRCB_UD(2)/NSLAVES ENDIF ENDIF OOC_STAT = 1 BLR_STRAT = 3 BLR_CASE = 1 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, OOC_LRCB_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(38) = TOTAL_MBYTES ENDIF IF (MYID.EQ.MASTER.AND.SUM_OF_PEAKS) THEN INFOG(46)= OOC_LRCB_UD(1) INFOG(47)= OOC_LRCB_UD(2) ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN OOC_LRCB_UD(3) = (OOC_LRCB_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE OOC_LRCB_UD(3) = OOC_LRCB_UD(2)/NSLAVES ENDIF ENDIF END IF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN WRITE( MPG,'(A,A)') & ' Estimations with BLR compression of LU factors ', & 'and Contribution Blocks:' WRITE( MPG,'(A,I6,A) ') & ' ICNTL(38) Estimated compression rate of LU factors =', & KEEP(464), '/1000' WRITE( MPG,'(A,I6,A) ') & ' ICNTL(39) Estimated compression rate of CB =', & KEEP(465), '/1000' ENDIF OOC_STAT = 0 BLR_STRAT = 2 BLR_CASE = 1 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, LRLUCB_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(34) = TOTAL_MBYTES ENDIF IF (MYID.EQ.MASTER.AND.SUM_OF_PEAKS) THEN INFOG(40)=LRLUCB_UD(1) INFOG(41)=LRLUCB_UD(2) ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN LRLUCB_UD(3) = (LRLUCB_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE LRLUCB_UD(3) = LRLUCB_UD(2)/NSLAVES ENDIF ELSE LRLUCB_UD(1) = TOTAL_MBYTES ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(40)):', & INFOG(40) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, IC factorization (INFOG(41)):' & ,INFOG(41) END IF OOC_STAT = 1 BLR_STRAT = 2 BLR_CASE = 1 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, OOC_LRLUCB_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(35) = TOTAL_MBYTES ENDIF IF (MYID.EQ.MASTER.AND.SUM_OF_PEAKS) THEN INFOG(42)=OOC_LRLUCB_UD(1) INFOG(43)=OOC_LRLUCB_UD(2) ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN OOC_LRLUCB_UD(3) = (OOC_LRLUCB_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE OOC_LRLUCB_UD(3) = OOC_LRLUCB_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(42)):', & INFOG(42) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, OOC factorization (INFOG(43)):' & ,INFOG(43) END IF END SUBROUTINE SMUMPS_MEM_ESTIM_BLR_ALL SUBROUTINE SMUMPS_MAX_MEM( KEEP, KEEP8, & MYID, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & MEMORY_MBYTES, EFF, OOC_STRAT, BLR_STRAT, PERLU_ON, & MEMORY_BYTES, & BLR_CASE, SUM_OF_PEAKS, MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: EFF, PERLU_ON, UNDER_L0_OMP INTEGER, INTENT(IN) :: OOC_STRAT, BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID, N, NELT, NSLAVES, LNA INTEGER(8), INTENT(IN) :: NA_ELT8, NNZ8 INTEGER, INTENT(IN) :: NA(LNA) INTEGER(8), INTENT(OUT):: MEMORY_BYTES INTEGER, INTENT(OUT) :: MEMORY_MBYTES INTEGER, INTENT(IN) :: BLR_CASE LOGICAL, INTENT(IN) :: SUM_OF_PEAKS LOGICAL, INTENT(IN) :: MEM_EFF_ALLOCATED INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER :: MUMPS_GET_POOL_LENGTH EXTERNAL :: MUMPS_GET_POOL_LENGTH INTEGER(8) :: MemEstimGlobal LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: PERLU, NBRECORDS INTEGER(8) :: NB_REAL INTEGER(8) :: TEMP, NB_BYTES, NB_INT INTEGER :: SMUMPS_LBUF_INT INTEGER(8) :: SMUMPS_LBUFR_BYTES8, SMUMPS_LBUF8 INTEGER :: NBUFS INTEGER(8) :: TEMPI INTEGER(8) :: TEMPR INTEGER :: MIN_PERLU INTEGER(8) :: BUF_OOC, BUF_OOC_PANEL, BUF_OOC_NOPANEL INTEGER(8) :: OOC_NB_FILE_TYPE INTEGER(8) :: NSTEPS8, N8, NELT8 INTEGER(8) :: I8OVERI INTEGER(8) :: SUM_NRLADU_underL0, & SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, & SUM_NRLADULR_WC_underL0 INTEGER(4) :: I4 INTEGER(8) :: MIN_NRLADU_underL0, MIN_NRLADU_if_LR_LU_underL0 INTEGER :: ITH, ITHMIN, ITHMIN_if_LRLU INTEGER(8) :: I8_L0_OMP_2, I8_L0_OMP_3, & I8_L0_OMP_5, I8_L0_OMP_6, I8_L0_OMP_7, & I8_L0_OMP_8, I8_L0_OMP_9, I8_L0_OMP_10, & I8_L0_OMP_11, I8_L0_OMP_12, I8_L0_OMP_13 I8OVERI = int(KEEP(10),8) PERLU = KEEP(12) NSTEPS8 = int(KEEP(28),8) N8 = int(N,8) NELT8 = int(NELT,8) IF (.NOT.PERLU_ON) PERLU = 0 I_AM_MASTER = ( MYID .eq. 0 ) I_AM_SLAVE = ( KEEP(46).eq. 1 .or. MYID .ne. 0 ) TEMP = 0_8 NB_REAL = 0_8 NB_BYTES = 0_8 NB_INT = 0_8 IF (KEEP(235) .NE. 0 .OR. KEEP(237) .NE. 0) THEN NB_INT = NB_INT + NSTEPS8 ENDIF NB_INT = NB_INT + 5_8 * NSTEPS8 NB_INT = NB_INT + NSTEPS8 + int(KEEP(56),8)*int(NSLAVES+2,8) NB_INT = NB_INT + 3_8*N8 + KEEP(280) IF (KEEP(38) .NE. 0 .AND.I_AM_SLAVE) NB_INT = NB_INT + 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 + KEEP(193)*I8OVERI NB_INT = NB_INT + KEEP(194)+KEEP(195)+KEEP(196) NB_INT = NB_INT + 2 ELSE NB_INT = NB_INT + 2_8 * ( NELT8 + 1_8 ) * I8OVERI NB_INT = NB_INT + N8 + 1_8 + NELT8 NB_INT = NB_INT + I8OVERI + 3 END IF NB_INT = NB_INT + int(LNA,8) IF ( .NOT. EFF ) THEN IF (I_AM_SLAVE) THEN IF (UNDER_L0_OMP) THEN I8_L0_OMP_2 = 0_8 I8_L0_OMP_3 = 0_8 MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,1) MIN_NRLADU_underL0 = I8_L0_OMP(1,1) ITHMIN = 1 ITHMIN_if_LRLU = 1 DO ITH=1, KEEP(400) IF (I8_L0_OMP(1,ITH).LT.MIN_NRLADU_underL0) & THEN MIN_NRLADU_underL0 = I8_L0_OMP(1,ITH) ITHMIN = ITH ENDIF IF (I8_L0_OMP(4,ITH).LT.MIN_NRLADU_if_LR_LU_underL0) & THEN MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,ITH) ITHMIN_if_LRLU = ITH ENDIF I8_L0_OMP_2=I8_L0_OMP_2 + I8_L0_OMP(2,ITH) I8_L0_OMP_3=I8_L0_OMP_3 + I8_L0_OMP(3,ITH) ENDDO IF (SUM_OF_PEAKS.AND.BLR_STRAT.GT.0) THEN I8_L0_OMP_5 = 0_8 I8_L0_OMP_6 = 0_8 I8_L0_OMP_7 = 0_8 I8_L0_OMP_8 = 0_8 I8_L0_OMP_9 = 0_8 I8_L0_OMP_10= 0_8 I8_L0_OMP_11= 0_8 I8_L0_OMP_12= 0_8 I8_L0_OMP_13= 0_8 DO ITH=1, KEEP(400) I8_L0_OMP_5 = I8_L0_OMP_5 + I8_L0_OMP(5,ITH) I8_L0_OMP_6 = I8_L0_OMP_6 + I8_L0_OMP(6,ITH) I8_L0_OMP_7 = I8_L0_OMP_7 + I8_L0_OMP(7,ITH) I8_L0_OMP_8 = I8_L0_OMP_8 + I8_L0_OMP(8,ITH) I8_L0_OMP_9 = I8_L0_OMP_9 + I8_L0_OMP(9,ITH) I8_L0_OMP_10= I8_L0_OMP_10+ I8_L0_OMP(10,ITH) I8_L0_OMP_11= I8_L0_OMP_11+ I8_L0_OMP(11,ITH) I8_L0_OMP_12= I8_L0_OMP_12+ I8_L0_OMP(12,ITH) I8_L0_OMP_13= I8_L0_OMP_13+ I8_L0_OMP(13,ITH) ENDDO ENDIF CALL SMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & 0_8, 0_8, 0_8, 0_8, & I8_L0_OMP_2, & I8_L0_OMP_3, & I8_L0_OMP_5, & I8_L0_OMP_6, & I8_L0_OMP_7, & I8_L0_OMP_8, & I8_L0_OMP_9, & I8_L0_OMP_10, & I8_L0_OMP_11, & I8_L0_OMP_12, & I8_L0_OMP_13, & MemEstimGlobal & ) IF (BLR_STRAT.EQ.0) THEN IF ( OOC_STRAT .LE. 0 .AND. OOC_STRAT .NE. -1 ) THEN MemEstimGlobal = MemEstimGlobal + & I8_L0_OMP(1,ITHMIN) + & I8_L0_OMP(23, ITHMIN) ELSE MemEstimGlobal = MemEstimGlobal + & I8_L0_OMP(23, ITHMIN) ENDIF ELSE IF ( OOC_STRAT .LE. 0 .AND. OOC_STRAT .NE. -1 ) THEN MemEstimGlobal = MemEstimGlobal + & I8_L0_OMP(4,ITHMIN_if_LRLU) + & I8_L0_OMP(23, ITHMIN_if_LRLU) ELSE MemEstimGlobal = MemEstimGlobal + & I8_L0_OMP(23, ITHMIN_if_LRLU) ENDIF ENDIF NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ELSE IF ( KEEP8(24).EQ.0_8 ) THEN SUM_NRLADU_underL0 = 0_8 SUM_NRLADU_if_LR_LU_underL0 = 0_8 SUM_NRLADULR_UD_underL0 = 0_8 SUM_NRLADULR_WC_underL0 = 0_8 IF (KEEP(400) .GT. 0 ) THEN DO ITH=1, KEEP(400) SUM_NRLADU_underL0 = & SUM_NRLADU_underL0 + I8_L0_OMP(1,ITH) SUM_NRLADU_if_LR_LU_underL0 = & SUM_NRLADU_if_LR_LU_underL0 + I8_L0_OMP(4,ITH) SUM_NRLADULR_UD_underL0 = & SUM_NRLADULR_UD_underL0 + I8_L0_OMP(9,ITH) SUM_NRLADULR_WC_underL0 = & SUM_NRLADULR_WC_underL0 + I8_L0_OMP(10,ITH) ENDDO ENDIF CALL SMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & SUM_NRLADU_underL0, SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, SUM_NRLADULR_WC_underL0, & KEEP8(53), & KEEP8(54), & KEEP8(33), & KEEP8(34), & KEEP8(35), & KEEP8(50), & KEEP8(36), & KEEP8(47), & KEEP8(37), & KEEP8(38), & KEEP8(39), & MemEstimGlobal & ) IF (KEEP(400).LE.0) THEN NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ELSE IF (BLR_STRAT.EQ.0) THEN IF ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(KEEP8(14) / 100_8 + 1_8 ) ELSE NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(KEEP8(12) / 100_8 + 1_8 ) ENDIF ELSE NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ENDIF ENDIF ENDIF ELSE NB_REAL = NB_REAL + 1_8 ENDIF ELSE IF (I_AM_SLAVE) THEN IF (UNDER_L0_OMP) THEN IF (MEM_EFF_ALLOCATED) THEN NB_REAL = NB_REAL + KEEP8(63) ELSE NB_REAL = NB_REAL + KEEP8(62) ENDIF ELSE IF (MEM_EFF_ALLOCATED) THEN NB_REAL = NB_REAL + KEEP8(23) + KEEP8(74) ELSE NB_REAL = NB_REAL + KEEP8(67) + KEEP8(74) ENDIF ENDIF ENDIF IF ( OOC_STRAT .GT. 0 .AND. I_AM_SLAVE ) THEN BUF_OOC_NOPANEL = 2_8 * KEEP8(119) IF (KEEP(50).EQ.0)THEN BUF_OOC_PANEL = 8_8 * int(KEEP(226),8) ELSE BUF_OOC_PANEL = 4_8 * int(KEEP(226),8) ENDIF IF (OOC_STRAT .EQ. 2) THEN BUF_OOC = BUF_OOC_NOPANEL ELSE BUF_OOC = BUF_OOC_PANEL ENDIF NB_REAL = NB_REAL + min(BUF_OOC + int(max(PERLU,0),8) * & (BUF_OOC/100_8+1_8),12000000_8) IF (OOC_STRAT .EQ. 2) THEN OOC_NB_FILE_TYPE = 1_8 ELSE IF (KEEP(50).EQ.0) THEN OOC_NB_FILE_TYPE = 2_8 ELSE OOC_NB_FILE_TYPE = 1_8 ENDIF ENDIF NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 * I8OVERI NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 * I8OVERI NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 ENDIF IF (KEEP(252).EQ.1 .AND. .NOT. I_AM_MASTER) THEN NB_REAL = NB_REAL + N8 ENDIF IF ( .not. ( I_AM_SLAVE .and. I_AM_MASTER .and. KEEP(52) .eq. 0 & .and. KEEP(55) .ne. 0 ) ) THEN NB_INT = NB_INT + KEEP8(27) END IF TEMPI= 0_8 TEMPR = 0_8 NBRECORDS = KEEP(39) IF (KEEP(55).eq.0) THEN IF (NNZ8 < int(NBRECORDS,8)) THEN NBRECORDS=int(NNZ8) ENDIF ELSE IF (NA_ELT8 < int(NBRECORDS,8)) THEN NBRECORDS=int(NA_ELT8) ENDIF ENDIF IF ( KEEP(54) .eq. 0 ) THEN IF ( I_AM_MASTER ) THEN IF ( KEEP(46) .eq. 0 ) THEN NBUFS = NSLAVES ELSE NBUFS = NSLAVES - 1 IF (KEEP(55) .eq. 0 ) & TEMPI = TEMPI + 2_8 * N8 END IF TEMPI = TEMPI + 2_8 * int(NBRECORDS,8) * int(NBUFS,8) TEMPR = TEMPR + int(NBRECORDS,8) * int(NBUFS,8) ELSE IF ( KEEP(55) .eq. 0 )THEN TEMPI = TEMPI + 2_8 * int(NBRECORDS,8) TEMPR = TEMPR + int(NBRECORDS,8) END IF END IF ELSE IF ( I_AM_SLAVE ) THEN TEMPI = TEMPI + int(1+4*NSLAVES,8) * int(NBRECORDS,8) TEMPR = TEMPR + int(1+2*NSLAVES,8) * int(NBRECORDS,8) END IF END IF TEMP = NB_BYTES + (NB_INT + TEMPI) * int(KEEP(34),8) & + NB_REAL * int(KEEP(35),8) & + (TEMPR+KEEP8(26)) * int(KEEP(149),8) NB_REAL = NB_REAL + KEEP8(26) IF ( I_AM_SLAVE ) THEN IF (BLR_STRAT.NE.0) THEN SMUMPS_LBUFR_BYTES8 = int(KEEP(380),8) * int(KEEP(35),8) ELSE SMUMPS_LBUFR_BYTES8 = int(KEEP(44),8) * int(KEEP(35),8) ENDIF SMUMPS_LBUFR_BYTES8 = max( SMUMPS_LBUFR_BYTES8, & 200000_8 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF IF (KEEP(72).NE.1) THEN SMUMPS_LBUFR_BYTES8 = SMUMPS_LBUFR_BYTES8 & + int( real(max(PERLU/2,MIN_PERLU))* & real(SMUMPS_LBUFR_BYTES8)/100E0,8) ELSE SMUMPS_LBUFR_BYTES8 = SMUMPS_LBUFR_BYTES8 & + int( real(max(PERLU,MIN_PERLU))* & real(SMUMPS_LBUFR_BYTES8)/100E0,8) ENDIF SMUMPS_LBUFR_BYTES8 = min(SMUMPS_LBUFR_BYTES8, & int(huge (I4)-100,8)) NB_BYTES = NB_BYTES + SMUMPS_LBUFR_BYTES8 IF (.NOT.UNDER_L0_OMP) THEN IF (BLR_STRAT.NE.0) THEN SMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 & * real(KEEP( 379 ) * KEEP( 35 )), 8 ) ELSE SMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 & * real(KEEP( 43 ) * KEEP( 35 )), 8 ) ENDIF SMUMPS_LBUF8 = max( SMUMPS_LBUF8, 200000_8 ) IF (KEEP(72).NE.1) THEN SMUMPS_LBUF8 = SMUMPS_LBUF8 & + int( real(max(PERLU/2,MIN_PERLU))* & real(SMUMPS_LBUF8)/100E0, 8) ELSE SMUMPS_LBUF8 = SMUMPS_LBUF8 & + int( real(max(PERLU,MIN_PERLU))* & real(SMUMPS_LBUF8)/100E0, 8) ENDIF SMUMPS_LBUF8 = min(SMUMPS_LBUF8, int(huge(I4)-100,8)) SMUMPS_LBUF8 = max(SMUMPS_LBUF8, SMUMPS_LBUFR_BYTES8+ & 3_8*int(KEEP(34),8)) NB_BYTES = NB_BYTES + SMUMPS_LBUF8 ENDIF SMUMPS_LBUF_INT = ( KEEP(56) + & NSLAVES * NSLAVES ) * 5 & * KEEP(34) NB_BYTES = NB_BYTES + int(SMUMPS_LBUF_INT,8) IF (.NOT.EFF) THEN IF (UNDER_L0_OMP) THEN IF (KEEP(144).GT.0) THEN NB_INT = NB_INT + N8*int(KEEP(400),8) NB_INT = NB_INT + & int(MUMPS_GET_POOL_LENGTH(NA(1), KEEP, KEEP8),8)* & int(KEEP(400),8) ENDIF ENDIF IF (KEEP(400).GT.0) THEN NB_INT = NB_INT + & int(MUMPS_GET_POOL_LENGTH(NA(1), KEEP, KEEP8),8) ENDIF IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int( & KEEP(138) + 3 * max(PERLU,10) * & ( KEEP(138) / 100 + 1 ) & ,8) ELSE NB_INT = NB_INT + int( & KEEP(137) + 3 * max(PERLU,10) * & ( KEEP(137) / 100 + 1 ) & ,8) ENDIF ENDIF IF (.NOT.UNDER_L0_OMP) THEN IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int( & KEEP(225) + 2 * max(PERLU,10) * & ( KEEP(225) / 100 + 1 ) & ,8) ELSE NB_INT = NB_INT + int( & KEEP(15) + 2 * max(PERLU,10) * & ( KEEP(15) / 100 + 1 ) & ,8) ENDIF ENDIF NB_INT = NB_INT + NSTEPS8 NB_INT = NB_INT + NSTEPS8 * I8OVERI NB_INT = NB_INT + N8 + 4_8 * NSTEPS8 + & int(MUMPS_GET_POOL_LENGTH(NA(1), KEEP, KEEP8),8) NB_INT = NB_INT + 2_8 * NSTEPS8 * I8OVERI ENDIF MEMORY_BYTES = NB_BYTES + NB_INT * int(KEEP(34),8) + & NB_REAL * int(KEEP(35),8) MEMORY_BYTES = max( MEMORY_BYTES, TEMP ) MEMORY_MBYTES = nint( real(MEMORY_BYTES) / real(1000000) ) RETURN END SUBROUTINE SMUMPS_MAX_MEM SUBROUTINE SMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & SUM_NRLADU_underL0, SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, SUM_NRLADULR_WC_underL0, & PEAK_FR, & PEAK_FR_OOC, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB, & NRLADULR_UD, & NRLADULR_WC, & NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, & NRLNECLR_LUCB_WC, & MemEstimGlobal & ) INTEGER, INTENT(IN) :: OOC_STRAT, BLR_STRAT INTEGER, INTENT(IN) :: BLR_CASE LOGICAL, INTENT(IN) :: SUM_OF_PEAKS INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER(8), INTENT(IN) :: SUM_NRLADU_underL0, & SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, & SUM_NRLADULR_WC_underL0 INTEGER(8), INTENT(IN) :: & PEAK_FR, & PEAK_FR_OOC, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB, & NRLADULR_UD, & NRLADULR_WC, & NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, & NRLNECLR_LUCB_WC INTEGER(8), INTENT(OUT) :: MemEstimGlobal IF ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN MemEstimGlobal = PEAK_FR_OOC ELSE MemEstimGlobal = PEAK_FR ENDIF IF (BLR_STRAT.GT.0) THEN IF (.NOT.SUM_OF_PEAKS) THEN IF (BLR_STRAT.EQ.1) THEN IF (BLR_CASE.LE.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(40) ELSE MemEstimGlobal = KEEP8(41) ENDIF ELSE IF (BLR_CASE.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(33) ELSE MemEstimGlobal = KEEP8(54) ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(53) ELSE MemEstimGlobal = KEEP8(42) ENDIF ENDIF ELSE IF (BLR_CASE.LE.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(43) ELSE MemEstimGlobal = KEEP8(45) ENDIF ELSE IF (BLR_CASE.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(34) ELSE MemEstimGlobal = KEEP8(35) ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(44) ELSE MemEstimGlobal = KEEP8(46) ENDIF ENDIF ENDIF ELSE IF (BLR_STRAT.EQ.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_LU & + SUM_NRLADU_if_LR_LU_underL0 ELSE MemEstimGlobal = PEAK_FR_OOC ENDIF IF (BLR_CASE.EQ.1) THEN MemEstimGlobal = MemEstimGlobal + NRLADULR_UD & + SUM_NRLADULR_UD_underL0 ELSE IF (BLR_CASE.EQ.3) THEN MemEstimGlobal = MemEstimGlobal + NRLADULR_WC & + SUM_NRLADULR_WC_underL0 ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_LUCB & + SUM_NRLADU_if_LR_LU_underL0 ELSE MemEstimGlobal = NRLNECOOC_if_LR_LUCB ENDIF IF (BLR_CASE.EQ.1) THEN MemEstimGlobal = MemEstimGlobal + NRLNECLR_LUCB_UD & + SUM_NRLADULR_UD_underL0 ELSE IF (BLR_CASE.EQ.3) THEN MemEstimGlobal = MemEstimGlobal + NRLNECLR_LUCB_WC & + SUM_NRLADULR_WC_underL0 ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_CB & + SUM_NRLADU_underL0 ELSE MemEstimGlobal = NRLNECOOC_if_LR_LUCB ENDIF MemEstimGlobal = MemEstimGlobal + NRLNECLR_CB_UD ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SET_MEMESTIMGLOBAL SUBROUTINE SMUMPS_SET_BLRSTRAT_AND_MAXS_K8 ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & KEEP, KEEP8) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS_BASE8, MAXS_BASE_RELAXED8 INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) CALL SMUMPS_SET_BLRSTRAT_AND_MAXS ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & KEEP(1), & KEEP8(12), & KEEP8(14), & KEEP8(33), & KEEP8(34), & KEEP8(35), & KEEP8(50) ) RETURN END SUBROUTINE SMUMPS_SET_BLRSTRAT_AND_MAXS_K8 SUBROUTINE SMUMPS_SET_BLRSTRAT_AND_MAXS( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, KEEP, & NRLNEC, & NRLNEC_ACTIVE, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB ) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS_BASE8, MAXS_BASE_RELAXED8 INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: NRLNEC, & NRLNEC_ACTIVE, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB INTEGER :: PERLU PERLU = KEEP(12) IF (KEEP(201) .EQ. 0) THEN MAXS_BASE8 = NRLNEC ELSE MAXS_BASE8 = NRLNEC_ACTIVE ENDIF BLR_STRAT = 0 IF (KEEP(486).EQ.2) THEN IF (KEEP(489).EQ.1) THEN BLR_STRAT = 2 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNECOOC_if_LR_LUCB ELSE MAXS_BASE8 = NRLNEC_if_LR_LUCB ENDIF ELSE BLR_STRAT = 1 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNEC_ACTIVE ELSE MAXS_BASE8 = NRLNEC_if_LR_LU ENDIF ENDIF ELSE IF (KEEP(486).EQ.3) THEN IF (KEEP(489).EQ.1) THEN BLR_STRAT = 3 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNECOOC_if_LR_LUCB ELSE MAXS_BASE8 = NRLNEC_if_LR_CB ENDIF ENDIF ENDIF IF ( MAXS_BASE8 .GT. 0_8 ) THEN MAXS_BASE_RELAXED8 = & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) ELSE MAXS_BASE_RELAXED8 = 1_8 END IF RETURN END SUBROUTINE SMUMPS_SET_BLRSTRAT_AND_MAXS SUBROUTINE SMUMPS_MEM_ALLOWED_SET_MAXS ( MAXS, & BLR_STRAT, OOC_STRAT, MAXS_ESTIM_RELAXED8, & KEEP, KEEP8, MYID, N, NELT, NA, LNA, & NSLAVES, ICNTL38, ICNTL39, IFLAG, IERROR & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(IN) :: BLR_STRAT INTEGER, INTENT(IN) :: OOC_STRAT INTEGER(8), INTENT(IN) :: MAXS_ESTIM_RELAXED8 INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID, N, NELT, NSLAVES, LNA INTEGER, INTENT(IN) :: NA(LNA), ICNTL38, ICNTL39 INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER(8) :: SMALLER_MAXS, UPDATED_DIFF LOGICAL :: EFF, PERLU_ON, SUM_OF_PEAKS INTEGER :: BLR_CASE INTEGER(8) :: TOTAL_BYTES, MEM_ALLOWED_BYTES, & MEM_DISPO_BYTES, MEM_DISPO INTEGER :: TOTAL_MBYTES, PERLU INTEGER(8) :: MEM_DISPO_BYTES_NR, MEM_DISPO_NR, & TOTAL_BYTES_NR INTEGER :: TOTAL_MBYTES_NR INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. PERLU_ON = .TRUE. PERLU = KEEP(12) EFF = .FALSE. SUM_OF_PEAKS = .TRUE. BLR_CASE = 1 MEM_ALLOWED_BYTES = KEEP8(4) CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, & KEEP8(28), KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF, OOC_STRAT, & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) MEM_DISPO_BYTES = MEM_ALLOWED_BYTES-TOTAL_BYTES IF (MEM_DISPO_BYTES.GT.0) THEN MEM_DISPO = MEM_DISPO_BYTES/int(KEEP(35),8) ELSE MEM_DISPO = (MEM_DISPO_BYTES-int(KEEP(35),8)+1)/ & int(KEEP(35),8) ENDIF IF (BLR_STRAT.EQ.0) THEN UPDATED_DIFF = 0_8 ELSE IF (BLR_STRAT.EQ.1) THEN IF (KEEP(464).NE.0) THEN UPDATED_DIFF = int( & real(KEEP8(36)) * ( 1.0E0 - & real(ICNTL38)/real(KEEP(464)) ) & , 8) ELSE UPDATED_DIFF = int ( & -real(KEEP8(11)-KEEP8(32)) * & real(ICNTL38) / 1000.0E0 & , 8) ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF (KEEP(464)+KEEP(465).NE.0) THEN UPDATED_DIFF = int( & real(KEEP8(38)) * ( 1.0E0 - & real(ICNTL38+ICNTL39)/ & real(KEEP(464)+KEEP(465)) ) & , 8) ELSE UPDATED_DIFF = int( & -real(KEEP8(39))* & real(ICNTL38+ICNTL39)/1000.0E0 & , 8) ENDIF ELSE IF (BLR_STRAT.EQ.3) THEN IF (KEEP(465).NE.0) THEN UPDATED_DIFF = int( & real(KEEP8(37)) * ( 1.0E0 - & real(ICNTL39)/real(KEEP(465)) ) & , 8) ELSE UPDATED_DIFF = int( & -real(KEEP8(39))* & real(ICNTL39)/1000.0E0 & , 8) ENDIF ELSE UPDATED_DIFF = 0_8 ENDIF MEM_DISPO = MEM_DISPO + UPDATED_DIFF MAXS = MAXS_ESTIM_RELAXED8 MEM_DISPO_NR = 0_8 IF ( (MEM_DISPO.LT.0) .AND. MAXS_ESTIM_RELAXED8.GT. & (MEM_ALLOWED_BYTES/int(KEEP(35),8)) ) THEN PERLU_ON = .FALSE. CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, & KEEP8(28), KEEP8(30), & NSLAVES, TOTAL_MBYTES_NR, EFF, OOC_STRAT, & BLR_STRAT, PERLU_ON, TOTAL_BYTES_NR, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) MEM_DISPO_BYTES_NR = MEM_ALLOWED_BYTES-TOTAL_BYTES_NR MEM_DISPO_NR = & MEM_DISPO_BYTES_NR/int(KEEP(35),8) & + UPDATED_DIFF IF ( MEM_DISPO_NR.LT.0 ) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE IF (BLR_STRAT.GE.2) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE MEM_DISPO_NR = MEM_DISPO_NR - & (int(KEEP(12),8)/120_8)* & (KEEP8(11)/4_8) IF ( MEM_DISPO_NR.LT.0 ) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE ENDIF ENDIF ENDIF ENDIF MAXS = MAXS_ESTIM_RELAXED8 IF (BLR_STRAT.EQ.0) THEN IF (MEM_DISPO.GT.0) THEN IF (OOC_STRAT.EQ.0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/2_8) ELSE MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/2_8) ENDIF ELSE MAXS = MAXS_ESTIM_RELAXED8 + MEM_DISPO ENDIF ELSE IF (BLR_STRAT.EQ.1) THEN IF ( MEM_DISPO .GT. 0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/10_8) ELSE IF ( MEM_DISPO .LT. 0) THEN IF (OOC_STRAT.EQ.0) THEN SMALLER_MAXS = KEEP8(34) + & int(PERLU,8) * ( KEEP8(34) / 100_8 + 1_8) ELSE SMALLER_MAXS = KEEP8(35) + & int(PERLU,8) * ( KEEP8(35) / 100_8 + 1_8) ENDIF MAXS = max(MAXS_ESTIM_RELAXED8+MEM_DISPO, & SMALLER_MAXS) ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF ( MEM_DISPO .GT. 0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/10_8) ELSE IF ( MEM_DISPO.LT.0) THEN MAXS = max( & MAXS_ESTIM_RELAXED8+MEM_DISPO, & MAXS_ESTIM_RELAXED8) ENDIF ELSE IF (BLR_STRAT.EQ.3) THEN IF ( MEM_DISPO .GT. 0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/4_8) ELSE IF ( MEM_DISPO.LT.0) THEN MAXS = max( & MAXS_ESTIM_RELAXED8+MEM_DISPO, & MAXS_ESTIM_RELAXED8) ENDIF ENDIF IF (MAXS .LE. 0_8) THEN IFLAG=-19 IF (MEM_DISPO.LT.0) THEN CALL MUMPS_SET_IERROR(MEM_DISPO,IERROR) ELSE CALL MUMPS_SET_IERROR(MAXS_ESTIM_RELAXED8-MAXS,IERROR) ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_MEM_ALLOWED_SET_MAXS SUBROUTINE SMUMPS_MEM_ALLOWED_SET_K75 ( & MAXS, MYID, UNDER_L0_OMP, & N, NELT, NA, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT, & KEEP, KEEP8, IFLAG, IERROR & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MAXS INTEGER, INTENT(IN) :: MYID, N, NELT, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT LOGICAL, INTENT(IN) :: UNDER_L0_OMP INTEGER, INTENT(IN) :: NA(LNA), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER(8) :: KEEP8_23_SAVETMP, TOTAL_BYTES INTEGER :: TOTAL_MBYTES LOGICAL :: PERLU_ON, MEM_EFF_ALLOCATED, EFF INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. KEEP8_23_SAVETMP = KEEP8(23) KEEP8(23) = MAXS PERLU_ON =.TRUE. MEM_EFF_ALLOCATED = .TRUE. EFF = .TRUE. KEEP8(74) = 0_8 KEEP8(63) = 0_8 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) KEEP8(23) = KEEP8_23_SAVETMP KEEP8(75) = KEEP8(4) - TOTAL_BYTES KEEP8(75) = KEEP8(75)/int(KEEP(35),8) IF (KEEP8(75).LT.0_8) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-KEEP8(75),IERROR) ENDIF RETURN END SUBROUTINE SMUMPS_MEM_ALLOWED_SET_K75 SUBROUTINE SMUMPS_L0_COMPUTE_PEAK_ALLOWED ( & MYID, N, & NELT, NA, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT, & KEEP, KEEP8, IFLAG, IERROR & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, N, NELT, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT INTEGER, INTENT(IN) :: NA(LNA), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER(8) :: KEEP8_23_SAVETMP, TOTAL_BYTES, TOTAL_STATIC, & TOTAL_ABOVE, TOTAL_UNDER INTEGER(8) :: EXTRA_MEM, MIN_NRLADU_underL0, & MIN_NRLADU_if_LR_LU_underL0 INTEGER :: TOTAL_MBYTES LOGICAL :: PERLU_ON, MEM_EFF_ALLOCATED, EFF LOGICAL :: UNDER_L0_OMP, SUM_OF_PEAKS INTEGER :: BLR_CASE, ITH INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. KEEP8_23_SAVETMP = KEEP8(23) KEEP8(23) = 0_8 UNDER_L0_OMP = .TRUE. PERLU_ON = .TRUE. MEM_EFF_ALLOCATED = .TRUE. EFF = .TRUE. KEEP8(74) = 0_8 KEEP8(63) = 0_8 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_STATIC = TOTAL_BYTES KEEP8(23) = KEEP8_23_SAVETMP MEM_EFF_ALLOCATED = .FALSE. EFF = .FALSE. BLR_CASE = 2 SUM_OF_PEAKS = .TRUE. UNDER_L0_OMP = .FALSE. CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_ABOVE = TOTAL_BYTES IF (PERLU_ON.AND.KEEP(201).LE.0) THEN IF (BLR_STRAT.GT.0) THEN MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,1) DO ITH=1, KEEP(400) MIN_NRLADU_if_LR_LU_underL0 = min ( & MIN_NRLADU_if_LR_LU_underL0, I8_L0_OMP(4,ITH) & ) ENDDO EXTRA_MEM = int(KEEP(12),8)* & ( MIN_NRLADU_if_LR_LU_underL0 / 100_8 + 1_8 ) ELSE MIN_NRLADU_underL0 = I8_L0_OMP(1,1) DO ITH=1, KEEP(400) MIN_NRLADU_underL0 = min ( & MIN_NRLADU_underL0, I8_L0_OMP(1,ITH) & ) ENDDO EXTRA_MEM = int(KEEP(12),8)* & ( MIN_NRLADU_underL0 / 100_8 + 1_8 ) ENDIF TOTAL_ABOVE = TOTAL_ABOVE + EXTRA_MEM ENDIF UNDER_L0_OMP = .TRUE. CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_UNDER = TOTAL_BYTES KEEP8(77) = ( max(TOTAL_UNDER,TOTAL_ABOVE) - TOTAL_STATIC ) & / int(KEEP(35),8) RETURN END SUBROUTINE SMUMPS_L0_COMPUTE_PEAK_ALLOWED SUBROUTINE SMUMPS_SETMAXTOZERO(M_ARRAY, M_SIZE) IMPLICIT NONE INTEGER M_SIZE REAL M_ARRAY(M_SIZE) REAL ZERO PARAMETER (ZERO=0.0E0) M_ARRAY=ZERO RETURN END SUBROUTINE SMUMPS_SETMAXTOZERO SUBROUTINE SMUMPS_COMPUTE_NBROWSinF ( & N, INODE, IFATH, KEEP, & IOLDPS, HF, IW, LIW, & NROWS, NCOLS, NPIV, & NELIM, NFS4FATHER, & NBROWSinF & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, INODE, IFATH INTEGER, INTENT(IN) :: KEEP(500) INTEGER, INTENT(IN) :: IOLDPS, HF, LIW, NROWS, NCOLS INTEGER, INTENT(IN) :: NPIV, NELIM, NFS4FATHER INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT):: NBROWSinF INTEGER :: ShiftFirstRowinFront NBROWSinF = 0 IF ( (KEEP(219).EQ.0).OR.(KEEP(50).NE.2).OR. & (NFS4FATHER.LE.0) ) THEN RETURN ENDIF ShiftFirstRowinFront = NCOLS-NPIV-NELIM-NROWS IF (ShiftFirstRowinFront.EQ.0) THEN NBROWSinF = min(NROWS, NFS4FATHER-NELIM) ELSE IF (ShiftFirstRowinFront.LT.NFS4FATHER-NELIM) THEN NBROWSinF = min(NROWS,NFS4FATHER-NELIM-ShiftFirstRowinFront) ELSE NBROWSinF=0 ENDIF RETURN END SUBROUTINE SMUMPS_COMPUTE_NBROWSinF SUBROUTINE SMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, INODE, IFATH INTEGER, INTENT(IN) :: FILS(N), PERM(N), KEEP(500) INTEGER, INTENT(IN) :: IOLDPS, HF, LIW, NFRONT, NASS1 INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT):: ESTIM_NFS4FATHER_ATSON INTEGER :: J, J_LASTFS, IN, NCB, I, IPOS ESTIM_NFS4FATHER_ATSON = 0 IN = IFATH J_LASTFS = IN DO WHILE (IN.GT.0) J_LASTFS = IN IN = FILS(IN) ENDDO NCB = NFRONT-NASS1 IPOS = IOLDPS + HF + NASS1 ESTIM_NFS4FATHER_ATSON = 0 DO I=1, NCB J = IW(IPOS+ESTIM_NFS4FATHER_ATSON) IF (PERM(J).LE.PERM(J_LASTFS)) THEN ESTIM_NFS4FATHER_ATSON = & ESTIM_NFS4FATHER_ATSON+1 ELSE EXIT ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_COMPUTE_ESTIM_NFS4FATHER SUBROUTINE SMUMPS_COMPUTE_MAXPERCOL( & A,ASIZE,NCOL,NROW, & M_ARRAY,NMAX,PACKED_CB,LROW1) IMPLICIT NONE INTEGER(8) :: ASIZE INTEGER NROW,NCOL,NMAX,LROW1 LOGICAL PACKED_CB REAL A(ASIZE) REAL M_ARRAY(NMAX) INTEGER I INTEGER(8):: APOS, J, LROW REAL ZERO,TMP PARAMETER (ZERO=0.0E0) DO I=1, NMAX M_ARRAY(I) = ZERO ENDDO APOS = 0_8 IF (PACKED_CB) THEN LROW=int(LROW1,8) ELSE LROW=int(NCOL,8) ENDIF DO I=1,NROW DO J=1_8,int(NMAX,8) TMP = abs(A(APOS+J)) IF(TMP.GT.M_ARRAY(J)) M_ARRAY(J) = TMP ENDDO APOS = APOS + LROW IF (PACKED_CB) LROW=LROW+1_8 ENDDO RETURN END SUBROUTINE SMUMPS_COMPUTE_MAXPERCOL SUBROUTINE SMUMPS_SIZE_IN_STRUCT( id, idintr, & NB_INT, NB_CMPLX, NB_CHAR ) USE SMUMPS_STRUC_DEF, ONLY: SMUMPS_STRUC USE SMUMPS_INTR_TYPES, ONLY: SMUMPS_INTR_STRUC IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(SMUMPS_INTR_STRUC) :: idintr INTEGER(8) NB_INT, NB_CMPLX INTEGER(8) NB_REAL,NB_CHAR NB_INT = 0_8 NB_CMPLX = 0_8 NB_REAL = 0_8 NB_CHAR = 0_8 IF (associated(id%IS)) NB_INT=NB_INT+size(id%IS) NB_INT=NB_INT+size(id%KEEP) NB_INT=NB_INT+size(id%ICNTL) NB_INT=NB_INT+size(id%INFO) NB_INT=NB_INT+size(id%INFOG) IF (associated(id%MAPPING)) NB_INT=NB_INT+size(id%MAPPING) IF (associated(id%STEP)) THEN NB_INT=NB_INT+size(id%STEP) ENDIF 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)) THEN NB_INT=NB_INT+size(id%FILS) ENDIF IF (associated(id%FRTPTR)) NB_INT=NB_INT+size(id%FRTPTR) IF (associated(id%FRTELT)) NB_INT=NB_INT+size(id%FRTELT) IF (associated(id%PTRAR)) & NB_INT=NB_INT+size(id%PTRAR)* id%KEEP(10) IF (associated(id%PTR8ARR)) & NB_INT=NB_INT+size(id%PTR8ARR)* id%KEEP(10) IF (associated(id%NINCOLARR)) & NB_INT=NB_INT+size(id%NINCOLARR) IF (associated(id%NINROWARR)) & NB_INT=NB_INT+size(id%NINROWARR) IF (associated(id%PTRDEBARR)) & NB_INT=NB_INT+size(id%PTRDEBARR) 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%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%ELTPROC)) NB_INT=NB_INT+size(id%ELTPROC) IF (associated(id%CANDIDATES)) & NB_INT=NB_INT+size(id%CANDIDATES,DIM=1)* & size(id%CANDIDATES,DIM=2) IF (associated(id%SYM_PERM)) THEN NB_INT=NB_INT+size(id%SYM_PERM) ENDIF IF (associated(id%UNS_PERM)) & NB_INT=NB_INT+size(id%UNS_PERM) IF (associated(id%ISTEP_TO_INIV2)) & NB_INT=NB_INT+size(id%ISTEP_TO_INIV2) IF (associated(id%FUTURE_NIV2)) & NB_INT=NB_INT+size(id%FUTURE_NIV2) IF (associated(id%TAB_POS_IN_PERE)) & NB_INT=NB_INT+size(id%TAB_POS_IN_PERE,DIM=1)* & size(id%TAB_POS_IN_PERE,DIM=2) 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%GLOB2LOC_RHS)) & NB_INT=NB_INT+size(id%GLOB2LOC_RHS) IF(id%GLOB2LOC_SOL_ALLOC.AND.associated(id%GLOB2LOC_SOL)) & NB_INT=NB_INT+size(id%GLOB2LOC_SOL) IF (associated(id%MEM_SUBTREE)) & NB_REAL=NB_REAL+size(id%MEM_SUBTREE)*(id%KEEP(35)/id%KEEP(16)) IF (associated(id%MY_ROOT_SBTR)) & NB_INT=NB_INT+size(id%MY_ROOT_SBTR) IF (associated(id%MY_FIRST_LEAF)) & NB_INT=NB_INT+size(id%MY_FIRST_LEAF) IF (associated(id%MY_NB_LEAF)) NB_INT=NB_INT+size(id%MY_NB_LEAF) IF (associated(id%DEPTH_FIRST)) NB_INT=NB_INT+size(id%DEPTH_FIRST) IF (associated(id%DEPTH_FIRST_SEQ)) & NB_INT=NB_INT+size(id%DEPTH_FIRST_SEQ) IF (associated(id%SBTR_ID)) NB_INT=NB_INT+size(id%SBTR_ID) IF (associated(id%SCHED_DEP)) NB_INT=NB_INT+size(id%SCHED_DEP) IF (associated(id%SCHED_GRP)) NB_INT=NB_INT+size(id%SCHED_GRP) IF (associated(id%SCHED_SBTR)) NB_INT=NB_INT+size(id%SCHED_SBTR) IF (associated(id%CROIX_MANU)) NB_INT=NB_INT+size(id%CROIX_MANU) IF (associated(id%COST_TRAV)) & NB_REAL=NB_REAL+size(id%COST_TRAV)*(id%KEEP(35)/id%KEEP(16)) IF (associated(id%CB_SON_SIZE)) NB_INT=NB_INT+size(id%CB_SON_SIZE) IF (associated(id%OOC_INODE_SEQUENCE)) & NB_INT=NB_INT+size(id%OOC_INODE_SEQUENCE) IF (associated(id%OOC_SIZE_OF_BLOCK)) & NB_INT=NB_INT+size(id%OOC_SIZE_OF_BLOCK)*id%KEEP(10) IF (associated(id%OOC_VADDR)) & NB_INT=NB_INT+size(id%OOC_VADDR,DIM=1)* & size(id%OOC_VADDR,DIM=2)*id%KEEP(10) IF (associated(id%OOC_TOTAL_NB_NODES)) & NB_INT=NB_INT+size(id%OOC_TOTAL_NB_NODES) IF (associated(id%OOC_NB_FILES)) & NB_INT=NB_INT+size(id%OOC_NB_FILES) IF (associated(id%OOC_FILE_NAME_LENGTH)) & NB_INT=NB_INT+size(id%OOC_FILE_NAME_LENGTH) IF (associated(id%PIVNUL_LIST)) NB_INT=NB_INT+size(id%PIVNUL_LIST) IF (associated(id%SUP_PROC)) NB_INT=NB_INT+size(id%SUP_PROC) IF (associated(id%IPTR_WORKING)) & NB_INT=NB_INT+size(id%IPTR_WORKING) IF (associated(id%WORKING)) NB_INT=NB_INT+size(id%WORKING) IF (associated(id%LRGROUPS)) THEN NB_INT=NB_INT+size(id%LRGROUPS) ENDIF IF (associated(id%I4_L0_OMP)) & NB_INT=NB_INT+size(id%I4_L0_OMP,DIM=1)* & size(id%I8_L0_OMP,DIM=2) IF (associated(id%I8_L0_OMP)) & NB_INT=NB_INT+size(id%I8_L0_OMP,DIM=1)* & size(id%I8_L0_OMP,DIM=2)*id%KEEP(10) IF (associated(id%IPOOL_B_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_B_L0_OMP) IF (associated(id%IPOOL_A_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_A_L0_OMP) IF (associated(id%PHYS_L0_OMP)) & NB_INT=NB_INT+size(id%PHYS_L0_OMP) IF (associated(id%VIRT_L0_OMP)) & NB_INT=NB_INT+size(id%VIRT_L0_OMP) IF (associated(id%PERM_L0_OMP)) & NB_INT=NB_INT+size(id%PERM_L0_OMP) IF (associated(id%PTR_LEAFS_L0_OMP)) & NB_INT=NB_INT+size(id%PTR_LEAFS_L0_OMP) IF (associated(id%L0_OMP_MAPPING)) & NB_INT=NB_INT+size(id%L0_OMP_MAPPING) IF (associated(id%SINGULAR_VALUES)) & NB_REAL=NB_REAL+size(id%SINGULAR_VALUES) IF (associated(idintr%root%RG2L)) THEN NB_INT=NB_INT+size(idintr%root%RG2L) ENDIF IF (associated(idintr%root%IPIV)) & NB_INT=NB_INT+size(idintr%root%IPIV) IF (associated(idintr%roota%RHS_CNTR_MASTER_ROOT)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%RHS_CNTR_MASTER_ROOT) IF (associated(idintr%roota%SCHUR_POINTER)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%SCHUR_POINTER) IF (associated(idintr%roota%QR_TAU)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%QR_TAU) IF (associated(idintr%roota%RHS_ROOT)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%RHS_ROOT) IF (associated(idintr%roota%SVD_U)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%SVD_U) IF (associated(idintr%roota%SVD_VT)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%SVD_VT) IF (associated(idintr%roota%SINGULAR_VALUES)) & NB_REAL=NB_REAL+size(idintr%roota%SINGULAR_VALUES) IF (associated(id%RHSINTR)) NB_CMPLX = NB_CMPLX + id%KEEP8(25) IF (associated(id%S)) NB_CMPLX=NB_CMPLX+id%KEEP8(23) IF (associated(id%COLSCA).AND.(id%KEEP(52).NE.-1)) & NB_REAL=NB_REAL+size(id%COLSCA) IF (associated(id%ROWSCA).AND.(id%KEEP(52).NE.-1)) & NB_REAL=NB_REAL+size(id%ROWSCA) IF (associated(id%ROWSCA_loc)) & NB_REAL=NB_REAL+size(id%ROWSCA_loc) IF (associated(id%COLSCA_loc).AND.id%KEEP(50).EQ.0) & NB_REAL=NB_REAL+size(id%COLSCA_loc) NB_REAL=NB_REAL+size(id%CNTL) NB_REAL=NB_REAL+size(id%RINFO) NB_REAL=NB_REAL+size(id%RINFOG) NB_REAL=NB_REAL+size(id%DKEEP) NB_CHAR=NB_CHAR+len(id%VERSION_NUMBER) NB_CHAR=NB_CHAR+len(id%OOC_TMPDIR) NB_CHAR=NB_CHAR+len(id%OOC_PREFIX) NB_CHAR=NB_CHAR+len(id%WRITE_PROBLEM) NB_CHAR=NB_CHAR+len(id%SAVE_DIR) NB_CHAR=NB_CHAR+len(id%SAVE_PREFIX) NB_CMPLX = NB_CMPLX + NB_REAL RETURN END SUBROUTINE SMUMPS_SIZE_IN_STRUCT SUBROUTINE SMUMPS_COPYI8SIZE(N8,SRC,DEST) IMPLICIT NONE INTEGER(8) :: N8 REAL, intent(in) :: SRC(N8) REAL, intent(out) :: DEST(N8) INTEGER(8) :: SHIFT8, HUG8 INTEGER :: I, I4SIZE IF(int(huge(I4SIZE),8) .EQ. int(huge(HUG8),8)) THEN CALL scopy(int(N8), SRC(1), 1, DEST(1), 1) ELSE HUG8=int(huge(I4SIZE),8) DO I = 1, int(( N8 + HUG8 - 1_8 ) / HUG8) SHIFT8 = 1_8 + int(I-1,8) * HUG8 I4SIZE = int(min(HUG8, N8-SHIFT8+1_8)) CALL scopy(I4SIZE, SRC(SHIFT8), 1, DEST(SHIFT8), 1) ENDDO END IF RETURN END SUBROUTINE SMUMPS_COPYI8SIZE SUBROUTINE SMUMPS_SET_TMP_PTR( THE_ADDRESS, THE_SIZE8 ) USE SMUMPS_STATIC_PTR_M INTEGER(8), INTENT(IN) :: THE_SIZE8 REAL, INTENT(IN) :: THE_ADDRESS(THE_SIZE8) CALL SMUMPS_SET_STATIC_PTR(THE_ADDRESS(1:THE_SIZE8)) RETURN END SUBROUTINE SMUMPS_SET_TMP_PTR SUBROUTINE SMUMPS_OOC_IO_LU_PANEL_I & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) USE SMUMPS_OOC, ONLY : IO_BLOCK, & SMUMPS_OOC_IO_LU_PANEL IMPLICIT NONE TYPE(IO_BLOCK), INTENT(INOUT):: MonBloc INTEGER(8) :: LAFAC INTEGER, INTENT(IN) :: STRAT, LIWFAC, MYID, TYPEFile INTEGER, INTENT(INOUT) :: IW(0:LIWFAC-1) REAL, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LNextPiv2beWritten, UNextPiv2beWritten INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) RETURN END SUBROUTINE SMUMPS_OOC_IO_LU_PANEL_I SUBROUTINE SMUMPS_BUF_SEND_CONTRIB_TYPE3_I ( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) USE SMUMPS_BUF, ONLY : SMUMPS_BUF_SEND_CONTRIB_TYPE3 IMPLICIT NONE INTEGER N, ISON, NBCOL_SON, NBROW_SON, NSUBSET_ROW, NSUBSET_COL INTEGER NPROW, NPCOL, MBLOCK, NBLOCK, LD_SON INTEGER BBPCBP INTEGER PDEST, TAG, COMM, IERR INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER :: RG2L(N) INTEGER NSUPROW, NSUPCOL INTEGER(8), INTENT(IN) :: TABSIZE INTEGER SIZE_PACK INTEGER KEEP(500) REAL VAL_SON( LD_SON, * ), TAB(*) LOGICAL TRANSP INTEGER N_ALREADY_SENT INTEGER NELIM_ROOT, NELIM_ROW, NELIM_COL CALL SMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) RETURN END SUBROUTINE SMUMPS_BUF_SEND_CONTRIB_TYPE3_I SUBROUTINE SMUMPS_BLR_UPDATE_TRAILING_I( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, sizeBEGS_BLR_L, & BEGS_BLR_U, sizeBEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, NB_BLR_U, & NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) USE SMUMPS_LR_TYPE, ONLY : LRB_TYPE USE SMUMPS_FAC_LR, ONLY : SMUMPS_BLR_UPDATE_TRAILING INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, & CURRENT_BLR, & NELIM, NIV, SYM, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT REAL, intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_U(NB_BLR_U-CURRENT_BLR) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER :: sizeBEGS_BLR_L, sizeBEGS_BLR_U INTEGER :: BEGS_BLR_L(sizeBEGS_BLR_L) INTEGER :: BEGS_BLR_U(sizeBEGS_BLR_U) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS CALL SMUMPS_BLR_UPDATE_TRAILING( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) RETURN END SUBROUTINE SMUMPS_BLR_UPDATE_TRAILING_I SUBROUTINE SMUMPS_COMPRESS_CB_I(A_PTR, LA_PTR, POSELT, LDA, & BEGS_BLR, sizeBEGS_BLR, BEGS_BLR_U, sizeBEGS_BLR_U, & NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY, & NELIM, & NBROWSinF & ) USE SMUMPS_LR_TYPE, ONLY : LRB_TYPE USE SMUMPS_FAC_LR, ONLY : SMUMPS_COMPRESS_CB IMPLICIT NONE INTEGER(8), intent(in) :: LA_PTR REAL, intent(inout) :: A_PTR(LA_PTR) INTEGER(8), intent(in) :: POSELT INTEGER :: sizeBEGS_BLR, sizeBEGS_BLR_U INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & KPERCENT, TOL_OPT, LWORK, OMP_NUM INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: CB_LRB(NB_ROWS,NB_COLS) INTEGER :: BEGS_BLR(sizeBEGS_BLR), BEGS_BLR_U(sizeBEGS_BLR_U) REAL :: RWORK(2*MAXI_CLUSTER*OMP_NUM) REAL :: BLOCK(MAXI_CLUSTER, MAXI_CLUSTER*OMP_NUM) REAL :: WORK(LWORK*OMP_NUM), TAU(MAXI_CLUSTER*OMP_NUM) INTEGER :: JPVT(MAXI_CLUSTER*OMP_NUM) INTEGER(8) :: KEEP8(150) REAL,intent(in) :: TOLEPS INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500) REAL :: M_ARRAY(max(NFS4FATHER,1)) INTEGER, intent(in) :: NELIM INTEGER, intent(in) :: NBROWSinF CALL SMUMPS_COMPRESS_CB(A_PTR, LA_PTR, POSELT, LDA, & BEGS_BLR, BEGS_BLR_U, & NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY=M_ARRAY, & NELIM=NELIM, & NBROWSinF=NBROWSinF & ) RETURN END SUBROUTINE SMUMPS_COMPRESS_CB_I SUBROUTINE SMUMPS_COMPRESS_PANEL_I_NOOPT( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, sizeBEGS_BLR, & NB_BLR, TOLEPS, TOL_OPT, K458, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8, & OMP_NUM & ) USE SMUMPS_LR_TYPE, ONLY : LRB_TYPE USE SMUMPS_FAC_LR, ONLY : SMUMPS_COMPRESS_PANEL IMPLICIT NONE INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV INTEGER, intent(in) :: OMP_NUM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) REAL, intent(inout) :: A(LA) INTEGER :: MAXI_CLUSTER REAL :: RWORK(2*MAXI_CLUSTER*OMP_NUM) REAL :: BLOCK(MAXI_CLUSTER,MAXI_CLUSTER*OMP_NUM) REAL :: WORK(LWORK*OMP_NUM) REAL :: TAU(MAXI_CLUSTER*OMP_NUM) INTEGER :: JPVT(MAXI_CLUSTER*OMP_NUM) INTEGER :: sizeBEGS_BLR INTEGER :: BEGS_BLR(sizeBEGS_BLR) INTEGER(8) :: KEEP8(150) INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, & K458, K473, TOL_OPT LOGICAL, intent(in) :: LBANDSLAVE INTEGER :: LWORK, NELIM REAL,intent(in) :: TOLEPS CHARACTER(len=1) :: DIR CALL SMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K458, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8 & ) RETURN END SUBROUTINE SMUMPS_COMPRESS_PANEL_I_NOOPT SUBROUTINE SMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & DECOMP_TIMER) USE SMUMPS_LR_TYPE, ONLY : LRB_TYPE USE SMUMPS_FAC_LR, ONLY : SMUMPS_DECOMPRESS_PANEL IMPLICIT NONE INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: COPY_DENSE_BLOCKS INTEGER, intent(in) :: NB_BLR, CURRENT_BLR INTEGER, intent(in) :: BEGS_BLR_DIAG, & BEGS_BLR_FIRST_OFFDIAG TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) CHARACTER(len=1) :: DIR INTEGER, intent(in) :: DECOMP_TIMER INTEGER, intent(in) :: LDA11, LDA21 CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & DECOMP_TIMER) RETURN END SUBROUTINE SMUMPS_DECOMPRESS_PANEL_I_NOOPT SUBROUTINE SMUMPS_BLR_UPD_NELIM_VAR_L_I( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, sizeBEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) USE SMUMPS_LR_TYPE, ONLY : LRB_TYPE USE SMUMPS_FAC_LR, ONLY : SMUMPS_BLR_UPD_NELIM_VAR_L IMPLICIT NONE INTEGER(8), intent(in) :: LA_U, LA_L INTEGER(8), intent(in) :: UPOS, LPOS INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR, & NELIM, FIRST_BLOCK CHARACTER(len=1),INTENT(IN) :: UTRANS INTEGER, intent(inout) :: IFLAG, IERROR REAL, TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER, INTENT(in) :: sizeBEGS_BLR_L INTEGER :: BEGS_BLR_L(sizeBEGS_BLR_L) CALL SMUMPS_BLR_UPD_NELIM_VAR_L( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) RETURN END SUBROUTINE SMUMPS_BLR_UPD_NELIM_VAR_L_I SUBROUTINE SMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, JBEG_BLOCK, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, sizeBEGS_BLR_LM, & NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, sizeBEGS_BLR_LS, & NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, OMP_NUM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) USE SMUMPS_LR_TYPE, ONLY : LRB_TYPE USE SMUMPS_FAC_LR, ONLY : SMUMPS_BLR_SLV_UPD_TRAIL_LDLT IMPLICIT NONE INTEGER(8), intent(in) :: LA, LA_BLOCFACTO REAL, intent(inout) :: A(LA) REAL, intent(in) :: A_BLOCFACTO(LA_BLOCFACTO) INTEGER(8), intent(in) :: POSELT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), TOL_OPT, & MAXI_CLUSTER, OMP_NUM, LD_BLOCFACTO, & JBEG_BLOCK INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS, & ISHIFT_LM, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS REAL, INTENT(INOUT) :: & BLOCK(MAXI_CLUSTER,MAXI_CLUSTER*OMP_NUM) INTEGER :: sizeBEGS_BLR_LM, sizeBEGS_BLR_LS INTEGER :: BEGS_BLR_LM(sizeBEGS_BLR_LM) INTEGER :: BEGS_BLR_LS(sizeBEGS_BLR_LS) TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM), & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS CALL SMUMPS_BLR_SLV_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, JBEG_BLOCK, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) RETURN END SUBROUTINE SMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I SUBROUTINE SMUMPS_SET_INNERBLOCKSIZE( SIZE_INNER, & NASS, KEEP ) IMPLICIT NONE INTEGER :: SIZE_INNER, NASS, KEEP(500) IF (NASS.LT.KEEP(4)) THEN SIZE_INNER = NASS ELSE IF (NASS .GT. KEEP(3)) THEN SIZE_INNER = min( KEEP(6), NASS ) ELSE SIZE_INNER = min( KEEP(5), NASS ) ENDIF RETURN END SUBROUTINE SMUMPS_SET_INNERBLOCKSIZE SUBROUTINE SMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) DOUBLE PRECISION :: OPELI INTEGER(8) :: KEEP8( 150 ) REAL :: OPELIR OPELIR = real(OPELI) CALL MUMPS_SETRVAL_ADDR_C(OPELIR, KEEP8(84)) RETURN END SUBROUTINE SMUMPS_UPDATE_PROGRESS MUMPS_5.8.1/src/zrank_revealing.F0000664000175000017500000005664415042446441016540 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_GET_NS_OPTIONS_FACTO(N,KEEP,ICNTL,MPG) IMPLICIT NONE INTEGER N, KEEP(500), ICNTL(60), MPG KEEP(19)=0 KEEP(19)=ICNTL(56) IF ((KEEP(19).LT.1).OR.(KEEP(19).GE.2)) KEEP(19)=0 IF ( KEEP(53) .LE. 0 .and. & KEEP(19) .NE. 0 ) THEN KEEP(19) = 0 IF ( MPG .GT. 0 ) THEN WRITE( MPG,'(A)') '** Warning: ICNTL(56) null space option' WRITE( MPG,'(A)') '** disabled (incompatibility with analysis)' END IF END IF KEEP(21) = min(ICNTL(57),N) KEEP(22) = max(ICNTL(55),0) IF ( KEEP(19) .ne. 0 .and. KEEP(60) .ne. 0 ) THEN IF ( MPG .GT. 0 ) THEN WRITE( MPG,'(A)') '** Warning: ICNTL(56) null space option' WRITE( MPG,'(A)') '** disabled (incompatibility with Schur)' END IF KEEP(19) = 0 END IF RETURN END SUBROUTINE ZMUMPS_GET_NS_OPTIONS_FACTO SUBROUTINE ZMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL, KEEP, & NRHS, MPG, INFO) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500), NRHS, MPG, ICNTL(60) INTEGER, intent(inout):: INFO(80) IF (KEEP(19).EQ.0.AND.KEEP(110).EQ.0) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 56 IF (KEEP(110).EQ.0) INFO(2) = 24 IF(MPG.GT.0) THEN WRITE( MPG,'(A)') &'** ERROR : Null space computation requirement' WRITE( MPG,'(A)') &'** not consistent with factorization options' ENDIF GOTO 333 ENDIF ENDIF IF (ICNTL(9).NE.1) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 9 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') &'** ERROR ICNTL(25) incompatible with ' WRITE( MPG,'(A)') &'** option transposed system (ICNTL(9).ne.1) ' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(19).EQ.2) THEN IF ((KEEP(111).NE.0).AND.(KEEP(50).EQ.0)) THEN INFO(1) = -37 INFO(2) = 0 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') &'** ERROR ICNTL(25) incompatible with ' WRITE( MPG,'(A)') &'** option RRQR (ICNLT(56)=2) and unsym. matrices ' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(111).eq.-1.AND.NRHS.NE.KEEP(112)+KEEP(17))THEN INFO(1)=-32 INFO(2)=NRHS GOTO 333 ENDIF IF (KEEP(111).gt.0 .AND. NRHS .NE. 1) THEN INFO(1)=-32 INFO(2)=NRHS GOTO 333 ENDIF IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) and ICNTL(30) functionalities ', & ' incompatible with null space' ENDIF INFO(1) = -37 IF (KEEP(237).NE.0) THEN INFO(2) = 30 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(30) functionality ', & ' incompatible with null space' ENDIF ELSE IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) functionality ', & ' incompatible with null space' ENDIF INFO(2) = 20 ENDIF GOTO 333 ENDIF IF (( KEEP(111) .LT. -1 ) .OR. & (KEEP(111).GT.KEEP(112)+KEEP(17)) .OR. & (KEEP(111) .EQ.-1 .AND. KEEP(112)+KEEP(17).EQ.0)) & THEN INFO(1)=-36 INFO(2)=KEEP(111) GOTO 333 ENDIF IF (KEEP(221).NE.0.AND.KEEP(111).NE.0) THEN INFO(1)=-37 INFO(2)=26 GOTO 333 ENDIF 333 CONTINUE RETURN END SUBROUTINE ZMUMPS_GET_NS_OPTIONS_SOLVE SUBROUTINE ZMUMPS_RR_INIT_POINTERS(roota) USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: roota NULLIFY(roota%QR_TAU) NULLIFY(roota%SVD_U) NULLIFY(roota%SVD_VT) NULLIFY(roota%SINGULAR_VALUES) RETURN END SUBROUTINE ZMUMPS_RR_INIT_POINTERS SUBROUTINE ZMUMPS_RR_FREE_POINTERS(roota) USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: roota IF (associated(roota%QR_TAU)) THEN DEALLOCATE(roota%QR_TAU) NULLIFY(roota%QR_TAU) ENDIF IF (associated(roota%SVD_U)) THEN DEALLOCATE(roota%SVD_U) NULLIFY(roota%SVD_U) ENDIF IF (associated(roota%SVD_VT)) THEN DEALLOCATE(roota%SVD_VT) NULLIFY(roota%SVD_VT) ENDIF IF (associated(roota%SINGULAR_VALUES)) THEN DEALLOCATE(roota%SINGULAR_VALUES) NULLIFY(roota%SINGULAR_VALUES) ENDIF RETURN END SUBROUTINE ZMUMPS_RR_FREE_POINTERS SUBROUTINE ZMUMPS_SEQ_SYMMETRIZE(N,A) INTEGER N COMPLEX(kind=8) A( N, N ) INTEGER I,J DO I = 2, N DO J = 1, I - 1 A( I, J ) = A( J, I ) END DO END DO RETURN END SUBROUTINE ZMUMPS_SEQ_SYMMETRIZE SUBROUTINE ZMUMPS_UXVSBP(N,PERM,X,RN01) INTEGER N,PERM(N),I COMPLEX(kind=8) RN01(N),X(N) DO I=1,N RN01(PERM(I))=X(I) ENDDO DO I=1,N X(I)=RN01(I) ENDDO RETURN END SUBROUTINE ZMUMPS_UXVSBP SUBROUTINE ZMUMPS_UXVSFP(N,PERM,X,RN01) INTEGER N,PERM(N),I COMPLEX(kind=8) RN01(N),X(N) DO I=1,N RN01(I)=X(PERM(I)) ENDDO DO I=1,N X(I)=RN01(I) ENDDO RETURN END SUBROUTINE ZMUMPS_UXVSFP SUBROUTINE ZMUMPS_SVD_QR_ESTIM_WK( PHASE, MBLOCK, NBLOCK, & SIZE_ROOT_ARG, & LOCAL_M, LOCAL_N, ROOT_OWNER, KEEP,KEEP8, & LIWK_RR, LWK_RR ) IMPLICIT NONE INTEGER, INTENT(IN) :: PHASE, SIZE_ROOT_ARG INTEGER, INTENT(IN) :: MBLOCK, NBLOCK, LOCAL_M, LOCAL_N LOGICAL, INTENT(IN) :: ROOT_OWNER INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(OUT):: LIWK_RR INTEGER(8), INTENT(OUT):: LWK_RR INTEGER SIZE_ROOT INTEGER NBPOSPONED_ESTIM PARAMETER (NBPOSPONED_ESTIM=2000) INTEGER SVD_QR,PAR_ROOT SVD_QR = KEEP(19) PAR_ROOT = KEEP(38) LIWK_RR = 0 LWK_RR = 0_8 IF (PAR_ROOT.EQ.0) THEN IF(ROOT_OWNER) THEN IF (PHASE.EQ.0) THEN SIZE_ROOT=SIZE_ROOT_ARG+NBPOSPONED_ESTIM ELSE SIZE_ROOT=SIZE_ROOT_ARG ENDIF IF(SVD_QR.EQ.1) THEN LWK_RR=int(3*SIZE_ROOT+1,8) ELSEIF(SVD_QR.EQ.2) THEN LWK_RR=int(SIZE_ROOT+1,8) END IF END IF ENDIF RETURN END SUBROUTINE ZMUMPS_SVD_QR_ESTIM_WK SUBROUTINE ZMUMPS_SEQ_FACTO_ROOT_SVD_QR &(NN,A,root,roota,WR03,LWR03,KEEP,KEEP8,INFO,LP,DKEEP, & GLOBK109,OPELIW,PIVNUL_LIST,LPIVNUL_LIST, & ROW_INDICES) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE ( MUMPS_ROOT_STRUC ) :: root TYPE ( ZMUMPS_ROOT_STRUC ) :: roota INTEGER :: NN,LP,LWR03,LWR03_MINSIZE COMPLEX(kind=8) :: A(NN*NN) INTEGER :: INFO(2),KEEP(500) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: DKEEP(230) DOUBLE PRECISION :: OPELIW INTEGER :: GLOBK109 INTEGER :: LPIVNUL_LIST INTEGER :: PIVNUL_LIST(LPIVNUL_LIST) INTEGER :: ROW_INDICES(NN) COMPLEX(kind=8) :: WR03(LWR03) INTEGER LDLT,DEFICIENCY DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: RWORK INTEGER :: I,LDA,LDU,LDVT,J INTEGER :: IERR, LAST_BEFORE_GAP_IND INTEGER :: LAST_BEFORE_GAPLIMIT_IND, FIRST_AFTER_MinPiv, & FIRST_AFTER_GAPLIMIT, START_POINT, END_POINT INTEGER :: ALLOCOK,MAXDEF,MINDEF DOUBLE PRECISION :: EPS, ZERO, GAPLIMIT, MaxGap, MaxGap1, & MinPiv, Tol_MaxGap PARAMETER(ZERO=0.0D0) EPS = epsilon(ZERO) LDLT=KEEP(50) IF ((KEEP(19) .NE. 1).AND.(KEEP(19) .NE. 2)) THEN INFO(1)=-107 INFO(2)= KEEP(19) IF ( LP .GT. 0 ) THEN WRITE(LP,*) " *** Option ",KEEP(19), & " for null space no more available." ENDIF GOTO 100 ENDIF IF(KEEP(19).EQ.1) THEN LWR03_MINSIZE=3*NN+1 ELSEIF(KEEP(19).EQ.2) THEN LWR03_MINSIZE=NN+1 END IF MAXDEF=KEEP(21) IF ( MAXDEF .LE. 0 ) THEN MAXDEF = NN ELSE MAXDEF = max(MAXDEF - GLOBK109,0) ENDIF MINDEF = max(KEEP(22) - GLOBK109,0) MINDEF = min(MINDEF,NN) MAXDEF = min(MAXDEF,NN) IF(KEEP(19).EQ.1) THEN OPELIW = OPELIW + dble(26)*dble(NN)*dble(NN)*dble(NN) ELSEIF(KEEP(19).EQ.2) THEN OPELIW = OPELIW + dble(4)*dble(NN)*dble(NN)*dble(NN)/dble(3) ENDIF IF (associated(roota%SINGULAR_VALUES)) & DEALLOCATE(roota%SINGULAR_VALUES) NULLIFY(roota%SINGULAR_VALUES) root%NB_SINGULAR_VALUES=NN ALLOCATE(roota%SINGULAR_VALUES(NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN IF ( LP .GT. 0 ) & WRITE(LP,*) 'ZMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating SINGULAR_VALUES' GOTO 100 END IF IF(KEEP(19).EQ.1) THEN IF(associated(roota%SVD_U)) DEALLOCATE(roota%SVD_U) NULLIFY(roota%SVD_U) ALLOCATE(roota%SVD_U(NN,NN),stat=ALLOCOK ) IF(ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NN IF ( LP .GT. 0 ) & WRITE(LP,*) 'ZMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating SVD_U' GOTO 100 END IF IF (associated(roota%SVD_VT)) DEALLOCATE(roota%SVD_VT) NULLIFY(roota%SVD_VT) ALLOCATE(roota%SVD_VT(NN,NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NN IF ( LP .GT. 0 ) & WRITE(LP,*) 'ZMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating SVD_VT' GOTO 100 END IF IF (allocated(RWORK)) DEALLOCATE(RWORK) ALLOCATE(RWORK(5*NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=5*NN IF ( LP .GT. 0 ) & WRITE(LP,*) & 'ZMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating RWORK' GOTO 100 END IF ELSEIF(KEEP(19).EQ.2) THEN IF (associated(roota%QR_TAU)) DEALLOCATE(roota%QR_TAU) NULLIFY(roota%QR_TAU) ALLOCATE(roota%QR_TAU(NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN IF ( LP .GT. 0 ) & WRITE(LP,*) & 'ZMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating QR_TAU' GOTO 100 END IF IF (associated(ROOT%IPIV)) DEALLOCATE(ROOT%IPIV) NULLIFY(ROOT%IPIV) ALLOCATE(ROOT%IPIV(NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN IF ( LP .GT. 0 ) & WRITE(LP,*) & 'ZMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating IPIV' GOTO 100 END IF IF (allocated(RWORK)) DEALLOCATE(RWORK) ALLOCATE(RWORK(2*NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=2*NN IF ( LP .GT. 0 ) & WRITE(LP,*) & 'ZMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating RWORK' GOTO 100 END IF ENDIF IF (LDLT.NE.0) THEN CALL ZMUMPS_SEQ_SYMMETRIZE(NN,A) END IF LDA=NN LDU=NN LDVT=NN IERR = 0 IF(KEEP(19).EQ.1) THEN CALL zgesvd('A','A',NN,NN,A,LDA,roota%SINGULAR_VALUES(1) & ,roota%SVD_U(1,1) & ,LDU,roota%SVD_VT(1,1),LDVT,WR03,LWR03,RWORK,IERR) ENDIF IF(IERR.NE.0) THEN INFO(1)=-107 INFO(2)=IERR IF (LP.GT.0) THEN IF(KEEP(19).EQ.1) THEN WRITE(LP,*) ' Problem in zgesvd : IERR = ', IERR ELSEIF(KEEP(19).EQ.2) THEN WRITE(LP,*) ' Problem in zgeqpf : IERR = ', IERR ENDIF GOTO 100 END IF ENDIF IF(KEEP(19).EQ.2) THEN DO I=1,NN roota%SINGULAR_VALUES(I)=abs(A(I+NN*(I-1))) ENDDO ENDIF DEFICIENCY=0 MinPiv = DKEEP(20) GAPLIMIT = DKEEP(9) IF (roota%SINGULAR_VALUES(NN).GT.MinPiv) THEN DEFICIENCY = 0 GOTO 170 ENDIF IF (roota%SINGULAR_VALUES(1).LE.GAPLIMIT) THEN DEFICIENCY = NN GOTO 170 ENDIF LAST_BEFORE_GAPLIMIT_IND = 0 LAST_BEFORE_GAP_IND = 0 FIRST_AFTER_MinPiv = 0 FIRST_AFTER_GAPLIMIT = 0 MaxGap = 0 MaxGap1 = 0 Tol_MaxGap = DKEEP(24) DO I=NN,1,-1 IF (FIRST_AFTER_MinPiv.GT.0) exit IF(roota%SINGULAR_VALUES(I).LE.GAPLIMIT) THEN LAST_BEFORE_GAPLIMIT_IND = I ELSE IF ((FIRST_AFTER_GAPLIMIT.EQ.0).AND. & (roota%SINGULAR_VALUES(I).LE.MinPiv)) THEN FIRST_AFTER_GAPLIMIT = I ELSE IF (roota%SINGULAR_VALUES(I).GT.MinPiv) THEN FIRST_AFTER_MinPiv = I IF (FIRST_AFTER_GAPLIMIT.EQ.0) FIRST_AFTER_GAPLIMIT = I ENDIF ENDDO START_POINT = LAST_BEFORE_GAPLIMIT_IND IF ((LAST_BEFORE_GAPLIMIT_IND.EQ.0).AND. & (FIRST_AFTER_GAPLIMIT.GT. FIRST_AFTER_MinPiv)) & START_POINT = FIRST_AFTER_GAPLIMIT END_POINT = FIRST_AFTER_MinPiv IF (FIRST_AFTER_MinPiv.EQ.0) END_POINT = 1 DO I=START_POINT,END_POINT+1,-1 IF (roota%SINGULAR_VALUES(I).EQ.0) THEN LAST_BEFORE_GAP_IND = I ELSE MaxGap1 = roota%SINGULAR_VALUES(I-1)* & (1/roota%SINGULAR_VALUES(I)) IF (MaxGap1.GE. Tol_MaxGap) THEN IF (MaxGap1.GE. DKEEP(25)*MaxGap ) THEN LAST_BEFORE_GAP_IND = I MaxGap = MaxGap1 ENDIF ENDIF ENDIF ENDDO IF (MaxGap.EQ.ZERO) THEN IF (LAST_BEFORE_GAPLIMIT_IND.EQ.0) THEN DEFICIENCY = 0 ELSE DEFICIENCY = NN - LAST_BEFORE_GAPLIMIT_IND +1 ENDIF ELSE DEFICIENCY = NN - LAST_BEFORE_GAP_IND +1 ENDIF 170 CONTINUE DEFICIENCY=min(DEFICIENCY,MAXDEF) DEFICIENCY=max(DEFICIENCY,MINDEF) KEEP(17)=DEFICIENCY IF(KEEP(19).EQ.2) THEN IF(DEFICIENCY.GT.0) THEN CALL ztrtrs('U','N','N',NN-DEFICIENCY,DEFICIENCY, & A,LDA,A(LDA*(NN-DEFICIENCY)+1),LDA,IERR) IF ( IERR .NE. 0 ) THEN IF (LP.GT.0) & WRITE(LP,*) ' Internal error in ztrtrs: IERR = ',IERR CALL MUMPS_ABORT() END IF END IF ENDIF DO J=NN-DEFICIENCY+1, NN IF(KEEP(19).EQ.1) THEN PIVNUL_LIST(J-NN+DEFICIENCY) = ROW_INDICES(J) ELSEIF(KEEP(19).EQ.2) THEN PIVNUL_LIST(J-NN+DEFICIENCY) = ROW_INDICES(root%IPIV(J)) ENDIF ENDDO 100 CONTINUE IF (allocated(RWORK)) DEALLOCATE(RWORK) RETURN END SUBROUTINE ZMUMPS_SEQ_FACTO_ROOT_SVD_QR SUBROUTINE ZMUMPS_SEQ_SOLVE_ROOT_SVD_QR & (NRHS,NN,A,root, roota, & IBEG_ROOT_DEF, IEND_ROOT_DEF, & RHS,KEEP,KEEP8,MTYPE,INFO,LWK8,WK, LP) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER NN, NRHS INTEGER(8), INTENT(IN) :: LWK8 TYPE ( MUMPS_ROOT_STRUC ) :: root TYPE ( ZMUMPS_ROOT_STRUC ) :: roota COMPLEX(kind=8) A(NN*NN) INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, MTYPE INTEGER INFO(2),KEEP(500) INTEGER(8) KEEP8(150) COMPLEX(kind=8) RHS(NN,NRHS), WK(LWK8) INTEGER LP INTEGER :: LWK COMPLEX(kind=8),DIMENSION(:,:), allocatable :: TEMP_RHS INTEGER :: I,IERR,K INTEGER :: LDLT,RRSTRAT,DEFICIENCY,LDA,LDRHS INTEGER :: ALLOCOK DOUBLE PRECISION, PARAMETER :: RONE=1.0D+0 COMPLEX(kind=8) ZERO, ONE, MINUSONE PARAMETER( ZERO = (0.0D0,0.0D0), ONE = (1.0D0,0.0D0)) PARAMETER( MINUSONE=(-1.0D0,0.0D0)) LDLT = KEEP(50) RRSTRAT = KEEP(19) DEFICIENCY = KEEP(17) LDA = NN LDRHS = NN LWK = int(min(int(huge(LWK),8),LWK8)) IERR = 0 IF ((RRSTRAT .NE. 1).AND.(RRSTRAT .NE. 2)) THEN WRITE(*,*) " *** Internal error ption ",RRSTRAT, & " for null space no more available." CALL MUMPS_ABORT() ENDIF IF (KEEP(111).EQ.0) THEN IF(KEEP(19).EQ.1) THEN IF ((MTYPE.EQ.0).OR.(LDLT.GT.0)) THEN allocate(TEMP_RHS(NN,NRHS), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NRHS IF ( LP .GT. 0 ) & WRITE(LP,*) & 'ZMUMPS_SEQ_SOLVE_ROOT_SVD_QR: Problem ' & //'allocating TEMP_RHS' RETURN END IF CALL zgemm('Conjugate transpose','N',NN,NRHS,NN,ONE, & roota%SVD_U(1,1),NN,RHS, & NN,ZERO,TEMP_RHS,NN) DO I=1,NN-DEFICIENCY TEMP_RHS( I, 1:NRHS ) = & cmplx(RONE/roota%SINGULAR_VALUES(I),kind=kind(TEMP_RHS))* & TEMP_RHS( I, 1:NRHS ) ENDDO DO I=NN-DEFICIENCY +1, NN TEMP_RHS(I, 1:NRHS) = ZERO ENDDO CALL zgemm('Conjugate transpose','N',NN,NRHS,NN,ONE, & roota%SVD_VT(1,1),NN, & TEMP_RHS, NN,ZERO,RHS,NN) DEALLOCATE(TEMP_RHS) ELSEIF(MTYPE.EQ.1) THEN allocate(TEMP_RHS(NRHS,NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NRHS IF ( LP .GT. 0 ) & WRITE(LP,*) & 'ZMUMPS_SEQ_SOLVE_ROOT_SVD_QR: Problem ' & //'allocating TEMP_RHS' RETURN END IF CALL zgemm('T','C',NRHS,NN, NN,ONE,RHS, NN, & roota%SVD_VT(1,1),NN, & ZERO,TEMP_RHS,NRHS) DO I=1,NN-DEFICIENCY RHS(I, 1:NRHS ) = & cmplx(RONE/roota%SINGULAR_VALUES(I),kind=kind(TEMP_RHS))* & TEMP_RHS(1:NRHS,I ) ENDDO DO I=NN-DEFICIENCY +1, NN RHS(I,1:NRHS) = ZERO ENDDO CALL zgemm('T','C',NRHS,NN,NN,ONE,RHS, NN, & roota%SVD_U(1,1),NN, & ZERO,TEMP_RHS,NRHS) DO I=1,NRHS RHS(1:NN,I) =TEMP_RHS(I,1:NN ) ENDDO DEALLOCATE(TEMP_RHS) ENDIF ELSEIF(KEEP(19).EQ.2) THEN IF ((MTYPE.EQ.0).OR.(LDLT.GT.0)) THEN CALL zunmqr('L','Conjugate transpose',NN,NRHS,NN, & A,LDA,roota%QR_TAU(1), & RHS,LDRHS,WK(1),LWK,IERR) IF(IERR.LT.0) THEN WRITE(*,*) & 'Error return from zunmqr in root solve: IERR=', IERR RETURN END IF CALL ztrtrs('U','N','N',NN-DEFICIENCY,NRHS,A,LDA, & RHS,LDRHS,IERR) IF ( IERR .LT. 0 ) THEN WRITE(*,*) & 'Error return from ztrtrs in roor solve: IERR =',IERR RETURN END IF DO I=1,NRHS RHS( NN - DEFICIENCY + 1: NN, I ) = ZERO ENDDO DO I=1,NRHS CALL ZMUMPS_UXVSBP(NN,root%IPIV(1),RHS(1,I),WK) ENDDO ELSEIF(MTYPE.EQ.1) THEN DO I=1,NRHS CALL ZMUMPS_UXVSFP(NN,root%IPIV(1),RHS(1,I),WK) ENDDO CALL ztrtrs('U','T','N',NN-DEFICIENCY,NRHS, & A,LDA,RHS,LDRHS,IERR) IF(IERR.NE.0) THEN WRITE(*,*) 'Error return from trtrs: IERR=', IERR STOP END IF allocate(TEMP_RHS(NRHS,NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NRHS IF ( LP .GT. 0 ) & WRITE(LP,*) & 'ZMUMPS_SEQ_SOLVE_ROOT_SVD_QR: Problem ' & //'allocating TEMP_RHS' RETURN END IF DO I=1,NRHS TEMP_RHS(I,1:NN-DEFICIENCY)=RHS(1:NN-DEFICIENCY, I) ENDDO DO I=NN - DEFICIENCY + 1,NN TEMP_RHS( 1: NRHS, I ) = ZERO ENDDO CALL zunmqr( 'R','Conjugate transpose',NRHS,NN,NN,A,LDA, & roota%QR_TAU(1), & TEMP_RHS,NRHS,WK,LWK,IERR) IF(IERR.LT.0) THEN WRITE(*,*) 'Error return from zunmqr: IERR=', IERR RETURN END IF DO I=1,NRHS RHS(1:NN, I)= TEMP_RHS(I,1:NN) ENDDO DEALLOCATE(TEMP_RHS) ENDIF ENDIF ELSE IF(KEEP(19).EQ.1) THEN IF ((MTYPE.EQ.0).OR.(LDLT.GT.0)) THEN DO I=IBEG_ROOT_DEF,IEND_ROOT_DEF RHS(:,I+1-IBEG_ROOT_DEF) = & CONJG(roota%SVD_VT(NN-DEFICIENCY+I,:)) ENDDO ELSEIF(MTYPE.EQ.1) THEN DO I=IBEG_ROOT_DEF,IEND_ROOT_DEF RHS(:,I+1-IBEG_ROOT_DEF) = & CONJG(roota%SVD_U(:,NN-DEFICIENCY+I)) ENDDO ENDIF ELSEIF(KEEP(19).EQ.2) THEN IF((MTYPE.EQ.0).OR.(LDLT.GT.0)) THEN DO I=IBEG_ROOT_DEF,IEND_ROOT_DEF RHS(NN-DEFICIENCY+I,I-IBEG_ROOT_DEF+1) = MINUSONE DO K=1,NN-DEFICIENCY RHS(K,I-IBEG_ROOT_DEF+1)= & A(K + LDA*(NN-DEFICIENCY+I-1)) ENDDO ENDDO DO I=1,IEND_ROOT_DEF-IBEG_ROOT_DEF+1 CALL ZMUMPS_UXVSBP(NN,root%IPIV(1),RHS(1,I),WK) ENDDO ELSEIF(MTYPE.EQ.1) THEN WRITE(*,*) 'Computation of a null space basis' & // ' of A is unavailable for unsymetric matrices' DO I=IBEG_ROOT_DEF,IEND_ROOT_DEF RHS(NN-DEFICIENCY+I,I-IBEG_ROOT_DEF+1) = ONE ENDDO CALL zunmqr('L','N',NN,NRHS,NN, A,LDA,roota%QR_TAU(1), & RHS,LDRHS,WK(1),LWK,IERR) ENDIF ENDIf ENDIF RETURN END SUBROUTINE ZMUMPS_SEQ_SOLVE_ROOT_SVD_QR MUMPS_5.8.1/src/sfac_process_rtnelind.F0000664000175000017500000001132615042446437017721 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_PROCESS_RTNELIND( root, roota, & INODE, NELIM, NSLAVES, ROW_LIST, & COL_LIST, SLAVE_LIST, & & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND ) USE MUMPS_LOAD USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER INODE, NELIM, NSLAVES INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER ROW_LIST(*), COL_LIST(*), & SLAVE_LIST(*) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), ITLOC( N + KEEP(253) ) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER IFLAG, IERROR INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF INTEGER COMM, COMM_LOAD, ND(KEEP(28)), FILS(N), DAD(KEEP(28)) INTEGER IROOT, TYPE_INODE, DEB_ROW, DEB_COL, & NOINT INTEGER(8) :: NOREAL INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE IROOT = KEEP(38) NSTK_S(STEP(IROOT))= NSTK_S(STEP(IROOT)) - 1 KEEP(42) = KEEP(42) + NELIM TYPE_INODE= MUMPS_TYPENODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IF (TYPE_INODE.EQ.1) THEN IF (NELIM.EQ.0) THEN KEEP(41) = KEEP(41) + 1 ELSE KEEP(41) = KEEP(41) + 3 ENDIF ELSE IF (NELIM.EQ.0) THEN KEEP(41) = KEEP(41) + NSLAVES ELSE KEEP(41) = KEEP(41) + 2*NSLAVES + 1 ENDIF ENDIF IF (NELIM.EQ.0) THEN PIMASTER(STEP(INODE)) = 0 ELSE NOINT = 6 + NSLAVES + NELIM + NELIM + KEEP(IXSZ) NOREAL= 0_8 CALL SMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) THEN WRITE(*,*) ' Failure in int space allocation in CB area ', & ' during assembly of root : SMUMPS_PROCESS_RTNELIND', & ' size required was :', NOINT, & 'INODE=',INODE,' NELIM=',NELIM, ' NSLAVES=', NSLAVES RETURN ENDIF PIMASTER(STEP( INODE )) = IWPOSCB + 1 PAMASTER(STEP( INODE )) = IPTRLU + 1_8 IW( IWPOSCB + 1+KEEP(IXSZ) ) = 2*NELIM IW( IWPOSCB + 2+KEEP(IXSZ) ) = NELIM IW( IWPOSCB + 3+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 5+KEEP(IXSZ) ) = 1 IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES IF (NSLAVES.GT.0) THEN IW( IWPOSCB+7+KEEP(IXSZ):IWPOSCB+7+KEEP(IXSZ)+NSLAVES-1) = & SLAVE_LIST(1:NSLAVES) ENDIF DEB_ROW = IWPOSCB+7+NSLAVES+KEEP(IXSZ) IW(DEB_ROW : DEB_ROW+NELIM -1) = ROW_LIST(1:NELIM) DEB_COL = DEB_ROW + NELIM IW(DEB_COL : DEB_COL+NELIM -1) = COL_LIST(1:NELIM) ENDIF IF (NSTK_S(STEP(IROOT)) .EQ. 0 ) THEN CALL SMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN END SUBROUTINE SMUMPS_PROCESS_RTNELIND MUMPS_5.8.1/src/zana_aux.F0000664000175000017500000043073115042446441015156 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if defined(__ve__) #if defined(VHOFFLOAD) #include 've.h' #endif #endif MODULE ZMUMPS_ANA_AUX_M IMPLICIT NONE CONTAINS SUBROUTINE ZMUMPS_ANA_F(N, NZ8, IRN, ICN, LIWALLOC, & IKEEP1, IKEEP2, IKEEP3, & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, & CNTL4, COLSCA, ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , METIS_OPTIONS #endif & , NORIG_ARG, SIZEOFBLOCKS, GCOMP_PROVIDED_IN, GCOMP & ) USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY : COMPACT_GRAPH_T IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR, NSLAVES INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: LIWALLOC INTEGER, INTENT(in) :: LISTVAR_SCHUR(:) INTEGER, POINTER :: IRN(:), ICN(:) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: INFO(80), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(OUT) :: NFSIZ(:), FILS(:), FRERE(:) INTEGER, INTENT(INOUT) :: PIV(:) INTEGER, INTENT(INOUT) :: IKEEP1(:), IKEEP2(:), IKEEP3(:) DOUBLE PRECISION :: CNTL4 DOUBLE PRECISION, POINTER :: COLSCA(:), ROWSCA(:) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER, INTENT(IN) :: METIS_OPTIONS(40) #endif INTEGER, INTENT(IN), OPTIONAL :: NORIG_ARG INTEGER, INTENT(IN), TARGET, OPTIONAL :: SIZEOFBLOCKS(N) LOGICAL, INTENT(IN), OPTIONAL :: GCOMP_PROVIDED_IN TYPE(COMPACT_GRAPH_T), OPTIONAL :: GCOMP INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: IWALLOC INTEGER, DIMENSION(:), POINTER :: IW INTEGER(8), DIMENSION(:), ALLOCATABLE, TARGET :: IPEALLOC INTEGER(8), DIMENSION(:), POINTER :: IPE INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8 INTEGER, DIMENSION(:,:), ALLOCATABLE :: PTRAR INTEGER, DIMENSION(:), ALLOCATABLE :: PARENT INTEGER, DIMENSION(:), ALLOCATABLE :: IWL1 INTEGER NBBUCK INTEGER, DIMENSION(:), ALLOCATABLE :: WTEMP INTEGER IERR INTEGER I, K, NCMPA, IN, IFSON INTEGER(8) :: J8, I8 INTEGER :: NORIG INTEGER(8) :: IFIRST, ILAST INTEGER(8) IWFR8 INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry INTEGER NBQD, AvgDens LOGICAL PROK, COMPRESS_SCHUR, LPOK, COMPUTE_PERM #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) INTEGER NUMFLAG #endif INTEGER METIS_IDX_SIZE INTEGER OPT_METIS_SIZE #endif #if defined(scotch) || defined(ptscotch) INTEGER :: SCOTCH_INT_SIZE #endif #if defined(pord) INTEGER :: PORD_INT_SIZE #endif DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: COLSCA_TEMP INTEGER THRESH, IVersion LOGICAL AGG6 INTEGER MINSYM PARAMETER (MINSYM=50) INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) INTEGER MTRANS, COMPRESS,NCMP,IERROR,J,JPERM,NCST INTEGER TOTEL INTEGER NFR #if defined(pord) INTEGER TOTW #endif INTEGER WEIGHTUSED #if defined(scotch) || defined(ptscotch) INTEGER WEIGHTREQUESTED #endif INTEGER HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & NBSONS_Scalapack_CAND LOGICAL SCOTCH_SYMBOLIC LOGICAL IDENT,SPLITROOT LOGICAL FREE_CENTRALIZED_MATRIX LOGICAL GCOMP_PROVIDED LOGICAL INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH INTEGER(8) :: LIW8, NZG8 DOUBLE PRECISION TIMEB INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR INTEGER, TARGET :: IDUMMY_ARRAY(1) INTEGER :: LSIZEOFBLOCKS_PTR LOGICAL :: SIZEOFBLOCKS_AVAIL #if defined (MUMPS_SCOTCHIMPORTOMPTHREADS) INTEGER :: ESMUMPSCONTEXT #endif EXTERNAL MUMPS_ANA_H, ZMUMPS_ANA_J, & ZMUMPS_ANA_K, ZMUMPS_ANA_GNEW, & ZMUMPS_ANA_LNEW, ZMUMPS_ANA_M EXTERNAL ZMUMPS_GNEW_SCHUR EXTERNAL ZMUMPS_LDLT_COMPRESS, ZMUMPS_EXPAND_PERMUTATION, & ZMUMPS_SET_CONSTRAINTS ALLOCATE( IWL1 (N), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF ALLOCATE( PTRAR (N,3), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 3*N GOTO 90 ENDIF SCOTCH_SYMBOLIC=(KEEP(270).EQ.0) #if defined(MUMPS_SCOTCHIMPORTOMPTHREADS) CALL MUMPS_SCOTCH_ESMUMPSCONTEXT( ESMUMPSCONTEXT ) SCOTCH_SYMBOLIC=SCOTCH_SYMBOLIC .AND. (ESMUMPSCONTEXT.EQ.1) #endif symmetry = INFO(8) NBQD = 0 GCOMP_PROVIDED=.FALSE. WEIGHTUSED = 0 NORIG = N IF (present(NORIG_ARG)) THEN NORIG=NORIG_ARG ENDIF IF (present(GCOMP_PROVIDED_IN)) & GCOMP_PROVIDED = GCOMP_PROVIDED_IN IF (GCOMP_PROVIDED.AND.(.NOT. present(GCOMP))) THEN INFO(1) = -900 WRITE(6,*) " INTERNAL ERROR in MUMPS(ANA_F) ", & GCOMP_PROVIDED_IN, present(GCOMP) INFO(2) = 1 RETURN ENDIF IF (GCOMP_PROVIDED) THEN NZG8 = GCOMP%NZG LIW8 = NZG8 + int(GCOMP%NG,8)+1_8 IW => GCOMP%ADJ(1:LIW8) IPE => GCOMP%IPE(1:GCOMP%NG+1) DO I=1,GCOMP%NG PTRAR(I,2) = int(IPE(I+1)-IPE(I)) ENDDO ELSE IF (LIWALLOC.GT.0_8) THEN ALLOCATE( IWALLOC (LIWALLOC), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(LIWALLOC,INFO(2)) GOTO 90 ENDIF ENDIF IF ( LIWALLOC.EQ.0_8 ) THEN INFO(1) = -900 WRITE(6,*) " INTERNAL ERROR in MUMPS(ANA_F) ", & "LIWALLOC, GCOMP_PROVIDED=", LIWALLOC, GCOMP_PROVIDED INFO(2) = 2 RETURN ENDIF LIW8 = LIWALLOC NZG8 = NZ8 IW => IWALLOC(1:LIW8) ALLOCATE( IPEALLOC(N+1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (N+1)*KEEP(10) GOTO 90 ENDIF IPE => IPEALLOC(1:N+1) ENDIF LP = ICNTL(1) MP = ICNTL(3) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) LDIAG = ICNTL(4) COMPRESS_SCHUR = .FALSE. IF (present(SIZEOFBLOCKS)) THEN SIZEOFBLOCKS_PTR => SIZEOFBLOCKS(1:N) LSIZEOFBLOCKS_PTR = N SIZEOFBLOCKS_AVAIL = .TRUE. ELSE SIZEOFBLOCKS_PTR => IDUMMY_ARRAY SIZEOFBLOCKS_AVAIL = .FALSE. LSIZEOFBLOCKS_PTR = 1 IDUMMY_ARRAY(1) = -1 ENDIF IF (PROK) THEN IF (present(GCOMP)) THEN WRITE(MP,'(A,I10,A,I13,A)') " Processing a graph of size:", N & ," with ", GCOMP%NZG, " edges" ELSE WRITE(MP,'(A,I10)') " Processing a graph of size:", N ENDIF ENDIF IF (GCOMP_PROVIDED) THEN FREE_CENTRALIZED_MATRIX = .FALSE. ELSE FREE_CENTRALIZED_MATRIX = ( & (KEEP(54).EQ.3).AND. & (KEEP(494).EQ.0).AND. & (KEEP(106).NE.3) & ) ENDIF INPLACE64_GRAPH_COPY = .FALSE. INPLACE64_RESTORE_GRAPH = .TRUE. IF (KEEP(1).LT.0) KEEP(1) = 0 NEMIN = KEEP(1) IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (present(SIZEOFBLOCKS)) THEN K = min(10,GCOMP%NG) IF (LDIAG.EQ.4) K = GCOMP%NG WRITE (MP,99909) N, NZG8, INFO(1) I8= 0_8 WRITE(MP,'(A)') " Graph adjacency " DO J=1, K IFIRST = GCOMP%IPE(J) ILAST= min(GCOMP%IPE(J+1)-1,GCOMP%IPE(J)+K-1) write(MP,'(A,I10)') " .... node/column:", J write(MP,'(8X,10I9)') & (GCOMP%ADJ(I8),I8=IFIRST,ILAST) ENDDO ELSE J8 = min(NZG8, 10_8) IF (LDIAG .EQ.4) J8 = NZG8 WRITE (MP,99999) N, NZG8, LIW8, INFO(1) IF (J8.GT.0_8) WRITE (MP,99998) (IRN(I8),ICN(I8),I8=1_8,J8) ENDIF K = min(10,N) IF (LDIAG.EQ.4) K = N IF (IORD.EQ.1 .AND. K.GT.0) THEN WRITE (MP,99997) (IKEEP1(I),I=1,K) ENDIF ENDIF NCMP = N IF (KEEP(60).NE.0) THEN IF ((SIZE_SCHUR.LE.0 ).OR. & (SIZE_SCHUR.GE.N) ) GOTO 90 ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF ( ( KEEP(60).NE.0).AND.(SIZE_SCHUR.GT.0) & .AND. & ((IORD.EQ.7).OR.(IORD.EQ.5)) & )THEN COMPRESS_SCHUR=.TRUE. NCMP = N-SIZE_SCHUR ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL ZMUMPS_GNEW_SCHUR(N,NCMP,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, & KEEP(264), KEEP(265), & LISTVAR_SCHUR(1), SIZE_SCHUR, FRERE(1), FILS(1), & INPLACE64_GRAPH_COPY) INFO(8) = symmetry INPLACE64_GRAPH_COPY = INPLACE64_GRAPH_COPY.AND. & (.NOT.FREE_CENTRALIZED_MATRIX) DEALLOCATE(IPQ8) IORD = 5 KEEP(95) = 1 NBQD = 0 ELSE #endif IF (GCOMP_PROVIDED) THEN IWFR8 = GCOMP%NZG+1_8 ELSE ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF CALL ZMUMPS_ANA_GNEW(N,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, KEEP(264), KEEP(265), & .TRUE., INPLACE64_GRAPH_COPY) INFO(8) = symmetry INPLACE64_GRAPH_COPY = INPLACE64_GRAPH_COPY.AND. & (.NOT.FREE_CENTRALIZED_MATRIX) DEALLOCATE(IPQ8) ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif IF(NBQD .GT. 0) THEN IF( KEEP(50) .EQ. 2 .AND. ICNTL(12) .EQ. 0 ) THEN IF(KEEP(95) .NE. 1) THEN IF ( PROK ) & WRITE( MP,*) & 'Compressed/constrained ordering set OFF' KEEP(95) = 1 ENDIF ENDIF ENDIF IF ( (KEEP(60).NE.0) .AND. (IORD.GT.1) .AND. & .NOT. COMPRESS_SCHUR ) THEN IORD = 0 ENDIF IF ( (KEEP(50).EQ.2) & .AND. (KEEP(95) .EQ. 3) & .AND. (IORD .EQ. 7) ) THEN IORD = 2 ENDIF CALL MUMPS_SET_ORDERING( NORIG, KEEP, & KEEP(50), NSLAVES, IORD, & NBQD, AvgDens, & PROK, MP ) IF(KEEP(50) .EQ. 2) THEN IF(KEEP(95) .EQ. 3 .AND. IORD .NE. 2) THEN IF (PROK) WRITE(MP,*) & 'WARNING: ZMUMPS_ANA_F constrained ordering not '// & ' available with selected ordering. Move to' // & ' compressed ordering.' KEEP(95) = 2 ENDIF ELSE KEEP(95) = 1 ENDIF MTRANS = KEEP(23) COMPRESS = KEEP(95) - 1 IF(COMPRESS .GT. 0 .AND. KEEP(52) .EQ. -2) THEN IF(CNTL4 .GE. 0.0D0) THEN IF (KEEP(1).LE.8) THEN NEMIN = 16 ELSE NEMIN = 2*KEEP(1) ENDIF ENDIF ENDIF IF(MTRANS .GT. 0 .AND. KEEP(50) .EQ. 2) THEN KEEP(23) = 0 ENDIF IF (COMPRESS .EQ. 2) THEN IF (IORD.NE.2) THEN WRITE(*,*) "IORD not compatible with COMPRESS:", & IORD, COMPRESS CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_SET_CONSTRAINTS( & N,PIV(1),FRERE(1),FILS(1),NFSIZ(1),IKEEP1(1), & NCST,KEEP,KEEP8, ROWSCA(1) & ) ENDIF IF ( IORD .NE. 1 ) THEN IF (COMPRESS .GE. 1) THEN ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL ZMUMPS_LDLT_COMPRESS( & N, NZ8, IRN(1), ICN(1), PIV(1), & NCMP, IW(1), LIW8, IPE(1), PTRAR(1,2), IPQ8, & IWL1, FILS(1), IWFR8, & IERROR, KEEP, KEEP8, ICNTL, INPLACE64_GRAPH_COPY) DEALLOCATE(IPQ8) symmetry = 100 ENDIF IF ( (symmetry.LT.MINSYM).AND.(KEEP(50).EQ.0) ) THEN IF(KEEP(23) .EQ. 7 ) THEN KEEP(23) = -5 GOTO 90 ELSE IF(KEEP(23) .EQ. -9876543) THEN IDENT = .TRUE. KEEP(23) = 5 IF (PROK) WRITE(MP,'(A)') & ' ... Apply column permutation (already computed)' DO J=1,N JPERM = PIV(J) FILS(JPERM) = J IF (JPERM.NE.J) IDENT = .FALSE. ENDDO IF (.NOT.IDENT) THEN DO J8=1_8,NZ8 J = ICN(J8) IF ((J.LE.0).OR.(J.GT.N)) CYCLE ICN(J8) = FILS(J) ENDDO ALLOCATE(COLSCA_TEMP(N), stat=IERR) IF ( IERR > 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF DO J = 1, N COLSCA_TEMP(J)=COLSCA(J) ENDDO DO J=1, N COLSCA(FILS(J))=COLSCA_TEMP(J) ENDDO DEALLOCATE(COLSCA_TEMP) IF (PROK) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL ZMUMPS_ANA_GNEW & (N,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264), KEEP(265), & .TRUE.,INPLACE64_GRAPH_COPY) INFO(8) = symmetry DEALLOCATE(IPQ8) NCMP = N ELSE KEEP(23) = 0 ENDIF ENDIF ELSE IF (KEEP(23) .EQ. 7 .OR. KEEP(23) .EQ. -9876543 ) THEN IF (PROK) WRITE(MP,'(A)') & ' ... No column permutation' KEEP(23) = 0 ENDIF ENDIF IF (FREE_CENTRALIZED_MATRIX & .AND.COMPRESS.EQ.0.AND.(.NOT.COMPRESS_SCHUR)) THEN deallocate(IRN) NULLIFY(IRN) deallocate(ICN) NULLIFY(ICN) ENDIF INPLACE64_RESTORE_GRAPH = & INPLACE64_RESTORE_GRAPH.AND.(COMPRESS.NE.1) ALLOCATE( PARENT ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF IF (IORD.NE.1 .AND. IORD.NE.5) THEN IF ( KEEP(60) .NE. 0 ) THEN IORD = 0 ENDIF IF (PROK) THEN IF (IORD.EQ.2) THEN WRITE(MP,'(A)') ' Ordering based on AMF ' #if defined(scotch) || defined(ptscotch) ELSE IF (IORD.EQ.3) THEN WRITE(MP,'(A)') ' Ordering based on SCOTCH ' #endif #if defined(pord) ELSE IF (IORD.EQ.4) THEN WRITE(MP,'(A)') ' Ordering based on PORD ' #endif ELSE IF (IORD.EQ.6) THEN WRITE(MP,'(A)') ' Ordering based on QAMD ' ELSE WRITE(MP,'(A)') ' Ordering based on AMD ' ENDIF ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF IF ( KEEP(60) .NE. 0 ) THEN CALL MUMPS_HAMD(N, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP1(1), & IKEEP2(1), NCMPA, FILS(1), IKEEP3(1), & PTRAR, PTRAR(1,3), & PARENT, & LISTVAR_SCHUR(1), SIZE_SCHUR) IF (KEEP(60)==1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ELSE IF ( .FALSE. ) THEN #if defined(pord) ELSEIF (IORD .EQ. 4) THEN CALL MUMPS_PORD_INTSIZE(PORD_INT_SIZE) TOTW = N IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) & ) THEN IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IF & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) THEN TOTW = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF IF (PORD_INT_SIZE .EQ. 64) THEN CALL MUMPS_PORDF_WND_MIXEDto64(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, TOTW, PARENT, & INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY & ) ELSE IF (PORD_INT_SIZE .EQ. 32) THEN CALL MUMPS_PORDF_WND_MIXEDto32(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, TOTW, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE WRITE(*,*) & "Internal error in PORD wrappers, PORD_INT_SIZE=", & PORD_INT_SIZE CALL MUMPS_ABORT() ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 GOTO 90 ENDIF IF (INFO(1) .LT.0) GOTO 90 IF (COMPRESS.EQ.1) THEN CALL ZMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS(1)) CALL ZMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP1(1), & FRERE(1),PTRAR(1,1)) DO I=1,NCMP IKEEP2(IKEEP1(I))=I ENDDO ENDIF ELSE IF (PORD_INT_SIZE.EQ.64) THEN CALL MUMPS_PORDF_MIXEDto64(NCMP, IWFR8-1_8, IPE, & IW, & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY & ) ELSE IF (PORD_INT_SIZE.EQ.32) THEN CALL MUMPS_PORDF_MIXEDto32(NCMP, IWFR8-1_8, IPE, & IW, & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE WRITE(*,*) & "Internal error in PORD wrappers, PORD_INT_SIZE=", & PORD_INT_SIZE CALL MUMPS_ABORT() ENDIF ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 GOTO 90 ENDIF IF (INFO(1) .LT. 0) GOTO 90 #endif #if defined(scotch) || defined(ptscotch) ELSEIF (IORD .EQ. 3) THEN CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE) IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) & ) THEN WEIGHTREQUESTED=1 IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IF & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) THEN DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF ELSE WEIGHTREQUESTED = 0 DO I= 1, N IWL1(I) = 1 ENDDO ENDIF IF (SCOTCH_INT_SIZE.EQ.32) THEN IF (KEEP(10).EQ.1) THEN INFO(1) = -52 INFO(2) = 2 ELSE CALL MUMPS_SCOTCH_MIXEDto32(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, & WEIGHTUSED, WEIGHTREQUESTED, SCOTCH_SYMBOLIC) ENDIF ELSE IF (SCOTCH_INT_SIZE.EQ.64) THEN CALL MUMPS_SCOTCH_MIXEDto64(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH, & WEIGHTUSED, WEIGHTREQUESTED, SCOTCH_SYMBOLIC) ELSE WRITE(*,*) & "Internal error in SCOTCH wrappers, SCOTCH_INT_SIZE=", & SCOTCH_INT_SIZE CALL MUMPS_ABORT() ENDIF IF (INFO(1) .LT. 0) GOTO 90 IF (.NOT. SCOTCH_SYMBOLIC) THEN IF ( COMPRESS .EQ. 1 ) THEN CALL ZMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94), & KEEP(93),PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF ELSE IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS).AND. & (WEIGHTUSED.EQ.0) ) & ) THEN CALL ZMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS(1)) CALL ZMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP1(1), & FRERE(1),PTRAR(1,1)) DO I=1,NCMP IKEEP2(IKEEP1(I))=I ENDDO ENDIF #endif ELSEIF (IORD .EQ. 2) THEN NBBUCK = 2*N COMPUTE_PERM=.FALSE. IF(COMPRESS .GE. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.GE.1) THEN CALL MUMPS_ABORT() ENDIF NBBUCK = max(NBBUCK, NORIG-N) NBBUCK = max(NBBUCK, 2*NORIG) NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF ALLOCATE( WTEMP ( 0: NBBUCK + 1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = NBBUCK+2 GOTO 90 ENDIF IF(COMPRESS .LE. 1) THEN CALL MUMPS_HAMF4 & (TOTEL, NCMP, COMPUTE_PERM, NBBUCK, LIW8, IPE(1), & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), WTEMP, PARENT(1)) ELSE IF(PROK) WRITE(MP,'(A)') & ' Constrained Ordering based on AMF' CALL MUMPS_CST_AMF(NCMP, NBBUCK, LIW8, IPE(1), & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), WTEMP, & NFSIZ(1), FRERE(1), PARENT(1)) ENDIF DEALLOCATE(WTEMP) ELSEIF (IORD .EQ. 6) THEN ALLOCATE( WTEMP ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF THRESH = 1 IVersion = 2 COMPUTE_PERM=.FALSE. IF(COMPRESS .EQ. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.EQ.1) THEN CALL MUMPS_ABORT() ENDIF NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL MUMPS_QAMD & (TOTEL,COMPUTE_PERM,IVersion, THRESH, WTEMP, & NCMP, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), PARENT(1)) DEALLOCATE(WTEMP) ELSE COMPUTE_PERM=.FALSE. IF(COMPRESS .EQ. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.EQ.1) THEN CALL MUMPS_ABORT() ENDIF NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL MUMPS_ANA_H(TOTEL, COMPUTE_PERM, & NCMP, LIW8, IPE(1), IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), PARENT(1)) ENDIF ENDIF IF(COMPRESS .GE. 1) THEN CALL ZMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94),KEEP(93), & PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) #if defined(scotch) || defined(ptscotch) IF (IORD.EQ.3) THEN WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME SPENT IN SCOTCH reordering =', TIMEB ENDIF #endif ENDIF ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MP,'(A)') ' Ordering based on METIS' ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN INFO(1) = -52 INFO(2) = 1 GOTO 90 ENDIF #if defined(metis4) || defined(parmetis3) NUMFLAG = 1 OPT_METIS_SIZE = 8 #else OPT_METIS_SIZE = 40 #endif IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 FRERE(I) = 2 ENDDO DO I=KEEP(93)/2+1,NCMP FRERE(I) = 1 ENDDO #if defined(metis4) || defined(parmetis3) IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEWND_MIXEDto32( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ELSE IF ((NORIG.NE.N).AND.present(SIZEOFBLOCKS)) THEN DO I=1, N FRERE(I) = SIZEOFBLOCKS(I) ENDDO IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEWND_MIXEDto32( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ELSE IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW, NUMFLAG, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW, NUMFLAG, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP,LPOK,KEEP(10), & LIW8, INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ENDIF ENDIF #else ELSE IF (present(SIZEOFBLOCKS)) THEN DO I=1,N FRERE(I) = SIZEOFBLOCKS(I) ENDDO ELSE DO I=1,NCMP FRERE(I) = 1 ENDDO ENDIF ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW, FRERE, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW, FRERE, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP,LPOK,KEEP(10), & LIW8, INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH) ELSE IF (LPOK) WRITE(LP,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF #endif IF (INFO(1) .LT.0) GOTO 90 IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME SPENT IN METIS reordering =', TIMEB ENDIF IF ( COMPRESS_SCHUR ) THEN CALL ZMUMPS_EXPAND_PERM_SCHUR( & N, NCMP, IKEEP1(1),IKEEP2(1), & LISTVAR_SCHUR(1), SIZE_SCHUR, FILS(1)) COMPRESS = -1 ENDIF IF (COMPRESS .EQ. 1) THEN CALL ZMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94), & KEEP(93),PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF ENDIF #endif IF (PROK) THEN IF (IORD.EQ.1) THEN WRITE(MP,'(A)') ' Ordering given is used' ENDIF ENDIF IF (IORD.EQ.1 .OR. IORD.EQ.5 .OR. COMPRESS.EQ.-1 & .OR. ( (IORD.EQ.3).AND.(.NOT.SCOTCH_SYMBOLIC) ) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) .AND.(IORD.EQ.3) & .AND. (WEIGHTUSED.EQ.0) & ) & ) THEN IF ((KEEP(106).EQ.1).OR.(KEEP(106).EQ.2).OR.(KEEP(106).EQ.4) & .OR.(KEEP(60).NE.0)) THEN IF ( COMPRESS .EQ. -1 ) THEN ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL ZMUMPS_ANA_GNEW(N,NZ8,IRN(1),ICN(1),IW(1),LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264),KEEP(265), .TRUE., & INPLACE64_GRAPH_COPY) DEALLOCATE(IPQ8) ENDIF COMPRESS = 0 IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF IF (KEEP(106).EQ.2) THEN IF (PROK) THEN WRITE(MP,'(A)') " SYMBOLIC based on column counts " ENDIF IF (present(SIZEOFBLOCKS)) THEN DO I=1, N FRERE(I) = SIZEOFBLOCKS(I) ENDDO ELSE FRERE(1) = -1 ENDIF CALL MUMPS_WRAP_GINP94 ( & N, IPE(1), IW(1), IWFR8, & IKEEP1(1), & FRERE(1), & KEEP(60), LISTVAR_SCHUR(1), SIZE_SCHUR, & KEEP(378), & IWL1, PARENT, & IKEEP2(1), IKEEP3(1), NFSIZ(1), & PTRAR(1,1), PTRAR(1,2), PTRAR(1,3), & INFO ) IF (INFO(1).LT.0) GOTO 90 ELSE IF ((KEEP(106).EQ.4).AND.(KEEP(60).EQ.0).AND. & (.NOT.present(SIZEOFBLOCKS) .OR. (NORIG.EQ.N)) & ) THEN WRITE(MP,*) " Undefined option for ICNTL(58) " INFO(1)= -99998 GOTO 90 ELSE ALLOCATE( WTEMP ( 2_8*int(N,8) ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(2_8*int(N,8), INFO(2) ) GOTO 90 ENDIF THRESH = -1 IF (KEEP(60) == 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR ENDIF AGG6 =.FALSE. IF (present(SIZEOFBLOCKS)) THEN DO I=1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO TOTEL = NORIG ELSE IWL1(1) = -1 TOTEL = N ENDIF CALL MUMPS_SYMQAMD(THRESH, WTEMP, & N, TOTEL, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1(1), WTEMP(N+1), & IKEEP2(1), NCMPA, FILS(1), IKEEP3(1), PTRAR, & PTRAR(1,3),IKEEP1(1), LISTVAR_SCHUR(1), ITEMP, & AGG6, PARENT) DEALLOCATE(WTEMP) ENDIF IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME IN symbolic factorization =', TIMEB ENDIF ELSE CALL ZMUMPS_ANA_J(N, NZ8, IRN(1), ICN(1), IKEEP1(1), IW(1), & LIW8, IPE(1), & PTRAR(1,2), IWL1, IWFR8, & INFO(1),INFO(2), MP) IF (KEEP(60) .EQ. 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR ENDIF CALL ZMUMPS_ANA_K(N, IPE(1), IW(1), LIW8, IWFR8, IKEEP1(1), & IKEEP2(1), IWL1, & PTRAR, NCMPA, ITEMP, PARENT) ENDIF ENDIF IF (KEEP(60) .NE. 0) THEN IF (KEEP(60)==1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ENDIF IF (allocated(IPEALLOC)) DEALLOCATE(IPEALLOC) ALLOCATE(WTEMP(N), stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF CALL ZMUMPS_ANA_LNEW & (N, PARENT, IWL1, IKEEP1(1), IKEEP2(1), IKEEP3(1), & NFSIZ(1), PTRAR, INFO(6), FILS(1), FRERE(1), & PTRAR(1,3), NEMIN, WTEMP, KEEP(60), & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), & ICNTL(13), KEEP(37), KEEP(197), NSLAVES, KEEP(250).EQ.1, & SIZEOFBLOCKS_AVAIL, SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR & , INODE_Scalapack_CAND, NBSONS_Scalapack_CAND, & KEEP(11), KEEP(191), KEEP(192), KEEP(193) & ) DEALLOCATE(WTEMP) IF (KEEP(60).NE.0) THEN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO WHILE (IN.GT.0) IN = FILS (IN) END DO IFSON = -IN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO I=2,SIZE_SCHUR FILS(IN) = LISTVAR_SCHUR (I) IN = FILS(IN) FRERE (IN) = N+1 ENDDO FILS(IN) = -IFSON ENDIF CALL ZMUMPS_ANA_M(IKEEP2(1), & PTRAR(1,3), INFO(6), & INFO(5), KEEP(2), KEEP(50), & KEEP8(101), KEEP(108), KEEP(5), & KEEP(6), KEEP(226), KEEP(253)) KEEP(59) = INFO(5) IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) INODE_Scalapack_CAND = KEEP(20) NBSONS_Scalapack_CAND = 1 END IF IF ( (KEEP(48) == 4 .AND. KEEP8(21).GT.0_8) & .OR. & (KEEP (48)==5 .AND. KEEP8(21) .GT. 0_8 ) & .OR. & (KEEP(24).NE.0.AND.KEEP8(21).GT.0_8) ) THEN CALL ZMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2), & KEEP(48), KEEP(50), NSLAVES) END IF IF (KEEP(210).LT.1.OR.KEEP(210).GT.2) KEEP(210)=2 IF (KEEP(210).EQ.2) KEEP8(79)=huge(KEEP8(79)) IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF IF (KEEP(11).EQ.0) THEN IF ( (KEEP(79).EQ.0).OR.(KEEP(79).EQ.2).OR. & (KEEP(79).EQ.3).OR.(KEEP(79).EQ.5).OR. & (KEEP(79).EQ.6) & ) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN CALL ZMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF (PROK) THEN WRITE(MP,*) " Number of split nodes in pre-splitting=", & KEEP(61) ENDIF ENDIF ENDIF ENDIF ENDIF HOW_TO_SPLIT_ROOT = 0 SPLITROOT = ICNTL(13) .EQ. -1 IF (KEEP(11).GT.1) THEN NFR = NFSIZ(INODE_Scalapack_CAND) #if defined(NOSCALAPACK) SPLITROOT = SPLITROOT .OR. & ( NSLAVES.GT.0.AND. & ( dble(NFR) - dble(NFR)/dble(max(2,NSLAVES)) & .GT. dble(KEEP(9)) ) & ) #else SPLITROOT = SPLITROOT .OR. & ( ICNTL(13).GT.0 .AND. NSLAVES .GT. ICNTL(13). AND. & ( dble(NFR) - dble(NFR)/dble(max(2,NSLAVES)) & .GT. dble(KEEP(9)) ) & ) #endif ELSE #if defined(NOSCALAPACK) SPLITROOT = SPLITROOT .OR. NSLAVES.GT.0 #else SPLITROOT = SPLITROOT .OR. & (ICNTL(13).GT.0 .AND. NSLAVES .GT. ICNTL(13) & ) #endif ENDIF IF (SPLITROOT.AND.KEEP(11).GT.0) HOW_TO_SPLIT_ROOT =1 IF (KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. IF (KEEP(11).GT.0) HOW_TO_SPLIT_ROOT = 2 ENDIF #if defined(NOSCALAPACK) #else IF ( KEEP(11).GT.0) THEN IF (.NOT.SPLITROOT .AND. & (KEEP(60).EQ.0).AND. & ( (NFSIZ(INODE_Scalapack_CAND).GT.KEEP(37)) & .AND.(ICNTL(13).LE.0) ) & .AND. & (NBSONS_Scalapack_CAND.GT.KEEP(11)) & ) THEN HOW_TO_SPLIT_ROOT = 3 SPLITROOT=.TRUE. ENDIF ENDIF #endif SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) )) IF (SPLITROOT) THEN IF (KEEP(11).EQ.0) THEN CALL ZMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) ENDIF ELSE CALL ZMUMPS_SPLIT_ROOT( NSLAVES, & HOW_TO_SPLIT_ROOT, INODE_Scalapack_CAND, & N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(1), KEEP8(1), & SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR, INFO(6)) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN K = min(10,N) IF (LDIAG.EQ.4) K = N IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) ENDIF GO TO 90 90 CONTINUE IF (INFO(1) .NE. 0) THEN IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE (LP,99996) INFO(1), INFO(2) ENDIF IF (allocated(IWALLOC)) DEALLOCATE(IWALLOC) IF (allocated(IWL1)) DEALLOCATE(IWL1) IF (allocated(IPEALLOC)) DEALLOCATE(IPEALLOC) IF (allocated(PTRAR)) DEALLOCATE(PTRAR) IF (allocated(PARENT)) DEALLOCATE(PARENT) RETURN 99999 FORMAT (/'Entering ordering phase with ...'/ & ' N NNZ LIW INFO(1)'/, & 6X, I10, I11, I12, I10) 99998 FORMAT ('Matrix entries: IRN() ICN()'/ & (I12, I9, I12, I9, I12, I9)) 99909 FORMAT (/'Entering ordering phase with graph dimensions ...'/ & ' |V| |E| INFO(1)'/, & 10X, I10, I13, I10) 99997 FORMAT ('IKEEP1(.)=', 10I8/(12X, 10I8)) 99996 FORMAT & (/'** Error/warning return ** from Analysis * INFO(1:2)= ', & (I3, I16)) 99989 FORMAT ('FILS (.) =', 10I9/(11X, 10I9)) 99988 FORMAT ('FRERE(.) =', 10I9/(11X, 10I9)) 99987 FORMAT ('NFSIZ(.) =', 10I9/(11X, 10I9)) END SUBROUTINE ZMUMPS_ANA_F SUBROUTINE ZMUMPS_ANA_N_DIST( id, NBINCOL, NBINROW ) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_STRUC IMPLICIT NONE include 'mpif.h' TYPE(ZMUMPS_STRUC), INTENT(INOUT), TARGET :: id INTEGER, INTENT(OUT), TARGET :: NBINCOL(:) INTEGER, INTENT(OUT), TARGET :: NBINROW(:) INTEGER :: IERR, allocok INTEGER :: IOLD, JOLD, INEW, JNEW INTEGER(8) :: K, INZ INTEGER, POINTER :: IIRN(:), IJCN(:) INTEGER, POINTER :: IWORK1(:), IWORK2(:) LOGICAL :: IDO IF(id%KEEP(54) .EQ. 3) THEN IIRN => id%IRN_loc IJCN => id%JCN_loc INZ = id%KEEP8(29) IWORK1 => NBINROW(1:id%N) allocate(IWORK2(id%N),stat=allocok) IF (allocok > 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%N RETURN ENDIF IDO = .TRUE. ELSE IIRN => id%IRN IJCN => id%JCN INZ = id%KEEP8(28) IWORK1 => NBINCOL(1:id%N) IWORK2 => NBINROW(1:id%N) IDO = id%MYID .EQ. 0 END IF DO 50 IOLD=1,id%N IWORK1(IOLD) = 0_8 IWORK2(IOLD) = 0_8 50 CONTINUE IF(IDO) THEN DO 70 K=1_8,INZ IOLD = IIRN(K) JOLD = IJCN(K) IF ( (IOLD.GT.id%N).OR.(JOLD.GT.id%N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) GOTO 70 IF (IOLD.NE.JOLD) THEN INEW = id%SYM_PERM(IOLD) JNEW = id%SYM_PERM(JOLD) IF ( id%KEEP( 50 ) .EQ. 0 ) THEN IF (INEW.LT.JNEW) THEN IWORK2(IOLD) = IWORK2(IOLD) + 1 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 (id%KEEP(54) .EQ. 3) THEN CALL MUMPS_BIGALLREDUCE(.FALSE., IWORK1(1), NBINCOL(1), id%N, & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) CALL MUMPS_BIGALLREDUCE(.FALSE., IWORK2(1), NBINROW(1), id%N, & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) deallocate(IWORK2) ELSE CALL MPI_BCAST( NBINCOL(1), id%N, MPI_INTEGER, & 0, id%COMM, IERR ) CALL MPI_BCAST( NBINROW(1), id%N, MPI_INTEGER, & 0, id%COMM, IERR ) END IF RETURN END SUBROUTINE ZMUMPS_ANA_N_DIST SUBROUTINE ZMUMPS_ANA_O( N, NZ, MTRANS, PERM, & IKEEPALLOC, LIKEEPALLOC, & idIRN, idJCN, idA, idROWSCA, idCOLSCA, WORK2, KEEP, & ICNTL, INFO, INFOG ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ INTEGER, INTENT(OUT) :: PERM(:) INTEGER, POINTER, DIMENSION(:) :: idIRN, idJCN COMPLEX(kind=8), POINTER, DIMENSION(:) :: idA DOUBLE PRECISION, POINTER, DIMENSION(:) :: idROWSCA, idCOLSCA INTEGER(8), INTENT(IN) :: LIKEEPALLOC INTEGER, TARGET :: IKEEPALLOC(LIKEEPALLOC) INTEGER, INTENT(INOUT) :: MTRANS INTEGER :: KEEP(500) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(INOUT) :: INFOG(80) INTEGER, TARGET :: WORK2(N) INTEGER :: allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: IW DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: S2 TARGET :: S2 INTEGER ICNTL64(10), INFO64(10) INTEGER ICNTL_SYM_MWM(10),INFO_SYM_MWM(10) DOUBLE PRECISION CNTL64(10) INTEGER MPRINT,LP, MP INTEGER JPERM INTEGER NUMNZ, I, J, JPOS LOGICAL PROK, IDENT, DUPPLI INTEGER K50, KER_SIZE, NZER_DIAG, MTRANSLOC,RZ_DIAG INTEGER(8) :: LIWG INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8 INTEGER :: LSC INTEGER(8) :: NZTOT, NZREAL, IPIW, LIW, LIWMIN, NZsave, & K, KPOS, LDW, LDWMIN, IRNW, RSPOS, CSPOS, & LS2,J8, N8 LOGICAL SCALINGLOC INTEGER,POINTER,DIMENSION(:) :: ZERODIAG INTEGER,POINTER,DIMENSION(:) :: STR_KER INTEGER,POINTER,DIMENSION(:) :: MARKED INTEGER,POINTER,DIMENSION(:) :: FLAG INTEGER,POINTER,DIMENSION(:) :: PIV_OUT DOUBLE PRECISION THEMIN, THEMAX, COLNORM,MAXDBL, ABSAK DOUBLE PRECISION ZERO,TWO,ONE PARAMETER(ZERO = 0.0D0,TWO = 2.0D0,ONE = 1.0D0) N8 = int(N,8) MPRINT = ICNTL(3) LP = ICNTL(1) MP = ICNTL(2) PROK = ((MPRINT.GT.0).AND.(ICNTL(4).GE.2)) K50 = KEEP(50) SCALINGLOC = .FALSE. IF(KEEP(52) .EQ. -2) THEN IF(.not.associated(idA)) THEN ELSE SCALINGLOC = .TRUE. ENDIF ELSE IF(KEEP(52) .EQ. 77) THEN SCALINGLOC = .TRUE. IF( MTRANS .NE. 5 .AND. MTRANS .NE. 6 & .AND. MTRANS .NE. 7) THEN SCALINGLOC = .FALSE. ENDIF IF(.not.associated(idA)) THEN SCALINGLOC = .FALSE. IF (PROK) & WRITE(MPRINT,*) 'Analysis: auto scaling OFF because ', & 'A not provided at analysis ' ENDIF ENDIF IF ( (KEEP(50).EQ.2).AND.(ICNTL(8).NE.-2).AND. & (MTRANS .EQ. 7 .OR. KEEP(95) .EQ. 0) ) THEN ZERODIAG => IKEEPALLOC(1:N) ZERODIAG = 0 NZER_DIAG = N RZ_DIAG = 0 DO K=1,NZ I = idIRN(K) J = idJCN(K) IF (I.NE.J) CYCLE IF ( (J.LE.N).AND.(J.GE.1) ) THEN IF(ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = 1 IF(associated(idA)) THEN ABSAK= abs(idA(K)) IF(ABSAK .EQ. dble(0.0D0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ENDIF NZER_DIAG = NZER_DIAG - 1 ENDIF ENDIF ENDDO IF( (NZER_DIAG+RZ_DIAG) .LT. max(1,(N/10)) ) THEN MTRANS = 0 KEEP(95) = 1 GOTO 500 ENDIF ENDIF IF(SCALINGLOC) THEN IF (PROK) WRITE(MPRINT,*) & 'Scaling will be computed during analysis' ENDIF IF( MTRANS.NE.0 .AND. (.NOT.associated(idA)) ) MTRANS=1 MTRANSLOC = MTRANS IF (MTRANS.LT.0 .OR. MTRANS.GT.7) GO TO 500 IF (K50 .EQ. 0) THEN IF(.NOT. SCALINGLOC .AND. MTRANS .EQ. 7) THEN GO TO 500 ENDIF IF(SCALINGLOC) THEN IF (MTRANSLOC.NE.6) THEN MTRANSLOC = 5 ENDIF ENDIF ELSE IF (MTRANS .EQ. 7) MTRANSLOC = 5 ENDIF IF(SCALINGLOC .AND. MTRANSLOC .NE. 5 .AND. & MTRANSLOC .NE. 6 ) THEN IF (PROK) WRITE(MPRINT,*) & 'WARNING scaling required: set MTRANS option to 5' MTRANSLOC = 5 ENDIF IF (N.EQ.1) THEN MTRANS = 0 KEEP(95) = 1 GO TO 500 ENDIF IF(K50 .NE. 0) THEN NZTOT = 2_8*NZ+N8 ELSE NZTOT = NZ ENDIF ZERODIAG => IKEEPALLOC(1:N) STR_KER => IKEEPALLOC(int(N+1,8):2_8*int(N,8)) CALL ZMUMPS_MTRANSI(ICNTL64,CNTL64) ICNTL64(1) = ICNTL(1) ICNTL64(2) = ICNTL(2) ICNTL64(3) = ICNTL(3) ICNTL64(4) = -1 IF (ICNTL(4).EQ.3) ICNTL64(4) = 0 IF (ICNTL(4).EQ.4) ICNTL64(4) = 1 ICNTL64(5) = -1 IF (PROK) THEN WRITE(MPRINT,'(A,I3)') & 'Compute maximum matching (Maximum Transversal):', & MTRANSLOC IF (MTRANSLOC.EQ.1) & WRITE(MPRINT,'(A,I3)')' ... JOB =',MTRANSLOC IF (MTRANSLOC.EQ.2) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': BOTTLENECK THESIS' IF (MTRANSLOC.EQ.3) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': BOTTLENECK SIMAX' IF (MTRANSLOC.EQ.4) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': MAXIMIZE SUM DIAGONAL' IF (MTRANSLOC.EQ.5 .OR. MTRANSLOC.EQ.6) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC, & ': MAXIMIZE PRODUCT DIAGONAL AND SCALE' ENDIF INFOG(23) = MTRANSLOC CNTL64(2) = huge(CNTL64(2)) IRNW = 1 IPIW = IRNW + NZTOT IF (MTRANSLOC.EQ.1) LIWMIN = 5_8*N8 IF (MTRANSLOC.EQ.2) LIWMIN = 3_8*N8 IF (MTRANSLOC.EQ.3) LIWMIN = 10_8*N8 + NZTOT IF (MTRANSLOC.EQ.4) LIWMIN = 2_8*N8 IF (MTRANSLOC.EQ.5) LIWMIN = 5_8*N8 IF (MTRANSLOC.EQ.6) LIWMIN = 5_8*N8 + NZTOT LIW = LIWMIN LIWG = LIW + NZTOT ALLOCATE(IW(LIWG), stat=allocok) IF (allocok .GT. 0 ) THEN GOTO 410 ENDIF ALLOCATE( IPQ8(N), IPE(N+1), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR( (2_8*int(N,8)+1_8) * int(KEEP(10),8), & INFO(2) ) GOTO 500 ENDIF IF (MTRANSLOC.EQ.1) THEN LDWMIN = N8+3_8 ENDIF IF (MTRANSLOC.EQ.2) LDWMIN = max( N8+NZTOT , N8+3_8 ) IF (MTRANSLOC.EQ.3) LDWMIN = max( NZTOT+1_8 , N8+3_8 ) IF (MTRANSLOC.EQ.4) LDWMIN = 2_8 * N8 + & max( NZTOT , N8+3_8 ) IF (MTRANSLOC.EQ.5) LDWMIN = 3_8 * N8 + NZTOT IF (MTRANSLOC.EQ.6) LDWMIN = 4_8 * N8 + NZTOT LDW = LDWMIN ALLOCATE(S2(LDW), stat=allocok) IF (allocok .GT. 0 ) THEN GOTO 430 ENDIF IF(MTRANSLOC .NE. 1) LDW = LDW-NZTOT RSPOS = NZTOT CSPOS = RSPOS+N8 NZREAL = 0_8 DO 5 J=1,N IPQ8(J) = 0_8 5 CONTINUE IF(K50 .EQ. 0) THEN DO 10 K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1).AND. & (I.LE.N).AND.(I.GE.1) ) THEN IPQ8(J) = IPQ8(J) + 1_8 NZREAL = NZREAL + 1_8 ENDIF 10 CONTINUE ELSE ZERODIAG = 0 NZER_DIAG = N RZ_DIAG = 0 DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1).AND. & (I.LE.N).AND.(I.GE.1) ) THEN IPQ8(J) = IPQ8(J) + 1_8 NZREAL = NZREAL + 1_8 IF(I .NE. J) THEN IPQ8(I) = IPQ8(I) + 1_8 NZREAL = NZREAL + 1_8 ELSE IF (ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = 1 IF(associated(idA)) THEN ABSAK= abs(idA(K)) IF(ABSAK .EQ. dble(0.0D0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ZERODIAG(I) = exponent(ABSAK) if ( ZERODIAG(I).EQ.0) ZERODIAG(I)=1 ENDIF NZER_DIAG = NZER_DIAG - 1 ELSE IF(associated(idA)) THEN ABSAK= abs(idA(K)) ZERODIAG(I) = ZERODIAG(I)+ exponent(ABSAK) if ( ZERODIAG(I).EQ.0) ZERODIAG(I)=1 ENDIF ENDIF ENDIF ENDIF ENDDO IF(MTRANSLOC .GE. 4) THEN DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN IPQ8(I) = IPQ8(I) + 1_8 NZREAL = NZREAL + 1_8 ENDIF ENDDO ENDIF ENDIF IPE(1) = 1 DO 20 J=1,N IPE(J+1) = IPE(J)+IPQ8(J) 20 CONTINUE DO 25 J=1, N IPQ8(J ) = IPE(J) 25 CONTINUE IF(K50 .EQ. 0) THEN IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1_8) = I IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ELSE IF ( .not.associated(idA)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1) = I S2(KPOS) = abs(idA(K)) IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ENDIF ELSE IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1) = I IPQ8(J) = IPQ8(J) + 1_8 IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDIF ENDDO ELSE IF ( .not.associated(idA) ) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF THEMAX = ZERO THEMIN = huge(THEMIN) DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1_8) = I S2(KPOS) = abs(idA(K)) IPQ8(J) = IPQ8(J) + 1_8 IF(abs(idA(K)) .GT. THEMAX) THEN THEMAX = abs(idA(K)) ELSE IF(abs(idA(K)) .LT. THEMIN & .AND. abs(idA(K)).GT. ZERO) THEN THEMIN = abs(idA(K)) ENDIF IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J S2(KPOS) = abs(idA(K)) IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDIF ENDDO DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = I S2(KPOS) = ZERO IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDDO IF ( THEMAX .NE. ZERO ) THEN CNTL64(2) = (log(THEMAX/THEMIN))*(dble(N)) & - log(THEMIN) + ONE ENDIF ENDIF ENDIF DUPPLI = .FALSE. NZsave = NZREAL FLAG => IKEEPALLOC(2_8*int(N,8)+1:3_8*int(N,8)) IF(MTRANSLOC.NE.1) THEN CALL ZMUMPS_SUPPRESS_DUPPLI_VAL(N,NZREAL,IPE(1),IW(IRNW),S2, & PERM(1),IPQ8(1)) ELSE CALL ZMUMPS_SUPPRESS_DUPPLI_STR(N,NZREAL,IPE(1),IW(IRNW), & PERM(1)) ENDIF IF(NZREAL .NE. NZsave) DUPPLI = .TRUE. LS2 = NZTOT IF ( MTRANSLOC .EQ. 1 ) THEN LS2 = 1_8 LDW = 1_8 ENDIF CALL ZMUMPS_MTRANS_DRIVER(MTRANSLOC ,N, N, NZREAL, & IPE, IW(IRNW), S2(1), LS2, & NUMNZ, PERM(1), LIW, IW(IPIW), LDW, S2(LS2+1), & IPQ8, & ICNTL64, CNTL64, INFO64, INFO) IF (INFO(1).LT.0) THEN IF (LP.GT.0 .AND. ICNTL(4).GE.1) & WRITE(LP,'(A,I5)') & ' Not enough memory in MAXTRANS INFO(1)=',INFO(1) GOTO 500 ENDIF IF (INFO64(1).LT.0) THEN IF (LP.GT.0 .AND. ICNTL(4).GE.1) & WRITE(LP,'(A,I5)') & ' INTERNAL ERROR in MAXTRANS INFO(1)=',INFO64(1) INFO(1) = -9964 INFO(2) = INFO64(1) GO TO 500 ENDIF IF (INFO64(1).GT.0) THEN IF (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(A,I5)') & ' WARNING in MAXTRANS INFO(1)=',INFO64(1) ENDIF KER_SIZE = 0 IF(K50 .EQ. 2) THEN DO I=1,N IF(ZERODIAG(I) .EQ. 0) THEN IF(PERM(I) .EQ. I) THEN KER_SIZE = KER_SIZE + 1 PERM(I) = -I STR_KER(KER_SIZE) = I ENDIF ENDIF ENDDO ENDIF IF (NUMNZ.LT.N) then IF (MTRANSLOC.EQ.1) THEN IF (MINVAL(PERM(1:N)) .LE. 0) THEN GOTO 400 ENDIF ELSE GO TO 400 ENDIF ENDIF IF(K50 .EQ. 0) THEN IDENT = .TRUE. IF (MTRANS .EQ. 0 ) GOTO 102 DO 80 J=1,N JPERM = PERM(J) IW(IRNW+int(JPERM-1,8)) = J IF (JPERM.NE.J) IDENT = .FALSE. 80 CONTINUE IF(IDENT) THEN MTRANS = 0 ELSE IF(MTRANS .EQ. 7) THEN MTRANS = -9876543 GOTO 102 ENDIF IF (PROK) WRITE(MPRINT,'(A)') & ' ... Apply column permutation' DO 100 K=1,NZ J = idJCN(K) IF ((J.LE.0).OR.(J.GT.N)) GO TO 100 idJCN(K) = IW(IRNW+int(J-1,8)) 100 CONTINUE IF (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' ENDIF 102 CONTINUE IF (SCALINGLOC) THEN IF ( associated(idCOLSCA)) & DEALLOCATE( idCOLSCA ) IF ( associated(idROWSCA)) & DEALLOCATE( idROWSCA ) ALLOCATE( idCOLSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in ZMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of COLSCA' GOTO 500 ENDIF ENDIF ALLOCATE( idROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in ZMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of ROWSCA' GOTO 500 ENDIF ENDIF KEEP(52) = -2 KEEP(74) = 1 MAXDBL = log(huge(MAXDBL)) DO J=1,N IF(S2(RSPOS+J) .GT. MAXDBL) THEN S2(RSPOS+J) = ZERO ENDIF IF(S2(CSPOS+J) .GT. MAXDBL) THEN S2(CSPOS+J)= ZERO ENDIF ENDDO DO 105 J=1,N J8 = int(J,8) idROWSCA(J) = exp(S2(RSPOS+J8)) IF(idROWSCA(J) .EQ. ZERO) THEN idROWSCA(J) = ONE ENDIF IF ( MTRANS .EQ. -9876543 .OR. MTRANS.EQ. 0 ) THEN idCOLSCA(J)= exp(S2(CSPOS+J8)) IF(idCOLSCA(J) .EQ. ZERO) THEN idCOLSCA(J) = ONE ENDIF ELSE idCOLSCA(IW(IRNW+J8-1_8))= exp(S2(CSPOS+J8)) IF(idCOLSCA(IW(IRNW+J8-1_8)) .EQ. ZERO) THEN idCOLSCA(IW(IRNW+J8-1_8)) = ONE ENDIF ENDIF 105 CONTINUE ENDIF ELSE IDENT = .FALSE. IF(SCALINGLOC) THEN IF ( associated(idCOLSCA)) DEALLOCATE( idCOLSCA ) IF ( associated(idROWSCA)) DEALLOCATE( idROWSCA ) ALLOCATE( idCOLSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in ZMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of COLSCA' GOTO 500 ENDIF ENDIF ALLOCATE( idROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in ZMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of ROWSCA' GOTO 500 ENDIF ENDIF KEEP(52) = -2 KEEP(74) = 1 MAXDBL = log(huge(MAXDBL)) DO J=1,N J8 = int(J,8) IF(S2(RSPOS+J8)+S2(CSPOS+J8) .GT. MAXDBL) THEN S2(RSPOS+J8) = ZERO S2(CSPOS+J8)= ZERO ENDIF ENDDO DO J=1,N J8 = int(J,8) IF(PERM(J) .GT. 0) THEN idROWSCA(J) = & exp((S2(RSPOS+J8)+S2(CSPOS+J8))/TWO) IF(idROWSCA(J) .EQ. ZERO) THEN idROWSCA(J) = ONE ENDIF idCOLSCA(J)= idROWSCA(J) ENDIF ENDDO DO JPOS=1,KER_SIZE I = STR_KER(JPOS) COLNORM = ZERO DO K = IPE(I),IPE(I+1) - 1 IF ( PERM( IW( IRNW+K-1_8) ) > 0 ) THEN COLNORM = max(COLNORM,S2(J)) ENDIF ENDDO COLNORM = exp(COLNORM) idROWSCA(I) = ONE / COLNORM idCOLSCA(I) = idROWSCA(I) ENDDO ENDIF IF(MTRANS .EQ. 7 .OR. KEEP(95) .EQ. 0) THEN IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) & .AND. KEEP(95) .EQ. 0) THEN MTRANS = 0 KEEP(95) = 1 GOTO 390 ELSE IF(KEEP(95) .EQ. 0) THEN IF(SCALINGLOC) THEN KEEP(95) = 3 ELSE KEEP(95) = 2 ENDIF ENDIF IF(MTRANS .EQ. 7) MTRANS = 5 ENDIF ENDIF IF(MTRANS .EQ. 0) GOTO 390 ICNTL_SYM_MWM = 0 INFO_SYM_MWM = 0 IF(MTRANS .EQ. 5 .OR. MTRANS .EQ. 6 .OR. & MTRANS .EQ. 7) THEN ICNTL_SYM_MWM(1) = 0 ICNTL_SYM_MWM(2) = 1 ELSE IF(MTRANS .EQ. 4) THEN ICNTL_SYM_MWM(1) = 2 ICNTL_SYM_MWM(2) = 1 ELSE ICNTL_SYM_MWM(1) = 0 ICNTL_SYM_MWM(2) = 1 ENDIF MARKED => IKEEPALLOC( int(N,8)+1_8 : 2_8*int(N,8)) FLAG => IKEEPALLOC(2_8*int(N,8)+1_8 : 3_8*int(N,8)) PIV_OUT => WORK2(1:N) IF(MTRANSLOC .LT. 4) THEN LSC = 1 ELSE LSC = 2*N ENDIF CALL ZMUMPS_SYM_MWM( & N, NZREAL, IPE, IW(IRNW), S2(1),LSC, PERM(1), & ZERODIAG(1), & ICNTL_SYM_MWM, S2(LSC+1),MARKED(1),FLAG(1), & PIV_OUT(1), INFO_SYM_MWM) IF(INFO_SYM_MWM(1) .NE. 0) THEN WRITE(*,*) '** Error in ZMUMPS_ANA_O' RETURN ENDIF IF(INFO_SYM_MWM(3) .EQ. N) THEN IDENT = .TRUE. ELSEIF ( (ICNTL(12).EQ.0).AND. & ( (N-INFO_SYM_MWM(4)-INFO_SYM_MWM(3)) .GT. N/10 ) & ) THEN IDENT = .TRUE. KEEP(95) = 1 ELSE DO I=1,N PERM(I) = PIV_OUT(I) ENDDO ENDIF KEEP(93) = INFO_SYM_MWM(4) KEEP(94) = INFO_SYM_MWM(3) IF (IDENT) MTRANS=0 ENDIF 390 IF(MTRANS .EQ. 0) THEN KEEP(95) = 1 IF (PROK) THEN WRITE (MPRINT,'(A)') & ' ... Column permutation not used' ENDIF ENDIF GO TO 500 400 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) & WRITE (LP,'(/A)') '** Error: Matrix is structurally singular' INFO(1) = -6 INFO(2) = NUMNZ GOTO 500 410 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in ZMUMPS_ANA_O' WRITE (LP,'(A,I14)') & '** Failure during allocation of INTEGER array of size ', & LIWG ENDIF INFO(1) = -7 CALL MUMPS_SET_IERROR(LIWG,INFO(2)) GOTO 500 430 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in ZMUMPS_ANA_O' WRITE (LP,'(A)') '** Failure during allocation of S2' ENDIF INFO(1) = -5 CALL MUMPS_SET_IERROR(LDW,INFO(2)) 500 CONTINUE IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(S2)) DEALLOCATE(S2) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(IPQ8)) DEALLOCATE(IPQ8) RETURN END SUBROUTINE ZMUMPS_ANA_O END MODULE ZMUMPS_ANA_AUX_M SUBROUTINE ZMUMPS_ANA_K(N,IPE, IW, LW, IWFR, IPS, IPV, & NV, FLAG, & NCMPA, SIZE_SCHUR, PARENT) IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR INTEGER, INTENT(IN) :: IPS(N) INTEGER(8), INTENT(IN) :: LW INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: IPV(N), NV(N), PARENT(N) INTEGER(8), INTENT(INOUT) :: IWFR INTEGER(8), INTENT(INOUT) :: IPE(N) INTEGER, INTENT(INOUT) :: IW(LW) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER I,J,ML,MS,ME,MINJS,IE,KDUMMY INTEGER LN,JS,JE INTEGER(8) :: JP, JP1, JP2, LWFR, IP DO 10 I=1,N FLAG(I) = 0 NV(I) = 0 J = IPS(I) IPV(J) = I 10 CONTINUE NCMPA = 0 DO 100 ML=1,N-SIZE_SCHUR MS = IPV(ML) ME = MS FLAG(MS) = ME IP = IWFR MINJS = N IE = ME DO 70 KDUMMY=1,N JP = IPE(IE) LN = 0 IF (JP.LE.0_8) GO TO 60 LN = IW(JP) DO 50 JP1=1_8,int(LN,8) JP = JP + 1_8 JS = IW(JP) IF (FLAG(JS).EQ.ME) GO TO 50 FLAG(JS) = ME IF (IWFR.LT.LW) GO TO 40 IPE(IE) = JP IW(JP) = LN - int(JP1) CALL ZMUMPS_ANA_D(N, IPE, IW, IP-1_8, LWFR, NCMPA) JP2 = IWFR - 1 IWFR = LWFR IF (IP.GT.JP2) GO TO 30 DO 20 JP=IP,JP2 IW(IWFR) = IW(JP) IWFR = IWFR + 1_8 20 CONTINUE 30 IP = LWFR JP = IPE(IE) 40 IW(IWFR) = JS MINJS = min(MINJS,IPS(JS)+0) IWFR = IWFR + 1_8 50 CONTINUE 60 IPE(IE) = int(-ME,8) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 80 70 CONTINUE 80 IF (IWFR.GT.IP) GO TO 90 IPE(ME) = 0_8 NV(ME) = 1 GO TO 100 90 MINJS = IPV(MINJS) NV(ME) = NV(MINJS) NV(MINJS) = ME IW(IWFR) = IW(IP) IW(IP) = int(IWFR - IP) IPE(ME) = IP IWFR = IWFR + 1_8 100 CONTINUE IF (SIZE_SCHUR == 0) GOTO 500 DO ML = N-SIZE_SCHUR+1,N ME = IPV(ML) IE = ME DO KDUMMY=1,N JP = IPE(IE) LN = 0 IF (JP.LE.0_8) GO TO 160 LN = IW(JP) 160 IPE(IE) = int(-IPV(N-SIZE_SCHUR+1),8) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 190 ENDDO 190 NV(ME) = 0 IPE(ME) = int(-IPV(N-SIZE_SCHUR+1),8) ENDDO ME = IPV(N-SIZE_SCHUR+1) IPE(ME) = 0_8 NV(ME) = SIZE_SCHUR 500 DO I=1,N PARENT(I) = int(IPE(I)) ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_K SUBROUTINE ZMUMPS_ANA_J(N, NZ, IRN, ICN, PERM, & IW, LW, IPE, IQ, FLAG, & IWFR, IFLAG, IERROR, MP) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ, LW INTEGER, INTENT(IN) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: PERM(N) INTEGER, INTENT(IN) :: MP INTEGER(8), INTENT(OUT):: IWFR INTEGER, INTENT(OUT) :: IERROR INTEGER, INTENT(OUT) :: IQ(N) INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER, INTENT(OUT) :: IW(LW) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER, INTENT(INOUT) :: IFLAG INTEGER :: I,J,LBIG,IN,LEN,JDUMMY,L1 INTEGER(8) :: K, K1, K2, KL, KID IERROR = 0 DO 10 I=1,N IQ(I) = 0 10 CONTINUE DO 80 K=1_8,NZ I = IRN(K) J = ICN(K) IW(K) = -I IF (I.EQ.J) GOTO 40 IF (I.GT.J) GOTO 30 IF (I.GE.1 .AND. J.LE.N) GO TO 60 GO TO 50 30 IF (J.GE.1 .AND. I.LE.N) GO TO 60 GO TO 50 40 IW(K) = 0 IF (I.GE.1 .AND. I.LE.N) GO TO 80 50 IERROR = IERROR + 1 IW(K) = 0 IF (IERROR.LE.1 .AND. MP.GT.0) WRITE (MP,99999) IF (IERROR.LE.10 .AND. MP.GT.0) WRITE (MP,99998) K, I, J GO TO 80 60 IF (PERM(J).GT.PERM(I)) GO TO 70 IQ(J) = IQ(J) + 1 GO TO 80 70 IQ(I) = IQ(I) + 1 80 CONTINUE IF (IERROR.GE.1) THEN IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 ENDIF IWFR = 1_8 LBIG = 0 DO 100 I=1,N L1 = IQ(I) LBIG = max(L1,LBIG) IWFR = IWFR + int(L1,8) IPE(I) = IWFR - 1_8 100 CONTINUE DO 140 K=1_8,NZ I = -IW(K) IF (I.LE.0) GO TO 140 KL = K IW(K) = 0 DO 130 KID=1,NZ J = ICN(KL) IF (PERM(I).LT.PERM(J)) GO TO 110 KL = IPE(J) IPE(J) = KL - 1_8 IN = IW(KL) IW(KL) = I GO TO 120 110 KL = IPE(I) IPE(I) = KL - 1_8 IN = IW(KL) IW(KL) = J 120 I = -IN IF (I.LE.0) GO TO 140 130 CONTINUE 140 CONTINUE K = IWFR - 1_8 KL = K + int(N,8) IWFR = KL + 1_8 DO 170 I=1,N FLAG(I) = 0 J = N + 1 - I LEN = IQ(J) IF (LEN.LE.0) GO TO 160 DO 150 JDUMMY=1,LEN IW(KL) = IW(K) K = K - 1_8 KL = KL - 1_8 150 CONTINUE 160 IPE(J) = KL KL = KL - 1_8 170 CONTINUE IF (LBIG.GE.huge(N)) GO TO 190 DO 180 I=1,N K = IPE(I) IW(K) = IQ(I) IF (IQ(I).EQ.0) IPE(I) = 0_8 180 CONTINUE GO TO 230 190 IWFR = 1_8 DO 220 I=1,N K1 = IPE(I) + 1_8 K2 = IPE(I) + int(IQ(I),8) IF (K1.LE.K2) GO TO 200 IPE(I) = 0_8 GO TO 220 200 IPE(I) = IWFR IWFR = IWFR + 1_8 DO 210 K=K1,K2 J = IW(K) IF (FLAG(J).EQ.I) GO TO 210 IW(IWFR) = J IWFR = IWFR + 1_8 FLAG(J) = I 210 CONTINUE K = IPE(I) IW(K) = int(IWFR - K - 1_8) 220 CONTINUE 230 RETURN 99999 FORMAT (' *** WARNING MESSAGE FROM ZMUMPS_ANA_J ***' ) 99998 FORMAT (I6, ' NON-ZERO (IN ROW, I6, 11H AND COLUMN ', I6, & ') IGNORED') END SUBROUTINE ZMUMPS_ANA_J SUBROUTINE ZMUMPS_ANA_D(N, IPE, IW, LW, IWFR,NCMPA) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(INOUT):: IPE(N) INTEGER, INTENT(INOUT) :: NCMPA INTEGER, INTENT(INOUT) :: IW(LW) INTEGER :: I, IR INTEGER(8) :: K1, K, K2, LWFR NCMPA = NCMPA + 1 DO 10 I=1,N K1 = IPE(I) IF (K1.LE.0_8) GO TO 10 IPE(I) = int(IW(K1), 8) IW(K1) = -I 10 CONTINUE IWFR = 1_8 LWFR = IWFR DO 60 IR=1,N IF (LWFR.GT.LW) GO TO 70 DO 20 K=LWFR,LW IF (IW(K).LT.0) GO TO 30 20 CONTINUE GO TO 70 30 I = -IW(K) IW(IWFR) = int(IPE(I)) IPE(I) = int(IWFR,8) K1 = K + 1_8 K2 = K + int(IW(IWFR),8) IWFR = IWFR + 1_8 IF (K1.GT.K2) GO TO 50 DO 40 K=K1,K2 IW(IWFR) = IW(K) IWFR = IWFR + 1_8 40 CONTINUE 50 LWFR = K2 + 1_8 60 CONTINUE 70 RETURN END SUBROUTINE ZMUMPS_ANA_D SUBROUTINE ZMUMPS_ANA_LNEW(N, IPE, NV, IPS, NE, NA, NFSIZ, & NODE, NSTEPS, & FILS, FRERE, ND, NEMIN, SUBORD, KEEP60, & KEEP20, KEEP38, NAMALG,NAMALGMAX, & CUMUL,KEEP50, ICNTL13, KEEP37, KEEP197, NSLAVES, & ALLOW_AMALG_TINY_NODES & , BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS & , INODE_Scalapack_CAND, NBSONS_Scalapack_CAND & , KEEP11, KEEP191, KEEP192, KEEP193 & ) IMPLICIT NONE INTEGER N, NSTEPS, KEEP60, KEEP20, KEEP38, KEEP50 INTEGER ND(N), NFSIZ(N) INTEGER IPE(N), FILS(N), FRERE(N), SUBORD(N) INTEGER NV(N), IPS(N), NE(N), NA(N), NODE(N) INTEGER NEMIN,AMALG_COUNT INTEGER NAMALG(N),NAMALGMAX, CUMUL(N) DOUBLE PRECISION SIZE_DADI_AMALGAMATED, PERCENT_FILL DOUBLE PRECISION ACCU, FLOPS_FATHER, FLOPS_SON, & FLOPS_AVANT, FLOPS_APRES INTEGER ICNTL13, KEEP37, NSLAVES LOGICAL ALLOW_AMALG_TINY_NODES INTEGER KEEP197 LOGICAL, INTENT(IN) :: BLKON INTEGER, INTENT(IN) :: LSIZEOFBLOCKS INTEGER, INTENT(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) INTEGER, INTENT(OUT):: INODE_Scalapack_CAND, & NBSONS_Scalapack_CAND INTEGER, INTENT(IN) :: KEEP11, KEEP191, KEEP192, KEEP193 #if defined(NOAMALGTOFATHER) #else #endif INTEGER I,IF,IS,NR,INS INTEGER K,L,ISON,IN,IFSON,INO INTEGER INOS,IB,IL INTEGER IPERM INTEGER MAXNODE INTEGER SIZE_Scalapack_CAND, NBSONS_current_root LOGICAL ROOT_WITH_FEW_SONS #if defined(NOAMALGTOFATHER) INTEGER INB,INF,INFS,INL,INSW,INT1,NR1 #else INTEGER DADI #endif LOGICAL AMALG_TO_father_OK AMALG_COUNT = 0 INODE_Scalapack_CAND = -1 NBSONS_Scalapack_CAND = -1 SIZE_Scalapack_CAND = -1 NBSONS_current_root = 0 DO 10 I=1,N CUMUL(I)= 0 IPS(I) = 0 NE(I) = 0 SUBORD(I) = 0 NAMALG(I) = 0 10 CONTINUE DO I=1,N IF (BLKON) THEN NODE(I) = SIZEOFBLOCKS(I) ELSE NODE(I) = 1 ENDIF ENDDO FRERE(1:N) = IPE(1:N) NR = N + 1 MAXNODE = 1 DO 50 I=1,N IF = -FRERE(I) IF (NV(I).EQ.0) THEN IF (SUBORD(IF).NE.0) SUBORD(I) = SUBORD(IF) SUBORD(IF) = I IF (BLKON) THEN NODE(IF) = NODE(IF)+SIZEOFBLOCKS(I) ELSE NODE(IF) = NODE(IF)+1 ENDIF MAXNODE = max(NODE(IF),MAXNODE) ELSE IF (IF.NE.0) THEN IS = -IPS(IF) IF (IS.GT.0) FRERE(I) = IS IPS(IF) = -I ELSE NR = NR - 1 NE(NR) = I ENDIF ENDIF 50 CONTINUE MAXNODE = int(dble(MAXNODE)*dble(NEMIN) / dble(100)) MAXNODE = max(MAXNODE,2000) #if defined(NOAMALGTOFATHER) DO 999 I=1,N FILS(I) = IPS(I) 999 CONTINUE NR1 = NR INS = 0 1000 IF (NR1.GT.N) GO TO 1151 INS = NE(NR1) NR1 = NR1 + 1 1070 INL = FILS(INS) IF (INL.LT.0) THEN INS = -INL GO TO 1070 ENDIF 1080 IF (FRERE(INS).LT.0) THEN INS = -FRERE(INS) FILS(INS) = 0 GO TO 1080 ENDIF IF (FRERE(INS).EQ.0) THEN INS = 0 GO TO 1000 ENDIF INB = FRERE(INS) IF (NV(INB).GE.NV(INS)) THEN INS = INB GO TO 1070 ENDIF INF = INB 1090 INF = FRERE(INF) IF (INF.GT.0) GO TO 1090 INF = -INF INFS = -FILS(INF) IF (INFS.EQ.INS) THEN FILS(INF) = -INB IPS(INF) = -INB FRERE(INS) = FRERE(INB) FRERE(INB) = INS ELSE INSW = INFS 1100 INFS = FRERE(INSW) IF (INFS.NE.INS) THEN INSW = INFS GO TO 1100 ENDIF FRERE(INS) = FRERE(INB) FRERE(INB) = INS FRERE(INSW)= INB ENDIF INS = INB GO TO 1070 1151 CONTINUE #endif DO 51 I=1,N FILS(I) = IPS(I) 51 CONTINUE IS = 1 I = 0 IPERM = 1 DO 160 K=1,N AMALG_TO_father_OK=.FALSE. IF (I.LE.0) THEN IF (NR.GT.N) EXIT I = NE(NR) NE(NR) = 0 NR = NR + 1 IL = N NA(N) = 0 NBSONS_current_root =0 IF (IPS(I).LT.0) THEN IB = -IPS(I) NBSONS_current_root = NBSONS_current_root + 1 69 IB =FRERE(IB) IF (IB.GT.0) THEN NBSONS_current_root = NBSONS_current_root + 1 GOTO 69 ENDIF ENDIF 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 DADI = -IPE(I) IF (DADI.EQ.0) THEN IF (NV(I) .GT. SIZE_Scalapack_CAND) THEN INODE_Scalapack_CAND = I SIZE_Scalapack_CAND = NV(I) ENDIF ENDIF #if ! defined(NOAMALGTOFATHER) IF ( (DADI.NE.0) .AND. & ( & (KEEP60.EQ.0).OR. & ( (KEEP20.NE.DADI).AND.(KEEP38.NE.DADI) ) & ) & ) THEN ACCU = dble(2)*dble(NODE(I))*dble(NV(DADI)-NV(I)+NODE(I)) SIZE_DADI_AMALGAMATED = & dble(NV(DADI)+NODE(I)) * & dble(NV(DADI)+NODE(I)) PERCENT_FILL = dble(100) * ACCU / SIZE_DADI_AMALGAMATED ACCU = ACCU + dble(CUMUL(I)) AMALG_TO_father_OK = ( & ( (NODE(I).LE.MAXNODE).AND.(NODE(DADI).LE.MAXNODE) ) & .OR. & ( (NODE(I).LE.NEMIN.and. NODE(DADI).GT. MAXNODE) & .OR.(NODE(DADI).LE.NEMIN .and. NODE(I).GT.MAXNODE))) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( PERCENT_FILL < dble(NEMIN) ) ) IF (KEEP197 .EQ. 1 ) THEN AMALG_TO_father_OK = AMALG_TO_father_OK.OR. & ( NODE(I).LE.2*NEMIN .AND. NODE(DADI).LT.4*NEMIN) ENDIF AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( ACCU / SIZE_DADI_AMALGAMATED .LE. dble(NEMIN)) ) IF (AMALG_TO_father_OK) THEN CALL MUMPS_GET_FLOPS_COST(NV(I),NODE(I),NODE(I), & KEEP50,1,FLOPS_SON) CALL MUMPS_GET_FLOPS_COST(NV(DADI),NODE(DADI), & NODE(DADI), & KEEP50,1,FLOPS_FATHER) FLOPS_AVANT = FLOPS_FATHER+FLOPS_SON & + max(dble(200.0) * dble(NV(I)-NODE(I)) & * dble(NV(I)-NODE(I)), & dble(10000.0)) CALL MUMPS_GET_FLOPS_COST(NV(DADI)+NODE(I), & NODE(DADI)+NODE(I), & NODE(DADI)+NODE(I), & KEEP50,1,FLOPS_APRES) IF (FLOPS_APRES.GT.FLOPS_AVANT* & (dble(1)+dble(max(8,NEMIN)-8)/dble(100))) THEN AMALG_TO_father_OK = .FALSE. ENDIF ENDIF ROOT_WITH_FEW_SONS =.TRUE. IF (KEEP11.GT.0) THEN IF (IPE(DADI).EQ.0) THEN IF & (NA(IL)+max(NA(IL+1),NBSONS_current_root) & .GT.KEEP11) & ROOT_WITH_FEW_SONS= .FALSE. ELSE IF & (NA(IL)+NA(IL+1)+max(NA(N),NBSONS_current_root) & .GT.KEEP11) & ROOT_WITH_FEW_SONS= .FALSE. ENDIF ENDIF IF ( (NV(I).GT. max(KEEP191,1)*NV(DADI)) & .AND. (NSLAVES.GT.1) & .AND. (ICNTL13.LE.0) & .AND. (NV(I).GT. KEEP37) & .AND. ROOT_WITH_FEW_SONS & ) THEN IF ( ( ACCU / SIZE_DADI_AMALGAMATED ) .LT. & 10.0D0/dble(max(KEEP191,1)) ) THEN AMALG_TO_father_OK = .TRUE. ENDIF ENDIF IF ( ALLOW_AMALG_TINY_NODES .AND. & (NODE(I)*max(KEEP192,1)) .LE. (NV(DADI)-NAMALG(DADI)) ) & THEN IF ( NAMALG(DADI) < & (NV(DADI)-NAMALG(DADI))/max(KEEP193,1) ) THEN AMALG_TO_father_OK = .TRUE. NAMALG(DADI) = NAMALG(DADI) + NODE(I) ENDIF ENDIF IF ( DADI .EQ. -FRERE(I) & .AND. -FILS(DADI).EQ.I & ) THEN AMALG_TO_father_OK = ( AMALG_TO_father_OK .OR. & ( NV(I)-NODE(I).EQ.NV(DADI)) ) ENDIF IF (AMALG_TO_father_OK) THEN CUMUL(DADI)=CUMUL(DADI)+nint(ACCU) NAMALG(DADI) = NAMALG(DADI) + NAMALG(I) AMALG_COUNT = AMALG_COUNT+1 IN = DADI 75 IF (SUBORD(IN).EQ.0) GOTO 76 IN = SUBORD(IN) GOTO 75 76 CONTINUE SUBORD(IN) = I NV(I) = 0 IFSON = -FILS(DADI) IF (IFSON.EQ.I) THEN IF (FILS(I).LT.0) THEN FILS(DADI) = FILS(I) GOTO 78 ELSE IF (FRERE(I).GT.0) THEN FILS(DADI) = -FRERE(I) ELSE FILS(DADI) = 0 ENDIF GOTO 90 ENDIF ENDIF IN = IFSON 77 INS = IN IN = FRERE(IN) IF (IN.NE.I) GOTO 77 IF (FILS(I) .LT.0) THEN FRERE(INS) = -FILS(I) ELSE FRERE(INS) = FRERE(I) GOTO 90 ENDIF 78 CONTINUE IN = -FILS(I) 79 INO = IN IN = FRERE(IN) IF (IN.GT.0) GOTO 79 FRERE(INO) = FRERE(I) 90 CONTINUE NODE(DADI) = NODE(DADI)+ NODE(I) NV(DADI) = NV(DADI) + NODE(I) NA(IL+1) = NA(IL+1) + NA(IL) GOTO 120 ENDIF ENDIF #endif NE(IS) = NE(IS) + NODE(I) IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1 NA(IS) = NA(IL) ND(IS) = NV(I) NODE(I) = IS IPS(I) = IPERM IPERM = IPERM + 1 IN = I 777 IF (SUBORD(IN).EQ.0) GO TO 778 IN = SUBORD(IN) NODE(IN) = IS IPS(IN) = IPERM IPERM = IPERM + 1 GO TO 777 778 IF (NA(IS).LE.0) GO TO 110 #if defined(NOAMALGTOFATHER) IF ( (KEEP60.NE.0).AND. & (NE(IS).EQ.ND(IS)) ) GOTO 110 IF (ND(IS-1)-NE(IS-1).EQ.ND(IS)) THEN GO TO 100 ENDIF IF(NAMALG(IS-1) .GE. NAMALGMAX) THEN GOTO 110 ENDIF IF ((NE(IS-1).GE.NEMIN).AND. & (NE(IS).GE.NEMIN) ) GO TO 110 IF (2*NE(IS-1)*(ND(IS)-ND(IS-1)+NE(IS-1)).GE. & ((ND(IS)+NE(IS-1))* & (ND(IS)+NE(IS-1))*NEMIN/100)) GO TO 110 NAMALG(IS-1) = NAMALG(IS-1)+1 100 NA(IS-1) = NA(IS-1) + NA(IS) - 1 ND(IS-1) = ND(IS) + NE(IS-1) NE(IS-1) = NE(IS) + NE(IS-1) NE(IS) = 0 NODE(I) = IS-1 IFSON = -FILS(I) IN = IFSON 102 INO = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 102 NV(INO) = 0 IN = I 888 IF (SUBORD(IN).EQ.0) GO TO 889 IN = SUBORD(IN) GO TO 888 889 SUBORD(IN) = INO INOS = -FILS(INO) IF (IFSON.EQ.INO) THEN FILS(I) = -INOS GO TO 107 ENDIF IN = IFSON 105 INS = IN IN = FRERE(IN) IF (IN.NE.INO) GO TO 105 IF (INOS.EQ.0) THEN FRERE(INS) = -I GO TO 120 ELSE FRERE(INS) = INOS ENDIF 107 IN = INOS IF (IN.EQ.0) GO TO 120 108 INT1 = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 108 FRERE(INT1) = -I GO TO 120 #endif 110 IS = IS + 1 120 IB = FRERE(I) IF (IB.GE.0) THEN IF (IB.GT.0) NA(IL) = 0 I = IB ELSE I = -IB IL = IL + 1 ENDIF 160 CONTINUE NSTEPS = IS - 1 I = INODE_Scalapack_CAND INOS = -FILS(I) NBSONS_Scalapack_CAND = 0 IF (INOS.GT.0) THEN NBSONS_Scalapack_CAND = NBSONS_Scalapack_CAND+1 INO = FRERE(INOS) DO WHILE (INO.GT.0 .AND. INO.LE.N) NBSONS_Scalapack_CAND = NBSONS_Scalapack_CAND+1 INO = FRERE(INO) ENDDO ENDIF DO I=1, N IF (NV(I).EQ.0) THEN FRERE(I) = N+1 NFSIZ(I) = 0 ELSE NFSIZ(I) = ND(NODE(I)) IF (SUBORD(I) .NE.0) THEN INOS = -FILS(I) INO = I DO WHILE (SUBORD(INO).NE.0) IS = SUBORD(INO) FILS(INO) = IS INO = IS END DO FILS(INO) = -INOS ENDIF ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_LNEW SUBROUTINE ZMUMPS_ANA_M(NE, ND, NSTEPS, & MAXFR, MAXELIM, K50, SIZEFAC_TOT, MAXNPIV, & K5,K6,PANEL_SIZE,K253) IMPLICIT NONE INTEGER, INTENT(in) :: NSTEPS, K50, K253, K5, K6 INTEGER, INTENT(in) :: NE(NSTEPS), ND(NSTEPS) INTEGER, INTENT(out) :: MAXNPIV, PANEL_SIZE INTEGER, INTENT(out) :: MAXFR, MAXELIM INTEGER(8), INTENT(out):: SIZEFAC_TOT INTEGER ITREE, NFR, NELIM INTEGER LKJIB INTEGER(8) :: SIZEFAC LKJIB = max(K5,K6) MAXFR = 0 MAXELIM = 0 MAXNPIV = 0 PANEL_SIZE = 0 SIZEFAC_TOT = 0_8 DO ITREE=1,NSTEPS NELIM = NE(ITREE) NFR = ND(ITREE) + K253 IF (NFR.GT.MAXFR) MAXFR = NFR IF (NFR-NELIM.GT.MAXELIM) MAXELIM = NFR - NELIM IF (NELIM .GT. MAXNPIV) THEN MAXNPIV = NELIM ENDIF IF (K50.EQ.0) THEN SIZEFAC = (2_8*int(NFR,8) - int(NELIM,8))*int(NELIM,8) PANEL_SIZE = max(PANEL_SIZE, NFR*(LKJIB+1)) ELSE SIZEFAC = int(NFR,8) * int(NELIM,8) PANEL_SIZE = max(PANEL_SIZE, NELIM*(LKJIB+1)) PANEL_SIZE = max(PANEL_SIZE, (NFR-NELIM)*(LKJIB+1)) ENDIF SIZEFAC_TOT = SIZEFAC_TOT + SIZEFAC END DO RETURN END SUBROUTINE ZMUMPS_ANA_M SUBROUTINE ZMUMPS_ANA_R( N, FILS, FRERE, & NSTK, NA ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: FILS(N), FRERE(N) INTEGER, INTENT(OUT) :: NSTK(N), NA(N) INTEGER NBROOT, NBLEAF, ILEAF, I, IN, ISON NA = 0 NSTK = 0 NBROOT = 0 ILEAF = 1 DO 11 I=1,N IF (FRERE(I).EQ. N+1) CYCLE IF (FRERE(I).EQ.0) NBROOT = NBROOT + 1 IN = I 12 IN = FILS(IN) IF (IN.GT.0) GO TO 12 IF (IN.EQ.0) THEN NA(ILEAF) = I ILEAF = ILEAF + 1 CYCLE ENDIF ISON = -IN 13 NSTK(I) = NSTK(I) + 1 ISON = FRERE(ISON) IF (ISON.GT.0) GO TO 13 11 CONTINUE NBLEAF = ILEAF-1 IF (N.GT.1) THEN IF (NBLEAF.GT.N-2) THEN IF (NBLEAF.EQ.N-1) THEN NA(N-1) = -NA(N-1)-1 NA(N) = NBROOT ELSE NA(N) = -NA(N)-1 ENDIF ELSE NA(N-1) = NBLEAF NA(N) = NBROOT ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_ANA_R SUBROUTINE ZMUMPS_DIAG_ANA &( MYID, COMM, KEEP,KEEP8, INFO, INFOG, RINFO, RINFOG, ICNTL, & SIZE_SCHUR ) IMPLICIT NONE INTEGER, INTENT(IN) :: COMM, MYID, KEEP(500), INFO(80), & ICNTL(60), INFOG(80), SIZE_SCHUR INTEGER(8), INTENT(IN) :: KEEP8(150) DOUBLE PRECISION, INTENT(IN) :: RINFO(40), RINFOG(40) INCLUDE 'mpif.h' INTEGER MASTER, MPG INTEGER ITMP, ICNTL48_EFF PARAMETER( MASTER = 0 ) MPG = ICNTL(3) IF ( MYID.eq.MASTER.and.MPG.GT.0.AND.ICNTL(4).GE.2) THEN ITMP = KEEP(13) IF (ICNTL(15).EQ.0) THEN ITMP = 0 ENDIF IF (KEEP(400).GT.0) THEN ICNTL48_EFF=1 ELSE ICNTL48_EFF=0 ENDIF 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(95), ICNTL(13), KEEP(12), & ITMP, & ICNTL(18), KEEP(252), KEEP(494), & ICNTL48_EFF, & KEEP(106), & 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), SIZE_SCHUR IF (KEEP(251).GT.0) WRITE(MPG, 99997) KEEP(251) IF (KEEP(253).GT.0) WRITE(MPG, 99996) KEEP(253) ENDIF RETURN 99992 FORMAT(/'Leaving analysis phase with ...'/ & ' INFOG(1) =',I16/ & ' INFOG(2) =',I16/ & ' -- (20) Number of entries in factors (estim.) =',I16/ & ' -- (3) Real space for factors (estimated) =',I16/ & ' -- (4) Integer space for factors (estimated) =',I16/ & ' -- (5) Maximum frontal size (estimated) =',I16/ & ' -- (6) Number of nodes in the tree =',I16/ & ' -- (32) Type of analysis effectively used =',I16/ & ' -- (7) Ordering option effectively used =',I16/ & ' ICNTL (6) Maximum transversal option =',I16/ & ' ICNTL (7) Pivot order option =',I16/ & ' ICNTL(12) Ordering symmetric indef. matrices =',I16/ & ' ICNTL(13) Parallelism/splitting of root node =',I16/ & ' ICNTL(14) Percentage of memory relaxation =',I16/ & ' ICNTL(15) Analysis by block effectively used =',I16/ & ' ICNTL(18) Distributed input matrix (on if >0) =',I16/ & ' ICNTL(32) Forward elimination during facto. =',I16/ & ' ICNTL(35) BLR activation =',I16/ & ' ICNTL(48) Tree based multithreading (effective)=',I16/ & ' ICNTL(58) Symbolic factorization option =',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/ & ' Size of Schur (SIZE_SCHUR) =',I16) 99996 FORMAT(' Forward solution during factorization, NRHS =',I16) 99997 FORMAT(' ICNTL(31) Discard factors (eff. value) =',I16) END SUBROUTINE ZMUMPS_DIAG_ANA SUBROUTINE ZMUMPS_CUTNODES & ( N, FRERE, FILS, NFSIZ, SIZEOFBLOCKS, LSIZEOFBLOCKS, & NSTEPS, NSLAVES, & KEEP, KEEP8, SPLITROOT, MP, LDIAG, INFO1, INFO2 ) IMPLICIT NONE INTEGER N, NSTEPS, NSLAVES, KEEP(500) INTEGER(8) KEEP8(150) INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) INTEGER LSIZEOFBLOCKS INTEGER SIZEOFBLOCKS(LSIZEOFBLOCKS) LOGICAL SPLITROOT INTEGER MP, LDIAG INTEGER INFO1, INFO2 INTEGER, DIMENSION(:), ALLOCATABLE :: IPOOL INTEGER INODE, DEPTH, I, IBEG, IEND, IIPOOL, NROOT INTEGER MAX_DEPTH, ISON, TOT_CUT, MAX_CUT, STRAT INTEGER(8) :: K79 INTEGER K82, allocok LOGICAL BLKON BLKON = .NOT.(SIZEOFBLOCKS(1).EQ.-1) K79 = KEEP8(79) K82 = abs(KEEP(82)) STRAT= KEEP(62) IF (KEEP(210).EQ.1) THEN MAX_DEPTH = 2*NSLAVES*K82 STRAT = STRAT/4 ELSE IF (( NSLAVES .eq. 1 ).AND. (.NOT. SPLITROOT) ) RETURN IF (NSLAVES.EQ.1) THEN MAX_DEPTH=1 ELSE MAX_DEPTH = int( log( dble( NSLAVES - 1 ) ) & / log(2.0D0) ) ENDIF ENDIF ALLOCATE(IPOOL(NSTEPS+1), stat=allocok) IF (allocok.GT.0) THEN INFO1= -7 INFO2= NSTEPS+1 RETURN ENDIF NROOT = 0 DO INODE = 1, N IF ( FRERE(INODE) .eq. 0 ) THEN NROOT = NROOT + 1 IPOOL( NROOT ) = INODE END IF END DO IBEG = 1 IEND = NROOT IIPOOL = NROOT + 1 IF (SPLITROOT) THEN MAX_DEPTH=0 ENDIF DO DEPTH = 1, MAX_DEPTH DO I = IBEG, IEND INODE = IPOOL( I ) ISON = INODE DO WHILE ( ISON .GT. 0 ) ISON = FILS( ISON ) END DO ISON = - ISON DO WHILE ( ISON .GT. 0 ) IPOOL( IIPOOL ) = ISON IIPOOL = IIPOOL + 1 ISON = FRERE( ISON ) END DO END DO IPOOL( IBEG ) = -IPOOL( IBEG ) IBEG = IEND + 1 IEND = IIPOOL - 1 END DO IPOOL( IBEG ) = -IPOOL( IBEG ) TOT_CUT = 0 IF (SPLITROOT) THEN MAX_CUT = NROOT*max(K82,2) IF (KEEP(72).EQ.1) THEN K79 = min(3_8*3_8,K79) ELSE K79 = min(2000_8*2000_8,K79) IF (KEEP(376) .EQ. 1) THEN K79 = min(int(KEEP(9)+1,8)*int(KEEP(9)+1,8),K79) ENDIF ENDIF IF (KEEP(53).NE.0) THEN K79 = 121_8*121_8 ENDIF ELSE MAX_CUT = 2 * NSLAVES IF (KEEP(210).EQ.1) THEN MAX_CUT = 4 * (MAX_CUT + 4) ENDIF ENDIF DEPTH = -1 DO I = 1, IIPOOL - 1 INODE = IPOOL( I ) IF ( INODE .LT. 0 ) THEN INODE = -INODE DEPTH = DEPTH + 1 END IF CALL ZMUMPS_SPLIT_1NODE & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, & KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IF ( TOT_CUT > MAX_CUT ) EXIT END DO KEEP(61) = TOT_CUT DEALLOCATE(IPOOL) RETURN END SUBROUTINE ZMUMPS_CUTNODES RECURSIVE SUBROUTINE ZMUMPS_SPLIT_1NODE & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, KEEP,KEEP8, & TOT_CUT, STRAT, DEPTH, K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IMPLICIT NONE INTEGER(8) :: K79 INTEGER INODE, N, NSTEPS, NSLAVES, KEEP(500), STRAT, & DEPTH, TOT_CUT, MP, LDIAG INTEGER(8) KEEP8(150) INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) LOGICAL SPLITROOT LOGICAL BLKON INTEGER LSIZEOFBLOCKS INTEGER SIZEOFBLOCKS(LSIZEOFBLOCKS) INTEGER I, IN, NPIV, NFRONT, NSLAVES_ESTIM DOUBLE PRECISION WK_SLAVE, WK_MASTER INTEGER INODE_SON, INODE_FATH, IN_SON, IN_FATH, IN_GRANDFATH INTEGER NPIV_COMPG, NPIV_SON_COMPG, NPIV_FATH_COMPG INTEGER NPIV_SON, NPIV_FATH, NPIV_TEMP INTEGER NCB, NSLAVESMIN, NSLAVESMAX INTEGER MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX EXTERNAL MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX IF ( (KEEP(210).EQ.1.AND.KEEP(60).EQ.0) .OR. & (SPLITROOT) ) THEN IF ( FRERE ( INODE ) .eq. 0 ) THEN NFRONT = NFSIZ( INODE ) NPIV = NFRONT IF (BLKON) THEN IN = INODE NPIV_COMPG = 0 DO WHILE( IN > 0 ) NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) ENDDO ELSE NPIV_COMPG = NPIV ENDIF NCB = 0 IF ( int(NFRONT,8)*int(NFRONT,8).GT.K79 & ) THEN GOTO 333 ENDIF ENDIF ENDIF IF ( FRERE ( INODE ) .eq. 0 ) RETURN NFRONT = NFSIZ( INODE ) IN = INODE NPIV = 0 NPIV_COMPG = 0 DO WHILE( IN > 0 ) IF (BLKON) THEN NPIV = NPIV + SIZEOFBLOCKS(IN) ENDIF NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) END DO IF (.NOT.BLKON) NPIV = NPIV_COMPG NCB = NFRONT - NPIV IF ( (NFRONT - (NPIV/2)) .LE. KEEP(9)) RETURN IF ((KEEP(50) == 0.and.int(NFRONT,8) * int(NPIV,8) > K79 ) .OR. &(KEEP(50) .NE.0.and.int(NPIV,8) * int(NPIV,8) > K79 )) GOTO 333 IF (KEEP(210).EQ.1) THEN NSLAVESMIN = 1 NSLAVESMAX = 64 NSLAVES_ESTIM = 32+NSLAVES ELSE NSLAVESMIN = MUMPS_BLOC2_GET_NSLAVESMIN & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375), KEEP(119)) NSLAVESMAX = MUMPS_BLOC2_GET_NSLAVESMAX & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375), KEEP(119)) NSLAVES_ESTIM = max (1, & nint( dble(NSLAVESMAX-NSLAVESMIN)/dble(3) ) & ) NSLAVES_ESTIM = min (NSLAVES_ESTIM, NSLAVES-1) ENDIF IF ( KEEP(50) .eq. 0 ) THEN WK_MASTER = 0.6667D0 * & dble(NPIV)*dble(NPIV)*dble(NPIV) + & dble(NPIV)*dble(NPIV)*dble(NCB) WK_SLAVE = dble( NPIV ) * dble( NCB ) * & ( 2.0D0 * dble(NFRONT) - dble(NPIV) ) & / dble(NSLAVES_ESTIM) ELSE WK_MASTER = dble(NPIV)*dble(NPIV)*dble(NPIV) / dble(3) WK_SLAVE = & (dble(NPIV)*dble(NCB)*dble(NFRONT)) & / dble(NSLAVES_ESTIM) ENDIF IF (KEEP(210).EQ.1) THEN IF ( dble( 100 + STRAT ) & * WK_SLAVE / dble(100) .GE. WK_MASTER ) RETURN ELSE IF ( dble( 100 + STRAT * max( DEPTH-1, 1 ) ) & * WK_SLAVE / dble(100) .GE. WK_MASTER ) RETURN ENDIF 333 CONTINUE IF (NPIV .LE. 1 ) RETURN NPIV_SON = max(NPIV/2,1) NPIV_FATH = NPIV - NPIV_SON IF (SPLITROOT) THEN IF (NCB .NE .0) THEN WRITE(*,*) "Error splitting" CALL MUMPS_ABORT() ENDIF NPIV_FATH = min(int(sqrt(dble(K79))), int(NPIV/2)) NPIV_SON = NPIV - NPIV_FATH ENDIF INODE_SON = INODE IF (BLKON) THEN NPIV_TEMP = 0 NPIV_SON_COMPG = 0 IN_SON = INODE DO WHILE (IN_SON > 0) NPIV_TEMP = NPIV_TEMP + SIZEOFBLOCKS(IN_SON) NPIV_SON_COMPG = NPIV_SON_COMPG +1 IF (NPIV_TEMP.GE.NPIV_SON) EXIT IN_SON = FILS( IN_SON ) END DO NPIV_FATH_COMPG = NPIV_COMPG - NPIV_SON_COMPG NPIV_SON = NPIV_TEMP NPIV_FATH = NPIV - NPIV_SON ELSE NPIV_SON_COMPG = NPIV_SON NPIV_FATH_COMPG = NPIV_FATH IN_SON = INODE DO I = 1, NPIV_SON_COMPG - 1 IN_SON = FILS( IN_SON ) END DO ENDIF IF (NPIV_FATH_COMPG.EQ.0) RETURN NSTEPS = NSTEPS + 1 TOT_CUT = TOT_CUT + 1 INODE_FATH = FILS( IN_SON ) IF ( INODE_FATH .LT. 0 ) THEN write(*,*) 'Error: INODE_FATH < 0 ', INODE_FATH END IF IN_FATH = INODE_FATH DO WHILE ( FILS( IN_FATH ) > 0 ) IN_FATH = FILS( IN_FATH ) END DO FRERE( INODE_FATH ) = FRERE( INODE_SON ) FRERE( INODE_SON ) = - INODE_FATH FILS ( IN_SON ) = FILS( IN_FATH ) FILS ( IN_FATH ) = - INODE_SON IN = FRERE( INODE_FATH ) DO WHILE ( IN > 0 ) IN = FRERE( IN ) END DO IF ( IN .eq. 0 ) GO TO 10 IN = -IN DO WHILE ( FILS( IN ) > 0 ) IN = FILS( IN ) END DO IN_GRANDFATH = IN IF ( FILS( IN_GRANDFATH ) .eq. - INODE_SON ) THEN FILS( IN_GRANDFATH ) = -INODE_FATH ELSE IN = IN_GRANDFATH IN = - FILS ( IN ) DO WHILE ( FRERE( IN ) > 0 ) IF ( FRERE( IN ) .eq. INODE_SON ) THEN FRERE( IN ) = INODE_FATH GOTO 10 END IF IN = FRERE( IN ) END DO WRITE(*,*) 'ERROR 2 in SPLIT NODE', & IN_GRANDFATH, IN, FRERE(IN) END IF 10 CONTINUE NFSIZ(INODE_SON) = NFRONT NFSIZ(INODE_FATH) = NFRONT - NPIV_SON KEEP(2) = max( KEEP(2), NFRONT - NPIV_SON ) IF (SPLITROOT) THEN RETURN ENDIF CALL ZMUMPS_SPLIT_1NODE & ( INODE_FATH, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IF (.NOT. SPLITROOT) THEN CALL ZMUMPS_SPLIT_1NODE & ( INODE_SON, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) ENDIF RETURN END SUBROUTINE ZMUMPS_SPLIT_1NODE SUBROUTINE ZMUMPS_SPLIT_ROOT & ( NSLAVES, HOW, INODE, N, FRERE, FILS, NFSIZ, KEEP, KEEP8, & SIZEOFBLOCKS, LSIZEOFBLOCKS, NSTEPS) IMPLICIT NONE INTEGER, INTENT(in) :: NSLAVES, HOW INTEGER, INTENT(in) :: INODE, N INTEGER(8), INTENT(in) :: KEEP8(150) INTEGER, INTENT(inout) :: NSTEPS INTEGER, INTENT(inout) :: KEEP(500) INTEGER, INTENT(inout) :: FRERE( N ), FILS( N ), NFSIZ( N ) INTEGER, INTENT(IN) :: LSIZEOFBLOCKS INTEGER, INTENT(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) LOGICAL :: BLKON INTEGER(8) :: K79 INTEGER I, IN, NPIV, NFRONT INTEGER INODE_SON, INODE_FATH, IN_SON, IN_FATH, IN_GRANDFATH INTEGER NPIV_COMPG, NPIV_SON_COMPG, NPIV_FATH_COMPG INTEGER NPIV_SON, NPIV_FATH, NPIV_TEMP INTEGER, PARAMETER :: K_HOW1 = 4000 IF (FRERE(INODE).NE.0) RETURN BLKON = .NOT.(SIZEOFBLOCKS(1).EQ.-1) K79 = max(KEEP8(79), 4_8) K79 = min(20000_8*20000_8,K79) IF (KEEP(72).EQ.1) THEN K79 = min(3_8*3_8,K79) ENDIF IF ((HOW.LT.1) .OR. (HOW.GT.3)) THEN RETURN ENDIF IF (HOW.EQ.2) THEN K79 = min(K79, 121_8*121_8) ENDIF NFRONT = NFSIZ (INODE) NPIV = NFRONT IF (NPIV .LE. 1 ) RETURN IF (BLKON) THEN IN = INODE NPIV_COMPG = 0 DO WHILE( IN > 0 ) NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) ENDDO ELSE NPIV_COMPG = NPIV ENDIF IF (HOW.EQ.1) THEN IF ( (NFRONT/2) .LT. K_HOW1 ) RETURN NPIV_FATH = max(NFRONT/max(NSLAVES,2), 1) NPIV_FATH = max(NPIV_FATH, K_HOW1/2) NPIV_FATH = min(NPIV_FATH, max(NFRONT/2,1)) NPIV_FATH = min(int(sqrt(dble(K79))), NPIV_FATH) NPIV_SON = NPIV - NPIV_FATH ELSE IF (HOW.EQ.2) THEN NPIV_FATH = min(int(sqrt(dble(K79))), int(NPIV/2)) NPIV_SON = NPIV - NPIV_FATH ELSE NPIV_FATH = max(NFRONT - 3*KEEP(6),1) NPIV_SON = NPIV - NPIV_FATH ENDIF INODE_SON = INODE IF (BLKON) THEN NPIV_TEMP = 0 NPIV_SON_COMPG = 0 IN_SON = INODE DO WHILE (IN_SON > 0) NPIV_TEMP = NPIV_TEMP + SIZEOFBLOCKS(IN_SON) NPIV_SON_COMPG = NPIV_SON_COMPG +1 IF (NPIV_TEMP.GE.NPIV_SON) EXIT IN_SON = FILS( IN_SON ) END DO NPIV_FATH_COMPG = NPIV_COMPG - NPIV_SON_COMPG NPIV_SON = NPIV_TEMP NPIV_FATH = NPIV - NPIV_SON ELSE NPIV_SON_COMPG = NPIV_SON NPIV_FATH_COMPG = NPIV_FATH IN_SON = INODE DO I = 1, NPIV_SON_COMPG - 1 IN_SON = FILS( IN_SON ) END DO ENDIF IF (NPIV_FATH_COMPG.EQ.0) RETURN 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 ) NSTEPS = NSTEPS + 1 IF ( (KEEP(53).EQ.0) .AND. NSLAVES.GT.1) THEN KEEP(38) = INODE_FATH ENDIF IF ( KEEP(53).NE.0 ) THEN KEEP(20) = INODE_FATH ENDIF RETURN END SUBROUTINE ZMUMPS_SPLIT_ROOT SUBROUTINE ZMUMPS_ANA_GNEW & (N, NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, NBQD, AvgDens, & KEEP264, KEEP265, PRINTSTAT, & INPLACE64_GRAPH_COPY & ) IMPLICIT NONE INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) INTEGER, intent(inout) :: IERROR INTEGER, intent(out) :: symmetry INTEGER, intent(out) :: NBQD, AvgDens INTEGER, intent(out) :: LEN(N), IW(LW) INTEGER(8), intent(out):: IWFR INTEGER(8), intent(out):: NRORM, NIORM INTEGER(8), intent(out):: IPE(N+1) INTEGER, intent(inout) :: IFLAG, KEEP264, KEEP265 INTEGER(8), intent(out):: IQ(N) INTEGER, intent(out) :: FLAG(N) LOGICAL, intent(in) :: PRINTSTAT LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, MPG, I, J, N1 INTEGER :: NBERR, THRESH, IERROR_LOC INTEGER(8) :: K8, K1, K2, LAST, NDUP INTEGER(8) :: NZOFFA, NDIAGA, L, N8 DOUBLE PRECISION :: RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) NZOFFA = 0_8 NDIAGA = 0 IERROR_LOC = 0 N8 = int(N,8) DO I=1,N+1 IPE(I) = 0_8 ENDDO IF (KEEP264.EQ.0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR_LOC = IERROR_LOC + 1 ELSE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR_LOC = IERROR_LOC + 1 ELSE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.EQ.J) THEN NDIAGA = NDIAGA + 1_8 ELSE IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDDO ENDIF ENDIF NIORM = NZOFFA + 3_8*N8 IF ((IERROR_LOC.GE.1).AND.(mod(IFLAG,2) .EQ. 0)) THEN IFLAG = IFLAG+1 IERROR = IERROR_LOC IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN NBERR = 0 WRITE (MP,99999) DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR. & (10_8.LE.K8 .AND. K8.LE.20_8)) THEN WRITE (MP,'(I16,A,I10,A,I10,A)') & K8,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K8,10_8).EQ.1_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'st entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.2_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.3_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE EXIT ENDIF ENDIF ENDDO ENDIF ENDIF NRORM = NIORM - 2_8*N8 IQ(1) = 1_8 N1 = N - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(N)+IQ(N)-1,IQ(N)) FLAG(1:N) = 0 IPE(1:N) = IQ(1:N) IW(1:LAST) = 0 IWFR = LAST + 1_8 IF (KEEP264 .EQ. 0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF (I.LT.J) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDDO ENDIF ENDIF IF (KEEP265.EQ.0) THEN NDUP = 0_8 DO I=1,N K1 = IPE(I) K2 = IQ(I) - 1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) EXIT IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE L = IQ(J) IW(L) = I IQ(J) = L + 1 IW(K8) = J FLAG(J) = I ENDIF END DO LEN(I) = int((IQ(I) - IPE(I))) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,N IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K1 = IPE(I) K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF 270 CONTINUE LEN(I) = int(IWFR - L) ENDDO ELSE KEEP265 = 1 ENDIF IPE(N+1) = IPE(N) + int(LEN(N),8) IWFR = IPE(N+1) ELSE IPE(1) = 1_8 DO I = 1, N LEN(I) = int(IQ(I) - IPE(I)) ENDDO DO I = 1, N IPE(I+1) = IPE(I) + int(LEN(I),8) ENDDO IWFR = IPE(N+1) ENDIF symmetry = 100 IF (SYM.EQ.0) THEN RSYM = dble(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/ & dble(NZOFFA+NDIAGA) IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) & THEN KEEP265 = -1 ENDIF symmetry = min(nint (100.0D0*RSYM), 100) IF (PRINTSTAT) THEN IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) ) & write(MPG,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) ) & write(MP,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry ENDIF ELSE ENDIF AvgDens = nint(dble(IWFR-1_8)/dble(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN DO I= 1, N J = max(LEN(I),1) IF (J.GT.THRESH) NBQD = NBQD+1 ENDDO ENDIF INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1_8)) IF (PRINTSTAT) THEN IF (MPG .GT. 0.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2)) & write(MP,'(A,1I5)') & ' Average density of rows/columns =', AvgDens ENDIF RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE ZMUMPS_ANA_GNEW SUBROUTINE ZMUMPS_SET_K821_SURFACE & (KEEP821, KEEP2, KEEP48 ,KEEP50, NSLAVES) IMPLICIT NONE INTEGER NSLAVES, KEEP2, KEEP48, KEEP50 INTEGER (8) :: KEEP821 INTEGER(8) KEEP2_SQUARE, NSLAVES8 NSLAVES8= int(NSLAVES,8) KEEP2_SQUARE = int(KEEP2,8) * int(KEEP2,8) KEEP821 = max(KEEP821*int(KEEP2,8),1_8) #if defined(t3e) KEEP821 = min(1500000_8, KEEP821) #elif defined(SP_) KEEP821 = min(3000000_8, KEEP821) #else KEEP821 = min(2000000_8, KEEP821) #endif #if defined(t3e) IF (NSLAVES .GT. 64) THEN KEEP821 = & min(8_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ELSE KEEP821 = & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ENDIF #else IF (NSLAVES.GT.64) THEN KEEP821 = & min(6_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ELSE KEEP821 = & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ENDIF #endif IF (KEEP50 .EQ. 0 ) THEN KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) ELSE KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) ENDIF IF (KEEP50 .EQ. 0 ) THEN #if defined(t3e) KEEP821 = max(KEEP821,200000_8) #else KEEP821 = max(KEEP821,300000_8) #endif ELSE #if defined(t3e) KEEP821 = max(KEEP821,40000_8) #else KEEP821 = max(KEEP821,80000_8) #endif ENDIF KEEP821 = -KEEP821 RETURN END SUBROUTINE ZMUMPS_SET_K821_SURFACE SUBROUTINE ZMUMPS_MTRANS_DRIVER(JOB,M,N,NE, & IP,IRN,A,LA,NUM,PERM,LIW,IW,LDW,DW, & IPQ8, & ICNTL,CNTL,INFO, INFOMUMPS) IMPLICIT NONE INTEGER :: NICNTL, NCNTL, NINFO, INFOMUMPS(80) PARAMETER (NICNTL=10, NCNTL=10, NINFO=10) INTEGER :: JOB,M,N,NUM INTEGER(8), INTENT(IN) :: NE, LIW,LDW, LA INTEGER(8) :: IP(N+1), IPQ8(N) INTEGER :: IRN(NE),PERM(M),IW(LIW) INTEGER :: ICNTL(NICNTL),INFO(NINFO) DOUBLE PRECISION :: A(LA) DOUBLE PRECISION :: DW(LDW),CNTL(NCNTL) INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWtemp8 INTEGER :: allocok INTEGER :: I,J,WARN1,WARN2,WARN4 INTEGER(8) :: K DOUBLE PRECISION :: FACT,ZERO,ONE,RINF,RINF2,RINF3 PARAMETER (ZERO=0.0D+00,ONE=1.0D+0) EXTERNAL ZMUMPS_MTRANSZ,ZMUMPS_MTRANSB,ZMUMPS_MTRANSR, & ZMUMPS_MTRANSS,ZMUMPS_MTRANSW INTRINSIC abs,log RINF = CNTL(2) RINF2 = huge(RINF2)/dble(int(2,8)*int(N,8)) RINF3 = 0.0D0 WARN1 = 0 WARN2 = 0 WARN4 = 0 IF (JOB.LT.1 .OR. JOB.GT.6) THEN INFO(1) = -1 INFO(2) = JOB IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'JOB',JOB GO TO 99 ENDIF IF (M.LT.1 .OR. M.LT.N) THEN INFO(1) = -2 INFO(2) = M IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'M',M GO TO 99 ENDIF IF (N.LT.1) THEN INFO(1) = -2 INFO(2) = N IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'N',N GO TO 99 ENDIF IF (NE.LT.1) THEN INFO(1) = -3 CALL MUMPS_SET_IERROR(NE,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'NE',NE GO TO 99 ENDIF IF (JOB.EQ.1) K = 4_8*int(N,8)+int(M,8) IF (JOB.EQ.2) K = int(N,8) + 2_8*int(M,8) IF (JOB.EQ.3) K = 8_8*int(N,8) + 2*int(M,8) + NE IF (JOB.EQ.4) K = int(N,8) + int(M,8) IF (JOB.EQ.5) K = 3_8*int(N,8) + 2_8*int(M,8) IF (JOB.EQ.6) K = 3_8*int(N,8) + 2_8*int(M,8) + NE IF (LIW.LT.K) THEN INFO(1) = -4 CALL MUMPS_SET_IERROR(K,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9004) INFO(1),K GO TO 99 ENDIF IF (JOB.GT.1) THEN IF (JOB.EQ.2) K = int(M,8) IF (JOB.EQ.3) K = int(1,8) IF (JOB.EQ.4) K = 2_8*int(M,8) IF (JOB.EQ.5) K = int(N,8) + 2_8*int(M,8) IF (JOB.EQ.6) K = int(N,8) + 3_8*int(M,8) IF (LDW .LT. K) THEN INFO(1) = -5 CALL MUMPS_SET_IERROR(K,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9005) INFO(1),K GO TO 99 ENDIF ENDIF IF (ICNTL(5).EQ.0) THEN DO 3 I = 1,M IW(I) = 0 3 CONTINUE DO 6 J = 1,N DO 4 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (I.LT.1 .OR. I.GT.M) THEN INFO(1) = -6 INFO(2) = J IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9006) INFO(1),J,I GO TO 99 ENDIF IF (IW(I).EQ.J) THEN INFO(1) = -7 INFO(2) = J IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9007) INFO(1),J,I GO TO 99 ELSE IW(I) = J ENDIF 4 CONTINUE 6 CONTINUE ENDIF IF (ICNTL(3).GT.0) THEN IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9020) JOB,M,N,NE IF (ICNTL(4).EQ.0) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,min(10,N+1)) WRITE(ICNTL(3),9022) (IRN(K),K=1_8,min(10_8,NE)) IF (JOB.GT.1) WRITE(ICNTL(3),9023) & (A(K),K=1_8,min(10_8,NE)) ELSEIF (ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,N+1) WRITE(ICNTL(3),9022) (IRN(K),K=1_8,NE) IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(K),K=1_8,NE) ENDIF WRITE(ICNTL(3),9024) (ICNTL(J),J=1,NICNTL) WRITE(ICNTL(3),9025) (CNTL(J),J=1,NCNTL) ENDIF ENDIF DO 8 I=1,NINFO INFO(I) = 0 8 CONTINUE IF (JOB.EQ.1) THEN DO 10 J = 1,N IW(J) = int(IP(J+1) - IP(J)) 10 CONTINUE CALL ZMUMPS_MTRANSZ(M,N,IRN,NE,IP,IW(1),PERM,NUM, & IW( int(N,8)+1_8), & IW(2_8*int(N,8)+1_8), & IW(3_8*int(N,8)+1_8), & IW(3_8*int(N,8)+int(M,8)+1_8)) GO TO 90 ENDIF IF (JOB.EQ.2) THEN DW(1) = max(ZERO,CNTL(1)) CALL ZMUMPS_MTRANSB(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IPQ8,IW(int(N,8)+1_8), & IW(int(N,8)+int(M,8)+1_8), & DW,RINF2) GO TO 90 ENDIF IF (JOB.EQ.3) THEN DO 20 K = 1,NE IW(K) = IRN(K) 20 CONTINUE CALL ZMUMPS_MTRANSR(N,NE,IP,IW,A) FACT = max(ZERO,CNTL(1)) CALL ZMUMPS_MTRANSS(M,N,NE,IP,IW(1),A,PERM,NUM,IW(NE+1_8), & IW(NE+int(N,8)+1_8),IW(NE+2_8*int(N,8)+1_8), & IW(NE+3_8*int(N,8)+1_8), & IW(NE+4_8*int(N,8)+1_8), & IW(NE+5_8*int(N,8)+1_8), & IW(NE+5_8*int(N,8)+int(M,8)+1_8), & FACT,RINF2) GO TO 90 ENDIF IF ((JOB.EQ.4).OR.(JOB.EQ.5).or.(JOB.EQ.6)) THEN ALLOCATE(IWtemp8(int(M,8)+int(N,8)+int(N,8)), stat=allocok) IF (allocok.GT.0) THEN INFOMUMPS(1) = -7 CALL MUMPS_SET_IERROR( int(M,8)+int(N,8)+int(N,8), & INFOMUMPS(2) ) GOTO 90 ENDIF ENDIF IF (JOB.EQ.4) THEN DO 50 J = 1,N FACT = ZERO DO 30 K = IP(J),IP(J+1)-1_8 IF (abs(A(K)).GT.FACT) FACT = abs(A(K)) 30 CONTINUE IF(FACT .GT. RINF3) RINF3 = FACT DO 40 K = IP(J),IP(J+1)-1_8 A(K) = FACT - abs(A(K)) 40 CONTINUE 50 CONTINUE DW(1) = max(ZERO,CNTL(1)) DW(2) = RINF3 IWtemp8(1) = int(JOB,8) CALL ZMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(int(N,8)+1_8),IPQ8, & IW(int(N,8)+1_8), & IWtemp8(2_8*int(N,8)+1_8), & DW(1),DW(int(M,8)+1_8),RINF2) DEALLOCATE(IWtemp8) GO TO 90 ENDIF IF (JOB.EQ.5 .or. JOB.EQ.6) THEN RINF3=ONE IF (JOB.EQ.5) THEN DO 75 J = 1,N FACT = ZERO DO 60 K = IP(J),IP(J+1)-1_8 IF (A(K).GT.FACT) FACT = A(K) 60 CONTINUE DW(2_8*int(M,8)+int(J,8)) = FACT IF (FACT.NE.ZERO) THEN FACT = log(FACT) IF(FACT .GT. RINF3) RINF3=FACT DO 70 K = IP(J),IP(J+1)-1_8 IF (A(K).NE.ZERO) THEN A(K) = FACT - log(A(K)) IF(A(K) .GT. RINF3) RINF3=A(K) ELSE A(K) = FACT + RINF ENDIF 70 CONTINUE ELSE DO 71 K = IP(J),IP(J+1)-1_8 A(K) = ONE 71 CONTINUE ENDIF 75 CONTINUE ENDIF IF (JOB.EQ.6) THEN DO 175 K = 1,NE IW(3_8*int(N,8)+2_8*int(M,8)+int(K,8)) = IRN(K) 175 CONTINUE DO 61 I = 1,M DW(2_8*int(M,8)+int(N,8)+int(I,8)) = ZERO 61 CONTINUE DO 63 J = 1,N DO 62 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (A(K).GT.DW(2_8*int(M,8)+int(N,8)+int(I,8))) THEN DW(2_8*int(M,8)+int(N,8)+int(I,8)) = A(K) ENDIF 62 CONTINUE 63 CONTINUE DO 64 I = 1,M IF (DW(2_8*int(M,8)+int(N,8)+int(I,8)).NE.ZERO) THEN DW(2_8*int(M,8)+int(N,8)+int(I,8)) = & 1.0D0/DW(2_8*int(M,8)+int(N,8)+int(I,8)) ENDIF 64 CONTINUE DO 66 J = 1,N DO 65 K = IP(J),IP(J+1)-1 I = IRN(K) A(K) = DW(2_8*int(M,8)+int(N,8)+int(I,8)) * A(K) 65 CONTINUE 66 CONTINUE CALL ZMUMPS_MTRANSR(N,NE,IP, & IW(3_8*int(N,8)+2_8*int(M,8)+1_8),A) DO 176 J = 1,N IF (IP(J).NE.IP(J+1)) THEN FACT = A(IP(J)) ELSE FACT = ZERO ENDIF DW(2_8*int(M,8)+int(J,8)) = FACT IF (FACT.NE.ZERO) THEN FACT = log(FACT) DO 170 K = IP(J),IP(J+1)-1_8 IF (A(K).NE.ZERO) THEN A(K) = FACT - log(A(K)) IF(A(K) .GT. RINF3) RINF3=A(K) ELSE A(K) = FACT + RINF ENDIF 170 CONTINUE ELSE DO 171 K = IP(J),IP(J+1)-1_8 A(K) = ONE 171 CONTINUE ENDIF 176 CONTINUE ENDIF DW(1) = max(ZERO,CNTL(1)) RINF3 = RINF3+ONE DW(2) = RINF3 IWtemp8(1) = int(JOB,8) IF (JOB.EQ.5) THEN CALL ZMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(int(N,8)+1_8),IPQ8, & IW(int(N,8)+1_8), & IWtemp8(2_8*int(N,8)+1_8), & DW(1),DW(int(M,8)+1_8),RINF2) ENDIF IF (JOB.EQ.6) THEN CALL ZMUMPS_MTRANSW(M,N,NE,IP, & IW(3_8*int(N,8)+2_8*int(M,8)+1_8),A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(int(N,8)+1_8),IPQ8, & IW(int(N,8)+1_8), & IWtemp8(2_8*int(N,8)+1_8), & DW(1),DW(int(M,8)+1_8),RINF2) ENDIF IF ((JOB.EQ.5).or.(JOB.EQ.6)) THEN DEALLOCATE(IWtemp8) ENDIF IF (JOB.EQ.6) THEN DO 79 I = 1,M IF (DW(2_8*int(M,8)+int(N,8)+int(I,8)).NE.0.0D0) THEN DW(I) = DW(I) + log(DW(2_8*int(M,8)+int(N,8)+int(I,8))) ENDIF 79 CONTINUE ENDIF IF (NUM.EQ.N) THEN DO 80 J = 1,N IF (DW(2_8*int(M,8)+int(J,8)).NE.ZERO) THEN DW(int(M,8)+int(J,8)) = DW(int(M,8)+int(J,8)) - & log(DW(2_8*int(M,8)+int(J,8))) ELSE DW(int(M,8)+int(J,8)) = ZERO ENDIF 80 CONTINUE ENDIF FACT = 0.5D0*log(RINF2) DO 86 I = 1,M IF (DW(I).LT.FACT) GO TO 86 WARN2 = 2 GO TO 90 86 CONTINUE DO 87 J = 1,N IF (DW(M+J).LT.FACT) GO TO 87 WARN2 = 2 GO TO 90 87 CONTINUE ENDIF 90 IF (INFOMUMPS(1).LT.0) RETURN IF (NUM.LT.N) WARN1 = 1 IF (JOB.EQ.4 .OR. JOB.EQ.5 .OR. JOB.EQ.6) THEN IF (CNTL(1).LT.ZERO) WARN4 = 4 ENDIF IF (INFO(1).EQ.0) THEN INFO(1) = WARN1 + WARN2 + WARN4 IF (INFO(1).GT.0 .AND. ICNTL(2).GT.0) THEN WRITE(ICNTL(2),9010) INFO(1) IF (WARN1.EQ.1) WRITE(ICNTL(2),9011) IF (WARN2.EQ.2) WRITE(ICNTL(2),9012) IF (WARN4.EQ.4) WRITE(ICNTL(2),9014) ENDIF ENDIF IF (ICNTL(3).GE.0) THEN IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9030) (INFO(J),J=1,2) WRITE(ICNTL(3),9031) NUM IF (ICNTL(4).EQ.0) THEN WRITE(ICNTL(3),9032) (PERM(J),J=1,min(10,M)) IF (JOB.EQ.5 .OR. JOB.EQ.6) THEN WRITE(ICNTL(3),9033) (DW(J),J=1,min(10,M)) WRITE(ICNTL(3),9034) (DW(int(M,8)+int(J,8)), & 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(int(M,8)+int(J,8)), & J=1,N) ENDIF ENDIF ENDIF ENDIF 99 RETURN 9001 FORMAT (' ****** Error in ZMUMPS_MTRANSA. INFO(1) = ',I2, & ' because ',(A),' = ',I14) 9004 FORMAT (' ****** Error in ZMUMPS_MTRANSA. INFO(1) = ',I2/ & ' LIW too small, must be at least ',I14) 9005 FORMAT (' ****** Error in ZMUMPS_MTRANSA. INFO(1) = ',I2/ & ' LDW too small, must be at least ',I14) 9006 FORMAT (' ****** Error in ZMUMPS_MTRANSA. INFO(1) = ',I2/ & ' Column ',I8, & ' contains an entry with invalid row index ',I8) 9007 FORMAT (' ****** Error in ZMUMPS_MTRANSA. INFO(1) = ',I2/ & ' Column ',I8, & ' contains two or more entries with row index ',I8) 9010 FORMAT (' ****** Warning from ZMUMPS_MTRANSA. INFO(1) = ',I2) 9011 FORMAT (' - The matrix is structurally singular.') 9012 FORMAT (' - Some scaling factors may be too large.') 9014 FORMAT (' - CNTL(1) is negative and was treated as zero.') 9020 FORMAT (' ****** Input parameters for ZMUMPS_MTRANSA:'/ & ' JOB =',I10/' M =',I10/' N =',I10/' NE =',I14) 9021 FORMAT (' IP(1:N+1) = ',8I8/(15X,8I8)) 9022 FORMAT (' IRN(1:NE) = ',8I8/(15X,8I8)) 9023 FORMAT (' A(1:NE) = ',4(1PD14.4)/(15X,4(1PD14.4))) 9024 FORMAT (' ICNTL(1:10) = ',8I8/(15X,2I8)) 9025 FORMAT (' CNTL(1:10) = ',4(1PD14.4)/(15X,4(1PD14.4))) 9030 FORMAT (' ****** Output parameters for ZMUMPS_MTRANSA:'/ & ' INFO(1:2) = ',2I8) 9031 FORMAT (' NUM = ',I8) 9032 FORMAT (' PERM(1:M) = ',8I8/(15X,8I8)) 9033 FORMAT (' DW(1:M) = ',5(F11.3)/(15X,5(F11.3))) 9034 FORMAT (' DW(M+1:M+N) = ',5(F11.3)/(15X,5(F11.3))) END SUBROUTINE ZMUMPS_MTRANS_DRIVER SUBROUTINE ZMUMPS_SUPPRESS_DUPPLI_VAL(N,NZ,IP,IRN,A,FLAG,POSI) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(INOUT) :: NZ INTEGER(8), INTENT(INOUT) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NZ) DOUBLE PRECISION, INTENT(INOUT) :: A(NZ) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER(8), INTENT(OUT) :: POSI(N) INTEGER :: ROW, COL INTEGER(8) :: K, WR_POS, BEG_COL, SV_POS FLAG = 0 WR_POS = 1_8 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1_8 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW A(WR_POS) = A(K) FLAG(ROW) = COL POSI(ROW) = WR_POS WR_POS = WR_POS+1 ELSE SV_POS = POSI(ROW) A(SV_POS) = A(SV_POS) + A(K) ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1_8 RETURN END SUBROUTINE ZMUMPS_SUPPRESS_DUPPLI_VAL SUBROUTINE ZMUMPS_SUPPRESS_DUPPLI_STR(N,NZ,IP,IRN,FLAG) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(INOUT) :: NZ INTEGER(8), INTENT(INOUT) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NZ) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER :: ROW, COL INTEGER(8) :: K, WR_POS, BEG_COL FLAG = 0 WR_POS = 1_8 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1_8 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW FLAG(ROW) = COL WR_POS = WR_POS+1_8 ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1_8 RETURN END SUBROUTINE ZMUMPS_SUPPRESS_DUPPLI_STR SUBROUTINE ZMUMPS_SORT_PERM( N, NA, LNA, NE_STEPS, & PERM, FILS, & DAD_STEPS, STEP, NSTEPS, & KEEP60, KEEP20, KEEP38, & INFO) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA INTEGER, INTENT(IN) :: FILS( N ), STEP(N), NA(LNA) INTEGER, INTENT(IN) :: DAD_STEPS ( NSTEPS ), NE_STEPS (NSTEPS) INTEGER, INTENT(IN) :: KEEP60, KEEP20, KEEP38 INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(OUT) :: PERM( N ) INTEGER :: IPERM, INODE, IN, ISCHUR INTEGER :: INBLEAF, INBROOT, allocok INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, NSTK INBLEAF = NA(1) INBROOT = NA(2) ALLOCATE(POOL(INBLEAF), NSTK(NSTEPS), stat=allocok) IF (allocok > 0 ) THEN INFO(1) = -7 INFO(2) = INBLEAF + NSTEPS RETURN ENDIF POOL(1:INBLEAF) = NA(3:2+INBLEAF) NSTK(1:NSTEPS) = NE_STEPS(1:NSTEPS) ISCHUR = 0 IF ( KEEP60.GT.0 ) THEN ISCHUR = max (KEEP20, KEEP38) ENDIF IPERM = 1 DO WHILE ( INBLEAF .NE. 0 ) INODE = POOL( INBLEAF ) INBLEAF = INBLEAF - 1 IN = INODE IF (INODE.NE.ISCHUR) THEN DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO ENDIF IN = DAD_STEPS(STEP( INODE )) IF ( IN .eq. 0 ) THEN INBROOT = INBROOT - 1 ELSE NSTK( STEP(IN) ) = NSTK( STEP(IN) ) - 1 IF ( NSTK( STEP(IN) ) .eq. 0 ) THEN INBLEAF = INBLEAF + 1 POOL( INBLEAF ) = IN END IF END IF END DO IF (IPERM.LE.N) THEN IF (ISCHUR.GT.0) THEN IN = ISCHUR DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO ENDIF ENDIF DEALLOCATE(POOL, NSTK) RETURN END SUBROUTINE ZMUMPS_SORT_PERM SUBROUTINE ZMUMPS_EXPAND_TREE_STEPS( ICNTL, & N, NBLK, BLKPTR, BLKVAR, & FILS_OLD, FILS_NEW, NSTEPS, & STEP_OLD, STEP_NEW, PAR2_NODES, NB_NIV2, & DAD_STEPS, FRERE_STEPS, & NA, LNA, & LRGROUPS_OLD, SIZELRGROUPS_OLD, & LRGROUPS_NEW, SIZELRGROUPS_NEW, & K20, K38, K494 & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NBLK, ICNTL(60), NSTEPS, LNA, & NB_NIV2, K494 INTEGER, INTENT(IN) :: BLKPTR(NBLK+1), BLKVAR(N) INTEGER, INTENT(IN) :: SIZELRGROUPS_OLD, SIZELRGROUPS_NEW INTEGER, INTENT(IN) :: FILS_OLD(NBLK), STEP_OLD(NBLK), & LRGROUPS_OLD(SIZELRGROUPS_OLD) INTEGER, INTENT(INOUT) :: DAD_STEPS(NSTEPS), FRERE_STEPS(NSTEPS) INTEGER, INTENT(INOUT) :: NA(LNA), PAR2_NODES(NB_NIV2), K20,K38 INTEGER, INTENT(OUT) :: FILS_NEW(N), STEP_NEW(N), & LRGROUPS_NEW(SIZELRGROUPS_NEW) INTEGER :: IB, I, IBFS, IBNB, IFS, INB INTEGER NBLEAF, NBROOT, ISTEP, IGROUP INTEGER :: II IF (K20.GT.0) K20 = BLKVAR(BLKPTR(K20)) IF (K38.GT.0) K38 = BLKVAR(BLKPTR(K38)) NBLEAF = NA(1) NBROOT = NA(2) IF (NBLK.GT.1) THEN DO I= 3, 3+NBLEAF+NBROOT-1 IBNB = NA(I) INB = BLKVAR(BLKPTR(IBNB)) NA(I) = INB ENDDO ENDIF IF (PAR2_NODES(1).GT.0) THEN DO I=1, NB_NIV2 IBNB = PAR2_NODES(I) INB = BLKVAR(BLKPTR(IBNB)) PAR2_NODES(I) = INB ENDDO ENDIF DO I= 1, NSTEPS IBNB = DAD_STEPS(I) IF (IBNB.EQ.0) THEN INB = 0 ELSE INB = BLKVAR(BLKPTR(IBNB)) ENDIF DAD_STEPS(I) = INB ENDDO DO I= 1, NSTEPS IBNB = FRERE_STEPS(I) IF (IBNB.EQ.0) THEN INB = 0 ELSE INB = BLKVAR(BLKPTR(abs(IBNB))) IF (IBNB.LT.0) INB=-INB ENDIF FRERE_STEPS(I) = INB ENDDO DO IB=1, NBLK IBFS = FILS_OLD(IB) IF (IBFS.EQ.0) THEN IFS = 0 ELSE IFS = BLKVAR(BLKPTR(abs(IBFS))) IF (IBFS.LT.0) IFS=-IFS ENDIF IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE DO II=BLKPTR(IB), BLKPTR(IB+1)-1 IF (II.LT. BLKPTR(IB+1)-1) THEN FILS_NEW(BLKVAR(II))= BLKVAR(II+1) ELSE FILS_NEW(BLKVAR(II))= IFS ENDIF ENDDO ENDDO DO IB=1, NBLK ISTEP = STEP_OLD(IB) IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE IF (ISTEP.LT.0) THEN DO II=BLKPTR(IB), BLKPTR(IB+1)-1 STEP_NEW(BLKVAR(II)) = ISTEP ENDDO ELSE I = BLKVAR(BLKPTR(IB)) STEP_NEW(I) = ISTEP DO II=BLKPTR(IB)+1, BLKPTR(IB+1)-1 STEP_NEW(BLKVAR(II)) = -ISTEP ENDDO ENDIF ENDDO IF (K494.NE.0) THEN DO IB=1, NBLK IGROUP = LRGROUPS_OLD(IB) IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE DO II=BLKPTR(IB), BLKPTR(IB+1)-1 LRGROUPS_NEW(BLKVAR(II)) = IGROUP ENDDO ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_EXPAND_TREE_STEPS SUBROUTINE ZMUMPS_DIST_AVOID_COPIES(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,PEAK,IERR & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) USE MUMPS_STATIC_MAPPING IMPLICIT NONE INTEGER N, NSLAVES, NBSA, IERR INTEGER ICNTL(60),INFOG(80),KEEP(500) INTEGER(8) KEEP8(150) INTEGER NE(N),NFSIZ(N),FRERE(N),FILS(N),PROCNODE(N) INTEGER SSARBR(N) DOUBLE PRECISION PEAK INTEGER, intent(IN) :: LSIZEOFBLOCKS INTEGER, intent(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) CALL MUMPS_SET_K78_83_91 (NSLAVES,KEEP(78),KEEP(83),KEEP(91)) CALL MUMPS_DISTRIBUTE(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,dble(PEAK),IERR & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) RETURN END SUBROUTINE ZMUMPS_DIST_AVOID_COPIES SUBROUTINE ZMUMPS_SET_PROCNODE(INODE, PROCNODE, VALUE, FILS, N) INTEGER, intent(in) :: INODE, N, VALUE INTEGER, intent(in) :: FILS(N) INTEGER, intent(inout) :: PROCNODE(N) INTEGER IN IN=INODE DO WHILE ( IN > 0 ) PROCNODE( IN ) = VALUE IN=FILS( IN ) ENDDO RETURN END SUBROUTINE ZMUMPS_SET_PROCNODE MUMPS_5.8.1/src/mumps_metis64.h0000664000175000017500000000441115042446422016115 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_METIS64_H #define MUMPS_METIS64_H /* Interfacing with 64-bit (par)metis, for METIS 4 or METIS 5 */ #include "mumps_common.h" /* includes mumps_compat.h and mumps_c_types.h */ #if defined(parmetis) || defined(parmetis3) #include "mpi.h" #define MUMPS_PARMETIS_64 \ F_SYMBOL(parmetis_64,PARMETIS_64) void MUMPS_CALL MUMPS_PARMETIS_64(MUMPS_INT8 *first, MUMPS_INT8 *vertloctab, MUMPS_INT8 *edgeloctab, #if defined(parmetis3) MUMPS_INT *numflag, MUMPS_INT *options, #else MUMPS_INT8 *numflag, MUMPS_INT8 *options, #endif MUMPS_INT8 *order, MUMPS_INT8 *sizes, MUMPS_INT *comm, MUMPS_INT *ierr); #define MUMPS_PARMETIS_VWGT_64 \ F_SYMBOL(parmetis_vwgt_64,PARMETIS_VWGT_64) void MUMPS_CALL MUMPS_PARMETIS_VWGT_64(MUMPS_INT8 *first, MUMPS_INT8 *vertloctab, MUMPS_INT8 *edgeloctab, #if defined(parmetis3) MUMPS_INT *numflag, MUMPS_INT *options, #else MUMPS_INT8 *numflag, MUMPS_INT8 *options, #endif MUMPS_INT8 *order, MUMPS_INT8 *sizes, MUMPS_INT *comm, MUMPS_INT8 *vwgt, MUMPS_INT *ierr); #endif #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) #define MUMPS_METIS_KWAY_64 \ F_SYMBOL(metis_kway_64,METIS_KWAY_64) void MUMPS_CALL MUMPS_METIS_KWAY_64(MUMPS_INT8 *n, MUMPS_INT8 *iptr, MUMPS_INT8 *jcn, MUMPS_INT8 *k, MUMPS_INT8 *part); #define MUMPS_METIS_KWAY_AB_64 \ F_SYMBOL(metis_kway_ab_64,METIS_KWAY_AB_64) void MUMPS_CALL MUMPS_METIS_KWAY_AB_64(MUMPS_INT8 *n, MUMPS_INT8 *iptr, MUMPS_INT8 *jcn, MUMPS_INT8 *k, MUMPS_INT8 *part, MUMPS_INT8 *vwgt); #endif #endif MUMPS_5.8.1/src/smumps_lr_data_m.F0000664000175000017500000036711415042446437016707 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_LR_DATA_M USE SMUMPS_LR_TYPE IMPLICIT NONE PRIVATE PUBLIC :: SMUMPS_BLR_END_FRONT, SMUMPS_BLR_INIT_MODULE, & SMUMPS_BLR_END_MODULE, SMUMPS_BLR_INIT_FRONT, & SMUMPS_BLR_SAVE_INIT, & SMUMPS_BLR_SAVE_PANEL_LORU, SMUMPS_BLR_RETRIEVE_BEGS_BLR_L, & SMUMPS_BLR_SAVE_BEGS_BLR_C, SMUMPS_BLR_RETRIEVE_BEGS_BLR_C, & SMUMPS_BLR_DEC_AND_RETRIEVE_L, SMUMPS_BLR_RETRIEVE_PANEL_LORU, & SMUMPS_BLR_DEC_AND_TRYFREE_L, SMUMPS_BLR_TRY_FREE_PANEL, & SMUMPS_BLR_FORCE_FREE_PANEL_L, & SMUMPS_BLR_FREE_CB_LRB, SMUMPS_BLR_FREE_ALL_PANELS, & SMUMPS_BLR_SAVE_CB_LRB, & SMUMPS_BLR_RETRIEVE_CB_LRB, SMUMPS_BLR_RETRIEVE_BEGSBLR_STA, & SMUMPS_BLR_SAVE_BEGS_BLR_DYN, SMUMPS_BLR_RETRIEVE_BEGSBLR_DYN, & SMUMPS_BLR_RETRIEVE_NB_PANELS, SMUMPS_BLR_EMPTY_PANEL_LORU, & SMUMPS_BLR_SAVE_NFS4FATHER, SMUMPS_BLR_RETRIEVE_NFS4FATHER, & SMUMPS_BLR_SAVE_M_ARRAY, SMUMPS_BLR_RETRIEVE_M_ARRAY, & SMUMPS_BLR_FREE_M_ARRAY & , SMUMPS_BLR_STRUC_TO_MOD, SMUMPS_BLR_MOD_TO_STRUC, BLR_ARRAY #if defined(MUMPS_NOF2003) & , BLR_STRUC_T, blr_panel_type, diag_block_type #endif & , SMUMPS_BLR_SAVE_DIAG_BLOCK, SMUMPS_BLR_RETRIEVE_DIAG_BLOCK #if ! defined(NO_SAVE_RESTORE) & , SMUMPS_SAVE_RESTORE_BLR #endif TYPE blr_panel_type integer :: NB_ACCESSES_LEFT type(LRB_TYPE), pointer :: LRB_PANEL(:) END TYPE blr_panel_type TYPE diag_block_type REAL, POINTER :: DIAG_BLOCK(:) END TYPE diag_block_type TYPE BLR_STRUC_T LOGICAL :: IsSYM, IsT2, IsSLAVE TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_L TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_U TYPE(LRB_TYPE), pointer :: CB_LRB(:,:) TYPE(diag_block_type), DIMENSION (:), POINTER :: DIAG_BLOCKS INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_STATIC INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_DYNAMIC INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: NB_ACCESSES_INIT INTEGER :: NB_PANELS INTEGER :: NFS4FATHER REAL, DIMENSION(:), POINTER :: M_ARRAY END TYPE BLR_STRUC_T type(BLR_STRUC_T), POINTER, DIMENSION(:), SAVE :: BLR_ARRAY TYPE BLR_ARRAY_T type(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY END TYPE BLR_ARRAY_T INTEGER BLR_ARRAY_FREE, PANELS_NOTUSED, PANELS_FREED, & NB_PANELS_NOTINIT, NFS4FATHER_NOTINIT PARAMETER (BLR_ARRAY_FREE=-9999, & PANELS_NOTUSED=-1111, PANELS_FREED=-2222, & NB_PANELS_NOTINIT=-3333, & NFS4FATHER_NOTINIT=-4444 ) #if ! defined(NO_SAVE_RESTORE) INCLUDE 'mumps_save_restore_modes.h' #endif CONTAINS SUBROUTINE SMUMPS_BLR_INIT_MODULE(INITIAL_SIZE, INFO & ) INTEGER, INTENT(IN) :: INITIAL_SIZE INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR ALLOCATE(BLR_ARRAY( INITIAL_SIZE ), stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=INITIAL_SIZE RETURN ENDIF DO I=1, INITIAL_SIZE NULLIFY(BLR_ARRAY(I)%PANELS_L) NULLIFY(BLR_ARRAY(I)%PANELS_U) NULLIFY(BLR_ARRAY(I)%CB_LRB) NULLIFY(BLR_ARRAY(I)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_DYNAMIC) BLR_ARRAY(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY(I)%NB_PANELS = NB_PANELS_NOTINIT NULLIFY(BLR_ARRAY(I)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_COL) BLR_ARRAY(I)%NFS4FATHER = NFS4FATHER_NOTINIT NULLIFY(BLR_ARRAY(I)%M_ARRAY) ENDDO RETURN END SUBROUTINE SMUMPS_BLR_INIT_MODULE SUBROUTINE SMUMPS_BLR_END_MODULE(INFO1, KEEP8, K34 & , LRSOLVE_ACT_OPT & ) INTEGER, INTENT(IN) :: INFO1, K34 LOGICAL, OPTIONAL, INTENT(IN) :: LRSOLVE_ACT_OPT INTEGER(8) :: KEEP8(150) INTEGER :: I, ILOOP IF (.NOT. associated(BLR_ARRAY)) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_END_MODULE" CALL MUMPS_ABORT() ENDIF DO I=1, size(BLR_ARRAY) ILOOP= I IF (associated(BLR_ARRAY(I)%PANELS_L).OR. & associated(BLR_ARRAY(I)%PANELS_U).OR. & associated(BLR_ARRAY(I)%CB_LRB).OR. & associated(BLR_ARRAY(I)%DIAG_BLOCKS) & ) THEN IF (present(LRSOLVE_ACT_OPT)) THEN CALL SMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8, K34 & , LRSOLVE_ACT_OPT & ) ELSE CALL SMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8, K34 ) ENDIF ENDIF ENDDO DEALLOCATE(BLR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE SMUMPS_BLR_END_MODULE SUBROUTINE SMUMPS_BLR_MOD_TO_STRUC(id_BLRARRAY_ENCODING) # if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING # else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING # endif CHARACTER :: CHAR_ARRAY(1) INTEGER :: CHAR_LENGTH, IERR TYPE(BLR_ARRAY_T) :: BLR_ARRAY_VAR IF (associated(id_BLRARRAY_ENCODING)) THEN WRITE(*,*) "Internal error 1 in MUMPS_BLR_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF BLR_ARRAY_VAR%BLR_ARRAY => BLR_ARRAY CHAR_LENGTH=size(transfer(BLR_ARRAY_VAR,CHAR_ARRAY)) ALLOCATE(id_BLRARRAY_ENCODING(CHAR_LENGTH), stat=IERR) IF (IERR > 0 ) THEN WRITE(*,*) "Allocation error in MUMPS_BLR_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF id_BLRARRAY_ENCODING=transfer(BLR_ARRAY_VAR,CHAR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE SMUMPS_BLR_MOD_TO_STRUC SUBROUTINE SMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) # if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING # else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING # endif TYPE (BLR_ARRAY_T) :: BLR_ARRAY_VAR IF (.NOT.associated(id_BLRARRAY_ENCODING)) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_STRUC_TO_MOD" ENDIF BLR_ARRAY_VAR = transfer(id_BLRARRAY_ENCODING,BLR_ARRAY_VAR) BLR_ARRAY => BLR_ARRAY_VAR%BLR_ARRAY DEALLOCATE(id_BLRARRAY_ENCODING) NULLIFY(id_BLRARRAY_ENCODING) RETURN END SUBROUTINE SMUMPS_BLR_STRUC_TO_MOD SUBROUTINE SMUMPS_BLR_INIT_FRONT(IWHANDLER, & INFO, MTK405) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX !$ USE OMP_LIB INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) INTEGER, INTENT(IN), OPTIONAL :: MTK405 TYPE(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY_TMP INTEGER :: OLD_SIZE, NEW_SIZE INTEGER :: I INTEGER :: IERR LOGICAL :: NEEDS_THREAD_SAFETY NEEDS_THREAD_SAFETY = .FALSE. IF (present(MTK405)) THEN IF (MTK405 .EQ. 1 ) THEN NEEDS_THREAD_SAFETY = .TRUE. ENDIF ENDIF IF ( NEEDS_THREAD_SAFETY ) THEN !$OMP CRITICAL(critical_blr_idx) CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) !$OMP END CRITICAL(critical_blr_idx) ELSE CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) ENDIF IF (IWHANDLER > size(BLR_ARRAY)) THEN OLD_SIZE = size(BLR_ARRAY) NEW_SIZE = max( (OLD_SIZE * 3) / 2 + 1, IWHANDLER) ALLOCATE(BLR_ARRAY_TMP(NEW_SIZE),stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=NEW_SIZE GOTO 500 ENDIF DO I=1, OLD_SIZE BLR_ARRAY_TMP(I)=BLR_ARRAY(I) ENDDO DO I=OLD_SIZE+1, NEW_SIZE NULLIFY(BLR_ARRAY_TMP(I)%PANELS_L) NULLIFY(BLR_ARRAY_TMP(I)%PANELS_U) NULLIFY(BLR_ARRAY_TMP(I)%CB_LRB) NULLIFY(BLR_ARRAY_TMP(I)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_DYNAMIC) BLR_ARRAY_TMP(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY_TMP(I)%NB_PANELS = NB_PANELS_NOTINIT NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_L) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_COL) BLR_ARRAY_TMP(I)%NFS4FATHER = NFS4FATHER_NOTINIT NULLIFY(BLR_ARRAY_TMP(I)%M_ARRAY) ENDDO DEALLOCATE(BLR_ARRAY) BLR_ARRAY => BLR_ARRAY_TMP NULLIFY(BLR_ARRAY_TMP) 500 CONTINUE ENDIF RETURN END SUBROUTINE SMUMPS_BLR_INIT_FRONT SUBROUTINE SMUMPS_BLR_SAVE_INIT(IWHANDLER, & IsSYM, IsT2, IsSLAVE, & NB_PANELS, & BEGS_BLR_L, BEGS_BLR_COL, & NB_ACCESSES_INIT, INFO) LOGICAL, INTENT(IN) :: IsSYM, IsT2, IsSLAVE INTEGER, INTENT(IN) :: NB_PANELS, IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: NB_ACCESSES_INIT INTEGER, INTENT(IN), DIMENSION(:) :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: I INTEGER :: IERR IF (NB_PANELS.EQ.0) THEN WRITE(6,*) " Internal error 1 in SMUMPS_BLR_SAVE_INIT ", & NB_PANELS ENDIF IF (IWHANDLER .LE.0 ) THEN WRITE(6,*) " Internal error 2 in SMUMPS_BLR_SAVE_INIT ", & IWHANDLER ENDIF IF (associated(BEGS_BLR_COL)) THEN ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=size(BEGS_BLR_COL) RETURN ENDIF ENDIF IF (NB_ACCESSES_INIT.EQ.0) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=3*size(BEGS_BLR_L) RETURN ENDIF ELSE IF (IsSYM) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & stat=IERR) ELSE ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%PANELS_U(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & stat=IERR) ENDIF IF (IERR .GT. 0) THEN INFO(1)=-13 IF (IsSYM) THEN INFO(2)=NB_PANELS+3*size(BEGS_BLR_L) ELSE INFO(2)=NB_PANELS+NB_PANELS+3*size(BEGS_BLR_L) ENDIF RETURN ENDIF IF (.NOT.IsSLAVE) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(NB_PANELS), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=NB_PANELS RETURN ENDIF ENDIF DO I=1,NB_PANELS NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L(I)%LRB_PANEL) IF (.NOT.IsSYM) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U(I)%LRB_PANEL) ENDIF IF (.NOT.IsSLAVE) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(I)%DIAG_BLOCK) ENDIF ENDDO ENDIF BLR_ARRAY(IWHANDLER)%IsSYM = IsSYM BLR_ARRAY(IWHANDLER)%IsT2 = IsT2 BLR_ARRAY(IWHANDLER)%IsSLAVE = IsSLAVE BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS BLR_ARRAY(IWHANDLER)%BEGS_BLR_L = BEGS_BLR_L BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC = BEGS_BLR_L BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC = -999991 IF (NB_ACCESSES_INIT.EQ.0) THEN BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = PANELS_NOTUSED ELSE BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = NB_ACCESSES_INIT ENDIF IF (associated(BEGS_BLR_COL)) THEN DO I=1,size(BEGS_BLR_COL) BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) ENDDO ELSE NULLIFY( BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL ) ENDIF RETURN END SUBROUTINE SMUMPS_BLR_SAVE_INIT SUBROUTINE SMUMPS_BLR_END_FRONT(IWHANDLER, INFO1, KEEP8, K34 & , LRSOLVE_ACT_OPT, MTK405 ) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX INTEGER, INTENT(INOUT) :: IWHANDLER INTEGER, INTENT(IN) :: INFO1 INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: K34 LOGICAL, OPTIONAL, INTENT(IN) :: LRSOLVE_ACT_OPT INTEGER, OPTIONAL, INTENT(IN) :: MTK405 INTEGER :: IPANEL, JPANEL INTEGER(8) :: MEM_FREED INTEGER :: IDUMMY, JDUMMY TYPE(blr_panel_type), POINTER :: THEPANEL LOGICAL :: LRSOLVE_ACT, NEEDS_THREAD_SAFETY TYPE(diag_block_type), POINTER :: THEBLOCK LRSOLVE_ACT = .FALSE. IF (present(LRSOLVE_ACT_OPT)) LRSOLVE_ACT = LRSOLVE_ACT_OPT IF (IWHANDLER.LE.0) THEN RETURN ENDIF NEEDS_THREAD_SAFETY = .FALSE. IF (present(MTK405)) THEN IF (MTK405 .EQ. 1 ) THEN NEEDS_THREAD_SAFETY = .TRUE. ENDIF ENDIF IF (IWHANDLER .GT. size(BLR_ARRAY)) THEN RETURN END IF IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ.BLR_ARRAY_FREE) & RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.NE. & PANELS_NOTUSED) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 2a in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated", & " NB_ACCESSES_LEFT= ",THEPANEL%NB_ACCESSES_LEFT CALL MUMPS_ABORT() ELSE CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDDO IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 2b in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated" CALL MUMPS_ABORT() ELSE CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDDO IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN MEM_FREED = 0_8 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) THEBLOCK => BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL) IF (associated(THEBLOCK%DIAG_BLOCK)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 3 in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated" CALL MUMPS_ABORT() ENDIF MEM_FREED = MEM_FREED + int(size(THEBLOCK%DIAG_BLOCK),8) DEALLOCATE (THEBLOCK%DIAG_BLOCK) NULLIFY (THEBLOCK%DIAG_BLOCK) ENDIF ENDDO IF ( MEM_FREED .GT. 0_8 ) THEN CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-MEM_FREED, & NEEDS_THREAD_SAFETY, KEEP8, & IDUMMY, JDUMMY, & .TRUE., .TRUE.) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsT2.OR. & BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN IF (associated(BLR_ARRAY(IWHANDLER)%CB_LRB)) THEN IF (INFO1 .GE. 0) THEN WRITE(*,*) & " Internal Error 4 in MUMPS_BLR_END_FRONT ", & IWHANDLER, "CB block still associated", & BLR_ARRAY(IWHANDLER)%IsT2, & BLR_ARRAY(IWHANDLER)%IsSLAVE CALL MUMPS_ABORT() ELSE DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%CB_LRB,1) DO JPANEL = 1, size(BLR_ARRAY(IWHANDLER)%CB_LRB,2) CALL DEALLOC_LRB( & BLR_ARRAY(IWHANDLER)%CB_LRB(IPANEL,JPANEL), & KEEP8, K34) ENDDO ENDDO DEALLOCATE(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) ENDIF ENDIF ENDIF ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) ENDIF BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS_NOTINIT BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER_NOTINIT IF (associated(BLR_ARRAY(IWHANDLER)%M_ARRAY)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY) NULLIFY(BLR_ARRAY(IWHANDLER)%M_ARRAY) ENDIF IF (NEEDS_THREAD_SAFETY) THEN !$OMP CRITICAL(critical_blr_idx) CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) !$OMP END CRITICAL(critical_blr_idx) ELSE CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) ENDIF RETURN END SUBROUTINE SMUMPS_BLR_END_FRONT SUBROUTINE SMUMPS_BLR_SAVE_PANEL_LORU ( & IWHANDLER, LORU, IPANEL, LRB_PANEL, NB_ACCESSES_INIT_IN ) type(LRB_TYPE), DIMENSION(:), pointer :: LRB_PANEL INTEGER, INTENT(IN) :: IWHANDLER, IPANEL, NB_ACCESSES_INIT_IN INTEGER, INTENT(IN) :: LORU TYPE(blr_panel_type), POINTER :: THEPANEL IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_SAVE_PANEL_LORU" CALL MUMPS_ABORT() ENDIF IF (LORU.EQ.0) THEN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) ELSE THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) ENDIF IF (NB_ACCESSES_INIT_IN.GT.0) THEN THEPANEL%NB_ACCESSES_LEFT = NB_ACCESSES_INIT_IN ELSE THEPANEL%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT ENDIF THEPANEL%LRB_PANEL => LRB_PANEL RETURN END SUBROUTINE SMUMPS_BLR_SAVE_PANEL_LORU SUBROUTINE SMUMPS_BLR_SAVE_CB_LRB ( & IWHANDLER, CB_LRB ) #if defined(MUMPS_NOF2003) TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) #else TYPE(LRB_TYPE), POINTER, INTENT(IN) :: CB_LRB(:,:) #endif INTEGER, INTENT(IN) :: IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_SAVE_CB_LRB" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%CB_LRB => CB_LRB RETURN END SUBROUTINE SMUMPS_BLR_SAVE_CB_LRB SUBROUTINE SMUMPS_BLR_SAVE_DIAG_BLOCK ( & IWHANDLER, IPANEL, D, KEEP34 ) use iso_c_binding REAL,POINTER :: D(:) INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER, INTENT(IN) :: KEEP34 IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_SAVE_DIAG_BLOCK" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in SMUMPS_BLR_SAVE_DIAG_BLOCK" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK => D RETURN END SUBROUTINE SMUMPS_BLR_SAVE_DIAG_BLOCK SUBROUTINE SMUMPS_BLR_SAVE_BEGS_BLR_C ( & IWHANDLER, BEGS_BLR_COL, INFO) INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_SAVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in SMUMPS_BLR_SAVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF ALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=size(BEGS_BLR_COL) RETURN ENDIF DO I=1,size(BEGS_BLR_COL) BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) ENDDO RETURN END SUBROUTINE SMUMPS_BLR_SAVE_BEGS_BLR_C SUBROUTINE SMUMPS_BLR_SAVE_BEGS_BLR_DYN ( & IWHANDLER, BEGS_BLR_DYNAMIC ) INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_DYNAMIC INTEGER, INTENT(IN) :: IWHANDLER INTEGER :: I IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_SAVE_BEGS_BLR_DYN" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in SMUMPS_BLR_SAVE_BEGS_BLR_DYN" CALL MUMPS_ABORT() ENDIF DO I=1,size(BEGS_BLR_DYNAMIC) BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(I) = BEGS_BLR_DYNAMIC(I) ENDDO RETURN END SUBROUTINE SMUMPS_BLR_SAVE_BEGS_BLR_DYN SUBROUTINE SMUMPS_BLR_RETRIEVE_BEGS_BLR_L & ( IWHANDLER, BEGS_BLR_L ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_BEGS_BLR_L" CALL MUMPS_ABORT() ENDIF BEGS_BLR_L => BLR_ARRAY(IWHANDLER)%BEGS_BLR_L RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_BEGS_BLR_L SUBROUTINE SMUMPS_BLR_RETRIEVE_BEGSBLR_STA & ( IWHANDLER, BEGS_BLR_STATIC ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_STATIC #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_BEGSBLR_STA" CALL MUMPS_ABORT() ENDIF BEGS_BLR_STATIC => BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_BEGSBLR_STA SUBROUTINE SMUMPS_BLR_RETRIEVE_BEGSBLR_DYN & ( IWHANDLER, BEGS_BLR_DYNAMIC ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_DYNAMIC #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_DYNAMIC #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_BEGSBLR_DYN" CALL MUMPS_ABORT() ENDIF BEGS_BLR_DYNAMIC => BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_BEGSBLR_DYN SUBROUTINE SMUMPS_BLR_RETRIEVE_BEGS_BLR_C & ( IWHANDLER, BEGS_BLR_COL, NB_PANELS ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NB_PANELS #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_COL #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_COL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF BEGS_BLR_COL => BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_BEGS_BLR_C SUBROUTINE SMUMPS_BLR_RETRIEVE_NB_PANELS & ( IWHANDLER, NB_PANELS ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NB_PANELS IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_NB_PANELS" CALL MUMPS_ABORT() ENDIF NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_NB_PANELS SUBROUTINE SMUMPS_BLR_DEC_AND_RETRIEVE_L(IWHANDLER, IPANEL, & BEGS_BLR_L, THELRBPANEL, & NBDEC ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: IPANEL, NBDEC #if defined(MUMPS_NOF2003) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL #else INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) "Internal error 2 in SMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) "Internal error 3 in SMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_L( IWHANDLER, BEGS_BLR_L ) THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - NBDEC RETURN END SUBROUTINE SMUMPS_BLR_DEC_AND_RETRIEVE_L LOGICAL FUNCTION SMUMPS_BLR_EMPTY_PANEL_LORU & (IWHANDLER, LorU, IPANEL) INTEGER, INTENT(IN) :: LorU, IPANEL, IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF (LorU.EQ.0) THEN IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) & "Internal error 2 in SMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF SMUMPS_BLR_EMPTY_PANEL_LORU = .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 3 in SMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF SMUMPS_BLR_EMPTY_PANEL_LORU = .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ENDIF RETURN END FUNCTION SMUMPS_BLR_EMPTY_PANEL_LORU SUBROUTINE SMUMPS_BLR_RETRIEVE_PANEL_LORU & (IWHANDLER, LORU, IPANEL, & THELRBPANEL) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: LORU INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_NOF2003) TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL #else TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF (LORU.EQ.0) THEN IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) & "Internal error 2 in SMUMPS_BLR_RETRIEVE_PANEL_LORU", & " IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) & "Internal error 3 in SMUMPS_BLR_RETRIEVE_PANEL_LORU", & " IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 4 in SMUMPS_BLR_RETRIEVE_PANEL_LORU", & " IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) & "Internal error 5 in SMUMPS_BLR_RETRIEVE_PANEL_LORU", & " IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL ENDIF RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_PANEL_LORU SUBROUTINE SMUMPS_BLR_RETRIEVE_DIAG_BLOCK & (IWHANDLER, IPANEL, & THEBLOCK) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_NOF2003) REAL, POINTER :: THEBLOCK(:) #else REAL, POINTER, INTENT(OUT) :: THEBLOCK(:) #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN WRITE(*,*) & "Internal error 2 in SMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK)) & THEN WRITE(*,*) & "Internal error 3 in SMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THEBLOCK => & BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_DIAG_BLOCK SUBROUTINE SMUMPS_BLR_RETRIEVE_CB_LRB & (IWHANDLER, THECB) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) TYPE(LRB_TYPE), POINTER :: THECB(:,:) #else TYPE(LRB_TYPE), POINTER, INTENT(OUT) :: THECB(:,:) #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_RETRIEVE_CB_LRB" CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%CB_LRB)) THEN WRITE(*,*) "Internal error 2 in SMUMPS_BLR_RETRIEVE_CB_LRB" CALL MUMPS_ABORT() ENDIF THECB => BLR_ARRAY(IWHANDLER)%CB_LRB RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_CB_LRB SUBROUTINE SMUMPS_BLR_SAVE_NFS4FATHER & ( IWHANDLER, NFS4FATHER ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: NFS4FATHER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_NFS4FATHER" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER RETURN END SUBROUTINE SMUMPS_BLR_SAVE_NFS4FATHER SUBROUTINE SMUMPS_BLR_RETRIEVE_NFS4FATHER & ( IWHANDLER, NFS4FATHER ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NFS4FATHER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_NFS4FATHER" CALL MUMPS_ABORT() ENDIF NFS4FATHER = BLR_ARRAY(IWHANDLER)%NFS4FATHER RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_NFS4FATHER SUBROUTINE SMUMPS_BLR_SAVE_M_ARRAY ( & IWHANDLER, M_ARRAY, INFO) REAL, DIMENSION(:), INTENT(IN) :: M_ARRAY INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_SAVE_M_ARRAY" CALL MUMPS_ABORT() ENDIF ALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY(size(M_ARRAY)), & stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=size(M_ARRAY) RETURN ENDIF DO I=1,size(M_ARRAY) BLR_ARRAY(IWHANDLER)%M_ARRAY(I) = M_ARRAY(I) ENDDO BLR_ARRAY(IWHANDLER)%NFS4FATHER = size(M_ARRAY) RETURN END SUBROUTINE SMUMPS_BLR_SAVE_M_ARRAY SUBROUTINE SMUMPS_BLR_RETRIEVE_M_ARRAY ( IWHANDLER, M_ARRAY) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_NOF2003) REAL, DIMENSION(:), POINTER :: M_ARRAY #else REAL, DIMENSION(:), POINTER, INTENT(OUT) :: M_ARRAY #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_RETRIEVE_M_ARRAY" CALL MUMPS_ABORT() ENDIF M_ARRAY => BLR_ARRAY(IWHANDLER)%M_ARRAY RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_M_ARRAY SUBROUTINE SMUMPS_BLR_FREE_M_ARRAY ( IWHANDLER ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_FREE_M_ARRAY" CALL MUMPS_ABORT() ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%M_ARRAY)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY) NULLIFY(BLR_ARRAY(IWHANDLER)%M_ARRAY) ENDIF BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER_NOTINIT RETURN END SUBROUTINE SMUMPS_BLR_FREE_M_ARRAY SUBROUTINE SMUMPS_BLR_DEC_AND_TRYFREE_L( IWHANDLER, IPANEL, & KEEP8, K34, NBDEC) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL, K34, NBDEC INTEGER(8) :: KEEP8(150) IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) & RETURN BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - NBDEC CALL SMUMPS_BLR_TRY_FREE_PANEL (IWHANDLER, IPANEL, & KEEP8, K34) RETURN END SUBROUTINE SMUMPS_BLR_DEC_AND_TRYFREE_L SUBROUTINE SMUMPS_BLR_FORCE_FREE_PANEL_L( IWHANDLER, IPANEL, & KEEP8, K34 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: K34 TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) & RETURN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED RETURN END SUBROUTINE SMUMPS_BLR_FORCE_FREE_PANEL_L SUBROUTINE SMUMPS_BLR_TRY_FREE_PANEL( IWHANDLER, IPANEL, & KEEP8, K34 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: K34 TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0.OR. & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.eq.huge(IPANEL) ) & RETURN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF ( THEPANEL%NB_ACCESSES_LEFT .EQ. 0 ) THEN IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF RETURN END SUBROUTINE SMUMPS_BLR_TRY_FREE_PANEL SUBROUTINE SMUMPS_BLR_FREE_CB_LRB ( IWHANDLER, FREE_ONLY_STRUCT, & KEEP8, K34 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, K34 LOGICAL, INTENT(IN) :: FREE_ONLY_STRUCT INTEGER(8) :: KEEP8(150) TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER :: IPANEL, JPANEL TYPE(LRB_TYPE), POINTER :: THELRB IF (BLR_ARRAY(IWHANDLER)%IsT2.AND. & .NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN write(*,*) 'Internal error 1 in SMUMPS_BLR_FREE_CB_LRB' CALL MUMPS_ABORT() ENDIF CB_LRB => BLR_ARRAY(IWHANDLER)%CB_LRB IF (.NOT.associated(CB_LRB)) THEN write(*,*) 'Internal error 2 in SMUMPS_BLR_FREE_CB_LRB' CALL MUMPS_ABORT() ENDIF IF (.NOT.FREE_ONLY_STRUCT) THEN DO IPANEL = 1,size(CB_LRB,1) DO JPANEL = 1,size(CB_LRB,2) THELRB => CB_LRB(IPANEL,JPANEL) IF (associated(THELRB)) THEN CALL DEALLOC_LRB(THELRB, KEEP8, K34) ENDIF ENDDO ENDDO ENDIF DEALLOCATE(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) RETURN END SUBROUTINE SMUMPS_BLR_FREE_CB_LRB SUBROUTINE SMUMPS_BLR_FREE_ALL_PANELS ( IWHANDLER, & LorU, KEEP8, K34) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, LorU, K34 INTEGER(8) :: KEEP8(150) INTEGER :: IPANEL INTEGER :: IDUMMY, JDUMMY TYPE(blr_panel_type), POINTER :: THEPANEL TYPE(diag_block_type), POINTER :: THEBLOCK INTEGER(8) :: MEM_FREED IF (IWHANDLER.LE.0) RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ. & PANELS_NOTUSED) RETURN IF (LorU.EQ.0.OR.LorU.EQ.2) THEN IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF ENDIF IF (LorU.GE.1.AND..NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, K34) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF ENDIF IF (LorU.GE.1.AND..NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN IF (associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN MEM_FREED = 0_8 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) THEBLOCK => BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL) IF (associated(THEBLOCK%DIAG_BLOCK)) THEN MEM_FREED = MEM_FREED + int(size(THEBLOCK%DIAG_BLOCK),8) DEALLOCATE(THEBLOCK%DIAG_BLOCK) NULLIFY (THEBLOCK%DIAG_BLOCK) ENDIF ENDDO IF (MEM_FREED .GT. 0 ) THEN CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-MEM_FREED, & .TRUE., KEEP8, & IDUMMY, JDUMMY, & .TRUE., .TRUE.) ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_BLR_FREE_ALL_PANELS #if ! defined(NO_SAVE_RESTORE) SUBROUTINE SMUMPS_SAVE_RESTORE_BLR(id_BLRARRAY_ENCODING & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: j1,NbRecords,NbSubRecords,size_array1,dummy,allocok,err INTEGER:: SIZE_GEST_BLR_ARRAY,SIZE_GEST_BLR_ARRAY_j1 INTEGER(8):: SIZE_VARIABLES_BLR_ARRAY,SIZE_VARIABLES_BLR_ARRAY_j1 INTEGER(4) :: I4 NbRecords=0 SIZE_GEST_BLR_ARRAY=0 SIZE_GEST_BLR_ARRAY_j1=0 SIZE_VARIABLES_BLR_ARRAY=0_8 SIZE_VARIABLES_BLR_ARRAY_j1=0_8 SIZE_GEST=0 SIZE_VARIABLES=0_8 if(mode.EQ.memory_save_mode.OR.mode.EQ.save_mode) then call SMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) endif if(mode.EQ.memory_save_mode) then IF(associated(BLR_ARRAY)) THEN NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 DO j1=1,size(BLR_ARRAY,1) CALL SMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_BLR_ARRAY=SIZE_GEST_BLR_ARRAY+ & SIZE_GEST_BLR_ARRAY_j1 SIZE_VARIABLES_BLR_ARRAY=SIZE_VARIABLES_BLR_ARRAY+ & SIZE_VARIABLES_BLR_ARRAY_j1 ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_ARRAY)) THEN NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 write(unit,iostat=err) size(BLR_ARRAY,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 DO j1=1,size(BLR_ARRAY,1) CALL SMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_ARRAY) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 allocate(BLR_ARRAY(size_array1), stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL SMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_BLR_ARRAY=SIZE_GEST_BLR_ARRAY+ & SIZE_GEST_BLR_ARRAY_j1 SIZE_VARIABLES_BLR_ARRAY=SIZE_VARIABLES_BLR_ARRAY+ & SIZE_VARIABLES_BLR_ARRAY_j1 ENDDO endif endif if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(mode.EQ.memory_save_mode) then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_BLR_ARRAY SIZE_GEST=SIZE_GEST+SIZE_GEST_BLR_ARRAY #if defined(MUMPS_NOF2003) SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif call SMUMPS_BLR_MOD_TO_STRUC(id_BLRARRAY_ENCODING) 100 continue RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_BLR SUBROUTINE SMUMPS_SAVE_RESTORE_BLR_STRUC(BLR_STRUC & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(BLR_STRUC_T) :: BLR_STRUC INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER, PARAMETER :: NBVARIABLES_BLR_STRUC_T = 15 INTEGER, PARAMETER :: B_IsSYM=1 INTEGER, PARAMETER :: B_IsT2=2 INTEGER, PARAMETER :: B_IsSLAVE=3 INTEGER, PARAMETER :: B_PANELS_L=4 INTEGER, PARAMETER :: B_PANELS_U=5 INTEGER, PARAMETER :: B_CB_LRB=6 INTEGER, PARAMETER :: B_DIAG_BLOCKS=7 INTEGER, PARAMETER :: B_BEGS_BLR_STATIC=8 INTEGER, PARAMETER :: B_BEGS_BLR_DYNAMIC=9 INTEGER, PARAMETER :: B_BEGS_BLR_L=10 INTEGER, PARAMETER :: B_BEGS_BLR_COL=11 INTEGER, PARAMETER :: B_NB_ACCESSES_INIT=12 INTEGER, PARAMETER :: B_NB_PANELS=13 INTEGER, PARAMETER :: B_NFS4FATHER=14 INTEGER, PARAMETER :: B_M_ARRAY=15 INTEGER(8),dimension(NBVARIABLES_BLR_STRUC_T):: & SIZE_VARIABLES_BLR_STRUC_T INTEGER,dimension(NBVARIABLES_BLR_STRUC_T)::SIZE_GEST_BLR_STRUC_T INTEGER,dimension(NBVARIABLES_BLR_STRUC_T)::NbRecords_BLR_STRUC_T INTEGER:: size_array1,size_array2,dummy,allocok INTEGER:: err,i1,j1,j2,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER::SIZE_GEST_PANELS_L,SIZE_GEST_PANELS_L_j1 INTEGER(8)::SIZE_VARIABLES_PANELS_L,SIZE_VARIABLES_PANELS_L_j1 INTEGER::SIZE_GEST_PANELS_U,SIZE_GEST_PANELS_U_j1 INTEGER(8)::SIZE_VARIABLES_PANELS_U,SIZE_VARIABLES_PANELS_U_j1 INTEGER::SIZE_GEST_CB_LRB,SIZE_GEST_CB_LRB_j1j2 INTEGER(8)::SIZE_VARIABLES_CB_LRB,SIZE_VARIABLES_CB_LRB_j1j2 INTEGER::SIZE_GEST_DIAG_BLOCKS,SIZE_GEST_DIAG_BLOCKS_j1 INTEGER(8)::SIZE_VARIABLES_DIAG_BLOCKS INTEGER(8)::SIZE_VARIABLES_DIAG_BLOCKS_j1 INTEGER(4)::I4 SIZE_VARIABLES_BLR_STRUC_T(:)=0_8 SIZE_GEST_BLR_STRUC_T(:)=0 NbRecords_BLR_STRUC_T(:)=0 SIZE_GEST_PANELS_L=0 SIZE_GEST_PANELS_L_j1=0 SIZE_VARIABLES_PANELS_L=0_8 SIZE_VARIABLES_PANELS_L_j1=0_8 SIZE_GEST_PANELS_U=0 SIZE_GEST_PANELS_U_j1=0 SIZE_VARIABLES_PANELS_U=0_8 SIZE_VARIABLES_PANELS_U_j1=0_8 SIZE_GEST_CB_LRB=0 SIZE_GEST_CB_LRB_j1j2=0 SIZE_VARIABLES_CB_LRB=0_8 SIZE_VARIABLES_CB_LRB_j1j2=0_8 SIZE_GEST_DIAG_BLOCKS=0 SIZE_GEST_DIAG_BLOCKS_j1=0 SIZE_VARIABLES_DIAG_BLOCKS=0_8 SIZE_VARIABLES_DIAG_BLOCKS_j1=0_8 DO i1=1,NBVARIABLES_BLR_STRUC_T SELECT CASE(i1) CASE(B_IsSYM) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsSYM if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsSYM if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_IsT2) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsT2 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsT2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_IsSLAVE) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsSLAVE if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsSLAVE if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_BEGS_BLR_STATIC) NbRecords_BLR_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_STATIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_STATIC,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_STATIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_STATIC,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_STATIC,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_STATIC ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%BEGS_BLR_STATIC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_STATIC(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_STATIC endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_BEGS_BLR_DYNAMIC) NbRecords_BLR_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_DYNAMIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_DYNAMIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_DYNAMIC ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%BEGS_BLR_DYNAMIC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_DYNAMIC(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_DYNAMIC endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_BEGS_BLR_L) NbRecords_BLR_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_L)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_L,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_L)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_L,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_L,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_L ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%BEGS_BLR_L) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_L(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_L endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_BEGS_BLR_COL) NbRecords_BLR_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_COL)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_COL,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%BEGS_BLR_COL)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_COL,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_COL,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_COL ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%BEGS_BLR_COL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_COL(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_COL endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_NB_ACCESSES_INIT) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NB_ACCESSES_INIT if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NB_ACCESSES_INIT if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_NB_PANELS) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NB_PANELS if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NB_PANELS if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_PANELS_L) if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%PANELS_L)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%PANELS_L,1) CALL SMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_L=SIZE_GEST_PANELS_L+ & SIZE_GEST_PANELS_L_j1 SIZE_VARIABLES_PANELS_L=SIZE_VARIABLES_PANELS_L+ & SIZE_VARIABLES_PANELS_L_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%PANELS_L)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%PANELS_L,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%PANELS_L,1) CALL SMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%PANELS_L) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%PANELS_L(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL SMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_L=SIZE_GEST_PANELS_L+ & SIZE_GEST_PANELS_L_j1 SIZE_VARIABLES_PANELS_L=SIZE_VARIABLES_PANELS_L+ & SIZE_VARIABLES_PANELS_L_j1 ENDDO endif endif CASE(B_PANELS_U) if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%PANELS_U)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%PANELS_U,1) CALL SMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_U=SIZE_GEST_PANELS_U+ & SIZE_GEST_PANELS_U_j1 SIZE_VARIABLES_PANELS_U=SIZE_VARIABLES_PANELS_U+ & SIZE_VARIABLES_PANELS_U_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%PANELS_U)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%PANELS_U,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%PANELS_U,1) CALL SMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%PANELS_U) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%PANELS_U(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL SMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_U=SIZE_GEST_PANELS_U+ & SIZE_GEST_PANELS_U_j1 SIZE_VARIABLES_PANELS_U=SIZE_VARIABLES_PANELS_U+ & SIZE_VARIABLES_PANELS_U_j1 ENDDO endif endif CASE(B_CB_LRB) if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%CB_LRB)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%CB_LRB,1) DO j2=1,size(BLR_STRUC%CB_LRB,2) CALL SMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_CB_LRB=SIZE_GEST_CB_LRB+ & SIZE_GEST_CB_LRB_j1j2 SIZE_VARIABLES_CB_LRB=SIZE_VARIABLES_CB_LRB+ & SIZE_VARIABLES_CB_LRB_j1j2 ENDDO ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%CB_LRB)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%CB_LRB,1),size(BLR_STRUC%CB_LRB,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%CB_LRB,1) DO j2=1,size(BLR_STRUC%CB_LRB,2) CALL SMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,save_mode & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%CB_LRB) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%CB_LRB(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 DO j2=1,size_array2 CALL SMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,restore_mode & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_CB_LRB=SIZE_GEST_CB_LRB+ & SIZE_GEST_CB_LRB_j1j2 SIZE_VARIABLES_CB_LRB=SIZE_VARIABLES_CB_LRB+ & SIZE_VARIABLES_CB_LRB_j1j2 ENDDO ENDDO endif endif CASE(B_DIAG_BLOCKS) if(mode.EQ.memory_save_mode) then IF(associated(BLR_STRUC%DIAG_BLOCKS)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%DIAG_BLOCKS,1) CALL SMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_DIAG_BLOCKS=SIZE_GEST_DIAG_BLOCKS+ & SIZE_GEST_DIAG_BLOCKS_j1 SIZE_VARIABLES_DIAG_BLOCKS= & SIZE_VARIABLES_DIAG_BLOCKS+ & SIZE_VARIABLES_DIAG_BLOCKS_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_STRUC%DIAG_BLOCKS)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%DIAG_BLOCKS,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%DIAG_BLOCKS,1) CALL SMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_STRUC%DIAG_BLOCKS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%DIAG_BLOCKS(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL SMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_DIAG_BLOCKS=SIZE_GEST_DIAG_BLOCKS+ & SIZE_GEST_DIAG_BLOCKS_j1 SIZE_VARIABLES_DIAG_BLOCKS= & SIZE_VARIABLES_DIAG_BLOCKS+ & SIZE_VARIABLES_DIAG_BLOCKS_j1 ENDDO endif endif CASE(B_NFS4FATHER) NbRecords_BLR_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NFS4FATHER if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NFS4FATHER if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE(B_M_ARRAY) if(mode.EQ.restore_mode) then nullify(BLR_STRUC%M_ARRAY) endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_BLR_STRUC_T(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_BLR_STRUC_T(i1)=NbRecords_BLR_STRUC_T(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_BLR_STRUC_T(i1) & +int(SIZE_GEST_BLR_STRUC_T(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_BLR_STRUC_T(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_BLR_STRUC_T(i1) size_read=size_read+SIZE_VARIABLES_BLR_STRUC_T(i1) & +int(SIZE_GEST_BLR_STRUC_T(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_BLR_STRUC_T(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_BLR_STRUC_T) & +SIZE_VARIABLES_PANELS_L & +SIZE_VARIABLES_PANELS_U & +SIZE_VARIABLES_CB_LRB & +SIZE_VARIABLES_DIAG_BLOCKS Local_SIZE_GEST=sum(SIZE_GEST_BLR_STRUC_T) & +SIZE_GEST_PANELS_L & +SIZE_GEST_PANELS_U & +SIZE_GEST_CB_LRB & +SIZE_GEST_DIAG_BLOCKS #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_BLR_STRUC_T) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 100 continue RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_BLR_STRUC SUBROUTINE SMUMPS_SAVE_RESTORE_LRB(LRB_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(LRB_TYPE) :: LRB_T INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER, PARAMETER :: LRB_Q=1 INTEGER, PARAMETER :: LRB_R=2 INTEGER, PARAMETER :: LRB_K=3 INTEGER, PARAMETER :: LRB_M=4 INTEGER, PARAMETER :: LRB_N=5 INTEGER, PARAMETER :: LRB_ISLR=6 INTEGER, PARAMETER :: NBVARIABLES_LRB_TYPE=6 INTEGER(8),dimension(NBVARIABLES_LRB_TYPE):: & SIZE_VARIABLES_LRB_TYPE INTEGER,dimension(NBVARIABLES_LRB_TYPE):: & SIZE_GEST_LRB_TYPE INTEGER,dimension(NBVARIABLES_LRB_TYPE):: & NbRecords_LRB_TYPE INTEGER:: size_array1,size_array2,dummy,allocok INTEGER:: err,i1,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER(4) ::I4 SIZE_VARIABLES_LRB_TYPE(:)=0_8 SIZE_GEST_LRB_TYPE(:)=0 NbRecords_LRB_TYPE(:)=0 DO i1=1,NBVARIABLES_LRB_TYPE SELECT CASE(i1) CASE(LRB_Q) NbRecords_LRB_TYPE(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(LRB_T%Q)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%Q,1)*size(LRB_T%Q,2) & * SIZE_ARITH_DEP ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(LRB_T%Q)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%Q,1)*size(LRB_T%Q,2) & * SIZE_ARITH_DEP write(unit,iostat=err) size(LRB_T%Q,1),size(LRB_T%Q,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) LRB_T%Q ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then nullify(LRB_T%Q) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(size_array1.EQ.-999) then SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size_array1*size_array2*SIZE_ARITH_DEP allocate(LRB_T%Q(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) LRB_T%Q endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_R) NbRecords_LRB_TYPE(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(LRB_T%R)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%R,1)*size(LRB_T%R,2) & * SIZE_ARITH_DEP ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(LRB_T%R)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%R,1)*size(LRB_T%R,2) & * SIZE_ARITH_DEP write(unit,iostat=err) size(LRB_T%R,1),size(LRB_T%R,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) LRB_T%R ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then nullify(LRB_T%R) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(size_array1.EQ.-999) then SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size_array1*size_array2*SIZE_ARITH_DEP allocate(LRB_T%R(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) LRB_T%R endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_K) NbRecords_LRB_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%K if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%K if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_M) NbRecords_LRB_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%M if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%M if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_N) NbRecords_LRB_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%N if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%N if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE(LRB_ISLR) NbRecords_LRB_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL elseif(mode.EQ.save_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL write(unit,iostat=err) LRB_T%ISLR if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL read(unit,iostat=err) LRB_T%ISLR if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_LRB_TYPE(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_LRB_TYPE(i1)= & NbRecords_LRB_TYPE(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_LRB_TYPE(i1) & +int(SIZE_GEST_LRB_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_LRB_TYPE(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_LRB_TYPE(i1) size_read=size_read+SIZE_VARIABLES_LRB_TYPE(i1) & +int(SIZE_GEST_LRB_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_LRB_TYPE(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_LRB_TYPE) Local_SIZE_GEST=sum(SIZE_GEST_LRB_TYPE) #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_LRB_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 300 continue RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_LRB SUBROUTINE SMUMPS_SAVE_RESTORE_BLR_PANEL(BLR_PANEL_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(blr_panel_type) :: BLR_PANEL_T INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER, PARAMETER :: P_NB_ACCESSES_LEFT=1 INTEGER, PARAMETER :: P_LRB_PANEL=2 INTEGER, PARAMETER :: NBVARIABLES_BLR_PANEL_TYPE = 2 INTEGER(8),dimension(NBVARIABLES_BLR_PANEL_TYPE):: & SIZE_VARIABLES_BLR_PANEL_TYPE INTEGER,dimension(NBVARIABLES_BLR_PANEL_TYPE):: & SIZE_GEST_BLR_PANEL_TYPE INTEGER,dimension(NBVARIABLES_BLR_PANEL_TYPE):: & NbRecords_BLR_PANEL_TYPE INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,j1,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER:: SIZE_GEST_LRB_PANEL_j1,SIZE_GEST_LRB_PANEL INTEGER(8)::SIZE_VARIABLES_LRB_PANEL_j1,SIZE_VARIABLES_LRB_PANEL INTEGER(4)::I4 SIZE_VARIABLES_BLR_PANEL_TYPE(:)=0_8 SIZE_GEST_BLR_PANEL_TYPE(:)=0 NbRecords_BLR_PANEL_TYPE(:)=0 SIZE_GEST_LRB_PANEL_j1=0 SIZE_GEST_LRB_PANEL=0 SIZE_VARIABLES_LRB_PANEL_j1=0_8 SIZE_VARIABLES_LRB_PANEL=0_8 DO i1=1,NBVARIABLES_BLR_PANEL_TYPE SELECT CASE(i1) CASE(P_NB_ACCESSES_LEFT) NbRecords_BLR_PANEL_TYPE(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT write(unit,iostat=err) BLR_PANEL_T%NB_ACCESSES_LEFT if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT read(unit,iostat=err) BLR_PANEL_T%NB_ACCESSES_LEFT if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 endif CASE(P_LRB_PANEL) if(mode.EQ.memory_save_mode) then IF(associated(BLR_PANEL_T%LRB_PANEL)) THEN NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 DO j1=1,size(BLR_PANEL_T%LRB_PANEL,1) CALL SMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,memory_save_mode & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_LRB_PANEL=SIZE_GEST_LRB_PANEL+ & SIZE_GEST_LRB_PANEL_j1 SIZE_VARIABLES_LRB_PANEL=SIZE_VARIABLES_LRB_PANEL+ & SIZE_VARIABLES_LRB_PANEL_j1 ENDDO ELSE NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(BLR_PANEL_T%LRB_PANEL)) THEN NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 write(unit,iostat=err) size(BLR_PANEL_T%LRB_PANEL,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 DO j1=1,size(BLR_PANEL_T%LRB_PANEL,1) CALL SMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,save_mode & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 400 ENDDO ELSE NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 ENDIF elseif(mode.EQ.restore_mode) then nullify(BLR_PANEL_T%LRB_PANEL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 if(size_array1.EQ.-999) then NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 else NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 allocate(BLR_PANEL_T%LRB_PANEL(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL SMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,restore_mode & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_LRB_PANEL=SIZE_GEST_LRB_PANEL+ & SIZE_GEST_LRB_PANEL_j1 SIZE_VARIABLES_LRB_PANEL=SIZE_VARIABLES_LRB_PANEL+ & SIZE_VARIABLES_LRB_PANEL_j1 ENDDO endif endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_BLR_PANEL_TYPE(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_BLR_PANEL_TYPE(i1)= & NbRecords_BLR_PANEL_TYPE(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_BLR_PANEL_TYPE(i1) & +int(SIZE_GEST_BLR_PANEL_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_BLR_PANEL_TYPE(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_BLR_PANEL_TYPE(i1) size_read=size_read+SIZE_VARIABLES_BLR_PANEL_TYPE(i1) & +int(SIZE_GEST_BLR_PANEL_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_BLR_PANEL_TYPE(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_BLR_PANEL_TYPE)+ & SIZE_VARIABLES_LRB_PANEL Local_SIZE_GEST=sum(SIZE_GEST_BLR_PANEL_TYPE)+ & SIZE_GEST_LRB_PANEL #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_BLR_PANEL_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 400 continue RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_BLR_PANEL SUBROUTINE SMUMPS_SAVE_RESTORE_DIAG_BLOCK(DIAG_BLOCK_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(diag_block_type) :: DIAG_BLOCK_T INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER, PARAMETER :: D_DIAG_BLOCK=1 INTEGER, PARAMETER :: NBVARIABLES_DIAG_BLOCK_TYPE = 1 INTEGER(8),dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & SIZE_VARIABLES_DIAG_BLOCK_TYPE INTEGER,dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & SIZE_GEST_DIAG_BLOCK_TYPE INTEGER,dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & NbRecords_DIAG_BLOCK_TYPE INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER(4) :: I4 SIZE_VARIABLES_DIAG_BLOCK_TYPE(:)=0_8 SIZE_GEST_DIAG_BLOCK_TYPE(:)=0 NbRecords_DIAG_BLOCK_TYPE(:)=0 DO i1=1,NBVARIABLES_DIAG_BLOCK_TYPE SELECT CASE(i1) CASE(D_DIAG_BLOCK) NbRecords_DIAG_BLOCK_TYPE(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(DIAG_BLOCK_T%DIAG_BLOCK)) THEN SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size(DIAG_BLOCK_T%DIAG_BLOCK,1) & * SIZE_ARITH_DEP ELSE SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 ENDIF elseif(mode.EQ.save_mode) then IF(associated(DIAG_BLOCK_T%DIAG_BLOCK)) THEN SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size(DIAG_BLOCK_T%DIAG_BLOCK,1) & * SIZE_ARITH_DEP write(unit,iostat=err) size(DIAG_BLOCK_T%DIAG_BLOCK,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 write(unit,iostat=err) DIAG_BLOCK_T%DIAG_BLOCK ELSE SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 elseif(mode.EQ.restore_mode) then nullify(DIAG_BLOCK_T%DIAG_BLOCK) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 if(size_array1.EQ.-999) then SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size_array1*SIZE_ARITH_DEP allocate(DIAG_BLOCK_T%DIAG_BLOCK(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) GOTO 200 endif read(unit,iostat=err) DIAG_BLOCK_T%DIAG_BLOCK endif if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 200 endif endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then NbSubRecords=int(SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)/ & huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_DIAG_BLOCK_TYPE(i1)= & NbRecords_DIAG_BLOCK_TYPE(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) & +int(SIZE_GEST_DIAG_BLOCK_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_DIAG_BLOCK_TYPE(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) size_read=size_read+SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) & +int(SIZE_GEST_DIAG_BLOCK_TYPE(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_DIAG_BLOCK_TYPE(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_DIAG_BLOCK_TYPE) Local_SIZE_GEST=sum(SIZE_GEST_DIAG_BLOCK_TYPE) #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_DIAG_BLOCK_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 200 continue RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_DIAG_BLOCK #endif END MODULE SMUMPS_LR_DATA_M MUMPS_5.8.1/src/front_data_mgt_m.F0000664000175000017500000007125215042446423016653 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_FRONT_DATA_MGT_M IMPLICIT NONE PRIVATE C -------------------------------------------- C This module contains routines to manage C handlers of various data associated to C active fronts *during the factorization*. C C It should be initialized at the beginning C of the factorization and terminated at the C end of the factorization. C C There are two types of data, see below. C C 'A' is for active type 2 fronts: list must C be empty at the end of the factorization C C 'F' will be for general fronts -- currently used C for BLR fronts, in three situations: C 1/ factorization of type 2 symmetric active fronts C (requires temporary storage of BLR panels) C 2/ LRSOLVE: BLR factors are kept until solution phase C (liberated in JOB=-2 or at the beginning of a new facto) C 3/ LRCB: CB is dynamically allocated and compressed C (liberated before the end of the factorization) C C Only handlers are managed in this module. C The data itself is in the module above using it. C For example, FAC_MAPROW_DATA_M manages MAPROW C messages that arrive too early. It handles an C array that contains all early MAPROW messages C and that is indexed with the handlers managed C by MUMPS_FRONT_DATA_MGT_M. C C -------------------------------------------- C C =============== C Public routines C =============== PUBLIC :: MUMPS_FDM_INIT, & MUMPS_FDM_END, & MUMPS_FDM_START_IDX, & MUMPS_FDM_END_IDX & , MUMPS_FDM_MOD_TO_STRUC & , MUMPS_FDM_STRUC_TO_MOD #if ! defined(NO_SAVE_RESTORE) & , MUMPS_SAVE_RESTORE_FRONT_DATA #endif C STACK_FREE_IDX(1:NB_FREE_IDX) holds the NB_FREE_IDX indices C of free handlers C STACK_FREE_IDX(NB_FREE_IDX+1:size(STACK_FREE_IDX)) is trash data TYPE FDM_STRUC_T INTEGER :: NB_FREE_IDX INTEGER, DIMENSION(:), POINTER :: STACK_FREE_IDX => null() INTEGER, DIMENSION(:), POINTER :: COUNT_ACCESS => null() END TYPE FDM_STRUC_T TYPE (FDM_STRUC_T), TARGET, SAVE :: FDM_A, FDM_F #if ! defined(NO_SAVE_RESTORE) INCLUDE 'mumps_save_restore_modes.h' #endif CONTAINS C SUBROUTINE MUMPS_FDM_INIT(WHAT, INITIAL_SIZE, INFO) C C Purpose: C ======= C C Initialize handler data ('A' or 'F') C C Arguments: C ========= C INTEGER, INTENT(IN) :: INITIAL_SIZE CHARACTER, INTENT(IN) :: WHAT ! 'A' or 'F' INTEGER, INTENT(INOUT) :: INFO(2) C C Local variables: C =============== C INTEGER :: IERR TYPE (FDM_STRUC_T), POINTER :: FDM_PTR C CALL MUMPS_FDM_SET_PTR(WHAT, FDM_PTR) ALLOCATE( FDM_PTR%STACK_FREE_IDX(INITIAL_SIZE), & FDM_PTR%COUNT_ACCESS (INITIAL_SIZE), stat=IERR ) IF (IERR < 0) THEN INFO(1) = -13 INFO(2) = INITIAL_SIZE * 2 RETURN ENDIF CALL MUMPS_FDM_SET_ALL_FREE(FDM_PTR) RETURN END SUBROUTINE MUMPS_FDM_INIT C SUBROUTINE MUMPS_FDM_END(WHAT) C C Purpose: C ======= C Free module datastructures associated to "WHAT" at C the end of a phase (typically factorization). C CHARACTER, INTENT(IN) :: WHAT C C Local variables C =============== C TYPE (FDM_STRUC_T), POINTER :: FDM_PTR C CALL MUMPS_FDM_SET_PTR(WHAT, FDM_PTR) IF (associated(FDM_PTR%STACK_FREE_IDX)) THEN DEALLOCATE(FDM_PTR%STACK_FREE_IDX) NULLIFY(FDM_PTR%STACK_FREE_IDX) FDM_PTR%NB_FREE_IDX=0 ELSE C Should not be called twice or when array is unassociated WRITE(*,*) "Internal error 1 in MUMPS_FDM_END", WHAT CALL MUMPS_ABORT() ENDIF IF (associated(FDM_PTR%COUNT_ACCESS)) THEN DEALLOCATE(FDM_PTR%COUNT_ACCESS) NULLIFY(FDM_PTR%COUNT_ACCESS) ELSE C Should not be called twice or when array is unassociated WRITE(*,*) "Internal error 2 in MUMPS_FDM_END", WHAT CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE MUMPS_FDM_END C SUBROUTINE MUMPS_FDM_MOD_TO_STRUC(WHAT, id_FDM_ENCODING,INFO) C C Purpose: C ======= C C Save module information in struture. C id_FDM_ENCODING corresponds to id%FDM_F_ENCODING C This version requires that WHAT is equal to 'F'. C C id_FDM_ENDODING takes responsibility of pointing to module C FDM_F information. This typically allows data from the module C to be passed from factorization to solve through the instance C and manage multiple instances. C CHARACTER, INTENT(IN) :: WHAT INTEGER, INTENT(INOUT) :: INFO(2) #if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_FDM_ENCODING #else CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_ENCODING #endif C C Local variables C =============== C C Character array of arbitrary dimension 1 CHARACTER :: CHAR_ARRAY(1) INTEGER :: CHAR_LENGTH, IERR C IF (WHAT .NE. 'F') THEN WRITE(*,*) "Internal error 1 in MUMPS_FDM_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF IF (associated(id_FDM_ENCODING)) THEN C Should be unassociated for this to work WRITE(*,*) "Internal error 2 in MUMPS_FDM_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF CHAR_LENGTH=size(transfer(FDM_F,CHAR_ARRAY)) ALLOCATE(id_FDM_ENCODING(CHAR_LENGTH), stat=IERR ) IF (IERR < 0) THEN INFO(1) = -13 INFO(2) = CHAR_LENGTH RETURN ENDIF C ------------------------------ C Fill contents of pointer array C with FDM_F derived datatype C ------------------------------ id_FDM_ENCODING = transfer(FDM_F,CHAR_ARRAY) C ---------------------------------------------- C FDM_F is not to be used again before a call to C MUMPS_FDM_STRUC_TO_MOD, invalidate its content C ---------------------------------------------- FDM_F%NB_FREE_IDX=-9999999 NULLIFY(FDM_F%STACK_FREE_IDX) NULLIFY(FDM_F%COUNT_ACCESS) RETURN END SUBROUTINE MUMPS_FDM_MOD_TO_STRUC C SUBROUTINE MUMPS_FDM_STRUC_TO_MOD(WHAT, id_FDM_ENCODING) C C Purpose: C ======= C C Set module pointer information from id_FDM_ENCODING) typically C at beginning of solve. Suppress from structure since C responsibility of pointing to module data is now inside C the module. C CHARACTER, INTENT(IN) :: WHAT #if defined(MUMPS_NOF2003) CHARACTER, DIMENSION(:), POINTER :: id_FDM_ENCODING #else CHARACTER, DIMENSION(:), POINTER, INTENT(INOUT) & :: id_FDM_ENCODING #endif C C Local variables C =============== C IF (.NOT.associated(id_FDM_ENCODING)) THEN WRITE(*,*) "Internal error 1 in MUMPS_FDM_STRUC_TO_MOD" ENDIF FDM_F=transfer(id_FDM_ENCODING,FDM_F) C Module is now responsible for accessing data. DEALLOCATE(id_FDM_ENCODING) NULLIFY(id_FDM_ENCODING) RETURN END SUBROUTINE MUMPS_FDM_STRUC_TO_MOD C SUBROUTINE MUMPS_FDM_START_IDX(WHAT, FROM, IWHANDLER, INFO) C C Purpose: C ======= C C Return a new free index/handler C (typically stored in IW) C CHARACTER, INTENT(IN) :: WHAT CHARACTER(LEN=*), INTENT(IN) :: FROM !For debugging purposes only INTEGER, INTENT(INOUT) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) C C Local variables C =============== C INTEGER :: OLD_SIZE, NEW_SIZE, IERR INTEGER :: I INTEGER, DIMENSION(:), POINTER :: TMP_COUNT_ACCESS TYPE(FDM_STRUC_T), POINTER :: FDM_PTR CALL MUMPS_FDM_SET_PTR(WHAT, FDM_PTR) C IF (IWHANDLER .GT. 0) THEN C Already started, counter should at least be 1 IF (FDM_PTR%COUNT_ACCESS(IWHANDLER) .LT. 1) THEN WRITE(*,*) "Internal error 1 in MUMPS_FDM_START_IDX", & FDM_PTR%COUNT_ACCESS(IWHANDLER) CALL MUMPS_ABORT() ENDIF GOTO 100 ENDIF C IF (FDM_PTR%NB_FREE_IDX .EQ. 0) THEN OLD_SIZE = size(FDM_PTR%STACK_FREE_IDX) NEW_SIZE = (OLD_SIZE * 3) / 2 + 1 ! or something else FDM_PTR%NB_FREE_IDX = NEW_SIZE - OLD_SIZE DEALLOCATE(FDM_PTR%STACK_FREE_IDX) ALLOCATE(FDM_PTR%STACK_FREE_IDX(NEW_SIZE), & TMP_COUNT_ACCESS(NEW_SIZE), stat=IERR) IF (IERR < 0) THEN INFO(1) = -13 INFO(2) = NEW_SIZE RETURN ENDIF C All new handlers indices are created DO I=1, FDM_PTR%NB_FREE_IDX FDM_PTR%STACK_FREE_IDX(I)=NEW_SIZE-I+1 ENDDO C Count access: copy old ones DO I=1, OLD_SIZE TMP_COUNT_ACCESS(I)=FDM_PTR%COUNT_ACCESS(I) ENDDO DO I=OLD_SIZE+1, NEW_SIZE TMP_COUNT_ACCESS(I)=0 ENDDO DEALLOCATE(FDM_PTR%COUNT_ACCESS) FDM_PTR%COUNT_ACCESS=>TMP_COUNT_ACCESS ENDIF C IWHANDLER = FDM_PTR%STACK_FREE_IDX(FDM_PTR%NB_FREE_IDX) FDM_PTR%NB_FREE_IDX = FDM_PTR%NB_FREE_IDX - 1 100 CONTINUE C Number of modules accessing this handler FDM_PTR%COUNT_ACCESS(IWHANDLER)=FDM_PTR%COUNT_ACCESS(IWHANDLER)+1 RETURN END SUBROUTINE MUMPS_FDM_START_IDX C SUBROUTINE MUMPS_FDM_END_IDX(WHAT, FROM, IWHANDLER) C C Purpose: C ======= C C Notify than an index/handler has been freed. C Mark it free for future reuse. C CHARACTER, INTENT(IN) :: WHAT CHARACTER(LEN=*), INTENT(IN) :: FROM ! for debug purposes only INTEGER, INTENT(INOUT) :: IWHANDLER TYPE(FDM_STRUC_T), POINTER :: FDM_PTR C CALL MUMPS_FDM_SET_PTR(WHAT, FDM_PTR) IF (IWHANDLER .LE.0) THEN C Already ended WRITE(*,*) "Internal error 1 in MUMPS_FDM_END_IDX",IWHANDLER CALL MUMPS_ABORT() ENDIF FDM_PTR%COUNT_ACCESS(IWHANDLER)=FDM_PTR%COUNT_ACCESS(IWHANDLER)-1 IF (FDM_PTR%COUNT_ACCESS(IWHANDLER) .LT. 0) THEN C Negative counter! WRITE(*,*) "Internal error 2 in MUMPS_FDM_END_IDX", & IWHANDLER, FDM_PTR%COUNT_ACCESS(IWHANDLER) CALL MUMPS_ABORT() ENDIF IF (FDM_PTR%COUNT_ACCESS(IWHANDLER) .EQ.0 ) THEN IF (FDM_PTR%NB_FREE_IDX .GE. size(FDM_PTR%STACK_FREE_IDX)) THEN WRITE(*,*) "Internal error 3 in MUMPS_FDM_END_IDX" CALL MUMPS_ABORT() ENDIF FDM_PTR%NB_FREE_IDX = FDM_PTR%NB_FREE_IDX + 1 C Having incremented the nb of free handlers we C store the index (IWHANDLER) that has been C effectively released for future reuse. FDM_PTR%STACK_FREE_IDX(FDM_PTR%NB_FREE_IDX) = IWHANDLER IWHANDLER = -8888 ! has been used and is now free ENDIF C RETURN END SUBROUTINE MUMPS_FDM_END_IDX C =================== C Private subroutines C =================== SUBROUTINE MUMPS_FDM_SET_PTR(WHAT, FDM_PTR) CHARACTER, INTENT(IN) :: WHAT #if defined(MUMPS_NOF2003) TYPE(FDM_STRUC_T), POINTER :: FDM_PTR #else TYPE(FDM_STRUC_T), POINTER, INTENT(OUT) :: FDM_PTR #endif C IF ( WHAT .EQ. 'A' ) THEN FDM_PTR => FDM_A ELSE IF ( WHAT .EQ. 'F' ) THEN FDM_PTR => FDM_F ELSE C Should be called with either A or F WRITE(*,*) "Internal error 1 in MUMPS_FDM_INIT" WRITE(*,*) "Allowed arguments for WHAT are A or F" CALL MUMPS_ABORT() ENDIF END SUBROUTINE MUMPS_FDM_SET_PTR SUBROUTINE MUMPS_FDM_SET_ALL_FREE(FDM_PTR) C C Purpose: C ======= C Initialize the stack of free elements for the first time C TYPE(FDM_STRUC_T), POINTER :: FDM_PTR INTEGER :: I FDM_PTR%NB_FREE_IDX = size(FDM_PTR%STACK_FREE_IDX) DO I = 1, FDM_PTR%NB_FREE_IDX FDM_PTR%STACK_FREE_IDX(I)=FDM_PTR%NB_FREE_IDX-I+1 FDM_PTR%COUNT_ACCESS (I)=0 ENDDO RETURN END SUBROUTINE MUMPS_FDM_SET_ALL_FREE C #if ! defined(NO_SAVE_RESTORE) ! ---------- MUMPS_SAVE_RESTORE_FRONT_DATA ----------------------- ! SUBROUTINE MUMPS_SAVE_RESTORE_FRONT_DATA(id_FDM_F_ENCODING & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT, TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IMPLICIT NONE C ======= C Purpose C ======= C C This routine is designed to manage a FDM_STRUC_T structure (save, restore, compute memory) C C ========== C Parameters C ========== C C FDM_STRUC : TYPE (FDM_STRUC_T) : the main structure C C unit : The unit of the file to be written or read C C mode : the type of operation to be performed by the routine C memory_save = compute the size of the save file and of the structure C save = save the instace C restore = restore the instace C C TOTAL_FILE_SIZE : size of the file to be written or read C C TOTAL_STRUC_SIZE : size of the structure to be saved or restored C C SIZE_INT : size of an integer C C INFO : copies of of INFO(1) and INFO(2) to allow save/restore of failled instaces C CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING INTEGER,intent(IN) :: unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: NbRecords,NbSubRecords INTEGER:: SIZE_GEST_FDM_F INTEGER(8):: SIZE_VARIABLES_FDM_F INTEGER(4) :: I4 NbRecords=0 SIZE_GEST_FDM_F=0 SIZE_VARIABLES_FDM_F=0_8 SIZE_GEST=0 SIZE_VARIABLES=0_8 if((mode.EQ.memory_save_mode).OR.(mode.EQ.save_mode)) then call MUMPS_FDM_STRUC_TO_MOD("F",id_FDM_F_ENCODING) endif if(mode.EQ.memory_save_mode) then CALL MUMPS_SAVE_RESTORE_FDM_STRUC( & FDM_F & ,unit,MYID,memory_save_mode & ,SIZE_GEST_FDM_F & ,SIZE_VARIABLES_FDM_F & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) elseif(mode.EQ.save_mode) then CALL MUMPS_SAVE_RESTORE_FDM_STRUC( & FDM_F & ,unit,MYID,save_mode & ,SIZE_GEST_FDM_F & ,SIZE_VARIABLES_FDM_F & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then CALL MUMPS_SAVE_RESTORE_FDM_STRUC( & FDM_F & ,unit,MYID,restore_mode & ,SIZE_GEST_FDM_F & ,SIZE_VARIABLES_FDM_F & ,SIZE_INT, TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 endif if(mode.EQ.memory_save_mode) then C If the size to write (SIZE_VARIABLES) is greater than 2^31 C Subrecords are created which need to be taken into account in C the file size computation NbSubRecords=int(SIZE_VARIABLES/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(mode.EQ.memory_save_mode) then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_FDM_F SIZE_GEST=SIZE_GEST+SIZE_GEST_FDM_F #if defined(MUMPS_NOF2003) C If the file is not written with access="stream" (stream is C only in case of Fortran 2003), the record's length is written C at the beginning and at the end of each record. C This is done using 2 INTEGERs so we use 2*SIZE_INT more space C for each record SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif call MUMPS_FDM_MOD_TO_STRUC("F",id_FDM_F_ENCODING,INFO(1)) 100 continue RETURN END SUBROUTINE MUMPS_SAVE_RESTORE_FRONT_DATA ! ------------------ MUMPS_SAVE_RESTORE_BLR_STRUC ------------ ! SUBROUTINE MUMPS_SAVE_RESTORE_FDM_STRUC(FDM_STRUC & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IMPLICIT NONE C ======= C Purpose C ======= C C This routine is designed to manage a BLR_STRUC_T structure C (save, restore, compute memory) C C ========== C Parameters C ========== C C BLR_STRUC : TYPE (BLR_STRUC_T) : the main structure C C unit : The unit of the file to be written or read C C mode : the type of operation to be performed by C the routine memory_save = compute the C size of the save file and of the structure C save = save the instace C restore = restore the instace C C TOTAL_FILE_SIZE : size of the file to be written or read C C TOTAL_STRUC_SIZE : size of the structure to be saved or restored C C SIZE_INT : size of an integer C C INFO1/INFO2 : copies of of INFO(1) and INFO(2) to allow C save/restore of failled instaces C TYPE(FDM_STRUC_T) :: FDM_STRUC INTEGER,intent(IN)::unit,MYID INTEGER,intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written C Done as for mumps_save_restore main structure but here by hand: INTEGER, PARAMETER :: S_NB_FREE_IDX = 1 INTEGER, PARAMETER :: S_STACK_FREE_IDX = 2 INTEGER, PARAMETER :: S_COUNT_ACCESS = 3 INTEGER, PARAMETER :: NBVARIABLES_FDM_STRUC_T = 3 INTEGER(8),dimension(NBVARIABLES_FDM_STRUC_T):: & SIZE_VARIABLES_FDM_STRUC_T INTEGER,dimension(NBVARIABLES_FDM_STRUC_T)::SIZE_GEST_FDM_STRUC_T INTEGER,dimension(NBVARIABLES_FDM_STRUC_T)::NbRecords_FDM_STRUC_T INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,NbSubRecords #if defined(MUMPS_NOF2003) INTEGER:: Local_NbRecords #endif INTEGER(4) :: I4 SIZE_VARIABLES_FDM_STRUC_T(:)=0_8 SIZE_GEST_FDM_STRUC_T(:)=0 NbRecords_FDM_STRUC_T(:)=0 C C BEGINNING OF THE MAIN LOOP ON ALL VARIABLES OF THE STRUCTURE C DO i1=1,NBVARIABLES_FDM_STRUC_T SELECT CASE(i1) CASE(S_NB_FREE_IDX) NbRecords_FDM_STRUC_T(i1)=1 if(mode.EQ.memory_save_mode) then SIZE_VARIABLES_FDM_STRUC_T(i1)=SIZE_INT elseif(mode.EQ.save_mode) then SIZE_VARIABLES_FDM_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) FDM_STRUC%NB_FREE_IDX if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then SIZE_VARIABLES_FDM_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) FDM_STRUC%NB_FREE_IDX if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_STACK_FREE_IDX) NbRecords_FDM_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(FDM_STRUC%STACK_FREE_IDX)) THEN SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_FDM_STRUC_T(i1)= & size(FDM_STRUC%STACK_FREE_IDX,1)*SIZE_INT ELSE SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_FDM_STRUC_T(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(FDM_STRUC%STACK_FREE_IDX)) THEN SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_FDM_STRUC_T(i1)= & size(FDM_STRUC%STACK_FREE_IDX,1)*SIZE_INT write(unit,iostat=err) & size(FDM_STRUC%STACK_FREE_IDX,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) FDM_STRUC%STACK_FREE_IDX ELSE SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_FDM_STRUC_T(i1)=0_8 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(FDM_STRUC%STACK_FREE_IDX) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_FDM_STRUC_T(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_FDM_STRUC_T(i1)=size_array1*SIZE_INT allocate(FDM_STRUC%STACK_FREE_IDX(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) FDM_STRUC%STACK_FREE_IDX endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE(S_COUNT_ACCESS) NbRecords_FDM_STRUC_T(i1)=2 if(mode.EQ.memory_save_mode) then IF(associated(FDM_STRUC%COUNT_ACCESS)) THEN SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_FDM_STRUC_T(i1)= & size(FDM_STRUC%COUNT_ACCESS,1)*SIZE_INT ELSE SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_FDM_STRUC_T(i1)=0_8 ENDIF elseif(mode.EQ.save_mode) then IF(associated(FDM_STRUC%COUNT_ACCESS)) THEN SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_FDM_STRUC_T(i1)= & size(FDM_STRUC%COUNT_ACCESS,1)*SIZE_INT write(unit,iostat=err) & size(FDM_STRUC%COUNT_ACCESS,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) FDM_STRUC%COUNT_ACCESS ELSE SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_FDM_STRUC_T(i1)=0_8 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(mode.EQ.restore_mode) then nullify(FDM_STRUC%COUNT_ACCESS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_FDM_STRUC_T(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_FDM_STRUC_T(i1)=size_array1*SIZE_INT allocate(FDM_STRUC%COUNT_ACCESS(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) FDM_STRUC%COUNT_ACCESS endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE DEFAULT END SELECT if(mode.EQ.memory_save_mode) then C If the size to write (SIZE_VARIABLES_FDM_STRUC_T(i1)) is greater than 2^31 C Subrecords are created which need to be taken into account in C the file size computation NbSubRecords=int(SIZE_VARIABLES_FDM_STRUC_T(i1)/huge(I4)) IF(NbSubRecords.GT.0) then NbRecords_FDM_STRUC_T(i1)=NbRecords_FDM_STRUC_T(i1) & +NbSubRecords ENDIF elseif(mode.EQ.save_mode) then size_written=size_written+SIZE_VARIABLES_FDM_STRUC_T(i1) & +int(SIZE_GEST_FDM_STRUC_T(i1),kind=8) #if defined(MUMPS_NOF2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_FDM_STRUC_T(i1),kind=8) #endif elseif(mode.EQ.restore_mode) then size_allocated=size_allocated+ & SIZE_VARIABLES_FDM_STRUC_T(i1) size_read=size_read+SIZE_VARIABLES_FDM_STRUC_T(i1) & +int(SIZE_GEST_FDM_STRUC_T(i1),kind=8) #if defined(MUMPS_NOF2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_FDM_STRUC_T(i1),kind=8) #endif endif ENDDO if(mode.EQ.memory_save_mode) then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_FDM_STRUC_T) Local_SIZE_GEST=sum(SIZE_GEST_FDM_STRUC_T) #if defined(MUMPS_NOF2003) Local_NbRecords=sum(NbRecords_FDM_STRUC_T) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 100 continue RETURN END SUBROUTINE MUMPS_SAVE_RESTORE_FDM_STRUC #endif END MODULE MUMPS_FRONT_DATA_MGT_M MUMPS_5.8.1/src/dooc_panel_piv.F0000664000175000017500000002771415042446441016334 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C This file contains routines related to OOC, C panels, and pivoting. They are used to store C permutation information of what is already on C disk to be able to permute things back at the C solve stage. C They do not need to be in the MUMPS_OOC C module (most of them do not use any variable C from the module, or are called from routines C where we do not necessarily want to do a C USE DMUMPS_OOC). INTEGER FUNCTION DMUMPS_OOC_GET_PANEL_SIZE & ( HBUF_SIZE, NNMAX, K227, K50 ) IMPLICIT NONE C C Arguments: C ========= C INTEGER, INTENT(IN) :: NNMAX, K227, K50 INTEGER(8), INTENT(IN) :: HBUF_SIZE C C Purpose: C ======= C C - Compute the effective size (maximum number of pivots in a panel) C for a front with NNMAX entries in its row (for U) / C column (for L). C - Be able to adapt the fixed number of columns in panel C depending on NNMAX, and size of IO buffer HBUF_SIZE C C Local variables C =============== C INTEGER K227_LOC INTEGER NBCOL_MAX INTEGER EFFECTIVE_SIZE NBCOL_MAX=int(HBUF_SIZE / int(NNMAX,8)) C KEEP(227): Maximum size (nb of col/row) of a panel K227_LOC = abs(K227) IF (K50.EQ.2) THEN C for 2x2 pivots we may end-up having the first part C of a 2x2 pivot in the last col of the panel; the C adopted solution consists in adding the next column C to the panel; therefore we need be able to C dynamically increase the panel size by one. C note that we also maintain property: C KEEP(227): Maximum size (nb of col/row) of a panel K227_LOC=max(K227_LOC,2) EFFECTIVE_SIZE = min(NBCOL_MAX-1, K227_LOC-1) cN - during bwd the effective size is useless ELSE C complete buffer space can be used for a panel EFFECTIVE_SIZE = min(NBCOL_MAX, K227_LOC) ENDIF IF (EFFECTIVE_SIZE.LE.0) THEN write(6,*) 'Internal buffers too small to store ', & ' ONE col/row of size', NNMAX CALL MUMPS_ABORT() ENDIF DMUMPS_OOC_GET_PANEL_SIZE = EFFECTIVE_SIZE RETURN END FUNCTION DMUMPS_OOC_GET_PANEL_SIZE C SUBROUTINE DMUMPS_PERMUTE_PANEL( IPIV, LPIV, ISHIFT, & THE_PANEL, NBROW, NBCOL, KbeforePanel ) IMPLICIT NONE C C Purpose: C ======= C C Permute rows of a panel, stored by columns, according C to permutation array IPIV. C IPIV is such that, for I = 1 to LPIV, row ISHIFT + I C in the front must be permuted with row IPIV( I ) C C Since the panel is not necessary at the beginning of C the front, let KbeforePanel be the number of pivots in the C front before the first pivot of the panel. C C In the panel, row ISHIFT+I-KbeforePanel is permuted with C row IPIV(I)-KbeforePanel C C Note: C ==== C C This routine can also be used to permute the columns of C a matrix (U) stored by rows. In that case, the argument C NBROW represents the number of columns, and NBCOL represents C the number of rows. C C C Arguments: C ========= C INTEGER LPIV, ISHIFT, NBROW, NBCOL, KbeforePanel INTEGER IPIV(LPIV) DOUBLE PRECISION THE_PANEL(NBROW, NBCOL) C C Local variables: C =============== C INTEGER I, IPERM C C Executable statements C ===================== C DO I = 1, LPIV C Swap rows ISHIFT + I and PIV(I) IPERM=IPIV(I) IF ( I+ISHIFT.NE.IPERM) THEN CALL dswap(NBCOL, & THE_PANEL(I+ISHIFT-KbeforePanel,1), NBROW, & THE_PANEL(IPERM-KbeforePanel,1), NBROW) ENDIF END DO RETURN END SUBROUTINE DMUMPS_PERMUTE_PANEL SUBROUTINE DMUMPS_GET_OOC_PERM_PTR(TYPEF, & NBPANELS, & I_PIVPTR, I_PIV, IPOS, IW, LIW) USE MUMPS_OOC_COMMON ! To access TYPEF_L and TYPEF_U IMPLICIT NONE INCLUDE 'mumps_headers.h' C C Purpose: C ======= C C Get the pointers in IW on pivoting information to be stored C during factorization and used during the solve phase. This C routine is both for the symmetric (TYPEF=TYPEF_L) and unsymmetric C cases (TYPEF=TYPEF_L or TYPEF_U). C The total size of this space is estimated during C fac_ass.F / fac_ass_ELT.F and must be: C * Symmetric case: 1 for NASS + 1 for NBPANELS_L + NBPANELS_L + NASS C * Unsymmetric case: 1 + (1+NBPANELS_L+NASS) + (1+NBPANELS_U+NASS) C Size computation is in routine DMUMPS_OOC_GET_PP_SIZES. C C At the end of the standard description of the structure of a node C (header, nb slaves, , row indices, col indices), we C add, when panel version with pivoting is used: C C NASS (nb of fully summed variables) C NBPANELS_L C PIVRPTR(1:NBPANELS_L) C PIV_L (1:NASS) NASS (=IW(IPOS)(or NASS-PIVRPTR(1) in C the future, after compression) C NBPANELS_U C PIVRPTR(1:NBPANELS_U) C PIV_U (1:NASS) NASS (=IW(IPOS)(or NASS-PIVRPTR(1) in C the future, after compression) C C C Output parameters: C ================= C NBPANELS : nb of panels as estimated during assembly C I_PIVPTR : position in IW of the starting of the pointer list C (of size NBPANELS) of the pointers to the list of pivots C I_PIV : position in IW of the starting of the pivot permutation list C INTEGER, intent(out) :: NBPANELS, I_PIVPTR, I_PIV INTEGER, intent(in) :: TYPEF ! TYPEF_L or TYPEF_U INTEGER, intent(in) :: LIW, IPOS INTEGER IW(LIW) C Locals INTEGER I_NBPANELS, I_NASS C I_NASS = IPOS I_NBPANELS = I_NASS + 1 ! L NBPANELS = IW(I_NBPANELS) ! L I_PIVPTR = I_NBPANELS + 1 ! L I_PIV = I_PIVPTR + NBPANELS ! L C ... of size NASS = IW(I_NASS) IF (TYPEF==TYPEF_U) THEN I_NBPANELS = I_PIV+IW(I_NASS) ! U NBPANELS = IW(I_NBPANELS) ! U I_PIVPTR = I_NBPANELS + 1 ! U I_PIV = I_PIVPTR + NBPANELS ! U ENDIF RETURN END SUBROUTINE DMUMPS_GET_OOC_PERM_PTR SUBROUTINE DMUMPS_OOC_PP_SET_PTR(K50,NBPANELS_L,NBPANELS_U, & NASS, IPOS, IW, LIW ) IMPLICIT NONE C C Purpose: C ======= C C Initialize the contents of PIV/PIVPTR/etc. that will store C pivoting information during the factorization. C NASS and NBPANELS are recorded. PIVPTR(1:NBPANELS) C is initialized to NASS+1. This will be modified during C the factorization in cases where permutations have to C be performed during the solve phase. C C Arguments: C ========= C INTEGER K50 INTEGER IPOS, NASS, NBPANELS_L, NBPANELS_U, LIW INTEGER IW(LIW) C C Local variables: C =============== C INTEGER IPOS_U C Executable statements IF (K50.EQ.1) THEN WRITE(*,*) "Internal error: DMUMPS_OOC_PP_SET_PTR called" ENDIF IW(IPOS)=NASS IW(IPOS+1)=NBPANELS_L IW(IPOS+2:IPOS+1+NBPANELS_L)=NASS+1 IF (K50 == 0) THEN IPOS_U=IPOS+2+NASS+NBPANELS_L IW(IPOS_U)=NBPANELS_U IW(IPOS_U+1:IPOS_U+NBPANELS_U)=NASS+1 ENDIF RETURN END SUBROUTINE DMUMPS_OOC_PP_SET_PTR SUBROUTINE DMUMPS_OOC_PP_TRYRELEASE_SPACE ( & IWPOS, IOLDPS, IW, LIW, MonBloc, NFRONT, KEEP & ) USE DMUMPS_OOC IMPLICIT NONE INCLUDE 'mumps_headers.h' C C Purpose: C ======= C If space used was at the top of the stack then C try to free space by detecting that C no permutation needs to be applied during C solve on panels. C One position is left (I_NASS) and set to -1 C to indicate that permutation not needed at solve. C C Arguments: C ========= C INTEGER, INTENT(IN) :: IOLDPS, LIW, NFRONT, & KEEP(500) INTEGER, INTENT(INOUT) :: IWPOS, IW(LIW) TYPE(IO_BLOCK), INTENT(IN):: MonBloc C C Local variables: C =============== C INTEGER :: NBPANELS_L,I_PIVRPTR_L, I_PIVR_L, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, XSIZE, IBEGOOC LOGICAL FREESPACE ! set to true when permutation not needed C Executable statements IF (KEEP(50).EQ.1) RETURN ! no pivoting C -------------------------------- C quick return if record is not at C the top of stack of L factors IF ((IOLDPS+IW(IOLDPS+XXI)).NE.IWPOS) RETURN C --------------------------------------------- C Panel+pivoting: get pointers on each subarray C --------------------------------------------- XSIZE = KEEP(IXSZ) IBEGOOC = IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE C -- get L related data CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IBEGOOC, IW, LIW) FREESPACE = & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_L)-1)) IF (KEEP(50).EQ.0) THEN C -- get U related dataA CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IBEGOOC, IW, LIW) FREESPACE = FREESPACE .AND. & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_U)-1)) ENDIF C --------------------------------- C Check if permutations eed be C performed on panels during solve C -------------------------------- IF (FREESPACE) THEN C -- compress memory for that node: keep one entry set to -7777 IW(IBEGOOC) = -7777 ! will be tested during solve IW(IOLDPS+XXI) = IBEGOOC & - IOLDPS + 1 ! new size of inode's record IWPOS = IBEGOOC+1 ! move back to top of stack ENDIF RETURN END SUBROUTINE DMUMPS_OOC_PP_TRYRELEASE_SPACE C SUBROUTINE DMUMPS_OOC_GET_PP_SIZES(K50, NBROW_L, NBCOL_U, NASS, & NBPANELS_L, NBPANELS_U, LREQ) USE DMUMPS_OOC ! To call DMUMPS_OOC_PANEL_SIZE IMPLICIT NONE C C Purpose C ======= C C Compute the size of the workspace required to store the permutation C information during factorization, so that solve can permute back C what has to be permuted (this could not be done during factorization C because it was already on disk). C C Arguments C ========= C INTEGER, intent(IN) :: K50, NBROW_L, NBCOL_U, NASS INTEGER, intent(OUT) :: NBPANELS_L, NBPANELS_U, LREQ NBPANELS_L=-99999 NBPANELS_U=-99999 C C Quick return in SPD case (no pivoting) C IF (K50.EQ.1) THEN LREQ = 0 RETURN ENDIF C C L information is always computed C NBPANELS_L = (NASS / DMUMPS_OOC_PANEL_SIZE(NBROW_L))+1 LREQ = 1 ! Store NASS & + 1 ! Store NBPANELS_L & + NASS ! Store permutations & + NBPANELS_L ! Store pointers on permutations IF (K50.eq.0) THEN C C Also take U information into account C NBPANELS_U = (NASS / DMUMPS_OOC_PANEL_SIZE(NBCOL_U) ) +1 LREQ = LREQ + 1 ! Store NBPANELS_U & + NASS ! Store permutations & + NBPANELS_U ! Store pointers on permutations ENDIF RETURN END SUBROUTINE DMUMPS_OOC_GET_PP_SIZES SUBROUTINE DMUMPS_OOC_PP_CHECK_PERM_FREED & (IW_LOCATION, MUST_BE_PERMUTED) IMPLICIT NONE INTEGER, INTENT(IN) :: IW_LOCATION LOGICAL, INTENT(INOUT) :: MUST_BE_PERMUTED C C Purpose C ======= C C Reset MUST_BE_PERMUTED to .FALSE. when we detect C that the DMUMPS_OOC_PP_TRY_RELEASE_SPACE has freed C the permutation information (see that routine). C IF (IW_LOCATION .EQ. -7777) THEN MUST_BE_PERMUTED = .FALSE. ENDIF RETURN END SUBROUTINE DMUMPS_OOC_PP_CHECK_PERM_FREED MUMPS_5.8.1/src/cmumps_comm_buffer.F0000664000175000017500000032302715042446440017216 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_BUF USE MUMPS_BUF_COMMON, ONLY: BUF_CB, SIZE_RBUF_BYTES, & SIZEofINT, SIZEofREAL, OVHSIZE, BUF_ADJUST, BUF_LOOK, & MUMPS_BUF_SIZE_AVAILABLE PRIVATE INTEGER, SAVE :: BUF_LMAX_ARRAY REAL, DIMENSION(:), ALLOCATABLE & , SAVE, TARGET :: BUF_MAX_ARRAY PUBLIC :: BUF_LMAX_ARRAY, BUF_MAX_ARRAY PUBLIC :: CMUMPS_BUF_DEALL_MAX_ARRAY, & CMUMPS_BUF_MAX_ARRAY_MINSIZE PUBLIC :: CMUMPS_BUF_SEND_CB, & CMUMPS_BUF_SEND_MASTER2SLAVE, & CMUMPS_BUF_SEND_VCB, & CMUMPS_BUF_SEND_MAITRE2, & CMUMPS_BUF_SEND_CONTRIB_TYPE2, & CMUMPS_BUF_SEND_BLOCFACTO, & CMUMPS_BUF_SEND_BLFAC_SLAVE, & CMUMPS_BUF_SEND_CONTRIB_TYPE3, & CMUMPS_BUF_SEND_BACKVEC, & CMUMPS_MPI_UNPACK_LRB CONTAINS SUBROUTINE CMUMPS_BUF_DEALL_MAX_ARRAY() IMPLICIT NONE IF (allocated( BUF_MAX_ARRAY)) DEALLOCATE( BUF_MAX_ARRAY ) RETURN END SUBROUTINE CMUMPS_BUF_DEALL_MAX_ARRAY SUBROUTINE CMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IMPLICIT NONE INTEGER IERR, NFS4FATHER IERR = 0 IF (allocated( BUF_MAX_ARRAY)) THEN IF (BUF_LMAX_ARRAY .GE. NFS4FATHER) RETURN DEALLOCATE( BUF_MAX_ARRAY ) ENDIF BUF_LMAX_ARRAY=max(1,NFS4FATHER) ALLOCATE(BUF_MAX_ARRAY(BUF_LMAX_ARRAY),stat=IERR) IF ( IERR .GT. 0 ) THEN IERR = -1 RETURN END IF RETURN END SUBROUTINE CMUMPS_BUF_MAX_ARRAY_MINSIZE SUBROUTINE CMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, LCONT, & NASS, NPIV, & IWROW, IWCOL, A, PACKED_CB, & DEST, TAG, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER DEST, TAG, COMM, IERR INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER INODE, FPERE, NFRONT, LCONT, NASS, NPIV INTEGER IWROW( LCONT ), IWCOL( LCONT ) COMPLEX A( * ) LOGICAL PACKED_CB INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER NBROWS_PACKET INTEGER POSITION, IREQ, IPOS, I, J1 INTEGER SIZE1, SIZE2, SIZE_PACK, SIZE_AV, SIZE_AV_REALS INTEGER IZERO, IONE INTEGER SIZECB INTEGER LCONT_SENT INTEGER DEST2(1) PARAMETER( IZERO = 0, IONE = 1 ) LOGICAL RECV_BUF_SMALLER_THAN_SEND DOUBLE PRECISION TMP DEST2(1) = DEST IERR = 0 IF (NBROWS_ALREADY_SENT .EQ. 0) THEN CALL MPI_PACK_SIZE( 11 + LCONT + LCONT, MPI_INTEGER, & COMM, SIZE1, IERR_MPI) ELSE CALL MPI_PACK_SIZE( 5, MPI_INTEGER, COMM, SIZE1, IERR_MPI) ENDIF CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE SIZE_AV = SIZE_RBUF_BYTES RECV_BUF_SMALLER_THAN_SEND = .TRUE. ENDIF SIZE_AV_REALS = ( SIZE_AV - SIZE1 ) / SIZEofREAL IF (SIZE_AV_REALS < 0 ) THEN NBROWS_PACKET = 0 ELSE IF (PACKED_CB) THEN TMP=2.0D0*dble(NBROWS_ALREADY_SENT)+1.0D0 NBROWS_PACKET = int( & ( sqrt( TMP * TMP & + 8.0D0 * dble(SIZE_AV_REALS)) - TMP ) & / 2.0D0 ) ELSE IF (LCONT.EQ.0) THEN NBROWS_PACKET = 0 ELSE NBROWS_PACKET = SIZE_AV_REALS / LCONT ENDIF ENDIF ENDIF 10 CONTINUE NBROWS_PACKET = max(0, & min(NBROWS_PACKET, LCONT - NBROWS_ALREADY_SENT)) IF (NBROWS_PACKET .EQ. 0 .AND. LCONT .NE. 0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (PACKED_CB) THEN SIZECB = (NBROWS_ALREADY_SENT*NBROWS_PACKET)+(NBROWS_PACKET & *(NBROWS_PACKET+1))/2 ELSE SIZECB = NBROWS_PACKET * LCONT ENDIF CALL MPI_PACK_SIZE( SIZECB, MPI_COMPLEX, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV ) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF (NBROWS_PACKET > 0) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.LCONT .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 10 & .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , DEST2) IF (IERR .EQ. -1 .OR. IERR .EQ. -2) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF ( NBROWS_PACKET > 0 ) GOTO 10 ENDIF IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (PACKED_CB) THEN LCONT_SENT=-LCONT ELSE LCONT_SENT=LCONT ENDIF CALL MPI_PACK( LCONT_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NBROWS_ALREADY_SENT == 0) THEN CALL MPI_PACK( LCONT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NASS-NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LCONT , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IONE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IWROW, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IWCOL, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF IF ( LCONT .NE. 0 ) THEN J1 = 1 + NBROWS_ALREADY_SENT * NFRONT IF (PACKED_CB) THEN DO I = NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( A( J1 ), I, MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) J1 = J1 + NFRONT END DO ELSE DO I = NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( A( J1 ), LCONT, MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) J1 = J1 + NFRONT END DO ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN WRITE(*,*) 'Error Try_send_cb: SIZE, POSITION=',SIZE_PACK, & POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET IF (NBROWS_ALREADY_SENT .NE. LCONT ) THEN IERR = -1 RETURN ENDIF 100 CONTINUE RETURN END SUBROUTINE CMUMPS_BUF_SEND_CB SUBROUTINE CMUMPS_BUF_SEND_MASTER2SLAVE( NRHS, INODE, IFATH, & EFF_CB_SIZE, LD_CB, LD_PIV, NPIV, & JBDEB, JBFIN, & CB, SOL, & DEST, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER NRHS, INODE, IFATH, EFF_CB_SIZE, LD_CB, LD_PIV, NPIV INTEGER DEST, COMM, IERR, JBDEB, JBFIN COMPLEX CB( LD_CB*(NRHS-1)+EFF_CB_SIZE ) COMPLEX SOL( max(1, LD_PIV*(NRHS-1)+NPIV) ) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE, SIZE1, SIZE2, K INTEGER POSITION, IREQ, IPOS INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 CALL MPI_PACK_SIZE( 6, MPI_INTEGER, COMM, SIZE1, IERR ) CALL MPI_PACK_SIZE( NRHS * (EFF_CB_SIZE + NPIV), & MPI_COMPLEX, COMM, & SIZE2, IERR_MPI ) SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IFATH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( EFF_CB_SIZE , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPIV , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBDEB , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBFIN , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) DO K = 1, NRHS CALL MPI_PACK( CB ( 1 + LD_CB * (K-1) ), & EFF_CB_SIZE, MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) END DO IF ( NPIV .GT. 0 ) THEN DO K=1, NRHS CALL MPI_PACK( SOL(1+LD_PIV*(K-1)), & NPIV, MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDDO END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, Master2Slave, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) 'Try_send_master2slave: SIZE, POSITION = ', & SIZE, POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE CMUMPS_BUF_SEND_MASTER2SLAVE SUBROUTINE CMUMPS_BUF_SEND_VCB( NRHS_B, NODE1, NODE2, NCB, LDW, & LONG, & IW, W, JBDEB, JBFIN, & RHSINTR, NRHS, LRHSINTR, IPOSINRHSINTR, NPIV, & KEEP, & DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER LDW, DEST, TAG, COMM, IERR INTEGER NRHS_B, NODE1, NODE2, NCB, LONG, JBDEB, JBFIN INTEGER IW( max( 1, LONG ) ) INTEGER, INTENT(IN) :: LRHSINTR, NRHS, IPOSINRHSINTR, NPIV COMPLEX W( max( 1, LDW * NRHS_B ) ) COMPLEX RHSINTR(LRHSINTR,NRHS) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS INTEGER SIZE1, SIZE2, SIZE, K INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1)=DEST IERR = 0 IF ( NODE2 .EQ. 0 ) THEN CALL MPI_PACK_SIZE( 4+LONG, MPI_INTEGER, COMM, SIZE1, & IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 6+LONG, MPI_INTEGER, COMM, SIZE1, & IERR_MPI ) END IF SIZE2 = 0 IF ( LONG .GT. 0 ) THEN CALL MPI_PACK_SIZE( NRHS_B*LONG, MPI_COMPLEX, & COMM, SIZE2, IERR_MPI ) END IF SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = 0 CALL MPI_PACK( NODE1, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF ( NODE2 .NE. 0 ) THEN CALL MPI_PACK( NODE2, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( JBDEB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBFIN, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LONG, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF ( LONG .GT. 0 ) THEN CALL MPI_PACK( IW, LONG, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF (NODE2.EQ.0) THEN DO K=1, NRHS_B IF (NPIV.GT.0) THEN CALL MPI_PACK( RHSINTR(IPOSINRHSINTR,JBDEB+K-1), NPIV, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF IF (LONG-NPIV .NE.0) THEN CALL MPI_PACK( W(NPIV+1+(K-1)*LDW), LONG-NPIV, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF END DO ELSE DO K=1, NRHS_B CALL MPI_PACK( W(1+(K-1)*LDW), LONG, MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) END DO ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE CMUMPS_BUF_SEND_VCB SUBROUTINE CMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, & IPERE, ISON, NROW, & IROW, NCOL, ICOL, VAL, LDA, NELIM, TYPE_SON, & NSLAVES, SLAVES, DEST, COMM, IERR, & & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER LDA, NELIM, TYPE_SON INTEGER IPERE, ISON, NROW, NCOL, NSLAVES INTEGER IROW( NROW ) INTEGER ICOL( NCOL ) INTEGER SLAVES( NSLAVES ) COMPLEX VAL(LDA, *) INTEGER IPOS, IREQ, DEST, COMM, IERR INTEGER SLAVEF, KEEP(500), INIV2 INTEGER(8) KEEP8(150) INTEGER TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE1, SIZE2, SIZE3, SIZE_PACK, POSITION, I INTEGER NBROWS_PACKET, NCOL_SEND INTEGER SIZE_AV LOGICAL RECV_BUF_SMALLER_THAN_SEND INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 IF ( NELIM .NE. NROW ) THEN WRITE(*,*) 'Error in TRY_SEND_MAITRE2:',NELIM, NROW CALL MUMPS_ABORT() END IF IF (NBROWS_ALREADY_SENT .EQ. 0) THEN CALL MPI_PACK_SIZE( NROW+NCOL+7+NSLAVES, MPI_INTEGER, & COMM, SIZE1, IERR_MPI ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK_SIZE( NSLAVES+1, MPI_INTEGER, & COMM, SIZE3, IERR_MPI ) ELSE SIZE3 = 0 ENDIF SIZE1=SIZE1+SIZE3 ELSE CALL MPI_PACK_SIZE(7, MPI_INTEGER,COMM,SIZE1,IERR_MPI) ENDIF IF ( KEEP(50).ne.0 .AND. TYPE_SON .eq. 2 ) THEN NCOL_SEND = NROW ELSE NCOL_SEND = NCOL ENDIF CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF IF (NROW .GT. 0 ) THEN NBROWS_PACKET = (SIZE_AV - SIZE1) / NCOL_SEND / SIZEofREAL NBROWS_PACKET = min(NBROWS_PACKET, NROW - NBROWS_ALREADY_SENT) NBROWS_PACKET = max(NBROWS_PACKET, 0) ELSE NBROWS_PACKET =0 ENDIF IF (NBROWS_PACKET .EQ. 0 .AND. NROW .NE. 0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR=-1 GOTO 100 ENDIF ENDIF 10 CONTINUE CALL MPI_PACK_SIZE( NBROWS_PACKET * NCOL_SEND, & MPI_COMPLEX, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF ( NBROWS_PACKET .GT. 0 ) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NROW .AND. & SIZE_PACK - SIZE1 .LT. ( SIZE_RBUF_BYTES - SIZE1 ) / 10 & .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN GOTO 100 ENDIF POSITION = 0 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSLAVES, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NBROWS_ALREADY_SENT .EQ. 0) THEN IF (NSLAVES.GT.0) THEN CALL MPI_PACK( SLAVES, NSLAVES, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( IROW, NROW, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ICOL, NCOL, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK( TAB_POS_IN_PERE(1,INIV2), NSLAVES+1, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF IF (NBROWS_PACKET.GE.1) THEN DO I=NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( VAL(1,I), NCOL_SEND, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO ENDIF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, MAITRE2, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN write(*,*) 'Try_send_maitre2, SIZE,POSITION=', & SIZE_PACK,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET IF ( NBROWS_ALREADY_SENT .NE. NROW ) THEN IERR = -1 ENDIF 100 CONTINUE RETURN END SUBROUTINE CMUMPS_BUF_SEND_MAITRE2 SUBROUTINE CMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & DESC_IN_LU, & IPERE, NFRONT_PERE, NASS_PERE, NFS4FATHER, NSLAVES_PERE, & ISON, NBROW, LMAP, MAPROW, POS_FIRST_ROW_TO_PDEST, & IW_CBSON, A_CBSON, LA_CBSON, & ISLAVE, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP253_LOC, NVSCHUR, & SON_NIV, MYID ) USE CMUMPS_LR_TYPE USE CMUMPS_LR_DATA_M USE MUMPS_BUF_COMMON IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT(inout):: NBCOLS_ALREADY_SENT, & NBLRB_ALREADY_SENT INTEGER, INTENT (in) :: KEEP253_LOC, NVSCHUR INTEGER, INTENT (in) :: SON_NIV INTEGER, INTENT(in) :: POS_FIRST_ROW_TO_PDEST INTEGER IPERE, ISON, NBROW, MYID INTEGER PDEST, ISLAVE, COMM, IERR INTEGER PDEST_MASTER, NASS_PERE, NSLAVES_PERE, & NFRONT_PERE, LMAP INTEGER MAPROW( LMAP ) INTEGER IW_CBSON( * ) COMPLEX A_CBSON( : ) INTEGER(8) :: LA_CBSON LOGICAL DESC_IN_LU, PACKED_CB INTEGER KEEP(500), N , SLAVEF INTEGER(8) KEEP8(150) INTEGER STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER NFS4FATHER,SIZE3,PS1,NCA,LROW1 INTEGER(8) :: ASIZE LOGICAL COMPUTE_MAX REAL, POINTER, DIMENSION(:) :: M_ARRAY INTEGER NBROWS_PACKET INTEGER NBLRB_TOTAL INTEGER NBLRB_PACKET INTEGER MAX_ROW_LENGTH INTEGER LROW, NELIM INTEGER(8) :: ITMP8 INTEGER NPIV, NFRONT, HS INTEGER SIZE_PACK, SIZE0, SIZE1, SIZE2, POSITION,I INTEGER SIZE_INTEGERS, B, SIZE_REALS, TMPSIZE, ONEorTWO, SIZE_AV INTEGER SIZE_NEXT_BLOCK 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 LOGICAL AVOID_TOO_SMALL_GRANULARITY INTEGER PDEST2(1) LOGICAL CB_IS_LR TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL, & BEGS_BLR_STA INTEGER :: NB_ROW_SHIFT, NB_COL_SHIFT, NASS_SHIFT, PANEL2SEND, & CURRENT_PANEL_SIZE, NB_BLR_ROWS, NB_BLR_COLS, & CB_IS_LR_INT, NCOL_SHIFT, NROW_SHIFT, & PANEL_BEG_OFFSET INTEGER :: NPIV_LR, LNEXT REAL :: K170PER1000 PARAMETER ( IONE=1 ) INCLUDE 'mumps_headers.h' REAL ZERO PARAMETER (ZERO = 0.0E0) CB_IS_LR = (IW_CBSON(1+XXLR).EQ.1 & .OR. IW_CBSON(1+XXLR).EQ.3) NBLRB_PACKET = 0 NBLRB_TOTAL = 0 IF (CB_IS_LR) THEN CB_IS_LR_INT = 1 ELSE CB_IS_LR_INT = 0 ENDIF AVOID_TOO_SMALL_GRANULARITY = .TRUE. IF (KEEP(173).EQ.1) AVOID_TOO_SMALL_GRANULARITY = .FALSE. COMPUTE_MAX = (KEEP(219) .NE. 0) .AND. & (KEEP(50) .EQ. 2) .AND. & (PDEST.EQ.PDEST_MASTER) & .AND. (NBCOLS_ALREADY_SENT.EQ.0) & .AND. (NBROWS_ALREADY_SENT.EQ.0) IF (COMPUTE_MAX) THEN CALL CMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERR = -4 RETURN ENDIF ENDIF PDEST2(1) = PDEST IERR = 0 LROW = IW_CBSON( 1 + KEEP(IXSZ)) NELIM = IW_CBSON( 2 + KEEP(IXSZ)) NPIV = IW_CBSON( 4 + KEEP(IXSZ)) IF ( NPIV .LT. 0 ) THEN NPIV = 0 END IF NROW = IW_CBSON( 3 + KEEP(IXSZ)) NFRONT = LROW + NPIV HS = 6 + IW_CBSON( 6 + KEEP(IXSZ)) + KEEP(IXSZ) IF (CB_IS_LR.AND.NBROW.GT.0) THEN CALL CMUMPS_BLR_RETRIEVE_CB_LRB(IW_CBSON(1+XXF), CB_LRB) IF (SON_NIV.EQ.1) THEN CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW_CBSON(1+XXF), & BEGS_BLR_ROW) CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_DYN(IW_CBSON(1+XXF), & BEGS_BLR_COL) NB_BLR_ROWS = size(BEGS_BLR_ROW) - 1 CALL CMUMPS_BLR_RETRIEVE_NB_PANELS(IW_CBSON(1+XXF), & NB_COL_SHIFT) NB_ROW_SHIFT = NB_COL_SHIFT NASS_SHIFT = BEGS_BLR_ROW(NB_ROW_SHIFT+1)-1 NPIV_LR = BEGS_BLR_COL(NB_COL_SHIFT+1)-1 ELSE NPIV_LR=NPIV CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW_CBSON(1+XXF), & BEGS_BLR_STA) NB_BLR_ROWS = size(BEGS_BLR_STA) - 2 BEGS_BLR_ROW => BEGS_BLR_STA(2:NB_BLR_ROWS+2) CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_C(IW_CBSON(1+XXF), & BEGS_BLR_COL, NB_COL_SHIFT) NASS_SHIFT = 0 NB_ROW_SHIFT = 0 ENDIF PANEL2SEND = -1 DO I=NB_ROW_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR_ROW(I+1)-1-NASS_SHIFT & .GT.NBROWS_ALREADY_SENT+POS_FIRST_ROW_TO_PDEST-1) THEN PANEL2SEND = I EXIT ENDIF ENDDO IF (PANEL2SEND.EQ.-1) THEN write(*,*) 'Internal error: PANEL2SEND not found' CALL MUMPS_ABORT() ENDIF CURRENT_PANEL_SIZE = BEGS_BLR_ROW(PANEL2SEND+1) & - BEGS_BLR_ROW(PANEL2SEND) PANEL_BEG_OFFSET = POS_FIRST_ROW_TO_PDEST + & NBROWS_ALREADY_SENT - & BEGS_BLR_ROW(PANEL2SEND) + NASS_SHIFT IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR_COL) - 1 ELSEIF (SON_NIV.EQ.1) THEN NB_BLR_COLS = PANEL2SEND ELSE NB_BLR_COLS = -1 NCOL_SHIFT = NPIV_LR NROW_SHIFT = LROW - NROW DO I=NB_COL_SHIFT+1,size(BEGS_BLR_COL)-1 IF (BEGS_BLR_COL(I+1)-NCOL_SHIFT.GT. & ( min ( & BEGS_BLR_ROW(PANEL2SEND+1)-POS_FIRST_ROW_TO_PDEST, & NBROW & ) & + NROW_SHIFT + POS_FIRST_ROW_TO_PDEST-1 ) & ) THEN NB_BLR_COLS = I EXIT ENDIF ENDDO IF (NB_BLR_COLS.EQ.-1) THEN write(*,*) 'Internal error: NB_BLR_COLS not found' CALL MUMPS_ABORT() ENDIF MAX_ROW_LENGTH = BEGS_BLR_ROW(PANEL2SEND)-1+NROW_SHIFT & + min(NBROW-NBROWS_ALREADY_SENT + PANEL_BEG_OFFSET, & CURRENT_PANEL_SIZE) ENDIF NBLRB_TOTAL = NB_BLR_COLS - NB_COL_SHIFT ENDIF STATE_SON = IW_CBSON(1+XXS) IF (STATE_SON .EQ. S_NOLCBCONTIG) THEN LDA_SON8 = int(LROW,8) SHIFTCB_SON = int(NPIV,8)*int(NROW,8) ELSE IF (STATE_SON .EQ. S_NOLCLEANED) THEN LDA_SON8 = int(LROW,8) SHIFTCB_SON = 0_8 ELSE LDA_SON8 = int(NFRONT,8) SHIFTCB_SON = int(NPIV,8) ENDIF CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (PDEST .EQ. PDEST_MASTER) THEN SIZE_DESC_BANDE=0 ELSE SIZE_DESC_BANDE=(11+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, & 11+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(COMPUTE_MAX) THEN CALL MPI_PACK_SIZE(1, MPI_INTEGER, & COMM, SIZE0, IERR_MPI ) IF(NFS4FATHER .GT. 0) THEN CALL MPI_PACK_SIZE( NFS4FATHER, MPI_REAL, & COMM, SIZE1, IERR_MPI ) ENDIF SIZE1 = SIZE1+SIZE0 ENDIF ONEorTWO = 1 IF (PDEST .EQ.PDEST_MASTER) THEN L = 0 ELSE IF (KEEP(50) .EQ. 0) THEN L = LROW ELSE L = LROW + POS_FIRST_ROW_TO_PDEST-LMAP+NBROWS_ALREADY_SENT-1 ONEorTWO=ONEorTWO+1 ENDIF NBINT = 6 + L + 1 IF (CB_IS_LR.AND.NBROW.GT.0) THEN NBINT = NBINT + 4*(NB_BLR_COLS-NB_COL_SHIFT) + 3 ENDIF CALL MPI_PACK_SIZE( NBINT, MPI_INTEGER, & COMM, TMPSIZE, IERR_MPI ) SIZE1 = SIZE1 + TMPSIZE SIZE_AV = SIZE_AV - SIZE1 NOT_ENOUGH_SPACE=.FALSE. IF (SIZE_AV .LT.0 ) THEN NBROWS_PACKET = 0 NOT_ENOUGH_SPACE=.TRUE. ELSE IF ( KEEP(50) .EQ. 0 ) THEN NBROWS_PACKET = & SIZE_AV / ( ONEorTWO*SIZEofINT+LROW*SIZEofREAL) ELSE B = 2 * ONEorTWO + & ( -1 + 2 * LROW + 2 * POS_FIRST_ROW_TO_PDEST -2*LMAP & + 2 * NBROWS_ALREADY_SENT ) & * SIZEofREAL / SIZEofINT NBROWS_PACKET=int((dble(-B)+sqrt((dble(B)*dble(B))+ & dble(4)*dble(2)*dble(SIZE_AV)/dble(SIZEofINT) * & dble(SIZEofREAL/SIZEofINT)))* & dble(SIZEofINT) / dble(2) / dble(SIZEofREAL)) ENDIF ENDIF 10 CONTINUE SIZE_NEXT_BLOCK = 0 IF (CB_IS_LR) THEN IF ( NBROW .GT. 0) THEN NBROWS_PACKET = CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET ELSE NBROWS_PACKET = 0 ENDIF ENDIF NBROWS_PACKET = max( 0, NBROWS_PACKET) NBROWS_PACKET = min(NBROW-NBROWS_ALREADY_SENT, NBROWS_PACKET) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE .OR. & (NBROWS_PACKET .EQ.0.AND. NBROW.NE.0) IF (CB_IS_LR.AND.NBROW.GT.0.AND..NOT.NOT_ENOUGH_SPACE) THEN CALL MPI_PACK_SIZE( ONEorTWO* NBROWS_PACKET, MPI_INTEGER, & COMM, TMPSIZE, IERR_MPI ) CALL CMUMPS_BLR_GET_SIZEREALS_CB_LRB( & SIZE_AV-TMPSIZE, CB_LRB, & NB_ROW_SHIFT, PANEL2SEND, & NBLRB_ALREADY_SENT, NBLRB_TOTAL, & NBLRB_PACKET, SIZE_REALS, SIZE_NEXT_BLOCK & , KEEP(173) & ) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE.OR.(NBLRB_PACKET.EQ.0) ENDIF IF ( (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NBROW) .AND. & .NOT.CB_IS_LR & ) THEN IF (KEEP(50).EQ.0) THEN LNEXT = LROW + 1 ELSE MAX_ROW_LENGTH = LROW + POS_FIRST_ROW_TO_PDEST - LMAP & + NBROWS_ALREADY_SENT & + NBROWS_PACKET-1 LNEXT = MAX_ROW_LENGTH + 1 ENDIF LNEXT = LNEXT + ONEorTWO CALL MPI_PACK_SIZE( LNEXT, & MPI_COMPLEX, & COMM, SIZE_NEXT_BLOCK, IERR_MPI ) ENDIF IF (SIZE_NEXT_BLOCK.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF IF (NOT_ENOUGH_SPACE) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (CB_IS_LR.AND.NBROW.GT.0) THEN IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 ELSEIF (SON_NIV.EQ.1) THEN MAX_ROW_LENGTH = LROW+POS_FIRST_ROW_TO_PDEST -LMAP & + NBROWS_ALREADY_SENT & + NBROWS_PACKET-1 ENDIF ELSE IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 SIZE_REALS = NBROWS_PACKET * LROW ELSE SIZE_REALS = ( LROW + POS_FIRST_ROW_TO_PDEST - LMAP & + NBROWS_ALREADY_SENT ) * & NBROWS_PACKET + ( NBROWS_PACKET * & ( NBROWS_PACKET - 1) ) / 2 MAX_ROW_LENGTH = LROW + POS_FIRST_ROW_TO_PDEST - LMAP & + NBROWS_ALREADY_SENT & + NBROWS_PACKET-1 ENDIF ENDIF SIZE_INTEGERS = ONEorTWO* NBROWS_PACKET CALL MPI_PACK_SIZE( SIZE_REALS, MPI_COMPLEX, & COMM, SIZE2, IERR_MPI ) CALL MPI_PACK_SIZE( SIZE_INTEGERS, MPI_INTEGER, & COMM, SIZE3, IERR_MPI ) IF (SIZE2 + SIZE3 .GT. SIZE_AV .AND. .NOT.CB_IS_LR) THEN NBROWS_PACKET = NBROWS_PACKET -1 IF (NBROWS_PACKET .GT. 0 .AND..NOT.CB_IS_LR) THEN GOTO 10 ENDIF IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF SIZE_PACK = SIZE1 + SIZE2 + SIZE3 K170PER1000 = real(min(KEEP(170),500))/real(1000) IF ( .NOT.CB_IS_LR & .AND. (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NBROW) & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND & .AND. ( SIZE_PACK .LT. & int(real(SIZE_RBUF_BYTES)*K170PER1000) ) & .AND. & ( int(SIZE_PACK,8) + int(SIZE_NEXT_BLOCK,8) .LE. & int(SIZE_RBUF_BYTES,8) ) & ) THEN IERR = -1 GOTO 100 ENDIF IF ( CB_IS_LR.AND. & ( NBROWS_PACKET.NE.0 ).AND. & ( NBLRB_ALREADY_SENT+NBLRB_PACKET.NE. NBLRB_TOTAL ) & .AND. ( SIZE_PACK .LT. & int(real(SIZE_RBUF_BYTES)*K170PER1000) ) & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND & .AND. AVOID_TOO_SMALL_GRANULARITY & .AND. ( & int(SIZE_PACK,8) + int(SIZE_NEXT_BLOCK,8) .LE. & int(SIZE_RBUF_BYTES,8) ) & ) THEN IERR = -1 GOTO 100 ENDIF IF (SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , PDEST2) IF (IERR .EQ. -1 .OR. IERR.EQ. -2) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF (NBROWS_PACKET > 0 ) GOTO 10 ENDIF IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (KEEP(50)==0) THEN CALL MPI_PACK( LROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE IF (CB_IS_LR.AND. & NBLRB_ALREADY_SENT+NBLRB_PACKET .EQ. NBLRB_TOTAL) THEN CALL MPI_PACK( -MAX_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE CALL MPI_PACK( MAX_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( CB_IS_LR_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF ( PDEST .NE. PDEST_MASTER ) THEN IF (KEEP(50)==0) THEN CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), LROW, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE IF (MAX_ROW_LENGTH > 0) THEN CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), & MAX_ROW_LENGTH, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF END IF DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = POS_FIRST_ROW_TO_PDEST + J -1 INDICE_PERE=MAPROW(I) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IPERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE CALL MPI_PACK( INDICE_PERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO IF (CB_IS_LR.AND.(NBROW.GT.0)) THEN CALL CMUMPS_BLR_PACK_CB_LRB( & CB_LRB, NB_ROW_SHIFT, & NBCOLS_ALREADY_SENT, & NBLRB_ALREADY_SENT, NBLRB_PACKET, & PANEL2SEND, & PANEL_BEG_OFFSET+1, PANEL_BEG_OFFSET+NBROWS_PACKET, & BUF_CB%CONTENT(IPOS:), & SIZE_PACK, POSITION, COMM, IERR & ) GOTO 200 ENDIF DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = POS_FIRST_ROW_TO_PDEST + J -1 IF (KEEP(50).ne.0) THEN THIS_ROW_LENGTH = LROW + I - LMAP ELSE THIS_ROW_LENGTH = LROW ENDIF IF (DESC_IN_LU) THEN IF ( PACKED_CB ) THEN IF (NELIM.EQ.0) THEN ITMP8 = int(I,8) ELSE ITMP8 = int(NELIM+I,8) ENDIF APOS = ITMP8 * (ITMP8-1_8) / 2_8 + 1_8 ELSE APOS = int(I+NELIM-1, 8) * int(LROW,8) + 1_8 ENDIF ELSE IF ( PACKED_CB ) THEN IF ( LROW .EQ. NROW ) THEN ITMP8 = int(I,8) APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 ELSE ITMP8 = int(I + LROW - NROW,8) APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 - & int(LROW - NROW, 8) * int(LROW-NROW+1,8) / 2_8 ENDIF ELSE APOS = int( I - 1, 8 ) * LDA_SON8 + SHIFTCB_SON + 1_8 ENDIF ENDIF CALL MPI_PACK( A_CBSON( APOS ), THIS_ROW_LENGTH, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO 200 CONTINUE IF (COMPUTE_MAX) THEN CALL MPI_PACK(NFS4FATHER,1, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NFS4FATHER .GT. 0) THEN IF (CB_IS_LR) THEN CALL CMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW_CBSON(1+XXF), M_ARRAY) CALL MPI_PACK(M_ARRAY(1), NFS4FATHER, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL CMUMPS_BLR_FREE_M_ARRAY ( IW_CBSON(1+XXF) ) ELSE BUF_MAX_ARRAY(1:NFS4FATHER) = ZERO IF(MAPROW(NROW) .GT. NASS_PERE) THEN DO PS1=1,NROW IF(MAPROW(PS1).GT.NASS_PERE) EXIT ENDDO IF (DESC_IN_LU) THEN IF (PACKED_CB) THEN APOS = int(NELIM+PS1,8) * int(NELIM+PS1-1,8) / & 2_8 + 1_8 NCA = -44444 ASIZE = int(NROW,8) * int(NROW+1,8)/2_8 - & int(NELIM+PS1,8) * int(NELIM+PS1-1,8)/2_8 LROW1 = PS1 + NELIM ELSE APOS = int(PS1+NELIM-1,8) * int(LROW,8) + 1_8 NCA = LROW ASIZE = int(NCA,8) * int(NROW-PS1+1,8) LROW1 = LROW ENDIF ELSE IF (PACKED_CB) THEN IF (NPIV.NE.0) THEN WRITE(*,*) "Error in PARPIV/CMUMPS_BUF_SEND_CONTRIB_TYPE2" CALL MUMPS_ABORT() ENDIF LROW1=LROW-NROW+PS1 ITMP8 = int(PS1 + LROW - NROW,8) APOS = ITMP8 * (ITMP8 - 1_8) / 2_8 + 1_8 - & int(LROW-NROW,8)*int(LROW-NROW+1,8)/2_8 ASIZE = int(LROW,8)*int(LROW+1,8)/2_8 - & ITMP8*(ITMP8-1_8)/2_8 NCA = -555555 ELSE APOS = int(PS1-1,8) * LDA_SON8 + 1_8 + SHIFTCB_SON NCA = int(LDA_SON8) ASIZE = LA_CBSON - APOS + 1_8 LROW1=-666666 ENDIF ENDIF IF ( NROW-PS1+1-KEEP253_LOC-NVSCHUR .GT. 0 ) THEN CALL CMUMPS_COMPUTE_MAXPERCOL( & A_CBSON(APOS),ASIZE,NCA, & NROW-PS1+1-KEEP253_LOC-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB,LROW1) ENDIF ENDIF CALL MPI_PACK(BUF_MAX_ARRAY, NFS4FATHER, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF ENDIF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & PDEST, CONTRIB_TYPE2, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE_PACK.LT. POSITION ) THEN WRITE(*,*) ' contniv2: SIZE, POSITION =',SIZE_PACK, POSITION WRITE(*,*) ' NBROW, LROW = ', NBROW, LROW CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) IF (CB_IS_LR) THEN IF (NBLRB_ALREADY_SENT+NBLRB_PACKET.EQ.NBLRB_TOTAL) THEN NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ELSE NBLRB_ALREADY_SENT = NBLRB_ALREADY_SENT + NBLRB_PACKET ENDIF ELSE NBROWS_ALREADY_SENT=NBROWS_ALREADY_SENT + NBROWS_PACKET ENDIF IF (NBROWS_ALREADY_SENT .NE. NBROW ) THEN IERR = -1 ENDIF 100 CONTINUE RETURN END SUBROUTINE CMUMPS_BUF_SEND_CONTRIB_TYPE2 SUBROUTINE CMUMPS_BUF_SEND_BLOCFACTO( INODE, NFRONT, & NCOL, NPIV, FPERE, LASTPANEL, IPIV, VAL, & PDEST, NDEST, KEEP, NB_BLOC_FAC, & NSLAVES_TOT, WIDTH, COMM, & NELIM, NPARTSASS, CURRENT_BLR_PANEL, & LR_ACTIVATED, BLR_LorU, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & IBEG_PANEL, COMPRESS_CB, & ICNTL, IERR ) USE CMUMPS_LR_TYPE IMPLICIT NONE INTEGER, intent(in) :: INODE, NCOL, NPIV, & FPERE, NFRONT, NDEST INTEGER, intent(in) :: IPIV( NPIV ) COMPLEX, intent(in) :: VAL( NFRONT, * ) INTEGER, intent(in) :: PDEST( NDEST ) INTEGER, intent(inout) :: KEEP(500) INTEGER, intent(in) :: NB_BLOC_FAC, & NSLAVES_TOT, COMM, WIDTH LOGICAL, intent(in) :: LASTPANEL LOGICAL, intent(in) :: COMPRESS_CB LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(in) :: NELIM, NPARTSASS, CURRENT_BLR_PANEL, & IBEG_PANEL TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(inout) :: IERR INTEGER, INTENT(inout):: NBCOLS_ALREADY_SENT, & NBLRB_ALREADY_SENT INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE3, SIZET, & IDEST, IPOSMSG, I, SIZE_MSG_BYTES LOGICAL OVERFLOW INTEGER(8) :: SIZE2_8, SIZE3_8, SIZET_8, SIZE_OVERFLOW INTEGER NPIVSENT INTEGER :: LP LOGICAL :: LPOK LOGICAL :: RECV_BUF_SMALLER_THAN_SEND, NOT_ENOUGH_SPACE INTEGER :: DEST_BLOCFACTO, TAG_BLOCFACTO INTEGER :: LR_ACTIVATED_INT INTEGER :: NBINT, SIZE_AV, SIZE_AV_ADJUSTED INTEGER :: JBEG_BLOCK, NCOL_SEND, NCOL_MAX, & SIZE_BLR_LorU_SENT, NCOL_DIAG, NEWCOL_SENT INTEGER :: NBLRB_PACKET, SIZE_NEXT_BLOCK LOGICAL :: AVOID_TOO_SMALL_GRANULARITY INTEGER, PARAMETER :: kmaxcol=3 REAL :: K170PER1000 LP = ICNTL( 1 ) LPOK = ( LP.GT.0 .AND. ICNTL(4).GE.1 ) IERR = 0 OVERFLOW = .FALSE. NOT_ENOUGH_SPACE = .FALSE. NBLRB_PACKET = -9988 NCOL_DIAG = -9988 AVOID_TOO_SMALL_GRANULARITY = .TRUE. IF (KEEP(173).EQ.1) AVOID_TOO_SMALL_GRANULARITY = .FALSE. SIZE_OVERFLOW = 0_8 JBEG_BLOCK = NBCOLS_ALREADY_SENT + 1 NCOL_SEND = NCOL - JBEG_BLOCK + 1 NEWCOL_SENT = NCOL_SEND CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF IF ( & (KEEP(50).NE.0) .OR. & (KEEP(50).EQ.0.AND.JBEG_BLOCK.EQ.1) & ) THEN NBINT = NPIV ELSE NBINT = 0 ENDIF IF ( LASTPANEL ) THEN IF ( KEEP(50) .eq. 0 ) THEN NBINT = 9 + NBINT ELSE NBINT = 11 + NBINT END IF ELSE IF ( KEEP(50) .eq. 0 ) THEN NBINT = 8 + NBINT ELSE NBINT = 10 + NBINT END IF END IF IF (LR_ACTIVATED.AND.KEEP(50).EQ.0) THEN IF ( COMPRESS_CB .AND.(NPIV.GT.0) & .AND. IBEG_PANEL.EQ.1 .AND. (JBEG_BLOCK.EQ.1) & ) THEN NBINT = NBINT + size(BLR_LorU) + 1 ELSE NBINT = NBINT + 1 ENDIF ENDIF CALL MPI_PACK_SIZE( NBINT + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE2_8 = 0_8 SIZE_AV_ADJUSTED = SIZE_AV SIZE_NEXT_BLOCK = 0 IF ( (NPIV.GT.0) & ) THEN SIZE_AV_ADJUSTED = SIZE_AV_ADJUSTED - int(SIZE2_8) - SIZE1 NOT_ENOUGH_SPACE = (SIZE_AV_ADJUSTED.LE.0) IF (.NOT. LR_ACTIVATED) THEN NCOL_MAX = (SIZE_AV_ADJUSTED) / (NPIV*SIZEofREAL) NCOL_MAX = max(NCOL_MAX,0) NCOL_SEND = min( NCOL_SEND, NCOL_MAX) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE.OR. & (NCOL_SEND.EQ.0) .OR. & ((JBEG_BLOCK.EQ.1).AND.(NCOL_MAX.LT.NPIV)) IF (JBEG_BLOCK.EQ.1) NCOL_SEND = max(NCOL_SEND, NPIV) IF (KEEP(173).EQ.1) THEN IF (JBEG_BLOCK.EQ.1) THEN NCOL_SEND = min(NCOL_SEND, kmaxcol+NPIV) ELSE NCOL_SEND = min(NCOL_SEND, kmaxcol) ENDIF ENDIF NOT_ENOUGH_SPACE= NOT_ENOUGH_SPACE.OR. & (NCOL_SEND .GT. NCOL_MAX) SIZE3_8 = int(NPIV,8)*int(NCOL_SEND,8)*int(KEEP(35),8) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ELSE CALL MPI_PACK_SIZE( NPIV*NCOL_SEND, & MPI_COMPLEX, & COMM, SIZE3, IERR_MPI ) SIZE2_8 = SIZE2_8 + int(SIZE3,8) ENDIF NEWCOL_SENT = NCOL_SEND IF (NBCOLS_ALREADY_SENT+NEWCOL_SENT.LT.NCOL) THEN CALL MPI_PACK_SIZE( NPIV, & MPI_COMPLEX, & COMM, SIZE_NEXT_BLOCK, IERR_MPI ) ENDIF ELSE NCOL_DIAG = -9995 IF ((KEEP(50).NE.0).OR.(JBEG_BLOCK.EQ.1)) THEN SIZE3_8 = int(NPIV,8)*int(NPIV+NELIM,8)*int(KEEP(35),8) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ELSE CALL MPI_PACK_SIZE( NPIV*(NPIV+NELIM), & MPI_COMPLEX, & COMM, SIZE3, IERR_MPI ) SIZE2_8 = SIZE2_8+int(SIZE3,8) NCOL_SEND = NPIV+NELIM SIZE_AV_ADJUSTED = SIZE_AV_ADJUSTED - int(SIZE2_8) ENDIF ELSE NCOL_SEND = 0 ENDIF NCOL_DIAG = NCOL_SEND IF (JBEG_BLOCK.EQ.1) THEN NEWCOL_SENT = NCOL_DIAG ELSE NEWCOL_SENT = 0 ENDIF NOT_ENOUGH_SPACE = ( NOT_ENOUGH_SPACE.OR. & (SIZE_AV_ADJUSTED.LE.0) ) CALL CMUMPS_MPI_PACK_SIZE_LR_PARTIAL ( 0, & BLR_LorU, NBLRB_ALREADY_SENT, & SIZE_AV_ADJUSTED, KEEP(173), & NBLRB_PACKET, NCOL_SEND, SIZE3_8, & SIZE_NEXT_BLOCK, & COMM, IERR & ) NEWCOL_SENT = NEWCOL_SENT + (NCOL_SEND-NCOL_DIAG) NOT_ENOUGH_SPACE= ( NOT_ENOUGH_SPACE.OR. & (NEWCOL_SENT.EQ.0).OR. & (SIZE3_8.GT.int(SIZE_AV_ADJUSTED,8)) ) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ENDIF SIZE2_8 = SIZE2_8+SIZE3_8 ENDIF ENDIF IF (SIZE_NEXT_BLOCK.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF IF (NOT_ENOUGH_SPACE & ) THEN IF (RECV_BUF_SMALLER_THAN_SEND & ) THEN IERR = -3 RETURN ELSE IERR = -1 RETURN ENDIF ENDIF SIZET_8 = int(SIZE1,8) + SIZE2_8 IF (SIZET_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZET_8 ENDIF IF (OVERFLOW) THEN IERR=-3 IF (LPOK) WRITE(LP,*) & "Integer overflow message inCMUMPS_BUF_SEND_BLOCFACTO", & "SIZE_OVERFLOW,NPIV,NFRONT,NELIM=", & SIZE_OVERFLOW, NPIV, NFRONT, NELIM RETURN ENDIF SIZET = int(SIZET_8) IF (SIZET.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF K170PER1000 = real(min(KEEP(170),500))/real(1000) IF ( (NBCOLS_ALREADY_SENT+NEWCOL_SENT.LT.NCOL) & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND & .AND. ( SIZET .LT. & int(real(SIZE_RBUF_BYTES)*K170PER1000) ) & .AND. ( & int(SIZET,8) + int(SIZE_NEXT_BLOCK,8) .LE. & int(SIZE_RBUF_BYTES,8) ) & .AND. AVOID_TOO_SMALL_GRANULARITY & ) THEN IERR = -1 RETURN ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NDEST , PDEST) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_CB%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST SIZE_MSG_BYTES = SIZET - OVHSIZE * (NDEST-1) * KEEP(34) POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) NPIVSENT = NPIV IF (LASTPANEL) NPIVSENT = -NPIV CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF ( LASTPANEL .OR. KEEP(50).ne.0 ) THEN CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) END IF IF ( LASTPANEL .AND. KEEP(50) .NE. 0 ) THEN CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) END IF CALL MPI_PACK( NEWCOL_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBEG_BLOCK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NELIM, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPARTSASS, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( CURRENT_BLR_PANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN LR_ACTIVATED_INT = 1 ELSE LR_ACTIVATED_INT = 0 ENDIF CALL MPI_PACK( LR_ACTIVATED_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF ( KEEP(50) .ne. 0 ) THEN CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDIF IF (LR_ACTIVATED.AND.KEEP(50).EQ.0) THEN SIZE_BLR_LorU_SENT = 0 IF ( COMPRESS_CB .AND.(NPIV.GT.0) & .AND. IBEG_PANEL.EQ.1 .AND. (JBEG_BLOCK.EQ.1) & ) THEN SIZE_BLR_LorU_SENT = size(BLR_LorU) ENDIF CALL MPI_PACK( SIZE_BLR_LorU_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), & SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF (SIZE_BLR_LorU_SENT.GT.0) THEN DO I=1, size(BLR_LorU) CALL MPI_PACK( BLR_LorU(I)%M, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), & SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDDO ENDIF ENDIF IF ( (NPIV.GT.0) & ) THEN IF ( & (KEEP(50).NE.0) .OR. & (KEEP(50).EQ.0.AND.JBEG_BLOCK.EQ.1) & ) THEN CALL MPI_PACK( IPIV, NPIV, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(50).NE.0.OR.JBEG_BLOCK.EQ.1) THEN DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NPIV+NELIM, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) END DO ENDIF CALL CMUMPS_MPI_PACK_LR_PARTIAL( & BLR_LorU, NBLRB_ALREADY_SENT, NBLRB_PACKET, & BUF_CB%CONTENT(IPOSMSG: & IPOSMSG+(SIZE_MSG_BYTES+KEEP(34)-1)/KEEP(34)-1), & SIZE_MSG_BYTES, POSITION, COMM, IERR,KEEP(34) ) ELSE DO I = 1, NPIV CALL MPI_PACK( VAL(JBEG_BLOCK,I), NCOL_SEND, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) END DO ENDIF ENDIF DO IDEST = NDEST, 1, -1 DEST_BLOCFACTO = PDEST(IDEST) IF ( KEEP(50) .EQ. 0) THEN TAG_BLOCFACTO = BLOC_FACTO KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, & MPI_PACKED, & DEST_BLOCFACTO, TAG_BLOCFACTO, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) ELSE KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, & MPI_PACKED, & DEST_BLOCFACTO, BLOC_FACTO_SYM, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) END IF END DO IF (NBCOLS_ALREADY_SENT+NEWCOL_SENT.EQ.NCOL & ) THEN NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ELSE NBCOLS_ALREADY_SENT = NBCOLS_ALREADY_SENT + NEWCOL_SENT IF (LR_ACTIVATED) THEN NBLRB_ALREADY_SENT = NBLRB_ALREADY_SENT + NBLRB_PACKET ENDIF IERR = -1 ENDIF IF ( SIZE_MSG_BYTES .LT. POSITION ) THEN WRITE(*,*) ' Error sending blocfacto : size < position' WRITE(*,*) ' INODE= ', INODE, & ' Size,position= ',SIZE_MSG_BYTES,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_MSG_BYTES .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE CMUMPS_BUF_SEND_BLOCFACTO SUBROUTINE CMUMPS_BUF_SEND_BLFAC_SLAVE( INODE, & NPIV, FPERE, IPOSK, JPOSK, UIP21K, LUIP21K, NCOLU, & NDEST, PDEST, COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & NBCOLS_ALREADY_SENT, NBLRB_ALREADY_SENT, & NOTHING_WAS_SENT, & A , LA, POSBLOCFACTO, LD_BLOCFACTO, & IPIV, MAXI_CLUSTER, IERR, IERROR ) USE CMUMPS_LR_TYPE IMPLICIT NONE INTEGER INODE, NCOLU, IPOSK, JPOSK, NPIV, NDEST, FPERE INTEGER(8) :: LUIP21K COMPLEX UIP21K( : ) INTEGER PDEST( NDEST ) INTEGER COMM, IERR, IERROR INTEGER, INTENT(INOUT) :: KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: NBCOLS_ALREADY_SENT, & NBLRB_ALREADY_SENT LOGICAL, intent(out) :: NOTHING_WAS_SENT TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS INTEGER(8), intent(in) :: LA, POSBLOCFACTO INTEGER, intent(in) :: LD_BLOCFACTO, IPIV(NPIV), & MAXI_CLUSTER, IPANEL COMPLEX, intent(inout) :: A(LA) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER LR_ACTIVATED_INT INTEGER POSITION, IREQ, IPOS, SIZE1, SIZET, & IDEST, IPOSMSG, SSS, SIZE3, SIZE_MSG_BYTES INTEGER(8) :: SIZE2_8, SIZE3_8, SIZET_8, SIZE_OVERFLOW LOGICAL :: OVERFLOW, LASTBL_INPANEL INTEGER :: JBEG_BLOCK, NCOL_SEND, NCOL_MAX INTEGER :: SIZE_AV, SIZE_AV_ADJUSTED LOGICAL :: RECV_BUF_SMALLER_THAN_SEND, NOT_ENOUGH_SPACE INTEGER :: NBLRB_PACKET, SIZE_NEXT_BLOCK LOGICAL :: AVOID_TOO_SMALL_GRANULARITY INTEGER, PARAMETER :: kmaxcol=3 REAL :: K170PER1000 IERR = 0 OVERFLOW = .FALSE. SIZE_OVERFLOW = 0_8 JBEG_BLOCK = NBCOLS_ALREADY_SENT + 1 NCOL_SEND = NCOLU - JBEG_BLOCK + 1 NBLRB_PACKET = -9977 NOTHING_WAS_SENT = .TRUE. AVOID_TOO_SMALL_GRANULARITY = .TRUE. IF (KEEP(173).EQ.1) AVOID_TOO_SMALL_GRANULARITY = .FALSE. CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF CALL MPI_PACK_SIZE( 8 + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE2_8 = 0_8 SIZE_AV_ADJUSTED = SIZE_AV - SIZE1 SIZE_NEXT_BLOCK = 0 NOT_ENOUGH_SPACE = (SIZE_AV_ADJUSTED.LE.0) IF (.NOT. LR_ACTIVATED) THEN NCOL_MAX = (SIZE_AV_ADJUSTED) / (NPIV*SIZEofREAL) NCOL_MAX = max(NCOL_MAX,0) NCOL_SEND = min( NCOL_SEND, NCOL_MAX) IF (KEEP(173).EQ.1) THEN NCOL_SEND = min(NCOL_SEND, kmaxcol) ENDIF NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE.OR.(NCOL_SEND.EQ.0) SIZE3_8 = int(NPIV,8)*int(NCOL_SEND,8) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ELSE CALL MPI_PACK_SIZE( abs(NPIV)*NCOL_SEND, & MPI_COMPLEX, & COMM, SIZE3, IERR_MPI ) SIZE2_8=SIZE2_8 + int(SIZE3,8) ENDIF IF (NBCOLS_ALREADY_SENT+NCOL_SEND.LT.NCOLU) THEN CALL MPI_PACK_SIZE( NPIV, & MPI_COMPLEX, & COMM, SIZE_NEXT_BLOCK, IERR_MPI ) ENDIF ELSE NCOL_SEND = 0 NOT_ENOUGH_SPACE = ( NOT_ENOUGH_SPACE.OR. & (SIZE_AV_ADJUSTED.LE.0) ) CALL CMUMPS_MPI_PACK_SIZE_LR_PARTIAL ( 1, & BLR_LS, NBLRB_ALREADY_SENT, & SIZE_AV_ADJUSTED, KEEP(173), & NBLRB_PACKET, NCOL_SEND, SIZE3_8, & SIZE_NEXT_BLOCK, & COMM, IERR & ) NOT_ENOUGH_SPACE= ( NOT_ENOUGH_SPACE.OR. & (NCOL_SEND.EQ.0).OR. & (SIZE3_8.GT.int(SIZE_AV_ADJUSTED,8)) ) IF (SIZE3_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZE3_8 ENDIF SIZE2_8 = SIZE2_8+SIZE3_8 ENDIF IF (SIZE_NEXT_BLOCK.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF IF (NOT_ENOUGH_SPACE) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 RETURN ELSE IERR = -1 RETURN ENDIF ENDIF SIZET_8 = int(SIZE1,8) + SIZE2_8 IF (SIZET_8 .GT. int(huge(SIZE3),8)) THEN OVERFLOW = .TRUE. SIZE_OVERFLOW = SIZET_8 ENDIF IF (OVERFLOW) THEN IERR=-3 RETURN ENDIF SIZET = int(SIZET_8) IF (SIZET.GT.SIZE_RBUF_BYTES) THEN CALL MPI_PACK_SIZE( 6 , & MPI_INTEGER, COMM, SSS, IERR_MPI ) SIZE2_8 = int(SSS,8)+SIZE2_8 IF (int(SIZE2_8).GT.SIZE_RBUF_BYTES) THEN IERR = -2 RETURN ENDIF END IF K170PER1000 = real(min(KEEP(170),500))/real(1000) IF ((NBCOLS_ALREADY_SENT+NCOL_SEND.LT.NCOLU) & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND & .AND. ( SIZET .LT. & int(real(SIZE_RBUF_BYTES)*K170PER1000) ) & .AND. ( & int(SIZET,8) + int(SIZE_NEXT_BLOCK,8) .LE. & int(SIZE_RBUF_BYTES,8) ) & .AND. AVOID_TOO_SMALL_GRANULARITY & ) THEN IERR = -1 RETURN ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NDEST, PDEST) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_CB%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST SIZE_MSG_BYTES = SIZET - OVHSIZE * (NDEST-1) * KEEP(34) POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JPOSK+JBEG_BLOCK-1, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) LASTBL_INPANEL = (NBCOLS_ALREADY_SENT+NCOL_SEND.EQ.NCOLU) IF (LASTBL_INPANEL) THEN CALL MPI_PACK( -NCOL_SEND, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ELSE CALL MPI_PACK( NCOL_SEND, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDIF IF (LR_ACTIVATED) THEN LR_ACTIVATED_INT = 1 ELSE LR_ACTIVATED_INT = 0 ENDIF CALL MPI_PACK( LR_ACTIVATED_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IPANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN CALL CMUMPS_MPI_PACKSCALE_LR_PARTIAL( BLR_LS, & NBLRB_ALREADY_SENT, NBLRB_PACKET, & BUF_CB%CONTENT( IPOSMSG: & IPOSMSG+(SIZE_MSG_BYTES+KEEP(34)-1)/KEEP(34)-1 ), & SIZE_MSG_BYTES, POSITION, COMM, & A, LA, POSBLOCFACTO, LD_BLOCFACTO, & IPIV, NPIV, MAXI_CLUSTER, IERR, IERROR ) IF (IERR.LT.0) RETURN ELSE CALL MPI_PACK( UIP21K(1_8+int(JBEG_BLOCK-1,8)*int(NPIV,8)), & NPIV * NCOL_SEND, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZE_MSG_BYTES, & POSITION, COMM, IERR_MPI ) ENDIF NOTHING_WAS_SENT = .FALSE. DO IDEST = 1, NDEST KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, & PDEST(IDEST), BLOC_FACTO_SYM_SLAVE, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) END DO IF ( LASTBL_INPANEL ) THEN NBCOLS_ALREADY_SENT = 0 NBLRB_ALREADY_SENT = 0 ELSE NBCOLS_ALREADY_SENT = NBCOLS_ALREADY_SENT + NCOL_SEND IF (LR_ACTIVATED) THEN NBLRB_ALREADY_SENT = NBLRB_ALREADY_SENT + NBLRB_PACKET ENDIF IERR = -1 ENDIF IF ( SIZE_MSG_BYTES .LT. POSITION ) THEN WRITE(*,*) ' Error sending blfac slave : size < position' WRITE(*,*) ' Size,position=',SIZE_MSG_BYTES,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_MSG_BYTES .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE CMUMPS_BUF_SEND_BLFAC_SLAVE SUBROUTINE CMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) 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, INTENT(IN) :: RG2L(N) INTEGER NSUPROW, NSUPCOL INTEGER(8), INTENT(IN) :: TABSIZE INTEGER SIZE_PACK INTEGER KEEP(500) COMPLEX VAL_SON( LD_SON, * ), TAB(*) LOGICAL TRANSP INTEGER N_ALREADY_SENT INTEGER :: NELIM_ROOT, NELIM_ROW, NELIM_COL INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER SIZE1, SIZE2, SIZE_AV, POSITION INTEGER SIZE_CBP, SIZE_TMP INTEGER IREQ, IPOS, ITAB INTEGER ISUB, JSUB, I, J INTEGER ILOC_ROOT, JLOC_ROOT INTEGER IPOS_ROOT, JPOS_ROOT INTEGER IONE LOGICAL RECV_BUF_SMALLER_THAN_SEND INTEGER PDEST2(1) PARAMETER ( IONE=1 ) INTEGER N_PACKET INTEGER NSUBSET_ROW_EFF, NSUBSET_COL_EFF, NSUPCOL_EFF PDEST2(1) = PDEST IERR = 0 IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN CALL MUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF SIZE_AV = min(SIZE_AV, SIZE_RBUF_BYTES) CALL MPI_PACK_SIZE(8 + NSUBSET_COL, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE_CBP = 0 IF (N_ALREADY_SENT .EQ. 0 .AND. & min(NSUPROW,NSUPCOL) .GT.0) THEN CALL MPI_PACK_SIZE(NSUPROW, MPI_INTEGER, COMM, & SIZE_CBP, IERR_MPI ) CALL MPI_PACK_SIZE(NSUPCOL, MPI_INTEGER, COMM, & SIZE_TMP, IERR_MPI ) SIZE_CBP = SIZE_CBP + SIZE_TMP CALL MPI_PACK_SIZE(NSUPROW*NSUPCOL, & MPI_COMPLEX, COMM, & SIZE_TMP, IERR_MPI ) SIZE_CBP = SIZE_CBP + SIZE_TMP SIZE1 = SIZE1 + SIZE_CBP ENDIF IF (BBPCBP.EQ.1) THEN NSUBSET_COL_EFF = NSUBSET_COL - NSUPCOL NSUPCOL_EFF = 0 ELSE NSUBSET_COL_EFF = NSUBSET_COL NSUPCOL_EFF = NSUPCOL ENDIF NSUBSET_ROW_EFF = NSUBSET_ROW - NSUPROW N_PACKET = & (SIZE_AV - SIZE1) / (SIZEofINT + NSUBSET_COL_EFF * SIZEofREAL) 10 CONTINUE N_PACKET = min( N_PACKET, & NSUBSET_ROW_EFF-N_ALREADY_SENT ) IF (N_PACKET .LE. 0 .AND. & NSUBSET_ROW_EFF-N_ALREADY_SENT.GT.0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF CALL MPI_PACK_SIZE( 8 + NSUBSET_COL_EFF + N_PACKET, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE1 = SIZE1 + SIZE_CBP CALL MPI_PACK_SIZE( N_PACKET * NSUBSET_COL_EFF, & MPI_COMPLEX, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV) THEN N_PACKET = N_PACKET - 1 IF ( N_PACKET > 0 ) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (N_PACKET + N_ALREADY_SENT .NE. NSUBSET_ROW - NSUPROW & .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 10 & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF ELSE N_PACKET = 0 CALL MPI_PACK_SIZE(8,MPI_INTEGER, COMM, SIZE_PACK, IERR_MPI ) END IF IF ( SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE, PDEST2 & ) IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUBSET_ROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUPROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUBSET_COL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUPCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( N_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( N_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( BBPCBP, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN IF (N_ALREADY_SENT .EQ. 0 .AND. & min(NSUPROW, NSUPCOL) .GT. 0) THEN DO ISUB = NSUBSET_ROW-NSUPROW+1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IF ( I .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L(INDCOL_SON( I )) ENDIF ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO DO ISUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( ISUB ) JPOS_ROOT = INDROW_SON( J ) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO IF ( TABSIZE.GE.int(NSUPROW,8)*int(NSUPCOL,8) ) THEN ITAB = 1 DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW J = SUBSET_ROW(JSUB) DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL I = SUBSET_COL(ISUB) TAB(ITAB) = VAL_SON(J, I) ITAB = ITAB + 1 ENDDO ENDDO CALL MPI_PACK(TAB(1), NSUPROW*NSUPCOL, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ELSE DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW J = SUBSET_ROW(JSUB) DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL I = SUBSET_COL(ISUB) CALL MPI_PACK(VAL_SON(J,I), 1, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO ENDDO ENDIF ENDIF IF ( .NOT. TRANSP ) THEN DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) IF ( I .LE. NELIM_ROW ) THEN IPOS_ROOT = NELIM_ROOT + I - 1 ELSE IPOS_ROOT = RG2L( INDROW_SON( I ) ) ENDIF ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO JSUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF J = SUBSET_COL( JSUB ) IF ( J .LE. NELIM_COL ) THEN JPOS_ROOT = NELIM_ROOT + J - 1 ELSE JPOS_ROOT = RG2L( INDCOL_SON( J ) ) ENDIF JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO JSUB = NSUBSET_COL_EFF-NSUPCOL_EFF+1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) JPOS_ROOT = INDCOL_SON( J ) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO ELSE DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) IF ( J .LE. NELIM_COL ) THEN IPOS_ROOT = NELIM_ROOT + J - 1 ELSE IPOS_ROOT = RG2L( INDCOL_SON( J ) ) ENDIF ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO ISUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF I = SUBSET_COL( ISUB ) IF ( I .LE. NELIM_ROW ) THEN JPOS_ROOT = NELIM_ROOT + I - 1 ELSE JPOS_ROOT = RG2L( INDROW_SON( I ) ) ENDIF JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO ISUB = NSUBSET_COL_EFF - NSUPCOL_EFF + 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) JPOS_ROOT = INDROW_SON(I) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO END IF IF ( TABSIZE.GE.int(N_PACKET,8)*int(NSUBSET_COL_EFF,8) ) THEN IF ( .NOT. TRANSP ) THEN ITAB = 1 DO ISUB = N_ALREADY_SENT+1, & N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) DO JSUB = 1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) TAB( ITAB ) = VAL_SON(J,I) ITAB = ITAB + 1 END DO END DO CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ELSE ITAB = 1 DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) DO ISUB = 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) TAB( ITAB ) = VAL_SON( J, I ) ITAB = ITAB + 1 END DO END DO CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END IF ELSE IF ( .NOT. TRANSP ) THEN DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) DO JSUB = 1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) CALL MPI_PACK( VAL_SON( J, I ), 1, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO END DO ELSE DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) DO ISUB = 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) CALL MPI_PACK( VAL_SON( J, I ), 1, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO END DO END IF ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & PDEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN WRITE(*,*) ' Error sending contribution to root:Size 0) THEN SCALED(1:BLR(I)%K,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * BLR(I)%R(1:BLR(I)%K,J) J = J+1 CALL MPI_PACK( SCALED(1,1), BLR(I)%K, & MPI_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) ELSE PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) PIV2 = A(POSELTD+LD_DIAG*J+J) OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) BLOCK(1:BLR(I)%K) = BLR(I)%R(1:BLR(I)%K,J) SCALED(1:BLR(I)%K,1) = PIV1 * BLR(I)%R(1:BLR(I)%K,J) & + OFFDIAG * BLR(I)%R(1:BLR(I)%K,J+1) CALL MPI_PACK( SCALED(1,1), BLR(I)%K, & MPI_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) SCALED(1:BLR(I)%K,2) = OFFDIAG * BLOCK(1:BLR(I)%K) & + PIV2 * BLR(I)%R(1:BLR(I)%K,J+1) J =J+2 CALL MPI_PACK( SCALED(1,2), BLR(I)%K, & MPI_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) ENDIF END DO ENDIF ELSE J = 1 DO WHILE (J <= BLR(I)%N) IF (IPIV(J) > 0) THEN SCALED(1:BLR(I)%M,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * BLR(I)%Q(1:BLR(I)%M,J) CALL MPI_PACK( SCALED(1,1), BLR(I)%M, & MPI_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) J = J+1 ELSE PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) PIV2 = A(POSELTD+LD_DIAG*J+J) OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) BLOCK(1:BLR(I)%M) = BLR(I)%Q(1:BLR(I)%M,J) SCALED(1:BLR(I)%M,1) = PIV1 * BLR(I)%Q(1:BLR(I)%M,J) & + OFFDIAG * BLR(I)%Q(1:BLR(I)%M,J+1) CALL MPI_PACK( SCALED(1,1), BLR(I)%M, & MPI_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) SCALED(1:BLR(I)%M,2) = OFFDIAG * BLOCK(1:BLR(I)%M) & + PIV2 * BLR(I)%Q(1:BLR(I)%M,J+1) CALL MPI_PACK( SCALED(1,2), BLR(I)%M, & MPI_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) J=J+2 ENDIF END DO ENDIF ENDDO 500 CONTINUE IF (allocated(BLOCK)) deallocate(BLOCK) IF (allocated(SCALED)) deallocate(SCALED) 600 CONTINUE RETURN END SUBROUTINE CMUMPS_MPI_PACKSCALE_LR_PARTIAL END MODULE CMUMPS_BUF MUMPS_5.8.1/src/sol_omp_common_m.F0000664000175000017500000000454715042446423016706 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C*********************************************************************** MODULE MUMPS_SOL_L0OMP_M C C Purpose: C ======= C Manage locks for right-looking updates of RHSINTR unde L0 threads C !$ USE OMP_LIB, ONLY: OMP_LOCK_KIND INTEGER, PARAMETER :: NB_LOCK_MAX = 18 !$ INTEGER(OMP_LOCK_KIND), !$ &ALLOCATABLE, DIMENSION(:), SAVE :: LOCK_FOR_SCATTER C C CONTAINS C SUBROUTINE MUMPS_SOL_L0OMP_LI( K400 ) !$ USE OMP_LIB, ONLY: OMP_INIT_LOCK IMPLICIT NONE C C Purpose: C ======= C Initialize locks for forward solution with L0-threads feature C (LI suffix: Lock Initialization) C C Argument: C ======== C K400: the number of threads for L0-threads; C we use min(K400, NB_LOCK_MAX) locks. C INTEGER, INTENT(IN) :: K400 C !$ INTEGER :: I C C Executable statements C ===================== C !$ IF (K400 .GT. 0) THEN !$ ALLOCATE(LOCK_FOR_SCATTER(min(NB_LOCK_MAX,K400))) !$ DO I = 1, min(NB_LOCK_MAX,K400) !$ CALL OMP_INIT_LOCK(LOCK_FOR_SCATTER(I)) !$ ENDDO !$ ENDIF RETURN END SUBROUTINE MUMPS_SOL_L0OMP_LI SUBROUTINE MUMPS_SOL_L0OMP_LD( K400 ) !$ USE OMP_LIB, ONLY : OMP_DESTROY_LOCK IMPLICIT NONE C C Purpose: C ======= C Destroy locks for forward solution with L0-threads feature C (LD suffix: Lock Destruction) C C Argument: C ======== C K400: the number of threads for L0-threads; C we use min(K400, NB_LOCK_MAX) locks. INTEGER, INTENT(IN) :: K400 C !$ INTEGER :: I C C Executable statements C ===================== C !$ IF (allocated(LOCK_FOR_SCATTER)) THEN !$ IF (K400 .GT. 0) THEN !$ DO I = 1, min(NB_LOCK_MAX,K400) !$ CALL OMP_DESTROY_LOCK(LOCK_FOR_SCATTER(I)) !$ ENDDO !$ DEALLOCATE(LOCK_FOR_SCATTER) !$ ENDIF !$ ENDIF RETURN END SUBROUTINE MUMPS_SOL_L0OMP_LD END MODULE MUMPS_SOL_L0OMP_M MUMPS_5.8.1/src/sfac_omp_m.F0000664000175000017500000015330515042446437015457 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_OMP_M INTEGER(8), PARAMETER :: UnderL0 = -20_8 INTEGER(8), PARAMETER :: CopyNotStarted = -19_8 INTEGER(8), PARAMETER :: WaitMem = -18_8 INTEGER(8), PARAMETER :: CopyFactorsFinished = -17_8 INTEGER(8), PARAMETER :: AllocateViderCBEnCours = -16_8 INTEGER(8), PARAMETER :: Finished = -15_8 CONTAINS SUBROUTINE SMUMPS_FAC_L0_OMP(N,LIW, NSTK_STEPS, ND, & FILS,STEP, FRERE, DAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PTRIST, PTRAST, PIMASTER, PAMASTER, PTRARW, PTRAIW, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, & RHS_MUMPS, RINFO, NBROOT, NBRTOT, NBROOT_UNDER_L0, UU, ICNTL, & PTLUST_S, PTRFAC, INFO, KEEP, KEEP8, PROCNODE_STEPS,SLAVEF, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & INTARR, DBLARR, root, roota, PERM, NELT, FRTPTR, FRTELT, LPTRAR, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB, NE, DKEEP, PIVNUL_LIST_STRUCT, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP, PHYS_L0_OMP, PERM_L0_OMP, PTR_LEAFS_L0_OMP, & L0_OMP_MAPPING, LL0_OMP_MAPPING, THREAD_LA, & MUMPS_TPS_ARR, SMUMPS_TPS_ARR, & NSTEPSW, OPASSW, OPELIW, NELVAW, COMP, & MAXFRW, NMAXNPIVW, NPVW, NOFFNEGW, NULLNEGW, & NB22T1W, NBTINYW, DET_EXPW, DET_MANTW, DET_SIGNW, & LRGROUPS, L0_OMP_FACTORS, LL0_OMP_FACTORS, & I4_L0_OMP, NBSTATS_I4, NBCOLS_I4, & I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 ) USE MUMPS_LOAD !$ USE OMP_LIB USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T USE SMUMPS_TPS_M, ONLY : SMUMPS_TPS_T USE MUMPS_LR_STATS USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC, & SMUMPS_L0OMPFAC_T USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : & SMUMPS_DM_FAC_ALLOC_ALLOWED, & SMUMPS_DM_ALLOC_S_WK, & SMUMPS_DM_FREE_S_WK USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER N,LIW, LPTRAR, & NSTEPSW, INFO(80) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER(8), INTENT(IN) :: THREAD_LA INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST_S(KEEP(28)), PERM(N) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NE(KEEP(28)) REAL RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER NBROOT INTEGER NBRTOT INTEGER, intent(out) :: NBROOT_UNDER_L0 INTEGER COMM_LOAD, ASS_IRECV REAL UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) REAL DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) DOUBLE PRECISION :: OPASSW, OPELIW INTEGER LRGROUPS(KEEP(280)) INTEGER, INTENT ( IN ) :: LPOOL_B_L0_OMP INTEGER, INTENT ( IN ) :: IPOOL_B_L0_OMP & ( LPOOL_B_L0_OMP ) INTEGER, INTENT ( IN ) :: L_PHYS_L0_OMP INTEGER, INTENT ( IN ) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT ( IN ) :: L_VIRT_L0_OMP INTEGER, INTENT ( IN ) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT ( IN ) :: VIRT_L0_OMP_MAPPING( L_VIRT_L0_OMP ) INTEGER, INTENT ( IN ) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT ( IN ) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT ( IN ) :: LL0_OMP_MAPPING INTEGER, INTENT ( OUT ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) TYPE (MUMPS_TPS_T), DIMENSION(:) :: MUMPS_TPS_ARR TYPE (SMUMPS_TPS_T), DIMENSION(:) :: SMUMPS_TPS_ARR INTEGER, INTENT ( IN ) :: LL0_OMP_FACTORS TYPE (SMUMPS_L0OMPFAC_T), INTENT(INOUT) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER, INTENT (IN) :: NBSTATS_I4, NBSTATS_I8 INTEGER, INTENT (IN) :: NBCOLS_I4, NBCOLS_I8 INTEGER, INTENT (IN) :: I4_L0_OMP(NBSTATS_I4, NBCOLS_I4) INTEGER(8), INTENT (IN) :: I8_L0_OMP(NBSTATS_I8, NBCOLS_I8) LOGICAL SMUMPS_POOL_EMPTY EXTERNAL SMUMPS_POOL_EMPTY, SMUMPS_EXTRACT_POOL INTEGER :: MYTHREAD_ID, ITH INTEGER :: THREAD_ID_P DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 INTEGER INODE, LEAF INTEGER TYPEF INTEGER NBFIN INTEGER TYPE INTEGER NBROOT_PROCESSED INTEGER MAXFRW, NPVW, NMAXNPIVW, NOFFNEGW, NULLNEGW, NELVAW, COMP INTEGER :: NB22T1W, NBTINYW, DET_EXPW, DET_SIGNW REAL :: DET_MANTW DOUBLE PRECISION FLOP_ESTIM_ACC INTEGER :: LPOOL_P INTEGER, DIMENSION(:), ALLOCATABLE :: IPOOL_P INTEGER(8) :: TO_ALLOCATE INTEGER, DIMENSION(:), ALLOCATABLE :: ID INTEGER(8), DIMENSION(:), ALLOCATABLE :: VAL INTEGER(8), ALLOCATABLE, DIMENSION(:) :: STATE, SIZE_COPIED INTEGER :: NbWaitMem, NbFinished, NbOnGoingCopies, NbUnderL0 INTEGER(8) :: KEEP8_77_SAVE DOUBLE PRECISION :: GTIME INTEGER(8) :: MEMDISPO_UNDERL0, MEMDISPO_PERTHREAD INTEGER :: BLR_STRAT INTEGER :: VIRTUAL_TASK, PHYSICAL_TASK INTEGER :: IFATH INTEGER :: I, INFO_P(2), allocok INTEGER(8) :: I8 !$ INTEGER(8) :: CHUNK8 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP_SAVE, NOMP_TOTAL !$ INTEGER :: NOMP_INNER !$ LOGICAL :: SAVE_NESTED CALL MUMPS_LOAD_DISABLE() GTIME = MPI_WTIME() L0_OMP_MAPPING = 0 NBROOT_PROCESSED = 0 NSTEPSW = 0 OPASSW = DZERO OPELIW = DZERO NELVAW = 0 COMP = 0 MAXFRW = 0 NMAXNPIVW = 0 NOFFNEGW = 0 NULLNEGW = 0 FLOP_ESTIM_ACC = DZERO NPVW = 0 NB22T1W = 0 NBTINYW = 0 DET_EXPW = 0 DET_MANTW = cmplx(1.0E0,0.0E0, kind=kind(1.0E0)) DET_SIGNW = 1 DO ITH = 1, KEEP(400) NULLIFY(MUMPS_TPS_ARR(ITH)%IW) NULLIFY(MUMPS_TPS_ARR(ITH)%ITLOC) NULLIFY(SMUMPS_TPS_ARR(ITH)%A) CALL SMUMPS_SET_MAXS_MAXIS_THREAD( & MUMPS_TPS_ARR(ITH)%LA, & MUMPS_TPS_ARR(ITH)%LIW, BLR_STRAT, & KEEP, & I4_L0_OMP(1,ITH), NBSTATS_I4, & I8_L0_OMP(1,ITH), NBSTATS_I8) ENDDO IF (KEEP8(4) .NE. 0_8) THEN CALL SMUMPS_MA_EFF_MEM_DISPO ( & MUMPS_TPS_ARR, KEEP(400),KEEP8, KEEP, & N, BLR_STRAT, LPOOL_B_L0_OMP, & I8_L0_OMP, NBSTATS_I8, & MEMDISPO_UNDERL0 & ) IF (KEEP(486).EQ.2) THEN MEMDISPO_UNDERL0 = max(MEMDISPO_UNDERL0/20_8,0_8) ELSE MEMDISPO_UNDERL0 = max(MEMDISPO_UNDERL0/4_8,0_8) ENDIF KEEP8(77) = KEEP8(77) + MEMDISPO_UNDERL0 MEMDISPO_PERTHREAD = 0_8 IF (MEMDISPO_UNDERL0.GT.0) THEN MEMDISPO_PERTHREAD = MEMDISPO_UNDERL0/(int(KEEP(400),8)) ENDIF DO ITH = 1, KEEP(400) MUMPS_TPS_ARR(ITH)%LA = MUMPS_TPS_ARR(ITH)%LA + & MEMDISPO_PERTHREAD ENDDO ENDIF DO ITH = 1, KEEP(400) MUMPS_TPS_ARR(ITH)%LRLU = MUMPS_TPS_ARR(ITH)%LA MUMPS_TPS_ARR(ITH)%LRLUS = MUMPS_TPS_ARR(ITH)%LA MUMPS_TPS_ARR(ITH)%LRLUSM = MUMPS_TPS_ARR(ITH)%LA MUMPS_TPS_ARR(ITH)%IPTRLU = MUMPS_TPS_ARR(ITH)%LA MUMPS_TPS_ARR(ITH)%POSFAC = 1_8 MUMPS_TPS_ARR(ITH)%IWPOS = 1 MUMPS_TPS_ARR(ITH)%IWPOSCB = MUMPS_TPS_ARR(ITH)%LIW ENDDO IF (KEEP(406) .EQ. 2 ) THEN ALLOCATE(STATE(KEEP(400)), SIZE_COPIED(KEEP(400)), stat=allocok) IF (allocok .GT. 0 ) THEN WRITE(*,*) "Problem allocating STATE/SIZE_COPIED", KEEP(400) CALL MUMPS_ABORT() ENDIF CALL SMUMPS_PERFORM_COPIES_INIT( STATE, KEEP8_77_SAVE, & NbWaitMem, NbFinished, NbOnGoingCopies, NbUnderL0, & KEEP, KEEP8 ) ENDIF !$ NOMP_INNER = 1 !$ IF (KEEP(369).GT.0) THEN !$ NOMP_TOTAL = omp_get_max_threads() !$ IF ( NOMP_TOTAL .NE. KEEP(400) ) THEN !$ IF ( KEEP(439) .GT. 1 ) THEN !$ NOMP_INNER = KEEP(439) !$ ELSE IF ( KEEP(439) .EQ. -1 !$ & ) THEN !$ NOMP_INNER = NOMP_TOTAL / KEEP(400) !$ ENDIF !$ IF (NOMP_INNER .GT. 1) THEN !$ SAVE_NESTED = omp_get_nested() !$ CALL OMP_SET_NESTED(.TRUE.) !$ ENDIF !$ ENDIF #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(KEEP(400),4)) #else !$ CALL omp_set_num_threads(KEEP(400)) #endif !$ ENDIF !$OMP PARALLEL !$OMP& SHARED ( IPOOL_B_L0_OMP, LPOOL_B_L0_OMP ) !$OMP& PRIVATE ( VIRTUAL_TASK, PHYSICAL_TASK, !$OMP& IPOOL_P, LPOOL_P, LEAF, INODE, IFATH, INFO_P, I, I8, !$OMP& TO_ALLOCATE, THREAD_ID_P, !$OMP& TYPE, TYPEF, NOMP_SAVE, allocok ) !$OMP& REDUCTION ( + : NPVW, OPASSW, OPELIW, NOFFNEGW, NELVAW, COMP, !$OMP& NB22T1W, NBTINYW, DET_EXPW, NULLNEGW, !$OMP& FLOP_ESTIM_ACC, NBROOT_PROCESSED, NSTEPSW ) !$OMP& REDUCTION ( * : DET_MANTW, DET_SIGNW ) !$OMP& REDUCTION ( max : MAXFRW, NMAXNPIVW ) THREAD_ID_P = 1 !$ THREAD_ID_P = OMP_GET_THREAD_NUM () + 1 !$OMP BARRIER !$ NOMP_SAVE = omp_get_max_threads() #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_INNER,4)) #else !$ CALL omp_set_num_threads(NOMP_INNER) #endif LPOOL_P = LPOOL_B_L0_OMP LEAF = 1 INFO_P = 0 VIRTUAL_TASK = 0 !$ IF ( omp_get_num_threads() .NE. KEEP(400) ) THEN !$ INFO_P(1)=-58 !$ INFO_P(2)=-100-omp_get_num_threads() !$ GOTO 700 !$ ENDIF CALL SMUMPS_DM_FAC_ALLOC_ALLOWED( MUMPS_TPS_ARR(THREAD_ID_P)%LA, & KEEP8, & INFO_P(1), INFO_P(2) ) IF (INFO_P(1) .LT. 0) GOTO 700 CALL SMUMPS_DM_ALLOC_S_WK( SMUMPS_TPS_ARR(THREAD_ID_P)%A, & max(1_8,MUMPS_TPS_ARR(THREAD_ID_P)%LA), allocok, KEEP(430), & KEEP(35) ) IF (allocok.GT.0) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4( MUMPS_TPS_ARR(THREAD_ID_P)%LA, & INFO_P(2)) GOTO 700 ELSE CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & MUMPS_TPS_ARR(THREAD_ID_P)%LA, & KEEP(405).EQ.1, & KEEP8, INFO_P(1), INFO_P(2), & .FALSE., .FALSE. ) IF (INFO_P(1) .LT. 0) THEN GOTO 700 ENDIF ENDIF TO_ALLOCATE = & ((int(MUMPS_TPS_ARR(THREAD_ID_P)%LIW,8) * int(KEEP(34),8 )) / & int(KEEP(35),8 ))+ & ((int(LPOOL_P,8) * int(KEEP(34),8 )) / int(KEEP(35),8 ))+ & ((int(N+KEEP(253),8) * int(KEEP(34),8 )) / int(KEEP(35),8 )) CALL SMUMPS_DM_FAC_ALLOC_ALLOWED( TO_ALLOCATE, & KEEP8, INFO_P(1), INFO_P(2) ) IF ( INFO_P(1) .LT. 0 ) GOTO 700 ALLOCATE ( MUMPS_TPS_ARR(THREAD_ID_P)%IW( & MUMPS_TPS_ARR(THREAD_ID_P)%LIW ), & IPOOL_P ( LPOOL_P ), & MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC ( N + KEEP(253) ), & stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO_P(1) = -13 INFO_P(2) = MUMPS_TPS_ARR(THREAD_ID_P)%LIW + & LPOOL_P + N+KEEP(253) GOTO 700 ELSE CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( TO_ALLOCATE, & KEEP(405).EQ.1, KEEP8, & INFO_P(1), INFO_P(2), .TRUE., .FALSE. ) IF (INFO_P(1) .LT. 0) THEN GOTO 700 ENDIF ENDIF CALL SMUMPS_ALLOC_CB( .FALSE., 0_8, & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, DKEEP, & MUMPS_TPS_ARR(THREAD_ID_P)%IW(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LIW, & SMUMPS_TPS_ARR(THREAD_ID_P)%A(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LA, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%IPTRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOS, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUSM, & INFO_P(1), INFO_P(2) & ) CALL SMUMPS_INIT_POOL_LAST3( IPOOL_P(1), LPOOL_P, & LEAF ) MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC = 0 600 CONTINUE VIRTUAL_TASK = VIRTUAL_TASK + 1 IF ( VIRTUAL_TASK .LT. L_VIRT_L0_OMP ) THEN IF ( VIRT_L0_OMP_MAPPING( VIRTUAL_TASK ) .EQ. THREAD_ID_P ) THEN DO PHYSICAL_TASK = & VIRT_L0_OMP ( VIRTUAL_TASK ), & VIRT_L0_OMP ( VIRTUAL_TASK + 1 ) - 1 DO I = PTR_LEAFS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK )+1 ) + 1, & PTR_LEAFS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK ) ) IF (IPOOL_B_L0_OMP(I) .GT. 0) THEN CALL SMUMPS_INSERT_POOL_N( N, IPOOL_P(1), & LPOOL_P, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), 3, 0, 1, STEP, & IPOOL_B_L0_OMP(I) ) END IF END DO DO WHILE ( & .NOT. SMUMPS_POOL_EMPTY( IPOOL_P(1), LPOOL_P ) & .AND. INFO_P(1) .GE. 0 ) CALL SMUMPS_EXTRACT_POOL( N, IPOOL_P(1), LPOOL_P, & PROCNODE_STEPS, SLAVEF, STEP, INODE, KEEP, KEEP8, MYID_NODES, & ND, .FALSE. ) 10 CONTINUE L0_OMP_MAPPING ( STEP ( INODE ) ) = THREAD_ID_P IFATH = DAD ( STEP ( INODE ) ) TYPE = 1 IF ( IFATH .NE. 0 ) THEN TYPEF = 1 ELSE TYPEF = -9999 ENDIF CALL MUMPS_STOP_ON_USER_REQUEST(KEEP, KEEP8, ICNTL, & INFO_P, MYID) IF (INFO_P(1) .LT. 0) THEN GOTO 700 ENDIF IF (THREAD_ID_P .EQ. KEEP(400)-1) THEN CALL SMUMPS_UPDATE_PROGRESS( OPELIW*KEEP(400), KEEP8 ) ENDIF CALL SMUMPS_PROCESS_FRONT_NIV1(COMM_LOAD, ASS_IRECV, N, INODE, & TYPE, TYPEF, MUMPS_TPS_ARR(THREAD_ID_P)%LA, MUMPS_TPS_ARR(THREAD & _ID_P)%IW(1), MUMPS_TPS_ARR(THREAD_ID_P)%LIW, SMUMPS_TPS_ARR( & THREAD_ID_P)%A(1), MAXFRW, NOFFNEGW, NULLNEGW, NPVW, & NB22T1W, NBTINYW, DET_EXPW, DET_MANTW, DET_SIGNW, INFO_P, UU, & SEUIL, SEUIL_LDLT_NIV2, OPELIW, NELVAW, NMAXNPIVW, NSTEPSW, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & NE, MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS, MUMPS_TPS_ARR(THREAD_ID_P)% % LRLUSM, MUMPS_TPS_ARR(THREAD_ID_P)%IPTRLU, ICNTL, KEEP, KEEP8, & DKEEP, PIVNUL_LIST_STRUCT, COMP, MUMPS_TPS_ARR(THREAD_ID_P)% & IWPOS, MUMPS_TPS_ARR(THREAD_ID_P)%IWPOSCB, PROCNODE_STEPS, & SLAVEF, IFATH, COMM_NODES, MYID_NODES, IPOOL_P, LPOOL_P, LEAF, & PERM, NSTK_STEPS, BUFR, LBUFR, LBUFR_BYTES, & NBFIN, root, roota, OPASSW, MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC(1), & RHS_MUMPS, FILS, PTRARW, PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, & PTRDEBARR, INTARR, DBLARR, ND, FRERE, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS, FLOP_ESTIM_ACC ) IF (INFO_P(1) .LT. 0) THEN GOTO 700 ENDIF IF ( IFATH .NE. 0 ) THEN IF ( PHYS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK ) ) & .NE. INODE ) THEN NSTK_STEPS ( STEP ( IFATH ) ) = & NSTK_STEPS ( STEP ( IFATH ) ) - 1 IF ( NSTK_STEPS ( STEP ( IFATH ) ) .EQ. 0 ) THEN INODE = IFATH GOTO 10 ENDIF ELSE !$OMP ATOMIC UPDATE NSTK_STEPS ( STEP ( IFATH ) ) = & NSTK_STEPS ( STEP ( IFATH ) ) - 1 !$OMP END ATOMIC END IF ELSE NBROOT_PROCESSED = NBROOT_PROCESSED + 1 END IF END DO END DO ENDIF GOTO 600 ENDIF 700 CONTINUE IF (associated(MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC)) THEN DEALLOCATE(MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC) NULLIFY(MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -(int(N+KEEP(253),8) * int(KEEP(34),8 )) / int(KEEP(35),8), & KEEP(405).EQ.1, KEEP8, & INFO_P(1), INFO_P(2), .TRUE., .FALSE. ) ENDIF IF (allocated(IPOOL_P)) THEN DEALLOCATE(IPOOL_P); CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -(int(LPOOL_P,8) * int(KEEP(34),8 )) / int(KEEP(35),8), & KEEP(405).EQ.1, KEEP8, & INFO_P(1), INFO_P(2), .TRUE., .FALSE. ) ENDIF IF ( KEEP(406) .EQ. 2) THEN CALL SMUMPS_PERFORM_COPIES( THREAD_ID_P, & MUMPS_TPS_ARR, SMUMPS_TPS_ARR, & L0_OMP_FACTORS, LL0_OMP_FACTORS, & STATE, SIZE_COPIED, & NbWaitMem, NbFinished, NbOngoingCopies, NbUnderL0, & MYID_NODES, N, SLAVEF, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & KEEP, KEEP8, INFO_P & ) ELSE IF ((KEEP(407) .EQ. 1) .OR. (KEEP(406) .EQ.1) ) THEN IF (INFO_P(1) .GE. 0) THEN CALL SMUMPS_DM_CBSTATIC2DYNAMIC_I & (2, & 0_8, & .FALSE., & MYID_NODES, N, SLAVEF, KEEP, KEEP8, & MUMPS_TPS_ARR(THREAD_ID_P)%IW(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LIW, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOSCB, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOS, & SMUMPS_TPS_ARR(THREAD_ID_P)%A(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LA, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%IPTRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & INFO_P(1), INFO_P(2) ) ENDIF ENDIF IF (KEEP(406) .EQ.1) THEN IF (INFO_P(1) .GE.0 )THEN TO_ALLOCATE = max(MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1,1_8) CALL SMUMPS_DM_FAC_ALLOC_ALLOWED( TO_ALLOCATE, & KEEP8, INFO_P(1), INFO_P(2) ) ENDIF IF (INFO_P(1) .GE.0 )THEN ALLOCATE(L0_OMP_FACTORS(THREAD_ID_P)%A(TO_ALLOCATE), & stat=allocok) IF (allocok .GT. 0) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4(TO_ALLOCATE, INFO_P(2)) L0_OMP_FACTORS(THREAD_ID_P)%LA = 0_8 ELSE L0_OMP_FACTORS(THREAD_ID_P)%LA = & MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8 CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & L0_OMP_FACTORS(THREAD_ID_P)%LA, KEEP(405).EQ.1, KEEP8, & INFO_P(1), INFO_P(2), .TRUE., .FALSE. ) ENDIF ENDIF IF (INFO_P(1) .GE.0 ) THEN DO I8 = 1_8, MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8 L0_OMP_FACTORS(THREAD_ID_P)%A(I8) = & SMUMPS_TPS_ARR(THREAD_ID_P)%A(I8) ENDDO ENDIF IF ( associated(SMUMPS_TPS_ARR(THREAD_ID_P)%A)) THEN CALL SMUMPS_DM_FREE_S_WK( SMUMPS_TPS_ARR(THREAD_ID_P)%A, & KEEP(430) ) NULLIFY(SMUMPS_TPS_ARR(THREAD_ID_P)%A) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -MUMPS_TPS_ARR(THREAD_ID_P)%LA, & KEEP(405).EQ.1, & KEEP8, & INFO_P(1), INFO_P(2), & .FALSE., .FALSE. ) IF (INFO_P(1) .GE. 0) THEN !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - L0_OMP_FACTORS(THREAD_ID_P)%LA !$OMP END ATOMIC ENDIF ENDIF ENDIF ENDIF IF (INFO_P(1) .LT.0) THEN !$OMP CRITICAL(critical_info) INFO(1) = INFO_P(1) INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ELSE IF (INFO_P(1) .GE. 0) THEN !$OMP CRITICAL(critical_info) IF (INFO(1) .EQ. 0) THEN INFO(1) = INFO_P(1) INFO(2) = INFO_P(2) ENDIF !$OMP END CRITICAL(critical_info) ENDIF #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_SAVE,4)) #else !$ CALL omp_set_num_threads(NOMP_SAVE) #endif !$OMP END PARALLEL !$ IF (KEEP(369).GT.0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_TOTAL),4)) #else !$ CALL omp_set_num_threads(NOMP_TOTAL) #endif !$ IF (NOMP_INNER .GT. 1) THEN !$ CALL OMP_SET_NESTED(SAVE_NESTED) !$ ENDIF !$ ENDIF IF (INFO(1) .LT. 0) THEN IF (ICNTL(1) .GT. 0 .AND. ICNTL(4) .GE.1 ) THEN WRITE(ICNTL(1),'(A,I6,I16,A,I5,A)') & "** ERROR DURING L0_OMP: INFO(1:2)=", & INFO(1), INFO(2), " (MPI worker ", MYID_NODES,")" ENDIF ENDIF IF ( KEEP(406) .EQ. 0 ) THEN ALLOCATE(ID(KEEP(400)), VAL(KEEP(400)), & stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = KEEP(400) GOTO 800 ENDIF DO MYTHREAD_ID = 1, KEEP(400) VAL (MYTHREAD_ID) = MUMPS_TPS_ARR( MYTHREAD_ID )%POSFAC-1_8 ID (MYTHREAD_ID) = MYTHREAD_ID ENDDO CALL MUMPS_SORT_INT8(KEEP(400), VAL, ID) DO ITH=1, KEEP(400) MYTHREAD_ID = ID(ITH) IF ((KEEP(407).NE.1) .AND. (KEEP(406).EQ.0)) THEN IF (INFO(1) .GE. 0) THEN CALL SMUMPS_DM_CBSTATIC2DYNAMIC_I & (2, & 0_8, & .FALSE., & MYID_NODES, N, SLAVEF, KEEP, KEEP8, & MUMPS_TPS_ARR(MYTHREAD_ID)%IW(1), & MUMPS_TPS_ARR(MYTHREAD_ID)%LIW, & MUMPS_TPS_ARR(MYTHREAD_ID)%IWPOSCB, & MUMPS_TPS_ARR(MYTHREAD_ID)%IWPOS, & SMUMPS_TPS_ARR(MYTHREAD_ID)%A(1), & MUMPS_TPS_ARR(MYTHREAD_ID)%LA, & MUMPS_TPS_ARR(MYTHREAD_ID)%LRLU, & MUMPS_TPS_ARR(MYTHREAD_ID)%IPTRLU, & MUMPS_TPS_ARR(MYTHREAD_ID)%LRLUS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & INFO(1), INFO(2) ) ENDIF ENDIF IF (KEEP(406).EQ.0) THEN IF (INFO(1) .GE. 0 )THEN TO_ALLOCATE = max(MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC-1,1_8) CALL SMUMPS_DM_FAC_ALLOC_ALLOWED( TO_ALLOCATE, & KEEP8, INFO(1), INFO(2) ) ENDIF IF (INFO(1) .GE.0 ) THEN ALLOCATE(L0_OMP_FACTORS(MYTHREAD_ID)%A(TO_ALLOCATE), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1) = -13 CALL MUMPS_SETI8TOI4(TO_ALLOCATE, INFO(2)) L0_OMP_FACTORS(MYTHREAD_ID)%LA = 0_8 ELSE L0_OMP_FACTORS(MYTHREAD_ID)%LA = & MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC-1_8 CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & L0_OMP_FACTORS(MYTHREAD_ID)%LA, & KEEP(405).EQ.1, KEEP8, & INFO(1), INFO(2), .TRUE., .FALSE. ) ENDIF ENDIF IF (INFO(1) .GE. 0) THEN !$ CHUNK8 = max( int(KEEP(361),8), !$ & (MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC+KEEP(400)-2_8) / !$ & KEEP(400) ) !$ OMP_FLAG = ( (MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC-1_8 > !$ & int(KEEP(361),8)) !$ & .AND. (KEEP(400).GT.1) !$ & ) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (OMP_FLAG) DO I8 = 1_8, MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC-1_8 L0_OMP_FACTORS(MYTHREAD_ID)%A(I8) = & SMUMPS_TPS_ARR(MYTHREAD_ID)%A(I8) ENDDO !$OMP END PARALLEL DO ENDIF IF ( associated(SMUMPS_TPS_ARR(MYTHREAD_ID)%A)) THEN CALL SMUMPS_DM_FREE_S_WK( SMUMPS_TPS_ARR(THREAD_ID_P)%A, & KEEP(430) ) NULLIFY(SMUMPS_TPS_ARR(MYTHREAD_ID)%A) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -MUMPS_TPS_ARR(MYTHREAD_ID)%LA, & KEEP(405).EQ.1, KEEP8, & INFO(1), INFO(2), & .FALSE., .FALSE. ) IF (INFO(1).GE.0) THEN KEEP8(69) = KEEP8(69) - L0_OMP_FACTORS(MYTHREAD_ID)%LA ENDIF ENDIF ENDIF ENDDO IF (ALLOCATED(ID)) DEALLOCATE(ID) IF (ALLOCATED(VAL)) DEALLOCATE(VAL) ENDIF 800 CONTINUE DO ITH = 1, KEEP(400) IF ( associated(SMUMPS_TPS_ARR(ITH)%A)) THEN CALL SMUMPS_DM_FREE_S_WK( SMUMPS_TPS_ARR(ITH)%A, & KEEP(430) ) NULLIFY(SMUMPS_TPS_ARR(ITH)%A) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -MUMPS_TPS_ARR(ITH)%LA, & KEEP(405).EQ.1, KEEP8, & INFO(1), INFO(2), & .FALSE., .FALSE. ) IF (INFO(1).GE.0) THEN KEEP8(69) = KEEP8(69) - L0_OMP_FACTORS(ITH)%LA ENDIF ENDIF ENDDO KEEP8(64) = 0_8 DO I = 1, KEEP(400) KEEP8(64) = KEEP8(64) + MUMPS_TPS_ARR(I)%POSFAC - 1_8 ENDDO KEEP8(62) = 0_8 DO I = 1, KEEP(400) KEEP8(62) = KEEP8(62) + MUMPS_TPS_ARR(I)%LRLUSM ENDDO NBROOT_UNDER_L0 = NBROOT_PROCESSED DKEEP(95) = real(MPI_WTIME() - GTIME) IF (KEEP(486) .NE. 0) THEN TIME_UPDATE = TIME_UPDATE/dble(KEEP(400)) TIME_COMPRESS = TIME_COMPRESS/dble(KEEP(400)) TIME_FRSWAP_COMPRESS = TIME_FRSWAP_COMPRESS/dble(KEEP(400)) TIME_CB_COMPRESS = TIME_CB_COMPRESS/dble(KEEP(400)) TIME_PANEL = TIME_PANEL/dble(KEEP(400)) TIME_FAC_I = TIME_FAC_I/dble(KEEP(400)) TIME_FAC_MQ = TIME_FAC_MQ/dble(KEEP(400)) TIME_FAC_SQ = TIME_FAC_SQ/dble(KEEP(400)) TIME_FRFRONTS = TIME_FRFRONTS/dble(KEEP(400)) TIME_LRTRSM = TIME_LRTRSM/dble(KEEP(400)) TIME_FRTRSM = TIME_FRTRSM/dble(KEEP(400)) TIME_LR_MODULE = TIME_LR_MODULE/dble(KEEP(400)) TIME_DECOMP = TIME_DECOMP/dble(KEEP(400)) TIME_DIAGCOPY = TIME_DIAGCOPY/dble(KEEP(400)) TIME_DECOMP_UCFS = TIME_DECOMP_UCFS/dble(KEEP(400)) TIME_LRASM_NIV1 = TIME_LRASM_NIV1/dble(KEEP(400)) TIME_LRASM_LOCASM2 = TIME_LRASM_LOCASM2/dble(KEEP(400)) TIME_LRASM_MAPLIG1 = TIME_LRASM_MAPLIG1/dble(KEEP(400)) TIME_LRASM_CONTRIB2 = TIME_LRASM_CONTRIB2/dble(KEEP(400)) TIME_FRASM_LOCASM2 = TIME_FRASM_LOCASM2/dble(KEEP(400)) TIME_FRASM_MAPLIG1 = TIME_FRASM_MAPLIG1/dble(KEEP(400)) TIME_FRASM_CONTRIB2 = TIME_FRASM_CONTRIB2/dble(KEEP(400)) ENDIF DKEEP(97) = DKEEP(97) / real(KEEP(400)) CALL MUMPS_LOAD_ENABLE() CALL MUMPS_LOAD_UPDATE(0,.FALSE., FLOP_ESTIM_ACC,KEEP,KEEP8) RETURN END SUBROUTINE SMUMPS_FAC_L0_OMP SUBROUTINE SMUMPS_SET_MAXS_MAXIS_THREAD(MAXS_BASE_RELAXED8TH, & MAXIS_BASE_RELAXEDTH, BLR_STRAT, & KEEP, & I4_L0_OMPTH, NBSTATS_I4, & I8_L0_OMPTH, NBSTATS_I8) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP(500), NBSTATS_I4, NBSTATS_I8 INTEGER, INTENT(IN) :: I4_L0_OMPTH(NBSTATS_I4) INTEGER(8), INTENT(IN) :: I8_L0_OMPTH(NBSTATS_I8) INTEGER(8), INTENT(OUT) :: MAXS_BASE_RELAXED8TH INTEGER, INTENT(OUT) :: MAXIS_BASE_RELAXEDTH INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER :: PERLU INTEGER(8) :: MAXS_BASE8TH INTEGER(8) :: MAXIS_BASE_RELAXEDTH8 PERLU = KEEP(12) CALL SMUMPS_SET_BLRSTRAT_AND_MAXS ( MAXS_BASE8TH, & MAXS_BASE_RELAXED8TH, BLR_STRAT, KEEP(1), & I8_L0_OMPTH(2), I8_L0_OMPTH(3), I8_L0_OMPTH(5), & I8_L0_OMPTH(6), I8_L0_OMPTH(7), I8_L0_OMPTH(8) ) IF ( KEEP(201) .EQ. 0 ) THEN MAXIS_BASE_RELAXEDTH8 = int(I4_L0_OMPTH(2),8) ELSE MAXIS_BASE_RELAXEDTH8 = int(I4_L0_OMPTH(4),8) ENDIF MAXIS_BASE_RELAXEDTH8 = max( 1_8, & MAXIS_BASE_RELAXEDTH8 + 3 * max(PERLU,10) * & ( MAXIS_BASE_RELAXEDTH8 / 100 + 1 ) & ) MAXIS_BASE_RELAXEDTH8 = min(MAXIS_BASE_RELAXEDTH8, & int( huge( MAXIS_BASE_RELAXEDTH ) ,8) & ) MAXIS_BASE_RELAXEDTH = int( MAXIS_BASE_RELAXEDTH8 ) RETURN END SUBROUTINE SMUMPS_SET_MAXS_MAXIS_THREAD SUBROUTINE SMUMPS_MA_EFF_MEM_DISPO( & MUMPS_TPS_ARR, NBTHREADS, KEEP8, KEEP, & N, BLR_STRAT, LPOOL_P, & I8_L0_OMP, NBSTATS_I8, & MEMDISPO_UNDERL0) USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T IMPLICIT NONE INTEGER, INTENT(IN) :: N, BLR_STRAT, KEEP(500) INTEGER, INTENT(IN) :: NBSTATS_I8, NBTHREADS, LPOOL_P INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER(8), INTENT(IN) :: I8_L0_OMP(NBSTATS_I8,NBTHREADS) INTEGER(8), INTENT(OUT) :: MEMDISPO_UNDERL0 TYPE (MUMPS_TPS_T), INTENT(IN) :: MUMPS_TPS_ARR(:) INTEGER :: PERLU, ITH, ITHMIN, ITHMIN_if_LRLU, OOC_STRAT INTEGER(8) :: TO_ALLOCATE, BLR_RELATED, COPY_RELATED INTEGER(8) :: MIN_NRLADU_underL0, MIN_NRLADU_if_LR_LU_underL0 PERLU = KEEP(12) OOC_STRAT = KEEP(201) TO_ALLOCATE = 0_8 DO ITH = 1, NBTHREADS TO_ALLOCATE = TO_ALLOCATE + & ((int(MUMPS_TPS_ARR(ITH)%LIW,8) * int(KEEP(34),8 )) / & int(KEEP(35),8 )) & + MUMPS_TPS_ARR(ITH)%LA ENDDO TO_ALLOCATE = TO_ALLOCATE + int(NBTHREADS,8)* ( & ((int(LPOOL_P,8) * int(KEEP(34),8 )) / int(KEEP(35),8 )) + & ((int(N+KEEP(253),8) * int(KEEP(34),8 )) / int(KEEP(35),8 )) & ) BLR_RELATED = 0_8 DO ITH = 1, NBTHREADS IF (BLR_STRAT.EQ.1) THEN BLR_RELATED = BLR_RELATED + & I8_L0_OMP(10,ITH) + & int(PERLU,8) * ( I8_L0_OMP(10,ITH) / 100_8 + 1_8) ELSE IF (BLR_STRAT.EQ.2) THEN BLR_RELATED = BLR_RELATED + & I8_L0_OMP(13,ITH) + & int(PERLU,8) * ( I8_L0_OMP(13,ITH) / 100_8 + 1_8) ELSE IF (BLR_STRAT.EQ.3) THEN BLR_RELATED = BLR_RELATED + & I8_L0_OMP(8,ITH) + & int(PERLU,8) * ( I8_L0_OMP(8,ITH) / 100_8 + 1_8) ENDIF ENDDO COPY_RELATED = 0_8 ITHMIN = 1 ITHMIN_if_LRLU = 1 MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,1) MIN_NRLADU_underL0 = I8_L0_OMP(1,1) DO ITH = 1, NBTHREADS IF (I8_L0_OMP(1,ITH).LT.MIN_NRLADU_underL0) & THEN MIN_NRLADU_underL0 = I8_L0_OMP(1,ITH) ITHMIN = ITH ENDIF IF (I8_L0_OMP(4,ITH).LT.MIN_NRLADU_if_LR_LU_underL0) & THEN MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,ITH) ITHMIN_if_LRLU = ITH ENDIF ENDDO IF (BLR_STRAT.EQ.0) THEN IF (OOC_STRAT .LE. 0 .AND. OOC_STRAT .NE. -1 ) THEN COPY_RELATED = COPY_RELATED + & I8_L0_OMP(1,ITHMIN) + & I8_L0_OMP(23, ITHMIN) ELSE COPY_RELATED = COPY_RELATED + & I8_L0_OMP(23, ITHMIN) ENDIF ELSE IF (OOC_STRAT .LE. 0 .AND. OOC_STRAT .NE. -1 ) THEN COPY_RELATED = COPY_RELATED + & I8_L0_OMP(4,ITHMIN_if_LRLU) + & I8_L0_OMP(23,ITHMIN_if_LRLU ) ELSE COPY_RELATED = COPY_RELATED + & I8_L0_OMP(23, ITHMIN_if_LRLU) ENDIF ENDIF COPY_RELATED = COPY_RELATED + & int(PERLU,8)*(COPY_RELATED / 100_8 + 1_8 ) TO_ALLOCATE = TO_ALLOCATE + COPY_RELATED + BLR_RELATED MEMDISPO_UNDERL0 = KEEP8(75) - TO_ALLOCATE RETURN END SUBROUTINE SMUMPS_MA_EFF_MEM_DISPO SUBROUTINE SMUMPS_L0OMP_COPY_IW( IW, LIW, IWPOS, & MUMPS_TPS_ARR, KEEP, & PTLUST, ICNTL, INFO ) USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T IMPLICIT NONE INTEGER :: KEEP(500) INTEGER, INTENT( IN ) :: LIW INTEGER, INTENT( INOUT ) :: IW(:) INTEGER, INTENT( INOUT ) :: IWPOS INTEGER, INTENT( INOUT ) :: PTLUST(KEEP(28)) INTEGER, INTENT( IN ) :: ICNTL(60) INTEGER, INTENT( INOUT ) :: INFO(80) TYPE (MUMPS_TPS_T), TARGET :: MUMPS_TPS_ARR(:) INTEGER :: ITHREAD, JTHREAD INTEGER :: REQUESTED_SIZE INTEGER :: IWPOS_TO_COPY INTEGER :: LOC_IPOS INTEGER :: LOC_SIZE, LOC_ISTEP TYPE (MUMPS_TPS_T), POINTER :: MUMPS_TPS INCLUDE 'mumps_headers.h' REQUESTED_SIZE = 0 DO ITHREAD = 1, size(MUMPS_TPS_ARR) MUMPS_TPS => MUMPS_TPS_ARR(ITHREAD) REQUESTED_SIZE = REQUESTED_SIZE + MUMPS_TPS%IWPOS - 1 ENDDO IF ( LIW - IWPOS + 1 .LT. REQUESTED_SIZE ) THEN WRITE(*,*) " LIW too small in SMUMPS_L0OMP_COPY_IW !!", LIW, & REQUESTED_SIZE INFO(1) = -8 INFO(2) = REQUESTED_SIZE-LIW+IWPOS-1 IF ( ICNTL(1) .GT. 0 .AND. ICNTL(4).GE.1) THEN WRITE(ICNTL(1),*) " ** ERROR IN SMUMPS_L0OMP_COPY_IW: ", & "LIW TOO SMALL TO COPY LOCAL FACTOR INFORMATION", & INFO(2) ENDIF GOTO 500 ENDIF DO ITHREAD = 1, size(MUMPS_TPS_ARR) MUMPS_TPS => MUMPS_TPS_ARR(ITHREAD) IWPOS_TO_COPY = IWPOS DO JTHREAD=1, ITHREAD - 1 IWPOS_TO_COPY = IWPOS_TO_COPY+MUMPS_TPS_ARR(JTHREAD)%IWPOS-1 ENDDO IW(IWPOS_TO_COPY: IWPOS_TO_COPY+MUMPS_TPS%IWPOS - 2) = & MUMPS_TPS%IW(1:MUMPS_TPS%IWPOS-1) LOC_IPOS = 1 DO WHILE ( LOC_IPOS .NE. MUMPS_TPS%IWPOS ) LOC_SIZE = MUMPS_TPS%IW(LOC_IPOS+XXI) LOC_ISTEP = MUMPS_TPS%IW(LOC_IPOS+KEEP(IXSZ)+4) PTLUST(LOC_ISTEP) = IWPOS_TO_COPY+LOC_IPOS-1 LOC_IPOS = LOC_IPOS + LOC_SIZE ENDDO ENDDO IWPOS = IWPOS + REQUESTED_SIZE 500 CONTINUE RETURN END SUBROUTINE SMUMPS_L0OMP_COPY_IW SUBROUTINE SMUMPS_PERFORM_COPIES_INIT( STATE, KEEP8_77_SAVE, & NbWaitMem, NbFinished, NbOnGoingCopies, NbUnderL0, & KEEP, KEEP8 ) INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(OUT) :: NbWaitMem, & NbFinished, & NbOnGoingCopies, & NbUnderL0 INTEGER(8), INTENT(OUT) :: STATE(KEEP(400)), KEEP8_77_SAVE INTEGER :: ITH NbWaitMem = 0 NbFinished = 0 NbOnGoingCopies = 0 NbUnderL0 = KEEP(400) DO ITH=1, KEEP(400) STATE(ITH) = UnderL0 ENDDO KEEP8_77_SAVE = KEEP8(77) RETURN END SUBROUTINE SMUMPS_PERFORM_COPIES_INIT SUBROUTINE SMUMPS_PERFORM_COPIES( THREAD_ID_P, & MUMPS_TPS_ARR, SMUMPS_TPS_ARR, & L0_OMP_FACTORS, LL0_OMP_FACTORS, & STATE, SIZE_COPIED, & NbWaitMem, NbFinished, NbOngoingCopies, NbUnderL0, & MYID_NODES, N, SLAVEF, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & KEEP, KEEP8, INFO_P & ) USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T USE SMUMPS_TPS_M, ONLY : SMUMPS_TPS_T USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_L0OMPFAC_T USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_FREE_S_WK INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: THREAD_ID_P INTEGER, INTENT(INOUT) :: INFO_P(2) INTEGER, INTENT(IN) :: MYID_NODES, N, SLAVEF INTEGER, INTENT(IN) :: STEP(N), DAD(KEEP(28)) INTEGER(8), INTENT(IN) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT(INOUT) :: NbWaitMem, & NbFinished, & NbOnGoingCopies, & NbUnderL0 INTEGER(8), INTENT(INOUT) :: STATE( KEEP(400) ) INTEGER(8), INTENT(INOUT) :: SIZE_COPIED(KEEP(400) ) TYPE (MUMPS_TPS_T), DIMENSION(:) :: MUMPS_TPS_ARR TYPE (SMUMPS_TPS_T), DIMENSION(:) :: SMUMPS_TPS_ARR INTEGER, INTENT ( IN ) :: LL0_OMP_FACTORS TYPE (SMUMPS_L0OMPFAC_T), INTENT(INOUT) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER :: NbFinishedPrivateCopy INTEGER :: LOCAL_ACTION INTEGER, PARAMETER :: NOTHING = 0 INTEGER, PARAMETER :: FREE_WORK_MYID = 1 INTEGER, PARAMETER :: COPY_FACTORS = 2 INTEGER, PARAMETER :: AllocateViderCB = 3 INTEGER, PARAMETER :: DORMIR = 4 INTEGER(8) :: COPY_START, CHUNK8, I8, TO_ALLOCATE INTEGER :: ITH, K INTEGER :: allocok INTEGER(8) :: PeakAuthorized_P INTEGER(8) :: MemNeeded_P, MemNeededForCB_P, MemDispo_P, & CBCopiedToDynamic_P, LRLUS_SAVE_P INTEGER(8) :: KEEP8_71, KEEP8_73 !$OMP CRITICAL(L0_COPIES) STATE(THREAD_ID_P) = CopyNotStarted IF ( INFO_P(1) .LT. 0 ) THEN NbFinished = NbFinished + 1 STATE(THREAD_ID_P) = Finished ENDIF DO ITH = 1, KEEP(400) IF ( STATE(ITH) .EQ. WaitMem ) THEN STATE(ITH)=CopyNotStarted ENDIF ENDDO NbWaitMem = 0 NbFinishedPrivateCopy = NbFinished !$OMP END CRITICAL(L0_COPIES) DO WHILE ( NbFinishedPrivateCopy .NE. KEEP(400) ) LOCAL_ACTION = DORMIR !$OMP CRITICAL(L0_COPIES) NbFinishedPrivateCopy = NbFinished IF ( NbFinished.EQ. KEEP(400)) THEN LOCAL_ACTION = NOTHING ELSE IF ( (NbFinished+NbWaitMem) .EQ. KEEP(400) ) THEN !$OMP ATOMIC READ KEEP8_73 = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC READ KEEP8_71 = KEEP8(71) !$OMP END ATOMIC MemDispo_P = KEEP8(77) - (KEEP8_73 -KEEP8_71) MemDispo_P = min(MemDispo_P, KEEP8(75)-KEEP8_73) MemNeeded_P = huge(MemNeeded_P) DO ITH = 1, KEEP(400) IF (STATE(ITH).EQ.WaitMem) THEN MemNeeded_P = min( MemNeeded_P, & MUMPS_TPS_ARR(ITH)%LA - & MUMPS_TPS_ARR(ITH)%LRLUS ) ENDIF ENDDO IF ((KEEP8(75)-KEEP8_73).LT.MemNeeded_P) THEN INFO_P(1) = -19 CALL MUMPS_SET_IERROR ( & MemNeeded_P-(KEEP8(75)-KEEP8_73), INFO_P(2)) DO ITH = 1, KEEP(400) STATE(ITH) = Finished ENDDO NbFinished = KEEP(400) ELSE KEEP8(77) = MemNeeded_P + (KEEP8_73 -KEEP8_71) DO ITH = 1, KEEP(400) IF ( STATE(ITH) .EQ. WaitMem ) THEN STATE(ITH)=CopyNotStarted ENDIF ENDDO NbWaitMem = 0 ENDIF LOCAL_ACTION = NOTHING ELSE SELECT CASE (STATE(THREAD_ID_P)) CASE ( CopyFactorsFinished ) LOCAL_ACTION = FREE_WORK_MYID CASE ( CopyNotStarted ) !$OMP ATOMIC READ KEEP8_73 = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC READ KEEP8_71 = KEEP8(71) !$OMP END ATOMIC PeakAuthorized_P = KEEP8(77) MemDispo_P = PeakAuthorized_P - (KEEP8_73 -KEEP8_71) MemDispo_P = min(MemDispo_P, KEEP8(75)-KEEP8_73) MemNeeded_P = MUMPS_TPS_ARR(THREAD_ID_P)%LA - & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS MemNeededForCB_P = MemNeeded_P - & ( MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC - 1_8 ) IF ( MemDispo_P .GE. MemNeeded_P ) THEN !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + MemNeeded_P KEEP8_73 = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC READ KEEP8_71 = KEEP8(71) !$OMP END ATOMIC MemDispo_P = PeakAuthorized_P - (KEEP8_73 -KEEP8_71) MemDispo_P = min(MemDispo_P, KEEP8(75)-KEEP8_73) IF ( MemDispo_P .LT. 0 ) THEN !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - MemNeeded_P !$OMP END ATOMIC IF ( STATE(THREAD_ID_P) .NE. WaitMem ) THEN STATE( THREAD_ID_P ) = WaitMem NbWaitMem = NbWaitMem + 1 ENDIF ELSE !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP8_73 ) !$OMP END ATOMIC IF ( STATE( THREAD_ID_P ) .EQ. WaitMem ) THEN NbWaitMem = NbWaitMem - 1 ENDIF STATE( THREAD_ID_P ) = AllocateViderCBEnCours LOCAL_ACTION = AllocateViderCB NbOngoingCopies = NbOnGoingCopies + 1 ENDIF ELSE IF ( STATE(THREAD_ID_P) .NE. WaitMem ) THEN STATE( THREAD_ID_P ) = WaitMem NbWaitMem = NbWaitMem + 1 ENDIF ENDIF CASE DEFAULT ITH = -1 DO K = THREAD_ID_P, THREAD_ID_P + KEEP(400) - 1 IF ( K > KEEP(400) ) THEN ITH = K - KEEP(400) ELSE ITH = K ENDIF IF ( STATE(ITH) .GE. 0 .AND. & STATE(ITH) .LT. MUMPS_TPS_ARR(ITH)%POSFAC - 1_8 ) THEN EXIT ELSE ITH = -1 ENDIF ENDDO IF ( ITH .GT. 0 ) THEN LOCAL_ACTION = COPY_FACTORS COPY_START = STATE(ITH) + 1 CHUNK8 = max( & & int(KEEP(361),8), & & (MUMPS_TPS_ARR(ITH)%POSFAC+KEEP(400)-2_8) / & (int(KEEP(400)*2,8)) & & ) IF (KEEP(72) .EQ. 1) THEN CHUNK8 = 4_8 ENDIF CHUNK8 = min( CHUNK8, & MUMPS_TPS_ARR(ITH)%POSFAC - 1_8 - COPY_START + 1_8 & ) STATE(ITH) = STATE(ITH) + CHUNK8 ENDIF END SELECT ENDIF !$OMP END CRITICAL(L0_COPIES) SELECT CASE ( LOCAL_ACTION ) CASE ( FREE_WORK_MYID ) IF ( associated(SMUMPS_TPS_ARR(THREAD_ID_P)%A) ) THEN CALL SMUMPS_DM_FREE_S_WK( & SMUMPS_TPS_ARR(THREAD_ID_P)%A, & KEEP(430) ) NULLIFY(SMUMPS_TPS_ARR(THREAD_ID_P)%A) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -MUMPS_TPS_ARR(THREAD_ID_P)%LA, & KEEP(405).EQ.1, & KEEP8, & INFO_P(1), INFO_P(2), & .FALSE., .FALSE. ) IF (INFO_P(1) .GE. 0) THEN !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - L0_OMP_FACTORS(THREAD_ID_P)%LA !$OMP END ATOMIC !$OMP CRITICAL(L0_COPIES) DO ITH = 1, KEEP(400) IF ( STATE(ITH) .EQ. WaitMem ) THEN STATE(ITH)=CopyNotStarted ENDIF ENDDO NbWaitMem = 0 NbFinished = NbFinished + 1 STATE( THREAD_ID_P ) = Finished NbOnGoingCopies = NbOnGoingCopies -1 !$OMP END CRITICAL(L0_COPIES) ENDIF ENDIF CASE ( AllocateViderCB ) TO_ALLOCATE = max(MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8,1_8) ALLOCATE( L0_OMP_FACTORS(THREAD_ID_P)%A(TO_ALLOCATE), & stat=allocok ) IF ( allocok .GT. 0 ) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4(TO_ALLOCATE, INFO_P(2)) L0_OMP_FACTORS(THREAD_ID_P)%LA = 0_8 !$OMP CRITICAL(L0_COPIES) !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - MemNeeded_P !$OMP END ATOMIC STATE(THREAD_ID_P) = Finished NbFinished = NbFinished + 1 !$OMP END CRITICAL(L0_COPIES) ELSE L0_OMP_FACTORS(THREAD_ID_P)%LA = & MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8 !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) + L0_OMP_FACTORS(THREAD_ID_P)%LA !$OMP END ATOMIC !$OMP CRITICAL(L0_COPIES) IF ( MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8 == 0_8 ) THEN STATE(THREAD_ID_P) = CopyFactorsFinished ELSE STATE ( THREAD_ID_P ) = 0 SIZE_COPIED( THREAD_ID_P ) = 0 ENDIF !$OMP END CRITICAL(L0_COPIES) LRLUS_SAVE_P = MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS CALL SMUMPS_DM_CBSTATIC2DYNAMIC_I & (3, & 0_8, & .FALSE., & MYID_NODES, N, SLAVEF, KEEP, KEEP8, & MUMPS_TPS_ARR(THREAD_ID_P)%IW(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LIW, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOSCB, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOS, & SMUMPS_TPS_ARR(THREAD_ID_P)%A(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LA, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%IPTRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & INFO_P(1), INFO_P(2) ) CBCopiedToDynamic_P = & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS - LRLUS_SAVE_P IF (INFO_P(1) .LT. 0 ) THEN !$OMP CRITICAL(L0_COPIES) !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - & ( MemNeededForCB_P - CBCopiedToDynamic_P ) !$OMP END ATOMIC STATE(THREAD_ID_P) = Finished NbFinished = NbFinished+1 !$OMP END CRITICAL(L0_COPIES) ELSE ENDIF ENDIF CASE ( COPY_FACTORS ) DO I8 = COPY_START, COPY_START + CHUNK8 - 1 L0_OMP_FACTORS(ITH)%A(I8) = SMUMPS_TPS_ARR(ITH)%A(I8) ENDDO !$OMP CRITICAL(L0_COPIES) SIZE_COPIED(ITH) = SIZE_COPIED(ITH) + CHUNK8 IF ( SIZE_COPIED(ITH) .EQ. L0_OMP_FACTORS(ITH)%LA ) THEN STATE(ITH) = CopyFactorsFinished ENDIF !$OMP END CRITICAL(L0_COPIES) CASE ( NOTHING ) CASE ( DORMIR ) CALL MUMPS_USLEEP(1000) CASE DEFAULT WRITE(*,*) " Internal error in SMUMPS_PERFORM_COPIES", & LOCAL_ACTION END SELECT ENDDO RETURN END SUBROUTINE SMUMPS_PERFORM_COPIES END MODULE SMUMPS_FAC_OMP_M RECURSIVE SUBROUTINE SMUMPS_PROCESS_FRONT_NIV1( COMM_LOAD, & ASS_IRECV, N, INODE, TYPE, TYPEF, LA, IW, LIW, A, & MAXFRW, NOFFNEGW, NULLNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INFO_P, UU, SEUIL, SEUIL_LDLT_NIV2, & OPELIW, NELVAW, NMAXNPIVW, NSTEPSW, PTRIST, PTLUST_S, & PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, NE, POSFAC, & LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP, KEEP8, DKEEP, & PIVNUL_LIST_STRUCT, COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, & SLAVEF, IFATH, COMM_NODES, MYID_NODES, IPOOL_P, & LPOOL_P, LEAF, PERM, NSTK_STEPS, BUFR, LBUFR, & LBUFR_BYTES, NBFIN, root, roota, OPASSW, ITLOC, RHS_MUMPS, FILS, & PTRARW, PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, DAD, LPTRAR, NELT, & FRTPTR, FRTELT, ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS, & FLOP_ESTIM_ACC ) USE SMUMPS_FAC_ASM_MASTER_M USE SMUMPS_FAC_ASM_MASTER_ELT_M USE SMUMPS_FAC1_LU_M USE SMUMPS_FAC1_LDLT_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER COMM_NODES, MYID_NODES, TYPE, TYPEF INTEGER N, LIW, INODE,INFO_P(2) INTEGER ICNTL(60), KEEP(500) REAL DKEEP(230) REAL UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER(8) KEEP8(150) INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU INTEGER IWPOSCB, IWPOS, & IFATH, SLAVEF, NELVAW, NMAXNPIVW, NSTEPSW INTEGER IW(LIW),PROCNODE_STEPS(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NE(KEEP(28)) REAL A(LA) INTEGER :: MAXFRW, NOFFNEGW, NULLNEGW, NPVW, NBTINYW INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER LEAF, COMP INTEGER :: NB22T1W, DET_EXPW, DET_SIGNW REAL :: DET_MANTW INTEGER PERM( N ) INTEGER NSTK_STEPS( KEEP(28) ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER NBFIN TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION FLOP_ESTIM_ACC INTEGER, INTENT(IN) :: LPOOL_P INTEGER, INTENT(IN) :: IPOOL_P(LPOOL_P) INTEGER :: IOLDPS, JOBASS, ETATASS INTEGER(8) :: POSELT LOGICAL :: AVOID_DELAYED, SON_LEVEL2 JOBASS = 0 ETATASS = 0 IF ( KEEP(55) .EQ. 0 ) THEN JOBASS = 0 CALL SMUMPS_FAC_ASM_NIV1( COMM_LOAD, ASS_IRECV, UU, & N, INODE, & IW, LIW, A, LA, INFO_P, ND, FILS, FRERE, DAD, MAXFRW, & root, roota, OPASSW, OPELIW, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & PTRARW, PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSW, & SON_LEVEL2,COMP, LRLU, IPTRLU, & IWPOS, IWPOSCB, POSFAC, & LRLUS, LRLUSM, ICNTL, KEEP, KEEP8, DKEEP, & INTARR, KEEP8(27), DBLARR, KEEP8(26), & NSTK_STEPS, PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL_P, & LPOOL_P, LEAF, PERM, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & JOBASS, ETATASS & , LRGROUPS & ) ELSE CALL SMUMPS_FAC_ASM_NIV1_ELT(COMM_LOAD,ASS_IRECV,UU, & NELT,FRTPTR, & FRTELT, N, INODE, IW, LIW, A, & LA, INFO_P, ND, FILS, FRERE, DAD, MAXFRW, & root, roota, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSW, SON_LEVEL2, COMP, LRLU, & IPTRLU, IWPOS, IWPOSCB, & POSFAC, LRLUS, LRLUSM, ICNTL, KEEP, KEEP8, DKEEP, & INTARR, KEEP8(27), DBLARR, KEEP8(26), & NSTK_STEPS, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, NBFIN, & IPOOL_P, LPOOL_P, LEAF, PERM, ISTEP_TO_INIV2, & TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF IF (INFO_P(1) .LT. 0) THEN RETURN ENDIF AVOID_DELAYED = ( ( IFATH .EQ. KEEP(20) & .OR. & IFATH .EQ. KEEP(38) ) & .AND. & ( KEEP(60) .NE. 0 ) ) POSELT = PTRAST(STEP(INODE)) IOLDPS = PTLUST_S(STEP(INODE)) IF ( KEEP(50) .EQ. 0 ) THEN CALL SMUMPS_FAC1_LU( N, INODE, & IW, LIW, & A, LA, IOLDPS, & POSELT, & INFO_P(1), INFO_P(2), UU, NOFFNEGW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) ELSE IW( IOLDPS + 4 + KEEP(IXSZ) ) = 1 CALL SMUMPS_FAC1_LDLT( N, INODE, & IW, LIW, A, & LA, & IOLDPS, POSELT, & INFO_P(1), INFO_P(2), UU, NOFFNEGW, NULLNEGW, NPVW, & NB22T1W, NBTINYW, DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, MYID_NODES, SEUIL, & AVOID_DELAYED, & ETATASS, & DKEEP(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IW(IOLDPS + 4 + KEEP(IXSZ)) = STEP(INODE) ENDIF IF (INFO_P(1) .LT. 0) THEN RETURN ENDIF CALL SMUMPS_FAC_STACK( COMM_LOAD, ASS_IRECV, N, INODE, TYPE, &TYPEF, LA, IW, LIW, A, &INFO_P(1), INFO_P(2), OPELIW, NELVAW, NMAXNPIVW, PTRIST, PTLUST_S, &PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, NE, POSFAC, &LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP, &KEEP8, DKEEP, &COMP,IWPOS, IWPOSCB, PROCNODE_STEPS, &SLAVEF, IFATH, COMM_NODES, MYID_NODES, IPOOL_P, &LPOOL_P, LEAF, NSTK_STEPS, PERM, BUFR, LBUFR, &LBUFR_BYTES, NBFIN, root, roota, OPASSW, ITLOC, RHS_MUMPS, &FILS, DAD, PTRARW, PTRAIW, &PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, &INTARR, DBLARR, ND, FRERE, &LPTRAR, NELT, FRTPTR, FRTELT, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS, & FLOP_ESTIM_ACC &) RETURN END SUBROUTINE SMUMPS_PROCESS_FRONT_NIV1 MUMPS_5.8.1/src/csol_aux.F0000664000175000017500000016051515042446440015164 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_FREETOPSO( N, KEEP28, IWCB, LIWW, & W, LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER(8), INTENT(IN) :: LWC INTEGER(8), INTENT(INOUT) :: POSWCB INTEGER N,LIWW,IWPOSCB, KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28) INTEGER(8) :: PTRACB(KEEP28) COMPLEX W(LWC) INTEGER SIZFI, SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN DO WHILE ( IWCB( IWPOSCB + 2 ) .eq. 0 ) SIZFR = IWCB( IWPOSCB + 1 ) SIZFI = 2 IWPOSCB = IWPOSCB + SIZFI POSWCB = POSWCB + SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN END DO RETURN END SUBROUTINE CMUMPS_FREETOPSO SUBROUTINE CMUMPS_COMPSO(N,KEEP28,IWCB,LIWW,W,LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER(8), INTENT(IN) :: LWC INTEGER(8), INTENT(INOUT) :: POSWCB INTEGER N,LIWW,IWPOSCB,KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28) INTEGER(8) :: PTRACB(KEEP28) COMPLEX W(LWC) INTEGER IPTIW,SIZFI,LONGI INTEGER(8) :: IPTA, LONGR, SIZFR, I8 INTEGER :: I IPTIW = IWPOSCB IPTA = POSWCB LONGI = 0 LONGR = 0_8 IF ( IPTIW .EQ. LIWW ) RETURN 10 CONTINUE IF (IWCB(IPTIW+2).EQ.0) THEN SIZFR = int(IWCB(IPTIW+1),8) SIZFI = 2 IF (LONGI.NE.0) THEN DO 20 I=0,LONGI-1 IWCB(IPTIW + SIZFI - I) = IWCB (IPTIW - I) 20 CONTINUE DO 30 I8=0,LONGR-1 W(IPTA + SIZFR - I8) = W(IPTA - I8) 30 CONTINUE ENDIF DO 40 I=1,KEEP28 IF ((PTRICB(I).LE.(IPTIW+1)).AND. & (PTRICB(I).GT.IWPOSCB) ) THEN PTRICB(I) = PTRICB(I) + SIZFI PTRACB(I) = PTRACB(I) + SIZFR ENDIF 40 CONTINUE IWPOSCB = IWPOSCB + SIZFI IPTIW = IPTIW + SIZFI POSWCB = POSWCB + SIZFR IPTA = IPTA + SIZFR ELSE SIZFR = int(IWCB(IPTIW+1),8) SIZFI = 2 IPTIW = IPTIW + SIZFI LONGI = LONGI + SIZFI IPTA = IPTA + SIZFR LONGR = LONGR + SIZFR ENDIF IF (IPTIW.NE.LIWW) GOTO 10 RETURN END SUBROUTINE CMUMPS_COMPSO SUBROUTINE CMUMPS_SOL_X(A, NZ8, N, IRN, ICN, Z, KEEP,KEEP8, & EFF_SIZE_SCHUR, SYM_PERM ) INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) COMPLEX, INTENT(IN) :: A(NZ8) REAL, INTENT(OUT) :: Z(N) INTEGER, INTENT(IN) :: EFF_SIZE_SCHUR, SYM_PERM(N) INTEGER :: I, J LOGICAL :: SKIP_COLinSchur REAL, PARAMETER :: ZERO = 0.0E0 INTEGER(8) :: K INTRINSIC abs DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE SKIP_COLinSchur = (EFF_SIZE_SCHUR.GT.0) IF (KEEP(264).EQ.0) THEN IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE IF ( SKIP_COLinSchur.AND. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR)) CYCLE IF ( SKIP_COLinSchur.AND. & (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR)) CYCLE Z(I) = Z(I) + abs(A(K)) ENDDO ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE IF ( SKIP_COLinSchur.AND. & ( (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR) & .OR. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR) & ) & ) CYCLE Z(I) = Z(I) + abs(A(K)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)) ENDIF ENDDO ENDIF ELSE IF (KEEP(50) .EQ.0) THEN IF (SKIP_COLinSchur) THEN DO K = 1_8, NZ8 J = ICN(K) IF ( SYM_PERM(J).GT.N-EFF_SIZE_SCHUR ) CYCLE I = IRN(K) IF ( SYM_PERM(I).GT.N-EFF_SIZE_SCHUR ) CYCLE Z(I) = Z(I) + abs(A(K)) ENDDO ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) Z(I) = Z(I) + abs(A(K)) ENDDO ENDIF ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ( SKIP_COLinSchur.AND. & ( (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR) & .OR. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR) & ) & ) CYCLE Z(I) = Z(I) + abs(A(K)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SOL_X SUBROUTINE CMUMPS_SCAL_X(A, NZ8, N, IRN, ICN, Z, & KEEP, KEEP8, COLSCA, & EFF_SIZE_SCHUR, SYM_PERM ) INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) COMPLEX, INTENT(IN) :: A(NZ8) REAL, INTENT(IN) :: COLSCA(N) REAL, INTENT(OUT) :: Z(N) INTEGER, INTENT(IN) :: EFF_SIZE_SCHUR, SYM_PERM(N) REAL, PARAMETER :: ZERO = 0.0E0 INTEGER :: I, J INTEGER(8) :: K LOGICAL :: SKIP_COLinSchur DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE SKIP_COLinSchur = (EFF_SIZE_SCHUR.GT.0) IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE IF ( SKIP_COLinSchur.AND. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR)) CYCLE IF ( SKIP_COLinSchur.AND. & (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR)) CYCLE Z(I) = Z(I) + abs(A(K)*COLSCA(J)) ENDDO ELSE DO K = 1, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE IF ( SKIP_COLinSchur.AND. & ( (SYM_PERM(I).GT.N-EFF_SIZE_SCHUR) & .OR. & (SYM_PERM(J).GT.N-EFF_SIZE_SCHUR) & ) & ) CYCLE Z(I) = Z(I) + abs(A(K)*COLSCA(J)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)*COLSCA(I)) ENDIF ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_SCAL_X SUBROUTINE CMUMPS_SOL_Y(A, NZ8, N, IRN, ICN, RHS, X, R, W, & KEEP,KEEP8) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) COMPLEX, INTENT(IN) :: A(NZ8), RHS(N), X(N) REAL, INTENT(OUT) :: W(N) COMPLEX, INTENT(OUT) :: R(N) INTEGER I, J INTEGER(8) :: K8 REAL, PARAMETER :: ZERO = 0.0E0 COMPLEX D DO I = 1, N R(I) = RHS(I) W(I) = ZERO ENDDO IF (KEEP(264).EQ.0) THEN IF (KEEP(50) .EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. & (J .LT. 1)) CYCLE D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. & (J .LT. 1)) CYCLE D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF (I.NE.J) THEN D = A(K8) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO ENDIF ELSE IF (KEEP(50) .EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF (I.NE.J) THEN D = A(K8) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SOL_Y SUBROUTINE CMUMPS_SOL_MULR(N, R, W) INTEGER, intent(in) :: N REAL, intent(in) :: W(N) COMPLEX, intent(inout) :: R(N) INTEGER I DO 10 I = 1, N R(I) = R(I) * W(I) 10 CONTINUE RETURN END SUBROUTINE CMUMPS_SOL_MULR SUBROUTINE CMUMPS_SOL_B(N, KASE, X, EST, W, IW, GRAIN) INTEGER, intent(in) :: N INTEGER, intent(inout) :: KASE INTEGER IW(N) COMPLEX W(N), X(N) REAL, intent(inout) :: EST INTEGER, intent(in) :: GRAIN INTRINSIC abs, nint, sign INTRINSIC real INTEGER CMUMPS_IXAMAX EXTERNAL CMUMPS_IXAMAX INTEGER ITMAX PARAMETER (ITMAX = 5) INTEGER I, ITER, J, JLAST, JUMP REAL ALTSGN REAL TEMP SAVE ITER, J, JLAST, JUMP COMPLEX ZERO, ONE PARAMETER( ZERO = (0.0E0,0.0E0) ) PARAMETER( ONE = (1.0E0,0.0E0) ) REAL, PARAMETER :: RZERO = 0.0E0 REAL, PARAMETER :: RONE = 1.0E0 IF (KASE .EQ. 0) THEN DO 10 I = 1, N X(I) = ONE / real(N) 10 CONTINUE KASE = 1 JUMP = 1 RETURN ENDIF SELECT CASE (JUMP) CASE (1) GOTO 20 CASE(2) GOTO 40 CASE(3) GOTO 70 CASE(4) GOTO 120 CASE(5) GOTO 160 CASE DEFAULT END SELECT 20 CONTINUE IF (N .EQ. 1) THEN W(1) = X(1) EST = abs(W(1)) GOTO 190 ENDIF DO 30 I = 1, N X(I) = cmplx( sign(RONE,real(X(I))), kind=kind(X)) IW(I) = nint(real(X(I))) 30 CONTINUE KASE = 2 JUMP = 2 RETURN 40 CONTINUE J = CMUMPS_IXAMAX(N, X, 1, GRAIN) ITER = 2 50 CONTINUE DO 60 I = 1, N X(I) = ZERO 60 CONTINUE X(J) = ONE KASE = 1 JUMP = 3 RETURN 70 CONTINUE DO 80 I = 1, N W(I) = X(I) 80 CONTINUE DO 90 I = 1, N IF (nint(sign(RONE, real(X(I)))) .NE. IW(I)) GOTO 100 90 CONTINUE GOTO 130 100 CONTINUE DO 110 I = 1, N X(I) = cmplx( sign(RONE, real(X(I))), kind=kind(X) ) IW(I) = nint(real(X(I))) 110 CONTINUE KASE = 2 JUMP = 4 RETURN 120 CONTINUE JLAST = J J = CMUMPS_IXAMAX(N, X, 1, GRAIN) IF ((abs(X(JLAST)) .NE. abs(X(J))) .AND. (ITER .LT. ITMAX)) THEN ITER = ITER + 1 GOTO 50 ENDIF 130 CONTINUE EST = RZERO DO 140 I = 1, N EST = EST + abs(W(I)) 140 CONTINUE ALTSGN = RONE DO 150 I = 1, N X(I) = cmplx(ALTSGN * (RONE + real(I - 1) / real(N - 1)), & kind=kind(X)) ALTSGN = -ALTSGN 150 CONTINUE KASE = 1 JUMP = 5 RETURN 160 CONTINUE TEMP = RZERO DO 170 I = 1, N TEMP = TEMP + abs(X(I)) 170 CONTINUE TEMP = 2.0E0/3.0E0 * TEMP / real(N) IF (TEMP .GT. EST) THEN DO 180 I = 1, N W(I) = X(I) 180 CONTINUE EST = TEMP ENDIF 190 KASE = 0 RETURN END SUBROUTINE CMUMPS_SOL_B SUBROUTINE CMUMPS_QD2( MTYPE, N, NZ8, ASPK, IRN, ICN, & LHS, WRHS, W, RHS, KEEP,KEEP8) IMPLICIT NONE INTEGER MTYPE, N INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(IN) :: IRN( NZ8 ), ICN( NZ8 ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX, INTENT(IN) :: ASPK( NZ8 ) COMPLEX, INTENT(IN) :: LHS( N ), WRHS( N ) COMPLEX, INTENT(OUT):: RHS( N ) REAL, INTENT(OUT):: W( N ) INTEGER I, J INTEGER(8) :: K8 REAL, PARAMETER :: DZERO = 0.0E0 DO I = 1, N W(I) = DZERO RHS(I) = WRHS(I) ENDDO IF ( KEEP(50) .EQ. 0 ) THEN IF (MTYPE .EQ. 1) THEN IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) ENDDO ENDIF ELSE IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDDO ENDIF ENDIF ELSE IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDIF ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_QD2 SUBROUTINE CMUMPS_ELTQD2( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & LHS, WRHS, W, RHS, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX A_ELT(NA_ELT8) COMPLEX LHS( N ), WRHS( N ), RHS( N ) REAL W(N) CALL CMUMPS_MV_ELT(N, NELT, ELTPTR, ELTVAR, A_ELT, & LHS, RHS, KEEP(50), MTYPE ) RHS = WRHS - RHS CALL CMUMPS_SOL_X_ELT( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8 ) RETURN END SUBROUTINE CMUMPS_ELTQD2 SUBROUTINE CMUMPS_SOL_X_ELT( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX A_ELT(NA_ELT8) REAL TEMP REAL W(N) INTEGER I, J, IEL, SIZEI, IELPTR INTEGER(8) :: K8 REAL DZERO PARAMETER(DZERO = 0.0E0) W = DZERO K8 = 1_8 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( KEEP(50).EQ.0 ) THEN IF (MTYPE.EQ.1) THEN DO J = 1, SIZEI DO I = 1, SIZEI W( ELTVAR( IELPTR + I) ) = & W( ELTVAR( IELPTR + I) ) & + abs(A_ELT( K8 )) K8 = K8 + 1_8 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + abs( A_ELT(K8)) K8 = K8 + 1_8 END DO W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + TEMP END DO ENDIF ELSE DO J = 1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K8 )) K8 = K8 + 1_8 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K8 )) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + abs(A_ELT( K8 )) K8 = K8 + 1_8 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_SOL_X_ELT SUBROUTINE CMUMPS_SOL_SCALX_ELT(MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8, COLSCA ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL COLSCA(N) COMPLEX A_ELT(NA_ELT8) REAL W(N) REAL TEMP, TEMP2 INTEGER I, J, IEL, SIZEI, IELPTR INTEGER(8) :: K8 REAL DZERO PARAMETER(DZERO = 0.0E0) W = DZERO K8 = 1_8 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( KEEP(50).EQ.0 ) THEN IF (MTYPE.EQ.1) THEN DO J = 1, SIZEI TEMP2 = abs(COLSCA(ELTVAR( IELPTR + J) )) DO I = 1, SIZEI W( ELTVAR( IELPTR + I) ) = & W( ELTVAR( IELPTR + I) ) & + abs(A_ELT( K8 )) * TEMP2 K8 = K8 + 1_8 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) TEMP2= abs(COLSCA(ELTVAR( IELPTR + J) )) DO I = 1, SIZEI TEMP = TEMP + abs(A_ELT( K8 )) * TEMP2 K8 = K8 + 1_8 END DO W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + TEMP END DO ENDIF ELSE DO J = 1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs( A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + J)) ) K8 = K8 + 1_8 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs(A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + J))) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + & abs(A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + I))) K8 = K8 + 1_8 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_SOL_SCALX_ELT SUBROUTINE CMUMPS_ELTYD( MTYPE, N, NELT, ELTPTR, & LELTVAR, ELTVAR, NA_ELT8, A_ELT, & SAVERHS, X, Y, W, K50 ) IMPLICIT NONE INTEGER N, NELT, K50, MTYPE, LELTVAR INTEGER(8) :: NA_ELT8 INTEGER ELTPTR( NELT + 1 ), ELTVAR( LELTVAR ) COMPLEX A_ELT( NA_ELT8 ), X( N ), Y( N ), & SAVERHS(N) REAL W(N) INTEGER IEL, I , J, K, SIZEI, IELPTR REAL ZERO COMPLEX TEMP REAL TEMP2 PARAMETER( ZERO = 0.0E0 ) Y = SAVERHS W = ZERO K = 1 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( K50 .eq. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN DO J = 1, SIZEI TEMP = X( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) - & A_ELT( K ) * TEMP W( ELTVAR( IELPTR + I ) ) = & W( ELTVAR( IELPTR + I ) ) + & abs( A_ELT( K ) * TEMP ) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) TEMP2 = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP - & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) TEMP2 = TEMP2 + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) K = K + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP W( ELTVAR( IELPTR + J ) ) = TEMP2 END DO END IF ELSE DO J = 1, SIZEI Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) W( ELTVAR( IELPTR + J ) ) = & W( ELTVAR( IELPTR + J ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) K = K + 1 DO I = J+1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) W( ELTVAR( IELPTR + I ) ) = & W( ELTVAR( IELPTR + I ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) W( ELTVAR( IELPTR + J ) ) = & W( ELTVAR( IELPTR + J ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) K = K + 1 END DO END DO END IF END DO RETURN END SUBROUTINE CMUMPS_ELTYD SUBROUTINE CMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) USE CMUMPS_OOC IMPLICIT NONE INTEGER INODE,KEEP(500),N INTEGER(8) KEEP8(150) INTEGER(8) :: LA INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER IERR COMPLEX A(LA) INTEGER RETURN_VALUE LOGICAL MUST_BE_PERMUTED RETURN_VALUE=CMUMPS_SOLVE_IS_INODE_IN_MEM(INODE,PTRFAC, & KEEP(28),A,LA,IERR) IF(RETURN_VALUE.EQ.OOC_NODE_NOT_IN_MEM)THEN IF(IERR.LT.0)THEN RETURN ENDIF CALL CMUMPS_SOLVE_ALLOC_FACTOR_SPACE(INODE,PTRFAC, & KEEP,KEEP8,A,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL CMUMPS_READ_OOC( & A(PTRFAC(STEP(INODE))), & INODE,IERR & ) IF(IERR.LT.0)THEN RETURN ENDIF ELSE IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF(RETURN_VALUE.NE.OOC_NODE_PERMUTED)THEN MUST_BE_PERMUTED=.TRUE. CALL CMUMPS_SOLVE_MODIFY_STATE_NODE(INODE) ELSE MUST_BE_PERMUTED=.FALSE. ENDIF RETURN END SUBROUTINE CMUMPS_SOLVE_GET_OOC_NODE SUBROUTINE CMUMPS_BUILD_MAPPING_INFO(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' TYPE(CMUMPS_STRUC), TARGET :: id INTEGER, ALLOCATABLE, DIMENSION(:) :: LOCAL_LIST INTEGER :: I,IERR,TMP,NSTEPS,N_LOCAL_LIST INTEGER :: MASTER,TAG_SIZE,TAG_LIST INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: I_AM_SLAVE PARAMETER(MASTER=0, TAG_SIZE=85,TAG_LIST=86) I_AM_SLAVE = (id%MYID .NE. MASTER & .OR. ((id%MYID.EQ.MASTER).AND.(id%KEEP(46).EQ.1))) NSTEPS = id%KEEP(28) ALLOCATE(LOCAL_LIST(NSTEPS),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating LOCAL_LIST' CALL MUMPS_ABORT() END IF N_LOCAL_LIST = 0 IF(I_AM_SLAVE) THEN DO I=1,NSTEPS IF(id%PTLUST_S(I).NE.0) THEN N_LOCAL_LIST = N_LOCAL_LIST + 1 LOCAL_LIST(N_LOCAL_LIST) = I END IF END DO IF(id%MYID.NE.MASTER) THEN CALL MPI_SEND(N_LOCAL_LIST, 1, & MPI_INTEGER, MASTER, TAG_SIZE, id%COMM,IERR) CALL MPI_SEND(LOCAL_LIST, N_LOCAL_LIST, & MPI_INTEGER, MASTER, TAG_LIST, id%COMM,IERR) DEALLOCATE(LOCAL_LIST) ALLOCATE(id%IPTR_WORKING(1), & id%WORKING(1), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating ', & 'IPTR_WORKING and WORKING' CALL MUMPS_ABORT() END IF END IF END IF IF(id%MYID.EQ.MASTER) THEN ALLOCATE(id%IPTR_WORKING(id%NPROCS+1), STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating IPTR_WORKING' CALL MUMPS_ABORT() END IF id%IPTR_WORKING = 0 id%IPTR_WORKING(1) = 1 id%IPTR_WORKING(MASTER+2) = N_LOCAL_LIST DO I=1, id%NPROCS-1 CALL MPI_RECV(TMP, 1, MPI_INTEGER, MPI_ANY_SOURCE, & TAG_SIZE, id%COMM, STATUS, IERR) id%IPTR_WORKING(STATUS(MPI_SOURCE)+2) = TMP END DO DO I=2, id%NPROCS+1 id%IPTR_WORKING(I) = id%IPTR_WORKING(I) & + id%IPTR_WORKING(I-1) END DO ALLOCATE(id%WORKING(id%IPTR_WORKING(id%NPROCS+1)-1),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating LOCAL_LIST' CALL MUMPS_ABORT() END IF TMP = MASTER + 1 IF (I_AM_SLAVE) THEN id%WORKING(id%IPTR_WORKING(TMP):id%IPTR_WORKING(TMP+1)-1) & = LOCAL_LIST(1:id%IPTR_WORKING(TMP+1) & -id%IPTR_WORKING(TMP)) ENDIF DO I=1,id%NPROCS-1 CALL MPI_RECV(LOCAL_LIST, NSTEPS, MPI_INTEGER, & MPI_ANY_SOURCE, TAG_LIST, id%COMM, STATUS, IERR) TMP = STATUS(MPI_SOURCE)+1 id%WORKING(id%IPTR_WORKING(TMP):id%IPTR_WORKING(TMP+1)-1) & = LOCAL_LIST(1:id%IPTR_WORKING(TMP+1)- & id%IPTR_WORKING(TMP)) END DO DEALLOCATE(LOCAL_LIST) END IF END SUBROUTINE CMUMPS_BUILD_MAPPING_INFO SUBROUTINE CMUMPS_SOL_OMEGA(N, RHS, & X, Y, R_W, C_W, IW, IFLAG, & OMEGA, NOITER, TESTConv, & LP, ARRET, GRAIN, CGCE ) IMPLICIT NONE INTEGER N, IFLAG INTEGER IW(N,2) COMPLEX RHS(N) COMPLEX X(N), Y(N) REAL R_W(N,2) COMPLEX C_W(N) INTEGER LP, NOITER LOGICAL TESTConv REAL OMEGA(2) REAL ARRET REAL CGCE INTEGER, intent(in) :: GRAIN REAL, PARAMETER :: CTAU=1.0E3 INTEGER I, IMAX REAL OM1, OM2, DXMAX REAL TAU, DD REAL OLDOMG(2) REAL, PARAMETER :: ZERO=0.0E0 REAL, PARAMETER :: ONE=1.0E0 INTEGER CMUMPS_IXAMAX SAVE OM1, OLDOMG IMAX = CMUMPS_IXAMAX(N, X, 1, GRAIN) DXMAX = abs(X(IMAX)) OMEGA(1) = ZERO OMEGA(2) = ZERO DO I = 1, N TAU = (R_W(I, 2) * DXMAX + abs(RHS(I))) * real(N) * CTAU DD = R_W(I, 1) + abs(RHS(I)) IF (DD .GT. TAU * epsilon(CTAU)) THEN OMEGA(1) = max(OMEGA(1), abs(Y(I)) / DD) IW(I, 1) = 1 ELSE IF (TAU .GT. ZERO) THEN OMEGA(2) = max(OMEGA(2), & abs(Y(I)) / (DD + R_W(I, 2) * DXMAX)) ENDIF IW(I, 1) = 2 ENDIF ENDDO IF (TESTConv) THEN OM2 = OMEGA(1) + OMEGA(2) IF (OM2 .LT. ARRET ) THEN IFLAG = 1 GOTO 70 ENDIF IF (NOITER .GE. 1) THEN IF (OM2 .GT. OM1 * CGCE) THEN IF (OM2 .GT. OM1) THEN OMEGA(1) = OLDOMG(1) OMEGA(2) = OLDOMG(2) DO I = 1, N X(I) = C_W(I) ENDDO IFLAG = 2 GOTO 70 ENDIF IFLAG = 3 GOTO 70 ENDIF ENDIF DO I = 1, N C_W(I) = X(I) ENDDO OLDOMG(1) = OMEGA(1) OLDOMG(2) = OMEGA(2) OM1 = OM2 ENDIF IFLAG = 0 RETURN 70 CONTINUE RETURN END SUBROUTINE CMUMPS_SOL_OMEGA SUBROUTINE CMUMPS_SOL_LCOND(N, RHS, & X, Y, D, R_W, C_W, IW, KASE, & OMEGA, ERX, COND, & LP, KEEP,KEEP8 ) IMPLICIT NONE INTEGER N, KASE, KEEP(500) INTEGER(8) KEEP8(150) INTEGER IW(N,2) COMPLEX RHS(N) COMPLEX X(N), Y(N) REAL D(N) REAL R_W(N,2) COMPLEX C_W(N) INTEGER LP REAL COND(2),OMEGA(2) LOGICAL LCOND1, LCOND2 INTEGER JUMP, I, IMAX REAL ERX, DXMAX REAL DXIMAX REAL, PARAMETER :: ZERO = 0.0E0 REAL, PARAMETER :: ONE = 1.0E0 INTEGER CMUMPS_IXAMAX INTRINSIC abs SAVE LCOND1, LCOND2, JUMP, DXIMAX, DXMAX IF (KASE .EQ. 0) THEN LCOND1 = .FALSE. LCOND2 = .FALSE. COND(1) = ONE COND(2) = ONE ERX = ZERO JUMP = 1 ENDIF SELECT CASE (JUMP) CASE (1) GOTO 30 CASE(2) GOTO 10 CASE(3) GOTO 110 CASE(4) GOTO 150 CASE(5) GOTO 35 CASE DEFAULT END SELECT 10 CONTINUE 30 CONTINUE 35 CONTINUE IMAX = CMUMPS_IXAMAX(N, X, 1, KEEP(361)) DXMAX = abs(X(IMAX)) DO I = 1, N IF (IW(I, 1) .EQ. 1) THEN R_W(I, 1) = R_W(I, 1) + abs(RHS(I)) R_W(I, 2) = ZERO LCOND1 = .TRUE. ELSE R_W(I, 2) = R_W(I, 2) * DXMAX + R_W(I, 1) R_W(I, 1) = ZERO LCOND2 = .TRUE. ENDIF ENDDO DO I = 1, N C_W(I) = X(I) * D(I) ENDDO IMAX = CMUMPS_IXAMAX(N, C_W(1), 1, KEEP(361)) DXIMAX = abs(C_W(IMAX)) IF (.NOT.LCOND1) GOTO 130 100 CONTINUE CALL CMUMPS_SOL_B(N, KASE, Y, COND(1), C_W, IW(1, 2), KEEP(361)) IF (KASE .EQ. 0) GOTO 120 IF (KASE .EQ. 1) CALL CMUMPS_SOL_MULR(N, Y, D) IF (KASE .EQ. 2) CALL CMUMPS_SOL_MULR(N, Y, R_W) JUMP = 3 RETURN 110 CONTINUE IF (KASE .EQ. 1) CALL CMUMPS_SOL_MULR(N, Y, R_W) IF (KASE .EQ. 2) CALL CMUMPS_SOL_MULR(N, Y, D) GOTO 100 120 CONTINUE IF (DXIMAX .GT. ZERO) COND(1) = COND(1) / DXIMAX ERX = OMEGA(1) * COND(1) 130 CONTINUE IF (.NOT.LCOND2) GOTO 170 KASE = 0 140 CONTINUE CALL CMUMPS_SOL_B(N, KASE, Y, COND(2), C_W, IW(1, 2), KEEP(361)) IF (KASE .EQ. 0) GOTO 160 IF (KASE .EQ. 1) CALL CMUMPS_SOL_MULR(N, Y, D) IF (KASE .EQ. 2) CALL CMUMPS_SOL_MULR(N, Y, R_W(1, 2)) JUMP = 4 RETURN 150 CONTINUE IF (KASE .EQ. 1) CALL CMUMPS_SOL_MULR(N, Y, R_W(1, 2)) IF (KASE .EQ. 2) CALL CMUMPS_SOL_MULR(N, Y, D) GOTO 140 160 IF (DXIMAX .GT. ZERO) THEN COND(2) = COND(2) / DXIMAX ENDIF ERX = ERX + OMEGA(2) * COND(2) 170 CONTINUE RETURN END SUBROUTINE CMUMPS_SOL_LCOND SUBROUTINE CMUMPS_SOL_CPY_FS2RHSINTR( JBDEB, JBFIN, NBROWS, & KEEP, RHSINTR, NRHS, LRHSINTR, FIRST_ROW_RHSINTR, W, LD_W, & FIRST_ROW_W ) INTEGER :: JBDEB, JBFIN, NBROWS INTEGER :: NRHS, LRHSINTR INTEGER :: FIRST_ROW_RHSINTR INTEGER, INTENT(IN) :: KEEP(500) COMPLEX, INTENT(INOUT) :: RHSINTR(LRHSINTR,NRHS) INTEGER :: LD_W, FIRST_ROW_W COMPLEX :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER :: JJ, K, ISHIFT !$OMP PARALLEL DO PRIVATE(ISHIFT, JJ), IF !$OMP& (JBFIN-JBDEB+1 > 2*KEEP(362) .AND. !$OMP& NBROWS * (JBFIN-JBDEB+1) > 2*KEEP(363)) DO K = JBDEB, JBFIN ISHIFT = FIRST_ROW_W + LD_W * (K-JBDEB) DO JJ = 0, NBROWS-1 RHSINTR(FIRST_ROW_RHSINTR+JJ,K) = W(ISHIFT+JJ) END DO END DO !$OMP END PARALLEL DO RETURN END SUBROUTINE CMUMPS_SOL_CPY_FS2RHSINTR SUBROUTINE CMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSINTR, NRHS, LRHSINTR, W, LD_W, FIRST_ROW_W, & IW, LIW, KEEP, N, POSINRHSINTR_BWD ) INTEGER, INTENT(IN) :: JBDEB, JBFIN, J1, J2 INTEGER, INTENT(IN) :: NRHS, LRHSINTR INTEGER, INTENT(IN) :: FIRST_ROW_W, LD_W, LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: KEEP(500) COMPLEX, INTENT(INOUT) :: RHSINTR(LRHSINTR,NRHS) COMPLEX :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: POSINRHSINTR_BWD(N) INTEGER :: ISHIFT, JJ, K, IPOSINRHSINTR !$OMP PARALLEL DO PRIVATE(JJ,ISHIFT,IPOSINRHSINTR), IF !$OMP& ((JBFIN-JBDEB+1 > 2*KEEP(362) .AND. !$OMP& (JBFIN-JBDEB+1)*(J2-KEEP(253)-J1+1)>2*KEEP(363))) DO K=JBDEB, JBFIN ISHIFT = FIRST_ROW_W+(K-JBDEB)*LD_W DO JJ = J1, J2-KEEP(253) IPOSINRHSINTR = abs(POSINRHSINTR_BWD(IW(JJ))) W(ISHIFT+JJ-J1)= RHSINTR(IPOSINRHSINTR,K) ENDDO ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE CMUMPS_SOL_BWD_GTHR SUBROUTINE CMUMPS_SOL_Q(MTYPE, IFLAG, N, & LHS, WRHS, W, RES, GIVNORM, ANORM, XNORM, SCLNRM, & MPRINT, ICNTL, KEEP,KEEP8) INTEGER MTYPE,N,IFLAG,ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) COMPLEX RES(N),LHS(N) COMPLEX WRHS(N) REAL W(N) REAL RESMAX,RESL2,XNORM, SCLNRM REAL ANORM,DZERO LOGICAL GIVNORM,PROK INTEGER MPRINT, MP INTEGER K INTRINSIC abs, max, sqrt MP = ICNTL(2) PROK = (MPRINT .GT. 0) DZERO = 0.0E0 IF (.NOT.GIVNORM) ANORM = DZERO RESMAX = DZERO RESL2 = DZERO DO 40 K = 1, N RESMAX = max(RESMAX, abs(RES(K))) RESL2 = RESL2 + abs(RES(K)) * abs(RES(K)) IF (.NOT.GIVNORM) ANORM = max(ANORM, W(K)) 40 CONTINUE XNORM = DZERO DO 50 K = 1, N XNORM = max(XNORM, abs(LHS(K))) 50 CONTINUE IF ( XNORM .EQ. DZERO .OR. (exponent(XNORM) .LT. & minexponent(XNORM) + KEEP(122) ) & .OR. & ( exponent(ANORM)+exponent(XNORM) .LT. & minexponent(XNORM) + KEEP(122) ) & .OR. & ( exponent(ANORM) + exponent(XNORM) -exponent(RESMAX) & .LT. minexponent(XNORM) + KEEP(122) ) & ) THEN IF (mod(IFLAG/2,2) .EQ. 0) THEN IFLAG = IFLAG + 2 ENDIF IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) & ' max-NORM of computed solut. is zero or close to zero. ' ENDIF IF (RESMAX .EQ. DZERO) THEN SCLNRM = DZERO ELSE SCLNRM = RESMAX / (ANORM * XNORM) ENDIF RESL2 = sqrt(RESL2) IF (PROK) WRITE( MPRINT, 90 ) RESMAX, RESL2, ANORM, XNORM, & SCLNRM 90 FORMAT (/' RESIDUAL IS ............ (INF-NORM) =',1PD9.2/ & ' .. (2-NORM) =',1PD9.2/ & ' RINFOG(4):NORM OF input Matrix (INF-NORM)=',1PD9.2/ & ' RINFOG(5):NORM OF Computed SOLUT (INF-NORM)=',1PD9.2/ & ' RINFOG(6):SCALED RESIDUAL ...... (INF-NORM)=',1PD9.2) RETURN END SUBROUTINE CMUMPS_SOL_Q SUBROUTINE CMUMPS_SOLVE_FWD_TRSOLVE (A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LDADIAG, NPIV, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT COMPLEX, INTENT(IN) :: A(LA) COMPLEX, INTENT(INOUT) :: WCB(LWCB) COMPLEX ONE PARAMETER ( ONE=(1.0E0,0.0E0) ) IF (KEEP(50).NE.0 .OR. MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ctrsv( 'U', 'T', 'U', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ctrsm( 'L','U','T','U', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ctrsv( 'L', 'N', 'N', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ctrsm( 'L','L','N','N', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF RETURN END SUBROUTINE CMUMPS_SOLVE_FWD_TRSOLVE SUBROUTINE CMUMPS_SOLVE_BWD_TRSOLVE (A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LDADIAG, NPIV, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT COMPLEX, INTENT(IN) :: A(LA) COMPLEX, INTENT(INOUT) :: WCB(LWCB) COMPLEX ONE PARAMETER ( ONE=(1.0E0,0.0E0) ) IF (MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ctrsv( 'L', 'T', 'N', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ctrsm( 'L','L','T','N', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ctrsv( 'U', 'N', 'U', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ctrsm( 'L','U','N','U', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF RETURN END SUBROUTINE CMUMPS_SOLVE_BWD_TRSOLVE SUBROUTINE CMUMPS_SOLVE_FWD_PANELS( & A, LA, APOS, NPIV, IW, & NRHS_B, WCB, LWCB, LDA_WCB, & PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, NPIV, KEEP(500) INTEGER, INTENT(IN) :: IW(NPIV) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT COMPLEX, INTENT(IN) :: A(LA) COMPLEX, INTENT(INOUT) :: WCB(LWCB) INTEGER :: NB_TARGET INTEGER :: NBPANELS INTEGER :: NBROWS_PANEL, NBCOLS_PANEL, ICOL_BEG, ICOL_END INTEGER(8) :: PANEL_APOS, PPIV_PANEL COMPLEX, PARAMETER :: ONE=(1.0E0,0.0E0) IF (KEEP(459) .LE. 1) THEN WRITE(*,*) " Internal error in CMUMPS_SOLVE_FWD_PANELS" CALL MUMPS_ABORT() ENDIF CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, NB_TARGET, KEEP ) PANEL_APOS = APOS NBPANELS = 0 ICOL_BEG = 1 NBROWS_PANEL = NPIV PPIV_PANEL = PPIV_COURANT DO WHILE ( ICOL_BEG .LE. NPIV ) NBPANELS = NBPANELS + 1 ICOL_END = min(NB_TARGET * NBPANELS, NPIV) IF ( IW(ICOL_END) .LT. 0 ) ICOL_END=ICOL_END+1 NBCOLS_PANEL = ICOL_END - ICOL_BEG + 1 CALL CMUMPS_SOLVE_FWD_TRSOLVE (A, LA, PANEL_APOS, & NBCOLS_PANEL, NBCOLS_PANEL, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_PANEL, MTYPE, KEEP) IF ( NBROWS_PANEL .GT. NBCOLS_PANEL ) THEN CALL CMUMPS_SOLVE_GEMM_UPDATE( A, LA, & PANEL_APOS + int(NBCOLS_PANEL,8) * int(NBCOLS_PANEL,8), & NBCOLS_PANEL, NBCOLS_PANEL, NBROWS_PANEL-NBCOLS_PANEL, & NRHS_B, WCB, LWCB, PPIV_PANEL, LDA_WCB, & PPIV_PANEL+NBCOLS_PANEL, LDA_WCB, & MTYPE, KEEP, ONE ) ENDIF ICOL_BEG = ICOL_END + 1 PANEL_APOS = PANEL_APOS + int(NBCOLS_PANEL,8) * & int(NBROWS_PANEL,8) NBROWS_PANEL = NBROWS_PANEL - NBCOLS_PANEL PPIV_PANEL = PPIV_PANEL + NBCOLS_PANEL ENDDO RETURN END SUBROUTINE CMUMPS_SOLVE_FWD_PANELS SUBROUTINE CMUMPS_SOLVE_BWD_PANELS( & A, LA, APOS, NPIV, IW, & NRHS_B, WCB, LWCB, LDA_WCB, & PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, NPIV, KEEP(500) INTEGER, INTENT(IN) :: IW(NPIV) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT COMPLEX, INTENT(IN) :: A(LA) COMPLEX, INTENT(INOUT) :: WCB(LWCB) INTEGER, PARAMETER :: PANEL_TABSIZE = 20 INTEGER(8) :: PANEL_POS(PANEL_TABSIZE) INTEGER :: PANEL_COL(PANEL_TABSIZE) INTEGER :: IPANEL, NBPANELS, NB_TARGET INTEGER :: NBROWS_PANEL, NBCOLS_PANEL INTEGER(8) :: PPIV_PANEL INTEGER :: MTYPE_TEMP COMPLEX, PARAMETER :: ONE=(1.0E0,0.0E0) IF (KEEP(459) .LE. 1) THEN WRITE(*,*) " Internal error 1 in CMUMPS_SOLVE_BWD_PANELS" CALL MUMPS_ABORT() ENDIF IF ( KEEP(459)+1 .GT. PANEL_TABSIZE ) THEN WRITE(*,*) " Internal error 2 in CMUMPS_SOLVE_BWD_PANELS" CALL MUMPS_ABORT() ENDIF CALL MUMPS_LDLTPANEL_PANELINFOS( NPIV, KEEP, IW, &NB_TARGET, NBPANELS, PANEL_COL, PANEL_POS, PANEL_TABSIZE, &.FALSE. ) DO IPANEL = NBPANELS, 1, -1 NBCOLS_PANEL = PANEL_COL( IPANEL+1 ) - PANEL_COL( IPANEL ) NBROWS_PANEL = NPIV - PANEL_COL( IPANEL ) + 1 PPIV_PANEL = PPIV_COURANT + PANEL_COL( IPANEL ) - 1 IF ( NBROWS_PANEL .GT. NBCOLS_PANEL ) THEN MTYPE_TEMP = 0 CALL CMUMPS_SOLVE_GEMM_UPDATE( A, LA, & APOS-1_8+PANEL_POS(IPANEL)+ & int(NBCOLS_PANEL,8)*int(NBCOLS_PANEL,8), & NBROWS_PANEL-NBCOLS_PANEL, NBCOLS_PANEL, & NBCOLS_PANEL, & NRHS_B, WCB, LWCB, PPIV_PANEL+NBCOLS_PANEL, LDA_WCB, & PPIV_PANEL, LDA_WCB, & MTYPE_TEMP, KEEP, ONE ) ENDIF CALL CMUMPS_SOLVE_BWD_TRSOLVE (A, LA, & APOS+PANEL_POS(IPANEL)-1_8, & NBCOLS_PANEL, NBCOLS_PANEL, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_PANEL, MTYPE, KEEP) ENDDO RETURN END SUBROUTINE CMUMPS_SOLVE_BWD_PANELS SUBROUTINE CMUMPS_SOLVE_GEMM_UPDATE & (A, LA, APOS1, NX, LDA, NY, & NRHS_B, WCB, LWCB, PTRX, LDX, & PTRY, LDY, & MTYPE, KEEP, COEF_Y ) INTEGER, INTENT(IN) :: MTYPE, NY, NX, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDY, LDA, LDX INTEGER(8), INTENT(IN) :: LA, APOS1, LWCB, PTRX, & PTRY COMPLEX, INTENT(IN) :: A(LA) COMPLEX, INTENT(INOUT) :: WCB(LWCB) COMPLEX, INTENT(IN) :: COEF_Y COMPLEX ALPHA, ZERO, ONE PARAMETER (ZERO=(0.0E0,0.0E0), ONE=(1.0E0,0.0E0), & ALPHA=(-1.0E0,0.0E0)) IF ( NX .NE. 0 .AND. NY.NE.0 ) THEN IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL cgemv('T', NX, NY, ALPHA, A(APOS1), & LDA, WCB(PTRX), 1, COEF_Y, & WCB(PTRY), 1) ELSE #endif CALL cgemm('T', 'N', NY, NRHS_B, NX, ALPHA, & A(APOS1), LDA, WCB(PTRX), LDX, COEF_Y, & WCB(PTRY), LDY) #if defined(MUMPS_USE_BLAS2) END IF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL cgemv('N',NY, NX, ALPHA, A(APOS1), & LDA, WCB(PTRX), 1, & COEF_Y, WCB(PTRY), 1 ) ELSE #endif CALL cgemm('N', 'N', NY, NRHS_B, NX, ALPHA, & A(APOS1), LDA, WCB(PTRX), LDX, & COEF_Y, WCB(PTRY), LDY) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF END IF RETURN END SUBROUTINE CMUMPS_SOLVE_GEMM_UPDATE SUBROUTINE CMUMPS_SOL_LD_AND_RELOAD_PANEL ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & IGNORE_K459 & ) USE CMUMPS_OOC IMPLICIT NONE INTEGER, INTENT(IN) :: MTYPE, INODE, N, NPIV, LIELL, & NELIM, NSLAVES INTEGER, INTENT(IN) :: LRHSINTR, NRHS, LIW, JBDEB, JBFIN INTEGER, INTENT(IN) :: IW(LIW), IPOS, POSINRHSINTR_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, APOS, LA, PPIV_COURANT INTEGER, INTENT(IN) :: LD_WCBPIV INTEGER, INTENT(IN) :: KEEP(500) COMPLEX, INTENT(IN) :: WCB( LWCB ) COMPLEX, INTENT(IN) :: A( LA ) COMPLEX, INTENT(INOUT) :: RHSINTR(LRHSINTR, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL, INTENT(IN) :: IGNORE_K459 INTEGER :: J1, J3 INTEGER :: IPOSINRHSINTR, JJ, K, & LDAJ, NRHS_B INTEGER(8) :: IFR8 , APOS1, APOS2, APOSOFF, IFR_ini8, & POSWCB1, POSWCB2 COMPLEX :: VALPIV, A11, A22, A12, DETPIV INTEGER, PARAMETER :: PANEL_TABSIZE = 20 INTEGER(8) :: PANEL_POS(PANEL_TABSIZE) INTEGER :: PANEL_COL(PANEL_TABSIZE) INTEGER :: IPANEL, ICOL, NBPANELS, NB_TARGET LOGICAL :: SKIP_IT LOGICAL :: OMP_FLAG COMPLEX ONE PARAMETER ( ONE=(1.0E0,0.0E0) ) IF ( NPIV.EQ. 0 ) RETURN NRHS_B = JBFIN-JBDEB+1 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J3 = IPOS + LIELL + NPIV END IF IPOSINRHSINTR = POSINRHSINTR_FWD(IW(J1)) IF ( KEEP(50) .eq. 0 ) THEN OMP_FLAG = .FALSE. !$ OMP_FLAG=(int(NRHS_B,8)*int(NPIV,8).GE.int(KEEP(363),8)) IF (OMP_FLAG) THEN !$OMP PARALLEL DO PRIVATE(IFR8) COLLAPSE(2) DO K = JBDEB, JBFIN DO IFR8 = 0_8, int(NPIV-1,8) RHSINTR(IPOSINRHSINTR+IFR8, K) = & WCB(PPIV_COURANT+(K-JBDEB)*LD_WCBPIV+IFR8) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO K = JBDEB, JBFIN DO IFR8 = 0_8, int(NPIV-1,8) RHSINTR(IPOSINRHSINTR+IFR8, K) = & WCB(PPIV_COURANT+(K-JBDEB)*LD_WCBPIV+IFR8) ENDDO ENDDO ENDIF ELSE CALL MUMPS_LDLTPANEL_PANELINFOS( NPIV, KEEP, IW(IPOS+LIELL+1), & NB_TARGET, NBPANELS, PANEL_COL, PANEL_POS, PANEL_TABSIZE, & IGNORE_K459 ) IFR_ini8 = PPIV_COURANT !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & ((J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363))) !$OMP PARALLEL DO PRIVATE(JJ,IFR8,APOS1,APOS2,APOSOFF,VALPIV, !$OMP& IPANEL,ICOL, !$OMP& POSWCB1,POSWCB2,A11,A22,A12,DETPIV,LDAJ,SKIP_IT) !$OMP& IF(OMP_FLAG) DO K = JBDEB, JBFIN DO JJ = J1, J3 IPANEL = (JJ-J1)/NB_TARGET + 1 IF ( JJ-J1+1 .LT. PANEL_COL(IPANEL) ) IPANEL = IPANEL -1 ICOL = JJ-J1+1 - PANEL_COL(IPANEL) + 1 LDAJ = PANEL_COL(IPANEL+1) - PANEL_COL(IPANEL) APOS1 = APOS-1_8+PANEL_POS( IPANEL ) + int(ICOL-1,8) * & int(LDAJ+1,8) IFR8 = IFR_ini8 + int(K-JBDEB,8)*int(LD_WCBPIV,8) + & int(JJ-J1,8) IF ( JJ .NE. J1 ) THEN IF ( IW(LIELL+JJ-1) .LT. 0 ) THEN SKIP_IT = .TRUE. ELSE SKIP_IT = .FALSE. ENDIF ELSE SKIP_IT = .FALSE. ENDIF IF (SKIP_IT) THEN ELSE IF ( IW(JJ+LIELL) .GT. 0 ) THEN VALPIV = ONE/A( APOS1 ) RHSINTR(IPOSINRHSINTR+JJ-J1 , K ) = & WCB( IFR8 ) * VALPIV APOS1 = APOS1 + int(LDAJ + 1,8) ELSE APOS2 = APOS1+int(LDAJ+1,8) APOSOFF=APOS1+1_8 A11 = A(APOS1) A22 = A(APOS2) A12 = A(APOSOFF) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(APOS2)/DETPIV A12 = -A12/DETPIV POSWCB1 = IFR8 POSWCB2 = POSWCB1+1_8 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSINTR(IPOSINRHSINTR+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 ENDIF ENDDO ENDDO !$OMP END PARALLEL DO END IF RETURN END SUBROUTINE CMUMPS_SOL_LD_AND_RELOAD_PANEL SUBROUTINE CMUMPS_SOL_LD_AND_RELOAD ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSINTR, LRHSINTR, NRHS, & POSINRHSINTR_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & IGNORE_K459 & ) USE CMUMPS_OOC INTEGER, INTENT(IN) :: MTYPE, INODE, N, NPIV, LIELL, & NELIM, NSLAVES INTEGER, INTENT(IN) :: LRHSINTR, NRHS, LIW, JBDEB, JBFIN INTEGER, INTENT(IN) :: IW(LIW), IPOS, POSINRHSINTR_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, APOS, LA, PPIV_COURANT INTEGER, INTENT(IN) :: LD_WCBPIV INTEGER, INTENT(IN) :: KEEP(500) COMPLEX, INTENT(IN) :: WCB( LWCB ) COMPLEX, INTENT(IN) :: A( LA ) COMPLEX, INTENT(INOUT) :: RHSINTR(LRHSINTR, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL, INTENT(IN) :: IGNORE_K459 INTEGER :: TempNROW, J1, J3, PANEL_SIZE INTEGER :: IPOSINRHSINTR, JJ, K, NBK, LDAJ, & LDAJ_ini, NBK_ini, LDAJ_FIRST_PANEL, NRHS_B INTEGER(8) :: IFR8 , APOS1, APOS2, APOSOFF, IFR_ini8, & POSWCB1, POSWCB2 COMPLEX :: VALPIV, A11, A22, A12, DETPIV !$ LOGICAL :: OMP_FLAG COMPLEX ONE PARAMETER ( ONE=(1.0E0,0.0E0) ) NRHS_B = JBFIN-JBDEB+1 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J3 = IPOS + LIELL + NPIV END IF IPOSINRHSINTR = POSINRHSINTR_FWD(IW(J1)) IF ( KEEP(50) .eq. 0 ) THEN !$ OMP_FLAG=(NRHS_B.GE.KEEP(362).AND.NRHS_B*NPIV.GE.KEEP(363)) !$OMP PARALLEL DO PRIVATE(IFR8) IF (OMP_FLAG) DO K=JBDEB,JBFIN IFR8 = PPIV_COURANT + (K-JBDEB)*LD_WCBPIV RHSINTR(IPOSINRHSINTR:IPOSINRHSINTR+NPIV-1, K) = & WCB(IFR8:IFR8+int(NPIV-1,8)) ENDDO !$OMP END PARALLEL DO ELSE IFR8 = PPIV_COURANT - 1_8 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN IF (MTYPE.EQ.1) THEN IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN TempNROW= NPIV+NELIM LDAJ_FIRST_PANEL=TempNROW ELSE TempNROW= LIELL LDAJ_FIRST_PANEL=TempNROW ENDIF ELSE TempNROW= NPIV LDAJ_FIRST_PANEL=LIELL ENDIF PANEL_SIZE = CMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) LDAJ = TempNROW ELSE IF ( KEEP(459) .GT. 1 .AND. KEEP(50) .NE. 0 & .AND. .NOT. IGNORE_K459 ) THEN CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, PANEL_SIZE, KEEP ) LDAJ = PANEL_SIZE ELSE PANEL_SIZE = -1 LDAJ = NPIV ENDIF ENDIF IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN NBK = 0 ENDIF IFR_ini8 = PPIV_COURANT - 1_8 LDAJ_ini = LDAJ IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & NBK_ini = NBK !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & ((J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363))) !$OMP PARALLEL DO PRIVATE(JJ,IFR8,NBK,APOS1,APOS2,APOSOFF,VALPIV, !$OMP& POSWCB1, POSWCB2,A11,A22,A12,DETPIV,LDAJ) IF(OMP_FLAG) DO K = JBDEB, JBFIN IFR8 = IFR_ini8 + int(K-JBDEB,8)*int(LD_WCBPIV,8) NBK = NBK_ini APOS1 = APOS LDAJ = LDAJ_ini JJ = J1 DO IF (JJ .GT. J3) EXIT IFR8 = IFR8 + 1_8 IF (IW(JJ+LIELL) .GT. 0) THEN VALPIV = ONE/A( APOS1 ) RHSINTR(IPOSINRHSINTR+JJ-J1 , K ) = & WCB( IFR8 ) * VALPIV IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 IF (NBK.EQ.PANEL_SIZE) THEN NBK = 0 LDAJ = LDAJ - PANEL_SIZE ENDIF ENDIF APOS1 = APOS1 + int(LDAJ + 1,8) JJ = JJ+1 ELSE IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 ENDIF APOS2 = APOS1+int(LDAJ+1,8) IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN APOSOFF = APOS1+int(LDAJ,8) ELSE APOSOFF=APOS1+1_8 ENDIF A11 = A(APOS1) A22 = A(APOS2) A12 = A(APOSOFF) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(APOS2)/DETPIV A12 = -A12/DETPIV POSWCB1 = IFR8 POSWCB2 = POSWCB1+1_8 RHSINTR(IPOSINRHSINTR+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSINTR(IPOSINRHSINTR+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 IF (NBK.GE.PANEL_SIZE) THEN LDAJ = LDAJ - NBK NBK = 0 ENDIF ENDIF APOS1 = APOS2 + int(LDAJ + 1,8) JJ = JJ+2 IFR8 = IFR8+1_8 ENDIF ENDDO ENDDO !$OMP END PARALLEL DO END IF RETURN END SUBROUTINE CMUMPS_SOL_LD_AND_RELOAD SUBROUTINE CMUMPS_SET_SCALING_LOC( scaling_data, N, ILOC, LILOC, & COMM, MYID, I_AM_SLAVE, MASTER, NB_BYTES, NB_BYTES_MAX, & K16_8, LP, LPOK, ICNTL, INFO ) IMPLICIT NONE type scaling_data_t SEQUENCE REAL, dimension(:), pointer :: SCALING REAL, dimension(:), pointer :: SCALING_LOC INTEGER, dimension(:), pointer :: SCALING_IND end type scaling_data_t type (scaling_data_t), INTENT(INOUT) :: scaling_data INTEGER, INTENT(IN) :: N, LILOC, COMM, MYID, MASTER, LP INTEGER, INTENT(IN) :: ILOC(LILOC) INTEGER(8), INTENT(INOUT) :: NB_BYTES, NB_BYTES_MAX INTEGER(8), INTENT(IN) :: K16_8 LOGICAL, INTENT(IN) :: I_AM_SLAVE, LPOK INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(IN) :: ICNTL(60) REAL, POINTER, DIMENSION(:) :: SCALING INTEGER :: I, IERR_MPI, allocok INCLUDE 'mpif.h' NULLIFY(scaling_data%SCALING_LOC) IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data%SCALING_LOC(max(1,LILOC)), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(1,LILOC) GOTO 35 ENDIF NB_BYTES = NB_BYTES + int(max(1,LILOC),8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF IF (MYID .NE. MASTER) THEN ALLOCATE(SCALING(N), stat=allocok) IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating temporary scaling array' ENDIF INFO(1)=-13 INFO(2)=N GOTO 35 ENDIF NB_BYTES = NB_BYTES + int(N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE SCALING => scaling_data%SCALING ENDIF 35 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF (INFO(1) .LT. 0) GOTO 90 CALL MPI_BCAST( SCALING(1), N, MPI_REAL, & MASTER, COMM, IERR_MPI) IF ( I_AM_SLAVE ) THEN DO I = 1, LILOC IF (ILOC(I) .GE. 1 .AND. ILOC(I) .LE. N) THEN scaling_data%SCALING_LOC(I) = SCALING(ILOC(I)) ENDIF ENDDO ENDIF 90 CONTINUE IF (MYID.NE. MASTER) THEN IF (associated(SCALING)) THEN DEALLOCATE(SCALING) NB_BYTES = NB_BYTES - int(N,8)*K16_8 ENDIF ENDIF NULLIFY(SCALING) IF (INFO(1) .LT. 0) THEN IF (associated(scaling_data%SCALING_LOC)) THEN DEALLOCATE(scaling_data%SCALING_LOC) NULLIFY(scaling_data%SCALING_LOC) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SET_SCALING_LOC MUMPS_5.8.1/src/zsol_omp_m.F0000664000175000017500000004754615042446441015536 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_SOL_L0OMP_M CONTAINS SUBROUTINE ZMUMPS_SOL_L0OMP_R(N, MTYPE, & NRHS, LIW, IW, PTRICB, RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & STEP, FRERE, DAD, FILS, NSTK, PTRIST, PTRFAC, INFO, & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF, & COMM, MYID, & BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, & FROM_PP, & NBROOT_UNDER_L0, LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS, & DO_PRUN, TO_PROCESS ) USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_L0OMPFAC_T !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT( in ) :: N, MTYPE, NRHS, SLAVEF, LIW INTEGER, INTENT( in ) :: IW(LIW) INTEGER :: INFO( 80 ), KEEP(500) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: DKEEP(230) INTEGER, INTENT( in ) :: PROCNODE_STEPS( KEEP(28) ) INTEGER :: PTRICB( KEEP(28) ) INTEGER, INTENT( in ) :: POSINRHSINTR_FWD(N), LRHSINTR COMPLEX(kind=8), INTENT(inout):: RHSINTR(LRHSINTR,NRHS) INTEGER, INTENT( in ) :: STEP(N), FRERE( KEEP(28) ), FILS( N ), & DAD( KEEP(28) ) INTEGER, INTENT( inout ) :: NSTK(KEEP(28)) INTEGER, INTENT( in ) :: PTRIST(KEEP(28)) INTEGER(8), INTENT( in ) :: PTRFAC(KEEP(28)) INTEGER, INTENT( IN ) :: COMM, MYID INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES INTEGER :: BUFR(LBUFR) INTEGER(8), INTENT(IN) :: LRHS_ROOT COMPLEX(kind=8) :: RHS_ROOT(LRHS_ROOT) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) LOGICAL, INTENT( in ) :: DO_NBSPARSE INTEGER, INTENT( in ) :: LRHS_BOUNDS INTEGER, INTENT( in ) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, INTENT( in ) :: FROM_PP INTEGER, INTENT( out ):: NBROOT_UNDER_L0 INTEGER, INTENT( in ) :: LPOOL_B_L0_OMP INTEGER, INTENT( in ) :: IPOOL_B_L0_OMP & ( LPOOL_B_L0_OMP ) INTEGER, INTENT( in ) :: L_PHYS_L0_OMP INTEGER, INTENT( in ) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT( in ) :: L_VIRT_L0_OMP INTEGER, INTENT( in ) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT( in ) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT( in ) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT( in ) :: LL0_OMP_MAPPING INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INTEGER, INTENT( in ) :: LL0_OMP_FACTORS LOGICAL, INTENT( in ) :: DO_PRUN LOGICAL, INTENT( in ) :: TO_PROCESS( KEEP(28) ) TYPE (ZMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER :: LASTFSSBTRSTA_P, LASTFSSBTRDYN_P INTEGER :: THREAD_ID, IL0OMPFAC INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOOL_P INTEGER, ALLOCATABLE, DIMENSION(:) :: IWCB_P COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: WCB_P INTEGER :: LPOOL_P, LEAF_P, LIWCB_P INTEGER(8) :: LWCB_P INTEGER(8) :: POSWCB_P, PLEFTWCB_P INTEGER :: POSIWCB_P LOGICAL :: IS_INODE_PROCESSED_P LOGICAL :: ERROR_WAS_BROADCASTED_P INTEGER :: INFO_P(2), allocok INTEGER :: I, VIRTUAL_TASK, PHYSICAL_TASK INTEGER :: INODE, IFATH, IROOT_SBTR INTEGER :: NBROOT_PROCESSED INTEGER :: NEXT_TASK_DYN !$ INTEGER :: NOMP_SAVE INTEGER :: NBFIN_DUMMY !$ INTEGER :: NOMP_TOTAL !$ INTEGER :: NOMP_INNER !$ LOGICAL :: SAVE_NESTED NBFIN_DUMMY = huge(NBFIN_DUMMY) NBROOT_PROCESSED = 0 PTRICB = 0 !$ NOMP_INNER = 1 !$ IF (KEEP(369).GT.0) THEN !$ NOMP_TOTAL = omp_get_max_threads() !$ IF (NOMP_TOTAL .NE. KEEP(400)) THEN !$ IF (KEEP(439) .GT. 1) THEN !$ NOMP_INNER = KEEP(439) !$ ELSE IF ( KEEP(439) .EQ. -1 !$ & ) THEN !$ NOMP_INNER = NOMP_TOTAL / KEEP(400) !$ ENDIF !$ ENDIF !$ IF (NOMP_INNER .GT. 1) THEN !$ SAVE_NESTED = omp_get_nested() !$ CALL OMP_SET_NESTED(.TRUE.) !$ ENDIF #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(KEEP(400),4)) #else !$ CALL omp_set_num_threads(KEEP(400)) #endif !$ ENDIF NEXT_TASK_DYN = KEEP(400)+1 !$OMP PARALLEL !$OMP& SHARED ( NEXT_TASK_DYN, IPOOL_B_L0_OMP, !$OMP& LPOOL_B_L0_OMP, NBFIN_DUMMY ) !$OMP& PRIVATE ( THREAD_ID, IL0OMPFAC, VIRTUAL_TASK, PHYSICAL_TASK, !$OMP& IPOOL_P, LPOOL_P, LEAF_P, !$OMP& LIWCB_P, LWCB_P, IWCB_P, WCB_P, !$OMP& PLEFTWCB_P, POSWCB_P, POSIWCB_P, !$OMP& LASTFSSBTRSTA_P, LASTFSSBTRDYN_P, !$OMP& INODE, IROOT_SBTR, IFATH, !$OMP& IS_INODE_PROCESSED_P, !$OMP& INFO_P, ERROR_WAS_BROADCASTED_P, NOMP_SAVE, allocok ) !$OMP& REDUCTION( + : NBROOT_PROCESSED ) !$ NOMP_SAVE = omp_get_max_threads() THREAD_ID = 1 !$ THREAD_ID = OMP_GET_THREAD_NUM() + 1 !$OMP BARRIER !$ CALL omp_set_num_threads(NOMP_INNER) LPOOL_P = LPOOL_B_L0_OMP INFO_P(1:2) = 0 LWCB_P = int(KEEP(133),8)*int(NRHS,8) LIWCB_P = KEEP(133) PLEFTWCB_P = 1_8 POSWCB_P = LWCB_P POSIWCB_P = LIWCB_P ALLOCATE(IPOOL_P(LPOOL_P), IWCB_P(LIWCB_P), WCB_P( LWCB_P), & stat=allocok) IF ( allocok > 0 ) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4(LPOOL_P + LIWCB_P + LWCB_P, & INFO(2)) !$OMP CRITICAL(critical_info) INFO(1) = -13 INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ENDIF !$OMP BARRIER IF (INFO(1) .LT. 0) THEN GOTO 50 ENDIF VIRTUAL_TASK = THREAD_ID 600 CONTINUE IF (VIRTUAL_TASK .LT. L_VIRT_L0_OMP) THEN DO PHYSICAL_TASK = VIRT_L0_OMP( VIRTUAL_TASK ), & VIRT_L0_OMP ( VIRTUAL_TASK + 1 ) - 1 LEAF_P = 1 DO I = PTR_LEAFS_L0_OMP( PERM_L0_OMP( PHYSICAL_TASK )+1 )+1, & PTR_LEAFS_L0_OMP( PERM_L0_OMP( PHYSICAL_TASK ) ) IF ( IPOOL_B_L0_OMP(I) .GT. 0 ) THEN IPOOL_P(LEAF_P) = IPOOL_B_L0_OMP(I) LEAF_P = LEAF_P + 1 ENDIF ENDDO IF ( LEAF_P .EQ. 1 ) THEN WRITE(*,*) " Internal error 1 in ZMUMPS_SOL_L0OMP_R", & LEAF_P ENDIF IROOT_SBTR = PHYS_L0_OMP( PERM_L0_OMP( PHYSICAL_TASK )) IF (DO_PRUN) THEN IF (.NOT. TO_PROCESS(STEP(IROOT_SBTR))) THEN CYCLE ENDIF ENDIF INODE = IROOT_SBTR DO WHILE (INODE .GT. 0) LASTFSSBTRSTA_P = INODE INODE=FILS(INODE) ENDDO CALL MUMPS_COMPUTE_LASTFS_DYN( IROOT_SBTR, LASTFSSBTRDYN_P, & MTYPE, KEEP, IW, LIW, N, STEP, PTRIST, FILS, FRERE ) DO WHILE (LEAF_P .NE.1 .AND. INFO_P(1) .GE. 0) LEAF_P = LEAF_P - 1 INODE = IPOOL_P(LEAF_P) IFATH = DAD(STEP(INODE) ) IL0OMPFAC = L0_OMP_MAPPING(STEP(INODE)) IF (IL0OMPFAC .NE. THREAD_ID) THEN ENDIF IF (DO_PRUN) THEN IS_INODE_PROCESSED_P = TO_PROCESS(STEP(INODE)) ELSE IS_INODE_PROCESSED_P = .TRUE. ENDIF IF ( IS_INODE_PROCESSED_P ) THEN CALL ZMUMPS_SOLVE_NODE_FWD( INODE, & LASTFSSBTRSTA_P, LASTFSSBTRDYN_P, & BUFR, LBUFR, LBUFR_BYTES, MYID, SLAVEF, COMM, & N, IPOOL_P, LPOOL_P, LEAF_P, NBFIN_DUMMY, NSTK, & IWCB_P, LIWCB_P, WCB_P, LWCB_P, & L0_OMP_FACTORS(IL0OMPFAC)%A(1), & L0_OMP_FACTORS(IL0OMPFAC)%LA, & IW, LIW, & NRHS, POSWCB_P, PLEFTWCB_P, POSIWCB_P, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, INFO_P, KEEP, KEEP8, DKEEP, & RHS_ROOT, LRHS_ROOT, MTYPE, & RHSINTR, LRHSINTR, POSINRHSINTR_FWD, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED_P ) IF (INFO_P(1) .LT. 0) THEN !$OMP CRITICAL(critical_info) INFO(1) = INFO_P(1) INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 50 IF (ERROR_WAS_BROADCASTED_P) THEN WRITE(*,*) " Internal error 2 in ZMUMPS_SOL_L0OMP_R", & ERROR_WAS_BROADCASTED_P ENDIF ENDIF IF ( IFATH .EQ. 0 ) THEN IF ( IS_INODE_PROCESSED_P ) THEN NBROOT_PROCESSED = NBROOT_PROCESSED + 1 ENDIF ELSE PTRICB(STEP(INODE)) = 0 IF (IFATH .NE. 0) THEN IF ( INODE .NE. IROOT_SBTR ) THEN IF ( IS_INODE_PROCESSED_P ) THEN NSTK(STEP(IFATH)) = NSTK(STEP(IFATH)) - 1 ENDIF IF (NSTK(STEP(IFATH)) .EQ. 0 .OR. & NSTK(STEP(IFATH)) .EQ. -1 ) THEN IPOOL_P( LEAF_P ) = IFATH LEAF_P = LEAF_P + 1 IF (DO_PRUN) THEN NSTK(STEP(IFATH)) = huge(NSTK(STEP(IFATH))) ENDIF ENDIF ELSE IF ( IS_INODE_PROCESSED_P ) THEN !$OMP ATOMIC UPDATE NSTK(STEP(IFATH)) = NSTK(STEP(IFATH)) - 1 !$OMP END ATOMIC ENDIF ENDIF ENDIF ENDIF ENDDO ENDDO !$OMP ATOMIC CAPTURE VIRTUAL_TASK = NEXT_TASK_DYN NEXT_TASK_DYN = NEXT_TASK_DYN + 1 !$OMP END ATOMIC GOTO 600 ENDIF 50 CONTINUE IF (allocated(IPOOL_P)) DEALLOCATE(IPOOL_P) IF (allocated(IWCB_P)) DEALLOCATE(IWCB_P) IF (allocated(WCB_P)) DEALLOCATE(WCB_P) #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_SAVE,4)) #else !$ CALL omp_set_num_threads(NOMP_SAVE) #endif !$OMP END PARALLEL !$ IF (KEEP(369).GT.0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_TOTAL),4)) #else !$ CALL omp_set_num_threads(NOMP_TOTAL) #endif !$ IF (NOMP_INNER .GT. 1) THEN !$ CALL OMP_SET_NESTED(SAVE_NESTED) !$ ENDIF !$ ENDIF NBROOT_UNDER_L0 = NBROOT_PROCESSED RETURN END SUBROUTINE ZMUMPS_SOL_L0OMP_R SUBROUTINE ZMUMPS_SOL_L0OMP_S(N, MTYPE, NRHS, LIW, IW, & PTRICB, PTRACB, RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & STEP, FRERE, FILS, NE_STEPS, PTRIST, PTRFAC, INFO, & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, RHS_ROOT, LRHS_ROOT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP, LPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, L_PHYS_L0_OMP, PHYS_L0_OMP, & PERM_L0_OMP, PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, & L0_OMP_FACTORS, LL0_OMP_FACTORS ) USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_L0OMPFAC_T USE OMP_LIB IMPLICIT NONE INTEGER, INTENT( in ) :: N, MTYPE, NRHS, SLAVEF, LIW INTEGER, INTENT( in ) :: IW(LIW) INTEGER :: INFO( 80 ), KEEP(500) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: DKEEP(230) INTEGER, INTENT( in ) :: PROCNODE_STEPS( KEEP(28) ) INTEGER :: PTRICB( KEEP(28) ) INTEGER(8) :: PTRACB( KEEP(28) ) INTEGER, INTENT( in ) :: POSINRHSINTR_BWD(N), LRHSINTR COMPLEX(kind=8), INTENT(inout):: RHSINTR(LRHSINTR,NRHS) INTEGER, INTENT( in ) :: STEP(N), FRERE( KEEP(28) ), FILS( N ) INTEGER, INTENT( inout ) :: NE_STEPS(KEEP(28)) INTEGER, INTENT( in ) :: PTRIST(KEEP(28)) INTEGER(8), INTENT( in ) :: PTRFAC(KEEP(28)) INTEGER, INTENT( IN ) :: COMM, MYID INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES INTEGER :: BUFR(LBUFR) INTEGER(8), INTENT(IN) :: LRHS_ROOT COMPLEX(kind=8) :: RHS_ROOT(LRHS_ROOT) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER :: LPANEL_POS INTEGER :: PANEL_POS(LPANEL_POS) LOGICAL, INTENT( in ) :: DO_NBSPARSE INTEGER, INTENT( in ) :: LRHS_BOUNDS INTEGER, INTENT( in ) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, INTENT( in ) :: PRUN_BELOW_BWD INTEGER, INTENT( in ) :: SIZE_TO_PROCESS LOGICAL, INTENT( in ) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, INTENT( in ) :: FROM_PP INTEGER, INTENT( in ) :: LPOOL_B_L0_OMP INTEGER, INTENT( in ) :: L_PHYS_L0_OMP INTEGER, INTENT( in ) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT( in ) :: L_VIRT_L0_OMP INTEGER, INTENT( in ) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT( in ) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT( in ) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT( in ) :: LL0_OMP_MAPPING INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INTEGER, INTENT( in ) :: LL0_OMP_FACTORS TYPE (ZMUMPS_L0OMPFAC_T), INTENT(IN) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER :: THREAD_ID, IL0OMPFAC INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOOL_P INTEGER, ALLOCATABLE, DIMENSION(:) :: IWCB_P COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: WCB_P COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: W2_P INTEGER, ALLOCATABLE, DIMENSION(:) :: PANEL_POS_P INTEGER :: LPOOL_P, IIPOOL_P, LIWCB_P, LPANEL_POS_P INTEGER :: MYLEAF_LEFT_HUGE_P INTEGER(8) :: LWCB_P INTEGER(8) :: POSWCB_P, PLEFTWCB_P INTEGER :: POSIWCB_P LOGICAL :: DO_MCAST2_TERMBWD_P LOGICAL :: ERROR_WAS_BROADCASTED_P INTEGER :: INFO_P(2), allocok INTEGER :: VIRTUAL_TASK, PHYSICAL_TASK INTEGER :: INODE INTEGER :: NEXT_TASK_DYN !$ INTEGER :: NOMP_SAVE INTEGER :: NBFIN_DUMMY LOGICAL, ALLOCATABLE, DIMENSION(:) :: DEJA_SEND_DUMMY !$ INTEGER :: NOMP_TOTAL NBFIN_DUMMY = huge(NBFIN_DUMMY) ALLOCATE(DEJA_SEND_DUMMY( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of DEJA_SEND_DUMMY in ' & //'routine ZMUMPS_SOL_S ' INFO(1)=-13 INFO(2)=SLAVEF GOTO 100 endif !$ IF (KEEP(369).GT.0) THEN !$ NOMP_TOTAL = omp_get_max_threads() #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(KEEP(400),4)) #else !$ CALL omp_set_num_threads(KEEP(400)) #endif !$ ENDIF PTRICB = 0 NEXT_TASK_DYN = KEEP(400)+1 !$OMP PARALLEL !$OMP& SHARED ( NEXT_TASK_DYN, LPOOL_B_L0_OMP, !$OMP& NBFIN_DUMMY, DEJA_SEND_DUMMY ) !$OMP& PRIVATE ( THREAD_ID, IL0OMPFAC, VIRTUAL_TASK, PHYSICAL_TASK, !$OMP& IPOOL_P, LPOOL_P, IIPOOL_P, MYLEAF_LEFT_HUGE_P, !$OMP& LIWCB_P, LWCB_P, IWCB_P, WCB_P, W2_P, LPANEL_POS_P, !$OMP& PANEL_POS_P, !$OMP& PLEFTWCB_P, POSWCB_P, POSIWCB_P, !$OMP& INODE, !$OMP& INFO_P, DO_MCAST2_TERMBWD_P, !$OMP& ERROR_WAS_BROADCASTED_P, NOMP_SAVE, allocok ) !$ NOMP_SAVE = omp_get_max_threads() THREAD_ID = 1 !$ THREAD_ID = OMP_GET_THREAD_NUM() + 1 !$OMP BARRIER !$ CALL omp_set_num_threads(1) LPOOL_P = LPOOL_B_L0_OMP INFO_P(1:2) = 0 LWCB_P = int(KEEP(133),8)*int(NRHS,8) LIWCB_P = KEEP(133) PLEFTWCB_P = 1_8 POSWCB_P = LWCB_P POSIWCB_P = LIWCB_P IF (KEEP(201).EQ.1) THEN LPANEL_POS_P = KEEP(228)+1 CALL MUMPS_ABORT() ELSE LPANEL_POS_P = 1 ENDIF ALLOCATE(IPOOL_P(LPOOL_P), IWCB_P(LIWCB_P), WCB_P( LWCB_P), & W2_P(KEEP(133)), PANEL_POS_P(LPANEL_POS_P), stat=allocok) IF ( allocok > 0 ) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4(LPOOL_P + LIWCB_P + LWCB_P + & KEEP(133)+LPANEL_POS_P, INFO(2)) !$OMP CRITICAL(critical_info) INFO(1) = -13 INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ENDIF !$OMP BARRIER IF (INFO(1) .LT. 0) THEN GOTO 50 ENDIF VIRTUAL_TASK = THREAD_ID 600 CONTINUE IF (VIRTUAL_TASK .LT. L_VIRT_L0_OMP) THEN DO PHYSICAL_TASK = VIRT_L0_OMP( VIRTUAL_TASK ), & VIRT_L0_OMP ( VIRTUAL_TASK + 1 ) - 1 INODE = PHYS_L0_OMP( PERM_L0_OMP( PHYSICAL_TASK ) ) IPOOL_P(1) = INODE IIPOOL_P = 2 MYLEAF_LEFT_HUGE_P = huge(MYLEAF_LEFT_HUGE_P) IF ( PRUN_BELOW_BWD ) THEN IF ( .NOT. TO_PROCESS(STEP(INODE)) ) THEN CYCLE ENDIF ENDIF DO WHILE (IIPOOL_P .NE.1 .AND. INFO_P(1) .GE. 0) IIPOOL_P = IIPOOL_P - 1 INODE = IPOOL_P(IIPOOL_P) IL0OMPFAC = L0_OMP_MAPPING(STEP(INODE)) IF (IL0OMPFAC .NE. THREAD_ID) THEN ENDIF CALL ZMUMPS_SOLVE_NODE_BWD( INODE, N, IPOOL_P, LPOOL_P, & IIPOOL_P, NBFIN_DUMMY, L0_OMP_FACTORS(IL0OMPFAC)%A(1), & L0_OMP_FACTORS(IL0OMPFAC)%LA, IW, LIW, & WCB_P, LWCB_P, NRHS, POSWCB_P, PLEFTWCB_P, POSIWCB_P, & RHSINTR, LRHSINTR, POSINRHSINTR_BWD, & PTRICB, PTRACB, IWCB_P, LIWCB_P, W2_P, NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, MYLEAF_LEFT_HUGE_P, INFO_P, & PROCNODE_STEPS, & DEJA_SEND_DUMMY, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP, KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS_P, LPANEL_POS_P, & PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS, & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED_P & , DO_MCAST2_TERMBWD_P & ) IF (INFO_P(1) .LT. 0) THEN !$OMP CRITICAL(critical_info) INFO(1) = INFO_P(1) INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 50 IF (ERROR_WAS_BROADCASTED_P) THEN WRITE(*,*) " Internal error 1 in ZMUMPS_SOL_L0OMP_R", & ERROR_WAS_BROADCASTED_P ENDIF IF (DO_MCAST2_TERMBWD_P) THEN WRITE(*,*) " Internal error 2 in ZMUMPS_SOL_L0OMP_R", & DO_MCAST2_TERMBWD_P ENDIF ENDDO ENDDO !$OMP ATOMIC CAPTURE VIRTUAL_TASK = NEXT_TASK_DYN NEXT_TASK_DYN = NEXT_TASK_DYN + 1 !$OMP END ATOMIC GOTO 600 ENDIF 50 CONTINUE IF (allocated(IPOOL_P)) DEALLOCATE(IPOOL_P) IF (allocated(IWCB_P)) DEALLOCATE(IWCB_P) IF (allocated(WCB_P)) DEALLOCATE(WCB_P) IF (allocated(W2_P)) DEALLOCATE(W2_P) IF (allocated(PANEL_POS_P)) DEALLOCATE(PANEL_POS_P) #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_SAVE,4)) #else !$ CALL omp_set_num_threads(NOMP_SAVE) #endif !$OMP END PARALLEL !$ IF (KEEP(369).GT.0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_TOTAL),4)) #else !$ CALL omp_set_num_threads(NOMP_TOTAL) #endif !$ ENDIF 100 CONTINUE IF (allocated(DEJA_SEND_DUMMY)) DEALLOCATE(DEJA_SEND_DUMMY) RETURN END SUBROUTINE ZMUMPS_SOL_L0OMP_S END MODULE ZMUMPS_SOL_L0OMP_M MUMPS_5.8.1/src/dfac_front_LDLT_type2.F0000664000175000017500000010676715042446437017435 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC2_LDLT_M CONTAINS SUBROUTINE DMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NNEGW, NNULLNEGW, NPVW, NB22T2W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP, PIVNUL_LIST_STRUCT & , LRGROUPS & ) USE DMUMPS_FAC_FRONT_AUX_M USE DMUMPS_FAC_FRONT_TYPE2_AUX_M USE DMUMPS_OOC USE DMUMPS_FAC_LR USE DMUMPS_LR_TYPE USE MUMPS_LR_STATS USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_DATA_M !$ USE OMP_LIB USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_TEST USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW INTEGER, intent(inout) :: NNEGW, NPVW, NNULLNEGW, NB22T2W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW INTEGER(8) :: LA INTEGER, TARGET :: IW( LIW ) DOUBLE PRECISION A( LA ) DOUBLE PRECISION UU, SEUIL TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) INTEGER NBFIN, SLAVEF, & IFLAG, IERROR, LEAF, LPOOL INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER NB_BLOC_FAC INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N), & PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL AVOID_DELAYED TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(KEEP(280)) INTEGER(8) :: POSELT INTEGER IOLDPS, allocok, K263,J INTEGER INOPV, IFINB, NFRONT, NPIV, IEND_BLOCK INTEGER NASS, LDAFS, IBEG_BLOCK INTEGER :: NB_POSTPONED INTEGER :: IBEG_BLOCK_FOR_IPIV LOGICAL LASTPANEL, LR_ACTIVATED, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR, CURRENT_BLR INTEGER Inextpiv LOGICAL RESET_TO_ONE INTEGER K109_SAVE INTEGER XSIZE, NBKJIB_ORIG DOUBLE PRECISION UUTEMP INCLUDE 'mumps_headers.h' INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV DOUBLE PRECISION , ALLOCATABLE, DIMENSION ( : ) :: DIAG_ORIG INTEGER :: SIZEDIAG_ORIG INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY, NELIM TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PP_FIRST2SWAP_L, IFLAG_OOC INTEGER PP_LastPIVRPTRFilled INTEGER INFO_TMP(2) INTEGER :: MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_SEND DOUBLE PRECISION, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP, BEGS_BLR_STATIC INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, I, IP, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG, APOSMAX DOUBLE PRECISION, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION,ALLOCATABLE :: RWORK(:) DOUBLE PRECISION, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM LOGICAL :: SWAP_OCCURRED INTEGER :: MY_NUM INTEGER PIVOT_OPTION INTEGER LAST_ROW EXTERNAL DMUMPS_BDC_ERROR LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC DOUBLE PRECISION GW_FACTCUMUL INTEGER PIVSIZ,IWPOSPIV DOUBLE PRECISION ONE PARAMETER (ONE = 1.0D0) NULLIFY(PTDummy) NULLIFY(ACC_LUA) NULLIFY(BEGS_BLR) NULLIFY(BLR_L) NULLIFY(BLR_SEND) NULLIFY(DIAG) NULLIFY(BLR_PANEL) NULLIFY(BEGS_BLR_TMP) NULLIFY(BEGS_BLR_STATIC) IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF SWAP_OCCURRED = .FALSE. INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC=SEUIL UUTEMP=UU ENDIF RESET_TO_ONE = ((KEEP(110).GT.0).AND.(DKEEP(2).LE.0.0D0)) IF (RESET_TO_ONE) THEN K109_SAVE = KEEP(109) ENDIF IBEG_BLOCK = 1 NB_BLOC_FAC = 0 XSIZE = KEEP(IXSZ) IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) NFRONT = IW(IOLDPS+XSIZE) NASS = abs(IW(IOLDPS+2+XSIZE)) LDAFS = NASS IF ((KEEP(219).EQ.1).AND.(KEEP(207).EQ.1).AND.(KEEP(50).EQ.2) & ) THEN APOSMAX = POSELT + int(LDAFS,8)*int(LDAFS,8) NB_POSTPONED = max(NFRONT - ND(STEP(INODE)),0) CALL DMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, A(APOSMAX), NASS, NB_POSTPONED) ENDIF IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL DMUMPS_SET_INNERBLOCKSIZE( NBKJIB_ORIG, NASS, KEEP) IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF (LR_ACTIVATED) THEN K263 = 1 ELSE K263 = KEEP(263) IF (K263 .NE. 0 .AND. NASS/NBLR_ORIG < 4) THEN IF ( NBLR_ORIG .GT. NBKJIB_ORIG * 4 ) THEN NBLR_ORIG = max(NBKJIB_ORIG, (NASS+3)/4) ELSE K263 = 0 ENDIF ENDIF ENDIF PIVOT_OPTION = MIN(2,KEEP(468)) IF ((UUTEMP == 0.0D0) .AND. OOC_EFFECTIVE_ON_FRONT) THEN IF (K263.EQ.1.AND.(.NOT.LR_ACTIVATED)) THEN PIVOT_OPTION = 0 ENDIF ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID, ' : DMUMPS_FAC2_LDLT failed to allocate ', & NASS, ' integers' IFLAG = -13 IERROR=NASS GO TO 500 END IF IF (KEEP(219).GE.3) THEN SIZEDIAG_ORIG = NASS ELSE SIZEDIAG_ORIG = 1 ENDIF ALLOCATE ( DIAG_ORIG(SIZEDIAG_ORIG), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID, & ' : FAC_NIV2 failed to allocate ', & NASS, ' REAL/COMPLEX entries' IFLAG=-13 IERROR=NASS GO TO 500 END IF CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF (OOC_EFFECTIVE_ON_FRONT) THEN IDUMMY = -9876 TYPEFile = TYPEF_L NextPiv2beWritten = 1 PP_FIRST2SWAP_L = NextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 2 MonBloc%NROW = NASS MonBloc%NCOL = NASS MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -66666 MonBloc%INDICES => & IW(IOLDPS+6+NFRONT+XSIZE+IW(IOLDPS+5+XSIZE) & :IOLDPS+5+2*NFRONT+XSIZE+IW(IOLDPS+5+XSIZE)) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(475).EQ.3) THEN IF (UUTEMP == 0.0D0) THEN PIVOT_OPTION = 0 ELSE PIVOT_OPTION = 1 ENDIF ENDIF CNT_NODES = CNT_NODES + 1 ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.2) .AND. & OOC_EFFECTIVE_ON_FRONT ) IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & 0, KEEP(488), .FALSE., KEEP(472), & NFRONT, KEEP(1)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) OMP_NUM = 1 #if ! defined(BLR_NOOPENMP) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 480 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL DMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 CALL DMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .TRUE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF LASTPANEL = .FALSE. DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = BEGS_BLR(CURRENT_BLR+1)-1 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*(MAXI_CLUSTER+1) DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 480 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (K263.EQ.0) THEN IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK ELSE IBEG_BLOCK_FOR_IPIV = IBEG_BLR ENDIF CALL DMUMPS_FAC_I_LDLT_NIV2( & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, & NFRONT,NASS,IBEG_BLOCK_FOR_IPIV, & IBEG_BLOCK, IEND_BLOCK, & NASS, IPIV, & N,INODE,IW,LIW,A,LA, & NNEGW,NNULLNEGW, NB22T2W,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INOPV, & IFLAG,IERROR,IOLDPS,POSELT,UU, SEUIL_LOC, & KEEP,KEEP8,PIVSIZ, & DKEEP(1), PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, & PIVOT_OPTION, & Inextpiv, IEND_BLR, LR_ACTIVATED, & OOC_EFFECTIVE_ON_FRONT) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ. 1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTPANEL = .TRUE. ELSE IF (INOPV .LE. 0) THEN INOPV = 0 NPVW = NPVW + PIVSIZ CALL DMUMPS_FAC_MQ_LDLT_NIV2(IEND_BLOCK, & NASS, IW(IOLDPS+1+XSIZE), INODE,A,LA, & LDAFS, POSELT,IFINB, & PIVSIZ, & KEEP(219), & PIVOT_OPTION, IEND_BLR, LR_ACTIVATED) IF(PIVSIZ .EQ. 2) THEN IWPOSPIV = IOLDPS+XSIZE+IW(IOLDPS+1+XSIZE)+6+ & IW(IOLDPS+5+XSIZE) IW(IWPOSPIV+NFRONT) = -IW(IWPOSPIV+NFRONT) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB .EQ. -1) THEN LASTPANEL = .TRUE. ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN IF (.NOT.RESET_TO_ONE.OR.K109_SAVE.EQ.KEEP(109)) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF ENDIF IF (K263.eq.0) THEN NELIM = IEND_BLR - NPIV CALL DMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEG_BLOCK, NPIV, IPIV, NASS,LASTPANEL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, .FALSE. & , NPARTSASS, CURRENT_BLR, BLR_DUMMY, LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN CALL DMUMPS_RESET_TO_ONE( & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), & NPIV, IBEG_BLOCK, & K109_SAVE, KEEP(109), PIVNUL_LIST_STRUCT, & A, POSELT, LA, LDAFS) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF ENDIF IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL DMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & -6666, -6666, & IEND_BLR, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ENDIF CALL MUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 500 ENDIF NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) THEN WRITE(*,*) "Internal error 1 in DMUMPS_FAC2_LDLT", & IEND_BLR, IEND_BLOCK CALL MUMPS_ABORT() ENDIF IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) NULLIFY(BLR_L) ENDIF GOTO 101 ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), KEEP(458), & KEEP(473), BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8 & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (PIVOT_OPTION.LT.2) THEN CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NB_BLR, 2, 1, 0, .FALSE., & IW, OFFSET_IW=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1, & NASS=NASS) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif ENDIF 400 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 480 IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L, 0) ENDIF ENDIF ENDIF 101 CONTINUE IF (.NOT. LR_ACTIVATED) THEN CALL DMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS, NASS, INODE, A, LA, & LDAFS, POSELT, & KEEP, KEEP8, & IEND_BLR, NASS, & -6666, -6666, & (PIVOT_OPTION.LE.1), .FALSE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ENDIF IF (K263.NE.0) THEN NELIM = IEND_BLR-NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_L)) THEN BLR_SEND=>BLR_L ENDIF CALL DMUMPS_SEND_FACTORED_PANEL( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEG_BLR, NPIV, IPIV, NASS,LASTPANEL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S,PTRFAC,STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, roota, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR , BLR_SEND , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN CALL DMUMPS_RESET_TO_ONE( & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), & NPIV, IBEG_BLR, & K109_SAVE, KEEP(109), PIVNUL_LIST_STRUCT, & A, POSELT, LA, LDAFS) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF ENDIF IF (.NOT. LR_ACTIVATED) THEN IF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL DMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & -6666, -6666, & NASS, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ELSE NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) THEN CALL MUMPS_ABORT() ENDIF #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL #endif IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN CALL DMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NASS, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 2, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8) ENDIF ENDIF IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 450 IF (KEEP(480).LT.2) THEN CALL DMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, & IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, & MAXI_CLUSTER, NPIV, & 2, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (PIVOT_OPTION.LT.2) THEN IF ((UU.GT.0).OR.(KEEP(486).NE.2)) THEN CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, NASS, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, & 'V', 1) ENDIF ENDIF 450 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 480 IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF ENDIF GOTO 100 ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL(BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & KEEP(34)) DEALLOCATE(BLR_L) ENDIF NULLIFY(BLR_L) ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO J=1,NB_BLR+1 BEGS_BLR_TMP(J) = BEGS_BLR_STATIC(J) ENDDO ENDIF ENDIF IF ( & (KEEP(486).EQ.2) & ) THEN MEM_TOT = 0 #if ! defined(BLR_NOOPENMP) !$OMP PARALLEL !$OMP& PRIVATE(IP, NELIM) #endif #if ! defined(BLR_NOOPENMP) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*DIAGSIZ_STA MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(LDAFS,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN POSELT_DIAG = POSELT_DIAG + int(LDAFS,8) ENDDO CALL DMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG, KEEP(34)) ENDDO #if ! defined(BLR_NOOPENMP) !$OMP ENDDO !$OMP SINGLE #endif CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(int(MEM_TOT,8), & .FALSE., KEEP8, IFLAG, IERROR, .TRUE., .TRUE.) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 460 IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN DO IP=1,NPARTSASS NELIM = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8, & KEEP(34)) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, LDAFS, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(458), KEEP(473), & BLR_PANEL, IP, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 440 #if ! defined(BLR_NOOPENMP) !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if ! defined(BLR_NOOPENMP) !$OMP END SINGLE #endif ENDDO #if ! defined(BLR_NOOPENMP) !$OMP BARRIER #endif 440 CONTINUE ENDIF 460 CONTINUE #if ! defined(BLR_NOOPENMP) !$OMP END PARALLEL #endif IF (UU.GT.0 .AND. SWAP_OCCURRED) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 ENDIF IF ( & (KEEP(486).EQ.2) & ) THEN CALL DMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF CALL DMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 480 CONTINUE 500 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF(allocated(IPIV)) DEALLOCATE( IPIV ) IF (allocated(DIAG_ORIG)) DEALLOCATE(DIAG_ORIG) IF (LR_ACTIVATED) THEN IF (IFLAG.GE.0) THEN CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 1, NELIM) DO IP=1,NPARTSASS CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL UPD_MRY_LU_LRGAIN(BLR_PANEL, NPARTSASS-IP & ) ENDDO CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NASS-NELIM, 2, 2) ENDIF IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8, KEEP(34)) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, KEEP(50), 2) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL DMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8, KEEP(34)) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL DMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & KEEP(34)) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_FAC2_LDLT SUBROUTINE DMUMPS_RESET_TO_ONE(FRONT_INDEX_LIST, NPIV, & IBEG_BLOCK, K109_SAVE, K109, PIVNUL_LIST_STRUCT, & A, POSELT, LA, LDAFS) USE MUMPS_PIVNUL_MOD, ONLY: PIVNUL_LIST_STRUCT_T INTEGER, INTENT(IN) :: NPIV, IBEG_BLOCK INTEGER, INTENT(IN) :: FRONT_INDEX_LIST(NPIV) INTEGER, INTENT(IN) :: K109 INTEGER, INTENT(INOUT) :: K109_SAVE TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT INTEGER(8), INTENT(IN) :: POSELT, LA INTEGER, INTENT(IN) :: LDAFS DOUBLE PRECISION, INTENT(INOUT) :: A(LA) LOGICAL :: TO_UPDATE INTEGER :: I, JJ, K DOUBLE PRECISION ONE PARAMETER (ONE = 1.0D0) DO K = K109_SAVE+1, K109 TO_UPDATE = .FALSE. I = PIVNUL_LIST_STRUCT%PIVNUL_LIST(K) DO JJ=IBEG_BLOCK, NPIV IF (FRONT_INDEX_LIST(JJ) .EQ.I) THEN TO_UPDATE=.TRUE. EXIT ENDIF ENDDO IF (TO_UPDATE) THEN A(POSELT+int(JJ,8)+int(LDAFS,8)*int(JJ-1,8))= ONE TO_UPDATE=.FALSE. ELSE write(*,*) ' Internal error related ', & 'to null pivot row detection' CALL MUMPS_ABORT() ENDIF ENDDO K109_SAVE = K109 RETURN END SUBROUTINE DMUMPS_RESET_TO_ONE END MODULE DMUMPS_FAC2_LDLT_M MUMPS_5.8.1/src/cfac_asm_ELT.F0000664000175000017500000002411215042446440015577 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ELT_ASM_S_2_S_INIT( & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP, KEEP8, MYID, LRGROUPS) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER NELT, N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID INTEGER NBROWS, NBCOLS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER INTARR(KEEP8(27)) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) COMPLEX :: A(LA) COMPLEX :: DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) INTEGER(8) :: POSELT COMPLEX, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL CMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) IF (NASS.LT.0) THEN NASS = -NASS IW(IOLDPS+1+KEEP(IXSZ)) = NASS CALL CMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, FILS, & PTRAIW, PTRARW, & INTARR, DBLARR, KEEP8(27), KEEP8(26), FRT_PTR, FRT_ELT, & RHS_MUMPS, LRGROUPS) ENDIF IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_ELT_ASM_S_2_S_INIT SUBROUTINE CMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW, &IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, PTRARW, &INTARR, DBLARR, LINTARR, LDBLARR, FRT_PTR, FRT_ELT, RHS_MUMPS, &LRGROUPS) !$ USE OMP_LIB USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, intent(in) :: N, NELT, LIW, IOLDPS, INODE INTEGER(8), intent(in) :: LA, POSELT, LINTARR, LDBLARR INTEGER, intent(in) :: IW(LIW) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(inout) :: ITLOC(N+KEEP(253)) COMPLEX, intent(inout) :: A(LA) COMPLEX, intent(in) :: RHS_MUMPS(KEEP8(85)) INTEGER, intent(in) :: INTARR(LINTARR) COMPLEX, intent(in) :: DBLARR(LDBLARR) INTEGER, intent(in) :: FRT_PTR(N+1), FRT_ELT(NELT) INTEGER, intent(in) :: FILS(N) INTEGER(8), intent(in) :: PTRAIW(NELT+1), PTRARW(NELT+1) INTEGER, INTENT(IN) :: LRGROUPS(KEEP(280)) !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 !$ INTEGER :: CHUNK INCLUDE 'mumps_headers.h' INTEGER :: HF, NBROWF, NBCOLF, NASS, NSLAVES INTEGER :: ILOC, IELL, ELTI, ELBEG, NUMELT INTEGER(8) :: SIZE_ELTI8 INTEGER :: I, J, K, K1, K2 INTEGER :: IPOS, IPOS1, IPOS2, JPOS, IJROW INTEGER :: IN INTEGER(8) :: II8, JJ8, J18, J28 INTEGER(8) :: AINPUT8 INTEGER(8) :: AII8 INTEGER(8) :: APOS, APOS2, ICT12 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE, TOPDIAG INTEGER(8) :: JJ3 INTEGER :: K1RHS, K2RHS, JFirstRHS COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) !$ NOMP = OMP_GET_MAX_THREADS() IF (KEEP(50) .EQ. 0 .OR. NBROWF .LT. KEEP(63)) THEN !$ CHUNK8 = int(KEEP(361),8) #if defined(_CRAYFTN) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, KEEP(361)) #else !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) #endif !$OMP& IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8) !$OMP& .AND. NOMP .GT. 1) DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = 0 IF (IW(IOLDPS+XXLR).GE.1) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0, & NBROWF, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) NB_BLR_LS = NPARTSCB call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR_LS) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS, & NBCOLF, KEEP(35)) MINSIZE = int(IBCKSZ2 / 3) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max( KEEP(360)/2, !$ & ((NBROWF+NOMP-1)/NOMP +2) / 3 ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK) !$OMP& IF (NBROWF .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(NBROWF-1,8) APOS = POSELT+ JJ8*int(NBCOLF,8) JJ3 = min( int(NBCOLF,8) - 1_8, & JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG ) A(APOS: APOS+JJ3) = ZERO ENDDO !$OMP END PARALLEL DO ENDIF K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = -JPOS JPOS = JPOS + 1 END DO K1 = IOLDPS + HF K2 = K1 + NBROWF - 1 JPOS = 1 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN K1RHS = 0 K2RHS = -1 DO K = K1, K2 J = IW(K) ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN K1RHS = K JFirstRHS=J-N ENDIF JPOS = JPOS + 1 ENDDO IF (K1RHS.GT.0) K2RHS=K2 IF ( K2RHS.GE.K1RHS ) THEN IN = INODE DO WHILE (IN.GT.0) IJROW = -ITLOC(IN) DO K = K1RHS, K2RHS J = IW(K) I = ITLOC(J) ILOC = mod(I,NBCOLF) APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+ IN) ENDDO IN = FILS(IN) ENDDO ENDIF ELSE DO K = K1, K2 J = IW(K) ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS JPOS = JPOS + 1 END DO ENDIF ELBEG = FRT_PTR(INODE) NUMELT = FRT_PTR(INODE+1) - ELBEG DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1_8 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = ITLOC(INTARR(II8)) IF (KEEP(50).EQ.0) THEN IF (I.LE.0) CYCLE AINPUT8 = AII8 + II8 - J18 IPOS = mod(I,NBCOLF) ICT12 = POSELT + int(IPOS-1,8) * int(NBCOLF,8) DO JJ8 = J18, J28 JPOS = ITLOC(INTARR(JJ8)) IF (JPOS.LE.0) THEN JPOS = -JPOS ELSE JPOS = JPOS/NBCOLF END IF APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ELSE IF ( I .EQ. 0 ) THEN AII8 = AII8 + J28 - II8 + 1_8 CYCLE ENDIF IF ( I .LE. 0 ) THEN IPOS1 = -I IPOS2 = 0 ELSE IPOS1 = I/NBCOLF IPOS2 = mod(I,NBCOLF) END IF ICT12 = POSELT + int(IPOS2-1,8)*int(NBCOLF,8) DO JJ8=II8,J28 AII8 = AII8 + 1_8 J = ITLOC(INTARR(JJ8)) IF ( J .EQ. 0 ) CYCLE IF ( IPOS2.EQ.0 .AND. J.LE.0) CYCLE IF ( J .LE. 0 ) THEN JPOS = -J ELSE JPOS = J/NBCOLF END IF IF ( (IPOS1.GE.JPOS) .AND. (IPOS2.GT.0) ) THEN APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AII8-1_8) END IF IF ( (IPOS1.LT.JPOS) .AND. (J.GT.0) ) THEN IPOS = mod(J,NBCOLF) JPOS = IPOS1 APOS2 = POSELT + int(IPOS-1,8)*int(NBCOLF,8) & + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AII8-1_8) END IF END DO END IF END DO END DO K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 END DO END SUBROUTINE CMUMPS_ASM_SLAVE_ELEMENTS MUMPS_5.8.1/src/zfac_omp_m.F0000664000175000017500000015351115042446441015460 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_OMP_M INTEGER(8), PARAMETER :: UnderL0 = -20_8 INTEGER(8), PARAMETER :: CopyNotStarted = -19_8 INTEGER(8), PARAMETER :: WaitMem = -18_8 INTEGER(8), PARAMETER :: CopyFactorsFinished = -17_8 INTEGER(8), PARAMETER :: AllocateViderCBEnCours = -16_8 INTEGER(8), PARAMETER :: Finished = -15_8 CONTAINS SUBROUTINE ZMUMPS_FAC_L0_OMP(N,LIW, NSTK_STEPS, ND, & FILS,STEP, FRERE, DAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PTRIST, PTRAST, PIMASTER, PAMASTER, PTRARW, PTRAIW, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, & RHS_MUMPS, RINFO, NBROOT, NBRTOT, NBROOT_UNDER_L0, UU, ICNTL, & PTLUST_S, PTRFAC, INFO, KEEP, KEEP8, PROCNODE_STEPS,SLAVEF, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & INTARR, DBLARR, root, roota, PERM, NELT, FRTPTR, FRTELT, LPTRAR, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB, NE, DKEEP, PIVNUL_LIST_STRUCT, & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, & L_VIRT_L0_OMP, VIRT_L0_OMP, VIRT_L0_OMP_MAPPING, & L_PHYS_L0_OMP, PHYS_L0_OMP, PERM_L0_OMP, PTR_LEAFS_L0_OMP, & L0_OMP_MAPPING, LL0_OMP_MAPPING, THREAD_LA, & MUMPS_TPS_ARR, ZMUMPS_TPS_ARR, & NSTEPSW, OPASSW, OPELIW, NELVAW, COMP, & MAXFRW, NMAXNPIVW, NPVW, NOFFNEGW, NULLNEGW, & NB22T1W, NBTINYW, DET_EXPW, DET_MANTW, DET_SIGNW, & LRGROUPS, L0_OMP_FACTORS, LL0_OMP_FACTORS, & I4_L0_OMP, NBSTATS_I4, NBCOLS_I4, & I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 ) USE MUMPS_LOAD !$ USE OMP_LIB USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T USE ZMUMPS_TPS_M, ONLY : ZMUMPS_TPS_T USE MUMPS_LR_STATS USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC, & ZMUMPS_L0OMPFAC_T USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : & ZMUMPS_DM_FAC_ALLOC_ALLOWED, & ZMUMPS_DM_ALLOC_S_WK, & ZMUMPS_DM_FREE_S_WK USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER N,LIW, LPTRAR, & NSTEPSW, INFO(80) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER(8), INTENT(IN) :: THREAD_LA INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST_S(KEEP(28)), PERM(N) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NE(KEEP(28)) DOUBLE PRECISION RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER NBROOT INTEGER NBRTOT INTEGER, intent(out) :: NBROOT_UNDER_L0 INTEGER COMM_LOAD, ASS_IRECV DOUBLE PRECISION UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION DKEEP(230) DOUBLE PRECISION :: OPASSW, OPELIW INTEGER LRGROUPS(KEEP(280)) INTEGER, INTENT ( IN ) :: LPOOL_B_L0_OMP INTEGER, INTENT ( IN ) :: IPOOL_B_L0_OMP & ( LPOOL_B_L0_OMP ) INTEGER, INTENT ( IN ) :: L_PHYS_L0_OMP INTEGER, INTENT ( IN ) :: PHYS_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT ( IN ) :: L_VIRT_L0_OMP INTEGER, INTENT ( IN ) :: VIRT_L0_OMP( L_VIRT_L0_OMP ) INTEGER, INTENT ( IN ) :: VIRT_L0_OMP_MAPPING( L_VIRT_L0_OMP ) INTEGER, INTENT ( IN ) :: PERM_L0_OMP( L_PHYS_L0_OMP ) INTEGER, INTENT ( IN ) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1) INTEGER, INTENT ( IN ) :: LL0_OMP_MAPPING INTEGER, INTENT ( OUT ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) TYPE (MUMPS_TPS_T), DIMENSION(:) :: MUMPS_TPS_ARR TYPE (ZMUMPS_TPS_T), DIMENSION(:) :: ZMUMPS_TPS_ARR INTEGER, INTENT ( IN ) :: LL0_OMP_FACTORS TYPE (ZMUMPS_L0OMPFAC_T), INTENT(INOUT) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER, INTENT (IN) :: NBSTATS_I4, NBSTATS_I8 INTEGER, INTENT (IN) :: NBCOLS_I4, NBCOLS_I8 INTEGER, INTENT (IN) :: I4_L0_OMP(NBSTATS_I4, NBCOLS_I4) INTEGER(8), INTENT (IN) :: I8_L0_OMP(NBSTATS_I8, NBCOLS_I8) LOGICAL ZMUMPS_POOL_EMPTY EXTERNAL ZMUMPS_POOL_EMPTY, ZMUMPS_EXTRACT_POOL INTEGER :: MYTHREAD_ID, ITH INTEGER :: THREAD_ID_P DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 INTEGER INODE, LEAF INTEGER TYPEF INTEGER NBFIN INTEGER TYPE INTEGER NBROOT_PROCESSED INTEGER MAXFRW, NPVW, NMAXNPIVW, NOFFNEGW, NULLNEGW, NELVAW, COMP INTEGER :: NB22T1W, NBTINYW, DET_EXPW, DET_SIGNW COMPLEX(kind=8) :: DET_MANTW DOUBLE PRECISION FLOP_ESTIM_ACC INTEGER :: LPOOL_P INTEGER, DIMENSION(:), ALLOCATABLE :: IPOOL_P INTEGER(8) :: TO_ALLOCATE INTEGER, DIMENSION(:), ALLOCATABLE :: ID INTEGER(8), DIMENSION(:), ALLOCATABLE :: VAL INTEGER(8), ALLOCATABLE, DIMENSION(:) :: STATE, SIZE_COPIED INTEGER :: NbWaitMem, NbFinished, NbOnGoingCopies, NbUnderL0 INTEGER(8) :: KEEP8_77_SAVE DOUBLE PRECISION :: GTIME INTEGER(8) :: MEMDISPO_UNDERL0, MEMDISPO_PERTHREAD INTEGER :: BLR_STRAT INTEGER :: VIRTUAL_TASK, PHYSICAL_TASK INTEGER :: IFATH INTEGER :: I, INFO_P(2), allocok INTEGER(8) :: I8 !$ INTEGER(8) :: CHUNK8 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP_SAVE, NOMP_TOTAL !$ INTEGER :: NOMP_INNER !$ LOGICAL :: SAVE_NESTED CALL MUMPS_LOAD_DISABLE() GTIME = MPI_WTIME() L0_OMP_MAPPING = 0 NBROOT_PROCESSED = 0 NSTEPSW = 0 OPASSW = DZERO OPELIW = DZERO NELVAW = 0 COMP = 0 MAXFRW = 0 NMAXNPIVW = 0 NOFFNEGW = 0 NULLNEGW = 0 FLOP_ESTIM_ACC = DZERO NPVW = 0 NB22T1W = 0 NBTINYW = 0 DET_EXPW = 0 DET_MANTW = cmplx(1.0D0,0.0D0, kind=kind(1.0D0)) DET_SIGNW = 1 DO ITH = 1, KEEP(400) NULLIFY(MUMPS_TPS_ARR(ITH)%IW) NULLIFY(MUMPS_TPS_ARR(ITH)%ITLOC) NULLIFY(ZMUMPS_TPS_ARR(ITH)%A) CALL ZMUMPS_SET_MAXS_MAXIS_THREAD( & MUMPS_TPS_ARR(ITH)%LA, & MUMPS_TPS_ARR(ITH)%LIW, BLR_STRAT, & KEEP, & I4_L0_OMP(1,ITH), NBSTATS_I4, & I8_L0_OMP(1,ITH), NBSTATS_I8) ENDDO IF (KEEP8(4) .NE. 0_8) THEN CALL ZMUMPS_MA_EFF_MEM_DISPO ( & MUMPS_TPS_ARR, KEEP(400),KEEP8, KEEP, & N, BLR_STRAT, LPOOL_B_L0_OMP, & I8_L0_OMP, NBSTATS_I8, & MEMDISPO_UNDERL0 & ) IF (KEEP(486).EQ.2) THEN MEMDISPO_UNDERL0 = max(MEMDISPO_UNDERL0/20_8,0_8) ELSE MEMDISPO_UNDERL0 = max(MEMDISPO_UNDERL0/4_8,0_8) ENDIF KEEP8(77) = KEEP8(77) + MEMDISPO_UNDERL0 MEMDISPO_PERTHREAD = 0_8 IF (MEMDISPO_UNDERL0.GT.0) THEN MEMDISPO_PERTHREAD = MEMDISPO_UNDERL0/(int(KEEP(400),8)) ENDIF DO ITH = 1, KEEP(400) MUMPS_TPS_ARR(ITH)%LA = MUMPS_TPS_ARR(ITH)%LA + & MEMDISPO_PERTHREAD ENDDO ENDIF DO ITH = 1, KEEP(400) MUMPS_TPS_ARR(ITH)%LRLU = MUMPS_TPS_ARR(ITH)%LA MUMPS_TPS_ARR(ITH)%LRLUS = MUMPS_TPS_ARR(ITH)%LA MUMPS_TPS_ARR(ITH)%LRLUSM = MUMPS_TPS_ARR(ITH)%LA MUMPS_TPS_ARR(ITH)%IPTRLU = MUMPS_TPS_ARR(ITH)%LA MUMPS_TPS_ARR(ITH)%POSFAC = 1_8 MUMPS_TPS_ARR(ITH)%IWPOS = 1 MUMPS_TPS_ARR(ITH)%IWPOSCB = MUMPS_TPS_ARR(ITH)%LIW ENDDO IF (KEEP(406) .EQ. 2 ) THEN ALLOCATE(STATE(KEEP(400)), SIZE_COPIED(KEEP(400)), stat=allocok) IF (allocok .GT. 0 ) THEN WRITE(*,*) "Problem allocating STATE/SIZE_COPIED", KEEP(400) CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_PERFORM_COPIES_INIT( STATE, KEEP8_77_SAVE, & NbWaitMem, NbFinished, NbOnGoingCopies, NbUnderL0, & KEEP, KEEP8 ) ENDIF !$ NOMP_INNER = 1 !$ IF (KEEP(369).GT.0) THEN !$ NOMP_TOTAL = omp_get_max_threads() !$ IF ( NOMP_TOTAL .NE. KEEP(400) ) THEN !$ IF ( KEEP(439) .GT. 1 ) THEN !$ NOMP_INNER = KEEP(439) !$ ELSE IF ( KEEP(439) .EQ. -1 !$ & ) THEN !$ NOMP_INNER = NOMP_TOTAL / KEEP(400) !$ ENDIF !$ IF (NOMP_INNER .GT. 1) THEN !$ SAVE_NESTED = omp_get_nested() !$ CALL OMP_SET_NESTED(.TRUE.) !$ ENDIF !$ ENDIF #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(KEEP(400),4)) #else !$ CALL omp_set_num_threads(KEEP(400)) #endif !$ ENDIF !$OMP PARALLEL !$OMP& SHARED ( IPOOL_B_L0_OMP, LPOOL_B_L0_OMP ) !$OMP& PRIVATE ( VIRTUAL_TASK, PHYSICAL_TASK, !$OMP& IPOOL_P, LPOOL_P, LEAF, INODE, IFATH, INFO_P, I, I8, !$OMP& TO_ALLOCATE, THREAD_ID_P, !$OMP& TYPE, TYPEF, NOMP_SAVE, allocok ) !$OMP& REDUCTION ( + : NPVW, OPASSW, OPELIW, NOFFNEGW, NELVAW, COMP, !$OMP& NB22T1W, NBTINYW, DET_EXPW, NULLNEGW, !$OMP& FLOP_ESTIM_ACC, NBROOT_PROCESSED, NSTEPSW ) !$OMP& REDUCTION ( * : DET_MANTW, DET_SIGNW ) !$OMP& REDUCTION ( max : MAXFRW, NMAXNPIVW ) THREAD_ID_P = 1 !$ THREAD_ID_P = OMP_GET_THREAD_NUM () + 1 !$OMP BARRIER !$ NOMP_SAVE = omp_get_max_threads() #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_INNER,4)) #else !$ CALL omp_set_num_threads(NOMP_INNER) #endif LPOOL_P = LPOOL_B_L0_OMP LEAF = 1 INFO_P = 0 VIRTUAL_TASK = 0 !$ IF ( omp_get_num_threads() .NE. KEEP(400) ) THEN !$ INFO_P(1)=-58 !$ INFO_P(2)=-100-omp_get_num_threads() !$ GOTO 700 !$ ENDIF CALL ZMUMPS_DM_FAC_ALLOC_ALLOWED( MUMPS_TPS_ARR(THREAD_ID_P)%LA, & KEEP8, & INFO_P(1), INFO_P(2) ) IF (INFO_P(1) .LT. 0) GOTO 700 CALL ZMUMPS_DM_ALLOC_S_WK( ZMUMPS_TPS_ARR(THREAD_ID_P)%A, & max(1_8,MUMPS_TPS_ARR(THREAD_ID_P)%LA), allocok, KEEP(430), & KEEP(35) ) IF (allocok.GT.0) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4( MUMPS_TPS_ARR(THREAD_ID_P)%LA, & INFO_P(2)) GOTO 700 ELSE CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & MUMPS_TPS_ARR(THREAD_ID_P)%LA, & KEEP(405).EQ.1, & KEEP8, INFO_P(1), INFO_P(2), & .FALSE., .FALSE. ) IF (INFO_P(1) .LT. 0) THEN GOTO 700 ENDIF ENDIF TO_ALLOCATE = & ((int(MUMPS_TPS_ARR(THREAD_ID_P)%LIW,8) * int(KEEP(34),8 )) / & int(KEEP(35),8 ))+ & ((int(LPOOL_P,8) * int(KEEP(34),8 )) / int(KEEP(35),8 ))+ & ((int(N+KEEP(253),8) * int(KEEP(34),8 )) / int(KEEP(35),8 )) CALL ZMUMPS_DM_FAC_ALLOC_ALLOWED( TO_ALLOCATE, & KEEP8, INFO_P(1), INFO_P(2) ) IF ( INFO_P(1) .LT. 0 ) GOTO 700 ALLOCATE ( MUMPS_TPS_ARR(THREAD_ID_P)%IW( & MUMPS_TPS_ARR(THREAD_ID_P)%LIW ), & IPOOL_P ( LPOOL_P ), & MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC ( N + KEEP(253) ), & stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO_P(1) = -13 INFO_P(2) = MUMPS_TPS_ARR(THREAD_ID_P)%LIW + & LPOOL_P + N+KEEP(253) GOTO 700 ELSE CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( TO_ALLOCATE, & KEEP(405).EQ.1, KEEP8, & INFO_P(1), INFO_P(2), .TRUE., .FALSE. ) IF (INFO_P(1) .LT. 0) THEN GOTO 700 ENDIF ENDIF CALL ZMUMPS_ALLOC_CB( .FALSE., 0_8, & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, DKEEP, & MUMPS_TPS_ARR(THREAD_ID_P)%IW(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LIW, & ZMUMPS_TPS_ARR(THREAD_ID_P)%A(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LA, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%IPTRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOS, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUSM, & INFO_P(1), INFO_P(2) & ) CALL ZMUMPS_INIT_POOL_LAST3( IPOOL_P(1), LPOOL_P, & LEAF ) MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC = 0 600 CONTINUE VIRTUAL_TASK = VIRTUAL_TASK + 1 IF ( VIRTUAL_TASK .LT. L_VIRT_L0_OMP ) THEN IF ( VIRT_L0_OMP_MAPPING( VIRTUAL_TASK ) .EQ. THREAD_ID_P ) THEN DO PHYSICAL_TASK = & VIRT_L0_OMP ( VIRTUAL_TASK ), & VIRT_L0_OMP ( VIRTUAL_TASK + 1 ) - 1 DO I = PTR_LEAFS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK )+1 ) + 1, & PTR_LEAFS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK ) ) IF (IPOOL_B_L0_OMP(I) .GT. 0) THEN CALL ZMUMPS_INSERT_POOL_N( N, IPOOL_P(1), & LPOOL_P, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), 3, 0, 1, STEP, & IPOOL_B_L0_OMP(I) ) END IF END DO DO WHILE ( & .NOT. ZMUMPS_POOL_EMPTY( IPOOL_P(1), LPOOL_P ) & .AND. INFO_P(1) .GE. 0 ) CALL ZMUMPS_EXTRACT_POOL( N, IPOOL_P(1), LPOOL_P, & PROCNODE_STEPS, SLAVEF, STEP, INODE, KEEP, KEEP8, MYID_NODES, & ND, .FALSE. ) 10 CONTINUE L0_OMP_MAPPING ( STEP ( INODE ) ) = THREAD_ID_P IFATH = DAD ( STEP ( INODE ) ) TYPE = 1 IF ( IFATH .NE. 0 ) THEN TYPEF = 1 ELSE TYPEF = -9999 ENDIF CALL MUMPS_STOP_ON_USER_REQUEST(KEEP, KEEP8, ICNTL, & INFO_P, MYID) IF (INFO_P(1) .LT. 0) THEN GOTO 700 ENDIF IF (THREAD_ID_P .EQ. KEEP(400)-1) THEN CALL ZMUMPS_UPDATE_PROGRESS( OPELIW*KEEP(400), KEEP8 ) ENDIF CALL ZMUMPS_PROCESS_FRONT_NIV1(COMM_LOAD, ASS_IRECV, N, INODE, & TYPE, TYPEF, MUMPS_TPS_ARR(THREAD_ID_P)%LA, MUMPS_TPS_ARR(THREAD & _ID_P)%IW(1), MUMPS_TPS_ARR(THREAD_ID_P)%LIW, ZMUMPS_TPS_ARR( & THREAD_ID_P)%A(1), MAXFRW, NOFFNEGW, NULLNEGW, NPVW, & NB22T1W, NBTINYW, DET_EXPW, DET_MANTW, DET_SIGNW, INFO_P, UU, & SEUIL, SEUIL_LDLT_NIV2, OPELIW, NELVAW, NMAXNPIVW, NSTEPSW, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & NE, MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS, MUMPS_TPS_ARR(THREAD_ID_P)% % LRLUSM, MUMPS_TPS_ARR(THREAD_ID_P)%IPTRLU, ICNTL, KEEP, KEEP8, & DKEEP, PIVNUL_LIST_STRUCT, COMP, MUMPS_TPS_ARR(THREAD_ID_P)% & IWPOS, MUMPS_TPS_ARR(THREAD_ID_P)%IWPOSCB, PROCNODE_STEPS, & SLAVEF, IFATH, COMM_NODES, MYID_NODES, IPOOL_P, LPOOL_P, LEAF, & PERM, NSTK_STEPS, BUFR, LBUFR, LBUFR_BYTES, & NBFIN, root, roota, OPASSW, MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC(1), & RHS_MUMPS, FILS, PTRARW, PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, & PTRDEBARR, INTARR, DBLARR, ND, FRERE, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS, FLOP_ESTIM_ACC ) IF (INFO_P(1) .LT. 0) THEN GOTO 700 ENDIF IF ( IFATH .NE. 0 ) THEN IF ( PHYS_L0_OMP ( PERM_L0_OMP ( PHYSICAL_TASK ) ) & .NE. INODE ) THEN NSTK_STEPS ( STEP ( IFATH ) ) = & NSTK_STEPS ( STEP ( IFATH ) ) - 1 IF ( NSTK_STEPS ( STEP ( IFATH ) ) .EQ. 0 ) THEN INODE = IFATH GOTO 10 ENDIF ELSE !$OMP ATOMIC UPDATE NSTK_STEPS ( STEP ( IFATH ) ) = & NSTK_STEPS ( STEP ( IFATH ) ) - 1 !$OMP END ATOMIC END IF ELSE NBROOT_PROCESSED = NBROOT_PROCESSED + 1 END IF END DO END DO ENDIF GOTO 600 ENDIF 700 CONTINUE IF (associated(MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC)) THEN DEALLOCATE(MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC) NULLIFY(MUMPS_TPS_ARR(THREAD_ID_P)%ITLOC) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -(int(N+KEEP(253),8) * int(KEEP(34),8 )) / int(KEEP(35),8), & KEEP(405).EQ.1, KEEP8, & INFO_P(1), INFO_P(2), .TRUE., .FALSE. ) ENDIF IF (allocated(IPOOL_P)) THEN DEALLOCATE(IPOOL_P); CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -(int(LPOOL_P,8) * int(KEEP(34),8 )) / int(KEEP(35),8), & KEEP(405).EQ.1, KEEP8, & INFO_P(1), INFO_P(2), .TRUE., .FALSE. ) ENDIF IF ( KEEP(406) .EQ. 2) THEN CALL ZMUMPS_PERFORM_COPIES( THREAD_ID_P, & MUMPS_TPS_ARR, ZMUMPS_TPS_ARR, & L0_OMP_FACTORS, LL0_OMP_FACTORS, & STATE, SIZE_COPIED, & NbWaitMem, NbFinished, NbOngoingCopies, NbUnderL0, & MYID_NODES, N, SLAVEF, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & KEEP, KEEP8, INFO_P & ) ELSE IF ((KEEP(407) .EQ. 1) .OR. (KEEP(406) .EQ.1) ) THEN IF (INFO_P(1) .GE. 0) THEN CALL ZMUMPS_DM_CBSTATIC2DYNAMIC_I & (2, & 0_8, & .FALSE., & MYID_NODES, N, SLAVEF, KEEP, KEEP8, & MUMPS_TPS_ARR(THREAD_ID_P)%IW(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LIW, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOSCB, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOS, & ZMUMPS_TPS_ARR(THREAD_ID_P)%A(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LA, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%IPTRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & INFO_P(1), INFO_P(2) ) ENDIF ENDIF IF (KEEP(406) .EQ.1) THEN IF (INFO_P(1) .GE.0 )THEN TO_ALLOCATE = max(MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1,1_8) CALL ZMUMPS_DM_FAC_ALLOC_ALLOWED( TO_ALLOCATE, & KEEP8, INFO_P(1), INFO_P(2) ) ENDIF IF (INFO_P(1) .GE.0 )THEN ALLOCATE(L0_OMP_FACTORS(THREAD_ID_P)%A(TO_ALLOCATE), & stat=allocok) IF (allocok .GT. 0) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4(TO_ALLOCATE, INFO_P(2)) L0_OMP_FACTORS(THREAD_ID_P)%LA = 0_8 ELSE L0_OMP_FACTORS(THREAD_ID_P)%LA = & MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8 CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & L0_OMP_FACTORS(THREAD_ID_P)%LA, KEEP(405).EQ.1, KEEP8, & INFO_P(1), INFO_P(2), .TRUE., .FALSE. ) ENDIF ENDIF IF (INFO_P(1) .GE.0 ) THEN DO I8 = 1_8, MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8 L0_OMP_FACTORS(THREAD_ID_P)%A(I8) = & ZMUMPS_TPS_ARR(THREAD_ID_P)%A(I8) ENDDO ENDIF IF ( associated(ZMUMPS_TPS_ARR(THREAD_ID_P)%A)) THEN CALL ZMUMPS_DM_FREE_S_WK( ZMUMPS_TPS_ARR(THREAD_ID_P)%A, & KEEP(430) ) NULLIFY(ZMUMPS_TPS_ARR(THREAD_ID_P)%A) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -MUMPS_TPS_ARR(THREAD_ID_P)%LA, & KEEP(405).EQ.1, & KEEP8, & INFO_P(1), INFO_P(2), & .FALSE., .FALSE. ) IF (INFO_P(1) .GE. 0) THEN !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - L0_OMP_FACTORS(THREAD_ID_P)%LA !$OMP END ATOMIC ENDIF ENDIF ENDIF ENDIF IF (INFO_P(1) .LT.0) THEN !$OMP CRITICAL(critical_info) INFO(1) = INFO_P(1) INFO(2) = INFO_P(2) !$OMP END CRITICAL(critical_info) ELSE IF (INFO_P(1) .GE. 0) THEN !$OMP CRITICAL(critical_info) IF (INFO(1) .EQ. 0) THEN INFO(1) = INFO_P(1) INFO(2) = INFO_P(2) ENDIF !$OMP END CRITICAL(critical_info) ENDIF #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_SAVE,4)) #else !$ CALL omp_set_num_threads(NOMP_SAVE) #endif !$OMP END PARALLEL !$ IF (KEEP(369).GT.0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(NOMP_TOTAL),4)) #else !$ CALL omp_set_num_threads(NOMP_TOTAL) #endif !$ IF (NOMP_INNER .GT. 1) THEN !$ CALL OMP_SET_NESTED(SAVE_NESTED) !$ ENDIF !$ ENDIF IF (INFO(1) .LT. 0) THEN IF (ICNTL(1) .GT. 0 .AND. ICNTL(4) .GE.1 ) THEN WRITE(ICNTL(1),'(A,I6,I16,A,I5,A)') & "** ERROR DURING L0_OMP: INFO(1:2)=", & INFO(1), INFO(2), " (MPI worker ", MYID_NODES,")" ENDIF ENDIF IF ( KEEP(406) .EQ. 0 ) THEN ALLOCATE(ID(KEEP(400)), VAL(KEEP(400)), & stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = KEEP(400) GOTO 800 ENDIF DO MYTHREAD_ID = 1, KEEP(400) VAL (MYTHREAD_ID) = MUMPS_TPS_ARR( MYTHREAD_ID )%POSFAC-1_8 ID (MYTHREAD_ID) = MYTHREAD_ID ENDDO CALL MUMPS_SORT_INT8(KEEP(400), VAL, ID) DO ITH=1, KEEP(400) MYTHREAD_ID = ID(ITH) IF ((KEEP(407).NE.1) .AND. (KEEP(406).EQ.0)) THEN IF (INFO(1) .GE. 0) THEN CALL ZMUMPS_DM_CBSTATIC2DYNAMIC_I & (2, & 0_8, & .FALSE., & MYID_NODES, N, SLAVEF, KEEP, KEEP8, & MUMPS_TPS_ARR(MYTHREAD_ID)%IW(1), & MUMPS_TPS_ARR(MYTHREAD_ID)%LIW, & MUMPS_TPS_ARR(MYTHREAD_ID)%IWPOSCB, & MUMPS_TPS_ARR(MYTHREAD_ID)%IWPOS, & ZMUMPS_TPS_ARR(MYTHREAD_ID)%A(1), & MUMPS_TPS_ARR(MYTHREAD_ID)%LA, & MUMPS_TPS_ARR(MYTHREAD_ID)%LRLU, & MUMPS_TPS_ARR(MYTHREAD_ID)%IPTRLU, & MUMPS_TPS_ARR(MYTHREAD_ID)%LRLUS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & INFO(1), INFO(2) ) ENDIF ENDIF IF (KEEP(406).EQ.0) THEN IF (INFO(1) .GE. 0 )THEN TO_ALLOCATE = max(MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC-1,1_8) CALL ZMUMPS_DM_FAC_ALLOC_ALLOWED( TO_ALLOCATE, & KEEP8, INFO(1), INFO(2) ) ENDIF IF (INFO(1) .GE.0 ) THEN ALLOCATE(L0_OMP_FACTORS(MYTHREAD_ID)%A(TO_ALLOCATE), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1) = -13 CALL MUMPS_SETI8TOI4(TO_ALLOCATE, INFO(2)) L0_OMP_FACTORS(MYTHREAD_ID)%LA = 0_8 ELSE L0_OMP_FACTORS(MYTHREAD_ID)%LA = & MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC-1_8 CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & L0_OMP_FACTORS(MYTHREAD_ID)%LA, & KEEP(405).EQ.1, KEEP8, & INFO(1), INFO(2), .TRUE., .FALSE. ) ENDIF ENDIF IF (INFO(1) .GE. 0) THEN !$ CHUNK8 = max( int(KEEP(361),8), !$ & (MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC+KEEP(400)-2_8) / !$ & KEEP(400) ) !$ OMP_FLAG = ( (MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC-1_8 > !$ & int(KEEP(361),8)) !$ & .AND. (KEEP(400).GT.1) !$ & ) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (OMP_FLAG) DO I8 = 1_8, MUMPS_TPS_ARR(MYTHREAD_ID)%POSFAC-1_8 L0_OMP_FACTORS(MYTHREAD_ID)%A(I8) = & ZMUMPS_TPS_ARR(MYTHREAD_ID)%A(I8) ENDDO !$OMP END PARALLEL DO ENDIF IF ( associated(ZMUMPS_TPS_ARR(MYTHREAD_ID)%A)) THEN CALL ZMUMPS_DM_FREE_S_WK( ZMUMPS_TPS_ARR(THREAD_ID_P)%A, & KEEP(430) ) NULLIFY(ZMUMPS_TPS_ARR(MYTHREAD_ID)%A) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -MUMPS_TPS_ARR(MYTHREAD_ID)%LA, & KEEP(405).EQ.1, KEEP8, & INFO(1), INFO(2), & .FALSE., .FALSE. ) IF (INFO(1).GE.0) THEN KEEP8(69) = KEEP8(69) - L0_OMP_FACTORS(MYTHREAD_ID)%LA ENDIF ENDIF ENDIF ENDDO IF (ALLOCATED(ID)) DEALLOCATE(ID) IF (ALLOCATED(VAL)) DEALLOCATE(VAL) ENDIF 800 CONTINUE DO ITH = 1, KEEP(400) IF ( associated(ZMUMPS_TPS_ARR(ITH)%A)) THEN CALL ZMUMPS_DM_FREE_S_WK( ZMUMPS_TPS_ARR(ITH)%A, & KEEP(430) ) NULLIFY(ZMUMPS_TPS_ARR(ITH)%A) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -MUMPS_TPS_ARR(ITH)%LA, & KEEP(405).EQ.1, KEEP8, & INFO(1), INFO(2), & .FALSE., .FALSE. ) IF (INFO(1).GE.0) THEN KEEP8(69) = KEEP8(69) - L0_OMP_FACTORS(ITH)%LA ENDIF ENDIF ENDDO KEEP8(64) = 0_8 DO I = 1, KEEP(400) KEEP8(64) = KEEP8(64) + MUMPS_TPS_ARR(I)%POSFAC - 1_8 ENDDO KEEP8(62) = 0_8 DO I = 1, KEEP(400) KEEP8(62) = KEEP8(62) + MUMPS_TPS_ARR(I)%LRLUSM ENDDO NBROOT_UNDER_L0 = NBROOT_PROCESSED DKEEP(95) = MPI_WTIME() - GTIME IF (KEEP(486) .NE. 0) THEN TIME_UPDATE = TIME_UPDATE/dble(KEEP(400)) TIME_COMPRESS = TIME_COMPRESS/dble(KEEP(400)) TIME_FRSWAP_COMPRESS = TIME_FRSWAP_COMPRESS/dble(KEEP(400)) TIME_CB_COMPRESS = TIME_CB_COMPRESS/dble(KEEP(400)) TIME_PANEL = TIME_PANEL/dble(KEEP(400)) TIME_FAC_I = TIME_FAC_I/dble(KEEP(400)) TIME_FAC_MQ = TIME_FAC_MQ/dble(KEEP(400)) TIME_FAC_SQ = TIME_FAC_SQ/dble(KEEP(400)) TIME_FRFRONTS = TIME_FRFRONTS/dble(KEEP(400)) TIME_LRTRSM = TIME_LRTRSM/dble(KEEP(400)) TIME_FRTRSM = TIME_FRTRSM/dble(KEEP(400)) TIME_LR_MODULE = TIME_LR_MODULE/dble(KEEP(400)) TIME_DECOMP = TIME_DECOMP/dble(KEEP(400)) TIME_DIAGCOPY = TIME_DIAGCOPY/dble(KEEP(400)) TIME_DECOMP_UCFS = TIME_DECOMP_UCFS/dble(KEEP(400)) TIME_LRASM_NIV1 = TIME_LRASM_NIV1/dble(KEEP(400)) TIME_LRASM_LOCASM2 = TIME_LRASM_LOCASM2/dble(KEEP(400)) TIME_LRASM_MAPLIG1 = TIME_LRASM_MAPLIG1/dble(KEEP(400)) TIME_LRASM_CONTRIB2 = TIME_LRASM_CONTRIB2/dble(KEEP(400)) TIME_FRASM_LOCASM2 = TIME_FRASM_LOCASM2/dble(KEEP(400)) TIME_FRASM_MAPLIG1 = TIME_FRASM_MAPLIG1/dble(KEEP(400)) TIME_FRASM_CONTRIB2 = TIME_FRASM_CONTRIB2/dble(KEEP(400)) ENDIF DKEEP(97) = DKEEP(97) / dble(KEEP(400)) CALL MUMPS_LOAD_ENABLE() CALL MUMPS_LOAD_UPDATE(0,.FALSE., FLOP_ESTIM_ACC,KEEP,KEEP8) RETURN END SUBROUTINE ZMUMPS_FAC_L0_OMP SUBROUTINE ZMUMPS_SET_MAXS_MAXIS_THREAD(MAXS_BASE_RELAXED8TH, & MAXIS_BASE_RELAXEDTH, BLR_STRAT, & KEEP, & I4_L0_OMPTH, NBSTATS_I4, & I8_L0_OMPTH, NBSTATS_I8) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP(500), NBSTATS_I4, NBSTATS_I8 INTEGER, INTENT(IN) :: I4_L0_OMPTH(NBSTATS_I4) INTEGER(8), INTENT(IN) :: I8_L0_OMPTH(NBSTATS_I8) INTEGER(8), INTENT(OUT) :: MAXS_BASE_RELAXED8TH INTEGER, INTENT(OUT) :: MAXIS_BASE_RELAXEDTH INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER :: PERLU INTEGER(8) :: MAXS_BASE8TH INTEGER(8) :: MAXIS_BASE_RELAXEDTH8 PERLU = KEEP(12) CALL ZMUMPS_SET_BLRSTRAT_AND_MAXS ( MAXS_BASE8TH, & MAXS_BASE_RELAXED8TH, BLR_STRAT, KEEP(1), & I8_L0_OMPTH(2), I8_L0_OMPTH(3), I8_L0_OMPTH(5), & I8_L0_OMPTH(6), I8_L0_OMPTH(7), I8_L0_OMPTH(8) ) IF ( KEEP(201) .EQ. 0 ) THEN MAXIS_BASE_RELAXEDTH8 = int(I4_L0_OMPTH(2),8) ELSE MAXIS_BASE_RELAXEDTH8 = int(I4_L0_OMPTH(4),8) ENDIF MAXIS_BASE_RELAXEDTH8 = max( 1_8, & MAXIS_BASE_RELAXEDTH8 + 3 * max(PERLU,10) * & ( MAXIS_BASE_RELAXEDTH8 / 100 + 1 ) & ) MAXIS_BASE_RELAXEDTH8 = min(MAXIS_BASE_RELAXEDTH8, & int( huge( MAXIS_BASE_RELAXEDTH ) ,8) & ) MAXIS_BASE_RELAXEDTH = int( MAXIS_BASE_RELAXEDTH8 ) RETURN END SUBROUTINE ZMUMPS_SET_MAXS_MAXIS_THREAD SUBROUTINE ZMUMPS_MA_EFF_MEM_DISPO( & MUMPS_TPS_ARR, NBTHREADS, KEEP8, KEEP, & N, BLR_STRAT, LPOOL_P, & I8_L0_OMP, NBSTATS_I8, & MEMDISPO_UNDERL0) USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T IMPLICIT NONE INTEGER, INTENT(IN) :: N, BLR_STRAT, KEEP(500) INTEGER, INTENT(IN) :: NBSTATS_I8, NBTHREADS, LPOOL_P INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER(8), INTENT(IN) :: I8_L0_OMP(NBSTATS_I8,NBTHREADS) INTEGER(8), INTENT(OUT) :: MEMDISPO_UNDERL0 TYPE (MUMPS_TPS_T), INTENT(IN) :: MUMPS_TPS_ARR(:) INTEGER :: PERLU, ITH, ITHMIN, ITHMIN_if_LRLU, OOC_STRAT INTEGER(8) :: TO_ALLOCATE, BLR_RELATED, COPY_RELATED INTEGER(8) :: MIN_NRLADU_underL0, MIN_NRLADU_if_LR_LU_underL0 PERLU = KEEP(12) OOC_STRAT = KEEP(201) TO_ALLOCATE = 0_8 DO ITH = 1, NBTHREADS TO_ALLOCATE = TO_ALLOCATE + & ((int(MUMPS_TPS_ARR(ITH)%LIW,8) * int(KEEP(34),8 )) / & int(KEEP(35),8 )) & + MUMPS_TPS_ARR(ITH)%LA ENDDO TO_ALLOCATE = TO_ALLOCATE + int(NBTHREADS,8)* ( & ((int(LPOOL_P,8) * int(KEEP(34),8 )) / int(KEEP(35),8 )) + & ((int(N+KEEP(253),8) * int(KEEP(34),8 )) / int(KEEP(35),8 )) & ) BLR_RELATED = 0_8 DO ITH = 1, NBTHREADS IF (BLR_STRAT.EQ.1) THEN BLR_RELATED = BLR_RELATED + & I8_L0_OMP(10,ITH) + & int(PERLU,8) * ( I8_L0_OMP(10,ITH) / 100_8 + 1_8) ELSE IF (BLR_STRAT.EQ.2) THEN BLR_RELATED = BLR_RELATED + & I8_L0_OMP(13,ITH) + & int(PERLU,8) * ( I8_L0_OMP(13,ITH) / 100_8 + 1_8) ELSE IF (BLR_STRAT.EQ.3) THEN BLR_RELATED = BLR_RELATED + & I8_L0_OMP(8,ITH) + & int(PERLU,8) * ( I8_L0_OMP(8,ITH) / 100_8 + 1_8) ENDIF ENDDO COPY_RELATED = 0_8 ITHMIN = 1 ITHMIN_if_LRLU = 1 MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,1) MIN_NRLADU_underL0 = I8_L0_OMP(1,1) DO ITH = 1, NBTHREADS IF (I8_L0_OMP(1,ITH).LT.MIN_NRLADU_underL0) & THEN MIN_NRLADU_underL0 = I8_L0_OMP(1,ITH) ITHMIN = ITH ENDIF IF (I8_L0_OMP(4,ITH).LT.MIN_NRLADU_if_LR_LU_underL0) & THEN MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,ITH) ITHMIN_if_LRLU = ITH ENDIF ENDDO IF (BLR_STRAT.EQ.0) THEN IF (OOC_STRAT .LE. 0 .AND. OOC_STRAT .NE. -1 ) THEN COPY_RELATED = COPY_RELATED + & I8_L0_OMP(1,ITHMIN) + & I8_L0_OMP(23, ITHMIN) ELSE COPY_RELATED = COPY_RELATED + & I8_L0_OMP(23, ITHMIN) ENDIF ELSE IF (OOC_STRAT .LE. 0 .AND. OOC_STRAT .NE. -1 ) THEN COPY_RELATED = COPY_RELATED + & I8_L0_OMP(4,ITHMIN_if_LRLU) + & I8_L0_OMP(23,ITHMIN_if_LRLU ) ELSE COPY_RELATED = COPY_RELATED + & I8_L0_OMP(23, ITHMIN_if_LRLU) ENDIF ENDIF COPY_RELATED = COPY_RELATED + & int(PERLU,8)*(COPY_RELATED / 100_8 + 1_8 ) TO_ALLOCATE = TO_ALLOCATE + COPY_RELATED + BLR_RELATED MEMDISPO_UNDERL0 = KEEP8(75) - TO_ALLOCATE RETURN END SUBROUTINE ZMUMPS_MA_EFF_MEM_DISPO SUBROUTINE ZMUMPS_L0OMP_COPY_IW( IW, LIW, IWPOS, & MUMPS_TPS_ARR, KEEP, & PTLUST, ICNTL, INFO ) USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T IMPLICIT NONE INTEGER :: KEEP(500) INTEGER, INTENT( IN ) :: LIW INTEGER, INTENT( INOUT ) :: IW(:) INTEGER, INTENT( INOUT ) :: IWPOS INTEGER, INTENT( INOUT ) :: PTLUST(KEEP(28)) INTEGER, INTENT( IN ) :: ICNTL(60) INTEGER, INTENT( INOUT ) :: INFO(80) TYPE (MUMPS_TPS_T), TARGET :: MUMPS_TPS_ARR(:) INTEGER :: ITHREAD, JTHREAD INTEGER :: REQUESTED_SIZE INTEGER :: IWPOS_TO_COPY INTEGER :: LOC_IPOS INTEGER :: LOC_SIZE, LOC_ISTEP TYPE (MUMPS_TPS_T), POINTER :: MUMPS_TPS INCLUDE 'mumps_headers.h' REQUESTED_SIZE = 0 DO ITHREAD = 1, size(MUMPS_TPS_ARR) MUMPS_TPS => MUMPS_TPS_ARR(ITHREAD) REQUESTED_SIZE = REQUESTED_SIZE + MUMPS_TPS%IWPOS - 1 ENDDO IF ( LIW - IWPOS + 1 .LT. REQUESTED_SIZE ) THEN WRITE(*,*) " LIW too small in ZMUMPS_L0OMP_COPY_IW !!", LIW, & REQUESTED_SIZE INFO(1) = -8 INFO(2) = REQUESTED_SIZE-LIW+IWPOS-1 IF ( ICNTL(1) .GT. 0 .AND. ICNTL(4).GE.1) THEN WRITE(ICNTL(1),*) " ** ERROR IN ZMUMPS_L0OMP_COPY_IW: ", & "LIW TOO SMALL TO COPY LOCAL FACTOR INFORMATION", & INFO(2) ENDIF GOTO 500 ENDIF DO ITHREAD = 1, size(MUMPS_TPS_ARR) MUMPS_TPS => MUMPS_TPS_ARR(ITHREAD) IWPOS_TO_COPY = IWPOS DO JTHREAD=1, ITHREAD - 1 IWPOS_TO_COPY = IWPOS_TO_COPY+MUMPS_TPS_ARR(JTHREAD)%IWPOS-1 ENDDO IW(IWPOS_TO_COPY: IWPOS_TO_COPY+MUMPS_TPS%IWPOS - 2) = & MUMPS_TPS%IW(1:MUMPS_TPS%IWPOS-1) LOC_IPOS = 1 DO WHILE ( LOC_IPOS .NE. MUMPS_TPS%IWPOS ) LOC_SIZE = MUMPS_TPS%IW(LOC_IPOS+XXI) LOC_ISTEP = MUMPS_TPS%IW(LOC_IPOS+KEEP(IXSZ)+4) PTLUST(LOC_ISTEP) = IWPOS_TO_COPY+LOC_IPOS-1 LOC_IPOS = LOC_IPOS + LOC_SIZE ENDDO ENDDO IWPOS = IWPOS + REQUESTED_SIZE 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_L0OMP_COPY_IW SUBROUTINE ZMUMPS_PERFORM_COPIES_INIT( STATE, KEEP8_77_SAVE, & NbWaitMem, NbFinished, NbOnGoingCopies, NbUnderL0, & KEEP, KEEP8 ) INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(OUT) :: NbWaitMem, & NbFinished, & NbOnGoingCopies, & NbUnderL0 INTEGER(8), INTENT(OUT) :: STATE(KEEP(400)), KEEP8_77_SAVE INTEGER :: ITH NbWaitMem = 0 NbFinished = 0 NbOnGoingCopies = 0 NbUnderL0 = KEEP(400) DO ITH=1, KEEP(400) STATE(ITH) = UnderL0 ENDDO KEEP8_77_SAVE = KEEP8(77) RETURN END SUBROUTINE ZMUMPS_PERFORM_COPIES_INIT SUBROUTINE ZMUMPS_PERFORM_COPIES( THREAD_ID_P, & MUMPS_TPS_ARR, ZMUMPS_TPS_ARR, & L0_OMP_FACTORS, LL0_OMP_FACTORS, & STATE, SIZE_COPIED, & NbWaitMem, NbFinished, NbOngoingCopies, NbUnderL0, & MYID_NODES, N, SLAVEF, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & KEEP, KEEP8, INFO_P & ) USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T USE ZMUMPS_TPS_M, ONLY : ZMUMPS_TPS_T USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_L0OMPFAC_T USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_FREE_S_WK INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: THREAD_ID_P INTEGER, INTENT(INOUT) :: INFO_P(2) INTEGER, INTENT(IN) :: MYID_NODES, N, SLAVEF INTEGER, INTENT(IN) :: STEP(N), DAD(KEEP(28)) INTEGER(8), INTENT(IN) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT(INOUT) :: NbWaitMem, & NbFinished, & NbOnGoingCopies, & NbUnderL0 INTEGER(8), INTENT(INOUT) :: STATE( KEEP(400) ) INTEGER(8), INTENT(INOUT) :: SIZE_COPIED(KEEP(400) ) TYPE (MUMPS_TPS_T), DIMENSION(:) :: MUMPS_TPS_ARR TYPE (ZMUMPS_TPS_T), DIMENSION(:) :: ZMUMPS_TPS_ARR INTEGER, INTENT ( IN ) :: LL0_OMP_FACTORS TYPE (ZMUMPS_L0OMPFAC_T), INTENT(INOUT) :: & L0_OMP_FACTORS(LL0_OMP_FACTORS) INTEGER :: NbFinishedPrivateCopy INTEGER :: LOCAL_ACTION INTEGER, PARAMETER :: NOTHING = 0 INTEGER, PARAMETER :: FREE_WORK_MYID = 1 INTEGER, PARAMETER :: COPY_FACTORS = 2 INTEGER, PARAMETER :: AllocateViderCB = 3 INTEGER, PARAMETER :: DORMIR = 4 INTEGER(8) :: COPY_START, CHUNK8, I8, TO_ALLOCATE INTEGER :: ITH, K INTEGER :: allocok INTEGER(8) :: PeakAuthorized_P INTEGER(8) :: MemNeeded_P, MemNeededForCB_P, MemDispo_P, & CBCopiedToDynamic_P, LRLUS_SAVE_P INTEGER(8) :: KEEP8_71, KEEP8_73 !$OMP CRITICAL(L0_COPIES) STATE(THREAD_ID_P) = CopyNotStarted IF ( INFO_P(1) .LT. 0 ) THEN NbFinished = NbFinished + 1 STATE(THREAD_ID_P) = Finished ENDIF DO ITH = 1, KEEP(400) IF ( STATE(ITH) .EQ. WaitMem ) THEN STATE(ITH)=CopyNotStarted ENDIF ENDDO NbWaitMem = 0 NbFinishedPrivateCopy = NbFinished !$OMP END CRITICAL(L0_COPIES) DO WHILE ( NbFinishedPrivateCopy .NE. KEEP(400) ) LOCAL_ACTION = DORMIR !$OMP CRITICAL(L0_COPIES) NbFinishedPrivateCopy = NbFinished IF ( NbFinished.EQ. KEEP(400)) THEN LOCAL_ACTION = NOTHING ELSE IF ( (NbFinished+NbWaitMem) .EQ. KEEP(400) ) THEN !$OMP ATOMIC READ KEEP8_73 = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC READ KEEP8_71 = KEEP8(71) !$OMP END ATOMIC MemDispo_P = KEEP8(77) - (KEEP8_73 -KEEP8_71) MemDispo_P = min(MemDispo_P, KEEP8(75)-KEEP8_73) MemNeeded_P = huge(MemNeeded_P) DO ITH = 1, KEEP(400) IF (STATE(ITH).EQ.WaitMem) THEN MemNeeded_P = min( MemNeeded_P, & MUMPS_TPS_ARR(ITH)%LA - & MUMPS_TPS_ARR(ITH)%LRLUS ) ENDIF ENDDO IF ((KEEP8(75)-KEEP8_73).LT.MemNeeded_P) THEN INFO_P(1) = -19 CALL MUMPS_SET_IERROR ( & MemNeeded_P-(KEEP8(75)-KEEP8_73), INFO_P(2)) DO ITH = 1, KEEP(400) STATE(ITH) = Finished ENDDO NbFinished = KEEP(400) ELSE KEEP8(77) = MemNeeded_P + (KEEP8_73 -KEEP8_71) DO ITH = 1, KEEP(400) IF ( STATE(ITH) .EQ. WaitMem ) THEN STATE(ITH)=CopyNotStarted ENDIF ENDDO NbWaitMem = 0 ENDIF LOCAL_ACTION = NOTHING ELSE SELECT CASE (STATE(THREAD_ID_P)) CASE ( CopyFactorsFinished ) LOCAL_ACTION = FREE_WORK_MYID CASE ( CopyNotStarted ) !$OMP ATOMIC READ KEEP8_73 = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC READ KEEP8_71 = KEEP8(71) !$OMP END ATOMIC PeakAuthorized_P = KEEP8(77) MemDispo_P = PeakAuthorized_P - (KEEP8_73 -KEEP8_71) MemDispo_P = min(MemDispo_P, KEEP8(75)-KEEP8_73) MemNeeded_P = MUMPS_TPS_ARR(THREAD_ID_P)%LA - & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS MemNeededForCB_P = MemNeeded_P - & ( MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC - 1_8 ) IF ( MemDispo_P .GE. MemNeeded_P ) THEN !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + MemNeeded_P KEEP8_73 = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC READ KEEP8_71 = KEEP8(71) !$OMP END ATOMIC MemDispo_P = PeakAuthorized_P - (KEEP8_73 -KEEP8_71) MemDispo_P = min(MemDispo_P, KEEP8(75)-KEEP8_73) IF ( MemDispo_P .LT. 0 ) THEN !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - MemNeeded_P !$OMP END ATOMIC IF ( STATE(THREAD_ID_P) .NE. WaitMem ) THEN STATE( THREAD_ID_P ) = WaitMem NbWaitMem = NbWaitMem + 1 ENDIF ELSE !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP8_73 ) !$OMP END ATOMIC IF ( STATE( THREAD_ID_P ) .EQ. WaitMem ) THEN NbWaitMem = NbWaitMem - 1 ENDIF STATE( THREAD_ID_P ) = AllocateViderCBEnCours LOCAL_ACTION = AllocateViderCB NbOngoingCopies = NbOnGoingCopies + 1 ENDIF ELSE IF ( STATE(THREAD_ID_P) .NE. WaitMem ) THEN STATE( THREAD_ID_P ) = WaitMem NbWaitMem = NbWaitMem + 1 ENDIF ENDIF CASE DEFAULT ITH = -1 DO K = THREAD_ID_P, THREAD_ID_P + KEEP(400) - 1 IF ( K > KEEP(400) ) THEN ITH = K - KEEP(400) ELSE ITH = K ENDIF IF ( STATE(ITH) .GE. 0 .AND. & STATE(ITH) .LT. MUMPS_TPS_ARR(ITH)%POSFAC - 1_8 ) THEN EXIT ELSE ITH = -1 ENDIF ENDDO IF ( ITH .GT. 0 ) THEN LOCAL_ACTION = COPY_FACTORS COPY_START = STATE(ITH) + 1 CHUNK8 = max( & & int(KEEP(361),8), & & (MUMPS_TPS_ARR(ITH)%POSFAC+KEEP(400)-2_8) / & (int(KEEP(400)*2,8)) & & ) IF (KEEP(72) .EQ. 1) THEN CHUNK8 = 4_8 ENDIF CHUNK8 = min( CHUNK8, & MUMPS_TPS_ARR(ITH)%POSFAC - 1_8 - COPY_START + 1_8 & ) STATE(ITH) = STATE(ITH) + CHUNK8 ENDIF END SELECT ENDIF !$OMP END CRITICAL(L0_COPIES) SELECT CASE ( LOCAL_ACTION ) CASE ( FREE_WORK_MYID ) IF ( associated(ZMUMPS_TPS_ARR(THREAD_ID_P)%A) ) THEN CALL ZMUMPS_DM_FREE_S_WK( & ZMUMPS_TPS_ARR(THREAD_ID_P)%A, & KEEP(430) ) NULLIFY(ZMUMPS_TPS_ARR(THREAD_ID_P)%A) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( & -MUMPS_TPS_ARR(THREAD_ID_P)%LA, & KEEP(405).EQ.1, & KEEP8, & INFO_P(1), INFO_P(2), & .FALSE., .FALSE. ) IF (INFO_P(1) .GE. 0) THEN !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - L0_OMP_FACTORS(THREAD_ID_P)%LA !$OMP END ATOMIC !$OMP CRITICAL(L0_COPIES) DO ITH = 1, KEEP(400) IF ( STATE(ITH) .EQ. WaitMem ) THEN STATE(ITH)=CopyNotStarted ENDIF ENDDO NbWaitMem = 0 NbFinished = NbFinished + 1 STATE( THREAD_ID_P ) = Finished NbOnGoingCopies = NbOnGoingCopies -1 !$OMP END CRITICAL(L0_COPIES) ENDIF ENDIF CASE ( AllocateViderCB ) TO_ALLOCATE = max(MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8,1_8) ALLOCATE( L0_OMP_FACTORS(THREAD_ID_P)%A(TO_ALLOCATE), & stat=allocok ) IF ( allocok .GT. 0 ) THEN INFO_P(1) = -13 CALL MUMPS_SETI8TOI4(TO_ALLOCATE, INFO_P(2)) L0_OMP_FACTORS(THREAD_ID_P)%LA = 0_8 !$OMP CRITICAL(L0_COPIES) !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - MemNeeded_P !$OMP END ATOMIC STATE(THREAD_ID_P) = Finished NbFinished = NbFinished + 1 !$OMP END CRITICAL(L0_COPIES) ELSE L0_OMP_FACTORS(THREAD_ID_P)%LA = & MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8 !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) + L0_OMP_FACTORS(THREAD_ID_P)%LA !$OMP END ATOMIC !$OMP CRITICAL(L0_COPIES) IF ( MUMPS_TPS_ARR(THREAD_ID_P)%POSFAC-1_8 == 0_8 ) THEN STATE(THREAD_ID_P) = CopyFactorsFinished ELSE STATE ( THREAD_ID_P ) = 0 SIZE_COPIED( THREAD_ID_P ) = 0 ENDIF !$OMP END CRITICAL(L0_COPIES) LRLUS_SAVE_P = MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS CALL ZMUMPS_DM_CBSTATIC2DYNAMIC_I & (3, & 0_8, & .FALSE., & MYID_NODES, N, SLAVEF, KEEP, KEEP8, & MUMPS_TPS_ARR(THREAD_ID_P)%IW(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LIW, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOSCB, & MUMPS_TPS_ARR(THREAD_ID_P)%IWPOS, & ZMUMPS_TPS_ARR(THREAD_ID_P)%A(1), & MUMPS_TPS_ARR(THREAD_ID_P)%LA, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%IPTRLU, & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & INFO_P(1), INFO_P(2) ) CBCopiedToDynamic_P = & MUMPS_TPS_ARR(THREAD_ID_P)%LRLUS - LRLUS_SAVE_P IF (INFO_P(1) .LT. 0 ) THEN !$OMP CRITICAL(L0_COPIES) !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - & ( MemNeededForCB_P - CBCopiedToDynamic_P ) !$OMP END ATOMIC STATE(THREAD_ID_P) = Finished NbFinished = NbFinished+1 !$OMP END CRITICAL(L0_COPIES) ELSE ENDIF ENDIF CASE ( COPY_FACTORS ) DO I8 = COPY_START, COPY_START + CHUNK8 - 1 L0_OMP_FACTORS(ITH)%A(I8) = ZMUMPS_TPS_ARR(ITH)%A(I8) ENDDO !$OMP CRITICAL(L0_COPIES) SIZE_COPIED(ITH) = SIZE_COPIED(ITH) + CHUNK8 IF ( SIZE_COPIED(ITH) .EQ. L0_OMP_FACTORS(ITH)%LA ) THEN STATE(ITH) = CopyFactorsFinished ENDIF !$OMP END CRITICAL(L0_COPIES) CASE ( NOTHING ) CASE ( DORMIR ) CALL MUMPS_USLEEP(1000) CASE DEFAULT WRITE(*,*) " Internal error in ZMUMPS_PERFORM_COPIES", & LOCAL_ACTION END SELECT ENDDO RETURN END SUBROUTINE ZMUMPS_PERFORM_COPIES END MODULE ZMUMPS_FAC_OMP_M RECURSIVE SUBROUTINE ZMUMPS_PROCESS_FRONT_NIV1( COMM_LOAD, & ASS_IRECV, N, INODE, TYPE, TYPEF, LA, IW, LIW, A, & MAXFRW, NOFFNEGW, NULLNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INFO_P, UU, SEUIL, SEUIL_LDLT_NIV2, & OPELIW, NELVAW, NMAXNPIVW, NSTEPSW, PTRIST, PTLUST_S, & PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, NE, POSFAC, & LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP, KEEP8, DKEEP, & PIVNUL_LIST_STRUCT, COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, & SLAVEF, IFATH, COMM_NODES, MYID_NODES, IPOOL_P, & LPOOL_P, LEAF, PERM, NSTK_STEPS, BUFR, LBUFR, & LBUFR_BYTES, NBFIN, root, roota, OPASSW, ITLOC, RHS_MUMPS, FILS, & PTRARW, PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ND, FRERE, DAD, LPTRAR, NELT, & FRTPTR, FRTELT, ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS, & FLOP_ESTIM_ACC ) USE ZMUMPS_FAC_ASM_MASTER_M USE ZMUMPS_FAC_ASM_MASTER_ELT_M USE ZMUMPS_FAC1_LU_M USE ZMUMPS_FAC1_LDLT_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (ZMUMPS_ROOT_STRUC) :: roota INTEGER COMM_LOAD, ASS_IRECV INTEGER COMM_NODES, MYID_NODES, TYPE, TYPEF INTEGER N, LIW, INODE,INFO_P(2) INTEGER ICNTL(60), KEEP(500) DOUBLE PRECISION DKEEP(230) DOUBLE PRECISION UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER(8) KEEP8(150) INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU INTEGER IWPOSCB, IWPOS, & IFATH, SLAVEF, NELVAW, NMAXNPIVW, NSTEPSW INTEGER IW(LIW),PROCNODE_STEPS(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NE(KEEP(28)) COMPLEX(kind=8) A(LA) INTEGER :: MAXFRW, NOFFNEGW, NULLNEGW, NPVW, NBTINYW INTEGER, intent(in) :: LRGROUPS(KEEP(280)) DOUBLE PRECISION OPASSW, OPELIW COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER LEAF, COMP INTEGER :: NB22T1W, DET_EXPW, DET_SIGNW COMPLEX(kind=8) :: DET_MANTW INTEGER PERM( N ) INTEGER NSTK_STEPS( KEEP(28) ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER NBFIN TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT DOUBLE PRECISION FLOP_ESTIM_ACC INTEGER, INTENT(IN) :: LPOOL_P INTEGER, INTENT(IN) :: IPOOL_P(LPOOL_P) INTEGER :: IOLDPS, JOBASS, ETATASS INTEGER(8) :: POSELT LOGICAL :: AVOID_DELAYED, SON_LEVEL2 JOBASS = 0 ETATASS = 0 IF ( KEEP(55) .EQ. 0 ) THEN JOBASS = 0 CALL ZMUMPS_FAC_ASM_NIV1( COMM_LOAD, ASS_IRECV, UU, & N, INODE, & IW, LIW, A, LA, INFO_P, ND, FILS, FRERE, DAD, MAXFRW, & root, roota, OPASSW, OPELIW, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & PTRARW, PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSW, & SON_LEVEL2,COMP, LRLU, IPTRLU, & IWPOS, IWPOSCB, POSFAC, & LRLUS, LRLUSM, ICNTL, KEEP, KEEP8, DKEEP, & INTARR, KEEP8(27), DBLARR, KEEP8(26), & NSTK_STEPS, PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL_P, & LPOOL_P, LEAF, PERM, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & JOBASS, ETATASS & , LRGROUPS & ) ELSE CALL ZMUMPS_FAC_ASM_NIV1_ELT(COMM_LOAD,ASS_IRECV,UU, & NELT,FRTPTR, & FRTELT, N, INODE, IW, LIW, A, & LA, INFO_P, ND, FILS, FRERE, DAD, MAXFRW, & root, roota, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSW, SON_LEVEL2, COMP, LRLU, & IPTRLU, IWPOS, IWPOSCB, & POSFAC, LRLUS, LRLUSM, ICNTL, KEEP, KEEP8, DKEEP, & INTARR, KEEP8(27), DBLARR, KEEP8(26), & NSTK_STEPS, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, NBFIN, & IPOOL_P, LPOOL_P, LEAF, PERM, ISTEP_TO_INIV2, & TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF IF (INFO_P(1) .LT. 0) THEN RETURN ENDIF AVOID_DELAYED = ( ( IFATH .EQ. KEEP(20) & .OR. & IFATH .EQ. KEEP(38) ) & .AND. & ( KEEP(60) .NE. 0 ) ) POSELT = PTRAST(STEP(INODE)) IOLDPS = PTLUST_S(STEP(INODE)) IF ( KEEP(50) .EQ. 0 ) THEN CALL ZMUMPS_FAC1_LU( N, INODE, & IW, LIW, & A, LA, IOLDPS, & POSELT, & INFO_P(1), INFO_P(2), UU, NOFFNEGW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) ELSE IW( IOLDPS + 4 + KEEP(IXSZ) ) = 1 CALL ZMUMPS_FAC1_LDLT( N, INODE, & IW, LIW, A, & LA, & IOLDPS, POSELT, & INFO_P(1), INFO_P(2), UU, NOFFNEGW, NULLNEGW, NPVW, & NB22T1W, NBTINYW, DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, MYID_NODES, SEUIL, & AVOID_DELAYED, & ETATASS, & DKEEP(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IW(IOLDPS + 4 + KEEP(IXSZ)) = STEP(INODE) ENDIF IF (INFO_P(1) .LT. 0) THEN RETURN ENDIF CALL ZMUMPS_FAC_STACK( COMM_LOAD, ASS_IRECV, N, INODE, TYPE, &TYPEF, LA, IW, LIW, A, &INFO_P(1), INFO_P(2), OPELIW, NELVAW, NMAXNPIVW, PTRIST, PTLUST_S, &PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, NE, POSFAC, &LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP, &KEEP8, DKEEP, &COMP,IWPOS, IWPOSCB, PROCNODE_STEPS, &SLAVEF, IFATH, COMM_NODES, MYID_NODES, IPOOL_P, &LPOOL_P, LEAF, NSTK_STEPS, PERM, BUFR, LBUFR, &LBUFR_BYTES, NBFIN, root, roota, OPASSW, ITLOC, RHS_MUMPS, &FILS, DAD, PTRARW, PTRAIW, &PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, &INTARR, DBLARR, ND, FRERE, &LPTRAR, NELT, FRTPTR, FRTELT, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS, & FLOP_ESTIM_ACC &) RETURN END SUBROUTINE ZMUMPS_PROCESS_FRONT_NIV1 MUMPS_5.8.1/src/cfac_process_root2son.F0000664000175000017500000003241115042446440017637 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE & CMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & INODE, NELIM_ROOT, root, roota, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER KEEP(500), ICNTL( 60 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER INODE, NELIM_ROOT INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER INTARR(KEEP8(27)) COMPLEX DBLARR(KEEP8(26)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER LCONT, NCOL_TO_SEND, LDA INTEGER(8) :: SHIFT_VAL_SON, POSELT INTEGER FPERE, IOLDPS, NFRONT, NPIV, NASS, NSLAVES, & H_INODE, NELIM, NBCOL, TYPE_SON, & NROW, NCOL, NBROW, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, LDAFS, IERR, & ISON, PDEST_MASTER_ISON INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG LOGICAL TRANSPOSE_ASM INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE FPERE = KEEP(38) TYPE_SON = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ).EQ.MYID) THEN IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NASS = abs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) H_INODE = 6 + NSLAVES + KEEP(IXSZ) NELIM = NASS - NPIV NBCOL = NFRONT - NPIV IF (NELIM.LE.0) THEN write(6,*) ' ERROR 1 in CMUMPS_PROCESS_ROOT2SON ', NELIM write(6,*) MYID,':Process root2son: INODE=',INODE, & 'Header=',IW(PTLUST_S(STEP(INODE)):PTLUST_S(STEP(INODE)) & +5+KEEP(IXSZ)) CALL MUMPS_ABORT() ENDIF NBROW = NFRONT - NPIV NROW = NELIM IF ( KEEP( 50 ) .eq. 0 ) THEN NCOL = NFRONT - NPIV ELSE NCOL = NELIM END IF SHIFT_LIST_ROW_SON = H_INODE + NPIV SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV IF ( KEEP(50).eq.0 .OR. TYPE_SON .eq. 1 ) THEN LDAFS = NFRONT ELSE LDAFS = NASS END IF SHIFT_VAL_SON = int(NPIV,8) * int(LDAFS,8) + int(NPIV,8) CALL CMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, & ASS_IRECV, & N, INODE, FPERE, & PTLUST_S(1), PTRAST(1), & root, roota, NROW, NCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDAFS, & ROOT_NON_ELIM_CB, MYID, COMM, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S(1), PTRFAC(1), PTRAST(1), & STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE.,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS, NELIM_ROOT, NELIM, NELIM & ) IF (IFLAG.LT.0 ) RETURN IF (TYPE_SON.EQ.1) THEN NROW = NFRONT - NASS NCOL = NELIM SHIFT_LIST_ROW_SON = H_INODE + NASS SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV SHIFT_VAL_SON = int(NASS,8) * int(NFRONT,8) + int(NPIV,8) IF ( KEEP( 50 ) .eq. 0 ) THEN TRANSPOSE_ASM = .FALSE. ELSE TRANSPOSE_ASM = .TRUE. END IF CALL CMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTLUST_S, PTRAST, & root, roota, NROW, NCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, & ROOT_NON_ELIM_CB, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP, & TRANSPOSE_ASM,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS, & NELIM_ROOT, 0, NELIM ) 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 IF (KEEP(50).NE.0) THEN CALL CMUMPS_COMPACT_FACTORS_SYM(A(POSELT), LDA, & NPIV, NBROW, KEEP, & int(LDA,8)*int(NBROW+NPIV,8), IW(IOLDPS+H_INODE+NFRONT)) ELSE CALL CMUMPS_COMPACT_FACTORS_UNSYM( & A(POSELT+int(NPIV,8)*int(LDA,8)), LDA, & NPIV, NBROW, KEEP, & int(LDA,8)*int(NBROW+NPIV,8) ) ENDIF IW(IOLDPS + KEEP(IXSZ)) = NBCOL IW(IOLDPS + 1 +KEEP(IXSZ)) = NASS - NPIV IF (TYPE_SON.EQ.2) THEN IW(IOLDPS + 2 +KEEP(IXSZ)) = NASS ELSE IW(IOLDPS + 2 +KEEP(IXSZ)) = NFRONT ENDIF IW(IOLDPS + 3 +KEEP(IXSZ)) = NPIV CALL CMUMPS_COMPRESS_LU(0_8,MYID,N,IOLDPS,TYPE_SON,IW,LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST,PTRFAC,STEP, KEEP,KEEP8, .FALSE.,INODE,IERR & , LRGROUPS, NASS & ) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 RETURN ENDIF ELSE ISON = INODE PDEST_MASTER_ISON = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(ISON)), KEEP(199) ) IF ( PTRIST(STEP(ISON)) .EQ. 0) THEN CALL CMUMPS_TREAT_DESCBAND( ISON, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE,LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 +KEEP(IXSZ)) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, roota, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN END DO IOLDPS = PTRIST(STEP(INODE)) LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV IF (NELIM.LE.0) THEN write(6,*) MYID,': INODE,LCONT, NROW, NPIV, NASS, NELIM=', & INODE,LCONT, NROW, NPIV, NASS, NELIM write(6,*) MYID,': IOLDPS=',IOLDPS write(6,*) MYID,': ERROR 2 in CMUMPS_PROCESS_ROOT2SON ' CALL MUMPS_ABORT() ENDIF NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) H_INODE = 6 + NSLAVES + KEEP(IXSZ) SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NPIV NCOL_TO_SEND = NELIM LDA = -9999 SHIFT_VAL_SON = -9999_8 IF ( KEEP( 50 ) .eq. 0 ) THEN TRANSPOSE_ASM = .FALSE. ELSE TRANSPOSE_ASM = .TRUE. END IF CALL CMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTRIST, PTRAST, & root, roota, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, & ROOT_NON_ELIM_CB, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,TRANSPOSE_ASM, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS, & NELIM_ROOT, 0, NCOL_TO_SEND ) IF (IFLAG.LT.0 ) RETURN IF (KEEP(214).EQ.2) THEN CALL CMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP, KEEP8, DKEEP,TYPE_SON & ) ENDIF IF (IFLAG.LT.0) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_PROCESS_ROOT2SON MUMPS_5.8.1/src/sfac_mem_dynamic.F0000664000175000017500000005156415042446437016636 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_DYNAMIC_MEMORY_M CONTAINS SUBROUTINE SMUMPS_DM_ALLOC_S_WK(S, MAXS, allocok, & KEEP430, KEEP35 ) IMPLICIT NONE REAL, DIMENSION(:), POINTER :: S INTEGER(8) :: MAXS INTEGER, INTENT(IN) :: KEEP35 INTEGER, INTENT(IN) :: KEEP430 INTEGER, INTENT(OUT) :: allocok INTEGER(8) :: TMP_ADDRESS8 IF (KEEP430.EQ.0) THEN ALLOCATE(S(MAXS), stat=allocok) ELSE IF (KEEP430.EQ.1) THEN CALL MUMPS_MALLOC_C( TMP_ADDRESS8, max(MAXS,1_8) * KEEP35 ) ELSE WRITE(*,*) "KEEP430: wrong value", KEEP430 CALL MUMPS_ABORT() ENDIF IF (TMP_ADDRESS8 .EQ. 0_8) THEN allocok = 1 ELSE allocok = 0 CALL SMUMPS_DM_SET_PTR( TMP_ADDRESS8, max(MAXS,1_8), S ) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_DM_ALLOC_S_WK SUBROUTINE SMUMPS_DM_FREE_S_WK( S, KEEP430 ) IMPLICIT NONE REAL, DIMENSION(:), POINTER :: S INTEGER, INTENT(IN) :: KEEP430 IF ( KEEP430 .EQ. 0 ) THEN DEALLOCATE(S) ELSE IF ( KEEP430 .EQ. 1 ) THEN CALL MUMPS_FREE_C(S(1)) #if defined(USE_XKBLAS) #endif ELSE WRITE(*,*) "KEEP430: wrong value", KEEP430 CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE SMUMPS_DM_FREE_S_WK SUBROUTINE SMUMPS_DM_SET_DYNPTR( CB_STATE, A, LA, & PAMASTER_OR_PTRAST, IXXD, & IXXR, SON_A, IACHK, RECSIZE ) IMPLICIT NONE INTEGER, INTENT(IN) :: CB_STATE INTEGER, INTENT(IN) :: IXXR(2), IXXD(2) INTEGER(8), INTENT(IN) :: LA, PAMASTER_OR_PTRAST REAL, INTENT(IN), TARGET :: A( LA ) #if defined(MUMPS_NOF2003) REAL, POINTER, DIMENSION(:) :: SON_A #else REAL, POINTER, DIMENSION(:), INTENT(OUT) :: SON_A #endif INTEGER(8), INTENT(OUT) :: IACHK, RECSIZE IF ( SMUMPS_DM_IS_DYNAMIC( IXXD ) ) THEN CALL MUMPS_GETI8(RECSIZE, IXXD) CALL SMUMPS_DM_SET_PTR( PAMASTER_OR_PTRAST, RECSIZE, SON_A ) IACHK = 1_8 ELSE CALL MUMPS_GETI8(RECSIZE, IXXR) IACHK = PAMASTER_OR_PTRAST SON_A => A ENDIF RETURN END SUBROUTINE SMUMPS_DM_SET_DYNPTR SUBROUTINE SMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP28, & KEEP199, INODE, CB_STATE, IXXD, & STEP, DAD, PROCNODE_STEPS, & RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IMPLICIT NONE INTEGER, INTENT(in) :: KEEP28, N, SLAVEF, MYID, INODE, CB_STATE INTEGER, INTENT(in) :: KEEP199 INTEGER, INTENT(in) :: IXXD(2) INTEGER, INTENT(in) :: DAD(KEEP28) INTEGER, INTENT(in) :: STEP(N) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP28) LOGICAL, INTENT(out) :: IS_PAMASTER, IS_PTRAST INTEGER(8), INTENT(in) :: PAMASTER(KEEP28), PTRAST(KEEP28) INTEGER(8), INTENT(in) :: RCURRENT LOGICAL :: DAD_TYPE2_NOT_ON_MYID INTEGER :: NODETYPE, DADTYPE INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE IS_PAMASTER = .FALSE. IS_PTRAST = .FALSE. IF (CB_STATE .EQ. S_FREE) THEN RETURN ENDIF NODETYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), KEEP199) DADTYPE=-99999 DAD_TYPE2_NOT_ON_MYID = .FALSE. IF (DAD(STEP(INODE)) .NE. 0) THEN DADTYPE= MUMPS_TYPENODE( & PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP199) IF (DADTYPE .EQ. 2 .AND. & MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP199).NE.MYID & ) THEN DAD_TYPE2_NOT_ON_MYID = .TRUE. ENDIF ENDIF IF (SMUMPS_DM_ISBAND(CB_STATE)) THEN IS_PTRAST=.TRUE. ELSE IF (NODETYPE.EQ.1 & .AND. MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP199).EQ.MYID & .AND. DAD_TYPE2_NOT_ON_MYID) & THEN IS_PTRAST=.TRUE. ELSE IS_PAMASTER=.TRUE. ENDIF RETURN END SUBROUTINE SMUMPS_DM_PAMASTERORPTRAST LOGICAL FUNCTION SMUMPS_DM_ISBAND(XXSTATE) INTEGER, INTENT(IN) :: XXSTATE INCLUDE 'mumps_headers.h' SELECT CASE (XXSTATE) CASE(S_NOTFREE, S_CB1COMP); SMUMPS_DM_ISBAND = .FALSE. CASE(S_ACTIVE, S_ALL, & S_NOLCBCONTIG, S_NOLCBNOCONTIG, S_NOLCLEANED, & S_NOLCBNOCONTIG38, S_NOLCBCONTIG38, S_NOLCLEANED38, & S_NOLNOCB, S_NOLNOCBCLEANED); SMUMPS_DM_ISBAND = .TRUE. CASE(S_FREE); SMUMPS_DM_ISBAND = .FALSE. CASE DEFAULT; WRITE(*,*) "Wrong state during SMUMPS_DM_ISBAND", XXSTATE CALL MUMPS_ABORT() END SELECT RETURN END FUNCTION SMUMPS_DM_ISBAND LOGICAL FUNCTION SMUMPS_DM_IS_DYNAMIC(IXXD) INTEGER :: IXXD(2) INTEGER(8) :: DYN_SIZE CALL MUMPS_GETI8( DYN_SIZE, IXXD ) SMUMPS_DM_IS_DYNAMIC = DYN_SIZE > 0_8 RETURN END FUNCTION SMUMPS_DM_IS_DYNAMIC SUBROUTINE SMUMPS_DM_FAC_ALLOC_ALLOWED & (MEM_COUNT_TO_ALLOCATE, KEEP8, & IFLAG, IERROR) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_COUNT_TO_ALLOCATE INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR IF ( KEEP8(73) + MEM_COUNT_TO_ALLOCATE & .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & KEEP8(73) + MEM_COUNT_TO_ALLOCATE -KEEP8(75), & IERROR ) ENDIF RETURN END SUBROUTINE SMUMPS_DM_FAC_ALLOC_ALLOWED SUBROUTINE SMUMPS_DM_CBSTATIC2DYNAMIC( STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) !$ USE OMP_LIB USE MUMPS_LOAD, ONLY : MUMPS_LOAD_MEM_UPDATE IMPLICIT NONE INTEGER, INTENT(in) :: STRATEGY INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS REAL, INTENT(in) :: A( LA ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER, INTENT(inout) :: IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER :: ICURRENT, INODE, TYPEINODE, CB_STATE INTEGER(8) :: RCURRENT, RCURRENT_SIZE, SIZEHOLE INTEGER(8) :: KEEP8TMPCOPY LOGICAL :: MOVE2DYNAMIC LOGICAL :: SSARBRDAD INTEGER(8) :: TMP_ADDRESS, ITMP8 INTEGER(8) :: I8 REAL, DIMENSION(:), POINTER :: DYNAMIC_CB LOGICAL :: IS_PAMASTER, IS_PTRAST INTEGER :: allocok !$ INTEGER(8) :: CHUNK8 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP LOGICAL :: IFLAG_M13_OCCURED, IFLAG_M19_OCCURED INTEGER(8) :: MIN_SIZE_M13, MIN_SIZE_M19 INTEGER, EXTERNAL :: MUMPS_TYPENODE IF ( STRATEGY .EQ. 0 ) THEN IF (LRLUS.LT.SIZER_NEEDED) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) ENDIF RETURN ENDIF IFLAG_M13_OCCURED = .FALSE. MIN_SIZE_M13 = huge(MIN_SIZE_M13) IFLAG_M19_OCCURED = .FALSE. MIN_SIZE_M19 = huge(MIN_SIZE_M19) !$ NOMP = OMP_GET_MAX_THREADS() ICURRENT = IWPOSCB + 1 RCURRENT = IPTRLU + 1 IF (STRATEGY.EQ.1 .AND. SIZER_NEEDED.LE.LRLUS) GOTO 500 IF (( KEEP8(73) + SIZER_NEEDED-LRLUS).GT. & KEEP8(75)) THEN IFLAG = -19 CALL MUMPS_SET_IERROR & (KEEP8(73) + SIZER_NEEDED-LRLUS-KEEP8(75), IERROR) GOTO 500 ENDIF DO WHILE (ICURRENT .NE. LIW-KEEP(IXSZ)+1) INODE = IW(ICURRENT+XXN) CB_STATE = IW(ICURRENT+XXS) CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT+XXR)) CALL SMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP(28), & KEEP(199), INODE, CB_STATE, & IW(ICURRENT+XXD:ICURRENT+XXD+1), & STEP, DAD, PROCNODE_STEPS, & RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF ( CB_STATE .NE. S_FREE .AND. & .NOT. SMUMPS_DM_IS_DYNAMIC(IW(ICURRENT+XXD)) ) THEN TYPEINODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IF (STRATEGY .EQ. -1) THEN MOVE2DYNAMIC = .FALSE. MOVE2DYNAMIC = MOVE2DYNAMIC .OR. & CB_STATE .EQ. S_NOLCBCONTIG .OR. & CB_STATE .EQ. S_NOLCBNOCONTIG .OR. & CB_STATE .EQ. S_NOLCLEANED .OR. & CB_STATE .EQ. S_ALL .OR. & CB_STATE .EQ. S_ACTIVE ELSE IF (STRATEGY .EQ. 2 .OR. STRATEGY .EQ. 3) THEN MOVE2DYNAMIC = .TRUE. MOVE2DYNAMIC = MOVE2DYNAMIC .AND. (TYPEINODE.NE.3) ELSE IF (STRATEGY .EQ. 1) THEN MOVE2DYNAMIC = .FALSE. IF (LRLUS.GT.SIZER_NEEDED) GOTO 500 IF (TYPEINODE.EQ.3) GOTO 100 MOVE2DYNAMIC = MOVE2DYNAMIC.OR..TRUE. ELSE WRITE(*,*) "Internal error in SMUMPS_DM_CBSTATIC2DYNAMIC", & MOVE2DYNAMIC CALL MUMPS_ABORT() ENDIF MOVE2DYNAMIC = MOVE2DYNAMIC .AND. (RCURRENT_SIZE .NE. 0_8) MOVE2DYNAMIC = MOVE2DYNAMIC .AND. & .NOT. ((ICURRENT.EQ.IWPOSCB + 1).AND.(SKIP_TOP_STACK)) IF (STRATEGY .NE. 3) THEN IF ( KEEP(405) .EQ. 1 ) THEN !$OMP ATOMIC READ KEEP8TMPCOPY = KEEP8(73) !$OMP END ATOMIC ELSE KEEP8TMPCOPY = KEEP8(73) ENDIF IF ( RCURRENT_SIZE + KEEP8TMPCOPY .GT. KEEP8(75) ) THEN IFLAG_M19_OCCURED= .TRUE. MIN_SIZE_M19 = min( MIN_SIZE_M19, & RCURRENT_SIZE+KEEP8(73)-KEEP8(75) ) MOVE2DYNAMIC = .FALSE. ENDIF ENDIF IF ( MOVE2DYNAMIC ) THEN #if defined(MUMPS_ALLOC_FROM_C) || defined(_CRAYFTN) CALL MUMPS_MALLOC_C( TMP_ADDRESS, & RCURRENT_SIZE * KEEP(35) ) IF (TMP_ADDRESS .EQ. 0_8) THEN allocok=1 ELSE allocok=0 ENDIF #else ALLOCATE(DYNAMIC_CB(RCURRENT_SIZE), stat=allocok) #endif IF (allocok .GT. 0) THEN IF ( (STRATEGY .NE. 1).OR. & (SIZER_NEEDED-LRLUS).GE.RCURRENT_SIZE) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) GOTO 500 ENDIF IFLAG_M13_OCCURED = .TRUE. MIN_SIZE_M13 = min(MIN_SIZE_M13, RCURRENT_SIZE) GOTO 100 ENDIF SIZEHOLE=0_8 IF (KEEP(216).NE.3) THEN CALL SMUMPS_SIZEFREEINREC( IW(ICURRENT), & LIW-ICURRENT+1, SIZEHOLE, KEEP(IXSZ)) ENDIF CALL MUMPS_STOREI8(RCURRENT_SIZE,IW(ICURRENT+XXD)) #if defined(MUMPS_ALLOC_FROM_C) || defined(_CRAYFTN) CALL SMUMPS_DM_SET_PTR( TMP_ADDRESS, RCURRENT_SIZE, & DYNAMIC_CB ) #else CALL MUMPS_ADDR_C(DYNAMIC_CB(1), TMP_ADDRESS) #endif IF (IS_PTRAST) THEN PTRAST(STEP(INODE)) = TMP_ADDRESS ELSE IF (IS_PAMASTER) THEN PAMASTER(STEP(INODE)) = TMP_ADDRESS ELSE WRITE(*,*) & "Internal error 3 in SMUMPS_DM_CBSTATIC2DYNAMIC", & RCURRENT, PTRAST(STEP(INODE)), PAMASTER(STEP(INODE)) CALL MUMPS_ABORT() ENDIF ITMP8 = (RCURRENT_SIZE-SIZEHOLE) LRLUS = LRLUS + ITMP8 IF (KEEP(405).EQ.1) THEN IF (SIZEHOLE .NE. 0_8) THEN !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + SIZEHOLE KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max( KEEP8(68), KEEP8TMPCOPY ) !$OMP END ATOMIC ENDIF ELSE KEEP8(69) = KEEP8(69) + SIZEHOLE KEEP8(68) = max( KEEP8(68), KEEP8(69) ) ENDIF CALL MUMPS_SET_SSARBR_DAD(SSARBRDAD, INODE, & DAD, N, KEEP(28), & STEP, PROCNODE_STEPS, KEEP(199)) CALL MUMPS_LOAD_MEM_UPDATE( SSARBRDAD, .FALSE., & LA - LRLUS, 0_8, -(RCURRENT_SIZE-SIZEHOLE), & KEEP, KEEP8, LRLUS) IF (ICURRENT .EQ. IWPOSCB+1) THEN IPTRLU = IPTRLU + RCURRENT_SIZE LRLU = LRLU + RCURRENT_SIZE CALL MUMPS_STOREI8(0_8, IW(ICURRENT+XXR)) ENDIF IF (STRATEGY .NE. 3) THEN CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS ( & RCURRENT_SIZE, KEEP(405).EQ.1, KEEP8, & IFLAG, IERROR, .FALSE., .FALSE.) IF (IFLAG.LT.0) GOTO 500 ENDIF !$ CHUNK8 = max( int(KEEP(361),8), !$ & (RCURRENT_SIZE+NOMP-1) / NOMP) !$ OMP_FLAG = ( (RCURRENT_SIZE > int(KEEP(361),8)) !$ & .AND.(NOMP.GT.1) !$ & ) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (OMP_FLAG) DO I8=1_8, RCURRENT_SIZE DYNAMIC_CB(I8) = A(RCURRENT+I8-1_8) ENDDO !$OMP END PARALLEL DO ENDIF ENDIF 100 CONTINUE RCURRENT = RCURRENT + RCURRENT_SIZE ICURRENT = ICURRENT + IW(ICURRENT+XXI) END DO IF (LRLUS.LT.SIZER_NEEDED) THEN IF (IFLAG_M19_OCCURED) THEN IFLAG = -19 CALL MUMPS_SET_IERROR(MIN_SIZE_M19, IERROR) ELSE IF (IFLAG_M13_OCCURED) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(MIN_SIZE_M13, IERROR) ELSE IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_DM_CBSTATIC2DYNAMIC SUBROUTINE SMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(in) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) LOGICAL, INTENT(in) :: ATOMIC_UPDATES INCLUDE 'mumps_headers.h' INTEGER :: ICURRENT, INODE INTEGER :: CB_STATE INTEGER(8) :: DYN_SIZE, TMP_ADDRESS INTEGER(8), PARAMETER :: RDUMMY = -987654 LOGICAL :: IS_PAMASTER, IS_PTRAST REAL, DIMENSION(:), POINTER :: TMP_PTR ICURRENT = IWPOSCB + 1 IF (KEEP8(73) .NE. 0_8) THEN DO WHILE (ICURRENT .LT. LIW-KEEP(IXSZ)+1) INODE = IW(ICURRENT+XXN) CB_STATE = IW(ICURRENT+XXS) IF (CB_STATE.NE.S_FREE) THEN CALL MUMPS_GETI8( DYN_SIZE, IW(ICURRENT+XXD) ) IF (DYN_SIZE .GT. 0_8) THEN CALL SMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP(28), & KEEP(199), INODE, CB_STATE, IW(ICURRENT+XXD), & STEP, DAD, PROCNODE_STEPS, & RDUMMY, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF (IS_PAMASTER) THEN TMP_ADDRESS = PAMASTER(STEP(INODE)) ELSE IF (IS_PTRAST) THEN TMP_ADDRESS = PTRAST(STEP(INODE)) ELSE WRITE(*,*) "Internal error 1 in SMUMPS_DM_FREEALLDYNAMICCB" & , IS_PTRAST, IS_PAMASTER ENDIF CALL SMUMPS_DM_SET_PTR(TMP_ADDRESS, DYN_SIZE, TMP_PTR) CALL SMUMPS_DM_FREE_BLOCK( IW(ICURRENT+XXG), & TMP_PTR, DYN_SIZE, & ATOMIC_UPDATES, KEEP8 ) CALL MUMPS_STOREI8(0_8, IW(ICURRENT+XXD)) ENDIF ENDIF ICURRENT = ICURRENT + IW(ICURRENT+XXI) ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_DM_FREEALLDYNAMICCB SUBROUTINE SMUMPS_DM_SET_PTR(ADDRESS, SIZFR8, CBPTR) USE SMUMPS_STATIC_PTR_M, ONLY : SMUMPS_GET_TMP_PTR IMPLICIT NONE INTEGER(8), INTENT(IN) :: ADDRESS, SIZFR8 #if defined(MUMPS_NOF2003) REAL, DIMENSION(:), POINTER :: CBPTR #else REAL, DIMENSION(:), POINTER, INTENT(out) :: CBPTR #endif !$OMP CRITICAL(STATIC_PTR_ACCESS) CALL SMUMPS_SET_TMP_PTR_C( ADDRESS, SIZFR8 ) CALL SMUMPS_GET_TMP_PTR( CBPTR ) !$OMP END CRITICAL(STATIC_PTR_ACCESS) RETURN END SUBROUTINE SMUMPS_DM_SET_PTR SUBROUTINE SMUMPS_DM_FREE_BLOCK( XXG_STATUS, DYNPTR, SIZFR8, & ATOMIC_UPDATES, KEEP8 ) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER :: XXG_STATUS REAL, POINTER, DIMENSION(:) :: DYNPTR INTEGER(8) :: SIZFR8 LOGICAL, INTENT(IN) :: ATOMIC_UPDATES INTEGER(8) :: KEEP8(150) INTEGER IDUMMY #if defined(MUMPS_ALLOC_FROM_C) || defined(_CRAYFTN) CALL MUMPS_FREE_C(DYNPTR(1)) #else DEALLOCATE(DYNPTR) #endif NULLIFY(DYNPTR) CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS ( & -SIZFR8, ATOMIC_UPDATES, KEEP8, IDUMMY, IDUMMY, & .TRUE., .FALSE.) RETURN END SUBROUTINE SMUMPS_DM_FREE_BLOCK END MODULE SMUMPS_DYNAMIC_MEMORY_M SUBROUTINE SMUMPS_DM_FREEALLDYNAMICCB_I( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_FREEALLDYNAMICCB IMPLICIT NONE INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(in) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) LOGICAL, INTENT(in) :: ATOMIC_UPDATES CALL SMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) RETURN END SUBROUTINE SMUMPS_DM_FREEALLDYNAMICCB_I SUBROUTINE SMUMPS_DM_CBSTATIC2DYNAMIC_I( & STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_CBSTATIC2DYNAMIC IMPLICIT NONE INTEGER, INTENT(in) :: STRATEGY INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS REAL, INTENT(in) :: A( LA ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER, INTENT(inout) :: IFLAG, IERROR CALL SMUMPS_DM_CBSTATIC2DYNAMIC( STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) RETURN END SUBROUTINE SMUMPS_DM_CBSTATIC2DYNAMIC_I MUMPS_5.8.1/src/cfac_scalings_simScale_util.F0000664000175000017500000013232315042446441021000 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, OSZ, & IWRK, IWSZ, INUMMY, NOMP_MAX ) !$ USE OMP_LIB C IMPLICIT NONE EXTERNAL CMUMPS_BUREDUCE INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM, NOMP_MAX INTEGER(8), INTENT(IN) :: NZ_loc INTEGER(8), INTENT(IN) :: IWSZ INTEGER, INTENT(IN) :: ISZ, OSZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C OUTPUT C IPARTVEC(I) = proc number with largest number of entries C in row/col I C INUMMY = number of local rows/columns with C at least one local entry (NUMPROCS .NE. 1 only) INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) INTEGER, INTENT(OUT) :: INUMMY C C INTERNAL WORKING ARRAY C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries C on my proc and in row/col I) for I=1,ISZ C (2*ISZ+1: 4*ISZ) is then set to C the processor with largest number of entries in its row/col C and its value (that is copied back into IPARTVEC(I) #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) #else INTEGER, INTENT(OUT) :: IWRK(IWSZ) #endif INCLUDE 'mpif.h' C C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER OP, IERROR INTEGER IR, IC !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK C !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = omp_get_max_threads() !$ CHUNK= max(K361/2, (ISZ+NOMP-1) / NOMP ) !$ ENDIF C INUMMY = 0 IF(NUMPROCS.NE.1) THEN C CHECK done outsize C IF(IWSZ < 4*ISZ) THEN C CHECK ENDS CALL MPI_OP_CREATE(CMUMPS_BUREDUCE, .TRUE., OP, IERROR) C PERFORM THE REDUCTION C WE FIRST ZERO OUT IF (NOMP_MAX.LE.0) THEN DO I=1,ISZ IWRK(2_8*int(I,8)-1_8) = 0 IWRK(2_8*int(I,8)) = MYID ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND.ISZ > K361 ) DO I=1,ISZ IWRK(2_8*int(I,8)-1_8) = 0 IWRK(2_8*int(I,8)) = MYID ENDDO !$OMP END PARALLEL DO ENDIF DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.ISZ).AND. & (IC.GE.1).AND.(IC.LE.OSZ)) THEN IWRK(2_8*int(IR,8)-1_8) = IWRK(2_8*int(IR,8)-1_8) + 1 ENDIF ENDDO CALL MUMPS_BIGALLREDUCE(.FALSE., IWRK(1), & IWRK(1_8+2_8*int(ISZ,8)), ISZ, & MPI_2INTEGER, OP, COMM, IERROR) C IF (NOMP_MAX.LE.0) THEN DO I=1,ISZ IPARTVEC(I) = IWRK(2_8*int(I,8)+2_8*int(ISZ,8)) C Compute INUMMY directly IF ( IPARTVEC(I) .EQ. MYID. OR. & IWRK(2_8*int(I,8)-1_8) .GT. 0 ) THEN INUMMY=INUMMY+1 ENDIF ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) !$OMP& REDUCTION(+:INUMMY) DO I=1,ISZ IPARTVEC(I) = IWRK(2_8*int(I,8)+2_8*int(ISZ,8)) C Compute INUMMY directly IF ( IPARTVEC(I) .EQ. MYID. OR. & IWRK(2_8*int(I,8)-1_8) .GT. 0 ) THEN INUMMY=INUMMY+1 ENDIF ENDDO !$OMP END PARALLEL DO ENDIF C FREE THE OPERATOR CALL MPI_OP_FREE(OP, IERROR) ELSE IF (NOMP_MAX.LE.0) THEN DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) DO I=1,ISZ IPARTVEC(I) = 0 ENDDO !$OMP END PARALLEL DO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_CREATEPARTVEC C C SEPARATOR: Another function begins C C SUBROUTINE CMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & MYROWINDICES, INUMMYR, & MYCOLINDICES, INUMMYC, & IWRK, IWSZ, NOMP_MAX ) !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: NZ_loc, IWSZ INTEGER MYID, NUMPROCS, M, N, NOMP_MAX INTEGER INUMMYR, INUMMYC INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER ROWPARTVEC(M) INTEGER COLPARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER MYCOLINDICES(INUMMYC) INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC, ITMP INTEGER(8) :: I8 C INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP=omp_get_max_threads() C note that M=N !$ CHUNK= max(K361/2, (M+NOMP-1) / NOMP ) !$ ENDIF C C MARK MY ROWS. IF (NOMP_MAX.LE.0) THEN DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( M > K361 .AND. NOMP .GT. 1) DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO !$OMP END PARALLEL DO ENDIF CTEMP !$OMP PARALLEL DO PRIVATE(I8,IR,IC) SCHEDULE(STATIC,CHUNK) CTEMP !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) DO I8=1,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 ENDIF ENDDO CTEMP !$OMP END PARALLEL DO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,M IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C C C DO THE SMAME THING FOR COLS IF (NOMP_MAX.LE.0) THEN DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 ENDDO !$OMP END PARALLEL DO ENDIF C CTEMP !$OMP PARALLEL DO PRIVATE(I8,IR,IC) SCHEDULE(STATIC,CHUNK) CTEMP !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) DO I8=1,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IC) .EQ. 0) IWRK(IC)= 1 ENDIF ENDDO CTEMP !$OMP END PARALLEL DO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYCOLINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C RETURN END SUBROUTINE CMUMPS_FILLMYROWCOLINDICES C C SEPARATOR: Another function begins C C INTEGER FUNCTION CMUMPS_CHK1LOC(D, DSZ, INDX, INDXSZ, EPS) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) INTEGER INDX(INDXSZ) REAL EPS C LOCAL VARS INTEGER I, IID REAL RONE PARAMETER(RONE=1.0E0) CMUMPS_CHK1LOC = 1 DO I=1, INDXSZ IID = INDX(I) IF (.NOT.( (D(IID).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(IID)) )) THEN CMUMPS_CHK1LOC = 0 ENDIF ENDDO RETURN END FUNCTION CMUMPS_CHK1LOC INTEGER FUNCTION CMUMPS_CHK1CONV(D, DSZ, EPS) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL EPS C LOCAL VARS INTEGER I REAL RONE PARAMETER(RONE=1.0E0) CMUMPS_CHK1CONV = 1 DO I=1, DSZ IF (.NOT.( (D(I).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(I)) )) THEN CMUMPS_CHK1CONV = 0 ENDIF ENDDO RETURN END FUNCTION CMUMPS_CHK1CONV C C SEPARATOR: Another function begins C INTEGER FUNCTION CMUMPS_CHKCONVGLO(DR, M, INDXR, INDXRSZ, & DC, N, INDXC, INDXCSZ, EPS, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER M, N, INDXRSZ, INDXCSZ REAL DR(M), DC(N) INTEGER INDXR(INDXRSZ), INDXC(INDXCSZ) REAL EPS INTEGER COMM EXTERNAL CMUMPS_CHK1LOC INTEGER CMUMPS_CHK1LOC INTEGER GLORES, MYRESR, MYRESC, MYRES INTEGER IERR MYRESR = CMUMPS_CHK1LOC(DR, M, INDXR, INDXRSZ, EPS) MYRESC = CMUMPS_CHK1LOC(DC, N, INDXC, INDXCSZ, EPS) MYRES = MYRESR + MYRESC CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) CMUMPS_CHKCONVGLO = GLORES RETURN END FUNCTION CMUMPS_CHKCONVGLO C C SEPARATOR: Another function begins C REAL FUNCTION CMUMPS_ERRSCALOC(D, TMPD, DSZ, & INDX, INDXSZ, NOMP_MAX) !$ USE OMP_LIB C THE VAR D IS NOT USED IN COMPUTATIONS. C IT IS THERE FOR READIBLITY OF THE *simScaleAbs.F IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, INDXSZ, NOMP_MAX REAL D(DSZ) REAL TMPD(DSZ) INTEGER INDX(INDXSZ) C LOCAL VARS REAL RONE PARAMETER(RONE=1.0E0) INTEGER I, IIND REAL ERRMAX INTRINSIC abs !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK ERRMAX = -RONE !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,INDXSZ IIND = INDX(I) IF(abs(RONE-TMPD(IIND)).GT.ERRMAX) THEN ERRMAX = abs(RONE-TMPD(IIND)) ENDIF ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I,IIND) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1 .AND. INDXSZ > K361 ) !$OMP& REDUCTION(max:ERRMAX) DO I=1,INDXSZ IIND = INDX(I) IF(abs(RONE-TMPD(IIND)).GT.ERRMAX) THEN ERRMAX = abs(RONE-TMPD(IIND)) ENDIF ENDDO !$OMP END PARALLEL DO ENDIF CMUMPS_ERRSCALOC = ERRMAX RETURN END FUNCTION CMUMPS_ERRSCALOC REAL FUNCTION CMUMPS_ERRSCA1(D, TMPD, DSZ, NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, NOMP_MAX REAL D(DSZ) REAL TMPD(DSZ) C LOCAL VARS REAL RONE PARAMETER(RONE=1.0E0) INTEGER I REAL ERRMAX1 INTRINSIC abs !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK ERRMAX1 = -RONE !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (DSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,DSZ IF(abs(RONE-TMPD(I)).GT.ERRMAX1) THEN ERRMAX1 = abs(RONE-TMPD(I)) ENDIF ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND.DSZ > K361 ) !$OMP& REDUCTION(max:ERRMAX1) DO I=1,DSZ IF(abs(RONE-TMPD(I)).GT.ERRMAX1) THEN ERRMAX1 = abs(RONE-TMPD(I)) ENDIF ENDDO !$OMP END PARALLEL DO ENDIF CMUMPS_ERRSCA1 = ERRMAX1 RETURN END FUNCTION CMUMPS_ERRSCA1 C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_UPDATESCALE(D, TMPD, DSZ, & INDX, INDXSZ, NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(in) :: DSZ, INDXSZ, NOMP_MAX REAL D(DSZ) REAL TMPD(DSZ) INTEGER INDX(INDXSZ) INTRINSIC sqrt C LOCAL VARS INTEGER I, IIND REAL RZERO PARAMETER(RZERO=0.0E0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,INDXSZ IIND = INDX(I) IF (TMPD(IIND).NE.RZERO) D(IIND)=D(IIND)/sqrt(TMPD(IIND)) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I,IIND) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. INDXSZ> K361 ) DO I=1,INDXSZ IIND = INDX(I) IF (TMPD(IIND).NE.RZERO) D(IIND)=D(IIND)/sqrt(TMPD(IIND)) ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE CMUMPS_UPDATESCALE C SUBROUTINE CMUMPS_UPSCALE1(D, TMPD, DSZ, NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, NOMP_MAX REAL D(DSZ) REAL TMPD(DSZ) INTRINSIC sqrt C LOCAL VARS INTEGER I REAL RZERO PARAMETER(RZERO=0.0E0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (DSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,DSZ IF (TMPD(I) .NE. RZERO) D(I) = D(I)/sqrt(TMPD(I)) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. DSZ> K361 ) DO I=1,DSZ IF (TMPD(I) .NE. RZERO) D(I) = D(I)/sqrt(TMPD(I)) ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE CMUMPS_UPSCALE1 C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_INITREALLST(D, DSZ, INDX, INDXSZ, VAL, & NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, INDXSZ, NOMP_MAX REAL D(DSZ) INTEGER INDX(INDXSZ) REAL VAL C LOCAL VARS INTEGER I, IIND !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,INDXSZ IIND = INDX(I) D(IIND) = VAL ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I,IIND) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. INDXSZ > K361 ) DO I=1,INDXSZ IIND = INDX(I) D(IIND) = VAL ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE CMUMPS_INITREALLST C C SEPARATOR: Another function begins C C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_INITREAL(D, DSZ, VAL, NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: DSZ, NOMP_MAX REAL D(DSZ) REAL VAL C LOCAL VARS INTEGER I !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = omp_get_max_threads() !$ CHUNK= max(K361/2, (DSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,DSZ D(I) = VAL ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND.DSZ > K361 ) DO I=1,DSZ D(I) = VAL ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE CMUMPS_INITREAL C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_REDUCE_WRK(WRK, N, WRK_TH, NOMP_MAX) C Called only when NOMP_MAX>0 !$ USE OMP_LIB IMPLICIT NONE INTEGER N,NOMP_MAX REAL WRK(N), WRK_TH(N,NOMP_MAX) C LOCAL VAR INTEGER I, IOMP REAL DZERO PARAMETER(DZERO=0.0E0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (N+NOMP-1) / NOMP ) !$OMP PARALLEL DO PRIVATE(I,IOMP) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. N > K361 ) DO I=1,N WRK(I) = DZERO DO IOMP=1,NOMP_MAX WRK(I) = WRK_TH(I,IOMP) + WRK(I) ENDDO ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE CMUMPS_REDUCE_WRK SUBROUTINE CMUMPS_REDUCE_WRK_MPI(WRK, N, WRK_TH, NOMP_MAX, & INDX, INDXSZ) C Called only when NOMP_MAX>0 !$ USE OMP_LIB IMPLICIT NONE INTEGER N,NOMP_MAX,INDXSZ REAL WRK(N), WRK_TH(N,NOMP_MAX) INTEGER INDX(INDXSZ) C LOCAL VAR INTEGER I, J, IOMP REAL DZERO PARAMETER(DZERO=0.0E0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$OMP PARALLEL DO PRIVATE(I,J,IOMP) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. INDXSZ > K361 ) DO I=1,INDXSZ J = INDX(I) WRK(J) = DZERO DO IOMP=1,NOMP_MAX WRK(J) = WRK_TH(J,IOMP) + WRK(J) ENDDO ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE CMUMPS_REDUCE_WRK_MPI SUBROUTINE CMUMPS_ZEROOUT(TMPD, TMPSZ, INDX, INDXSZ, & NOMP_MAX) !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN):: TMPSZ,INDXSZ, NOMP_MAX REAL TMPD(TMPSZ) INTEGER INDX(INDXSZ) C LOCAL VAR INTEGER I REAL DZERO PARAMETER(DZERO=0.0E0) !$ INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK= max(K361/2, (INDXSZ+NOMP-1) / NOMP ) !$ ENDIF IF (NOMP_MAX.LE.0) THEN DO I=1,INDXSZ TMPD(INDX(I)) = DZERO ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC, CHUNK) !$OMP& IF ( NOMP.GT.1.AND. INDXSZ > K361 ) DO I=1,INDXSZ TMPD(INDX(I)) = DZERO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE CMUMPS_ZEROOUT C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_BUREDUCE(INV, INOUTV, LEN, DTYPE) C C Like MPI_MINLOC operation (with ties broken sometimes with min C and sometimes with max) C The objective is find for each entry row/col C the processor with largest number of entries in its row/col C When 2 procs have the same number of entries in the row/col C then C if this number of entries is odd we take the proc with largest id C if this number of entries is even we take the proc with smallest id C IMPLICIT NONE #if defined(WORKAROUNDINTELILP64MPI2INTEGER) || defined(WORKAROUNDILP64MPICUSTOMREDUCE) INTEGER(4) :: LEN INTEGER(4) :: INV(2*LEN) INTEGER(4) :: INOUTV(2*LEN) INTEGER(4) :: DTYPE #else INTEGER :: LEN INTEGER :: INV(2*LEN) INTEGER :: INOUTV(2*LEN) INTEGER :: DTYPE #endif INTEGER I #if defined(WORKAROUNDINTELILP64MPI2INTEGER) || defined(WORKAROUNDILP64MPICUSTOMREDUCE) INTEGER(4) DIN, DINOUT, PIN, PINOUT #else INTEGER DIN, DINOUT, PIN, PINOUT #endif DO I=1,2*LEN-1,2 DIN = INV(I) ! nb of entries in row/col PIN = INV(I+1) ! proc number C DINOUT DINOUT = INOUTV(I) PINOUT = INOUTV(I+1) IF (DINOUT < DIN) THEN INOUTV(I) = DIN INOUTV(I+1) = PIN ELSE IF (DINOUT == DIN) THEN C --INOUTV(I) = DIN C --even number I take smallest Process number (pin) IF ((mod(DINOUT,2).EQ.0).AND.(PINPINOUT)) THEN C --odd number I take largest Process number (pin) INOUTV(I+1) = PIN ENDIF ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_BUREDUCE C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_IBUINIT(IW, IWSZ, IVAL) IMPLICIT NONE INTEGER(8) :: IWSZ #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) IW(IWSZ) INTEGER(4) IVAL #else INTEGER IW(IWSZ) INTEGER IVAL #endif INTEGER(8) :: I DO I=1_8,IWSZ IW(I)=IVAL ENDDO RETURN END SUBROUTINE CMUMPS_IBUINIT C C SEPARATOR: Another function begins C C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX,ISNDRCVNUM,ISNDRCVVOL, & OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER(8), INTENT(IN) :: IWRKSZ INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ, OSZ INTEGER, INTENT(IN) :: COMM C When INDX holds row indices O(ther)INDX holds col indices INTEGER, INTENT(IN) :: INDX(NZ_loc) INTEGER, INTENT(IN) :: OINDX(NZ_loc) C On entry IPARTVEC(I) holds proc number with largest number of entries C in row/col I INTEGER, INTENT(IN) :: IPARTVEC(ISZ) C C OUTPUT PARAMETERS C SNDSZ (IPROC+1) is set to the number of rows (or col) that C MYID will have to send to IPROC C RCVSZ(IPROC+1) is set to the nb of row/cols that C MYID will receive from IPROC INTEGER, INTENT(OUT) :: SNDSZ(NUMPROCS) INTEGER, INTENT(OUT) :: RCVSZ(NUMPROCS) C OSNDRCVNUM is set to the total number of procs C destination of messages from MYID (< NUMPROCS) C ISNDRCVNUM is set to the total number procs C that will send messages to MYID (< NUMPROCS) C ISNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C OSNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C Knowing that for each row the process with the largest C number of entries will centralize all indices then C ISNDRCVVOL and OSNDRCVVOL are bounded by N INTEGER, INTENT(OUT) :: ISNDRCVNUM, OSNDRCVNUM INTEGER, INTENT(OUT) :: ISNDRCVVOL, OSNDRCVVOL C C INTERNAL WORKING ARRAY INTEGER IWRK(IWRKSZ) INCLUDE 'mpif.h' C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER IIND, IIND2, PIND INTEGER IERROR C check done outsize C IF(ISZ>IWRKSZ) THEN ERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,max(ISZ,OSZ) IWRK(I) = 0 ENDDO C C set SNDSZ DO I8=1,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. & (IIND2.GE.1).AND.(IIND2.LE.OSZ))THEN PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN C MYID will send row/col IIND to proc PIND C (PIND has the largest nb of entries in row/col IIND IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO C C use SNDSZ to set RCVSZ CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) C C compute number of procs destinations of messages from MYID C number of row/col sent by MYID. ISNDRCVNUM = 0 ISNDRCVVOL = 0 OSNDRCVNUM = 0 OSNDRCVVOL = 0 DO I=1, NUMPROCS IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) ENDDO RETURN END SUBROUTINE CMUMPS_NUMVOLSNDRCV C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_SETUPCOMMS(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX, & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, & SNDSZ, RCVSZ, IWRK, & ISTATUS, REQUESTS, & ITAGCOMM, COMM ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER ISNDVOL, OSNDVOL INTEGER MYID, NUMPROCS, ISZ, OSZ C ISZ is either M or N INTEGER INDX(NZ_loc) INTEGER OINDX(NZ_loc) C INDX is either IRN_loc or JCN_col INTEGER IPARTVEC(ISZ) C IPARTVEC is either rowpartvec or colpartvec INTEGER :: ISNDRCVNUM INTEGER INGHBPRCS(ISNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1) INTEGER ISNDRCVJA(ISNDVOL) INTEGER OSNDRCVNUM INTEGER ONGHBPRCS(OSNDRCVNUM) INTEGER OSNDRCVIA(NUMPROCS+1) INTEGER OSNDRCVJA(OSNDVOL) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INTEGER IWRK(ISZ) INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) INTEGER REQUESTS(ISNDRCVNUM) INTEGER ITAGCOMM, COMM C LOCAL VARS INTEGER I, IIND, IIND2, IPID, OFFS INTEGER IWHERETO, POFFS, ITMP, IERROR INTEGER(8) :: I8 C COMPUATIONs START DO I=1,ISZ IWRK(I) = 0 ENDDO C INITIALIZE ONGHBPRCS using SNDSZ C INITIALIZE THE OSNDRCVIA using SNDSZ OFFS = 1 POFFS = 1 DO I=1,NUMPROCS OSNDRCVIA(I) = OFFS + SNDSZ(I) IF(SNDSZ(I) > 0) THEN ONGHBPRCS(POFFS)=I POFFS = POFFS + 1 ENDIF OFFS = OFFS + SNDSZ(I) ENDDO OSNDRCVIA(NUMPROCS+1) = OFFS C CHECK STARTS C check done outsize C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) DO I8=1,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. & (IIND2.GE.1).AND.(IIND2.LE.OSZ) ) THEN IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF ENDIF ENDDO C FILLED UP, WHAT I WILL RECEIVE (My requests from others) C FILL UP ISNDRCVJA. It will be received to fill up CALL MPI_BARRIER(COMM,IERROR) OFFS = 1 POFFS = 1 ISNDRCVIA(1) = 1 DO I=2,NUMPROCS+1 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) IF(RCVSZ(I-1) > 0) THEN INGHBPRCS(POFFS)=I-1 POFFS = POFFS + 1 ENDIF OFFS = OFFS + RCVSZ(I-1) ENDDO CALL MPI_BARRIER(COMM,IERROR) DO I=1, ISNDRCVNUM IPID = INGHBPRCS(I) OFFS = ISNDRCVIA(IPID) ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, & ITAGCOMM, COMM, REQUESTS(I),IERROR) ENDDO DO I=1,OSNDRCVNUM IPID = ONGHBPRCS(I) OFFS = OSNDRCVIA(IPID) ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, & ITAGCOMM, COMM,IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF CALL MPI_BARRIER(COMM,IERROR) RETURN END SUBROUTINE CMUMPS_SETUPCOMMS C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_DOCOMMINF(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, & ISNDRCVNUM, INGHBPRCS, & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, & OSNDRCVNUM, ONGHBPRCS, & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, & ISTATUS, REQUESTS, & COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL REAL TMPD(IDSZ) INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) REAL ISNDRCVA(ISNDRCVVOL) INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) REAL OSNDRCVA(OSNDRCVVOL) INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER COMM, IERROR C LOCAL VARS INTEGER I, PID, OFFS, SZ, J, JS, JE, IID DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, & MPI_REAL, PID-1, & ITAGCOMM,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS, JE IID = OSNDRCVJA(J) OSNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_REAL, PID-1, & ITAGCOMM, COMM, IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF C FOLD INTO MY D DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1)-1 DO J=JS,JE IID = ISNDRCVJA(J) IF(TMPD(IID) < ISNDRCVA(J)) TMPD(IID)= ISNDRCVA(J) ENDDO ENDDO C COMMUNICATE THE UPDATED ONES DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, & MPI_REAL, PID-1, & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1) -1 DO J=JS, JE IID = ISNDRCVJA(J) ISNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_REAL, PID-1, & ITAGCOMM+1, COMM, IERROR) ENDDO IF(OSNDRCVNUM > 0) THEN CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS,JE IID = OSNDRCVJA(J) TMPD(IID)=OSNDRCVA(J) ENDDO ENDDO RETURN END SUBROUTINE CMUMPS_DOCOMMINF C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_DOCOMM1N(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, & ISNDRCVNUM, INGHBPRCS, & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, & OSNDRCVNUM, ONGHBPRCS, & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, & ISTATUS, REQUESTS, & COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL REAL TMPD(IDSZ) INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) REAL ISNDRCVA(ISNDRCVVOL) INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) REAL OSNDRCVA(OSNDRCVVOL) INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER COMM, IERROR C LOCAL VARS INTEGER I, PID, OFFS, SZ, J, JS, JE, IID DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, & MPI_REAL, PID-1, & ITAGCOMM,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS, JE IID = OSNDRCVJA(J) OSNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_REAL, PID-1, & ITAGCOMM, COMM, IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF C FOLD INTO MY D DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1)-1 DO J=JS,JE IID = ISNDRCVJA(J) TMPD(IID) = TMPD(IID)+ ISNDRCVA(J) ENDDO ENDDO C COMMUNICATE THE UPDATED ONES DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, & MPI_REAL, PID-1, & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1) -1 DO J=JS, JE IID = ISNDRCVJA(J) ISNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_REAL, PID-1, & ITAGCOMM+1, COMM, IERROR) ENDDO IF(OSNDRCVNUM > 0) THEN CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS,JE IID = OSNDRCVJA(J) TMPD(IID)=OSNDRCVA(J) ENDDO ENDDO RETURN END SUBROUTINE CMUMPS_DOCOMM1N SUBROUTINE CMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, & IWRK, IWSZ, INUMMY) !$ USE OMP_LIB IMPLICIT NONE EXTERNAL CMUMPS_BUREDUCE INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM INTEGER(8) :: NZ_loc, IWSZ INTEGER, INTENT(IN) :: ISZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C C OUTPUT C IPARTVEC(I) = proc number with largest number of entries C in row/col I C INUMMY = number of local rows/columns with C at least one local entry (NUMPROCS .NE. 1 only) INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) INTEGER, INTENT(OUT) :: INUMMY C C INTERNAL WORKING ARRAY C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries C on my proc and in row/col I) for I=1,ISZ C (2*ISZ+1: 4*ISZ) is then set to C the processor with largest number of entries in its row/col C and its value (that is copied back into IPARTVEC(I) #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) #else INTEGER, INTENT(OUT) :: IWRK(IWSZ) #endif INCLUDE 'mpif.h' C C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER OP, IERROR INTEGER IR, IC INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK C INUMMY = 0 !$ NOMP=omp_get_max_threads() !$ CHUNK= max(K361/2, (ISZ+NOMP-1) / NOMP ) IF(NUMPROCS.NE.1) THEN C CHECK done outsize C IF(IWSZ < 2*ISZ) THEN C CHECK ENDS CALL MPI_OP_CREATE(CMUMPS_BUREDUCE, .TRUE., OP, IERROR) C PERFORM THE REDUCTION !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) DO I=1,ISZ IWRK(2_8*int(I,8)-1_8) = 0 IWRK(2_8*int(I,8)) = MYID ENDDO !$OMP END PARALLEL DO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.ISZ).AND. & (IC.GE.1).AND.(IC.LE.ISZ)) THEN IWRK(2_8*int(IR,8)-1_8) = IWRK(2_8*int(IR,8)-1_8) + 1 IWRK(2_8*int(IC,8)-1_8) = IWRK(2_8*int(IC,8)-1_8) + 1 ENDIF ENDDO CALL MUMPS_BIGALLREDUCE(.FALSE., & IWRK(1), IWRK(1_8+2_8*int(ISZ,8)), ISZ, & MPI_2INTEGER, OP, COMM, IERROR) C CHUNK computed in previous // do !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) !$OMP& REDUCTION(+:INUMMY) DO I=1,ISZ IPARTVEC(I) = IWRK(2_8*int(I,8)+2_8*int(ISZ,8)) C Compute INUMMY directly IF ( IPARTVEC(I) .EQ. MYID. OR. & IWRK(2_8*int(I,8)-1_8) .GT. 0 ) THEN INUMMY=INUMMY+1 ENDIF ENDDO !$OMP END PARALLEL DO C FREE THE OPERATOR CALL MPI_OP_FREE(OP, IERROR) ELSE !$OMP PARALLEL DO PRIVATE(I) SCHEDULE(STATIC,CHUNK) !$OMP& IF ( ISZ > K361 .AND. NOMP .GT. 1) DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_CREATEPARTVECSYM SUBROUTINE CMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX,OINDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER(8), INTENT(IN) :: IWRKSZ INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ INTEGER, INTENT(IN) :: INDX(NZ_loc), OINDX(NZ_loc) INTEGER, INTENT(IN) :: IPARTVEC(ISZ) INTEGER, INTENT(IN) :: COMM C C OUTPUT PARAMETERS C SNDSZ (IPROC+1) is set to the number of rows (or col) that C MYID will have to send to IPROC C RCVSZ(IPROC+1) is set to the nb of row/cols that C MYID will receive from IPROC INTEGER :: SNDSZ(NUMPROCS) INTEGER :: RCVSZ(NUMPROCS) C OSNDRCVNUM is set to the total number of procs C destination of messages from MYID (< NUMPROCS) C ISNDRCVNUM is set to the total number procs C that will send messages to MYID (< NUMPROCS) C ISNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C OSNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C Knowing that for each row the process with the largest C number of entries will centralize all indices then C ISNDRCVVOL and OSNDRCVVOL are bounded by N INTEGER, INTENT(OUT) :: ISNDRCVNUM, ISNDRCVVOL INTEGER, INTENT(OUT) :: OSNDRCVNUM, OSNDRCVVOL C C INTERNAL WORKING ARRAY INTEGER, INTENT(OUT) :: IWRK(IWRKSZ) INCLUDE 'mpif.h' C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER IIND, IIND2, PIND INTEGER IERROR C check done outsize C IF(ISZ>IWRKSZ) THEN ERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,ISZ IWRK(I) = 0 ENDDO C C set SNDSZ DO I8=1_8,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) & .AND.(IIND2.LE.ISZ)) THEN PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN C MYID will send row/col IIND to proc PIND C (PIND has the largest nb of entries in row/col IIND IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF IIND = OINDX(I8) PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO C C use SNDSZ to set RCVSZ CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) C C compute number of procs destinations of messages from MYID C number of row/col sent by MYID. ISNDRCVNUM = 0 ISNDRCVVOL = 0 OSNDRCVNUM = 0 OSNDRCVVOL = 0 DO I=1, NUMPROCS IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) ENDDO RETURN END SUBROUTINE CMUMPS_NUMVOLSNDRCVSYM INTEGER FUNCTION CMUMPS_CHKCONVGLOSYM(D, N, INDXR, INDXRSZ, & EPS, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER N, INDXRSZ REAL D(N) INTEGER INDXR(INDXRSZ) REAL EPS INTEGER COMM EXTERNAL CMUMPS_CHK1LOC INTEGER CMUMPS_CHK1LOC INTEGER GLORES, MYRESR, MYRES INTEGER IERR MYRESR = CMUMPS_CHK1LOC(D, N, INDXR, INDXRSZ, EPS) MYRES = 2*MYRESR CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) CMUMPS_CHKCONVGLOSYM = GLORES RETURN END FUNCTION CMUMPS_CHKCONVGLOSYM SUBROUTINE CMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & MYROWINDICES, INUMMYR, & IWRK, IWSZ, NOMP_MAX ) !$ USE OMP_LIB IMPLICIT NONE INTEGER MYID, NUMPROCS, N, NOMP_MAX INTEGER(8) :: NZ_loc, IWSZ INTEGER INUMMYR INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC, ITMP INTEGER(8) :: I8 INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER NOMP, CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP=omp_get_max_threads() !$ CHUNK= max(K361/2, (N+NOMP-1) / NOMP ) !$ ENDIF C C MARK MY ROWS. IF (NOMP_MAX.LE.0) THEN DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO !$OMP END PARALLEL DO ENDIF C DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 IF(IWRK(IC) .EQ.0) IWRK(IC)=1 ENDIF ENDDO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C C C THE SMAME THING APPLY TO COLS C RETURN END SUBROUTINE CMUMPS_FILLMYROWCOLINDICESSYM SUBROUTINE CMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OINDX, & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, & SNDSZ, RCVSZ, IWRK, & ISTATUS, REQUESTS, & ITAGCOMM, COMM ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, ISZ, ISNDVOL, OSNDVOL INTEGER(8) :: NZ_loc C ISZ is either M or N INTEGER INDX(NZ_loc), OINDX(NZ_loc) C INDX is either IRN_loc or JCN_col INTEGER IPARTVEC(ISZ) C IPARTVEC is either rowpartvec or colpartvec INTEGER ISNDRCVNUM, INGHBPRCS(ISNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1) INTEGER ISNDRCVJA(ISNDVOL) INTEGER OSNDRCVNUM, ONGHBPRCS(OSNDRCVNUM) INTEGER OSNDRCVIA(NUMPROCS+1) INTEGER OSNDRCVJA(OSNDVOL) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INTEGER IWRK(ISZ) INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) INTEGER REQUESTS(ISNDRCVNUM) INTEGER ITAGCOMM, COMM C LOCAL VARS INTEGER I, IIND,IIND2,IPID,OFFS,IWHERETO,POFFS, ITMP, IERROR INTEGER(8) :: I8 C COMPUATIONs START DO I=1,ISZ IWRK(I) = 0 ENDDO C INITIALIZE ONGHBPRCS using SNDSZ C INITIALIZE THE OSNDRCVIA using SNDSZ OFFS = 1 POFFS = 1 DO I=1,NUMPROCS OSNDRCVIA(I) = OFFS + SNDSZ(I) IF(SNDSZ(I) > 0) THEN ONGHBPRCS(POFFS)=I POFFS = POFFS + 1 ENDIF OFFS = OFFS + SNDSZ(I) ENDDO OSNDRCVIA(NUMPROCS+1) = OFFS C CHECK STARTS C check done outsize C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) DO I8=1_8,NZ_loc IIND=INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) & .AND.(IIND2.LE.ISZ)) THEN IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF IIND = OINDX(I8) IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF ENDIF ENDDO C FILLED UP, WHAT I WILL RECEIVE (My requests from others) C FILL UP ISNDRCVJA. It will be received to fill up CALL MPI_BARRIER(COMM,IERROR) OFFS = 1 POFFS = 1 ISNDRCVIA(1) = 1 DO I=2,NUMPROCS+1 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) IF(RCVSZ(I-1) > 0) THEN INGHBPRCS(POFFS)=I-1 POFFS = POFFS + 1 ENDIF OFFS = OFFS + RCVSZ(I-1) ENDDO CALL MPI_BARRIER(COMM,IERROR) DO I=1, ISNDRCVNUM IPID = INGHBPRCS(I) OFFS = ISNDRCVIA(IPID) ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, & ITAGCOMM, COMM, REQUESTS(I),IERROR) ENDDO DO I=1,OSNDRCVNUM IPID = ONGHBPRCS(I) OFFS = OSNDRCVIA(IPID) ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, & ITAGCOMM, COMM,IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF CALL MPI_BARRIER(COMM,IERROR) RETURN END SUBROUTINE CMUMPS_SETUPCOMMSSYM MUMPS_5.8.1/src/zfac_root_parallel.F0000664000175000017500000001740315042446441017207 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_FACTO_ROOT( & MPA, MYID, MASTER_OF_ROOT, & root, roota, N, IROOT, & COMM, IW, LIW, IFREE, & A, LA, PTRAST, PTLUST_S, PTRFAC, & STEP, INFO, LDLT, QR, & WK, LWK, KEEP,KEEP8,DKEEP,OPELIW, & DET_EXP, DET_MANT, DET_SIGN & ) USE MUMPS_LR_STATS, ONLY: UPD_FLOP_ROOT USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE ZMUMPS_INTR_TYPES, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE ( MUMPS_ROOT_STRUC ) :: root TYPE ( ZMUMPS_ROOT_STRUC ) :: roota INTEGER, INTENT(IN) :: MPA INTEGER N, IROOT, COMM, LIW, MYID, IFREE, MASTER_OF_ROOT INTEGER(8) :: LA INTEGER(8) :: LWK COMPLEX(kind=8) WK( LWK ) INTEGER KEEP(500) DOUBLE PRECISION DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTLUST_S(KEEP(28)), STEP(N), IW( LIW ) INTEGER INFO( 2 ), LDLT, QR COMPLEX(kind=8) A( LA ) DOUBLE PRECISION, intent(inout) :: OPELIW INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP COMPLEX(kind=8), INTENT(INOUT) :: DET_MANT #if ! defined(NOSCALAPACK) INTEGER IOLDPS INTEGER(8) :: IAPOS INTEGER LOCAL_M, LOCAL_N, LPIV, IERR DOUBLE PRECISION :: FLOPS_ROOT INTEGER(8) :: ENTRIES_ROOT INTEGER allocok INTEGER FWD_LOCAL_N_RHS, FWD_MTYPE #endif INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_NUMROC IF ( .NOT. root%yes ) RETURN IF ( KEEP(60) .NE. 0 ) THEN IF ((LDLT == 1 .OR. LDLT == 2) .AND. KEEP(60) == 3 ) THEN CALL ZMUMPS_SYMMETRIZE( WK, root%MBLOCK, & root%MYROW, root%MYCOL, root%NPROW, root%NPCOL, & roota%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_NLOC, & root%TOT_ROOT_SIZE, MYID, COMM ) ENDIF RETURN ENDIF #if ! defined(NOSCALAPACK) IF (MPA.GT.0) THEN IF (MYID.EQ.MASTER_OF_ROOT) THEN CALL MUMPS_GET_FLOPS_COST & (root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & LDLT, 3, FLOPS_ROOT) WRITE(MPA,'(A, A, 1PD10.3)') & " ... Start processing the root node with ScaLAPACK, ", & " remaining flops = ", FLOPS_ROOT ENDIF ENDIF IOLDPS = PTLUST_S(STEP(IROOT))+KEEP(IXSZ) IAPOS = PTRAST(STEP(IROOT)) LOCAL_M = IW( IOLDPS + 2 ) LOCAL_N = IW( IOLDPS + 1 ) IAPOS = PTRFAC(IW ( IOLDPS + 4 )) IF ( LDLT.EQ.0 .OR. LDLT.EQ.2 .OR. QR.ne.0 ) THEN LPIV = LOCAL_M + root%MBLOCK ELSE LPIV = 1 END IF IF (associated( root%IPIV )) DEALLOCATE(root%IPIV) root%LPIV = LPIV ALLOCATE( root%IPIV( LPIV ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LPIV WRITE(*,*) MYID,': problem allocating IPIV(',LPIV,') in root' CALL MUMPS_ABORT() END IF CALL DESCINIT( root%DESCRIPTOR(1), root%TOT_ROOT_SIZE, & root%TOT_ROOT_SIZE, root%MBLOCK, root%NBLOCK, & 0, 0, root%CNTXT_BLACS, LOCAL_M, IERR ) IF ( LDLT.EQ.2 ) THEN IF(root%MBLOCK.NE.root%NBLOCK) THEN WRITE(*,*) ' Error: symmetrization only works for' WRITE(*,*) ' square block sizes, MBLOCK/NBLOCK=', & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() END IF IF ( LWK .LT. min( & int(root%MBLOCK,8) * int(root%NBLOCK,8), & int(root%TOT_ROOT_SIZE,8)* int(root%TOT_ROOT_SIZE,8 ) & )) THEN WRITE(*,*) 'Not enough workspace for symmetrization.' CALL MUMPS_ABORT() END IF CALL ZMUMPS_SYMMETRIZE( WK, root%MBLOCK, & root%MYROW, root%MYCOL, root%NPROW, root%NPCOL, & A( IAPOS ), LOCAL_M, LOCAL_N, & root%TOT_ROOT_SIZE, MYID, COMM ) END IF IF (LDLT.EQ.0.OR.LDLT.EQ.2) THEN CALL pzgetrf( root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & A( IAPOS ), & 1, 1, root%DESCRIPTOR(1), root%IPIV(1), IERR ) IF ( IERR .GT. 0 ) THEN INFO(1)=-10 INFO(2)=IERR-1 END IF ELSE CALL pzpotrf('L',root%TOT_ROOT_SIZE,A(IAPOS), & 1,1,root%DESCRIPTOR(1),IERR) IF ( IERR .GT. 0 ) THEN INFO(1)=-40 INFO(2)=IERR-1 END IF END IF IF (IERR .GT. 0) THEN CALL MUMPS_UPDATE_FLOPS_ROOT( OPELIW, LDLT, & root%TOT_ROOT_SIZE, INFO(2), & root%NPROW, root%NPCOL, MYID ) IF (KEEP(486) .GT. 0) THEN CALL UPD_FLOP_ROOT( LDLT, & root%TOT_ROOT_SIZE, INFO(2), & root%NPROW, root%NPCOL, MYID ) ENDIF ELSE CALL MUMPS_UPDATE_FLOPS_ROOT( OPELIW, LDLT, & root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & root%NPROW, root%NPCOL, MYID ) IF (KEEP(486) .GT. 0) THEN CALL UPD_FLOP_ROOT( LDLT, & root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & root%NPROW, root%NPCOL, MYID ) ENDIF ENDIF IF ( LDLT .EQ. 0 ) THEN ENTRIES_ROOT = int(root%TOT_ROOT_SIZE,8) & * int(root%TOT_ROOT_SIZE,8) ELSE ENTRIES_ROOT = int(root%TOT_ROOT_SIZE,8) & * int(root%TOT_ROOT_SIZE+1,8)/2_8 ENDIF KEEP8(10)=KEEP8(10) + ENTRIES_ROOT / & int(root%NPROW * root%NPCOL,8) IF (MYID .eq. MASTER_OF_ROOT) THEN KEEP8(10)=KEEP8(10) + & mod(ENTRIES_ROOT, int(root%NPROW*root%NPCOL,8)) ENDIF CALL ZMUMPS_PAR_ROOT_MINMAX_PIV_UPD ( & root%MBLOCK, root%IPIV(1),root%MYROW, & root%MYCOL, root%NPROW, root%NPCOL, A(IAPOS), LOCAL_M, & LOCAL_N, root%TOT_ROOT_SIZE, MYID, DKEEP, KEEP, LDLT) IF (KEEP(258).NE.0) THEN IF (root%MBLOCK.NE.root%NBLOCK) THEN write(*,*) "Internal error in ZMUMPS_FACTO_ROOT:", & "Block size different for rows and columns", & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_GETDETER2D(root%MBLOCK, root%IPIV(1),root%MYROW, & root%MYCOL, root%NPROW, root%NPCOL, A(IAPOS), LOCAL_M, & LOCAL_N, root%TOT_ROOT_SIZE, MYID, DET_MANT, DET_EXP, & LDLT) ENDIF IF (KEEP(252) .NE. 0) THEN FWD_LOCAL_N_RHS = MUMPS_NUMROC(KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL) FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) FWD_MTYPE = 1 CALL ZMUMPS_SOLVE_2D_BCYCLIC( & root%TOT_ROOT_SIZE, & KEEP(253), & FWD_MTYPE, & A(IAPOS), & root%DESCRIPTOR(1), & LOCAL_M, LOCAL_N, FWD_LOCAL_N_RHS, & root%IPIV(1), LPIV, & roota%RHS_ROOT(1,1), LDLT, & root%MBLOCK, root%NBLOCK, & root%CNTXT_BLACS, IERR) ENDIF #endif RETURN END SUBROUTINE ZMUMPS_FACTO_ROOT MUMPS_5.8.1/src/ztools.F0000664000175000017500000026710215042446441014702 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_COMPRESS_LU(SIZE_INPLACE, &MYID,N,IOLDPS,TYPE,IW, LIW, A, LA, &POSFAC, LRLU, LRLUS, IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, &SSARBR,INODE,IERR & , LRGROUPS, NASS &) USE MUMPS_LOAD USE ZMUMPS_OOC !$ USE OMP_LIB USE ZMUMPS_LR_CORE IMPLICIT NONE INTEGER MYID INTEGER IOLDPS, TYPE, LIW, N, KEEP(500) INTEGER(8) :: SIZE_INPLACE, LA, POSFAC, LRLU, LRLUS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) KEEP8(150) INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER IWPOS INTEGER STEP( N ) INTEGER (8) :: PTRFAC(KEEP(28)) LOGICAL SSARBR INTEGER IOLDSHIFT, IPSSHIFT INTEGER LRGROUPS(KEEP(280)), NASS INCLUDE 'mumps_headers.h' INTEGER LCONT, NELIM, NROW, NPIV, INTSIZ INTEGER NFRONT, NSLAVES INTEGER IPS, IPSIZE INTEGER(8) :: SIZELU, SIZENOTLU, IAPOS, I, SIZESHIFT, ITMP8 INTEGER(8) :: SIZEXXR LOGICAL LRCOMPRESS_PANEL INTEGER INODE INTEGER IERR IERR=0 IOLDSHIFT = IOLDPS + KEEP(IXSZ) IF ( IW( IOLDSHIFT ) < 0 ) THEN write(*,*) ' ERROR 1 compressLU:Should not point to a band.' CALL MUMPS_ABORT() ELSE IF ( IW( IOLDSHIFT + 2 ) < 0 ) THEN write(*,*) ' ERROR 2 compressLU:Stack not performed yet', & IW(IOLDSHIFT + 2) CALL MUMPS_ABORT() ENDIF LCONT = IW( IOLDSHIFT ) NELIM = IW( IOLDSHIFT + 1 ) NROW = IW( IOLDSHIFT + 2 ) NPIV = IW( IOLDSHIFT + 3 ) IAPOS = PTRFAC(IW( IOLDSHIFT + 4 )) NSLAVES= IW( IOLDSHIFT + 5 ) NFRONT = LCONT + NPIV INTSIZ = IW(IOLDPS+XXI) LRCOMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) IF ( (NSLAVES > 0 .AND. TYPE .NE. 2) .OR. & (NSLAVES .eq. 0 .AND. TYPE .EQ. 2 ) ) THEN WRITE(*,*) ' ERROR 3 compressLU: problem with level of inode' CALL MUMPS_ABORT() END IF IF ( KEEP(50) .EQ. 0 ) THEN IF (KEEP(251) .NE. 2) THEN SIZELU = int(LCONT + NROW, 8) * int(NPIV,8) ELSE SIZELU = NPIV * NFRONT ENDIF ELSE IF ( KEEP(459) .GT. 1 ) THEN CALL MUMPS_LDLTPANEL_STORAGE( NPIV, KEEP, & IW(IOLDSHIFT+6+NSLAVES+NFRONT), SIZELU) SIZELU = SIZELU + int( NROW - NPIV, 8 ) * int( NPIV, 8 ) ELSE SIZELU = int(NROW,8) * int(NPIV,8) ENDIF ENDIF CALL MUMPS_GETI8(SIZEXXR, IW(IOLDPS+XXR)) SIZENOTLU = SIZEXXR - SIZELU CALL MUMPS_SUBTRI8TOARRAY( IW(IOLDPS+XXR), SIZENOTLU ) IF ((KEEP(201).NE.0) & .OR.(LRCOMPRESS_PANEL.AND.KEEP(486).EQ.2) & ) THEN SIZESHIFT = SIZEXXR ELSE SIZESHIFT = SIZENOTLU IF (SIZENOTLU.EQ.0_8) THEN GOTO 500 ENDIF ENDIF IF (KEEP(201).EQ.2) THEN IF (KEEP(405) .EQ. 0) THEN KEEP8(31)=KEEP8(31)+SIZELU CALL ZMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) ELSE !$OMP CRITICAL(critical_old_ooc) KEEP8(31)=KEEP8(31)+SIZELU CALL ZMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) !$OMP END CRITICAL(critical_old_ooc) ENDIF IF(IERR.LT.0)THEN WRITE(*,*)MYID,': Internal error in ZMUMPS_NEW_FACTOR' CALL MUMPS_ABORT() ENDIF ENDIF IF ( IOLDPS + INTSIZ .NE. IWPOS ) THEN IPS = IOLDPS + INTSIZ DO WHILE ( IPS .NE. IWPOS ) IPSIZE = IW(IPS+XXI) IPSSHIFT = IPS + KEEP(IXSZ) IF ( IPSIZE .LE. 0 .OR. IPS .GT. IWPOS ) THEN WRITE(*,*) " Internal error 1 ZMUMPS_COMPRESS_LU" WRITE(*,*) " IOLDPS, INTSIZ, IWPOS, LIW=", & IOLDPS, INTSIZ, IWPOS, LIW WRITE(*,*) " IWPOS, IPS, IPSIZE =", IWPOS, IPS, IPSIZE WRITE(*,*) " Header at IOLDPS =", & IW(IOLDPS:IOLDPS+KEEP(IXSZ)+5) WRITE(*,*) " Header at IPS =", & IW(IPS:IPS+KEEP(IXSZ)+5) CALL MUMPS_ABORT() ENDIF IF (IPS+IPSIZE .GT. IWPOS) THEN WRITE(*,*) " Internal error 2 ZMUMPS_COMPRESS_LU" WRITE(*,*) " IOLDPS, INTSIZ, IWPOS, LIW=", & IOLDPS, INTSIZ, IWPOS, LIW WRITE(*,*) " IWPOS, IPS, IPSIZE =", IWPOS, IPS, IPSIZE WRITE(*,*) " Header at IOLDPS =", & IW(IOLDPS:IOLDPS+KEEP(IXSZ)+5) WRITE(*,*) " Header at IOLDPS+INTSIZ =", & IW(IOLDPS+INTSIZ:IOLDPS+INTSIZ+KEEP(IXSZ)+5) WRITE(*,*) " Header at IPS =", & IW(IPS:IPS+KEEP(IXSZ)+5) WRITE(*,*) " ========================== " WRITE(*,*) " Headers starting at IOLDPS:" IPS = IOLDPS DO WHILE (IPS .LE. IWPOS) WRITE(*,*) " -> new IW header at position" , IPS, ":", & IW(IPS:IPS+KEEP(IXSZ)+5) IPS = IPS + IW(IPS+XXI) ENDDO CALL MUMPS_ABORT() ENDIF IF ( IW( IPSSHIFT + 2 ) < 0 ) THEN NFRONT = IW( IPSSHIFT ) IF (IW(IPSSHIFT+4) .LT. 0) THEN WRITE(*,*) " Internal error 3 ZMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW(IPSSHIFT+4))=PTRFAC(IW(IPSSHIFT+4)) & - SIZESHIFT PTRAST(IW(IPSSHIFT+4))=PTRAST(IW(IPSSHIFT+4)) & - SIZESHIFT ELSE IF ( IW( IPSSHIFT ) < 0 ) THEN IF (IW(IPSSHIFT+3) .LT. 0) THEN WRITE(*,*) " Internal error 4 ZMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW(IPSSHIFT+3)) = PTRFAC(IW(IPSSHIFT+3)) & -SIZESHIFT ELSE NFRONT = IW( IPSSHIFT ) + IW( IPSSHIFT + 3 ) IF (IW(IPSSHIFT+4) .LT. 0) THEN WRITE(*,*) " Internal error 4 ZMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZESHIFT END IF IPS = IPS + IPSIZE END DO IF (SIZESHIFT .NE. 0_8) THEN DO I=IAPOS+SIZEXXR-SIZESHIFT, POSFAC-SIZESHIFT-1_8 A( I ) = A( I + SIZESHIFT) END DO END IF ENDIF POSFAC = POSFAC - SIZESHIFT LRLU = LRLU + SIZESHIFT ITMP8 = SIZESHIFT - SIZE_INPLACE LRLUS = LRLUS + ITMP8 IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) - ITMP8 ELSE !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - ITMP8 !$OMP END ATOMIC ENDIF 500 CONTINUE IF (LRCOMPRESS_PANEL.AND.KEEP(486).EQ.2) THEN CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & -SIZESHIFT+SIZE_INPLACE, & KEEP,KEEP8,LRLUS) ELSE CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,SIZELU,-SIZENOTLU+SIZE_INPLACE, & KEEP,KEEP8,LRLUS) ENDIF RETURN END SUBROUTINE ZMUMPS_COMPRESS_LU SUBROUTINE ZMUMPS_STACK_BAND( N, ISON, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP, KEEP8, DKEEP, TYPE_SON & ) !$ USE OMP_LIB USE ZMUMPS_OOC USE MUMPS_LOAD USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER(8) :: LA, LRLU, LRLUS, POSFAC, IPTRLU INTEGER N, ISON, LIW, IWPOS, IWPOSCB, & COMP, IFLAG, IERROR, SLAVEF, MYID, COMM, & TYPE_SON INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), IW(LIW) INTEGER PTLUST_S(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION OPELIW DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE COMPLEX(kind=8) A( LA ) INTEGER(8) :: LREQA, POSA, POSALOC, OLDPOS, JJ INTEGER NFRONT, NCOL_L, NROW_L, LREQI, NSLAVES_L, & POSI, I, IROW_L, ICOL_L, LDA_BAND, NASS LOGICAL NONEED_TO_COPY_FACTORS INTEGER(8) :: LREQA_HEADER INTEGER LIWFAC, STRAT, TYPEFile, NextPivDummy, & IOLDPS_CB LOGICAL LAST_CALL TYPE(IO_BLOCK) :: MonBloc INTEGER LRSTATUS INCLUDE 'mumps_headers.h' DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0d0) COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: IACHK, SIZFR_SON_A, ITMP8 FLOP1 = ZERO NCOL_L = IW( PTRIST(STEP( ISON )) + 3 + KEEP(IXSZ) ) NROW_L = IW( PTRIST(STEP( ISON )) + 2 + KEEP(IXSZ) ) NSLAVES_L = IW( PTRIST(STEP( ISON )) + 5 + KEEP(IXSZ) ) LRSTATUS = IW( PTRIST(STEP( ISON )) + XXLR) LDA_BAND = NCOL_L + IW( PTRIST(STEP( ISON )) + KEEP(IXSZ) ) IF ( KEEP(50) .eq. 0 ) THEN NFRONT = LDA_BAND ELSE NFRONT = IW( PTRIST(STEP( ISON )) + 7 + KEEP(IXSZ) ) END IF IF (KEEP(201).EQ.1) THEN IOLDPS_CB = PTRIST(STEP( ISON )) LIWFAC = IW(IOLDPS_CB+XXI) TYPEFile = TYPEF_L NextPivDummy = -8888 MonBloc%INODE = ISON MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW_L MonBloc%NCOL = LDA_BAND MonBloc%NFS = IW(IOLDPS_CB+1+KEEP(IXSZ)) MonBloc%LastPiv = NCOL_L MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX LAST_CALL = .TRUE. MonBloc%Last = .TRUE. CALL ZMUMPS_DM_SET_DYNPTR(IW(PTRIST(STEP(ISON))+XXS), & A, LA, PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR_SON_A) CALL ZMUMPS_OOC_IO_LU_PANEL_I & ( STRAT, TYPEFile, & SON_A(IACHK), SIZFR_SON_A, MonBloc, & NextPivDummy, NextPivDummy, & IW(IOLDPS_CB), LIWFAC, & MYID, KEEP8(31), IFLAG,LAST_CALL ) IF ((NCOL_L.EQ.0).OR.(NROW_L.EQ.0)) THEN ENDIF ENDIF NONEED_TO_COPY_FACTORS = ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.-1) & .OR. KEEP(251) .EQ. 2 & .OR. (LRSTATUS.GE.2.AND.KEEP(486).EQ.2) & ) IF ((NCOL_L.EQ.0).OR.(NROW_L.EQ.0)) THEN GOTO 80 ENDIF LREQI = 4 + NCOL_L + NROW_L + KEEP(IXSZ) LREQA_HEADER = int(NCOL_L,8) * int(NROW_L,8) IF (NONEED_TO_COPY_FACTORS) THEN LREQA = 0_8 ELSE LREQA = LREQA_HEADER ENDIF IF ( LRLU .LT. LREQA .OR. & IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LREQA ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) GO TO 700 END IF CALL ZMUMPS_COMPRE_NEW( N, KEEP, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS,IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ZMUMPS_STACK_BAND:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) GOTO 700 END IF IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB GOTO 700 END IF END IF IF (.NOT. NONEED_TO_COPY_FACTORS) THEN POSA = POSFAC POSFAC = POSFAC + LREQA LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) IF(KEEP(201).NE.2)THEN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,LREQA,LREQA,KEEP,KEEP8,LRLUS) ELSE CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) ENDIF ENDIF POSI = IWPOS IWPOS = IWPOS + LREQI PTLUST_S(STEP( ISON )) = POSI IW(POSI:POSI+KEEP(IXSZ)-1)=-99999 IW(POSI+XXS)=-9999 IW(POSI+XXI)=LREQI CALL MUMPS_STOREI8(0_8, IW(POSI+XXD)) CALL MUMPS_STOREI8(LREQA, IW(POSI+XXR)) CALL MUMPS_STOREI8(LREQA_HEADER, IW(POSI+XXR)) IW(POSI+XXLR) = LRSTATUS IW(POSI+XXF) = IW(PTRIST(STEP(ISON))+XXF) POSI=POSI+KEEP(IXSZ) IW( POSI ) = - NCOL_L IW( POSI + 1 ) = NROW_L IW( POSI + 2 ) = NFRONT - NCOL_L IW( POSI + 3 ) = STEP(ISON) IF (.NOT. NONEED_TO_COPY_FACTORS) THEN PTRFAC(STEP(ISON)) = POSA ELSE PTRFAC(STEP(ISON)) = -77777_8 ENDIF IROW_L = PTRIST(STEP(ISON)) + 6 + NSLAVES_L + KEEP(IXSZ) ICOL_L = PTRIST(STEP(ISON)) + 6 + NROW_L + NSLAVES_L + KEEP(IXSZ) DO I = 1, NROW_L IW( POSI+3+I ) = IW( IROW_L+I-1 ) ENDDO DO I = 1, NCOL_L IW( POSI+NROW_L+3+I) = IW( ICOL_L+I-1 ) ENDDO IF (.NOT.NONEED_TO_COPY_FACTORS) THEN CALL ZMUMPS_DM_SET_DYNPTR(IW(PTRIST(STEP(ISON))+XXS), & A, LA, PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR_SON_A) IF (int(NROW_L,8)*int(NCOL_L,8).GT.int(KEEP(361),8)) THEN !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(I,JJ,OLDPOS,POSALOC) DO I = 1, NROW_L DO JJ = 0_8, int(NCOL_L-1,8) OLDPOS = IACHK + int(I-1,8)*int(LDA_BAND,8) POSALOC = POSA + int(NCOL_L,8)*int(I-1,8) A( POSALOC+JJ ) = SON_A( OLDPOS+JJ ) ENDDO END DO !$OMP END PARALLEL DO ELSE POSALOC = POSA DO I = 1, NROW_L OLDPOS = IACHK + int(I-1,8)*int(LDA_BAND,8) DO JJ = 0_8, int(NCOL_L-1,8) A( POSALOC+JJ ) = SON_A( OLDPOS+JJ ) ENDDO POSALOC = POSALOC + int(NCOL_L,8) END DO ENDIF ENDIF ITMP8 = int(NCOL_L,8) * int(NROW_L,8) IF (KEEP(405) .EQ.1) THEN !$OMP ATOMIC UPDATE KEEP8(10) = KEEP8(10) + ITMP8 !$OMP END ATOMIC ELSE KEEP8(10) = KEEP8(10) + ITMP8 ENDIF IF (KEEP(201).EQ.2) THEN IF (KEEP(405).EQ.0) THEN KEEP8(31)=KEEP8(31)+LREQA CALL ZMUMPS_NEW_FACTOR(ISON,PTRFAC,KEEP,KEEP8,A,LA,LREQA,IFLAG) ELSE !$OMP CRITICAL(critical_old_ooc) KEEP8(31)=KEEP8(31)+LREQA CALL ZMUMPS_NEW_FACTOR(ISON,PTRFAC,KEEP,KEEP8,A,LA,LREQA,IFLAG) !$OMP END CRITICAL(critical_old_ooc) ENDIF IF(IFLAG.LT.0)THEN WRITE(*,*)MYID,': Internal error in ZMUMPS_NEW_FACTOR' IERROR=0 GOTO 700 ENDIF POSFAC = POSFAC - LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - LREQA !$OMP END ATOMIC CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,LREQA,0_8,KEEP,KEEP8,LRLUS) ENDIF 80 CONTINUE IF (TYPE_SON == 1) THEN GOTO 90 ENDIF IF ( KEEP(50) .eq. 0 ) THEN FLOP1 = dble( NCOL_L * NROW_L) + & dble(NROW_L*NCOL_L)*dble(2*NFRONT-NCOL_L-1) ELSE FLOP1 = dble( NCOL_L ) * dble( NROW_L ) & * dble( 2 * LDA_BAND - NROW_L - NCOL_L + 1) END IF OPELIW = OPELIW + FLOP1 FLOP1_EFFECTIVE = FLOP1 NASS = IW( PTRIST(STEP( ISON )) + 4 + KEEP(IXSZ) ) IF ( NCOL_L .NE. NASS ) THEN IF ( KEEP(50).eq.0 ) THEN FLOP1 = dble( NASS * NROW_L) + & dble(NROW_L*NASS)*dble(2*NFRONT-NASS-1) ELSE FLOP1 = dble( NASS ) * dble( NROW_L ) * & dble( 2 * LDA_BAND - NROW_L - NASS + 1) END IF END IF CALL MUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) CALL MUMPS_LOAD_UPDATE(2,.FALSE.,-FLOP1,KEEP,KEEP8) 90 CONTINUE RETURN 700 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE ZMUMPS_STACK_BAND SUBROUTINE ZMUMPS_FREE_BAND( N, ISON, & PTRIST, PTRAST, IW, LIW, A, LA, & LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON & ) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_PTR, & ZMUMPS_DM_FREE_BLOCK IMPLICIT NONE INTEGER(8) :: LRLU, LRLUS, IPTRLU, LA INTEGER ISON, MYID, N, IWPOSCB, TYPE_SON INTEGER KEEP(500), STEP(N) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)) INTEGER LIW INTEGER IW(LIW) COMPLEX(kind=8) A(LA) INTEGER ISTCHK INTEGER(8) :: DYN_SIZE COMPLEX(kind=8), DIMENSION(:), POINTER :: FORTRAN_POINTER INTEGER :: XXG_STATUS INCLUDE 'mumps_headers.h' ISTCHK = PTRIST(STEP(ISON)) CALL MUMPS_GETI8( DYN_SIZE, IW(ISTCHK+XXD) ) XXG_STATUS = IW(ISTCHK+XXG) IF (DYN_SIZE .GT. 0_8) THEN CALL ZMUMPS_DM_SET_PTR( PTRAST(STEP(ISON)), & DYN_SIZE, FORTRAN_POINTER ) ENDIF CALL ZMUMPS_FREE_BLOCK_CB_STATIC(.FALSE.,MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) IF (DYN_SIZE .GT. 0_8) THEN CALL ZMUMPS_DM_FREE_BLOCK(XXG_STATUS, FORTRAN_POINTER, DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF PTRIST(STEP( ISON )) = -9999888 PTRAST(STEP( ISON )) = -9999888_8 RETURN END SUBROUTINE ZMUMPS_FREE_BAND SUBROUTINE ZMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, KEEP, KEEP8, & MYID, COMM, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & INFO, INFOG, PROK, MP, PROKG, MPG & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: PROK, PROKG, SUM_OF_PEAKS INTEGER , INTENT(IN) :: MYID, COMM, N, NELT, NSLAVES, & LNA, MP, MPG INTEGER(8), INTENT(IN):: NA_ELT8, NNZ8 INTEGER, INTENT(IN):: NA(LNA) INTEGER :: KEEP(500), INFO(80), INFOG(80) INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER, PARAMETER :: MASTER = 0 INTEGER :: OOC_STAT, BLR_STRAT, BLR_CASE INTEGER :: IRANK LOGICAL :: EFF, PERLU_ON, COMPUTE_MAXAVG INTEGER(8) :: TOTAL_BYTES INTEGER :: TOTAL_MBYTES INTEGER(8) :: TOTAL_BYTES_UNDER_L0 INTEGER :: TOTAL_MBYTES_UNDER_L0 INTEGER, DIMENSION(3) :: LRLU_UD, OOC_LRLU_UD INTEGER, DIMENSION(3) :: & LRLUCB_UD, OOC_LRLUCB_UD, & LRCB_UD, OOC_LRCB_UD PERLU_ON = .TRUE. EFF = .FALSE. COMPUTE_MAXAVG = .NOT.(NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) IF ( PROKG.AND.SUM_OF_PEAKS) THEN WRITE( MPG,'(A)') & ' Estimations with BLR compression of LU factors:' WRITE( MPG,'(A,I6,A) ') & ' ICNTL(38) Estimated compression rate of LU factors =', & KEEP(464), '/1000' ENDIF OOC_STAT = 0 BLR_STRAT = 1 BLR_CASE = 1 CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, LRLU_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(30) = TOTAL_MBYTES IF (MYID.EQ.MASTER) THEN INFOG(36) = LRLU_UD(1) INFOG(37) = LRLU_UD(2) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN LRLU_UD(3) = (LRLU_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE LRLU_UD(3) = LRLU_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(36)):', & INFOG(36) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, IC factorization (INFOG(37)):' & ,INFOG(37) END IF OOC_STAT = 1 BLR_STRAT = 1 BLR_CASE = 1 CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, OOC_LRLU_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(31) = TOTAL_MBYTES IF (MYID.EQ.MASTER) THEN INFOG(38)= OOC_LRLU_UD(1) INFOG(39)= OOC_LRLU_UD(2) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN OOC_LRLU_UD(3) = (OOC_LRLU_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE OOC_LRLU_UD(3) = OOC_LRLU_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(38)):', & INFOG(38) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, OOC factorization (INFOG(39)):' & ,INFOG(39) END IF IF (SUM_OF_PEAKS) THEN OOC_STAT = 0 BLR_STRAT = 3 BLR_CASE = 1 CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, LRCB_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(37) = TOTAL_MBYTES ENDIF IF (MYID.EQ.MASTER.AND.SUM_OF_PEAKS) THEN INFOG(44)= LRCB_UD(1) INFOG(45)= LRCB_UD(2) ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN LRCB_UD(3) = (LRCB_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE LRCB_UD(3) = LRCB_UD(2)/NSLAVES ENDIF ENDIF OOC_STAT = 1 BLR_STRAT = 3 BLR_CASE = 1 CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, OOC_LRCB_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(38) = TOTAL_MBYTES ENDIF IF (MYID.EQ.MASTER.AND.SUM_OF_PEAKS) THEN INFOG(46)= OOC_LRCB_UD(1) INFOG(47)= OOC_LRCB_UD(2) ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN OOC_LRCB_UD(3) = (OOC_LRCB_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE OOC_LRCB_UD(3) = OOC_LRCB_UD(2)/NSLAVES ENDIF ENDIF END IF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN WRITE( MPG,'(A,A)') & ' Estimations with BLR compression of LU factors ', & 'and Contribution Blocks:' WRITE( MPG,'(A,I6,A) ') & ' ICNTL(38) Estimated compression rate of LU factors =', & KEEP(464), '/1000' WRITE( MPG,'(A,I6,A) ') & ' ICNTL(39) Estimated compression rate of CB =', & KEEP(465), '/1000' ENDIF OOC_STAT = 0 BLR_STRAT = 2 BLR_CASE = 1 CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, LRLUCB_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(34) = TOTAL_MBYTES ENDIF IF (MYID.EQ.MASTER.AND.SUM_OF_PEAKS) THEN INFOG(40)=LRLUCB_UD(1) INFOG(41)=LRLUCB_UD(2) ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN LRLUCB_UD(3) = (LRLUCB_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE LRLUCB_UD(3) = LRLUCB_UD(2)/NSLAVES ENDIF ELSE LRLUCB_UD(1) = TOTAL_MBYTES ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(40)):', & INFOG(40) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, IC factorization (INFOG(41)):' & ,INFOG(41) END IF OOC_STAT = 1 BLR_STRAT = 2 BLR_CASE = 1 CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, OOC_LRLUCB_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(35) = TOTAL_MBYTES ENDIF IF (MYID.EQ.MASTER.AND.SUM_OF_PEAKS) THEN INFOG(42)=OOC_LRLUCB_UD(1) INFOG(43)=OOC_LRLUCB_UD(2) ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN OOC_LRLUCB_UD(3) = (OOC_LRLUCB_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE OOC_LRLUCB_UD(3) = OOC_LRLUCB_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(42)):', & INFOG(42) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, OOC factorization (INFOG(43)):' & ,INFOG(43) END IF END SUBROUTINE ZMUMPS_MEM_ESTIM_BLR_ALL SUBROUTINE ZMUMPS_MAX_MEM( KEEP, KEEP8, & MYID, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & MEMORY_MBYTES, EFF, OOC_STRAT, BLR_STRAT, PERLU_ON, & MEMORY_BYTES, & BLR_CASE, SUM_OF_PEAKS, MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: EFF, PERLU_ON, UNDER_L0_OMP INTEGER, INTENT(IN) :: OOC_STRAT, BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID, N, NELT, NSLAVES, LNA INTEGER(8), INTENT(IN) :: NA_ELT8, NNZ8 INTEGER, INTENT(IN) :: NA(LNA) INTEGER(8), INTENT(OUT):: MEMORY_BYTES INTEGER, INTENT(OUT) :: MEMORY_MBYTES INTEGER, INTENT(IN) :: BLR_CASE LOGICAL, INTENT(IN) :: SUM_OF_PEAKS LOGICAL, INTENT(IN) :: MEM_EFF_ALLOCATED INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER :: MUMPS_GET_POOL_LENGTH EXTERNAL :: MUMPS_GET_POOL_LENGTH INTEGER(8) :: MemEstimGlobal LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: PERLU, NBRECORDS INTEGER(8) :: NB_REAL INTEGER(8) :: TEMP, NB_BYTES, NB_INT INTEGER :: ZMUMPS_LBUF_INT INTEGER(8) :: ZMUMPS_LBUFR_BYTES8, ZMUMPS_LBUF8 INTEGER :: NBUFS INTEGER(8) :: TEMPI INTEGER(8) :: TEMPR INTEGER :: MIN_PERLU INTEGER(8) :: BUF_OOC, BUF_OOC_PANEL, BUF_OOC_NOPANEL INTEGER(8) :: OOC_NB_FILE_TYPE INTEGER(8) :: NSTEPS8, N8, NELT8 INTEGER(8) :: I8OVERI INTEGER(8) :: SUM_NRLADU_underL0, & SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, & SUM_NRLADULR_WC_underL0 INTEGER(4) :: I4 INTEGER(8) :: MIN_NRLADU_underL0, MIN_NRLADU_if_LR_LU_underL0 INTEGER :: ITH, ITHMIN, ITHMIN_if_LRLU INTEGER(8) :: I8_L0_OMP_2, I8_L0_OMP_3, & I8_L0_OMP_5, I8_L0_OMP_6, I8_L0_OMP_7, & I8_L0_OMP_8, I8_L0_OMP_9, I8_L0_OMP_10, & I8_L0_OMP_11, I8_L0_OMP_12, I8_L0_OMP_13 I8OVERI = int(KEEP(10),8) PERLU = KEEP(12) NSTEPS8 = int(KEEP(28),8) N8 = int(N,8) NELT8 = int(NELT,8) IF (.NOT.PERLU_ON) PERLU = 0 I_AM_MASTER = ( MYID .eq. 0 ) I_AM_SLAVE = ( KEEP(46).eq. 1 .or. MYID .ne. 0 ) TEMP = 0_8 NB_REAL = 0_8 NB_BYTES = 0_8 NB_INT = 0_8 IF (KEEP(235) .NE. 0 .OR. KEEP(237) .NE. 0) THEN NB_INT = NB_INT + NSTEPS8 ENDIF NB_INT = NB_INT + 5_8 * NSTEPS8 NB_INT = NB_INT + NSTEPS8 + int(KEEP(56),8)*int(NSLAVES+2,8) NB_INT = NB_INT + 3_8*N8 + KEEP(280) IF (KEEP(38) .NE. 0 .AND.I_AM_SLAVE) NB_INT = NB_INT + 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 + KEEP(193)*I8OVERI NB_INT = NB_INT + KEEP(194)+KEEP(195)+KEEP(196) NB_INT = NB_INT + 2 ELSE NB_INT = NB_INT + 2_8 * ( NELT8 + 1_8 ) * I8OVERI NB_INT = NB_INT + N8 + 1_8 + NELT8 NB_INT = NB_INT + I8OVERI + 3 END IF NB_INT = NB_INT + int(LNA,8) IF ( .NOT. EFF ) THEN IF (I_AM_SLAVE) THEN IF (UNDER_L0_OMP) THEN I8_L0_OMP_2 = 0_8 I8_L0_OMP_3 = 0_8 MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,1) MIN_NRLADU_underL0 = I8_L0_OMP(1,1) ITHMIN = 1 ITHMIN_if_LRLU = 1 DO ITH=1, KEEP(400) IF (I8_L0_OMP(1,ITH).LT.MIN_NRLADU_underL0) & THEN MIN_NRLADU_underL0 = I8_L0_OMP(1,ITH) ITHMIN = ITH ENDIF IF (I8_L0_OMP(4,ITH).LT.MIN_NRLADU_if_LR_LU_underL0) & THEN MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,ITH) ITHMIN_if_LRLU = ITH ENDIF I8_L0_OMP_2=I8_L0_OMP_2 + I8_L0_OMP(2,ITH) I8_L0_OMP_3=I8_L0_OMP_3 + I8_L0_OMP(3,ITH) ENDDO IF (SUM_OF_PEAKS.AND.BLR_STRAT.GT.0) THEN I8_L0_OMP_5 = 0_8 I8_L0_OMP_6 = 0_8 I8_L0_OMP_7 = 0_8 I8_L0_OMP_8 = 0_8 I8_L0_OMP_9 = 0_8 I8_L0_OMP_10= 0_8 I8_L0_OMP_11= 0_8 I8_L0_OMP_12= 0_8 I8_L0_OMP_13= 0_8 DO ITH=1, KEEP(400) I8_L0_OMP_5 = I8_L0_OMP_5 + I8_L0_OMP(5,ITH) I8_L0_OMP_6 = I8_L0_OMP_6 + I8_L0_OMP(6,ITH) I8_L0_OMP_7 = I8_L0_OMP_7 + I8_L0_OMP(7,ITH) I8_L0_OMP_8 = I8_L0_OMP_8 + I8_L0_OMP(8,ITH) I8_L0_OMP_9 = I8_L0_OMP_9 + I8_L0_OMP(9,ITH) I8_L0_OMP_10= I8_L0_OMP_10+ I8_L0_OMP(10,ITH) I8_L0_OMP_11= I8_L0_OMP_11+ I8_L0_OMP(11,ITH) I8_L0_OMP_12= I8_L0_OMP_12+ I8_L0_OMP(12,ITH) I8_L0_OMP_13= I8_L0_OMP_13+ I8_L0_OMP(13,ITH) ENDDO ENDIF CALL ZMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & 0_8, 0_8, 0_8, 0_8, & I8_L0_OMP_2, & I8_L0_OMP_3, & I8_L0_OMP_5, & I8_L0_OMP_6, & I8_L0_OMP_7, & I8_L0_OMP_8, & I8_L0_OMP_9, & I8_L0_OMP_10, & I8_L0_OMP_11, & I8_L0_OMP_12, & I8_L0_OMP_13, & MemEstimGlobal & ) IF (BLR_STRAT.EQ.0) THEN IF ( OOC_STRAT .LE. 0 .AND. OOC_STRAT .NE. -1 ) THEN MemEstimGlobal = MemEstimGlobal + & I8_L0_OMP(1,ITHMIN) + & I8_L0_OMP(23, ITHMIN) ELSE MemEstimGlobal = MemEstimGlobal + & I8_L0_OMP(23, ITHMIN) ENDIF ELSE IF ( OOC_STRAT .LE. 0 .AND. OOC_STRAT .NE. -1 ) THEN MemEstimGlobal = MemEstimGlobal + & I8_L0_OMP(4,ITHMIN_if_LRLU) + & I8_L0_OMP(23, ITHMIN_if_LRLU) ELSE MemEstimGlobal = MemEstimGlobal + & I8_L0_OMP(23, ITHMIN_if_LRLU) ENDIF ENDIF NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ELSE IF ( KEEP8(24).EQ.0_8 ) THEN SUM_NRLADU_underL0 = 0_8 SUM_NRLADU_if_LR_LU_underL0 = 0_8 SUM_NRLADULR_UD_underL0 = 0_8 SUM_NRLADULR_WC_underL0 = 0_8 IF (KEEP(400) .GT. 0 ) THEN DO ITH=1, KEEP(400) SUM_NRLADU_underL0 = & SUM_NRLADU_underL0 + I8_L0_OMP(1,ITH) SUM_NRLADU_if_LR_LU_underL0 = & SUM_NRLADU_if_LR_LU_underL0 + I8_L0_OMP(4,ITH) SUM_NRLADULR_UD_underL0 = & SUM_NRLADULR_UD_underL0 + I8_L0_OMP(9,ITH) SUM_NRLADULR_WC_underL0 = & SUM_NRLADULR_WC_underL0 + I8_L0_OMP(10,ITH) ENDDO ENDIF CALL ZMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & SUM_NRLADU_underL0, SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, SUM_NRLADULR_WC_underL0, & KEEP8(53), & KEEP8(54), & KEEP8(33), & KEEP8(34), & KEEP8(35), & KEEP8(50), & KEEP8(36), & KEEP8(47), & KEEP8(37), & KEEP8(38), & KEEP8(39), & MemEstimGlobal & ) IF (KEEP(400).LE.0) THEN NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ELSE IF (BLR_STRAT.EQ.0) THEN IF ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(KEEP8(14) / 100_8 + 1_8 ) ELSE NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(KEEP8(12) / 100_8 + 1_8 ) ENDIF ELSE NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ENDIF ENDIF ENDIF ELSE NB_REAL = NB_REAL + 1_8 ENDIF ELSE IF (I_AM_SLAVE) THEN IF (UNDER_L0_OMP) THEN IF (MEM_EFF_ALLOCATED) THEN NB_REAL = NB_REAL + KEEP8(63) ELSE NB_REAL = NB_REAL + KEEP8(62) ENDIF ELSE IF (MEM_EFF_ALLOCATED) THEN NB_REAL = NB_REAL + KEEP8(23) + KEEP8(74) ELSE NB_REAL = NB_REAL + KEEP8(67) + KEEP8(74) ENDIF ENDIF ENDIF IF ( OOC_STRAT .GT. 0 .AND. I_AM_SLAVE ) THEN BUF_OOC_NOPANEL = 2_8 * KEEP8(119) IF (KEEP(50).EQ.0)THEN BUF_OOC_PANEL = 8_8 * int(KEEP(226),8) ELSE BUF_OOC_PANEL = 4_8 * int(KEEP(226),8) ENDIF IF (OOC_STRAT .EQ. 2) THEN BUF_OOC = BUF_OOC_NOPANEL ELSE BUF_OOC = BUF_OOC_PANEL ENDIF NB_REAL = NB_REAL + min(BUF_OOC + int(max(PERLU,0),8) * & (BUF_OOC/100_8+1_8),12000000_8) IF (OOC_STRAT .EQ. 2) THEN OOC_NB_FILE_TYPE = 1_8 ELSE IF (KEEP(50).EQ.0) THEN OOC_NB_FILE_TYPE = 2_8 ELSE OOC_NB_FILE_TYPE = 1_8 ENDIF ENDIF NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 * I8OVERI NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 * I8OVERI NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 ENDIF IF (KEEP(252).EQ.1 .AND. .NOT. I_AM_MASTER) THEN NB_REAL = NB_REAL + N8 ENDIF IF ( .not. ( I_AM_SLAVE .and. I_AM_MASTER .and. KEEP(52) .eq. 0 & .and. KEEP(55) .ne. 0 ) ) THEN NB_INT = NB_INT + KEEP8(27) END IF TEMPI= 0_8 TEMPR = 0_8 NBRECORDS = KEEP(39) IF (KEEP(55).eq.0) THEN IF (NNZ8 < int(NBRECORDS,8)) THEN NBRECORDS=int(NNZ8) ENDIF ELSE IF (NA_ELT8 < int(NBRECORDS,8)) THEN NBRECORDS=int(NA_ELT8) ENDIF ENDIF IF ( KEEP(54) .eq. 0 ) THEN IF ( I_AM_MASTER ) THEN IF ( KEEP(46) .eq. 0 ) THEN NBUFS = NSLAVES ELSE NBUFS = NSLAVES - 1 IF (KEEP(55) .eq. 0 ) & TEMPI = TEMPI + 2_8 * N8 END IF TEMPI = TEMPI + 2_8 * int(NBRECORDS,8) * int(NBUFS,8) TEMPR = TEMPR + int(NBRECORDS,8) * int(NBUFS,8) ELSE IF ( KEEP(55) .eq. 0 )THEN TEMPI = TEMPI + 2_8 * int(NBRECORDS,8) TEMPR = TEMPR + int(NBRECORDS,8) END IF END IF ELSE IF ( I_AM_SLAVE ) THEN TEMPI = TEMPI + int(1+4*NSLAVES,8) * int(NBRECORDS,8) TEMPR = TEMPR + int(1+2*NSLAVES,8) * int(NBRECORDS,8) END IF END IF TEMP = NB_BYTES + (NB_INT + TEMPI) * int(KEEP(34),8) & + NB_REAL * int(KEEP(35),8) & + (TEMPR+KEEP8(26)) * int(KEEP(149),8) NB_REAL = NB_REAL + KEEP8(26) IF ( I_AM_SLAVE ) THEN IF (BLR_STRAT.NE.0) THEN ZMUMPS_LBUFR_BYTES8 = int(KEEP(380),8) * int(KEEP(35),8) ELSE ZMUMPS_LBUFR_BYTES8 = int(KEEP(44),8) * int(KEEP(35),8) ENDIF ZMUMPS_LBUFR_BYTES8 = max( ZMUMPS_LBUFR_BYTES8, & 200000_8 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF IF (KEEP(72).NE.1) THEN ZMUMPS_LBUFR_BYTES8 = ZMUMPS_LBUFR_BYTES8 & + int( dble(max(PERLU/2,MIN_PERLU))* & dble(ZMUMPS_LBUFR_BYTES8)/100D0,8) ELSE ZMUMPS_LBUFR_BYTES8 = ZMUMPS_LBUFR_BYTES8 & + int( dble(max(PERLU,MIN_PERLU))* & dble(ZMUMPS_LBUFR_BYTES8)/100D0,8) ENDIF ZMUMPS_LBUFR_BYTES8 = min(ZMUMPS_LBUFR_BYTES8, & int(huge (I4)-100,8)) NB_BYTES = NB_BYTES + ZMUMPS_LBUFR_BYTES8 IF (.NOT.UNDER_L0_OMP) THEN IF (BLR_STRAT.NE.0) THEN ZMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 & * dble(KEEP( 379 ) * KEEP( 35 )), 8 ) ELSE ZMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 & * dble(KEEP( 43 ) * KEEP( 35 )), 8 ) ENDIF ZMUMPS_LBUF8 = max( ZMUMPS_LBUF8, 200000_8 ) IF (KEEP(72).NE.1) THEN ZMUMPS_LBUF8 = ZMUMPS_LBUF8 & + int( dble(max(PERLU/2,MIN_PERLU))* & dble(ZMUMPS_LBUF8)/100D0, 8) ELSE ZMUMPS_LBUF8 = ZMUMPS_LBUF8 & + int( dble(max(PERLU,MIN_PERLU))* & dble(ZMUMPS_LBUF8)/100D0, 8) ENDIF ZMUMPS_LBUF8 = min(ZMUMPS_LBUF8, int(huge(I4)-100,8)) ZMUMPS_LBUF8 = max(ZMUMPS_LBUF8, ZMUMPS_LBUFR_BYTES8+ & 3_8*int(KEEP(34),8)) NB_BYTES = NB_BYTES + ZMUMPS_LBUF8 ENDIF ZMUMPS_LBUF_INT = ( KEEP(56) + & NSLAVES * NSLAVES ) * 5 & * KEEP(34) NB_BYTES = NB_BYTES + int(ZMUMPS_LBUF_INT,8) IF (.NOT.EFF) THEN IF (UNDER_L0_OMP) THEN IF (KEEP(144).GT.0) THEN NB_INT = NB_INT + N8*int(KEEP(400),8) NB_INT = NB_INT + & int(MUMPS_GET_POOL_LENGTH(NA(1), KEEP, KEEP8),8)* & int(KEEP(400),8) ENDIF ENDIF IF (KEEP(400).GT.0) THEN NB_INT = NB_INT + & int(MUMPS_GET_POOL_LENGTH(NA(1), KEEP, KEEP8),8) ENDIF IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int( & KEEP(138) + 3 * max(PERLU,10) * & ( KEEP(138) / 100 + 1 ) & ,8) ELSE NB_INT = NB_INT + int( & KEEP(137) + 3 * max(PERLU,10) * & ( KEEP(137) / 100 + 1 ) & ,8) ENDIF ENDIF IF (.NOT.UNDER_L0_OMP) THEN IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int( & KEEP(225) + 2 * max(PERLU,10) * & ( KEEP(225) / 100 + 1 ) & ,8) ELSE NB_INT = NB_INT + int( & KEEP(15) + 2 * max(PERLU,10) * & ( KEEP(15) / 100 + 1 ) & ,8) ENDIF ENDIF NB_INT = NB_INT + NSTEPS8 NB_INT = NB_INT + NSTEPS8 * I8OVERI NB_INT = NB_INT + N8 + 4_8 * NSTEPS8 + & int(MUMPS_GET_POOL_LENGTH(NA(1), KEEP, KEEP8),8) NB_INT = NB_INT + 2_8 * NSTEPS8 * I8OVERI ENDIF MEMORY_BYTES = NB_BYTES + NB_INT * int(KEEP(34),8) + & NB_REAL * int(KEEP(35),8) MEMORY_BYTES = max( MEMORY_BYTES, TEMP ) MEMORY_MBYTES = nint( dble(MEMORY_BYTES) / dble(1000000) ) RETURN END SUBROUTINE ZMUMPS_MAX_MEM SUBROUTINE ZMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & SUM_NRLADU_underL0, SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, SUM_NRLADULR_WC_underL0, & PEAK_FR, & PEAK_FR_OOC, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB, & NRLADULR_UD, & NRLADULR_WC, & NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, & NRLNECLR_LUCB_WC, & MemEstimGlobal & ) INTEGER, INTENT(IN) :: OOC_STRAT, BLR_STRAT INTEGER, INTENT(IN) :: BLR_CASE LOGICAL, INTENT(IN) :: SUM_OF_PEAKS INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER(8), INTENT(IN) :: SUM_NRLADU_underL0, & SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, & SUM_NRLADULR_WC_underL0 INTEGER(8), INTENT(IN) :: & PEAK_FR, & PEAK_FR_OOC, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB, & NRLADULR_UD, & NRLADULR_WC, & NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, & NRLNECLR_LUCB_WC INTEGER(8), INTENT(OUT) :: MemEstimGlobal IF ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN MemEstimGlobal = PEAK_FR_OOC ELSE MemEstimGlobal = PEAK_FR ENDIF IF (BLR_STRAT.GT.0) THEN IF (.NOT.SUM_OF_PEAKS) THEN IF (BLR_STRAT.EQ.1) THEN IF (BLR_CASE.LE.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(40) ELSE MemEstimGlobal = KEEP8(41) ENDIF ELSE IF (BLR_CASE.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(33) ELSE MemEstimGlobal = KEEP8(54) ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(53) ELSE MemEstimGlobal = KEEP8(42) ENDIF ENDIF ELSE IF (BLR_CASE.LE.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(43) ELSE MemEstimGlobal = KEEP8(45) ENDIF ELSE IF (BLR_CASE.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(34) ELSE MemEstimGlobal = KEEP8(35) ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(44) ELSE MemEstimGlobal = KEEP8(46) ENDIF ENDIF ENDIF ELSE IF (BLR_STRAT.EQ.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_LU & + SUM_NRLADU_if_LR_LU_underL0 ELSE MemEstimGlobal = PEAK_FR_OOC ENDIF IF (BLR_CASE.EQ.1) THEN MemEstimGlobal = MemEstimGlobal + NRLADULR_UD & + SUM_NRLADULR_UD_underL0 ELSE IF (BLR_CASE.EQ.3) THEN MemEstimGlobal = MemEstimGlobal + NRLADULR_WC & + SUM_NRLADULR_WC_underL0 ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_LUCB & + SUM_NRLADU_if_LR_LU_underL0 ELSE MemEstimGlobal = NRLNECOOC_if_LR_LUCB ENDIF IF (BLR_CASE.EQ.1) THEN MemEstimGlobal = MemEstimGlobal + NRLNECLR_LUCB_UD & + SUM_NRLADULR_UD_underL0 ELSE IF (BLR_CASE.EQ.3) THEN MemEstimGlobal = MemEstimGlobal + NRLNECLR_LUCB_WC & + SUM_NRLADULR_WC_underL0 ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_CB & + SUM_NRLADU_underL0 ELSE MemEstimGlobal = NRLNECOOC_if_LR_LUCB ENDIF MemEstimGlobal = MemEstimGlobal + NRLNECLR_CB_UD ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SET_MEMESTIMGLOBAL SUBROUTINE ZMUMPS_SET_BLRSTRAT_AND_MAXS_K8 ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & KEEP, KEEP8) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS_BASE8, MAXS_BASE_RELAXED8 INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) CALL ZMUMPS_SET_BLRSTRAT_AND_MAXS ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & KEEP(1), & KEEP8(12), & KEEP8(14), & KEEP8(33), & KEEP8(34), & KEEP8(35), & KEEP8(50) ) RETURN END SUBROUTINE ZMUMPS_SET_BLRSTRAT_AND_MAXS_K8 SUBROUTINE ZMUMPS_SET_BLRSTRAT_AND_MAXS( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, KEEP, & NRLNEC, & NRLNEC_ACTIVE, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB ) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS_BASE8, MAXS_BASE_RELAXED8 INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: NRLNEC, & NRLNEC_ACTIVE, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB INTEGER :: PERLU PERLU = KEEP(12) IF (KEEP(201) .EQ. 0) THEN MAXS_BASE8 = NRLNEC ELSE MAXS_BASE8 = NRLNEC_ACTIVE ENDIF BLR_STRAT = 0 IF (KEEP(486).EQ.2) THEN IF (KEEP(489).EQ.1) THEN BLR_STRAT = 2 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNECOOC_if_LR_LUCB ELSE MAXS_BASE8 = NRLNEC_if_LR_LUCB ENDIF ELSE BLR_STRAT = 1 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNEC_ACTIVE ELSE MAXS_BASE8 = NRLNEC_if_LR_LU ENDIF ENDIF ELSE IF (KEEP(486).EQ.3) THEN IF (KEEP(489).EQ.1) THEN BLR_STRAT = 3 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNECOOC_if_LR_LUCB ELSE MAXS_BASE8 = NRLNEC_if_LR_CB ENDIF ENDIF ENDIF IF ( MAXS_BASE8 .GT. 0_8 ) THEN MAXS_BASE_RELAXED8 = & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) ELSE MAXS_BASE_RELAXED8 = 1_8 END IF RETURN END SUBROUTINE ZMUMPS_SET_BLRSTRAT_AND_MAXS SUBROUTINE ZMUMPS_MEM_ALLOWED_SET_MAXS ( MAXS, & BLR_STRAT, OOC_STRAT, MAXS_ESTIM_RELAXED8, & KEEP, KEEP8, MYID, N, NELT, NA, LNA, & NSLAVES, ICNTL38, ICNTL39, IFLAG, IERROR & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(IN) :: BLR_STRAT INTEGER, INTENT(IN) :: OOC_STRAT INTEGER(8), INTENT(IN) :: MAXS_ESTIM_RELAXED8 INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID, N, NELT, NSLAVES, LNA INTEGER, INTENT(IN) :: NA(LNA), ICNTL38, ICNTL39 INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER(8) :: SMALLER_MAXS, UPDATED_DIFF LOGICAL :: EFF, PERLU_ON, SUM_OF_PEAKS INTEGER :: BLR_CASE INTEGER(8) :: TOTAL_BYTES, MEM_ALLOWED_BYTES, & MEM_DISPO_BYTES, MEM_DISPO INTEGER :: TOTAL_MBYTES, PERLU INTEGER(8) :: MEM_DISPO_BYTES_NR, MEM_DISPO_NR, & TOTAL_BYTES_NR INTEGER :: TOTAL_MBYTES_NR INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. PERLU_ON = .TRUE. PERLU = KEEP(12) EFF = .FALSE. SUM_OF_PEAKS = .TRUE. BLR_CASE = 1 MEM_ALLOWED_BYTES = KEEP8(4) CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, & KEEP8(28), KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF, OOC_STRAT, & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) MEM_DISPO_BYTES = MEM_ALLOWED_BYTES-TOTAL_BYTES IF (MEM_DISPO_BYTES.GT.0) THEN MEM_DISPO = MEM_DISPO_BYTES/int(KEEP(35),8) ELSE MEM_DISPO = (MEM_DISPO_BYTES-int(KEEP(35),8)+1)/ & int(KEEP(35),8) ENDIF IF (BLR_STRAT.EQ.0) THEN UPDATED_DIFF = 0_8 ELSE IF (BLR_STRAT.EQ.1) THEN IF (KEEP(464).NE.0) THEN UPDATED_DIFF = int( & dble(KEEP8(36)) * ( 1.0D0 - & dble(ICNTL38)/dble(KEEP(464)) ) & , 8) ELSE UPDATED_DIFF = int ( & -dble(KEEP8(11)-KEEP8(32)) * & dble(ICNTL38) / 1000.0D0 & , 8) ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF (KEEP(464)+KEEP(465).NE.0) THEN UPDATED_DIFF = int( & dble(KEEP8(38)) * ( 1.0D0 - & dble(ICNTL38+ICNTL39)/ & dble(KEEP(464)+KEEP(465)) ) & , 8) ELSE UPDATED_DIFF = int( & -dble(KEEP8(39))* & dble(ICNTL38+ICNTL39)/1000.0D0 & , 8) ENDIF ELSE IF (BLR_STRAT.EQ.3) THEN IF (KEEP(465).NE.0) THEN UPDATED_DIFF = int( & dble(KEEP8(37)) * ( 1.0D0 - & dble(ICNTL39)/dble(KEEP(465)) ) & , 8) ELSE UPDATED_DIFF = int( & -dble(KEEP8(39))* & dble(ICNTL39)/1000.0D0 & , 8) ENDIF ELSE UPDATED_DIFF = 0_8 ENDIF MEM_DISPO = MEM_DISPO + UPDATED_DIFF MAXS = MAXS_ESTIM_RELAXED8 MEM_DISPO_NR = 0_8 IF ( (MEM_DISPO.LT.0) .AND. MAXS_ESTIM_RELAXED8.GT. & (MEM_ALLOWED_BYTES/int(KEEP(35),8)) ) THEN PERLU_ON = .FALSE. CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, & KEEP8(28), KEEP8(30), & NSLAVES, TOTAL_MBYTES_NR, EFF, OOC_STRAT, & BLR_STRAT, PERLU_ON, TOTAL_BYTES_NR, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) MEM_DISPO_BYTES_NR = MEM_ALLOWED_BYTES-TOTAL_BYTES_NR MEM_DISPO_NR = & MEM_DISPO_BYTES_NR/int(KEEP(35),8) & + UPDATED_DIFF IF ( MEM_DISPO_NR.LT.0 ) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE IF (BLR_STRAT.GE.2) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE MEM_DISPO_NR = MEM_DISPO_NR - & (int(KEEP(12),8)/120_8)* & (KEEP8(11)/4_8) IF ( MEM_DISPO_NR.LT.0 ) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE ENDIF ENDIF ENDIF ENDIF MAXS = MAXS_ESTIM_RELAXED8 IF (BLR_STRAT.EQ.0) THEN IF (MEM_DISPO.GT.0) THEN IF (OOC_STRAT.EQ.0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/2_8) ELSE MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/2_8) ENDIF ELSE MAXS = MAXS_ESTIM_RELAXED8 + MEM_DISPO ENDIF ELSE IF (BLR_STRAT.EQ.1) THEN IF ( MEM_DISPO .GT. 0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/10_8) ELSE IF ( MEM_DISPO .LT. 0) THEN IF (OOC_STRAT.EQ.0) THEN SMALLER_MAXS = KEEP8(34) + & int(PERLU,8) * ( KEEP8(34) / 100_8 + 1_8) ELSE SMALLER_MAXS = KEEP8(35) + & int(PERLU,8) * ( KEEP8(35) / 100_8 + 1_8) ENDIF MAXS = max(MAXS_ESTIM_RELAXED8+MEM_DISPO, & SMALLER_MAXS) ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF ( MEM_DISPO .GT. 0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/10_8) ELSE IF ( MEM_DISPO.LT.0) THEN MAXS = max( & MAXS_ESTIM_RELAXED8+MEM_DISPO, & MAXS_ESTIM_RELAXED8) ENDIF ELSE IF (BLR_STRAT.EQ.3) THEN IF ( MEM_DISPO .GT. 0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/4_8) ELSE IF ( MEM_DISPO.LT.0) THEN MAXS = max( & MAXS_ESTIM_RELAXED8+MEM_DISPO, & MAXS_ESTIM_RELAXED8) ENDIF ENDIF IF (MAXS .LE. 0_8) THEN IFLAG=-19 IF (MEM_DISPO.LT.0) THEN CALL MUMPS_SET_IERROR(MEM_DISPO,IERROR) ELSE CALL MUMPS_SET_IERROR(MAXS_ESTIM_RELAXED8-MAXS,IERROR) ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_MEM_ALLOWED_SET_MAXS SUBROUTINE ZMUMPS_MEM_ALLOWED_SET_K75 ( & MAXS, MYID, UNDER_L0_OMP, & N, NELT, NA, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT, & KEEP, KEEP8, IFLAG, IERROR & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MAXS INTEGER, INTENT(IN) :: MYID, N, NELT, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT LOGICAL, INTENT(IN) :: UNDER_L0_OMP INTEGER, INTENT(IN) :: NA(LNA), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER(8) :: KEEP8_23_SAVETMP, TOTAL_BYTES INTEGER :: TOTAL_MBYTES LOGICAL :: PERLU_ON, MEM_EFF_ALLOCATED, EFF INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. KEEP8_23_SAVETMP = KEEP8(23) KEEP8(23) = MAXS PERLU_ON =.TRUE. MEM_EFF_ALLOCATED = .TRUE. EFF = .TRUE. KEEP8(74) = 0_8 KEEP8(63) = 0_8 CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) KEEP8(23) = KEEP8_23_SAVETMP KEEP8(75) = KEEP8(4) - TOTAL_BYTES KEEP8(75) = KEEP8(75)/int(KEEP(35),8) IF (KEEP8(75).LT.0_8) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-KEEP8(75),IERROR) ENDIF RETURN END SUBROUTINE ZMUMPS_MEM_ALLOWED_SET_K75 SUBROUTINE ZMUMPS_L0_COMPUTE_PEAK_ALLOWED ( & MYID, N, & NELT, NA, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT, & KEEP, KEEP8, IFLAG, IERROR & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, N, NELT, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT INTEGER, INTENT(IN) :: NA(LNA), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER(8) :: KEEP8_23_SAVETMP, TOTAL_BYTES, TOTAL_STATIC, & TOTAL_ABOVE, TOTAL_UNDER INTEGER(8) :: EXTRA_MEM, MIN_NRLADU_underL0, & MIN_NRLADU_if_LR_LU_underL0 INTEGER :: TOTAL_MBYTES LOGICAL :: PERLU_ON, MEM_EFF_ALLOCATED, EFF LOGICAL :: UNDER_L0_OMP, SUM_OF_PEAKS INTEGER :: BLR_CASE, ITH INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. KEEP8_23_SAVETMP = KEEP8(23) KEEP8(23) = 0_8 UNDER_L0_OMP = .TRUE. PERLU_ON = .TRUE. MEM_EFF_ALLOCATED = .TRUE. EFF = .TRUE. KEEP8(74) = 0_8 KEEP8(63) = 0_8 CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_STATIC = TOTAL_BYTES KEEP8(23) = KEEP8_23_SAVETMP MEM_EFF_ALLOCATED = .FALSE. EFF = .FALSE. BLR_CASE = 2 SUM_OF_PEAKS = .TRUE. UNDER_L0_OMP = .FALSE. CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_ABOVE = TOTAL_BYTES IF (PERLU_ON.AND.KEEP(201).LE.0) THEN IF (BLR_STRAT.GT.0) THEN MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,1) DO ITH=1, KEEP(400) MIN_NRLADU_if_LR_LU_underL0 = min ( & MIN_NRLADU_if_LR_LU_underL0, I8_L0_OMP(4,ITH) & ) ENDDO EXTRA_MEM = int(KEEP(12),8)* & ( MIN_NRLADU_if_LR_LU_underL0 / 100_8 + 1_8 ) ELSE MIN_NRLADU_underL0 = I8_L0_OMP(1,1) DO ITH=1, KEEP(400) MIN_NRLADU_underL0 = min ( & MIN_NRLADU_underL0, I8_L0_OMP(1,ITH) & ) ENDDO EXTRA_MEM = int(KEEP(12),8)* & ( MIN_NRLADU_underL0 / 100_8 + 1_8 ) ENDIF TOTAL_ABOVE = TOTAL_ABOVE + EXTRA_MEM ENDIF UNDER_L0_OMP = .TRUE. CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_UNDER = TOTAL_BYTES KEEP8(77) = ( max(TOTAL_UNDER,TOTAL_ABOVE) - TOTAL_STATIC ) & / int(KEEP(35),8) RETURN END SUBROUTINE ZMUMPS_L0_COMPUTE_PEAK_ALLOWED SUBROUTINE ZMUMPS_SETMAXTOZERO(M_ARRAY, M_SIZE) IMPLICIT NONE INTEGER M_SIZE DOUBLE PRECISION M_ARRAY(M_SIZE) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0D0) M_ARRAY=ZERO RETURN END SUBROUTINE ZMUMPS_SETMAXTOZERO SUBROUTINE ZMUMPS_COMPUTE_NBROWSinF ( & N, INODE, IFATH, KEEP, & IOLDPS, HF, IW, LIW, & NROWS, NCOLS, NPIV, & NELIM, NFS4FATHER, & NBROWSinF & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, INODE, IFATH INTEGER, INTENT(IN) :: KEEP(500) INTEGER, INTENT(IN) :: IOLDPS, HF, LIW, NROWS, NCOLS INTEGER, INTENT(IN) :: NPIV, NELIM, NFS4FATHER INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT):: NBROWSinF INTEGER :: ShiftFirstRowinFront NBROWSinF = 0 IF ( (KEEP(219).EQ.0).OR.(KEEP(50).NE.2).OR. & (NFS4FATHER.LE.0) ) THEN RETURN ENDIF ShiftFirstRowinFront = NCOLS-NPIV-NELIM-NROWS IF (ShiftFirstRowinFront.EQ.0) THEN NBROWSinF = min(NROWS, NFS4FATHER-NELIM) ELSE IF (ShiftFirstRowinFront.LT.NFS4FATHER-NELIM) THEN NBROWSinF = min(NROWS,NFS4FATHER-NELIM-ShiftFirstRowinFront) ELSE NBROWSinF=0 ENDIF RETURN END SUBROUTINE ZMUMPS_COMPUTE_NBROWSinF SUBROUTINE ZMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, INODE, IFATH INTEGER, INTENT(IN) :: FILS(N), PERM(N), KEEP(500) INTEGER, INTENT(IN) :: IOLDPS, HF, LIW, NFRONT, NASS1 INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT):: ESTIM_NFS4FATHER_ATSON INTEGER :: J, J_LASTFS, IN, NCB, I, IPOS ESTIM_NFS4FATHER_ATSON = 0 IN = IFATH J_LASTFS = IN DO WHILE (IN.GT.0) J_LASTFS = IN IN = FILS(IN) ENDDO NCB = NFRONT-NASS1 IPOS = IOLDPS + HF + NASS1 ESTIM_NFS4FATHER_ATSON = 0 DO I=1, NCB J = IW(IPOS+ESTIM_NFS4FATHER_ATSON) IF (PERM(J).LE.PERM(J_LASTFS)) THEN ESTIM_NFS4FATHER_ATSON = & ESTIM_NFS4FATHER_ATSON+1 ELSE EXIT ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_COMPUTE_ESTIM_NFS4FATHER SUBROUTINE ZMUMPS_COMPUTE_MAXPERCOL( & A,ASIZE,NCOL,NROW, & M_ARRAY,NMAX,PACKED_CB,LROW1) IMPLICIT NONE INTEGER(8) :: ASIZE INTEGER NROW,NCOL,NMAX,LROW1 LOGICAL PACKED_CB COMPLEX(kind=8) A(ASIZE) DOUBLE PRECISION M_ARRAY(NMAX) INTEGER I INTEGER(8):: APOS, J, LROW DOUBLE PRECISION ZERO,TMP PARAMETER (ZERO=0.0D0) DO I=1, NMAX M_ARRAY(I) = ZERO ENDDO APOS = 0_8 IF (PACKED_CB) THEN LROW=int(LROW1,8) ELSE LROW=int(NCOL,8) ENDIF DO I=1,NROW DO J=1_8,int(NMAX,8) TMP = abs(A(APOS+J)) IF(TMP.GT.M_ARRAY(J)) M_ARRAY(J) = TMP ENDDO APOS = APOS + LROW IF (PACKED_CB) LROW=LROW+1_8 ENDDO RETURN END SUBROUTINE ZMUMPS_COMPUTE_MAXPERCOL SUBROUTINE ZMUMPS_SIZE_IN_STRUCT( id, idintr, & NB_INT, NB_CMPLX, NB_CHAR ) USE ZMUMPS_STRUC_DEF, ONLY: ZMUMPS_STRUC USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_INTR_STRUC IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(ZMUMPS_INTR_STRUC) :: idintr INTEGER(8) NB_INT, NB_CMPLX INTEGER(8) NB_REAL,NB_CHAR NB_INT = 0_8 NB_CMPLX = 0_8 NB_REAL = 0_8 NB_CHAR = 0_8 IF (associated(id%IS)) NB_INT=NB_INT+size(id%IS) NB_INT=NB_INT+size(id%KEEP) NB_INT=NB_INT+size(id%ICNTL) NB_INT=NB_INT+size(id%INFO) NB_INT=NB_INT+size(id%INFOG) IF (associated(id%MAPPING)) NB_INT=NB_INT+size(id%MAPPING) IF (associated(id%STEP)) THEN NB_INT=NB_INT+size(id%STEP) ENDIF 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)) THEN NB_INT=NB_INT+size(id%FILS) ENDIF IF (associated(id%FRTPTR)) NB_INT=NB_INT+size(id%FRTPTR) IF (associated(id%FRTELT)) NB_INT=NB_INT+size(id%FRTELT) IF (associated(id%PTRAR)) & NB_INT=NB_INT+size(id%PTRAR)* id%KEEP(10) IF (associated(id%PTR8ARR)) & NB_INT=NB_INT+size(id%PTR8ARR)* id%KEEP(10) IF (associated(id%NINCOLARR)) & NB_INT=NB_INT+size(id%NINCOLARR) IF (associated(id%NINROWARR)) & NB_INT=NB_INT+size(id%NINROWARR) IF (associated(id%PTRDEBARR)) & NB_INT=NB_INT+size(id%PTRDEBARR) 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%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%ELTPROC)) NB_INT=NB_INT+size(id%ELTPROC) IF (associated(id%CANDIDATES)) & NB_INT=NB_INT+size(id%CANDIDATES,DIM=1)* & size(id%CANDIDATES,DIM=2) IF (associated(id%SYM_PERM)) THEN NB_INT=NB_INT+size(id%SYM_PERM) ENDIF IF (associated(id%UNS_PERM)) & NB_INT=NB_INT+size(id%UNS_PERM) IF (associated(id%ISTEP_TO_INIV2)) & NB_INT=NB_INT+size(id%ISTEP_TO_INIV2) IF (associated(id%FUTURE_NIV2)) & NB_INT=NB_INT+size(id%FUTURE_NIV2) IF (associated(id%TAB_POS_IN_PERE)) & NB_INT=NB_INT+size(id%TAB_POS_IN_PERE,DIM=1)* & size(id%TAB_POS_IN_PERE,DIM=2) 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%GLOB2LOC_RHS)) & NB_INT=NB_INT+size(id%GLOB2LOC_RHS) IF(id%GLOB2LOC_SOL_ALLOC.AND.associated(id%GLOB2LOC_SOL)) & NB_INT=NB_INT+size(id%GLOB2LOC_SOL) IF (associated(id%MEM_SUBTREE)) & NB_REAL=NB_REAL+size(id%MEM_SUBTREE)*(id%KEEP(35)/id%KEEP(16)) IF (associated(id%MY_ROOT_SBTR)) & NB_INT=NB_INT+size(id%MY_ROOT_SBTR) IF (associated(id%MY_FIRST_LEAF)) & NB_INT=NB_INT+size(id%MY_FIRST_LEAF) IF (associated(id%MY_NB_LEAF)) NB_INT=NB_INT+size(id%MY_NB_LEAF) IF (associated(id%DEPTH_FIRST)) NB_INT=NB_INT+size(id%DEPTH_FIRST) IF (associated(id%DEPTH_FIRST_SEQ)) & NB_INT=NB_INT+size(id%DEPTH_FIRST_SEQ) IF (associated(id%SBTR_ID)) NB_INT=NB_INT+size(id%SBTR_ID) IF (associated(id%SCHED_DEP)) NB_INT=NB_INT+size(id%SCHED_DEP) IF (associated(id%SCHED_GRP)) NB_INT=NB_INT+size(id%SCHED_GRP) IF (associated(id%SCHED_SBTR)) NB_INT=NB_INT+size(id%SCHED_SBTR) IF (associated(id%CROIX_MANU)) NB_INT=NB_INT+size(id%CROIX_MANU) IF (associated(id%COST_TRAV)) & NB_REAL=NB_REAL+size(id%COST_TRAV)*(id%KEEP(35)/id%KEEP(16)) IF (associated(id%CB_SON_SIZE)) NB_INT=NB_INT+size(id%CB_SON_SIZE) IF (associated(id%OOC_INODE_SEQUENCE)) & NB_INT=NB_INT+size(id%OOC_INODE_SEQUENCE) IF (associated(id%OOC_SIZE_OF_BLOCK)) & NB_INT=NB_INT+size(id%OOC_SIZE_OF_BLOCK)*id%KEEP(10) IF (associated(id%OOC_VADDR)) & NB_INT=NB_INT+size(id%OOC_VADDR,DIM=1)* & size(id%OOC_VADDR,DIM=2)*id%KEEP(10) IF (associated(id%OOC_TOTAL_NB_NODES)) & NB_INT=NB_INT+size(id%OOC_TOTAL_NB_NODES) IF (associated(id%OOC_NB_FILES)) & NB_INT=NB_INT+size(id%OOC_NB_FILES) IF (associated(id%OOC_FILE_NAME_LENGTH)) & NB_INT=NB_INT+size(id%OOC_FILE_NAME_LENGTH) IF (associated(id%PIVNUL_LIST)) NB_INT=NB_INT+size(id%PIVNUL_LIST) IF (associated(id%SUP_PROC)) NB_INT=NB_INT+size(id%SUP_PROC) IF (associated(id%IPTR_WORKING)) & NB_INT=NB_INT+size(id%IPTR_WORKING) IF (associated(id%WORKING)) NB_INT=NB_INT+size(id%WORKING) IF (associated(id%LRGROUPS)) THEN NB_INT=NB_INT+size(id%LRGROUPS) ENDIF IF (associated(id%I4_L0_OMP)) & NB_INT=NB_INT+size(id%I4_L0_OMP,DIM=1)* & size(id%I8_L0_OMP,DIM=2) IF (associated(id%I8_L0_OMP)) & NB_INT=NB_INT+size(id%I8_L0_OMP,DIM=1)* & size(id%I8_L0_OMP,DIM=2)*id%KEEP(10) IF (associated(id%IPOOL_B_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_B_L0_OMP) IF (associated(id%IPOOL_A_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_A_L0_OMP) IF (associated(id%PHYS_L0_OMP)) & NB_INT=NB_INT+size(id%PHYS_L0_OMP) IF (associated(id%VIRT_L0_OMP)) & NB_INT=NB_INT+size(id%VIRT_L0_OMP) IF (associated(id%PERM_L0_OMP)) & NB_INT=NB_INT+size(id%PERM_L0_OMP) IF (associated(id%PTR_LEAFS_L0_OMP)) & NB_INT=NB_INT+size(id%PTR_LEAFS_L0_OMP) IF (associated(id%L0_OMP_MAPPING)) & NB_INT=NB_INT+size(id%L0_OMP_MAPPING) IF (associated(id%SINGULAR_VALUES)) & NB_REAL=NB_REAL+size(id%SINGULAR_VALUES) IF (associated(idintr%root%RG2L)) THEN NB_INT=NB_INT+size(idintr%root%RG2L) ENDIF IF (associated(idintr%root%IPIV)) & NB_INT=NB_INT+size(idintr%root%IPIV) IF (associated(idintr%roota%RHS_CNTR_MASTER_ROOT)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%RHS_CNTR_MASTER_ROOT) IF (associated(idintr%roota%SCHUR_POINTER)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%SCHUR_POINTER) IF (associated(idintr%roota%QR_TAU)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%QR_TAU) IF (associated(idintr%roota%RHS_ROOT)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%RHS_ROOT) IF (associated(idintr%roota%SVD_U)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%SVD_U) IF (associated(idintr%roota%SVD_VT)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%SVD_VT) IF (associated(idintr%roota%SINGULAR_VALUES)) & NB_REAL=NB_REAL+size(idintr%roota%SINGULAR_VALUES) IF (associated(id%RHSINTR)) NB_CMPLX = NB_CMPLX + id%KEEP8(25) IF (associated(id%S)) NB_CMPLX=NB_CMPLX+id%KEEP8(23) IF (associated(id%COLSCA).AND.(id%KEEP(52).NE.-1)) & NB_REAL=NB_REAL+size(id%COLSCA) IF (associated(id%ROWSCA).AND.(id%KEEP(52).NE.-1)) & NB_REAL=NB_REAL+size(id%ROWSCA) IF (associated(id%ROWSCA_loc)) & NB_REAL=NB_REAL+size(id%ROWSCA_loc) IF (associated(id%COLSCA_loc).AND.id%KEEP(50).EQ.0) & NB_REAL=NB_REAL+size(id%COLSCA_loc) NB_REAL=NB_REAL+size(id%CNTL) NB_REAL=NB_REAL+size(id%RINFO) NB_REAL=NB_REAL+size(id%RINFOG) NB_REAL=NB_REAL+size(id%DKEEP) NB_CHAR=NB_CHAR+len(id%VERSION_NUMBER) NB_CHAR=NB_CHAR+len(id%OOC_TMPDIR) NB_CHAR=NB_CHAR+len(id%OOC_PREFIX) NB_CHAR=NB_CHAR+len(id%WRITE_PROBLEM) NB_CHAR=NB_CHAR+len(id%SAVE_DIR) NB_CHAR=NB_CHAR+len(id%SAVE_PREFIX) NB_CMPLX = NB_CMPLX + NB_REAL/2_8 RETURN END SUBROUTINE ZMUMPS_SIZE_IN_STRUCT SUBROUTINE ZMUMPS_COPYI8SIZE(N8,SRC,DEST) IMPLICIT NONE INTEGER(8) :: N8 COMPLEX(kind=8), intent(in) :: SRC(N8) COMPLEX(kind=8), intent(out) :: DEST(N8) INTEGER(8) :: SHIFT8, HUG8 INTEGER :: I, I4SIZE IF(int(huge(I4SIZE),8) .EQ. int(huge(HUG8),8)) THEN CALL zcopy(int(N8), SRC(1), 1, DEST(1), 1) ELSE HUG8=int(huge(I4SIZE),8) DO I = 1, int(( N8 + HUG8 - 1_8 ) / HUG8) SHIFT8 = 1_8 + int(I-1,8) * HUG8 I4SIZE = int(min(HUG8, N8-SHIFT8+1_8)) CALL zcopy(I4SIZE, SRC(SHIFT8), 1, DEST(SHIFT8), 1) ENDDO END IF RETURN END SUBROUTINE ZMUMPS_COPYI8SIZE SUBROUTINE ZMUMPS_SET_TMP_PTR( THE_ADDRESS, THE_SIZE8 ) USE ZMUMPS_STATIC_PTR_M INTEGER(8), INTENT(IN) :: THE_SIZE8 COMPLEX(kind=8), INTENT(IN) :: THE_ADDRESS(THE_SIZE8) CALL ZMUMPS_SET_STATIC_PTR(THE_ADDRESS(1:THE_SIZE8)) RETURN END SUBROUTINE ZMUMPS_SET_TMP_PTR SUBROUTINE ZMUMPS_OOC_IO_LU_PANEL_I & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) USE ZMUMPS_OOC, ONLY : IO_BLOCK, & ZMUMPS_OOC_IO_LU_PANEL IMPLICIT NONE TYPE(IO_BLOCK), INTENT(INOUT):: MonBloc INTEGER(8) :: LAFAC INTEGER, INTENT(IN) :: STRAT, LIWFAC, MYID, TYPEFile INTEGER, INTENT(INOUT) :: IW(0:LIWFAC-1) COMPLEX(kind=8), INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LNextPiv2beWritten, UNextPiv2beWritten INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) RETURN END SUBROUTINE ZMUMPS_OOC_IO_LU_PANEL_I SUBROUTINE ZMUMPS_BUF_SEND_CONTRIB_TYPE3_I ( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) USE ZMUMPS_BUF, ONLY : ZMUMPS_BUF_SEND_CONTRIB_TYPE3 IMPLICIT NONE INTEGER N, ISON, NBCOL_SON, NBROW_SON, NSUBSET_ROW, NSUBSET_COL INTEGER NPROW, NPCOL, MBLOCK, NBLOCK, LD_SON INTEGER BBPCBP INTEGER PDEST, TAG, COMM, IERR INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER :: RG2L(N) INTEGER NSUPROW, NSUPCOL INTEGER(8), INTENT(IN) :: TABSIZE INTEGER SIZE_PACK INTEGER KEEP(500) COMPLEX(kind=8) VAL_SON( LD_SON, * ), TAB(*) LOGICAL TRANSP INTEGER N_ALREADY_SENT INTEGER NELIM_ROOT, NELIM_ROW, NELIM_COL CALL ZMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) RETURN END SUBROUTINE ZMUMPS_BUF_SEND_CONTRIB_TYPE3_I SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING_I( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, sizeBEGS_BLR_L, & BEGS_BLR_U, sizeBEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, NB_BLR_U, & NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) USE ZMUMPS_LR_TYPE, ONLY : LRB_TYPE USE ZMUMPS_FAC_LR, ONLY : ZMUMPS_BLR_UPDATE_TRAILING INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, & CURRENT_BLR, & NELIM, NIV, SYM, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT COMPLEX(kind=8), intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_U(NB_BLR_U-CURRENT_BLR) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER :: sizeBEGS_BLR_L, sizeBEGS_BLR_U INTEGER :: BEGS_BLR_L(sizeBEGS_BLR_L) INTEGER :: BEGS_BLR_U(sizeBEGS_BLR_U) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS CALL ZMUMPS_BLR_UPDATE_TRAILING( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) RETURN END SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING_I SUBROUTINE ZMUMPS_COMPRESS_CB_I(A_PTR, LA_PTR, POSELT, LDA, & BEGS_BLR, sizeBEGS_BLR, BEGS_BLR_U, sizeBEGS_BLR_U, & NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY, & NELIM, & NBROWSinF & ) USE ZMUMPS_LR_TYPE, ONLY : LRB_TYPE USE ZMUMPS_FAC_LR, ONLY : ZMUMPS_COMPRESS_CB IMPLICIT NONE INTEGER(8), intent(in) :: LA_PTR COMPLEX(kind=8), intent(inout) :: A_PTR(LA_PTR) INTEGER(8), intent(in) :: POSELT INTEGER :: sizeBEGS_BLR, sizeBEGS_BLR_U INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & KPERCENT, TOL_OPT, LWORK, OMP_NUM INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: CB_LRB(NB_ROWS,NB_COLS) INTEGER :: BEGS_BLR(sizeBEGS_BLR), BEGS_BLR_U(sizeBEGS_BLR_U) DOUBLE PRECISION :: RWORK(2*MAXI_CLUSTER*OMP_NUM) COMPLEX(kind=8) :: BLOCK(MAXI_CLUSTER, MAXI_CLUSTER*OMP_NUM) COMPLEX(kind=8) :: WORK(LWORK*OMP_NUM), TAU(MAXI_CLUSTER*OMP_NUM) INTEGER :: JPVT(MAXI_CLUSTER*OMP_NUM) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500) DOUBLE PRECISION :: M_ARRAY(max(NFS4FATHER,1)) INTEGER, intent(in) :: NELIM INTEGER, intent(in) :: NBROWSinF CALL ZMUMPS_COMPRESS_CB(A_PTR, LA_PTR, POSELT, LDA, & BEGS_BLR, BEGS_BLR_U, & NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY=M_ARRAY, & NELIM=NELIM, & NBROWSinF=NBROWSinF & ) RETURN END SUBROUTINE ZMUMPS_COMPRESS_CB_I SUBROUTINE ZMUMPS_COMPRESS_PANEL_I_NOOPT( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, sizeBEGS_BLR, & NB_BLR, TOLEPS, TOL_OPT, K458, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8, & OMP_NUM & ) USE ZMUMPS_LR_TYPE, ONLY : LRB_TYPE USE ZMUMPS_FAC_LR, ONLY : ZMUMPS_COMPRESS_PANEL IMPLICIT NONE INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV INTEGER, intent(in) :: OMP_NUM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER :: MAXI_CLUSTER DOUBLE PRECISION :: RWORK(2*MAXI_CLUSTER*OMP_NUM) COMPLEX(kind=8) :: BLOCK(MAXI_CLUSTER,MAXI_CLUSTER*OMP_NUM) COMPLEX(kind=8) :: WORK(LWORK*OMP_NUM) COMPLEX(kind=8) :: TAU(MAXI_CLUSTER*OMP_NUM) INTEGER :: JPVT(MAXI_CLUSTER*OMP_NUM) INTEGER :: sizeBEGS_BLR INTEGER :: BEGS_BLR(sizeBEGS_BLR) INTEGER(8) :: KEEP8(150) INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, & K458, K473, TOL_OPT LOGICAL, intent(in) :: LBANDSLAVE INTEGER :: LWORK, NELIM DOUBLE PRECISION,intent(in) :: TOLEPS CHARACTER(len=1) :: DIR CALL ZMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K458, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8 & ) RETURN END SUBROUTINE ZMUMPS_COMPRESS_PANEL_I_NOOPT SUBROUTINE ZMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & DECOMP_TIMER) USE ZMUMPS_LR_TYPE, ONLY : LRB_TYPE USE ZMUMPS_FAC_LR, ONLY : ZMUMPS_DECOMPRESS_PANEL IMPLICIT NONE INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: COPY_DENSE_BLOCKS INTEGER, intent(in) :: NB_BLR, CURRENT_BLR INTEGER, intent(in) :: BEGS_BLR_DIAG, & BEGS_BLR_FIRST_OFFDIAG TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) CHARACTER(len=1) :: DIR INTEGER, intent(in) :: DECOMP_TIMER INTEGER, intent(in) :: LDA11, LDA21 CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & DECOMP_TIMER) RETURN END SUBROUTINE ZMUMPS_DECOMPRESS_PANEL_I_NOOPT SUBROUTINE ZMUMPS_BLR_UPD_NELIM_VAR_L_I( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, sizeBEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) USE ZMUMPS_LR_TYPE, ONLY : LRB_TYPE USE ZMUMPS_FAC_LR, ONLY : ZMUMPS_BLR_UPD_NELIM_VAR_L IMPLICIT NONE INTEGER(8), intent(in) :: LA_U, LA_L INTEGER(8), intent(in) :: UPOS, LPOS INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR, & NELIM, FIRST_BLOCK CHARACTER(len=1),INTENT(IN) :: UTRANS INTEGER, intent(inout) :: IFLAG, IERROR COMPLEX(kind=8), TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER, INTENT(in) :: sizeBEGS_BLR_L INTEGER :: BEGS_BLR_L(sizeBEGS_BLR_L) CALL ZMUMPS_BLR_UPD_NELIM_VAR_L( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) RETURN END SUBROUTINE ZMUMPS_BLR_UPD_NELIM_VAR_L_I SUBROUTINE ZMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, JBEG_BLOCK, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, sizeBEGS_BLR_LM, & NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, sizeBEGS_BLR_LS, & NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, OMP_NUM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) USE ZMUMPS_LR_TYPE, ONLY : LRB_TYPE USE ZMUMPS_FAC_LR, ONLY : ZMUMPS_BLR_SLV_UPD_TRAIL_LDLT IMPLICIT NONE INTEGER(8), intent(in) :: LA, LA_BLOCFACTO COMPLEX(kind=8), intent(inout) :: A(LA) COMPLEX(kind=8), intent(in) :: A_BLOCFACTO(LA_BLOCFACTO) INTEGER(8), intent(in) :: POSELT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), TOL_OPT, & MAXI_CLUSTER, OMP_NUM, LD_BLOCFACTO, & JBEG_BLOCK INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS, & ISHIFT_LM, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS COMPLEX(kind=8), INTENT(INOUT) :: & BLOCK(MAXI_CLUSTER,MAXI_CLUSTER*OMP_NUM) INTEGER :: sizeBEGS_BLR_LM, sizeBEGS_BLR_LS INTEGER :: BEGS_BLR_LM(sizeBEGS_BLR_LM) INTEGER :: BEGS_BLR_LS(sizeBEGS_BLR_LS) TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM), & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS CALL ZMUMPS_BLR_SLV_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, JBEG_BLOCK, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) RETURN END SUBROUTINE ZMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I SUBROUTINE ZMUMPS_SET_INNERBLOCKSIZE( SIZE_INNER, & NASS, KEEP ) IMPLICIT NONE INTEGER :: SIZE_INNER, NASS, KEEP(500) IF (NASS.LT.KEEP(4)) THEN SIZE_INNER = NASS ELSE IF (NASS .GT. KEEP(3)) THEN SIZE_INNER = min( KEEP(6), NASS ) ELSE SIZE_INNER = min( KEEP(5), NASS ) ENDIF RETURN END SUBROUTINE ZMUMPS_SET_INNERBLOCKSIZE SUBROUTINE ZMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) DOUBLE PRECISION :: OPELI INTEGER(8) :: KEEP8( 150 ) CALL MUMPS_SETDVAL_ADDR_C(OPELI, KEEP8(84)) RETURN END SUBROUTINE ZMUMPS_UPDATE_PROGRESS MUMPS_5.8.1/src/sfac_par_m.F0000664000175000017500000015246615042446437015455 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_PAR_M CONTAINS SUBROUTINE SMUMPS_FAC_PAR(N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NULLNEGPV, NB22T1, NB22T2, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & PTRIST, PTRAST, PIMASTER, PAMASTER, PTRARW, PTRAIW, PTR8ARR, & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & L0_OMP_MAPPING, LL0_OMP_MAPPING, & MUMPS_TPS_ARR, SMUMPS_TPS_ARR, LTPS_ARR, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & NBROOT_UNDER_L0, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8, PROCNODE_STEPS, & SLAVEF,MYID, COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & INTARR, DBLARR, root, roota, PERM, NELT, FRTPTR, FRTELT, LPTRAR, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, & DKEEP, PIVNUL_LIST_STRUCT, LRGROUPS ) !$ USE OMP_LIB USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : & SMUMPS_DM_FREEALLDYNAMICCB USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_TEST USE MUMPS_LOAD USE SMUMPS_OOC, ONLY: SMUMPS_OOC_CLEAN_PENDING, & IO_BLOCK, & SMUMPS_OOC_FORCE_WRT_BUF_PANEL, & SMUMPS_NEW_FACTOR, & SMUMPS_OOC_IO_LU_PANEL, & SMUMPS_FORCE_WRITE_BUF USE MUMPS_OOC_COMMON, ONLY: TYPEF_L, STRAT_WRITE_MAX USE SMUMPS_FAC_ASM_MASTER_M USE SMUMPS_FAC_ASM_MASTER_ELT_M USE SMUMPS_FAC1_LDLT_M USE SMUMPS_FAC2_LDLT_M USE SMUMPS_FAC1_LU_M USE SMUMPS_FAC2_LU_M USE OMP_LIB USE MUMPS_TPS_M USE SMUMPS_TPS_M USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE SMUMPS_INTR_TYPES, ONLY : SMUMPS_ROOT_STRUC USE MUMPS_PIVNUL_MOD IMPLICIT NONE TYPE (MUMPS_ROOT_STRUC) :: root TYPE (SMUMPS_ROOT_STRUC) :: roota INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80) DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI INTEGER, INTENT(INOUT) :: NELVA, COMP INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV, & NULLNEGPV INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP REAL, INTENT(INOUT) :: DET_MANT INTEGER(8) :: LA REAL, TARGET :: A(LA) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER LPOOL INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) REAL :: RHS_MUMPS(KEEP8(85)) INTEGER IW(LIW), NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST(KEEP(28)), PERM(N) INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IPOOL(LPOOL) INTEGER NE(KEEP(28)) REAL RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU INTEGER IWPOS, LEAF, NBROOT, NBRTOT INTEGER, INTENT(in) :: NBROOT_UNDER_L0 INTEGER COMM_LOAD, ASS_IRECV REAL UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) REAL DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) LOGICAL IS_ISOLATED_NODE TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT REAL DKEEP(230) INTEGER LRGROUPS(KEEP(280)) INTEGER, INTENT( IN ) :: LTPS_ARR TYPE (MUMPS_TPS_T), TARGET :: MUMPS_TPS_ARR( LTPS_ARR ) TYPE (SMUMPS_TPS_T), TARGET :: SMUMPS_TPS_ARR( LTPS_ARR ) INTEGER, INTENT( IN ) :: LL0_OMP_MAPPING INTEGER, INTENT( IN ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 INTEGER INODE INTEGER IWPOSCB INTEGER FPERE, TYPEF INTEGER MP, LP, DUMMY(1) INTEGER NBFIN, NBROOT_TRAITEES INTEGER NFRONT, IOLDPS 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 !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 INTEGER LIWK_RR, PHASE, MBLOCK, NBLOCK INTEGER(8) :: LWK_RR INTEGER(8) :: I8 INTEGER I, K, KEEP17_LU INTEGER NOFFNEGPV_ROOT, NTOTPV_ROOT, NB22T1_ROOT, NBTINY_ROOT, & NULLNEGPV_ROOT, & DET_EXP_ROOT, DET_SIGN_ROOT, & LRecord, Header_ROOT(5) REAL DET_MANT_ROOT REAL DKEEP_SAVE(230) REAL, DIMENSION(:), POINTER :: A_ROOT_SAVE LOGICAL :: IS_A_ROOT_SAVE_ALLOCATED INTEGER, DIMENSION(:), ALLOCATABLE :: RECORD_ROOT INTEGER KEEP_SAVE(500) INTEGER(8) KEEP8_SAVE(150) EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE LOGICAL MUMPS_INSSARBR EXTERNAL MUMPS_INSSARBR LOGICAL SMUMPS_POOL_EMPTY EXTERNAL SMUMPS_POOL_EMPTY, SMUMPS_EXTRACT_POOL LOGICAL STACK_RIGHT_AUTHORIZED INTEGER, EXTERNAL :: MUMPS_NUMROC INTEGER JOBASS, ETATASS INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY INTEGER(8) :: ITMP8 TYPE(IO_BLOCK) :: MonBloc INCLUDE 'mumps_headers.h' INTEGER MPA DOUBLE PRECISION OPLAST_PRINTED DOUBLE PRECISION :: ROOTTIME INTEGER:: ITH DOUBLE PRECISION :: DUMMY_FLOP_ESTIM_ACC DUMMY_FLOP_ESTIM_ACC = 0.0d0 ITLOC(1:N+KEEP(253)) =0 ASS_IRECV = MPI_REQUEST_NULL MP = ICNTL(2) LP = ICNTL(1) IWPOSCB = LIW NULLIFY(BUFRX) IS_BUFRX_ALLOCATED = .FALSE. KEEP(143) = -1 KEEP17_LU = -1 NULLIFY(A_ROOT_SAVE) IS_A_ROOT_SAVE_ALLOCATED = .FALSE. IF ( INFO(1) .LT. 0 ) THEN GOTO 640 ENDIF OPLAST_PRINTED = DONE MPA = ICNTL(2) IF (ICNTL(4).LT.2) MPA=0 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) CALL SMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) STACK_RIGHT_AUTHORIZED = .TRUE. CALL SMUMPS_ALLOC_CB( .FALSE., 0_8, & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, DKEEP, & IW, LIW, A, LA, LRLU, IPTRLU, IWPOS, IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, LRLUS, KEEP8(67), & INFO(1), INFO(2) & ) JOBASS = 0 ETATASS = 0 NBFIN = NBRTOT NBROOT_TRAITEES = 0 KEEP(121)=0 IF ( KEEP(38).NE.0 ) THEN IF (root%yes) THEN CALL SMUMPS_ROOT_ALLOC_STATIC( & root, roota, KEEP(38), N, IW, LIW, & A, LA, & FILS, DAD, MYID_NODES, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, INFO(1), KEEP,KEEP8, DKEEP, INFO(2) ) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 635 END IF IF (KEEP(400).GT.0) THEN NBROOT_TRAITEES = NBROOT_UNDER_L0 IF (NBROOT_TRAITEES .GT.0) THEN IF (NBROOT_TRAITEES.EQ.NBROOT) THEN NBFIN = NBFIN - NBROOT IF (SLAVEF .GT. 1) THEN CALL SMUMPS_MCAST2( NBROOT, 1, MPI_INTEGER, & MYID_NODES, COMM_NODES, RACINE, SLAVEF, KEEP ) ENDIF ENDIF ENDIF IF (NBFIN .EQ. 0) GOTO 640 ENDIF KEEP(429)=0 20 CONTINUE CALL SMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) CALL MUMPS_STOP_ON_USER_REQUEST( KEEP, KEEP8, ICNTL, INFO, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 635 NIV1_FLAG=0 SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .FALSE. IF ( SLAVEF .GT. 1 ) THEN CALL SMUMPS_TRY_RECVTREAT( & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, & MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, & COMP, INFO(1), INFO(2), COMM_NODES, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, & root, roota, OPASS, OPELI, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED & , LRGROUPS & ) CALL MUMPS_LOAD_RECV_MSGS(COMM_LOAD) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (MESSAGE_RECEIVED) THEN IF ( INFO(1) .LT. 0 ) GO TO 640 IF ( NBFIN .eq. 0 ) GOTO 640 ELSE IF ( .NOT. SMUMPS_POOL_EMPTY( IPOOL, LPOOL) )THEN CALL SMUMPS_EXTRACT_POOL( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, STEP, INODE, KEEP,KEEP8, MYID_NODES, ND, & (.NOT. STACK_RIGHT_AUTHORIZED) ) STACK_RIGHT_AUTHORIZED = .TRUE. IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF IF (KEEP(47).EQ.4) THEN IF(INODE.GT.0.AND.INODE.LE.N)THEN IF((NE(STEP(INODE)).EQ.0).AND. & (FRERE(STEP(INODE)).EQ.0))THEN IS_ISOLATED_NODE=.TRUE. ELSE IS_ISOLATED_NODE=.FALSE. ENDIF ENDIF CALL MUMPS_LOAD_SBTR_UPD_NEW_POOL( & IS_ISOLATED_NODE,INODE,IPOOL,LPOOL, & MYID_NODES,SLAVEF,COMM_LOAD,KEEP,KEEP8) ENDIF IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. & ( KEEP(47) == 4 )).OR. & (KEEP(80) == 1 .AND. KEEP(47) .GE. 1)) THEN CALL MUMPS_UPPER_PREDICT(INODE,STEP,KEEP(28), & PROCNODE_STEPS,FRERE,ND,COMM_LOAD,SLAVEF, & MYID_NODES,KEEP,KEEP8,N) END IF GOTO 30 ELSE CALL MUMPS_BUF_TEST() ENDIF ENDIF GO TO 20 30 CONTINUE IF ( INODE .LT. 0 ) THEN INODE = -INODE FPERE = DAD(STEP(INODE)) GOTO 130 ELSE IF (INODE.GT.N) THEN INODE = INODE - N IF (INODE.EQ.KEEP(38)) THEN NBROOT_TRAITEES = NBROOT_TRAITEES + 1 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN NBFIN = NBFIN - NBROOT IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL SMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID_NODES, & COMM_NODES, RACINE, SLAVEF, KEEP ) END IF ENDIF IF (NBFIN.EQ.0) GOTO 640 GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (TYPE.EQ.1) GOTO 100 FPERE = DAD(STEP(INODE)) AVOID_DELAYED = ( (FPERE .eq. KEEP(20) .OR. FPERE .eq. KEEP(38)) & .AND. KEEP(60).ne.0 ) IF ( KEEP(50) .eq. 0 ) THEN CALL SMUMPS_FAC2_LU( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, & NOFFNEGPV, NTOTPV, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, & NBFIN,LEAF, INFO(1), INFO(2), IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_STEPS,PERM,PROCNODE_STEPS, & root, roota, OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & 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_STRUCT & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) ELSE CALL SMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, & NOFFNEGPV, NULLNEGPV, NTOTPV, & NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, & NBFIN,LEAF, INFO(1), INFO(2), IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_STEPS,PERM,PROCNODE_STEPS, & root, roota, OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & 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_STRUCT & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF ( IW( PTLUST(STEP(INODE)) + KEEP(IXSZ) + 5 ) .GT. 1 ) THEN GOTO 20 END IF END IF GOTO 130 ENDIF IF (INODE.EQ.KEEP(38)) THEN CALL SMUMPS_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, & root, roota, FRERE, & INODE, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, COMP, & INFO(1), INFO(2), COMM_NODES, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID_NODES, SLAVEF, & & OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP, ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (TYPE.EQ.1) THEN IF (KEEP(55).NE.0) THEN CALL SMUMPS_FAC_ASM_NIV1_ELT( COMM_LOAD, ASS_IRECV, & UU, NELT, FRTPTR, FRTELT, & N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,roota,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP, & INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS,PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & , MUMPS_TPS_ARR, SMUMPS_TPS_ARR, & L0_OMP_MAPPING & ) ELSE JOBASS = 0 CALL SMUMPS_FAC_ASM_NIV1(COMM_LOAD, ASS_IRECV, & UU, N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,roota,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP, INTARR,KEEP8(27), & DBLARR,KEEP8(26), & NSTK_STEPS,PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, JOBASS,ETATASS & , LRGROUPS & , MUMPS_TPS_ARR, SMUMPS_TPS_ARR, & L0_OMP_MAPPING & ) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF ( INFO(1) .LT. 0 ) GOTO 640 IF ((IW(PTLUST(STEP(INODE))+XXNBPR).GT.0).OR.(SON_LEVEL2)) THEN GOTO 20 ENDIF ELSE IF ( KEEP(55) .eq. 0 ) THEN CALL SMUMPS_FAC_ASM_NIV2(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, & INFO(1), & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, & root, roota, OPASS, OPELI, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) ELSE CALL SMUMPS_FAC_ASM_NIV2_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, INFO(1), & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, & root, roota, OPASS, OPELI, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) END IF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 640 GOTO 20 ENDIF 100 CONTINUE FPERE = DAD(STEP(INODE)) IF ( INODE .eq. KEEP(20) ) THEN POSELT = PTRAST(STEP(INODE)) IF (PTRFAC(STEP(INODE)).NE.POSELT) THEN WRITE(*,*) "ERROR 2 in SMUMPS_FAC_PAR", POSELT GOTO 635 ENDIF IF (KEEP(118).GE.40) THEN IOLDPS = PTLUST(STEP(INODE)) LRecord = IW(IOLDPS+XXI) IF (allocated(RECORD_ROOT)) DEALLOCATE(RECORD_ROOT) ALLOCATE(RECORD_ROOT(LRecord), stat=IERR) IF (IERR.GT.0) THEN INFO(1)= -13 INFO(2)= LRecord IF (LP > 0) & write(LP,*) "ERROR allocate RECORD_ROOT" GOTO 635 ENDIF RECORD_ROOT(1:LRecord) = IW(IOLDPS:IOLDPS+LRecord-1) ENDIF CALL SMUMPS_CHANGE_HEADER & ( IW(PTLUST(STEP(INODE))+KEEP(IXSZ)), KEEP(253) ) IF (KEEP(118).GE.40) THEN Header_ROOT(1:5) = IW(PTLUST(STEP(INODE))+KEEP(IXSZ): & PTLUST(STEP(INODE))+KEEP(IXSZ)+4) ENDIF GOTO 200 END IF POSELT = PTRAST(STEP(INODE)) IOLDPS = PTLUST(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_FAC1_LU ( & N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFNEGPV, NTOTPV, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & KEEP,KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) GOTO 635 ELSE IW( IOLDPS+4+KEEP(IXSZ) ) = 1 CALL SMUMPS_FAC1_LDLT( N, INODE, & IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFNEGPV, NULLNEGPV, NTOTPV, & NB22T1, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, & ETATASS, & DKEEP(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) GOTO 635 IW( IOLDPS+4+KEEP(IXSZ) ) = STEP(INODE) ENDIF JOBASS = ETATASS IF (JOBASS.EQ.1) THEN CALL SMUMPS_FAC_ASM_NIV1(COMM_LOAD, ASS_IRECV, & UU, N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,roota,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, & PTRARW,PTRAIW,PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & JOBASS,ETATASS & , LRGROUPS & ) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 635 130 CONTINUE TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF ( FPERE .NE. 0 ) THEN TYPEF = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(FPERE)),KEEP(199)) ELSE TYPEF = -9999 END IF CALL SMUMPS_FAC_STACK( COMM_LOAD, ASS_IRECV, & N,INODE,TYPE,TYPEF,LA,IW,LIW,A, & INFO(1),INFO(2),OPELI,NELVA,NMAXNPIV, & PTRIST,PTLUST,PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NE, POSFAC,LRLU, LRLUS,KEEP8(67), & IPTRLU,ICNTL,KEEP,KEEP8,DKEEP,COMP,IWPOS,IWPOSCB, & PROCNODE_STEPS,SLAVEF,FPERE,COMM_NODES,MYID_NODES, & IPOOL, LPOOL, LEAF, & NSTK_STEPS, PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, & root, roota, & OPASS, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ,DUMMY_FLOP_ESTIM_ACC & ) IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 640 200 CONTINUE IF ( INODE .eq. KEEP(38) ) THEN WRITE(*,*) 'Error .. in SMUMPS_FAC_PAR: ', & ' INODE == KEEP(38)' CALL MUMPS_ABORT() END IF IF ( FPERE.EQ.0 ) THEN NBROOT_TRAITEES = NBROOT_TRAITEES + 1 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN IF (KEEP(201).EQ.1) THEN CALL SMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF ( KEEP(201).EQ.2) THEN CALL SMUMPS_FORCE_WRITE_BUF(IERR) ENDIF NBFIN = NBFIN - NBROOT IF ( NBFIN .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in SMUMPS_FAC_PAR: ', & ' NBFIN=', NBFIN CALL MUMPS_ABORT() END IF IF ( NBROOT .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in SMUMPS_FAC_PAR: ', & ' NBROOT=', NBROOT CALL MUMPS_ABORT() END IF IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL SMUMPS_MCAST2( DUMMY(1), 1, MPI_INTEGER, & MYID_NODES, COMM_NODES, RACINE, SLAVEF, KEEP ) END IF ENDIF IF (NBFIN.EQ.0)THEN GOTO 640 ENDIF ELSEIF ( FPERE.NE.KEEP(38) .AND. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID_NODES ) THEN NSTK_STEPS(STEP(FPERE)) = NSTK_STEPS(STEP(FPERE))-1 IF ( NSTK_STEPS( STEP( FPERE )).EQ.0) THEN IF (KEEP(234).NE.0 .AND. & MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199))) & THEN STACK_RIGHT_AUTHORIZED = .FALSE. ENDIF CALL SMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( FPERE, N, PROCNODE_STEPS,KEEP(199), & ND, FILS, FRERE, STEP, PIMASTER, KEEP(28), & KEEP(50), KEEP(253), FLOP1, & IW, LIW, KEEP(IXSZ) ) IF (FPERE.NE.KEEP(20)) & CALL MUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ENDIF GO TO 20 635 CONTINUE IF (allocated(RECORD_ROOT)) DEALLOCATE(RECORD_ROOT) CALL SMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP ) 640 CONTINUE CALL SMUMPS_CANCEL_IRECV( INFO(1), & KEEP, & ASS_IRECV, BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, & MYID_NODES, SLAVEF) CALL MUMPS_CLEAN_PENDING( INFO(1), KEEP, & BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, & .TRUE., & .TRUE.) CALL MPI_BARRIER( COMM_NODES, IERR ) IF (INFO(1) .LT. 0) THEN CALL SMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & .FALSE. ) IF ( KEEP(400) .GT. 0 & ) THEN !$OMP PARALLEL DO SCHEDULE(STATIC,1) DO ITH = 1, KEEP(400) IF (associated(MUMPS_TPS_ARR(ITH)%IW)) THEN CALL SMUMPS_DM_FREEALLDYNAMICCB_I( MYID, N, SLAVEF, & KEEP, KEEP8, & MUMPS_TPS_ARR(ITH)%IW(1), MUMPS_TPS_ARR(ITH)%LIW, & MUMPS_TPS_ARR(ITH)%IWPOSCB, MUMPS_TPS_ARR(ITH)%IWPOS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & .TRUE. ) ENDIF ENDDO !$OMP END PARALLEL DO ENDIF ENDIF IF ( INFO(1) .GE. 0 ) THEN IF( KEEP(38) .NE. 0 .OR. KEEP(20).NE.0) THEN CALL MUMPS_SECDEB(ROOTTIME) MASTER_ROOT = MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(max(KEEP(38),KEEP(20)))), & KEEP(199)) ROOT_OWNER = (MASTER_ROOT .EQ. MYID_NODES) IF ( KEEP(38) .NE. 0 ) THEN IF (KEEP(60).EQ.0) THEN IOLDPS = PTLUST(STEP(KEEP(38))) LOCAL_M = IW(IOLDPS+2+KEEP(IXSZ)) LOCAL_N = IW(IOLDPS+1+KEEP(IXSZ)) ELSE IOLDPS = -999 LOCAL_M = root%SCHUR_MLOC LOCAL_N = root%SCHUR_NLOC ENDIF ITMP8 = int(LOCAL_M,8)*int(LOCAL_N,8) LBUFRX = min(int(root%MBLOCK,8)*int(root%NBLOCK,8), & int(root%TOT_ROOT_SIZE,8)*int(root%TOT_ROOT_SIZE,8) ) IS_BUFRX_ALLOCATED = .FALSE. IF ( LRLU .GT. LBUFRX ) THEN BUFRX => A(POSFAC:POSFAC+LRLU-1_8) LBUFRX=LRLU ELSE ALLOCATE( BUFRX( LBUFRX ), stat = IERR ) IF (IERR.gt.0) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR(LBUFRX, INFO(2) ) IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before SMUMPS_FACTO_ROOT', LBUFRX ELSE IS_BUFRX_ALLOCATED = .TRUE. ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL, INFO, & COMM_NODES, MYID_NODES ) IF (INFO(1).GE.0) THEN CALL SMUMPS_FACTO_ROOT( & MPA, MYID_NODES, MASTER_ROOT, & root, roota, N, KEEP(38), & COMM_NODES, IW, LIW, IWPOS + 1, & A, LA, PTRAST, PTLUST, PTRFAC, STEP, & INFO(1), KEEP(50), KEEP(19), & BUFRX(1), LBUFRX, KEEP,KEEP8, DKEEP, & OPELI, DET_EXP, DET_MANT, DET_SIGN ) CALL SMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IS_BUFRX_ALLOCATED = .FALSE. CALL MUMPS_PROPINFO( ICNTL, INFO, & COMM_NODES, MYID_NODES ) ENDIF IF ( MYID_NODES .eq. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))), & KEEP(199)) & ) THEN IF ( INFO(1) .EQ. -10 .OR. INFO(1) .EQ. -40 ) THEN NTOTPV = NTOTPV + INFO(2) ELSE IF ( INFO(1) .GE. 0 ) THEN NTOTPV = NTOTPV + root%TOT_ROOT_SIZE NMAXNPIV = max(NMAXNPIV,root%TOT_ROOT_SIZE) END IF END IF IF (INFO(1).GE.0.AND.KEEP(60).EQ.0) THEN IF (root%yes) THEN IF (KEEP(252).EQ.0) THEN IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_L NextPiv2beWritten = 1 MonBloc%INODE = KEEP(38) MonBloc%MASTER = .TRUE. MonBloc%Typenode = 3 MonBloc%NROW = LOCAL_M MonBloc%NCOL = LOCAL_N MonBloc%NFS = MonBloc%NCOL MonBloc%Last = .TRUE. MonBloc%LastPiv = MonBloc%NCOL MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. LAST_CALL = .TRUE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(PTRFAC(STEP(KEEP(38)))), & LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IERR,LAST_CALL) IF (IERR .LT.0) THEN INFO(1) = IERR IF (LP > 0 ) THEN WRITE(LP,*)MYID, & ': Error in SMUMPS_OOC_IO_LU_PANEL',IERR ENDIF ENDIF ELSE IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+ ITMP8 CALL SMUMPS_NEW_FACTOR(KEEP(38),PTRFAC, & KEEP,KEEP8,A,LA, ITMP8, IERR) IF(IERR.LT.0)THEN INFO(1)=IERR IF (LP > 0 ) THEN WRITE(LP,*)MYID, & ': Error in SMUMPS_NEW_FACTOR',IERR ENDIF ENDIF ENDIF ENDIF IF (KEEP(201).NE.0 .OR. KEEP(252).NE.0) THEN LRLUS = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 IF (KEEP(252).NE.0) THEN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,0_8,-ITMP8, & KEEP,KEEP8,LRLUS) ELSE CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLUS) ENDIF IF (PTRFAC(STEP(KEEP(38))).EQ.POSFAC-ITMP8) THEN POSFAC = POSFAC - ITMP8 LRLU = LRLU + ITMP8 ENDIF ELSE CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLUS) ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL, INFO, & COMM_NODES, MYID_NODES ) ENDIF IF ( INFO(1).GE.0 .AND. KEEP(252) .NE. 0 .AND. & (KEEP(60).EQ.0 .OR. KEEP(221).EQ.1)) THEN IF (root%yes) 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(roota%RHS_CNTR_MASTER_ROOT( & LRHS_CNTR_MASTER_ROOT), stat=IERR ) IF (IERR.gt.0) THEN INFO(1) = -13 INFO(2) = LRHS_CNTR_MASTER_ROOT IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'CNTR_MASTER_ROOT of size', & LRHS_CNTR_MASTER_ROOT ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL, INFO, COMM_NODES, & MYID_NODES) IF (root%yes .AND. INFO(1).GE.0) THEN FWD_LOCAL_N_RHS = MUMPS_NUMROC(KEEP(253), & root%NBLOCK, root%MYCOL, 0, root%NPCOL) FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) CALL SMUMPS_GATHER_ROOT( MYID_NODES, & root%TOT_ROOT_SIZE, KEEP(253), & roota%RHS_CNTR_MASTER_ROOT(1), LOCAL_M, & FWD_LOCAL_N_RHS, root%MBLOCK, root%NBLOCK, & roota%RHS_ROOT(1,1), MASTER_ROOT, & root%NPROW, root%NPCOL, COMM_NODES ) ENDIF ENDIF ELSE IF (KEEP(19).NE.0) THEN CALL MPI_REDUCE(KEEP(109), GLOBK109, 1, & MPI_INTEGER, MPI_SUM, & MASTER_ROOT, & COMM_NODES, IERR) ENDIF IF (ROOT_OWNER) THEN IPOSROOT = PTLUST(STEP(KEEP(20))) NFRONT = IW(IPOSROOT+KEEP(IXSZ)+3) NFRONT8 = int(NFRONT,8) IPOSROOTROWINDICES=IPOSROOT+6+KEEP(IXSZ)+ & IW(IPOSROOT+5+KEEP(IXSZ)) NTOTPV = NTOTPV + NFRONT NMAXNPIV = max(NMAXNPIV,NFRONT) END IF IF ( KEEP(60) .EQ. 0 ) THEN IF ( ROOT_OWNER ) THEN IF (KEEP(118).GE.40) THEN NOFFNEGPV_ROOT = 0 NULLNEGPV_ROOT = 0 NTOTPV_ROOT = 0 NB22T1_ROOT = 0 NBTINY_ROOT = 0 DET_SIGN_ROOT = 1 DET_EXP_ROOT = 0 DET_MANT_ROOT = 1.0E0 DKEEP_SAVE(:) = DKEEP(:) KEEP_SAVE(:) = KEEP(:) KEEP8_SAVE(:) = KEEP8(:) KEEP_SAVE(201) = 0 IF (KEEP(110).EQ.0) THEN KEEP_SAVE(110)= 1 IF (KEEP(118).EQ.40) THEN IF ((DKEEP(10).LE.0).OR.(DKEEP(10).GT.1)) THEN DKEEP_SAVE(1) = DKEEP(9)*1E-1 ELSE DKEEP_SAVE(1) = DKEEP(9)*DKEEP(10) ENDIF ELSE IF (KEEP(118).EQ.41) THEN DKEEP_SAVE(1) = DKEEP(9) ELSE IF (KEEP(118).EQ.42) THEN IF (DKEEP(13).LT.1) THEN DKEEP_SAVE(1) = DKEEP(9)*10 ELSE DKEEP_SAVE(1) = DKEEP(9)*DKEEP(13) ENDIF ENDIF ELSE DKEEP_SAVE(1) = DKEEP(9) ENDIF IS_A_ROOT_SAVE_ALLOCATED = .FALSE. IF (LRLU.GT.NFRONT8*NFRONT8) THEN A_ROOT_SAVE => A(POSFAC:POSFAC+LRLU-1_8) ELSE IF (associated(A_ROOT_SAVE)) & DEALLOCATE(A_ROOT_SAVE) ALLOCATE(A_ROOT_SAVE(NFRONT8*NFRONT8),stat=IERR) IF (IERR.GT.0) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR(NFRONT8*NFRONT8, INFO(2) ) IF (LP > 0 ) & write(LP,*) "ERROR allocating A_ROOT_SAVE ", & " of size ", NFRONT*NFRONT GOTO 735 ENDIF IS_A_ROOT_SAVE_ALLOCATED = .TRUE. ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ CHUNK8=int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF ( NFRONT8*NFRONT8 > int(KEEP(361),8) .AND. NOMP .GT. 1) DO I8 =1_8, NFRONT8*NFRONT8 A_ROOT_SAVE(I8) = & A(PTRAST(STEP(KEEP(20)))+I8-1_8) ENDDO IW(PTLUST(STEP(INODE))+KEEP(IXSZ): & PTLUST(STEP(INODE))+KEEP(IXSZ)+4) & = RECORD_ROOT(KEEP(IXSZ)+1:KEEP(IXSZ)+5) IW(PTLUST(STEP(INODE))+XXLR) = 0 AVOID_DELAYED = .TRUE. IF (KEEP(50).EQ.0) THEN CALL SMUMPS_FAC1_LU_I ( & N, INODE, IW, LIW, A_ROOT_SAVE(1), & NFRONT8*NFRONT8, IPOSROOT, 1_8, & INFO(1), INFO(2), UU, NOFFNEGPV_ROOT, NTOTPV_ROOT, & NBTINY_ROOT, & DET_EXP_ROOT, DET_MANT_ROOT, DET_SIGN_ROOT, & KEEP_SAVE,KEEP8_SAVE, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP_SAVE(1), PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) THEN IF (LP.GT.0) & write(LP,*) "ERROR after SMUMPS_FAC1_LU ", & "on the root INFO(1)= ", INFO(1) GOTO 735 ENDIF ELSE CALL SMUMPS_FAC1_LDLT_I (N,KEEP_SAVE(20), & IW, LIW, A_ROOT_SAVE(1), NFRONT8*NFRONT8, & IPOSROOT, 1_8, & INFO(1), INFO(2), UU, & NOFFNEGPV_ROOT, NULLNEGPV_ROOT, NTOTPV_ROOT, & NB22T1_ROOT, NBTINY_ROOT, & DET_EXP_ROOT, DET_MANT_ROOT, DET_SIGN_ROOT, & KEEP_SAVE,KEEP8_SAVE, MYID_NODES, SEUIL, & AVOID_DELAYED, ETATASS, DKEEP_SAVE(1), & PIVNUL_LIST_STRUCT, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) THEN IF (LP.GT.0) & write(LP,*) "ERROR after SMUMPS_FAC1_LDLT ", & "on the root INFO(1)= ", INFO(1) GOTO 735 ENDIF ENDIF LRecord = IW(IOLDPS+XXI) IW(PTLUST(STEP(INODE)): & PTLUST(STEP(INODE))+LRecord-1) = & RECORD_ROOT(1:LRecord) IW(PTLUST(STEP(INODE))+KEEP(IXSZ): & PTLUST(STEP(INODE))+KEEP(IXSZ)+4) = & Header_ROOT(1:5) KEEP17_LU = KEEP_SAVE(109)-KEEP(109) IF (KEEP_SAVE(109).GT.KEEP(109)) THEN K = 1 DO I = KEEP(109)+1, KEEP(109)+KEEP17_LU RECORD_ROOT(K) = & PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) K = K+1 ENDDO ENDIF IF (IS_A_ROOT_SAVE_ALLOCATED) DEALLOCATE(A_ROOT_SAVE) NULLIFY(A_ROOT_SAVE) IS_A_ROOT_SAVE_ALLOCATED = .FALSE. DET_SIGN = DET_SIGN * DET_SIGN_ROOT DET_EXP = DET_EXP + DET_EXP_ROOT CALL SMUMPS_UPDATEDETER ( DET_MANT_ROOT, & DET_MANT, DET_EXP) NOFFNEGPV = NOFFNEGPV + NOFFNEGPV_ROOT NULLNEGPV = NULLNEGPV + NULLNEGPV_ROOT ENDIF LOCAL_M = 0 LOCAL_N = 0 MBLOCK = 0 NBLOCK = 0 PHASE = 1 CALL SMUMPS_SVD_QR_ESTIM_WK( PHASE, & MBLOCK, NBLOCK, NFRONT, LOCAL_M, LOCAL_N, & ROOT_OWNER, KEEP,KEEP8, & LIWK_RR, LWK_RR ) LBUFRX = LWK_RR IS_BUFRX_ALLOCATED = .FALSE. IF ( LRLU .GT. LBUFRX ) THEN BUFRX => A(POSFAC:POSFAC+LBUFRX-1_8) ELSE ALLOCATE( BUFRX( LBUFRX ), stat = IERR ) IF (IERR.gt.0) THEN INFO(1) = -13 CALL MUMPS_SET_IERROR(LBUFRX, INFO(2)) IF (LP.GT.0) & write(LP,*) ' Error allocating, real & array ','of size ', LBUFRX, & ' before SMUMPS_SEQ_FACTO_ROOT_SVD_QR' GOTO 735 ENDIF IS_BUFRX_ALLOCATED = .TRUE. ENDIF IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST .LT. & KEEP(109)+NFRONT) THEN CALL MUMPS_RESIZE_PIVNUL(KEEP, N, PIVNUL_LIST_STRUCT, & KEEP(109)+NFRONT, INFO(1), INFO(2) ) IF (INFO(1).LT.0) GOTO 735 ENDIF CALL SMUMPS_SEQ_FACTO_ROOT_SVD_QR( & NFRONT,A(PTRAST(STEP(KEEP(20)))), & root, roota, & BUFRX(1), int(LBUFRX), & KEEP,KEEP8, INFO, LP, DKEEP, & GLOBK109, OPELI, & PIVNUL_LIST_STRUCT%PIVNUL_LIST(KEEP(109)+1), & PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST- KEEP(109), & IW(IPOSROOTROWINDICES)) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IS_BUFRX_ALLOCATED = .FALSE. IF (INFO(1).LT.0) GOTO 735 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) CALL SMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) KEEP(143) = KEEP17_LU IF (KEEP(118).GE.40) THEN K = 1 IF (KEEP(17).GT.0) THEN DO I = KEEP(109)+1, KEEP(109)+KEEP(17) IF ( K .GT. KEEP17_LU ) THEN PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) = -1 ELSE PIVNUL_LIST_STRUCT%PIVNUL_LIST(I) = & RECORD_ROOT(K) ENDIF K = K+1 ENDDO ENDIF ENDIF IF (allocated(RECORD_ROOT)) DEALLOCATE(RECORD_ROOT) IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC, IW(IPOSROOT+XXR)) LIWFAC = IW(IPOSROOT+XXI) TYPEFile = TYPEF_L NextPiv2beWritten = 1 MonBloc%INODE = KEEP(20) MonBloc%MASTER = .TRUE. MonBloc%Typenode = 3 MonBloc%NCOL = NFRONT MonBloc%NROW = NFRONT MonBloc%NFS = NFRONT MonBloc%Last = .TRUE. MonBloc%LastPiv = MonBloc%NCOL MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. LAST_CALL = .TRUE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(PTRAST(STEP(KEEP(20)))), & LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IPOSROOT), LIWFAC, & MYID, KEEP8(31), IERR, LAST_CALL) IF(IERR.LT.0)THEN IF (LP > 0) & WRITE(LP,*)MYID, & ': Error raised in SMUMPS_OOC_IO_LU_PANEL', & IERR INFO(1)=IERR ENDIF ELSE IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+NFRONT8*NFRONT8 CALL SMUMPS_NEW_FACTOR(KEEP(20),PTRFAC, & KEEP,KEEP8,A,LA, NFRONT8*NFRONT8, IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID, & ': Internal error in SMUMPS_NEW_FACTOR', & IERR GOTO 735 ENDIF ENDIF ITMP8 = NFRONT8*NFRONT8 IF(KEEP(201).NE.0)THEN IF (PTRFAC(STEP(KEEP(20))).EQ. & POSFAC-ITMP8) THEN POSFAC = POSFAC - ITMP8 LRLU = LRLU + ITMP8 LRLUS = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 ELSE IF (LP.GT.0) & WRITE(LP,*) "Internal error", & POSFAC,NFRONT8, & "root KEEP(20) not on top in OOC" GOTO 735 ENDIF ENDIF CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,ITMP8,0_8,KEEP,KEEP8,LRLUS) ENDIF 735 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM_NODES, MYID_NODES ) IF (INFO(1).LT.0) GOTO 745 CALL MPI_BCAST( KEEP(17), 1, MPI_INTEGER, & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(20))), & KEEP(199)), & COMM_NODES, IERR ) CALL MPI_BCAST( KEEP(143), 1, MPI_INTEGER, & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(20))), & KEEP(199)), & COMM_NODES, IERR ) END IF IF (ROOT_OWNER.AND.KEEP(60).NE.0) THEN ITMP8 = NFRONT8*NFRONT8 IF ( PTRFAC(STEP(KEEP(20))) .EQ. POSFAC - & ITMP8 ) THEN POSFAC = POSFAC - ITMP8 LRLUS = LRLUS + ITMP8 LRLU = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-ITMP8,KEEP,KEEP8,LRLUS) ENDIF ENDIF END IF GOTO 750 745 CONTINUE IF (allocated(RECORD_ROOT)) DEALLOCATE(RECORD_ROOT) IF (IS_A_ROOT_SAVE_ALLOCATED) DEALLOCATE(A_ROOT_SAVE) NULLIFY(A_ROOT_SAVE) 750 CONTINUE IF (INFO(1).LT.0) GOTO 500 CALL MUMPS_SECFIN(ROOTTIME) DKEEP(99)=real(ROOTTIME) END IF END IF 500 CONTINUE IF ( KEEP(38) .NE. 0 ) THEN IF (MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))),KEEP(199)) & ) THEN MAXFRT = max ( MAXFRT, root%TOT_ROOT_SIZE) END IF END IF IF ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.2)) THEN CALL SMUMPS_OOC_CLEAN_PENDING(IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ENDIF CALL MUMPS_PROPINFO( ICNTL, INFO, COMM_NODES, MYID_NODES ) ENDIF IF (associated(roota%RHS_ROOT)) THEN DEALLOCATE(roota%RHS_ROOT) NULLIFY(roota%RHS_ROOT) ENDIF RETURN END SUBROUTINE SMUMPS_FAC_PAR SUBROUTINE SMUMPS_CHANGE_HEADER( HEADER, KEEP253 ) INTEGER HEADER( 6 ), KEEP253 INTEGER NFRONT, NASS NFRONT = HEADER(1) IF ( HEADER(2) .ne. 0 ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 1 :',HEADER(2) CALL MUMPS_ABORT() END IF NASS = abs( HEADER( 3 ) ) IF ( NASS .NE. abs( HEADER( 4 ) ) ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 2 :',HEADER(3:4) CALL MUMPS_ABORT() END IF IF ( NASS+KEEP253 .NE. NFRONT ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 3 : not root', & NASS, KEEP253, NFRONT CALL MUMPS_ABORT() END IF HEADER( 1 ) = KEEP253 HEADER( 2 ) = 0 HEADER( 3 ) = NFRONT HEADER( 4 ) = NFRONT-KEEP253 RETURN END SUBROUTINE SMUMPS_CHANGE_HEADER END MODULE SMUMPS_FAC_PAR_M MUMPS_5.8.1/src/smumps_mpi3_mod.F0000664000175000017500000000137615042446437016467 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_MPI3_MOD IMPLICIT NONE INTEGER, PARAMETER :: WIN_SYM_PERM272 = 272 INTEGER, PARAMETER :: WIN_FILS273 = 273 INTEGER, PARAMETER :: WIN_STEP274 = 274 INTEGER, PARAMETER :: WIN_LRGROUPS275 = 275 INTEGER, PARAMETER :: WIN_RG2L276 = 276 END MODULE SMUMPS_MPI3_MOD MUMPS_5.8.1/src/smumps_config_file.F0000664000175000017500000000103315042446437017212 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_CONFIG_FILE_RETURN() RETURN END SUBROUTINE SMUMPS_CONFIG_FILE_RETURN MUMPS_5.8.1/src/zfac_sol_pool.F0000664000175000017500000004376715042446441016212 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_INIT_POOL_LAST3(IPOOL, LPOOL, LEAF) USE MUMPS_LOAD IMPLICIT NONE INTEGER LPOOL, LEAF INTEGER IPOOL(LPOOL) IPOOL(LPOOL-2) = 0 IPOOL(LPOOL-1) = 0 IPOOL(LPOOL) = LEAF-1 RETURN END SUBROUTINE ZMUMPS_INIT_POOL_LAST3 SUBROUTINE ZMUMPS_INSERT_POOL_N & (N, POOL, LPOOL, PROCNODE, SLAVEF, KEEP199, & K28, K76, K80, K47, STEP, INODE) USE MUMPS_LOAD IMPLICIT NONE INTEGER N, INODE, LPOOL, K28, SLAVEF, K76, K80, K47, KEEP199 INTEGER STEP(N), POOL(LPOOL), PROCNODE(K28) EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR, ATM_CURRENT_NODE INTEGER NBINSUBTREE, NBTOP, INODE_EFF,POS_TO_INSERT INTEGER IPOS1, IPOS2, ISWAP INTEGER NODE,J,I ATM_CURRENT_NODE = ( K76 == 2 .OR. K76 ==3 .OR. & K76==4 .OR. K76==5) NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF (INODE > N ) THEN INODE_EFF = INODE - N ELSE IF (INODE < 0) THEN INODE_EFF = - INODE ELSE INODE_EFF = INODE ENDIF IF(((INODE.GT.0).AND.(INODE.LE.N)).AND.(.NOT. & MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE_EFF)), & KEEP199)) & ) THEN IF ((K80 == 1 .AND. K47 .GE. 1) .OR. & (( K80 == 2 .OR. K80==3 ) .AND. & ( K47 == 4 ))) THEN CALL MUMPS_REMOVE_NODE(INODE,1) ENDIF ENDIF IF ( MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE_EFF)), & KEEP199) ) THEN POOL(NBINSUBTREE + 1 ) = INODE NBINSUBTREE = NBINSUBTREE + 1 ELSE POS_TO_INSERT=NBTOP+1 IF((K76.EQ.4).OR.(K76.EQ.5).OR.(K76.EQ.6))THEN IF((INODE.GT.N).OR.(INODE.LE.0))THEN DO J=NBTOP,1,-1 IF((POOL(LPOOL-2-J).GT.0) & .AND.(POOL(LPOOL-2-J).LE.N))THEN GOTO 333 ENDIF IF ( POOL(LPOOL-2-J) < 0 ) THEN NODE=-POOL(LPOOL-2-J) ELSE IF ( POOL(LPOOL-2-J) > N ) THEN NODE = POOL(LPOOL-2-J) - N ELSE NODE = POOL(LPOOL-2-J) ENDIF IF((K76.EQ.4).OR.(K76.EQ.6))THEN IF(DEPTH_FIRST_LOAD(STEP(NODE)).GE. & DEPTH_FIRST_LOAD(STEP(INODE_EFF)))THEN GOTO 333 ENDIF ENDIF IF(K76.EQ.5)THEN IF(COST_TRAV(STEP(NODE)).LE. & COST_TRAV(STEP(INODE_EFF)))THEN GOTO 333 ENDIF ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO IF(J.EQ.0) J=1 333 CONTINUE DO I=NBTOP,POS_TO_INSERT,-1 POOL(LPOOL-2-I-1)=POOL(LPOOL-2-I) ENDDO POOL(LPOOL-2-POS_TO_INSERT)=INODE NBTOP = NBTOP + 1 GOTO 20 ENDIF DO J=NBTOP,1,-1 IF((POOL(LPOOL-2-J).GT.0).AND.(POOL(LPOOL-2-J).LE.N))THEN GOTO 888 ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO 888 CONTINUE DO I=J,1,-1 NODE=POOL(LPOOL-2-I) IF((K76.EQ.4).OR.(K76.EQ.6))THEN IF(DEPTH_FIRST_LOAD(STEP(NODE)).GE. & DEPTH_FIRST_LOAD(STEP(INODE_EFF)))THEN GOTO 999 ENDIF ENDIF IF(K76.EQ.5)THEN IF(COST_TRAV(STEP(NODE)).LE. & COST_TRAV(STEP(INODE_EFF)))THEN GOTO 999 ENDIF ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO IF(I.EQ.0) I=1 999 CONTINUE DO J=NBTOP,POS_TO_INSERT,-1 POOL(LPOOL-2-J-1)=POOL(LPOOL-2-J) ENDDO POOL(LPOOL-2-POS_TO_INSERT)=INODE NBTOP = NBTOP + 1 GOTO 20 ENDIF POOL( LPOOL - 2 - ( NBTOP + 1 ) ) = INODE NBTOP = NBTOP + 1 IPOS1 = LPOOL - 2 - NBTOP IPOS2 = LPOOL - 2 - NBTOP + 1 10 CONTINUE IF ( IPOS2 == LPOOL - 2 ) GOTO 20 IF ( POOL(IPOS1) < 0 ) GOTO 20 IF ( POOL(IPOS2) < 0 ) GOTO 30 IF ( ATM_CURRENT_NODE ) THEN IF ( POOL(IPOS1) > N ) GOTO 20 IF ( POOL(IPOS2) > N ) GOTO 30 END IF GOTO 20 30 CONTINUE ISWAP = POOL(IPOS1) POOL(IPOS1) = POOL(IPOS2) POOL(IPOS2) = ISWAP IPOS1 = IPOS1 + 1 IPOS2 = IPOS2 + 1 GOTO 10 20 CONTINUE ENDIF POOL(LPOOL) = NBINSUBTREE POOL(LPOOL - 1) = NBTOP RETURN END SUBROUTINE ZMUMPS_INSERT_POOL_N LOGICAL FUNCTION ZMUMPS_POOL_EMPTY(POOL, LPOOL) IMPLICIT NONE INTEGER LPOOL INTEGER POOL(LPOOL) INTEGER NBINSUBTREE, NBTOP NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) ZMUMPS_POOL_EMPTY = (NBINSUBTREE + NBTOP == 0) RETURN END FUNCTION ZMUMPS_POOL_EMPTY SUBROUTINE ZMUMPS_EXTRACT_POOL( N, POOL, LPOOL, PROCNODE, SLAVEF, & STEP, INODE, KEEP,KEEP8, MYID, ND, & FORCE_EXTRACT_TOP_SBTR ) USE MUMPS_LOAD IMPLICIT NONE INTEGER INODE, LPOOL, SLAVEF, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(N), POOL(LPOOL), PROCNODE(KEEP(28)), & ND(KEEP(28)) EXTERNAL MUMPS_INSSARBR, MUMPS_ROOTSSARBR, ZMUMPS_POOL_EMPTY LOGICAL MUMPS_INSSARBR, MUMPS_ROOTSSARBR, ZMUMPS_POOL_EMPTY INTEGER NBINSUBTREE, NBTOP, INSUBTREE, INODE_EFF, MYID LOGICAL LEFT, ATOMIC_SUBTREE,UPPER,FLAG_MEM,SBTR_FLAG,PROC_FLAG LOGICAL FORCE_EXTRACT_TOP_SBTR INTEGER NODE_TO_EXTRACT,I,J,MIN_PROC NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF ( KEEP(76) > 6 .OR. KEEP(76) < 0 ) THEN WRITE(*,*) "Error 2 in ZMUMPS_EXTRACT_POOL: unknown strategy" CALL MUMPS_ABORT() ENDIF ATOMIC_SUBTREE = ( KEEP(76) == 1 .OR. KEEP(76) == 3) IF ( ZMUMPS_POOL_EMPTY(POOL, LPOOL) ) THEN WRITE(*,*) "Error 1 in ZMUMPS_EXTRACT_POOL" CALL MUMPS_ABORT() ENDIF IF ( .NOT. ATOMIC_SUBTREE ) THEN LEFT = (NBTOP == 0) IF(.NOT.LEFT)THEN IF((KEEP(76).EQ.4).OR.(KEEP(76).EQ.5))THEN IF(NBINSUBTREE.EQ.0)THEN LEFT=.FALSE. ELSE IF ( POOL(NBINSUBTREE) < 0 ) THEN I = -POOL(NBINSUBTREE) ELSE IF ( POOL(NBINSUBTREE) > N ) THEN I = POOL(NBINSUBTREE) - N ELSE I = POOL(NBINSUBTREE) ENDIF IF ( POOL(LPOOL-2-NBTOP) < 0 ) THEN J = -POOL(LPOOL-2-NBTOP) ELSE IF ( POOL(LPOOL-2-NBTOP) > N ) THEN J = POOL(LPOOL-2-NBTOP) - N ELSE J = POOL(LPOOL-2-NBTOP) ENDIF IF(KEEP(76).EQ.4)THEN IF(DEPTH_FIRST_LOAD(STEP(J)).GE. & DEPTH_FIRST_LOAD(STEP(I)))THEN LEFT=.TRUE. ELSE LEFT=.FALSE. ENDIF ENDIF IF(KEEP(76).EQ.5)THEN IF(COST_TRAV(STEP(J)).LE. & COST_TRAV(STEP(I)))THEN LEFT=.TRUE. ELSE LEFT=.FALSE. ENDIF ENDIF ENDIF ENDIF ENDIF ELSE IF ( INSUBTREE == 1 ) THEN IF (NBINSUBTREE == 0) THEN WRITE(*,*) "Error 3 in ZMUMPS_EXTRACT_POOL" CALL MUMPS_ABORT() ENDIF LEFT = .TRUE. ELSE LEFT = ( NBTOP == 0) ENDIF ENDIF 222 CONTINUE IF ( LEFT ) THEN INODE = POOL( NBINSUBTREE ) IF(KEEP(81).EQ.2)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN CALL ZMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8,PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(.NOT.SBTR_FLAG)THEN WRITE(*,*)MYID,': ca a change pour moi' LEFT=.FALSE. GOTO 222 ENDIF ENDIF ELSEIF(KEEP(81).EQ.3)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN NODE_TO_EXTRACT=INODE FLAG_MEM=.FALSE. CALL MUMPS_LOAD_CHK_MEMCST_POOL(FLAG_MEM) IF(FLAG_MEM)THEN CALL ZMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(.NOT.SBTR_FLAG)THEN LEFT=.FALSE. WRITE(*,*)MYID,': ca a change pour moi (2)' GOTO 222 ENDIF ENDIF ENDIF ENDIF NBINSUBTREE = NBINSUBTREE - 1 IF ( INODE < 0 ) THEN INODE_EFF = -INODE ELSE IF ( INODE > N ) THEN INODE_EFF = INODE - N ELSE INODE_EFF = INODE ENDIF IF ( MUMPS_INSSARBR( PROCNODE(STEP(INODE_EFF)), & KEEP(199)) ) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.0))THEN CALL MUMPS_LOAD_SET_SBTR_MEM(.TRUE.) ENDIF INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE_EFF)), & KEEP(199))) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.1))THEN CALL MUMPS_LOAD_SET_SBTR_MEM(.FALSE.) ENDIF INSUBTREE = 0 END IF ELSE IF (NBTOP < 1 ) THEN WRITE(*,*) "Error 5 in ZMUMPS_EXTRACT_POOL", NBTOP CALL MUMPS_ABORT() ENDIF INODE = POOL( LPOOL - 2 - NBTOP ) IF(KEEP(81).EQ.1)THEN CALL MUMPS_LOAD_POOL_CHECK_MEM & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IF(UPPER)THEN GOTO 666 ELSE NBINSUBTREE=NBINSUBTREE-1 IF ( MUMPS_INSSARBR( PROCNODE(STEP(INODE)), & KEEP(199)) ) THEN INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE)), & KEEP(199))) THEN INSUBTREE = 0 ENDIF GOTO 777 ENDIF ENDIF IF(KEEP(81).EQ.2)THEN CALL ZMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN LEFT=.TRUE. WRITE(*,*)MYID,': ca a change pour moi (3)' GOTO 222 ENDIF ELSE IF(KEEP(81).EQ.3)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN NODE_TO_EXTRACT=INODE FLAG_MEM=.FALSE. CALL MUMPS_LOAD_CHK_MEMCST_POOL(FLAG_MEM) IF(FLAG_MEM)THEN CALL ZMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN LEFT=.TRUE. WRITE(*,*)MYID,': ca a change pour moi (4)' GOTO 222 ENDIF ELSE CALL MUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ENDIF ENDIF ENDIF ENDIF 666 CONTINUE NBTOP = NBTOP - 1 IF((INODE.GT.0).AND.(INODE.LE.N))THEN IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. & ( KEEP(47) == 4 ))) THEN CALL MUMPS_REMOVE_NODE(INODE,2) ENDIF ENDIF IF ( INODE < 0 ) THEN INODE_EFF = -INODE ELSE IF ( INODE > N ) THEN INODE_EFF = INODE - N ELSE INODE_EFF = INODE ENDIF END IF 777 CONTINUE POOL(LPOOL) = NBINSUBTREE POOL(LPOOL - 1) = NBTOP POOL(LPOOL - 2) = INSUBTREE RETURN END SUBROUTINE ZMUMPS_EXTRACT_POOL SUBROUTINE ZMUMPS_MEM_CONS_MNG(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR,FLAG_SAME_PROC,MIN_PROC) USE MUMPS_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) LOGICAL SBTR,FLAG_SAME_PROC INTEGER POS_TO_EXTRACT,NODE_TO_EXTRACT,NBTOP,I,INSUBTREE, & NBINSUBTREE DOUBLE PRECISION MIN_COST, TMP_COST NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) MIN_COST=huge(MIN_COST) TMP_COST=huge(TMP_COST) FLAG_SAME_PROC=.FALSE. SBTR=.FALSE. MIN_PROC=-9999 IF((INODE.GT.0).AND.(INODE.LE.N))THEN POS_TO_EXTRACT=-1 NODE_TO_EXTRACT=-1 DO I=NBTOP,1,-1 IF(NODE_TO_EXTRACT.LT.0)THEN POS_TO_EXTRACT=I NODE_TO_EXTRACT=POOL(LPOOL-2-I) CALL MUMPS_LOAD_COMP_MAXMEM_POOL(NODE_TO_EXTRACT, & TMP_COST,PROC) MIN_COST=TMP_COST MIN_PROC=PROC ELSE CALL MUMPS_LOAD_COMP_MAXMEM_POOL(POOL(LPOOL-2-I), & TMP_COST,PROC) IF((PROC.NE.MIN_PROC).OR.(TMP_COST.NE.MIN_COST))THEN FLAG_SAME_PROC=.TRUE. ENDIF IF(TMP_COST.GT.MIN_COST)THEN POS_TO_EXTRACT=I NODE_TO_EXTRACT=POOL(LPOOL-2-I) MIN_COST=TMP_COST MIN_PROC=PROC ENDIF ENDIF ENDDO IF((KEEP(47).EQ.4).AND.(NBINSUBTREE.NE.0))THEN CALL MUMPS_CHECK_SBTR_COST(NBINSUBTREE,INSUBTREE,NBTOP, & MIN_COST,SBTR) IF(SBTR)THEN WRITE(*,*)MYID,': selecting from subtree' RETURN ENDIF ENDIF IF((.NOT.SBTR).AND.(.NOT.FLAG_SAME_PROC))THEN WRITE(*,*)MYID,': I must search for a task & to save My friend' RETURN ENDIF INODE = NODE_TO_EXTRACT DO I=POS_TO_EXTRACT,NBTOP IF(I.NE.NBTOP)THEN POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDIF ENDDO POOL(LPOOL-2-NBTOP)=INODE CALL MUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ELSE ENDIF END SUBROUTINE ZMUMPS_MEM_CONS_MNG SUBROUTINE ZMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) USE MUMPS_LOAD IMPLICIT NONE INTEGER INODE,LPOOL,N,SLAVEF,MYID,MIN_PROC INTEGER POOL(LPOOL),KEEP(500),PROCNODE(KEEP(28)),STEP(N) INTEGER(8) KEEP8(150) LOGICAL SBTR_FLAG,PROC_FLAG EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR INTEGER NODE_TO_EXTRACT,I,POS_TO_EXTRACT,NBTOP,NBINSUBTREE NBTOP= POOL(LPOOL - 1) NBINSUBTREE = POOL(LPOOL) IF(NBTOP.GT.0)THEN WRITE(*,*)MYID,': NBTOP=',NBTOP ENDIF SBTR_FLAG=.FALSE. PROC_FLAG=.FALSE. CALL ZMUMPS_MEM_CONS_MNG(INODE,POOL,LPOOL,N,STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN RETURN ENDIF IF(MIN_PROC.EQ.-9999)THEN IF((INODE.GT.0).AND.(INODE.LT.N))THEN SBTR_FLAG=(NBINSUBTREE.NE.0) ENDIF RETURN ENDIF IF(.NOT.PROC_FLAG)THEN NODE_TO_EXTRACT=INODE IF((INODE.GE.0).AND.(INODE.LE.N))THEN CALL MUMPS_FIND_BEST_NODE_FOR_MEM(MIN_PROC,POOL, & LPOOL,INODE) IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)), & KEEP(199)))THEN WRITE(*,*)MYID,': Extracting from a subtree & for helping',MIN_PROC SBTR_FLAG=.TRUE. RETURN ELSE IF(NODE_TO_EXTRACT.NE.INODE)THEN WRITE(*,*)MYID,': Extracting from top & inode=',INODE,'for helping',MIN_PROC ENDIF CALL MUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ENDIF ENDIF DO I=1,NBTOP IF (POOL(LPOOL-2-I).EQ.INODE)THEN GOTO 452 ENDIF ENDDO 452 CONTINUE POS_TO_EXTRACT=I DO I=POS_TO_EXTRACT,NBTOP-1 POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDDO POOL(LPOOL-2-NBTOP)=INODE ENDIF END SUBROUTINE ZMUMPS_MEM_NODE_SELECT SUBROUTINE ZMUMPS_GET_INODE_FROM_POOL & ( IPOOL, LPOOL, III, LEAF, & INODE, STRATEGIE ) IMPLICIT NONE INTEGER, INTENT(IN) :: STRATEGIE, LPOOL INTEGER IPOOL (LPOOL) INTEGER III,LEAF INTEGER, INTENT(OUT) :: INODE LEAF = LEAF - 1 INODE = IPOOL( LEAF ) RETURN END SUBROUTINE ZMUMPS_GET_INODE_FROM_POOL MUMPS_5.8.1/src/dmumps_sol_es.F0000664000175000017500000010730415042446437016223 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_SOL_ES PRIVATE PUBLIC:: DMUMPS_CHAIN_PRUN_NODES PUBLIC:: DMUMPS_CHAIN_PRUN_NODES_STATS PUBLIC:: DMUMPS_INITIALIZE_RHS_BOUNDS PUBLIC:: DMUMPS_PROPAGATE_RHS_BOUNDS PUBLIC:: DMUMPS_TREE_PRUN_NODES PUBLIC:: DMUMPS_SOL_ES_INIT # if defined(STAT_ES_SOLVE) PUBLIC:: DMUMPS_SOL_ES_PRINT_STATS # endif PUBLIC:: DMUMPS_ES_GET_SUM_Nloc PUBLIC:: DMUMPS_ES_NODES_SIZE_AND_FILL INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK # if defined(STAT_ES_SOLVE) DOUBLE PRECISION :: nb_flops, & nb_sparse_flops, & total_efficiency INTEGER :: total_procs, total_blocks #endif INCLUDE 'mumps_headers.h' CONTAINS SUBROUTINE DMUMPS_SOL_ES_INIT(SIZE_OF_BLOCK_ARG, KEEP201) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP201 INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK_ARG IF (KEEP201 > 0) THEN SIZE_OF_BLOCK => SIZE_OF_BLOCK_ARG ELSE NULLIFY(SIZE_OF_BLOCK) ENDIF #if defined(STAT_ES_SOLVE) nb_flops=0.0d0 nb_sparse_flops=0.0d0 total_efficiency=0.0d0 total_procs=0 total_blocks=0 #endif RETURN END SUBROUTINE DMUMPS_SOL_ES_INIT SUBROUTINE DMUMPS_TREE_PRUN_NODES( & fill, & DAD, NE_STEPS, FRERE, KEEP28, & FILS, STEP, N, & nodes_RHS, nb_nodes_RHS, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N, KEEP28 INTEGER, INTENT(IN) :: DAD(KEEP28),NE_STEPS(KEEP28),FRERE(KEEP28) INTEGER, INTENT(IN) :: FILS(N), STEP(N) INTEGER, INTENT(IN) :: nodes_RHS(:), nb_nodes_RHS INTEGER :: nb_prun_nodes INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_List(nb_prun_nodes) INTEGER :: nb_prun_roots INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Roots(nb_prun_roots) INTEGER :: nb_prun_leaves INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Leaves(nb_prun_leaves) LOGICAL :: TO_PROCESS(KEEP28) INTEGER :: IN, I, ISTEP, TMP, TMPsave LOGICAL :: FILS_VISITED nb_prun_nodes = 0 nb_prun_leaves = 0 TO_PROCESS(:) = .FALSE. DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) TMPsave = TMP ISTEP = STEP(TMP) DO WHILE(.NOT.TO_PROCESS(ISTEP)) TO_PROCESS(ISTEP) = .TRUE. nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = TMP END IF IN = FILS(TMP) DO WHILE(IN.GT.0) IN = FILS(IN) END DO FILS_VISITED = .FALSE. IF (IN.LT.0) THEN FILS_VISITED = TO_PROCESS(STEP(-IN)) ENDIF IF ( IN.LT.0.and..NOT.FILS_VISITED) & THEN TMP = -IN ISTEP = STEP(TMP) ELSE IF (IN.EQ.0) THEN nb_prun_leaves = nb_prun_leaves + 1 IF (fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF ELSE TMP = -IN ISTEP = STEP(TMP) ENDIF DO WHILE (TMP.NE.TMPsave) TMP = abs(FRERE(ISTEP)) IF(TMP.NE.0) THEN ISTEP = STEP(TMP) ELSE exit END IF IF (.NOT.TO_PROCESS(ISTEP)) exit END DO END IF END DO END DO nb_prun_roots = 0 DO I=1,nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) IF(DAD(ISTEP).NE.0) THEN IF(.NOT.TO_PROCESS(STEP(DAD(ISTEP)))) THEN nb_prun_roots = nb_prun_roots + 1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF END IF ELSE nb_prun_roots = nb_prun_roots + 1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF END IF END DO RETURN END SUBROUTINE DMUMPS_TREE_PRUN_NODES SUBROUTINE DMUMPS_CHAIN_PRUN_NODES( & fill, & DAD, KEEP28, & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes,nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: KEEP28 INTEGER, INTENT(IN) :: DAD(KEEP28) INTEGER, INTENT(IN) :: nb_nodes_RHS INTEGER, INTENT(IN) :: nodes_RHS(max(nb_nodes_RHS,1)) INTEGER, INTENT(INOUT) :: nb_prun_nodes INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_List(nb_prun_nodes) INTEGER, INTENT(INOUT) :: nb_prun_roots INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Roots(nb_prun_roots) INTEGER, INTENT(INOUT) :: nb_prun_leaves INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Leaves(nb_prun_leaves) INTEGER, INTENT(OUT) :: Pruned_SONS(KEEP28) LOGICAL, INTENT(OUT) :: TO_PROCESS(KEEP28) INTEGER :: IN, I, ISTEP, TMP nb_prun_nodes = 0 nb_prun_roots = 0 TO_PROCESS(:) = .FALSE. Pruned_SONS(:) = -1 DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) TO_PROCESS(ISTEP) = .TRUE. IF (Pruned_SONS(ISTEP) .eq. -1) THEN Pruned_SONS(ISTEP) = 0 nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = nodes_RHS(I) END IF IN = nodes_RHS(I) IN = DAD(STEP(IN)) DO WHILE (IN.NE.0) TO_PROCESS(STEP(IN)) = .TRUE. IF (Pruned_SONS(STEP(IN)).eq.-1) THEN nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = IN END IF Pruned_SONS(STEP(IN)) = 1 TMP = IN IN = DAD(STEP(IN)) ELSE Pruned_SONS(STEP(IN)) = Pruned_SONS(STEP(IN)) + 1 GOTO 201 ENDIF ENDDO nb_prun_roots = nb_prun_roots +1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF ENDIF 201 CONTINUE ENDDO nb_prun_leaves = 0 DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) IF (Pruned_SONS(ISTEP).EQ.0) THEN nb_prun_leaves = nb_prun_leaves +1 IF(fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF END IF ENDDO RETURN END SUBROUTINE DMUMPS_CHAIN_PRUN_NODES SUBROUTINE DMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, K242, K243, & UNS_PERM_INV, SIZE_UNS_PERM_INV, K23, & RHS_BOUNDS, NSTEPS, & nb_sparse, MYID, & mode) IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, N, NSTEPS, K242, K243, K23 INTEGER, INTENT(IN) :: JBEG_RHS, SIZE_PERM_RHS, nb_sparse INTEGER, INTENT(IN) :: NBCOL, NZ_RHS, SIZE_UNS_PERM_INV INTEGER, INTENT(IN) :: STEP(N), PERM_RHS(SIZE_PERM_RHS) INTEGER, INTENT(IN) :: IRHS_PTR(NBCOL+1),IRHS_SPARSE(NZ_RHS) INTEGER, INTENT(IN) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, INTENT(INOUT):: RHS_BOUNDS(2*NSTEPS) INTEGER, INTENT(IN) :: mode INTEGER :: I, ICOL, JPTR, J, JAM1, node, bound RHS_BOUNDS = 0 ICOL = 0 DO I = 1, NBCOL IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE ICOL = ICOL + 1 bound = ICOL - mod(ICOL, nb_sparse) + 1 IF(mod(ICOL, nb_sparse).EQ.0) bound = bound - nb_sparse IF(mode.EQ.0) THEN IF ((K242.NE.0).OR.(K243.NE.0)) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 ENDIF node = abs(STEP(JAM1)) IF(RHS_BOUNDS(2*node - 1).EQ.0) THEN RHS_BOUNDS(2*node - 1) = bound RHS_BOUNDS(2*node) = bound + nb_sparse - 1 ELSE RHS_BOUNDS(2*node) = bound + nb_sparse - 1 END IF ELSE DO JPTR = IRHS_PTR(I), IRHS_PTR(I+1)-1 J = IRHS_SPARSE(JPTR) IF ( mode .EQ. 1 ) THEN IF (K23.NE.0) J = UNS_PERM_INV(J) ENDIF node = abs(STEP(J)) IF(RHS_BOUNDS(2*node - 1).EQ.0) THEN RHS_BOUNDS(2*node - 1) = bound RHS_BOUNDS(2*node) = bound + nb_sparse - 1 ELSE RHS_BOUNDS(2*node) = bound + nb_sparse - 1 END IF END DO END IF END DO RETURN END SUBROUTINE DMUMPS_INITIALIZE_RHS_BOUNDS SUBROUTINE DMUMPS_PROPAGATE_RHS_BOUNDS( & pruned_leaves, nb_pruned_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, NSTEPS, & MYID, COMM, KEEP485, #if defined(STAT_ES_SOLVE) & KEEP46, & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, #endif & IW, LIW, PTRIST, KIXSZ,OOC_FCT_LOC, PHASE, LDLT, K38) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' INTEGER, INTENT(IN) :: nb_pruned_leaves, N, NSTEPS INTEGER, INTENT(IN) :: STEP(N), DAD(NSTEPS), Pruned_SONS(NSTEPS) INTEGER, INTENT(IN) :: MYID, COMM, KEEP485 INTEGER, INTENT(IN) :: pruned_leaves(nb_pruned_leaves) INTEGER, INTENT(IN) :: LIW, IW(LIW), PTRIST(NSTEPS) INTEGER, INTENT(IN) :: KIXSZ, OOC_FCT_LOC, PHASE, LDLT, K38 # if defined(STAT_ES_SOLVE) INTEGER, INTENT(IN) :: KEEP46 INTEGER, INTENT(IN) :: SIZE_IPTR_WORKING, SIZE_WORKING, & IPTR_WORKING(SIZE_IPTR_WORKING), & WORKING(SIZE_WORKING) #endif INTEGER, INTENT(INOUT):: RHS_BOUNDS(2*NSTEPS) INTEGER :: I, node, father, size_pool, next_size_pool INTEGER :: IERR INTEGER, ALLOCATABLE, DIMENSION(:) :: POOL, NBSONS #if defined(STAT_ES_SOLVE) LOGICAL, ALLOCATABLE, DIMENSION(:) :: isleaf INTEGER :: J, NPROCS, proc, allocok LOGICAL :: found DOUBLE PRECISION :: avg_load, efficiency, max_load, effmax DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: proc_flops_buf DOUBLE PRECISION :: proc_block_flops, block_flops INTEGER :: SK38 INTEGER, PARAMETER :: MASTER = 0 #endif ALLOCATE(POOL(nb_pruned_leaves), & NBSONS(NSTEPS), & STAT=IERR) IF (IERR.NE.0) THEN WRITE(6,*)'Allocation problem in DMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() END IF size_pool = nb_pruned_leaves POOL = pruned_leaves NBSONS = Pruned_SONS # if defined(STAT_ES_SOLVE) NPROCS = SIZE_IPTR_WORKING-1 IF((MYID.EQ.MASTER).AND.(KEEP46.EQ.1)) THEN ALLOCATE(isleaf(NSTEPS), STAT=IERR) IF (IERR.NE.0) THEN WRITE(6,*)'Allocation problem in DMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() END IF isleaf = .FALSE. DO I=1,nb_pruned_leaves isleaf(abs(STEP(pruned_leaves(I)))) = .true. END DO proc = 0 DO I=1,NPROCS found = .FALSE. J = IPTR_WORKING(I) DO WHILE((J.LE.IPTR_WORKING(I+1)-1).AND.(.NOT.found)) IF (isleaf(WORKING(J)))THEN found = .TRUE. END IF J = J + 1 END DO IF(found) THEN proc = proc + 1 END IF END DO total_procs = total_procs + proc total_blocks = total_blocks + 1 DEALLOCATE(isleaf) END IF # endif DO WHILE (size_pool.ne.0) next_size_pool =0 DO I=1, size_pool node = STEP(POOL(I)) IF (DAD(node).NE.0) THEN father = STEP(DAD(node)) NBSONS(father) = NBSONS(father)-1 IF (RHS_BOUNDS(2*father-1).EQ.0) THEN RHS_BOUNDS(2*father-1) = RHS_BOUNDS(2*node-1) RHS_BOUNDS(2*father) = RHS_BOUNDS(2*node) ELSE RHS_BOUNDS(2*father-1) = min(RHS_BOUNDS(2*father-1), & RHS_BOUNDS(2*node-1)) RHS_BOUNDS(2*father) = max(RHS_BOUNDS(2*father), & RHS_BOUNDS(2*node)) END IF IF(NBSONS(father).EQ.0) THEN next_size_pool = next_size_pool+1 POOL(next_size_pool) = DAD(node) END IF END IF END DO size_pool = next_size_pool END DO DEALLOCATE(POOL, NBSONS) # if defined(STAT_ES_SOLVE) IF (KEEP46.EQ.1) THEN IF(MYID.EQ.MASTER) THEN block_flops = 0D0 END IF proc_block_flops = 0D0 IF (K38 .GT. 0) THEN SK38 = STEP(K38) ELSE SK38 = 0 END IF DO I=1,NSTEPS IF (RHS_BOUNDS(2*I).NE.0) THEN IF(PTRIST(I).GT.0) THEN proc_block_flops = proc_block_flops & + dble(2*(RHS_BOUNDS(2*I) - RHS_BOUNDS(2*I-1) +1)) & * dble(DMUMPS_LOCAL_FACTOR_SIZE(IW, LIW, & PTRIST(I)+KIXSZ, & PHASE,LDLT,I.EQ.SK38)) END IF END IF END DO IF(MYID.EQ.MASTER) THEN ALLOCATE(proc_flops_buf(SIZE_IPTR_WORKING-1),stat=allocok) IF(allocok.GT.0) THEN WRITE(6,*)'Allocation problem of proc_flops_buf' & ,' in DMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() ENDIF proc_flops_buf=0.0d0 ELSE ALLOCATE(proc_flops_buf(1),stat=allocok) IF(allocok.GT.0) THEN WRITE(6,*)'Allocation problem of proc_flops_buf' & ,' in DMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() ENDIF proc_flops_buf=0.0d0 END IF CALL MPI_GATHER(proc_block_flops, 1, MPI_DOUBLE_PRECISION, & proc_flops_buf, 1, MPI_DOUBLE_PRECISION, & 0, COMM, IERR) CALL MPI_REDUCE(proc_block_flops, block_flops, 1, & MPI_DOUBLE_PRECISION, MPI_SUM, 0, COMM, IERR) IF(MYID.EQ.MASTER) THEN nb_sparse_flops = nb_sparse_flops+block_flops avg_load = sum(proc_flops_buf)/dble(NPROCS) max_load = maxval(proc_flops_buf) efficiency = 0D0 effmax = 0D0 DO I=1,NPROCS efficiency= efficiency + (proc_flops_buf(I)-avg_load)**2 IF (proc_flops_buf(I)-avg_load.GT.0.0D0) THEN effmax = effmax + (max_load-avg_load)**2 ELSE IF (proc_flops_buf(I)-avg_load.LT.0.0D0) THEN effmax = effmax + avg_load**2 END IF END DO efficiency = sqrt(efficiency/dble(NPROCS)) effmax = sqrt(effmax/dble(NPROCS)) IF(effmax.ne.0.0d0) efficiency = efficiency / effmax efficiency = 1.0d0 - efficiency efficiency = efficiency * block_flops total_efficiency = total_efficiency + efficiency DEALLOCATE(proc_flops_buf) ELSE DEALLOCATE(proc_flops_buf) END IF END IF #endif RETURN END SUBROUTINE DMUMPS_PROPAGATE_RHS_BOUNDS INTEGER(8) FUNCTION DMUMPS_LOCAL_FACTOR_SIZE(IW,LIW,PTR, & PHASE, LDLT, IS_ROOT) INTEGER, INTENT(IN) :: LIW, PTR, PHASE, LDLT INTEGER, INTENT(IN) :: IW(LIW) LOGICAL, INTENT(IN) :: IS_ROOT INTEGER(8) :: NCB, NELIM, LIELL, NPIV, NROW NCB = int(IW(PTR),8) NELIM = int(IW(PTR+1),8) NROW = int(IW(PTR+2),8) NPIV = int(IW(PTR+3),8) LIELL = NPIV + NCB IF (IS_ROOT) THEN DMUMPS_LOCAL_FACTOR_SIZE = int(IW(PTR+1),8) * & int(IW(PTR+2),8) / 2_8 RETURN ENDIF IF (NCB.GE.0_8) THEN IF (PHASE.EQ.0 & .OR. (PHASE.EQ.1.AND.LDLT.NE.0) & ) THEN DMUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV-1_8)/2_8 + (NROW-NPIV)*NPIV ELSE DMUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV-1_8)/2_8 + (LIELL-NPIV)*NPIV ENDIF ELSE DMUMPS_LOCAL_FACTOR_SIZE = & -NCB*NELIM END IF RETURN END FUNCTION DMUMPS_LOCAL_FACTOR_SIZE SUBROUTINE DMUMPS_CHAIN_PRUN_NODES_STATS & (MYID, N, KEEP28, KEEP201, KEEP485, FR_FACT, & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_LOC # if defined(STAT_ES_SOLVE) & , NRHS, COMM, IW, LIW, PTRIST, KIXSZ, PHASE, & LDLT, K38 #endif & ) IMPLICIT NONE INTEGER, intent(in) :: KEEP28, KEEP201, OOC_FCT_TYPE_LOC, N, & KEEP485 INTEGER(8), intent(in) :: FR_FACT INTEGER, intent(in) :: nb_prun_nodes, MYID INTEGER, intent(in) :: Pruned_List(nb_prun_nodes) INTEGER, intent(in) :: STEP(N) #if defined(STAT_ES_SOLVE) INTEGER, INTENT(IN):: LIW, COMM, NRHS, LDLT, K38 INTEGER, INTENT(IN):: IW(LIW), PTRIST(KEEP28), KIXSZ, PHASE DOUBLE PRECISION :: proc_block_flops, block_flops INTEGER(8) :: Pruned_Size_ic INTEGER :: IERR INTEGER :: SK38 #endif INCLUDE 'mpif.h' INTEGER I, ISTEP INTEGER(8) :: Pruned_Size #if defined(STAT_ES_SOLVE) Pruned_Size_ic = 0_8 #endif Pruned_Size = 0_8 #if defined(STAT_ES_SOLVE) IF (K38 .GT. 0) THEN SK38 = STEP(K38) ELSE SK38 = 0 END IF #endif 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 #if defined(STAT_ES_SOLVE) IF (PTRIST(ISTEP) .GT. 0) THEN Pruned_Size_ic = Pruned_Size_ic + & DMUMPS_LOCAL_FACTOR_SIZE(IW, LIW, & PTRIST(ISTEP)+KIXSZ, & PHASE, LDLT, & ISTEP.EQ.SK38) ENDIF # endif ENDDO #if defined(STAT_ES_SOLVE) proc_block_flops = dble(2_8*Pruned_Size_ic)*dble(NRHS) CALL MPI_REDUCE(proc_block_flops, block_flops, 1, & MPI_DOUBLE_PRECISION, MPI_SUM, 0, COMM, IERR) IF(MYID.EQ.0) nb_flops = nb_flops + block_flops #endif RETURN END SUBROUTINE DMUMPS_CHAIN_PRUN_NODES_STATS #if defined(STAT_ES_SOLVE) SUBROUTINE DMUMPS_SOL_ES_PRINT_STATS( & K212, K235, K237, K485, K497, NZLU8, & NRHS, ICNTL27, N, K50, DKEEPS, RINFOGS, MPG) IMPLICIT NONE INTEGER, intent(in) :: K212, K235, K237, K485, K497, & NRHS, MPG, ICNTL27, N, K50 INTEGER(8), intent(in) :: NZLU8 DOUBLE PRECISION, intent(out) :: DKEEPS(5), RINFOGS(5) LOGICAL :: AM1, ES_FWD, ES_BWD, DO_NBSPARSE IF (MPG.LE.0) RETURN AM1 = (K237 .NE. 0) ES_FWD = (K235 .NE. 0) .AND. (.NOT. AM1) ES_BWD = (K212 .NE. 0) .AND. (.NOT. AM1) DO_NBSPARSE = (K497.NE.0).AND.(NRHS.GT.1).AND.(ICNTL27.GT.1) IF (AM1) & WRITE(MPG,'(/A)') ' ** FLOPS SUMMARY during SOLVE AM1 ** ' IF ((ES_FWD).AND. (.NOT.ES_BWD)) & WRITE(MPG,'(/A,A)') ' ** FLOPS SUMMARY during fwd step', & ' (exploit RHS sparsity) ** ' IF ((.NOT.ES_FWD).AND. (ES_BWD)) & WRITE(MPG,'(/A,A)') ' ** FLOPS SUMMARY during bwd step', & ' (selected entries in solution) ** ' IF ((ES_FWD).AND. (ES_BWD)) & WRITE(MPG,'(/A,/A)') & ' ** FLOPS SUMMARY during SOLVE (fwd+bwd steps)', & ' (sparse RHS and selected entries in solution) **' IF ( & (ES_FWD) .AND. (.NOT.ES_BWD) & .OR. & (.NOT.ES_FWD) .AND. (ES_BWD) & ) THEN IF (K50.NE.0) THEN DKEEPS(1)=(dble(NZLU8)-dble(N))*dble(2*NRHS) ELSE DKEEPS(1)=(dble(NZLU8)-dble(N))*dble(NRHS) ENDIF ELSE IF ((ES_FWD).AND.(ES_BWD)) THEN IF (K50.NE.0) THEN DKEEPS(1) = (dble(NZLU8)-dble(N))*dble(4*NRHS) ELSE DKEEPS(1)=(dble(NZLU8)-dble(N))*dble(2*NRHS) ENDIF ENDIF RINFOGS(1) = DKEEPS(1) IF (.NOT.AM1) THEN WRITE(MPG,'(A,F25.1)') & ' RINFOG(24) FLOPS with dense full rank format =', DKEEPS(1) ENDIF DKEEPS(2)=dble(nb_flops) IF (DO_NBSPARSE) DKEEPS(4)=dble(nb_sparse_flops) IF (DO_NBSPARSE) THEN RINFOGS(2)= DKEEPS(4) ELSE RINFOGS(2)= DKEEPS(2) ENDIF WRITE(MPG,'(A,F25.1)') & ' RINFOG(25) FLOPS with exploit sparsity (ES) =', RINFOGS(2) RETURN END SUBROUTINE DMUMPS_SOL_ES_PRINT_STATS #endif SUBROUTINE DMUMPS_ES_GET_SUM_Nloc ( & N, Nloc_ITAB, ITAB_loc, COMM, & SUM_idNloc_8 ) IMPLICIT NONE INTEGER, INTENT(IN) :: N #if defined(MUMPS_NOF2003) INTEGER, POINTER :: ITAB_loc (:) #else INTEGER, INTENT( IN ), POINTER :: ITAB_loc (:) #endif INTEGER, INTENT(IN) :: Nloc_ITAB INTEGER, INTENT(IN) :: COMM INTEGER(8) :: SUM_idNloc_8 INCLUDE 'mpif.h' INTEGER I, II, IERR_MPI INTEGER(8) :: idNloc_8 idNloc_8 = 0_8 DO I= 1, Nloc_ITAB II = ITAB_loc(I) IF (II.GE.1 .and. II.LE.N) & idNloc_8 = idNloc_8 + 1_8 ENDDO CALL MPI_ALLREDUCE (idNloc_8, SUM_idNloc_8, 1, & MPI_INTEGER8, & MPI_SUM, COMM, IERR_MPI ) RETURN END SUBROUTINE DMUMPS_ES_GET_SUM_Nloc SUBROUTINE DMUMPS_ES_NODES_SIZE_AND_FILL ( & fill, & N, NSTEPS, KEEP, STEP, Step2node, & ITAB_loc, Nloc_ITAB, & MYID, COMM, & Pruned_Sons, Lnodes_ITAB #if defined(AVOID_MPI_IN_PLACE) & , TMP_INT_ARRAY #endif & , nodes_ITAB & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N, NSTEPS, KEEP(500) INTEGER, INTENT(IN) :: Nloc_ITAB INTEGER, INTENT(IN) :: STEP(N), Step2node(NSTEPS), & ITAB_loc(max(1,Nloc_ITAB)) INTEGER, INTENT(IN) :: MYID, COMM #if defined(AVOID_MPI_IN_PLACE) INTEGER :: TMP_INT_ARRAY(NSTEPS) #endif INTEGER, INTENT(INOUT) :: Pruned_Sons(NSTEPS), Lnodes_ITAB INTEGER, OPTIONAL, INTENT(OUT) :: nodes_ITAB(max(1,Lnodes_ITAB)) INCLUDE 'mpif.h' INTEGER I, II, ISTEP, IERR_MPI, Lnodes_ITAB_loc, INODE_PRINC IF (.NOT.fill) THEN Pruned_SONS = 0 DO I= 1, Nloc_ITAB II = ITAB_loc(I) IF (II.GE.1 .and. II.LE.N) THEN ISTEP = abs(STEP(II)) IF ( Pruned_SONS(ISTEP) .eq. 0 ) THEN Pruned_SONS(ISTEP) = 1 ENDIF ENDIF ENDDO #if defined(AVOID_MPI_IN_PLACE) TMP_INT_ARRAY = Pruned_Sons #endif CALL MPI_ALLREDUCE( #if defined(AVOID_MPI_IN_PLACE) & TMP_INT_ARRAY, #else & MPI_IN_PLACE, #endif & Pruned_Sons, NSTEPS, & MPI_INTEGER, MPI_SUM, COMM, IERR_MPI) Lnodes_ITAB = 0 DO ISTEP=1,NSTEPS if (Pruned_SONS(ISTEP) .NE.0) Lnodes_ITAB=Lnodes_ITAB+1 ENDDO ELSE IF (Lnodes_ITAB.GT.0) THEN Lnodes_ITAB_loc = 0 DO ISTEP=1,NSTEPS if (Pruned_SONS(ISTEP) .GT. 0) then Lnodes_ITAB_loc=Lnodes_ITAB_loc+1 INODE_PRINC = Step2node( ISTEP ) nodes_ITAB(Lnodes_ITAB_loc) = INODE_PRINC endif ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_ES_NODES_SIZE_AND_FILL END MODULE DMUMPS_SOL_ES SUBROUTINE DMUMPS_PERMUTE_RHS_GS & (LP, LPOK, PROKG, MPG, PERM_STRAT, & SYM_PERM, N, NRHS, & IRHS_PTR, SIZE_IRHS_PTR, & IRHS_SPARSE, NZRHS, & PERM_RHS, IERR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: LP, MPG, PERM_STRAT, N, NRHS, & SIZE_IRHS_PTR, & NZRHS LOGICAL, INTENT(IN) :: LPOK, PROKG INTEGER, INTENT(IN) :: SYM_PERM(N) INTEGER, INTENT(IN) :: IRHS_PTR(SIZE_IRHS_PTR) INTEGER, INTENT(IN) :: IRHS_SPARSE(NZRHS) INTEGER, INTENT(OUT) :: PERM_RHS(NRHS) INTEGER, INTENT(OUT) :: IERR INTEGER :: I,J,K, POSINPERMRHS, JJ, & KPOS INTEGER, ALLOCATABLE :: ROW_REFINDEX(:) IERR = 0 IF ((PERM_STRAT.NE.-1).AND.(PERM_STRAT.NE.1)) THEN IERR=-1 IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -1 in ", & " DMUMPS_PERMUTE_RHS_GS, PERM_STRAT =", PERM_STRAT, & " is out of range " RETURN ENDIF IF (PERM_STRAT.EQ.-1) THEN DO I=1,NRHS PERM_RHS(I) = I END DO GOTO 490 ENDIF ALLOCATE(ROW_REFINDEX(NRHS), STAT=IERR) IF (IERR.GT.0) THEN IERR=-1 IF (LPOK) THEN WRITE(LP,*) " ERROR -2 : ", & " ALLOCATE IN DMUMPS_PERMUTE_RHS_GS OF SIZE :", & NRHS ENDIF RETURN ENDIF DO I=1,NRHS IF (IRHS_PTR(I+1)-IRHS_PTR(I).LE.0) THEN IERR = 1 IF (I.EQ.1) THEN ROW_REFINDEX(I) = IRHS_SPARSE(IRHS_PTR(I)) ELSE ROW_REFINDEX(I) = ROW_REFINDEX(I-1) ENDIF ELSE ROW_REFINDEX(I) = IRHS_SPARSE(IRHS_PTR(I)) ENDIF END DO POSINPERMRHS = 0 DO I=1,NRHS KPOS = N+1 JJ = 0 DO J=1,NRHS K = ROW_REFINDEX(J) IF (K.LE.0) CYCLE IF (SYM_PERM(K).LT.KPOS) THEN KPOS = SYM_PERM(K) JJ = J ENDIF END DO IF (JJ.EQ.0) THEN IERR = -3 IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -3 in ", & " DMUMPS_PERMUTE_RHS_GS " GOTO 500 ENDIF POSINPERMRHS = POSINPERMRHS + 1 PERM_RHS(POSINPERMRHS) = JJ ROW_REFINDEX(JJ) = -ROW_REFINDEX(JJ) END DO IF (POSINPERMRHS.NE.NRHS) THEN IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -4 in ", & " DMUMPS_PERMUTE_RHS_GS ", maxval(ROW_REFINDEX) IERR = -4 GOTO 500 ENDIF 490 CONTINUE 500 CONTINUE IF (allocated(ROW_REFINDEX)) DEALLOCATE(ROW_REFINDEX) END SUBROUTINE DMUMPS_PERMUTE_RHS_GS SUBROUTINE DMUMPS_PERMUTE_RHS_AM1 & (PERM_STRAT, SYM_PERM, & IRHS_PTR, NHRS, & PERM_RHS, SIZEPERM, IERR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: PERM_STRAT, NHRS, SIZEPERM INTEGER, INTENT(IN) :: SYM_PERM(SIZEPERM) INTEGER, INTENT(IN) :: IRHS_PTR(NHRS) INTEGER, INTENT(OUT):: IERR INTEGER, INTENT(OUT):: PERM_RHS(SIZEPERM) DOUBLE PRECISION :: RAND_NUM INTEGER I, J, STRAT IERR = 0 STRAT = PERM_STRAT IF( (STRAT.NE.-3).AND. & (STRAT.NE.-2).AND. & (STRAT.NE.-1).AND. & (STRAT.NE. 1).AND. & (STRAT.NE. 2).AND. & (STRAT.NE. 6) ) THEN WRITE(*,*)"Warning: incorrect value for the RHS permutation; ", & "defaulting to post-order" STRAT = 1 END IF IF (STRAT .EQ. -3) THEN PERM_RHS(1:SIZEPERM)=0 DO I=1, SIZEPERM CALL random_number(RAND_NUM) RAND_NUM = RAND_NUM*dble(SIZEPERM) J = ceiling(RAND_NUM) DO WHILE (PERM_RHS(J).NE.0) CALL random_number(RAND_NUM) RAND_NUM = RAND_NUM*dble(SIZEPERM) J = ceiling(RAND_NUM) ENDDO PERM_RHS(J)=I ENDDO ELSEIF (STRAT .EQ. -2) THEN DO I=1, SIZEPERM PERM_RHS(SIZEPERM -I +1) = I ENDDO ELSEIF (STRAT .EQ. -1) THEN DO I=1, SIZEPERM PERM_RHS(I) = I ENDDO ELSEIF (STRAT .EQ. 1) THEN DO I=1, SIZEPERM PERM_RHS(SYM_PERM(I)) = I ENDDO ELSEIF (STRAT .EQ. 2) THEN DO I=1, SIZEPERM PERM_RHS(SIZEPERM-SYM_PERM(I)+1) = I ENDDO ENDIF END SUBROUTINE DMUMPS_PERMUTE_RHS_AM1 SUBROUTINE DMUMPS_INTERLEAVE_RHS_AM1( & PERM_RHS, SIZE_PERM, & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, & IRHS_PTR, & STEP, SYM_PERM, N, NBRHS, & PROCNODE, NSTEPS, SLAVEF, KEEP199, & behaviour_L0, reorder, n_select, PROKG, MPG & ) IMPLICIT NONE INTEGER, INTENT(IN) :: SIZE_PERM, & SIZE_IPTR_WORKING, & IPTR_WORKING(SIZE_IPTR_WORKING), & SIZE_WORKING, & WORKING(SIZE_WORKING), & N, & IRHS_PTR(N+1), & STEP(N), & SYM_PERM(N), & NBRHS, & NSTEPS, & PROCNODE(NSTEPS), & SLAVEF, KEEP199, & n_select, MPG LOGICAL, INTENT(IN) :: behaviour_L0, & reorder, PROKG INTEGER, INTENT(INOUT) :: PERM_RHS(SIZE_PERM) INTEGER :: I, J, K, IVAR, IBLOCK, & entry, & node, & SIZE_PERM_WORKING, & NB_NON_EMPTY, & to_be_found, & posintmprhs, & selected, & local_selected, & current_proc, & NPROCS, & n_pass, & pass, & nblocks, & n_select_loc, & IERR INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_RHS, & PTR_PROCS, & IPTR_PERM_WORKING, & PERM_WORKING, & MYTYPENODE INTEGER, ALLOCATABLE, DIMENSION(:) :: & PERM_PO, & ISTEP2BLOCK, & NEXTINBLOCK LOGICAL, ALLOCATABLE, DIMENSION(:) :: USED LOGICAL :: allow_above_L0 INTEGER, EXTERNAL :: MUMPS_TYPENODE_ROUGH NPROCS = SIZE_IPTR_WORKING - 1 ALLOCATE(TMP_RHS(SIZE_PERM), & PTR_PROCS(NPROCS), & USED(SIZE_PERM), & IPTR_PERM_WORKING(NPROCS+1), & MYTYPENODE(NSTEPS), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in DMUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF DO I=1, NSTEPS MYTYPENODE(I) = MUMPS_TYPENODE_ROUGH( PROCNODE(I), KEEP199 ) ENDDO NB_NON_EMPTY = 0 DO I=1,SIZE_PERM IF(IRHS_PTR(I+1)-IRHS_PTR(I).NE.0) THEN NB_NON_EMPTY = NB_NON_EMPTY + 1 END IF END DO K = 0 IPTR_PERM_WORKING(1)=1 DO I=1,NPROCS USED = .FALSE. DO J=IPTR_WORKING(I),IPTR_WORKING(I+1)-1 USED(WORKING(J)) = .TRUE. END DO DO J=1,N IF (USED(abs(STEP(PERM_RHS(J)))).AND. & ((IRHS_PTR(PERM_RHS(J)+1)-IRHS_PTR(PERM_RHS(J))).NE.0)) & THEN K = K + 1 END IF END DO IPTR_PERM_WORKING(I+1) = K+1 END DO SIZE_PERM_WORKING = K ALLOCATE(PERM_WORKING(SIZE_PERM_WORKING), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in DMUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF K = 0 DO I=1,NPROCS USED = .FALSE. DO J=IPTR_WORKING(I),IPTR_WORKING(I+1)-1 USED(WORKING(J)) = .TRUE. END DO DO J=1,N IF (USED(abs(STEP(PERM_RHS(J)))).AND. & ((IRHS_PTR(PERM_RHS(J)+1)-IRHS_PTR(PERM_RHS(J))).NE.0)) & THEN K = K + 1 PERM_WORKING(K) = PERM_RHS(J) END IF END DO END DO IF(behaviour_L0) THEN n_pass = 2 allow_above_L0 = .false. to_be_found = 0 DO I=1,SIZE_PERM IF((MYTYPENODE(abs(STEP(I))).LE.1).AND. & (IRHS_PTR(I+1)-IRHS_PTR(I).NE.0)) & THEN to_be_found = to_be_found + 1 END IF END DO ELSE n_pass = 1 allow_above_L0 = .true. to_be_found = NB_NON_EMPTY END IF PTR_PROCS(1:NPROCS) = IPTR_PERM_WORKING(1:NPROCS) USED = .FALSE. current_proc = 1 n_select_loc = n_select IF (n_select_loc.LE.0) THEN n_select_loc = 1 ENDIF posintmprhs = 0 DO pass=1,n_pass selected = 0 DO WHILE(selected.LT.to_be_found) local_selected = 0 DO WHILE(local_selected.LT.n_select_loc) IF(PTR_PROCS(current_proc).EQ. & IPTR_PERM_WORKING(current_proc+1)) & THEN EXIT ELSE entry = PERM_WORKING(PTR_PROCS(current_proc)) node = abs(STEP(entry)) IF(.NOT.USED(entry)) THEN IF(allow_above_L0.OR.(MYTYPENODE(node).LE.1)) THEN USED(entry) = .TRUE. selected = selected + 1 local_selected = local_selected + 1 posintmprhs = posintmprhs + 1 TMP_RHS(posintmprhs) = entry IF(selected.EQ.to_be_found) EXIT END IF END IF PTR_PROCS(current_proc) = PTR_PROCS(current_proc) + 1 END IF END DO current_proc = mod(current_proc,NPROCS)+1 END DO to_be_found = NB_NON_EMPTY - to_be_found allow_above_L0 = .true. PTR_PROCS(1:NPROCS) = IPTR_PERM_WORKING(1:NPROCS) END DO DO I=1,SIZE_PERM IF(IRHS_PTR(PERM_RHS(I)+1)-IRHS_PTR(PERM_RHS(I)).EQ.0) THEN posintmprhs = posintmprhs+1 TMP_RHS(posintmprhs) = PERM_RHS(I) IF(posintmprhs.EQ.SIZE_PERM) EXIT END IF END DO DEALLOCATE(PTR_PROCS, USED, & IPTR_PERM_WORKING, & PERM_WORKING, MYTYPENODE) IF(reorder) THEN nblocks = (N+NBRHS-1)/NBRHS ALLOCATE(PERM_PO(N), ISTEP2BLOCK(N), NEXTINBLOCK(nblocks), & stat=IERR) IF(IERR.GT.0) THEN IF (PROKG ) WRITE(MPG,*) & 'Warning: reorder not done in DMUMPS_INTERLEAVE_RHS_AM1' PERM_RHS = TMP_RHS GOTO 500 ENDIF DO IVAR = 1, N K = SYM_PERM( IVAR ) PERM_PO( K ) = IVAR END DO DO I = 1, N IBLOCK = 1 + ( I - 1 ) / NBRHS IVAR = TMP_RHS( I ) K = SYM_PERM( IVAR ) ISTEP2BLOCK( K ) = IBLOCK END DO DO IBLOCK = 1, NBLOCKS NEXTINBLOCK(IBLOCK) = 1 + (IBLOCK-1)*NBRHS ENDDO DO K = 1, N IBLOCK = ISTEP2BLOCK(K) IVAR = PERM_PO(K) PERM_RHS(NEXTINBLOCK(IBLOCK)) = IVAR NEXTINBLOCK(IBLOCK) = NEXTINBLOCK(IBLOCK) + 1 ENDDO ELSE PERM_RHS = TMP_RHS END IF 500 CONTINUE DEALLOCATE(TMP_RHS) IF (allocated(PERM_PO )) DEALLOCATE(PERM_PO ) IF (allocated(ISTEP2BLOCK)) DEALLOCATE(ISTEP2BLOCK) IF (allocated(NEXTINBLOCK)) DEALLOCATE(NEXTINBLOCK) RETURN END SUBROUTINE DMUMPS_INTERLEAVE_RHS_AM1 MUMPS_5.8.1/src/mumps_register_thread.h0000664000175000017500000000121715042446422017776 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_REGISTER_THREAD_H #define MUMPS_REGISTER_THREAD_H void mumps_register_thread_return(); { /* Registering tools will be available in the future. */ } #endif /* MUMPS_REGISTER_THREAD_H */ MUMPS_5.8.1/src/lr_common.F0000664000175000017500000000673115042446423015334 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_LR_COMMON IMPLICIT NONE INTEGER, PARAMETER :: NPREC_STOC_MAX = 10 INTEGER, PARAMETER :: NPREC_CALC_MAX = 3 CONTAINS SUBROUTINE COMPUTE_BLR_VCS(K472, IBCKSZ, MAXSIZE, NASS, & NFRONT, K35) INTEGER, INTENT(IN) :: MAXSIZE, NASS, K472 INTEGER, INTENT(IN) :: NFRONT, K35 INTEGER, INTENT(OUT) :: IBCKSZ IF (K472.EQ.1) THEN #if defined(__ve__) IF (NASS.LE.1000) THEN IBCKSZ = 256 ELSEIF (NASS.GT.1000.AND.NASS.LE.5000) THEN IBCKSZ = 384 ELSEIF (NASS.GT.5000.AND.NASS.LE.10000) THEN IBCKSZ = 512 ELSEIF (NASS.GT.10000.AND.NASS.LE.100000) THEN IBCKSZ = 512 ELSE IBCKSZ = 768 ENDIF #else IF (NASS.LE.1000) THEN IBCKSZ = 128 ELSEIF (NASS.GT.1000.AND.NASS.LE.5000) THEN IBCKSZ = 256 ELSEIF (NASS.GT.5000.AND.NASS.LE.10000) THEN IBCKSZ = 384 ELSEIF (NASS.GT.10000.AND.NASS.LE.100000) THEN IBCKSZ = 512 ELSE IBCKSZ = 768 ENDIF IF (NFRONT.GT.20*NASS.AND.NFRONT.GT.100000) THEN IBCKSZ = max(IBCKSZ,min(NASS,768)) ENDIF #endif IBCKSZ = min(IBCKSZ,MAXSIZE) ELSE IBCKSZ = MAXSIZE ENDIF RETURN END SUBROUTINE COMPUTE_BLR_VCS SUBROUTINE MUMPS_UPD_TREE(NV, NSTEPS, N, FIRST, LPTR, RPTR, F, & VLIST, FILS, FRERE_STEPS, STEP, DAD_STEPS, NE_STEPS, NA, LNA, & PVS, K38, STEP_SCALAPACK_ROOT) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NV, NSTEPS, LNA, F, VLIST(NV) INTEGER :: FILS(:), FRERE_STEPS(:), & DAD_STEPS(:), STEP(:), NE_STEPS(:), NA(:) INTEGER, INTENT(INOUT) :: PVS(NSTEPS), LPTR, RPTR INTEGER, INTENT(INOUT) :: K38 INTEGER, INTENT(IN) :: STEP_SCALAPACK_ROOT LOGICAL :: FIRST INTEGER :: PV, NODE, I PV = VLIST(1) NODE = ABS(STEP(PV)) PVS(NODE) = PV IF(FIRST) THEN I = DAD_STEPS(NODE) DO WHILE(FILS(I).GT.0) I = FILS(I) END DO FILS(I) = -PV END IF IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF IF(DAD_STEPS(NODE) .EQ. 0) THEN NA(RPTR) = PV RPTR = RPTR -1 ELSE DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF IF(NE_STEPS(NODE) .EQ. 0) THEN NA(LPTR) = PV LPTR = LPTR -1 END IF STEP(VLIST(1)) = ABS(STEP(VLIST(1))) IF (STEP(VLIST(1)).EQ.STEP_SCALAPACK_ROOT) THEN K38 = VLIST(1) ENDIF DO I=1, NV-1 IF(STEP(VLIST(I+1)).GT.0) STEP(VLIST(I+1)) = -STEP(VLIST(I+1)) FILS(VLIST(I)) = VLIST(I+1) END DO FILS(VLIST(NV)) = F RETURN END SUBROUTINE MUMPS_UPD_TREE END MODULE MUMPS_LR_COMMON MUMPS_5.8.1/src/cfac_mem_alloc_cb.F0000664000175000017500000001556315042446440016721 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, PROCESS_BANDE, & MYID,N, KEEP,KEEP8,DKEEP, & IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LREQ, LREQCB, NODE_ARG, STATE_ARG, SET_HEADER, & COMP, LRLUS, LRLUSM, IFLAG, IERROR ) !$ USE OMP_LIB USE MUMPS_LOAD IMPLICIT NONE INTEGER N,LIW, KEEP(500) INTEGER(8) LA, LRLU, IPTRLU, LRLUS, LRLUSM, LREQCB INTEGER(8) PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER IWPOS,IWPOSCB INTEGER(8) :: MIN_SPACE_IN_PLACE INTEGER NODE_ARG, STATE_ARG INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER IW(LIW),PTRIST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER MYID, IXXP COMPLEX A(LA) LOGICAL INPLACE, PROCESS_BANDE, SSARBR, SET_HEADER INTEGER COMP, LREQ, IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER INODE_LOC,NPIV,NASS,NROW,NCB INTEGER ISIZEHOLE INTEGER(8) :: MEM_GAIN, RSIZEHOLE, LREQCB_EFF, LREQCB_WISHED INTEGER(8) :: DYN_SIZE, KEEP8TMPCOPY IF ( INPLACE ) THEN LREQCB_EFF = MIN_SPACE_IN_PLACE IF ( MIN_SPACE_IN_PLACE > 0_8 ) THEN LREQCB_WISHED = LREQCB ELSE LREQCB_WISHED = 0_8 ENDIF ELSE LREQCB_EFF = LREQCB LREQCB_WISHED = LREQCB ENDIF IF (IWPOSCB.EQ.LIW) THEN IF (LREQ.NE.KEEP(IXSZ).OR.LREQCB.NE.0_8 & .OR. .NOT. SET_HEADER) THEN WRITE(*,*) "Internal error in CMUMPS_ALLOC_CB ", & SET_HEADER, LREQ, LREQCB CALL MUMPS_ABORT() ENDIF IF (IWPOSCB-IWPOS+1 .LT. KEEP(IXSZ)) THEN WRITE(*,*) "Problem with integer stack size",IWPOSCB, & IWPOS, KEEP(IXSZ) IFLAG = -8 IERROR = LREQ RETURN ENDIF IWPOSCB=IWPOSCB-KEEP(IXSZ) IW(IWPOSCB+1+XXI)=KEEP(IXSZ) CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXR)) CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXD)) IW(IWPOSCB+1+XXN)=-919191 IW(IWPOSCB+1+XXS)=S_NOTFREE IW(IWPOSCB+1+XXP)=TOP_OF_STACK RETURN ENDIF CALL MUMPS_GETI8( DYN_SIZE, IW(IWPOSCB+1 + XXD)) IF (DYN_SIZE .EQ. 0_8 & .AND. KEEP(214).EQ.1.AND. & KEEP(216).EQ.1.AND. & IWPOSCB.NE.LIW) THEN IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG.OR. & IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN NCB = IW( IWPOSCB+1 + KEEP(IXSZ) ) NROW = IW( IWPOSCB+1 + KEEP(IXSZ) + 2) NPIV = IW( IWPOSCB+1 + KEEP(IXSZ) + 3) INODE_LOC= IW( IWPOSCB+1 + XXN) CALL CMUMPS_GET_SIZEHOLE(IWPOSCB+1,IW,LIW, & ISIZEHOLE,RSIZEHOLE) IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG) THEN CALL CMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, & NROW,NCB,NPIV+NCB,0, & IW(IWPOSCB+1 + XXS),RSIZEHOLE) IW(IWPOSCB+1 + XXS) =S_NOLCLEANED MEM_GAIN = int(NROW,8)*int(NPIV,8) ENDIF IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN NASS = IW( IWPOSCB+1 + KEEP(IXSZ) + 4) CALL CMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, & NROW,NCB,NPIV+NCB,NASS-NPIV, & IW(IWPOSCB+1 + XXS),RSIZEHOLE) IW(IWPOSCB+1 + XXS) =S_NOLCLEANED38 MEM_GAIN = int(NROW,8)*int(NPIV+NCB-(NASS-NPIV),8) ENDIF IF (ISIZEHOLE.NE.0) THEN CALL CMUMPS_ISHIFT( IW,LIW,IWPOSCB+1, & IWPOSCB+IW(IWPOSCB+1+XXI), & ISIZEHOLE ) IWPOSCB=IWPOSCB+ISIZEHOLE IW(IWPOSCB+1+XXP+IW(IWPOSCB+1+XXI))=IWPOSCB+1 PTRIST(STEP(INODE_LOC))=PTRIST(STEP(INODE_LOC))+ & ISIZEHOLE ENDIF CALL MUMPS_SUBTRI8TOARRAY(IW(IWPOSCB+1+XXR), MEM_GAIN) IPTRLU = IPTRLU+MEM_GAIN+RSIZEHOLE LRLU = LRLU+MEM_GAIN+RSIZEHOLE PTRAST(STEP(INODE_LOC))= & PTRAST(STEP(INODE_LOC))+MEM_GAIN+RSIZEHOLE ENDIF ENDIF IF (LRLU.LT.LREQCB_WISHED)THEN IF (LREQCB_EFF.LT.LREQCB_WISHED) THEN CALL CMUMPS_COMPRE_NEW(N,KEEP,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD) ENDIF ENDIF CALL CMUMPS_GET_SIZE_NEEDED & (LREQ, LREQCB_EFF, .FALSE., & KEEP(1), KEEP8(1), & N,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 650 IXXP=IWPOSCB+XXP+1 IF (IXXP.GT.LIW) THEN WRITE(*,*) "Internal error 3 in CMUMPS_ALLOC_CB ",IXXP ENDIF IF (IW(IXXP).GT.0) THEN WRITE(*,*) "Internal error 2 in CMUMPS_ALLOC_CB ",IW(IXXP),IXXP ENDIF IWPOSCB = IWPOSCB - LREQ IF (SET_HEADER) THEN IW(IXXP)= IWPOSCB + 1 IW(IWPOSCB+1:IWPOSCB+1+KEEP(IXSZ))=-99999 IW(IWPOSCB+1+XXI)=LREQ CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXR)) CALL MUMPS_STOREI8(0_8, IW(IWPOSCB+1+XXD)) IW(IWPOSCB+1+XXS)=STATE_ARG IW(IWPOSCB+1+XXN)=NODE_ARG IW(IWPOSCB+1+XXP)=TOP_OF_STACK IW(IWPOSCB+1+XXNBPR)=0 ENDIF IPTRLU = IPTRLU - LREQCB LRLU = LRLU - LREQCB LRLUS = LRLUS - LREQCB_EFF LRLUSM = min(LRLUS, LRLUSM) IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) + LREQCB_EFF KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + LREQCB_EFF KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC ENDIF CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) 650 CONTINUE RETURN END SUBROUTINE CMUMPS_ALLOC_CB MUMPS_5.8.1/src/zsol_root_parallel.F0000664000175000017500000000752615042446441017260 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ROOT_SOLVE( NRHS, DESCA_PAR, & CNTXT_PAR,LOCAL_M,LOCAL_N,MBLOCK,NBLOCK, & IPIV,LPIV,MASTER_ROOT,MYID,COMM, & RHS_SEQ,SIZE_ROOT,A,INFO,MTYPE,LDLT ) IMPLICIT NONE INTEGER NRHS, MTYPE INTEGER DESCA_PAR( 9 ) INTEGER LOCAL_M, LOCAL_N, MBLOCK, NBLOCK INTEGER CNTXT_PAR, MASTER_ROOT, SIZE_ROOT INTEGER MYID, COMM INTEGER LPIV, IPIV( LPIV ) INTEGER INFO(80), LDLT COMPLEX(kind=8) RHS_SEQ( SIZE_ROOT *NRHS) COMPLEX(kind=8) A( LOCAL_M, LOCAL_N ) #if ! defined(NOSCALAPACK) INTEGER IERR, NPROW, NPCOL, MYROW, MYCOL INTEGER LOCAL_N_RHS COMPLEX(kind=8), ALLOCATABLE, DIMENSION( :,: ) ::RHS_PAR INTEGER, EXTERNAL :: MUMPS_NUMROC INTEGER allocok CALL blacs_gridinfo( CNTXT_PAR, NPROW, NPCOL, MYROW, MYCOL ) LOCAL_N_RHS = MUMPS_NUMROC(NRHS, NBLOCK, MYCOL, 0, NPCOL) LOCAL_N_RHS = max(1,LOCAL_N_RHS) ALLOCATE(RHS_PAR(LOCAL_M, LOCAL_N_RHS),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) ' Problem during solve of the root.' WRITE(*,*) ' Reduce number of right hand sides.' CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_SCATTER_ROOT( MYID, SIZE_ROOT, NRHS, RHS_SEQ, & LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) CALL ZMUMPS_SOLVE_2D_BCYCLIC (SIZE_ROOT, NRHS, MTYPE, & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, & IPIV, LPIV, RHS_PAR, LDLT, & MBLOCK, NBLOCK, CNTXT_PAR, & IERR) CALL ZMUMPS_GATHER_ROOT( MYID, SIZE_ROOT, NRHS, & RHS_SEQ, LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) DEALLOCATE(RHS_PAR) #endif RETURN END SUBROUTINE ZMUMPS_ROOT_SOLVE #if ! defined(NOSCALAPACK) SUBROUTINE ZMUMPS_SOLVE_2D_BCYCLIC (SIZE_ROOT, NRHS, MTYPE, & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, & IPIV, LPIV, RHS_PAR, LDLT, & MBLOCK, NBLOCK, CNTXT_PAR, & IERR) IMPLICIT NONE INTEGER, intent (in) :: SIZE_ROOT, NRHS, LDLT, LOCAL_M, & LOCAL_N, LOCAL_N_RHS, & MBLOCK, NBLOCK, CNTXT_PAR, MTYPE INTEGER, intent (in) :: DESCA_PAR( 9 ) INTEGER, intent (in) :: LPIV, IPIV( LPIV ) COMPLEX(kind=8), intent (in) :: A( LOCAL_M, LOCAL_N ) COMPLEX(kind=8), intent (inout) :: RHS_PAR(LOCAL_M, LOCAL_N_RHS) INTEGER, intent (out) :: IERR INTEGER :: DESCB_PAR( 9 ) IERR = 0 CALL DESCINIT( DESCB_PAR, SIZE_ROOT, & NRHS, MBLOCK, NBLOCK, 0, 0, & CNTXT_PAR, LOCAL_M, IERR ) IF (IERR.NE.0) THEN WRITE(*,*) 'After DESCINIT, IERR = ', IERR CALL MUMPS_ABORT() END IF IF ( LDLT .eq. 0 .OR. LDLT .eq. 2 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL pzgetrs('N',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, & RHS_PAR,1,1,DESCB_PAR,IERR) ELSE CALL pzgetrs('T',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, & RHS_PAR, 1, 1, DESCB_PAR,IERR) END IF ELSE CALL pzpotrs( 'L', SIZE_ROOT, NRHS, A, 1, 1, DESCA_PAR, & RHS_PAR, 1, 1, DESCB_PAR, IERR ) END IF IF ( IERR .LT. 0 ) THEN WRITE(*,*) ' Problem during solve of the root' CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE ZMUMPS_SOLVE_2D_BCYCLIC #endif MUMPS_5.8.1/src/cfac_front_aux.F0000664000175000017500000026435715042446440016341 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC_FRONT_AUX_M CONTAINS SUBROUTINE CMUMPS_FAC_H(NFRONT,NASS,IW,LIW,A,LA, & INOPV,NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IOLDPS,POSELT,UU,SEUIL,KEEP, KEEP8, DKEEP, & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U,MAXFROMN,IS_MAXFROMN_AVAIL, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, NVSCHUR &) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,LIW,INOPV INTEGER(8) :: LA INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) REAL :: DKEEP(230) REAL UU, SEUIL COMPLEX A(LA) INTEGER IW(LIW) REAL, intent(in) :: MAXFROMN LOGICAL, intent(inout) :: IS_MAXFROMN_AVAIL INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER, intent(in) :: NVSCHUR REAL AMROW REAL RMAX, SEUIL_LOC COMPLEX SWOP INTEGER(8) :: APOS, POSELT INTEGER(8) :: J1, J2, J3_8, JJ, IDIAG INTEGER(8) :: J1_ini INTEGER(8) :: NFRONT8 INTEGER IOLDPS INTEGER NPIV,IPIV,IPIV_SHIFT INTEGER, intent(inout) :: NOFFW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX, intent(inout) :: DET_MANTW INTEGER J, J3 INTEGER NPIVP1,JMAX,ISW,ISWPS1 INTEGER ISWPS2,KSW,XSIZE INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INTEGER ISHIFT, K206 INTEGER CMUMPS_IXAMAX INCLUDE 'mumps_headers.h' INTRINSIC max REAL, PARAMETER :: RZERO = 0.0E0 #if defined(_OPENMP) INTEGER :: NOMP, CHUNK NOMP = OMP_GET_MAX_THREADS() #endif SEUIL_LOC = max(DKEEP(1), SEUIL) NFRONT8 = int(NFRONT,8) INOPV = 0 XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 K206 = KEEP(206) IF ((KEEP(50).NE.1).AND.OOC_EFFECTIVE_ON_FRONT) THEN CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE) & +KEEP(IXSZ), & IW, LIW) CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF ISHIFT = 0 IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.NASS) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF (ISHIFT.GT.0.AND.IS_MAXFROMN_AVAIL) THEN IPIV = NPIVP1 APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)) .GE. UU*MAXFROMN .AND. & abs(A(IDIAG)) .GT. max(SEUIL_LOC,tiny(RMAX)) & ) THEN ISHIFT = 0 ENDIF ENDIF IF ( ISHIFT .GT. 0) THEN IS_MAXFROMN_AVAIL = .FALSE. ENDIF ENDIF DO 460 IPIV_SHIFT=NPIVP1+ISHIFT,NASS+ISHIFT IF (IPIV_SHIFT .LE. NASS) THEN IPIV=IPIV_SHIFT ELSE IPIV=IPIV_SHIFT-NASS-1+NPIVP1 ENDIF APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) JMAX = 1 AMROW = RZERO J1 = APOS J3 = NASS -NPIV JMAX = CMUMPS_IXAMAX(J3,A(J1),NFRONT,KEEP(360)) JJ = J1 + int(JMAX-1,8)*NFRONT8 AMROW = abs(A(JJ)) RMAX = AMROW J1 = APOS + int(NASS-NPIV,8) * NFRONT8 J3 = NFRONT - NASS - KEEP(253)-NVSCHUR IF (IS_MAXFROMN_AVAIL) THEN RMAX = max(MAXFROMN,RMAX) IS_MAXFROMN_AVAIL = .FALSE. ELSE IF (J3.EQ.0) GOTO 370 #if defined(_OPENMP) IF (J3.GE.KEEP(360)) THEN J1_ini = J1 CHUNK = max(KEEP(360)/2,(J3+NOMP-1)/NOMP) !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& FIRSTPRIVATE(J1_ini,NFRONT8,J3) !$OMP& REDUCTION(max:RMAX) DO J=1,J3 RMAX = max(abs(A(J1_ini + int(J-1,8) * NFRONT8)), & RMAX) END DO !$OMP END PARALLEL DO ELSE #endif DO J=1,J3 RMAX = max(abs(A(J1)), RMAX) J1 = J1 + NFRONT8 END DO #if defined(_OPENMP) ENDIF #endif END IF 370 IF (RMAX.LE.tiny(RMAX)) GO TO 460 IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)) .GE. UU*RMAX .AND. & abs(A(IDIAG)) .GT. max(SEUIL_LOC,tiny(RMAX)) ) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF ( .NOT. ( AMROW .GE. UU*RMAX .AND. & AMROW .GT. max(SEUIL_LOC,tiny(RMAX)) & ) & ) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS + int(JMAX - 1,8) * NFRONT8 )), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER( & A(APOS + int(JMAX - 1,8) * NFRONT8 ), & DET_MANTW, DET_EXPW ) ENDIF IF ( IPIV .NE. NPIVP1 .OR. JMAX .NE. 1) THEN IF (KEEP(405) .EQ.0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF ENDIF IF (IPIV.EQ.NPIVP1) GO TO 400 DET_SIGNW = - DET_SIGNW J1 = POSELT + int(NPIV,8) J3_8 = POSELT + int(IPIV-1,8) DO J= 1,NFRONT SWOP = A(J1) A(J1) = A(J3_8) A(J3_8) = SWOP J1 = J1 + NFRONT8 J3_8 = J3_8 + NFRONT8 END DO ISWPS1 = IOLDPS + 5 + NPIVP1 + NFRONT + XSIZE ISWPS2 = IOLDPS + 5 + IPIV + NFRONT + XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW 400 IF (JMAX.EQ.1) GO TO 420 DET_SIGNW = -DET_SIGNW J1 = POSELT + int(NPIV,8) * NFRONT8 J2 = POSELT + int(NPIV + JMAX - 1,8) * NFRONT8 DO KSW=1,NFRONT SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + 1_8 J2 = J2 + 1_8 END DO ISWPS1 = IOLDPS + 5 + NPIV + 1 + XSIZE ISWPS2 = IOLDPS + 5 + NPIV + JMAX + XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE INOPV = 1 GOTO 430 420 CONTINUE IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE IS_MAXFROMN_AVAIL = .FALSE. RETURN END SUBROUTINE CMUMPS_FAC_H SUBROUTINE CMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP,MAXFROMN,IS_MAXFROMN_AVAIL,NVSCHUR) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER NFRONT,NASS,LIW,IFINB INTEGER(8) :: LA COMPLEX A(LA) INTEGER IW(LIW) COMPLEX ALPHA,VALPIV INTEGER(8) :: APOS, POSELT, UUPOS, LPOS, IRWPOS INTEGER(8) :: NFRONT8 INTEGER IOLDPS,NPIV,XSIZE INTEGER, intent(in) :: KEEP(500) REAL, intent(inout) :: MAXFROMN LOGICAL, intent(inout) :: IS_MAXFROMN_AVAIL INTEGER, intent(in) :: NVSCHUR INTEGER NEL,IROW,NEL2,JCOL,NELMAXM INTEGER NPIVP1 COMPLEX, PARAMETER :: ONE=(1.0E0,0.0E0) #if defined(_OPENMP) LOGICAL:: OMP_FLAG INTEGER:: NOMP, CHUNK NOMP = OMP_GET_MAX_THREADS() #endif NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 NELMAXM= NEL -KEEP(253)-NVSCHUR NEL2 = NASS - NPIVP1 IFINB = 0 IF (NPIVP1.EQ.NASS) IFINB = 1 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) #if defined(_OPENMP) OMP_FLAG = .FALSE. CHUNK = max(NEL,1) IF (NOMP.GT.1) THEN IF (NEL.LT.KEEP(360)) THEN IF (NEL*NEL2.GE.KEEP(361)) THEN OMP_FLAG = .TRUE. CHUNK = max(20, (NEL+NOMP-1)/NOMP) ENDIF ELSE OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2, (NEL+NOMP-1)/NOMP) ENDIF ENDIF #endif IF (KEEP(351).EQ.1) THEN MAXFROMN = 0.0E0 IF (NEL2 > 0) THEN IS_MAXFROMN_AVAIL = .TRUE. ENDIF !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& PRIVATE(LPOS, UUPOS, IRWPOS, ALPHA, JCOL) !$OMP& FIRSTPRIVATE(APOS,NFRONT8,VALPIV,NEL,NEL2) !$OMP& REDUCTION(max:MAXFROMN) IF(OMP_FLAG) DO IROW = 1, NEL LPOS = APOS + NFRONT8*int(IROW,8) A(LPOS) = A(LPOS)*VALPIV ALPHA = -A(LPOS) IRWPOS = LPOS + 1_8 UUPOS = APOS + 1_8 IF (NEL2 > 0) THEN A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IF (IROW.LE.NELMAXM) & MAXFROMN=max(MAXFROMN, abs(A(IRWPOS))) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 DO JCOL = 2, NEL2 A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 ENDDO ENDIF END DO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& FIRSTPRIVATE(APOS,NFRONT8,VALPIV,NEL,NEL2) !$OMP& PRIVATE(LPOS, UUPOS, IRWPOS, ALPHA, JCOL) IF(OMP_FLAG) DO IROW = 1, NEL LPOS = APOS + NFRONT8*int(IROW,8) A(LPOS) = A(LPOS)*VALPIV ALPHA = -A(LPOS) IRWPOS = LPOS + 1_8 UUPOS = APOS + 1_8 DO JCOL = 1, NEL2 A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE CMUMPS_FAC_N SUBROUTINE CMUMPS_FAC_PT_SETLOCK427( K427_OUT, K427, & K405, K222, NEL1, NASS ) INTEGER, INTENT(IN) :: K427, K405, K222, NEL1, NASS INTEGER, INTENT(OUT) :: K427_OUT K427_OUT = K427 IF ( K427_OUT .GT. 0 ) K427_OUT = 0 IF ( K427_OUT .LT. 0 ) K427_OUT = -1 RETURN END SUBROUTINE CMUMPS_FAC_PT_SETLOCK427 SUBROUTINE CMUMPS_FAC_P(A,LA,NFRONT, & NPIV,NASS,POSELT,CALL_UTRSM, KEEP, INODE, & CALL_OOC, IWFAC, LIWFAC, LAFAC, MonBloc, MYID, KEEP8, & LNextPiv2beWritten, UNextPiv2beWritten, & IFLAG ) USE CMUMPS_OOC, ONLY : IO_BLOCK, TYPEF_BOTH_LU, & CMUMPS_OOC_IO_LU_PANEL USE MUMPS_OOC_COMMON, ONLY : STRAT_TRY_WRITE IMPLICIT NONE INTEGER(8) :: LA,POSELT,LAFAC COMPLEX A(LA) INTEGER NFRONT, NPIV, NASS LOGICAL, INTENT(IN) :: CALL_UTRSM INTEGER, INTENT(INOUT) :: IFLAG LOGICAL, INTENT(IN) :: CALL_OOC INTEGER LIWFAC, MYID, & LNextPiv2beWritten, UNextPiv2beWritten INTEGER IWFAC(LIWFAC) TYPE(IO_BLOCK) :: MonBloc INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS INTEGER NEL1, NEL11, IFLAG_OOC INTEGER :: INODE COMPLEX ALPHA, ONE PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) INCLUDE 'mumps_headers.h' NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV LPOS2 = POSELT + int(NASS,8)*int(NFRONT,8) LPOS = LPOS2 + int(NPIV,8) LPOS1 = POSELT + int(NPIV,8) UPOS = POSELT + int(NASS,8) IF ( CALL_UTRSM ) THEN CALL ctrsm('R', 'U', 'N', 'U', NEL1, NPIV, ONE, & A(POSELT), NFRONT, A(UPOS), NFRONT) ENDIF CALL ctrsm('L','L','N','N',NPIV,NEL1,ONE,A(POSELT),NFRONT, & A(LPOS2),NFRONT) IF (CALL_OOC) THEN CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT_TRY_WRITE, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IWFAC, LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, & .FALSE. ) IF (IFLAG_OOC .LT. 0) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF CALL cgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) IF ((CALL_UTRSM).AND.(NASS-NPIV.GT.0)) THEN LPOS2 = POSELT + int(NPIV,8)*int(NFRONT,8) LPOS = LPOS2 + int(NASS,8) CALL cgemm('N','N',NEL1,NASS-NPIV,NPIV,ALPHA,A(UPOS), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_P SUBROUTINE CMUMPS_FAC_T(A,LA,NPIVB,NFRONT, & NPIV,NASS,POSELT) IMPLICIT NONE INTEGER NPIVB,NASS INTEGER(8) :: LA COMPLEX A(LA) INTEGER(8) :: APOS, POSELT INTEGER NFRONT, NPIV, NASSL INTEGER(8) :: LPOS, LPOS1, LPOS2 INTEGER NEL1, NEL11, NPIVE COMPLEX ALPHA, ONE PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV NPIVE = NPIV - NPIVB NASSL = NASS - NPIVB APOS = POSELT + int(NPIVB,8)*int(NFRONT,8) & + int(NPIVB,8) LPOS2 = APOS + int(NASSL,8) CALL ctrsm('R','U','N','U',NEL1,NPIVE,ONE,A(APOS),NFRONT, & A(LPOS2),NFRONT) LPOS = LPOS2 + int(NFRONT,8)*int(NPIVE,8) LPOS1 = APOS + int(NFRONT,8)*int(NPIVE,8) CALL cgemm('N','N',NEL1,NEL11,NPIVE,ALPHA,A(LPOS2), & NFRONT,A(LPOS1),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE CMUMPS_FAC_T SUBROUTINE CMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, NPIV, & NFRONT, LAST_ROW, LAST_COL, A, LA, POSELT, & FIRST_COL, CALL_LTRSM, CALL_UTRSM, CALL_GEMM, & WITH_COMM_THREAD, LR_ACTIVATED & ) !$ USE OMP_LIB #if defined(_OPENMP) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_TEST #endif IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: NPIV, NFRONT, LAST_ROW, LAST_COL INTEGER, intent(in) :: FIRST_COL INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: CALL_LTRSM, CALL_UTRSM, CALL_GEMM LOGICAL, intent(in) :: WITH_COMM_THREAD, LR_ACTIVATED INTEGER(8) :: NFRONT8, LPOSN, LPOS2N INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS, POSELT_LOCAL INTEGER :: NELIM, LKJIW, NEL1, NEL11, UTRSM_NCOLS COMPLEX ALPHA, ONE PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) !$ INTEGER :: NOMP !$ LOGICAL :: TRSM_GEMM_FINISHED !$ LOGICAL :: SAVE_NESTED, SAVE_DYNAMIC NFRONT8= int(NFRONT,8) NELIM = IEND_BLOCK - NPIV NEL1 = LAST_ROW - IEND_BLOCK IF ( NEL1 < 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_FAC_SQ,IEND_BLOCK>LAST_ROW", & IEND_BLOCK, LAST_ROW CALL MUMPS_ABORT() ENDIF LKJIW = NPIV - IBEG_BLOCK + 1 NEL11 = LAST_COL - NPIV LPOS2 = POSELT + int(IEND_BLOCK,8)*NFRONT8 + int(IBEG_BLOCK-1,8) UTRSM_NCOLS = LAST_COL - FIRST_COL UPOS = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 + int(FIRST_COL,8) POSELT_LOCAL = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 & + int(IBEG_BLOCK-1,8) IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN IF (WITH_COMM_THREAD .EQV. .FALSE.) THEN IF (CALL_LTRSM) THEN CALL ctrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) ENDIF IF (CALL_UTRSM) THEN CALL ctrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL cgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF IF (CALL_GEMM) THEN LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSELT_LOCAL + int(LKJIW,8) CALL cgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF ELSE !$ NOMP = OMP_GET_MAX_THREADS() !$ CALL OMP_SET_NUM_THREADS(2) !$ SAVE_NESTED = OMP_GET_NESTED() !$ SAVE_DYNAMIC = OMP_GET_DYNAMIC() !$ CALL OMP_SET_NESTED(.TRUE.) !$ CALL OMP_SET_DYNAMIC(.FALSE.) !$ TRSM_GEMM_FINISHED = .FALSE. !$OMP PARALLEL SHARED(TRSM_GEMM_FINISHED) !$ IF (OMP_GET_THREAD_NUM() .EQ. 1) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL OMP_SET_NUM_THREADS(int(NOMP,4)) #else !$ CALL OMP_SET_NUM_THREADS(NOMP) #endif IF (CALL_LTRSM) THEN CALL ctrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) ENDIF IF (CALL_UTRSM) THEN CALL ctrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL cgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF IF (CALL_GEMM) THEN LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSELT_LOCAL + int(LKJIW,8) CALL cgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) END IF !$ TRSM_GEMM_FINISHED = .TRUE. !$ ELSE !$ DO WHILE (.NOT. TRSM_GEMM_FINISHED) !$ CALL MUMPS_BUF_TEST() !$ CALL MUMPS_USLEEP(10000) !$ END DO !$ END IF !$OMP END PARALLEL !$ CALL OMP_SET_NESTED(SAVE_NESTED) !$ CALL OMP_SET_DYNAMIC(SAVE_DYNAMIC) #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL OMP_SET_NUM_THREADS(int(NOMP,4)) #else !$ CALL OMP_SET_NUM_THREADS(NOMP) #endif ENDIF ELSE IF (CALL_UTRSM.AND.UTRSM_NCOLS.NE.0) THEN CALL ctrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL cgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_FAC_SQ SUBROUTINE CMUMPS_FAC_MQ(IBEG_BLOCK,IEND_BLOCK, & NFRONT, NASS, NPIV, LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED & ) IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK, NFRONT, & NASS, NPIV, LAST_COL INTEGER, intent(out) :: IFINB INTEGER(8), intent(in) :: LA, POSELT COMPLEX, intent(inout) :: A(LA) LOGICAL, intent(in) :: LR_ACTIVATED COMPLEX :: VALPIV INTEGER(8) :: APOS, UUPOS, LPOS INTEGER(8) :: NFRONT8 COMPLEX :: ONE, ALPHA INTEGER :: NEL2,NPIVP1,KROW,NEL PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) NFRONT8= int(NFRONT,8) NPIVP1 = NPIV + 1 NEL = LAST_COL - NPIVP1 IFINB = 0 NEL2 = IEND_BLOCK - NPIVP1 IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ELSE APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 541 KROW = 1,NEL2 A(LPOS) = A(LPOS)*VALPIV LPOS = LPOS + NFRONT8 541 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS + 1_8 #if defined(MUMPS_USE_BLAS2) CALL cgeru(NEL,NEL2,ALPHA,A(UUPOS),1,A(LPOS),NFRONT, & A(LPOS+1_8),NFRONT) #else CALL cgemm('N','N',NEL,NEL2,1,ALPHA,A(UUPOS),NEL, & A(LPOS),NFRONT,ONE,A(LPOS+1_8),NFRONT) #endif ENDIF RETURN END SUBROUTINE CMUMPS_FAC_MQ SUBROUTINE CMUMPS_FAC_FR_UPDATE_CBROWS( INODE, NFRONT, NASS, & CALL_UTRSM, A, LA, LAFAC, POSELT, IW, LIW, IOLDPS, & MonBloc, MYID, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR) USE CMUMPS_OOC, ONLY: IO_BLOCK IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS, & LIW, MYID, XSIZE, IOLDPS, LIWFAC INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(inout) :: NOFFW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX, intent(inout) :: DET_MANTW INTEGER, intent(inout) :: PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & IFLAG LOGICAL, intent(in) :: CALL_UTRSM INTEGER, intent(inout) :: IW(LIW) COMPLEX, intent(inout) :: A(LA) REAL, intent(in) :: SEUIL, UU, DKEEP(230) INTEGER, intent(in) :: KEEP( 500 ) INTEGER(8), intent(inout) :: LAFAC INTEGER(8) :: KEEP8(150) INTEGER, intent(in) :: NVSCHUR TYPE(IO_BLOCK), intent(inout) :: MonBloc LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER :: NPIV, NEL1, IBEG_BLOCK, IFINB, INOPV INTEGER Inextpiv REAL :: MAXFROMN LOGICAL :: IS_MAXFROMN_AVAIL NPIV = IW(IOLDPS+1+XSIZE) NEL1 = NFRONT - NASS IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF IF ((NPIV.GT.0).AND.(NEL1.GT.0)) THEN IF (OOC_EFFECTIVE_ON_FRONT) THEN MonBloc%LastPiv = NPIV ENDIF CALL CMUMPS_FAC_P(A,LA,NFRONT, NPIV, NASS, POSELT, & CALL_UTRSM, KEEP, INODE, & OOC_EFFECTIVE_ON_FRONT, IW(IOLDPS), & LIWFAC, LAFAC, & MonBloc, MYID, KEEP8, & LNextPiv2beWritten, UNextPiv2beWritten, & IFLAG) ENDIF NPIV = IW(IOLDPS+1+XSIZE) IBEG_BLOCK = NPIV IF (NASS.EQ.NPIV) GOTO 500 IF (KEEP(19).GT.0) THEN GOTO 500 ENDIF IS_MAXFROMN_AVAIL = .FALSE. 120 CALL CMUMPS_FAC_H(NFRONT,NASS,IW,LIW,A,LA, & INOPV, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IOLDPS,POSELT,UU,SEUIL, & KEEP, KEEP8, DKEEP, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, MAXFROMN, IS_MAXFROMN_AVAIL, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, NVSCHUR & ) IF (INOPV.NE.1) THEN CALL CMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP, MAXFROMN, IS_MAXFROMN_AVAIL, & NVSCHUR) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) GOTO 120 ENDIF NPIV = IW(IOLDPS+1+XSIZE) NEL1 = NFRONT - NASS IF ((NPIV.LE.IBEG_BLOCK).OR.(NEL1.EQ.0)) GO TO 500 CALL CMUMPS_FAC_T(A,LA,IBEG_BLOCK, & NFRONT,NPIV,NASS,POSELT) 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_FR_UPDATE_CBROWS SUBROUTINE CMUMPS_FAC_I(NFRONT,NASS,LAST_ROW, & IBEG_BLOCK, IEND_BLOCK, & N,INODE,IW,LIW,A,LA, & INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UU,SEUIL,KEEP,KEEP8, & DKEEP,PIVNUL_LIST_STRUCT, SWAP_OCCURRED, & & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR, PARPIV_T1, & TIPIV & ) !$ USE OMP_LIB USE MUMPS_OOC_COMMON USE MUMPS_PIVNUL_MOD IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(inout), OPTIONAL :: TIPIV(:) INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER, intent(in) :: NFRONT,NASS,N,LIW,INODE,LAST_ROW INTEGER, intent(inout) :: IFLAG,IERROR, INOPV,NOFFW, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX, intent(inout) :: DET_MANTW REAL, intent(in) :: UU, SEUIL INTEGER, intent(inout) :: IW(LIW) INTEGER, intent(in) :: IOLDPS INTEGER(8), intent(in) :: POSELT INTEGER KEEP(500) INTEGER(8) KEEP8(150) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT LOGICAL, intent(inout) :: SWAP_OCCURRED REAL DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER, intent(in) :: NVSCHUR INTEGER, intent(in) :: PARPIV_T1 INCLUDE 'mumps_headers.h' COMPLEX SWOP INTEGER XSIZE INTEGER(8) :: APOS, IDIAG INTEGER(8) :: J1, J2, JJ, J3 INTEGER(8) :: NFRONT8 INTEGER ILOC COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) REAL RZERO, RMAX, AMROW, MAX_PREV_in_PARPIV REAL RCMAX INTEGER(8) :: APOSMAX, APOSROW REAL :: RMAX_NORELAX REAL PIVNUL, ABS_PIVOT COMPLEX FIXA, CSEUIL, PIVOT INTEGER NPIV,IPIV, LRLOC INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 INTEGER ISWPS2,KSW, HF, IPIVNUL INTEGER CMUMPS_IXAMAX INTEGER :: ISHIFT, K206 INTEGER :: IPIV_SHIFT,IPIV_END INTRINSIC max DATA RZERO /0.0E0/ #if defined(_OPENMP) INTEGER :: NOMP,CHUNK #endif INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U #if defined(_OPENMP) NOMP = OMP_GET_MAX_THREADS() #endif PIVNUL = DKEEP(1) FIXA = cmplx(DKEEP(2),kind=kind(FIXA)) CSEUIL = cmplx(SEUIL,kind=kind(CSEUIL)) NFRONT8 = int(NFRONT,8) K206 = KEEP(206) XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE NPIVP1 = NPIV + 1 APOSMAX = POSELT+NFRONT8*NFRONT8-1_8 IF (OOC_EFFECTIVE_ON_FRONT) THEN CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF IF ( present(TIPIV) ) THEN ILOC = NPIVP1 - IBEG_BLOCK + 1 TIPIV(ILOC) = ILOC ENDIF IF (INOPV .EQ. -1) THEN JMAX=1 APOS = POSELT + NFRONT8*int(NPIVP1-1,8) + int(NPIV,8) PIVOT = A(APOS) ABS_PIVOT = abs(PIVOT) IDIAG = APOS CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .TRUE.) IF(ABS_PIVOT.LT.SEUIL) THEN IF (real(PIVOT) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF GO TO 430 ENDIF INOPV = 0 ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) JMAX = 1 IF ((PIVOT_OPTION.EQ.0).OR.(UU.EQ.RZERO)) THEN ABS_PIVOT = abs(A(APOS)) IF(ABS_PIVOT.LT.SEUIL) THEN CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .TRUE.) IF (real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 GO TO 420 ELSE IF (ABS_PIVOT.EQ.RZERO) THEN GO TO 630 ENDIF GO TO 380 ENDIF AMROW = RZERO J1 = APOS IF (PIVOT_OPTION.EQ.1 .OR. (LR_ACTIVATED .AND. & (KEEP(480).GE.2 & ))) THEN J = IEND_BLR - NPIV ELSE J = NASS - NPIV ENDIF J2 = J1 + J - 1_8 JMAX = CMUMPS_IXAMAX(J,A(J1),1,KEEP(361)) JJ = J1 + int(JMAX - 1,8) AMROW = abs(A(JJ)) RMAX = AMROW IF (PIVOT_OPTION.GE.2) THEN J1 = J2 + 1_8 IF (PIVOT_OPTION.GE.3 & ) THEN J2 = APOS + & int(- NPIV + NFRONT - 1 - KEEP(253) - NVSCHUR,8) ELSE J2 = APOS +int(- NPIV + NASS - 1 ,8) ENDIF IF (J2.LT.J1) GO TO 370 IF (KEEP(351).EQ.1 .AND. J2-J1.GT.KEEP(361)) THEN !$ CHUNK = max(KEEP(361)/2,(int(J2-J1)+NOMP-1)/NOMP) !$OMP PARALLEL DO schedule(static, CHUNK) PRIVATE(JJ) !$OMP& FIRSTPRIVATE(J1,J2) !$OMP& REDUCTION(max:RMAX) DO JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) ENDDO !$OMP END PARALLEL DO ELSE DO 360 JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) 360 CONTINUE ENDIF 370 CONTINUE ENDIF IDIAG = APOS + int(IPIV - NPIVP1,8) ABS_PIVOT = abs(A(IDIAG)) IF (PARPIV_T1.NE.0) THEN RMAX_NORELAX = real(A(APOSMAX+int(IPIV,8))) ELSE RMAX_NORELAX = RZERO ENDIF RMAX = max(RMAX,RMAX_NORELAX) IF ( RMAX .LE. PIVNUL ) THEN IF (LAST_ROW.EQ.NFRONT) THEN LRLOC = LAST_ROW -KEEP(253)-NVSCHUR ELSE LRLOC = LAST_ROW ENDIF IF (NFRONT - KEEP(253) .EQ. NASS) THEN IF (IEND_BLOCK.NE.NASS ) THEN GOTO 460 ENDIF J1=POSELT+int(IPIV-1,8)+int(NPIV,8)*NFRONT8 J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 ELSE J1=POSELT+int(IPIV-1,8) J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 ENDIF DO JJ=J1, J2, NFRONT8 IF ( abs(A(JJ)) .GT. PIVNUL ) THEN GOTO 460 END IF ENDDO IF ((PARPIV_T1.NE.0) & .AND.(PARPIV_T1.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & real(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + NFRONT8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) GOTO 460 ENDDO ENDIF ENDIF CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .TRUE.) !$OMP ATOMIC CAPTURE KEEP(109) = KEEP(109)+1 IPIVNUL = KEEP(109) !$OMP END ATOMIC IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST.LT.KEEP(109)) & THEN CALL MUMPS_RESIZE_PIVNUL(KEEP, N, PIVNUL_LIST_STRUCT, & IPIVNUL, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 430 ENDIF IF (KEEP(405).EQ.1) THEN !$OMP CRITICAL(critical_pivnul) PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) !$OMP END CRITICAL(critical_pivnul) ELSE PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) ENDIF IF(real(FIXA).GT.RZERO) THEN IF(real(A(IDIAG)) .GE. RZERO) THEN A(IDIAG) = FIXA ELSE A(IDIAG) = -FIXA ENDIF ELSE J1 = APOS J2 = APOS + & int(- NPIV + NFRONT - 1 - KEEP(253),8) DO JJ=J1,J2 A(JJ) = ZERO ENDDO A(IDIAG) = -FIXA ENDIF JMAX = IPIV - NPIV GOTO 385 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF (ABS_PIVOT .GE. UU*RMAX .AND. & ABS_PIVOT .GT. max(SEUIL,tiny(RMAX))) THEN IF (KEEP(19).GT.0) THEN IF (LAST_ROW.EQ.NFRONT) THEN LRLOC = LAST_ROW -KEEP(253)-NVSCHUR ELSE LRLOC = LAST_ROW ENDIF J1=POSELT+int(IPIV-1,8)+int(NPIV,8)*NFRONT8 J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 RCMAX = RZERO DO JJ=J1, J2, NFRONT8 RCMAX = max(abs(A(JJ)),RCMAX) ENDDO IF (ABS_PIVOT .GE. UU*RCMAX) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF ELSE JMAX = IPIV - NPIV GO TO 380 ENDIF ENDIF IF ( .NOT. (AMROW .GE. UU*RMAX .AND. & AMROW .GT. max(SEUIL,tiny(RMAX))) ) GO TO 460 IF (KEEP(19).GT.0) THEN IF (LAST_ROW.EQ.NFRONT) THEN LRLOC = LAST_ROW -KEEP(253)-NVSCHUR ELSE LRLOC = LAST_ROW ENDIF J1=POSELT+int(NPIV+JMAX-1,8)+int(NPIV,8)*NFRONT8 J2=POSELT+int(NPIV+JMAX-1,8)+int(LRLOC-1,8)*NFRONT8 RCMAX = RZERO DO JJ=J1, J2, NFRONT8 RCMAX = max(abs(A(JJ)),RCMAX) ENDDO IF (.NOT.(AMROW .GE. UU*RCMAX) ) THEN GO TO 460 ENDIF ENDIF NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS+int(JMAX-1,8))), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER( A(APOS+int(JMAX-1,8)), & DET_MANTW, & DET_EXPW ) ENDIF 385 CONTINUE IF ( IPIV .NE. NPIVP1 .OR. JMAX .NE. 1 ) THEN SWAP_OCCURRED = .TRUE. IF (KEEP(405) .EQ. 0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF ENDIF IF (IPIV.EQ.NPIVP1) GO TO 400 IF (PARPIV_T1.NE.0) THEN SWOP = A(APOSMAX+int(NPIVP1,8)) A(APOSMAX+int(NPIVP1,8)) = A(APOSMAX+int(IPIV,8)) A(APOSMAX+int(IPIV,8)) = SWOP ENDIF DET_SIGNW = - DET_SIGNW J1 = POSELT + int(NPIV,8)*NFRONT8 J2 = J1 + NFRONT8 - 1_8 J3 = POSELT + int(IPIV-1,8)*NFRONT8 DO 390 JJ=J1,J2 SWOP = A(JJ) A(JJ) = A(J3) A(J3) = SWOP J3 = J3 + 1_8 390 CONTINUE ISWPS1 = IOLDPS + HF - 1 + NPIVP1 ISWPS2 = IOLDPS + HF - 1 + IPIV ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW 400 IF (JMAX.EQ.1) GO TO 420 DET_SIGNW = - DET_SIGNW IF ( present(TIPIV) ) THEN TIPIV(ILOC) = ILOC + JMAX - 1 ENDIF J1 = POSELT + int(NPIV,8) J2 = POSELT + int(NPIV + JMAX - 1,8) DO 410 KSW=1,LAST_ROW SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + NFRONT8 J2 = J2 + NFRONT8 410 CONTINUE ISWPS1 = IOLDPS + HF - 1 + NFRONT + NPIV + 1 ISWPS2 = IOLDPS + HF - 1 + NFRONT + NPIV + JMAX ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 430 630 CONTINUE IFLAG = -10 GOTO 430 420 CONTINUE IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_I SUBROUTINE CMUMPS_FAC_I_LDLT & ( NFRONT,NASS,N,INODE,IBEG_BLOCK,IEND_BLOCK, & IW,LIW, A,LA, INOPV, & NNEGW, NNULLNEGW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IERROR,IOLDPS,POSELT,UU, SEUIL,KEEP,KEEP8,PIVSIZ, & DKEEP, PIVNUL_LIST_STRUCT, SWAP_OCCURRED, XSIZE, & PP_FIRST2SWAP_L, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled,MAXFROMM,IS_MAXFROMM_AVAIL, & PIVOT_OPTION, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, LR_ACTIVATED & ) !$ USE OMP_LIB USE MUMPS_OOC_COMMON USE MUMPS_PIVNUL_MOD IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER NFRONT,NASS,LIW,N,INODE,IFLAG,IERROR,INOPV, & IOLDPS INTEGER, intent(inout) :: NNEGW, NNULLNEGW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX, intent(inout) :: DET_MANTW INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: PIVOT_OPTION,IEND_BLR INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER PIVSIZ,LPIV, XSIZE COMPLEX A(LA) REAL UU, UULOC, SEUIL INTEGER IW(LIW) INTEGER KEEP(500) INTEGER(8) KEEP8(150) TYPE(PIVNUL_LIST_STRUCT_T) :: PIVNUL_LIST_STRUCT LOGICAL, intent(inout) :: SWAP_OCCURRED REAL DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled REAL, intent(in) :: MAXFROMM LOGICAL, intent(inout) :: IS_MAXFROMM_AVAIL INTEGER, intent(in) :: NVSCHUR INTEGER, intent(in) :: PARPIV_T1 LOGICAL, intent(in) :: LR_ACTIVATED include 'mpif.h' INTEGER (8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX, LIM, LIM_SWAP REAL RMAX,AMAX,TMAX, MAX_PREV_in_PARPIV, ABS_PIVOT REAL RMAX_NORELAX, TMAX_NORELAX, UULOCM1 INTEGER(8) :: APOSMAX, APOSROW REAL MAXPIV REAL PIVNUL REAL MAXFROMM_UPDATED COMPLEX FIXA, CSEUIL COMPLEX PIVOT,DETPIV REAL ABSDETPIV INCLUDE 'mumps_headers.h' INTEGER :: HF, IPIVNUL INTEGER :: J INTEGER(8) :: APOS, J1, J2, JJ, NFRONT8, KK, J1_ini, JJ_ini INTEGER :: LDA INTEGER(8) :: LDA8 INTEGER NPIV,IPIV INTEGER NPIVP1,K INTEGER :: ISHIFT, K206, IPIV_SHIFT, IPIV_END INTRINSIC max COMPLEX ZERO, ONE PARAMETER( ZERO = (0.0E0,0.0E0) ) PARAMETER( ONE = (1.0E0,1.0E0) ) REAL RZERO,RONE PARAMETER(RZERO=0.0E0, RONE=1.0E0) #if defined(_OPENMP) LOGICAL :: OMP_FLAG INTEGER :: NOMP, CHUNK, J1_end #endif INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L !$ NOMP = OMP_GET_MAX_THREADS() PIVNUL = DKEEP(1) FIXA = cmplx(DKEEP(2),kind=kind(FIXA)) CSEUIL = cmplx(SEUIL,kind=kind(CSEUIL)) LDA = NFRONT LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) K206 = KEEP(206) UULOC = UU IF (UULOC.GT.RZERO) THEN UULOCM1 = RONE/UULOC ELSE UULOCM1 = RONE ENDIF HF = 6 + XSIZE IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, IOLDPS+2*NFRONT+6+KEEP(IXSZ), & IW, LIW) ENDIF PIVSIZ = 1 NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 APOSMAX = POSELT+LDA8*LDA8-1_8 IF(INOPV .EQ. -1) THEN APOS = POSELT + (LDA8+1_8) * int(NPIV,8) POSPV1 = APOS CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), DKEEP, KEEP, .TRUE.) IF(abs(A(APOS)).LT.SEUIL) THEN IF(real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER( A(APOS), DET_MANTW, DET_EXPW ) ENDIF ENDIF IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF IF (ISHIFT.GT.0.AND.IS_MAXFROMM_AVAIL) THEN IPIV = NPIVP1 APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF ( MAXFROMM .GT. PIVNUL ) THEN IF (PARPIV_T1.NE.0) THEN MAXFROMM_UPDATED = max & ( MAXFROMM, & abs(real(A(APOSMAX+int(IPIV,8)))) & ) ELSE MAXFROMM_UPDATED = MAXFROMM ENDIF IF ( (abs(PIVOT) .GE. UULOC*MAXFROMM_UPDATED).AND. & abs(PIVOT) .GT. max(SEUIL,tiny(MAXFROMM_UPDATED)) & ) THEN ISHIFT = 0 ENDIF ENDIF ENDIF IF ( ISHIFT .GT. 0) THEN IS_MAXFROMM_AVAIL = .FALSE. ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN IF(ABS_PIVOT.LT.SEUIL) THEN CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .TRUE.) IF(real(PIVOT) .GE. RZERO) THEN A(POSPV1) = CSEUIL ELSE A(POSPV1) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (ABS_PIVOT.EQ.RZERO) THEN GO TO 630 ELSE CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF ENDIF GO TO 420 ENDIF IF ( IS_MAXFROMM_AVAIL ) THEN IF ( MAXFROMM .GT. PIVNUL ) THEN IF (PARPIV_T1.NE.0) THEN MAXFROMM_UPDATED = max & ( MAXFROMM, & abs(real(A(APOSMAX+int(IPIV,8)))) & ) ELSE MAXFROMM_UPDATED = MAXFROMM ENDIF IF ( (ABS_PIVOT .GE. UULOC*MAXFROMM_UPDATED).AND. & (ABS_PIVOT .GT. max(SEUIL,tiny(MAXFROMM_UPDATED))) & ) THEN CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GOTO 415 ENDIF ENDIF IS_MAXFROMM_AVAIL = .FALSE. ENDIF AMAX = -RONE JMAX = 0 IF (PIVOT_OPTION.EQ.3 & ) THEN LIM = NFRONT - KEEP(253)-NVSCHUR ELSEIF (PIVOT_OPTION.GE.2 & ) THEN LIM = NASS ELSEIF (PIVOT_OPTION.GE.1) THEN LIM = IEND_BLR ELSE write(*,*) 'Internal error in FAC_I_LDLT 1x1:', & PIVOT_OPTION CALL MUMPS_ABORT() ENDIF J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1, IEND_BLOCK - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDA8 ENDDO RMAX = RZERO J1_ini = J1 #if defined(_OPENMP) J1_end = LIM - IEND_BLOCK CHUNK = max(J1_end,1) IF ( J1_end.GE.KEEP(360)) THEN OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2,(J1_end+NOMP-1)/NOMP) ELSE OMP_FLAG = .FALSE. ENDIF #endif !$OMP PARALLEL DO SCHEDULE(static, CHUNK) PRIVATE(J1) !$OMP& REDUCTION(max:RMAX) IF(OMP_FLAG) DO J=1, LIM - IEND_BLOCK J1 = J1_ini + int(J-1,8) * LDA8 RMAX = max(abs(A(J1)),RMAX) ENDDO !$OMP END PARALLEL DO IF (PARPIV_T1.NE.0) THEN RMAX_NORELAX = real(A(APOSMAX+int(IPIV,8))) ELSE RMAX_NORELAX = RZERO ENDIF RMAX = max(RMAX,RMAX_NORELAX) IF (max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL) THEN IF ((PARPIV_T1.NE.0) & .AND.(PARPIV_T1.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & real(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + NFRONT8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) THEN GOTO 460 ENDIF ENDDO ENDIF ENDIF CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(POSPV1)), DKEEP, KEEP, .TRUE.) !$OMP ATOMIC CAPTURE KEEP(109) = KEEP(109) + 1 IPIVNUL = KEEP(109) !$OMP END ATOMIC IF (PIVNUL_LIST_STRUCT%SIZE_PIVNUL_LIST.LT.KEEP(109)) & THEN CALL MUMPS_RESIZE_PIVNUL(KEEP, N, & PIVNUL_LIST_STRUCT, & IPIVNUL, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 420 ENDIF IF (KEEP(405).EQ.1) THEN !$OMP CRITICAL(critical_pivnul) PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) !$OMP END CRITICAL(critical_pivnul) ELSE PIVNUL_LIST_STRUCT%PIVNUL_LIST(IPIVNUL) = & IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) ENDIF IF(real(FIXA).GT.RZERO) THEN IF(real(PIVOT) .GE. RZERO) THEN A(POSPV1) = FIXA ELSE A(POSPV1) = -FIXA ENDIF ELSE J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 A(JJ) = ZERO ENDDO J1 = POSPV1 + LDA8 DO J=1, IEND_BLOCK - IPIV A(J1) = ZERO J1 = J1 + LDA8 ENDDO DO J=1,LIM - IEND_BLOCK A(J1) = ZERO J1 = J1 + LDA8 ENDDO A(POSPV1) = ONE ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF ( abs(PIVOT).GE.UULOC*max(RMAX,AMAX) & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(RMAX)) ) THEN CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(PIVOT), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL CMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) THEN GOTO 460 ELSE IF (JMAX.EQ.0) THEN GOTO 460 ENDIF IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN GOTO 460 ENDIF IF ( & (KEEP(19).NE.0).AND.(max(AMAX,RMAX,abs(PIVOT)).LE.SEUIL) & ) & THEN GO TO 460 ENDIF IF (RMAX.LT.AMAX) THEN J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN RMAX = max(RMAX,abs(A(JJ))) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1,IEND_BLOCK-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX = max(abs(A(J1)),RMAX) ENDIF J1 = J1 + LDA8 ENDDO ENDIF APOSJ = POSELT + int(JMAX-1,8)*LDA8 + int(NPIV,8) POSPV2 = APOSJ + int(JMAX - NPIVP1,8) IF (IPIV.LT.JMAX) THEN OFFDAG = APOSJ + int(IPIV - NPIVP1,8) ELSE OFFDAG = APOS + int(JMAX - NPIVP1,8) END IF TMAX = RZERO #if defined(_OPENMP) J1_end = LIM-JMAX CHUNK = max(J1_end,1) IF (J1_end.GE.KEEP(360)) THEN OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2,(J1_end+NOMP-1)/NOMP) ELSE OMP_FLAG = .FALSE. ENDIF #endif IF (JMAX .LT. IPIV) THEN JJ_ini = POSPV2 !$OMP PARALLEL DO SCHEDULE(static, CHUNK) IF (OMP_FLAG) !$OMP& PRIVATE(JJ) REDUCTION(max:TMAX) DO K = 1, LIM - JMAX JJ = JJ_ini+ int(K,8)*NFRONT8 IF (JMAX+K.NE.IPIV) THEN TMAX=max(TMAX,abs(A(JJ))) ENDIF ENDDO !$OMP END PARALLEL DO DO KK = APOSJ, POSPV2-1_8 TMAX = max(TMAX,abs(A(KK))) ENDDO ELSE JJ_ini = POSPV2 !$OMP PARALLEL DO SCHEDULE(static, CHUNK) PRIVATE(JJ) !$OMP& REDUCTION(max:TMAX) IF(OMP_FLAG) DO K = 1, LIM-JMAX JJ = JJ_ini + int(K,8)*NFRONT8 TMAX=max(TMAX,abs(A(JJ))) ENDDO !$OMP END PARALLEL DO DO KK = APOSJ, POSPV2 - 1_8 IF (KK.NE.OFFDAG) THEN TMAX = max(TMAX,abs(A(KK))) ENDIF ENDDO ENDIF IF (PARPIV_T1.NE.0) THEN TMAX_NORELAX = max(SEUIL*UULOCM1, & abs(real(A(APOSMAX+int(JMAX,8)))) & ) ELSE TMAX_NORELAX = SEUIL*UULOCM1 ENDIF TMAX = max (TMAX,TMAX_NORELAX) DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)**2 ABSDETPIV = abs(DETPIV) IF (SEUIL.GT.RZERO) THEN IF (sqrt(ABSDETPIV) .LE. SEUIL ) THEN GOTO 460 ENDIF ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & ABSDETPIV .OR. (ABSDETPIV .EQ. RZERO) ) THEN GO TO 460 ENDIF IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & ABSDETPIV .OR. (ABSDETPIV.EQ. RZERO) ) THEN GO TO 460 ENDIF CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( sqrt(ABSDETPIV), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL CMUMPS_UPDATEDETER(DETPIV, DET_MANTW, DET_EXPW ) ENDIF PIVSIZ = 2 NB22T1W = NB22T1W + 1 415 CONTINUE IF (K206.GE.1) THEN Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) ENDIF DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2) THEN IF (K==1) THEN LPIV = min(IPIV,JMAX) ELSE LPIV = max(IPIV,JMAX) ENDIF ELSE LPIV = IPIV ENDIF IF (LPIV.EQ.NPIVP1) GOTO 416 IF (KEEP(405) .EQ. 0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF LIM_SWAP = NFRONT CALL CMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, LIM_SWAP, & LDA, NFRONT, 1, PARPIV_T1, KEEP(50), & KEEP(IXSZ), -9999) SWAP_OCCURRED = .TRUE. 416 CONTINUE IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF NPIVP1 = NPIVP1 + 1 ENDDO IF(PIVSIZ .EQ. 2) THEN A(POSELT+(LDA8+1_8)*int(NPIV,8)+1_8) = DETPIV ENDIF GOTO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE PIVSIZ = 0 IFLAG = -10 420 CONTINUE IS_MAXFROMM_AVAIL = .FALSE. RETURN END SUBROUTINE CMUMPS_FAC_I_LDLT SUBROUTINE CMUMPS_FAC_MQ_LDLT(IEND_BLOCK, & NFRONT,NASS,NPIV,INODE, & A,LA,LDA, & POSELT,IFINB,PIVSIZ, & MAXFROMM, IS_MAXFROMM_AVAIL, IS_MAX_USEFUL, & PARPIV_T1, LAST_ROW, IEND_BLR, NVSCHUR_K253, & LR_ACTIVATED & ) IMPLICIT NONE INTEGER, intent(out):: IFINB INTEGER, intent(in) :: INODE, NFRONT, NASS, NPIV INTEGER, intent(in) :: IEND_BLOCK INTEGER, intent(in) :: LDA INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER, intent(in) :: LAST_ROW INTEGER, intent(in) :: IEND_BLR INTEGER(8) :: POSELT REAL, intent(out) :: MAXFROMM LOGICAL, intent(out) :: IS_MAXFROMM_AVAIL LOGICAL, intent(in) :: IS_MAX_USEFUL INTEGER, intent(in) :: PARPIV_T1 INTEGER, INTENT(in) :: NVSCHUR_K253 LOGICAL, intent(in) :: LR_ACTIVATED COMPLEX VALPIV REAL :: MAXFROMMTMP INTEGER NCB1 INTEGER(8) :: NFRONT8 INTEGER(8) :: LDA8 INTEGER(8) :: K1POS INTEGER NEL2 COMPLEX ONE, ZERO COMPLEX A11,A22,A12 INTEGER(8) :: APOS, LPOS, LPOS1, LPOS2 INTEGER(8) :: POSPV1, POSPV2 INTEGER :: PIVSIZ,NPIV_NEW,J2,I INTEGER(8) :: OFFDAG, OFFDAG_OLD, K1, K2, IROW #if defined(__ve__) INTEGER(8) :: J2_8, KU1, KU2 #else INTEGER(8) :: IBEG, IEND, JJ_LOC, JJ, ROW_SHIFT INTEGER(8) :: IBEG_LOC, IEND_LOC #endif COMPLEX SWOP,DETPIV,MULT1,MULT2 INTEGER(8) :: APOSMAX !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' PARAMETER(ONE = (1.0E0,0.0E0), & ZERO = (0.0E0,0.0E0)) LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) NPIV_NEW = NPIV + PIVSIZ IFINB = 0 IS_MAXFROMM_AVAIL = .FALSE. NCB1 = LAST_ROW - IEND_BLOCK NEL2 = IEND_BLOCK - NPIV_NEW IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ENDIF MAXFROMM = 0.0E0 IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDA8 #if defined(__ve__) IF (NEL2+NCB1.GT.0) THEN !$ OMP_FLAG = (NCB1 + NEL2> 300) !$OMP PARALLEL DO PRIVATE(I,K1POS) IF (OMP_FLAG) !NEC$ IVDEP DO I=1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) ENDDO !$OMP END PARALLEL DO !$OMP PARALLEL DO PRIVATE(I,K1POS) IF (OMP_FLAG) !NEC$ IVDEP DO I=1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS) = A(K1POS) * VALPIV ENDDO !$OMP END PARALLEL DO IF (.NOT. IS_MAX_USEFUL) THEN !$ OMP_FLAG = (NCB1 > 300).AND.(NEL2.GE.2) !$OMP PARALLEL DO PRIVATE(I,J2,J2_8,K1POS) IF (OMP_FLAG) !NEC$ IVDEP DO J2 = 1, NEL2 J2_8 = int(J2,8) !NEC$ IVDEP DO I=J2, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS+J2_8)=A(K1POS+J2_8)-(A(K1POS)*A(APOS+J2_8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE IF (NEL2.GT.0) THEN MAXFROMMTMP=0.0E0 !$ OMP_FLAG = (NCB1+NEL2 > 300) !$OMP PARALLEL DO PRIVATE(I,K1POS) IF (OMP_FLAG) !$OMP& REDUCTION(max:MAXFROMMTMP) !NEC$ IVDEP DO I=1, NEL2 + NCB1 - NVSCHUR_K253 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS+1_8)=A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) MAXFROMMTMP=max(MAXFROMMTMP, abs(A(K1POS+1_8))) ENDDO !$OMP END PARALLEL DO IS_MAXFROMM_AVAIL = .TRUE. MAXFROMM=max(MAXFROMM, MAXFROMMTMP) IF (NVSCHUR_K253.GT.0) THEN DO I= NEL2 + NCB1- NVSCHUR_K253 +1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS+1_8)=A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) ENDDO ENDIF ENDIF IF (NEL2.GT.1) THEN !$ OMP_FLAG = (NCB1+NEL2 > 300).AND.(NEL2.GE.3) !$OMP PARALLEL DO PRIVATE(I,J2,J2_8,K1POS) IF (OMP_FLAG) !NEC$ IVDEP DO J2 = 2, NEL2 J2_8 = int(J2,8) !NEC$ IVDEP DO I=J2, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(K1POS+J2_8)=A(K1POS+J2_8)-(A(K1POS)*A(APOS+J2_8)) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF ENDIF ENDIF #else 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 (NCB1.GT.0) THEN IF (.NOT. IS_MAX_USEFUL) THEN !$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) DO I=NEL2+1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE MAXFROMMTMP=0.0E0 !$ OMP_FLAG = (NCB1-NVSCHUR_K253>300) !$OMP PARALLEL DO PRIVATE(JJ,K1POS) !$OMP& REDUCTION(max:MAXFROMMTMP) IF (OMP_FLAG) DO I=NEL2+1, NEL2 + NCB1 - NVSCHUR_K253 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV IF (NEL2 > 0) THEN A(K1POS+1_8) = A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) MAXFROMMTMP=max(MAXFROMMTMP, abs(A(K1POS+1_8))) DO JJ = 2_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDIF ENDDO !$OMP END PARALLEL DO DO I = NEL2 + NCB1 - NVSCHUR_K253 + 1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO MAXFROMM=max(MAXFROMM, MAXFROMMTMP) ENDIF ENDIF #endif ELSE POSPV1 = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) POSPV2 = POSPV1 + NFRONT8 + 1_8 OFFDAG_OLD = POSPV2 - 1_8 OFFDAG = POSPV1 + 1_8 SWOP = A(POSPV2) DETPIV = A(OFFDAG) A22 = A(POSPV1)/DETPIV A11 = SWOP/DETPIV A12 = -A(OFFDAG_OLD)/DETPIV A(OFFDAG) = A(OFFDAG_OLD) A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDA8 - 1_8 LPOS2 = LPOS1 + 1_8 #if defined(__ve__) CALL ccopy(LAST_ROW-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) CALL ccopy(LAST_ROW-NPIV_NEW, A(LPOS2), LDA, A(POSPV2+1_8), 1) !$ OMP_FLAG = (NEL2+NCB1 > 300) !$OMP PARALLEL DO PRIVATE(J2,J2_8,I,K1,K2,KU1,KU2) !$OMP& IF (OMP_FLAG) !NEC$ IVDEP DO J2=1, NEL2 + NCB1 J2_8 = int(J2,8) KU1 = POSPV1 + 2_8 + (J2_8-1_8) KU2 = POSPV2 + 1_8 + (J2_8-1_8) K1 = LPOS1 + (J2_8-1_8)*NFRONT8 K2 = K1 + 1_8 A(K1) = A11*A(KU1)+A12*A(KU2) A(K2) = A12*A(KU1)+A22*A(KU2) ENDDO IF (NEL2.GT.0) THEN !$ OMP_FLAG = (NCB1+NEL2 > 300).AND.(NEL2.GE.2) !$OMP PARALLEL DO PRIVATE(I,J2,J2_8,K1,K2,MULT1,MULT2,IROW) !$OMP& IF (OMP_FLAG) !NEC$ IVDEP DO J2 = 1,NEL2 J2_8 = int(J2,8) MULT1 = -A(POSPV1 + 2_8 + J2_8-1_8) MULT2 = -A(POSPV2 + 1_8 + J2_8-1_8) !NEC$ IVDEP DO I= J2, NEL2 + NCB1 K1 = LPOS1 + (int(I,8)-1_8)*NFRONT8 K2 = K1 + 1_8 IROW = K2 + J2_8 A(IROW) = A(IROW) + MULT1*A(K1) + & MULT2*A(K2) ENDDO ENDDO ENDIF #else JJ = POSPV2 + NFRONT8-1_8 IBEG = JJ + 2_8 IEND = IBEG DO J2 = 1,NEL2 K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) A(POSPV1 + 2_8 + (int(J2,8)-1_8)) = A(K1) A(POSPV2 + 1_8 + (int(J2,8)-1_8)) = A(K2) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 DO IROW = IBEG, IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A( JJ ) = -MULT1 A( JJ + 1_8 ) = -MULT2 IBEG = IBEG + NFRONT8 IEND = IEND + NFRONT8 + 1_8 JJ = JJ+NFRONT8 ENDDO IEND = IEND-1_8 !$OMP PARALLEL DO PRIVATE(J2, K1, K2, MULT1, MULT2, IROW, JJ_LOC, !$OMP& ROW_SHIFT, IBEG_LOC, IEND_LOC) IF (LAST_ROW-IEND_BLOCK>300) DO J2 = 1,LAST_ROW-IEND_BLOCK ROW_SHIFT = (J2-1_8)*NFRONT8 JJ_LOC = JJ + ROW_SHIFT IBEG_LOC = IBEG + ROW_SHIFT IEND_LOC = IEND + ROW_SHIFT K1 = JJ_LOC K2 = JJ_LOC+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) A(POSPV1 + 2_8 + NEL2 + (J2-1_8)) = A(K1) A(POSPV2 + 1_8 + NEL2 + (J2-1_8)) = A(K2) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 DO IROW = IBEG_LOC, IEND_LOC A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A( JJ_LOC ) = -MULT1 A( JJ_LOC + 1_8 ) = -MULT2 ENDDO !$OMP END PARALLEL DO #endif ENDIF IF ((IS_MAXFROMM_AVAIL).AND.(NEL2.GT.0)) THEN IF (PARPIV_T1.NE.0) THEN APOSMAX = POSELT+LDA8*LDA8-1_8 + int(NPIV_NEW+1,8) MAXFROMM = max(MAXFROMM, & real(A(APOSMAX)) & ) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_FAC_MQ_LDLT SUBROUTINE CMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NFRONT,NASS,INODE,A,LA, & LDA, & POSELT, & KEEP,KEEP8, & FIRST_ROW_TRSM, LAST_ROW_TRSM, & LAST_COL_GEMM, LAST_ROW_GEMM, & CALL_TRSM, CALL_GEMM, LR_ACTIVATED, & IW, LIW, OFFSET_IW & ) IMPLICIT NONE INTEGER, intent(in) :: NPIV INTEGER, intent(in) :: NFRONT, NASS, IBEG_BLOCK, IEND_BLOCK INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER, intent(in) :: INODE INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA INTEGER, intent(in) :: LAST_COL_GEMM INTEGER, intent(in) :: LAST_ROW_GEMM, LAST_ROW_TRSM, & FIRST_ROW_TRSM LOGICAL, intent(in) :: CALL_TRSM, CALL_GEMM, LR_ACTIVATED INTEGER :: OFFSET_IW, LIW INTEGER :: IW(LIW) INTEGER(8) :: LDA8 INTEGER NPIV_BLOCK, NEL1 INTEGER NRHS_TRSM INTEGER(8) :: LPOS, UPOS, APOS INTEGER IROW INTEGER Block INTEGER BLSIZE COMPLEX ONE, ALPHA INCLUDE 'mumps_headers.h' PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) LDA8 = int(LDA,8) NEL1 = LAST_COL_GEMM - IEND_BLOCK NRHS_TRSM = LAST_ROW_TRSM-FIRST_ROW_TRSM NPIV_BLOCK = NPIV - IBEG_BLOCK + 1 IF (NPIV_BLOCK.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF (CALL_TRSM) THEN APOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IBEG_BLOCK-1,8) LPOS = POSELT + LDA8*int(FIRST_ROW_TRSM,8)+int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8)+int(FIRST_ROW_TRSM,8) CALL ctrsm('L', 'U', 'T', 'U', NPIV_BLOCK, NRHS_TRSM, & ONE, A(APOS), LDA, A(LPOS), LDA) CALL CMUMPS_FAC_LDLT_COPY2U_SCALEL(NRHS_TRSM, 1, KEEP(424), & NFRONT, NPIV_BLOCK, LIW, IW, OFFSET_IW, LA, A, & POSELT, LPOS, UPOS, APOS, .NOT.LR_ACTIVATED) ENDIF IF (CALL_GEMM) THEN #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1 .OR. & ( KEEP(421) > 0 .AND. NEL1 > KEEP(421) ) ) THEN LPOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IEND_BLOCK,8) APOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IEND_BLOCK,8) CALL cgemmt( 'U','N','N', NEL1, & NPIV_BLOCK, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) ELSE #endif IF ( LAST_COL_GEMM - IEND_BLOCK > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = LAST_COL_GEMM - IEND_BLOCK END IF IF ( LAST_COL_GEMM - IEND_BLOCK .GT. 0 ) THEN DO IROW = IEND_BLOCK+1, LAST_COL_GEMM, BLSIZE Block = min( BLSIZE, LAST_COL_GEMM - IROW + 1 ) LPOS = POSELT + int( IROW - 1,8) * LDA8 + & int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK - 1,8) * LDA8 + & int( IROW - 1,8) APOS = POSELT + int( IROW - 1,8) * LDA8 + int( IROW - 1,8) CALL cgemm( 'N','N', Block, LAST_COL_GEMM - IROW + 1, & NPIV_BLOCK, ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) END DO END IF #if defined(GEMMT_AVAILABLE) END IF #endif LPOS = POSELT + int(LAST_COL_GEMM,8)*LDA8 + int(IBEG_BLOCK-1,8) UPOS = POSELT + int(IBEG_BLOCK-1,8) * LDA8 + & int(IEND_BLOCK,8) APOS = POSELT + int(LAST_COL_GEMM,8)*LDA8 + int(IEND_BLOCK,8) IF (LAST_ROW_GEMM .GT. LAST_COL_GEMM) THEN CALL cgemm('N', 'N', NEL1, LAST_ROW_GEMM-LAST_COL_GEMM, & NPIV_BLOCK, ALPHA, A(UPOS), LDA, A(LPOS), LDA, & ONE, A(APOS), LDA) ENDIF ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_SQ_LDLT SUBROUTINE CMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, IPIV, POSELT, LASTROW2SWAP, & LDA, NFRONT, LEVEL, PARPIV, K50, XSIZE, & IBEG_BLOCK_TO_SEND ) IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER LIW, IOLDPS, NPIVP1, IPIV INTEGER LDA, NFRONT, LEVEL, PARPIV, K50, XSIZE INTEGER LASTROW2SWAP COMPLEX A( LA ) INTEGER IW( LIW ) INTEGER, INTENT(IN) :: IBEG_BLOCK_TO_SEND INCLUDE 'mumps_headers.h' INTEGER :: IBEG INTEGER ISW, ISWPS1, ISWPS2, HF INTEGER(8) :: IDIAG, APOS INTEGER(8) :: LDA8 COMPLEX SWOP LDA8 = int(LDA,8) APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIVP1-1,8) IDIAG = APOS + int(IPIV - NPIVP1,8) HF = 6 + IW( IOLDPS + 5 + XSIZE) + XSIZE ISWPS1 = IOLDPS + HF + NPIVP1 - 1 ISWPS2 = IOLDPS + HF + IPIV - 1 ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW ISW = IW(ISWPS1+NFRONT) IW(ISWPS1+NFRONT) = IW(ISWPS2+NFRONT) IW(ISWPS2+NFRONT) = ISW IF ( LEVEL .eq. 2 ) THEN IBEG = IBEG_BLOCK_TO_SEND CALL cswap( NPIVP1 - 1 - IBEG + 1, & A( POSELT + int(NPIVP1-1,8) + & int(IBEG-1,8) * LDA8), LDA, & A( POSELT + int(IPIV-1,8) + & int(IBEG-1,8) * LDA8), LDA ) END IF CALL cswap( NPIVP1-1, & A( POSELT+int(NPIVP1-1,8) * LDA8 ), 1, & A( POSELT + int(IPIV-1,8) * LDA8 ), 1 ) CALL cswap( IPIV - NPIVP1 - 1, & A( POSELT+int(NPIVP1,8) * LDA8 + int(NPIVP1-1,8) ), & LDA, A( APOS + 1_8 ), 1 ) SWOP = A(IDIAG) A(IDIAG) = A( POSELT+int(NPIVP1-1,8)*LDA8+int(NPIVP1-1,8) ) A( POSELT + int(NPIVP1-1,8)*LDA8 + int(NPIVP1-1,8) ) = SWOP IF (LASTROW2SWAP - IPIV.GT.0) THEN CALL cswap( LASTROW2SWAP - IPIV, & A( APOS + LDA8 ), LDA, & A( IDIAG + LDA8 ), LDA ) ENDIF IF (PARPIV.NE.0 .AND.K50.EQ.2) THEN IF ( LEVEL .eq. 2 .OR. LEVEL.eq.1) THEN APOS = POSELT+LDA8*LDA8-1_8 SWOP = A(APOS+int(NPIVP1,8)) A(APOS+int(NPIVP1,8))= A(APOS+int(IPIV,8)) A(APOS+int(IPIV,8)) = SWOP ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SWAP_LDLT SUBROUTINE CMUMPS_FAC_LDLT_COPY2U_SCALEL( IROWMAX, IROWMIN, & SIZECOPY, LDA, NCOLS, LIW, IW, OFFSET_IW, & LA, A, POSELT, A_LPOS, A_UPOS, A_DPOS, & COPY_NEEDED ) !$ USE OMP_LIB INTEGER, INTENT(IN) :: IROWMAX, IROWMIN INTEGER, INTENT(IN) :: SIZECOPY INTEGER, INTENT(IN) :: LDA, NCOLS INTEGER, INTENT(IN) :: LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: OFFSET_IW INTEGER(8), INTENT(IN) :: LA COMPLEX, INTENT(INOUT) :: A(LA) INTEGER(8), INTENT(IN) :: POSELT, A_LPOS, A_UPOS, A_DPOS LOGICAL, INTENT(IN) :: COPY_NEEDED INTEGER(8) :: LPOS, UPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER :: IROWEND, IROW, Block2 INTEGER :: I, J COMPLEX :: MULT1, MULT2, A11, DETPIV, A22, A12 INTEGER :: BLSIZECOPY COMPLEX :: ONE PARAMETER (ONE=(1.0E0,0.0E0)) INTEGER(8) :: LPOSI, UPOSI LOGICAL :: PIVOT_2X2 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP, CHUNK LDA8 = int(LDA,8) IF (SIZECOPY.NE.0) THEN BLSIZECOPY = SIZECOPY ELSE BLSIZECOPY = 250 ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = (64/4) !$ IF (NOMP .GT. 1 .AND. NCOLS .GE. 4*CHUNK) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max(2*CHUNK, NCOLS/NOMP) !$ ENDIF DO IROWEND = IROWMAX, IROWMIN, -BLSIZECOPY Block2 = min(BLSIZECOPY, IROWEND) IROW = IROWEND - Block2 + 1 LPOS = A_LPOS + int(IROW-1,8)*LDA8 UPOS = A_UPOS + int(IROW-1,8) !$OMP PARALLEL DO PRIVATE(PIVOT_2X2, A11, DPOS, !$OMP& POSPV1, POSPV2, OFFDAG, A22, A12, DETPIV, J, MULT1, MULT2 !$OMP& , LPOSI, UPOSI !$OMP& ) FIRSTPRIVATE(Block2, LDA, LDA8, LPOS, UPOS, A_DPOS) !$OMP& SCHEDULE(STATIC,CHUNK) IF(OMP_FLAG) DO I=1, NCOLS PIVOT_2X2 = .FALSE. IF(IW(OFFSET_IW+I-1) .LE. 0) THEN PIVOT_2X2 = .TRUE. ELSE IF (I .GT. 1) THEN IF (IW(OFFSET_IW+I-2) .LE. 0) THEN cycle ENDIF ENDIF ENDIF DPOS = A_DPOS + LDA8*int(I-1,8) + int(I-1,8) IF(.not. PIVOT_2X2) THEN A11 = ONE/A(DPOS) LPOSI = LPOS+int(I-1,8) IF (COPY_NEEDED) THEN UPOSI = UPOS+int(I-1,8)*LDA8 #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, Block2 A(UPOSI+int(J-1,8)) = A(LPOSI+int(J-1,8)*LDA8) END DO ENDIF #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, Block2 A(LPOSI+int(J-1,8)*LDA8) = A(LPOSI+int(J-1,8)*LDA8)*A11 END DO ELSE IF (COPY_NEEDED) THEN CALL ccopy(Block2, A(LPOS+int(I-1,8)), & LDA, A(UPOS+int(I-1,8)*LDA8), 1) CALL ccopy(Block2, A(LPOS+int(I,8)), & LDA, A(UPOS+int(I,8)*LDA8), 1) ENDIF POSPV1 = DPOS POSPV2 = DPOS + int(LDA+1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1,Block2 MULT1 = A11*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A12*A(LPOS+int(J-1,8)*LDA8+int(I,8)) MULT2 = A12*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A22*A(LPOS+int(J-1,8)*LDA8+int(I,8)) A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) = MULT1 A(LPOS+int(J-1,8)*LDA8+int(I,8)) = MULT2 ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDDO END SUBROUTINE CMUMPS_FAC_LDLT_COPY2U_SCALEL SUBROUTINE CMUMPS_FAC_LDLT_COPYSCALE_U( IROWMAX, IROWMIN, & SIZECOPY, LDA, NCOLS, LIW, IW, OFFSET_IW, & LA, A, POSELT, A_LPOS, A_UPOS, A_DPOS ) !$ USE OMP_LIB INTEGER, INTENT(IN) :: IROWMAX, IROWMIN INTEGER, INTENT(IN) :: SIZECOPY INTEGER, INTENT(IN) :: LDA, NCOLS INTEGER, INTENT(IN) :: LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: OFFSET_IW INTEGER(8), INTENT(IN) :: LA COMPLEX, INTENT(INOUT) :: A(LA) INTEGER(8), INTENT(IN) :: POSELT, A_LPOS, A_UPOS, A_DPOS INTEGER(8) :: LPOS, UPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER :: IROWEND, IROW, Block2 INTEGER :: I, J COMPLEX :: MULT1, MULT2, A11, A22, A12 INTEGER :: BLSIZECOPY COMPLEX :: ONE PARAMETER (ONE=(1.0E0,0.0E0)) INTEGER(8) :: LPOSI, UPOSI LOGICAL :: PIVOT_2X2 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP, CHUNK LDA8 = int(LDA,8) IF (SIZECOPY.NE.0) THEN BLSIZECOPY = SIZECOPY ELSE BLSIZECOPY = 250 ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = (64/4) !$ IF (NOMP .GT. 1 .AND. NCOLS .GE. 4*CHUNK) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max(2*CHUNK, NCOLS/NOMP) !$ ENDIF DO IROWEND = IROWMAX, IROWMIN, -BLSIZECOPY Block2 = min(BLSIZECOPY, IROWEND) IROW = IROWEND - Block2 + 1 LPOS = A_LPOS + int(IROW-1,8)*LDA8 UPOS = A_UPOS + int(IROW-1,8) !$OMP PARALLEL DO PRIVATE(PIVOT_2X2, A11, DPOS, !$OMP& POSPV1, POSPV2, OFFDAG, A22, A12, J, MULT1, MULT2 !$OMP& , LPOSI, UPOSI !$OMP& ) FIRSTPRIVATE(Block2, LDA, LDA8, LPOS, UPOS, POSELT) !$OMP& SCHEDULE(STATIC,CHUNK) IF(OMP_FLAG) DO I=1, NCOLS PIVOT_2X2 = .FALSE. IF(IW(OFFSET_IW+I-1) .LE. 0) THEN PIVOT_2X2 = .TRUE. ELSE IF (I .GT. 1) THEN IF (IW(OFFSET_IW+I-2) .LE. 0) THEN cycle ENDIF ENDIF ENDIF DPOS = A_DPOS + LDA8*int(I-1,8) + int(I-1,8) IF(.not. PIVOT_2X2) THEN A11 = A(DPOS) LPOSI = LPOS+int(I-1,8) UPOSI = UPOS+int(I-1,8)*LDA8 #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1, Block2 A(UPOSI+int(J-1,8)) = A(LPOSI+int(J-1,8)*LDA8)*A11 END DO ELSE POSPV1 = DPOS POSPV2 = DPOS + int(LDA+1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) #if defined(__ve__) !NEC$ IVDEP #endif DO J = 1,Block2 MULT1 = A11*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A12*A(LPOS+int(J-1,8)*LDA8+int(I,8)) MULT2 = A12*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A22*A(LPOS+int(J-1,8)*LDA8+int(I,8)) A(UPOS+int(I-1,8)*LDA8+int(J-1,8)) = MULT1 A(UPOS+int(I,8)*LDA8+int(J-1,8)) = MULT2 ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDDO RETURN END SUBROUTINE CMUMPS_FAC_LDLT_COPYSCALE_U SUBROUTINE CMUMPS_FAC_T_LDLT(NFRONT,NASS, & IW,LIW,A,LA, & LDA, & IOLDPS,POSELT,KEEP,KEEP8, & POSTPONE_COL_UPDATE, ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG, OFFSET_IW, INODE ) USE CMUMPS_OOC IMPLICIT NONE INTEGER NFRONT, NASS,LIW INTEGER(8) :: LA COMPLEX A(LA) INTEGER IW(LIW) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: POSELT INTEGER LDA INTEGER IOLDPS, ETATASS LOGICAL POSTPONE_COL_UPDATE INTEGER(8) :: LAFAC INTEGER TYPEFile, NextPiv2beWritten INTEGER LIWFAC, MYID, IFLAG TYPE(IO_BLOCK):: MonBloc INTEGER IDUMMY LOGICAL LAST_CALL INTEGER :: OFFSET_IW INTEGER, intent(in):: INODE INCLUDE 'mumps_headers.h' INTEGER(8) :: UPOS, APOS, LPOS INTEGER(8) :: LDA8 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, IROWEND INTEGER I2, I2END, Block2, IFLAG_OOC COMPLEX ONE, ALPHA, BETA, ZERO PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) LDA8 = int(LDA,8) IF (ETATASS.EQ.1) THEN BETA = ZERO ELSE BETA = ONE ENDIF IF ( NFRONT - NASS > KEEP(58) ) THEN IF ( NFRONT - NASS > KEEP(57) ) THEN BLSIZE = KEEP(58) ELSE BLSIZE = (NFRONT - NASS)/2 END IF ELSE BLSIZE = NFRONT - NASS END IF BLSIZE2 = KEEP(218) NPIV = IW( IOLDPS + 1 + KEEP(IXSZ)) IF ( NFRONT - NASS .GT. 0 ) THEN IF ( POSTPONE_COL_UPDATE ) THEN LPOS = POSELT + LDA8 * int(NASS,8) CALL ctrsm( 'L', 'U', 'T', 'U', & NPIV, NFRONT-NASS, ONE, & A( POSELT ), LDA, & A( LPOS ), LDA ) ENDIF #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1 .OR. & ( KEEP(421) > 0 .AND. NFRONT-NASS > KEEP(421) ) ) THEN LPOS = POSELT + int(NASS,8)*LDA8 UPOS = POSELT + int(NASS,8) APOS = POSELT + int(NASS,8)*LDA8 + int(NASS,8) IF (POSTPONE_COL_UPDATE) THEN CALL CMUMPS_FAC_LDLT_COPY2U_SCALEL( NFRONT - NASS, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, & POSELT, .TRUE. ) ENDIF CALL cgemmt('U', 'N', 'N', NFRONT-NASS, NPIV, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, & BETA, & A( APOS ), LDA ) ELSE #endif DO IROWEND = NFRONT - NASS, 1, -BLSIZE Block = min( BLSIZE, IROWEND ) IROW = IROWEND - Block + 1 LPOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 APOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 + & int(NASS + IROW - 1,8) UPOS = POSELT + int(NASS,8) IF (.NOT. POSTPONE_COL_UPDATE) THEN UPOS = POSELT + int(NASS + IROW - 1,8) ENDIF IF (POSTPONE_COL_UPDATE) THEN CALL CMUMPS_FAC_LDLT_COPY2U_SCALEL( Block, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, & POSELT, .TRUE. ) ENDIF DO I2END = Block, 1, -BLSIZE2 Block2 = min(BLSIZE2, I2END) I2 = I2END - Block2+1 CALL cgemm('N', 'N', Block2, Block-I2+1, NPIV, ALPHA, & A(UPOS+int(I2-1,8)), LDA, & A(LPOS+int(I2-1,8)*LDA8), LDA, & BETA, & A(APOS + int(I2-1,8) + int(I2-1,8)*LDA8), LDA) IF (KEEP(201).EQ.1) THEN IF (NextPiv2beWritten.LE.NPIV) THEN LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, MYID, & KEEP8(31), & IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC RETURN ENDIF ENDIF ENDIF ENDDO IF ( NFRONT - NASS - IROW + 1 - Block > 0 ) THEN CALL cgemm( 'N', 'N', Block, NFRONT-NASS-Block-IROW+1, NPIV, & ALPHA, A( UPOS ), LDA, & A( LPOS + LDA8 * int(Block,8) ), LDA, & BETA, & A( APOS + LDA8 * int(Block,8) ), LDA ) ENDIF END DO #if defined(GEMMT_AVAILABLE) END IF #endif IF ( (POSTPONE_COL_UPDATE).AND.(NASS-NPIV.GT.0) ) THEN LPOS = POSELT + int(NPIV,8)*LDA8 UPOS = POSELT + int(NPIV,8) CALL CMUMPS_FAC_LDLT_COPYSCALE_U( NASS-NPIV, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, POSELT) LPOS = POSELT + LDA8 * int(NASS,8) CALL cgemm('N', 'N', NASS-NPIV, NFRONT-NASS, NPIV, ALPHA, & A( POSELT + int(NPIV,8)), LDA, & A( LPOS ), LDA, & BETA, & A( LPOS + int(NPIV,8) ), LDA) ENDIF END IF RETURN END SUBROUTINE CMUMPS_FAC_T_LDLT SUBROUTINE CMUMPS_STORE_PERMINFO( PIVRPTR, NBPANELS, PIVR, NASS, & K, P, LastPanelonDisk, & LastPIVRPTRIndexFilled ) IMPLICIT NONE INTEGER, intent(in) :: NBPANELS, NASS, K, P INTEGER, intent(inout) :: PIVRPTR(NBPANELS), PIVR(NASS) INTEGER LastPanelonDisk, LastPIVRPTRIndexFilled INTEGER I IF ( LastPanelonDisk+1 > NBPANELS ) THEN WRITE(*,*) "INTERNAL ERROR IN CMUMPS_STORE_PERMINFO!" WRITE(*,*) "NASS=",NASS,"PIVRPTR=",PIVRPTR(1:NBPANELS) WRITE(*,*) "K=",K, "P=",P, "LastPanelonDisk=",LastPanelonDisk WRITE(*,*) "LastPIVRPTRIndexFilled=", LastPIVRPTRIndexFilled CALL MUMPS_ABORT() ENDIF PIVRPTR(LastPanelonDisk+1) = K + 1 IF (LastPanelonDisk.NE.0) THEN PIVR(K - PIVRPTR(1) + 1) = P DO I = LastPIVRPTRIndexFilled + 1, LastPanelonDisk PIVRPTR(I)=PIVRPTR(LastPIVRPTRIndexFilled) ENDDO ENDIF LastPIVRPTRIndexFilled = LastPanelonDisk + 1 RETURN END SUBROUTINE CMUMPS_STORE_PERMINFO SUBROUTINE CMUMPS_UPDATE_MINMAX_PIVOT & ( DIAG, DKEEP, KEEP, NULLPIVOT) !$ USE OMP_LIB IMPLICIT NONE REAL, INTENT(IN) :: DIAG REAL, INTENT(INOUT) :: DKEEP(230) LOGICAL, INTENT(IN) :: NULLPIVOT INTEGER, INTENT(IN) :: KEEP(500) IF (KEEP(405).EQ.0) THEN DKEEP(21) = max(DKEEP(21), DIAG) DKEEP(19) = min(DKEEP(19), DIAG) IF (.NOT.NULLPIVOT) THEN DKEEP(20) = min(DKEEP(20), DIAG) ENDIF ELSE !$OMP ATOMIC UPDATE DKEEP(21) = max(DKEEP(21), DIAG) !$OMP END ATOMIC !$OMP ATOMIC UPDATE DKEEP(19) = min(DKEEP(19), DIAG) !$OMP END ATOMIC IF (.NOT.NULLPIVOT) THEN !$OMP ATOMIC UPDATE DKEEP(20) = min(DKEEP(20), DIAG) !$OMP END ATOMIC ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_UPDATE_MINMAX_PIVOT SUBROUTINE CMUMPS_GET_SIZE_SCHUR_IN_FRONT ( & N, NCB, SIZE_SCHUR, ROW_INDICES, PERM, & NVSCHUR & ) IMPLICIT NONE INTEGER, intent(in) :: N, NCB, SIZE_SCHUR INTEGER, intent(in) :: ROW_INDICES(NCB), PERM(N) INTEGER, intent(out):: NVSCHUR INTEGER :: I, IPOS, IBEG_SCHUR IBEG_SCHUR = N - SIZE_SCHUR +1 NVSCHUR = 0 IPOS = NCB DO I= NCB,1,-1 IF (abs(ROW_INDICES(I)).LE.N) THEN IF (PERM(ROW_INDICES(I)).LT.IBEG_SCHUR) EXIT ENDIF IPOS = IPOS -1 ENDDO NVSCHUR = NCB-IPOS RETURN END SUBROUTINE CMUMPS_GET_SIZE_SCHUR_IN_FRONT END MODULE CMUMPS_FAC_FRONT_AUX_M MUMPS_5.8.1/src/cfac_process_bf.F0000664000175000017500000000103115042446440016433 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_PROCESS_BF_RETURN() RETURN END SUBROUTINE CMUMPS_PROCESS_BF_RETURN MUMPS_5.8.1/src/zmumps_mpi3_mod.F0000664000175000017500000000137615042446441016471 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_MPI3_MOD IMPLICIT NONE INTEGER, PARAMETER :: WIN_SYM_PERM272 = 272 INTEGER, PARAMETER :: WIN_FILS273 = 273 INTEGER, PARAMETER :: WIN_STEP274 = 274 INTEGER, PARAMETER :: WIN_LRGROUPS275 = 275 INTEGER, PARAMETER :: WIN_RG2L276 = 276 END MODULE ZMUMPS_MPI3_MOD MUMPS_5.8.1/src/zmumps_sol_es.F0000664000175000017500000010730415042446441016244 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_SOL_ES PRIVATE PUBLIC:: ZMUMPS_CHAIN_PRUN_NODES PUBLIC:: ZMUMPS_CHAIN_PRUN_NODES_STATS PUBLIC:: ZMUMPS_INITIALIZE_RHS_BOUNDS PUBLIC:: ZMUMPS_PROPAGATE_RHS_BOUNDS PUBLIC:: ZMUMPS_TREE_PRUN_NODES PUBLIC:: ZMUMPS_SOL_ES_INIT # if defined(STAT_ES_SOLVE) PUBLIC:: ZMUMPS_SOL_ES_PRINT_STATS # endif PUBLIC:: ZMUMPS_ES_GET_SUM_Nloc PUBLIC:: ZMUMPS_ES_NODES_SIZE_AND_FILL INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK # if defined(STAT_ES_SOLVE) DOUBLE PRECISION :: nb_flops, & nb_sparse_flops, & total_efficiency INTEGER :: total_procs, total_blocks #endif INCLUDE 'mumps_headers.h' CONTAINS SUBROUTINE ZMUMPS_SOL_ES_INIT(SIZE_OF_BLOCK_ARG, KEEP201) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP201 INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK_ARG IF (KEEP201 > 0) THEN SIZE_OF_BLOCK => SIZE_OF_BLOCK_ARG ELSE NULLIFY(SIZE_OF_BLOCK) ENDIF #if defined(STAT_ES_SOLVE) nb_flops=0.0d0 nb_sparse_flops=0.0d0 total_efficiency=0.0d0 total_procs=0 total_blocks=0 #endif RETURN END SUBROUTINE ZMUMPS_SOL_ES_INIT SUBROUTINE ZMUMPS_TREE_PRUN_NODES( & fill, & DAD, NE_STEPS, FRERE, KEEP28, & FILS, STEP, N, & nodes_RHS, nb_nodes_RHS, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N, KEEP28 INTEGER, INTENT(IN) :: DAD(KEEP28),NE_STEPS(KEEP28),FRERE(KEEP28) INTEGER, INTENT(IN) :: FILS(N), STEP(N) INTEGER, INTENT(IN) :: nodes_RHS(:), nb_nodes_RHS INTEGER :: nb_prun_nodes INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_List(nb_prun_nodes) INTEGER :: nb_prun_roots INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Roots(nb_prun_roots) INTEGER :: nb_prun_leaves INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Leaves(nb_prun_leaves) LOGICAL :: TO_PROCESS(KEEP28) INTEGER :: IN, I, ISTEP, TMP, TMPsave LOGICAL :: FILS_VISITED nb_prun_nodes = 0 nb_prun_leaves = 0 TO_PROCESS(:) = .FALSE. DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) TMPsave = TMP ISTEP = STEP(TMP) DO WHILE(.NOT.TO_PROCESS(ISTEP)) TO_PROCESS(ISTEP) = .TRUE. nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = TMP END IF IN = FILS(TMP) DO WHILE(IN.GT.0) IN = FILS(IN) END DO FILS_VISITED = .FALSE. IF (IN.LT.0) THEN FILS_VISITED = TO_PROCESS(STEP(-IN)) ENDIF IF ( IN.LT.0.and..NOT.FILS_VISITED) & THEN TMP = -IN ISTEP = STEP(TMP) ELSE IF (IN.EQ.0) THEN nb_prun_leaves = nb_prun_leaves + 1 IF (fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF ELSE TMP = -IN ISTEP = STEP(TMP) ENDIF DO WHILE (TMP.NE.TMPsave) TMP = abs(FRERE(ISTEP)) IF(TMP.NE.0) THEN ISTEP = STEP(TMP) ELSE exit END IF IF (.NOT.TO_PROCESS(ISTEP)) exit END DO END IF END DO END DO nb_prun_roots = 0 DO I=1,nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) IF(DAD(ISTEP).NE.0) THEN IF(.NOT.TO_PROCESS(STEP(DAD(ISTEP)))) THEN nb_prun_roots = nb_prun_roots + 1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF END IF ELSE nb_prun_roots = nb_prun_roots + 1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF END IF END DO RETURN END SUBROUTINE ZMUMPS_TREE_PRUN_NODES SUBROUTINE ZMUMPS_CHAIN_PRUN_NODES( & fill, & DAD, KEEP28, & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes,nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: KEEP28 INTEGER, INTENT(IN) :: DAD(KEEP28) INTEGER, INTENT(IN) :: nb_nodes_RHS INTEGER, INTENT(IN) :: nodes_RHS(max(nb_nodes_RHS,1)) INTEGER, INTENT(INOUT) :: nb_prun_nodes INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_List(nb_prun_nodes) INTEGER, INTENT(INOUT) :: nb_prun_roots INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Roots(nb_prun_roots) INTEGER, INTENT(INOUT) :: nb_prun_leaves INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Leaves(nb_prun_leaves) INTEGER, INTENT(OUT) :: Pruned_SONS(KEEP28) LOGICAL, INTENT(OUT) :: TO_PROCESS(KEEP28) INTEGER :: IN, I, ISTEP, TMP nb_prun_nodes = 0 nb_prun_roots = 0 TO_PROCESS(:) = .FALSE. Pruned_SONS(:) = -1 DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) TO_PROCESS(ISTEP) = .TRUE. IF (Pruned_SONS(ISTEP) .eq. -1) THEN Pruned_SONS(ISTEP) = 0 nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = nodes_RHS(I) END IF IN = nodes_RHS(I) IN = DAD(STEP(IN)) DO WHILE (IN.NE.0) TO_PROCESS(STEP(IN)) = .TRUE. IF (Pruned_SONS(STEP(IN)).eq.-1) THEN nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = IN END IF Pruned_SONS(STEP(IN)) = 1 TMP = IN IN = DAD(STEP(IN)) ELSE Pruned_SONS(STEP(IN)) = Pruned_SONS(STEP(IN)) + 1 GOTO 201 ENDIF ENDDO nb_prun_roots = nb_prun_roots +1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF ENDIF 201 CONTINUE ENDDO nb_prun_leaves = 0 DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) IF (Pruned_SONS(ISTEP).EQ.0) THEN nb_prun_leaves = nb_prun_leaves +1 IF(fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF END IF ENDDO RETURN END SUBROUTINE ZMUMPS_CHAIN_PRUN_NODES SUBROUTINE ZMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, K242, K243, & UNS_PERM_INV, SIZE_UNS_PERM_INV, K23, & RHS_BOUNDS, NSTEPS, & nb_sparse, MYID, & mode) IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, N, NSTEPS, K242, K243, K23 INTEGER, INTENT(IN) :: JBEG_RHS, SIZE_PERM_RHS, nb_sparse INTEGER, INTENT(IN) :: NBCOL, NZ_RHS, SIZE_UNS_PERM_INV INTEGER, INTENT(IN) :: STEP(N), PERM_RHS(SIZE_PERM_RHS) INTEGER, INTENT(IN) :: IRHS_PTR(NBCOL+1),IRHS_SPARSE(NZ_RHS) INTEGER, INTENT(IN) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, INTENT(INOUT):: RHS_BOUNDS(2*NSTEPS) INTEGER, INTENT(IN) :: mode INTEGER :: I, ICOL, JPTR, J, JAM1, node, bound RHS_BOUNDS = 0 ICOL = 0 DO I = 1, NBCOL IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE ICOL = ICOL + 1 bound = ICOL - mod(ICOL, nb_sparse) + 1 IF(mod(ICOL, nb_sparse).EQ.0) bound = bound - nb_sparse IF(mode.EQ.0) THEN IF ((K242.NE.0).OR.(K243.NE.0)) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 ENDIF node = abs(STEP(JAM1)) IF(RHS_BOUNDS(2*node - 1).EQ.0) THEN RHS_BOUNDS(2*node - 1) = bound RHS_BOUNDS(2*node) = bound + nb_sparse - 1 ELSE RHS_BOUNDS(2*node) = bound + nb_sparse - 1 END IF ELSE DO JPTR = IRHS_PTR(I), IRHS_PTR(I+1)-1 J = IRHS_SPARSE(JPTR) IF ( mode .EQ. 1 ) THEN IF (K23.NE.0) J = UNS_PERM_INV(J) ENDIF node = abs(STEP(J)) IF(RHS_BOUNDS(2*node - 1).EQ.0) THEN RHS_BOUNDS(2*node - 1) = bound RHS_BOUNDS(2*node) = bound + nb_sparse - 1 ELSE RHS_BOUNDS(2*node) = bound + nb_sparse - 1 END IF END DO END IF END DO RETURN END SUBROUTINE ZMUMPS_INITIALIZE_RHS_BOUNDS SUBROUTINE ZMUMPS_PROPAGATE_RHS_BOUNDS( & pruned_leaves, nb_pruned_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, NSTEPS, & MYID, COMM, KEEP485, #if defined(STAT_ES_SOLVE) & KEEP46, & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, #endif & IW, LIW, PTRIST, KIXSZ,OOC_FCT_LOC, PHASE, LDLT, K38) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' INTEGER, INTENT(IN) :: nb_pruned_leaves, N, NSTEPS INTEGER, INTENT(IN) :: STEP(N), DAD(NSTEPS), Pruned_SONS(NSTEPS) INTEGER, INTENT(IN) :: MYID, COMM, KEEP485 INTEGER, INTENT(IN) :: pruned_leaves(nb_pruned_leaves) INTEGER, INTENT(IN) :: LIW, IW(LIW), PTRIST(NSTEPS) INTEGER, INTENT(IN) :: KIXSZ, OOC_FCT_LOC, PHASE, LDLT, K38 # if defined(STAT_ES_SOLVE) INTEGER, INTENT(IN) :: KEEP46 INTEGER, INTENT(IN) :: SIZE_IPTR_WORKING, SIZE_WORKING, & IPTR_WORKING(SIZE_IPTR_WORKING), & WORKING(SIZE_WORKING) #endif INTEGER, INTENT(INOUT):: RHS_BOUNDS(2*NSTEPS) INTEGER :: I, node, father, size_pool, next_size_pool INTEGER :: IERR INTEGER, ALLOCATABLE, DIMENSION(:) :: POOL, NBSONS #if defined(STAT_ES_SOLVE) LOGICAL, ALLOCATABLE, DIMENSION(:) :: isleaf INTEGER :: J, NPROCS, proc, allocok LOGICAL :: found DOUBLE PRECISION :: avg_load, efficiency, max_load, effmax DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: proc_flops_buf DOUBLE PRECISION :: proc_block_flops, block_flops INTEGER :: SK38 INTEGER, PARAMETER :: MASTER = 0 #endif ALLOCATE(POOL(nb_pruned_leaves), & NBSONS(NSTEPS), & STAT=IERR) IF (IERR.NE.0) THEN WRITE(6,*)'Allocation problem in ZMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() END IF size_pool = nb_pruned_leaves POOL = pruned_leaves NBSONS = Pruned_SONS # if defined(STAT_ES_SOLVE) NPROCS = SIZE_IPTR_WORKING-1 IF((MYID.EQ.MASTER).AND.(KEEP46.EQ.1)) THEN ALLOCATE(isleaf(NSTEPS), STAT=IERR) IF (IERR.NE.0) THEN WRITE(6,*)'Allocation problem in ZMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() END IF isleaf = .FALSE. DO I=1,nb_pruned_leaves isleaf(abs(STEP(pruned_leaves(I)))) = .true. END DO proc = 0 DO I=1,NPROCS found = .FALSE. J = IPTR_WORKING(I) DO WHILE((J.LE.IPTR_WORKING(I+1)-1).AND.(.NOT.found)) IF (isleaf(WORKING(J)))THEN found = .TRUE. END IF J = J + 1 END DO IF(found) THEN proc = proc + 1 END IF END DO total_procs = total_procs + proc total_blocks = total_blocks + 1 DEALLOCATE(isleaf) END IF # endif DO WHILE (size_pool.ne.0) next_size_pool =0 DO I=1, size_pool node = STEP(POOL(I)) IF (DAD(node).NE.0) THEN father = STEP(DAD(node)) NBSONS(father) = NBSONS(father)-1 IF (RHS_BOUNDS(2*father-1).EQ.0) THEN RHS_BOUNDS(2*father-1) = RHS_BOUNDS(2*node-1) RHS_BOUNDS(2*father) = RHS_BOUNDS(2*node) ELSE RHS_BOUNDS(2*father-1) = min(RHS_BOUNDS(2*father-1), & RHS_BOUNDS(2*node-1)) RHS_BOUNDS(2*father) = max(RHS_BOUNDS(2*father), & RHS_BOUNDS(2*node)) END IF IF(NBSONS(father).EQ.0) THEN next_size_pool = next_size_pool+1 POOL(next_size_pool) = DAD(node) END IF END IF END DO size_pool = next_size_pool END DO DEALLOCATE(POOL, NBSONS) # if defined(STAT_ES_SOLVE) IF (KEEP46.EQ.1) THEN IF(MYID.EQ.MASTER) THEN block_flops = 0D0 END IF proc_block_flops = 0D0 IF (K38 .GT. 0) THEN SK38 = STEP(K38) ELSE SK38 = 0 END IF DO I=1,NSTEPS IF (RHS_BOUNDS(2*I).NE.0) THEN IF(PTRIST(I).GT.0) THEN proc_block_flops = proc_block_flops & + dble(2*(RHS_BOUNDS(2*I) - RHS_BOUNDS(2*I-1) +1)) & * dble(ZMUMPS_LOCAL_FACTOR_SIZE(IW, LIW, & PTRIST(I)+KIXSZ, & PHASE,LDLT,I.EQ.SK38)) END IF END IF END DO IF(MYID.EQ.MASTER) THEN ALLOCATE(proc_flops_buf(SIZE_IPTR_WORKING-1),stat=allocok) IF(allocok.GT.0) THEN WRITE(6,*)'Allocation problem of proc_flops_buf' & ,' in ZMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() ENDIF proc_flops_buf=0.0d0 ELSE ALLOCATE(proc_flops_buf(1),stat=allocok) IF(allocok.GT.0) THEN WRITE(6,*)'Allocation problem of proc_flops_buf' & ,' in ZMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() ENDIF proc_flops_buf=0.0d0 END IF CALL MPI_GATHER(proc_block_flops, 1, MPI_DOUBLE_PRECISION, & proc_flops_buf, 1, MPI_DOUBLE_PRECISION, & 0, COMM, IERR) CALL MPI_REDUCE(proc_block_flops, block_flops, 1, & MPI_DOUBLE_PRECISION, MPI_SUM, 0, COMM, IERR) IF(MYID.EQ.MASTER) THEN nb_sparse_flops = nb_sparse_flops+block_flops avg_load = sum(proc_flops_buf)/dble(NPROCS) max_load = maxval(proc_flops_buf) efficiency = 0D0 effmax = 0D0 DO I=1,NPROCS efficiency= efficiency + (proc_flops_buf(I)-avg_load)**2 IF (proc_flops_buf(I)-avg_load.GT.0.0D0) THEN effmax = effmax + (max_load-avg_load)**2 ELSE IF (proc_flops_buf(I)-avg_load.LT.0.0D0) THEN effmax = effmax + avg_load**2 END IF END DO efficiency = sqrt(efficiency/dble(NPROCS)) effmax = sqrt(effmax/dble(NPROCS)) IF(effmax.ne.0.0d0) efficiency = efficiency / effmax efficiency = 1.0d0 - efficiency efficiency = efficiency * block_flops total_efficiency = total_efficiency + efficiency DEALLOCATE(proc_flops_buf) ELSE DEALLOCATE(proc_flops_buf) END IF END IF #endif RETURN END SUBROUTINE ZMUMPS_PROPAGATE_RHS_BOUNDS INTEGER(8) FUNCTION ZMUMPS_LOCAL_FACTOR_SIZE(IW,LIW,PTR, & PHASE, LDLT, IS_ROOT) INTEGER, INTENT(IN) :: LIW, PTR, PHASE, LDLT INTEGER, INTENT(IN) :: IW(LIW) LOGICAL, INTENT(IN) :: IS_ROOT INTEGER(8) :: NCB, NELIM, LIELL, NPIV, NROW NCB = int(IW(PTR),8) NELIM = int(IW(PTR+1),8) NROW = int(IW(PTR+2),8) NPIV = int(IW(PTR+3),8) LIELL = NPIV + NCB IF (IS_ROOT) THEN ZMUMPS_LOCAL_FACTOR_SIZE = int(IW(PTR+1),8) * & int(IW(PTR+2),8) / 2_8 RETURN ENDIF IF (NCB.GE.0_8) THEN IF (PHASE.EQ.0 & .OR. (PHASE.EQ.1.AND.LDLT.NE.0) & ) THEN ZMUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV-1_8)/2_8 + (NROW-NPIV)*NPIV ELSE ZMUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV-1_8)/2_8 + (LIELL-NPIV)*NPIV ENDIF ELSE ZMUMPS_LOCAL_FACTOR_SIZE = & -NCB*NELIM END IF RETURN END FUNCTION ZMUMPS_LOCAL_FACTOR_SIZE SUBROUTINE ZMUMPS_CHAIN_PRUN_NODES_STATS & (MYID, N, KEEP28, KEEP201, KEEP485, FR_FACT, & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_LOC # if defined(STAT_ES_SOLVE) & , NRHS, COMM, IW, LIW, PTRIST, KIXSZ, PHASE, & LDLT, K38 #endif & ) IMPLICIT NONE INTEGER, intent(in) :: KEEP28, KEEP201, OOC_FCT_TYPE_LOC, N, & KEEP485 INTEGER(8), intent(in) :: FR_FACT INTEGER, intent(in) :: nb_prun_nodes, MYID INTEGER, intent(in) :: Pruned_List(nb_prun_nodes) INTEGER, intent(in) :: STEP(N) #if defined(STAT_ES_SOLVE) INTEGER, INTENT(IN):: LIW, COMM, NRHS, LDLT, K38 INTEGER, INTENT(IN):: IW(LIW), PTRIST(KEEP28), KIXSZ, PHASE DOUBLE PRECISION :: proc_block_flops, block_flops INTEGER(8) :: Pruned_Size_ic INTEGER :: IERR INTEGER :: SK38 #endif INCLUDE 'mpif.h' INTEGER I, ISTEP INTEGER(8) :: Pruned_Size #if defined(STAT_ES_SOLVE) Pruned_Size_ic = 0_8 #endif Pruned_Size = 0_8 #if defined(STAT_ES_SOLVE) IF (K38 .GT. 0) THEN SK38 = STEP(K38) ELSE SK38 = 0 END IF #endif 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 #if defined(STAT_ES_SOLVE) IF (PTRIST(ISTEP) .GT. 0) THEN Pruned_Size_ic = Pruned_Size_ic + & ZMUMPS_LOCAL_FACTOR_SIZE(IW, LIW, & PTRIST(ISTEP)+KIXSZ, & PHASE, LDLT, & ISTEP.EQ.SK38) ENDIF # endif ENDDO #if defined(STAT_ES_SOLVE) proc_block_flops = dble(2_8*Pruned_Size_ic)*dble(NRHS) CALL MPI_REDUCE(proc_block_flops, block_flops, 1, & MPI_DOUBLE_PRECISION, MPI_SUM, 0, COMM, IERR) IF(MYID.EQ.0) nb_flops = nb_flops + block_flops #endif RETURN END SUBROUTINE ZMUMPS_CHAIN_PRUN_NODES_STATS #if defined(STAT_ES_SOLVE) SUBROUTINE ZMUMPS_SOL_ES_PRINT_STATS( & K212, K235, K237, K485, K497, NZLU8, & NRHS, ICNTL27, N, K50, DKEEPS, RINFOGS, MPG) IMPLICIT NONE INTEGER, intent(in) :: K212, K235, K237, K485, K497, & NRHS, MPG, ICNTL27, N, K50 INTEGER(8), intent(in) :: NZLU8 DOUBLE PRECISION, intent(out) :: DKEEPS(5), RINFOGS(5) LOGICAL :: AM1, ES_FWD, ES_BWD, DO_NBSPARSE IF (MPG.LE.0) RETURN AM1 = (K237 .NE. 0) ES_FWD = (K235 .NE. 0) .AND. (.NOT. AM1) ES_BWD = (K212 .NE. 0) .AND. (.NOT. AM1) DO_NBSPARSE = (K497.NE.0).AND.(NRHS.GT.1).AND.(ICNTL27.GT.1) IF (AM1) & WRITE(MPG,'(/A)') ' ** FLOPS SUMMARY during SOLVE AM1 ** ' IF ((ES_FWD).AND. (.NOT.ES_BWD)) & WRITE(MPG,'(/A,A)') ' ** FLOPS SUMMARY during fwd step', & ' (exploit RHS sparsity) ** ' IF ((.NOT.ES_FWD).AND. (ES_BWD)) & WRITE(MPG,'(/A,A)') ' ** FLOPS SUMMARY during bwd step', & ' (selected entries in solution) ** ' IF ((ES_FWD).AND. (ES_BWD)) & WRITE(MPG,'(/A,/A)') & ' ** FLOPS SUMMARY during SOLVE (fwd+bwd steps)', & ' (sparse RHS and selected entries in solution) **' IF ( & (ES_FWD) .AND. (.NOT.ES_BWD) & .OR. & (.NOT.ES_FWD) .AND. (ES_BWD) & ) THEN IF (K50.NE.0) THEN DKEEPS(1)=(dble(NZLU8)-dble(N))*dble(2*NRHS) ELSE DKEEPS(1)=(dble(NZLU8)-dble(N))*dble(NRHS) ENDIF ELSE IF ((ES_FWD).AND.(ES_BWD)) THEN IF (K50.NE.0) THEN DKEEPS(1) = (dble(NZLU8)-dble(N))*dble(4*NRHS) ELSE DKEEPS(1)=(dble(NZLU8)-dble(N))*dble(2*NRHS) ENDIF ENDIF RINFOGS(1) = DKEEPS(1) IF (.NOT.AM1) THEN WRITE(MPG,'(A,F25.1)') & ' RINFOG(24) FLOPS with dense full rank format =', DKEEPS(1) ENDIF DKEEPS(2)=dble(nb_flops) IF (DO_NBSPARSE) DKEEPS(4)=dble(nb_sparse_flops) IF (DO_NBSPARSE) THEN RINFOGS(2)= DKEEPS(4) ELSE RINFOGS(2)= DKEEPS(2) ENDIF WRITE(MPG,'(A,F25.1)') & ' RINFOG(25) FLOPS with exploit sparsity (ES) =', RINFOGS(2) RETURN END SUBROUTINE ZMUMPS_SOL_ES_PRINT_STATS #endif SUBROUTINE ZMUMPS_ES_GET_SUM_Nloc ( & N, Nloc_ITAB, ITAB_loc, COMM, & SUM_idNloc_8 ) IMPLICIT NONE INTEGER, INTENT(IN) :: N #if defined(MUMPS_NOF2003) INTEGER, POINTER :: ITAB_loc (:) #else INTEGER, INTENT( IN ), POINTER :: ITAB_loc (:) #endif INTEGER, INTENT(IN) :: Nloc_ITAB INTEGER, INTENT(IN) :: COMM INTEGER(8) :: SUM_idNloc_8 INCLUDE 'mpif.h' INTEGER I, II, IERR_MPI INTEGER(8) :: idNloc_8 idNloc_8 = 0_8 DO I= 1, Nloc_ITAB II = ITAB_loc(I) IF (II.GE.1 .and. II.LE.N) & idNloc_8 = idNloc_8 + 1_8 ENDDO CALL MPI_ALLREDUCE (idNloc_8, SUM_idNloc_8, 1, & MPI_INTEGER8, & MPI_SUM, COMM, IERR_MPI ) RETURN END SUBROUTINE ZMUMPS_ES_GET_SUM_Nloc SUBROUTINE ZMUMPS_ES_NODES_SIZE_AND_FILL ( & fill, & N, NSTEPS, KEEP, STEP, Step2node, & ITAB_loc, Nloc_ITAB, & MYID, COMM, & Pruned_Sons, Lnodes_ITAB #if defined(AVOID_MPI_IN_PLACE) & , TMP_INT_ARRAY #endif & , nodes_ITAB & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N, NSTEPS, KEEP(500) INTEGER, INTENT(IN) :: Nloc_ITAB INTEGER, INTENT(IN) :: STEP(N), Step2node(NSTEPS), & ITAB_loc(max(1,Nloc_ITAB)) INTEGER, INTENT(IN) :: MYID, COMM #if defined(AVOID_MPI_IN_PLACE) INTEGER :: TMP_INT_ARRAY(NSTEPS) #endif INTEGER, INTENT(INOUT) :: Pruned_Sons(NSTEPS), Lnodes_ITAB INTEGER, OPTIONAL, INTENT(OUT) :: nodes_ITAB(max(1,Lnodes_ITAB)) INCLUDE 'mpif.h' INTEGER I, II, ISTEP, IERR_MPI, Lnodes_ITAB_loc, INODE_PRINC IF (.NOT.fill) THEN Pruned_SONS = 0 DO I= 1, Nloc_ITAB II = ITAB_loc(I) IF (II.GE.1 .and. II.LE.N) THEN ISTEP = abs(STEP(II)) IF ( Pruned_SONS(ISTEP) .eq. 0 ) THEN Pruned_SONS(ISTEP) = 1 ENDIF ENDIF ENDDO #if defined(AVOID_MPI_IN_PLACE) TMP_INT_ARRAY = Pruned_Sons #endif CALL MPI_ALLREDUCE( #if defined(AVOID_MPI_IN_PLACE) & TMP_INT_ARRAY, #else & MPI_IN_PLACE, #endif & Pruned_Sons, NSTEPS, & MPI_INTEGER, MPI_SUM, COMM, IERR_MPI) Lnodes_ITAB = 0 DO ISTEP=1,NSTEPS if (Pruned_SONS(ISTEP) .NE.0) Lnodes_ITAB=Lnodes_ITAB+1 ENDDO ELSE IF (Lnodes_ITAB.GT.0) THEN Lnodes_ITAB_loc = 0 DO ISTEP=1,NSTEPS if (Pruned_SONS(ISTEP) .GT. 0) then Lnodes_ITAB_loc=Lnodes_ITAB_loc+1 INODE_PRINC = Step2node( ISTEP ) nodes_ITAB(Lnodes_ITAB_loc) = INODE_PRINC endif ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_ES_NODES_SIZE_AND_FILL END MODULE ZMUMPS_SOL_ES SUBROUTINE ZMUMPS_PERMUTE_RHS_GS & (LP, LPOK, PROKG, MPG, PERM_STRAT, & SYM_PERM, N, NRHS, & IRHS_PTR, SIZE_IRHS_PTR, & IRHS_SPARSE, NZRHS, & PERM_RHS, IERR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: LP, MPG, PERM_STRAT, N, NRHS, & SIZE_IRHS_PTR, & NZRHS LOGICAL, INTENT(IN) :: LPOK, PROKG INTEGER, INTENT(IN) :: SYM_PERM(N) INTEGER, INTENT(IN) :: IRHS_PTR(SIZE_IRHS_PTR) INTEGER, INTENT(IN) :: IRHS_SPARSE(NZRHS) INTEGER, INTENT(OUT) :: PERM_RHS(NRHS) INTEGER, INTENT(OUT) :: IERR INTEGER :: I,J,K, POSINPERMRHS, JJ, & KPOS INTEGER, ALLOCATABLE :: ROW_REFINDEX(:) IERR = 0 IF ((PERM_STRAT.NE.-1).AND.(PERM_STRAT.NE.1)) THEN IERR=-1 IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -1 in ", & " ZMUMPS_PERMUTE_RHS_GS, PERM_STRAT =", PERM_STRAT, & " is out of range " RETURN ENDIF IF (PERM_STRAT.EQ.-1) THEN DO I=1,NRHS PERM_RHS(I) = I END DO GOTO 490 ENDIF ALLOCATE(ROW_REFINDEX(NRHS), STAT=IERR) IF (IERR.GT.0) THEN IERR=-1 IF (LPOK) THEN WRITE(LP,*) " ERROR -2 : ", & " ALLOCATE IN ZMUMPS_PERMUTE_RHS_GS OF SIZE :", & NRHS ENDIF RETURN ENDIF DO I=1,NRHS IF (IRHS_PTR(I+1)-IRHS_PTR(I).LE.0) THEN IERR = 1 IF (I.EQ.1) THEN ROW_REFINDEX(I) = IRHS_SPARSE(IRHS_PTR(I)) ELSE ROW_REFINDEX(I) = ROW_REFINDEX(I-1) ENDIF ELSE ROW_REFINDEX(I) = IRHS_SPARSE(IRHS_PTR(I)) ENDIF END DO POSINPERMRHS = 0 DO I=1,NRHS KPOS = N+1 JJ = 0 DO J=1,NRHS K = ROW_REFINDEX(J) IF (K.LE.0) CYCLE IF (SYM_PERM(K).LT.KPOS) THEN KPOS = SYM_PERM(K) JJ = J ENDIF END DO IF (JJ.EQ.0) THEN IERR = -3 IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -3 in ", & " ZMUMPS_PERMUTE_RHS_GS " GOTO 500 ENDIF POSINPERMRHS = POSINPERMRHS + 1 PERM_RHS(POSINPERMRHS) = JJ ROW_REFINDEX(JJ) = -ROW_REFINDEX(JJ) END DO IF (POSINPERMRHS.NE.NRHS) THEN IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -4 in ", & " ZMUMPS_PERMUTE_RHS_GS ", maxval(ROW_REFINDEX) IERR = -4 GOTO 500 ENDIF 490 CONTINUE 500 CONTINUE IF (allocated(ROW_REFINDEX)) DEALLOCATE(ROW_REFINDEX) END SUBROUTINE ZMUMPS_PERMUTE_RHS_GS SUBROUTINE ZMUMPS_PERMUTE_RHS_AM1 & (PERM_STRAT, SYM_PERM, & IRHS_PTR, NHRS, & PERM_RHS, SIZEPERM, IERR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: PERM_STRAT, NHRS, SIZEPERM INTEGER, INTENT(IN) :: SYM_PERM(SIZEPERM) INTEGER, INTENT(IN) :: IRHS_PTR(NHRS) INTEGER, INTENT(OUT):: IERR INTEGER, INTENT(OUT):: PERM_RHS(SIZEPERM) DOUBLE PRECISION :: RAND_NUM INTEGER I, J, STRAT IERR = 0 STRAT = PERM_STRAT IF( (STRAT.NE.-3).AND. & (STRAT.NE.-2).AND. & (STRAT.NE.-1).AND. & (STRAT.NE. 1).AND. & (STRAT.NE. 2).AND. & (STRAT.NE. 6) ) THEN WRITE(*,*)"Warning: incorrect value for the RHS permutation; ", & "defaulting to post-order" STRAT = 1 END IF IF (STRAT .EQ. -3) THEN PERM_RHS(1:SIZEPERM)=0 DO I=1, SIZEPERM CALL random_number(RAND_NUM) RAND_NUM = RAND_NUM*dble(SIZEPERM) J = ceiling(RAND_NUM) DO WHILE (PERM_RHS(J).NE.0) CALL random_number(RAND_NUM) RAND_NUM = RAND_NUM*dble(SIZEPERM) J = ceiling(RAND_NUM) ENDDO PERM_RHS(J)=I ENDDO ELSEIF (STRAT .EQ. -2) THEN DO I=1, SIZEPERM PERM_RHS(SIZEPERM -I +1) = I ENDDO ELSEIF (STRAT .EQ. -1) THEN DO I=1, SIZEPERM PERM_RHS(I) = I ENDDO ELSEIF (STRAT .EQ. 1) THEN DO I=1, SIZEPERM PERM_RHS(SYM_PERM(I)) = I ENDDO ELSEIF (STRAT .EQ. 2) THEN DO I=1, SIZEPERM PERM_RHS(SIZEPERM-SYM_PERM(I)+1) = I ENDDO ENDIF END SUBROUTINE ZMUMPS_PERMUTE_RHS_AM1 SUBROUTINE ZMUMPS_INTERLEAVE_RHS_AM1( & PERM_RHS, SIZE_PERM, & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, & IRHS_PTR, & STEP, SYM_PERM, N, NBRHS, & PROCNODE, NSTEPS, SLAVEF, KEEP199, & behaviour_L0, reorder, n_select, PROKG, MPG & ) IMPLICIT NONE INTEGER, INTENT(IN) :: SIZE_PERM, & SIZE_IPTR_WORKING, & IPTR_WORKING(SIZE_IPTR_WORKING), & SIZE_WORKING, & WORKING(SIZE_WORKING), & N, & IRHS_PTR(N+1), & STEP(N), & SYM_PERM(N), & NBRHS, & NSTEPS, & PROCNODE(NSTEPS), & SLAVEF, KEEP199, & n_select, MPG LOGICAL, INTENT(IN) :: behaviour_L0, & reorder, PROKG INTEGER, INTENT(INOUT) :: PERM_RHS(SIZE_PERM) INTEGER :: I, J, K, IVAR, IBLOCK, & entry, & node, & SIZE_PERM_WORKING, & NB_NON_EMPTY, & to_be_found, & posintmprhs, & selected, & local_selected, & current_proc, & NPROCS, & n_pass, & pass, & nblocks, & n_select_loc, & IERR INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_RHS, & PTR_PROCS, & IPTR_PERM_WORKING, & PERM_WORKING, & MYTYPENODE INTEGER, ALLOCATABLE, DIMENSION(:) :: & PERM_PO, & ISTEP2BLOCK, & NEXTINBLOCK LOGICAL, ALLOCATABLE, DIMENSION(:) :: USED LOGICAL :: allow_above_L0 INTEGER, EXTERNAL :: MUMPS_TYPENODE_ROUGH NPROCS = SIZE_IPTR_WORKING - 1 ALLOCATE(TMP_RHS(SIZE_PERM), & PTR_PROCS(NPROCS), & USED(SIZE_PERM), & IPTR_PERM_WORKING(NPROCS+1), & MYTYPENODE(NSTEPS), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in ZMUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF DO I=1, NSTEPS MYTYPENODE(I) = MUMPS_TYPENODE_ROUGH( PROCNODE(I), KEEP199 ) ENDDO NB_NON_EMPTY = 0 DO I=1,SIZE_PERM IF(IRHS_PTR(I+1)-IRHS_PTR(I).NE.0) THEN NB_NON_EMPTY = NB_NON_EMPTY + 1 END IF END DO K = 0 IPTR_PERM_WORKING(1)=1 DO I=1,NPROCS USED = .FALSE. DO J=IPTR_WORKING(I),IPTR_WORKING(I+1)-1 USED(WORKING(J)) = .TRUE. END DO DO J=1,N IF (USED(abs(STEP(PERM_RHS(J)))).AND. & ((IRHS_PTR(PERM_RHS(J)+1)-IRHS_PTR(PERM_RHS(J))).NE.0)) & THEN K = K + 1 END IF END DO IPTR_PERM_WORKING(I+1) = K+1 END DO SIZE_PERM_WORKING = K ALLOCATE(PERM_WORKING(SIZE_PERM_WORKING), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in ZMUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF K = 0 DO I=1,NPROCS USED = .FALSE. DO J=IPTR_WORKING(I),IPTR_WORKING(I+1)-1 USED(WORKING(J)) = .TRUE. END DO DO J=1,N IF (USED(abs(STEP(PERM_RHS(J)))).AND. & ((IRHS_PTR(PERM_RHS(J)+1)-IRHS_PTR(PERM_RHS(J))).NE.0)) & THEN K = K + 1 PERM_WORKING(K) = PERM_RHS(J) END IF END DO END DO IF(behaviour_L0) THEN n_pass = 2 allow_above_L0 = .false. to_be_found = 0 DO I=1,SIZE_PERM IF((MYTYPENODE(abs(STEP(I))).LE.1).AND. & (IRHS_PTR(I+1)-IRHS_PTR(I).NE.0)) & THEN to_be_found = to_be_found + 1 END IF END DO ELSE n_pass = 1 allow_above_L0 = .true. to_be_found = NB_NON_EMPTY END IF PTR_PROCS(1:NPROCS) = IPTR_PERM_WORKING(1:NPROCS) USED = .FALSE. current_proc = 1 n_select_loc = n_select IF (n_select_loc.LE.0) THEN n_select_loc = 1 ENDIF posintmprhs = 0 DO pass=1,n_pass selected = 0 DO WHILE(selected.LT.to_be_found) local_selected = 0 DO WHILE(local_selected.LT.n_select_loc) IF(PTR_PROCS(current_proc).EQ. & IPTR_PERM_WORKING(current_proc+1)) & THEN EXIT ELSE entry = PERM_WORKING(PTR_PROCS(current_proc)) node = abs(STEP(entry)) IF(.NOT.USED(entry)) THEN IF(allow_above_L0.OR.(MYTYPENODE(node).LE.1)) THEN USED(entry) = .TRUE. selected = selected + 1 local_selected = local_selected + 1 posintmprhs = posintmprhs + 1 TMP_RHS(posintmprhs) = entry IF(selected.EQ.to_be_found) EXIT END IF END IF PTR_PROCS(current_proc) = PTR_PROCS(current_proc) + 1 END IF END DO current_proc = mod(current_proc,NPROCS)+1 END DO to_be_found = NB_NON_EMPTY - to_be_found allow_above_L0 = .true. PTR_PROCS(1:NPROCS) = IPTR_PERM_WORKING(1:NPROCS) END DO DO I=1,SIZE_PERM IF(IRHS_PTR(PERM_RHS(I)+1)-IRHS_PTR(PERM_RHS(I)).EQ.0) THEN posintmprhs = posintmprhs+1 TMP_RHS(posintmprhs) = PERM_RHS(I) IF(posintmprhs.EQ.SIZE_PERM) EXIT END IF END DO DEALLOCATE(PTR_PROCS, USED, & IPTR_PERM_WORKING, & PERM_WORKING, MYTYPENODE) IF(reorder) THEN nblocks = (N+NBRHS-1)/NBRHS ALLOCATE(PERM_PO(N), ISTEP2BLOCK(N), NEXTINBLOCK(nblocks), & stat=IERR) IF(IERR.GT.0) THEN IF (PROKG ) WRITE(MPG,*) & 'Warning: reorder not done in ZMUMPS_INTERLEAVE_RHS_AM1' PERM_RHS = TMP_RHS GOTO 500 ENDIF DO IVAR = 1, N K = SYM_PERM( IVAR ) PERM_PO( K ) = IVAR END DO DO I = 1, N IBLOCK = 1 + ( I - 1 ) / NBRHS IVAR = TMP_RHS( I ) K = SYM_PERM( IVAR ) ISTEP2BLOCK( K ) = IBLOCK END DO DO IBLOCK = 1, NBLOCKS NEXTINBLOCK(IBLOCK) = 1 + (IBLOCK-1)*NBRHS ENDDO DO K = 1, N IBLOCK = ISTEP2BLOCK(K) IVAR = PERM_PO(K) PERM_RHS(NEXTINBLOCK(IBLOCK)) = IVAR NEXTINBLOCK(IBLOCK) = NEXTINBLOCK(IBLOCK) + 1 ENDDO ELSE PERM_RHS = TMP_RHS END IF 500 CONTINUE DEALLOCATE(TMP_RHS) IF (allocated(PERM_PO )) DEALLOCATE(PERM_PO ) IF (allocated(ISTEP2BLOCK)) DEALLOCATE(ISTEP2BLOCK) IF (allocated(NEXTINBLOCK)) DEALLOCATE(NEXTINBLOCK) RETURN END SUBROUTINE ZMUMPS_INTERLEAVE_RHS_AM1 MUMPS_5.8.1/src/crank_revealing.F0000664000175000017500000005645415042446440016507 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_GET_NS_OPTIONS_FACTO(N,KEEP,ICNTL,MPG) IMPLICIT NONE INTEGER N, KEEP(500), ICNTL(60), MPG KEEP(19)=0 KEEP(19)=ICNTL(56) IF ((KEEP(19).LT.1).OR.(KEEP(19).GE.2)) KEEP(19)=0 IF ( KEEP(53) .LE. 0 .and. & KEEP(19) .NE. 0 ) THEN KEEP(19) = 0 IF ( MPG .GT. 0 ) THEN WRITE( MPG,'(A)') '** Warning: ICNTL(56) null space option' WRITE( MPG,'(A)') '** disabled (incompatibility with analysis)' END IF END IF KEEP(21) = min(ICNTL(57),N) KEEP(22) = max(ICNTL(55),0) IF ( KEEP(19) .ne. 0 .and. KEEP(60) .ne. 0 ) THEN IF ( MPG .GT. 0 ) THEN WRITE( MPG,'(A)') '** Warning: ICNTL(56) null space option' WRITE( MPG,'(A)') '** disabled (incompatibility with Schur)' END IF KEEP(19) = 0 END IF RETURN END SUBROUTINE CMUMPS_GET_NS_OPTIONS_FACTO SUBROUTINE CMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL, KEEP, & NRHS, MPG, INFO) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500), NRHS, MPG, ICNTL(60) INTEGER, intent(inout):: INFO(80) IF (KEEP(19).EQ.0.AND.KEEP(110).EQ.0) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 56 IF (KEEP(110).EQ.0) INFO(2) = 24 IF(MPG.GT.0) THEN WRITE( MPG,'(A)') &'** ERROR : Null space computation requirement' WRITE( MPG,'(A)') &'** not consistent with factorization options' ENDIF GOTO 333 ENDIF ENDIF IF (ICNTL(9).NE.1) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 9 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') &'** ERROR ICNTL(25) incompatible with ' WRITE( MPG,'(A)') &'** option transposed system (ICNTL(9).ne.1) ' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(19).EQ.2) THEN IF ((KEEP(111).NE.0).AND.(KEEP(50).EQ.0)) THEN INFO(1) = -37 INFO(2) = 0 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') &'** ERROR ICNTL(25) incompatible with ' WRITE( MPG,'(A)') &'** option RRQR (ICNLT(56)=2) and unsym. matrices ' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(111).eq.-1.AND.NRHS.NE.KEEP(112)+KEEP(17))THEN INFO(1)=-32 INFO(2)=NRHS GOTO 333 ENDIF IF (KEEP(111).gt.0 .AND. NRHS .NE. 1) THEN INFO(1)=-32 INFO(2)=NRHS GOTO 333 ENDIF IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) and ICNTL(30) functionalities ', & ' incompatible with null space' ENDIF INFO(1) = -37 IF (KEEP(237).NE.0) THEN INFO(2) = 30 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(30) functionality ', & ' incompatible with null space' ENDIF ELSE IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) functionality ', & ' incompatible with null space' ENDIF INFO(2) = 20 ENDIF GOTO 333 ENDIF IF (( KEEP(111) .LT. -1 ) .OR. & (KEEP(111).GT.KEEP(112)+KEEP(17)) .OR. & (KEEP(111) .EQ.-1 .AND. KEEP(112)+KEEP(17).EQ.0)) & THEN INFO(1)=-36 INFO(2)=KEEP(111) GOTO 333 ENDIF IF (KEEP(221).NE.0.AND.KEEP(111).NE.0) THEN INFO(1)=-37 INFO(2)=26 GOTO 333 ENDIF 333 CONTINUE RETURN END SUBROUTINE CMUMPS_GET_NS_OPTIONS_SOLVE SUBROUTINE CMUMPS_RR_INIT_POINTERS(roota) USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: roota NULLIFY(roota%QR_TAU) NULLIFY(roota%SVD_U) NULLIFY(roota%SVD_VT) NULLIFY(roota%SINGULAR_VALUES) RETURN END SUBROUTINE CMUMPS_RR_INIT_POINTERS SUBROUTINE CMUMPS_RR_FREE_POINTERS(roota) USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: roota IF (associated(roota%QR_TAU)) THEN DEALLOCATE(roota%QR_TAU) NULLIFY(roota%QR_TAU) ENDIF IF (associated(roota%SVD_U)) THEN DEALLOCATE(roota%SVD_U) NULLIFY(roota%SVD_U) ENDIF IF (associated(roota%SVD_VT)) THEN DEALLOCATE(roota%SVD_VT) NULLIFY(roota%SVD_VT) ENDIF IF (associated(roota%SINGULAR_VALUES)) THEN DEALLOCATE(roota%SINGULAR_VALUES) NULLIFY(roota%SINGULAR_VALUES) ENDIF RETURN END SUBROUTINE CMUMPS_RR_FREE_POINTERS SUBROUTINE CMUMPS_SEQ_SYMMETRIZE(N,A) INTEGER N COMPLEX A( N, N ) INTEGER I,J DO I = 2, N DO J = 1, I - 1 A( I, J ) = A( J, I ) END DO END DO RETURN END SUBROUTINE CMUMPS_SEQ_SYMMETRIZE SUBROUTINE CMUMPS_UXVSBP(N,PERM,X,RN01) INTEGER N,PERM(N),I COMPLEX RN01(N),X(N) DO I=1,N RN01(PERM(I))=X(I) ENDDO DO I=1,N X(I)=RN01(I) ENDDO RETURN END SUBROUTINE CMUMPS_UXVSBP SUBROUTINE CMUMPS_UXVSFP(N,PERM,X,RN01) INTEGER N,PERM(N),I COMPLEX RN01(N),X(N) DO I=1,N RN01(I)=X(PERM(I)) ENDDO DO I=1,N X(I)=RN01(I) ENDDO RETURN END SUBROUTINE CMUMPS_UXVSFP SUBROUTINE CMUMPS_SVD_QR_ESTIM_WK( PHASE, MBLOCK, NBLOCK, & SIZE_ROOT_ARG, & LOCAL_M, LOCAL_N, ROOT_OWNER, KEEP,KEEP8, & LIWK_RR, LWK_RR ) IMPLICIT NONE INTEGER, INTENT(IN) :: PHASE, SIZE_ROOT_ARG INTEGER, INTENT(IN) :: MBLOCK, NBLOCK, LOCAL_M, LOCAL_N LOGICAL, INTENT(IN) :: ROOT_OWNER INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(OUT):: LIWK_RR INTEGER(8), INTENT(OUT):: LWK_RR INTEGER SIZE_ROOT INTEGER NBPOSPONED_ESTIM PARAMETER (NBPOSPONED_ESTIM=2000) INTEGER SVD_QR,PAR_ROOT SVD_QR = KEEP(19) PAR_ROOT = KEEP(38) LIWK_RR = 0 LWK_RR = 0_8 IF (PAR_ROOT.EQ.0) THEN IF(ROOT_OWNER) THEN IF (PHASE.EQ.0) THEN SIZE_ROOT=SIZE_ROOT_ARG+NBPOSPONED_ESTIM ELSE SIZE_ROOT=SIZE_ROOT_ARG ENDIF IF(SVD_QR.EQ.1) THEN LWK_RR=int(3*SIZE_ROOT+1,8) ELSEIF(SVD_QR.EQ.2) THEN LWK_RR=int(SIZE_ROOT+1,8) END IF END IF ENDIF RETURN END SUBROUTINE CMUMPS_SVD_QR_ESTIM_WK SUBROUTINE CMUMPS_SEQ_FACTO_ROOT_SVD_QR &(NN,A,root,roota,WR03,LWR03,KEEP,KEEP8,INFO,LP,DKEEP, & GLOBK109,OPELIW,PIVNUL_LIST,LPIVNUL_LIST, & ROW_INDICES) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE ( MUMPS_ROOT_STRUC ) :: root TYPE ( CMUMPS_ROOT_STRUC ) :: roota INTEGER :: NN,LP,LWR03,LWR03_MINSIZE COMPLEX :: A(NN*NN) INTEGER :: INFO(2),KEEP(500) INTEGER(8) :: KEEP8(150) REAL :: DKEEP(230) DOUBLE PRECISION :: OPELIW INTEGER :: GLOBK109 INTEGER :: LPIVNUL_LIST INTEGER :: PIVNUL_LIST(LPIVNUL_LIST) INTEGER :: ROW_INDICES(NN) COMPLEX :: WR03(LWR03) INTEGER LDLT,DEFICIENCY REAL, DIMENSION(:), ALLOCATABLE :: RWORK INTEGER :: I,LDA,LDU,LDVT,J INTEGER :: IERR, LAST_BEFORE_GAP_IND INTEGER :: LAST_BEFORE_GAPLIMIT_IND, FIRST_AFTER_MinPiv, & FIRST_AFTER_GAPLIMIT, START_POINT, END_POINT INTEGER :: ALLOCOK,MAXDEF,MINDEF REAL :: EPS, ZERO, GAPLIMIT, MaxGap, MaxGap1, & MinPiv, Tol_MaxGap PARAMETER(ZERO=0.0E0) EPS = epsilon(ZERO) LDLT=KEEP(50) IF ((KEEP(19) .NE. 1).AND.(KEEP(19) .NE. 2)) THEN INFO(1)=-107 INFO(2)= KEEP(19) IF ( LP .GT. 0 ) THEN WRITE(LP,*) " *** Option ",KEEP(19), & " for null space no more available." ENDIF GOTO 100 ENDIF IF(KEEP(19).EQ.1) THEN LWR03_MINSIZE=3*NN+1 ELSEIF(KEEP(19).EQ.2) THEN LWR03_MINSIZE=NN+1 END IF MAXDEF=KEEP(21) IF ( MAXDEF .LE. 0 ) THEN MAXDEF = NN ELSE MAXDEF = max(MAXDEF - GLOBK109,0) ENDIF MINDEF = max(KEEP(22) - GLOBK109,0) MINDEF = min(MINDEF,NN) MAXDEF = min(MAXDEF,NN) IF(KEEP(19).EQ.1) THEN OPELIW = OPELIW + dble(26)*dble(NN)*dble(NN)*dble(NN) ELSEIF(KEEP(19).EQ.2) THEN OPELIW = OPELIW + dble(4)*dble(NN)*dble(NN)*dble(NN)/dble(3) ENDIF IF (associated(roota%SINGULAR_VALUES)) & DEALLOCATE(roota%SINGULAR_VALUES) NULLIFY(roota%SINGULAR_VALUES) root%NB_SINGULAR_VALUES=NN ALLOCATE(roota%SINGULAR_VALUES(NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN IF ( LP .GT. 0 ) & WRITE(LP,*) 'CMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating SINGULAR_VALUES' GOTO 100 END IF IF(KEEP(19).EQ.1) THEN IF(associated(roota%SVD_U)) DEALLOCATE(roota%SVD_U) NULLIFY(roota%SVD_U) ALLOCATE(roota%SVD_U(NN,NN),stat=ALLOCOK ) IF(ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NN IF ( LP .GT. 0 ) & WRITE(LP,*) 'CMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating SVD_U' GOTO 100 END IF IF (associated(roota%SVD_VT)) DEALLOCATE(roota%SVD_VT) NULLIFY(roota%SVD_VT) ALLOCATE(roota%SVD_VT(NN,NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NN IF ( LP .GT. 0 ) & WRITE(LP,*) 'CMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating SVD_VT' GOTO 100 END IF IF (allocated(RWORK)) DEALLOCATE(RWORK) ALLOCATE(RWORK(5*NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=5*NN IF ( LP .GT. 0 ) & WRITE(LP,*) & 'CMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating RWORK' GOTO 100 END IF ELSEIF(KEEP(19).EQ.2) THEN IF (associated(roota%QR_TAU)) DEALLOCATE(roota%QR_TAU) NULLIFY(roota%QR_TAU) ALLOCATE(roota%QR_TAU(NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN IF ( LP .GT. 0 ) & WRITE(LP,*) & 'CMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating QR_TAU' GOTO 100 END IF IF (associated(ROOT%IPIV)) DEALLOCATE(ROOT%IPIV) NULLIFY(ROOT%IPIV) ALLOCATE(ROOT%IPIV(NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN IF ( LP .GT. 0 ) & WRITE(LP,*) & 'CMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating IPIV' GOTO 100 END IF IF (allocated(RWORK)) DEALLOCATE(RWORK) ALLOCATE(RWORK(2*NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=2*NN IF ( LP .GT. 0 ) & WRITE(LP,*) & 'CMUMPS_SEQ_FACTO_ROOT_SVD_QR: Problem ' & //'allocating RWORK' GOTO 100 END IF ENDIF IF (LDLT.NE.0) THEN CALL CMUMPS_SEQ_SYMMETRIZE(NN,A) END IF LDA=NN LDU=NN LDVT=NN IERR = 0 IF(KEEP(19).EQ.1) THEN CALL cgesvd('A','A',NN,NN,A,LDA,roota%SINGULAR_VALUES(1) & ,roota%SVD_U(1,1) & ,LDU,roota%SVD_VT(1,1),LDVT,WR03,LWR03,RWORK,IERR) ENDIF IF(IERR.NE.0) THEN INFO(1)=-107 INFO(2)=IERR IF (LP.GT.0) THEN IF(KEEP(19).EQ.1) THEN WRITE(LP,*) ' Problem in cgesvd : IERR = ', IERR ELSEIF(KEEP(19).EQ.2) THEN WRITE(LP,*) ' Problem in cgeqpf : IERR = ', IERR ENDIF GOTO 100 END IF ENDIF IF(KEEP(19).EQ.2) THEN DO I=1,NN roota%SINGULAR_VALUES(I)=abs(A(I+NN*(I-1))) ENDDO ENDIF DEFICIENCY=0 MinPiv = DKEEP(20) GAPLIMIT = DKEEP(9) IF (roota%SINGULAR_VALUES(NN).GT.MinPiv) THEN DEFICIENCY = 0 GOTO 170 ENDIF IF (roota%SINGULAR_VALUES(1).LE.GAPLIMIT) THEN DEFICIENCY = NN GOTO 170 ENDIF LAST_BEFORE_GAPLIMIT_IND = 0 LAST_BEFORE_GAP_IND = 0 FIRST_AFTER_MinPiv = 0 FIRST_AFTER_GAPLIMIT = 0 MaxGap = 0 MaxGap1 = 0 Tol_MaxGap = DKEEP(24) DO I=NN,1,-1 IF (FIRST_AFTER_MinPiv.GT.0) exit IF(roota%SINGULAR_VALUES(I).LE.GAPLIMIT) THEN LAST_BEFORE_GAPLIMIT_IND = I ELSE IF ((FIRST_AFTER_GAPLIMIT.EQ.0).AND. & (roota%SINGULAR_VALUES(I).LE.MinPiv)) THEN FIRST_AFTER_GAPLIMIT = I ELSE IF (roota%SINGULAR_VALUES(I).GT.MinPiv) THEN FIRST_AFTER_MinPiv = I IF (FIRST_AFTER_GAPLIMIT.EQ.0) FIRST_AFTER_GAPLIMIT = I ENDIF ENDDO START_POINT = LAST_BEFORE_GAPLIMIT_IND IF ((LAST_BEFORE_GAPLIMIT_IND.EQ.0).AND. & (FIRST_AFTER_GAPLIMIT.GT. FIRST_AFTER_MinPiv)) & START_POINT = FIRST_AFTER_GAPLIMIT END_POINT = FIRST_AFTER_MinPiv IF (FIRST_AFTER_MinPiv.EQ.0) END_POINT = 1 DO I=START_POINT,END_POINT+1,-1 IF (roota%SINGULAR_VALUES(I).EQ.0) THEN LAST_BEFORE_GAP_IND = I ELSE MaxGap1 = roota%SINGULAR_VALUES(I-1)* & (1/roota%SINGULAR_VALUES(I)) IF (MaxGap1.GE. Tol_MaxGap) THEN IF (MaxGap1.GE. DKEEP(25)*MaxGap ) THEN LAST_BEFORE_GAP_IND = I MaxGap = MaxGap1 ENDIF ENDIF ENDIF ENDDO IF (MaxGap.EQ.ZERO) THEN IF (LAST_BEFORE_GAPLIMIT_IND.EQ.0) THEN DEFICIENCY = 0 ELSE DEFICIENCY = NN - LAST_BEFORE_GAPLIMIT_IND +1 ENDIF ELSE DEFICIENCY = NN - LAST_BEFORE_GAP_IND +1 ENDIF 170 CONTINUE DEFICIENCY=min(DEFICIENCY,MAXDEF) DEFICIENCY=max(DEFICIENCY,MINDEF) KEEP(17)=DEFICIENCY IF(KEEP(19).EQ.2) THEN IF(DEFICIENCY.GT.0) THEN CALL ctrtrs('U','N','N',NN-DEFICIENCY,DEFICIENCY, & A,LDA,A(LDA*(NN-DEFICIENCY)+1),LDA,IERR) IF ( IERR .NE. 0 ) THEN IF (LP.GT.0) & WRITE(LP,*) ' Internal error in ctrtrs: IERR = ',IERR CALL MUMPS_ABORT() END IF END IF ENDIF DO J=NN-DEFICIENCY+1, NN IF(KEEP(19).EQ.1) THEN PIVNUL_LIST(J-NN+DEFICIENCY) = ROW_INDICES(J) ELSEIF(KEEP(19).EQ.2) THEN PIVNUL_LIST(J-NN+DEFICIENCY) = ROW_INDICES(root%IPIV(J)) ENDIF ENDDO 100 CONTINUE IF (allocated(RWORK)) DEALLOCATE(RWORK) RETURN END SUBROUTINE CMUMPS_SEQ_FACTO_ROOT_SVD_QR SUBROUTINE CMUMPS_SEQ_SOLVE_ROOT_SVD_QR & (NRHS,NN,A,root, roota, & IBEG_ROOT_DEF, IEND_ROOT_DEF, & RHS,KEEP,KEEP8,MTYPE,INFO,LWK8,WK, LP) USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER NN, NRHS INTEGER(8), INTENT(IN) :: LWK8 TYPE ( MUMPS_ROOT_STRUC ) :: root TYPE ( CMUMPS_ROOT_STRUC ) :: roota COMPLEX A(NN*NN) INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, MTYPE INTEGER INFO(2),KEEP(500) INTEGER(8) KEEP8(150) COMPLEX RHS(NN,NRHS), WK(LWK8) INTEGER LP INTEGER :: LWK COMPLEX,DIMENSION(:,:), allocatable :: TEMP_RHS INTEGER :: I,IERR,K INTEGER :: LDLT,RRSTRAT,DEFICIENCY,LDA,LDRHS INTEGER :: ALLOCOK REAL, PARAMETER :: RONE=1.0E+0 COMPLEX ZERO, ONE, MINUSONE PARAMETER( ZERO = (0.0E0,0.0E0), ONE = (1.0E0,0.0E0)) PARAMETER( MINUSONE=(-1.0E0,0.0E0)) LDLT = KEEP(50) RRSTRAT = KEEP(19) DEFICIENCY = KEEP(17) LDA = NN LDRHS = NN LWK = int(min(int(huge(LWK),8),LWK8)) IERR = 0 IF ((RRSTRAT .NE. 1).AND.(RRSTRAT .NE. 2)) THEN WRITE(*,*) " *** Internal error ption ",RRSTRAT, & " for null space no more available." CALL MUMPS_ABORT() ENDIF IF (KEEP(111).EQ.0) THEN IF(KEEP(19).EQ.1) THEN IF ((MTYPE.EQ.0).OR.(LDLT.GT.0)) THEN allocate(TEMP_RHS(NN,NRHS), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NRHS IF ( LP .GT. 0 ) & WRITE(LP,*) & 'CMUMPS_SEQ_SOLVE_ROOT_SVD_QR: Problem ' & //'allocating TEMP_RHS' RETURN END IF CALL cgemm('Conjugate transpose','N',NN,NRHS,NN,ONE, & roota%SVD_U(1,1),NN,RHS, & NN,ZERO,TEMP_RHS,NN) DO I=1,NN-DEFICIENCY TEMP_RHS( I, 1:NRHS ) = & cmplx(RONE/roota%SINGULAR_VALUES(I),kind=kind(TEMP_RHS))* & TEMP_RHS( I, 1:NRHS ) ENDDO DO I=NN-DEFICIENCY +1, NN TEMP_RHS(I, 1:NRHS) = ZERO ENDDO CALL cgemm('Conjugate transpose','N',NN,NRHS,NN,ONE, & roota%SVD_VT(1,1),NN, & TEMP_RHS, NN,ZERO,RHS,NN) DEALLOCATE(TEMP_RHS) ELSEIF(MTYPE.EQ.1) THEN allocate(TEMP_RHS(NRHS,NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NRHS IF ( LP .GT. 0 ) & WRITE(LP,*) & 'CMUMPS_SEQ_SOLVE_ROOT_SVD_QR: Problem ' & //'allocating TEMP_RHS' RETURN END IF CALL cgemm('T','C',NRHS,NN, NN,ONE,RHS, NN, & roota%SVD_VT(1,1),NN, & ZERO,TEMP_RHS,NRHS) DO I=1,NN-DEFICIENCY RHS(I, 1:NRHS ) = & cmplx(RONE/roota%SINGULAR_VALUES(I),kind=kind(TEMP_RHS))* & TEMP_RHS(1:NRHS,I ) ENDDO DO I=NN-DEFICIENCY +1, NN RHS(I,1:NRHS) = ZERO ENDDO CALL cgemm('T','C',NRHS,NN,NN,ONE,RHS, NN, & roota%SVD_U(1,1),NN, & ZERO,TEMP_RHS,NRHS) DO I=1,NRHS RHS(1:NN,I) =TEMP_RHS(I,1:NN ) ENDDO DEALLOCATE(TEMP_RHS) ENDIF ELSEIF(KEEP(19).EQ.2) THEN IF ((MTYPE.EQ.0).OR.(LDLT.GT.0)) THEN CALL cunmqr('L','Conjugate transpose',NN,NRHS,NN, & A,LDA,roota%QR_TAU(1), & RHS,LDRHS,WK(1),LWK,IERR) IF(IERR.LT.0) THEN WRITE(*,*) & 'Error return from cunmqr in root solve: IERR=', IERR RETURN END IF CALL ctrtrs('U','N','N',NN-DEFICIENCY,NRHS,A,LDA, & RHS,LDRHS,IERR) IF ( IERR .LT. 0 ) THEN WRITE(*,*) & 'Error return from ctrtrs in roor solve: IERR =',IERR RETURN END IF DO I=1,NRHS RHS( NN - DEFICIENCY + 1: NN, I ) = ZERO ENDDO DO I=1,NRHS CALL CMUMPS_UXVSBP(NN,root%IPIV(1),RHS(1,I),WK) ENDDO ELSEIF(MTYPE.EQ.1) THEN DO I=1,NRHS CALL CMUMPS_UXVSFP(NN,root%IPIV(1),RHS(1,I),WK) ENDDO CALL ctrtrs('U','T','N',NN-DEFICIENCY,NRHS, & A,LDA,RHS,LDRHS,IERR) IF(IERR.NE.0) THEN WRITE(*,*) 'Error return from trtrs: IERR=', IERR STOP END IF allocate(TEMP_RHS(NRHS,NN), stat=ALLOCOK) IF (ALLOCOK.GT.0) THEN INFO(1)=-13 INFO(2)=NN*NRHS IF ( LP .GT. 0 ) & WRITE(LP,*) & 'CMUMPS_SEQ_SOLVE_ROOT_SVD_QR: Problem ' & //'allocating TEMP_RHS' RETURN END IF DO I=1,NRHS TEMP_RHS(I,1:NN-DEFICIENCY)=RHS(1:NN-DEFICIENCY, I) ENDDO DO I=NN - DEFICIENCY + 1,NN TEMP_RHS( 1: NRHS, I ) = ZERO ENDDO CALL cunmqr( 'R','Conjugate transpose',NRHS,NN,NN,A,LDA, & roota%QR_TAU(1), & TEMP_RHS,NRHS,WK,LWK,IERR) IF(IERR.LT.0) THEN WRITE(*,*) 'Error return from cunmqr: IERR=', IERR RETURN END IF DO I=1,NRHS RHS(1:NN, I)= TEMP_RHS(I,1:NN) ENDDO DEALLOCATE(TEMP_RHS) ENDIF ENDIF ELSE IF(KEEP(19).EQ.1) THEN IF ((MTYPE.EQ.0).OR.(LDLT.GT.0)) THEN DO I=IBEG_ROOT_DEF,IEND_ROOT_DEF RHS(:,I+1-IBEG_ROOT_DEF) = & CONJG(roota%SVD_VT(NN-DEFICIENCY+I,:)) ENDDO ELSEIF(MTYPE.EQ.1) THEN DO I=IBEG_ROOT_DEF,IEND_ROOT_DEF RHS(:,I+1-IBEG_ROOT_DEF) = & CONJG(roota%SVD_U(:,NN-DEFICIENCY+I)) ENDDO ENDIF ELSEIF(KEEP(19).EQ.2) THEN IF((MTYPE.EQ.0).OR.(LDLT.GT.0)) THEN DO I=IBEG_ROOT_DEF,IEND_ROOT_DEF RHS(NN-DEFICIENCY+I,I-IBEG_ROOT_DEF+1) = MINUSONE DO K=1,NN-DEFICIENCY RHS(K,I-IBEG_ROOT_DEF+1)= & A(K + LDA*(NN-DEFICIENCY+I-1)) ENDDO ENDDO DO I=1,IEND_ROOT_DEF-IBEG_ROOT_DEF+1 CALL CMUMPS_UXVSBP(NN,root%IPIV(1),RHS(1,I),WK) ENDDO ELSEIF(MTYPE.EQ.1) THEN WRITE(*,*) 'Computation of a null space basis' & // ' of A is unavailable for unsymetric matrices' DO I=IBEG_ROOT_DEF,IEND_ROOT_DEF RHS(NN-DEFICIENCY+I,I-IBEG_ROOT_DEF+1) = ONE ENDDO CALL cunmqr('L','N',NN,NRHS,NN, A,LDA,roota%QR_TAU(1), & RHS,LDRHS,WK(1),LWK,IERR) ENDIF ENDIf ENDIF RETURN END SUBROUTINE CMUMPS_SEQ_SOLVE_ROOT_SVD_QR MUMPS_5.8.1/src/clr_type.F0000664000175000017500000000465215042446440015167 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_LR_TYPE IMPLICIT NONE TYPE LRB_TYPE COMPLEX,POINTER,DIMENSION(:,:) :: Q => null() COMPLEX,POINTER,DIMENSION(:,:) :: R => null() INTEGER :: K,M,N LOGICAL :: ISLR END TYPE LRB_TYPE CONTAINS SUBROUTINE DEALLOC_LRB(LRB_OUT, KEEP8, K34 & ) TYPE(LRB_TYPE), INTENT(INOUT) :: LRB_OUT INTEGER(8) :: KEEP8(150) INTEGER :: K34 INTEGER :: MEM, IDUMMY, JDUMMY IF (LRB_OUT%M.EQ.0) RETURN IF (LRB_OUT%N.EQ.0) RETURN MEM = 0 IF (LRB_OUT%ISLR) THEN IF (associated(LRB_OUT%Q)) THEN MEM = MEM + size(LRB_OUT%Q) DEALLOCATE (LRB_OUT%Q) NULLIFY(LRB_OUT%Q) ENDIF IF (associated(LRB_OUT%R)) THEN MEM = MEM + size(LRB_OUT%R) DEALLOCATE (LRB_OUT%R) NULLIFY(LRB_OUT%R) ENDIF ELSE IF (associated(LRB_OUT%Q)) THEN MEM = MEM + size(LRB_OUT%Q) DEALLOCATE (LRB_OUT%Q) NULLIFY(LRB_OUT%Q) ENDIF ENDIF CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(-int(MEM,8), & .TRUE., KEEP8, & IDUMMY, JDUMMY, & .TRUE., .TRUE.) END SUBROUTINE DEALLOC_LRB SUBROUTINE DEALLOC_BLR_PANEL(BLR_PANEL, IEND, KEEP8, K34, IBEG_IN) INTEGER, INTENT(IN) :: IEND TYPE(LRB_TYPE), INTENT(INOUT) :: BLR_PANEL(:) INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: K34 INTEGER, INTENT(IN), OPTIONAL :: IBEG_IN INTEGER :: I, IBEG IF (present(IBEG_IN)) THEN IBEG = IBEG_IN ELSE IBEG = 1 ENDIF IF (IEND.GE.IBEG) THEN IF (BLR_PANEL(1)%M.NE.0) THEN DO I=IBEG, IEND CALL DEALLOC_LRB(BLR_PANEL(I), KEEP8, K34) ENDDO ENDIF ENDIF END SUBROUTINE DEALLOC_BLR_PANEL END MODULE CMUMPS_LR_TYPE MUMPS_5.8.1/src/dfac_lastrtnelind.F0000664000175000017500000002076215042446440017026 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, & root, roota, FRERE, IROOT, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_SEND_ROOT2SLAVE, & MUMPS_BUF_SEND_ROOT2SON USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE DMUMPS_INTR_TYPES, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (DMUMPS_ROOT_STRUC) :: roota INTEGER IROOT INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC,IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER(8) :: LA INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(KEEP(280)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP8(85)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) INTEGER ND(KEEP(28)), FRERE(KEEP(28)) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER I, NELIM, NB_CONTRI_GLOBAL, NUMORG, & NFRONT, IROW, JCOL, PDEST, HF, IOLDPS, & IN, DEB_ROW, ILOC_ROW, IFSON, ILOC_COL, & IPOS_SON, NELIM_SON, NSLAVES_SON, HS, & IROW_SON, ICOL_SON, ISLAVE, IERR, & NELIM_SENT, IPOS_STATREC, TYPE_SON INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' NB_CONTRI_GLOBAL = KEEP(41) NUMORG = root%ROOT_SIZE NELIM = KEEP(42) NFRONT = NUMORG + KEEP(42) DO IROW = 0, root%NPROW - 1 DO JCOL = 0, root%NPCOL - 1 PDEST = IROW * root%NPCOL + JCOL IF ( PDEST .NE. MYID ) THEN CALL MUMPS_BUF_SEND_ROOT2SLAVE(NFRONT, & NB_CONTRI_GLOBAL, PDEST, COMM, KEEP, IERR) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'MUMPS_BUF_SEND_ROOT2SLAVE' CALL MUMPS_ABORT() endif ENDIF END DO END DO CALL DMUMPS_PROCESS_ROOT2SLAVE( NFRONT, & NB_CONTRI_GLOBAL, root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND ) IF (IFLAG < 0 ) RETURN HF = 6 + KEEP(IXSZ) IOLDPS = PTLUST_S(STEP(IROOT)) IN = IROOT DEB_ROW = IOLDPS + HF ILOC_ROW = DEB_ROW DO WHILE (IN.GT.0) IW(ILOC_ROW) = IN IW(ILOC_ROW+NFRONT) = IN ILOC_ROW = ILOC_ROW + 1 IN = FILS(IN) END DO IFSON = -IN ILOC_ROW = IOLDPS + HF + NUMORG ILOC_COL = ILOC_ROW + NFRONT IF ( NELIM.GT.0 ) THEN IN = IFSON DO WHILE (IN.GT.0) IPOS_SON = PIMASTER(STEP(IN)) IF (IPOS_SON .EQ. 0) GOTO 100 NELIM_SON = IW(IPOS_SON+1+KEEP(IXSZ)) if (NELIM_SON.eq.0) then write(6,*) ' error 1 in process_last_rtnelind' CALL MUMPS_ABORT() endif NSLAVES_SON = IW(IPOS_SON+5+KEEP(IXSZ)) HS = 6 + NSLAVES_SON + KEEP(IXSZ) IROW_SON = IPOS_SON + HS ICOL_SON = IROW_SON + NELIM_SON DO I = 1, NELIM_SON IW( ILOC_ROW+I-1 ) = IW( IROW_SON+I-1 ) ENDDO DO I = 1, NELIM_SON IW( ILOC_COL+I-1 ) = IW( ICOL_SON+I-1 ) ENDDO NELIM_SENT = ILOC_ROW - IOLDPS - HF + 1 DO ISLAVE = 0,NSLAVES_SON IF (ISLAVE.EQ.0) THEN PDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)),KEEP(199)) ELSE PDEST = IW(IPOS_SON + 5 + ISLAVE+KEEP(IXSZ)) ENDIF IF (PDEST.NE.MYID) THEN CALL MUMPS_BUF_SEND_ROOT2SON(IN, NELIM_SENT, & PDEST, COMM, KEEP, IERR ) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'MUMPS_BUF_SEND_ROOT2SON' CALL MUMPS_ABORT() endif ELSE CALL DMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & IN, NELIM_SENT, root, roota, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( ISLAVE .NE. 0 ) THEN IF (KEEP(50) .EQ. 0) THEN IPOS_STATREC = PTRIST(STEP(IN))+6+KEEP(IXSZ) ELSE IPOS_STATREC = PTRIST(STEP(IN))+8+KEEP(IXSZ) ENDIF IF (IW(IPOS_STATREC).EQ. S_REC_CONTSTATIC) THEN IW(IPOS_STATREC) = S_ROOT2SON_CALLED ELSE IF (NSLAVES_SON .EQ. 0) THEN TYPE_SON = 1 ELSE TYPE_SON = 2 ENDIF CALL DMUMPS_FREE_BAND( N, IN, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON & ) ENDIF ENDIF IPOS_SON = PIMASTER(STEP(IN)) ENDIF END DO CALL DMUMPS_FREE_BLOCK_CB_STATIC( & .FALSE., MYID, N, IPOS_SON, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) ILOC_ROW = ILOC_ROW + NELIM_SON ILOC_COL = ILOC_COL + NELIM_SON 100 CONTINUE IN = FRERE(STEP(IN)) ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_LAST_RTNELIND MUMPS_5.8.1/src/mumps_io_err.c0000664000175000017500000001047115042446422016077 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mumps_io_err.h" #include "mumps_io_basic.h" #include "mumps_c_types.h" #if defined( MUMPS_WIN32 ) # include #endif /* Exported global variables */ char* mumps_err; MUMPS_INT* dim_mumps_err; MUMPS_INT mumps_err_max_len; MUMPS_INT err_flag; #if ! ( defined(MUMPS_WIN32) || defined(WITHOUT_PTHREAD) ) pthread_mutex_t err_mutex; #endif /* ! ( MUMPS_WIN32 || WITHOUT_PTHREAD ) */ /* Functions */ /* Keeps a C pointer to store error description string that will be displayed by the Fortran layers. * dim contains the size of the Fortran character array to store the description. */ void MUMPS_CALL MUMPS_LOW_LEVEL_INIT_ERR_STR(MUMPS_INT *dim, char* err_str, mumps_ftnlen l1){ mumps_err = err_str; dim_mumps_err = (MUMPS_INT *) dim; mumps_err_max_len = (MUMPS_INT) *dim; err_flag = 0; return; } #if ! defined(MUMPS_WIN32) && ! defined(WITHOUT_PTHREAD) MUMPS_INLINE MUMPS_INT mumps_io_protect_err() { if(mumps_io_flag_async==IO_ASYNC_TH){ pthread_mutex_lock(&err_mutex); } return 0; } MUMPS_INLINE MUMPS_INT mumps_io_unprotect_err() { if(mumps_io_flag_async==IO_ASYNC_TH){ pthread_mutex_unlock(&err_mutex); } return 0; } MUMPS_INT mumps_io_init_err_lock() { pthread_mutex_init(&err_mutex,NULL); return 0; } MUMPS_INT mumps_io_destroy_err_lock() { pthread_mutex_destroy(&err_mutex); return 0; } MUMPS_INT mumps_check_error_th() { /* If err_flag != 0, then error_str is set */ return err_flag; } #endif /* MUMPS_WIN32 && WITHOUT_PTHREAD */ MUMPS_INT mumps_io_error(MUMPS_INT mumps_errno, const char* desc) { MUMPS_INT len; #if ! defined( MUMPS_WIN32 ) && ! defined( WITHOUT_PTHREAD ) mumps_io_protect_err(); #endif if(err_flag == 0){ strncpy(mumps_err, desc, mumps_err_max_len); /* mumps_err is a FORTRAN string, we do not care about adding a final 0 */ len = (MUMPS_INT) strlen(desc); *dim_mumps_err = (len <= mumps_err_max_len ) ? len : mumps_err_max_len; err_flag = mumps_errno; } #if ! defined( MUMPS_WIN32 ) && ! defined( WITHOUT_PTHREAD ) mumps_io_unprotect_err(); #endif return mumps_errno; } MUMPS_INT mumps_io_sys_error(MUMPS_INT mumps_errno, const char* desc) { MUMPS_INT len = 2; /* length of ": " */ const char* _desc; char* _err; #if defined( MUMPS_WIN32 ) MUMPS_INT _err_len; #endif #if ! defined( MUMPS_WIN32 ) && ! defined( WITHOUT_PTHREAD ) mumps_io_protect_err(); #endif if(err_flag==0){ if(desc == NULL) { _desc = ""; } else { len += (MUMPS_INT) strlen(desc); _desc = desc; } #if ! defined( MUMPS_WIN32 ) _err = strerror(errno); len += (MUMPS_INT) strlen(_err); snprintf(mumps_err, mumps_err_max_len, "%s: %s", _desc, _err); /* mumps_err is a FORTRAN string, we do not care about adding a final 0 */ #else /* This a VERY UGLY workaround for snprintf: this function has been * integrated quite lately into the ANSI stdio: some windows compilers are * not up-to-date yet. */ if( len >= mumps_err_max_len - 1 ) { /* then do not print sys error msg at all */ len -= 2; len = (len >= mumps_err_max_len ) ? mumps_err_max_len - 1 : len; _err = strdup( _desc ); _err[len] = '\0'; sprintf(mumps_err, "%s", _err); } else { _err = strdup(strerror(errno)); _err_len = (MUMPS_INT) strlen(_err); /* We will use sprintf, so make space for the final '\0' ! */ if((len + _err_len) >= mumps_err_max_len) { /* truncate _err, not to overtake mumps_err_max_len at the end. */ _err[mumps_err_max_len - len - 1] = '\0'; len = mumps_err_max_len - 1; } else { len += _err_len; } sprintf(mumps_err, "%s: %s", _desc, _err); } free(_err); #endif *dim_mumps_err = (len <= mumps_err_max_len ) ? len : mumps_err_max_len; err_flag = mumps_errno; } #if ! defined( MUMPS_WIN32 ) && ! defined( WITHOUT_PTHREAD ) mumps_io_unprotect_err(); #endif return mumps_errno; } MUMPS_5.8.1/src/mumps_thread_affinity.h0000664000175000017500000000132615042446422017764 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_THREAD_AFFINITY_H #define MUMPS_THREAD_AFFINITY_H #include "mumps_common.h" #define MUMPS_THREAD_AFFINITY_RETURN \ F_SYMBOL(thread_affinity_return,THREAD_AFFINITY_RETURN) void MUMPS_CALL MUMPS_THREAD_AFFINITY_RETURN(); #endif /* MUMPS_THREAD_AFFINITY_H */ MUMPS_5.8.1/src/dfac_scalings_simScaleAbs.F0000664000175000017500000017536015042446441020402 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SIMSCALEABS(IRN_loc, JCN_loc, A_loc, NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, & NOMP_MAX, SYM, NB1, NB2, NB3, EPS, & ONENORMERR,INFNORMERR) C---------------------------------------------------------------------- C IF SYM=0 CALLs unsymmetric variant DMUMPS_SIMSCALEABSUNS. C IF SYM=2 CALLS symmetric variant where only one of a_ij and a_ji C is stored. DMUMPS_SIMSCALEABSSYM C--------------------------------------------------------------------- C For details, see the two subroutines below C DMUMPS_SIMSCALEABSUNS and DMUMPS_SIMSCALEABSSYM C --------------------------------------------------------------------- C !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) NZ_loc INTEGER(8) :: IWRKSZ INTEGER(8) :: ISZWRKRC, LWRKR_TH, LWRKC_TH INTEGER :: NOMP_MAX INTEGER M, N, OP INTEGER NUMPROCS, MYID, COMM INTEGER(8) :: INTSZ, RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) DOUBLE PRECISION A_loc(NZ_loc) INTEGER RPARTVEC(M) INTEGER RSNDRCVSZ(2*NUMPROCS) INTEGER CPARTVEC(N) INTEGER CSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER(8) :: REGISTRE(12) DOUBLE PRECISION ROWSCA(M) DOUBLE PRECISION COLSCA(N) DOUBLE PRECISION WRKRC(ISZWRKRC) DOUBLE PRECISION WRKR_TH(LWRKR_TH,max(NOMP_MAX,1)) DOUBLE PRECISION WRKC_TH(LWRKC_TH,max(NOMP_MAX,1)) DOUBLE PRECISION ONENORMERR,INFNORMERR C LOCALS C FOR the scaling phase INTEGER SYM, NB1, NB2, NB3 DOUBLE PRECISION EPS C EXTERNALS EXTERNAL DMUMPS_SIMSCALEABSUNS,DMUMPS_SIMSCALEABSSYM, & DMUMPS_INITREAL C MUST HAVE IT INTEGER I INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER :: NOMP !$ INTEGER :: CHUNK !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = omp_get_max_threads() !$ CHUNK= max(K361/2, (N+NOMP-1) / NOMP ) !$ ENDIF IF(SYM.EQ.0) THEN CALL DMUMPS_SIMSCALEABSUNS(IRN_loc, JCN_loc, A_loc, & NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, NOMP_MAX, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) ELSE CALL DMUMPS_SIMSCALEABSSYM(IRN_loc, JCN_loc, A_loc, & NZ_loc, & N, NUMPROCS, MYID, COMM, & RPARTVEC, & RSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, NOMP_MAX, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) IF (OP.EQ.2) THEN IF (NOMP_MAX.LE.0) THEN DO I=1,N COLSCA(I) = ROWSCA(I) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1,N COLSCA(I) = ROWSCA(I) ENDDO ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SIMSCALEABS SUBROUTINE DMUMPS_SIMSCALEABSUNS(IRN_loc, JCN_loc, A_loc, NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, & WRKC_TH, LWRKC_TH, NOMP_MAX, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) C---------------------------------------------------------------------- C Input parameters: C M, N: size of matrix (in general M=N, but the algorithm C works for rectangular matrices as well (norms other than C inf-norm are not possible mathematically in this case). C NUMPROCS, MYID, COMM: guess what are those C RPARTVEC: row partvec to be filled when OP=1 C CPARTVEC: col partvec to be filled when OP=1 C RSNDRCVSZ: send recv sizes for row operations. C to be filled when OP=1 C CSNDRCVSZ: send recv sizes for col operations. C to be filled when OP=1 C REGISTRE: to store some pointers (size etc) C IWRK: working space. when OP=1 IWRKSZ.GE.4*MAXMN C when OP=2 INTSZ portion is used. Thus, IWRKSZ>INTSZ C when OP=2 C IWRKSZ: size C INTSZ: to be computed when OP=1, necessary integer space to run C scaling algo when OP=2 C RESZ: to be computed when OP=1, necessary real space to run C scaling algo when OP=2 C OP: C =1 estimation of memory and construction of partvecs C writes into RPARTVEC,CPARTVEC,RSNDRCVSZ,CSNDRCVSZ,REGISTRE C does not access WRKRC, uses IWRK as workspace C computes INTSZ and RESZ. C =2 Compute scalings C restores pointers from REGISTRE, C stores communication structure in IWRK (from the start). C C ROWSCA: space for row scaling factor; has size M C COLSCA: space for col scaling factor; has size N C WRKRC: real working space. when OP=1, is not accessed. Thus, it C can be declared to be of size 1 at OP=1 call. C ISZWRKRC: size C SYM: is matrix symmetric C NB1, NB2, NB3: algo runs C NB1 iters of inf-norm (default 1/1), C NB2 iters of 1-norm (default 3/10), C NB3 iters of inf-norm (default 3/10). C in succession. C EPS: tolerance for concergence. C IF EPS < 0.R0 then does not test convergence. C If convergence occured during the first set of inf-norm C iterations, we start performing one-norm iterations. C If convergence occured during the one-norm iterations, C we start performing the second set of inf-norm iterations. C If convergence occured during the second set of inf-norm, C we prepare to return. C ONENORMERR : error in one norm scaling (associated with the scaling C arrays of the previous iterations), C INFNORMERR : error in inf norm scaling (associated with the scaling C arrays of the previous iterations). C--------------------------------------------------------------------- C On input: C OP=1==>Requirements C IWRKSZ.GE.4*MAXMN C RPARTVEC of size M C CPARTVEC of size N C RSNDRCVSZ of size 2*NUMPROCS C CSNDRCVSZ of size 2*NUMPROCS C REGISTRE of size 12 C C OP=2==>Requirements C INTSZ .GE. REGISTRE(11) C RESZ .GE. REGISTRE(12) C--------------------------------------------------------------------- C On output: C ROWSCA and COLSCA C at processor 0 of COMM: complete factors. C at other processors : only the ROWSCA(i) or COLSCA(j) C for which there is a nonzero a_i* or a_*j are useful. C ONENORMERR : error in one norm scaling C = -1.0 if iter2=0. C INFNORMERR : error in inf norm scaling C = inf norm error at iter3 if iter3 > 0 C = inf norm error at iter1 if iter1 > 0, iter3=0 C = -1.0 if iter1=iter3=0 C --------------------------------------------------------------------- C References: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C C The parallelization approach is discussed in C [3] P. R. Amestoy, I. S. Duff, D. Ruiz, and B. Ucar, C "A parallel matrix scaling algorithm". C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, Jan'08. C and was supported by ANR-SOLSTICE project (ANR-06-CIS6-010) C --------------------------------------------------------------------- !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER(8) :: IWRKSZ, INTSZ INTEGER(8) :: ISZWRKRC, LWRKR_TH, LWRKC_TH INTEGER :: M, N, OP INTEGER :: NUMPROCS, MYID, COMM, NOMP_MAX INTEGER(8) :: RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) DOUBLE PRECISION A_loc(NZ_loc) INTEGER RPARTVEC(M) INTEGER CPARTVEC(N) INTEGER RSNDRCVSZ(2*NUMPROCS) INTEGER CSNDRCVSZ(2*NUMPROCS) INTEGER(8) :: REGISTRE(12) INTEGER IWRK(IWRKSZ) DOUBLE PRECISION ROWSCA(M) DOUBLE PRECISION COLSCA(N) DOUBLE PRECISION WRKRC(ISZWRKRC) DOUBLE PRECISION WRKR_TH(LWRKR_TH,max(NOMP_MAX,1)) DOUBLE PRECISION WRKC_TH(LWRKC_TH,max(NOMP_MAX,1)) DOUBLE PRECISION ONENORMERR,INFNORMERR C LOCALS INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER ICSNDRCVNUM, OCSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER ICSNDRCVVOL, OCSNDRCVVOL INTEGER INUMMYR, INUMMYC C IMPORTANT POINTERS INTEGER(8) :: IMYRPTR,IMYCPTR INTEGER(8) :: IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER(8) :: ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER(8) :: ICNGHBPRCS, ICSNDRCVIA,ICSNDRCVJA INTEGER(8) :: OCNGHBPRCS, OCSNDRCVIA,OCSNDRCVJA INTEGER(8) :: ISTATUS, REQUESTS, TMPWORK INTEGER(8) :: ITDRPTR, ITDCPTR, ISRRPTR INTEGER(8) :: OSRRPTR, ISRCPTR, OSRCPTR C FOR the scaling phase INTEGER NB1, NB2, NB3 DOUBLE PRECISION EPS C Iteration vars INTEGER ITER, IR, IC INTEGER(8) :: NZIND DOUBLE PRECISION ELM C COMM TAGS.... INTEGER TAG_COMM_COL PARAMETER(TAG_COMM_COL=100) INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) C FUNCTIONS EXTERNAL DMUMPS_CREATEPARTVEC, & DMUMPS_NUMVOLSNDRCV, & DMUMPS_SETUPCOMMS, & DMUMPS_FILLMYROWCOLINDICES, & DMUMPS_INITREAL, & DMUMPS_INITREALLST, & DMUMPS_DOCOMMINF, & DMUMPS_DOCOMM1N DOUBLE PRECISION DMUMPS_ERRSCALOC DOUBLE PRECISION DMUMPS_ERRSCA1 INTRINSIC abs DOUBLE PRECISION RONE, RZERO PARAMETER(RONE=1.0D0,RZERO=0.0D0) C TMP VARS INTEGER(8) :: RESZR, RESZC INTEGER(8) :: INTSZR, INTSZC INTEGER MAXMN INTEGER I, IERROR, IOMP DOUBLE PRECISION ONEERRROW, ONEERRCOL, ONEERRL, ONEERRG DOUBLE PRECISION INFERRROW, INFERRCOL, INFERRL, INFERRG LOGICAL OORANGEIND INTEGER, PARAMETER :: K361 = 2048 !$ INTEGER :: NOMP !$ INTEGER :: CHUNK, CHUNK_NZ !$ ! Too large => pb with cache L3 ? !$ ! INTEGER(8) :: CHUNK8 !$ IF (NOMP_MAX.GT.0) THEN !$ NOMP = omp_get_max_threads() !$ CHUNK = max(K361/2, (N+NOMP-1) / NOMP ) !$ ! CHUNK8= (NZ_loc+int(NOMP-1,8) / int(NOMP,8) ) ) !$ CHUNK_NZ = max(K361/2, (N+NOMP_MAX-1) / NOMP_MAX ) !$ ENDIF C OORANGEIND = .FALSE. INFERRG = -RONE ONEERRG = -RONE MAXMN = M IF(MAXMN < N) MAXMN = N C Create row partvec and col partvec IF(OP == 1) THEN IF(NUMPROCS > 1) THEN C Check done outside C IF(IWRKSZ.LT.4*MAXMN) THEN ERROR.... CALL DMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, M, N, & IWRK, IWRKSZ, INUMMYR, NOMP_MAX) CALL DMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & JCN_loc, IRN_loc, NZ_loc, & CPARTVEC, N, M, & IWRK, IWRKSZ, INUMMYC, NOMP_MAX) C Compute sndrcv sizes, store them for later use CALL DMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, M, RPARTVEC, & NZ_loc, IRN_loc, N, JCN_loc, & IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM,ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) CALL DMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, N, CPARTVEC, & NZ_loc, JCN_loc, M, IRN_loc, & ICSNDRCVNUM,ICSNDRCVVOL, & OCSNDRCVNUM,OCSNDRCVVOL, & IWRK,IWRKSZ, & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), COMM) INTSZR = int(IRSNDRCVNUM,8) + int(ORSNDRCVNUM,8) + & int(IRSNDRCVVOL,8) + int(ORSNDRCVVOL,8) + & 2_8*int(NUMPROCS+1,8) + int(INUMMYR,8) INTSZC = int(ICSNDRCVNUM,8) + int(OCSNDRCVNUM,8) + & int(ICSNDRCVVOL,8) + int(OCSNDRCVVOL,8) + & 2_8*int(NUMPROCS+1,8) + int(INUMMYC,8) INTSZ = INTSZR + INTSZC + int(MAXMN,8) + & int(MPI_STATUS_SIZE +1,8) * int(NUMPROCS,8) ELSE C NUMPROCS IS 1 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 ICSNDRCVNUM = 0 OCSNDRCVNUM = 0 ICSNDRCVVOL = 0 OCSNDRCVVOL = 0 INUMMYC = 0 INTSZ = 0_8 ENDIF C CALCULATE NECESSARY DOUBLE PRECISION SPACE RESZR = int(M,8) + int(IRSNDRCVVOL,8) + int(ORSNDRCVVOL,8) RESZC = int(N,8) + int(ICSNDRCVVOL,8) + int(OCSNDRCVVOL,8) RESZ = RESZR + RESZC C CALCULATE NECESSARY INT SPACE C The last maxmn is tmpwork for setup comm and fillmyrowcol REGISTRE(1) = int(IRSNDRCVNUM,8) REGISTRE(2) = int(ORSNDRCVNUM,8) REGISTRE(3) = int(IRSNDRCVVOL,8) REGISTRE(4) = int(ORSNDRCVVOL,8) REGISTRE(5) = int(ICSNDRCVNUM,8) REGISTRE(6) = int(OCSNDRCVNUM,8) REGISTRE(7) = int(ICSNDRCVVOL,8) REGISTRE(8) = int(OCSNDRCVVOL,8) REGISTRE(9) = int(INUMMYR,8) REGISTRE(10) = int(INUMMYC,8) REGISTRE(11) = INTSZ REGISTRE(12) = RESZ ELSE C else of op=1. That is op=2 now. C restore the numbers IRSNDRCVNUM = int(REGISTRE(1)) ORSNDRCVNUM = int(REGISTRE(2)) IRSNDRCVVOL = int(REGISTRE(3)) ORSNDRCVVOL = int(REGISTRE(4)) ICSNDRCVNUM = int(REGISTRE(5)) OCSNDRCVNUM = int(REGISTRE(6)) ICSNDRCVVOL = int(REGISTRE(7)) OCSNDRCVVOL = int(REGISTRE(8)) INUMMYR = int(REGISTRE(9)) INUMMYC = int(REGISTRE(10)) IF(NUMPROCS > 1) THEN C Check done outsize C IF(INTSZ < REGISTRE(11)) THEN ERROR C IF(RESZ < REGISTRE(12)) THEN ERROR C Fill up myrows and my colsX CALL DMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, CPARTVEC, M, N, & IWRK(1_8), INUMMYR, & IWRK(1_8+int(INUMMYR,8)), INUMMYC, & IWRK(1_8+int(INUMMYR,8)+int(INUMMYC,8)), & IWRKSZ-int(INUMMYR,8)-int(INUMMYC,8), NOMP_MAX ) IMYRPTR = 1_8 IMYCPTR = IMYRPTR + int(INUMMYR,8) C Set up comm and run. C set pointers in iwrk (4 parts) C C ROWS [---------------------------------------------] IRNGHBPRCS = IMYCPTR + int(INUMMYC ,8) IRSNDRCVIA = IRNGHBPRCS + int(IRSNDRCVNUM,8) IRSNDRCVJA = IRSNDRCVIA + int(NUMPROCS+1 ,8) ORNGHBPRCS = IRSNDRCVJA + int(IRSNDRCVVOL,8) ORSNDRCVIA = ORNGHBPRCS + int(ORSNDRCVNUM,8) ORSNDRCVJA = ORSNDRCVIA + int(NUMPROCS+1 ,8) C COLS [---------------------------------------------] ICNGHBPRCS = ORSNDRCVJA + int(ORSNDRCVVOL,8) ICSNDRCVIA = ICNGHBPRCS + int(ICSNDRCVNUM,8) ICSNDRCVJA = ICSNDRCVIA + int(NUMPROCS+1 ,8) OCNGHBPRCS = ICSNDRCVJA + int(ICSNDRCVVOL,8) OCSNDRCVIA = OCNGHBPRCS + int(OCSNDRCVNUM,8) OCSNDRCVJA = OCSNDRCVIA + int(NUMPROCS+1 ,8) C C MPI [-----------------] REQUESTS = OCSNDRCVJA + int(OCSNDRCVVOL,8) ISTATUS = REQUESTS + int(NUMPROCS,8) C C TMPWRK [-----------------] TMPWORK = ISTATUS + int(MPI_STATUS_SIZE,8)*int(NUMPROCS,8) CALL DMUMPS_SETUPCOMMS(MYID, NUMPROCS, M, RPARTVEC, & NZ_loc, IRN_loc,N, JCN_loc, & IRSNDRCVNUM, IRSNDRCVVOL, & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_ROW, COMM) CALL DMUMPS_SETUPCOMMS(MYID, NUMPROCS, N, CPARTVEC, & NZ_loc, JCN_loc, M, IRN_loc, & ICSNDRCVNUM, ICSNDRCVVOL, & IWRK(ICNGHBPRCS), & IWRK(ICSNDRCVIA), & IWRK(ICSNDRCVJA), & OCSNDRCVNUM, OCSNDRCVVOL, & IWRK(OCNGHBPRCS),IWRK(OCSNDRCVIA),IWRK(OCSNDRCVJA), & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_COL, COMM) CALL DMUMPS_INITREAL(ROWSCA, M, RZERO, NOMP_MAX) CALL DMUMPS_INITREAL(COLSCA, N, RZERO, NOMP_MAX) CALL DMUMPS_INITREALLST(ROWSCA, M, & IWRK(IMYRPTR),INUMMYR, RONE, NOMP_MAX) CALL DMUMPS_INITREALLST(COLSCA, N, & IWRK(IMYCPTR),INUMMYC, RONE, NOMP_MAX) ELSE CALL DMUMPS_INITREAL(ROWSCA, M, RONE, NOMP_MAX) CALL DMUMPS_INITREAL(COLSCA, N, RONE, NOMP_MAX) ENDIF ITDRPTR = 1_8 ITDCPTR = ITDRPTR + int(M,8) C ISRRPTR = ITDCPTR + int(N,8) OSRRPTR = ISRRPTR + int(IRSNDRCVVOL,8) C ISRCPTR = OSRRPTR + int(ORSNDRCVVOL,8) OSRCPTR = ISRCPTR + int(ICSNDRCVVOL,8) C To avoid bound check errors... IF(NUMPROCS == 1)THEN OSRCPTR = OSRCPTR - 1_8 ISRCPTR = ISRCPTR - 1_8 OSRRPTR = OSRRPTR - 1_8 ISRRPTR = ISRRPTR - 1_8 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1_8 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1_8 IF(ICSNDRCVVOL == 0) ISRCPTR = ISRCPTR - 1_8 IF(OCSNDRCVVOL == 0) OSRCPTR = OSRCPTR - 1_8 ENDIF ITER = 1 DO WHILE (ITER.LE.NB1+NB2+NB3) C{ C ------------------------- C CLEAR temporary Dr and Dc C ------------------------- IF (NOMP_MAX.GT.1 .AND. & (ITER.GT.NB1 .AND.ITER.LE.NB1+NB2) & ) THEN C{ !$OMP PARALLEL !$OMP& PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 IF(NUMPROCS > 1) THEN CALL DMUMPS_ZEROOUT(WRKR_TH(1,IOMP),N, & IWRK(IMYRPTR),INUMMYR, 0) CALL DMUMPS_ZEROOUT(WRKC_TH(1,IOMP),N, & IWRK(IMYCPTR),INUMMYC, 0) ELSE CALL DMUMPS_INITREAL(WRKR_TH(1,IOMP),N, RZERO, & 0) CALL DMUMPS_INITREAL(WRKC_TH(1,IOMP),N, RZERO, & 0) ENDIF !$OMP END PARALLEL C} ELSE C{ IF(NUMPROCS > 1) THEN CALL DMUMPS_ZEROOUT(WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) CALL DMUMPS_ZEROOUT(WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) ELSE CALL DMUMPS_INITREAL(WRKRC(ITDRPTR),M, RZERO, & NOMP_MAX) CALL DMUMPS_INITREAL(WRKRC(ITDCPTR),N, RZERO, & NOMP_MAX) ENDIF C} ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN C ------------------ C INF-NORM ITERATION C ------------------ IF (NOMP_MAX.LE.0) THEN IF((ITER.EQ.1).OR.(OORANGEIND)) THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) IF(WRKRC(IR) int(K361,8) .AND. NOMP .GT. 1) !$OMP& REDUCTION(.OR.:OORANGEIND) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) !$OMP ATOMIC UPDATE WRKRC(IR)= max (ELM, WRKRC(IR)) !$OMP END ATOMIC C IF(WRKRC(ITDRPTR-1_8+int(IR,8)) int4 !$OMP ATOMIC UPDATE WRKRC(ITDCPTR-1_8+int(IC,8)) = & max (ELM,WRKRC(ITDCPTR-1_8+int(IC,8))) !$OMP END ATOMIC ELSE OORANGEIND = .TRUE. ENDIF ENDDO !$OMP END PARALLEL DO ELSEIF(.NOT.OORANGEIND) THEN !$OMP PARALLEL DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) DO NZIND=1,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) C IF(WRKRC(ITDRPTR-1_8+int(IR,8)) 1) THEN CALL DMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, & ICSNDRCVNUM,IWRK(ICNGHBPRCS), & ICSNDRCVVOL,IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), & WRKRC(ISRCPTR), & OCSNDRCVNUM,IWRK(OCNGHBPRCS), & OCSNDRCVVOL,IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), & WRKRC( OSRCPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) C CALL DMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, & IRSNDRCVNUM,IWRK(IRNGHBPRCS), & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM,IWRK(ORNGHBPRCS), & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = DMUMPS_ERRSCALOC(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) C find error for the cols INFERRCOL = DMUMPS_ERRSCALOC(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) C get max of those two errors INFERRL = INFERRCOL IF(INFERRROW > INFERRL ) THEN INFERRL = INFERRROW ENDIF C CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL DMUMPS_UPDATESCALE(COLSCA, & WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) CALL DMUMPS_UPDATESCALE(ROWSCA, & WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE C SINGLE PROCESSOR CASE: INF-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = DMUMPS_ERRSCA1(ROWSCA, & WRKRC(ITDRPTR), M, NOMP_MAX) C find error for the cols INFERRCOL = DMUMPS_ERRSCA1(COLSCA, & WRKRC(ITDCPTR), N, NOMP_MAX) C get max of those two errors INFERRL = INFERRCOL IF(INFERRROW > INFERRL) THEN INFERRL = INFERRROW ENDIF INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL DMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N, & NOMP_MAX) CALL DMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M, & NOMP_MAX) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE C ---------------------------------------- C WE HAVE ITER.GT.NB1 AND ITER.LE.NB1+NB2. C ONE-NORM ITERATION C ---------------------------------------- IF (NOMP_MAX.LE.1) THEN IF((ITER .EQ.1).OR.(OORANGEIND))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) C WRKRC(ITDRPTR-1_8+int(IR,8)) = C & WRKRC(ITDRPTR-1_8+int(IR,8)) + ELM WRKRC(IR) = WRKRC(IR) + ELM WRKRC(ITDCPTR-1_8+int(IC,8)) = & WRKRC(ITDCPTR-1_8+int(IC,8)) + ELM ELSE OORANGEIND = .TRUE. ENDIF ENDDO ELSEIF(.NOT.OORANGEIND) THEN DO NZIND=1,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) C WRKRC(ITDRPTR-1_8+int(IR,8)) = C & WRKRC(ITDRPTR-1_8+int(IR,8)) + ELM WRKRC(IR) = WRKRC(IR) + ELM WRKRC(ITDCPTR-1_8+int(IC,8)) = & WRKRC(ITDCPTR-1_8+int(IC,8)) + ELM ENDDO ENDIF C} ELSE ! NOMP_MAX>1 IF((ITER .EQ.1).OR.(OORANGEIND))THEN !$OMP PARALLEL PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 !$OMP DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) !$OMP& REDUCTION(.OR.:OORANGEIND) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) WRKR_TH(IR,IOMP) = WRKR_TH(IR,IOMP) + ELM IF (IR.NE.IC) & WRKC_TH(IC,IOMP) = WRKC_TH(IC,IOMP) + ELM ELSE OORANGEIND = .TRUE. ENDIF ENDDO !$OMP END DO !$OMP END PARALLEL ELSEIF(.NOT.OORANGEIND) THEN !$OMP PARALLEL PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 !$OMP DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) DO NZIND=1,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) WRKR_TH(IR,IOMP) = WRKR_TH(IR,IOMP) + ELM IF (IR.NE.IC) & WRKC_TH(IC,IOMP) = WRKC_TH(IC,IOMP) + ELM ENDDO !$OMP END DO !$OMP END PARALLEL ENDIF C C For all i on MYID: C Build WRKRC(i) = Sum (WRKR_TH(i,IOMP) C IOMP \in [1:NOMP_MAX] IF(NUMPROCS > 1) THEN CALL DMUMPS_REDUCE_WRK_MPI (WRKRC, N, WRKR_TH, & NOMP_MAX, & IWRK(IMYRPTR),INUMMYR) CALL DMUMPS_REDUCE_WRK_MPI (WRKRC(ITDCPTR), & N, WRKC_TH, NOMP_MAX, & IWRK(IMYCPTR),INUMMYC) ELSE CALL DMUMPS_REDUCE_WRK (WRKRC, N, WRKR_TH, NOMP_MAX) CALL DMUMPS_REDUCE_WRK (WRKRC(ITDCPTR), & N, WRKC_TH, NOMP_MAX) ENDIF C} ENDIF IF(NUMPROCS > 1) THEN CALL DMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, & ICSNDRCVNUM, IWRK(ICNGHBPRCS), & ICSNDRCVVOL, IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), & WRKRC(ISRCPTR), & OCSNDRCVNUM, IWRK(OCNGHBPRCS), & OCSNDRCVVOL, IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), & WRKRC( OSRCPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) C CALL DMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, & IRSNDRCVNUM, IWRK(IRNGHBPRCS), & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM, IWRK(ORNGHBPRCS), & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = DMUMPS_ERRSCALOC(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) C find error for the cols ONEERRCOL = DMUMPS_ERRSCALOC(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) C get max of those two errors ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL ) THEN ONEERRL = ONEERRROW ENDIF C CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL DMUMPS_UPDATESCALE(COLSCA, & WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) CALL DMUMPS_UPDATESCALE(ROWSCA, & WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE C SINGLE-PROCESSOR CASE: ONE-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = DMUMPS_ERRSCA1(ROWSCA, & WRKRC(ITDRPTR), M, NOMP_MAX) C find error for the cols ONEERRCOL = DMUMPS_ERRSCA1(COLSCA, & WRKRC(ITDCPTR), N, NOMP_MAX) C get max of those two errors ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL) THEN ONEERRL = ONEERRROW ENDIF ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL DMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N, & NOMP_MAX) CALL DMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M, & NOMP_MAX) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL DMUMPS_UPDATESCALE(COLSCA, WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC, NOMP_MAX) CALL DMUMPS_UPDATESCALE(ROWSCA, WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) C ELSE C SINGLE PROCESSOR CASE: Conv check and update of sca arrays CALL DMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N, & NOMP_MAX) CALL DMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M, & NOMP_MAX) ENDIF ITER = ITER + 1 C} ENDDO ONENORMERR = ONEERRG INFNORMERR = INFERRG IF(NUMPROCS > 1) THEN C{ CALL MPI_REDUCE(ROWSCA, WRKRC(1), M, MPI_DOUBLE_PRECISION, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN DO I=1, M ROWSCA(I) = WRKRC(I) ENDDO ENDIF C Scaling factors are printed C WRITE (6,*) MYID, 'ROWSCA=',ROWSCA C WRITE (6,*) MYID, 'COLSCA=',COLSCA C CALL FLUSH(6) c REduce the whole scaling factors to processor 0 of COMM CALL MPI_REDUCE(COLSCA, WRKRC(1_8+int(M,8)), N, & MPI_DOUBLE_PRECISION, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN C{ IF (NOMP_MAX.LE.0) THEN DO I=1, N COLSCA(I) = WRKRC(int(I,8)+int(M,8)) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1, N COLSCA(I) = WRKRC(int(I,8)+int(M,8)) ENDDO !$OMP END PARALLEL DO ENDIF C} ENDIF C} ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SIMSCALEABSUNS C C C SEPARATOR: Another function begins C C SUBROUTINE DMUMPS_SIMSCALEABSSYM(IRN_loc, JCN_loc, A_loc, NZ_loc, & N, NUMPROCS, MYID, COMM, & PARTVEC, & RSNDRCVSZ, & REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & SCA, WRKRC, ISZWRKRC, & WRKR_TH, LWRKR_TH, NOMP_MAX, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) C---------------------------------------------------------------------- C Input parameters: C N: size of matrix (sym matrix, square). C NUMPROCS, MYID, COMM: guess what are those C PARTVEC: row/col partvec to be filled when OP=1 C RSNDRCVSZ:send recv sizes for row/col operations. C to be filled when OP=1 C REGISTRE: to store some pointers (size etc). Its size is 12, C but we do not use all in this routine. C IWRK: working space. when OP=1 IWRKSZ.GE.2*MAXMN C when OP=2 INTSZ portion is used. Donc, IWRKSZ>INTSZ C when OP=2 C IWRKSZ: size C INTSZ: to be computed when OP=1, necessary integer space to run C scaling algo when OP=2 C RESZ: to be computed when OP=1, necessary real space to run C scaling algo when OP=2 C OP: C =1 estimation of memory and construction of partvecs C writes into PARTVEC,RSNDRCVSZ,REGISTRE C does not access WRKRC, uses IWRK as workspace C computes INTSZ and RESZ. C =2 Compute scalings C restores pointers from REGISTRE, C stores communication structure in IWRK (from the start). C C SCA: space for row/col scaling factor; has size M C WRKRC: real working space. when OP=1, is not accessed. Donc, it C can be declared to be of size 1 at OP=1 call. C ISZWRKRC: size C SYM: is matrix symmetric C NB1, NB2, NB3: algo runs C NB1 iters of inf-norm (default 1/1), C NB2 iters of 1-norm (default 3/10), C NB3 iters of inf-norm (default 3/10). C in succession. C EPS: tolerance for concergence. C IF EPS < 0.R0 then does not test convergence. C See comments for the uns case above. C ONENORMERR : error in one norm scaling (see comments for the C uns case above), C INFNORMERR : error in inf norm scaling (see comments for the C uns case above). C--------------------------------------------------------------------- C On input: C OP=1==>Requirements C IWRKSZ.GE.2*MAXMN XXXX compare with uns variant. C PARTVEC of size N C SNDRCVSZ of size 2*NUMPROCS C REGISTRE of size 12 C C OP=2==>Requirements C INTSZ .GE. REGISTRE(11) C RESZ .GE. REGISTRE(12) C--------------------------------------------------------------------- C On output: C SCA C at processor 0 of COMM: complete factors. C at other processors : only the SCA(i) and SCA(j) C for which there is a nonzero a_ij. C ONENORMERR : error in one norm scaling C = -1.0 if iter2=0. C INFNORMERR : error in inf norm scaling C = inf norm error at iter3 if iter3 > 0 C = inf norm error at iter1 if iter1 > 0, iter3=0 C = -1.0 if iter1=iter3=0 C --------------------------------------------------------------------- C NOTE: some variables are named in such a way that they correspond C to the row variables in unsym case. They are used for both C row and col communications. C --------------------------------------------------------------------- C References: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C C The parallelization approach is based on discussion in C [3] P. R. Amestoy, I. S. Duff, D. Ruiz, and B. Ucar, "A parallel C matrix scaling algorithm", accepted for publication, C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, Jan'08. C and was supported by ANR-SOLSTICE project (ANR-06-CIS6-010) C --------------------------------------------------------------------- !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER N, OP INTEGER(8) :: IWRKSZ, LWRKR_TH INTEGER NUMPROCS, MYID, COMM, NOMP_MAX INTEGER(8) :: 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(8) :: REGISTRE(12) DOUBLE PRECISION SCA(N) INTEGER(8) :: ISZWRKRC DOUBLE PRECISION WRKRC(ISZWRKRC), & WRKR_TH(LWRKR_TH, max(NOMP_MAX,1)) C LOCALS INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER INUMMYR C IMPORTANT POINTERS INTEGER(8) :: IMYRPTR,IMYCPTR INTEGER(8) :: IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER(8) :: ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER(8) :: ISTATUS, REQUESTS, TMPWORK INTEGER(8) :: ITDRPTR, ISRRPTR, OSRRPTR DOUBLE PRECISION ONENORMERR,INFNORMERR C FOR the scaling phase INTEGER NB1, NB2, NB3 DOUBLE PRECISION EPS C Iteration vars INTEGER ITER, IR, IC INTEGER(8) :: NZIND DOUBLE PRECISION ELM C COMM TAGS.... INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) C FUNCTIONS EXTERNAL DMUMPS_CREATEPARTVECSYM, & DMUMPS_NUMVOLSNDRCVSYM, & DMUMPS_SETUPCOMMSSYM, & DMUMPS_FILLMYROWCOLINDICESSYM, & DMUMPS_DOCOMMINF, & DMUMPS_DOCOMM1N, & DMUMPS_INITREAL, & DMUMPS_INITREALLST DOUBLE PRECISION DMUMPS_ERRSCALOC DOUBLE PRECISION DMUMPS_ERRSCA1 INTRINSIC abs DOUBLE PRECISION RONE, RZERO PARAMETER(RONE=1.0D0,RZERO=0.0D0) C TMP VARS INTEGER(8) :: INTSZR INTEGER MAXMN INTEGER I, IERROR DOUBLE PRECISION ONEERRL, ONEERRG DOUBLE PRECISION INFERRL, INFERRG LOGICAL OORANGEIND INTEGER, PARAMETER :: K361 = 2048 INTEGER :: IOMP !$ INTEGER :: NOMP !$ INTEGER :: CHUNK, CHUNK_NZ !$ ! Too large => pb with cache L3 ? !$ ! INTEGER(8) :: CHUNK8 !$ ! CHUNK8= max(int(K361/2,8), !$ ! & (NZ_loc+int(NOMP-1,8) / int(NOMP,8) ) ) !$ ! CHUNK8 = min(CHUNK8, huge(CHUNK)-1_8) !$ NOMP = omp_get_max_threads() !$ CHUNK= max(K361/2, (N+NOMP-1) / NOMP ) !$ IF (NOMP_MAX.GT.0) THEN !$ CHUNK_NZ = max(K361/2, (N+NOMP_MAX-1) / NOMP_MAX ) !$ ENDIF C OORANGEIND = .FALSE. INFERRG = -RONE ONEERRG = -RONE MAXMN = N IF(OP == 1) THEN C{ IF(NUMPROCS > 1) THEN C Check done outside C IF(IWRKSZ.LT.2*MAXMN) THEN ERROR.... CALL DMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK, IWRKSZ, INUMMYR ) C C Check done outside CALL DMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc, JCN_loc, IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) C C INTSZR = int(IRSNDRCVNUM,8) + int(ORSNDRCVNUM,8) + & int(IRSNDRCVVOL,8) + int(ORSNDRCVVOL,8) + & 2_8*int(NUMPROCS+1,8) + int(INUMMYR,8) INTSZ = INTSZR + int(N,8) + & int(MPI_STATUS_SIZE +1,8) * int(NUMPROCS,8) ELSE C NUMPROCS IS 1 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 INTSZ = 0_8 ENDIF C CALCULATE NECESSARY DOUBLE PRECISION SPACE RESZ = int(N,8) + int(IRSNDRCVVOL,8) + int(ORSNDRCVVOL,8) REGISTRE(1) = int(IRSNDRCVNUM,8) REGISTRE(2) = int(ORSNDRCVNUM,8) REGISTRE(3) = int(IRSNDRCVVOL,8) REGISTRE(4) = int(ORSNDRCVVOL,8) REGISTRE(9) = int(INUMMYR,8) REGISTRE(11) = INTSZ REGISTRE(12) = RESZ C} ELSE C{ C else of op=1. That is op=2 now. C restore the numbers IRSNDRCVNUM = int(REGISTRE(1)) ORSNDRCVNUM = int(REGISTRE(2)) IRSNDRCVVOL = int(REGISTRE(3)) ORSNDRCVVOL = int(REGISTRE(4)) INUMMYR = int(REGISTRE(9)) IF(NUMPROCS > 1) THEN C Check done outsize C IF(INTSZ < REGISTRE(11)) THEN ERROR C IF(RESZ < REGISTRE(12)) THEN ERROR C Fill up myrows and my colsX CALL DMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK(1), INUMMYR, & IWRK(1+INUMMYR), IWRKSZ-int(INUMMYR,8), NOMP_MAX) IMYRPTR = 1_8 IMYCPTR = IMYRPTR + int(INUMMYR,8) C Set up comm and run. C set pointers in iwrk (3 parts) C C ROWS [---------------------------------------------] IRNGHBPRCS = IMYCPTR IRSNDRCVIA = IRNGHBPRCS + int(IRSNDRCVNUM,8) IRSNDRCVJA = IRSNDRCVIA + int(NUMPROCS+1,8) ORNGHBPRCS = IRSNDRCVJA + int(IRSNDRCVVOL,8) ORSNDRCVIA = ORNGHBPRCS + int(ORSNDRCVNUM,8) ORSNDRCVJA = ORSNDRCVIA + int(NUMPROCS + 1,8) C MPI [-----------------] REQUESTS = ORSNDRCVJA + int(ORSNDRCVVOL,8) ISTATUS = REQUESTS + int(NUMPROCS,8) C TMPWRK [-----------------] TMPWORK = ISTATUS + int(MPI_STATUS_SIZE,8)*int(NUMPROCS,8) CALL DMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc, JCN_loc, & IRSNDRCVNUM, IRSNDRCVVOL, & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_ROW, COMM) CALL DMUMPS_INITREAL(SCA, N, RZERO, NOMP_MAX) CALL DMUMPS_INITREALLST(SCA, N, & IWRK(IMYRPTR),INUMMYR, RONE, NOMP_MAX) ELSE CALL DMUMPS_INITREAL(SCA, N, RONE, NOMP_MAX) ENDIF ITDRPTR = 1_8 ISRRPTR = ITDRPTR + int(N,8) OSRRPTR = ISRRPTR + int(IRSNDRCVVOL,8) C C To avoid bound check errors... IF(NUMPROCS == 1)THEN OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 ENDIF C computation starts ITER = 1 DO WHILE(ITER.LE.NB1+NB2+NB3) C{ C ------------------------- C CLEAR temporary Dr and Dc C ------------------------- IF (NOMP_MAX.GT.1 .AND. & (ITER.GT.NB1 .AND.ITER.LE.NB1+NB2) & ) THEN C if one norm iteration and multithreading activated C WRKR_TH need be initialized and C WRKRC will be set by reduction of WRKR_TH !$OMP PARALLEL !$OMP& PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 IF(NUMPROCS > 1) THEN CALL DMUMPS_ZEROOUT(WRKR_TH(1,IOMP),N, & IWRK(IMYRPTR),INUMMYR, 0) ELSE CALL DMUMPS_INITREAL(WRKR_TH(1,IOMP),N, RZERO, & 0) ENDIF !$OMP END PARALLEL ELSE IF(NUMPROCS > 1) THEN CFIXME Size N should be adjusted to effective size CALL DMUMPS_ZEROOUT(WRKRC(ITDRPTR),N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) ELSE CALL DMUMPS_INITREAL(WRKRC(ITDRPTR),N, RZERO, & NOMP_MAX) ENDIF ENDIF C IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN C ------------------ C{ INF-NORM ITERATION C ------------------ IF (NOMP_MAX.LE.0) THEN IF((ITER .EQ.1).OR.(OORANGEIND))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) IF (WRKRC(IR) int(K361,8) .AND. NOMP .GT. 1) !$OMP& REDUCTION(.OR.:OORANGEIND) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) !$OMP ATOMIC UPDATE WRKRC(IR)= max (ELM, WRKRC(IR)) !$OMP END ATOMIC C IF(WRKRC(ITDRPTR-1_8+int(IR,8)) int(K361,8) .AND. NOMP .GT. 1) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) !$OMP ATOMIC UPDATE WRKRC(IR)= max (ELM, WRKRC(IR)) !$OMP END ATOMIC C IF(WRKRC(ITDRPTR-1_8+int(IR,8)) 1) THEN C{ CALL DMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, & IRSNDRCVNUM,IWRK(IRNGHBPRCS), & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM,IWRK(ORNGHBPRCS), & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) CCCC FIXME #if defined(dev_version) IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = DMUMPS_ERRSCALOC(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL DMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF CCC #endif C} ELSE C{ SINGLE PROCESSOR CASE: INF-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = DMUMPS_ERRSCA1(SCA, & WRKRC(ITDRPTR), N, NOMP_MAX) INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL DMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N, & NOMP_MAX) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF C} ENDIF C} ELSE C ---------------------------------------- C{ WE HAVE ITER.GT.NB1 AND ITER.LE.NB1+NB2. C ONE-NORM ITERATION C ---------------------------------------- IF (NOMP_MAX.LE.1) THEN IF((ITER.EQ.1).OR.(OORANGEIND))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKRC(IR) = WRKRC(IR) + ELM IF(IR.NE.IC) THEN WRKRC(IC) = WRKRC(IC) + ELM ENDIF ELSE OORANGEIND = .TRUE. ENDIF ENDDO ELSEIF(.NOT.OORANGEIND)THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKRC(IR) = WRKRC(IR) + ELM IF(IR.NE.IC) THEN WRKRC(IC) = WRKRC(IC) + ELM ENDIF ENDDO ENDIF ELSE ! NOMP_MAX>1 IF((ITER.EQ.1).OR.(OORANGEIND))THEN !$OMP PARALLEL PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 !$OMP DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) !$OMP& REDUCTION(.OR.:OORANGEIND) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKR_TH(IR,IOMP) = WRKR_TH(IR,IOMP) + ELM IF(IR.NE.IC) THEN WRKR_TH(IC,IOMP) = WRKR_TH(IC,IOMP) + ELM ENDIF ELSE OORANGEIND = .TRUE. ENDIF ENDDO !$OMP END DO !$OMP END PARALLEL ELSEIF(.NOT.OORANGEIND)THEN !$OMP PARALLEL PRIVATE(IOMP) !$OMP& NUM_THREADS(NOMP_MAX) !$OMP& IF ( NZ_loc > int(K361,8) .AND. NOMP .GT. 1) IOMP = 1 !$ IOMP = OMP_GET_THREAD_NUM() + 1 !$OMP DO PRIVATE(NZIND,IR,IC,ELM) !$OMP& SCHEDULE(STATIC,CHUNK_NZ) DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKR_TH(IR,IOMP) = WRKR_TH(IR,IOMP) + ELM IF(IR.NE.IC) THEN WRKR_TH(IC,IOMP) = WRKR_TH(IC,IOMP) + ELM ENDIF ENDDO !$OMP END DO !$OMP END PARALLEL C} ENDIF C C For all i on MYID: C Build WRKRC(i) = Sum (WRKR_TH(i,IOMP) C IOMP \in [1:NOMP_MAX] IF(NUMPROCS > 1) THEN CALL DMUMPS_REDUCE_WRK_MPI (WRKRC, N, WRKR_TH, & NOMP_MAX, & IWRK(IMYRPTR),INUMMYR) ELSE CALL DMUMPS_REDUCE_WRK (WRKRC, N, WRKR_TH, NOMP_MAX) ENDIF ENDIF IF(NUMPROCS > 1) THEN C{ CALL DMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, & IRSNDRCVNUM, IWRK(IRNGHBPRCS), & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM, IWRK(ORNGHBPRCS), & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = DMUMPS_ERRSCALOC(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) C mpi allreduce. CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL DMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF C} ELSE C{ SINGLE-PROCESSOR CASE: ONE-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = DMUMPS_ERRSCA1(SCA, & WRKRC(ITDRPTR), N, NOMP_MAX) ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL DMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N, & NOMP_MAX) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF C} ENDIF IF(NUMPROCS > 1) THEN CALL DMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR, NOMP_MAX) ELSE CALL DMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N, & NOMP_MAX) ENDIF ITER = ITER + 1 C} ENDDO ONENORMERR = ONEERRG INFNORMERR = INFERRG IF(NUMPROCS > 1) THEN C{ CALL MPI_REDUCE(SCA, WRKRC(1), N, MPI_DOUBLE_PRECISION, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN IF (NOMP_MAX.LE.0) THEN DO I=1, N SCA(I) = WRKRC(I) ENDDO ELSE !$OMP PARALLEL DO PRIVATE(I) !$OMP& SCHEDULE(STATIC,CHUNK) !$OMP& IF ( N > K361 .AND. NOMP .GT. 1) DO I=1, N SCA(I) = WRKRC(I) ENDDO !$OMP END PARALLEL DO ENDIF ENDIF C} ENDIF C} ENDIF RETURN END SUBROUTINE DMUMPS_SIMSCALEABSSYM MUMPS_5.8.1/src/cfac_process_root2slave.F0000664000175000017500000003267115042446440020162 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, & TOT_CONT_TO_RECV, root, roota, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND) USE MUMPS_LOAD USE CMUMPS_OOC USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (MUMPS_ROOT_STRUC) :: root TYPE (CMUMPS_ROOT_STRUC) :: roota INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER TOT_ROOT_SIZE, TOT_CONT_TO_RECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER ND( KEEP(28) ) INTEGER IFLAG, IERROR, COMM, COMM_LOAD INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193)) INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194)) INTEGER, INTENT(IN) :: NINROWARR(KEEP(195)) INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196)) COMPLEX :: RHS_MUMPS(KEEP8(85)) INTEGER INTARR(KEEP8(27)) COMPLEX DBLARR(KEEP8(26)) INTEGER :: allocok COMPLEX, DIMENSION(:,:), POINTER :: TMP INTEGER NEW_LOCAL_M, NEW_LOCAL_N INTEGER OLD_LOCAL_M, OLD_LOCAL_N INTEGER I, J INTEGER LREQI, IROOT INTEGER(8) :: LREQA INTEGER POSHEAD, IPOS_SON,IERR LOGICAL MASTER_OF_ROOT, NO_OLD_ROOT COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INCLUDE 'mumps_headers.h' INTEGER MUMPS_NUMROC, MUMPS_PROCNODE EXTERNAL MUMPS_NUMROC, MUMPS_PROCNODE IROOT = KEEP( 38 ) root%TOT_ROOT_SIZE = TOT_ROOT_SIZE MASTER_OF_ROOT = ( MYID .EQ. & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), & KEEP(199) ) ) NEW_LOCAL_M = MUMPS_NUMROC( TOT_ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) NEW_LOCAL_M = max( 1, NEW_LOCAL_M ) NEW_LOCAL_N = MUMPS_NUMROC( TOT_ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) IF ( PTRIST(STEP( IROOT )).GT.0) THEN OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) ELSE OLD_LOCAL_N = 0 OLD_LOCAL_M = NEW_LOCAL_M ENDIF IF (PTRIST(STEP(IROOT)) .EQ.0) THEN NO_OLD_ROOT = .TRUE. ELSE NO_OLD_ROOT =.FALSE. ENDIF IF (KEEP(60) .NE. 0) THEN IF ( MASTER_OF_ROOT ) THEN LREQI=6+2*TOT_ROOT_SIZE+KEEP(IXSZ) LREQA=0_8 IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN CALL CMUMPS_COMPRE_NEW( N, KEEP, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ),COMP,DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA-LRLUS, IERROR) GOTO 700 END IF ENDIF IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB GOTO 700 ENDIF PTLUST(STEP(IROOT))= IWPOS IWPOS = IWPOS + LREQI POSHEAD = PTLUST( STEP(IROOT)) IW( POSHEAD + XXI )=LREQI CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR) ) CALL MUMPS_STOREI8( 0_8, IW(POSHEAD + XXD) ) IW( POSHEAD + XXS )=-9999 IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 IW( POSHEAD +KEEP(IXSZ)) = 0 IW( POSHEAD + 1 +KEEP(IXSZ)) = -1 IW( POSHEAD + 2 +KEEP(IXSZ)) = -1 IW( POSHEAD + 4 +KEEP(IXSZ)) = STEP(IROOT) IW( POSHEAD + 5 +KEEP(IXSZ)) = 0 IW( POSHEAD + 3 +KEEP(IXSZ)) = TOT_ROOT_SIZE ELSE PTLUST(STEP(IROOT)) = -4444 ENDIF PTRIST(STEP(IROOT)) = 0 PTRFAC(STEP(IROOT)) = -4445_8 IF (root%yes .and. NO_OLD_ROOT) THEN IF (NEW_LOCAL_N .GT. 0) THEN CALL CMUMPS_SET_TO_ZERO(roota%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC, & KEEP) IF (KEEP(55).EQ.0) THEN CALL CMUMPS_ASM_ARR_ROOT( N, root, roota, & IROOT, STEP(IROOT), & roota%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC, & root%SCHUR_NLOC, FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL CMUMPS_ASM_ELT_ROOT(N, root, roota, & roota%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC, & root%SCHUR_NLOC, LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF ENDIF ENDIF ELSE IF ( MASTER_OF_ROOT ) THEN LREQI = 6 + 2 * TOT_ROOT_SIZE+KEEP(IXSZ) ELSE LREQI = 6+KEEP(IXSZ) END IF LREQA = int(NEW_LOCAL_M, 8) * int(NEW_LOCAL_N, 8) CALL CMUMPS_GET_SIZE_NEEDED( & LREQI , LREQA, .FALSE., & KEEP(1), KEEP8(1), & N, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 700 PTLUST(STEP( IROOT )) = IWPOS IWPOS = IWPOS + LREQI IF (LREQA.EQ.0_8) THEN PTRAST (STEP(IROOT)) = POSFAC PTRFAC (STEP(IROOT)) = POSFAC ELSE PTRAST (STEP(IROOT)) = POSFAC PTRFAC (STEP(IROOT)) = POSFAC ENDIF POSFAC = POSFAC + LREQA LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA KEEP8(67) = min(KEEP8(67), LRLUS) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) POSHEAD = PTLUST( STEP(IROOT)) IW( POSHEAD + XXI ) = LREQI CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR)) CALL MUMPS_STOREI8( 0_8, IW(POSHEAD + XXD)) IW( POSHEAD + XXS ) = S_NOTFREE IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 IW( POSHEAD + KEEP(IXSZ) ) = 0 IW( POSHEAD + 1 + KEEP(IXSZ) ) = NEW_LOCAL_N IW( POSHEAD + 2 + KEEP(IXSZ) ) = NEW_LOCAL_M IW( POSHEAD + 4 + KEEP(IXSZ) ) = STEP(IROOT) IW( POSHEAD + 5 + KEEP(IXSZ) ) = 0 IF ( MASTER_OF_ROOT ) THEN IW( POSHEAD + 3 + KEEP(IXSZ) ) = TOT_ROOT_SIZE ELSE IW( POSHEAD + 3 + KEEP(IXSZ) ) = 0 ENDIF IF ( PTRIST(STEP(IROOT)) .EQ. 0) THEN CALL CMUMPS_SET_TO_ZERO(A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, KEEP) IF (KEEP(55) .EQ.0 ) THEN CALL CMUMPS_ASM_ARR_ROOT( N, root, roota, & IROOT, STEP(IROOT), & A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, & FILS, & KEEP, PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, & INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL CMUMPS_ASM_ELT_ROOT( N, root, roota, & A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF PAMASTER(STEP(IROOT)) = 0_8 ELSE IF ( PTRIST(STEP(IROOT)) .LT. 0 ) THEN CALL CMUMPS_SET_TO_ZERO(A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, KEEP) ELSE OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) IF ( TOT_ROOT_SIZE .eq. root%ROOT_SIZE ) THEN IF ( LREQA .NE. int(OLD_LOCAL_M,8) * int(OLD_LOCAL_N,8) ) & THEN write(*,*) 'error 1 in PROCESS_ROOT2SLAVE', & OLD_LOCAL_M, OLD_LOCAL_N CALL MUMPS_ABORT() END IF CALL CMUMPS_COPYI8SIZE(LREQA, & A( PAMASTER(STEP(IROOT)) ), & A( PTRAST (STEP(IROOT)) ) ) ELSE CALL CMUMPS_COPY_ROOT( A( PTRAST(STEP(IROOT))), & NEW_LOCAL_M, & NEW_LOCAL_N, A( PAMASTER( STEP(IROOT)) ), OLD_LOCAL_M, & OLD_LOCAL_N ) END IF IF ( PTRIST( STEP( IROOT ) ) .GT. 0 ) THEN IPOS_SON= PTRIST( STEP(IROOT)) CALL CMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., & MYID, N, IPOS_SON, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) END IF ENDIF PTRIST(STEP( IROOT )) = 0 PAMASTER(STEP( IROOT )) = 0_8 ENDIF IF ( NO_OLD_ROOT ) THEN IF (KEEP(253) .GT.0) THEN root%RHS_NLOC = MUMPS_NUMROC( KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) root%RHS_NLOC = max( root%RHS_NLOC, 1 ) ELSE root%RHS_NLOC = 1 ENDIF IF (associated(roota%RHS_ROOT)) DEALLOCATE(roota%RHS_ROOT) ALLOCATE(roota%RHS_ROOT(NEW_LOCAL_M, root%RHS_NLOC), & stat=allocok) IF ( allocok.GT.0 ) THEN IFLAG = -13 IERROR = NEW_LOCAL_N * root%RHS_NLOC GOTO 700 ENDIF IF (KEEP(253) .NE. 0) THEN roota%RHS_ROOT=ZERO CALL CMUMPS_ASM_RHS_ROOT( N, FILS, root, roota, KEEP, KEEP8, & RHS_MUMPS, IFLAG, IERROR ) ENDIF ELSE IF (NEW_LOCAL_M.GT.OLD_LOCAL_M .AND. KEEP(253) .GT.0) THEN TMP => roota%RHS_ROOT NULLIFY(roota%RHS_ROOT) ALLOCATE (roota%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 roota%RHS_ROOT(I,J)=TMP(I,J) ENDDO DO I = OLD_LOCAL_M+1, NEW_LOCAL_M roota%RHS_ROOT(I,J) = ZERO ENDDO ENDDO DEALLOCATE(TMP) NULLIFY(TMP) ENDIF KEEP(121) = KEEP(121) + TOT_CONT_TO_RECV IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL CMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL CMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL CMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT + N ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN 700 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE CMUMPS_PROCESS_ROOT2SLAVE SUBROUTINE CMUMPS_COPY_ROOT &( NEW, M_NEW, N_NEW,OLD, M_OLD, N_OLD ) INTEGER M_NEW, N_NEW, M_OLD, N_OLD COMPLEX NEW( M_NEW, N_NEW ), OLD( M_OLD, N_OLD ) INTEGER J COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) DO J = 1, N_OLD NEW( 1: M_OLD, J ) = OLD( 1: M_OLD, J ) NEW( M_OLD + 1: M_NEW, J ) = ZERO END DO NEW( 1: M_NEW,N_OLD + 1: N_NEW ) = ZERO RETURN END SUBROUTINE CMUMPS_COPY_ROOT MUMPS_5.8.1/src/sfac_process_bf.F0000664000175000017500000000103115042446437016461 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_PROCESS_BF_RETURN() RETURN END SUBROUTINE SMUMPS_PROCESS_BF_RETURN MUMPS_5.8.1/src/zini_driver.F0000664000175000017500000002444515042446442015676 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C #if defined(__ve__) #if defined(VHOFFLOAD) #include 've.h' #endif #endif SUBROUTINE ZMUMPS_INI_DRIVER( id, idintr ) USE ZMUMPS_STRUC_DEF USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_INTR_STRUC C C Purpose: C ======= C C Initialize an instance of the ZMUMPS package. C IMPLICIT NONE INCLUDE 'mpif.h' TYPE (ZMUMPS_STRUC) :: id TYPE (ZMUMPS_INTR_STRUC) :: idintr INTEGER MASTER, IERR,PAR_loc,SYM_loc PARAMETER( MASTER = 0 ) INTEGER color #if defined(metis) || defined(parmetis) INTEGER I #endif INTEGER(8) :: I8 C ----------------------------- C Initialize MPI related data C ----------------------------- CALL MPI_COMM_SIZE(id%COMM, id%NPROCS, IERR ) C Now done in the main MUMPS driver: C CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR ) C PAR_loc=id%PAR SYM_loc=id%SYM C Broadcasting PAR/SYM (KEEP(46)/KEEP(50)) in order to C have only one value available: the one from the master CALL MPI_BCAST(PAR_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) CALL MPI_BCAST(SYM_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) C Initialize a subcommunicator C for slave nodes C IF ( PAR_loc .eq. 0 ) THEN C ------------------- C Host is not working C ------------------- IF ( id%MYID .eq. MASTER ) THEN color = MPI_UNDEFINED ELSE color = 0 END IF CALL MPI_COMM_SPLIT( id%COMM, color, 0, & id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS - 1 ELSE C ---------------- C Host is working C ---------------- CALL MPI_COMM_DUP( id%COMM, id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS END IF C --------------------------- C Use same slave communicator C for load information C --------------------------- IF (PAR_loc .ne. 0 .or. id%MYID .NE. MASTER) THEN CALL MPI_COMM_DUP( id%COMM_NODES, id%COMM_LOAD, IERR ) ENDIF C ---------------------------------------------- C Initialize default values for CNTL,ICNTL,KEEP,KEEP8 C potentially depending on id%SYM and id%NSLAVES C ---------------------------------------------- CALL ZMUMPSID( id%NSLAVES, id%LWK_USER, & id%CNTL(1), id%ICNTL(1), & id%KEEP(1), id%KEEP8(1), id%INFO(1), id%INFOG(1), & id%RINFO(1), id%RINFOG(1), & SYM_loc, PAR_loc, id%DKEEP(1), id%MYID ) CALL MUMPS_BUILD_ARCH_NODE_COMM( id%COMM, id%KEEP(411), & id%KEEP(412), id%KEEP(413), id%KEEP(410) ) 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" #if ! defined(NO_SAVE_RESTORE) id%SAVE_DIR="NAME_NOT_INITIALIZED" id%SAVE_PREFIX="NAME_NOT_INITIALIZED" #endif C Default value for NRHS is 1 id%NRHS = 1 C Leading dimension will be reset to id%N is ZMUMPS_SOL_DRIVER C if id%NRHS remains equal to 1. Otherwise id%LRHS must be C set by user. id%LRHS = 0 ! Value will be checked in ZMUMPS_CHECK_DENSE_RHS ! Not accessed if id%NRHS=1 C Similar behaviour for LREDRHS (value will C be checked in ZMUMPS_CHECK_REDRHS) id%LREDRHS = 0 C id%INST_Number = -1 C C Define the options for Metis C id%METIS_OPTIONS(:) = 0 #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) C Useful size is 8 C set to default options id%METIS_OPTIONS(1) = 0 #else C Useful size is 40 C This sets the default values CALL METIS_SETDEFAULTOPTIONS(id%METIS_OPTIONS) CALL MUMPS_METIS_OPTION_NUMBERING(I) C The value of I corresponds to "METIS_OPTION_NUMBERING", which tells C METIS to use Fortran numbering. METIS_OPTION_NUMBERING is defined C in metis.h and accessed through a C wrapper. id%METIS_OPTIONS(I+1) = 1 ! +1 for Fortran indexing #endif #endif C C Nullify a few pointers and integers C id%N = 0; id%NZ = 0; id%NNZ = 0_8 NULLIFY(id%IRN) NULLIFY(id%JCN) NULLIFY(id%A) id%NZ_loc = 0; id%NNZ_loc = 0_8 NULLIFY(id%IRN_loc) NULLIFY(id%JCN_loc) NULLIFY(id%A_loc) NULLIFY(id%MAPPING) NULLIFY(id%RHS) NULLIFY(id%REDRHS) id%NZ_RHS=0 NULLIFY(id%RHS_SPARSE) NULLIFY(id%IRHS_SPARSE) NULLIFY(id%IRHS_PTR) NULLIFY(id%ISOL_loc) NULLIFY(id%IRHS_loc) id%LSOL_loc=0 id%LRHS_loc=0 id%Nloc_RHS=0 NULLIFY(id%SOL_loc) NULLIFY(id%RHS_loc) NULLIFY(id%COLSCA) NULLIFY(id%ROWSCA) NULLIFY(id%ROWSCA_loc) NULLIFY(id%COLSCA_loc) NULLIFY(id%PERM_IN) NULLIFY(id%IS) NULLIFY(id%STEP) C Info for analysis by block id%NBLK = 0 NULLIFY(id%BLKPTR) NULLIFY(id%BLKVAR) C Info for pruning tree NULLIFY(id%Step2node) NULLIFY(id%DAD_STEPS) NULLIFY(id%NE_STEPS) NULLIFY(id%ND_STEPS) NULLIFY(id%FRERE_STEPS) NULLIFY(id%SYM_PERM) NULLIFY(id%UNS_PERM) NULLIFY(id%PIVNUL_LIST) NULLIFY(id%FILS) NULLIFY(id%PTRAR) NULLIFY(id%PTR8ARR) NULLIFY(id%NINCOLARR) NULLIFY(id%NINROWARR) NULLIFY(id%PTRDEBARR) NULLIFY(id%FRTPTR) NULLIFY(id%FRTELT) NULLIFY(id%NA) id%LNA=0 NULLIFY(id%PROCNODE_STEPS) NULLIFY(id%S) NULLIFY(id%LPS) NULLIFY(id%PTLUST_S) NULLIFY(id%PTRFAC) NULLIFY(id%DEPTH_FIRST) NULLIFY(id%DEPTH_FIRST_SEQ) NULLIFY(id%SBTR_ID) NULLIFY(id%SCHED_DEP) NULLIFY(id%SCHED_SBTR) NULLIFY(id%SCHED_GRP) NULLIFY(id%CROIX_MANU) NULLIFY(id%WK_USER) NULLIFY(id%MEM_SUBTREE) NULLIFY(id%MEM_SUBTREE) NULLIFY(id%MY_ROOT_SBTR) NULLIFY(id%MY_FIRST_LEAF) NULLIFY(id%MY_NB_LEAF) NULLIFY(id%COST_TRAV) NULLIFY(id%RHSINTR) id%LD_RHSINTR = 0 NULLIFY(id%GLOB2LOC_RHS) NULLIFY(id%GLOB2LOC_SOL) id%GLOB2LOC_SOL_ALLOC = .FALSE. C C Out of Core management related data C NULLIFY(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAMES) NULLIFY(id%OOC_VADDR) NULLIFY(id%OOC_NB_FILES) NULLIFY(id%LRGROUPS) NULLIFY(id%FDM_F_ENCODING) NULLIFY(id%BLRARRAY_ENCODING) NULLIFY(id%MTKO_PROCS_MAP) C Must be nullified because of routine C ZMUMPS_SIZE_IN_STRUCT NULLIFY(id%CB_SON_SIZE) C C Components of the arithmetic-dependent root C CALL ZMUMPS_INI_ROOT(idintr%roota) NULLIFY(idintr%root%RG2L) NULLIFY(idintr%root%IPIV) NULLIFY(id%SCHUR_CINTERFACE) C C Element-entry C id%NELT=0 NULLIFY(id%ELTPTR) NULLIFY(id%ELTVAR) NULLIFY(id%A_ELT) NULLIFY(id%ELTPROC) C C Schur C id%SIZE_SCHUR = 0 NULLIFY( id%LISTVAR_SCHUR ) NULLIFY( id%SCHUR ) C -- Distributed Schur id%NPROW = 0 id%NPCOL = 0 id%MBLOCK = 0 id%NBLOCK = 0 id%SCHUR_MLOC = 0 ! Exit from analysis id%SCHUR_NLOC = 0 ! Exit from analysis id%SCHUR_LLD = 0 C C Candidates and node partitionning C NULLIFY(id%ISTEP_TO_INIV2) NULLIFY(id%I_AM_CAND) NULLIFY(id%FUTURE_NIV2) NULLIFY(id%TAB_POS_IN_PERE) NULLIFY(id%CANDIDATES) id%OOC_NB_FILE_TYPE=-123456 C C Initializations for L0_OMP mechanisms C NULLIFY(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) NULLIFY(id%PHYS_L0_OMP) NULLIFY(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%PERM_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) NULLIFY(id%L0_OMP_MAPPING) NULLIFY(idintr%L0_OMP_FACTORS) NULLIFY(id%I4_L0_OMP) NULLIFY(id%I8_L0_OMP) id%LPOOL_B_L0_OMP = 0 id%LPOOL_A_L0_OMP = 0 id%L_VIRT_L0_OMP = 0 id%L_PHYS_L0_OMP = 0 id%THREAD_LA = 0 C C Mapping information used during solve. C NULLIFY(id%IPTR_WORKING) NULLIFY(id%WORKING) C C Initializations for Rank detection/null space C NULLIFY(id%SINGULAR_VALUES) C Architecture data NULLIFY(id%MEM_DIST) C Must be nullified because of routine C ZMUMPS_SIZE_IN_STRUCT NULLIFY(id%SUP_PROC) id%Deficiency = 0 idintr%root%LPIV = -1 idintr%root%yes = .FALSE. idintr%root%gridinit_done = .FALSE. C NOT IN SAVE/RESTORE id%ASSOCIATED_OOC_FILES=.FALSE. C C ---------------------------------------- C Find MYID_NODES relatively to COMM_NODES C If the calling processor is not inside C COMM_NODES, MYID_NODES will not be C significant / used anyway C ---------------------------------------- IF ( id%KEEP( 46 ) .ne. 0 .OR. & id%MYID .ne. MASTER ) THEN CALL MPI_COMM_RANK & (id%COMM_NODES, id%MYID_NODES, IERR ) ELSE id%MYID_NODES = -464646 ENDIF C C Check that KEEP(34), the size of a Fortran INTEGER, C as initialized above during ZMUMPSID C matches the size of an integer in C. If not, C raise an error immediately. C CALL MUMPS_INT_SIZE_C(I8) IF (int(I8) .NE. id%KEEP(34)) THEN id%INFO(1)=-69 id%INFO(2)=int(I8) ! size of MUMPS_INT C Installation problem! C WRITE on unit 6 since ICNTL(1:4) are not set by the user yet IF (id%MYID .EQ. 0) WRITE(6,995) int(I8) 995 FORMAT(' Installation error -69: ', &' MUMPS_INT size (',I4,') incompatible with INTEGER size') ENDIF RETURN END SUBROUTINE ZMUMPS_INI_DRIVER SUBROUTINE ZMUMPS_INI_ROOT(roota) USE ZMUMPS_INTR_TYPES, ONLY: ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE(ZMUMPS_ROOT_STRUC) :: roota NULLIFY(roota%RHS_CNTR_MASTER_ROOT) NULLIFY(roota%RHS_ROOT) NULLIFY(roota%SCHUR_POINTER) CALL ZMUMPS_RR_INIT_POINTERS(roota) RETURN END SUBROUTINE ZMUMPS_INI_ROOT MUMPS_5.8.1/src/mumps_load.F0000664000175000017500000064623115042446423015514 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_LOAD implicit none PUBLIC :: MUMPS_LOAD_SET_INICOST, MUMPS_LOAD_INIT, & MUMPS_LOAD_SET_SLAVES, MUMPS_LOAD_UPDATE, & MUMPS_LOAD_END, MUMPS_LOAD_PROCESS_MESSAGE, & MUMPS_LOAD_LESS, MUMPS_LOAD_LESS_CAND, & MUMPS_LOAD_SET_SLAVES_CAND, MUMPS_LOAD_MASTER_2_ALL, & MUMPS_LOAD_RECV_MSGS, MUMPS_LOAD_MEM_UPDATE, & MUMPS_LOAD_SET_PARTITION, & MUMPS_SPLIT_PREP_PARTITION, MUMPS_SPLIT_POST_PARTITION, & MUMPS_SPLIT_PROPAGATE_PARTI, MUMPS_LOAD_POOL_UPD_NEW_POOL, & MUMPS_LOAD_SBTR_UPD_NEW_POOL, MUMPS_LOAD_POOL_CHECK_MEM, & MUMPS_LOAD_SET_SBTR_MEM, & MUMPS_REMOVE_NODE, MUMPS_UPPER_PREDICT & ,MUMPS_LOAD_SEND_MD_INFO, & MUMPS_LOAD_CLEAN_MEMINFO_POOL, MUMPS_LOAD_COMP_MAXMEM_POOL, & MUMPS_LOAD_CHK_MEMCST_POOL, MUMPS_CHECK_SBTR_COST, & MUMPS_FIND_BEST_NODE_FOR_MEM, & MUMPS_LOAD_INIT_SBTR_STRUCT DOUBLE PRECISION, DIMENSION(:), & ALLOCATABLE, SAVE, PRIVATE :: LOAD_FLOPS INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PRIVATE :: BUF_LOAD_RECV INTEGER, SAVE, PRIVATE :: LBUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES INTEGER, SAVE, PRIVATE :: K50, K69, K35 INTEGER(8), SAVE, PRIVATE :: MAX_SURF_MASTER LOGICAL, SAVE, PRIVATE :: BDC_MEM, BDC_POOL, BDC_SBTR, & BDC_POOL_MNG, & BDC_M2_MEM,BDC_M2_FLOPS,BDC_MD,REMOVE_NODE_FLAG, & REMOVE_NODE_FLAG_MEM DOUBLE PRECISION, SAVE, PRIVATE :: REMOVE_NODE_COST, & REMOVE_NODE_COST_MEM INTEGER, SAVE, PRIVATE :: SBTR_WHICH_M DOUBLE PRECISION, DIMENSION(:), & ALLOCATABLE, TARGET, SAVE, PRIVATE :: WLOAD DOUBLE PRECISION, SAVE, PRIVATE :: DELTA_LOAD, DELTA_MEM LOGICAL, SAVE, PRIVATE :: IS_MUMPS_LOAD_ENABLED PUBLIC:: MUMPS_LOAD_ENABLE, MUMPS_LOAD_DISABLE INTEGER(8), SAVE, PRIVATE :: CHECK_MEM INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, TARGET, PRIVATE :: & IDWLOAD DOUBLE PRECISION, SAVE, PRIVATE :: ALPHA DOUBLE PRECISION, SAVE, PRIVATE :: BETA INTEGER, SAVE, PRIVATE :: MYID, NPROCS, COMM_LD INTEGER, SAVE, PRIVATE :: COMM_NODES DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, SAVE, & PRIVATE :: POOL_MEM DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, PRIVATE, & SAVE :: SBTR_MEM DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, & PRIVATE, SAVE :: SBTR_CUR INTEGER, DIMENSION(:), ALLOCATABLE, & PRIVATE, SAVE :: NB_SON DOUBLE PRECISION, & PRIVATE, SAVE :: SBTR_CUR_LOCAL DOUBLE PRECISION, & PRIVATE, SAVE :: PEAK_SBTR_CUR_LOCAL DOUBLE PRECISION, & PRIVATE, SAVE :: MAX_PEAK_STK DOUBLE PRECISION, SAVE, & PRIVATE :: POOL_LAST_COST_SENT DOUBLE PRECISION, SAVE, & PRIVATE :: MIN_DIFF INTEGER, SAVE :: POS_ID,POS_MEM INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: CB_COST_ID INTEGER(8), DIMENSION(:), ALLOCATABLE, SAVE & :: CB_COST_MEM PUBLIC :: CB_COST_ID, CB_COST_MEM,POS_MEM,POS_ID DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: LU_USAGE INTEGER(8), DIMENSION(:), ALLOCATABLE, SAVE, & PRIVATE::MD_MEM, TAB_MAXS DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, SAVE ::MEM_SUBTREE INTEGER :: NB_SUBTREES,NIV1_FLAG INTEGER, PRIVATE :: INDICE_SBTR,INDICE_SBTR_ARRAY INTEGER :: POOL_NIV2_SIZE INTEGER,SAVE :: INSIDE_SUBTREE PUBLIC :: NB_SUBTREES,MEM_SUBTREE,INSIDE_SUBTREE,NIV1_FLAG DOUBLE PRECISION, SAVE, PRIVATE :: DM_SUMLU, & DM_THRES_MEM DOUBLE PRECISION, DIMENSION(:), & ALLOCATABLE, SAVE , PRIVATE:: DM_MEM INTEGER, SAVE, PRIVATE :: POOL_SIZE,ID_MAX_M2 DOUBLE PRECISION, SAVE, PRIVATE :: MAX_M2,TMP_M2 INTEGER, DIMENSION(:),ALLOCATABLE,SAVE, PRIVATE:: POOL_NIV2 DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE,SAVE, & PRIVATE :: POOL_NIV2_COST, NIV2 DOUBLE PRECISION, SAVE, PRIVATE :: CHK_LD INTEGER, DIMENSION(:),POINTER, SAVE, PRIVATE :: & PROCNODE_LOAD, STEP_TO_NIV2_LOAD INTEGER, DIMENSION(:),POINTER, SAVE, PRIVATE :: KEEP_LOAD INTEGER, SAVE, PRIVATE :: N_LOAD INTEGER(8), DIMENSION(:), POINTER, SAVE, PRIVATE:: KEEP8_LOAD INTEGER, DIMENSION(:),POINTER, SAVE :: & FILS_LOAD, STEP_LOAD, & FRERE_LOAD, ND_LOAD, & NE_LOAD,DAD_LOAD INTEGER, DIMENSION(:,:),POINTER, SAVE, PRIVATE :: CAND_LOAD INTEGER, DIMENSION(:),POINTER, SAVE, & PRIVATE :: MY_FIRST_LEAF,MY_NB_LEAF, MY_ROOT_SBTR INTEGER, DIMENSION(:),ALLOCATABLE,SAVE, & PRIVATE ::SBTR_FIRST_POS_IN_POOL DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE,SAVE, & PRIVATE ::SBTR_PEAK_ARRAY, & SBTR_CUR_ARRAY DOUBLE PRECISION,DIMENSION(:),POINTER, SAVE :: COST_TRAV INTEGER, DIMENSION(:),POINTER, SAVE :: DEPTH_FIRST_LOAD, & DEPTH_FIRST_SEQ_LOAD,SBTR_ID_LOAD PUBLIC :: DEPTH_FIRST_LOAD,COST_TRAV, FILS_LOAD,STEP_LOAD, & FRERE_LOAD, ND_LOAD,NE_LOAD,DAD_LOAD, & DEPTH_FIRST_SEQ_LOAD,SBTR_ID_LOAD INTEGER, SAVE :: ROOT_CURRENT_SUBTREE,CURRENT_BEST, & SECOND_CURRENT_BEST PUBLIC :: ROOT_CURRENT_SUBTREE,CURRENT_BEST, & SECOND_CURRENT_BEST CONTAINS SUBROUTINE MUMPS_LOAD_ENABLE() IMPLICIT NONE IS_MUMPS_LOAD_ENABLED = .TRUE. RETURN END SUBROUTINE MUMPS_LOAD_ENABLE SUBROUTINE MUMPS_LOAD_DISABLE() IMPLICIT NONE IS_MUMPS_LOAD_ENABLED = .FALSE. RETURN END SUBROUTINE MUMPS_LOAD_DISABLE SUBROUTINE MUMPS_LOAD_SET_INICOST( COST_SUBTREE_ARG, K64, DK15, & K375, MAXS ) IMPLICIT NONE DOUBLE PRECISION COST_SUBTREE_ARG INTEGER, INTENT(IN) :: K64, K375 DOUBLE PRECISION, INTENT(IN) :: DK15 INTEGER(8)::MAXS DOUBLE PRECISION :: T64, T66 LOGICAL :: AVOID_LOAD_MESSAGES T64 = max ( dble(K64), dble(1) ) T64 = min ( T64, dble(1000) ) T66 = max (dble(DK15), dble(100)) MIN_DIFF = ( T64 / dble(1000) )* & T66 * dble(1000000) DM_THRES_MEM = dble(MAXS/300_8) AVOID_LOAD_MESSAGES = .FALSE. IF (K375.EQ.1) THEN AVOID_LOAD_MESSAGES = .TRUE. ENDIF IF (AVOID_LOAD_MESSAGES) THEN MIN_DIFF = MIN_DIFF * 1000.D0 DM_THRES_MEM = DM_THRES_MEM * 1000_8 ENDIF RETURN END SUBROUTINE MUMPS_LOAD_SET_INICOST SUBROUTINE MUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND, ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, SLAVES_LIST, & SIZE_SLAVES_LIST & ) IMPLICIT NONE INTEGER, intent(in) :: INODE, N, SIZE_SLAVES_LIST, SLAVEF, & KEEP(500) INTEGER, intent(in) :: STEP(N), DAD (KEEP(28)), ICNTL(60), & PROCNODE_STEPS(KEEP(28)), CAND(SLAVEF+1), & FILS(N) INTEGER, intent(out) :: NBSPLIT, NUMORG_SPLIT INTEGER, intent(inout) :: SLAVES_LIST(SIZE_SLAVES_LIST), & COPY_CAND(SLAVEF+1) INTEGER :: IN, LP, II INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT LP = ICNTL(1) IN = INODE NBSPLIT = 0 NUMORG_SPLIT = 0 DO WHILE & ( & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.6 & ) & ) NBSPLIT = NBSPLIT + 1 IN = DAD(STEP(IN)) II = IN DO WHILE (II.GT.0) NUMORG_SPLIT = NUMORG_SPLIT + 1 II = FILS(II) ENDDO END DO SLAVES_LIST(1:NBSPLIT) = CAND(1:NBSPLIT) COPY_CAND(1:SIZE_SLAVES_LIST-NBSPLIT) = & CAND(1+NBSPLIT:SIZE_SLAVES_LIST) COPY_CAND(SIZE_SLAVES_LIST-NBSPLIT+1:SLAVEF) = -1 COPY_CAND(SLAVEF+1) = SIZE_SLAVES_LIST-NBSPLIT RETURN END SUBROUTINE MUMPS_SPLIT_PREP_PARTITION SUBROUTINE MUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, ICNTL, & TAB_POS, NSLAVES_NODE & ) IMPLICIT NONE INTEGER, intent(in) :: INODE, N, SLAVEF, NCB, & KEEP(500), NBSPLIT INTEGER, intent(in) :: STEP(N), DAD (KEEP(28)), ICNTL(60), & PROCNODE_STEPS(KEEP(28)), & FILS(N) INTEGER, intent(inout) :: TAB_POS ( SLAVEF+2 ), NSLAVES_NODE INTEGER :: IN, LP, II, NUMORG, NBSPLIT_LOC, I INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT DO I= NSLAVES_NODE+1, 1, -1 TAB_POS(I+NBSPLIT) = TAB_POS(I) END DO LP = ICNTL(1) IN = INODE NBSPLIT_LOC = 0 NUMORG = 0 TAB_POS(1) = 1 DO WHILE & ( & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.6 & ) & ) NBSPLIT_LOC = NBSPLIT_LOC + 1 IN = DAD(STEP(IN)) II = IN DO WHILE (II.GT.0) NUMORG = NUMORG + 1 II = FILS(II) ENDDO TAB_POS(NBSPLIT_LOC+1) = NUMORG + 1 END DO DO I = NBSPLIT+2, NBSPLIT+NSLAVES_NODE+1 TAB_POS(I) = TAB_POS(I) + NUMORG ENDDO NSLAVES_NODE = NSLAVES_NODE + NBSPLIT TAB_POS (NSLAVES_NODE+2:SLAVEF+1) = -9999 TAB_POS ( SLAVEF+2 ) = NSLAVES_NODE RETURN END SUBROUTINE MUMPS_SPLIT_POST_PARTITION SUBROUTINE MUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND, SIZE_CAND, & SON_SLAVE_LIST, NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, ICNTL, & ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES_NODE, & SLAVES_LIST, SIZE_SLAVES_LIST & ) IMPLICIT NONE INTEGER, intent(in) :: INODE, TYPESPLIT, IFSON, N, SLAVEF, & KEEP(500), & NSLSON, SIZE_SLAVES_LIST, SIZE_CAND INTEGER, intent(in) :: STEP(N), DAD (KEEP(28)), ICNTL(60), & PROCNODE_STEPS(KEEP(28)), & FILS(N), INIV2, & SON_SLAVE_LIST (NSLSON), & ISTEP_TO_INIV2(KEEP(71)), & CAND(SIZE_CAND) INTEGER, intent(out) :: NSLAVES_NODE INTEGER, intent(inout) :: & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, intent(out) :: SLAVES_LIST (SIZE_SLAVES_LIST) INTEGER :: I, NSLAVES_SONS, & INIV2_FILS, ISHIFT 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 MUMPS_SPLIT_PROPAGATE_PARTI SUBROUTINE MUMPS_LOAD_SET_PARTITION( & NCBSON_MAX, SLAVEF, & KEEP,KEEP8,ICNTL, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,INODE &) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: SLAVEF, NFRONT INTEGER, intent (inout) ::NCB INTEGER, intent(in) :: CAND_OF_NODE(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE INTEGER, intent(in) :: NCBSON_MAX INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER i INTEGER LP,MP INTEGER(8) DUMMY1 INTEGER DUMMY2 INTEGER TMP_ARRAY(2) LP=ICNTL(4) MP=ICNTL(2) IF ( KEEP(48) == 0 .OR. KEEP(48) .EQ. 3 ) THEN CALL MUMPS_LOAD_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST) ELSE IF ( KEEP(48) == 4 ) THEN CALL MUMPS_SET_PARTI_ACTV_MEM( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID) DO i=1,NSLAVES_NODE IF(TAB_POS(i+1)-TAB_POS(i).LE.0)THEN WRITE(*,*)'probleme de partition dans &MUMPS_LOAD_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDDO ELSE IF ( KEEP(48) == 5 ) THEN IF (KEEP(375).EQ.1) THEN GOTO 458 ENDIF CALL MUMPS_SET_PARTI_FLOP_IRR( & NCBSON_MAX, & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE, & MP,LP) DO i=1,NSLAVES_NODE IF(TAB_POS(i+1)-TAB_POS(i).LE.0)THEN WRITE(*,*)'problem with partition in &MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDDO GOTO 457 458 CONTINUE IF ( KEEP(375).EQ.1 )THEN TMP_ARRAY(1)=0 TMP_ARRAY(2)=0 ENDIF CALL MUMPS_SET_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE, & TAB_MAXS,TMP_ARRAY,DUMMY1,DUMMY2 & ) ELSE WRITE(*,*) "Strategy 6 not implemented" CALL MUMPS_ABORT() ENDIF 457 CONTINUE RETURN END SUBROUTINE MUMPS_LOAD_SET_PARTITION SUBROUTINE MUMPS_LOAD_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB INTEGER, intent(in) :: CAND_OF_NODE(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1) INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER ITEMP, NMB_OF_CAND, NSLAVES_LESS DOUBLE PRECISION MSG_SIZE LOGICAL FORCE_CAND INTEGER MUMPS_REG_GET_NSLAVES EXTERNAL MUMPS_REG_GET_NSLAVES IF ( KEEP(48) == 0 .AND. KEEP(50) .NE. 0) THEN write(*,*) "Internal error 2 in MUMPS_LOAD_PARTI_REGULAR." CALL MUMPS_ABORT() END IF IF ( KEEP(48) == 3 .AND. KEEP(50) .EQ. 0) THEN write(*,*) "Internal error 3 in MUMPS_LOAD_PARTI_REGULAR." CALL MUMPS_ABORT() END IF MSG_SIZE = dble( NFRONT - NCB ) * dble(NCB) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF IF (FORCE_CAND) THEN ITEMP=MUMPS_LOAD_LESS_CAND & (MEM_DISTRIB, & CAND_OF_NODE, & & KEEP(69), SLAVEF, MSG_SIZE, & NMB_OF_CAND ) ELSE ITEMP=MUMPS_LOAD_LESS(KEEP(69),MEM_DISTRIB,MSG_SIZE) NMB_OF_CAND = SLAVEF - 1 END IF NSLAVES_LESS = max(ITEMP,1) NSLAVES_NODE = MUMPS_REG_GET_NSLAVES(KEEP8(21), KEEP(48), & KEEP(50),SLAVEF, & NCB, NFRONT, NSLAVES_LESS, NMB_OF_CAND, & KEEP(375), KEEP(119)) CALL MUMPS_BLOC2_SETPARTITION( & KEEP,KEEP8, SLAVEF, & TAB_POS, & NSLAVES_NODE, NFRONT, NCB & ) IF (FORCE_CAND) THEN CALL MUMPS_LOAD_SET_SLAVES_CAND(MEM_DISTRIB(0), & CAND_OF_NODE, SLAVEF, NSLAVES_NODE, & SLAVES_LIST) ELSE CALL MUMPS_LOAD_SET_SLAVES(MEM_DISTRIB(0), & MSG_SIZE, SLAVES_LIST, NSLAVES_NODE) ENDIF RETURN END SUBROUTINE MUMPS_LOAD_PARTI_REGULAR SUBROUTINE MUMPS_LOAD_INIT( MEMORY_MD_ARG, MAXS, idKEEP, & idKEEP8, idINFO, idISTEP_TO_INIV2, idCANDIDATES, idND_STEPS, & idFILS, idFRERE_STEPS, idDAD_STEPS, idPROCNODE_STEPS, & idSTEP, idNE_STEPS, idN, idMAX_SURF_MASTER, idSUP_PROC, & idCOMM_LOAD, idCOMM_NODES, & idDEPTH_FIRST, idCOST_TRAV, idDEPTH_FIRST_SEQ, idSBTR_ID, & idNA, idNSLAVES, idFUTURE_NIV2, & idNBSA, idNBSA_LOCAL, idMEM_SUBTREE, idMY_FIRST_LEAF, & idMY_NB_LEAF, idMY_ROOT_SBTR ) USE MUMPS_BUF_COMMON USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER(8), intent(in) :: MEMORY_MD_ARG INTEGER(8), intent(in) :: MAXS INTEGER, TARGET :: idKEEP(500) INTEGER(8), TARGET :: idKEEP8(150) INTEGER, TARGET :: idINFO(80) INTEGER, DIMENSION(:), POINTER :: idISTEP_TO_INIV2 INTEGER, DIMENSION(:,:), POINTER :: idCANDIDATES INTEGER,POINTER,DIMENSION(:) :: idND_STEPS INTEGER,POINTER,DIMENSION(:) :: idFILS INTEGER,POINTER,DIMENSION(:) :: idFRERE_STEPS, idDAD_STEPS INTEGER,POINTER,DIMENSION(:) :: idPROCNODE_STEPS INTEGER,POINTER,DIMENSION(:) :: idSTEP INTEGER,POINTER,DIMENSION(:) :: idNE_STEPS INTEGER :: idN INTEGER(8) :: idMAX_SURF_MASTER INTEGER, DIMENSION(:,:), POINTER :: idSUP_PROC INTEGER :: idCOMM_LOAD, idCOMM_NODES INTEGER, DIMENSION(:), POINTER :: idDEPTH_FIRST DOUBLE PRECISION, DIMENSION(:), POINTER :: idCOST_TRAV INTEGER, DIMENSION(:), POINTER :: idDEPTH_FIRST_SEQ INTEGER, DIMENSION(:), POINTER :: idSBTR_ID INTEGER,POINTER,DIMENSION(:) :: idNA INTEGER :: idNSLAVES INTEGER, DIMENSION(:), POINTER :: idFUTURE_NIV2 INTEGER :: idNBSA, idNBSA_LOCAL DOUBLE PRECISION, DIMENSION(:), POINTER :: idMEM_SUBTREE INTEGER, DIMENSION(:), POINTER :: idMY_FIRST_LEAF INTEGER, DIMENSION(:), POINTER :: idMY_NB_LEAF INTEGER, DIMENSION(:), POINTER :: idMY_ROOT_SBTR INTEGER K34_LOC INTEGER(8) :: I8SIZE INTEGER allocok, IERR, IERR_MPI, i, BUF_LOAD_SIZE DOUBLE PRECISION :: MAX_SBTR DOUBLE PRECISION ZERO DOUBLE PRECISION MEMORY_SENT PARAMETER( ZERO=0.0d0 ) DOUBLE PRECISION SIZE_DBLE(2) INTEGER WHAT INTEGER(8) MEMORY_MD, LA CALL MUMPS_LOAD_ENABLE() STEP_TO_NIV2_LOAD=>idISTEP_TO_INIV2 CAND_LOAD=>idCANDIDATES ND_LOAD=>idND_STEPS KEEP_LOAD=>idKEEP KEEP8_LOAD=>idKEEP8 FILS_LOAD=>idFILS FRERE_LOAD=>idFRERE_STEPS DAD_LOAD=>idDAD_STEPS PROCNODE_LOAD=>idPROCNODE_STEPS STEP_LOAD=>idSTEP NE_LOAD=>idNE_STEPS N_LOAD=idN ROOT_CURRENT_SUBTREE=-9999 MEMORY_MD=MEMORY_MD_ARG LA=MAXS MAX_SURF_MASTER=idMAX_SURF_MASTER+ & (int(idKEEP(12),8)*int(idMAX_SURF_MASTER,8)/int(100,8)) COMM_LD = idCOMM_LOAD COMM_NODES = idCOMM_NODES MAX_PEAK_STK = 0.0D0 K69 = idKEEP(69) IF ( idKEEP(47) .le. 0 .OR. idKEEP(47) .gt. 4 ) THEN write(*,*) "Internal error 1 in MUMPS_LOAD_INIT" CALL MUMPS_ABORT() END IF CHK_LD=dble(0) BDC_MEM = ( idKEEP(47) >= 2 ) BDC_POOL = ( idKEEP(47) >= 3 ) BDC_SBTR = ( idKEEP(47) >= 4 ) BDC_M2_MEM = ( ( idKEEP(80) == 2 .OR. idKEEP(80) == 3 ) & .AND. idKEEP(47) == 4 ) BDC_M2_FLOPS = ( idKEEP(80) == 1 & .AND. idKEEP(47) .GE. 1 ) BDC_MD = (idKEEP(86)==1) SBTR_WHICH_M = idKEEP(90) REMOVE_NODE_FLAG=.FALSE. REMOVE_NODE_FLAG_MEM=.FALSE. REMOVE_NODE_COST_MEM=dble(0) REMOVE_NODE_COST=dble(0) IF (idKEEP(80) .LT. 0 .OR. idKEEP(80)>3) THEN WRITE(*,*) "Unimplemented KEEP(80) Strategy" CALL MUMPS_ABORT() ENDIF IF ((idKEEP(80) == 2 .OR. idKEEP(80)==3).AND. idKEEP(47).NE.4) & THEN WRITE(*,*) "Internal error 3 in MUMPS_LOAD_INIT" CALL MUMPS_ABORT() END IF IF (idKEEP(81) == 1 .AND. idKEEP(47) < 2) THEN WRITE(*,*) "Internal error 2 in MUMPS_LOAD_INIT" CALL MUMPS_ABORT() ENDIF BDC_POOL_MNG = ((idKEEP(81) == 1).AND.(idKEEP(47) >= 2)) IF(idKEEP(76).EQ.4)THEN DEPTH_FIRST_LOAD=>idDEPTH_FIRST ENDIF IF(idKEEP(76).EQ.5)THEN COST_TRAV=>idCOST_TRAV ENDIF IF(idKEEP(76).EQ.6)THEN DEPTH_FIRST_LOAD=>idDEPTH_FIRST DEPTH_FIRST_SEQ_LOAD=>idDEPTH_FIRST_SEQ SBTR_ID_LOAD=>idSBTR_ID ENDIF IF (BDC_M2_MEM.OR.BDC_M2_FLOPS) THEN POOL_NIV2_SIZE=max(1,min(idNBSA+idKEEP(262),idNA(1))) ALLOCATE(NIV2(idNSLAVES), NB_SON(idKEEP(28)), & POOL_NIV2(POOL_NIV2_SIZE), & POOL_NIV2_COST(POOL_NIV2_SIZE), & stat=allocok) DO i = 1, idKEEP(28) NB_SON(i)=idNE_STEPS(i) ENDDO NIV2=dble(0) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(2) = idNSLAVES + idKEEP(28) + 200 RETURN ENDIF ENDIF K50 = idKEEP(50) CALL MPI_COMM_RANK( COMM_LD, MYID, IERR_MPI ) NPROCS = idNSLAVES 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 MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(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 MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(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 MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(2) = NPROCS RETURN END IF LU_USAGE=dble(0) MD_MEM=int(0,8) ENDIF IF((idKEEP(81).EQ.2).OR.(idKEEP(81).EQ.3))THEN ALLOCATE(CB_COST_MEM(2*2000*idNSLAVES), & stat=allocok) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(2) = idNSLAVES RETURN ENDIF CB_COST_MEM=int(0,8) ALLOCATE(CB_COST_ID(2000*3), & stat=allocok) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(2) = idNSLAVES RETURN ENDIF CB_COST_ID=0 POS_MEM=1 POS_ID=1 ENDIF ALLOCATE(FUTURE_NIV2(NPROCS), stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(2) = NPROCS RETURN ENDIF DO i = 1, NPROCS FUTURE_NIV2(i) = idFUTURE_NIV2(i) IF(BDC_MD)THEN IF(FUTURE_NIV2(i).EQ.0)THEN MD_MEM(i-1)=999999999_8 ENDIF ENDIF ENDDO DELTA_MEM=ZERO DELTA_LOAD=ZERO CHECK_MEM=0_8 IF(BDC_SBTR.OR.BDC_POOL_MNG)THEN NB_SUBTREES=idNBSA_LOCAL IF (allocated(MEM_SUBTREE)) DEALLOCATE(MEM_SUBTREE) ALLOCATE(MEM_SUBTREE(idNBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(2) = idNBSA_LOCAL RETURN ENDIF DO i=1,idNBSA_LOCAL MEM_SUBTREE(i)=idMEM_SUBTREE(i) ENDDO MY_FIRST_LEAF=>idMY_FIRST_LEAF MY_NB_LEAF=>idMY_NB_LEAF MY_ROOT_SBTR=>idMY_ROOT_SBTR IF (allocated(SBTR_FIRST_POS_IN_POOL)) & DEALLOCATE(SBTR_FIRST_POS_IN_POOL) ALLOCATE(SBTR_FIRST_POS_IN_POOL(idNBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(2) = idNBSA_LOCAL RETURN ENDIF INSIDE_SUBTREE=0 PEAK_SBTR_CUR_LOCAL = dble(0) SBTR_CUR_LOCAL = dble(0) IF (allocated(SBTR_PEAK_ARRAY)) DEALLOCATE(SBTR_PEAK_ARRAY) ALLOCATE(SBTR_PEAK_ARRAY(idNBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(2) = idNBSA_LOCAL RETURN ENDIF SBTR_PEAK_ARRAY=dble(0) IF (allocated(SBTR_CUR_ARRAY)) DEALLOCATE(SBTR_CUR_ARRAY) ALLOCATE(SBTR_CUR_ARRAY(idNBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(2) = idNBSA_LOCAL RETURN ENDIF SBTR_CUR_ARRAY=dble(0) INDICE_SBTR_ARRAY=1 NIV1_FLAG=0 INDICE_SBTR=1 ENDIF IF ( allocated(LOAD_FLOPS) ) DEALLOCATE( LOAD_FLOPS ) ALLOCATE( LOAD_FLOPS( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(2) = NPROCS RETURN END IF IF ( allocated(WLOAD) ) DEALLOCATE( WLOAD ) ALLOCATE( WLOAD( NPROCS ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(2) = NPROCS RETURN END IF IF ( allocated(IDWLOAD) ) DEALLOCATE( IDWLOAD ) ALLOCATE( IDWLOAD( NPROCS ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(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 MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(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 MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(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 MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(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 MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(2) = NPROCS RETURN END IF SBTR_CUR = dble(0) SBTR_MEM = dble(0) END IF K34_LOC=idKEEP(34) CALL MUMPS_SIZE_C(SIZE_DBLE(1),SIZE_DBLE(2),I8SIZE) K35 = int(I8SIZE) BUF_LOAD_SIZE = K34_LOC * 2 * ( NPROCS - 1 ) + & NPROCS * ( K35 + K34_LOC ) IF (BDC_MEM) THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35 END IF IF (BDC_SBTR)THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35 ENDIF LBUF_LOAD_RECV = (BUF_LOAD_SIZE+K34_LOC)/K34_LOC LBUF_LOAD_RECV_BYTES = LBUF_LOAD_RECV * K34_LOC IF ( allocated(BUF_LOAD_RECV) ) DEALLOCATE(BUF_LOAD_RECV) ALLOCATE( BUF_LOAD_RECV( LBUF_LOAD_RECV), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in MUMPS_LOAD_INIT' idINFO(1) = -13 idINFO(2) = LBUF_LOAD_RECV RETURN ENDIF BUF_LOAD_SIZE = BUF_LOAD_SIZE * 20 CALL MUMPS_BUF_ALLOC_LOAD_BUFFER( BUF_LOAD_SIZE, IERR ) IF ( IERR .LT. 0 ) THEN idINFO(1) = -13 idINFO(2) = BUF_LOAD_SIZE RETURN END IF DO i = 0, NPROCS - 1 LOAD_FLOPS( i ) = ZERO END DO IF ( BDC_MEM ) THEN DO i = 0, NPROCS - 1 DM_MEM( i )=ZERO END DO ENDIF CALL CMUMPS_INIT_ALPHA_BETA(idKEEP(69)) IF(BDC_MD)THEN MAX_SBTR=0.0D0 IF(BDC_SBTR)THEN DO i=1,idNBSA_LOCAL MAX_SBTR=max(idMEM_SUBTREE(i),MAX_SBTR) ENDDO ENDIF MD_MEM(MYID)=MEMORY_MD WHAT=8 CALL MUMPS_BUF_BROADCAST( WHAT, & COMM_LD, NPROCS, & FUTURE_NIV2, & dble(MEMORY_MD),dble(0) ,MYID, idKEEP(267), IERR ) WHAT=9 MEMORY_SENT = dble(LA-MAX_SURF_MASTER)-MAX_SBTR & - max( dble(LA) * dble(3) / dble(100), & dble(2) * & dble(max(idKEEP(5),idKEEP(6))) * dble(idKEEP(127))) IF (idKEEP(12) > 25) THEN MEMORY_SENT = MEMORY_SENT - & dble(idKEEP(12))*0.2d0*dble(LA)/100.0d0 ENDIF IF (idKEEP(375).EQ.1) THEN MEMORY_SENT=dble(LA) ENDIF TAB_MAXS(MYID)=int(MEMORY_SENT,8) CALL MUMPS_BUF_BROADCAST( WHAT, & COMM_LD, NPROCS, & FUTURE_NIV2, & MEMORY_SENT, & dble(0),MYID, idKEEP(267), IERR ) ENDIF RETURN END SUBROUTINE MUMPS_LOAD_INIT SUBROUTINE MUMPS_LOAD_UPDATE( CHECK_FLOPS,PROCESS_BANDE, & INC_LOAD, KEEP,KEEP8 ) USE MUMPS_BUF_COMMON USE MUMPS_FUTURE_NIV2 IMPLICIT NONE DOUBLE PRECISION INC_LOAD INTEGER KEEP(500) INTEGER(8) KEEP8(150) LOGICAL PROCESS_BANDE LOGICAL :: EXIT_FLAG INTEGER CHECK_FLOPS INTEGER IERR DOUBLE PRECISION ZERO, SEND_MEM, SEND_LOAD,SBTR_TMP PARAMETER( ZERO=0.0d0 ) INTRINSIC max IF (.NOT. IS_MUMPS_LOAD_ENABLED) RETURN IF (INC_LOAD == 0.0D0) THEN IF(REMOVE_NODE_FLAG)THEN REMOVE_NODE_FLAG=.FALSE. ENDIF RETURN ENDIF IF((CHECK_FLOPS.NE.0).AND. & (CHECK_FLOPS.NE.1).AND.(CHECK_FLOPS.NE.2))THEN WRITE(*,*)MYID,': Bad value for CHECK_FLOPS' CALL MUMPS_ABORT() ENDIF IF(CHECK_FLOPS.EQ.1)THEN CHK_LD=CHK_LD+INC_LOAD ELSE IF(CHECK_FLOPS.EQ.2)THEN RETURN ENDIF ENDIF IF ( PROCESS_BANDE ) THEN RETURN ENDIF LOAD_FLOPS( MYID ) = max( LOAD_FLOPS( MYID ) + INC_LOAD, ZERO) IF(BDC_M2_FLOPS.AND.REMOVE_NODE_FLAG)THEN IF(INC_LOAD.NE.REMOVE_NODE_COST)THEN IF(INC_LOAD.GT.REMOVE_NODE_COST)THEN DELTA_LOAD = DELTA_LOAD + & (INC_LOAD-REMOVE_NODE_COST) GOTO 888 ELSE DELTA_LOAD = DELTA_LOAD - & (REMOVE_NODE_COST-INC_LOAD) GOTO 888 ENDIF ENDIF GOTO 333 ENDIF DELTA_LOAD = DELTA_LOAD + INC_LOAD 888 CONTINUE IF ( DELTA_LOAD > MIN_DIFF .OR. DELTA_LOAD < -MIN_DIFF) THEN SEND_LOAD = DELTA_LOAD IF (BDC_MEM) THEN SEND_MEM = DELTA_MEM ELSE SEND_MEM = ZERO END IF IF(BDC_SBTR)THEN SBTR_TMP=SBTR_CUR(MYID) ELSE SBTR_TMP=dble(0) ENDIF 111 CONTINUE CALL MUMPS_BUF_SEND_UPDATE_LOAD( BDC_SBTR,BDC_MEM, & BDC_MD,COMM_LD, NPROCS, & SEND_LOAD, & SEND_MEM,SBTR_TMP, & DM_SUMLU, & FUTURE_NIV2, & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL MUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 333 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE.0 ) THEN WRITE(*,*) "Internal Error in MUMPS_LOAD_UPDATE",IERR CALL MUMPS_ABORT() ENDIF DELTA_LOAD = ZERO IF (BDC_MEM) DELTA_MEM = ZERO ENDIF 333 CONTINUE IF(REMOVE_NODE_FLAG)THEN REMOVE_NODE_FLAG=.FALSE. ENDIF RETURN END SUBROUTINE MUMPS_LOAD_UPDATE SUBROUTINE MUMPS_LOAD_MEM_UPDATE( SSARBR, & PROCESS_BANDE_ARG, MEM_VALUE, NEW_LU, INC_MEM_ARG, & KEEP,KEEP8,LRLUS) USE MUMPS_BUF_COMMON USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_VALUE, INC_MEM_ARG, NEW_LU,LRLUS LOGICAL, INTENT(IN) :: PROCESS_BANDE_ARG, SSARBR INTEGER IERR, KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION ZERO, SEND_MEM, SBTR_TMP PARAMETER( ZERO=0.0d0 ) INTRINSIC max, abs INTEGER(8) :: INC_MEM LOGICAL PROCESS_BANDE LOGICAL :: EXIT_FLAG IF (.NOT. IS_MUMPS_LOAD_ENABLED) RETURN PROCESS_BANDE=PROCESS_BANDE_ARG INC_MEM = INC_MEM_ARG IF ( PROCESS_BANDE .AND. NEW_LU .NE. 0_8) THEN WRITE(*,*) " Internal Error in MUMPS_LOAD_MEM_UPDATE." WRITE(*,*) " NEW_LU must be zero if called from PROCESS_BANDE" CALL MUMPS_ABORT() ENDIF DM_SUMLU = DM_SUMLU + dble(NEW_LU) IF(KEEP_LOAD(201).EQ.0)THEN CHECK_MEM = CHECK_MEM + INC_MEM ELSE CHECK_MEM = CHECK_MEM + INC_MEM - NEW_LU ENDIF IF ( MEM_VALUE .NE. CHECK_MEM ) THEN WRITE(*,*)MYID, & ':Problem with increments in MUMPS_LOAD_MEM_UPDATE', & CHECK_MEM, MEM_VALUE, INC_MEM,NEW_LU CALL MUMPS_ABORT() ENDIF IF (PROCESS_BANDE) THEN RETURN ENDIF IF(BDC_POOL_MNG) THEN IF(SBTR_WHICH_M.EQ.0)THEN IF (SSARBR) SBTR_CUR_LOCAL = SBTR_CUR_LOCAL+ & dble(INC_MEM-NEW_LU) ELSE IF (SSARBR) SBTR_CUR_LOCAL = SBTR_CUR_LOCAL+ & dble(INC_MEM) ENDIF ENDIF IF ( .NOT. BDC_MEM ) THEN RETURN ENDIF IF (BDC_SBTR .AND. SSARBR) THEN IF((SBTR_WHICH_M.EQ.0).AND.(KEEP(201).NE.0))THEN SBTR_CUR(MYID) = SBTR_CUR(MYID)+dble(INC_MEM-NEW_LU) ELSE SBTR_CUR(MYID) = SBTR_CUR(MYID)+dble(INC_MEM) ENDIF SBTR_TMP = SBTR_CUR(MYID) ELSE SBTR_TMP=dble(0) ENDIF IF ( NEW_LU > 0_8 ) THEN INC_MEM = INC_MEM - NEW_LU ENDIF DM_MEM( MYID ) = DM_MEM(MYID) + dble(INC_MEM) MAX_PEAK_STK=max(MAX_PEAK_STK,DM_MEM(MYID)) IF(BDC_M2_MEM.AND.REMOVE_NODE_FLAG_MEM)THEN IF(dble(INC_MEM).NE.REMOVE_NODE_COST_MEM)THEN IF(dble(INC_MEM).GT.REMOVE_NODE_COST_MEM)THEN DELTA_MEM = DELTA_MEM + & (dble(INC_MEM)-REMOVE_NODE_COST_MEM) GOTO 888 ELSE DELTA_MEM = DELTA_MEM - & (REMOVE_NODE_COST_MEM-dble(INC_MEM)) GOTO 888 ENDIF ENDIF GOTO 333 ENDIF DELTA_MEM = DELTA_MEM + dble(INC_MEM) 888 CONTINUE IF ((KEEP(48).NE.5).OR. & ((KEEP(48).EQ.5).AND.(abs(DELTA_MEM) & .GE.0.2d0*dble(LRLUS))))THEN IF ( abs(DELTA_MEM) > DM_THRES_MEM ) THEN SEND_MEM = DELTA_MEM 111 CONTINUE CALL MUMPS_BUF_SEND_UPDATE_LOAD( & BDC_SBTR, & BDC_MEM,BDC_MD, COMM_LD, & NPROCS, & DELTA_LOAD, & SEND_MEM,SBTR_TMP, & DM_SUMLU, & FUTURE_NIV2, & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL MUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 333 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in MUMPS_LOAD_MEM_UPDATE",IERR CALL MUMPS_ABORT() ENDIF DELTA_LOAD = ZERO DELTA_MEM = ZERO ENDIF ENDIF 333 CONTINUE IF(REMOVE_NODE_FLAG_MEM)THEN REMOVE_NODE_FLAG_MEM=.FALSE. ENDIF END SUBROUTINE MUMPS_LOAD_MEM_UPDATE INTEGER FUNCTION MUMPS_LOAD_LESS( K69, MEM_DISTRIB,MSG_SIZE ) IMPLICIT NONE INTEGER i, NLESS, K69 INTEGER, DIMENSION(0:NPROCS-1) :: MEM_DISTRIB DOUBLE PRECISION LREF DOUBLE PRECISION MSG_SIZE NLESS = 0 DO i=1,NPROCS IDWLOAD(i) = i - 1 ENDDO WLOAD(1:NPROCS) = LOAD_FLOPS(0:NPROCS-1) IF(BDC_M2_FLOPS)THEN DO i=1,NPROCS WLOAD(i)=WLOAD(i)+NIV2(i) ENDDO ENDIF IF(K69 .gt. 1) THEN CALL CMUMPS_ARCHGENWLOAD(MEM_DISTRIB,MSG_SIZE,IDWLOAD,NPROCS) ENDIF LREF = LOAD_FLOPS(MYID) DO i=1, NPROCS IF (WLOAD(i).LT.LREF) NLESS=NLESS+1 ENDDO MUMPS_LOAD_LESS = NLESS RETURN END FUNCTION MUMPS_LOAD_LESS SUBROUTINE MUMPS_LOAD_SET_SLAVES(MEM_DISTRIB,MSG_SIZE,DEST, & NSLAVES) IMPLICIT NONE INTEGER NSLAVES INTEGER DEST(NSLAVES) INTEGER, DIMENSION(0:NPROCS - 1) :: MEM_DISTRIB INTEGER i,J,NBDEST DOUBLE PRECISION MSG_SIZE IF ( NSLAVES.eq.NPROCS-1 ) THEN J = MYID+1 DO i=1,NSLAVES J=J+1 IF (J.GT.NPROCS) J=1 DEST(i) = J - 1 ENDDO ELSE DO i=1,NPROCS IDWLOAD(i) = i - 1 ENDDO CALL MUMPS_SORT_DOUBLES(NPROCS, WLOAD, IDWLOAD) NBDEST = 0 DO i=1, NSLAVES J = IDWLOAD(i) IF (J.NE.MYID) THEN NBDEST = NBDEST+1 DEST(NBDEST) = J ENDIF ENDDO IF (NBDEST.NE.NSLAVES) THEN DEST(NSLAVES) = IDWLOAD(NSLAVES+1) ENDIF IF(BDC_MD)THEN J=NSLAVES+1 do i=NSLAVES+1,NPROCS IF(IDWLOAD(i).NE.MYID)THEN DEST(J)= IDWLOAD(i) J=J+1 ENDIF end do ENDIF ENDIF RETURN END SUBROUTINE MUMPS_LOAD_SET_SLAVES SUBROUTINE MUMPS_LOAD_END( INFO1, NSLAVES, IERR ) USE MUMPS_BUF_COMMON USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER, INTENT(IN) :: INFO1 INTEGER, INTENT(IN) :: NSLAVES INTEGER, INTENT(OUT) :: IERR INTEGER :: DUMMY_COMMUNICATOR IERR=0 DUMMY_COMMUNICATOR = -999 CALL MUMPS_CLEAN_PENDING( INFO1, KEEP_LOAD(1), BUF_LOAD_RECV(1), & LBUF_LOAD_RECV, & LBUF_LOAD_RECV_BYTES, DUMMY_COMMUNICATOR, COMM_LD, & NSLAVES, & .FALSE., & .TRUE. & ) DEALLOCATE( LOAD_FLOPS ) DEALLOCATE( WLOAD ) DEALLOCATE( IDWLOAD ) DEALLOCATE(FUTURE_NIV2) IF(BDC_MD)THEN DEALLOCATE(MD_MEM) DEALLOCATE(LU_USAGE) DEALLOCATE(TAB_MAXS) ENDIF IF ( BDC_MEM ) DEALLOCATE( DM_MEM ) IF ( BDC_POOL) DEALLOCATE( POOL_MEM ) IF ( BDC_SBTR) THEN DEALLOCATE( SBTR_MEM ) DEALLOCATE( SBTR_CUR ) DEALLOCATE(SBTR_FIRST_POS_IN_POOL) NULLIFY(MY_FIRST_LEAF) NULLIFY(MY_NB_LEAF) NULLIFY(MY_ROOT_SBTR) ENDIF IF(KEEP_LOAD(76).EQ.4)THEN NULLIFY(DEPTH_FIRST_LOAD) ENDIF IF(KEEP_LOAD(76).EQ.5)THEN NULLIFY(COST_TRAV) ENDIF IF((KEEP_LOAD(76).EQ.4).OR.(KEEP_LOAD(76).EQ.6))THEN NULLIFY(DEPTH_FIRST_LOAD) NULLIFY(DEPTH_FIRST_SEQ_LOAD) NULLIFY(SBTR_ID_LOAD) ENDIF IF (BDC_M2_MEM.OR.BDC_M2_FLOPS) THEN DEALLOCATE(NB_SON,POOL_NIV2,POOL_NIV2_COST, NIV2) END IF IF((KEEP_LOAD(81).EQ.2).OR.(KEEP_LOAD(81).EQ.3))THEN DEALLOCATE(CB_COST_MEM) DEALLOCATE(CB_COST_ID) ENDIF NULLIFY(ND_LOAD) NULLIFY(KEEP_LOAD) NULLIFY(KEEP8_LOAD) NULLIFY(FILS_LOAD) NULLIFY(FRERE_LOAD) NULLIFY(PROCNODE_LOAD) NULLIFY(STEP_LOAD) NULLIFY(NE_LOAD) NULLIFY(CAND_LOAD) NULLIFY(STEP_TO_NIV2_LOAD) NULLIFY(DAD_LOAD) IF (BDC_SBTR.OR.BDC_POOL_MNG) THEN DEALLOCATE(MEM_SUBTREE) DEALLOCATE(SBTR_PEAK_ARRAY) DEALLOCATE(SBTR_CUR_ARRAY) ENDIF CALL MUMPS_BUF_DEALL_LOAD_BUFFER( IERR ) DEALLOCATE(BUF_LOAD_RECV) RETURN END SUBROUTINE MUMPS_LOAD_END RECURSIVE SUBROUTINE MUMPS_LOAD_RECV_MSGS(COMM) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGTAG, MSGLEN, MSGSOU,COMM INTEGER IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL FLAG 10 CONTINUE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR_MPI ) IF (FLAG) THEN KEEP_LOAD(65)=KEEP_LOAD(65)+1 KEEP_LOAD(267)=KEEP_LOAD(267)-1 MSGTAG = STATUS( MPI_TAG ) MSGSOU = STATUS( MPI_SOURCE ) IF ( MSGTAG .NE. UPDATE_LOAD) THEN write(*,*) "Internal error 1 in MUMPS_LOAD_RECV_MSGS", & MSGTAG CALL MUMPS_ABORT() ENDIF CALL MPI_GET_COUNT(STATUS, MPI_PACKED, MSGLEN, IERR_MPI) IF ( MSGLEN > LBUF_LOAD_RECV_BYTES ) THEN write(*,*) "Internal error 2 in MUMPS_LOAD_RECV_MSGS", & MSGLEN, LBUF_LOAD_RECV_BYTES CALL MUMPS_ABORT() ENDIF CALL MPI_RECV( BUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES, & MPI_PACKED, MSGSOU, MSGTAG, COMM_LD, STATUS, IERR_MPI) CALL MUMPS_LOAD_PROCESS_MESSAGE( MSGSOU, BUF_LOAD_RECV, & LBUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES ) GOTO 10 ENDIF RETURN END SUBROUTINE MUMPS_LOAD_RECV_MSGS RECURSIVE SUBROUTINE MUMPS_LOAD_PROCESS_MESSAGE & ( MSGSOU, BUFR, LBUFR, LBUFR_BYTES ) USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER MSGSOU, LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INCLUDE 'mpif.h' INTEGER POSITION, WHAT, NSLAVES, i INTEGER IERR_MPI DOUBLE PRECISION LOAD_RECEIVED INTEGER INODE_RECEIVED,NCB_RECEIVED DOUBLE PRECISION SURF INTEGER, POINTER, DIMENSION (:) :: LIST_SLAVES DOUBLE PRECISION, POINTER, DIMENSION (:) :: LOAD_INCR EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WHAT, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) IF ( WHAT == 0 ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) DM_MEM(MSGSOU) = DM_MEM(MSGSOU) + LOAD_RECEIVED MAX_PEAK_STK=max(MAX_PEAK_STK,DM_MEM(MSGSOU)) END IF IF(BDC_SBTR)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) SBTR_CUR(MSGSOU)=LOAD_RECEIVED ENDIF IF(BDC_MD)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(KEEP_LOAD(201).EQ.0)THEN LU_USAGE(MSGSOU)=LOAD_RECEIVED ENDIF ENDIF ELSEIF (( WHAT == 1).OR.(WHAT.EQ.19)) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR_MPI) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI) DO i = 1, NSLAVES LOAD_FLOPS(LIST_SLAVES(i)) = & LOAD_FLOPS(LIST_SLAVES(i)) + & LOAD_INCR(i) END DO IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI) DO i = 1, NSLAVES DM_MEM(LIST_SLAVES(i)) = DM_MEM(LIST_SLAVES(i)) + & LOAD_INCR(i) MAX_PEAK_STK=max(MAX_PEAK_STK,DM_MEM(LIST_SLAVES(i))) END DO END IF IF(WHAT.EQ.19)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI) CALL MUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE_RECEIVED) CB_COST_ID(POS_ID)=INODE_RECEIVED CB_COST_ID(POS_ID+1)=NSLAVES CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 DO i=1,NSLAVES WRITE(*,*)MYID,':',LIST_SLAVES(i),'->',LOAD_INCR(i) CB_COST_MEM(POS_MEM)=int(LIST_SLAVES(i),8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(LOAD_INCR(i),8) POS_MEM=POS_MEM+1 ENDDO ENDIF NULLIFY( LIST_SLAVES ) NULLIFY( LOAD_INCR ) ELSE IF (WHAT == 2 ) THEN IF ( .not. BDC_POOL ) THEN WRITE(*,*) "Internal error 2 in MUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() END IF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) POOL_MEM(MSGSOU)=LOAD_RECEIVED ELSE IF ( WHAT == 3 ) THEN IF ( .NOT. BDC_SBTR) THEN WRITE(*,*) "Internal error 3 in MUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) SBTR_MEM(MSGSOU)=SBTR_MEM(MSGSOU)+LOAD_RECEIVED ELSE IF (WHAT == 4) THEN FUTURE_NIV2(MSGSOU+1)=0 IF(BDC_MD)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SURF, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) MD_MEM(MSGSOU)=999999999_8 TAB_MAXS(MSGSOU)=TAB_MAXS(MSGSOU)+int(SURF,8) ENDIF IF(BDC_M2_MEM.OR.BDC_M2_FLOPS)THEN ENDIF ELSE IF (WHAT == 5) THEN IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*) "Internal error 7 in MUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR_MPI ) IF(BDC_M2_MEM) THEN CALL MUMPS_PROCESS_NIV2_MEM_MSG(INODE_RECEIVED) ELSEIF(BDC_M2_FLOPS) THEN CALL MUMPS_PROCESS_NIV2_FLOPS_MSG(INODE_RECEIVED) ENDIF IF((KEEP_LOAD(81).EQ.2).OR.(KEEP_LOAD(81).EQ.3))THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR_MPI ) IF( & MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE_RECEIVED)), & KEEP_LOAD(199)).EQ.1 & )THEN CB_COST_ID(POS_ID)=INODE_RECEIVED CB_COST_ID(POS_ID+1)=1 CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 CB_COST_MEM(POS_MEM)=int(MSGSOU,8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(NCB_RECEIVED,8)* & int(NCB_RECEIVED,8) POS_MEM=POS_MEM+1 ENDIF ENDIF ELSE IF ( WHAT == 6 ) THEN IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*) "Internal error 8 in MUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(BDC_M2_MEM) THEN NIV2(MSGSOU+1) = LOAD_RECEIVED ELSEIF(BDC_M2_FLOPS) THEN NIV2(MSGSOU+1) = NIV2(MSGSOU+1) + LOAD_RECEIVED IF(NIV2(MSGSOU+1).LT.0.0D0)THEN IF(abs(NIV2(MSGSOU+1)) .LE. 1.0D-3) THEN NIV2(MSGSOU+1)=0.0D0 ELSE WRITE(*,*)'problem with NIV2_FLOPS message', & NIV2(MSGSOU+1),MSGSOU,LOAD_RECEIVED CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ELSEIF(WHAT == 17)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(BDC_M2_MEM) THEN NIV2(MSGSOU+1) = LOAD_RECEIVED CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(BDC_MD)THEN DM_MEM(MYID)=DM_MEM(MYID)+LOAD_RECEIVED ELSEIF(BDC_POOL)THEN POOL_MEM(MSGSOU)=LOAD_RECEIVED ENDIF ELSEIF(BDC_M2_FLOPS) THEN NIV2(MSGSOU+1) = NIV2(MSGSOU+1) + LOAD_RECEIVED IF(NIV2(MSGSOU+1).LT.0.0D0)THEN IF(abs(NIV2(MSGSOU+1)) .LE. 1.0D-3) THEN NIV2(MSGSOU+1)=0.0D0 ELSE WRITE(*,*)'problem with NIV2_FLOPS message', & NIV2(MSGSOU+1),MSGSOU,LOAD_RECEIVED CALL MUMPS_ABORT() ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED ENDIF ELSEIF ( WHAT == 7 ) THEN IF(.NOT.BDC_MD)THEN WRITE(*,*)MYID,': Internal error 4 &in MUMPS_LOAD_PROCESS_MESSAGE' CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) DO i = 1, NSLAVES MD_MEM(LIST_SLAVES(i)) = & MD_MEM(LIST_SLAVES(i)) + & int(LOAD_INCR(i),8) IF(FUTURE_NIV2(LIST_SLAVES(i)+1).EQ.0)THEN MD_MEM(LIST_SLAVES(i))=999999999_8 ENDIF END DO ELSEIF ( WHAT == 8 ) THEN IF(.NOT.BDC_MD)THEN WRITE(*,*)MYID,': Internal error 5 &in MUMPS_LOAD_PROCESS_MESSAGE' CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) MD_MEM(MSGSOU)=MD_MEM(MSGSOU)+int(LOAD_RECEIVED,8) IF(FUTURE_NIV2(MSGSOU+1).EQ.0)THEN MD_MEM(MSGSOU)=999999999_8 ENDIF ELSEIF ( WHAT == 9 ) THEN IF(.NOT.BDC_MD)THEN WRITE(*,*)MYID,': Internal error 6 &in MUMPS_LOAD_PROCESS_MESSAGE' CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) TAB_MAXS(MSGSOU)=int(LOAD_RECEIVED,8) ELSE WRITE(*,*) "Internal error 1 in MUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE MUMPS_LOAD_PROCESS_MESSAGE integer function MUMPS_LOAD_LESS_CAND & (MEM_DISTRIB,CAND, & K69, & SLAVEF,MSG_SIZE, & NMB_OF_CAND ) implicit none integer, intent(in) :: K69, SLAVEF INTEGER, intent(in) :: CAND(SLAVEF+1) INTEGER, DIMENSION(0:NPROCS - 1), intent(in) :: MEM_DISTRIB INTEGER, intent(out) :: NMB_OF_CAND integer i,nless DOUBLE PRECISION lref DOUBLE PRECISION MSG_SIZE nless = 0 NMB_OF_CAND=CAND(SLAVEF+1) do i=1,NMB_OF_CAND WLOAD(i)=LOAD_FLOPS(CAND(i)) IF(BDC_M2_FLOPS)THEN WLOAD(i)=WLOAD(i)+NIV2(CAND(i)+1) ENDIF end do IF(K69 .gt. 1) THEN CALL CMUMPS_ARCHGENWLOAD(MEM_DISTRIB,MSG_SIZE, & CAND,NMB_OF_CAND) ENDIF lref = LOAD_FLOPS(MYID) do i=1, NMB_OF_CAND if (WLOAD(i).lt.lref) nless=nless+1 end do MUMPS_LOAD_LESS_CAND = nless return end function MUMPS_LOAD_LESS_CAND subroutine MUMPS_LOAD_SET_SLAVES_CAND & (MEM_DISTRIB,CAND, & & SLAVEF, & nslaves_inode, DEST) implicit none integer, intent(in) :: nslaves_inode, SLAVEF integer, intent(in) :: CAND(SLAVEF+1) integer, dimension(0:NPROCS - 1), intent(in) :: MEM_DISTRIB integer, intent(out) :: DEST(CAND(SLAVEF+1)) integer i,j,NMB_OF_CAND external MUMPS_SORT_DOUBLES NMB_OF_CAND = CAND(SLAVEF+1) if(nslaves_inode.ge.NPROCS .or. & nslaves_inode.gt.NMB_OF_CAND) then write(*,*)'Internal error in MUMPS_LOAD_SET_SLAVES_CAND', & nslaves_inode, NPROCS, NMB_OF_CAND CALL MUMPS_ABORT() end if if (nslaves_inode.eq.NPROCS-1) then j=MYID+1 do i=1,nslaves_inode if(j.ge.NPROCS) j=0 DEST(i)=j j=j+1 end do else do i=1,NMB_OF_CAND IDWLOAD(i)=i end do call MUMPS_SORT_DOUBLES(NMB_OF_CAND, & WLOAD(1),IDWLOAD(1) ) do i=1,nslaves_inode DEST(i)= CAND(IDWLOAD(i)) end do IF(BDC_MD)THEN do i=nslaves_inode+1,NMB_OF_CAND DEST(i)= CAND(IDWLOAD(i)) end do ENDIF end if return end subroutine MUMPS_LOAD_SET_SLAVES_CAND SUBROUTINE CMUMPS_INIT_ALPHA_BETA(K69) IMPLICIT NONE INTEGER K69 IF (K69 .LE. 4) THEN ALPHA = 0.0d0 BETA = 0.0d0 RETURN ENDIF IF (K69 .EQ. 5) THEN ALPHA = 0.5d0 BETA = 50000.0d0 RETURN ENDIF IF (K69 .EQ. 6) THEN ALPHA = 0.5d0 BETA = 100000.0d0 RETURN ENDIF IF (K69 .EQ. 7) THEN ALPHA = 0.5d0 BETA = 150000.0d0 RETURN ENDIF IF (K69 .EQ. 8) THEN ALPHA = 1.0d0 BETA = 50000.0d0 RETURN ENDIF IF (K69 .EQ. 9) THEN ALPHA = 1.0d0 BETA = 100000.0d0 RETURN ENDIF IF (K69 .EQ. 10) THEN ALPHA = 1.0d0 BETA = 150000.0d0 RETURN ENDIF IF (K69 .EQ. 11) THEN ALPHA = 1.5d0 BETA = 50000.0d0 RETURN ENDIF IF (K69 .EQ. 12) THEN ALPHA = 1.5d0 BETA = 100000.0d0 RETURN ENDIF ALPHA = 1.5d0 BETA = 150000.0d0 RETURN END SUBROUTINE CMUMPS_INIT_ALPHA_BETA SUBROUTINE CMUMPS_ARCHGENWLOAD(MEM_DISTRIB,MSG_SIZE,ARRAY_ADM,LEN) IMPLICIT NONE INTEGER i,LEN INTEGER, DIMENSION(0:NPROCS-1) :: MEM_DISTRIB DOUBLE PRECISION MSG_SIZE,FORBIGMSG INTEGER ARRAY_ADM(LEN) DOUBLE PRECISION MY_LOAD FORBIGMSG = 1.0d0 IF (K69 .lt.2) THEN RETURN ENDIF IF(BDC_M2_FLOPS)THEN MY_LOAD=LOAD_FLOPS(MYID)+NIV2(MYID+1) ELSE MY_LOAD=LOAD_FLOPS(MYID) ENDIF IF((MSG_SIZE * dble(K35) ) .gt. 3200000.0d0) THEN FORBIGMSG = 2.0d0 ENDIF IF (K69 .le. 4) THEN DO i = 1,LEN IF ((MEM_DISTRIB(ARRAY_ADM(i)) .EQ. 1) .AND. & WLOAD(i) .LT. MY_LOAD ) THEN WLOAD(i) = WLOAD(i)/MY_LOAD ELSE IF ( MEM_DISTRIB(ARRAY_ADM(i)) .NE. 1 ) THEN WLOAD(i) = WLOAD(i) * & dble(MEM_DISTRIB(ARRAY_ADM(i))) & * FORBIGMSG & + dble(2) ENDIF ENDIF ENDDO RETURN ENDIF DO i = 1,LEN IF ((MEM_DISTRIB(ARRAY_ADM(i)) .EQ. 1) .AND. & WLOAD(i) .LT. MY_LOAD ) THEN WLOAD(i) = WLOAD(i) / MY_LOAD ELSE IF(MEM_DISTRIB(ARRAY_ADM(i)) .NE. 1) THEN WLOAD(i) = (WLOAD(i) + & ALPHA * MSG_SIZE * dble(K35) + & BETA) * FORBIGMSG ENDIF ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_ARCHGENWLOAD SUBROUTINE MUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, NSLAVES,INODE) USE MUMPS_BUF_COMMON USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER, INTENT (IN) :: MYID, SLAVEF, COMM, NASS, NSLAVES INTEGER, INTENT (IN) :: TAB_POS(SLAVEF+2) INTEGER, INTENT (IN) :: LIST_SLAVES( NSLAVES ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER NCB, NFRONT, NBROWS_SLAVE INTEGER i, IERR,WHAT,INODE, allocok LOGICAL :: EXIT_FLAG DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: MEM_INCREMENT DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: FLOPS_INCREMENT DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: CB_BAND ALLOCATE(MEM_INCREMENT(NSLAVES), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of MEM_INCREMENT ' & // 'in routine MUMPS_LOAD_MASTER_2_ALL' CALL MUMPS_ABORT() endif ALLOCATE(FLOPS_INCREMENT(NSLAVES), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of FLOPS_INCREMENT ' & // 'in routine MUMPS_LOAD_MASTER_2_ALL' CALL MUMPS_ABORT() endif ALLOCATE(CB_BAND(NSLAVES), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of CB_BAND ' & // 'in routine MUMPS_LOAD_MASTER_2_ALL' CALL MUMPS_ABORT() endif IF((KEEP(81).NE.2).AND.(KEEP(81).NE.3))THEN WHAT=1 ELSE WHAT=19 ENDIF FUTURE_NIV2(MYID+1) = FUTURE_NIV2(MYID+1) - 1 IF ( FUTURE_NIV2(MYID+1) < 0 ) THEN WRITE(*,*) "Internal error in MUMPS_LOAD_MASTER_2_ALL" CALL MUMPS_ABORT() ENDIF IF ( FUTURE_NIV2(MYID + 1) == 0 ) THEN 112 CONTINUE CALL MUMPS_BUF_SEND_NOT_MSTR(COMM,MYID,SLAVEF, & dble(MAX_SURF_MASTER),KEEP,IERR) IF (IERR == -1 ) THEN CALL MUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 112 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in MUMPS_LOAD_MASTER_2_ALL", & IERR CALL MUMPS_ABORT() ENDIF TAB_MAXS(MYID) = TAB_MAXS(MYID) + int(MAX_SURF_MASTER,8) ENDIF IF ( NSLAVES /= TAB_POS(SLAVEF + 2) ) THEN write(*,*) "Error 1 in MUMPS_LOAD_MASTER_2_ALL", & NSLAVES, TAB_POS(SLAVEF+2) CALL MUMPS_ABORT() ENDIF NCB = TAB_POS(NSLAVES+1) - 1 NFRONT = NCB + NASS DO i = 1, NSLAVES NBROWS_SLAVE = TAB_POS(i+1) - TAB_POS(i) IF ( KEEP(50) == 0 ) THEN FLOPS_INCREMENT( i ) = (dble(NBROWS_SLAVE)*dble( NASS ))+ & dble(NBROWS_SLAVE) * dble(NASS) * & dble(2*NFRONT-NASS-1) ELSE FLOPS_INCREMENT( i ) = dble(NBROWS_SLAVE) * dble(NASS ) * & dble( 2 * ( NASS + TAB_POS(i+1) - 1 ) & - NBROWS_SLAVE - NASS + 1 ) ENDIF IF ( BDC_MEM ) THEN IF ( KEEP(50) == 0 ) THEN MEM_INCREMENT( i ) = dble(NBROWS_SLAVE) * & dble(NFRONT) ELSE MEM_INCREMENT( i ) = dble(NBROWS_SLAVE) * & dble( NASS + TAB_POS(i+1) - 1 ) END IF ENDIF IF((KEEP(81).NE.2).AND.(KEEP(81).NE.3))THEN CB_BAND(i)=dble(-999999) ELSE IF ( KEEP(50) == 0 ) THEN CB_BAND( i ) = dble(NBROWS_SLAVE) * & dble(NFRONT-NASS) ELSE CB_BAND( i ) = dble(NBROWS_SLAVE) * & dble(TAB_POS(i+1)-1) END IF ENDIF END DO IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN CB_COST_ID(POS_ID)=INODE CB_COST_ID(POS_ID+1)=NSLAVES CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 DO i=1,NSLAVES CB_COST_MEM(POS_MEM)=int(LIST_SLAVES(i),8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(CB_BAND(i),8) POS_MEM=POS_MEM+1 ENDDO ENDIF 111 CONTINUE CALL MUMPS_BUF_BCAST_ARRAY(BDC_MEM, COMM, MYID, SLAVEF, & FUTURE_NIV2, & NSLAVES, LIST_SLAVES,INODE, & MEM_INCREMENT, & FLOPS_INCREMENT,CB_BAND, WHAT, KEEP, IERR) IF ( IERR == -1 ) THEN CALL MUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in MUMPS_LOAD_MASTER_2_ALL", & IERR CALL MUMPS_ABORT() ENDIF IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN DO i = 1, NSLAVES LOAD_FLOPS(LIST_SLAVES(i)) = LOAD_FLOPS(LIST_SLAVES(i)) & + FLOPS_INCREMENT(i) IF ( BDC_MEM ) THEN DM_MEM(LIST_SLAVES(i)) = DM_MEM(LIST_SLAVES(i)) & + MEM_INCREMENT(i) END IF ENDDO ENDIF 100 CONTINUE DEALLOCATE(MEM_INCREMENT,FLOPS_INCREMENT,CB_BAND) RETURN END SUBROUTINE MUMPS_LOAD_MASTER_2_ALL SUBROUTINE MUMPS_LOAD_POOL_UPD_NEW_POOL( & POOL, LPOOL, & PROCNODE, KEEP,KEEP8, SLAVEF, COMM, MYID, STEP, N, & ND, FILS ) USE MUMPS_BUF_COMMON USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER LPOOL, SLAVEF, COMM, MYID INTEGER N, KEEP(500) INTEGER(8) KEEP8(150) INTEGER POOL( LPOOL ), PROCNODE( KEEP(28) ), STEP( N ) INTEGER ND( KEEP(28) ), FILS( N ) INTEGER i, INODE, NELIM, NFR, LEVEL, IERR, WHAT DOUBLE PRECISION COST LOGICAL :: EXIT_FLAG INTEGER NBINSUBTREE,NBTOP,INSUBTREE INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF(BDC_MD)THEN RETURN ENDIF IF((KEEP(76).EQ.0).OR.(KEEP(76).EQ.2))THEN IF(NBTOP.NE.0)THEN DO i = LPOOL-NBTOP-2, min(LPOOL-3,LPOOL-NBTOP-2+3) INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ELSE DO i = NBINSUBTREE, max(1,NBINSUBTREE-3), -1 INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ENDIF ELSE IF(KEEP(76).EQ.1)THEN IF(INSUBTREE.EQ.1)THEN DO i = NBINSUBTREE, max(1,NBINSUBTREE-3), -1 INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ELSE DO i = LPOOL-NBTOP-2, min(LPOOL-3,LPOOL-NBTOP-2+3) INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ENDIF ELSE WRITE(*,*) & 'Internal error: Unknown pool management strategy' CALL MUMPS_ABORT() ENDIF ENDIF 20 CONTINUE i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS(i) GOTO 10 ENDIF NFR = ND( STEP(INODE) ) LEVEL = MUMPS_TYPENODE( PROCNODE(STEP(INODE)), KEEP(199) ) IF (LEVEL .EQ. 1) THEN COST = dble( NFR ) * dble( NFR ) ELSE IF ( KEEP(50) == 0 ) THEN COST = dble( NFR ) * dble( NELIM ) ELSE COST = dble( NELIM ) * dble( NELIM ) ENDIF ENDIF 30 CONTINUE IF ( abs(POOL_LAST_COST_SENT-COST).GT.DM_THRES_MEM ) THEN WHAT = 2 111 CONTINUE CALL MUMPS_BUF_BROADCAST( WHAT, & COMM, SLAVEF, & FUTURE_NIV2, & COST, dble(0), MYID, KEEP(267), IERR ) POOL_LAST_COST_SENT = COST POOL_MEM(MYID)=COST IF ( IERR == -1 )THEN CALL MUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in MUMPS_LOAD_POOL_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF ENDIF RETURN END SUBROUTINE MUMPS_LOAD_POOL_UPD_NEW_POOL SUBROUTINE MUMPS_LOAD_SBTR_UPD_NEW_POOL( & OK,INODE,POOL,LPOOL,MYID,SLAVEF,COMM,KEEP,KEEP8) USE MUMPS_BUF_COMMON USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER LPOOL,MYID,SLAVEF,COMM,INODE INTEGER POOL(LPOOL),KEEP(500) INTEGER(8) KEEP8(150) INTEGER WHAT,IERR LOGICAL OK DOUBLE PRECISION COST LOGICAL FLAG, EXIT_FLAG EXTERNAL MUMPS_ROOTSSARBR,MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_ROOTSSARBR,MUMPS_IN_OR_ROOT_SSARBR IF((INODE.LE.0).OR.(INODE.GT.N_LOAD)) THEN RETURN ENDIF IF (.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_LOAD(STEP_LOAD(INODE)), KEEP(199)) & ) THEN RETURN ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP(199)))THEN IF(NE_LOAD(STEP_LOAD(INODE)).EQ.0)THEN RETURN ENDIF ENDIF FLAG=.FALSE. IF(INDICE_SBTR.LE.NB_SUBTREES)THEN IF(INODE.EQ.MY_FIRST_LEAF(INDICE_SBTR))THEN FLAG=.TRUE. ENDIF ENDIF IF(FLAG)THEN SBTR_PEAK_ARRAY(INDICE_SBTR_ARRAY)=MEM_SUBTREE(INDICE_SBTR) SBTR_CUR_ARRAY(INDICE_SBTR_ARRAY)=SBTR_CUR(MYID) INDICE_SBTR_ARRAY=INDICE_SBTR_ARRAY+1 WHAT = 3 IF(dble(MEM_SUBTREE(INDICE_SBTR)).GE.DM_THRES_MEM)THEN 111 CONTINUE CALL MUMPS_BUF_BROADCAST( & WHAT, COMM, SLAVEF, & FUTURE_NIV2, & dble(MEM_SUBTREE(INDICE_SBTR)), dble(0), & MYID, KEEP(267), IERR ) IF ( IERR == -1 )THEN CALL MUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 1 in MUMPS_LOAD_SBTR_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF ENDIF SBTR_MEM(MYID)=SBTR_MEM(MYID)+ & dble(MEM_SUBTREE(INDICE_SBTR)) INDICE_SBTR=INDICE_SBTR+1 IF(INSIDE_SUBTREE.EQ.0)THEN INSIDE_SUBTREE=1 ENDIF ELSE IF(INODE.EQ.MY_ROOT_SBTR(INDICE_SBTR-1))THEN WHAT = 3 COST=-SBTR_PEAK_ARRAY(INDICE_SBTR_ARRAY-1) IF(abs(COST).GE.DM_THRES_MEM)THEN 112 CONTINUE CALL MUMPS_BUF_BROADCAST( & WHAT, COMM, SLAVEF, & FUTURE_NIV2, & COST, dble(0), MYID, KEEP(267), IERR ) IF ( IERR == -1 )THEN CALL MUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN ELSE GOTO 112 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 3 in MUMPS_LOAD_SBTR_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF ENDIF INDICE_SBTR_ARRAY=INDICE_SBTR_ARRAY-1 SBTR_MEM(MYID)=SBTR_MEM(MYID)- & SBTR_PEAK_ARRAY(INDICE_SBTR_ARRAY) SBTR_CUR(MYID)=SBTR_CUR_ARRAY(INDICE_SBTR_ARRAY) IF(INDICE_SBTR_ARRAY.EQ.1)THEN SBTR_CUR(MYID)=dble(0) INSIDE_SUBTREE=0 ENDIF ENDIF ENDIF RETURN END SUBROUTINE MUMPS_LOAD_SBTR_UPD_NEW_POOL SUBROUTINE MUMPS_SET_PARTI_ACTV_MEM & (SLAVEF,KEEP,KEEP8,PROCS,MEM_DISTRIB,NCB,NFRONT, & NSLAVES_NODE,TAB_POS, & SLAVES_LIST,SIZE_SLAVES_LIST,MYID) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID INTEGER, intent(in) :: PROCS(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1) INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER NUMBER_OF_PROCS, 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 MUMPS_SET_PARTI_ACTV_MEM" CALL MUMPS_ABORT() ENDIF K821=abs(KEEP8(21)) DK821=dble(K821) K50=KEEP(50) K48=KEEP(48) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF IF(K48.NE.4)THEN WRITE(*,*)'CMUMPS_COMPUTE_PARTI_ACTV_MEM_K821 & should be called with KEEP(48) different from 4' CALL MUMPS_ABORT() ENDIF KMIN=1 KMAX=int(K821/int(NFRONT,8)) IF(FORCE_CAND)THEN DO i=1,PROCS(SLAVEF+1) WLOAD(i)=DM_MEM(PROCS(i)) IDWLOAD(i)=PROCS(i) ENDDO NUMBER_OF_PROCS=PROCS(SLAVEF+1) OTHERS=NUMBER_OF_PROCS ELSE NUMBER_OF_PROCS=SLAVEF WLOAD(1:SLAVEF) = DM_MEM(0:NUMBER_OF_PROCS-1) DO i=1,NUMBER_OF_PROCS IDWLOAD(i) = i - 1 ENDDO OTHERS=NUMBER_OF_PROCS-1 ENDIF NB_ROWS=0 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, IDWLOAD) TOTAL_MEM=int(NCB,8)*int(NFRONT,8) SOMME=dble(0) J=1 PEAK=dble(0) DO i=1,NUMBER_OF_PROCS IF((IDWLOAD(i).NE.MYID))THEN PEAK=max(PEAK,WLOAD(i)) TEMP_ID(J)=IDWLOAD(i) TEMP(J)=WLOAD(i) IF(BDC_SBTR)THEN TEMP(J)=TEMP(J)+SBTR_MEM(IDWLOAD(i))- & SBTR_CUR(IDWLOAD(i)) ENDIF IF(BDC_POOL)THEN TEMP(J)=TEMP(J)+POOL_MEM(TEMP_ID(J)) ENDIF IF(BDC_M2_MEM)THEN TEMP(J)=TEMP(J)+NIV2(TEMP_ID(J)+1) ENDIF J=J+1 ENDIF ENDDO NUMBER_OF_PROCS=J-1 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, TEMP, TEMP_ID) IF(K50.EQ.0)THEN PEAK=max(PEAK, & DM_MEM(MYID)+dble(NFRONT)*dble(NFRONT-NCB)) ELSE PEAK=max(PEAK, & DM_MEM(MYID)+dble(NFRONT-NCB)*dble(NFRONT-NCB)) ENDIF PEAK=max(PEAK,TEMP(OTHERS)) SOMME=dble(0) DO i=1,NUMBER_OF_PROCS SOMME=SOMME+TEMP(OTHERS)-TEMP(i) ENDDO IF(SOMME.LE.dble(TOTAL_MEM)) THEN GOTO 096 ENDIF 096 CONTINUE SOMME=dble(0) DO i=1,OTHERS SOMME=SOMME+TEMP(OTHERS)-TEMP(i) ENDDO IF(dble(TOTAL_MEM).GE.SOMME) THEN AFFECTED=0 CHOSEN=0 ACC=0 DO i=1,OTHERS IF(K50.EQ.0)THEN IF((TEMP(OTHERS)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(OTHERS)-TEMP(i) ENDIF X=int(TMP_SUM/dble(NFRONT)) IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN IF((TEMP(OTHERS)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(OTHERS)-TEMP(i) ENDIF X=int((-dble(NFRONT-NCB+ACC) & +sqrt(((dble(NFRONT-NCB+ACC)* & dble(NFRONT-NCB+ACC))+dble(4)* & (TMP_SUM))))/ & dble(2)) IF((ACC+X).GT.NCB) X=NCB-ACC IF(X.LE.0) THEN WRITE(*,*)"Internal Error 2 in & MUMPS_SET_PARTI_ACTV_MEM" CALL MUMPS_ABORT() ENDIF ENDIF NB_ROWS(i)=X CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB-ACC.LT.KMIN) GOTO 111 IF(NCB.EQ.ACC) GOTO 111 ENDDO 111 CONTINUE IF((ACC.GT.NCB))THEN X=0 DO i=1,OTHERS X=X+NB_ROWS(i) ENDDO WRITE(*,*)'NCB=',NCB,',SOMME=',X WRITE(*,*)MYID, & ": Internal Error 3 in MUMPS_SET_PARTI_ACTV_MEM" CALL MUMPS_ABORT() ENDIF IF((NCB.NE.ACC))THEN IF(K50.NE.0)THEN IF(CHOSEN.NE.0)THEN ADDITIONNAL_ROWS=NCB-ACC NB_ROWS(CHOSEN)=NB_ROWS(CHOSEN)+ADDITIONNAL_ROWS ELSE TMP_SUM=dble(TOTAL_MEM)/dble(NUMBER_OF_PROCS) CHOSEN=0 ACC=0 DO i=1,OTHERS X=int((-dble(NFRONT-NCB+ACC) & +sqrt(((dble(NFRONT-NCB+ACC)* & dble(NFRONT-NCB+ACC))+dble(4)* & (TMP_SUM))))/ & dble(2)) IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB-ACC.LT.KMIN) GOTO 002 IF(NCB.EQ.ACC) GOTO 002 ENDDO 002 CONTINUE IF(ACC.LT.NCB)THEN NB_ROWS(CHOSEN)=NB_ROWS(CHOSEN)+(NCB-ACC) ENDIF ENDIF GOTO 333 ENDIF ADDITIONNAL_ROWS=NCB-ACC DO i=CHOSEN,1,-1 IF(int(dble(ADDITIONNAL_ROWS)/ & dble(i)).NE.0)THEN GOTO 222 ENDIF ENDDO 222 CONTINUE X=int(dble(ADDITIONNAL_ROWS)/dble(i)) DO J=1,i NB_ROWS(J)=NB_ROWS(J)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ENDDO IF(ADDITIONNAL_ROWS.NE.0) THEN NB_ROWS(1)=NB_ROWS(1)+ADDITIONNAL_ROWS ENDIF ENDIF 333 CONTINUE IF(NB_ROWS(CHOSEN).EQ.0) CHOSEN=CHOSEN-1 GOTO 889 ELSE DO i=OTHERS,1,-1 SOMME=dble(0) DO J=1,i SOMME=SOMME+TEMP(J) ENDDO SOMME=(dble(i)*TEMP(i))-SOMME IF(dble(TOTAL_MEM).GE.SOMME) GOTO 444 ENDDO 444 CONTINUE REF=i DO J=1,i IF(TEMP(J).EQ.TEMP(i)) THEN SMALL_SET=J GOTO 123 ENDIF ENDDO 123 CONTINUE IF(i.EQ.1)THEN NB_ROWS(i)=NCB CHOSEN=1 GOTO 666 ENDIF 323 CONTINUE AFFECTED=0 CHOSEN=0 ACC=0 DO i=1,SMALL_SET IF(K50.EQ.0)THEN IF((TEMP(SMALL_SET)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(SMALL_SET)-TEMP(i) ENDIF X=int(TMP_SUM/dble(NFRONT)) IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN IF((TEMP(SMALL_SET)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(SMALL_SET)-TEMP(i) ENDIF X=int((-dble(NFRONT-NCB+ACC) & +sqrt(((dble(NFRONT-NCB+ACC)* & dble(NFRONT-NCB+ACC))+dble(4)* & (TMP_SUM))))/ & dble(2)) IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 4 in MUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF NB_ROWS(i)=X ACC=ACC+X CHOSEN=CHOSEN+1 IF(NCB-ACC.LT.KMIN) GOTO 888 IF(NCB.EQ.ACC) GOTO 888 IF(ACC.GT.NCB) THEN WRITE(*,*)MYID, & ': Internal error 5 in MUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDDO 888 CONTINUE SOMME=dble(0) X=NFRONT-NCB IF((ACC.GT.NCB))THEN WRITE(*,*)MYID, & ':Internal error 6 in MUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF IF((ACC.LT.NCB))THEN IF(K50.NE.0)THEN IF(SMALL_SET.LT.OTHERS)THEN SMALL_SET=REF+1 REF=SMALL_SET GOTO 323 ELSE NB_ROWS(CHOSEN)=NB_ROWS(CHOSEN)+NCB-ACC GOTO 666 ENDIF ENDIF ADDITIONNAL_ROWS=NCB-ACC i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) J=1 X=int(ADDITIONNAL_ROWS/(i-1)) IF((X.EQ.0).AND.(ADDITIONNAL_ROWS.NE.0))THEN DO WHILE ((J.LT.i).AND.(ADDITIONNAL_ROWS.GT.0)) NB_ROWS(J)=NB_ROWS(J)+1 ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-1 J=J+1 ENDDO IF(ADDITIONNAL_ROWS.NE.0)THEN WRITE(*,*)MYID, & ':Internal error 7 in MUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF GOTO 047 ENDIF IF((TEMP(1)+dble((NB_ROWS(1)+X)*NFRONT)).LE. & TEMP(i))THEN DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) AFFECTED=X IF((AFFECTED+NB_ROWS(J)).GT. & KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & AFFECTED J=J+1 ENDDO ELSE DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LE.i)) AFFECTED=int((TEMP(i)-(TEMP(J)+ & (dble(NB_ROWS(J))*dble(NFRONT)))) & /dble(NFRONT)) IF((AFFECTED+NB_ROWS(J)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) ENDIF IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED J=J+1 ENDDO ENDIF i=i+1 ENDDO 047 CONTINUE IF((ADDITIONNAL_ROWS.EQ.0).AND. & (i.LT.NUMBER_OF_PROCS))THEN CHOSEN=i-1 ELSE CHOSEN=i-2 ENDIF IF((CHOSEN.EQ.NUMBER_OF_PROCS-1).AND. & (ADDITIONNAL_ROWS.NE.0))THEN DO i=1,CHOSEN NB_ROWS(i)=NB_ROWS(i)+1 ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-1 IF(ADDITIONNAL_ROWS.EQ.0) GOTO 048 ENDDO 048 CONTINUE ENDIF IF((CHOSEN.EQ.NUMBER_OF_PROCS-1).AND. & (ADDITIONNAL_ROWS.NE.0))THEN i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LE.i)) AFFECTED=int((TEMP(i)-(TEMP(J)+ & (dble(NB_ROWS(J))* & dble(NFRONT))))/dble(NFRONT)) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED J=J+1 ENDDO i=i+1 ENDDO CHOSEN=i-2 ENDIF 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 MUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF CHOSEN=CHOSEN-1 ELSE IF(NB_ROWS(i).GT.0)THEN X=1 ELSE WRITE(*,*) & 'Internal error 13 in MUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDIF ENDDO NSLAVES_NODE=CHOSEN TAB_POS(NSLAVES_NODE+1)= NCB+1 TAB_POS(SLAVEF+2) = CHOSEN POS=1 DO i=1,CHOSEN SLAVES_LIST(i)=TEMP_ID(i) TAB_POS(i)=POS POS=POS+NB_ROWS(i) IF(NB_ROWS(i).LE.0)THEN WRITE(*,*) & 'Internal error 14 in MUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDDO DO i=CHOSEN+1,NUMBER_OF_PROCS SLAVES_LIST(i)=TEMP_ID(i) ENDDO IF(POS.NE.(NCB+1))THEN WRITE(*,*) & 'Internal error 15 in MUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF END SUBROUTINE MUMPS_SET_PARTI_ACTV_MEM SUBROUTINE MUMPS_SET_PARTI_FLOP_IRR & (NCBSON_MAX,SLAVEF,KEEP,KEEP8, & PROCS,MEM_DISTRIB,NCB,NFRONT, & NSLAVES_NODE,TAB_POS, & SLAVES_LIST,SIZE_SLAVES_LIST,MYID,INODE,MP,LP) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID INTEGER, intent(in) :: NCBSON_MAX INTEGER, intent(in) :: PROCS(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE INTEGER, intent(in) :: MP,LP INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER NUMBER_OF_PROCS, K50, K83, K69 INTEGER(8) :: K821 INTEGER J INTEGER KMIN, KMAX INTEGER OTHERS,CHOSEN,SMALL_SET,ACC DOUBLE PRECISION SOMME,TMP_SUM,DELTA,A,B,C,MASTER_WORK INTEGER AFFECTED INTEGER ADDITIONNAL_ROWS,i,X,REF,POS,NELIM INTEGER(8) X8 LOGICAL FORCE_CAND,SMP DOUBLE PRECISION BANDE_K821 INTEGER NB_SAT,NB_ZERO DOUBLE PRECISION TEMP(SLAVEF),TOTAL_COST, MAX_MEM_ALLOW INTEGER TEMP_ID(SLAVEF),NB_ROWS(SLAVEF) INTEGER NSLAVES_REF,NCB_FILS EXTERNAL MPI_WTIME,MUMPS_GETKMIN INTEGER MUMPS_GETKMIN INTEGER POS_MIN_LOAD,SIZE_MY_SMP,WHAT 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) K83=KEEP(83) K69=0 NCB_FILS=NCBSON_MAX IF(int(NCB_FILS,8)*int(min(NCB,NCB_FILS),8).GT.K821)THEN HAVE_TYPE1_SON=.TRUE. ELSE HAVE_TYPE1_SON=.FALSE. ENDIF SMP=(K69.NE.0) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF NELIM=NFRONT-NCB KMAX=int(K821/int(NCB,8)) IF(FORCE_CAND)THEN DO i=1,PROCS(SLAVEF+1) WLOAD(i)=LOAD_FLOPS(PROCS(i)) IDWLOAD(i)=PROCS(i) WLOAD(i)=max(WLOAD(i),0.0d0) ENDDO NUMBER_OF_PROCS=PROCS(SLAVEF+1) OTHERS=NUMBER_OF_PROCS ELSE NUMBER_OF_PROCS=SLAVEF WLOAD(1:SLAVEF) = LOAD_FLOPS(0:NUMBER_OF_PROCS-1) DO i=1,NUMBER_OF_PROCS IDWLOAD(i) = i - 1 IF (WLOAD(i) < -0.5d0 ) THEN IF((MP.GT.0).AND.(LP.GE.2))THEN WRITE(MP,*)MYID,': Negative load ', & WLOAD(i) ENDIF ENDIF WLOAD(i)=max(WLOAD(i),0.0d0) ENDDO OTHERS=NUMBER_OF_PROCS-1 ENDIF KMAX=int(NCB/OTHERS) KMIN=MUMPS_GETKMIN(int(NCB,8)*int(KMAX,8),K50,KMAX,NCB) NB_ROWS=0 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, IDWLOAD) IF(K50.EQ.0)THEN TOTAL_COST=dble( NELIM ) * dble ( NCB ) + & dble(NCB) * dble(NELIM)*dble(2*NFRONT-NELIM-1) ELSE TOTAL_COST=dble(NELIM) * dble ( NCB ) * & dble(NFRONT+1) ENDIF CALL MUMPS_GET_FLOPS_COST(NFRONT,NELIM,NELIM,K50, & 2,MASTER_WORK) SOMME=dble(0) J=1 IF(FORCE_CAND.AND.(NUMBER_OF_PROCS.GT.K83))THEN MASTER_WORK=dble(KEEP(88))*MASTER_WORK/dble(100) ENDIF IF(FORCE_CAND.AND.(NUMBER_OF_PROCS.LE.K83))THEN MASTER_WORK=dble(KEEP(87))*MASTER_WORK/dble(100) ENDIF IF(MASTER_WORK.LT.dble(1))THEN MASTER_WORK=dble(1) ENDIF NSLAVES_REF=int(TOTAL_COST/MASTER_WORK)+1 IF(FORCE_CAND)THEN NSLAVES_REF=min(NSLAVES_REF,NUMBER_OF_PROCS) ELSE NSLAVES_REF=min(NSLAVES_REF,NUMBER_OF_PROCS-1) ENDIF DO i=1,NUMBER_OF_PROCS IF((IDWLOAD(i).NE.MYID))THEN TEMP_ID(J)=IDWLOAD(i) TEMP(J)=WLOAD(i) IF(BDC_M2_FLOPS)THEN TEMP(J)=TEMP(J)+NIV2(TEMP_ID(J)+1) ENDIF J=J+1 ENDIF ENDDO NUMBER_OF_PROCS=J-1 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, TEMP, TEMP_ID) SOMME=dble(0) TMP_SUM=dble(0) DO i=1,OTHERS SOMME=SOMME+TEMP(OTHERS)-TEMP(i) TMP_SUM=TMP_SUM+TEMP(i) ENDDO TMP_SUM=(TMP_SUM/dble(OTHERS))+ & (TOTAL_COST/dble(OTHERS)) SIZE_MY_SMP=OTHERS MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 IF(.NOT.SMP) MAX_LOAD=TEMP(OTHERS) IF(SMP)THEN J=1 DO i=1,OTHERS IF(MEM_DISTRIB(TEMP_ID(i)).EQ.1)THEN IF(TEMP(i).LE.TMP_SUM)THEN WLOAD(J)=TEMP(i) IDWLOAD(J)=TEMP_ID(i) J=J+1 ELSE ENDIF ENDIF ENDDO MAX_LOAD=WLOAD(J-1) SIZE_MY_SMP=J-1 DO i=1,OTHERS IF((MEM_DISTRIB(TEMP_ID(i)).NE.1).OR. & ((MEM_DISTRIB(TEMP_ID(i)).EQ.1).AND. & (TEMP(i).GE.TMP_SUM)))THEN WLOAD(J)=TEMP(i) IDWLOAD(J)=TEMP_ID(i) J=J+1 ENDIF ENDDO TEMP=WLOAD TEMP_ID=IDWLOAD ENDIF IF(BDC_MD)THEN BUF_SIZE=dble(K821) IF (KEEP(201).EQ.2) THEN A=dble(int((dble(KEEP(100))/dble(2))/dble(NELIM))) IF(K50.EQ.0)THEN BUF_SIZE=min(BUF_SIZE,A*dble(NCB)) ELSE BUF_SIZE=min(BUF_SIZE,A*A) ENDIF ENDIF BUF_SIZE=dble(K821) DO i=1,NUMBER_OF_PROCS A=dble(MD_MEM(TEMP_ID(i)))/ & dble(NELIM) A=A*dble(NFRONT) IF(K50.EQ.0)THEN B=dble(int(dble(NCB)/dble(NUMBER_OF_PROCS))+1)* & dble(NFRONT) ELSE WHAT = 5 CALL MUMPS_MAX_SURFCB_NBROWS(WHAT, KEEP,KEEP8, NCB, & NFRONT, min(NCB,OTHERS), J, X8) B=dble(X8)+(dble(J)*dble(NELIM)) ENDIF NELIM_MEM_SIZE=A+B MEM_SIZE_WEAK(i)=NELIM_MEM_SIZE IF((SBTR_WHICH_M.EQ.0).OR.(.NOT.BDC_SBTR))THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i)) ENDIF ELSE IF(BDC_SBTR)THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1)- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ENDIF ENDIF ENDIF IF(min(MEM_SIZE_STRONG(i),MEM_SIZE_WEAK(i)).LT.dble(0))THEN IF(MEM_SIZE_STRONG(i).LT.0.0d0)THEN MEM_SIZE_STRONG(i)=dble(0) ELSE MEM_SIZE_WEAK(i)=dble(0) ENDIF ENDIF ENDDO ELSE BUF_SIZE=dble(K821) DO i=1,NUMBER_OF_PROCS IF((SBTR_WHICH_M.EQ.0).OR.(.NOT.BDC_SBTR))THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i)) ENDIF ELSE IF(BDC_SBTR)THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1)- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ENDIF ENDIF ENDIF MEM_SIZE_STRONG(i)=max(dble(0),MEM_SIZE_STRONG(i)) MEM_SIZE_WEAK(i)=huge(MEM_SIZE_WEAK(i)) ENDDO ENDIF IF((((NUMBER_OF_PROCS.LE.K83).AND.FORCE_CAND).AND. & (TOTAL_COST.GE.SOMME)).OR. & (.NOT.FORCE_CAND).OR. & (((NUMBER_OF_PROCS+1).GT.K83).AND.FORCE_CAND))THEN REF=NSLAVES_REF SMALL_SET=NSLAVES_REF IF(.NOT.SMP)THEN DO i=NSLAVES_REF,1,-1 SOMME=dble(0) DO J=1,i SOMME=SOMME+TEMP(J) ENDDO SOMME=(dble(i)*TEMP(i))-SOMME IF(TOTAL_COST.GE.SOMME) GOTO 444 ENDDO 444 CONTINUE REF=i SMALL_SET=REF MAX_LOAD=TEMP(SMALL_SET) ELSE X=min(SIZE_MY_SMP,NSLAVES_REF) 450 CONTINUE SOMME=dble(0) DO J=1,X SOMME=SOMME+(TEMP(X)-TEMP(J)) ENDDO IF(SOMME.GT.TOTAL_COST)THEN X=X-1 GOTO 450 ELSE IF(X.LT.SIZE_MY_SMP) THEN REF=X SMALL_SET=REF MAX_LOAD=TEMP(SMALL_SET) ELSE X=min(SIZE_MY_SMP,NSLAVES_REF) J=X+1 MAX_LOAD=TEMP(X) TMP_SUM=MAX_LOAD DO i=X+1,OTHERS IF(TEMP(i).GT.MAX_LOAD)THEN SOMME=SOMME+(dble(i-1)*(TEMP(i)-MAX_LOAD)) TMP_SUM=MAX_LOAD MAX_LOAD=TEMP(i) ELSE SOMME=SOMME+(MAX_LOAD-TEMP(i)) ENDIF IF(i.EQ.NSLAVES_REF)THEN SMALL_SET=NSLAVES_REF REF=SMALL_SET GOTO 323 ENDIF IF(SOMME.GT.TOTAL_COST)THEN REF=i-1 SMALL_SET=i-1 MAX_LOAD=TMP_SUM GOTO 323 ENDIF ENDDO ENDIF ENDIF ENDIF 323 CONTINUE MAX_LOAD=dble(0) DO i=1,SMALL_SET MAX_LOAD=max(MAX_LOAD,TEMP(i)) ENDDO TEMP_MAX_LOAD=MAX_LOAD NB_ROWS=0 TMP_SUM=dble(0) CHOSEN=0 ACC=0 NB_SAT=0 NB_ZERO=0 DO i=1,SMALL_SET IF(K50.EQ.0)THEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF IF(HAVE_TYPE1_SON)THEN IF(K50.EQ.0)THEN X=int((BUF_SIZE-dble(NFRONT))/dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF IF(K50.EQ.0)THEN KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) X=int((MAX_LOAD-TEMP(i))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE X=0 ENDIF ELSE IF(X.LT.KMIN)THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*(dble(NELIM)+dble(2*ACC+1)) C=-(MAX_LOAD-TEMP(i)) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 1 in MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE X=0 ENDIF ELSE IF(X.LT.KMIN)THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF NB_ROWS(i)=X ACC=ACC+X CHOSEN=CHOSEN+1 IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF TMP_SUM=MAX_LOAD IF(K50.EQ.0)THEN MAX_LOAD=max(MAX_LOAD, & (TEMP(i)+(dble(NELIM) * & dble(NB_ROWS(i)))+ & (dble(NB_ROWS(i))*dble(NELIM)* & dble(2*NFRONT-NELIM-1)))) ELSE MAX_LOAD=max(MAX_LOAD, & TEMP(i)+(dble(NELIM) * dble(NB_ROWS(i)))* & dble(2*(NELIM+ACC)-NB_ROWS(i) & -NELIM+1)) ENDIF IF(TMP_SUM.LT.MAX_LOAD)THEN ENDIF IF(NCB-ACC.LT.KMIN) GOTO 888 IF(NCB.EQ.ACC) GOTO 888 IF(ACC.GT.NCB) THEN WRITE(*,*)MYID, & ': Internal error 2 in MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDDO 888 CONTINUE SOMME=dble(0) X=NFRONT-NCB IF((ACC.GT.NCB))THEN WRITE(*,*)MYID, & ': Internal error 3 in MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF((ACC.LT.NCB))THEN IF(K50.NE.0)THEN IF(SMALL_SET.LE.OTHERS)THEN IF((NB_SAT.EQ.SMALL_SET).AND.(SMALL_SET.LT. & NSLAVES_REF))THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF 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 MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE NB_ZERO=NB_ZERO+1 X=0 ENDIF ELSE IF(X.LT.min(KMIN,KMAX))THEN NB_ZERO=NB_ZERO+1 X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(J)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(J))THEN MIN_LOAD=TEMP(J) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 ACC=ACC+X TMP_SUM=MAX_LOAD TEMP_MAX_LOAD=max(TEMP_MAX_LOAD, & TEMP(J)+(dble(NELIM) * & dble(NB_ROWS(J)))* & dble(2*(NELIM+ & ACC)-NB_ROWS(J) & -NELIM+1)) IF(REF.LE.NUMBER_OF_PROCS-1)THEN IF(TEMP_MAX_LOAD.GT.TEMP(REF+1))THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ENDIF ENDIF IF(NCB.EQ.ACC) GOTO 666 ENDDO IF(NB_SAT.EQ.SMALL_SET)THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE GOTO 434 ENDIF ENDIF IF(NB_ZERO.EQ.SMALL_SET)THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE GOTO 434 ENDIF ENDIF IF((NB_SAT+NB_ZERO).EQ.SMALL_SET)THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE GOTO 434 ENDIF ENDIF ENDDO 434 CONTINUE ADDITIONNAL_ROWS=NCB-ACC IF(ADDITIONNAL_ROWS.NE.0)THEN IF(ADDITIONNAL_ROWS.LT.KMIN)THEN i=CHOSEN J=ACC 436 CONTINUE IF(NB_ROWS(i).NE.0)THEN J=J-NB_ROWS(i) A=dble(1) B=dble(J+2) C=-BUF_SIZE+dble(J+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-J) X=NCB-J BANDE_K821=dble(X)*dble(NELIM+J+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(J+2+NELIM) C=-BUF_SIZE+dble(J+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-J) X=NCB-J BANDE_K821=dble(X)*dble(NELIM+J+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(J+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(NB_ROWS(i).NE.KMAX)THEN IF(NCB-J.LE.KMAX)THEN NB_ROWS(i)=+NCB-J ADDITIONNAL_ROWS=0 ENDIF ENDIF TEMP_MAX_LOAD=max(TEMP_MAX_LOAD, & TEMP(i)+ & (dble(NELIM) * dble(NB_ROWS(i)))* & dble(2*(NELIM+ & ACC)-NB_ROWS(i) & -NELIM+1)) IF(REF.LE.NUMBER_OF_PROCS-1)THEN IF(TEMP_MAX_LOAD.GT.TEMP(REF+1))THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ENDIF ENDIF ELSE i=i-1 IF(i.NE.0)GOTO 436 ENDIF IF(ADDITIONNAL_ROWS.NE.0)THEN i=CHOSEN IF(i.NE.SMALL_SET)THEN i=i+1 IF(NB_ROWS(i).NE.0)THEN WRITE(*,*)MYID, & ': Internal error 5 in MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDIF NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF CHOSEN=i ENDIF ENDIF i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF((TEMP(i).LE.MAX_LOAD))THEN A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(i)) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX ELSE X=0 ENDIF ELSE IF(X.LT.KMIN)THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X ACC=ACC+X ADDITIONNAL_ROWS=NCB-ACC ELSE IF((TEMP(i).GT.MAX_LOAD))THEN MAX_LOAD=TEMP(i) NB_SAT=0 ACC=0 NB_ROWS=0 DO J=1,i A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(J)) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 6 in MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE X=0 ENDIF ELSE IF(X.LT.min(KMIN,KMAX))THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(J)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(J))THEN MIN_LOAD=TEMP(J) POS_MIN_LOAD=i ENDIF ENDIF ACC=ACC+X MAX_LOAD=max(MAX_LOAD, & TEMP(J)+ & (dble(NELIM)*dble(NB_ROWS(J)))* & dble(2*(NELIM+ & ACC)-NB_ROWS(J) & -NELIM+1)) IF(NCB.EQ.ACC) GOTO 741 IF(NCB-ACC.LT.KMIN) GOTO 210 ENDDO 210 CONTINUE ENDIF 741 CONTINUE i=i+1 ADDITIONNAL_ROWS=NCB-ACC ENDDO CHOSEN=i-1 IF(ADDITIONNAL_ROWS.NE.0)THEN ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)*dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS- & NELIM+1) SOMME=SOMME/dble(NUMBER_OF_PROCS) NB_ROWS=0 ACC=0 CHOSEN=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(i)+SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 7 in MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX ELSE X=0 ENDIF ELSE IF(X.LT.min(KMIN,KMAX))THEN X=min(KMAX,KMIN) ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB.EQ.ACC) GOTO 666 IF(NCB-ACC.LT.KMIN) GOTO 488 ENDDO 488 CONTINUE ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)* & dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS- & NELIM+1) SOMME=SOMME/dble(NUMBER_OF_PROCS) NB_ROWS=0 ACC=0 CHOSEN=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(i)+SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 8 in MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN X=KMAX ELSE IF(X.LT.KMIN)THEN X=KMIN ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB.EQ.ACC) GOTO 666 IF(NCB-ACC.LT.KMIN) GOTO 477 ENDDO 477 CONTINUE IF(ACC.NE.NCB)THEN NB_SAT=0 ACC=0 CHOSEN=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) X=KMAX-NB_ROWS(i) IF((ACC+NB_ROWS(i)+X).GT.NCB) & X=NCB-(ACC+NB_ROWS(i)) NB_ROWS(i)=NB_ROWS(i)+X IF((dble(NB_ROWS(i))* & dble(NB_ROWS(i)+ACC)).EQ. & BANDE_K821)THEN NB_SAT=NB_SAT+1 ENDIF ACC=ACC+NB_ROWS(i) IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 IF(NCB.EQ.ACC) GOTO 666 IF(NCB-ACC.LT.KMIN) GOTO 834 ENDDO 834 CONTINUE ENDIF IF(ACC.NE.NCB)THEN ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)* & dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS- & NELIM+1) SOMME=SOMME/dble(NUMBER_OF_PROCS-NB_SAT) ACC=0 DO i=1,CHOSEN A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF IF((dble(NB_ROWS(i))* & dble(NB_ROWS(i)+ACC)).EQ. & BANDE_K821)THEN GOTO 102 ENDIF A=dble(NELIM) B=dble(NELIM)* & dble(NELIM+2*(ACC+NB_ROWS(i))+1) C=-(SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(1) B=dble(ACC+NELIM) C=dble(-BANDE_K821) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 9 in MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF((ACC+X+NB_ROWS(i)).GT.NCB)THEN IF((NCB-ACC).GT.KMAX)THEN NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NCB-ACC ENDIF ELSE IF((NB_ROWS(i)+X).GT.KMAX)THEN NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NB_ROWS(i)+X ENDIF ENDIF 102 CONTINUE ACC=ACC+NB_ROWS(i) IF(NCB.EQ.ACC) THEN CHOSEN=i GOTO 666 ENDIF IF(NCB-ACC.LT.KMIN) THEN CHOSEN=i GOTO 007 ENDIF ENDDO 007 CONTINUE DO i=1,CHOSEN NB_ROWS(i)=NB_ROWS(i)+1 ACC=ACC+1 IF(ACC.EQ.NCB)GOTO 666 ENDDO IF(ACC.LT.NCB)THEN IF(SMP)THEN NB_ROWS(1)=NB_ROWS(1)+NCB-ACC ELSE NB_ROWS(POS_MIN_LOAD)= & NB_ROWS(POS_MIN_LOAD)+NCB-ACC ENDIF ENDIF ENDIF GOTO 666 ENDIF ENDIF GOTO 666 ENDIF ADDITIONNAL_ROWS=NCB-ACC i=CHOSEN+1 IF(NB_SAT.EQ.SMALL_SET) GOTO 777 DO i=1,SMALL_SET IDWLOAD(i)=i AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & (dble(NFRONT+1))) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF WLOAD(i)=MAX_MEM_ALLOW ENDDO CALL MUMPS_SORT_DOUBLES(SMALL_SET, WLOAD, IDWLOAD) NB_ZERO=0 IF((NB_SAT.EQ.SMALL_SET).AND. & (SMALL_SET.LT.NSLAVES_REF))THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF IF((NB_SAT.EQ.SMALL_SET).AND. & (SMALL_SET.LE.NUMBER_OF_PROCS))GOTO 777 AFFECTED=int(ADDITIONNAL_ROWS/(SMALL_SET-NB_SAT)) AFFECTED=max(AFFECTED,1) DO i=1,SMALL_SET KMAX=int(WLOAD(i)/dble(NFRONT)) IF(NB_ROWS(IDWLOAD(i)).EQ.KMAX)THEN GOTO 912 ENDIF IF((NB_ROWS(IDWLOAD(i))+min(AFFECTED, & ADDITIONNAL_ROWS)).GT.KMAX)THEN IF(NB_ROWS(IDWLOAD(i)).GT.KMAX)THEN ENDIF ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(IDWLOAD(i))) NB_ROWS(IDWLOAD(i))=KMAX NB_SAT=NB_SAT+1 IF(NB_SAT.EQ.SMALL_SET)THEN IF(SMALL_SET.NE.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE MAX_LOAD=max(MAX_LOAD, & (TEMP(IDWLOAD(i))+(dble(NELIM) * & dble(NB_ROWS(IDWLOAD(i))))+ & (dble(NB_ROWS(IDWLOAD(i)))* & dble(NELIM))* & dble(2*NFRONT-NELIM-1))) GOTO 777 ENDIF ENDIF AFFECTED=int(ADDITIONNAL_ROWS/(SMALL_SET-NB_SAT)) AFFECTED=max(AFFECTED,1) ELSE IF((NB_ROWS(IDWLOAD(i))+min(AFFECTED, & ADDITIONNAL_ROWS)).GE.KMIN)THEN X=min(AFFECTED,ADDITIONNAL_ROWS) NB_ROWS(IDWLOAD(i))=NB_ROWS(IDWLOAD(i))+ & X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ELSE X=int((MAX_LOAD-TEMP(IDWLOAD(i)))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X+AFFECTED.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ELSE X=AFFECTED+X ENDIF IF(X.GE.KMIN)THEN NB_ROWS(IDWLOAD(i))=NB_ROWS(IDWLOAD(i))+ & X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & X ELSE NB_ZERO=NB_ZERO+1 ENDIF ENDIF ENDIF 912 CONTINUE MAX_LOAD=max(MAX_LOAD, & (TEMP(IDWLOAD(i))+(dble(NELIM)* & dble(NB_ROWS(IDWLOAD(i))))+ & (dble(NB_ROWS(IDWLOAD(i)))*dble(NELIM))* & dble(2*NFRONT-NELIM-1))) IF(SMALL_SET.LT.NUMBER_OF_PROCS)THEN IF(MAX_LOAD.GT.TEMP(SMALL_SET+1))THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ENDIF ENDIF IF(SMALL_SET.EQ.NB_SAT)GOTO 777 IF(ADDITIONNAL_ROWS.EQ.0)THEN CHOSEN=SMALL_SET GOTO 049 ENDIF ENDDO 777 CONTINUE IF((NB_ZERO.NE.0).AND.(ADDITIONNAL_ROWS.GE.KMIN))THEN J=NB_ZERO 732 CONTINUE X=int(ADDITIONNAL_ROWS/(J)) IF(X.LT.KMIN)THEN J=J-1 GOTO 732 ENDIF IF(X*J.LT.ADDITIONNAL_ROWS)THEN X=X+1 ENDIF DO i=1,SMALL_SET AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & dble(BANDE_K821)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(NB_ROWS(i).EQ.0)THEN IF(X.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ENDIF IF(X.GT.KMAX)THEN X=KMAX ENDIF IF(X.GT.KMIN)THEN NB_ROWS(i)=X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X MAX_LOAD=max(MAX_LOAD, & (TEMP(i)+(dble(NELIM) * & dble(NB_ROWS(i)))+ & (dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1))) ENDIF ENDIF ENDDO ENDIF i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF((TEMP(i).LE.MAX_LOAD))THEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) AFFECTED=int((MAX_LOAD-TEMP(i))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(i).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(i)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(i) NB_SAT=NB_SAT+1 ELSE IF((AFFECTED+NB_ROWS(i)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(i)=NB_ROWS(i)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED ENDIF ELSE IF((TEMP(i).GT.MAX_LOAD))THEN IF(NB_SAT.EQ.i-1) GOTO 218 X=(ADDITIONNAL_ROWS/(i-1-NB_SAT)) ACC=1 DO J=1,i-1 TMP_SUM=((dble(NELIM) * dble(NB_ROWS(J)+X)) & +(dble(NB_ROWS(J)+X)*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) IF((TEMP(J)+TMP_SUM).GT.MAX_LOAD)THEN ACC=0 ENDIF ENDDO IF(ACC.EQ.1)THEN MAX_LOAD=TEMP(i) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF AFFECTED=X MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(J).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(J)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) NB_SAT=NB_SAT+1 ELSE IF((AFFECTED+NB_ROWS(J)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & AFFECTED ENDIF J=J+1 ENDDO ELSE MAX_LOAD=TEMP(i) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF TMP_SUM=((dble(NELIM)* dble(NB_ROWS(J))) & +(dble(NB_ROWS(J))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((MAX_LOAD-(TEMP(J)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 10 in MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF AFFECTED=X MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(J).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(J)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) NB_SAT=NB_SAT+1 ELSE IF((AFFECTED+NB_ROWS(J)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & AFFECTED ENDIF J=J+1 ENDDO ENDIF ENDIF 218 CONTINUE i=i+1 ENDDO CHOSEN=i-1 IF((CHOSEN.EQ.NUMBER_OF_PROCS-1).AND. & (ADDITIONNAL_ROWS.NE.0))THEN DO i=1,CHOSEN IF(NB_ROWS(i)+1.GE.KMIN)THEN NB_ROWS(i)=NB_ROWS(i)+1 ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-1 ENDIF MAX_LOAD=max(MAX_LOAD, & (TEMP(i)+(dble(NELIM) * & dble(NB_ROWS(i)))+ & (dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1))) IF(ADDITIONNAL_ROWS.EQ.0) GOTO 048 ENDDO 048 CONTINUE ENDIF IF((ADDITIONNAL_ROWS.NE.0))THEN IF(CHOSEN.LT.NUMBER_OF_PROCS)THEN i=CHOSEN+1 ELSE IF(CHOSEN.NE.NUMBER_OF_PROCS)THEN WRITE(*,*)MYID, & ': Internal error 11 in MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF i=CHOSEN ENDIF DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF(TEMP(i).LE.MAX_LOAD)THEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) TMP_SUM=((dble(NELIM) * dble(NB_ROWS(i))) & +(dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((MAX_LOAD-(TEMP(i)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) AFFECTED=X IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 12 in MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(i).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(i)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(i) ELSE IF((AFFECTED+NB_ROWS(i)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(i)=NB_ROWS(i)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED ENDIF IF(i.NE.NUMBER_OF_PROCS) GOTO 624 ELSE IF((TEMP(i).GT.MAX_LOAD))THEN X=int(ADDITIONNAL_ROWS/i-1) X=max(X,1) IF((MAX_LOAD+((dble(NELIM)* & dble(X))+(dble( & X)*dble(NELIM))*dble( & (2*NFRONT-NELIM-1)))).LE.TEMP(i))THEN AFFECTED=X POS=1 ELSE POS=0 ENDIF MAX_LOAD=TEMP(i) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) MAX_MEM_ALLOW=BANDE_K821 IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(POS.EQ.0)THEN TMP_SUM=((dble(NELIM) * & dble(NB_ROWS(J))) & +(dble(NB_ROWS(J))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((TEMP(i)-(TEMP(J)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT- & NELIM))) ELSE X=int(TMP_SUM) ENDIF IF(X.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(J).LT.KMAX)THEN IF((X+NB_ROWS(J)).GT.KMAX)THEN X=KMAX-NB_ROWS(J) ELSE IF((NB_ROWS(J)+X).LT. & KMIN)THEN X=0 ENDIF ENDIF NB_ROWS(J)=NB_ROWS(J)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ENDIF J=J+1 ENDDO ENDIF 624 CONTINUE i=i+1 ENDDO CHOSEN=i-1 IF(ADDITIONNAL_ROWS.NE.0)THEN ACC=0 DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) TMP_SUM=((dble(NELIM) * dble(NB_ROWS(i))) & +(dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((MAX_LOAD- & (TEMP(i)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 13 in MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(i).LT.KMAX)THEN IF((X+NB_ROWS(i)).GE.KMAX)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE IF((X+NB_ROWS(i)).GE. & KMIN)THEN NB_ROWS(i)=NB_ROWS(i)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ACC=ACC+1 ELSE ACC=ACC+1 ENDIF ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO IF(CHOSEN.LT.NUMBER_OF_PROCS)THEN CHOSEN=CHOSEN+1 ENDIF IF(ACC.EQ.0)THEN ACC=1 ENDIF X=int(ADDITIONNAL_ROWS/ACC) X=max(X,1) ACC=0 DO i=1,CHOSEN J=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(J)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN J=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(J)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) TMP_SUM=((dble(NELIM) * dble(NB_ROWS(i))) & +(dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) J=int((MAX_LOAD- & (TEMP(i)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(NB_ROWS(i).LT.KMAX)THEN IF((min(X,J)+NB_ROWS(i)).GE.KMAX)THEN IF((KMAX-NB_ROWS(i)).GT. & ADDITIONNAL_ROWS)THEN NB_ROWS(i)=NB_ROWS(i)+ & ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ENDIF ELSE IF((min(X,J)+NB_ROWS(i)).GE. & KMIN)THEN NB_ROWS(i)=NB_ROWS(i)+min(X,J) ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & min(X,J) ACC=ACC+1 ENDIF ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO IF(ACC.GT.0)THEN DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(KMAX-NB_ROWS(i).LT. & ADDITIONNAL_ROWS)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE IF(NB_ROWS(i).EQ.0)THEN IF(min(KMIN,KMAX).LT. & ADDITIONNAL_ROWS)THEN NB_ROWS(i)=min(KMIN,KMAX) ADDITIONNAL_ROWS= & ADDITIONNAL_ROWS- & min(KMIN,KMAX) ENDIF ELSE NB_ROWS(i)=NB_ROWS(i)+ & ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO ENDIF DO i=1,CHOSEN IDWLOAD(i)=i AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF WLOAD(i)=(BANDE_K821-dble(NB_ROWS(i)*NFRONT)) ENDDO CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, & IDWLOAD) NB_SAT=0 DO i=1,CHOSEN X=int(ADDITIONNAL_ROWS/(CHOSEN-NB_SAT)) X=max(X,1) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(NB_ROWS(IDWLOAD(i)).LT.KMAX)THEN IF((NB_ROWS(IDWLOAD(i))+X).LT.KMAX)THEN NB_ROWS(IDWLOAD(i))= & NB_ROWS(IDWLOAD(i))+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(IDWLOAD(i))) NB_ROWS(IDWLOAD(i))=KMAX ENDIF ENDIF IF(NB_ROWS(IDWLOAD(i)).EQ.KMAX)THEN NB_SAT=NB_SAT+1 ENDIF IF(ADDITIONNAL_ROWS.EQ.0) GOTO 049 ENDDO DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(KMAX-NB_ROWS(i).LT.ADDITIONNAL_ROWS)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO X=int(ADDITIONNAL_ROWS/CHOSEN) X=max(X,1) DO i=1,CHOSEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X NB_ROWS(i)=NB_ROWS(i)+X IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO NB_ROWS(1)=NB_ROWS(1)+ADDITIONNAL_ROWS ENDIF ENDIF 049 CONTINUE ENDIF 666 CONTINUE SOMME=dble(0) X=0 POS=0 DO i=1,CHOSEN X=X+NB_ROWS(i) SOMME=SOMME+ dble(NB_ROWS(i)) ENDDO GOTO 890 ELSE IF((KEEP(83).GE.NUMBER_OF_PROCS).AND.FORCE_CAND)THEN MAX_LOAD=dble(0) DO i=1,OTHERS MAX_LOAD=max(MAX_LOAD,TEMP(i)) ENDDO ACC=0 CHOSEN=0 X=1 DO i=1,OTHERS ENDDO DO i=2,OTHERS IF(TEMP(i).EQ.TEMP(1))THEN X=X+1 ELSE GOTO 329 ENDIF ENDDO 329 CONTINUE TMP_SUM=TOTAL_COST/dble(X) TEMP_MAX_LOAD=dble(0) DO i=1,OTHERS IF(K50.EQ.0)THEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF IF(HAVE_TYPE1_SON)THEN IF(K50.EQ.0)THEN X=int((BUF_SIZE-dble(NFRONT))/dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i))) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF IF(K50.EQ.0)THEN KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(TMP_SUM+TEMP(i).GT.MAX_LOAD)THEN SOMME=MAX_LOAD-TEMP(i) ELSE SOMME=TMP_SUM ENDIF X=int(SOMME/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.GT.KMAX)THEN X=KMAX ELSE IF(X.LT.KMIN)THEN X=min(KMIN,KMAX) ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) IF(TMP_SUM+TEMP(i).GT.MAX_LOAD)THEN C=-(MAX_LOAD-TEMP(i)) ELSE C=-TMP_SUM ENDIF DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 14 in MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GT.KMIN)THEN X=KMAX ELSE X=0 ENDIF ELSE IF(X.LE.min(KMIN,KMAX))THEN IF(KMAX.LT.KMIN)THEN X=0 ELSE X=min(KMIN,KMAX) ENDIF ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF TEMP_MAX_LOAD=max(TEMP_MAX_LOAD,TEMP(i)) NB_ROWS(i)=X CHOSEN=CHOSEN+1 ACC=ACC+X IF(ACC.EQ.NCB) GOTO 541 ENDDO 541 CONTINUE IF(ACC.LT.NCB)THEN IF(K50.EQ.0)THEN ADDITIONNAL_ROWS=NCB-ACC DO J=1,CHOSEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & dble(BANDE_K821)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF((NB_ROWS(J)).LT.KMAX)THEN IF(ADDITIONNAL_ROWS.GT.(KMAX-NB_ROWS(J)))THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(J)) NB_ROWS(J)=KMAX ELSE NB_ROWS(J)=NB_ROWS(J)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 889 ENDDO X=int(ADDITIONNAL_ROWS/CHOSEN) X=max(X,1) DO J=1,CHOSEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(J)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF((NB_ROWS(J)+X).GT.KMAX)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(J)) NB_ROWS(J)=KMAX ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X NB_ROWS(J)=NB_ROWS(J)+X ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 889 ENDDO DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(KMAX-NB_ROWS(i).LT.ADDITIONNAL_ROWS)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 889 ENDDO DO i=1,NUMBER_OF_PROCS IDWLOAD(i)=i AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF WLOAD(i)=(BANDE_K821-(dble(NB_ROWS(i))* & dble(NFRONT))) ENDDO CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, & IDWLOAD) NB_SAT=0 DO i=1,CHOSEN X=int(ADDITIONNAL_ROWS/(CHOSEN-NB_SAT)) X=max(X,1) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(NB_ROWS(IDWLOAD(i)).LT.KMAX)THEN IF((NB_ROWS(IDWLOAD(i))+X).LT.KMAX)THEN NB_ROWS(IDWLOAD(i))= & NB_ROWS(IDWLOAD(i))+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(IDWLOAD(i))) NB_ROWS(IDWLOAD(i))=KMAX ENDIF ENDIF IF(NB_ROWS(IDWLOAD(i)).EQ.KMAX)THEN NB_SAT=NB_SAT+1 ENDIF IF(ADDITIONNAL_ROWS.EQ.0) GOTO 889 ENDDO GOTO 994 ELSE ACC=0 CHOSEN=0 DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) X=KMAX-NB_ROWS(i) IF((ACC+NB_ROWS(i)+X).GT.NCB) & X=NCB-(ACC+NB_ROWS(i)) NB_ROWS(i)=NB_ROWS(i)+X ACC=ACC+NB_ROWS(i) CHOSEN=CHOSEN+1 IF(NCB.EQ.ACC) GOTO 889 ENDDO ADDITIONNAL_ROWS=NCB-ACC ENDIF ACC=0 CHOSEN=0 DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) X=KMAX-NB_ROWS(i) IF((ACC+NB_ROWS(i)+X).GT.NCB) & X=NCB-(ACC+NB_ROWS(i)) NB_ROWS(i)=NB_ROWS(i)+X ACC=ACC+NB_ROWS(i) CHOSEN=CHOSEN+1 IF(NCB.EQ.ACC) GOTO 889 ENDDO ADDITIONNAL_ROWS=NCB-ACC 994 CONTINUE X=int(dble(ADDITIONNAL_ROWS)/dble(OTHERS)) IF((X*OTHERS).LT.ADDITIONNAL_ROWS)THEN X=X+1 ENDIF DO i=1,OTHERS NB_ROWS(i)=NB_ROWS(i)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X IF(ADDITIONNAL_ROWS.LT.X)X=ADDITIONNAL_ROWS ENDDO CHOSEN=OTHERS ENDIF ENDIF 889 CONTINUE MAX_LOAD=TEMP_MAX_LOAD 890 CONTINUE J=CHOSEN X=0 DO i=J,1,-1 IF(NB_ROWS(i).EQ.0)THEN CHOSEN=CHOSEN-1 ELSE IF(NB_ROWS(i).GT.0)THEN X=1 ELSE WRITE(*,*)MYID, & ': Internal error 15 in MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDIF ENDDO NSLAVES_NODE=CHOSEN TAB_POS(NSLAVES_NODE+1)= NCB+1 TAB_POS(SLAVEF+2) = CHOSEN POS=1 X=1 DO i=1,J IF(NB_ROWS(i).NE.0)THEN SLAVES_LIST(X)=TEMP_ID(i) TAB_POS(X)=POS POS=POS+NB_ROWS(i) IF(NB_ROWS(i).LE.0)THEN WRITE(*,*)MYID, & ': Internal error 16 in MUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF X=X+1 ENDIF ENDDO IF(POS.NE.(NCB+1))THEN WRITE(*,*)MYID, & ': Internal error 17 in MUMPS_SET_PARTI_FLOP_IRR', & POS,NCB+1 CALL MUMPS_ABORT() ENDIF END SUBROUTINE MUMPS_SET_PARTI_FLOP_IRR SUBROUTINE MUMPS_LOAD_POOL_CHECK_MEM & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IMPLICIT NONE INTEGER INODE, LPOOL, SLAVEF, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(KEEP(28)), POOL(LPOOL), PROCNODE(KEEP(28)) LOGICAL UPPER INTEGER J DOUBLE PRECISION MEM_COST INTEGER NBINSUBTREE,i,NBTOP EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF(KEEP(47).LT.2)THEN WRITE(*,*)'MUMPS_LOAD_POOL_CHECK_MEM must & be called with KEEP(47)>=2' CALL MUMPS_ABORT() ENDIF IF((INODE.GT.0).AND.(INODE.LE.N))THEN MEM_COST=MUMPS_LOAD_GET_MEM(INODE) IF((DM_MEM(MYID)+dble(MEM_COST)+ PEAK_SBTR_CUR_LOCAL- & SBTR_CUR_LOCAL) & .GT.MAX_PEAK_STK)THEN DO i=NBTOP-1,1,-1 INODE = POOL( LPOOL - 2 - i) MEM_COST=MUMPS_LOAD_GET_MEM(INODE) IF((INODE.LT.0).OR.(INODE.GT.N)) THEN DO J=i+1,NBTOP,-1 POOL(J-1)=POOL(J) ENDDO UPPER=.TRUE. RETURN ENDIF IF((DM_MEM(MYID)+dble(MEM_COST)+PEAK_SBTR_CUR_LOCAL- & SBTR_CUR_LOCAL).LE. & MAX_PEAK_STK) THEN DO J=i+1,NBTOP,-1 POOL(J-1)=POOL(J) ENDDO UPPER=.TRUE. RETURN ENDIF ENDDO IF(NBINSUBTREE.NE.0)THEN INODE = POOL( NBINSUBTREE ) IF(.NOT.MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)))THEN WRITE(*,*) & 'Internal error 1 in MUMPS_LOAD_POOL_CHECK_MEM' CALL MUMPS_ABORT() ENDIF UPPER=.FALSE. RETURN ENDIF INODE=POOL(LPOOL-2-NBTOP) UPPER=.TRUE. RETURN ENDIF ENDIF UPPER=.TRUE. END SUBROUTINE MUMPS_LOAD_POOL_CHECK_MEM SUBROUTINE MUMPS_LOAD_SET_SBTR_MEM(WHAT) IMPLICIT NONE LOGICAL WHAT IF(.NOT.BDC_POOL_MNG)THEN WRITE(*,*)'MUMPS_LOAD_SET_SBTR_MEM & should be called when K81>0 and KEEP(47)>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 MUMPS_LOAD_SET_SBTR_MEM DOUBLE PRECISION FUNCTION MUMPS_LOAD_GET_MEM( INODE ) IMPLICIT NONE INTEGER INODE,LEVEL,i,NELIM,NFR DOUBLE PRECISION COST EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF NFR = ND_LOAD( STEP_LOAD(INODE) ) + KEEP_LOAD(253) LEVEL = MUMPS_TYPENODE( PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199) ) IF (LEVEL .EQ. 1) THEN COST = dble(NFR) * dble(NFR) ELSE IF ( K50 == 0 ) THEN COST = dble(NFR) * dble(NELIM) ELSE COST = dble(NELIM) * dble(NELIM) ENDIF ENDIF MUMPS_LOAD_GET_MEM=COST RETURN END FUNCTION MUMPS_LOAD_GET_MEM RECURSIVE SUBROUTINE MUMPS_NEXT_NODE(FLAG,COST,COMM) USE MUMPS_BUF_COMMON USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER COMM,WHAT,IERR LOGICAL FLAG, EXIT_FLAG DOUBLE PRECISION COST DOUBLE PRECISION TO_BE_SENT IF(FLAG)THEN WHAT=17 IF(BDC_M2_FLOPS)THEN TO_BE_SENT=DELTA_LOAD-COST DELTA_LOAD=dble(0) ELSE IF(BDC_M2_MEM)THEN IF(BDC_POOL.AND.(.NOT.BDC_MD))THEN TO_BE_SENT=max(TMP_M2,POOL_LAST_COST_SENT) POOL_LAST_COST_SENT=TO_BE_SENT ELSE IF(BDC_MD)THEN DELTA_MEM=DELTA_MEM+TMP_M2 TO_BE_SENT=DELTA_MEM ELSE TO_BE_SENT=dble(0) ENDIF ENDIF ELSE WHAT=6 TO_BE_SENT=dble(0) ENDIF 111 CONTINUE CALL MUMPS_BUF_BROADCAST( WHAT, & COMM, NPROCS, & FUTURE_NIV2, & COST, & TO_BE_SENT, & MYID, KEEP_LOAD(267), IERR ) IF ( IERR == -1 )THEN CALL MUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in MUMPS_LOAD_POOL_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF 100 CONTINUE RETURN END SUBROUTINE MUMPS_NEXT_NODE SUBROUTINE MUMPS_UPPER_PREDICT(INODE,STEP,NSTEPS,PROCNODE,FRERE, & NE,COMM,SLAVEF,MYID,KEEP,KEEP8,N) USE MUMPS_BUF_COMMON IMPLICIT NONE INTEGER INODE,NSTEPS,MYID,SLAVEF,COMM,N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER FRERE(NSTEPS),NE(NSTEPS),STEP(N),PROCNODE(NSTEPS) EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_PROCNODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR INTEGER i,NCB,NELIM INTEGER MUMPS_PROCNODE INTEGER FATHER_NODE,FATHER,WHAT,IERR EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE LOGICAL :: EXIT_FLAG IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*)MYID,': Problem in MUMPS_UPPER_PREDICT' CALL MUMPS_ABORT() ENDIF IF((INODE.LT.0).OR.(INODE.GT.N)) THEN RETURN ENDIF i=INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF NCB=ND_LOAD(STEP_LOAD(INODE))-NELIM + KEEP_LOAD(253) WHAT=5 FATHER_NODE=DAD_LOAD(STEP_LOAD(INODE)) IF (FATHER_NODE.EQ.0) THEN RETURN ENDIF IF((FRERE(STEP(FATHER_NODE)).EQ.0).AND. & ((FATHER_NODE.EQ.KEEP(38)).OR. & (FATHER_NODE.EQ.KEEP(20))))THEN RETURN ENDIF IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(FATHER_NODE)), & KEEP(199))) THEN RETURN ENDIF FATHER=MUMPS_PROCNODE(PROCNODE(STEP(FATHER_NODE)),KEEP(199)) IF(FATHER.EQ.MYID)THEN IF(BDC_M2_MEM)THEN CALL MUMPS_PROCESS_NIV2_MEM_MSG(FATHER_NODE) ELSEIF(BDC_M2_FLOPS)THEN CALL MUMPS_PROCESS_NIV2_FLOPS_MSG(FATHER_NODE) ENDIF IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN IF(MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP(199)).EQ.1)THEN CB_COST_ID(POS_ID)=INODE CB_COST_ID(POS_ID+1)=1 CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 CB_COST_MEM(POS_MEM)=int(MYID,8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(NCB,8)*int(NCB,8) POS_MEM=POS_MEM+1 ENDIF ENDIF GOTO 666 ENDIF 111 CONTINUE CALL MUMPS_BUF_SEND_FILS(WHAT, COMM, NPROCS, & FATHER_NODE,INODE,NCB, KEEP,MYID, & FATHER, IERR) IF (IERR == -1 ) THEN CALL MUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 666 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in MUMPS_UPPER_PREDICT", & IERR CALL MUMPS_ABORT() ENDIF 666 CONTINUE RETURN END SUBROUTINE MUMPS_UPPER_PREDICT SUBROUTINE MUMPS_REMOVE_NODE(INODE,NUM_CALL) IMPLICIT NONE DOUBLE PRECISION MAXI INTEGER i,J,IND_MAXI INTEGER INODE,NUM_CALL IF(BDC_M2_MEM)THEN IF(((NUM_CALL.EQ.1).AND.(BDC_MD)).OR. & ((NUM_CALL.EQ.2).AND.(.NOT.BDC_MD)))THEN RETURN ENDIF ENDIF IF((FRERE_LOAD(STEP_LOAD(INODE)).EQ.0).AND. & ((INODE.EQ.KEEP_LOAD(38)).OR. & (INODE.EQ.KEEP_LOAD(20)))) THEN RETURN ENDIF DO i=POOL_SIZE,1,-1 IF(POOL_NIV2(i).EQ.INODE) GOTO 666 ENDDO NB_SON(STEP_LOAD(INODE))=-1 RETURN 666 CONTINUE IF(BDC_M2_MEM)THEN IF(POOL_NIV2_COST(i).EQ.MAX_M2)THEN TMP_M2=MAX_M2 MAXI=dble(0) IND_MAXI=-9999 DO J=POOL_SIZE,1,-1 IF(J.NE.i) THEN IF(POOL_NIV2_COST(J).GT.MAXI)THEN MAXI=POOL_NIV2_COST(J) IND_MAXI=J ENDIF ENDIF ENDDO MAX_M2=MAXI J=IND_MAXI REMOVE_NODE_FLAG_MEM=.TRUE. REMOVE_NODE_COST_MEM=TMP_M2 CALL MUMPS_NEXT_NODE(REMOVE_NODE_FLAG,MAX_M2,COMM_LD) NIV2(MYID+1)=MAX_M2 ENDIF ELSEIF(BDC_M2_FLOPS)THEN REMOVE_NODE_COST=POOL_NIV2_COST(i) REMOVE_NODE_FLAG=.TRUE. CALL MUMPS_NEXT_NODE(REMOVE_NODE_FLAG, & -POOL_NIV2_COST(i),COMM_LD) NIV2(MYID+1)=NIV2(MYID+1)-POOL_NIV2_COST(i) ENDIF DO J=i+1,POOL_SIZE POOL_NIV2(J-1)=POOL_NIV2(J) POOL_NIV2_COST(J-1)=POOL_NIV2_COST(J) ENDDO POOL_SIZE=POOL_SIZE-1 END SUBROUTINE MUMPS_REMOVE_NODE RECURSIVE SUBROUTINE MUMPS_PROCESS_NIV2_MEM_MSG(INODE) IMPLICIT NONE INTEGER INODE 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 MUMPS_PROCESS_NIV2_MEM_MSG' CALL MUMPS_ABORT() ENDIF ENDIF NB_SON(STEP_LOAD(INODE))= & NB_SON(STEP_LOAD(INODE))-1 IF(NB_SON(STEP_LOAD(INODE)).EQ.0)THEN IF(POOL_SIZE.EQ.POOL_NIV2_SIZE)THEN WRITE(*,*)MYID,': Internal Error 2 in &MUMPS_PROCESS_NIV2_MEM_MSG' CALL MUMPS_ABORT() ENDIF POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & MUMPS_LOAD_GET_MEM(INODE) POOL_SIZE=POOL_SIZE+1 IF(POOL_NIV2_COST(POOL_SIZE).GT.MAX_M2)THEN MAX_M2=POOL_NIV2_COST(POOL_SIZE) ID_MAX_M2=POOL_NIV2(POOL_SIZE) CALL MUMPS_NEXT_NODE(REMOVE_NODE_FLAG_MEM,MAX_M2,COMM_LD) NIV2(1+MYID)=MAX_M2 ENDIF ENDIF RETURN END SUBROUTINE MUMPS_PROCESS_NIV2_MEM_MSG RECURSIVE SUBROUTINE MUMPS_PROCESS_NIV2_FLOPS_MSG(INODE) IMPLICIT NONE INTEGER INODE 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 MUMPS_PROCESS_NIV2_FLOPS_MSG' CALL MUMPS_ABORT() ENDIF ENDIF NB_SON(STEP_LOAD(INODE))= & NB_SON(STEP_LOAD(INODE))-1 IF(NB_SON(STEP_LOAD(INODE)).EQ.0)THEN IF(POOL_SIZE.EQ.POOL_NIV2_SIZE)THEN WRITE(*,*)MYID,': Internal Error 2 in &MUMPS_PROCESS_NIV2_FLOPS_MSG',POOL_NIV2_SIZE, & POOL_SIZE CALL MUMPS_ABORT() ENDIF POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & MUMPS_LOAD_GET_FLOPS_COST(INODE) POOL_SIZE=POOL_SIZE+1 MAX_M2=POOL_NIV2_COST(POOL_SIZE) ID_MAX_M2=POOL_NIV2(POOL_SIZE) CALL MUMPS_NEXT_NODE(REMOVE_NODE_FLAG, & POOL_NIV2_COST(POOL_SIZE), & COMM_LD) NIV2(MYID+1)=POOL_NIV2_COST(POOL_SIZE)+NIV2(MYID+1) ENDIF RETURN END SUBROUTINE MUMPS_PROCESS_NIV2_FLOPS_MSG DOUBLE PRECISION FUNCTION MUMPS_LOAD_GET_FLOPS_COST(INODE) USE MUMPS_FUTURE_NIV2 INTEGER INODE INTEGER NFRONT,NELIM,i,LEVEL EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE DOUBLE PRECISION COST i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF NFRONT = ND_LOAD( STEP_LOAD(INODE) ) + KEEP_LOAD(253) LEVEL = MUMPS_TYPENODE( PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199) ) COST=dble(0) CALL MUMPS_GET_FLOPS_COST(NFRONT,NELIM,NELIM, & KEEP_LOAD(50),LEVEL,COST) MUMPS_LOAD_GET_FLOPS_COST=COST RETURN END FUNCTION MUMPS_LOAD_GET_FLOPS_COST INTEGER FUNCTION MUMPS_LOAD_GET_CB_FREED( INODE ) IMPLICIT NONE INTEGER INODE,NELIM,NFR,SON,IN,i INTEGER COST_CB COST_CB=0 i = INODE 10 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 10 ENDIF SON=-i DO i=1, NE_LOAD(STEP_LOAD(INODE)) NFR = ND_LOAD( STEP_LOAD(SON) ) + KEEP_LOAD(253) IN=SON NELIM = 0 20 CONTINUE IF ( IN > 0 ) THEN NELIM = NELIM + 1 IN = FILS_LOAD(IN) GOTO 20 ENDIF COST_CB=COST_CB+((NFR-NELIM)*(NFR-NELIM)) SON=FRERE_LOAD(STEP_LOAD(SON)) ENDDO MUMPS_LOAD_GET_CB_FREED=COST_CB RETURN END FUNCTION MUMPS_LOAD_GET_CB_FREED SUBROUTINE MUMPS_LOAD_SEND_MD_INFO(SLAVEF,NMB_OF_CAND, & LIST_OF_CAND, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, & NSLAVES,INODE) USE MUMPS_BUF_COMMON USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, NASS, NSLAVES INTEGER, INTENT (IN) :: NMB_OF_CAND INTEGER, INTENT (IN) :: LIST_OF_CAND(NMB_OF_CAND) INTEGER, INTENT (IN) :: TAB_POS(SLAVEF+2) INTEGER, INTENT (IN) :: LIST_SLAVES(NSLAVES) INTEGER KEEP(500),INODE INTEGER(8) KEEP8(150) INTEGER allocok DOUBLE PRECISION MEM_COST,FCT_COST DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE :: DELTA_MD INTEGER, DIMENSION(:), ALLOCATABLE :: IPROC2POSINDELTAMD INTEGER, DIMENSION(:), ALLOCATABLE :: P_TO_UPDATE INTEGER NBROWS_SLAVE,i,WHAT,IERR INTEGER :: NP_TO_UPDATE, K LOGICAL :: EXIT_FLAG MEM_COST=dble(0) FCT_COST=dble(0) CALL MUMPS_LOAD_GET_ESTIM_MEM_COST(INODE,FCT_COST, & MEM_COST,NMB_OF_CAND,NASS) ALLOCATE(IPROC2POSINDELTAMD(0:SLAVEF-1), & DELTA_MD(min(SLAVEF, NMB_OF_CAND+NSLAVES)), & P_TO_UPDATE(min(SLAVEF, NMB_OF_CAND+NSLAVES)), & stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) "PB ALLOC IN MUMPS_LOAD_SEND_MD_INFO", & SLAVEF, NMB_OF_CAND, NSLAVES CALL MUMPS_ABORT() ENDIF IPROC2POSINDELTAMD = -99 NP_TO_UPDATE = 0 DO i = 1, NSLAVES NP_TO_UPDATE = NP_TO_UPDATE + 1 IPROC2POSINDELTAMD (LIST_SLAVES(i)) = NP_TO_UPDATE NBROWS_SLAVE = TAB_POS(i+1) - TAB_POS(i) DELTA_MD(NP_TO_UPDATE)=-dble(NBROWS_SLAVE)* & dble(NASS) P_TO_UPDATE(NP_TO_UPDATE) = LIST_SLAVES(i) ENDDO DO i = 1, NMB_OF_CAND K = IPROC2POSINDELTAMD(LIST_OF_CAND(i)) IF ( K > 0 ) THEN DELTA_MD(K)=DELTA_MD(K)+FCT_COST ELSE NP_TO_UPDATE = NP_TO_UPDATE + 1 IPROC2POSINDELTAMD (LIST_OF_CAND(i)) = NP_TO_UPDATE DELTA_MD (NP_TO_UPDATE) = FCT_COST P_TO_UPDATE(NP_TO_UPDATE) = LIST_OF_CAND(i) ENDIF ENDDO WHAT=7 111 CONTINUE CALL MUMPS_BUF_BCAST_ARRAY(.FALSE., COMM_LD, MYID, SLAVEF, & FUTURE_NIV2, & NP_TO_UPDATE, P_TO_UPDATE,0, & DELTA_MD, & DELTA_MD, & DELTA_MD, & WHAT, KEEP, IERR) IF ( IERR == -1 ) THEN CALL MUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error 2 in MUMPS_LOAD_SEND_MD_INFO", & IERR CALL MUMPS_ABORT() ENDIF IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN DO i = 1, NP_TO_UPDATE MD_MEM(P_TO_UPDATE(i))=MD_MEM(P_TO_UPDATE(i))+ & int(DELTA_MD( i ),8) IF(FUTURE_NIV2(P_TO_UPDATE(i)+1).EQ.0)THEN MD_MEM(P_TO_UPDATE(i))=999999999_8 ENDIF ENDDO ENDIF 100 CONTINUE DEALLOCATE(DELTA_MD,P_TO_UPDATE,IPROC2POSINDELTAMD) RETURN END SUBROUTINE MUMPS_LOAD_SEND_MD_INFO SUBROUTINE MUMPS_LOAD_GET_ESTIM_MEM_COST(INODE,FCT_COST, & MEM_COST,NSLAVES,NELIM) IMPLICIT NONE INTEGER INODE,NSLAVES,NFR,NELIM DOUBLE PRECISION MEM_COST,FCT_COST NFR=ND_LOAD(STEP_LOAD(INODE)) + KEEP_LOAD(253) FCT_COST=dble(int(dble(NFR-NELIM)/dble(NSLAVES))+1)* & dble(NELIM) MEM_COST=dble(int(dble(NFR-NELIM)/dble(NSLAVES))+1)* & dble(NFR) RETURN END SUBROUTINE MUMPS_LOAD_GET_ESTIM_MEM_COST SUBROUTINE MUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER INODE INTEGER i,J,SON,NSLAVES_TEMP,POS_TEMP,K INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE IF((INODE.LT.0).OR.(INODE.GT.N_LOAD))THEN RETURN ENDIF IF(POS_ID.GT.1)THEN i=INODE 10 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 10 ENDIF SON=-i IF(POS_ID.LT.NE_LOAD(STEP_LOAD(INODE))*3)THEN i=1 ENDIF DO i=1, NE_LOAD(STEP_LOAD(INODE)) J=1 DO WHILE (J.LT.POS_ID) IF(CB_COST_ID(J).EQ.SON)GOTO 295 J=J+3 ENDDO 295 CONTINUE IF(J.GE.POS_ID)THEN IF ( MUMPS_PROCNODE( & PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199) ) .EQ. MYID ) THEN IF(INODE.EQ.KEEP_LOAD(38))THEN GOTO 666 ELSE IF(FUTURE_NIV2(MYID+1).NE.0)THEN WRITE(*,*)MYID,': i did not find ',SON CALL MUMPS_ABORT() ENDIF GOTO 666 ENDIF ELSE GOTO 666 ENDIF ENDIF NSLAVES_TEMP=CB_COST_ID(J+1) POS_TEMP=CB_COST_ID(J+2) DO K=J,POS_ID-1 CB_COST_ID(K)=CB_COST_ID(K+3) ENDDO K=POS_TEMP DO WHILE (K.LE.POS_MEM-1) CB_COST_MEM(K)=CB_COST_MEM(K+2*NSLAVES_TEMP) K=K+1 ENDDO POS_MEM=POS_MEM-2*NSLAVES_TEMP POS_ID=POS_ID-3 IF((POS_MEM.LT.1).OR.(POS_ID.LT.1))THEN WRITE(*,*)MYID,': negative pos_mem or pos_id' CALL MUMPS_ABORT() ENDIF 666 CONTINUE SON=FRERE_LOAD(STEP_LOAD(SON)) ENDDO ENDIF END SUBROUTINE MUMPS_LOAD_CLEAN_MEMINFO_POOL SUBROUTINE MUMPS_LOAD_CHK_MEMCST_POOL(FLAG) IMPLICIT NONE LOGICAL FLAG INTEGER i DOUBLE PRECISION MEM FLAG=.FALSE. DO i=0,NPROCS-1 MEM=DM_MEM(i)+LU_USAGE(i) IF(BDC_SBTR)THEN MEM=MEM+SBTR_MEM(i)-SBTR_CUR(i) ENDIF IF((MEM/dble(TAB_MAXS(i))).GT.0.8d0)THEN FLAG=.TRUE. GOTO 666 ENDIF ENDDO 666 CONTINUE END SUBROUTINE MUMPS_LOAD_CHK_MEMCST_POOL SUBROUTINE MUMPS_CHECK_SBTR_COST(NBINSUBTREE,INSUBTREE,NBTOP, & MIN_COST,SBTR) IMPLICIT NONE INTEGER NBINSUBTREE,INSUBTREE,NBTOP DOUBLE PRECISION MIN_COST LOGICAL SBTR INTEGER i DOUBLE PRECISION TMP_COST,TMP_MIN TMP_MIN=huge(TMP_MIN) DO i=0,NPROCS-1 IF(i.NE.MYID)THEN IF(BDC_SBTR)THEN TMP_MIN=min(TMP_MIN,dble(TAB_MAXS(i))-(DM_MEM(i)+ & LU_USAGE(i))-(SBTR_MEM(i)-SBTR_CUR(i))) ELSE TMP_MIN=min(TMP_MIN,dble(TAB_MAXS(i))- & (DM_MEM(i)+LU_USAGE(i))) ENDIF ENDIF ENDDO IF(NBINSUBTREE.GT.0)THEN IF(INSUBTREE.EQ.1)THEN TMP_COST=dble(TAB_MAXS(MYID))-(DM_MEM(MYID)+ & LU_USAGE(MYID)) & -(SBTR_MEM(MYID)-SBTR_CUR(MYID)) ELSE SBTR=.FALSE. GOTO 777 ENDIF ENDIF TMP_MIN=min(TMP_COST,TMP_MIN) IF(TMP_MIN.GT.MIN_COST) SBTR=.TRUE. 777 CONTINUE END SUBROUTINE MUMPS_CHECK_SBTR_COST SUBROUTINE MUMPS_LOAD_COMP_MAXMEM_POOL(INODE,MAX_MEM,PROC) USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER INODE,PROC INTEGER i,POS,NSLAVES,SLAVE,NCAND,J,NELIM,NCB,NFRONT,SON,K INTEGER allocok EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE DOUBLE PRECISION MAX_MEM DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: MEM_ON_PROCS, & RECV_BUF LOGICAL, DIMENSION(:), ALLOCATABLE :: CONCERNED IF((FRERE_LOAD(STEP_LOAD(INODE)).EQ.0) & .AND.(INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF ALLOCATE( MEM_ON_PROCS(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in MUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF ALLOCATE( CONCERNED(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in MUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF ALLOCATE( RECV_BUF(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in MUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF RECV_BUF=dble(0) i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF SON=-i NFRONT=ND_LOAD(STEP_LOAD(INODE)) + KEEP_LOAD(253) NCB=NFRONT-NELIM IF(MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199)).EQ.2)THEN NCAND=CAND_LOAD(NPROCS+1, STEP_TO_NIV2_LOAD(STEP_LOAD(INODE))) ENDIF DO i=0,NPROCS-1 IF(i.EQ.MYID)THEN MEM_ON_PROCS(i)=dble(TAB_MAXS(i))-(DM_MEM(i)+ & LU_USAGE(i)+ & MUMPS_LOAD_GET_MEM(INODE)) IF(BDC_SBTR)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)-(SBTR_MEM(i)-SBTR_CUR(i)) ENDIF CONCERNED(i)=.TRUE. ELSE MEM_ON_PROCS(i)=dble(TAB_MAXS(i))-(DM_MEM(i)+LU_USAGE(i)) IF(BDC_SBTR)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)-(SBTR_MEM(i)-SBTR_CUR(i)) ENDIF IF(BDC_M2_MEM)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)-NIV2(i+1) ENDIF ENDIF IF(MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199)).EQ.2)THEN IF(BDC_MD.AND.(KEEP_LOAD(48).EQ.5))THEN DO J=1,NCAND IF(CAND_LOAD(J, STEP_TO_NIV2_LOAD(STEP_LOAD(INODE))) & .EQ.i)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)- & ((dble(NFRONT)*dble(NCB))/dble(NCAND)) CONCERNED(i)=.TRUE. GOTO 666 ENDIF ENDDO ENDIF ENDIF 666 CONTINUE ENDDO DO K=1, NE_LOAD(STEP_LOAD(INODE)) i=1 DO WHILE (i.LE.POS_ID) IF(CB_COST_ID(i).EQ.SON)GOTO 295 i=i+3 ENDDO 295 CONTINUE IF(i.GE.POS_ID)THEN IF(FUTURE_NIV2(MYID+1).NE.0)THEN WRITE(*,*)MYID,': ',SON,'has not been found & in MUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF GOTO 777 ENDIF NSLAVES=CB_COST_ID(i+1) POS=CB_COST_ID(i+2) DO i=1,NSLAVES SLAVE=int(CB_COST_MEM(POS)) IF(.NOT.CONCERNED(SLAVE))THEN MEM_ON_PROCS(SLAVE)=MEM_ON_PROCS(SLAVE)+ & dble(CB_COST_MEM(POS+1)) ENDIF DO J=0,NPROCS-1 IF(CONCERNED(J))THEN IF(SLAVE.NE.J)THEN RECV_BUF(J)=max(RECV_BUF(J), & dble(CB_COST_MEM(POS+1))) ENDIF ENDIF ENDDO POS=POS+2 ENDDO 777 CONTINUE SON=FRERE_LOAD(STEP_LOAD(SON)) ENDDO MAX_MEM=huge(MAX_MEM) WRITE(*,*)'NPROCS=',NPROCS,MAX_MEM DO i=0,NPROCS-1 IF(MAX_MEM.GT.MEM_ON_PROCS(i))THEN PROC=i ENDIF MAX_MEM=min(MEM_ON_PROCS(i),MAX_MEM) ENDDO DEALLOCATE(MEM_ON_PROCS) DEALLOCATE(CONCERNED) DEALLOCATE(RECV_BUF) END SUBROUTINE MUMPS_LOAD_COMP_MAXMEM_POOL SUBROUTINE MUMPS_FIND_BEST_NODE_FOR_MEM(MIN_PROC,POOL, & LPOOL,INODE) IMPLICIT NONE INTEGER INODE,LPOOL,MIN_PROC INTEGER POOL(LPOOL) EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER i,NBTOP,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) IF((KEEP_LOAD(47).EQ.4).AND. & ((NBINSUBTREE.NE.0)))THEN DO J=INDICE_SBTR,NB_SUBTREES NODE=MY_ROOT_SBTR(J) FATHER=DAD_LOAD(STEP_LOAD(NODE)) i=FATHER 110 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 110 ENDIF SON=-i i=SON 120 CONTINUE IF ( i > 0 ) THEN IF( MUMPS_PROCNODE(PROCNODE_LOAD(STEP_LOAD(i)), & KEEP_LOAD(199)) .EQ. MIN_PROC ) THEN SBTR_NB_LEAF=MY_NB_LEAF(J) POS=SBTR_FIRST_POS_IN_POOL(J) IF(POOL(POS+SBTR_NB_LEAF).NE.MY_FIRST_LEAF(J))THEN WRITE(*,*)MYID,': The first leaf is not ok' CALL MUMPS_ABORT() ENDIF ALLOCATE (TMP_SBTR(SBTR_NB_LEAF), stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*)MYID,': Not enough space & for allocation' CALL MUMPS_ABORT() ENDIF POS=SBTR_FIRST_POS_IN_POOL(J) DO K=1,SBTR_NB_LEAF TMP_SBTR(K)=POOL(POS+K-1) ENDDO DO K=POS+1,NBINSUBTREE-SBTR_NB_LEAF POOL(K)=POOL(K+SBTR_NB_LEAF) ENDDO POS=1 DO K=NBINSUBTREE-SBTR_NB_LEAF+1,NBINSUBTREE POOL(K)=TMP_SBTR(POS) POS=POS+1 ENDDO DO K=INDICE_SBTR,J SBTR_FIRST_POS_IN_POOL(K)=SBTR_FIRST_POS_IN_POOL(K) & -SBTR_FIRST_POS_IN_POOL(J) ENDDO SBTR_FIRST_POS_IN_POOL(J)=NBINSUBTREE-SBTR_NB_LEAF POS=MY_FIRST_LEAF(J) L=MY_NB_LEAF(J) DO K=INDICE_SBTR,J MY_FIRST_LEAF(J)=MY_FIRST_LEAF(J+1) MY_NB_LEAF(J)=MY_NB_LEAF(J+1) ENDDO MY_FIRST_LEAF(INDICE_SBTR)=POS MY_NB_LEAF(INDICE_SBTR)=L INODE=POOL(NBINSUBTREE) DEALLOCATE(TMP_SBTR) RETURN ENDIF i = FRERE_LOAD(STEP_LOAD(i)) GOTO 120 ENDIF ENDDO ENDIF DO J=NBTOP,1,-1 NODE=POOL(LPOOL-2-J) FATHER=DAD_LOAD(STEP_LOAD(NODE)) i=FATHER 11 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 11 ENDIF SON=-i i=SON 12 CONTINUE IF ( i > 0 ) THEN IF( MUMPS_PROCNODE(PROCNODE_LOAD(STEP_LOAD(i)), & KEEP_LOAD(199)) .EQ. MIN_PROC ) THEN INODE=NODE RETURN ENDIF i = FRERE_LOAD(STEP_LOAD(i)) GOTO 12 ENDIF ENDDO END SUBROUTINE MUMPS_FIND_BEST_NODE_FOR_MEM SUBROUTINE MUMPS_LOAD_INIT_SBTR_STRUCT(POOL, LPOOL,KEEP,KEEP8) IMPLICIT NONE INTEGER LPOOL,POOL(LPOOL),KEEP(500) INTEGER(8) KEEP8(150) INTEGER i,POS EXTERNAL MUMPS_ROOTSSARBR LOGICAL MUMPS_ROOTSSARBR IF(.NOT.BDC_SBTR) RETURN POS=0 DO i=NB_SUBTREES,1,-1 DO WHILE(MUMPS_ROOTSSARBR( & PROCNODE_LOAD(STEP_LOAD(POOL(POS+1))), & KEEP(199))) POS=POS+1 ENDDO SBTR_FIRST_POS_IN_POOL(i)=POS+1 POS=POS+MY_NB_LEAF(i) ENDDO END SUBROUTINE MUMPS_LOAD_INIT_SBTR_STRUCT END MODULE MUMPS_LOAD MUMPS_5.8.1/src/cfac_root_parallel.F0000664000175000017500000001733715042446440017165 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_FACTO_ROOT( & MPA, MYID, MASTER_OF_ROOT, & root, roota, N, IROOT, & COMM, IW, LIW, IFREE, & A, LA, PTRAST, PTLUST_S, PTRFAC, & STEP, INFO, LDLT, QR, & WK, LWK, KEEP,KEEP8,DKEEP,OPELIW, & DET_EXP, DET_MANT, DET_SIGN & ) USE MUMPS_LR_STATS, ONLY: UPD_FLOP_ROOT USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE ( MUMPS_ROOT_STRUC ) :: root TYPE ( CMUMPS_ROOT_STRUC ) :: roota INTEGER, INTENT(IN) :: MPA INTEGER N, IROOT, COMM, LIW, MYID, IFREE, MASTER_OF_ROOT INTEGER(8) :: LA INTEGER(8) :: LWK COMPLEX WK( LWK ) INTEGER KEEP(500) REAL DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTLUST_S(KEEP(28)), STEP(N), IW( LIW ) INTEGER INFO( 2 ), LDLT, QR COMPLEX A( LA ) DOUBLE PRECISION, intent(inout) :: OPELIW INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP COMPLEX, INTENT(INOUT) :: DET_MANT #if ! defined(NOSCALAPACK) INTEGER IOLDPS INTEGER(8) :: IAPOS INTEGER LOCAL_M, LOCAL_N, LPIV, IERR DOUBLE PRECISION :: FLOPS_ROOT INTEGER(8) :: ENTRIES_ROOT INTEGER allocok INTEGER FWD_LOCAL_N_RHS, FWD_MTYPE #endif INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_NUMROC IF ( .NOT. root%yes ) RETURN IF ( KEEP(60) .NE. 0 ) THEN IF ((LDLT == 1 .OR. LDLT == 2) .AND. KEEP(60) == 3 ) THEN CALL CMUMPS_SYMMETRIZE( WK, root%MBLOCK, & root%MYROW, root%MYCOL, root%NPROW, root%NPCOL, & roota%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_NLOC, & root%TOT_ROOT_SIZE, MYID, COMM ) ENDIF RETURN ENDIF #if ! defined(NOSCALAPACK) IF (MPA.GT.0) THEN IF (MYID.EQ.MASTER_OF_ROOT) THEN CALL MUMPS_GET_FLOPS_COST & (root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & LDLT, 3, FLOPS_ROOT) WRITE(MPA,'(A, A, 1PD10.3)') & " ... Start processing the root node with ScaLAPACK, ", & " remaining flops = ", FLOPS_ROOT ENDIF ENDIF IOLDPS = PTLUST_S(STEP(IROOT))+KEEP(IXSZ) IAPOS = PTRAST(STEP(IROOT)) LOCAL_M = IW( IOLDPS + 2 ) LOCAL_N = IW( IOLDPS + 1 ) IAPOS = PTRFAC(IW ( IOLDPS + 4 )) IF ( LDLT.EQ.0 .OR. LDLT.EQ.2 .OR. QR.ne.0 ) THEN LPIV = LOCAL_M + root%MBLOCK ELSE LPIV = 1 END IF IF (associated( root%IPIV )) DEALLOCATE(root%IPIV) root%LPIV = LPIV ALLOCATE( root%IPIV( LPIV ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LPIV WRITE(*,*) MYID,': problem allocating IPIV(',LPIV,') in root' CALL MUMPS_ABORT() END IF CALL DESCINIT( root%DESCRIPTOR(1), root%TOT_ROOT_SIZE, & root%TOT_ROOT_SIZE, root%MBLOCK, root%NBLOCK, & 0, 0, root%CNTXT_BLACS, LOCAL_M, IERR ) IF ( LDLT.EQ.2 ) THEN IF(root%MBLOCK.NE.root%NBLOCK) THEN WRITE(*,*) ' Error: symmetrization only works for' WRITE(*,*) ' square block sizes, MBLOCK/NBLOCK=', & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() END IF IF ( LWK .LT. min( & int(root%MBLOCK,8) * int(root%NBLOCK,8), & int(root%TOT_ROOT_SIZE,8)* int(root%TOT_ROOT_SIZE,8 ) & )) THEN WRITE(*,*) 'Not enough workspace for symmetrization.' CALL MUMPS_ABORT() END IF CALL CMUMPS_SYMMETRIZE( WK, root%MBLOCK, & root%MYROW, root%MYCOL, root%NPROW, root%NPCOL, & A( IAPOS ), LOCAL_M, LOCAL_N, & root%TOT_ROOT_SIZE, MYID, COMM ) END IF IF (LDLT.EQ.0.OR.LDLT.EQ.2) THEN CALL pcgetrf( root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & A( IAPOS ), & 1, 1, root%DESCRIPTOR(1), root%IPIV(1), IERR ) IF ( IERR .GT. 0 ) THEN INFO(1)=-10 INFO(2)=IERR-1 END IF ELSE CALL pcpotrf('L',root%TOT_ROOT_SIZE,A(IAPOS), & 1,1,root%DESCRIPTOR(1),IERR) IF ( IERR .GT. 0 ) THEN INFO(1)=-40 INFO(2)=IERR-1 END IF END IF IF (IERR .GT. 0) THEN CALL MUMPS_UPDATE_FLOPS_ROOT( OPELIW, LDLT, & root%TOT_ROOT_SIZE, INFO(2), & root%NPROW, root%NPCOL, MYID ) IF (KEEP(486) .GT. 0) THEN CALL UPD_FLOP_ROOT( LDLT, & root%TOT_ROOT_SIZE, INFO(2), & root%NPROW, root%NPCOL, MYID ) ENDIF ELSE CALL MUMPS_UPDATE_FLOPS_ROOT( OPELIW, LDLT, & root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & root%NPROW, root%NPCOL, MYID ) IF (KEEP(486) .GT. 0) THEN CALL UPD_FLOP_ROOT( LDLT, & root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & root%NPROW, root%NPCOL, MYID ) ENDIF ENDIF IF ( LDLT .EQ. 0 ) THEN ENTRIES_ROOT = int(root%TOT_ROOT_SIZE,8) & * int(root%TOT_ROOT_SIZE,8) ELSE ENTRIES_ROOT = int(root%TOT_ROOT_SIZE,8) & * int(root%TOT_ROOT_SIZE+1,8)/2_8 ENDIF KEEP8(10)=KEEP8(10) + ENTRIES_ROOT / & int(root%NPROW * root%NPCOL,8) IF (MYID .eq. MASTER_OF_ROOT) THEN KEEP8(10)=KEEP8(10) + & mod(ENTRIES_ROOT, int(root%NPROW*root%NPCOL,8)) ENDIF CALL CMUMPS_PAR_ROOT_MINMAX_PIV_UPD ( & root%MBLOCK, root%IPIV(1),root%MYROW, & root%MYCOL, root%NPROW, root%NPCOL, A(IAPOS), LOCAL_M, & LOCAL_N, root%TOT_ROOT_SIZE, MYID, DKEEP, KEEP, LDLT) IF (KEEP(258).NE.0) THEN IF (root%MBLOCK.NE.root%NBLOCK) THEN write(*,*) "Internal error in CMUMPS_FACTO_ROOT:", & "Block size different for rows and columns", & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() ENDIF CALL CMUMPS_GETDETER2D(root%MBLOCK, root%IPIV(1),root%MYROW, & root%MYCOL, root%NPROW, root%NPCOL, A(IAPOS), LOCAL_M, & LOCAL_N, root%TOT_ROOT_SIZE, MYID, DET_MANT, DET_EXP, & LDLT) ENDIF IF (KEEP(252) .NE. 0) THEN FWD_LOCAL_N_RHS = MUMPS_NUMROC(KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL) FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) FWD_MTYPE = 1 CALL CMUMPS_SOLVE_2D_BCYCLIC( & root%TOT_ROOT_SIZE, & KEEP(253), & FWD_MTYPE, & A(IAPOS), & root%DESCRIPTOR(1), & LOCAL_M, LOCAL_N, FWD_LOCAL_N_RHS, & root%IPIV(1), LPIV, & roota%RHS_ROOT(1,1), LDLT, & root%MBLOCK, root%NBLOCK, & root%CNTXT_BLACS, IERR) ENDIF #endif RETURN END SUBROUTINE CMUMPS_FACTO_ROOT MUMPS_5.8.1/src/ctools.F0000664000175000017500000026644315042446440014661 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_COMPRESS_LU(SIZE_INPLACE, &MYID,N,IOLDPS,TYPE,IW, LIW, A, LA, &POSFAC, LRLU, LRLUS, IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, &SSARBR,INODE,IERR & , LRGROUPS, NASS &) USE MUMPS_LOAD USE CMUMPS_OOC !$ USE OMP_LIB USE CMUMPS_LR_CORE IMPLICIT NONE INTEGER MYID INTEGER IOLDPS, TYPE, LIW, N, KEEP(500) INTEGER(8) :: SIZE_INPLACE, LA, POSFAC, LRLU, LRLUS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) KEEP8(150) INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER IWPOS INTEGER STEP( N ) INTEGER (8) :: PTRFAC(KEEP(28)) LOGICAL SSARBR INTEGER IOLDSHIFT, IPSSHIFT INTEGER LRGROUPS(KEEP(280)), NASS INCLUDE 'mumps_headers.h' INTEGER LCONT, NELIM, NROW, NPIV, INTSIZ INTEGER NFRONT, NSLAVES INTEGER IPS, IPSIZE INTEGER(8) :: SIZELU, SIZENOTLU, IAPOS, I, SIZESHIFT, ITMP8 INTEGER(8) :: SIZEXXR LOGICAL LRCOMPRESS_PANEL INTEGER INODE INTEGER IERR IERR=0 IOLDSHIFT = IOLDPS + KEEP(IXSZ) IF ( IW( IOLDSHIFT ) < 0 ) THEN write(*,*) ' ERROR 1 compressLU:Should not point to a band.' CALL MUMPS_ABORT() ELSE IF ( IW( IOLDSHIFT + 2 ) < 0 ) THEN write(*,*) ' ERROR 2 compressLU:Stack not performed yet', & IW(IOLDSHIFT + 2) CALL MUMPS_ABORT() ENDIF LCONT = IW( IOLDSHIFT ) NELIM = IW( IOLDSHIFT + 1 ) NROW = IW( IOLDSHIFT + 2 ) NPIV = IW( IOLDSHIFT + 3 ) IAPOS = PTRFAC(IW( IOLDSHIFT + 4 )) NSLAVES= IW( IOLDSHIFT + 5 ) NFRONT = LCONT + NPIV INTSIZ = IW(IOLDPS+XXI) LRCOMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) IF ( (NSLAVES > 0 .AND. TYPE .NE. 2) .OR. & (NSLAVES .eq. 0 .AND. TYPE .EQ. 2 ) ) THEN WRITE(*,*) ' ERROR 3 compressLU: problem with level of inode' CALL MUMPS_ABORT() END IF IF ( KEEP(50) .EQ. 0 ) THEN IF (KEEP(251) .NE. 2) THEN SIZELU = int(LCONT + NROW, 8) * int(NPIV,8) ELSE SIZELU = NPIV * NFRONT ENDIF ELSE IF ( KEEP(459) .GT. 1 ) THEN CALL MUMPS_LDLTPANEL_STORAGE( NPIV, KEEP, & IW(IOLDSHIFT+6+NSLAVES+NFRONT), SIZELU) SIZELU = SIZELU + int( NROW - NPIV, 8 ) * int( NPIV, 8 ) ELSE SIZELU = int(NROW,8) * int(NPIV,8) ENDIF ENDIF CALL MUMPS_GETI8(SIZEXXR, IW(IOLDPS+XXR)) SIZENOTLU = SIZEXXR - SIZELU CALL MUMPS_SUBTRI8TOARRAY( IW(IOLDPS+XXR), SIZENOTLU ) IF ((KEEP(201).NE.0) & .OR.(LRCOMPRESS_PANEL.AND.KEEP(486).EQ.2) & ) THEN SIZESHIFT = SIZEXXR ELSE SIZESHIFT = SIZENOTLU IF (SIZENOTLU.EQ.0_8) THEN GOTO 500 ENDIF ENDIF IF (KEEP(201).EQ.2) THEN IF (KEEP(405) .EQ. 0) THEN KEEP8(31)=KEEP8(31)+SIZELU CALL CMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) ELSE !$OMP CRITICAL(critical_old_ooc) KEEP8(31)=KEEP8(31)+SIZELU CALL CMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) !$OMP END CRITICAL(critical_old_ooc) ENDIF IF(IERR.LT.0)THEN WRITE(*,*)MYID,': Internal error in CMUMPS_NEW_FACTOR' CALL MUMPS_ABORT() ENDIF ENDIF IF ( IOLDPS + INTSIZ .NE. IWPOS ) THEN IPS = IOLDPS + INTSIZ DO WHILE ( IPS .NE. IWPOS ) IPSIZE = IW(IPS+XXI) IPSSHIFT = IPS + KEEP(IXSZ) IF ( IPSIZE .LE. 0 .OR. IPS .GT. IWPOS ) THEN WRITE(*,*) " Internal error 1 CMUMPS_COMPRESS_LU" WRITE(*,*) " IOLDPS, INTSIZ, IWPOS, LIW=", & IOLDPS, INTSIZ, IWPOS, LIW WRITE(*,*) " IWPOS, IPS, IPSIZE =", IWPOS, IPS, IPSIZE WRITE(*,*) " Header at IOLDPS =", & IW(IOLDPS:IOLDPS+KEEP(IXSZ)+5) WRITE(*,*) " Header at IPS =", & IW(IPS:IPS+KEEP(IXSZ)+5) CALL MUMPS_ABORT() ENDIF IF (IPS+IPSIZE .GT. IWPOS) THEN WRITE(*,*) " Internal error 2 CMUMPS_COMPRESS_LU" WRITE(*,*) " IOLDPS, INTSIZ, IWPOS, LIW=", & IOLDPS, INTSIZ, IWPOS, LIW WRITE(*,*) " IWPOS, IPS, IPSIZE =", IWPOS, IPS, IPSIZE WRITE(*,*) " Header at IOLDPS =", & IW(IOLDPS:IOLDPS+KEEP(IXSZ)+5) WRITE(*,*) " Header at IOLDPS+INTSIZ =", & IW(IOLDPS+INTSIZ:IOLDPS+INTSIZ+KEEP(IXSZ)+5) WRITE(*,*) " Header at IPS =", & IW(IPS:IPS+KEEP(IXSZ)+5) WRITE(*,*) " ========================== " WRITE(*,*) " Headers starting at IOLDPS:" IPS = IOLDPS DO WHILE (IPS .LE. IWPOS) WRITE(*,*) " -> new IW header at position" , IPS, ":", & IW(IPS:IPS+KEEP(IXSZ)+5) IPS = IPS + IW(IPS+XXI) ENDDO CALL MUMPS_ABORT() ENDIF IF ( IW( IPSSHIFT + 2 ) < 0 ) THEN NFRONT = IW( IPSSHIFT ) IF (IW(IPSSHIFT+4) .LT. 0) THEN WRITE(*,*) " Internal error 3 CMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW(IPSSHIFT+4))=PTRFAC(IW(IPSSHIFT+4)) & - SIZESHIFT PTRAST(IW(IPSSHIFT+4))=PTRAST(IW(IPSSHIFT+4)) & - SIZESHIFT ELSE IF ( IW( IPSSHIFT ) < 0 ) THEN IF (IW(IPSSHIFT+3) .LT. 0) THEN WRITE(*,*) " Internal error 4 CMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW(IPSSHIFT+3)) = PTRFAC(IW(IPSSHIFT+3)) & -SIZESHIFT ELSE NFRONT = IW( IPSSHIFT ) + IW( IPSSHIFT + 3 ) IF (IW(IPSSHIFT+4) .LT. 0) THEN WRITE(*,*) " Internal error 4 CMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZESHIFT END IF IPS = IPS + IPSIZE END DO IF (SIZESHIFT .NE. 0_8) THEN DO I=IAPOS+SIZEXXR-SIZESHIFT, POSFAC-SIZESHIFT-1_8 A( I ) = A( I + SIZESHIFT) END DO END IF ENDIF POSFAC = POSFAC - SIZESHIFT LRLU = LRLU + SIZESHIFT ITMP8 = SIZESHIFT - SIZE_INPLACE LRLUS = LRLUS + ITMP8 IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) - ITMP8 ELSE !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - ITMP8 !$OMP END ATOMIC ENDIF 500 CONTINUE IF (LRCOMPRESS_PANEL.AND.KEEP(486).EQ.2) THEN CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & -SIZESHIFT+SIZE_INPLACE, & KEEP,KEEP8,LRLUS) ELSE CALL MUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,SIZELU,-SIZENOTLU+SIZE_INPLACE, & KEEP,KEEP8,LRLUS) ENDIF RETURN END SUBROUTINE CMUMPS_COMPRESS_LU SUBROUTINE CMUMPS_STACK_BAND( N, ISON, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP, KEEP8, DKEEP, TYPE_SON & ) !$ USE OMP_LIB USE CMUMPS_OOC USE MUMPS_LOAD USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER(8) :: LA, LRLU, LRLUS, POSFAC, IPTRLU INTEGER N, ISON, LIW, IWPOS, IWPOSCB, & COMP, IFLAG, IERROR, SLAVEF, MYID, COMM, & TYPE_SON INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), IW(LIW) INTEGER PTLUST_S(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION OPELIW DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE COMPLEX A( LA ) INTEGER(8) :: LREQA, POSA, POSALOC, OLDPOS, JJ INTEGER NFRONT, NCOL_L, NROW_L, LREQI, NSLAVES_L, & POSI, I, IROW_L, ICOL_L, LDA_BAND, NASS LOGICAL NONEED_TO_COPY_FACTORS INTEGER(8) :: LREQA_HEADER INTEGER LIWFAC, STRAT, TYPEFile, NextPivDummy, & IOLDPS_CB LOGICAL LAST_CALL TYPE(IO_BLOCK) :: MonBloc INTEGER LRSTATUS INCLUDE 'mumps_headers.h' DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0d0) COMPLEX, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: IACHK, SIZFR_SON_A, ITMP8 FLOP1 = ZERO NCOL_L = IW( PTRIST(STEP( ISON )) + 3 + KEEP(IXSZ) ) NROW_L = IW( PTRIST(STEP( ISON )) + 2 + KEEP(IXSZ) ) NSLAVES_L = IW( PTRIST(STEP( ISON )) + 5 + KEEP(IXSZ) ) LRSTATUS = IW( PTRIST(STEP( ISON )) + XXLR) LDA_BAND = NCOL_L + IW( PTRIST(STEP( ISON )) + KEEP(IXSZ) ) IF ( KEEP(50) .eq. 0 ) THEN NFRONT = LDA_BAND ELSE NFRONT = IW( PTRIST(STEP( ISON )) + 7 + KEEP(IXSZ) ) END IF IF (KEEP(201).EQ.1) THEN IOLDPS_CB = PTRIST(STEP( ISON )) LIWFAC = IW(IOLDPS_CB+XXI) TYPEFile = TYPEF_L NextPivDummy = -8888 MonBloc%INODE = ISON MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW_L MonBloc%NCOL = LDA_BAND MonBloc%NFS = IW(IOLDPS_CB+1+KEEP(IXSZ)) MonBloc%LastPiv = NCOL_L MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX LAST_CALL = .TRUE. MonBloc%Last = .TRUE. CALL CMUMPS_DM_SET_DYNPTR(IW(PTRIST(STEP(ISON))+XXS), & A, LA, PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR_SON_A) CALL CMUMPS_OOC_IO_LU_PANEL_I & ( STRAT, TYPEFile, & SON_A(IACHK), SIZFR_SON_A, MonBloc, & NextPivDummy, NextPivDummy, & IW(IOLDPS_CB), LIWFAC, & MYID, KEEP8(31), IFLAG,LAST_CALL ) IF ((NCOL_L.EQ.0).OR.(NROW_L.EQ.0)) THEN ENDIF ENDIF NONEED_TO_COPY_FACTORS = ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.-1) & .OR. KEEP(251) .EQ. 2 & .OR. (LRSTATUS.GE.2.AND.KEEP(486).EQ.2) & ) IF ((NCOL_L.EQ.0).OR.(NROW_L.EQ.0)) THEN GOTO 80 ENDIF LREQI = 4 + NCOL_L + NROW_L + KEEP(IXSZ) LREQA_HEADER = int(NCOL_L,8) * int(NROW_L,8) IF (NONEED_TO_COPY_FACTORS) THEN LREQA = 0_8 ELSE LREQA = LREQA_HEADER ENDIF IF ( LRLU .LT. LREQA .OR. & IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LREQA ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) GO TO 700 END IF CALL CMUMPS_COMPRE_NEW( N, KEEP, IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS,IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress CMUMPS_STACK_BAND:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) GOTO 700 END IF IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB GOTO 700 END IF END IF IF (.NOT. NONEED_TO_COPY_FACTORS) THEN POSA = POSFAC POSFAC = POSFAC + LREQA LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) IF(KEEP(201).NE.2)THEN CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,LREQA,LREQA,KEEP,KEEP8,LRLUS) ELSE CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) ENDIF ENDIF POSI = IWPOS IWPOS = IWPOS + LREQI PTLUST_S(STEP( ISON )) = POSI IW(POSI:POSI+KEEP(IXSZ)-1)=-99999 IW(POSI+XXS)=-9999 IW(POSI+XXI)=LREQI CALL MUMPS_STOREI8(0_8, IW(POSI+XXD)) CALL MUMPS_STOREI8(LREQA, IW(POSI+XXR)) CALL MUMPS_STOREI8(LREQA_HEADER, IW(POSI+XXR)) IW(POSI+XXLR) = LRSTATUS IW(POSI+XXF) = IW(PTRIST(STEP(ISON))+XXF) POSI=POSI+KEEP(IXSZ) IW( POSI ) = - NCOL_L IW( POSI + 1 ) = NROW_L IW( POSI + 2 ) = NFRONT - NCOL_L IW( POSI + 3 ) = STEP(ISON) IF (.NOT. NONEED_TO_COPY_FACTORS) THEN PTRFAC(STEP(ISON)) = POSA ELSE PTRFAC(STEP(ISON)) = -77777_8 ENDIF IROW_L = PTRIST(STEP(ISON)) + 6 + NSLAVES_L + KEEP(IXSZ) ICOL_L = PTRIST(STEP(ISON)) + 6 + NROW_L + NSLAVES_L + KEEP(IXSZ) DO I = 1, NROW_L IW( POSI+3+I ) = IW( IROW_L+I-1 ) ENDDO DO I = 1, NCOL_L IW( POSI+NROW_L+3+I) = IW( ICOL_L+I-1 ) ENDDO IF (.NOT.NONEED_TO_COPY_FACTORS) THEN CALL CMUMPS_DM_SET_DYNPTR(IW(PTRIST(STEP(ISON))+XXS), & A, LA, PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR_SON_A) IF (int(NROW_L,8)*int(NCOL_L,8).GT.int(KEEP(361),8)) THEN !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(I,JJ,OLDPOS,POSALOC) DO I = 1, NROW_L DO JJ = 0_8, int(NCOL_L-1,8) OLDPOS = IACHK + int(I-1,8)*int(LDA_BAND,8) POSALOC = POSA + int(NCOL_L,8)*int(I-1,8) A( POSALOC+JJ ) = SON_A( OLDPOS+JJ ) ENDDO END DO !$OMP END PARALLEL DO ELSE POSALOC = POSA DO I = 1, NROW_L OLDPOS = IACHK + int(I-1,8)*int(LDA_BAND,8) DO JJ = 0_8, int(NCOL_L-1,8) A( POSALOC+JJ ) = SON_A( OLDPOS+JJ ) ENDDO POSALOC = POSALOC + int(NCOL_L,8) END DO ENDIF ENDIF ITMP8 = int(NCOL_L,8) * int(NROW_L,8) IF (KEEP(405) .EQ.1) THEN !$OMP ATOMIC UPDATE KEEP8(10) = KEEP8(10) + ITMP8 !$OMP END ATOMIC ELSE KEEP8(10) = KEEP8(10) + ITMP8 ENDIF IF (KEEP(201).EQ.2) THEN IF (KEEP(405).EQ.0) THEN KEEP8(31)=KEEP8(31)+LREQA CALL CMUMPS_NEW_FACTOR(ISON,PTRFAC,KEEP,KEEP8,A,LA,LREQA,IFLAG) ELSE !$OMP CRITICAL(critical_old_ooc) KEEP8(31)=KEEP8(31)+LREQA CALL CMUMPS_NEW_FACTOR(ISON,PTRFAC,KEEP,KEEP8,A,LA,LREQA,IFLAG) !$OMP END CRITICAL(critical_old_ooc) ENDIF IF(IFLAG.LT.0)THEN WRITE(*,*)MYID,': Internal error in CMUMPS_NEW_FACTOR' IERROR=0 GOTO 700 ENDIF POSFAC = POSFAC - LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - LREQA !$OMP END ATOMIC CALL MUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,LREQA,0_8,KEEP,KEEP8,LRLUS) ENDIF 80 CONTINUE IF (TYPE_SON == 1) THEN GOTO 90 ENDIF IF ( KEEP(50) .eq. 0 ) THEN FLOP1 = dble( NCOL_L * NROW_L) + & dble(NROW_L*NCOL_L)*dble(2*NFRONT-NCOL_L-1) ELSE FLOP1 = dble( NCOL_L ) * dble( NROW_L ) & * dble( 2 * LDA_BAND - NROW_L - NCOL_L + 1) END IF OPELIW = OPELIW + FLOP1 FLOP1_EFFECTIVE = FLOP1 NASS = IW( PTRIST(STEP( ISON )) + 4 + KEEP(IXSZ) ) IF ( NCOL_L .NE. NASS ) THEN IF ( KEEP(50).eq.0 ) THEN FLOP1 = dble( NASS * NROW_L) + & dble(NROW_L*NASS)*dble(2*NFRONT-NASS-1) ELSE FLOP1 = dble( NASS ) * dble( NROW_L ) * & dble( 2 * LDA_BAND - NROW_L - NASS + 1) END IF END IF CALL MUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) CALL MUMPS_LOAD_UPDATE(2,.FALSE.,-FLOP1,KEEP,KEEP8) 90 CONTINUE RETURN 700 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE CMUMPS_STACK_BAND SUBROUTINE CMUMPS_FREE_BAND( N, ISON, & PTRIST, PTRAST, IW, LIW, A, LA, & LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON & ) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_PTR, & CMUMPS_DM_FREE_BLOCK IMPLICIT NONE INTEGER(8) :: LRLU, LRLUS, IPTRLU, LA INTEGER ISON, MYID, N, IWPOSCB, TYPE_SON INTEGER KEEP(500), STEP(N) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)) INTEGER LIW INTEGER IW(LIW) COMPLEX A(LA) INTEGER ISTCHK INTEGER(8) :: DYN_SIZE COMPLEX, DIMENSION(:), POINTER :: FORTRAN_POINTER INTEGER :: XXG_STATUS INCLUDE 'mumps_headers.h' ISTCHK = PTRIST(STEP(ISON)) CALL MUMPS_GETI8( DYN_SIZE, IW(ISTCHK+XXD) ) XXG_STATUS = IW(ISTCHK+XXG) IF (DYN_SIZE .GT. 0_8) THEN CALL CMUMPS_DM_SET_PTR( PTRAST(STEP(ISON)), & DYN_SIZE, FORTRAN_POINTER ) ENDIF CALL CMUMPS_FREE_BLOCK_CB_STATIC(.FALSE.,MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) IF (DYN_SIZE .GT. 0_8) THEN CALL CMUMPS_DM_FREE_BLOCK(XXG_STATUS, FORTRAN_POINTER, DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF PTRIST(STEP( ISON )) = -9999888 PTRAST(STEP( ISON )) = -9999888_8 RETURN END SUBROUTINE CMUMPS_FREE_BAND SUBROUTINE CMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, KEEP, KEEP8, & MYID, COMM, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & INFO, INFOG, PROK, MP, PROKG, MPG & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: PROK, PROKG, SUM_OF_PEAKS INTEGER , INTENT(IN) :: MYID, COMM, N, NELT, NSLAVES, & LNA, MP, MPG INTEGER(8), INTENT(IN):: NA_ELT8, NNZ8 INTEGER, INTENT(IN):: NA(LNA) INTEGER :: KEEP(500), INFO(80), INFOG(80) INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER, PARAMETER :: MASTER = 0 INTEGER :: OOC_STAT, BLR_STRAT, BLR_CASE INTEGER :: IRANK LOGICAL :: EFF, PERLU_ON, COMPUTE_MAXAVG INTEGER(8) :: TOTAL_BYTES INTEGER :: TOTAL_MBYTES INTEGER(8) :: TOTAL_BYTES_UNDER_L0 INTEGER :: TOTAL_MBYTES_UNDER_L0 INTEGER, DIMENSION(3) :: LRLU_UD, OOC_LRLU_UD INTEGER, DIMENSION(3) :: & LRLUCB_UD, OOC_LRLUCB_UD, & LRCB_UD, OOC_LRCB_UD PERLU_ON = .TRUE. EFF = .FALSE. COMPUTE_MAXAVG = .NOT.(NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) IF ( PROKG.AND.SUM_OF_PEAKS) THEN WRITE( MPG,'(A)') & ' Estimations with BLR compression of LU factors:' WRITE( MPG,'(A,I6,A) ') & ' ICNTL(38) Estimated compression rate of LU factors =', & KEEP(464), '/1000' ENDIF OOC_STAT = 0 BLR_STRAT = 1 BLR_CASE = 1 CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, LRLU_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(30) = TOTAL_MBYTES IF (MYID.EQ.MASTER) THEN INFOG(36) = LRLU_UD(1) INFOG(37) = LRLU_UD(2) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN LRLU_UD(3) = (LRLU_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE LRLU_UD(3) = LRLU_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(36)):', & INFOG(36) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, IC factorization (INFOG(37)):' & ,INFOG(37) END IF OOC_STAT = 1 BLR_STRAT = 1 BLR_CASE = 1 CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, OOC_LRLU_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(31) = TOTAL_MBYTES IF (MYID.EQ.MASTER) THEN INFOG(38)= OOC_LRLU_UD(1) INFOG(39)= OOC_LRLU_UD(2) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN OOC_LRLU_UD(3) = (OOC_LRLU_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE OOC_LRLU_UD(3) = OOC_LRLU_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(38)):', & INFOG(38) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, OOC factorization (INFOG(39)):' & ,INFOG(39) END IF IF (SUM_OF_PEAKS) THEN OOC_STAT = 0 BLR_STRAT = 3 BLR_CASE = 1 CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, LRCB_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(37) = TOTAL_MBYTES ENDIF IF (MYID.EQ.MASTER.AND.SUM_OF_PEAKS) THEN INFOG(44)= LRCB_UD(1) INFOG(45)= LRCB_UD(2) ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN LRCB_UD(3) = (LRCB_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE LRCB_UD(3) = LRCB_UD(2)/NSLAVES ENDIF ENDIF OOC_STAT = 1 BLR_STRAT = 3 BLR_CASE = 1 CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, OOC_LRCB_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(38) = TOTAL_MBYTES ENDIF IF (MYID.EQ.MASTER.AND.SUM_OF_PEAKS) THEN INFOG(46)= OOC_LRCB_UD(1) INFOG(47)= OOC_LRCB_UD(2) ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN OOC_LRCB_UD(3) = (OOC_LRCB_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE OOC_LRCB_UD(3) = OOC_LRCB_UD(2)/NSLAVES ENDIF ENDIF END IF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN WRITE( MPG,'(A,A)') & ' Estimations with BLR compression of LU factors ', & 'and Contribution Blocks:' WRITE( MPG,'(A,I6,A) ') & ' ICNTL(38) Estimated compression rate of LU factors =', & KEEP(464), '/1000' WRITE( MPG,'(A,I6,A) ') & ' ICNTL(39) Estimated compression rate of CB =', & KEEP(465), '/1000' ENDIF OOC_STAT = 0 BLR_STRAT = 2 BLR_CASE = 1 CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, LRLUCB_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(34) = TOTAL_MBYTES ENDIF IF (MYID.EQ.MASTER.AND.SUM_OF_PEAKS) THEN INFOG(40)=LRLUCB_UD(1) INFOG(41)=LRLUCB_UD(2) ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN LRLUCB_UD(3) = (LRLUCB_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE LRLUCB_UD(3) = LRLUCB_UD(2)/NSLAVES ENDIF ELSE LRLUCB_UD(1) = TOTAL_MBYTES ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(40)):', & INFOG(40) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, IC factorization (INFOG(41)):' & ,INFOG(41) END IF OOC_STAT = 1 BLR_STRAT = 2 BLR_CASE = 1 CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IF (KEEP(400) .GT. 0 ) THEN CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES_UNDER_L0, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .TRUE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0) ENDIF CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, OOC_LRLUCB_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(35) = TOTAL_MBYTES ENDIF IF (MYID.EQ.MASTER.AND.SUM_OF_PEAKS) THEN INFOG(42)=OOC_LRLUCB_UD(1) INFOG(43)=OOC_LRLUCB_UD(2) ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN OOC_LRLUCB_UD(3) = (OOC_LRLUCB_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE OOC_LRLUCB_UD(3) = OOC_LRLUCB_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(42)):', & INFOG(42) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, OOC factorization (INFOG(43)):' & ,INFOG(43) END IF END SUBROUTINE CMUMPS_MEM_ESTIM_BLR_ALL SUBROUTINE CMUMPS_MAX_MEM( KEEP, KEEP8, & MYID, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & MEMORY_MBYTES, EFF, OOC_STRAT, BLR_STRAT, PERLU_ON, & MEMORY_BYTES, & BLR_CASE, SUM_OF_PEAKS, MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: EFF, PERLU_ON, UNDER_L0_OMP INTEGER, INTENT(IN) :: OOC_STRAT, BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID, N, NELT, NSLAVES, LNA INTEGER(8), INTENT(IN) :: NA_ELT8, NNZ8 INTEGER, INTENT(IN) :: NA(LNA) INTEGER(8), INTENT(OUT):: MEMORY_BYTES INTEGER, INTENT(OUT) :: MEMORY_MBYTES INTEGER, INTENT(IN) :: BLR_CASE LOGICAL, INTENT(IN) :: SUM_OF_PEAKS LOGICAL, INTENT(IN) :: MEM_EFF_ALLOCATED INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER :: MUMPS_GET_POOL_LENGTH EXTERNAL :: MUMPS_GET_POOL_LENGTH INTEGER(8) :: MemEstimGlobal LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: PERLU, NBRECORDS INTEGER(8) :: NB_REAL INTEGER(8) :: TEMP, NB_BYTES, NB_INT INTEGER :: CMUMPS_LBUF_INT INTEGER(8) :: CMUMPS_LBUFR_BYTES8, CMUMPS_LBUF8 INTEGER :: NBUFS INTEGER(8) :: TEMPI INTEGER(8) :: TEMPR INTEGER :: MIN_PERLU INTEGER(8) :: BUF_OOC, BUF_OOC_PANEL, BUF_OOC_NOPANEL INTEGER(8) :: OOC_NB_FILE_TYPE INTEGER(8) :: NSTEPS8, N8, NELT8 INTEGER(8) :: I8OVERI INTEGER(8) :: SUM_NRLADU_underL0, & SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, & SUM_NRLADULR_WC_underL0 INTEGER(4) :: I4 INTEGER(8) :: MIN_NRLADU_underL0, MIN_NRLADU_if_LR_LU_underL0 INTEGER :: ITH, ITHMIN, ITHMIN_if_LRLU INTEGER(8) :: I8_L0_OMP_2, I8_L0_OMP_3, & I8_L0_OMP_5, I8_L0_OMP_6, I8_L0_OMP_7, & I8_L0_OMP_8, I8_L0_OMP_9, I8_L0_OMP_10, & I8_L0_OMP_11, I8_L0_OMP_12, I8_L0_OMP_13 I8OVERI = int(KEEP(10),8) PERLU = KEEP(12) NSTEPS8 = int(KEEP(28),8) N8 = int(N,8) NELT8 = int(NELT,8) IF (.NOT.PERLU_ON) PERLU = 0 I_AM_MASTER = ( MYID .eq. 0 ) I_AM_SLAVE = ( KEEP(46).eq. 1 .or. MYID .ne. 0 ) TEMP = 0_8 NB_REAL = 0_8 NB_BYTES = 0_8 NB_INT = 0_8 IF (KEEP(235) .NE. 0 .OR. KEEP(237) .NE. 0) THEN NB_INT = NB_INT + NSTEPS8 ENDIF NB_INT = NB_INT + 5_8 * NSTEPS8 NB_INT = NB_INT + NSTEPS8 + int(KEEP(56),8)*int(NSLAVES+2,8) NB_INT = NB_INT + 3_8*N8 + KEEP(280) IF (KEEP(38) .NE. 0 .AND.I_AM_SLAVE) NB_INT = NB_INT + 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 + KEEP(193)*I8OVERI NB_INT = NB_INT + KEEP(194)+KEEP(195)+KEEP(196) NB_INT = NB_INT + 2 ELSE NB_INT = NB_INT + 2_8 * ( NELT8 + 1_8 ) * I8OVERI NB_INT = NB_INT + N8 + 1_8 + NELT8 NB_INT = NB_INT + I8OVERI + 3 END IF NB_INT = NB_INT + int(LNA,8) IF ( .NOT. EFF ) THEN IF (I_AM_SLAVE) THEN IF (UNDER_L0_OMP) THEN I8_L0_OMP_2 = 0_8 I8_L0_OMP_3 = 0_8 MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,1) MIN_NRLADU_underL0 = I8_L0_OMP(1,1) ITHMIN = 1 ITHMIN_if_LRLU = 1 DO ITH=1, KEEP(400) IF (I8_L0_OMP(1,ITH).LT.MIN_NRLADU_underL0) & THEN MIN_NRLADU_underL0 = I8_L0_OMP(1,ITH) ITHMIN = ITH ENDIF IF (I8_L0_OMP(4,ITH).LT.MIN_NRLADU_if_LR_LU_underL0) & THEN MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,ITH) ITHMIN_if_LRLU = ITH ENDIF I8_L0_OMP_2=I8_L0_OMP_2 + I8_L0_OMP(2,ITH) I8_L0_OMP_3=I8_L0_OMP_3 + I8_L0_OMP(3,ITH) ENDDO IF (SUM_OF_PEAKS.AND.BLR_STRAT.GT.0) THEN I8_L0_OMP_5 = 0_8 I8_L0_OMP_6 = 0_8 I8_L0_OMP_7 = 0_8 I8_L0_OMP_8 = 0_8 I8_L0_OMP_9 = 0_8 I8_L0_OMP_10= 0_8 I8_L0_OMP_11= 0_8 I8_L0_OMP_12= 0_8 I8_L0_OMP_13= 0_8 DO ITH=1, KEEP(400) I8_L0_OMP_5 = I8_L0_OMP_5 + I8_L0_OMP(5,ITH) I8_L0_OMP_6 = I8_L0_OMP_6 + I8_L0_OMP(6,ITH) I8_L0_OMP_7 = I8_L0_OMP_7 + I8_L0_OMP(7,ITH) I8_L0_OMP_8 = I8_L0_OMP_8 + I8_L0_OMP(8,ITH) I8_L0_OMP_9 = I8_L0_OMP_9 + I8_L0_OMP(9,ITH) I8_L0_OMP_10= I8_L0_OMP_10+ I8_L0_OMP(10,ITH) I8_L0_OMP_11= I8_L0_OMP_11+ I8_L0_OMP(11,ITH) I8_L0_OMP_12= I8_L0_OMP_12+ I8_L0_OMP(12,ITH) I8_L0_OMP_13= I8_L0_OMP_13+ I8_L0_OMP(13,ITH) ENDDO ENDIF CALL CMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & 0_8, 0_8, 0_8, 0_8, & I8_L0_OMP_2, & I8_L0_OMP_3, & I8_L0_OMP_5, & I8_L0_OMP_6, & I8_L0_OMP_7, & I8_L0_OMP_8, & I8_L0_OMP_9, & I8_L0_OMP_10, & I8_L0_OMP_11, & I8_L0_OMP_12, & I8_L0_OMP_13, & MemEstimGlobal & ) IF (BLR_STRAT.EQ.0) THEN IF ( OOC_STRAT .LE. 0 .AND. OOC_STRAT .NE. -1 ) THEN MemEstimGlobal = MemEstimGlobal + & I8_L0_OMP(1,ITHMIN) + & I8_L0_OMP(23, ITHMIN) ELSE MemEstimGlobal = MemEstimGlobal + & I8_L0_OMP(23, ITHMIN) ENDIF ELSE IF ( OOC_STRAT .LE. 0 .AND. OOC_STRAT .NE. -1 ) THEN MemEstimGlobal = MemEstimGlobal + & I8_L0_OMP(4,ITHMIN_if_LRLU) + & I8_L0_OMP(23, ITHMIN_if_LRLU) ELSE MemEstimGlobal = MemEstimGlobal + & I8_L0_OMP(23, ITHMIN_if_LRLU) ENDIF ENDIF NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ELSE IF ( KEEP8(24).EQ.0_8 ) THEN SUM_NRLADU_underL0 = 0_8 SUM_NRLADU_if_LR_LU_underL0 = 0_8 SUM_NRLADULR_UD_underL0 = 0_8 SUM_NRLADULR_WC_underL0 = 0_8 IF (KEEP(400) .GT. 0 ) THEN DO ITH=1, KEEP(400) SUM_NRLADU_underL0 = & SUM_NRLADU_underL0 + I8_L0_OMP(1,ITH) SUM_NRLADU_if_LR_LU_underL0 = & SUM_NRLADU_if_LR_LU_underL0 + I8_L0_OMP(4,ITH) SUM_NRLADULR_UD_underL0 = & SUM_NRLADULR_UD_underL0 + I8_L0_OMP(9,ITH) SUM_NRLADULR_WC_underL0 = & SUM_NRLADULR_WC_underL0 + I8_L0_OMP(10,ITH) ENDDO ENDIF CALL CMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & SUM_NRLADU_underL0, SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, SUM_NRLADULR_WC_underL0, & KEEP8(53), & KEEP8(54), & KEEP8(33), & KEEP8(34), & KEEP8(35), & KEEP8(50), & KEEP8(36), & KEEP8(47), & KEEP8(37), & KEEP8(38), & KEEP8(39), & MemEstimGlobal & ) IF (KEEP(400).LE.0) THEN NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ELSE IF (BLR_STRAT.EQ.0) THEN IF ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(KEEP8(14) / 100_8 + 1_8 ) ELSE NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(KEEP8(12) / 100_8 + 1_8 ) ENDIF ELSE NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ENDIF ENDIF ENDIF ELSE NB_REAL = NB_REAL + 1_8 ENDIF ELSE IF (I_AM_SLAVE) THEN IF (UNDER_L0_OMP) THEN IF (MEM_EFF_ALLOCATED) THEN NB_REAL = NB_REAL + KEEP8(63) ELSE NB_REAL = NB_REAL + KEEP8(62) ENDIF ELSE IF (MEM_EFF_ALLOCATED) THEN NB_REAL = NB_REAL + KEEP8(23) + KEEP8(74) ELSE NB_REAL = NB_REAL + KEEP8(67) + KEEP8(74) ENDIF ENDIF ENDIF IF ( OOC_STRAT .GT. 0 .AND. I_AM_SLAVE ) THEN BUF_OOC_NOPANEL = 2_8 * KEEP8(119) IF (KEEP(50).EQ.0)THEN BUF_OOC_PANEL = 8_8 * int(KEEP(226),8) ELSE BUF_OOC_PANEL = 4_8 * int(KEEP(226),8) ENDIF IF (OOC_STRAT .EQ. 2) THEN BUF_OOC = BUF_OOC_NOPANEL ELSE BUF_OOC = BUF_OOC_PANEL ENDIF NB_REAL = NB_REAL + min(BUF_OOC + int(max(PERLU,0),8) * & (BUF_OOC/100_8+1_8),12000000_8) IF (OOC_STRAT .EQ. 2) THEN OOC_NB_FILE_TYPE = 1_8 ELSE IF (KEEP(50).EQ.0) THEN OOC_NB_FILE_TYPE = 2_8 ELSE OOC_NB_FILE_TYPE = 1_8 ENDIF ENDIF NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 * I8OVERI NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 * I8OVERI NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 ENDIF IF (KEEP(252).EQ.1 .AND. .NOT. I_AM_MASTER) THEN NB_REAL = NB_REAL + N8 ENDIF IF ( .not. ( I_AM_SLAVE .and. I_AM_MASTER .and. KEEP(52) .eq. 0 & .and. KEEP(55) .ne. 0 ) ) THEN NB_INT = NB_INT + KEEP8(27) END IF TEMPI= 0_8 TEMPR = 0_8 NBRECORDS = KEEP(39) IF (KEEP(55).eq.0) THEN IF (NNZ8 < int(NBRECORDS,8)) THEN NBRECORDS=int(NNZ8) ENDIF ELSE IF (NA_ELT8 < int(NBRECORDS,8)) THEN NBRECORDS=int(NA_ELT8) ENDIF ENDIF IF ( KEEP(54) .eq. 0 ) THEN IF ( I_AM_MASTER ) THEN IF ( KEEP(46) .eq. 0 ) THEN NBUFS = NSLAVES ELSE NBUFS = NSLAVES - 1 IF (KEEP(55) .eq. 0 ) & TEMPI = TEMPI + 2_8 * N8 END IF TEMPI = TEMPI + 2_8 * int(NBRECORDS,8) * int(NBUFS,8) TEMPR = TEMPR + int(NBRECORDS,8) * int(NBUFS,8) ELSE IF ( KEEP(55) .eq. 0 )THEN TEMPI = TEMPI + 2_8 * int(NBRECORDS,8) TEMPR = TEMPR + int(NBRECORDS,8) END IF END IF ELSE IF ( I_AM_SLAVE ) THEN TEMPI = TEMPI + int(1+4*NSLAVES,8) * int(NBRECORDS,8) TEMPR = TEMPR + int(1+2*NSLAVES,8) * int(NBRECORDS,8) END IF END IF TEMP = NB_BYTES + (NB_INT + TEMPI) * int(KEEP(34),8) & + NB_REAL * int(KEEP(35),8) & + (TEMPR+KEEP8(26)) * int(KEEP(149),8) NB_REAL = NB_REAL + KEEP8(26) IF ( I_AM_SLAVE ) THEN IF (BLR_STRAT.NE.0) THEN CMUMPS_LBUFR_BYTES8 = int(KEEP(380),8) * int(KEEP(35),8) ELSE CMUMPS_LBUFR_BYTES8 = int(KEEP(44),8) * int(KEEP(35),8) ENDIF CMUMPS_LBUFR_BYTES8 = max( CMUMPS_LBUFR_BYTES8, & 200000_8 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF IF (KEEP(72).NE.1) THEN CMUMPS_LBUFR_BYTES8 = CMUMPS_LBUFR_BYTES8 & + int( real(max(PERLU/2,MIN_PERLU))* & real(CMUMPS_LBUFR_BYTES8)/100E0,8) ELSE CMUMPS_LBUFR_BYTES8 = CMUMPS_LBUFR_BYTES8 & + int( real(max(PERLU,MIN_PERLU))* & real(CMUMPS_LBUFR_BYTES8)/100E0,8) ENDIF CMUMPS_LBUFR_BYTES8 = min(CMUMPS_LBUFR_BYTES8, & int(huge (I4)-100,8)) NB_BYTES = NB_BYTES + CMUMPS_LBUFR_BYTES8 IF (.NOT.UNDER_L0_OMP) THEN IF (BLR_STRAT.NE.0) THEN CMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 & * real(KEEP( 379 ) * KEEP( 35 )), 8 ) ELSE CMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 & * real(KEEP( 43 ) * KEEP( 35 )), 8 ) ENDIF CMUMPS_LBUF8 = max( CMUMPS_LBUF8, 200000_8 ) IF (KEEP(72).NE.1) THEN CMUMPS_LBUF8 = CMUMPS_LBUF8 & + int( real(max(PERLU/2,MIN_PERLU))* & real(CMUMPS_LBUF8)/100E0, 8) ELSE CMUMPS_LBUF8 = CMUMPS_LBUF8 & + int( real(max(PERLU,MIN_PERLU))* & real(CMUMPS_LBUF8)/100E0, 8) ENDIF CMUMPS_LBUF8 = min(CMUMPS_LBUF8, int(huge(I4)-100,8)) CMUMPS_LBUF8 = max(CMUMPS_LBUF8, CMUMPS_LBUFR_BYTES8+ & 3_8*int(KEEP(34),8)) NB_BYTES = NB_BYTES + CMUMPS_LBUF8 ENDIF CMUMPS_LBUF_INT = ( KEEP(56) + & NSLAVES * NSLAVES ) * 5 & * KEEP(34) NB_BYTES = NB_BYTES + int(CMUMPS_LBUF_INT,8) IF (.NOT.EFF) THEN IF (UNDER_L0_OMP) THEN IF (KEEP(144).GT.0) THEN NB_INT = NB_INT + N8*int(KEEP(400),8) NB_INT = NB_INT + & int(MUMPS_GET_POOL_LENGTH(NA(1), KEEP, KEEP8),8)* & int(KEEP(400),8) ENDIF ENDIF IF (KEEP(400).GT.0) THEN NB_INT = NB_INT + & int(MUMPS_GET_POOL_LENGTH(NA(1), KEEP, KEEP8),8) ENDIF IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int( & KEEP(138) + 3 * max(PERLU,10) * & ( KEEP(138) / 100 + 1 ) & ,8) ELSE NB_INT = NB_INT + int( & KEEP(137) + 3 * max(PERLU,10) * & ( KEEP(137) / 100 + 1 ) & ,8) ENDIF ENDIF IF (.NOT.UNDER_L0_OMP) THEN IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int( & KEEP(225) + 2 * max(PERLU,10) * & ( KEEP(225) / 100 + 1 ) & ,8) ELSE NB_INT = NB_INT + int( & KEEP(15) + 2 * max(PERLU,10) * & ( KEEP(15) / 100 + 1 ) & ,8) ENDIF ENDIF NB_INT = NB_INT + NSTEPS8 NB_INT = NB_INT + NSTEPS8 * I8OVERI NB_INT = NB_INT + N8 + 4_8 * NSTEPS8 + & int(MUMPS_GET_POOL_LENGTH(NA(1), KEEP, KEEP8),8) NB_INT = NB_INT + 2_8 * NSTEPS8 * I8OVERI ENDIF MEMORY_BYTES = NB_BYTES + NB_INT * int(KEEP(34),8) + & NB_REAL * int(KEEP(35),8) MEMORY_BYTES = max( MEMORY_BYTES, TEMP ) MEMORY_MBYTES = nint( real(MEMORY_BYTES) / real(1000000) ) RETURN END SUBROUTINE CMUMPS_MAX_MEM SUBROUTINE CMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & SUM_NRLADU_underL0, SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, SUM_NRLADULR_WC_underL0, & PEAK_FR, & PEAK_FR_OOC, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB, & NRLADULR_UD, & NRLADULR_WC, & NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, & NRLNECLR_LUCB_WC, & MemEstimGlobal & ) INTEGER, INTENT(IN) :: OOC_STRAT, BLR_STRAT INTEGER, INTENT(IN) :: BLR_CASE LOGICAL, INTENT(IN) :: SUM_OF_PEAKS INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER(8), INTENT(IN) :: SUM_NRLADU_underL0, & SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, & SUM_NRLADULR_WC_underL0 INTEGER(8), INTENT(IN) :: & PEAK_FR, & PEAK_FR_OOC, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB, & NRLADULR_UD, & NRLADULR_WC, & NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, & NRLNECLR_LUCB_WC INTEGER(8), INTENT(OUT) :: MemEstimGlobal IF ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN MemEstimGlobal = PEAK_FR_OOC ELSE MemEstimGlobal = PEAK_FR ENDIF IF (BLR_STRAT.GT.0) THEN IF (.NOT.SUM_OF_PEAKS) THEN IF (BLR_STRAT.EQ.1) THEN IF (BLR_CASE.LE.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(40) ELSE MemEstimGlobal = KEEP8(41) ENDIF ELSE IF (BLR_CASE.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(33) ELSE MemEstimGlobal = KEEP8(54) ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(53) ELSE MemEstimGlobal = KEEP8(42) ENDIF ENDIF ELSE IF (BLR_CASE.LE.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(43) ELSE MemEstimGlobal = KEEP8(45) ENDIF ELSE IF (BLR_CASE.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(34) ELSE MemEstimGlobal = KEEP8(35) ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(44) ELSE MemEstimGlobal = KEEP8(46) ENDIF ENDIF ENDIF ELSE IF (BLR_STRAT.EQ.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_LU & + SUM_NRLADU_if_LR_LU_underL0 ELSE MemEstimGlobal = PEAK_FR_OOC ENDIF IF (BLR_CASE.EQ.1) THEN MemEstimGlobal = MemEstimGlobal + NRLADULR_UD & + SUM_NRLADULR_UD_underL0 ELSE IF (BLR_CASE.EQ.3) THEN MemEstimGlobal = MemEstimGlobal + NRLADULR_WC & + SUM_NRLADULR_WC_underL0 ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_LUCB & + SUM_NRLADU_if_LR_LU_underL0 ELSE MemEstimGlobal = NRLNECOOC_if_LR_LUCB ENDIF IF (BLR_CASE.EQ.1) THEN MemEstimGlobal = MemEstimGlobal + NRLNECLR_LUCB_UD & + SUM_NRLADULR_UD_underL0 ELSE IF (BLR_CASE.EQ.3) THEN MemEstimGlobal = MemEstimGlobal + NRLNECLR_LUCB_WC & + SUM_NRLADULR_WC_underL0 ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_CB & + SUM_NRLADU_underL0 ELSE MemEstimGlobal = NRLNECOOC_if_LR_LUCB ENDIF MemEstimGlobal = MemEstimGlobal + NRLNECLR_CB_UD ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SET_MEMESTIMGLOBAL SUBROUTINE CMUMPS_SET_BLRSTRAT_AND_MAXS_K8 ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & KEEP, KEEP8) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS_BASE8, MAXS_BASE_RELAXED8 INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) CALL CMUMPS_SET_BLRSTRAT_AND_MAXS ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & KEEP(1), & KEEP8(12), & KEEP8(14), & KEEP8(33), & KEEP8(34), & KEEP8(35), & KEEP8(50) ) RETURN END SUBROUTINE CMUMPS_SET_BLRSTRAT_AND_MAXS_K8 SUBROUTINE CMUMPS_SET_BLRSTRAT_AND_MAXS( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, KEEP, & NRLNEC, & NRLNEC_ACTIVE, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB ) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS_BASE8, MAXS_BASE_RELAXED8 INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: NRLNEC, & NRLNEC_ACTIVE, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB INTEGER :: PERLU PERLU = KEEP(12) IF (KEEP(201) .EQ. 0) THEN MAXS_BASE8 = NRLNEC ELSE MAXS_BASE8 = NRLNEC_ACTIVE ENDIF BLR_STRAT = 0 IF (KEEP(486).EQ.2) THEN IF (KEEP(489).EQ.1) THEN BLR_STRAT = 2 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNECOOC_if_LR_LUCB ELSE MAXS_BASE8 = NRLNEC_if_LR_LUCB ENDIF ELSE BLR_STRAT = 1 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNEC_ACTIVE ELSE MAXS_BASE8 = NRLNEC_if_LR_LU ENDIF ENDIF ELSE IF (KEEP(486).EQ.3) THEN IF (KEEP(489).EQ.1) THEN BLR_STRAT = 3 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNECOOC_if_LR_LUCB ELSE MAXS_BASE8 = NRLNEC_if_LR_CB ENDIF ENDIF ENDIF IF ( MAXS_BASE8 .GT. 0_8 ) THEN MAXS_BASE_RELAXED8 = & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) ELSE MAXS_BASE_RELAXED8 = 1_8 END IF RETURN END SUBROUTINE CMUMPS_SET_BLRSTRAT_AND_MAXS SUBROUTINE CMUMPS_MEM_ALLOWED_SET_MAXS ( MAXS, & BLR_STRAT, OOC_STRAT, MAXS_ESTIM_RELAXED8, & KEEP, KEEP8, MYID, N, NELT, NA, LNA, & NSLAVES, ICNTL38, ICNTL39, IFLAG, IERROR & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(IN) :: BLR_STRAT INTEGER, INTENT(IN) :: OOC_STRAT INTEGER(8), INTENT(IN) :: MAXS_ESTIM_RELAXED8 INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID, N, NELT, NSLAVES, LNA INTEGER, INTENT(IN) :: NA(LNA), ICNTL38, ICNTL39 INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER(8) :: SMALLER_MAXS, UPDATED_DIFF LOGICAL :: EFF, PERLU_ON, SUM_OF_PEAKS INTEGER :: BLR_CASE INTEGER(8) :: TOTAL_BYTES, MEM_ALLOWED_BYTES, & MEM_DISPO_BYTES, MEM_DISPO INTEGER :: TOTAL_MBYTES, PERLU INTEGER(8) :: MEM_DISPO_BYTES_NR, MEM_DISPO_NR, & TOTAL_BYTES_NR INTEGER :: TOTAL_MBYTES_NR INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. PERLU_ON = .TRUE. PERLU = KEEP(12) EFF = .FALSE. SUM_OF_PEAKS = .TRUE. BLR_CASE = 1 MEM_ALLOWED_BYTES = KEEP8(4) CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, & KEEP8(28), KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF, OOC_STRAT, & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) MEM_DISPO_BYTES = MEM_ALLOWED_BYTES-TOTAL_BYTES IF (MEM_DISPO_BYTES.GT.0) THEN MEM_DISPO = MEM_DISPO_BYTES/int(KEEP(35),8) ELSE MEM_DISPO = (MEM_DISPO_BYTES-int(KEEP(35),8)+1)/ & int(KEEP(35),8) ENDIF IF (BLR_STRAT.EQ.0) THEN UPDATED_DIFF = 0_8 ELSE IF (BLR_STRAT.EQ.1) THEN IF (KEEP(464).NE.0) THEN UPDATED_DIFF = int( & real(KEEP8(36)) * ( 1.0E0 - & real(ICNTL38)/real(KEEP(464)) ) & , 8) ELSE UPDATED_DIFF = int ( & -real(KEEP8(11)-KEEP8(32)) * & real(ICNTL38) / 1000.0E0 & , 8) ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF (KEEP(464)+KEEP(465).NE.0) THEN UPDATED_DIFF = int( & real(KEEP8(38)) * ( 1.0E0 - & real(ICNTL38+ICNTL39)/ & real(KEEP(464)+KEEP(465)) ) & , 8) ELSE UPDATED_DIFF = int( & -real(KEEP8(39))* & real(ICNTL38+ICNTL39)/1000.0E0 & , 8) ENDIF ELSE IF (BLR_STRAT.EQ.3) THEN IF (KEEP(465).NE.0) THEN UPDATED_DIFF = int( & real(KEEP8(37)) * ( 1.0E0 - & real(ICNTL39)/real(KEEP(465)) ) & , 8) ELSE UPDATED_DIFF = int( & -real(KEEP8(39))* & real(ICNTL39)/1000.0E0 & , 8) ENDIF ELSE UPDATED_DIFF = 0_8 ENDIF MEM_DISPO = MEM_DISPO + UPDATED_DIFF MAXS = MAXS_ESTIM_RELAXED8 MEM_DISPO_NR = 0_8 IF ( (MEM_DISPO.LT.0) .AND. MAXS_ESTIM_RELAXED8.GT. & (MEM_ALLOWED_BYTES/int(KEEP(35),8)) ) THEN PERLU_ON = .FALSE. CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, & KEEP8(28), KEEP8(30), & NSLAVES, TOTAL_MBYTES_NR, EFF, OOC_STRAT, & BLR_STRAT, PERLU_ON, TOTAL_BYTES_NR, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) MEM_DISPO_BYTES_NR = MEM_ALLOWED_BYTES-TOTAL_BYTES_NR MEM_DISPO_NR = & MEM_DISPO_BYTES_NR/int(KEEP(35),8) & + UPDATED_DIFF IF ( MEM_DISPO_NR.LT.0 ) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE IF (BLR_STRAT.GE.2) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE MEM_DISPO_NR = MEM_DISPO_NR - & (int(KEEP(12),8)/120_8)* & (KEEP8(11)/4_8) IF ( MEM_DISPO_NR.LT.0 ) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE ENDIF ENDIF ENDIF ENDIF MAXS = MAXS_ESTIM_RELAXED8 IF (BLR_STRAT.EQ.0) THEN IF (MEM_DISPO.GT.0) THEN IF (OOC_STRAT.EQ.0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/2_8) ELSE MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/2_8) ENDIF ELSE MAXS = MAXS_ESTIM_RELAXED8 + MEM_DISPO ENDIF ELSE IF (BLR_STRAT.EQ.1) THEN IF ( MEM_DISPO .GT. 0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/10_8) ELSE IF ( MEM_DISPO .LT. 0) THEN IF (OOC_STRAT.EQ.0) THEN SMALLER_MAXS = KEEP8(34) + & int(PERLU,8) * ( KEEP8(34) / 100_8 + 1_8) ELSE SMALLER_MAXS = KEEP8(35) + & int(PERLU,8) * ( KEEP8(35) / 100_8 + 1_8) ENDIF MAXS = max(MAXS_ESTIM_RELAXED8+MEM_DISPO, & SMALLER_MAXS) ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF ( MEM_DISPO .GT. 0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/10_8) ELSE IF ( MEM_DISPO.LT.0) THEN MAXS = max( & MAXS_ESTIM_RELAXED8+MEM_DISPO, & MAXS_ESTIM_RELAXED8) ENDIF ELSE IF (BLR_STRAT.EQ.3) THEN IF ( MEM_DISPO .GT. 0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/4_8) ELSE IF ( MEM_DISPO.LT.0) THEN MAXS = max( & MAXS_ESTIM_RELAXED8+MEM_DISPO, & MAXS_ESTIM_RELAXED8) ENDIF ENDIF IF (MAXS .LE. 0_8) THEN IFLAG=-19 IF (MEM_DISPO.LT.0) THEN CALL MUMPS_SET_IERROR(MEM_DISPO,IERROR) ELSE CALL MUMPS_SET_IERROR(MAXS_ESTIM_RELAXED8-MAXS,IERROR) ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_MEM_ALLOWED_SET_MAXS SUBROUTINE CMUMPS_MEM_ALLOWED_SET_K75 ( & MAXS, MYID, UNDER_L0_OMP, & N, NELT, NA, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT, & KEEP, KEEP8, IFLAG, IERROR & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MAXS INTEGER, INTENT(IN) :: MYID, N, NELT, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT LOGICAL, INTENT(IN) :: UNDER_L0_OMP INTEGER, INTENT(IN) :: NA(LNA), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER(8) :: KEEP8_23_SAVETMP, TOTAL_BYTES INTEGER :: TOTAL_MBYTES LOGICAL :: PERLU_ON, MEM_EFF_ALLOCATED, EFF INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. KEEP8_23_SAVETMP = KEEP8(23) KEEP8(23) = MAXS PERLU_ON =.TRUE. MEM_EFF_ALLOCATED = .TRUE. EFF = .TRUE. KEEP8(74) = 0_8 KEEP8(63) = 0_8 CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) KEEP8(23) = KEEP8_23_SAVETMP KEEP8(75) = KEEP8(4) - TOTAL_BYTES KEEP8(75) = KEEP8(75)/int(KEEP(35),8) IF (KEEP8(75).LT.0_8) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-KEEP8(75),IERROR) ENDIF RETURN END SUBROUTINE CMUMPS_MEM_ALLOWED_SET_K75 SUBROUTINE CMUMPS_L0_COMPUTE_PEAK_ALLOWED ( & MYID, N, & NELT, NA, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT, & KEEP, KEEP8, IFLAG, IERROR & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, N, NELT, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT INTEGER, INTENT(IN) :: NA(LNA), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(IN) :: NBSTATS_I8, NBCOLS_I8 INTEGER(8), INTENT(IN) :: I8_L0_OMP (NBSTATS_I8, NBCOLS_I8) INTEGER(8) :: KEEP8_23_SAVETMP, TOTAL_BYTES, TOTAL_STATIC, & TOTAL_ABOVE, TOTAL_UNDER INTEGER(8) :: EXTRA_MEM, MIN_NRLADU_underL0, & MIN_NRLADU_if_LR_LU_underL0 INTEGER :: TOTAL_MBYTES LOGICAL :: PERLU_ON, MEM_EFF_ALLOCATED, EFF LOGICAL :: UNDER_L0_OMP, SUM_OF_PEAKS INTEGER :: BLR_CASE, ITH INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. KEEP8_23_SAVETMP = KEEP8(23) KEEP8(23) = 0_8 UNDER_L0_OMP = .TRUE. PERLU_ON = .TRUE. MEM_EFF_ALLOCATED = .TRUE. EFF = .TRUE. KEEP8(74) = 0_8 KEEP8(63) = 0_8 CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_STATIC = TOTAL_BYTES KEEP8(23) = KEEP8_23_SAVETMP MEM_EFF_ALLOCATED = .FALSE. EFF = .FALSE. BLR_CASE = 2 SUM_OF_PEAKS = .TRUE. UNDER_L0_OMP = .FALSE. CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_ABOVE = TOTAL_BYTES IF (PERLU_ON.AND.KEEP(201).LE.0) THEN IF (BLR_STRAT.GT.0) THEN MIN_NRLADU_if_LR_LU_underL0 = I8_L0_OMP(4,1) DO ITH=1, KEEP(400) MIN_NRLADU_if_LR_LU_underL0 = min ( & MIN_NRLADU_if_LR_LU_underL0, I8_L0_OMP(4,ITH) & ) ENDDO EXTRA_MEM = int(KEEP(12),8)* & ( MIN_NRLADU_if_LR_LU_underL0 / 100_8 + 1_8 ) ELSE MIN_NRLADU_underL0 = I8_L0_OMP(1,1) DO ITH=1, KEEP(400) MIN_NRLADU_underL0 = min ( & MIN_NRLADU_underL0, I8_L0_OMP(1,ITH) & ) ENDDO EXTRA_MEM = int(KEEP(12),8)* & ( MIN_NRLADU_underL0 / 100_8 + 1_8 ) ENDIF TOTAL_ABOVE = TOTAL_ABOVE + EXTRA_MEM ENDIF UNDER_L0_OMP = .TRUE. CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & , I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 & ) TOTAL_UNDER = TOTAL_BYTES KEEP8(77) = ( max(TOTAL_UNDER,TOTAL_ABOVE) - TOTAL_STATIC ) & / int(KEEP(35),8) RETURN END SUBROUTINE CMUMPS_L0_COMPUTE_PEAK_ALLOWED SUBROUTINE CMUMPS_SETMAXTOZERO(M_ARRAY, M_SIZE) IMPLICIT NONE INTEGER M_SIZE REAL M_ARRAY(M_SIZE) REAL ZERO PARAMETER (ZERO=0.0E0) M_ARRAY=ZERO RETURN END SUBROUTINE CMUMPS_SETMAXTOZERO SUBROUTINE CMUMPS_COMPUTE_NBROWSinF ( & N, INODE, IFATH, KEEP, & IOLDPS, HF, IW, LIW, & NROWS, NCOLS, NPIV, & NELIM, NFS4FATHER, & NBROWSinF & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, INODE, IFATH INTEGER, INTENT(IN) :: KEEP(500) INTEGER, INTENT(IN) :: IOLDPS, HF, LIW, NROWS, NCOLS INTEGER, INTENT(IN) :: NPIV, NELIM, NFS4FATHER INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT):: NBROWSinF INTEGER :: ShiftFirstRowinFront NBROWSinF = 0 IF ( (KEEP(219).EQ.0).OR.(KEEP(50).NE.2).OR. & (NFS4FATHER.LE.0) ) THEN RETURN ENDIF ShiftFirstRowinFront = NCOLS-NPIV-NELIM-NROWS IF (ShiftFirstRowinFront.EQ.0) THEN NBROWSinF = min(NROWS, NFS4FATHER-NELIM) ELSE IF (ShiftFirstRowinFront.LT.NFS4FATHER-NELIM) THEN NBROWSinF = min(NROWS,NFS4FATHER-NELIM-ShiftFirstRowinFront) ELSE NBROWSinF=0 ENDIF RETURN END SUBROUTINE CMUMPS_COMPUTE_NBROWSinF SUBROUTINE CMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, INODE, IFATH INTEGER, INTENT(IN) :: FILS(N), PERM(N), KEEP(500) INTEGER, INTENT(IN) :: IOLDPS, HF, LIW, NFRONT, NASS1 INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT):: ESTIM_NFS4FATHER_ATSON INTEGER :: J, J_LASTFS, IN, NCB, I, IPOS ESTIM_NFS4FATHER_ATSON = 0 IN = IFATH J_LASTFS = IN DO WHILE (IN.GT.0) J_LASTFS = IN IN = FILS(IN) ENDDO NCB = NFRONT-NASS1 IPOS = IOLDPS + HF + NASS1 ESTIM_NFS4FATHER_ATSON = 0 DO I=1, NCB J = IW(IPOS+ESTIM_NFS4FATHER_ATSON) IF (PERM(J).LE.PERM(J_LASTFS)) THEN ESTIM_NFS4FATHER_ATSON = & ESTIM_NFS4FATHER_ATSON+1 ELSE EXIT ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_COMPUTE_ESTIM_NFS4FATHER SUBROUTINE CMUMPS_COMPUTE_MAXPERCOL( & A,ASIZE,NCOL,NROW, & M_ARRAY,NMAX,PACKED_CB,LROW1) IMPLICIT NONE INTEGER(8) :: ASIZE INTEGER NROW,NCOL,NMAX,LROW1 LOGICAL PACKED_CB COMPLEX A(ASIZE) REAL M_ARRAY(NMAX) INTEGER I INTEGER(8):: APOS, J, LROW REAL ZERO,TMP PARAMETER (ZERO=0.0E0) DO I=1, NMAX M_ARRAY(I) = ZERO ENDDO APOS = 0_8 IF (PACKED_CB) THEN LROW=int(LROW1,8) ELSE LROW=int(NCOL,8) ENDIF DO I=1,NROW DO J=1_8,int(NMAX,8) TMP = abs(A(APOS+J)) IF(TMP.GT.M_ARRAY(J)) M_ARRAY(J) = TMP ENDDO APOS = APOS + LROW IF (PACKED_CB) LROW=LROW+1_8 ENDDO RETURN END SUBROUTINE CMUMPS_COMPUTE_MAXPERCOL SUBROUTINE CMUMPS_SIZE_IN_STRUCT( id, idintr, & NB_INT, NB_CMPLX, NB_CHAR ) USE CMUMPS_STRUC_DEF, ONLY: CMUMPS_STRUC USE CMUMPS_INTR_TYPES, ONLY: CMUMPS_INTR_STRUC IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(CMUMPS_INTR_STRUC) :: idintr INTEGER(8) NB_INT, NB_CMPLX INTEGER(8) NB_REAL,NB_CHAR NB_INT = 0_8 NB_CMPLX = 0_8 NB_REAL = 0_8 NB_CHAR = 0_8 IF (associated(id%IS)) NB_INT=NB_INT+size(id%IS) NB_INT=NB_INT+size(id%KEEP) NB_INT=NB_INT+size(id%ICNTL) NB_INT=NB_INT+size(id%INFO) NB_INT=NB_INT+size(id%INFOG) IF (associated(id%MAPPING)) NB_INT=NB_INT+size(id%MAPPING) IF (associated(id%STEP)) THEN NB_INT=NB_INT+size(id%STEP) ENDIF 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)) THEN NB_INT=NB_INT+size(id%FILS) ENDIF IF (associated(id%FRTPTR)) NB_INT=NB_INT+size(id%FRTPTR) IF (associated(id%FRTELT)) NB_INT=NB_INT+size(id%FRTELT) IF (associated(id%PTRAR)) & NB_INT=NB_INT+size(id%PTRAR)* id%KEEP(10) IF (associated(id%PTR8ARR)) & NB_INT=NB_INT+size(id%PTR8ARR)* id%KEEP(10) IF (associated(id%NINCOLARR)) & NB_INT=NB_INT+size(id%NINCOLARR) IF (associated(id%NINROWARR)) & NB_INT=NB_INT+size(id%NINROWARR) IF (associated(id%PTRDEBARR)) & NB_INT=NB_INT+size(id%PTRDEBARR) 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%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%ELTPROC)) NB_INT=NB_INT+size(id%ELTPROC) IF (associated(id%CANDIDATES)) & NB_INT=NB_INT+size(id%CANDIDATES,DIM=1)* & size(id%CANDIDATES,DIM=2) IF (associated(id%SYM_PERM)) THEN NB_INT=NB_INT+size(id%SYM_PERM) ENDIF IF (associated(id%UNS_PERM)) & NB_INT=NB_INT+size(id%UNS_PERM) IF (associated(id%ISTEP_TO_INIV2)) & NB_INT=NB_INT+size(id%ISTEP_TO_INIV2) IF (associated(id%FUTURE_NIV2)) & NB_INT=NB_INT+size(id%FUTURE_NIV2) IF (associated(id%TAB_POS_IN_PERE)) & NB_INT=NB_INT+size(id%TAB_POS_IN_PERE,DIM=1)* & size(id%TAB_POS_IN_PERE,DIM=2) 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%GLOB2LOC_RHS)) & NB_INT=NB_INT+size(id%GLOB2LOC_RHS) IF(id%GLOB2LOC_SOL_ALLOC.AND.associated(id%GLOB2LOC_SOL)) & NB_INT=NB_INT+size(id%GLOB2LOC_SOL) IF (associated(id%MEM_SUBTREE)) & NB_REAL=NB_REAL+size(id%MEM_SUBTREE)*(id%KEEP(35)/id%KEEP(16)) IF (associated(id%MY_ROOT_SBTR)) & NB_INT=NB_INT+size(id%MY_ROOT_SBTR) IF (associated(id%MY_FIRST_LEAF)) & NB_INT=NB_INT+size(id%MY_FIRST_LEAF) IF (associated(id%MY_NB_LEAF)) NB_INT=NB_INT+size(id%MY_NB_LEAF) IF (associated(id%DEPTH_FIRST)) NB_INT=NB_INT+size(id%DEPTH_FIRST) IF (associated(id%DEPTH_FIRST_SEQ)) & NB_INT=NB_INT+size(id%DEPTH_FIRST_SEQ) IF (associated(id%SBTR_ID)) NB_INT=NB_INT+size(id%SBTR_ID) IF (associated(id%SCHED_DEP)) NB_INT=NB_INT+size(id%SCHED_DEP) IF (associated(id%SCHED_GRP)) NB_INT=NB_INT+size(id%SCHED_GRP) IF (associated(id%SCHED_SBTR)) NB_INT=NB_INT+size(id%SCHED_SBTR) IF (associated(id%CROIX_MANU)) NB_INT=NB_INT+size(id%CROIX_MANU) IF (associated(id%COST_TRAV)) & NB_REAL=NB_REAL+size(id%COST_TRAV)*(id%KEEP(35)/id%KEEP(16)) IF (associated(id%CB_SON_SIZE)) NB_INT=NB_INT+size(id%CB_SON_SIZE) IF (associated(id%OOC_INODE_SEQUENCE)) & NB_INT=NB_INT+size(id%OOC_INODE_SEQUENCE) IF (associated(id%OOC_SIZE_OF_BLOCK)) & NB_INT=NB_INT+size(id%OOC_SIZE_OF_BLOCK)*id%KEEP(10) IF (associated(id%OOC_VADDR)) & NB_INT=NB_INT+size(id%OOC_VADDR,DIM=1)* & size(id%OOC_VADDR,DIM=2)*id%KEEP(10) IF (associated(id%OOC_TOTAL_NB_NODES)) & NB_INT=NB_INT+size(id%OOC_TOTAL_NB_NODES) IF (associated(id%OOC_NB_FILES)) & NB_INT=NB_INT+size(id%OOC_NB_FILES) IF (associated(id%OOC_FILE_NAME_LENGTH)) & NB_INT=NB_INT+size(id%OOC_FILE_NAME_LENGTH) IF (associated(id%PIVNUL_LIST)) NB_INT=NB_INT+size(id%PIVNUL_LIST) IF (associated(id%SUP_PROC)) NB_INT=NB_INT+size(id%SUP_PROC) IF (associated(id%IPTR_WORKING)) & NB_INT=NB_INT+size(id%IPTR_WORKING) IF (associated(id%WORKING)) NB_INT=NB_INT+size(id%WORKING) IF (associated(id%LRGROUPS)) THEN NB_INT=NB_INT+size(id%LRGROUPS) ENDIF IF (associated(id%I4_L0_OMP)) & NB_INT=NB_INT+size(id%I4_L0_OMP,DIM=1)* & size(id%I8_L0_OMP,DIM=2) IF (associated(id%I8_L0_OMP)) & NB_INT=NB_INT+size(id%I8_L0_OMP,DIM=1)* & size(id%I8_L0_OMP,DIM=2)*id%KEEP(10) IF (associated(id%IPOOL_B_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_B_L0_OMP) IF (associated(id%IPOOL_A_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_A_L0_OMP) IF (associated(id%PHYS_L0_OMP)) & NB_INT=NB_INT+size(id%PHYS_L0_OMP) IF (associated(id%VIRT_L0_OMP)) & NB_INT=NB_INT+size(id%VIRT_L0_OMP) IF (associated(id%PERM_L0_OMP)) & NB_INT=NB_INT+size(id%PERM_L0_OMP) IF (associated(id%PTR_LEAFS_L0_OMP)) & NB_INT=NB_INT+size(id%PTR_LEAFS_L0_OMP) IF (associated(id%L0_OMP_MAPPING)) & NB_INT=NB_INT+size(id%L0_OMP_MAPPING) IF (associated(id%SINGULAR_VALUES)) & NB_REAL=NB_REAL+size(id%SINGULAR_VALUES) IF (associated(idintr%root%RG2L)) THEN NB_INT=NB_INT+size(idintr%root%RG2L) ENDIF IF (associated(idintr%root%IPIV)) & NB_INT=NB_INT+size(idintr%root%IPIV) IF (associated(idintr%roota%RHS_CNTR_MASTER_ROOT)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%RHS_CNTR_MASTER_ROOT) IF (associated(idintr%roota%SCHUR_POINTER)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%SCHUR_POINTER) IF (associated(idintr%roota%QR_TAU)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%QR_TAU) IF (associated(idintr%roota%RHS_ROOT)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%RHS_ROOT) IF (associated(idintr%roota%SVD_U)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%SVD_U) IF (associated(idintr%roota%SVD_VT)) & NB_CMPLX=NB_CMPLX+size(idintr%roota%SVD_VT) IF (associated(idintr%roota%SINGULAR_VALUES)) & NB_REAL=NB_REAL+size(idintr%roota%SINGULAR_VALUES) IF (associated(id%RHSINTR)) NB_CMPLX = NB_CMPLX + id%KEEP8(25) IF (associated(id%S)) NB_CMPLX=NB_CMPLX+id%KEEP8(23) IF (associated(id%COLSCA).AND.(id%KEEP(52).NE.-1)) & NB_REAL=NB_REAL+size(id%COLSCA) IF (associated(id%ROWSCA).AND.(id%KEEP(52).NE.-1)) & NB_REAL=NB_REAL+size(id%ROWSCA) IF (associated(id%ROWSCA_loc)) & NB_REAL=NB_REAL+size(id%ROWSCA_loc) IF (associated(id%COLSCA_loc).AND.id%KEEP(50).EQ.0) & NB_REAL=NB_REAL+size(id%COLSCA_loc) NB_REAL=NB_REAL+size(id%CNTL) NB_REAL=NB_REAL+size(id%RINFO) NB_REAL=NB_REAL+size(id%RINFOG) NB_REAL=NB_REAL+size(id%DKEEP) NB_CHAR=NB_CHAR+len(id%VERSION_NUMBER) NB_CHAR=NB_CHAR+len(id%OOC_TMPDIR) NB_CHAR=NB_CHAR+len(id%OOC_PREFIX) NB_CHAR=NB_CHAR+len(id%WRITE_PROBLEM) NB_CHAR=NB_CHAR+len(id%SAVE_DIR) NB_CHAR=NB_CHAR+len(id%SAVE_PREFIX) NB_CMPLX = NB_CMPLX + NB_REAL/2_8 RETURN END SUBROUTINE CMUMPS_SIZE_IN_STRUCT SUBROUTINE CMUMPS_COPYI8SIZE(N8,SRC,DEST) IMPLICIT NONE INTEGER(8) :: N8 COMPLEX, intent(in) :: SRC(N8) COMPLEX, intent(out) :: DEST(N8) INTEGER(8) :: SHIFT8, HUG8 INTEGER :: I, I4SIZE IF(int(huge(I4SIZE),8) .EQ. int(huge(HUG8),8)) THEN CALL ccopy(int(N8), SRC(1), 1, DEST(1), 1) ELSE HUG8=int(huge(I4SIZE),8) DO I = 1, int(( N8 + HUG8 - 1_8 ) / HUG8) SHIFT8 = 1_8 + int(I-1,8) * HUG8 I4SIZE = int(min(HUG8, N8-SHIFT8+1_8)) CALL ccopy(I4SIZE, SRC(SHIFT8), 1, DEST(SHIFT8), 1) ENDDO END IF RETURN END SUBROUTINE CMUMPS_COPYI8SIZE SUBROUTINE CMUMPS_SET_TMP_PTR( THE_ADDRESS, THE_SIZE8 ) USE CMUMPS_STATIC_PTR_M INTEGER(8), INTENT(IN) :: THE_SIZE8 COMPLEX, INTENT(IN) :: THE_ADDRESS(THE_SIZE8) CALL CMUMPS_SET_STATIC_PTR(THE_ADDRESS(1:THE_SIZE8)) RETURN END SUBROUTINE CMUMPS_SET_TMP_PTR SUBROUTINE CMUMPS_OOC_IO_LU_PANEL_I & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) USE CMUMPS_OOC, ONLY : IO_BLOCK, & CMUMPS_OOC_IO_LU_PANEL IMPLICIT NONE TYPE(IO_BLOCK), INTENT(INOUT):: MonBloc INTEGER(8) :: LAFAC INTEGER, INTENT(IN) :: STRAT, LIWFAC, MYID, TYPEFile INTEGER, INTENT(INOUT) :: IW(0:LIWFAC-1) COMPLEX, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LNextPiv2beWritten, UNextPiv2beWritten INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) RETURN END SUBROUTINE CMUMPS_OOC_IO_LU_PANEL_I SUBROUTINE CMUMPS_BUF_SEND_CONTRIB_TYPE3_I ( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) USE CMUMPS_BUF, ONLY : CMUMPS_BUF_SEND_CONTRIB_TYPE3 IMPLICIT NONE INTEGER N, ISON, NBCOL_SON, NBROW_SON, NSUBSET_ROW, NSUBSET_COL INTEGER NPROW, NPCOL, MBLOCK, NBLOCK, LD_SON INTEGER BBPCBP INTEGER PDEST, TAG, COMM, IERR INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER :: RG2L(N) INTEGER NSUPROW, NSUPCOL INTEGER(8), INTENT(IN) :: TABSIZE INTEGER SIZE_PACK INTEGER KEEP(500) COMPLEX VAL_SON( LD_SON, * ), TAB(*) LOGICAL TRANSP INTEGER N_ALREADY_SENT INTEGER NELIM_ROOT, NELIM_ROW, NELIM_COL CALL CMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP, & NELIM_ROOT, NELIM_ROW, NELIM_COL ) RETURN END SUBROUTINE CMUMPS_BUF_SEND_CONTRIB_TYPE3_I SUBROUTINE CMUMPS_BLR_UPDATE_TRAILING_I( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, sizeBEGS_BLR_L, & BEGS_BLR_U, sizeBEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, NB_BLR_U, & NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) USE CMUMPS_LR_TYPE, ONLY : LRB_TYPE USE CMUMPS_FAC_LR, ONLY : CMUMPS_BLR_UPDATE_TRAILING INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, & CURRENT_BLR, & NELIM, NIV, SYM, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT COMPLEX, intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_U(NB_BLR_U-CURRENT_BLR) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER :: sizeBEGS_BLR_L, sizeBEGS_BLR_U INTEGER :: BEGS_BLR_L(sizeBEGS_BLR_L) INTEGER :: BEGS_BLR_U(sizeBEGS_BLR_U) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS CALL CMUMPS_BLR_UPDATE_TRAILING( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) RETURN END SUBROUTINE CMUMPS_BLR_UPDATE_TRAILING_I SUBROUTINE CMUMPS_COMPRESS_CB_I(A_PTR, LA_PTR, POSELT, LDA, & BEGS_BLR, sizeBEGS_BLR, BEGS_BLR_U, sizeBEGS_BLR_U, & NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY, & NELIM, & NBROWSinF & ) USE CMUMPS_LR_TYPE, ONLY : LRB_TYPE USE CMUMPS_FAC_LR, ONLY : CMUMPS_COMPRESS_CB IMPLICIT NONE INTEGER(8), intent(in) :: LA_PTR COMPLEX, intent(inout) :: A_PTR(LA_PTR) INTEGER(8), intent(in) :: POSELT INTEGER :: sizeBEGS_BLR, sizeBEGS_BLR_U INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & KPERCENT, TOL_OPT, LWORK, OMP_NUM INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: CB_LRB(NB_ROWS,NB_COLS) INTEGER :: BEGS_BLR(sizeBEGS_BLR), BEGS_BLR_U(sizeBEGS_BLR_U) REAL :: RWORK(2*MAXI_CLUSTER*OMP_NUM) COMPLEX :: BLOCK(MAXI_CLUSTER, MAXI_CLUSTER*OMP_NUM) COMPLEX :: WORK(LWORK*OMP_NUM), TAU(MAXI_CLUSTER*OMP_NUM) INTEGER :: JPVT(MAXI_CLUSTER*OMP_NUM) INTEGER(8) :: KEEP8(150) REAL,intent(in) :: TOLEPS INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500) REAL :: M_ARRAY(max(NFS4FATHER,1)) INTEGER, intent(in) :: NELIM INTEGER, intent(in) :: NBROWSinF CALL CMUMPS_COMPRESS_CB(A_PTR, LA_PTR, POSELT, LDA, & BEGS_BLR, BEGS_BLR_U, & NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY=M_ARRAY, & NELIM=NELIM, & NBROWSinF=NBROWSinF & ) RETURN END SUBROUTINE CMUMPS_COMPRESS_CB_I SUBROUTINE CMUMPS_COMPRESS_PANEL_I_NOOPT( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, sizeBEGS_BLR, & NB_BLR, TOLEPS, TOL_OPT, K458, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8, & OMP_NUM & ) USE CMUMPS_LR_TYPE, ONLY : LRB_TYPE USE CMUMPS_FAC_LR, ONLY : CMUMPS_COMPRESS_PANEL IMPLICIT NONE INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV INTEGER, intent(in) :: OMP_NUM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) COMPLEX, intent(inout) :: A(LA) INTEGER :: MAXI_CLUSTER REAL :: RWORK(2*MAXI_CLUSTER*OMP_NUM) COMPLEX :: BLOCK(MAXI_CLUSTER,MAXI_CLUSTER*OMP_NUM) COMPLEX :: WORK(LWORK*OMP_NUM) COMPLEX :: TAU(MAXI_CLUSTER*OMP_NUM) INTEGER :: JPVT(MAXI_CLUSTER*OMP_NUM) INTEGER :: sizeBEGS_BLR INTEGER :: BEGS_BLR(sizeBEGS_BLR) INTEGER(8) :: KEEP8(150) INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, & K458, K473, TOL_OPT LOGICAL, intent(in) :: LBANDSLAVE INTEGER :: LWORK, NELIM REAL,intent(in) :: TOLEPS CHARACTER(len=1) :: DIR CALL CMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K458, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8 & ) RETURN END SUBROUTINE CMUMPS_COMPRESS_PANEL_I_NOOPT SUBROUTINE CMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & DECOMP_TIMER) USE CMUMPS_LR_TYPE, ONLY : LRB_TYPE USE CMUMPS_FAC_LR, ONLY : CMUMPS_DECOMPRESS_PANEL IMPLICIT NONE INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: COPY_DENSE_BLOCKS INTEGER, intent(in) :: NB_BLR, CURRENT_BLR INTEGER, intent(in) :: BEGS_BLR_DIAG, & BEGS_BLR_FIRST_OFFDIAG TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) CHARACTER(len=1) :: DIR INTEGER, intent(in) :: DECOMP_TIMER INTEGER, intent(in) :: LDA11, LDA21 CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & DECOMP_TIMER) RETURN END SUBROUTINE CMUMPS_DECOMPRESS_PANEL_I_NOOPT SUBROUTINE CMUMPS_BLR_UPD_NELIM_VAR_L_I( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, sizeBEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) USE CMUMPS_LR_TYPE, ONLY : LRB_TYPE USE CMUMPS_FAC_LR, ONLY : CMUMPS_BLR_UPD_NELIM_VAR_L IMPLICIT NONE INTEGER(8), intent(in) :: LA_U, LA_L INTEGER(8), intent(in) :: UPOS, LPOS INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR, & NELIM, FIRST_BLOCK CHARACTER(len=1),INTENT(IN) :: UTRANS INTEGER, intent(inout) :: IFLAG, IERROR COMPLEX, TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER, INTENT(in) :: sizeBEGS_BLR_L INTEGER :: BEGS_BLR_L(sizeBEGS_BLR_L) CALL CMUMPS_BLR_UPD_NELIM_VAR_L( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) RETURN END SUBROUTINE CMUMPS_BLR_UPD_NELIM_VAR_L_I SUBROUTINE CMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, JBEG_BLOCK, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, sizeBEGS_BLR_LM, & NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, sizeBEGS_BLR_LS, & NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, OMP_NUM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) USE CMUMPS_LR_TYPE, ONLY : LRB_TYPE USE CMUMPS_FAC_LR, ONLY : CMUMPS_BLR_SLV_UPD_TRAIL_LDLT IMPLICIT NONE INTEGER(8), intent(in) :: LA, LA_BLOCFACTO COMPLEX, intent(inout) :: A(LA) COMPLEX, intent(in) :: A_BLOCFACTO(LA_BLOCFACTO) INTEGER(8), intent(in) :: POSELT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), TOL_OPT, & MAXI_CLUSTER, OMP_NUM, LD_BLOCFACTO, & JBEG_BLOCK INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS, & ISHIFT_LM, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS COMPLEX, INTENT(INOUT) :: & BLOCK(MAXI_CLUSTER,MAXI_CLUSTER*OMP_NUM) INTEGER :: sizeBEGS_BLR_LM, sizeBEGS_BLR_LS INTEGER :: BEGS_BLR_LM(sizeBEGS_BLR_LM) INTEGER :: BEGS_BLR_LS(sizeBEGS_BLR_LS) TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM), & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS CALL CMUMPS_BLR_SLV_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, JBEG_BLOCK, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) RETURN END SUBROUTINE CMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I SUBROUTINE CMUMPS_SET_INNERBLOCKSIZE( SIZE_INNER, & NASS, KEEP ) IMPLICIT NONE INTEGER :: SIZE_INNER, NASS, KEEP(500) IF (NASS.LT.KEEP(4)) THEN SIZE_INNER = NASS ELSE IF (NASS .GT. KEEP(3)) THEN SIZE_INNER = min( KEEP(6), NASS ) ELSE SIZE_INNER = min( KEEP(5), NASS ) ENDIF RETURN END SUBROUTINE CMUMPS_SET_INNERBLOCKSIZE SUBROUTINE CMUMPS_UPDATE_PROGRESS( OPELI, KEEP8 ) DOUBLE PRECISION :: OPELI INTEGER(8) :: KEEP8( 150 ) REAL :: OPELIR OPELIR = real(OPELI) CALL MUMPS_SETRVAL_ADDR_C(OPELIR, KEEP8(84)) RETURN END SUBROUTINE CMUMPS_UPDATE_PROGRESS MUMPS_5.8.1/src/zfac_process_master2.F0000664000175000017500000001636015042446441017464 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, SLAVEF, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, KEEP, KEEP8, DKEEP, & ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE MUMPS_LOAD USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER SLAVEF INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ), ITLOC( N +KEEP(253) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP8(85)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ) INTEGER IFLAG, IERROR, COMM, COMM_LOAD INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER ND(KEEP(28)), FILS( N ), DAD(KEEP(28)), FRERE(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSITION, IFATH, ISON, NROW, NCOL, NELIM, & NSLAVES INTEGER(8) :: NOREAL INTEGER NOINT, INIV2, NCOL_EFF DOUBLE PRECISION FLOP1 INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER NOREAL_PACKET LOGICAL PERETYPE2 INCLUDE 'mumps_headers.h' COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYN_SIZE INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IFATH, 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & ISON , 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NROW , 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NCOL , 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, & MPI_INTEGER, COMM, IERR) IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN NCOL_EFF = NROW ELSE NCOL_EFF = NCOL ENDIF NOREAL_PACKET = NBROWS_PACKET * NCOL_EFF IF (NBROWS_ALREADY_SENT .EQ. 0) THEN NOINT = 6 + NROW + NCOL + NSLAVES + KEEP(IXSZ) NOREAL= int(NROW,8) * int(NCOL_EFF,8) CALL ZMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, ISON, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) THEN RETURN ENDIF PIMASTER(STEP( ISON )) = IWPOSCB + 1 PAMASTER(STEP( ISON )) = IPTRLU + 1_8 IW( IWPOSCB + 1 + XXNBPR ) = 0 IW( IWPOSCB + 1 + KEEP(IXSZ) ) = NCOL NELIM = NROW IW( IWPOSCB + 2 + KEEP(IXSZ) ) = NELIM IW( IWPOSCB + 3 + KEEP(IXSZ) ) = NROW IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN IW( IWPOSCB + 4 + KEEP(IXSZ) ) = NROW - NCOL IF ( NROW - NCOL .GE. 0 ) THEN WRITE(*,*) 'Error in PROCESS_MAITRE2:',NROW,NCOL CALL MUMPS_ABORT() END IF ELSE IW( IWPOSCB + 4 + KEEP(IXSZ) ) = 0 END IF IW( IWPOSCB + 5 + KEEP(IXSZ) ) = 1 IW( IWPOSCB + 6 + KEEP(IXSZ) ) = NSLAVES IF (NSLAVES.GT.0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 7 + KEEP(IXSZ) ), & NSLAVES, MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 7 + KEEP(IXSZ) + NSLAVES), & NROW, MPI_INTEGER, COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 7 + KEEP(IXSZ) + NROW + NSLAVES), & NCOL, MPI_INTEGER, COMM, IERR) IF ( NSLAVES .GT. 0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(ISON) ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES+1, MPI_INTEGER, COMM, IERR) TAB_POS_IN_PERE(SLAVEF+2,INIV2) = NSLAVES ENDIF ENDIF IF (NOREAL_PACKET.GT.0) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(PIMASTER(STEP(ISON))+XXD)) IF ( DYN_SIZE .GT. 0_8 ) THEN CALL ZMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), & DYN_SIZE, SON_A ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SON_A( 1_8 + & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8) ), & NOREAL_PACKET, MPI_DOUBLE_COMPLEX, COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( PAMASTER(STEP(ISON)) + & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8) ), & NOREAL_PACKET, MPI_DOUBLE_COMPLEX, COMM, IERR ) ENDIF ENDIF IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NROW ) THEN PERETYPE2 = ( MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)), & KEEP(199)) .EQ. 2 ) NSTK_S( STEP(IFATH )) = NSTK_S( STEP(IFATH) ) - 1 IF ( NSTK_S( STEP(IFATH)) .EQ. 0 ) THEN CALL ZMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IFATH ) IF (KEEP(47) .GE. 3) THEN CALL MUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( IFATH, N, PROCNODE_STEPS, & KEEP(199), ND, & FILS,FRERE, STEP, PIMASTER, & KEEP(28), KEEP(50), KEEP(253), & FLOP1,IW, LIW, KEEP(IXSZ) ) IF (IFATH.NE.KEEP(20)) & CALL MUMPS_LOAD_UPDATE(1, .FALSE., FLOP1, KEEP,KEEP8) END IF ENDIF RETURN END SUBROUTINE ZMUMPS_PROCESS_MASTER2 MUMPS_5.8.1/src/mumps_io_basic.c0000664000175000017500000006673115042446422016402 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mumps_io_basic.h" #include "mumps_io_err.h" #include "mumps_c_types.h" /* Exported global variables */ #if ! defined (MUMPS_WIN32) # if defined(WITH_PFUNC) && ! defined (WITHOUT_PTHREAD) # include pthread_mutex_t mumps_io_pwrite_mutex; # endif #endif /* MUMPS_WIN32 */ mumps_file_type* mumps_files = NULL; char* mumps_ooc_file_prefix = NULL; MUMPS_INT mumps_elementary_data_size; MUMPS_INT mumps_io_is_init_called; MUMPS_INT mumps_io_myid; MUMPS_OFF_T mumps_io_max_file_size; MUMPS_INT mumps_io_flag_async; MUMPS_INT mumps_io_k211; MUMPS_INT mumps_io_nb_file_type; /* Functions */ MUMPS_INLINE MUMPS_INT mumps_gen_file_info(long long vaddr, MUMPS_OFF_T * pos, MUMPS_INT * file){ *file=(MUMPS_INT)(vaddr/(long long)mumps_io_max_file_size); *pos=(MUMPS_OFF_T)(vaddr%(long long)mumps_io_max_file_size); return 0; } MUMPS_INLINE void mumps_init_max_file_size(MUMPS_OFF_T * mumps_io_max_file_size, MUMPS_INT keep255){ int force_small_files; force_small_files=0; /* Check if file size should be < 2GB */ if (sizeof(MUMPS_OFF_T)==4){ force_small_files=1; /* should not occur */ } # if defined(MUMPS_WIN32) # if ! defined(MUMPS_WINLARGEFILES) force_small_files=1; /* fseek and fwrite use long which is 32-bit */ # endif # else /* lseek and pread/pwrite (WITH_PFUNC) use off_t */ if (sizeof(off_t)==4){ force_small_files=1; } # endif if (keep255 < 0) { *mumps_io_max_file_size=-keep255; } else { if (force_small_files ) { /* 1 or 2 GBytes */ if ( keep255 > 2 || keep255 == 0 ){ *mumps_io_max_file_size=2; } else { *mumps_io_max_file_size=keep255; /* 1 or 2 GBytes */ } } else { if ( keep255 == 0 ) { *mumps_io_max_file_size=2; } else { *mumps_io_max_file_size=keep255; } } *mumps_io_max_file_size=*mumps_io_max_file_size*(MUMPS_OFF_T)(1000000000); } } MUMPS_INT mumps_set_file(MUMPS_INT type,MUMPS_INT file_number_arg){ /* Define file name pattern. * Last 6 'X' will be replaced to make file name unique */ char name[1300]; /* Larger than prefix(255)+tmpdir(1023)+base_name (20)+\0 (1) */ #if ! defined(_WIN32) MUMPS_INT fd; char buf[64]; /* for error message */ #endif mumps_file_struct *mumps_io_pfile_pointer_array; if (file_number_arg > ((mumps_files+type)->mumps_io_nb_file)-1){ /* mumps_io_nb_file was initialized to the estimated number of files inside mumps_io_init_file_struct; this block is entered in case of a too small estimation of the required number of files. */ /* We increase the number of files needed and then realloc. */ ((mumps_files+type)->mumps_io_nb_file)++; (mumps_files+type)->mumps_io_pfile_pointer_array=(mumps_file_struct*)realloc((void *)(mumps_files+type)->mumps_io_pfile_pointer_array,((mumps_files+type)->mumps_io_nb_file)*sizeof(mumps_file_struct)); /* Check for reallocation problem */ if((mumps_files+type)->mumps_io_pfile_pointer_array==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } /* initialize "is_opened", as in mumps_io_init_file_struct */ ((mumps_files+type)->mumps_io_pfile_pointer_array+((mumps_files+type)->mumps_io_nb_file)-1)->is_opened = 0; } mumps_io_pfile_pointer_array=(mumps_files+type)->mumps_io_pfile_pointer_array; /* * Change the current file: * Careful: both mumps_io_current_file_number and * mumps_io_current_file must be changed */ ((mumps_files+type)->mumps_io_current_file_number)=file_number_arg; ((mumps_files+type)->mumps_io_current_file)=mumps_io_pfile_pointer_array+file_number_arg; if((mumps_io_pfile_pointer_array+file_number_arg)->is_opened!=0){ /* * The file already exists and is open. * The i/o will be performed in the current file (which may not * be the last one. */ return 0; } /*********************/ /* CREATE A NEW FILE */ /*********************/ /* #if ! defined( MUMPS_WIN32 )*/ /* MinGW does not have a mkstemp function and MinGW defines _WIN32, * so we also go in the else branch below with MinGW */ #if ! defined(_WIN32) strcpy(name,mumps_ooc_file_prefix); fd=mkstemp(name); /* * A file name is built by mkstemp and the file * is opened. fd holds 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 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); 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; } ((mumps_files+type)->mumps_io_current_file)->write_pos=0; ((mumps_files+type)->mumps_io_current_file)->is_opened=1; return 0; } void mumps_update_current_file_position(mumps_file_struct* file_arg){ file_arg->current_pos=file_arg->write_pos; } MUMPS_INT mumps_compute_where_to_write(const double to_be_written,const MUMPS_INT type,long long vaddr,size_t already_written){ /* Check if the current file has enough space to receive the whole block*/ MUMPS_INT ret_code; MUMPS_INT file; mumps_file_struct *current_file; long long vaddr_loc; MUMPS_OFF_T pos; /* Virtual address based file management scheme */ vaddr_loc=vaddr*(long long)mumps_elementary_data_size+(long long)already_written; mumps_gen_file_info(vaddr_loc,&pos,&file); ret_code=mumps_set_file(type,file); if(ret_code<0){ return ret_code; } current_file=(mumps_files+type)->mumps_io_current_file; current_file->write_pos=pos; mumps_update_current_file_position(current_file); return 0; } MUMPS_INT mumps_prepare_pointers_for_write(double to_be_written, MUMPS_OFF_T * pos_in_file, MUMPS_INT * file_number,const MUMPS_INT type,long long vaddr,size_t already_written){ MUMPS_INT ret_code; ret_code=mumps_compute_where_to_write(to_be_written,type,vaddr,already_written); if(ret_code<0){ return ret_code; } *pos_in_file=((mumps_files+type)->mumps_io_current_file)->current_pos; *file_number=(mumps_files+type)->mumps_io_current_file_number; return 0; } MUMPS_INT mumps_compute_nb_concerned_files(long long block_size, MUMPS_INT * nb_concerned_files,long long vaddr){ MUMPS_INT file; MUMPS_OFF_T pos, available_size; long long vaddr_loc; vaddr_loc=vaddr*(long long)mumps_elementary_data_size; mumps_gen_file_info(vaddr_loc,&pos,&file); available_size=mumps_io_max_file_size-pos+1; *nb_concerned_files=(MUMPS_INT)my_ceil((double)(my_max(0,((block_size)*(double)(mumps_elementary_data_size))-(double)available_size))/(double)mumps_io_max_file_size)+1; return 0; } MUMPS_INT mumps_io_do_write_block(void * address_block, long long block_size, MUMPS_INT * type_arg, long long vaddr, MUMPS_INT * ierr){ /* Type of fwrite : size_t fwrite(const void *ptr, size_t size, *size_t nmemb, FILE *stream); */ size_t write_size; MUMPS_INT i; MUMPS_INT nb_concerned_files=0; MUMPS_INT ret_code,file_number_loc; MUMPS_OFF_T pos_in_file_loc; double to_be_written; #if ! defined( MUMPS_WIN32 ) MUMPS_INT* file; #else FILE** file; #endif MUMPS_OFF_T where; void* loc_addr; MUMPS_INT type; size_t already_written=0; char buf[64]; type=*type_arg; loc_addr=address_block; mumps_compute_nb_concerned_files(block_size,&nb_concerned_files,vaddr); to_be_written=((double)mumps_elementary_data_size)*((double)(block_size)); for(i=0;imumps_io_current_file)->write_pos)>to_be_written){ write_size=(size_t)to_be_written; already_written=(size_t)to_be_written; }else{ write_size=(size_t)((double)(mumps_io_max_file_size-((mumps_files+type)->mumps_io_current_file)->write_pos)); already_written=already_written+(size_t)write_size; } #if defined( MUMPS_WIN32 ) write_size=(size_t)(MUMPS_INT)((write_size)/mumps_elementary_data_size); #endif file=&(((mumps_files+type)->mumps_io_current_file)->file); where=((mumps_files+type)->mumps_io_current_file)->write_pos; #if ! defined( MUMPS_WIN32 ) && ! defined (WITHOUT_PTHREAD) # ifdef WITH_PFUNC if(mumps_io_flag_async==IO_ASYNC_TH){ mumps_io_unprotect_pointers(); } # endif #endif ret_code=mumps_io_write__(file,loc_addr,write_size,where,type); if(ret_code<0){ return ret_code; } #if ! defined( MUMPS_WIN32 ) && ! defined (WITHOUT_PTHREAD) # ifdef WITH_PFUNC if(mumps_io_flag_async==IO_ASYNC_TH){ mumps_io_protect_pointers(); } # endif #endif #if ! defined( MUMPS_WIN32 ) ((mumps_files+type)->mumps_io_current_file)->write_pos=((mumps_files+type)->mumps_io_current_file)->write_pos+((MUMPS_INT)write_size); to_be_written=to_be_written-((MUMPS_INT)write_size); loc_addr=(void*)((size_t)loc_addr+write_size); #else /* fread and write */ ((mumps_files+type)->mumps_io_current_file)->write_pos=((mumps_files+type)->mumps_io_current_file)->write_pos+((MUMPS_INT8)write_size*mumps_elementary_data_size); to_be_written=to_be_written-((MUMPS_INT)write_size*mumps_elementary_data_size); loc_addr=(void*)((size_t)loc_addr+(size_t)((MUMPS_INT)write_size*mumps_elementary_data_size)); #endif #if ! defined( MUMPS_WIN32 ) && ! defined (WITHOUT_PTHREAD) # ifdef WITH_PFUNC if(mumps_io_flag_async==IO_ASYNC_TH){ mumps_io_unprotect_pointers(); } # endif #endif } if(to_be_written!=0){ *ierr = -90; sprintf(buf,"Internal (1) error in low-level I/O operation %lf",to_be_written); return mumps_io_error(*ierr,buf); } /* printf("write ok -> %d \n");*/ return 0; } MUMPS_INT mumps_io_do_read_block(void * address_block, long long block_size, MUMPS_INT * type_arg, long long vaddr, MUMPS_INT * ierr){ size_t size; #if ! defined( MUMPS_WIN32 ) MUMPS_INT* file; #else FILE** file; #endif double read_size; MUMPS_INT local_fnum; MUMPS_OFF_T local_offset; void *loc_addr; long long vaddr_loc; MUMPS_OFF_T size_effectively_read; MUMPS_INT type; type=*type_arg; if(block_size==0){ return 0; } read_size=(double)mumps_elementary_data_size*(double)(block_size); loc_addr=address_block; vaddr_loc=vaddr*(long long)mumps_elementary_data_size; /* We need to read a total of read_size bytes, possibly * by chunks and possibly from several files */ while(read_size>0){ /* Virtual addressing based management stuff */ local_fnum=(MUMPS_INT)(vaddr_loc/(long long)mumps_io_max_file_size); local_offset=(MUMPS_OFF_T)(vaddr_loc%(long long)mumps_io_max_file_size); file=&((((mumps_files+type)->mumps_io_pfile_pointer_array)+local_fnum)->file); #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 size_effectively_read=mumps_io_read__(file,loc_addr,size,local_offset,type); if(size_effectively_read<0){ /* an error occurred */ *ierr=(MUMPS_INT)size_effectively_read; return *ierr; } #if defined( MUMPS_WIN32 ) size_effectively_read=size_effectively_read*mumps_elementary_data_size; #endif vaddr_loc=vaddr_loc+(long long)size_effectively_read; read_size=read_size-(double)size_effectively_read; loc_addr=(void*)((size_t)loc_addr+size_effectively_read); local_fnum++; local_offset=0; if(local_fnum>(mumps_files+type)->mumps_io_nb_file){ *ierr = -90; return mumps_io_error(*ierr,"Internal error (2) in low level read op\n"); } } return 0; } MUMPS_INT mumps_free_file_pointers(MUMPS_INT *step){ MUMPS_INT i,j,bound,ierr; /* Free prefix only for facto */ if (*step == 0) free(mumps_ooc_file_prefix); if(mumps_files == NULL ) return 0; bound=mumps_io_nb_file_type; 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_files+j)->mumps_io_pfile_pointer_array); } free(mumps_files); return 0; } /* Initialize the mumps_file_type structure at th position in mumps_files. It only set values with no allocation to avoid any errors. */ void mumps_io_init_file_struct(MUMPS_INT* nb,MUMPS_INT which) { (mumps_files+which)->mumps_io_current_file_number = -1; (mumps_files+which)->mumps_io_last_file_opened = -1; (mumps_files+which)->mumps_io_nb_file_opened = 0; (mumps_files+which)->mumps_io_nb_file=*nb; (mumps_files+which)->mumps_io_pfile_pointer_array = NULL; (mumps_files+which)->mumps_io_current_file=NULL; } /* Allocate the file structures for factor files and initialize the is_opened filed to 0 */ MUMPS_INT mumps_io_alloc_file_struct(MUMPS_INT* nb,MUMPS_INT which) { MUMPS_INT i; (mumps_files+which)->mumps_io_pfile_pointer_array=(mumps_file_struct *)malloc((*nb)*sizeof(mumps_file_struct)); if((mumps_files+which)->mumps_io_pfile_pointer_array==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } for(i=0;i<*nb;i++){ (((mumps_files+which)->mumps_io_pfile_pointer_array)+i)->is_opened=0; } return 0; } MUMPS_INT mumps_init_file_structure(MUMPS_INT* _myid, long long *total_size_io,MUMPS_INT *size_element,MUMPS_INT *nb_file_type,MUMPS_INT *flag_tab, MUMPS_INT keep255) { /* Computes the number of files needed. Uses ceil value. */ MUMPS_INT ierr; #if ! defined( MUMPS_WIN32 ) MUMPS_INT mumps_flag_open; #endif MUMPS_INT i,nb; MUMPS_INT mumps_io_nb_file; mumps_init_max_file_size(&mumps_io_max_file_size, keep255); mumps_io_nb_file_type=*nb_file_type; mumps_io_nb_file=(MUMPS_INT)((((double)(*total_size_io)*1000000)*((double)(*size_element)))/(double)mumps_io_max_file_size)+1; #if ! defined( MUMPS_WIN32 ) mumps_flag_open=0; #endif mumps_io_myid=*_myid; mumps_elementary_data_size=*size_element; /* Allocates the memory necessary to handle the file pointer array.*/ mumps_files=(mumps_file_type *)malloc(mumps_io_nb_file_type*sizeof(mumps_file_type)); if(mumps_files==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } /* Safe initialization of the mumps_file_type elements */ for(i=0;imumps_flag_open=mumps_flag_open|O_WRONLY|O_CREAT|O_TRUNC; # if defined(__MINGW32__) /* O_BINARY necessary */ (mumps_files+i)->mumps_flag_open=(mumps_files+i)->mumps_flag_open|O_BINARY; # endif #else strcpy((mumps_files+i)->mumps_flag_open,"wb"); #endif break; case 1: #if ! defined( MUMPS_WIN32 ) (mumps_files+i)->mumps_flag_open=mumps_flag_open|O_RDONLY|O_CREAT|O_TRUNC; # if defined(__MINGW32__) /* O_BINARY necessary */ (mumps_files+i)->mumps_flag_open=(mumps_files+i)->mumps_flag_open|O_BINARY; # endif #else strcpy((mumps_files+i)->mumps_flag_open,"rb"); #endif break; case 2: #if ! defined( MUMPS_WIN32 ) (mumps_files+i)->mumps_flag_open=mumps_flag_open|O_RDWR|O_CREAT|O_TRUNC; # if defined(__MINGW32__) /* O_BINARY necessary */ (mumps_files+i)->mumps_flag_open=(mumps_files+i)->mumps_flag_open|O_BINARY; # endif #else strcpy((mumps_files+i)->mumps_flag_open,"rwb"); #endif break; default: return mumps_io_error(-90,"unknown value of flag_open\n"); } ierr=mumps_io_alloc_file_struct(&nb,i); if(ierr<0){ return ierr; } ierr=mumps_set_file(i,0); if(ierr<0){ return ierr; } } return 0; } MUMPS_INT mumps_init_file_name(char* mumps_dir,char* mumps_file, MUMPS_INT* mumps_dim_dir,MUMPS_INT* mumps_dim_file,MUMPS_INT* _myid){ MUMPS_INT i; char *tmp_dir,*tmp_fname; char base_name[20]; MUMPS_INT dir_flag=0,file_flag=0; char mumps_base[10]="mumps_"; tmp_dir=(char *)malloc(((*mumps_dim_dir)+1)*sizeof(char)); if(tmp_dir==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } tmp_fname=(char *)malloc(((*mumps_dim_file)+1)*sizeof(char)); if(tmp_fname==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } for(i=0;i<*mumps_dim_dir;i++){ tmp_dir[i]=mumps_dir[i]; } tmp_dir[i]=0; for(i=0;i<*mumps_dim_file;i++){ tmp_fname[i]=mumps_file[i]; } tmp_fname[i]=0; if(strcmp(tmp_dir,UNINITIALIZED)==0){ dir_flag=1; free(tmp_dir); tmp_dir=getenv("MUMPS_OOC_TMPDIR"); if(tmp_dir==NULL){ tmp_dir=MUMPS_OOC_DEFAULT_DIR; } } if(strcmp(tmp_fname,UNINITIALIZED)==0){ free(tmp_fname); tmp_fname=getenv("MUMPS_OOC_PREFIX"); file_flag=1; } if(tmp_fname!=NULL){ #if ! defined( MUMPS_WIN32 ) sprintf(base_name,"_%s%d_XXXXXX",mumps_base,(int)*_myid); #else sprintf(base_name,"_%s%d",mumps_base,*_myid); #endif mumps_ooc_file_prefix=(char *)malloc((strlen(SEPARATOR)+strlen(tmp_dir)+strlen(tmp_fname)+strlen(base_name)+1+1)*sizeof(char)); if(mumps_ooc_file_prefix==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } sprintf(mumps_ooc_file_prefix,"%s%s%s%s",tmp_dir,SEPARATOR,tmp_fname,base_name); }else{ #if ! defined( MUMPS_WIN32 ) sprintf(base_name,"%s%s%d_XXXXXX",SEPARATOR,mumps_base,(int)*_myid); #else sprintf(base_name,"%s%s%d",SEPARATOR,mumps_base,*_myid); #endif mumps_ooc_file_prefix=(char *)malloc((strlen(SEPARATOR)+strlen(tmp_dir)+strlen(base_name)+1)*sizeof(char)); if(mumps_ooc_file_prefix==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } sprintf(mumps_ooc_file_prefix,"%s%s%s",tmp_dir,SEPARATOR,base_name); } if(!dir_flag){ free(tmp_dir); } if(!file_flag){ free(tmp_fname); } return 0; } MUMPS_INT mumps_io_get_nb_files(MUMPS_INT* nb_files, const MUMPS_INT* type){ *nb_files=((mumps_files+*type)->mumps_io_last_file_opened)+1; return 0; } MUMPS_INT mumps_io_get_file_name(MUMPS_INT* indice,char* name,MUMPS_INT* length,MUMPS_INT* type){ MUMPS_INT i; i=(*indice)-1; strcpy(name,(((mumps_files+*type)->mumps_io_pfile_pointer_array)+i)->name); *length=(MUMPS_INT)strlen(name)+1; return 0; } MUMPS_INT mumps_io_alloc_pointers(MUMPS_INT* nb_file_type,MUMPS_INT * dim){ MUMPS_INT ierr; MUMPS_INT i; /* This is called by solve step, we have only one type of files */ mumps_io_nb_file_type=*nb_file_type; mumps_files=(mumps_file_type *)malloc(mumps_io_nb_file_type*sizeof(mumps_file_type)); if(mumps_files==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } for(i=0;imumps_flag_open=mumps_flag_open|O_RDONLY; #else strcpy((mumps_files+i)->mumps_flag_open,"rb"); #endif } mumps_io_myid=*myid_arg; mumps_elementary_data_size=*size_element; mumps_io_flag_async=*async_arg; return 0; } MUMPS_INT mumps_io_set_file_name(MUMPS_INT* indice,char* name,MUMPS_INT* length,MUMPS_INT* type){ MUMPS_INT i; i=(*indice)-1; strcpy((((mumps_files+*type)->mumps_io_pfile_pointer_array)+i)->name,name); return 0; } MUMPS_INT mumps_io_open_files_for_read(){ MUMPS_INT i,j; mumps_file_struct *mumps_io_pfile_pointer_array; #if defined (sgi) || defined (__sgi) struct dioattr dio; #endif for(j=0;jmumps_io_pfile_pointer_array; for(i=0;i<(mumps_files+j)->mumps_io_nb_file;i++){ #if ! defined( MUMPS_WIN32 ) (mumps_io_pfile_pointer_array+i)->file=open((mumps_io_pfile_pointer_array+i)->name,(mumps_files+j)->mumps_flag_open); if((mumps_io_pfile_pointer_array+i)->file==-1){ return mumps_io_sys_error(-90,"Problem while opening OOC file"); } #else (mumps_io_pfile_pointer_array+i)->file=fopen((mumps_io_pfile_pointer_array+i)->name,(mumps_files+j)->mumps_flag_open); if((mumps_io_pfile_pointer_array+i)->file==NULL){ return mumps_io_error(-90,"Problem while opening OOC file"); } (mumps_io_pfile_pointer_array+i)->is_opened=1; #endif } } return 0; } MUMPS_INT mumps_io_set_last_file(MUMPS_INT* dim,MUMPS_INT* type){ (mumps_files+*type)->mumps_io_last_file_opened=*dim-1; (mumps_files+*type)->mumps_io_nb_file_opened=*dim; return 0; } #if ! defined( MUMPS_WIN32 ) && ! defined (WITHOUT_PTHREAD) # ifdef WITH_PFUNC MUMPS_INT mumps_io_protect_pointers(){ pthread_mutex_lock(&mumps_io_pwrite_mutex); return 0; } MUMPS_INT mumps_io_unprotect_pointers(){ pthread_mutex_unlock(&mumps_io_pwrite_mutex); return 0; } MUMPS_INT mumps_io_init_pointers_lock(){ pthread_mutex_init(&mumps_io_pwrite_mutex,NULL); return 0; } MUMPS_INT mumps_io_destroy_pointers_lock(){ pthread_mutex_destroy(&mumps_io_pwrite_mutex); return 0; } # endif /*WITH_PFUNC*/ #endif /* _WIN32 && WITHOUT_PTHREAD */ /* mumps_io_read__ reads up to size bytes and returns either the number of bytes read, or, in case of error, a negative n error */ MUMPS_OFF_T mumps_io_read__(void * file,void * loc_addr,size_t size,MUMPS_OFF_T local_offset,MUMPS_INT type){ MUMPS_OFF_T ret_code; #if ! defined( MUMPS_WIN32 ) ret_code=mumps_io_read_os_buff__(file,loc_addr, size,local_offset); #else ret_code=mumps_io_read_win32__(file,loc_addr, size,local_offset); #endif return ret_code; } #if ! defined( MUMPS_WIN32 ) MUMPS_OFF_T mumps_io_read_os_buff__(void * file,void * loc_addr,size_t size, MUMPS_OFF_T local_offset){ MUMPS_OFF_T ret_code; # ifdef WITH_PFUNC ret_code=(MUMPS_OFF_T)pread(*(MUMPS_INT *)file,loc_addr,size,(off_t)local_offset); # else lseek(*(MUMPS_INT *)file, (off_t)local_offset,SEEK_SET); ret_code=(MUMPS_OFF_T)read(*(MUMPS_INT *)file,loc_addr,size); # endif if(ret_code==-1){ return (MUMPS_OFF_T)mumps_io_sys_error(-90,"Problem with low level read"); } return ret_code; /* can be smaller than size in case size is large, typically > 2GB */ } #endif #if defined( MUMPS_WIN32 ) MUMPS_OFF_T mumps_io_read_win32__(void * file, void * loc_addr,size_t size, MUMPS_OFF_T local_offset){ MUMPS_OFF_T ret_code; #if defined(MUMPS_WINLARGEFILES) _fseeki64(*(FILE **)file,local_offset,SEEK_SET); /* expects where to be __int64 */ #else fseek(*(FILE **)file,(long) local_offset,SEEK_SET); #endif ret_code=(MUMPS_OFF_T)fread(loc_addr,mumps_elementary_data_size,size,*(FILE **)file); /* with fread, all requested bytes must be read and if this is not the case an error is raised */ if((ret_code!=(MUMPS_OFF_T)size)||(ferror(*(FILE**)file))){ return (MUMPS_OFF_T)mumps_io_error(-90,"Problem with I/O operation\n"); } return ret_code; } #endif MUMPS_INT mumps_io_write__(void *file, void *loc_addr, size_t write_size, MUMPS_OFF_T where, MUMPS_INT type){ MUMPS_INT ret_code; #if ! defined( MUMPS_WIN32 ) ret_code=mumps_io_write_os_buff__(file,loc_addr, write_size,where); if(ret_code<0){ return ret_code; } #else ret_code=mumps_io_write_win32__(file,loc_addr, write_size,where); if(ret_code<0){ return ret_code; } #endif return 0; } #if ! defined( MUMPS_WIN32 ) MUMPS_INT mumps_io_write_os_buff__(void *file, void *loc_addr, size_t write_size, MUMPS_OFF_T where){ size_t ret_code; # ifdef WITH_PFUNC ret_code=pwrite(*(MUMPS_INT *)file,loc_addr,write_size,(off_t)where); # else /*in this case all the I/O's are made by the I/O thread => we don't need to protect the file pointer.*/ lseek(*(MUMPS_INT *)file,(off_t)where,SEEK_SET); ret_code=write(*(MUMPS_INT *)file,loc_addr,write_size); # endif if((MUMPS_INT)ret_code==-1){ return mumps_io_sys_error(-90,"Problem with low level write"); } else if(ret_code!=write_size){ return mumps_io_error(-90,"Error not enough space on disk \n"); } return 0; } #endif #if defined( MUMPS_WIN32 ) MUMPS_INT mumps_io_write_win32__(void *file, void *loc_addr, size_t write_size, MUMPS_OFF_T where){ size_t ret_code; #if defined(MUMPS_WINLARGEFILES) _fseeki64(*(FILE **)file,where,SEEK_SET); /* expects where to be __int64 */ #else fseek(*(FILE **)file,(long)where,SEEK_SET); #endif ret_code=fwrite(loc_addr,mumps_elementary_data_size, write_size,*(FILE**)file); if((ret_code!=write_size)||(ferror(*(FILE**)file))){ return mumps_io_error(-90,"Problem with I/O operation\n"); } return 0; } #endif MUMPS_5.8.1/INSTALL0000664000175000017500000004455315042446416013510 0ustar amestoyamestoy=========================================== MUMPS 5.8.1 INSTALLATION =========================================== Pre-requisites -------------- If you only want to use the sequential version, you need: -> an optimized sequential or multithreaded BLAS library -> the LAPACK library If you want to use MUMPS on a multicore machine, you need: -> a multithreaded BLAS library -> the LAPACK library -> additional gains can be expected compiling/linking with OpenMP (see userguide, sections "Combining MPI and multithreaded parallelism" and "Enabling the BLR functionality at installation") If you want to use the parallel (distributed memory MPI based) version, you need: -> MPI -> BLAS library -> BLACS library -> LAPACK and ScaLAPACK libraries For performance (time and memory issues) we very strongly recommend to install: -> SCOTCH and/or METIS for the sequential and parallel versions -> PT-SCOTCH and/or ParMetis to parallelize the analysis phase (parallel version only: ParMetis and PT-SCOTCH must be disabled for the sequential version as this would otherwise lead to undefined MPI symbols at the link phase) Installation ------------ The following steps can be applied. % tar zxvf MUMPS_5.8.1.tar.gz % cd MUMPS_5.8.1 You then need to build a file called Makefile.inc corresponding to your architecture. A few examples are available in the directory Make.inc : Makefile.debian.SEQ : default for debian systems with standard packages, sequential version Makefile.debian.PAR : default for debian systems with standard packages, parallel version Makefile.FREEBSD10.SEQ : default Makefile.inc for a FreeBSD system, sequential version. Makefile.FREEBSD10.PAR : default Makefile.inc for a FreeBSD system, parallel version. Makefile.G95.SEQ : default Makefile.inc for the G95 compiler, sequential version. Makefile.G95.PAR : default Makefile.inc for the G95 compiler, parallel version. Makefile.INTEL.SEQ : default for PC with the Intel suite (compilers and MKL), sequential. Makefile.INTEL.PAR : default for PC with the Intel suite (compilers, MPI and MKL), parallel. Makefile.NEC.SEQ : default Makefile.inc for a NEC, sequential version. Makefile.NEC.PAR : default Makefile.inc for a NEC, parallel version. Makefile.SGI.SEQ : default Makefile.inc for an Origin, sequential version. Makefile.SGI.PAR : default Makefile.inc for an Origin, parallel version. Makefile.SUN.SEQ : default Makefile.inc for a SUN, sequential version. Makefile.SUN.PAR : default Makefile.inc for a SUN, parallel version. Makefile.SP64.SEQ : default for SP (64 bits), sequential version. Makefile.SP64.PAR : default for SP (64 bits), parallel version. Makefile.WIN.MS-Intel.SEQ : default for Windows with Intel compiler, sequential, with GNU make. Makefile.WIN.MS-G95.SEQ : default for Windows with g95 compiler, sequential, with GNU make. For example, a parallel version of MUMPS on a debian or ubuntu system and standard packages copy Make.inc/Makefile.debian.PAR into Makefile.inc: % cp Make.inc/Makefile.debian.PAR ./Makefile.inc However, in most cases, Makefile.inc should be adapted to fit with your architecture, libraries and compilers (see comments in the Makefile.inc.generic or Makefile.inc.generic.SEQ for details). The variables LIBBLAS (BLAS library), SCALAP (ScaLAPACK and LAPACK libraries), INCPAR (include files for MPI), LIBPAR (library files for MPI) are concerned. We also strongly recommend to install METIS and/or SCOTCH, see the ordering section of Makefile.inc. Makefile.inc also contains a line "PLAT=" which defines an empty $(PLAT) Makefile variable. You can use it to add a default suffix to the generated libraries. By default, only the double precision version of MUMPS will be installed, with static MUMPS libraries. The command: % make will build the version for a specific arithmetic, where is one of 's', 'd','c','z' (for single precision real, double precision real, complex, and double complex). The command: % make all will compile versions of MUMPS for all 4 arithmetics. After issuing the command: % make all , ./lib will contain the mumps libraries libxmumps.a (with x = 'd', 'c', 's' or 'z') and libmumps_common.a. Both must be included at link time in an external program. A simple Fortran test driver in ./examples (see ./examples/README) will also be compiled as well as an example of using MUMPS from a C main program. Dynamic libraries: ----------------- Instead of static libraries, you can build dynamic libraries: make sshared make dshared make cshared make zshared make allshared Make sure to do a 'make clean' if you previously installed static libraries, since dynamic libraries require the -fPIC option during compilation (if needed, the definition FPIC_OPT=-fPIC can be adapted in the Makefile.inc) The dynamic libraries (e.g. libmumps.so, libdmumps.so, etc.) are installed in the directory MUMPS_5.8.1/lib/ so that including the directory MUMPS_5.8.1/lib in your LD_LIBRARY_PATH environment variable will allow them to be successively loaded at runtime. Alternatively, you can uncomment and adapt the line #RPATH_OPT= -Wl,-rpath /path/to/MUMPS_5.8.1/lib in the Makefile.inc Although we do not currently support an official SONAME, note that, given a version x.y.z of MUMPS, it is binary/ABI compatible with x.y.z' versions, but not with x.y'.z'' versions. Preprocessing constants ----------------------- This section describes some preprocessing flags that can be added in the OPTF and OPTC variables of Makefile.inc. -DDETERMINISTIC_PARALLEL_GRAPH: When using several MPI processes, the order of the edges of the graphs constructed by MUMPS in parallel may vary between successive execuions. Ordering packages (e.g., SCOTCH, PT-SCOTCH, METIS, parMETIS) are sensitive to this order, possibly leading to different flops and memory estimates between executions. When compiling MUMPS with -DDETERMINISTIC_PARALLEL_GRAPH, the order of the edges of the graph passed to ordering packages will be identical for each run. -DMAIN_COMP: Note that some Fortran runtime libraries define the "main" symbol. This can cause problems when using MUMPS from C if Fortran is used for the link phase. One approach is to use a specific flag (such as -nofor_main for Intel ifort compiler). Another approach is to use the C linker (gcc, etc...) and add manually the Fortran runtime libraries (that should not define the symbol "main"). Finally, if the previous approaches do not work, compile the C example with "-DMAIN_COMP". This might not work well with some MPI implementations (see options in Makefiles and the FAQ page at http://mumps-solver.org). -DAdd_ , -DAdd__ and -DUPPER: These options are used for defining the calling convention from C to Fortran or Fortran to C. Some other preprocessing options correspond to default architectures and are defined in specific Makefiles. -DPRINT_BACKTRACE_ON_ABORT: Print backtrace (BACKTRACE with GFORTRAN and TRACEBACKQQ with INTEL_COMPILER) in case of call to MUMPS_ABORT() -DMUMPS_USE_BLAS2: Some BLAS vendor libraries have more efficient BLAS3 than BLAS2 routines, even when one of the dimensions is set to 1. For this reason MUMPS typically avoids BLAS2 calls and replaces them by BLAS3 calls with one dimension set to 1 (e.g. avoid dgemv and use dgemm instead). The flag -DMUMPS_USE_BLAS2 keeps the BLAS2 calls instead of replacing them by BLAS3 calls with one of the dimensions set to 1. -DBLR_NOOPENMP: When this flag is used, the BLR feature will use multithreaded BLAS and not call BLAS within OpenMP regions. To be used only if there is a problem of compatibility between the BLAS library and OpenMP, or for debugging purposes. -DNOSCALAPACK When this flag is used, MUMPS does not need to be linked with the BLACS and ScaLAPACK libraries. This is not recommended because performance can be decreased. ICNTL(13) will be ignored if it is set to 0. -DAVOID_MPI_IN_PLACE: MUMPS uses MPI_IN_PLACE in some collective MPI operations. In case of MPI environments where MPI_IN_PLACE is failing, it is possible to avoid the use of MPI_IN_PLACE at the cost of more temporary memory allocation and possibly less efficient code. -DMUMPS_SCOTCHIMPORTOMPTHREADS: MUMPS provides OpenMP threads to multithreaded SCOTCH/PT-SCOTCH, instead of letting SCOTCH creating new threads. This feature can, in some cases, resolve thread affinity issues impacting performance negatively. Note that, when Scotch 7.0.4 is compiled with cmake, the symbol scotchfcontextrandomclone is missing from the Scotch library. To solve this issue, you may either compile Scotch 7.0.4 with make, or add "library_context_f.c" after "library_context.c" in the file "scotch-v7.0.4/src/libscotch/CMakeLists.txt". -DNO_SAVE_RESTORE: Disables the save restore feature. RINFO(7), RINFO(8), RINFOG(17), RINFOG(18) will no longer be computed, and a call to MUMPS with JOB=7 or JOB=8 will lead to an error. Sequential version ------------------ You can use the parallel MPI version of MUMPS on a single processor. If you only plan to use MUMPS on a uniprocessor machine, and do not want to install parallel libraries such as MPI, ScaLAPACK, etc... then it might be more convenient to use one of the Makefile..SEQ to build a sequential version of MUMPS instead of a parallel one. For that, a dummy MPI library (available in ./libseq) defining all symbols related to parallel libraries is used at the link phase. Note that you should use 'make clean' before building the MUMPS sequential library if you had previously built a parallel version. And vice versa. Compiling and linking your program with MUMPS --------------------------------------------- Basically, ./lib/lib[sdcz]mumps.a and ./lib/libmumps_common.a constitute the MUMPS library and ./include/*.h are the include files. Also, some BLAS, LAPACK, ScaLAPACK, BLACS, and MPI are needed. (Except for the sequential version where ./libseq/libmpiseq.a is used.) Please refer to the Makefile available in the directory ./examples for an example of how to link your program with MUMPS. We advise to use the same compiler alignment options for compiling your program as were used for compiling MUMPS. Otherwise some derived datatypes may not match. Using MUMPS from an existing project ------------------------------------ If you want to use MUMPS from outside the MUMPS installation directory, please make sure the ./lib/ and ./include/ directories can be accessed, and start from the Makefile.inc used at installation and the Makefile available in ./examples as models. Interface with the Metis and ParMetis orderings ----------------------------------------------- Since the release of MUMPS 4.10.0, the Metis API has changed. MUMPS 5.0 and later versions assume that Metis 5.1.0 or ParMetis 4.0.3 or later are installed, and that the newer versions of Metis/ParMetis are backward compatible with Metis 5.1.0/ParMetis 4.0.3. It is however still possible to continue using Metis versions 4.0.3 or lower by forcing the compilation flag -Dmetis4 in your Makefile.inc, and to continue using ParMetis versions 3.2.0 or lower by forcing the compilation flag -Dparmetis3. Note that Metis 5.0.3 and ParMetis 4.0.1/4.0.2 have never been supported in MUMPS. 32-bit versus 64-bit Fortran integers ------------------------------------- MUMPS uses a mix of 32-bit and 64-bit integers depending on the possible sizes of the integers that must be manipulated. Most integers at the MUMPS interface level are 32-bit integers: only NNZ and NNZ_loc are 64-bit integers, as the number of non-zeros in a matrix can exceed the 32-bit integer limit on large problems. Internally, MUMPS uses a mix of 32-bit and 64-bit integers. 64-bit integers are mainly used for data proportional to NNZ or NNZ_loc or to address large arrays. However, external libraries like BLAS, MPI, (Sca)LAPACK, can remain 32-bit. For each ordering, the user should decide at installation time if the ordering manipulates 32-bit or 64-bit indices. 64-bit integers are recommended if the number of nonzeros in the matrix becomes significant as compared to 2^31-1 - for PORD: by default, PORD is installed in a way compatible with standard integers (Fortran INTEGER). Installation of MUMPS with -DPORD_INTSIZE64 (i.e. adding the -DPORD_INTSIZE64 option to the OPTC variable from your Makefile.inc) will install PORD with 64-bit integers and MUMPS will also call PORD with 64-bit integers. Warning: if you activate or deactivate -DPORD_INTSIZE64 between two installations, the previously installed pord library should be cleaned before recompilation. This can be done with "make clean". - for METIS/parMETIS: in the file metis.h (assuming here a version of metis >= 5), it is possible to modify the line "#define IDXTYPEWIDTH 32" by "#define IDXTYPEWIDTH 64" in order to use 64-bit integers for indices (see comments in metis.h for more information). MUMPS will then check the value of IDXTYPE in metis.h in order to call METIS with integer parameters of the correct datatype. - for scotch/pt-SCOTCH: in scotch.h, you can compile SCOTCH either with -DINTSIZE32 (default) or with -DINTSIZE64, in order to process large graphs. MUMPS will then check the size of a SCOTCH integer in scotch.h in order to call SCOTCH with integer parameters of the correct datatype Finally, it is possible to force all integers to be 64-bit at installation. This can be useful, if, for example, MUMPS is called from an environment where all integers are 64-bit. This approach relies: i) on a Fortran compiler flag (e.g., -i8, -fdefault-integer-8, or something else, depending on your compiler) that should be added in the OPTF variable from the Makefile.inc corresponding to your local configuration. ii) on forcing a 64-bit default integer in C code, by adding the -DINTSIZE64 option to the OPTC variable from your Makefile.inc (remark that this option will also force an installation of PORD with 64-bit integers, since PORD installation is based on the same OPTC variable) iii) on the fact that all external libraries called by MUMPS should use 64-bit integers. In particular, all external orderings must have been compiled with 64-bit integers as we have not developed 64-bit to 32-bit wrappers. Furthermore: - for the MPI-free version, METIS, SCOTCH, BLAS, LAPACK should thus also rely on 64-bit integers. - for the MPI version, one also needs an MPI (and ScaLAPACK) implementation where all integers are 64-bit (both MPI_INTEGER and counts). Remark that for this latter point, Intel provides an ilp64 version of MPI where integers (counts, MPI_INTEGER, ...) are 64-bit. However, in the MPI versions we have tested, MPI_2INTEGER which could be expected to be 128-bit in that case is only 64-bit, see Intel documentation. In order to have MUMPS working correcly with such MPI versions, please try adding -DWORKAROUNDINTELILP64MPI2INTEGER to the OPTF variable of your Makefile.inc Platform MPI also provides an interface for 64-bit default integers, for which we had feedback that MUMPS should be compiled with -DWORKAROUNDILP64MPICUSTOMREDUCE (but not -DWORKAROUNDINTELILP64MPI2INTEGER) - The OpenMP runtime library should also rely on 64-bit integers. Adding -DWORKAROUNDINTELILP64OPENMPLIMITATION to the OPTF variable from the file Makefile.inc will use 32-bit integers during OpenMP calls and avoid warnings in an Intel environment. When including MUMPS headers files from a C application, one can check at compilation time the preprocessing constants MUMPS_INTSIZE32 and MUMPS_INTSIZE64 (see include/mumps_int_def.h generated during the build process and include/mumps_c_types.h) in order to see how MUMPS_INT was defined. At runtime, one can simply check sizeof(MUMPS_INT). If for some reason you are building MUMPS without using 'make', you can copy into include/mumps_int_def.h either src/mumps_int_def32_h.in (or src/mumps_int_def64_h.in in case of a MUMPS installation with 64-bit default integers). Using BLAS extension GEMMT -------------------------- If the BLAS library includes the GEMMT level-3 BLAS extension, we strongly recommend to use it. -DGEMMT_AVAILABLE should then be added to the OPTF variable of your Makefile.inc. This can significantly improve the performance of the factorization of symmetric matrices. To be compatible, the GEMMT signature should be the same as the ones described at https://www.intel.com/content/www/us/en/docs/onemkl/developer-reference-fortran/2023-0/gemmt.html https://sxauroratsubasa.sakura.ne.jp/documents/sdk/SDK_NLC/UsersGuide/man/dgemmt.html Platform and software dependencies ---------------------------------- Versions of MUMPS have been tested on a large range of platforms. MUMPS is potentially portable to any platform having a C and Fortran 90 compiler as well as MPI, BLACS, and ScaLAPACK installed. * WINDOWS ------- Although the MUMPS development team is not using Windows, you may be interested by discussions on this topic in the archives of MUMPS users, or by links to contributions from users (see the MUMPS website, and follow "Links"). -DMUMPS_WINLARGEFILES is designed to reduce the number of file descriptors under Windows and allow for files larger than 2GB. * FREEBSD AND SOLARIS ------------------- Under FreeBSD and Solaris, please check that the spaces are kept after the definition of commands. For example, use AR = ar -vr "" to force keeping the space after ar -vr See the example Makefile.FREEBSD10 in the Make.inc/ directory. Note that the absence of space in the main Makefile is motivated by portability on Windows environments. * gfortran versions >= 10 ----------------------- For MUMPS to compile with gfortran versions greater or equal t 10, the option '-fallow-argument-mismatch' should be included in OPTF in your Makefile.inc * MAC OSX ------- Dominique Orban has developed a Homebrew formula for MUMPS. Please check the "Links" page at http://mumps-solver.org and http://brew.sh * LAM --- lam version 6.5.6 or greater is required for the double complex version of MUMPS to work correctly. * MPICH ----- The double complex version does not work correctly with MPICH2 v 1.0.3, due to truncated messages when using double complex types. * CRAY ---- At least with old CRAY versions, 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. With recent Cray compilers, the flag -DMUMPS_ALLOC_FROM_C should be used, to avoid some Fortran pointer manipulations not allowed by the compiler. MUMPS_5.8.1/doc/0000775000175000017500000000000015042446422013206 5ustar amestoyamestoyMUMPS_5.8.1/doc/CeCILL-C_V1-fr.txt0000664000175000017500000005314615042446416016111 0ustar amestoyamestoy CONTRAT DE LICENCE DE LOGICIEL LIBRE CeCILL-C Avertissement Ce contrat est une licence de logiciel libre issue d'une concertation entre ses auteurs afin que le respect de deux grands principes prside sa rdaction: * d'une part, le respect des principes de diffusion des logiciels libres: accs au code source, droits tendus confrs aux utilisateurs, * d'autre part, la dsignation d'un droit applicable, le droit franais, auquel elle est conforme, tant au regard du droit de la responsabilit civile que du droit de la proprit intellectuelle et de la protection qu'il offre aux auteurs et titulaires des droits patrimoniaux sur un logiciel. Les auteurs de la licence CeCILL-C (pour Ce[a] C[nrs] I[nria] L[ogiciel] L[ibre]) sont: Commissariat l'Energie Atomique - CEA, tablissement public de recherche caractre scientifique, technique et industriel, dont le sige est situ 25 rue Leblanc, immeuble Le Ponant D, 75015 Paris. Centre National de la Recherche Scientifique - CNRS, tablissement public caractre scientifique et technologique, dont le sige est situ 3 rue Michel-Ange, 75794 Paris cedex 16. Institut National de Recherche en Informatique et en Automatique - INRIA, tablissement public caractre scientifique et technologique, dont le sige est situ Domaine de Voluceau, Rocquencourt, BP 105, 78153 Le Chesnay cedex. Prambule Ce contrat est une licence de logiciel libre dont l'objectif est de confrer aux utilisateurs la libert de modifier et de rutiliser le logiciel rgi par cette licence. L'exercice de cette libert est assorti d'une obligation de remettre la disposition de la communaut les modifications apportes au code source du logiciel afin de contribuer son volution. L'accessibilit au code source et les droits de copie, de modification et de redistribution qui dcoulent de ce contrat ont pour contrepartie de n'offrir aux utilisateurs qu'une garantie limite et de ne faire peser sur l'auteur du logiciel, le titulaire des droits patrimoniaux et les concdants successifs qu'une responsabilit restreinte. A cet gard l'attention de l'utilisateur est attire sur les risques associs au chargement, l'utilisation, la modification et/ou au dveloppement et la reproduction du logiciel par l'utilisateur tant donn sa spcificit de logiciel libre, qui peut le rendre complexe manipuler et qui le rserve donc des dveloppeurs ou des professionnels avertis possdant des connaissances informatiques approfondies. Les utilisateurs sont donc invits charger et tester l'adquation du logiciel leurs besoins dans des conditions permettant d'assurer la scurit de leurs systmes et/ou de leurs donnes et, plus gnralement, l'utiliser et l'exploiter dans les mmes conditions de scurit. Ce contrat peut tre reproduit et diffus librement, sous rserve de le conserver en l'tat, sans ajout ni suppression de clauses. Ce contrat est susceptible de s'appliquer tout logiciel dont le titulaire des droits patrimoniaux dcide de soumettre l'exploitation aux dispositions qu'il contient. Article 1 - DEFINITIONS Dans ce contrat, les termes suivants, lorsqu'ils seront crits avec une lettre capitale, auront la signification suivante: Contrat: dsigne le prsent contrat de licence, ses ventuelles versions postrieures et annexes. Logiciel: dsigne le logiciel sous sa forme de Code Objet et/ou de Code Source et le cas chant sa documentation, dans leur tat au moment de l'acceptation du Contrat par le Licenci. Logiciel Initial: dsigne le Logiciel sous sa forme de Code Source et ventuellement de Code Objet et le cas chant sa documentation, dans leur tat au moment de leur premire diffusion sous les termes du Contrat. Logiciel Modifi: dsigne le Logiciel modifi par au moins une Contribution Intgre. Code Source: dsigne l'ensemble des instructions et des lignes de programme du Logiciel et auquel l'accs est ncessaire en vue de modifier le Logiciel. Code Objet: dsigne les fichiers binaires issus de la compilation du Code Source. Titulaire: dsigne le ou les dtenteurs des droits patrimoniaux d'auteur sur le Logiciel Initial. Licenci: dsigne le ou les utilisateurs du Logiciel ayant accept le Contrat. Contributeur: dsigne le Licenci auteur d'au moins une Contribution Intgre. Concdant: dsigne le Titulaire ou toute personne physique ou morale distribuant le Logiciel sous le Contrat. Contribution Intgre: dsigne l'ensemble des modifications, corrections, traductions, adaptations et/ou nouvelles fonctionnalits intgres dans le Code Source par tout Contributeur. Module Li: dsigne un ensemble de fichiers sources y compris leur documentation qui, sans modification du Code Source, permet de raliser des fonctionnalits ou services supplmentaires ceux fournis par le Logiciel. Logiciel Driv: dsigne toute combinaison du Logiciel, modifi ou non, et d'un Module Li. Parties: dsigne collectivement le Licenci et le Concdant. Ces termes s'entendent au singulier comme au pluriel. Article 2 - OBJET Le Contrat a pour objet la concession par le Concdant au Licenci d'une licence non exclusive, cessible et mondiale du Logiciel telle que dfinie ci-aprs l'article 5 pour toute la dure de protection des droits portant sur ce Logiciel. Article 3 - ACCEPTATION 3.1 L'acceptation par le Licenci des termes du Contrat est rpute acquise du fait du premier des faits suivants: * (i) le chargement du Logiciel par tout moyen notamment par tlchargement partir d'un serveur distant ou par chargement partir d'un support physique; * (ii) le premier exercice par le Licenci de l'un quelconque des droits concds par le Contrat. 3.2 Un exemplaire du Contrat, contenant notamment un avertissement relatif aux spcificits du Logiciel, la restriction de garantie et la limitation un usage par des utilisateurs expriments a t mis disposition du Licenci pralablement son acceptation telle que dfinie l'article 3.1 ci dessus et le Licenci reconnat en avoir pris connaissance. Article 4 - ENTREE EN VIGUEUR ET DUREE 4.1 ENTREE EN VIGUEUR Le Contrat entre en vigueur la date de son acceptation par le Licenci telle que dfinie en 3.1. 4.2 DUREE Le Contrat produira ses effets pendant toute la dure lgale de protection des droits patrimoniaux portant sur le Logiciel. Article 5 - ETENDUE DES DROITS CONCEDES Le Concdant concde au Licenci, qui accepte, les droits suivants sur le Logiciel pour toutes destinations et pour la dure du Contrat dans les conditions ci-aprs dtailles. Par ailleurs, si le Concdant dtient ou venait dtenir un ou plusieurs brevets d'invention protgeant tout ou partie des fonctionnalits du Logiciel ou de ses composants, il s'engage ne pas opposer les ventuels droits confrs par ces brevets aux Licencis successifs qui utiliseraient, exploiteraient ou modifieraient le Logiciel. En cas de cession de ces brevets, le Concdant s'engage faire reprendre les obligations du prsent alina aux cessionnaires. 5.1 DROIT D'UTILISATION Le Licenci est autoris utiliser le Logiciel, sans restriction quant aux domaines d'application, tant ci-aprs prcis que cela comporte: 1. la reproduction permanente ou provisoire du Logiciel en tout ou partie par tout moyen et sous toute forme. 2. le chargement, l'affichage, l'excution, ou le stockage du Logiciel sur tout support. 3. la possibilit d'en observer, d'en tudier, ou d'en tester le fonctionnement afin de dterminer les ides et principes qui sont la base de n'importe quel lment de ce Logiciel; et ceci, lorsque le Licenci effectue toute opration de chargement, d'affichage, d'excution, de transmission ou de stockage du Logiciel qu'il est en droit d'effectuer en vertu du Contrat. 5.2 DROIT DE MODIFICATION Le droit de modification comporte le droit de traduire, d'adapter, d'arranger ou d'apporter toute autre modification au Logiciel et le droit de reproduire le logiciel en rsultant. Il comprend en particulier le droit de crer un Logiciel Driv. Le Licenci est autoris apporter toute modification au Logiciel sous rserve de mentionner, de faon explicite, son nom en tant qu'auteur de cette modification et la date de cration de celle-ci. 5.3 DROIT DE DISTRIBUTION Le droit de distribution comporte notamment le droit de diffuser, de transmettre et de communiquer le Logiciel au public sur tout support et par tout moyen ainsi que le droit de mettre sur le march titre onreux ou gratuit, un ou des exemplaires du Logiciel par tout procd. Le Licenci est autoris distribuer des copies du Logiciel, modifi ou non, des tiers dans les conditions ci-aprs dtailles. 5.3.1 DISTRIBUTION DU LOGICIEL SANS MODIFICATION Le Licenci est autoris distribuer des copies conformes du Logiciel, sous forme de Code Source ou de Code Objet, condition que cette distribution respecte les dispositions du Contrat dans leur totalit et soit accompagne: 1. d'un exemplaire du Contrat, 2. d'un avertissement relatif la restriction de garantie et de responsabilit du Concdant telle que prvue aux articles 8 et 9, et que, dans le cas o seul le Code Objet du Logiciel est redistribu, le Licenci permette un accs effectif au Code Source complet du Logiciel pendant au moins toute la dure de sa distribution du Logiciel, tant entendu que le cot additionnel d'acquisition du Code Source ne devra pas excder le simple cot de transfert des donnes. 5.3.2 DISTRIBUTION DU LOGICIEL MODIFIE Lorsque le Licenci apporte une Contribution Intgre au Logiciel, les conditions de distribution du Logiciel Modifi en rsultant sont alors soumises l'intgralit des dispositions du Contrat. Le Licenci est autoris distribuer le Logiciel Modifi sous forme de code source ou de code objet, condition que cette distribution respecte les dispositions du Contrat dans leur totalit et soit accompagne: 1. d'un exemplaire du Contrat, 2. d'un avertissement relatif la restriction de garantie et de responsabilit du Concdant telle que prvue aux articles 8 et 9, et que, dans le cas o seul le code objet du Logiciel Modifi est redistribu, le Licenci permette un accs effectif son code source complet pendant au moins toute la dure de sa distribution du Logiciel Modifi, tant entendu que le cot additionnel d'acquisition du code source ne devra pas excder le simple cot de transfert des donnes. 5.3.3 DISTRIBUTION DU LOGICIEL DERIVE Lorsque le Licenci cre un Logiciel Driv, ce Logiciel Driv peut tre distribu sous un contrat de licence autre que le prsent Contrat condition de respecter les obligations de mention des droits sur le Logiciel telles que dfinies l'article 6.4. Dans le cas o la cration du Logiciel Driv a ncessit une modification du Code Source le licenci s'engage ce que: 1. le Logiciel Modifi correspondant cette modification soit rgi par le prsent Contrat, 2. les Contributions Intgres dont le Logiciel Modifi rsulte soient clairement identifies et documentes, 3. le Licenci permette un accs effectif au code source du Logiciel Modifi, pendant au moins toute la dure de la distribution du Logiciel Driv, de telle sorte que ces modifications puissent tre reprises dans une version ultrieure du Logiciel, tant entendu que le cot additionnel d'acquisition du code source du Logiciel Modifi ne devra pas excder le simple cot du transfert des donnes. 5.3.4 COMPATIBILITE AVEC LA LICENCE CeCILL Lorsqu'un Logiciel Modifi contient une Contribution Intgre soumise au contrat de licence CeCILL, ou lorsqu'un Logiciel Driv contient un Module Li soumis au contrat de licence CeCILL, les stipulations prvues au troisime item de l'article 6.4 sont facultatives. Article 6 - PROPRIETE INTELLECTUELLE 6.1 SUR LE LOGICIEL INITIAL Le Titulaire est dtenteur des droits patrimoniaux sur le Logiciel Initial. Toute utilisation du Logiciel Initial est soumise au respect des conditions dans lesquelles le Titulaire a choisi de diffuser son oeuvre et nul autre n'a la facult de modifier les conditions de diffusion de ce Logiciel Initial. Le Titulaire s'engage ce que le Logiciel Initial reste au moins rgi par le Contrat et ce, pour la dure vise l'article 4.2. 6.2 SUR LES CONTRIBUTIONS INTEGREES Le Licenci qui a dvelopp une Contribution Intgre est titulaire sur celle-ci des droits de proprit intellectuelle dans les conditions dfinies par la lgislation applicable. 6.3 SUR LES MODULES LIES Le Licenci qui a dvelopp un Module Li est titulaire sur celui-ci des droits de proprit intellectuelle dans les conditions dfinies par la lgislation applicable et reste libre du choix du contrat rgissant sa diffusion dans les conditions dfinies l'article 5.3.3. 6.4 MENTIONS DES DROITS Le Licenci s'engage expressment: 1. ne pas supprimer ou modifier de quelque manire que ce soit les mentions de proprit intellectuelle apposes sur le Logiciel; 2. reproduire l'identique lesdites mentions de proprit intellectuelle sur les copies du Logiciel modifi ou non; 3. faire en sorte que l'utilisation du Logiciel, ses mentions de proprit intellectuelle et le fait qu'il est rgi par le Contrat soient indiqus dans un texte facilement accessible notamment depuis l'interface de tout Logiciel Driv. Le Licenci s'engage ne pas porter atteinte, directement ou indirectement, aux droits de proprit intellectuelle du Titulaire et/ou des Contributeurs sur le Logiciel et prendre, le cas chant, l'gard de son personnel toutes les mesures ncessaires pour assurer le respect des dits droits de proprit intellectuelle du Titulaire et/ou des Contributeurs. Article 7 - SERVICES ASSOCIES 7.1 Le Contrat n'oblige en aucun cas le Concdant la ralisation de prestations d'assistance technique ou de maintenance du Logiciel. Cependant le Concdant reste libre de proposer ce type de services. Les termes et conditions d'une telle assistance technique et/ou d'une telle maintenance seront alors dtermins dans un acte spar. Ces actes de maintenance et/ou assistance technique n'engageront que la seule responsabilit du Concdant qui les propose. 7.2 De mme, tout Concdant est libre de proposer, sous sa seule responsabilit, ses licencis une garantie, qui n'engagera que lui, lors de la redistribution du Logiciel et/ou du Logiciel Modifi et ce, dans les conditions qu'il souhaite. Cette garantie et les modalits financires de son application feront l'objet d'un acte spar entre le Concdant et le Licenci. Article 8 - RESPONSABILITE 8.1 Sous rserve des dispositions de l'article 8.2, le Licenci a la facult, sous rserve de prouver la faute du Concdant concern, de solliciter la rparation du prjudice direct qu'il subirait du fait du Logiciel et dont il apportera la preuve. 8.2 La responsabilit du Concdant est limite aux engagements pris en application du Contrat et ne saurait tre engage en raison notamment: (i) des dommages dus l'inexcution, totale ou partielle, de ses obligations par le Licenci, (ii) des dommages directs ou indirects dcoulant de l'utilisation ou des performances du Logiciel subis par le Licenci et (iii) plus gnralement d'un quelconque dommage indirect. En particulier, les Parties conviennent expressment que tout prjudice financier ou commercial (par exemple perte de donnes, perte de bnfices, perte d'exploitation, perte de clientle ou de commandes, manque gagner, trouble commercial quelconque) ou toute action dirige contre le Licenci par un tiers, constitue un dommage indirect et n'ouvre pas droit rparation par le Concdant. Article 9 - GARANTIE 9.1 Le Licenci reconnat que l'tat actuel des connaissances scientifiques et techniques au moment de la mise en circulation du Logiciel ne permet pas d'en tester et d'en vrifier toutes les utilisations ni de dtecter l'existence d'ventuels dfauts. L'attention du Licenci a t attire sur ce point sur les risques associs au chargement, l'utilisation, la modification et/ou au dveloppement et la reproduction du Logiciel qui sont rservs des utilisateurs avertis. Il relve de la responsabilit du Licenci de contrler, par tous moyens, l'adquation du produit ses besoins, son bon fonctionnement et de s'assurer qu'il ne causera pas de dommages aux personnes et aux biens. 9.2 Le Concdant dclare de bonne foi tre en droit de concder l'ensemble des droits attachs au Logiciel (comprenant notamment les droits viss l'article 5). 9.3 Le Licenci reconnat que le Logiciel est fourni "en l'tat" par le Concdant sans autre garantie, expresse ou tacite, que celle prvue l'article 9.2 et notamment sans aucune garantie sur sa valeur commerciale, son caractre scuris, innovant ou pertinent. En particulier, le Concdant ne garantit pas que le Logiciel est exempt d'erreur, qu'il fonctionnera sans interruption, qu'il sera compatible avec l'quipement du Licenci et sa configuration logicielle ni qu'il remplira les besoins du Licenci. 9.4 Le Concdant ne garantit pas, de manire expresse ou tacite, que le Logiciel ne porte pas atteinte un quelconque droit de proprit intellectuelle d'un tiers portant sur un brevet, un logiciel ou sur tout autre droit de proprit. Ainsi, le Concdant exclut toute garantie au profit du Licenci contre les actions en contrefaon qui pourraient tre diligentes au titre de l'utilisation, de la modification, et de la redistribution du Logiciel. Nanmoins, si de telles actions sont exerces contre le Licenci, le Concdant lui apportera son aide technique et juridique pour sa dfense. Cette aide technique et juridique est dtermine au cas par cas entre le Concdant concern et le Licenci dans le cadre d'un protocole d'accord. Le Concdant dgage toute responsabilit quant l'utilisation de la dnomination du Logiciel par le Licenci. Aucune garantie n'est apporte quant l'existence de droits antrieurs sur le nom du Logiciel et sur l'existence d'une marque. Article 10 - RESILIATION 10.1 En cas de manquement par le Licenci aux obligations mises sa charge par le Contrat, le Concdant pourra rsilier de plein droit le Contrat trente (30) jours aprs notification adresse au Licenci et reste sans effet. 10.2 Le Licenci dont le Contrat est rsili n'est plus autoris utiliser, modifier ou distribuer le Logiciel. Cependant, toutes les licences qu'il aura concdes antrieurement la rsiliation du Contrat resteront valides sous rserve qu'elles aient t effectues en conformit avec le Contrat. Article 11 - DISPOSITIONS DIVERSES 11.1 CAUSE EXTERIEURE Aucune des Parties ne sera responsable d'un retard ou d'une dfaillance d'excution du Contrat qui serait d un cas de force majeure, un cas fortuit ou une cause extrieure, telle que, notamment, le mauvais fonctionnement ou les interruptions du rseau lectrique ou de tlcommunication, la paralysie du rseau lie une attaque informatique, l'intervention des autorits gouvernementales, les catastrophes naturelles, les dgts des eaux, les tremblements de terre, le feu, les explosions, les grves et les conflits sociaux, l'tat de guerre... 11.2 Le fait, par l'une ou l'autre des Parties, d'omettre en une ou plusieurs occasions de se prvaloir d'une ou plusieurs dispositions du Contrat, ne pourra en aucun cas impliquer renonciation par la Partie intresse s'en prvaloir ultrieurement. 11.3 Le Contrat annule et remplace toute convention antrieure, crite ou orale, entre les Parties sur le mme objet et constitue l'accord entier entre les Parties sur cet objet. Aucune addition ou modification aux termes du Contrat n'aura d'effet l'gard des Parties moins d'tre faite par crit et signe par leurs reprsentants dment habilits. 11.4 Dans l'hypothse o une ou plusieurs des dispositions du Contrat s'avrerait contraire une loi ou un texte applicable, existants ou futurs, cette loi ou ce texte prvaudrait, et les Parties feraient les amendements ncessaires pour se conformer cette loi ou ce texte. Toutes les autres dispositions resteront en vigueur. De mme, la nullit, pour quelque raison que ce soit, d'une des dispositions du Contrat ne saurait entraner la nullit de l'ensemble du Contrat. 11.5 LANGUE Le Contrat est rdig en langue franaise et en langue anglaise, ces deux versions faisant galement foi. Article 12 - NOUVELLES VERSIONS DU CONTRAT 12.1 Toute personne est autorise copier et distribuer des copies de ce Contrat. 12.2 Afin d'en prserver la cohrence, le texte du Contrat est protg et ne peut tre modifi que par les auteurs de la licence, lesquels se rservent le droit de publier priodiquement des mises jour ou de nouvelles versions du Contrat, qui possderont chacune un numro distinct. Ces versions ultrieures seront susceptibles de prendre en compte de nouvelles problmatiques rencontres par les logiciels libres. 12.3 Tout Logiciel diffus sous une version donne du Contrat ne pourra faire l'objet d'une diffusion ultrieure que sous la mme version du Contrat ou une version postrieure. Article 13 - LOI APPLICABLE ET COMPETENCE TERRITORIALE 13.1 Le Contrat est rgi par la loi franaise. Les Parties conviennent de tenter de rgler l'amiable les diffrends ou litiges qui viendraient se produire par suite ou l'occasion du Contrat. 13.2 A dfaut d'accord amiable dans un dlai de deux (2) mois compter de leur survenance et sauf situation relevant d'une procdure d'urgence, les diffrends ou litiges seront ports par la Partie la plus diligente devant les Tribunaux comptents de Paris. Version 1.0 du 2006-09-05. MUMPS_5.8.1/doc/userguide_5.8.1.pdf0000664000175000017500000353516015042446422016443 0ustar amestoyamestoy%PDF-1.5 % 5 0 obj << /Type /ObjStm /N 100 /First 847 /Length 1957 /Filter /FlateDecode >> stream xZKo8WMqQc c;Q`M~jCiDRS54E3 EKBIA%0 DA&"$i-hx%ѲpE ^+4 U!aXChM&LBi`=RIOaR򰱄9,a;)9Q>MAlaF&)[h ,p e@ (D[ p%V p*%&`~T7 Qi;(tp@Q0nD%E`kŁ9(D)**f ::U80VD Ժ! qrud0@=A< c(dcܪ $dx5j %b2LH&; :2`p3VA\2N@X)ԺX`7-rHJ@ԎaRaÑVC,Q8؅p" %ŔPNNƵ w=081'"xASKrrNNޯ.Vyj='^ ] \RJq5k6Yf⚝k?]>OnM>eٺJ>Msx'N3ʿF]n{EkcS|3לG]yHbȿD7~x~&c5k?}zz!JD}xzF^f< նw˄ڴ}o5laKk|YjNPy{9 ?bh u\`hCu  s\`'C8.0f ``?f4`O`A`Dž}46+f8-2sߌb~7\b)GVQGdhox8R- יM<1Aa7洗<|{0s֢ya aMg8i.SOK^ع70\s  uXDqsK(>(0R}#0 -G9Tgט?uZbM>5dfhOG0hO.nlqbx$ע[/aċNgX11L;Vn]J~Þ7:r09M#c? "kz#2}l/WaE[{ʠn5­Q!m!)NΰZccy)7V8qFf݊;Cr<[IB+S`6hA^f9Ґ&T=CвCS[H_ᛆYbirJ8۱%~câeT?š~IևhҲ A;_kQ-"yx߫\B"1˚BwW;,ҼDa 8~l'37 q-gfTH]ۨ2b&JZ֙UeTVyO4~3SWwh%v;/"jRnxS?HɚH (CX7pz9"ٻHغIeď}n;Ӹ^F'-텐=qE"DS 4:y2=km6v. }#:\ +Mh=p6LImP۸2"1_ֺYF0pŊ_%FFOf<=^OdԱ\mo/kyCMQt2Ibg0^s?zւb,YɭJ$iktKW0Q_-)Eg̷>]u`؛:_^n endstream endobj 206 0 obj << /Type /ObjStm /N 100 /First 917 /Length 2138 /Filter /FlateDecode >> stream x[[oD~_1T"< Z PhpR_6ۤY5o\2cgm9߹Υ3=Ӹ δs+VpYy`(pLpaDJÄ O<A8 B1e 4KeA@8&L@ ΂wHax'R=xU xjM 4ބW{(S IQР )h^Z/\a9'+ " )h+@A A)& N'DԡATP!(ؔ70 Z$h = aaA(hRWj*p] ,2Ax m |P@ `[HÃUҚ*T ` ,CY0`\` 0$EV@@~`MMC nEice/);n?egl3_^?,g58?4\r.~.uGe\>)%R/4\~,WT9UW|V}m?q|\gdx),Ri|W.bF9>.YP[G dY6+EeE<}|AQ"O;?>N},'Σ m/i6TߨZ+iFE~x^6"r^'/MI_VPd3Zլ8> stream xڍVKs6WV*SHdou4gR[ 9& 㺿 .H=N{"ow}&&|o7%K$"aYIYWU%һo ^u )55^C)NGӡ]޼KdA ɓ3R'4\)Adф)HEX|pi;Dp'$kRť֏N["vO %5#INJ*DI&Vջq!S.ƒW̃"-``dkqU}^·$E=<̨X3Mw5x5.ކ8 J^a|5j,<O ITy5"*UϙhQ5O1*9e$Fmİ;*tzqk Bf2];heLo"8}n#V~ڑu&K>u>jl:( Ձ/l;0"j nK;`j}HJN*X4=1r,^F1h[̓2~# j*_ǐפ(Y6*z76z1E O.oN!<ZZ,qۙfi/$y1tsc2'HIEXCdTPWmkd.w+<)YB٪^CI tv8C)f`6dު`o9x\۠,'>y(<w _gAM /`,ΙEY.ͨ{L݋rwOWm?NuC~BqCZv]y5j]Hޞ4"c!4&B@u3U+Σ79i2e*F[,}$R6$硴XG=.1`C>~(lFxG.fϛ՗UM`RJLjNIJW>dwИHyaSBe]}xJ8 2 Rc͒7( r@Yj5C_Ȃh1. G7ḵnabfç(ng_6F"NU`;0̫V1`N.u񇛛~.[g0mŒӖ{oC ʧduE *uRjM endstream endobj 584 0 obj << /Length 1935 /Filter /FlateDecode >> stream x\Kw8Wxi/@12k/ Ft(P;'w?ynz706N {i"Y"?ÿa01=_\V Ѓ \ ,l"x`aP,b~:^$O}QuG=Gv!Yt vH<5߹L%?OYdLDoo0 pc˓.HٰdыW7+RÂbSU=$.焧~N@t%w<[E6mǽP!}&4 ahNxe3t6$1s||;;yreDxb&`12"#U\v\'"Ha Jhy "5f]bΗi%C`2riv@f`]V,rԹ]qpuˍx]qWx΍7n}&ܑ+nv̍{܄]qC:7#z}s;u΍f{?q&MhȜ"Q*c&fҷbx{ F+E_uG=or4Bc855VX"]D.xu6+#>j) endstream endobj 407 0 obj << /Type /ObjStm /N 100 /First 906 /Length 2585 /Filter /FlateDecode >> stream x[YoH~ׯ!>g2 qL'ؒWs߯O&vvYUeiA &Ap47p3qLK|u2i0KH @<( "V R#-1P4PLJb-AδvL3i$PBm4x , Sc`%SxULI`bL[ǔq 4Bve!vaʑ8caBA"C6@iZGK gII۞ A P!xF@pܶf{Β$0!$"2+c#9U@g$2ZH@JBS:IdN]6Пqt24 ܇aWr]4XW)~$]T,*ֽ-+&͚pHo[ne+hɫx-|.UtyCt۷V>_h^pUJc{\P71Jyf+|3y]Q[#Ԡ{y7]oϮω.{=>>z]QI溑!&YTlA :ROFvTKǵ[ܦgI+y,.whGmy:k>K5j1i=J5oO֒Gy2_ 6M4j'`t-G{viSߣH8OM /vyФ;i;oGmQr>.!P3UiQp дQqt,kZ9նL[Y5Mq\T=h09XqDōCe}mş2/#<9Kf!qamI=r_U/iguF 'I4-EK!rOM/ ) ?[Ή,`bWb2#ov(C套rt#jVH<2ݺ'ޕ9Y²?˟7ŦSL}c4&A4W,iUgvXȟ'7nw<]_}.6z1 Tءr^[ k\hxPb^7g7E3]Y1y7׳|W;Eg0#=$f_O4&~?qrzqV@w3-lr&mru' px׫؛ػB?t#=HOGz:ӑLg"=HDz&3Lg#=HFz6ҳlg#=HEz.s\"=9߳FaNiyw:U83ɭ˞΀UƫEU(y bP.s\ȸc9|j"3|PuHނI3 anLɤG+[P0XL@@ V19zG"Zc`.y*,&`03g3pQa6SRc`&SX cq`1AXFy1b  QnK–8p]X$b5Da3b ɏ^&|uƲ\ʸr " 8]I*qӨԹ,-=Y ƍ2ALVCQHB6̃2PLKcWѫ1ΫP{@gގz0~$)^/5HR k3 JL 7Jan0 0J AMWJ0 0 N-y Zc #QQ܏zaʔM1ؐ删7F:D(ɨ̺`#DwD4F>iIQQJo0ld*5J endstream endobj 641 0 obj << /Length 2707 /Filter /FlateDecode >> stream x\[sH~ϯУTu~IULʩx=;5D1*@ԍrbG΃K!w\|'}?6)̎f'/<Ӊ뗫 `F&\2\]OAg3̦U,*ɳ38}_̐柊hiwgU\Dx߫7MLcbݔ#Խ#()w?;/ddWi7s!}69€)/X⏋5+N9ͻ AT I`6gB{_h!Cb05XEhOWQ}ddZvgIDiOmOgs:ˢkдt{~!f-/悓RK_]22BNHciz}B(]< QuH@dWnž2a8m!.my.T1rBvE EjK|Z}RE҄u:mA.9؅eKM\Jˏq{YЉL耎@*]**4ӤtG3Y:]\h{!}bBb`\.:VʲqUEk(:Xf0+Zrr91ڑ55-Uw lG@q1$Q-˛˨ڽ"<V$Ә׫``c2ee/?J_1V95Ke7-tͮC:JxgF&uNm~=8ؚ1wTZ%)5vM:?xH|[w=OqV(4h HX`5h?AHǡ#zay9;AڤmId\TuA5. UPkX80)aB,ƫ"_e!~>~\,UbۀO\"v\'ѧF:v ^jFpЙ>ݥK!46JDI"t/W9Ĭ%AV{N{4֩fȗ]d1gm!҇47O+wGt%]ۓS*Ai%NؾU 뿣J/5W٘k^Vs/p&U\hOq;Iv:A<(WbKNGڋm\MČl #jy,FPXn]4 w _fh٪tx!YI#`>+3ն֌@Kt%&<&|8-Ivmb]ny?[exBGf03Lؒ:usX߳z4?H`ѣqtYc|^eC}kNX]w l?_XL|`'5#,j%)Qlx)8 "hPnlB~B"Ȗ1s[̲J'b[Ef mWEfՁ25~MѴG<26Pz5'-k^q]CqSuq`;;1k*D50p%t[o7ݖ:m:T ,.Og<~u\fhT-՟ * qV6It/ H*8Ϧ?CeFF)&yl)I8:d#9P(IRc1`8ML{6Фx b*@)Ba :2:B}J M-gڦWbF&Edl߼3 Q`u0ۆ禊lzmK#3Pvsf]%:P5ѺV^w&|Bm5:)ǀ`m<ǒihm2t /I'Zƭ*LEo 0KXDt &FAҟ=>z  `,Gp`]ɻ߫J{3 HZ}]?u$٦/Iuk?)"~ȳk* 7_| ԼԾ&:n9ưlo eqFcmx Yaxy5GGanՍԹB8d@I#0@=4 44lnGk0!=QBR8LlBevNɕߕ/-C1H+'m#Ҟj[ -# @= /ɡ{Bm舱~~Sٰ;zk=4p6|aHj}m4өɜYж1e7G5 B6 YyP$+(M;v*4_uVD^#`3yjEvv:uÀuZWгigUJ ?|+^`l|w/_~[Iߵ{O=[Du|Yv 0d_*P#N=-~ yjC:'|\EN2*>s;P])80o#e_k Nә- pmǺ_L endstream endobj 682 0 obj << /Length 1548 /Filter /FlateDecode >> stream xZ]S8}ϯ$3Чe=Rv҅t(ԳHm{e&HZ`[}sνW =?ex;x= ܛ="bTx~ aě̼C(F|4*Lz4ƝzD눈9L^Yugnt/n;K8ߧɻfDZbFcAځ5nq\, `y3vp5&)V@O _9 qHHϗ1Ii< {3Tݔ]c"_I]! 0wo"py|FƗd|w楗-!c(;^,NMR2L+~ji^^zL:wI3gc*Ki˪ת[S'u=Hsrv$>'=Dɩz,GBZ&:@zZT3"@J2݇2p[/ I^-M2['n,Wag==$^DJA/F ,,DM7ym7Ef;[LG \x) 1| aal:DEu @5I`Xf%M!4q2'E6 ҨQ 6* Y=.xkX]XGsjP8!BwSV_LA#o;!/} 2UmMqcL҅\ ^*O EdEd%`'|DDx5n_0CK$c8(E,K?J endstream endobj 590 0 obj << /Type /ObjStm /N 100 /First 921 /Length 2819 /Filter /FlateDecode >> stream x[ێ}ca]xDN,?$cWXsc[NCЊ͞f4:EVB .!)J QZ)м̡cDk;(rѶyAP<izP ?_$hBjqUKT)3<-etsvsb(jE ։;-PR f$ ^?Yp6/Ƀy۳yAˬ x9"~(bm!F:/g|Xؒ}Ie'@P3/ RaiRh ՠCE5ԓ0W5e) Tٴ76`:^mLqM/ Pc_SF@W9S7i+ VR8{Y6\)4~E0E"./ĆjmC8Q6 Q/`pt\bK0c/ 3YGcRSC:Ó/(l"}^zE8oW}@g,?|{66/no7AƍJx "1+`x \\n_܆ Η:x=/o ?Ëon}x{gh _nWt7/n .}^IJTޙT~Y,m,,,,OOY2ϲ̲βM\ߧ\reʕ)W\re)W\re)O.cϘ\5j:Ύ5ָq1H 3՘3`3tcfoonyy l`5x;1 ]kYcpq(4Kpl䁡iDŽ!#VTs[;;V:":Ͱ:5X&y8l;3\0н" «^G1lLʆL̇ذڗlV֘27 ZKym92}$N岶y)7[͸ ^ <.xj92 j eVqv!A, K> 4E>6؟ X7{GO JjylSAqG(}%ް  sNY `6nFbTK,׼eAF/5q4J,ٰgB91" } ) ' 8sws#-8Nb#4.~^[{TVŨU@'aOhBMX\UeцA+O ӲlBK!R0tD-om̭M]_k9 :/A Qޗ У3uH x\S꧓!~Da 02*GB"ď`6DƤ) bmI7/ tVQّkPbFk 7? L?0iX6̔Lݴ6wº=9U6dXӝ3w/-SCQ3zl#@cKznPp+@%}bIlGn1l)C'Ql8r8VqwњSp*I0:'4[2 99͖ؒ;7o͸o¬rˆ7Ǟ99OgZ3g?M ˇ3.O ĤI'ױl:`O[8vql9G=q;EG"; 3:19}-`q :#=StCeKڬ8Q(:_̿k endstream endobj 717 0 obj << /Length 3615 /Filter /FlateDecode >> stream xZݓ۶_Gi! 3L}>$y$1E*$.I4"%X,vhq?ww}WLX, .4Z.b|q[5hl7jw޶yU~'L 1G)>x2> Q!ElbiW\/mH?a+CUI )SFl)W5=4r^cڣ{-]V{,fvp~f iK )jKIԑĐ1HbP 3ޓ}f%͌53i'o-3&zhf6Ip$^,MܜǬDzYIKC6w.{[s&S@7x$Y1/Q$ʼ0pryoK[acp%z7+-ϭQ#uf.Pq]pQwJTأ-ۆV'ݶP%!Ǜd 2+tvϣkS]eyx<Ucv[I+#۶?*Ԋ'` JʔHF5V8~N;{qNC0g wJƊ"r:(nf1xJmHq_Qv>8&(QVޟ gGR_ |͉'n1I:qgӝOU_ ۽'rv簛w-`-{^apgz?+K$v1O?9/:!1CԳ:$DCϟRzDbQm?c >lŗutt`4o4DUiXqt,؈7F?a{rߟkS^Jj xskE 1IBT ?7Ե%j1Hj[w^yƮףe7 /+?IV $1=jkd/jd1 :Tj=«.2ma=h]b8u1n} i>S"Эhhjr5qw$LƝ;blE8@ICɹB}~V&& <=f v3`)TlK(A66=ԅՑrCi(p!۴9`K{q ;QWه4Y;Ku 1m 6ζ3XsƓtrMtqװB1)ng˪w1\t tѠkt 5c)@8bn7\lL^mǹ=ll`- 7&diK 5~hA4HST`լչ)W1SN<φO(8cr: w]L?=s._[ 3WE*!Nn<RRu8/۪<"wz\i?GINޑ}n `ԣ,St͇>ggkzkgЀf/ 5T*5=[eCIFeA,pz-^;zt>2/U_R&,EpiWfп]Z*ӹ8COD rYPքF\*Dr#0 Ю (L$VO"F@m3|MMN$\F%fk_ &YpHV6˻@Wu?5q=iU? j\[J&S> 9E1ע=m5/M*٭N/0&MB8pӳ"2[ɾv @ȌePڱyQMtE+Tz'iڼ=?@M8u`p:/p y4 &NN=b1EML~/u6o/="]j]68;+H|ث ^R1=j޹$`T5\0D ??!Gӎ}s)ngpws[;'zI"[Wp1z\{'Ȅae.DMTOn2蚎 ?F ={v<zg_2'_/B<p1QNL8(^m]aZט_ d],Z[׎oGէEj F Q2ÿCUqVx%X\+j?p_Ubt6.z =o)BQ+u|o,GZ?qU$fg|> 1x V!?,R3>X;) p=࿫LR3d3tC~%)!7W %yn'e < CUJejzZD"z+Rl;P8jVIAp~]ex|n+::Y˰S8Z _l^?!iTTyRhP|._{:ReFa^<-p:Wj\ꉞC Uv])E,WeK֥SZF{E\GëA" K"4m3M=+'鯉=E{kC5UM]>jz&|[RH ErT oUcNh>/# 5Y L/6&H"?W쬌׸j;K#_8˻w_vtq|4Oٽg2rT6)`z?Β}KA;F3_0Agzw > stream xڭYYs~_1* HvױʫZT~ ,^!ȕ_ntCP{(y"F'am~xݫ|͓$o v8$Y+78~^$towlkhO7j~@Ab?&7p9>`҇u=r?Q0mo{Rkq Us )iC'}c5KQw cy7Zmx+Nm#1<ʈxA\jrRޥXKWc Y"͸}:7Wg)9x.7Hd_8qz_S4g=GGYGF8Ou-f$łY,AUp5/В5f`8%z8ʝG&w2b;tcEǾm<ӁEqGenuqXI\W7 hcyF+ c S eOو}%iܢ4غ+ rxF6sr@USPK6qreE*\Uu,VoFm ncW58\2m֡U:b8kYgW<'ُ5|ba« ?E;;ph[/s`*U ;d3vU!q%<"{# #a69 zJ "XJ,MϛZBZ#$!-|;woe"ZO# I,IL 5q`0&)lJ$aеZZ=bTy!WQCUs@+XK`ߎîm?02O/""^A8.RSe$" $4HcO&-ŜHZG2͔{&Ma+.K7a8H(0p}8@kf%w"BfQMZ9lOYF=9qu⯺ˬ:iDlGcxjM7 )DoU)ԋɤp)j_ТQvH_*B8zOz}os)yQ3zL^gmqI:v{hd2AcxSB@y<-o, *=lGb'5?ѯ1,2:aC0u8Yk ,lۮ ]NBbqf_dw-4^f eӁzAN #^xG7DQHl%.Y.cIpgN5/I#؅g͖x*ܐF~ ~cwIR Jb7|$^òݫS endstream endobj 772 0 obj << /Length 2683 /Filter /FlateDecode >> stream xڭY[s۶~ϯۑΉYoL&=>cמĝL'x 0E_v)RJ*}"pa'?o7?$(OV$^( =]6<,gg FTQUZ<>Jy]Q-R_S3eUlE*W3 RuJ+^U73n6_;YUښZQ\V79c74Li9m'|*X8%QG¯M{<8#ۏv><'㭍f)H*VhQH֚Ffp+bKi)d< i2*v5>'5Pr*9,``nLڰNV3-&Z"*)s F9RUtPY$t>d[&d7K 'eՠ c]Qoph{~dcFZ(ܕ#@ R[P&A+]TCsX, NX`MFv ~*0AYn'0 ')?_V;VE SiH;nx~Z;YK ֯o/)tњ'(ͅȫC=\Q~ݪMZ.3Vpˌ )pF4eh" pNⷻ+ϪΖȟkUZҚoXqJg`>7po-vI,My0~v"_֣eЃv㻹>/=*׀3sM6-Ђ-ĖeQi U rhg<9(9$l\A 6'`ж(]g=oi|9h0 y9^sgZPr6RCpm\uXpmas U8]2%H]ޖC,Njn.zr6p՝n3Ng'ѻRt) Ij 8W4C={$yϝ_׎,Uݟuc}mFY Uokdb&؄XY76Dlfb֍콱WFk_-dRwe=<(dGEg|l1hzS ًA|pyջk; ֙J C+o|R UQU9J~G㭄Vt;MpᝡcÖ{mE!Aj`ѓw/>m#q?D5]oٗ>У(cb6nmްѽ9\˥B/Hgk}s pw"vndGo{yl%ЅZn(s7Wp5jrFY$Nw#7 Xz8DͱܬX7.+hQhҢ<&o\#Q*&/>6@6@S8j14 4$MSm?n))p4Ö0 |NܡV():M P-ecr&7%>` ˜@0}ӲG-,"]"01O=ӷW+ԠK3; an.o`UKyI魽G^F`8{!b޼9}cJ=I1s/ ;;Qƙsg2 fVc3co{K.al}a 8^0QMxc4П',ҹlds. zβ7kAρ$n8o^ x{m2>8׽+ć2ƦrՒAu?y|TʭX\l)m `JBQ8b!8O#/Jǝ 1oP8vt[ &fRڵbʶ䢁rlNQB}swGA|;>>k(,*8i;r}hGeMc,kd)h#sE$3 .wwoDt endstream endobj 805 0 obj << /Length 3545 /Filter /FlateDecode >> stream xڵv6#^!n^c(ϲ<2>$9/lŊS5e R*ԎW+Wm\}V$fED Wa0.:[ }mfyy{g]CIerxYH hj|ѓ[*fI5O:W!ɮ/ &|L[]:-cwy4KtICM➾}umZ7M^S|ZD~䵈cO3 |CBx)-A.VpHl*불7~#޸k HCipy3U:smЬ6hcmDDj DDKkM@\]A 4jjQxa6/wyQ}{Bo=En1=KO @鍮-kpz_p< =ݴ>mrCH=i#9 l%hJ‰}]cހi|ꚾ`ϡ`TܱOaOq[y۳eVX[we5$ZeDMnDݜqO[l}A:eڑ=WImHXma9.FgMHd;{!Q1 ɷxbxu] Zx2E{D D@K[41D]s*,)2`لs  e/@* q-]4 UVZXKqC<EiaeC+Xn-B&iid A`Kd4؄![tĚ6`g;te2ryӦyI (}-unw4ZvP O!3DqPh!E.4 (Wn_;G 1F!N糐>x8yl #-ЦXs]ݬ$T~ /fڟ[11k l{,0_|?zdY҂< B |M=3Q ڡ" -cl |*1|]a|=2;4˪5 &T0|8+R)sDId"!jblNNLc*\59Ef[K-k,0d FWݦɎrY(iAL7U{rp6h0xT6 -8`nTƒ0е ֽ(jZfF grRL9y*qbyl:]2DaHf FӸRL?'Ko?J pj`b/Ca5 e# WO Gn$B]ê!\CVD#v0gW;M@TLch&/vȡ H0/s[fW֖݂`)D%D7 ,҃ 񍡿/=B(-RPxps3os(fQ<cB(уHMALkF -+L|AN6@3 |6?0aFTfU0l Z! XIUց"X"H,PPN6w,-LXf /ӥYSWXb] QRHqY-zCw+B}i2'MPfIa= gG3:bI4/oJ&栊Dp &ޛZ+POZYVGA5*iBqToA/ƃ@ZMKJ`$X47hdmwz;uɢȸeƺtv =&@SƻZZ ሀG m)BÒy޴/$׾r$Pg))9d186-}.G-EI(fG1 |m YWSؗ#{D:Hx8,yKMnk6,ΘfAVjv揢Xor MUoKvNW㆓Qև`,oO?J=Z3$ ,au|\b &CMLōcI^R&k4@VEwsu&}d%@AG)}sF񹏎;:zƶ{IS. iAB I"kQ{G( LBH|ߌqYXp:OzfUp{x Lʏq~$T, `eӐuڌ(4T4gs_d$]0*T6_{9H "6O`|:YGkt(6y:U 0! _wnpnҿ:.- Ҟ#k!Hb,˸^*4, =uf~kbهSi.n8w&s˃./>MWg d χbjDpQ|*voh۷|΍?!.]:qH? ^NLO]goXR@~nB4@␩5v-sx@qvbjt6w@!fjc1t7!XG;ǀQUW{TPSdU ~1XfWuT?}t&^fn~P;3R To_0AIsWW L|wЏW\r'{1 $p}#1A LP+’ܠMR+3D҉=p[.s$ bIyd< 6'gq괈N.@ˋxJAcp8!&T^vfTpJΝ@}e\/\,6G,qCA`D njG5?eZ鷸u ~L1ώksYX!D,!|IXJ5 endstream endobj 854 0 obj << /Length 3888 /Filter /FlateDecode >> stream xڽ[۶B%$f8Σn'/L|$܉5E*$w %$;#b.n/~O;*jȊƑ.6l:+۬HbʹЈ# @Srtvxٳ~ =a+)5urOu?qs Bf#B hYQؚ=CUӋS=~MLԘ!57@sDI W5=yZK!HӰ giӲNaA9:${5z iJA`^iRթldqĹ!y~'8Ϗr"ɑ$,ϟ932@Bod FFF0o;/۪=9QQ|dDUUYj8}pH Uв[ۙ!^:!ѧv]>MGJ{UEs# мucY@D?^V֥I{.c#+A6d/X&EOE>0Rי4D-Q=+SG?߶?+N#.YXC П[/U^ƌVW f`&%Na15-.@*gR辢svlǘ~P }s 0 ?vڦ}ۆ~,1~Q'N7|h`S۷⊄#ê#*uRF/ݯyۧYie廗"n^^ 0"u9➱>&Ǽn:c|w]A} ;]9kaNn M `' Q,'.}r nS4a>mr!` yNӂg_<Bxˆbُ?Nja7Q,=jbJ`'8Fw,x|M nY%)5E9Nc3yE1@:.5!X1Wb,y KE@I(θ_dh.j&ݶfMK8A qhCB0?ɋ #yWt,B;'(1Pٖ^lkvk2*A LbMKQ;SBq7C+H:D=N>*('M0JuX ~LgkYuo N?B/DEqF9#5CV@s8Ztޏ7Iy4"KQjwbǐ ~F$38zdG.oaZO㙃d^|/1ܲAz҄-4hW'pV-$ޫ?:>:]c_7[7 ^nqvz&.8a>JGz?=oCE=)K{dwY2 Z/ &XSiaQb>NiG@z~廷U]W?IY\(6qD) &@ή V>}7h8~sovW$Wj?*7+/SRs*hժ\6@ǐ7߽ostr $ 'FyQ= )ltÔDE'@Q jsK" \ :\ηYAmaPo ^ad䚥Z K(>7aXȗrܥqiZ-1W/' WP"eD;OzW9ਯ3L5f*AoЋYt|&۶!=BCFYI2,i 9hԘ4[ｍ6&79QHR']Ꮝ$0r r21{٬`B&RR_Vo\Q1>S-?zhPsM#ڕB@\b~c)e2Tsd@URn.ۀ]vPO\FiMl#S.e(81::as!lh>fuv(Ӱ2!ak{·luV~RH(5ѣK(v&$|#.z4!_'(u v+vh*$ͼZ#.샿%Wby g썒!NvSC;e^5MbWiQ3*’XKLV`2$oK.!HgL . &ݚ/^y?_j92p0.Z U7&׃e긗 xX`q_XH!(N2O`5g;uo8 T wߚ HddE$m^ D_xPIiD%((9MMI"fPH{v9P\3d L"c`e"Ops N>2:Y/n!9x n]>Izՙ\"h6D hK'^yw2b%CT's*?.ꮹUVDSٞxAkL&c6bL}j^@*8hn?oiR)/XACwO,/}cigWh)3w$J 8^%-⬴a6ܮ]LlSUDžߜ,>Ui +weؿ@:YޭN U~!ֶ('^PEzb~vsWހ=]&gbiu`KHbW`jj,z_|Fzٜ6u6$&~[iX`S{Uv~ԪݤPr_P␗UK|E PQ7yٍ$}.G/?&Q1AO? )X[X_0 {$2RNAћUGRej_N*=m[TP,1aG;56Wn&#rX$!F74pݴX ߕnM a"&0cl'v3R$j@{g Pf I??IQstI1'Omin endstream endobj 684 0 obj << /Type /ObjStm /N 100 /First 902 /Length 2914 /Filter /FlateDecode >> stream x[moI_w?0J D`uw,B&A7F=5nI49i=q0 ČMlWٕ# S.B(-PY"(ZA:}۷GW4],f7ߎ hrvrokk8Sqs'fwݾnhj/gO ~`H:jq)wcz0$ ]ytn|}&e#ҍR: wr6bX|V剣/GjF㇋U!3B}a{l"f܌rqx0÷ٗ{{/f# =YNVΜ#7.Ζ_?=O.`Qۋƒ^BxEbbj]s]-:PW+UZJTz+kzk+Օ*uuMuպVzaMj7n5 #(H:×Hxxu?&I\B ,e N`ԐH ;?M!A>!Q,lR!]D/oɔ "A`F"yG|5T (>0pUiv@8@L)oD:??JC$]8abӧ[e ApwAKI}")^M~,G%"2Y-g܋e8BQI~t$4?kZ0|\ "*g_r>.4@@͎O?͖0DZe~JIҀh0-O'8$h2KC$C@rhHpz|4A$-*fWVQYz+qWrPm$N!ɣȵ&N+%Ix"'tCh‰ \?#0ǎd5}bA7l.t%k<'8] xo `Nn)Hw|k"Ivv ʕF5K5  ۈzwo&l<'ٜ`KeBE`Df{fo܌>vcNe9}S_ܯiCf\ҐԪl5d7D{ѯo2770 5H*?I&N,ı R(6QBmlu_beؤJ YQزѷ}O&ٿM %f'dk wGGVb-9k5J#3(6mADNSXIц *Wdr׏Hl̄ cԈK'̩HI"F>6KpC@\nCgPBe )x%`誉jf'PA-iaT6x݈g{^پ޵ڻV{jZ'rZ'r&ukkM:sMNRRRRRRRRRRRm:lMa_ }/{_$kCLt,%coEOayɮ`E 8Kl -6zYhA$IW|9 䑪yR'*9S[up226hJpg-H»%}(({poY>=؅iLv7OaLcvj ISM!|H?$؃\?p%k60a0В0RH(Yƈd)|sv`E ;?yܔ^XT<**?1P1DFR<Ȇ`U&uNBƲM{{ZTd7XJ{ ta<^}e $ >Bdɕ\@nҗG8/Q%$">_d||qrD-l} Zc%;Qv ֊Q&۰d."#vKWU\9J\Pժ[|o/8Zsz3㜹!׵YzJ]c]S]^dJ+=J+=ғJO*=ғJO*=Im\qw"nHsrR͇_Ucvtb׌`$6vk_|bu۱#>ax і@Q+ S?CJjnDw962?_[ endstream endobj 898 0 obj << /Length 3714 /Filter /FlateDecode >> stream xڥrF=_GD<$ڵT>$#e\|vO EALPnO_ ~?&& $nnT$C}ugp7H$Xn$B ̀[?jq40x7XKފ:ĭ#5qq2]eo)M(/)Hfnjɡ뉱l[6Cѽ'íAQN`AunlTCa7uĩ.0r&qP--,-C)PLnTa]ã N`(%(AV|txJlj:3Ǧs`&D,wQ:t,z}>$Pw,T"e/X)WuxIF'rIʴ΂d;Ut4\ . \446¦=RJo87sY@ؖa0݄w.VVEWnT,h160!',wQ^wC*Bn Immchu{z*^l`#hؙ(28.6x 8t\gLRq/n BKFKyAܟ>CuǐYUFg[gwζ,诎 5,:+:<x0*4K*"+r3nB J-(*\{h<=ޯE;w$GO~`)!r}K[j [ܑ1%4$̳S}(ԙw "xuGm;OSɆ GJr~1%:[3}|, `rfyB |-FD%ʨn|u*)yn[<ҩ@!i 5ٱ#%u˨NSjIk1-jV0V'YAաCR"DR;f&?vuבqϹ.qkq^ӼNa(P:!;CG%y9wa֕2h|~5GObh7AXԉaJalǦ"a XT?6bYbj.y@/p`f{,j8aBE H% {3΢lpku<[H Jd8paप~@u f̥V5KN /i`4W6pA}Gx*W2j (d00R|6IO$yu-n/:[*caOtg-d~w!KM4b|+*-/+8hG7jx JqRRl,g, z6.YwѢƠqGr.jɒPεٙg PP ϜeCDRrxAg`c/IC]l-{;j"_1_3OCȻlGj{f*tW:Tc -"hޚ<0!bt TNH[y|#M5$%Er:cWNd$Y=9E+X|}(Jq\KPz4:s +Wwt(i?a?^D.^|Oowo<)> #/K(r/m`X#u q;C.reW-YQLP :EIEj!Ww&ԭJV<4,"x RSXs"Wg.+q%:r~T9J\Y['V3v^2W<)n6|Q((ޙ|cl'"HͶpA|||Iq2VTBAAt\23 3xhFhwln;3{n >k!O~¬ ou n?mT0V WEh b#{칖u~ʳF!{Gщ)͞sA$r..]4$ w` F̍ W!O?؟%}޶w6}QۦρFDʻ-!xIVi0Bqi%ˍDb8yqH y4YJhEw,o@(uw?*qP>I!ޮl۳Y )(91N41_ř endstream endobj 922 0 obj << /Length 3751 /Filter /FlateDecode >> stream xڭv6=_G&$Onng{yDF"Uj4!} f`` E,6Ff\,|f"͸t!॰Rĸ]{T $o4͌Xςϫ2=F0 Д@3əi%AdH;I襓&_o"-;AZ"ͼl|GdC741BGpAEyiUyXO82(2=+#3WXvqN z''$䪆Pwh]7hȳY4Tbh(ݫ_poIwm!'7Nvª3˫E,׋X HMIJ+L5櫊NaBf%=-[O&>ؒB( Utho/^{||zI+p-rrr":reu<:xEgyo{(ܚ-4#-Zs0%gKKŢ.!yݧ7 ZAh@Q5|h چ!3jQ%P-.| {r;8j5n$B_N8L&{>28dܴ|!0=?p!nijOұ' fˡ. C}HX-܁'' (S綾%RzY;F5ꄯ\|G5ZZw/֛uT ́v qC`W9~CŦU3|: $kG[<ÄB8e #5BgqED2(10U|wع&BUM5 G tE kζE[⒁#!K{BPC*S7]6E{S5 8s*䩦1uZ*%u Rp#FĿTgbϒ,bIQUȆό=bWڶ*#[2_Kz A|k_x ;qu]2`/ ZV(]j`ˏA8Ǜ(8G(&ྰFM8q,#M"-AV dui ecAkrw"_' P@%ۺ<SJ~m$mSm0P" o4ePE<ј8g4*۲CO@m^4 GUVi$pApqێ S:yz}#ln(3$ KH  G0YB}>mJb2,rKlO}n‹ņ)!p Q9&֯/.KU$>'q뫛#(ExeToc1=+yjCea,r eMT7yaup!gf ,/xC5fMNJf_8Y.L"Th?8N.:Twn~Թrq;t`c̓6(\߉C3 X`H’"*p##غY6Ωx#'Ԍ>!K3dgMsb~SYmnBt:Z4Uuϻ : CZyXtO/$`G`4ޒ{pJ4bp` qti@G Hm!f#l ͡H*Pc]b l%]EҥUQk?Y(N`*wL)dcr7SyP٬{3c菅/m,&i21KٔDGŗ4TQcfjm+I]v#j$p䖉]`2 z3V`[/h{#2DÚ ٦@7ݑX rcR'\aOnP wGy<-ƗN(O4^ny#dCQ4jZ\t@-](盉]/!t[ pKˋ)01T=0є!;u4}9:=gD~k:<8̯ׄoRQ FqWMZ&!9 ~q4s7)F9:4CR}?}b`EmϨ~!swAh?+ Jw?:ҲpX9H.9#AcźYo\]z#_ ?s S ݺS-@mՉS9/-6ұ_U8Ćw@=.芖x@,=jn)5v{XCCq=᫧t|\uagdE.p:GV-t!2WD5;/ew&KB/J:%̏~˝ejM쿹x5{D-fuS_5\ 80uy cyatyw endstream endobj 953 0 obj << /Length 3389 /Filter /FlateDecode >> stream xڵKs  ŋ$I:ӤM&&MwrHr%T"w PE٢^,ž//e9S.B&L&j %OKɄdn%8˯? 'w+%˶;h~?J&| ,\徬_p0+1.Y_״n fˌ,(0p_˶lݑ ą_UpC["HU16VV߉ב9s6N>3Y y}p=袪O.msmh}ӤiŎP8:@JArsfI@K5b(T觤>%':_۠9B+fι`Mh\ fL=MYDSDDMΌI*p5y|kX^IZ ʫ? '!߇6x܏_Yb\$;@ ("c`${"8V"v43PͿ- AzSnMP\yZ3^y_mPM?j 3'%Nk8;0Ş :Wsl }o g.'כ>G6?/iE czɲ:Ecٿ+?m,dz;sZ<马[+}8^}d O@+(y(NWtۂ0J̋0RB~UwǍK)#\LNzSQw\FSZ1gpۀ1k5>϶>֖>Qe lCYwg/I+ǾdEعLjǡ>Y8PqhjSaynoHr+*WG\uz,(Quu( utSjt=mh4g_=o{jR6 tM 1{/x3>JDD6_3x? 0MED\>eXGy)Dj;YT\Wؤ oV4rvCUnR,6 --C(P/ʓHmvQ6wXļ8 RaTO3 j\xMhbC9@8߳<}j :dowy7L Dl?z'BGYJm[O&Je|R؀oE2~c$%jN?r֝데߈}lF_ꥋ a~R| _zg aK5;O"RyXzՂ?dDe-uJ]["qWE-@6&ʈݰell2_WaN7OѦ2z#SV|w`e VRVa0QU $7 .i8kyZb5`҈g7!l?4;O(z l+DN!ǥ#҉"dR]0B<~ñe.\_*̸^`S=F0x23h?FlRk Xf@/l*Vݨ;є KKWְ;[G0Ve{'v q‘5pPޡQ ;x50]7^IʈJW ,9Jׄ`CS t~_n8K8?+|Uhգ@ bVH"Vaѩc]uP\#>#u͙/Zԑ!9b}ⷯ7O7(ܳ/Gktdmh[ތ Gs`.e9JVaGk0%:t ZVq8.a}Tuw > stream x[ߏ~nvE A, 7p$hW=]@#-m.*F-SȥP栌CQC)`%P*)Zn艽 t){* OU!ȁZ!'!!fАs'%dpkȪmո$[Y蔉Xrଌ VlKW%pW'Fmٴ|,)q@I҂&/L \SYC3՟XKh4RPjx*C­(4R Zϲq5@P(J.ZkX [P f0R]AHCMB*v[XDQitgQ"@]O՝|?ڤwLj9bj M'Ǽ(-zH#z,7c/wEp|; )E^j)Γf}V5%׀B-D}86SF79itGyN` c11d&TKPGcQga]ME&o<14#ߴ?ym@Q^ۆ_γz]nC/א糷1#5>'7Q<]T7˳3|j]Q1j[虻˝|e[r/KeeuxnWg?z.ZgZ"I嬬  Ͱ<Rl.HTCr-1xA?D c $`ﰷ~z63̨]P" #3tE@j(p@"uCI`gHH=7Sg41F[4/"^b1w-o~рiFpe5b$1oE%Y*\$6m\5LaEɒf`)brTb-&@vY) w6aa-Qs- or57t)VS8z{n쭶b3P Ⱥ}̄ XTnEȂ8`'c`t#QIn_|=C=46}(M0â/èih9q3o )6OkLg!à`2&ΐr6S lz͂]7v%2{)Se3˥F5 ~``(v5V< wgçͿ0pv}W|o7jwA!gmJg[0ô8HoC|&Rɷ!vY8.y¨sܡOί !s;!ǽHGz?ޏ~lL"p. a̓=m!̵ac݅[Uzo3M +Փ9/x!%!A"v IeA4,Mƒ$.2߂\E Dg)Y+x)Y3'Aewԧ32օ%mabo0 t endstream endobj 987 0 obj << /Length 3747 /Filter /FlateDecode >> stream xڭZK6ϯe*!@ SNIe=8g E*$o{" @w_7.NjP]_|5 eX](:6v~* eVTtE]eeyˍ0h%),Hs]~yA(E- @ u(X%2_0]naI4ō4ޒe=Mgb7ۏT$(3%R~T[T̛U/$vyQ:eꚺ,-w<(Pa" PWyt2[.,d0R?4닿/=\:HB}ЋpΟa➆:QzƁIq(HW=dͿ~z/3U^Yc?Cd$S䜇GX0QF5~k-h 5Xno}sW3@ZAoH@+`vIle6{h^OMLe禺VYg ``aQ `ϻieێndlK_ٔD":8$O搈喖Y]JC%lgq")s{h8OΧn& ZǶ$xf<;6s(Ri$v @+n b3`^gt\%սXG)8aقM|7oʁ[)_{xmza1=64'S)q?``u(Zp)_l3JPъ~:UO&Ƕ_~?m["`AS s %W<}Eïg31r3/ȁ'85рpd/ cܞrqDh=g_.S9RedaWMx0u& J@#)إp\@A bSu8ʎ쳮)> CV74#0RAN{M;OX lȪXXHPW! 4s '(9,@8( yp9/N,~#L qK@a(Im/20N*e9hʙf 3PHI`7Uĉ3cNܹxɿD@b#W@_/_, dff4#5^j;|33%f锕̔6p׳RQ:frk(zFO%jUڀNOXLB |OsuPcn48(J XԊgb{[!-!AB3a-T}ͬOKĤNFmHjuJ_i iF3K#= .H)S3Vh#=E*'|14WR8?؟GX#u'σU#BUO/W[dG:nG211XF OF( u#bM@![j>x.?!r&#;Ffyd~PF[dVٱa`sw "yW*Fo;`#l'W[!@8 gP<2/寢jחIH̑dC1^Ǫ=;]-?N\!o}/=o02nT{ ZQ"PS(!;J75p&úrReSDa7F&؃`>ԙ7=nhOL>0GƐpggdqlF;'lH, Z='Gʩ! :raJE\8J̨%v5$'/i&|,Yy2Th#{ a|mTJ݅LU)P /KюqV;_y~m4gkk1,"~'%e8|Y4)~vatjYñ(rN#/c,2vHb9^cʟӅ\4Ҩ B/R{O2-AԖ$, ׌`Y(?uel|⯓ Uh90|DLEdJ`G)'f 75x\*cϾb({iG+s {/;H/T;8 A2 b.M t7 tA=-"cm^2i^yҮN{{fc:N#؞=e.dHfdD@AE - ыRR>*躊B^cg# ґh /}ߑ wyS姜?nzoW,[NWؑ$nFfB]R駶%Hh؜5$O'XWDORŒ <~A"4t)эf9Z<);4\Pͬu]MLJSSI<޴ endstream endobj 1003 0 obj << /Length 1201 /Filter /FlateDecode >> stream xڥWKs6 W(\zQ6;t:ַlؚå__l@|y xam*4C ⌉LJD.}kS.WQ~+xL_Xt7->~@r4O30q~yO<)sL1irs46㠇%ΚkӖS%q)ƶ?`Fx7CPIINXS"~\jq)Bݖ׶vϑeao y=B ׌_ng˕J̘Fiءn ]pc9#NStm?Xry9`> f: dp^E,7Xijb?UXYlЧBڦigȕ$S9D`  @<>VTq]O3ߵߥ[];tonކ S~}ӮF|>T< mcU@n'K!PY< ]w9Ld_?_\82}cUq[իo>q8@{k`jQU5%!bh^huiy)8ytJ0P5n` kSX90;Ǥ6H\?xnޠ{gQk8/Q3x-1_SҎ@ǡÀ8`(ȞF8~n=)M;q%#mն73O~/q0;:WŐ Lpgcq\ν<$pYem5L_{ [m`Gϗeɳ[ ƣ2SD6nƜZ}?AMCD'[BFH=sL#V$X9SG^gC=U endstream endobj 1024 0 obj << /Length 3306 /Filter /FlateDecode >> stream x˒_!ߤ !^$ćIv9rX@IJLR}4]oDf/ Y.7W:U ΙZ,o\h&\f\nv)\y$V"Y6]>+/muU}Z ,omV?]b6̤"Ebs$q۾lZd ~1ID]ʺwH"!XW0W~OOf%CC,w//wuYq$y[|@3 @fꫦV}UEKCח^T]SW"ǖcG@Dr&r0, -DD@ .L S{lIۦhT!O/[HW5Aɉ`l$#It0۶P֙asXpM[wcOE}jւsF{2?_] (Yq$)3`ë?%df2Go^stȴLya-Ҝh 4KAc~vuTjW,b{G@`ؾhwlۦhKZmS_:W# JLO01 1ޘ8pgZj2MqpL`8 +UUKW@r,|jYa|MY4 :*4+b|]r'Z=qzZh :MqdSp-jJGda6@r`Jwm]!jXrj8( ۲ =Px? Bt~ Rg|?ZUb JNÔ5&LRθ})ir8SAp=a$9r\V]wFͩ+8m-뭣/;L7H 1oaEĖ7TE|V6qNH*MAšD46<߾j'g.ʙ,J $|Rá%% vklQi,T yC:;a#Q GoTC3NW4]Wmw7#6>E"{ݩw 2-Y剏O7n_z3-RO!eѹAn3p|$2biz&W]9 KZ2`:~Y`{ 2`n!`$+'}"ufjvTT>or79g QihY-ޒ#_! WL/PX Γԕ}*¶07Ẃbvz2H5S /5=ƻ2XU1d1AUs0zP|"q^i $;TWKk2gyBiHXϻ@5y?cn IrU@9C0^X@c))"M=5wR>T\ } 삄!2 rDcdzHRŌAKʉ_Ñ{R*8S|؁g屧1q[+*lE <ʣ_ײmh@9JAU=[:-J@s=C5^s.id&hn3;{wJ%$+#NL0ONV⿙ws L+ At#U!pl|jc>o)3AʦL5}q0C]#d62.xilId3Jbg+mٖ1?x.8If455 fuxJ@/(U4]]¤X[^V89R. ka'6 9X<ՀU_B8f9!%^;dp\gA\)Gj$iŝa.*DeQcg &R|I&ɑ G2E} OoQq6I|[[AqK#Wc Hd< +\a!B@N;@bf`o ǡ(:8ͤP;skZG1H!M}?g - 1EݷNjEZzGq'\=Fsb *{( fZ-ހ; Y%DI:t> stream x]o8=j.DICYXVbJr쯿)Q6"#rf82]wWGYrcr&uRL2-fٗ?$'\OpLxg_U2Cy TI2%ꢪ֭4@Tlkn+Ib #撠M7EV? ڵo웶@^Hn8[8@ |PA1T$"z!Cz/*-G',!dw÷ 99v De !wv([[[(yxQ .JkBV屘;`%A .Y"TeWpps{$>&<VW*K<$`7 D=b//z^,v}dc.eO9(:os,.i.;rE[l'4cJD1yP93f_SHb&1'%>V,+ݗE=2twx2gN:mFmy] :lZ:}v^G*äI91 GAnؖuӕD`stS({mul,e[]X`z&S*ȯw^ M`[t( } > Z1|X}iLRf 1 @ciц&x$sQ`N8!}Wgp7mVon\vKTX`bZ)- IK#OGB *^  Y],++ZU]٬JZ˺ڀHF,1gJp|NSp{A%s{T80{n#@V%vu_Y mIZAS4[i<8(u9 A>7cS pٯ7mZ.ZMzWD}TUDPME C']4<1]V"yr{P3Aef=: Øz?Sw$r~CTHKyOqNc-15@(zLP+N%`  ؑB*0CrH5/9P;"~+ d?ȣp& P,~ԭC2Bk]tEYs.j=L: 3_ϲm{.)0u s)S*J :Gٮ~i#'=ʂNr)K[~A<,(#KMd5;}{%p fHMapaB E54ϋf<ӛY\ץwbj:e:wV\.!PDںmT:BdcVA=){ԀoM>K*C3da:q a'EӠM]ϳqp`k8eػ[PMcNO63Z /c|TH`IP9m~P>"9˹܏& T>WqcEx%˸w$m̕pV%<},QTXAy]h>4#e܊G5|bxR9oe[F<#U:P q[BR}G5êYHNUƺA1c!?PA?tA˫oHʄe=4egZ4ٌB>_Dza$M hHWC?+ߵ66ٞ~gmۂT1 'sSQ,:7"5W^]`Zw_KjGϡ#9' CA8zBS̤9E]Saۯw FĺS"NI'm,ڔ 5mJ`<#m&-IG2j/֮&'T4$@W̱Ok &bED GEӡlQjj6nMqK % *#{nݤIv!l0-9RgUgOwv[+Gb-'1 n/j=[>-mZ,s1377)-mv5:I⦕-ܳrlڒHiV]Q>p=`f!p6M6h6^͆Fg|0h A>[,yXjezO9QbhH\ 5+j Rio4_4F61_kQ4^]QiҌܥ/m7Kot"mg<,h+iIMR5(wqUFX>ϻY6)-}Ͼ g9!!otmlHj.PU>|~tӳcc\m_xI¯mc=:^,H~}LE[6ӴHZNцԦ  N^V endstream endobj 960 0 obj << /Type /ObjStm /N 100 /First 946 /Length 2718 /Filter /FlateDecode >> stream xڽZn7}c!‹`Hu@va~]y`5t+iؔ`Mź*vuUI.⪊@.'Bq7;etӌnpwK)/*nE_10Eb[-`;I\Ԁ;I]L&<8Fv)z5UGâH OTL80qL6&;(49C?9ڍ[\Y$B$'m11Z0@Jf .dKV?WWZ_6wo_X>}[g}}soDC5zVmOQ?'O[yqgO?~E$+(L OAPPW%ys9 l7 =ox6[q&T(R_=4>T7Xs x3 F>oeW|s[>ݜm.Vk9/Wz{%ejvX,owM {Gco9tȜЁr݁ۓc\uHϞ{{[^ޯx|w 6m\mOח-$[Xe5JAe^ qM5/Tcj_4\pa^8\ipzyX/zo27T@>3?nνvdhcFaP^H`P,pθF1Rk$ ]r^59Oy6_}`#bsp@1-xΊ}b{\H͞~begp8{sOR `BJ5yYp#C:$4N젻(D2HO$XB-EBAQZ,J%8Yw`Nr|̪xӏ_}~HdžI`@F͞B<#l&;,Z hU= ID셥Jș<pby6T6r>;["R\|"aD@R|ȧէZVIJ_؉]Q2gx[{~~qt!K l WH|덐4/ٸ9hq`2s(L%^A9WoeKnf s c( E/N]dwVl"@2deʐ !CQZc`!SFȬIdbTجm@h/Os2|]}ڜԺ ׆$Z53 󠄎ds )HpS$]-ɷ$GʘUْuF|FR`DJ2 S]%rƒ[xTG]ZŰz3<ؿ:*$iM4b{ijVk0|VӊǢE~A+@c :6c1P͓gx+Җ2\[&rs9;5LF1ϰ2rvF? &GC]Fl"%x 0-R{H98ï -)+Ee|;2yn5.=K_xyLE|75ޛ ^K9!<\L&v)HJFl#T-HLwy"Yۉ([KVakxlQ)! TCr{g: X8+aj#*Vh9#{geKQy[vvdt HJ2sZ-][p3G3Fy s=vX|tፍ2Dњ)V= 8-\  LVaA.׿ȟ֯ɟo&4r>|G>#)8KF(#S)e\Yƕe\Yƕu\YǕu\YǕu\YǕ3^ vzz*[}?p PGazMc2vܲ!dD\"$~ I%Z<kw)NI <ٲ2(# R9Qxt *O\f%"9fgES\8fWbGK#b"L!/' v =.2֣ΤԶUluGTbV#4|UR2psuh"վZuhQ\F endstream endobj 1077 0 obj << /Length 4073 /Filter /FlateDecode >> stream xZY6~ׯǪK?^۱aU"kyЭ31O$A HeMxݳP>IMIbnnnG7I*R7Ǜ_7,ܴ]͡=_)[ێEU?.E7T.:]_shͥ.]yW I8Gi:Ϸ<ڼ|zkl2 ,m~ =AxSa9/_~g6e^Ǫjf`BqjIT۝ͱ=\ꪔ_(jD ];vU\h֡ ¥rn:Y5r6[4ȼ/ \S](E 7e_wqLs 6,b431(3'nMYy4Uf;Zrv͝g3<؎zkVFA8t U7_mwIn~z7YijG=_IQ+ j BD"(5~?~w<ȿLL RKڕ5vu`"IgE `w@ YW KUYYWA-@ ,==,Y%V-,,Vz8]q?-DZs+ƾFչj v8 X{u,kNۋh؆pjemw =MnsVAj+-cRbgİ| +l7x.f Osg@'M`ĩl`wգ8 mW< @l)Ht&(JumjJw  I#ۡ'&9`L-] |:J oR@!tAiXXOdL6kg;4Hc.Nؿ!,]L.n[j"xM'dM:1RtBo< O$} kRN d˸5 )M[6Z!̤ODap9z k6Gu4?ɞ.4PY 4.м$-CdS5(躀1[NGvg۠sxmҹ펈M\:B n_EVUaw"::ϲum^gflKXDď#{R:xS;QkTÅCLq]Ѽ۵|c19{$^4Cq/Mȉu\@)_7< O&% 73̉qpFCjx&ᾊP俠 #h3,,9m =UFP2z !8c{n-q7RӠUܐcu`V8^0n`|77ܛks%l8 hٯx9PH-8Xf~5WL2:f 6UcmY6ɗ]bJ{ @3St*d䯠^(9w (`:dEZO#u@S]u'_aծ$0AG=Bk1GރZr8STeՠU +4ywP8rNˡX p޷5zdA (^( {ܕ5#QI7uY]fVH/I7yjejpแEPSxsM= D|5spń?-t:@]p>2D W>P"<~ S+/͝;yJ9ٕ]3_e<[b,@L@琀G/@b5!P{?G +Y|GՈ*>_ϥZO89x 3B !Q!UH#hdb26xW3 Mfz&6r 21nuW UNkGh.gS`Fa>2RY"׾=QhSrh;XȥmAw, Re .z^U*8̤AvxJKg RS/*mP\ Sv BsD^WDW+U*z$E2/Xǒsn.QiQ%V;/5&C@)u&0L=n]U|Z4D< 67:NEៅHARA|a~٪灞7*~]]HOd^(eO ]!a^pXԂ9YJgW9>&C%VQ@{g{X]ʃԤmރө#ytx ?zޜA m%׹N-ơrכ*N*BN]leh* iǁU8ą*P:S ci]=oTo?Q)h@u6<\J(EC>ֺK\0̎Ѱ Ϲ%g#GY8*}WCAX{ί18[}T1b=fgpw#=-AѦ5v -ɲrMav=SU3L`w1=b;:ȳd*pWO`Jr^W|(4g$\ om\]'ُ}ib.g9Ł)6Zw$2C,%%tl@ |.# 4H0ځo` H_7R}_z:|GA9d Ye4>Tg (@ۉjUGo<%|)]o(ݕß05j6!|/6P@ajlyҍPKI t>rrlEWĽF!{_#ܦF Q656[EYT0,CƩ?$)<+H{Q3; gy9pH,馆zJn# IiB;Z-: ç[2Oվ'輅@Yv>2)WJBZz7KxA%xCw":';]lΌ 56 yg6ˈ[E_..~F@b}tU-g܎_tr^$W2tӦ|XXs~xd/!SPVoO%y% s!Jx/[_(Le(H[$L\> stream xڭr8m媈&5{d؉7vj3s$b IţPR5@4_twYZ?,z*ԋ( @ץu |_ܾ_=4ArB2i߰`H4ua= bdO[}ݶRjTx`EZ̆*Sx͌7lmgƾ7Gyw-,Wrmu#Ksԕ}%_H^ /gmKj?5c `uͱgS7YW7Ry+! &`CN]L,/U|i%E+5PTZGfҟƶ~%~~~Vmqɮ_^j Z7Yʭ dDyDJSfFtmDIv%aa`޷j$B3  fE[^٥Bgyxpi t< Cvo7yV0n׸[qX82(k\ilSeimlAcv`%a2J3t7{=@M V]J׼ܾ }7Ytpm I\'sPٜp=iÕ%<6Y*eeX +,^dt!x C>ԝlwD&AP8aM>kmZ"aFuKm͎[[5knl ^~oQmWwo>]ݿx*r! [Ϋ:tN_q[Uݱpgy,Ԋ >05Ab0k=?=GA̲:2Nsّ-4nk8 D4Lrb@'VKɖY('@|&QP:=8ת=!g u>tqr^k/J;O2ác!^* o~־@WswXn:1Ò'FG` &ݡ4e`t^ pRhWuǍ2B48\ s){)rM EuSo+Gi(XdO%cа=YJ }V  ,rav NIh(~=8SxWr$8U(7slq[t%~W$KHX&^fnj@cG[G.&GC݇| olA/ar4[s)n!O.O(S(: 81oKDAGA^U?BR8ݯHt;C Av<\.lWBvgMVH^~r4__qӄkǽp+J@CɆbO[xSy5GHѵ"rTL4va/aT2")VOQhR)xۀZe$ރ"Vp.wa2Z 8Psz!9 oDŽcnn[9Xb8:4ֲNOhf>Vn=ncYg%;t)Jpd;\6+vˏ.J7:#a|Y13C~\u-P.dG}kofh |S{^%"`wA0fP˅"Tbqw)N7K(`fft?}9vnW lB}; fw:!lEg[MZ>ja ܩ  C/߆|O%߱g4Nν)b/V'ͽ( Dc@x60T.{@8 f<3 "k*;-b6xPqD֩T-&``zwO5y4wBW't`wBfi Mt2aHQpʕVQJE器WŊ떛XN1ݹ݌-/8ց֥}Yw z|bO<X27 sճ RѰAu4"VXqq4H{IWw|&^| ̠Vp?;~IBO=kaoHm[̎{P r1D/Wt w*c7$oK>J򟆄,w9(@UfШf=f((pme6YX}A!*؝"e%(ƈd9iVDN_qg* xP :JI:$gdq 1vHqz/2 kaV$!G!7qZ{|'a_Clͣ7agVьT>{8=I]*AggK׸"5e?W-QѮ6]4~ůꌊF1(yQE#/I{E~uJL@?V%g4^xHi\B} VYi5 ?µ~&yKgvu'/҃XBw^Y'+[]mW[m9`@AZ~)V@6 ˕ꪃef_XeL؀ n8t7^ 3^۫G[⯞ fK=5E=;WEs?Z;}C\ёc}ڐ) РRO%%_#rIs7ErleR/J"8gd`ͧW endstream endobj 1115 0 obj << /Length 3492 /Filter /FlateDecode >> stream xڽ]۶ݿB! CwSI@Im<w A g߹vv@]ūg=<*,]]߬#UHHޯ~]l6,á걕?^tmĺ뫖Gۦ>98C+v=u!]5 mw_5vUsKl0{w({(=ꚺ<ԙrO-SWo ~P:TG ࢟GZ x-kdvuh죫zG3]e٤PrKۦ"+)f3#< kwHQ|F=/lWM['9u3nږ8cMFؙi?T56-Ui'x}Ks(DƵ_4j][׆`{E$/5@LRN H)iaa_9l(زhYVU+vrBFY9 ,EŴ&[&$JbyIZQ:ſdx&"\ʶdۉq ,TME"O=;dudOҏ] 4W=%z'<`Lf8 ]"%2{ `**4l[X?B Q?dOz cXrR.BgGZ#lAbA8,e*E|Bf+9WTzP-icg;ϣذ񠬛Ru[Y~VC|.YגCMp/ HɡLAP[|p :A`WWd7@cho0=c iN+uC>s1) zzWS`Öb$P>0Gvݎw$WJ!].xzaOTI9BG'c. ;0ѲgnDz6^vGH i(S *ҥqqmdjW68QKP]ځ3 u?cjlX**{^BJE(iac!R M3n9Xzl[,8 G>r}0Vdrd:H9x(ry-w 9oe8J1hl|_B('G8[E" %ˊHbɴ2 I~ܑ~Q[cEEY,{+S@]U"sYjݤ9BCo%4rr1-p3\Ndm"lA.l_$С$wwu#3=rIF2tzU,X$s15ѺyȐ(VeXt']ҏ:D 6.|$* j98wx u K{W6`vh@ɏ% ;"p~ u ?jhJPӗa%#=jU52Ơ;{Y9V/*{^J3Hܝr>zrNH60Xv ^P}mQ i -TĞH54ᦟM}]GE6ŔBڗ%Y5FVy`4YU?)M[]5vl)sЛ)y~5cba!VSf5bpȮ9)/H3ܯM/8|: H+e =.6]aB?Llec]?_ GLC(P !춪֐}b\J+b|è vLnqcmLW%Fp.3! Lȼ]`p $: Ka)=e*< HM$ƻ}bF_6WPQ {s!}3YZ]33KPa񕊍u!ߤ}mMNfa~_h] endstream endobj 1139 0 obj << /Length 3335 /Filter /FlateDecode >> stream x[K6W訩` zˇlIy+ImSJ,V$RKR'>H'=׍V28I&?|?yCR~52PN'ɯms7cL5>,|i+ߛ]V5y]mTgD&k{Gfg_ۭ9|IÔʹYwLN*+Wwu)`nG!BN$IV8Đ$QYBTQ,ҽQ(eYϸq>EYUޕNp:mVnW95ve~j2- i/7pmM٢) O͏YgakgUYm͌dӷ{Q`LVVfS"}㋻ǩ6R0](~Cl򽋍ͪuXS}ݱA4/+H>m67,o Q){<:0^yS ;zuLİ̸$BA D{#Fvl"*!*JDBU)e?p2 T`sQnwEwdape}QaHCzӿEI;3.k"\3\ퟏ!^G@e_?LB|H$J0 !NRw5$Z&37C诉PFPsSEͽ RQF^Ʒ]<`&ϒnyE; GLJ~r{|>3g5- hi~#Lu0/CȶƓtN#`B#r:-GໝB&/lVngu].rPެKV?0 <3(~'GMY܄EX._.ۢn!b\73=4M.mMkGaJ^/u L jSH1&BFigſoZ S'JMk EVc2u侟Y[OWd+CH# "l}ή*Azbss@QRNM 4֍d0|KfoeY?Nݏ|/wNƼ1Om2SQSlUIUUn/cwamJQ613j hSbyE۶u6"o6GS*]0#26bFIYyeGRkk:+>0x7i쮎)HvZy8sqt>Ǎ8z) . *LJKMb2Jyb3&o;?5_J4D~ ]Gw/:Yu}ѭl[I}ѵ}_~^j.B}P뾀uPݲ)=`Up\IϞ~Ja0K#C^e;xI/xYpȄ98D>UœJcYeK6}}x;Xd|Yw4}s`xw)"MV[3e56 )@ʇ5ᦳ~xUWo6$X-,]"u߸rd$=. Tlpqw<\rte"jF a6w Eyޠ0W_{zeWCv9yQAC7;%x-Z٪jxZkî΃@{: Zuw׋G(P\0֡s| %%ʅQC*@:@SȜIy[myOz'ET|7XҟH_E4|ƛX# ߌlsBYwqSRqjHQ! P vzeP1NjlEUqGX N .+Jvu9%9o9vSf(Y? 1ȗ5]A$W0Z=_6Q*tW֠XoNՅ:njӮK B6\w*}4(䚘D\?u1,)*hl BLͣadT(à7{Zp|^jpuTo\Dt1:3w ¿}egr_yjZ, `o a! !XƄ.w@`_;8g4t}s:A@Aڼ\2\V5,eX,}sn.]gᗰŸ0 >.2 %t7WޙXteԷ-nPvpFb+ K%ꐧ la+mm,VgZO8}iB(p>?D|ǗCj_TK栶Sr,.\YbLHcd07R, endstream endobj 1171 0 obj << /Length 2949 /Filter /FlateDecode >> stream xڝ˒6>_Ue1͎=lM*x\9$>@$L2Iٞ| |3thݍ~[V'n~ÕRnEaR~QUZ=V9Fy*zGsW|J {N+ZN]ud^]讨LJjY jSr&PSk?:.P74KAmyfg趨<ddIcɜy}:f oEȈڳnZY+w/4, %1Km',M-ͩ/L'O{noS PB┍R%JTєt%ql3 01Z9eqpߞ.}}M@ߌOԐwߴ"99,4ykLs/R>zyIh^iU,p*D(iǟכ(VWS<3{_T. }+-H[Ǥ U0}~Ȑ"i-וa_oIw?#vk& m,14N{): jٙ!" P1ȏ<[CA}K@TFij6 s]I>IB@0KY>W{9Q( L: f-wXa8az.hbQnUsF5*(y(>.d ޭ0Q/sMsLo JîM뾰HT1 _LFH(!$Zpm{!DVQvMb&-R٢TV oY*q^ .,vVW];MdϐZ5r w֕)QERɻRw?!@$*͟D ~N`G^M'Ni% }{n/2=>C͎q`.0K2C0Vb >f-(&Zcđpq4z'$u=I4**(s,Ի3s!(]TzP( ·M@Ac `* 9o_7 DHB ¼v+ALbj8:mdŰ -"/enNN#_Hx|}r=uAdA&մ~J,QgHytT=SX}+sE3 Y]3W {9QUlt%5s|Gdp_C--qYu3i'ԝY A '} ʐH#oJI}F綛NF(^ 1['(~*DadʞqA@s;pwW-<0/NyVaHRV矸E) LbV\q-T" zkr6}4uDuwy",@Qg}!'}b#f..\_rŭD0#@:^E)ц,m)"DgJnsdԡ-|S-5C|耧8(u}/n9Ndc'b{oj (zH2ӛ !^&aK^&ll+ 5ў~w+G0'M: 0 ؒCBN$KfMlgi`BWi1l;-U}<߬=ġX(,HBŘskn>1 GczQ [.(˶vVD uF2Ty}Q"4{Z$c$ );y=&o<;7#j2&r6E5.pw"{̶>N|'^ݔu!PSɵ=&ܾGz Eouigڼ)S /wLk4,ԕ 1rl!EcQfI@zG ] +, ߳b B?( endstream endobj 1159 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figs/BLRLU_step1.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 1175 0 R /BBox [0 0 457.725006 422.008942] /Group 1173 0 R /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> /s5 1176 0 R /s8 1177 0 R >>/XObject << /x6 1178 0 R /x9 1179 0 R >>/Font << /f-0-0 1180 0 R/f-1-0 1181 0 R>> >> /Length 761 /Filter /FlateDecode >> stream xUNA }߯cRis7  KZB|}̒eIlf9sl{6%!6sNXsbiQ#Γ`88R&Ombz=Zk'jոPm tNЋ90ZʃtvhAdQT^@eG5D&W}1lbFhֱt: -Fh=Y !dfCmUud8F $|v{ Two⑾n978M tUW?!URDcڀE<|z7yZ,~r9mLc=LLLkYs.CCѨF[6鋘XcKNq9{Tx1}]ܝo/7 Q0 _C3cf> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x13 1184 0 R >> >> >> stream x+2T0Bkgiih`j˥h^_ah endstream endobj 1179 0 obj << /Type /XObject /Length 47 /Filter /FlateDecode /Subtype /Form /BBox [ 58 -0.991058 458 398.008942] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x16 1185 0 R >> >> >> stream x+2T0Bkgiih`j˥h^_ah. endstream endobj 1184 0 obj << /Length 1192 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 140 2 220 238] /Resources 1193 0 R >> stream x ʱ >S@ ,Z=G%{5 4IOJ#bڴn9o endstream endobj 1185 0 obj << /Length 1194 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 58 0 458 399] /Resources 1195 0 R >> stream x;@PEY݀1YDxD"Q}ܜ$j`ɰVJ']MNaB-N>y0XϪN 6j~S\+zDf endstream endobj 1187 0 obj << /Length 1197 0 R /Filter /FlateDecode >> stream x]n > stream x]Mo  Ə*fcl/akR{wla!;Ͻ6 I7ya]р2yQNf: }`[D-d2{/u84\C&su҂C^ 2KG,2 d kmwuљoE[=bj\2ĊY!7ubDLb0~  ښ5kT-1먤S1W{մ*8^>iO =T朚rJ1Q<>Ǜ(:K9nz~ƈI#:2yJ/О endstream endobj 1190 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 140 1.008942 220 237.008942] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream x3P0¢tDb.CC= K# #c3T4. endstream endobj 1191 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 58 -0.991058 458 398.008942] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream x3P0¢tDb.S ]=KKC @R(U! A  endstream endobj 1196 0 obj << /Length 1200 0 R /Filter /FlateDecode /Length1 3964 >> stream xWol3?ǭ1.ps,C g>Wg0j(V츆M]B~?Y*6phMNU-TCIDؾ[[|*u͛y{@f@6r,7; @G&cS~ \@RWgޚ>߼uV}oyonDFvk+8-|v_cP^>E_j;j$PFNE[kDYV{fh zz\,X!lROBk7m%v %z.Zc֊L$m oKw7lhOuivFq>&Q΂IR$G:Jefo77̒$Ӷ+O/x|||]b}#B>!pBPϛ,sIr dMݲHC؋5rH}/]Hz9fKKevbŹ Gr0zw$vԁdM׵XtTd];۟ly>EV^OeEtI@ijgyY,CA>A3WpjK-?`,K"D0)l & kJge q}c$t+Y ++bJl V""i$CE nK!=IC`ƒAŝ1|"fx 0 W|YK9TB:̷*z<ʛMa%L@#$+p0xWKr`W <`l!/:0>4J- YYX֬K ̲fexV TY753ì wzƥȘsEJ6`pUCFkՋ-h"mHEJd&rp4eXCa6!;b-&bz!q7;n;쀌0)z恬?03Afp21YRdNfF^6+w̠~)#FFP!c,(20a g-)*I u`|FH~;&G%`%<ZZ}r=8ޔxNa2rpq=;[Q Jʈ'tk!A&|D 9,\jи܀Q$7 ėbsNe ٌ8P?‰ *EBUBJ%*]BU;܅i!uپ]7rn o ?5Dk#frŕnvJ<?q?|GpЖk{ȲŻEƢxki 9_PNP})`{=h֊"Iv o_!Z)!n@\&N˱w`_iB)/~?HD_Ѷ^FK큗*63HYrPϐ3r4)d/yO|_![8yh>pHGAEA!e"RHI^n8h$Ƶ.h5Eѥ("FwHe{פ++ҮFg4B0A*G MJj\qyr!12$NPJjr;qH>c f!17 >13bD30L˟H$<1 N04K@gCĊEgIL a endstream endobj 1063 0 obj << /Type /ObjStm /N 100 /First 989 /Length 3070 /Filter /FlateDecode >> stream xZmo7_ s9|gp ;IMFںȒO/3\QjYڸ܇;8gwpf8 I2J(A ')2M*xa栒64 "J4p4Sг#phȔΓc NhY_P CE}1> # RE g hí4b{F{(l@0\0lG"#eҠ" DT)E"}f[$X-r,a!ELaƉ4 m#ib~iҎX+aՒuceI/|Z1,\% sA0F,Ȧek`O, +SewokQl>3͊dY xYJ&7ӳSSrn?ӧX䧢?at% 4`l;Yǿ zkH:h[k-#qOu=lif6}ŷgz/tO۝@Z=J̢Y㱸t9 Ȟo&QMgB|/ND}!xuShdLsJ:mlH}ߜgžaҿ`z^md f@@"|!B!b!ҊT]S擇Tgˏj44Mg,K~^V?P~"KQ  R*E|$;Ά=շӷSgzW???fu"1$vI2J=)|h:?ԟ@X 솅eAP.ыU/InİIͣxm߈DCNHHVJI;ϛգYe^al͹Ow G xf=A挲G 'zEpJ^W^ֲZm0JsnF1"A #C)J@ϫ59Xdss790$ٰ$qEC:Hwm|kc^ِ$v6Z#\@v:((l\sovt sĂ9b`T0G*#>qz($tpv(TW_(pq9[@u'-`>*! s\S<{wH,Ai%n ud7)V S-R{ cPY\c aYtVHVbdX #Tyzw?\,O~#DNamWͤ:o݌t§:NOfv4k~mѯbVO:}zr~4g(?Ϧhۯѧx^]4WW y?H[7B\1)_I[JB˛[xM/%jF{kX|pj#;mvP.Lڑ.@rckBdm>Nm4v_~ FiF-nMKQ!t!L!m\!|!B!b! 8#U™zEi%LxPdm깸S^e^ےzHE%䫍LTY0B=bΒw gcL@!X9:`# iB8ݪ4ǒXzs?J= OM(`騡!4'{%:GAg˿(˟+ B#z[dM^Ui=-&Mb51&Ra~dqqrC$V*QUR=nAY|`$>lMcdjb> 9K#-代D~5#!/>Ϟv=FWI`UAEf|ڻ~(;kXzَC IK]}0suDn 1tž6fޞ=?>~&Z`0o H]'=I Y,MA`VS0)j|I.תN:7(,(ƥߋ3sjAS~,(+)-r٨%DfTFI.TxA xΧkIN-W}\(Ri(cl Naqj^1T4RTQMe} b)"UU >oH|w)| 91qo6d@ǡ#qut5u8"shJVF>К5 &z޵ճ=2x{# dLWJcd;^E+)Q`Xf&`r2%wOPE%qn#W@+ ƙ+g_/`>ZT.kzgMPdԣT$s RUŬ r:@Z<_뵥 }_?b u̿__9tvΖ @MvNzջbyjtq'| իz]/p6fe۔Yo&hr!F|T^ |q9 GÒPs5tz~<';CZRP #]?nOOb|r*'Ġ\pV:˩SKT};s\y6Kmve—nUv7Fij|>F?ģ_N<=Pq::{r|^rQGŸ Kt>̗>+G> stream xX{xU?N~U;<:$&i#`  D`t0  2Ё yp];33!S :;3~[o}s9wm``*@~`f[@_ MA/̋(y|a}/)593ϥk@TO7ޣgT/tLa#>J9i=-S6'*sAQ/D 5P1WJ2i gϴgq/N+k!Fv})My |yD`? :{庰5L6p;93ۮ_mw^J~GdlĦ3  qx?TByrɥ= :K%/Z*alRe>{18';1yv˞M,"YPA/O:k#!%DvzXNNM5'uG<#Bu"0椄 >"VL16{Q4O=Qh|jiKZW҉OkVY)[Kxk_69&fH:YWUL LAAQE!q 8L*n|%B*{{nB3)5v}5VYuk$Fyh9홴A[[ՖvDg,b $$7tiݫ}vt|#ۥk {JfwNRsx^K7I$ lm&f'~y/e+-v n̽E-WE`Tɬâk]wæ[m`|6ffɳif'hkךvbVTМ3-ŸOi Cot垷Nmi!:y]s\9'M19eS}e~9,sj a"(M߭L6ݭc2Ylj(KX42>QWvJk^x\Y77;kۭ z>g:LvƲIr2,iÄK7GaVlS](Oڈ9,kHN$ã6dפ,,RllLE= S_wMMO3{&^CcYpⓒcXVЦ }sbVf;w_2kl$S))<.R&}qɲ%1Cp3-aAwL@%쏣|.hR$Y0OCKRTSP"!C1X>Z w+%}1~Zug{@% ٟJd׽ձ0+a8'-Uw~I-mW %i23b2b3qh? b b qe+kbjbk5q+%7$w$\z} E1EEޢ2oY\ULUl*.|:>!$[ؐN1Yq7eN:rac4ͫv_c˛92?;Y O]%3۷\ ڕՇ8J [)4&:jdkgNƵ #brSӰC+CE~zuٜ1< _|,OӧU擎r@E0ln#n0JnIvEz@kBZ#o?۬Т(#e<({:c)F sKD-QV9:-Fl#Rqu>71l Ɓ3.)h=`~(|'%adJRޘl4E"P*eiiS,8yD8kOVqso[' Vt׊uuu~Vw-?GORbJml'Lz1 sSg#)\VDoQ~?^f/dJPe#w?9l_I9YoXSA]3E ;^\DzA(M.h\k.DtyÃ( r#*B4UJKVaU+JȂВ 2!!xK 7]aϞ %tI|tpĉK_?q\9n64D#^"#  ll4rSXl0ƝOz-9"U""9Qp]H҄ 8z&C6){Ҿ8uꋴ]tvbφ-tBTsދ\t4}!^ NwCM{_vtkR]WH ݟ$c$dM &H>SnM;>?3?H`s4λAqDY( $h-õV ^S,)ZtwhJLJl75.1RU[m.CbX hC;:Љ#1J6'HLJ]ڐڑNPPzi6涼G޹k~K˹{SR cr !Hvԉ |ĺ[b7S&Hە#>h8Se:F.B`i E23Z/0W\tAqm1eT 5$M)O}")'5:YW'Ÿ.o 1Nqjlu?F^㎔ǥP)I-5qMuh^m0qcnW I%X$YjVE1]fq8i2ihg ;{0"$+P4`JaL0{Jxa=q==#bEԿ?s~=>aRC_:J8;N2OWHA4n<uP_ߝmW!moHaVJo.vP˩AzV"jyZi 8M#kwA\e!ϕc0G % ʧ"y!mnr+(^ ~Y,pO.v1 ka;T-nV Rt`3R?EZz;VYxei legVV`TI%hS43,eR׬;AVV] (nSbkW6@_`9g+y<ZZ{1G)aKw#UKEl|-fўh$XKp4NNiq P0J^Xki "N5nz&o#4ږx==SH>G5Om} _0؝?o6i 5S{`i#olQw\=3l B"I;f8F| kmy2U^|Mq;'x"HCKx=,NprmnVSDS+ۡ| 8KPќ4K(K(or2Q1ZC3brS]IL%FbA3[-Zhi$D ?0߃o|_}&po1j=}|O1}˅ѯtN/ !%n6;1bl! YVYq˳|K1>ɟN|ƂO To۰& v17q}'>0JີøJ^k>|BՃa*׺q]餪}R_ \\+.1U+{]?*p2\Z^G.b .`'.XމeKJqK<>8wGs -pðt?8M)>X~O&-p2<9 =89pˍDž 4S9?sSx:mc8Ɔz)vi m/0W୷nem|ǁm8L`C|h'C88[ポ1e̛4)& 35at  4ANhӊa S}<6LaOIi(0A`8z1cba`N엇T^atRaCiRhzt@xй hhr@+&D@MnTQN4ԊɥȜY|_xDPiS endstream endobj 1160 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figs/BLRLU_step2.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 1203 0 R /BBox [0 0 457.725006 399.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> /s5 1204 0 R /s8 1205 0 R /s10 1206 0 R /s12 1207 0 R /s14 1208 0 R /s16 1209 0 R /s18 1210 0 R /s20 1211 0 R /s22 1212 0 R /s24 1213 0 R /s26 1214 0 R /s28 1215 0 R /s31 1216 0 R /s33 1217 0 R /s35 1218 0 R >>/XObject << /x6 1219 0 R /x9 1220 0 R /x11 1221 0 R /x13 1222 0 R /x15 1223 0 R /x17 1224 0 R /x19 1225 0 R /x21 1226 0 R /x23 1227 0 R /x25 1228 0 R /x27 1229 0 R /x29 1230 0 R /x32 1231 0 R /x34 1232 0 R /x36 1233 0 R >>/Font << /f-0-0 1234 0 R/f-1-0 1235 0 R>> >> /Length 684 /Filter /FlateDecode >> stream xUn@ +x 25݀=qz1rbIRI:\ > /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x39 1251 0 R >> >> >> stream x+2T0Bkga & ɹ\ Ɩ .\\  endstream endobj 1220 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 58 0.100006 458 399.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x42 1252 0 R >> >> >> stream x+2T0Bkga & ɹ\ &F .\\  endstream endobj 1221 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 227 244.100006 237 303.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x45 1253 0 R >> >> >> stream x+2T0Bkga & ɹ\ & .\\  endstream endobj 1222 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 243 300.100006 293 311.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x48 1254 0 R >> >> >> stream x+2T0Bkga & ɹ\ & .\\  endstream endobj 1223 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 147 164.100006 157 223.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x51 1255 0 R >> >> >> stream x+2T0Bkga & ɹ\  .\\  endstream endobj 1224 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 163 220.100006 213 231.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x54 1256 0 R >> >> >> stream x+2T0Bkga & ɹ\ & .\\  endstream endobj 1225 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 147 84.100006 157 143.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x57 1257 0 R >> >> >> stream x+2T0Bkga & ɹ\  .\\  endstream endobj 1226 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 163 140.100006 213 151.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x60 1258 0 R >> >> >> stream x+2T0Bkga & ɹ\ f .\\  endstream endobj 1227 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 307 244.100006 317 303.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x63 1259 0 R >> >> >> stream x+2T0Bkga & ɹ\ f .\\  endstream endobj 1228 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 323 300.100006 373 311.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x66 1260 0 R >> >> >> stream x+2T0Bkga & ɹ\ ff .\\  endstream endobj 1229 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 387 244.100006 397 303.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x69 1261 0 R >> >> >> stream x+2T0Bkga & ɹ\ f .\\ endstream endobj 1230 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 403 300.100006 453 311.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x72 1262 0 R >> >> >> stream x+2T0Bkga & ɹ\ F .\\  endstream endobj 1231 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 147 4.100006 157 63.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x75 1263 0 R >> >> >> stream x+2T0Bkga & ɹ\  .\\  endstream endobj 1232 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 163 60.100006 213 71.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x78 1264 0 R >> >> >> stream x+2T0Bkga & ɹ\  .\\ endstream endobj 1233 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 220 -0.899994 458 238.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x81 1265 0 R >> >> >> stream x+2T0Bkga & ɹ\  .\\  endstream endobj 1251 0 obj << /Length 1285 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 140 3 220 239] /Resources 1286 0 R >> stream x+2TtDb.C#c =3cs ]#c=3S3T4@.h k endstream endobj 1252 0 obj << /Length 1287 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 58 1 458 400] /Resources 1288 0 R >> stream x1 0{~x!^ R,DE,7 2FbqxvTzѼc'< ˌ&'JK#FE<& d endstream endobj 1253 0 obj << /Length 1289 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 227 245 237 304] /Resources 1290 0 R >> stream x+2P wDb.C=3rgqE*(p(**(\.## Ks=c3c S3T`@@.A3 endstream endobj 1254 0 obj << /Length 1291 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 243 301 293 312] /Resources 1292 0 R >> stream x+2P wDb.C=3rgqE*(p(**(\.# K=c3c  T`@@.A3 endstream endobj 1255 0 obj << /Length 1293 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 147 165 157 224] /Resources 1294 0 R >> stream x+2P wDb.C=3rgqE*(p(**(\.C Css=c3c S3T`@@.Sc endstream endobj 1256 0 obj << /Length 1295 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 163 221 213 232] /Resources 1296 0 R >> stream x+2P wDb.C=3rgqE*(p(**(\.C3C3K=c3c  T`@@.Sc endstream endobj 1257 0 obj << /Length 1297 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 147 85 157 144] /Resources 1298 0 R >> stream x+2P wDb.C=3rgqE*(p(**(\.C #Ss=c3c S3T`@@.Sb endstream endobj 1258 0 obj << /Length 1299 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 163 141 213 152] /Resources 1300 0 R >> stream x+2P wDb.C=3rgqE*(p(**(\.C3#K=c3c  T`@@.Sb endstream endobj 1259 0 obj << /Length 1301 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 307 245 317 304] /Resources 1302 0 R >> stream x+2P wDb.C=3rgqE*(p(**(\.c Ks=c3c S3T`@@.A2 endstream endobj 1260 0 obj << /Length 1303 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 323 301 373 312] /Resources 1304 0 R >> stream x+2P wDb.C=3rgqE*(p(**(\.c# K=c3c  T`@@.A2 endstream endobj 1261 0 obj << /Length 1305 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 387 245 397 304] /Resources 1306 0 R >> stream x+2P wDb.C=3rgqE*(p(**(\.c Ks=c3c S3T`@@.BJ: endstream endobj 1262 0 obj << /Length 1307 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 403 301 453 312] /Resources 1308 0 R >> stream x+2P wDb.C=3rgqE*(p(**(\. K=c3c  T`@@.At1 endstream endobj 1263 0 obj << /Length 1309 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 147 5 157 64] /Resources 1310 0 R >> stream x+2P wDb.C=3rgqE*(p(**(\.C ccs=c3c S3T`@@.Ssa endstream endobj 1264 0 obj << /Length 1311 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 163 61 213 72] /Resources 1312 0 R >> stream x+2P wDb.C=3rgqE*(p(**(\.C3c#K=c3c  T`@@.Sra endstream endobj 1265 0 obj << /Length 1313 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 220 0 458 239] /Resources 1314 0 R >> stream x+23QtDb. r [Y*ż8+:(jeP`V L sY(*[iSSKT'-@@.YO endstream endobj 1267 0 obj << /Length 1316 0 R /Filter /FlateDecode >> stream x]n > stream x]n0 y KHR5p>(o_'M_q=wz 0='cEQ6*N} 8wv\}Pp ~Ó^ {.=͹EۂƑ^:Y*>v&G*BN(d DZhXQsuT߃z<'C\2T'&#d!g2OLFȚ5hבYI:s:/>su>>/>7yO#KJS2tU萙 endstream endobj 1270 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 140 2.100006 220 238.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream x3P0¢tDb.C#=C 0SRҸ endstream endobj 1271 0 obj << /Type /XObject /Length 47 /Filter /FlateDecode /Subtype /Form /BBox [ 58 0.100006 458 399.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream x3P0¢tDb.S =C 0S010P0T(JUH0 endstream endobj 1272 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 227 244.100006 237 303.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream x3P0¢tDb.##s#=C 0S04P0T(JUH! endstream endobj 1273 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 243 300.100006 293 311.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream x3P0¢tDb.#cc=C 0S05P04T(JUH9 endstream endobj 1274 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 147 164.100006 157 223.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream x3P0¢tDb.CsC3=C 0S04P0T(JUHM endstream endobj 1275 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 163 220.100006 213 231.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream x3P0¢tDb.C3c##=C 0S05P04T(JUHe endstream endobj 1276 0 obj << /Type /XObject /Length 47 /Filter /FlateDecode /Subtype /Form /BBox [ 147 84.100006 157 143.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream x3P0¢tDb.Cs =C 0S04P0T(JUH endstream endobj 1277 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 163 140.100006 213 151.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream x3P0¢tDb.C3cC=C 0S05P04T(JUHy endstream endobj 1278 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 307 244.100006 317 303.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream x3P0¢tDb.cs#=C 0S04P0T(JUH  endstream endobj 1279 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 323 300.100006 373 311.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream x3P0¢tDb.c#cc=C 0S05P04T(JUH! endstream endobj 1280 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 387 244.100006 397 303.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream x3P0¢tDb.c s#=C 0S04P0T(JUH endstream endobj 1281 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 403 300.100006 453 311.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream x3P0¢tDb.cc=C 0S05P04T(JUH  endstream endobj 1282 0 obj << /Type /XObject /Length 46 /Filter /FlateDecode /Subtype /Form /BBox [ 147 4.100006 157 63.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream x3P0¢tDb.Cs=C 0S04P0T(JUH endstream endobj 1283 0 obj << /Type /XObject /Length 47 /Filter /FlateDecode /Subtype /Form /BBox [ 163 60.100006 213 71.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream x3P0¢tDb.C3c3=C 0S05P04T(JUH endstream endobj 1284 0 obj << /Type /XObject /Length 47 /Filter /FlateDecode /Subtype /Form /BBox [ 220 -0.899994 458 238.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.17004 /ca 0.17004 >> >> >> >> stream x3P0¢tDb.##]= K 0Q02bKT4.a ? endstream endobj 1315 0 obj << /Length 1319 0 R /Filter /FlateDecode /Length1 3964 >> stream xWol3?ǭ1.ps,C g>Wg0j(V츆M]B~?Y*6phMNU-TCIDؾ[[|*u͛y{@f@6r,7; @G&cS~ \@RWgޚ>߼uV}oyonDFvk+8-|v_cP^>E_j;j$PFNE[kDYV{fh zz\,X!lROBk7m%v %z.Zc֊L$m oKw7lhOuivFq>&Q΂IR$G:Jefo77̒$Ӷ+O/x|||]b}#B>!pBPϛ,sIr dMݲHC؋5rH}/]Hz9fKKevbŹ Gr0zw$vԁdM׵XtTd];۟ly>EV^OeEtI@ijgyY,CA>A3WpjK-?`,K"D0)l & kJge q}c$t+Y ++bJl V""i$CE nK!=IC`ƒAŝ1|"fx 0 W|YK9TB:̷*z<ʛMa%L@#$+p0xWKr`W <`l!/:0>4J- YYX֬K ̲fexV TY753ì wzƥȘsEJ6`pUCFkՋ-h"mHEJd&rp4eXCa6!;b-&bz!q7;n;쀌0)z恬?03Afp21YRdNfF^6+w̠~)#FFP!c,(20a g-)*I u`|FH~;&G%`%<ZZ}r=8ޔxNa2rpq=;[Q Jʈ'tk!A&|D 9,\jи܀Q$7 ėbsNe ٌ8P?‰ *EBUBJ%*]BU;܅i!uپ]7rn o ?5Dk#frŕnvJ<?q?|GpЖk{ȲŻEƢxki 9_PNP})`{=h֊"Iv o_!Z)!n@\&N˱w`_iB)/~?HD_Ѷ^FK큗*63HYrPϐ3r4)d/yO|_![8yh>pHGAEA!e"RHI^n8h$Ƶ.h5Eѥ("FwHe{פ++ҮFg4B0A*G MJj\qyr!12$NPJjr;qH>c f!17 >13bD30L˟H$<1 N04K@gCĊEgIL a endstream endobj 1317 0 obj << /Length 1320 0 R /Filter /FlateDecode /Length1 5716 >> stream xX{xTE?uϭ~?t'$H Bڄ@`-0h(!eBx9 !""aa< 3.qw̠΄۪ԽuιUuN:S`` @p|lz/@2sn`0(}} {$۔2hLYӋ@$lbJ2ɳ{b(n #+IqaM_\*k}hwYB A@BwI[LǗK2d4_ʅЅ/J^ б:5Z@ v}SyB?w+zC^z:yu]wm|v Oz3t35'ч%AU/a橁kvhc g^/l|GS85#FQ6mN&"C"@7 'BA_m{UTNuqG>zɞdwd"X)}S~xII]u2]NMlث/hb6?fak˪_m:$jJ) -Y0tVﰻ[^8 cX$Wi~Zy3-ƃlv9SX%HEyjIgpJgT>GәCG껾'evG=i,:kMfn#~3/I fl<q(JRYd4uE)>lY`p[O8>`G]ӷo?S*U/0 w1XGb2-7+ x/m\C 'AAb\.+[IzhVU/`4T0l+`UؤX&^V\`(ݠ+F0?w{au|F3o<5ϖ=~V׵Nc2''2NGs!Ƭ摆 cSS s U &59$EVxn[[S!%Knt=^C1ٔjiiu9Ͳ%㹆~~\s%S?K~~~}ayeկX6Vr{Haqie@ 402Z[[W}ҴڼڲXmZwwZZ+j:k*L֋eiXeIl^iY1]6M{w饵#Vc:6< Ge$Y%ArC FKv0pbܭZa`ti!1.֒'P>muZU[^$H QZ#$v:u&'Qre=&QGX$p=)N ևeMʌG,̿ӏ/suK?dkJ#DOݬI:LU n 5*ZP:@Y ߟ0 zs`s(3(_rAri:$_IJ4KG;$PlN#"?Oոv56nXt/^۫K^zlggmKY%?:cYw'-'dp0J*xF;ڭ4sH:FK6k~|OB ˜ߪܠz1| u &%0 ; ]JXT(Os~L YP+/8`:wx3?)NL^[UhM9voY.3(6T|ּ`6M!\R rbou ۂ12͘1$3 VEPYpJRDhv&#;o-k邮eouz}ݻ7n|I]< c:æ G˵k-(Ly@5U 5ᗌ$T`M( \hX:  8\Χ`9@Nk.uR49{5n].dQpgHy$ 5i'0ĎۖgOjjQW*vˆUIk@wMh). Q[m1cpkdﭯ76?R'Ԗc(39`ezԃ\n?,G煈|>&1vҩErbt=6J'O)n{'+|:67W {)GLr7t3k~0⍟D0El‹6p/,jpϜ^IF?"h!=dxCX~ o[}qGy~ƎBOc" 5/(tBr8#nz)NM0HZKb*m C0s p!; )-l1:y'ZӃ%fR = J,^00O"1l쐢- -vwVM_,l7kQk0Ԏَ!!xMgWW5J/f/j~!sW2Y ~* ?)KG??.Njxa8(Q~ '?+ʼng'+U~2ߋf 'c$#*6FGyPCSxB>;/?4߅xPok6|S`}1྽^^c7H7q w |u;,J1'u5]඗M|MX_UKX|A3"ƌ47o=p7nX?o8*Sq_nmN>\s^eĨ*ƕS+XxV+>3+.z?-cYyq%[).2hDžc _ sQ"g ,8S cQ;N3T8EI>'XP&N8V0 8)||7gDZXF|P_(|_($-pH‘ f>Rf.̯aJ|h;9Fdq@+dÁ|ˊ_`;mǜ~ ϱcl#`:1ˌy{0r3'](ޙث*ƞi6Ӌi6=T/x<Ŋ^#& LhE鱡]$Ř`xxq}+[1NAѱh%FHTZfS47 4צh4 4(tv/tH\ ґ)YW>z_(ϖ} endstream endobj 1339 0 obj << /Length 3929 /Filter /FlateDecode >> stream xڭZK6ϯQSaڃ=q޲cg\ي%q,)RKRq_EJԌbE$FLJY8"ۋ~, (ۻ.̢ʨj~tmveuJp^7vݥ O7j~mS_*7r9nn6YN{KγeW7WZ_}l-?6Y6E'Ypo ԥC,jBB SoZ䥰vAO#kYe嗯[E(^( _r8SɬL`X[\z~w;Ϊv P|#UG"%hvJ΋ÎjM9u|)ּ }=̓ٗS2SF[~½Vz2|+ԡאvIqm4Ќ&8tLD]gz/j'dYvH? OIB(cKt:}l|~vD:o) N%E8EثDz^*wƜ hКd͸HM}j -X~:VhYV>35g#0Ԗee;ڴ>8SP@5??N68Y  |,"qЍsȀN]fH5{ך8IAȢ7YN4ic0ĉ>]A K@BߡN[dP?VНr4\=StneM' 6c7~bMfҶM elN|慀6y>N9ǖp)'KՖؒ5]莏K$:'vpy LձnQNU ae8,mC`NxuQj=Q:* (N-0d@P2Sԅ,eN%Ev>=@&1vB$"t;J99E`Dlcr$ 3Z*W7@-e{ Lec LϴbSYSR5҇66ZIL%- Vɷh: #_‘1Fc(PCsb.%3Lm`d|Ct PP|T-J(!/Gz|"hH~ȭMb L%U>T)E}s`H~Aq)<bQ_g5e?yаG"&Uh+%|F v^04j8@TAI*ARwxP'p_VF:<:^h#.kbVZ 'p̗BI8ӭށ3P|T_ALFR,;aC_|~⎑QhiIF\8fbf)C6 i2$Fhޱ/6ǎCMXtS){uuPqߏJWg 7 _/^!&=mlrsC8[ !\?L"trvscp9jpJ&h.krCn`dm0Pؗ\(H9a*l* WD8pU}J4zW̜l־}A1&WGhW˯N1TFGJ2cۮ-up6P3 : PNI ` cJձ̟wTzxOf7 "]q'R Eym@US MH> %cQ?p[ gpveO CyY>h:pd7RT-.>p" L)Wbpk&\I4_Mw".NMo=jmq|d||a35D>Rqqt^{PJ"fpUZ ܂c a`7'y&z8L ڳ$} :Dqؽw 5A/vtN };fd .7S|LĽ^fO2=\+dqٲn! {uGk e/O_N,SݳG9 VF3߼}~_'B8" _z{:}> Za}8RѲůQ_M_n)B 4U|BkRu:SЕBDoc02;n@> L2 _?X I1C;Og)xy~x 'P!@ЌKC=QzU}!(A+m鸨`ս~b (ta8F%pƻpN g{U#B[p/ &$)8G?esH+81NlǢ#"*zyJ4L|Pisw>|=!ƴ!;n*rVăl}O endstream endobj 1202 0 obj << /Type /ObjStm /N 100 /First 971 /Length 2010 /Filter /FlateDecode >> stream xYmOG>?ڊH̉8H2-ٜ艹] [@lOTuWWUWU$ C" ` zNhxa(3af5H&&{瘘HxĤLL X&LD؋d2q)eb䨀 p(P|mQ}բj;8OFӋfr)d{2oV |`u1fY߈D;;O8[\nrr~Uf=B!,G5BHbV[v5{[̈tϸ[mFYf\k.cPĺ7PoYWbzt=\no9Ưqs-=J>?`C LN!ziCu oO&Q3Alۙu!'яGuIFV||ŵYF\Aq˖^q݆8l+#nyMW˪:? עnsQ2ҹ^p!'% jIrq# [ZMiػE\X+SJn8$᠗hKI-ou^&oVA*J1_L'IJOh%RA(2p)g^0$Qi>`-Vw~ l*ISs\Wo4=$(e%ܕ;U 2\Wg'D#)Z'"= [>"_sXP(ЊuQ>9liDeՂ{j* \0,k QeJT5_I8u6pjNPrw:jT W]Wj ߀D_f{{}izbXA˖x+8=S^s'۫v::a#/ʳS'>5quc*}ΝeꤞOϖMꋦ7U $cnGsM]Lܸq'Ǘ_7i ZZfV3}^ÆT`|>ɟMp"B:|؟?a0~5$e!@BmkzR3ĢSqcf\B$&WA^B'&fd$kfMPIQE?a sG4nJOCG8way׏;7B endstream endobj 1349 0 obj << /Length 2422 /Filter /FlateDecode >> stream xڽYYs۶~`P;ӇYƙlײn<0ck鯿@J)'<}pg_@]e<{~gVdS&gzÄ${_\W4<tq˦ZӫOUX]\1/ 0>ysr=zz6:{:m%{Dρ0yEp evBj B#S:# -JŌ=JـIS :u: .0> [C/e}Ct1vwѾAN3`1+QRpi.*-eA(g@`h7\c|Xb3*hO vW4^hȗ+vKcU6qLxZa &>iA7)DG YqO>ǧ2>]'JZW1~ÿ㰤]ʻ ̑7Ey*m>\_PL+?'(Ш"|P&oqeTDUZzu!,vQ"hRf & f#& E^5(j"5>5 RqXaqݦRt?a·/5_0|GT${bW![ @n2;/a=2B˷17 ʌIZQ K[e:q 2.Y8,: ߅dyt`ѶSkƽh5A+ԎJKc ,WZO=-0P'df '-{a^DL&j3f=ցf6|}⸪nfjfT{ e}Im<>^&jӒק؄@Ya# >l@d1 Ct|dwّԅF!3LiP78#&f-GOES5Tѫ:&Wގ)eDZ*wQeޫ6ќ ytq~yݖ^E3aѹ?Ip[N9vNi/ϔoKȮ-w$$; %]6嚓t[]~)%K#SsLId7_\Zn)3)qѓw}+a!9v:djY^&u䪜"j8@PPB9sV F4+fp..-i.(OfkPJ-^kE:媊@nXW^eԨJ jn||蒲wD@(g;JT#qݔUs,D2 <p8z1ai6O?8 J4M;$XӉo:ۢhp\dqUUͨkĆ7׋ $&dCa+_ X&tk^~Ln^#:rnXT)Ex)?IGA-tt:ʯ *btWxLm!Pժ7zMنCIU"^F[E@O:98MR` :"rQOkrxRۏ1ᬆzqܬޯ0w:so;U@7HXFh!pt$QN?[]GqrYPgH&Q=z1qnrj& f$NwWʊ(p7d(حQ!0h-l(6#&{/8]N5f2&)q;ԅ/vAjq ~&[QN*e6]gZJ "bV oK@*gPUH7qٔ)Zq`S%! R-V8 B}rWz3H 4z],雇 M,A}Zu Rw0]8Q0IbyLWNx(ʉ49P&E|9]4xVE~ toz ,6Hǘp[LoCT=Wu\ endstream endobj 1369 0 obj << /Length 4225 /Filter /FlateDecode >> stream x\Ys~ׯ@TG@QIWЉ=@$$@ʯO=3RdSU].zz{7-|™+סݒ"ҝ }}Ա}ڱ1K\> k`4AUJӕʴUOKjO:ڷr|zr'l) #k]MRߴDO?󣓖7S4zOQ:J:o'13/ G^ʶߢ FQ[]O~wkHTAp+ͤP^GK65hOwZO:V;LLszw %#D~5"@0$7a>澨N^"5@sY^z9ICҪ$N >:=AIB/6qtw_Ael>{5NϮGr4AGaEﻓty9]Li?r~R:[>"qI ~t8'4܍]0`:71G i"wbF??oI%6ْ J3*"t֣*2&qTl&=MkghYN (9Ϧl"|8_|줆l@X`а昮cK]yOXVny0ut=Π$cᄩEьko:4q%LjX~s"?vV5 HaSmZS,):6zM= 7q5O(u3ɐb8!vs4-d@4kMI_"d_PRB_I{ȷ1dEP+B kJ>cZS7H4u7K~eꆩ{qP+ %ZpHp"U4;401z-hņDD/)0W٥s8S-]g'c9`y< Ȑ(c>8r䴹Swl/Un)% `/a; c3/yYCy5% X4X М榊(զ (M]z"iUyeJXQ. *qNZUjU\s9jCꃾa7mcMiOI\}A 8Ҳ2ni]І].qM4Xl9ףWZ!9YֈvVܥY4VP+BMlY! CeV@"hp6B82 S V'++)@0vqF_ףV|$W 4TnV# (eW2A'Ò [  hBGi8 L -10> E&4 ,Ra%9%hkΟbD)Hs֮Er&lJ6:E͗ >"?/_0a-C5̈́Fr`ׄYr~ʅҗ=aogOj(iJʩhxR[ @r%Z><*&m9@S,-v{hR~?2/?j)֣6eT()&ZOBL Ӷ^Л:O3(idr;] R ozDJc=u"@ؒ|3nORp̋Ma<e g|4}E`vѻ4 _Ob}ivH u?&/]Sƚqcj 8hvBMMtx7D*R*oGU_*ws6GV>$ql"vuHK%yBbh ,@貝c;UuЦ# Qn4Z[3qYx|Q{! 2F P(713ncaӵex[R0JlrPY[@(BbDF@gRgg$"K+Lt&Oع%w>!{ ]1,!G,WH "N0{).XxU5t\ M<2=Ɩpr5QXEF0b&/dS V17QY8'hJF6Mx[+y*chҾ/\D@.ѼcL﬎ٔp9Z%CcNefX^ˌdvu&dWk`tKtm*y=Q\eIN4j3۝1(!J<:*gU]lZ I6nEfI*fH"brtHcL$d̴>Ml)Gf+ IDYfȖ(Ǵ/;Z}7r=^d 6^iy C"ɎjE׎mHv̼1PםTwfU-EuG>"izS'®CbU;v[d:'R_@ՓF/#"0ZR*uD2 aG'yAZړ(]{p%z_8 ^!b ްo#cK} Ѐ!*nܒ!nCS/+C\-휰us+OuH,:$VB'/}6n 4C#,ŴQ3$%Qy|E*z 4ԜDA]YN8G`34UFEx"I9Xb;jm@PU^C[Qc+TLc}g]坄K.r]5ME64;jPU@}RDŽd ) 4hS)j4ˊA [ ҄2Y a}x #)ǘPVzJ&8Wy}K:1ptb$i!7scgÎ:2:xXX#c.1Zoe>fN77uRUt3]o''PNHC#hՠQȣywfklxdۧ떷BuN=;<>׷Kȿ_)ȞkeTe1qW;9v8_Z(}v*s~ cxApqkY˰suoǕ1dk7_SU$;)FGL>欆wC 6Ig\6ufPHiT#$ISB,OOGrV&n'7eo> stream xŘ]o[7 +t]TGHJX 4V"M"Xat~/nhҚH%VSI5D]]u D&IAОdᓓTKE+Tu|9l.as+/o1 wJ8Uΰ!@:M ujuj`M;.͙(3PLk(CSCKG4H|έDL>^g)Tex40YbaImj`6:FcjX\&itaX6FKT IVPH25zjTՈA2b#خap Ը k Ԁ ѩZl ^ltx%Nw 6lL I BS# 6 ɩaskfghH3; <5`Ԁ iS6d JS6Ҍ{u 1g1g,xjԀ ѓ9#aICB2TwI绖yf3̔gߘwF9q 8|n{uF`iZ^?ŗ?|^~]\ߣ|]~x4CQB}v6Iu\S}"d?J{P4A*p<^#g8n|,zGJ]4`֎*-L0m Å8L3ft*8]_~4 ]qdZ.8(J r%N#L%U(`YBBG B it;> stream xr8e!6.!j'}I@KʼnDM$޾ K/B1 r|1|gyKL͏Y7sf&[uVcrYqY[8k]҅;I;EBOF^gج b~GJRW2nl,b+r)VA2K/6*DG1-'&^*?H}xKx |ޕYoO+$8D.-ii;,p,lpO׳鯧gaO%A|7gq䇈~"}v׷b5U*T-9_y%{z,$ f~CI2iն̈P#pn&qt9 gEI+K]7evA1H(z E9ǵ\r`=/.&/iv+S 5̣vp8Z5XLW=t=tn, v˖HB]S҂!Qf[[0H2&U~3'o?2*I*͗ kn|ծ Nku >9N͈\)5 U2l2X~,8`1+&Q,҃!ȰD4vо+8sitGU~}㧭}C8o@4['f綋ƾUQnd"⢩Q{,z,)6DZI RXawq tX<On')y&|BC?LgzҎEY $~.qxObnKgMBWzQ|0*X0TBO@$\ۗ>")QԁQd—Jc`"C9xu,gX3*k[ką-|z.ȟ?n_̕UFȓH!6~zcbYL<[%}uf1O/CiadKt 88. DG`CV]>u29k |ǑDc=; \&>|i  +֮+XT 1ā*6,Rh$ȶjrȋ!9ˤRyaSy32u2'RYlZyyi,8? /% kkǂQ9h ZU孕CzPLMo}Cfˋ []?Ig&i%_'¥ԯ9HWBIFLŹ,93g|.d jQ2h#SʅKTu/P[.GrCB:,)bAOYi}N)Z+aAK_VS گRnLn| (pRg1/Um\2 WéqZwLaJ|2GOe!‡L.#Ѓa1"`%YvKJzWs9d5"գ,uUcf?CnBF{W]y^^`4;]f[H+ LY\*dtܰY|\MN5k;js$ 01_Unj_ADwƥď6,X/l^WHߴnEF  jA7Sp=kwXV#!XJHw@ӄ[q'VM[)7T$o " Du(Cp (;T{'ZϠ(|^U+vq坓~ЦP%; O D>=~p1Alx|xzS0VC7]}lKy(5IW&j=sV'X^I;9*!w- q.3zHIKMu^=jLWZdEͮIVҺ[/3=O91$&m&gIUr̝rƭڶJV npͅ-s!U ;i9 J%si"`ml{H #Ǣִ'#DKm'Kt&|p[WF ew ž#Ɂ9+uJx[uǽ/ƈ%!:5^ױ98~|?~ JR6'bgs0VnƾJ#22A\@$mV4&j-귘!Y3 L4Z뗕ٚ+w[n+AM),uJ7<դ]>24%G^'d>P5%F-8>{؝II:?Ac~߯ǭ&iDɽ3*ٻ4.XzԵ(::.LwWţ(b$bp0t6qwa69ɀ[5ӑ> stream x[Kϯ%URYWvvljv}(jYǓ_n4I3q\aW ~~Y0*pZY̌jvq1C%]g_E>,t8ba0on3j<,VYE*kU]o[!` AD0`"07?/W! Rǟ} 3KL0m}AA)c&~rވuRPx*?aPg;}_Yڴ< ,Dq!\0 :2MIB2_S.ەYFFrY*3be췿qKơZ-U$3Gaqz}*80-Z-~FN}L*kpxO4j$T}f$XA YC{h-NvT ohYcՇF#BP&ʹLg3&N+j=00}v͋̈́ OncpKFZ_\e}ll8ƀ3J Picp*}U;pMsRx\7I:*7#KMjb&UiW-*&VT] .^3ł`xRs hC 5qA3I?*fhe4kv#_=3VɬS]R#T0X`xyK mM ]S{Fe~ gغYA;/vc DlX} =d1QO6S^SQerD:`n_Vm3a)T ]XzD& ZmU1B?#BJ3XA<z(oN)5SP"9DeY$% aOx!;31 Vdo8󵀄o}Wǣ; h;mʊ?Z ?jm3Q np& eB2t"lrC$M'0 VWK0\ 4V,$}IҰ|D^2%rY}Q*qCw)Q>ɾ>xMA3 O,MuװyD$m7Z;c6 7 yF#zKS ?m83`"G- qoC]V#ܒ@P.eCNdrBBTH},KCHoO=m1Գ  55kn[:k8\ۄg2Mԟl61 |LXl]!& ^ saoCh%uu΂-!&p;v7v[HY A%P۟%`"ՅgK5ߜ*Ba0zHǚ]KwSz'%MX0-ʸK~Nž9jJ954ۨ]}ͦwh͛=AJ|[08gzz2 -ZҡD;v8'qL+p^-F$’XuRl\h!V߷$ la1W/V\{`D$VJӡ1%"AtUOmЌ5mo?=@;{}=DUwgt +Z]j72վ&G&;+3fb}v1Rtbއv4^>I[:cX0.8Fafe_M0|y`+HnDYMj!(Cl /l}4' 퍚hgm)b *mj(HcPց^:-#]_|Ե"u^ iMDLy"՚OZ`]!]N7 U͛O k굵l7vE-A0u} >!q(ݠan {B֕SŗBB&3Ԭ Uvq!YRX4G Ye R n/ȯϻ0fd{OSP;ZVw< 3wN# ^"1m Cɗ@ 0@τ4J1Ξ1-1i<>9$cdsؘ/ejܛ.)-%\%_ۖ-amR̍5Jxޥe1&tQѼJ˪2}sB&P)3ʴ~INPJ캧u8kP/:aU89e@j۞p1qy.}>KgEnWMTzlMcZ}؍ǗnXb(ńA2U.i6*'IOHC)4 PvM Ko/i6. Ao2%j`M1E^Xl 8iӹɈDɈ:+_\J)׿bs1KFܕVK]Yg%  Mύb&& %]jqTjVK1r/.j@+xeuh9%~jFL)3QS?WVRq匕!/pOpŅ'9SuĿ׬ҿ{13:-4`@K տ\ endstream endobj 1447 0 obj << /Type /ObjStm /N 100 /First 999 /Length 2693 /Filter /FlateDecode >> stream x[[[~ׯc!9$`%v]xݢ㇍#FU+Q֛.(e5爚8΍ܘbRg ? j"NCSrb}lv*}pqZ0XKq)s)7|U+!s I}dNe`RK% U(;cH2UaN$vb"XȖdJpRB"pkI-¤ZTrEIqZY!Q9ͱSsMjN8 N[,SUt%A& YZu>jpY&18kG;#%B$j5aasiTmSO[:ǷMq_NeWqY69TgQ%4g-ČX:%J]Z$ZTv U\)sU-@F)z0 (UNEW[Эb/$4?2L3dHu> #CNFp^! h$' W$S/g*XAqe(PG椻ɀXB'!-vb7LK&|3NBgO]7ǻS%{՗ϟ?~l|*lR8`Eŗp @xVgb+7`Pv2E l)b+ a"( H! p+hA!0fbXAd3( W$n"Sǖuzd+_*R%M()al u&$YUEJĞ3RuUyx&Z42Ka /NQƼѢ0wg-7E @(Ìj2tEas(n $/ Lh L=I6<(ّI(8h@D5 ŻO&TB5_KsP<Єm̱v {/b]m 33pt C@zaD%;O+-pP k+"0wFkh&gG3w:yz:utW7?lMÏ!"BHȃ bp 28, 28, 28ଃ:8ଃ:8ଃs489 ipNh3My6j+^{U{4A4}q}go/fʜzAa'OEFMnPdWJX}ǰ#X!?A.\ɟ<7,&Qz:Ai9BRX&6k ys<x #vVZ˷?/O=@91a[UJ1le\|^0PG\+"#+n0ISPV*\8 ΂k+hp8M vE@xlc6Ͳ_yd@yḳ.S6"̢h^)ʻʌVYN%wl|#1a/6!UWX PbXH֫d."@f$PghG& $A AӖcl.A] ,1%R*B"ϰ&BJW^$LӎӒ?+7a1~rmɂP}hpq i?_AG ;gg;K/A yIOx+³v$ v *H [_~z3YMQp3$Φw;NhSn (PAm9wn;"Pə Ա=hAx؀ki^[)].`g'9Ɔ*k :^)i8Bpax.˧Nih%'X^d7Ps<B)b-e;^/hm$셬lֺ endstream endobj 1587 0 obj << /Length 4027 /Filter /FlateDecode >> stream xڽ[sB3'N.$L.=;$y)b# Iqbh[M!,.W!yX- e,ԁ"Nt "Y/~^B1W+T.ݱhVRzs0bDF,aǯxp%J*7fs%nh kxMMn, .07LJEY B!N8~*HGGR~[-P"h?Cm"M*ص+f:2* \SSW-@`o:R7 R17[\/_PIYG%ڎ2dUeUέ1 T;2):}jm'' tpfH4;1=#-sܙV˷#TH<LjU$@f3$ d{BG~!Utp Y%Pmyv)HgaG?&$HO? / 8)}DA,ΐ7/)GfkYĺ8>CT6S؆Ci]tYkQCB%N"5]w-)ô"/7TЄ<0A}ʕIERO69s⛦ޟqQqerVjtGyMx"NA:RJژ u huQqcؑciȕl*7m #ޱ34%/[jiL! ?bƓU $O.Xi"&o^Y.EE7@ FAPn_T`Rb] ݔ]W%1I&gÔ*%~ ux; "s) X (,1<ǁ<#Y8v ށ h ;O0Zjmۢoh!; &!J^W^E71ɻx uD uЃ0ρùTSxrr0d(sT>=-fhTEB5(ۢ'U{~T9l3BD غ9v0$̷17ȴجno7P}TEš}τ@04}I:OSG0Eޜ;P7j)ftlCtF,2 cck9v*2biɀ@A?o஍hNuG$9b!nUoVorLZ: TLD)k.!TIXˊ[* +l'cJ$.J31`BR 4J,6_BdnHi iTIKz)tHe-}e}d&Mn\b),4=KdT }=:4Xx˃h^BrBg/7C K.Pa KX340#t;Piɀ/'d4L@tܱ̝8 Okh!"6CiWdk(ٗșX;kd,ˆbX=0LzWprL ˛J祕"!/F"sچSKO-)N-)J-A;(C@W %K'dX hE^xU͙2w.|:YiB9+鋍 g1uj+&L e}lZ]_չwqنY)tDdw>f$1Qiy*i.Q)}R cW'KIQe |Ж.-N'f> !7 %ĥ@Ltaq_p^:9 'E Cs젓#%NN>vr+4ǤǤ>ecg4Lk'gЎx>gLr8&Ќ8ehp.@M[?"HEi@⊌9!C&IrL{9e,9V[8 ;묱x3w揻1f6vI~W.#/TT9.e7}6ktsz=kBWXG#>> ćظĀ_)j=X[)kL>]n;4"uQvkD :_Z >OytzhmxģXTM.>rR-k/߱C Q-5w}/CytWJ0/e]%Taۻ1J-i19lŷHJ[k*eZ܈,ޅi<>he<6 vf` q*L3LKoNZQo1OJ4$lUTX~ 9Xa-0Nw4ͩ[%Ea\&>T,~}.?`-0`݇o?~[3Ix-ifć 3;5K^U beǷ:ˏ˪Ro@zUͫ_! bi[|_:jtۡ{8g~O~9RN& E= jzɄ{&cI+6bpt`IB Z19QYP L݅@&ˢge nZ? n'OBOܻ 0BA8n"d_b¶{%ގwr;1D\N35@i]j2uUO- xΣ15iar&1>w縿h.˘S=Q8?UG-jB=pQ.%W9dEܹA c: p<2 [VNfVJe@L>KUâh ansM 'kx9V؞jpNFh9dH`p >-Z/aq],vlHC a"Ʒ?}~K02ז!_Dg·?O3hebd_oJ@-:j}1X  *\F,AC}{ >esf.t<"T(9 ˮv}fz_& 'f K|jζ3j5}041& 8+2TN4R6tWTEc,bdon,oj*k @n4R7R0 dH(+Q+ҺG(HU2Ա;5B;2ǝJnC{d3t,?JmcDfgQ_&æuLK>dT9q}C?h(:8s"Q1 TIՒ5`I88/[}r.;s_ŦĐ3' "`W`]e}Bi4A$ $bT|I,NWU{i66gdl*X\(-Z 2Ῥ:I8(OÀk͡1 endstream endobj 1601 0 obj << /Length 3326 /Filter /FlateDecode >> stream xZKs6WqBH|VIXV6@8F7жMDhя Vw`Eϯn.:WXnnW*N#pu[3R%ٺl6a6mW65ԧִλ)ʼ7;7zo N?0}.M>{JUYAx6Es86/792 Det|kx׋FpJh'Z$\~ V;nva%EAZ' v0cjPH^ݍoAi&f5K$?foOEj ѷLꁚe]e^1(E(Ws˃A` mGt]]&H)6p-2=N c & KFD/N&"Y5#6 Xh݄麩\yW8DJ:Q8xs}lso[ڊN37wl'6 LdY 8GܖA {k$w/éCYKE*>PJZ: Ccxm{b㞴 p+ѪE9w-C7_-"CdVRSkc;RUfBNtEᆕ<}^Y{k/= G虪N/0関k@|m##4/frnS.aV=0ʇ^Ո&rnDpN5uWo=7 o/܈Ey0*;z'B#zZB/9DcL>5Jp7a$Nu0.ʀPj"9ZGk4[c6,@8=I/+j]f6>'q!{JD椲=W'dOVƟ ,(qM= T: xVM5=VmkQiBXFК@^k:x>+}KKEx ҈"MokpÌmcpI~ 7ۚj1f69P}sv܋Z (Y?޲L$N}IԑHN]+)E#dc;Ie(qE)M#2q[B/%Otj3TCV;1#[sʂesJ%=ܝZR4s((8 > g #O2;Zفfvev֎")6">wG휟T9G@dy@0&mA2o:k~$-՚M\ i;e`ZڠK7nNTx$ִfכ#/w2i^ 9V*N,ݦC 3S{p{Zh[7k{8l. SSSd)^NjRoBەƕ[g%}ovT5ݩꝊ\gk"$3 4̪UǺ_eȠ16T,& 3Hcd Vf[33[C8aC]@h>S9! 8j'#rٷnj4Y3!aSriK:{ `Ȣp bL ,X^-#v=2$r&==ܦw<C>L{NV /PN_4S /\xXݶC)&Xil ԭ)hw*rU|Gl?,6bCGx)&xЮ|8?i^S,0y4yj´5 ܭ+@R?Y<]nh>YJc}kG o)t<{03E|V[: I*gYn# ٓ,"‡}Yy_ZkS\ID }.HPƘWw` CI/E}9r׶QG@BI!%3 d:rFkvkvj\Ypkw$ekw'Zz wjTS|wv"'50$5`'_ӨءŘ1+ CiP" a9I\C0$r@䇑Klb˜ rH:Udb.x3QG.QA"u;(֠)_'٤d-Bj\V1): fVVH_(8!dKz=6X2M@~6&5ܑ \ߖ9=kz ;e~׀Gc(.hZB:aNV`a9*hysЯr19hAx:vY7傀%cW=fl g8;Uy´]J5JV`j;cC޻ժ>ɿАLmev^[Ē4I,TFf㥽4 _Ɖ,R2y! lM1,Z\٘lr- =#Vʑ1 YϨONtF)2R.릿Fp1X,Vofc'ch3ũm L˅CE$M8_G>6-~e>e)}X 38q!qJE>+wl:KJ-||3J۫A@ǽ})tbBqS!fFA+?thY+HdI RSe_Ky3z$q)Bnk"(7|d1@+0c}t :Bnf)i:qOu }OG%k gy?vճjgbX6 nSQtks`䜐[s^HwJB&,fJ" |#Q+%1B/Uӎ^+Քan%xFLEпJr0`gl2'| ^5pGS︇\l2hM}zNU6d{mS )(駂iՋ7pP3SmN:/݀Hk"]9/ZVcj{&8 W;*|z:a5 .K3MClmf4p3d0|n<(nMQvfTÙ^ƨJ9$}BʀN)/o. J endstream endobj 1629 0 obj << /Length 3209 /Filter /FlateDecode >> stream xk>RfLNN{h~$GX"sٙH=P}gvL~|%Goo^}UDֆLTHl ef55Mhy_/z~id|Xfo*x~/"P N:{dxG>"jme pXh`(lVlA۰k=H~-s"]Cb6(Lɯ =€/8?p  KJ֠#i-rW58&.۬[-N/y~CT.ʏ;PVm bbs!O;y8l X7ŀX7T86fo?-AN>,)%$3Eʂ>"E:#e|\jo֗pP  |iYXf u}||%SRGUf(bͫ=̊h{)Ɓ~pۋ)!Ħ-iy;Ħ0@8zM= 2AQ[ZAcwfG$Cs^e T iѱGTiܔвS"mk`[Qvsj/wP5T) ֑2P;yT۞Vڗo`e؋ >$5m(.8 Sv_珴Q]XveU6EԜ&oMEt`3Xwo'sgLd_0KOմ;x*}ϭ7cn jkG"C$`#A&.Tۼ\yi%sh1@3Hp;֥xN8n(J̩6 &4TqoR4nRkm, ?sX D\tHy"9WPn "w#Sy$eуBa4x<}Aj>y8~Yفcs\҃W:9uF 3cI^HˎK܇M+:R@~h8b?zxXNCoE~UQ}MlFVfƇ;9'A^y5 ЂE櫬p]C=|6@πz^)C@lZJ˾mM *XdO+GDVO]]p x7>NXi#`#0~dz`hThZI̾lXt0Hʀ8ڃ0B/tM7LBD1& Z9wNΝN—=5ఆv}7((1~w=om!*S$f6q(d ٜGkli3i Ғ &I|2IL+dY lN+'P*S0P!a>ٰ~ƅ:(ޟ<[pp_NdOThl41GŖC tݠԑz:]c{_ڱҎFƶtJ>B|sm Ļ}$phI_$gjd_ pP‰2g1#s<~]F!6oEjAGGʙzACgaכr LY~ Vf#N` (m(ir(>b 9Я ikXU f (EOȘ49L{t[;:x3;:(}`k 2'bI|mzԏ.Tah.)# FQ@g5d,۬4%~[P]v$ 䇳99)21.I|M~L1ߵT[G0 C+9D_E -M|.bg߁yP&_tEyT:=nDHV_ !9fjӿrK30kg:'ͅϤsM$#26{'=I[i,!:d T9ayu MmkiOn4^?_{w8޿Q3q {.wVp48f9i."@ s}!{ry=3Qg0?GiDqdpI//'M2\L=S &5D Όf_6c^b[r-GX*Pjn]R.ed=QrAҪzE)ph5Ur*- /;!vld#](a(> stream xZKs6WeFUodkgT,aQcpBr,+~_C[1 h4~|q;pK7w~e]JtoZ:f5m_:.'7Y[uմsM<)XHܷn`!4iX Ru[[h{έ%&3+Kh }Λ0'/u[şY[T[vJ-_>[<Ⱐhei77p EGݟ7IdrrH\q窓r< GװfyKƠH4p|H+rUR/wYSF80-8krYq!'qN6@7p0S B dE3T luy0>A@xl_a=\ LNNSy/p7jxRYY9r6J!#e/]V#ֲMlf8f&däqg͝[k+0#t+8DzL95а͗h3t\gMN-oVbagX:MP'hj0!v#CZw,Z17^1nzρՑf QFE!7z3Ϛ[h=V 1>ߵD tg7^08/ʢ HdAĤ^;@q +~sEP"q':/a9 PЋ G, <5E/_JM9/NC a.@Inj`*a]2a ?%-h'Lt@P()3iG3G3u#Y"@.^=`6f=@<Ml+é"6{:g v yS jg^W,IbBNbc1Ԥl@bjʀπ8 5Sf1@bj$s]H`'A#pte @acDwòsU ; oHQ:Wf5.5ET._9 0v.=V Ƴ91hGN iq0o0J1t&?U(/d]Sq$ _^Cq0Rbh\t=bZ32:G$6oxL΢Jŵ+jcvQDm%S ^OW?7N{FPhબBU˔+TiYAR3t$R~W']TS;5<,L% -06߀eN:sB{ǃ_6UhѥEAXv"<ָEekf4_S#@=@J8%vcz KTgxgTw"߾%P0_.#"=* |ʃW&EqgCR8YW6+›Ps&- $b{БqrPnBpUoGU_Tw>L`]7r*z0ӻj|Mݐf0uliH*:OƛG^p"y$Omd8)* G@{>3 q=CEBLa>2ЈF ^ȠH5P50`=3hxɨ00=^q5A.j&I1px誾|%'=aJ0%d0ghJ^M)AAUPPTݣjDY]/lF<"/qLqRq/ X_^!+򥠗\A&|6hٽ)=`뇡f ?+CB:~or, hg(j%6lo⡊8Гz8_ԧbxHxwTU6~}}򥧔Ǚ67u0Ȯ*0!Ky;bzև Cc^^&tt„1ƍCTT N=H3ɣLqG}ur]0fnIpR"- V2B70Uĩ2DXU>Nk9 o0ygB, JC{(i[@P̠0<MQ>|2Mxe~o;QTu d endstream endobj 1558 0 obj << /Type /ObjStm /N 100 /First 989 /Length 2633 /Filter /FlateDecode >> stream xZ[~_Q䁚]W E%by89f3JA;h$ο?W3vf;Lqw\jI$H4-9 B:Ds(+.s.dG*x+b6)P ^h[f(6RT &J%ni(XD%BRL|A\,qٰHj!QLвp<Žh}29 #|.W b ?7Z\ v. 6$cbBi0X oT7`*Fr Wku5w\]VΑ!bmˮHt3^u65h\{*zХDzB;HM$ӰvRˆIu"E B 7$IP.pd+r8shonqb>Z}ݯyuߣŽ \x\|[X59k1uwũ[<\=[w_O7շ ĢznP|k۷c qſ (Żׯ_dM;'6ƍ0Ħ1G1/i &'4n4xS o1[_^]9;_:ۼsr^///vޯK'xuF[bLeMܾsf'&>"-Üi@ 2D^>9!0 e,>b={HHC;&/cE6@2DX֘{d8tƍE 1 a23 PL<Р{n|ab_h e}=a|0jFmtX谴mmii<39َ^xBj& 1*J&7`nQzR}H|ij㞰S9 ux<-lpBds0PIGioCti a#rPC_( atƆg|0 bgSr^;j<bOL6UM>TxD9440)ԩܨrjS1*pe̍"%ʍ`mS3kYG>̃(z=A Fʕ8ie,cd#Y:F1u'8.dRP,+rm4y#E<$\@0ekx&?.r>'k:A{-@cfb p`A"256>9t@ aXNB\V j!4"b$H E,XW;{i.ݎMyκQ" :6#*1˳7 ?ga lA;sS4㓓řiyIgUߔkd&͜(8MDVJEpZ+Tn,uܠL\e+*"Tr󝢇D۞~f3 E7Nw{ci\G0fWrt_e}< m @#0rpD Z"Q@ GQ ={C ܣ*5gk1$6bhiWGR__) Lc؀)6 fb6'75$)k&(r g*֊ ~k'l(8?I niD8> stream xڽ<]ۺ~)b٢H =inE]5퓓;ʒVvV^>d-9 #f31?߾R3OU:]Ϥz:H-gOsD%f!󿔻}S(1?x=wb{fa%5s,+eib8޾;Gxot"$xj52Vҝ%FvnZ#r`ZqGLe6CQGZx[O"T弬轃\|] !p"|9kj_ 6˦¢bݹ d*JX`,fUV I۾qSF8mPB$&}9I8G' 18.y-f/'R/G<,mUGIyFtZ{@kų"wfT4׸ȂbeͣMM5Ƥxwa|_>1$ #6Ųnz<+J4D-D]ds$2]o65/ LA_n fP}hJ:yTʰHSP/ձjV+H>YX DGR'WA)qB~&6VR*}Q)24Qòva֦Xf~ |:%Q~Gz\JJ 0hK9 ꣵk}Y|Ny2V ec.mOy/?z?$"e&gY W?"f+hf_-zG}z@IDge?ߎv{4j bR|ѶG l I]qUf̊,Nĕ=LU݈%#G:W֖UIhxF1Z@hތ!ZCnilEϘC\[(R3g]]hRCm+D;B'0؆ T ̊!߀:X# 52n`~i x!3 l| ,h8bhc{`d,6azLGiэ *]{4`%mH<`V%)'(J'qxڤXQNxIAȧ6ܩg&}AlD(͔DGKY\ -9j]MN5Ѽ/? 6boQyxWnכ'% }A_/;lHID{-) ˆTaaB P.uk{lGY9:L9&J_CD"XEw>M 瑩8NmC6щlcP@Νc]pQ|ϛ&BI)WڑnQ" EeREA]֛YjU.F}&1عP)홑VG$ 'Rr6˻,3z{`! `,{ɧdvinR0MuDat`3d\>mY<~e'$gg =D_Sg5OM)uŇ-*1vL‚Hp(E?Tڀoΐ]{Q;;YQfNbsn ,`|7ֺdMb\f5`?V\ XL:ɜ|$_r@|d4JpН*-1- re3StƛhZ/Uׇʰ]1x¢/i֭#תEOPЪU9Ċs 3TObPofb|nB6cL:|ԁ80l؁%sh@WLct^ 0TjY@=ĞYf;.Bz`(ۻNT߶ q~GIW GRfzL)ԡXK $X9B/N-.~5lo*6ϣֹ!NA3X,iN+,H#;Ma޸k(,)3n͇7"s xŸt<C}/Ҟ6߃/e(,’!k*'Uߪbb,=Yӌ\,>SC~h>cK0 I` P7J5𫶚5|:Qh)y)fJJ.\wRo.;_G,a.rX0B`)}xcou[Վi| $ضh桜OzM]rõ84CAB'H)Îюn^Sc-?K#ȃ9LwVp.c4 b\n@u)6EL.\Umơ5P+ ^9a!聲T5ISgA1( jvR1kkK|d&ufz ۡ-WE'Iq{Xc~p1p{_T| {y"\wCnYE^'o ,tx*zޠ*xlC8A %W:3}<(m֔LoM_P)+TA]ᆘ$dMUJWLPշIƍkdbH)[RC<+áaPǏD> stream x[msܶ_~ 5!x':MUj-rwݥ7 s"蝡ɺiyKmeÐT;Dj`gW/ Kw8;ЩF-}Mb(H֔/8-8u(  2o$ӬSe`=tE JQ~zXgtz;SX꪿ԚT:9 L}XN\T F^i]η-Ѐ1 t7VnGGsByC^3XӀ= +p2}Cz2u9C=HgWL{sDUE#‚~]Qc|BAaP yL)X >\9J 3Zѭe> RvdTT>6B$aTٝ*.Ш!=arO-_sd@fR Y2ZniX a+?h'˔5-.xixzSUh/M tۥVYvř>l.'6!1S V6R̹J^*>LU|}jyyqcÿO ݙmN`Ȓcf>3lpsAfBr/ '2B]S<(Qc5,# Y˞rXf6!gwÝ ̶0! ^A) 2 y{.R7ڲ!Zgϣ|\}jz0!Dɼ* 2ES1Ua1~=;{or4#p%009х؆*Qn *5Cun00ٝgTst1w,Yag2gT\*P@0r=|W/J/Əge7g,Xv::Sw ;u8w4O0G:9b"ĩvΕe 2/3#W-[\OeHq/BXx3"}H#Q5Y-V2Vaz=zUFSKf,e·>cR!0'1R "mtQ خ]Y\p[}R-W ܠ'B՚p?.f@5TMe GKc(IzVOC u7;E:x3^2SWݼ=cAXxA9#^<4i߳ЖȄ `$%aLSО=[-;.uF1kw6[^(R8낯~zXWzH99~jx>5(K0ˊjנV B5Dڣ<S{jndk&!,GpIf-j@jo7.D%H@ĝo1ZYGט 4vn\ۧ Dr6_-^`!a0?^:'=~ n%]*SZzH @w5u68Ttp* X$*ݣCjF!$z pHxpt v0\LB|&SIXKr;f%ꡏu_R~&t_7H3s`l>cC=tx{gJ_T q'wRǮ*.}^:LX@{q}.]?ЏϜ7j,a+զ]GV47۱ mFCxZL$Әz\ifxk3$#9=A A$ iG5 9hq`<ߠa>k6!Tbs"-Mʶ: aOp<dЯfA:en@/˓ I zfn#y`|#1DncO4sy} ?n7z!gyiԏw8 Oq05Ҹ7-T ǑNeY:eN9:`t?Ws49;˜oUeA(muن:DeRiCP0*h/6t1)]fPmH;> stream x[KsFWUp a0/U{SN։-{emR@Q&.ZvO%Rd/{~|ӊf׳hó/}o, Scj& 3PH1\~ ~~.>o( nv]XA-Tom^#sjoڪWT6m9)p R 0cXzP ~\KŇ=V3`>VFϕ-\5 H$: G(.Z20-)%w~U?po{FbH0~z:( ~z#鱺@Aڷ1VTZ*#bu)GxiUIPخjV-Vdf!E]S;P˳I ("؅>LFWYW_mOr]$/ݲxlw8q_.^9 ~IRA!/É Nj* >~=lAfjK%VY@̧;Yx?ହT`ۓ @QJ)H {՟Q6)bZC  F99uW5(M,2o3< .H{g )+A'C`gmO!*4{%Y6/·!=<8Lc UlTO`؂4.sEPbn a.¶>uqnk)V<# OVS! !:aZ&-% Ub8bN0MVMm]sBtli'PVL*zlɠ/Eg]:"q[. `H.hB[C N)P`ŒJ,k@y:▾81pvF#;0I"ա4W:ʇZUzXC:l(^OsE'cs ^b("S26}4(h0 ty-@ѫrq L+p2x z`vJg ioTN[5JQp8jws\nl.Pu(XEDh Tが VʂZصt QzxcxuIFΔFs#XC3qCÙ3w;-0`Ap:5#Φ Oưz3^?m% f!Y`']n^~SCeøPF~9hIЧk=QHs ңrlAUg` p:1  VaJ~ P)d>DoHd^3n9c\G9yDAQi:4`lK}g"WR׌4`҄$gl\@7mXa$`=Isw0P j耼58nQܰ/϶X۳/T*+վ\eu"$3Jآ+TpI3No{~w~33ڑwkΡ*۬(y HH N>nvPh}|ǗaY>1*Y_x>D!A%j!3S3G$t9z9QD9^?_ep|hEúi?(`SnL2$!uG&tϐA8æhPAqE5~ҽfhC/Z[D@-C5F N~hC[PMpG[ Rc.>(HN0o7`+\7`,+~0zŲNxrt;c%NCTcVs/= rBev9,]5tzzφtDD8z8f2#M6^vvE@0t #JPSq( Cb;Ŷ#Q0|.,}.@bW "kJ|F෻Dг>zbpL"B=%" JgHlc'0}ה'^ihqqч`yЃtԽ$x`8¤..]@P='q>gCz9M{yNET6`F"-i'> ~9U̩$Kr֍^X1z<~`OE/) |Lz$;`$L"pPP%Ūo$/ĆFPI>:FKMffJ,VNKvCiZ QEI/"9h"svt/ ;vNu J(x[RSʢcCba(oEEGCjbdn$dı(,3i€Mb}'9WΩ5wqB*`IqK2 Cl)y {JϞ5MFpX1Pcr5'*y5 `M,iiqꍏ9^2~ >sC5@4D'_}ޱڞUVA1SVF5dY$:d_iNDTw䡓亇Sp He!PGajОV .T:)fO0쯂 2z+I^jBWTrr}0av)Jg#ùz(x-]>}S5u)dzNF!zC8jF˛ϻ&z̎DLG'!ds =e.u8UL%Xt#p24vx(,Ҙ;qy8fY@ 0T`Qqz ̗~"cFԡu^a ^x]}9{(=;W9b>33Ġ#2 endstream endobj 1651 0 obj << /Type /ObjStm /N 100 /First 998 /Length 2691 /Filter /FlateDecode >> stream x[[o[~ׯ!ݙ`oqK(8~P65jL-J[9{3;YǬ悋Yd'M TD4S`ɕRA5)/k1('=% mTx*ڱgIP h $9JRrb S"f܈%Ѫ}_s24L(:N- YRR 8 Jj:rzL;LjEm* \F1gJ7-.i! Z~m/]hxuu'o/~X3{v'onzyyd|y|t?8Z<_]=GdNp}sڄ3.3 ;͂v &~NJq,z rt OڽROX]/ˋG{է˷ˏڟgU<#&ٓK-l6v=#"?=!I-<09y`s<0 e`.s\20 7oīW^J.>#IFҤa$ S^Jϸ} FlNɈ f'L!`?N̈o02 #نdXO:ZȈg#UtP}CE7 >Lg\Oނ=<2A)Pz+ٜGMgg$B}$1dFkndYGV5-N7F727~m2ͷ jTgc``D])g*'$3"Hy2tg+HُJkz2ec> eABPJ[K) ZnCNJ)/<ZueξLjvB2|L4DS2tRd=ҋXMٍ\-^=ɜ9pDnnLut~FblS躂>f1UNN 6oMܒݣ`Pw6C+T!Qܱ[ P9pŲI}znX'(o=v̮¾l]Y1-vNX 0NqNXͤ6Im4h&LjF3MLg[߬x 6[/)Ҳh4[68ؘ8j$ zqg/ΦLӋ蟜M΀7 >k؈$_L$4ɭ0Zd4ʆ3V93o3Y"<3j^f]e \T4pPP2=1>^q@ }ʄ{`3+,#@~= 0p3\&q)MR(8E愀(b/w ;Σx8{rZGOPRy\e/T;DޏW&՘n!` ~7v~ܠo(c{ F;|:}N}c#hzYO|ҳ.Rݚ$oUrYɎ&-e7) HKx 8%ߦrj'vp<1@2塤X>7{OZ3ս:0! zJ nLpCLaȪ(2u MQhvsro[]x&'^:$~Cy#K%')Uc^-)vkiډDqGxO}X!p endstream endobj 1789 0 obj << /Length 3869 /Filter /FlateDecode >> stream xZsB/f,"vpIL2]r4I@K͉D$u_],@e[N> >,"Y-W/_~'_j9˴ .4Z.R|vy^y$zSmYu mXqΗh<+K`2-x_v4h[M~GmSYx0::u9:ϼ1[0z?oEVA+<0ƒeUW跟JKWYKJp Pi;KM @$8, :uD-`jïK)kU.qшuln'_")aǪ@͆o6E{_ pE| ] Wsg- zK=8xRNZ~`f1pL0 y8tPňl^2]~ӕ U>дwD!~lh!$7\f'/6ؼl+ҌY kbaBsd%9~˒ L&*1"cwu+DQuE(c^?1Rtqa7gIACSArHQzÈ,oVpdǎڼC$(w )"BC؉+L 4 o;:2nN߃h)(i/:< ]Ǣc0.ȰgJdpdr":H03LZ ;J^J^J(rPSi|S>\p)@dž&TG4ǎ>{&0GM:zߛrWvD&.BJq(lEcWpmQm}۽_qpۓXkgxr+W4"'[[jLP&jﶩ,5 Ԝ\eB՗ryXDÑ Izdx8mUL0:8i02a^]8@f{a 7Iϊ!O;y*F]k K5Wdq6/Kfg `0h@]ӷsA;Tu[Ɯ-П| 7NsEF^~s3X}P|HIb>s}BU@RK2&vt*\6ڄRZQ-Ffs-msD+UIa+"\rsL ĭ`6; [K"=x+?ra4O7k.{ z֋^x"T]oj?L3by6C&38I:lEL$=<>&Iʦ؎F}R N8 HW@oK+?C̣~+q%4{8l[$۵Z{ـ7n{kMp9Y0OrOdܠ_/|cxeW);s`<@d׈mQ3iQE 9յƽJ.7sø2pT|Dy!=4{=uAz^6^'.-0BRRa&ȩ!%)=EW7%(Σ27nq9 p]]\:̄?{Vp.r:;%l.]IT(@30 LH w9~u#mG=9l\(I/Js@J{\`25l }ןԔqb.}@{\~@SmjɴVc_n,}*QEk\9, =]oZ Xep]}I k}"y2/fvNX >\1¨ ( "y LRZ| ˿yۉqL5}L#5%^mrixn`X6WI,RM2]3)"fz8.Uxys YC6PנX⼭(𺢘=)<R=L&$DJ~e~ —җʗڗ/>k:+u˝O9 RE)- **h4')65Hg ǁ+ 7v6tA"f&1,9dUO35.OOpr % dISr\>YR *AO:M@q9Bރla%.>?MO39ӰE @B0rV endstream endobj 1835 0 obj << /Length 3291 /Filter /FlateDecode >> stream xڵZYsF~ׯVQU"2'TbgmR[N@P(>=Q&v!_B$ f!MH.RvayS՗+宪3l6kӼh~V0^bѸt)o]VӬ"Z_{6 8ܮ?yؐE-e&+MK>Mi]J}.S~Gl5-R+Zď:njrXi) &6r'I[˕Je~ Ar@¡qDzTvyPG{?0wp3틌F%u]VٖCf;囻)$X*Yރ@KVD(RیeuE<ʴuQm>VjaoKWvh}SW;ZNxhCp5 6# ?xû/&jթ/o_|{}Džę 01\yH.>.[IwCw q`0JJjoLOGFpڲJ5 N4&C])$2W={=atug۬:Cvh4[~Fƌ ,ahfc~!:~ *d@76iPU EE; UMK&6ÑBA:Pd~QfݺQXT }֡E7uWRHjȋ3*3KH/o|lo.%ͫ{ ] M×j|]|J<櫴Q5֡4_@3 AK_I":_<&g`|wAWeӇwoDK8=xʩhʂ_ɨ+k{o*3n`{`;8P}%'1lŗJODx[KiG lv "䆆l=Y3;.0~8'O=7M ֶ.+d5r5 )*m&>uq`p0י_/rrt':y!r; Sx:djۡ =p-ۆz. =mn|wǡ]Gava5O #%h%!8zzc~#pܝ _2pε  K @b x}F}^DFHkv^P˗ES$%G:>b&N~C3bMcQH nvڟtg%)R1r?5<8D!oZezդ 35t/r9pYپێZ(B@7߽iv٥Jt  p$bcXd*la]i= g tCF^zKl@YQ1}C*4{kD%b]V gSlRĐX_3dڤXCY 9; ^0A]$Sb #zKO E2ztXdnOU~em \3@ n<ӌ͂Gpv+肹8F=}3~%$ZZUDۊWf1)FUN{pNܥj𳌕)-EgEgGU!Y}XF3/xߣi9O^ЦXrBG؏OVdCCP{)diT":4ig:'&)I`M|v/b (+4R4K5ӆ/4s i U7 TCѦeV\XH@ٛm8}/>ГkfcS$ƞP/@l O:X/|j$jmNb#AAH8*-m衆IݠRP'jhS_khVªqym `[giIS7M ?2ν;,2XDbX?LO7QT.+zQ` ̀ A\4QZ>/(19ܞ5+`ةwiqNPZ:W^1}u%q@O syLdرK]"|_8YVh8[ƠmvGp. .?b ~d 㲁-nNj81Xju駜 K/*)Ք/a9|bOm1D?Q/"^/Q~ | Np4p|}6a$W0jf։0+ @mgwfXѮ>5$u@!/xAL4}lzĞ{a2"| sǢ3X~ID縲HP-T 8; (GTMb& 4/ð,h^+ᴣuvqmwDY> RMWz5! ;}]i_wA%ϲ'e6}ٵ^1j|a+[ڞqX(V8ƾ.ysqM%X&8O,U6-:0 g-)ۄ}V/b?Evf7BŃ' ϑW$oƪP-1lv2߁5#or  _ c-Lι3?yj ȿ*Ht-/1N#4?,ƌa4 V{&d4ll.m`N}fRgu|tti~5)h5ۥ߶+[RB&L +}$h Ovbl]9w*r"[-UGDYI? Tp1f +hm ы̉z*tкOW||RJo$ endstream endobj 1873 0 obj << /Length 3647 /Filter /FlateDecode >> stream xڽ]s6ݿB/7#X8$@07yh{i'棱;D[IBRq_X$(ʶ=X @]|v7.k:,RϮogB*&U4F1zqtK9_H>ݡڢ*Kͨ+̫mEvWٖzq_șh[O8UÏp`ѥ)Kd ¡WgMnll[eeۺX.缡Gʙ?5ᇋ1iĒ89Qyah_oŽ7] ?oF;%`,F)$38B~XjyP-#3h` R`ģ@0bͥk#ƮUՋeHlV+9B/A.nݦ7>ۢͩ MͶwU]]̖uެד:%HkKI|*2 #''۵d] c"{ C$fy|]|NE۩d|;@#M+E 2V mK{E۫ oLR0qՇ7jF%8;(}Cuej5ҵi.1KGi9OIZKD˜SW`YfZ1 AmC?+.`1h!|]J~ǁ@pa{o(%:MM>=,@|: i(}IZ;xҝ&~0$0OV:Lmh;YֲCoJͿG_d-M7\&Z=FiGc .['_*284 2G*G]0 M2pZ˛W':R7G?]"[4[S8g4J+8 h8$@ɜE p$jgUKpf xQ9ϱj\31fGj Ǖrޞ=@F5\P}LaZLG" 4  6Pu;zMgKB\0;GlElW+Pm>ui=!WȎP 2Yт.SȾ:a8 G +|\Ia?,">3o&X'JACu t*NG ~tOӳO'H{0 Oӑ$I뻸GXZ·sLs' { c`uiϛNƝ yWm+>t(ܭYֈ'lVűZ74}ʛ|' 6i>K?5A*l,-[xXUҀ &%QoH(N(>sJ)D@CAabbUkJs -Õ,In1 h5Mk:2%Ro9Ϣާ'T-A ĉּsUɆ׽n[وUŌËJds%F⣴ ̨VC]#'Z_}:tGpxtSiK^n}~Qo"D([1(];)BhqE<Lt@@Q #O#M4gg^CC"ݧx~,6xͪ]˳uPT#\np"}%l2[d$$%0[Ӵ/F«gaIO;ݧ_NNk&..FBrhZCL.EY%0:r}t yPZٔ°f}۬Am卆"h;9)'doPJ&)6MĔA2"lc߹$3raE9`ݱj,g9@$ݳRp N/K“$ db`H']G[:XQ">?b}ov }S"쫂32"vHB$ ĩ{pͶCH>5B_Jk Oh_ʦphOj̳/Ȯ+!LH0sT]|}V c& L|'e'Ӳv/8OrU:G»u{ÙKqeHhw%rJTm]m  N4iNxfTo+)/(?0 JJt B҅N;;\L̔M!f; L$AIN/ Ur?BÊ]wuƒZZx /Z@aU קC$m\1eyddjFbuIo α>\zyG=,jMSGXT9K-r/اiP"<80~F4o(P<+~ێwqM41j{B&!OΐAcipK)/Cm_L p f)ZZNX_j%"$l)Q']aҥJnY&DqI@ݦ,0%ٴe[xf/ DE]̦:lה0<; 4;Bem6fYBg )8)EHΖ^|-n32_점o)o岷݅o =8nqghhe'ҭPuj)xQaHƮZaJ_f y%z=7GQeVCMoCh_j7Ȁa:<+V<U < lrk/Y;uV6D%wϘ1[\/곴3 XB:XB mKKVa `(,d}@|p㣿h"szt7y;1Fodϼ=#JtwH> stream xڽ[r}Wz0ݍJ*I%('ql=Җ͒U˔9Xb)*rmB qh)Ų N'lT9ќ56bpIrB"JmS\K4kx: Pk"A*jɼǡ"^ HZdNE8@N)*H&0R-5-w83fsOT*[Y ciX[]n)Eg".&|u1gQ҈D}I..I\x2K1wyͥت>MKc4 |S%U.kasO[xV^ ZO)s 0V>O?LU վ5)91Dj.ir]mN[5 is=,yڵ% t.R ZTTB\ ĜmChJhRkK0 =Q)&4:F 1\Ԫ] qV$s>ʯ ][(Νj#^2*7Lv5w|WjxA["jsLƕZ ޽٫|`vx_?9>yw0{X/0 ϳdz?K8Yޚжz9wݻfn;w-wb.: /^MV79ق@L a$*@cGs$E7]Ȟ{VjG5=)Cė LG srZ6t@Mo~_>ޝ>~'ǧ+߳GGw1,m]p/?~\ #{ƒxxz(|C|z ?l/a&>fÏGo֯8Z?}Zp:Z͝GU_GpI#x~qQ/^,oX"#7{5r//wNsqOg7ӵ=X|r]2{o/w&4a(t`*)E8ϥp)qX% 3"gi0eyR^`l ]Ǔ0Dpƒxzx}=ϟ>?!\ )ψaxb@ -Ԑ&AYvf^ya4 #Bhg@ϗ}MTϘYi !'bp'8xNH/0Co>MbD1nm@&ߞBWϸa57.t ?-Ѕ]?~06Ɇhu1oHE5] :QHgZ0} [}htS08  u3i}`b35Ed^~FѶ)N!8'iS+XU|2pl(ta8~FvHIO5=*me  !ŰSHEDb&{۹"и iB6@FԷ -M)I0P# ڥ9^۳wM RȖZ' ; 21-웦IHF\Ĩm!"lV'!t'!t<; *Wٯ;O#SƀyKP~:یĹ^bڟ9xp3MT] "[Lk:uNaǒAaQK͑[نl| 6KU:Z Ûs$7v7b%&IIϩ- nE nN 8D< 嬜_If%û?͝sޔ   8i4hѨ1$ː,C 2$ː,C 2$ː,C:$됬C:- .Y`Ć ԬqbwztVQjkz5Z`ycp#|0&#bpbBlk[1ܞ;WG`w86Cma} 3%Bap)< "HsB>)`db"@wyz8E_LųpLvJdY6O^-"c}6lZC 4;-c0.K!rMS*ۙ2逆wE 0r0f* bϻc_P}<{p!` W/L8 # ׄh>eXҒ˳0gOÚч˳NN%EH!;S:@]@B]~8#Y2m`&qeC0MIa 7 <$`30a,,s(Y ǢH4+M\[GHcU%8&C黗L4vIK'*kfYW 6m mc=E"`X V[D?ItoǛh8PxAuW{-e$G=F,0B@&źP3E}aCzi? 5S2q߉qCAKIvٻMm]UtpU6*\ *nc8c8Hc4uQZG!huQZG!huQZG!h5OJJ))4D.EZ*XMqw1BɬdZKo\yjt~8\]cY-"QH+#IfܘёEf1K 9!Ƣ+4ײ? QCC2 l-Qۺ> stream x[Ks6ϯe1LVI&;5Ɂ ;8ίn4hٲ݋Bxv7,*0, C5Z͸,5ϮO&O<9:oy1Z0O~i a ;+ UAk&"Ǿ?~ t&ݏT2^b*V{kEcsޞJ1G%*Rymw$g2wNU/L*MVxެ U"ꬦ ss)Gi}"f۔)NOD0Ҟl٦= Xp gJ)Pi(R@FPo4Ϛ;j-Wm?P-MewK5Ųv?ns W6D|[ SeUS6KfO e,XYς X\_*nz}@]9x7؂6O;vc*n{p"!Kkx℣dދ*FwCnHhԔe^)~]5GHN; !U2"YԵi%VIJ UkM=+*=AҴ[-I&1+d, +_ޘ~\.n{UfTȩ, }vf߼(ъբ n]E86'ESe jٚjk@x2cO\YxK*hSAM7ڷH̆CNP!b,MYe[4|_~db v̽VmdG#>",@]',q{ kN%I $3%2TYZZs2bB2KNj?ÿz+dB03D,4ؼk0[`uL٭!._r1&h)"y.]VѤp_h?Aih;3R5pχpU(s4S -߳MڸegEz72;7^GOnZܑVcUv'_ l"7) `X._Rڍv6Q`Kn\V #5Ȟ u1DϑE :x?>*F 3`^k9vO]cvbx[bT2gP'E3qqSMf},]e;]@37 ˢ*SoK<[VR#n/\ -!~mDGޞ$~-XN{\L4e# bŇI<ǰxLkR}y`ߝ#o%0DT \$'E r"PHM~ײr*ciVjdEݠ|_4-3xso3^4·[3s^#1^ 7\ƀ*_`:.Bw?uߛ&ob@Ũ-xyX iX%4$؀M0ܸ_з܀16MhӅcEG wm^eu d)r?0J2(7MN<~^,aa"#o~7[*,7DcкRNlXay5 <.mk rWU=;`/.H- U,>&V/Ikײ~͊`Eb#~Ť!>󖈧  "2GP,pTp̱g^ & =٦_&B<1A]N@1P)bB5/ޝ"rDQKUcT*)-с ]p6ꢇSd DxT$~W?OuNm\bF|R~C1̆ N)r |@8d<Cp+YLv|x3%c.#X?t@( )&$C_S*J ~Ij{'^C{B\adm8E )\}a\M!ى捓:"{-"pRޘU˛^fjJLS6u9mbcߧn[h*D4z0* 79蛷wFk_Ob w=8.'ljS?tH3-䓟ɄϿ'e q~QtĉM/R.,Hn٨ޜ'm$"ҼCbG@Ӏ\NT޳tz-n}@6|ۿ߈:7 l*TH.V:gרw a-.uY_I&Rpj=![-%xwx fõ2{u)ԧZӆ|V1+f"\ ժ2q΃f2!VH&\Vr;q)ډ޹_IK' r+{1Vuiw{i ]MJt.@]/x;7~o"T̸A`V<>p8@5V8<9=8>i{MpM7^3z @`hCt9N+^vR)@Aܹ)K癯 [knWgg7 B7eElU7E,gME;,3urmvжOSh8%<'Sovsu!">vKκ9 &|u] [?z~.zھXܲ*Z`:&M0к]~/yZ5[6 ,wg7Ɯ٤[~1՗J> stream x[Ys~_Tɕ7ȭ92&Lh%u~}/Ѳ5M^,g ng|3>ճzL˔3&]f^rc;ޠikwޭvvu;ݼh.k|{W~ﮞL@>3)sbr/|g)>ۙrLHY s { dfVf{+ٟzO8?3b\q gJbGUnUßï0s+*8Ձ}].Ε]H>x!<+6p! |1)a=&®γ] ձ³ AX`-;Fvc| 6S+ 2ʣңYb#HL$ < 2qIFߎ~ 1Oe3il:EZӺXClh)cn7A8Fu>c5yCE$95_[+zIi\Py+0>zaUf+šL& <ʢCR)-yRZDXuSm6(oꮮzwO_ͺoV4j]mV_%ʉ~ׇʭR=2cT;MZՖ̦#/Ҕy ^՛cs5g^]^ 7f/_6 tema%( L _w >RYf7<"T*?.-^?i*e㻖 ,صL@m:kؔT@ATkjM2Cɀh_S[H涎ir`k]1'竼l#/4L LtGA3c!Рpδ9Μv.nH |Ym;|*m;9MbJ%('qbp#}~]:m>6MѰ] -Rhup7[7@]U;NC:?M̹Ny9aM529Rtg2*X`D~,V^CO]e_r=p4HE|ڦwx@(x㿂~RӅd<6.Al>&×Xå{-+@ @̻\^Hh  :_Ph8NANSvGΑ gۻMX8HWbU0KWM QML(?yCu1حGF">|V7'Z1]I"=!?3mk=n*s4YZЕB8n(3 a'th'- @88KBs@%䣆X0# *(6)(_b T,b+!ICEY-Ф qj8oKbP)O9aN '3H~~J`ћ y^Βd5E[_-~[9ӷZ٤5[ńV`"h֊ۢĐb/X43MS!I'hG\sk({cAg?V4H)%[._2\q5<(miG7{^t#a -ID|%` %0ۑEiHcGX"ZZ0˼F7=jK4հ%`f(–=|mawn0o,U%E\h~ }]#8"SI1>;PifZ+f='H jL "ic?(&'f_1nŘ]J,bdtX|;j TD19׻T/Q_k8yL>d]NQ"Ր;ԩW Cr+z_㍊YO(-;5\&ov=1 3})6'΁zHcB'n,?#3&8_p3`#x/۬uf%r=cPE&i..Z7(5%ݜqXM䞞s桤 0KhGIcOH IbEm!DŽT[Avt6&]$pUwv1ֶv% ͎A."\y}ӆKVPˌ`܁F4'F¥̤ǃ ^Ys 7(@UgxV#M;D^O&D ,C |#a0B4[F琍Kae]ܵH8)UacTfi?:ѡ\'rNz}{W€ "pFA0)3ǀy5>HGL%L8fQ#"~UCX/d{+ & Tڭ:W;G 5oѰ BnjLZ_0R4aT5m >*|>Uf*Be3;Ԓ1Йq=.Ļ ]X }7.~>\JouNHӒ׎w/O/s!P~@3`;7^q+u3 g: _1TUI+;O9?$u{ؾrGOQS ԃoFOC9qN3 9F7/$Ѷ3:>6Z/KM4 Bwg kC]!x`j$o_[X M|EU 6׷O  & ʷی~.4/ӈ4H(dWeTJ_*fI aM]mm :N&2&ۉ)\U=q7{ jRI %BU/ޜ`3W?zYS;|٫R=+=@k2ds&@h۱N?R]ޠ6x3xG4ϵQL)xe\x D,V=eӞB$gs"zy;a9 \/g endstream endobj 1875 0 obj << /Type /ObjStm /N 100 /First 1005 /Length 2943 /Filter /FlateDecode >> stream x[]S7}_GxԭOJIPRYld{lH=Nܭ+mKm_B4ZFrk\fLʉ o6x2G`x9C+d$Iij5rl3*>*HΈSHވOĈ:Hj$(g`$f)#܌ ` I)@+TάD:- )ޙo<썊sg:|$pd4wJ%E| Fu&/ !5lلSȡ=ŌɧLtkoo,bd(}LJ*%RkeKN)&V%+K5ɵ}0kݒFet <SnC2hedXCFZN1U U49SbÄ %Mxw?wm;F% r. pow>}B_>K Vˋ9ȿo6هhb~W]l͚+EvZ]}oIyB؊hlہ턬pFOKF7ꮑ]o}pK\|oHohoވ NtNtjS;N m=, '2Hl{+ը 8Z #*ǁ6hÀJS)ifngo?SӘI;\h>]0 m 1S@h bIo$2ӿ2' ԕ8pL`6x_)R޿8x0L2/?NW}x8ĕfN/p x;z~qw&G3va$Xc iy/^E"fÁyX4.8! mH%yL)df @zD,y5{uu٘'m`V TfrSlş}4=ߑz@R&;\<Ebx>4ʛZlQ&ݎCrLzvO G1*0J@zk_΁:ΠWÕ]Eo6e˴wݽV|f0ez1ޮBa}\n4R^D"n)W^sd/OJf}0'o""?FmN_i{j7x3UNɣ1N2@4}z?;^/gZmFAz֨36F7roZAŮ)K,t)K,v)kv)kv)7jB)Dݷ4prKaNp>&9jY/'ù+hdh]131`o\G1|{:[]&x4?h.|nW}uDytGf$pq; qz3X\+R7c[t_ZV,8rnlժ6gZ{QҔOl>qa"A}WX "-a-W:zW:KLt!Pێ_N8X ~3(tLlk4nS -Ҿ!6`gst9Syj7ڍ X-рe,V8segSe djL况;\jb-f托!ݢVF [FWV{Fs9㚘md53*5)8FN{ L6'z'"Jw 5B}!j3O_@+ (+oYW=]s?a1UކIZʑFg9̬ c>M¤ӑ0[C~DZ301 `S)0kP% UnA?t9-#c9?. endstream endobj 1997 0 obj << /Length 4213 /Filter /FlateDecode >> stream x[KsW*bb1/`f+Nq6NvnU"! eʯOtIP"$球0ӏf.? ˳o \$BHH5PbqY|\ Ja>;3K4Წ6i7Є\& 8qFIxw?` { B/MZM.0N7=zӈ4+@X8RE>UihYHRsm ӈ-wis;n^%U& ɹ8{ڎk:gu:}EsI"w vqѻ[Cl{X@3 9yLuK (m&!mv_/.j )D&,[8u52vޕUO B|Wx65%O=/H6jֲFC2&IeUvTBNݧ.k3@(P? 7-G''? hOh%b-N4dy:{syn a@vI,۳ 4uA g`=6Lf"MMn7|pe24A,W xr_RtP 7tw%VCRUyd FMMXr&W6 ]ԼC|`eJ/K(~iy^ ,sd</FFH5ݖn,5Ҏ嶹/B8!le'h40ZďUw3,*v(Ŵ/LY)ؚ G] Z@jmAMh5kB=&*dd-UU˖ZNl:SװP#64IQŎbQ{vho\v>C}JϱuJXf4_n; e#f۬*<,¢[ףd `w/rG'"!絯L CxyIWУ7TZ X, f 2PͤU qh4|hڌQˎ{^ix'eYG.c=饓`yF>PM(a<$3i-|.Xћߒ]hߑ2V.LsV6t,)RM&2A$UqbHRLX0b޲[u]Q:]hrtح+i|88xx8*˷v.@8뙨+pۋ˟_}a#`,hC[ɜy^[]ۋz3awtD #gzY XOrϨ/8EjcnS;)ԀYN?xƏ_18mXA~ž)s"0jv`^|/+.t ]nd4QX>>xiNOOO>߹gT14&  h"`S4)ahRM-9x Mݠ؂ (++T5 3&a†i|w&[imX#}q!&է&mJuFjn5[j<6iy#6YML[p1YCL2tt`mDw*mϩ}_a΂li{RxDrU%r fg *KGIdJizN[qҪetwM@Cǟ~|1a.b5.)4 Fz7 *#80$9f׵ 8pA{v@A-1i W,1bǏQcKK_NU:V!t#z{0jtMħ78p`=f0ee1fTƁY{&5lKq8sS#*w6KM$L5cDR vi^;SӺ | `SvKQߺ&_#׀k@y>ab^,=2~jv)1XEAqO=va\6ؼވHAjj]̐x\ll>9N&zs@z|ja`[VP'iIk6cheG3>l gN2tB ?$)v)r ]dDKMeuO ],n/ 8)/@Ugʚ%Q;/=l 9fµ 0DLp0!AaDh B8Dzy;LTPe;r` 0v ^yƸpꘪ*~eNi4ʅ>~>Qb> }"1 }4C 0 )Լ܋?›ַn\`6J̺p`?JpgBθp6׸G֏FEQ2TnTxBsI3?ӜĀ:q=OO&[2R6SW@4aݑ`?pb-82>~4&:t_I0?L<[kޒQ`[2JŃ[2h|KFVQ.m|S.JbR`ZCRJhôU['gT^ᔨ{*V«Ԁ7`j)ElxƲܰR0&oy7xZ_qO_Ks\ zxKu>)P@R9?L^M q]s1G1^hQ# +(.I5کC2iԨY8V{ -:-OQ``}-6Jk&azLKtDԓVIѿCY}"ˆuS >vxFOI {/@w]MfT<[A03 ~ృGI"߁.՗ ;ѽΧPǙw $hab +Fbۦss6| ,!X7⫒.י+O.XbL?Ԭ+IIȧnǶJ6lw1;+T5IGHβjCyܑC|ǃM R ' ;d_8A5Zڇ;7M]_B!d *,Ll)&Q8~Ŗ ͷcPJpv^M'b,w Рwyw/iٟxzO=UMP<#ah r[RoCSUrOtPU Q왵g܁gRa|]ko"n _E9uo0'G.;r30ܡ͇)5IL*$:mÃ!}-T Oc2'[;PlwEJ/BsLCԌ/&vEQ0_nn.'PG:}.=Bݛr-ұ XRI"܏Ē*'"_)*  wk/Wʒk@4"`ț˳Sx endstream endobj 2034 0 obj << /Length 3426 /Filter /FlateDecode >> stream x[IwW07كށy3ib;$ L .):`襺֯p{WEbc~e4/n׋j)t&-}+d{H+1n}.ϺL:] oD4O( 0š4%Oۚ6Mq*b:B?凫%-i++K5LZ8B40(q'0["?~:T1.Cf8ȋ7eR=[;~CJLEw*'9hAW>XIY^elODF@fRuY2ϭ@B!u5sGf96nvo^]Nc瑣9aKχsh}.VEYվdjuѼN>Cշ2Kf9X}ؘ7H0p 0P_0稏2ϵhYN;;ȂsQ+2  7(KeJvm s~~xj._0 M -eE-?INخ+FdЍx3mIUbI9;!Ӂ7~`B]f0V} ,'Z|V Ȳ5p"4fyK7˴3TP[lS'&pPoKdKɄguE!OP%7_&c&UD(Z)9YDtA$@|kCUA_;k~K!-g oxcބ9ak _JJ}p Z56W( )&?R>ڪT*Hj?}y7-af؞9LIʸStHss B~{Ϸ .8 -,ڽ[X_`yGG7t9We58_JOgފզ8lQ M}RsO}cVo/c!0 n7N0h&yЎy?DkSB1nS¸/#l{ F[eB"fZGqkKx#'"b[I)=++˝؅r!ؤI^-DΓ]RW$V c)nne!áu5P~5 Jؾ9v:4;gyc,ٖ2q?c"Pfe mgK?}Q,9 ?zI hHSHG$P&26ϙB̸9S1' 3Qtt8LBkC w$3?ҲXޗi䡀HctK0~t&=u]&Y")Lq^Ac|zR0a4UbHlj13S)B"~`4J-8oyj@:Cx; !~t.GA?P/c&۹a(G? y&kցC| -(v h$_^nV2YQ{0 T;TNܜe0X>)&ܐ+ȿT-Ak]m, I@$(s\ b1T꩙8>R<<>V.CU{ߕfTGD7>]H# UHM+ =Inp8;f xVu"Cnvc-'NXT~}0~J}9x-MHQ[tZbFUy?k"cqśux3 *a:O=! I%,>D\Iԃ\ӼVw#z!iYe52![4`؂vhb$r>Yt7 4xn;5NLݳ07ݠI}ɃtU_9Bx$+0!8.IZ. 2rPXm#JtJ}Bt^73*.ԧA ^dm騂f&M,) ?L!OZ.5̆b<ضɣsQ1(0b"R)>HvH8@Q$&oD ~m(7k'%-܏]7_>vhId,`\r%#1W$=k^nq7[<eFCLJ.cՋp"7!o΅*fn: x4Q1- =BHdgG)H>xXęC6[@fBi~Hw?*g>& H$DP)qz*2AH[:Xۿi/ش'+h|W^{u"LGҳ5Se!Ȓ0'd%rܲ pI(wNwpr]z={\RJr|6N)oN)qé.s%`$j:r'.,# GYdGjf1 P?s&ۦ#qwe{  P> |#COH1o y[$tKv6ҒH:M{1x~.8KW3 {r f5e纸s ^7M%:ZIi7{-SWoQ<,by|}4#c:wydR%p&;yqW})ޙD b=X %@#c+VT QwFp0Kݣ=[7%u,‰Шr }=.D8H~Q >RJ= of |,U,IQ]ҕ̖l·*w|M]+`Ja:PՄm 7]SP3,dj$,2J~:2:~Ij|LKl\wiFx7MLDώG`VgOOGԗۏISv\#Ң%2"q% endstream endobj 1950 0 obj << /Type /ObjStm /N 100 /First 1004 /Length 2717 /Filter /FlateDecode >> stream xڽZ[o\~ׯcZ|SkXF"/+ő@vY8áqIq13kϖjꚑHr%Oʜv*:Y@152MW$|F9jYߩ98\9GN̑>eY M,oؑ,+9cVaJH#-Es䢶.S\*7}\J:%.y}E\25 eeŌ%IVT3QKq\>hծ4u9 ׁ;].0G@!D-FZF %f(AHB;E(\+ _*U~@PUQ#CV$Tw&,Ts + sHTn!XK@ B`ӷ0&_C A0`@P נPEˀn16$fC &ŷT0E9Th@ap'ҩIeL-t$H9@"V.DRIt{#}pE-ۛO߿=FKpßΦ߼A^jDIOUdĮEϿJw_/( ϬR񁻑kXp}(8i|4&DhL3^ =&^q19>`f `>͡HK(3FfpДi @sbZ}Ær{>pQr{ =G?~:_WFc xa;?ۅaHE"ZQIŗׂI΀aR}d4?'g>At :" `b,{cI/z\5f椫xLԀ,1zY #|, ~ZVmYh xNN6=.Y | %ͳx3AṔ\uՂ+2*9*p_Wmb0(Z1[L݅cl 9v !b],7CX61xd9~RYI^gaI T d(_̒oZb1, =L,>QpS1ׯWVxtpؕpbRVT/^11{D|䰈?|l̃NS]By ꒥De?̼@#2-̛HJUQp#DYERGld.<^ǰh`Pbg+b03 \f0,(4[2ej3eX{$Y)%=$7f1,X"*ҀԤ+&ub=Tf/j<8-93B ֱA~T[5{7ؙu` !-~a4Ğ%ͅ#BFD$ i<Ӻ`(!/ >]Sj]UG,7"-/cI\;&Z#o,8Zw( vhX&H\ ՖM/ZFy ᷍!TnL_tNo7щ/DDDDDD $ bpYgepYgepYgupYgupYg vaVXLxQ6Q!+K <8ؙ^)d4:9 6N:5aJŮ*R ^gly?a㭝;[|~ <=CS܆a< 7x]BD"*.y K'ڳԂW\)k @Pqf,ebHweSa+q›x Uf- .^->OWYoD\eN J!^bBxdfW\aH[Xjw&tfNXHW3 {|+:P=1ZBl0x+@-#tΰ%dc$ų1ېOv?~앳(yraPZ?]28C+HpJaHz8*/@= 323$l?~o$]_;> stream x˖۶u?_ 'mI\3=]YPZ"xI݈\ 3:ኞxvIglxBx"f*DzwW:w?(љ= vvsoo^YF2~nnjnn[,yBbORa_"  ]]K)U+<T;|2[DuحƎ{lb[Do#~TRehPCD DenJ,S!7nӄZf߇m\_j"#k߆@$5(`ct ${}s AA!$Xd,b1R2"Y2V'T!8P5sF+xJxSm>e)reԕep%JEJ²G"Di"UϢSneUveu[o]YW:񞉯>Ed(#@Z"DDP*`@Idvwnzm˻r|YDPV$b<ѭ QCig*d]1bLdߣ㪛6PeJL .yYDk" );)qg,c`03`AQ{곴H$i͛z1?9x*9"P@:hD/(p@k-;_[SqQ~ ;ɍǹ Tt½?NN=Wyzi-%jQr@A:zy [Ia'a#{`|13DG&)Y۲pJynBQ75/?>S|c>mi7-b3QrƬEW6uh;4vg"nYBթʛE qm=o_M^B{8pH:^>*X?DI:E)nmE5MQ?8쎯ȇѨKNe?sn$j}yF)`>g p׶uDt;Ld<*O }[l>sZwE2 AG^~S@OOժܖcQ$XjQpl^CYL#2w]vMZpps 'syFRE~Y7&ϖt'_l]YPYHe IIʓ{Z41P*hG>d7$^}4oξ>хh$b YDGDF䡤 vOob N b qRiv-,J$7zt0rf2wQ=c F{.8,pB]O2#P<͠XBu%r,D‹HI*Ǟg EPѻ l_/yEqّQa+MjOn}}0Il&OHnH&qd2DOBWf(,7hr)'1`rnц>?Sam `-GA-prU8">f5nZwvWv!Tˇ&_;Y}]VGe=,T2'1=Hi}n0NF6@wNN(q`8gT?nw1>QgusӠ"!H[EXt A!=AJoW1vR-(5A0Pt1 TC{%}02a{gg u#0Nz*nLWT{a58mp c-|/̌ѥ6vàT2f(/vwPaK{|`ysƑo"3 /M+[;lT]~@Nq{Qe)&װ%鸽ov[ q`|dJ]ʵQR$[;[ ,>r TH zǃHs>G , 845;k.l,|w~;@-I^2j5'F_X@58,DZ сANXF8qi:hg Lcqw'5-4QIvdI7J77^Sb/\2xԸ>m({m팫6pPmUnqm˩NjաηmplKrܙ vF6I_W0±`WtMnퟻQ[S:.t=7U^D !Kdvӱ&]P &(5 KowyYy . Dvn6FYL.Uu$1ƣO(s> stream xk۸{~͋ @zwpMdQHlkjliO/ΐԃb1&g&~|DG?_?zBYBrv}3cL'0f/?u_(mvU־]euޥWlyzBڙ"$JA_S2(Afa+<k(,(J@_&ޯB*["p#[@ G mDO `cPqG>bO:c3,I">z a!;@38"hnfbQ'4I.dW\2X@&TGzƱPbQa=ԳP@@"ՂQĤP\fB#CeV \'W3dLz # !L1G@}VLa|H0>]e )'An;ZGC<†"zLr2ZaqbOK8CځF$D;ﶬX{P>h͍%Zv/Z 4En06Ȗoа Sa=p/ `iXNj2]p# [ce1kS$3N2I_͐lF1rVY]v!34bֻ*/>+:=_żJ`ǺΗoiЫUuŕy?[Oe!^˻IxB8mS2j6F= ʼnNUՊOn``}B"y|<+tg Y]0:D6}cɀ)cg(ZɞT16B-H~hd0)lS[ߢ=aN(+U潰 Kӳ>IwfSP)!C֎zYZ|7SAB>ƘH \{ g:Ln5ϯ5Ud=[ NL7>8CwB-hHt|iYCxj*i5ZTۥf M,XOi%\o-N& xG6>M,f2\{ m+:~]8N7[=KQ fI XYP tu 3!{( wBGlVGp; a0[HqA!oJQ1PoD5Щ;qם$:u)/7)8|'J hI[R=^ؒB& % קA&pYt^١tm 9>XG =yt իϗI= ո*bB(դ ᜀ J]6A{0rg-Ah=IXJk$?Ĝ7='1Gu JHi79*PH b> y﵆QIKY:݇)iD1vރG5e/xϦ>w kzG)LV9`H1\iA~#~{yplUX;7>e`mο8Y6>ca /,M^$pi|W ~glOtL}[6k^Yxcv\{<. s<݁dkD6}"`#˰'rGDLIo%*a1"jRo&$k0-(_5wZcť3Nu7..O (Z3gXx7aXwA,FaJw͢Y| LS3<.,ĆbyPdE;_g/m 0tpyicA*;~ _>MUnc]]sW!hkE6$ڧ D[:U}+uZ");8\f@ ̞4$zWy;I8z)z9yyK7&Do!'}&WWD8؏u͂Qn!mp^/3ݪqry5LQEG~5}BCfQ/^㐐0J>_Pp.Ǜx[ endstream endobj 2144 0 obj << /Length 3946 /Filter /FlateDecode >> stream xڭ[s~Ss7|s.w3I>e' I뻋eY?X,],,*>lh-gW&bʹUlv:wayY&Xp?}V_~gD1T+l6[8LF&5u)˲/X lI A6R}A_v&ilp}鸲K+t bR4SWCg?7<}/W u*#C:/{ڔ(w*->eDQg|e\G̊1ciqEˆn[1m'c}s50aouݿz+ܯxfu*Reudf_g+);s 3 هW?WId$bگ~~ݛmP0{Z S n"g/P$.x3XMxİ%t/o*Ci1iD򡞥8_+UVP0i_h5,߁t'H+۪0(RjdEE^܌!c<ô}r{ԙHרk\Kk <ݴON&@##aeؤ~3qH~&52LٛclwP&IDAOD$2^׊(*+j"1d_:{'SLa]?0ApZwo6m9#`4䑕mf[D۵Y -iu7UIS%X"!%ItjB030~:]!'U#xhg W(h$գTO͛p %rZK, ʫP{rC)*fbE7v 2XS]`vdHl 5m2־a`Nn}tGHf&@7ȾO`mXRaǣ5|&F0#.(v~kH6w\ű`LŽ5Ikf`awM(|Bˊ5 Ukzpt7U:wjh B1hMn f+.L=l:ΣD'R ! -{  @x?/]CݞAct  h5=<T{݂NHQ9Ѵ풑?Bpje9J}U8b>YA>`(H!3,B*dyغUK'XW5Tj t^|dꡪ!N*a <_k<86R{ y}m@UvjwU0^डif 5݈m =: ηd#MVqaݸH  :' R uT]k*N>`7ckZyF"69%HsE)567_0^B"ʓ r!QP7f S  }@,:KjNclq!R߻OAs.7+OIRBf>lDR8!bq*(/Ns:,֑P1! 'R)%b=rgRTP {S^T:t?h*GJvڛ~!"Y 0 ƌ΋K> ੵ<90'9{3=E#"-K r8'X_qksowD | !cD&"(yXIF yaoss+'/2u##3oAMBe^ǂȎy$$z(]^ E ѥUKjaw'K ֹYXذp U}D*ITRp_ crܵWQ| )@ VwzKCG SL06Y&",9ŲIF?x{`Ԩ} K̩@-#w1=I]#yd"< GS<JL\$F>XKM pv’,I"H`倪):uI$;uu1~a;Iw(xwP`?+}/:H G,Ym@稬4"x8UjfvL3s4.SFrҠ.AA,XʇWCou(S)Ϛ.6(\zkxx߇'|f}6'Rj H >ÚKmőHǛE̎;ҡ<J}h# ZnoMILCcy*FIgq8g4 fRz0q0F7kYlλxi#Sܚ>i S8)."Eގa7|B8x_$ÅLC71SKx6v +PAf"$ 95]TI&o: $dF:' 7<Ƽ>42itMY}8m]jPP@f\rOO/ # ˄P}S(`NHo <35"RqZat0C BXh5 6r F [ DŽ|.a{2g@!a*f=@YWȗୱ;W:,'X@ vx<x`%+O<%1t8ldzDLБDC^bD Ǖ(.0Ą@pHX,OKA:أ=0}`kN^y4x\P,sETi6?2g CX ʲ#E4mjsY 76me܌Z9_<*b uYsaԼ>;_b*(QvM88la5!z1(M ` ]nj"vHKVe~^bͶΛr7#2DMPY[FngdB;-Y[ʏV ӾV,#k1``fJr^5!7 x5X0=.,koŠUbU{ %G-d7~,kx?* g׆ͱKvͶiИ8P6kaMA0"ntjQJo0Br61@X푡3@ Kj?ؠ޻v5~7q9aKCyy{o )f~귌Sڟ`)=;M҅-IJ;1} {N²lmYzySSMFi*]O'0Hőԇ|-롂?V7K JF)Q6l']2Lu(e=&y+߆!E4~ 砲:mG/N6m~L?9=%=pZm=h@sVI\tUsx{ endstream endobj 2198 0 obj << /Length 2343 /Filter /FlateDecode >> stream xZ[s۶~ϯ#5c!čtдM&gv9}%*"}H*뻋HK#?x,b`pYh/ϟ=Y(R˄šEf\j|A=_46YQa+C4MKYFYˬW4xbHBygUv'!NsoR4yV>_֛LGy_-dJ'dN8M^ˮ |Dyy[BKtY<$۲\4YvqlMk)YM]uYIM52o&t]KXsۮ+^?̜(Mm|!# Q>ǎomM(m˼ߖC&;geQrPdWlHC_!g :MM$Is7?~pW'9- µ 82XfmN-<)~xm HiFW9WA2@/@%L^w? qWL6 7aasR)z9˺੫UQ_cu;PI]$wp!{`$WV4Ej]|#E*(8Tpڄ))TBbH~TG1UJPњ%Bj Cb)(F ~HTX)Hh&s0_gmd&Q\@+XWb] 7a,4_4F=,f`E 7fd  cރ-0lJl*A8 ~/sO$Bz5s&h;U!gk[-p_׍'Pڮ.mc!ρTͭ`Ɂ6<<ߑ i9 (h$!X;#j ';QuXKvWYv=k8Ah4ϵzEЏe)^pi'Ĕ* 2Fƞ30e]ֲFno{:/vw[4}Pհ6 l#_Kmrȫ?+`ΎƦ lU~ZȖclA &/O?x&wO9eWJ>$M,`ANlJ Gj8ttH. 2 L Gb'1F>4>"Ԃ_d9.}PzPf(>Sm녅Y[녽Ƅ S4kt*}m[74a[9.vpn@\Z{]E0wUf!^ty/5x (ˡ8;5')n@qSDdIhwho.fƵyF-R,Qnzlՠ{b=D(fÕ鈫7Hys@ҡHC__5C"`jPbJxhwa

    Ə?t h@ázZ7i%o-fUy~%uSOUQHɓ* 'ڪEXۛr olmA<6bx^ h{@r~P{ o57cy荧, Y ^ $;ҡ˺A9$ĺve݁^JĐuSSxZj7K)vD{@b89RYZK8'SAehLso#VLo6$ O}_,c^44ޣ""p3/9P8*4,q[}p9( ݔɵC/1kGR}LΗ]ec+ؠPe(yzkx+8)U|""qS>ÂEZ|3=,$Mu(GPQ<掔#MDDb}PkkzCB |LޮI+Ff2bcq>25+\'AI 'A';sqIdxl}BfgDW|&xS؜ װn[ n},u.zp/ %*oO9%gXdxjXd4+HE;bX:";,sǗ>S6ȗ|Y9NGD\|FtF'K62OE z;k{>lr* 1v BCBl'k\c܋k/&sPl[QV9UK05u-F:crsUհ,ͦ@9xRZ/P h[LpܝMNbdu_L~3|Ź'ʘvQG٠Î c8M_^Bĥpi3;iLƬDtvx?˖/艡C]wX4Qg k6 }^ 3D!*c^X^ךET8[eh,(Sv]u:Ym5 @47|rr($ܩ1)O(JtGAu}L}gq]}8㰏/*D%CkJ"*[SНU>TVHzùȋlآza+_Hb李MjevZ=n}5 kLr8tAŽsՔ]PMfeû$:*JCmI5WnR`d>ʲM = sP|H syS!ζ&ݭ.!9u[c]amhe7kAlp4^f,&G'OTۜ T(I)C\\@F]F(zgí+/Ӏr6IawL%+-!H.Affp 4V|N 4{V Ӝ9|< eS5D6~J7 m(Ɓj.N{a\zu/qݒg4Ѡ}ٶT 3'-^FEvM)K[<ƒ b#J͈Q XœH F;OPyy'_l@b Z;̈́i(>y0%m?ij9JHBM])GC:2\S54ט*V4]YLcV#Wݮ} {B{ Ia~382dpĎ|=iZOYkS7LWpT63VͻCvp-Kvݏ?`'ㆹk_ͰS#7w}؎o ۈ4ҁִJ{ uݷx:TsQ衇rAkHskD,lKuP;! tq .j+@+.~ThSɝ2L-? endstream endobj 4727 0 obj << /Length 2934 /Filter /FlateDecode >> stream xZ_sУ<KK;͵9Ӈ<mk"I| R,nr%.].t߿\囄- I"7w &5a-lqY|\>.WzX6WBe:@e]xb~gv<`uVU*zw % ԢD5Ʃ&jo$X T滯fJGs4Ωќ?;!6+(fbXe^q6bD)eu8TYyԒ؉؊Y+ 2sbɆс4tjaMj=]3h" hv^Ѳ}Qq,<95f&IFM1OwOն5%\,??ﷻh7Ps{Tg!"eۍ9',6+ADw67i-^_hVPKk,Q+\8Hh|~lbq=K1] lEIbI+wS$6OV^C&|щ@UNlZ)PT(=uO>Vоwa$h PAZS53drJ̀"Z(.8tFƞqAtS8n`!o6Сoo݆9ϝkMsN}/\8_fY|1F::{[@$t.H+b {ǎpPg]Be_9{.K= c41PƟc= uE`U΀Bb`Ċڃy)awiSsUsȫ>EG#FL葙p/&@Bܳ %I \Y5|0._z{m"ybLo 37`v2]{gS[ALWi1YcR5n3̆!m 1ʷѰ P&I,Scbͱc^:KMB$yf Oam6Aey3Է H2v tiޫ7HX vqB^|ͩ$SN%$I}IJc Qvw{8nY&1y?;mFQ(I/KTL%]3_5c+Bd1mB$oM3 Cb@H3)1q ־TpӔ€PN@ʋM]FzJJϊKyP/P+̒؟Sv:1 KnDqh%nT wu~}7ܮY{5_ hϐM#^H+6s%@h<4&4Dmš}Izuk>[ִF5,ySê5HTy[3*vAZdA>F_4烧[W!Լhog뮲czh)2M:(!${N@t3 O~% Ii>99 x]&Ieœ<̄_@`ӀGPL\贅 DqJ4؉ QC p"&yx,ɐI Kqy.NpׯX+Q8qû=g@] qd͌Ė0hٱ.;>%yvѽ 4 Y,AB*4ԞSy)!ہH^ GknuFAuau΃k丫/K7b\y endstream endobj 4652 0 obj << /Type /ObjStm /N 100 /First 1003 /Length 2610 /Filter /FlateDecode >> stream xڽZn}߯G!]U} |D#7`+@ӻMYr8 VͲLuݻcs(N,Nh.!f .E"r!1R$պ)Ax B:֥6'/IUi:jNMF1v*9MkhZ!-Nklߚ3L#8JNV[YilYf\ xdء$bA|8).8vt(\`_kTRoK؁%#'efQk.Rjǒ׸dNa)95 tݱiV`PF9:o$Wq]\\1Vb|nJyP_)}ǡR_Yԕ5 UyZ;Ғ\Xjz.՜Ai6%>U |XH\MɇMl&>5jpGnzi2L$6R~&P do*m%4F rEid YJtJen&d?^Nt+/Hzx~6nvZyן{jd{M@8o/OHX_m RL>#,O %[[?s^oIzWW}=[!xL^E{}AIjXxxX2$f%= nt0&al0BkIQkHbÀ" ^~kXLIYJ#`2eCBdfMAv)cո0 d15t7=Eah &7$T_a pcP]Q\Idvi޳.@V   !jHOx.R;ԏ𮈯51ƤY(J ".)EL>P2ߙV,2oK;nIY2x H "h#j{,ּ= 0Tm^z #&d}t'gԳUzwX6AG%ЉL>^yIl@sOLׂ.҆X jU+Az.4X`tn U=(GC\B ~@_HO @+9ӸW Ϙv"%r**w27uCh6;5_S-8U8wDLc&7msqR=F¨WQ {&7 C=[jͅ-Crۭn?l|qnrn2WծYVew^+i><``?58=h!Z޾;ٙ[|ڹ/6+mv7HutʛwpO\cNKc|yy99c PQQD9)|1]t}4ݮo0,b3HN]%EԆwVT['R a ud HA0Xi F ʘf!q$C;&--ЃMYWЦ@?F8CZ1pTM9W4>$CAmʍo/98mċAza')9 " ' [wx-a^F%'+yZ^f}o<䂞ўd\*zx Тeù(s/u.0s{ǸyM fC4FhUrwˮs9#LnI4[ D2xhT*y^=ɔYcC_x17cnsc =2 "" " bH!YdeH!YdeH!YdgKU6sЬWP3ɦaِu5cD6 G]H?h & \kMYɾZաT }$Vy˗a$v5߿כ_H] endstream endobj 4755 0 obj << /Length 2750 /Filter /FlateDecode >> stream x[ݓ۸ ߿ޙ'~CˤsII܃֖OliϒJևlR]Y@y0 Ey5z`bM eO64/~ ykM&RU IjqŸ Jɰ_P .HЋvBc){lzH#`ExEE \[@F_:KqHdn΂/b6c8WSS Ő; pL\ Yc.aRVa"b l_׌Z8 c1.\i<)floʕ992H !'Ypc.xq7╀iQ=T X}E]ţQ4*gxoW==groǰ=loH'FJ~Ȼ6KH> Đ8-p|#85` 82#Oب9#Tkp(sݭH8)Ps) $羣6To aCaCHml(nGcSPBڣ=6D q`C|颴o #]ҡ G_5AÙIws毻fxnLe8& jA5 j5N ʄ@qA_wLXy(GiAHG+#}Pv +gk]!hmVf[eq L̬6xC$ySڪu3/ٶȨ|l2 @ Y(yLlm\v;>ߠa*"m pEDL(7!GekD";PR,+Gt "f7ubÎΤʭ͸[ܡ.rr7$d"'cy\hUg c귗Ԉ49-@ix)d I7Em#~Zdssdp&6x_S.HFJLiDz@+aw4{M@IQפcE2Uc+b> $y*ƹXp$g*TY ]u)1^NJzA}CyՀ]gzL%u mvYkZ#|[q.{w5J༖Ǫj%,`?̞HhƑ pj}wݱ'8ANXw³(cpFYŲx'Z] cmَCJncc1C#FMmZ8XǗv* l(Ja偄ȠMrt⿪w@ endstream endobj 4823 0 obj << /Length 4500 /Filter /FlateDecode >> stream xڽ]s~^:#Ϝ|=%smtڴDۜJKRq_],/:Q ]7櫻_}?\[WB3\]߮4LaBv:麪/.R1YEyGmݕU_E*eZ_]JΤr4ǿ~* a1-MάnW]H~] ge V46y뺪鲖Zީ6CM~lwa2WomQa[ P%4̙2͔Mťi>ܾX:X0 󜠂k&EI"A-KކJ$GuU6#5_E3Ey[c@ЪFiLdLn6MFIOS.綮C" F aZ8nJ3!#l0γ tde@S:4'OnLv8ay蹽 Z߲NOM33 [q(O4< Hɚ>vۆAZQcӠC)ɹsh3;:'z|.m\q@X5鋔0w6{B: npaGϰS`ɰMN HBtqc 4-=Vиk}zq?x0#_)3^Rjj pLtWYԄ՛;8ܨ$ILw>}w(E.0'zYƥx.Joy]_#8ǣMG]rA@;G8J]4e*q@]ZRI$eq7EEFFGB8E(*jyI-ͷT7fAsvz}i:K J[$6P(xR;Ϩ'g /1ME@=  afU~D|4Mo=i"r`zNkXb:23B-ZIz;N`7ZU%̚nw聆/) t8H{\ջGZ&vKlI|v![|BbVYA"xBk$zVĄmE W >E/c ij,t{QD'&r ઀WiFA*w룉aGNmtܡA}1˱w Y1d>HslTfmn=(@_0; v5,8Upοl,I\}Մ`EsfP `p>*8W$rWݷ  c\} yݮxc$}$,17k19ۭܝr.^#"ug,/Ey:'dxTU7ym畇+ʥX0ȳqOH|e911g爘2<ŁRc6Fgt%9vRlF-s{g;|]>;O4#Z( Dw^KFӧݏ:n竅*A< YO˖FtF sjǗ&dF4Sndv(j^* ǹ& AI Z5PD '! -0~,#I~`C#gQbtQNYC,)G<' LMHJ!ϮF0o/xw9[& H]-[0nr9".RA.$֜WVT` |δMӕ$`^K`7f!f)SqP^( (pYt(LcXj2B1AcJp,RD/Ŋ1׽t1>Bc8 KhbJjp3dp:8ݕbudǚhgy4iYeЋ}~0lN߅䜺Ɍ|!18n\]NrE0.\gp1J ۅ]n#̵֒sl6i<3UN) 都dePR9z@+\I@+lKL4m 0_BHq1%2D'/0=vwLJe䛊KƥS}NDWA irz=w`m5v)$3-8J$pt77/1#urr#Prb ciP88SMfE.Q8Ll |SMJ 6 06>U&THr0/c*/+Nz~$YT0ZL˘^gW\4'ዥGרZӜ7N7}z} t s1z |={XCU-&e|ǙRzCK"Rx i&n]d,q#nyV^2z@?5rP}^*oׅpjW +A`N63ُuuZPF s/L]TT 6|W,c3bXk}#qy(ysg by| 6Tav*76.];ZKm*U²1|g]r "eH}K^wrŸLYb.hkKkC]c5Bg\$L41Ŏ@t1[MKS ;o ˂/a+*[3ijIkOGk԰H;4obI+ZK"t_}.O,L]\ k>E?;: i '_Rk(/7]~'WK>'IT(htQ*[>eM`~&7-CxL󺾐M]+8!9A!-BZ~AR ѫ*/9f<K0.)K&|VYŋim8lЇR<>*H+jR۫<[)t|&eU[.X9Vjlb^ ^P endstream endobj 4730 0 obj << /Type /ObjStm /N 100 /First 997 /Length 2487 /Filter /FlateDecode >> stream xڽZ[T~_я!=]]7 Y!K(aGek-D}gk8s -gTUXKRrrm$, J(ZHPk%B zI q Y ^sFJT,H+Z ϖr<\ZRywm)gd Aa_7>JƾC2/gnuhCWRtB+ƟaAV5QV% nOHJhI*P ϫM-Tvu̫ɞuf?˫fÿsO?o^]~қퟶml+i)*DTDcv`gƑ۾ 티}z*lw_j:E#6NOXq'~x򗧯!V0U F>a#gábeLH)V윣І$EԳB7fg2!13:uջ臗߿~PTGHd4)W5 ਈ]11LtWx解1?hP9)[Hœ3Ar~0LI ɫɚ-cB9ca~a(Kl=2< uNnͲ7.%o1w( f+be]m ;KXU RP;Wx y>}6od"1̶z}U %jQAXVKp~2߷Uy, 5lD"OHΧ.a(Q>gGN8~,C8[o1"0?jEûwo>܉$[Ԉjf˨)},MU/.wAuJhKYU. iA[zW(+J y0`8jRs _HCTؖ*2wuDDGCl@~֗Fx6bYwQ$ GWﮮ_rvpϳ~w}aǏ/]ya}rupj;7ŸY n488@gWo_n}o>`.~w~Wڟw?t0c[ g׸Pq8xg~n!T={8QhNt' a lٜ9gs9s6\sqZiG vC:Bdz\\`qh!+/"SSφCY ֌t&mÕCBD6g0ϊX9L`#`*k/2+CzaYPVONVίB)Jf =) y| D ֧#ɺ @( }2"[1KI7Oՠqlngca^^<;C[Eю8,7XWFzchkKp;H|!swʁ_H2iS1H42''ȺlA5J8e~{}uG"ķ,8Rºؾn=UHZtZ;-H?16Ⱥþl{rXkC.sq4Z^we6N~8gܹ==X#({ w;"lFl,ДÑĢ 7XN/|mRvhKk Q/>ΫeBZ-Ľl^8SjtL1'ۙ3,Y~lllll:ꜫsnι9望snι9望snι9sι;sι;sy8ᜇsy8ᜇsyp)9!Nd' s8QhNt'8gu9~GHYsڅSn#w~w1""hGDu |aiNNC_@]R9?ú*l[;>Υ QX3AٙnmȚ4l/p>`8@;13W.8lap,0֝W6`g!UN~8A=ɖXW WwUfrE2ʲu=4*0= cݸi @»_ R endstream endobj 4886 0 obj << /Length 3928 /Filter /FlateDecode >> stream x\Ks6ϯQa[9xggg$$JmV$!8~/hZU{ F?n“ |>qGI'%R݄P`"Ln_3B~sHk%PObUE:1,U-*;#bzF~O*}r]7NHL*erL!Ȱ?ܾ! OȄa˵=c/}DOڑ E2jra!t9?|GZMYtytv}j͸JwqHRaŧS3*> yhy,|Q1b5KLfpa`!+f2 <-yV}fŦʳ <םVk΋{<+޼07نYa :s@ߣz1#ONJ oM27r~Xǚg;ĩH^pDp5Fkߺ!.e>/j8K48 H)%=&\åKu>l81 NLӉ9}xWisuYzg*ǭa7F]`9o.2NW.RouWV8īUol}\bꀘ=V̻!}=FOo9y}Wa) &l <=|/إo5>jSY//???#`޷ܘz}K2+*aHHq';;wDDyRb%)(F53`RNR=rb̃3jm9aw66_mZtŽ|% j?ֺսUtnCI &¹(nJ@;eo L`sHZ竕zs2>`d-l c8>Y져5 FCQy2;4E!|~Kc̣xzNa UALy~u|㫰)r;}UkƋq"!'a2o֬B,VeMY˜xN!JMdW^3=%;yv,-b{.aE=#p!!n¤~h :Ri/$ĸB8GJhƸDЮ1LT g3yZ'̄Om\Bp3eJ+z<¢ Σa>= w/e&s3swM>_i&g.tmՓ_)y (DUs~P  BudnkHY]@ )a-C- vA]܆onG]؋PmT22J wx:& ƐΕ+lv>!҇>&& N[\ J#9<4>W Ahc9t\wrN=S"bֈvU9,a{O/H3O~@.J"`PTA bѽgR%J~{+Uh-ʏ n~H0BE &5&>BJ`#J3t F[.IVHKO]m h@9C =' í ԩ|~@],|qA|5U ѭeM$ B`/VeNʜSbcpzkL53[P<$[y-@.H*;-;zd Ȗ;c‘?.NR J2l_eZ:ofA=4 EV_ ,v7P3:P@ ͸(%q\!C (~#h{ X.H 4rv&|ej&Fs|eb{v:A Ds(Ǒ^EҘ+G uE0PZ}xs[)ps@P/ѯfSheUe1ԃ^*U֛3KLw+0:y> @Ƈww#RnJxK{DL?n (V4 3,a-zĘuI賉S)m 5h -MlJ֐ҨCs[ޏwHҰ4١>ڳ,~ZgfNK3!$XdM\-]v^@Mqͥ=wNmA:kn!ս"!:/n2䎊G#ud`4⭝셏gc:|ڜ nGwLr::"ց@r]nAFz[b\!jwSz3 uﶿ([$e1H@"WLJ;;sSg;QS,nBLlS %I4d8pYfKPJ]gSv~s>9[V}1S={?ە)xгF lewӽTA$hK~{7Nxx."ov |̋s -pu[)ȆjXw2\#5Ɇ'U EXy(ucTHBVp#wA(+9]RIqah" bHFc.)2!V]YW{(@1fF~V-ja)9ysu~}Frc@4'"3icIYIub= RJX,Xv H3$R4/`E @qRHե) Xl MkڛT‰ŀB @yy\|!17"lo*0" \F䊌b<"fX~\!͸t*Mmyb1$>V'fߛ czGmj?3I>C0էg" @FRӄvh w _/I+:G.)ED%0wPm9LdN&NhdZN6hoonp*S$?)x |h2.Sھ6p WkבR6-d`8@& pC{ǃDˆ{wXпv_1_{U,EM9D;b4 endstream endobj 4832 0 obj << /Type /ObjStm /N 100 /First 1008 /Length 2663 /Filter /FlateDecode >> stream xڽ[n7}W1y0U+`:pdA^Zg0=3l`f$`[]uX*օ\,EX@\ ʮ4堸$>9b$UxL"]tRcB5;@ʵ8UV4-8BM; Z;sWբ3QrZv,u:˹3|vkΚC>ThQg>֐Aaku)(F%DRA"U(牺;_1#Jm 4,XtLr; QU4O 9 Air \ÈZ;/@Ė4?X _nJr ICrT]ZUAip[_9ʀR1vԗa"]uFV7פFu ʑ;]]z Z X` [ *aC%]OB!u E[hw E ޡUr, Hn IkOLy*BjĐMCK웨tZI,8!i\œhqGߗo_o?-ΖВωVfqŴ'c8w[4&)y ŇzG2e GJfp )DxBtJ/Պ1߅aB4B[)vg|qu0x$ڣ s/+T{x9("Hl>ydL}&0CEG& X>|cLv_]M ͸-l<>(!)$pZj)ŋQ{8q>#zY9b|DĀ8+a1$t^SY͐^Fg`pX l?5(桬jR3jtJ`0|w?HTEA<q#9c@VJĀZ@Sϱ}`MƓH@R68pqzpAճnqv￷-jZ;[՗.nW׭/{:׌d3[g0Q A4lfc c :6A' qPr8(A9 iPNrӠ4(A9 yP΃r<(A9yP΃rˠ\2(A eP.rˆpD,Tgen@!SĤ_T qk= !Z, fD!ӁX,2>z#yɷd`/ྪC$ 6ԙ^KfιRCXjse m>DH-Simhlb/x @+(;roPDhDj27fV])d2M4^]{TxM)3Ք'@z{y' Fwɔ|k56%- R)?)7y *x琗mSd_gd-Ӟ摳{Q/mֻP`g(O'yB˔d("l}C(BlpUS4UcY}8na3Q5_GM`Hf>NgBVJWN kۑWx7W3֓ {Sgt {uٔ?VoB;J7g55> stream xۖ۶_J;!vR9mĵx"RUڕ@mEA >C |Ϯ|擈Z̈́qE)\-'?N\~y aw8#3xbzr6N?&ɋkdy͒u{tw]ҵnˬmᮉ,y w¢Wo/1a!ۮ.)5)qͻp"߾yv`  O?qY Q]j #ƈɜI3^t?JW$x mϮ+nܵL) CD騞DHUakL+֬i0p4\l.( /ot̂b+Kdrw JY=b&%qV}ܹ!שN 0+viRO{&6}Jb8fLM|Y)5fBM˻n[7gYmbMYl@I캖)6MG8QE#a tW:G` (eǿz,:a`ÆM4l,6O~NVpB õIq`<P "j<ɗEuz9 a6qo=>C !u#(/Һee10+6v (f,b2 1c Ȣ}Xh&AC hg:"]$8Clq&]CgC:uf1 $}OM@@I,X 2).\<@ 4 a&`\c22ҟhF46}=DTە؝%zk8Ԛg-Yׇf,v-45'qeVmK08[4zz[b-cNso)Kk=a$R: kH8V=ej~CTS ICDAby0DFSiU[Q)[7,2Mcg(X;`V5\)q4-q.9qA2 <)!@}2%d"~+*}(hx|G] #xVg ȋ/O7+<̔=n߂kBA)o#b·ꎹ0P&XPhFQ9_UL!~q] G-WwM ߆̌s.d,ƄC. #,v4F;9iIONEXoj;@ -ϤڠK k1X7 o-Գ`F_\eQ~ވa> 3Ƙ}O =8zaEY@KK2by=nJ D`aI} 8n(= LXq/xksJNotI謊KG+i'7\:oZ 86q݀*M!=$xNGcP)1pZ?xoQE.[b#Μ(ׇc'CiO; tPӌP~rJqfNϞԩHfX *:\ ǪcudҶJ [oW:@g.|";386od+jUGi4 c5P[Q UNqC(3rp—ż̈h 6pO#;"+;qu Iv{zf 7͌Y^Uo5v8xc4DR1c0-G .m|E-}8X݂WOԦfOzLXMhmS+`Y1k7L&˓ȸOZ 2UG2MX6-a΍5tYcpOyZW#FD&g,)_6";Wp[4"X^_6jPcƹ\q<;&ѰBa(ea(C0|{M4)-!6!CEOlzsL!qR7C4e,BXFa`XKy8L+eÛLL_ބ2'Fc=alh̹͡kVWl |_wc SP12'$5t|;Wunw64i!d$%u&(hmce7of`/Bx}}ne:(p&h,ЋQƣU}e5YU 2#P gZjzяgQ4>zDy=U?}\wSrrcC㶨*GKqz]W?,om}tz]TUn"ʵ_fb)%)&mv>j-ƨOVnS#ΐ4$]n,ɶ\V` mM 2Lvc"JDu>C,wU?GV/;ޏfc4,V{V[ suR|N^4`3,j_ xH.xz} ]?ǥ$*^G Vao"l:9p@a-oC}?|wm: ƅI?9Ż#y=#:~Hmx4:[hw"FOT`$Kب [lq^༽@8v;T3cSG8|ESRHvކ!qh"-vR̪oClJ2]l:+Φi;J, }2!a6^\5x:=oX"{ZX ܈߻Vv[N Z+Ò ݔՍ8Gp)3s kb_I^;yVjN#Beď&K{d)>*/,j"mplp9 <Ř_n8ƚ:ڈ~ǀ]g5GDA endstream endobj 4898 0 obj << /Type /ObjStm /N 100 /First 1011 /Length 2715 /Filter /FlateDecode >> stream xڽ[ߏ ~BC")Q`8{ 4up.[7i~.to$ķoH")]nZC i $̈́Vq9e(lT/$4Jl.g* y <1*k=k-k5d-kٞ R3BI 8qkupf0K40.T!{>I۵,jR)C `+J %{9dZ!Ix?C|NjPTd| ]#P_^ġ IB2PZJ4% JxjK-hCBMZ2vNALA {w|g 5q_ָ*c\PvK-+nVR Ƴ7LxVWxj`8 5>18t8{@ۯy^+h^2<nq )a Lϔ7AS%7 .A[ Q2DͱI\L$R^0A&b42 jv/&|X1a,hpq# 'Ø"q9{l_luկgG77BzzzzƗ՛Mx'cP)JTX1%Hsl%㾇^Փ?/o.>go&c5 L**/aL.?͌1!=V,B eۋ.on3Ҡ@"&hhP,B1b-!޼] -QPPH^EUn{l/`kL?yVol?ϪחXf}b6yn|XkG1,݂<y{㘫x4gT4;]mVr] u\pdrdrdrdrdrdrdrdrdrdrdvdvdvdvdvdvdvdvdvdvdqdqdqdqdqdqdqdqdqdqّ#gGΎ9;rvّ#G.\8rqő#GVGVGVGVGVGVGVGVGVGVG\:ruՑ#WG\ٝww|u*5#Vb8d^/^=oť\"+16jmZ(5X/;;c[  dmO_,z ԰ ٝE>\ϛ!v `pJK8 b؛ldB 0rQߨg`S`)$kc[+NaVKRC[hM38K YȄȚKZ#U5|^QaZN, 9RhMO8K$D)+{P|eu7HCUiݝA>bN?h&D QbBYI/ߞ"4` Njm%RF2IelSehv[ޢ={'%΂Ө}Olkm  K!?bgtΒ,H(X"5uv4\VHR$]9EWI fu h;H-fuh*bQ?,Maz{zoGe)*S` ]QNQx93[A߼Pz.ȹ[ѭＨ1msvGAe! 86#aRƞeIYyem?خ)[`E5+GNl[tX.Yh64H ;%jc1uvzhNPk󞆠 SI'GBeG> stream x<ْ >rL{Nt-HJɬz_ha-Cg_o; RhXyOc8jSOoweo5uq%SV2njGSq^~կpi;`g1-?qKՆ:nۜZpr#w̷6MFh?1g\v>8δz"1y Cd֚i^8dFLpMZ - "Zyf}gOkH$g^͏o [&bSW-Z pW[,Ӏ+'6L7)$2;08rڞ~&3Tt: R0!k8DJ7! $; Ȋm9m ؕGj]@c[Bׇe;BsfNb9:F 򉸖ts%tWܵJj2&J7Gδd% 9 _Yo%G^(C~ TP%p{O#Rw@ L9 ŲFQ]>REƁI0ݜt @3T1Ξq}8a|Wžjuz{HrO}0ZpzϟI9R@*sB9D=$2ӅgQxlj L` -6uF)m3] T Y>^KIT EpP`ό [TQ+qD6 4{9dB@d/30𸓴8FS3hapj`{eʍ<*u OW  ˦bBo``DzVԵVk\<_82!- ,0R[HmY&8͇%j M0֠kjvQ@|ݬF  J 76BiB+B ?EbW~$z?_rC]C؝( Gp/. i0X-Zj7M!G~i/ENr+ӄiB"̱g/4ܻuuĨ>8YMǣh {^TL~ex!qJﮯΚhwoRrvC]aWW)l p @486nñNÒz@LꏜZk8HU-=.aF"KYx7 f٠aY3'!ÞIժh&x,֋mD2ow<`ׄVdAIɐ]؈xDC"h?ARUEX64 FU%0Jkl{/zAD%( WUrWnt~^9A./H?-mCǏxyDB\6|d((7U2 jڳ֎fmd 2ƶϫe| iR_A,ahK+i@))VI;RG7RW7圢Z ՞D#Uy_WzHsTtDj`;);0x!l, T OKB3n{|(+jU/CAOwjŠÊ?Hc]G>曼I RJvcx1B.)^n` , Evն ,H=ty5O>0+SE6va^}: m3TA:pN+?[l~~]?|u0$` D$ v|FU߂_p͉$R1n`ďǔ^qL+Zw1[\16x(D(Lh @ {j*-6Rfz>:/:OiE,l\``(SW'3 86{'[{;wwcS:1gtQ?|0Vh˜.%{$@NF#YIX&뿽~a@"IHnQ/@V׋Ԅ_eP`@rqY͖AVU5 *坺%'&YE%441.n8` Y I9z NA%`?FukJdZ`IH:Ϭe(/X ̈́vR߃.ڙq'%.M\&; [c[waz캩yΏ6w 6q}S2ƓNW N!+zzp͛L?2Mfzb-_?> k,\}Λh]'vܺ}"R 5g4R+| ip;^K(ipm(8.ώT*um(pV2*pRwЁ]!d?UɮQg!3({ @+X*\Lt*C=&zM^ZW޾PF'8' P`Lshx}l%9/JHcF3'{Ob:ZZ`8w :*.t<:TWOp:'p?( OΆW$~lkR ɕ tU4V=fd_dg8N%EQlOoH˜G ox-&r;yzyưbB $aWp|"!7C;mtēyȘ b$q$@١9$cf! 5!D{,mBl)lw!k@Jѫ3yXLgÁJO5Ά :0Ǯ8&{y_c.׌>k)~7$})N].oQOXX@q?X93DYXQe?1p91hoK#& _+MIc7SoTp2EN[bYC_f?ǝ%"`o^XȔ*z:Ae=z(eɛ޲pkjZmm܁8=P7bipu9Xbh,Ɂy5T $W)+J]~yR` kj5#Q#W%:XJDcE6`%=ýs)]U\R?*3Pn tؐ T jA:03x skosC>_ /#0m_[& fdYwUެjÝC "}$Wb@ =3-sAA'X(kTqK]er^%1x1M-;jHJqݣpkeU{N{STc%y{T8PFD6A)7/^n(P1p;P̑{tTlY֯zË SO/Wy^^~y=-HTCX) zWˀ6MM"|}DrN__'"vFcjȲvyXa"LP ~b P9 tYYqP:E]b +ilT2ܠ9Ź,ѤCҖ6j endstream endobj 5023 0 obj << /Type /ObjStm /N 100 /First 1001 /Length 2501 /Filter /FlateDecode >> stream xڽZێ}߯!F Ni\e=lփذcF)pAvgP.bUbS4!sqŸۉ\A L# uACN% 9t@evEťVQS%WrUKrF@9K5 cהR Rd(UUa$$%( {&9*UHs"#cFaf s`$3dQ F Lhj bfڙ@9t-}ٺ!+,Bڍ!<b0$<(͝KhEnQ`9f&+ݤ{U=T`$G M k%/݁EdN` %uǰ7[(܍ F EbnB$cA~B7 $TC驅jH1y-kOe!-^lX.8;D994njez~حu͊Pr7 'c@i2p"~u!MkiܚSK ܬvAq1#spe-z~^ӻbu~ǻ.V6߯%$~w_\ַZqNIaM1Sh0ix$MX_|W}Aݗ_HNH r4%ۣ@ӟ>@)G䁁cEax !D5oт)LS$pYyɕXY(7Y0\%ɋ.IubAxoCbAT"c10g`Z53 ˱Wpg/8ať}d%=A(A`Tg)u@ԢhgJRQiQbD+}BQPg Zt@b/O> &amzU՘D)ҩ`:;,X(v"/[9|]<4juQi7?r'p::ށ`h(^ Z*E,ow>|xp i Vy>ztI=9ZdT#G#a 3hqI!ڎ]%ZUH`GF3=Z[vhGUu 9HHZU944 :r$:ztrc`. vLX{Tcc %TonׁW.o]w__ooݶ秗 v3D[Ef}<1`z,^ ??w]m???n>߮=q76CO=t] 71vBBB - !C!LN߱!!!iy4C3<4C 24,C 24,C 24ЬC:4ЬC:4ЬC 64lC 64lC 64L/KosR  i9y_zCbs&-J0 gH5K&`<9ӢW3Zb{*2\&F5b!#01Sϫ"(X{B,4 $ blߙG+k6DT[9 [@`<B*Ι&8gs{)knSth{VYk`2M3'AGm;w%? dy{Koh3!Jq>-Q198VO lGOo>81j$ȟ|(H= ݄x:uq]ϸ:#qk -0N>7gTD2=.;0*.˴k,21Рǿ҂l}.)nf,I/$@,C_H@q.B}Տ̠X⦰S0U*bӓ!Id'1Ǔӫ=ܿ@xSTy) = !,}+&g?=0)X\qxu o^-Ȏ LCf1,Ĕ[kyҖ0'۵ '3H-[:m@tю#QGJ^}MhCv> stream x<ْȑ -;,}Ȟ5Xmk޵?IP h7 dY*2򮬦#:5YⴖqE#mag'5x0`O~|&Rͷx5=u;FvQ?15^UuP w6$HfYiU :t-zM6P XB x?|ypi:b#iQZ{* 1._t4GgG_x-F^WvHa;tw;ܙ H0J&F\z:\&\ZLJ_S 9E9+Y\ H{ƿŇ^L3HIa7PWPF _b_N̾>?,_,b*w"ҤOM ~wZ,Ѫٶ*8 6LPBaa?q:Yx\Wiِ;MՒL(vwlVjY敟'r],ע~j]Fxr?a\l^ƒ' [;5*kRu9&_ yɓo"(׫̾ \,Bw`؁`, =OyrTpw^Sz2Fp' {4n7%Ho yZbKsPYR6K>&E9:h?gU= w+i?J _ɷ%x-.]4zդأRfn`ϦYV@oa!w5<>pO9١xVPmmo7]?,lG `;R+hfF-,CGJ^UQh?_FF`*/J/N/%U$R3l`"by~y2j)eΪnYuLrl][-Ͷ9CjY 6A*^qb u?6"$F<}9~woGIvcSS;R.C/IgI'3%tZuF%=5Vu(< EEF4r/O?PgGSrY﴿#ۍ(2Kl{0\8!rGpΧv*A4~ CX:gކ,Y`h#)(F ehI/|v Z/k` 3{10wXkS) $~f%b*4l Erhu9ݗV ԥf/5~c#0_:[Ȭ~{iޔA5-| "v޿~00io.iʄ!͞Є00taq)ϣH"U$f0IȈ@Sb ghb ߁e[ E̊:=mVmC=ž%zQ$EM/8\,4Gl_ +8&i%zбk?=}э22(e^U E^c(9a(IZ=qB') جW嬑rl '\zk:Pc6!ufu)BX|}ӗc``,'"koHKztdIۗ0u! "4~xR5E׉QnFwG Tܸ; >>M(OAM@8 ZtZpoPt!E\ic^؃XqB.YnO)Bˡ`ҒZb3Ũ 3G|,!uO⥝P隴ZFeT!27Ph M^q18یucv qv&9_H͠nPF@HB "xAY !=jacny 9oXq{,SB>C(ӍB+ҍkrpQ{*ziWm4֨v"  @*+._wCŵ0Tn-p3]e3 BJcі|ʄnO($Z M5OEBVҗGxpקá}KG$R:2{oՏHOlTLB v\Hbs kL33ǮM]B&p)!p%7tw.t#dzH0;6QC;Xg/(U-AG#:+\x̑;<;n'veӃ:kN_47GoO|cO; Cc2:VP.Y- #2<[V2&Dߢ3)3`j?*NUvﲁ^ l::m=TSV&-a%;hYz:n4;2Kԇj!P^qtDp#DZ _N^_ٔBD&+ Cc]V YD2werFa`Pc+4;fc^hVG+s/+ogJK 1 yS>Nq^H*l$TrOhq }W/nL32[hJ4]xNJʗXJe/O8ԯ[ԬhtK@;7)U^IC|~"6:8QKƄT8b>{Mrֹ "d>}:i0vu 72$bqw| 6y_Nߧ ,n)vV+ä]=2XnX*ٶ~7p,]oCS@uuPb8Y5XdWg|׵%E()HIA:$^1IwPi^ lyJ[zE9ZEgѝqtqud/Ch42-0JC ImG6Z(lo 'v$koṋǥ.W՗:Е-iJqVuIhhLŇMQ /IQr> *&>pX,374QDF+|;LnҠW l}*GeEQRMNte=𡕋_墰7 E~S 9) *^jg΄DDՂ*йvGxkRŋ;e*8eK dlo"r=뼚exowJ7C^(g]o :_R0屚 2"%;5}oć/_8U (fF{-%pgey۱ LWБm}.x9 w8qrVr]a:?&&⁉k^kGCSHy::m??S.z0En%/Q֜>_Z;ϳz[@q&U`OµM B_˵ 4ŵŵn|#Fl%EQ6&9_cDA1vC|= endstream endobj 5191 0 obj << /Length 3966 /Filter /FlateDecode >> stream xڭ[s6bl`AUYmh$TP9,v猥9_D~z_͂Յ |F^/ׯP&v?1fPXf2^DiM5-QK>0GW7$]W봪v-ch ee , `MPm첦qƗQn ]IW!L ҽ W>%^<ϻ —r.=J!/a.A{y,"qaX$U`$:,LG4MI ? pt\D MS,6_pUgE4ˋQ T_YN? _&5&ﳤNʴX v{q߁dba]ݟV_iYm^ԡ[V/ hRW ޖIwŹZ.ם[4WЯ:VEŔC̋ca`34Gd'MLC[212tZjkAz>Z ==:u?csj"~{B;_$o&# i~S$P[kt_5}1|8Q/ņL&\.*>>4"_ti n+9 ?lT,9P!+~sH;M G @S#a+ 2skaZ6pKPHwZwӇ.f}FZh(:!?:!װL^f˜ )zCɘ/;LLO_YӏِՅ2`*K]&ΗNg^ ̲N{<~vwYF|? F]r >ǀDC }NWsR4oA<CAB;z#=#toMUtFӢjCI~ ^ AP A!7(hHYҪ+6da>o{j?JNq$,BO0OZ-1\FͱOzxRZ.mfsL:Oft*_ kUK-w$/: Շ>ң?Z\`CH$?y&YKx0ZkA|,Z_Ihuak+iKFۄ"^4r:gJc ,l_XjGD`y\p;[q܄g75 IųvKVyF0 Y t;lMM` ha_s|h*:]%iJrujGd;۬NC-]PTwv{otVJ(8e'Iʆ(IwympqxkjiOkx"\b^Cf^ޤ'πQY  gIamSK*2\& bCv:m?\ !V0gaJ TgSn8Xe%t?l[".1sYO.'- p34 l$U<IIy:krA^5>l.ˆ/ܧ^U=]|p]b7ZT?TKyo~Ԡy4ʔ4+(/k Fsg#pU=j x ۾"|ipz`XA3E Lps/ zJ{ՠX5_2? QdL!Ttxu@`RzCiT$M;;A1zǟ޸}3JY$t/j靎'7rB4͋>r0Ai!onn Zv q7gFB@v_rrB3 _ˡ(e\garuq<&Y l$wt(@b4)<,*6uJ^gv'.9O\1{3/ $)n_8kZ d r7wWԱ+, ۆq &ǟ\ؙ8[^X '!&o4i^rW{&Qg d:Ix,>c۟&Kl0/AHB7o_"+=n=MO b{y  {FÞ\Yѕ5o.<{W/lTT]AC7;,B %u |q]i/FфGHP1esacOPb/YfNelz ?4i{y x|$3-)RƄ%d2j"_RmK\ +4&\WsB8ǝ5}Oq?ONj>v7EҙęXG,ԨORI}>& ?NG$3;áqni"2Rk p<!~)TL !p#&͗P}{2"K\ fXfV9lPH]J~uZ+TC@e9@;1&+Y}5'@O@1]jRtTBD9TxD ].F/H *:/i?,Qz> stream xڽZێ}߯`YEI@0KذV@HzXɓ@kF9Qm@Nt݋r(E$?1B!Q\JDu%5T#gPWkr3BŃTZbH(_q-F|ր6NXaS'#JNG+NZuҬSzcNuJfJ촶-E'3.Z$IT<2L.xdSRBKi (0),[()N H%G!TQ,QJ9Rg5JΒ=[" lPYo$YYsdkg]dkRXMt*{j@t%>u'UX@!uRQU(RkjbǚrEs5"c ;F(~a›҅6Q6kJÉF kFR^Zl>n6؅ 0lѶ;E8#7Mu1R0";C;_U?~ߺ̓]ſO6/~^ 毛6^py}s{U=$d/&Xݿ6gnKy_^Kw߹~8$a'j B}mzȳ'_ߓ%aH }qX+Ĵ/\`>|xsBxq3WgV :Vu.\]7DC]Ra60~dyHtH4ϳU)jjytw[oNwՅ/w?w[''nO'( v;=0x@`c{nCnN.ߝmyۼ~޹7_;'xbs~tnq ޟ?캛micW5GdZCGl+5Ja(dˍk"BHȃAAA qps889qp 28, 28, 28ଃ:87 %d>"D/#"VBZ(WK49xB '|cx<˂Zِ7"XɢHvW !o,AHXK~?/C3! >ҳc6你iuA}*,}"(Pd`Iy%}pǠzFoaXZɲ`lK=;ӄǖWpD_{_W}f#Ő tOũ\Zq *:i~d)@C*KDgH#>GFkHVouк>\! !}$:yh!%/!FŶ  Y#`q HR0hnl/PpŒ]bAhN2%"G)n1C =7A,:!ij1clIxjPYWpMAZ@V=" #ALfGa~z? zhD1$Fy`8>`$IϚX,-0sy gG|KuC+d’VBiT5b$W gqlgvZչ*]dU\$ @( lLhO3WU\Թ"(w6j< 3r`Tkmzk8ӈ/_ӿ<y~+1Wchchch 68l 68\281w\28 eps\:8upYO=]1y`1iIVfQN#jZηLqUhsx͈x-_K؞#`qBT1ie+ $qPG5U Sg^rHFEh\rFĬgF嶪b\Z8x)#=S!Ҧ!XB[^<[.ksGϖ<9Elrqސ.~42 j{9kw +m-H> stream xڽZv+s,*qOqNIƞ,F-nN(R!)w{>$LW)V $#惤FFJ?EkE$@~-/mN˪.w7<\:Zn哛wA gyenh~{JEb.~y8"F y$AJhX>h ?(Č>7S7E .RH'IƊ.p Y47Os,?tEf )NRHku3Ml);~=+/8 xbD@6vD8Mt~?v`c$f+њ}mEBŒb{H>d"7L`&8Iڇpmܫ {L˼k)K_!P1[~cY% OPQf>>!? lp:.?YFrĸ*) 'ʊ[} tPAR +o%`aI]9?"o69JlƙBIqcl61,s2 kr4'YcQ ۺ쭆B%.C S'J0C b6y #JC.[JHPJT2͟} 9}I|u>&uZa" N#D\!ȐI8O >&ezq#.4rfH' wE Aci,5K 66DwS?@71ng@w,x2ʽ`\t(]UU恲ω3|UEzZuFqn{(WdWpk'H"Гj) 2g1tJ19'B[謠"8RA3B5= Uƹ>V0MG! ]-dxh-A_*$y80T*bz@ 6#z(-tm p|憍ɠuSSt.#X$f}ams(lCAՓ&N Gw֣VA=cPuq; *j )sqh7r -eT,5~g;lC5MQ:-vz42br;h+Io]\$RmyVL'Uxw.i~17l"7U攫:s$^ɠoB$w*6wve'ޗBG59"JkNzomN# )$lL0c2aݫM4%[hnhBsǛG8pOղwNs4p˾2M89o6b g t8V'fgadB#Iɱ a&'ey7K 2gLBzDW#ū#aնt5fLsF!&4klhh[:¿GY.nҔS vKo * @73"nƶL/K[S] c\u(kt<J{B'uP+^e%g.;0%o)BJ3oC *@P*Ҙc2':/IYGI/W~ AYUd|?B{ZK%:3b/qϿGMTo۶! D e tCUɇyW&W *7i͹d)z/{}DثyHq@n ث#BFkNYJd#7@i:Z=@8F z$PD(U;z*J7po/ڍVqKXzGm/_qioQ8hWD\~n頨&O}Iaqk8@DVWNlVu@94bleYѐ;xb'aH=;&Хyd`7Ŏ]caYEd]c endstream endobj 5212 0 obj << /Length 3395 /Filter /FlateDecode >> stream xڭZm۶~B3:>t&%Q>gœ(D"s|Z!.>X(=ُ̂~x3Y-73.*X1r='_^ /&}*պ0 ,0̮xnG1-LHDk]tX izKπ>yvnkz<үnviY>/N*ItpxtMZ1LKS73y69Z;t鯗i[fTrlI:OK$ 4if5u#(qAM%R 7Υ׷Wx$TdUWA14]R/2%E?tTNV- VL2cOu+PcPj\y }r*[DC /V`H _RCd}]T99xDƔ%ea U&(HW%Ɏ+ jQQFH)}tO@q]?6ld; C5٠4I,kMhéKJó0Պ.#fBH85F6Bͱɸ!( ńc9 >.ro "ݣ+(tZܼZ.M#z@zB íQ3j>d.$ p9b5_N 8gh[,hig [YV.A>'ҤnwCU6 yQC^MZ-)sJ &W3*65I;>ºAc7yA""Оz3{wO\ [Z"DYX1V Nex+N5&,/~@L*iR$J >.?54XijϦn&F+g.aHXLLn\fK1=L-ֲ Kؿi s^9U"Q("-?rۀY?F!;]%q@/eLMTp d/8.% 1"vמ%fhWXS'zs{ _2`:xVkqC٤bC- U7K|;m2ՕMZҧ$6#arJmk^0Yn)~4%ĺeEmc2K(OG o41Irvr3..ķ ŠHdV a'|iEíyg=Y.k}Ն1cc 4bOF`~bКˊ[*+F=3޹X V%S>p8s;&79'[h2->uTVLF60QtVH̑] db] ۿeQjJwM;n%8{ӛ"q< bPGN<0hfwh}O;)aְ#uLJaoOw,ӝel{fgCznqxJig3جe{MQsY~ǩ{uJIƐ?% $z3& NL Gܼ'nǴ(%4ѝt3]5XI44bD}ڰ!6ه11iT\%4\j㯡PLEG)zM45& #}?广1BSAh罱%*-zlju&aӬOe4]!zw۾s[2mHB7 SqAzV݆BQSj= 0m8P* endstream endobj 5226 0 obj << /Length 3628 /Filter /FlateDecode >> stream xڽZ[w6~ϯУt Ksn7ݦyIF]J;aKsE"A7̐nf|3n_]={sfBDk9Z̈́L`ƚ@̮هyb)8][nRj>ߔuZExwHb0gK1.Wk|'Bϫ6yAFFdU]m =o+zԮ Y-7EMsP9X(bI"afgG z]B̋?eMy Af@(T ^ߔO(h޴M ]A_Sܽ-LQm]>X[-UUomg]M7Wٮ'G \r״EӲdf|  X,Nƛs 0bv=`%N#%^jt͖T0tJٵ $Zc8MߚkP5*ZEH*JXj' 8Fa< ;=;z3Tu>35^̹SClۦУv=7j΋qMQx6F" =9B<@1\R="UN!mͺoP{5O{>_UE/]*d-_%S1雃$9?_JORteks bImPԔ͝m$zɗ)NS~-zD@((~J(Fұt2| KLCL8%n$ n.L0Ο2bQv(SMNL%ۮK;-_RRXFkM@P:GѠ6x/F̞ӇUِ .S]qF3 0n/޽=_,A|0ȗxx{68?7|AwѴ>HCI7 I Y/<jtKC)M0S ^OBj`H4a&f/||7[n:ϚqȔܗ5Վ7gnSLF0|w=D?O>z 񧟴!?sRO pd `aRN~azOn@7܄#?r; wjx\LWX4 (hcg!S%Q&]@)#?*ccqQ&E=weWlJu'j 8jJd Pk.:a[hmr17I]pGY,D(m.+"̖Ɗ4-7O^(.LL+*t3:JМΪjMN7 [6a)j\w\$̤(le#'#5'I4e6m?5x;FMtYiSLz SK^4͎N9sJ#f2{ںzyY&)Ƶ{܂۪i: ] Mks7bԱW_TxoEQ`AOTQS B*3CJ&m <{J S`\ǤKqPp1ui#'Awe1cW*H-p_Pao?bFeciœ{|fV1/ FD2(8\aUQ;R8uL7% $ʙx؛ YFz֥Z_PDM&O )u8ME.(#sDc?x?.ba,7T:M+pjf qNa_e  e~g[E9RMю}R<s@gM%qk`uw]UUixJo@Mz(5<̭ai>zjDM*0Ɖ4BP2,"fM? >{5j8?& j;3Hsc.m-CχE8fq0B6mFp4ى&-p-@-z[2K2GHW#m#:烓:bu`ý\7oØE>z.P%O;~RTMs:A_@|k\`~qM?ƝELNolY9&1m  @e-f\Ef.@HNs[#Z~Lp[ȴTξlPJqJ~g}8qĊe ZaϽJ\" 5CtU|;Wxb:ֲNO ,^FbƒT@@2;~1̗|2ia !c1T/ endstream endobj 5233 0 obj << /Length 3831 /Filter /FlateDecode >> stream xڭMw6_#^ !u]IvMs%(D$w3Hq/8|ba!"&?ҿY^%62P֭l}'}Wy>|Dr7f6Xi@ +]0adвXsŚP@ѶM١ݧm)mXfī\ϑ} <0X6yc}fEhY9V+oQюCdιw w<u +hL†n -SRVL-(τXwmm`,$l< G:spX˷U5Q@}HWZ?O_ys>`GXшX%xɛ˷?^I3vF5ȧv|a 06m*a#2@i4UNܦy525^xy9%QyM]αchPǕeD>޶+( JLtlbdsv dk}heGwR2eRמ*I|`D=.NYA>[{&0Yb/HA F..̾ s4%I{[f?/eїc҂qr3HSfMML{YV>I)@p Ck #L9 C!{(}"Ȟ7SBvtj?kG{85%2i/ =}3:`b z\_T\`9-1y[!ÅPsbG:[&(HB D`ndTYs, cQR 8Ww=b9Ҽޭ?9$>RT0_j9bި!QpD6eƌ[,iėęL8Bx^Mܪʿ' k_vs[HRF9pt,*#ԋN ԟ0W|L$?Wފvs{ҽB|iQ r!NR.2aw[b aޗ%=XﱧvUhΤ>)BOMG ,7?0e_EF6Wsͻq\Ta|3LJu_錈 RXxN{IQnˡ"0J&Appȑ~8W+4ʎI"*}'#N$Рl`O;l}ȎYՠ&;ˀ7)# q#]; kO(`Wl,7VfztDs=JP g&kKnqys~S,,w}rH3&; ,>Vf=_(ֻK(v~S'ߋK/nSYENIGF.s'0ZayI8×Ldǟ )á O,T(8ʆ9j;tT*DО^!7 4ֹ3:&Y>>87)+z#yMG> EPFsڈ^DN}(gA ؙ{&wYe9v]Ȑt JF)`SATiy #&U%M sOGA\L 1'~@ҭ(Rcwz6J$Q2KO^u~T _s_xk? dh,Ypm}ܭ MLDy8:W^D,3эFp],Jm_[~wʤ ?L3dD*-3H=PiU2ww );v3bIs[_Y1Ʈ:2-4\W ^ºV BJW`cٔr/B^K־>wd,;NX1/IK^`)6)nہl#EI\.ܾ~9e |ݵOF+!Q `f;|u[A^e1z7拗!G5WBU_\CHPKLw4.P7qixTU]fHȀtpBQ@a1Ps bm DN޾ah/M_yۻ>8a~)=r"jp#2_:@87e?zY='YƲ 0 %1 A c.G#>Ȭ?80'ZC6 %4O&?> 0|\þPbzW.Ѳ$?D"ȩ<ܾ'rr 2vm`#O[ .s7Rarοڀ}I,R;ġD:~3 hٗL֥HxZL:?&бD x&^~=_(h+s8ѧBlqlt)yx=|$10S*$>0ZG?[%X+(y7weeÒe.$VF}QDL^Li]) ^~ gI#;v"E0'3P{.eCm!+$lacPLDT_9zATL5Q_ܻ:ʁ*tP]" "%e:?ap endstream endobj 5243 0 obj << /Length 3234 /Filter /FlateDecode >> stream xZKs8W(WEXITmqfJּD[H/I%ۍ!cg^Do4)ZŏϸxV,RY &aBfoV*~[`A.}Kufw]&zySms$s)6f2XPUݴn-} /fGOMa*o|+Yf2:aG+)2ZIJNC-6ukjۯ ;>mS/E.|_8l+G*aIfa[n;>p/SdU~5'Q;58_{[+i-VMopiW|/G6iLeC/<܌L@2+KljPç#8ƾ6È껦zv-k/A>2:yAiv5 k&ZMup*O):慢BBFT>X&Rx&[o9_mͷNpn Tf03|IAm@~~x; 7 Sߡħq:._ώ/v  ,Xµb>Ҋ+dYDJۦr"IR@`P?6H{2a9̐VM ԯ?N<[D.ujBna3Ze]e^{&8C%d9;짘[0VPAू8!:68sc _&20`FdQ7 `_{ϻ)~\ #fzyY&MhOZI @y x ;=$T mS*f T0ӖR:P)bx3<{bw:~l$7 ř4A6hR4Ak_">oT]:Kn8h퓬9@ɔ,K](ҿ*`md6[~)60k; ~9=4 &.kKb #9O!'|Aɾ:5z=P@XܝajF ٜ?[zohKlsUa=ȸ硖f-.x蹌lZr'uNFOY298;yuyˌ 4%IlwԞGVfatm8tYޢD7Z~͔=bI>ӈsZSnoHi}Mvx53{1^0m.J"B`-)bƙFSwJ#89rccpM)eVGS:BHˤLٰ osi;8f8Om0zNCmsZC/eU͉b`M{5>U0wv,"tOQjnj&3_=8 :+fLYPSݔ]yZ{ dfѢ /gXpj?cvfMdKz78J9<0\t: =P\jOxkpE R]l{Wܡ5qwNh-H]Br|nG v!\&ciad9jLvI43E䣘1$?;JV#2L&HSH%ǙmqmQrGnN] H1d,A-5sا˽vu*{>>O  ?Ns>Y3҂U b;x.F 8> !e7/etA'gxChh"dC<8lЋUsը#w5;?)>Pc;-/Ms,L'13]̒C5?y+a'/8sXRuX1p~w䐐?.+eFs?SMK=|d|7_v߇ ׊F!8?D 4 2 0nO}:o1PǨ?}N<ͫS_Pd˳ΑΫ2ԟIQ+ j㒫̸pT{k"\]׸$.0(:4y@t:{{:CAbqpq N[GzxصsSuÇ ^Ds}N%A{]JuW&CP+{!9L~cu endstream endobj 5250 0 obj << /Length 3286 /Filter /FlateDecode >> stream x\KsFW0Iv-DUv́hITDɯ߯g@R -9~M^z`YpBjfP(I쿬<ُ7_ƯLT)ł)By3:;& W{G1^0oUi?>Tx] O: 5@Ύ9gQ%x`$x5IrKpd^?a/ A@s=Qi j8Ad׸pEet81\> a"&"'dv_ME 8oa^u@@YK"LՐIDsP#xhT!BJR2-np4 8I3z/}#)56h@.8Rfqi&taD~0t,:􎛄H@:r$q#G豸Xq XżQm>DzHҋ(Qi~Jc h9f7ԟfv1YғEg)vr5zՆZnX  md@9oC8! ^dž,*!l+L$&U8KWT7iP n{@A ~,18昚&1aE΄ļ-gٟݤf\O-{t9Evr9YH|\҅ϖtiQŲuX0(}:wEkH4x9hZVg"9V2d׹ c,߰ B69%rUe+Vd@ OI4?YQM.QC[1r"@>QZɇ _tLXMIJ T:5ؙh7;lbgZ:[z)8\T-Hr.a_q(brIb(n6'˾dZ I@CACSjQ |J&S.yL'QRxD?(!S(BR `F`Xcb_h3^u4f%V?7F'#:nWJ!i{CWwGJ<2fS9@ ٜ 6s`F3 !DQ1ޑpDό 0$wcS _~ bqoC9GB:5mTͻp .RL͑oաQ4vsMw%U yVΛ/m1nL:^9SY炟꜊8s*PR"dlGr ơ" P K4"f'YʶZ^1D/뭓{bwnh }n+teBƮUXRI henuoMV©56@K_7S+IJ #>K_n0PKkBR!AUr*F|{/%oov8t\*NjmB+X-`FuPdb NuZ 3 Hk<+5@ГR7"7<vLc!#Ib D  wX4QM62T sJtj@W.N^B F ͘YVhoR9P„iv &W)QuZ#L\!X<"wGTC}3\D5Z;BD(^dva_/cTqMS9](E ](%1VP2*6)EdkrRӎskϸѝYl/7Y`HC6{p66Kp൞epuwڠ~eSu4c }if4 }8\]/&/d9b$K0NK`C8P$ 8nʕ@gSs\6'/ǘjEMiK\>tczWe[JnՕyVdz!{h[ER=Q3+b%d?Ғ[6R#BsnJY?H\1frU1ût9!J)T  BHT!}1Dzk>hJ4we;#*usZpLY@цEUm8G?\գ:7kQE"sgCMtĸsyq)eBk9&N!*L8/fSa ώ;?M/ <dg'2xҥ{zxrQeN^:y0UeGqrBtZ8}Tk@6H; endstream endobj 5201 0 obj << /Type /ObjStm /N 100 /First 979 /Length 2138 /Filter /FlateDecode >> stream xZ]o}ׯc`@i5b?Mjj2dHʒZd $<;3U\p29l;4TEUK)'W)gW#PLy $^Z$vy=uTj1S%Jv,+Ul 1'I95(U!a(r&a htEVU0C doQ!PTcHI`:&rs.;bb jbHSӤN|*a}Hڦ%{%$U=([6c42&Yl H¦ _H6H;]"eѮ__w4~6:ߌ?Cb4~==[7\`V)_5xE:f}>u7~9; G>y/G@xuD'8xK0?lrt'<$ .EOp=%\eG>!简T/@x,x e}⪞AWO>([qqëŀ"gdIŋ|ċrJܔ4) f\:iJb1n| Cz4` 5 {XEܒ,b'_V r -ڍggY&݃ u dBҭ"Saq}1[h: ԎCڂtm7[n(هrr6ur],_&k8Ru@]_ӕH?NJ|vv2cŋC7>~\wrEhHOwMg|Wl("z/yîwaO6%}SRg\&+,܎6 O;ٸj D}F7Y9U_4U\eNmFeGCF+7ٝD1\s3Yb7b&(VIz#pX x%Ȑ!JĊ: THvU5ak _S֗QH5߯1)N&Ij yܩvjuVC]> 2]O]^Qa2XjgS՗քMlFDeAvJY|1M?\'{1"#wo;myP|\ug9YsrB x8>4lyא*5hJbSnhhJQBD~M|P}ÐVX6sl,{-чjGJHEb6R}y}<6Qbؒ:QQ9^XA\[\6aJV~m}c$nmtk[hR6#_ʈnmTڨ߫jk͠nmc[{IYQ^ endstream endobj 5312 0 obj << /Length 1303 /Filter /FlateDecode >> stream xWKs6WH΄($LmIqVz-g$:]K`=V\|^,<FO l;#y*32'\qdrlAn#'iX6N ,`OR."~ !K5ˆD=\xxКNJP ANuDkHAdƒF>G&QܞcA1O J$1Vb Me R,Dh=~ڢvĦ^ڪF24{/~:r8 i+h-H)3]68tqfÊr]nb_18(P2*coqeU*FŶrimDEb3 )U(!u_l) WI*~ܗi@MQqx]Uxa"Y&[⺗rp慎ݶ<)f\Z!J*5\yKfd͋ժ<ؗ|EӔku8}stk9>A =.,ڡ)idN-р4, =ؖº$2050l8^?[A41̞ZE"_%D=I" iL105pB4etHkm&?Mw xbx [*\|K%U DH9CTk@|$09gvޏEIC%^oy ?N]ù0:5\JCP15!8vDugP<^kL=6k88L:*5 }qI%p\*rwޭCMhf ];&wM݀98=wÁ;0ng/_f6]tw.w9/;0/oe(x=GyMO«2,0N`>2yBe±J\Zd7rx`VrJ endstream endobj 5317 0 obj << /Length 3484 /Filter /FlateDecode >> stream x\KwWhӆL#G±=xf\[NڦY(fYv,_2$K"'u!p{z=˂S7xR3#pF f nzgP&@wza|bbR,X'E*or+jb<*N\{'`ުȁ׷{7g*ޯ۞dP8`CҴP[f]-!#R56 +x; >h 9pjxmrH[!"Rz?yr $8:N_l(2,xᮉ <;OGyߢ?,wp~Py_u?~4Qx֪RRTC~\##R xO(*ק>@ &W)`Ȫ %L)7E0[ n;@A j\PsFqJ"p0=NgooGu%x7I1r.;( 7KA¹iIO`3wyͯw?><2n Q`Ү\MF^#vt:+6-l>^geR@e7XKĀA(gf_*b-|p(%"LD )<8?j>9N_RdZ, /8 ,#f 7=H9ZI݉V)7ͫ/p[5>6AaT 6` CE) bSSzuP[jE41CM bm4tѮDJ(Ej oXAhAc9:,#q: #Jd$uUM. Z7R"lђDX"IбRJLX/6EITҺ|ag0/ s;lr\&k~ p49qۨ*Uf_[4 :a&aWxl5J])/Lr$LӍb  nO-al}yG&S63,*4r[}Y8ufڷC54)Ş.^.^P 2ynGӲOZŲQvh!LB?D dNC*;q\ . 'Ys)wv7y烈 ZÙdE()v_Q4RWҔFf1۬5Cꮦ]ְkX[)ۡSDiN0@|];lFp>LXy Q1m;搚yGQǠeps<@VJC/.PAnxFËfMn 8CGJDE}wtIŤ7d&f[ɗ;W?mGskΛNyڶ #f󇻏+SUf5t8Yr H:_rڥ])itX-VJ+tNϮP>KWUO6"֣t:F^m%C endstream endobj 5307 0 obj << /Type /ObjStm /N 100 /First 973 /Length 1368 /Filter /FlateDecode >> stream xڭMo7 +tl/QH0N @qQc7X\vb ,b9CQ5ԫOԆhjH R8<(1FEwzqۄ% {C؄G6aK:F3FgakaD&A>qwn O˦% V ,EpCVOx[KUB btBC{Sڌ-KtB jOC18%Jqq%Xs]Α[X"D՟Nluz`7MHb?qF{.Nѻh ˦GOhkLM@ V]oB=i"c Ej1O6=Ú4kw.=:2{ {S&WVwj-nsŁ0!͙|1pm!FWAsEP:W:WWcA>,6W[6y6gLustY^SdLN˯Qb炓|y+t(Nf084\Qd/,A-F7d<%3i5Lw6,-J钻Z0M"YFK,+钕Y5L+bF-L % Ө>V40c#LBqr0]Z.x/h|Qd<]'n|^~/Og5l,ǻ!xq)F"-N㴼Y?ݐq Ƴ=Õk9z]׫5~Y_=}J @[:oYn;vz#|> stream x[ms_N3d'B{Rw&ԙv-{Fd5RR~}ݽ;ޑ'92Nb/.@;97lS~g_0qid(~J4λ˷7Sg{Z;r1ۣhǿ/ޟkDˣtv[KqC2!bVpCrBGtpbjB?|@lk툜8#tٌ'x/:ֱb<:dQ5.2VKJ g ;d 8YV<>;Y6*MTLh/@[$S/ʲ,u4~]&d*mo^)_K/^q9GyKyu)S/:S@|^iqB h8}E)cCҡcm-uO*AvBc1I& 50%.~ֹ0kpc-8ӂrۺbDV/ LK-lLkK%'bP~ ~8ۋ1N_ Δ?sb;]/Jed|tu}cg"AD kyhMm/2dczĂ'FJ)ci ;iP^*'gU`_64o.62ZW /(n`$R%>a%YľRWePilK qś7-J:oշv ئ4x%g3d|6^>e5ںvfE29w^%1'aQqRP=Ukm2 ocLd2az(Qrlb-;OP/tfoBxR>bXk4L1"mi>΄֙Up"X4(׉gZ,FM۷jI0v;FD juL\/ɦa<[Dk;ecq~k&Cf`֘>ux1C1[qCXq '^@ '%'ek1L'6fwAԝb#׾oJn8ɰYIDj3.Lq oKpj- %2LasJ{3MĊ┋+X92[@Ƈw3@35xpwZ0]Q:WܴpSMT3RHo д fzf>k9?F'bqYJ =@eRlQg8쁖W\{4ظ2A 1_iyq*/F96\حhG/:zWVH.~1(Jn$8P4`o̻S>ZO "#BB}smT̜vCA+k(xXd#ΆT4ߡl79V&0s< v pVAY C@ϒ"WM[ODGoLe'{̚rckM 6y (q7 ӦƮ.,z%$73`*Gݠjqي#yA:gC ݆ ?ZD mED'CY׃Meouc%C</ܫ$S֍WiBR#vplalf2=Q5X>eCGY0I?}EW#%̓Oz󶼺:mG %7w8+i5ܠd?)3H endstream endobj 5437 0 obj << /Length 1232 /Filter /FlateDecode >> stream xX[s8~ϯdU-_:83`3n2KM),6I}At9:.@V ih%s a05&HK>kw#a-}ٝtZds18K\Qepi;[])ש7bu-I\.IʤvqV%10ltDz#NZ|hS\ku1isHZ"3(u4buyN#_,6 pl)UVUTSJ?x…,\B]p匈J~姼dXw,m4-_]ИM薬nHqtnߤ|?I^|=X ]{Gc a ¶\6gU>wg*Za\US="T&I|o$fUV}lVHbnKK?HR2`A\d5-= 9-OECKf)YGMWٗ6*G/89x84%@xEqm^TuZ(a^$3+lY쪡wي UTr}ܕU}heVg*z߂#+ܴ֞ІZy-eQ1  }K]j| ‹蒍#f wK>0#M>A3mw8ԩh("|'qNN8V:Ijz2I'u 2J"a@e]dÁ.r=7y(YPoKlF]PYVU $Y7e6F7dB7SZW;`DCPzv OM(5=Tj=kJX D+ئ8F)^֢u,QcQHA\ Zrڳ3gŁ/|z휬!cՐvɞ=U:CұLvS %hoKZn=Q), 0}Ul6G_VLF־ Z]* ]w^d79 '${q2 9cWǖR toTj?:Sc/=.6缘Q8yF`&kHum4 ~ endstream endobj 5441 0 obj << /Length 1008 /Filter /FlateDecode >> stream xڵXo8޿Em9jؓ!KHԄ)ڢ%Yg#zjԮy<&@yPrq189 ]AT{Hm]AҠ`xG_51{}t\oכ| yNĻ ,xW3 >SJ*7kЬ^U[aXwZtgǙFw"܇?*]Eַy2,B!-Q;sѢ >93W- //0p&\ Hw#f`t0',/'[,y$/d5Y%6N(Koɭfm(YK~ W O􈆌2^]$ۈRV;Irl/_XEK!n R=+Ҍ/)$RHכmqU_M⮷IL3r&M>gNjB*Y9pOGt*;/緞9Im$.p^⠀ ۖA ԗKP- ~Joq0 Y9ۺ4$%0w{mJ_ y}94 HG3jf2@X}w; ޕp0CJw T {<u Gob?=chB ^MszŰ;7]5%6?+|uhF|c=Qh,_,<~qc?MOx>|w&_=8כUT U#P3&ofXͼ | 55LWU|5 fbo;c.=M.< H3`9RƻOC;Ktf<>K @P> stream xYYo7~Xh-Ûyp;Q`Kh FGj9\-GFZg8GFF4zyDم%2FL2"bi,Dw5ݞvݞ|=>%4˗b-1P7-Wkc*.[`nQ|c7;6%p8#oGInnpd&ehlO8t];v(OQN*C^ %M ς:.ScOI4lYfytKlWùIn= 2Ej0a4l"J=? %TҎqhs16coѫkNI#~!uHl9IupvI; tD΃_^^Nl5^%>Z}-$u6q%9p;YkvFv p6_: ,һ<`&Y^ڿR l}wv-ul,[6t*v6EWgcOs9՛,޸,_-6T.b@E#q)r+̏~OX]f'G4EGTV-cHPgTrL$8argtJ' *Ӷr"^+A++ G#L'/|ICHmUTT0i.he6+(nBzDW]a T6TNpȀȀ㛶&u' fRQPyC=oR]]'Vucy}B%e(/781sJ)-hI(ՑJ=yb$0eSȴ?FeV{FPk܉˘{E[܂;qTob TCfL#'E\ϟ@$Te籪ĀQi &&,]A/ /=Kqɿ-Y[o66w,F]LqbTsHaJkRDL p:Щj˨$ 6 uՄ`q m& f@AmMb _JoV$D]mݣתP=kQEZ#jw`0|sj~3 &]-z'l`^N96#C^wUpBN$b DJ 4ue/`FJ,Be?pHFA/zkcrWP`b`r]FgM$[^do}:I X 1g=kPlk ss VX?A7 endstream endobj 5459 0 obj << /Length 1408 /Filter /FlateDecode >> stream xڥX[o6~ϯ2 !)Qm&b,vP`i`(s匒fEHP4H"s>;;?aMCdeD 8ԹlăK|3ޜ%y΋K;|}_Ή[s<9ù|/B~cs1T엚.zZdz2N lHeo\\yѨKH0Pٜ@tt1Kl Bxvq tJG-t7<€Oijr JTyBI]FM8 b`'_p+QweKY=M&ڪ_&7Y"⊄*sE ߋD0.d\Nehcý7qd hPc"b"{B`?> stream xڭXQo6~ϯ2lh!)"aMEc>rΒ Yi $Ji*>آ#Gs@scMD<0Nr387o(9 ᛓG{ @F-;sVg4J£SULFv(zk|X5yp5MG&TPY>]D>QR*LZAqp*{"KhDAnaV s1l T',A(K,jN!\ 2_b1n rg- ^z򊈩;1Ɗ<M@~d7PYTfF\˻6}2ǚ囓r*<͢2z w@\pr:s-Kp}֣V)zA9 emx P%j,MI Õy PN- j3v&Qv|xgLrHpyzEI>-^QrM3(|A.IQzm7nK[zv N-4S7?_ %~Kvê9쎮?R{%=7څr׌Ǜ[6YyV1mGk,,KCh"j}]K( Jt6wl蹛7XʞZ: 8Jdnɐ24\0:=BK H˥۷dY֪MpƚfFA: cBp@e-OA]AJd-/z%;M#FYX+CM+/Ve6M=7Z":^* æX[wS[C:ލ~U x5=|m:9g@0OMȋFJVlM;:¨ endstream endobj 5467 0 obj << /Length 890 /Filter /FlateDecode >> stream xX]oP`&[R6w6mVmj[6حY@Zg8y? { jg0}S5ΩfN4D h`c-yg^D*-`"%#lv¦ȈdȻ)\+{^#=oa1f袨-ok!LNX'䌇h2y|e.`&|Xat^^_^}vz- s;AbVPT  QeIK|̞ȯoO"BF?c?\-zBv*jnYfhOkU1JN)Q}#MƱ4l^g0[7kǨFf<[pf[sQMcǝx7ƶtm*/^ i溃A ?]z{jDy\;6<^/[8K-Re+&پWI#z獚 gl& Ť~ҭFQ;F$ydTSbm 1ؚN^C5noKoW : @^8*(_ ~5MAx}{j,#Q ƮXF^u>@F YA^(QV۩psbOJ>r%f?뭉3 *HyƆ A*T+{a%Ŧ0X[V H!mAKB?AؾW>V!V q&ĴZ]ߓH g@G2VEh흨ɖ/>H@p̓?E8:D!Un>L* endstream endobj 5472 0 obj << /Length 349 /Filter /FlateDecode >> stream xڅR]K0}߯a5ۏ4UDa0X}چ6sڎl{7mNs9y!@Z`&i]G8 H2' c0R$wL-uh fV%4N Wg59gΙPTJJy%l|eatre{9ބ>W[&Ek^j n8ثckDFbf=iQ"5ӅH_iY^F`8&TRyC{'M)1[}xԗ,~ASGе]uĺ[ !Gz6i} endstream endobj 5476 0 obj << /Length 1702 /Filter /FlateDecode >> stream xڕXs(~_63lɱ/$7i\q:u2a>@IܿV҂~'I v?F]owëi/< ƧӨhDqoz6 q[ǽodFKN3b`)), ?A4 2Ĝ `,B&ru5_ve_/o𧻓A l^2Oem~> N~g{cML3fJsszK3d2N8Z,J{psJ>՗ ek۠ Q;⌳Yb)#EN[\/E\vM3u%thG>~ L[$"YO!eiVKg(eؙ11Y ^^j+e{f+q"As~s bW{Z|1dqz]ח+ągVɬr~7_|F }";)FMn x &nm*qwuRTRH˲qz 6@l4L7OjKg)ùA+ qImY6J .:In j*'M#()`;Z<Ƞج2}6A2&,SK‴:1dn~E-.E^{D'Š{4@ &0$9S>: [u.쎩Rh@:C5%)MEyJ[|("<{&ݒB'Fg9En@Vs`M$RjC^n Q\Nl:i3?G ?F&ᬔm uk2 CAN OJ]b3BLNj ͪe@> stream xڕYYں~?:/x_捙a HRь=#U?#PL@n6G&gԖŤ2>K**㭲,ȇ c! J(;j@ sgb}t}sT7a{l^sڥi-#Y?]0`^0}iHȤkSG=}ӹh8f}!̸Un29B3VyWLI /¦"1z{BW@0cdS2l1pOwr'^fͣ!nrK(lB@tCVQQ*@AD}Z%QyR*d^f5nDc/ݰdf(+VկU@ybISZݵz,sRKf=C+/ 0bmٛiQR+N*U}P*g\&en>[w[/(jjҤB 9Q9Bh:cs58dˌ0soX2:;fZswײm!w7b' zuxџc^ IAǺDÉgAt-gy7+2l{쑎]/g>$2+SH3ڇcmw!{sg+6?RWV~=n!;PK}f:']cXĶ\Ӛ16p8x'4ZD'k.Q|,x_Sl|1ߎSH/b( HOn"5x7rl3cL"_K|k>ep.` ^µѬd0O6:0;Ȧ)p{"msoJ H'РO |çQ -vl7vˋaa:q^.F(p!_qv] GIe9^rm^QADBJw;>x lE t^rpK4=tnh#? T$ u +NPu(q\dzŋq ~"}m75C])|Б *~! c*P|2 yka?lbc q<@f#|k$ɭxxe>d[aGO;1ͷ#{k71IQʬRlv2H)b(\{vs@ +闟fߎ=H؉Ġ;IQꦂ<*xԣ2>T?ĤPЃ _nAj6멷r-HQHQ! h$xTĊ["RHTOӋw@)4""0\J lO#x =p( GoʯoTC['1$1Pp yQ7)T8юV[)i(P@0+3Jwn5u'&H)/ LCuJl@Bnj f;pz?`U, ] oYY!CExVY[YD+M],MULhp IgmEWy.KBօt}VEJAaxU-w<I~ؐ*–YWc9WA$NuC>: DuJ֔T9 endstream endobj 5377 0 obj << /Type /ObjStm /N 100 /First 974 /Length 1571 /Filter /FlateDecode >> stream xX]o[7 }cY%A~,]n+2%= x>_` |a&7?'ٲ/^N>>(էq4*hTjhTچѨ>Gь8 DvU>'[} ϚO}. n{K'UrQR.u>{> j1fOi{|욂/S?\kBY u-s!@kw9)zx@bSJ)o~]n惏 I-ZltlßE3G+;0G" .l:k]R"w džŃ=ޝJY ~Yx{IF>FC?S k>ҵ) Ml5ddd;|th(T[ۡ "fR,h.xFsvUa0(uM*T Ϧl*?ϛEmnL.gt}o]scc펭]n/SP)(t(  (ȃe"p5F4 6p]ou9 endstream endobj 5486 0 obj << /Length 3596 /Filter /FlateDecode >> stream xZ[w8~_Z%on-ۙݝ΃b3Ne)+j9>)Eݝgo~&?H?홐,2J}ޞf~_}췥֑q!2 MacۋBjaW֍a@}[F̶HF"ދ?76mV4!1ͮ*Peț(Mǝ KN2c!Y$uV6*Y;4vDmtmHC'E~n5u{SeA_0D[jzs;yI,js\sʗR\WB2 CA =, $ j'& j=-$Y pF0~h~l"Pһ =kvYAGniꤥ- FӔ*;TTk:Vgz e~l:^zF_ɨɨ_G}I '(v*uĻdefdM@n;0TGJ5EfQconYSVB_Ng˖-B]SX4y?iS DE j0@ .TȞkVzpݮ9T`*OeckzD QaS!8 ul'sv޵CRe$1>} j} >&Y zwG. %EOʄ|R&b'IԚ>lOܱO jh+Ly<[KS) @ P\x{ՍifjT]WŲ~;HuhǹǧV¤첆##BE'ٷ8B m7'l$ѭ搧M5R%y6`ټU$|+} i!" 2jC2S>$Ռ>elvOd`5h4]e> U/=N|yK;;[تg\5J#@$ܖ= =d@>y:ۀ#ίa\QuB}uv&s";`#0v^"~Vp#81.zdH BY!r!TcH- U*ey_6 8Ox?$S֕Q&F*r̝Fښ#>9gXͲ]nʪtsbebQ.4@~!(MPRknPvC(rkď8p%)h 5@/KA<gO"Е .k K]=lg<DiJ-O!yvr1ղ.J9W彭xp W=v헃k } 9I lDQ0Lwaqߖ + /3[wbX]^acy mp}X{$cGjP\pG9#Se>*0ϋ 'Й~wM?xsվX9z P9:9n^!LԂv L~fL9o)\yrH70-36` Ϋ/&I']-#PtOlQ8uC{2,l7aw^Ȍ]*Y/!%FQ隃".N0~/ *ԔVMe9Yg 睻m,\VUV.0nĜaGØ nOUS=N=z{cCWI+VUh>9cz:SMחtwOߛ~ϗX\>+ 'X*)N_`2i#MWH?ߕV-)%^Kf\Xٖ:c@;G Ht z: Ui< GdPSMZcH>[JH )>yiFe 78იz@ 5t9ΰ;p!8f (5½n#v9l1˩ՌKIɆ ׫˃9-8yk̎P  \ 5'"imNW&7Ug*t>o\QWm'@3(ٺ*ن8蕫Wqy?K#Z=:IMu.ZZoKߴZGdŃF7xlEVaścR9dxGex9 bfb rHlՑF2S~'0vY0\pѷdrƚ\aMGIѤ|Yq_l>HO]|v5om$u=uրjS kٳ{_T^SrMw.Q9eMm2,[`60eMMdۍq$C0@OO a/? Fhn)NzضCPЂb`Xt b[uoe6j:}3`M){&r:MG.N-HO]AMBеnqQ+DzT}QO>#|oM;u R{| KD*o5.> stream xZKwJWhw9'Qb%I3s9ABGOUWg6w#Zlr?a7y~vZIEZn… _Nt{\z;|_wg3WT)w[j32Iw vuVwE(eU練}6˜ا]Ylڏ]R醺YO*dWzx8v=vEڱ&mR3?T.-clkAHvA@ّ}N>9Bښd6tM ʌc7Ҿ|=y!&v'53rA@N];)k&M4bMr Dlx Imuj=E]5sn^bw(0,DTBi#fjFf6Y0/0iRI׏j:{=~q~l Qt~ԃ(y \znWr: `(HbzGj,#MNTRθpSHb zr3=mP _\?+2I ϘH7"Vi'L9-D2HF<(%.xxi'#5d0T oxGm4)#08".j>(^.|]6p+ ^[ԏ~> hk3 ő͒:I lnF H@3Fo$'&}=tjToLP{z gckf 2V@΢=8S8`ms5rR鉰U T<A|+ 2z mA'4YEVE' j2 YXKZ5o|ERBpF85`Rˎ2w 1fӒ? ofjRgx xodh\dh ͥ4ccABAK%ٟ)ZueZ=MeIWUrknK?7Dfy7epfG+:F({(MH m{Ș}OI24!-&0E Dzi}jc0w(2)(~b/#G!>#ĺRҢU8厚{J Ai$)Z~-Hi{RXQpЁ_BSvE֕/Y}1u''-w*5 |*{^I8D HdSP>wo,(#3IqX]-ǎ6I>)Ll?pq>$?r}7+m.O`|h/x.Vv:ny-$ˡF(z"ҡrvV[*ݺׇm PUf4XVƛ"znQ4"hOc>)[= I2c2&/Zҿ2xx$,9UwNO?>[@U8Zwϱ*q |'d @a%w3uxOcL&g!`NN;ǣC/f@ώMꪫ86Xm l@, <&:\hYBC=̠~90W|Zvj~k:QuBBRANNZO0]o*d0*Q%#Qi5`~ wqI5`h8f 8@TI!31 Y@l(^7}j(Cl2=ۤ u-BYd$4S^!0_-#śGo ;707 .T2g ˏc;@iSlꨩd+T :W ~],yS> /TCgE(Q97Iq{HSd^A // #+]-(=~DkXОdkxi~WPުb? 0v(@I*SIm3t~Fǚ+Cn.``u|?`IO/r7@&qmOJyxm\+Ȏ4-l &@Wy[L0 z|S Dno=_SvK0qBs;goiݘi]K ܿ{J93J%(&+ M&440^ɵ4Ho(7T8`K{up|3fSؗ+Z^uЅKۋ .&P wK[҂ehLܩ3#/%t9_T5,$2JcCfҍSI^)O\x2p.p0R{cK4ܡano/l[8efM)Lx*3=⠾x[VA +u3"{ uI{5%p͎&9ZWzlsu Z/-4֜ 3D#Eo5 endstream endobj 5496 0 obj << /Length 749 /Filter /FlateDecode >> stream xmTR0>3XHe[Q%L)L QZ2 $!KZ]}+"8#G⦠QyQQhpʲE%~>焱pESGǔC KPTRPFY\$z" lߊn5(c<ΟJvk-ae>JAv9C" L9׀ԟnbJIx^D %3W0[_?A'*NW%2ʍ 4\8;a [o}LDk9VV63HpXrjϰ HǔzP.2l+\ W׏72 r{ b]^~ ѧ1>eyO =umӹhO\Gocr! MWzGt xB9l j[t7[%mVZQ̪CRFPQ0Ş~ZfKcCf޷ {ahN|(qÎN1rSWIfRf.s\\M7aJ} :gVaWH^*L^ J7zp^`bla1Y=595i3wMXNI u,;I endstream endobj 5530 0 obj << /Length1 1408 /Length2 1444 /Length3 0 /Length 2344 /Filter /FlateDecode >> stream xڍT 8TSi\42n%]̬1+ci֚a urIm*GE6&$JDIںaԮsggng`3f *y~l@3t9!brpA!c(X)08 Nt:{ I9#N+1)FD!EDYg2 X!C!+!1a|&ߥ0CRIlP0K(GPJ1"u0! Ia@Fq2D `) (m` TTthe" |,D  BD Og7*F(xH!b(g*RDBT+g)Ӑ %p?GD {WT FP4|$DPP9@&&7[LK: [єxP"%1DpÀ:?Q @-;igrR$ cm0#+sWF괷@9 ,,XdxAXTh=,WqD%E\\|#z%O>7GB˕Y'Y&MFBB +#Hct1G ZA$T:rԁH,Bh4v {a8at>Rc`#q/1Rk$o!RP$--A82QQ C9bbRr 9J!>,ҧ23U-*ˤRR# ;`>._ksޮp煚=3^7#*z-3#zSgPK/k҃7mKmͿ:Qt[͇̼5MLT4huu]"--o5Zn Ɨ{%O^9mђƦRC߮UsPo5O*5\eZC|^k3Y0׸qpOm佌4ԞƔZvQk6@_**Liq wϖ 4aLefuX_ g{~nӆo!+\fg̫ئZgWbERMw i:znG煊SXh &&>5tO0#bͻ(MGc aO敮jCYA#v SG кR,jVKڒ)r)0V-9eLQsuhe9jy'by^`ۮws~$֡بqba(ߤ?CP8-b/68 joS( .,I.[rʹusLrψؤ7IP}Wʸ"}fNK߹+&hs򒳬i=[K ikaBLaIlCO㫳)r_=r~LУyŠGH ̦m[ƚ8$) 9Q8h8`×ޚq|b`FӃ^"m, L3\"EE%s,ݲ_> stream xڍt4\ڶDDэ{c 1="DA5D^D D zI޼Z߷f=n}]X@@"0‚ @UOB@ 1' m'40$B?((1Xh{aQ@XBFXRD@ 鿁H 9z6Es"=P0g ߯7(CQ01.PwlE#!0()\0!!A;ZrV|`};hĜ A46 Eꀱ.p s9 @` 8Pஆ `8{apu0l A<0hA4 kF_i׬pTEC4`(({~B@ >9Np2EV2 OO"!\kW)3ˏsgL^{^S"H9bnUPi"sSݵÖs$⏣7zG >+01 (m^x7kszzI]7ȧ>)|8nQ)Cr^^ 4:gC=U3!/վ/ãqI|A;qK"'&"[ Tc\*_.OeK>JyНS,KO;c4Af235~TqpjG (Nx`G⳰5lLMK+L[>pFȤX:a=@/y:FW.ID.Xڙʀe0pW1=thDnscK;I(r?ԵkΞ2. . 5$#t[!\֙g} "73KR}" nfpk[CQZìD-JP)п2T6[)>EɶIEYt>cQpqv 2Scƫcd,þMn^{@+@ʧ }XINB)TExdGL? b(GXn=vn9w"fv E$l4bK\ΕςH G jV`1/RSlF,jP7l;|wpШ&! //rrwTHI1w9m$R,~Ig#76\.%v1%}ãp+M]pAMWB3ŅnIܴ 3U}wwlFP|YrwY_v 4EFs^N;xj_Cx)TӇM՟AQycd4~eNX=jwug`nbm)u򠌷Ҟ>K*)z2 xtWtWdec59$P?sϬ ߑv ! i!d'KzFXU4:WKd=tZٌZ?vK3I>"u{YaqINNn=nw֐ <(敆9xOU?ǘ Ǩ,\ t"wS'[V T=99L`͂c)upEn ƟA[βI5)Jc&Tw~>;+uGH g DX=-H-CUPGooŃ eEFS#υ{;Qf.nȌ+KϤXe^me~uлHZ Ͽ#aBY-k{tr{CO 4];^;71 h$:ci]Y!Kg>uFhRPh < BqMh%"0s qo[>6wMZ=YVӊ~Pj<$ppc[u3{gW!Erl6I9G~ mu,gs:I8~IRe~b LoO )3cܽ}=yc!`frĻ{ QM޺w2JCThӘd^IؗTV`K1ϤRBe_iٶݔY&u 4V+,Pv}7fo{d* vW`xյ{ڤ-ȅ926Nfӛ4. KZ?d"MS9ErRVQv֊wr}BMqFL/*rTdcY(:W1rk<+6ϟ_a9dt C4}|J)N[(.zvXkpLwzwad+y%Mӊ, ZlH(>GDww7C?J 6~m ltixma[~u>D+F|}:nqdt h;Wg<=aBּYr-:A^q,18jΡgE'}]͒܉7_J]յabY)L'~1{sM[kߌBf i;3fu,l̪),q?vSxkRK 1+3Tj\&.sK鲒n** "uP;FdC_,("F )]ڽ̮nQ7gI}-N =wn1I4wPsD$sX-Fy\"E,ʁ=}!_مEQ Bw6GX9Uܷ$GIod?ٻxG=-ғE=jeDh2Yb۪TbrфaIƣVo%f8pqXǐǩ/qá3uӷlL=Y>?WNH4Oő<6""R+G c,"7ѾX,] &NJ FI=g%G)J}D(":vՂx*O9n^krywq1O˾lŤl{lnnӜt= *)}t(I_ue\W) t7 ?ɣY 7uG%)f~OYaw8@ㄕ(ٵNQK7`2#MN}voyj]=򟠫 /do}ULYl.I'nf6~.\ Lز Cm֫΢3?ϏH FҰ)& 3:8'{EyhAo%r]2}^I{ z9^n)PJ_fƌ^Mmu_6Who9%~*ծ͹L-Z/ɯC>H82<“%@zz}N \VecFa!5 ~ TW/f@7wg[Kz1!᧷err>+nJLnG7BĞk\d@D6Г{Gp|0s2k=F{i4&x驼׍4ejlm:j!?-& fmj"s#-NDvaqr;#W2fe\lֆsu[Yκo1:=9\> fZ2{4^SZaRzlPN{X8W_rS[òdN?,==Boyί.<]l*Hdu]sfɽKrB;u/%#o5.Bs'S[vlY>MfDX3s{\,zS],dJݽP/jxڑ}>1U*ibiRj6ir,ִ̕^m>8RrơEf2Y*/ ?Je-+1l}G,T|՛S&ju5 uah ZH9G96y?u|<MKm+#q,]<#Ym h\R!:D }/}-,z91$Gs$ڐ~>c@h}mÕ^9b.:=KwFS r{ BPcY'Sks~̫ :i4w8tr鬸H7 = W=ulb xSҫ<}{IJ^ꈅeִ#[KWhcL<^B;5kv7E%ffxَΦ>]-9`1q_ɧLdQL]{>wN,r'CŪ|[I&@|b:>šV0<8#ef8:9 CTFOvSSnL\|m32 NI]Zx]^dxO=?1yEHOE R5fjʸѼ؉R45?S~a0e!~f':3P/g, ql6_cZ3Y"uM\{r0O>G5ج_]~!ʆ_o endstream endobj 5483 0 obj << /Type /ObjStm /N 100 /First 944 /Length 3946 /Filter /FlateDecode >> stream x[km>?N>"+Ñ-XȒ0s{ν#V @A,V"Y;9ƾ O).>\/>@PRC_KN-d + u)[Jv|Ӗ@ F5ѻ-5x0>.0^AIU+:bbR ^򒀤 B2:"]ic,0%tHbKͽ Z#V^!R!(APQl2^H̆b 0XZ\9`LM f){\Ch1R61D / H\{BLB$TǵBrY/-92vLHhNXbԎ[0{bh;PGQh1k(LNsJƼb@OjXe`FW505`Xʁ8GbA*%` ΌRF B LC∁iG:DžmT5TB Ra j2`]tGvrMSR'XF ӄ.@ui_}uB@3=^R{'u|'PԘ Nj&v>]rݻ7nyyūno`ݯ?puۻ믗'W 5=`T0uOwsmGN {{w|{L̮8~xۗݏs}P{xnnEH{lPP D9<8ѝԹR{Hy/uPZKڡڇ>T!I|{?0HL{ 'WG gy`I]6sKK ݪ.4U{W}< ~={~~ ?=.RWw`InޮŸw:pȥNsK/KԥCfL Ad;c {s9WYI;oJ04wm0d$W GwȈ!D9ԽM >tNBL;)S?2RcO\z]7اoNmg#MXmޥ58 5Z*`#$kM5d)Ë!?K,9'Hh)5EdY`L+֪QΠw5J`5ˀsoZx_>E\o-nX'`\@$iIj@Wo>gFGq׸;$WGW ʐw9<ʸCybh)=*bo2D EBdD^EJ<0b=tK?{&|1YkʲqWwJ^ؼvt!Th ,fy$$ge\դtfL'u{[Kڜ eJS8 WuV'NXA?ߘЀBeOe׵ѷtI9SYb.=d]с%}"Ѿ7Zߠ uuXEhLhs{9F"r?)\4~*5d2fx"tޞyߛٙ!0Y8tWY7USxTl ͳX%+'Rr%n_bq'Dz~3$7s8+dvN{Ds֋,d춤Z\-J V713_2R1GgԼ|W>(Lo=CK<36Vڨ=j2~ű2ɆH>;et b1dԼ 3y=l=9~"-:ҦUk}NCj1݉d"0g|<$59-GX֙8oٙ.F q@(;Xc:j42rBlj1 lu4 )ᬩXXY5 ZEl'otn%%˔hmud$[Yvgtơm$ؚɵ j)Vۀ \^}^!U%nyuo*8Vɥ._U,ۅgK!ksReƨ% IMFu;2Pk})cy+[_I%̩$0<[)9tAG-&4V!zU5kPt)Cu&dMY_# %*yEtny2(:YS TZa-r5bj!{Opl8ֱ0Ttk\+X/,y-i~fugѱ}-@.ilֵ}^VH=Ƈ2W#4xes&֙O$p>5p[Vjjm&)pa(Եl^ۤ9jcirsU{8v&E>L-Vi]n_j]JV`XdE"Tؤf>Zt]&qb9sg[rpw})8'ƹ:GET'R$ZhB/o͌7Sbdk$>9O2w8?cQmdk"Wϲ"Fs´^X:Y&LKw2\-E=Gږ77@a T} 縚ŋ9/o_{wk?͟>}ۧxՇ%ŷYW._uY:ͽK8fwu__RZ0|`󛻛7_~՛#Z?qul7%߿\/wݒ6'%d4 S ÷Ϟ߹g]^ T=A-aݺ<_7/hpn endstream endobj 5534 0 obj << /Length1 1536 /Length2 7774 /Length3 0 /Length 8802 /Filter /FlateDecode >> stream xڍT6LI 5CtwC C44--t4 !!sZ߷f~~_f-Niw@rpE2 gfօ!zP3 YDar $wx<bmQ3J\P`8 @u(KŃD\p$*j` GOa~o%"AɍoSm wAloV$ǍzAqD%'JHk?7?(_S gJQ#́Bݡ`I8yMuPJij7!qudvND%N"{EEętb_;<۩,Z/ Wf/FG(wkhh8u6ol1?0g;irTt*\ިT]<Io9HNZܧ$d ѫ>ٍ{ebsT׹ %-)(̏$GS^9&>(y4TAк5$s҈Lv 0ύ>wv$BlOL w5MQqNNa]%lȵzcNUNxUwTwNS諛M,v|y=SBBJ_I{ԋHϳz>2Dt6`ZأF=:m×_C'=}͸-gf*QuqXE=>%9]:x?:֙ڕYawOl&E7ؐ+Eϳ;zYXe܅('d]B w,G‘t`i2\XO+ ¿$'@WaZWBP#) ~@ҵv:ol 5 ~~ɅgPFp}b:/83 ew}Q2ض/S?ٺa+Ə>OK1}Uj_ 0=]ԥ}u]JN,]RҾή oHtLtU{tUxky?,*wdvϑ};r%>`Pr=-^&l{xUcgޜra}mк\B<;{$^$Z?)7EﯢwGoy2+ih/VD*67G^Y}om1'+ޜ$К3 EG>]2UsaJb) \m*>q1KVDfO-Z!G #]D'ym .]͜.GSrEjɺtt:P#ZqʕgqƦE72ʫ;F9!+>M>c+y\#Ϯ|xX/mHTd&m1(2/&]F2G毱_f.Gmp:0bŨƌXm3Eq'Q :}m B '_Mjtg'n~г >]^yPFQ>LBOCMTN-ͣTd:+aCM;IuXcCB+4T'Pu{g@wYFiiGc'㏚Zi$hslJUE=~f4g( /̔5M酦zE kyI i%6Ok<=BOD=1`H= ]gII!ϦQR9XymsIUKF'ϤW;&k ђA dtXVo ",_NhF7^ڝRwR)sUF}M=z' W&' a+- ‚y j?gHVS bZ5QZc M j;?  gR.RzܘϱRDdy 6O.GMĪ'* ܪ#} Flg*bl¡P O1ke̝xbCCi=ߏ4TUH6w}@6\}io?)tf')OhЧ쵼nu'!Hj55QlKgssҷϥW^"35)2:!dv\N1AԨst$QfD _se!Ia`Hv Unѩ(XIdb$Ҷy'yLw4H4ߌIHmqdL#+K>{kZ~ ך:;8oB\&NY$t$'͚!e`6 Vl㑧~a&%rX8?2 v11gGӭmxQ$8CA/Bu*e<)Cg )ʞ7I_'VeEQ& prx^";1Ƅ0}6)yʩ7zҰUαdur;݀q(^L=jQ&laȨb"Q˿Z.MQ' eť}eI%))ޟ_\|*v\jSZ&7ܾdW@YS0<"NnqPavS8S=;VN|_Zùt6LBJ"Bm){ 'Kr47"I~87P$97nc@,9=]uuӸ<݊<lb+z첱z[QZL6Z]SEO9KoYĝ+p!.'meDtu,Yѻ U46C-!W; M7-40)ROnq+R0_U8qpE*kl°fyO/r"vb cf t)-0{3ϱY *uf:Io=ttmp{ۻX9<w<NBjƸq|=$´2jϷa$ɩ:S= y;Ak {kmW㓾iTӲ-2I;,K4U^FZЗh㑯c'JfH{  (^'6ڃSYxG!q[aPET^!.w;z}[ )հ"EJe* S\X˻M3201,Ƈ4)z[y]E([@Iwȇd3Hҽ2$u{nOTc> wT^')ϼ(gJ. sv<6 }C1W+e Un2WW )HTX~B5圥Gs 48gڕS|j^7Ay׊3=K cP9l^*TKGhu4󧌭Y?˾~e7"eKv2ߟ_ܖ\j+G\ɠжt2 >Ɓ /`jE& +47hpVdH/ܲ D737uNeXoنfJ8sT`䱘Fqz0Q;[p} {|d^@P;[ה_BԸӥs.:bH.W%գXFc>ROd龞K63.LK~*Zm4nj~qγ{} |(/U_K7KUbϵ3]n|eva Yu#ǰlRgaƗv#߫t+k(UxsOaKn\(mX|^RE/iۧ^pfTF}b/:43e. yemShiQ%N]]<#b%v8%1qV)JQwiT3,? R/' @,ezp U#:6J5ex(uPEtfO.UyKg~%iyaF%HVdUxB 'ȗDXww]9aAMԒ% 8HX=~O#,BfmagA3Hݺ4sJ=AE6$; 5ŏ)x 6EuO2HX#b֣K^]$d?#u j#l,~t2!@>N߽.5߾ٺA<<"K\bf4:Ϗ-?Z,5)~CVPu~uSt5dqI?#z6e_v6L[›ȥ^cD +FJO- 6=[ 3]ٞQG=N~ߛ*+J{v 䥗}r$3{Mm3<~yY-T~v&6EZ@'? .X\P>oMی0ǩHڃA{O;}dזڭn ܚ̷r@~6?9?amIXs_7oW'eujm"U@d\ Y+ȬQI +`lJ96l!EGU۠^Q'X\C }F=ղ(¡ D%-xn6]X,\[0) j&upqm/qw^ٸ}b&WSQ3ڋݓC,9,b'Ltu"׌tDU-twslBmڠ7b>щpoR=uSyu' PP92Q"F^f>y` {nѹ{lޕG_KT_ }@=/OAy)3KvvH +H09( :e7` X],u˘Ym-79"n6s#"I%fjy`) ]V;@Nnɯˊ_yA7,^6Y?}1XҷP3k3,Oي%sϊ"Jrl%>J1tozztE}Ne sJ0V{/"|uʱyY\m[Wxo_iڻN 8n | >Z峺+r<0xkWtz"Y|{,`(&|Q]C>Wn5+iyI ZX/0xc]j)Ve=cD(RfL+#7ַ<Y.oqSbo$@7Qiȡ#q7WNkJϟ$ü?ZleOCIiz#)П#5YY R2Al+ȬkKpб#~옓9>h,Ǡ!Ne`n-Лgc8L!"AdҒy^H{ 9 RSզ-'Mr>_k$6ųSQ8I-V7icV/ <[|1B{V[h6>k帀AkG9SA)L`.JH{1>|tdd5 'UyR9{0 }u;iMFy˄W['ّ\H(q3Ly G'vݕ_5=ƻLcΘ᭞Wgٮ(:cl6|U΢ކdMZǬީa%X߭[kFTqL+p|1=xpt YbY^3nБ&u /мRzțU.Ur1JTh`{p< lc!]Ii"{L/vUR<(}0X7_/y9[,(?yzYf(! endstream endobj 5537 0 obj << /Length1 1573 /Length2 9159 /Length3 0 /Length 10184 /Filter /FlateDecode >> stream xڍPk.Skp(])%$kqn8škqoš~ws&3s-_=Oh4٥0< ) y%FɍedGΠqpA$9=ٽAJ6.00''S?0a, xPA! 20;wKs 4y0rHB,MAP+)) 38WfQ '';a Օds0gaZ:Y4 a*wg - Kǿ03'W$4@<`)9@SQXo6?pqp߁,9LMav %`fiWprsb߆ Gؓ?di2y2r@^JzjM,9-m~irP urD]iO sz,`MPK{g?&O"?2sS_@L-kARr?ui=54<{:\ 'gT7B-M&sK(Ob,Op^`_ VT{wꤥanOv>A;7'K a@Wj]ӘS?`g9XKZ 98MG$lc/G qNO m {ia6St=!Z:[AjNsoB`/;'=-DȿTrPSq@ w#~B|OMC09='?([7$x@?RzT rjqSL??)t&".n>et רL4.& b0 3 JܕǘvV,,W.> v,o1K.R{5բ4'zݽӘт>?N`O]KrK ]!YK-ʵGdi$xV%2]${vi\Z'vg/ݰ/>R+ű{GzrG_x|+v ''D<`IR",.Q (24moVӴ/ ]&_{c"8T}Azfv ^N{wmD %RqNDb函[3ؕCټ׶QdWf&||3fkpPS k;DjitiEkrguoTs._~/@oT5`rOYNSkAp-͗Ig!bvN~.dIIF3,, @Lއ`96YT n^\vH`϶PI(D"|n-S<~ Qaۯ(/a 6m,2pIчӵ6z>Dץl/Hn")*V]up}f/e9ȵJԲsa_5qN @yEU&0!"Y%BҢ~(־&bDVai _)=sFyϙps)BA[;ߨx`>bEJ)[:Y)-ѡ*N^ ci2($u|^X l~P.L0V0Y^A:蠋%RLDnB> xzkiWHLg͜8 ]"CRWM;x;<>;< i+sc֐/{~|]"c6I g=,oK0"Fe!DEd9j+)̜,aC#Qvȥ\kSLB`8'ڟz@ eBQ́8.`: <=|uWgδ RIRp-e򌭴XH%lE\2C#Y]rQeL!^6g!aj -'c{*:;N918+k&u=T"b((aG"&?Lch蠛mt1LU6l|NyD{J1uÂk-@XrB ǐŮcpucTPn[^$Xˬ v0 ZϧR2":gA0,6scNѺs"# gl6ň}FG aoh&/qncj *Ut"ـŬsa}?ûYh8l@ɝ]*]ի̪0"7s^s2LO42{"EΌwo 2d1 rnߠVMR&J dEO=|)B|c>z|E0qHy༔Hy5aZF{85g.WduHMȈ.qA?%&&{dž,L}ZT@6?ٱΉٯ$9wdAV~%?G =5pS6;RV<%8Xo~W7aL=VٵaRmUT<Ӧ1?:pPK܊18g,w?]߮x~Dzte_u:R/id^w$lFlrsv !OYI- ߌF˟UJUHԣS.sTͨ'Ȥ"q[C_݈)3r sjXۢmn:@o_Xl)pu?&ڛA ܌ Ѩ=2ޖ TQ_} TkNu9~˫ӶWM#B'G9Q34 c`'fT^xkZm֋/4U']KPѬ OYd$]ɹEoT5LQ߃fj݁*l?h7z p=ۥUzta#ӧWjd+vmb|8-j)jY j"8 "e0 hZ9 Z.WGYr&BtUWs#3\\W"^p և?z e rs_]")1h7<بnÝh~FzR~*^nՉ(nLZ?MPWkl .njD=u+2>+9+̅U-L11Dq U;flrMȁyJwDNOBnz~cNgtӞoyYRS H>o-ɷr3֨an"=yE,)=٩-.iy񕪙Axuù%gC~󲼱1ͭCΛ6YUg 1eNx;W)5 *,>CۑY!G`+z`t5 aM2*xF':^XȲy<^vH/xźkhr2,[J񑵇A1,xUTo>pcs=]*oWAxKBcM5Jgc'ӤzŖQYSIV8yD1Љj<2Ei ?ůe?@,a8ǎxAZj+$XUCj/z~F_ۉ[eP&Y=XR=jш8l@1Z+`OE}BWVF2LnV )ʗ98IXR#I5ŎV\g![kט9aC[}Ʋ63#&4`Q\,ػbSS'idX! -8PI3x6*u z#ҕG9zh)9%9uR4 n'ۜhikve6Tb^c]M.*8ҰL>kO 4jgUy UCZxJc=펿)8JCb|ܜ V 1nF 0&̺efOWC˰mVP|7S?) )(4ac+$eYr'p榡0k@ƻ3IBvxqo2>muANHX@,WrY߆TY!MYwn.UyV"j ӽ5:%Ɋ3?6?$tFT:ޱL}!..d͕X_(9S|ӆju~c2>R ̈rAAn_~r2j%}7uZyvjzml돶2b'|YxkLZ 7PiJ-t=VNNC OjbU'!I|~e "^^=__ :rѬC5kě{OC~nI3[vZUdjGptfRf@]Wi߱PMy8 -pÞjk~%5L٫OL\ƿzTq+AȺ{;LC֢󝡫`;ț }MWԧ(,#Dn@G(R[')_^*ml%#㫱(iyu8p{ՕVƠ%ݹ kԈmCF|ɂ\"V"R!_NhtvTևEtX3YrߋΞsi A}xYa -L +,ZEU[g=_}手 яYzv zcL[fBᣏF˭DY ^$Yq4ːXZ豑 +>4}rY_-oid:Ԏ#YH"iUCC-1l-!!. M# *w\g!`i`ld.eumfabw >y62kd-$\E.fpo\䕮}XjH%h'Ͷ"mǂHu>"TyI g3wmWIpmZ4ta 6͑,Wq݇Mu=%Nf~>l3,pѧpP;~:tvd0o `4SR_ˠ'Tcϋ|pkk&P`,qSD`ydW; 'oU:ZyO1>zO)zH{A[9Z x ѭ_R1#9Z#)]h [Ch >ܤ)eU zQ-1|1-Lf4Y1PX\mCaxTu;ǨWTQk3xDsƯ%ݶׄq[)(ʛBp??5{_҂/T}{W{L8V/ u<sHS8ƫ4* 6p' zSն"7؊}yFO Yqbg*#h!)y4"u(mtW7gY gAd8s۬ X=իsS:-߰eIzSٍi%&*tlq:m)c"_*e>F%sѩemgm6jjXy#v+3Qrfg>t|7/L`l3`g\HOv?2 CML_1rm&L;w_~!mv>'Z{ +8oPc hXsYNG>?<AU$ݦ4M CW\3}{Dc+ZZVTDw$#[?uX-2skFAEϧ$"ttB槃U%k}hF)0!FgB' wМ 5mkߞz~-ˍyQIk7$E)/^!n+; ᤞn\-Fwp1dNY]—5;dh Q/4;.ϕYuҗ:3/(Wd2P݋HͿFnivj:a-ף@,rh^V>A(\ex2A)j 隨9,Ek{k"Tv./T8 <=mEG;.8~t͕ Zzr-%[(";„(^0>ѯenA݋8%[&;*U0WpExnG)F{i9dj._iCli} Dvq NoiڱSG0J惼r7!cgz5z;Zz@GcG±V:(U!U/,7*, )8"BZ[;gKXWhUB&?x0(C*5D6M/E,6M囔2-[<8O@5_yUݶ-Y_Xk3;Iqi&&梑1{ fT"<)u:ZNQ['IK~i{?wu!>%LNcf^/`/'yʴ."͛f2`pЅ 1HW48nԥǝ\V峏=4H!94F$l٭#sBuÇt)wvV1ʊ!4B%/>8>[ ç.2"ڮV 啡DI& [2{GafʬcA82^~Yga;&*Ybu/;%KK麆M}B2(uPH.vQ9Tk.S!slehfsɟkZ7=d`Ľhh_ͦ! iOpW%hg8D5mƕᵸ6`Zg_fʓ'M]}ݧI <0jsȡ69E .~<'ٝ)im\*-#9:I ܼi GR̞5cz.+Uդ,Lc`Gaq6`c+8ߝ/p ɹoMT%m3*tcm<7 x{grQp 0"ҬA~&g1g6m;go2hF(2D׻r#9u8&bߋ8E qgRy(W.X @sAc4wp\;vpHJ t#7^eӠgE뎆 *m`_`xMc*niJQDbkd EbIWsm oT˖@+1*y >' 㵡9|'O!9O8g>8'y8LS*ڑ&c?qmYT WUyj)݀}{\O03;3[Uy+*96Ӭ9i˭SUsz<7n0 endstream endobj 5539 0 obj << /Length1 1603 /Length2 7170 /Length3 0 /Length 8209 /Filter /FlateDecode >> stream xڍ4k6QF zk0f03z QCtEDDNt{-|=Yk湯kk~}}m=Yyy P deՇP$ ?G< B` Mx<}@" 7 xCQgO$}S?0'_\\w:@ Apmu9`/ I;4;/ ŋ@>v]( tBh:%dPp= nG Gd!P$8@OU V l+ ;#ApO`syhnrD!nAn #&A%YC0g4s"/SVCNNP8Ek 0$|s|ެkaCl~5qu3\\ @cP4@(. *" `;_$/_og3 /zCAh+ĿW XCmap¿o`͟G<f>}zzc/w˧m`Ooa_H\ **6>'m?۽9l/p5ki"nl prs0|)snH7 '_7uELfj3PYU4fdᶎ=FJ h`?v3G@~+~ ;O7p0kE $I0f!P.M{9\pG fk͈A.O%q~Nw Q!OE%*b$ FC`(gGrur}{߈)S"o4ѿ}~sYP(pjj9w/ D-EZ5@yɳGW#ȷ>)j[pm}ɥηPjmmVp-^n'5 eIv{oy_Fӈ cʦVUɎS}:߉gP8K^4] [L$qV;J|.Bf5a]iW$ \(UB}-a$-+'UE4kgVWϠ%Q>8io' aI'/Hv14N?|@+ew╳oI@ 6 .yA4aQ45a{ {);N,._*;D-EvQAxK hV=t00jtN %śWH .lmw[_\vMQR'QLߡO-ߣ:j3c,C pR1BYn7E)J6oMj:U/?A23f%a5,#sk$rd=sRY49,j)B$ +ӞU$E0E6{o(On4 hj)>1  8Bn%Y,'UpFY,j3!gw?_-U[ܮ.N*î=5tRI~5m.dY]qOTq3宍_ =AO0v %V?|EgJ~1zf(*h)+.$Ej#q:t=~bV;{hM).Qrֶs(.`o] gmܣ;H%:6]?'kMy!cKH]@PƑ3,ꅏDMuy$N(|@k8Ľ*FZre*rIPKfk#m;lNnTd-[u'``}"R4ɦɕ|b=If 8QaҥbOI]`ڃŢ^8pBy;d[%uGǛ>CmCT:Asa\yg} >ADBaI"v<Nճhўĝr)֨;Z\'v``w苩yz{O ,1|R?; T|ՑR*+{<2 4.yߒ>iRڧj-zU0a%:U,I"P-ZNjѿ 8G[iPkS wɒGYc4@%EVD[ F\ r2 9i$r^5VM':Ϝya*;3GٚFB!<֎{φ{،~T)/[9XWlG*Tk#]FSu]Xc{օsE+|ZxfDˮ%g2Giǯ<9҆J vDcN5gayj䫬\Y&Q֋}&/OkF90W^Qem:-/#E揌 Gݞ# ɹ]]ߴ^dK%ׁz͚;iEM"~F}|;F߃csxeYG懰v|0Ttb?*oXN>@*vK;ƬC:@Wxm5}!@2Ju<QL\=塪"~(Y/ ~SL۵v<jU?EIr &'?D1([֏Ϛ1ORї} 9q]NYBYO7R#rś0aHJ}HPx'xB@ _܎Ky6!"1[T<|?"d"5:hAE#ntOeM]+sYW?ǩD<QB5TF ;Gҝg'd\`x"V3k$ TAM${O@h~ PF*;D?wo2UGpg˦G&PυZ/7{qsؒÆ;$JVlMf5U?8蘨3;3$^m4O! UyroVo> i!ĵ4O\Wj;ɀYb/.(ΕO.2w)5]w?gcgti> Tb>SCVa%T<>G/f*$>U m%F}zyXyp6T9=z^H'eU!s[G-0)FrSaI+j o L.LXrƸ5c 'r9/#'S-#'Vrr~e蒑$:~N8z9 zLtsXـĝy:X#wĔ64i+ ev+Ȉ4]i3`wK{q_mmORNL<$B,06 'qt/}Nm|a}o`|tn1'r)T l&U~*pGTV TZ*mQɟk.v@AރB&r3LW,+ԉ(RHǬSчs."#LᶻEy~p!,!pͤmebj櫒r=OvqvjXgJq>)Mm| 1^S6s)/E+.Љ%Il ]~Ixi5`(3 |gL5Mi9` i8GE #3+ ylhIpԭ*l#¤ci";S*K]j=%e:5֙0˲S֛[t{X/̟jYC^h|s7n29N?#qb^68#e\sLl=fߠj8ڸO9}I!IBL?»ea<͂{?u<\L\;l^.VOtz,'6([I1eQ=)ջGM'ΫXTG~% [2H;(&lln ,Bfgl`m{3]f| o TK܅>n>QQmL8MTmkcJHUUFVǓԯU<4G6}2㟛"%{0\=ѫ).3΁!qɾgWxA:]yvqIU"~̥i$Sy|.9ĤI4x<*ZgVv awbV/pY2P_N8N=y7ݕȑ6-oQx2+F2Dӱ#.AS`8,[%/y(킨v^ej];CQ_2ya) r>bnD)# JƮi{{YCjg],b\ 蓲{$(nj& >X IU ʖHg?MSjPxG!Р8dj>K v [q։E߿.bv쯙=E;~7|Г4Y&GP 1x=38ǐ>Dp%o[MlOzmN5SR9݁X(+V<x^ՔBM%g^}E!*:\A2zc\8Mp`D`û).6־d축d%gpЕʜ" =΍y _M[ޗ{ߗR8TLw^?|wqθE1q{#2/dX /)n8Eb ەJt}lM}8l!YH612&G2|\#k8xWpܻ, xZxeve#m-jwig7$taD0ԝ̳)-ߴ<δ"o7k1@'9~zSptFF[!)~3q3鎃]RtfDGDr.p:[1fj9cL=ҵd#C]GzmCfOWWT;H*RfLl2o+Iv"" Zx x$޷%FNqc`VTQ֨mU`{:%j\Zy>I92$h'֗~\ZI(bPB]U]ëm|S%;f [E r;Oj-d:1 =+=9]1 Sx;1w$h(^ɯ`?tlHqXզZ%bjQ"ns.QUd/L4RV>dBv3*6¢l|jpdIMi VJ¡>+\Z+eAjT/}f7ve$Oݪi:HCNr9F4Ch:QE_4O `)*zD}C[ēa5+j?(6R4䖓ӡ=U`r\2hxLM>!\e囷gPtUh?aHQU1 Ba 8w`H7W6UR졘KALc;|e|l=ء Թ# I#>jh2] ј(gE=+jXj0:d,ID74]K+,y-w咇՛a,o8]mur{@(9eEdֹh^yH33H6גNr&' endstream endobj 5541 0 obj << /Length1 1416 /Length2 6052 /Length3 0 /Length 7019 /Filter /FlateDecode >> stream xڍwT6҄RE:QCH* $$ IU*H* H)*J/_PϽ_VJޙyfϳΛwv05$Iuu5 $, 89XW~) #RPF XOuW XK@@!Ho -Tx큺@-$p*#Qhߏ@n(,))~W:P C!.sïP8 2NX,JJPS@x=X'! C{# n? 8Np AÀx+ C`)04:HS!~u~l,W?_(醂 GWza! C< pWuPMOg>  Ga1Ōe۬WFX ?8ﻷuA =>[pP& $ą%D0w $x7 +pgA!Q@0? @<`@,?`0`pnoh 0{$_G,htO)ߟTRBz}B $"?]Op@/]ߨ{C? O]L/R42;R{+!npW??ښ#]D[ORؤwY8)}EW&Ң^YC"i!ɮxEtOnAKіzeZ T }3]QZVsbUXTD.W<3c3NVaӾ8;J\SQhB͌oF-ZhzU2mq߷kJ YWkqq4R Ȟl-28A9VRW[)a=A^ދ@=aGI`&t0@H߽.m:(PnT-7E੡pD/]O+SeIaݤe}J'?~iW'F(.6FU1R"H& s殰#3N5vVssJ,=.obH\zя N*ܲn{Y6!l:;^򵖯U`A%HvMYZ!N1vy:<mA-@I߫ ĽiNF !OHѠG7& @7t}g ajS%'$yg*=ƺݱKh"P (.mВ̜ F.Q~1G!TN^Dz;|Ш9`2Vp0;X^fQͺJ,gPջ7MfoHۋ<7.tAw;3!͇~<wx`l޳[c'iyMlq 5'Bgt+o-_p|n^N>vj8cgآ -ִ&h^ce`>x/8/ :e4x;6xدfu$2Tp<LV9Yߺe1JIvsȂx`^i3e7 h jg'zH֞*E`׺6 p{# mud+pai@&EV [[eU`W盟^7Q&C,lQR }2G|PSMJ"1nl}@@sP!+(/s.{ɚCC{rO:&|;u]~ %nTR_[#{&fcZI?2`X@hE)!gœ'{1=^4h92oeùakz;4veP,1̜;+f:<&.,=XipՄ=XeVAS@Υfx3(H~!M5f<2>;¥ܒGكr ѽ+oFK$׹gzAЃAgz9q:qOzMR+3a,}3.IOOL"LV$2D}׊Xaʌk +JfJRoV $Ѽ1K(j 0(MHA}!PWHCCx.%*o׻zo^F҈,x7sLi31@B,q3iU44yg-e uix8[~<+Jt^^Mff4#[ΦV'@mWj ИNOPnHԅ ÁS3qzџᷙ?yjbCsW>r{Srר{W|۬3[eCb-c{w;fZ|`dNCA&G}sJ> nkZ TDwR^|a>R|btD+DF38=hIR0e;іIͷ/k/FyO$U R&:)+5Q l,qG؂UMI|; dSQQo3m_\Rwߩzg%SrܤT˪Euk{aS3drEyg{صʲj!\a#1,εk]j$An3& Oq5#B藷ʋ QݢT^:*o"v3$D}rZRNy4ȫȚ<y9X=GVIĶj񌟨޵@ܫXt9 (Gs BȸRJ{\9Cb +m a779^$w{R)?K˦ݓlnQ s6~h-}}u@] &8Xơ@|(&AhoKjt3-l1NWcj >Z@]*Շdaav[Qww:BOi753{ӈѯ,_?zsHXlF@/rx*t|DžiPb;2jJr*8UeYvKqс8GЯsHT+Nh Eȫp[g.Q-MN\k׃B ̶K Q7Ӑ :T+C,J\[_L&ҡ#L+!ȗvfD+~Jj{E]p ,s=pPjBEsP*UC6uwpf\c'~nfY?tp[_\Ni'Q&"HLE뷨9'Ku[K6>ka 񽭥e[/=ڢϨ brgYVEJ0RVB!]jt4gw vo7{dBgN]NW|IGCyo{JsRGZl4K>Fl2| J4r3Y|춄Okw0Ĭߟm~]JlAj$VDbRt)?Ww|ܔvYHIVcML>'4 rvXQn{3j9Ax0 ^iJ`cŋ2 gKVY3!wog9 }DQ美-{5N@겹eա*T^h`']mk,cag䕩 M&. Dq7oB}[百^͍lxzܩ"PIdJƺgforדm3^9ZtHQ?<ơ{52qK$I_a+|SzR*tseWʑibcz[=Hhh%ʏ*dgq#)tYeBVmz0l$P Q8uL5ԶwegUV33jv"іB&P­<)u"%C(R%Hv#xQ+,GWU ]]|;҆ш! z?kMn`ZIFJzgЫBi(s;K;e5#zmI21ښKX#"r*M֬; #w4k^Y m ,r's֞=Sw.yqj]cAti{ŖbFKo~ɲk)+n|NT'mY?*z!b Ƣc_- ] KbfR:;I&*2<)[Vߒ_~O(4#!ØcMSw; C^DPշvS !I<*퐄K?QrVn%R.C8LbqTFhWh5G[%(n@ta'iv)`u$F@clEUoW_?=$% !lOA bG((wy4m dv K5.ES1)]P+ކ2l^Y?Շ*5}Aw+y?L'Ku2R]:C VQqՌT~?/6dmɿ\DnwXGy];p RE*j!9;a2O+ͣD.`1aE/%T8x֘:ο0Y)T|L~@Rt|dۆl#/` aqFz\_K_g~uPԑ9n^|:6lU־Ș6{GǪ1mtNQ?!E g^ؗQ>L<{N_Ed&svXHI'jgҟѐ:G'2E0}1t;h#o ~峊ƻ5_+w: <* k?_.P60FPfkq+:v8&R;#X R*+ ]'Qו e\ouF<.lrN[D/6 XKaQ_]Ȓpq@@uUk#$Մ`XcKptzy錔 AIBζt36 |E[ϝ>v圱5GD-?\Tu Z$"qr,8jLŅK;J2prݷ\s~ a~Ѳ$:cNLJ juxL> ͋y->jŁync>yRXPHid{G %źQxz qKʽwǟ;V>|Fz`Ga\xmI6.rv kz7ٌ(I(^ endstream endobj 5543 0 obj << /Length1 1393 /Length2 6063 /Length3 0 /Length 7013 /Filter /FlateDecode >> stream xڍuT6(R * %-Hc(nH"H*HHt#{}y߳s}]u}ɪoįh!~4@YGG( &4c!I9BPh8!(08tuE@qi@XHHo % P:M$&TF:{PGPt` N`# C0*% `@Nh$ *pc`Cr~ 9A&@ 0ѿFH{;p0ƥ" (;HC Ak(O?? A`0#{#-@@# [ ~h0 A ?wYw̪;eAOq)r -{8v΂&+DC"`bB"  l` tvrF:qk@|`PE ` #HsC۸G=B8B??y1p5uTy/ B ܃Ͽ'WaewP\ w1]$?L㾀|*ODj\GwQ'CM!:wTAQ(* $G= vp 6&?G@hW .KHb8^#h7@h0. s"HP(')q $GH^@P_e(/>zmR8N"2AAM+e$7Ϸ&t=k>U6fVW{؁R kOo,jPۗ?y3ެ1MTb.Du3EPA;8oz߫ns{HMB3I(]CLm!IlZ-']ӔEk,r`(UeUD*N璟gmRy٪S+1a5%V΍oءQ3ki 96߻xu W:7hEr9i6d:=;Xq:0I##?%X>4'We;iSs͎8hg˚CK㓮$Rɲs7hxxhoA:hIfuA4]} 7 %ϯsK_Mkn_~:Iz2e=EH1LԾbş!3o6kJ+>G*v#4ed9(讄r*\$>LVrLйM6 #&*50Zaz}+$]fl;v0p-" 57zH4b<`Hx=Or!;`Yw>_rim ǥW|P?":%籍"biޝ,wBR'#A:]LL7;(_tYA&k>`4HG隶V4V 9"ں2B*//&R*- _..2d'4ݝDɹ(ܧוnbߕ;F4>m7}-\Pɿ]}n3qcQ*Ӯ:!C/}z>$EUUr/dh#[-ӧi*7&8d3aO<{h*1a ~fz[ PWjxފ.3WI^~z?=i >i}ʟlk A')jbEXI#3'hO불=зX3uN0-_1vTdYpY݇ 6bľ+hK639wT  Q"/|#s oйJ<ӹ0e2>C"SPLE:8negVTMu'rVvDK8!t%ǖuEF0hjAE h!+unTK5q4("v3s&.o( P|͈*\zEƨ7En޶-:$ @ms $7ߗJLSG r,*),b$ߏѸ33 6d`èѻHH@C75!)Y;XsH>D?:7% _b[|#ꂧSñ698"Hx;m$;c=3?Ş(-UDm؁3gz ) d5iJ;UJyEE)-m2)ڷظ۲ꉗZ'nS|"?>z4Br!7bi8xG2r\+eRn|LHkhaRཨ-m(˨ 2uS#, *~?͕kߦB炂CcJJW G(nLhr^y߆DkFr I76GuP___ [W>_C e9GfՊ; R 7/GAҬb*m`'m+L8NcBUS#~J"-k]fo|}wғ͂dt]UbEAҢjƩ?tKQ#&Vm/i>tF>i)k^8R=˚J dߒ5 _4x?ADiWKV/n/ [tŌ@𝣫- =D^CW\o/M[QE);IhBR,F|B9fMRB4Fz]7x`VR!Mrժ1-äIOtf'j2SWQ裿CTLH6Q|вGQv-o(EB>6ށ@3ya{G-^U0PqpS8f'Ilqa?PNuwn49j: |g;WV~|H #7\x3w UI7Z+|gh/Ѷ]`Bif%lVZN'wUN'<W-khD|[5֍!;vM,_ %r\ޞe5a`eӍ|oR>;;aAd(Cxp|%Jꆽ,wо1,E]8 u|z4i>0_4al{d. ;ԣWH^moOP._}R*Qfhޓ’HjU:xm񱏟_a *sZ19xzdko>_~ƅ9Xɯ/X<|l8cMҸҫɻyiA"kH@M} FCNK-NIR:E^Kk㳄\̞‡*INo&'Bݎ:(EKLս1ԑS,ꬬ^{< )HF,pFzO]<٠o½uTx}W8}(nmV7C+ڡŇz iߝMljC"$QdO|lu" ^^zg"%l2FS@_/U|x/r;,[R/JOa8Dەg w`瑚<kFV YǕ%qQb'T O{FK}WY\.&p1 t .@hUj0$lZ@h Y?&-9$WBOwĬY gMHJ_kceǸ .Kh}u$;Q˕T/ɼ_5ãDoYe^To$3,8N#μ #oV3#*7-|$MnT;&<ۦ]r6YdiWќ%o)".(bI^`zUWk#ʒ&¤6J Y5w@>2aU 5 ¯Ey0з; =Co1Dne:kv,4lռk1a?YY-(!)$s16VzWxLG!I;٩I˞[ۘQOG_ gMY]Ν5rFγkǙ3Di VtcwRܵ O; 2@3NX5[3xtexC-nO,lr0Qpv1Yëi;м!10Qr-;&\(~+B>҂:9ՕjΑf~fQu$MTscFTd C\F~7RD}+j:S,IjqP# :.+MK*BOy ᯖѝ{ xTRcB'T {DS mWKfv&LuO,(khaᵅL } fr\zI/JpԺa0 Όsg&h7\A*)“*1_gLlޝ薶b>-K#R[|C s@Rz׵G-[WFLY*Fw(M}֋ M\y̤4LXgS,XS݄pAY"՗Q@g›4+Snty|Ӧ<ȕV1~1rTďJGG7>!9i;'V.l񝛬 5|XM_˨1JB-H*O!H_I p׫4oRy\<|:ߕ~]̕-f>%vGZ]:> sZ[l9YW2]z$rt2Sh%w{ڗiߴ|*[˦b624t(b]%dmq>nvƴM/Ƌжكi::?;l9_?E3S371emopC6N^g$*ןCպTW|=%wk>ra;Kx0ŏliMXJ~8o@I`Khr{'|>Iz c`TB_;~Y71.ْFvjO?hnZX= )˹_9ڵ&d0roI=u_tJ ͙0HtH]SW<!yJX*|[tt?tMRv|A2wLW$Z^[NC0Tt[,LW6cT4`t#CnbE*Ǒ}$&=[ @9Z銷(n=}uf#Uq^FHZl({ 4=(4lyEI0b?H`{v+mbمыjwf {}+$'9] 73ΞTw3‰g,?n-Y [MjB6lRZVWG!s%^PY@=C<ˊRӟ$3&;vdTx~+w>`⛍փT=s9`JU.W|NdjʭLK~Pp#c2 ha/Cd?D[P|"6EiH"8޶IOښ~rqަh˻vle"0;#˻"V4z{1¯zUt endstream endobj 5545 0 obj << /Length1 1714 /Length2 10660 /Length3 0 /Length 11755 /Filter /FlateDecode >> stream xڍP-Xpwwwƥw; nydfUUW}}}ڇBUY$`afcaH()qXY9XXYّih4[_bdm _ ȋLb`wqظxYY쬬|1tpHJ,y{ 23 ?G=wlfbP2X^24 @@www;gKaz&;bP@ M@vƂLд)p8/[ xIАS84VӀ X@`?MM= -"0Lغ8mML_  -0yi\̜üܲ>I3=N/`7݄#P Epp@NwxMOG?/x;:8,^-@/.&n o#d669 0Y"Y_ 賾p m=1c@9y9I?;['.~ `cd|; *XqpY5b@r; kAHnja. F-H5l i]!/ k*v, 8YX9] sU0O)j`{ ?2yy?\^xe 7!eo`{ع&&/A\/LxYPsY /.}ȿ@7F߈Egzb7^o ۋ9/ ߁ "/uY 6/ Ph/: u|//_2suv~{2?^Id0`&d]zU؝ygT4Fy!"Wjh#N#3cQTzMкCY&ku{֓\zߒ4f z:r*m8s/*i7$s^ opy[ۿ}-P#>T4kp]foEdF ~^7ؿC :)%O"ɉP!0 T[OC)B_"/ A:#*-/m?or4Gposiu ۶([2[iDXT1b`1\7ɰ% zd~>Kiײ5x.%oQ.:lP5sv6ֲL-`8ҿa(riR@Tҳ`A ]S'w$E_;sqJGB,(ГBq`FkQߪ$@-B/rڞwO5Ă0 '|#3 h;~f"QRCp/N2s%n`:p7l;+ ~n]~JGH\,y[b7.dz7%Yf~z+Ȗ ' ;B^-]2NTFiIWvs\*3TJ[qM|̢[ät@D;R,I[P͗hYRiř)wۢ ĽI&~or]F%+Ikr ʫ3-310[P"Rh2"BK'S]jw]浞 smfXWjp;@'⌥S^̦:S KPʰd7[re]*eaS?$* 50ݦg}4Z5h3T0y0/l%P}24p2yT;l,]ukQozG'hﬤ9Sj1?Қ\ Z]gU睐[Qi7sح;)fxb/ Ŭ?ޡvf1م!wFBQZ2yک_*¹%7UEit'IDr~cR.g%ܺhkoQ[#K<&b:{mSo)*<ꃊ}'kE6:p%,4URd.©W~Bu:b$HqvisGF$,bg6(7 Kv]k )KlG/&W 2Acue(雝U*6aVs"K8("%.w,r%ok(*gL{-t0:^H ?/(þSBU$LU:A򷯓ON8 cB /_lEE+IB+-l&0T~=?a#asfqw J3o"l[N1*IR-ANq\R8n(Ý_;}iob^e?=Ē:k{Ue!J\{U/MM4E/8?yfUS)˜2 Ɯ2iO!Ӥpi1<mU1 q>֣K[aЂTJXҢ[r >ىk3;X`-b#y6a羿º]]C#R,Tz=d, :?,mTM dMՊFpZ %CBA.Ȫs\2md-Gq ?M`/+Y&]y&$@f5f>[_=Bc͍biMvyK(ݢ8F?7MfJ-;'i궼-ūb9,*6kt)[l00+%KP0Nܸ<^{P_܂L\ӎyiޱZ4yZ~%騦2^@DzisƩ|]8|cY4H@z gBr=$n\acR(#* =ˉpTyzqcWUǞQ[An@>4+<{( zLEM3wʬR1H=-/GӁV)qn ΂RG[?qӺsܝ"iL1F9-OLmsSM-9~ʑtT)5'X.*E`Lm4j &X|Ik.kWi u1LrRgj7,-%~n#R8.]d2Y Fީlāj|@b"~_Ag^0B?Jq<4J7I$!3[d[v`pX)2kfpN Βy;%ϥzͯ1qZa)kh,!J |uFT\ϓ5k m^>o9Ge< JMDQ\; Jc \>L~QGۻ~REj殧\ϔcsGLm{ eY;E k}lWpߤFgZlSgIӷS{Dػ_~߱wJ'mAQCߴmSC"<:w>+sStFkg+?eܴQ#zV:S0~~&8Deb-!=L+̡Axm7d4|5=&S=vR}⦩6ߏ{U \T2s~$G!r^`BsO1䐷(MklXMޠӇ=Y#&ЪH/\; ɼCR3wOtޣx' ?sF Bpyʢ;{g(6W^dc;82R%3%;.H5<]iGzыeErl@Smë}'rd9pGP¤)~U|d,nx#<U Xoby&(C ^=Ә]P/Gl荷'\{d;rwiic Aw+LTu2R`k $k|RFx@$._]΅g[V+j ^|ƦeǏPtW6/>Zu}[7P֧{x! y HPtZ+Y5:Grsɔ !qG|i3.-7-m=ꣻ?ɉ)DBY.y8 xLڇQHI36]a^W꾋mR*\輁NO7UmȕyIϘ倇6ĞrzYZ_5D[O|}Vj ճBlYK5zL?,\2%VCv[JX0#&-:Xͧ6хlBzcrE#ܕ=sZ)aKFVߌk^4X^UFڀ`uJnB: sA֗EdΣ0RuU4 aL'ăe{-!úA.Ƒ(bzﰏ8+ qzT߷Zѻw4#Ž6v3մQk]}^}}Hrv:Vo|Gh^RBLҗ6@r#qN d<`KQ֡g(r6#^wRoZ]MC8ŬhcW c{ʧ=AyrZ ViRUCCQb&+k&D| ;sk8_^̱4#n(y%#ݍKN}\g#}S9K$d^zi{@*YBЈT\rF~Z L3FbYTn|A8zd{ZÅ)mhz]lm=Ĺ#Ў46QGa%$IB駉(,NWdymQpYxƅ.PnR8V2`c6/~b,h BFS4TIj͇K)G[R4_8%qV3__9qsBْDuMe@4-)5~BQU'Lg'txَO4-yDk Yj!eBN􀐔J@)#a=ai! A63GgcgᎴÂ" vZ:7>FT[a{3▋$r9[}ؚdFkŜ>xX~bA2L;+h@!ߝ>4|a?_phDRLB6RIo+\~I4O.{: 'E4j>nբeݷ>d4w:\NJPb+MT!TEټɦ[јIL>'!79.gp^90qgmr,*H0LpM\pW8:yA-eBc-^IF#L^sx|=c*>hwL`ys!9saFȣWuNk8?ZqCausjjºi.Ug9@MMsݝ7o+z@<+>{x㼹RHj%reۺ7GR&Zp[WVAHZ /6ZT3"<d]Ul~VJ:Wƺfy%̍Cn-*XES!Uh&]6$m碟]W'vb)S%%.zրr1\G0t{g{Nל=d+v;5RwNGB7TZqJ6+jm]{@ITxrS/zfȍn葋M7NceΩ]Fxَ YTjJOGz1]bFґw>'?zR'-\-Kܱx^ 7|ZP +ׂ%.kKL?A?R&WXx.ET}!(T5pJ;ZeVrQ~.~v'& ɤPRZkRKU1 G?\Rl3cn٧G@[ n%Z6ѫE_Œ& H "W,%| )[Ƕ!\-%OVo>=V̭IY:5z~EX*j#LkANQ-IRBmH %ND wi.d:5]|[]@9xLJ`I} pQX9#$~GDa-h 8E8Y"Xb0Nt)u q\,z^Ir~^8`f"\N[wUzQ 5Zp킙RY_E 'Nȱha#Eg&@Q/δ*^\ ZO8 -\;șY/$r W$!0i9P;?'}>65g0A?ώc^5;bStuhF+%~%d]6f5ȍh`: W $ZƝN[= U&fլ*mO {϶7L7ͪo8 F9 MSRQ?JUso"EwJ'Ĵn$z8 1A:ūyϐآTgg.0% a765ZMgy¹R8nd92OflIPjuXû2Uc+g/K#M*މ0oOhPZNanl][jշ6Zם{D_5 HolVYWA=2>PXZ_=*`0Qz5B4vMYK>hF]zUMPEhT<|,YD3 <ԚS\j_W|q`;kM#m)Ҡa5q,[дf_lu.PY/(]X[ʏ^oö~|AIЗsAv_T1&B4HIYKWyX˶G䒎G+mfFyb;fh߯7qt3L)L~Bֱһ! )J]\xm]+&dTvm+M ɋc䘌1順S3g獽ͤbhHLz,8N]n|7nNq0aBWq쨣Zx|2* N׬ލ (cSW]G Wr4؎m3Dt~ sM5YFtpAY6M/>Fj#~E XHo!QIY8+]EڈOeq`ҌQIX(MͅX](&0#(;#D_ccI:mptNBܾcR:l5uZPLʠښOkܻ/l{,8WLH|Lk֞8{HZ\mȏkCJ>ןE/vWI:R:cGnO^hrvɮZҽRz,УS&aO]NcEh?G!+UA^!!@%?kي`VN`ӈxВ¡Uywt?i*[Yz1{ɛ:#kńW.DĩrHq3Y"+ǕexTx*ka,mt>8m""C_/9c?Ɣ4K<xb IeWţ|k1pmd! x 9XlH4 sF؟ +3_f1N:+M pҹ>2ՈKa=5ꉠ,:nn(yj4mvWzǪ2(4sJI1g"U2+<#"co= ;A.AN01:u,coβw=t~z<+*o )v!Z3;g!gF?$=gJu>U*_|Yw̵?MΏ&3Dj:I\>ߗ_pcf |s(_ERLgԤ Z z}Pyuy}ak@=߹㴯޴qP@rR̘UwM!3SrаS3fmULf8WO<$4;%xM l_dNuT} J$+Y"kc'8̑WJUkt5ЧL)*4bF#庻F5񌶌tYv% EK2\0Pd5Ĉ|1z5u~9܈U8mydЬm%Cyv3ƣi<IJ6bd"b&̟6J G2vWረbY_gjϱ|thݚ:smvHam޶¼꠲pnD-cHazgQqq#d>;( υpLP)y@6:iy\Y)+cVbB+:fyR<Z?zԊ_3޽! U\E܍NEn=AAUgp<Ð0C5h ,;X,e-U"BQRK4?fIR4IVlCoZMLx$ٓR&&IX|q`+fܷ6:Xe[̕ksg=A6ڥ5<w[TJM tk"rBaUǨ.[:L$\@\dUC؅o Cz҆վY%X6p}δ-_'Yy6nE=MfѠ; `P05~h&g*~%lǕM>:kċcn}37U;t\cU~0,i웬XmIQ:JF4MRy)l+EMJ{zs{Oz;+m๒;ٝOFSf_Pg]?uiegoa=$>0dhQ;C&9ы5\eH\t'o@/y&#Kg?8<H_S&{TŠ;U":t7ǖs/1ϴ 遧=yxƱҐ1-.u$4pK'K-,>a;gP5 Gg55u);Txkn^i5 N6Bnc endstream endobj 5547 0 obj << /Length1 1407 /Length2 6054 /Length3 0 /Length 7020 /Filter /FlateDecode >> stream xڍtT.)H ]3t7HwJ 14 4"H(-)R"79{׺wZ~߽g2!m*H(ji@A> PCPw!ݡ`SqZH@ @" Q  +.P{Z|u$Atu98k p@<.PwhQP0`(rD\%.|HwN7 Їz@ݽv_.? ap=8 Ex3<vPwzs&@'l >пU @.`/ M>F =|ۢ~wq<<`_#*>ee"@yO ݗ:#= agk;OW~#7 s@1QA1 8*o "]!0{(=O (- Ou4 c/0D'P?"=`t_> ?.Zlˆ>/ `_գ-a?-P;ofH:9`t'u"~_Ў?/A<& ٿ%@!SHdSmhi<7ڨ^ꩩh>Wyz9 +sNTebԩvjc /7Fۄ$S$9& %{1tb-kkJ^=F^"֦8S^xgEb;`&|L͞3tf 3D請K = bսBH%蕄r/>$SP4L*NX5 tY]̓z]z)9A5Foo{]Q1 5vJ}WwUۀU2b 9$q~{H |z`m`Tdamהyng)ۏ d.?<W Fjiʹݲ%oob?ϫ= !]~XlKwc=N3c6׹OD۴r8?Ɓ`!DLq~xݗc)z/X+ibʐax8^$O_T5rR$~U+8,";SQF]| =d;R]Qɝ*Bj9w} B!*gj 15DB>94Ȯ"iâR3/ $6mv6!quKN[?fGGU l?)hٰǼO//瞔}n 'cIDE=:XP*x#!b|Q`-K7ԵQͪ\\@O3GnȹC7BGũ0?ΝCՒ1D0釸li/JϬ=9, OGJRj[wpky(6wF9Р\srYK̀.RZsS;{DHL4  7$N9zm% 9LЖ:]rZ-XLoܮ7DK2_X2&3!ڗjW_/b\׵d 4f$]`kbכIA U|59Rccv? n[}brM}u<[kEFiH2*RntQOZNnӇHeVش+rp2%}1> }g?:/)X<ÿl0?iEd&gF5~h]Fv; .7f[î*o~NrU I >8"%Vph ׸ǚw!g1բw&6<þ'f5&sXEQc"۴?)T0_:G6wu۲(J煎Fmj H0UN~ ;wu^dd@ gȑi4cB!Hb#rփ_**|Flݣ9Η3ڷh5t^qSc-L Oysb5NSce(Ae~X^Vr -1`go_SK#j*HKZ0_V=S7H+Iv]"곛OJ90U@ȸLN8&"#r?ejm3ΗkԺtJm3l4kE=ZuA]dW H-[nabXF2:|XQ LvZ9LSgwyOķ)3$J0H[B"5Y'\P<Ӓ !҃'_Ha:y`G=v=IyU,Yi34Dk3z)^wǺDz(0Ȉ ?%1:`^ުA){> ^4K nJiOi` ȆKVۨBw{\g *$Mp'%I$牠[bSZ/` ?EPorb>,5]:sZJ7c%R|#+xs){cFb.vĺ(V; L2PSSaꏲ;<7Mk+U SY_`=|1}O]&j:u:v"Qp>'-bY H&#,gi}}7INMaY3.tvê.?H0Ka<=wQmRb#eU'2Gޝ?Ǭn̰M9wqq ur=\S20kn'+qBUД ӳ9C}ܼw/~lh΋^73C437/,l Wr Gq­1FVeWKc.cސ栬QyjL&j.6OT~u`%` ?`\~rPc?˿^zD~m̓သ3>wHbd6b:f(I[0~=JU{gr7 r.rq'N4)HuC>dF4#ϲ6I*5ß^]'ؒ9tZI< > ]^ms$xnpc}T65koRIԳ,Ƃv'. p˧ t2?Pn=ixCKU-K~m$PàW%X4ug#J:[>}Рc3"_OI7eU8OE3՗3ͽ3J7T\j v )N HV5+;rlIVZLQЬ[%%x\imEjhcPWz4uܐ<0L.Nm$Q^:8[d|a@=(xg7 ~ u0S;zv:r'2pVj|l/C\ w 'G"Pjft;"5*#).?*_+8bސg v8&srGBGr ,ۍ?9Jp\Z[>c-Q4ciżp|2y}{V\Hw)|fx'Fqƺ9 yYK}K$먄KVQ]5]{FfnmkqMFȥ?mtچwe L54{eīDe1H|ޯt+ `L,LRZ A<}.UYߡ1GG,})&'Hujo[O*L~ǣVnFO va?xOf8 Oe$|M%ay܍g#]e(rW.֗TVj )/~Ep6cod 60%ѩ1fI3buLOB/vE&d<=fE1~rJ+fxR. 76M/Jrô$fJq0w?0B3K}7wAv$'/ȇl\J83-Syy<ۤWqC-Gzy_1~N}oRZYѐ㖾8 5yF L^X.xcʐ?szh `@xM*ʞ6gp}6%*$OyN YT:,9ׯ/?m*h+~8'> x ߼i,5œ%ZfIHT*A0"|=(DX=BO q;}"FWƩ6(XY t[Sۣk@]kE۲s̞I-arUfֳmE8n`'t˴\ey<|kA1CƉH0dߛЃc\Y6ůoosy2Sk ;^E~)Гq?'-Aknoq=٤?1c/VS<ǻ$F=`osdv tӁe| չ-S(Trh8<'W\ ? kPG'# \eX&SBX~V&Y? 9& aɰ8|X9<&X[f%ި }؃Ld)=9"e=G iXx~ɜ5^X#)IvB x]~'+I+ } D;cLjZ /3Q/#4զk&pt%+rÌLS{IJMžFf:wuKf&E{!Vm#R]ؔ=-fk),>Um#ԙȞȗ @4Mn~x˽zC;n{#V&=zJݏs`~4qeE!.]sBXIWqڗ 2ֳQTQ&G߸ 5^ r&mu4w:{vѐ6;Ҙƥ ?Ǡlc56d`ۗH1aDhwR<0" N dY\0%?'gLRxn6hKpbzdLdcQlH62VjS iO=";:z`c'AKqrv`bCps\=]J_ vg[%J<̶K)VZ.FldkO2wDWO&DʹyBͫ@A|Ukr7;Nhw>ڊai5W2}M_@4X4p:J@~$:y'3E.Cb7S0'76)aYrdOw6'u(/f`dWx];MY ?[nWP%J__Dt ]JSq3(jTt~ ]BDKltZB+Y81umV_cj0ɸ=C?Y2*g5AEĕ:M OfȖ2W< otR?H$[षP>jkzd&qS)hK#Vî^~vSÖ۷D9W4EO-ڦ+Lq; 5z(K\q Ii)j([s J9ب*!MtU_#mL26w;Ťd!cФճT3Y'972tCpP~ܓHdU{H$a5y0jn7zw.]t/{& HcFu &¼¿lӷH{ M&|/~'򪝆X1By@ endstream endobj 5549 0 obj << /Length1 2123 /Length2 15946 /Length3 0 /Length 17240 /Filter /FlateDecode >> stream xڌP[ .A38wwww  .]e/y^ݽ{uw #RP450qecJrT̝##S3vp41C&tГH9[l\\ &Qu]̍t)[cG82a[;wsS3m@iH`d hm`ň?v4Zm ͍ J3'';.zzWWW:#) dhbl+a*fȕmM\ƀ㇅cs @eh c#sv@wsS1@^L͉1Khhat[ >T?OzvNtVH* Z[89G9YK_I9ѫژ;KGCGfj`e`g` rng"_ =l&I{|y:]Nޞ^027t!66? {>}h/#[+?/?wMH I ebe02?`c+icbaOu]*v&gѶ?]`sm7 1g+)^YZ[Gk>&@cl?S+kldlW% hcʹ,t ,݌̝ ͚_ˇY0Cˏ 1Y:~LCcbepGAOƏ 52vt6N&&p3+^/?Cz?Cz;GOç"_`+!F@>SC;h8?vCKI3#5C9Xk_Go?22rEc_>5SJh?*~E~m/H,?u+Ŀd'lM]ǏûǸ4_>;ZGN;Apykp >&c~}-rY=T @^|`/ ':,]"(բCN!k}sΝ厖PД nt6x $W=YC~NX~#>e2d/DWr"1v6_UE2xjJN*{Xֱ;Q:)ri<\+?m wEK]8r≰@W!dt9IC4G81+ݠJ~6۽>%bߛՈ sZ(#3 0_u3_j8oV=R8,,ض\IzTqȚŠڭ?CÔmUآ7ʲTT49ӼY ksG2Y Pxq pe&PşEA䯯wSo6,qe:-)jy2_"_׭Dž?ɦ5Bs8W6T'?pm[|T=4 )B)Wn08#= _hI U9XaF؏r2^`OvGWLj)dָU]eO#(kix!Hk;]t@Da4nqlr=KbS9ӌxH$Qٔù߂tuMtr/+Y?&T'vS>\%}Xr BLx{wA?۵&Y/RC}4q(W,|t<Cwց={g:^='eiɷvDT]ЃFZ]C7@g & M# PֺUx5"3{hd%`jP~{5挫.[%*GBKy4F]2) fʝP'A#J׷%"<ǎd9êv? TLtŷ q @Кyf?7 c>g0l']ʠ_i虺gqrxmOg+Rr]g6.fhoq]mQ_ Ð[]a?cS@}_g)] 6-+K1'j;8m’#goX i^fAqD5J/덧(M.7r9Owo!>7ζ \t=1\?DĖ h{ֵ[4%7։oEY7k^\7ݩE)W`1ΥiZpk4uy`c'MEWU4ż?_q9 uEϱn㚇(JZ>f-W. hΕN@ u"|՗&4O YDZ@^mgpgk?ޛ p=9_FKُrCRK$F9% 3+lbh ;f4)tF[y'zLI I@0b̨`0 *;.NG ֒_U׾'fZ: X\R: "sXQ՟!.{1Aӹa׍qm%*ۻ龴*<]9bxJJ 8 ka!&T~D[Ut%o-1EBmƧзxy&``s`;E8V1[.N.Z2 aO\Svi}]_ˍM*dE7TTm*qߑ|\ݠQ+w;vKe/>"[ FzXTn̬ VYDB#{I͸h;CSl":C*4b ly |]Xp$J_>E"C|g p~lN(GD_ 7S$R+\ΙF;VR%EFԺ jn;L6LM_`I5"Ҹ[-YPGрع?R7nqYaCCT}**nZRg"B D< ik(n6V%ce1>&[*TftyA~ o?J?7/+N_֋,񔩤V]~@W }]i)A~_x20OI߀OfՅ@tXkŘ {LтP_`[i 3& `r< j_윓c},)D3wX(aJO}skIx>zZaH ա7_c%I=*xFO 8?l R/~>ݠםs1d !# ;wL=_ X>.Ƕu6hc&VJ!UkBfIgǒ+>6+HQ'<ĩ>y  &S.74dQiR߱#-U>;ݿ!q}(Ɛ&}1_<"q^$57u{4>ekA-D/~k<q^6Uo]|`n&+@"m綾vJدwYPE}88A=u~SjxQOG'jGPe%:AC}]| lʨawNIuP ܯg̼qo*,s<ʬMovYf 6[4DvlCZ3|34 _v-|"UXeEl d' W'<vhfšt{Sϗcџ9 , !B}i&(+E'[L)_3Sz %א>O؅l/ؼS9_mY^X9Cͺw SɢݦTd׮+lWιɞ{Ka-ILj jw]FVV'1 M \](j$IRd7$r( =l%w#~v 6|=MY?.YtX4 N}/P/=Ke4< B4m[,~SM$gE.j.U$Q3}ְKèO0jj1fqhnӏJީL{G4>gӉzdTw2[sT"(KP;#}.zwW9%"uԅ/$)xl qMȶ3k܊wkF5>qfquHn[ :=hX:i5D@BoW; Tt,NUQ"LPmջ=QX}K=Kjn] i\4+gcM伒Yܭ*,ͪSbSJNB:x;ʀɢ][kE`B]6 d;F'4r/1 Є l."PU¶N[G5tK"45`#js %7jk6/lPH5aW&i H8:;Yvzug^Ыcv_J EyT۟Y-mq ugx޸f*JGpfb `<\fiɇ;1 `ZMNa73aA8 2UFփb4En)őJ/A{zxa|Yzb]4m1 ?iMSYd#1`K+Ib?8.`OeK`+ba/l1{^,ǙHp9͹00R_~"(/l̮Q] ޚY@;a&zN݅T$kDE]`VDœZ^1tUP=͜6(pr&i*D@"@'\E l}-A InО\BZMNYIs\`iuǥQGI7_K \r(C@v#&ѩq $*`K[e-}6Q̮."@]^C͏1ʖz\ue+jw B2ȓ[BnOKM^u$YZkxJ٘B h }of@P/0 e2 ~Tю:s0 LZŐA[DP[sb̻zkMCO;Mʈ;=@GvB6ڔY#nUd87 ]Ukg;QЪsչf{ қUۤ dIAO\Wgm.]Kri.{ ՝LwHZR[)Up{]c_J!7z!MsOղ+Q=[:Qݰ̷V@bok]N61SF Om0JP3 q}pi; 4$e4ch;5FBZ_Hݏf5P/Yu|ؿ~6\ IÖ'$? cɯ2i!k!1)gB9blܢeq:k~ ,%Y8,\S9^Ԗgn+ '.h_~ &5UrB^H1=e-Ҽwx{?eMŁ(XJV7yf(:s7<QBc ZUJd4&|@2(5o=(S3ͨP,XkuP|' !qÂSUhT*2j͈Wa$&Nv .z6J#V9`r >Uhl`Y6<]=M"h"KB=,!OOS/nbP4yh,gi4"Wռu0.r0uȤV~b2NrT~9Igɐg:x|?g_tx?d>k#ҩQ~SɺTX}i R A25l2xJMogW x'+.B˃4Hx3#ނ[;َOj&3#-oX~:?7ٟ \즛P5zMNڇO$U)sG4IYHMÑPSZtEm]Q¤x ^[eGkt~)T]MvrSҿ6 )DV{{nR@dټfiO,vY!;g=XJL]xa"v?L[+ 5nv)x3! ֐̋qyTd@^X]{pnWʯR"3"6VY ^x@QR6ElDkW-*}2;qbN-g6[Ě+QXxw\r f$Ѿ$=U}4wF [f_k? *M;ϥ q IU&{l"6n rHPz5Y˄Jf3U0DX-t{[u.Si3VU=} 5mRY*}"ύZ6L7'RHK ъ}zA-<܌I%0awwC ɱ$~s6-nd,Y-AEޯ97sYV[7ptkF7wF0~4lK BN&_-oj;|6y HRNEĿ統D1O- RJLS(TWĭ}=%7Vc6B=r>gaoJzs v/}M-#2f3rLh'b5F֮@_:@LE_Jmb^_Zg:t @CO[Ot8E}cIAuU`JZ);c>\7(BfK@F9Zf4%+Pu$4+<:g- %C4/;1N_#M$3b_v9A[PgWfIPR* nC\7|%VvH*4dUg/Br߲oh #7tGF]A!63s)G:drL+8}c$F~\=ѦRQ=gPzϥˑ rxWXlŵSJ̏tn YClokf} \$m`ATRRN Z.3MoS>a̐]3\'\Dx{ٴoϰ2NʔwI6?zeN=!wat,$#8ҭhԱZjuxMũ0m}q_qtB+iA.oϺ)d# Wة2?P| a_)g- гÐ[~n\ڨMaoS[Ccq493 qi䰰M 6#B Zb)] oES8g!ەt=sE(nSC{d6z`AU`1PXt6S-6%q;J g#3p\,g`(*{4#Ϛ3>.2CJYDP2H>᰾_{.1Z`P}w?M)Pst˩XnX3/^[tn7AW6Qu. XՙXy~75A7s0EJg5U[H!>=R(dO6O8Y8۴r.9r5'yZoT'2j(#)njJvN7,(} –|8g5W@մf$\"_dMH{/R d$dL*g׆UFi qڦ>SytZ½x;Ssq:"C-e{2^Ee`s՟}X͑$3FBX@1_`ڡAjnk3x&Y?6Rsm{y;.=jɭgLR]PhU'70 ZyV++j1V/yί>J#&^(_/z9:prХbŪ@cGV<"Ņ|#,$ = BRwgkoAV^`rCTXM3"u8gP`,gsI2ŝl*/]~ڲ1)%:n-L;HYJI2 [ -b}MH_2£OۿgC C\`fepgέ/.`) tDR^DQcEo6g=eH]MY#oIfǩd$d%Eox?V7~"v6>957Akk Fȿ-Tz_}S֗} „( 25h}s\^9a%6o#v~9٣ Qo :@[Ě8=^x{'RvU=UCNˋȮ5$qmO&qZ ОQ*έB#>F\"~q`=Cb) 7Rk_f,-jꓲx}~eE^ NyvVrޛ-?UФkbxDRr!+ú5H3!7Ǣv0Q\"l0b.Ӈei͛˿"ȗO9B-K8o+2Po .svD'.0 p=7g~):sx;#8a}6* 'G[W-Ent9`ذ/0HOzPV> 蒗~Fcx*JheFǔNTQS}ʉb+\5HH*CL:x. އJo5XƲAD7{F7BջI$67<+[ik?VEl6OR?TWl(V| |'z*.Ή`G  *,J2&OCǖGػl>6CC~ς英iޮN8A@tS.BFrfQ]z4FCiwKD߼8:ݧ6I-CˉKN/N흌Wǵgmn1VMHf[k=X2e㹙|eax`Izl{o϶b L{+ Rc/eЬdgfɑ C&gQ́T&Q蛍=֘Zvˬo6[r.VGva9hw̝p1|f3 LGyPm,\6_c'fcU]Xt 2Up-5&LQpO%Eyۏt"Wj~$Шxsl+Qٯi G+C%S^g%O'[ɒuU#2:M vN*(\1Qcp>4h$'X72gÍZ0̀ 4[Pw;" 5uK56d =eR]hfM-6  kuL>sb0pSJ5y' 6!ɫ:H÷0UBUT)iԵBYl&2#ysgi5llF!Q OG39R74'6CcG3Gvͭi ;~"1w}бYo-IˀQ=sdN*\lM!4νwE䰽I(~0*]'%DYAa|.iշOa0ja.co(jrEźWD#Qp\ʕZBީQ@-Ԝ&6(Ϡ3I ':O<ۼxv1rEv9p7ҕXPN)@T{| ʳɱ nfh*dq7-[WD₉ѷnzF'lpUWL5Wh̋ŭw*'+Y"m9-dڸ #>1ud7[2yLNe}-IAtgr>.CEKubS ɍ; QټC#4 QNߠ`Z$Mݸm޳šOxTTϛ({ 1޽vYDxrv砻viѬA+>󤯹 Ld':r,UnS@čwdUt1|L@L3;1R'(64?;hS](sm&N '"}t,NͻloUYƧU)ǯ[e\;6;Y`*?-DObҽLv$@ㇸU:ǍOA!$nzr(?+k#z2@^T ~ D5u~7l|ؐY@j$&LI :G Rx9}[! G/ }7Fk 8.Z9,NjUس2dbM%ø9ϣSa!^ff/$$9ˣlY0&;72Fܛh5&Eʥ oSaԫ]Riq!171I']UYJ Uz.hȈV6ö=לFEv9a99z/Ax81?ئyrAH~3jZ]yy6Q~#qr ^U=QMCHZ'H0`ING7FȁS7mc*G V u["YD3(9{u{$=G>z@f it$2Lݠo6z$O&=BGk^`lQz=P` BV?E;, eF.H4)?]s7CƏyHd7~:B_&WצiXW]A'o'+ҊbtNU.#cHc8P#FRV&W$6U\dJ&~rCI[mzd&٤[7E!fЬ"1w5Nv,KP2ܗBH ^"n4i,Y~:p OgV'*@Q~A~235(5< ^p8gVq).a٧UgG"5E4` ^,&x1S=K~X4 mΥww2E䅺ć=ӧ3kh <pJC񎟘\bcW&ѬiJI `w j1[&s<"l1LFi?.?&oq&!L&1ލ*9?:F*y.-G!ԁeckOMJ?H-^dt9w"& y2(b^ h#%p#?o4DZ̍0 JE8xr=[00CK 7C4\'A4SD(wXL 7{Ge(?XmXKo$|_! endstream endobj 5551 0 obj << /Length1 1398 /Length2 6789 /Length3 0 /Length 7747 /Filter /FlateDecode >> stream xڍt4ֶeDޙ[{:L2f](!j&JQQ袆=9oZܻ}뺹،L]NP $-UM $& `h8/5!᠊B:5O`1 XR,% EA 9"Q@5// A".Ug 掾.#יT`Pvz\WtHgh0[rS@7 uhL4syћ"]~xÜ .4zB8 Xw%!~CD t@C =a?ZAr_ qv9l \x('[5ȯ4׷pQEzx@ho`(= CSjr[E%@ ;Jo mR_O^ BA_( @' wk5||hdw /$o14U13536?0HH@&u}g#6#Vձ_|2@^ 7mA  !?y3>k#ioWKC]`>mFCp}0o ?vv?z_,P#7׳^ٮ|o9,pF$BAK$Ak.@("@C](E_uoY\(EQ uMظn_oCPg(Y.nUT[~B- M|NI UdG̡O/(M^mWHsNf"&!3 `{t|I^PuhLŌ.THc%? 5•-LOO6rp8LN d3A(μ㓯3f- wq(TtƂ?>'L"^ͪ#j+}&KyOQ<>R-TR; i*;S+Aך]Uf-Z]3M|y{!vk :(tpSۻbJS̯n7=%Ŝ~ijS N>>r^(Hhcږ 8fנy~b Giy)ip!}w]L1;7?Kal"\f$#;_F+V 1H\[}y'6"LE'lKBk5*2.k _Ӭ#-NvbUz3l0CS9v"'-3_6D2Kۧ-/1j\< j2<źM>+{e á%-SXc_> -rl_w$e“2n>t5SdS hQ+ lj KxgFSr.(&.>~}۶sNM1;ʹ_5]oe1,*FSsƆzXt6?BF[E:Qb-JLaBe$%$[IC19LCV!|cJUgKn"Y ll:V~HI/ƘDjXp@:1w9,`PI0aƕuړټ0š7o{6hnp'9#${$m$d> )v:|v9[d玟g| F<[պIJEk^lz._o!7/-DuVyJnGpn uqu}6Mi;\(j"YWtHEL5H{~%Bo*r5eI^h>w78 Z2>:yͮݣCkL}aǴh S ׃xh,2Ȋ%sMG7nhjoڴ{ >jDŽFB.(GxIo(%̀E,]O 3ȼW0r1rZCI#Gx#h􉃒+֜w(~w^Y1K] ]Na1rA3>2c15 aRrCay`Qhmo+k̟j;=Kj 煻L:})Ka[|M DL>̂EQݫ"`.IeLz v)v1(⸢H_x}M)Nm=%wۭodD Ú=y] B1)_/WkǪy&,'#[^u 4"0""\6UtWGVb؀=<4X٧ sSx鸨_3]RmewgR뫚!d`cZN@ӶϟzA`?#^?BCa>Mz/Mx-6qZGxG`{qt_AnW04z |_1 zA1@i =>tHJ8aOw$9&)pX"QgZ >@c\8<}7,W}$qʋO<`?%"Ҷ-298/.vREQap[^h&;F[po1N(B5u, QDrb45ɌlIyXB<5H->JeUwml9-*GY$^ܡi(tUn9Uoe;݌K#J؞T[m4103 kC}S. R&6nN-k/hHc8͢qF?/6/F|%zSU}XiL{bUtbS'|>ȹYɰn32i{g :2!p@<˧%&MST}0jMrmC|OWQ`G8)4Ǯ :]ћnXy!3 |.%G,j'QbB6UU :gBa;6wXV@ty'h7og.BC#Yz(T7gUK tp (dPXyOQEߑFB|cڭ!l _ =iS&RDJvD?(;#UFKSXr|@'kq7gNK 6FaZy4 ,ϫ4YFɭT~JL쟯Ӳe~m Nr08x*JWدݎ{ğX`S ݟY.j)c'I{PaYvhYabl7f#[%one{z'2[g"w ;'BfS7Ը-º1KVZsVڅeD_'~(#h^~n"I 7Hi7fiܨk~LKpdy3U`vWu"`E0_K̻=9SKh<ʻJߩ_Ti 4L{<.JgSK.+b|' SXu%^Ic^_-LF,S~b:iQO?k8 Y="Rؖи`YHVZ q?́ClҬn~:a&^.~Π˵\^Qru[eOV)>ȱ?@Ngc玱Zo H5Kʱ%0 YcG+I% 2s#k{Դ>xAMN)LVT^> N_|}:XUbQKT;MFc6%MdhQ܇)4.uf+߽Yr7O/5K(Vy\FX,/Bkj;jFƸwi5j]?fu8y/j`/4iA7*n9A!QuW Ȑ2`~M2LHiuurs\:i]ϻª}186;( e.wlц]W-W nWxs{fO>ax1v;kfO4'j/mf5٫]@5>Ōל[-e<^^ato0|YâkVgmCHS6ۏ,;\[-X,$T މݦ/ژWlI>:b-i)M? wyqDx#—'CtM}<^*MQշe5*4}$4k&/"F/v+eX35O|W;'iq'ҎzMC9~]Q^;bs0Ұ/(ufCĄI"`2 5BSYf*n2CEn Ċsϭ'a-Ȃ܂6?[7W`{z(:ʐoV{ C:CVv, XF<~ ' "+) ܏KP*)7]pt.jsL{=G{4ƽߊ \grD ̉ݾC?ʐo: Ô7t^+Zڵ=/5i:EVe?3ڿ(9yPJac~I.NCqzZ(B˰{2V?] Jp>_ PMR|F-[`;;Δiˤ5K!ڍS$_&tn ^PrAA2o)5C)r+W۫YXy7OB5\,4FViiJ5/ EJzua) R+A+;Rff=_WR'op57+WnfkĮ8 SBnı7s $Ւjڮ2^ُ23e7vDhH^w^ >1v{*j'D5UI"Q7fFY̆1۽oT[yZc9@6۬jȑ pPJl+ [F(n)kЭ\Z΀*K޻[7kպ'N 571$ $cPN3ؚ8&mpW-8zc"},քH\x䚮QJdĶQӇ =g8= __kBhklكiw'?Yv(>0+S+Mqn^}WFkDv.GQ}4M;WqQv7D^))^l<gs RСڔ*H6գUN)hmQ.):ٶoiYʘh7'OȂ?>f).h[/t|uY??}$<8fzV޼J /brJYkhLqd[L.{hG[5ƙ%{NB)*~N#?5>G)lv"n:T-G] d'YE\8#،eQ|2F'c>A-#V -%*]ѨǓ%gz J &mlL 5Ӵ C֡ J4 vRZ9sZopYI?QK=Qb~$W1ɶL+J/3Փ| j& w甒mJSvF#˵ s :UT~2.ETR7S}c*gFdVظ)QtEû!O3YlprmES҃_HR.j Y'B;4yU]"ADK=IqF۲\)"ux)%Sah`H`&g"I~(y%&_{"s ݄Ml]W '{^ԫUR35 RH/idzױբ7Y?[WLIiXM&/nW~b^nI-,MCZjiSU̱#[J ZO'mhf:Rk-Ew+=nyO ްwħZ\"_]jSqj$((v?tN!=\ viﮰf#t?ښjnV0l Gc&a}r9KܪR81ԯG=bV%FIk~ZIZrMut9| "ZfɑŶe5j6he> stream xڍt4ڮ.J^bD'D$h !`31-zޣ!zoAt%(!MD%Y5k>}LTr預XQ 1"@$! Ā@Ir>>s8&糄a("hb``^ QH !US@¿("@  ($̝OWi $nv0p 0canW!` ð!ŢŽnb(- aOa 31r>3nrz10C`H+$\%a? !&p{ GvC (74 G:X#`; #Wߕ:UXw1w8W\MY DXw_i10ؽܬ+GB5@[ <`ZS `N0,@)H`0YWxso4Q|Ձ/8^5;®}0߆%$P8 p9~.lWړf{%/( k6 +*% (dF1W}# ث)`Ͽ_3J04(\=$&_Q_t<f v#&\i{C j0(X##]AMX-~-῾*Q lWqr_) v8L6LRF`+!I|%V 0@\ ^80nTV {q5+7"-aPx`0W[ W{a0 B>;u m?Vgx<ɷa!$;8"M^YX r%l4!OeRHի+ 0ݬCq^6!k d!M(5a]$]%AXb_ɸw>/%ݻXyYY8 F}5 /cF1uH }6@'};~1EAVqB'1˭zIn%I$9 8}[IKc\ Ba,gTpș1 #WOY4p˼`8Ь@e)+h{ќ{h7?g3鹽&`=d;7Gݡnv| [խyZ"Or8=Z؉byR3[L(n|ʪj"?PfQv^U/ML4> buԃI]ĪAd܅`xUW;E@%2'3 jJ#D uqݝɂ8v; Œ;~tȃC/}{seڷYs՚]gm=drm&Z+$`RY@!dfY?k |: Pr#y'u$/,1I1apins`㱯SBJRf,à=xwo<~r% t`gYK-[olY|{3C,I!PPS7ϟ&΁vNC 'iX>͈ލU fD=7;|eStתLYֽSBDآL{dWgH Z73OE>Am5&$9wԟ׎ۭ7ٓ)0eʈmSEBb^(6v>9 l(T#nEf=ق}+2>VYZ3ȍS}QaKF!"G'N,#:egyZJ,&V>u)]^pqu[}X ʍxk8r\҉xk^!̼W.k,9@HXr~׬G_Bu\zle/+iFųKhrP)b*`5Yv9S؆Lrvm^ .Ov?>!ˁf*9tt`/ z3Br&=% ek˹g# b̐LgYf:/᣼PPc$-. 0e;,~9&K^dVwZVS1=خ1`2/AEz==_ȏsrU3{8#k}: \"SixNeI0(,0 *ʷVN-O.jN鱴ɼ $ްh`|KoTx!$&e4kEbdFֆ>c7w7>1kj&7V|lԦ^RN)$ a([OdՃ#.O c\&PeH"xɊ #B>NMm01I7՗SjP>-~WHd7Ma=PZMO,6ѽաx>s_{Ûr r;s\ŴliD2VjeX?Zw6l|aC-+Ԯn-H V/P4BIl}Q6^o4Vy['&6B:rr?[Ŵ3=mWyAYZJt6g(pZDae*(Yݛgytkku$/ˋۙ@CRg/}7"kU}_~$(Qx}AS&DTRElFoL"Fn1Wh"_yi;L|j]fJK;T]~`{zLxgFvMP̺v:ϼoavR}7ld"Ԉg'=($&;rw(S"3I:6*3=lIg{ev4igX⒞Q$WBqJ1-+<<2G6ll{rCM۠eRn* j_2R|Oֺ[/3])JcI0͖h _%SgZ.J's_pXA}`b *jYXnxf.|]%Ji(G8MJ+dd2 k,̝X mOXGxњY9iDF ޵ϙ|d.B4[fV˼.')aI!DVE23*roN4j#Gh$ +eJU&&98+a>W(;r1ꖋǠ&\\_N\љRy lpm{^yZ^:Q驅sۏKiO*уl׆FNs9"%GX<F4Q-Pjb4/Dx-1M0ؾT6=_x(00󈁞s?mX$bcxk1Y.坬\?ɸdcRG. ߅f ?)hr.نCjx4 ze SL21liQp;jFj12;V/H.U?{ ȍqG|kh`M`w9Z^]Չ*؛4'2ZaYM_xCg[PjHI,|V2Бw&野'YrlUJzh,$4[]JU8N DALN 3/inj+FD%T#~I-*>k-ʦ0~Y#kkUEIG +ҳA2^3i)a99A Hz<aN}_Nǽ1ʠv"%xƬo/ĿfN?IHȾZe~b1Qiۥ퐸 2OBUk&,|Ե|ؠ5c+:鼰.FȇcMk/? yX3Cw(Ar O{[[V`xLkh=piC!;={$~VKmHf;}WMoEŶ&n >m"4w$#}mM3+Vf l!YY`Sb{ߝpM̸֋;<8Z۪_9DDAX`JDwU3{ZJc}Xb8Ic>!j]+DݠqU9 Ϗ_wG;{wP祉 ;S<0+xsCϣ/C] 4x>aD1y"7ٛC,?E?M:cmНp}ۼvt|=AmCRޭYWHʎQiB'N. RZDܭInwn3܉5J5f Gq̃V%EBo~ӑ%>J.x3imdι#3 cL*2Odﬞ1NHyS+e\"Ή{}#1Q){%~/@Y2(/KrJ[^kEWA>1{خdr{ܭxĆ33> O .fY^{{ P 9O/-^~$_-9lVjwY!bAf$"jщzmr ѳo$vD"m\[+MQܫ>ݘbJC\a$ǪIFL&SZMerKf}BSiMM%Fk7fƙV i,GJ7'*yw6ێMDh f3i5 E)RdhOȈݟ99Ikߡ+wbD38&3He1/MS{N6D*ygc=²w*ł^fŖbBtXv:x_|6? ag{ӻ7Sx&SERaxiGb0pة?Ͻ& Kh[ׂ?DǦґM)^`Wߕ68%l8QJ=LW 5(&`Ū9قe+~\Z=Fwз³ ,W\W%gu g?ɨ䶡I,̻ᥑ#(݆Cm>x'wrM)9Sͻq[o6s.K ɬrhOt}ݮE~πcrџH'`UHzIx9ߖӲr7M]h>Pu}iRxEX`##opds endstream endobj 5555 0 obj << /Length1 1588 /Length2 7995 /Length3 0 /Length 9052 /Filter /FlateDecode >> stream xڍTl7NR҈0atwFc6;$ i)I.4@>}glw猝_aUGQB@i8M`(W !WAB(4 Fp+@H $.-$! @"U7'FD*w?$?G $%%E `8@ro] W.Yg]ZPG)@:s|`(g:~ A&@0qy(0 @0v;@c-] cǀWkBBW 3A~0 uP(>@0W=w`!lr@]1=\A##c}6V)+#|@ $$%@ + ?ZpG@O.'a￦bpKf,mb@K]+o-/G vG 55YW=Z(0zN7:P?TZ0WjzPB@[qA?h>VAK+ïHzhI  ^Co./@$@pE_#BAzAD04 7 >[FE<6h ]P?zQ'z5f(g$DC /$:>7B}D&a]dY]IU n9[ tenj\'[ K1_m%8F7Z!ZGY v3f6{$AřO޲Q3k:.&LmJ_LӲ%:1y'oI;(h;A(jE8|DسΊɝOif^-#?<~;-MuU qx}TVR+.~E3խ9O4gA{WPޓ JTL3S2RZ^T')AhˮʸH#<+|6)j]NY<8u4R3$%jI-햇f;P~(hcesqsGrM%af ݢ!?㫴d}z †xA /To?Lq='AeQAgh"J+.JUϩqS:Z7&֏+'3֚?~E{:i bIosCٴ ./EMɗq~cɈy[/ ~udxk-^FL@+pR՘=O: lf4z,# {cU&_wă kvVN9VW[w2xyy!!y1x9Մ 8 T f$ej*](> FVo)N0c `)‚qdJ"Ң|6YwO bŘ$'ˣz/OAaL&f EZ@?ɜ+5\OCJ`Y51>j}S?Nf?GZOrOa5bUؐpOrVqNޖy $ x!YP-Ux'QC>6*y|e`xoa_YbYlhKMJ)N>ꓮ>kdPYi:lRXMQ>&Bx=Y74 n?t-ۗ3f?DtgzXNDpcNJGPMK!s$u._Pj@5'>*yO!'kW؝Wœ|:o} g~?سrQSMJ7 7j_;{u}ﶦnHk J4e,oV`o#l~,c۝-~kiy4^|T#nkOoOgԃr.ȩj:-}I|p>x"P%/ϋjiyfMs\ `mVJaVG-?R=T44Ojq %ÕcW>'?/!+Gّ~/339 $s2ެ[⚅Zz݇?a0o:qPJk{?Χ q'g,:;pKRqTP}<oL#{AMx)M$vϧ|Ry ]ڌoJMxJG |iX,}MGHg]Y[|%^5n7RW;wBO2 |mC/ 3fr)[R+Wgbs b)L 2yyJB*Aukc5)":K(g(ZRbnLkJ\_htֵi40Ϫ}1E<0%/9mҩhX#--E⮺Ym{/]5\ە<tALt:*5 )s~.FX:WM!Kp='wGzOJrEJ6)"$*ܹ-aؖ[ղ@_{60QP_dmu[gk8Kz@kV]Ͼ(,fyӓgCAgEwV/B.;2]wRLYacǢx"GX~ `GiS2QٽK<{y|D@[ѣ !mlcە{Q8wś3V34(5>qt RD5Zqpt}#)*qb0#V]*t;4l%ڱQ=~[V=Kb GWV$E!>-]}>E 0.w[wHw=UΓe%~ɼ7mm<VQ{ّ}Tr+>ZD .MB-q7vo09+ -[%XhE4W>V^Qqo$Ǻh$!>B%`wV~j@PНR57p?ۄA'֐.~oW}\C씄I[<4#MBkKg-UX%l{u@to=ݛѥӇY#^^ KOg'8acv{W 9P}j{ڸ7VO6n51&ܧ?<2SCL/Yx,R*6^6Jo&g w|Yz3DEm-H[ROeHUIȾ{\g壁<)jk 1#/nIBwyA~~ȕ/NP@;}<@j컭..b;ss|kFzv^`?9l^#ar÷l&[{wLT}4g n1T i}Q;- R|I1'"_7sW7f摌}A4$Y\Kө6]^gvƵn3k^L'e,zI+Dw~V [= {M}O8 g@{?-#L7'qNEy?l񸜌J V{#: o5hLK>GPnV*f}T F J'x%r isǹ*g{Aa>6d_!B̫Jwƌ^Phen~5qDHUeK.ۜx' a*Qu;b8*<}^7Ϭ$V7)-FkZnƤo)b`TG=p8Qeb^nA((;̊F'\vWM9;msܻԌ 8ר^b)9NV %w &6V[HDBx"og,x}6LU4غsbon#--6֎(r4.&eo 놸]Ӂ|r{AQL*1e~-I x֎ :%)4r>V9S'd$0{)F^/FÐ].ki|7?ɰ:;/H|gVYl(Y+Lr':1eϺO\{u>;*2ƌGKM&7.q,o;4]J\[9gZD*AfW=y$Lts4Ǻmk\*᯽j=p\M ^Oo?KR;Σ>Se:u@LPP t'J9R'T1$۱ SkԂ)y8YgUe|wPA\Y}Rע$i|zKB;cV'nWa{mMNEVB1Iҡ`\ʹxT+:He\┖Ye|םSGg.=%Meezh0;XhTeL$Һ $yPѐ0↊)7oH|GrrX 13qHY|'H{&7oE@W{9v [#ۼ%7KTKu")d?6}4k&GU+w'u9.l9wJ:xdbdžXoqQҗN|NN-@TRd=b9}4Xƻǹe᪣UG98{>n ] ~Bq Bt] Q0 p@s*"h:52e5絗Ym1T?G@UE6XF6kO:g̷e4"?%p*mYȜGc%uldž6ezf{Bk 8kQT,ݧo㛺 ^PTN]vVtQQ0ɫ p5HPa{h~2 SJt56LbNk귐7lB2&ZJkUyn %97 mx"^'|]vBePbhhn+dTpSN@I֛/WTA?R mooK4jym aM{oa\;&jlq BnW(cmn,^4 b&|ʤxg?1k)K[ȅ8"M,Oť_**3ÑFBPRhIv&^:R6lA MSDAUh`C(Es P =ꕘ~{6AkFjlJp鴈 v~HB/c)R*J8TiuI*$ׅ.sW"0 ^UM_˥BW)ɼrfX5>ujطx^ɂx.wľZǓ#VI\t.4Ɵ쫊`݌tT e>225EuWkRsܧ-q#5c_HwDi4E .?:{DWCMupRM$rN$xAbfMꞖ ǞGiOLynbꏑ*Zsc S~ xN1P4Vm)lŪ@9^s 5{W2cp( H8|VE;0"r}I;4yg sYk-jmFi9p*vWC,z2iUF{gw} Dlvw&wqݏv͂駦qNxP >c;?f^osxSM BkI'Sڙek9.u)a5ǝB(tAb.}pg" j(5d\"mcû-sƶ˼.䓍`j\-w{oC7Zhsu1a y冯G0yRwփ9Sѭ-@TY]-;be#?KTg40WPic:<ñM+v~iR3^m{XNz&{7},Y/Y yϮ+C8 bp9g7ֺ)qS6m<"* x<2f[l%m~Jڒ-aLr#*H2"RH1_+wVkJ"AQg,Kٞ/e TGoC7RHh%BOA2xAqDKIֈ+C렒;o>*:WQy(2тW$Y)ZCH)eAwo~]%YڈS$eIֺP9 g&yQ*E}i!HjfҘp!< etaۼ .k:ϵ@od*?N'ʗa??~Y`7d9'cI^mίĻ'x.w@^ݽG7%rV"wx endstream endobj 5557 0 obj << /Length1 1357 /Length2 5946 /Length3 0 /Length 6879 /Filter /FlateDecode >> stream xڍVT۲I HG~)JOBޫT)B PHQ MQK'"MJQ HE=w{kV|3g|^>oj!qA`8ID 46W )D$,ly#XAX?$pM,#ڴ`81 {P*UP@iD_ @R kb|Hw-(UTTX$a8x" X`H.)Dxp>J`p`` 'JH`C`v 1)0`caX@4x#1ij }#菃P)+;cP>0t0!U#)\N]9¼0xX s!:.訛0bu"}p~R~H_!^6UB!8?ЯXxcBc?k7$W >`+4rDA |D+e7e&naH7 ?w (pEq hF'E!DAȯϿWDnb.X@Hw440A^RZP4@\3) Wcn@O[WM_/ae!2Mp{Ni;c,oߨ/0;/Wj#Wc+>FԀ:ߗA!\M8[70!=($*#7 Gj_꒖`X,,D1q'D"~3K18b@l/ p`A)/#X,QVO<_F p~˛*y%J'M Tiϳfi=LEv&bRC͇AoWhx%-ՖB}CEzד_b0g "M[4[z.oH{T^U}dpQNJ$V0K)A8(lL!nVhȧ~\B\v|;,.5V 8>K Fe>8膏(\ F&_zM~~}Z m]/ZB7b2ұD 2#NN _KK' {0<ϭs1 {{2_e_w+| ߌ^U8 :#--pYږ2cU#ѸH8Wᢐpr,spp^-Q:Ly5p͖%'ՈNzRЪEq))飷Y[ȋhxu/%9߱{V޾gBO.֧VMyJ9uњiNH>~[ҥ y\iƈ< +PvQ)ݵVWrg6r+Q j-ZO mSuѦ= EaNB_kŌ5ಳp [. j-j2ٿry?g3畦1Y"s6|4~qjhiY!}SU,)+ׂڃkjӯGXf ="6O*{OVTbjL¸4LAیyy>HJʙs<;ߍDyfV5~`lsVUʫ)"Ž%M`kuu܏'t}ZGm6p5pQa5+ t4BmIw?57>pܘEa8㗺 vnYںM~:YW9OFU&5ZV(S7 ;~Ig,H!,B{=X@ 6_XPUmKog~|J2/:H{}{R \Ń(q^D:2wQ97K.VSU+(kMzVؙ<1  lP=!f!*7B6G qaQ<:Y] yO+QW9z\≀v%F]%f8& O:d 6M5=S'u E[!.òi6s>-p;bW.c<-rHrB*lsH:'n9ŗj>Űmܽp-$+!{ϷLsrvJ.j#ɽ]џ򹜑_.A[h*YH^ęう8vD# <+s-1{S%ޟt#PՔgWQO"Ǭ$hȘu=9U}Nc ;eMZ=d2[剦ܮ)j+(ȨfoG]nqJYތ$? )/(\c#/}H^VD_TnQϭgeW>h|gjƭILdfDHY3e Le-9SKs$ \UX ٫;>}O43uF})b t]aTnHpi/mC7)Ӟ `N;xubȃ]e^S׿2o={M5nC6ژyZ=Wo1WGF[1ϧ  c4M*be>ހFˢ\Fa#;A(T9e1^zmKeKrוu5#_ 0o=@qe,BvrPSʕe:Y(sMgeB \k>4su_f&Ukz9 ;Z\oipTlw^-]Y廦Z$-}l,q9+m̐x|Y(Q=˳sVzm2wAM2kMƈGm\M+ԫ/=Ż滺SRo-9 61^+ Fv0xz`t9 R]i^rf Vy\S G"-c&f:ƁG +2{R:N|6y:a5ɘUFC.Q.Hn`{{> -QMPTڪ7t0 >3Z4rƾF68JPSDxO_)Py7a)jN6v'"ldhz!ծ/l[:G&ԪlhFG>A*^M;ժ 7ZCHщk]1]z:҆4~z_w&n0!-(",adg#Llm' [qto_7/NNsUaj{[F>ʰ~,jn(WWX"&^ॠNadΓb\d\.4Itzy4p'-̉pus&k@) ^$}kK"/ NEBc}~ӗ^ӈ/|OOC>PîuԸ_CpT+F2 )Em9Qq(>Χ։'uHyg<'R q?K947-D.rZGf5f5#ǵzW ҂1Zbk-* ҮfnZURCyz.,vj Oj2+ӖZwWQ`g?Lf12Χ}Q5Ѵc%\&~tU-7cKKUA:_wզjuuxK 1V[/1"kMSɁO]1{CwJwa'%oM-kٜq+DQ}*EF_O{ǎ.F0 ^|R-hxv#Ua عyFbgCRn!!%VXpK}>n)-)``uGܟ{vaIc̐Kȑ.!cuQ%[2HytI) M *kO?mfRtV &:wFR2VGL6za˴48S]e'''MJnfzBesc.7)$]c@q+)/sBcE&B.>}jX@{KtV.v}${P7mTeK=>iOb0Ib21"1M;0bI<:7tg9%f.Ht[ lz+G3iv_Y = ݔq3EKe f]Z4}F6+5Gh7L VNr+*PZŸ4ҦC8u}}y4+3кx9.p9s>ǩ>۔2wN'(tw |cꂝI$eW5.0)<ۅ"mxҵ &6 N*Q i>+ù;8 X)|8j~I9)É>%w|TwﲿU ǖ! &jHЅ/`^wعbԇHxpWu@gw7U5շ\\"F +-8ku >;o3{|2~)h~?_G1dMj}gVVeiv0!<,/qNCLudSV6bb^d;fTrÐƌ䔀S=rS)A]Jat'@jY5v?YaY+S%cNҽ՞eW;Z?$,ZL<M3(2Ŕ[3ti5 [>3Jh2̝W\֫Q6ZRlA=G'[S. f"X+ʝ$@"_}$ gswVh7oUݶT`rZLBIi5b<1 BƳMCݴ%DT٬،4C|ޖsKuntd“مW#5,ݧ+o1D4pĔ:}i05j0ugMi8o50]n,gS z2޵?٬P?p XXϳ[&F\857Yw<)>gWBu4 gS,"8AV+BÊ);AŖ$|?ɽ+V%V~bCSE"^Ε/jQJ{ Թ>yXVUȭh;dtW?.$AKY?xɁŤVq^_~<7AV/=U"Jc3rB{7`B{p?CkGW7IsO gŋ {sM> `Sqf]sUE'ZxS o<`9jޏ1fޡPvySO\X4d{!"D]#MR6grh0A ɢvl( 8`Oe V}oJM}oDksKOQ2N1Wx]Rdg`\30@B@QMl/:oW1 endstream endobj 5559 0 obj << /Length1 1426 /Length2 6533 /Length3 0 /Length 7506 /Filter /FlateDecode >> stream xڍvT6]J4J !00tttIH*HK(]z=_֬5ώwdzNvCcA%XC Dd*zDDĄDDDI89M ((JiF !pU` P5=8 b PJFD *""/E8B 8pI©wA@QWuRJn`P`7̋ (n|3 .#,%rC N/p#<_An߉ pL!?1B Ð4`k ?ʺ_ֿA`Ap7ws8B`%~)H8 @Av߁JF&C# (/7"Tnn` I+>Ulﶺ^0?gGW hwaS RK9Q )i {; rn- cs1) ` hp y#{1G@"">>YcA}V\ac -]u [  IE%D@)O/ _Qmsҿ< /Ƃ<JDB?ݿ/xPo)/#A>1|E0׃c&ߪUAT ̀ "Bo!e*p_p$BEDK*{W@b[ ?T~M$@|H0-$~@:3 ,0&LzG8W?%aSu cտ @D0oa_0f6 '>qy|Z%6$7ι9 }NF[xq5#Y+ u)FMIGךH>uTB,hoۀݦ͙灾KfX@}թ]U67>f^%slL04*d3.{%BGM>qteK\A@e5ex .^33>F-05N1ầֿT,9:z\m9xF=/>1_ܰ>Rؐjԏkmw0KA@gё>Ůas~0?E\XU^W$ᓲyrjNw+n|4u‘Oh *vw6Bxl(:\_E V1D~6#.!]Ii ;tW}Xl{D8nxqϒ+ C4n,2 6DGj@ o ifX~-gII,6xX&?8)KeMe|gx(M {)p" ln1 A0Q7Ov"[ VJ(0i\bsץ+8z5o~hb줍"Ww1Ǝ^D(L4*6+Q*/Vh%Bȷᤸf?ϩ[~=MpCewP6aPH7(]]8v)fG[c|#">׺;hze43a F!{;+o'lr~>Μ_`Fʿ =hjMj\#ˠ5> o,0eq3YgL9#I<3DY)%Y_i\gkBi>W½vb^ Opd_}' ~d42q?n{**^C&GlбLdn@c,Z-)#$zI<-"wFE>/,w;?ccmè7mY0Y~ HѴ9ѩ@Xy7'9lk2Imn4b%mҤNd;<{V{_y%gxy!BQwI[:P-CO6zDwS}vX#lZ*Fi t`So0H/>5 ^Ζ5cm Ŧ+Sǚ# ?ѺdYfx4UQk֬hMޯy/_j+ l+rK #4?V7~zf~NVę7yr$"٭g~_Є1a|k`Y,YO!J._Wߴ]S1sqg2kn| 9BD[xNX͊DH,pwti 8󼞃QnuDV[J t#\) (b}MV8hRzX!y-V9VH|;$l??*YC}l:m@ C UzxY>ܦ' yX Zҝ]rLk:V?tdiKa˫Rz(HCnbC -V&svlQ=ڇ9O]ѽ>5˪_5wtA_>Eg|=Zښ(rFBLJ{|Wf[/F W\-T+F?.M,L 9'#k@4QFtװ@*uSyֵR&sأd Ϭԯ/8Dž@>: Q>zg0c'9U_L}'CXOIJ{ߏkOo/5&T#=&;Hue_[ n b!!^[m^ҳ%ޛ[m fpṩXy/IJb"B+ jxY(Xpqrc}+o/*jplKJ˧_Ji3*MҷG+ʋS0/p7<6IYptʑٲ؞P><>53RsSwGODm^Kܾx1 , M|7ΞNsڞ̓;16B)jL,) a˟_~gm JՓUcm+K`YB [InWC gjR*k2:IQ)ʀDCǸX!O /vͅ}Vjo-Dx@w*^ xۍxK]M1V߶?4gn̮tE2`VcsQ7j :"wu 't={Ȧ-,CG:MDž Rs1ޱͬ _RiLk,{lƉy[\~r/'Wu12 Dyު".Nˣ~xQq i܆<>H,|Ӏ{)"<+|yMF=@=z%1Q\)v ,wjb-Wvv+Z"\N]_ j[q2k➾Ƈ}7ZkRqضhTP.U=o^[J/Ŏ<4]Auu统^q#h EnGoh,g}#2cc"B2]Ud~S#l1X#paQݳὣ1tioS2!-97z`7[[[8X~ u\?$h*sy&S(]ԢN$C] "\px, l< zSd}v+> (v6d_"<j@pj5nxy€_dR1NJVUb2󉎌xĖ>远n\#eq ܢrDP3͟&7P?u_N9(JD^bgD$bylv w掳7ەFl"h12)#qј `r:& ,DcTf=/5eŞ(Kٹc\4O! iSX~هۯJgδwbmP7qޘF&$fȡ+DNCs3Flh/*?%@Ω߶U4쑲"t%.^K9r@^TD6!ᙰ%vǵmCu{9_A,N`"_42LdcOiZKD_|4} . x {AGo *Ҁ"6|x9<L~_|g^gOE=n>%VYesh\V$uԍ_*ZvsBӓr Pa-jYǻcgXV6>vSjE&R42+ElnumD6fs}}WSISIR*1\հ\~TMk,ymՃ40/Vr=DLt5\2ѽOiQv5,(-/0jjך>gf@ݟY!o/'kBuVxr9ھto*@r5ׁ'6Lnwjh+HdoN[ҵvP42. ܎.5O_ՆM&5cnj,mBJ m⓿\a^g+(79wsVM_p/~pL7d琝d ָIΌb9LMӎxΊLLj[[}ogڹ˧_5@:Җ, dqpT We9n #Mpw~,͟K25eÔNkdVcC9baQRݵoVϺԏq-kF"[ v$ b]m85IͷEiRnC*"Ba=Z}v|; )oF΁PY ";F|F3{n`XNJ̅v>?MaJئ+AiTШSg`[tKSsb7[KlXZ%i9O}l9M43;񥟜d QD>b ;p^hHK&Jicl>s52: |ҶL"rk'Jzy?Vb5*0#d-ohӋI! a endstream endobj 5561 0 obj << /Length1 1740 /Length2 10423 /Length3 0 /Length 11558 /Filter /FlateDecode >> stream xڍT-kp  . 4x %xkp=Hp;3Z-jڻήSU\YIl ;31$T̬( g[( &M_0I7=@`gge H Y= ZYZ9Op23(8[^N43@@gJA+hlb X 1@VU 4.hb0fjOX lf^[% P(9tӁؘNWD ?Mv& {KPgvvwf؛v4uělML_nSWuNfw,Ӽ\h[$4{u?jcvdons { PF/ beec@w3+=lޞ`K @o+ qz{o `2s-A(d/z/`lm=q,br: 7%.vx2qعXl΢lK?2`ߟb_n?]>_A\hp}V.V1#og vMX;_˼8̾eU *A.v8쀘ߗr͕AfVʟN 2yy4^ 4}vsqL X\O541f{K 4ڬl*RXw.:ya/P%9la"g ^7;a,±*$¹CJۖ_I7v@"8v[=#ǒB#IOK;[W C~x{.u"i*?sn. Kß^o!`.d҄ 9T8o(@`bVs+A_˭_}PNpaq59î@UMyT|'`Ïq` _^J2uXg8e*33~N+NDZ0;>{e>X+k'7\w7DOuor\- *6 wiQ0l-Һp*]G!+B\vCnwut?lC-r"}K:PHe~:ZyI:]i<(d(]5l_M|O>M,9@u9@ڳZHxoh蟞Y#E$XeWtTDQMԒpV(3)h5ߔqs| asCrNemE^Fw֣%9Zl$i4IqZ3,,-~l":"/ˑڑFz]3JX.e. ]^ 򹎾7e|(Ҧ 4ĝ-u._`R$N.HMypQE.FLNG(z/,K  T0O-NbK?,4]햛s6Ohh;QhuYt4x9>ܯ7ZhnYล䚣PpH귫Βzh/h.g8lPq`w{WncnJXD9UU/2[.F$BrRA;)IOà>+v4&&%C`BLw+@~DӁ\2G۠]md!a[я5hxqç\VpT: jk~faNj>D8ye,K = =4$Eb~D~ zȐ2·FաiC_QFQ7%~Gu&upꤾOg-|;6zӯU%##);qPg™Ǥ%v>{}u(.h T^è\&#Q~(FU=2Ρ'd)Q!\v@_^$p,nGp[yW;OkO$2bwЄFiKD# D|"nI_ioTt1H.m-UI+;=,3&鋮j޷,"!iX*7q8 om󤼕P}UFNRn֊c8 -(`0%xm2O%Ե ř8dJDik7Dlx7,,[v3p"jҷJĘR<=+GQaqٳRcvyM]A SF_%sUMIfoV_wO l&?]}u> "#5j{EXEF{%;atLh{TG&ꮗEDO)no k 1`T`{!מmo:҃ qpڝЉPw[{8?nڜȪK}`]6TXQ_njX~PE' D Ę/3i: 1Lg`NDroҠ:yy ?Y~/E oԍ!]D;?dRy$M-sbԓFlme|a ?0WJ+6MjG_UQb]J |-O){m 3F+GFsJh5`6Z nF.%w)ܟ hHW5q9w^iFPBn©c-CѥbմW{4]}>a1%')Do#/6;Czlnef /\*S5\{ڕr nOe/GKԃ]WO2E%ctaN Bɘ KNE I}$ 'K:SIaKަ! 0Z{a\+t?Zl9{`fD$9FW,yL%`Y%ZL_'6ޢ*;b!ņ+47U)3FȤ$1f.!^Dܮ0D83ޤ0bPgǴh |ZԘYCsr )VDBh|p y^>Wᕪٜ :W[({i1-51O48c>ߐh{m+EjGJ[- BN7%zt(wϚ9S|%;y+sG8γG~N`SKF`#h 7hO3Z"V\s3:an^oD|U〸'? ڞ:RقJӪ%|c'1W/PDWZe#KVoGBO8:wBھvN_ls& s;62oU=J"NV8THU>UB+aeI ޽Nٜn#.㢩}bb" #!)f1j*z Sk(Oo{E ={k~(=rjai4^ǎX/$3gwSE%a0>΀ݙ'7?ߑ@V XGY/g)Mh[gԦG.:\a}PK -8CË.,^=v(K5=]K`̈́=nWRT k+GGR!p;Qc?RZҾa"q򡙓ٞM2dk?b Ǒ5 Վ }5 uvX!x$%{HfI}/>D tĝPCzm hwEѲ栾=+"g}K/&^A0C\T-k}M=9J>Dۉ|\ǂ[[fhj \`$+ "uHVV.6Bf+eRGR_>[S ):Rw؉92}ݤwb՜bbg23\^!~SǛU<4:RUX6ĿCE%[ ix$2r`YDb)<#5$ '̹P{*6 z1P%T;ݣU?b,M3]n,幯fzZҴeRheũ]۶߿sSLn7-QT mhM7|z݌>bTq_?yi`dZ)$'Ku ѧYEkϹ(RhaTY &Q47Dæ .5U6nFp@s( G} G/<+) nQw(3uĕT q@[/Ff bi1UD~vVAԶ45/mC/M^+'EܰxHb 7b;^K<-wY=f)jѝ-LqanoMngQnSr-7-p|4NjUȩGz 6Zz֭alwkB ^\PdFGW|t{->ozhGvR-T^O6?P) *&Jh~`'wd@5Ԭc}U""njI$i^[}(uԒ \=ˈYfn&.?:AF { h!?%SqzBzKT72Z~9Y?v~# ZuN2J[ŸGUӏE=.z}E"ѴFąm:(/NCK/}k"z)>G mZ?r70" { ?3l$yYwʦ]_Gsm[\ 4BWS[ [`8WBDX>Ly)mcUo#29'9TnGFG` ͙ua+*Zf=]x?M '[DrfF1y?us?v xL8ӮB BZQy UjH? lgo 2q'Űbdlo6 GZ$|꣙BVNY (JK[z0q;(sAt^W-Qqhػ+"=L/Ao5xC6䟿 'Pynjn$~>kPPM-iChX&LJLtIWkATe6ի2gr[[9PӦI(޺vP~|U\. .XAn6hOChY[HGŵZ2]@u!^4ҟHIzauuN)3EԨآ9vN4J/RO @b|)k /2MqA#5 -| %7Cs9Mp7Ť+x?HB{q>Rr B~dzY̫SFũq0/Q؎&=nF>~6&23=tmgp?CQ:.v3F]C.O0.GS@Zdr;סbo˄}6& c[ą4нOckYZN~so ¼xi(kHQ:)eNwy[m ϷSC[CϏa0~3MԠ194!n"P5˷DŔAm:Ԅ0ٛw6UJ08ˋ5_I=bFlUJ>Y^(S,:G%5{Hh ^DZKi눻nHPϦ Z=P=&Rto.u QOD5n~SDm -095sv%omC \ǰJt""3׵Ϫ^9scKT1{3[!͕8X5Ր\#ثW5NRP\cpMq30Eǿb3,jRgTn8v' f8<_}>AX>S!` P|k`J~>bn hD'qپW2'oo>ڢY;U.3%@iW] { i%BFm`eCNQḓ3!,܇DJeI.)5+O7G-:NKbh}2wv XBfcfsߑh y?'RpwYa <1o%o2dsjxNb6뛨Jgt 3bڦ‘P> VM zlgcp ]AA%!s!龻0 ;kJAɍ|N&HRgQWjC!^0w3Jl/-{g-7f;]^Mˌn3ѯ8rx#+9;45{x*3iPu RگJaI_o"Dbw :%Ƀ^2n9z`u-x)tGFq;Q1 iS`˦q*K0TTrmx$ԭY7fYx~w·/-j']v0N3MVv0t?l~p76^""+ÑHȨJW⨫BR4= tTiB;>;NJe>s8Nlej<\RQ<6zG:݈<27tdXO8߿uNjۧI<ٝnnG+47R޸ꉝ]߾E~mulN2w7 Ld(%y|VZ*DtWٳ.O$s G?j2 XlG~]>\'8M&#b1nR3<˟;34 h'L:3w,|Aκs>q*11NcC\v' uZD`wbĆ2r;Zbzܣ7ѾX@*a)WInVZJ>l -KNkJ6\9I7yh8U齨)f͋q$\1nFijd}3tHb-r"¿;a2Ҫ̓]۹qo(C~u *KrL}D7=~gnJv‘v賙`ucS!. è tf?I{z endstream endobj 5563 0 obj << /Length1 1402 /Length2 6169 /Length3 0 /Length 7131 /Filter /FlateDecode >> stream xڍxT6AzSz@zH.RB Ezޛ H/һR7Ai;"={3왽g'+,{ Iu-B!!!!aBvv( OnDBp@({B@(OBup ŤRBBa!!ɿO) h!$!2B# JJN(A<` B9C+A01 QKr!Nr|(`ABр߭jz?!PwR QW6nn8 I?'w?? Gp_c8x ¡^M?>' *$)&& @<_L!G@#AyC(O/H`i(8AvC X z0o#R143JJ_@$_RL⢀1ApG@vw8G ܀C pD7S,U%ws 7(\/Z 5%]](Z p'4"ՠ( k  _7 :KHbh]ѷM!ZC\WF8 #D5Ѫt&3@P@SO_+.m!No<$ tǂ`/OO~3oC 0<,2Nއswe;&r ZY^CLGcz0jj3}W~D]j5V՜(ڮq:jyފ;|hu)}#fI[ s!BRdF7C2(,H1h)Tx.L~OSg5Z#e{=֐?$TM⛷ȇObo==UBup-ﯔEY&΍Y|^n]VH 񝡥}ԁ 6cf4QM;-=nK<ƑcVI0HI-f27 F|e (-YgvC:N;`n3yYkl?[WEnkW$hގ{9/F?lQ=c'YC^ \*QŮ+Ah+֬I77[A>Bfh\nOmHcN˫ >^VkszΝio#|,aٮ-12f&-pW꽅zf7wF#jHL:_5M"1csu4J޶k8?kn l>0QR{Vw,Bwz qp1z jlJ0˰KW=&Wj 2J ; K}x+F\&mɄ0oﻅw`M!fWܧ5l /{J(5734&pۗX){k.iP X7Eo-Vu@}C|&`❤Wqi6NVb˫aڎT˞Y8+FZJzG ~hh^{-F}~үBͱt[Vެ.*nB'4Za"'t# bxA >2]iS}GlB ?B=1g[zJ~ć5 }\(sRM>K>Zx՞sKc$Zy9H=y + s)799Rkz}AR.@;~kyBԧ S92|%rlGwvqLYvBW$q!q<2N ʕrl?Xy#1fq\b} 9/AJ$h:}wP F?ݫ'1y|͕1 4AlN/ZjQa°Db i)'`033CIFPȵj,cPU>=\N Uf=P]m tE"(M?سbR3S}^SU~9Sa.]L>(SKo!{Kn3Gg|Ys8"%jN= *eoo+WQvy<%e^y<} /)8i[3yNgeV_{}"l'Rg}x@`a;&Ƴu9ɡwk^;ܹ3U)+c$Υ$ǟڥЧǡ閙tɈ'댙SwqdAix%]G(ƒhKVWEM(;WAEZf,›Bqq8yl9o kwo8ZɬL g^v3MQ]M7>tGdHvcvYx%G9P>ź~&b!U/r,wqNqޒKuQgIkb-  ,Fc8Qgʺ8>zYj HIElr6j-g:Tޅ++Zjccku-Y2y70gcW˩n5=c0IV1Hߣ4|M;!_Zf'7t *>6IӸ滇E-)J~.T_B؍;t }uzJz2NC˓uPsYTe1aj0eK+;<_tR|/P##G Qꜗk3ݹk/p2qq]4m'lj'hT^hyl11 HAvO]?ZSQh$^kDd$oUe7DR^+@O('R?)fˡg)| V-5큩MkC>aCF69$|fh,ɻMgQ,v *E^,^k/87,ZOXbߍ_Hv#{PsL`d}g* 'r3ЭN` +@f㈇AO\R zu+{+H)Ls VAGvځެzDƐq>_ֱeO R'-I[M 4ն{Qi IƦAae7OUr!׮%E]a/KiH{eL^[A8,!ߑEeߣ;ɘFqZ;PKmg;I Xƹ==xB.āΛ%f$ef;N6KjSq5y~RɵNJO& Υl +RE(iw`h,Dž{KȜj.4_PdS/zhxwپulq*]aA^l}Coed^}4V }bvdbTiӂ7nXC6AS]35!џr-sTTsBҾGe gub 0,)+?RizO@J+}p>۩UXeQVN?$UYe8 亪#GBc QdkQ%Sԍ È[ߘu΋Β[i||>u2F.p?f PM|,mM:@}x(˪iJR{r0LzgKā5=kHX'N1u1d=*Lxs|KͲG{vվ0ِ*xW z24 &"4i]ZHe"Ud6X:'`o5$g.s!w\yg542~J0cGK]^1z1?f]rzvp 8ʒf$e8EƋ7ǻ|ts%: tǗ򿝆Qb=uMteLCNRh]1,Ռ +d3Ι~M &FVCό-y| SqK*=Zz)C?+$\г}v;3ukkGZ|YlΎ{6w< j. G+n#Z^w-W xisXMYS 9;d=Z^f3|~Ek\L\<F{JJ4fB0<3$dOA"}Vײn~aEG8ɛv} }a\_\Qcp $n<|V{ƼYىkKx2u ;vP;B'DBx Vxo(qZ2|aK&SRX[LZa[ϣo_۬97Z`'8^ |Jqmt69e' ~\0}> stream xڍvTT.Hw(% Qaf!f$%AQ[RBZC@%QcssZYkygƬ# EZ/$ k$ Qf6}+_y)Qh:9B$?? // EPá:/D\ N^.p[̿n' !!:\0Plaa(E$<<pP7''LE/m"D%DEE3JeFOtC0+\`~>CP Ovfg>|'`;34HϗOA,퓓Cz>0 ,,I~̢?*k$ Y.aW?si Ѥ)?}feqRrsp?`G_n(4Ցh jYu^Y <¼pW%' GAl0/90-+ף_> LJ+]0zYWABLPDl|z<E Q=`t!uh?C\\"Mt+Afv5gU<C7VZ#㍺#DP9>q_(9YBoHTttʗٰiGfbʣlb>ϫ(fD,5r[6# ɽ$0N?Z]%vG9L6uF3 jȔ,$MOȏSs5􁅅̞T\J򧔴TުY{i2U\1DN䋓;>e_IJ[iJrѐ"|BKt S C*Ey-f=YAl_VT>E&*q"[[I(Xbt[N-;7]6lĘZ<<|㽙{-=nvSo1mN@!9?@E=GE"!5s5vѪ^o)W 2tl#WO^M*έ`塛{kZ<ۉGsCH`g#܁@ ,'*OKWxvӁO}Q!ڔ4OY7k(1Nk-sOН6Ԯ12_ S10Nٛ-wa{ഖA$ruYGݬXxƷckI1]Ѫ=춲391.kA59vÏV\ƹCq>L\Ď00mk7zq8+;UFhZ[$JH+9mؑѼb9bϾm؞v]B Pe 5T_pTfV)5ÝpmT1e5nYWNv k|k'[Gx0J53W^iXKf`wVp,=Uzǻ5cI0r{HbihuhV>qBKBrKH@6:(צʤ[(T|Gc?O # \+!yAǝD2O FK! 撥\BkeBdS$:F۶. |se)H`9v9;Ί?.R?u3wWiGMKD 6w>`yH&z% R=x#όAT{ g9ju\~Z2V*Eq$E=',9:T^XQ k&9>;^zXqOYKK2{UW15kn :x)w>8&Uژ[q+:\Ol,WHg?ɗL~RУk[ h"AD׊= 6(ak%ըj|jxЬc"nJEʤvba)c4^ۑ'ѵj84|h^(rc)[]%욋8J?[9#'7?F댐:eJ= ~L=߉1׌R1c_\Tz/wdLZO"Aeb5789Wt@T&JZe@FEB~-Jَhx8gR([y,3ܟzh#ADi'Gxd۾$%^7~\,rhٔr yAhWIJ2ƬxcI H$!XNhZT{4x^͋y,D3šBUɡo(]/0YZ(V* 8+3NCk'O|y"^4IJbd2K'$־&Td6&HZ绾yJwEJ&*w/T:~gy<ٔ.L>M=3iLƌ`٥j7?|NlX1Xi+&!M|?yyc_>NC"K8\Шbt,et,A;ߢ| ٚMsЪx!oM]z~"z+=aR/D/f% M'hd`fNi+?Ƈ )ʆ$w wS(=qưXJv$Rp05eHČ FAsrKWեULX9}ron4r$V,GUj4:ߴ9vэE]r/* tjh4./ٳjcLjt 9`7^4L; 9yj~Z`e瘎)UWgY>̀2x9:8 웗>X#^;+6UnUw̧}T'o;]mS[̢s+*^J9@={/(4gno k9@%>KtU:@M#U AzBO79f*y&S!!ez1hE[g&3B!BsscGpLCvsdOg;WIA36HC6\MCm9!\vBL=fMۈ16/* !Fss]{muxe@t NjRǡ @~Erk ca8  xTC mor|#|.R\ٵύ}XFӗM_LK4y)P8bmco mޗH"0=k˧3UՖ0 f,_4>k~}xu{CSFWaKӅ눵%1RrbaI7-Ï6jҖ\?̥u;t̎ݎd$"=8%PհźV oƦ@l,\$e"Z.1 "diXM;r2IHv35ʵ|X%:zv+F<;N㪂ʐ^L|q>F{}Wؓi,BT`&u~.Pۍ`V)$rx}\fCߜD,iZ)e|8'\y w+NŒoz;aORExh#!9,lGmt+6L&o=*w(ly9Bq`9a)$ Qkk:tBc9D +<ݡK}}@nB3ufw4Z>>3$೽w(uF%dZs5g9wSt+%lsv{Э s?OSwzdKS[a}{M9RQW`i wUK[AYv7[.PD xO}7~zkmF)(oOĦ,AZ vdbuM5a1oNL>1&km69C.;e0kmX4I?nfH+SA%7k#p8_kl D΍85E1T͐Gu`l™zLU_G.zqU ) S>MlFP6zFB4e/*.Gip1k-u`wvxrϊӏY*r&'8=ZŹj^ι;NнKx0f-qð5rϞd ;bMsZ'PɔVwaU+)$dy{[NQX;<^Ϻ苹,-χ8 ۃ-JԜ˦G0dH&NdnJ_޺ tݟp]8ƿ~1.~X?T>D]zņO1#'΅9 Mc0 CDMeL,Jhha 1=sF?,[dCQs;o9ttݻQ܁f;k.GNm& ߗ0vte%ߦeP^[|9Od?߫LVs$ޫU=89Nܦ]׉nM-fmn58GQX( g5{e҅[ ˵qkhtŴE)]Eĺ,Zߪm-m`ה>D57w{uS0gƓaSұޕ$>9T˿gE8`ӫ Q {%oUhqd%E0P48ltPc<|U:&|&Rb:zA{5 H45u.tVJJVӃ]_S,5Ѣ@J>>n>jq t،O;YuOQ~5hc=f2n=JP=|ކ#j7~S%9Ҽ h\5S'CDYRO& vj`)Y.\ΓL*G.K(u^s 4U(S.3 =_loIPQA^.)`iNBri #TfNi)aEWnd~q**1}rŗjQ,y=m.~HڧUD *Ŭ ~ endstream endobj 5567 0 obj << /Length1 1431 /Length2 6353 /Length3 0 /Length 7339 /Filter /FlateDecode >> stream xڍvT[.ҫ4PЫJ@DHI (&M@DRWMT:(Q{׺wk}3̞^b7T HF$(YH@Q! PqpBQh!J((Ŕ,Oh@ HR(24(K ꍂ9:a %~P1NP8vG{ ibG qBH]^' 0((`.S  !0`\`Pᎀ@Q# m+ l !+ lo0#j a00vA#`0l% PU0UsŠ0_% =eD C4ɯa(=ؽtDp!  `nP (X%$$P7IWxcoWo# p9@/_4 ܡ 1;# AOt, u6X|= DxC_aM#%#ME?Ǧ ŤrHJIE + ?$@OS;alK-ƭ@{[]oNH巙00XͺcAbT3蟙ՁB`j`9P@8b,ahU;QפP}$jzeÎ3@ceNϿUA#!LD\F$@D }r "ywWGZF( .}\ʢJuyhiL씪Rziphmʧ@_'H7eƮ"R 8ԒԩRmX8\cxgxKöKfInAr5ʣebj:7/**Q:MÞ|Xp{951:hzE:ߙs8no6lRzhgs*rvn0[qefBK)wtбnf(xVZ:zм)ud'UqۗzArZvqM{G^:Ͼ~N5MYGuxԿ=8F(lѺV)Uσ(!**4%|}/X>t#FY*YRq}q\'NP^cAFuf ҇0LzwP6#6g=$Q6?3zKQq7z44-~ŜKumV{:̓E(75!,OTE~Jq݂~Aj%7Ν$TLP~ M6J)YU}JC˭C~^ Y&@!?63gAUN9:KЍ崕<{2F*oT&9*ͶإiSMWO^ uYijLQ5Ծ>J.JVf4ڭ0`dCV<񾮓-K;kj6DG~ 쟟x Amu74c>q|g^{=1Qvmzɺh# o /#୾'Xt7#+Zag_Urn^j: p@PYawU{$8>gT~!mQXQUw=rq$i@]ݵS|WQL~d~K5FQDGa t\t ֹ4"L gr>H歓󩺖zu+˲ K:_Ou+$Ѽ{:f9-/)b lV5VxC2+l07Fe }\Z3*-%DeMҋau41'd>Hi}Kw1r>G\33$u9vn|hMB)3da뤔Ys`49ZVk:ΓSTdg$o$S:Pȿ[Y6'VRyb_)D`s^oeG]͂G.GkmÊb^=GCiImtϘ=U$oUr'}ɃܵR'xus y5p9q eTϙsx/Nm*бv2f35(¢-Ҷ8@莃F3|*| G[#Ү9=ADkZ~q-{RdѳBuNfxr $6뗙|"wlnfMl\1 A#ʞ?%f/Y8c+4Dv䔾D4:j'?[lT;ܪ B~Ԭ[Tj]!o}֨>>#'fO !VYSttKML&IS/.Fi8OdE9͹ucA6h~u"_WX(|KeGj%']$7G2LIED ֖? =`Dsw^Q?4\ţ{Z~RhO)v}lgefAŚiCn܌zr] \ nIٻE;[9?^Iif@KR_S~;, _?)bYۊLC5:Q{<^_Z!r>H)N1&טt*{eȆbjֆ!-O{gJIE˯>)'o\7k,Fpt-V[ᛟ>i~I(˹]|!f,ƵǬW) y ׽⯦Α+M9rۧ蓨V?9Ħqz-O]g=_e |+Τڬ7<-6-Py?/vtVsJ%TޕOvx;sal.#2SQv@,/BBwlTGt oL̃ks ^Q ^E;̍S}W~MސM&JIѬ#<".o1ު~\}08>ͱQW]ޱm'" F*Y7,_K(O-+O&? oGWGKmvpH$;w[Z}nLzYDu/ ~]T)Uxq\@73oz1rU"qLn15on#p:Ɣs >bON Z4p60'sQnc>b֜Zain2@_ G觤tІfԚ\Ijw@nfڔ"Mb鴇]Xo4чH|%[zcm4=0 'HvL+A\ $Ap[ OQzy.Зp\8O\_l_͎{;td OLls,u Z^&LL A}abK|ǻ$6 ZX?q\aL+3ݨL&gM{NEO>YW037 }=/qا,R!xB"<=WWnP+sW1#yJVMqnw̢@w, u'gh2v%X%P x>%Q7^Rútէ^Ճ~$rT͕u]qd_(4^Y[+?&MM ;^'Yf T':&ۭ<{S.clؚDdNOo0{5֔XӦ8R7dvixF 2d:|'z]|/+~njz&Ր|Lo%*uݏɝۦGzzHZ[g^q]QPeT-'KV3fX%/6WgbSR:kUǕ,Rt7(Ρz;;ʡ l|lFQΛh"| ]!V- <$#1DN͝2[ mto;'PVU6`Hk#%9&Gs^B:jW'ew 6ݑzzJEHR{ [:FP17H'ľ[MJ+Զ!Ұho%tc VnnVSR `gɩ5! E>;[ƨCS,uYe'2q#IK^,X49Jdmk<'0jhI&&}RBx)T{[87!k8 ;MkG[>elKbjjR6Ձgɖ3y#e>,yxCZ; '/{.ZOkź11QF/\ڷUwkZWvMv$Kl!"*Ko:,=Lz rW#Pܾ'@7!~]-B∘2co6)f[ ZMSڒ'S?zBUw_0Px̘6o{<n5/i2ݰƾ@Z}3gwI:L6+lx]>5I1ÖyߑJz о3' x =;[ڬ4oqAmc}=bN*}( dGW/$jUU'c#3[N3W #=_0wҪq A3u]}OUy55SVPZ9ofnhII拝ioY_u\ rYW~edeD'3UUJBMXkV" z/6j_j~{*dw¤l雲%tw-M $C͆h'Zʘ*ù]i>Z\9/#I ʡьJO7y=p4-6s#a=dn82.>).2EVvY[fLDT};8>u)k70 endstream endobj 5569 0 obj << /Length1 1441 /Length2 6390 /Length3 0 /Length 7377 /Filter /FlateDecode >> stream xڍtT.(03t#ݍ0 0 CwH (]"4 )!Hw7 sw]5k}~~~YuyeV0%$ 5MD OnG;D0+_y  &Pss`aq8ED w5@D\^(f8\ȃY'  fG(ahCŁ@>+e+G`0;k` g2>"vA{@P0 7nk p9@_U C!k!<=r#~'CP3Gl0AX"B]7wbuC9$ wWEZ0BA@7ro i dDߤnf QD V#W ⿁Q(f__ G o4 MM ?eX @$>][uq-f7=54P;}&ҨK{hhI %iT4[zn@,4>[Aw?s:;LɈ( Ri~3c,=D֓{ߑuVllEw@l")]+(;=49B dӅ$o CpĤ< x{D1SMѝEժ!.}d/p m%LP#/&HO@c*eXZgEqp }!χe(Id5/|*o׶[PpjpU@ 3JUM~9%YHesZPK4LnXۦ_%qʃԣtF>Ѱtq1V'/ԫ,=Ŏʑ>rg&o6n¥`u2?́W;NܹC1zAl=yE3ʜ15~O}_)Ԕ4 >|Kzd8+0qxAoY\fA͔g %kCGwYM8JH1RT[ՓyXvo}1En%O˧)q$.Q%WU?I;5hUNAMA[,]͛" =z'ߧ;bx}ϟA0% *\cnDY9LzOQJ>ʊF*QoE8l4Gi y+˸YP UmG[ FLF6bhi;Ig$T%M@i' ovxzT=ϿHxͩ}+f&ha.c7TDz{(f[O?h wTK43Nt0OJqꭋ ZC;$:F HNJ; =lR$uv3e;?[>V_x%h÷a5sJמκjZEGWWiT FU+ WdG__o?(F1mF8x&ʂv?2֓ѥi\LÍ"<8R|}:]:3e~ۇQ)0xJAj⬐{j[ΡP߳?;1_ m?)(KmnfЉ;ƙh~͟l5x\9^KyR~n OCb|S4x-c8֠Ǥ=ʡ0%?Dʻ,6 n&Y,! ǟx#\p}hdazt73[ {Y҄fI=:Dۃͳ䁄͜\{*\R> ?Fj(Ԗp^MGPܯ|bp޼ԗ\{G!D4PMcwQ^c;;38jyNW)eRK'%:vLRrsBWUZJٮtS[_+yT>yYapQ+뭎ez{m^-3\L %妕̏ͻW3?;rͻVNI+fSrDNC^Cf~<2C3[ Nu`e.@1GG@4+:>zg|29sHHMTX˶ayU W,\^oE(KV: Ɋ o;~ŏg)#t o&Ml &bd f3,h[Ou".BfOY4*%ڑh:#U]ݰH!xe7W?~ hWUc>YAÒҎ=YT͐}?ls#OJ9w9>JAqSwH= VHxX+ɷ Kg@.j+Sop2T@{HvEcۈϺ]ʡ#wʐC(ef=vj=.͹LàRU.xM|8_rxjf=\FWWW"zZ7m`SKm%Vcl\Y%Eg2(XU+unx_$]8`Q%/ a|t)={V֒Dv/= U [,HHQ0Ug"m×tMpF{i 7~oyt+T0~OVT]rT4<.0 |ƴvpgJԦ}N`ʆ[iG #|F-57«sq$UvyR-jULDs_.2Z2֍qiyjh02߱ǐ+uLOKFzıhm+}M)6HԓuNI t^(`4+l{gafs-,gZP^qo6rj ;!Iʼn>AtyRz$V )F=7;>uwQ\l9],qx+ȻӁ]f:#'SD#5xP!~^ iкz,Pnה=&@<EJJc6.FEYS8hgzwK>ִC-4IB+ .ŒPi ؠfڂnKsC!֨EvWa"꺰'\;3u' F*mJRDn] oٰm2c<^S<ʣMj|5 t&؋bLO*j^_,|珙<;HeG u^ Q=y 6k5.&or%Ձ}E=1ၛ;"M}=eX;-;JZGMᗸ.]ԬJP%F0?|%3/5kL;'{I~xT endstream endobj 5571 0 obj << /Length1 1437 /Length2 6387 /Length3 0 /Length 7371 /Filter /FlateDecode >> stream xڍuTS[-] TB.]z Ő%$ޫHQ^DI鈀"{o#^k9wؙ H{=$/, $T3  MW_0 BÑ堊1XL !@mOW(PXBFXRFH("$$#%T{@=6CU(ߟ@.7PXZZw8P Cs8 \rN -D9*p' Cy_ `:M?1 FX!Ob7ka?κ PX@? @n`/t€t0>> vE#`/0lu]9xO6W{h A ᮿZ{* S` kG@~5t4E=Z[ A?Tc,/wA<]]~3 X Gz0(Z0VG,p= j@PnKjp[QBBe ₽?X^6Kg"@0 a$0VPo&H 61D~UR(  bs E(Gx0"vmWmO  Hls}DI27_:b-b13tekLz6]^)@ZIș1:~[2}&OD2=ML.*m KĬor2D tzj$Rij7q8TďTҒY蟻Eq,z>[^cn?:|@1; 髟׿J)ܶI9^j"H +Jl_s0Ha@4ApOkQ#4F5\bSbNm?c/C"ZxE# ITMc{LFNazV|*(͢u=nBz`,_c{E1$#XCiw\՜ÏJ*R9}/Ohwyؼ u./U#wAUݏm=t#i{foD1536D}+xk:K0(yɚHpD 乃x3wƓ% wOHp[@ scOMPiɳ޽?zvUť"Jhfo Wo24!(8BN)E}6N އWILеn~%1. Eb2_R($Ǣ$öU$i bG/>ʝ{|EǙxL->UWȑ{SA t!Ia%() l !LPT^F]lٝפ#߫1~ NpBrBű^ ?39`Qs>$Tjq ߃ͪc)r@A9$UR"qaбrZmr5 %l 腑` އ.E+8i!/k{b:mZ&2[~- ^ksf1}7{dBQs"q'Ɓ O'KKUCerhڳ>z'e ?mu&sRAfCSS}*i>azj"ϗ|kY/e"G(XԖTn{ݜ8Y:k_4ǝq@`exOˋQFGL5;/v8m~D#n @ sݔ`9hHm\xvr)%[\uޞЁhP]b!6a~$%iu n ڕ/ܞke}9a&n|ϗ5~ŷ`Ƙ3µD epCĵvܞ;|9o~ͨTqV{-_<"{XuA[?v}k, F*wٔ-z= T 8GF):;I{7A+ܼ2vK_4ճgnԡ!Q TY`t\w㇮}]<]@#b6)Ur+cwXEGnOAr>Sd0iC OTzt͘sMW\{#-_kQǸ+r݋ O(h j/(-=K[+$[S~E!AHe~'-=:PCfƼq#-J~ R>O'-'1nw 8HF]^Z0 wQXfLΛōԫ#ٚ?s*!I䕟IPp4BZ/Ő4fޅj|MuI멪2WP<Xt-vAtR l^$kP>TwB,T+H ǪbѾ)S7h-g"GGg K<)6&_#I*rLē&/7MKN}}^H^Fjsr=!`UơRGLr]aH~")e'")EG DV| dRY[ {gV qTqVs֟Kjmxcr_&&b.U:Mo3bXA9Nx|ZJf[徙N5[%5YKH(98$k,SfA'cCE1ײ E}W^^(+++cn#U0=.X$g0EiKM&m;DnCT!i nLGi\KguM!syTI /j@B֗\Oň}n#b/1`@S?XZwj:R8e75(Iy,WNube92ɶ,^8F&cTnW]x2Rx1}RMSC̒g^lLKtϚ ~?)\iaOmْu}_?<Li2 Yc!5~+;AR|# e:k9mG ?Tc!;q9ϫυD&dinO8C7sK1MEk Q1KZM` 0w'%oj7+Y^oWT|Q)c]TJ C?-*8D >tnS "1#*r22 -%fgOalQSy󡝈x,p\HKwd 0e(R.v}3㥨5C>$-B"fHy !AGًKʁoLJpQ#IijqӉtN$㓤x\/z L ctr}q7=(致$J gٺ,ϪS~8m=@mCrKJט Jrh{{b8i3y2' [WnLC)[UЅsfpn/O]|-i4szhW[Ft8)^1EB0Wȟ!IsRh>%~qG6Uڥ-S37tGo9߽nXz`s%Su7G7lT gދWY:xeg>@̖­2͜*6#wRLzH cpk6SA 5y6D}N:r u dNd!\J9qg$IH<}3hƎGQ8%Z>Q{Dୀ+ڙg|d`UBHf۹Wbؾ_`b !Z'if#W!8;o'y]gs&| MB2֣ @֏d.Il=mk?8.A Bb\<.uTI6Ike+dV 4b %sim>23!$^VNr#SKB3skPMO69χd$*=KEy6!/>40{N@u ;Ir܍@LNS7a0|Ң8|%[tq(`L ZmCLGgMFR(UMe{#h SѪh 1E2' ? 5gXt_l+y@z&_3PX5]@9z3-N[t'|g-S&?H$َjFNP[P\-~]g hh딁y#;'{${&n߆eiDiW9<|ۙWJH9$ܯd;YļJY772g\ Ԡqa{mG b>l@{Q'_{fsǵ'x0QpOY[tmJqNDe*p8; :t|nMS+PttPiJ'"FEn{| __g,zzQcEE T [4@^c5I8O@Ptw >*P˞ZKX9 _G9]]Ao76@2mƯ 92 Cb~ޚfo3FzݗϺU Xp1 5)8_#mrPg7CvNj~b9?Ig;}Ix/r7Rd$/gs!tߥ)_+yNԟL[ڬ HG<M9xӥX'+Z]ͭ"\}[<(1~كQ߮4Q=$8x>m|-jt~gPEG~{9ΫoH(wk_#%kc cʼ($#_3vZ~KXL䤻e~jpKĪG'T1W0Cz$ǚw.Jl endstream endobj 5573 0 obj << /Length1 1694 /Length2 8123 /Length3 0 /Length 9242 /Filter /FlateDecode >> stream xڍT6,%Ht JwwJJ00 3!"ݍ " * ҂|{Ykfg?{{ٛD@wkahAaY @XXLPXX H Dc0u Ӈ^P@DRVDJVX *,,/") PzC@}A.Fr~H+sͿx"22RT+!FzA *$BP&pg `( Ca<` 0`0Da"6Aw 3 03 j }@7E1@o  tdh.億 (ADa0=<04w~$ ~Bu}p@οy!`O/ DF$e$%%`OUwxS?Q7 (G1E `a ^ࠀ4PD8`|$`#ў@0aP+dgg}﯊mSUDe2qI !!+[3+cp;Z0 K;aDOΰD izA̼33pjkh Zu@ \0b 4!`d~Q߻%,?6|9c ?&0f|^ {D%$@$G( @3 %ap41 Gn$@H7$&Āպ"#L!N`(?}'A@X {\~Z0' Q yF1hG Y((O ̢}#&#5 x!Lu`_/p'n O;T}V?ޞ_Lꏐ@sOgiMx:ާ}-ȿw>kE\v.F@ŏ.`eT*=rb?ј׆'3.Ժ6PrJΖƈUƎb\D[ْQ"m2LuF!qg1~6qó/<譕˖>i:n+ĩZyj;}G8ɂwļ] B ?x5B%yt8=ڶdku[r>sb?cG:+d $^u4 Ӥ*w@a<=f/$Iz-rOWu ^щ'>j߇zJ~lQҥ S)e\jrͪ/]~'Omb0(ePK|Fp`VA7kjV]:KĦuG[3ƦV􅵡/Z!e l-~rSqg~`:*R,V!83vѵ2:q-)%嘚aSx)|(|>UFW]!Qp.\ZbMY5 (~QZ'R+QU3wr sѿȀWsY;TwV\t;kNp "VzgEbk+0(vҴ)CXDKG'N{T^k{m| Ync D,1x[]Jۖ/lݺWXL%8R/~X6\}=?a$tLoΊM_=-&_sÇ>PrN*,Fq]K03"UU֧J,?h-|&q#R?.B3ZvC8K73rMp:KfyR1ԟ\!J_mV%#TU~ŶC]rV=pO)4%ޓBm>IFEI{ #'\#kmyQM'nC˞ ^% 3ؚ{JlNr39.ݏܱٷMߎtai ͦ4*{Ӫ;#Ҟb&ЕK gFSۣ,>RYx$A#DXUi1&vq/^eUiNGϟ$9&V㸻0}∏J%+hr%!V,wU&pҒYy[[豑W;_jFNmDU84!N֣òR! Ф3%o|,Yd7 S5.S %nZ8xQ2X̬ =q2$nbNm.-E%N5&(\dJv~~tD1<7MTl3O'k R[3n*t2l73%m=ł՛eR/8ڏ'YnX||+IHhکmfIY0&].7as2!F=@ᱢ",ˋF0}?/f_[\¹|;/snY\5]ә ߠQ%TkE zkx+4B?}0~?[F0fphZz[9wnn|"D?4W% AF@ۅe 1zmq93Ȥ:NVe᧴vp1 4g%^֫}THy0ؙLXCM$j֮Q+!og=uwXIsKr} +I1>]nP$s!7 Jc7",fe#aK& V|(@+vU33q3atBuŭI2ęp/ٮEAz X`[ӂ2̛ o[m6RQͰ_\u֐<&ːogra> Z%OgDSgfJ`㚗rOoMbQVMEvhWl/ڢ@PK˹EonHkT~@ ]eeoZqjdE}fLZlCDIy .8N|=+r0x!m|ֵXT"Uhڈ_kE4}vasp \\4iűaI6ϳ$򾾰Fhd |<4t؋jdQlEankyR|j8eECv zDҲ+l-7xT4[Qt4ܧ!NS"xiW)pu(aK5)e3 2Hq<}J}F,T7H.Ou}Ta"DL6KxA4G=i aӬ 6^[AWϲsS (j{8T0Ųrtݧq4! qݿ[BHtQJd1([ElZdk^֛sLj9*˧G%$:/&.Pj2kB%+ԎPJGSjL T{0?mUs*lIs ի/0qqQs7H?#:1ֆbE{ռ䚏$+.jGMhDk]zᜡ >x$oNTI8*Vf| O70g퉑 7\z%cEoD:tџFj94f'[Eq2:dqs]&GD]6ڑSs/[{Dx?'&{$ߖd} ~},EfHN(N -cI1ֱwqE4f ҩ\}u0ޤQ3dWEȴv#ѩۓ YmtVB''v:⥜?"+|痢5Wab<.yzjʫH4iec-Z\;,@:=KD cL켇 ?JΡUZj̟"{j]FGd~tC-בa"=>*D/֙:ZϙCxnl><ۉȈ {dtk:6qAf\wATB$&gu5hR 澃5"u?^Ix]xiO[ ulYK*3_z`fw&C"OSP u\ăSKYɞk G >F( |.4)vPa1=2B: |~-H欏w7а_QoWtT1|]8NltwԓP-w\B-hxR.UIT>t"e+~XTA͊4w4} ";nfdT[cL5Gv5ó x9 шaGo<;*Զ")b"d۬4o*aHxEЃMfu{7E2^ tM&]VVabo:oN4~$($=$$C㟱Aj759AgV/\i~q'OM1OW {@8wIF ugŜaOZ ix 8pVBs( cVcNScT=po@O }}$oqIng[ ,^)MUreK{3g3>w#qqͯ-v}c sAoʤD o1L ̐YÆ)?0A7F6EfeU& DL+E)cQTЅK$5AnqxU%?2fB:rܲASn>W]?k;.F3ò}UKp,j_C EI;2:K힇0gѭ'.{Im -EU{I]G]~a)>,=ΝGLKlm=2x厣g1ɏჃJlFl&/kxavjԚ KɔU T$vMj Ugq=cGOӶO=3=.Uv F8iMPηy)QiPRZŌHH¡J^r=s͹5zZ7TCM7R]fN0-~m??O@{2QvJ3w? Y&K~#ϕhƏvrpiɰNVUCgR$@ y-"R=k*ṇ&md[nKNP5 ʛ݂< r"}4.vKW^σ,Y7ܼnZK 1O _U\nAxP26uZ[o^љ+E)跦mvxiH,ma$D؄۫40ͣN[ҜRa\CCXtדB&юb$%.-|е}򋚱dP '`qY=S~SQ_Lt.O?ֽE*^PO[2}_D* (;M61}Q>Cix/\UsyTg `2AN'OW-뢔rRJ; 4# g(M;J¬/4wKչ )\uz7xZB3!G|fd=C! 첟[f=3}.7z|2Y!t`5ϻI-,tfjΧ I|-E<2.?2MH6 tkʃlnL"C[C^[g.ɍqfC)k/vV|&lU\'sR̺e9a1?:̇~!F3 NQox{YO{-FǠ=Guy`gveuzG},U?p 2G4Hº3 ɚR jD:_?b1w~zȷC''V4ُkb [vj$m8ƮfH>@OrwS͆A_XOpz+Eݢ &M+!׻l]xB†ޒcj8ahfmls>{E9M=MDG8 g'u[ylT)(j1S[NC!*%5PXAqoQR28E!t9%k*K:maÄcjr6 gT* H#OↃ=p{j[,PUYy#IUi 9P1K4x3^tBC\7r(vr~&]l]l=6߹گf Ĉ{6vh+S.vG) OO+ P$9FM@T'u{ O/DDrJ(}h: S8Uo A7ժiE+)v+ endstream endobj 5575 0 obj << /Length1 1399 /Length2 6316 /Length3 0 /Length 7272 /Filter /FlateDecode >> stream xڍtTSҶ; 4N(ҫ@&tMz*#{QDD. o3왽p +ڣj($V,(An@ qHu&11R?h8@8 t[2`) I BT^{@cHyQhͿ~,--Pt0(:p; C .#*-uÈЎwo `^p{n??~CpW 2004 \( U(778!՟  Wͺ QH H'"$A m[sU;Mr8 `ў "`wD IsظG#|A8_ϿWV8z٣߯ПSRB%b , H,E\-ձ_Kֺ± I ;_U7wCjOp #''NVnt( A#0XB$Ǐ!|z,eI0_\_1`.!8N>W Cҙ-ngI8A}~3 *Daq)܌׵q}:18-(]ah4N}Ɂk_o>p, &\vR-6*&A tUk]?TY]ӟ~*Vrbr^O{,ðPvF+FSVg8ޑa`#cm&sC]J]b-rLoㇷ+fPQ~®q7$&bƺIuy'K--qj*ӏö~;̰\A M5ƅ:-լ%`nʹ%C6t|b̷7ߌg8n?O}d-w`NRf+y>츾)z]a3ݨj]k 3ɒHb3o*>Ziguo~<=gҐЮ4͏6{{I1ް[t`moɓЊk6r7?WI[|4Ej 'q-!IzBReI1|l:kǗr&XTjN>_;۱ oSi]l(H! td!ʈI@㛜fUh!DMx(a9֕KQ ;(11ΕWiٮ )`\` +zJ9/}lڈyljhVFR l@~-#)*x[rbR*szUV6GQꗑ7 ށ37"" ?Ysܡ)MtT[S ?g-]q4=f}a k+taY̭<tڍ{oˢaTy\v}Pn$ J 2LnU[ki*/y\Rm}`骔ʝZ 8IV~#d}GyS'*~0fXL?Sb5d˜z,{llS˲~~}K!FhzvNA9 N(Mo|@d$/gWn94.n'ž >ܿ |$8?Iaܼ%Q)uB/Gn5S?&{>2JO|y@U~dzC|FA̴)P1kwyA<>i_QJ>L7<۠BBLg*66Ƭ\.ʻֹ339t6IUNf"tm{%5i>}wou<0w(2Ht%a/\sf'U˄Bvlv&Xz3x:tV&c=Nkv 0Wo,m\jy 'D6$?6M_ ˰ÒJ|QùΫo;顳|M6.˄v ct*A>}-SWMt9,Ot%{Vh|C'foߌKm;Dk$3ȏ+d(_ɚq8q-HhJG?5O}Hjʃ0l{N2&$Z~;(:>1eFO>6>Xh>e+hW`Vlظ-Ky2P?{f3D--{ RplJ‹H!#tĴfېUpe$/Lv4s%09G$Ÿz.JC'M̆:xD}val@|8T]K Ej (#O!s RܭycRbT!OrΫ7+~ž7}jIO5'DR6+i3e]@L2ai$L z{ w៯3(, l?gXz#5aP55KF23=>vѬ Cu۵gv+l-h&!&w!2XkO})Rĵۼ!uƫ qGy[ZR1<5*O8m4 \\ %"oC1TX ʒYyb٬̟UNg'lc.E$" O3PMz5wy<1Fqk 罹0M_ͣ6rGt]]M`SƋv5|Tq^ Cbo f,+m#բ@ ̔\N)c}}]6§iYXΤ~d}Y'`\ 4CY8k{xh+ǘw޲ ޼,EQȨBVXtVSZ3O%"aD2:S f ojJ?9ZfjT6J\ 揑z-/ߴNm69^<2%"MBQy"^tPV.?YvKHKI,p|mH9KxOuHlRճI+*<:7=X5TM-bX!j鈇]_B?Q orOF_è?[>{ubx;Lzs}}6>⇹)}V}Z%RNA"z:* !Ş/oX,{R43?8X5mzե;wdhƮ~=ɽyTD:]|sw]uax.ױfDeJc͠ܢ&ާ+zF4f1u{muF4,nqpT,sn}ixCQ'Q%o[)?CF U;!/Տb1W,x;ަ6oVJF~d5tiب tjBmF1 A# |bTNiflHu6[ )on;qwʳT+}8Wwfع_1mef.UHڟڶ/eW’Poz'wF< 19^S ԬZԮ%e{Y5}wv PWKo9kE*'G=޹6,veoZShEw92x;%}ghʀt$wS cueT(u});Q1=RHpQMT;RF"X\6Urԋ˽b |vfx~RŴQ7Kf"릀˴m.y̛!if8l&i2?l#$k!˺(ԩS~or&lk)a6 NkV3A{=7 ggV^6DsB?,Z|y%9)*>' p\3):T%)e;[Y ɠz@;9AcPɼRT<:/%{H G>.^>)Z$<1r9q=^٬)AI۶(eyBʵ)"7DYh5"ycsRw\WYjJ)Q8w y;M{FxT%o1zO,i9sJQ$i?,@礿eō {#E!Z.8Fo" o ^J- v͙> /ټAA:s{r>26 {hėS:o\˜8+|ڕm!;cTs8o$.j[u[}ڊ2 (pQ|wPC(.7yP̿٣<2$&SS鐇$)|ۜ; ˖G$]<_wl! ʚW?W/`՟ޘWp*W5=7hyVӨ(Dgv/.բ.#c>|T^2`A Qt5L@&өRswQMR愭4 y_j#9db@V.EԹ3{7Ts\aNJWr%G.Q1um9?tJ@jd<\ǹ*;T~Oc2R-:dR.o6g-UKSj&bLR/ 0piH)Ikf۱UdqjiԫHӉZkҤY믺IeSX:lfN]n$} ji~Xxu=H^jg<e @pO韟R0~6|#Aɝ^=+x'9WD^Y±lKE$ਨ뛛c++@Ɗ7Ҽ(Qkc%-?g)W6ݥ*=jF66ڹ5WMtIc-<麽Ok/eU%Ϡn^!M@fL,M7'l#u$_bٰ7E4=Osqj+uk͍3@דO gDd$W`` Gy&I/A,/K[C !jkbd/vg 9/ }EkƷ3DsqjQb@щɌEfggyy\3l_^D3+'vp ßo` FFNZ endstream endobj 5577 0 obj << /Length1 1507 /Length2 7088 /Length3 0 /Length 8096 /Filter /FlateDecode >> stream xڍtTk.C?nF`BA@JAJ$iAZ?޵]<{?{{/'-DҀ NNC8 iCEPB +2}F"  $K IH0,"% (CᶀD@JH/}uP@HJJw8 C A;NB$C{+"-(!qv@psa3Og NnC{@P0nW- \k]`?d?>BB+W"8w0 E:@^p=`wUОh>E8!!r@=7( vp;jQW) l0 >e8 uD =;8W+fCb`0XRD0O^.|].U0_qhF !!E60{8O+3|0_iOJ^H?+mt_XO78/," RￓB'Raz5s/7@d*Z bItN\b&,r"jvEtjzt+RŚnVkU6UtWhMw0#{^mR5㏬L~Si AZCAŶ[wq]>N4h=_@ ysZDyY8@cUn[᪁w 4<?9ʽ`*Fo+oȡ-`8bT1%#n0mf\)-=S,aфA}"NKςa#m-]kC^ b)%olUaȇ6|/굑|Vm^&H=El=iV<]Q/7U5?IMk')Ml__WT5WƳZ6鲿vSQFש@g+L]4\|hC飃RГd)jF𚣉*@ۇ<~ س8,^[Tq=]d1^K)=~% AYKz]uۃfOD$L+(i*mkxylݧo9Ū'Jr|g.oL䮞*h!ݩR7sMVOK3 &pϩ :mBJL޻T z:덠D^uN?m~@H)"vXc-M %E>2U֊a#axC΀74"kuX;Ja/ p=..cy!fXfFtz\`Olоgu=M}1y7y= wW7K|;||>g"C>)0F 'rVN$N{k(>MG5dc 8',k M3v ]rlAgܔ$ݥHrZo swBy!Aḁ FYI?Y-x=P|eR!uwfɂ(6Ni<⼰+Ie@L85;RF.Iǀ A;H@iDimdAzt>M/:Tk}Az;9'sD!ov&v;] 4,uVKΉ=k[ &)71k#LS ܦpv ' hLI{]+8LwW>g/~M2~]N /-KB|Ӌ5?]/r+2>GUӀ~"VM=b1MC%jRH9^'ٌW8cկHRLF`K\;S^p+⬐2W`}sB65Hߠˆ?_)*9(c3('[74qBjrӋ7َeZť$ZS#ZGHEQ}'ƕv靎=9O5]|B#_{PX2xBZfv۵}T؇aQk^6A9>/ z;& =Hh"JǺ;=O qv7OkG#f[w*@ºlm -"' XR0!a>#x)bU^hZw%0u+&FX`Ȟ'|WɺRy3/BkK(7'Oץ3BO}yDr S$#qP1aPqƚ"+¯Α[u-)= _V[^AvL^,E7R2l0-o{ƁkBt9g#Ef><*RR۹:@Y#~t)CE}I]:4zv?)M _ȧWB/ʦhaYA =rd͍ӑ6]eפ'>^{X4XNsѽw_DHBeTԁh~A5ŬCzD~"c[Ru߿醅ItG `^w=]Z<"p†-s B)vXy$}~\L>ͺ?(E(*RRQ[^3[Vk[G V5]b-&]!KYjn߻8wc~3^Nc7 zjJ釷"j!/, y!3c^/be`OBF}DЂo2(iR j_%B;+sr?B%| *p7-fxW-O  %;x.{3 Ke"4ȂӰNœ)j_6-91 t k[Y+NM߅<$:|mb0R$6{{Z' e;J ~XepȽ9vmE*18/DF;%=-[C <{rW/06c煉=OoK(6vԶbDcrK};;̜XVIa|IFi :@H f; 1?Uyh(dHw%~U ;!--T0^d)t1:Ꚗ~f/SШrYa]UٶHscpf'~;6^&ʻбD820Y\CQh-cd73+Cb=g O7R=]Hºً՜uF< _p^(+ex.Ϫ%k;'8QQlp1l9J]SQf\U%|^paS&sOq~ko*_XR>_lZ֪*'ؑL~آa뱅N'zV]/g 5V jL\mǭVEHqkǢ9/$wl)^y<$3Kĭ"z)k~hk Ktrjku^AngL[5#Aoi4 )~-*A!ReWK. ~1ځQ:HH/~!Uph%玳8!ϖO9ɡ7qw(D!ycKLo)ׇ#o$>A+EF=n7PIqG7iҵ$- ^yr&^VC0tl,U}12*IVw*ؓbš&g6+1Qyx MW3/K{>>,~xeӍP N\< V 5"&F7 F:&.>߷ MX{>BƌnQ|n=Lj3p-h~"c28QZNpS\;`m3&W?{n K;l# &L!ؒi ZBE񝥏YZ0h=D4 qA׏GYf'DYGwoSlye8$[/e𘙬U Jl/ձ7(r k,ȝzP8;3Qv L$ 3@3dkt?Yq~EMJ--*)rqzI!Day(46Sz#;DσҒ 3kmX{3S7T8tt-&ClWSc)M>yCB>?߭f`m^'#T4>%oWX` OO3C3[F9Ўgj-CQ&2he>ruXVޝzH!`ocYZS:Y!>heټk=Qtnt-N Zj,DTE0G39{ 1퇅j~yIX F{!o= e^nL@}CGͿ<=:RGC@EkiUU^{=*+h6s FƸl %ٶdϖ2v{/-ʖTr~Wg,fA4o&[z ]_%\]23O=;p֏Yj=Ȍ>a1r.)v<^NNgZ ?˦ nٮ޲uXal웩q/`$׵_GltY#S~@|YБҲ)zΪ(jۿ2;/+Fk/EY@(edKa6>sٮLm=\N4>n_?ޱ6SSmVgs,f!ilp~H0Ĥ5%飺Su1,d"S# YsUdQcq2NP<KX]*77B\9 \F wRAWM^UבK~SS/`5#_p6ıH}jװ&&,`/]W)ۈ͆~ YZ ¼c5(7^$y ױ/b{/|otxcLA'g<}OllD~-/ݙA]ZizmՃlgV+2gcA]\BՕ;9Tf."Ie˳+A#ٙԳVKќ$8dzqGwz B$Kc?i!>}b3zj?}Ptݚy)GLaKxO\Xt|R"Y zKq,壝CE\"SnQa2Sr-Pg,7u&H ̓ Ybu`ipH#rC aw>3n6c=s˯/65f>xzfzߠ C&>i qhEUAJPsv~>E}XZ #. թ'rXDsda"};!f0 o *jv7| Bm|oҧ&DLrdp4]d6nt)Yِ-#Q.+;|5y q%JDG}9|2GF" X^O.18JTQ]I/QButϥX*ޫAMq˅ɹ>3팊82~TFzY!Y#׶zJR˨i$<6V<vz6Uhגeh6EMkTHLTy(-k>O|n\)߬Ű$9y|xҾ0m^ _ZEVoqrF؊Y M1r:5~J`<3{a)^XvFf?`ze]&ڱ#\S> q4!*vrܔB Y=~0K c|7[N$rJ-\ Ms1;o0,E7֧ZW L]ˈ{9mƂ~\ڣҷVe!.f iJg_hN> stream xڍS 8Tޱ]EOQ-O2AR*Yk̬1&Q;]RNH؅JEI]ӖP.]8g h9Y]O1l ōidpqQ St' OvX"E0+pfJ gfjA[eA:j I,8c(,%bb p |8DB(pp,"^BBqWL a`%q"ɐHJ$ֆF@$e`-$'K#N8<0>.$0 B R"Cy'WN ` liMt qH  |DulW2)P|(B?OlzN'J1.%KF2 f{gD0KI %L7hاAy|e<"2nCH_l0T܌`r 1<)D abL Dp8‡?R .a_;H4!\J0;1  6S U|B(B)[re)o3b˄qo~H{| ' !2ѷ^'"v?P\L0\{kBgH"$*:10O<8t\BF1 |LBR)4$b;'G>0 sIM1eL`~LK,qG D/a@QVCSOY7;9Vq5hi JۍvZ=F*w\ɏ+ܕi0o(/Ź.ީ-/!k$%i14TbJY饹6y2eҾ55o_ݹOgxvhҖݭ)vH>Tů4,g5Pi/Xgn5 7D7Պ:3ya AM5o|I_Ԑ'{wζbAOliEiGs 2_fj4rgz9Gf[Wk3}/J9h~?Uk|4R[ٜNTش@__vdݼcp"=Oy\ظ+t38cZs2.-ӱ('5u]팴^Hb+M:wUz.& [G6Z̸9!k&lĕԭR?:I=tm/#Xa RG"2dtOW'=nU$ǃ/:^-2YeINVyé<-GDUn+˝qcxitz8gdYBR%GMܸ}ŗʧns7xfkP*3SLP~PoT$\1 w7Wu}}flYSW-*Nyi/ }xzGxVQ³:3 yFœ9.^o2js> stream xڬctf&NEOũ۶'͊m۶m;NvN{wc>|?k޸n\ dhm 6Nt YskCgG[iZE3'F PF&&#@ @FEMM_LS@hekg q ̀s+ @HN^CBV @)& ΆVFis## `b`dkclOitG;_7 `m`0u0q'[? +!;ۿum ;O'3b;UlMZ9Sҿtaj mN@7bvVcs0WΎ6 hj`ltt Wz;;+y`2cdolSs8EoԹ foƶ6Vc ߐ;Hozo~OhQg++YH9c _V4T; '1Kÿ探n@cys'#3NKbc t2e_220N hc%_ӫIJHQ/+;)M"ck` ںF)1( hgN)Fzn c`ɸ }ξ':;7}Br)TIlu"h `o!KSt*Sb+#-D5p3лzm%ImI búqVzo$;u/dX܈ܹ=*۷w P4INa^X:)V״ՓKH_%A-@,iǦ o b8 /`JKMLMhk6# Őb'=Seɚ^%t;~%;RqvٖK7M}A0N$3 bXL_:`ZM;(GxT@8'oO'P)$f, ' 1 b_*skű^/;=Ki2ҤO7<ٷJTB > ,p_A# o}U :v>+*8 1LV#! uXJʿ%'ГrUGVw'cs| !c 232qU6P.rOgX١7{ 7ۺ cmTbAnNJ<>9' O D |P=lLNiNFQm+ 1#bMm (itUg#=9Ae^3EpcC`ȸ@4KwqBazM[~B*v5M<l/f P},e8bA-7m}U5k?XꋹLJJ8rzjGqŜӨrCKT;3 (6 'c=U>)΂dqz17qs[p|έ[L̵ٔ[( 7KQ6䬂FP-B;{@rݞL\ |f41Vx_K+<&=nn|!eSx,IyS[zMEq&q9BgiYTQEdqRc<$WDR<Ҭف([qذ_hאX(Iv1ÎX_gOy/qk!ؼhs M4D|49oN&O_}5۠4)&NBTГC95m* ޤRvCj.v껣[PK©(s$Y6`Jp}1!/VlQg ~9yhZ57UCHM-ߢӗ9zͅnr7wc >V?wxL,Po%2[M;YrƽWBMkLCpkK_RU"t>jdG -pOX rϱi[(9R}h+2@2WØ >$ Wn$Di,6}wmJ 깾!4s/x:{w;;kX| ?3rEZBis;I+.eR$Z2|L=ugI@ "hLbN+] u9JgzAaC!F\\26ENBeO[5n~{ EyG<zV.#[mWӍZ;9쮾W"oyvH_:ŮeuŴo>r!SFD"-(sAK=A_Bp1RV *+3f;RNP0ydwY#MgRI9NJ0B ꙭzEzºY} "603Z/(| _o+4JJS#_<$@Yk"Fչ ?Il]N/ 9h^>IϦBeeGƹov;eځB!a DG ,)VKIPǀu-%1 /j4$Z\-y>6˿`1dz1ճ$f!uY\[aS CtԬ9ٕfAR@ v xxt~}+ʎI$1ҵcla"exB5Z%!Lbs=+峍e.39yVgJ +z+V'J{b=(OJDpIH< -=λ4f]y1͌<֩4ć}j&b3:!ߍ%:#NNB_)v+F[&vOA|T@k~z0M1/!02}yIIiL*3PDKő}oʦU+hM=H IWe#IƷg %&!/yclG"qU~;5fǏԍNؕ=غa*P5cPո8˦h)j5;.J'ɰR==ĆGwȒ:p&68Kp4-$8%),M>LoC 5QC}dOy V~V?Mmiφ<C N=) IOZDNJ0r w.>d>ى~"Kcf$D/ >t\rc3hTp߲lϲWAoL c%24W?*L](D E;R4z1T# ?!"Kz%ȉ==()j0@޴ ;RJ_-ɏwx!*Q1oy{9j*"j'JqsmM\P5a1Szw> c*o 6YrgtgԨq'DÜTh9[ |+F2PݫTj[,sg=УVҹ 2.n>x eG26Ib{yiWYfE,!ن o~O:[K֣1lM Xq J6t"  F!lRQ=CO?ѺOx=8I-Jݖ(.I _K D|AT+*7)aq'A}=X4U)dž/fXCm$<{%){nEW ^.츋z~@A;a2x7=mf)k)M>'ZϤ}}>k5I8g.d$lgoIG1qLFIΦR?z>KýCqB `zBaiߤ\\1Ǫ3nCТ,z%>烬nC#A‚-Cx ~>TrDgJ-ోgai]LFcIpwVxG2juGŽ8VΛFteX8h5 ܷt9Ź7&F/}GW2Z辯9Myxea{ LV%N IV\i8s֢iE_ĥ9QS%=2~5 Q%5BIvk#} Fݚ\_'g әcAMw{d'6<9 4ͳ&Hdߏ,&ԭ 6«?7ح1OU0ll-g>R 5 m~trzHԊ],өqͦMz ՁDÞ {`F+tYUP&ٿ; txiߥ5wa5Y:2 L^6A*~˫ѼqB^PecZ$AT!Or 6ۤn- }!TDJ.C\8Уdz+;=o c7CjxD5Z{2JM'L@r}94y"|kEbz⿚Rrj< my)J,r~1c 4" vȳ3m97t „@ޙLDS .Hl%Eƚa=L#ln2%l'CeT ˴svZCɡKl a; }Ig#`=|g^ :?qINp(hAmT=7G5_eWq F{QerQ"-©hKBqZ܉kݫpA*}F:>ljyb9ef#dX Woj8>BlҖ^7*Ύj\R~} @{^TW"K;1 ja8eOLaT&ع [0R\@ybM.Guȕ֤LD$fT/fX&Pma*򞊸 ߀>>yh)(VfAi=I1C DmÌ&j|#FVm}twWԭPRdlGꏌI_nɲ*cYH0vxuIX }%3!}ǰUdDo-c8 "_υ cSR-1z%n_PS 1 6Vw@0buUHEϧLxT5E\67TKR֨ZwMɛyK}O7]fr{ Fٱ..u)?\y>ccsN52p `Rc!ݨ%үai|H%-N̟>yVb:^C>fǿ5Z#a\ț6ObcЋ{#i%R-!8zY}MvO}*`&] `tlY ʣ'q>nX2$-e:CmðpyI{u_鸁GK-> n;Q3G52dѡkT^Z6Z}L~ŃXt q۵ӡhDQ1oblM+ *zܶ`,/HI;wcA{`Vd3lΖ#Rb*Y4ee3C i5~0>\&٤&pF"ty٣`MhѡjcOBUw{Qcw&:M9S(wF ?\fNɻFD{GAPyAX_^K!ǎR`ދ<ĠgJDM޴7/gA.HM %@rJ Xxv3u۲#h1SC"Z:WU%ԑ8`RntWk\Aݬ}*CQ UXKϵhqcmpڶ肭zbmM[j4X'pYcl TGp~h%9fHU4_=p<'k=NbM^i]x3T}\M?˭~iwgaqu{zb'"DdrMIWRox̱8 L f[Mˤ 1\ա y $q6 +Opcc-=Ok. ë !̭I&wl{ijǞ(V|؅O\U2;8N>$aQtq"Mnz܌6y4Y0m@őq \lX@4dr5Dc\Qg ڷdV^b~a_ӝv궹Z062'xeu&#R+ܲDX>6\خ7hn]_n$_? ig 'lsO[ W )ԩ瞓:Ut+Zf.|[[4 |'XZUd m0oul vҿz^e)"{!Z/GuiB16U^F&KMR<’t<7S9qnEe_)*%IPxn;[aj9_]G6SrB۴S P}&.5+ϻ[{h*އ=|IKљ6N0=ViwͿ'W0g)M@_3㉹tdQȗ?Fk{|eU̖W/^$Tz wlKq=lg$pq7,& گ4:K3(}ĹqGyzۀ46Ql = [fqC ڔ_E'JH$۴*6YZXt?F3eU\OƅȑǝfJ>6Ljt߳F,O)R7ٖc5 /G0(*ҹ^Ӆ's"(%EOBr{I`1!4aRZ2RH9aag5; = gՎ#g4[U" CJ;HjiKv@WE4w>i';x5T 8ڶ&g,WEVVIYc8WmƳ$ hϼ,qe^i-ê{^ D0tsIպD,PQBAmms-!esģocdJt?7`CoIs7? kB8y6n"4CU :Eg;@^6Hg{q;?:#fFu#m H ^9K& J*awN8}ly4ڒ3 Sr ?!e~9>o'd\%Zds9{Ub4!~G n0 #o(5͑DS`%BW|, xӻTmY(#fb 7ݮ7AI(/H|Cv[>d)vhq~g`&1FDj9&!K*.p7PU_:m[hR:^gn>-p5' /ƟY{DIb1$:' E~*EUb"F7ejX@AutxC/[S)duH ^7:a|0w-2F1A3VF%⤕@UVsJg{~*Q.Gq2}m&`[dS=|ܣʒvpir2<}XX`AAX`01(ٰw“\UCr>NшQbG z[#wq3F,)9_f"Q 𡳱nn1lQWTYX;!=v-f9<m튚 0Ub 2qx&b98>W(45=Am.jE[ngrx>e?-wD&ʙ' |8--d2-٥N-CMwNAsGU"^ONÊNUkuL;>Wc{R'Sqa"o zc֭%K=G*VP.vkmq@[rJ^ ǼcarT'!ʺ@8i/IxEI@Z:.tB.]~=E"U-6":NU6=.qk-a[ sVeeL/,+ iD$8\q@уDjXgu]^H;7hFEMcz}C64%G>v-CtYO|͌6R 6 \PE:ä#^sgNL Q t}~:1Q+ZlEj*y غۑ:O[aaX}tT?u::o6b=}a4J} ;`t`,LU/,7HcvOQԶ> Y\#4r[#h'Lɘi.AMrɞ=³GfB[]z{"{wdz]Q7HPwfS tmhZgn:B6G3ٺ`__a0bV|pI80YBvO+:b7L_%j\MXhe9-8&)17v 5\hr*,7װg(NTa kI>B5A/ 7ިhaU |p,P5ߞ=+LaVH^ުo53-80/>3-И[!_Mvr;rTAr#1FmJ_TT)rۮRKɱ2`;!ktEY2$eТel@WĒMq\NXL99dԊ"~y%lI__TۏaZCEx"тC& c޸ܥqJz]bI:ۭ.5qZͱ|P[? -u1rڵ*2G+;>N4gm4c] :[#(ú9h.M)ReHY!jZ&?sjvacxBۢJ:|Bw]z(DYݭ$F&yi_䤢|;RtGǬQ˹zYU K:P}wp@DAH =}|q%WWY¹ CavQ @BMDRssjVm $Npl<:v`[9B>ͧoH̚aW'ϱ*ZW^xݪ `;4Yˏ;c5N!?,nKF#X2"ܶ}Zu&"]9da F<-d|Mc:fS5_%f@P9?MLJi][eRE5\W~}xG3O4) d4]գ=@{^>c-QX@!Qcw@=Џ2W*\YNo 2>Xڨ$VV">(nLkJ \ پI_2G gZ`ѓOȹH>h#"@J%}yԬgբA pb2IG^4(7%&bn?O2bcFH', WBҌLk}m/)%A/O{΅dT "6o%"3:q&d>VJ>ܽ#?Q1,!{rtH̽0~£dܻ%g~{+oFfh_[eQNr]oiR:FB* > y\B܅#`}izrڞ$uLMb'= ֦s%!4)$z\',0\#<M݂ 3{K ģHZ԰YִD)ayɕE ' D}|+dW rUEtJ5ڑI[Meqw'-clN`oU{cBn%覺\M ORMez#Pun ]h fҪp7^MM$v iqnnQac1~<P\<z5/̭!IJ𻂖l{BmEI+OloL^|Mu`ZN1) $ Sیю⪩;XneahcY轲@"wh& İjRaAI(@v-$ت60x 4mc@3.ڪZJ,]T~?Glj||RGx cvD3&PWlaLS=oDŨ}<1\LTˊV$Mfo\[w⏣`I[OL ØeEM\b]).) i)rw%vKq l:Х{a"CWPʄZSd<!KH:$-F5/M_,d)\?mX~YڌMA v@ΜzȘR1ݘ2l3+ ZG֜ ukjAl,#Fv}b:κdAPݳ S;{e7vJ*K|7~WEzfz4ǰKg#1sb w%BC߀L `?9:-j/-Irjji§Y& t/>NЌߧ>~w./CU<ʿ}ڜvq;6QW=FðfgkǁeGipF"Qg˺!HgP0շPl?CJNchNw]t%ƅ񕼁;y4A#!dz9̍f=~Ġ_x*B|wru|<  JNKA=US[zd p7L4XilWvKT*,洒^sv1Cmyͼd˓\}l[2 𳒐 fs7)buc nL<3HP񍺶J謜"Ȟl#>DԀGOЉ[Rkg`C Bs |njr;~=~`>@MI0,{'RP\ L*aun>vcӹ؆Ӓ`߫,g٠$Í-# @lI]faDm10~p:73q mLh7`RccYFwMDڙm\XT2V]AU9"=>C /i1ta=r%޿K:a(ω*zɍ&Nf8Vh\GU~,c_RA_pK"X^Vn&2)B_WG&3xͯYCat4OV\.J)(X s4k 歛[HA61f@m 0~bO ؒ 3Z\5*A~ t%dHXfN1g[RI:$O!<f<֝qAf2c lpnF.*t5]t$^hZa:6,գul7%ыX3nZ778?㘰wDtAϬS_͔rH8Q.~}s˺ @Q"N},KeY3$*i49^Օ"uNl_.59j)ސJX/gUȃ [Vfי&ZpStDb.Q`lxPF.EDR ,e6z[DKn2*˫'Ν65#CZd90=2m&? /)tvwSN(EEyW_l@vOX]u µÊ-PdĭF]=R t*A+ywgwyrmbjٖWRU|{5Xv/:Ved͈/j4A'^*[ 7vDV'+`D[ாxz:!YIB?әB@m4&?|P`wÀ}il6Id0Mlf|Bala8Oh;ԣ2/5aւ.ӔhMylH5J)Qbg.Gc\7AE%{5G?]EЩϤb}0G' JRdNgfD:APD$f{#Crÿ'p 8:E`if/" c~DWX3AF87RCG&8QCH}w4 _;8/9=ra͊c\}.J՜;5 'z>Ǿ5ܻ&g|1|2w47jdQʯ 4 :;Z{E咖;h.MftnWgR2>p>AV. ?;҇$!D+_f+blAz,i8@ՈT(/ӟDW=9Ș{PF7Y<{0Kcv Ǝ(B%_tY iQv΋XsL2 'tM_dHcC8̠8 (TqjnUzwε'&6Eh),GȠ3k{Ce Eu&͉5yVǩGn؆lǛ^h]ި|w 6@Ox89=0iyVw{G)+-> SIp`0Qw7^Jpї`gojFNH`t%(u %Uq٨{'i ~k{cMIdѦ Xhb"?oW#PJʄ)`N\M]W{p#Y1Krw;Z 6\X^t#''I!8bֽǚrWyfv@I-@zWR)Qx&'?KB,:II큇 MY=Sh󿄀>ig{SB6p"}sskWs"Ѯ* $]=8a֍A) *'mF3'-,b'[ryi~xwi/oU endstream endobj 5583 0 obj << /Length1 1144 /Length2 3664 /Length3 0 /Length 4414 /Filter /FlateDecode >> stream xuTw<'1W̊ùq8 +B$DHYl"qY U{{z}]zoV:P'`Fdj 'k AIp<*Ah8$/HaFCpD2`@`X $G\ Dc@V:d "Rh/j`xU;+HAq 1{GqII߈*3/`pHhF A ܏vAb8? 1,LdʼnzhX3G`/bS!B] C?[eQ<``"D8X  [GJ') 0 _?wrr ( kNد9A\2`{FP( n@vzw.()-wV$-Dt QQUIOE+6A _'WKt!HaAT@^HI\J`?/iB0#?89d;W8  t~1A/XCD0B༼n+4I)y#|QKtO @AHiBC(8GA{1x~^_{X ^#h/>UWI/ *t(i2dZ#/[Qz>W2L[>5u{cxSA)kDq*=<"ջv3iԃkKeH8S99ǽhx :^ЫI<< ^ -ěQͽܯmC>ݮ_fks"f}5'PM݊bKk2^]cy)[x:b8nWGaOiHt^$O$?ouRӅ}֛gK2yqKW[L=Qj zcQcP$|(\i>JUd8ɋy=3uϳ$::%ilO5o5r)nvTIwMеGھ~֥iחH eXnQ)t9["\4}@bv0$u@߲+zk#NHWhi9Kܠ ɬo̿Jwi?:zSP,4%Vи/8G6H ےR+ݽ؍/*6d^lJSo30{АPntJik+i4iѮ2j@XUޫ'y,{CZ^nA)!EXGyPrL('ߍ՜/-$4J+BQd^Dם4po/˵Q{߀:q%jD$c}@-t(nZ}^#2R vr_#+UKbΊHx8w]tV+eSkQU|"ndt\t۝ޖ+&v))j} xV+^Y.~EAQFSzhtƮp8巄y4~#E̙$[#8 ]dNtQoUn*SxDQ'ABl2l}'k%WsSKtMI'+0ۿ;]T"ESTdݩPEr Ve+\))`ߠ:VS/l.|k{fw\VS*]GB!R Ŗdѯ!Kd֟M./{,R>RAVLnޞs8̐Gb,y3BYBz _plgU_@\W?d 5[oLL;2Q R أ/:ěN#-v_^/;w{ Ou{tE }JzoYX{8"o9WD-'Drv=uxx`oR*.=]p|u`jL͘I>Bi3 8! lb:ZtQxŦ;$;8碚sFXqjbL4WSq ZfzY c3Q2ಎ6=M漾6PcYpUeDxJr(u#< Nɡ$JӫzZ0.-cwtF$ڳZ+it]VyBLJfv,M86+1> x{rGaMrGMG~-׳`^ EmmJƂwWu(KAnuƞZu2BQ.j͝յg)gKBs^g.,Hix (gs@@F.\d1-]UA + q4PfaWZu($ %ʙq땼9Y{blb]l Ը3DcBϼ1D73}wCw6sj#ݒËv_祄mEKY>gAl&5 nj%awRye.VS b n/$uӚzè$hh2!6zzW^m"\SAt:&bW;6 ,/m~B 9-㼼pfMg_ƭ;cw^1] l>Ux\S2W5rڬ>z9V%y}9r2"ĉl^@zD闽dN-8h3Hur\QV,La)gxp,+6aؠuCoI%RdaCKolwo,Nl@}h^>0{ q)AUkCvo[-t"W&˗0#&s3wbF+bήN:]/0ZK<|6g{݊T8xԯp1hp蛱dNVfѫl [?Y$tO}=L0 :Oԉ̂/7ؽ/n}e Im# TKLyqAh]-^d:I_VTF- $\j}\z7MC=!.]gg,׍J؂*MKg{od4>hgs*+i{~I endstream endobj 5585 0 obj << /Length1 1626 /Length2 16564 /Length3 0 /Length 17411 /Filter /FlateDecode >> stream xڬSt-b{ŶmXTl۶mVb}Nܗsoc·ENB/djo sgf`[:+sM-p"N@#K{;Q# @h XXp{O'Ks 5--Y {OLgKs;7-/u p,mE-)y @ht2(Xd-Mv@j?93r&Ӏ&@\to3 \v&6k7!'}]M,\*?-f#MM\i_0.Fv?SKg#Ͽ98Y18͍Lmab3uo`lE/.@38f5M\6cgWL:O_gg02]Pߩ'-OB]1;иRl-m<3Zo6r1;!;010h,n4Ut1׿jv@'K;_]5R=3T-,M.+տ3jK*]UOG+r=3KP_@u3rq훉_FQq13i<4[_7 R;2%3 >PڨZT_c3|6is@pӆ7xCJ_EI{Ȩ_~zIvBIpoJIY` ڟԭ$! "rh|td6'78ՍDmA[z]!#Cάz/qZaoV.E=P/ZDTɵd^uhh1>U-)"lnR*¼-Lƃ-~܋=e(ؗ]80 } #} v0d QY(Fs{/glO PyYKOq$`%KӛA=$ /v jL+ws?f%Ehϼ˴K  4.orl +)yǿT=\2"]J`"/xۼ9,]Ѻ`z"T/5g0hXJ_oדl ⍷Z|7aT20]pTKyz}U|i vw}mDS;>;+vnjSrQhX!6ʂ&Ӭw!j6Av늅^iͤo1xʸٝ֝[#ok)!gm0(ڐ = OiLWXe9ǡԯAӀD6 n++PK"DC|%kWs'n滞zWL=|9dO)CX:A}sg H{y -]Ec{<1$ 17w9KIu/l?kggϵUw_raӎ: N!BRkИ. LI|:VlYzJy|M}xI.T6ߕPHB+gd5?=i秣ѤL&֜%]oz&@wqƞ[,y-pC1^ч{Sν~G#:BՐ* /LڈjƬa+hw9_y׸%/[P}愚_z6+-}tЍSwW߫oO4*8WL aa ?o5my *K6s1=#Z?zƛ $>É n tekk5tw V|Sp=$7-ur& 6>_=r 4D\| ^ɉ.FHNWMÐ=gO`R} `]vsxox)xYy2@Md6OaWd–ޖRɻSnWl"Xx*~n>HEAjPQ4jJS@>M MTD́NBH2I(qQ@KL@H }s2富@FDW{㫟wh_Ri!RbC =VPrx * 'HIjvFܧ' LWo5eDRc$xK&cj(p(ȹp(b)S(vl'ƹ7f[bNl)vec&3fnjrp-[t%i|˚)7%eh'Q-XݎCUn` Bi池8 ul"?]MU٠6Ru wB{ke`7ixh11 dM\e'1RHڭ(j{Ӊw@MteYjj:-% >w7jgX)~dr['~ q"~Ay]T͊U `˟9E8yZ<萜^]_@hj8~ ųUݎurע`,:a,ATКPQc9X醫ęI)V:԰]y4MʊԂ_7KaH;7JRGUܟo)27id t/l9*i3-\ JT RjOhW1Y3UI ʂHj#l6Ѳkw4<\NU{o*X3\Opʘ0m-] 3Qc b螠{ʲ>"dƁ5jF[(ʫ2h;ն UtϏ$KXd^ +BT ),9p Yt,uM.Z4/ޏCgIUT1 #,pߍ񨨠|6u3CS wqڅ]5A*X2S7zy&ǰƓP+ b[T;+ҮWoޑUS@Đ.ﵡ㬚x\=%py{3J1K5 hfs㧏)n1Iyջ| SR+w%,qsbi}iʃk]YނTuВ}琞<5a-p5 nb4Fn0)G߼eSWѕ*@ +ڲNJU506RqԵb9-5C ؗ%Y4E7ݓD5Uj]sK(\~>ܰU;58-t?Pm&ARkA7Ԃ_/L% >ukp{q9-_.MFp1@&>m2)qgʅ4Ledʠ\Ĉ|3%-2*yqt-,Y+&MKԹQjCGdRX,XE"]c%붑;n~3GIz."ȕ\XpI:3~*d\8ؔ ppŢ$z{C) 0gA"22m,R(Ix%gWtyuӒS|D6׬wDH÷sGEt;|-tzmnEC(hCJ3&*jm̙SPǐ6\Y {ފ pǼvsR/,Aɓ#(π>N[wAD/W3\YS`ə)q,}wB~e* n&:Mrs@-}kM F9>ksw Ӊ'GT0O~2(1q` 5O[}ٕԩuoZ@Ύ?C M.3+j@g{,}Ѿ Kl-Έ9# $BW:pB3i|Fy"?ALizi>ɯ \uF6`ZlgYezQY uޯ6k/$ Gq$AMQ:b(,D\4|63>%|YD ,}SK)sD•iNXNq )o+U݋&>F6`20T2`vW,ͫ)=EwznKݭ4W28ź0[fݞhctR;^rZZôn6s]{SDt'"U;˟ئ>jk'3¹ S R$L*R'oVWn{H6A :QE W0]zyj}6iupse<, (~̤L=HkOr&jk0`df [}ěϑKdi:aד\E3&8dxG oc(H/ag> ҂SK6"8MoEQKX@5Ob#87Chp'({&x`l1[moӮ8Q9&b=Mr:vk"Tw\si $ @:1-ƹ-Vp6WJJtՆɨ  +mIګ06VOVxnjL**T`TIF%S/L"R[0(Snңk,4X }"+j?V] Ԉn93u|c%߃gh=O]Y4^$ov[uc|ɅZYŴ…QpCWK9` H]}EK181 z%tQ: qv@RAq>%/-YH x#(L`Lw(lĿ<3jF4=c=>Dw=>)ګ+;Di-WUE}~ ;`"6|dLgVHz;GލPfﭏ}iM3K(՞RɳُŠɽ1QQf&iˀ_(sV`$g;5GUb/On!F}\y D| K0ig< Vb YX 6I # P< ~1bO{Vz /MiImn=wJfŤmhH[ p)d2ma_4L)j$_pwg@pгu܀;1WvpG>Ӊl!.`6 OŇiu7P 'ɅI8Y7]u-+~/I'zLBL2[@KNm6]"sXL4AۻZ/d$=qe62}JAԋ{|Gեem4zmʜDzW/>9A&=qV[(9yc:Q6!(=HH w k?LŘOǪP]q ·tZtBhG-7Y#2u,%W$}"_.>L+zP)/Mq6X7л1r%t[bvXsYXJ*6Mrh޷3#RJR[p%]7?ZqZά0O(𬝻.Fn 2hBID44Ea]nmQ|En2<VWߒ-)Adj{bP'|aUBbjijW0,*m $]ͰŶo$;o60_n!DZl,\g&P ߭Pd|=)mi0~ ;Z]1}SU8Jʠ*v㶑5C جe&qJR{w͵;8}9(3W|&H{_(HlQ=wEY{Pb2$. r*F\eL?{,Ra5#4_-8Tmt1[i{ɑ\aWsAC#T9&Hd;%pu2qj#윘fפ{"q5t yR=!MS+P2Ԭ:E{q W=ߑ#)U"okF(}ej9H!ĺ|Y frĪJt6vu*8"к;Ҙ6%& 7ρ3dFv;͊<|ɣxCFJ}ywx1Ʋ~?)E嫚Ϛڄ2M#Q8a?gԨ KqEVlMh,#JFwI Q1J6 OۙUH4)8)[? PeP*naջs[( u,e^AKmTQ% ?]q.q U)$Y Ew)Z$*hA(2>p¶uu1;HuM";(īR,-ڟNO'tIFZy1נ-/G%9/{uWBN;)L#,*)krR0'?RWHv>_GN~r?E v!+/v䛌:i lcýCgt(Cpj}fؿFwЫ ֚#m&Mny9_`7ri{@@0pREʼn@;R':]BU lvlX 6z7Ǻ8%IH'&Oh^]+Tb-Ħ:ԨpR+=2݉~-[$gi܆ ao1(8]7"9vVJClgGڴ^](֗ ݈sZ>[?7{@,3|!)^;=pbi~@ԏbyunși_l/Uz&'\pd^4FFϖxUJꫴ ",l7. We`F=A9 T5vІ:ķȖ[WۖN|065uBcvma5o`?uܖ@JZn]TDhs̔>XCF'zRYnߺzԣy[yjWx#\5A\'SJRL?0"Dx1a| q܉՘ KK #p ?}مyrĄ7x @#;?o_B6` KI Q%듉؜~\ST)j;a:<>˥{C]Pt~5LN@%n+'7۰ ת/EpaWWd$JŸh-2^aBnX K("ZiV9 g TrA'^2-@;m.S%ݦMs!^t"LܦWc"VV[àvC"N;nl2hɱgALO+AA)c6ޑ64AXDI|Κ!Cy;qizM52.Paî`YH,`&?3!ڊ7h)F".XF \C!.@^yK'D E(4IJt_&/cxa D"pX#oI KNvk#O!~O-t+1G4"&z 1U[qZBMaJϢ&ˆeç'I!ȗQ3`4|A,c)ec43_5O<3nO_V6֩c!t/g'S$v@ S|6 K(MmkQNYk/Kky_uί1pGY7I=zUalԯLڤACF,$8zW[C-\^7KCH*# YO^E ԺnKB ɅTUA;*/ ^wBeѹaNmfNq:wf_EE>U|;Qm:JZsz&6hVK&|o;Ep*8a@3 E=a嗀-h𢓫 Q8,˝hXsfa\ҕ 7˦-f:1R+\o\p2P[1?3pޭiH(q[C)&33H?DOn~goX*0h-+=gѓE2oRB6NOʞL J5]s=uHM' ; DISdKp)J!R~;pԤ&oGb_Y8?lLy@(zrl<}I])ܼL7B]ޖl5w= \mLUa>/K&5Q~?ׄZ#yH6?=a$5;ZUբk9G3_Ug/!ɏAfD)1pz~:>5߅?zy.XH@$ϜV~T#WU ;>r1sb';62LbbY<:!<[e*ߌɞhԍ A3iA3AG C;/q5Cj~H2p:.J S;kKfs=%.kXD~ʜu5CfJ{/6pRFu{NEɼi8A"$nF )j3n}SDI>f Oto8~y}{,:wO, l#eDѼVLˣxȀDHBJS̓V3`7sUdphUvU %: WyWy\9xE&D4-]juv^oGG,Ub زrMdֹcʹ:M{_2a_ulWΣԳ+*gɯf:UwwY=QCZo[FI_s7ZJC/䪟ځE{p y58 &mY(2BcILFMfpo'qsa(DZI=⚼8ei&jq ^h,'ҳd^|2#O*{S"7jmcbX[ʽ%o:Xxx\,M^ȯ^ǫ.8=&wME^PHٻ(Bf,ņb߈>Yy $zy~[G}70`*Kdh.MjPa)9୉4cNa(`rp0 }N FA'MjO Ral#u)%.Lc nm8f,`Cʐ.ψg =-~& Sx)xwD;+#(Vƅ)iKmu̕ g?VHž A{ԥoBCPܥ 8+!5?W JM%`+2T gM%-ȺP7 R#Вs` v,.޻?BkC 둥'vi%7-ty\B  RtWI V[roM՞35BL&+FSNxӻ༨wNvFBೱR1^> rg ] =-BaE0OR@)đHK1jЃ]&tATsjV:_ ȑ:TʇaҾyU[EO;qwKsvPޤ (㗆~z$?/.].r,pF;ύr-{s_%tAT3p}+_k t8aV7rz2 '0&+`Ѭ `#"mލ>Hd͛$A)7X]~yKw7gl+&q=I +5]`A,TFL XKe1{`8-qTZLws@2p򌄤7nPYII,ɪ$c񛘗vW Li_skbg^^{AgLW 4BT](b&I籘rZ*9*Imrٸj@;#Xϵ []H!k4T> H}t^]1xK'xwVYTJIv9(|˦ʑ$U"9{Xݍvt%z2m7$ӾE}HS u DH TBlBBi;,8W Y P,O{ 6 p~֪pi$ݎ÷hՉwW *} |8ӋniJֱw98V=8高 M/>w1͛[O%)!f{RYZշEZw! v> ^&r֝Vd3ϳұKi#w4E2ǰFFdC`lx!JWqð8dX$ EͶȡF`\Ybj%_V l;3}Ktt"yY3F +I9 *ͤsA]rO)r]Ud*Kn4&26PF֍H5!SBm?mRl2LnL;gS\™[/8µY5s3BIT~:;F^'WyXsWNU6'5ԻgaO6ED`@:BJ^UxRJ%V$hlH~wS|Aohk(4SA;7+=!NO9TEY22 q𪹟cܝ~hOOrh83Kv/*QGOm`=aӉ5qyKZ_|/4!ܓ?ؑ=u9l+= }'Y_Dc"1V9|՝A6C%Ȟzbж)0bb8e5}^ݨ֬b͙7v"0=TI~A2I(%}C݌]+Qk^wtk׾kgCu]jL)'dE 0u4EKb欘wuUYs[XN/,zHkU/ZE!B/[XkLeOYWzqMxѳZ(c=FV>pHs/::Xֽl9*F¡;ͺm$ DwBDqdWur0t-yݼÃFX \rnF)I; ]KFv>t<7(𺥪kn=[^DEyz]1ː/ɳ cnL*Hzv4BQ[.e`leb($Q*&5]QxAM 6Qyq^!2%h77Dgcz%.ugSfm&5>ױӧ̗&FՉv$9X-`+F b3;H[/-xȭF,U{C#-$GB[X.[ܟUq20xo_s 11i$-W75WJmmEiw{1Dq b3D^>{ܸ/AL^*lw̄OP=]Rz;tn'7E"5@'RX*d{xpB㥡ۖ z:H⻃v:e n ,oc<KL[P`}|?? 2)DUzP8TJh[y~9Ӝ TN~kx0.[ա{e JR87ifbP.ޱBwch`\L`;$ _7SVy mDi$͕d85W@QG%ߗL aw%Z!dWnS E@IZ8쓙O. )NRLw+K5͌#bq*~}V6 ?0O:0?CkPDTЙ} A(ǠmͤO"z7Ϳ;;Ϻo9ufo?C#eT+jvFuBv(xC(->n[ڗ<|G:﫝* !LCZ ʺ7;cԝnwJ}MVaW Z{j]U_4Yc6&uCQ$"ʫpjݚjxYUyM*ac%V{\|:ny!(hZ^c|`?iѥˍnG endstream endobj 5587 0 obj << /Length1 1630 /Length2 20005 /Length3 0 /Length 20850 /Filter /FlateDecode >> stream xڬctfm&vضm۶mVl۶mT줒mzwt?kꚸ=ɈULL\F\tʦ殀z622'SCK{;QCSn @ `!;x:Y[(Ք5hhhS ?,#-LmlM\B_\,Lf6E-)y @jdci 46s6;l-L,i͙/3`jl7-?`dhw.K;cW 7WAN=l);8;Y:fUw..vk؛47vZ9\L=\ed 0tv1/pu3 hNN&6ab3to`hy,]Mma4v]301[o67S 򟝡[' AoJ}$7PB oWG+=2vw :b m-mcP^P "owqb+8׈^fgT?W?uL@VFgލ R_tvNbxblt|&7/觋Cs6Zd5w/WBǸ=TKo!CFx08$~ZI9Ui5F~t58Ktb/duJA,DIuFN %-h921~hʟ%z].P|@5C 9t|tLQZVa1Ooq8 •3VՋ-q=u2Wd,oȒ۶̈́1Ryd>)zm}:=blAKs'2PMZ@2q~)Fu#ʹ:tp;S~gY1 R'<FQ'mNk5<]X:f/Qb Fk3[" ?ܷ;}ܲ~%ՠ qoNZ(uhpؚsLM(67HFUQjƭsPyV7%ӈ髑0!l,aE +hpVGzrv@cz,TdRr=h"" ]kGX(c( Bo]>%)׼]ڱ8yXbyoX@_("1~/׀O= սm-z~wP,A%ٟ'IQIg7ejDf~z#5-R/S|6stܟmRAT2eClXIY$RQ&PJGXXZH5KUm[k6S\ìSx).qՂ?L̂δu( 2iG;2_Ffn9l0-.b}Ì`2zwU0Ws3ʂPYxbߞ CF9; QW:Mãh! ^Ɏ<'l5,D5.8Hxh-1נY6 r[MQȈQǁ(qTrHQHYE@ [P3,x*H"W!U";3|\ϡ6լYяI ${b/eS]أ XI4>`[Gs*~u, ݭѫAжWR> zpz: !ޫ,#ڑ1[Îh 10d)5WͬwMFi[/qa˔/5G&ļ&i)bW;Zܢ{U;qSD<0Uҁ'el5t{9WiXX?I䈟a/5j4~~H~Ka$!M~Mzje9q[ә qItHޟeH1LC5(zNo4r'%1|7I^$oSH6 O +ltZf$j)clZ,cKL?'yiᛧ ȴV{P?Dd=0ǟ8` a:<&05X=\0t+(L2((_WK"r؊AMj(v{Nn 1-UFo4κfliZs( y~Cvuu,"tWS P7ZXv!W 3Sߣd9};{5 M!(@L+ B̺w-3ï LpT&WQ--Rx]`фgOeh%QPuf>ЯA,KyPs-nQGF}8s= \8)7oDJ5<EOV{PQ K5q~9Cq^l+ qgYwV,EIxl kAOwFɳ4;l[3(Wu[@~ C QGF՞6F fK?:uan3ڴitҘ=WZ;(Qz8>7 _;~b\fa:{4/ h;!~`'ɓ/x훠\r\M3vlmHfCu4ybϑr̵(}߶W3:r䴟b~W,ȹ0zzrr7>0Wxw@x. gm}AeAhE0Ӆ6l#u{JMNdi;5dFCS@%OATF-+A% T7hASmkW1_xN$]9?k>ŷ$V_=-uW;&(xקyqޗ Y"GuR:*\&+5 Yb݈hϧS+_Sj>B brʏvMmLEsP)،.}jTtY{Mŋ?T,"\e6- K;48,(u&NexDS7C7=;;zT#)vߧ.U_dCDCQ蔄h0_:CS`u!gqһ"To^0ya fo#K5ĨX1\y(SdaC1w]L*i6l$sA cfo;o+FPSI\0W6oS{ ͐C}vtMd2\A*dV7ڞVL^0x9¹`g~ l;;PPv( 񬏴;<5+B6,]lNڤB/7eE#F*GO'5Y^ŗcDމXbEl0tvt!U$Oc}qGs@ZϺ`,3g/@botFBGy@o~*9KG?~7r{? %?es[8>=,/k f p"ӡ/ Qwy0[ډ?qCKo^QNb[Ųۨ, 0u1e;9o! L&4=/\ak M! <@ pP~ٷ6>4լC .C 2 $NO,3?%^YĎ "R |-:UY$s(Z)уQr΄q'M`JN'IHq>ly邏:aNٵB?(!u#mL`Ijv4F2<#22 ܵmv gqObƕ“e5)$%S8AA:҉bۃ\sT\V-R'i( ȘLDiy8;.ZUa3dJc/sާ3e{'hp סG]ΆhGܠ$Q'Ea. SӾ\+$aR/iA( `-[.~^Ĵ1,(/oV̎yͅhvo[qxhcVGZF V& 6)`%Z>q\h8iӫ/mfם~=(YМx=.1hN.p 'R_q@aS@W O2<` <"Έ캓_-כA<'GMD!q|ƣY2(qW_.}OS"ېHj_]6O Crdž?k]5AIwf^t莯wc:e  %Mɘ YHBQ G"cMMX{E >0kwr1ގNHNu2iX-G vEV'4XAh+>Nl]\eS XꋨX};,@j'(>؇A;g[w"e%YY>A³;]wTHE p1Mb0vRCC uChxt +L(#ڴiGpݹ }ʧlfLzSCwFZJ{B҄ bϏGoNxAef0V？aUDu\ѩ19^w~{"Ŧb|]O.qP$sԗ~]M]Xl]C6f~ ^ּ[||T/pO 7@Iu X cX<~:zۊnڒ{eStFS|u*;oѱķ,Ӟ\J*]eף9C8d">,Sw 8GBlD4Fn+Q6 eE$"yFR΃8Yap*PH$_܀xpa3SiN_)lݦV|66CUݬªzOn.xXK9YkM Y&&h.'C68!,̺v%;Q3lz@թ!F7{accR-q+i6P\c`ZuEa;&m])*D/L D|}&}~%VyץK!R/L SlhPi$A\'~lV=ePҍ`aNŽ0yb;zD3_vkŞ6h!Ёͭ[8m]X`2kKݫkD4@M'zXFD`o"d.C튻x-3,4̻66Aĥo]'qUqYQ%J~SCZ8hsB M &Oٓ+aw9HRZaP VՏAVWΝg=V.,h 60o?wE"ltA%lk;њz9n*RE:1b#fKW<9gkcV*). դ,9}n/$ۢ\'͐3j )+&|}=): t—$\-Z}Ǣ|.vd'0/pJ'οcxMeN,ʹՌ#L ` 2ZTUrM>pˡe7s2}򪍚`Gǂ7@h5W:k_ , &ȨE+Z$٤͘:Bz0WX'Cs unq S1C@=OJѮZAcAZjz3ߺqϪN\eO< "z'qYLM^_ =Iܒ#dbo.Ir~J3q֦CO'JSJ̲Y?GZ\VOB$`hBzjGzE^;2;u1a0,Kj)eŷ=[K"τY_,pu-6ĝR.03U"[$J(<Bm62yؙ.RRzV췳{nfn>ltMM5_`wBKՒ<"si#R7|ɇE`Hi!2]ΑD\!vrmQd5wqAܧk"3 ͲW{1~enMʧd3m.bM5Wi㺔gNYYEܴ.i5y.oNw1 rzb"eq9'rI(Iqy|^j\7lm0\[TxcJ\Fe= 27+DrȮ ?x֭T!ac){ KPuBW%2aseF3､zH0Md9`Mn2!ݤY]MdO0Xx ?hPt]@ /#…kO%)|ϐXRi!v{8d)/+R[Ӊ tT:']0 5ٹRq$^L=8lBf"ђ-`P߂ٻ*תӿF0]²̓癇dbgArNw|lD(~٢`νk1;UMC@dwgKcOdӈ`U -}MK]0ȜEv[vQViE,q,G҉5֜Iz'|Wj]| UÃqdݷg1>I*u_W} )#8*.MnqcmL)ǜwQ\t!/%g 2.)({Jttl$PYOWD-\`*~FI+YaU3\áw F}| fǚa̪IALQQ{ /4ugsLy& xF'Q#uo PEX2f >sc,w h5+g[nԂ9+E!I֠˸2!Bq- NDZ&>2CC&:I$Tt@53U/rJ?MMt*Vbߺ!\ .k,ԄK?;%ɒ>GRMu`8&Hy$-n8Hh_doSRqԽhK^' Lp+!`QB_7)*$֧VqKKfmvߩC-8y1Xg P2i~W0\PqՅ($Ude:]~B˝َ$%MŦIɗù9 ʿ?@rPe#:zPK~e r YMqMd͙^GamYXBmx6a@h m]V9A3^_*8ϜUzvq"})/403b[ m)ŝ⤈S In"G\<vkȇ.ӥor}«kZ9QczmіcʆpOCyYMvql>[bcM!5fP_5cQQCA^<#zvd8L[@RkD_0}ǽu Mp2%8?g7Ͷ탤 טr,n,"7$ik*ƈrp@UiV1/ M>Gyŷǐ.;=&͗р;!*}SN*zCV*:.5 ё۠R2$$=դ<aG֋dV&*tsL̠k` h<`0K8vQ@Eگ2LJCDv! h2qJ_ԹKG@ꨈ=dRYى#x-7+7pQ2~_WEI]3ié'KٮT)$m|Y#5qչƁi,n:qV-r +mc5B 8+&70W4Ɣ`ulGC! T:%*> %ԯWH ?LQ!l;}k5uu>2p> Ԥx*msT%xUľ;hd-BR[+˭L?¡CtH݇ׯ B;a:5WQT0[tCuTSȈ\WN>pӍfl:~nkIj)#șJ49BWkaebia T?nh"HHЀՁ":J^шf9y'0\[/]O,({TL*`YXVJk>vT`93-KfmlfukoX2DV)RYr.$hʵ}b$5&+1lR1ؙ !}.0d#/XUQSUŸyHRŒe:omh>d˦4:FV?jd.=Ӎc"j׳5"ddg*snv)[ G4>˩n?/z,k`2#p` j* ϒlCK@KqP$ bj/Q a?B7'i<oC:ކ&.04Q\h3u[۠2i6 c,xG"C{G)-Q@%ګfdk)aV k<6y:ezT@jOTԇm/xUzJKeQs6SSY}QM{5 霙+sQr*\m>+;&i{|UD" kgҥ+1rŷ/ ` Pe^ΖcrŶ7T) #1. Fp$B'~mGU'j)h(-Op$ZsyO* `/]?b>zHAuR-4k ܥ |W$؅8Zǐ txSm`EOd}sm$2sX5͉1eka6J9Ư4`9$joĀ?QǃxB4pAd2^#A͑=FUW_QUQ_y0)/g­!_7;Yyqk`y6V]&Ļ)3H†h1i~e+#/` 8hNֶoL;0GH&_篞[/@ q@mm.VV}zF$ xur!<6ᚇq_XFRElV3ZlG-=q,m8dEzYQ$yDw]b3gS)g0)6aWjBE}Y݄(^CL@XМ1)9ҝWy`j%NM8~7;KP&3I hC-IwVvEEAd46=6BpZnĦxmO|{{7Ip%KxLBINGi,(,'OD{ Vb*S#/A d`?YXiIGvA^l ԵjVϡ\Eze.>!yP E*k,F;HX'rs4ҩ-ƥy %w.Aa.VE9*qiU*'+~ K ]5C..gюq9!҄Lc@3\e0S$]_!AY2@Co aSG$|K(mI@uXczבcs9%Z֦1Zo1OYܐ[Z\\ljV;f@Bߘ5YN4c0x ^B8 9T5?E2ٖ aDϥי M+b3Cc&J>jx6Lh(%2kM, $_Eš}yPcOB,93dqKZۅ:є>hYh> M$߳c{P1 dvz7]w$Od BBZ ,M:搭^_Dx"S=Leŕ`!ہQ8^鍲(]вX;.cc@vA^}e u)ȼNڴ Z΍!Vĉ}^YjI'kT=M%9޷j=Ywz3_q#?*h ?-a~hs9++nZݝ ARKQN$^ּl۸c`tabw, \_DQHVclR?)9=9wΙ)vC uPVsrxJ഍+KJs)?ih  PAWBzq ]@w/;nLOV&ej""&H`H8-?3t .pz?F$登6ZcB@,f}TDu& /$AD?[הEX8,ڛ/de+0il< yP `nδBBțL= [9^ahgi`nT/6Y)\4@oD$:OySWZ!? Ac|Ux-|bcw5$<8q_*嶷m dreB Z@VG*)/r} Gzdr0TA9GmZfFo]d#3+8mYғ:{YUy٨19ֶw8D Ϯ]WǤy jR:Uw1ǬbF{LMA"c&uG@N:rJHٸ= }Lach 1OiFWs%~N6D65Du35t=})u*wnmu'_OKF^:~X\Wj.WT(B_-p>Z*1;nރ>:yF Tf(_G"LntPYiJ4kꢀ<<ZQlW|fxzlcX&1R'DA7OBlT-JD}%ƜKZesdz|vnzfU&xj5B#,7wAksn*/k,69,;oQEt3-!nR>8>AGSnH+}ڷ~>;`3_([-H͗LD l`(J":h_Es`c֛\N098Ra.o~mTUM }cls)esl-vtf,23%,䳁4iK ۱Fe$q-QaH؆5T+ͪaDi%H=Ѱ*h?!l2L4sE)T:&)q?- ×!!.@NQ 7,@= *_['?4h~C훞LBy=cMx׌6~n[`A;q4|x.PD{$Wӵ*l?Ai\$ƛ1CPJ?gI@O 44yg=en^.rb| 1odGn~iIu'nz_g#Dq亩1>˔3N _A|) Y;PsyX)%keI[Z>l?2VWHE\4Lq2GxlP ,6 ''?C,1B帲[*ޠmSp33T@noyLm0 'ds\(EL5\ebd!l ȒaΔgO縟:Q,N ָpҵBsMv&GSJ:Itar26m'=4Aa3 1hTE4כpD/89k o] &vAluZ?m0"MQ-{oK*ŘDZbf-m5y a{ʋ-DW_9+ok3 qSL}:*$u'bR=Eyzvմ#]> 7ԯXEoEev&ȮXY Z \U ֩\zdD!]9kmnEUeh`EJU`Km0ԗ?37KRd(e4oM#wlX(WoF U;vԍ;ם4F+ )Ag$bR2JV9/ p"kҥ _CaI12eur5&̽@JzP^2e򧾇a qd]T&-QK/Nܨ pHA0y+X3, MD:ę`-Tb/x* VnWcbbR׻Lݤ- ;$Nr.2HbNoyTD4يa[b4QV59zRPvҒ{FMG]7K$r)JՖm" \秋<`VNQ`H19/c8_HMd׽[<4c._#[JS٘_tD;)e+!_pmҥ(YWҫsNKkbhJ77{*jzjQrMvŹ_r bm \Eq*4x,EpC:GHǟˎo < uH7KA/Ԭmk WU*`8޹(VЯ{.u'QXΡZeܞ0d$wim>Qo(1; T*N331mSBhy(;t8)/۠]/1G2?U@@a,AߣE hh,$ςj:ݣa@~M)J ɱ'??cr 8\-iLGk|d,g#9! &nWl.2@gj2諥a7&_OC+ErK&?[])jxX%,OQ T}9i9ْVV v1T[0#K\Jr$842frEIjF U8SŀƼcd}u\}̠w-H|c3/9mh68lmTuu_ơ :N: >dp9Űvj:U佚 v#l؋^tS\{6le`J/sY4.B.hyi{YCY2vR6"Ϧ9& eAJRNGr¬ǞC|=˼ÕJ ~Zߔf9^ :wFa߸ĤYtqqkӀ8 5 /!ī!\.Wq:x}SE ڽ5o4RG>Yk`G9B'8tCGʖY450@ 'ek4#pdR.F $ujCVAi0Yd| 2_~A\!FoƦv *4 LD#_^_z%\yq\8ypW6ǩ-Nm`'}ql: )y|M^hGT ROE**ͣ݉:դ&|㤥,k-\PO^H$+,bܼ+lk/gǎrֱr8 _ j}H`x4Z#9QqlMV,#ZǍFsJ[^x<kʫZa63ͱ$`n⚇ip/&K ,> ĉ=?UTP*dIS&.F_a-㨑p~u'/n{ySFF.^b01`vs\5p>Il҅|d?pjh#b+Tmzw c8ChJ6G0SN{2-y~Y )b"#}˸ QU!Bu|*!hEGB>/%,5@A{޲u1h 19}pL">.jh#?|ۣ8^K5HgS&[f}Ff1*)k/9?e%#i31[Nw-2IF^ `+"ѹ:\e# Z/u[V2b "!J9LO` oIX*,{5hN8{h&}خC3h #1|j PE<}x+ Gnw`3ݭ[#;rkO4b;蔦Txkjj#E*2نPpQi}%'Ӱ*l(g8L5|2%4*,_=7C 7yAC2Zh 0[ pϱgE@<8M63&ᩐlKncSkV{ORQ4Zх%*pP3_I/Oc.֐2a,)@)J-7g;f2h7ԝHvԮ̻nP cT~(E'Ab,|ȧ'OKԜs D*i_>)58\véy)IoF@,p-*4J hA[4]u JP''LYdV-j>ޅOud 2|tgw9)(VlgJaxȝl?1-a L<eu+gA|PZ3 K`  N:GkL[-IM3EǑe1S"%MT{Mg'TaCʴr ՛YDB Sifjk, ǻ;CQe ,EOTvPeXL6 endstream endobj 5589 0 obj << /Length1 1647 /Length2 16847 /Length3 0 /Length 17710 /Filter /FlateDecode >> stream xڬce]%ݏaCїjz]KB5PEAsĠWq}(Ψv7W?uB@VFgލ R_t~AtL146:2w>pKMcrNid JhGn/5@UsZG8͹i͢fB(^Okzt /eFGfFSj*8%K楔ǽaE:~ʳR?ZbAΊHl_ a]@SE{"Ddܨ M0WB󥓰ryF!ciZGߴ2Z/j꼯ސT5KSkmC߉vVE:lH ;uR./{zlmm4@'[~Q2\ߨ ifj(l% \vENXɎE+`hQ%mX;0SqˢЅX}~FRڛFh{9|i= tܿ(R 0xϴ灎iZN{(#UˢmGEj|VeZh{'5J.tFDVӟyT,[{ ͽ!ˢƙuDD`;`Hf :OB󦪿NĚ^w۹ X#)Ś]߅!k H?VhG˶懸Urz2Ul+h6(1Ѷ{g_>D(&CϚcgp^jn5PR>K萎~ACd9pk^↱x^QX!ݩC=V!_"-![E JRԔ)A0 Iz?Ȱ(`/fb6xlS?)b ?ɺQe]̋h՜s.S1 nZ1whuɼVn=/1dMˣ- ߘjfi/Qtd4"(xWvjR/%$ϻ)Skܦbnʥ:@R؅|n~e{]ͭV]L=C> V)ARL4)bT~.-Y½H)ڑp~skPI'+"0H9+9r2F}KuxT>ajƒ5sIKfK uIh\ewqndrD=Ж*1t ň͓XNӧ5IނZ߷;Eot3ݻhr5C$)ũAxqDʺz:y/S( _}є n _[r\۶_0̽AE9KeV<C˧.2* q^⍽O;5GsJ3fM搀Lmnfi B tܗ,k_CmI*3k^Ϥ~ID@IƮ[z5B!hܗ)Rg2;ä0Iݡl!T;Rƾ|ms=..<1DKF4]OLlUfOIcy߰U n$M{^I,$OTY+b1MHdњ1rVf lw$ |%81ԄdYy ϰa{Bl4d;9L/G]q.@J G{; :?w:d1m`fhQ* YE8egXMIzcĶ dT>dDBHKߣ8Y k4&ugaTe`w;Dĩ]/'?op"{@޴:>u>@dsM294p, !8X=N,&<gǩtc +-JcASClt1v YwVyhU_bݒBy7AerGxzlQM(cz ?)COW(p(K=؝ ~C/?wSN^7L&ț]OD]Pbj%=D%ƿW(f=N^Ÿ4f:xz ηʃ]A7Fw-*50kCZe"U#XF e{&BP׏7;g~$ZP5r{7f ]]pDQ%Aq55Rt_[C_Y哦.El9$5-++8PAեA1fH59GEl7UO"k0m]"4ЎЦHpTRR-b& <+ٷݣR?c@Dzvap_J^+ Nh4e]qi D6- <0yc.[J-ԖSJJbI)~ q-xaF#34<@?~6$ƣswi>[s2wG/H (L&7|ߺ E|OIRVI`gڠv2t V-75{\1,E+Oow6| Vu_0>NU;:  \HV VC`Guڼ$i 2b9 cпЗ E%G!HtW%dDW190Nh'})92!4HeH?^o<ͻZd4xy.n,a<F.t Dt?F¡Q63xH1_=M>Wl7wN.xw ACP\[?{ v̠:gA3'>d^!46iB[4@P0"=D?Wݍ )!n>Ss^>:G0?ڑBcT'T} ~〸Nʮs+h5/5K^ϓ>{=zs9$x]ގnRV8EuRo2;7ςa !GAqSD2Ūv6@KB?ɉ5 U"klUc]bk!vUyn,ER((Hj oP-6, DߡrGl` :Fϙ*soS7fƶg7j_ʱPvgopaWsH1Hű>$Krݸ,Q5#uz5 էLRqG T{ރ'~c(+zPIFmVp&}磕ڭ%iC#8B| $hMO1n^[@3\f)[< \FFbH@ViaFb6t\ bLEhܖ{v?M1lj`50 ]y"' rfRulWڋ;m=xf+AMSP`&ɇ_6@\9O:kNAmk3˿Bu U!4}oL%VjN9#|.]C`3rw]Q~tH뭝CWk$6:Lڴ_t#E~.[KcJl+.t8i/F^h pPnG~J;{&q \&~-[pqO5Hǖh޽?aڣ#D5XD0OO@\x^*f5[T-)щo0v\0i3l ө@2Rۤ$?Q4GӾ'4(^KIQ|P$Z~0֜qcBz?c>ZpBϰDQnC w4˃cwJӗƩRW ^Z[ ~SA$`fӿ;兪A<`4DQuf;QD2s#=>CNi?豠!* M:eKSKwl,R*mRYSc'??5ug!0iGb˫EX"jϢO%Lw7X7-;]'0"ZMwWru!nA1WQsnk,|f<+IR>MPB-*f;i*[ )r T65fpvFU=GﲕV@B>.ޣqy1y"j@{Xv3[on3)jWGԕ Wf#$~TH/'EaVF"g K/ğ]fkeS{BӰK ځGj%0 s~'o3MΜG4'԰g4 GXEEoƽ0o獭T 1)MT]UZ74'FLY n^OqDJ:lͳoUQdJr]0}` qRo3"9 #dߜI⽁mCqkwb@*nGk#\_`e~@zFcW|ʮy J^GZ׉{ ,汆Q,"˦B{]BraJā`0oae<γgB[K)b V?˶A2`[h=.LCi&I%É^Zܛ-e"n7vչ!9ʳ|# ؼ=K0MTLh启2t(H  ]^xumlnZƟ&a;;l3;<3p g,/V`J.8"Ygxq/T.sӤ MtL4}FG=}1vjl5 !営+N"aOtA &\ EhWes{7<| և?jOfgxMx 0)(rvRw*RQ'&T[ *]IRh.SX/ʸzY_% Nk\IS ?Ys_n c~¦>m ~j2Dnh9be.4ӱ/ |%,S2g$/*y=]hKM٨9nl"xGe2*}: "=P|LxX;.лe:ODn"PS:4lBj6fƷP_á#] HkFM m9#(r%'W{ŭfS]7Ѥ#WdHe#1U_m|)) U&AvQ$кe8 ؒ ~yEEr{Gc<115E6(M'{s:iVAlQ˅aǣH?JGn{9b+fqn:@amH'T[m6_%g)W?xx9th-XafwDY9 x!R{^=~%9Jg) ԓH.'N߱A{:$#р)iZ-ʰijxLLAx #x8YMEJ8N@K ap7&n1=] 3v^ X^-K`Sm N;H$Ab'7liB-`/ŰLZ *?LN[HIKޠzCH u#'*НռM"ZdiJϦ84ly`8ADarքFnq%}^Eئ#lɂ ,EWNi=g/!@oQ֤[W X/NۯR{i' zf?_c5Guխ /[YmuQVH/ TZ<1]kmk<"{ODZT{ z1ilIf[:oSw!Ժ gZ@OR6~߽r"=PPV1Փ H쵁D= ڥЧ!]j?=R6(VYkY s/=pyCQ?^&io{̉9WPҔM^Qj(Q/*l~[s`o.!lwqg_Mb nv˦үXGv !7qHDs2Y3,xVc=I`9Moq&rz.ςnH1允!!n/ C槚eq];ZTy<֊6i JWjhޯRSÙq C%pTn&+E NV9 /.˜59>#)b+;u .b4[iØ<:sD|g o!~ r3Nr|>K\pܝoTd\ﳠ [NwN$0־}ldbֱQZ)|Ar`#W,r ܋drJzgLEP7{Xgj=Js_*[5+R#p!sD+׮xzޤ0B@X$0 *e98R=p4]s5f?Q69qa;ÿ>gPg`ɓfJo a1Z]}'&D,8RhY k@]6𫃁-HK>߶g8xtH:5EHqֿJe 91V<94K_΋8;ݸL%QJ}zS ^?ÆReҒ$|l[@q2'Q򵧿XtDZ?RLzg% |#t }}2x}J 甓?YM"L1~\+MЮ2 E'Y@COK85 4g4c2R]T0Ajgꜻ%eWPemj]U s0D}Mu0Nq#5Duq9I㋎-гqАU #F ?$.3#,=|}$.er~S[*Zا!(fup9]"!)Ҿ>=]k޹igւy̯O, SkLv2%#*N$aCí؅ؒɘg2U͵XrPC*MV%(6!NA0=BԸ#UOG|~b1!Oo YMHS 6$YYGƄOn{tfB5)- {*ÏK\ng `Š{]}p z'];1O#Q?1[!,}u K9Z|g F;ڗՅWeVFOAw`]IB7E I-vpqOg$e2$^e ^g&dњta`;+=n~ZbꍜY忛66J.b>̧^k*{s+CNnje,i?Y3aH C\bz#5˻ # Zt&w{m5}Rfsvrczb/Y`FB@Me%$ArтےK^`AweO8TiVw;Nf{h{Tw0 ]y*׳egOV|V=3.;\#u9# gِGrq2W ,ߙۀ)ڗ%ĽqJa6 dĚ93h'Cf|y-t*#胭ЧlV/rn,[9kTc -1W/9gP%0/#<H5)l%H_ŏ5z% WdWJs gj1 zl]%y$?H&%ޱ;y_hR yʕ]Nnxk fCD~FM(qFhRsf_5\튧D)!(Xw?]ͭ(r![໔3pjF1=]$i Z{%^a{,|؝̽LP\vy[~P vcm,So_q70`ʰ}uv,:jLo?S#̠/wf?*O-G]`mA.^Kl9M'^îݿxt* h ! _ Dd"d%k % mkE!+NğvjL~k(uy4upgK[nL j? i.JDHXԭtP|_ |K<ɂ @ r! 2З,M}* L"mrT6w9UIi߄}۴2MgYi2@xUeBw{p_-C:@)H/q#05{JqhyxYQxSHM:ae0ҋ%y 8׋[ ykv|Y%TwyM59v=n4ߧl`$H ?28fḒ(R`L?@'M`p,«Iݍ bg )(hl@ʫ#< _b-VUaQH %_\&nsU6fkRRnH> Ad#;u4f`,Ke#b&h;KawuC!C!03ׇ< :uddDeOt_ +CJ_=|Ɣߗw-(pŊGH.v7[e kP߂̧r^yax;?+ۓE-SS =$g?%p~3joblS:M}T;3븯#>6+~H2_hKh1X*GeIN9_C  `'=|tI5^|]WfygXU{=7b)W?>0Y_ڵ ]=q1VH] TTtS,bBy5znֽ:R}.gGҊhЮė:=fޖ/Slqėϳ\B\v&vbp-džH%e彚0^~ln j5?Cʁ1 ;砎Ex1Jz[K%>56N H>À3!Fu*#Z=)>!wz,uxǀLaۛw>Da.";Y,3y "U"2X8Rt9fB)vgkԝ-ɚ, >'ʒ lD,xFaUL{CP g3 5P _h\W*DD΅.[6D0"4|Ex64_M/4JhZ'L e} s8juLsT`="wg]t:\.ρ",2N_2QȷV'N~ɾn=8tFb_ _ZكcGvn4'cW9pkݫVv8@,qt!k\1,X&&2Rcae]w>1 B~,4{٩O7vE0~-xt%C:0YS܍Ň+dy׋ ,`-W|`6k B⫀^S|"i:e>C.G(8UG-[nvu@EBRaK %.M3*a9*;x][E5+-pBAxE 1Zt4$1l; ]DEDo|b |~ho~CC;e 1% s7mg`魢E.Msu߼Mqmdlf~4Ti"-"ܖEF/7 etz"qgh=5ؓSx6Dqv+wП]Gw^OlcqZ|1\Yn0Ҙv2A AA\4'LGb>6:Q>FV3/g:Q$sUosCXMt]۴ne^" k.l! 9`; ́!i?i5(~TbRż'F;a4z @tƚw$T&UU `]{Svda}7Vf\+Z*v.-/g*# EZ!:koHO!JӳzBl{%Dss*Ŗˬ4'# od/l8Ea}.'_E3OֶsޙVI+)6OZUrn [*C_Oxa&#QJ]Մ1PZU#Nd@ƀ92~@1ΊG>?1OJH8ؾd.y56U%hU SD#aݿOd DC7d`i) 9_Oq텸jFRo]Ci4J{5 HM۾&:0yxb]@Kx\G'F:6 ?s7omVU9cPv[68t $(+2.gǝF> Fۘ è \sId F )8eH(XrڼغƪūhiL ]X aj[@=V@gx+d̗^ #A1WV3P ʇW$v\6L]2Ο1 )N#,sUtE*a]~Q{`qjVVK]"wS&]^Y~R8w6&hMߏ}QUdDVmaEPy_E ](Z(%wZ8FllM?+( bX;@ǥ˲-}=l1#~4w\Q$=/d Cc/jLuRKT u-qwNs#m*ߪW%#"B4M * jEY0r=Cn7y*TQOCo(%ď? .Y{`yHXM%× gTYqY4K#=pkM~|D1^(ZBKq݂[.g bP MC+0^Y՘zJW%̮0;ٺ $Mdv9p@du<gy˅BDퟨQF ߬saNJTukw,E3%/Qc:ADŅhc;ZC tj\Ҋ~㫝3pnrߥEXw+\@cXdR01JDrgϜDfdY ŸH둨@VD]Ge>@sKHcА2]n?/Sč,.gPHw()7ՌAtBE|8*jDckUD\v[f-R.K}Zҍw{|H1AFlyub9uĽ[M)^Y8Le:0%Ԑ{qV1nfzbls]i $ 8r9٨l^IDq]YxȟU˺G *{L%P0 jdD:~5R@Sһu1 ߍ %j`ED1<=ċٗѝOeoș $P3v oM8ttʫ$>B4KA_tk]"j7@MC&~a,lL]n|=QOj,A{BY+TbEpK6dARbgYS[œJQ} F(hgd"*pQH)"*#tPEgOGK Ff 6BDjy-Ph qP8o> MqJ#,*&[~r\wsJ-HLHȑҮ!az.sͱǣ>p1 勷Fl`p4g|4AoYӯpD5u=0 ts7<&2xLjT 2<̢eOA~ךHaH\4$cVs2h y#)} jE68g>ƴ(cs^;=T/2 M@xB٭FXMhOd'f -Kڝ\ٵ2R|N3Y6x`pGIX/&).T1m,*wbgL7t(޴:jYiܪk/5):fKzƠ<ub[ a鲑AVa[rPlԞ9 |2(9 ӏ;$ $*k¤^Z:N=g,dVmw, t$ޅ[^`XD4oGD@Sx]4^pcL8ZR;"Qq4S(qg.Ӵn.e6osaYFvQ=flr5(M5xI2f5 z^K_o^Zg? W:|n{1&_tAKv{m!T}wmѦQ<:G xʁƣޤS3" PlZbtKsIT@ro;B{WJ:ũ{u$zk endstream endobj 5591 0 obj << /Length 901 /Filter /FlateDecode >> stream xmUn8+|H<0 3Iث-1Yl!nYUlvW?g?|W<.Sg͟c>1ӡ{gK1g4K@`B5 |4FXgM52k`F5M};ZNg;] BH^RSRG(. P'߀2HDh$l[ĹZcLa̡D#X ^ptגu{5s(@5[S[ nz17C}^<{SJI k%b2qȢT2yF ng0a+™51ȩ8_ _Y*v58[>/q n:Է:i/rߖ5WZ]}uWZipp% xɱu9c-\ܚcg:|CUd2Wf{ :?PfY>#r玧ntiJO WRxҎ#v_?6ſ@ endstream endobj 5592 0 obj << /Length 741 /Filter /FlateDecode >> stream xmUMo0WxvHB!qmU^!1H__myݷDULG^͹t߷.k4c*S'ҵ>]g,yݔKeF$mS3&qGRp`I_3[dE4ݹn'&9綐7UaL)l:M z!YU0rўo>ν9},lj'}4>2]ݼ[ivjs92V+Vh ~y8&X-MmM|ŖE LS7Њ~& U 2X(pm XX(W8X&LR4=zukTGEm7h8Kc`Iu(!a <#G >n-tJ!]O2`̏S#',<ؓL%qO8\π: 3ht ,+9ugCwËpD|ORɉ#ɇW m藒1NwH=8! 4DCp&q"pBCT/9!ɨ~B }Rq҉TFIܨύ|nTs|neEA;~<6OIystg>O:yұϓN|I/|yI>O:yҹϓ.|R T<띹_mKz}K=W7"V{/@̪X endstream endobj 5593 0 obj << /Length 741 /Filter /FlateDecode >> stream xmUMo0WxvHB!qmU^!1H__myݷDULG^͹t߷.k4c*S'ҵ>]g,yݔKeF$mS3&q'. 45vScnOӝybsn ySt}T -Uu#]a`ܛٷrɦvwNC0}*;Qfg6``bۆѰWaҍ*ʜOtKWlY4s Gjb|PE`)Ce0j*m!,,`qʼnre$E#.CZ\wF|TTvv.<T39pD;p3B$qƩ/088?rxy!B=X y82VAנp"Zqx8t9MD/W)u8|}ۆ~)30|SRHCO4Dg''/4DBϘ''!.'8O%|nQύܨF>7*QFQVg>O*͓*nm'-?I>Oz#'OyJS:ޙ_:&Wt}c:> stream xmUMo0WxvHB!qmU^!1H__myݷDULG^͹t߷.k4c*S'ҵ>]g,yݔKeF$mS3&qg1]C_7[,ifkܒ;m#J#<頃MGeA AZ $F<ǹ7uoM_>‡`Uwvl.@j* ۣaӯ ^)o'ä RU9ͻ ز(ViZۏR_VRn-`2TBXXQ`  IF\Bbu <\`Gc)y ,<$gsv1ag٭N)I&S?^`qq5 B{ $.  SqdAEBu4$OOB:]*N:qJ(sB5Qύ}nTsύ(Qw|T~'UIO:y҉ϓ<ϓV>OZO:y҅S}RJtv3wtMxG^y: =tx\S{*qs$ endstream endobj 5595 0 obj << /Length 494 /Filter /FlateDecode >> stream xmMo0 !Rz|P!$)m&Zؓ)d@xHrz<L~B5Gg>k#_>d"9ԠW^ػiz6]oVWo nǢ+-{toWWj1JFsnM3t^0`٩ʌfyaT%䞲/w׮zOe,ɮ7W ތS3pf3m/.)8نvC ,x4]"wɕltA93x92@rc4JJ>x\\-ߵ`,v]Un9t\Α#oc 1G9K %q yEZGȂX oB5<ǻrQk9p8NяcQ{ 1z3zӮϜI]-|ĭVӭ.D᾽mbVzo endstream endobj 5596 0 obj << /Length 696 /Filter /FlateDecode >> stream xmTMo0Wx$ ! 8l[jWHL7IPV=M̼ su;Uٛ=w]yil;<[[j<=?׾+v`&ߴț<^*;~&Q>MS >_P{=s@dkx;`VY`s4JaQܡn.Uu9\Y6><ٴ.Z.4>Dӗ}~r:-d0VWk,8yLһʮӮђ[*mLr?q 5F8@=@)& 8Rx uD\j2HV0CzL] bctI g$`htы0\F0s jd< I6zg W qȐ+#k .bsrbmXK7ǵH7Gnb>&jؐu1VljOu$՟qWS/%1{\xB!K(hHTЖ枃Jρϯv=k2UKς_:~$/ ~E+7ˢ/ l(/} -+ZXukoԝE?ZKq endstream endobj 5597 0 obj << /Length 696 /Filter /FlateDecode >> stream xmTMo0Wx$ ! 8l[jWHL7IPV=M̼ su;Uٛ=w]yil;<[[j<=?׾+v`&ߴț<^*;~&Q>MS 9_P{=s@dkx;`VY`s4JaQܡn.Uu9\Y6><ٴ.Z.4>Dӗ}~r:-d0VWk,8yLһʮӮђ[*mLr?q 5F8@=@)& 8Rx uD\j2HV0CzL] bctI g$`htы0\F0s jd< I6zg W qȐ+#k .bsrbmXK7ǵH7Gnb>&jؐu1VljOu$՟qWS/%1{\xB!K(hHTЖ枃Jρϯv=k2UKς_:~$/ ~E+7ˢ/ l(/} -+ZXukoԝE?ZK endstream endobj 5598 0 obj << /Length 695 /Filter /FlateDecode >> stream xmTMo0Wx$ ! 8l[jWHL7IPV=M̼ su;Uٛ=w]yil;<[[j<=?׾+v`&ߴț<^*;~&Q>MS'>u;q~:fc_0F)lGιmu f8Gӫ6b"!YUe.`M{My?IC4}+̝l/Bj*{pϻƲO('$ *{>J-9_eQ"V$)MP:^9 ^` br @ {@(\,RH&ti m+3ԅ ,;F$БzFFieD(0A1a8yΠFpnù[w6p@ )9r9b_ia|F-(:(nQHY^`nA|n(戥K}s\}sԑoA&vqc⠦ YK^ʛ!_my_)=^ ^{TGRw1RDž'xJzImi9j'pͽܳ/-_Z,N_: ~iyY2q,nЪ5QN Y58.] endstream endobj 5599 0 obj << /Length 695 /Filter /FlateDecode >> stream xmTMo0Wx$ ! 8l[jWHL7IPV=M̼ su;Uٛ=w]yil;<[[j<=?׾+v`&ߴț<^*;~&Q>MS>u;q~:fc_0F)lGιmu f8Gӫ6b"!YUe.`M{My?IC4}+̝l/Bj*{pϻƲO('$ *{>J-9_eQ"V$)MP:^9 ^` br @ {@(\,RH&ti m+3ԅ ,;F$БzFFieD(0A1a8yΠFpnù[w6p@ )9r9b_ia|F-(:(nQHY^`nA|n(戥K}s\}sԑoA&vqc⠦ YK^ʛ!_my_)=^ ^{TGRw1RDž'xJzImi9j'pͽܳ/-_Z,N_: ~iyY2q,nЪ5QN Y58.] endstream endobj 5600 0 obj << /Length 695 /Filter /FlateDecode >> stream xmTMo0Wx@HJ+$|(C V&of=؉z͞K_I{EwwY[\j ֖OOo}ͶM5<8)NҎI~TM'E]WRpp߫8?3/??Wm#L3UʎUSW1iFϢvy9jŦo> stream xmUMo0WxvHUdCmU^!1H#x?gx]OTm$|͜s_Iss :L;<Sz==׾f`*_`ɫڟk3'iѴ}=M;7rfnj-eSӵOLg~8 )ok A8 $`I\3`Af<Z]! xNky"7 _㓧q H`nḱRONH=CpB:# =%888QA~!*zƜАT?!~> tw8y*sύ }nFE>7*QύR>7G];~<6OIyktg>O:yұϓN|I/|yIg>O:y҅ϓ.}2 L> stream xmUMo0WxvHUdCmU^!1H#x?gx]OTm$|͜s_Iss :L;<Sz==׾f`*_`ɫڟk3'iѴ}=M;7rfnj-eSӵOLg~8 )ok A8 $`I\3`Af<Z]! xNky"7 _㓧q H`nḱRONH=CpB:# =%888QA~!*zƜАT?!~> tw8y*sύ }nFE>7*QύR>7G];~<6OIyktg>O:yұϓN|I/|yIg>O:y҅ϓ.}2 L> stream xmUMo0WxvHUdC۪TBb A!Gp?gxYOTm$|՜s_Iss :L;268{zb/}WUjWm?fd}Oi=7gRx=7i'Էf[7̖s ~ts[(:0p l:5m_-tB}W{X8 jw]lj'OC=6}Ӿ|< D0,6;96ݕq4L MUWqS~Ӿ |Ҳ\Khv7RKs|*Z -1 b[d08A  i$C#.CZ\wF|TT<\`Gc)y ,<$g v1a粳[ RHדL1>g~8 䔷5 B{ $.  3qdAEBu7js"ܨF)EYQУ.?yRmTy'oOz>OZOyʄS&}/6>zչ{ZkZs}=?Fey endstream endobj 5604 0 obj << /Length 740 /Filter /FlateDecode >> stream xmUMo0WxvH UdC۪TBb B8߯{ .@=/ۙڽs{K;K.k6/k+[M'ҷ>dyӔKe'$cS`vfSfK}fƁVGGf\bu<19w|擬CTAW $rG]IyMsh$aW7y̟u? sK-`θtJ!'c83?NaO<Dg!;IX 0z)rЃ@kpBQ]^Z7! / U <ɉ#W m/%]cX! gȀhID8QN~ACT/sQQRs 穅ύ>7: F+}n4eE=zG~<6OɈy2kLd>O&y2ϓQ>OfdV>OF<dR'<>O)yJS*}𗏿tx>z{O->tՍ]*3>cC~ endstream endobj 5605 0 obj << /Length 739 /Filter /FlateDecode >> stream xmUMo0WxvHUdC۪TBb A!Gp?gxYOTm$|՜s_Iss :L;268{zb/}WUjWm?fd}Oi=7gRd{nCN8oͰof-%6'&9Pu`L/"tkں(a[ duS $xqa MN{}m}gىx` tw8y*sύ }nFE>7*QύR>7G];~<6OIyktg>O:yұϓN|I/|yIg>O:y҅ϓ.}2 L> stream xmUMo0WxvHUdC۪TBb A!Gp?gxYOTm$|՜s_Iss :L;268{zb/}WUjWm?fd}Oi=7gRd{nCN8oͰof-%6'&9Pu`L/"tkں(a[ duS $xqa MN{}m}gىx` tw8y*sύ }nFE>7*QύR>7G];~<6OIyktg>O:yұϓN|I/|yIg>O:y҅ϓ.}2 L> stream xmUMo:W5?$R. d9M eCkmCp;;w~>|3E_?O]5߶w]Occ]=~?}Oyh9%?۹׬B|Ɯ>);vw%g43>\ 6 EJ78 1{~`W(-;]%=xe_,b+-O;q\L}UI--=BKE1p[! Mߊyu>.N5K)Wb٬8i[_uʕMzQ)V(Txޢjy!Z2P="Zd0\ÃGR\).2*Шa!U,H`+j.5Nα@VK-x%3%AYӀzΚ>kP#5m0Woþj.ZT$X/)n)#Wo(oRZ $Kp4Z-b\1ܰJ P"GXQi/8k^Zq:Zs9dB )sL-7xJ`aɽ)f$1 dъcCZC<73JgznHȰYɚTa,_-O87}KԴܗLloK+gJ.GZyVc48Wt]:P~`rZq.n1] S/Pu7Ue:?&?!d&1yHn5)yғBx#1ޞ]Go׏M?X endstream endobj 5608 0 obj << /Length 898 /Filter /FlateDecode >> stream xmUMo:W5?$R. d9M eCkmCp;;w~>|3E_?O]5߶w]Occ]=~?}Oyh9%?۹׬B|Ɯ>);vj|N8}No)e0&h?q:P_ X}ac1+a  jҢ~]ߏ{_r)4i_px`!dZ>i]<U_cr%ͪcךv[\٤ժX*be-@E-X@-꩖xkM PY@ ,#bEA 5rEqIb>,彐A$ G#e"&c D`%rE*s(Ǩ5ثCI*=ǔ^pk+ ܛbVLbX+@8:13Jp3<|6 ^ΜANVjRy9cpסAM}Ė)|֪,+pp70h8J+NK}Eլk)5t7Og:|CUd2Wf{ :?PfY6#r率ltiJ/ VRx{vw_?6F endstream endobj 5609 0 obj << /Length 900 /Filter /FlateDecode >> stream xmUMo:W5?$R. d9M eCkmCp;;w~>|3E_?O]5߶w]Occ]=~?}Oyh9%?۹׬B|Ɯ>);vw;{>oaI> ѲH8U/RǾ0ñ_x0ӅxBiE.͏S=/b_ixމbc4fi|8EXD_R4.GRQhV̪xvqڎXJfUıkM;rͭSlҏ֋jU,N2@ ",   T[<5 1"àcvG@mg K | +T|5flxZ1YP^ꠦdb}[ה_Q>kUbw88]k|'%Ǿjց{ g䈏rsqk:n87xIue.Aft0!?4ɳ4mFtӔ^z1?z .~l-qG endstream endobj 5610 0 obj << /Length 900 /Filter /FlateDecode >> stream xmUMo:W5?$R. d9M eCkmCp;;w~>|3E_?O]5߶w]Occ]=~?}Oyh9%?۹׬B|Ɯ>);vw7{>oaI> ѲH8U/RǾ0ñ_x0ӅxBiE.͏S=/b_ixމbc4fi|8EXD_R4.GRQhV̪xvqڎXJfUıkM;rͭSlҏ֋jU,N2@ ",   T[<5 1"àcvG@mg K | +T|5flxZ1YP^ꠦdb}[ה_Q>kUbw88]k|'%Ǿjց{ g䈏rsqk:n87xIue.Aft0!?4ɳ4mFtӔ^z1?z .~lP}L endstream endobj 5611 0 obj << /Length 900 /Filter /FlateDecode >> stream xmUMo:W5?$R. d9M eCkmCp;;w~>|3E_?O]5߶w]Occ]=~?}Oyh9%?۹׬B|Ɯ>);vz|N8}No)e0&h?q:P_ X}ac1+a  jҢ~]ߏ{_r)4i_px`!dZ>i]<U_cr%ͪcךv[\٤ժX*be-@E-X@-꩖xkM PY@ ,#bEA 5rEqIb>,彐A$ G#e"&c D`%rE*s(Ǩ5ثCI*=ǔ^pk+ ܛbVLbX+@8:13Jp3<|6 ^ΜANVjRy9cpסAM}Ė)|֪,+pp70h8J+NK}Eլk)up >o U^g{_e{]*?`CBhgiیtV;۳ѝ)(ZK7bA;E^]|sQ endstream endobj 5612 0 obj << /Length 900 /Filter /FlateDecode >> stream xmUMo:W5?$R. d9M eCkmCp;;w~>|3E_?O]5߶w]Occ]=~?}Oyh9%?۹׬B|Ɯ>);v:U0 @w- PX+QGkW3 TU(1{)/Y)p3W537Ŭ4İV2 &W,ZqLuH+c(gfxFIl^  "9+/Y5P՘kWrifC}{-m)^S~EUYWH+o`^w qW򝀗.Y1#>RN1ŭ9|<%&ߗ6߻_gTd2?d7&Ҕӭ?w> stream xmUMo0Wx$*B!qض*jn$H$3Ch<~3~~~ngjv9{C{K;K.k6㳵ችm#O7٦4\ =؏8ݿ߳4\Ǻqaf.nr K~~扉GιKM'0 6/dB. ]o?ў6͡ 0!0s;s-`1* wVPơo}[~3#ȯ>3,L}f"3{Yy}fIL}fr3Sx,g>K7Éf4,}%a0^tvP? ^/®7 endstream endobj 5614 0 obj << /Length 672 /Filter /FlateDecode >> stream xmTn0C6*drضj^pHA@Cfy'n`g#govh/}eg羋򶺜m=Ooٽ[׌uRۉ=Iۏw{Vq5;\ظ{32bƱ)`Pk IckgUPSH@"7#?d 9aFm-P!.@'1 c09SGTX3 qxryB4 AAN8pЏ}% Jxxm_p?0䗒䗊/ TB~RtА3~N>|T%9%cQ/G:%uF>%WV6G]$ ' $ML/?mwTkW XֵdpZRF# endstream endobj 5615 0 obj << /Length 833 /Filter /FlateDecode >> stream xmUMo0Wx8T·~h[ ۍT~3r#_)9۞c$_{t]P܂~ݣP_(&w(R|vp#P)->g_B?q8SG AC۽[ia߿{2ZE_cf/1/{/4G+)bUUwkuTO4[@ 0@`%! #P .w)úp%KcJe Rͤ(*1:bDDR@ ȓ2UR*N)KIΡԀ0CS,km:5Bͦ&[Y{Ł@꒩)NMvSpJs}irphS ᐙ2L9ΙV}yXi8'z Ԛxq1GyלNZ1fXt:s0>wpVR.խr)>1qҾKvHX1iS5rM yR6FBlH>]6b 5&5&0a'evb_dfQTtQ]zK/WБ^Zz&孯ӷrW.&_rUOz䢓n9)C]!􁠧r7dE?_;~T?m endstream endobj 5616 0 obj << /Length 664 /Filter /FlateDecode >> stream xmTMo0WxNB+8l[+ML7RI";onDo3ތ?n~<&yݽIr/ŋ=wWIG77eW]Nm=ij몝m-m3Q/oMq'}vIֿ/ ˺sӵBK)ɱn;A9n1vAxHŢn!XN4$>΃=mc-bB}hjM^Uwww BF˥푊QM]1ʫڞCeݡ}BʥXl6ȶ5R^clFrJՒk ;%9& }8K|y091x&GϹPT#Z%)&!lRvDr䨑\#G|bǚHUʸ4'22| ^Dm=^sS<cLUي_3;S}Ш2?}LN=8g,u..Q/)87l _??q Zqб<4 4谡Цg~ѧ,I 4sY^y?4hv5O#ܵy7S4 &*s0P.9S0׬p~ne8|p\ouqn6|kq_^~& am endstream endobj 5617 0 obj << /Length 665 /Filter /FlateDecode >> stream xmTMk0WhFG*! miʲVZCcYy#9햅ļ{3񸟤e&Oo]&C]]Mq>zwt߉Ǯ)n.pCx?nڽVgx=itO"i [\l\WM}'ԭ̚t4pXeȉeU oq yM\-CnCW_Ey}wP dZz891euB)] W-\v\]~[S!8&+Zce"'2Ɍ5I@|"B2AQhSlLء28a}ɑFq5ҍnnbfǮCG= Wܢe$g;A,:sx l=NOTƘ$0_س/vЧQ%~Zx pX2]$^qnaK??q FqMyc0=) &l(mi,3|d &\c ]͹&ӈ9w{d-tx\ \cΜekqLJs?<@>qhx .׷8wl~1V<*m"mmDa endstream endobj 5618 0 obj << /Length 664 /Filter /FlateDecode >> stream xmTMo0WxvB+8l[jWHL7RI;onDo3ތ?n~<&Y$ŝK_IsE77E[^N\5sߖ;7|[lzmS_*7F?h3΃;mc-bB`ew\_7oK׽;(2Z.ETz}ܟ~o9V^MVK7-\f\S}[S!pcSs|TXo1/ȡ aeuC> stream xmTMo0WxvB+8l[+ML7RI;onDo3ތ?n~<&YվI|/ŋ;t硋nn\3<:Wj\=?-wn6pGۦ|Tnʽgxté7~qzxKlqrnX7UޞMjuSAxHiQ,'wͱ 1}hW7q{UEݥ-rG*F>NNL7u]tNhWS;wE )b,#TTHy=)9>*QKr7P:MȡQ^s$LD6aȑ*s.$S56`>ƄmÁ#TL 5kd}WXssc*zRh/#? bE$L|ږ8^y>eSQc̯bV̯cNa'_OAJ195kd3EH@8ܰ%~As*=F 0`{RLPh33Y$LƹǬ oqMsȼ tx\ \cΜ-eksL ?"@>qhx ׷=l~1֍>*]!MBa endstream endobj 5620 0 obj << /Length 665 /Filter /FlateDecode >> stream xmTn0C6U@"mTt@;olvR3ތm~<&YվI|+œ;t羋<]3;Wj|{}[ mmᆂMv{Kt=c_~B?zxoBS6wBJ)X7UaMuSxHiQV,4$O;nC-bD/OCnC_n^ѻs׽9X2Z.ET~{~ʶrn_~߼h!R,6ew*ؔb%k e+Kӄ$a"1x*s.$S56P>Ƅm„A Fs 5577vرϾ+uaя6R:!,əCxg+ѧy*JcL|*m:fvuiWUꧏɩ\g%<Ϛ"sÖ0_:3x0kjhyIYx0aCnOg3$cx0<<v5O#ܵu7A 6*sZ ZcΜ-ܠeYksL ?"@>qh|tngk;dGGM@c endstream endobj 5536 0 obj << /Type /ObjStm /N 100 /First 1025 /Length 4089 /Filter /FlateDecode >> stream xڵ[r8+x-bb"mZчrju-n|d`w",ȗHJh  &h,R0t¸`X @Iф5O8Uؘ Z@IC*(|Nӄ;]hf=->u"%'961)/DjezK `KХP桤-&)hb4`c gйZp2.Z p1xqJoYR8KГURt1Zd$">F._0h~pXǢ|T31̀Bp^MC`)Gs n !3Vq\ >QaBޓfIk?Ŗ,\ g$uI@IePM *wxW2B,jppʒ@\)hK G1A#X lP%Z ^HJˁ؂Fk߂P.m؂3 `? @\w"9R ,C 1**ʰK5 Ri H ְ|J`4X)Z퐛ӄgt9ZWŎNᗣ'w\p2|\&2l>sWm9}ٖWϡU*wUXk1_Vd7Yj ӗUɗ/_?߂//Nw&hP mlh.hyPE:\ 2I"0ɺ;vt`,>jWB#9pzr3ab[#?o`0hd$d5{"c)y[YM.ooofw}<9IɲY^Oul 7^|'O|7O Ll?#GmI.^|>b<4YN'O8G|Iٮ7I c'|'k,N87]̋T'Y:8>>TM"*}P2N uҶ)Bj8-] c Fs`a#l)l<7G%8 n) z+)%,Hvr~XleF`ѯpǶ`u_."}6kWcPpG4@zO3:ZmyN_j;I_MʍH~0jOpnYQFLUm |:T-4X:ܽl;T`Ƴӝtp08V6 LVdL3`t=Y'edىڔ² οkA:#dL8@OHKx;ۤ*W=a8\,Atsۆ&;矏Ͽy-;׼\܀X16דI"t>WOR<=fߡTE7Ɯ͇ǣNw{qtv {sD&{to%@d4!<0V8SAgXs?WaI>|b4ߕqb&u)fn i0kGx]INOΎ~Ounp&mqrӯ*lȓP&LM,Oȩ_t_@$ [ra=ZR2]gd1:^+W&愐Ƌz0I_bv-aQ &)yȥ%OV3zL?"=_I0ö3$“~ \4EkC"%?_asfN3Wa; .RX +lI˭0ѴͭEfs1d֊$w'z>݋~܀]dWHiy{^ڋosRaXmѨ4 L0G~ hȍl +1PFvqȝ/ge'Y?d  Li0\h9^n0 Dhd+iUYWE?] j{?xA5[)>|SaH&ᦉMVf. /s ('jCye'(lð7-kCY4ѾϥPF{DfCg6Joܣ$sVDЀ/"sfiglxH sZ !BDWZdž 2=G bW.|ړ4XIcEŗL]I##yn(XȢ'EGa/v%―F0gY2kCLWZF/i6aBi2 0BW.$a&a֯+HxM!JOt%b@ c?DB!┚DWRg=Dj+iTVWZrFZ,UEh뿀LX]ώaz3ohlj'߿/m}PG NgJSz`)3ꈌL: Åcl2f?IhZZ&63$ᘹ'> stream x}Y˪%Gܟz 2`E0[uruH!)BUqN]#夵VNZZbR$u$  bpPRi*Ky%y)*I%ʸ$(#34dM2s"dT '^;R\3b:$Zg "x̏&΂q0ZR1Vfd퉅PK\q`EA` 0!Н \fp5kyIf1rЋ1ln1f~'wP 1L(Sԩ&T1V Pm@zu4K.49Nc2׆FzAłZ/ S"S=0JSFQS)#s_\g #Bp1ؼg !/Gu Y95kSy פilm"\dWK?|gqgގ}?>ܘg>̳~zbjXŢ'ǍXeXgv qeJ'X?ooY?~TIۚ?YL]dOh|5!T죶FԫQ/c;<;;;;+]RSL0E-Blφ%b^yn1֙u<ˎz Aσϋ;Yk^S4/TNaL ִVܗ鐫úٹX6o.,}5/ri6㞝Ksl.ͽnaqU XO.,mwxu̚yfv-̘3^jGffƼ5cvv3t*bwȟy1~vݳ].k.͋KE!4/.}şّͱ./fh~y_vwbˋ,6_fyCQ$$ޜy{c8'wlX܍qMa3l7Gf߼.ig̋/VxlN̋/Ή9rb6'\b3;$e~n+j읈O_w+\|My2d4ݾq5 une<_,͗'n˫\.:V˦8h(ۘom׸:xyS3ڛ*>@5cXABAQeT@NԩN٩S:5Zb^"ڋѮ;^"hh/jvqkD].FhGD;.lvvKD;F;hn@h'#sx3ᰛŁ=S苀b~d5fȼoo endstream endobj 5628 0 obj << /Type /ObjStm /N 100 /First 980 /Length 4469 /Filter /FlateDecode >> stream xڅ[ks[_q>FӱE鼶:nH3mcsL]JRI_p=ϳX\t hi`b0z0$qZ NhΛg =`0DRR `i1H-$NF9`efA 0%,6(+08rdjPAxT8 #<x3.PـkG(\fCVP4`\HzLSt8#qut'buŪvX.VG\j뎋buŲvX.G\,kbw1ѫܩ AȊ@gDNV!gl%˻nw:I[!$%l9jTres+P@<;= v8Y !f,M MgmiF15&H1nihQS-PӔf<YJxn۞MW+Z\фūPGf,5UcmcјBNyjt5Gpuwԭu-iL V,VV[YHZ̼cV[Yjb+ ?J+5,1DDֺ?Iֺ!56qB" wCdUn3u4Au"GD6{ Tq9Z"-[B- ؆kKlÈW2rGnV%PcbW-KS{0TM˜2{MCFkT5M!-5 qOSTc9Y{ 3ZTSh~[:A*{mClMGre/v^d/gt8\ Ց!tl-hұY#[URVaIaZ#mnJbo2(3H"χVNU}+Eld16b+A)cBvAn[w$WG 6> nIҭ/)ZDeQ)?\(GǗ$8ܳzv~&Ι퟾?`L BMqHBKuhmPB;hk.7gXd|9ǝ]づ_^?|~~_nxf(8Hȃ ׃ ~ yx?쩒EXIa5i[\BS8Ur:9bX bݏ0Дkqj7WP,>TISH͞{J+/*AXOKS_Al `.JZ=ҕ\,b,8.iM8Z8M'4#ٓsؓJ~rNHt\D~21$RagqT&\rإyoLRäsm\EwNr:vZ)&ɹZ)\$@,vbboF][Z*#7LT]{] A7 d}Г-@<#=W`RI W<:Tc f)j eKbRC4} Myv͝@TrIu*>R\6G Lu˳s&9S%^* e+ Dc#3mhdSv5/9͈,d4s~ gVx"|;1t˒}=Ba3Źʼn8WT>6΂5zu|*j'JUƲ]뚏j իXt{ccXYi_v"N9iTt>>U9#OTdsHg9%>u_~)x.³922z_sMMLN ye|ooAT~.v3Oepλgz/{X 7 )7jEѸAtV$m(pݳ_c$x*ofI$IkED歧X{`Wx'ǂ:|q$)nةM`WfJR[(Cqzzu'c>Hs&,Z%2_x\sHHN $?qG%?[I 9BA`%Pal'H9`1uA(AP`RQ[mO@zӁOrHòo^z=ev ޢgXETg]no>}R\3ֱۇjKg ջ=9g?@^Sd2~|ܯw'slm ūx*8ϩuf&pqO~76KgtWg d-h\]_H) V,\p5-?ݬ|ڮ~YOV*w- 3+{=>䙮ֿ?m67Y{6<]Wrkvf AWr=|6r;l{'_&H~q3S!˧XG*R:F!3Zp/)4-]5mu}YO&_|׬r(Y_ <.'BOQ=={?lASq|skƙW?ҟasn^cԪ|턢RKu~c Br[Srd X@Hxetv2a/D{ _.O)j 7АvG<|ڬhkwK7+ 2}~,/ίޝB`^6I|o?,? 8ro?>pnfǗ? 8]r rSOXN4ԒT%DKk':Zqڜ u\>M6)jWlAd`i&cf@B=ћګ/S^uwr4X,ք*nI[ >l2`-G=1tyūiH?- ~=bkZ'>dDӷ,1.IqKWY]%kՈiչ Í*ϫge}xXjP=+zK{.iu}n$ʐzlV̢iG.VvSdW#Π>윔>ۭo75Vݧo)>r]iWʫi%)шwxFE"2u~,I_+Sl h:#Yd^0hMFs/ҾdZ6b#NNFNrh mӳ[{& #@i#,_d}0W^YLWhe>V6,3ɨ̶Cs0o-9L6{nYp`}A< "; M@VannjOwV["!V=`ȞF®)zuemcVu04$(lo6K8/s:81GGbLH;HF8{PhTPGv1f*H'UΑ`z* M=&S׸<~b`m?(>!LRb/@B|(@tb*}_h6ÎS؋^E("(B!E"'i6ÈwV endstream endobj 5714 0 obj << /Type /ObjStm /N 100 /First 1044 /Length 4315 /Filter /FlateDecode >> stream xڍ\K%ϯ%7 mWBJE(Y3dDF`P~\{o6L.?NcwU۾HtD'^,>-ysimoH{9_Z_'.ϔ)l>O)mv[XѾ#QZ I960*^8"z)- W Zՙm~ ~WL[`re …RTZ8lqϨSڢy^ʾZOܖS['t+-Y1-{5o_ط,`(-+aBc1Hw}@o#[4p)֡ -yK @d  5Tޅl]Bd)Y (DB PBd).SC'A! P,bK"bkD~]E(ĖB PBl)[ %8ndQZEzm^Zj 2U0[y2LbKPVOtL2EeJje09JmhvChO-}<>`qK~=qEK %@Cd r@rkmlP"(,@  %K!BZSZG£=(, eK!BRމCl-əlCl)P([ 1|ȦP([ 12`=T!-4-&K! FB 4q-[Si[Ҭ,X*@f:&zh<n⼶Zyd|p dd\C9 L Hgrբk(gk('#Hr2Ra(Z&r#ern܆Vkʉ,}ʉ-}ʉ-}ʉ-}Hfrb^zw ,s Ė@Ė@Ė@Ė@p[#w66[{PNb)PNb)PNbBb)PNbrYG{ʹrK!rK!rK!x-IePNa_{ocw,)X !S0}BR iC(gP,j(Bp[.P,j(2<ߚPB9a4C¾{9]7oGLl贯 ӰT ^]'nO5hSLS o$鸬9tC $dDԽWDl]N@5Q[Ci214 |;U}ЃZG{O^sE遞sͷG5Ht9׽t} :pmGzO^y Qyn]rIS˅<:U>rdcMgp)tk7~Rq #g: b +faM/ޏZ;p.r]Ƣ@w3BqO`,™^d 1.Q*tH"%_QwgDZ8{=|@t3**Q#VBcTuE{6xcqJKݙDt&%Ol::]6ݧ]􌥾k40b񷍷GNۣ8]#8ûUW\+\+\+\(a o(ʽʽ=/7/:Nז,H[ ؟ ph Ipkr|^5uͦ3& }+:,:FȸU^(dYٗ(ҡt<71'&z]D;cDYgY~zE >^zf #a0(GD)~T >)ނX[KSk(`B9n~O] ʥz~bێ-j"˂hY, dWE9z☾~ ) nZC+Y\跖qb9Zj/΂]ݰMoaWTfE)oCO/-vjm4H"|2 Jy@rYztQ)6:o RAȐ|o_~!VZi\I1{KeqЀ<4Be4NhC8 xI{K>L5PlcCؘ }i}}x+crņ=6aOԀWѭί_}c!N qjS/5_(}8c87rÑ} ޽zwl]- endstream endobj 5841 0 obj << /Producer (pdfTeX-1.40.22) /Author()/Title(\376\377\000M\000U\000M\000P\000S\000\040\000U\000s\000e\000r\000s\000'\000\040\000g\000u\000i\000d\000e)/Subject()/Creator(LaTeX with hyperref)/Keywords() /CreationDate (D:20250730184921+02'00') /ModDate (D:20250730184921+02'00') /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.141592653-2.6-1.40.22 (TeX Live 2022/dev/Debian) kpathsea version 6.3.4/dev) >> endobj 5815 0 obj << /Type /ObjStm /N 26 /First 249 /Length 839 /Filter /FlateDecode >> stream xڅOo@{lA8٪@ D9UEJҪI|{f>ċ9Tz7qĵ.(EG۟ usىxlrTbvISiOief*8V1-SIKEeG|(R(%.v<;R)wo ̬E^c ŋb[3lߜ ""{fOrg,w]^(-Njt_}VsCDUzXZmwv5KA- yZ_w+nX ] /Length 13732 /Filter /FlateDecode >> stream x%ypd__w]K34h}gߗSD14$F21?ـZ~l11ݥF]m;ƀMGe O~ү/ǻݾ?sjn8BsSS[SԴybslaSb *E۠]-,v@ z,vAʺ-)e.VZYؠM-7(էa-.6)M녕bZ-N+ZkQl)}*YSdq#lRvQ7e}5ʦ[}v(kSNإC{aNe,~e嫷~e7Aeaegx*qeהxN*SpZ'e,ʾP9hTg&eO,F/*K=x .+kVx*[kp]YoMe[=x n+ۦ;pWve,+ۡXCe'şŇgRvbleQӍh|Ũʴbs.CeC&g5Fco/GϮV+ϳlw<^E}vʴY}v>e-j쳍v1֎f5-ʎ(;hQcݦ+mpVcݡ,wE}QNe>Ge5~ebZ6Ub|Pc "豪n(e1v[b3rUa1*؏؅Ұ}xmCYeG+{lR#a݅طa#Mxeʢڵb7XzfͪMPVH:Z]ee[cm48x>TXYDEc(XmQc}쩲>h쩾h+-j쳍ƞr>JYjE}8G5w`̢>A/ih쳍ƞ_lFcOl4䍨%hVb *#"mЮ,)Щ7W=[oί-X: /Ƨ["\c*,Veʢa[\jJiX_Tq㻓SxwJXa >XalMVa'ݰB?p!8 G(pN8 <\p . ܀IӮsa,!w1;x Nmw܇Ax 9 ^x =| d"d""7#㍖ǫYq#>3!>jcBmLƄlLƄlLƄlLƄlLƄlLƄlL0=LOD[tb#L8ޏK΄Ӆk M|,W.82 c9GL^p`X8   I q 9ؓ4=074Dn` xr@Ә؉Iӻ_?dOOOOy HtN\JF:?mwa}K\qbՙe/W8qxuh$ - m ] =E@\!.×C\|B\r^qyqQJvpz'}|4}?m^opy~}\J>._ͯOחlM~,v \"nO;G3!`89ŧe!\pnm .$bMmYtܢ1#Wq;Fec@o Ag< aiiAiAiA~ 24-C24Ǧ[IScs?hMw~6h.H"X K`%&I뱖e!ýȁ%-հB6n;aU,a~CpQ8JMbeoq߿W;o"jҮ.q kwn@:$ƭ[qͳA({NvNIr>IkIk`&xeOL!,nl;-|/}-%߾7Irw&ßWx(~)IaE|ofhN[ ;););););):):Xݢn?m닛`3l  t~CpQ8SpY8\KpU܄[p]i~AQԁ7t.J/AymAymAymAymAw. {@=[K*sP<#@L"yezAVσ; 'b 5|A9uJ ?H ?H ?HkxoA߃X mi2e/keF<0Ѭ~;i?!n粦[ДE,e(@9:^Eݭ"Pr\Ȋ@Y"PE,e(@Y"PE,e(@9ė/]N%Ϳ[\][, ea( CYP0/_/_@YhP0a,e9(AYrPy2e˜9/ HX+{nyLc n"З5U' e)}[ڠ:z `1,eVFax3&Nˤ7Ŷ&-][^A_㝰 v  |A0p {O `C\/-g rʶUcQ:܀p n ><2SxW@tz|U\q9~/'yu'}n4i9h眏q>cq>cq>cq>X/nl5o([xBJaPX<8! cQ0& c0& c0&cr0&cr0&c-IKgx1H#y"e1cz1ǘcz1ǘcz1ǘcz1ǘcz1ǘ{g gGl8cq>c|Ϛ fhqcW}I.H"X K`)a, +a5%-sihj 6f`;x:fK4Cp@|18'$p &-w~#67nŚς; p.[x7܆;p}xd1<  p=iyq)e=iZ kTFE`TFE`TFE`TFE`TFE`TFE`TFE`TFE`Qѵr>(磜r>V ~QGwAFt=J(ݣtI˷գ%-?}kpCVC lވNo-;]!<  *\"Dr%K\,qYe)tMZBÑ3 <ד֕{y%K8/q^y%K8/q^y@Pr(ADw%Kt.]Dw%VKX-Zbj%VK+E'iutܕ| mi:7^_'N|:u׉_'N|:u*uu9t]Nw:ut]Nw:utcd\cu4֩JZEt X K`)!87ED.u@]"PE.u@]"PEjZ ڡ:aJ֟kJZīUZu6Fa lmvNa_o~8#pq8'3py\+p|ѿ7 ނrbl=x 9x 3 x 5,cWqr.gr.gnY9#39#3ˀ2=3IGŌyǯ%mnD3ΰ: 3ΰ:3iovjgs)jgvjgvjgvjgvjgvjgQVfsàgڙ5IoiŲ?þT{*eB| 1P@e3]ȹQ)R1:| |> r>9{yo?C'm?e|s>'`:y+V NN ] E(EQ,bQX.]Hw"Et.]Hw"Et-R[Hmq7+_wE"ȫp9i.]Hw"Et.]Hw"Et.]Hw"Et.]Hw"Et.]Hwբ/"E~-[o1mIgӾ軛 fhVhvNn,ŰBVjXu?G.KwZu6Fp"ҽVa]t;C}A8cpNIp}usp.E \kpnM܅{pCxx O);x+gभI[G_8_g9rK|6%>K|,Yg%>K|,Yjfm4fOg%>K|,Yg%>K|,Yg%>Kh6̙:e CV,5Yo5~k[o-J\ҞUq^y5k8q^y5k8q^yКv^kyv^DTvM"jXZc?%8;iBFw5kt״v^kyv^0Ԅ& 5kt]Fw5kt]Fw5kt]FwݵPMB}IUDԴ\oK9bZ \Nn3 [a ,4,`\^X `5 Bۤ쉭ZttG [`+2<\ݝsuw9Ww^}`2s p18'$pUE湛p n ><2.)Ʈ<'sx/x 8>GLĕuc֤"#;3H;#;#1n~Gwߑ{#a?B#P6B#IGoĦb=HL,#\p9#\p9#\p9Yrdoұ3ܞau$n:#:#:#7By#䍐7sP6r-ܗ&b"sGap/L=E3zyj%JC޵ +aOR%>Xha]`$W m 68KIw_rYbV xkqOuϐCpQ8SpY86݃oٚtpbϮv{!Ԗ{p'MPa&L 3IwTdXx+#>ɈOfg%qg%#/yKF^2dC| 3ggM!>C| KuuuuuugQN9ii yt|\ĬaꈴL<.ככW7oz&x7777777777777777777777777GҺy3ƯNമ 3:h:h:hLlN:~tכÛ֥ևևևևևևևև?V"C@1R7@ oFRH2X+]Կ } k:cCԳcb%[aweyL6~7fOt*tXMy H? 8I4pF|_+pu0]~c5~c=>>[O:~c +7?zd7 S;L0S;L0S;L0S;k0S;L^wۂwIGJl+?S;L0T p*b^ba*ba*wT S1$M?pm81BzX a5>ba;b+VUQ[Q[Q[Q[Q[Q[Q~S[Q[Q[QuKh3mT6S*Q1Ye3h}TQ>*`0Xa`ڭ݊ڭ݊ڭgIgtT+UȫW!B^ewy"Zm 3**IE#h$TQ>*GEh=͠btME[h mBw +$WH\Q$WH\!Br ɕ/# fhVhv耘 Rlҹs.VH2X+VjXt>MVa]^}A8cpN p98 2\p 6܁px   p18g?'k{u.e8tߍr:6*\p_܄[pT[!v~yd1< x 5)6SO?SO?SO?SO?StO=EJ|)Χ8|StS)ڒt-Zl.SN~j{Y_o17]؛t5oS Ô0L Ô0L Ô0L Ô0L Ô0Lp Ns Sb1%S@@0L Ô0L SO;pdJ֦؟b)؟b)؟b)؟b)؟b)L^!&I˭hj矴%]+OD Mk:^!tC5B ͉kN^s"לD5'B9z͉kNޘ!&A5 BIzMk^ lνfBML?}_XM =2Bz3'&M o)5{!7y^izILۛ\LR9Y u0Wz̈́k&^3! LIJҵdau|63xt2?a:yuǣ1A*)*&J&]7QΑ/'$]QS6%];JX`@ lHx%'~}ŏ!m5Q/1nL٨^ˀzP/e@E {4k*g qP915:P/1o=P~f vO> I-mTW_$]md[Wtxt7}͛UK}-^&/]jKfjOf_H[3iW]Iϖ;;鹾)^$=bJ%={%^-Jz&t͋r|I;KO%6īeIߏW˓jEF;o౳jeʟWV'"kEūɢ }ɢҔ,ݟl?f p_k?5P7*h:6E# , ,V5V77Z;C[88k5pnb=dc\6#b1 #ifdef INTSIZE64 #define LIBSEQ_INT int64_t #define LIBSEQ_INT8 int64_t #else #define LIBSEQ_INT int #define LIBSEQ_INT8 int64_t #endif #if ! defined(LIBSEQ_CALL) #if defined(_WIN32) && ! defined(__MINGW32__) /* Choose between next lines or modify according * to your Windows calling conventions: #define LIBSEQ_CALL #define LIBSEQ_CALL __declspec(dllexport) #define LIBSEQ_CALL __declspec(dllexport) */ #define LIBSEQ_CALL #else #define LIBSEQ_CALL #endif #endif #ifndef MUMPS_MPI_H #define MUMPS_MPI_H /* We define all symbols as extern "C" for users who call MUMPS with its libseq from a C++ driver. */ #ifdef __cplusplus extern "C" { #endif /* This is the minimum to have the C interface to MUMPS work with the * C example provided. Other stub functions of the MPI standard may be * added as needed. */ typedef LIBSEQ_INT MPI_Comm; /* Simple type for MPI communicator */ static MPI_Comm MPI_COMM_WORLD=(MPI_Comm)0; int LIBSEQ_CALL MPI_Init(int *pargc, char ***pargv); int LIBSEQ_CALL MPI_Comm_rank(MPI_Comm comm, int *rank); int LIBSEQ_CALL MPI_Finalize(void); MPI_Comm LIBSEQ_CALL MPI_Comm_f2c(LIBSEQ_INT comm); /* For MPI_IS_IN_PLACE tests */ void LIBSEQ_CALL MUMPS_CHECKADDREQUAL(char *a, char*b, LIBSEQ_INT8 *i); void LIBSEQ_CALL MUMPS_CHECKADDREQUAL_(char *a, char*b, LIBSEQ_INT8 *i); void LIBSEQ_CALL mumps_checkaddrequal_(char *a, char*b, LIBSEQ_INT8 *i); void LIBSEQ_CALL mumps_checkaddrequal__(char *a, char*b, LIBSEQ_INT8 *i); double LIBSEQ_CALL MPI_Wtime(void); #ifdef __cplusplus } #endif #endif /* MUMPS_MPI_H */ MUMPS_5.8.1/libseq/elapse.h0000664000175000017500000000166015042446422015345 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_CALL #if defined(_WIN32) /* Modify/choose between next 2 lines depending * * on your Windows calling conventions */ /* #define MUMPS_CALL __stdcall */ #define MUMPS_CALL #else #define MUMPS_CALL #endif #endif #if (defined(_WIN32) && ! defined(__MINGW32__)) || defined(UPPER) #define mumps_elapse MUMPS_ELAPSE #elif defined(Add__) #define mumps_elapse mumps_elapse__ #elif defined(Add_) #define mumps_elapse mumps_elapse_ #endif void MUMPS_CALL mumps_elapse(double *val); MUMPS_5.8.1/libseq/elapse.c0000664000175000017500000000164615042446422015344 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #if defined(_WIN32) #include "elapse.h" #include #include void MUMPS_CALL mumps_elapse(double *val) { time_t ltime; struct _timeb tstruct; time (<ime); _ftime(&tstruct); *val = (double) ltime + (double) tstruct.millitm*(0.001); } #else #include "elapse.h" #include void mumps_elapse(double *val) { struct timeval time; gettimeofday(&time,(struct timezone *)0); *val=time.tv_sec+time.tv_usec*1.e-6; } #endif MUMPS_5.8.1/libseq/Makefile0000664000175000017500000000130615042446422015360 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # all: staticlibmpiseq .PHONY: all staticlibmpiseq sharedlibmpiseq clean topdir = .. include $(topdir)/Makefile.inc staticlibmpiseq: libmpiseq$(PLAT)$(LIBEXT) libmpiseq$(PLAT)$(LIBEXT): mpi.o mpic.o elapse.o $(AR)$@ mpi.o mpic.o elapse.o $(RANLIB) $@ sharedlibmpiseq: $(MAKE) FPIC="$(FPIC_OPT)" libmpiseq$(PLAT)$(LIBEXT_SHARED) libmpiseq$(PLAT)$(LIBEXT_SHARED): mpi.o mpic.o elapse.o $(FC) $(SHARED_OPT) mpi.o mpic.o elapse.o -o libmpiseq$(PLAT)$(LIBEXT_SHARED) .f.o: $(FC) $(OPTF) $(FPIC) -c $*.f $(OUTF)$*.o .c.o: $(CC) $(OPTC) $(FPIC) $(CDEFS) -I. -c $*.c $(OUTC)$*.o clean: $(RM) *.o *$(LIBEXT) MUMPS_5.8.1/libseq/README0000664000175000017500000000032115042446422014574 0ustar amestoyamestoy This directory contains dummy MPI/BLACS/ScaLAPACK symbols to allow linking/running MUMPS on a platform where MPI is not installed. It is used by the main Makefile to build a sequential version of MUMPS. MUMPS_5.8.1/libseq/mpic.c0000664000175000017500000000254315042446422015020 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * * * Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mpi.h" #include "elapse.h" MPI_Comm LIBSEQ_CALL MPI_Comm_f2c(LIBSEQ_INT comm) { return 0; } int LIBSEQ_CALL MPI_Init(int *pargc, char ***pargv) { return 0; } int LIBSEQ_CALL MPI_Comm_rank(MPI_Comm comm, int *rank) { *rank=0; return 0; } int LIBSEQ_CALL MPI_Finalize(void) { return 0; } /* Internal: for MPI_IS_IN_PLACE tests from Fortran */ void LIBSEQ_CALL MUMPS_CHECKADDREQUAL(char *a, char*b, LIBSEQ_INT8 *i) { if (a - b == 0) { *i=1; } else { *i=0; } } void LIBSEQ_CALL MUMPS_CHECKADDREQUAL_(char *a, char*b, LIBSEQ_INT8 *i) { MUMPS_CHECKADDREQUAL(a,b,i); } void LIBSEQ_CALL mumps_checkaddrequal_(char *a, char*b, LIBSEQ_INT8 *i) { MUMPS_CHECKADDREQUAL(a,b,i); } void LIBSEQ_CALL mumps_checkaddrequal__(char *a, char*b, LIBSEQ_INT8 *i) { MUMPS_CHECKADDREQUAL(a,b,i); } double LIBSEQ_CALL MPI_Wtime() { double val; mumps_elapse(&val); return val; } MUMPS_5.8.1/libseq/mpif.h0000664000175000017500000000650515042446422015032 0ustar amestoyamestoy! ! This file is part of MUMPS 5.8.1, released ! on Wed Jul 30 16:49:18 UTC 2025 ! ! ! Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! Mumps Technologies, University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license ! (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and ! https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) ! ! ! Stub mpif.h file including symbols used by MUMPS. ! INTEGER MPI_2DOUBLE_PRECISION INTEGER MPI_2INTEGER INTEGER MPI_2REAL INTEGER MPI_ANY_SOURCE INTEGER MPI_ANY_TAG INTEGER MPI_BYTE INTEGER MPI_CHARACTER INTEGER MPI_COMM_NULL INTEGER MPI_COMM_WORLD INTEGER MPI_COMPLEX INTEGER MPI_DOUBLE_COMPLEX INTEGER MPI_DOUBLE_PRECISION INTEGER MPI_INTEGER INTEGER MPI_LOGICAL INTEGER MPI_MAX INTEGER MPI_MAX_PROCESSOR_NAME INTEGER MPI_MAXLOC INTEGER MPI_MIN INTEGER MPI_MINLOC INTEGER MPI_PACKED INTEGER MPI_PROD INTEGER MPI_REAL INTEGER MPI_REPLACE INTEGER MPI_REQUEST_NULL INTEGER MPI_SOURCE INTEGER MPI_STATUS_SIZE INTEGER MPI_SUM INTEGER MPI_TAG INTEGER MPI_UNDEFINED INTEGER MPI_WTIME_IS_GLOBAL INTEGER MPI_LOR INTEGER MPI_LAND INTEGER MPI_INTEGER8 INTEGER MPI_REAL8 INTEGER MPI_COMM_SELF INTEGER MPI_BSEND_OVERHEAD INTEGER MPI_THREAD_SINGLE INTEGER MPI_THREAD_FUNNELED INTEGER MPI_THREAD_MULTIPLE INTEGER MPI_BOR INTEGER MPI_WIN_NULL INTEGER MPI_ADDRESS_KIND INTEGER MPI_INFO_NULL INTEGER MPI_SUCCESS INTEGER MPI_ERRORS_RETURN PARAMETER (MPI_2DOUBLE_PRECISION=1) PARAMETER (MPI_2INTEGER=2) PARAMETER (MPI_2REAL=3) PARAMETER (MPI_ANY_SOURCE=4) PARAMETER (MPI_ANY_TAG=5) PARAMETER (MPI_BYTE=6) PARAMETER (MPI_CHARACTER=7) PARAMETER (MPI_COMM_NULL=8) PARAMETER (MPI_COMM_WORLD=9) PARAMETER (MPI_COMPLEX=10) PARAMETER (MPI_DOUBLE_COMPLEX=11) PARAMETER (MPI_DOUBLE_PRECISION=12) PARAMETER (MPI_INTEGER=13) PARAMETER (MPI_LOGICAL=14) PARAMETER (MPI_MAX=15) PARAMETER (MPI_MAX_PROCESSOR_NAME=31) PARAMETER (MPI_MAXLOC=16) PARAMETER (MPI_MIN=17) PARAMETER (MPI_MINLOC=18) PARAMETER (MPI_PACKED=19) PARAMETER (MPI_PROD=20) PARAMETER (MPI_REAL=21) PARAMETER (MPI_REPLACE=22) PARAMETER (MPI_REQUEST_NULL=23) PARAMETER (MPI_SOURCE=1) PARAMETER (MPI_STATUS_SIZE=2) PARAMETER (MPI_SUM=26) PARAMETER (MPI_TAG=2) PARAMETER (MPI_UNDEFINED=28) PARAMETER (MPI_WTIME_IS_GLOBAL=30) PARAMETER (MPI_LOR=31) PARAMETER (MPI_LAND=32) PARAMETER (MPI_INTEGER8=33) PARAMETER (MPI_REAL8=34) PARAMETER (MPI_COMM_SELF=35) PARAMETER (MPI_THREAD_SINGLE=36) PARAMETER (MPI_THREAD_FUNNELED=37) PARAMETER (MPI_THREAD_MULTIPLE=38) PARAMETER (MPI_BOR=39) PARAMETER (MPI_WIN_NULL=40) PARAMETER (MPI_ADDRESS_KIND=8) PARAMETER (MPI_INFO_NULL=41) PARAMETER (MPI_SUCCESS=0) PARAMETER (MPI_ERRORS_RETURN=42) INTEGER MPI_IN_PLACE COMMON/mpif_libseq/MPI_IN_PLACE PARAMETER (MPI_BSEND_OVERHEAD=0) DOUBLE PRECISION MPI_WTIME EXTERNAL MPI_WTIME MUMPS_5.8.1/libseq/mpi.f0000664000175000017500000017163315042446422014667 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C C C Copyright 1991-2025 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C******************************************************************* C C This file contains stub MPI/BLACS/ScaLAPACK library functions for C linking/running MUMPS on a platform where MPI is not installed. C C******************************************************************* C C MPI C C****************************************************************** SUBROUTINE MPI_BSEND( BUF, CNT, DATATYPE, DEST, TAG, COMM, & IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, DATATYPE, DEST, TAG, COMM, IERR INTEGER BUF(*) WRITE(*,*) 'Error. MPI_BSEND should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_BSEND C*********************************************************************** SUBROUTINE MPI_BUFFER_ATTACH(BUF, CNT, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, IERR INTEGER BUF(*) IERR = 0 RETURN END SUBROUTINE MPI_BUFFER_ATTACH C*********************************************************************** SUBROUTINE MPI_BUFFER_DETACH(BUF, CNT, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, IERR INTEGER BUF(*) IERR = 0 RETURN END SUBROUTINE MPI_BUFFER_DETACH SUBROUTINE MPI_GATHER( SENDBUF, CNT, & DATATYPE, RECVBUF, RECVCNT, RECTYPE, & ROOT, COMM, IERR ) IMPLICIT NONE INTEGER CNT, DATATYPE, RECVCNT, RECTYPE, ROOT, COMM, IERR INTEGER SENDBUF(*), RECVBUF(*) LOGICAL, EXTERNAL :: MUMPS_IS_IN_PLACE IF (.NOT. MUMPS_IS_IN_PLACE(SENDBUF, CNT)) THEN IF ( RECVCNT .NE. CNT ) THEN WRITE(*,*) 'ERROR in MPI_GATHER, RECVCNT != CNT' STOP ELSE CALL MUMPS_COPY( CNT, SENDBUF, RECVBUF, 0, 0, DATATYPE, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) 'ERROR in MPI_GATHER, DATATYPE=',DATATYPE STOP END IF END IF END IF IERR = 0 RETURN END SUBROUTINE MPI_GATHER C*********************************************************************** SUBROUTINE MPI_GATHERV( SENDBUF, CNT, & DATATYPE, RECVBUF, RECVCNT, DISPLS, RECTYPE, & ROOT, COMM, IERR ) IMPLICIT NONE INTEGER CNT, DATATYPE, RECTYPE, ROOT, COMM, IERR INTEGER RECVCNT(1) INTEGER SENDBUF(*), RECVBUF(*) INTEGER DISPLS(*) LOGICAL, EXTERNAL :: MUMPS_IS_IN_PLACE C IF (.NOT. MUMPS_IS_IN_PLACE(SENDBUF, CNT)) THEN IF ( RECVCNT(1) .NE. CNT ) THEN WRITE(*,*) 'ERROR in MPI_GATHERV, RECVCNT(1) != CNT' STOP ELSE CALL MUMPS_COPY( CNT, SENDBUF, RECVBUF, 0, DISPLS(1), & DATATYPE, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) 'ERROR in MPI_GATHERV, DATATYPE=',DATATYPE STOP END IF END IF ENDIF IERR = 0 RETURN END SUBROUTINE MPI_GATHERV C*********************************************************************** SUBROUTINE MPI_ALLREDUCE( SENDBUF, RECVBUF, CNT, DATATYPE, & OPERATION, COMM, IERR ) IMPLICIT NONE INTEGER CNT, DATATYPE, OPERATION, COMM, IERR INTEGER SENDBUF(*), RECVBUF(*) LOGICAL, EXTERNAL :: MUMPS_IS_IN_PLACE IF (.NOT. MUMPS_IS_IN_PLACE(SENDBUF, CNT)) THEN CALL MUMPS_COPY( CNT, SENDBUF, RECVBUF, 0, 0, DATATYPE, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) 'ERROR in MPI_ALLREDUCE, DATATYPE=',DATATYPE STOP END IF ENDIF IERR = 0 RETURN END SUBROUTINE MPI_ALLREDUCE C*********************************************************************** SUBROUTINE MPI_REDUCE( SENDBUF, RECVBUF, CNT, DATATYPE, OP, & ROOT, COMM, IERR ) IMPLICIT NONE INTEGER CNT, DATATYPE, OP, ROOT, COMM, IERR INTEGER SENDBUF(*), RECVBUF(*) LOGICAL, EXTERNAL :: MUMPS_IS_IN_PLACE IF (.NOT. MUMPS_IS_IN_PLACE(SENDBUF, CNT)) THEN CALL MUMPS_COPY( CNT, SENDBUF, RECVBUF, 0, 0, DATATYPE, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) 'ERROR in MPI_REDUCE, DATATYPE=',DATATYPE STOP END IF ENDIF IERR = 0 RETURN END SUBROUTINE MPI_REDUCE C*********************************************************************** SUBROUTINE MPI_REDUCE_SCATTER( SENDBUF, RECVBUF, RECVCNT, & DATATYPE, OP, COMM, IERR ) IMPLICIT NONE INTEGER RECVCNT, DATATYPE, OP, COMM, IERR INTEGER SENDBUF(*), RECVBUF(*) LOGICAL, EXTERNAL :: MUMPS_IS_IN_PLACE IF (.NOT. MUMPS_IS_IN_PLACE(SENDBUF, RECVCNT)) THEN CALL MUMPS_COPY( RECVCNT, SENDBUF, RECVBUF, 0, 0, & DATATYPE, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) 'ERROR in MPI_REDUCE_SCATTER, DATATYPE=',DATATYPE STOP END IF ENDIF IERR = 0 RETURN END SUBROUTINE MPI_REDUCE_SCATTER C*********************************************************************** SUBROUTINE MPI_ABORT( COMM, IERRCODE, IERR ) IMPLICIT NONE INTEGER COMM, IERRCODE, IERR WRITE(*,*) "** MPI_ABORT called" STOP END SUBROUTINE MPI_ABORT C*********************************************************************** SUBROUTINE MPI_ALLTOALL( SENDBUF, SENDCNT, SENDTYPE, & RECVBUF, RECVCNT, RECVTYPE, COMM, IERR ) IMPLICIT NONE INTEGER SENDCNT, SENDTYPE, RECVCNT, RECVTYPE, COMM, IERR INTEGER SENDBUF(*), RECVBUF(*) LOGICAL, EXTERNAL :: MUMPS_IS_IN_PLACE IF (.NOT. MUMPS_IS_IN_PLACE(SENDBUF, RECVCNT)) THEN IF ( RECVCNT .NE. SENDCNT ) THEN WRITE(*,*) 'ERROR in MPI_ALLTOALL, RECVCNT != SENDCNT' STOP ELSE IF ( RECVTYPE .NE. SENDTYPE ) THEN WRITE(*,*) 'ERROR in MPI_ALLTOALL, RECVTYPE != SENDTYPE' STOP ELSE CALL MUMPS_COPY( SENDCNT, SENDBUF, RECVBUF, & 0, 0, SENDTYPE, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) 'ERROR in MPI_ALLTOALL, SENDTYPE=',SENDTYPE STOP END IF END IF ENDIF IERR = 0 RETURN END SUBROUTINE MPI_ALLTOALL C*********************************************************************** SUBROUTINE MPI_ALLTOALLV( SENDBUF, SENDCNT, SDISPLS, SENDTYPE, & RECVBUF, RECVCNT, RDISPLS, RECVTYPE, & COMM, IERR) IMPLICIT NONE INTEGER SENDCNT, SENDTYPE, RECVCNT, RECVTYPE, COMM, IERR INTEGER SENDBUF(*), RECVBUF(*), SDISPLS(*), RDISPLS(*) LOGICAL, EXTERNAL :: MUMPS_IS_IN_PLACE IF (.NOT. MUMPS_IS_IN_PLACE(SENDBUF, RECVCNT)) THEN IF ( RECVCNT .NE. SENDCNT ) THEN WRITE(*,*) 'ERROR in MPI_ALLTOALLV, RECVCNT != SENDCNT' STOP ELSE IF ( RECVTYPE .NE. SENDTYPE ) THEN WRITE(*,*) 'ERROR in MPI_ALLTOALLV, RECVTYPE != SENDTYPE' STOP ELSE CALL MUMPS_COPY( SENDCNT, SENDBUF, RECVBUF, & SDISPLS(1), RDISPLS(1), SENDTYPE, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) 'ERROR in MPI_ALLTOALL, SENDTYPE=',SENDTYPE STOP END IF END IF ENDIF IERR = 0 RETURN END SUBROUTINE MPI_ALLTOALLV C*********************************************************************** SUBROUTINE MPI_ATTR_PUT( COMM, KEY, VAL, IERR ) IMPLICIT NONE INTEGER COMM, KEY, VAL, IERR RETURN END SUBROUTINE MPI_ATTR_PUT C*********************************************************************** SUBROUTINE MPI_BARRIER( COMM, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, IERR IERR = 0 RETURN END SUBROUTINE MPI_BARRIER C*********************************************************************** SUBROUTINE MPI_GET_PROCESSOR_NAME( NAME, RESULTLEN, IERROR) CHARACTER (LEN=*) NAME INTEGER RESULTLEN,IERROR RESULTLEN = 1 IERROR = 0 NAME = 'X' RETURN END SUBROUTINE MPI_GET_PROCESSOR_NAME C*********************************************************************** SUBROUTINE MPI_BCAST( BUFFER, CNT, DATATYPE, ROOT, COMM, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, DATATYPE, ROOT, COMM, IERR INTEGER BUFFER( * ) IERR = 0 RETURN END SUBROUTINE MPI_BCAST C*********************************************************************** SUBROUTINE MPI_CANCEL( IREQ, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IREQ, IERR IERR = 0 RETURN END SUBROUTINE MPI_CANCEL C*********************************************************************** SUBROUTINE MPI_COMM_CREATE( COMM, GROUP, COMM2, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, GROUP, COMM2, IERR IERR = 0 RETURN END SUBROUTINE MPI_COMM_CREATE C*********************************************************************** SUBROUTINE MPI_COMM_DUP( COMM, COMM2, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, COMM2, IERR IERR = 0 RETURN END SUBROUTINE MPI_COMM_DUP C*********************************************************************** SUBROUTINE MPI_COMM_FREE( COMM, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, IERR IERR = 0 RETURN END SUBROUTINE MPI_COMM_FREE C*********************************************************************** SUBROUTINE MPI_COMM_GROUP( COMM, GROUP, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, GROUP, IERR IERR = 0 RETURN END SUBROUTINE MPI_COMM_GROUP C*********************************************************************** SUBROUTINE MPI_COMM_RANK( COMM, RANK, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, RANK, IERR RANK = 0 IERR = 0 RETURN END SUBROUTINE MPI_COMM_RANK C*********************************************************************** SUBROUTINE MPI_COMM_SIZE( COMM, SIZE, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, SIZE, IERR SIZE = 1 IERR = 0 RETURN END SUBROUTINE MPI_COMM_SIZE C*********************************************************************** SUBROUTINE MPI_COMM_SPLIT( COMM, COLOR, KEY, COMM2, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, COLOR, KEY, COMM2, IERR IERR = 0 RETURN END SUBROUTINE MPI_COMM_SPLIT C*********************************************************************** SUBROUTINE MPI_FINALIZE( IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR IERR = 0 RETURN END SUBROUTINE MPI_FINALIZE C*********************************************************************** SUBROUTINE MPI_GET_COUNT( STATUS, DATATYPE, CNT, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER DATATYPE, CNT, IERR INTEGER STATUS( MPI_STATUS_SIZE ) WRITE(*,*) 'Error. MPI_GET_CNT should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_GET_COUNT C*********************************************************************** SUBROUTINE MPI_GROUP_FREE( GROUP, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER GROUP, IERR IERR = 0 RETURN END SUBROUTINE MPI_GROUP_FREE C*********************************************************************** SUBROUTINE MPI_GROUP_RANGE_EXCL( GROUP, N, RANGES, GROUP2, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER GROUP, N, GROUP2, IERR INTEGER RANGES(*) IERR = 0 RETURN END SUBROUTINE MPI_GROUP_RANGE_EXCL C*********************************************************************** SUBROUTINE MPI_GROUP_SIZE( GROUP, SIZE, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER GROUP, SIZE, IERR SIZE = 1 ! Or should it be zero ? IERR = 0 RETURN END SUBROUTINE MPI_GROUP_SIZE C*********************************************************************** SUBROUTINE MPI_INIT_THREAD(MPI_THREAD_REQ, THREAD_SUPPORT, IERR) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR, MPI_THREAD_REQ, THREAD_SUPPORT IERR = 0 THREAD_SUPPORT=MPI_THREAD_REQ RETURN END SUBROUTINE MPI_INIT_THREAD C*********************************************************************** SUBROUTINE MPI_INIT(IERR) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR IERR = 0 RETURN END SUBROUTINE MPI_INIT C*********************************************************************** SUBROUTINE MPI_INITIALIZED( FLAG, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' LOGICAL FLAG INTEGER IERR FLAG = .TRUE. IERR = 0 RETURN END SUBROUTINE MPI_INITIALIZED C*********************************************************************** SUBROUTINE MPI_IPROBE( SOURCE, TAG, COMM, FLAG, STATUS, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER SOURCE, TAG, COMM, IERR INTEGER STATUS(MPI_STATUS_SIZE) LOGICAL FLAG FLAG = .FALSE. IERR = 0 RETURN END SUBROUTINE MPI_IPROBE C*********************************************************************** SUBROUTINE MPI_IRECV( BUF, CNT, DATATYPE, SOURCE, TAG, COMM, & IREQ, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, DATATYPE, SOURCE, TAG, COMM, IREQ, IERR INTEGER BUF(*) IERR = 0 RETURN END SUBROUTINE MPI_IRECV C*********************************************************************** SUBROUTINE MPI_ISEND( BUF, CNT, DATATYPE, DEST, TAG, COMM, & IREQ, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, DATATYPE, DEST, TAG, COMM, IERR, IREQ INTEGER BUF(*) WRITE(*,*) 'Error. MPI_ISEND should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_ISEND C*********************************************************************** SUBROUTINE MPI_TYPE_COMMIT( NEWTYP, IERR_MPI ) IMPLICIT NONE INTEGER NEWTYP, IERR_MPI RETURN END SUBROUTINE MPI_TYPE_COMMIT C*********************************************************************** SUBROUTINE MPI_TYPE_FREE( NEWTYP, IERR_MPI ) IMPLICIT NONE INTEGER NEWTYP, IERR_MPI RETURN END SUBROUTINE MPI_TYPE_FREE C*********************************************************************** SUBROUTINE MPI_TYPE_CONTIGUOUS( LENGTH, DATATYPE, NEWTYPE, & IERR_MPI ) IMPLICIT NONE INTEGER LENGTH, DATATYPE, NEWTYPE, IERR_MPI RETURN END SUBROUTINE MPI_TYPE_CONTIGUOUS C*********************************************************************** SUBROUTINE MPI_OP_CREATE( FUNC, COMMUTE, OP, IERR ) IMPLICIT NONE EXTERNAL FUNC LOGICAL COMMUTE INTEGER OP, IERR OP = 0 RETURN END SUBROUTINE MPI_OP_CREATE C*********************************************************************** SUBROUTINE MPI_OP_FREE( OP, IERR ) IMPLICIT NONE INTEGER OP, IERR RETURN END SUBROUTINE MPI_OP_FREE C*********************************************************************** SUBROUTINE MPI_PACK( INBUF, INCNT, DATATYPE, OUTBUF, OUTCNT, & POSITION, COMM, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER INCNT, DATATYPE, OUTCNT, POSITION, COMM, IERR INTEGER INBUF(*), OUTBUF(*) WRITE(*,*) 'Error. MPI_PACKED should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_PACK C*********************************************************************** SUBROUTINE MPI_PACK_SIZE( INCNT, DATATYPE, COMM, SIZE, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER INCNT, DATATYPE, COMM, SIZE, IERR WRITE(*,*) 'Error. MPI_PACK_SIZE should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_PACK_SIZE C*********************************************************************** SUBROUTINE MPI_PROBE( SOURCE, TAG, COMM, STATUS, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER SOURCE, TAG, COMM, IERR INTEGER STATUS( MPI_STATUS_SIZE ) WRITE(*,*) 'Error. MPI_PROBE should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_PROBE C*********************************************************************** SUBROUTINE MPI_RECV( BUF, CNT, DATATYPE, SOURCE, TAG, COMM, & STATUS, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, DATATYPE, SOURCE, TAG, COMM, IERR INTEGER BUF(*), STATUS(MPI_STATUS_SIZE) WRITE(*,*) 'Error. MPI_RECV should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_RECV C*********************************************************************** SUBROUTINE MPI_REQUEST_FREE( IREQ, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IREQ, IERR IERR = 0 RETURN END SUBROUTINE MPI_REQUEST_FREE C*********************************************************************** SUBROUTINE MPI_SEND( BUF, CNT, DATATYPE, DEST, TAG, COMM, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, DATATYPE, DEST, TAG, COMM, IERR INTEGER BUF(*) WRITE(*,*) 'Error. MPI_SEND should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_SEND C*********************************************************************** SUBROUTINE MPI_SSEND( BUF, CNT, DATATYPE, DEST, TAG, COMM, IERR) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, DATATYPE, DEST, TAG, COMM, IERR INTEGER BUF(*) WRITE(*,*) 'Error. MPI_SSEND should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_SSEND C*********************************************************************** SUBROUTINE MPI_TEST( IREQ, FLAG, STATUS, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IREQ, IERR INTEGER STATUS( MPI_STATUS_SIZE ) LOGICAL FLAG FLAG = .FALSE. IERR = 0 RETURN END SUBROUTINE MPI_TEST C*********************************************************************** SUBROUTINE MPI_TESTANY( CNT, IREQARRAY, IND, FLAG, STATUS, IERR) IMPLICIT NONE INCLUDE 'mpif.h' LOGICAL FLAG INTEGER IND, IERR, CNT INTEGER IREQARRAY(IND), STATUS(MPI_STATUS_SIZE) FLAG=.FALSE. IERR=0 RETURN END SUBROUTINE MPI_TESTANY C*********************************************************************** SUBROUTINE MPI_UNPACK( INBUF, INSIZE, POSITION, OUTBUF, OUTCNT, & DATATYPE, COMM, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER INSIZE, POSITION, OUTCNT, DATATYPE, COMM, IERR INTEGER INBUF(*), OUTBUF(*) WRITE(*,*) 'Error. MPI_UNPACK should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_UNPACK C*********************************************************************** SUBROUTINE MPI_WAIT( IREQ, STATUS, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IREQ, IERR INTEGER STATUS( MPI_STATUS_SIZE ) WRITE(*,*) 'Error. MPI_WAIT should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_WAIT C*********************************************************************** SUBROUTINE MPI_WAITALL( CNT, ARRAY_OF_REQUESTS, STATUS, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, IERR INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER ARRAY_OF_REQUESTS( CNT ) WRITE(*,*) 'Error. MPI_WAITALL should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_WAITALL C*********************************************************************** SUBROUTINE MPI_WAITANY( CNT, ARRAY_OF_REQUESTS, INDEX, STATUS, & IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, INDEX, IERR INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER ARRAY_OF_REQUESTS( CNT ) WRITE(*,*) 'Error. MPI_WAITANY should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_WAITANY C*********************************************************************** DOUBLE PRECISION FUNCTION MPI_WTIME( ) C elapsed time DOUBLE PRECISION VAL C write(*,*) 'Entering MPI_WTIME' CALL MUMPS_ELAPSE( VAL ) MPI_WTIME = VAL C write(*,*) 'Exiting MPI_WTIME' RETURN END FUNCTION MPI_WTIME C*********************************************************************** SUBROUTINE MPI_COMM_SET_ERRHANDLER(COMM, ERRHANDLER, IERR ) IMPLICIT NONE INTEGER COMM, ERRHANDLER, IERR IERR = 0 RETURN END SUBROUTINE MPI_COMM_SET_ERRHANDLER C*********************************************************************** SUBROUTINE MPI_COMM_GET_ERRHANDLER(COMM, ERRHANDLER, IERR ) IMPLICIT NONE INTEGER COMM, ERRHANDLER, IERR IERR = 0 RETURN END SUBROUTINE MPI_COMM_GET_ERRHANDLER C*********************************************************************** SUBROUTINE MPI_WIN_ALLOCATE_SHARED( SIZE_ARRAY_BYTES, DISP_UNIT, & INFO, COMM, CPTR_ARRAY, WIN, IERR ) USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER :: DISP_UNIT, INFO, COMM, WIN, IERR INTEGER(KIND=MPI_ADDRESS_KIND) :: SIZE_ARRAY_BYTES TYPE(C_PTR) :: CPTR_ARRAY WRITE(*,*) 'Error. MPI_WIN_ALLOCATE_SHARED should not be called.' STOP RETURN END SUBROUTINE MPI_WIN_ALLOCATE_SHARED C*********************************************************************** SUBROUTINE MPI_WIN_SHARED_QUERY( WIN, RANK, SIZE_ARRAY_BYTES, & DISP_UNIT, CPTR_ARRAY, IERR ) USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER :: WIN, RANK, DISP_UNIT, IERR INTEGER(KIND=MPI_ADDRESS_KIND) :: SIZE_ARRAY_BYTES TYPE(C_PTR) :: CPTR_ARRAY WRITE(*,*) 'Error. MPI_WIN_SHARED_QUERY should not be called.' STOP RETURN END SUBROUTINE MPI_WIN_SHARED_QUERY C*********************************************************************** SUBROUTINE MPI_WIN_FREE( WIN, IERROR ) IMPLICIT NONE INTEGER :: WIN, IERROR WRITE(*,*) 'Error. MPI_WIN_FREE should not be called.' STOP RETURN END SUBROUTINE MPI_WIN_FREE C*********************************************************************** C C Utilities to copy data C C*********************************************************************** SUBROUTINE MUMPS_COPY( CNT, SENDBUF, RECVBUF, SS, RS, & DATATYPE, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' C SS/RS: shift for SENDBUF/RECVBUF INTEGER CNT, DATATYPE, IERR, SS, RS INTEGER SENDBUF(*), RECVBUF(*) IF ( DATATYPE .EQ. MPI_INTEGER ) THEN CALL MUMPS_COPY_INTEGER( SENDBUF, RECVBUF, CNT, SS, RS ) ELSEIF ( DATATYPE .EQ. MPI_LOGICAL ) THEN CALL MUMPS_COPY_LOGICAL( SENDBUF, RECVBUF, CNT, SS, RS ) ELSE IF ( DATATYPE .EQ. MPI_REAL ) THEN CALL MUMPS_COPY_REAL( SENDBUF, RECVBUF, CNT, SS, RS ) ELSE IF ( DATATYPE .EQ. MPI_DOUBLE_PRECISION .OR. & DATATYPE .EQ. MPI_REAL8 ) THEN CALL MUMPS_COPY_DOUBLE_PRECISION( SENDBUF, RECVBUF, CNT, SS, RS ) ELSE IF ( DATATYPE .EQ. MPI_COMPLEX ) THEN CALL MUMPS_COPY_COMPLEX( SENDBUF, RECVBUF, CNT, SS, RS ) ELSE IF ( DATATYPE .EQ. MPI_DOUBLE_COMPLEX ) THEN CALL MUMPS_COPY_DOUBLE_COMPLEX( SENDBUF, RECVBUF, CNT, SS, RS ) ELSE IF ( DATATYPE .EQ. MPI_2DOUBLE_PRECISION) THEN CALL MUMPS_COPY_2DOUBLE_PRECISION( SENDBUF, RECVBUF, CNT, SS, RS ) ELSE IF ( DATATYPE .EQ. MPI_2INTEGER) THEN CALL MUMPS_COPY_2INTEGER( SENDBUF, RECVBUF, CNT, SS, RS ) ELSE IF ( DATATYPE .EQ. MPI_INTEGER8) THEN CALL MUMPS_COPY_INTEGER8( SENDBUF, RECVBUF, CNT, SS, RS ) ELSE IERR=1 RETURN END IF IERR=0 RETURN END SUBROUTINE MUMPS_COPY SUBROUTINE MUMPS_COPY_INTEGER( S, R, N, SS, RS ) IMPLICIT NONE INTEGER N, SS, RS INTEGER S(N),R(N) INTEGER I DO I = 1, N R(I+RS) = S(I+SS) END DO RETURN END SUBROUTINE MUMPS_COPY_INTEGER SUBROUTINE MUMPS_COPY_INTEGER8( S, R, N, SS, RS ) IMPLICIT NONE INTEGER N, SS, RS INTEGER(8) S(N),R(N) INTEGER I DO I = 1, N R(I+RS) = S(I+SS) END DO RETURN END SUBROUTINE MUMPS_COPY_INTEGER8 SUBROUTINE MUMPS_COPY_LOGICAL( S, R, N, SS, RS ) IMPLICIT NONE INTEGER N, SS, RS LOGICAL S(N),R(N) INTEGER I DO I = 1, N R(I+RS) = S(I+SS) END DO RETURN END SUBROUTINE MUMPS_COPY_2INTEGER( S, R, N, SS, RS ) IMPLICIT NONE INTEGER N, SS, RS INTEGER S(N+N),R(N+N) INTEGER I DO I = 1, N+N R(I+RS+RS) = S(I+SS+SS) END DO RETURN END SUBROUTINE MUMPS_COPY_2INTEGER SUBROUTINE MUMPS_COPY_REAL( S, R, N, SS, RS ) IMPLICIT NONE INTEGER N, SS, RS REAL S(N),R(N) INTEGER I DO I = 1, N R(I+RS) = S(I+SS) END DO RETURN END SUBROUTINE MUMPS_COPY_2DOUBLE_PRECISION( S, R, N, SS, RS ) IMPLICIT NONE INTEGER N, SS, RS DOUBLE PRECISION S(N+N),R(N+N) INTEGER I DO I = 1, N+N R(I+RS+RS) = S(I+SS+SS) END DO RETURN END SUBROUTINE MUMPS_COPY_2DOUBLE_PRECISION SUBROUTINE MUMPS_COPY_DOUBLE_PRECISION( S, R, N, SS, RS ) IMPLICIT NONE INTEGER N, SS, RS DOUBLE PRECISION S(N),R(N) INTEGER I DO I = 1, N R(I+RS) = S(I+SS) END DO RETURN END SUBROUTINE MUMPS_COPY_COMPLEX( S, R, N, SS, RS ) IMPLICIT NONE INTEGER N, SS, RS COMPLEX S(N),R(N) INTEGER I DO I = 1, N R(I+RS) = S(I+SS) END DO RETURN END SUBROUTINE MUMPS_COPY_COMPLEX SUBROUTINE MUMPS_COPY_DOUBLE_COMPLEX( S, R, N, SS, RS ) IMPLICIT NONE INTEGER N, SS, RS C DOUBLE COMPLEX S(N),R(N) COMPLEX(kind=kind(0.0D0)) :: S(N),R(N) INTEGER I DO I = 1, N R(I+RS) = S(I+SS) END DO RETURN END LOGICAL FUNCTION MUMPS_IS_IN_PLACE( SENDBUF, CNT ) INTEGER SENDBUF(*), CNT INCLUDE 'mpif.h' INTEGER(8) :: I C Check address using C code MUMPS_IS_IN_PLACE = .FALSE. IF ( CNT .GT. 0 ) THEN CALL MUMPS_CHECKADDREQUAL(SENDBUF(1), MPI_IN_PLACE, I) IF (I .EQ. 1) THEN MUMPS_IS_IN_PLACE = .TRUE. ENDIF ENDIF C Begin old code which requires the MPI_IN_PLACE C variable to have the F2003 attribute VOLATILE C IF ( CNT .GT. 0 ) THEN C MPI_IN_PLACE = -1 C IF (SENDBUF(1) .EQ. MPI_IN_PLACE) THEN C MPI_IN_PLACE = -9876543 C IF (MUMPS_CHECK_EQUAL(SENDBUF(1), MPI_IN_PLACE)) THEN C MUMPS_IS_IN_PLACE = .TRUE. C ENDIF C ENDIF C ENDIF C End old code RETURN END FUNCTION MUMPS_IS_IN_PLACE C Begin old code C LOGICAL FUNCTION MUMPS_CHECK_EQUAL(I,J) C INTEGER :: I,J C IF (I.EQ.J) THEN C MUMPS_CHECK_EQUAL = .TRUE. C ELSE C MUMPS_CHECK_EQUAL = .FALSE. C ENDIF C END FUNCTION MUMPS_CHECK_EQUAL C End old code C*********************************************************************** C C BLACS C C*********************************************************************** SUBROUTINE blacs_gridinit( CNTXT, C, NPROW, NPCOL ) IMPLICIT NONE INTEGER CNTXT, NPROW, NPCOL CHARACTER C WRITE(*,*) 'Error. BLACS_GRIDINIT should not be called.' STOP RETURN END SUBROUTINE blacs_gridinit C*********************************************************************** SUBROUTINE blacs_gridinfo( CNTXT, NPROW, NPCOL, MYROW, MYCOL ) IMPLICIT NONE INTEGER CNTXT, NPROW, NPCOL, MYROW, MYCOL WRITE(*,*) 'Error. BLACS_GRIDINFO should not be called.' STOP RETURN END SUBROUTINE blacs_gridinfo C*********************************************************************** SUBROUTINE blacs_gridexit( CNTXT ) IMPLICIT NONE INTEGER CNTXT WRITE(*,*) 'Error. BLACS_GRIDEXIT should not be called.' STOP RETURN END SUBROUTINE blacs_gridexit C*********************************************************************** C C ScaLAPACK C C*********************************************************************** SUBROUTINE DESCINIT( DESC, M, N, MB, NB, IRSRC, ICSRC, & ICTXT, LLD, INFO ) IMPLICIT NONE INTEGER ICSRC, ICTXT, INFO, IRSRC, LLD, M, MB, N, NB INTEGER DESC( * ) WRITE(*,*) 'Error. DESCINIT should not be called.' STOP RETURN END SUBROUTINE DESCINIT C*********************************************************************** INTEGER FUNCTION numroc( N, NB, IPROC, ISRCPROC, NPROCS ) INTEGER N, NB, IPROC, ISRCPROC, NPROCS C Can be called IF ( NPROCS .ne. 1 ) THEN WRITE(*,*) 'Error. Last parameter from NUMROC should be 1' STOP ENDIF IF ( IPROC .ne. 0 ) THEN WRITE(*,*) 'Error. IPROC should be 0 in NUMROC.' STOP ENDIF NUMROC = N RETURN END FUNCTION numroc C*********************************************************************** SUBROUTINE pcpotrf( UPLO, N, A, IA, JA, DESCA, INFO ) IMPLICIT NONE CHARACTER UPLO INTEGER IA, INFO, JA, N INTEGER DESCA( * ) COMPLEX A( * ) WRITE(*,*) 'Error. PCPOTRF should not be called.' STOP RETURN END SUBROUTINE pcpotrf C*********************************************************************** SUBROUTINE pcgetrf( M, N, A, IA, JA, DESCA, IPIV, INFO ) IMPLICIT NONE INTEGER IA, INFO, JA, M, N INTEGER DESCA( * ), IPIV( * ) COMPLEX A( * ) WRITE(*,*) 'Error. PCGETRF should not be called.' STOP RETURN END SUBROUTINE pcgetrf C*********************************************************************** SUBROUTINE pctrtrs( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, & B, IB, JB, DESCB, INFO ) IMPLICIT NONE CHARACTER DIAG, TRANS, UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ) COMPLEX A( * ), B( * ) WRITE(*,*) 'Error. PCTRTRS should not be called.' STOP RETURN END SUBROUTINE pctrtrs C*********************************************************************** SUBROUTINE pzpotrf( UPLO, N, A, IA, JA, DESCA, INFO ) IMPLICIT NONE CHARACTER UPLO INTEGER IA, INFO, JA, N INTEGER DESCA( * ) C DOUBLE COMPLEX A( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ) WRITE(*,*) 'Error. PZPOTRF should not be called.' STOP RETURN END SUBROUTINE pzpotrf C*********************************************************************** SUBROUTINE pzgetrf( M, N, A, IA, JA, DESCA, IPIV, INFO ) IMPLICIT NONE INTEGER IA, INFO, JA, M, N INTEGER DESCA( * ), IPIV( * ) C DOUBLE COMPLEX A( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ) WRITE(*,*) 'Error. PZGETRF should not be called.' STOP RETURN END SUBROUTINE pzgetrf C*********************************************************************** SUBROUTINE pztrtrs( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, & B, IB, JB, DESCB, INFO ) IMPLICIT NONE CHARACTER DIAG, TRANS, UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ) C DOUBLE COMPLEX A( * ), B( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ), B( * ) WRITE(*,*) 'Error. PZTRTRS should not be called.' STOP RETURN END SUBROUTINE pztrtrs C*********************************************************************** SUBROUTINE pspotrf( UPLO, N, A, IA, JA, DESCA, INFO ) IMPLICIT NONE CHARACTER UPLO INTEGER IA, INFO, JA, N INTEGER DESCA( * ) REAL A( * ) WRITE(*,*) 'Error. PSPOTRF should not be called.' STOP RETURN END SUBROUTINE pspotrf C*********************************************************************** SUBROUTINE psgetrf( M, N, A, IA, JA, DESCA, IPIV, INFO ) IMPLICIT NONE INTEGER IA, INFO, JA, M, N INTEGER DESCA( * ), IPIV( * ) REAL A( * ) WRITE(*,*) 'Error. PSGETRF should not be called.' STOP RETURN END SUBROUTINE psgetrf C*********************************************************************** SUBROUTINE pstrtrs( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, & B, IB, JB, DESCB, INFO ) IMPLICIT NONE CHARACTER DIAG, TRANS, UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ) REAL A( * ), B( * ) WRITE(*,*) 'Error. PSTRTRS should not be called.' STOP RETURN END SUBROUTINE pstrtrs C*********************************************************************** SUBROUTINE pdpotrf( UPLO, N, A, IA, JA, DESCA, INFO ) IMPLICIT NONE CHARACTER UPLO INTEGER IA, INFO, JA, N INTEGER DESCA( * ) DOUBLE PRECISION A( * ) WRITE(*,*) 'Error. PDPOTRF should not be called.' STOP RETURN END SUBROUTINE pdpotrf C*********************************************************************** SUBROUTINE pdgetrf( M, N, A, IA, JA, DESCA, IPIV, INFO ) IMPLICIT NONE INTEGER IA, INFO, JA, M, N INTEGER DESCA( * ), IPIV( * ) DOUBLE PRECISION A( * ) WRITE(*,*) 'Error. PDGETRF should not be called.' STOP RETURN END SUBROUTINE pdgetrf C*********************************************************************** SUBROUTINE pdtrtrs( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, & B, IB, JB, DESCB, INFO ) IMPLICIT NONE CHARACTER DIAG, TRANS, UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ) DOUBLE PRECISION A( * ), B( * ) WRITE(*,*) 'Error. PDTRTRS should not be called.' STOP RETURN END SUBROUTINE pdtrtrs C*********************************************************************** SUBROUTINE INFOG2L( GRINDX, GCINDX, DESC, NPROW, NPCOL, MYROW, & MYCOL, LRINDX, LCINDX, RSRC, CSRC ) IMPLICIT NONE INTEGER CSRC, GCINDX, GRINDX, LRINDX, LCINDX, MYCOL, & MYROW, NPCOL, NPROW, RSRC INTEGER DESC( * ) WRITE(*,*) 'Error. INFOG2L should not be called.' STOP RETURN END SUBROUTINE INFOG2L C*********************************************************************** INTEGER FUNCTION INDXG2P( INDXGLOB, NB, IPROC, ISRCPROC, NPROCS ) INTEGER INDXGLOB, IPROC, ISRCPROC, NB, NPROCS INDXG2P = 0 WRITE(*,*) 'Error. INFOG2L should not be called.' STOP RETURN END FUNCTION INDXG2P C*********************************************************************** SUBROUTINE pcscal(N, ALPHA, X, IX, JX, DESCX, INCX) IMPLICIT NONE INTEGER INCX, N, IX, JX COMPLEX ALPHA COMPLEX X( * ) INTEGER DESCX( * ) WRITE(*,*) 'Error. PCSCAL should not be called.' STOP RETURN END SUBROUTINE pcscal C*********************************************************************** SUBROUTINE pzscal(N, ALPHA, X, IX, JX, DESCX, INCX) IMPLICIT NONE INTEGER INCX, N, IX, JX C DOUBLE COMPLEX ALPHA C DOUBLE COMPLEX X( * ) COMPLEX(kind=kind(0.0D0)) :: ALPHA, X( * ) INTEGER DESCX( * ) WRITE(*,*) 'Error. PZSCAL should not be called.' STOP RETURN END SUBROUTINE pzscal C*********************************************************************** SUBROUTINE pdscal(N, ALPHA, X, IX, JX, DESCX, INCX) IMPLICIT NONE INTEGER INCX, N, IX, JX DOUBLE PRECISION ALPHA DOUBLE PRECISION X( * ) INTEGER DESCX( * ) WRITE(*,*) 'Error. PDSCAL should not be called.' STOP RETURN END SUBROUTINE pdscal C*********************************************************************** SUBROUTINE psscal(N, ALPHA, X, IX, JX, DESCX, INCX) IMPLICIT NONE INTEGER INCX, N, IX, JX REAL ALPHA REAL X( * ) INTEGER DESCX( * ) WRITE(*,*) 'Error. PSSCAL should not be called.' STOP RETURN END SUBROUTINE psscal C*********************************************************************** SUBROUTINE pzdot & ( N, DOT, X, IX, JX, DESCX, INCX, Y, IY, JY, DESCY, INCY ) IMPLICIT NONE INTEGER N, IX, JX, IY, JY, INCX, INCY INTEGER DESCX(*), DESCY(*) C DOUBLE COMPLEX X(*), Y(*) COMPLEX(kind=kind(0.0D0)) :: X(*), Y(*) DOUBLE PRECISION DOT DOT = 0.0d0 WRITE(*,*) 'Error. PZDOT should not be called.' STOP RETURN END SUBROUTINE pzdot C*********************************************************************** SUBROUTINE pcdot & ( N, DOT, X, IX, JX, DESCX, INCX, Y, IY, JY, DESCY, INCY ) IMPLICIT NONE INTEGER N, IX, JX, IY, JY, INCX, INCY INTEGER DESCX(*), DESCY(*) COMPLEX X(*), Y(*) REAL DOT DOT = 0.0e0 WRITE(*,*) 'Error. PCDOT should not be called.' STOP RETURN END SUBROUTINE pcdot C*********************************************************************** SUBROUTINE pddot & ( N, DOT, X, IX, JX, DESCX, INCX, Y, IY, JY, DESCY, INCY ) IMPLICIT NONE INTEGER N, IX, JX, IY, JY, INCX, INCY INTEGER DESCX(*), DESCY(*) DOUBLE PRECISION X(*), Y(*), DOT DOT = 0.0d0 WRITE(*,*) 'Error. PDDOT should not be called.' STOP RETURN END SUBROUTINE pddot C*********************************************************************** SUBROUTINE psdot & ( N, DOT, X, IX, JX, DESCX, INCX, Y, IY, JY, DESCY, INCY ) IMPLICIT NONE INTEGER N, IX, JX, IY, JY, INCX, INCY INTEGER DESCX(*), DESCY(*) REAL X(*), Y(*), DOT DOT = 0.0e0 WRITE(*,*) 'Error. PSDOT should not be called.' STOP RETURN END SUBROUTINE psdot C*********************************************************************** SUBROUTINE zgebs2d( CONTXT, SCOPE, TOP, M, N, A, LDA ) IMPLICIT NONE INTEGER CONTXT, M, N, LDA C DOUBLE COMPLEX A(*) COMPLEX(kind=kind(0.0D0)) :: A(*) CHARACTER SCOPE, TOP WRITE(*,*) 'Error. ZGEBS2D should not be called.' STOP RETURN END SUBROUTINE zgebs2d C*********************************************************************** SUBROUTINE cgebs2d( CONTXT, SCOPE, TOP, M, N, A, LDA ) IMPLICIT NONE INTEGER CONTXT, M, N, LDA COMPLEX A(*) CHARACTER SCOPE, TOP WRITE(*,*) 'Error. CGEBS2D should not be called.' STOP RETURN END SUBROUTINE cgebs2d C*********************************************************************** SUBROUTINE sgebs2d( CONTXT, SCOPE, TOP, M, N, A, LDA ) IMPLICIT NONE INTEGER CONTXT, M, N, LDA REAL A(*) CHARACTER SCOPE, TOP WRITE(*,*) 'Error. SGEBS2D should not be called.' STOP RETURN END SUBROUTINE sgebs2d C*********************************************************************** SUBROUTINE dgebs2d( CONTXT, SCOPE, TOP, M, N, A, LDA ) IMPLICIT NONE INTEGER CONTXT, M, N, LDA DOUBLE PRECISION A(*) CHARACTER SCOPE, TOP WRITE(*,*) 'Error. DGEBS2D should not be called.' STOP RETURN END SUBROUTINE dgebs2d C*********************************************************************** SUBROUTINE zgebr2d( CONTXT, SCOPE, TOP, M, N, A, LDA ) IMPLICIT NONE INTEGER CONTXT, M, N, LDA C DOUBLE COMPLEX A(*) COMPLEX(kind=kind(0.0D0)) :: A(*) CHARACTER SCOPE, TOP WRITE(*,*) 'Error. ZGEBR2D should not be called.' STOP RETURN END SUBROUTINE zgebr2d C*********************************************************************** SUBROUTINE cgebr2d( CONTXT, SCOPE, TOP, M, N, A, LDA ) IMPLICIT NONE INTEGER CONTXT, M, N, LDA COMPLEX A(*) CHARACTER SCOPE, TOP WRITE(*,*) 'Error. CGEBR2D should not be called.' STOP RETURN END SUBROUTINE cgebr2d C*********************************************************************** SUBROUTINE sgebr2d( CONTXT, SCOPE, TOP, M, N, A, LDA ) IMPLICIT NONE INTEGER CONTXT, M, N, LDA REAL A(*) CHARACTER SCOPE, TOP WRITE(*,*) 'Error. SGEBR2D should not be called.' STOP RETURN END SUBROUTINE sgebr2d C*********************************************************************** SUBROUTINE dgebr2d( CONTXT, SCOPE, TOP, M, N, A, LDA ) IMPLICIT NONE INTEGER CONTXT, M, N, LDA DOUBLE PRECISION A(*) CHARACTER SCOPE, TOP WRITE(*,*) 'Error. DGEBR2D should not be called.' STOP RETURN END SUBROUTINE dgebr2d C*********************************************************************** SUBROUTINE pcgetrs( TRANS, N, NRHS, A, IA, JA, DESCA, IPIV, B, & IB, JB, DESCB, INFO ) IMPLICIT NONE CHARACTER TRANS INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ), IPIV( * ) COMPLEX A( * ), B( * ) WRITE(*,*) 'Error. PCGETRS should not be called.' STOP RETURN END SUBROUTINE pcgetrs C*********************************************************************** SUBROUTINE pzgetrs( TRANS, N, NRHS, A, IA, JA, DESCA, IPIV, B, & IB, JB, DESCB, INFO ) IMPLICIT NONE CHARACTER TRANS INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ), IPIV( * ) c DOUBLE COMPLEX A( * ), B( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ), B( * ) WRITE(*,*) 'Error. PZGETRS should not be called.' STOP RETURN END SUBROUTINE pzgetrs C*********************************************************************** SUBROUTINE psgetrs( TRANS, N, NRHS, A, IA, JA, DESCA, IPIV, B, & IB, JB, DESCB, INFO ) IMPLICIT NONE CHARACTER TRANS INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ), IPIV( * ) REAL A( * ), B( * ) WRITE(*,*) 'Error. PSGETRS should not be called.' STOP RETURN END SUBROUTINE psgetrs C*********************************************************************** SUBROUTINE pdgetrs( TRANS, N, NRHS, A, IA, JA, DESCA, IPIV, B, & IB, JB, DESCB, INFO ) IMPLICIT NONE CHARACTER TRANS INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ), IPIV( * ) DOUBLE PRECISION A( * ), B( * ) WRITE(*,*) 'Error. PDGETRS should not be called.' STOP RETURN END SUBROUTINE pdgetrs C*********************************************************************** SUBROUTINE pcpotrs( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, & DESCB, INFO ) IMPLICIT NONE CHARACTER UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ) COMPLEX A( * ), B( * ) WRITE(*,*) 'Error. PCPOTRS should not be called.' STOP RETURN END SUBROUTINE pcpotrs C*********************************************************************** SUBROUTINE pzpotrs( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, & DESCB, INFO ) IMPLICIT NONE CHARACTER UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ) c DOUBLE COMPLEX A( * ), B( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ), B( * ) WRITE(*,*) 'Error. PZPOTRS should not be called.' STOP RETURN END SUBROUTINE pzpotrs C*********************************************************************** SUBROUTINE pspotrs( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, & DESCB, INFO ) IMPLICIT NONE CHARACTER UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ) REAL A( * ), B( * ) WRITE(*,*) 'Error. PSPOTRS should not be called.' STOP RETURN END SUBROUTINE pspotrs C*********************************************************************** SUBROUTINE pdpotrs( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, & DESCB, INFO ) IMPLICIT NONE CHARACTER UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ) DOUBLE PRECISION A( * ), B( * ) WRITE(*,*) 'Error. PDPOTRS should not be called.' STOP RETURN END SUBROUTINE pdpotrs C*********************************************************************** SUBROUTINE pscnrm2( N, NORM2, X, IX, JX, DESCX, INCX ) IMPLICIT NONE INTEGER N, IX, JX, INCX INTEGER DESCX(*) REAL NORM2 COMPLEX X( * ) WRITE(*,*) 'Error. PCNRM2 should not be called.' STOP RETURN END SUBROUTINE pscnrm2 C*********************************************************************** SUBROUTINE pdznrm2( N, NORM2, X, IX, JX, DESCX, INCX ) IMPLICIT NONE INTEGER N, IX, JX, INCX INTEGER DESCX(*) DOUBLE PRECISION NORM2 C DOUBLE COMPLEX X( * ) COMPLEX(kind=kind(0.0D0)) :: X( * ) WRITE(*,*) 'Error. PZNRM2 should not be called.' STOP RETURN END SUBROUTINE pdznrm2 C*********************************************************************** SUBROUTINE psnrm2( N, NORM2, X, IX, JX, DESCX, INCX ) IMPLICIT NONE INTEGER N, IX, JX, INCX INTEGER DESCX(*) REAL NORM2, X( * ) WRITE(*,*) 'Error. PSNRM2 should not be called.' STOP RETURN END SUBROUTINE psnrm2 C*********************************************************************** SUBROUTINE pdnrm2( N, NORM2, X, IX, JX, DESCX, INCX ) IMPLICIT NONE INTEGER N, IX, JX, INCX INTEGER DESCX(*) DOUBLE PRECISION NORM2, X( * ) WRITE(*,*) 'Error. PDNRM2 should not be called.' STOP RETURN END SUBROUTINE pdnrm2 C*********************************************************************** REAL FUNCTION pclange( NORM, M, N, A, IA, JA, & DESCA, WORK ) CHARACTER NORM INTEGER IA, JA, M, N INTEGER DESCA( * ) COMPLEX A( * ), WORK( * ) PCLANGE = 0.0e0 WRITE(*,*) 'Error. PCLANGE should not be called.' STOP RETURN END FUNCTION pclange C*********************************************************************** DOUBLE PRECISION FUNCTION pzlange( NORM, M, N, A, IA, JA, & DESCA, WORK ) CHARACTER NORM INTEGER IA, JA, M, N INTEGER DESCA( * ) REAL A( * ), WORK( * ) PZLANGE = 0.0d0 WRITE(*,*) 'Error. PZLANGE should not be called.' STOP RETURN END FUNCTION pzlange C*********************************************************************** REAL FUNCTION pslange( NORM, M, N, A, IA, JA, & DESCA, WORK ) CHARACTER NORM INTEGER IA, JA, M, N INTEGER DESCA( * ) REAL A( * ), WORK( * ) PSLANGE = 0.0e0 WRITE(*,*) 'Error. PSLANGE should not be called.' STOP RETURN END FUNCTION pslange C*********************************************************************** DOUBLE PRECISION FUNCTION pdlange( NORM, M, N, A, IA, JA, & DESCA, WORK ) CHARACTER NORM INTEGER IA, JA, M, N INTEGER DESCA( * ) DOUBLE PRECISION A( * ), WORK( * ) PDLANGE = 0.0d0 WRITE(*,*) 'Error. PDLANGE should not be called.' STOP RETURN END FUNCTION pdlange C*********************************************************************** SUBROUTINE pcgecon( NORM, N, A, IA, JA, DESCA, ANORM, & RCOND, WORK, LWORK, IWORK, LIWORK, INFO ) IMPLICIT NONE CHARACTER NORM INTEGER IA, INFO, JA, LIWORK, LWORK, N REAL ANORM, RCOND INTEGER DESCA( * ), IWORK( * ) COMPLEX A( * ), WORK( * ) WRITE(*,*) 'Error. PCGECON should not be called.' STOP RETURN END SUBROUTINE pcgecon C*********************************************************************** SUBROUTINE pzgecon( NORM, N, A, IA, JA, DESCA, ANORM, & RCOND, WORK, LWORK, IWORK, LIWORK, INFO ) IMPLICIT NONE CHARACTER NORM INTEGER IA, INFO, JA, LIWORK, LWORK, N DOUBLE PRECISION ANORM, RCOND INTEGER DESCA( * ), IWORK( * ) C DOUBLE COMPLEX A( * ), WORK( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ), WORK( * ) WRITE(*,*) 'Error. PZGECON should not be called.' STOP RETURN END SUBROUTINE pzgecon C*********************************************************************** SUBROUTINE psgecon( NORM, N, A, IA, JA, DESCA, ANORM, & RCOND, WORK, LWORK, IWORK, LIWORK, INFO ) IMPLICIT NONE CHARACTER NORM INTEGER IA, INFO, JA, LIWORK, LWORK, N REAL ANORM, RCOND INTEGER DESCA( * ), IWORK( * ) REAL A( * ), WORK( * ) WRITE(*,*) 'Error. PSGECON should not be called.' STOP RETURN END SUBROUTINE psgecon C*********************************************************************** SUBROUTINE pdgecon( NORM, N, A, IA, JA, DESCA, ANORM, & RCOND, WORK, LWORK, IWORK, LIWORK, INFO ) IMPLICIT NONE CHARACTER NORM INTEGER IA, INFO, JA, LIWORK, LWORK, N DOUBLE PRECISION ANORM, RCOND INTEGER DESCA( * ), IWORK( * ) DOUBLE PRECISION A( * ), WORK( * ) WRITE(*,*) 'Error. PDGECON should not be called.' STOP RETURN END SUBROUTINE pdgecon C*********************************************************************** SUBROUTINE pcgeqpf( M, N, A, IA, JA, DESCA, IPIV, TAU, & WORK, LWORK, INFO ) IMPLICIT NONE INTEGER IA, JA, INFO, LWORK, M, N INTEGER DESCA( * ), IPIV( * ) COMPLEX A( * ), TAU( * ), WORK( * ) WRITE(*,*) 'Error. PCGEQPF should not be called.' STOP RETURN END SUBROUTINE pcgeqpf C*********************************************************************** SUBROUTINE pzgeqpf( M, N, A, IA, JA, DESCA, IPIV, TAU, & WORK, LWORK, INFO ) IMPLICIT NONE INTEGER IA, JA, INFO, LWORK, M, N INTEGER DESCA( * ), IPIV( * ) C DOUBLE COMPLEX A( * ), TAU( * ), WORK( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ), TAU( * ), WORK( * ) WRITE(*,*) 'Error. PZGEQPF should not be called.' STOP RETURN END SUBROUTINE pzgeqpf C*********************************************************************** SUBROUTINE psgeqpf( M, N, A, IA, JA, DESCA, IPIV, TAU, & WORK, LWORK, INFO ) IMPLICIT NONE INTEGER IA, JA, INFO, LWORK, M, N INTEGER DESCA( * ), IPIV( * ) REAL A( * ), TAU( * ), WORK( * ) WRITE(*,*) 'Error. PSGEQPF should not be called.' STOP RETURN END SUBROUTINE psgeqpf C*********************************************************************** SUBROUTINE pdgeqpf( M, N, A, IA, JA, DESCA, IPIV, TAU, & WORK, LWORK, INFO ) IMPLICIT NONE INTEGER IA, JA, INFO, LWORK, M, N INTEGER DESCA( * ), IPIV( * ) DOUBLE PRECISION A( * ), TAU( * ), WORK( * ) WRITE(*,*) 'Error. PDGEQPF should not be called.' STOP RETURN END SUBROUTINE pdgeqpf C*********************************************************************** SUBROUTINE pcaxpy(N, A, X, IX, JX, DESCX, INCX, Y, IY, JY, & DESCY, INCY) IMPLICIT NONE INTEGER N, IX, IY, JX, JY, INCX, INCY INTEGER DESCX(*), DESCY(*) COMPLEX A(*),X(*),Y(*) WRITE(*,*) 'Error. PCAXPY should not be called.' STOP RETURN END SUBROUTINE pcaxpy C*********************************************************************** SUBROUTINE pzaxpy(N, A, X, IX, JX, DESCX, INCX, Y, IY, JY, & DESCY, INCY) IMPLICIT NONE INTEGER N, IX, IY, JX, JY, INCX, INCY INTEGER DESCX(*), DESCY(*) C DOUBLE COMPLEX A(*),X(*),Y(*) COMPLEX(kind=kind(0.0D0)) :: A(*),X(*),Y(*) WRITE(*,*) 'Error. PZAXPY should not be called.' STOP RETURN END SUBROUTINE pzaxpy C*********************************************************************** SUBROUTINE psaxpy(N, A, X, IX, JX, DESCX, INCX, Y, IY, JY, & DESCY, INCY) IMPLICIT NONE INTEGER N, IX, IY, JX, JY, INCX, INCY INTEGER DESCX(*), DESCY(*) REAL A(*),X(*),Y(*) WRITE(*,*) 'Error. PSAXPY should not be called.' STOP RETURN END SUBROUTINE psaxpy C*********************************************************************** SUBROUTINE pdaxpy(N, A, X, IX, JX, DESCX, INCX, Y, IY, JY, & DESCY, INCY) IMPLICIT NONE INTEGER N, IX, IY, JX, JY, INCX, INCY INTEGER DESCX(*), DESCY(*) DOUBLE PRECISION A(*),X(*),Y(*) WRITE(*,*) 'Error. PDAXPY should not be called.' STOP RETURN END SUBROUTINE pdaxpy C*********************************************************************** SUBROUTINE pctrsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, IA, $ JA, DESCA, B, IB, JB, DESCB ) IMPLICIT NONE CHARACTER SIDE, UPLO, TRANSA, DIAG INTEGER M, N, IA, JA, IB, JB COMPLEX ALPHA INTEGER DESCA( * ), DESCB( * ) COMPLEX A( * ), B( * ) WRITE(*,*) 'Error. PCTRSM should not be called.' STOP RETURN END SUBROUTINE pctrsm C*********************************************************************** SUBROUTINE pztrsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, IA, $ JA, DESCA, B, IB, JB, DESCB ) IMPLICIT NONE CHARACTER SIDE, UPLO, TRANSA, DIAG INTEGER M, N, IA, JA, IB, JB C DOUBLE COMPLEX ALPHA COMPLEX(kind=kind(0.0D0)) :: ALPHA INTEGER DESCA( * ), DESCB( * ) C DOUBLE COMPLEX A( * ), B( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ), B( * ) WRITE(*,*) 'Error. PZTRSM should not be called.' STOP RETURN END SUBROUTINE pztrsm C*********************************************************************** SUBROUTINE pstrsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, IA, $ JA, DESCA, B, IB, JB, DESCB ) IMPLICIT NONE CHARACTER SIDE, UPLO, TRANSA, DIAG INTEGER M, N, IA, JA, IB, JB REAL ALPHA INTEGER DESCA( * ), DESCB( * ) REAL A( * ), B( * ) WRITE(*,*) 'Error. PSTRSM should not be called.' STOP RETURN END SUBROUTINE pstrsm C*********************************************************************** SUBROUTINE pdtrsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, IA, $ JA, DESCA, B, IB, JB, DESCB ) IMPLICIT NONE CHARACTER SIDE, UPLO, TRANSA, DIAG INTEGER M, N, IA, JA, IB, JB DOUBLE PRECISION ALPHA INTEGER DESCA( * ), DESCB( * ) DOUBLE PRECISION A( * ), B( * ) WRITE(*,*) 'Error. PDTRSM should not be called.' STOP RETURN END SUBROUTINE pdtrsm C*********************************************************************** SUBROUTINE pcunmqr( SIDE, TRANS, M, N, K, A, IA, JA, & DESCA, TAU, C, IC, JC, DESCC, WORK, & LWORK, INFO ) IMPLICIT NONE CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N INTEGER DESCA( * ), DESCC( * ) COMPLEX A( * ), C( * ), TAU( * ), WORK( * ) WRITE(*,*) 'Error. PCUNMQR should not be called.' STOP RETURN END SUBROUTINE pcunmqr C*********************************************************************** SUBROUTINE pzunmqr( SIDE, TRANS, M, N, K, A, IA, JA, & DESCA, TAU, C, IC, JC, DESCC, WORK, & LWORK, INFO ) IMPLICIT NONE CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N INTEGER DESCA( * ), DESCC( * ) C DOUBLE COMPLEX A( * ), C( * ), TAU( * ), WORK( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ), C( * ), TAU( * ), WORK( * ) WRITE(*,*) 'Error. PZUNMQR should not be called.' STOP RETURN END SUBROUTINE pzunmqr C*********************************************************************** SUBROUTINE psormqr( SIDE, TRANS, M, N, K, A, IA, JA, & DESCA, TAU, C, IC, JC, DESCC, WORK, & LWORK, INFO ) IMPLICIT NONE CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N INTEGER DESCA( * ), DESCC( * ) REAL A( * ), C( * ), TAU( * ), WORK( * ) WRITE(*,*) 'Error. PSORMQR should not be called.' STOP RETURN END SUBROUTINE psormqr C*********************************************************************** SUBROUTINE pdormqr( SIDE, TRANS, M, N, K, A, IA, JA, & DESCA, TAU, C, IC, JC, DESCC, WORK, & LWORK, INFO ) IMPLICIT NONE CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N INTEGER DESCA( * ), DESCC( * ) DOUBLE PRECISION A( * ), C( * ), TAU( * ), WORK( * ) WRITE(*,*) 'Error. PDORMQR should not be called.' STOP RETURN END SUBROUTINE pdormqr C*********************************************************************** SUBROUTINE chk1mat( MA, MAPOS0, NA, NAPOS0, IA, JA, DESCA, & DESCAPOS0, INFO ) IMPLICIT NONE INTEGER DESCAPOS0, IA, INFO, JA, MA, MAPOS0, NA, NAPOS0 INTEGER DESCA( * ) WRITE(*,*) 'Error. CHK1MAT should not be called.' STOP RETURN END SUBROUTINE chk1mat C*********************************************************************** SUBROUTINE pchk2mat( MA, MAPOS0, NA, NAPOS0, IA, JA, DESCA, & DESCAPOS0, MB, MBPOS0, NB, NBPOS0, IB, JB, & DESCB, DESCBPOS0, NEXTRA, EX, EXPOS, INFO ) IMPLICIT NONE INTEGER DESCAPOS0, DESCBPOS0, IA, IB, INFO, JA, JB, MA, & MAPOS0, MB, MBPOS0, NA, NAPOS0, NB, NBPOS0, & NEXTRA INTEGER DESCA( * ), DESCB( * ), EX( NEXTRA ), & EXPOS( NEXTRA ) WRITE(*,*) 'Error. PCHK2MAT should not be called.' STOP RETURN END SUBROUTINE pchk2mat C*********************************************************************** SUBROUTINE pxerbla( CONTXT, SRNAME, INFO ) IMPLICIT NONE INTEGER CONTXT, INFO CHARACTER SRNAME WRITE(*,*) 'Error. PXERBLA should not be called.' STOP RETURN END SUBROUTINE pxerbla C*********************************************************************** SUBROUTINE descset( DESC, M, N, MB, NB, IRSRC, ICSRC, ICTXT, & LLD ) IMPLICIT NONE INTEGER ICSRC, ICTXT, IRSRC, LLD, M, MB, N, NB INTEGER DESC( * ) WRITE(*,*) 'Error. DESCSET should not be called.' STOP RETURN END SUBROUTINE descset SUBROUTINE MPI_COMM_CREATE_ERRHANDLER(COMM_ERRHANDLER_FN, & ERRHANDLER, IERROR) IMPLICIT NONE EXTERNAL COMM_ERRHANDLER_FN INTEGER ERRHANDLER, IERROR RETURN END SUBROUTINE MPI_COMM_CREATE_ERRHANDLER SUBROUTINE MPI_ERRHANDLER_FREE(ERRHANDLER, IERROR) IMPLICIT NONE INTEGER ERRHANDLER, IERROR RETURN END SUBROUTINE MPI_ERRHANDLER_FREE MUMPS_5.8.1/PORD/0000775000175000017500000000000015042446416013210 5ustar amestoyamestoyMUMPS_5.8.1/PORD/include/0000775000175000017500000000000015042446416014633 5ustar amestoyamestoyMUMPS_5.8.1/PORD/include/space.h0000664000175000017500000000276415042446416016110 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: space.h / / author J"urgen Schulze, University of Paderborn / created 99sep14 / / This file includes all necessary header files / ******************************************************************************/ #include #include #include #include #include #ifndef _WIN32 #include #endif #if defined(__MINGW32__) #include #endif #include #ifdef PARIX #ifdef __EPX #include #include #include #include #include #include #include #else #include #include #include #include #include #include #include #endif #include #endif #ifdef MPI #include "mpi.h" #endif #include "const.h" #include "params.h" #include "macros.h" #include "types.h" #include "protos.h" #include "eval.h" #define FORTRAN(nu,nl,pl,pc) \ void nu (); \ void nl pl \ { nu pc; } \ void nl##_ pl \ { nu pc; } \ void nl##__ pl \ { nu pc; } \ void nu pl MUMPS_5.8.1/PORD/include/types.h0000664000175000017500000002053515042446416016155 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: types.h / / author J"urgen Schulze, University of Paderborn / created 99sep14 / / This file contains the fundamental data structures / ******************************************************************************/ /***************************************************************************** A macro defining the size of integers (modified for compatibility with MUMPS) ******************************************************************************/ #if defined(INTSIZE64) || defined(PORD_INTSIZE64) #include #define PORD_INT int64_t #else #define PORD_INT int #endif typedef double FLOAT; typedef PORD_INT options_t; typedef FLOAT timings_t; /***************************************************************************** Graph object ******************************************************************************/ typedef struct _graph { PORD_INT nvtx; PORD_INT nedges; PORD_INT type; PORD_INT totvwght; PORD_INT *xadj; PORD_INT *adjncy; PORD_INT *vwght; } graph_t; /***************************************************************************** Graph bisection object ******************************************************************************/ typedef struct _gbisect { graph_t *G; PORD_INT *color; PORD_INT cwght[3]; } gbisect_t; /***************************************************************************** Domain decomposition object ******************************************************************************/ typedef struct _domdec { graph_t *G; PORD_INT ndom; PORD_INT domwght; PORD_INT *vtype; PORD_INT *color; PORD_INT cwght[3]; PORD_INT *map; struct _domdec *prev, *next; } domdec_t; /***************************************************************************** Bipartite graph object ******************************************************************************/ typedef struct _gbipart { graph_t *G; PORD_INT nX; PORD_INT nY; } gbipart_t; /***************************************************************************** Recursive nested dissection object ******************************************************************************/ typedef struct _nestdiss { graph_t *G; PORD_INT *map; PORD_INT depth; PORD_INT nvint; PORD_INT *intvertex; PORD_INT *intcolor; PORD_INT cwght[3]; struct _nestdiss *parent, *childB, *childW; } nestdiss_t; /***************************************************************************** Multisector object ******************************************************************************/ typedef struct _multisector { graph_t *G; PORD_INT *stage; PORD_INT nstages; PORD_INT nnodes; PORD_INT totmswght; } multisector_t; /***************************************************************************** Elimination graph object ******************************************************************************/ typedef struct _gelim { graph_t *G; PORD_INT maxedges; PORD_INT *len; PORD_INT *elen; PORD_INT *parent; PORD_INT *degree; PORD_INT *score; } gelim_t; /***************************************************************************** Bucket structure object ******************************************************************************/ typedef struct _bucket { PORD_INT maxbin, maxitem; PORD_INT offset; PORD_INT nobj; PORD_INT minbin; PORD_INT *bin; PORD_INT *next; PORD_INT *last; PORD_INT *key; } bucket_t; /***************************************************************************** Minimum priority object ******************************************************************************/ typedef struct _stageinfo stageinfo_t; typedef struct _minprior { gelim_t *Gelim; multisector_t *ms; bucket_t *bucket; stageinfo_t *stageinfo; PORD_INT *reachset; PORD_INT nreach; PORD_INT *auxaux; PORD_INT *auxbin; PORD_INT *auxtmp; PORD_INT flag; } minprior_t; struct _stageinfo { PORD_INT nstep; PORD_INT welim; PORD_INT nzf; FLOAT ops; }; /***************************************************************************** Elimination tree object ******************************************************************************/ typedef struct _elimtree { PORD_INT nvtx; PORD_INT nfronts; PORD_INT root; PORD_INT *ncolfactor; PORD_INT *ncolupdate; PORD_INT *parent; PORD_INT *firstchild; PORD_INT *silbings; PORD_INT *vtx2front; } elimtree_t; /***************************************************************************** Input matrix object ******************************************************************************/ typedef struct _inputMtx { PORD_INT neqs; PORD_INT nelem; FLOAT *diag; FLOAT *nza; PORD_INT *xnza; PORD_INT *nzasub; } inputMtx_t; /***************************************************************************** Dense matrix object ******************************************************************************/ typedef struct _workspace workspace_t; typedef struct _denseMtx { workspace_t *ws; PORD_INT front; PORD_INT owned; PORD_INT ncol; PORD_INT nrow; PORD_INT nelem; PORD_INT nfloats; PORD_INT *colind; PORD_INT *rowind; PORD_INT *collen; FLOAT *entries; FLOAT *mem; struct _denseMtx *prevMtx, *nextMtx; } denseMtx_t; struct _workspace { FLOAT *mem; PORD_INT size; PORD_INT maxsize; PORD_INT incr; denseMtx_t *lastMtx; }; /***************************************************************************** Compressed subscript structure object ******************************************************************************/ typedef struct _css { PORD_INT neqs; PORD_INT nind; PORD_INT owned; PORD_INT *xnzl; PORD_INT *nzlsub; PORD_INT *xnzlsub; } css_t; /***************************************************************************** Front subscript object ******************************************************************************/ typedef struct _frontsub { elimtree_t *PTP; PORD_INT nind; PORD_INT *xnzf; PORD_INT *nzfsub; } frontsub_t; /***************************************************************************** Factor matrix object ******************************************************************************/ typedef struct _factorMtx { PORD_INT nelem; PORD_INT *perm; FLOAT *nzl; css_t *css; frontsub_t *frontsub; } factorMtx_t; /***************************************************************************** Mapping object ******************************************************************************/ typedef struct _groupinfo groupinfo_t; typedef struct { elimtree_t *T; PORD_INT dimQ; PORD_INT maxgroup; PORD_INT *front2group; groupinfo_t *groupinfo; } mapping_t; struct _groupinfo { FLOAT ops; PORD_INT nprocs; PORD_INT nfronts; }; /***************************************************************************** Topology object ******************************************************************************/ typedef struct { PORD_INT nprocs; PORD_INT mygridId; PORD_INT dimX; PORD_INT dimY; PORD_INT myQId; PORD_INT dimQ; PORD_INT *cube2grid; #ifdef PARIX LinkCB_t **link; #endif #ifdef MPI MPI_Comm comm; MPI_Status status; #endif } topology_t; /***************************************************************************** Communication buffer object ******************************************************************************/ typedef struct { char *data; size_t len; size_t maxlen; } buffer_t; /***************************************************************************** Bit mask object ******************************************************************************/ typedef struct { PORD_INT dimQ; PORD_INT maxgroup; PORD_INT mygroupId; PORD_INT offset; PORD_INT *group; PORD_INT *colbits, *colmask; PORD_INT *rowbits, *rowmask; } mask_t; MUMPS_5.8.1/PORD/include/protos.h0000664000175000017500000003223615042446416016340 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: protos.h / / author J"urgen Schulze, University of Paderborn / created 99sep14 / / This file contains the prototypes of all non-static functions / ******************************************************************************/ /* functions in lib/greg_pord.h */ PORD_INT greg_pord(PORD_INT, PORD_INT, PORD_INT *, PORD_INT *, PORD_INT *, PORD_INT *, PORD_INT *); /* functions in lib/graph.c */ graph_t* newGraph(PORD_INT, PORD_INT); void freeGraph(graph_t*); void printGraph(graph_t*); void randomizeGraph(graph_t*); graph_t* setupSubgraph(graph_t*, PORD_INT*, PORD_INT, PORD_INT*); graph_t* setupGraphFromMtx(inputMtx_t*); graph_t* setupGridGraph(PORD_INT, PORD_INT, PORD_INT); PORD_INT connectedComponents(graph_t*); graph_t* compressGraph(graph_t*, PORD_INT*); /* functions in lib/gbisect.c */ gbisect_t* newGbisect(graph_t*); void freeGbisect(gbisect_t*); void printGbisect(gbisect_t*); void checkSeparator(gbisect_t*); void constructSeparator(gbisect_t*, options_t*, timings_t*); PORD_INT smoothBy2Layers(gbisect_t*, PORD_INT*, PORD_INT*, PORD_INT, PORD_INT); void smoothSeparator(gbisect_t*, options_t*); /* functions in lib/ddcreate.c */ domdec_t* newDomainDecomposition(PORD_INT, PORD_INT); void freeDomainDecomposition(domdec_t*); void printDomainDecomposition(domdec_t*); void checkDomainDecomposition(domdec_t*); void buildInitialDomains(graph_t*, PORD_INT*, PORD_INT*, PORD_INT*); void mergeMultisecs(graph_t *G, PORD_INT*, PORD_INT*); domdec_t* initialDomainDecomposition(graph_t*, PORD_INT*, PORD_INT*, PORD_INT*); domdec_t* constructDomainDecomposition(graph_t*, PORD_INT*); void computePriorities(domdec_t*, PORD_INT*, PORD_INT*, PORD_INT); void eliminateMultisecs(domdec_t*, PORD_INT*, PORD_INT*); void findIndMultisecs(domdec_t*, PORD_INT*, PORD_INT*); domdec_t* coarserDomainDecomposition(domdec_t*, PORD_INT*); void shrinkDomainDecomposition(domdec_t*, PORD_INT); /* functions in lib/ddbisect.c */ void checkDDSep(domdec_t*); PORD_INT findPseudoPeripheralDomain(domdec_t*, PORD_INT); void constructLevelSep(domdec_t*, PORD_INT); void initialDDSep(domdec_t*); void updateB2W(bucket_t*, bucket_t*, domdec_t*, PORD_INT, PORD_INT*, PORD_INT*, PORD_INT*, PORD_INT*); void updateW2B(bucket_t*, bucket_t*, domdec_t*, PORD_INT, PORD_INT*, PORD_INT*, PORD_INT*, PORD_INT*); void improveDDSep(domdec_t*); /* functions in lib/gbipart.c */ gbipart_t* newBipartiteGraph(PORD_INT, PORD_INT, PORD_INT); void freeBipartiteGraph(gbipart_t*); void printGbipart(gbipart_t*); gbipart_t* setupBipartiteGraph(graph_t*, PORD_INT*, PORD_INT, PORD_INT, PORD_INT*); void maximumMatching(gbipart_t*, PORD_INT*); void maximumFlow(gbipart_t*, PORD_INT*, PORD_INT*); void DMviaMatching(gbipart_t*, PORD_INT*, PORD_INT*, PORD_INT*); void DMviaFlow(gbipart_t*, PORD_INT*, PORD_INT*, PORD_INT*, PORD_INT*); /* functions in lib/nestdiss.c */ nestdiss_t* newNDnode(graph_t*, PORD_INT*, PORD_INT); void freeNDnode(nestdiss_t*); nestdiss_t* setupNDroot(graph_t*, PORD_INT*); void splitNDnode(nestdiss_t*, options_t*, timings_t*); void buildNDtree(nestdiss_t*, options_t*, timings_t*); void freeNDtree(nestdiss_t*); /* functions in lib/multisector.c */ multisector_t* newMultisector(graph_t*); void freeMultisector(multisector_t*); multisector_t* trivialMultisector(graph_t*); multisector_t* constructMultisector(graph_t*, options_t*, timings_t*); multisector_t* extractMS2stage(nestdiss_t*); multisector_t* extractMSmultistage(nestdiss_t*); /* functions in lib/gelim.c */ gelim_t* newElimGraph(PORD_INT, PORD_INT); void freeElimGraph(gelim_t*); void printElimGraph(gelim_t*); gelim_t* setupElimGraph(graph_t*); PORD_INT crunchElimGraph(gelim_t*); void buildElement(gelim_t *Gelim, PORD_INT me); void updateAdjncy(gelim_t*, PORD_INT*, PORD_INT, PORD_INT*, PORD_INT*); void findIndNodes(gelim_t*, PORD_INT*, PORD_INT, PORD_INT*, PORD_INT*, PORD_INT*, PORD_INT*); void updateDegree(gelim_t*, PORD_INT*, PORD_INT, PORD_INT*); void updateScore(gelim_t*, PORD_INT*, PORD_INT, PORD_INT, PORD_INT*); elimtree_t* extractElimTree(gelim_t*); /* functions in lib/bucket.c */ bucket_t* newBucket(PORD_INT, PORD_INT, PORD_INT); void freeBucket(bucket_t*); bucket_t* setupBucket(PORD_INT, PORD_INT, PORD_INT); PORD_INT minBucket(bucket_t*); void insertBucket(bucket_t*, PORD_INT, PORD_INT); void removeBucket(bucket_t*, PORD_INT); /* functions in lib/minpriority.c */ minprior_t* newMinPriority(PORD_INT nvtx, PORD_INT nstages); void freeMinPriority(minprior_t*); minprior_t* setupMinPriority(multisector_t*); elimtree_t* orderMinPriority(minprior_t*, options_t*, timings_t*); void eliminateStage(minprior_t*, PORD_INT, PORD_INT, timings_t*); PORD_INT eliminateStep(minprior_t*, PORD_INT, PORD_INT); /* functions in lib/tree.c */ elimtree_t* newElimTree(PORD_INT, PORD_INT); void freeElimTree(elimtree_t*); void printElimTree(elimtree_t *); PORD_INT firstPostorder(elimtree_t*); PORD_INT firstPostorder2(elimtree_t*, PORD_INT); PORD_INT nextPostorder(elimtree_t*, PORD_INT); PORD_INT firstPreorder(elimtree_t*); PORD_INT nextPreorder(elimtree_t*, PORD_INT); elimtree_t* setupElimTree(graph_t*, PORD_INT*, PORD_INT*); void initFchSilbRoot(elimtree_t*); void permFromElimTree(elimtree_t*, PORD_INT*); elimtree_t* expandElimTree(elimtree_t*, PORD_INT*, PORD_INT); elimtree_t* permuteElimTree(elimtree_t*, PORD_INT*); elimtree_t* fundamentalFronts(elimtree_t*); elimtree_t* mergeFronts(elimtree_t*, PORD_INT); elimtree_t* compressElimTree(elimtree_t*, PORD_INT*, PORD_INT); PORD_INT justifyFronts(elimtree_t*); PORD_INT nWorkspace(elimtree_t*); PORD_INT nFactorIndices(elimtree_t*); PORD_INT nFactorEntries(elimtree_t*); FLOAT nFactorOps(elimtree_t*); void subtreeFactorOps(elimtree_t*, FLOAT*); FLOAT nTriangularOps(elimtree_t*); /* functions in lib/matrix.c */ inputMtx_t* newInputMtx(PORD_INT, PORD_INT); void freeInputMtx(inputMtx_t*); void printInputMtx(inputMtx_t*); denseMtx_t* newDenseMtx(workspace_t*, PORD_INT); void freeDenseMtx(denseMtx_t*); void printDenseMtx(denseMtx_t*); void checkDenseMtx(denseMtx_t*); workspace_t* initWorkspaceForDenseMtx(PORD_INT, PORD_INT); FLOAT* getWorkspaceForDenseMtx(workspace_t*, PORD_INT); void freeWorkspaceForDenseMtx(workspace_t*); inputMtx_t* setupInputMtxFromGraph(graph_t*); inputMtx_t* setupLaplaceMtx(PORD_INT, PORD_INT, PORD_INT); inputMtx_t* permuteInputMtx(inputMtx_t*, PORD_INT*); /* functions in lib/symbfac.c */ css_t* newCSS(PORD_INT, PORD_INT, PORD_INT); void freeCSS(css_t*); css_t* setupCSSFromGraph(graph_t*, PORD_INT*, PORD_INT*); css_t* setupCSSFromFrontSubscripts(frontsub_t*); frontsub_t* newFrontSubscripts(elimtree_t*); void freeFrontSubscripts(frontsub_t*); void printFrontSubscripts(frontsub_t*); frontsub_t* setupFrontSubscripts(elimtree_t*, inputMtx_t*); factorMtx_t* newFactorMtx(PORD_INT); void freeFactorMtx(factorMtx_t*); void printFactorMtx(factorMtx_t*); void initFactorMtx(factorMtx_t *L, inputMtx_t*); void initFactorMtxNEW(factorMtx_t *L, inputMtx_t*); /* functions in lib/numfac.c */ void numfac(factorMtx_t *L, timings_t *cpus); denseMtx_t* setupFrontalMtx(workspace_t*, factorMtx_t*, PORD_INT); void initLocalIndices(denseMtx_t*, PORD_INT*, PORD_INT*); denseMtx_t* extendedAdd(denseMtx_t*, denseMtx_t*, PORD_INT*, PORD_INT*); denseMtx_t* setupUpdateMtxFromFrontalMtx(denseMtx_t*, factorMtx_t*); /* functions in lib/kernel.c */ denseMtx_t* factorize1x1Kernel(denseMtx_t*, PORD_INT); denseMtx_t* factorize2x2Kernel(denseMtx_t*, PORD_INT); denseMtx_t* factorize3x3Kernel(denseMtx_t*, PORD_INT); /* functions in lib/triangular.c */ void forwardSubst1x1(factorMtx_t*, FLOAT*); void backwardSubst1x1(factorMtx_t*, FLOAT*); void forwardSubst1x1NEW(factorMtx_t*, FLOAT*); void backwardSubst1x1NEW(factorMtx_t*, FLOAT*); /* functions in lib/mapping.c */ mapping_t* newMapping(elimtree_t*, PORD_INT); void freeMapping(mapping_t*); void printMapping(mapping_t*); void listing(mapping_t*, PORD_INT, PORD_INT, PORD_INT, FLOAT*, FLOAT*); mapping_t* setupMapping(elimtree_t*, PORD_INT, PORD_INT); void split(mapping_t*, PORD_INT, PORD_INT, PORD_INT, PORD_INT*, PORD_INT*, FLOAT*, PORD_INT); /* functions in lib/interface.c */ elimtree_t* SPACE_ordering(graph_t*, options_t*, timings_t*); elimtree_t* SPACE_transformElimTree(elimtree_t*, PORD_INT); factorMtx_t* SPACE_symbFac(elimtree_t*, inputMtx_t*); void SPACE_numFac(factorMtx_t*, timings_t*); void SPACE_solveTriangular(factorMtx_t *L, FLOAT *rhs, FLOAT *xvec); void SPACE_solve(inputMtx_t*, FLOAT*, FLOAT*, options_t*, timings_t*); void SPACE_solveWithPerm(inputMtx_t*, PORD_INT*, FLOAT*, FLOAT*, options_t*, timings_t*); mapping_t* SPACE_mapping(graph_t*, PORD_INT*, options_t*, timings_t*); /* functions in lib/sort.c */ void insertUpInts(PORD_INT, PORD_INT*); void insertUpIntsWithStaticIntKeys(PORD_INT, PORD_INT*, PORD_INT*); void insertDownIntsWithStaticFloatKeys(PORD_INT, PORD_INT*, FLOAT*); void insertUpFloatsWithIntKeys(PORD_INT, FLOAT*, PORD_INT*); void qsortUpInts(PORD_INT, PORD_INT*, PORD_INT*); void qsortUpFloatsWithIntKeys(PORD_INT, FLOAT*, PORD_INT*, PORD_INT*); void distributionCounting(PORD_INT, PORD_INT*, PORD_INT*); /* functions in lib/read.c */ graph_t* readChacoGraph(char*); inputMtx_t* readHarwellBoeingMtx(char*); /* functions in libPAR/topology.c */ topology_t* newTopology(PORD_INT); void freeTopology(topology_t*); void printTopology(topology_t*); topology_t* setupTopology(void); void recMapCube(topology_t*, PORD_INT, PORD_INT, PORD_INT, PORD_INT, PORD_INT, PORD_INT); void sendCube(topology_t*, void*, size_t, PORD_INT); size_t recvCube(topology_t*, void*, size_t, PORD_INT); PORD_INT myrank(void); /* functions in libPAR/mask.c */ mask_t* newMask(PORD_INT); void freeMask(mask_t*); mask_t* setupMask(PORD_INT, PORD_INT, PORD_INT); /* functions in libPAR/broadcast.c */ void broadcastInputMtx(topology_t*, inputMtx_t**); void broadcastElimTree(topology_t*, elimtree_t**); void broadcastArray(topology_t*, char*, size_t); /* functions in libPAR/buffer.c */ buffer_t* newBuffer(size_t); void freeBuffer(buffer_t*); buffer_t* exchangeBuffer(topology_t*, buffer_t*, PORD_INT); buffer_t* setupSymbFacBuffer(frontsub_t*, PORD_INT*); void readoutSymbFacBuffer(buffer_t*, frontsub_t*, PORD_INT*); buffer_t* setupNumFacBuffer(workspace_t*, mask_t*, PORD_INT); void readoutNumFacBuffer(workspace_t*, buffer_t*, denseMtx_t**); buffer_t* setupTriangularBuffer(frontsub_t*, PORD_INT*, FLOAT*); void readoutTriangularBuffer(buffer_t*, frontsub_t*, PORD_INT*, FLOAT*); /* functions in libPAR/symbfacPAR.c */ frontsub_t* newFrontSubscriptsPAR(mask_t*, mapping_t*, elimtree_t*); frontsub_t* setupFrontSubscriptsPAR(topology_t*, mask_t*, mapping_t*, elimtree_t*, inputMtx_t*); css_t* setupCSSFromFrontSubscriptsPAR(mask_t*, mapping_t*, frontsub_t*); void initFactorMtxPAR(mask_t*, mapping_t*, factorMtx_t*, inputMtx_t*); /* functions in libPAR/numfacPAR.c */ void numfacPAR(topology_t*, mask_t*, mapping_t*, factorMtx_t*, PORD_INT msglvl, timings_t*); denseMtx_t* setupFrontalMtxPAR(mask_t*, PORD_INT, workspace_t*, factorMtx_t*, PORD_INT); void initLocalIndicesPAR(denseMtx_t*, PORD_INT*, PORD_INT*); denseMtx_t* extendedAddPAR(denseMtx_t*, denseMtx_t*, PORD_INT*, PORD_INT*); denseMtx_t* setupUpdateMtxFromFrontalMtxPAR(denseMtx_t*, factorMtx_t*); denseMtx_t* setupUpdateMtxFromBuffer(workspace_t*, FLOAT*); void splitDenseMtxColumnWise(denseMtx_t*, mask_t*, buffer_t*, PORD_INT); void splitDenseMtxRowWise(denseMtx_t*, mask_t*, buffer_t*, PORD_INT); /* functions in libPAR/kernelPAR.c */ denseMtx_t* factorize1x1KernelPAR(topology_t*, mask_t*, PORD_INT, denseMtx_t*, frontsub_t*, timings_t*); denseMtx_t* factorize2x2KernelPAR(topology_t*, mask_t*, PORD_INT, denseMtx_t*, frontsub_t*, timings_t*); denseMtx_t* factorize3x3KernelPAR(topology_t*, mask_t*, PORD_INT, denseMtx_t*, frontsub_t*, timings_t*); /* functions in libPAR/triangularPAR.c */ void forwardSubst1x1PAR(topology_t*, mask_t*, mapping_t*, factorMtx_t*, FLOAT*, FLOAT*); void backwardSubst1x1PAR(topology_t*, mask_t*, mapping_t*, factorMtx_t*, FLOAT*); void forwardSubst1x1KernelPAR(topology_t*, mask_t*, PORD_INT, PORD_INT, factorMtx_t*, FLOAT*, FLOAT*); void backwardSubst1x1KernelPAR(topology_t*, mask_t*, PORD_INT, PORD_INT, factorMtx_t*, FLOAT*); void accumulateVector(topology_t*, mask_t*, mapping_t*, factorMtx_t*, FLOAT*); /* functions in libPAR/interfacePAR.c */ topology_t* SPACE_setupTopology(void); mask_t* SPACE_setupMask(topology_t*, PORD_INT); void SPACE_cleanup(topology_t*, mask_t*); factorMtx_t* SPACE_symbFacPAR(topology_t*, mask_t*, mapping_t*, elimtree_t*, inputMtx_t*); void SPACE_numFacPAR(topology_t*, mask_t*, mapping_t*, factorMtx_t*, PORD_INT msglvl, timings_t*); void SPACE_solveTriangularPAR(topology_t*, mask_t*, mapping_t*, factorMtx_t*, FLOAT*, FLOAT*); void SPACE_solveWithPermPAR(topology_t *top, mask_t *mask, inputMtx_t *A, PORD_INT *perm, FLOAT *rhs, FLOAT *xvec, options_t *options, timings_t *cpus); MUMPS_5.8.1/PORD/include/const.h0000664000175000017500000001027415042446416016136 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: const.h / / author J"urgen Schulze, University of Paderborn / created 99sep14 / / This file contains constant definitions / ******************************************************************************/ /* matrix types */ #define GRID 0 #define MESH 1 #define TORUS 2 #define HB 3 /* graph types */ #define UNWEIGHTED 0 #define WEIGHTED 1 /* type of ordering */ #define MINIMUM_PRIORITY 0 #define INCOMPLETE_ND 1 #define MULTISECTION 2 #define TRISTAGE_MULTISECTION 3 /* fill-reducing node selection strategies */ #define AMD 0 #define AMF 1 #define AMMF 2 #define AMIND 3 /* node selection strategies for generating the domain decompositions */ #define QMD 0 #define QMRDV 1 #define QRAND 2 /* default options for SPACE */ #define SPACE_ORDTYPE MULTISECTION #define SPACE_NODE_SELECTION1 AMMF #define SPACE_NODE_SELECTION2 AMMF #define SPACE_NODE_SELECTION3 QMRDV #define SPACE_DOMAIN_SIZE 200 #define SPACE_MSGLVL 2 #define SPACE_ETREE_NONZ 256 #define SPACE_ETREE_BAL 5 #define SPACE_MASK_OFFSET 2 /* misc. constants */ #define TRUE 1 #define FALSE 0 #define ERR -1 #define NOERR 0 #define MAX_LINE_LEN 255 #define MAX_INT ((1<<30)-1) #define MAX_FLOAT 1e31 #define EPS 0.001 /* constants used in color array */ /* these constants are also used as an index (do not change) */ #define GRAY 0 #define BLACK 1 #define WHITE 2 /* constants for the Dulmage-Mendelsohn decomposition (dmflags) */ /* these constants are also used as an index (do not change) */ #define SI 0 /* node e X is reachable via exposed node e X */ #define SX 1 /* node e X is reachable via exposed node e Y */ #define SR 2 /* SR = X - (SI u SX) */ #define BI 3 /* node e Y is reachable via exposed node e Y */ #define BX 4 /* node e Y is reachable via exposed node e X */ #define BR 5 /* BR = Y - (BI u BX) */ /* size/indices of option array (do not change) */ #define ORD_OPTION_SLOTS 7 #define OPTION_ORDTYPE 0 #define OPTION_NODE_SELECTION1 1 #define OPTION_NODE_SELECTION2 2 #define OPTION_NODE_SELECTION3 3 #define OPTION_DOMAIN_SIZE 4 #define OPTION_MSGLVL 5 #define OPTION_ETREE_NONZ 6 /* size/indices for timing array in ordering computation */ #define ORD_TIME_SLOTS 12 #define TIME_COMPRESS 0 /* 0. TIME_COMPRESS */ #define TIME_MS 1 /* 1. TIME_MS */ #define TIME_MULTILEVEL 2 /* 1.1 TIME_MULTILEVEL */ #define TIME_INITDOMDEC 3 /* 1.1.1 TIME_INITDOMDEC */ #define TIME_COARSEDOMDEC 4 /* 1.1.2 TIME_COARSEDOMDEC */ #define TIME_INITSEP 5 /* 1.1.3 TIME_INITSEP */ #define TIME_REFINESEP 6 /* 1.1.4 TIME_REFINESEP */ #define TIME_SMOOTH 7 /* 1.2 TIME_SMOOTH */ #define TIME_BOTTOMUP 8 /* 2. TIME_BOTTOMUP */ #define TIME_UPDADJNCY 9 /* 2.1 TIME_UPDADJNCY */ #define TIME_FINDINODES 10 /* 2.2 TIME_FINDINODES */ #define TIME_UPDSCORE 11 /* 2.3 TIME_UPDSCORE */ /* size/indices for timing array in sequential numerical factorization */ #define NUMFAC_TIME_SLOTS 4 #define TIME_INITFRONT 0 #define TIME_EXADD 1 #define TIME_KERNEL 2 #define TIME_INITUPD 3 /* size/indices for timing array in parallel numerical factorization */ #define NUMFACPAR_TIME_SLOTS 9 #define TIME_INITFRONT 0 #define TIME_EXADD 1 #define TIME_KERNEL 2 #define TIME_INITUPD 3 #define TIME_EXCHANGE 4 #define TIME_INITFRONTPAR 5 #define TIME_EXADDPAR 6 #define TIME_KERNELPAR 7 #define TIME_INITUPDPAR 8 /* size/indices for timing array in parallel kernel */ #define KERNELPAR_TIME_SLOTS 4 #define TIME_PIVOT 0 #define TIME_PIVOT_WAIT 1 #define TIME_CMOD 2 #define TIME_CMOD_WAIT 3 MUMPS_5.8.1/PORD/include/macros.h0000664000175000017500000000434015042446416016271 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: macros.h / / author J"urgen Schulze, University of Paderborn / created 99jan24 / / This file contains some useful macros / ******************************************************************************/ /* Some compilers (VC++ for instance) define a min and a max in the stdlib */ #ifdef min # undef min #endif #ifdef max # undef max #endif #define min(a,b) ((a) < (b) ? (a) : (b)) #define max(a,b) ((a) > (b) ? (a) : (b)) #define mymalloc(ptr, nr, type) \ if (!(ptr = (type*)malloc((max(nr,1)) * sizeof(type)))) \ { printf("malloc failed on line %d of file %s (nr=%d)\n", \ __LINE__, __FILE__, nr); \ exit(ERR); \ } #define myrealloc(ptr, nr, type) \ if (!(ptr = (type*)realloc(ptr, (nr) * sizeof(type)))) \ { printf("realloc failed on line %d of file %s (nr=%d)\n", \ __LINE__, __FILE__, nr); \ exit(ERR); \ } #define myrandom(range) \ rand() % (range); #define swap(a, b, tmp) \ { (tmp) = (a); (a) = (b); (b) = (tmp); } #define seed() \ srand((PORD_INT)time(0) % 10000); #define bit(var, d) \ ((var) & (1 << (d))) #define negbit(var, d) \ ((var) ^ (1 << (d))) #define waitkey() \ { char _s[MAX_LINE_LEN]; printf("\n"); gets(_s); } #define pord_resettimer(var) \ var = 0; #define pord_starttimer(var) \ var -= ((FLOAT)clock()/CLOCKS_PER_SEC); #define pord_stoptimer(var) \ var += ((FLOAT)clock()/CLOCKS_PER_SEC); #define quit() \ exit(ERR); #ifdef PARIX #undef pord_starttimer(var) #ifdef __EPX #define pord_starttimer(var) \ var -= ((FLOAT)TimeNow()/CLOCK_TICK); #else #define pord_starttimer(var) \ var -= ((FLOAT)TimeNowHigh()/CLK_TCK_HIGH); #endif #undef pord_stoptimer(var) #ifdef __EPX #define pord_stoptimer(var) \ var += ((FLOAT)TimeNow()/CLOCK_TICK); #else #define pord_stoptimer(var) \ var += ((FLOAT)TimeNowHigh()/CLK_TCK_HIGH); #endif #undef quit() #define quit() \ exit(ERR); #endif MUMPS_5.8.1/PORD/include/eval.h0000664000175000017500000000427115042446416015737 0ustar amestoyamestoy/***************************************************************************** / / PORD Ordering Library: eval.h / / author J"urgen Schulze, University of Paderborn / created 99mar30 / / This file contains the definition of various separator evaluation functions / ******************************************************************************/ #define F eval1 /* default separator evaluation function */ /* --------------------------------------------------------------------- */ /* SEPARATOR EVALUATION FUNCTION 1 */ /* Size of domains W and B is allowed to differ TOLERANCE * 100 percent. */ /* Within this tolerance the difference is not penalized and only the */ /* size of the separator is returned. Additionally, the mantissa of the */ /* returned value is set to (max-min)/max. */ /* --------------------------------------------------------------------- */ #define TOL1 0.50 /* tolerated imbalance induced by bisector */ #define PEN1 100 /* penalty in case of higher imbalance */ #define eval1(S, B, W) \ S + PEN1 * max(0, max(W,B) * (1-TOL1) - min(W,B)) \ + (FLOAT)(max(W,B)-min(W,B)) / (FLOAT)max(W,B) /* --------------------------------------------------------------------- */ /* SEPARATOR EVALUATION FUNCTION 2 */ /* Ashcraft and Liu (Using domain decomposition to find graph bisectors) */ /* --------------------------------------------------------------------- */ #define alpha 0.1 #define TOL2 0.70 #define PEN2 100 #define eval2(S, B, W) \ S * (1 + alpha * ((FLOAT)max(W,B)/(FLOAT)max(1,min(W,B)))) \ + PEN2 * max(0, max(W,B) * (1-TOL2) - min(W,B)) /* --------------------------------------------------------------------- */ /* SEPARATOR EVALUATION FUNCTION 3 */ /* Ashcraft and Liu (Generalized nested dissection:some recent progress) */ /* --------------------------------------------------------------------- */ #define alpha2 0.33 #define eval3(S, B, W) \ S * S + alpha2 * (max(W,B)-min(W,B)) * (max(W,B)-min(W,B)) MUMPS_5.8.1/PORD/include/params.h0000664000175000017500000000157015042446416016272 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: params.h / / author J"urgen Schulze, University of Paderborn / created 99sep14 / / This file contains parameter definitions / ******************************************************************************/ /* default parameters */ #define MAX_BAD_FLIPS 100 /* interrupt/stop FM */ #define COMPRESS_FRACTION 0.75 /* node reduction in compressed graph */ #define MIN_NODES 100 /* stop recursive separator construction */ #define DEFAULT_SEPS 31 /* default number of separators */ #define MAX_SEPS 255 /* max. number of separators */ #define MIN_DOMAINS 100 /* min. number of domains in a decomp. */ #define MAX_COARSENING_STEPS 10 /* max. number of generated dom. decomp. */ MUMPS_5.8.1/PORD/README0000664000175000017500000000330615042446416014072 0ustar amestoyamestoyACKNOWLEDGEMENT: This directory contains an implementation of the PORD algorithm, as described in: "Towards a tighter coupling of bottom-up and top-down sparse matrix ordering methods, J. Schulze, BIT, 41:4, pp 800, 2001." It is extracted from the SPACE-1.0 package developed at the University of Paderborn by Juergen Schulze (js@juergenschulze.de). A lot of the code in SPACE-1.0 was itself based on the SPOOLES package by Cleve Ashcraft. We are grateful to Juergen Schulze for letting us distribute PORD. SPACE-1.0 (which includes PORD) is in the public domain, see https://web.archive.org/web/20140426002151/http://www2.cs.uni-paderborn.de/cs/ag-monien/PERSONAL/SCHLUNZ/vrp.html holding a copy of the original web page from Paderborn University (former web page not anymore available: http://www2.cs.uni-paderborn.de/cs/ag-monien/PERSONAL/SCHLUNZ/vrp.html) in which it is indicated "The fill-reducing ordering algorithm has been integrated in a software package called SPACE (SPArse Cholesky Elimination). The package not only provides an easy to use interface to the ordering algorithm, it also offers functions for the symbolical/numerical factorization steps and for the solution of the triangular systems. The factorizations and solves may be computed in serial or in parallel using MPI. In all cases, the important computational kernels are based on BLAS-3 like operations. Although all functions are completely written in C code, the design of the library follows object-oriented principles; there are objects and methods that can be applied to the objects (i.e. object creation, object manipulation). The SPACE library is totally within the public domain; there are absolutely no licensing restrictions. MUMPS_5.8.1/PORD/lib/0000775000175000017500000000000015042446416013756 5ustar amestoyamestoyMUMPS_5.8.1/PORD/lib/symbfac.c0000664000175000017500000004453315042446416015557 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: symbfac.c / / author J"urgen Schulze, University of Paderborn / created 09/15/99 / / This file contains code for the symbolical factorization. / ****************************************************************************** Data type: struct css int neqs; number of equations int nind; number of row subscripts in compressed format int owned; does the object own vector nzlsub? int *xnzl; start of column int *nzlsub; row subscripts int *xnzlsub; start of column's row subscripts struct frontsub elimtree_t *PTP; permuted elimination tree int nind number of indices int *xnzf; start of front subscripts int *nzfsub front subscripts for permuted elimtree PTP struct factorMtx int nelem; number of nonzeros (incl. diagonal entries) int *perm; permutation vector FLOAT *nzl; vector of nonzeros (incl. diagonal entries) css_t *css; compressed subscript structure of factorMtx frontsub_t *frontsub; front subscripts Comments: Methods in lib/symbfac.c: - css = newCSS(int neqs, int nind, int owned); - void freeCSS(css_t *css); - css = setupCSSFromGraph(graph_t *G, int *perm, int *invp); - css = setupCSSFromFrontSubscripts(frontsub_t *frontsub); - frontsub = newFrontSubscripts(elimtree_t *PTP); - void freeFrontSubscripts(frontsub_t *frontsub); - void printFrontSubscripts(frontsub_t *frontsub); - frontsub = setupFrontSubscripts(elimtree_t *PTP, inputMtx_t *PAP); - L = newFactorMtx(int nelem); - void freeFactorMtx(factorMtx_t *L); - void printFactorMtx(factorMtx_t *L); - void initFactorMtx(factorMtx_t *L, inputMtx_t *PAP); - void initFactorMtxNEW(factorMtx_t *L, inputMtx_t *PAP); ******************************************************************************/ #include /***************************************************************************** ******************************************************************************/ css_t* newCSS(PORD_INT neqs, PORD_INT nind, PORD_INT owned) { css_t *css; mymalloc(css, 1, css_t); mymalloc(css->xnzl, (neqs+1), PORD_INT); mymalloc(css->xnzlsub, neqs, PORD_INT); if (owned) { mymalloc(css->nzlsub, nind, PORD_INT); } else { css->nzlsub = NULL; } css->neqs = neqs; css->nind = nind; css->owned = owned; return(css); } /***************************************************************************** ******************************************************************************/ void freeCSS(css_t *css) { free(css->xnzl); free(css->xnzlsub); if (css->owned) free(css->nzlsub); free(css); } /***************************************************************************** ******************************************************************************/ css_t* setupCSSFromGraph(graph_t *G, PORD_INT *perm, PORD_INT *invp) { css_t *css; PORD_INT *marker, *mergelink, *indices, *tmp, *xnzl, *xnzlsub, *nzlsub; PORD_INT neqs, maxmem, u, v, col, mergecol, knz, mrk, beg, end; PORD_INT fast, len, k, p, e, i, istart, istop; neqs = G->nvtx; maxmem = 2 * neqs; /* ------------------------- set up the working arrays ------------------------- */ mymalloc(marker, neqs, PORD_INT); mymalloc(indices, neqs, PORD_INT); mymalloc(mergelink, neqs, PORD_INT); mymalloc(tmp, neqs, PORD_INT); for (k = 0; k < neqs; k++) marker[k] = mergelink[k] = -1; /* ------------------------------------------------------- allocate storage for the compressed subscript structure ------------------------------------------------------- */ css = newCSS(neqs, maxmem, TRUE); xnzl = css->xnzl; nzlsub = css->nzlsub; xnzlsub = css->xnzlsub; /* ------------------------------------------------------------ main loop: determine the subdiag. row indices of each column ------------------------------------------------------------ */ xnzl[0] = 0; beg = end = 0; for (k = 0; k < neqs; k++) { indices[0] = k; knz = 1; if ((mergecol = mergelink[k]) != -1) /* is k a leaf ??? */ { mrk = marker[mergecol]; fast = TRUE; } else { mrk = k; fast = FALSE; } /* -------------------------- original columns (indices) -------------------------- */ u = invp[k]; istart = G->xadj[u]; istop = G->xadj[u+1]; for (i = istart; i < istop; i++) { v = G->adjncy[i]; if ((col = perm[v]) > k) { indices[knz++] = col; if (marker[col] != mrk) fast = FALSE; } } /* -------------------------- external columns (indices) -------------------------- */ if ((fast) && (mergelink[mergecol] == -1)) { xnzlsub[k] = xnzlsub[mergecol] + 1; knz = xnzl[mergecol+1] - xnzl[mergecol] - 1; } else { for (i = 0; i < knz; i++) marker[indices[i]] = k; while (mergecol != -1) { len = xnzl[mergecol+1] - xnzl[mergecol]; istart = xnzlsub[mergecol]; istop = istart + len; for (i = istart; i < istop; i++) { col = nzlsub[i]; if ((col > k) && (marker[col] != k)) { indices[knz++] = col; marker[col] = k; } } mergecol = mergelink[mergecol]; } qsortUpInts(knz, indices, tmp); /* --------------------------------------------------- store indices in nzlsub; resize nzlsub if too small --------------------------------------------------- */ beg = end; xnzlsub[k] = beg; end = beg + knz; if (end > maxmem) { maxmem += neqs; myrealloc(nzlsub, maxmem, PORD_INT); } len = 0; for (i = beg; i < end; i++) nzlsub[i] = indices[len++]; } /* ---------------------------- append column k to mergelink ---------------------------- */ if (knz > 1) { p = xnzlsub[k]+1; e = nzlsub[p]; mergelink[k] = mergelink[e]; mergelink[e] = k; } xnzl[k+1] = xnzl[k] + knz; } /* ----------------------------- end of main loop: free memory ----------------------------- */ free(marker); free(indices); free(tmp); free(mergelink); /* ------------------------------------------------------ finalize the compressed subscript structure and return ------------------------------------------------------ */ css->nind = xnzlsub[neqs-1] + 1; myrealloc(nzlsub, css->nind, PORD_INT); css->nzlsub = nzlsub; return(css); } /***************************************************************************** ******************************************************************************/ css_t* setupCSSFromFrontSubscripts(frontsub_t *frontsub) { elimtree_t *PTP; css_t *css; PORD_INT *xnzf, *nzfsub, *ncolfactor, *xnzl, *xnzlsub; PORD_INT nind, nvtx, K, beg, knz, firstcol, col; PTP = frontsub->PTP; xnzf = frontsub->xnzf; nzfsub = frontsub->nzfsub; nind = frontsub->nind; nvtx = PTP->nvtx; ncolfactor = PTP->ncolfactor; /* ------------------------------------------------------- allocate storage for the compressed subscript structure ------------------------------------------------------- */ css = newCSS(nvtx, nind, FALSE); css->nzlsub = nzfsub; xnzl = css->xnzl; xnzlsub = css->xnzlsub; /* --------------------------------------- fill the compressed subscript structure --------------------------------------- */ xnzl[0] = 0; for (K = firstPostorder(PTP); K != -1; K = nextPostorder(PTP, K)) { beg = xnzf[K]; knz = xnzf[K+1] - beg; firstcol = nzfsub[beg]; for (col = firstcol; col < firstcol + ncolfactor[K]; col++) { xnzlsub[col] = beg++; xnzl[col+1] = xnzl[col] + knz--; } } return(css); } /***************************************************************************** ******************************************************************************/ frontsub_t* newFrontSubscripts(elimtree_t *PTP) { frontsub_t *frontsub; PORD_INT nfronts, nind; nfronts = PTP->nfronts; nind = nFactorIndices(PTP); mymalloc(frontsub, 1, frontsub_t); mymalloc(frontsub->xnzf, (nfronts+1), PORD_INT); mymalloc(frontsub->nzfsub, nind, PORD_INT); frontsub->PTP = PTP; frontsub->nind = nind; return(frontsub); } /***************************************************************************** ******************************************************************************/ void freeFrontSubscripts(frontsub_t *frontsub) { freeElimTree(frontsub->PTP); free(frontsub->xnzf); free(frontsub->nzfsub); free(frontsub); } /***************************************************************************** ******************************************************************************/ void printFrontSubscripts(frontsub_t *frontsub) { elimtree_t *PTP; PORD_INT *xnzf, *nzfsub, *ncolfactor, *ncolupdate, *parent; PORD_INT nfronts, root, K, count, i, istart, istop; PTP = frontsub->PTP; xnzf = frontsub->xnzf; nzfsub = frontsub->nzfsub; nfronts = PTP->nfronts; root = PTP->root; ncolfactor = PTP->ncolfactor; ncolupdate = PTP->ncolupdate; parent = PTP->parent; printf("#fronts %d, root %d\n", nfronts, root); for (K = firstPostorder(PTP); K != -1; K = nextPostorder(PTP, K)) { printf("--- front %d, ncolfactor %d, ncolupdate %d, parent %d\n", K, ncolfactor[K], ncolupdate[K], parent[K]); count = 0; istart = xnzf[K]; istop = xnzf[K+1]; for (i = istart; i < istop; i++) { printf("%5d", nzfsub[i]); if ((++count % 16) == 0) printf("\n"); } if ((count % 16) != 0) printf("\n"); } } /***************************************************************************** ******************************************************************************/ frontsub_t* setupFrontSubscripts(elimtree_t *PTP, inputMtx_t *PAP) { frontsub_t *frontsub; PORD_INT *ncolfactor, *ncolupdate, *firstchild, *silbings, *vtx2front; PORD_INT *xnza, *nzasub, *xnzf, *nzfsub; PORD_INT *marker, *tmp, *first, *indices; PORD_INT nvtx, nfronts, col, firstcol, knz; PORD_INT u, i, istart, istop, K, J; nvtx = PTP->nvtx; nfronts = PTP->nfronts; ncolfactor = PTP->ncolfactor; ncolupdate = PTP->ncolupdate; firstchild = PTP->firstchild; silbings = PTP->silbings; vtx2front = PTP->vtx2front; xnza = PAP->xnza; nzasub = PAP->nzasub; /* ------------------------- set up the working arrays ------------------------- */ mymalloc(marker, nvtx, PORD_INT); mymalloc(tmp, nvtx, PORD_INT); mymalloc(first, nfronts, PORD_INT); for (i = 0; i < nvtx; i++) marker[i] = -1; /* -------------------------------- find the first column of a front -------------------------------- */ for (u = nvtx-1; u >= 0; u--) { K = vtx2front[u]; first[K] = u; } /* ----------------------------------------- allocate storage for the front subscripts ----------------------------------------- */ frontsub = newFrontSubscripts(PTP); xnzf = frontsub->xnzf; nzfsub = frontsub->nzfsub; knz = 0; for (K = 0; K < nfronts; K++) { xnzf[K] = knz; knz += (ncolfactor[K] + ncolupdate[K]); } xnzf[K] = knz; /* ------------------------------------------- postorder traversal of the elimination tree ------------------------------------------- */ for (K = firstPostorder(PTP); K != -1; K = nextPostorder(PTP, K)) { knz = 0; indices = nzfsub + xnzf[K]; firstcol = first[K]; /* ------------------------------------- internal columns (indices) of front K ------------------------------------- */ for (col = firstcol; col < firstcol + ncolfactor[K]; col++) { indices[knz++] = col; marker[col] = K; } /* ------------------------------------- external columns (indices) of front K ------------------------------------- */ for (J = firstchild[K]; J != -1; J = silbings[J]) { istart = xnzf[J]; istop = xnzf[J+1]; for (i = istart; i < istop; i++) { col = nzfsub[i]; if ((col > firstcol) && (marker[col] != K)) { marker[col] = K; indices[knz++] = col; } } } /* ------------------------------------- original columns (indices) of front K ------------------------------------- */ for (u = 0; u < ncolfactor[K]; u++) { istart = xnza[firstcol + u]; istop = xnza[firstcol + u + 1]; for (i = istart; i < istop; i++) { col = nzasub[i]; if ((col > firstcol) && (marker[col] != K)) { marker[col] = K; indices[knz++] = col; } } } /* ---------------- sort the indices ---------------- */ qsortUpInts(knz, indices, tmp); } /* ---------------------- free memory and return ---------------------- */ free(marker); free(tmp); free(first); return(frontsub); } /***************************************************************************** ******************************************************************************/ factorMtx_t* newFactorMtx(PORD_INT nelem) { factorMtx_t *L; mymalloc(L, 1, factorMtx_t); mymalloc(L->nzl, nelem, FLOAT); L->nelem = nelem; L->css = NULL; L->frontsub = NULL; L->perm = NULL; return(L); } /***************************************************************************** ******************************************************************************/ void freeFactorMtx(factorMtx_t *L) { freeCSS(L->css); freeFrontSubscripts(L->frontsub); free(L->nzl); free(L->perm); free(L); } /***************************************************************************** ******************************************************************************/ void printFactorMtx(factorMtx_t *L) { css_t *css; FLOAT *nzl; PORD_INT *xnzl, *nzlsub, *xnzlsub; PORD_INT neqs, nelem, nind, k, ksub, i, istart, istop; nelem = L->nelem; nzl = L->nzl; css = L->css; neqs = css->neqs; nind = css->nind; xnzl = css->xnzl; nzlsub = css->nzlsub; xnzlsub = css->xnzlsub; printf("#equations %d, #elements (+diag.) %d, #indices (+diag.) %d\n", neqs, nelem, nind); for (k = 0; k < neqs; k++) { printf("--- column %d\n", k); ksub = xnzlsub[k]; istart = xnzl[k]; istop = xnzl[k+1]; for (i = istart; i < istop; i++) printf(" row %5d, entry %e\n", nzlsub[ksub++], nzl[i]); } } /***************************************************************************** ******************************************************************************/ void initFactorMtx(factorMtx_t *L, inputMtx_t *PAP) { elimtree_t *PTP; frontsub_t *frontsub; css_t *css; PORD_INT *ncolfactor; FLOAT *nzl, *nza, *diag; PORD_INT *xnzl, *nzlsub, *xnzlsub, *xnza, *nzasub, *xnzf, *nzfsub; PORD_INT nelem, K, k, kstart, h, hstart, dis, i, istart, istop; PORD_INT firstcol, lastcol; nelem = L->nelem; nzl = L->nzl; css = L->css; xnzl = css->xnzl; nzlsub = css->nzlsub; xnzlsub = css->xnzlsub; frontsub = L->frontsub; PTP = frontsub->PTP; ncolfactor = PTP->ncolfactor; xnzf = frontsub->xnzf; nzfsub = frontsub->nzfsub; diag = PAP->diag; nza = PAP->nza; xnza = PAP->xnza; nzasub = PAP->nzasub; /* ------------------------------------ set all numerical values of L to 0.0 ------------------------------------ */ for (i = 0; i < nelem; i++) nzl[i] = 0.0; /* -------------------------------------------- init. factor matrix with the nonzeros of PAP -------------------------------------------- */ for (K = firstPostorder(PTP); K != -1; K = nextPostorder(PTP, K)) { firstcol = nzfsub[xnzf[K]]; lastcol = firstcol + ncolfactor[K]; for (k = firstcol; k < lastcol; k++) { istart = xnza[k]; istop = xnza[k+1]; kstart = xnzl[k]; hstart = xnzlsub[k]; h = hstart; for (i = istart; i < istop; i++) { for (; nzlsub[h] != nzasub[i]; h++); dis = h - hstart; nzl[kstart+dis] = nza[i]; } nzl[kstart] = diag[k]; } } } /***************************************************************************** ******************************************************************************/ void initFactorMtxNEW(factorMtx_t *L, inputMtx_t *PAP) { elimtree_t *PTP; frontsub_t *frontsub; css_t *css; PORD_INT *ncolfactor; FLOAT *nzl, *nza, *diag, *entriesL; PORD_INT *xnzl, *xnza, *nzasub, *xnzf, *nzfsub; PORD_INT *tmp, neqs, nelem, K, k, len, row, i, istart, istop; PORD_INT firstcol, lastcol; nelem = L->nelem; nzl = L->nzl; css = L->css; xnzl = css->xnzl; frontsub = L->frontsub; PTP = frontsub->PTP; ncolfactor = PTP->ncolfactor; xnzf = frontsub->xnzf; nzfsub = frontsub->nzfsub; neqs = PAP->neqs; diag = PAP->diag; nza = PAP->nza; xnza = PAP->xnza; nzasub = PAP->nzasub; /* ------------------------ allocate working storage ------------------------ */ mymalloc(tmp, neqs, PORD_INT); /* ------------------------------------ set all numerical values of L to 0.0 ------------------------------------ */ for (i = 0; i < nelem; i++) nzl[i] = 0.0; /* -------------------------------------------- init. factor matrix with the nonzeros of PAP -------------------------------------------- */ for (K = firstPostorder(PTP); K != -1; K = nextPostorder(PTP, K)) { len = 0; istart = xnzf[K]; istop = xnzf[K+1]; for (i = istart; i < istop; i++) tmp[nzfsub[i]] = len++; firstcol = nzfsub[istart]; lastcol = firstcol + ncolfactor[K]; entriesL = nzl + xnzl[firstcol]; for (k = firstcol; k < lastcol; k++) { istart = xnza[k]; istop = xnza[k+1]; for (i = istart; i < istop; i++) { row = nzasub[i]; entriesL[tmp[row]] = nza[i]; } entriesL[tmp[k]] = diag[k]; entriesL += --len; } } /* -------------------- free working storage -------------------- */ free(tmp); } MUMPS_5.8.1/PORD/lib/ddbisect.c0000664000175000017500000007230415042446416015711 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: ddbisect.c / / author J"urgen Schulze, University of Paderborn / created 00mar09 / / This file contains code for the construction/improvement of a vertex / separator for a domain decomposition / ****************************************************************************** Data type: struct domdec graph_t *G; pointer to graph object int ndom; number of domains int domwght; total weight of domains int *vtype; type of node (DOMAIN or MULTISEC) int *color; color of node (GRAY, BLACK, or WHITE) int cwght[3]; weights of GRAY, BLACK, WHITE partitions int *map; maps nodes to next coarser domain decomp. struct domdec *prev; pointer to previous finer domain decomp. struct domdec *next; pointer to next coarser domain decomp. Comments: o Structure holds the domain decompositions constructed by the coarsening process; it also holds the colorings of the domain decomp. computed by the refinement process o vtype[v]: represents the status of a node in the domain decomposition 0, iff status of v is unknown 1, iff v is a domain vertex 2, iff v is a multisector vertex 3, iff multisec v is eliminated and now forms a domain 4, iff multisec v is absorbed by another multisec/domain Methods in lib/ddbisect.c: - void checkDDSep(domdec_t *dd); - int findPseudoPeripheralDomain(domdec_t *dd, int domain); o returns a domain with maximal excentricity by repeated breadth first search; first bfs starts at node domain - void constructLevelSep(domdec_t *dd, int domain); o determines a vertex separator by breadth first search starting at node domain; - void initialDDSep(domdec_t *dd); o computes an initial separator for the domain decomposition dd; initially, all domains/multisecs are colored black; the function scans over all connected components of dd; it first calls findPseudoPeripheral- Domain to obtain a domain with maximal excentricity and then it calls constructLevelSep for that domain. - void updateB2W(bucket_t *w_bucket, bucket_t *b_bucket, domdec_t *dd, int domain, int *tmp_color, int *deltaW, int *deltaB, int *deltaS); o if domain flips its color from BLACK to WHITE, all neighboring domains that share a common variable have to be updated (see my PhD thesis) - void updateW2B(bucket_t *w_bucket, bucket_t *b_bucket, domdec_t *dd, int domain, int *tmp_color, int *deltaW, int *deltaB, int *deltaS); o if domain flips its color from WHITE to BLACK, all neighboring domains that share a common variable have to be updated (see my PhD thesis) - void improveDDSep(domdec_t *dd); o Fiducia-Mattheyses variant to improve the coloring/separator of a domain decomposition (see my PhD thesis) ******************************************************************************/ #include /* #define DEBUG */ /****************************************************************************** ******************************************************************************/ void checkDDSep(domdec_t *dd) { PORD_INT *xadj, *adjncy, *vwght, *vtype, *color, *cwght; PORD_INT nvtx, err, u, v, i, istart, istop, nBdom, nWdom; PORD_INT checkS, checkB, checkW; nvtx = dd->G->nvtx; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vwght = dd->G->vwght; vtype = dd->vtype; color = dd->color; cwght = dd->cwght; err = FALSE; printf("checking separator of domain decomposition (S %d, B %d, W %d)\n", cwght[GRAY], cwght[BLACK], cwght[WHITE]); checkS = checkB = checkW = 0; for (u = 0; u < nvtx; u++) /* check neighborhood of multisector nodes */ if (vtype[u] == 2) { nBdom = nWdom = 0; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; if (color[v] == BLACK) nBdom++; if (color[v] == WHITE) nWdom++; } switch(color[u]) { case GRAY: checkS += vwght[u]; if ((nBdom == 0) || (nWdom == 0)) printf("WARNING: multisec %d belongs to S, but nBdom = %d and " "nWdom = %d\n", u, nBdom, nWdom); break; case BLACK: checkB += vwght[u]; if (nWdom > 0) { printf("ERROR: black multisec %d adjacent to white domain\n", u); err = TRUE; } break; case WHITE: checkW += vwght[u]; if (nBdom > 0) { printf("ERROR: white multisec %d adjacent to black domain\n", u); err = TRUE; } break; default: printf("ERROR: multisec %d has unrecognized color %d\n", u, color[u]); err = TRUE; } } /* sum up size of white/black domains */ else /* if (vtype[u] == 1) */ switch(color[u]) { case BLACK: checkB += vwght[u]; break; case WHITE: checkW += vwght[u]; break; default: printf("ERROR: domain %d has unrecognized color %d\n", u, color[u]); err = TRUE; } /* check cwght[GRAY], cwght[BLACK], cwght[WHITE] */ if ((checkS != cwght[GRAY]) || (checkB != cwght[BLACK]) || (checkW != cwght[WHITE])) { printf("ERROR in partitioning: checkS %d (S %d), checkB %d (B %d), " "checkW %d (W %d)\n", checkS, cwght[GRAY], checkB, cwght[BLACK], checkW, cwght[WHITE]); err = TRUE; } if (err) quit(); } /***************************************************************************** ******************************************************************************/ PORD_INT findPseudoPeripheralDomain(domdec_t* dd, PORD_INT domain) { PORD_INT *xadj, *adjncy, *vtype, *level, *queue; PORD_INT nvtx, qhead, qtail, nlev, lastdomain, u, v, i, istart, istop; nvtx = dd->G->nvtx; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vtype = dd->vtype; /* ------------------------ allocate working storage ------------------------ */ mymalloc(level, nvtx, PORD_INT); mymalloc(queue, nvtx, PORD_INT); /* --------------------------------------- find a domain with maximal excentricity --------------------------------------- */ nlev = 0; lastdomain = domain; while (TRUE) { for (u = 0; u < nvtx; u++) level[u] = -1; queue[0] = domain; level[domain] = 0; qhead = 0; qtail = 1; while (qhead != qtail) { u = queue[qhead++]; if (vtype[u] == 1) /* remember last domain */ lastdomain = u; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; if (level[v] == -1) { queue[qtail++] = v; level[v] = level[u] + 1; } } } if (level[lastdomain] > nlev) { nlev = level[lastdomain]; domain = lastdomain; } else break; } /* ------------------------------- free working storage and return ------------------------------- */ free(level); free(queue); return(domain); } /***************************************************************************** *****************************************************************************/ void constructLevelSep(domdec_t* dd, PORD_INT domain) { PORD_INT *xadj, *adjncy, *vwght, *vtype, *color, *cwght; PORD_INT *queue, *deltaS, *deltaB, *deltaW; PORD_INT nvtx, bestvalue, weight, qhead, qtail, qopt, q, dS, dB, dW; PORD_INT u, v, w, i, istart, istop, j, jstart, jstop; /* ====================================================================== vtype[u]: (u domain) 1 => domain u has not been touched yet (not in queue, no color flip) -1 => domain u is in queue and its deltaS, deltaB, deltaW values have to be updated -2 => domain u is in queue and no update necessary -3 => domain u has flipped its color to black deltaS[u], deltaB[u], deltaW[u]: u domain: denotes the change in partition size, if u flips its color u multisec: deltaB/deltaW denote number of adj. black/white domains ====================================================================== */ nvtx = dd->G->nvtx; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vwght = dd->G->vwght; vtype = dd->vtype; color = dd->color; cwght = dd->cwght; /* ------------------------------------------ allocate working storage + initializations ------------------------------------------ */ mymalloc(queue, nvtx, PORD_INT); mymalloc(deltaS, nvtx, PORD_INT); mymalloc(deltaB, nvtx, PORD_INT); mymalloc(deltaW, nvtx, PORD_INT); for (u = 0; u < nvtx; u++) { deltaS[u] = deltaB[u] = deltaW[u] = 0; if (vtype[u] == 2) deltaW[u] = xadj[u+1] - xadj[u]; } /* --------------------------------------------- build a BFS tree rooted at domain the separator is given by the level structure --------------------------------------------- */ queue[0] = domain; qhead = 0; qtail = 1; vtype[domain] = -1; while ((cwght[BLACK] < cwght[WHITE]) && (qhead != qtail)) { qopt = 0; bestvalue = MAX_INT; /* -------------------------------------------------------------------- run through queue, update domains if necessary, and find best domain -------------------------------------------------------------------- */ for (q = qhead; q < qtail; q++) { u = queue[q]; if (vtype[u] == -1) { dB = vwght[u]; dW = -dB; dS = 0; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; /* color of multisec v */ weight = vwght[v]; /* is GRAY or WHITE */ if (color[v] == WHITE) { dW -= weight; dS += weight; } /* multisec will move to S */ else if (deltaW[v] == 1) { dB += weight; dS -= weight; } /* multisec will move to B */ } deltaS[u] = dS; deltaB[u] = dB; deltaW[u] = dW; vtype[u] = -2; } if (cwght[GRAY] + deltaS[u] < bestvalue) { bestvalue = cwght[GRAY] + deltaS[u]; qopt = q; } } /* ---------------------------------------------------- move best domain to head of queue and color it black ---------------------------------------------------- */ u = queue[qopt]; swap(queue[qopt], queue[qhead], v); qhead++; color[u] = BLACK; cwght[GRAY] += deltaS[u]; cwght[BLACK] += deltaB[u]; cwght[WHITE] += deltaW[u]; vtype[u] = -3; /* ------------------------------------------------------------ update all multisecs that are adjacent to domain u and check domains adjacent to the multisecs ------------------------------------------------------------ */ istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; deltaB[v]++; deltaW[v]--; if (deltaW[v] == 0) /* color of multisec v changed to BLACK */ color[v] = BLACK; else if (deltaB[v] == 1) /* color of multisec v changed to GRAY */ { color[v] = GRAY; jstart = xadj[v]; jstop = xadj[v+1]; for (j = jstart; j < jstop; j++) { w = adjncy[j]; if (vtype[w] == 1) /* a new domain enters the queue */ { queue[qtail++] = w; vtype[w] = -1; } else if (vtype[w] == -2) /* update (old) domain in queue */ vtype[w] = -1; } } else if (deltaW[v] == 1) /* color of multisec v remains GRAY for */ { jstart = xadj[v]; /* the last time */ jstop = xadj[v+1]; for (j = jstart; j < jstop; j++) { w = adjncy[j]; if (vtype[w] == -2) vtype[w] = -1; } } } } /* --------------------------- reset vtype and free memory --------------------------- */ for (i = 0; i < qtail; i++) { u = queue[i]; vtype[u] = 1; } free(queue); free(deltaS); free(deltaB); free(deltaW); } /***************************************************************************** ******************************************************************************/ void initialDDSep(domdec_t *dd) { PORD_INT *vtype, *color, *cwght; PORD_INT nvtx, totvwght, domain, u; nvtx = dd->G->nvtx; totvwght = dd->G->totvwght; vtype = dd->vtype; color = dd->color; cwght = dd->cwght; /* -------------------------------------------------------- initializations (all nodes are colored white by default) -------------------------------------------------------- */ cwght[GRAY] = 0; cwght[BLACK] = 0; cwght[WHITE] = totvwght; for (u = 0; u < nvtx; u++) color[u] = WHITE; /* ---------------------------------------------------------------------- scan over connected components and create level based vertex separator ---------------------------------------------------------------------- */ for (u = 0; u < nvtx; u++) if ((vtype[u] == 1) && (color[u] == WHITE)) { domain = findPseudoPeripheralDomain(dd, u); constructLevelSep(dd, domain); if (cwght[BLACK] >= cwght[WHITE]) break; } } /***************************************************************************** *****************************************************************************/ void updateB2W(bucket_t *w_bucket, bucket_t *b_bucket, domdec_t *dd, PORD_INT domain, PORD_INT *tmp_color, PORD_INT *deltaW, PORD_INT *deltaB, PORD_INT *deltaS) { PORD_INT *xadj, *adjncy, *vwght, *vtype; PORD_INT weight, u, v, i, istart, istop, j, jstart, jstop; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vwght = dd->G->vwght; vtype = dd->vtype; istart = xadj[domain]; istop = xadj[domain+1]; for (i = istart; i < istop; i++) { u = adjncy[i]; weight = vwght[u]; jstart = xadj[u]; jstop = xadj[u+1]; /* --------------------------------------------------------------- subcase (1): before flipping domain to WHITE there was only one other WHITE domain v. update deltaB[v] and deltaS[v] --------------------------------------------------------------- */ if (deltaW[u] < 0) { v = -(deltaW[u]+1); deltaW[u] = 1; #ifdef DEBUG printf(" B2W case (1): (via multisec %d) removing domain %d from " "w_bucket\n", u, v); #endif removeBucket(w_bucket, v); deltaB[v] -= weight; deltaS[v] += weight; insertBucket(w_bucket, deltaS[v], v); } /* --------------------------------------------------------------- subcase (2): all other domains are BLACK. update deltaB, deltaS of these BLACK domains. NOTE: subcase (3) may directly follow --------------------------------------------------------------- */ if (deltaW[u] == 0) { tmp_color[u] = GRAY; for (j = jstart; j < jstop; j++) { v = adjncy[j]; if (vtype[v] == 1) { #ifdef DEBUG printf(" B2W case (2): (via multisec %d) removing domain %d from " "b_bucket\n", u, v); #endif removeBucket(b_bucket, v); deltaB[v] += weight; deltaS[v] -= weight; insertBucket(b_bucket, deltaS[v], v); } } } if (deltaB[u] < 0) deltaB[u] = 1; /* the unique BLACK dom. flipped */ deltaB[u]--; deltaW[u]++; /* ------------------------------------------------------------- subcase (3): after flipping domain to WHITE there is only one remaining BLACK domain. search it and update deltaW, deltaS furthermore, store the remaining BLACK domain in deltaB[u] ------------------------------------------------------------- */ if (deltaB[u] == 1) { for (j = jstart; j < jstop; j++) { v = adjncy[j]; if ((tmp_color[v] == BLACK) && (vtype[v] == 1)) { #ifdef DEBUG printf(" B2W case (3): (via multisec %d) removing domain %d from " "b_bucket\n", u, v); #endif removeBucket(b_bucket, v); deltaW[v] += weight; deltaS[v] -= weight; deltaB[u] = -(v+1); insertBucket(b_bucket, deltaS[v], v); } } } /* ------------------------------------------------------------- subcase (4): after flipping domain to WHITE there is no other BLACK domain. update deltaW, deltaS of the WHITE domains ------------------------------------------------------------- */ if (deltaB[u] == 0) { tmp_color[u] = WHITE; for (j = jstart; j < jstop; j++) { v = adjncy[j]; if (vtype[v] == 1) { #ifdef DEBUG printf(" B2W case (4): (via multisec %d) removing domain %d from " "w_bucket\n", u, v); #endif removeBucket(w_bucket, v); deltaW[v] -= weight; deltaS[v] += weight; insertBucket(w_bucket, deltaS[v], v); } } } } } /***************************************************************************** *****************************************************************************/ void updateW2B(bucket_t *w_bucket, bucket_t *b_bucket, domdec_t *dd, PORD_INT domain, PORD_INT *tmp_color, PORD_INT *deltaW, PORD_INT *deltaB, PORD_INT *deltaS) { PORD_INT *xadj, *adjncy, *vwght, *vtype; PORD_INT weight, u, v, i, istart, istop, j, jstart, jstop; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vwght = dd->G->vwght; vtype = dd->vtype; istart = xadj[domain]; istop = xadj[domain+1]; for (i = istart; i < istop; i++) { u = adjncy[i]; weight = vwght[u]; jstart = xadj[u]; jstop = xadj[u+1]; /* --------------------------------------------------------------- subcase (1): before flipping domain to BLACK there was only one other BLACK domain v. update deltaW[v] and deltaS[v] --------------------------------------------------------------- */ if (deltaB[u] < 0) { v = -(deltaB[u]+1); deltaB[u] = 1; #ifdef DEBUG printf(" W2B case (1): (via multisec %d) removing domain %d from " "b_bucket\n", u, v); #endif removeBucket(b_bucket, v); deltaW[v] -= weight; deltaS[v] += weight; insertBucket(b_bucket, deltaS[v], v); } /* --------------------------------------------------------------- subcase (2): all other domains are WHITE. update deltaW, deltaS of these WHITE domains. NOTE: subcase (3) may directly follow --------------------------------------------------------------- */ if (deltaB[u] == 0) { tmp_color[u] = GRAY; for (j = jstart; j < jstop; j++) { v = adjncy[j]; if (vtype[v] == 1) { #ifdef DEBUG printf(" W2B case (2): (via multisec %d) removing domain %d from " "w_bucket\n", u, v); #endif removeBucket(w_bucket, v); deltaW[v] += weight; deltaS[v] -= weight; insertBucket(w_bucket, deltaS[v], v); } } } if (deltaW[u] < 0) deltaW[u] = 1; /* the unique WHITE dom. flipped */ deltaB[u]++; deltaW[u]--; /* ------------------------------------------------------------- subcase (3): after flipping domain to BLACK there is only one remaining WHITE domain. search it and update deltaB, deltaS furthermore, store the remaining WHITE domain in deltaW[u] ------------------------------------------------------------- */ if (deltaW[u] == 1) { for (j = jstart; j < jstop; j++) { v = adjncy[j]; if ((tmp_color[v] == WHITE) && (vtype[v] == 1)) { #ifdef DEBUG printf(" W2B case (3): (via multisec %d) removing domain %d from " "w_bucket\n", u, v); #endif removeBucket(w_bucket, v); deltaB[v] += weight; deltaS[v] -= weight; deltaW[u] = -(v+1); insertBucket(w_bucket, deltaS[v], v); } } } /* --------------------------------------------------------------- subcase (4): after flipping domain to BLACK there is no other WHITE domain. update deltaB, deltaS of the BLACK domains --------------------------------------------------------------- */ if (deltaW[u] == 0) { tmp_color[u] = BLACK; for (j = jstart; j < jstop; j++) { v = adjncy[j]; if (vtype[v] == 1) { #ifdef DEBUG printf(" W2B case (4): (via multisec %d) removing domain %d from " "b_bucket\n", u, v); #endif removeBucket(b_bucket, v); deltaB[v] -= weight; deltaS[v] += weight; insertBucket(b_bucket, deltaS[v], v); } } } } } /***************************************************************************** ******************************************************************************/ void improveDDSep(domdec_t *dd) { bucket_t *b_bucket, *w_bucket; PORD_INT *xadj, *adjncy, *vwght, *vtype, *color, *cwght; PORD_INT *tmp_color, *deltaS, *deltaB, *deltaW; PORD_INT nvtx, weight, tmp_S, tmp_B, tmp_W; PORD_INT pos, bestglobalpos, badflips, b_domain, w_domain, domain, nxtdomain; PORD_INT fhead, ftail, u, v, i, istart, istop; FLOAT bestglobalvalue, b_value, w_value, value; /* ====================================================================== vtype[u]: (u domain) 1 => color of domain u has not been changed < 0 => points to next domain in flipping list (fhead points to first, ftail points to last domain in list) = 0 => domain is last domain in flipping list ====================================================================== */ nvtx = dd->G->nvtx; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vwght = dd->G->vwght; vtype = dd->vtype; color = dd->color; cwght = dd->cwght; mymalloc(tmp_color, nvtx, PORD_INT); mymalloc(deltaS, nvtx, PORD_INT); mymalloc(deltaB, nvtx, PORD_INT); mymalloc(deltaW, nvtx, PORD_INT); OUTER_LOOP_START: /* ---------------------------------------------------------------------- copy data of actual bisection and initialize buckets and flipping list ---------------------------------------------------------------------- */ tmp_S = cwght[GRAY]; tmp_B = cwght[BLACK]; tmp_W = cwght[WHITE]; bestglobalpos = badflips = 0; bestglobalvalue = F(tmp_S, tmp_B, tmp_W); b_bucket = setupBucket(nvtx, nvtx, (nvtx >> 1)); w_bucket = setupBucket(nvtx, nvtx, (nvtx >> 1)); fhead = 0; ftail = -1; pos = 0; /* ---------------------------------------------------------- initialize tmp_color, deltaB, and deltaW for all multisecs ---------------------------------------------------------- */ for (u = 0; u < nvtx; u++) if (vtype[u] == 2) { deltaB[u] = deltaW[u] = 0; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; if (color[v] == BLACK) deltaB[u]++; else deltaW[u]++; } if ((deltaB[u] > 0) && (deltaW[u] > 0)) /* update multisec coloring */ tmp_color[u] = GRAY; else if (deltaB[u] > 0) tmp_color[u] = BLACK; else tmp_color[u] = WHITE; color[u] = tmp_color[u]; } /* ----------------------------------------------------------------- initialize tmp_color, deltaS,B,W for all domains and fill buckets ----------------------------------------------------------------- */ for (u = 0; u < nvtx; u++) if (vtype[u] == 1) { tmp_color[u] = color[u]; if (tmp_color[u] == BLACK) /* domain may be flipped to WHITE */ { deltaW[u] = vwght[u]; deltaB[u] = -deltaW[u]; deltaS[u] = 0; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; /* tmp_color[v] e {GRAY, BLACK} */ weight = vwght[v]; if (tmp_color[v] == BLACK) /* multisec v will move into S */ { deltaB[u] -= weight; deltaS[u] += weight; } else if (deltaB[v] == 1) /* multisec v will move into W */ { deltaW[u] += weight; deltaS[u] -= weight; deltaB[v] = -(u+1); } } insertBucket(b_bucket, deltaS[u], u); } if (tmp_color[u] == WHITE) /* domain may be flipped to BLACK */ { deltaB[u] = vwght[u]; deltaW[u] = -deltaB[u]; deltaS[u] = 0; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; /* tmp_color[v] e {GRAY, WHITE} */ weight = vwght[v]; if (tmp_color[v] == WHITE) /* multisec v will move into S */ { deltaW[u] -= weight; deltaS[u] += weight; } else if (deltaW[v] == 1) /* multisec v will move into B */ { deltaB[u] += weight; deltaS[u] -= weight; deltaW[v] = -(u+1); } } insertBucket(w_bucket, deltaS[u], u); } } #ifdef DEBUG printf("starting inner loop: b_bucket->nobj %d, w_bucket->nobj %d\n", b_bucket->nobj, w_bucket->nobj); waitkey(); #endif INNER_LOOP_START: /* ------------------------------------------- extract best domain from b_bucket, w_bucket ------------------------------------------- */ b_value = w_value = MAX_FLOAT; if ((b_domain = minBucket(b_bucket)) != -1) { b_value = F((tmp_S+deltaS[b_domain]), (tmp_B+deltaB[b_domain]), (tmp_W+deltaW[b_domain])); #ifdef DEBUG printf("best black domain: %d, deltaS %d, deltaB %d, deltaW %d, " "cost %7.2f\n", b_domain, deltaS[b_domain], deltaB[b_domain], deltaW[b_domain], b_value); #endif } if ((w_domain = minBucket(w_bucket)) != -1) { w_value = F((tmp_S+deltaS[w_domain]), (tmp_B+deltaB[w_domain]), (tmp_W+deltaW[w_domain])); #ifdef DEBUG printf("best white domain: %d, deltaS %d, deltaB %d, deltaW %d, " "cost %7.2f\n", w_domain, deltaS[w_domain], deltaB[w_domain], deltaW[w_domain], w_value); #endif } if ((b_domain == ERR) && (w_domain == ERR)) goto INNER_LOOP_END; if (b_value + EPS < w_value) { domain = b_domain; value = b_value; removeBucket(b_bucket, domain); } else { domain = w_domain; value = w_value; removeBucket(w_bucket, domain); } #ifdef DEBUG printf(" domain %d removed from bucket\n", domain); #endif /* ------------------------------------------------------------------- flip the color of domain and put it in list of log. flipped domains ------------------------------------------------------------------- */ if (ftail != -1) vtype[ftail] = -(domain+1); /* append domain */ else fhead = -(domain+1); /* list starts with domain */ vtype[domain] = 0; /* mark end of list */ ftail = domain; /* domain is last element in list */ if (tmp_color[domain] == BLACK) { tmp_color[domain] = WHITE; updateB2W(w_bucket,b_bucket,dd,domain,tmp_color,deltaW,deltaB,deltaS); } else if (tmp_color[domain] == WHITE) { tmp_color[domain] = BLACK; updateW2B(w_bucket,b_bucket,dd,domain,tmp_color,deltaW,deltaB,deltaS); } tmp_S += deltaS[domain]; tmp_B += deltaB[domain]; tmp_W += deltaW[domain]; pos++; if (value + EPS < bestglobalvalue) { bestglobalvalue = value; bestglobalpos = pos; badflips = 0; } else badflips++; if (badflips < MAX_BAD_FLIPS) goto INNER_LOOP_START; INNER_LOOP_END: /* -------------------------------------------- end of inner loop: now do the physical flips -------------------------------------------- */ pos = 0; nxtdomain = fhead; while (nxtdomain != 0) { domain = -nxtdomain - 1; if (pos < bestglobalpos) { if (color[domain] == BLACK) color[domain] = WHITE; else color[domain] = BLACK; cwght[GRAY] += deltaS[domain]; cwght[BLACK] += deltaB[domain]; cwght[WHITE] += deltaW[domain]; pos++; } nxtdomain = vtype[domain]; vtype[domain] = 1; } /* ---------------------------------------------- partition improved => re-start the whole stuff ---------------------------------------------- */ #ifdef DEBUG printf(" INNER_LOOP_END (#pyhs. flips %d): S %d, B %d, W %d (%7.2f)\n", bestglobalpos, cwght[GRAY], cwght[BLACK], cwght[WHITE], bestglobalvalue); waitkey(); #endif /* JY: moved next instruction after the two * freeBucket instructions because * this was the cause of a memory leak. * if (bestglobalpos > 0) goto OUTER_LOOP_START; */ freeBucket(b_bucket); freeBucket(w_bucket); if (bestglobalpos > 0) goto OUTER_LOOP_START; free(tmp_color); free(deltaS); free(deltaB); free(deltaW); } MUMPS_5.8.1/PORD/lib/minpriority.c0000664000175000017500000004151415042446416016514 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: minpriority.c / / author J"urgen Schulze, University of Paderborn / created 01jan15 / / This file contains functions dealing with the minimum priority object / ****************************************************************************** Data type: struct minprior gelim_t *Gelim; the elimination graph of G multisector_t *ms; the multisector for G bucket_t *bucket; holds unelim. vert. of actual stage stageinfo_t *stageinfo; contains statistics for each stage int *reachset; holds boundary vert. in each step int nreach; number of vertices in reachset int *auxaux; general purpose auxiliary vector int *auxbin; special auxiliary vector int *auxtmp; special auxiliary vector int flag; flag for vector auxtmp (see below) struct stageinfo int nstep; # of elim. steps in each stage int welim; weight of elim. vert. in each stage int nzf; # of factor entries in each stage FLOAT ops; # of factor ops. in each stage Comments: o Structure used to compute a minimum priority ordering for a graph G with multisector ms. The elimination process is organized in stages. The stages are given by the multisector (i.e. ms->stage). The vertices of a stage are eliminated in steps. In each elimination step a maximal independent set of vertices with minimum priority is eliminated o Structure does not own multisector object => it will not be freed o Three auxiliary vectors can be used by functions working on minprior IMPORTANT INVARIANTS for vectors auxbin, auxtmp auxbin[i] = -1 holds at start and at end of each function auxtmp[i] < flag holds at start and at end of each function Methods in lib/minpriority.c: - minprior = newMinPriority(int nvtx, int nstages); o Initial: Gelim = ms = bucket = NULL, nreach = 0, flag = 1; - void freeMinPriority(minprior_t *minprior); - minprior = setupMinPriority(multisector_t *ms); o allocates memory for the minprior object by calling newMinPriority and sets up the elimination graph by a call to setupElimGraph and the bucket by a call to setupBucket; finally, it initializes the vectors, i.e. auxbin[u] = -1, auxtmp[u] = 0 for all 0 <= u <= nvtx, and nstep = welim = nzf = ops = 0 for all stages - T = orderMinPriority(minprior_t *minprior options_t *options,timings_t *cpus); o MASTER_FUNCTION: computes a bottom-up ordering according to the specified ordtype e { MINIMUM_PRIORITY, INCOMPLETE_ND, MULTISECTION, TRISTAGE_MULTISECTION } o used options: OPTION_ORDTYPE, OPTION_NODE_SELECTION1, OPTION_NODE_SELECTION2 o returned timings: (see eliminateStage) TIME_UPDSCORE, TIME_UPDADJNCY, TIME_FINDINODES - void eliminateStage(minprior_t *minprior, int istage, int scoretype, timings_t *cpus); o eliminates all principal variables u with stage[u] <= istage using the score function given by scoretype o returned timings: TIME_UPDSCORE, TIME_UPDADJNCY, TIME_FINDINODES - int eliminateStep(minprior_t *minprior, int istage, int scoretype); o the variables u with stage[u] <= istage are eliminated in steps; in each step a maximal independet set of variables with minimum score is eliminated o the function returns the size of the independent set, i.e. the number of variables that have been eliminated in the actual step ******************************************************************************/ #include /* #define DEBUG */ /* #define BE_CAUTIOUS */ /***************************************************************************** ******************************************************************************/ minprior_t* newMinPriority(PORD_INT nvtx, PORD_INT nstages) { minprior_t *minprior; stageinfo_t *stageinfo; mymalloc(stageinfo, nstages, stageinfo_t); mymalloc(minprior, 1, minprior_t); minprior->Gelim = NULL; minprior->ms = NULL; minprior->bucket = NULL; minprior->stageinfo = stageinfo; mymalloc(minprior->reachset, nvtx, PORD_INT); mymalloc(minprior->auxaux, nvtx, PORD_INT); mymalloc(minprior->auxbin, nvtx, PORD_INT); mymalloc(minprior->auxtmp, nvtx, PORD_INT); minprior->nreach = 0; minprior->flag = 1; return(minprior); } /***************************************************************************** ******************************************************************************/ void freeMinPriority(minprior_t *minprior) { freeElimGraph(minprior->Gelim); freeBucket(minprior->bucket); free(minprior->stageinfo); free(minprior->reachset); free(minprior->auxaux); free(minprior->auxbin); free(minprior->auxtmp); free(minprior); } /***************************************************************************** ******************************************************************************/ minprior_t* setupMinPriority(multisector_t *ms) { minprior_t *minprior; stageinfo_t *stageinfo; PORD_INT *auxbin, *auxtmp; PORD_INT nvtx, nstages, istage, u; nvtx = ms->G->nvtx; nstages = ms->nstages; minprior = newMinPriority(nvtx, nstages); minprior->ms = ms; minprior->Gelim = setupElimGraph(ms->G); minprior->bucket = setupBucket(nvtx, nvtx, 0); auxbin = minprior->auxbin; auxtmp = minprior->auxtmp; for (u = 0; u < nvtx; u++) { auxbin[u] = -1; auxtmp[u] = 0; } for (istage = 0; istage < nstages; istage++) { stageinfo = minprior->stageinfo + istage; stageinfo->nstep = 0; stageinfo->welim = 0; stageinfo->nzf = 0; stageinfo->ops = 0.0; } return(minprior); } /***************************************************************************** ******************************************************************************/ elimtree_t* orderMinPriority(minprior_t *minprior, options_t *options, timings_t *cpus) { elimtree_t *T; PORD_INT nvtx, nstages, istage, scoretype, ordtype; nvtx = minprior->Gelim->G->nvtx; nstages = minprior->ms->nstages; ordtype = options[OPTION_ORDTYPE]; scoretype = options[OPTION_NODE_SELECTION2]; /* ------------------------------ check whether nstages is valid ------------------------------ */ if ((nstages < 1) || (nstages > nvtx)) { fprintf(stderr, "\nError in function orderMinPriority\n" " no valid number of stages in multisector (#stages = %d)\n", nstages); quit(); } if ((nstages < 2) && (ordtype != MINIMUM_PRIORITY)) { fprintf(stderr, "\nError in function orderMinPriority\n" " not enough stages in multisector (#stages = %d)\n", nstages); quit(); } /* -------------------------------------------------------------- first stage: eliminate all vertices in the remaining subgraphs -------------------------------------------------------------- */ scoretype = options[OPTION_NODE_SELECTION1]; eliminateStage(minprior, 0, scoretype, cpus); /* ------------------------------------------------------- other stages: eliminate all vertices in the multisector ------------------------------------------------------- */ switch(ordtype) { case MINIMUM_PRIORITY: break; case INCOMPLETE_ND: for (istage = 1; istage < nstages; istage++) eliminateStage(minprior, istage, scoretype, cpus); break; case MULTISECTION: eliminateStage(minprior, nstages-1, scoretype, cpus); break; default: fprintf(stderr, "\nError in function orderMinPriority\n" " unrecognized ordering type %d\n", ordtype); quit(); } /* ------------------------------------------- print statistics for the elimination stages ------------------------------------------- */ if ((ordtype != MINIMUM_PRIORITY) && (options[OPTION_MSGLVL] > 1)) for (istage = 0; istage < nstages; istage++) printf("%4d. stage: #steps %6d, weight %6d, nzl %8d, ops %e\n", istage, minprior->stageinfo[istage].nstep, minprior->stageinfo[istage].welim, minprior->stageinfo[istage].nzf, minprior->stageinfo[istage].ops); /* ----------------------------------- extract elimination tree and return ----------------------------------- */ T = extractElimTree(minprior->Gelim); return(T); } /***************************************************************************** ******************************************************************************/ void eliminateStage(minprior_t *minprior, PORD_INT istage, PORD_INT scoretype, timings_t *cpus) { gelim_t *Gelim; bucket_t *bucket; stageinfo_t *stageinfo; PORD_INT *stage, *reachset, *auxbin, *auxtmp, *auxaux; PORD_INT *degree, *score; PORD_INT *pflag, nreach, nvtx, r, u, i; Gelim = minprior->Gelim; bucket = minprior->bucket; stage = minprior->ms->stage; stageinfo = minprior->stageinfo + istage; reachset = minprior->reachset; auxaux = minprior->auxaux; auxbin = minprior->auxbin; auxtmp = minprior->auxtmp; pflag = &(minprior->flag); nvtx = Gelim->G->nvtx; degree = Gelim->degree; score = Gelim->score; #ifdef DEBUG printf("\nSTARTING NEW ELIMINATION STAGE (nedges %d, maxedges %d)\n\n", Gelim->G->nedges, Gelim->maxedges); if (istage> 0) printElimGraph(Gelim); /* waitkey(); */ #endif /* ------------------------------------------------------------- load reachset with all principal variables in stage <= istage ------------------------------------------------------------- */ nreach = 0; for (u = 0; u < nvtx; u++) if ((score[u] == -1) && (stage[u] <= istage)) { reachset[nreach++] = u; score[u] = degree[u]; /* score[u] = degree[u]*(degree[u]-1)/2; */ } /* ---------------------------------------------------------------- do an initial update of the vertices in reachset and fill bucket ---------------------------------------------------------------- */ pord_starttimer(cpus[TIME_UPDSCORE]); updateDegree(Gelim, reachset, nreach, auxbin); updateScore(Gelim, reachset, nreach, scoretype, auxbin); pord_stoptimer(cpus[TIME_UPDSCORE]); for (i = 0; i < nreach; i++) { u = reachset[i]; insertBucket(bucket, score[u], u); } /* ------------------------------------- and now start the elimination process ------------------------------------- */ while (TRUE) { if (eliminateStep(minprior, istage, scoretype) == 0) break; nreach = minprior->nreach; #ifdef BE_CAUTIOUS printf("checking arrays auxtmp and auxbin\n"); for (u = 0; u < nvtx; u++) if ((auxtmp[u] >= *pflag) || (auxbin[u] != -1)) { printf("ERROR: flag = %d, auxtmp[%d] = %d, auxbin[%d] = %d\n", *pflag, u, auxtmp[u], u, auxbin[u]); quit(); } #endif /* ---------------------------------------------------------- update the adjacency structure of all vertices in reachset ---------------------------------------------------------- */ pord_starttimer(cpus[TIME_UPDADJNCY]); updateAdjncy(Gelim, reachset, nreach, auxtmp, pflag); pord_stoptimer(cpus[TIME_UPDADJNCY]); /* ---------------------------------------- find indistinguishable nodes in reachset ---------------------------------------- */ pord_starttimer(cpus[TIME_FINDINODES]); findIndNodes(Gelim, reachset, nreach, auxbin, auxaux, auxtmp, pflag); pord_stoptimer(cpus[TIME_FINDINODES]); #ifdef BE_CAUTIOUS printf("checking arrays auxtmp and auxbin\n"); for (u = 0; u < nvtx; u++) if ((auxtmp[u] >= *pflag) || (auxbin[u] != -1)) { printf("ERROR: flag = %d, auxtmp[%d] = %d, auxbin[%d] = %d\n", *pflag, u, auxtmp[u], u, auxbin[u]); quit(); } #endif /* ---------------------------------------------------------------- clean reachset of nonprincipal nodes and nodes not in this stage ---------------------------------------------------------------- */ r = 0; for (i = 0; i < nreach; i++) { u = reachset[i]; if (score[u] >= 0) reachset[r++] = u; } nreach = r; /* --------------------------------------------------- update the degree/score of all vertices in reachset --------------------------------------------------- */ pord_starttimer(cpus[TIME_UPDSCORE]); updateDegree(Gelim, reachset, nreach, auxbin); updateScore(Gelim, reachset, nreach, scoretype, auxbin); pord_stoptimer(cpus[TIME_UPDSCORE]); /* ---------------------------- re-insert vertices in bucket ---------------------------- */ for (i = 0; i < nreach; i++) { u = reachset[i]; insertBucket(bucket, score[u], u); } stageinfo->nstep++; } } /***************************************************************************** ******************************************************************************/ PORD_INT eliminateStep(minprior_t *minprior, PORD_INT istage, PORD_INT scoretype) { gelim_t *Gelim; bucket_t *bucket; stageinfo_t *stageinfo; PORD_INT *stage, *reachset, *auxtmp; PORD_INT *xadj, *adjncy, *vwght, *len, *degree, *score; PORD_INT *pflag, *pnreach, nelim, minscr, vwghtu, u, v, i, istart, istop; FLOAT tri, rec; Gelim = minprior->Gelim; bucket = minprior->bucket; stage = minprior->ms->stage; stageinfo = minprior->stageinfo + istage; reachset = minprior->reachset; pnreach = &(minprior->nreach); auxtmp = minprior->auxtmp; pflag = &(minprior->flag); xadj = Gelim->G->xadj; adjncy = Gelim->G->adjncy; vwght = Gelim->G->vwght; len = Gelim->len; degree = Gelim->degree; score = Gelim->score; #ifdef DEBUG printf("\nStarting new elimination step (nedges %d, maxedges %d)\n", Gelim->G->nedges, Gelim->maxedges); /* waitkey(); */ #endif /* ---------------------- check for empty bucket ---------------------- */ if ((u = minBucket(bucket)) == -1) return(0); minscr = score[u]; /* ---------------------------------------- loop while nodes of minimum score remain ---------------------------------------- */ nelim = 0; *pnreach = 0; while (TRUE) { vwghtu = vwght[u]; /* -------------------------------------------------- increment welim and nelim and remove u from bucket -------------------------------------------------- */ removeBucket(bucket, u); stageinfo->welim += vwghtu; nelim++; /* ----------------------------------------------------------------- call buildElement to create element u and merge u's boundary with the nodes in reachset; remove any vertex from bucket that belongs to u's boundary and to the actual stage ----------------------------------------------------------------- */ buildElement(Gelim, u); istart = xadj[u]; istop = istart + len[u]; for (i = istart; i < istop; i++) { v = adjncy[i]; /* v belongs to u's boundary */ if (auxtmp[v] < *pflag) /* v not yet in reachset */ { auxtmp[v] = *pflag; if (stage[v] <= istage) /* v belongs to actual stage */ removeBucket(bucket, v); reachset[(*pnreach)++] = v; } } #ifdef DEBUG printf("Node %d (weight %d, score %d) eliminated: (boundary weight %d)\n", u, vwghtu, minscr, degree[u]); for (i = istart; i < istop; i++) printf("%4d (degree %2d)", adjncy[i], degree[adjncy[i]]); printf("\n"); #endif /* --------------------------------------------------------------- increment the storage and operation counts for this elim. stage --------------------------------------------------------------- */ tri = vwghtu; rec = degree[u]; stageinfo->nzf += (PORD_INT)((tri * (tri+1)) / 2); stageinfo->nzf += (PORD_INT)(tri * rec); stageinfo->ops += (tri*tri*tri) / 3.0 + (tri*tri) / 2.0 - (5*tri) / 6.0; stageinfo->ops += (tri*tri*rec) + (rec*(rec+1)*tri); /* --------------------------------------------------------------- end this elim. step, if one of the following conditions is true (1) no multiple elimination (2) bucket empty (3) no further variable with minimum score ---------------------------------------------------------------- */ if (scoretype / 10 == 0) break; if ((u = minBucket(bucket)) == -1) break; if (score[u] > minscr) break; } /* ----------------------- clear auxtmp and return ----------------------- */ (*pflag)++; return(nelim); } MUMPS_5.8.1/PORD/lib/nestdiss.c0000664000175000017500000002531215042446416015761 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: nestdiss.c / / author J"urgen Schulze, University of Paderborn / created 00dec29 / / This file contains functions dealing with the rec. nested dissection object / ****************************************************************************** Data type: struct nestdiss graph_t *G; pointer to original graph int *map; maps nodes of G to constructed subgraph int depth; depth in nested dissection tree int nvint; number of vertices in subgraph int *intvertex; internal vertices of subgraph int *intcolor; color of vertices in intvertex int cwght[3]; weights of bisection struct nestdiss *parent; pointer to parent nd node struct nestdiss *childB; pointer to black descendant nd node struct nestdiss *childW; pointer to white descendand nd node Comments: o Structure used to build the nested dissection tree. Vector intvertex holds the vertices of the subgraph to be partitioned. Once a separator has been computed, the coloring of vertex u = intvertex[i] is stored in vector intcolor[i] and the partition weights are stored in cwght[GRAY], cwght[BLACK], and cwght[WHITE]. o Structure does not own graph object G => it will not be freed Note: G is the original graph o Structure does not own map array => it will not be freed Note: map is a "global" array that is used when constructing the subgraph induced by the vertices in intvertex. The array maps the vertices of the original graph G to the vertices of the subgraph. Methods in lib/nestdiss.c: - nd = newNDnode(graph_t *G, int *map, int nvint); o Initial: depth = 0, cwght[GRAY] = cwght[BLACK] = cwght[WHITE] = 0, and parent = childB = childW = NULL; - void freeNDnode(nestdiss_t *nd); - ndroot = setupNDroot(graph_t *G, int *map); o sets up the root of the nested dissection tree; the function first calls newNDnode to allocate memory for ndroot and, then, sets intvertex[i] = i for all 0 <= i < G->nvtx - void splitNDnode(nestdiss_t *nd, options_t *options, timings_t *cpus); o constructs the subgraph induced by nd->intvertex and computes a bisection for it by calling constructSeparator and smoothSeparator. Then, the nd object is splitted in a black one that holds the black partition and a white one that holds the white partition. o used options: (see constructSeparator and smoothSeparator) OPTION_MSGLVL, OPTION_NODE_SELECTION3 o returned timings: (also see constructSeparator) TIME_INITDOMDEC, TIME_COARSEDOMDEC, TIME_INITSEP, TIME_REFINESEP TIME_MULTILEVEL, TIME_SMOOTH - void buildNDtree(nestdiss_t *ndroot, options_t *options, timings_t *cpus); o builds the nested dissection tree under root ndroot, i.e. it applies the nested dissection process to the (sub)graph induced by ndroot->intvertex by iteratively calling function splitNDnode. o used options: (also see splitNDnode) OPTION_DOMAIN_SIZE, OPTION_MSGLVL, OPTION_NODE_SELECTION3 o returned timings: (see splitNDnode) TIME_INITDOMDEC, TIME_COARSEDOMDEC, TIME_INITSEP, TIME_REFINESEP TIME_MULTILEVEL, TIME_SMOOTH - void freeNDtree(nestdiss_t *ndroot); o removes the nested dissection tree under root ndroot Note: ndroot is not freed ******************************************************************************/ #include /***************************************************************************** ******************************************************************************/ nestdiss_t* newNDnode(graph_t *G, PORD_INT *map, PORD_INT nvint) { nestdiss_t *nd; mymalloc(nd, 1, nestdiss_t); mymalloc(nd->intvertex, nvint, PORD_INT); mymalloc(nd->intcolor, nvint, PORD_INT); nd->G = G; nd->map = map; nd->depth = 0; nd->nvint = nvint; nd->cwght[GRAY] = nd->cwght[BLACK] = nd->cwght[WHITE] = 0; nd->parent = nd->childB = nd->childW = NULL; return(nd); } /***************************************************************************** ******************************************************************************/ void freeNDnode(nestdiss_t *nd) { free(nd->intvertex); free(nd->intcolor); free(nd); } /***************************************************************************** ******************************************************************************/ nestdiss_t* setupNDroot(graph_t *G, PORD_INT *map) { nestdiss_t *ndroot; PORD_INT *intvertex, nvtx, i; nvtx = G->nvtx; ndroot = newNDnode(G, map, nvtx); intvertex = ndroot->intvertex; for (i = 0; i < nvtx; i++) intvertex[i] = i; return(ndroot); } /***************************************************************************** ******************************************************************************/ void splitNDnode(nestdiss_t *nd, options_t *options, timings_t *cpus) { nestdiss_t *b_nd, *w_nd; graph_t *Gsub; gbisect_t *Gbisect; PORD_INT *map, *intvertex, *intcolor, *b_intvertex, *w_intvertex; PORD_INT nvint, b_nvint, w_nvint, u, i; map = nd->map; nvint = nd->nvint; intvertex = nd->intvertex; intcolor = nd->intcolor; /* ------------------------------------------------------------- extract the subgraph for which a bisection has to be computed ------------------------------------------------------------- */ if (nd->G->nvtx == nd->nvint) { Gsub = nd->G; /* a hack to save time and space */ for (u = 0; u < nd->nvint; u++) /* but do not forget the map vector */ map[u] = u; } else Gsub = setupSubgraph(nd->G, intvertex, nvint, map); Gbisect = newGbisect(Gsub); /* --------------------------------- compute the bisection for Gbisect --------------------------------- */ pord_starttimer(cpus[TIME_MULTILEVEL]); constructSeparator(Gbisect, options, cpus); pord_stoptimer(cpus[TIME_MULTILEVEL]); pord_starttimer(cpus[TIME_SMOOTH]); if (Gbisect->cwght[GRAY] > 0) smoothSeparator(Gbisect, options); pord_stoptimer(cpus[TIME_SMOOTH]); /* ---------------------------------------- copy the bisection back to the nd object ---------------------------------------- */ b_nvint = w_nvint = 0; nd->cwght[GRAY] = Gbisect->cwght[GRAY]; nd->cwght[BLACK] = Gbisect->cwght[BLACK]; nd->cwght[WHITE] = Gbisect->cwght[WHITE]; for (i = 0; i < nvint; i++) { u = intvertex[i]; intcolor[i] = Gbisect->color[map[u]]; switch(intcolor[i]) { case GRAY: break; case BLACK: b_nvint++; break; case WHITE: w_nvint++; break; default: fprintf(stderr, "\nError in function splitNDnode\n" " node %d has unrecognized color %d\n", u, intcolor[i]); quit(); } } /* ------------------------------------------------------ and now split the nd object according to the bisection ------------------------------------------------------ */ b_nd = newNDnode(nd->G, map, b_nvint); b_intvertex = b_nd->intvertex; w_nd = newNDnode(nd->G, map, w_nvint); w_intvertex = w_nd->intvertex; b_nvint = w_nvint = 0; for (i = 0; i < nvint; i++) { u = intvertex[i]; if (intcolor[i] == BLACK) b_intvertex[b_nvint++] = u; if (intcolor[i] == WHITE) w_intvertex[w_nvint++] = u; } nd->childB = b_nd; b_nd->parent = nd; nd->childW = w_nd; w_nd->parent = nd; b_nd->depth = nd->depth + 1; w_nd->depth = nd->depth + 1; /* ----------------- free the subgraph ----------------- */ if (Gsub != nd->G) freeGraph(Gsub); freeGbisect(Gbisect); } /***************************************************************************** ******************************************************************************/ void buildNDtree(nestdiss_t *ndroot, options_t *options, timings_t *cpus) { nestdiss_t *nd; nestdiss_t *queue[2*MAX_SEPS+1]; PORD_INT maxseps, seps, domainsize, qhead, qtail; maxseps = MAX_SEPS; domainsize = options[OPTION_DOMAIN_SIZE]; if (domainsize == 1) maxseps = DEFAULT_SEPS; /* secret switch */ /* -------------------------------------------------- build the nested dissection tree under root ndroot -------------------------------------------------- */ queue[0] = ndroot; qhead = 0; qtail = 1; seps = 0; while ((qhead != qtail) && (seps < maxseps)) { seps++; nd = queue[qhead++]; splitNDnode(nd, options, cpus); if ((nd->childB == NULL) || (nd->childW == NULL)) { fprintf(stderr, "\nError in function buildNDtree\n" " recursive nested dissection process failed\n"); quit(); } if (options[OPTION_MSGLVL] > 1) printf("%4d. S %6d, B %6d, W %6d [bal %4.2f, rel %6.4f, cost %7.2f]\n", seps, nd->cwght[GRAY], nd->cwght[BLACK], nd->cwght[WHITE], (FLOAT)min(nd->cwght[BLACK], nd->cwght[WHITE]) / max(nd->cwght[BLACK], nd->cwght[WHITE]), (FLOAT)nd->cwght[GRAY] / (nd->cwght[GRAY] + nd->cwght[BLACK] + nd->cwght[WHITE]), F(nd->cwght[GRAY], nd->cwght[BLACK], nd->cwght[WHITE])); if ((nd->childB->nvint > MIN_NODES) && ((nd->cwght[BLACK] > domainsize) || (qtail < DEFAULT_SEPS))) queue[qtail++] = nd->childB; if ((nd->childW->nvint > MIN_NODES) && ((nd->cwght[WHITE] > domainsize) || (qtail < DEFAULT_SEPS))) queue[qtail++] = nd->childW; } } /***************************************************************************** ******************************************************************************/ void freeNDtree(nestdiss_t *ndroot) { nestdiss_t *nd, *parent; /* ------------------------------------------------------ to remove the nested dissection tree under root ndroot visit the nodes in post-order ------------------------------------------------------ */ for (nd = ndroot; nd->childB != NULL; nd = nd->childB); while (nd != ndroot) { parent = nd->parent; if ((parent == NULL) || (parent->childB == NULL) || (parent->childW == NULL)) { fprintf(stderr, "\nError in function removeNDtree\n" " nested dissection tree corrupted\n"); quit(); } if (parent->childB == nd) /* left subtree of parent visited */ { freeNDnode(nd); /* free root of left subtree and goto right */ for (nd = parent->childW; nd->childB != NULL; nd = nd->childB); } else /* right subtree of parent visited */ { freeNDnode(nd); /* free root of right subtree and goto parent */ nd = parent; } } } MUMPS_5.8.1/PORD/lib/multisector.c0000664000175000017500000002653115042446416016503 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: ms.c / / author J"urgen Schulze, University of Paderborn / created 01jan04 / / This file contains functions dealing with the multisector object / ****************************************************************************** Data type: struct multisector graph_t *G; pointer to original graph int *stage; stage[u]=i => node u will be elim. in stage i int nstages; number of stages int nnodes; number of nodes in multisector int totmswght; weigth of nodes in multisector Comments: o Structure does not own graph object G => it will not be freed Note: G is the original graph Methods in lib/multisector.c: - ms = newMultisector(graph_t *G); o Initial: nstages = nnodes = totmswght = 0; - void freeMultisector(ms_t *ms); - ms = trivialMultisector(graph_t *G); o allocates memory for the multisector object by a call to newMultisector and sets stage[u] = 0 for all vertices u and nstages = 1; the trivial multisector can be used for pure bottom-up orderings - ms = constructMultisector(graph_t *G, options_t* options, timings_t *cpus); o MASTER_FUNCTION: computes a multisector for G according to the specified ordtype e { MINIMUM_PRIORITY, INCOMPLETE_ND, MULTISECTION, TRISTAGE_MULTISECTION } MINIMUM_PRIORTY: return the multisector obtained by a call to trivialMultisector INCOMPLETE_ND, MULTISECTION, TRISTAGE_MULTISECTION: build separator tree by calling buildNDtree and extract multisector by calling extractMS2stage (MULTISECTION) or extractMSmultistage (INCOMPLETE_ND, TRISTAGE_MULTISECTION) o used options: (also see buildNDtree) OPTION_ORDTYPE, OPTION_DOMAIN_SIZE, OPTION_MSGLVL, OPTION_NODE_SELECTION3 o returned timings: (see buildNDtree) TIME_INITDOMDEC, TIME_COARSEDOMDEC, TIME_INITSEP, TIME_REFINESEP TIME_MULTILEVEL, TIME_SMOOTH - ms = extractMS2stage(nestdiss_t *ndroot); o extracts a 2-stage multisector from the nested dissection tree with root ndroot: stage[u] = 0 => u belongs to a domain stage[u] = 1 => u belongs to the multisector and nstages = 2; the 2-stage multisector can be used for classical multisection orderings - ms = extractMSmultistage(nestdiss_t *ndroot); o extracts a multi-stage multisector from the nested dissection tree at ndroot: stage[u] = 0 => u belongs to a domain stage[u] = i, i > 0 => u belongs to the multisector, i.e.: stage[u] = 1 => u belongs to a leaf separator : stage[u] = nstages-1 => u belongs to the root separator the multisector can be used for incomplete nested dissection orderings or for three-stage multisection orderings ******************************************************************************/ #include /***************************************************************************** ******************************************************************************/ multisector_t* newMultisector(graph_t *G) { multisector_t *ms; mymalloc(ms, 1, multisector_t); mymalloc(ms->stage, G->nvtx, PORD_INT); ms->G = G; ms->nstages = 0; ms->nnodes = 0; ms->totmswght = 0; return(ms); } /***************************************************************************** ******************************************************************************/ void freeMultisector(multisector_t *ms) { free(ms->stage); free(ms); } /***************************************************************************** ******************************************************************************/ multisector_t* trivialMultisector(graph_t *G) { multisector_t *ms; PORD_INT *stage, nvtx, u; /* ----------------------------------------------------------------- allocate memory for the multisector object and init. stage vector ----------------------------------------------------------------- */ nvtx = G->nvtx; ms = newMultisector(G); stage = ms->stage; for (u = 0; u < nvtx; u++) stage[u] = 0; /* no vertex belongs to a separator */ /* ------------------------------- finalize the multisector object ------------------------------- */ ms->nstages = 1; ms->nnodes = 0; ms->totmswght = 0; return(ms); } /***************************************************************************** ******************************************************************************/ multisector_t* constructMultisector(graph_t *G, options_t* options, timings_t *cpus) { multisector_t *ms; nestdiss_t *ndroot; PORD_INT *map, nvtx, ordtype; nvtx = G->nvtx; /* ------------------------------ check number of nodes in graph ------------------------------ */ /* ----------------------------------- JY: inserted the condition "&& (options[OPTION_MSGLVL] > 0)" below, to avoid systematic printing ----------------------------------- */ if ((nvtx <= MIN_NODES) && (options[OPTION_ORDTYPE] != MINIMUM_PRIORITY) && (options[OPTION_MSGLVL] > 0)) { printf("\nWarning in constructMultisector\n" " graph has less than %d nodes, skipping separator construction\n\n", MIN_NODES); options[OPTION_ORDTYPE] = MINIMUM_PRIORITY; } /* -------------------------------------------------------- determine the multisector according to the ordering type -------------------------------------------------------- */ ordtype = options[OPTION_ORDTYPE]; switch(ordtype) { case MINIMUM_PRIORITY: ms = trivialMultisector(G); break; case INCOMPLETE_ND: case MULTISECTION: case TRISTAGE_MULTISECTION: mymalloc(map, nvtx, PORD_INT); ndroot = setupNDroot(G, map); buildNDtree(ndroot, options, cpus); if (ordtype == MULTISECTION) ms = extractMS2stage(ndroot); else ms = extractMSmultistage(ndroot); freeNDtree(ndroot); freeNDnode(ndroot); free(map); break; default: fprintf(stderr, "\nError in function constructMultisector\n" " unrecognized ordering type %d\n", ordtype); quit(); } return(ms); } /***************************************************************************** ******************************************************************************/ multisector_t* extractMS2stage(nestdiss_t *ndroot) { multisector_t *ms; nestdiss_t *nd, *parent; PORD_INT *stage, *intvertex, *intcolor; PORD_INT nvint, nnodes, totmswght, i; /* ----------------------------------------------------------------- allocate memory for the multisector object and init. stage vector ----------------------------------------------------------------- */ ms = trivialMultisector(ndroot->G); stage = ms->stage; /* ------------------------------------------------------------ extract the stages of the separator vertices: stage[u] = 1, iff u belongs to a separator ------------------------------------------------------------ */ nnodes = totmswght = 0; for (nd = ndroot; nd->childB != NULL; nd = nd->childB); while (nd != ndroot) { parent = nd->parent; if ((parent == NULL) || (parent->childB == NULL) || (parent->childW == NULL)) { fprintf(stderr, "\nError in function extractMS2stage\n" " nested dissection tree corrupted\n"); quit(); } if (parent->childB == nd) /* left subtree of parent visited */ for (nd = parent->childW; nd->childB != NULL; nd = nd->childB); else /* right subtree of parent visited */ { nd = parent; /* extract the separator of parent */ totmswght += nd->cwght[GRAY]; nvint = nd->nvint; intvertex = nd->intvertex; intcolor = nd->intcolor; for (i = 0; i < nvint; i++) if (intcolor[i] == GRAY) { nnodes++; stage[intvertex[i]] = 1; } } } /* ------------------------------------------ finalize the multisector object and return ------------------------------------------ */ ms->nstages = 2; ms->nnodes = nnodes; ms->totmswght = totmswght; return(ms); } /***************************************************************************** ******************************************************************************/ multisector_t* extractMSmultistage(nestdiss_t *ndroot) { multisector_t *ms; nestdiss_t *nd, *parent; PORD_INT *stage, *intvertex, *intcolor; PORD_INT nvtx, nvint, maxstage, istage, nnodes, totmswght, i, u; /* ----------------------------------------------------------------- allocate memory for the multisector object and init. stage vector ----------------------------------------------------------------- */ ms = trivialMultisector(ndroot->G); stage = ms->stage; /* ------------------------------------------------------------ extract the stages of the separator vertices: stage[u] = i, i>0, iff u belongs to a separator in depth i-1 ------------------------------------------------------------ */ maxstage = nnodes = totmswght = 0; for (nd = ndroot; nd->childB != NULL; nd = nd->childB); while (nd != ndroot) { parent = nd->parent; if ((parent == NULL) || (parent->childB == NULL) || (parent->childW == NULL)) { fprintf(stderr, "\nError in function extractMSmultistage\n" " nested dissection tree corrupted\n"); quit(); } if (parent->childB == nd) /* left subtree of parent visited */ for (nd = parent->childW; nd->childB != NULL; nd = nd->childB); else /* right subtree of parent visited */ { nd = parent; /* extract the separator of parent */ istage = nd->depth + 1; /* sep. vertices belong to this stage */ maxstage = max(maxstage, istage); totmswght += nd->cwght[GRAY]; nvint = nd->nvint; intvertex = nd->intvertex; intcolor = nd->intcolor; for (i = 0; i < nvint; i++) if (intcolor[i] == GRAY) { nnodes++; stage[intvertex[i]] = istage; } } } /* -------------------------------------------------------------------- we have: stage[u] = 0 => u belongs to a domain stage[u] = 1 => u belongs to the root separator (depth = 0) : stage[u] = maxstage => u belongs to a leaf separator but we must eliminate the separators in a bottom-up fashion; we like to have: stage[u] = 0 => u belongs to a domain stage[u] = 1 => u belongs to a leaf separator : stage[u] = maxstage => u belongs to the root separator -------------------------------------------------------------------- */ nvtx = ndroot->G->nvtx; for (u = 0; u < nvtx; u++) if (stage[u] > 0) stage[u] = maxstage - stage[u] + 1; /* ------------------------------------------ finalize the multisector object and return ------------------------------------------ */ ms->nstages = maxstage + 1; ms->nnodes = nnodes; ms->totmswght = totmswght; return(ms); } MUMPS_5.8.1/PORD/lib/sort.c0000664000175000017500000001407715042446416015122 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: sort.c / / author J"urgen Schulze, University of Paderborn / created 09/15/99 / / This file contains some sorting functions. the code is adopted from / the book "Algorithms in C" by R. Sedgewick. / ******************************************************************************/ #include #define THRES 10 /***************************************************************************** / insertion sort upwards (INTS, without keys) ******************************************************************************/ void insertUpInts(PORD_INT n, PORD_INT *array) { PORD_INT i, j, v; for (i = 1; i < n; i++) { v = array[i]; j = i; while ((j > 0) && (array[j-1] > v)) { array[j] = array[j-1]; j--; } array[j] = v; } } /***************************************************************************** / insertion sort upwards (INTS, with static INT keys) ******************************************************************************/ void insertUpIntsWithStaticIntKeys(PORD_INT n, PORD_INT *array, PORD_INT *key) { PORD_INT i, j, ke; PORD_INT e; for (i = 1; i < n; i++) { e = array[i]; ke = key[e]; j = i; while ((j > 0) && (key[array[j-1]] > ke)) { array[j] = array[j-1]; j--; } array[j] = e; } } /***************************************************************************** / insertion sort downwards (INTS, with static INT keys) ******************************************************************************/ void insertDownIntsWithStaticFloatKeys(PORD_INT n, PORD_INT *array, FLOAT *key) { PORD_INT i, j, e; FLOAT ke; for (i = 1; i < n; i++) { e = array[i]; ke = key[e]; j = i; while ((j > 0) && (key[array[j-1]] < ke)) { array[j] = array[j-1]; j--; } array[j] = e; } } /***************************************************************************** / insertion sort upwards (FLOATS, with INT keys) ******************************************************************************/ void insertUpFloatsWithIntKeys(PORD_INT n, FLOAT *array, PORD_INT *key) { PORD_INT i, j, ke; FLOAT e; for (i = 1; i < n; i++) { e = array[i]; ke = key[i]; j = i; while ((j > 0) && (key[j-1] > ke)) { array[j] = array[j-1]; key[j] = key[j-1]; j--; } array[j] = e; key[j] = ke; } } /***************************************************************************** / median-of-three quicksort upwards (INTS, without keys) ******************************************************************************/ void qsortUpInts(PORD_INT n, PORD_INT *array, PORD_INT *stack) { register PORD_INT i, j; PORD_INT t, l, m, r, p; l = 0; r = n-1; p = 2; while (p > 0) if ((r-l) > THRES) { m = l + ((r-l) >> 1); if (array[l] > array[r]) swap(array[l], array[r], t); if (array[l] > array[m]) swap(array[l], array[m], t); if (array[r] > array[m]) swap(array[m], array[r], t); m = array[r]; i = l-1; j = r; for (;;) { while (array[++i] < m); while (array[--j] > m); if (i >= j) break; swap(array[i], array[j], t); } swap(array[i], array[r], t); if ((i-l) > (r-i)) { stack[p++] = l; stack[p++] = i-1; l = i+1; } else { stack[p++] = i+1; stack[p++] = r; r = i-1; } } else { r = stack[--p]; l = stack[--p]; } if (THRES > 0) insertUpInts(n, array); } /***************************************************************************** / median-of-three quicksort upwards (FLOATS, with INT keys) ******************************************************************************/ void qsortUpFloatsWithIntKeys(PORD_INT n, FLOAT *array, PORD_INT *key, PORD_INT *stack) { register PORD_INT i, j; PORD_INT t, l, m, r, p; FLOAT e; l = 0; r = n-1; p = 2; while (p > 0) if ((r-l) > THRES) { m = l + ((r-l) >> 1); if (key[l] > key[r]) { swap(array[l], array[r], e); swap(key[l], key[r], t); } if (key[l] > key[m]) { swap(array[l], array[m], e); swap(key[l], key[m], t); } if (key[r] > key[m]) { swap(array[m], array[r], e); swap(key[m], key[r], t); } m = key[r]; i = l-1; j = r; for (;;) { while (key[++i] < m); while (key[--j] > m); if (i >= j) break; swap(array[i], array[j], e); swap(key[i], key[j], t); } swap(array[i], array[r], e); swap(key[i], key[r], t); if ((i-l) > (r-i)) { stack[p++] = l; stack[p++] = i-1; l = i+1; } else { stack[p++] = i+1; stack[p++] = r; r = i-1; } } else { r = stack[--p]; l = stack[--p]; } if (THRES > 0) insertUpFloatsWithIntKeys(n, array, key); } /***************************************************************************** / distribution counting (INTS, with static INT keys) ******************************************************************************/ void distributionCounting(PORD_INT n, PORD_INT *node, PORD_INT *key) { register PORD_INT i; PORD_INT *tmp, *count, minkey, maxkey, l, u, vk; /* determine maximal and minimal key */ minkey = MAX_INT; maxkey = 0; for (i = 0; i < n; i++) { u = node[i]; maxkey = max(key[u], maxkey); minkey = min(key[u], minkey); } l = maxkey-minkey; /* printf("minkey %d, maxkey %d, range %d\n", minkey, maxkey, l); */ mymalloc(count, (l+1), PORD_INT); mymalloc(tmp, n, PORD_INT); for (i = 0; i <= l; i++) count[i] = 0; /* scale down all key-values */ for (i = 0; i < n; i++) { u = node[i]; vk = key[u]-minkey; key[u] = vk; count[vk]++; } /* now do the sorting */ for (i = 1; i <= l; i++) count[i] += count[i-1]; for (i = n-1; i >= 0; i--) { u = node[i]; tmp[--count[key[u]]] = u; } for (i = 0; i < n; i++) node[i] = tmp[i]; /* for (i = 0; i < n; i++) { u = node[i]; printf(" node %d, key %d\n", u, key[u]); } */ free(count); free(tmp); } MUMPS_5.8.1/PORD/lib/gelim.c0000664000175000017500000011777115042446416015235 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: gelim.c / / author J"urgen Schulze, University of Paderborn / created 01jan10 / / This file contains functions dealing with the elimination graph object / ****************************************************************************** Data type: struct gelim graph_t *G; pointer to graph object int maxedges; max number of edges that can be stored int *len; length of v's adjacency list int *elen; number of elements adjacent to v int *parent; parent in front tree / representative of v int *degree; boundary size / (approximate) degree int *score; holds the score of uneliminated vertex v Comments: o Structure used to hold the elimination graphs of a bottom-up ordering o G->totvwght: total weight of all uneliminated vertices o G->xadj[v] = -1 => there is no adjacency list for variable/element v => variable v has degree 0 (in this case G->vwght[v] > 0) => variable v istinguishable/removed by mass elimination or element v has been absorbed (in this case G->vwght[v] = 0) o G->vwght[v]: weight of the princial variable v; if v becomes an element, weight[v] remains unchanged for the rest of the elim. process = 0 => variable v is nonprincipal/removed by mass elimination o len[v], elen[v]: the adjacency list of vertex/element v contains len[v] entries; the first elen[v] entries are elements (if v is an element, then elen[v] = 0 will hold) o parent[v]: for an (absorbed) element, parent[v] points to the parent of element v in the front tree; for an indistinguishable vertex, parent[v] points to its representative vertex (which may have also found to be indistinguishable to another one) o degree[v]: for an uneliminated vertex, the (approximate) degree in Gelim; for an element, the weight of its boundary (i.e. degree[v] gives the exakt degree of v at the time of its elimination) o score[v]: vertices are eliminated according to their score value >= 0; additionally, the score vector is used to represent the status of a node in the actual stage: -1, iff variable v will be eliminated in an upcomming stage -2, iff variable v is nonprincipal/removed by mass elim. -3, iff variable v has been eliminated and now forms an element -4, iff element v has been absorbed Methods in lib/gelim.c - Gelim = newElimGraph(int nvtx, int nedges); - void freeElimGraph(gelim_t *Gelim); - void printElimGraph(gelim_t *Gelim); - Gelim = setupElimGraph(graph_t *G); o allocates memory for the elimination graph by calling newElimGraph and initializes the vectors, i.e. len[u] = xadj[u+1]-xadj[u]; elen[u] = 0; parent[u] = -1; degree[u] = exact (external) degree of vertex u; score[u] = -1; xadj[u] = -1, if len[u] = 0 - int crunchElimGraph(gelim_t *Gelim); o tries to compress the adjacency vector on success the function return TRUE, otherwise FALSE - void buildElement(gelim_t *Gelim, int me); o turns variable me into an element; if me is an leaf, the element is constructed in-place, otherwise its adjacency list is appended to G o all relevant vectors are updated, i.e. vwght[me] = 0, degree[me] = |Lme|, score[me] = -3 for all neighboring elements: parent[e] = me, score[e] = -4 - void updateAdjncy(gelim_t *Gelim, int *reachset, int nreach, int *tmp, int *pflag); o updates the adjacency structure of all vertices in reachset IMPORTANT REQUIREMENTS: (1) all values stored in tmp[u] are smaller than *pflag - void findIndNodes(gelim_t *Gelim, int *reachset, int nreach, int *bin, int *next, int *tmp, int *pflag); o searches reachset for indistinguishable vertices IMPORTANT REQUIREMENTS: (1) the adjacency lists of all vertices in reachset have been updated by a call to updateAdjncy (2) bin[i] = -1 for all 0 <= i < G->nvtx (3) all values stored in tmp[u] are smaller than *pflag o on return bin[i] = -1 holds again - void updateDegree(gelim_t *Gelim, int *reachset, int nreach, int *bin); o computes new approximate degrees for all vertices in reachset IMPORTANT REQUIREMENTS: (1) the adjacency lists of all vertices in reachset have been updated by a call to updateAdjncy (2) the boundary size of each newly formed element has been computed (3) bin[i] = -1 for all 0 <= i < G->nvtx o on return bin[i] = -1 holds again - void updateScore(gelim_t *Gelim, int *reachset, int nreach, int scoretype, int *bin); o updates the score of all vertices in reachset IMPORTANT REQUIREMENTS: (1) the approximate degrees are correctly computed (by updateDegree) (2) bin[i] = -1 for all 0 <= i < G->nvtx o on return bin[i] = -1 holds again - T = extractElimTree(gelim_t *Gelim); o uses the status of the nodes (stored in the score vector) and the parent vector to set up the elimination tree T; vectors T->ncolfactor and T->ncolupdate are initialized using vectors G->vwght and degree ******************************************************************************/ #include /* #define DEBUG */ /***************************************************************************** ******************************************************************************/ gelim_t* newElimGraph(PORD_INT nvtx, PORD_INT nedges) { gelim_t *Gelim; mymalloc(Gelim, 1, gelim_t); Gelim->G = newGraph(nvtx, nedges); Gelim->maxedges = nedges; mymalloc(Gelim->len, nvtx, PORD_INT); mymalloc(Gelim->elen, nvtx, PORD_INT); mymalloc(Gelim->parent, nvtx, PORD_INT); mymalloc(Gelim->degree, nvtx, PORD_INT); mymalloc(Gelim->score, nvtx, PORD_INT); return(Gelim); } /***************************************************************************** ******************************************************************************/ void freeElimGraph(gelim_t *Gelim) { freeGraph(Gelim->G); free(Gelim->len); free(Gelim->elen); free(Gelim->parent); free(Gelim->degree); free(Gelim->score); free(Gelim); } /***************************************************************************** ******************************************************************************/ void printElimGraph(gelim_t *Gelim) { graph_t *G; PORD_INT count, u, v, i, istart; G = Gelim->G; for (u = 0; u < G->nvtx; u++) { istart = G->xadj[u]; /* --------------------------------------------------------------- case 1: u is a principal variable => vwght[u]: weight of all mapped indistinguishable variables => degree[u]: approximate degree ---------------------------------------------------------------- */ if ((Gelim->score[u] == -1) || (Gelim->score[u] >= 0)) { printf("--- adjacency list of variable %d (weight %d, degree %d, " "score %d):\n", u, G->vwght[u], Gelim->degree[u], Gelim->score[u]); printf("elements:\n"); count = 0; for (i = istart; i < istart + Gelim->elen[u]; i++) { printf("%5d", G->adjncy[i]); if ((++count % 16) == 0) printf("\n"); } if ((count % 16) != 0) printf("\n"); printf("variables:\n"); count = 0; for (i = istart + Gelim->elen[u]; i < istart + Gelim->len[u]; i++) { printf("%5d", G->adjncy[i]); if ((++count % 16) == 0) printf("\n"); } if ((count % 16) != 0) printf("\n"); } /* --------------------------------------------------------------- case 2: u is nonprincipal/removed by mass elimination ---------------------------------------------------------------- */ else if (Gelim->score[u] == -2) printf("--- variable %d is nonprincipal/removed by mass elim. " "(parent %d)\n", u, Gelim->parent[u]); /* ----------------------------------------------- case 3: u is an element: => degree[u]: weight of boundary ----------------------------------------------- */ else if (Gelim->score[u] == -3) { printf("--- boundary of element %d (degree %d, score %d):" "\n", u, Gelim->degree[u], Gelim->score[u]); count = 0; for (i = istart; i < istart + Gelim->len[u]; i++) { v = G->adjncy[i]; if (G->vwght[v] > 0) { printf("%5d", G->adjncy[i]); if ((++count % 16) == 0) printf("\n"); } } if ((count % 16) != 0) printf("\n"); } /* -------------------------------- case 4: u is an absorbed element -------------------------------- */ else if (Gelim->score[u] == -4) printf("--- element %d has been absorbed (parent %d)\n", u, Gelim->parent[u]); /* ---------------------------------------- none of the above cases is true => error ---------------------------------------- */ else { fprintf(stderr, "\nError in function printElimGraph\n" " node %d has invalid score %d\n", u, Gelim->score[u]); quit(); } } } /***************************************************************************** ******************************************************************************/ gelim_t* setupElimGraph(graph_t *G) { gelim_t *Gelim; PORD_INT *xadj, *adjncy, *vwght, *xadjGelim, *adjncyGelim, *vwghtGelim; PORD_INT *len, *elen, *parent, *degree, *score; PORD_INT nvtx, nedges, deg, u, i, istart, istop; nvtx = G->nvtx; nedges = G->nedges; xadj = G->xadj; adjncy = G->adjncy; vwght = G->vwght; Gelim = newElimGraph(nvtx, nedges+nvtx); xadjGelim = Gelim->G->xadj; adjncyGelim = Gelim->G->adjncy; vwghtGelim = Gelim->G->vwght; len = Gelim->len; elen = Gelim->elen; parent = Gelim->parent; degree = Gelim->degree; score = Gelim->score; /* -------------- copy the graph -------------- */ Gelim->G->type = G->type; Gelim->G->totvwght = G->totvwght; for (u = 0; u < nvtx; u++) { xadjGelim[u] = xadj[u]; vwghtGelim[u] = vwght[u]; } xadjGelim[nvtx] = xadj[nvtx]; for (i = 0; i < nedges; i++) adjncyGelim[i] = adjncy[i]; Gelim->G->nedges = nedges; /* ---------------------- initialize all vectors ---------------------- */ for (u = 0; u < nvtx; u++) { istart = xadj[u]; istop = xadj[u+1]; len[u] = istop - istart; elen[u] = 0; parent[u] = -1; deg = 0; switch(Gelim->G->type) /* compute the external degree of u */ { case UNWEIGHTED: deg = len[u]; break; case WEIGHTED: for (i = istart; i < istop; i++) deg += vwght[adjncy[i]]; break; default: fprintf(stderr, "\nError in function setupElimGraph\n" " unrecognized graph type %d\n", Gelim->G->type); } degree[u] = deg; if (len[u] == 0) /* len(u) = 0 => adjncy list of u not in use */ xadjGelim[u] = -1; /* mark with -1, otherwise crunchElimGraph fails */ score[u] = -1; } return(Gelim); } /***************************************************************************** ******************************************************************************/ PORD_INT crunchElimGraph(gelim_t *Gelim) { PORD_INT *xadj, *adjncy, *len; PORD_INT nvtx, nedges, u, i, isrc, idest; nvtx = Gelim->G->nvtx; nedges = Gelim->G->nedges; xadj = Gelim->G->xadj; adjncy = Gelim->G->adjncy; len = Gelim->len; /* --------------------------------------------- mark begining of u's adjacency list by -(u+1) --------------------------------------------- */ for (u = 0; u < nvtx; u++) { i = xadj[u]; /* is adjacency list of u still in use? */ if (i != -1) /* verify that list is non-empty */ { if (len[u] == 0) { fprintf(stderr, "\nError in function crunchElimGraph\n" " adjacency list of node %d is empty\n", u); quit(); } xadj[u] = adjncy[i]; /* if so, move first item to xadj[u] */ adjncy[i] = -(u+1); /* u's adjacency list is headed by -(u+1) */ if (len[u] == 0) printf("error: u %d, len %d\n", u, len[u]); } } /* -------------------------- crunch all adjacency lists -------------------------- */ idest = isrc = 0; while (isrc < Gelim->G->nedges) { u = adjncy[isrc++]; if (u < 0) /* a new adjacency list starts here */ { u = -u - 1; /* it's the adjacency list of u */ adjncy[idest] = xadj[u]; /* first item was stored in xadj[u] */ xadj[u] = idest++; for (i = 1; i < len[u]; i++) adjncy[idest++] = adjncy[isrc++]; } } Gelim->G->nedges = idest; /* ------------------ was it successful? ------------------ */ if (idest < nedges) return(TRUE); else return (FALSE); } /***************************************************************************** ******************************************************************************/ void buildElement(gelim_t *Gelim, PORD_INT me) { graph_t *G; PORD_INT *xadj, *adjncy, *vwght, *len, *elen, *parent, *degree, *score; PORD_INT degme, elenme, vlenme, mesrcptr, medeststart, medeststart2; PORD_INT medestptr, ln, p, i, j, v, e; G = Gelim->G; xadj = G->xadj; adjncy = G->adjncy; vwght = G->vwght; len = Gelim->len; elen = Gelim->elen; parent = Gelim->parent; degree = Gelim->degree; score = Gelim->score; /* --------------------------------- construct boundary of element Lme --------------------------------- */ degme = 0; G->totvwght -= vwght[me]; /* me eliminated => reduce weight of Gelim */ vwght[me] = -vwght[me]; score[me] = -3; /* variable me becomes an element */ elenme = elen[me]; vlenme = len[me] - elenme; mesrcptr = xadj[me]; /* ----------------------------------------------------------- if me is a leaf => its boundary can be constructed in-place ----------------------------------------------------------- */ if (elenme == 0) { medeststart = xadj[me]; /* Lme overwrites old variable */ medestptr = medeststart; /* boundary of Lme starts here */ for (i = 0; i < vlenme; i++) { v = adjncy[mesrcptr++]; if (vwght[v] > 0) /* v not yet placed in boundary */ { degme += vwght[v]; /* increase size of Lme */ vwght[v] = -vwght[v]; /* flag v as being in Lme */ adjncy[medestptr++] = v; } } } /* ------------------------------------------------------------------- me is not a leaf => its boundary must be constructed in empty space ------------------------------------------------------------------- */ else { medeststart = G->nedges; /* Lme appended to graph */ medestptr = medeststart; /* boundary of Lme starts here */ for (i = 0; i <= elenme; i++) { if (i < elenme) /* working on elements */ { len[me]--; e = adjncy[mesrcptr++]; /* merge boundary of element e with Lme */ p = xadj[e]; /* adjacency list of e starts here */ ln = len[e]; } else { e = me; /* merge uncovered variables with Lme */ p = mesrcptr; /* variables start here */ ln = vlenme; } for (j = 0; j < ln; j++) { len[e]--; /* pick next variable, decrease length */ v = adjncy[p++]; if (vwght[v] > 0) { degme += vwght[v]; /* increase size of Lme */ vwght[v] = -vwght[v]; /* flag v as being in Lme */ /* ------------------------------------------ add v to Lme, compress adjncy if necessary ------------------------------------------ */ if (medestptr == Gelim->maxedges) { if (len[me] == 0) xadj[me] = -1; else xadj[me] = mesrcptr; if (len[e] == 0) xadj[e] = -1; else xadj[e] = p; /* crunch adjacency list -- !!!we need more memory!!! */ if (!crunchElimGraph(Gelim)) { fprintf(stderr, "\nError in function buildElement\n" " unable to construct element (not enough memory)\n"); quit(); } /* crunch partially constructed element me */ medeststart2 = G->nedges; for (p = medeststart; p < medestptr; p++) adjncy[G->nedges++] = adjncy[p]; medeststart = medeststart2; medestptr = G->nedges; mesrcptr = xadj[me]; p = xadj[e]; } adjncy[medestptr++] = v; } } /* ---------------------- mark absorbed elements ---------------------- */ if (e != me) { xadj[e] = -1; parent[e] = me; score[e] = -4; } } G->nedges = medestptr; /* new element Lme ends here */ } /* ----------------------------------- element me successfully constructed ----------------------------------- */ degree[me] = degme; xadj[me] = medeststart; vwght[me] = -vwght[me]; elen[me] = 0; len[me] = medestptr - medeststart; if (len[me] == 0) xadj[me] = -1; /* --------------------------- unmark all variables in Lme --------------------------- */ mesrcptr = xadj[me]; vlenme = len[me]; for (i = 0; i < vlenme; i++) { v = adjncy[mesrcptr++]; vwght[v] = -vwght[v]; } } /***************************************************************************** ******************************************************************************/ void updateAdjncy(gelim_t *Gelim, PORD_INT *reachset, PORD_INT nreach, PORD_INT *tmp, PORD_INT *pflag) { PORD_INT *xadj, *adjncy, *vwght, *len, *elen, *parent, *score; PORD_INT u, v, e, me, i, j, jj, jdest, jfirstolde, jfirstv, jstart, jstop; PORD_INT covered, marku; xadj = Gelim->G->xadj; adjncy = Gelim->G->adjncy; vwght = Gelim->G->vwght; len = Gelim->len; elen = Gelim->elen; parent = Gelim->parent; score = Gelim->score; /* ----------------------------------------------------------------- build the new element/variable list for each variable in reachset ----------------------------------------------------------------- */ for (i = 0; i < nreach; i++) { u = reachset[i]; vwght[u] = -vwght[u]; /* mark all variables in reachset */ jstart = xadj[u]; jstop = xadj[u] + len[u]; jdest = jfirstolde = jstart; #ifdef DEBUG printf("Updating adjacency list of node %d\n", u); #endif /* -------------------------------------------------------- scan the list of elements associated with variable u place newly formed elements at the beginning of the list -------------------------------------------------------- */ for (j = jstart; j < jstart + elen[u]; j++) { e = adjncy[j]; #ifdef DEBUG printf(" >> element %d (score %d, parent %d)\n", e,score[e],parent[e]); #endif if (score[e] == -4) /* e has been absorbed in this elim. step */ { me = parent[e]; /* me is the newly formed element */ if (tmp[me] < *pflag) { adjncy[jdest++] = adjncy[jfirstolde]; /* move 1st old e to end */ adjncy[jfirstolde++] = me; /* append me at the beg. */ tmp[me] = *pflag; } } else /* e has not been absorbed, i.e. it is */ if (tmp[e] < *pflag) /* an old element */ { adjncy[jdest++] = e; tmp[e] = *pflag; } } jfirstv = jdest; /* list of variables starts here */ /* ------------------------------------------------------- scan the list of variables associated with variable u place newly formed elements at the begining of the list ------------------------------------------------------- */ for (j = jstart + elen[u]; j < jstop; j++) { v = adjncy[j]; #ifdef DEBUG printf(" >> variable %d (score %d)\n", v, score[v]); #endif if (score[v] == -3) /* v has been eliminated in this step */ { if (tmp[v] < *pflag) /* and, thus, forms a newly created elem. */ { adjncy[jdest++] = adjncy[jfirstv]; /* move 1st var. to end */ adjncy[jfirstv++] = adjncy[jfirstolde]; /* move 1st old e to end */ adjncy[jfirstolde++] = v; /* append v at the beg. */ tmp[v] = *pflag; } } else adjncy[jdest++] = v; /* v is still a variable */ } elen[u] = jfirstv - jstart; len[u] = jdest - jstart; (*pflag)++; /* clear tmp for next round */ #ifdef DEBUG printf(" node %d: neighboring elements:\n", u); for (j = jstart; j < jstart + elen[u]; j++) printf("%5d", adjncy[j]); printf("\n node %d: neighboring variables:\n", u); for (j = jstart + elen[u]; j < jstart + len[u]; j++) printf("%5d", adjncy[j]); printf("\n"); #endif } /* --------------------------------------------------------- remove from each list all covered edges between variables --------------------------------------------------------- */ for (i = 0; i < nreach; i++) { u = reachset[i]; jstart = xadj[u]; jstop = jstart + len[u]; marku = FALSE; for (jdest = j = jstart + elen[u]; j < jstop; j++) { v = adjncy[j]; if (vwght[v] > 0) /* v does not belong to reachset */ adjncy[jdest++] = v; /* edge (u,v) not covered */ if (vwght[v] < 0) /* both vertices belong to reachset */ { covered = FALSE; /* check for a common element */ if (!marku) { for (jj = jstart; jj < jstart + elen[u]; jj++) /* mark elem. */ tmp[adjncy[jj]] = *pflag; /* of u */ marku = TRUE; } for (jj = xadj[v]; jj < xadj[v] + elen[v]; jj++) /* check elem. */ if (tmp[adjncy[jj]] == *pflag) /* of v */ { covered = TRUE; break; } if (!covered) adjncy[jdest++] = v; } } len[u] = jdest - jstart; (*pflag)++; /* clear tmp for next round */ #ifdef DEBUG printf(" node %d: neighboring uncovered variables:\n", u); for (j = jstart + elen[u]; j < jstart + len[u]; j++) printf("%5d", adjncy[j]); printf("\n"); #endif } /* -------------------------------- unmark all variables in reachset -------------------------------- */ for (i = 0; i < nreach; i++) { u = reachset[i]; vwght[u] = -vwght[u]; } } /***************************************************************************** ******************************************************************************/ void findIndNodes(gelim_t *Gelim, PORD_INT *reachset, PORD_INT nreach, PORD_INT *bin, PORD_INT *next, PORD_INT *tmp, PORD_INT *pflag) { PORD_INT *xadj, *adjncy, *vwght, *len, *elen, *parent, *score; PORD_INT nvtx, chk, keepon, u, v, w, wlast, i, j, jstart, jstop, jstep, jj, jjstop; nvtx = Gelim->G->nvtx; xadj = Gelim->G->xadj; adjncy = Gelim->G->adjncy; vwght = Gelim->G->vwght; len = Gelim->len; elen = Gelim->elen; parent = Gelim->parent; score = Gelim->score; #ifdef DEBUG printf("Checking reachset for indistinguishable variables\n"); #endif /* ----------------------------------------------------------------------- compute checksums for all principal variables on reachset and fill bins NOTE: checksums are stored in parent vector ----------------------------------------------------------------------- */ for (i = 0; i < nreach; i++) { u = reachset[i]; chk = 0; jstart = xadj[u]; jstop = jstart + len[u]; /* Modified by JYL: 16 march 2005: * This code was failing in case of * overflow. for (j = jstart; j < jstop; j++) chk += adjncy[j]; chk = chk % nvtx; */ jstep=max(1000000000/nvtx,1); for (j = jstart; j < jstop; j+=jstep) { jjstop = min(jstop, j+jstep); for (jj = j; jj < jjstop; jj++) chk += adjncy[jj]; chk = chk % nvtx; } parent[u] = chk; /* JYL: temporary: if (parent[u] < - 10) printf("Probleme %d \n",chk);*/ next[u] = bin[chk]; bin[chk] = u; } /* ----------------------- supervariable detection ----------------------- */ for (i = 0; i < nreach; i++) { u = reachset[i]; if (vwght[u] > 0) /* u is a principal variable */ { chk = parent[u]; /* search bin[chk] for ind. nodes */ v = bin[chk]; /* okay, v is the first node in this bin */ bin[chk] = -1; /* no further examinations of this bin */ while (v != -1) { jstart = xadj[v]; jstop = xadj[v] + len[v]; for (j = jstart; j < jstop; j++) tmp[adjncy[j]] = *pflag; w = next[v]; /* v is principal and w is a potential */ wlast = v; /* nonprincipal variable */ while (w != -1) { keepon = TRUE; if ((len[w] != len[v]) || (elen[w] != elen[v]) || ((score[w] < 0) && (score[v] >= 0)) || ((score[w] >= 0) && (score[v] < 0))) keepon = FALSE; if (keepon) { for (jj = xadj[w]; jj < xadj[w] + len[w]; jj++) if (tmp[adjncy[jj]] < *pflag) { keepon = FALSE; break; } } if (keepon) /* found it! mark w as nonprincipal */ { parent[w] = v; /* representative of w is v */ /* Temporary JY if (parent[w] < - 10) printf("Probleme\n"); */ #ifdef DEBUG printf(" non-principal variable %d (score %d) mapped onto " "%d (score %d)\n", w, score[w], v, score[v]); #endif vwght[v] += vwght[w]; /* add weight of w */ vwght[w] = 0; xadj[w] = -1; /* w's adjacency list can be over- */ score[w] = -2; /* written during next crunch */ w = next[w]; next[wlast] = w; /* remove w from bin */ } else /* failed */ { wlast = w; w = next[w]; } } v = next[v]; /* no more variables can be absorbed by v */ (*pflag)++; /* clear tmp vector for next round */ } } } /* ------------------------------------------------------- re-initialize parent vector for all principal variables ------------------------------------------------------- */ for (i = 0; i < nreach; i++) { u = reachset[i]; if (vwght[u] > 0) parent[u] = -1; } } /***************************************************************************** ******************************************************************************/ void updateDegree(gelim_t *Gelim, PORD_INT *reachset, PORD_INT nreach, PORD_INT *bin) { PORD_INT *xadj, *adjncy, *vwght, *len, *elen, *degree; PORD_INT totvwght, deg, vwghtv, u, v, w, e, me, r, i, istart, istop; PORD_INT j, jstart, jstop; totvwght = Gelim->G->totvwght; xadj = Gelim->G->xadj; adjncy = Gelim->G->adjncy; vwght = Gelim->G->vwght; len = Gelim->len; elen = Gelim->elen; degree = Gelim->degree; /* ------------------------------------------------------------------- degree update only for those vertices in reachset that are adjacent to an element ------------------------------------------------------------------- */ for (r = 0; r < nreach; r++) { u = reachset[r]; if (elen[u] > 0) bin[u] = 1; } /* ----------------------------------------- and now do the approximate degree updates ----------------------------------------- */ for (r = 0; r < nreach; r++) { u = reachset[r]; if (bin[u] == 1) /* me is the most recently formed element */ { me = adjncy[xadj[u]]; /* in the neighborhood of u */ #ifdef DEBUG printf("Updating degree of all variables in L(%d) (initiated by %d)\n", me, u); #endif /* ---------------------------------------------------------------- compute in bin[e] the size of Le\Lme for all unabsorbed elements ---------------------------------------------------------------- */ istart = xadj[me]; istop = istart + len[me]; /* compute in bin[e] the size */ for (i = istart; i < istop; i++) /* of Le/Lme for all elements */ { v = adjncy[i]; /* e != me that are adjacent */ vwghtv = vwght[v]; /* to a principal var. e Lme */ if (vwghtv > 0) { jstart = xadj[v]; jstop = jstart + elen[v]; for (j = jstart; j < jstop; j++) { e = adjncy[j]; if (e != me) { if (bin[e] > 0) bin[e] -= vwghtv; else bin[e] = degree[e] - vwghtv; } } } } #ifdef DEBUG for (i = istart; i < istop; i++) { v = adjncy[i]; if (vwght[v] > 0) for (j = xadj[v]; j < xadj[v] + elen[v]; j++) { e = adjncy[j]; if (e != me) printf(" >> element %d: degree %d, outer degree %d\n", e, degree[e], bin[e]); } } #endif /* ------------------------------------------------------ update approx. degree for all v in Lme with bin[v] = 1 ------------------------------------------------------ */ for (i = istart; i < istop; i++) { v = adjncy[i]; /* update the upper bound deg. */ vwghtv = vwght[v]; /* of all principal variables */ deg = 0; /* in Lme that have not been */ if (bin[v] == 1) /* updated yet */ { jstart = xadj[v]; jstop = jstart + len[v]; /* scan the element list associated with principal v */ for (j = jstart; j < jstart + elen[v]; j++) { e = adjncy[j]; if (e != me) deg += bin[e]; } /* scan the supervariables in the list associated with v */ for (j = jstart + elen[v]; j < jstop; j++) { w = adjncy[j]; deg += vwght[w]; } /* compute the external degree of v (add size of Lme) */ deg = min(degree[v], deg); degree[v] = max(1, min(deg+degree[me]-vwghtv, totvwght-vwghtv)); bin[v] = -1; #ifdef DEBUG printf(" >> variable %d (totvwght %d, vwght %d): deg %d, " "degme %d, approx degree %d\n", v, totvwght, vwghtv, deg, degree[me], degree[v]); #endif } } /* ------------------------------------ clear bin[e] of all elements e != me ------------------------------------ */ for (i = istart; i < istop; i++) { v = adjncy[i]; vwghtv = vwght[v]; if (vwghtv > 0) { jstart = xadj[v]; jstop = jstart + elen[v]; for (j = jstart; j < jstop; j++) { e = adjncy[j]; if (e != me) bin[e] = -1; } } } } } } /***************************************************************************** ******************************************************************************/ void updateScore(gelim_t *Gelim, PORD_INT *reachset, PORD_INT nreach, PORD_INT scoretype, PORD_INT *bin) { PORD_INT *xadj, *adjncy, *vwght, *len, *elen, *degree, *score; PORD_INT vwghtv, deg, degme, u, v, me, r, i, istart, istop; /* Modified by JYL, 16 march 2005. * scr could overflow for quasi dense rows. * Use a double instead for large degrees * aset it near to MAX_INT in case of problem. */ double scr_dbl; PORD_INT scr; xadj = Gelim->G->xadj; adjncy = Gelim->G->adjncy; vwght = Gelim->G->vwght; len = Gelim->len; elen = Gelim->elen; degree = Gelim->degree; score = Gelim->score; /* ------------------------------------------------------------------ score update only for those vertices in reachset that are adjacent to an element ------------------------------------------------------------------ */ for (r = 0; r < nreach; r++) { u = reachset[r]; if (elen[u] > 0) bin[u] = 1; } /* ---------------------------- and now do the score updates ---------------------------- */ scoretype = scoretype % 10; for (r = 0; r < nreach; r++) { u = reachset[r]; if (bin[u] == 1) /* me is the most recently formed element */ { me = adjncy[xadj[u]]; /* in the neighborhood of u */ #ifdef DEBUG printf("Updating score of all variables in L(%d) (initiated by %d)\n", me, u); #endif istart = xadj[me]; istop = xadj[me] + len[me]; for (i = istart; i < istop; i++) { v = adjncy[i]; /* update score of all principal */ if (bin[v] == 1) /* variables in Lme that have not */ { vwghtv = vwght[v]; /* been updated yet */ deg = degree[v]; degme = degree[me] - vwghtv; if (deg > 40000 || degme > 40000) { switch(scoretype) { case AMD: scr_dbl = (double)deg; break; case AMF: scr_dbl = (double)deg*(double)(deg-1)/2 - (double)degme*(double)(degme-1)/2; break; case AMMF: scr_dbl = ((double)deg*(double)(deg-1)/2 - (double)degme*(double)(degme-1)/2) / (double)vwghtv; break; case AMIND: scr_dbl = max(0, ((double)deg*(double)(deg-1)/2 - (double)degme*(double)(degme-1)/2) - (double)deg*(double)vwghtv); break; default: fprintf(stderr, "\nError in function updateScore\n" " unrecognized selection strategy %d\n", scoretype); quit(); } /* Some buckets have offset nvtx / 2. * Using MAX_INT - nvtx should then be safe */ score[v] = (PORD_INT) (min(scr_dbl,MAX_INT-Gelim->G->nvtx)); } else { switch(scoretype) { case AMD: scr = deg; break; case AMF: scr = deg*(deg-1)/2 - degme*(degme-1)/2; break; case AMMF: scr = (deg*(deg-1)/2 - degme*(degme-1)/2) / vwghtv; break; case AMIND: scr = max(0, (deg*(deg-1)/2 - degme*(degme-1)/2) - deg*vwghtv); break; default: fprintf(stderr, "\nError in function updateScore\n" " unrecognized selection strategy %d\n", scoretype); quit(); } score[v] = scr; } bin[v] = -1; #ifdef DEBUG printf(" >> variable %d (me %d): weight %d, (ext)degme %d, " "degree %d, score %d\n", u, me, vwghtv, degme, degree[v], score[v]); #endif if (score[v] < 0) { fprintf(stderr, "\nError in function updateScore\n" " score[%d] = %d is negative\n", v, score[v]); quit(); } } } } } } /*****************************************************************************) ******************************************************************************/ elimtree_t* extractElimTree(gelim_t *Gelim) { elimtree_t *T; PORD_INT *vwght, *par, *degree, *score, *sib, *fch; PORD_INT *ncolfactor, *ncolupdate, *parent, *vtx2front; PORD_INT nvtx, nfronts, root, u, v, front; nvtx = Gelim->G->nvtx; vwght = Gelim->G->vwght; par = Gelim->parent; degree = Gelim->degree; score = Gelim->score; /* ------------------------ allocate working storage ------------------------ */ mymalloc(sib, nvtx, PORD_INT); mymalloc(fch, nvtx, PORD_INT); for (u = 0; u < nvtx; u++) sib[u] = fch[u] = -1; /* -------------------------------------------------------------- count fronts and create top-down view of the tree given by par -------------------------------------------------------------- */ nfronts = 0; root = -1; for (u = 0; u < nvtx; u++) switch(score[u]) { case -2: /* variable u is nonprincipal */ break; case -3: /* variable u has been elim. and now forms an elem. */ sib[u] = root; root = u; nfronts++; break; case -4: /* element u has been absorbed by par[u] */ v = par[u]; sib[u] = fch[v]; fch[v] = u; nfronts++; break; default: fprintf(stderr, "\nError in function extractElimTree\n" " ordering not complete (score[%d] = %d)\n", u, score[u]); quit(); } #ifdef DEBUG for (u = 0; u < nvtx; u++) printf("node %d: score %d, par %d, fch %d, sib %d\n", u, score[u], par[u], fch[u], sib[u]); #endif /* -------------------------------------- allocate space for the elimtree object -------------------------------------- */ T = newElimTree(nvtx, nfronts); ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; parent = T->parent; vtx2front = T->vtx2front; /* ------------------------------------------------------------- fill the vtx2front vector so that representative vertices are mapped in a post-order traversal ------------------------------------------------------------- */ nfronts = 0; u = root; while (u != -1) { while (fch[u] != -1) u = fch[u]; vtx2front[u] = nfronts++; while ((sib[u] == -1) && (par[u] != -1)) { u = par[u]; vtx2front[u] = nfronts++; } u = sib[u]; } /* --------------------------------------------------- fill in the vtx2front map for nonprincipal vertices --------------------------------------------------- */ for (u = 0; u < nvtx; u++) if (score[u] == -2) { v = u; while ((par[v] != -1) && (score[v] == -2)) v = par[v]; vtx2front[u] = vtx2front[v]; } /* ------------------------------------------------------------- set up the parent vector of T and fill ncolfactor, ncolupdate ------------------------------------------------------------- */ for (u = 0; u < nvtx; u++) { front = vtx2front[u]; if (score[u] == -3) { parent[front] = -1; ncolfactor[front] = vwght[u]; ncolupdate[front] = degree[u]; } if (score[u] == -4) { parent[front] = vtx2front[par[u]]; ncolfactor[front] = vwght[u]; ncolupdate[front] = degree[u]; } } /* ---------------------------- set up all other arrays of T ---------------------------- */ initFchSilbRoot(T); /* ---------------------- free memory and return ---------------------- */ free(sib); free(fch); return(T); } MUMPS_5.8.1/PORD/lib/gbisect.c0000664000175000017500000004254215042446416015551 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: gbisect.c / / author J"urgen Schulze, University of Paderborn / created 00dec29 / / This file contains functions dealing with the graph bisection object / ****************************************************************************** Data type: struct gbisect graph_t *G; pointer to graph that will be partitioned int *color; color of node (GRAY, BLACK, or WHITE) int cwght[3]; weights of GRAY, BLACK, WHITE partitions Comments: o Structure used to compute the bisection of a graph. Structure does not own graph object => it will not be freed. Methods in lib/gbisect.c: - Gbisect = newGbisect(graph_t *G); o Initial: cwght[GRAY] = cwght[BLACK] = cwght[WHITE] = 0 - void freeGbisect(gbisect_t *Gbisect); - void printGbisect(gbisect_t *Gbisect); - void checkSeparator(gbisect_t *Gbisect); - void constructSeparator(gbisect_t *Gbisect, options_t *options, timings_t *cpus); o constructs a vertex separator by applying the new multilevel approach; it first constructs an initial domain decomposition for Gbisect->G by calling constructDomainDecomposition; the dd is then coarsed by several calls to shrinkDomainDecomposition; the last dd is colored by a call to initialDDSep; this coloring is refined during the uncoarsening phase by several calls to improveDDSep o used options: OPTION_MSGLVL, OPTION_NODE_SELECTION3 returned timings: TIME_INITDOMDEC, TIME_COARSEDOMDEC, TIME_INITSEP, TIME_REFINESEP - int smoothBy2Layers(gbisect_t *Gbisect, int *bipartvertex, int *pnX, int black, int white); o on start, bipartvertex contains the nodes of the separator; the separator is then paired with eiter the black or the white partition so that the nodes in bipartvertex induce a bipartite graph; this graph is constructed by setupBipartiteGraph; a Dulmage-Mendelsohn decomposition is computed and the separator is smoothed; the vertices of the smoothed separator are returned in bipartvertex - void smoothSeparator(gbisect_t *Gbisect, options_t *options); o smoothes a given separator by repeatedly calling smoothBy2Layers o used options: OPTION_MSGLVL ******************************************************************************/ #include /* #define DEBUG */ /* #define BE_CAUTIOUS */ /***************************************************************************** ******************************************************************************/ gbisect_t* newGbisect(graph_t *G) { gbisect_t *Gbisect; mymalloc(Gbisect, 1, gbisect_t); mymalloc(Gbisect->color, G->nvtx, PORD_INT); Gbisect->G = G; Gbisect->cwght[GRAY] = 0; Gbisect->cwght[BLACK] = 0; Gbisect->cwght[WHITE] = 0; return(Gbisect); } /***************************************************************************** ******************************************************************************/ void freeGbisect(gbisect_t *Gbisect) { free(Gbisect->color); free(Gbisect); } /***************************************************************************** ******************************************************************************/ void printGbisect(gbisect_t *Gbisect) { graph_t *G; PORD_INT count, u, v, i, istart, istop; G = Gbisect->G; printf("\n#nodes %d, #edges %d, totvwght %d\n", G->nvtx, G->nedges >> 1, G->totvwght); printf("partition weights: S %d, B %d, W %d\n", Gbisect->cwght[GRAY], Gbisect->cwght[BLACK], Gbisect->cwght[WHITE]); for (u = 0; u < G->nvtx; u++) { count = 0; printf("--- adjacency list of node %d (weight %d, color %d)\n", u, G->vwght[u], Gbisect->color[u]); istart = G->xadj[u]; istop = G->xadj[u+1]; for (i = istart; i < istop; i++) { v = G->adjncy[i]; printf("%5d (color %2d)", v, Gbisect->color[v]); if ((++count % 4) == 0) printf("\n"); } if ((count % 4) != 0) printf("\n"); } } /***************************************************************************** ******************************************************************************/ void checkSeparator(gbisect_t *Gbisect) { PORD_INT *xadj, *adjncy, *vwght, *color, *cwght; PORD_INT nvtx, err, checkS, checkB, checkW, a, b, u, v, i, istart, istop; nvtx = Gbisect->G->nvtx; xadj = Gbisect->G->xadj; adjncy = Gbisect->G->adjncy; vwght = Gbisect->G->vwght; color = Gbisect->color; cwght = Gbisect->cwght; err = FALSE; printf("checking separator of induced subgraph (S %d, B %d, W %d)\n", cwght[GRAY], cwght[BLACK], cwght[WHITE]); checkS = checkB = checkW = 0; for (u = 0; u < nvtx; u++) { istart = xadj[u]; istop = xadj[u+1]; switch(color[u]) { case GRAY: /* is it a minimal separator? */ checkS += vwght[u]; a = b = FALSE; for (i = istart; i < istop; i++) { v = adjncy[i]; if (color[v] == WHITE) a = TRUE; if (color[v] == BLACK) b = TRUE; } if (!((a) && (b))) printf("WARNING: not a minimal separator (node %d)\n", u); break; case BLACK: /* is it realy a separator? */ checkB += vwght[u]; for (i = istart; i < istop; i++) { v = adjncy[i]; if (color[v] == WHITE) { printf("ERROR: white node %d adjacent to black node %d\n", u,v); err = TRUE; } } break; case WHITE: checkW += vwght[u]; break; default: printf("ERROR: node %d has unrecognized color %d\n", u, color[u]); err = TRUE; } } /* check cwght[GRAY], cwght[BLACK], cwght[WHITE] */ if ((checkS != cwght[GRAY]) || (checkB != cwght[BLACK]) || (checkW != cwght[WHITE])) { printf("ERROR in partitioning: checkS %d (S %d), checkB %d (B %d), " "checkW %d (W %d)\n", checkS, cwght[GRAY], checkB, cwght[BLACK], checkW, cwght[WHITE]); err = TRUE; } if (err) quit(); } /***************************************************************************** ******************************************************************************/ void constructSeparator(gbisect_t *Gbisect, options_t *options, timings_t *cpus) { domdec_t *dd, *dd2; PORD_INT *color, *cwght, *map, nvtx, u, i; nvtx = Gbisect->G->nvtx; color = Gbisect->color; cwght = Gbisect->cwght; /* -------------------------------------------------------------- map vector identifies vertices of Gbisect->G in domain decomp. -------------------------------------------------------------- */ mymalloc(map, nvtx, PORD_INT); /* -------------------------------------- construct initial domain decomposition -------------------------------------- */ pord_starttimer(cpus[TIME_INITDOMDEC]); dd = constructDomainDecomposition(Gbisect->G, map); #ifdef BE_CAUTIOUS checkDomainDecomposition(dd); #endif if (options[OPTION_MSGLVL] > 2) printf("\t 0. dom.dec.: #nodes %d (#domains %d, weight %d), #edges %d\n", dd->G->nvtx, dd->ndom, dd->domwght, dd->G->nedges >> 1); pord_stoptimer(cpus[TIME_INITDOMDEC]); /* --------------------------------------------------- construct sequence of coarser domain decompositions --------------------------------------------------- */ pord_starttimer(cpus[TIME_COARSEDOMDEC]); i = 0; while ((dd->ndom > MIN_DOMAINS) && (i < MAX_COARSENING_STEPS) && ((dd->G->nedges >> 1) > dd->G->nvtx)) { shrinkDomainDecomposition(dd, options[OPTION_NODE_SELECTION3]); dd = dd->next; i++; #ifdef BE_CAUTIOUS checkDomainDecomposition(dd); #endif if (options[OPTION_MSGLVL] > 2) printf("\t %2d. dom.dec.: #nodes %d (#domains %d, weight %d), #edges %d" "\n", i, dd->G->nvtx, dd->ndom, dd->domwght, dd->G->nedges >> 1); } pord_stoptimer(cpus[TIME_COARSEDOMDEC]); /* ----------------------------------------------- determine coloring of last domain decomposition ------------------------------------------------ */ pord_starttimer(cpus[TIME_INITSEP]); initialDDSep(dd); if (dd->cwght[GRAY] > 0) improveDDSep(dd); #ifdef BE_CAUTIOUS checkDDSep(dd); #endif if (options[OPTION_MSGLVL] > 2) printf("\t %2d. dom.dec. sep.: S %d, B %d, W %d [cost %7.2f]\n", i, dd->cwght[GRAY], dd->cwght[BLACK], dd->cwght[WHITE], F(dd->cwght[GRAY], dd->cwght[BLACK], dd->cwght[WHITE])); pord_stoptimer(cpus[TIME_INITSEP]); /* -------------- refine coloring --------------- */ pord_starttimer(cpus[TIME_REFINESEP]); while (dd->prev != NULL) { dd2 = dd->prev; dd2->cwght[GRAY] = dd->cwght[GRAY]; dd2->cwght[BLACK] = dd->cwght[BLACK]; dd2->cwght[WHITE] = dd->cwght[WHITE]; for (u = 0; u < dd2->G->nvtx; u++) dd2->color[u] = dd->color[dd2->map[u]]; freeDomainDecomposition(dd); if (dd2->cwght[GRAY] > 0) improveDDSep(dd2); #ifdef BE_CAUTIOUS checkDDSep(dd2); #endif dd = dd2; i--; if (options[OPTION_MSGLVL] > 2) printf("\t %2d. dom.dec. sep.: S %d, B %d, W %d [cost %7.2f]\n", i, dd->cwght[GRAY], dd->cwght[BLACK], dd->cwght[WHITE], F(dd->cwght[GRAY], dd->cwght[BLACK], dd->cwght[WHITE])); } pord_stoptimer(cpus[TIME_REFINESEP]); /* --------------------------------- copy coloring to subgraph Gbisect --------------------------------- */ cwght[GRAY] = dd->cwght[GRAY]; cwght[BLACK] = dd->cwght[BLACK]; cwght[WHITE] = dd->cwght[WHITE]; for (u = 0; u < nvtx; u++) color[u] = dd->color[map[u]]; freeDomainDecomposition(dd); free(map); } /***************************************************************************** ******************************************************************************/ PORD_INT smoothBy2Layers(gbisect_t *Gbisect, PORD_INT *bipartvertex, PORD_INT *pnX, PORD_INT black, PORD_INT white) { gbipart_t *Gbipart; PORD_INT *xadj, *adjncy, *color, *cwght, *map; PORD_INT *flow, *rc, *matching, *dmflag, dmwght[6]; PORD_INT nvtx, smoothed, nX, nX2, nY, x, y, u, i, j, jstart, jstop; nvtx = Gbisect->G->nvtx; xadj = Gbisect->G->xadj; adjncy = Gbisect->G->adjncy; color = Gbisect->color; cwght = Gbisect->cwght; nX = *pnX; /* ---------------------------------------------------- map vector identifies vertices of Gbisect in Gbipart ---------------------------------------------------- */ mymalloc(map, nvtx, PORD_INT); /* ---------------------------------- construct set Y of bipartite graph ---------------------------------- */ nY = 0; for (i = 0; i < nX; i++) { x = bipartvertex[i]; jstart = xadj[x]; jstop = xadj[x+1]; for (j = jstart; j < jstop; j++) { y = adjncy[j]; if (color[y] == black) { bipartvertex[nX+nY++] = y; color[y] = GRAY; } } } for (i = nX; i < nX+nY; i++) { y = bipartvertex[i]; color[y] = black; } /* -------------------------------------------- compute the Dulmage-Mendelsohn decomposition -------------------------------------------- */ Gbipart = setupBipartiteGraph(Gbisect->G, bipartvertex, nX, nY, map); mymalloc(dmflag, (nX+nY), PORD_INT); switch(Gbipart->G->type) { case UNWEIGHTED: mymalloc(matching, (nX+nY), PORD_INT); maximumMatching(Gbipart, matching); DMviaMatching(Gbipart, matching, dmflag, dmwght); free(matching); break; case WEIGHTED: mymalloc(flow, Gbipart->G->nedges, PORD_INT); mymalloc(rc, (nX+nY), PORD_INT); maximumFlow(Gbipart, flow, rc); DMviaFlow(Gbipart, flow, rc, dmflag, dmwght); free(flow); free(rc); break; default: fprintf(stderr, "\nError in function smoothSeparator\n" " unrecognized bipartite graph type %d\n", Gbipart->G->type); quit(); } #ifdef DEBUG printf("Dulmage-Mendelsohn decomp. computed\n" "SI %d, SX %d, SR %d, BI %d, BX %d, BR %d\n", dmwght[SI], dmwght[SX], dmwght[SR], dmwght[BI], dmwght[BX], dmwght[BR]); #endif /* ----------------------------------------------------------------------- 1st TEST: try to exchange SI with BX, i.e. nodes in SI are moved from the separator into white (white grows), and nodes in BX are moved from black into the separator (black shrinks) ----------------------------------------------------------------------- */ smoothed = FALSE; if (F(cwght[GRAY]-dmwght[SI]+dmwght[BX], cwght[black]-dmwght[BX], cwght[white]+dmwght[SI]) + EPS < F(cwght[GRAY], cwght[black], cwght[white])) { smoothed = TRUE; #ifdef DEBUG printf("exchange SI with BX\n"); #endif cwght[white] += dmwght[SI]; cwght[GRAY] -= dmwght[SI]; cwght[black] -= dmwght[BX]; cwght[GRAY] += dmwght[BX]; for (i = 0; i < nX+nY; i++) { u = bipartvertex[i]; if (dmflag[map[u]] == SI) color[u] = white; if (dmflag[map[u]] == BX) color[u] = GRAY; } } /* ----------------------------------------------------------------------- 2nd TEST: try to exchange SR with BR, i.e. nodes in SR are moved from the separator into white (white grows), and nodes in BR are moved from black into the separator (black shrinks) NOTE: SR is allowed to be exchanged with BR only if SI = BX = 0 or if SI has been exchanged with BX (Adj(SR) is a subset of BX u BR) ----------------------------------------------------------------------- */ if ((F(cwght[GRAY]-dmwght[SR]+dmwght[BR], cwght[black]-dmwght[BR], cwght[white]+dmwght[SR]) + EPS < F(cwght[GRAY], cwght[black], cwght[white])) && ((smoothed) || (dmwght[SI] == 0))) { smoothed = TRUE; #ifdef DEBUG printf("exchange SR with BR\n"); #endif cwght[white] += dmwght[SR]; cwght[GRAY] -= dmwght[SR]; cwght[black] -= dmwght[BR]; cwght[GRAY] += dmwght[BR]; for (i = 0; i < nX+nY; i++) { u = bipartvertex[i]; if (dmflag[map[u]] == SR) color[u] = white; if (dmflag[map[u]] == BR) color[u] = GRAY; } } /* ----------------------------------------------------- fill bipartvertex with the nodes of the new separator ----------------------------------------------------- */ nX2 = 0; for (i = 0; i < nX+nY; i++) { u = bipartvertex[i]; if (color[u] == GRAY) bipartvertex[nX2++] = u; } *pnX = nX2; /* ------------------------------- free working storage and return ------------------------------- */ free(map); free(dmflag); freeBipartiteGraph(Gbipart); return(smoothed); } /***************************************************************************** ******************************************************************************/ void smoothSeparator(gbisect_t *Gbisect, options_t *options) { PORD_INT *xadj, *adjncy, *vwght, *color, *cwght, *bipartvertex; PORD_INT nvtx, nX, nX2, u, x, y, a, b, i, j, jstart, jstop; nvtx = Gbisect->G->nvtx; xadj = Gbisect->G->xadj; adjncy = Gbisect->G->adjncy; vwght = Gbisect->G->vwght; color = Gbisect->color; cwght = Gbisect->cwght; mymalloc(bipartvertex, nvtx, PORD_INT); /* ---------------------------------------------------------- extract the separator (store its vertices in bipartvertex) ---------------------------------------------------------- */ nX = 0; for (u = 0; u < nvtx; u++) if (color[u] == GRAY) bipartvertex[nX++] = u; do { /* --------------------------------------------------------------- minimize the separator (i.e. minimize set X of bipartite graph) --------------------------------------------------------------- */ cwght[GRAY] = nX2 = 0; for (i = 0; i < nX; i++) { x = bipartvertex[i]; a = b = FALSE; jstart = xadj[x]; jstop = xadj[x+1]; for (j = jstart; j < jstop; j++) { y = adjncy[j]; if (color[y] == WHITE) a = TRUE; if (color[y] == BLACK) b = TRUE; } if ((a) && (!b)) { color[x] = WHITE; cwght[WHITE] += vwght[x]; } else if ((!a) && (b)) { color[x] = BLACK; cwght[BLACK] += vwght[x]; } else { bipartvertex[nX2++] = x; cwght[GRAY] += vwght[x]; } } nX = nX2; #ifdef BE_CAUTIOUS checkSeparator(Gbisect); #endif /* ------------------------------------------------------------------ smooth the unweighted/weighted separator first pair it with the larger set; if unsuccessful try the smaller ------------------------------------------------------------------ */ if (cwght[BLACK] >= cwght[WHITE]) { a = smoothBy2Layers(Gbisect, bipartvertex, &nX, BLACK, WHITE); if (!a) a = smoothBy2Layers(Gbisect, bipartvertex, &nX, WHITE, BLACK); } else { a = smoothBy2Layers(Gbisect, bipartvertex, &nX, WHITE, BLACK); if (!a) a = smoothBy2Layers(Gbisect, bipartvertex, &nX, BLACK, WHITE); } if ((options[OPTION_MSGLVL] > 2) && (a)) printf("\t separator smoothed: S %d, B %d, W %d [cost %7.2f]\n", cwght[GRAY], cwght[BLACK], cwght[WHITE], F(cwght[GRAY], cwght[BLACK], cwght[WHITE])); } while (a); free(bipartvertex); } MUMPS_5.8.1/PORD/lib/tree.c0000664000175000017500000007632515042446416015076 0ustar amestoyamestoy/***************************************************************************** / / SPACE SPArse Cholesky Elimination) Library: tree.c / / author J"urgen Schulze, University of Paderborn / created 09/15/99 / / This file contains functions dealing with elimination/front tree object / ****************************************************************************** Data type: struct elimtree int nvtx; number of vertices in the tree int nfronts; number of fronts in the tree int root; root of the tree int *ncolfactor; number of factor columns in front int *ncolupdate; number of update columns for front int *parent; parent in front tree int *firstchild; first child in front tree int *silbings; silbings in front tree int *vtx2front; maps vertices to fronts Comments: o Structure used to hold the elimination/front tree; the tree is used to guide the symbolical and numerical factorization; a "node" in the tree can be a single vertex (in the context of an elimination tree) or a group of vertices (as for a front tree) o NOTE: Also the ordering can be expressed in terms of front trees; the permutation vector perm is then obtained by a post order traversal of the tree (see method permFromElimTree below) Methods in lib/tree.c: - T = newElimTree(int nvtx, int nfronts); o Initial: root = -1 - void freeElimTree(elimtree_t *T); - void printElimTree(elimtree_t *T); - int firstPostorder(elimtree_t *T); o returns the first front in a post order traversal of T - int firstPostorder2(elimtree_t *T, int root); o returns the first front in a post order traversal of T[root] - int nextPostorder(elimtree_t *T, int J); o returns the front that follows J in a post order traversal of T - int firstPreorder(elimtree_t *T); o returns the first front in a pre order traversal of T - int nextPreorder(elimtree_t *T, int J); o returns the front that follows J in a pre order traversal of T - T = setupElimTree(graph_t *G, int *perm, int *invp); o constructs an elimination tree for G with permutation vectors perm, invp; a union-find algorithm is used to set up the parent vector of T; T->root and vectors T->firstchild, T->silbings are initialized by calling initFchSilbRoot; vector T->ncolupdate is filled by calling function setupCSSFromGraph (see below) - void initFchSilbRoot(elimtree_t *T); o uses vector T->parent to initialize T->firstchild, T->silbings, T->root - void permFromElimTree(elimtree_t *T, int *perm); o fills vectors perm, invp according to a post order traversal of T - T2 = expandElimTree(elimtree_t *T, int *vtxmap, int nvtxorg) o creates and returns an elimtree object for the uncompressed graph; the map from original vertices to compressed vertices is found in vector vtxmap; the number of original vertices (i.e. the length of vector vtxmap) is nvtxorg o NOTE: the function only expands vector T->vtx2front and sets T2->nvtx to nvtxorg; all other vectors are copied from T to T2, i.e. the number of fronts and the tree structure are the same in T and T2 - PTP = permuteElimTree(elimtree_t *T, int *perm); o in T: vtx2front[u] points to front containing vertex u in PTP: vtx2front[k] points to front containing column k = perm[u] o NOTE: the function only permutes vector T->vtx2front; all other vectors are copied from T to PTP, i.e. the number of fronts and the tree structure are the same in T and PTP - T2 = fundamentalFronts(elimtree_t *T); o compresses chains of fronts to a single front; once a map from original fronts to compressed fronts is known, the compressed elimtree object T2 can be created by calling compressElimTree (see below) - T2 = mergeFronts(elimtree_t *T, int maxzeros); o merges small subtrees together in one front; it returns an elimtree object T2 where a front has either been merged with none or all of its children; the maximal number of zero entries that is allowed to be introduced when merging the fronts together is given by maxzeros - T2 = compressElimTree(elimtree_t *T, int *frontmap, int cnfronts); o creates a new front tree using frontmap; vector frontmap maps the original fronts of T to a smaller set of fronts; cnfronts is number of new fronts (i.e. the maximal entry in frontmap) - int justifyFronts(elimtree_t *T); o orders the children of a front so that the working storage in the multifrontal algorithm is minimized; the function returns the amount of extra working storage for the justified tree - int nWorkspace(elimtree_t *T); o returns the size of the working storage in the multifrontal algorithm (measured in terms of FLOATS, for BYTES multiply with sizeof(FLOAT)) - int nFactorIndices(elimtree_t *T); o returns the number of indices taken by the factor matrix represented by T - int nFactorEntries(elimtree_t *T); o returns the number of entries taken by the factor matrix represented by T - FLOAT nFactorOps(elimtree_t *T); o returns the number of operations required to compute the factor matrix represented by T - void subtreeFactorOps(elimtree *T, FLOAT *ops) o returns in ops[K] the number of operations required to factor the fronts in tree T(K) (this includes front K) - FLOAT nTriangularOps(elimtree_t *T); o returns the number of operations required to solve the triangular systems ******************************************************************************/ #include /***************************************************************************** ******************************************************************************/ elimtree_t* newElimTree(PORD_INT nvtx, PORD_INT nfronts) { elimtree_t *T; mymalloc(T, 1, elimtree_t); mymalloc(T->ncolfactor, nfronts, PORD_INT); mymalloc(T->ncolupdate, nfronts, PORD_INT); mymalloc(T->parent, nfronts, PORD_INT); mymalloc(T->firstchild, nfronts, PORD_INT); mymalloc(T->silbings, nfronts, PORD_INT); mymalloc(T->vtx2front, nvtx, PORD_INT); T->nvtx = nvtx; T->nfronts = nfronts; T->root = -1; return(T); } /***************************************************************************** ******************************************************************************/ void freeElimTree(elimtree_t *T) { free(T->ncolfactor); free(T->ncolupdate); free(T->parent); free(T->firstchild); free(T->silbings); free(T->vtx2front); free(T); } /***************************************************************************** ******************************************************************************/ void printElimTree(elimtree_t *T) { PORD_INT *ncolfactor, *ncolupdate, *parent, *firstchild, *silbings, *vtx2front; PORD_INT *first, *link, nvtx, nfronts, root, J, K, u, count, child; nvtx = T->nvtx; nfronts = T->nfronts; root = T->root; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; parent = T->parent; firstchild = T->firstchild; silbings = T->silbings; vtx2front = T->vtx2front; printf("#fronts %d, root %d\n", nfronts, root); /* ----------------------------------------------------------- store the vertices/columns of a front in a bucket structure ----------------------------------------------------------- */ mymalloc(first, nfronts, PORD_INT); mymalloc(link, nvtx, PORD_INT); for (J = 0; J < nfronts; J++) first[J] = -1; for (u = nvtx-1; u >= 0; u--) { J = vtx2front[u]; link[u] = first[J]; first[J] = u; } /* ----------------------------------------------------------- print fronts according to a postorder traversal of the tree ----------------------------------------------------------- */ for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { printf("--- front %d, ncolfactor %d, ncolupdate %d, parent %d\n", K, ncolfactor[K], ncolupdate[K], parent[K]); count = 0; printf("children:\n"); for (child = firstchild[K]; child != -1; child = silbings[child]) { printf("%5d", child); if ((++count % 16) == 0) printf("\n"); } if ((count % 16) != 0) printf("\n"); count = 0; printf("vertices mapped to front:\n"); for (u = first[K]; u != -1; u = link[u]) { printf("%5d", u); if ((++count % 16) == 0) printf("\n"); } if ((count % 16) != 0) printf("\n"); } /* ---------------------- free memory and return ---------------------- */ free(first); free(link); } /***************************************************************************** ******************************************************************************/ PORD_INT firstPostorder(elimtree_t *T) { PORD_INT *firstchild, J; firstchild = T->firstchild; if ((J = T->root) != -1) while (firstchild[J] != -1) J = firstchild[J]; return(J); } /***************************************************************************** ******************************************************************************/ PORD_INT firstPostorder2(elimtree_t *T, PORD_INT root) { PORD_INT *firstchild, J; firstchild = T->firstchild; if ((J = root) != -1) while (firstchild[J] != -1) J = firstchild[J]; return(J); } /***************************************************************************** ******************************************************************************/ PORD_INT nextPostorder(elimtree_t *T, PORD_INT J) { PORD_INT *parent, *firstchild, *silbings; parent = T->parent; firstchild = T->firstchild; silbings = T->silbings; if (silbings[J] != -1) { J = silbings[J]; while (firstchild[J] != -1) J = firstchild[J]; } else J = parent[J]; return(J); } /***************************************************************************** ******************************************************************************/ PORD_INT firstPreorder(elimtree_t *T) { return(T->root); } /***************************************************************************** ******************************************************************************/ PORD_INT nextPreorder(elimtree_t *T, PORD_INT J) { PORD_INT *parent, *firstchild, *silbings; parent = T->parent; firstchild = T->firstchild; silbings = T->silbings; if (firstchild[J] != -1) J = firstchild[J]; else { while ((silbings[J] == -1) && (parent[J] != -1)) J = parent[J]; J = silbings[J]; } return(J); } /***************************************************************************** ******************************************************************************/ elimtree_t* setupElimTree(graph_t *G, PORD_INT *perm, PORD_INT *invp) { elimtree_t *T; css_t *css; PORD_INT *xadj, *adjncy, *vwght, *ncolfactor, *ncolupdate, *parent; PORD_INT *vtx2front, *realroot, *uf_father, *uf_size; PORD_INT *xnzl, *nzlsub, *xnzlsub; PORD_INT nvtx, front, front2, froot, f, r, u, v, i, istart, istop; PORD_INT prevlen, len, h, hsub; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; vwght = G->vwght; /* -------------------------- set up the working storage -------------------------- */ mymalloc(realroot, nvtx, PORD_INT); mymalloc(uf_father, nvtx, PORD_INT); mymalloc(uf_size, nvtx, PORD_INT); /* ------------------------------------------------ allocate storage for the elimination tree object ------------------------------------------------ */ T = newElimTree(nvtx, nvtx); ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; parent = T->parent; vtx2front = T->vtx2front; /* ----------------------------- set up the parent vector of T ----------------------------- */ for (front = 0; front < nvtx; front++) { parent[front] = -1; u = invp[front]; /* only vertex u belongs to this front */ uf_father[front] = front; /* front forms a set in union-find structure */ uf_size[front] = 1; /* the set consists of a single front */ realroot[front] = front; froot = front; /* run through the adjacency list of u */ istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; front2 = perm[v]; if (front2 < front) { r = front2; while (uf_father[r] != r) /* find root of front2 in union-find */ r = uf_father[r]; while (front2 != r) /* path compression */ { f = front2; front2 = uf_father[front2]; uf_father[f] = r; } f = realroot[r]; /* merge union-find sets */ if ((parent[f] == -1) && (f != front)) { parent[f] = front; if (uf_size[froot] < uf_size[r]) { uf_father[froot] = r; uf_size[r] += uf_size[froot]; froot = r; } else { uf_father[r] = froot; uf_size[froot] += uf_size[r]; } realroot[froot] = front; } } } } /* --------------------------------------------- set the vectors T->firstchild and T->silbings --------------------------------------------- */ initFchSilbRoot(T); /* ---------------------------------------------------------- set the vectors T->vtx2front, T->ncolfactor, T->ncolupdate ---------------------------------------------------------- */ css = setupCSSFromGraph(G, perm, invp); xnzl = css->xnzl; nzlsub = css->nzlsub; xnzlsub = css->xnzlsub; prevlen = 0; for (front = 0; front < nvtx; front++) { u = invp[front]; ncolfactor[front] = vwght[u]; ncolupdate[front] = 0; vtx2front[u] = front; len = xnzl[front+1] - xnzl[front]; if (prevlen - 1 == len) ncolupdate[front] = ncolupdate[front-1] - vwght[u]; else { h = xnzlsub[front] + 1; for (i = 1; i < len; i++) { hsub = nzlsub[h++]; v = invp[hsub]; ncolupdate[front] += vwght[v]; } } prevlen = len; } /* ---------------------- free memory and return ---------------------- */ free(css); free(realroot); free(uf_father); free(uf_size); return(T); } /***************************************************************************** ******************************************************************************/ void initFchSilbRoot(elimtree_t *T) { PORD_INT *parent, *firstchild, *silbings, nfronts, J, pJ; nfronts = T->nfronts; parent = T->parent; firstchild = T->firstchild; silbings = T->silbings; for (J = 0; J < nfronts; J++) silbings[J] = firstchild[J] = -1; for (J = nfronts-1; J >= 0; J--) if ((pJ = parent[J]) != -1) { silbings[J] = firstchild[pJ]; firstchild[pJ] = J; } else { silbings[J] = T->root; T->root = J; } } /***************************************************************************** ******************************************************************************/ void permFromElimTree(elimtree_t *T, PORD_INT *perm) { PORD_INT *vtx2front, *first, *link; PORD_INT nvtx, nfronts, K, u, count; nvtx = T->nvtx; nfronts = T->nfronts; vtx2front = T->vtx2front; /* ----------------------------------------------------------- store the vertices/columns of a front in a bucket structure ----------------------------------------------------------- */ mymalloc(first, nfronts, PORD_INT); mymalloc(link, nvtx, PORD_INT); for (K = 0; K < nfronts; K++) first[K] = -1; for (u = nvtx-1; u >= 0; u--) { K = vtx2front[u]; link[u] = first[K]; first[K] = u; } /* ----------------------------------------------------- postorder traversal of the elimination tree to obtain the permutation vectors perm, invp ----------------------------------------------------- */ count = 0; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) for (u = first[K]; u != -1; u = link[u]) { perm[u] = count; count++; } /* ---------------------- free memory and return ---------------------- */ free(first); free(link); } /***************************************************************************** ******************************************************************************/ elimtree_t* permuteElimTree(elimtree_t *T, PORD_INT *perm) { elimtree_t *PTP; PORD_INT nvtx, nfronts, J, u; nvtx = T->nvtx; nfronts = T->nfronts; /* -------------------------------------------------------------- allocate space for the new elimtree object and copy front data the permuted tree has the same number of fronts/tree structure -------------------------------------------------------------- */ PTP = newElimTree(nvtx, nfronts); PTP->root = T->root; for (J = 0; J < nfronts; J++) { PTP->ncolfactor[J] = T->ncolfactor[J]; PTP->ncolupdate[J] = T->ncolupdate[J]; PTP->parent[J] = T->parent[J]; PTP->firstchild[J] = T->firstchild[J]; PTP->silbings[J] = T->silbings[J]; } /* --------------------------------------------------------------------- set up the new vtx2front vector; the trees only differ in this vector --------------------------------------------------------------------- */ for (u = 0; u < nvtx; u++) PTP->vtx2front[perm[u]] = T->vtx2front[u]; return(PTP); } /***************************************************************************** ******************************************************************************/ elimtree_t* expandElimTree(elimtree_t *T, PORD_INT *vtxmap, PORD_INT nvtxorg) { elimtree_t *T2; PORD_INT *vtx2front, *vtx2front2; PORD_INT nfronts, J, u; nfronts = T->nfronts; /* -------------------------------------------------------------- allocate space for the new elimtree object and copy front data the expanded tree has the same number of fronts/tree structure -------------------------------------------------------------- */ T2 = newElimTree(nvtxorg, nfronts); T2->root = T->root; for (J = 0; J < nfronts; J++) { T2->ncolfactor[J] = T->ncolfactor[J]; T2->ncolupdate[J] = T->ncolupdate[J]; T2->parent[J] = T->parent[J]; T2->firstchild[J] = T->firstchild[J]; T2->silbings[J] = T->silbings[J]; } /* --------------------------------------------------------------------- set up the new vtx2front vector; the trees only differ in this vector --------------------------------------------------------------------- */ vtx2front = T->vtx2front; vtx2front2 = T2->vtx2front; for (u = 0; u < nvtxorg; u++) vtx2front2[u] = vtx2front[vtxmap[u]]; return(T2); } /***************************************************************************** ******************************************************************************/ elimtree_t* fundamentalFronts(elimtree_t *T) { elimtree_t *T2; PORD_INT *ncolfactor, *ncolupdate, *parent, *firstchild, *silbings; PORD_INT *frontmap, nfronts, cnfronts, J, child; nfronts = T->nfronts; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; parent = T->parent; firstchild = T->firstchild; silbings = T->silbings; /* ------------------------- set up the working arrays ------------------------- */ mymalloc(frontmap, nfronts, PORD_INT); /* ----------------------------- search the fundamental fronts ----------------------------- */ cnfronts = 0; J = T->root; while (J != -1) { while (firstchild[J] != -1) J = firstchild[J]; frontmap[J] = cnfronts++; while ((silbings[J] == -1) && (parent[J] != -1)) { J = parent[J]; child = firstchild[J]; if ((silbings[child] != -1) || (ncolupdate[child] != ncolfactor[J] + ncolupdate[J])) frontmap[J] = cnfronts++; else frontmap[J] = frontmap[child]; } J = silbings[J]; } /* ------------------------------ construct new elimination tree ------------------------------ */ T2 = compressElimTree(T, frontmap, cnfronts); /* ---------------------- free memory and return ---------------------- */ free(frontmap); return(T2); } /***************************************************************************** ******************************************************************************/ elimtree_t* mergeFronts(elimtree_t *T, PORD_INT maxzeros) { elimtree_t *T2; PORD_INT *ncolfactor, *ncolupdate, *firstchild, *silbings; PORD_INT *frontmap, *newncolfactor, *nzeros, *rep; PORD_INT nfronts, cnfronts, K, ncolfrontK, J, Jall, cost; nfronts = T->nfronts; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; firstchild = T->firstchild; silbings = T->silbings; /* ------------------------- set up the working arrays ------------------------- */ mymalloc(frontmap, nfronts, PORD_INT); mymalloc(newncolfactor, nfronts, PORD_INT); mymalloc(nzeros, nfronts, PORD_INT); mymalloc(rep, nfronts, PORD_INT); for (K = 0; K < nfronts; K++) { newncolfactor[K] = ncolfactor[K]; nzeros[K] = 0; rep[K] = K; } /* ----------------------------------------------------- perform a postorder traversal of the elimination tree ----------------------------------------------------- */ for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) if (firstchild[K] != -1) { ncolfrontK = newncolfactor[K] + ncolupdate[K]; Jall = 0; cost = 0; for (J = firstchild[K]; J != -1; J = silbings[J]) { Jall += newncolfactor[J]; cost -= newncolfactor[J] * newncolfactor[J]; cost += 2*newncolfactor[J] * (ncolfrontK - ncolupdate[J]); cost += 2*nzeros[J]; } cost += Jall * Jall; cost = cost / 2; if (cost < maxzeros) { for (J = firstchild[K]; J != -1; J = silbings[J]) { rep[J] = K; newncolfactor[K] += newncolfactor[J]; } nzeros[K] = cost; } } /* ---------------------------------- construct frontmap from vector rep ---------------------------------- */ cnfronts = 0; for (K = 0; K < nfronts; K++) if (rep[K] == K) frontmap[K] = cnfronts++; else { for (J = K; rep[J] != J; J = rep[J]); rep[K] = J; } for (K = 0; K < nfronts; K++) if ((J = rep[K]) != K) frontmap[K] = frontmap[J]; /* ------------------------------ construct new elimination tree ------------------------------ */ T2 = compressElimTree(T, frontmap, cnfronts); /* ---------------------- free memory and return ---------------------- */ free(frontmap); free(newncolfactor); free(nzeros); free(rep); return(T2); } /***************************************************************************** ******************************************************************************/ elimtree_t* compressElimTree(elimtree_t *T, PORD_INT *frontmap, PORD_INT cnfronts) { elimtree_t *T2; PORD_INT *ncolfactor, *ncolupdate, *parent, *vtx2front; PORD_INT nvtx, nfronts, u, K, pK, newfront, pnewfront; nvtx = T->nvtx; nfronts = T->nfronts; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; parent = T->parent; vtx2front = T->vtx2front; /* -------------------------------------------- allocate memory for the new elimtree T2 and init. ncolfactor, ncolupdate, and parent -------------------------------------------- */ T2 = newElimTree(nvtx, cnfronts); for (K = 0; K < cnfronts; K++) { T2->ncolfactor[K] = T2->ncolupdate[K] = 0; T2->parent[K] = -1; } /* -------------------------------------------------------------- set the new vectors T2->ncolfactor, T2->ncolupdate, T2->parent -------------------------------------------------------------- */ for (K = 0; K < nfronts; K++) { newfront = frontmap[K]; T2->ncolfactor[newfront] += ncolfactor[K]; if (((pK = parent[K]) != -1) && ((pnewfront = frontmap[pK]) != newfront)) { T2->parent[newfront] = pnewfront; T2->ncolupdate[newfront] = ncolupdate[K]; } } /* --------------------------------------------------- set the new vectors T2->firstchild and T2->silbings --------------------------------------------------- */ initFchSilbRoot(T2); /* ------------------------------------ set the the new vector T2->vtx2front ------------------------------------ */ for (u = 0; u < nvtx; u++) T2->vtx2front[u] = frontmap[vtx2front[u]]; return(T2); } /***************************************************************************** ******************************************************************************/ PORD_INT justifyFronts(elimtree_t *T) { PORD_INT *ncolfactor, *ncolupdate, *firstchild, *silbings, *minWspace, *list; PORD_INT nfronts, K, ncolfrontK, frontsizeK, wspace, child, nxtchild; PORD_INT count, m, s, i; nfronts = T->nfronts; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; firstchild = T->firstchild; silbings = T->silbings; /* ------------------------- set up the working arrays ------------------------- */ mymalloc(minWspace, nfronts, PORD_INT); mymalloc(list, nfronts, PORD_INT); /* --------------------------------------------------------- postorder traversal of the elimination tree to obtain the optimal justification of the children of each front ---------------------------------------------------------- */ wspace = 0; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { ncolfrontK = ncolfactor[K] + ncolupdate[K]; frontsizeK = (ncolfrontK * (ncolfrontK + 1)) >> 1; if ((child = firstchild[K]) == -1) minWspace[K] = frontsizeK; else { count = 0; /* sort children according to their minWspace value */ while (child != -1) { list[count++] = child; child = silbings[child]; } insertUpIntsWithStaticIntKeys(count, list, minWspace); firstchild[K] = -1; for (i = 0; i < count; i++) { child = list[i]; silbings[child] = firstchild[K]; firstchild[K] = child; } /* compute minWspace[K] */ child = firstchild[K]; nxtchild = silbings[child]; m = s = minWspace[child]; while (nxtchild != -1) { s = s - minWspace[child] + ((ncolupdate[child] * (ncolupdate[child] + 1)) >> 1) + minWspace[nxtchild]; m = max(m, s); child = nxtchild; nxtchild = silbings[nxtchild]; } s = s - minWspace[child] + ((ncolupdate[child] * (ncolupdate[child] + 1)) >> 1) + frontsizeK; minWspace[K] = max(m, s); } wspace = max(wspace, minWspace[K]); } /* ---------------------- free memory and return ---------------------- */ free(minWspace); free(list); return(wspace); } /***************************************************************************** ******************************************************************************/ PORD_INT nWorkspace(elimtree_t *T) { PORD_INT *ncolfactor, *ncolupdate, *firstchild, *silbings, *minWspace; PORD_INT nfronts, K, ncolfrontK, frontsizeK, wspace, child, nxtchild, m, s; nfronts = T->nfronts; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; firstchild = T->firstchild; silbings = T->silbings; /* ------------------------- set up the working arrays ------------------------- */ mymalloc(minWspace, nfronts, PORD_INT); /* ------------------------------------------- postorder traversal of the elimination tree ------------------------------------------- */ wspace = 0; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { ncolfrontK = ncolfactor[K] + ncolupdate[K]; frontsizeK = (ncolfrontK * (ncolfrontK + 1)) >> 1; if ((child = firstchild[K]) == -1) minWspace[K] = frontsizeK; else { child = firstchild[K]; nxtchild = silbings[child]; m = s = minWspace[child]; while (nxtchild != -1) { s = s - minWspace[child] + ((ncolupdate[child] * (ncolupdate[child] + 1)) >> 1) + minWspace[nxtchild]; m = max(m, s); child = nxtchild; nxtchild = silbings[nxtchild]; } s = s - minWspace[child] + ((ncolupdate[child] * (ncolupdate[child] + 1)) >> 1) + frontsizeK; minWspace[K] = max(m, s); } wspace = max(wspace, minWspace[K]); } /* ---------------------- free memory and return ---------------------- */ free(minWspace); return(wspace); } /***************************************************************************** ******************************************************************************/ PORD_INT nFactorIndices(elimtree_t *T) { PORD_INT *ncolfactor, *ncolupdate; PORD_INT nfronts, ind, K; nfronts = T->nfronts; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; ind = 0; for (K = 0; K < nfronts; K++) ind += (ncolfactor[K] + ncolupdate[K]); return(ind); } /***************************************************************************** ******************************************************************************/ PORD_INT nFactorEntries(elimtree_t *T) { PORD_INT *ncolfactor, *ncolupdate; PORD_INT ent, tri, rec, K; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; ent = 0; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { tri = ncolfactor[K]; rec = ncolupdate[K]; ent += (tri * (tri+1)) / 2; ent += (tri * rec); } return(ent); } /***************************************************************************** ******************************************************************************/ FLOAT nFactorOps(elimtree_t *T) { PORD_INT *ncolfactor, *ncolupdate; FLOAT ops, tri, rec; PORD_INT K; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; ops = 0.0; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { tri = ncolfactor[K]; rec = ncolupdate[K]; ops += (tri*tri*tri) / 3.0 + (tri*tri) / 2.0 - (5*tri) / 6.0; ops += (tri*tri*rec) + (rec*(rec+1)*tri); } return(ops); } /***************************************************************************** ******************************************************************************/ void subtreeFactorOps(elimtree_t *T, FLOAT *ops) { PORD_INT *ncolfactor, *ncolupdate; FLOAT tri, rec; PORD_INT J, K; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { tri = ncolfactor[K]; rec = ncolupdate[K]; ops[K] = (tri*tri*tri) / 3.0 + (tri*tri) / 2.0 - (5*tri) / 6.0; ops[K] += (tri*tri*rec) + (rec*(rec+1)*tri); for (J = T->firstchild[K]; J != -1; J = T->silbings[J]) ops[K] += ops[J]; } } /***************************************************************************** ******************************************************************************/ FLOAT nTriangularOps(elimtree_t *T) { PORD_INT *ncolfactor, *ncolupdate; FLOAT ops, tri, rec; PORD_INT K; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; ops = 0.0; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { tri = ncolfactor[K]; rec = ncolupdate[K]; ops += (tri*tri) + 2.0*tri*rec; /* forward ops */ ops += (tri*tri) + 2.0*tri*rec; /* backward ops */ } return(ops); } MUMPS_5.8.1/PORD/lib/ddcreate.c0000664000175000017500000007447115042446416015712 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: ddcreate.c / / author J"urgen Schulze, University of Paderborn / created 00nov28 / / This file contains functions dealing with construction/coarsening / of a domain decomposition / ****************************************************************************** Data type: struct domdec graph_t *G; pointer to graph object int ndom; number of domains int domwght; total weight of domains int *vtype; type of node (see comment below) int *color; color of node (GRAY, BLACK, or WHITE) int cwght[3]; weights of GRAY, BLACK, WHITE partitions int *map; maps nodes to next coarser domain decomp. struct domdec *prev; pointer to previous finer domain decomp. struct domdec *next; pointer to next coarser domain decomp. Comments: o Structure holds the domain decompositions constructed by the coarsening process; it also holds the colorings of the domain decomp. computed by the refinement process o vtype[v]: represents the status of a node in the domain decomposition 0, iff status of v is unknown 1, iff v is a domain vertex 2, iff v is a multisector vertex 3, iff multisec v is eliminated and now forms a domain 4, iff multisec v is absorbed by another multisec/domain Methods in lib/ddcreate.c: - dd = newDomainDecomposition(int nvtx, int nedges); o Initial: ndom = domwght = 0, cwght[GRAY] = cwght[BLACK] = cwght[WHITE] = 0, and prev = next = NULL - void freeDomainDecomposition(domdec_t *dd); - void printDomainDecomposition(domdec_t *dd); - void checkDomainDecomposition(domdec_t *dd); - void buildInitialDomains(graph_t *G, int *vtxlist, int *vtype, int *rep); o determines initial domains according to the order of nodes in vtxlist; furthermore, it sets rep[u] = v for all multisecs u that are adjacent to only one domain v o on start vtype[u] = 0 for all 0 <= u < nvtx, on return vtype[u] = 1, iff u belongs to a domain (rep[u]=u => u is seed of domain) vtype[u] = 2, iff u belongs to a multisec (rep[u]=u => u is seed) - void mergeMultisecs(graph_t *G, int *vtype, int *rep); o merges all adjacent multisecs that do not share a common domain o on return vtype[w] = 4, iff multisec w belongs to multisec cluster u = rep[w] - dd = initialDomainDecomposition(graph_t *G, int *map, int *vtype, int *rep); o allocates memory for the initial domain decomposition of G by calling newDomainDecomposition and creates the domain decomposition according to the vectors vtype and rep; the map vector maps vertices of G onto vertices of dd - dd = constructDomainDecomposition(graph_t *G, int *map); o constructs an initial domain decomposition for the graph G by calling the functions (a) buildInitialDomains (b) mergeMultisecs (c) initialDomainDecomposition vextor map identifies vertices of G in the domain decomposition - void computePriorities(domdec_t *dd, int *msvtxlist, int *key, int scoretype); o computes for each multisec u in msvtxlist its priority key[u] according to the node selection strategy scoretype - void eliminateMultisecs(domdec_t *dd, int *msvtxlist, int *rep); o eliminates multisecs according to their order in msvtxlist; furthermore, it sets rep[u] = v for all multisecs u that are adjacent to only one newly formed domain v o on return dd->vtype[u] = 1, iff u is a domain (rep[u] = u) dd->vtype[u] = 2, iff u is an uneliminated multisec (rep[u] = u) dd->vtype[u] = 3, iff u is an eliminated multisec (rep[u] = u) dd->vtype[u] = 4, iff multisec u is absorbed by new domain v = rep[u]; - void findIndMultisecs(domdec_t *dd, int *msvtxlist, int *rep); o searches all unelim./unabsorbed multisecs in msnvtxlist for indistinguishable multisecs; sets dd->vtype[u] = 4 and rep[u] = v, iff u, v are indistinguishable and v is the representative of u - dd2 = coarserDomainDecomposition(domdec_t* dd1, int *rep); o allocates memory for the coarser domain decomposition by calling newDomainDecomposition and creates the domain decomposition according to the vectors dd1->vtype and rep; vector dd1->map identifies the vertices of dd1 in dd2 - void shrinkDomainDecomposition(domdec_t *dd, int scoretype); o shrinks dd according to a chosen node selection strategy by calling the functions (a) computePriorities (b) eliminateMultisecs (c) findIndMultisecs (d) coarserDomainDecomposition the coarser domain decomposition is appended to dd via prev/next pointers ******************************************************************************/ #include /***************************************************************************** ******************************************************************************/ domdec_t* newDomainDecomposition(PORD_INT nvtx, PORD_INT nedges) { domdec_t *dd; mymalloc(dd, 1, domdec_t); mymalloc(dd->vtype, nvtx, PORD_INT); mymalloc(dd->color, nvtx, PORD_INT); mymalloc(dd->map, nvtx, PORD_INT); dd->G = newGraph(nvtx, nedges); dd->ndom = dd->domwght = 0; dd->cwght[GRAY] = dd->cwght[BLACK] = dd->cwght[WHITE] = 0; dd->prev = dd->next = NULL; return(dd); } /***************************************************************************** ******************************************************************************/ void freeDomainDecomposition(domdec_t *dd) { freeGraph(dd->G); free(dd->vtype); free(dd->color); free(dd->map); free(dd); } /***************************************************************************** ******************************************************************************/ void printDomainDecomposition(domdec_t *dd) { graph_t *G; PORD_INT count, u, v, i, istart, istop; G = dd->G; printf("\n#nodes %d (#domains %d, weight %d), #edges %d, totvwght %d\n", G->nvtx, dd->ndom, dd->domwght, G->nedges >> 1, G->totvwght); printf("partition weights: S %d, B %d, W %d\n", dd->cwght[GRAY], dd->cwght[BLACK], dd->cwght[WHITE]); for (u = 0; u < G->nvtx; u++) { count = 0; printf("--- adjacency list of node %d (vtype %d, color %d, map %d\n", u, dd->vtype[u], dd->color[u], dd->map[u]); istart = G->xadj[u]; istop = G->xadj[u+1]; for (i = istart; i < istop; i++) { v = G->adjncy[i]; printf("%5d (vtype %2d, color %2d)", v, dd->vtype[v], dd->color[v]); if ((++count % 3) == 0) printf("\n"); } if ((count % 3) != 0) printf("\n"); } } /***************************************************************************** ******************************************************************************/ void checkDomainDecomposition(domdec_t *dd) { PORD_INT *xadj, *adjncy, *vwght, *vtype; PORD_INT err, nvtx, ndom, domwght, dom, multi, u, v, i, istart, istop; nvtx = dd->G->nvtx; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vwght = dd->G->vwght; vtype = dd->vtype; err = FALSE; printf("checking domain decomposition (#nodes %d, #edges %d)\n", dd->G->nvtx, dd->G->nedges >> 1); ndom = domwght = 0; for (u = 0; u < nvtx; u++) { /* check node type */ if ((vtype[u] != 1) && (vtype[u] != 2)) { printf("ERROR: node %d is neither DOMAIN nor MULTISEC\n", u); err = TRUE; } /* count domains and sum up their weight */ if (vtype[u] == 1) { ndom++; domwght += vwght[u]; } /* check number of neighboring domains and multisecs */ dom = multi = 0; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; if (vtype[v] == 1) dom++; if (vtype[v] == 2) multi++; } if ((vtype[u] == 1) && (dom > 0)) { printf("ERROR: domain %d is adjacent to other domain\n", u); err = TRUE; } if ((vtype[u] == 2) && (dom < 2)) { printf("ERROR: less than 2 domains adjacent to multisec node %d\n", u); err = TRUE; } if ((vtype[u] == 2) && (multi > 0)) { printf("ERROR: multisec %d is adjacent to other multisec nodes\n", u); err = TRUE; } } /* check number and weight of domains */ if ((ndom != dd->ndom) || (domwght != dd->domwght)) { printf("ERROR: number/size (%d/%d) of domains does not match with those in" " domain decomp. (%d/%d)\n", ndom, domwght, dd->ndom, dd->domwght); err = TRUE; } if (err) quit(); } /***************************************************************************** ******************************************************************************/ void buildInitialDomains(graph_t *G, PORD_INT *vtxlist, PORD_INT *vtype, PORD_INT *rep) { PORD_INT *xadj, *adjncy; PORD_INT nvtx, u, v, w, i, j, jstart, jstop; xadj = G->xadj; adjncy = G->adjncy; nvtx = G->nvtx; /* -------------------------------------------------------------------- determine initial domains according to the order of nodes in vtxlist -------------------------------------------------------------------- */ for (i = 0; i < nvtx; i++) { u = vtxlist[i]; if (vtype[u] == 0) { vtype[u] = 1; jstart = xadj[u]; jstop = xadj[u+1]; for (j = jstart; j < jstop; j++) { v = adjncy[j]; vtype[v] = 2; } } } /* ------------------------------------------------------------ eliminate all multisecs that are adjacent to only one domain ------------------------------------------------------------ */ for (i = 0; i < nvtx; i++) { u = vtxlist[i]; if (vtype[u] == 2) { v = -1; jstart = xadj[u]; jstop = xadj[u+1]; for (j = jstart; j < jstop; j++) { w = adjncy[j]; if (vtype[w] == 1) { if (v == -1) v = rep[w]; /* u adjacent to domain v = rep[w] */ else if (v != rep[w]) { v = -1; /* u adjacent to another domain */ break; } } } if (v != -1) /* u absorbed by domain v */ { vtype[u] = 1; rep[u] = v; } } } } /***************************************************************************** ******************************************************************************/ void mergeMultisecs(graph_t *G, PORD_INT *vtype, PORD_INT *rep) { PORD_INT *xadj, *adjncy, *tmp, *queue; PORD_INT nvtx, qhead, qtail, flag, keepon, u, v, w, x; PORD_INT i, istart, istop, j, jstart, jstop; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; /* ------------------------ allocate working storage ------------------------ */ mymalloc(tmp, nvtx, PORD_INT); mymalloc(queue, nvtx, PORD_INT); for (u = 0; u < nvtx; u++) tmp[u] = -1; /* ------------------------------------------------------- merge all adjacent multisecs that do not share a domain ------------------------------------------------------- */ flag = 1; for (u = 0; u < nvtx; u++) if (vtype[u] == 2) { qhead = 0; qtail = 1; queue[0] = u; vtype[u] = -2; /* multisec u is the seed of a new cluster, mark all adj. domains */ istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; if (vtype[v] == 1) tmp[rep[v]] = flag; } /* and now build the cluster */ while (qhead != qtail) { v = queue[qhead++]; istart = xadj[v]; istop = xadj[v+1]; for (i = istart; i < istop; i++) { keepon = TRUE; w = adjncy[i]; if (vtype[w] == 2) { jstart = xadj[w]; jstop = xadj[w+1]; for (j = jstart; j < jstop; j++) { x = adjncy[j]; if ((vtype[x] == 1) && (tmp[rep[x]] == flag)) { keepon = FALSE; break; } } if (keepon) /* multisecs v and w have no domain in common; mark */ /* all domains adjacent to w and put w in cluster u */ { for (j = jstart; j < jstop; j++) { x = adjncy[j]; if (vtype[x] == 1) tmp[rep[x]] = flag; } queue[qtail++] = w; rep[w] = u; vtype[w] = -2; } } } } /* clear tmp vector for next round */ flag++; } /* ------------------------------------ reset vtype and free working storage ------------------------------------ */ for (u = 0; u < nvtx; u++) if (vtype[u] == -2) vtype[u] = 2; free(tmp); free(queue); } /***************************************************************************** ******************************************************************************/ domdec_t* initialDomainDecomposition(graph_t *G, PORD_INT *map, PORD_INT *vtype, PORD_INT *rep) { domdec_t *dd; PORD_INT *xadj, *adjncy, *vwght, *xadjdd, *adjncydd, *vwghtdd, *vtypedd; PORD_INT *tmp, *bin, nvtx, nedges, nvtxdd, nedgesdd, ndom, domwght, flag; PORD_INT i, j, jstart, jstop, u, v, w; nvtx = G->nvtx; nedges = G->nedges; xadj = G->xadj; adjncy = G->adjncy; vwght = G->vwght; /* ------------------------ allocate working storage ------------------------ */ mymalloc(tmp, nvtx, PORD_INT); mymalloc(bin, nvtx, PORD_INT); for (u = 0; u < nvtx; u++) { tmp[u] = -1; bin[u] = -1; } /* ------------------------------------------------------------- allocate memory for the dd using upper bounds nvtx and nedges ------------------------------------------------------------- */ dd = newDomainDecomposition(nvtx, nedges); xadjdd = dd->G->xadj; adjncydd = dd->G->adjncy; vwghtdd = dd->G->vwght; vtypedd = dd->vtype; /* ------------------------------------------------------- put all nodes u belonging to representative v in bin[v] ------------------------------------------------------- */ for (u = 0; u < nvtx; u++) { v = rep[u]; if (u != v) { bin[u] = bin[v]; bin[v] = u; } } /* ---------------------------------------------- and now build the initial domain decomposition ---------------------------------------------- */ flag = 1; nedgesdd = nvtxdd = 0; ndom = domwght = 0; for (u = 0; u < nvtx; u++) if (rep[u] == u) { xadjdd[nvtxdd] = nedgesdd; vtypedd[nvtxdd] = vtype[u]; vwghtdd[nvtxdd] = 0; tmp[u] = flag; /* find all cluster that are adjacent to u in dom. dec. */ v = u; do { map[v] = nvtxdd; vwghtdd[nvtxdd] += vwght[v]; jstart = xadj[v]; jstop = xadj[v+1]; for (j = jstart; j < jstop; j++) { w = adjncy[j]; if ((vtype[w] != vtype[u]) && (tmp[rep[w]] != flag)) { tmp[rep[w]] = flag; adjncydd[nedgesdd++] = rep[w]; } } v = bin[v]; } while (v != -1); if (vtypedd[nvtxdd] == 1) { ndom++; domwght += vwghtdd[nvtxdd]; } nvtxdd++; flag++; } /* -------------------------------------------- finalize the new domain decomposition object -------------------------------------------- */ xadjdd[nvtxdd] = nedgesdd; dd->G->nvtx = nvtxdd; dd->G->nedges = nedgesdd; dd->G->type = WEIGHTED; dd->G->totvwght = G->totvwght; for (i = 0; i < nedgesdd; i++) adjncydd[i] = map[adjncydd[i]]; for (u = 0; u < nvtxdd; u++) dd->color[u] = dd->map[u] = -1; dd->ndom = ndom; dd->domwght = domwght; /* ------------------------------- free working storage and return ------------------------------- */ free(tmp); free(bin); return(dd); } /***************************************************************************** ******************************************************************************/ domdec_t* constructDomainDecomposition(graph_t *G, PORD_INT *map) { domdec_t *dd; PORD_INT *xadj, *adjncy, *vwght, *vtxlist, *vtype, *key, *rep; PORD_INT nvtx, deg, u, i, istart, istop; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; vwght = G->vwght; /* --------------------------------------------------------- sort the vertices in G in ascending order of their degree --------------------------------------------------------- */ mymalloc(vtxlist, nvtx, PORD_INT); mymalloc(key, nvtx, PORD_INT); for (u = 0; u < nvtx; u++) { vtxlist[u] = u; istart = xadj[u]; istop = xadj[u+1]; switch(G->type) { case UNWEIGHTED: deg = istop - istart; break; case WEIGHTED: deg = 0; for (i = istart; i < istop; i++) deg += vwght[adjncy[i]]; break; default: fprintf(stderr, "\nError in function constructDomainDecomposition\n" " unrecognized graph type %d\n", G->type); quit(); } key[u] = deg; } distributionCounting(nvtx, vtxlist, key); free(key); /* ------------------------------------------------------------- build initial domains and cluster multisecs that do not share a common domain ------------------------------------------------------------- */ mymalloc(vtype, nvtx, PORD_INT); mymalloc(rep, nvtx, PORD_INT); for (u = 0; u < nvtx; u++) { vtype[u] = 0; rep[u] = u; } buildInitialDomains(G, vtxlist, vtype, rep); mergeMultisecs(G, vtype, rep); free(vtxlist); /* -------------------------------------------------- finally, build the domain decomposition and return -------------------------------------------------- */ dd = initialDomainDecomposition(G, map, vtype, rep); free(vtype); free(rep); return(dd); } /***************************************************************************** ******************************************************************************/ void computePriorities(domdec_t *dd, PORD_INT *msvtxlist, PORD_INT *key, PORD_INT scoretype) { PORD_INT *xadj, *adjncy, *vwght, *marker; PORD_INT nvtx, nlist, k, weight, deg, u, v, w; PORD_INT i, istart, istop, j, jstart, jstop; nvtx = dd->G->nvtx; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vwght = dd->G->vwght; marker = dd->map; nlist = nvtx - dd->ndom; switch(scoretype) { case QMRDV: /* maximal relative decrease of variables in quotient graph */ for (k = 0; k < nlist; k++) { u = msvtxlist[k]; weight = vwght[u]; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) weight += vwght[adjncy[i]]; key[u] = weight / vwght[u]; } break; case QMD: /* ----------------------- minimum degree in quotient graph */ for (k = 0; k < nlist; k++) { u = msvtxlist[k]; marker[u] = -1; } for (k = 0; k < nlist; k++) { u = msvtxlist[k]; marker[u] = u; deg = 0; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; jstart = xadj[v]; jstop = xadj[v+1]; for (j = jstart; j < jstop; j++) { w = adjncy[j]; if (marker[w] != u) { marker[w] = u; deg += vwght[w]; } } } key[u] = deg; } break; case QRAND: /* ------------------------------------------------- random */ for (k = 0; k < nlist; k++) { u = msvtxlist[k]; key[u] = myrandom(nvtx); } break; default: fprintf(stderr, "\nError in internal function computePriorities\n" " unrecognized node selection strategy %d\n", scoretype); quit(); } } /***************************************************************************** ******************************************************************************/ void eliminateMultisecs(domdec_t *dd, PORD_INT *msvtxlist, PORD_INT *rep) { PORD_INT *xadj, *adjncy, *vtype; PORD_INT nvtx, nlist, keepon, u, v, w, k, i, istart, istop; nvtx = dd->G->nvtx; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vtype = dd->vtype; nlist = nvtx - dd->ndom; /* ------------------------------------------------------- eliminate multisecs according to the order in msvtxlist ------------------------------------------------------- */ for (k = 0; k < nlist; k++) { u = msvtxlist[k]; istart = xadj[u]; istop = xadj[u+1]; keepon = TRUE; for (i = istart; i < istop; i++) { v = adjncy[i]; if (rep[v] != v) /* domain already absorbed by an eliminated */ { keepon = FALSE; /* multisec => multisec u cannot be deleted */ break; } } if (keepon) { vtype[u] = 3; for (i = istart; i < istop; i++) { v = adjncy[i]; rep[v] = u; } } } /* ------------------------------------------------------------ eliminate all multisecs that are adjacent to only one domain ------------------------------------------------------------ */ for (k = 0; k < nlist; k++) { u = msvtxlist[k]; if (vtype[u] == 2) { v = -1; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { w = adjncy[i]; if (v == -1) v = rep[w]; /* u adjacent to domain v = rep[w] */ else if (v != rep[w]) { v = -1; /* u adjacent to another domain */ break; } } if (v != -1) /* u absorbed by domain v */ { vtype[u] = 4; rep[u] = v; } } } } /***************************************************************************** ******************************************************************************/ void findIndMultisecs(domdec_t *dd, PORD_INT *msvtxlist, PORD_INT *rep) { PORD_INT *xadj, *adjncy, *vtype, *tmp, *bin, *checksum, *next, *key; PORD_INT nvtx, nlist, flag, keepon, deg, chk, ulast, u, v, k, i, istart, istop; nvtx = dd->G->nvtx; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vtype = dd->vtype; nlist = nvtx - dd->ndom; checksum = dd->map; /* ------------------------ allocate working storage ------------------------ */ mymalloc(tmp, nvtx, PORD_INT); mymalloc(bin, nvtx, PORD_INT); mymalloc(next, nvtx, PORD_INT); mymalloc(key, nvtx, PORD_INT); for (u = 0; u < nvtx; u++) { tmp[u] = -1; bin[u] = -1; } /* ------------------------------------------------------------------- compute checksums for all unelim./unabsorbed multisecs in msvtxlist ------------------------------------------------------------------- */ flag = 1; for (k = 0; k < nlist; k++) { u = msvtxlist[k]; if (vtype[u] == 2) { deg = chk = 0; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; if (tmp[rep[v]] != flag) { tmp[rep[v]] = flag; chk += rep[v]; deg++; } } chk = chk % nvtx; checksum[u] = chk; key[u] = deg; next[u] = bin[chk]; bin[chk] = u; flag++; } } /* --------------------------------- merge indistinguishable multisecs --------------------------------- */ for (k = 0; k < nlist; k++) { u = msvtxlist[k]; if (vtype[u] == 2) { chk = checksum[u]; v = bin[chk]; /* examine all multisecs in bin[hash] */ bin[chk] = -1; /* do this only once */ while (v != -1) { istart = xadj[v]; istop = xadj[v+1]; for (i = istart; i < istop; i++) tmp[rep[adjncy[i]]] = flag; ulast = v; /* v is principal and u is a potiential */ u = next[v]; /* nonprincipal variable */ while (u != -1) { keepon = TRUE; if (key[u] != key[v]) keepon = FALSE; if (keepon) { istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) if (tmp[rep[adjncy[i]]] != flag) { keepon = FALSE; break; } } if (keepon) /* found it! mark u as nonprincipal */ { rep[u] = v; /* printf(" >> mapping %d onto %d\n", u, v); */ vtype[u] = 4; u = next[u]; next[ulast] = u; /* remove u from bin */ } else /* failed */ { ulast = u; u = next[u]; } } v = next[v]; /* no more variables can be absorbed by v */ flag++; /* clear tmp vector for next round */ } } } /* -------------------- free working storage -------------------- */ free(tmp); free(bin); free(next); free(key); } /***************************************************************************** ******************************************************************************/ domdec_t* coarserDomainDecomposition(domdec_t* dd1, PORD_INT *rep) { domdec_t *dd2; PORD_INT *xadjdd1, *adjncydd1, *vwghtdd1, *vtypedd1, *mapdd1; PORD_INT *xadjdd2, *adjncydd2, *vwghtdd2, *vtypedd2; PORD_INT *tmp, *bin, nvtxdd1, nedgesdd1, nvtxdd2, nedgesdd2; PORD_INT ndom, domwght, flag, u, v, w, i, istart, istop; nvtxdd1 = dd1->G->nvtx; nedgesdd1 = dd1->G->nedges; xadjdd1 = dd1->G->xadj; adjncydd1 = dd1->G->adjncy; vwghtdd1 = dd1->G->vwght; vtypedd1 = dd1->vtype; mapdd1 = dd1->map; /* ------------------------ allocate working storage ------------------------ */ mymalloc(tmp, nvtxdd1, PORD_INT); mymalloc(bin, nvtxdd1, PORD_INT); for (u = 0; u < nvtxdd1; u++) { tmp[u] = -1; bin[u] = -1; } /* ------------------------------------------------------------ allocate memory using the upper bounds nvtxdd1 and nedgesdd1 ------------------------------------------------------------ */ dd2 = newDomainDecomposition(nvtxdd1, nedgesdd1); xadjdd2 = dd2->G->xadj; adjncydd2 = dd2->G->adjncy; vwghtdd2 = dd2->G->vwght; vtypedd2 = dd2->vtype; /* ------------------------------------------------------- put all nodes u belonging to representative v in bin[v] ------------------------------------------------------- */ for (u = 0; u < nvtxdd1; u++) { v = rep[u]; if (u != v) { bin[u] = bin[v]; bin[v] = u; } } /* ---------------------------------------------- and now build the coarser domain decomposition ---------------------------------------------- */ flag = 1; nvtxdd2 = nedgesdd2 = 0; ndom = domwght = 0; for (u = 0; u < nvtxdd1; u++) if (rep[u] == u) { xadjdd2[nvtxdd2] = nedgesdd2; vwghtdd2[nvtxdd2] = 0; vtypedd2[nvtxdd2] = vtypedd1[u]; if (vtypedd2[nvtxdd2] == 3) vtypedd2[nvtxdd2] = 1; tmp[u] = flag; /* find all cluster that are adjacent to u in dom. dec. */ v = u; do { mapdd1[v] = nvtxdd2; vwghtdd2[nvtxdd2] += vwghtdd1[v]; if ((vtypedd1[v] == 1) || (vtypedd1[v] == 2)) { istart = xadjdd1[v]; istop = xadjdd1[v+1]; for (i = istart; i < istop; i++) { w = adjncydd1[i]; if (tmp[rep[w]] != flag) { tmp[rep[w]] = flag; adjncydd2[nedgesdd2++] = rep[w]; } } } v = bin[v]; } while (v != -1); if (vtypedd2[nvtxdd2] == 1) { ndom++; domwght += vwghtdd2[nvtxdd2]; } nvtxdd2++; flag++; } /* -------------------------------------------- finalize the new domain decomposition object -------------------------------------------- */ xadjdd2[nvtxdd2] = nedgesdd2; dd2->G->nvtx = nvtxdd2; dd2->G->nedges = nedgesdd2; dd2->G->type = WEIGHTED; dd2->G->totvwght = dd1->G->totvwght; for (i = 0; i < nedgesdd2; i++) adjncydd2[i] = mapdd1[adjncydd2[i]]; for (u = 0; u < nvtxdd2; u++) dd2->color[u] = dd2->map[u] = -1; dd2->ndom = ndom; dd2->domwght = domwght; /* -------------------------- set back node types in dd1 -------------------------- */ for (u = 0; u < nvtxdd1; u++) if ((vtypedd1[u] == 3) || (vtypedd1[u] == 4)) vtypedd1[u] = 2; /* ------------------------------- free working storage and return ------------------------------- */ free(tmp); free(bin); return(dd2); } /***************************************************************************** ******************************************************************************/ void shrinkDomainDecomposition(domdec_t* dd1, PORD_INT scoretype) { domdec_t *dd2; PORD_INT *msvtxlist, *rep, *key; PORD_INT nvtxdd1, nlist, u; nvtxdd1 = dd1->G->nvtx; mymalloc(msvtxlist, nvtxdd1, PORD_INT); mymalloc(rep, nvtxdd1, PORD_INT); mymalloc(key, nvtxdd1, PORD_INT); /* --------------- initializations --------------- */ nlist = 0; for (u = 0; u < nvtxdd1; u++) { if (dd1->vtype[u] == 2) msvtxlist[nlist++] = u; rep[u] = u; } /* ------------------------------------- compute priorities and sort multisecs ------------------------------------- */ computePriorities(dd1, msvtxlist, key, scoretype); distributionCounting(nlist, msvtxlist, key); /* ---------------------------------------------------------- eliminate multisecs and build coarser domain decomposition ---------------------------------------------------------- */ eliminateMultisecs(dd1, msvtxlist, rep); findIndMultisecs(dd1, msvtxlist, rep); dd2 = coarserDomainDecomposition(dd1, rep); /* ----------------------------------- append coarser domain decomposition ----------------------------------- */ dd1->next = dd2; dd2->prev = dd1; free(msvtxlist); free(rep); free(key); } MUMPS_5.8.1/PORD/lib/gbipart.c0000664000175000017500000005155315042446416015563 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: gbipart.c / / author J"urgen Schulze, University of Paderborn / created 00dec26 / / This file contains functions dealing with bipartite graphs / ****************************************************************************** Data type: struct gbipart graph_t *G; pointer to graph object with E c X x Y int nX; the vertices 0,...,nX-1 belong to X int nY; the vertices nX,...,nX+nY-1 belong to Y Comments: o Structure used to smooth a separator computed for a subgraph Gbisect. The separator is paired with the border vertices in black/white partition, thus, resulting in a bipartite graph. Methods in lib/gbipart.c: - Gbipart = newBipartiteGraph(int nX, int nY, int nedges); - void freeBipartiteGraph(gbipart_t *Gbipart); - void printGbipart(gbipart_t *Gbipart); - Gbipart = setupBipartiteGraph(graph_t *G, int *bipartvertex, int nX, int nY, int *vtxmap) o Gbipart is induced by the vertices in bipartvertex. The first nX vertices are the vertices 0...nX-1 and the last nY vertices are the vertices nX...nX+nY-1 of Gbipart. Vector vtxmap maps the vertices in bipartvertex to the vertices of the bipartite graph. - void maximumMatching(gbipart_t *Gbipart, int *matching); - void maximumFlow(gbipart_t *Gbipart, int *flow, int *rc) o flow[i] stores the flow over the edge in adjncy[i] of Gbipart. It is positive, if the edge is from X to Y, otherwise flow is negative. o rc[u] stores the residual capacity of edge (source,u), u e X, respectively (u,sink), u e Y. All edges between X and Y have infinite capacity, therefore, no rc value must be computed for them. - void DMviaMatching(gbipart_t *Gbipart, int *matching, int *dmflag, int *dmwght); o on return. vector dmflag is filled with the following values: / SI, iff x e X is reachable via exposed node e X dmflag[x] = < SX, iff x e X is reachable via exposed node e Y \ SR, iff x e X - (SI u SX) / BI, iff y e Y is reachable via exposed node e Y dmflag[y] = < BX, iff y e Y is reachable via exposed node e X \ BR, iff y e Y - (BI u BX) o on return, vector dmwght is filled with the following values: dmwght[SI] - weight of SI dmwght[BI] - weight of BI dmwght[SX] - weight of SX dmwght[BX] - weight of BX dmwght[SR] - weight of SR dmwght[BR] - weight of BR - void DMviaFlow(gbipart_t *Gbipart, int *flow, int *rc, int *dmflag, int *dmwght); o vectors dmflag and dmwght are filled as described above ******************************************************************************/ #include #define FREE -1 #define SOURCE -2 #define SINK -3 /***************************************************************************** ******************************************************************************/ gbipart_t* newBipartiteGraph(PORD_INT nX, PORD_INT nY, PORD_INT nedges) { gbipart_t *Gbipart; mymalloc(Gbipart, 1, gbipart_t); Gbipart->G = newGraph(nX+nY, nedges); Gbipart->nX = nX; Gbipart->nY = nY; return(Gbipart); } /***************************************************************************** ******************************************************************************/ void freeBipartiteGraph(gbipart_t *Gbipart) { freeGraph(Gbipart->G); free(Gbipart); } /***************************************************************************** ******************************************************************************/ void printGbipart(gbipart_t *Gbipart) { graph_t *G; PORD_INT count, u, i, istart, istop; G = Gbipart->G; printf("\n#vertices %d (nX %d, nY %d), #edges %d, type %d, totvwght %d\n", G->nvtx, Gbipart->nX, Gbipart->nY, G->nedges >> 1, G->type, G->totvwght); for (u = 0; u < G->nvtx; u++) { count = 0; printf("--- adjacency list of vertex %d (weight %d):\n", u, G->vwght[u]); istart = G->xadj[u]; istop = G->xadj[u+1]; for (i = istart; i < istop; i++) { printf("%5d", G->adjncy[i]); if ((++count % 16) == 0) printf("\n"); } if ((count % 16) != 0) printf("\n"); } } /***************************************************************************** ******************************************************************************/ gbipart_t* setupBipartiteGraph(graph_t *G, PORD_INT *bipartvertex, PORD_INT nX, PORD_INT nY, PORD_INT *vtxmap) { gbipart_t *Gbipart; PORD_INT *xadj, *adjncy, *vwght, *xadjGb, *adjncyGb, *vwghtGb; PORD_INT nvtx, nedgesGb, totvwght, u, x, y, i, j, jstart, jstop, ptr; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; vwght = G->vwght; /* ---------------------------------------------------------------- compute number of edges and local indices of vertices in Gbipart ---------------------------------------------------------------- */ nedgesGb = 0; for (i = 0; i < nX+nY; i++) { u = bipartvertex[i]; if ((u < 0) || (u >= nvtx)) { fprintf(stderr, "\nError in function setupBipartiteGraph\n" " node %d does not belong to graph\n", u); quit(); } jstart = xadj[u]; jstop = xadj[u+1]; for (j = jstart; j < jstop; j++) vtxmap[adjncy[j]] = -1; nedgesGb += (jstop - jstart); } for (i = 0; i < nX+nY; i++) { u = bipartvertex[i]; vtxmap[u] = i; } Gbipart = newBipartiteGraph(nX, nY, nedgesGb); xadjGb = Gbipart->G->xadj; adjncyGb = Gbipart->G->adjncy; vwghtGb = Gbipart->G->vwght; /* --------------------------------- build the induced bipartite graph --------------------------------- */ totvwght = 0; ptr = 0; for (i = 0; i < nX; i++) { x = bipartvertex[i]; xadjGb[i] = ptr; vwghtGb[i] = vwght[x]; totvwght += vwght[x]; jstart = xadj[x]; jstop = xadj[x+1]; for (j = jstart; j < jstop; j++) { y = adjncy[j]; if (vtxmap[y] >= nX) adjncyGb[ptr++] = vtxmap[y]; } } for (i = nX; i < nX+nY; i++) { y = bipartvertex[i]; xadjGb[i] = ptr; vwghtGb[i] = vwght[y]; totvwght += vwght[y]; jstart = xadj[y]; jstop = xadj[y+1]; for (j = jstart; j < jstop; j++) { x = adjncy[j]; if ((vtxmap[x] >= 0) && (vtxmap[x] < nX)) adjncyGb[ptr++] = vtxmap[x]; } } xadjGb[nX+nY] = ptr; Gbipart->G->type = G->type; Gbipart->G->totvwght = totvwght; return(Gbipart); } /***************************************************************************** ******************************************************************************/ void maximumMatching(gbipart_t *Gbipart, PORD_INT *matching) { PORD_INT *xadj, *adjncy, *level, *marker, *queue, *stack; PORD_INT top, top2, u, x, x2, y, y2, nX, nY, i, istart, istop; PORD_INT qhead, qtail, max_level; xadj = Gbipart->G->xadj; adjncy = Gbipart->G->adjncy; nX = Gbipart->nX; nY = Gbipart->nY; mymalloc(level, (nX+nY), PORD_INT); mymalloc(marker, (nX+nY), PORD_INT); mymalloc(queue, nX, PORD_INT); mymalloc(stack, nY, PORD_INT); /* ------------------- initialize matching ------------------- */ for (u = 0; u < nX+nY; u++) matching[u] = FREE; /* --------------------------------------------------- construct maximal matching in bipartite graph (X,Y) --------------------------------------------------- */ for (x = 0; x < nX; x++) { istart = xadj[x]; istop = xadj[x+1]; for (i = istart; i < istop; i++) { y = adjncy[i]; if (matching[y] == FREE) { matching[x] = y; matching[y] = x; break; } } } /* -------------------------------------------------------------------- construct maximum matching in bipartite graph (X,Y) (Hopcroft, Karp) -------------------------------------------------------------------- */ while (TRUE) { for (u = 0; u < nX+nY; u++) level[u] = marker[u] = -1; qhead = qtail = 0; /* fill queue with free X nodes */ for (x = 0; x < nX; x++) if (matching[x] == FREE) { queue[qtail++] = x; level[x] = 0; } /* -------------------------------------------------------------- breadth first search to construct layer network containing all vertex disjoint augmenting paths of minimal length -------------------------------------------------------------- */ top = 0; max_level = MAX_INT; while (qhead != qtail) { x = queue[qhead++]; /* note: queue contains only */ if (level[x] < max_level) /* nodes from X */ { istart = xadj[x]; istop = xadj[x+1]; for (i = istart; i < istop; i++) { y = adjncy[i]; if (level[y] == -1) { level[y] = level[x] + 1; if (matching[y] == FREE) { max_level = level[y]; /* note: stack contains only */ stack[top++] = y; /* nodes form Y */ } else if (level[y] < max_level) { x2 = matching[y]; level[x2] = level[y] + 1; queue[qtail++] = x2; } } } } } if (top == 0) break; /* no augmenting path found */ /* ------------------------------------------------------------ restricted depth first search to construct maximal number of vertex disjoint augmenting paths in layer network ------------------------------------------------------------ */ while (top > 0) { top2 = top--; y = stack[top2-1]; /* get the next exposed node in Y */ marker[y] = xadj[y]; /* points to next neighbor of y */ while (top2 > top) { y = stack[top2-1]; i = marker[y]++; if (i < xadj[y+1]) /* not all neighbors of y visited */ { x = adjncy[i]; if ((marker[x] == -1) && (level[x] == level[y]-1)) { marker[x] = 0; if (level[x] == 0) /* augmenting path found */ while (top2 > top) /* pop stack */ { y2 = stack[--top2]; x2 = matching[y2]; /* / o == o */ matching[x] = y2; /* / */ matching[y2] = x; /* x -- y2 == x2 -- y */ x = x2; /* \ */ } /* \ o == o */ else { y2 = matching[x]; stack[top2++] = y2; marker[y2] = xadj[y2]; } } } else top2--; } } } /* ------------------------------- free working storage and return ------------------------------- */ free(level); free(marker); free(queue); free(stack); } /***************************************************************************** ******************************************************************************/ void maximumFlow(gbipart_t *Gbipart, PORD_INT *flow, PORD_INT *rc) { PORD_INT *xadj, *adjncy, *vwght, *parent, *marker, *queue; PORD_INT nedges, u, v, x, y, nX, nY, j, i, istart, istop; PORD_INT qhead, qtail, capacity; nedges = Gbipart->G->nedges; xadj = Gbipart->G->xadj; adjncy = Gbipart->G->adjncy; vwght = Gbipart->G->vwght; nX = Gbipart->nX; nY = Gbipart->nY; mymalloc(parent, (nX+nY), PORD_INT); mymalloc(marker, (nX+nY), PORD_INT); mymalloc(queue, (nX+nY), PORD_INT); /* ------------------------------------- initialize flow and residual capacity ------------------------------------- */ for (u = 0; u < nX+nY; u++) rc[u] = vwght[u]; for (i = 0; i < nedges; i++) flow[i] = 0; /* -------------------------------------------------- determine an initial flow in the bipartite network -------------------------------------------------- */ for (x = 0; x < nX; x++) { istart = xadj[x]; istop = xadj[x+1]; for (i = istart; i < istop; i++) { y = adjncy[i]; capacity = min(rc[x], rc[y]); if (capacity > 0) { rc[x] -= capacity; rc[y] -= capacity; flow[i] = capacity; for (j = xadj[y]; adjncy[j] != x; j++); flow[j] = -capacity; } if (rc[x] == 0) break; } } /* ----------------------------------------------------------- construct maximum flow in bipartite network (Edmonds, Karp) ----------------------------------------------------------- */ while (TRUE) { for (u = 0; u < nX+nY; u++) parent[u] = marker[u] = -1; qhead = qtail = 0; /* fill queue with free X nodes */ for (x = 0; x < nX; x++) if (rc[x] > 0) { queue[qtail++] = x; parent[x] = x; } /* --------------------------------------------------------- breadth first search to find the shortest augmenting path --------------------------------------------------------- */ capacity = 0; while (qhead != qtail) { u = queue[qhead++]; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; if ((parent[v] == -1) && ((v >= nX) || (flow[i] < 0))) /* v >= nX => u->v is a forward edge having infty capacity */ /* otherwise u<-v is a backward edge and (v,u) must have */ /* positive capacity (i.e. (u,v) has neg. capacity) */ { parent[v] = u; marker[v] = i; queue[qtail++] = v; if ((v >= nX) && (rc[v] > 0)) /* found it! */ { u = v; /* (v,sink) is below capacity */ capacity = rc[u]; while (parent[u] != u) /* get minimal residual capa. */ { i = marker[u]; u = parent[u]; if (u >= nX) capacity = min(capacity, -flow[i]); } capacity = min(capacity, rc[u]); rc[v] -= capacity; /* augment flow by min. rc */ while (parent[v] != v) { i = marker[v]; u = parent[v]; flow[i] += capacity; for (j = xadj[v]; adjncy[j] != u; j++); flow[j] = -flow[i]; v = u; } rc[v] -= capacity; qhead = qtail; /* escape inner while loop */ break; } } } } if (capacity == 0) break; } free(parent); free(marker); free(queue); } /***************************************************************************** ******************************************************************************/ void DMviaMatching(gbipart_t *Gbipart, PORD_INT *matching, PORD_INT *dmflag, PORD_INT *dmwght) { PORD_INT *xadj, *adjncy, *vwght, *queue, qhead, qtail; PORD_INT u, x, nX, y, nY, i, istart, istop; xadj = Gbipart->G->xadj; adjncy = Gbipart->G->adjncy; vwght = Gbipart->G->vwght; nX = Gbipart->nX; nY = Gbipart->nY; mymalloc(queue, (nX+nY), PORD_INT); /* ---------------------------------------------------------------------- mark all exposed nodes of X with SI and all exposed nodes of Y with BI ---------------------------------------------------------------------- */ qhead = qtail = 0; for (x = 0; x < nX; x++) if (matching[x] == FREE) { queue[qtail++] = x; dmflag[x] = SI; } else dmflag[x] = SR; for (y = nX; y < nX+nY; y++) if (matching[y] == FREE) { queue[qtail++] = y; dmflag[y] = BI; } else dmflag[y] = BR; /* ------------------------------------------------------------------ construct Dulmage-Mendelsohn decomp. starting with SI and BI nodes ------------------------------------------------------------------ */ while (qhead != qtail) { u = queue[qhead++]; istart = xadj[u]; istop = xadj[u+1]; switch(dmflag[u]) { case SI: for (i = istart; i < istop; i++) { y = adjncy[i]; if (dmflag[y] == BR) { queue[qtail++] = y; dmflag[y] = BX; } } break; case BX: x = matching[u]; dmflag[x] = SI; queue[qtail++] = x; break; case BI: for (i = istart; i < istop; i++) { x = adjncy[i]; if (dmflag[x] == SR) { queue[qtail++] = x; dmflag[x] = SX; } } break; case SX: y = matching[u]; dmflag[y] = BI; queue[qtail++] = y; break; } } /* ---------------------- fill the dmwght vector ---------------------- */ dmwght[SI] = dmwght[SX] = dmwght[SR] = 0; for (x = 0; x < nX; x++) switch(dmflag[x]) { case SI: dmwght[SI] += vwght[x]; break; case SX: dmwght[SX] += vwght[x]; break; case SR: dmwght[SR] += vwght[x]; break; } dmwght[BI] = dmwght[BX] = dmwght[BR] = 0; for (y = nX; y < nX+nY; y++) switch(dmflag[y]) { case BI: dmwght[BI] += vwght[y]; break; case BX: dmwght[BX] += vwght[y]; break; case BR: dmwght[BR] += vwght[y]; break; } free(queue); } /***************************************************************************** ******************************************************************************/ void DMviaFlow(gbipart_t *Gbipart, PORD_INT *flow, PORD_INT *rc, PORD_INT *dmflag, PORD_INT *dmwght) { PORD_INT *xadj, *adjncy, *vwght, *queue, qhead, qtail; PORD_INT u, v, x, nX, y, nY, i, istart, istop; xadj = Gbipart->G->xadj; adjncy = Gbipart->G->adjncy; vwght = Gbipart->G->vwght; nX = Gbipart->nX; nY = Gbipart->nY; mymalloc(queue, (nX+nY), PORD_INT); /* ---------------------------------------------------------- mark all nodes reachable from source/sink with SOURCE/SINK ---------------------------------------------------------- */ qhead = qtail = 0; for (x = 0; x < nX; x++) if (rc[x] > 0) { queue[qtail++] = x; dmflag[x] = SOURCE; } else dmflag[x] = FREE; for (y = nX; y < nX+nY; y++) if (rc[y] > 0) { queue[qtail++] = y; dmflag[y] = SINK; } else dmflag[y] = FREE; /* -------------------------------------------------------------------- construct Dulmage-Mendelsohn decomp. starting with SOURCE/SINK nodes -------------------------------------------------------------------- */ while (qhead != qtail) { u = queue[qhead++]; istart = xadj[u]; istop = xadj[u+1]; switch(dmflag[u]) { case SOURCE: for (i = istart; i < istop; i++) { v = adjncy[i]; if ((dmflag[v] == FREE) && ((v >= nX) || (flow[i] < 0))) { queue[qtail++] = v; dmflag[v] = SOURCE; /* v reachable via forward edge u->v */ } /* or via backward edge u<-v */ } break; case SINK: for (i = istart; i < istop; i++) { v = adjncy[i]; if ((dmflag[v] == FREE) && ((v < nX) || (flow[i] > 0))) { queue[qtail++] = v; dmflag[v] = SINK; /* u reachable via forward edge v->u */ } /* or via backward edge v<-u */ } break; } } /* ----------------------------------------------------- all nodes x in X with dmflag[x] = SOURCE belong to SI all nodes x in X with dmflag[x] = SINK belong to SX all nodes x in X with dmflag[x] = FREE belong to SR ----------------------------------------------------- */ dmwght[SI] = dmwght[SX] = dmwght[SR] = 0; for (x = 0; x < nX; x++) switch(dmflag[x]) { case SOURCE: dmflag[x] = SI; dmwght[SI] += vwght[x]; break; case SINK: dmflag[x] = SX; dmwght[SX] += vwght[x]; break; default: dmflag[x] = SR; dmwght[SR] += vwght[x]; } /* ----------------------------------------------------- all nodes y in Y with dmflag[y] = SOURCE belong to BX all nodes y in Y with dmflag[y] = SINK belong to BI all nodes y in Y with dmflag[y] = FREE belong to BR ----------------------------------------------------- */ dmwght[BI] = dmwght[BX] = dmwght[BR] = 0; for (y = nX; y < nX+nY; y++) switch(dmflag[y]) { case SOURCE: dmflag[y] = BX; dmwght[BX] += vwght[y]; break; case SINK: dmflag[y] = BI; dmwght[BI] += vwght[y]; break; default: dmflag[y] = BR; dmwght[BR] += vwght[y]; } free(queue); } MUMPS_5.8.1/PORD/lib/Makefile0000664000175000017500000000166215042446416015423 0ustar amestoyamestoy # To compile directly, uncomment the line below. # include ../Make.in # # include $(BUILDDIR)/Makefile.inc # # Otherwise, adequate variables for CC, CFLAGS, AR and # RANLIB must be passed to make. # .PHONY: clean realclean INCLUDES = -I../include COPTIONS = $(INCLUDES) $(CFLAGS) $(OPTFLAGS) $(FPIC) OBJS = graph.o gbipart.o gbisect.o ddcreate.o ddbisect.o nestdiss.o \ multisector.o gelim.o bucket.o tree.o \ symbfac.o interface.o sort.o minpriority.o # Note: numfac.c read.c mapping.c triangular.c matrix.c kernel.c # were not direcly used by MUMPS and have been removed from the # original SPACE package. # OUTC = -o .c.o: $(CC) $(COPTIONS) -c $*.c $(OUTC)$*.o libpord$(PLAT)$(LIBEXT):$(OBJS) $(AR)$@ $(OBJS) $(RANLIB) $@ libpord$(PLAT)$(LIBEXT_SHARED):$(OBJS) $(CC) -shared $(OBJS) -o libpord$(PLAT)$(LIBEXT_SHARED) clean: rm -f *.o realclean: rm -f *.o libpord$(PLAT)$(LIBEXT) libpord$(PLAT)$(LIBEXT_SHARED) MUMPS_5.8.1/PORD/lib/interface.c0000664000175000017500000006507515042446416016077 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: interface.c / / author J"urgen Schulze, University of Paderborn / created 01jan26 / / This file contains some high level interface functions (only these / functions should be called by a user). / ******************************************************************************/ #include /***************************************************************************** o Input: undirected graph G options -- if NULL, default options are used option[0] holds OPTION_ORDTYPE option[1] holds OPTION_NODE_SELECTION1 option[2] holds OPTION_NODE_SELECTION2 option[3] holds OPTION_NODE_SELECTION3 option[4] holds OPTION_DOMAIN_SIZE option[5] holds OPTION_MSGLVL o Output: elimination/front tree T reflecting the ordering of G cpus -- if NULL, no timing information is pulled back cpus[0] holds TIME_COMPRESS cpus[1] holds TIME_MS cpus[2] holds TIME_MULTILEVEL cpus[3] holds TIME_INITDOMDEC cpus[4] holds TIME_COARSEDOMDEC cpus[5] holds TIME_INITSEP cpus[6] holds TIME_REFINESEP cpus[7] holds TIME_SMOOTH cpus[8] holds TIME_BOTTOMUP cpus[9] holds TIME_UPDADJNCY cpus[10] holds TIME_FINDINODES cpus[11] holds TIME_UPDSCORE o Comments: this function computes an ordering for G; it returns an elimination tree T; permutation vectors perm, invp can be extracted from T by calling function permFromElimTree(T, perm, invp) ******************************************************************************/ elimtree_t* SPACE_ordering(graph_t *G, options_t *options, timings_t *cpus) { graph_t *Gc; multisector_t *ms; minprior_t *minprior; elimtree_t *T, *T2; timings_t cpusOrd[ORD_TIME_SLOTS]; options_t default_options[] = { SPACE_ORDTYPE, SPACE_NODE_SELECTION1, SPACE_NODE_SELECTION2, SPACE_NODE_SELECTION3, SPACE_DOMAIN_SIZE, SPACE_MSGLVL }; PORD_INT *vtxmap, istage, totnstep, totnzf; FLOAT totops; /* -------------------------------------------------- set default options, if no other options specified -------------------------------------------------- */ if (options == NULL) options = default_options; /* ---------------- reset all timers ---------------- */ pord_resettimer(cpusOrd[TIME_COMPRESS]); pord_resettimer(cpusOrd[TIME_MS]); pord_resettimer(cpusOrd[TIME_MULTILEVEL]); pord_resettimer(cpusOrd[TIME_INITDOMDEC]); pord_resettimer(cpusOrd[TIME_COARSEDOMDEC]); pord_resettimer(cpusOrd[TIME_INITSEP]); pord_resettimer(cpusOrd[TIME_REFINESEP]); pord_resettimer(cpusOrd[TIME_SMOOTH]); pord_resettimer(cpusOrd[TIME_BOTTOMUP]); pord_resettimer(cpusOrd[TIME_UPDADJNCY]); pord_resettimer(cpusOrd[TIME_FINDINODES]); pord_resettimer(cpusOrd[TIME_UPDSCORE]); /* ------------------ compress the graph ------------------ */ pord_starttimer(cpusOrd[TIME_COMPRESS]); mymalloc(vtxmap, G->nvtx, PORD_INT); Gc = compressGraph(G, vtxmap); pord_stoptimer(cpusOrd[TIME_COMPRESS]); if (Gc != NULL) { if (options[OPTION_MSGLVL] > 0) printf("compressed graph constructed (#nodes %d, #edges %d)\n", Gc->nvtx, Gc->nedges >> 1); } else { Gc = G; free(vtxmap); if (options[OPTION_MSGLVL] > 0) printf("no compressed graph constructed\n"); } /* ------------------- compute multisector ------------------- */ pord_starttimer(cpusOrd[TIME_MS]); ms = constructMultisector(Gc, options, cpusOrd); pord_stoptimer(cpusOrd[TIME_MS]); if (options[OPTION_MSGLVL] > 0) printf("quality of multisector: #stages %d, #nodes %d, weight %d\n", ms->nstages, ms->nnodes, ms->totmswght); /* --------------------------------- compute minimum priority ordering --------------------------------- */ pord_starttimer(cpusOrd[TIME_BOTTOMUP]) minprior = setupMinPriority(ms); T = orderMinPriority(minprior, options, cpusOrd); pord_stoptimer(cpusOrd[TIME_BOTTOMUP]); if (options[OPTION_MSGLVL] > 0) { totnstep = totnzf = 0; totops = 0.0; for (istage = 0; istage < ms->nstages; istage++) { totnstep += minprior->stageinfo[istage].nstep; totnzf += minprior->stageinfo[istage].nzf; totops += minprior->stageinfo[istage].ops; } printf("quality of ordering: #steps %d, nzl %d, ops %e\n", totnstep, totnzf, totops); } /* ----------------------- expand elimination tree ----------------------- */ if (Gc != G) { T2 = expandElimTree(T, vtxmap, G->nvtx); freeElimTree(T); freeGraph(Gc); free(vtxmap); } else T2 = T; /* -------------------------------------------------- pull back timing results, if vector cpus available -------------------------------------------------- */ if (cpus != NULL) { cpus[0] = cpusOrd[TIME_COMPRESS]; cpus[1] = cpusOrd[TIME_MS]; cpus[2] = cpusOrd[TIME_MULTILEVEL]; cpus[3] = cpusOrd[TIME_INITDOMDEC]; cpus[4] = cpusOrd[TIME_COARSEDOMDEC]; cpus[5] = cpusOrd[TIME_INITSEP]; cpus[6] = cpusOrd[TIME_REFINESEP]; cpus[7] = cpusOrd[TIME_SMOOTH]; cpus[8] = cpusOrd[TIME_BOTTOMUP]; cpus[9] = cpusOrd[TIME_UPDADJNCY]; cpus[10] = cpusOrd[TIME_FINDINODES]; cpus[11] = cpusOrd[TIME_UPDSCORE]; } /* ---------------------- free memory and return ---------------------- */ freeMultisector(ms); freeMinPriority(minprior); return(T2); } #if defined(cleaned_version) /***************************************************************************** o Input: elimination/front tree T max. number of zeros that is allowed to be introduced in front o Output: transformed elimination/front tree T' o Comments: the goal is to make T (obtained by orderMinPriority or setupElimTree) more appropiate for the multifrontal algorithm ******************************************************************************/ elimtree_t* SPACE_transformElimTree(elimtree_t *T, PORD_INT maxzeros) { elimtree_t *T2, *T3; /* ----------------------------------------------------- 1st: determine the fundamental fronts this step significantly improves the cache reuse ----------------------------------------------------- */ T2 = fundamentalFronts(T); /* ----------------------------------------------------------------- 2nd: group together small subtrees into one front this step reduces the number of fronts and thus the overhead associated with them; the expense is added storage for the logically zero entries and the factor operations on them ------------------------------------------------------------------ */ T3 = mergeFronts(T2, maxzeros); freeElimTree(T2); /* -------------------------------------------------------------- 3rd: order the children of a front so that the working storage in the multifrontal algorithm is minimized -------------------------------------------------------------- */ (void)justifyFronts(T3); return(T3); } /***************************************************************************** o Input: transformed elimination/front tree T, input matrix A o Output: initial factor matrix L of the permuted input matrix PAP o Comments: L contains nonzeros of PAP; all other entries are set to 0.0 ******************************************************************************/ factorMtx_t* SPACE_symbFac(elimtree_t *T, inputMtx_t *A) { factorMtx_t *L; frontsub_t *frontsub; css_t *css; inputMtx_t *PAP; elimtree_t *PTP; PORD_INT *perm, neqs, nelem; /* ------------------------------------------------------ extract permutation vectors from T and permute T and A ------------------------------------------------------ */ neqs = A->neqs; mymalloc(perm, neqs, PORD_INT); permFromElimTree(T, perm); PTP = permuteElimTree(T, perm); PAP = permuteInputMtx(A, perm); /* ------------------------------------------------------------------- create factor matrix L of PAP, i.e. (1) create the subscript structure of the fronts, i.e. frontsub (2) use frontsub to create the compressed subscript structure of L (3) allocate memory for L and the nonzeros of L, i.e. L->nzl (4) init. L with the nonzeros of PAP ------------------------------------------------------------------- */ frontsub = setupFrontSubscripts(PTP, PAP); css = setupCSSFromFrontSubscripts(frontsub); nelem = css->xnzl[neqs]; L = newFactorMtx(nelem); L->perm = perm; L->frontsub = frontsub; L->css = css; initFactorMtx(L, PAP); /* ----------------------------------------------------- free permuted input matrix and return note: PTP and perm have been inherited by frontsub, L ----------------------------------------------------- */ freeInputMtx(PAP); return(L); } /***************************************************************************** o Input: transformed elimination/front tree initial factor matrix L of the permuted input matrix PAP o Output: factor matrix L of the permuted input matrix PAP cpus -- if NULL no timing information is pulled back cpus[0] holds TIME_INITFRONT cpus[1] holds TIME_EXPAND cpus[2] holds TIME_KERNEL cpus[3] holds TIME_INITUPD o Comments: this function does the actual numerical factorization; to improve register and cache reuse it uses a kernel of size 3x3 ******************************************************************************/ void SPACE_numFac(factorMtx_t *L, timings_t *cpus) { timings_t cpusFactor[NUMFAC_TIME_SLOTS]; /* ---------------- reset all timers ---------------- */ pord_resettimer(cpusFactor[TIME_INITFRONT]); pord_resettimer(cpusFactor[TIME_EXADD]); pord_resettimer(cpusFactor[TIME_KERNEL]); pord_resettimer(cpusFactor[TIME_INITUPD]); /* ------------------------- compute Cholesky factor L ------------------------- */ numfac(L, cpusFactor); /* -------------------------------------------------- pull back timing results, if vector cpus available -------------------------------------------------- */ if (cpus != NULL) { cpus[0] = cpusFactor[TIME_INITFRONT]; cpus[1] = cpusFactor[TIME_EXADD]; cpus[2] = cpusFactor[TIME_KERNEL]; cpus[3] = cpusFactor[TIME_INITUPD]; } } /***************************************************************************** o Input: transformed elimination/front tree factor matrix L of the permuted input matrix PAP right hand side vector rhs of the original system Ax = b o Output: solution vector xvec of the original system Ax = b o Comments: this function solves the remaining triangular systems; ******************************************************************************/ void SPACE_solveTriangular(factorMtx_t *L, FLOAT *rhs, FLOAT *xvec) { FLOAT *yvec; PORD_INT *perm; PORD_INT neqs, k; perm = L->perm; neqs = L->css->neqs; /* ------------------------------------------- set up permuted right hand side vector yvec ------------------------------------------- */ mymalloc(yvec, neqs, FLOAT); for (k = 0; k < neqs; k++) yvec[perm[k]] = rhs[k]; /* ------------------------- solve Ly = b and L^Tz = y ------------------------- */ forwardSubst1x1(L, yvec); backwardSubst1x1(L, yvec); /* --------------------------------------------------------------- extract from yvec the solution vector of the un-permuted system --------------------------------------------------------------- */ for (k = 0; k < neqs; k++) xvec[k] = yvec[perm[k]]; free(yvec); } /***************************************************************************** o Input: sparse matrix A, right hand side vector rhs options -- if NULL, default options are used option[0] holds OPTION_ORDTYPE option[1] holds OPTION_NODE_SELECTION1 option[2] holds OPTION_NODE_SELECTION2 option[3] holds OPTION_NODE_SELECTION3 option[4] holds OPTION_DOMAIN_SIZE option[5] holds OPTION_MSGLVL option[6] holds OPTION_ETREE_NONZ o Output: solution vector xvec of the original system Ax = b cpus -- if NULL, no timing information is pulled back cpus[0] holds time to construct the graph cpus[1] holds time to compute the ordering cpus[2] holds TIME_COMPRESS cpus[3] holds TIME_MS cpus[4] holds TIME_MULTILEVEL cpus[5] holds TIME_INITDOMDEC cpus[6] holds TIME_COARSEDOMDEC cpus[7] holds TIME_INITSEP cpus[8] holds TIME_REFINESEP cpus[9] holds TIME_SMOOTH cpus[10] holds TIME_BOTTOMUP cpus[11] holds TIME_UPDADJNCY; cpus[12] holds TIME_FINDINODES cpus[13] holds TIME_UPDSCORE cpus[14] holds time to transform the elimination tree cpus[15] holds time to compute the symbolical factorization cpus[16] holds time to compute the numerical factorization cpus[17] holds TIME_INITFRONT cpus[18] holds TIME_EXADD cpus[19] holds TIME_KERNEL cpus[20] holds TIME_INITUPD cpus[21] holds time to solve the triangular systems o Comments: this is the final topmost function that can be used as a black box in other algorithm; it provides a general purpose direct solver for large sparse positive definite systems ******************************************************************************/ void SPACE_solve(inputMtx_t *A, FLOAT *rhs, FLOAT *xvec, options_t *options, timings_t *cpus) { graph_t *G; elimtree_t *T, *T2; factorMtx_t *L; timings_t cpusOrd[ORD_TIME_SLOTS], cpusFactor[NUMFAC_TIME_SLOTS]; timings_t t_graph, t_ord, t_etree, t_symb, t_num, t_solvetri; options_t default_options[] = { SPACE_ORDTYPE, SPACE_NODE_SELECTION1, SPACE_NODE_SELECTION2, SPACE_NODE_SELECTION3, SPACE_DOMAIN_SIZE, SPACE_MSGLVL, SPACE_ETREE_NONZ }; /* -------------------------------------------------- set default options, if no other options specified -------------------------------------------------- */ if (options == NULL) options = default_options; /* ---------------- reset all timers ---------------- */ pord_resettimer(t_graph); pord_resettimer(t_ord); pord_resettimer(t_etree); pord_resettimer(t_symb); pord_resettimer(t_num); pord_resettimer(t_solvetri); /* ----------------- set up graph G(A) ----------------- */ pord_starttimer(t_graph); G = setupGraphFromMtx(A); pord_stoptimer(t_graph); if (options[OPTION_MSGLVL] > 0) printf("\ninduced graph constructed: #vertices %d, #edges %d, #components " "%d\n", G->nvtx, G->nedges >> 1, connectedComponents(G)); /* -------------------------------------------- construct ordering/elimination tree for G(A) -------------------------------------------- */ pord_starttimer(t_ord); T = SPACE_ordering(G, options, cpusOrd); pord_stoptimer(t_ord); freeGraph(G); if (options[OPTION_MSGLVL] > 0) printf("quality of initial elim. tree: #fronts %d, #indices %d\n\t" "nzl %d, ops %e, wspace %d\n", T->nfronts, nFactorIndices(T), nFactorEntries(T), nFactorOps(T), nWorkspace(T)); /* ------------------------------- elimination tree transformation ------------------------------- */ pord_starttimer(t_etree); T2 = SPACE_transformElimTree(T, options[OPTION_ETREE_NONZ]); pord_stoptimer(t_etree); freeElimTree(T); if (options[OPTION_MSGLVL] > 0) printf("quality of transformed elim. tree: #fronts %d, #indices %d\n\t" "nzl %d, ops %e, wspace %d\n", T2->nfronts, nFactorIndices(T2), nFactorEntries(T2), nFactorOps(T2), nWorkspace(T2)); /* ------------------------ symbolical factorization ------------------------ */ pord_starttimer(t_symb); L = SPACE_symbFac(T2, A); pord_stoptimer(t_symb); if (options[OPTION_MSGLVL] > 0) printf("quality of factor matrix:\n\tneqs %d, #indices %d, nzl %d\n", L->css->neqs, L->css->nind, L->nelem); /* ----------------------- numerical factorization ----------------------- */ pord_starttimer(t_num); SPACE_numFac(L, cpusFactor); pord_stoptimer(t_num); if (options[OPTION_MSGLVL] > 0) printf("performance of numerical factorization: %6.2f mflops\n", (double)nFactorOps(T2) / t_num / 1000000); /* ------------------------------ solution of triangular systems ------------------------------ */ pord_starttimer(t_solvetri); SPACE_solveTriangular(L, rhs, xvec); pord_stoptimer(t_solvetri); if (options[OPTION_MSGLVL] > 0) printf("performance of forward/backward solve: %6.2f mflops\n", (double)nTriangularOps(T2) / t_solvetri / 1000000); freeElimTree(T2); freeFactorMtx(L); /* -------------------------------------------------- pull back timing results, if vector cpus available -------------------------------------------------- */ if (cpus != NULL) { cpus[0] = t_graph; cpus[1] = t_ord; cpus[2] = cpusOrd[TIME_COMPRESS]; cpus[3] = cpusOrd[TIME_MS]; cpus[4] = cpusOrd[TIME_MULTILEVEL]; cpus[5] = cpusOrd[TIME_INITDOMDEC]; cpus[6] = cpusOrd[TIME_COARSEDOMDEC]; cpus[7] = cpusOrd[TIME_INITSEP]; cpus[8] = cpusOrd[TIME_REFINESEP]; cpus[9] = cpusOrd[TIME_SMOOTH]; cpus[10] = cpusOrd[TIME_BOTTOMUP]; cpus[11] = cpusOrd[TIME_UPDADJNCY]; cpus[12] = cpusOrd[TIME_FINDINODES]; cpus[13] = cpusOrd[TIME_UPDSCORE]; cpus[14] = t_etree; cpus[15] = t_symb; cpus[16] = t_num; cpus[17] = cpusFactor[TIME_INITFRONT]; cpus[18] = cpusFactor[TIME_EXADD]; cpus[19] = cpusFactor[TIME_KERNEL]; cpus[20] = cpusFactor[TIME_INITUPD]; cpus[21] = t_solvetri; } } /***************************************************************************** o Input: sparse matrix A with permutation vector perm right hand side vector rhs options -- if NULL, default options are used option[0] holds OPTION_MSGLVL option[1] holds OPTION_ETREE_NONZ o Output: solution vector xvec of the original system Ax = b cpus -- if NULL, no timing information is pulled back cpus[0] holds time to construct the graph cpus[1] holds time to construct the elimination tree cpus[2] holds time to transform the elimination tree cpus[3] holds time to compute the symbolical factorization cpus[4] holds time to compute the numerical factorization cpus[5] holds TIME_INITFRONT cpus[6] holds TIME_EXADD cpus[7] holds TIME_KERNEL cpus[8] holds TIME_INITUPD cpus[9] holds time to solve the triangular systems o Comments: this function can be used to solve an equation system using an externally computed permutation vector ******************************************************************************/ void SPACE_solveWithPerm(inputMtx_t *A, PORD_INT *perm, FLOAT *rhs, FLOAT *xvec, options_t *options, timings_t *cpus) { graph_t *G; elimtree_t *T, *T2; factorMtx_t *L; timings_t cpusFactor[NUMFAC_TIME_SLOTS], t_graph, t_etree_construct; timings_t t_etree_merge, t_symb, t_num, t_solvetri; options_t default_options[] = { SPACE_MSGLVL, SPACE_ETREE_NONZ }; PORD_INT *invp, i, msglvl, maxzeros; /* -------------------------------------------------- set default options, if no other options specified -------------------------------------------------- */ if (options == NULL) options = default_options; msglvl = options[0]; maxzeros = options[1]; /* ---------------- reset all timers ---------------- */ pord_resettimer(t_graph); pord_resettimer(t_etree_construct); pord_resettimer(t_etree_merge); pord_resettimer(t_symb); pord_resettimer(t_num); pord_resettimer(t_solvetri); /* ----------------- set up graph G(A) ----------------- */ pord_starttimer(t_graph); G = setupGraphFromMtx(A); pord_stoptimer(t_graph); if (msglvl > 0) printf("\ninduced graph constructed: #vertices %d, #edges %d, #components " "%d\n", G->nvtx, G->nedges >> 1, connectedComponents(G)); /* --------------------------------------------------- construct inital elimination tree according to perm --------------------------------------------------- */ pord_starttimer(t_etree_construct); mymalloc(invp, G->nvtx, PORD_INT); for (i = 0; i < G->nvtx; i++) invp[perm[i]] = i; T = setupElimTree(G, perm, invp); pord_stoptimer(t_etree_construct); freeGraph(G); free(invp); if (msglvl > 0) printf("quality of initial elim. tree: #fronts %d, #indices %d\n\t" "nzl %d, ops %e, wspace %d\n", T->nfronts, nFactorIndices(T), nFactorEntries(T), nFactorOps(T), nWorkspace(T)); /* ------------------------------- elimination tree transformation ------------------------------- */ pord_starttimer(t_etree_merge); T2 = SPACE_transformElimTree(T, maxzeros); pord_stoptimer(t_etree_merge); freeElimTree(T); if (msglvl > 0) printf("quality of transformed elim. tree: #fronts %d, #indices %d\n\t" "nzl %d, ops %e, wspace %d\n", T2->nfronts, nFactorIndices(T2), nFactorEntries(T2), nFactorOps(T2), nWorkspace(T2)); /* ------------------------ symbolical factorization ------------------------ */ pord_starttimer(t_symb); L = SPACE_symbFac(T2, A); pord_stoptimer(t_symb); if (msglvl > 0) printf("quality of factor matrix:\n\tneqs %d, #indices %d, nzl %d\n", L->css->neqs, L->css->nind, L->nelem); /* ----------------------- numerical factorization ----------------------- */ pord_starttimer(t_num); SPACE_numFac(L, cpusFactor); pord_stoptimer(t_num); if (msglvl > 0) printf("performance of numerical factorization: %6.2f mflops\n", (double)nFactorOps(T2) / t_num / 1000000); /* ------------------------------ solution of triangular systems ------------------------------ */ pord_starttimer(t_solvetri); SPACE_solveTriangular(L, rhs, xvec); pord_stoptimer(t_solvetri); if (msglvl > 0) printf("performance of forward/backward solve: %6.2f mflops\n", (double)nTriangularOps(T2) / t_solvetri / 1000000); freeElimTree(T2); freeFactorMtx(L); /* -------------------------------------------------- pull back timing results, if vector cpus available -------------------------------------------------- */ if (cpus != NULL) { cpus[0] = t_graph; cpus[1] = t_etree_construct; cpus[2] = t_etree_merge; cpus[3] = t_symb; cpus[4] = t_num; cpus[5] = cpusFactor[TIME_INITFRONT]; cpus[6] = cpusFactor[TIME_EXADD]; cpus[7] = cpusFactor[TIME_KERNEL]; cpus[8] = cpusFactor[TIME_INITUPD]; cpus[9] = t_solvetri; } } /***************************************************************************** o Input: graph G with permutation vector perm options -- if NULL, default options are used option[0] holds OPTION_MSGLVL option[1] holds OPTION_ETREE_NONZ option[2] holds OPTION_ETREE_BAL option[3] holds dimension of hypercube o Output: mapping object map cpus -- if NULL, no timing information is pulled back cpus[0] holds time to construct the elimination tree cpus[1] holds time to transform the elimination tree cpus[2] holds time to compute the mapping o Comments: this function can be used to obtain a mapping object for the parallel factorization ******************************************************************************/ mapping_t* SPACE_mapping(graph_t *G, PORD_INT *perm, options_t *options, timings_t *cpus) { mapping_t *map; elimtree_t *T, *T2; timings_t t_etree_construct, t_etree_merge, t_map; options_t default_options[] = { SPACE_MSGLVL, SPACE_ETREE_NONZ, SPACE_ETREE_BAL, 2 }; PORD_INT *invp, i, msglvl, maxzeros, bal, dimQ; /* -------------------------------------------------- set default options, if no other options specified -------------------------------------------------- */ if (options == NULL) options = default_options; msglvl = options[0]; maxzeros = options[1]; bal = options[2]; dimQ = options[3]; /* ---------------- reset all timers ---------------- */ pord_resettimer(t_etree_construct); pord_resettimer(t_etree_merge); pord_resettimer(t_map); /* --------------------------------------------------- construct inital elimination tree according to perm --------------------------------------------------- */ pord_starttimer(t_etree_construct); mymalloc(invp, G->nvtx, PORD_INT); for (i = 0; i < G->nvtx; i++) invp[perm[i]] = i; T = setupElimTree(G, perm, invp); pord_stoptimer(t_etree_construct); free(invp); if (msglvl > 0) printf("quality of initial elim. tree: #fronts %d, #indices %d\n\t" "nzl %d, ops %e, wspace %d\n", T->nfronts, nFactorIndices(T), nFactorEntries(T), nFactorOps(T), nWorkspace(T)); /* ------------------------------- elimination tree transformation ------------------------------- */ pord_starttimer(t_etree_merge); T2 = SPACE_transformElimTree(T, maxzeros); pord_stoptimer(t_etree_merge); freeElimTree(T); if (msglvl > 0) printf("quality of transformed elim. tree: #fronts %d, #indices %d\n\t" "nzl %d, ops %e, wspace %d\n", T2->nfronts, nFactorIndices(T2), nFactorEntries(T2), nFactorOps(T2), nWorkspace(T2)); /* ------------------- compute the mapping ------------------- */ pord_starttimer(t_map); map = setupMapping(T2, dimQ, bal); pord_stoptimer(t_map); /* -------------------------------------------------- pull back timing results, if vector cpus available -------------------------------------------------- */ if (cpus != NULL) { cpus[0] = t_etree_construct; cpus[1] = t_etree_merge; cpus[2] = t_map; } /* -------------------------------------------------------------- return mapping object (don't free T2, since it belongs to map) -------------------------------------------------------------- */ return(map); } #endif MUMPS_5.8.1/PORD/lib/graph.c0000664000175000017500000004031015042446416015221 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: graph.c / / author J"urgen Schulze, University of Paderborn / created 99sep14 / / This file contains functions dealing with the graph object. / ****************************************************************************** Data type: struct graph int nvtx; number of vertices int nedges; number of edges int type; vertices can be UNWEIGTHED or WEIGTHED int totvwght; total vertex weight int *xadj; xadj[u] points to start of u's adjacency list int *adjncy; holds the adjacency lists int *vwght; holds the vertex weights Comments: o no edge weights are stored. In our application weighted graphs re- present compressed unweighted graphs and, therefore, ewght[(u,v)] = vwght[u] * vwght[v]. Methods in lib/graph.c: - G = newGraph(int nvtx, int nedges); o Initial: we assume that G is unweighted, therefore: type = UNWEIGTHED, totvwght = nvtx, and vwght[u] = 1 - void freeGraph(graph_t *G); - void printGraph(graph_t *G); - void randomizeGraph(graph_t *G); - Gsub = setupSubgraph(graph_t *G, int *intvertex, int nvint, int *vtxmap); o extracts the subgraph induced by the vertices in array intvertex from G. vtxmap maps the vertices in intvertex to the vertices of the subgraph. - G = setupGraphFromMtx(inputMtx_t *A); - G = setupGridGraph(int dimX, int dimY, int type); o type e {GRID, MESH, TORUS} - int connectedComponents(graph_t *G); - cG = compressGraph(graph_t *G, int *vtxmap) o cG = NULL, if there are not enough ind. vertices (see COMPRESS_FRACTION) o for u in G vtxmap[u] points to representative of u in cG ******************************************************************************/ #include /***************************************************************************** ******************************************************************************/ graph_t* newGraph(PORD_INT nvtx, PORD_INT nedges) { graph_t *G; PORD_INT i; mymalloc(G, 1, graph_t); mymalloc(G->xadj, (nvtx+1), PORD_INT); mymalloc(G->adjncy, nedges, PORD_INT); mymalloc(G->vwght, nvtx, PORD_INT); G->nvtx = nvtx; G->nedges = nedges; G->type = UNWEIGHTED; G->totvwght = nvtx; for (i = 0; i < nvtx; i++) G->vwght[i] = 1; return(G); } /***************************************************************************** ******************************************************************************/ void freeGraph(graph_t *G) { free(G->xadj); free(G->adjncy); free(G->vwght); free(G); } /***************************************************************************** ******************************************************************************/ void printGraph(graph_t *G) { PORD_INT count, u, i, istart, istop; printf("\n#vertices %d, #edges %d, type %d, totvwght %d\n", G->nvtx, G->nedges >> 1, G->type, G->totvwght); for (u = 0; u < G->nvtx; u++) { count = 0; printf("--- adjacency list of vertex %d (weight %d):\n", u, G->vwght[u]); istart = G->xadj[u]; istop = G->xadj[u+1]; for (i = istart; i < istop; i++) { printf("%5d", G->adjncy[i]); if ((++count % 16) == 0) printf("\n"); } if ((count % 16) != 0) printf("\n"); } } /***************************************************************************** ******************************************************************************/ void randomizeGraph(graph_t *G) { PORD_INT *xadj, *adjncy, nvtx, u, v, len, j, i, istart, istop; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; for (u = 0; u < nvtx; u++) { istart = xadj[u]; istop = xadj[u+1]; if ((len = istop - istart) > 1) for (i = istart; i < istop; i++) { j = myrandom(len); swap(adjncy[i], adjncy[i+j], v); len--; } } } /***************************************************************************** ******************************************************************************/ graph_t* setupSubgraph(graph_t *G, PORD_INT *intvertex, PORD_INT nvint, PORD_INT *vtxmap) { graph_t *Gsub; PORD_INT *xadj, *adjncy, *vwght, *xadjGsub, *adjncyGsub, *vwghtGsub; PORD_INT nvtx, nedgesGsub, totvwght, u, v, i, j, jstart, jstop, ptr; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; vwght = G->vwght; /* ------------------------------------------------------------- compute number of edges and local indices of vertices in Gsub ------------------------------------------------------------- */ nedgesGsub = 0; for (i = 0; i < nvint; i++) { u = intvertex[i]; if ((u < 0) || (u >= nvtx)) { fprintf(stderr, "\nError in function setupSubgraph\n" " node %d does not belong to graph\n", u); quit(); } jstart = xadj[u]; jstop = xadj[u+1]; for (j = jstart; j < jstop; j++) vtxmap[adjncy[j]] = -1; nedgesGsub += (jstop - jstart); } for (i = 0; i < nvint; i++) { u = intvertex[i]; vtxmap[u] = i; } Gsub = newGraph(nvint, nedgesGsub); xadjGsub = Gsub->xadj; adjncyGsub = Gsub->adjncy; vwghtGsub = Gsub->vwght; /* -------------------------- build the induced subgraph -------------------------- */ totvwght = 0; ptr = 0; for (i = 0; i < nvint; i++) { u = intvertex[i]; xadjGsub[i] = ptr; vwghtGsub[i] = vwght[u]; totvwght += vwght[u]; jstart = xadj[u]; jstop = xadj[u+1]; for (j = jstart; j < jstop; j++) { v = adjncy[j]; if (vtxmap[v] >= 0) adjncyGsub[ptr++] = vtxmap[v]; } } xadjGsub[nvint] = ptr; Gsub->type = G->type; Gsub->totvwght = totvwght; return(Gsub); } /***************************************************************************** ******************************************************************************/ graph_t* setupGraphFromMtx(inputMtx_t *A) { graph_t *G; PORD_INT *xnza, *nzasub, *xadj, *adjncy; PORD_INT neqs, nelem, nvtx, k, h1, h2, j, i, istart, istop; neqs = A->neqs; nelem = A->nelem; xnza = A->xnza; nzasub = A->nzasub; /* ------------------------------------ allocate memory for unweighted graph ------------------------------------ */ G = newGraph(neqs, 2*nelem); nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; /* ----------------------------------------- determine the size of each adjacency list ----------------------------------------- */ for (k = 0; k < neqs; k++) xadj[k] = xnza[k+1] - xnza[k]; for (k = 0; k < nelem; k++) xadj[nzasub[k]]++; /* ------------------------------------------------------------- determine for each vertex where its adjacency list will start ------------------------------------------------------------- */ h1 = xadj[0]; xadj[0] = 0; for (k = 1; k <= nvtx; k++) { h2 = xadj[k]; xadj[k] = xadj[k-1] + h1; h1 = h2; } /* ------------------------ fill the adjacency lists ------------------------ */ for (k = 0; k < neqs; k++) { istart = xnza[k]; istop = xnza[k+1]; for (i = istart; i < istop; i++) { j = nzasub[i]; adjncy[xadj[k]++] = j; /* store {k,j} in adjacency list of k */ adjncy[xadj[j]++] = k; /* store {j,k} in adjacency list of j */ } } /* -------------------------------------------- restore startpoint of each vertex and return -------------------------------------------- */ for (k = nvtx-1; k > 0; k--) xadj[k] = xadj[k-1]; xadj[0] = 0; return(G); } /***************************************************************************** ******************************************************************************/ graph_t* setupGridGraph(PORD_INT dimX, PORD_INT dimY, PORD_INT type) { graph_t *G; PORD_INT *xadj, *adjncy, nvtx, nedges, knz, k; /* --------------- initializations --------------- */ G = NULL; knz = 0; nvtx = dimX * dimY; /* --------------------------------- create unweighted grid/mesh graph --------------------------------- */ if ((type == GRID) || (type == MESH)) { nedges = 8 /* for edge vertices */ + 6 * (dimX-2 + dimY-2) /* for border vertices */ + 4 * (dimX-2) * (dimY-2); /* for interior vertices */ if (type == MESH) nedges += 4 * (dimX-1) * (dimY-1); /* diagonals */ G = newGraph(nvtx, nedges); xadj = G->xadj; adjncy = G->adjncy; for (k = 0; k < nvtx; k++) { xadj[k] = knz; if ((k+1) % dimX > 0) /* / k+1-dimX (MESH) */ { adjncy[knz++] = k+1; /* k - k+1 (GRID) */ if (type == MESH) /* \ k+1+dimX (MESH) */ { if (k+1+dimX < nvtx) adjncy[knz++] = k+1+dimX; if (k+1-dimX >= 0) adjncy[knz++] = k+1-dimX; } } if (k % dimX > 0) /* k-1-dimX \ (MESH) */ { adjncy[knz++] = k-1; /* k-1 - k (GRID) */ if (type == MESH) /* k-1+dimX / (MESH) */ { if (k-1+dimX < nvtx) adjncy[knz++] = k-1+dimX; if (k-1-dimX >= 0) adjncy[knz++] = k-1-dimX; } } if (k+dimX < nvtx) /* k-dimX (GRID) */ adjncy[knz++] = k+dimX; /* | */ if (k-dimX >= 0) /* k */ adjncy[knz++] = k-dimX; /* | */ } /* k+dimX (GRID) */ xadj[nvtx] = knz; } /* ----------------------------- create unweighted torus graph ----------------------------- */ if (type == TORUS) { nedges = 4 * dimX * dimY; G = newGraph(nvtx, nedges); xadj = G->xadj; adjncy = G->adjncy; for (k = 0; k < nvtx; k++) { xadj[k] = knz; if (((k+1) % dimX) == 0) /* k -- k+1 */ adjncy[knz++] = k+1-dimX; else adjncy[knz++] = k+1; if ((k % dimX) == 0) /* k-1 -- k */ adjncy[knz++] = k-1+dimX; else adjncy[knz++] = k-1; adjncy[knz++] = (k+dimX) % nvtx; /* k-dimX */ adjncy[knz++] = (k+dimX*(dimY-1)) % nvtx; /* | */ } /* k */ xadj[nvtx] = knz; /* | */ } /* k+dimX */ return(G); } /***************************************************************************** ******************************************************************************/ PORD_INT connectedComponents(graph_t *G) { PORD_INT *xadj, *adjncy, *marker, *queue; PORD_INT nvtx, u, v, w, qhead, qtail, comp, i, istart, istop; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; /* ------------------------ allocate working storage ------------------------ */ mymalloc(marker, nvtx, PORD_INT); mymalloc(queue, nvtx, PORD_INT); /* --------------- initializations --------------- */ comp = 0; for (u = 0; u < nvtx; u++) marker[u] = -1; /* -------------------------------------- get the number of connected components -------------------------------------- */ for (u = 0; u < nvtx; u++) if (marker[u] == -1) { comp++; qhead = 0; qtail = 1; queue[0] = u; marker[u] = 0; while (qhead != qtail) /* breadth first search in each comp. */ { v = queue[qhead++]; istart = xadj[v]; istop = xadj[v+1]; for (i = istart; i < istop; i++) { w = adjncy[i]; if (marker[w] == -1) { queue[qtail++] = w; marker[w] = 0; } } } } /* ------------------------------- free working storage and return ------------------------------- */ free(marker); free(queue); return(comp); } /***************************************************************************** private function of compressGraph ******************************************************************************/ static PORD_INT indNodes(graph_t *G, PORD_INT *vtxmap) { PORD_INT *xadj, *adjncy, *deg, *checksum, *tmp; PORD_INT nvtx, cnvtx, u, v, i, istart, istop, j, jstart, jstop; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; /* ------------------------- set up the working arrays ------------------------- */ mymalloc(deg, nvtx, PORD_INT); mymalloc(checksum, nvtx, PORD_INT); mymalloc(tmp, nvtx, PORD_INT); /* ------------------------------------------------- compute for each vertex u its degree and checksum ------------------------------------------------- */ for (u = 0; u < nvtx; u++) { istart = xadj[u]; istop = xadj[u+1]; deg[u] = istop - istart; checksum[u] = u; tmp[u] = -1; vtxmap[u] = u; for (i = istart; i < istop; i++) checksum[u] += adjncy[i]; } /* ------------------------------------- search for indistinguishable vertices ------------------------------------- */ cnvtx = nvtx; for (u = 0; u < nvtx; u++) if (vtxmap[u] == u) { tmp[u] = u; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) tmp[adjncy[i]] = u; /* scan adjacency list of vertex u for indistinguishable vertices */ for (i = istart; i < istop; i++) { v = adjncy[i]; if ((v > u) && (checksum[v] == checksum[u]) && (deg[v] == deg[u]) && (vtxmap[v] == v)) { jstart = xadj[v]; jstop = xadj[v+1]; for (j = jstart; j < jstop; j++) if (tmp[adjncy[j]] != u) goto FAILURE; /* found it!!! map v onto u */ vtxmap[v] = u; cnvtx--; FAILURE: ; } } } /* ---------------------- free memory and return ---------------------- */ free(deg); free(checksum); free(tmp); return(cnvtx); } /***************************************************************************** ******************************************************************************/ graph_t* compressGraph(graph_t* G, PORD_INT* vtxmap) { graph_t *Gc; PORD_INT *xadj, *adjncy, *vwght, *xadjGc, *adjncyGc, *vwghtGc, *perm; PORD_INT nvtx, nvtxGc, nedgesGc, u, v, i, istart, istop; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; vwght = G->vwght; /* -------------------------------------------------------------- compressed graph small enough? if so, allocate working storage -------------------------------------------------------------- */ /* avoid print statement * printf("indNodes(G, vtxmap) = %d",indNodes(G, vtxmap)); */ if ((nvtxGc = indNodes(G, vtxmap)) > COMPRESS_FRACTION * nvtx) return(NULL); mymalloc(perm, nvtx, PORD_INT); /* ----------------------------------- count edges of the compressed graph ----------------------------------- */ nedgesGc = 0; for (u = 0; u < nvtx; u++) if (vtxmap[u] == u) { istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; if (vtxmap[v] == v) nedgesGc++; } } /* --------------------------------------------------------- allocate memory for the compressed graph and construct it --------------------------------------------------------- */ Gc = newGraph(nvtxGc, nedgesGc); xadjGc = Gc->xadj; adjncyGc = Gc->adjncy; vwghtGc = Gc->vwght; nvtxGc = nedgesGc = 0; for (u = 0; u < nvtx; u++) if (vtxmap[u] == u) { istart = xadj[u]; istop = xadj[u+1]; xadjGc[nvtxGc] = nedgesGc; vwghtGc[nvtxGc] = 0; perm[u] = nvtxGc++; for (i = istart; i < istop; i++) { v = adjncy[i]; if (vtxmap[v] == v) adjncyGc[nedgesGc++] = v; } } xadjGc[nvtxGc] = nedgesGc; for (i = 0; i < nedgesGc; i++) adjncyGc[i] = perm[adjncyGc[i]]; for (u = 0; u < nvtx; u++) { vtxmap[u] = perm[vtxmap[u]]; vwghtGc[vtxmap[u]] += vwght[u]; } Gc->type = WEIGHTED; Gc->totvwght = G->totvwght; /* ---------------------- free memory and return ---------------------- */ free(perm); return(Gc); } MUMPS_5.8.1/PORD/lib/bucket.c0000664000175000017500000002006615042446416015403 0ustar amestoyamestoy/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: bucket.c / / author J"urgen Schulze, University of Paderborn / created 12/06/00 / / This file contains functions dealing with buckets. / ****************************************************************************** Data type: struct bucket int maxbin; maximal bin in bucket int maxitem; maximal item that can be stored in bucket int offset; to store items with negative key-value int nobj; number of items in bucket int minbin; leftmost non-empty bin int *bin; there are maxbin+1 bins (bin[0]...bin[maxbin]) int *next; next[item] points to next item in bin int *last; last[item] points to previous item in bin int *key; holds key of item (MAX_INT if item not in bucket) Comments: o Any implementation of a bucket should enable insert/remove operations in constant time o There a two special bins: bin[0] contains all items u with key[u] + offset < 0 bin[maxbin] contains all items u with key[u] + offset > maxbin Methods in lib/bucket.c: - bucket = newBucket(int maxbin, int maxitem, int offset); o Initial: nobj = 0 and minbin = MAX_INT - void freeBucket(bucket_t *bucket); - bucket = setupBucket(int maxbin, int maxitem, int offset); o allocates memory for the bucket by calling newBucket and initializes the vectors, i.e. bin[i] = -1 for all 0 <= i <= maxbin, next[u] = last[u] = -1, and key[u] = MAX_INT for all 0 <= u <= maxitem - int minBucket(bucket_t *bucket); o returns the item whose key-value is minimal; this item is stored in bin[minbin]; if minbin = 0 or minbin = maxbin, the whole bin must be searched, since the items stored herein may have different keys o if nobj = 0, the function returns -1 - void insertBucket(bucket_t *bucket, int k, int item); o insert item with key k in bucket; if key[item] != MAX_INT (i.e. item already in bucket) or if item > maxitem the program terminates - void removeBucket(bucket_t *bucket, int item); o removes item from bucket; if key[item] == MAX_INT (i.e. item not in bucket) the program terminates ******************************************************************************/ #include /****************************************************************************** ******************************************************************************/ bucket_t* newBucket(PORD_INT maxbin, PORD_INT maxitem, PORD_INT offset) { bucket_t *bucket; mymalloc(bucket, 1, bucket_t); mymalloc(bucket->bin, (maxbin+1), PORD_INT); mymalloc(bucket->next, (maxitem+1), PORD_INT); mymalloc(bucket->last, (maxitem+1), PORD_INT); mymalloc(bucket->key, (maxitem+1), PORD_INT); bucket->maxbin = maxbin; bucket->maxitem = maxitem; bucket->offset = offset; bucket->nobj = 0; bucket->minbin = MAX_INT; return(bucket); } /****************************************************************************** ******************************************************************************/ void freeBucket(bucket_t *bucket) { free(bucket->bin); free(bucket->next); free(bucket->last); free(bucket->key); free(bucket); } /****************************************************************************** ******************************************************************************/ bucket_t* setupBucket(PORD_INT maxbin, PORD_INT maxitem, PORD_INT offset) { bucket_t *bucket; PORD_INT i, u; if (offset < 0) { fprintf(stderr, "\nError in function setupBucket\n" " offset must be >= 0\n"); quit(); } bucket = newBucket(maxbin, maxitem, offset); for (i = 0; i <= maxbin; i++) bucket->bin[i] = -1; for (u = 0; u <= maxitem; u++) { bucket->next[u] = bucket->last[u] = -1; bucket->key[u] = MAX_INT; } return(bucket); } /****************************************************************************** ******************************************************************************/ PORD_INT minBucket(bucket_t *bucket) { PORD_INT *bin, *next, *key, maxbin, minbin, nobj; PORD_INT item, bestitem, bestkey; maxbin = bucket->maxbin; nobj = bucket->nobj; minbin = bucket->minbin; bin = bucket->bin; next = bucket->next; key = bucket->key; if (nobj > 0) { /* --------------------------------------------- get the first item from leftmost nonempty bin --------------------------------------------- */ while (bin[minbin] == -1) minbin++; bucket->minbin = minbin; bestitem = bin[minbin]; bestkey = minbin; /* -------------------------------------------------- items in bins 0 and maxbin can have different keys => search for item with smallest key -------------------------------------------------- */ if ((minbin == 0) || (minbin == maxbin)) { item = next[bestitem]; while (item != -1) { if (key[item] < bestkey) { bestitem = item; bestkey = key[item]; } item = next[item]; } } /* --------------------------------- return the item with smallest key --------------------------------- */ return(bestitem); } else return(-1); } /****************************************************************************** ******************************************************************************/ void insertBucket(bucket_t *bucket, PORD_INT k, PORD_INT item) { PORD_INT s, nextitem; /* ------------------------------------ check whether there are any problems ------------------------------------ */ if (abs(k) >= MAX_INT - bucket->offset - 1) { fprintf(stderr, "\nError in function insertBucket\n" " key %d too large/small for bucket\n", k); quit(); } if (item > bucket->maxitem) { fprintf(stderr, "\nError in function insertBucket\n" " item %d too large for bucket (maxitem is %d)\n", item, bucket->maxitem); quit(); } if (bucket->key[item] != MAX_INT) { fprintf(stderr, "\nError in function insertBucket\n" " item %d already in bucket\n", item); quit(); } /* ------------------------------------- determine the bin that holds the item ------------------------------------- */ s = max(0, (k + bucket->offset)); s = min(s, bucket->maxbin); /* -------------------------------------------------------------- adjust minbin, increase nobj, and mark item as being in bucket -------------------------------------------------------------- */ bucket->minbin = min(bucket->minbin, s); bucket->nobj++; bucket->key[item] = k; /* ----------------------------- finally, insert item in bin s ----------------------------- */ nextitem = bucket->bin[s]; if (nextitem != -1) bucket->last[nextitem] = item; bucket->next[item] = nextitem; bucket->last[item] = -1; bucket->bin[s] = item; } /****************************************************************************** ******************************************************************************/ void removeBucket(bucket_t *bucket, PORD_INT item) { PORD_INT s, nextitem, lastitem; /* ---------------------------- check whether item in bucket ---------------------------- */ if (bucket->key[item] == MAX_INT) { fprintf(stderr, "\nError in function removeBucket\n" " item %d is not in bucket\n", item); quit(); } /* ----------------------- remove item from bucket ----------------------- */ nextitem = bucket->next[item]; lastitem = bucket->last[item]; if (nextitem != -1) bucket->last[nextitem] = lastitem; if (lastitem != -1) bucket->next[lastitem] = nextitem; else { s = max(0, (bucket->key[item] + bucket->offset)); s = min(s, bucket->maxbin); bucket->bin[s] = nextitem; } /* -------------------------------------------- decrease nobj and mark item as being removed -------------------------------------------- */ bucket->nobj--; bucket->key[item] = MAX_INT; } MUMPS_5.8.1/examples/0000775000175000017500000000000015042446422014257 5ustar amestoyamestoyMUMPS_5.8.1/examples/ssimpletest.F0000664000175000017500000000472215042446422016747 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C PROGRAM MUMPS_TEST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'smumps_struc.h' TYPE (SMUMPS_STRUC) mumps_par INTEGER IERR, I INTEGER(8) I8 CALL MPI_INIT(IERR) C Define a communicator for the package. mumps_par%COMM = MPI_COMM_WORLD C Initialize an instance of the package C for L U factorization (sym = 0, with working host) mumps_par%JOB = -1 mumps_par%SYM = 0 mumps_par%PAR = 1 CALL SMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF C Define problem on the host (processor 0) IF ( mumps_par%MYID .eq. 0 ) THEN READ(5,*) mumps_par%N READ(5,*) mumps_par%NNZ ALLOCATE( mumps_par%IRN ( mumps_par%NNZ ) ) ALLOCATE( mumps_par%JCN ( mumps_par%NNZ ) ) ALLOCATE( mumps_par%A( mumps_par%NNZ ) ) ALLOCATE( mumps_par%RHS ( mumps_par%N ) ) DO I8 = 1, mumps_par%NNZ READ(5,*) mumps_par%IRN(I8),mumps_par%JCN(I8),mumps_par%A(I8) END DO DO I = 1, mumps_par%N READ(5,*) mumps_par%RHS(I) END DO END IF C Call package for solution mumps_par%JOB = 6 CALL SMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF C Solution has been assembled on the host IF ( mumps_par%MYID .eq. 0 ) THEN WRITE( 6, * ) ' Solution is ',(mumps_par%RHS(I),I=1,mumps_par%N) END IF C Deallocate user data IF ( mumps_par%MYID .eq. 0 )THEN DEALLOCATE( mumps_par%IRN ) DEALLOCATE( mumps_par%JCN ) DEALLOCATE( mumps_par%A ) DEALLOCATE( mumps_par%RHS ) END IF C Destroy the instance (deallocate internal data structures) mumps_par%JOB = -2 CALL SMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF 500 CALL MPI_FINALIZE(IERR) STOP END MUMPS_5.8.1/examples/multiple_arithmetics_example.F0000664000175000017500000000753115042446422022336 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C PROGRAM MUMPS_MULTIPLE_ARITHMETICS_TEST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'smumps_struc.h' INCLUDE 'dmumps_struc.h' INCLUDE 'cmumps_struc.h' INCLUDE 'zmumps_struc.h' TYPE (SMUMPS_STRUC) smumps_par TYPE (DMUMPS_STRUC) dmumps_par TYPE (CMUMPS_STRUC) cmumps_par TYPE (ZMUMPS_STRUC) zmumps_par INTEGER IERR CALL MPI_INIT(IERR) C Define a communicator for the packages. smumps_par%COMM = MPI_COMM_WORLD dmumps_par%COMM = smumps_par%COMM cmumps_par%COMM = smumps_par%COMM zmumps_par%COMM = smumps_par%COMM C Initialize all instances of the package C for L U factorization (sym = 0, with working host) smumps_par%JOB = -1 smumps_par%SYM = 0 smumps_par%PAR = 1 CALL SMUMPS(smumps_par) IF (smumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " smumps_par%INFOG(1)= ", smumps_par%INFOG(1), & " smumps_par%INFOG(2)= ", smumps_par%INFOG(2) GOTO 500 END IF dmumps_par%JOB = smumps_par%JOB dmumps_par%SYM = smumps_par%SYM dmumps_par%PAR = smumps_par%PAR cmumps_par%JOB = smumps_par%JOB cmumps_par%SYM = smumps_par%SYM cmumps_par%PAR = smumps_par%PAR zmumps_par%JOB = smumps_par%JOB zmumps_par%SYM = smumps_par%SYM zmumps_par%PAR = smumps_par%PAR CALL DMUMPS(dmumps_par) IF (dmumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " dmumps_par%INFOG(1)= ", dmumps_par%INFOG(1), & " dmumps_par%INFOG(2)= ", dmumps_par%INFOG(2) GOTO 500 END IF CALL CMUMPS(cmumps_par) IF (cmumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " cmumps_par%INFOG(1)= ", cmumps_par%INFOG(1), & " cmumps_par%INFOG(2)= ", cmumps_par%INFOG(2) GOTO 500 END IF CALL ZMUMPS(zmumps_par) IF (zmumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " zmumps_par%INFOG(1)= ", zmumps_par%INFOG(1), & " zmumps_par%INFOG(2)= ", zmumps_par%INFOG(2) GOTO 500 END IF IF ( smumps_par%MYID .eq. 0 )THEN write(6,'(A)') "Creation of all instances went well" ENDIF C Destroy the instances (deallocate internal data structures) smumps_par%JOB = -2 CALL SMUMPS(smumps_par) IF (smumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " smumps_par%INFOG(1)= ", smumps_par%INFOG(1), & " smumps_par%INFOG(2)= ", smumps_par%INFOG(2) GOTO 500 END IF dmumps_par%JOB = smumps_par%JOB cmumps_par%JOB = smumps_par%JOB zmumps_par%JOB = smumps_par%JOB CALL DMUMPS(dmumps_par) IF (dmumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " dmumps_par%INFOG(1)= ", dmumps_par%INFOG(1), & " dmumps_par%INFOG(2)= ", dmumps_par%INFOG(2) GOTO 500 END IF CALL CMUMPS(cmumps_par) IF (cmumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " cmumps_par%INFOG(1)= ", cmumps_par%INFOG(1), & " cmumps_par%INFOG(2)= ", cmumps_par%INFOG(2) GOTO 500 END IF CALL ZMUMPS(zmumps_par) IF (zmumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " zmumps_par%INFOG(1)= ", zmumps_par%INFOG(1), & " zmumps_par%INFOG(2)= ", zmumps_par%INFOG(2) GOTO 500 END IF 500 CALL MPI_FINALIZE(IERR) STOP END PROGRAM MUMPS_MULTIPLE_ARITHMETICS_TEST MUMPS_5.8.1/examples/csimpletest.F0000664000175000017500000000472215042446422016727 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C PROGRAM MUMPS_TEST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'cmumps_struc.h' TYPE (CMUMPS_STRUC) mumps_par INTEGER IERR, I INTEGER(8) I8 CALL MPI_INIT(IERR) C Define a communicator for the package. mumps_par%COMM = MPI_COMM_WORLD C Initialize an instance of the package C for L U factorization (sym = 0, with working host) mumps_par%JOB = -1 mumps_par%SYM = 0 mumps_par%PAR = 1 CALL CMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF C Define problem on the host (processor 0) IF ( mumps_par%MYID .eq. 0 ) THEN READ(5,*) mumps_par%N READ(5,*) mumps_par%NNZ ALLOCATE( mumps_par%IRN ( mumps_par%NNZ ) ) ALLOCATE( mumps_par%JCN ( mumps_par%NNZ ) ) ALLOCATE( mumps_par%A( mumps_par%NNZ ) ) ALLOCATE( mumps_par%RHS ( mumps_par%N ) ) DO I8 = 1, mumps_par%NNZ READ(5,*) mumps_par%IRN(I8),mumps_par%JCN(I8),mumps_par%A(I8) END DO DO I = 1, mumps_par%N READ(5,*) mumps_par%RHS(I) END DO END IF C Call package for solution mumps_par%JOB = 6 CALL CMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF C Solution has been assembled on the host IF ( mumps_par%MYID .eq. 0 ) THEN WRITE( 6, * ) ' Solution is ',(mumps_par%RHS(I),I=1,mumps_par%N) END IF C Deallocate user data IF ( mumps_par%MYID .eq. 0 )THEN DEALLOCATE( mumps_par%IRN ) DEALLOCATE( mumps_par%JCN ) DEALLOCATE( mumps_par%A ) DEALLOCATE( mumps_par%RHS ) END IF C Destroy the instance (deallocate internal data structures) mumps_par%JOB = -2 CALL CMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF 500 CALL MPI_FINALIZE(IERR) STOP END MUMPS_5.8.1/examples/csimpletest_save_restore.F0000664000175000017500000001217315042446422021507 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C PROGRAM MUMPS_TEST_SAVE_RESTORE IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'cmumps_struc.h' TYPE (CMUMPS_STRUC) mumps_par_save, mumps_par_restore INTEGER IERR, I CALL MPI_INIT(IERR) C Define a communicator for the package. mumps_par_save%COMM = MPI_COMM_WORLD C Initialize an instance of the package C for L U factorization (sym = 0, with working host) mumps_par_save%JOB = -1 mumps_par_save%SYM = 0 mumps_par_save%PAR = 1 CALL CMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Define problem on the host (processor 0) IF ( mumps_par_save%MYID .eq. 0 ) THEN READ(5,*) mumps_par_save%N READ(5,*) mumps_par_save%NZ ALLOCATE( mumps_par_save%IRN ( mumps_par_save%NZ ) ) ALLOCATE( mumps_par_save%JCN ( mumps_par_save%NZ ) ) ALLOCATE( mumps_par_save%A( mumps_par_save%NZ ) ) DO I = 1, mumps_par_save%NZ READ(5,*) mumps_par_save%IRN(I),mumps_par_save%JCN(I) & ,mumps_par_save%A(I) END DO END IF C Activate OOC mumps_par_save%ICNTL(22)=1 C Call package for factorization mumps_par_save%JOB = 4 CALL CMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Call package for save mumps_par_save%JOB = 7 mumps_par_save%SAVE_DIR="/tmp" mumps_par_save%SAVE_PREFIX="mumps_simpletest_save" CALL CMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Deallocate user data IF ( mumps_par_save%MYID .eq. 0 )THEN DEALLOCATE( mumps_par_save%IRN ) DEALLOCATE( mumps_par_save%JCN ) DEALLOCATE( mumps_par_save%A ) END IF C Destroy the instance (deallocate internal data structures) mumps_par_save%JOB = -2 CALL CMUMPS(mumps_par_save) C Now mumps_par_save has be destroyed C We use a new instance mumps_par_restore to finish the computation C Define a communicator for the package on the new instance. mumps_par_restore%COMM = MPI_COMM_WORLD C Initialize a new instance of the package C for L U factorization (sym = 0, with working host) mumps_par_restore%JOB = -1 mumps_par_restore%SYM = 0 mumps_par_restore%PAR = 1 CALL CMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Call package for restore with OOC feature mumps_par_restore%JOB = 8 mumps_par_restore%SAVE_DIR="/tmp" mumps_par_restore%SAVE_PREFIX="mumps_simpletest_save" CALL CMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Define rhs on the host (processor 0) IF ( mumps_par_restore%MYID .eq. 0 ) THEN ALLOCATE( mumps_par_restore%RHS ( mumps_par_restore%N ) ) DO I = 1, mumps_par_restore%N READ(5,*) mumps_par_restore%RHS(I) END DO END IF C Call package for solution mumps_par_restore%JOB = 3 CALL CMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Solution has been assembled on the host IF ( mumps_par_restore%MYID .eq. 0 ) THEN WRITE( 6, * ) ' Solution is ', & (mumps_par_restore%RHS(I),I=1,mumps_par_restore%N) END IF C Deallocate user data IF ( mumps_par_restore%MYID .eq. 0 )THEN DEALLOCATE( mumps_par_restore%RHS ) END IF C Delete the saved files C Note mumps_par_restore%ICNTL(34) is kept to default (0) to suppress C also the OOC files. mumps_par_restore%JOB = -3 CALL CMUMPS(mumps_par_restore) C Destroy the instance (deallocate internal data structures) mumps_par_restore%JOB = -2 CALL CMUMPS(mumps_par_restore) 500 CALL MPI_FINALIZE(IERR) STOP END MUMPS_5.8.1/examples/zsimpletest_save_restore.F0000664000175000017500000001217315042446422021536 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C PROGRAM MUMPS_TEST_SAVE_RESTORE IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'zmumps_struc.h' TYPE (ZMUMPS_STRUC) mumps_par_save, mumps_par_restore INTEGER IERR, I CALL MPI_INIT(IERR) C Define a communicator for the package. mumps_par_save%COMM = MPI_COMM_WORLD C Initialize an instance of the package C for L U factorization (sym = 0, with working host) mumps_par_save%JOB = -1 mumps_par_save%SYM = 0 mumps_par_save%PAR = 1 CALL ZMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Define problem on the host (processor 0) IF ( mumps_par_save%MYID .eq. 0 ) THEN READ(5,*) mumps_par_save%N READ(5,*) mumps_par_save%NZ ALLOCATE( mumps_par_save%IRN ( mumps_par_save%NZ ) ) ALLOCATE( mumps_par_save%JCN ( mumps_par_save%NZ ) ) ALLOCATE( mumps_par_save%A( mumps_par_save%NZ ) ) DO I = 1, mumps_par_save%NZ READ(5,*) mumps_par_save%IRN(I),mumps_par_save%JCN(I) & ,mumps_par_save%A(I) END DO END IF C Activate OOC mumps_par_save%ICNTL(22)=1 C Call package for factorization mumps_par_save%JOB = 4 CALL ZMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Call package for save mumps_par_save%JOB = 7 mumps_par_save%SAVE_DIR="/tmp" mumps_par_save%SAVE_PREFIX="mumps_simpletest_save" CALL ZMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Deallocate user data IF ( mumps_par_save%MYID .eq. 0 )THEN DEALLOCATE( mumps_par_save%IRN ) DEALLOCATE( mumps_par_save%JCN ) DEALLOCATE( mumps_par_save%A ) END IF C Destroy the instance (deallocate internal data structures) mumps_par_save%JOB = -2 CALL ZMUMPS(mumps_par_save) C Now mumps_par_save has be destroyed C We use a new instance mumps_par_restore to finish the computation C Define a communicator for the package on the new instance. mumps_par_restore%COMM = MPI_COMM_WORLD C Initialize a new instance of the package C for L U factorization (sym = 0, with working host) mumps_par_restore%JOB = -1 mumps_par_restore%SYM = 0 mumps_par_restore%PAR = 1 CALL ZMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Call package for restore with OOC feature mumps_par_restore%JOB = 8 mumps_par_restore%SAVE_DIR="/tmp" mumps_par_restore%SAVE_PREFIX="mumps_simpletest_save" CALL ZMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Define rhs on the host (processor 0) IF ( mumps_par_restore%MYID .eq. 0 ) THEN ALLOCATE( mumps_par_restore%RHS ( mumps_par_restore%N ) ) DO I = 1, mumps_par_restore%N READ(5,*) mumps_par_restore%RHS(I) END DO END IF C Call package for solution mumps_par_restore%JOB = 3 CALL ZMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Solution has been assembled on the host IF ( mumps_par_restore%MYID .eq. 0 ) THEN WRITE( 6, * ) ' Solution is ', & (mumps_par_restore%RHS(I),I=1,mumps_par_restore%N) END IF C Deallocate user data IF ( mumps_par_restore%MYID .eq. 0 )THEN DEALLOCATE( mumps_par_restore%RHS ) END IF C Delete the saved files C Note mumps_par_restore%ICNTL(34) is kept to default (0) to suppress C also the OOC files. mumps_par_restore%JOB = -3 CALL ZMUMPS(mumps_par_restore) C Destroy the instance (deallocate internal data structures) mumps_par_restore%JOB = -2 CALL ZMUMPS(mumps_par_restore) 500 CALL MPI_FINALIZE(IERR) STOP END MUMPS_5.8.1/examples/dsimpletest.F0000664000175000017500000000472215042446422016730 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C PROGRAM MUMPS_TEST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'dmumps_struc.h' TYPE (DMUMPS_STRUC) mumps_par INTEGER IERR, I INTEGER(8) I8 CALL MPI_INIT(IERR) C Define a communicator for the package. mumps_par%COMM = MPI_COMM_WORLD C Initialize an instance of the package C for L U factorization (sym = 0, with working host) mumps_par%JOB = -1 mumps_par%SYM = 0 mumps_par%PAR = 1 CALL DMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF C Define problem on the host (processor 0) IF ( mumps_par%MYID .eq. 0 ) THEN READ(5,*) mumps_par%N READ(5,*) mumps_par%NNZ ALLOCATE( mumps_par%IRN ( mumps_par%NNZ ) ) ALLOCATE( mumps_par%JCN ( mumps_par%NNZ ) ) ALLOCATE( mumps_par%A( mumps_par%NNZ ) ) ALLOCATE( mumps_par%RHS ( mumps_par%N ) ) DO I8 = 1, mumps_par%NNZ READ(5,*) mumps_par%IRN(I8),mumps_par%JCN(I8),mumps_par%A(I8) END DO DO I = 1, mumps_par%N READ(5,*) mumps_par%RHS(I) END DO END IF C Call package for solution mumps_par%JOB = 6 CALL DMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF C Solution has been assembled on the host IF ( mumps_par%MYID .eq. 0 ) THEN WRITE( 6, * ) ' Solution is ',(mumps_par%RHS(I),I=1,mumps_par%N) END IF C Deallocate user data IF ( mumps_par%MYID .eq. 0 )THEN DEALLOCATE( mumps_par%IRN ) DEALLOCATE( mumps_par%JCN ) DEALLOCATE( mumps_par%A ) DEALLOCATE( mumps_par%RHS ) END IF C Destroy the instance (deallocate internal data structures) mumps_par%JOB = -2 CALL DMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF 500 CALL MPI_FINALIZE(IERR) STOP END MUMPS_5.8.1/examples/dsimpletest_save_restore.F0000664000175000017500000001217315042446422021510 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C PROGRAM MUMPS_TEST_SAVE_RESTORE IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'dmumps_struc.h' TYPE (DMUMPS_STRUC) mumps_par_save, mumps_par_restore INTEGER IERR, I CALL MPI_INIT(IERR) C Define a communicator for the package. mumps_par_save%COMM = MPI_COMM_WORLD C Initialize an instance of the package C for L U factorization (sym = 0, with working host) mumps_par_save%JOB = -1 mumps_par_save%SYM = 0 mumps_par_save%PAR = 1 CALL DMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Define problem on the host (processor 0) IF ( mumps_par_save%MYID .eq. 0 ) THEN READ(5,*) mumps_par_save%N READ(5,*) mumps_par_save%NZ ALLOCATE( mumps_par_save%IRN ( mumps_par_save%NZ ) ) ALLOCATE( mumps_par_save%JCN ( mumps_par_save%NZ ) ) ALLOCATE( mumps_par_save%A( mumps_par_save%NZ ) ) DO I = 1, mumps_par_save%NZ READ(5,*) mumps_par_save%IRN(I),mumps_par_save%JCN(I) & ,mumps_par_save%A(I) END DO END IF C Activate OOC mumps_par_save%ICNTL(22)=1 C Call package for factorization mumps_par_save%JOB = 4 CALL DMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Call package for save mumps_par_save%JOB = 7 mumps_par_save%SAVE_DIR="/tmp" mumps_par_save%SAVE_PREFIX="mumps_simpletest_save" CALL DMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Deallocate user data IF ( mumps_par_save%MYID .eq. 0 )THEN DEALLOCATE( mumps_par_save%IRN ) DEALLOCATE( mumps_par_save%JCN ) DEALLOCATE( mumps_par_save%A ) END IF C Destroy the instance (deallocate internal data structures) mumps_par_save%JOB = -2 CALL DMUMPS(mumps_par_save) C Now mumps_par_save has be destroyed C We use a new instance mumps_par_restore to finish the computation C Define a communicator for the package on the new instance. mumps_par_restore%COMM = MPI_COMM_WORLD C Initialize a new instance of the package C for L U factorization (sym = 0, with working host) mumps_par_restore%JOB = -1 mumps_par_restore%SYM = 0 mumps_par_restore%PAR = 1 CALL DMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Call package for restore with OOC feature mumps_par_restore%JOB = 8 mumps_par_restore%SAVE_DIR="/tmp" mumps_par_restore%SAVE_PREFIX="mumps_simpletest_save" CALL DMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Define rhs on the host (processor 0) IF ( mumps_par_restore%MYID .eq. 0 ) THEN ALLOCATE( mumps_par_restore%RHS ( mumps_par_restore%N ) ) DO I = 1, mumps_par_restore%N READ(5,*) mumps_par_restore%RHS(I) END DO END IF C Call package for solution mumps_par_restore%JOB = 3 CALL DMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Solution has been assembled on the host IF ( mumps_par_restore%MYID .eq. 0 ) THEN WRITE( 6, * ) ' Solution is ', & (mumps_par_restore%RHS(I),I=1,mumps_par_restore%N) END IF C Deallocate user data IF ( mumps_par_restore%MYID .eq. 0 )THEN DEALLOCATE( mumps_par_restore%RHS ) END IF C Delete the saved files C Note mumps_par_restore%ICNTL(34) is kept to default (0) to suppress C also the OOC files. mumps_par_restore%JOB = -3 CALL DMUMPS(mumps_par_restore) C Destroy the instance (deallocate internal data structures) mumps_par_restore%JOB = -2 CALL DMUMPS(mumps_par_restore) 500 CALL MPI_FINALIZE(IERR) STOP END MUMPS_5.8.1/examples/input_simpletest_cmplx0000664000175000017500000000050215042446422021012 0ustar amestoyamestoy5 : N 12 : NZ 1 2 (3.0,0.0) 2 3 (-3.0,0.0) 4 3 (2.0,0.0) 5 5 (1.0,0.0) 2 1 (3.0,0.0) 1 1 (2.0,0.0) 5 2 (4.0,0.0) 3 4 (2.0,0.0) 2 5 (6.0,0.0) 3 2 (-1.0,0.0) 1 3 (4.0,0.0) 3 3 (1.0,0.0) (20.0,0.0) (24.0,0.0) (9.0,0.0) (6.0,0.0) (13.0,0.0) : RHS MUMPS_5.8.1/examples/ssimpletest_save_restore.F0000664000175000017500000001217315042446422021527 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C PROGRAM MUMPS_TEST_SAVE_RESTORE IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'smumps_struc.h' TYPE (SMUMPS_STRUC) mumps_par_save, mumps_par_restore INTEGER IERR, I CALL MPI_INIT(IERR) C Define a communicator for the package. mumps_par_save%COMM = MPI_COMM_WORLD C Initialize an instance of the package C for L U factorization (sym = 0, with working host) mumps_par_save%JOB = -1 mumps_par_save%SYM = 0 mumps_par_save%PAR = 1 CALL SMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Define problem on the host (processor 0) IF ( mumps_par_save%MYID .eq. 0 ) THEN READ(5,*) mumps_par_save%N READ(5,*) mumps_par_save%NZ ALLOCATE( mumps_par_save%IRN ( mumps_par_save%NZ ) ) ALLOCATE( mumps_par_save%JCN ( mumps_par_save%NZ ) ) ALLOCATE( mumps_par_save%A( mumps_par_save%NZ ) ) DO I = 1, mumps_par_save%NZ READ(5,*) mumps_par_save%IRN(I),mumps_par_save%JCN(I) & ,mumps_par_save%A(I) END DO END IF C Activate OOC mumps_par_save%ICNTL(22)=1 C Call package for factorization mumps_par_save%JOB = 4 CALL SMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Call package for save mumps_par_save%JOB = 7 mumps_par_save%SAVE_DIR="/tmp" mumps_par_save%SAVE_PREFIX="mumps_simpletest_save" CALL SMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Deallocate user data IF ( mumps_par_save%MYID .eq. 0 )THEN DEALLOCATE( mumps_par_save%IRN ) DEALLOCATE( mumps_par_save%JCN ) DEALLOCATE( mumps_par_save%A ) END IF C Destroy the instance (deallocate internal data structures) mumps_par_save%JOB = -2 CALL SMUMPS(mumps_par_save) C Now mumps_par_save has be destroyed C We use a new instance mumps_par_restore to finish the computation C Define a communicator for the package on the new instance. mumps_par_restore%COMM = MPI_COMM_WORLD C Initialize a new instance of the package C for L U factorization (sym = 0, with working host) mumps_par_restore%JOB = -1 mumps_par_restore%SYM = 0 mumps_par_restore%PAR = 1 CALL SMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Call package for restore with OOC feature mumps_par_restore%JOB = 8 mumps_par_restore%SAVE_DIR="/tmp" mumps_par_restore%SAVE_PREFIX="mumps_simpletest_save" CALL SMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Define rhs on the host (processor 0) IF ( mumps_par_restore%MYID .eq. 0 ) THEN ALLOCATE( mumps_par_restore%RHS ( mumps_par_restore%N ) ) DO I = 1, mumps_par_restore%N READ(5,*) mumps_par_restore%RHS(I) END DO END IF C Call package for solution mumps_par_restore%JOB = 3 CALL SMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Solution has been assembled on the host IF ( mumps_par_restore%MYID .eq. 0 ) THEN WRITE( 6, * ) ' Solution is ', & (mumps_par_restore%RHS(I),I=1,mumps_par_restore%N) END IF C Deallocate user data IF ( mumps_par_restore%MYID .eq. 0 )THEN DEALLOCATE( mumps_par_restore%RHS ) END IF C Delete the saved files C Note mumps_par_restore%ICNTL(34) is kept to default (0) to suppress C also the OOC files. mumps_par_restore%JOB = -3 CALL SMUMPS(mumps_par_restore) C Destroy the instance (deallocate internal data structures) mumps_par_restore%JOB = -2 CALL SMUMPS(mumps_par_restore) 500 CALL MPI_FINALIZE(IERR) STOP END MUMPS_5.8.1/examples/Makefile0000664000175000017500000000512215042446422015717 0ustar amestoyamestoy# # This file is part of MUMPS 5.8.1, released # on Wed Jul 30 16:49:18 UTC 2025 # topdir = .. libdir = $(topdir)/lib default: d .PHONY: default all s d c z multi clean .SECONDEXPANSION: all: c z s d multi c: csimpletest csimpletest_save_restore z: zsimpletest zsimpletest_save_restore s: ssimpletest ssimpletest_save_restore d: dsimpletest dsimpletest_save_restore c_example_save_restore c_example multi: multiple_arithmetics_example include $(topdir)/Makefile.inc LIBSMUMPS = -L$(libdir) -lsmumps$(PLAT) -lmumps_common$(PLAT) LIBCMUMPS = -L$(libdir) -lcmumps$(PLAT) -lmumps_common$(PLAT) LIBSDMUMPS = -L$(libdir) -ldmumps$(PLAT) -lsmumps$(PLAT) -lmumps_common$(PLAT) LIBCZMUMPS = -L$(libdir) -lzmumps$(PLAT) -lcmumps$(PLAT) -lmumps_common$(PLAT) ssimpletest: $$@.o $(FL) -o $@ $(OPTL) ssimpletest.o $(LIBSMUMPS) $(LORDERINGS) $(LIBS) $(RPATH_OPT) $(LIBBLAS) $(LIBOTHERS) dsimpletest: $$@.o $(FL) -o $@ $(OPTL) dsimpletest.o $(LIBSDMUMPS) $(LORDERINGS) $(LIBS) $(RPATH_OPT) $(LIBBLAS) $(LIBOTHERS) csimpletest: $$@.o $(FL) -o $@ $(OPTL) csimpletest.o $(LIBCMUMPS) $(LORDERINGS) $(LIBS) $(RPATH_OPT) $(LIBBLAS) $(LIBOTHERS) zsimpletest: $$@.o $(FL) -o $@ $(OPTL) zsimpletest.o $(LIBCZMUMPS) $(LORDERINGS) $(LIBS) $(RPATH_OPT) $(LIBBLAS) $(LIBOTHERS) c_example: $$@.o $(FL) -o $@ $(OPTL) $@.o $(LIBSDMUMPS) $(LORDERINGS) $(LIBS) $(RPATH_OPT) $(LIBBLAS) $(LIBOTHERS) multiple_arithmetics_example: $$@.o $(FL) -o $@ $(OPTL) $@.o $(LIBSDMUMPS) $(LIBCZMUMPS) $(LORDERINGS) $(LIBS) $(RPATH_OPT) $(LIBBLAS) $(LIBOTHERS) ssimpletest_save_restore: $$@.o $(FL) -o $@ $(OPTL) ssimpletest_save_restore.o $(LIBSMUMPS) $(LORDERINGS) $(LIBS) $(LIBBLAS) $(LIBOTHERS) dsimpletest_save_restore: $$@.o $(FL) -o $@ $(OPTL) dsimpletest_save_restore.o $(LIBSDMUMPS) $(LORDERINGS) $(LIBS) $(LIBBLAS) $(LIBOTHERS) csimpletest_save_restore: $$@.o $(FL) -o $@ $(OPTL) csimpletest_save_restore.o $(LIBCMUMPS) $(LORDERINGS) $(LIBS) $(LIBBLAS) $(LIBOTHERS) zsimpletest_save_restore: $$@.o $(FL) -o $@ $(OPTL) zsimpletest_save_restore.o $(LIBCZMUMPS) $(LORDERINGS) $(LIBS) $(LIBBLAS) $(LIBOTHERS) c_example_save_restore: $$@.o $(FL) -o $@ $(OPTL) $@.o $(LIBSDMUMPS) $(LORDERINGS) $(LIBS) $(LIBBLAS) $(LIBOTHERS) .SUFFIXES: .c .F .o .F.o: $(FC) $(OPTF) -I. -I$(topdir)/include -I$(topdir)/src $(INCS) -c $*.F $(OUTF)$*.o .c.o: $(CC) $(OPTC) $(CDEFS) -I. -I$(topdir)/include -I$(topdir)/src $(INCS) -c $*.c $(OUTC)$*.o clean: $(RM) *.o [sdcz]simpletest c_example multiple_arithmetics_example ssimpletest_save_restore dsimpletest_save_restore csimpletest_save_restore zsimpletest_save_restore c_example_save_restore MUMPS_5.8.1/examples/input_simpletest_real0000664000175000017500000000027515042446422020621 0ustar amestoyamestoy5 :N 12 :NZ 1 2 3.0 2 3 -3.0 4 3 2.0 5 5 1.0 2 1 3.0 1 1 2.0 5 2 4.0 3 4 2.0 2 5 6.0 3 2 -1.0 1 3 4.0 3 3 1.0 :values 20.0 24.0 9.0 6.0 13.0 :RHS MUMPS_5.8.1/examples/c_example_save_restore.c0000664000175000017500000001177515042446422021154 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * */ /* Example program using the C interface to the * double real arithmetic version of MUMPS, dmumps_c. * We solve the system A x = RHS with * A = diag(1 2) and RHS = [1 4]^T * Solution is [1 2]^T */ #include #include #include "mpi.h" #include "dmumps_c.h" #define JOB_INIT -1 #define JOB_END -2 #define USE_COMM_WORLD -987654 #if defined(MAIN_COMP) /* * Some Fortran compilers (COMPAQ fort) define "main" in * their runtime library while a Fortran program translates * to MAIN_ or MAIN__ which is then called from "main". * We defined argc/argv arbitrarily in that case. */ int MAIN__(); int MAIN_() { return MAIN__(); } int MAIN__() { int argc=1; char * name = "c_example_save_restore"; char ** argv ; #else int main(int argc, char ** argv) { #endif DMUMPS_STRUC_C id_save,id_restore; MUMPS_INT n = 2; MUMPS_INT8 nnz = 2; MUMPS_INT irn[] = {1,2}; MUMPS_INT jcn[] = {1,2}; double a[2]; double rhs[2]; int error = 0; /* When compiling with -DINTSIZE64, MUMPS_INT is 64-bit but MPI ilp64 versions may still require standard int for C interface. */ /* MUMPS_INT myid, ierr; */ int myid, ierr; #if defined(MAIN_COMP) argv = &name; #endif ierr = MPI_Init(&argc, &argv); ierr = MPI_Comm_rank(MPI_COMM_WORLD, &myid); /* Define A and rhs */ rhs[0]=1.0;rhs[1]=4.0; a[0]=1.0;a[1]=2.0; /* Initialize MUMPS save instance. Use MPI_COMM_WORLD */ id_save.comm_fortran=USE_COMM_WORLD; id_save.par=1; id_save.sym=0; id_save.job=JOB_INIT; dmumps_c(&id_save); /* Define the problem on the host */ if (myid == 0) { id_save.n = n; id_save.nnz =nnz; id_save.irn=irn; id_save.jcn=jcn; id_save.a = a; } #define ICNTL(I) icntl[(I)-1] /* macro s.t. indices match documentation */ /* No outputs */ id_save.ICNTL(1)=-1; id_save.ICNTL(2)=-1; id_save.ICNTL(3)=-1; id_save.ICNTL(4)=0; /* Call the MUMPS package on the save instance (analyse and factorization). */ id_save.job=4; dmumps_c(&id_save); /* MUMPS save feature on the save instance. */ strcpy(id_save.save_prefix,"csave_restore"); strcpy(id_save.save_dir,"/tmp"); if (myid == 0) { printf("Saving MUMPS instance in %s with prefix %s.\n", id_save.save_dir, id_save.save_prefix); } id_save.job=7; dmumps_c(&id_save); if (id_save.infog[0]<0) { printf("\n (PROC %d) ERROR RETURN: \tINFOG(1)= %d\n\t\t\t\tINFOG(2)= %d\n", myid, id_save.infog[0], id_save.infog[1]); error = 1; } else if (myid == 0) { printf(" DONE\n\n"); } /* Terminate the save instance. */ id_save.job=JOB_END; dmumps_c(&id_save); if (!error) { /* Initialize MUMPS restore instance. Use MPI_COMM_WORLD */ id_restore.comm_fortran=USE_COMM_WORLD; id_restore.par=1; id_restore.sym=0; id_restore.job=JOB_INIT; dmumps_c(&id_restore); /* Define the rhs on the host */ if (myid == 0) { id_restore.rhs = rhs; } /* No outputs */ id_save.ICNTL(1)=-1; id_save.ICNTL(2)=-1; id_save.ICNTL(3)=-1; id_save.ICNTL(4)=0; /* MUMPS restore feature on restore instance. */ if (myid == 0) { printf("Restoring MUMPS instance in %s with prefix %s.\n", id_save.save_dir, id_save.save_prefix); } strcpy(id_restore.save_prefix,"csave_restore"); strcpy(id_restore.save_dir,"/tmp"); id_restore.job=8; dmumps_c(&id_restore); if (id_save.infog[0]<0) { printf("\n (PROC %d) ERROR RETURN: \tINFOG(1)= %d\n\t\t\t\tINFOG(2)= %d\n", myid, id_save.infog[0], id_save.infog[1]); error = 1; } else if (myid == 0) { printf(" DONE\n\n"); } } if (!error) { /* Call the MUMPS package on restore instance (solve). */ if (myid == 0) { printf("Calling MUMPS package (solve).\n"); } id_restore.job=3; dmumps_c(&id_restore); if (id_save.infog[0]<0) { printf("=> (PROC %d) ERROR RETURN: \tINFOG(1)= %d\n\t\t\t\tINFOG(2)= %d\n", myid, id_save.infog[0], id_save.infog[1]); error = 1; } else if (myid == 0) { printf(" DONE\n\n"); } /* Deletes the saved and the OOC files. */ if (myid == 0) { printf("Removing save files.\n"); } id_restore.job=-3; dmumps_c(&id_restore); if (id_save.infog[0]<0) { printf("=> (PROC %d) ERROR RETURN: \tINFOG(1)= %d\n\t\t\t\tINFOG(2)= %d\n", myid, id_save.infog[0], id_save.infog[1]); error = 1; } else if (myid == 0) { printf(" DONE\n\n"); } /* Terminate the restore instance. */ id_restore.job=JOB_END; dmumps_c(&id_restore); } if (myid == 0) { if (!error) { printf("Solution is : (%8.2f %8.2f)\n", rhs[0],rhs[1]); } else { printf("An error has occured, please check error code returned by MUMPS.\n"); } } ierr = MPI_Finalize(); return 0; } MUMPS_5.8.1/examples/c_example.c0000664000175000017500000000460415042446422016364 0ustar amestoyamestoy/* * * This file is part of MUMPS 5.8.1, released * on Wed Jul 30 16:49:18 UTC 2025 * */ /* Example program using the C interface to the * double real arithmetic version of MUMPS, dmumps_c. * We solve the system A x = RHS with * A = diag(1 2) and RHS = [1 4]^T * Solution is [1 2]^T */ #include #include #include "mpi.h" #include "dmumps_c.h" #define JOB_INIT -1 #define JOB_END -2 #define USE_COMM_WORLD -987654 #if defined(MAIN_COMP) /* * Some Fortran compilers (COMPAQ fort) define "main" in * their runtime library while a Fortran program translates * to MAIN_ or MAIN__ which is then called from "main". * We defined argc/argv arbitrarily in that case. */ int MAIN__(); int MAIN_() { return MAIN__(); } int MAIN__() { int argc=1; char * name = "c_example"; char ** argv ; #else int main(int argc, char ** argv) { #endif DMUMPS_STRUC_C id; MUMPS_INT n = 2; MUMPS_INT8 nnz = 2; MUMPS_INT irn[] = {1,2}; MUMPS_INT jcn[] = {1,2}; double a[2]; double rhs[2]; /* When compiling with -DINTSIZE64, MUMPS_INT is 64-bit but MPI ilp64 versions normally still require standard int for C */ /* MUMPS_INT myid, ierr; */ int myid, ierr; int error = 0; #if defined(MAIN_COMP) argv = &name; #endif ierr = MPI_Init(&argc, &argv); ierr = MPI_Comm_rank(MPI_COMM_WORLD, &myid); /* Define A and rhs */ rhs[0]=1.0;rhs[1]=4.0; a[0]=1.0;a[1]=2.0; /* Initialize a MUMPS instance. Use MPI_COMM_WORLD */ id.comm_fortran=USE_COMM_WORLD; id.par=1; id.sym=0; id.job=JOB_INIT; dmumps_c(&id); /* Define the problem on the host */ if (myid == 0) { id.n = n; id.nnz =nnz; id.irn=irn; id.jcn=jcn; id.a = a; id.rhs = rhs; } #define ICNTL(I) icntl[(I)-1] /* macro s.t. indices match documentation */ /* No outputs */ id.ICNTL(1)=-1; id.ICNTL(2)=-1; id.ICNTL(3)=-1; id.ICNTL(4)=0; /* Call the MUMPS package (analyse, factorization and solve). */ id.job=6; dmumps_c(&id); if (id.infog[0]<0) { printf(" (PROC %d) ERROR RETURN: \tINFOG(1)= %d\n\t\t\t\tINFOG(2)= %d\n", myid, id.infog[0], id.infog[1]); error = 1; } /* Terminate instance. */ id.job=JOB_END; dmumps_c(&id); if (myid == 0) { if (!error) { printf("Solution is : (%8.2f %8.2f)\n", rhs[0],rhs[1]); } else { printf("An error has occured, please check error code returned by MUMPS.\n"); } } ierr = MPI_Finalize(); return 0; } MUMPS_5.8.1/examples/README0000664000175000017500000000500115042446422015133 0ustar amestoyamestoy * Supposing the MUMPS libraries with appropriate arithmetic have been generated, you may compile the example drivers by typing either make (which defaults to make d) make s make d make c make z make multi or make all * For the small C driver, only an example using double arithmetic is available. Try for example "mpirun -np 3 ./c_example" (parallel version),or "./c_example" (sequential version). The solution should be (1,2) * For multiple instances using different arithmetics, a small example is available in multiple_arithmetics_example.F. Supposing the MUMPS libraries with all arithmetic have been generated, you may compile the example driver by typing : make multi Then try for example: "mpirun -np 3 ./multiple_arithmetics_example" (parallel version), or "./multiple_arithmetics_example" (sequential version). * For the small Fortran driver, 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 Fortran driver using the save/restore feature, see comments in simpletest_save_restore.F and try for example "mpirun -np 2 ./ssimpletest_save_restore < input_simpletest_real" "mpirun -np 2 ./dsimpletest_save_restore < input_simpletest_real" "mpirun -np 2 ./csimpletest_save_restore < input_simpletest_cmplx" "mpirun -np 2 ./zsimpletest_save_restore < input_simpletest_cmplx" if you are using the parallel version of MUMPS, or "./ssimpletest_save_restore < input_simpletest_real" "./dsimpletest_save_restore < input_simpletest_real" "./csimpletest_save_restore < input_simpletest_cmplx" "./zsimpletest_save_restore < input_simpletest_cmplx" if you are using the sequential version. The solution should be (1,2,3,4,5) * For the small C driver using the save/restore feature, only an example using double arithmetic is available. Try for example "mpirun -np 3 ./c_example_save_restore" (parallel version),or "./c_example_save_restore" (sequential version). The solution should be (1,2) MUMPS_5.8.1/examples/zsimpletest.F0000664000175000017500000000472215042446422016756 0ustar amestoyamestoyC C This file is part of MUMPS 5.8.1, released C on Wed Jul 30 16:49:18 UTC 2025 C PROGRAM MUMPS_TEST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'zmumps_struc.h' TYPE (ZMUMPS_STRUC) mumps_par INTEGER IERR, I INTEGER(8) I8 CALL MPI_INIT(IERR) C Define a communicator for the package. mumps_par%COMM = MPI_COMM_WORLD C Initialize an instance of the package C for L U factorization (sym = 0, with working host) mumps_par%JOB = -1 mumps_par%SYM = 0 mumps_par%PAR = 1 CALL ZMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF C Define problem on the host (processor 0) IF ( mumps_par%MYID .eq. 0 ) THEN READ(5,*) mumps_par%N READ(5,*) mumps_par%NNZ ALLOCATE( mumps_par%IRN ( mumps_par%NNZ ) ) ALLOCATE( mumps_par%JCN ( mumps_par%NNZ ) ) ALLOCATE( mumps_par%A( mumps_par%NNZ ) ) ALLOCATE( mumps_par%RHS ( mumps_par%N ) ) DO I8 = 1, mumps_par%NNZ READ(5,*) mumps_par%IRN(I8),mumps_par%JCN(I8),mumps_par%A(I8) END DO DO I = 1, mumps_par%N READ(5,*) mumps_par%RHS(I) END DO END IF C Call package for solution mumps_par%JOB = 6 CALL ZMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF C Solution has been assembled on the host IF ( mumps_par%MYID .eq. 0 ) THEN WRITE( 6, * ) ' Solution is ',(mumps_par%RHS(I),I=1,mumps_par%N) END IF C Deallocate user data IF ( mumps_par%MYID .eq. 0 )THEN DEALLOCATE( mumps_par%IRN ) DEALLOCATE( mumps_par%JCN ) DEALLOCATE( mumps_par%A ) DEALLOCATE( mumps_par%RHS ) END IF C Destroy the instance (deallocate internal data structures) mumps_par%JOB = -2 CALL ZMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF 500 CALL MPI_FINALIZE(IERR) STOP END MUMPS_5.8.1/README0000664000175000017500000000414515042446416013330 0ustar amestoyamestoy=========================================== MUMPS 5.8.1 =========================================== MUMPS 5.8.1 solves a sparse system of linear equations A x = b using Gaussian elimination. Please read this README file and the documentation (in ./doc/) for a complete list of functionalities. Documentation and publications related to MUMPS can also be found at http://mumps-solver.org/ For installation problems, bug reports, and to report your experience/feedback with the package, please subscribe to the MUMPS Users's mailing list. Please refer to INSTALL for installation instructions. Please refer to LICENSE for conditions of use the package. Contents of the distribution: ---------------------------- ChangeLog LICENSE CREDITS INSTALL README VERSION Makefile Make.inc/ doc/ src/ lib/ include/ libseq/ examples/ PORD/ MATLAB/ SCILAB/ doc contains the users' guide in pdf format. src contains the source files (for all arithmetics 's','d','c' or 'z') necessary to generate the MUMPS library. lib is the place where the MUMPS libraries libxmumps.[a|so] (x='s','d','c' or 'z') and the arith-independent library libmumps_common.[a|so] 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 fake MPI routines to build a libmpiseq.[a|so] library used by the non-MPI (sequential or multithreaded), version of MUMPS. examples contains illustrative test programs showing how MUMPS can be used. PORD contains the PORD package (not part of MUMPS) from University of Paderborn. See PORD/README for more info. MATLAB contains a MATLAB interface to the sequential version of MUMPS SCILAB contains a SCILAB interface to the sequential version of MUMPS (only tested with scilab version 4) MUMPS_5.8.1/lib/0000775000175000017500000000000015042446416013212 5ustar amestoyamestoyMUMPS_5.8.1/lib/README0000664000175000017500000000034415042446416014073 0ustar amestoyamestoyAfter a successful build, this directory should contain the MUMPS libraries: - arithmetic-independent library: libmumps_common.a or limumps_common.so - aritmetic-dependent libraries: libxmumps.a or libxmumps.so, x=d, s, c, z

    i3 췓Y1}#'=z#7w/iZjX?\Ҳ%->HҺ-_{P Hʭ;T㑈)}(&d7Jje+Wusu6Z2@ևc5nx_D~Œqq!ÅB׿w8=D$.}/0aBE5!ݱ nf$=.V(OvocBB%7Dv䉐DzK=+goaaQٗ#0t5P'cKSuzgE` y9,^EjWx5v ^ EjxG#~p~pU4KU ~#z / ~/*ĺYsQ^!uE31{25/2YJ;]GGU_س=S<<' YPԢu ތMa~&ԋ%9Rޒ_ϟ= endstream endobj 2049 0 obj << /Type /ObjStm /N 100 /First 992 /Length 2770 /Filter /FlateDecode >> stream xڽZn\}Wy[aȥNRIŞBM ˀ]3T,[:G:Uó_mB:veJItgQ ͔*K_|j"l桮C·(0+ oG1Ēx׳GV_gZa3H8Q[˗?}ɾ):ԘM",Xp= ZsTd 5 Av|rs{e_\zd<8[=\^G11c$(b 00D}n777SVT]}yd}A/pOۚ>]^/_1q V?_m^_=_x6o³L9p0|:~zygۜL}FN5nlll(QgF5ʔ\2%)LeJ.SrV;rzqVm^OV_>&ㆦ{{1#/9l<ߧ!՗'ן$Ǐ>.Vplޢd}w_=YPXM݅hP)2n]T`k] 0\p-1V[7*K nPop#oǨaZ嘄I$}>IsO'i4I$}J;\5d6tIb2L,/L ܽ8C ]IsQm鋋6{P@d9X,-2JÁ#QeTV=.rQuF -1 ,k/8L=z<̊+Eߗ05ح9ܧ9($!a*|~*•8j-]&}>!+&=vqJPwMqova]A(UlA(޿JIXNO̤w*_{qq-PݚթCT>W]yp(rVxzycr߮ ۑqv7jbQۡl(l?${r \ ȝdk{-}XH=S zB-A߅o!i!uQpp[,u6lLf٪1_fe6duJ)yqxטmJ)ʢ qѸo-},qvAYK^:e`̵h\ܿYak|k~ 1\ւgZOVrd(6սg٥ L n0i:GhQ߷#24j0#;ZC~ӎ6Pn}{Q`NݘzpNf0$L6 O0izyQGezyQGezyQGezyQGezyQʔ\:%)NuJSr\:%)MmJnSr۔ܦ6%)yngΒvbg70>w)%S?]֎ۍgڑ~X2.8%cã endstream endobj 2261 0 obj << /Length 3409 /Filter /FlateDecode >> stream xZmo~B_/%h&pKA-6q_ߙY:KN`Z3̮X-{HŸYX~/߽xU$rw iM«MM$5?-y˻o4Eb_|۪TF,}{Y^:6fyxa2NE5ǛcoYV}(/籲͆^vuʛ1IJt"s4JO3aůi ~Zz=7l5P]kZlxR~X~ tqז &ϼ5XI'). lڪrbt7WTV AZ v7zzF3jb.6~Ww' ǟ|[޸^8I ΛU]S̓QfPtO'd2C/+_G#En d̸O;+7(YnuqHϐS3>(LU9MG$ĢJٱozk~X hLƜ%DkO-&1QzmbfZB94o^ŭ]"q+Y@0lq,J>jX;~,PA=X`L)6d.vĂ?;*Cs'ൗH\m{ yĨћ|*;TMSlB~=}L {1CjTd8*sk,̗lF}4:b[MHmwO@~HZ@NB2/|5$FTúi ]c]`}#RO8rt2Z6!U+.] 'Rk0nΤQÍ&#6s.0!mlvgPtu}t qzݗyLvr{|@ǰm\Pb<ܓOXWɈ`t^WrA@}VqįR)bq?=6#UʳJg\˹*0e8k۽'ԴT9W%y9mOEs* }"TaˠC<:y$|Ȏ&ZqLv 6XȊFi.@"dm%h?۲rp@5οGl :9 E/]Uo8~k6&-.Aox'}09̯Pݩu2'U kM|~Jg"֧j:rUπj?󩫊16~Wu6]\wR2 )En endstream endobj 2333 0 obj << /Length 4871 /Filter /FlateDecode >> stream x\o㸵/p1GY`Eޝ)Val++;{%XN.Z3)"|(v-&]ͻF-r/>,6J0V3.ki꟟?!˜1pZq-Uu[_ j0Jd㡪fy_Zs?aa1u?~LƤuB8~'6$d7[Ik(yKey~~ǿZ,eC?#-nfZ1e4pS8!ReͼLlyąMI#wEKj\V7Y& iᮤ1ž>Ud9q移h~ۺg"3 t&M[+Hr^t%@V~zY6mIw)۶)e<&pNmCf2,-o8P7=],XXv_ZBLp{rBѬQydi+Oj! YDVhL=C>V͋3XѥmJrǟ/V3 &-is/8ؓ-hPs;s#.#*ok_n[Ak `\K;1Z SmE@T+![ khaha%F fhh ¥x 2Z؊F $V%B/^IPRc4k)\Vb[ D>tb3lc4ܾ/ׇ"LNd^H4zy7!f֪`kթU\SAfgUjkUgkմV>U1_9H}=. !U) $$X-6#:+@qB*/ XZ{<mPQMHS ig>J5V xg^o'UA$?GM+5Hh! Ӏ8jrRyDyvd_ER( gX`Hϑ{=7_L43ytJ=Pk~E90ߤ~@2}~Y,蟠qBfLN^Ǝ|8>S%_wyn($}>U&ەyv5]v,ؾ̶Ĺ&8;үHR4M&DOMDg9NwqP]b%MIjk2>Ղg83*5 ߾sFA鸑'LJBLR?x,C>uccM;$҈1c?TlK@ezB>fjWλ!/~Yئ04>,, v掲 <3W\ mW2NȞ{9k3lSޗ{R,}M fU/>MhU`;cpYۮ!,x{Pwq ,Hl+jb{,1][-x{Oof|r׏А*h[#}bbk [x @!Bp@BzQfB0@p4j) r^b4 tMqw}y%&?`|vpemGW$pfcKש5 t,v:4k}2X+nj ]C)Їt / !O+‰j}{CKLq{;z[ A{V~U_f->WkbwMd6e@Lj#u.u bYcEujz OY6ͱ!a''bUy%Iꀌ뀌3 R|0b[4W.o=|5jVLnu(' Ug4_~_{F2[,2*pGnD@!Á}YAm0քS@HSt ^X$L,e^L7'rЂF!yx>^@cy9| k %m_nSU=-Bi@ :":3a3t&o _'=]id&/@P}CH[Z$(+iR.pfP@A }M Vmux|L.aD8~`M0 9vK25(Žr]xj-FS;%p#6 EC=x.p @MٮPL\bq:`Sn~yB6ԊΧ :uwpվ=ņ]Wx 8k^4߫WqBlV P[Cpx0?-^mu/&BeITn7~v'bF_h!ME<;em&6N '?L ;T;4yP7o/v:b H235(҂lJ@?,׈C x"?>jҁo>8W+>P}fM?q/:`ڐ?q-mW*<UOPI x>TH)J צ)2Y[cS?Q$&h/}æPP|fl>A>qTXG\af8Rb9$ǙKb;=c_q1mwt$udN쏻?OAm?vYhճβavMfN"e1`9\>-9H CvG~nDT-Ӟ\!6 5N@ P$4H.-M!e2I%X=,3_ˇҿV]迋їM}C1=E7s+2}HfN+·95YTJ(A? ]T[X5q>*֤/?qs9<l<7^-j](<8ϘJ+S+56TleTt+vZ%NH(!EV6q,)'ՙUScxQ-IuȝWՀc9z3L'ExZJM<_7M~Q>s|m'TL5_~_^j""6  eduR<_&)8`*YNXʅ;SNPGu fT(% yDmxkPjdq"u%|M3f&cNy <|K1.P2^G.QJWQB$R$8&rP.> stream x[MѾpȪ"U ؎!FF]cW+ZVtwuX\C %jBlB:BjB Zn&p襘 !M*! U7 2+W{Ȫn=G0`Ti܅*)cjh]hu4(k Ljj,P).eٻ*R@^j0P cR WLJ2}-frU sIe, %7J(L10xbƍRh%&Vs_JLf:JxI8܄,|^~g~Wo sk*Y&095p \%WÁ 2*"TLT:$˪@JQFG\,m?aі P%E8VؑjdDH$: :1UbKy3 1 6" { ]  Y2u9C7kpH@Bi "ֶ6inFmmcYdpV̤-ߢ2(gBsכeg@6Z1 >];Yۭ}.olF 2O8+gñIڐSsӘl("b QJy&y -6*dr\n1uo:/5[7 xYЎYF =@OgKpldrz0LF#$g$Ň.ru?tg묖cT+KCOenˬ<?;Ԁ޿}`8<{pcLJ@~}|~xx ypu{8 JF.s`[xk0{@onP<_Mo+{<==,Ûifo5 LA-x۶@uzpL; <6 W; 삸P&Nꂺ\' r]p5kf̮Y\fq5k,Y\2i~Wt=cg$Y`ʡVz΅CUe6_- q؄]Y0+Y@h8 Ec)\٠L tw+ʡPvArC%Vٱt8Yk PaGNiR(;pam~Є]pM~u@-`;\Ƞ:"#o#o 9ނ^mJ#dIֵ~,Nx uG=YQ+rv\Kg jg>cqVs;j%@=/ vM{|-Yj939vmORWkӛ~CзTYc`ZА[_ޣU֧L7@eAH(qZgr 2d31~`R8 mK:gdu9%E + <ᒲ(~!!+gc;;IXq'#3JS#>>k Ãn ,?2jii;&w[C"# Zc5]g=߉r8U*Nt']ʼnD:Y]fu5kV׬暛kn暛kn暻kv򒜼$'/K:5w]s?iFZs!@. Bq.4\sv5gל]sv5gל]sv5k&L\|"n_Zh4Ȃbܤ,D" nǀ(thF zۑ/"3SȺMA#T(|]V։PcX7)ܪ+z^B\FYt:EXPob672 yj1vҁHM ,n65X-nulhOf' F_dS@]2A}襈zM@cxXwKV3:1Ux?]/ endstream endobj 2377 0 obj << /Length 4149 /Filter /FlateDecode >> stream x[K6WU* rUN;U8%R!)O&~_F\`h4u7/~_ŷ/^| RBqaBAfW)o-~YYi˫1nΚ첺muVuV~+ٺrCcUC[Tam s&YHH|[܅"LJJxope1dZ8sR^D,3GQ`W+.ǁ),V)P:_W]\6<4y*m%ÿA 4ӉYXgXbb{o|*Mwn! m_+Hp5,KSY/ziR2דw >0fCN۬/YyC7?gOV$1EZWuW 5wP՗F™)=!T%3GVvUbIJXi%ri%e_Ya-b+jmyMmj,.@ 6HbԑzdZykSo:~,7>n%ԏk\'G{K3Py R7ŕXV%o&Y9J㝴ψT,|KZ0Κ+^ۭ7;<t#YvMz. u C<X+Hv7e+ޖxC5d2Vzd&k3zjco转ZzȑU6'*̂[iA#*5Iы')aE!A_ ,Ap~=EꍬQ@9ahQU*+naA-?lzĞ~F9ͤi/P;4-jSʹRQۻ<1, v7^ [ ?^ {= ׍?5 H yAZ]^S; }F.<֋<Gg"9zR}ZAx&qpϑ M3t$ vݡh Zg<J<gP y|ETx'4}J07uّMF> lH{(dɊ^:zI ͸яRB"}HowU{*@(`#;1{8% c8K~{IlLVWa_x8;6.CZDFkc?9[ģ ~KZUQ$)ڣ+hX@kEZ7$?6F\ߓ\Af)  5Pk\TZ|JyW"] 8/tuw_hq U>+?k9sH L=(Ln~i9GFMU`9 #Nxp&>UKK|m9ӈӱ v #EIMZQĔ4ct  #$1mfNLΌ,?.^M ` Ы<>< ߇mb~7d֥@,,)Au3i&.V톞omHRoY]-֯!QJl=!'gSr ?% PKqN@1)`NqW i>S,r_^\'a痬j;ǭYSsP_I5es!ė' |O>!?ͺcLL W8fqNtu`0It_Ds<Ȭ 8/ x R04pj%6aB^8_= 'BÙ [m(SS!BXnt)cy'I"N }4i*_%~7qŽ&&jTaιf hħw.CaChӧ5mm I}@\- V |/2 xBY/hqcYwu6aZELU _Bf:`YT> +V S/4BD h))_W|;gZhǵdFL`霂a" r P/ >]]%F0OV~\1um,>/ /; m{ډ5R?$': /_!$9#%eNJ7԰w*UL$R+&i4Ixcn[o"sr T5s8}t0&G]yF?L?Guá$ b'6 {prg:$g#Ig_Ƶ1a@e=+{?Kè0LiK; d?<h QVl)<' +<WqhG[Q,TbČI2+H6RRƠ˔*6Ym9 F~aaћK8Muݲvҽe mCcV> [RcmWS<J];4a0<'pfF{TfN&sVbcibIF?d7/V#B B]>gÞEӿuљ`.?ɠÛѯ.MqLY:U}cMq_:$X)i͕}UpWz⣿1w1e_䴧s8>OxeZ$q3i",g@0t2`#> &F0 m|+G IWI 7^$]Hm:"ޯ7_J%`"_~Oz o *:`Xz!C(CmO!\8:M$p7HK>±9_NZ W3]a 14a8:#IhY<%2i){kO dmh<"6IwmQϝeRtg(%L߃tZsLyeȫr0LسWspaZ9> stream xZKsFWUdU8<1p8I9(^K"*$o<@)z ạ_t4<&?&RbrP& |$riެ,gs&2ӗo~nF O$t2 mY4*cBc=QqDVŧߣ^<R'fˆJ\_~{N*ͺMY{hR~_-vޛ_Rp>o63*M ɪٜ'lZ5?kͭ)]XzZlˌEPHѩ{ij@)UǂD\A#"L22?K736V3ME]i#Wْ\+5*j>JkVa4c^NI\v?.o0%K[EAh"n{p 㔑.À-3wH"PzXrD GHSOĵ(b +KcI2a;/lXĻlaxj(Thd-xĆ[e 2K)2_Đ|tHaJȞw4_> [zglV9_$pDg2"JzLmIoHbHv P,&3`DM[5zjMDrw黰IiHT'x_ۀ.;g\-/~yw=E8d*K+9tǿDcQVIǻĻ vĚ F-y y3s4-{5NNڑ==qU~@ߤu^OAu G\CrN9r&9;b 9sW\{!g[_E1`x$B2gSoA,%aLt9{k{4o Dnmif Rܹc˚:x'6V삀d<wIyoRD]{~=ήYwrV6炢j_Wr(h|&fcfͼKO ъ#e~aҤW DȊC ;eJqs8I*gZģ9P6Xxz1aiTI0Pε^@")vv&ŗ, Bзo&[]@S<f*-4l2OqQg|=TmӀ܆XV0yp]:DejN !%ܦ?-+NmUgϽڇS28iS*pKD˂.u{B&1lxfe#ɹla [^G<3̺W=<oL}W,ɱkŸK0X Dطx b7ю$l>4ON周%9ۚvY[UE8&+՗(iڞ5{=?ͥ5Z@{0!x'|$2\qVb'vb'HA|[~8GdqF)m0X+UYXK >CF*:KQ:^U[-1"-EVa>*Fy: TlZl0Bid>2+t'@P~@ny&_o w 眒ɣupn!!U&fdiJmXFG>Z{bgMiuIdK?8w$edfx`Pˋzt4 e4۟Lr ݁T۫b-tsf4V%aKO2nV}x%ا#ґ: X;,b]80(Fg["hI2s?6{#9Ei (!`VڅB!u >(2 dVbժŹՇy0aD(Äp!.>NP}C_0$ H0NO?IIH> stream x[ێ}߯`X,`1$ K<(q>p#+Vnv4YSEjjAreF&|R(;MqGCg#^2$h9Dx %-VRפΖMFYqJksUJ %w|AXzY]2x- 9STNrɉ{aBnV gKu<,gBp.& ad`uH Ƹ>Y(^ E=c fɀ;>LB:>ƸTla1x\RYslD*i 12UXO34S2Ϙ0tP]pku΋W9>1ScϠ-Ъ35d: -]d[C2:TM c,P^ܹhz&&*V.TJfe($&2YC/S3H[Վ)i ƀ"2&MRqsv&">&14a4Ndli/V1&;-ήf[)ޜVkžjm0YR.>=p{ø~gWIp v#b!|cELnp(^k9bDhb\4<|vO˫gWaExLQ @05H*10K؊|]{*#=|SLXJ4_‘˚8`3j:abvXdU5҃EFp%`@QW]j83!&ģSŌ`UYjX3x(~ .M1!`N =*\""9j2]<ѷTRԓH1q1'8!Ka>t$%Æ^"]L߲@S=b R d0rTs[[u>0n93N׶(zazX7䒂YAY(8#Xsֶ|Ai/ƜT@okj(90E[X]X+Mge0Lk@s' ]7ĵʘgD<}/Z[3>!ktD5*h uJsaIp. CU%EdLMfuD" *Y` =Yk1KoŐD3mc8#ECY: І0@_%nCe;EnjLd !3ea>f3ӯWT ( w!q"]?<wcK`@Sme-6^2uoAYhˈѬv,juέ 6.4Nb }XqK$ \ =T ˔ @֏Yb6*8A[,h>ad,u >]XE0M:yk2A  Ⱥ"(fba (5pF:]ؖ:B/@8F_\3 0{7ncL (i]-gb3S.˝@9ZBЙU 2A ' 07Xp * ǥ8 —>0p~A¿?H.Ë[;Jmu?>+O^p_>=<샌GWth;{,P\Ӆ5j`?]ձ:P|{6Uv;'W1@ţ{^`O^cϻqo/?)tP;#ܓxN/5cOxƖf9Ƽcllٰ(1Dz9ͱlJ.Sr˔\2%)LeJ.Sr}J)٧d}J)٧d}J)%X+@`< YwxEHQmQ.QΓL\0ڊŞ Csmq</[>nKqIpn%)O}J'!gf̆F6SL2%˔,SLR,a3B~"a nΟ0a3,-z:sS2[w&/ fb endstream endobj 2452 0 obj << /Length 3348 /Filter /FlateDecode >> stream xZYF~_4a$x;>q8䁢(ayd2[CfFc guu_Uw/ϯ.~xe"b1jq]p-&ҌK,>-wn\y˫ âؾR.ŧ?~^L-31Ň-qFf>kB_5bN޼{ 1m7^Ph΄~ɥ^>{Gx?zG'x(d<° wg!ŷ3ON "ﰬq#J^%}l/V" bF&upu^5}]WŦyH,Zl|{Ӻ(N/[HjRhe U]g;*7m_Pan_596@$nR2jTVك;4%0dF/Q٩l/W2 i*,쒶r2ia[uuQMG4ʖLazQ#k11k$}կq٣oWQHNk!Unkk4ngo$2`)__dWSZTNK86 IJ֝l1]mg9K™o\B6YOE #@爵Nڵn*b'Ԗ]Q}u[ʗM xӻV>|L nF ٍyahʄ,P՚Hzm)qI"oogV+ү#lT迗*X!~H8[6Kڮ>5\p`L93<s3v !Y&P x8k ă Xț47Eo_v>p5$;$*cZ P0Fc{ߠs0.R wXKn@@\o?פEPP&7nbژ.2uAO|Z3k8qIŢ8FoӪl $ ݵK6V-`.h|"SM6sb)$TX;/se{gN!EhYIf~PlJYxַT!PL[k9$h!:/`Y5M.1m[6FN-n@ڸ2Z`KogN`N<D{Ҿklnw 5Kڽq{#ռ!O.UMfL5"P./璡j迳>{nn`g,ǾF{g1pd{ƣw^AN?!S:y˝Eqp;U容S4PkǬ4r{ްpİe`!u>68"PaPؐa}/D6=H T;R&:%+~0e+kZZKZez0.juxdE^fDavTFA{5C= 3O&`T7T 1q )1pz_~}ޣ wq 4 όV`Y2XMAQ1-Wﲤ+D DYh*ƚ1&/gG"FD`I$(FۅiAڛ6OjՎJ-X5㾤u`+[+PI.-A9J˼Jn>l` ":QMhnT@<@drl[?&&}s т]9&k/a-ZV쨘d)B}Ppk+͹"Bd}aEvhev؆ !ꆚx8t2,[ghqbJU]{b,Lyf>=U.q y/0pҳ4jdmK8xxNv c<_dpr:#A`"4L>f8g 8+2Bs9X3Ƶ׉n)Ip)RkYn 2:G5FBP0}΍nYa#t٩|:K8u,t 8;wnÞ aoM:RۜɎbG.o &:-!wJ`'_=l௭u24"&]Ը4\8bFqBU)eCaX4#c.G6qvJzXCkF>+Hu$fn%CĀDBEu@ƄS?Y"噜ِ<fЈ=:"^aYILsN>мvIeNEp#_];T-)"|SE^̈́)Sd2C7:+[Æ0kh02NT X:b k􏖰^myI?%&s6J@BRec :۩xlLkkIcxNrD"f` Jzv)&9Xnt# 'C~5YS>;mf۸}k.i<-ܧ Gڒ?c,Q yi"d8Wd˫x endstream endobj 2492 0 obj << /Length 3693 /Filter /FlateDecode >> stream xɒ6Q=!fgq)ۓJr`jCJn;_? 5IjNx |>ɗϵXi-'7& aMU 6MS\_̸ӫ^Ǣj.WG7nuUZ; [8fLLʀӪiʫe8cM'e_>7rxĨQ4&Vf-'?ϔ=źo 6]@fDru s.??WUW&c, ^ON2=cK[ V%1 {B5 !/ml3.Wj8ny:NArRlj\wWӏ_*oR"Fk lry`t'rn#,?v<t-{!4K@t 6LnrdAk-pn.[zSNiEg(6 P*`;[lD FcF|@Ѥ٬J^<ǽwE;*/HcEt`o_N%9$mʄFOr5h6@n<_bNBfj1vBX f##τP4@žS H~q !i\sOm3"i6 sf^W]a\vKoK2M]mxU,rTeK sMh %< o+\$(ɽ[z AK+O:Pf~'j|rI$H88:"-¢QJ2F˽/[USNt@c?n`m0?E3&ҧC[_o&LQ-.jv8f{l+UDP=kyׅ]Gj=8˸gfb "7(wT(ΰ،3ȃ9E!gݬѡ$S$1SΏގ>,IBͅtM~X`mk d  /q dv]U[m ]2oep*zLJ vU<نB؋Gm:(pCM֯lSiU޴#ajujsG?ޙ[|L6kD8!J&f:>N2:ڮhVc zg\n^~NV} Xeyߝ O }?G]ҸU3XŢ;Z E aPLPa%8&~ "T58Nt4EX[*9cj6B '0YϪ8ͼwl?-)묭 Wrtm}VfB:=~"eUj bܽ ĥr5N}?KjC& OUwֿaU>pU.׎eMU[znr%6uW ZM=Hxq7 a|y56 8DX9qŎ {V (r`O H ؟.$جXoK64/Gس@#)y$,`9\g'?;8jG >({)UiHհx:Kng/Z;⤈h$ͦ)ׇ=n^SO.!,q `8%N98N.2MͣLL TaI>zTQծWCxw)eo)067[Xa>%>1Va yA /`WRuQȈGXpr`3QS]isihUPܪ_s-|FEz= 8qW԰HܕtN@,N.դ33p,MMe'~Azt?7gB[ŕizxe[ > fh$d> =dsC6Al܇ƀo)/[$~kfʘmw,F+hվw3ADG BMhߔ g錰><Œ]оI>eGs1zN]-k;vU@w0JXOxl -%LJ]_g My]m֎;A =p "yO'7h? 'Rp6 L3 5\ x2} endstream endobj 2420 0 obj << /Type /ObjStm /N 100 /First 1008 /Length 2810 /Filter /FlateDecode >> stream xڽ[]o\}ׯcp! Q)[YB m* RrRJ@^ ^9IԒ\pQktuid5r`ά)堺Ms oI9HHS%ѦNLEKNJhpdGSR?+HAš8b-HTR0QqcWu*i%ф%1` BKa/$J(dT:TpSUoK-F `3q\ε#sfV6`$6gW,dkfF*v{íUVJ0Rs%QpTUWRx,X~I\5aHz|/vXW #s5w,j-KVR5\0GE|`_>ਂQEpxr Է :KB·Br0}@P$pM )عKA5R)KTdк[戂b5}CRjP)BHFMY~PGTu л XCss4 CA'ѓ'Gwv?:>~{v e(DBIOݓ'nuV/76n}7/&֟}E)&S𣚯 Rrrߋϟ__mzrQQ3C.8 "C .Ǎew{׾u܋0z!70y-qȭ ݀kٝn_{iVI =w#eނL6qhtpqXvV"3Tr":+>`}/ *% dc^B_B<)d_Ŗ6MqA4cxe9|c_R)NN \>ռ z{SX^<+ B3"Xg VAd9SB/&vg| ;`!Np̳ -4FV`K=Bû/9H.P 78Yh攀G5d.U6$M²^&D\]>Or {V_rrqXpD ̐RCE Uiւ@SggNwߜm w}y=ۮGŶɱacC"x؃8.$gWV'Ok(^ջ{.>b{zfJf^m/?v5g6_\?˼'gnb+, A2u ~a d  :(렬:(렜4(A9 iPNrӠ崣aZDD]DKwkJ/TMۛg:`Ѽ`IOIoU"-df+ &4VNgDtތ RJ Uó @'&SSٹ06Ck}\m7v|F "q@Ҍ1$wt2*&R)e@XN,, ډ dxGK ֖8T}KR"YQ=l^y3dMnҚr*9Υټ9[U^=Q@d^Uɾr f]x4`w~6{cDŽ4Xͅ[ PZ03!^< c!((+7zLqa%;ߏ=GaX-N*< *K |bqႆ,'϶&GQZԀY@a-{ע"boK/M*v}ZҤJK`"RUSVCh8XMฺxo*&_I$#K"_Oe Cppzƕc=-_>0{_n0h~8]Yk3+YX.כr6@,ɪMjD&zG<y;بببببؠl 6(۠\2(A eP.rˠ\2(AuPrMstbLbT'nIRV1ݷKom)vR<{!+=f2N"4,%x00^XHG_="o F AJ`x ;o{\`蚊#4f€ku q,!R\IДÀ$oq%{rהP4vO+śWb0<`fSVCsA~X̓@Ə_٪C#P-wfAc N> stream xڽ[Y6~ϯǞiDilݤ$enUZ3Zg Hst;%A@݆o/|M0ԛۍІ #6a0e}dWh,fvSo4͚&;\dGm3*WMKCWݬ;)pa+/Hѽsf֎oLd}HTܪOF{աھׇkGgN9fYd4?-؏>s)8+VBYIy ޜgX{7/$/싋i& vJiuY4<2Y"E RJG9ޚfE842<^r 8Slr>.mӂh$Wx6m:3i󪤞rW]+ vwo M~Țu?;!NUni t͊lCyaofߨ90fT6uPdȣA%©EXr#@f*b f)O_i@;N8#@F펩j5 .˴꩓ Rߖt-Mv}~E h'bnߴy w\Y'QTg鈶ΒWZ>]6vzVW0<)ake$ < q b)!Z,' #ГD7Jg΅L+V% ( eZOp5ˢ|.@h[HLmAϧqcuk$hDJɸ2KNWϠ ŵᚮp:j!7kj)tuR6P\Ǧ͎T@o *\6^٬ Ǜ ҁ=Q]JC⸗FA\$Bеɒ'Yֹ=ijly,l@y_K&X^a~.;cJ_}Ok.\H-z4]O7Ne܇ɩdu]gpVQ OEVX'9\gU]Ow]XٵSD` h)WZmWeA"Egڼ|F/uFD<͕w ]a~HmӮSa m+'-5'-h#dB۩|ZRsU::NIca>#W#HnMAuvK7ҏdMgj87qdDsT] ^Ѩ9;&5ȥSf w&P&@c״T{ۊ~ n2EABA[xal. E]A^8'W]" P ypP>m&zi3A^qRthZŸc{ް#-1Ч|Kth(˒_ (x-vtNJ+uLׁsT&\M&cFgTDD;3kgZs5H3Z=Nܸ:O![[%HqK=v$N 86zOFAlN@o8ZBu%_x4zZ {詭˨-fgٙ vKҭ=Ra9 `U96 eږSfAbߣ"F&5 ua"DCwHlznXEvd,ݤgG%>^A2h@E^Bj;uLbNGm%x1$)Kܗ3p4I[ud"2, ;Չ9m>WS$}) Zө: H֒~:\v8o4_y:k,hGzg|sV74<Շ:g<"7/ #EVe?]vZu(,E$7#L&ܞZ ba+rYS?GaWmrƦIj(=<ƊgiBb'chHܢ՛JsLeUﲚӖ`DWSޗз9&Ǚv8'*0mcHRw%z\14e2EnIi@;l4Ǎ^;75,_1#s` ExD*el @ ^~ߕॄ#Ys2 V#V-gC]9{c ;֘R87EܱfeE*>ZhɿpG0P2o~0ў`+7+ShqL@I#dW΍hUq_aa18%`#CJ7( ,(+ X"2f 00=Zc^*#C_}~A7ku> mV5$ۧޮҍ4Kp9OxVբhϨ=xw.)&Ɗ~ԵƩ)XCVN׎o-raXF4irb$)?3*?x ݣԁQ8JL~̮deш{`׉uuGrG"y˱>W. }@bNtrON͒?PPtٰ[E~.|W`}O?> 8cbA艀XMl>eO6 6nIͤUuZ1dN"oxHCWP\yLUS4i[΅ڂ - @L yڞEcHnލ",7:tCPq8LvB_K}6]-9*(v8X ~.2:/.u-)+ xDžS7ykw {*%q,\S7O鞚R8er\d-3CJE+Xń a~>uFWt'{Nm:_鐃 RҖ[ \䘭:z}x~T~0cUE&_wU8z& ƒ`fX-s"f5JͤqA8@V )ݸ)`*Vv +ESǡ^0HOL>%ؽEҿjCwqWq #s)ffGQc ֜䜠no~ D0uGTZC70MMpBᛑهa(wsRVWsþ}k'`MzNY3C.Y1,ԠgCcTpd$~1/B"1d,W>\8CRo[@̸,i1?7){ۧ;A}_emT=[ ` SI^wILΡ7_v endstream endobj 2602 0 obj << /Length 3719 /Filter /FlateDecode >> stream x[s6_Gy&BM3&wDǜPsOђh)=@b]Ì~yFyx컟u43j-gW73&#"6F&j5{?{a|Su\,""V~S7j?mOϫ_a|_p)_,lϱ7jVʻ_p3fnq^{O`ZΈb=q*(3j3g1pƀnNAB̖g]f8@E}N_OCEgo<- iM_Pp.g FUvt${: 2?x٫wd9TJ"h߻q* SG<if9BѳoDܫCɭ$*: q6"\7tqž@ܯ:sP'$t_:Wq; "A}sJAh;'u|E7 n-X ZQc+/qM"B5kKwBMJyu mEZ v^lJ|%-}'VJ2|w)q- TvYmwYm$ݧ."b .D&h%ͺIr`>0՜^ɲJ7gw%h`j8|͢53-ww. jcoQ;}9i`9Pi `WUt#H~%+;8 @h0'6ڏ$*58j9R ʈH+p|IQ #q99]if2lJuy_&{Z}lٝp!%绿`-qQD(qIdLZNRHSxczr(XK_[&e+hL?'.7>$.OPB|b˴@z"!J'@Z#$`8| 7TC/M~@N@RR <}!?()leD!vDڀ9r G ձ5IXӊLiZfq5uQf|L _*msec wu|h6l:/HNaF gR*#)#Qq4#wɍָrj^TE0N-a`ࠆQPDcL&]7lwk'\MY 0y{D~o ꨉzXӊ___rzs[uaDG daP|%fD+] am,[PPZ'qD+ {NV{gD|4>GwdtOS`k ,M^ lu ~MX:I- sIGbZyJYKq>m&=j,}ZD<#c8GTHX6w]}_kfR)5a I0笑]iGYqǭ nڗ0? O=THbe7x1Q6Ex- {@@DYiNU'-ץ+M߳%76:ט#ԜbM%*pXQ]z+|#\3G.Y% <'@H=`iCY%-C袅۬5lwznuYa/.: ls34UG}d,@cZa=c2 OBj_v,mrB`h b.CY(%@T>v, 7~/d[7U={{!o|akwj'')IG[~w"Yw7e3')]I/j 6bD%3G~ %@I9ێ;v851k7`vkw$rQ Gu%u\ě'iT&&V'vz/vSV)>pcqmL }B'` ^]y5`3fQd]2!寜 : &p`\[;ʵ Klq?D\UuCac=Əʬ2\m7go3=n41 7nf<\ JrciFT!nl,M%q7Áe%qy{q %3Tt"-T?a9q6w99QbʝO/g4 h0i\d.ţ :n0toŃo7 OD^;#y_4lqr;쏲C 5DaS l& ΓzR6Qͺդ&D'ɵ):"!b4P!w%;Nĩs}8a5CN9a]wXQd% endstream endobj 2497 0 obj << /Type /ObjStm /N 100 /First 1014 /Length 2996 /Filter /FlateDecode >> stream x[]o\}ׯcP.g E&~PEkЦ\JMX{{x5XTr@\ Ɓs1h~2Iᶚ O19è>NjaWJךS46m2P@MN0´j5uڰ8F,Qt%gI dgbT؟ _+1Mk E]4鿚b*}\,dq5).ՁR1*xT\J_ΙT\*HW Mx%˝I{ ܱ5LyM] Tn_sEv- Lx6%Q"HV+N5j| H謀V]}-k!& $iTT׬vL9ZopԀ5RtIY i|: Mɶ.2ACjdzby aP͊ak7U,# XMoGjBc$g. k7`5 BjTX Wþb1 r*pCuOYF&ȔpHET1>!VYzod]_'7_,CxndG铓|^WGȯsa^pWzVn^nç/3՟>} xXWgǟ|+4DGT-x}y{9'"ђ}LH`wﰂbw~ͫ[owo0wܭ+mZnv7_O<;s7ow߾؝nOdxs/&F.l?DW8x%T/tV*~mZF'xճ۝{usc}W=߭wtH wbs=[_c/O޼u}3ri }vӈZՍ]p.p@W2u ՠ+ A4y 1ePAYeePAYeePAYeuPAYeuPAYemPA_Q\[]6ʛ~Pu> A&AE@bl]Qd`-GXA2FN!/*lj9V+ªyύb^X˸BPK}4$*U..x-!Z2W슂lrga Ei>`f @ YT9⦵y:kh2` XH cb.~.[aU_%  .ϥEDG~Ca+kj6v`M[ H FF! jҧnT5F5VW-Xg^_NB%B͌~AD$h(]Pn.O)vPެߞ}$uP+[G d%F݊,|n#TyEzbaL!v8* ELNs#콷S:o(=2p&/ܸ_R pYpn{Mylە/=}wXjjjjjj{8q㠜ƕt2Jc4Jc4Jcl&Wo B DԷw@DL\v b6#4]c ٽ\b? JuM832;!.'[:F] TۋV[X粀ckvrC,DboC].' % endstream endobj 2636 0 obj << /Length 3655 /Filter /FlateDecode >> stream xڵr6_+v3vtҴxa7yUy& IQg ҊB 1fg#oB f"36Yl%LL>ەЀ XA$&).6JYðӴA'kXLljQwem0:x|!K!h"UZB`f~i6<ì=̝qE6B`A::[цgPHj+AG6C3lQijD QMS=!Q)¿g͎{\4 .B˒GD$VhUZsC F`ZM#$iCm;G9S{t.QP A?L #WPfI=UP & gM.asu4a|bTXzHF)Ѷ3Oܸjaԟ;J㕭 )s?_a')86pmK^<8y4Uq-:?P?A}9>!jߕ >Cy Oe:o:?&*}3ɌCA)Ug9d4E(!T&υ- %\$BB/ TV=AM>!h|5dA H<} "ֻl1o`Dg,C,cs#+BQbg=z@e^dA3Y>@mJP ފ߼B_4AA ߭kѦ\Z> 1ONh~xvR\Ͽ9bx7B)rWλI`T |] 8 gYe{0Eɷsy'DQʿR'%iE.+uuٕ<8N5}|`yS]ʞmv;E5d;KK#m"(`4 P3DǬsZkq {_Q쟜ozgt,e^JH¯01ʔ{>@3_Jo9 >z{ߝ Dus֚~z}bzoo"Tnxu`v+](8S1 }5}a#HBOU_r=D= : 6&Q l$j`W<^Gֵڹ#n K }h3`Fj綻 #`sA<I};\loÂ)Wu-7\kֽzW?`-f@/ jkbtQ DiOmht_Іtcip 8vk@5gx?ƾ otԛ9jM96.whQl %w`l;,x a Wｒ/omGDɱ |=95&kdva;RЂ9R@^܇%Gõx\>Fdp t|0;ΛϺf$YWBCq?j;,I葜%b6/T{?-oho-U0?Ƹ#!#ǂ^{; &wx?\Y\R(-uIE96G+BOC+RMI6MHfJ\)(h%q>J!#u&FBzgAlk-CNpF8ݸUcAkl=*uB: AL[x+8;ISz)Mmj3G.XBg=JǰEMplfֆHZ[jtUd9V~b3d*d,}$h90QaN" n'ͼeX Qf3w=1 Zo05ӷLߍ.1 6f>D0n%åoO3M| $]Aح/8jY,$X AT,j[w]|w?<'Fj O¦w@e؜཭F{5sJ:rYXS@zTbuiq+CL!sY|g )?qwyi xc!Dɤ꼽ı쥛ɗl4T{f!G*"Q3\M$6k;VKo~l +,j3_6LeCG E{"sm)}:0fXO`/GݔafQ7d[b4KL]tW endstream endobj 2678 0 obj << /Length 4151 /Filter /FlateDecode >> stream x;˒ۺ{6a"SkO*Uɂ#qV3kJUL>'<3\F~fUzlJc}ج5{,bC}l~}ײ[zv4\l6ucwXm.ŭA-gYs Yi31tSeR/# S%5B9Tq⒠i_U->{z@-;b}.t@+{~s+kl!3xNdȔ?ʦZ7GidB]T4sbHTôOFcݖ.J+)!)~hn`% }EDU9lwT;:710Fp%+\`3TdH"Cy/<ٞK2.p/ied0Jy~LGru*TŁu>6L}Hں=x' p={2(XH1%pMw{I>HZbźSV) wؼڃW$WU`uۅal4SbHw.u3cbWՋ|(_i(ᎊY`) TI$˲0N`02LL@zK&A>1i-|G ɉ 4,Uׁ:t@ÇI~,n'.4+C 謹aK;PsaOJ]~ ,d"̈Len)s!.FA,7Bc JDeSإ+{є2p+|z6c\:F4 ߇pa寏qk:94 =@5,IǏ;m"AEOC 0LtMGeݬ}@yz]Ūwe*]v&I0.\BW9H{A\?x>#}p$Y) !6 d=Ŗ l܇@:,cPkK07Hp-7RXSQN!H֤"UŜ1o޾VLei*㔸S< G&f@Dܭ[;i;G?=U2g f9F4\ $ TKm! U[ndMY/Aob"(EaXC=!aY&^@Dxb0fprtc@SCPë4.YZf-Ř~0eбP3Bɢ}ـ-Фa0`.W1JibVĈ[~>O)QVㄌ Yh7|+}%p;\ ,etS*[hpخ{zժ>POq^iq=QU=Cc 2V'736{N|$б"MPzP(:q 3c.Ϩ POCGor2-Y>Wz:7W!BmX)2u1 m.7g՛M-u\"UfE~ ZJEc$lFOhb*ESdU;z'>ar8C.JQ,Q94E%~BdZ3P))MqRr} >y R?vU6ι$-O5ґT 4b=r &N^eXkTǕN;ND E &gq J]W5aW`ao]б < PD c,h|Dj? Hp5JEv% YZP+Bv?q%& КzS%S@W9Մ㓈z]L\wJ۞DB$7$n^F`Xl8nUBA mxE<"/Trp* cER.ˇȽF%3ZUZd(Uԫtz?# 0ѼP17clbC;%)=3;K&qw"LMĂ̦'(1a'g;奝ԯ`V_IOjR rV]|% LH) ^{:+nNYr|4% 18}Z%_c] endstream endobj 2730 0 obj << /Length 4820 /Filter /FlateDecode >> stream xڽ\s6B/W%W|ܪ<$[;Im&dn@KITH*_7M٢ Aht_|>XHXj^|[řTzaÄϛůqwoww 1?Vz}Lя-$)4_KM/=d;au9{ٲ3xYrV 6`U>tĶc,lպɸ7yuRR/ʞnYkb{jE^Pސ TOS% }1R0A&iٱWD04wS?_[ feFwǺY[Xwn@ Jp}ilrjktЂ30 5U뺬j.mSyڥ/۱_ 2o\]~#u~hF;|( X,736sלݬϰYoKD|pӀbA5j!a-3fBx鐏IWJ%'4!՟f\՟:›r:o8=t  h^DLy(_qlJDQߖٖ:(Oۼy=ɹGfdwb ,ӝ%O$ K.! 0qisځӍwlrO2^I41xO:ImS- ^`8ޛWɲh¸~eke]g!R%FgS 0@ký=. 9x`Kn4SF pL7p&~x0qHGCtQ]af`nY.].5" n ' P5UYNYO`#S["Lq{#A> =rh ~1Ʒ̫!}~[EC0@_ҾmY4mps>F9BcC^@7O|Ӫۺ)A$19H)7 AL6Mg  F9;9١qa1&wϒv'rh{Mv94lyV* bMS+ y Q*CoNVylp.-UȟȐ?5Sٶ/M/f)v}@_?};" bۣ$(1혔4#@Ti G+frЁfcfh'5:ɳ&~ iɜIQJ}:%*:&LP\s*anU盚a=-,nd踑M C _<Y'hʾۧ " 3InL>VVJ9 /6y[[^k9,o îINM kBY+Nu0ɧ5m2s}IN} 7NSmy-w4d Qk0>5]K^~7hqqK}žTS֦lׁ":a~aɾ۩ gW/~ ]Hs:P! >#6huSVş=S5Č|r?]/O:dX/瘕*>|Y3f ;+ ޗ.ZFxgDⲃ(JrPcjB9v+ vgu37gyӇ^5` vW^aɑUJb`%G2pjsH $a`&y;`?eu4p֏ N_xU"oK ڒMے, u19(A]f%.z >)es54sqTe汦M\*QGugi2dO6`w^(cV fD]:YLOc" '91iv淓iT3*53T6*/shlSe:&YАBQ,၄'A{0jnX 3"r:C -]i>RݳA[?d$þITBbMܫm}rwS 2hPD(8VAלy{>KX01߭^%ZxėDc6vEG\?v9̾ k|:L'?uM@IE* FK[U0h}!m.٬y!/,PPA% CcQ1ߓwCDyrY6b"ZfZ$=KO_Gd('DjP}ika+ ==aجﾀ/E|Pûj~ͯnWc3XHV=gM T !*cڗ6Ev_e$#4rxw^.L3a8Zځ Ll[? LPai|ε-]Z[okmÄI.XWl/ ] NKp4xz>2\BNI]=-CI_XOeLV_sf2Y_8}呥夁},M50yaקkqLWHfLW^36Ֆb_LAp`sJmC.ЦǙ0jpnuڻ]ޒ -@1B0em=Px[pU ;G rS=<>4za.lp".e}@DigLuF޸&g-+o*hUu) heUPaoQGgNRB͔h<&o)XQBּ@;L?I6l^b#aE5q t!~k`ٶDQGߎEEy} w98/Z'"hmgv>ԫ$B^LO3V0+_2J亏5W!< /o%[lsxkq)% R+~wXl:kw̲CS*}|-Kƨ2KP1jb7R endstream endobj 2610 0 obj << /Type /ObjStm /N 100 /First 1010 /Length 2934 /Filter /FlateDecode >> stream xڽ[n\}W1yr8$,NR')\ǰ6,HkƖSZ. [sWCr83g͵BɝB  :B57 #!z2 F#I6P D:Z % b %-eB2rg RûMkȒggx,e;&(M&deJot=%`r>Ӟ(U()IPGPR"uJ5<3S VCic#>i eL*@3fV؇j:5cJjzEǁjWF:i 2|6t~uL S+5"9)%fsRuTBH5ȔZ\XJMiJ#UVS03c15 %t*5zSmz2:B4R}4GQqCR5NrtTaZZ L. A_F)Xf?m 'XTE,b=%{MTۦD]&seԀ2[{NJԹxAMpElZa_H;+Tsƍ*4V5q<>&Lڈs/1PC ۟wle{SWH/7o~|̇ͳ.$E9كOax lN滋am/?~_:Gs=łQ0Wv+N|l9ZrLz:0J.q`xi%[,rXƓG?"/"B;>9bIc۟__ u9@JR##BN϶fuDc ƀ0Nm`*|D`:&G]q=z!q x , 6|P ר[᪺6b:G4PQCEǎ"w&o%,lo޼<ؐ2#Yبo.\\ltW<;ݽm^n"!b2Ӯљ_i%at)C> wUx =mwWLCg7쫋g۫}:?ׯx4S%fjqp:? B'O\ w]dל]sv5kֽ jQ!Gԓd xh'}_HZt+ec|>2OEq\Ɏ"*+b"IwX!;ՔM~H#% KNEIHM'<S p"̱) YUX$”l?Ͻ؁px ȓgߟ..kLUs/<$e걲$L /Rp (_0玠`6c^Iy[l+L@FQXj) XXKQEV;}a,1˲~ Y:d(wBve:Zc-ʾb1]SG\u^I Hla*r]ِC!utV )LZr;>1Iѽ[L ;kpG׻mxI@0d7葰)(o>dIGɩIr6MkCpN < ^b0ūwJ&'zGFx <%XEdxF7*HZ#%!nH4IEGl#z`#jЯ,?4>Z_rk[aqX:IiqRZ'IiqRZ\su5W\]su5W\]su57\ss57\ss57ƒ$Y3.rD:\I\r?~Z:M2xBi ZOV[=N~Ec} iDY$ 9$=#-!~vCUgOk3`}& T`b [.ۨ,jA5O X*I~0d+eȄH<n(!Xx`Yo  "U> stream x[[o8~У9_ b\(n`AZ-e,̯sHJl7H)G&'?ebp0a"V&Xr9Mާ1W4du:-ղqW44.Ox.i𽺚WEUч˗@G1Dsg9 "ErO\UY6"*PO%KLWʇ+">^_Q8,ED2ۼ#OxPAP-P͎?=c)L(qEP 8ϗOxp%LV!FdxMK]8f\#|6oѭ|/޼S 9=Ev tz] oUBj:[fݗ2h n YQYO}UoWiUofyP6! [1U^ptle50 !t X"L*& ],rIhH 0-ܭi ub9Y/UVN:Q ڧ]Ȗ! pɮS 5Tqɂiz= Q~kC 4@lZG=b䆇HXA n~ 9 LgB^ aeL8 "$ "L< "$H9u6@OX|h#F#(gDH4/U^oyEguDX؞h Xr SR0{di?V;>΋*E;Ӫ.W|{g;.?q!:/H$槃H EL}-̀OH*:5L p%q. &4K=8";D?j{B$cU{Qi#I]_$AB쁄{B:8H"&s$\"I ݱx5^3 .XJ#El0 ʧ[c5ka幻tS Vfco5U^m XQ"SH<\YU0";"ٳx6 6q !شX!'.9ƆwmpP*uHq!^qos\/Ef3E9$ip#QS$u=II X[aٞ[|=Lݰw53ɀދ8f-p%mĠ `fL`c AvPjEz`q#ԍklsI|ql^lݬU#<2j :Aa;BC9i lڛ!e! <^þ Z'\a]yH]P N;TA;D 7QsmajǬj }Т hu-G=(=4@ Gh=bNU HRi3A]Uрh T#!h݋A lLaKp`wފx~!jHC /PM}nX lvSaREqUC"zaw,$[):(ZE0뻚e]EDSwcjɸƓ@:ok6%MhTvj0aZ}@NrgZAaj];5*wbMs\|w Jgn$=]/I@K^猕r mXr)4-  βۺj%&íz&6w \-3qa9b12$ !:DӱG떷=_I!__=%=Q(, }1^mr]wIV:i:;&TAc}1'I;䮠"ƨ$nP֚mGx kӭNJbE#nnQG7h:ciP L$8 ϝ-NeyeIy]?RJŁ,N_O endstream endobj 2811 0 obj << /Length 4567 /Filter /FlateDecode >> stream x\ݓ6_ԍ&U~Hv;^U6c,do7QrD hǯA[+/?H"kZ|_pG< KY|lf%4[~#2*&VE7~.œqoNXqXlî\8ȈNDכ0/YQuV4U ) L-e;BG6 H"BF _1O(& '6rԲo]?ó2b@&Npo 'm|7O$hV$zCUZ˴HwOu^]wjΛaqzQs+DcѳMwCVݗ>n1 c3 nHb]qYY.*boVeeQML,ŋ:k1ʃ)@f"k0aқ3#"o޼ BļyAE+9[~C#5V8OhO kmT"<5@KmP9X$LѽçWBk|!8W #Ud\~-6'Ud"2ƴ?`VE#)u>|Ͷm|-TH0mPQ R_xFaQcl-7y "qwVnHf1B\f" 5{2wCj_VHް:SDv@iRDDCkYOx(vrkoxN] VMhτȂ߀aHMY_`9bW)PQ q<_`S6ظًv[ | jʎP`ZP%%aju߀~7W$iM;Q`x AsibF-*7%-_f9 9'Ay$8 !,-lf>dRX#TH@zc1XwCXA<ű1OBSkueV_hzF,EPPQǡŹslh-ojB) 9 cCdVo,4)=[W]6Ay_ Jlf  F)L+_j&3iu5'6:xN>5_Q(sV#B2pN*4sĿ8DxtAW Y{M܍0:8Y.H!8vnǛGV߆H-%7 q}eޟ44`dnE]9_;PNZIQ lqD NiKݜD|LDL\| "*iJ- .#kDb$!"Gԝ1F-x[": ŷY ΨX:ek pbo:T1BD} cAהo[FJ:6l)4$;2q(g5@z7{dd|D+\/3B0 ..1i!} @şfkr 54㳬38S b&=-P wn &:Q6_ .#uK0v[:3֗VgZ& afP%6]&ЃیCUa=d-b< ¯B32Qo Qv!!X/~ODq|KvF`Z_.A'5hey@=O򊚬iX "@xew LܮȲ~=jxNeavs%@(eNG<4D ˿tmaMaߨgrElXacx` ^\!,w \dv2jMgLG:b"@ۖ"P`]IltgW0YкɊڿBJhAB[6U"#mFXㄉAcZD-% y4Y#%X.CwԚҏ_ߐ: z 4:'rU@+M)a]rV9R FDÏHo )oo3 zNZ *cN-97 АEpM#.C_Bi4A]( &^η,"sI܄:(e0p3Z\EK+x[}kde]q*\{u hD2TNnGBH+@Qbh$f҃ȥhOUthAIChwɌ Cr" h*:$}5^w̃ak;ⰿsraÍ0M#SCHc5b/O15LS-ͮ]4nǼnGֶA4IZׇ#Nng,^_ QB~%FVAa-?WIp5{5Jl2vz,wA +CoÙU Ԇ!pw1/$>ޒJ:7r\CO:UȨxrx_n}A| }wA_3yF+qb~#ǸXtg!p&yKIvR'aå e5p.&m `T=Գyݡ(FcH`/HY."qT[y2!;$DV 4`N!۝Ca dd< X )L@QRvAė2Z4FiiS'M c 5[|:'6[ŀ8UaB`Mo!\kyBEf ?qWI=rgdz+qFC3}ӥY>)q'Y\EVL_gфIFmP \1>1_cx7Gİ?gs kqz;¸x P2@Bᄁ=FSצwE,h`2L.7 g:&#W4yQ(ϋ ](x{:0jxk02оϧ{7@A/@ )xX:Fa 7yw mtQ/ endstream endobj 2733 0 obj << /Type /ObjStm /N 100 /First 1013 /Length 2915 /Filter /FlateDecode >> stream xڽ[]o\}ׯcP.3ÏuB &F8ƨ!H{ZZ W;393AcRu1d1ٍ# Y#{ɛW/86]L0vFF l7"xRr(']G&n"[7b8@{Ah8vAVtLK=sQ# D3gDLش\08 Cp,>QYf&YVA|a(.I7ߓ[XA!րd/GY 6e/)-|vXP7eiMCPu,2 4 "TjYEOƦ#vFWu5& (=ax_E?4JM9 ']/PlLEF"kc_V匐HAD)2X Дb~@a ūRv2E"F^Dn6)) D6XCs mhO`EVԩ]C`UpxD, UH! |ޤIǴ)%<8uy}^~hgv۳%?xH<{j{yu&2ק_ P^,/Xx8999ss`s0%۔lSM6%S_I~fCG+G^Bd+r|5F>e>-o m?\ɫ`eO{ C$0ċ'8`ۋa<~@M'a<]|ߟ((9&g#9.J?t}\41~#7^yi7R*^qHP5D>Z5P& /I$e2 ~L_&/)NuJSr\:%)NmJnSr۔ܦ6%)MmJnSrܧ>%)O}JSr^rKidآ-բN nO^R`Wv' @behȱ\W \N jڃň]Rb.-Z S7 ̀[/8pf#!LvT:Na{ a@L6v!/] lN :@s{l܏GT+%,WwG:9~#A-]ꈱVϒ2{dSx-D&?QaKݕ.sKEJ$8=Pt'ıCD{H7/.:jW}yVB͑YOWj>`SBvYxsl㓙wO ʵSO`X%s0+!l|16 yUq9Zt J&yM*c[pF?"B?x΋{9B "(9*($B:Y'*> stream xڽ[s6_b"M{=u]JlN(%8vD˒A#b2]ςُճoY0T+ø0ҌK>Z~_ΥvL:;zy|yM]ԽS7I쏫qYdʇ81 3ad;|AǾKKmh9QT۴Z&]Q;=k`;D<-&is|~q凫g>Ȍϔ XH+O)gͳf+x0)hvg{nfHu>|Q;咈'Kbvٹj~]@l:ؒ/ˢIv+ ,J}vo[=`g+?dYyS2m&~0 l~IAȹT;^@^].f)ժK潻:%R|,TIQߖVۅk|9j7Iqm͑^;Ⱦ_z{-i{8Q{#I)XR(17X"̫M72n jsmY4akcvX Oa?嶪p!HAX1Z3H@<"͌4۲,MP)[㿳nI+?qޭ{i m8{k-8FgM!4?,Vnd,&}nh*ix 8@H7`%=nma wXؾR`BM*1ţ]JX=*xX-J'r $˓EN S-px "{M Ab@A0\lab>ons'|e 3v`CQ9:[,VQY zD|Wl_Jp!E8'"M;9130XV7/'uO~5su 6WsOmBo$U%9qc'˦%~߇ #K[dPmn*mUMj7ch[`E-%gٚ'2SRU u؃^-NW D0;$QCLZ[љ9B%lƬ׸j-ٝ%ck|]ҭ.q2>ϟ0˒yRLc6QȰeE a+xPa5 hϬa g|8ﭿ1pzǪ*7-yS֎նʊމ:@M6h,g479 c)2<9oBd"+8])H&qgaEaqm( Ηʙc|ϟ?;ly{~op<{}qy˷vE\ @j~SnW\W77u. ۯ;b*jՐp%eRQwP)E#u d?pd/X} Ѐi3bxtn=)/§rC6_~{ԃx߱[ JAǧC08 b @nV3oG!GAPIU|UM)7&&օ{CuxJrQ>p!Zm|N})Y7iEq zr<>W~C| [.v$-lk o4i3'+yuy#c$fJ7:h$#xFOޡB %yMbSEib\jr@E0?TY2Ub2O JN'y]+g녮(|o7b8dأVX?BFLꯁHBF3vh )؜{DJ={̈/Lǃp. sOT p{r:(QČj8 1Eca7:6nln{:(ia)@Ca@$-$x5IhXo^8t0\1r{&<"kJw 0C(n7G0\ȹрHz&hKFx.h!֎;8 %q-V XGt"GC>22W\5aTovDOt#D$I^TZe^[UܬRBfۼ鯼pn7UwYtwQOUjP @;i~9㜻 Ҹ@ wiXo4io7npJ0 }h|ti*b\|(^NCA07πGq𦹹 })fبeV,]QLap$lvTۋjl@6i=Hq\;%d8jNLd*ᕚmX?ycF>#u[p%@ô]OFmvVM)l|pdND\sڅέۢ\':OF9"aCJ0|čӞ:!?O0͔A20UAEm ƦWUBKˢ&*kz+Zʦ@ӖT)Cwf Q,T#x9D;cʌpd|a$zzgI7zKA-IgLȒ`Z9gtBq[ۨ3_9O.kGYdҊDdo P"mܔH:qyÇ710f61nmn0 >o XAxcq(j>?y}zޑ$d1C_+[:+q~\G@Pӥ*0=)b{N?+شئg:pp 2fexa w@Fpdl䢹iIÔjlI读np=9Dc@)=29co r`*J3d:n!J\PG:>KS!'*& aWdKvo%n(DmTTd k`oBNR{{K~)&`6}nBzV2ή 2GoJ>`(`ۄbxl*(G Uqa(><2ˇE^)<#TCu l.K* b,_!]arqmڱ\M!q`WVdu4 ,_L"_ʘ0?]4I@c8Vq$&+wN 1'C0a59<]l "`3kNl(BZ_&Xy~/OIg0c(0 P J RY-lC)V~29Ps=w K16|%.'B"}wh[2b`?lE1ݼT}u / h*sU]jtX<6?u}J\rwTz )DN46ZJ'$ ~@}5E>`,ϕjH4|JR+Xݎ1t(xK7x͡ endstream endobj 2906 0 obj << /Length 4247 /Filter /FlateDecode >> stream x[Ys~_TɕB\*?&+3NRfhHWeʶlWp2%?Jߜy]̤Nfz+fnN~:wg~~%o23iS[gͫJf+a ̔H3Ȭg__ujR w8'585zO7_.PI'2T*͆'Fa2&e+N_ۓ6n~]cQȷ$|Un) G,~|QPVywwbD@f-9đ|XRᳬ,΋^b+᝛-d"2X?ϫBʪܕ緘Utw8wI*Rg3NpGNXFgWӘ' iQ5HUea^:D8kግ^r fӥ!_]MH +@_P_N!*5ko97$ 5MۖgSݎ rY4 *Zeuj|}vIrZXF ze 2Tr _њBUbKGbUDg $_vv|ۇ_'V;n3 hX)Js;ܝ,\~,*."\ߗY]`,j" e20A&xs~i+I_ʂ]Y\-Ϡ"@^_uqK^I߂ٶH6-('-;~7;P=F)'24\e{L'=PwԿ̢ Fj(͙B3D"xX,BSF׬4@2I,ϛz ja1P0 "PS4z[C`zˆZr!JKX#A>z(acRC`iVMMwnsN5-- pTE&FSFW(<-]A@u|(<2>2nQ67c~Gyt n /\Hr KPu}Y.9e*MВy eB̀;Y`t}hJA RX1VzT e]`vbV^|hb^ X`ךk.m5"|=庀*tf a>BuzyNxytЌԡ#*_}-Pxc\qX0ul0D-Eay𗤑F:n,N6&`|%:R:6Lq$9W%(УS8V)œi0{ @(` Ga+H߆l$|zxXQb,<;HC̯fEJ0h)q1>z_yoڞoe >qA@b 4n[tb*o PVw``WM2(.bc?9pz{>d鑼7j+ @ʩZ *#C`U. F` wjۣ.0[=7FKOFVgiupTJf`73cH{#o{ .iw/l=d=.kcU;{@HR>V4[pxٶBV~x`,`Af]e2.<|qqgddەAV=gJu兵f2h0TsYia7:j*+ 8G$//-2'o;?IfPc`B%,v#[\$dnq^$ k*Wq]d'ϳbé1UWj2$x>^XMڷeԝdb"fx]=2`ŽSţaV53uķD\  BsBP[` BQ|C.mig{]IR77|Zt[֎0():T\3vWy/3ǼEE}d^;QcF1 {dž>f $0:ܟ`[8[d7w f=ج`i5Yb4bzGwtX! /xEY.Nu75~09w{Qz2<+ 4elQ4+ ?<*&ӯϨߠ 7J3I (Ons"5_# C oT`0u힐b$ĝ̇8XUa7K/(% US,Aw!#"iEʈM:^?[z|D#}&|>c*ϊÁ٣u_0/h"Z>g"I`9:]t]u:_7Gxz3wVL+w=IpƵ٠wg endstream endobj 2813 0 obj << /Type /ObjStm /N 100 /First 1009 /Length 2860 /Filter /FlateDecode >> stream x[]o}ׯc%*\Neɰ\E^F\)օ_s˵UK+%Mp.\˕R NJ .j :} B@]>\ArUkGŐGF $Ŝ GEGb5k'QSŌSK1+G2VȜjt6Ӹ^!;G4OLJ}Usc!5j-Yiu&9pԜJ,Y(:˅_+`!H5%0$L|\5$*W\UrKEXj]87T]7e}]li*9nqQuu%T~W%>q+VvdB5s$3HCk`28ϫ_5JZ jnJ{Z }\VcD{ jiu-e[V @+]cr' ZGbcPJu`bp1, p^QjowB vY 1U~T!zlEPeTV'F\X B)`5Ik XMrÊպboR:$B<[/Kxxvv[iկޟxt~ny:(gױ_-^.OWܴ(>/ -?u7FͷߺÿFD^BBjXuLVpZC/zhl01gf3ea_N U_m}[s3㣃Ӂ,N+A_,x-6f(x!}FÃHW!y&VkŠMI;1|z<%,o# 4Al&&İƐ"o5` 5$ >}h4XrjZtU|q>Ո0Ⱦ#(=޸#vsv;27ydAdz=΢XY?#A^".$S R,O_bVv.:̷0Lmvۃ~ 5Zm;Np),%͆$e'faAئ,0 {DA!I`Al 2o*+߃@mq0Tdf*:78t , '34݅]=5M%ԉE BhZY׉Эh3jOu03Øbma0Ko{]3KmVR-x|"i3 8 ^쳥@N߯ ʴXoiX(pj]0T;F endstream endobj 2969 0 obj << /Length 4127 /Filter /FlateDecode >> stream x\Y~ׯK=TAsѮ\9<`IeXͯO$%V*=_ |ɟ^pӋh$1jveY&'&|i1~~}1M d-.+ܥHJK_}O/~zY6fx䴚W/,I&_|ՄsY)!\k3oYh)i}~틪[bz//sx傳iN7|u/78h[KH9oסX.:J^~`L:"=)pzkZhYy hq53Hz2 kf]diZ}]Ur|}Ӳ̋`Ѽzz_e.Exr;\HKC$U_1j2YG%Qj<~N\~xK"YX;1 #; Dt]gdaw9n|HH:ՌZWUÆ O6"[t53+ˣdWWTv1$L =خݡmm<1 D;JwȸkņjPoF09]7nLeĮ\BqoMzKN1 ti> Ϥ@b3]oW7T ʭ_YdI6t@X;ӒMr1Nz}(]Ї1XPm-CZO톞p-`뿣6/x.ᑖ^v]X(o4#׽ԥŤ$ҶO˚(vp7B ] c9Ԗ ݶzb&a jl@xːQck6rcr9C儿H;oOfZF1בSe ~6wAR Wܔ ~gSzx]&ǷCʛC̹'^Qj%XWIo'2"j]G%SeP7v5*/l}21Dwg^9-ѲwpF1\ʫӷ,wE5i,[V;oˎkKpw]!D|{")l旕- x;ȾSFmI8*1LBvLȍ^hwf@;r%uӥl1([+L2`:R^ؿéa)=ֽZxL߼TYad),G@G#2 b#d{ zɺZt-l6 X&[i<.ldUai jE"0Taz6 (Mя2DRo6&opM+Gz\XG/SHeBQNj%(P&FWcx~N 078yت GHjW:qScH4 W{?7H3I(N@5I)ɥ}Z[O79duڮ(g4r 2Md("\zNpA0?`f6rN'j.}oCMM%#`'eZzXgm)1+uR¦QFL3M `%bE4kX5X>;vDS5q#ܞus;@Ɍ&~ocʼ|r[ v34h_Sa$!*P1mL/o)Xkd+wBgGDI~"~ FRȮ-ڷ݀/"8|w_#jQyrPh[Hwv6VP =5]vCP RgDo#z|'9,`y{w>5)a8kCDkM<6}b=i)j4!-%Ebn+K)Qsx-\nab"0b"bVi/DDt1/(ⵎY,>נ_1C׻&+rſzK& ro6R7x Ap[88֤U:R88 Rбu /ḥ}vt1VOdXH N R>IȦp;UU2nng-0F4g&hlSQ(Mː(1/df}닛q4DVd"%@/{Ѱ|nv/+ qfX8)6dI1; .8ULFi2a.5˝_z้;+nz9IQ$YFQK7)22:p&|5vpXɏ>Uoݖ?EK읨~ T> QM&e))> ^4VMrYcN)~_6& b,xOa5 \' CsB=`2$+081.: FHTNݻ.UㆷtlM?$(&Nc(gaFN(~G; >~4yy[tF(Pu/:tp>9vT?w[tP `F)۸:~YŪaD +B)ŠRM<_o C xxꏴ$k/) ߆=*"j8 xK2SA3͋UTEZkb7|W^|EAy/9[AaEq`$F(&ԃL2YC܀Oc g#*QoLJ4VwuvG$v:'o 1YnީsT31`91?TU6goP[1J߆iβapEf7blnO !ф@df`SvCк^Xzeuz&* }?FPP3QCzZHZ?ek1z~;2 t{|[,myƋs7 U<~K} WKÔtk;60H8U4 ꓚ endstream endobj 3007 0 obj << /Length 3841 /Filter /FlateDecode >> stream xڭ[[s6~ϯ3;vЦ6i}%$$hY>$w`>xٗbV0o]\̈́4L5aBj|ל-M3m3ifQWW-wu֒~VծՊzWUl4Λe[n]|fu\&LŤ 7Vf+ܙ4|UX:Њ3̬EʻtrD:Y= |op"Oh E>|.hyvYmwmtٷflG;md͇We 4+OԖsɜе)wm>5^3q5nyh ;|fӈ+gZD߼;FQaAx@/pQ=/+ǽ-ƍAӇzwCm?}I3lNzT\V!#asE|8@At[G 3mU5mt*L 4 $)V2ϋ*8enٔ-H%UZPyYv$H÷pA!=n6#ޖJZvesg QhqІOQ6Qh$O3 dՇ4D0${#eSa{tT=1d~93 攜Yqn[A'N|1nfY?HӒfR0-ǟN²'^ o*}?#Sl) njuJż*u EjșTn:~|zլPH`E1c72 b‰tj]9m ZYD{q$ZN3&qɹ~1fD [E4d!4ZӤ߾{#\Oj$1o_yuR`LԂ)X?3~?Fr> ULJK2c8dQ hOP (Sdc-4^1Ձ3XM]bl}J1C̈^}&:ԛ!ҏC.E1 0oKG`8m.XfQmyGAnÄIں@/CD>:N ،3I呸|DAqybiLJ2N(8ba?41/|">A.-Sr2L1 kT{Ԃc׾`qE  #ŁB^ 73mFZҒӠbCdlqH"7I),ٕPJ;F"('A/uPHetضvwM5$SwB>r>=]!T@َ5&Zv06TXƽ[I99-P0U>g`n6H/cbLXSeGM0xE.rCC&(3Xnn8]"І.~R RUaMR^ibS'\7AUӂRnv RZ`| a-P _V aڌ~(e)~% Q;Q#3;IvͿ徫&ˑ9Ԥ)ݧRϲ BgEmz t:84a~0(uhe,qP;I1 gp@]KԫSD}Ԯp On_l=ɑ6I$Xu]~cCdB߄2B{;o8)9WٯauL] B} qncߔ]dp~3 W{̬V40(MP5|Kxk8"h7O_#}67!,D.)HB#b?FB6/ؓo,RƤ%f Zn$ œ2Vdt,{: Hp9E~.cJ`݅:Ӫlj9Pz0V%\zM-WBKةL$8N\q5<i-? nxrti|xeӶUw m͚3:ዻs]Vd rxtQ3rn."cX!KLBxɤ1coGjGW%Ř~qQ_QSI%Pd=FmS8,ZL-Y"gw f|75ojzSB$ FWpަ4X5Qq=:G(UP{$EP RhޗxcG=]\wt'ȟN/SvZכz;zDcxO4WɧO -+q۳n>/˶EQET߬WC(R15/~߽h iyhՁ#)'zOHe{܊)59MF]jH ӄX)(6 5${ UՒPtٷfĿmتYOFu0 {uxru<%AI+XqRؿ4Eg 3(\W۪MI1[fvpܥQyݖ1Yɋ+hwm$K<(&9/jB@WL%!R endstream endobj 2908 0 obj << /Type /ObjStm /N 100 /First 1009 /Length 2754 /Filter /FlateDecode >> stream xڽ[n}WqC7Xx-dV$F B/|}LlGj Ap؇ź5ҺblldA(.Fu%76]|Cp1Ѫ.bWD%G)|]‰`}9c)h0*q1.w< R[;B&TaKwYMX\)ƕ)SWBHx{ .FR^+VClV`UiO]n]1WKKА8ZЕ>V-T5 |x7,|'rrѧnЗx:B)!CGB&jNrE/CjE\oq%IMz&H荅@l R/C֥UAw9*3F+ XJ+c²h@* 5@uEFew}@՛vӯm.ޯ/nl8>^϶-нl,N 6Mⱹ1{N͛[=q_w?p3Ė&"9UN!D=Ǣ]K/xan,C[2r-W_G IvsO;ڧOXV[+v_8/X^b5zaP4RXa炗px?ȠDAϾM08OCkl~Ǐn2mCnؙ/[c Nn؈&|nrшV_3qǛN.yuݮ/Ν>Ǔv8Z=ݜoǚ?sƸ=b4z`Fh\>>d m'OֽZ_c}:߮ϷyrGߋ6Pv6:ӈmsGdJ>#0755lpC1lbjf CCCCCCCCCCCN 9r2dɐ!'CN Y Y Y Y Y Y Y Y Y Y 9r6lِ!gCΆ 9r6bŐ!y Va`XȻtr9~_f1R TKA "R-/-@3};HR=pQ+jI⡾̮TJ>??]HɁ}#<}|lX>C>&*"m.60 ^ RK!rJҲ '7Hs6TP [$UQ6R0o88("MvYIFXXh_D$pMb+sL>(ė HsC&#[Xx)^MF.2gp2ie=,o4ZIQTQWx_AL'nY3 FWDi:boBr/@jB}N)6(V=PzX@ʀjj=UzxjT9hVs `3f6l nݐ!wC r!Cqqj*|o 'ZBCK[8!Fb_8NZY@Kė Dms+R}&0EɬHZ64V6\dP 0yo =/% +w&X> stream xZmo__ [Z|%ɥqqISPyWJ=;!%J+W/9"p*Z,_N'~9|dXb;ʼn4#?wr]u ^W\}EXċ9K\T0rxJh)>cQuOn<4m9}]^em]|:pGf9OX!+1`RH)j_Z_i+M^6Yokd)Վ7hm bc˪ mhd+ds]l{<`tjڢuc ARIU E9O-Xb@Вn < dI!bΪo RجiuA 蓜!5qcmRM?U6H;tΩ\7Ç%A$76ns6߇fbE9v'ź3;߄5s\-0wS\#'`>+\(4Pf>kNR݊ @Mѐlu |Dp{ SG4Bzm$tw5 \`m3`D `wYL*CY_Z[Q?!5\lGRJ9duUAOAk୷Kz^Þ#QgأAuu@xr; >1K.bq74i5Iz1+Gk|Ȯ!6b"X%PY{my[~5壘DT^2fI*| 6 mo7Ծ!.s؅ơ#G$Y'^<B$ڕ`G/%(z+]SxGkܕKر\WO!xw70Cp{)Zo{ |0qcVDfEI_8ި0h,,; q@Xmy#N'}pHѨA-%&X>X[KY%K"O! Se0h]Gvu+sf(zRt ]{(!tk"d;&uی&w.؈ɬ3]5 5$ yhm'W;w )G 9;N\@ ,,d 4f;y!Zl!ĢL݁a_z`SĴRFDVic<ȋƀfLx* k ;{HŌ>=4Q9B lP!G9" ЪFѨB!+$VQ)JHm '`X@G6 __ ݻlxG$%w;,鉴us(ă̆(cvCnlQS[R 4|IKufQ&^"9h'l1KH#_煷XO?P:+9Ө|q 8pV`XϪ)m8q&ac7/N'}^ ŢBO,X*>B4F FS(4((X<ߌ7p$J\E2, j=_ Fɗ@z\I$sQbzٓ3 8߉q݂־s8%1C3AbM,6HVI?Mqw 4h—݀XV!MW}--XJt v>NŠ()|\0zD΂j`t Av1]!'xvf|V)ӽ*M)Úko$L<>ЦgVED=to3+ V_+ÌR:wx) D|2 ЄwI5YG FҔN}fm$?49gJA>C)yڥ䉻qRz"@W3GOp#9EFZ5sɧN+bxMNxce+ pT##}.YЂwL/D7/23i%΁~Dv \);ىx?7܈Ͳ( L<5ݽgxTlg #pD<EŴL2a^\U< x>˷[y aa EK҉LTx fJqН_]Rp.;9!tb싺bu5qMiG6kx&"] |A|<dqB+i}& 3ɢH?d$S0zޕma 6'-0Q5n+R͔HMB]O#'Eg&S]aCX=~'s}?&П=-_}OQa[ K/'l;KE5XGh}^EKwtfoU4f|&*Z:w->!yf0\Ii RݯVIG刺U-ZQjkg`JC(9P` ,J endstream endobj 3020 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figs/SchurSolution.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 3056 0 R /BBox [0 0 374 110] /Resources << /ProcSet [ /PDF /Text ] /ExtGState << /R7 3057 0 R >>/Font << /R8 3058 0 R>> >> /Length 920 /Filter /FlateDecode >> stream xVM7 ϯq7 u%E( tAE)AaH{/53X`g")Jߜt-/翇ow޻P?ѼLׁG eHքp¹pFWb4]8DbVVu@" )RrLY魲)%"qihǭ\M޺sKB2%n@/_B$ l<49O"b!`B Yi`}9ZKLzJ$|VύH;1Żմq >9 P8Hf_Ê:ebE#^"I#V ڍUb1 ނt:Ikv- bILAaLJ1AF#z4*ݻ0kP] k!s\V#Vn!"Pw,G6wx&b<Ci5)LR46Bd dLԬ$~AL{,,wR7@Ђi QVhM@uQ!3|%Dp|O@2úDi9&m.k׃ yfr/r:yf'] t²]0=k;<^ibKKaɮ7CSd=6}:=Bzi6< 6K[Mlz&mib:Bѓᇻ(SS2iUI.w,\tnk~;ƛ$u'dN*$I;R y#z9__<L?k2gk}`LS,<߽T ;ޅYBްA=X)<~x9ݳx endstream endobj 3060 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1809 >> stream xmS}TS$[)r24Z 3:qȡ "pIK3@$ȇXf6]cnuN97;g7xzsߋ I;MY( M)-x`xue DE̓`9}QP:GLp\ZwLYPlޗem} 辍Hd2eAdw*TbEf$[RJ T:uaDU"ɻJR.J6mDl;9e5䒤HI$EQPAeNHLJIu8 ".bx%^#^' ~B 1MC cHE:$ ϨuK 7e']WEl-C}tjޤ+)`8@ˤ T [;ϵ < A$FxiS 6^Auq6PB} U(O4AӉ4@zޜ}MC#hs7>נqecCUԸ&#N{L0v'c4Ji܇&2tfTc#=}zͧij1q$X8o&}ڼ\M..Y4G:0e;) QCC8'~6C""piZA[U]k=/ R޴0zHx_O '>u1b) L+/ (K=״3"km&"*SkeR ͚),!P#8Cu][@ ozN#S]E]OV7%*2Y"i5m'w~ABWJ!iқ Һ0tmo`픾?F{0^_-ޠm2;LJ6tʼn6_*)+B^mY,w`pgMuT#g6n셋4A7،¦m.Dk)ύye߳>j岯2`sw?}NŊ*0/M'n*>\Xq;[< .Xǂ^AH'~/$C~lvz-fKH5-MZ/[C]{//i7O Z9x=$%ڎg []EFD \Ds#gls`tSJτrJQy|Zg6Aٚ"ҚhOqS]eZvAvPxE49|oefj†96?4L1;- SzꒊTd5wgÕGJ U:9̀|Wq-gXel2zw؈'SB)JhkX97J険`?x06[r'>79`R|r/s0 .Uo'##=}͜zo+,'OU?SEC:w_ޚ q4p.ۀ<O'w^|z"\iOH.EDƶca [G?ƴ|qR_T)l zj~t3egԡ!{j|򾃂,ݒ[(6d}Stݜ < CˢDrrz V3E!Lijf ZƬୖ*3L㯀OQ /E@ endstream endobj 3069 0 obj << /Length 3603 /Filter /FlateDecode >> stream xڭZKs8WrU%5[sp2ر{N(XH IF7h;3 wgWAa(wE BOr%`qW,>-wu|%ByYa17?__~O@ uqu$i&ap8!|rʷ" G.[*r-4i;ܗH '{.5:"Ux͌'Ue]5tL%B,{Np<3+îMS7+%y 4t5}zǍ~<<7H^ 9N4aPr_TpWTKbڕmWxh:kYbJ}nZ`Q9Ւe( @/z8$J4p5)<` J7Xg{iQ U- #upAhW5/"}p8;נ3sBޠ#(pgomy" cbpHOq =5Ko!``JbY7n%; T G ckV|-[ V~3t$٧F!DPv[Z^#!H#1/ٽnIOwq;I $RM3ͩ޾>WͿ_\K(Ϥp2QJ0 ;fKQV<(|%,&+q2 sA%m^FQ:|K>tin\vC!]5PKOd," &|5|f`]VZ#5NF?]tuuCEe>us[#[_2 L-E6z LqW(E&Pe9Xڕ& go $$K@DhnuU-+ Dy.#HgiO){H(}zhʬp6?X3 _" 9JW]c1b6nf6}0%kX]eXŨ?Xp Z|5F#D3e]. J|fB7W [|| ̢iAwc)VJ0qBPx +"ޝ~zjbIPGgQ@'ϓix0C g=(ʋ"ph@IW3{&,WDbݿ?iN*o]A40o;* ù:׺DtlꦟB_[& e,uf3=`{JjKW\R'k!53H,0䊤 0*/6⊤L<J(aށ c/jӰ0:L :\&qT?*=G,DbKF&Nb0Ie@V)%Qu OU"QH=EX8xo*5u #zXC0K39h0h+ <ߜp[Š]8u/s+vMB$nO0^?.LB}0(8'tOEA Y|yQ2Vd3zTzt1wh PCdd C,~ءgɣmde#gřHn]crP&#TN++V,Md8*8]f{mWq r{/ץIG weRv=5^R⁂x5e[Ms z/TŅ] [mh G&MI.'Mq/YXe;b eG*`*+wg |yqs9/覺f.-M P(4q3eVycr8"߀ ľecg0Ԏ #qՌZX>r{ʟd\f2 28gwsCZ0@A aN>q*O7NBj(P@ֽ 0:K/:pZ):Ít),z'W_q2M,./>ZcO%y?^/07&$f禫C[iT⮙"[Lol#eeA ]Kl%6p`j#0Y4jK0ZmQUtB`goJCak%̀gF@cv a}Ch Q"(\7S1Jv (K/"Ndu*5j9'- כvw+OsO *7zeϥ%!C!_ 5~2NK}Ho7f6oQ1]Ryb\iq$SG&Z P(yJESf_AptKg60OyUM6jC|h3!^wfd̦ޱtnGhZ+equ1g"!6:h;9]֠~{ !C4!nY"7d\|uxC|89Զn-/yO\۲<͎{ӶG,`d<^[mH NӏQ|Yk֛ Eج)Flr _'&tTW.ӟ +<=UzՄ(9?o2c4 8 0#' =F?GxB˞Bk~g(ı8_|ǥf|cL\㾙>}WɬⳠ.51t/$Ô3<#c8֮|qBWdV6F,ӂ c#\bp2J=!4cvbw;JƉ ?nPdB\<`&M_ bKb` bK`$MKZuhV J㙤hi&__yLӈN aPi2t:~ oF  %V@YW >@4KWߣu;{S;=r 0E:9?yCt?Df endstream endobj 3096 0 obj << /Length 3160 /Filter /FlateDecode >> stream xZY~ׯ h:G.@V,CƖVkAaCIͯOUWZ2.{:*_ݭ7/|~~uoDfu[I UY!\nW}V_5;3juٖ닫no=apZK#bchfT4@iZv4_6)I`|WWeD]$m:OU 䓸]oOowL+ R:d- iBpgW5nqSb )1?9bmV䇼Lޞ꼼cO;s䎜3pbxKV 5 .A=%[%Ktxg\ևĵџcDz}{6ڞCR/-NAyow k #B BjCv6S[WN+vN 9‘7QB=g>-Vhm{5mu*oSrmΘ@>#6ϹTXNI,`ւn' L~4NpM?ῌ&.mLր쀥B4(Orwt#əj[HSw*)a6SQwwlL)>4/lQH^&9o'xI22Ӿx0c2@ 6, ءJp1VD"SQE. !Sx5b'g~QL`r@r9 tp4c{mȫ_ңbv$ G=e}m}GՁA١r& +Z^6)Pn*2 z Qd[W#| k:[(c򻅭U<^%UniӜTܷ\Eq*qWrϽ5 5XTl!r@qCZfVs@{0GU^8$G._Y|255AE;=]E RBPBpbN6Rӭ7%E%g+)a{"2)Ok ZCg&Q[NEh0_jZc.t^GϏ$&LOTitzU7_v"lepx_O2{R_Y +RQ ?މiDt]wj )N) =SBL$`HwIuiVu$PQ 3<\VpLmyF aNw<4aZ}*ׅ2 '>.&UQ{3ʜ~ fYHPJD@xjQ!৓nD;f0>a\ 9@7 Z#CѻH K c&ӁBi{`1NJW? ɰ9 rJS-mU% GfY ~ZF0ċN˃En2aSn31@A`4`{rhZ,04!8iq[f sm$&Cw ?sx P\kq '#@ODK/,BEAh\zw+ՕHw}d׊46n0z2TGŏ/pQ,|@fok*=B'q h3Ë~1"iвz1TEޝ AjA=`$h"K<'BrjAE3ј&~;B[1&&~_y1->|Qrej'F tB"}>p*F׆RAɫ3Q݋ ߿~A c0vƠ mi;0&oچ ']nA7ƟrK"GyIO~w}vζW䥕Wn{O+MCvO)!Ne@_PLge$[A9hKHMS=Nkٴs0l5 vd v]`z FgDK@qbXUB '؀? endstream endobj 3011 0 obj << /Type /ObjStm /N 100 /First 1011 /Length 3254 /Filter /FlateDecode >> stream x[k7_oJAQW@$!!`<جI5L=JH}_arrB :0sIj!a9pE# $:F$m3wBGW~MBd9(U K4a 9S~g x?Z=T^d"G-Fժg>Ө˳+,2[XLk R Bvj?N" ֨ǯ^zG_ ﬖf@+<%F&Zk1~'blLX} 4)JU2CemҺt|о W(@I)Q0M8cp+O߭l|yHu 2ssmJ b° p t>4_by Sn I;n(2<^Ηɴ{hٴ0ɟgd ]Ŧ)o[=Eᑻm'Ls8Lv v$eH~|<./;h[ <ύLM޷#|b.6k&P[yjږg{=M-EZyGަKQ"ikl\rj))u7ЦO'_b:K"T4M%h*AS ZUml+e[)JVʶR]*eW)JU[Y8;1];ώųf=]>oDQ1 2yóh$*R`MK^6s,(x9?-fu%P`jNŏjT@E\˲v/B_MmќWW7߾}j&NCk!g,֛&+9l'ُf'ETs?>q%Bh"Y,2WW>t}PW4Ol9[<\goҗv;~|j̡֣ >\<(@ݴ~d b4[0B`:-ΝQyRa9n͛旦d,mcٜ.z媽A:Jaܗpۼ*ߓܖ?LAh|O60xLt>k7y[ D%ˍ:Iz[,5q6B^$ ,撿&zX1g@LpAq 鐲2#C0Oﱞ|Öwæ ۲QfXrHMyXhjܭ!سJ!cDe dI8ҐԫCV!_j5rBEߡ|@ B8p^E@'%ijdK#22Ϫf02KSd&})fp !ML{ QGB%dX̣"s! = d"6#nc@h %v0WLQO h#͒+dSa$Q^ BO- V #m1tZEp =g!*P̊eN|Y %*P>kҝq9HG`=@.2_H,yzE;X[dQ&3+ x2d06V|&FK&?(~@`~k;[(#Gtvbyc Y}@oPRZvH'ךΗiZF+K#pMv4pp2ñVNG g14ЊZY!$u?oIVr)"mt7) ov\\hxm iaFS[n玫K# 퍾.u=D|y{_8vq4:oekn$v]2EkW76QTA ~oɛ6RyHm렃"D^TR7y1Veӆ^쮫 a,knZ]Z \aåxBž<ܗcӱXt~:{FFFFRNrS*T)J9UʩRj(4^tL@ZǫUӔ8&h& 54Fa/a"s%H8aϛU;0G{V l;IFl8b`fE6> stream xZݏ6߿/xᷤ p5AAKC٦%W7á>W6ibQ7#Ň_݁kϳ)DZf8.3-ZN. %Z^]#R`;lx~Kuߠ(P؝9#Q$DZ͎̀x %ၱ]d5ϊodM:4&˜"Ю!ay\gyzM'Lxe᩿%g"Uufzao?Z_ p+8SS[*ݯ˚veq$ 3Ǵ2(0=H5F:N-D!G'4'IY8x!!JYlMxίAgO7'.XZnW6+G%(II놌47 p^v.5#(QZccAOZwG~2W/ фbgk&^#BF~3LHxQ,,72 Q&AU(Yo4*tjp05^ڛ]9SMd=`p3>Jxiم6=7<@ubHWV-Tʅ596X⽟iHU[A-'xL4nsꖞmAc36aTY.@!M!8y}ZEZɱ}DdAr6KL;P$\(P =@h C-HaPK?U3U8{o_,u7s{O;,~c# 8C)WgO:|]௏9" ]E'ըF=<"[y`,Ϣ^ +Ì=О7S|7C S@Y{Oi> stream xZK6ϯUZ @rcJ^{d(1ίn4@!)Ww5 g󋳟^"eYv!TD"qb|weݶ8_ER-]_^7^,4Ln>ޗEwSV-6T['X+[jj)NdgPɀm @Y_,+Y36dėy2K-Ȼbc-8(3zѠf]kԯJFN=xsJeȟfW2%R7'ҲSP4ϖ@RVn _:Q@Zoh lIb<"6^<^T6uյNSM1oMef|/3+,.K4urJ1[BˋΐM Irǒl?bmQ-nL"LenfL}ե,QxWʺ'@"vZ_lL6`212 ֡_m:tEAcf5yBi7W716ihqV$j{ XrP[[m{Q&zc8Y5y0 MA0VBzbgc l!oĞ}A|9`ΤNr1d"=L}(X\Kʄ6jp7_4+J"ϸbɗI˶˻ʵw I 1P Wo^5G0[3)њуђ/y,]EX]pN~LrEE?'fm3p͸J&SLќy`c2&|#X_I$`D#6(4c 3}w;{ @TZ-"ΤYܞjLGn#]i8צ_D[DҲJ @-?krFs hp(,fie+ $| f2@rxYlQ-uMY I(LQQ%$yT (n&5]D2Y!jJ5?lg$m`+͠jyP5J! dh~F,`89\0pvh4aX&R@C3E"*i~m0C$@7 ZAi;o(=@a`A}W ࠊyB 6,Jd }=΍~p^QAlݹ=7K5}-Y<v^)*DzGJ&Ub; .ӣ%WN X 7q\!@x;=e=r d4,T=g}ɴ]듔zRpq;sMpif ȭ|>j|'rS4G 6v 8XE2Zv_[8dy ~d@'ٗUSeSʎ\r}2 nO#NW$PE' P^}28TFa;0d@:=4\0&Yx'uJ^2p {l DM6$^0Z6s$QǾQC38\+*uAhJ4%͙/,uL!ռ {SlZwDdlbLq& RI0 (i"aلXcMĴPUA˯ V[s[̿\{ܔJ Ųo A^]YD(c0r5̾晠x8W[1qگP"&>${:t-KZl:d݂b0vH/(Di]wc*'V^n$]C&$CC^^"U endstream endobj 3218 0 obj << /Length 4533 /Filter /FlateDecode >> stream xڭ\[o丱~_/hVT}dw 2=3>A6yXnɑ;|ŋnv~0"%*V}UE:^}Yū?o}S"WER|ub\E\UbT[ޯ~]*aq?gW\b:*^3V_~檾s?+fՇɺ!1lB[r_4_}_|З,D.mW/gF)᭢l̶PYT"k{_ Ht-EٴYɯg(c*HkW`moEHqV5q=<| DtTO340P/n(qBbU^%7y~կ7<|-J!,bAl,"]>M>ag,, A9U %޵k+ʬ~v1bmx*?hGOUw[߫!53XX$v;iӖq_ ~Y [.7{bIx]fǬɛ~.͵ K7֭]kq-uDҲH5_X-K朵Dt,EKU5rA$Tʶ({F P_{nw߳'hZHOtz=֓y2jB|kkׁH$;ki5rأڜVNrh$l~Du4Y 录Q"r5WV3z$Q*Ib"Tx1WeHPEVUkҒz=ljl~kDllaF@i9KT%,v(@_Y?FP'CA9j#ܘYyޣjP @+#mW7\#za9js]hDr$SM%+n&8H0\)K"2cZx3]gl&ߪ6woΞZ"8`-PP9| !׵*ψ3 R}FZ(5RlQIj*}DK{ZN[D\& ua#F𥅲t6Jfkˌ+/+aBcNaFaln p)"=D&V=X_-0]>fO$Dt1=ms|̩~?硗SUCw|_= V ;JGzHh:wܐ+9l\ ;u+mOөPfa3m _QDMz~ (kE|vOuEV[!G Z[v]?sPJ#"#'K&mo`n*>TPVx, 1n?Ho!NaNjCHCF&,{xW >ݯWh<"76]}~>D1d&q=Dgt86pS_1UxIܒS1F-6WM=Y^%]=Kx0'9޲ w;nU5^&4NQd?CץN_& 6ȶ\MMh2i]N>mOl45Kz9EJЯ ~82?@[[C?G6H]o8֌J@Nb(a%DF I7 Ej:1>uȧ9 q dlV΅P(qz^;(cpN`P-#x#nA#j[慅DfEM4YBQ>,V3fEXg:K[/׻T8.<%]14_N[A{~B_@o0(S6/CJ4pZ^ׁ7Z3T ,@S-.J9 I,n\'5|S\:pш_>Ӈif%C#(4x\)@Dbmv;K~=,-`$-0b6O:IbI6gZ A}>q(aCBD܃j:PKT9'" SnU]&Yɘ||qҮ$S;FbZf #X'gDC,B9 xrWB-u<irY'9"a:Md͝4ɛV¡ ,zS힪!Q0i)TBoA R N\l}v}~o BV7^[6ob=SB[?9e(fExOo'*z@|ivi]Ql>ݿ.wt#\X~>zTb* e\g |/ʇer2 .a7 {'DFp%ϤOo>} U4:zx#rg+2XƬ;Eo۹g4 TsPҟzU5ɉ* 0eޯ\f^Ol>i0Gl?;"EjD(<7 uЯCB[ڀsR"|~ѹ8V 4ΓiL>F7\< L]=YIƧbEP , yRZu,$Ĩ!m T[BO)}mEׅZ?Eװ%/az!Qg;}9pihyYݟ5p םuFgDNƒ؞ g(ҡ]O(ո!.GI_۱tr!F/3y|I0L(̵8mΰ]`57n;=MK e)Ljs'7 վQ܄ϝ9sfr4(u'a֞KmQL_wxd<1xm^.P>" @kTz+9Mɉ:<5 Ժw}Yo!s̜:y)^ ]JɾK^q&zt?$2nzgfŶ94mWXmwE\'Iɵؙ{'cUC<6u比{-haW\"f] I1+ J*BAr᎕PNyDySip#+oK?A_/E:OApL:bqȞ!<_:96Â;=T5 4UY]q۔mzTkW;$oAT]Y,`.S K_$eȕc.}P>xZ$gXA Jպ)6 ׁn0|I6jJx.T1͔m$ۦIUwg;TvtS3"Jbd`>#zrFUքc z>@ZMo.T̼rIΦxh;^:D9\Yz}~N&_am$4HH91'~(l endstream endobj 3099 0 obj << /Type /ObjStm /N 100 /First 1013 /Length 2857 /Filter /FlateDecode >> stream x[[7~_G}.P U6An iPL44;:=3Bͩ*W|vsjR8d&H*&hM(Ae AỤ}7sZ &%Ț@@DRąMS.g lMvOTM$b]lR y<Qӗv{׾ }d}d8=fR "T-HiiGKςDAFL i)VCE5h79$%P 0aJ*P HNEɳaAߥaa 5a*aT-T%{xj)6,B@IiشT*60- d|pb#aM0x SJdj =4NfU#܅}$FP^ǰd+6MDb"TdK L0b Al au0 `0@! =D]wXT`bL )jsP1e[+)4 +ٖPFLħh6!oc҅I Sb->g^uX}qq9[=f\Ճ˫W/Cz×y\lK=ڇhJTqv߇yX=|qV½WX_}M3@@cR*Rc=Lk`T)U`V#R4*BS6 YcO՜cm9-&4)m /83!0 Ep4Uw V(U#0U\Zʭhd &Ҋ~țu|wQ}rr+ό#(K]YX? D k9\|xކpbq)ՈxruX=|wyô}f͓ڦ7V//6#Q{<|G _`5l/wk,A\5بp^]ydabq^ߞߧ].6{K 4pf~v{Z0fB~6Oϯ6.O ռG# 4<# pȅ#qA](.T }oIp5gל]sv5gל]3fr5k&Ly:(";q]|X s L0-z2/ G9rʱ:D%-RkFRZ*Ἡ͉C+_@ φ*1 n5buKb2F%G'dm/L-vZ(-2?"*5J:ꎸ&DG+ӕz9мi AqX:fe8x4̓08dV*\Ø#`)@X G8F? !b8#p̺\H(J87q7ysQdYqXmdvT5՚1FCpy(B;ͻpBN&qn |vv* k| Ĉ9= ȼ!K6q@ʼƩ@{=cvShh(8Ldϛ%$p*-o]m vAzN f: RdcS0g4 ^F\XԖGI 9Jp; ȝ~@9adSrH7[Ʃ>"++MdV9)N]gD<,lxFDM ێb{7=LiSթ϶m΁6@s9j.wG'̻5w]sw5I3Bv\`uP]h.f?yI~򒦓3qRm봅zWjZbS!ld>(XvAFB{?9?'Z=u59NԔ؏&F `ؔQ'4 džmg>+ۏ2|>eӁaFC pbc@ma@8a/ul`~mnE1i3 R58R 62 o?=b endstream endobj 3266 0 obj << /Length 4399 /Filter /FlateDecode >> stream x<]s㶵+(I0vfݴvӵo{g>2mq".IeE˖@,OooΨe -j%_\.~\vYo..Nyoho.y~>&^InwMY\/uAhɻ a1'e6a+?j MXfEڃ˻+S/B/ͮhqӋ=cr-㶇OߓH?N{So|eQ#,VJb?7WKRsq"M(62_ 1h`bxLQ5ywL'*oSMq8q.SJD]SaOENCo\߱`"v+oOE 8M8S|Haeo+anyG3=/mcj6~0_Te^$kSuYd $$"wQxA,g[/?&}4D^3U:|]o', V Zo8:.'!!A soէ9X;"c|a獟l; q 8bif^f``&&o#W'6KY6C1}/^:u__zF H[> 4tj |i`"h}6yA BD1L%z3D(TϘV}`zRШ#cF=L) PA3=,+]W+w,L]_1_ R7#3y{Pk@+`~7Y$ P)1 g,nMF .38fqo>Y9?c0V^lZ0S]h⯠~ (K<]LQ&8\0=G ?K . Fkf$pM_xIY&%^d 1V"F/1LRm3x޶6!]Q/ '?#> \~:|<]7D7.< HY~.:p"_AS;l —.Fx&M!w1CQ 73 -l Haحs{8 O]|⽏\>ߢiB3-Sq4G~*}B_d"e$HJ)vQUDa8Hqɖm?M99餧\;٥5WBd04qO6E:sia%ޣWoA0΁d\JZI]k`B:}٠si{Q0x ~oƚoöG`3&x؁<:,`э3&~SۖEyY2lӎѼLb U-YG=DBg+zf6s^]n'GHLdGSˆ=?|5$ڿvRP0LIJнIc|MGE6S! R=dJ~; @vDgӪnwUQ.aܩ\>}xJAm&#%rtt̑Bx? aiJF{.2C<變% t7y3Kut!wt4$f4@Xf˘7W:pkN:fP*eJxwE^llB%"ۃ84Tެ4{SA_0 !8?0=Bfcw3VX/*pЏRmwۇvfbqOTBxRrSve8n\J2#&0 q&kvx19 AgD09OS%'*Hey^UƲ>s3T-!0=q"hBD.IҘ Wo/8ZcoJ} 1Aoꂵ:E)Nk-RA!e(ȏo,FCTfΡ,0So,i+KRX4#3,F4L&R͘ɽ] 1Sf n2%Dkv+h&.#s@Iǀ\M ܡzNL|E@Lr"24MOdJ$IL#!@Qω6MȔY.Ϭ)*ash ̤zrP1 ˄LT~/:\Xa&\Eb@uz"bK1bvWB@b?Py 6Ϡ"uMZMI7/@f^3`&.X} -LL`2R/_*_U³f<#Ɲ./8I[_Im6 ꇓ|,DcG[">Q x1k: C#X[&ڧDňej7ض+WQհwh ɩoP S`+!^yRQ,@*w83cK13Ѡ8އݭD}hS9́yfJ_|a| `(hKj~D2|W$[~0 ǩMȵ[3rsn8aSaV3dK˟*ılׁNGIǖ8XOyjzM׭Rc~:\ k=e2]`Lb']6|PEӝmZ{B A6Ŝr&X*غqWKMnYM Gn&"3a6o(|qHbG U%k*I7r[.I-ծiQ e8 ||m`l*S1+lNi;r.FX 23{e@H%ǖC,G`!6b!}x?w74wjakEaD΄,46s@q ~V`R=wKO^_#Nl!31v"14H݃P_ɕ`:13R}:,|vJzn}S܅,Fy2NmPSRW_L" XϔsJrdj`Gu6J;@{$g^F'~nyA~JVeַ?9@\}lҳ^ۼG, rS.ۘlQtL68:a&̀ΌG\}г1f' `Hw}ný6 t2$}ގv &YI1k̘8|?W endstream endobj 3304 0 obj << /Length 3685 /Filter /FlateDecode >> stream xڽ[ݓ۶_Gތ3Ijg.st&O,N$Q%)X)ޝ$;}@ 6{?c^Gܽuβ8O5[͸JcYK>[~ޮ{̃΂9W0LeT,eۖ˫Dtݺºn;,hyhQs[\ }:*jʶʘؔ-u[LWHd15H{yR,B"o'KDɈ ʮnW\y9sj 5 cΥ[?a.wDb3O$PhH˜8W UƢm%C9sW1 /G5*J@`*61M9eubeօ19W<"i5l+"#%VuC/O@ks{nU$vehG}(m)ﺴi;W+v ۻ)WeS«>$R'mp%tD1xה_Za[IRɆ\ Rh)gqdeA%T|mEe ]O:f!T aE=6 Hڠ aQ* -5p)wNvW~!j3m# 9J$fJj |gy̸7?y{;= cjtfEyT6lB[lR.%5 SW;hmYtmH r!ղu΋"O3&v+Y!q<o+}lg 7138l}olaTgs; SPn_:sq*@:V=ewx  gq4yR0Oidِ^S4Jwi#_}i(X_n= r-\Id(~77'2)g' 4R",ܽyHH`8$v$ ($ CzlrlNHNr :dwR vz{_ȿAI#<1x+VaNhL"Sc%la(COM\|)"5|ꆲ7 [SLz{@kGba;V-=MPyI5i9jO2JxΔ H&{S?O`xF 9{!_JGc˗% |0Odv˅Q$ױTTUԾ+QnXRNTre!q(4\afS3?LF3Jh$10n}Hو;:0zSr 倻 ~ D(1H`]2 9 J!<=ܷ Ə<n&a5mVzCi 0X AMR'Β-D~& B$c^omYP9%@?Q˝隠0J ekg@tS~8S6%S cͣź\N"K`ÚY) ێ>_ՄC(`r*.ʸTN\l@+*g\)$ʯQd0Yͦr#]:0;fSFXn\^)>b4.{^^|Er󇰨Giq̦9(HçO(]/&P@/)/4^[-Ļ _NHA ,.zXWjn =vW/)r~lI5%.,ݗnPpwC4c#yU lzFӗsXQw:%l>07aj\PJ&%rQ9-w9@u.UY8_q\ NL&T84q|CÐ$,:u?!~\g<s?ܝ gS%աqy I޳JT򔄰x/qh+mvϽ=gM6fڤnؙ2 Дz hDe^E_[YJ\B0}| stFG^_źwfݔ)/5(b}9 /Dr0M6> A`DCϕAjsp5 *9̟}~QZpL^mm|9FI:G[z܂ =Y&gz$sL/ԣKu98JPɮul'NeBҪ{gA ZeS;'>mr#yMɀiCvl#ZbpgW1I<9]㚹v<ڎV wдWgJ0Cgd1ǝ] *װ%UpZh'W+1eu^#9j@b'sq0``[-dGaqh4)f-L%+"V+K P bMua~Wl>fKLyϢRí:~4&\P6WCTL\VîR$.F蹍oˮ;lw޻*ٗ7o]GJKK'"4y`y23Ht fGwxyETHI@ `gk/a@j-LOV<}"ɒDXdRM@"{ws 3j+SckD:(:~'UTNzB,,i$;ȷ93%s9ag&n$ؗSp4gۚ&-Oav{5զ>QkSQa?v.nsMM&}CӘ 뭈4NB\p(1?n _)W=Rܥy܋͑3fF͎\ԋdXloosE~2NF4o,̡Mn\Y'.u `JclSvMC,fs484 Xv\wd o2C)*?!3 endstream endobj 3223 0 obj << /Type /ObjStm /N 100 /First 1005 /Length 2858 /Filter /FlateDecode >> stream xڽ[n}W`Y,cYām V:C'pjFBn`/dT|)ƙK5^du1Q\9PS| d~Ƌa8g|‘7>kH PD#59F1JFTڻHb$M)uxa@[̐ u|^ftA}|jpH;I)^.6mt5!##6IF 'RM Bya#u`bb,|.`Eo`b!< jb- L}OH&RG&4LQJ\ǤțT]ɮ">Ly&GMVh29 s[,k.ި&7xDo `$7 Jӯє_ Ёi€c6է6½Bb9YKyFTS7 g XK%j[Ѥ;⽋~!f@v fuL:cxm6OTT`n<&I.%m]C s? ?H06 ІkwMAb{;=x`qߏK8\Y/=X<\][^vpOg׾],^-/5܄ X L&̡y,Nle̽O?xF+Ά̏??FX\jq;yHKޕ{8 XQsp\~.t-uf(l3;A\-@)5% [4͆CRO;̇#3"dgol7n/j,7[<&t 8-`zAt6/?Z9]k0tk `N^ c*D-օ|ً󳓳)F+Թ8q ep :;-1>i }?Ol{>}ܫWK֗.tɥK.]rK\%.vɵK]rk\%׍dV6wZOZEW a_s+g9M`6ZQaF֩L Ha*yl4hcJsʒ- 'gEȐ=> stream xr]_ΐ3fX vIԩؖ2M !U{޸AɔXr-h!=%9)L&WIMfI+KɻϻuSY.v]Uu_OSG{$eRݾVٹp/D2SD|=O;QEn]o?؉ڑl,/!*u; H{[mc?A`Dh#u6{TeB̀ 7ڭ˝jW6J9?*y.\~tg##JbnphiMm4jHmG$/gjkGd<%*n`*}YnTe`\{7kXP d;inv7X~\I<'Wz}9]R. c^DH\sٷ\8n`m.cÖ/Sey8n$jJp]{ۭ5ys4'?Z]t6mwgV9s3}|35s?fBEWEYEAjٔݜnڛAzKdl z[L}:u$eҡIzvVN-JSK+UR* T"P#ôc۪2Fov-urx*N*rRI}d;$Ϲѓ, Es8 F97RyC֜Ey:p$[u[T=NOũ<8 *H Ī fbbTf<&p*"6wmФ`z(Mn]W/|EvA‘ ,+&{;㌀q9"> 8ҍr:*F$qw!=nG /y=G_6G;D8LRI&]R5|*NfYüX%e, 9N\+yc+mlbZΘL }`CZu=@;#|BANҢ]Wcɟ :gXc&n㫱vԵ8.ޭL*\E. d!ZAAƦ "!3 qteVriTY beݔD%MdA(rC=" Pp YZ|8u  5zJ'-1$ O" 0 T7S䰛=6恏~ Ҏ+Ҧ(G ;+V#0O6[e gƌuiWxPYپ5<-uB/Ilۥ 'f؍}tn25CכT WUWm†;P6Xrw MpۈSg.l-#ZC I8SwpG}6!n1D'R!nO6[#0ژyހK/&:T9zy-XOq0[viqߗv^˲?99 8xLQ >lvS  Bv :q-2R[ |URcHq4@%$| N6iKP:iʻ`q]V7c|(j'XZۍLE>L!E!2O  +qϕeEFd4`2sI BS20EC9 廉bho xh^`͘a"J1\X1?:avϐԱs/R@v5{eu&|ψeν,g9Qx˒XvPg,X\`"(ƅ/Pn\{5H2ǯ[9#a9rK%#0@kXP-~Ύyn/Rb@z2yx{G8^?B ~ RGZoA `0g fx5H8-HvZ`.Qsdn~;K#Fn˹/%13/6['/SdJ,qW^~L /3h)lYMYJs.gT!j z7OHBy$规Jik€G5A@ BD9k:aCΥ]Fw98 m:T<9,'xc݌84^nF1pTuT<;SH!Pf#drHU@9~Sb ^ 6MupJh ~K@jƳllXL=PM.9-PK$\U$wKM6&'S Շx'#cWMژ)TYEIkBLG 8# )߮8"5㦜OjꏗڈԜ@kOumz#g%jVpH< v3"9;6O5;zOjڸ3YZh#l*O;|UY9\Дxzod L svcbكD1w) -XwB#E(̹o;z6?Yq4A ѩ!:0&_h:n<'v endstream endobj 3348 0 obj << /Length 3039 /Filter /FlateDecode >> stream xڵZK6ϯe >jqdرw<l( B );KŚLNhME*wW|EQwۅj )wGiWژfyJ孫rֵ)2Ҟ~ݙ&dEAP10?x`.[Rh篌[PWk4fsqdvl'fj^>NJhaݏpNXeŤCV/msycSUcgp7'5Vu?~XWYt$誶0{Ud{e0 W S%/B"hpԁ[f߽zGbƀWyz>;_Ί Ha \Q3߃S ]u$xu{b^uw:^ ɪ{gǜn%.YFR{pQ<} &4,BC Z mMvl)j$H.ڍih_Tpg'm:/Goqy-tZa iLqU%H犃6T6vYS4hsn(ܒǸw;#nPT9XNS;.䦪W`+HUn9dИ9rBb ʺX',!u L}^9z[\\)۽uV$tD1i`p> vUmy+B)-k6\}:%OсH&vЭ9jJe)u]UI 5(?b"{x07D4ܐ_@0 _2|7Ł,`3j{55F_UePjTtʻ6 /?R/A$>EN))HӞQ70hwk:P@ YE־ J\0yWgGҢ(AJ0P/l6w$Mv:Q{ BB:@@ )ni)6v":Wʬx Ghۑ)в k /p̑u(ѯh-waM>$B_SNtVgP @#߽hSSFb_ZH`Xy臖vSԇ *_!x@m>\htOF7pK`C'ѡk[s4;Q7ZGpm`'@~9l@k%f/$ieOcmNTJy_;nOԦ.B<_c`lfaC;:*WG{ޚ ]{A 9Z 1-jD0d>y@%/Bڤ˴^vp L c;nKNBֶ,BU{Мuu!J-Vͯ~B %O\ :b|&/v)BO.Ն`pQH+E=̞a?ˎa 7w}sa2N,E2i{2N:ү\:+ZWɀHm3buFbz&BdA/9EfYwa0]N\VG||$GL& 0Hhy BT ofY. F> >n!p;/ VjxF}3D.`ۖFc ^|^rA_SMdzĔ(IZMȵ#0U1SOC*8Ul. ˦`7XS)"KhLJ/voƹZϔR`kl;'<9Z.ULz_o#A[`F,Zu( td8} ,E9'rMlFsH2M83IzoooUm[ε%?8ˆ:m@언~im ~NB7!{ɄR" r* K%ӖKJN)s,dͧ,˚* "[(HQ| *N}!.3!Dj{[`4} Stܨ[X?vR 6 xOL%6BE R1G3%:z5.,Eo? cia +!F/OB `\ kJyn]"ڻ>cݱ"6<Ƃ(f!&=L,lК#KE Ĉ<{'R1`:)GYLۊM4D@S1z ,TlNN=Y]g%C.i:M H'-=<\<+L'9fXaUвk6oXeuw/S׮CvO%~मTg|ge}*c]kGL8\O? -E:h1_腻̺;vs>g1O TYqKU]pjީ_z@ Y$!2I a4 Q endstream endobj 3399 0 obj << /Length 1741 /Filter /FlateDecode >> stream xZr6+撪 }9Fؕ"1IקrRb,.7w{Cg[Iqxe&!|~v`` }>o8\;?Yp{Ҳa4w9ayR-j*/IY<=RVf8;E7YaV 'ۢdC#ftdX!%ʕM]R&x_h>EաT@G7! =_-.GCM굠s2\ܚ$=<S C 9a-'ͿɆyw[saQ_~bŞ C &Õm[k Q+rFC&( eƳb;F NYQIlqͳsӇ*'gk4BJvnUM*ßm-q9\fU82qu#ȑ Ik%GOC*Y0cj^};lC(0#gri7<'!A)^fUp08'u1Ac(UV 滿w}Oa);9=efx+9<_:PY=!RkS"f^]< KO`K:u7ӑbPos~/t. (/\?C\-fVy !z+~&StfePw.TI] ֢CzjYyk fAdE3*9"e6˝ Q, ghܝ dd1,>@bh9H<\[h;Q҆&]&BS%m==n޾};R8#takIPzEˌ#LBQ }%E[Ȼ5DU~)pAك<n$W-zk_!d=Ϸ8ͻ}﹡̖m%A,S-@~Дި͔QN ǖ\WRN^jY)-+K)F jZtxt~Ƌ"A^pCOCo( aJdAzn#VxwM'W"8E+wVd"o^:yW r[ {0osO{YM_\|Vwsk (6l>?5\n ڰ"+sZy@z^^\F6pV=B4yTiye. oƭ4aT+flLl 7|@`Nt\߷;7V삞]`EAr&ohy%i"e1}) wCZoVϒ2#\ ٽ?q!:>h46E*tYۭnSpJB<1=!{D[FA9zrYG-+9Źͳk\ 梇1*Ac8I Z(~B)ԼMRoߣK ~ۆaԴ+"]ڑJOT(:F9+^ Rv8۲ToQ r;7+tߖ7Dg0,/HmaǩLPJ}cү4RDe;N^ w ?+Y$e#k;!`X@W,G垞ucMT> stream x[]o\}ׯcR \pbvSBT)ֈ{w+ْk1D{HϜ!$&ZpZq2 Rraf8f$ި8ѐb/V'{ ɡ8< NK^JN|7 :2QQAU~i7xѴ$AGjd ̢jH)^w%@ -UPM ADo0_3vb6`ZSwgO" :bsBJ0!F$7%-4tcOSw4rTg1„Y*c͑qo☙9 ]%ak%*ktbK>)aFprYO e=)z),b}"eW8ez0HA'0ħs| i'0,E:%-R Gͥ?ͮUOkSg5#T9~EhA-bQ"+"´;Q4 Dz70"k(X_$H]ޗ\M3peѵS`j0bD:P4V.\[j+DP(?̼oJfz|\^q4D]; k. 3d^P6ӈ}n xX Q 9*HbYOz@ = cT9LR .WTaD))j<"囝j/Oޞ~+G @"FB$NI9(1R j"7˫b#=ՆCtd%mM5h CD1,<o"R`&az溄٩8EZ& |&F;Q{aF4|**HҡGqR^3$5Ͻw7{$3]o}y"4a,0{ 'dљс"}ս jMsxGpv8 y}:Ѓ,zzo}LV7RB4D;ZB;l0}CbPxTcO(NR>kj۱}r.WI8 y 8B$7eTP3@][V|%Noqp Vze^G@S'(,2dn^OAR=Q VĮA@;>H1tB &!#~n[MI3 3nNU$-uVn*3jWpYdj@6@ &hUfY[yw:ZƿUKש3ŀttG<@kDPLg Vn?lX!_[ ȝU5be" MDX#d"5^TxUy"BwZZ]SOm1xUw=NmҎWgIg3"-dLjAJ\ y;mW *wL ƩU3s+!O~f 8BbS39OAx5 fY1_ގҾFdKhw2d endstream endobj 3450 0 obj << /Length 1891 /Filter /FlateDecode >> stream xYKoFWHf${(IuSG!Êl"r)ί,w))ۑA=Y {^_'O^H({GX "x{T>.^wcDOxh;/Os!X`A ~괺ɬ ?VUZoWT:+)؛dSadIZqgMgmRuV\lsUeud[mf**jVE?/SۨʲLuV_3 D0pu"٫W4N[*o]Lw#I{~:## `&iaaXuZ~YٶY/y{ Lbfڣ&%c/ޞ9 5I Njd%e?R< L*'PZԘzyȍz2-{ jxu##/R#OI/`dsDJ"/f7U1y8wnN0}7w[Oχȝ(h bR||`ObpRнIR` `o.BK]A݌]j[fͺDfg6+ R3G5tiZi&5^!QˉKˉw@zjv- hb&Msh~UL;=mlMzFd,A;]>߼UNV96 h.A @zDp]&0pFP0ʐ(dvH1hxR4>ǘ=B8映 xEcHP:n{sM6IX]2 uEz-gyw|A|`gmxׇG.P endstream endobj 3495 0 obj << /Length 3329 /Filter /FlateDecode >> stream xZYoF~#@yPv+;6njc!'<(~54#lv쳺LjF߽7w^,IVSh#+/3v1ξnl\)=&+t }j6b.b:{\-TUXM[7޷Ŷm\c^ƍEVl֫vEgwPtM%1IXDsFI1 &3-pe7F,\HIabh"JDG_lMĉNn_ӜDQ73|D[Whe DE?X9`M^n"p"&"9nj!$R fnP fj%_] MMn_pi{JuEq $0OP쐯@,-ls9?}DM7M+dT`,]PՀr|08&wp[,>C{11t" fUZQcvCQ5/'[Ěp?E16o4 (8f|ŧ/?g?}]<`MzN -cmOg~-Pb)`>ޝ?@R ,F"U#mOks8H@;־Nx l, \Ζ{ϸ L@nQ'< Fw׷{GF˒Ӽp1!Ľ]O^Ev MggR:Q ߮.OԿy}۫cHSO)U?OW{JwyhwUPJz{4Wt1I\`ۍ7scL_Eϰ[)z:$ d&X~vq_l Cg Įy+z׃a-xO@%3p7VPhܔǿخB*JL5f`$t҉+P. 7 ۵ {x+u͆%՝9I70!gEY~iݿey[Qs~>^ْYԑHZ$$ L $g6{O*Q?Kq\# J>S!6]yoO6O8m?]0f: 5sKwj9]23v+43%k\̛s8+x{0ຖ~V#+D^u/G9z%,0]r]KjqR>I e N53mcqN\Mؔ #` :E{#~~o]*|@թؔYRWlS\ To2*Welawn6'Jp z=9`ګ갡pqHuxb pn6C,s7 @S$ǩi13Lj;AKW%NKeʧxm7Kk^{&GrJ 3,6B0ܟR&NLb6%:+\5R#;ɱ#'am*)Z^*g W_c5rjeC VMNZ C?~;{k"q!>'SGz7C9&cOFM +\q/'x7xł-'^f+(SH`HzJmŧc`g2r4BNd endstream endobj 3530 0 obj << /Length 4341 /Filter /FlateDecode >> stream x[[s8~ϯVU1LxS;沉N-6O$RCR8|$_R>A4_wCf,"8POaEfqy&20Bj\/~]~ȶi>gtZ ir=#Ħ8;WF-ӺζWlMzʊ:vnܨnWkR=q ğ]T_ij@@aa^hX3l2"IǍ*5ɽae|rXq?Xt>:Zs&~̹]\`_AĐ^~&mKKCI?L bUn[ȒVrU}6yYK$G6Ƶ⫫|VMd͋Z[(-dtsSVys΍4uVyͿzV T#6Ύ2~sy&YeS6L&/ ? \OYU_WYyzSp lt,uVQMQK.fF/kƢ0cQ4~|H?36+G JV9TZhUduSW;> k7}}he 4.5n!]S>u/jie3#_CQYh8Yʮ̋8%0/o?| LOHa]$tXm_[X% t/[Tb6/ H%F)iPrcÛczOiք- մIZqbmM-tFӓPcƛ_޼8T"dM #5q &D?˜Z a{#7&Oic tYw+vmЃvƂFK.C/h-kȗ?YvPsDV00B-c,aK+tZwSa9UVdJD}48(kmp@_dg_)w1Š$BgE+x]_PVϟVR$8daA<'E0%ґ r'i2L1քqg@-z@DHFP!7F~Y B9)cn,ğw#tENfkWF]D=~V1$GGT/}QvxrjCַ~SjiiyIdj"Mrip}gɢũNQ>f}T1. ;j^eŪsl4I(YAL0!=_JD;!s edO9ħ8٧TVAU֪b戜u`DrB8皎c)I|$Koc iLY|d}%ӄSK°#K|"w%#~!~5$-+S/|l~,^LXc&IysP'JL܈-zWkn3ffɕLK }phØ)(;r JjEx1Jf(A#px`>7hԼ׭_u=|Щ|6u{TW1[QrIc@ep8Q2z0ߙlB ear7G7Є[bwPvk!`0 g1<͏J՚R~R*:z]n]o}ƄUg.!NƟ4{B@{tcq7 sǑKyw+p1Gįz{ջl4Ћ 4幾m=7scU*Z9½q׬к1OjXE6M3 ղM.d\ j[7-?~|<;ZBjqol7Q=gRݵy1ذhzC2aX} $FN&loXI7.#1$VMdotviൌ]]gBm'l85ػ߽c+tLuk6K+}'zSSG}0zJ0e_2H!gFԈA׃'+zڝ筥r1W'#C K'ACnd]^AY][Uo(5#1$ry2" Rr}5'dP;|M`t `9L/_+4UwNFo]!ԥ5E U Y\)q$!˸KtIvclxNj(s0$iC=Դhv@Z[F q8XO|-˚anG ѱs҉+Uu@Go+uûT:2޴f-ҡc'qT] :.%!jJ:`5?muƵ~ E _=X.(Y?_@#۵$5WȌH''Բo {5iV"]}mTxWu4Ԝf\9es"ۼ2fhZ zW~0R5.pNr7{sI^whKΊw= z\ ;vPmzڥҽ:sɈ2;[$-.Xh…TѰ4^ƹB,twׄgi ?p8M&yQ婸. lV@0ކ˫&mcߩrG{~#u 4)sOdH8bȀW9w~EuI{lEq@KafA6 F7,`{'g~ut\U)k Y#Ěg<f%Bdͧ[ Y9Ͼe-")sD.cwH)8 5ޜh endstream endobj 3437 0 obj << /Type /ObjStm /N 100 /First 1009 /Length 3028 /Filter /FlateDecode >> stream xڽ[ms7_͔K_2m2q:w4T[M|I$W{\Q[%fg/ΐJLpI$BƝPL^#MI`Ƨ02;} %P708([|PJ P0aP/S"ny'zK)I JYA([QXY2b#J9K\)DWp1SJ% ApCXAr_gh &clBs1 UA]Pވ=12LtaMHaib`p]bQ~ٛ"$V4W|Aa &1KPL ŤqFo:ߜL#sT.X\]g:^hYŻ%$̣dS\ S"StHP UYSU RAG㺶PRG@B&uɩڂ, E-B6؀F]+X: 3% '%1f^I A2rh!` :L;QfXLb؈˞jib,0qJz%8P Mݛ /:|XM_W`<-_:8jnx2<|Ib2<K RR  \m{pdo/fxd:Njlw7L".ؒy#;[i8#^ȼ` ߦ "3xA3<\[,Φ3ǟMWrnxoVP1/ qT7!XJֿ#y !Nuye<|ſ釃c'os}p8<!fl3<a7Eq\b厀J 4f N@iiao֔rz9={3A-0f6[ďD|W.[ wӌ  `Yx#jO,=y!܏72뱩{S˛  X`s-ALY:bM\_1ʵ1',!l&$7(hc895ΩqNsjS895ιq΍snsC u2c"+`=<rL$|OolM9m8gN:mV,`!$V AXR[(b+\_m |W_#~ Lje+1guAF-y gaXjw֊d"nG0O$:P=4C % Zfd߬/5g2erN>v{w5C$坊XҨX|@eA Zo"V+9X/7Ogzt{ux;bxAziU|OrYrZ5aKo9% )ٱ~;rVޝfnZNSb̊i r@c&ڀmF7<ȇO/>il@Q66v8Ȱ=4Š pN8ai=`BhR.%  hUZ6+k?j7*]z,!vCI[ş\' Uymh F_HҘJCHATZkmf]4রBrEukkEkk0qS+:?nANne$Ir+V&)LRZu&[e5!HȍhqƙgjqƙCj 1Ɛn| p݊|+ރk׭ɧ6_C/qh>8:'ӀDf :K-zDkv$"v7ܐ8jfO..2DͰ0Ecpzے6 =LI !&eAB&[ 郯XFK˨YY YFW%VZ9tq#h>8:)r 5k-w CIL5rLH<Y^ lyLxU(OH6 m"!֞^ѼW%_!xVTj1n4@MҨu> stream x[[sܶ~ׯؗPS ƕ Ƀ8;Lڥ ɕk%>-z9/?w]$,cZmb' %COb] \NT*WDyyz&vvSWꢼߛ¡*_Q=~Sͣg̙澡x5뫪ҼggԤtrbmթQl-kdn(AҠpU4&+3@8Oi&f-,7T/7|me &vG6_A+8 `VEl&XnO>+ۆ;u ]Sffq~O/#.+ O1L*;ӭ 0XER*i`T~tR9Y]+U}]GlCR4AxJfo͐VYl2 'Qf9+WTR&Wac6d<[yItV sTvm*T]+/.w x›u&H^ܠ7v5Y ^t.Ӑ&<u0h;ku^_MHz5+1,Q%jzXV/R1E ;9$i¬L^\iPUE'L^(+ءr5N;.a-MT8RƇ62 T{ 8Pʖ&d)&!(˔Q, Jay=o ^`WK Ў"FT FB}k0CҎ=QPrC~PzHF*cd/;#.h،*&A4K9$=\Xb^dvID~2ĮCiq죉ǂsݺX}8aǰ>]C?V PW#etY@5UYpbDN+jw2 72Vk^^>lOxfr^u9~;Y aJKoV46]UM9M@|SYW͊F#C9邍>Wn"]=gt[2=\M=5^5 5-ſ^|?9V'F3#R}) ^29`F ઱a;{_LT$%HL (R3%, Hx\W(ԡç ,kpjIPx1 a왒 À5Liޅ`m!Jɻhw%9ؠp̠Ku6X!=R rc@Ktuqv'b+v"crrD?)KPM.DR-mnO hꮽٵxXzSeI9HZgɰlT14Wq%WOa+7zoad'e_9m<]*O> z p9ĎU D2V=~*vL8BVuklɯ]_v(!]|s vդr&f59/ؓrL^7?y>qM]I*g{n,̈D~f\vѩ(8EYy.HseZj~q `赟($jM,!71ormv넄0>ޡho?@/s_:)3Mp,q)ys$¯&e苗v3 _T~>]MEBdʪB.<zb$b"gncafY`m9 >Y #UH`Vͦc?kE'*bEdy f@&%J%BDoAX4Tt"Mj 7l~_Ȝ`Kx; pJ0R3&r;Nf3 3%D}k/n[XIgY˅(EV\%X Y`4hf?-횃>^H J QxJa5M3I+?_~Cgߣ_;sg2~L\Q<\l->RR{w٠q>llIO[GX;HI0H)'\w7˺ 7|=jنV:kqS2MxZ Y;2㰄WL ŹTS% qp዇I E+͛SK˶Ysu l329 Ue\nXz3ف$;\8{ 8|֚ڷ.7!pWMp|o-i4}#A(gDؗ~8AGw?MzL D XX)n)e,Wcu<3@F>t&'>GN}{>}SNŰ G$F<{K速iEOEXؕ},>fWo̬c(_i!=$åe5VRE˼n3瑰K3&хsQeֹx( εef%7Oli,TϳO2Gu|Chhea?ηLHYXid :;st MLAze0ݡ/ƤQx~8>9Sbx?6ID0+H1ti#llv 6]! CGIjOGELlG)t^ԃ ~BD%'g?}Y)'=OQ`ͦp*B:k=<@S_Q8yOYIPܧMpDbm1k:_W#6Fpşǟ Ab 2_V @ӧB'j>l%A|sIųI'z6(;xuQ?> stream xZ[۶~УvBp# fm8{ڱ@IԊD$98DRܵv:H 8nf|3>ub13,c=̄N,6J̮׳$ZȈϿa"c[XAW۪XԿuW2g_\GuU^c]7Tlw Ý8㑜-f KՃ7vuպ$a O!w95d]I$ՆEPiȷW %x ):PmMʹgk "  ctRDuxIsw3&/>>F K )iTGJK [BvVgp`uhMt=y}t-4JiyJ2BD ^+髪{|Ҕڪ.?n<_CoPc7-p <6Vh=֥R$ )Y5L #ecUGS N9#~0+Xk+_&K_+= %RY",tK̅j۬ԑ7UQYK%wzCu$q\yܪ'b'pBl['}\Bz&'2,y% hed^bDMs!bDFMQʽr8',+R/'~n >L@luWjaMA;n >jQOdl-b;vRuƲݿN)$@8U6~ Ӈk`ԝzB;sLKiPb+L.߃6>̀ Fgycs8"o8iKbJ9Q.Fbbz=Sg0T`kݚSE2jN.BJoE4~#ԯ:/ ;@OP8fR%a٥|N{Y@5O)z jN B3yqR1ӿa#5nqʎ? awp.îlL^`~V"]Maî*zip@`#IQ?I{xq8-xU{NGZM0c 80<AHnxvGMpDG\XX8rI|%b0NfKy{o;;.w2Wlr'R8:"Q]d|Cq)`^¿cAjX=`A$$^7~u8`gs#6snzB $ 3{-hox=zqn.n-5nC)y3v$&SOHF#ȧJ wR)Zܠs!W8C?.q;.=>(e̚,}#,)X4sw59?P%*iB odYKB&{OJS2ԥ/Mߍ'ģFC0* `kk,aQsn~l԰ǯ@V&# kIV4a . &:A K }i?^z 8se~%<+]>0( Q|$3ecWH͈P^ë_n%.sP,rp@-̀K7ujUݸM]$ձVat{UG^KTȜֆh|e&-G{*㖛XtqL0ھı%J-}mn>@{ :]Or|crT&{2 L`UyCcI.#Ej݀ݚjU]w#z`͝sp5UF3QBŁb*S%c.$& Cv쿺J) endstream endobj 3637 0 obj << /Length 3382 /Filter /FlateDecode >> stream xێ}B}8Cu7mڋJXKBR_s&. aWCrxܯ_|woֈERca!eŠIb&XܯUީGٶ`Өd-+oCeҖ2_MOt5.mQg_J8/j$)\ ¤,)q$_xXĕ Kt´^|A/{p-sSݚ8b%z4>f=ڞ3 |'<HDa1DaaX*QnXz%g-D90 L둗篇iQyաV'6fM:58e8c%z(2LJ8sZ ?"G` B u$NA]乐,H{h7I G 96(9+թI8wyE=I.zV--7g/DH> SrO|pWgCn_f֪ WΈVq%N](%z^}R;)_=Q}^?T._q(Й&P&Bg\;w]bkhGaDσk >y㩠S劳$.1YCg=2K@D:{:@yu֝L)%jc͞ 3i|*($+]pɱ5^u(`9(Tnl2 djKjO8t(D0t(8gD]1!Xb:/ w@1 LX j$՗cفJM3b( @]s%LSJ{.@yi3d'OY%VQ4A۳XD_l07o.Oj4l` 86M6 &ZԿ"!9dK!ztQySuѣ{28vFd.7?&pbEeumeVxPGA Z*}u7߿%9҄LXiB;{lC%3]N եOc$ft*{VI|3xbO,|45y " BzZ i,U ^G]N/M>d[LUBMOZxZ]σ4>Ӂ':ڡUb".?Y^ x=C!^G ATJb@++?o\99|kJcjG+kPwxɹSHЃ>F/Cvض8\)F$E=Xb[OsAdѫ+"^ץv/uB@Z[zԅ|M+>@ZB}C WH$ ηŮ(3o?:ƾ*KF7IMXiRBl_v!A!;bT]?KiNi xyPwQ 2|Rj0)\0Zy3=(]>`sGϫcr;[uփf5 *3J`|W't:h/~fד0m4;jV8|gzdsRV>I XA]2fkt8uhO3*!k9^9Ȓ&bĽ}屔'Eۘ񈕆j( lZ3p fmwZ]6Q15C]ȗm:\fXM:aH6@ 5sǢYi&B7ޠXP+S:ͻ_b ~q)Hq>$cD.>!@%)_tDz,/l<d8n{?#P= ʟGWa]0OOA|m:+^!~3;7}Rj4q_YqHlZ-xEST7qfзQ{c ن%fs@:#xU^bi׮A"5o"5t@UCw֏ E-'SM+1l>ߣB\%14p $_#q{Muخi7yK 9Bq'S՝cΦ+<dȜ=cPG䡬'D͎X/="KD@:$ 9O#%ylPrPUjU58$@ijĶ}#_p)sUVv#];f i|е$M@sPPbޥsk?F^:A h,|*>7P4HOɆX%8Jrvz!s&uW!v_?N;]頇bv()ISDG; 7dV6;zxR ezL=GϝRPțMZ? ^͸w&dvh+lT*9>R|t7֐tŸp :mQ&8l ȦZ}/>q:91UV ߚ+Y'pN/v'L%s;wmRxARfH+m2zr endstream endobj 3535 0 obj << /Type /ObjStm /N 100 /First 1016 /Length 3001 /Filter /FlateDecode >> stream xڽ[]oT}ϯcBRK/BE<0j# U_' M&= )slbꂋ)Fg5_NbAV$RO5ᓘdl'҄-~r3 NRKl3uR3G5J1s*JɖjjleqmqJhU9'aii"(9FU(%G#\H&^h 3됪#&_83R!zLJ ljϒ٥Бa c@l@PXյ$cZ\+-q Ps*i}-J /(&|!eju gLJ(MC4[ 1/&= %PB(R(L0B0Fj|`^ᄠ`S1f.*V`hڤbH  -GKs?w_[w斷E= oе/Ńջ륋O~:l3<:ޜlNݿ=FzäuYm;4wn;xZTF i4(K=9܋֫ˍ{ ?t?6n?~Xr-0lsx:_^~Zww?K>0_;noVr듉'ivkhѐшaFcH!نdӐ4$!9 iHNCrӐ<$!9yHCr󐜇<$OvM?9={{n~\} ?,/V x){xTD->zV/VO_<_S&фj<ÃG3(</17u)i.HAxLnHs,m p0| ¸`͸1%G+|xFCGOga0a|i*Óӏ_~dIQ/|fk fHُL hяOZN#C@[EB\ap 5 |O͜p;r򂘆+D+|ӇUW@+ Y<;5hH9tunL&|UU\ F@{4iJrZ僡MvS̳ mᆰٓN>`ܞxgˢe8t!#+t'[ҿ9tPb6P <(sa%tH #٭E@>)%V@BXLQpŃ}RkUm " )'őYp$Jt\l ]ŃQ7I݇" Ew"N:[|8,@G+zkdF "j Rd$ s7~bH$P1u҅:{|EL40D ,`a|-  8qK'r iz\u@'ⱩH,@[7{NN]#A HނMj՛^9"mC`Mr%I`^"g?aw/KPFi222222(:(:(:(:(:$!uHCrې܆6$! mHnCrېvyDkh蔼*yƈ #}dpْͭ'-O/Sc}1S dԭ醠EC=DP@G&6&!8""F iw)v)# z˧3ry+WLxֆ|#j0IEJHn-']8'@l)Vm#ِJbED\74ר8 .v<M@ Z"]@v!%+Ox&4VIb 80xv; Z8QowHtyb4pxqR?n5JJ%Gc E u ٓMؤ竑lV‚Uxz; ]'$wSWpz{i$`dxV^QC/7DLvFxaEڹ-52*PcZKњ:+eK4ƀTP CU 9acG& )FedjRms6!/!MP2I'|8*5G0oV:p/?yj}|NL)Ӊ7j=;8W^ܳ8㖷h\E̡8)At]w*ߕW#RH5p\8L3 iXq\} |\+REaNM*ti :-XtpK!aݘ69^\Ag=1/y>/' UTsKן{Pm.f:AsJP2][;WFb KwT• endstream endobj 3670 0 obj << /Length 3388 /Filter /FlateDecode >> stream xڽێ|_)R p$EApdɑ|}g8nN'Q >x\oû?|"fIvexaaz>/OkMi7j{9[n;=b%S~@Eocp/\dOS\|o_鱭igvUi8]~mU΋}AJI%)$Kg Zu ekȨi djQ#GrNpn}:esȸtcоUMM[Káj6GY4Phpv`!D%t dIGGnH0!b[yKׅM oFS ۯWQ_FmҢx&&o`z)|j R+: y&1-:yUZ! в'ٓPC&YH/#1 Z"b8ֿZoP'vc9O˴xnht?kTH5^Ux:URgtC@|"5/ay>)6Uy?xuotHkԾxfgB EQpD3ewsٞ+jz~4wNZaJ#9J,ȏxw?. (kQGaM'uuI?YUuU0mu`m>(a * c'#RE8f+PȓaWR/ hdK0 KdU,CC^7[Dp.m4"R$cu^洂XiyaP]TB&NۿV[L)j+A_\頰`$sl! `*c6nu$ ,_$ O6m]@dͥ?| Aa*6Nqj{j Nc^ ÌK䂳ȟ"[=2&~ F}j/;q_7݉E_\Fg'Ed#݄,v\h"x]X[tjsu8RTt[ ڋ$odˇ~F#mpAcz'1-{>V?LQ"o^7G*ᾺL$ڍi'ʱw߽[&{oA M#Q1bYںCs\$*0H !I-u&tX9)Y$ώϖ ݦwO`qewׅ\b̥*b~xRLj$i V /doZVVK/~Z) \>i^'B`ɹ[`WGl [}6ӎl %O }1+8[xTԔelܧBA "aȣo#&w5ͭ ; }Q-A>xT@ufLDwE5}{ƙOe +{ڮf\Ӣoq~0-Fd+G`@U]lTo08XflMӨ,\Ҁ\cS0bxO1pApJ+܏@|Ȭ^wKx,_I!t[%;Q[G 2qA$n: ~AL a$P~ nXPm:;Kr}wk$df )zAv{qBB٤c0q *ݼzKI=+qxPO p/G.#i#9QnƱ!*nhn;tbV]KE)A:jP A [Ɯrݐ!&kC8+id:~3#уAC E[e4H3ˁwHznH焭X6ς>ӝ+@X_skzeg2aoܨInIndshxfT4čvh?x܂"$b2ش^@ x3w|;psu?F"/^N..ߑ r9hNF8AJlDx$"jgvPS j?ѝ[bVnz!B&ID?]sL;_Ud ӗ"ۿgNP^8dddѭbq3oB1}h}0?jl.//cdEk&{nA>Ni%&!gcje"- ЃyHBy1.p\7ŸB5$!5uP4~n kTZ]S7K8%/<9#;5[|_(+K\l{e.3448b0cZ&nPٛӹ ߚp8}VCvnǞmՙ傎D?1¨—(+y78^DQ%lȟؐ7}W Grb !gb8>1&BBl} n>Y!;ǁ6MK&g ="&Q-lTfO&vjDq&b|P ,vC7u.гng^ej뒰7/~nk*aBմ*_*F,_A CueZS=u!}Uk8PQ*Ss q#ΧF̒bcue2_ Ɏ__/ Dqɀp$LӗW^˳ƻ+17 Ҁ=%q+|AN̬e-jZgD6n푺To۱뜓D>_X X@`]d&SzvhBHhn| bGǶ# endstream endobj 3716 0 obj << /Length 3048 /Filter /FlateDecode >> stream xZs6_GzBMsLukR_>$}%"U hG{ ؏.@ >ًpXkY0a-֋4Ot}:g*HiBW47MH W 0#`QJE~FxcExo_׏TQ.?s3M3e*X,$[^Iu7E`Dy~ߤRhm}0HQ*#e/¾j۽J5 ]ߦUJr۽ι >sMV^@wXUiRCed+ґd1Mfm|G/H"D#I3>FVB]^fMmW[]uV&&M}mh7O|ʭm%:/Ww]YN/~]H8$`LX"Q5$u:!.#cS(֒V ֘FڔϮ*q}X+/?6)ܐRq$0kc<*K~Tv%/O!ߌ "_5`PĊy+I"#O%,tyʞWf2+ڲ|N6DDpr:ar`,0>80SvtIKe KBgچϨj`tY^CW?+*w1 A:鈦ё LWOiTHTyi#kO *WTSߡƜCR3D|0bY"2T!'!z(SOaJ:*1!xU-G'B<b@<7r!hMѬ>8>L2ݧ暚뛙 rH&mm$ N2jNīb&fz@l/Y2zIisid̓UL2E4TD2K/3g%sOybS}T]u P,kJ}uO \&cJՇa6~\?E~L>T%آ`Ւyx":A\̞6Ar;I ؽ420i p-6 Џ̄a$u].6+j!gO[C"O T0 Gr[C! jJDÖBdoeomj. Y'@+ EHr"1-PŃS9&=pLhel0_"PۤC=窾ꃭ%2Vj^Mğ V=K 1,w@#8f_=v]? S ihW7AK{}a'3KH<59m㇂IU9gyOoi eKw+ \T \uQ~3";GkGKm3rDsvo/Brl6u3M)td&I bf6'yk"hs_#[AKLٍDaoOZ Ll`:Q5v l/bI*|8WG!4t j$dދ{OkHP)sj(1X(r-X;b endstream endobj 3772 0 obj << /Length 3314 /Filter /FlateDecode >> stream x[s6_GyBE>_tGq(آm2$d&4ZSNZ6xnKU31kj.JlI嚾7e/xe~F`,T8u|pkƗy-y/bI&1r T2I"T$T*Hi>T噈eVS5z[]ޱ ekEivvIϷ?}92MhUeuGiWf?bLΤ?cWSBR1AT}SzM=0#1́yLnŢ:2P'x \9nU"-({}&+mY\mn:{6G'Cam_J!)Սb/:H!&:RY^}#WIR4|)$&iun-RCaGΚycʆcZEAuhŒEVeU[jlfc>}wԸœӖg2ޢXbőb=99;K(q;vURO7vUkjN:~|ob^noh HR!{W=dU޲ uuZa[e6Xl?fv,J /a1 U!+ZFl e-]e 5cMJ؁ T닫s$?H1JOcKV):|:C L9G6K I-Wl۔ݚ2җvTfjU*U;gL"'*qGYZN@aEBOup͖F&Etʯ%Eè]Yfs>qEzSwSSox$ UV󢠻#"/g Q  KRQf(2سSD(c#eD̬2qXi"@g{7-X*zխ1i@ڑ릵{ߏVriE쮦@ϟ3aA&:Ͱazt%DH0|'KM&jR(&/=\ f4^|?8JN#N1keW T`=F10g!w~թd;w߆?{RpcBuϤ}Mu'L'MrT3%3ip#G@њFR3-AIMX<y"3 Dgp²=PY4DO'\)#f}}"am6kt A<0E=>qdC~604,O;ag-&jLE$VId&$ _&6۔X3Wӻ*9$qXXg੆WO)yvzn"Ns"[p"Cq}Ci7ɮ>|P/]zҹتEح5[HQwj7oV~k*I)+(hb"_PHL `ȹHɗ3+Ѓ89Sۻ"szub5;a_Ѭ>՛tA= >8`1\!ᣴXu xd$cV1jI&ñyHk|"pz[V~I~mLaYW1\bo VH>S}0N\B! 2NDOD 3!<;هBxpa3o Y >W΄1osm#Lj.bMs!l< T"&EMp&DB@ ^Lb&ԓI xGX1pŨp#Eڔn8jݔ:\(;ą cp;w S&L䃄#xFk.X۶|Xmv ] ׃ 㰸V\^/yO13*ѷ #z#zp8"zۘ*=Lo"c2#dF7wSLg&к06L_>|I˙{5.ӓ [qRxGO~>43{ :jzKTua0V9 )e7iqolc 2Y(XsyIȡ|{CWSSt$=p;Ƃk7f\]Wdu{! TԖ_M;csmwQL){E`rVi5 z12yхs[G*n= ÊtiQԸgݶ[?j$|7~t/jȂl^8 WY+Ct2UjKbXҧr=yT;Hb!q7ysg#.RX a -6$.Cy( j ` HP~"(O41 ۨC<?]p]RJ0"32b"׏bpst]Ov]* #w8OÝ|V& b@Bw,9M!${|ĥ7KY￝t,tx'L > endstream endobj 3642 0 obj << /Type /ObjStm /N 100 /First 1010 /Length 2917 /Filter /FlateDecode >> stream xڽ[]o\}ׯc%C QAGiY$FSɐ"9ܝJ{@;ǹB rQFV1D29HkhPpC= 4A+Ŵ,-@ɝh吵 GrQ;$DA0 \a -|B-Hm=p4ՀLK9{xLJ1V*5s:l}>C G]G#hRR.@6k%k%mA\PSVbYJjj%+kќBՉRڦNX}MʔB+V: 0OZgl̑H^܏te|#(Bkt 356tJiO0(^ 2$t5jm[Ⳁm"{cK k #O=U4"#ŋFFM1fPoNS0J Cs.-R9MɨY^M81CZLy70g ðp),C./eƹs%Qƹ'H<g/NQ|Q4_6'=e.ۏN&yfSn6Ϯm DlQ`C-8ȷg՗]^>e"<99Y>v~GwwZתVK.꒫K.撛Kn.撛Knm{ȗƻ/ Kq 9۾[?눙(Q4u"8~+(uĪl}h}ׇ.lՈ*ǒ>/ 6^QRDWcI*-"\ 4 OPD6į!{Eq>yAQpecԈ G^KbՆvQZ[l8.U 번 @AgI&$ֶŲZݡ@C&і=|B-Mqd("J4HCEUSt+ 8HpBuber4`}nG1^J@ byEAznOD5\#*cǡ8,H6Ȣ AQM+6dAɌr}Xԓ@pHYt_ 2Qv@3=mXw ĕρLH)B/Fxfi;eb:Md sF#@On~5~uy+&/EH8533LC,8bsO"icԒ#1eVQ#Wk"˺vX%ךJ,1MKfeRQ"|oO&ƁNiÑ-ɦegd Qryw$J-_9&ԚsR椒9]e2UtUw;]]rw%w]p%<\p%<\pc+_!A|}KyI> }y:ucz7/iAX82" Q5=l$ʈ RϾxhbi+;$l/8}| QDb<0KVO8= ²x"khwMd|ݲoE ۦ8`f3)cOz;Ȉ}~$G7A-fGLg>tN뚏1:1y;]^\9NH m <˜\KDQ`z =~j(qi=*- D qX!-R)-`CLf˃sr/ 4)"e? @<6ErȻx8/l1Cssn v V(eae]w&E^[^~߾>J='dշn(m[ dnv2WşJ&ibq;U;U;U;U;U;U;Uξ⒋K..Y]dujjjjjjjjjjjjjjێץT]h UNݭ^ϯ:|%Xo?>A&dž@8B|.pئ=GDCivګ̰uͶezɊdђRgb ņh> }_C k?_,3 /{HӳW^ղ*i (xt/oy~0 M%^NTQ endstream endobj 3823 0 obj << /Length 3408 /Filter /FlateDecode >> stream x[ms6_Ldgz3]{Nu~%:T\{/(ђ+I?@p.V|v'|'_`$ef"aҨM JL_p_\v#>[iLbAmQ/˪h..U[_&zjuWY9/./$bFnvH6\9il|b/b֤KaYۼ)eBG>TO٬h" |~gf&<_evuZfwndWx.p1ęTv P]o@Yo&YXVU'Je,:,EkzvmQk뚖!3- ͧ:Xف9+$[[!zt i44y=R H?HH_=㉠'|K9F1m&_~9*K'r";@ɛ'*~ I|o?m_rJ3pg!~N.LJ ,3١]6Ctbd:`T$<%!6IqR3NϚ䊥InX;"~cm 0o,ᰤbࡔ8 sY¤a..TaũTv(XSJYN s^!VCcjfM( wbAΘ&a܊ v!KCO{_b2cGʦ=l|!}l|'*Ww7ETU-^uV˻UUTx%q,!? "\bO[(S-9: `}\U~H%LtXT1k:TĤ'&ʧ[6ߊtTwwoO}v \ {fE%τvp0lhXH$,Q1u)? }M; V JmMvyOٍ>$Bv!GH\jLy!/iz.]@R"@W%4b1 1PZYǝ^ '^$aN+ =]Ut'jeŮ"m%n|:mۢs@e;Bvv||oSfS!d#%W7R ;ј #7sOI}FLloLt ^֩"Լo‹av/Z,Ry˃C8 g7um; Kbt2 *QDg@ XnĹKG|#abʙM&Ì!x+6kz^Tnsڂ(Fⶈ M eWN$RF:a҄6'ޗ='Y TJ,݀d3SI\G`/.,S;a`s5{YDlFѦFR>֕LoWtCDHeāSØU& 9k83 oh7=nfhWK_@A2<{Jr '' m]S+r`ox1H(ͽx C垀;H9 2E5z}]*N5Gq5P`-K;}C׭a U@%nڞy#p}% K7! L+cF*XK,wynmYQZ/Z.6 n֕ R 2m2.b"}˖"%ܽU.AX:;:2~n>Su&LF` ѓuM fKeDǨ$Dj8g(N%شQ2_w.i; ߸[x^4.{ssOXWB.r,ҹJZ)rAqZ溯^˼}(ރJzG ]E_q+gge]#1!C u8 @u9vRx_›(<=X[(sbF?XFL_QHqBuE^Rz;4zv]C>u]16k upR5vdf S62Lc'u"\[UNbP 1h#'.f cj;p˔Mj|.XR6*[yqCUeFECΫF߾ZjgaYŞ>eAq[ļbBur5/Ժs{nQ-p@tl??載KEY?7rso@ nȔ,u+*}؛xyӋ<*wj/'%+hܣ{}-D_ Q,]}C;IsKTut ?kW]Tb'@'_J> ;vDyF@CIj_ٿ/Ntԡ8t6X% m޼|>eYd)]2!QZ~a ga΂9{>gN%+L_)w$;ќ̡ܖĆ@#Su;Ug (%|uл]q:*~.X.yEu #ܑʰ.@2AWi7U endstream endobj 3848 0 obj << /Length 3650 /Filter /FlateDecode >> stream xڽr}BM:S 03yIdfn3I(Z+ I|}x}MoY4U4z~s{g%Zdz͌+t$f*%]gBho?sg,&XHu=4yY\ͳUSV4OnL0@c;꟞=%\ ?fln|qb}2$7{=!fXؚӌ>Ҙ5'j(DNy =0OFyꦬF,1i4g {כw>2>{y(l!T2hd3%8K"\>a2aByZU݉H0HX8 a8(`"5PʘYi^=) SœP7h~3e-,:>QwCrZg« &y kS::3VGlDe2G^_# CT%dk8_2dvN_$,+9-7iȄ,@B Q803pJ7xa*-C3 yhl0 H1:L(c0#:{e Fhaz1cZ /8AY `fxrGiGHi_*W7MeN0+LY_!Zi]g6Ht ;6eK#…n@ΫC.2 F'z~I/)ymF](Pp1Ϫ C3 &Brk"ԙ_HَfTn{OuLtշ?_[1Wg8o57)gl&nCO0O sTy o%pH ہebRwmpRh ĐQőf]埩B/xv![M]Q?97*QLL2N ނUBLW_ )(~c,8hώgێ*,ĤmDL(fuRy:"Fds[."!'\h0rL]Z}"`UAU )ӈ  TPXD,6@^L <*fs>Y!^a +CM 6u+WA8P@j()'rޣQ2H4rL ~l¢"ʡE 1u. )":cDöwg`Ϩ3ߑnڸP+uϼ1OJDreoGɯNBh>w8nm&I/B+DbǤ@yTkEALbuz<tdKo |U2H qSNlv%-zP2o4ӧ_? !I=4}VӎňP€3>lCOF%ΤBsZ3%iXu<|,r$|Xr'eA=KEH$y1 y9j;uFJFkqXS[I53t[͛Kr+V14unZ gwt+uqO^Gz~Ar3EEal[ӾRc ]@(\`hlaپT*;h|E瀞>Az5IkCǎ#^ гb:{HbD({Îi;5OZX]QC/S0v{3ފm}:Mw/v#?f:.I֭cs萀긃_ZЗM-׉͹yZuq-P2Ӓy9QG;Az#*+&S$T֓w<ϯR#xg.$ֲ݁ Vh;DbϮoS?v!)ZH,~l G$"g!+8~q⇙H3Sĩ;ηX82=odb|!*w.EUYK:L?h*D+5?y ]cW/r̋K#5dj- G,0)yN.wo-$Í{yG[B"!E<ܒ2k{;D oAp|6 2V`nuڤ_+` 2g 7Ld)0g3'e_r9uEN43rT!4fEh,fvL &ae}^ EAZ̉Kᰇ=w'K 663Xa c|.55v;-  p8w*fbU^x4 a!$BU<\9D?%Ğd]qhL2%Hv9Iw\$2>/s{*0Kш] (m99SQvKFT]9/)޸[ T%(81E{|Gr& ;C7 %JHwUZZd\ ]Ik8`Pg\oGu:@yA"tpNH;LZ&xK)G )v U\!oTe동*jwsK?fN>|3-{]kP1~L}$ӫO1_vtLe89-#?~xڪ*P<{[%rlD~ۃ7qEw$Dâs$ :hdQm1@@6&ߥM}-i'/]Xx]d* endstream endobj 3774 0 obj << /Type /ObjStm /N 100 /First 1017 /Length 2822 /Filter /FlateDecode >> stream x[[o[7~cB3Crgdױ ;ypa*d7(]-9ppBEnDq+Q]"sR#+}BbȶXփBq1h.j1JlDG_"GT # G {H,Yv!_P%(lJ (8'|!}s0.׀@Q`>NbjR\؉D0(i\ J$B(ȓQs5YRn{@ɶ.iߋC;\^#eRCBmO9q)xC)b7_q%hj'X9ٻeg%@aSKiV4F)54nߪӔUvYljtZl5 ڻU\vزأfWϊv4BB&b)F H)& MkДC!p >FhPH,HB"8Dӈݢ-.4˰Ã5#IFb ᔌ3Up$jtT_pB/8hPak aHN$Ϟ}{}X?jG}0{X~/8~jzv.r 'ؕp*ط8}=ss7nvf/Wǧ'G_o9roP: ÿC} T|l~,x g@ a4%b,083l !_#.|su Iӣ0€M{s[5@qGWEo3_ XsQ|eސ Q"/Ep|(>ެ~X4 ؝Csk0~ Ta,ތz F,?c I\0I 0 'nA\X67x#H,[LȰ$B:Ť>XL9u$ mLFPJo-N62u!F042-V u%Y8dbh 5y5MX ,6]_c=gFMS6FL(CaR5 ]ePXiXi"VAӪ T{GO쥩I. ^_L\( B{#ɺG;n0z|ϨGՇdAqF&< Hcd<NV~rnZIh'Ia1z tPNjp<[ `@  eHӴ _J呩0#SC@IRF՜bڃזhiS cvo<*jeV>'!Ǒ;VNBl 9x#[ V[yI#VU- < cx!vJq qČ3!oLzqм(YD-~q+wQ-1[fHw( UH#!hWu stR:$ZmDK*} *֌ M$'춚mf8wι!:VBÑ%X%MΫbVP@8ÁG}8vrV=&mj-52i$LC%9[TN?>UJ!I)W #.X9[U *,kf <2NΦ95޾IM;teU5#;$ 'pDC| ,Q';> ʔ\D&1[shKBt  ڔA `7dAL'Z ީ[ lnwN UP6F빫'],s\m+?quDB:=~;3=mwfE06>0}`0aߢE-oq3r`rw9s̝3w9K,CKĻRV<+E,0ڌHe;O!nٝxFKa&G'A]w؀63}e:dxxA* v3I6= J\@w0Hkb3gkgmc+yz2 endstream endobj 3918 0 obj << /Length 4076 /Filter /FlateDecode >> stream x\s6_Gy&M7k.Ms{(JtI).;/" b], 6ٷ/ՋW%5Fͮ3TDG\jg?_ᝆqM l!4g?-6M17ԢNymF7g}M)Ϸt.;z~sWһDwUjlWڏELw٪Gv||>[pIgNŎ:Ti(l!Dv܈RXp ّnp}( !FfEzVG輬#o^cq7O‹/ NhP5}AhǾOx$~MZ?y$eG>Z!07UwwtKwjA~46@]{{y(mV~Wn]yAnϏEŤx [? `՞^ Pk6-I6ڛVUPSzZr^*}ˊJ,b1s7ҥOW.!Veۖ;*rqĥd'>3++Pr;Mv9cb zYCd!UP['Imt@ 9 y) Mܿ7 ~}&|UߠT(O"@-|[i^ׅoUߥˌsl^62?uBU"d<҈sbٔ{QtUzrZXz]$TT4e?P%5-ʈD(]+t~٫ҠH=rvrrbm|~-dan%>U"wnu|ÒąfG6\;^ LP%~EnOCsUv~WY&5ûa6#ǖ  etwr1neuEEȢ&NvZZ-[Z5$JM;6Q}K:pŠأ8yPPiN`!XU:D"{#ň&?  70SXⓥmz{ D>eǤPԟ͎< ȎbScEH:#Pk{@Hy0ٓRѵY/=6(i]=vq}2ʐFȵڞy\=e5XP?R^g1q'E aqA4ф<HOVsȭ j&,NfQ“/xO(?o}{ qg $R{k>]N?33 k}b ZHrfa9[-Tli9";w3Y<A_,u=?T#5f&u*v+%mH @yh-G;h#G1,9aB ^' SSOaX0F=pEx^S儙: &LaU]oqO3!1ctNW|l!ƢKzMahw0)i {/s]&mv#@0}ܝA6ߖ"֩X6ud76oiyh~-gWB}s 9*anZ='4k{0=%#۹3^C ЖEV:n ?x'ޟc~EF*:p>n׈ӤeLJBV:k8GsP}bhcIheqߞPuөXUgds j-D\h?!Z5XC=qevqy5Qq:or2ǦB39;`7nY[QA%[:0*?ȃTYEgU59L9QXʧň_N's>v,|%f,?>7'1a`0.d.CFNT P endstream endobj 3962 0 obj << /Length 3408 /Filter /FlateDecode >> stream x[Y6~УB$Vysg6/v(cB IřFDHqv k(}_/!䳘0TۻWf\zaSI+IOkzNM&Mvm~g5ޚl3Jjߥw>ozN2ڧ>j!9,G| tP.yN][M^i,s~ʶnͿO @-L `^O$ н.g.=ǚHo}{.N0ZRF,%S/OZ2~’{䏞xlEͳ.ã2yL6E١ln)H^(1 2hXK̙}5q*}M̦mTi)unHv,iwQ&~]Ed()sg`URPc/[I^r ?g͆Q%ů 0v`8$ϊOn&j#4=MB+zPp4Z(_H?"H}3 㧈Q3d8Yq-Wnvܵx-L3`&-fyʈ+̿ ngvY~7aUn¢\AhŧH]gA_#Шp @l^xΐܟ %00$fH+W>gnhzdՔUgXjGJ,?dIy~ut@!r GMSzm & Yn~!\A<2&"w`Ӣi9G"K3d5I{ڋ흩&IUT%>إ`A B#;0 2[4P3ꯒҼ{ǻ@S{;B2qsf S7ν} T`gRLTXêzھK0[KXLx@|I䳛v@=)%mgۇ,вK 4u3s. A3Sԧ1ny|Jb.| `PD$g-:~0=dy:Hza r%1$tOrӏ9>/edo=T,.:K!W1*KHHIN<ɨ2O1 !AK}Q^xDPegTFLEG_7iu l'LYE(%f𦪬 ۤH{ {CAW`mS/B;=bKA (>?경65S@_9fWwᄕiچmH4O 6 D>Yo!AIId<t h;8y̸_@"e@A ;EBSrPg gR$4o Ыm:й+>wɪK 7΍'`I3^xK2ڨNFiԑxMʺh5)Һ3g~}(uq)y a=ٌ> 1-J,#Px2@t=ځ}H[g_?%\9;t*N7H1$+TMJ}߈70X$ؖJq %@O1BH<8 JVNIɿ1yWޞ:AJ&u#ŴO"OwadkzG8ZM(WVMD,U&㦫~Y5*X3p2z~H~?Ip!]ZvX/ۢuJ[bP&jP0 a#&)Hu9 >UG+Ȑbn>L>u=,oXօ6/=LgI3U1FtoUUU$:~ɾ4,^bh}"|h}0^_9`Rv:D$Q`h IFPIN/y4ޫ,inJ᱒fJKTjMͤ#vMY۴ =ެ6fo)[ 5PĭLӢ…VD'H.c8 /f 9ρg+V $S@aP |?(y㥠|@U&= '+Av%]QݽJ`=<@F*y͊ _ciˑ ]1WT灖mɿ{JY7= نI+kk`GlrɊb$Juž3ޑB`GV4iU`,bGV%{,K+|Q󢤛O5['ftoVSVpn1<-ի7aOiEa&o@7y.`'&D@ndaWyfb8YU^8=;ݠWq-' Vfja$z,UW\ӳELA&Kp oӦYl܍ (n,`oֻXw88!H?Ot}ygkn37Cc,"Y@P,m:F@_3 endstream endobj 3850 0 obj << /Type /ObjStm /N 100 /First 1018 /Length 2957 /Filter /FlateDecode >> stream x[n}W %r(`)փ,oiT}ZJ\ 5;3g}Vv!kЂ4ЃNab AS} 9t[*aBACNc~d!E[v zȭp !^!Y w-ɕwMhb:ư܃f m:P>)n[xCA»EǼk00i%RD| fjmF}j %ZPUBQ檰gw-2*ƨ%|ۼBMiC6J]dKLj-Cs>Hs48sf|ml6FbRF10/BaJ~r+:R8ƅXs"y~ DpΝY|e+S/FeL-7,$ Ft t.DvTz"X0 b dBs*1eM2?2p>\]BWՔ`49:*ÊG0Z:{l?l泋˛7?'?m>q{]BtH/7| ~; q4VčSE4X[EFAIzT`Q\q'_ϯCW E"Ƴ.#k,X+X4(pw//\+K EyE=sL"G \ sj. H7C+ht]D$E4$h Ƅ  O?䓼)Fk{0Ȃ *e^c>Z>! Z =XSOֱjO|83%}˫翼z {٫E|6蠲=f#/f%xЖ.PC˳[@yvu_>۷7?gzqf!pgH:3 NBӑ9Y!tUVre;W&aȲI&Aݦ/Sr''^5 ]\z`)3H&+[7t3 ; 96T"eŃԞcf?[,ڹEQ;MۑRHFzV&;a<;;OίolC6 qqZ:׏n{ $INQ'{FzlxRQ#M˓2 sAuF1~ؑ%PW {nslslslslę9o%[rx˙9qf83G]fu5kV׬Y]fs5;yl8yl8ylk6l\sq4444{#tcݧVsEas|tRWn~H^4S _,{Dˎ-qn`T$|G5& _"O_х5N5V4j@לEfYJRSQxr BbW\,ܴ()3-3O,c X4H endstream endobj 3988 0 obj << /Length 2639 /Filter /FlateDecode >> stream xZ[~_20戤NnXlA^mzL,<_sx(5O7@ Rpv; g߄7o.%|[qNGmAc_+SתÙtuKMqe7ߺjU]BD{ n.ZR5Ԥ]YPWjq`u;&n%2 n/;]sX)Ap7Yd5G(wERE莣K<5[CdMP5M  Jb"Tr>.BjDYqq*ui|Y|ǧHH(~+0sI/2T˙$= M *ʇƢ8^R gEv$[aE3ֺA9Ch= >?1's.dI?tH>O btpյ*/jBSP' ;G;yF,ɦRLm 8x >qHĦ,i!&mmfd|qp1h4}I>[O],c~:!~A2A,Rj$ NBلɇ?Q=a^F62@/, LeǗ}]Bb8 .'~Sޑ'B2zOpQ}r+ Y:a5ryaI Dr݌aj1:bgp ^w? eq?ӕwۡ.LĿ=iȴ1bC &H>X`E`WGjW_ HX>NXh=:>Y&!L12$$zY"g-`弔{`a܊Ƶ; -L?]D-zj1lpQTxtM~+o !2X+z=c4tS{Wm qfa'\iF7yPj HQ`3J%>9`-6`m:Va}Eo&#uĵTE߀|%D|ܖjU0x7+>WrȰχe?3n^^̒zi U'??1G>%zC]Ⱦi$  )ʣ]*šB/k`\hF難ra Jj@-}5kMjTK}hrqH@[;Ǚ ><9;4t5w@7VťICChlw/Wj&Vd9#a=uؑ8N)yw5腯a4pN8)6ZP y4》8zOuV”wXG&u.yMeǧ4H}r;2tPLݺ0޹Opnœ'tGqߛ_fk%>AT*ُO '_b_2i)mTTK @b8>2ALo)9[M%tf|'+DsR" z:F}rC=M3EEb,0.B z2 ;a͛,D endstream endobj 4035 0 obj << /Length 3048 /Filter /FlateDecode >> stream xZs۸_Gi&]ܥ$nNMS#9.H%;Ms6A\~~xtW"[gWЎ 'f62L(1Z>_rK:˳v՟3hb4K&],滤J<-)j|Eل?-'Y\)|4^nڊ~6-M4m2,r)8MLKڴnb)h/n8q&*dUgd\,Q/^@=bq⹤%=x8 ބln饩fVuS'UFxe6U;*n+WR<IG2H1 Z\Ӏ#هO"R A4vO5}mue\ҠXV3cf'Gl2'): dz2;mXa(uZQS*a+uZSB GHe(]4%=sbK=du RcWVdMw &EǤ78~F ڌBK(:br?Oh}]oӵ'$a` Zڜ'c>^2:]ČpeEI0$|VIV{ǾMPk)iK X bi|:q})GM8ׁwio.^bm?P`LU9^A HT;&(;izsۍWx#&-jf,oBƏk#m]7mJ9Ӆ,fFxs+#z`ӆy,q -+C"U?=;& I@$ݠ7C>)k02;VI318)NxLj5T. DS`8Hz捃@ؒM3Tuӌ[=[$HtM:'>ϗYT4κtCZm ,@2M`Qn݆aOczIhS$ tqxkX ȁd^V׷ -xEz)< X՞^ 7K_K@P;y: UgkSq4n!!Ȣ|v쯡T3~lSX SHX+I۔&[䦄{>K`OKLҺZr|E} yݛV*{t4>iHu̖&R[@gz|qwJwݕH}3 ;IZ͔, NQZ$oBE (8lLDAڳ˞ u|,7 PDWTnA*gm!QGH,Eu+{741WTز{@Rja{&;``ӕJzl**weyü nӻ*6u0y`Ps8;E8<\2VJWI[Ĉa`/%#È) oqWL8:vjڪ@o#άIk`9SV[Qr=P Ă9 S/= _”KCk_7mᓤpu?e{ǐ98&D&A'1umDKtŽUm9zr,38}sWmj[VXs$ y RMJAAaP'NA;5x)ׄƊNh3ARPՁȋn|Qm@_Q[xHӿpz%#&]W3<;,γa^)>걅] ׯzZ4)ڣXO+}Xw,$S$vf ͤ% endstream endobj 4072 0 obj << /Length 3620 /Filter /FlateDecode >> stream x[K6WU* Tll;TN L>L~vQV#F?n|~W?<'~y&\E,6&XW"D %V7ջ=$p1SZnW!\zgM :bO6V]ÅxRFJ8 fXc܏Ӄqڴ !̀RZ2KGcózئ !cX,.cV!L|QqQgTg0 ł(\Ӥo|scTW2[z"4WqIqSe\ f[@?_*JUI+lGZO8庯$_75=䅗ZudXew̻F!Tv.j$Ѹlf4\hX/\J1sg6;X/U}}I c8Pػ¹w&O?σ{0I,E0bA&Ytg;f=l'М܄CxuS__;̦D4+)Wp'B'Y,@3ӭM/#ᾚQsdt-Y%z`0?hxb΄G;:ԅq63Fz8tSVN3O;ӭߥۻiviMRvM'MO%+Asax8  He0E(i~ieQxjIdUw)ƙ릵lD*î?R{̊ԈQ޵?͉d仍֦f*6 o(W>7NmޅC,?a-` u8~z8,x- qxoKBY"sJD z_;ꃤ %87m vG-ΔEg,3.N> 8 PZ1V>E1RH{C314գfhH3BiL>G^L"onԖMuq_c:N>ȫlc~d:D&jgv{הԃ,5{ɥ 2D:/+-{ e+!l8 +ՠUn+z/Zk&|) IEp{I!-Ay-<('j5l/6I^b`kAunmIm;ì|vN Z'XIF)#}ɩ59f_gQ6h*57Zd"H-oP~PWI"6KYw7ո8VM)mWzҕp#QSuaۇD. "<(MB~h=<{2ڋFx}1Dw _DGT0kX BX9a-1&* B 53'x5R'sl?.-wMUs :UN{lc*.ʱDBt"Ĺ&tzHɦͿmYɱ W(i+{HŰ5`L#8֫vO#zWQ&M\N QgFӶN,X5e؞"d{#cէla(_9(_nP;6[ q`%.Hܜ;M$'mw?é;?1zOߌ_P;J ΄ \k1zefUKAa@Nt;|Ar~haC:qzѠE^3gR~z[w /|Y_\ߡXxBn ލ&m[뇥aZۓ a"35D]ڤ+'-?">i2wːs-UE``Sx1]14E31`*JafNH@0LA+cdcH~fi0W΅ѱsϭ=0~aM 2mmXuC _@Z6#֑³#xQpA(&{ԿPzKzԟ/o qYhU35Ő<3hD-]<A 2s.¶r:ŲKɤB~'pcK H[O*Fa;( %f5RѴ\+12$zr&MYjW/rA'ڻm'a ^kx>:_`W;Ћqf2?d^cq +𪻛"S҉Yyp+q3=/,2¬j"Vy~M9n:~㘰=9OPc8rWDc#Kq߾ >.JdT/# >n\vLojUrwb?zi11 k,l|{mmv~KPL/쓓5 0^WI]faL'}Bnc6|=$7 i1 endstream endobj 3966 0 obj << /Type /ObjStm /N 100 /First 1014 /Length 2898 /Filter /FlateDecode >> stream x[]o\}ׯл|I'\G6,ZHJ¸ ;rB57ZI?̚7JjYA?ŜJ#OTX?pi[5+[-㉞JBrL>D[!HDZs@<E,Q!ox`KyȻ݇psT/|?3x߀F sB[$%B9>$.-m51%ikMҒ->tL͵mVUűom<[sF>Z,wr2bKa<֪j2͊9ax|V:Z-YXjO5n9*ě3Kn1ujA-0Imh,*ޯ9&XTD3i;vKY pYu :Ƴ-Aٞ9'1oS Wra_GMl&j'h/ols+C6wpfh[ESVO1 ``6ؾayB6$`6<l0>V=䒹i>~cp0|ի[Wه7OV__\1#2׫WVXFdrv~dM[`p7$cW:K.^]Փ/%f 4d!hXmWo^zӣ?}16l\3M:UXvM̨mS@`1! ~x| &_ANe܏Ew!@?Է9-?@.p x!,drBCh qLHd#e=hn03b,ɹ- 1 }+Bx-)X!"nˀOS bXn #b.H5@lЌ<{ o=-N)#׎˝sOw3pvP^ly}uNNjoT4wj9zz t_o/}2p)פ`] sg)P@JHG}`08Ve>˴X,U*i;l>Rk|hDboG&61:xqyۛgNl6D7ߝmli+d|3(vSws$:&^o4i3 ipQ&>,DC+;x۳5ȟ CP;u"MXq?q~0)aIe$,$3id?Ғqٴh"Z,ǘcz14z0Lo4n!% DCaѨh%$\Br %$\Br %$>'*͐!GNw+XC̅.\DFU! ) 87ya`]RQl+N oHEz!|vRDž˓ ;Iش=FT~3#e: drΛ#dV[@[FrʓoRdIxuko9AC8cYr'1 w|`˦A@Xd<2o/~7VlٞHr>4ߑd%uA]>jmPb͖QFpVgAD]ܧ\/ ~M2 +T3j=xxLX0U#{\/{y{:}V^忮f4ReF0#C\B g^^R&0@0IxKm^ܠ ?MO1`Oil@@k; ȬPg$H`;-eT.Wz-EweKů*VĉG*;&KRl9_~YT UŮ:GS38\?/>7~rLzh&:k!FލBލ]6@NmO?7~ݲcQ(a0zE=FQQT8$sHSOI<%Sx$H#!YBd 5$kH֐!YCd -$[Hl!Bv f;!<)d k ?&N endstream endobj 4121 0 obj << /Length 3549 /Filter /FlateDecode >> stream x[͗۶QjWrHҤu>;!ɁKqW|H$ArW+9 |u7](V1KPnV"P,zJn_nZ pviM+^mdwWӬ+UQ4_|]Mq6;~6o"_md ELNyYʲy훜 xs8yGb̐yˉ0-Qӕ9ʨw:ysؠ`ɕ, "gBXu×-Gu 3ק6)$n̗\(~vi_ʪI\zJu(Kj|oܦPI,WS{m;pwS,T,v;mrjtMvur$$ߥz'\kA;:fv(!viCSd&'Xu<->@FLmę FܞXLFҽ曷7&""v/>oQɤ/*'?'4q[E @(Q#:`1N>Qch̩vׂZKTmN v~(R23Z6krC%A:؛9 q5i l|O gnFx(WgH H;%IoQJ, إsUFD4by"|1\\Ʒ~%b݋(0?υwر"1 w @9;=PDd cf@o0aA }MS7gp0Vq kǞ*f\kA~wlxM"8 @xR^in9UC$%Fn dG`P$^KKՋhIq1MNLn6\$c%0CoEd9V4$X4p beK]9Eh$Q;6vh,o)qH[ vYy.?0oX0"3,ID#"= M[/sD aSV=JZq%6v,i7 & Q7fNE1@ig&踖z&U<` Wyƃ/UL)2$} m0 &mQ7ՊՊ_f삽df. uAfIM%akرJ}QHG+)Ivܡ)^hR NKz4t( mq.@in)+k{֛stԡ=ն>PߞQ9<`DCʜ*٬:rv{៰}BX*J|YXεbn ,A4|ӀX"ՐJk!)MroI:os;,~FwC]t=댅6R8qX!n dmH%>6&X4OӲRluL vgzb%̨Īrwf wi=N.NaK0 zKwMgXajvNoX t7r^K*g `s Q2@j{Ӑf.7q֮n-Ws 7@LyuRz ,گ9Ad\UbU{HlmgREԟ{"_T8Xܨ깝"WBߞ(FMcMGp4)?@G}ۥEe"P"J^##a`\K\{@8t "+n\yƄMX2ܢa1uao%;\yX#RY4fQXh[ؙ 'vJ*C߽o8`;XֈA||lKlk8p(d˜K9OX,WVCl2SjrI6yWdK x&ɒq~2.Uj/.&r`aY2‡3 MDäːFtylwl2., jyv"ٵ#hFoKGXAX3Z7ݛ\BoX&jH&0/ZoYy< 5Sa ywCr#CO[z;m2 qbUsO5e-"Z}e`t܆60y3x-!ÍX<~.2,?=ow7vco`wۀe&g*a¢(nW͇(`#s1ǖ^ 6YA_WLj{ʼnC}Li/ӓ2|N&QZE~4P?$"[ȬJ/48ߪ6O$8\ozvC!$/_o`qͻSjòo''3iUYV{=.(lgM e#@s b &IdB/yr{&Asf{쩇#;'KhT?yLY1$ݐ)9mH+sh3{Lͫ__ szג> stream xZKϯQZx$*lg׾3vr|(j,EIʳ_n4>yHW*Rt7>4n->- 6y~ws_$pq]X"(fun~-tBcDPn.W"~ϻoܧT/~j`Q1&"hbFۑS#صN0WDnSew7dwy/:&Ϻ6-w5Xq"| &A#|嗬 l"eYNv)OuTz[`) :]0ea(8\ 7+sb8|0¦"`T9\_ f*qŚ]+`洣bJlաS3gpYWƙ L"BD/5{jpeoCfwʰ^r%YW7v6Oi_Y'튺:q% <wQyMx;Uy\p8!B7Ĵg/ά.C1L)[ f DwcD:~z݌Mˎ,D$ǞW 1lúk&.j8" f<a73a>X)˕% okH"{zZg&5^XV):?p̿•V795 m2*ÿjP eˮmuiUvƺ*X{M6P4h7 p,|pzW19|Bx|FGZCHЁ8`>ɶܒ('Cij+:tZYzp"6\qQ]ZeuoawQhy2sk#OHwo~zƼ+J`J,][VFgS4k.D 8m@'OMmƺMڥ4!>I-|UW^g/&j$[_^LjYk%/EbG"G( : O_D=FPIDWxLG){Rl&Iv#LH>?NDIyx$$%z_`.A8('i@Vxcj(`BP TAHgas~k[|CѓzI<?}棥>Al=?r "L8*iDaLpUZ޷4782 J>3L3 (6agI50Tx;2`rb|sC #`f(T{MH\([!Pb҄PN%x`y,6aGCYC&3dX,V[8Y~R}J& +:M0/@`+TvTO {1%Z/ u Z_UEŮ%C%0{EHys2z!]aU*]h[gOKd,Kv.vnh^ sՂ`1J P`3m$ax3`$h A#ꀊ[qEp5s=˭f)ʣ81GQCapgCŶ.~?ieQ:]ğ W| 4z}uYgs,b'{ٓeaߧݬu<9 * r٤&Co=>)vi|x<c CJvakIx }ϼP,{]Ew?AiU"b{H LbX4cR9R/fubʲ@, [ڶnАg|[ {gХVGx̖޵DŽ#:S&Sfˍz$=W cO]zE >gݘedy8k%9 5w] &Tvo!>%Cb9~۝KD6q 9O49H U)|W|q@*~fՉsy x=9ݡG4̅`˅q4^؀ߋvTs,LĆd.p 5Pv1a aKÙ3`ers lVOL|>J&ɰaOXM< a`D6b%E(HbpK"x"CSP|J`oO8}Z~ n5i뽣B΍a^Pt |jtA%˪<) XP6zH# cE'LH890P93ΐCJȺ |3 Mw'4H5hkcUHs?[nm >HO^["@L!>[۵e$\?&c9l j׻d}5ina+  xN a^}wc ^̀LЇE :Y *Z2tCI!]qS2W$Asc)MNF e1E7%\\.3ĸyikg^n|{?٣|J BXu^xP5Mec4H4'A{J=cz#M endstream endobj 4074 0 obj << /Type /ObjStm /N 100 /First 1017 /Length 2974 /Filter /FlateDecode >> stream xڽ[n7}W1y0*F_b' ݬc,g1֐(N,[j vfOu/.8 ".j!N0g ";]nFZN$QD@EL`n*.fLX2(-$($0qS@fJ.fNRnÒ8iNc5b|6Z4EI ӜI'\̑88Hq%a"%ϑXZcRkM\ ۻRNKR*"&Wp7=B*cJU0Qp$mѪ[9=:\.Q/iɮ3`Pb }L~5ѕ|#Fۻj|́R}+ԤR! =o5%:$^=:ChZIj B<_@jPKHP V >@DFYJq %_1[T >ƁLT1-j ٶ0&QEJxB+c37 3A Ly$HoPD,G͘Ջvg/~V] 0շG/c8X_oK`+bw[ӳgn}^< )?} ,;@,%/Bd9{J0>j'}}Fǿ_ázCs6IGÀ/K ̤yږNZ?}s<#(4T,@| !haEQ .[[F&%F b]$j `|D<|;s9W-SnEçUC|?K o $N9qHIX(7@w-/O6oN}:#ְ5uDCfܛLHO `y W&ܭ#9CnQ]94 bH, -VB=i`, ,4Mi֥|D {24% ,1,JA|J @4|/zBá0hKA!pwՔ =hLd0a ah9C,, ݯ"ږdA]p M{L3 @,g,1Đ=g.@f jaQγyփ$*, b,@F3|e!kiITDT#\WD * G:_*BdT!seg&̄,_ˍnjuAޢC _.0Se>$֕5drDCHU"쨲8ټ)=2@p 08RDpy1Vf0̀ dzf1M`Xd!xE-d~V韎>Ҳ+۷n!|H hzt3'?7O7'~"ӂU؁w]pk>" vBwճyt]t:{Yt`1Nٳ瘢(OPdxVfHrGlj6u89B0ե05zG~[ٜC%8!HG,܆id[w2o]̶S`CU (XRC`]yVF$@nH+zL7qWi$甼G€|DJ. 6gPUvx$dxj Dk1R`n/d J q` 6_;b)V}~n]u5'Y̍P,ˆ1#2MgKelP u&X[`[d io_!s?lf :fl B,\=HݪO9'ϟ[HW!ysЛ QY7\9\/lNW $1,m+,h:]o%&D̞(Bf6 d#0t"$J< O')+ ) k?ZiMEH[l޳ 6l<{syN~2p4x6yJ6m5…d|m,GߩW ݥ>.%s8z%qJdAdtXd<%)OaaaaYgupYgmpgmpgmp9Y;>J(.W0j Ofwr/ly~y6 =x~Gņ϶lzK`Bv3Cly3̛! F+30J .Kajo$DyoH{޽}i$i endstream endobj 4204 0 obj << /Length 2423 /Filter /FlateDecode >> stream xZK6ϯe* ĕC]r%q@Qɯn|3#Mdg]僇$~|dx{}AwBDayWkWo!e߯~al0L$BȧE^ŶZ,y@zK)Խ;r`OҺ(?:+ri?)$mQi:6(a/JO_6Jl'FZ#2jlh%$ bo$ nߛ3(&[|X TW^[eVwlmrݔY~3B{yÀ|&#VxL$ہ?gVOqacFƲ+gE TUں}JfD7脗'[X j~XA_INJwF_];/fƾm ]IѶ4uRkpͮN BRKß%}%tp)c@;( ;QZ& ;jU,A_eU]YMuQЛA{)ۣDK*`ݾ1:H}L7(׶ua&qr^7M٭ZL= W(hn6vHVX]Q+{,8z |-e&[0HMYj3VgUgۭC / g(>E Ga]`Ac&. RI\/=*QS_'Ͷ\eI0mHiD y|NwӏNo 8,k%BX|IC'#Õ-"~592̸ vzWw혼jv~椶tj0.*v^ΆÜyЎ`=峠aWEa%EWcn =1*uPhkp5|T@krm[\`<3 CfA[$}p9X;pb0F,B$>+f-~#C4y ɴnL 3N' Tm=WYj> :G&,!/yQ%gf $!SۄZ-o~>[CCƪnޒmU8I(.Y'_,SVKif`9bhsb82}MqdT*5P]s"wpQȱ}{~fAf2K?d2"*RO*N :iQ%[ M!@y7 h@ieEJ#A? *9 (cK} T`T5&BC+]jmXیQ )Lߣxֶg21[!h/9p:mG bDظ 64yLy3qV̩O@)rËeވ8GX-hBs 1b] Wm/1%ԄDlPdWu02#|XeU{/?.RyBB!"Ňߩ`2ޭyQDb./~A!,7UH8h caᬫLsuxG^-(Jb2$[ ^FK`T_g` P:pnOqSwQuO]I{2C t K)K8>ަ۾oDDLgϞ^Ьf~˘$#P7Qv@zvb000|qNjIuZq{v!WJ^+# "zvs2B|%jL`H `;&M  !4<f@wç?~l?::;g`o'Hg(^K8e̓>O䡱*0H $$骱ck|g endstream endobj 4226 0 obj << /Length 2707 /Filter /FlateDecode >> stream xZ[6~_d fyH. 4;in }mM,D&`Z3Ey94}ً zw?Ej"91Sl0fه}u/xH۸0I@뗰 -(! J tpV" }x?\TJn#RtJ"'#.mp I,9OS%:N-"N7J.WI5_HUiU+~[(/=i~ށ7OolCMqM{$哓?f]Y" jb>ؘ}>1Oڒ?gRaH֩X^hI_04}ve{q3*-r`'~Hx'lqboͨC; If']VLutdBke0-β$K@GvWej<}H&;Ih4D\(isU2qZ}<$ 9 V*侐aç M]k+-cpZ;qvW{m'nY,]CRiiĎ?݊pob|y[|@X;yĦ$eNs lTEޞ~kGxiPTU_lLP% )54hNT8tb͈hi5( o16Lw `h]-{=Ekҍw9bí}Naa4[jx&mV)R~dt(3$ I?UMf*ə)QLƭ.̈0{~kJwۥ?W4ZnT]zen{X}Do%:Hi%Z6G}e(:c3N1BTpVۋ_gFϾک[H60ga"Vo/'hrE EH`x5xpf + JEuDZsWSym M ")dh͇""s{@Mtm_M˼Rżbx@ac@7Y]!Ufk]uh6Et7KzHEM!z`uq9֨c~`)w6 N#;5T1i>6>Z3mle`[b?xr4P"DkX{R8E!~ZdNpeǴ&yI9ͷM\?ڀry4yȩ}n<A}-ZgnV)]Ӣ(gnڳ{zcҏ7Q  6Tea9Pv VXݨ`\ O84OбGK?`I<\m7hT ;MrՀNrm Y*h./ kg Ml;݋\͐qIH,;jd 'm=f |i<5/Li%4zigXCuCrld)'u9򵍹g| <؁O b⶜`~79;{,D V뗴}$@)ߝ1%1+8O 'xD(9ܤ=(K>Dy*zŁ zb=y@l]j ^Y&6Yq{`N&ˊUqKxlm"9j0§y*C(W`Chv4h+Aؙacc\vp媦0P&$ 8;K3ׁfwg|T8W;?p!C_Ĉ(kOF?<}/Yw])[M>-.f*Ȇ,60e1;0MdӉޞ9xHmZfG˚{ endstream endobj 4157 0 obj << /Type /ObjStm /N 100 /First 1015 /Length 2803 /Filter /FlateDecode >> stream x[mBd^\0 Ph:40Y:}>l0kf״vd >HGr]p)Jq1E I킹*6\Bt'ZR b]rQ$@ ?c獝jub-RsЇ&qK$.9ɕc e*N,A qdNch9^rp iƼ5VJhW" )I"\$wD;SKk͸BE\B|E]MbI.K"'eϥ \C\̭`/͈݊3n+Uu% `J)\+,gQ\iJT WS[}W1PM}4,g-%q]Ŵ56ނ4Uv)e$QRg 6޴g\} RZh5) 0҅XA+XF lP }3h/AA6"44`=1ƀiFƿ\{e 1r!5 ^|R%5 T-󀥋)}G%vJ H(Y"@JѤ.b4 D&M9 J-B !b4şN/qߝ'O??,.-/^fGb8Y|vRš;N`K0ߤw8u+x]~/_%|<3[]NsEP: ^ӃJڒ-VڵgfIrlڵ8N|bj48A Aob'nI*,fM \~|7s5`^ 0`m(f/j檭FϭD0߉ 7xf B9ESIP _ /5}04O5Z̻`S?&0AGPSWo@p{a(3 1[T}CO$)| d7){9M0LxhΆ$L϶kT Œ²g-#фs;2dTTp 8[sh>r%jg6+[~ݘRBvb3S=@ $ϥpH%8ۤs['끾8%џHXn4/䥨L= ֐Yd6Py(#|m܋,HCro ,C-jS8LEj KBK''uY YOi|C#o:qb㡒Exqz{'nry|m/<|}Bϕstvya&g\{p %;Tfòiؕwx:Qlm+0ѸEPP0z.:z:z:z:z:zg=F6zMofـ\1:6@א\ 3%T3I&dؽ&W;re0(ߜTp1r;"$6:#oG_ %O P ]hY r9zx|hj2ăԄ+h"MMHQ =XD+$ซxU)ۗ#ЖnxV1ȕx8X*F 9;ymՂ61RM;-UTa!d+p i aW"5`2ar="hsED"p܅.CtQ3J^d*p<8`F\ЩN$:I GbOᘚ$t`-0N'P=(vޝLDlLUT MLV2ٓ\v@ 5W`WHŐLWwx>? JhHPv~ ʁhDjIGmq7*ϑ,;W!]m#L^`9j:3P;5Y{RՇ-Tt*uE*/+K" N65|o&?%Q6 vciiiii7j6zn6zn۞yif+!!F88tiye8zg=YFϢ3Y]JJWHXZ؃CpLNYHgΘ1u,DRgd_6?×+LnǡsSVrnCp82rrc#EZ2OUy }8f΍zg$ !<+8͈ p<վ()8&w@X {5{aqM> stream xZ[o:~ϯ6PsERgs)rP&>}-&*[.;ËdrcEuf8 `v7 f//⟿G,!2e0gQM60@O70z0,IBcST **[,۪R|U;;!%K;D$C [ q!Iɧ%ιX2$&:%Fz!kfwwmVy+ےTtݔUW i:en|QPecJ2uysN)ykb4 RH'V4iBYmU)33JxD*Tsuݮj܎4vaݖK_t| hFޞ$Ŀ٤ݗ]ynHkUNCVW zkNwiPӌlVZZZ4$E˺W]kZf¡%$hϪ'`$rsGK`&|>!yciuۂsbث r@QXɬIo,ľ/wZFڎh'v:ѿlkY`*[-5@MW\-G-&Sr/&ưhr$ JlQU="V֔wSqrF>۴-5C1pJZ j I0wuͨj,*k{ _;U)"ޛr:tR Ϥ QHSs"껺mݛ巛/_3:$#ç`A#@)2$(bv}o{r&M%f&;HLT6(1_&8$ݩ N $`6n 9@͠VqƌBwHCFZ$1J[{vkj6mO]o]k”|Xc6l[gN'IńFyqџF4pA*t.v)uMcHCHGSBfEBh0LQO`0"ć'|1m X|m1SffO!KԫT\rU;w8AQ't+]}. \a@0&Z$< σTaS[ $nSQzi<-28sOo=)!%53 P҇:y>U?}BL]25~CiSA][ضQ-F98eZC4*H \L6U:1xkt  PB@mtSP'excyk4DcLv^7Հj $)w5חW/߽|; Hاr1ջ߮ #'X\>9jՋh#{T6@0OnH)쇶 Apcʐk_b [# ,b|!:qlV]C96~b{m,|ȁ!ۙKS~)h!jO"$|ps8v)9 pO\`--\ߕ2t1 ᕂ},Hh$( :O%˞,ZT4Mg$-;?cA^.A/:xN,y JQܒ i6C$k6qcL* i8 .+jնSq ]ާkJ^Gꇎ{E1 ĿB!ir}=rMB3"d]ixy޴6 ))D,ǒ _2$y<{BLKm^;%)J=0۹Hܣ׃+a* '' X-<1-W[!C G\^s5`i ®"M\VǻݓK sd/쟹3/COoAG_d\:F=ҖquW |ib R$RXn}6'5MR6/)ha 1}W.Bjo~:LYdŒ]IB_@ r endstream endobj 4280 0 obj << /Length 2866 /Filter /FlateDecode >> stream xZ[۶~_>tF0 ;ӺuLj'%aWSBR^}@:?E$!\; g/ 4IMDLX%a WM6l% ?θ |gjV4I_Nf]^̸w& L;_&?MFt M$ PL *b$/kSEgK|Jwl*6YYvעlT7eA&wY\UwSV+Seŭ{Bfim܂f49$#6Ca3E%dT=?g@Vw]f+ 0u2/Y|γEV3%,G=Mm5I'C "e,(g>_$qBI&;FIgy8 1A]k!"BU{ 0>[QZ#Wh&9aIȈCo4X?wv&D%p~ ZhuB nYҊ0,sVncD@v;ZytZDy]N' /Nc>hGUzn1umLQ;G9i pCK (D%D 5kGqIN/W^7gznۣ_0U"r3wEmMvD=/Ib9#y#21ԝS/GYwΥ ł=Q駙yuM/᭧a= BS(;g7ļO I#dk3G;pd0Q ! tH̖f̞I2WD<>ZN2R"sQ깍ݧ$ݢ*w?LhonZ贗Ϧ*'uAM,wDH_'wx^a]& }[k[[W*SSjeDrA_Si{}y'+{oEtde9³Tia>cjP3K8@jB <C=-XjjcNQ䣚9i[SE|Qc9 L ތAcﶬDpEy5 zj[-ubGl,29@m2sZΘ=l!7G },t">r93\Hy ǹ ` x{pabb qъaۂW_IZEYq+X6xEaVh %aKƩ[0O PD$zLǓ.i~̾1hV0X!p~Y"/nMj œu N LMD[7o%v"slw$D1QΆXRW_o}^jbViD*7D-^#m21mg"Q2l;;^]ګsR/m_ Vӵ$UKb2z׺3 1}t$GƑF f-!MC\x W3!n҄юgvdQo8xc7nM G"=|cm HX|_ u6T?r؅XUؗD';%Pwuo@Ad\]']Į!ghve㮮j*ue (ji v'Z_<Ep[|Cqu8#ZA>ath?wiDDޤβвNw3Mas5g/-<+A8ږu- wn|dP I*![?ؿuu*u>a~@.>RA(nBxMe" @lȿ endstream endobj 4304 0 obj << /Length 3171 /Filter /FlateDecode >> stream xZݓ۶dL9$n_ӱ@I<5E$.Et{ɋ `؏.Go8*>)%$UJD7PM#HB9n6?Y_rSQR3^/9zm^2/V涱ζ6N^W]무fƮn߲+۽Grt~%qsċmU٢$q2wn&Ǭ'{Mnrcқ/eD B.fWf$Z',k&wm*KpضG͆UQq2xFL'394&1?)pUAh2|NҰ륦K'|ܴ z&1(+#èY,9$-EG&ı1ISeM>*#,Gn*P聠EpLi"gOԅ|ǝ>tz<g'N'82ȣ{g5 }D%hg{#oo_!qD#{#%),ֻ׿^sΐw'PFe}|a*!%_n-)PqK=u8R"d͐齎:u73`\}BDr~ e!2ad~tbB{*`2:q\b/bj&|U`\Nh z@г˺rնo}xӣxs 艨dp}vz[Tne8uffNcfYžϡC0w3<+,$Ee _9]D4&7mv(;ιX Ne`s?e}5jwp01aN)uc_|G44&,x߂q "FhчYa$9eͻ9I5TQ: HØ:'1xqkL<8xyVURBe8y7Hs8Mj ]- X$!1NY^~(̎%'hwYYMWV͹ [u]";>eIrYy1L(b`08QqkE~ݻCWC(Լ]cCU?ug >U3mΒ`m.R#ڍ@?l@|̥0[9)6g_򰫬Fb?31 ]ʍmzLRNT:(n}]9Ontg{[slp<9dZӯ:r-L1囩6Z;Vxl{",py#FG(Ay>a ^}7g@Z[3NgpxxBV&~wԲ0!;R ; m펛Őqͮw Ϝ`ɘ~yy;(\jH.u(6엜 x40M\9B_2X`-[NJ^:OgфFf4=>?!:j1HB[˙MYeQ6Q*M=5x\T0D8RD=rN4DS+U>VˎДQB%ߤO0cµ\>W{ʰngm!q _]WU;h'Z!4Κu?Kl $i)@Otq,43>hY>2@:n*T_k/ŏ]z.㲊5a}ZZ YU?O%n9އv%;yQĴ*ʢXTVD !.b4ACع}a渪]CFA>!sf&{r]\uYALTDmىϏP@=S\dagN?< *9?D(G;7yrak/q튝8J%avn3hRR$=@U/SM ꚺY=N6yT%R*<7NjWv@5Ģy`Dc 5NSvI)l r)MNxYiG WӲ.ح+n!AwnWqb do+׍30{ Ad. 7X\%kWZLd_]R' V%?姪Ш~}67};͍ rp}F1: Sf&CA/Fܕ5D "qFf]Q}- ߨoyZOSJ0~|!O 7"!wFb`\lZB,O |~,HBIx4$yҥ+'kS_C`x31\IG&nRv$$+jR1i}3qp/oC41ÉqĿOtTP013^MH1I\2'0 endstream endobj 4353 0 obj << /Length 3702 /Filter /FlateDecode >> stream xZKܶWLĭ $AdJJlّVA3a!$G |-WZNUS MIx>yoRTnmDڪ,6hssؼ |@Ls)LBLgJ 3ObeLFa`|fk j,pȃsyUM”IU%~sneȨD[OSv<}_ul}WA)4hoYc{r;j}PSS/fhnl-p6 U%(GNVʨ4/?޼H E M6o*S=c,r\ (2 bpnem aT\zq[)B dSX ,f_tj>gq+){H=up{xӲ$]Q! DM_ɴ//Yu0; j WYT[ө<Ի/;k 51Q$ *^YP7UwsS-Ld]uAX.ԝZk+F39\őKB=^CvB ?ah:MLT$<ŭT=v67 ݍ*]l纨6nG soQ35q*6<08Q+YZ76D`U1>}:WY2Qɺût~ɖ -j(DO2*gsXK$=uXf_vd؎? ms>Q F0}`Ğp?3ח]EAd#45T-4ukFɨF,/=6ͬ{D?nҙ8S}5(ڬLhB̏~YvEЀ*bkkahpsO[2Xc_qzt#kf 2e0S`-ILZJm ?9AS{ !~wʈ+0ٲw2b' Sˠ%BU7NQ<ϫa X⣈ȜWeqel׀`خ-~*$0LU^ R\Z* AqveURME3Z)#&wOȇSYv 2\ g>ڳۿuwSQ$R.ag%VPw7ADVX:R/{ޕT0&ą!H+/)CA9@W'ѥw, 02͎Z6ASJB"1"~aӂд9VHUddAB$p1B욓P$牝k rB-|}C^O!f\FVUw]qd:l`INmT|ёxh]b+cRӍ^=$<:J6rYkتd%3~b%6w)'(6ڏġ ,OV(x?g)7EԹ.孥*of}0Nn](dMN7LFtSI#q+^R$RZ/ k0ݥΆ۩g>,Jh'[('4b,؎;('vq!}BƄ(45'=U]ۃz8g/3#!DU,>tE,^P`Ï:yM֤vI-W}Xw9"1Y1(!,+~;g&B**xc ɬnZJq Pz6كDA/ {æ!Ok ͽ{*L> stream xڽ[]T7}_mH6 ͒(lgi04AА4>J.Ip:΢5p%g`j.5ZǴI?K.Y%*.9T]FzFz%lbȻb586+ NrVaI ’lD!s^#Ѿp RZr`_^(`~MN·5>Ѣ]UWFAUI,,r\VgY}6gKLZ`s蛆̱^Ʈ9e_9p?Jr`keеإ JjP5b+ǐf idl~ `Z]R--]  &WIj_DU|%d Vv8hK\V=9Zr$ĵ-tFqbWe&6hU4o!v4 @k6I &"QN>OaO&v$S`QԽH M8@;؍/NV/nV]\\nNV^^Y_ ?W߯sz~qIJH)zpB 5qgŰ܃nuVO/_^cᗯoO|Br*b_]xyYS^q ws[=|{yug¥mmn6kՓˋM؋a'p0:їM#:jkuP+lקk{ĭ^ڸݚ tY_laO/Aח^?q_+]FϮ5j {{x!?=L42:6y4hhSCeuPAYeuPAYemPAemP-O& z jEV~5=4/%Ea30Ɓ#]fA?C#~?#H<|$[2N< u #6+#5xeȟ<#|&|~`#CAdc^3%q!KI.)˳2R fU=1ƺD>2 F0VDMQO //Co RبbHrfA:Y<@OO=ꬌdhE`|B^DR> lv F{AǮ +l!A"=$Dp H((z2!>C߃k…'qDX,_'7 q8v16&|A`3VI"_ Dr@R(tdv7|_*֎xx<|sFr- ;PS:r42x$3rg,}|\!vr\B2GQR)_PQQȣG]!EnXQ(bQFŢEˠ\2(2k cdA` *~<ʬ8pLJ'BG1s /d{Ua5(C4B|T4nLcXD8a9]6`aN\!-&Db BH7s9>趃G1ָLyMc*=`Ŕ<ؘ*G1/$ |6~&4*{mوOs@B~Dڊ4-&^^D%gpm3'9nf6~7#X~`d:}AVM] 𤹣f!Lc!A%Y6";8oӆ;FU&zh/a+Z9r4ڷ2+8||b!?s8udududududu`:0A L&hr۠6(A m̻3…Yhtk"^jIvXNlΤCs~3W*Mr "h;Fٽ]'E!MF8Xb%98oH9.xP .CF!By$~%f#>#Ɠ0v"2().w'w&6r13dJ`t"gۍᵪƋ -DdQi+>QzFHz-HډKdקy͠ $f֯zmjB98젆짞vbCa9u{1vzhjʼ) iKx9팜u"SH r3d~^> -}4p jǍnƖy$@`: I XQ Øφ$[C]ς$> stream x\r8+"GW"ĩq8^"QjJNsAeQI`g%Yp}q5 | 8! !i%R,.~' #ftr0#/:HƐ}p5EF盋W$ Irs_D(81"mrPwHq:cҰbWLMkRTj >ˆk.%b׻tWNgTI^lvۻuJ6HJOoH5ZP k Bɉ9,"?LŰq peQRR!kuLbD8I9U@8UP%s 2e \lqVU=+e Ą9| nu;x*?Jlu2ɋkI^X!t2B04csKF4z5N8Dnɢ ky2eiUpeahd9 ͩiImTZZ~R1I%:Q00aсp$u`l T"$0T>V9p/4[x2p1(ޛ'Z6:]ol9=bL bSx!)Q!Sb9F91PJ8~ T\.=!w< 5 9axpH >2;x_B8Hiwr&q-3-*07Jj$?ϡ/n3!u8? HCCk c{H@=ߚmzQu]4;oEa8`x `a(d@}~f-cfr=%b=_d3 )&/6q&&| ܏0'ajܕi^dj6-IAٽJ0ID&r@0R0 {m|K5 yoLf4mTCVdMKUfۭ\ӊ<`xF q;#V8c\p"g0o%M? 'KZwa,&W 7S'߻&8qʖ+uR5u#Dji좻6`r-{h0h2YN60E>PD0SgL9ˮw+27 H)4CC hůÙ8l2Bͣ#]֟l;@!f9agxCrb׾1YT3Ԍ^$`Diaꯞ3 !VyDSXe kFC1$L3!N31jH$d Z)->en0_ rcf>!L*c&;S &#D ~%|&uxw=I0cH{\]ư3'Χ C"435ȸc{_FzTWkF)I S58gBÎa8*|ϫ0R@~,܉@ 60/ F d89^}AgP8 *{7== m~#Jmzrڤ6_ \@ $DV\faޢ*NIc&Wɹu0aL\ևvຆ* =dOCN6ɦCGG eoN?3 t'D/~auI~c?腢1-xx&Ymqv܄'x{u 6a?ub={Ui*euc ZǂCJn]nf^t?Zd6sxo7$ѓ_/Z"'y> stream x\K%URUOJb$GC,2Iy3ƋDDP2 Vя9"Z|&B-肊p.T*Hfǟ ɓJQ&"!Tg,8D,zx[E/UJ, ."V UxxZ,ڼb|f2ZOQ||ГIPEPI0Fcj#GVfhFdc%ZosA 1EFD2aXnڢ) *uY *ۺڝ]jG |֊F'һxHF4TBoH;^9T^·B9tʡU0PИ֊9g [d gp^R!b][v.csV>xʛW@wPtBq/ƲOXjZ ѣHIG@_{h Ty%m;: B+d:+YxӅF©3GYh L gљ$Egp$,:9#@t{Ѵub[ Wu8S6}A}Ʈm5t U ?vn6u7cș@›.7 N,< >HiLҙ@›$7 $,:$ RJoqw?hj OǺ(?~i=Se B׾]9]ѣ@:` |ocDpYtFg£+R^WJxMfp6d k,:ELTq^tP!x:V,ר+[wЭܡ0;̽q`SqqHXƁ;iYd1\'` W\p6; {ܹM;: RGlV gљ.Egp^,\GPL\I8 op&3X8ꔊDwBYcߞTSӵ+Ge ܾ*=;@p:` |m#m2NYxӅF©3Sh,nSA M$CgPA9x{rP&sJEck<\z61}h`Ap`p:_wN\{8m`oSq8&IͫYxӅF©3S`φS6N9xs k2_Ju &2)ۺvSPpƱB ERP7o(,쑁?A^~sě|Tލn=*@m;: S",:«3h`^gq ΧSL&e`^H8=JzX%:}to/WkŢEzm'kbWN>:TM{M4:N%,=q7T d{\ #IZS+-[^{sixguܬO(ZYDH#sLw\X&ߘ!&sCW.ͯJ02`LR>#I->l@^嶛7>=>{ٙS86(dHAQ´s ]Z:M^\ZDblmcd^]c`_cvFoWFȳͳN_ˇ[svhrbG-OF}/ղ廭V8ں?ދu'ƿxs땗GMo'd*OB``0fk;XH0ɜPSN(Behc^d>&&::{M,^p% _- FJ8P)b?WN.iûs,`} ^ Kb"0B,Oß\Px"=7\X̅S"M))XA@){B)$dͰ'F2FApWGP盢ѱ'b祥nHutl |HnWa});h='&z'(.bNcn;L(Uv})0EkKyyMa !`Ű\ 3~ŕܧu*m CfʶaRO*QjH  @V'3WPAҲO3S`+M8 n++ `ʌ|W싲_T`m c4 5ӞD8 P\SFHt^ }:O{:6^ =;@ u5MܽU?QU8RIث(s=^|s3(8m.M9O.Ꮙ)F]^mJU 8_v n9TKffA)&5H '$њ&s M^ E|SGf=x0nBn]g/ɼT9&J,\E"hu7yS A`yZaf}خzt6E?ʇOPJ"j8 =]5jQŠ执; •'sA=>"ytے.%T L@ȓ4QȭX!cj_X:U^@ObxɳYM0t,88ZRqo:_ _'W<{j:.jn KX4cAsq,)PxYl ]5~ iW82Fڮ7UqfƦf/e^e@SWOx`3+&)~/ O}P9n3qn_a'C$fQY٧ܜ+= QI/G//[K;;ڴ4 [:槿3%F>mߴ )Qf*ZL'zĽ`@ezi=,B8Իvv̔'ȝo/Jޞ[ef;9VS"XZ &P}X% endstream endobj 4425 0 obj << /Length 3766 /Filter /FlateDecode >> stream x[KsW%U*ʇe)t,)1Ŋv}{K{z~NS>+ܼu"Wi%I٭dl#i*IM$\lW?oKuPf+6]_Hæxݖs߷60O]RzGEV~hʮ+xOԣoMST}7hۺN~øwStǦ*{8$3I?~|P!R(3ǫw"H?S'u$t -n %Gع亮ﺢ;$vRMW7yWUtqkEz]bv!-ۏTj wM/& /;,"%wXIbH/)$2bʖ~{v Y*8{p[{OnfQ`Ȉ\J.eep)֯tWO1.+b;_w- pܥ>vrS7qo66Gq(‰~W߾gQItQ,3?kCD$w$t@,R9F,R&%'0Ѕ\CP<ɤ`H:/lM]m ,`Z}r[l6h9J]?d%k#3WX TMVY):d%zV RUE62E/42ؠpSp1] CP% jQMxZۼyj2#.'sm- BhB[Ii{4K0wҏ_!1UE۟zf*d܋kbD]3TɆX my ^L?vқN:uƅ lEQ s8[n^NJ̮ AK^XmT\ ({~9SQLRjZ>oþP4Rc5ג(ӴRI:54MڜQ UPTC>~0UG@wyYdBk4 f,C9݂ЛXN}i_)FM~If= z󦠹9<ǻ]nAk?`HK9Zb"}{=8cm DAL0E8v^o mKS'nop,%݊l -;yfME8~fG@'z}UQ5[WnsVjHGf]7~On t9=s _i5 d>yP}[h!ʾd-]J汎`4_\g i:>gi8~-덿~Ք Kmʿl@lKa:]SJN'궛C}57"BxĨ)xDzQsM\3 1PV0צ]߶ȷZҞzЂu^ ACH&B1Dv2slN" +\^Omق`A}7˰# kܙK0@5bAuxf 20pN۪m{$*<]4\ALwx߮s~lOha$헧wbX~UvaFg!F:8c!մvLyNۖ-(#XS`b,hpHEZ)ٜM/ƀ>TB+FIvsؠ)qXz]W.yido-+id$Qb0SqT,OU"z>KEf-8P]lm$kw4Hp`'V_?ҧV- vzSW{07F/c-mKq=H,aږn.}%F{}lP*X=LX I0I{9 h_,*/͋r>~]VL6g!  Ҝ\lR34>U`CĥKEFEVf^2i#9HJQ/9S1y< !-pf>2[q@M/ 4JA8~) V5V;xBE6c&04YͱbQ&a j1ծ}zό2nOcIƉ(,Os4czF@bvV\R"n;ʐQO3Lgϕ"p3=tT+{{1{lrzWǔވ:8-9= LK6HmUpc(Jz^D {6)b\1L~[V |jo1c9:ŊT{MBzjS9_=bGG>WfԬ+|S)?a?Na> stream x[][}_ k7E^?4uv¨ 2Diݬ -`Jp̐BRPH9pVo ZqF -0 /(]% |]4i ޲@z?ʁ*Jf.jG)dؒKaB)nԿ I} 2]ЋBQ߶ GôHWٿ[bAI|A9;*)>ixԎχ>KAj o(eLS ū+%k9:GBV+L.s@hw.( +Jtu % t ZGr߶P}FUf`PjkN.ꪹ϶WQbJAU,}۩v[)8ekhRr]`*m[`I LCQ}*G[r:Gn&ԛtQфѨ 6 ĀMƤbM{H ĶkSƕ[.V:l/Vn}zu}:'7~X=zMbrn^% |,x҆^߇2n^mqf{:.oZa9qM%G2q,B d>)qSM",Jz'?8'ѽ$ifSl6q-`lI4&!`7#v֝ ~xӫ/.6ri aQeNpAj>_?~gh-z(ן>|xŎn'Be,p{գ͇oWAvＸn7a/⯿o^n@Փ~R<]'Y!AbNf mCwұ@,!3Zټ\C'aj6|1_\k}y_oۏf7nޭ?xW74ƺ:v;q<y4hhѠѐyH!dyH!P@e'LHKV'"p\̝f|T$ 6'j! b:ڕE6#wAYAu5Gt1`Q`(~,(JkbH`ԳR*q'7 j] rjޭy?ye^e^eH.Crː\fM:ՐWlӲL:,JnS݁q c)@h֘w: k6/(:(y JnG N7 V ȤFYF Vv9< Db#&6;G#v ۵y)t2ʬ~yG?L^wnpou3,)goϗ<QO^ej9<)/Ǭ)|!2 tXΏ.*q(k[nY$qQiy^~j#i[<͏,bw~ScTǼ\PH~BMܴ4 "gbϥ-b́L8BgSEU7\x}K.~ĸ"攨N9ʌJ+Q-iJ6sH|b$# H/4=|_ %1-h!=$Q{/ T=p#eկ5lY/iW鵜wwXʩH8auNE3[lmyL}< 0SGGvhG6*mT>ڨ|Qhs7h4x4d4t4l4hѨ1$ӐLC2 4$v:u8`WZ3A.جb+rAPrNql Hd?Lg2ZO 5f ixqPhD9F5$~98si vN; vd\i$숛# 򋺣Z& +ۙ0N,9/]+3"-ϸ̩?+{": `6h DG=h4 $A fip"~ix7S ͹ϐXʯ旅geo\K ϒů-PfPt9o:tgKdP,$DZ=^^E7-CV]J"" 'K$v\ ڵקr~o0~|Է`a.KBhžvn!BRU]d86PZ]ja<ï&Q/{흴Lh(Bc嘰 +kBo<2%W??]}:=&:6 *. endstream endobj 4481 0 obj << /Length 4337 /Filter /FlateDecode >> stream xڭ\[۸~УʃCZodכq*#qlJӍ ^5~{u3wo,ɴO&(BnU kûfB%TP w\mO>1w]ݔ]YWsw/>XBl'_\DSvP1S| bSu5ԻmƷա2_L#Ym Ԉ=$S1| U>m[>—۲NPqrկ*|.2{8HԦa>!D^?b#BťvFHfc?0?8, ,K|^XNmap^"xXM= v̾.TM@;ᄟnwus][ˤsfp#؏B.^Qѹ0aE+Q~8!)A\ܠ>ᦋq1?LV[AmyǶ  !H~0!JU5#UM9K@[K%+㧠=f05=Wt[)SS9j2NH'U2DQѤJ=SřIY6'紬&Ԭ0,Ya袚U5݆_/yM`Qb^XTK4מP5lF$WJi xg'cx#MZ>q~!o޵]h+M7,VO0e %kJlQ~8c'Cڱ6?Pp(bEIcv*L@/Vj 7?[AxXπ?Рg`g|hx ƹk~2B3@?i-dvelŤߍ)k1*kgHH, }Et谵Qw"O֩?;"PK4ؤG ( ؜࿚|D3>~?.?I_L>:yn5(YxVt(n:A~e jq`!RMǪ^}p uqùOL8yLo[*編frMjWcc}x!fF=]tSQr^6np+l^Ð\aeU4]z,?}^} * \!D.|UiStp{B2Vr``rp @zE'~AflA._Z wi,nv!}2(گ(LzcA7ˑO {=-JD X:1{c#,F ;.6dDyN4,㗆{ .)?daqTOX˰rm fUn=1; u`e}Io;B z#A @=iWD-.|1Ȁ5v}%z<I (ge ;uv ~yVI/K: :ӏK &h+ÈPlwr@~(?\mكEEf#Xġ3݇^N787J3Xq@bg z]P+J%$($na%Hz!4R1;(Z.)8ȅ'x ġ90$?-,~!d1!x3"0S=O3ıv0x 5E|iZo}2D[ %)R;YZ-:jۏ?p "pUu 2J'")Ǔ>*,=m\P*nB#˽T P1TH30cOn0H-6%Unk[0lhw[]y?.*t..R~4v0GџSr8gyB^zSrюW8.]H6OSV+.m9> gP>['f8g+][>KؘpJ|\;{Do ݰ0*6z;׿f``WV+ud 臙ufq\vܢ,s8i[= 0@aݮ;SHG;AQ ֓ػ#H?"$:ul2Jq~]ln8o}JZ'-I SVRJ,M ƞ u0*"+X"1*)9ND!_ƆAث8}}>z e@aql8Kw=1JGOjXbyQv8BOA4km lⰬlE[T7ҷ!uvi{q6}ULj )F -z˓#%V0:Gۍx`WZBz+$v4{y{k!¼ C( L2hB!rMhr0DH Ɔ$ fE;rn1Dl CZCt^p*(Vs'>ؒXM4;FDX6UH-Us)NBTd&ڭ]R~CTOpCs| vG>tJ%^{:uHEλ!zdd< cè ʰx@4z( :UmĹd.sPέ ӯ:L>>!Ȥ00^h`0Ĉz"V<=]9m"^* QzbCbMp11>$*pfz+iI)90] sr-fH>̮\ 12RGq̈qp B%ޅwqeo5':fYzNi $Kc'$< Pł@NUqn]`h`׵r/Cz&* Zfgp7vsn.F[Th -(8e\[$%A/\ۇ2ł:;UC=ڦ uZ*ѕn1"2}P%3&L^l*@TԀo脺DDģ\H OL+yb…?1qXE5LHI#s'L2yu=_4gl" P#sp0-B/cY`<|x z=8Xq1T ͆eP_*3a̷.>6(*=8Ş-{NLݝ9]1?YI+8ō!T+ג["[ iGو?Cr U;@Hwr vI [K_8>Y7i<1&֝lԺMR%AA[ d<{PnaKtEyouǔ>c@K, ,| ΦAgM~夑тK,NI "26k.5.&^X6*`}вJ΂JP̲Py*SإQ`rIπca a_Bn(i|7%>bI]BRJ8 2:+A= ?MI~+gŒ ??L,) d^vJ_2WM-I+nr~}#|v13 0uYSq% 3kPu6`VƔD13,v7½O2 2ClvMԀf )}&Z,#8WA8⡀f`q4qv]<6eMQC(K@UJ'Xcsq2C 5z o.k(+PЁI$KRl/DOUٝZh{ķ}MLv57/Un,l="Y}d ֝k@xnX8t jbl endstream endobj 4539 0 obj << /Length 3811 /Filter /FlateDecode >> stream x[KQSex?R)۵x'GaYHe=n$@Q3zl%U/"Mя!60coްx_>s7Fnf\ق[>3N\yp#Z56}YHj=vI 6U~6a]fv\ۧHL7B}M1sSWgS+WjU7b/>|zz?~ ]pVxÚ̳0鲭#hM᥅,w_Gˑ̈ LWyV;l grnwoe BY7o-q p5>k& >݄kXO־h=/n6 8xByFYhccY6 SĞ2\w8=M ;wvHM} 3 `]g;ܑ-Sw+ەtSq{Fo?>Q;,HfڷA.]Bp_8!sFk'ťk9M.GZk}*rMznY 7^GфHCDZ5 Av K$<b`Tl84Ƣn}Y ySp;@K$;. h˫o|\vFiokBI.mú^@ fKo,#mvmf !}Νy^+8 Ëڎ`@ށN3uy |Mڥ- n݄0'bOq{wؼ_ء X\~ >oWL 1з~-;O"I:Hܐ8NLjzz#'{a;W |̭agD0mk6mm[N!ĵdmO@_DQ݆n To_.qq >+/ м 0;A2!C`fͩ}ؑ6ئy,'['KTE=d2>-N8IӉ8iӋ4;@"$< 68/` Qc'Nm?how?SB|*U vM/L#K`D<f.d3&@dpmM3P8&Grb<< Uj@wr$ p7τğuyiв=3+в(؜>+B+Ibxڐ I4 X$4vZ-v);3‚SEs栩wUئuu MDZTD1R1)Xs*l05>v\5Ԫ`q&.bHt4h~S_ZjShif@jPN $P@_} ^rc4\q,H{o^C&B}H0SfS|̰4BāP#J^;O0Vw b`0{P@/Y J+ m%K)BmM7O3bO(p48t[HY~DVK=b/\c%܌췲/јvlBz?g+ X~e;ɜG.71ظ΃ևčćwg>>{Иa-`gFI~Xh{ $bX!4G̤`p1!0 E' u$B^*p({,_@8ӺOylUG*lzyn ̍S^J_qЕ<,Sj[CwJc0Y>U߄)e& ;}>s{r軗d({/'ip>‹5tBYs2@C\} ~-eB(9N=wSX}i-o2;:>@;?һKҮ(5` 7!r9kr!AL0!lX/ 2O=4˖2yٝ 0A2L6* 7*pj%CrInn@~$'oAam*˽H(cEp~Tr֎#$C׽hTD~=Tj}wU@a ֠}FB2,Ѣxx`} endstream endobj 4434 0 obj << /Type /ObjStm /N 100 /First 992 /Length 2611 /Filter /FlateDecode >> stream xڽZߏ ~߿B΋V$EJs8s$ζb5YmlnJJ'4OAE+WrT (.[sT W^ MaCW Ŀ,XX̷a$'Z0_K fl#-G(GS-Pw %_E()#"&ƗIGŕ)B\KpO@MZ$O@Ϩ'@1;͑:J׈ƠCkNjٿ ur6Μo_IhZ*CؠLl ]W]$AS/TΧU;!· uR|6<|>ﻰzl/Яzf͋^m~}f!AXsd(-G!Wð '}|ߟ| /"|?8X~ Y(nOC}ŐJKRof=--B9rQ$|+~15:ǟ~F+Pwo޼RꜦ m)7s[E) EbkKqEiKq)njU`)D+7U r[z?G7߯^L<:v7ׁ˿?<<\vb}wmxPaZ>RK}v}ŏ/!؊]gAvvz}e F6mŋ{xzr$H <<2<Đ<C:C:ꐬC 6$ېlC 6$ېlC 6$! eH.Crː\N0I~XiI_?9W9_4ɩFdy{TbAF~UL/5Q4d+ E\_4!6wxFń"lD:s+˟[1;IH < vG\]@鋏2gsI[QehiT,d٠Xd]枢y٨1 zvEua a2H¥YYuA;4#!uwooQM:"pIp-I7(SJuSKP;2{ٗ Z JzQW q>ak:vu+Gp7T 8\33+ Y`"48xeO(SN8Aahr9C 9:9GFզFr冔 )EVX (1Fg,#\ Q;8FnvUrW RvWZXRH<'e$ȶ6G žֳbL6&a |#@ͦ|@AaOM '|2fv(^!r^GK{]5ү7rNktM X]Nr3Ï-,Bn;fqʶ;{~9f$Ck%?E~4s(>Ou.>K47ks2meqU !ȃA diH!diH!diHcVcVcV!dyH!deH!Yd%:aϩ@b;`׸Dx6MQXldu\]n+CK}3Km2S;OE>ֹQoiMb/{nMy>[,bZZ||Tzʪի6ºZnO3A*(4Y 㑇Z[n#g=g Pd>:"nF ]Vҷ( ? MwTj='Q,ffl?'~0FяzBa[ܡG6x#};tv*Nͳn G?9C9r8x2A-Hr?ELU̧ӧSv$N,elgjٷ Xl">vi*8`pAГ endstream endobj 4593 0 obj << /Length 3644 /Filter /FlateDecode >> stream x[Ks6WUr7TJRcw&9P2e" IetDۻIm0C[F?ntq//4[Dj-S-tlq{suWw+4W°TQ!sЕ@NG#fM^\ Lo~b0Jl)% m91fGH->DI[\GF,CAHi$%LD$+o 7f{2TyWiNeF~fj6jy}k?{ٲ{rY9o|e^ap[ X1J"Ey(dS׼&{#i DԢ@=_aDkmz}'i}(Ѻ=g>e~VFDCҷ0S8`#ԛ:er0XfǬ%4RkPH=@cCZV}f#u&ًh4k9Oc e-@~8K▵acwuOpu vZ?;16~)'ax`o 5H  $C GxcDU9䍟Ę滏[ KJnSo}^<~tY,IP p1ʳcPpHW1}qRzpY/~uռf˴xfnp,)tW0|-ʷ^\رA]+̀t÷"wo7KPҿ^').1%&|`UOu|*d}R1f\y$SU6yips"Z8묅`D  #e%a6yVi0`ֻ|SgWu%l*vrWEՂ<'6jȻ|{u??0)}#@U4߯ C`cLiZzf2gZjwCϛ&l0V~ QX_xw `  f>Dcn]N!P5>2AASjϊm18zHhߓhg^4: g4ǜs -9N B#XȄ0E7}!̲&\"%o~t 5),>akMl7P<'OIg$$ X*gJŧS7̞T6h zDIӍJ5m7BRuWMm>{" I7xv@H0 bQciv;CI|рFI͋Ӂzx.}yAM"yul}9;&DSJ Y$E<7|~jyphc4T6R,`,`D@%߉xqg.Nxqvx\rw3{{+bTbsE{/!Q<{`ׄT}O1==3n}OQ#h~EШr{bD}OA=W}OV3|oO{Q:cs }AvmQ}uxЏ-4|[mƉil+cN7ʟX-_DCGu_ArvJ2ǂgwIǡmCI23ZhQ弈&1|Xy6$+ll ޹ijf}6h5|+=/lvNjxt44!XEs(Jpj2k|7޾x; dZ/%?P!fl$ G?k i8_~WIM3LfsQ-?b*.Oy_zIm[{?!-4煑8a/[|T ~u!"1CXDK Cۡaj K- !;F)X̛c¶ɜV ArYz8s+uҗR:QCP1OGP7S`ǐ4pG$ Ҋ@F ^#a`m8m^>'a'aͮHE73l~v$03|*jR9ёhnhGN4ȉ>Nܤ#їWD4a!Ӈ.YG=v:DW-jd.|d,`pHkurC8L.s>./u ƒV׻Ͱ;{f{jc*#?{`StC9U΁xpAeޕO yJ2 sw8d[a\;J7Ř7sDQ SR00Bn`oxO \_\l\Dv` k/8cAwivdď8}3ؒSWf+,~v .&yc| v}ȇf4ͱ3o;u|QUo_7#l#O.KwD%Iw+8@pqLF4 #B>LÐF0` ?$h?@S&=+v?v>:;H]5P8VIWX Rd:nYUq6!ҾC) 59JL|!!v;9:"BO|ڔ{?Gy~,+j_zCFŒ{N?fǓn!8XP9:3m@JsC#/*TGmϮ(R.9lajŲ9c[֒Sz-d@vkj\Ac&)H"swF t-y; lVgS` A~%rʩv)L>c@ $4𖼹uP S額gs7. +bUw?`|5tu ٿoQMm .@c7cgzfq$9z4M̤&tOShN@qz|ȍځc*z$9 қ6ދ7xO?1Dח;]SbE[.]#e@`Fp?;_G0ȨUK8V(4j(`_#8&CXÞkU#*k#wd,۬,͘[p[yVF8oOI -wUz= w>NP󴧷PHɛ>> stream xڭ[[~_S":ު}`OvqCba~VKى,)rMW+ |_[Yb^VBq&^0vyӇ/p_q;1YYX`s1֮]،ֻiv#mUmQoo6VbGۇYu8Z7~\MglsXPiRǣ[u)o|KcHwH4l3U/?}3F d%&m}rcC ?t̴?p5pƲ$YUiQg FqH}Ӻz4sjv2Y !A+јi|[+Ԫ$=pڷqTԁ]3!"|kEILE}DzU qnY?ZDgç:JC6:(Yd@`q|} D"Y5elz!M 'UEӈEpoIH{Ozzʁ}yo-|:&=@7~̙ ?6{J9GW ƝV5Ov\0ie)P^}Ms:Ž{u`Qna|_}H'^\\ӌ^ͅ3sSkA &Z9vlL,jgJLlդh?{H]c OE]xc m;;5֝:|.Hz&z]9 1r%K F b !chL|uw]Wې,R<~v`nN0n[AoXN\j/.8=M#(U ĖI՝>>XJ"M1RmLcͼ#7 '998%v:2cXXw pFCPrME4DyOUBHng}]Tq˙{),̋\E[DdGֵ=UQ NrɑҺ>t|E 韋j9sfOИ+Ké3joWr&Yby!X{]oCDXMhcMѓd]tXdDS =S̢U @i$lڴ>g73RX|7L|*U_N !&݁$v N5$Nwġ MS^ yAv+W}2tv[fO&Wur<#^w-eYp4qCF w9]SOmNt۟rl=h 5whT- yi ν>D]Eۏ` gZvK p%taU6$ ou>L]?>?NaܽJ)8C| Mvqޗ}8C]#%諊̙#.$;GbLJ".il'} u+mhXK{e'!Ev ;lz; 9HQ gM QH7v=r[@OS7I*3BM^#PQ2D(eT@EgAEс8ǐ0:Fp *.{XQteK.I&ŞkB*/dr ms@cD} 0'/ݗpIQ2pVwp\R P{7tϔ3f,?,9G["K]p.ZSNc^xMYHfJ$I ^b3Ťy]qqIqS};& 4H_@]qKD@;OwSm !\5thNg#؏jCK_}Z߈x}!֞ iЪb:?0)|`RI] d?1'Wub5|A2{:5bX^C?w7hL<&t#p;.7˙1ntp;v*؉g2dqJ t֪jP]?R)gQyҴ,KHGI!x()czɞ% blv)&=q6G*cw4st^'t 5A#l* nͩ!uO\p8h\*xϜ)ˢym/a(~惐f(Ccfvkt'!P3Yptꛯn_ $a;SUvx|A0LVZTӛk#5d|= 5qc|(/=KR~ʩ:uDMgECOb&-o%K cEIE5]BQJdg\Dz<7 4iYtL|{TłY6H3euɓ҆q\Fv遗I"pJ\, ]V3x]&GGFv'de:g^׮F*siKM~y_:IAO)zeQ\Nۂchp]u,)rlZ@wP gҡݒ } wc&}y+>% )Y-(n*k b9,|Gb86^ уAc$܌p*3rtU'XԝCFBp" ;M|+]d)U<`Lzw~9v*ˆh^Bnhd6}z˩|;?O/-uE;sA=DxmK`q,o9s qrfU)rk$ˏ⨐نqg>0LI ^ǻh s7 'PLA$쭰c'4 endstream endobj 4547 0 obj << /Type /ObjStm /N 100 /First 1000 /Length 2497 /Filter /FlateDecode >> stream xڽ[o~ !gHؕM E~PCau~û9ō{'pv8?9RJ-dF@jWC- -%!6fKDiJ e,d8ծqfJ(!+)Pe(9(Fa$ $u\zkM@)7Lh S[ݮ9e J g6j`郒 {i tXAŤbaxJ&q ؊:]=|Öٲ$8Vt-FOwE6xI$q ] ݞbՂP A 45 T)ZTـWNKgh *doTePJBK{~ }0 *x^n+ޙ ~=C5 ]ZPjkZmW 6`?mszJ'{D YwM_ 6BP}l>Ls؛PCnL@b-fLEdn*4 $.PTQ ;ǫ ﮯϻ1~/ ]y<ͻ]x 3 ͤc6C Q]x8/6G?xgo+zP-Q΂K8JCkN$&N"r }I oCBQ9H1z/7Q$":ST,]"UywbiLl!}ln~ ;sfs9H Z?s6@Xgݑ@l~>eVΛmΝ !P(bsX?~\vnxnj y\X/׻VA.$jP(~iea+5~q}w1O/.>_\kzwkπjfxxns/Ƶl~yS+eg'㋫ϒax (DiNQ r(N8 :ᜫs,Y8gq9s,Y:gu9sVY:望snι9۞e+syX^IøTUS)ʫ#Cy5H>E)EcKN"㪓@$q .@xQ0.&BlfG^j3Y"${3RVBH ±l:_+ď`xplՎ#)CJ&)KI#+6˛:gLaށvGgYV-fҺ% 0 9Q'^ƋTEQ ÝIUNE@^tz 8-գD T2 $G '+E$6W`F U6$> e\31֓I2G+*ÏɓCZTJ 6DeO#(V Gj C"R.+MhE+QٟC뢨Ůc8͋ #;vj!VZ|` QڟfՎ&F]R$Hpyk6k@|sֿv I$ZTWrbH[R%J@ʲ;\XktEu-@bLarБl5i #W0_6ۏ?bu@Mar5)-{Cߝe;4@\Jd) FreitTG=TyErf`4i<ˆ wRdٳ-Ss^ #e]}qZ͚bg:%9@sq$~^vcjd>ʣP:- ]N3Fxh7͛]CJA5E;Rml(s!9!aT3gJ4w6+әHĚ; h>ޔ`e6sa#а5l?4l((((([܁NDq:!N 眝sv9g眝sv9g眝sv9s&LΙ39gr9sfΙ3%[8szsrpmV8 Ɏ'&*)]Nied 3o !Q֐dQx#w")9H_)Qab6q`.OY4#-T&}\8@BgM=RLq$Hb k`t혼a\z>rnqSg> stream xڽ[KsﯘK'A*Ǖu8%@Pk9Br,˿>h9('9Hb߱؅o}!<-Lnv\THrrw7ݏ7}bIǯ~ (eRVյ")ƪwŶlzյ2l'NGz鮸N~a`c0t`)0rWež;>6N >]qtW4 vװR>]ݤ` YrS{h ,Kh{jxҗf)tv[;5u_kz n GdŸxf凯''t*)|w73±/O/O?0{ug7wh=6i^,6.RZHOY{Ik vw<!p{wO˝TR򤤪;?Pi@=h ՅC=|rH-av>#8 i0&jڧGlk'I X֭=_}ٝ]$"ש ph ʲ]SedDi|*j}3aWOEHy@邒!3M,R$_<-A;ϨU`WzϻAtKm5 @^e谖I=F7s